From ff84897f63000f085a5d45c1deaa826ad51989a9 Mon Sep 17 00:00:00 2001 From: Lauren Chilutti Date: Fri, 1 Apr 2022 12:23:42 -0400 Subject: [PATCH] Public Release of SHiELD_Physics containing updates from GFDL Weather and Climate Dynamics Division --- FV3GFS/FV3GFS_io.F90 | 6383 +++++ GFS_layer/GFS_abstraction_layer.F90 | 47 + GFS_layer/GFS_diagnostics.F90 | 3462 +++ GFS_layer/GFS_driver.F90 | 751 + GFS_layer/GFS_physics_driver.F90 | 4104 +++ GFS_layer/GFS_radiation_driver.F90 | 1907 ++ GFS_layer/GFS_restart.F90 | 184 + GFS_layer/GFS_typedefs.F90 | 3748 +++ IPD_layer/IPD_driver.F90 | 141 + IPD_layer/IPD_typedefs.F90 | 76 + LICENSE.md | 157 + README.md | 33 + atmos_drivers/coupled/atmos_model.F90 | 826 + atmos_drivers/solo/atmos_model.F90 | 356 + gsmphys/GFDL_parse_tracers.F90 | 41 + gsmphys/aer_cloud.F | 3994 +++ gsmphys/calpreciptype.f90 | 1412 ++ gsmphys/cldmacro.F | 2372 ++ gsmphys/cldwat2m_micro.F | 5498 ++++ gsmphys/cnvc90.f | 90 + gsmphys/co2hc.f | 1738 ++ gsmphys/cs_conv.f90 | 3873 +++ gsmphys/date_def.f | 13 + gsmphys/dcyc2.f | 250 + gsmphys/dcyc2.pre.rad.f | 206 + gsmphys/efield.f | 3241 +++ gsmphys/funcphys.f90 | 2899 +++ gsmphys/gcm_shoc.f90 | 1713 ++ gsmphys/gcycle.F90 | 256 + gsmphys/get_prs.f | 380 + gsmphys/get_prs_fv3.f90 | 60 + gsmphys/gfs_phy_tracer_config.f | 232 + gsmphys/gocart_tracer_config_stub.f | 17 + gsmphys/gscond.f | 521 + gsmphys/gscondp.f | 358 + gsmphys/gwdc.f | 1353 + gsmphys/gwdps.f | 1272 + gsmphys/h2o_def.f | 12 + gsmphys/h2oc.f | 894 + gsmphys/h2ohdc.f | 165 + gsmphys/h2ointerp.f90 | 189 + gsmphys/h2ophys.f | 100 + gsmphys/idea_co2.f | 73 + gsmphys/idea_composition.f | 237 + gsmphys/idea_dissipation.f | 191 + gsmphys/idea_h2o.f | 95 + gsmphys/idea_ion.f | 1845 ++ gsmphys/idea_o2_o3.f | 153 + gsmphys/idea_phys.f | 605 + gsmphys/idea_solar_heating.f | 1227 + gsmphys/idea_tracer.f | 419 + gsmphys/ideaca.f | 232 + gsmphys/iounitdef.f | 94 + gsmphys/lrgsclr.f | 289 + gsmphys/m_micro_driver.f90 | 1262 + gsmphys/machine.F | 31 + gsmphys/mersenne_twister.f | 498 + gsmphys/mfdeepcnv.f | 2265 ++ gsmphys/mfpbl.f | 392 + gsmphys/mfpblt.f | 440 + gsmphys/mfpbltq.f | 457 + gsmphys/mfscu.f | 545 + gsmphys/mfscuq.f | 539 + gsmphys/mfshalcnv.f | 1451 ++ gsmphys/module_bfmicrophysics.f | 3199 +++ gsmphys/module_nst_model.f90 | 924 + gsmphys/module_nst_parameters.f90 | 143 + gsmphys/module_nst_water_prop.f90 | 703 + gsmphys/module_sf_noahmp_glacier.f90 | 2991 +++ gsmphys/module_sf_noahmplsm.f90 | 8201 ++++++ gsmphys/module_wrf_utl.f90 | 53 + gsmphys/moninedmf.f | 1307 + gsmphys/moninp.f | 547 + gsmphys/moninp1.f | 556 + gsmphys/moninq.f | 942 + gsmphys/moninq1.f | 940 + gsmphys/moninshoc.f | 475 + gsmphys/mstadb.f | 80 + gsmphys/mstadbtn.f | 91 + gsmphys/mstadbtn2.f | 91 + gsmphys/mstcnv.f | 316 + gsmphys/myj_jsfc.F90 | 1345 + gsmphys/myj_pbl.F90 | 2126 ++ gsmphys/namelist_soilveg.f | 49 + gsmphys/noahmp_tables.f90 | 956 + gsmphys/num_parthds.F | 23 + gsmphys/ozinterp.f90 | 195 + gsmphys/ozne_def.f | 14 + gsmphys/ozphys.f | 153 + gsmphys/ozphys_2015.f | 108 + gsmphys/physcons.f90 | 172 + gsmphys/physparam.f | 309 + gsmphys/precpd.f | 719 + gsmphys/precpd_shoc.f | 438 + gsmphys/precpdp.f | 570 + gsmphys/progt2.f | 246 + gsmphys/progtm_module.f | 93 + gsmphys/rad_initialize.f | 224 + gsmphys/radiation_aerosols.f | 5501 ++++ gsmphys/radiation_astronomy.f | 1055 + gsmphys/radiation_clouds.F | 4209 +++ gsmphys/radiation_gases.f | 1169 + gsmphys/radiation_surface.f | 814 + gsmphys/radlw_datatb.f | 32462 ++++++++++++++++++++++++ gsmphys/radlw_main.f | 6675 +++++ gsmphys/radlw_param.f | 162 + gsmphys/radsw_datatb.f | 22084 ++++++++++++++++ gsmphys/radsw_main.f | 5383 ++++ gsmphys/radsw_param.f | 202 + gsmphys/rascnvv2.f | 4321 ++++ gsmphys/rayleigh_damp.f | 90 + gsmphys/rayleigh_damp_mesopause.f | 105 + gsmphys/samfaerosols.f | 803 + gsmphys/samfdeepcnv.f | 2797 ++ gsmphys/samfshalcnv.f | 1810 ++ gsmphys/sascnv.f | 1771 ++ gsmphys/sascnvn.f | 2043 ++ gsmphys/satmedmfvdiff.f | 1566 ++ gsmphys/satmedmfvdifq.f | 1592 ++ gsmphys/set_soilveg.F | 445 + gsmphys/sfc_cice.f | 112 + gsmphys/sfc_diag.f | 60 + gsmphys/sfc_diff.f | 421 + gsmphys/sfc_diff_gfdl.f | 614 + gsmphys/sfc_drv.f | 602 + gsmphys/sfc_land.f | 1079 + gsmphys/sfc_noahmp_drv.f | 1139 + gsmphys/sfc_nst.f | 570 + gsmphys/sfc_ocean.f | 147 + gsmphys/sfc_sice.f | 652 + gsmphys/sfcsub.F | 8705 +++++++ gsmphys/sflx.f | 5571 ++++ gsmphys/shalcnv.f | 1281 + gsmphys/shalcv.f | 205 + gsmphys/shalcv_1lyr.f | 188 + gsmphys/shalcv_fixdp.f | 194 + gsmphys/shalcv_opr.f | 164 + gsmphys/som_mlm.F90 | 539 + gsmphys/surface_perturbation.F90 | 419 + gsmphys/tracer_const_h.f | 62 + gsmphys/tridi2t3.f | 41 + gsmphys/wam_f107_kp_mod.f90 | 75 + gsmphys/wv_saturation.F | 1574 ++ gsmphys/ysupbl.F90 | 1519 ++ simple_coupler/coupler_main.F90 | 516 + 145 files changed, 221471 insertions(+) create mode 100644 FV3GFS/FV3GFS_io.F90 create mode 100644 GFS_layer/GFS_abstraction_layer.F90 create mode 100644 GFS_layer/GFS_diagnostics.F90 create mode 100644 GFS_layer/GFS_driver.F90 create mode 100644 GFS_layer/GFS_physics_driver.F90 create mode 100644 GFS_layer/GFS_radiation_driver.F90 create mode 100644 GFS_layer/GFS_restart.F90 create mode 100644 GFS_layer/GFS_typedefs.F90 create mode 100644 IPD_layer/IPD_driver.F90 create mode 100644 IPD_layer/IPD_typedefs.F90 create mode 100644 LICENSE.md create mode 100644 README.md create mode 100644 atmos_drivers/coupled/atmos_model.F90 create mode 100644 atmos_drivers/solo/atmos_model.F90 create mode 100644 gsmphys/GFDL_parse_tracers.F90 create mode 100644 gsmphys/aer_cloud.F create mode 100644 gsmphys/calpreciptype.f90 create mode 100644 gsmphys/cldmacro.F create mode 100644 gsmphys/cldwat2m_micro.F create mode 100644 gsmphys/cnvc90.f create mode 100644 gsmphys/co2hc.f create mode 100644 gsmphys/cs_conv.f90 create mode 100644 gsmphys/date_def.f create mode 100644 gsmphys/dcyc2.f create mode 100644 gsmphys/dcyc2.pre.rad.f create mode 100644 gsmphys/efield.f create mode 100644 gsmphys/funcphys.f90 create mode 100644 gsmphys/gcm_shoc.f90 create mode 100644 gsmphys/gcycle.F90 create mode 100644 gsmphys/get_prs.f create mode 100644 gsmphys/get_prs_fv3.f90 create mode 100644 gsmphys/gfs_phy_tracer_config.f create mode 100644 gsmphys/gocart_tracer_config_stub.f create mode 100644 gsmphys/gscond.f create mode 100755 gsmphys/gscondp.f create mode 100644 gsmphys/gwdc.f create mode 100644 gsmphys/gwdps.f create mode 100644 gsmphys/h2o_def.f create mode 100644 gsmphys/h2oc.f create mode 100644 gsmphys/h2ohdc.f create mode 100755 gsmphys/h2ointerp.f90 create mode 100755 gsmphys/h2ophys.f create mode 100644 gsmphys/idea_co2.f create mode 100644 gsmphys/idea_composition.f create mode 100644 gsmphys/idea_dissipation.f create mode 100644 gsmphys/idea_h2o.f create mode 100644 gsmphys/idea_ion.f create mode 100644 gsmphys/idea_o2_o3.f create mode 100644 gsmphys/idea_phys.f create mode 100644 gsmphys/idea_solar_heating.f create mode 100644 gsmphys/idea_tracer.f create mode 100644 gsmphys/ideaca.f create mode 100644 gsmphys/iounitdef.f create mode 100644 gsmphys/lrgsclr.f create mode 100644 gsmphys/m_micro_driver.f90 create mode 100644 gsmphys/machine.F create mode 100644 gsmphys/mersenne_twister.f create mode 100755 gsmphys/mfdeepcnv.f create mode 100755 gsmphys/mfpbl.f create mode 100644 gsmphys/mfpblt.f create mode 100644 gsmphys/mfpbltq.f create mode 100644 gsmphys/mfscu.f create mode 100644 gsmphys/mfscuq.f create mode 100755 gsmphys/mfshalcnv.f create mode 100644 gsmphys/module_bfmicrophysics.f create mode 100644 gsmphys/module_nst_model.f90 create mode 100644 gsmphys/module_nst_parameters.f90 create mode 100644 gsmphys/module_nst_water_prop.f90 create mode 100644 gsmphys/module_sf_noahmp_glacier.f90 create mode 100644 gsmphys/module_sf_noahmplsm.f90 create mode 100644 gsmphys/module_wrf_utl.f90 create mode 100755 gsmphys/moninedmf.f create mode 100644 gsmphys/moninp.f create mode 100644 gsmphys/moninp1.f create mode 100644 gsmphys/moninq.f create mode 100644 gsmphys/moninq1.f create mode 100644 gsmphys/moninshoc.f create mode 100644 gsmphys/mstadb.f create mode 100644 gsmphys/mstadbtn.f create mode 100644 gsmphys/mstadbtn2.f create mode 100644 gsmphys/mstcnv.f create mode 100644 gsmphys/myj_jsfc.F90 create mode 100644 gsmphys/myj_pbl.F90 create mode 100644 gsmphys/namelist_soilveg.f create mode 100644 gsmphys/noahmp_tables.f90 create mode 100644 gsmphys/num_parthds.F create mode 100644 gsmphys/ozinterp.f90 create mode 100644 gsmphys/ozne_def.f create mode 100644 gsmphys/ozphys.f create mode 100755 gsmphys/ozphys_2015.f create mode 100644 gsmphys/physcons.f90 create mode 100755 gsmphys/physparam.f create mode 100644 gsmphys/precpd.f create mode 100644 gsmphys/precpd_shoc.f create mode 100755 gsmphys/precpdp.f create mode 100644 gsmphys/progt2.f create mode 100644 gsmphys/progtm_module.f create mode 100644 gsmphys/rad_initialize.f create mode 100644 gsmphys/radiation_aerosols.f create mode 100644 gsmphys/radiation_astronomy.f create mode 100644 gsmphys/radiation_clouds.F create mode 100644 gsmphys/radiation_gases.f create mode 100644 gsmphys/radiation_surface.f create mode 100644 gsmphys/radlw_datatb.f create mode 100644 gsmphys/radlw_main.f create mode 100644 gsmphys/radlw_param.f create mode 100644 gsmphys/radsw_datatb.f create mode 100644 gsmphys/radsw_main.f create mode 100644 gsmphys/radsw_param.f create mode 100644 gsmphys/rascnvv2.f create mode 100755 gsmphys/rayleigh_damp.f create mode 100755 gsmphys/rayleigh_damp_mesopause.f create mode 100644 gsmphys/samfaerosols.f create mode 100644 gsmphys/samfdeepcnv.f create mode 100644 gsmphys/samfshalcnv.f create mode 100644 gsmphys/sascnv.f create mode 100644 gsmphys/sascnvn.f create mode 100644 gsmphys/satmedmfvdiff.f create mode 100644 gsmphys/satmedmfvdifq.f create mode 100644 gsmphys/set_soilveg.F create mode 100644 gsmphys/sfc_cice.f create mode 100644 gsmphys/sfc_diag.f create mode 100644 gsmphys/sfc_diff.f create mode 100644 gsmphys/sfc_diff_gfdl.f create mode 100644 gsmphys/sfc_drv.f create mode 100644 gsmphys/sfc_land.f create mode 100644 gsmphys/sfc_noahmp_drv.f create mode 100644 gsmphys/sfc_nst.f create mode 100644 gsmphys/sfc_ocean.f create mode 100644 gsmphys/sfc_sice.f create mode 100644 gsmphys/sfcsub.F create mode 100644 gsmphys/sflx.f create mode 100644 gsmphys/shalcnv.f create mode 100644 gsmphys/shalcv.f create mode 100644 gsmphys/shalcv_1lyr.f create mode 100644 gsmphys/shalcv_fixdp.f create mode 100644 gsmphys/shalcv_opr.f create mode 100644 gsmphys/som_mlm.F90 create mode 100644 gsmphys/surface_perturbation.F90 create mode 100644 gsmphys/tracer_const_h.f create mode 100644 gsmphys/tridi2t3.f create mode 100644 gsmphys/wam_f107_kp_mod.f90 create mode 100644 gsmphys/wv_saturation.F create mode 100644 gsmphys/ysupbl.F90 create mode 100644 simple_coupler/coupler_main.F90 diff --git a/FV3GFS/FV3GFS_io.F90 b/FV3GFS/FV3GFS_io.F90 new file mode 100644 index 00000000..259b100d --- /dev/null +++ b/FV3GFS/FV3GFS_io.F90 @@ -0,0 +1,6383 @@ +module FV3GFS_io_mod + +!----------------------------------------------------------------------- +! gfs_physics_driver_mod defines the GFS physics routines used by +! the GFDL FMS system to obtain tendencies and boundary fluxes due +! to the physical parameterizations and processes that drive +! atmospheric time tendencies for use by other components, namely +! the atmospheric dynamical core. +! +! NOTE: This module currently supports only the operational GFS +! parameterizations as of September 2015. Further development +! is needed to support the full suite of physical +! parameterizations present in the GFS physics package. +!----------------------------------------------------------------------- +! +!--- FMS/GFDL modules + use block_control_mod, only: block_control_type + use mpp_mod, only: mpp_error, mpp_pe, mpp_root_pe, & + mpp_chksum, NOTE, FATAL, mpp_get_current_pelist_name + use mpp_domains_mod, only: domain2d, mpp_get_compute_domain + use fms_mod, only: stdout + use fms2_io_mod, only: FmsNetcdfDomainFile_t, unlimited, & + open_file, close_file, register_field, & + register_axis, register_restart_field, & + register_variable_attribute, & + read_restart, write_restart, & + get_global_io_domain_indices, & + dimension_exists, write_data + use time_manager_mod, only: time_type + use data_override_mod, only: data_override + use diag_manager_mod, only: register_diag_field, send_data + use fv_mp_mod, only: is_master, mp_reduce_sum, mp_reduce_min, mp_reduce_max +! +!--- GFS physics modules + use machine, only: kind_phys +!--- variables needed for calculating 'sncovr' + use namelist_soilveg, only: salp_data, snupx + +! +! --- variables needed for Noah MP init +! + use noahmp_tables, only: laim_table,saim_table,sla_table, & + bexp_table,smcmax_table,smcwlt_table, & + dwsat_table,dksat_table,psisat_table, & + isurban_table,isbarren_table, & + isice_table,iswater_table + +! +!--- GFS_typedefs + use GFS_typedefs, only: GFS_sfcprop_type, GFS_diag_type, GFS_grid_type + use GFS_typedefs, only: GFS_cldprop_type + use ozne_def, only: oz_coeff +! +!--- IPD typdefs + use IPD_typedefs, only: IPD_control_type, IPD_data_type, & + IPD_restart_type +!--- GFS physics constants + use physcons, only: pi => con_pi, RADIUS => con_rerth, rd => con_rd +!--- needed for dq3dt output + use ozne_def, only: oz_coeff +!--- needed for cold-start capability to initialize q2m + use gfdl_cld_mp_mod, only: wqs1, qsmith_init + use coarse_graining_mod, only: block_mode, block_upsample, block_min, block_max, block_sum, weighted_block_average + use coarse_graining_mod, only: MODEL_LEVEL, PRESSURE_LEVEL + use coarse_graining_mod, only: vertical_remapping_requirements, get_coarse_array_bounds + use coarse_graining_mod, only: vertically_remap_field, mask_area_weights +! +!----------------------------------------------------------------------- + implicit none + private + + !--- public interfaces --- + public FV3GFS_restart_read, FV3GFS_restart_write, FV3GFS_restart_write_coarse + public FV3GFS_IPD_checksum + public gfdl_diag_register, gfdl_diag_output + public FV3GFS_diag_register_coarse, register_diag_manager_controlled_diagnostics + public register_coarse_diag_manager_controlled_diagnostics + public send_diag_manager_controlled_diagnostic_data + public sfc_data_override + + !--- GFDL filenames + character(len=32) :: fn_oro = 'oro_data.nc' + character(len=32) :: fn_srf = 'sfc_data.nc' + character(len=32) :: fn_phy = 'phy_data.nc' + + !--- GFDL FMS netcdf restart data types + type(FmsNetcdfDomainFile_t) :: Oro_restart + type(FmsNetcdfDomainFile_t) :: Sfc_restart + type(FmsNetcdfDomainFile_t) :: Phy_restart + + !--- GFDL FMS restart containers + character(len=32), allocatable, dimension(:) :: oro_name2, sfc_name2, sfc_name3 + real(kind=kind_phys), allocatable, target, dimension(:,:,:) :: oro_var2, sfc_var2, phy_var2 + real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3, phy_var3 + !--- Noah MP restart containers + real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3sn,sfc_var3eq,sfc_var3zn + + ! Coarse graining + real(kind=kind_phys), allocatable, target, dimension(:,:,:) :: sfc_var2_coarse + real(kind=kind_phys), allocatable, target, dimension(:,:,:,:) :: sfc_var3_coarse + type(FmsNetcdfDomainFile_t) :: Sfc_restart_coarse + + integer :: isco, ieco, jsco, jeco, levo + +!-RAB + type data_subtype + real(kind=kind_phys), dimension(:), pointer :: var2 => NULL() + real(kind=kind_phys), dimension(:,:), pointer :: var3 => NULL() + real(kind=kind_phys), dimension(:), pointer :: var21 => NULL() + end type data_subtype + !--- data type definition for use with GFDL FMS diagnostic manager until write component is working + type gfdl_diag_type + private + integer :: id + integer :: axes + logical :: time_avg + character(len=64) :: time_avg_kind + character(len=64) :: mod_name + character(len=128) :: name + character(len=128) :: desc + character(len=64) :: unit + character(len=64) :: mask + character(len=64) :: intpl_method + real(kind=kind_phys) :: cnvfac + type(data_subtype), dimension(:), allocatable :: data + + ! Add an attribute that specifies the coarse-graining method for the + ! variable. By default we will set this as unspecified and raise an error + ! if a user asks to coarse-grain a variable that does not have a supported + ! method for coarse-graining. Currently supported methods are: + ! + ! 'area_weighted' + ! 'mass_weighted' + ! + ! In the future we may want to support more methods, e.g. for the land + ! surface variables, which may require masking. + character(len=64) :: coarse_graining_method = 'unspecified' +!rab real(kind=kind_phys), dimension(:), pointer :: var2 => NULL() +!rab real(kind=kind_phys), dimension(:), pointer :: var21 => NULL() + end type gfdl_diag_type + real(kind=kind_phys) :: zhour +! + integer :: tot_diag_idx = 0 + integer, parameter :: DIAG_SIZE = 250 + real(kind=kind_phys), parameter :: missing_value = 9.99e20 + type(gfdl_diag_type), dimension(DIAG_SIZE) :: Diag, Diag_coarse, Diag_diag_manager_controlled, Diag_diag_manager_controlled_coarse +!-RAB + + +!--- miscellaneous other variables + logical :: module_is_initialized = .FALSE. + + character(len=64) :: AREA_WEIGHTED = 'area_weighted' + character(len=64) :: MASKED_AREA_WEIGHTED = 'masked_area_weighted' + character(len=64) :: MASS_WEIGHTED = 'mass_weighted' + character(len=64) :: MODE = 'mode' + + CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! PUBLIC SUBROUTINES +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +!-------------------- +! FV3GFS_restart_read +!-------------------- + subroutine FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, Model, fv_domain) + type(IPD_data_type), intent(inout) :: IPD_Data(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + type(block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(inout) :: Model + type(domain2d), intent(in) :: fv_domain + + !--- read in surface data from chgres + call sfc_prop_restart_read (IPD_Data%Sfcprop, Atm_block, Model, fv_domain) + + !--- read in + if (Model%sfc_override) call sfc_prop_override (IPD_Data%Sfcprop, IPD_Data%Grid, Atm_block, Model, fv_domain) + + !--- read in physics restart data + call phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) + + end subroutine FV3GFS_restart_read + +!--------------------- +! FV3GFS_restart_write +!--------------------- + subroutine FV3GFS_restart_write (IPD_Data, IPD_Restart, Atm_block, Model, fv_domain, timestamp) + type(IPD_data_type), intent(inout) :: IPD_Data(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + type(block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + type(domain2d), intent(in) :: fv_domain + character(len=32), optional, intent(in) :: timestamp + + !--- read in surface data from chgres + call sfc_prop_restart_write (IPD_Data%Sfcprop, Atm_block, Model, fv_domain, timestamp) + + !--- read in physics restart data + call phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timestamp) + + end subroutine FV3GFS_restart_write + + subroutine FV3GFS_restart_write_coarse (IPD_Data, IPD_Restart, Atm_block, Model, coarse_domain, timestamp) + type(IPD_data_type), intent(inout) :: IPD_Data(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + type(block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + type(domain2d), intent(in) :: coarse_domain + character(len=32), optional, intent(in) :: timestamp + + if (present(timestamp)) then + call sfc_prop_restart_write_coarse (IPD_Data%Sfcprop, Atm_block, Model, & + coarse_domain, IPD_Data%Grid, timestamp) + else + call sfc_prop_restart_write_coarse (IPD_Data%Sfcprop, Atm_block, Model, & + coarse_domain, IPD_Data%Grid) + endif + end subroutine FV3GFS_restart_write_coarse + +!-------------------- +! FV3GFS_IPD_checksum +!-------------------- + subroutine FV3GFS_IPD_checksum (Model, IPD_Data, Atm_block) + !--- interface variables + type(IPD_control_type), intent(in) :: Model + type(IPD_data_type), intent(in) :: IPD_Data(:) + type (block_control_type), intent(in) :: Atm_block + !--- local variables + integer :: outunit, j, i, ix, nb, isc, iec, jsc, jec, lev, ct, l, ntr + integer :: nsfcprop2d, idx_opt + real(kind=kind_phys), allocatable :: temp2d(:,:,:) + real(kind=kind_phys), allocatable :: temp3d(:,:,:,:) + character(len=32) :: name + + isc = Model%isc + iec = Model%isc+Model%nx-1 + jsc = Model%jsc + jec = Model%jsc+Model%ny-1 + lev = Model%levs + + ntr = size(IPD_Data(1)%Statein%qgrs,3) + + if(Model%lsm == Model%lsm_noahmp) then + nsfcprop2d = 154 + else + nsfcprop2d = 100 + endif + + allocate (temp2d(isc:iec,jsc:jec,nsfcprop2d+Model%ntot3d+Model%nctp)) + allocate (temp3d(isc:iec,jsc:jec,1:lev,17+Model%ntot3d+2*ntr)) + + temp2d = 0. + temp3d = 0. + + do j=jsc,jec + do i=isc,iec + nb = Atm_block%blkno(i,j) + ix = Atm_block%ixp(i,j) + !--- statein pressure + temp2d(i,j, 1) = IPD_Data(nb)%Statein%pgr(ix) + temp2d(i,j, 2) = IPD_Data(nb)%Sfcprop%slmsk(ix) + temp2d(i,j, 3) = IPD_Data(nb)%Sfcprop%tsfc(ix) + temp2d(i,j, 4) = IPD_Data(nb)%Sfcprop%tisfc(ix) + temp2d(i,j, 5) = IPD_Data(nb)%Sfcprop%snowd(ix) + temp2d(i,j, 6) = IPD_Data(nb)%Sfcprop%zorl(ix) + temp2d(i,j, 7) = IPD_Data(nb)%Sfcprop%fice(ix) + temp2d(i,j, 8) = IPD_Data(nb)%Sfcprop%hprime(ix,1) + temp2d(i,j, 9) = IPD_Data(nb)%Sfcprop%sncovr(ix) + temp2d(i,j,10) = IPD_Data(nb)%Sfcprop%snoalb(ix) + temp2d(i,j,11) = IPD_Data(nb)%Sfcprop%alvsf(ix) + temp2d(i,j,12) = IPD_Data(nb)%Sfcprop%alnsf(ix) + temp2d(i,j,13) = IPD_Data(nb)%Sfcprop%alvwf(ix) + temp2d(i,j,14) = IPD_Data(nb)%Sfcprop%alnwf(ix) + temp2d(i,j,15) = IPD_Data(nb)%Sfcprop%facsf(ix) + temp2d(i,j,16) = IPD_Data(nb)%Sfcprop%facwf(ix) + temp2d(i,j,17) = IPD_Data(nb)%Sfcprop%slope(ix) + temp2d(i,j,18) = IPD_Data(nb)%Sfcprop%shdmin(ix) + temp2d(i,j,19) = IPD_Data(nb)%Sfcprop%shdmax(ix) + temp2d(i,j,20) = IPD_Data(nb)%Sfcprop%tg3(ix) + temp2d(i,j,21) = IPD_Data(nb)%Sfcprop%vfrac(ix) + temp2d(i,j,22) = IPD_Data(nb)%Sfcprop%vtype(ix) + temp2d(i,j,23) = IPD_Data(nb)%Sfcprop%stype(ix) + temp2d(i,j,24) = IPD_Data(nb)%Sfcprop%uustar(ix) + temp2d(i,j,25) = IPD_Data(nb)%Sfcprop%oro(ix) + temp2d(i,j,26) = IPD_Data(nb)%Sfcprop%oro_uf(ix) + temp2d(i,j,27) = IPD_Data(nb)%Sfcprop%hice(ix) + temp2d(i,j,28) = IPD_Data(nb)%Sfcprop%weasd(ix) + temp2d(i,j,29) = IPD_Data(nb)%Sfcprop%canopy(ix) + temp2d(i,j,30) = IPD_Data(nb)%Sfcprop%ffmm(ix) + temp2d(i,j,31) = IPD_Data(nb)%Sfcprop%ffhh(ix) + temp2d(i,j,32) = IPD_Data(nb)%Sfcprop%f10m(ix) + temp2d(i,j,33) = IPD_Data(nb)%Sfcprop%tprcp(ix) + temp2d(i,j,34) = IPD_Data(nb)%Sfcprop%srflag(ix) + temp2d(i,j,35) = IPD_Data(nb)%Sfcprop%slc(ix,1) + temp2d(i,j,36) = IPD_Data(nb)%Sfcprop%slc(ix,2) + temp2d(i,j,37) = IPD_Data(nb)%Sfcprop%slc(ix,3) + temp2d(i,j,38) = IPD_Data(nb)%Sfcprop%slc(ix,4) + temp2d(i,j,39) = IPD_Data(nb)%Sfcprop%smc(ix,1) + temp2d(i,j,40) = IPD_Data(nb)%Sfcprop%smc(ix,2) + temp2d(i,j,41) = IPD_Data(nb)%Sfcprop%smc(ix,3) + temp2d(i,j,42) = IPD_Data(nb)%Sfcprop%smc(ix,4) + temp2d(i,j,43) = IPD_Data(nb)%Sfcprop%stc(ix,1) + temp2d(i,j,44) = IPD_Data(nb)%Sfcprop%stc(ix,2) + temp2d(i,j,45) = IPD_Data(nb)%Sfcprop%stc(ix,3) + temp2d(i,j,46) = IPD_Data(nb)%Sfcprop%stc(ix,4) + temp2d(i,j,47) = IPD_Data(nb)%Sfcprop%t2m(ix) + temp2d(i,j,48) = IPD_Data(nb)%Sfcprop%q2m(ix) + temp2d(i,j,49) = IPD_Data(nb)%Coupling%nirbmdi(ix) + temp2d(i,j,50) = IPD_Data(nb)%Coupling%nirdfdi(ix) + temp2d(i,j,51) = IPD_Data(nb)%Coupling%visbmdi(ix) + temp2d(i,j,52) = IPD_Data(nb)%Coupling%visdfdi(ix) + temp2d(i,j,53) = IPD_Data(nb)%Coupling%nirbmui(ix) + temp2d(i,j,54) = IPD_Data(nb)%Coupling%nirdfui(ix) + temp2d(i,j,55) = IPD_Data(nb)%Coupling%visbmui(ix) + temp2d(i,j,56) = IPD_Data(nb)%Coupling%visdfui(ix) + temp2d(i,j,57) = IPD_Data(nb)%Coupling%sfcdsw(ix) + temp2d(i,j,58) = IPD_Data(nb)%Coupling%sfcnsw(ix) + temp2d(i,j,59) = IPD_Data(nb)%Coupling%sfcdlw(ix) + temp2d(i,j,60) = IPD_Data(nb)%Grid%xlon(ix) + temp2d(i,j,61) = IPD_Data(nb)%Grid%xlat(ix) + temp2d(i,j,62) = IPD_Data(nb)%Grid%xlat_d(ix) + temp2d(i,j,63) = IPD_Data(nb)%Grid%sinlat(ix) + temp2d(i,j,64) = IPD_Data(nb)%Grid%coslat(ix) + temp2d(i,j,65) = IPD_Data(nb)%Grid%area(ix) + temp2d(i,j,66) = IPD_Data(nb)%Grid%dx(ix) + if (Model%ntoz > 0) then + temp2d(i,j,67) = IPD_Data(nb)%Grid%ddy_o3(ix) + endif + if (Model%h2o_phys) then + temp2d(i,j,68) = IPD_Data(nb)%Grid%ddy_h(ix) + endif + temp2d(i,j,69) = IPD_Data(nb)%Cldprop%cv(ix) + temp2d(i,j,70) = IPD_Data(nb)%Cldprop%cvt(ix) + temp2d(i,j,71) = IPD_Data(nb)%Cldprop%cvb(ix) + temp2d(i,j,72) = IPD_Data(nb)%Radtend%sfalb(ix) + temp2d(i,j,73) = IPD_Data(nb)%Radtend%coszen(ix) + temp2d(i,j,74) = IPD_Data(nb)%Radtend%tsflw(ix) + temp2d(i,j,75) = IPD_Data(nb)%Radtend%semis(ix) + temp2d(i,j,76) = IPD_Data(nb)%Radtend%coszdg(ix) + temp2d(i,j,77) = IPD_Data(nb)%Radtend%sfcfsw(ix)%upfxc + temp2d(i,j,78) = IPD_Data(nb)%Radtend%sfcfsw(ix)%upfx0 + temp2d(i,j,79) = IPD_Data(nb)%Radtend%sfcfsw(ix)%dnfxc + temp2d(i,j,80) = IPD_Data(nb)%Radtend%sfcfsw(ix)%dnfx0 + temp2d(i,j,81) = IPD_Data(nb)%Radtend%sfcflw(ix)%upfxc + temp2d(i,j,82) = IPD_Data(nb)%Radtend%sfcflw(ix)%upfx0 + temp2d(i,j,83) = IPD_Data(nb)%Radtend%sfcflw(ix)%dnfxc + temp2d(i,j,84) = IPD_Data(nb)%Radtend%sfcflw(ix)%dnfx0 + + idx_opt = 85 + if (Model%lsm == Model%lsm_noahmp) then + temp2d(i,j,idx_opt) = IPD_Data(nb)%Sfcprop%snowxy(ix) + temp2d(i,j,idx_opt+1) = IPD_Data(nb)%Sfcprop%tvxy(ix) + temp2d(i,j,idx_opt+2) = IPD_Data(nb)%Sfcprop%tgxy(ix) + temp2d(i,j,idx_opt+3) = IPD_Data(nb)%Sfcprop%canicexy(ix) + temp2d(i,j,idx_opt+4) = IPD_Data(nb)%Sfcprop%canliqxy(ix) + temp2d(i,j,idx_opt+5) = IPD_Data(nb)%Sfcprop%eahxy(ix) + temp2d(i,j,idx_opt+6) = IPD_Data(nb)%Sfcprop%tahxy(ix) + temp2d(i,j,idx_opt+7) = IPD_Data(nb)%Sfcprop%cmxy(ix) + temp2d(i,j,idx_opt+8) = IPD_Data(nb)%Sfcprop%chxy(ix) + temp2d(i,j,idx_opt+9) = IPD_Data(nb)%Sfcprop%fwetxy(ix) + temp2d(i,j,idx_opt+10) = IPD_Data(nb)%Sfcprop%sneqvoxy(ix) + temp2d(i,j,idx_opt+11) = IPD_Data(nb)%Sfcprop%alboldxy(ix) + temp2d(i,j,idx_opt+12) = IPD_Data(nb)%Sfcprop%qsnowxy(ix) + temp2d(i,j,idx_opt+13) = IPD_Data(nb)%Sfcprop%wslakexy(ix) + temp2d(i,j,idx_opt+14) = IPD_Data(nb)%Sfcprop%zwtxy(ix) + temp2d(i,j,idx_opt+15) = IPD_Data(nb)%Sfcprop%waxy(ix) + temp2d(i,j,idx_opt+16) = IPD_Data(nb)%Sfcprop%wtxy(ix) + temp2d(i,j,idx_opt+17) = IPD_Data(nb)%Sfcprop%lfmassxy(ix) + temp2d(i,j,idx_opt+18) = IPD_Data(nb)%Sfcprop%rtmassxy(ix) + temp2d(i,j,idx_opt+19) = IPD_Data(nb)%Sfcprop%stmassxy(ix) + temp2d(i,j,idx_opt+20) = IPD_Data(nb)%Sfcprop%woodxy(ix) + temp2d(i,j,idx_opt+21) = IPD_Data(nb)%Sfcprop%stblcpxy(ix) + temp2d(i,j,idx_opt+22) = IPD_Data(nb)%Sfcprop%fastcpxy(ix) + temp2d(i,j,idx_opt+23) = IPD_Data(nb)%Sfcprop%xsaixy(ix) + temp2d(i,j,idx_opt+24) = IPD_Data(nb)%Sfcprop%xlaixy(ix) + temp2d(i,j,idx_opt+25) = IPD_Data(nb)%Sfcprop%taussxy(ix) + temp2d(i,j,idx_opt+26) = IPD_Data(nb)%Sfcprop%smcwtdxy(ix) + temp2d(i,j,idx_opt+27) = IPD_Data(nb)%Sfcprop%deeprechxy(ix) + temp2d(i,j,idx_opt+28) = IPD_Data(nb)%Sfcprop%rechxy(ix) + + temp2d(i,j,idx_opt+29) = IPD_Data(nb)%Sfcprop%snicexy(ix,-2) + temp2d(i,j,idx_opt+30) = IPD_Data(nb)%Sfcprop%snicexy(ix,-1) + temp2d(i,j,idx_opt+31) = IPD_Data(nb)%Sfcprop%snicexy(ix,0) + temp2d(i,j,idx_opt+32) = IPD_Data(nb)%Sfcprop%snliqxy(ix,-2) + temp2d(i,j,idx_opt+33) = IPD_Data(nb)%Sfcprop%snliqxy(ix,-1) + temp2d(i,j,idx_opt+34) = IPD_Data(nb)%Sfcprop%snliqxy(ix,0) + temp2d(i,j,idx_opt+35) = IPD_Data(nb)%Sfcprop%tsnoxy(ix,-2) + temp2d(i,j,idx_opt+36) = IPD_Data(nb)%Sfcprop%tsnoxy(ix,-1) + temp2d(i,j,idx_opt+37) = IPD_Data(nb)%Sfcprop%tsnoxy(ix,0) + temp2d(i,j,idx_opt+38) = IPD_Data(nb)%Sfcprop%smoiseq(ix,1) + temp2d(i,j,idx_opt+39) = IPD_Data(nb)%Sfcprop%smoiseq(ix,2) + temp2d(i,j,idx_opt+40) = IPD_Data(nb)%Sfcprop%smoiseq(ix,3) + temp2d(i,j,idx_opt+41) = IPD_Data(nb)%Sfcprop%smoiseq(ix,4) + temp2d(i,j,idx_opt+42) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,-2) + temp2d(i,j,idx_opt+43) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,-1) + temp2d(i,j,idx_opt+44) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,0) + temp2d(i,j,idx_opt+45) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,1) + temp2d(i,j,idx_opt+46) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,2) + temp2d(i,j,idx_opt+47) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,3) + temp2d(i,j,idx_opt+48) = IPD_Data(nb)%Sfcprop%zsnsoxy(ix,4) + temp2d(i,j,idx_opt+49) = IPD_Data(nb)%Sfcprop%albdvis(ix) + temp2d(i,j,idx_opt+50) = IPD_Data(nb)%Sfcprop%albdnir(ix) + temp2d(i,j,idx_opt+51) = IPD_Data(nb)%Sfcprop%albivis(ix) + temp2d(i,j,idx_opt+52) = IPD_Data(nb)%Sfcprop%albinir(ix) + temp2d(i,j,idx_opt+53) = IPD_Data(nb)%Sfcprop%emiss(ix) + idx_opt = 139 + endif + + if (Model%nstf_name(1) > 0) then + temp2d(i,j,idx_opt) = IPD_Data(nb)%Sfcprop%tref(ix) + temp2d(i,j,idx_opt+1) = IPD_Data(nb)%Sfcprop%z_c(ix) + temp2d(i,j,idx_opt+2) = IPD_Data(nb)%Sfcprop%c_0(ix) + temp2d(i,j,idx_opt+3) = IPD_Data(nb)%Sfcprop%c_d(ix) + temp2d(i,j,idx_opt+4) = IPD_Data(nb)%Sfcprop%w_0(ix) + temp2d(i,j,idx_opt+5) = IPD_Data(nb)%Sfcprop%w_d(ix) + temp2d(i,j,idx_opt+6) = IPD_Data(nb)%Sfcprop%xt(ix) + temp2d(i,j,idx_opt+7) = IPD_Data(nb)%Sfcprop%xs(ix) + temp2d(i,j,idx_opt+8) = IPD_Data(nb)%Sfcprop%xu(ix) + temp2d(i,j,idx_opt+9) = IPD_Data(nb)%Sfcprop%xz(ix) + temp2d(i,j,idx_opt+10) = IPD_Data(nb)%Sfcprop%zm(ix) + temp2d(i,j,idx_opt+11) = IPD_Data(nb)%Sfcprop%xtts(ix) + temp2d(i,j,idx_opt+12) = IPD_Data(nb)%Sfcprop%xzts(ix) + temp2d(i,j,idx_opt+13) = IPD_Data(nb)%Sfcprop%ifd(ix) + temp2d(i,j,idx_opt+14) = IPD_Data(nb)%Sfcprop%dt_cool(ix) + temp2d(i,j,idx_opt+15) = IPD_Data(nb)%Sfcprop%qrain(ix) + endif + + do l = 1,Model%ntot2d + temp2d(i,j,nsfcprop2d+l) = IPD_Data(nb)%Tbd%phy_f2d(ix,l) + enddo + + do l = 1,Model%nctp + temp2d(i,j,nsfcprop2d+Model%ntot2d+l) = IPD_Data(nb)%Tbd%phy_fctd(ix,l) + enddo + + temp3d(i,j,:, 1) = IPD_Data(nb)%Statein%phii(ix,1:lev) + temp3d(i,j,:, 2) = IPD_Data(nb)%Statein%prsi(ix,1:lev) + temp3d(i,j,:, 3) = IPD_Data(nb)%Statein%prsik(ix,1:lev) + temp3d(i,j,:, 4) = IPD_Data(nb)%Statein%phil(ix,:) + temp3d(i,j,:, 5) = IPD_Data(nb)%Statein%prsl(ix,:) + temp3d(i,j,:, 6) = IPD_Data(nb)%Statein%prslk(ix,:) + temp3d(i,j,:, 7) = IPD_Data(nb)%Statein%ugrs(ix,:) + temp3d(i,j,:, 8) = IPD_Data(nb)%Statein%vgrs(ix,:) + temp3d(i,j,:, 9) = IPD_Data(nb)%Statein%vvl(ix,:) + temp3d(i,j,:,10) = IPD_Data(nb)%Statein%tgrs(ix,:) + temp3d(i,j,:,11) = IPD_Data(nb)%Stateout%gu0(ix,:) + temp3d(i,j,:,12) = IPD_Data(nb)%Stateout%gv0(ix,:) + temp3d(i,j,:,13) = IPD_Data(nb)%Stateout%gt0(ix,:) + temp3d(i,j,:,14) = IPD_Data(nb)%Radtend%htrsw(ix,:) + temp3d(i,j,:,15) = IPD_Data(nb)%Radtend%htrlw(ix,:) + temp3d(i,j,:,16) = IPD_Data(nb)%Radtend%swhc(ix,:) + temp3d(i,j,:,17) = IPD_Data(nb)%Radtend%lwhc(ix,:) + do l = 1,Model%ntot3d + temp3d(i,j,:,17+l) = IPD_Data(nb)%Tbd%phy_f3d(ix,:,l) + enddo + do l = 1,ntr + temp3d(i,j,:,17+Model%ntot3d+l) = IPD_Data(nb)%Statein%qgrs(ix,:,l) + temp3d(i,j,:,17+Model%ntot3d+ntr+l) = IPD_Data(nb)%Stateout%gq0(ix,:,l) + enddo + enddo + enddo + + outunit = stdout() + do i = 1,nsfcprop2d+Model%ntot2d+Model%nctp + write (name, '(i3.3,3x,4a)') i, ' 2d ' + write(outunit,100) name, mpp_chksum(temp2d(:,:,i:i)) + enddo + do i = 1,17+Model%ntot3d+2*ntr + write (name, '(i2.2,3x,4a)') i, ' 3d ' + write(outunit,100) name, mpp_chksum(temp3d(:,:,:,i:i)) + enddo +100 format("CHECKSUM::",A32," = ",Z20) + + end subroutine FV3GFS_IPD_checksum + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! PRIVATE SUBROUTINES +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------------------------------------------------------------------- +! register_sfc_prop_restart_vars +!---------------------------------------------------------------------- +! creates and populates a data type for surface variables which is +! then used to "register" restart variables with the GFDL FMS +! restart subsystem. +! +! calls: register_restart_field +! +!---------------------------------------------------------------------- + subroutine register_sfc_prop_restart_vars(Model, nx, ny, nvar_s2m, action) + type(IPD_control_type), intent(in) :: Model + integer, intent(in) :: nx + integer, intent(in) :: ny + integer, intent(out) :: nvar_s2m + character(len=*), intent(in) :: action !< alloc, read, write + + !--- local variables + integer :: is, ie + integer :: lsoil, num + integer :: nvar_s2mp, nvar_s2o + integer :: nvar_s3, nvar_s3mp + logical :: opt + character(len=8) :: dim_names_2d(3), dim_names_3d(4) + integer, allocatable, dimension(:) :: buffer + real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() + real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p => NULL() + + if (Model%cplflx) then ! needs more variables + nvar_s2m = 34 + else + nvar_s2m = 32 + endif + nvar_s2o = 18 + nvar_s3 = 3 + + if (Model%lsm == Model%lsm_noahmp) then + nvar_s2mp = 39 !mp 2D + nvar_s3mp = 5 !mp 3D + else + nvar_s2mp = 0 !mp 2D + nvar_s3mp = 0 !mp 3D + endif + + if (.not. allocated(sfc_name2)) then + !--- allocate the various containers needed for restarts + allocate(sfc_name2(nvar_s2m+nvar_s2o+nvar_s2mp)) + allocate(sfc_name3(nvar_s3+nvar_s3mp)) + + allocate(sfc_var2(nx,ny,nvar_s2m+nvar_s2o+nvar_s2mp)) + allocate(sfc_var3(nx,ny,Model%lsoil,nvar_s3)) + sfc_var2 = -9999._kind_phys + sfc_var3 = -9999._kind_phys +! + if (Model%lsm == Model%lsm_noahmp) then + allocate(sfc_var3sn(nx,ny,-2:0,4:6)) + allocate(sfc_var3eq(nx,ny,1:4,7:7)) + allocate(sfc_var3zn(nx,ny,-2:4,8:8)) + sfc_var3sn = -9999._kind_phys + sfc_var3eq = -9999._kind_phys + sfc_var3zn = -9999._kind_phys + end if + + !--- names of the 2D variables to save + sfc_name2(1) = 'slmsk' + sfc_name2(2) = 'tsea' !tsfc + sfc_name2(3) = 'sheleg' !weasd + sfc_name2(4) = 'tg3' + sfc_name2(5) = 'zorl' + sfc_name2(6) = 'alvsf' + sfc_name2(7) = 'alvwf' + sfc_name2(8) = 'alnsf' + sfc_name2(9) = 'alnwf' + sfc_name2(10) = 'facsf' + sfc_name2(11) = 'facwf' + sfc_name2(12) = 'vfrac' + sfc_name2(13) = 'canopy' + sfc_name2(14) = 'f10m' + sfc_name2(15) = 't2m' + sfc_name2(16) = 'q2m' + sfc_name2(17) = 'vtype' + sfc_name2(18) = 'stype' + sfc_name2(19) = 'uustar' + sfc_name2(20) = 'ffmm' + sfc_name2(21) = 'ffhh' + sfc_name2(22) = 'hice' + sfc_name2(23) = 'fice' + sfc_name2(24) = 'tisfc' + sfc_name2(25) = 'tprcp' + sfc_name2(26) = 'srflag' + sfc_name2(27) = 'snwdph' !snowd + sfc_name2(28) = 'shdmin' + sfc_name2(29) = 'shdmax' + sfc_name2(30) = 'slope' + sfc_name2(31) = 'snoalb' + !--- variables below here are optional + sfc_name2(32) = 'sncovr' + if(Model%cplflx) then + sfc_name2(33) = 'tsfcl' !temp on land portion of a cell + sfc_name2(34) = 'zorll' !zorl on land portion of a cell + end if + + !--- NSSTM inputs only needed when (nstf_name(1) > 0) .and. (nstf_name(2)) == 0) + sfc_name2(nvar_s2m+1) = 'tref' + sfc_name2(nvar_s2m+2) = 'z_c' + sfc_name2(nvar_s2m+3) = 'c_0' + sfc_name2(nvar_s2m+4) = 'c_d' + sfc_name2(nvar_s2m+5) = 'w_0' + sfc_name2(nvar_s2m+6) = 'w_d' + sfc_name2(nvar_s2m+7) = 'xt' + sfc_name2(nvar_s2m+8) = 'xs' + sfc_name2(nvar_s2m+9) = 'xu' + sfc_name2(nvar_s2m+10) = 'xv' + sfc_name2(nvar_s2m+11) = 'xz' + sfc_name2(nvar_s2m+12) = 'zm' + sfc_name2(nvar_s2m+13) = 'xtts' + sfc_name2(nvar_s2m+14) = 'xzts' + sfc_name2(nvar_s2m+15) = 'd_conv' + sfc_name2(nvar_s2m+16) = 'ifd' + sfc_name2(nvar_s2m+17) = 'dt_cool' + sfc_name2(nvar_s2m+18) = 'qrain' + ! + ! Only needed when Noah MP LSM is used - 39 2D + ! + if (Model%lsm == Model%lsm_noahmp) then + sfc_name2(nvar_s2m+19) = 'snowxy' + sfc_name2(nvar_s2m+20) = 'tvxy' + sfc_name2(nvar_s2m+21) = 'tgxy' + sfc_name2(nvar_s2m+22) = 'canicexy' + sfc_name2(nvar_s2m+23) = 'canliqxy' + sfc_name2(nvar_s2m+24) = 'eahxy' + sfc_name2(nvar_s2m+25) = 'tahxy' + sfc_name2(nvar_s2m+26) = 'cmxy' + sfc_name2(nvar_s2m+27) = 'chxy' + sfc_name2(nvar_s2m+28) = 'fwetxy' + sfc_name2(nvar_s2m+29) = 'sneqvoxy' + sfc_name2(nvar_s2m+30) = 'alboldxy' + sfc_name2(nvar_s2m+31) = 'qsnowxy' + sfc_name2(nvar_s2m+32) = 'wslakexy' + sfc_name2(nvar_s2m+33) = 'zwtxy' + sfc_name2(nvar_s2m+34) = 'waxy' + sfc_name2(nvar_s2m+35) = 'wtxy' + sfc_name2(nvar_s2m+36) = 'lfmassxy' + sfc_name2(nvar_s2m+37) = 'rtmassxy' + sfc_name2(nvar_s2m+38) = 'stmassxy' + sfc_name2(nvar_s2m+39) = 'woodxy' + sfc_name2(nvar_s2m+40) = 'stblcpxy' + sfc_name2(nvar_s2m+41) = 'fastcpxy' + sfc_name2(nvar_s2m+42) = 'xsaixy' + sfc_name2(nvar_s2m+43) = 'xlaixy' + sfc_name2(nvar_s2m+44) = 'taussxy' + sfc_name2(nvar_s2m+45) = 'smcwtdxy' + sfc_name2(nvar_s2m+46) = 'deeprechxy' + sfc_name2(nvar_s2m+47) = 'rechxy' + sfc_name2(nvar_s2m+48) = 'drainncprv' + sfc_name2(nvar_s2m+49) = 'draincprv' + sfc_name2(nvar_s2m+50) = 'dsnowprv' + sfc_name2(nvar_s2m+51) = 'dgraupelprv' + sfc_name2(nvar_s2m+52) = 'diceprv' + sfc_name2(nvar_s2m+53) = 'albdvis' + sfc_name2(nvar_s2m+54) = 'albdnir' + sfc_name2(nvar_s2m+55) = 'albivis' + sfc_name2(nvar_s2m+56) = 'albinir' + sfc_name2(nvar_s2m+57) = 'emiss' + endif + + !--- names of the 3D variables to save + sfc_name3(1) = 'stc' + sfc_name3(2) = 'smc' + sfc_name3(3) = 'slc' + !--- Noah MP + if (Model%lsm == Model%lsm_noahmp) then + sfc_name3(4) = 'snicexy' + sfc_name3(5) = 'snliqxy' + sfc_name3(6) = 'tsnoxy' + sfc_name3(7) = 'smoiseq' + sfc_name3(8) = 'zsnsoxy' + endif + endif ! if not allocated + + if (trim(action) == "alloc") then + return + elseif (trim(action) == "read") then + !--- register the axes for restarts + if (dimension_exists(Sfc_restart, "xaxis_1")) then + call register_axis(Sfc_restart, "xaxis_1", "X") + call register_axis(Sfc_restart, "yaxis_1", "Y") + call register_axis(Sfc_restart, "zaxis_1", dimension_length=4) + call register_axis(Sfc_restart, "zaxis_2", dimension_length=3) + call register_axis(Sfc_restart, "zaxis_3", dimension_length=7) + call register_axis(Sfc_restart, "Time", unlimited) + dim_names_2d(1) = "xaxis_1" + dim_names_2d(2) = "yaxis_1" + dim_names_2d(3) = "Time" + dim_names_3d(1) = "xaxis_1" + dim_names_3d(2) = "yaxis_1" + dim_names_3d(3) = "zaxis_1" ! to be reset as needed when variables are registered + dim_names_3d(4) = "Time" + else + call register_axis(Sfc_restart, 'lon', 'X') + call register_axis(Sfc_restart, 'lat', 'Y') + call register_axis(Sfc_restart, 'lsoil', dimension_length=Model%lsoil) + dim_names_2d(1) = "lat" + dim_names_2d(2) = "lon" + dim_names_3d(1) = "lat" + dim_names_3d(2) = "lon" + dim_names_3d(3) = "lsoil" + endif + + elseif (trim(action) == "write") then + + !--- register the axes for restarts + call register_axis(Sfc_restart, 'xaxis_1', 'X') + call register_field(Sfc_restart, 'xaxis_1', 'double', (/'xaxis_1'/)) + call register_variable_attribute(Sfc_restart, 'xaxis_1', 'cartesian_axis', 'X', str_len=1) + call get_global_io_domain_indices(Sfc_restart, 'xaxis_1', is, ie, indices=buffer) + call write_data(Sfc_restart, "xaxis_1", buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'yaxis_1', 'Y') + call register_field(Sfc_restart, 'yaxis_1', 'double', (/'yaxis_1'/)) + call register_variable_attribute(Sfc_restart, 'yaxis_1', 'cartesian_axis', 'Y', str_len=1) + call get_global_io_domain_indices(Sfc_restart, 'yaxis_1', is, ie, indices=buffer) + call write_data(Sfc_restart, "yaxis_1", buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'zaxis_1', dimension_length=Model%lsoil) + call register_field(Sfc_restart, 'zaxis_1', 'double', (/'zaxis_1'/)) + call register_variable_attribute(Sfc_restart, 'zaxis_1', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(Model%lsoil) ) + do lsoil=1, Model%lsoil + buffer(lsoil) = lsoil + end do + call write_data(Sfc_restart, 'zaxis_1', buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'Time', unlimited) + call register_field(Sfc_restart, 'Time', 'double', (/'Time'/)) + call register_variable_attribute(Sfc_restart, 'Time', 'cartesian_axis', 'T', str_len=1) + call write_data(Sfc_restart, 'Time', 1) + + if (Model%lsm == Model%lsm_noahmp) then + call register_axis(Sfc_restart, 'zaxis_2', dimension_length=3) + call register_field(Sfc_restart, 'zaxis_2', 'double', (/'zaxis_2'/)) + call register_variable_attribute(Sfc_restart, 'zaxis_2', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(3) ) + do lsoil=-2,0 + buffer(lsoil) = lsoil + end do + call write_data(Sfc_restart, 'zaxis_2', buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'zaxis_3', dimension_length=7) + call register_field(Sfc_restart, 'zaxis_3', 'double', (/'zaxis_3'/)) + call register_variable_attribute(Sfc_restart, 'zaxis_3', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(7) ) + do lsoil=-2,4 + buffer(lsoil) = lsoil + end do + call write_data(Sfc_restart, 'zaxis_3', buffer) + deallocate(buffer) + endif ! if (lsm_noahmp) + + dim_names_2d(1) = "xaxis_1" + dim_names_2d(2) = "yaxis_1" + dim_names_2d(3) = "Time" + dim_names_3d(1) = "xaxis_1" + dim_names_3d(2) = "yaxis_1" + dim_names_3d(3) = "zaxis_1" ! to be reset as needed when variables are registered + dim_names_3d(4) = "Time" + + else ! error case + + call mpp_error(FATAL,"FV3GFS_io::register_sfc_prop_restart_vars action not found") + + endif ! end of if (read) + + !--- register the 2D fields + do num = 1,nvar_s2m + var2_p => sfc_var2(:,:,num) + opt = .false. + if (trim(sfc_name2(num)) == 'sncovr'.or.trim(sfc_name2(num)) == 'tsfcl'.or.trim(sfc_name2(num)) == 'zorll') opt = .true. + call register_restart_field(Sfc_restart, sfc_name2(num), var2_p, dim_names_2d, is_optional=opt) + nullify(var2_p) + enddo + + !--- register NSST variables + if (Model%nstf_name(1) > 0) then + opt = .true. + if (Model%nstf_name(2) == 0) opt = .false. + do num = nvar_s2m+1,nvar_s2m+nvar_s2o + var2_p => sfc_var2(:,:,num) + call register_restart_field(Sfc_restart, sfc_name2(num), var2_p, dim_names_2d, is_optional=opt) + nullify(var2_p) + enddo + endif + + !--- Noah MP register only necessary only lsm = 2, not necessary has values + if (nvar_s2mp > 0) then + opt = .true. + do num = nvar_s2m+nvar_s2o+1,nvar_s2m+nvar_s2o+nvar_s2mp + var2_p => sfc_var2(:,:,num) + call register_restart_field(Sfc_restart, sfc_name2(num), var2_p, dim_names_2d, is_optional=opt) + nullify(var2_p) + enddo + endif ! noahmp + + !--- register the 3D fields + do num = 1,nvar_s3 + var3_p => sfc_var3(:,:,:,num) + dim_names_3d(3) = "zaxis_1" + call register_restart_field(Sfc_restart, sfc_name3(num), var3_p, dim_names_3d) + nullify(var3_p) + enddo + + !--- register the NOAH-MP 3D fields + if (Model%lsm == Model%lsm_noahmp) then + opt = .false. + do num = nvar_s3+1,nvar_s3+3 + var3_p => sfc_var3sn(:,:,:,num) + dim_names_3d(3) = "zaxis_2" + call register_restart_field(Sfc_restart, sfc_name3(num), var3_p, dim_names_3d, is_optional=opt) + nullify(var3_p) + enddo + + var3_p => sfc_var3eq(:,:,:,7) + dim_names_3d(3) = "zaxis_1" + call register_restart_field(Sfc_restart, sfc_name3(7), var3_p, dim_names_3d, is_optional=opt) + nullify(var3_p) + + var3_p => sfc_var3zn(:,:,:,8) + dim_names_3d(3) = "zaxis_3" + call register_restart_fIeld(Sfc_restart, sfc_name3(8), var3_p, dim_names_3d, is_optional=opt) + nullify(var3_p) + endif !mp + + end subroutine register_sfc_prop_restart_vars + +!---------------------------------------------------------------------- +! sfc_prop_restart_read +!---------------------------------------------------------------------- +! calls a routine to "register" restart variables with the GFDL FMS +! restart subsystem. +! +! calls a GFDL FMS routine to restore the data from a restart file. +! calculates sncovr if it is not present in the restart file. +! +! calls: open_file, register_sfc_prop_restart_vars, read_restart, +! close_file +! +! opens: oro_data.tile?.nc, sfc_data.tile?.nc +! +!---------------------------------------------------------------------- + subroutine sfc_prop_restart_read (Sfcprop, Atm_block, Model, fv_domain) + !--- interface variable definitions + type(GFS_sfcprop_type), intent(inout) :: Sfcprop(:) + type (block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(inout) :: Model + type (domain2d), intent(in) :: fv_domain + !--- local variables + integer :: i, j, k, ix, lsoil, num, nb + integer :: isc, iec, jsc, jec, npz, nx, ny + integer :: nvar_o2, nvar_s2m + integer :: isnow + logical :: opt + character(len=8) :: dim_names_2d(3) + real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() + + character(len=64) :: fname + !--- local variables for sncovr calculation + integer :: vegtyp + + real(kind=kind_phys) :: rsnow, tem + !--- Noah MP + integer :: soiltyp,ns,imon,iter,imn + real(kind=kind_phys) :: masslai, masssai,snd + real(kind=kind_phys) :: ddz,expon,aa,bb,smc,func,dfunc,dx + real(kind=kind_phys) :: bexp, smcmax, smcwlt,dwsat,dksat,psisat + + real(kind=kind_phys), dimension(-2:0) :: dzsno + real(kind=kind_phys), dimension(-2:4) :: dzsnso + + real(kind=kind_phys), dimension(4), save :: zsoil,dzs + data dzs /0.1,0.3,0.6,1.0/ + data zsoil /-0.1,-0.4,-1.0,-2.0/ + + + nvar_o2 = 19 + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + npz = Atm_block%npz + nx = (iec - isc + 1) + ny = (jec - jsc + 1) + + !--- Open the restart file and associate it with the Oro_restart fileobject + fname='INPUT/'//trim(fn_oro) + if (open_file(Oro_restart, fname, "read", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + call register_axis(Oro_restart, "lat", "y") + call register_axis(Oro_restart, "lon", "x") + dim_names_2d(1) = "lat" + dim_names_2d(2) = "lon" + + !--- OROGRAPHY FILE + if (.not. allocated(oro_name2)) then + !--- allocate the various containers needed for orography data + allocate(oro_name2(nvar_o2)) + allocate(oro_var2(nx,ny,nvar_o2)) + oro_var2 = -9999._kind_phys + + oro_name2(1) = 'stddev' ! hprime(ix,1) + oro_name2(2) = 'convexity' ! hprime(ix,2) + oro_name2(3) = 'oa1' ! hprime(ix,3) + oro_name2(4) = 'oa2' ! hprime(ix,4) + oro_name2(5) = 'oa3' ! hprime(ix,5) + oro_name2(6) = 'oa4' ! hprime(ix,6) + oro_name2(7) = 'ol1' ! hprime(ix,7) + oro_name2(8) = 'ol2' ! hprime(ix,8) + oro_name2(9) = 'ol3' ! hprime(ix,9) + oro_name2(10) = 'ol4' ! hprime(ix,10) + oro_name2(11) = 'theta' ! hprime(ix,11) + oro_name2(12) = 'gamma' ! hprime(ix,12) + oro_name2(13) = 'sigma' ! hprime(ix,13) + oro_name2(14) = 'elvmax' ! hprime(ix,14) + oro_name2(15) = 'orog_filt' ! oro + oro_name2(16) = 'orog_raw' ! oro_uf + oro_name2(17) = 'land_frac' ! land fraction [0:1] + !--- variables below here are optional + oro_name2(18) = 'lake_frac' ! lake fraction [0:1] + oro_name2(19) = 'lake_depth' ! lake depth(m) + !--- register the 2D fields + do num = 1,nvar_o2 + var2_p => oro_var2(:,:,num) + opt = .false. + if (trim(oro_name2(num)) == 'lake_frac' .or. trim(oro_name2(num)) == 'lake_depth') opt = .true. + call register_restart_field(Oro_restart, oro_name2(num), var2_p, dim_names_2d, is_optional=opt) + nullify(var2_p) + enddo + endif + + !--- read the orography restart/data + call mpp_error(NOTE,'reading topographic/orographic information from INPUT/oro_data.tile*.nc') + call read_restart(Oro_restart) + call close_file(Oro_restart) + + !--- copy data into GFS containers + do nb = 1, Atm_block%nblks + !--- 2D variables + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + !--- stddev + Sfcprop(nb)%hprim(ix) = oro_var2(i,j,1) + !--- hprime(1:14) + Sfcprop(nb)%hprime(ix,1) = oro_var2(i,j,1) + Sfcprop(nb)%hprime(ix,2) = oro_var2(i,j,2) + Sfcprop(nb)%hprime(ix,3) = oro_var2(i,j,3) + Sfcprop(nb)%hprime(ix,4) = oro_var2(i,j,4) + Sfcprop(nb)%hprime(ix,5) = oro_var2(i,j,5) + Sfcprop(nb)%hprime(ix,6) = oro_var2(i,j,6) + Sfcprop(nb)%hprime(ix,7) = oro_var2(i,j,7) + Sfcprop(nb)%hprime(ix,8) = oro_var2(i,j,8) + Sfcprop(nb)%hprime(ix,9) = oro_var2(i,j,9) + Sfcprop(nb)%hprime(ix,10) = oro_var2(i,j,10) + Sfcprop(nb)%hprime(ix,11) = oro_var2(i,j,11) + Sfcprop(nb)%hprime(ix,12) = oro_var2(i,j,12) + Sfcprop(nb)%hprime(ix,13) = oro_var2(i,j,13) + Sfcprop(nb)%hprime(ix,14) = oro_var2(i,j,14) + !--- oro + Sfcprop(nb)%oro(ix) = oro_var2(i,j,15) + !--- oro_uf + Sfcprop(nb)%oro_uf(ix) = oro_var2(i,j,16) + Sfcprop(nb)%landfrac(ix) = oro_var2(i,j,17) !land frac [0:1] + Sfcprop(nb)%lakefrac(ix) = oro_var2(i,j,18) !lake frac [0:1] + enddo + enddo + + if (nint(oro_var2(1,1,18)) == -9999._kind_phys) then ! lakefrac doesn't exist in the restart, need to create it + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - will computing lakefrac') + Model%frac_grid = .false. + else + Model%frac_grid = .true. + endif + + if (Model%me == Model%master ) write(0,*)' resetting Model%frac_grid=',Model%frac_grid + + !--- deallocate containers + deallocate(oro_name2, oro_var2) + + else ! no file - cold_start (no way yet to create orography on-the-fly) + + call mpp_error(NOTE,'No INPUT/oro_data.tile*.nc orographic data found; setting to 0') + !--- copy data into GFS containers + do nb = 1, Atm_block%nblks + !--- 2D variables + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + !--- stddev + Sfcprop(nb)%hprim(ix) = 0.0 + !--- hprime(1:14) + Sfcprop(nb)%hprime(ix,1:14) = 0.0 + !--- oro + Sfcprop(nb)%oro(ix) = 0.0 + !--- oro_uf + Sfcprop(nb)%oro_uf(ix) = 0.0 + enddo + enddo + + endif + + !--- Open the restart file and associate it with the Sfc_restart fileobject + fname='INPUT/'//trim(fn_srf) + if (open_file(Sfc_restart, fname, "read", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + + !--- register any variables needed for the restart read + call register_sfc_prop_restart_vars(Model, nx, ny, nvar_s2m, action="read") + + !--- read the surface restart/data + call mpp_error(NOTE,'reading surface properties data from INPUT/sfc_data.tile*.nc') + call read_restart(Sfc_restart) + call close_file(Sfc_restart) + + !--- place the data into the block GFS containers + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + +!--- 2D variables +! ------------ + Sfcprop(nb)%slmsk(ix) = sfc_var2(i,j,1) !--- slmsk + Sfcprop(nb)%tsfco(ix) = sfc_var2(i,j,2) !--- tsfc (tsea in sfc file) + Sfcprop(nb)%weasd(ix) = sfc_var2(i,j,3) !--- weasd (sheleg in sfc file) + Sfcprop(nb)%tg3(ix) = sfc_var2(i,j,4) !--- tg3 + Sfcprop(nb)%zorlo(ix) = sfc_var2(i,j,5) !--- zorl on ocean + Sfcprop(nb)%alvsf(ix) = sfc_var2(i,j,6) !--- alvsf + Sfcprop(nb)%alvwf(ix) = sfc_var2(i,j,7) !--- alvwf + Sfcprop(nb)%alnsf(ix) = sfc_var2(i,j,8) !--- alnsf + Sfcprop(nb)%alnwf(ix) = sfc_var2(i,j,9) !--- alnwf + Sfcprop(nb)%facsf(ix) = sfc_var2(i,j,10) !--- facsf + Sfcprop(nb)%facwf(ix) = sfc_var2(i,j,11) !--- facwf + Sfcprop(nb)%vfrac(ix) = sfc_var2(i,j,12) !--- vfrac + Sfcprop(nb)%canopy(ix) = sfc_var2(i,j,13) !--- canopy + Sfcprop(nb)%f10m(ix) = sfc_var2(i,j,14) !--- f10m + Sfcprop(nb)%t2m(ix) = sfc_var2(i,j,15) !--- t2m + Sfcprop(nb)%q2m(ix) = sfc_var2(i,j,16) !--- q2m + Sfcprop(nb)%vtype(ix) = sfc_var2(i,j,17) !--- vtype + Sfcprop(nb)%stype(ix) = sfc_var2(i,j,18) !--- stype + Sfcprop(nb)%uustar(ix) = sfc_var2(i,j,19) !--- uustar + Sfcprop(nb)%ffmm(ix) = sfc_var2(i,j,20) !--- ffmm + Sfcprop(nb)%ffhh(ix) = sfc_var2(i,j,21) !--- ffhh + Sfcprop(nb)%hice(ix) = sfc_var2(i,j,22) !--- hice + Sfcprop(nb)%fice(ix) = sfc_var2(i,j,23) !--- fice + Sfcprop(nb)%tisfc(ix) = sfc_var2(i,j,24) !--- tisfc + Sfcprop(nb)%tprcp(ix) = sfc_var2(i,j,25) !--- tprcp + Sfcprop(nb)%srflag(ix) = sfc_var2(i,j,26) !--- srflag + Sfcprop(nb)%snowd(ix) = sfc_var2(i,j,27) !--- snowd (snwdph in the file) + Sfcprop(nb)%shdmin(ix) = sfc_var2(i,j,28) !--- shdmin + Sfcprop(nb)%shdmax(ix) = sfc_var2(i,j,29) !--- shdmax + Sfcprop(nb)%slope(ix) = sfc_var2(i,j,30) !--- slope + Sfcprop(nb)%snoalb(ix) = sfc_var2(i,j,31) !--- snoalb + Sfcprop(nb)%sncovr(ix) = sfc_var2(i,j,32) !--- sncovr + if(Model%cplflx) then + Sfcprop(nb)%tsfcl(ix) = sfc_var2(i,j,33) !--- sfcl (temp on land portion of a cell) + Sfcprop(nb)%zorll(ix) = sfc_var2(i,j,34) !--- zorll (zorl on land portion of a cell) + end if + ! + !--- NSSTM variables + if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 1)) then + !--- nsstm tref + Sfcprop(nb)%tref(ix) = Sfcprop(nb)%tsfco(ix) + Sfcprop(nb)%xz(ix) = 30.0d0 + endif + if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 0)) then + Sfcprop(nb)%tref(ix) = sfc_var2(i,j,nvar_s2m+1) !--- nsstm tref + Sfcprop(nb)%z_c(ix) = sfc_var2(i,j,nvar_s2m+2) !--- nsstm z_c + Sfcprop(nb)%c_0(ix) = sfc_var2(i,j,nvar_s2m+3) !--- nsstm c_0 + Sfcprop(nb)%c_d(ix) = sfc_var2(i,j,nvar_s2m+4) !--- nsstm c_d + Sfcprop(nb)%w_0(ix) = sfc_var2(i,j,nvar_s2m+5) !--- nsstm w_0 + Sfcprop(nb)%w_d(ix) = sfc_var2(i,j,nvar_s2m+6) !--- nsstm w_d + Sfcprop(nb)%xt(ix) = sfc_var2(i,j,nvar_s2m+7) !--- nsstm xt + Sfcprop(nb)%xs(ix) = sfc_var2(i,j,nvar_s2m+8) !--- nsstm xs + Sfcprop(nb)%xu(ix) = sfc_var2(i,j,nvar_s2m+9) !--- nsstm xu + Sfcprop(nb)%xv(ix) = sfc_var2(i,j,nvar_s2m+10) !--- nsstm xv + Sfcprop(nb)%xz(ix) = sfc_var2(i,j,nvar_s2m+11) !--- nsstm xz + Sfcprop(nb)%zm(ix) = sfc_var2(i,j,nvar_s2m+12) !--- nsstm zm + Sfcprop(nb)%xtts(ix) = sfc_var2(i,j,nvar_s2m+13) !--- nsstm xtts + Sfcprop(nb)%xzts(ix) = sfc_var2(i,j,nvar_s2m+14) !--- nsstm xzts + Sfcprop(nb)%d_conv(ix) = sfc_var2(i,j,nvar_s2m+15) !--- nsstm d_conv + Sfcprop(nb)%ifd(ix) = sfc_var2(i,j,nvar_s2m+16) !--- nsstm ifd + Sfcprop(nb)%dt_cool(ix) = sfc_var2(i,j,nvar_s2m+17) !--- nsstm dt_cool + Sfcprop(nb)%qrain(ix) = sfc_var2(i,j,nvar_s2m+18) !--- nsstm qrain + endif + +! Noah MP +! ------- + if (Model%lsm == Model%lsm_noahmp) then + Sfcprop(nb)%snowxy(ix) = sfc_var2(i,j,nvar_s2m+19) + Sfcprop(nb)%tvxy(ix) = sfc_var2(i,j,nvar_s2m+20) + Sfcprop(nb)%tgxy(ix) = sfc_var2(i,j,nvar_s2m+21) + Sfcprop(nb)%canicexy(ix) = sfc_var2(i,j,nvar_s2m+22) + Sfcprop(nb)%canliqxy(ix) = sfc_var2(i,j,nvar_s2m+23) + Sfcprop(nb)%eahxy(ix) = sfc_var2(i,j,nvar_s2m+24) + Sfcprop(nb)%tahxy(ix) = sfc_var2(i,j,nvar_s2m+25) + Sfcprop(nb)%cmxy(ix) = sfc_var2(i,j,nvar_s2m+26) + Sfcprop(nb)%chxy(ix) = sfc_var2(i,j,nvar_s2m+27) + Sfcprop(nb)%fwetxy(ix) = sfc_var2(i,j,nvar_s2m+28) + Sfcprop(nb)%sneqvoxy(ix) = sfc_var2(i,j,nvar_s2m+29) + Sfcprop(nb)%alboldxy(ix) = sfc_var2(i,j,nvar_s2m+30) + Sfcprop(nb)%qsnowxy(ix) = sfc_var2(i,j,nvar_s2m+31) + Sfcprop(nb)%wslakexy(ix) = sfc_var2(i,j,nvar_s2m+32) + Sfcprop(nb)%zwtxy(ix) = sfc_var2(i,j,nvar_s2m+33) + Sfcprop(nb)%waxy(ix) = sfc_var2(i,j,nvar_s2m+34) + Sfcprop(nb)%wtxy(ix) = sfc_var2(i,j,nvar_s2m+35) + Sfcprop(nb)%lfmassxy(ix) = sfc_var2(i,j,nvar_s2m+36) + Sfcprop(nb)%rtmassxy(ix) = sfc_var2(i,j,nvar_s2m+37) + Sfcprop(nb)%stmassxy(ix) = sfc_var2(i,j,nvar_s2m+38) + Sfcprop(nb)%woodxy(ix) = sfc_var2(i,j,nvar_s2m+39) + Sfcprop(nb)%stblcpxy(ix) = sfc_var2(i,j,nvar_s2m+40) + Sfcprop(nb)%fastcpxy(ix) = sfc_var2(i,j,nvar_s2m+41) + Sfcprop(nb)%xsaixy(ix) = sfc_var2(i,j,nvar_s2m+42) + Sfcprop(nb)%xlaixy(ix) = sfc_var2(i,j,nvar_s2m+43) + Sfcprop(nb)%taussxy(ix) = sfc_var2(i,j,nvar_s2m+44) + Sfcprop(nb)%smcwtdxy(ix) = sfc_var2(i,j,nvar_s2m+45) + Sfcprop(nb)%deeprechxy(ix) = sfc_var2(i,j,nvar_s2m+46) + Sfcprop(nb)%rechxy(ix) = sfc_var2(i,j,nvar_s2m+47) + Sfcprop(nb)%drainncprv(ix) = sfc_var2(i,j,nvar_s2m+48) + Sfcprop(nb)%draincprv(ix) = sfc_var2(i,j,nvar_s2m+49) + Sfcprop(nb)%dsnowprv(ix) = sfc_var2(i,j,nvar_s2m+50) + Sfcprop(nb)%dgraupelprv(ix)= sfc_var2(i,j,nvar_s2m+51) + Sfcprop(nb)%diceprv(ix) = sfc_var2(i,j,nvar_s2m+52) + Sfcprop(nb)%albdvis(ix) = sfc_var2(i,j,nvar_s2m+53) + Sfcprop(nb)%albdnir(ix) = sfc_var2(i,j,nvar_s2m+54) + Sfcprop(nb)%albivis(ix) = sfc_var2(i,j,nvar_s2m+55) + Sfcprop(nb)%albinir(ix) = sfc_var2(i,j,nvar_s2m+56) + Sfcprop(nb)%emiss(ix) = sfc_var2(i,j,nvar_s2m+57) + endif + + + !--- 3D variables + do lsoil = 1,Model%lsoil + Sfcprop(nb)%stc(ix,lsoil) = sfc_var3(i,j,lsoil,1) !--- stc + Sfcprop(nb)%smc(ix,lsoil) = sfc_var3(i,j,lsoil,2) !--- smc + Sfcprop(nb)%slc(ix,lsoil) = sfc_var3(i,j,lsoil,3) !--- slc + enddo + + if (Model%lsm == Model%lsm_noahmp) then + do lsoil = -2, 0 + Sfcprop(nb)%snicexy(ix,lsoil) = sfc_var3sn(i,j,lsoil,4) + Sfcprop(nb)%snliqxy(ix,lsoil) = sfc_var3sn(i,j,lsoil,5) + Sfcprop(nb)%tsnoxy(ix,lsoil) = sfc_var3sn(i,j,lsoil,6) + enddo + + do lsoil = 1, 4 + Sfcprop(nb)%smoiseq(ix,lsoil) = sfc_var3eq(i,j,lsoil,7) + enddo + + do lsoil = -2, 4 + Sfcprop(nb)%zsnsoxy(ix,lsoil) = sfc_var3zn(i,j,lsoil,8) + enddo + endif + + enddo !ix + enddo !nb + + call mpp_error(NOTE, 'gfs_driver:: - after put to container ') +! so far: At cold start everything is 9999.0, warm start snowxy has values +! but the 3D of snow fields are not available because not allocated yet. +! ix,nb loops may be consolidate with the Noah MP isnowxy init +! restore traditional vars first,we need some of them to init snow fields +! snow depth to actual snow layers; so we can allocate and register +! note zsnsoxy is from -2:4 - isnowxy is from 0:-2, but we need +! exact snow layers to pass 3D fields correctly, snow layers are +! different fro grid to grid, we have to init point by point/grid. +! It has to be done after the weasd is available +! sfc_var2(1,1,32) is the first; we need this to allocate snow related fields + + !--- if sncovr does not exist in the restart, need to create it + if (nint(sfc_var2(1,1,32)) == -9999) then + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver::surface_props_input - computing sncovr') + !--- compute sncovr from existing variables + !--- code taken directly from read_fix.f + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + Sfcprop(nb)%sncovr(ix) = 0.0 + if (Sfcprop(nb)%slmsk(ix) > 0.001) then + vegtyp = Sfcprop(nb)%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + rsnow = 0.001*Sfcprop(nb)%weasd(ix)/snupx(vegtyp) + if (0.001*Sfcprop(nb)%weasd(ix) < snupx(vegtyp)) then + Sfcprop(nb)%sncovr(ix) = 1.0 - (exp(-salp_data*rsnow) - rsnow*exp(-salp_data)) + else + Sfcprop(nb)%sncovr(ix) = 1.0 + endif + endif + enddo + enddo + endif + + if(Model%frac_grid) then ! 3-way composite + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + tem = 1.0 - Sfcprop(nb)%landfrac(ix) - Sfcprop(nb)%fice(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%landfrac(ix) & + + Sfcprop(nb)%zorll(ix) * Sfcprop(nb)%fice(ix) & !zorl ice = zorl land + + Sfcprop(nb)%zorlo(ix) * tem + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfcl(ix) * Sfcprop(nb)%landfrac(ix) & + + Sfcprop(nb)%tisfc(ix) * Sfcprop(nb)%fice(ix) & + + Sfcprop(nb)%tsfco(ix) * tem + enddo + enddo + else ! in this case ice fracion is fraction of water fraction + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + !--- specify tsfcl/zorll from existing variable tsfco/zorlo + Sfcprop(nb)%tsfcl(ix) = Sfcprop(nb)%tsfco(ix) + Sfcprop(nb)%zorll(ix) = Sfcprop(nb)%zorlo(ix) + Sfcprop(nb)%zorl(ix) = Sfcprop(nb)%zorlo(ix) + Sfcprop(nb)%tsfc(ix) = Sfcprop(nb)%tsfco(ix) + if (Sfcprop(nb)%slmsk(ix) > 1.9) then + Sfcprop(nb)%landfrac(ix) = 0.0 + else + Sfcprop(nb)%landfrac(ix) = Sfcprop(nb)%slmsk(ix) + endif + enddo + enddo + endif ! if (Model%frac_grid) + + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + if (Sfcprop(nb)%lakefrac(ix) > 0.0) then + Sfcprop(nb)%oceanfrac(ix) = 0.0 ! lake & ocean don't coexist in a cell + else + Sfcprop(nb)%oceanfrac(ix) = 1.0 - Sfcprop(nb)%landfrac(ix) !LHS:ocean frac [0:1] + endif + + enddo + enddo + + if (Model%lsm == Model%lsm_noahmp) then + if (sfc_var2(1,1,nvar_s2m+19) < -9990. ) then + !--- initialize NOAH MP properties + if (Model%me == Model%master ) call mpp_error(NOTE, 'gfs_driver:: - Cold start Noah MP ') + + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + + Sfcprop(nb)%tvxy(ix) = missing_value + Sfcprop(nb)%tgxy(ix) = missing_value + Sfcprop(nb)%tahxy(ix) = missing_value + Sfcprop(nb)%canicexy(ix) = missing_value + Sfcprop(nb)%canliqxy(ix) = missing_value + Sfcprop(nb)%eahxy(ix) = missing_value + Sfcprop(nb)%cmxy(ix) = missing_value + Sfcprop(nb)%chxy(ix) = missing_value + Sfcprop(nb)%fwetxy(ix) = missing_value + Sfcprop(nb)%sneqvoxy(ix) = missing_value + Sfcprop(nb)%alboldxy(ix) = missing_value + Sfcprop(nb)%qsnowxy(ix) = missing_value + Sfcprop(nb)%wslakexy(ix) = missing_value + Sfcprop(nb)%taussxy(ix) = missing_value + Sfcprop(nb)%waxy(ix) = missing_value + Sfcprop(nb)%wtxy(ix) = missing_value + Sfcprop(nb)%zwtxy(ix) = missing_value + Sfcprop(nb)%xlaixy(ix) = missing_value + Sfcprop(nb)%xsaixy(ix) = missing_value + + Sfcprop(nb)%lfmassxy(ix) = missing_value + Sfcprop(nb)%stmassxy(ix) = missing_value + Sfcprop(nb)%rtmassxy(ix) = missing_value + Sfcprop(nb)%woodxy(ix) = missing_value + Sfcprop(nb)%stblcpxy(ix) = missing_value + Sfcprop(nb)%fastcpxy(ix) = missing_value + Sfcprop(nb)%smcwtdxy(ix) = missing_value + Sfcprop(nb)%deeprechxy(ix) = missing_value + Sfcprop(nb)%rechxy(ix) = missing_value + Sfcprop(nb)%drainncprv(ix) = 0. + Sfcprop(nb)%draincprv(ix) = 0. + Sfcprop(nb)%dsnowprv(ix) = 0. + Sfcprop(nb)%dgraupelprv(ix)= 0. + Sfcprop(nb)%diceprv(ix) = 0. + Sfcprop(nb)%albdvis(ix) = missing_value + Sfcprop(nb)%albdnir(ix) = missing_value + Sfcprop(nb)%albivis(ix) = missing_value + Sfcprop(nb)%albinir(ix) = missing_value + Sfcprop(nb)%emiss(ix) = missing_value + + Sfcprop(nb)%snowxy (ix) = missing_value + Sfcprop(nb)%snicexy(ix, -2:0) = missing_value + Sfcprop(nb)%snliqxy(ix, -2:0) = missing_value + Sfcprop(nb)%tsnoxy (ix, -2:0) = missing_value + Sfcprop(nb)%smoiseq(ix, 1:4) = missing_value + Sfcprop(nb)%zsnsoxy(ix, -2:4) = missing_value + + if (Sfcprop(nb)%slmsk(ix) > 0.01) then + + Sfcprop(nb)%tvxy(ix) = Sfcprop(nb)%tsfcl(ix) + Sfcprop(nb)%tgxy(ix) = Sfcprop(nb)%tsfcl(ix) + Sfcprop(nb)%tahxy(ix) = Sfcprop(nb)%tsfcl(ix) + + if (Sfcprop(nb)%snowd(ix) > 0.01 .and. Sfcprop(nb)%tsfcl(ix) > 273.15 ) Sfcprop(nb)%tvxy(ix) = 273.15 + if (Sfcprop(nb)%snowd(ix) > 0.01 .and. Sfcprop(nb)%tsfcl(ix) > 273.15 ) Sfcprop(nb)%tgxy(ix) = 273.15 + if (Sfcprop(nb)%snowd(ix) > 0.01 .and. Sfcprop(nb)%tsfcl(ix) > 273.15 ) Sfcprop(nb)%tahxy(ix) = 273.15 + + Sfcprop(nb)%canicexy(ix) = 0.0 + Sfcprop(nb)%canliqxy(ix) = Sfcprop(nb)%canopy(ix) + + Sfcprop(nb)%eahxy(ix) = 2000.0 + + !--- eahxy = psfc*qv/(0.622+qv); qv is mixing ratio, converted from sepcific + ! humidity specific humidity /(1.0 - specific humidity) + + Sfcprop(nb)%cmxy(ix) = 0.0 + Sfcprop(nb)%chxy(ix) = 0.0 + Sfcprop(nb)%fwetxy(ix) = 0.0 + Sfcprop(nb)%sneqvoxy(ix) = Sfcprop(nb)%weasd(ix) ! mm + Sfcprop(nb)%alboldxy(ix) = 0.65 + Sfcprop(nb)%qsnowxy(ix) = 0.0 + + !--- if (Sfcprop(nb)%srflag(ix) > 0.001) Sfcprop(nb)%qsnowxy(ix) = Sfcprop(nb)%tprcp(ix)/Model%dtp + ! already set to 0.0 + Sfcprop(nb)%wslakexy(ix) = 0.0 + Sfcprop(nb)%taussxy(ix) = 0.0 + + Sfcprop(nb)%albdvis(ix) = 0.2 + Sfcprop(nb)%albdnir(ix) = 0.2 + Sfcprop(nb)%albivis(ix) = 0.2 + Sfcprop(nb)%albinir(ix) = 0.2 + Sfcprop(nb)%emiss(ix) = 0.95 + + Sfcprop(nb)%waxy(ix) = 4900.0 + Sfcprop(nb)%wtxy(ix) = Sfcprop(nb)%waxy(ix) + Sfcprop(nb)%zwtxy(ix) = (25.0 + 2.0) - Sfcprop(nb)%waxy(ix) / 1000.0 /0.2 + ! + vegtyp = Sfcprop(nb)%vtype(ix) + if (vegtyp == 0) vegtyp = 7 + imn = Model%idate(2) + + if ((vegtyp == isbarren_table) .or. (vegtyp == isice_table) .or. (vegtyp == isurban_table) .or. & + & (vegtyp == iswater_table)) then + + Sfcprop(nb)%xlaixy(ix) = 0.0 + Sfcprop(nb)%xsaixy(ix) = 0.0 + + Sfcprop(nb)%lfmassxy(ix) = 0.0 + Sfcprop(nb)%stmassxy(ix) = 0.0 + Sfcprop(nb)%rtmassxy(ix) = 0.0 + + Sfcprop(nb)%woodxy (ix) = 0.0 + Sfcprop(nb)%stblcpxy (ix) = 0.0 + Sfcprop(nb)%fastcpxy (ix) = 0.0 + + else + + + Sfcprop(nb)%xlaixy(ix) = max(laim_table(vegtyp, imn),0.05) + Sfcprop(nb)%xsaixy(ix) = max(Sfcprop(nb)%xlaixy(ix)*0.1,0.05) + + masslai = 1000.0 / max(sla_table(vegtyp),1.0) + Sfcprop(nb)%lfmassxy(ix) = Sfcprop(nb)%xlaixy(ix)*masslai + masssai = 1000.0 / 3.0 + Sfcprop(nb)%stmassxy(ix) = Sfcprop(nb)%xsaixy(ix)* masssai + + Sfcprop(nb)%rtmassxy(ix) = 500.0 + + Sfcprop(nb)%woodxy (ix) = 500.0 + Sfcprop(nb)%stblcpxy(ix) = 1000.0 + Sfcprop(nb)%fastcpxy(ix) = 1000.0 + + endif ! non urban ... + + if ( vegtyp == isice_table ) then + do lsoil = 1,Model%lsoil + Sfcprop(nb)%stc(ix,lsoil) = min(Sfcprop(nb)%stc(ix,lsoil),min(Sfcprop(nb)%tg3(ix),263.15)) + Sfcprop(nb)%smc(ix,lsoil) = 1 + Sfcprop(nb)%slc(ix,lsoil) = 0 + enddo + endif + + snd = Sfcprop(nb)%snowd(ix)/1000.0 ! go to m from snwdph + + if (Sfcprop(nb)%weasd(ix) /= 0.0 .and. snd == 0.0 ) then + snd = Sfcprop(nb)%weasd(ix)/1000.0 + endif + + if (vegtyp == 15) then ! land ice in MODIS/IGBP + if ( Sfcprop(nb)%weasd(ix) < 0.1) then + Sfcprop(nb)%weasd(ix) = 0.1 + snd = 0.01 + endif + endif + + if (snd < 0.025 ) then + Sfcprop(nb)%snowxy(ix) = 0.0 + dzsno(-2:0) = 0.0 + elseif (snd >= 0.025 .and. snd <= 0.05 ) then + Sfcprop(nb)%snowxy(ix) = -1.0 + dzsno(0) = snd + elseif (snd > 0.05 .and. snd <= 0.10 ) then + Sfcprop(nb)%snowxy(ix) = -2.0 + dzsno(-1) = 0.5*snd + dzsno(0) = 0.5*snd + elseif (snd > 0.10 .and. snd <= 0.25 ) then + Sfcprop(nb)%snowxy(ix) = -2.0 + dzsno(-1) = 0.05 + dzsno(0) = snd - 0.05 + elseif (snd > 0.25 .and. snd <= 0.45 ) then + Sfcprop(nb)%snowxy(ix) = -3.0 + dzsno(-2) = 0.05 + dzsno(-1) = 0.5*(snd-0.05) + dzsno(0) = 0.5*(snd-0.05) + elseif (snd > 0.45) then + Sfcprop(nb)%snowxy(ix) = -3.0 + dzsno(-2) = 0.05 + dzsno(-1) = 0.20 + dzsno(0) = snd - 0.05 - 0.20 + else + call mpp_error(FATAL, 'problem with the logic assigning snow layers.') + endif + + !--- Now we have the snowxy field + ! snice + snliq + tsno allocation and compute them from what we have + Sfcprop(nb)%tsnoxy(ix,-2:0) = 0.0 + Sfcprop(nb)%snicexy(ix,-2:0) = 0.0 + Sfcprop(nb)%snliqxy(ix,-2:0) = 0.0 + Sfcprop(nb)%zsnsoxy(ix,-2:4) = 0.0 + + isnow = nint(Sfcprop(nb)%snowxy(ix))+1 ! snowxy <=0.0, dzsno >= 0.0 + + do ns = isnow , 0 + Sfcprop(nb)%tsnoxy(ix,ns) = Sfcprop(nb)%tgxy(ix) + Sfcprop(nb)%snliqxy(ix,ns) = 0.0 + Sfcprop(nb)%snicexy(ix,ns) = 1.00 * dzsno(ns) * Sfcprop(nb)%weasd(ix)/snd + enddo + ! + !--- zsnsoxy, all negative ? + ! + do ns = isnow, 0 + dzsnso(ns) = -dzsno(ns) + enddo + + do ns = 1 , 4 + dzsnso(ns) = -dzs(ns) + enddo + ! + !--- Assign to zsnsoxy + ! + Sfcprop(nb)%zsnsoxy(ix,isnow) = dzsnso(isnow) + do ns = isnow+1,4 + Sfcprop(nb)%zsnsoxy(ix,ns) = Sfcprop(nb)%zsnsoxy(ix,ns-1) + dzsnso(ns) + enddo + + ! + !--- smoiseq + ! Init water table related quantities here + ! + soiltyp = Sfcprop(nb)%stype(ix) + + + if (soiltyp == 0) then + Sfcprop(nb)%stype(ix) = 16 + soiltyp = Sfcprop(nb)%stype(ix) + endif + + bexp = bexp_table(soiltyp) + smcmax = smcmax_table(soiltyp) + smcwlt = smcwlt_table(soiltyp) + dwsat = dwsat_table(soiltyp) + dksat = dksat_table(soiltyp) + psisat = -psisat_table(soiltyp) + + if (vegtyp == isurban_table) then + smcmax = 0.45 + smcwlt = 0.40 + endif + + if ((bexp > 0.0) .and. (smcmax > 0.0) .and. (-psisat > 0.0 )) then + do ns = 1, Model%lsoil + if ( ns == 1 )then + ddz = -zsoil(ns+1) * 0.5 + elseif ( ns < Model%lsoil ) then + ddz = ( zsoil(ns-1) - zsoil(ns+1) ) * 0.5 + else + ddz = zsoil(ns-1) - zsoil(ns) + endif + ! + !--- Use newton-raphson method to find eq soil moisture + ! + expon = bexp + 1. + aa = dwsat / ddz + bb = dksat / smcmax ** expon + + smc = 0.5 * smcmax + + do iter = 1, 100 + func = (smc - smcmax) * aa + bb * smc ** expon + dfunc = aa + bb * expon * smc ** bexp + dx = func / dfunc + smc = smc - dx + if ( abs (dx) < 1.e-6) exit + enddo ! iteration + Sfcprop(nb)%smoiseq(ix,ns) = min(max(smc,1.e-4),smcmax*0.99) + enddo ! ddz soil layer + else ! bexp <= 0.0 + Sfcprop(nb)%smoiseq(ix,1:4) = smcmax + endif ! end the bexp condition + + Sfcprop(nb)%smcwtdxy(ix) = smcmax + Sfcprop(nb)%deeprechxy(ix) = 0.0 + Sfcprop(nb)%rechxy(ix) = 0.0 + + endif !end if slmsk>0.01 (land only) + + enddo ! ix + enddo ! nb + endif + endif !if Noah MP cold start ends + + else !--- ELSE of IF (open_file(fn_srf) ... + + !--- Noah MP define arbitrary value (number layers of snow) to indicate + ! coldstart(sfcfile doesn't include noah mp fields) or not + + call mpp_error(NOTE,'No INPUT/sfc_data.tile*.nc surface data found; cold-starting land surface') + !Need a namelist for options: + ! 1. choice of sst (uniform, profiles) --- ML0 should relax to this + ! 2. Choice of veg, soil type with certain soil T,q,ql + ! How to fix day of year (for astronomy)? + !--- place the data into the block GFS containers + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + !--- 2D variables + !--- slmsk + Sfcprop(nb)%slmsk(ix) = 0. + !--- tsfc (tsea in sfc file) + Sfcprop(nb)%tsfc(ix) = 300. ! should specify some latitudinal profile + !--- weasd (sheleg in sfc file) + Sfcprop(nb)%weasd(ix) = 0.0 + !--- tg3 + Sfcprop(nb)%tg3(ix) = 290. !generic value, probably not good; real value latitude-dependent + !--- zorl + Sfcprop(nb)%zorl(ix) = 0.1 ! typical ocean value; different values for different land surfaces (use a lookup table?) + !--- alvsf + Sfcprop(nb)%alvsf(ix) = 0.06 + !--- alvwf + Sfcprop(nb)%alvwf(ix) = 0.06 + !--- alnsf + Sfcprop(nb)%alnsf(ix) = 0.06 + !--- alnwf + Sfcprop(nb)%alnwf(ix) = 0.06 + !--- facsf + Sfcprop(nb)%facsf(ix) = 0.0 + !--- facwf + Sfcprop(nb)%facwf(ix) = 0.0 + !--- vfrac + Sfcprop(nb)%vfrac(ix) = 0.0 + !--- canopy + Sfcprop(nb)%canopy(ix) = 0.0 + !--- f10m + Sfcprop(nb)%f10m(ix) = 0.9 + !--- t2m + Sfcprop(nb)%t2m(ix) = Sfcprop(nb)%tsfc(ix) + !--- q2m + Sfcprop(nb)%q2m(ix) = 0.0 ! initially dry atmosphere? + !--- vtype + Sfcprop(nb)%vtype(ix) = 0.0 + !--- stype + Sfcprop(nb)%stype(ix) = 0.0 + !--- uustar + Sfcprop(nb)%uustar(ix) = 0.5 + !--- ffmm + Sfcprop(nb)%ffmm(ix) = 10. + !--- ffhh + Sfcprop(nb)%ffhh(ix) = 10. + !--- hice + Sfcprop(nb)%hice(ix) = 0.0 + !--- fice + Sfcprop(nb)%fice(ix) = 0.0 + !--- tisfc + Sfcprop(nb)%tisfc(ix) = Sfcprop(nb)%tsfc(ix) + !--- tprcp + Sfcprop(nb)%tprcp(ix) = 0.0 + !--- srflag + Sfcprop(nb)%srflag(ix) = 0.0 + !--- snowd (snwdph in the file) + Sfcprop(nb)%snowd(ix) = 0.0 + !--- shdmin + Sfcprop(nb)%shdmin(ix) = 0.0 !this and the next depend on the surface type + !--- shdmax + Sfcprop(nb)%shdmax(ix) = 0.0 + !--- slope + Sfcprop(nb)%slope(ix) = 0.0 ! also land-surface dependent + !--- snoalb + Sfcprop(nb)%snoalb(ix) = 0.0 + !--- sncovr + Sfcprop(nb)%sncovr(ix) = 0.0 + ! + !--- NSSTM variables + if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 1)) then + !--- nsstm tref + Sfcprop(nb)%tref(ix) = Sfcprop(nb)%tsfc(ix) + Sfcprop(nb)%xz(ix) = 30.0d0 + endif + if ((Model%nstf_name(1) > 0) .and. (Model%nstf_name(2) == 0)) then + !return an error + call mpp_error(FATAL, 'cold-starting does not support NSST.') + endif + + !--- 3D variables + ! these are all set to ocean values. + !--- stc + Sfcprop(nb)%stc(ix,:) = Sfcprop(nb)%tsfc(ix) + !--- smc + Sfcprop(nb)%smc(ix,:) = 1.0 + !--- slc + Sfcprop(nb)%slc(ix,:) = 1.0 + enddo + enddo + !--- end of file not existing cold-start case + + endif !--- END of IF (open_file(fn_srf) ... + + + end subroutine sfc_prop_restart_read + + subroutine sfc_data_override(Time, IPD_data, Atm_block, Model) + + implicit none + !--- interface variable definitions + type(time_type), intent(in) :: Time + type(IPD_data_type), intent(inout) :: IPD_Data(:) + type (block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + !--- local variables + integer :: i, j, ix, nb + integer :: isc, iec, jsc, jec + + logical :: used + real, allocatable :: sst(:,:), ci(:,:) + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + + if (Model%use_ext_sst) then + + ! Here is a sample data_table that will enable reading in + ! external SSTs and sea-ice from an external file. + ! + !"ATM", "sst", "sst", "INPUT/ec_sst.nc", "bilinear", 1.0 + !"ATM", "ci", "ci", "INPUT/ec_sst.nc", "bilinear", 1.0 + + allocate(sst(isc:iec,jsc:jec)) + allocate(ci(isc:iec,jsc:jec)) + call data_override('ATM', 'sst', sst, Time, override=used) + if (.not. used) then + call mpp_error(FATAL, " SST dataset not specified in data_table.") + endif + call data_override('ATM', 'ci', ci, Time, override=used) + if (.not. used) then + call mpp_error(NOTE, " Sea ice fraction dataset not specified in data_table. No override will occur.") + ci(:,:) = -999. + endif + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) + j = Atm_block%index(nb)%jj(ix) + IPD_Data(nb)%Statein%sst(ix) = sst(i,j) + IPD_Data(nb)%Statein%ci(ix) = ci(i,j) + enddo + enddo + deallocate(sst) + deallocate(ci) + + endif + + end subroutine sfc_data_override + + subroutine sfc_prop_override(Sfcprop, Grid, Atm_block, Model, fv_domain) + + implicit none + !--- interface variable definitions + type(GFS_sfcprop_type), intent(inout) :: Sfcprop(:) + type(GFS_grid_type), intent(inout) :: Grid(:) + type (block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + type (domain2d), intent(in) :: fv_domain + !--- local variables + integer :: i, j, k, ix, lsoil, num, nb + integer :: isc, iec, jsc, jec, npz, nx, ny, ios + + logical :: ideal_sst = .false. + real(kind=kind_phys) :: sst_max = 300. + real(kind=kind_phys) :: sst_min = 271.14 ! -2c --> sea ice + integer :: sst_profile = 0 + + logical :: ideal_land = .false. + !Assuming modern veg/soil types + ! sample Amazon settings; values for OKC in comments + integer :: vegtype = 2 ! 12 + integer :: soiltype = 9 ! 8 + real(kind=kind_phys) :: vegfrac = 0.8 ! 0.25 -- 0.75 + real(kind=kind_phys) :: zorl = 265 ! 15 + !uniform soil temperature and moisture for now + real(kind=kind_phys) :: stc = 300. ! 310. + real(kind=kind_phys) :: smc = 0.4 ! wet season vs. 0.08 dry ! 0.2 okc highly variable and patchy + + namelist /sfc_prop_override_nml/ & + ideal_sst, sst_max, sst_profile, & !Aquaplanet SST options + ideal_land, vegtype, soiltype, & ! idealized soil/veg options + vegfrac, zorl, stc, smc + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + npz = Atm_block%npz + nx = (iec - isc + 1) + ny = (jec - jsc + 1) + + !--- read the sfc_prop_override namelist + read(Model%input_nml_file, nml=sfc_prop_override_nml, iostat=ios) + + call qsmith_init + + call mpp_error(NOTE, "Calling sfc_prop_override") + + if (ideal_sst) then + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + !--- slmsk + Sfcprop(nb)%slmsk(ix) = 0.0 + !--- tsfc (tsea in sfc file) + select case (sst_profile) + case (0) + Sfcprop(nb)%tsfc(ix) = sst_max + case (1) ! symmetric + Sfcprop(nb)%tsfc(ix) = sst_min + (sst_max - sst_min)*Grid(nb)%coslat(ix) + case default + call mpp_error(FATAL, "value of sst_profile not defined.") + end select + !--- zorl + Sfcprop(nb)%zorl(ix) = zorl + !--- vfrac + Sfcprop(nb)%vfrac(ix) = 0.0 + if (Sfcprop(nb)%tsfc(ix) <= sst_min) then + !--- hice + Sfcprop(nb)%hice(ix) = 1.0 + !--- fice + Sfcprop(nb)%fice(ix) = 1.0 + Sfcprop(nb)%tsfc(ix) = sst_min + else + !--- hice + Sfcprop(nb)%hice(ix) = 0.0 + !--- fice + Sfcprop(nb)%fice(ix) = 0.0 + endif + !--- tisfc + Sfcprop(nb)%tisfc(ix) = Sfcprop(nb)%tsfc(ix) + !--- t2m ! slt. unstable + Sfcprop(nb)%t2m(ix) = Sfcprop(nb)%t2m(ix) * 0.98 + !--- q2m ! use RH = 98% and assume ps = 1000 mb + Sfcprop(nb)%q2m(ix) = wqs1 (Sfcprop(nb)%t2m(ix), 1.e5/rd/Sfcprop(nb)%t2m(ix)) + !--- vtype + Sfcprop(nb)%vtype(ix) = 0 + !--- stype + Sfcprop(nb)%stype(ix) = 0 + !Override MLO properties also + if (Model%do_ocean) then + Sfcprop(nb)%ts_clim_iano(ix) = Sfcprop(nb)%tsfc(ix) + Sfcprop(nb)%tsclim(ix) = Sfcprop(nb)%tsfc(ix) + Sfcprop(nb)%ts_som(ix) = Sfcprop(nb)%tsfc(ix) + endif + enddo + enddo + + + elseif (ideal_land) then + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + !--- slmsk + Sfcprop(nb)%slmsk(ix) = 1.0 + !--- tsfc (tsea in sfc file) + Sfcprop(nb)%tsfc(ix) = stc + !--- weasd (sheleg in sfc file) + Sfcprop(nb)%weasd(ix) = 0.0 ! snow + !--- tg3 + Sfcprop(nb)%tg3(ix) = stc ! simple approach + !--- zorl + Sfcprop(nb)%zorl(ix) = zorl + !--- vfrac + Sfcprop(nb)%vfrac(ix) = vegfrac + !--- canopy + Sfcprop(nb)%canopy(ix) = 0.0 !this quantity is quite variable + !--- t2m + Sfcprop(nb)%t2m(ix) = stc * 0.98 !slt unstable + !--- q2m ! use RH = 98% + Sfcprop(nb)%q2m(ix) = wqs1 (Sfcprop(nb)%t2m(ix), 1.e5/rd/Sfcprop(nb)%t2m(ix)) + !--- vtype + Sfcprop(nb)%vtype(ix) = vegtype + !--- stype + Sfcprop(nb)%stype(ix) = soiltype + !--- hice + Sfcprop(nb)%hice(ix) = 0.0 + !--- fice + Sfcprop(nb)%fice(ix) = 0.0 + !--- tisfc + Sfcprop(nb)%tisfc(ix) = stc + !--- snowd (snwdph in the file) + Sfcprop(nb)%snowd(ix) = 0.0 + !--- snoalb + Sfcprop(nb)%snoalb(ix) = 0.5 + !--- sncovr + Sfcprop(nb)%sncovr(ix) = 0.0 + !--- 3D variables + do lsoil = 1,Model%lsoil + !--- stc + Sfcprop(nb)%stc(ix,lsoil) = stc + !--- smc + Sfcprop(nb)%smc(ix,lsoil) = smc + !--- slc = smc + Sfcprop(nb)%slc(ix,lsoil) = smc + enddo + + enddo + enddo + + endif + + + end subroutine sfc_prop_override + + +!---------------------------------------------------------------------- +! sfc_prop_restart_write +!---------------------------------------------------------------------- +! routine to write out GFS surface restarts via the GFDL FMS restart +! subsystem. +! takes an optional argument to append timestamps for intermediate +! restarts. +! +! calls: register_restart_field, save_restart +!---------------------------------------------------------------------- + subroutine sfc_prop_restart_write (Sfcprop, Atm_block, Model, fv_domain, timestamp) + !--- interface variable definitions + type(GFS_sfcprop_type), intent(in) :: Sfcprop(:) + type(block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + type(domain2d), intent(in) :: fv_domain + character(len=32), optional, intent(in) :: timestamp + !--- local variables + integer :: i, j, k, nb, ix, lsoil, num + integer :: isc, iec, jsc, jec, npz, nx, ny + integer :: nvar_s2m + character(len=64) :: fname + character(len=32) :: fn_srf = 'sfc_data.nc' + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + npz = Atm_block%npz + nx = (iec - isc + 1) + ny = (jec - jsc + 1) + + !--- Open the restart file and associate it with the Sfc_restart fileobject + if (present(timestamp)) then + fname='RESTART/'//trim(timestamp)//'.'//trim(fn_srf) + else + fname='RESTART/'//trim(fn_srf) + endif + + if (open_file(Sfc_restart, fname, "overwrite", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + + !--- register the variables needed for the restart write + call register_sfc_prop_restart_vars(Model, nx, ny, nvar_s2m, action="write") + + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + !--- 2D variables + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + sfc_var2(i,j,1) = Sfcprop(nb)%slmsk(ix) !--- slmsk + sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) !--- tsfc (tsea in sfc file) + sfc_var2(i,j,3) = Sfcprop(nb)%weasd(ix) !--- weasd (sheleg in sfc file) + sfc_var2(i,j,4) = Sfcprop(nb)%tg3(ix) !--- tg3 + sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) !--- zorl + sfc_var2(i,j,6) = Sfcprop(nb)%alvsf(ix) !--- alvsf + sfc_var2(i,j,7) = Sfcprop(nb)%alvwf(ix) !--- alvwf + sfc_var2(i,j,8) = Sfcprop(nb)%alnsf(ix) !--- alnsf + sfc_var2(i,j,9) = Sfcprop(nb)%alnwf(ix) !--- alnwf + sfc_var2(i,j,10) = Sfcprop(nb)%facsf(ix) !--- facsf + sfc_var2(i,j,11) = Sfcprop(nb)%facwf(ix) !--- facwf + sfc_var2(i,j,12) = Sfcprop(nb)%vfrac(ix) !--- vfrac + sfc_var2(i,j,13) = Sfcprop(nb)%canopy(ix)!--- canopy + sfc_var2(i,j,14) = Sfcprop(nb)%f10m(ix) !--- f10m + sfc_var2(i,j,15) = Sfcprop(nb)%t2m(ix) !--- t2m + sfc_var2(i,j,16) = Sfcprop(nb)%q2m(ix) !--- q2m + sfc_var2(i,j,17) = Sfcprop(nb)%vtype(ix) !--- vtype + sfc_var2(i,j,18) = Sfcprop(nb)%stype(ix) !--- stype + sfc_var2(i,j,19) = Sfcprop(nb)%uustar(ix)!--- uustar + sfc_var2(i,j,20) = Sfcprop(nb)%ffmm(ix) !--- ffmm + sfc_var2(i,j,21) = Sfcprop(nb)%ffhh(ix) !--- ffhh + sfc_var2(i,j,22) = Sfcprop(nb)%hice(ix) !--- hice + sfc_var2(i,j,23) = Sfcprop(nb)%fice(ix) !--- fice + sfc_var2(i,j,24) = Sfcprop(nb)%tisfc(ix) !--- tisfc + sfc_var2(i,j,25) = Sfcprop(nb)%tprcp(ix) !--- tprcp + sfc_var2(i,j,26) = Sfcprop(nb)%srflag(ix)!--- srflag + sfc_var2(i,j,27) = Sfcprop(nb)%snowd(ix) !--- snowd (snwdph in the file) + sfc_var2(i,j,28) = Sfcprop(nb)%shdmin(ix)!--- shdmin + sfc_var2(i,j,29) = Sfcprop(nb)%shdmax(ix)!--- shdmax + sfc_var2(i,j,30) = Sfcprop(nb)%slope(ix) !--- slope + sfc_var2(i,j,31) = Sfcprop(nb)%snoalb(ix)!--- snoalb + sfc_var2(i,j,32) = Sfcprop(nb)%sncovr(ix)!--- sncovr + if (Model%cplflx) then + sfc_var2(i,j,33) = Sfcprop(nb)%tsfcl(ix) !--- tsfcl (temp on land) + sfc_var2(i,j,34) = Sfcprop(nb)%zorll(ix) !--- zorll (zorl on land) + end if + !--- NSSTM variables + if (Model%nstf_name(1) > 0) then + sfc_var2(i,j,nvar_s2m+1) = Sfcprop(nb)%tref(ix) !--- nsstm tref + sfc_var2(i,j,nvar_s2m+2) = Sfcprop(nb)%z_c(ix) !--- nsstm z_c + sfc_var2(i,j,nvar_s2m+3) = Sfcprop(nb)%c_0(ix) !--- nsstm c_0 + sfc_var2(i,j,nvar_s2m+4) = Sfcprop(nb)%c_d(ix) !--- nsstm c_d + sfc_var2(i,j,nvar_s2m+5) = Sfcprop(nb)%w_0(ix) !--- nsstm w_0 + sfc_var2(i,j,nvar_s2m+6) = Sfcprop(nb)%w_d(ix) !--- nsstm w_d + sfc_var2(i,j,nvar_s2m+7) = Sfcprop(nb)%xt(ix) !--- nsstm xt + sfc_var2(i,j,nvar_s2m+8) = Sfcprop(nb)%xs(ix) !--- nsstm xs + sfc_var2(i,j,nvar_s2m+9) = Sfcprop(nb)%xu(ix) !--- nsstm xu + sfc_var2(i,j,nvar_s2m+10) = Sfcprop(nb)%xv(ix) !--- nsstm xv + sfc_var2(i,j,nvar_s2m+11) = Sfcprop(nb)%xz(ix) !--- nsstm xz + sfc_var2(i,j,nvar_s2m+12) = Sfcprop(nb)%zm(ix) !--- nsstm zm + sfc_var2(i,j,nvar_s2m+13) = Sfcprop(nb)%xtts(ix) !--- nsstm xtts + sfc_var2(i,j,nvar_s2m+14) = Sfcprop(nb)%xzts(ix) !--- nsstm xzts + sfc_var2(i,j,nvar_s2m+15) = Sfcprop(nb)%d_conv(ix) !--- nsstm d_conv + sfc_var2(i,j,nvar_s2m+16) = Sfcprop(nb)%ifd(ix) !--- nsstm ifd + sfc_var2(i,j,nvar_s2m+17) = Sfcprop(nb)%dt_cool(ix)!--- nsstm dt_cool + sfc_var2(i,j,nvar_s2m+18) = Sfcprop(nb)%qrain(ix) !--- nsstm qrain + endif + + ! Noah MP + if (Model%lsm == Model%lsm_noahmp) then + sfc_var2(i,j,nvar_s2m+19) = Sfcprop(nb)%snowxy(ix) + sfc_var2(i,j,nvar_s2m+20) = Sfcprop(nb)%tvxy(ix) + sfc_var2(i,j,nvar_s2m+21) = Sfcprop(nb)%tgxy(ix) + sfc_var2(i,j,nvar_s2m+22) = Sfcprop(nb)%canicexy(ix) + sfc_var2(i,j,nvar_s2m+23) = Sfcprop(nb)%canliqxy(ix) + sfc_var2(i,j,nvar_s2m+24) = Sfcprop(nb)%eahxy(ix) + sfc_var2(i,j,nvar_s2m+25) = Sfcprop(nb)%tahxy(ix) + sfc_var2(i,j,nvar_s2m+26) = Sfcprop(nb)%cmxy(ix) + sfc_var2(i,j,nvar_s2m+27) = Sfcprop(nb)%chxy(ix) + sfc_var2(i,j,nvar_s2m+28) = Sfcprop(nb)%fwetxy(ix) + sfc_var2(i,j,nvar_s2m+29) = Sfcprop(nb)%sneqvoxy(ix) + sfc_var2(i,j,nvar_s2m+30) = Sfcprop(nb)%alboldxy(ix) + sfc_var2(i,j,nvar_s2m+31) = Sfcprop(nb)%qsnowxy(ix) + sfc_var2(i,j,nvar_s2m+32) = Sfcprop(nb)%wslakexy(ix) + sfc_var2(i,j,nvar_s2m+33) = Sfcprop(nb)%zwtxy(ix) + sfc_var2(i,j,nvar_s2m+34) = Sfcprop(nb)%waxy(ix) + sfc_var2(i,j,nvar_s2m+35) = Sfcprop(nb)%wtxy(ix) + sfc_var2(i,j,nvar_s2m+36) = Sfcprop(nb)%lfmassxy(ix) + sfc_var2(i,j,nvar_s2m+37) = Sfcprop(nb)%rtmassxy(ix) + sfc_var2(i,j,nvar_s2m+38) = Sfcprop(nb)%stmassxy(ix) + sfc_var2(i,j,nvar_s2m+39) = Sfcprop(nb)%woodxy(ix) + sfc_var2(i,j,nvar_s2m+40) = Sfcprop(nb)%stblcpxy(ix) + sfc_var2(i,j,nvar_s2m+41) = Sfcprop(nb)%fastcpxy(ix) + sfc_var2(i,j,nvar_s2m+42) = Sfcprop(nb)%xsaixy(ix) + sfc_var2(i,j,nvar_s2m+43) = Sfcprop(nb)%xlaixy(ix) + sfc_var2(i,j,nvar_s2m+44) = Sfcprop(nb)%taussxy(ix) + sfc_var2(i,j,nvar_s2m+45) = Sfcprop(nb)%smcwtdxy(ix) + sfc_var2(i,j,nvar_s2m+46) = Sfcprop(nb)%deeprechxy(ix) + sfc_var2(i,j,nvar_s2m+47) = Sfcprop(nb)%rechxy(ix) + sfc_var2(i,j,nvar_s2m+48) = Sfcprop(nb)%drainncprv(ix) + sfc_var2(i,j,nvar_s2m+49) = Sfcprop(nb)%draincprv(ix) + sfc_var2(i,j,nvar_s2m+50) = Sfcprop(nb)%dsnowprv(ix) + sfc_var2(i,j,nvar_s2m+51) = Sfcprop(nb)%dgraupelprv(ix) + sfc_var2(i,j,nvar_s2m+52) = Sfcprop(nb)%diceprv(ix) + sfc_var2(i,j,nvar_s2m+53) = Sfcprop(nb)%albdvis(ix) + sfc_var2(i,j,nvar_s2m+54) = Sfcprop(nb)%albdnir(ix) + sfc_var2(i,j,nvar_s2m+55) = Sfcprop(nb)%albivis(ix) + sfc_var2(i,j,nvar_s2m+56) = Sfcprop(nb)%albinir(ix) + sfc_var2(i,j,nvar_s2m+57) = Sfcprop(nb)%emiss(ix) + endif + + !--- 3D variables + do lsoil = 1,Model%lsoil + sfc_var3(i,j,lsoil,1) = Sfcprop(nb)%stc(ix,lsoil) !--- stc + sfc_var3(i,j,lsoil,2) = Sfcprop(nb)%smc(ix,lsoil) !--- smc + sfc_var3(i,j,lsoil,3) = Sfcprop(nb)%slc(ix,lsoil) !--- slc + enddo + ! 5 Noah MP 3D + if (Model%lsm == Model%lsm_noahmp) then + + do lsoil = -2,0 + sfc_var3sn(i,j,lsoil,4) = Sfcprop(nb)%snicexy(ix,lsoil) + sfc_var3sn(i,j,lsoil,5) = Sfcprop(nb)%snliqxy(ix,lsoil) + sfc_var3sn(i,j,lsoil,6) = Sfcprop(nb)%tsnoxy(ix,lsoil) + enddo + + do lsoil = 1,Model%lsoil + sfc_var3eq(i,j,lsoil,7) = Sfcprop(nb)%smoiseq(ix,lsoil) + enddo + + do lsoil = -2,4 + sfc_var3zn(i,j,lsoil,8) = Sfcprop(nb)%zsnsoxy(ix,lsoil) + enddo + + endif ! Noah MP + enddo + enddo + + call write_restart(Sfc_restart) + call close_file(Sfc_restart) + endif + end subroutine sfc_prop_restart_write + + subroutine sfc_prop_restart_write_coarse(Sfcprop, Atm_block, Model, coarse_domain, Grid, timestamp) + type(GFS_sfcprop_type), intent(in) :: Sfcprop(:) + type(block_control_type), intent(in) :: atm_block + type(IPD_control_type), intent(in) :: Model + type(domain2d), intent(in) :: coarse_domain + type(GFS_grid_type), intent(in) :: Grid(:) + character(len=32), optional, intent(in) :: timestamp + + integer :: i, j, k, nb, ix, lsoil, num + integer :: isc, iec, jsc, jec, npz, nx, ny + integer :: nvar2m, nvar2o, nvar3, nvar_s2m + + integer :: is_coarse, ie_coarse, js_coarse, je_coarse, nx_coarse, ny_coarse + character(len=64) :: fname + character(len=32) :: fn_srf_coarse = 'sfc_data_coarse.nc' + real(kind=kind_phys), allocatable, dimension(:,:) :: area, & + dominant_sfc_type, dominant_vtype, dominant_stype, & + tisfc_area_average, only_area_weighted_zorl, & + only_area_weighted_canopy, coarsened_area_times_fice, & + coarsened_area_times_sncovr, coarsened_area_times_vfrac + logical, allocatable, dimension(:,:) :: sfc_type_mask, sfc_and_vtype_mask, sfc_and_stype_mask + real(kind=kind_phys) :: FREEZING, VTYPE_LAND_ICE, STYPE_LAND_ICE, SHDMIN_CANOPY_THRESHOLD + + if (Model%cplflx .or. (Model%lsm .eq. Model%lsm_noahmp) .or. (Model%nstf_name(1) > 0)) then + call mpp_error(FATAL, 'Coarse graining strategy not defined for land surface model configuration') + endif + + nvar2m = 32 + nvar3 = 3 + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + npz = Atm_block%npz + nx = (iec - isc + 1) + ny = (jec - jsc + 1) + + call mpp_get_compute_domain(coarse_domain, is_coarse, ie_coarse, js_coarse, je_coarse) + nx_coarse = ie_coarse - is_coarse + 1 + ny_coarse = je_coarse - js_coarse + 1 + + allocate(area(nx,ny)) + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + area(i,j) = Grid(nb)%area(ix) + enddo + enddo + + allocate(dominant_sfc_type(nx,ny)) + allocate(dominant_vtype(nx,ny)) + allocate(dominant_stype(nx,ny)) + allocate(sfc_type_mask(nx,ny)) + allocate(sfc_and_vtype_mask(nx,ny)) + allocate(sfc_and_stype_mask(nx,ny)) + allocate(tisfc_area_average(nx_coarse,nx_coarse)) + allocate(only_area_weighted_zorl(nx_coarse,nx_coarse)) + allocate(only_area_weighted_canopy(nx_coarse,nx_coarse)) + allocate(coarsened_area_times_fice(nx_coarse,nx_coarse)) + allocate(coarsened_area_times_sncovr(nx_coarse,nx_coarse)) + allocate(coarsened_area_times_vfrac(nx_coarse,nx_coarse)) + + if (.not. allocated(sfc_var2_coarse)) then + allocate(sfc_var2_coarse(nx_coarse,ny_coarse,nvar2m)) + allocate(sfc_var3_coarse(nx_coarse,ny_coarse,Model%lsoil,nvar3)) + endif + + + !--- Open the restart file and associate it with the Sfc_restart fileobject + if (present(timestamp)) then + fname='RESTART/'//trim(timestamp)//'.'//trim(fn_srf_coarse) + else + fname='RESTART/'//trim(fn_srf_coarse) + endif + + if (open_file(Sfc_restart_coarse, fname, "overwrite", coarse_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + + !--- register surface properties for coarse restart + call register_sfc_prop_restart_vars(Model, nx, ny, nvar_s2m, action="alloc") + + call register_coarse_sfc_prop_restart_fields(Model, sfc_var2_coarse, sfc_var3_coarse, nvar2m, nvar3) + + do nb = 1, Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + sfc_var2(i,j,1) = Sfcprop(nb)%slmsk(ix) + sfc_var2(i,j,2) = Sfcprop(nb)%tsfc(ix) + sfc_var2(i,j,3) = Sfcprop(nb)%weasd(ix) + sfc_var2(i,j,4) = Sfcprop(nb)%tg3(ix) + sfc_var2(i,j,5) = Sfcprop(nb)%zorl(ix) + sfc_var2(i,j,6) = Sfcprop(nb)%alvsf(ix) + sfc_var2(i,j,7) = Sfcprop(nb)%alvwf(ix) + sfc_var2(i,j,8) = Sfcprop(nb)%alnsf(ix) + sfc_var2(i,j,9) = Sfcprop(nb)%alnwf(ix) + sfc_var2(i,j,10) = Sfcprop(nb)%facsf(ix) + sfc_var2(i,j,11) = Sfcprop(nb)%facwf(ix) + sfc_var2(i,j,12) = Sfcprop(nb)%vfrac(ix) + sfc_var2(i,j,13) = Sfcprop(nb)%canopy(ix) + sfc_var2(i,j,14) = Sfcprop(nb)%f10m(ix) + sfc_var2(i,j,15) = Sfcprop(nb)%t2m(ix) + sfc_var2(i,j,16) = Sfcprop(nb)%q2m(ix) + sfc_var2(i,j,17) = Sfcprop(nb)%vtype(ix) + sfc_var2(i,j,18) = Sfcprop(nb)%stype(ix) + sfc_var2(i,j,19) = Sfcprop(nb)%uustar(ix) + sfc_var2(i,j,20) = Sfcprop(nb)%ffmm(ix) + sfc_var2(i,j,21) = Sfcprop(nb)%ffhh(ix) + sfc_var2(i,j,22) = Sfcprop(nb)%hice(ix) + sfc_var2(i,j,23) = Sfcprop(nb)%fice(ix) + sfc_var2(i,j,24) = Sfcprop(nb)%tisfc(ix) + sfc_var2(i,j,25) = Sfcprop(nb)%tprcp(ix) + sfc_var2(i,j,26) = Sfcprop(nb)%srflag(ix) + sfc_var2(i,j,27) = Sfcprop(nb)%snowd(ix) + sfc_var2(i,j,28) = Sfcprop(nb)%shdmin(ix) + sfc_var2(i,j,29) = Sfcprop(nb)%shdmax(ix) + sfc_var2(i,j,30) = Sfcprop(nb)%slope(ix) + sfc_var2(i,j,31) = Sfcprop(nb)%snoalb(ix) + sfc_var2(i,j,32) = Sfcprop(nb)%sncovr(ix) + do lsoil = 1,Model%lsoil + sfc_var3(i,j,lsoil,1) = Sfcprop(nb)%stc(ix,lsoil) + sfc_var3(i,j,lsoil,2) = Sfcprop(nb)%smc(ix,lsoil) + sfc_var3(i,j,lsoil,3) = Sfcprop(nb)%slc(ix,lsoil) + enddo + enddo + enddo + + ! Coarse grain all the variables + + ! First coarse-grain the land surface type and upsample it back to the native resolution + call block_mode(sfc_var2(:,:,1), sfc_var2_coarse(:,:,1)) + call block_upsample(sfc_var2_coarse(:,:,1), dominant_sfc_type) + sfc_type_mask = (dominant_sfc_type .eq. sfc_var2(:,:,1)) + + ! Then coarse-grain the vegetation and soil types and upsample them too + call block_mode(sfc_var2(:,:,17), sfc_type_mask, sfc_var2_coarse(:,:,17)) + call block_upsample(sfc_var2_coarse(:,:,17), dominant_vtype) + call block_mode(sfc_var2(isc:iec,jsc:jec,18), sfc_type_mask, sfc_var2_coarse(:,:,18)) + call block_upsample(sfc_var2_coarse(:,:,18), dominant_stype) + + sfc_and_vtype_mask = (sfc_type_mask .and. (dominant_vtype .eq. sfc_var2(:,:,17))) + sfc_and_stype_mask = (sfc_type_mask .and. (dominant_stype .eq. sfc_var2(:,:,18))) + + ! Take the area weighted mean over full blocks for the surface temperature + call weighted_block_average(area, sfc_var2(:,:,2), sfc_var2_coarse(:,:,2)) + + ! Take the area weighted average over the dominant surface type for tg3 + call weighted_block_average(area, sfc_var2(:,:,4), sfc_type_mask, sfc_var2_coarse(:,:,4)) + + ! Take the area weighted average over the dominant surface type for vfrac + call weighted_block_average(area, sfc_var2(:,:,12), sfc_type_mask, sfc_var2_coarse(:,:,12)) + + ! Take the area and vfrac weighted average over the dominant surface and vegetation type for zorl and canopy + call weighted_block_average(area * sfc_var2(:,:,12), sfc_var2(:,:,5), sfc_and_vtype_mask, & + sfc_var2_coarse(:,:,5)) + call weighted_block_average(area * sfc_var2(:,:,12), sfc_var2(:,:,13), sfc_and_vtype_mask, & + sfc_var2_coarse(:,:,13)) + + ! Also compute a simple area weighted average over the dominant surface and + ! vegetation type for zorl and canopy; this will be used in the event that + ! the sum of vfrac is equal to zero. + call weighted_block_average(area, sfc_var2(:,:,5), sfc_and_vtype_mask, & + only_area_weighted_zorl) + call weighted_block_average(area, sfc_var2(:,:,13), sfc_and_vtype_mask, & + only_area_weighted_canopy) + + call block_sum(area * sfc_var2(:,:,12), sfc_and_vtype_mask, coarsened_area_times_vfrac) + + ! If the dominant surface type is ocean or sea-ice then just use the + ! area weighted average over the dominant surface and vegetation type for zorl or canopy. + where (coarsened_area_times_vfrac .eq. 0.0) + sfc_var2_coarse(:,:,5) = only_area_weighted_zorl + sfc_var2_coarse(:,:,13) = only_area_weighted_canopy + endwhere + + ! Take the area weighted average of the albedo variables + call weighted_block_average(area, sfc_var2(:,:,6), sfc_var2_coarse(:,:,6)) + call weighted_block_average(area, sfc_var2(:,:,7), sfc_var2_coarse(:,:,7)) + call weighted_block_average(area, sfc_var2(:,:,8), sfc_var2_coarse(:,:,8)) + call weighted_block_average(area, sfc_var2(:,:,9), sfc_var2_coarse(:,:,9)) + call weighted_block_average(area, sfc_var2(:,:,10), sfc_var2_coarse(:,:,10)) + call weighted_block_average(area, sfc_var2(:,:,11), sfc_var2_coarse(:,:,11)) + + ! Take the area weighted average of f10, t2m, q2m, uustar, ffmm, and ffhh + call weighted_block_average(area, sfc_var2(:,:,14), sfc_var2_coarse(:,:,14)) + call weighted_block_average(area, sfc_var2(:,:,15), sfc_var2_coarse(:,:,15)) + call weighted_block_average(area, sfc_var2(:,:,16), sfc_var2_coarse(:,:,16)) + call weighted_block_average(area, sfc_var2(:,:,19), sfc_var2_coarse(:,:,19)) + call weighted_block_average(area, sfc_var2(:,:,20), sfc_var2_coarse(:,:,20)) + call weighted_block_average(area, sfc_var2(:,:,21), sfc_var2_coarse(:,:,21)) + + ! Take the area weighted average over the dominant surface type for fice + call weighted_block_average(area, sfc_var2(:,:,23), sfc_type_mask, sfc_var2_coarse(:,:,23)) + + ! Compute the area weighted average of tpcrp + call weighted_block_average(area, sfc_var2(:,:,25), sfc_var2_coarse(:,:,25)) + + ! Take the mode for srflag + call block_mode(sfc_var2(:,:,26), sfc_var2_coarse(:,:,26)) + + ! Take the area weighted average for snow depth + call weighted_block_average(area, sfc_var2(:,:,27), sfc_var2_coarse(:,:,27)) + + ! Take the min and max over the dominant sfc type for shdmin and shdmax + call block_min(sfc_var2(:,:,28), sfc_type_mask, sfc_var2_coarse(:,:,28)) + call block_max(sfc_var2(:,:,29), sfc_type_mask, sfc_var2_coarse(:,:,29)) + + ! Take the masked block mode over the dominant surface type for slope + call block_mode(sfc_var2(:,:,30), sfc_type_mask, sfc_var2_coarse(:,:,30)) + + ! Take the block maximum for the snoalb + call block_max(sfc_var2(:,:,31), sfc_type_mask, sfc_var2_coarse(:,:,31)) + + ! Take the area weighted average over the dominant surface type for sncovr + call weighted_block_average(area, sfc_var2(:,:,32), sfc_type_mask, sfc_var2_coarse(:,:,32)) + + ! For sheleg take the area and sncovr weighted average; zero out any regions where the snow cover fraction is zero over the block. + call weighted_block_average(area * sfc_var2(:,:,32), sfc_var2(:,:,3), sfc_var2_coarse(:,:,3)) + call block_sum(area * sfc_var2(:,:,32), coarsened_area_times_sncovr) + where (coarsened_area_times_sncovr .eq. 0.0) + sfc_var2_coarse(:,:,3) = 0.0 + endwhere + + ! Do something similar for hice + call weighted_block_average(area * sfc_var2(:,:,23), sfc_var2(:,:,22), sfc_var2_coarse(:,:,22)) + call block_sum(area * sfc_var2(:,:,23), coarsened_area_times_fice) + where (coarsened_area_times_fice .eq. 0.0) + sfc_var2_coarse(:,:,22) = 0.0 + endwhere + + ! Over sea ice compute the area and ice fraction weighted average of tisfc; over all + ! other surfaces use just the area weighted average of tisfc. + call weighted_block_average(area * sfc_var2(:,:,23), sfc_var2(:,:,24), sfc_type_mask, sfc_var2_coarse(:,:,24)) + call weighted_block_average(area, sfc_var2(:,:,24), sfc_type_mask, tisfc_area_average) + where (sfc_var2_coarse(:,:,1) .lt. 2.0) + sfc_var2_coarse(:,:,24) = tisfc_area_average + endwhere + + ! Apply corrections to 2D variables based on surface_chgres.F90 + FREEZING = 273.16 + VTYPE_LAND_ICE = 15.0 + STYPE_LAND_ICE = 16.0 + SHDMIN_CANOPY_THRESHOLD = 0.011 + + ! Correction (1) + ! Clip tsea and tg3 at 273.16 K if a cell contains land ice. + where ((sfc_var2_coarse(:,:,2) .gt. FREEZING) .and. (sfc_var2_coarse(:,:,17) .eq. VTYPE_LAND_ICE)) + sfc_var2_coarse(:,:,2) = FREEZING + endwhere + where ((sfc_var2_coarse(:,:,4) .gt. FREEZING) .and. (sfc_var2_coarse(:,:,17) .eq. VTYPE_LAND_ICE)) + sfc_var2_coarse(:,:,4) = FREEZING + endwhere + + ! Correction (2) + ! If a cell contains land ice, make sure the soil type is ice. + where (sfc_var2_coarse(:,:,17) .eq. VTYPE_LAND_ICE) + sfc_var2_coarse(:,:,18) = STYPE_LAND_ICE + endwhere + + ! Correction (3) + ! If a cell does not contain vegetation, i.e. if shdmin < 0.011, + ! then set the canopy moisture content to zero. + where (sfc_var2_coarse(:,:,28) .lt. SHDMIN_CANOPY_THRESHOLD) + sfc_var2_coarse(:,:,13) = 0.0 + endwhere + + ! Correction (4) + ! If a cell contains land ice, then shdmin is set to zero. + where (sfc_var2_coarse(:,:,17) .eq. VTYPE_LAND_ICE) + sfc_var2_coarse(:,:,28) = 0.0 + endwhere + + ! For the 3D variables (all soil properties) take the area weighted average + ! over the dominant surface and soil type. + do num = 1,nvar3 + call weighted_block_average(area, sfc_var3(:,:,:,num), sfc_and_stype_mask, Model%lsoil, sfc_var3_coarse(:,:,:,num)) + enddo + + call write_restart(Sfc_restart_coarse) + call close_file(Sfc_restart_coarse) + endif + + + end subroutine sfc_prop_restart_write_coarse + + + subroutine register_coarse_sfc_prop_restart_fields(Model, var2, var3, nvar2, nvar3) + type(IPD_control_type), intent(in) :: Model + real(kind=kind_phys), target, intent(inout) :: var2(:,:,:) + real(kind=kind_phys), target, intent(inout) :: var3(:,:,:,:) + integer, intent(in) :: nvar2, nvar3 + + integer :: is, ie, num, lsoil + real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() + real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p => NULL() + integer, allocatable, dimension(:) :: buffer + character(len=8) :: dim_names_2d(3), dim_names_3d(4) + + !--- register the axes for restarts + call register_axis(Sfc_restart, 'xaxis_1', 'X') + call register_field(Sfc_restart, 'xaxis_1', 'double', (/'xaxis_1'/)) + call register_variable_attribute(Sfc_restart, 'xaxis_1', 'cartesian_axis', 'X', str_len=1) + call get_global_io_domain_indices(Sfc_restart, 'xaxis_1', is, ie, indices=buffer) + call write_data(Sfc_restart, "xaxis_1", buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'yaxis_1', 'Y') + call register_field(Sfc_restart, 'yaxis_1', 'double', (/'yaxis_1'/)) + call register_variable_attribute(Sfc_restart, 'yaxis_1', 'cartesian_axis', 'Y', str_len=1) + call get_global_io_domain_indices(Sfc_restart, 'yaxis_1', is, ie, indices=buffer) + call write_data(Sfc_restart, "yaxis_1", buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'zaxis_1', dimension_length=Model%lsoil) + call register_field(Sfc_restart, 'zaxis_1', 'double', (/'zaxis_1'/)) + call register_variable_attribute(Sfc_restart, 'zaxis_1', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(Model%lsoil) ) + do lsoil=1, Model%lsoil + buffer(lsoil) = lsoil + end do + call write_data(Sfc_restart, 'zaxis_1', buffer) + deallocate(buffer) + + call register_axis(Sfc_restart, 'Time', unlimited) + call register_field(Sfc_restart, 'Time', 'double', (/'Time'/)) + call register_variable_attribute(Sfc_restart, 'Time', 'cartesian_axis', 'T', str_len=1) + call write_data(Sfc_restart, 'Time', 1) + + !--- Assign dimensions to array for use in register_restart_field + dim_names_2d(1) = "xaxis_1" + dim_names_2d(2) = "yaxis_1" + dim_names_2d(3) = "Time" + dim_names_3d(1) = "xaxis_1" + dim_names_3d(2) = "yaxis_1" + dim_names_3d(3) = "zaxis_1" + dim_names_3d(4) = "Time" + + do num = 1,nvar2 + var2_p => var2(:,:,num) + call register_restart_fIeld(Sfc_restart_coarse, sfc_name2(num), var2_p, dim_names_2d) + nullify(var2_p) + enddo + + do num = 1,nvar3 + var3_p => var3(:,:,:,num) + call register_restart_field(Sfc_restart_coarse, sfc_name3(num), var3_p, dim_names_3d) + nullify(var3_p) + enddo + + end subroutine register_coarse_sfc_prop_restart_fields + +!---------------------------------------------------------------------- +! phys_restart_read +!---------------------------------------------------------------------- +! creates and populates a data type which is then used to "register" +! restart variables with the GFDL FMS restart subsystem. +! calls a GFDL FMS routine to restore the data from a restart file. +! calculates sncovr if it is not present in the restart file. +! +! calls: register_restart_field, restart_state, free_restart +! +! opens: phys_data.tile?.nc +! +!---------------------------------------------------------------------- + subroutine phys_restart_read (IPD_Restart, Atm_block, Model, fv_domain) + !--- interface variable definitions + type(IPD_restart_type), intent(in) :: IPD_Restart + type(block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + type(domain2d), intent(in) :: fv_domain + !--- local variables + integer :: i, j, k, nb, ix, num + integer :: isc, iec, jsc, jec, npz, nx, ny + integer :: nvar2d, nvar3d + character(len=64) :: fname + character(len=8) :: dim_names_2d(3), dim_names_3d(4) + real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() + real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p => NULL() + + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + npz = Atm_block%npz + nx = (iec - isc + 1) + ny = (jec - jsc + 1) + nvar2d = IPD_Restart%num2d + nvar3d = IPD_Restart%num3d + + !--- Assign dimensions to array for use in register_restart_field + dim_names_2d(1) = "xaxis_1" + dim_names_2d(2) = "yaxis_1" + dim_names_2d(3) = "Time" + dim_names_3d(1) = "xaxis_1" + dim_names_3d(2) = "yaxis_1" + dim_names_3d(3) = "zaxis_1" + dim_names_3d(4) = "Time" + + !--- Open the restart file and associate it with the Phy_restart fileobject + fname='INPUT/'//trim(fn_phy) + if (open_file(Phy_restart, fname, "read", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + + !--- register the axes for restarts + call register_axis(Phy_restart, "xaxis_1", "X") + call register_axis(Phy_restart, "yaxis_1", "Y") + call register_axis(Phy_restart, "zaxis_1", npz) + call register_axis(Phy_restart, "Time", unlimited) + + !--- register the restart fields + if (.not. allocated(phy_var2)) then + allocate (phy_var2(nx,ny,nvar2d)) + allocate (phy_var3(nx,ny,npz,nvar3d)) + phy_var2 = 0.0_kind_phys + phy_var3 = 0.0_kind_phys + + do num = 1,nvar2d + var2_p => phy_var2(:,:,num) + call register_restart_field (Phy_restart, trim(IPD_Restart%name2d(num)), & + var2_p, dim_names_2d, is_optional=.true.) + nullify(var2_p) + enddo + do num = 1,nvar3d + var3_p => phy_var3(:,:,:,num) + call register_restart_field (Phy_restart, trim(IPD_restart%name3d(num)), & + var3_p, dim_names_3d, is_optional=.true.) + nullify(var3_p) + enddo + endif + + !--- read the surface restart/data + call mpp_error(NOTE,'reading physics restart data from INPUT/phy_data.tile*.nc') + call read_restart(Phy_restart) + call close_file(Phy_restart) + else + call mpp_error(NOTE,'No physics restarts - cold starting physical parameterizations') + return + endif + + !--- place the data into the block GFS containers + !--- phy_var* variables + do num = 1,nvar2d + do nb = 1,Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + IPD_Restart%data(nb,num)%var2p(ix) = phy_var2(i,j,num) + enddo + enddo + enddo + do num = 1,nvar3d + do nb = 1,Atm_block%nblks + do k=1,npz + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + IPD_Restart%data(nb,num)%var3p(ix,k) = phy_var3(i,j,k,num) + enddo + enddo + enddo + enddo + + if (allocated(phy_var2)) deallocate(phy_var2) + if (allocated(phy_var3)) deallocate(phy_var3) + + end subroutine phys_restart_read + + +!---------------------------------------------------------------------- +! phys_restart_write +!---------------------------------------------------------------------- +! routine to write out GFS surface restarts via the GFDL FMS restart +! subsystem. +! takes an optional argument to append timestamps for intermediate +! restarts. +! +! calls: register_restart_field, save_restart +!---------------------------------------------------------------------- + subroutine phys_restart_write (IPD_Restart, Atm_block, Model, fv_domain, timestamp) + !--- interface variable definitions + type(IPD_restart_type), intent(in) :: IPD_Restart + type(block_control_type), intent(in) :: Atm_block + type(IPD_control_type), intent(in) :: Model + type(domain2d), intent(in) :: fv_domain + character(len=32), optional, intent(in) :: timestamp + !--- local variables + integer :: is, ie, i, j, k, nb, ix, num + integer :: isc, iec, jsc, jec, npz, nx, ny + integer :: nvar2d, nvar3d + integer, allocatable, dimension(:) :: buffer + character(len=64) :: fname + character(len=8) :: dim_names_2d(3), dim_names_3d(4) + real(kind=kind_phys), pointer, dimension(:,:) :: var2_p => NULL() + real(kind=kind_phys), pointer, dimension(:,:,:) :: var3_p => NULL() + + isc = Atm_block%isc + iec = Atm_block%iec + jsc = Atm_block%jsc + jec = Atm_block%jec + npz = Atm_block%npz + nx = (iec - isc + 1) + ny = (jec - jsc + 1) + nvar2d = IPD_Restart%num2d + nvar3d = IPD_Restart%num3d + + !--- Assign dimensions to array for use in register_restart_field + dim_names_2d(1) = "xaxis_1" + dim_names_2d(2) = "yaxis_1" + dim_names_2d(3) = "Time" + dim_names_3d(1) = "xaxis_1" + dim_names_3d(2) = "yaxis_1" + dim_names_3d(3) = "zaxis_1" + dim_names_3d(4) = "Time" + + !--- Open the restart file and associate it with the Phy_restart fileobject + if (present(timestamp)) then + fname='RESTART/'//trim(timestamp)//'.'//trim(fn_phy) + else + fname='RESTART/'//trim(fn_phy) + endif + + if (open_file(Phy_restart, fname, "overwrite", fv_domain, is_restart=.true., dont_add_res_to_filename=.true.)) then + + !--- register the axes for restarts + call register_axis(Phy_restart, "xaxis_1", "X") + call register_field(Phy_restart, 'xaxis_1', 'double', (/'xaxis_1'/)) + call register_variable_attribute(Phy_restart, 'xaxis_1', 'cartesian_axis', 'X', str_len=1) + call get_global_io_domain_indices(Phy_restart, 'xaxis_1', is, ie, indices=buffer) + call write_data(Phy_restart, "xaxis_1", buffer) + deallocate(buffer) + + call register_axis(Phy_restart, "yaxis_1", "Y") + call register_field(Phy_restart, 'yaxis_1', 'double', (/'yaxis_1'/)) + call register_variable_attribute(Phy_restart, 'yaxis_1', 'cartesian_axis', 'Y', str_len=1) + call get_global_io_domain_indices(Phy_restart, 'yaxis_1', is, ie, indices=buffer) + call write_data(Phy_restart, "yaxis_1", buffer) + deallocate(buffer) + + call register_axis(Phy_restart, "zaxis_1", npz) + call register_field(Phy_restart, 'zaxis_1', 'double', (/'zaxis_1'/)) + call register_variable_attribute(Phy_restart, 'zaxis_1', 'cartesian_axis', 'Z', str_len=1) + allocate( buffer(npz) ) + do i=1, npz + buffer(i)=i + end do + call write_data(Phy_restart, "zaxis_1", buffer) + deallocate(buffer) + + call register_axis(Phy_restart, "Time", unlimited) + call register_field(Phy_restart, 'Time', 'double', (/'Time'/)) + call register_variable_attribute(Phy_restart, 'Time', 'cartesian_axis', 'T', str_len=1) + call write_data(Phy_restart, "Time", 1) + + !--- register the restart fields + if (.not. allocated(phy_var2)) then + allocate (phy_var2(nx,ny,nvar2d)) + allocate (phy_var3(nx,ny,npz,nvar3d)) + phy_var2 = 0.0_kind_phys + phy_var3 = 0.0_kind_phys + + do num = 1,nvar2d + var2_p => phy_var2(:,:,num) + call register_restart_field (Phy_restart, trim(IPD_Restart%name2d(num)), & + var2_p, dim_names_2d) + nullify(var2_p) + enddo + do num = 1,nvar3d + var3_p => phy_var3(:,:,:,num) + call register_restart_field (Phy_restart, trim(IPD_restart%name3d(num)), & + var3_p, dim_names_3d) + nullify(var3_p) + enddo + endif + + !--- 2D variables + do num = 1,nvar2d + do nb = 1,Atm_block%nblks + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + phy_var2(i,j,num) = IPD_Restart%data(nb,num)%var2p(ix) + enddo + enddo + enddo + !--- 3D variables + do num = 1,nvar3d + do nb = 1,Atm_block%nblks + do k=1,npz + do ix = 1, Atm_block%blksz(nb) + i = Atm_block%index(nb)%ii(ix) - isc + 1 + j = Atm_block%index(nb)%jj(ix) - jsc + 1 + phy_var3(i,j,k,num) = IPD_Restart%data(nb,num)%var3p(ix,k) + enddo + enddo + enddo + enddo + + call write_restart(Phy_restart) + call close_file(Phy_restart) + + if (allocated(phy_var2)) deallocate (phy_var2) + if (allocated(phy_var3)) deallocate (phy_var3) + endif + + end subroutine phys_restart_write + + subroutine register_diag_manager_controlled_diagnostics(Time, IntDiag, nblks, axes) + type(time_type), intent(in) :: Time + type(GFS_diag_type), intent(in) :: IntDiag(:) + integer, intent(in) :: nblks + integer, intent(in) :: axes(4) + + integer :: nb + integer :: index = 1 + + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_longwave_heating' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to longwave radiation' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,1) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_shortwave_heating' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to shortwave radiation' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,2) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_turbulence' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to turbulence scheme' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,3) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_deep_convection' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to deep convection' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,4) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_shallow_convection' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to shallow convection' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,5) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_microphysics' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to micro-physics' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,6) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_dissipation_of_gravity_waves' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to gravity wave drag' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,7) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to clear sky longwave radiation' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,8) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky' + Diag_diag_manager_controlled(index)%desc = 'temperature tendency due to clear sky shortwave radiation' + Diag_diag_manager_controlled(index)%unit = 'K/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%t_dt(:,:,9) + enddo + + ! Vertically integrated instantaneous temperature tendency diagnostics + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_longwave_heating' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to longwave radiation' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,1) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_shortwave_heating' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to shortwave radiation' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,2) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_turbulence' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to turbulence scheme' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,3) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_deep_convection' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to deep convection' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,4) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_shallow_convection' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to shallow convection' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,5) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_microphysics' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to micro-physics' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,6) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_dissipation_of_gravity_waves' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to gravity wave drag' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,7) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_longwave_heating_assuming_clear_sky' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to clear sky longwave radiation' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,8) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_air_temperature_due_to_shortwave_heating_assuming_clear_sky' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated temperature tendency due to clear sky shortwave radiation' + Diag_diag_manager_controlled(index)%unit = 'W/m**2' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%t_dt_int(:,9) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_specific_humidity_due_to_turbulence' + Diag_diag_manager_controlled(index)%desc = 'water vapor tendency due to turbulence scheme' + Diag_diag_manager_controlled(index)%unit = 'kg/kg/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%q_dt(:,:,1) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_specific_humidity_due_to_deep_convection' + Diag_diag_manager_controlled(index)%desc = 'water vapor tendency due to deep convection' + Diag_diag_manager_controlled(index)%unit = 'kg/kg/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%q_dt(:,:,2) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_specific_humidity_due_to_shallow_convection' + Diag_diag_manager_controlled(index)%desc = 'water vapor tendency due to shallow convection' + Diag_diag_manager_controlled(index)%unit = 'kg/kg/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%q_dt(:,:,3) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_specific_humidity_due_to_microphysics' + Diag_diag_manager_controlled(index)%desc = 'water vapor tendency due to microphysics' + Diag_diag_manager_controlled(index)%unit = 'kg/kg/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%q_dt(:,:,4) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 3 + Diag_diag_manager_controlled(index)%name = 'tendency_of_specific_humidity_due_to_change_in_atmosphere_mass' + Diag_diag_manager_controlled(index)%desc = 'residual water vapor tendency' + Diag_diag_manager_controlled(index)%unit = 'kg/kg/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'mass_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var3 => IntDiag(nb)%q_dt(:,:,5) + enddo + + ! Vertically integrated instantaneous specific humidity tendency diagnostics + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_specific_humidity_due_to_turbulence' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated water vapor tendency due to turbulence scheme' + Diag_diag_manager_controlled(index)%unit = 'kg/m**2/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%q_dt_int(:,1) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_specific_humidity_due_to_deep_convection' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated water vapor tendency due to deep convection' + Diag_diag_manager_controlled(index)%unit = 'kg/m**2/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%q_dt_int(:,2) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_specific_humidity_due_to_shallow_convection' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated water vapor tendency due to shallow convection' + Diag_diag_manager_controlled(index)%unit = 'kg/m**2/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%q_dt_int(:,3) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_specific_humidity_due_to_microphysics' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated water vapor tendency due to microphysics' + Diag_diag_manager_controlled(index)%unit = 'kg/m**2/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%q_dt_int(:,4) + enddo + + index = index + 1 + Diag_diag_manager_controlled(index)%axes = 2 + Diag_diag_manager_controlled(index)%name = 'vertically_integrated_tendency_of_specific_humidity_due_to_change_in_atmosphere_mass' + Diag_diag_manager_controlled(index)%desc = 'vertically integrated residual water vapor tendency' + Diag_diag_manager_controlled(index)%unit = 'kg/m**2/s' + Diag_diag_manager_controlled(index)%mod_name = 'gfs_phys' + Diag_diag_manager_controlled(index)%coarse_graining_method = 'area_weighted' + allocate (Diag_diag_manager_controlled(index)%data(nblks)) + do nb = 1,nblks + Diag_diag_manager_controlled(index)%data(nb)%var2 => IntDiag(nb)%q_dt_int(:,5) + enddo + + do index = 1, DIAG_SIZE + if (trim(Diag_diag_manager_controlled(index)%name) .eq. '') exit ! No need to populate non-existent diagnostics + Diag_diag_manager_controlled(index)%id = register_diag_field(trim(Diag_diag_manager_controlled(index)%mod_name), & + & trim(Diag_diag_manager_controlled(index)%name), & + & axes(1:Diag_diag_manager_controlled(index)%axes), Time, trim(Diag_diag_manager_controlled(index)%desc), & + & trim(Diag_diag_manager_controlled(index)%unit), missing_value=real(missing_value)) + enddo + end subroutine register_diag_manager_controlled_diagnostics + +!------------------------------------------------------------------------- +!--- gfdl_diag_register --- +!------------------------------------------------------------------------- +! creates and populates a data type which is then used to "register" +! GFS physics diagnostic variables with the GFDL FMS diagnostic manager. +! includes short & long names, units, conversion factors, etc. +! there is no copying of data, but instead a clever use of pointers. +! calls a GFDL FMS routine to register diagnositcs and compare against +! the diag_table to determine what variables are to be output. +! +! calls: register_diag_field +!------------------------------------------------------------------------- +! Current sizes +! 13+NFXR - radiation +! 76+pl_coeff - physics +!------------------------------------------------------------------------- + subroutine gfdl_diag_register(Time, Sfcprop, Gfs_diag, Cldprop, & + Atm_block, axes, NFXR, ldiag3d, nkld, levs) + use physcons, only: con_g +!--- subroutine interface variable definitions + type(time_type), intent(in) :: Time + type(Gfs_sfcprop_type), intent(in) :: Sfcprop(:) + type(GFS_diag_type), intent(in) :: Gfs_diag(:) + type(GFS_cldprop_type), intent(in) :: Cldprop(:) + type (block_control_type), intent(in) :: Atm_block + integer, dimension(4), intent(in) :: axes + integer, intent(in) :: NFXR + logical, intent(in) :: ldiag3d + integer, intent(in) :: nkld + integer, intent(in) :: levs +!--- local variables + integer :: idx, num, nb, nblks, nx, ny, k + integer, allocatable :: blksz(:) + character(len=2) :: xtra + real(kind=kind_phys), parameter :: cn_one = 1._kind_phys + real(kind=kind_phys), parameter :: cn_100 = 100._kind_phys + real(kind=kind_phys), parameter :: cn_th = 1000._kind_phys + real(kind=kind_phys), parameter :: cn_hr = 3600._kind_phys + + nblks = Atm_block%nblks + allocate (blksz(nblks)) + blksz(:) = Atm_block%blksz(:) + + isco = Atm_block%isc + ieco = Atm_block%iec + jsco = Atm_block%jsc + jeco = Atm_block%jec + levo = levs + + Diag(:)%id = -99 + Diag(:)%axes = -99 + Diag(:)%cnvfac = cn_one + Diag(:)%time_avg = .FALSE. + Diag(:)%time_avg_kind = '' + Diag(:)%mask = '' + Diag(:)%coarse_graining_method = 'area_weighted' + Diag(:)%intpl_method = 'nearest_stod' + + idx = 0 + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ALBDOsfc' + Diag(idx)%desc = 'surface albedo' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + Diag(idx)%mask = 'positive_flux' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,3) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,4) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'USWRFsfc' + Diag(idx)%desc = 'averaged surface upward shortwave flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,3) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'DSWRFsfc' + Diag(idx)%desc = 'averaged surface downward shortwave flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,4) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'DLWRFsfc' + Diag(idx)%desc = 'surface downward longwave flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_lw' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,19) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ULWRFsfc' + Diag(idx)%desc = 'surface upward longwave flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_lw' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,20) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'duvb_ave' + Diag(idx)%desc = 'UV-B Downward Solar Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,21) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cduvb_ave' + Diag(idx)%desc = 'Clear sky UV-B Downward Solar Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,22) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'vbdsf_ave' + Diag(idx)%desc = 'Visible Beam Downward Solar Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,24) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'vddsf_ave' + Diag(idx)%desc = 'Visible Diffuse Downward Solar Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,25) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'nbdsf_ave' + Diag(idx)%desc = 'Near IR Beam Downward Solar Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,26) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'nddsf_ave' + Diag(idx)%desc = 'Near IR Diffuse Downward Solar Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,27) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'csulf_avetoa' + Diag(idx)%desc = 'Clear Sky Upward Long Wave Flux at toa' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_lw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,28) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'csusf_avetoa' + Diag(idx)%desc = 'Clear Sky Upward Short Wave Flux at toa' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,29) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'csdlf_ave' + Diag(idx)%desc = 'Clear Sky Downward Long Wave Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_lw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,30) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'csusf_ave' + Diag(idx)%desc = 'Clear Sky Upward Short Wave Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,31) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'csdsf_ave' + Diag(idx)%desc = 'Clear Sky Downward Short Wave Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,32) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'csulf_ave' + Diag(idx)%desc = 'Clear Sky Upward Long Wave Flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_lw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,33) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'DSWRFtoa' + Diag(idx)%desc = 'top of atmos downward shortwave flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,23) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'USWRFtoa' + Diag(idx)%desc = 'top of atmos upward shortwave flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_sw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,2) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ULWRFtoa' + Diag(idx)%desc = 'top of atmos upward longwave flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_lw' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,1) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TCDCclm' + Diag(idx)%desc = 'atmos column total cloud cover [%]' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,17) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TCDCbndcl' + Diag(idx)%desc = 'boundary layer cloud layer total cloud cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,18) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TCDCcnvcl' + Diag(idx)%desc = 'convective cloud layer total cloud cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Cldprop(nb)%cv(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PREScnvclt' + Diag(idx)%desc = 'pressure at convective cloud top level' + Diag(idx)%unit = 'pa' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%mask = 'cldmask' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Cldprop(nb)%cvt(:) + Diag(idx)%data(nb)%var21 => Cldprop(nb)%cv(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PREScnvclb' + Diag(idx)%desc = 'pressure at convective cloud bottom level' + Diag(idx)%unit = 'pa' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%mask = 'cldmask' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Cldprop(nb)%cvb(:) + Diag(idx)%data(nb)%var21 => Cldprop(nb)%cv(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TCDChcl' + Diag(idx)%desc = 'high cloud level total cloud cover [%]' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,5) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PRES_avehct' + Diag(idx)%desc = 'pressure high cloud top level' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,8) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,5) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PRES_avehcb' + Diag(idx)%desc = 'pressure high cloud bottom level' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,11) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,5) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TEMP_avehct' + Diag(idx)%desc = 'temperature high cloud top level' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,14) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,5) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TCDCmcl' + Diag(idx)%desc = 'mid cloud level total cloud cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,6) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PRES_avemct' + Diag(idx)%desc = 'pressure middle cloud top level' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,9) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,6) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PRES_avemcb' + Diag(idx)%desc = 'pressure middle cloud bottom level' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,12) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,6) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TEMP_avemct' + Diag(idx)%desc = 'temperature middle cloud top level' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,15) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,6) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TCDClcl' + Diag(idx)%desc = 'low cloud level total cloud cover' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_100 + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,7) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PRES_avelct' + Diag(idx)%desc = 'pressure low cloud top level' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,10) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,7) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'PRES_avelcb' + Diag(idx)%desc = 'pressure low cloud bottom level' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,13) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,7) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'TEMP_avelct' + Diag(idx)%desc = 'temperature low cloud top level' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'rad_swlw_min' + Diag(idx)%mask = "cldmask_ratio" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,16) + Diag(idx)%data(nb)%var21 => Gfs_diag(nb)%fluxr(:,7) + enddo + +!--- accumulated diagnostics --- + do num = 1,NFXR + write (xtra,'(I2.2)') num + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'fluxr_'//trim(xtra) + Diag(idx)%desc = 'fluxr diagnostic '//trim(xtra)//' - GFS radiation' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%fluxr(:,num) + enddo + enddo + +!--- averaged diagnostics --- + do num = 1,nkld + write (xtra,'(I2.2)') num + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'cloud_'//trim(xtra) + Diag(idx)%desc = 'cloud diagnostic '//trim(xtra)//' - GFS radiation' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%cloud(:,:,num) + enddo + enddo + +!--- the next two appear to be appear to be coupling fields in gloopr +!--- each has four elements +!rab do num = 1,4 +!rab write (xtra,'(I1)') num +!rab idx = idx + 1 +!rab Diag(idx)%axes = 2 +!rab Diag(idx)%name = 'dswcmp_'//trim(xtra) +!rab Diag(idx)%desc = 'dswcmp dagnostic '//trim(xtra)//' - GFS radiation' +!rab Diag(idx)%unit = 'XXX' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab do nb = 1,nblks +!rab Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dswcmp(:,num) +!rab enddo +!rab enddo +!rab +!rab do num = 1,4 +!rab write (xtra,'(I1)') num +!rab idx = idx + 1 +!rab Diag(idx)%axes = 2 +!rab Diag(idx)%name = 'uswcmp_'//trim(xtra) +!rab Diag(idx)%desc = 'uswcmp dagnostic '//trim(xtra)//' - GFS radiation' +!rab Diag(idx)%unit = 'XXX' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab do nb = 1,nblks +!rab Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%uswcmp(:,num) +!rab enddo +!rab enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sw_upfxc' + Diag(idx)%desc = 'total sky upward sw flux at toa - GFS radiation' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%topfsw(:)%upfxc + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sw_dnfxc' + Diag(idx)%desc = 'total sky downward sw flux at toa - GFS radiation' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%topfsw(:)%dnfxc + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sw_upfx0' + Diag(idx)%desc = 'clear sky upward sw flux at toa - GFS radiation' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%topfsw(:)%upfx0 + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'lw_upfxc' + Diag(idx)%desc = 'total sky upward lw flux at toa - GFS radiation' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%topflw(:)%upfxc + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'lw_upfx0' + Diag(idx)%desc = 'clear sky upward lw flux at toa - GFS radiation' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%topflw(:)%upfx0 + enddo + +!--- physics accumulated diagnostics --- + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ssrun_acc' + Diag(idx)%desc = 'surface storm water runoff - GFS lsm' + Diag(idx)%unit = 'kg/m**2' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%srunoff(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'evbs_ave' + Diag(idx)%desc = 'Direct Evaporation from Bare Soil - GFS lsm' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%evbsa(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'evcw_ave' + Diag(idx)%desc = 'Canopy water evaporation - GFS lsm' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%evcwa(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'snohf_ave' + Diag(idx)%desc = 'Snow Phase Change Heat Flux - GFS lsm' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%snohfa(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'trans_ave' + Diag(idx)%desc = 'transpiration - GFS lsm' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%transa(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sbsno_ave' + Diag(idx)%desc = 'Sublimation (evaporation from snow) - GFS lsm' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%sbsnoa(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'snowc_ave' + Diag(idx)%desc = 'snow cover - GFS lsm' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%cnvfac = cn_100 + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%snowca(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'soilm' + Diag(idx)%desc = 'total column soil moisture content [kg/m**2]' + Diag(idx)%unit = 'kg/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%mask = "land_only" + Diag(idx)%coarse_graining_method = MASKED_AREA_WEIGHTED + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%soilm(:) + Diag(idx)%data(nb)%var21 => Sfcprop(nb)%slmsk(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tmpmin2m' + Diag(idx)%desc = 'min temperature at 2m height' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tmpmin(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tmpmax2m' + Diag(idx)%desc = 'max temperature at 2m height' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tmpmax(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'dusfc' + Diag(idx)%desc = 'surface zonal momentum flux [N/m**2]' + Diag(idx)%unit = 'N/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dusfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'dvsfc' + Diag(idx)%desc = 'surface meridional momentum flux' + Diag(idx)%unit = 'N/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dvsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'shtfl_ave' + Diag(idx)%desc = 'surface sensible heat flux' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dtsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'lhtfl_ave' + Diag(idx)%desc = 'surface latent heat flux [W/m**2]' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dqsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totprcp_ave' + Diag(idx)%desc = 'surface precipitation rate [kg/m**2/s]' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'full' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totprcp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totprcpb_ave' + Diag(idx)%desc = 'bucket surface precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totprcpb(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'gflux_ave' + Diag(idx)%desc = 'surface ground heat flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. +! Diag(idx)%mask = "land_ice_only" + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%gflux(:) +! Diag(idx)%data(nb)%var21 => Sfcprop(nb)%slmsk(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'DLWRF' + Diag(idx)%desc = 'time accumulated downward lw flux at surface- GFS physics' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dlwsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ULWRF' + Diag(idx)%desc = 'time accumulated upward lw flux at surface- GFS physics' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%ulwsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sunsd_acc' + Diag(idx)%desc = 'sunshine duration time' + Diag(idx)%unit = 's' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%suntim(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'watr_acc' + Diag(idx)%desc = 'total water runoff' + Diag(idx)%unit = 'kg/m**2' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%runoff(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'pevpr_ave' + Diag(idx)%desc = 'averaged potential evaporation rate' + Diag(idx)%unit = 'W/M**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%ep(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cwork_ave' + Diag(idx)%desc = 'cloud work function (valid only with sas)' + Diag(idx)%unit = 'J/kg' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cldwrk(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'u-gwd_ave' + Diag(idx)%desc = 'surface zonal gravity wave stress' + Diag(idx)%unit = 'N/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dugwd(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'v-gwd_ave' + Diag(idx)%desc = 'surface meridional gravity wave stress' + Diag(idx)%unit = 'N/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dvgwd(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'psmean' + Diag(idx)%desc = 'surface pressure' + Diag(idx)%unit = 'kPa' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%psmean(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cnvprcp_ave' + Diag(idx)%desc = 'averaged surface convective precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'full' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cnvprcp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cnvprcpb_ave' + Diag(idx)%desc = 'averaged bucket surface convective precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cnvprcpb(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cnvprcp' + Diag(idx)%desc = 'surface convective precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cnvprcp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'spfhmin2m' + Diag(idx)%desc = 'minimum specific humidity at 2m height' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%spfhmin(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'spfhmax2m' + Diag(idx)%desc = 'maximum specific humidity at 2m height' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%spfhmax(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'u10mmax' + Diag(idx)%desc = 'maximum (magnitude) u-wind' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'vector_bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%u10mmax(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'v10mmax' + Diag(idx)%desc = 'maximum (magnitude) v-wind' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'vector_bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%v10mmax(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'wind10mmax' + Diag(idx)%desc = 'maximum wind speed' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%wind10mmax(:) + enddo + +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'u10max' +! Diag(idx)%desc = 'hourly maximum (magnitude) u-wind' +! Diag(idx)%unit = 'm/s' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'vector_bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%u10max(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'v10max' +! Diag(idx)%desc = 'hourly maximum (magnitude) v-wind' +! Diag(idx)%unit = 'm/s' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'vector_bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%v10max(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'spd10max' +! Diag(idx)%desc = 'hourly maximum wind speed' +! Diag(idx)%unit = 'm/s' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%spd10max(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 't02max' +! Diag(idx)%desc = 'max hourly 2m Temperature' +! Diag(idx)%unit = 'K' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%t02max(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 't02min' +! Diag(idx)%desc = 'min hourly 2m Temperature' +! Diag(idx)%unit = 'K' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%t02min(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'rh02max' +! Diag(idx)%desc = 'max hourly 2m RH' +! Diag(idx)%unit = '%' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%rh02max(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'rh02min' +! Diag(idx)%desc = 'min hourly 2m RH' +! Diag(idx)%unit = '%' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%rh02min(:) +! enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'rain' + Diag(idx)%desc = 'total rain at this time step' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%rain(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'rainc' + Diag(idx)%desc = 'convective rain at this time step' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%rainc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ice' + Diag(idx)%desc = 'ice fall at this time step' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%ice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'snow' + Diag(idx)%desc = 'snow fall at this time step' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%snow(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'graupel' + Diag(idx)%desc = 'graupel fall at this time step' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%graupel(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totice_ave' + Diag(idx)%desc = 'surface ice precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'full' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'toticeb_ave' + Diag(idx)%desc = 'bucket surface ice precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%toticeb(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totsnw_ave' + Diag(idx)%desc = 'surface snow precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'full' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totsnw(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totsnwb_ave' + Diag(idx)%desc = 'bucket surface snow precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totsnwb(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totgrp_ave' + Diag(idx)%desc = 'surface graupel precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + Diag(idx)%time_avg_kind = 'full' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totgrp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'totgrpb_ave' + Diag(idx)%desc = 'bucket surface graupel precipitation rate' + Diag(idx)%unit = 'kg/m**2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_th + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%totgrpb(:) + enddo + +!--- physics instantaneous diagnostics --- + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'u10m' + Diag(idx)%desc = '10 meter u wind [m/s]' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'vector_bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%u10m(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'v10m' + Diag(idx)%desc = '10 meter v wind [m/s]' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'vector_bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%v10m(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'dpt2m' + Diag(idx)%desc = '2 meter dew point temperature [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dpt2m(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'hgt_hyblev1' + Diag(idx)%desc = 'layer 1 height' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%zlvl(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'psurf' + Diag(idx)%desc = 'surface pressure [Pa]' + Diag(idx)%unit = 'Pa' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%psurf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'hpbl' + Diag(idx)%desc = 'surface planetary boundary layer height [m]' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%hpbl(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'hgamt' + Diag(idx)%desc = 'ysu counter-gradient heat flux factor' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%hgamt(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'hfxpbl' + Diag(idx)%desc = 'ysu entrainment heat flux factor' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%hfxpbl(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'pwat' + Diag(idx)%desc = 'atmos column precipitable water [kg/m**2]' + Diag(idx)%unit = 'kg/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%pwat(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tmp_hyblev1' + Diag(idx)%desc = 'layer 1 temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%t1(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'spfh_hyblev1' + Diag(idx)%desc = 'layer 1 specific humidity' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%q1(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ugrd_hyblev1' + Diag(idx)%desc = 'layer 1 zonal wind' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'vector_bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%u1(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'vgrd_hyblev1' + Diag(idx)%desc = 'layer 1 meridional wind' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'vector_bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%v1(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'sfexc' + Diag(idx)%desc = 'Exchange Coefficient' + Diag(idx)%unit = 'kg/m2/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%chh(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'acond' + Diag(idx)%desc = 'Aerodynamic conductance' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%cmm(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'DLWRFI' + Diag(idx)%desc = 'instantaneous sfc downward lw flux' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dlwsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ULWRFI' + Diag(idx)%desc = 'instantaneous sfc upward lw flux' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%ulwsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'DSWRFI' + Diag(idx)%desc = 'instantaneous sfc downward sw flux' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dswsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'USWRFI' + Diag(idx)%desc = 'instantaneous sfc upward sw flux' + Diag(idx)%unit = 'w/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%uswsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'dusfci' + Diag(idx)%desc = 'instantaneous u component of surface stress' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dusfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'dvsfci' + Diag(idx)%desc = 'instantaneous v component of surface stress' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dvsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'shtfl' + Diag(idx)%desc = 'instantaneous surface sensible heat flux' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dtsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'lhtfl' + Diag(idx)%desc = 'instantaneous surface latent heat flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%dqsfci(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'gfluxi' + Diag(idx)%desc = 'instantaneous surface ground heat flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%gfluxi(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'pevpr' + Diag(idx)%desc = 'instantaneous surface potential evaporation' + Diag(idx)%unit = 'W/M**2' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%epi(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'wilt' + Diag(idx)%desc = 'wiltimg point (volumetric)' + Diag(idx)%unit = 'Proportion' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%smcwlt2(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'fldcp' + Diag(idx)%desc = 'Field Capacity (volumetric)' + Diag(idx)%unit = 'fraction' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%smcref2(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'wet1' + Diag(idx)%desc = 'normalized soil wetness' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%wet1(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'cpofp' + Diag(idx)%desc = 'Percent frozen precipitation' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%intpl_method = 'bilinear' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%sr(:) + enddo + +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'crain_ave' +! Diag(idx)%desc = 'averaged categorical rain' +! Diag(idx)%unit = 'number' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! Diag(idx)%cnvfac = cn_one +! Diag(idx)%time_avg = .TRUE. +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tdomr(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'csnow_ave' +! Diag(idx)%desc = 'averaged categorical snow' +! Diag(idx)%unit = 'number' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! Diag(idx)%cnvfac = cn_one +! Diag(idx)%time_avg = .TRUE. +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tdoms(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'cfrzr_ave' +! Diag(idx)%desc = 'averaged categorical freezing rain' +! Diag(idx)%unit = 'number' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! Diag(idx)%cnvfac = cn_one +! Diag(idx)%time_avg = .TRUE. +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tdomzr(:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'cicep_ave' +! Diag(idx)%desc = 'averaged categorical sleet' +! Diag(idx)%unit = 'number' +! Diag(idx)%mod_name = 'gfs_phys' +! Diag(idx)%intpl_method = 'bilinear' +! Diag(idx)%cnvfac = cn_one +! Diag(idx)%time_avg = .TRUE. +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tdomip(:) +! enddo +! +!--- three-dimensional variables that need to be handled special when writing + if (ldiag3d) then + + do num = 1,6 + write (xtra,'(I1)') num + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dt3dt_'//trim(xtra) + Diag(idx)%desc = 'temperature change due to physics '//trim(xtra)//'' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%coarse_graining_method = 'mass_weighted' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%dt3dt(:,:,num) + enddo + enddo + + do num = 1,5+oz_coeff + write (xtra,'(I1)') num + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dq3dt_'//trim(xtra) + Diag(idx)%desc = 'moisture change due to physics '//trim(xtra)//'' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + Diag(idx)%coarse_graining_method = 'mass_weighted' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%dq3dt(:,:,num) + enddo + enddo + + do num = 1,4 + write (xtra,'(I1)') num + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'du3dt_'//trim(xtra) + Diag(idx)%desc = 'u momentum change due to physics '//trim(xtra)//'' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%du3dt(:,:,num) + enddo + enddo + + do num = 1,4 + write (xtra,'(I1)') num + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dv3dt_'//trim(xtra) + Diag(idx)%desc = 'v momentum change due to physics '//trim(xtra)//'' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%dv3dt(:,:,num) + enddo + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'dkt_pbl' + Diag(idx)%desc = 'instantaneous heat diffusion coefficient' + Diag(idx)%unit = 'm**2/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%dkt(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'flux_cg' + Diag(idx)%desc = 'instantaneous counter-gradient heat flux in ysu' + Diag(idx)%unit = 'K*m/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%flux_cg(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'flux_en' + Diag(idx)%desc = 'instantaneous entrainment heat flux in ysu' + Diag(idx)%unit = 'K*m/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%flux_en(:,:) + enddo + +! idx = idx + 1 +! Diag(idx)%axes = 3 +! Diag(idx)%name = 'refl_10cm' +! Diag(idx)%desc = 'Radar reflectivity' +! Diag(idx)%unit = 'dBz' +! Diag(idx)%mod_name = 'gfs_phys' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%refl_10cm(:,:) +! enddo +! +! idx = idx + 1 +! Diag(idx)%axes = 3 +! Diag(idx)%name = 'cnvw' +! Diag(idx)%desc = 'subgrid scale convective cloud water' +! Diag(idx)%unit = 'kg/kg' +! Diag(idx)%mod_name = 'gfs_phys' +! allocate (Diag(idx)%data(nblks)) +! if( Model%ncnvw > 0 ) then +! do nb = 1,nblks +! Diag(idx)%data(nb)%var3 => Tbd(nb)%phy_f3d(:,:,Model%ncnvw) +! enddo +! endif + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'diss_est' + Diag(idx)%desc = 'dissipation rate for skeb' + Diag(idx)%unit = 'none' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%diss_est(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'skebu_wts' + Diag(idx)%desc = 'perturbation velocity' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%skebu_wts(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'skebv_wts' + Diag(idx)%desc = 'perturbation velocity' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%skebv_wts(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'zmtnblck' + Diag(idx)%desc = 'level of dividing streamline' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%zmtnblck(:) + enddo + +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'refdmax' +! Diag(idx)%desc = 'max hourly 1-km agl reflectivity' +! Diag(idx)%unit = 'dBZ' +! Diag(idx)%mod_name = 'gfs_phys' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%refdmax(:) +! enddo +! idx = idx + 1 +! Diag(idx)%axes = 2 +! Diag(idx)%name = 'refdmax263k' +! Diag(idx)%desc = 'max hourly -10C reflectivity' +! Diag(idx)%unit = 'dBZ' +! Diag(idx)%mod_name = 'gfs_phys' +! allocate (Diag(idx)%data(nblks)) +! do nb = 1,nblks +! Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%refdmax263k(:) +! enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'sppt_wts' + Diag(idx)%desc = 'perturbation velocity' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%sppt_wts(:,:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 3 + Diag(idx)%name = 'shum_wts' + Diag(idx)%desc = 'perturbation velocity' + Diag(idx)%unit = 'm/s' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%shum_wts(:,:) + enddo + +!!$ idx = idx + 1 +!!$ Diag(idx)%axes = 3 +!!$ !Requires lgocart = .T. +!!$ Diag(idx)%name = 'dqdt_v' +!!$ Diag(idx)%desc = 'instantaneous total moisture tendency' +!!$ Diag(idx)%unit = 'XXX' +!!$ Diag(idx)%mod_name = 'gfs_phys' +!!$ allocate (Diag(idx)%data(nblks)) +!!$ do nb = 1,nblks +!!$ Diag(idx)%data(nb)%var3 => Gfs_diag(nb)%Diag(nb)%dqdt_v(:,:,num) +!!$ enddo + +! +!--- prognostic variable tendencies (T, u, v, sph, clwmr, o3) +!rab idx = idx + 1 +!rab Diag(idx)%axes = 3 +!rab Diag(idx)%name = 'dtemp_dt' +!rab Diag(idx)%desc = 'GFS radiation/physics temperature tendency' +!rab Diag(idx)%unit = 'K/s' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab +!rab idx = idx + 1 +!rab Diag(idx)%axes = 3 +!rab Diag(idx)%name = 'du_dt' +!rab Diag(idx)%desc = 'GFS radiation/physics horizontal wind component tendency' +!rab Diag(idx)%unit = 'm/s/s' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab +!rab idx = idx + 1 +!rab Diag(idx)%axes = 3 +!rab Diag(idx)%name = 'dv_dt' +!rab Diag(idx)%desc = 'GFS radiation/physics meridional wind component tendency' +!rab Diag(idx)%unit = 'm/s/s' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab +!rab idx = idx + 1 +!rab Diag(idx)%axes = 3 +!rab Diag(idx)%name = 'dsphum_dt' +!rab Diag(idx)%desc = 'GFS radiation/physics specific humidity tendency' +!rab Diag(idx)%unit = 'kg/kg/s' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab +!rab idx = idx + 1 +!rab Diag(idx)%axes = 3 +!rab Diag(idx)%name = 'dclwmr_dt' +!rab Diag(idx)%desc = 'GFS radiation/radiation cloud water mixing ratio tendency' +!rab Diag(idx)%unit = 'kg/kg/s' +!rab Diag(idx)%mod_name = 'gfs_phys' +!rab +!rab idx = idx + 1 +!rab Diag(idx)%axes = 3 +!rab Diag(idx)%name = 'do3mr_dt' +!rab Diag(idx)%desc = 'GFS radiation/radiation ozone mixing ratio tendency' +!rab Diag(idx)%unit = 'kg/kg/s' +!rab Diag(idx)%mod_name = 'gfs_phys' + + endif + +!--- Surface diagnostics in gfs_sfc + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'alnsf' + Diag(idx)%desc = 'mean nir albedo with strong cosz dependency' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%alnsf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'alnwf' + Diag(idx)%desc = 'mean nir albedo with weak cosz dependency' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%alnwf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'alvsf' + Diag(idx)%desc = 'mean vis albedo with strong cosz dependency' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%alvsf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'alvwf' + Diag(idx)%desc = 'mean vis albedo with weak cosz dependency' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%alvwf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'canopy' + Diag(idx)%desc = 'canopy water (cnwat in gfs data)' + Diag(idx)%unit = '%' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%canopy(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'f10m' + Diag(idx)%desc = '10-meter wind speed divided by lowest model wind speed' + Diag(idx)%unit = 'N/A' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%f10m(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'facsf' + Diag(idx)%desc = 'fractional coverage with strong cosz dependency' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%facsf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'facwf' + Diag(idx)%desc = 'fractional coverage with weak cosz dependency' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%facwf(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ffhh' + Diag(idx)%desc = 'fh parameter from PBL scheme' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%ffhh(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ffmm' + Diag(idx)%desc = 'fm parameter from PBL scheme' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%ffmm(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'uustar' + Diag(idx)%desc = 'uustar surface frictional wind' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%uustar(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'slope' + Diag(idx)%desc = 'surface slope type' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%slope(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'fice' + Diag(idx)%desc = 'surface ice concentration (ice=1; no ice=0) [fraction]' + Diag(idx)%unit = 'fraction' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%fice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'hice' + Diag(idx)%desc = 'sea ice thickness (icetk in gfs_data)' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%hice(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'snoalb' + Diag(idx)%desc = 'maximum snow albedo in fraction (salbd?? in gfs data)' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%snoalb(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'shdmax' + Diag(idx)%desc = 'maximum fractional coverage of green vegetation' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%shdmax(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'shdmin' + Diag(idx)%desc = 'minimum fractional coverage of green vegetation' + Diag(idx)%unit = 'XXX' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%shdmin(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'snowd' + Diag(idx)%desc = 'surface snow depth [m]' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'gfs_sfc' + Diag(idx)%cnvfac = cn_one/cn_th + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%snowd(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'crain' + Diag(idx)%desc = 'instantaneous categorical rain' + Diag(idx)%unit = 'number' + Diag(idx)%mod_name = 'gfs_sfc' + Diag(idx)%cnvfac = cn_one + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%srflag(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'stype' + Diag(idx)%desc = 'soil type in integer 1-9' + Diag(idx)%unit = 'N/A' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%stype(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'q2m' + Diag(idx)%desc = '2m specific humidity [kg/kg]' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%q2m(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 't2m' + Diag(idx)%desc = '2m temperature [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%t2m(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tsfc' + Diag(idx)%desc = 'surface temperature [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%tsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'qsfc' + Diag(idx)%desc = 'surface specific humidity [kg/kg]' + Diag(idx)%unit = 'kg/kg' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%qsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tg3' + Diag(idx)%desc = 'deep soil temperature' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%tg3(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tisfc' + Diag(idx)%desc = 'surface temperature over ice fraction' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%tisfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tprcp' + Diag(idx)%desc = 'total precipitation' + Diag(idx)%unit = 'kg/m**2' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%tprcp(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'vtype' + Diag(idx)%desc = 'vegetation type in integer 1-13' + Diag(idx)%unit = 'number' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%vtype(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'weasd' + Diag(idx)%desc = 'surface snow water equivalent [kg/m**2]' + Diag(idx)%unit = 'kg/m**2' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%weasd(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'HGTsfc' + Diag(idx)%desc = 'surface geopotential height [gpm]' + Diag(idx)%unit = 'gpm' + Diag(idx)%mod_name = 'gfs_sfc' + Diag(idx)%cnvfac = con_g + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%oro(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SLMSKsfc' + Diag(idx)%desc = 'sea-land-ice mask (0-sea, 1-land, 2-ice)' + Diag(idx)%unit = 'N/A' + Diag(idx)%mod_name = 'gfs_sfc' + Diag(idx)%coarse_graining_method = MODE + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%slmsk(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ZORLsfc' + Diag(idx)%desc = 'surface roughness [m]' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'gfs_sfc' + Diag(idx)%cnvfac = cn_one/cn_100 + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%zorl(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'VFRACsfc' + Diag(idx)%desc = 'vegetation fraction' + Diag(idx)%unit = 'N/A' + Diag(idx)%mod_name = 'gfs_sfc' + Diag(idx)%cnvfac = cn_100 + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%vfrac(:) + enddo + + do num = 1,4 + write (xtra,'(I1)') num + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'slc_'//trim(xtra) + Diag(idx)%desc = 'liquid soil mositure at layer-'//trim(xtra) + Diag(idx)%unit = 'xxx' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%slc(:,num) + enddo + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILW1' + Diag(idx)%desc = 'volumetric soil moisture 0-10cm [fraction]' + Diag(idx)%unit = 'fraction' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%smc(:,1) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILW2' + Diag(idx)%desc = 'volumetric soil moisture 10-40cm [fraction]' + Diag(idx)%unit = 'fraction' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%smc(:,2) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILW3' + Diag(idx)%desc = 'volumetric soil moisture 40-100cm [fraction]' + Diag(idx)%unit = 'fraction' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%smc(:,3) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILW4' + Diag(idx)%desc = 'volumetric soil moisture 100-200cm [fraction]' + Diag(idx)%unit = 'fraction' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%smc(:,4) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILT1' + Diag(idx)%desc = 'soil temperature 0-10cm [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%stc(:,1) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILT2' + Diag(idx)%desc = 'soil temperature 10-40cm [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%stc(:,2) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILT3' + Diag(idx)%desc = 'soil temperature 40-100cm [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%stc(:,3) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'SOILT4' + Diag(idx)%desc = 'soil temperature 100-200cm [K]' + Diag(idx)%unit = 'K' + Diag(idx)%mod_name = 'gfs_sfc' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Sfcprop(nb)%stc(:,4) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'netflxsfc' + Diag(idx)%desc = 'net surface heat flux [W/m**2]' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%netflxsfc(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'qflux_restore' + Diag(idx)%desc = 'restoring flux' + Diag(idx)%unit = 'W/m**2' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%coarse_graining_method = AREA_WEIGHTED + Diag(idx)%time_avg = .TRUE. + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%qflux_restore(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'tclim_iano' + Diag(idx)%desc = 'climatological SST plus initial anomaly' + Diag(idx)%unit = 'degree C' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%tclim_iano(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'MLD' + Diag(idx)%desc = 'ocean mixed layer depth' + Diag(idx)%unit = 'm' + Diag(idx)%mod_name = 'gfs_phys' + Diag(idx)%cnvfac = cn_one + Diag(idx)%time_avg = .TRUE. + Diag(idx)%coarse_graining_method = AREA_WEIGHTED + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%mld(:) + enddo + + idx = idx + 1 + Diag(idx)%axes = 2 + Diag(idx)%name = 'ps_dt' + Diag(idx)%desc = 'surface pressure tendency' + Diag(idx)%unit = 'Pa/3hr' + Diag(idx)%mod_name = 'gfs_phys' + allocate (Diag(idx)%data(nblks)) + do nb = 1,nblks + Diag(idx)%data(nb)%var2 => Gfs_diag(nb)%ps_dt(:) + enddo + + tot_diag_idx = idx + + if (idx > DIAG_SIZE) then + call mpp_error(FATAL, 'gfs_driver::gfs_diag_register - need to increase DIAG_SIZE') + endif + + do idx = 1,tot_diag_idx + if (diag(idx)%axes == -99) then + call mpp_error(FATAL, 'gfs_driver::gfs_diag_register - attempt to register an undefined variable') + endif + Diag(idx)%id = register_diag_field (trim(Diag(idx)%mod_name), trim(Diag(idx)%name), & + axes(1:Diag(idx)%axes), Time, trim(Diag(idx)%desc), & + trim(Diag(idx)%unit), missing_value=real(missing_value)) + enddo + + end subroutine gfdl_diag_register + + subroutine populate_coarse_diag_type(diagnostic, coarse_diagnostic) + type(gfdl_diag_type), intent(in) :: diagnostic + type(gfdl_diag_type), intent(inout) :: coarse_diagnostic + + ! We leave the data attribute empty for these, because we will coarsen it + ! directly from the data attribute in the full resolution version of each + ! diagnostic. + coarse_diagnostic%axes = diagnostic%axes + coarse_diagnostic%time_avg = diagnostic%time_avg + coarse_diagnostic%mod_name = diagnostic%mod_name + coarse_diagnostic%name = trim(diagnostic%name) // '_coarse' + coarse_diagnostic%desc = diagnostic%desc + coarse_diagnostic%unit = diagnostic%unit + coarse_diagnostic%cnvfac = diagnostic%cnvfac + coarse_diagnostic%coarse_graining_method = diagnostic%coarse_graining_method + end subroutine populate_coarse_diag_type + + subroutine fv3gfs_diag_register_coarse(Time, coarse_axes) + type(time_type), intent(in) :: Time + integer, intent(in) :: coarse_axes(4) + + integer :: index + + do index = 1, DIAG_SIZE + if (Diag(index)%name .eq. '') exit ! No need to populate non-existent coarse diagnostics + call populate_coarse_diag_type(Diag(index), Diag_coarse(index)) + Diag_coarse(index)%id = register_diag_field( & + trim(Diag_coarse(index)%mod_name), trim(Diag_coarse(index)%name), & + coarse_axes(1:Diag_coarse(index)%axes), Time, trim(Diag_coarse(index)%desc), & + trim(Diag_coarse(index)%unit), missing_value=real(missing_value)) + enddo + end subroutine fv3gfs_diag_register_coarse + + subroutine register_coarse_diag_manager_controlled_diagnostics(Time, coarse_axes) + type(time_type), intent(in) :: Time + integer, intent(in) :: coarse_axes(4) + + integer :: index + + do index = 1, DIAG_SIZE + if (Diag(index)%name .eq. '') exit ! No need to populate non-existent coarse diagnostics + call populate_coarse_diag_type(Diag_diag_manager_controlled(index), Diag_diag_manager_controlled_coarse(index)) + Diag_diag_manager_controlled_coarse(index)%id = register_diag_field( & + trim(Diag_diag_manager_controlled_coarse(index)%mod_name), trim(Diag_diag_manager_controlled_coarse(index)%name), & + coarse_axes(1:Diag_diag_manager_controlled_coarse(index)%axes), Time, trim(Diag_diag_manager_controlled_coarse(index)%desc), & + trim(Diag_diag_manager_controlled_coarse(index)%unit), missing_value=real(missing_value)) + enddo + end subroutine register_coarse_diag_manager_controlled_diagnostics + + subroutine send_diag_manager_controlled_diagnostic_data(Time, Atm_block, IPD_Data, nx, ny, levs, & + write_coarse_diagnostics, delp, coarsening_strategy, ptop) + type(time_type), intent(in) :: Time + type(block_control_type), intent(in) :: Atm_block + type(IPD_data_type), intent(in) :: IPD_Data(:) + integer, intent(in) :: nx, ny, levs + logical, intent(in) :: write_coarse_diagnostics + real(kind=kind_phys), intent(in) :: delp(isco:ieco,jsco:jeco,1:levo) + character(len=64), intent(in) :: coarsening_strategy + real(kind=kind_phys), intent(in) :: ptop + + logical :: require_area, require_masked_area, require_mass, require_masked_mass, require_vertical_remapping + real(kind=kind_phys), allocatable :: area(:,:) + real(kind=kind_phys), allocatable :: mass(:,:,:), phalf(:,:,:), phalf_coarse_on_fine(:,:,:) + real(kind=kind_phys), allocatable :: masked_area(:,:,:) + + real(kind=kind_phys) :: var2d(nx, ny) + real(kind=kind_phys) :: var3d(nx, ny, levs) + integer :: i, j, ii, jj, k, isc, jsc, ix, nb, index, used + + isc = atm_block%isc + jsc = atm_block%jsc + + if (write_coarse_diagnostics) then + call determine_required_coarse_graining_weights(Diag_diag_manager_controlled_coarse, coarsening_strategy, & + & require_area, require_masked_area, require_mass, require_vertical_remapping) + if (.not. require_vertical_remapping) then + if (require_area) then + allocate(area(nx, ny)) + call get_area(Atm_block, IPD_Data, nx, ny, area) + endif + if (require_mass) then + allocate(mass(nx, ny, levs)) + call get_mass(Atm_block, IPD_Data, delp, nx, ny, levs, mass) + endif + else + allocate(area(nx, ny)) + allocate(phalf(nx, ny, levs + 1)) + allocate(phalf_coarse_on_fine(nx, ny, levs + 1)) + allocate(masked_area(nx, ny, levs)) + call get_area(Atm_block, IPD_Data, nx, ny, area) + call vertical_remapping_requirements(delp, area, ptop, phalf, phalf_coarse_on_fine) + call mask_area_weights(area, phalf, phalf_coarse_on_fine, masked_area) + endif + endif + + do index = 1, DIAG_SIZE + if (trim(Diag_diag_manager_controlled(index)%name) .eq. '') exit + if (Diag_diag_manager_controlled(index)%id .gt. 0 .or. Diag_diag_manager_controlled_coarse(index)%id .gt. 0) then + if (Diag_diag_manager_controlled(index)%axes .eq. 2) then + do j = 1, ny + jj = j + jsc - 1 + do i = 1, nx + ii = i + isc - 1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + var2d(i,j) = Diag_diag_manager_controlled(index)%data(nb)%var2(ix) + enddo + enddo + if (Diag_diag_manager_controlled(index)%id > 0) then + used = send_data(Diag_diag_manager_controlled(index)%id, var2d, Time) + endif + if (Diag_diag_manager_controlled_coarse(index)%id > 0) then + call store_data2D_coarse(Diag_diag_manager_controlled_coarse(index)%id, Diag_diag_manager_controlled_coarse(index)%name, & + & Diag_diag_manager_controlled_coarse(index)%coarse_graining_method, nx, ny, var2d, area, Time) + endif + elseif (Diag_diag_manager_controlled(index)%axes .eq. 3) then + do k=1, levs + do j = 1, ny + jj = j + jsc - 1 + do i = 1, nx + ii = i + isc - 1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + var3d(i,j,k) = Diag_diag_manager_controlled(index)%data(nb)%var3(ix,levs - k + 1) + enddo + enddo + enddo + if (Diag_diag_manager_controlled(index)%id .gt. 0) then + used = send_data(Diag_diag_manager_controlled(index)%id, var3d, Time) + endif + if (Diag_diag_manager_controlled_coarse(index)%id > 0) then + if (trim(coarsening_strategy) .eq. MODEL_LEVEL) then + call store_data3D_coarse_model_level(Diag_diag_manager_controlled_coarse(index)%id, & + & Diag_diag_manager_controlled_coarse(index)%name, & + & Diag_diag_manager_controlled_coarse(index)%coarse_graining_method, & + & nx, ny, levs, var3d, area, mass, Time) + elseif (trim(coarsening_strategy) .eq. PRESSURE_LEVEL) then + call store_data3D_coarse_pressure_level(Diag_diag_manager_controlled_coarse(index)%id, & + & Diag_diag_manager_controlled_coarse(index)%name, & + & Diag_diag_manager_controlled_coarse(index)%coarse_graining_method, & + & nx, ny, levs, var3d, phalf, phalf_coarse_on_fine, masked_area, Time, ptop) + else + call mpp_error(FATAL, 'Invalid coarse-graining strategy provided.') + endif + endif + endif + endif + enddo + end subroutine send_diag_manager_controlled_diagnostic_data + +!------------------------------------------------------------------------- + + +!------------------------------------------------------------------------- +!--- gfs_diag_output --- +!------------------------------------------------------------------------- +! routine to transfer the diagnostic data to the GFDL FMS diagnostic +! manager for eventual output to the history files. +! +! calls: send_data +!------------------------------------------------------------------------- + subroutine gfdl_diag_output(Time, Atm_block, IPD_Data, nx, ny, fprint, & + levs, ntcw, ntoz, dt, time_int, time_intfull, & + fhswr, fhlwr, & + prt_stats, write_coarse_diagnostics, delp, & + coarsening_strategy, ptop) +!--- subroutine interface variable definitions + logical :: fprint + type(time_type), intent(in) :: Time + type (block_control_type), intent(in) :: Atm_block + type(IPD_data_type), intent(in) :: IPD_Data(:) + integer, intent(in) :: nx, ny, levs, ntcw, ntoz + real(kind=kind_phys), intent(in) :: dt + real(kind=kind_phys), intent(in) :: time_int + real(kind=kind_phys), intent(in) :: time_intfull + real(kind=kind_phys), intent(in) :: fhswr, fhlwr + logical, intent(in) :: prt_stats + logical, intent(in) :: write_coarse_diagnostics + real(kind=kind_phys), intent(in) :: delp(isco:ieco,jsco:jeco,1:levo) + character(len=64), intent(in) :: coarsening_strategy + real(kind=kind_phys), intent(in) :: ptop +!--- local variables + integer :: i, j, k, idx, nblks, nb, ix, ii, jj, kflip + integer :: is_in, js_in, isc, jsc + character(len=2) :: xtra + real(kind=kind_phys), dimension(nx*ny) :: var2p + real(kind=kind_phys), dimension(nx*ny,levs) :: var3p + real(kind=kind_phys), dimension(nx,ny) :: var2, area, lat, lon, one, landmask, seamask + real(kind=kind_phys), dimension(nx,ny,levs) :: var3 + real(kind=kind_phys) :: rdt, rtime_int, rtime_intfull, lcnvfac + real(kind=kind_phys) :: rtime_radsw, rtime_radlw + logical :: used + + ! Local variables required for coarse-grianing + logical :: require_area, require_masked_area, require_mass, require_masked_mass, require_vertical_remapping + real(kind=kind_phys), allocatable :: mass(:,:,:), phalf(:,:,:), phalf_coarse_on_fine(:,:,:) + real(kind=kind_phys), allocatable :: masked_area(:,:,:) + + nblks = Atm_block%nblks + rdt = 1.0d0/dt + rtime_int = 1.0d0/time_int + rtime_intfull = 1.0d0/time_intfull + rtime_radsw = 1.0d0/fhswr + rtime_radlw = 1.0d0/fhlwr + + isc = Atm_block%isc + jsc = Atm_block%jsc + is_in = Atm_block%isc + js_in = Atm_block%jsc + + !Metrics + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + area(i,j) = IPD_Data(nb)%Grid%area(ix) + lat(i,j) = IPD_Data(nb)%Grid%xlat(ix) + lon(i,j) = IPD_Data(nb)%Grid%xlon(ix) + one(i,j) = 1. + landmask(i,j) = IPD_Data(nb)%Sfcprop%slmsk(ix) + seamask(i,j) = 1. - landmask(i,j) + enddo + enddo + + if (write_coarse_diagnostics) then + call determine_required_coarse_graining_weights(diag_coarse, coarsening_strategy, require_area, & + & require_masked_area, require_mass, require_vertical_remapping) + if (.not. require_vertical_remapping) then + if (require_mass) then + allocate(mass(nx, ny, levs)) + call get_mass(Atm_block, IPD_Data, delp, nx, ny, levs, mass) + endif + else + allocate(phalf(nx, ny, levs + 1)) + allocate(phalf_coarse_on_fine(nx, ny, levs + 1)) + allocate(masked_area(nx, ny, levs)) + call vertical_remapping_requirements(delp, area, ptop, phalf, phalf_coarse_on_fine) + call mask_area_weights(area, phalf, phalf_coarse_on_fine, masked_area) + endif + endif + + do idx = 1,tot_diag_idx + if ((Diag(idx)%id > 0) .or. (diag_coarse(idx)%id > 0)) then + lcnvfac = Diag(idx)%cnvfac + if (Diag(idx)%time_avg) then + if ( trim(Diag(idx)%time_avg_kind) == 'full' ) then + lcnvfac = lcnvfac*rtime_intfull + else if ( trim(Diag(idx)%time_avg_kind) == 'rad_lw' ) then + lcnvfac = lcnvfac*min(rtime_radlw,rtime_int) + else if ( trim(Diag(idx)%time_avg_kind) == 'rad_sw' ) then + lcnvfac = lcnvfac*min(rtime_radsw,rtime_int) + else if ( trim(Diag(idx)%time_avg_kind) == 'rad_swlw_min' ) then + lcnvfac = lcnvfac*min(max(rtime_radsw,rtime_radlw),rtime_int) + else + lcnvfac = lcnvfac*rtime_int + endif + endif + if (Diag(idx)%axes == 2) then + if (trim(diag(idx)%mask) == 'positive_flux') then + !--- albedos are actually a ratio of two radiation surface properties + var2(1:nx,1:ny) = 0._kind_phys + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + if (Diag(idx)%data(nb)%var21(ix) > 0._kind_phys) & + var2(i,j) = max(0._kind_phys,min(1._kind_phys,Diag(idx)%data(nb)%var2(ix)/Diag(idx)%data(nb)%var21(ix)))*lcnvfac + enddo + enddo + elseif (trim(Diag(idx)%mask) == 'land_ice_only') then + !--- need to "mask" gflux to output valid data over land/ice only + var2(1:nx,1:ny) = missing_value + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + if (Diag(idx)%data(nb)%var21(ix) /= 0) var2(i,j) = Diag(idx)%data(nb)%var2(ix)*lcnvfac + enddo + enddo + elseif (trim(Diag(idx)%mask) == 'land_only') then + !--- need to "mask" soilm to have value only over land + var2(1:nx,1:ny) = missing_value + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + if (Diag(idx)%data(nb)%var21(ix) == 1) var2(i,j) = Diag(idx)%data(nb)%var2(ix)*lcnvfac + enddo + enddo + elseif (trim(Diag(idx)%mask) == 'cldmask') then + !--- need to "mask" soilm to have value only over land + var2(1:nx,1:ny) = missing_value + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + if (Diag(idx)%data(nb)%var21(ix)*100. > 0.5) var2(i,j) = Diag(idx)%data(nb)%var2(ix)*lcnvfac + enddo + enddo + elseif (trim(Diag(idx)%mask) == 'cldmask_ratio') then + !--- need to "mask" soilm to have value only over land + var2(1:nx,1:ny) = missing_value + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + if (Diag(idx)%data(nb)%var21(ix)*100.*lcnvfac > 0.5) var2(i,j) = Diag(idx)%data(nb)%var2(ix)/ & + Diag(idx)%data(nb)%var21(ix) + enddo + enddo + elseif (trim(Diag(idx)%mask) == '') then + do j = 1, ny + jj = j + jsc -1 + do i = 1, nx + ii = i + isc -1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + var2(i,j) = Diag(idx)%data(nb)%var2(ix)*lcnvfac + enddo + enddo + endif + if (Diag(idx)%id > 0) then + used=send_data(Diag(idx)%id, var2, Time) + endif + if (Diag_coarse(idx)%id > 0) then + call store_data2D_coarse(Diag_coarse(idx)%id, Diag_coarse(idx)%name, & + Diag_coarse(idx)%coarse_graining_method, nx, ny, var2, area, Time) + endif + + !!!! Accumulated diagnostics --- lmh 19 sep 17 + if (fprint .or. prt_stats) then + select case (trim(Diag(idx)%name)) + case('totprcp_ave') + call prt_gb_nh_sh_us('Total Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 86400.) + call prt_gb_nh_sh_us('Land Precip (mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 86400.) + case('totsnw') + call prt_gb_nh_sh_us('Total Snowfall (9:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 777600.) + call prt_gb_nh_sh_us('Land Snowfall (9:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 777600.) +! case('totgrp') ! Tiny?? +! call prt_gb_nh_sh_us('Total Icefall (2:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, one, 172800.) +! call prt_gb_nh_sh_us('Land Icefall (2:1 mm/d)', 1, nx, 1, ny, var2, area, lon, lat, landmask, 172800.) + case('lhtfl_ave') + call prt_gb_nh_sh_us('Total sfc LH flux ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + case('shtfl_ave') + call prt_gb_nh_sh_us('Total sfc SH flux ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + case('DSWRFtoa') + call prt_gb_nh_sh_us('TOA SW down ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + case('USWRFtoa') + call prt_gb_nh_sh_us('TOA SW up ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + case('ULWRFtoa') + call prt_gb_nh_sh_us('TOA LW up ', 1, nx, 1, ny, var2, area, lon, lat, one, 1.) + case('t2m') + call prt_gb_nh_sh_us('2-m T max ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MAX') + call prt_gb_nh_sh_us('2-m T min ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MIN') + case('tsfc') + call prt_gb_nh_sh_us('sfc T max ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MAX') + call prt_gb_nh_sh_us('sfc T min ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MIN') + call prt_gb_nh_sh_us('SST max ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1., 'MAX') + call prt_gb_nh_sh_us('SST min ', 1, nx, 1, ny, var2, area, lon, lat, seamask, 1., 'MIN') + case('ps_dt') + call prt_gb_nh_sh_us('ps_dt max ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MAX') + call prt_gb_nh_sh_us('ps_dt min ', 1, nx, 1, ny, var2, area, lon, lat, one, 1., 'MIN') + end select + endif + elseif (Diag(idx)%axes == 3) then + !--- dt3dt variables ---- restored 16 feb 18 lmh + do k=1,levs + kflip=levs+1-k + do j=1,ny + jj = j + jsc -1 + do i=1,nx + ii = i + isc - 1 + nb = Atm_block%blkno(ii,jj) + ix = Atm_block%ixp(ii,jj) + var3(i,j,k) = Diag(idx)%data(nb)%var3(ix,kflip)*lcnvfac + enddo + enddo + enddo + if (Diag(idx)%id > 0) then + used=send_data(Diag(idx)%id, var3, Time) + endif + if (Diag_coarse(idx)%id > 0) then + if (trim(coarsening_strategy) .eq. MODEL_LEVEL) then + call store_data3D_coarse_model_level(Diag_coarse(idx)%id, Diag_coarse(idx)%name, & + Diag_coarse(idx)%coarse_graining_method, & + nx, ny, levo, var3, area, mass, Time) + elseif (trim(coarsening_strategy) .eq. PRESSURE_LEVEL) then + call store_data3D_coarse_pressure_level(Diag_coarse(idx)%id, Diag_coarse(idx)%name, & + Diag_coarse(idx)%coarse_graining_method, & + nx, ny, levo, var3, phalf, phalf_coarse_on_fine, masked_area, Time, ptop) + else + call mpp_error(FATAL, 'Invalid coarse-graining strategy provided.') + endif + endif + +#ifdef JUNK + !--- dq3dt variables + do num = 1,5+Mdl_parms%pl_coeff + write(xtra,'(i1)') num + if (trim(Diag(idx)%name) == 'dq3dt_'//trim(xtra)) then + var3(1:nx,1:ny,1:levs) = RESHAPE(Gfs_diag%dq3dt(1:ngptc,levs:1:-1,num:num), (/nx,ny,levs/)) + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + enddo + !--- du3dt and dv3dt variables + do num = 1,4 + write(xtra,'(i1)') num + if (trim(Diag(idx)%name) == 'du3dt_'//trim(xtra)) then + var3(1:nx,1:ny,1:levs) = RESHAPE(Gfs_diag%du3dt(1:ngptc,levs:1:-1,num:num), (/nx,ny,levs/)) + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + if (trim(Diag(idx)%name) == 'dv3dt_'//trim(xtra)) then + var3(1:nx,1:ny,1:levs) = RESHAPE(Gfs_diag%dv3dt(1:ngptc,levs:1:-1,num:num), (/nx,ny,levs/)) + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + enddo + if (trim(Diag(idx)%name) == 'dqdt_v') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Gfs_diag%dqdt_v(1:ngptc,levs:1:-1), (/nx,ny,levs/)) + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + !--- temperature tendency + if (trim(Diag(idx)%name) == 'dtemp_dt') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Statein%tgrs(1:ngptc,levs:1:-1), (/nx,ny,levs/)) + var3(1:nx,1:ny,1:levs) = (RESHAPE(Stateout%gt0(1:ngptc,levs:1:-1), (/nx,ny,levs/)) & + - var3(1:nx,1:ny,1:levs))*rdt + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + !--- horizontal wind component tendency + if (trim(Diag(idx)%name) == 'du_dt') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Statein%ugrs(1:ngptc,levs:1:-1), (/nx,ny,levs/)) + var3(1:nx,1:ny,1:levs) = (RESHAPE(Stateout%gu0(1:ngptc,levs:1:-1), (/nx,ny,levs/)) & + - var3(1:nx,1:ny,1:levs))*rdt + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + !--- meridional wind component tendency + if (trim(Diag(idx)%name) == 'dv_dt') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Statein%vgrs(1:ngptc,levs:1:-1), (/nx,ny,levs/)) + var3(1:nx,1:ny,1:levs) = (RESHAPE(Stateout%gv0(1:ngptc,levs:1:-1), (/nx,ny,levs/)) & + - var3(1:nx,1:ny,1:levs))*rdt + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + !--- specific humidity tendency + if (trim(Diag(idx)%name) == 'dsphum_dt') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Statein%qgrs(1:ngptc,levs:1:-1,1:1), (/nx,ny,levs/)) + var3(1:nx,1:ny,1:levs) = (RESHAPE(Stateout%gq0(1:ngptc,levs:1:-1,1:1), (/nx,ny,levs/)) & + - var3(1:nx,1:ny,1:levs))*rdt + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + !--- cloud water mixing ration tendency + if (trim(Diag(idx)%name) == 'dclwmr_dt') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Statein%qgrs(1:ngptc,levs:1:-1,ntcw:ntcw), (/nx,ny,levs/)) + var3(1:nx,1:ny,1:levs) = (RESHAPE(Stateout%gq0(1:ngptc,levs:1:-1,ntcw:ntcw), (/nx,ny,levs/)) & + - var3(1:nx,1:ny,1:levs))*rdt + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif + !--- ozone mixing ration tendency + if (trim(Diag(idx)%name) == 'do3mr_dt') then + var3(1:nx,1:ny,1:levs) = RESHAPE(Statein%qgrs(1:ngptc,levs:1:-1,ntoz:ntoz), (/nx,ny,levs/)) + var3(1:nx,1:ny,1:levs) = (RESHAPE(Stateout%gq0(1:ngptc,levs:1:-1,ntoz:ntoz), (/nx,ny,levs/)) & + - var3(1:nx,1:ny,1:levs))*rdt + used=send_data(Diag(idx)%id, var3, Time, is_in=is_in, js_in=js_in, ks_in=1) + endif +#endif + endif + endif + enddo + + + end subroutine gfdl_diag_output +!------------------------------------------------------------------------- + subroutine prt_gb_nh_sh_us(qname, is,ie, js,je, a2, area, lon, lat, mask, fac, operation_in) !Prints averages/sums, or maxes/mins + use physcons, pi=>con_pi + character(len=*), intent(in):: qname + integer, intent(in):: is, ie, js, je + real(kind=kind_phys), intent(in), dimension(is:ie, js:je):: a2 + real(kind=kind_phys), intent(in), dimension(is:ie, js:je):: area, lon, lat, mask + real, intent(in) :: fac + character(len=*), intent(in), OPTIONAL :: operation_in +! Local: + real(kind=kind_phys), parameter:: rad2deg = 180./pi + real(kind=kind_phys) :: slat, slon + real(kind=kind_phys):: t_eq, t_nh, t_sh, t_gb, t_us + real(kind=kind_phys):: area_eq, area_nh, area_sh, area_gb, area_us + integer:: i,j + character(len=100) :: diagstr + character(len=20) :: diagstr1 + character(len=3) :: operation + + if (present(operation_in)) then + operation = operation_in(1:3) + else + operation = 'SUM' + endif + + if (operation == "MAX") then + t_eq =-1.e14 ; t_nh =-1.e14; t_sh =-1.e14; t_gb =-1.e14; t_us =-1.e14 + area_eq = 0. ; area_nh = 0. ; area_sh = 0. ; area_gb = 0. ; area_us = 0. + do j=js,je + do i=is,ie + if (mask(i,j) <= 1.e-6) cycle + + slat = lat(i,j)*rad2deg + slon = lon(i,j)*rad2deg + area_gb = 1. + t_gb = max(t_gb,a2(i,j)) + if( (slat>-20. .and. slat<20.) ) then + area_eq = 1. + t_eq = max(t_eq,a2(i,j)) + elseif( slat>=20. .and. slat<80. ) then + area_nh = 1. + t_nh = max(t_nh,a2(i,j)) + elseif( slat<=-20. .and. slat>-80. ) then + area_sh = 1. + t_sh = max(t_sh,a2(i,j)) + endif + if ( slat>25. .and. slat<50. .and. & + slon>235. .and. slon<300. ) then + area_us = 1. + t_us = max(t_us,a2(i,j)) + endif + enddo + enddo + + call mp_reduce_max( t_gb) + call mp_reduce_max( t_nh) + call mp_reduce_max( t_sh) + call mp_reduce_max( t_eq) + call mp_reduce_max( t_us) + elseif (operation == "MIN") then + t_eq = 1.e14 ; t_nh = 1.e14; t_sh = 1.e14; t_gb = 1.e14; t_us = 1.e14 + area_eq = 0. ; area_nh = 0. ; area_sh = 0. ; area_gb = 0. ; area_us = 0. + do j=js,je + do i=is,ie + if (mask(i,j) <= 1.e-6) cycle + + slat = lat(i,j)*rad2deg + slon = lon(i,j)*rad2deg + area_gb = 1. + t_gb = min(t_gb,a2(i,j)) + if( (slat>-20. .and. slat<20.) ) then + area_eq = 1. + t_eq = min(t_eq,a2(i,j)) + elseif( slat>=20. .and. slat<80. ) then + area_nh = 1. + t_nh = min(t_nh,a2(i,j)) + elseif( slat<=-20. .and. slat>-80. ) then + area_sh = 1. + t_sh = min(t_sh,a2(i,j)) + endif + if ( slat>25. .and. slat<50. .and. & + slon>235. .and. slon<300. ) then + area_us = 1. + t_us = min(t_us,a2(i,j)) + endif + enddo + enddo + + call mp_reduce_min( t_gb) + call mp_reduce_min( t_nh) + call mp_reduce_min( t_sh) + call mp_reduce_min( t_eq) + call mp_reduce_min( t_us) + else + t_eq = 0. ; t_nh = 0.; t_sh = 0.; t_gb = 0.; t_us = 0. + area_eq = 0.; area_nh = 0.; area_sh = 0.; area_gb = 0.; area_us = 0. + operation = 'SUM' + do j=js,je + do i=is,ie + slat = lat(i,j)*rad2deg + slon = lon(i,j)*rad2deg + area_gb = area_gb + area(i,j)*mask(i,j) + t_gb = t_gb + a2(i,j)*area(i,j)*mask(i,j) + if( (slat>-20. .and. slat<20.) ) then + area_eq = area_eq + area(i,j)*mask(i,j) + t_eq = t_eq + a2(i,j)*area(i,j)*mask(i,j) + elseif( slat>=20. .and. slat<80. ) then + area_nh = area_nh + area(i,j)*mask(i,j) + t_nh = t_nh + a2(i,j)*area(i,j)*mask(i,j) + elseif( slat<=-20. .and. slat>-80. ) then + area_sh = area_sh + area(i,j)*mask(i,j) + t_sh = t_sh + a2(i,j)*area(i,j)*mask(i,j) + endif + if ( slat>25. .and. slat<50. .and. & + slon>235. .and. slon<300. ) then + area_us = area_us + area(i,j)*mask(i,j) + t_us = t_us + a2(i,j)*area(i,j)*mask(i,j) + endif + enddo + enddo + + call mp_reduce_sum(area_gb) + call mp_reduce_sum( t_gb) + call mp_reduce_sum(area_nh) + call mp_reduce_sum( t_nh) + call mp_reduce_sum(area_sh) + call mp_reduce_sum( t_sh) + call mp_reduce_sum(area_eq) + call mp_reduce_sum( t_eq) + call mp_reduce_sum(area_us) + call mp_reduce_sum( t_us) + endif + + diagstr = trim(qname) // ' ' // trim(mpp_get_current_pelist_name()) // ' ' + !if (area_gb < 1.) then + ! diagstr1 = '' + !elseif( area_gb <= 4.*pi*RADIUS*RADIUS*.98) then + ! write(diagstr1,101) 'Grid', t_gb/area_gb*fac + !else + if (area_gb <= 1.e-6) return + write(diagstr1,101) 'GB', t_gb/area_gb*fac + !endif + diagstr = trim(diagstr) // trim(diagstr1) + if (area_nh <= 1.e-6 ) then + diagstr1 = '' + else + write(diagstr1,101) 'NH', t_nh/area_nh*fac + endif + diagstr = trim(diagstr) // trim(diagstr1) + if (area_sh <= 1.e-6 ) then + diagstr1 = '' + else + write(diagstr1,101) 'SH', t_sh/area_sh*fac + endif + diagstr = trim(diagstr) // trim(diagstr1) + if (area_eq <= 1.e-6) then + diagstr1 = '' + else + write(diagstr1,101) 'EQ', t_eq/area_eq*fac + endif + diagstr = trim(diagstr) // trim(diagstr1) + if (area_us <= 1.e-6) then + diagstr1 = '' + else + write(diagstr1,101) 'US', t_us/area_us*fac + endif + diagstr = trim(diagstr) // trim(diagstr1) + + if (is_master()) write(*,'(A)') trim(diagstr) + +101 format(3x, A, ': ', F7.2) + + end subroutine prt_gb_nh_sh_us + + subroutine determine_required_coarse_graining_weights(coarse_diag, coarsening_strategy, require_area, & + & require_masked_area, require_mass, require_vertical_remapping) + type(gfdl_diag_type), intent(in) :: coarse_diag(:) + character(len=64), intent(in) :: coarsening_strategy + logical, intent(out) :: require_area, require_masked_area, require_mass, require_vertical_remapping + + require_area = any(coarse_diag%id .gt. 0 .and. coarse_diag%coarse_graining_method .eq. AREA_WEIGHTED) + require_mass = any(coarse_diag%id .gt. 0 .and. coarse_diag%coarse_graining_method .eq. MASS_WEIGHTED) + + if (trim(coarsening_strategy) .eq. PRESSURE_LEVEL) then + require_masked_area = any(coarse_diag%id .gt. 0 .and. coarse_diag%axes .eq. 3 .and. & + & coarse_diag%coarse_graining_method .eq. AREA_WEIGHTED) + require_vertical_remapping = any(coarse_diag%id .gt. 0 .and. coarse_diag%axes .eq. 3) + else + require_masked_area = .false. + require_vertical_remapping = .false. + endif + end subroutine determine_required_coarse_graining_weights + + subroutine get_area(Atm_block, IPD_Data, nx, ny, area) + type(block_control_type), intent(in) :: Atm_block + type(IPD_data_type), intent(in) :: IPD_Data(:) + integer, intent(in) :: nx, ny + real(kind=kind_phys), intent(out) :: area(1:nx,1:ny) + + integer :: i, ii, j, jj, block_number, column + do j = 1, ny + jj = j + jsco - 1 + do i = 1, nx + ii = i + isco - 1 + block_number = Atm_block%blkno(ii,jj) + column = Atm_block%ixp(ii,jj) + area(i,j) = IPD_Data(block_number)%Grid%area(column) + enddo + enddo + end subroutine get_area + + subroutine get_mass(Atm_block, IPD_Data, delp, nx, ny, nz, mass) + type(block_control_type), intent(in) :: Atm_block + type(IPD_data_type), intent(in) :: IPD_Data(:) + integer, intent(in) :: nx, ny, nz + real(kind=kind_phys), intent(in) :: delp(1:nx,1:ny,1:nz) + real(kind=kind_phys), intent(out) :: mass(1:nx,1:ny,1:nz) + + integer :: i, ii, j, jj, k, block_number, column, isc, jsc + real(kind=kind_phys) :: area_value + + do k = 1, nz + do j = 1, ny + jj = j + jsco - 1 + do i = 1, nx + ii = i + isco - 1 + block_number = Atm_block%blkno(ii,jj) + column = Atm_block%ixp(ii,jj) + area_value = IPD_Data(block_number)%Grid%area(column) + mass(i,j,k) = area_value * delp(i,j,k) + enddo + enddo + enddo + end subroutine get_mass + + subroutine store_data2D_coarse(id, name, method, nx, ny, full_resolution_field, area, Time) + integer, intent(in) :: id + character(len=64), intent(in) :: name + character(len=64), intent(in) :: method + integer, intent(in) :: nx, ny + real(kind=kind_phys), intent(in) :: full_resolution_field(1:nx,1:ny) + real(kind=kind_phys), intent(in) :: area(1:nx,1:ny) + type(time_type), intent(in) :: Time + + real(kind=kind_phys), allocatable :: coarse(:,:) + character(len=128) :: message + integer :: is_coarse, ie_coarse, js_coarse, je_coarse, nx_coarse, ny_coarse + logical :: used + + call get_coarse_array_bounds(is_coarse, ie_coarse, js_coarse, je_coarse) + nx_coarse = ie_coarse - is_coarse + 1 + ny_coarse = je_coarse - js_coarse + 1 + + allocate(coarse(nx_coarse, ny_coarse)) + + if (method .eq. AREA_WEIGHTED) then + call weighted_block_average(area, full_resolution_field, coarse) + elseif (method .eq. MASKED_AREA_WEIGHTED) then + call weighted_block_average(area, full_resolution_field, full_resolution_field .ne. missing_value, coarse) + elseif (method .eq. MODE) then + call block_mode(full_resolution_field, coarse) + elseif (method .eq. MASS_WEIGHTED) then + message = 'mass_weighted is not a valid coarse_graining_method for 2D variable ' // trim(name) + call mpp_error(FATAL, message) + else + message = 'A valid coarse_graining_method must be specified for ' // trim(name) + call mpp_error(FATAL, message) + endif + used = send_data(id, coarse, Time) + end subroutine store_data2D_coarse + + subroutine store_data3D_coarse_model_level(id, name, method, nx, ny, nz, full_resolution_field, & + area, mass, Time) + integer, intent(in) :: id + character(len=64), intent(in) :: name + character(len=64), intent(in) :: method + integer, intent(in) :: nx, ny, nz + real(kind=kind_phys), intent(in) :: full_resolution_field(1:nx,1:ny,1:nz) + real(kind=kind_phys), intent(in) :: area(1:nx,1:ny) + real(kind=kind_phys), intent(in) :: mass(1:nx,1:ny,1:nz) + type(time_type), intent(in) :: Time + + real(kind=kind_phys), allocatable :: coarse(:,:,:) + character(len=128) :: message + integer :: is_coarse, ie_coarse, js_coarse, je_coarse, nx_coarse, ny_coarse + logical :: used + + call get_coarse_array_bounds(is_coarse, ie_coarse, js_coarse, je_coarse) + nx_coarse = ie_coarse - is_coarse + 1 + ny_coarse = je_coarse - js_coarse + 1 + + allocate(coarse(nx_coarse, ny_coarse, nz)) + + if (method .eq. AREA_WEIGHTED) then + call weighted_block_average(area, full_resolution_field, coarse) + elseif (method .eq. MASKED_AREA_WEIGHTED) then + message = 'Masked area-weighted coarse-graining is not currently implemented for 3D variables' + call mpp_error(FATAL, message) + elseif (method .eq. MASS_WEIGHTED) then + call weighted_block_average(mass, full_resolution_field, coarse) + elseif (method .eq. MODE) then + message = 'Block mode coarse-graining is not currently implemented for 3D variables' + call mpp_error(FATAL, message) + else + message = 'A valid coarse_graining_method must be specified for ' // trim(name) + call mpp_error(FATAL, message) + endif + used = send_data(id, coarse, Time) + end subroutine store_data3D_coarse_model_level + + subroutine store_data3D_coarse_pressure_level(id, name, method, nx, ny, nz, full_resolution_field, & + & phalf, phalf_coarse_on_fine, masked_area, Time, ptop) + integer, intent(in) :: id + character(len=64), intent(in) :: name + character(len=64), intent(in) :: method + integer, intent(in) :: nx, ny, nz + real(kind=kind_phys), intent(in) :: full_resolution_field(1:nx,1:ny,1:nz) + real(kind=kind_phys), intent(in) :: phalf(1:nx,1:ny,1:nz + 1) + real(kind=kind_phys), intent(in) :: phalf_coarse_on_fine(1:nx,1:ny,1:nz + 1) + real(kind=kind_phys), intent(in) :: masked_area(1:nx,1:ny,1:nz) + type(time_type), intent(in) :: Time + real(kind=kind_phys), intent(in) :: ptop + + real(kind=kind_phys), allocatable :: remapped(:,:,:), coarse(:,:,:) + character(len=128) :: message + integer :: is_coarse, ie_coarse, js_coarse, je_coarse, nx_coarse, ny_coarse + logical :: used + + call get_coarse_array_bounds(is_coarse, ie_coarse, js_coarse, je_coarse) + nx_coarse = ie_coarse - is_coarse + 1 + ny_coarse = je_coarse - js_coarse + 1 + + allocate(remapped(nx, ny, nz)) + allocate(coarse(nx_coarse, ny_coarse, nz)) + + call vertically_remap_field(phalf, full_resolution_field, phalf_coarse_on_fine, ptop, remapped) + + ! AREA_WEIGHTED and MASS_WEIGHTED are equivalent in pressure level coarse-graining + if (method .eq. AREA_WEIGHTED .or. method .eq. MASS_WEIGHTED) then + call weighted_block_average(masked_area, remapped, coarse) + elseif (method .eq. MASKED_AREA_WEIGHTED) then + message = 'Masked area-weighted coarse-graining is not currently implemented for 3D variables' + call mpp_error(FATAL, message) + elseif (method .eq. MODE) then + message = 'Block mode coarse-graining is not currently implemented for 3D variables' + call mpp_error(FATAL, message) + else + message = 'A valid coarse_graining_method must be specified for ' // trim(name) + call mpp_error(FATAL, message) + endif + used = send_data(id, coarse, Time) +end subroutine store_data3D_coarse_pressure_level + +end module FV3GFS_io_mod + + + diff --git a/GFS_layer/GFS_abstraction_layer.F90 b/GFS_layer/GFS_abstraction_layer.F90 new file mode 100644 index 00000000..b8e6d890 --- /dev/null +++ b/GFS_layer/GFS_abstraction_layer.F90 @@ -0,0 +1,47 @@ +module physics_abstraction_layer + + use GFS_typedefs, only: init_type => GFS_init_type, & + control_type => GFS_control_type, & + statein_type => GFS_statein_type, & + stateout_type => GFS_stateout_type, & + sfcprop_type => GFS_sfcprop_type, & + coupling_type => GFS_coupling_type, & + grid_type => GFS_grid_type, & + tbd_type => GFS_tbd_type, & + cldprop_type => GFS_cldprop_type, & + radtend_type => GFS_radtend_type, & + intdiag_type => GFS_diag_type + + use GFS_driver, only: initialize => GFS_initialize, & + time_vary_step => GFS_time_vary_step, & + radiation_step1 => GFS_radiation_driver, & + physics_step1 => GFS_physics_driver, & + physics_step2 => GFS_stochastic_driver + +!---------------------- +! public physics types +!---------------------- + public init_type + public control_type + public statein_type + public stateout_type + public sfcprop_type + public coupling_type + public grid_type + public tbd_type + public cldprop_type + public radtend_type + public intdiag_type + +!-------------------------- +! public physics functions +!-------------------------- + public initialize + public time_vary_step + public radiation_step1 + public physics_step1 + public physics_step2 + +CONTAINS + +end module physics_abstraction_layer diff --git a/GFS_layer/GFS_diagnostics.F90 b/GFS_layer/GFS_diagnostics.F90 new file mode 100644 index 00000000..2ce2abcd --- /dev/null +++ b/GFS_layer/GFS_diagnostics.F90 @@ -0,0 +1,3462 @@ +module physics_diag_layer + +!------------------------------------------------------------------------------------------! +! ! +! This module populates the IPD_Diag container withe the elements from GFS physics that ! +! are to be output via the write component in the NEMS system. The IPD_Diag container ! +! contains properties from the GFS_diag_type, GFS_sfcprop_type and +! ! +!------------------------------------------------------------------------------------------! + + use machine, only: kind_phys + use IPD_typedefs, only: IPD_diag_type + use physics_abstraction_layer, only: control_type, statein_type, & + stateout_type, sfcprop_type, & + coupling_type, grid_type, & + tbd_type, cldprop_type, & + radtend_type, intdiag_type, & + init_type + + public diag_populate + + CONTAINS +!******************************************************************************************* + +!---------------------- +! GFS_populate_IPD_Diag +!---------------------- + subroutine diag_populate (IPD_Diag, Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag, Init_parm) +!------------------------------------------------------------------------------------------! +! IPD_METADATA ! +! IPD_Diag%name [char*32 ] variable name in source [char*32] ! +! IPD_Diag%output_name [char*32 ] output name for variable [char*32] ! +! IPD_Diag%mod_name [char*32 ] module name (e.g. physics, radiation, etc) ! +! IPD_Diag%file_name [char*32 ] output file name for variable ! +! IPD_Diag%desc [char*128] long description of field ! +! IPD_Diag%unit [char*32 ] units associated with fields ! +! IPD_Diag%type_stat_proc [char*32 ] type of statistic processing: ! +! average, accumulation, maximal, minimal, etc. ! +! IPD_Diag%level_type [char*32 ] vertical level of the field ! +! IPD_Diag%level [int*4 ] vertical level(s) ! +! IPD_Diag%cnvfac [real*8 ] conversion factors to output in specified units ! +! IPD_Diag%zhour [real*8 ] forecast hour when bucket was last emptied ! +! IPD_Diag%fcst_hour [real*8 ] current forecast hour (same as fhour) ! +! IPD_Diag%data(nb)%var2p(:) [real*8 ] pointer to 2D data [=> null() for a 3D field] ! +! IPD_Diag%data(nb)%var3p(:,:) [real*8 ] pointer to 3D data [=> null() for a 2D field] ! +!------------------------------------------------------------------------------------------! + + implicit none +! +! --- interface variables + type(IPD_diag_type), intent(inout) :: IPD_Diag(:) + type(control_type), intent(in) :: Model + type(statein_type), intent(in) :: Statein(:) + type(stateout_type), intent(in) :: Stateout(:) + type(sfcprop_type), intent(in) :: Sfcprop(:) + type(coupling_type), intent(in) :: Coupling(:) + type(grid_type), intent(in) :: Grid(:) + type(tbd_type), intent(in) :: Tbd(:) + type(cldprop_type), intent(in) :: Cldprop(:) + type(radtend_type), intent(in) :: Radtend(:) + type(intdiag_type), intent(in) :: Diag(:) + type(init_type), intent(in) :: Init_parm + + !--- local variabls + integer :: idx, nblks, nb, num + real(kind=kind_phys), parameter :: cn_one = 1._kind_phys + real(kind=kind_phys), parameter :: cn_100 = 100._kind_phys + real(kind=kind_phys), parameter :: cn_th = 1000._kind_phys + real(kind=kind_phys), parameter :: cn_hr = 3600._kind_phys + + real(kind=kind_phys), pointer :: var1(:) => null() + + nblks = size(Init_parm%blksz) + + !--- initialize GFS_diag + IPD_Diag(:)%name = ' ' + IPD_Diag(:)%output_name = ' ' + IPD_Diag(:)%mod_name = ' ' + IPD_Diag(:)%file_name = ' ' + IPD_Diag(:)%desc = ' ' + IPD_Diag(:)%unit = ' ' + IPD_Diag(:)%type_stat_proc = ' ' + IPD_Diag(:)%level_type = ' ' + IPD_Diag(:)%level = 1 + IPD_Diag(:)%cnvfac = cn_one + IPD_Diag(:)%zhour = Model%zhour + IPD_Diag(:)%fcst_hour = Model%fhour + do idx = 1,size(IPD_Diag,1) + allocate (IPD_Diag(idx)%data(nblks)) + enddo + + idx = 0 + + ! IPD DIAG CONTAINER DATA + !--- FLUXR + !--- This data array contains 33 fields including radiation flux, + !--- cloud cover, pressure and many other fields, suggest to + !--- split into 2D fields: + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr' + IPD_Diag(idx)%output_name = ' ' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'flux from radiation' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = ' ' + IPD_Diag(idx)%level = Model%nfxr + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%fluxr + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr1' + IPD_Diag(idx)%output_name = 'ulwrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Upward long wave radiation flux at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,1) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr2' + IPD_Diag(idx)%output_name = 'uswrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Upward solar radiation flux at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,2) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr3' + IPD_Diag(idx)%output_name = 'uswrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Upward solar radiation flux at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,3) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr4' + IPD_Diag(idx)%output_name = 'dswrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward solar radiation flux at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,4) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr5' + IPD_Diag(idx)%output_name = 'tcdc' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Total cloud cover at high cloud layer' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'high_cloud_lyr' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,5) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr6' + IPD_Diag(idx)%output_name = 'tcdc' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Total cloud cover at middle cloud layer' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'mid_cloud_lyr' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,6) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr7' + IPD_Diag(idx)%output_name = 'tcdc' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Total cloud cover at low cloud layer' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'low_cloud_lyr' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,7) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr8' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Pressure at high cloud top level' + IPD_Diag(idx)%unit = 'pa' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimsw' + IPD_Diag(idx)%level_type = 'high_cloud_top_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,8) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr9' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Pressure at middle cloud top level' + IPD_Diag(idx)%unit = 'pa' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'mid_cloud_top_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,9) + enddo + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr10' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Pressure at low cloud top level' + IPD_Diag(idx)%unit = 'pa' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'low_cloud_top_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,10) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr11' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Pressure at high cloud bottom level' + IPD_Diag(idx)%unit = 'pa' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'high_cloud_bot_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,11) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr12' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Pressure at middle cloud bottom level' + IPD_Diag(idx)%unit = 'pa' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'mid_cloud_bot_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,12) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr13' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Pressure at low cloud bot level' + IPD_Diag(idx)%unit = 'pa' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'low_cloud_bot_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,13) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr14' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Temperature at high cloud top level' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'high_cloud_top_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,14) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr15' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Temperature at middle cloud top level' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'mid_cloud_top_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,15) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr16' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Temperature at low cloud top level' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'acc_cloud' + IPD_Diag(idx)%level_type = 'low_cloud_top_lvl' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,16) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr17' + IPD_Diag(idx)%output_name = 'tcdc' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Total cloud cover at total atmospheric column' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'entire_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,17) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr18' + IPD_Diag(idx)%output_name = 'tcdc' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Total cloud cover (precent) at boundary layer cloud layer' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'bound_lyr_cloud_lyr' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,18) + enddo + + !--- fluxr19 and fluxr20 are replaced with the surface temperature + ! adjusted quantities for output + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr21' + IPD_Diag(idx)%output_name = 'duvb' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'UV-B downward solar flux (w/m**2) at land sea surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,21) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr22' + IPD_Diag(idx)%output_name = 'cduvb' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky UV-B downward solar flux (w/m**2) at land sea surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,22) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr23' + IPD_Diag(idx)%output_name = 'dswrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward solar radiation flux (w/m**2) at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,23) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr24' + IPD_Diag(idx)%output_name = 'vbdsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward sw uv+vis beam radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surfaces' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,24) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr25' + IPD_Diag(idx)%output_name = 'vddsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward sw uv+vis diffuse radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surfaces' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,25) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr26' + IPD_Diag(idx)%output_name = 'nbdsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward sw nir beam radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surfaces' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,26) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr27' + IPD_Diag(idx)%output_name = 'nddsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward sw nir diffuse radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_timsw' + IPD_Diag(idx)%level_type = 'surfaces' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,27) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr28' + IPD_Diag(idx)%output_name = 'csulf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky upward long wave radiation flux (w/m**2) at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,28) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr29' + IPD_Diag(idx)%output_name = 'csusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky upward solar radiation flux (w/m**2) at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimer' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,29) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr30' + IPD_Diag(idx)%output_name = 'csdlf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky downward long wave radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimer' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,30) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr31' + IPD_Diag(idx)%output_name = 'csusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky upward solar radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimer' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,31) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr32' + IPD_Diag(idx)%output_name = 'csdsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky downward solar radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimer' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,32) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'fluxr33' + IPD_Diag(idx)%output_name = 'csulf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Clear sky upward long wave radiation flux (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimer' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%fluxr(:,33) + enddo + !--- done with FLUXR + + !--- dlwsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'dlwsfc' + IPD_Diag(idx)%output_name = 'dlwrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'downward longwave flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dlwsfc + enddo +!---need to convert to "ave" for output?? + + !---ulwsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'ulwsfc' + IPD_Diag(idx)%output_name = 'ulwrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'upward long wave flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%ulwsfc + enddo +!--- need to convert to "ave" for output?? + + ! COUPLING FIELDS + !---nirbmdi + idx = idx + 1 + IPD_Diag(idx)%name = 'nirbmdi' + IPD_Diag(idx)%output_name = 'nbdsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward short wave nir beam radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'Inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%nirbmdi + enddo + + !---nirdfdi + idx = idx + 1 + IPD_Diag(idx)%name = 'nirdfdi' + IPD_Diag(idx)%output_name = 'nddsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Downward short wave nir diffuse radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'Inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%nirdfdi + enddo +!--- need to convert to "ave" for output + + !---visbmdi + idx = idx + 1 + IPD_Diag(idx)%name = 'visbmdi' + IPD_Diag(idx)%output_name = 'vbdsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'Downward short wave uv+vis beam radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%visbmdi + enddo + + !---visdfdi + idx = idx + 1 + IPD_Diag(idx)%name = 'visdfdi' + IPD_Diag(idx)%output_name = 'vddsf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'cpl ' + IPD_Diag(idx)%desc = 'Downward short wave uv+vis diffuse radiation flux [W/m**2] at surface ' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%visdfdi + enddo + + !---nirbmui + idx = idx + 1 + IPD_Diag(idx)%name = 'nirbmui' + IPD_Diag(idx)%output_name = 'nbusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'Upward short wave nir beam radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%nirbmui + enddo + + !---nirdfui + idx = idx + 1 + IPD_Diag(idx)%name = 'nirdfui' + IPD_Diag(idx)%output_name = 'ndusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'Upward short wave nir beam radiation flux [W/m**2] at surface ' + IPD_Diag(idx)%unit = ' ' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = ' ' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%nirdfui + enddo + + !---visbmui + idx = idx + 1 + IPD_Diag(idx)%name = 'visbmui' + IPD_Diag(idx)%output_name = 'vbusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'Upward short wave uv+vis beam radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = ' ' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = ' ' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%visbmui + enddo + + !---visdfui + idx = idx + 1 + IPD_Diag(idx)%name = 'visdfui' + IPD_Diag(idx)%output_name = 'vdusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'Upward short wave uv+vis diffuse radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2 ' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Coupling(nb)%visdfui + enddo + ! END COUPLING FIELDS + + !---topfsw%upfxc + idx = idx + 1 + IPD_Diag(idx)%name = 'sw_upfxc' + IPD_Diag(idx)%output_name = 'uswrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'upward solar radiation flux [w/m**2] at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%topfsw(:)%upfxc + enddo + + !---topfsw%dnfxc + idx = idx + 1 + IPD_Diag(idx)%name = 'sw_dnfxc' + IPD_Diag(idx)%output_name = 'dswrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'downward solar radiation flux [w/m**2] at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%topfsw(:)%dnfxc + enddo + + !---topfsw%upfx0 + idx = idx + 1 + IPD_Diag(idx)%name = 'sw_upfx0' + IPD_Diag(idx)%output_name = 'csusf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'Clear sky upward solar radiation flux [w/m**2] at top of atmosphere' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%topfsw(:)%upfx0 + enddo + + !---topflw%upfxc + idx = idx + 1 + IPD_Diag(idx)%name = 'lw_upfxc' + IPD_Diag(idx)%output_name = 'ulwrf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'upward long wave radiation flux [w/m**2] at top of atmosphere ' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%topflw(:)%upfxc + enddo + +!--- clear sky down long wave is missing? + + !---topflw%upfx0 + idx = idx + 1 + IPD_Diag(idx)%name = 'lw_upfx0' + IPD_Diag(idx)%output_name = 'csulf' + IPD_Diag(idx)%mod_name = 'radiation' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'Clear sky upward long wave radiation flux [w/m**2] at top of atmosphere ' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'top_of_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%topflw(:)%upfx0 + enddo + + !---srunoff + idx = idx + 1 + IPD_Diag(idx)%name = 'srunoff' + IPD_Diag(idx)%output_name = 'ssrun' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'storm water runoff [kg/m**2] at surface' + IPD_Diag(idx)%unit = 'kg/m**2 ' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = 1.e3 + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%srunoff + enddo + + !---evbsa + idx = idx + 1 + IPD_Diag(idx)%name = 'evbsa' + IPD_Diag(idx)%output_name = 'EVBSA' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Direct Evaporation [w/m**2] from Bare Soil' + IPD_Diag(idx)%unit = 'w/m**2 ' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%evbsa + enddo + + !---evcwa + idx = idx + 1 + IPD_Diag(idx)%name = 'evcwa' + IPD_Diag(idx)%output_name = 'evcw' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Canopy water evaporation' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'surface ' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%evcwa + enddo + + !---snohfa + idx = idx + 1 + IPD_Diag(idx)%name = 'snohfa' + IPD_Diag(idx)%output_name = 'snohf' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Snow Phase Change Heat Flux [w/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%snohfa + enddo + + !---snowca + idx = idx + 1 + IPD_Diag(idx)%name = 'snowca' + IPD_Diag(idx)%output_name = 'snowc' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Snow cover (fraction) at surface' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%snowca + enddo + + !---sbsnoa + idx = idx + 1 + IPD_Diag(idx)%name = 'sbsnoa' + IPD_Diag(idx)%output_name = 'sbsno' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Snow sublimation [w/m^2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%sbsnoa + enddo + + !---transa + idx = idx + 1 + IPD_Diag(idx)%name = 'transa' + IPD_Diag(idx)%output_name = 'trans' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Transpiration [w/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%transa + enddo + + !---soilm + idx = idx + 1 + IPD_Diag(idx)%name = 'soilm' + IPD_Diag(idx)%output_name = 'soilm' + IPD_Diag(idx)%mod_name = 'land' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'total column soil moisture content [kg/m**2] at surface' + IPD_Diag(idx)%unit = 'kg/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'soil layer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_th + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%soilm + enddo + + !---tmpmin + idx = idx + 1 + IPD_Diag(idx)%name = 'tmpmin' + IPD_Diag(idx)%output_name = 'tmin' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'minimum temperature at 2 m above ground' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'min' + IPD_Diag(idx)%level_type = '2 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%tmpmin + enddo + + !---tmpmax + idx = idx + 1 + IPD_Diag(idx)%name = 'tmpmax' + IPD_Diag(idx)%output_name = 'tmax' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'maximum temperature at 2 m above ground' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'max' + IPD_Diag(idx)%level_type = '2 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%tmpmax + enddo + + !---dusfc + idx = idx + 1 + IPD_Diag(idx)%name = 'dusfc' + IPD_Diag(idx)%output_name = 'uflx' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Zonal momentum flux [Ns/m**2] at surface' + IPD_Diag(idx)%unit = 'Ns/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dusfc + enddo + + !---dvsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'dvsfc' + IPD_Diag(idx)%output_name = 'vflx' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'meridional momentum flux [Ns/m**2] at surface' + IPD_Diag(idx)%unit = 'Ns/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dvsfc + enddo + + !---dtsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'dtsfc' + IPD_Diag(idx)%output_name = 'shtfl' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'surface sensible heat flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dtsfc + enddo + + !---dqsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'dqsfc' + IPD_Diag(idx)%output_name = 'lhtfl ' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'surface latent heat flux [W/m**2]' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dqsfc + enddo + + !---totprcp + idx = idx + 1 + IPD_Diag(idx)%name = 'totprcp' + IPD_Diag(idx)%output_name = 'prate' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'precipitation rate [kg/m**2/s] at surface' + IPD_Diag(idx)%unit = 'kg/m**2/s' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%totprcp + enddo + + !---gflux + idx = idx + 1 + IPD_Diag(idx)%name = 'gflux' + IPD_Diag(idx)%output_name = 'gflux' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'ground heat flux [W/m**2/s] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%gflux + enddo + + !---dlwsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'dlwsfc' + IPD_Diag(idx)%output_name = 'dlwrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Time accumulated downward long wave radiation flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dlwsfc + enddo + + !---ulwsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'ulwsfc' + IPD_Diag(idx)%output_name = 'ulwrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'time accumulated upward lw flux at surface [W/m**2]' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'accumulation' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%ulwsfc + enddo + + !---suntim + idx = idx + 1 + IPD_Diag(idx)%name = 'suntim' + IPD_Diag(idx)%output_name = 'sunsd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Accumulated sunshine duration time [s]' + IPD_Diag(idx)%unit = 's' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%suntim + enddo + + !---runoff + idx = idx + 1 + IPD_Diag(idx)%name = 'runoff' + IPD_Diag(idx)%output_name = 'RUNOFF' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'total water runoff [kg/m**2] at surface' + IPD_Diag(idx)%unit = 'kg/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_th + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%runoff + enddo + + !---ep + idx = idx + 1 + IPD_Diag(idx)%name = 'ep' + IPD_Diag(idx)%output_name = 'pevpr' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Potential evaporation rate [w/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%ep + enddo + + !---cldwrk + idx = idx + 1 + IPD_Diag(idx)%name = 'cldwrk' + IPD_Diag(idx)%output_name = 'cwork' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'cloud work function (valid only with SAS) [J/kg] at total atmospheric column' + IPD_Diag(idx)%unit = 'J/kg' + IPD_Diag(idx)%type_stat_proc = 'acc ' + IPD_Diag(idx)%level_type = 'rntire_atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%cldwrk + enddo + + !---dugwd + idx = idx + 1 + IPD_Diag(idx)%name = 'dugwd' + IPD_Diag(idx)%output_name = 'u-gwd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Zonal gravity wave stress [N/m**2] at surface' + IPD_Diag(idx)%unit = 'N/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dugwd + enddo + + !---dvgwd + idx = idx + 1 + IPD_Diag(idx)%name = 'dvgwd' + IPD_Diag(idx)%output_name = 'v-gwd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Meridional gravity wave stress [N/m**2] at surface' + IPD_Diag(idx)%unit = 'N/m**2' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dvgwd + enddo + + !---psmean + idx = idx + 1 + IPD_Diag(idx)%name = 'psmean' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'time accumulation surface pressure [kPa*s]' + IPD_Diag(idx)%unit = 'kPa*s' + IPD_Diag(idx)%type_stat_proc = 'acc' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%psmean + enddo + + !---cnvprcp + idx = idx + 1 + IPD_Diag(idx)%name = 'cnvprcp' + IPD_Diag(idx)%output_name = 'cprat' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'convective precipitation rate [kg/m**2/s] at surface' + IPD_Diag(idx)%unit = 'kg/m**2/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%cnvprcp + enddo + + !---spfhmin + idx = idx + 1 + IPD_Diag(idx)%name = 'spfhmin' + IPD_Diag(idx)%output_name = 'spfhmin' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'minimum specific humidity [kg/kg] at 2 m above ground' + IPD_Diag(idx)%unit = 'kg/kg ' + IPD_Diag(idx)%type_stat_proc = 'min' + IPD_Diag(idx)%level_type = '2 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%spfhmin + enddo + + !---spfhmax + idx = idx + 1 + IPD_Diag(idx)%name = 'spfhmaxn' + IPD_Diag(idx)%output_name = 'spfhmax' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'maximum specific humidity [kg/kg] at 2 m above ground' + IPD_Diag(idx)%unit = 'kg/kg' + IPD_Diag(idx)%type_stat_proc = 'max' + IPD_Diag(idx)%level_type = '2 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%spfhmax + enddo + + !---u10mmax + idx = idx + 1 + IPD_Diag(idx)%name = 'u10mmaxn' + IPD_Diag(idx)%output_name = 'u10mmax' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'maximum u-wind speed (m/s) at 10 m above ground' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'max' + IPD_Diag(idx)%level_type = '10 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%u10mmax + enddo + + !---v10mmax + idx = idx + 1 + IPD_Diag(idx)%name = 'v10mmaxn' + IPD_Diag(idx)%output_name = 'v10mmax' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'maximum v-wind speed (m/s) at 10 m above ground' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'max' + IPD_Diag(idx)%level_type = '10 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%v10mmax + enddo + + !---wind10mmax + idx = idx + 1 + IPD_Diag(idx)%name = 'wind10mmaxn' + IPD_Diag(idx)%output_name = 'wind10mmax' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'maximum wind speed (m/s) at 10 m above ground' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'max' + IPD_Diag(idx)%level_type = '10 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%wind10mmax + enddo + + !---rain + idx = idx + 1 + IPD_Diag(idx)%name = 'rain' + IPD_Diag(idx)%output_name = 'APCP' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'instantaneous total precipitation [m] at surface' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%rain + enddo + + !---rainc + idx = idx + 1 + IPD_Diag(idx)%name = 'rainc' + IPD_Diag(idx)%output_name = 'ACPCP' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'instantaneous convective precipitation [m] at surface' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%rainc + enddo + + !---ice + idx = idx + 1 + IPD_Diag(idx)%name = 'ice' + IPD_Diag(idx)%output_name = 'ICE' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'instantaneous ice fall' + IPD_Diag(idx)%unit = ' ' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%ice + enddo + + !---snow + idx = idx + 1 + IPD_Diag(idx)%name = 'snow' + IPD_Diag(idx)%output_name = 'SNOW' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'instantaneous snow fall' + IPD_Diag(idx)%unit = ' ' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%snow + enddo + + !---graupel + idx = idx + 1 + IPD_Diag(idx)%name = 'graupel' + IPD_Diag(idx)%output_name = 'GRAUPEL' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'instantaneous graupel fall' + IPD_Diag(idx)%unit = ' ' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%graupel + enddo + + !---totice + idx = idx + 1 + IPD_Diag(idx)%name = 'totice' + IPD_Diag(idx)%output_name = 'TOTICE' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'surface ice precipitation rate [kg/m**2/s]' + IPD_Diag(idx)%unit = 'kg/m**2/s' + IPD_Diag(idx)%type_stat_proc = 'accumulation' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%totice + enddo + + !---totsnw + idx = idx + 1 + IPD_Diag(idx)%name = 'totsnw' + IPD_Diag(idx)%output_name = 'TOTSNW' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'surface snow precipitation rate [kg/m**2/s]' + IPD_Diag(idx)%unit = 'kg/m**2/s' + IPD_Diag(idx)%type_stat_proc = 'accumulation' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%totsnw + enddo + + !---totgrp + idx = idx + 1 + IPD_Diag(idx)%name = 'totgrp' + IPD_Diag(idx)%output_name = 'TOTGRP' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'surface graupel precipitation rate [kg/m**2/s]' + IPD_Diag(idx)%unit = 'kg/m**2/s' + IPD_Diag(idx)%type_stat_proc = 'accumulation' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one/cn_hr + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%totgrp + enddo + + !---u10m + idx = idx + 1 + IPD_Diag(idx)%name = 'u10m' + IPD_Diag(idx)%output_name = 'ugrd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'u wind component [m/s] at 10 m abover ground' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '10 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%u10m + enddo + + !---v10m + idx = idx + 1 + IPD_Diag(idx)%name = 'v10m' + IPD_Diag(idx)%output_name = 'vgrd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'v wind component [m/s] at 10 m above ground' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '10 m above ground' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%v10m + enddo + + !---dpt2m + idx = idx + 1 + IPD_Diag(idx)%name = 'dpt2m' + IPD_Diag(idx)%output_name = 'dpt' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'Dew point temperature [K] at 2 m above ground' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '2 m above ground' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dpt2m + enddo + + !---zlvl + idx = idx + 1 + IPD_Diag(idx)%name = 'zlvl' + IPD_Diag(idx)%output_name = 'hgt' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'height [m] at model layer 1' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%zlvl + enddo + + !---psurf + idx = idx + 1 + IPD_Diag(idx)%name = 'psurf' + IPD_Diag(idx)%output_name = 'pres' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'surface pressure [Pa]' + IPD_Diag(idx)%unit = 'Pa' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%psurf + enddo + + !---hpbl + idx = idx + 1 + IPD_Diag(idx)%name = 'hpbl' + IPD_Diag(idx)%output_name = 'HPBL' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'surface planetary boundary layer height [m]' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%hpbl + enddo + + !---pwat + idx = idx + 1 + IPD_Diag(idx)%name = 'pwat' + IPD_Diag(idx)%output_name = 'pwat' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'atmos column precipitable water [kg/m**2]' + IPD_Diag(idx)%unit = 'kg/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'entire atmos' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%pwat + enddo + + !---t1 + idx = idx + 1 + IPD_Diag(idx)%name = 't1' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Temperature [K] at model layer 1' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model lyaer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%t1 + enddo + + !---q1 + idx = idx + 1 + IPD_Diag(idx)%name = 'q1' + IPD_Diag(idx)%output_name = 'spfh' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'specific humidity [kg/kg] sy model layer 1' + IPD_Diag(idx)%unit = 'kg/kg' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%q1 + enddo + + !---u1 + idx = idx + 1 + IPD_Diag(idx)%name = 'u1' + IPD_Diag(idx)%output_name = 'ugrd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'layer 1 zonal wind [m/s] at model ayer 1' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%u1 + enddo + + !---v1 + idx = idx + 1 + IPD_Diag(idx)%name = 'v1' + IPD_Diag(idx)%output_name = 'vgrd' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'meridional wind [m/s] at model ayer 1' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%v1 + enddo + + !---chh + idx = idx + 1 + IPD_Diag(idx)%name = 'chh' + IPD_Diag(idx)%output_name = 'CHH' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'thermal exchange coefficient' + IPD_Diag(idx)%unit = 'kg/m**2/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%chh + enddo + + !---cmm + idx = idx + 1 + IPD_Diag(idx)%name = 'cmm' + IPD_Diag(idx)%output_name = 'CMM' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'momentum exchange coefficient' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%cmm + enddo + + !---dlwsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'dlwsfci' + IPD_Diag(idx)%output_name = 'dlwrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'instantaneous downward lw flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dlwsfci + enddo + + !---ulwsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'ulwsfci' + IPD_Diag(idx)%output_name = 'ulwrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'instantaneous upward lw flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%ulwsfci + enddo + + !---dswsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'dswsfci' + IPD_Diag(idx)%output_name = 'dswrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'instantaneous downward sw flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dswsfci + enddo + + !---uswsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'uswsfci' + IPD_Diag(idx)%output_name = 'uswrf' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'instantaneous upward sw flux [W/m**2] at surface' + IPD_Diag(idx)%unit = 'W/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%uswsfci + enddo + + !---dusfci + idx = idx + 1 + IPD_Diag(idx)%name = 'dusfci' + IPD_Diag(idx)%output_name = 'uflx' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'instantaneous Zonal compt of momentum flux at surface' + IPD_Diag(idx)%unit = 'n/m**2 ' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dusfci + enddo + + !---dvsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'dvsfci' + IPD_Diag(idx)%output_name = 'vflx' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'instantaneous v component of surface stress' + IPD_Diag(idx)%unit = 'n/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dvsfci + enddo + + !---dtsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'dtsfci' + IPD_Diag(idx)%output_name = 'shtfl' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'instantaneous surface sensible heat flux [w/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dtsfci + enddo + + !---dqsfci + idx = idx + 1 + IPD_Diag(idx)%name = 'dqsfci' + IPD_Diag(idx)%output_name = 'lhtfl' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'instantaneous latent heat flux [w/m**2] at surface' + IPD_Diag(idx)%unit = 'w/m**2 ' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%dqsfci + enddo + + !---gfluxi + idx = idx + 1 + IPD_Diag(idx)%name = 'gfluxi' + IPD_Diag(idx)%output_name = 'gflux' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'instantaneous ground heat flux [w/m**2]at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%gfluxi + enddo + + !---epi + idx = idx + 1 + IPD_Diag(idx)%name = 'epi' + IPD_Diag(idx)%output_name = 'pevpr' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'cpl' + IPD_Diag(idx)%desc = 'instantaneous potential evaporation rate (w/m**2) at surface' + IPD_Diag(idx)%unit = 'w/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc ' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%epi + enddo + + !---smcwlt2 + idx = idx + 1 + IPD_Diag(idx)%name = 'smcwlt2' + IPD_Diag(idx)%output_name = 'wilt' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'wilting point (proportion) at surface' + IPD_Diag(idx)%unit = 'proportion ' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%smcwlt2 + enddo + + !---smcref2' + idx = idx + 1 + IPD_Diag(idx)%name = 'smcref2' + IPD_Diag(idx)%output_name = 'SMCREF2' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Field capacity (fraction) at surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%smcref2 + enddo + + !---wet1 + idx = idx + 1 + IPD_Diag(idx)%name = 'wet1' + IPD_Diag(idx)%output_name = 'WET1' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'gocart_cpl ' + IPD_Diag(idx)%desc = 'normalized top soil layer wetness [frqaction]' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'soil layer' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%wet1 + enddo + + !---sr + idx = idx + 1 + IPD_Diag(idx)%name = 'sr' + IPD_Diag(idx)%output_name = 'cpofp' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Frozen precipitation fraction' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%sr + enddo + + if (Model%ldiag3d) then + !---dt3dt + idx = idx + 1 + IPD_Diag(idx)%name = 'dt3dt1' + IPD_Diag(idx)%output_name = 'LWHR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Long wave radiative heating rate [K/s] at model layers ' + IPD_Diag(idx)%unit = 'K/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dt3dt(:,:,1) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dt3dt2' + IPD_Diag(idx)%output_name = 'SWHR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Short wave radiative heating rate [K/s] at model layers ' + IPD_Diag(idx)%unit = 'K/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dt3dt(:,:,2) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dt3dt3' + IPD_Diag(idx)%output_name = 'VDFHR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Vertical diffusion heating rate [K/s] at model layers ' + IPD_Diag(idx)%unit = 'K/s' + IPD_Diag(idx)%type_stat_proc = 'amm_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dt3dt(:,:,3) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dt3dt4' + IPD_Diag(idx)%output_name = 'CNVHR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Deep convective heating rate [K/s] at model layers ' + IPD_Diag(idx)%unit = 'K/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dt3dt(:,:,4) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dt3dt5' + IPD_Diag(idx)%output_name = 'SHAHR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Shallow convective heating rate [K/s] at model layers ' + IPD_Diag(idx)%unit = 'K/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dt3dt(:,:,5) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dt3dt6' + IPD_Diag(idx)%output_name = 'LRGHR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Large scale condensate heat rate [K/s] at model layers ' + IPD_Diag(idx)%unit = 'K/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dt3dt(:,:,6) + enddo + + !---dq3dt + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt1' + IPD_Diag(idx)%output_name = 'VDFMR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Vertical diffusion moistening rate [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,1) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt2' + IPD_Diag(idx)%output_name = 'CNVMR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Deep convective moistening rate [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,2) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt3' + IPD_Diag(idx)%output_name = 'SHAMR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Shallow convective moistening rate [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,3) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt4' + IPD_Diag(idx)%output_name = 'LRGMR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Large scale moistening rate [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,4) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt5' + IPD_Diag(idx)%output_name = 'VDFOZ' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Ozone vertical diffusion [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,5) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt6' + IPD_Diag(idx)%output_name = 'POZ' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Ozone production [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,6) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt7' + IPD_Diag(idx)%output_name = 'TOZ' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Ozone tendency [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,7) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt8' + IPD_Diag(idx)%output_name = 'POZT' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Ozone production from temperature term [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,8) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dq3dt9' + IPD_Diag(idx)%output_name = 'POZO' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Ozone production from col ozone term [kg/kg/s] at model layers' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dq3dt(:,:,1) + enddo + + !---du3dt + idx = idx + 1 + IPD_Diag(idx)%name = 'du3dt1' + IPD_Diag(idx)%output_name = 'VDFUA' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Vertical diffusion zonal acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%du3dt(:,:,1) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'du3dt2' + IPD_Diag(idx)%output_name = 'GWDU' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Gravity wave drag zonal acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%du3dt(:,:,2) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'du3dt3' + IPD_Diag(idx)%output_name = 'CNVU' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Convective zonal momentum mixing acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%du3dt(:,:,3) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'du3dt4' + IPD_Diag(idx)%output_name = 'CNGWDU' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Convective Gravity wave drag zonal momentum mixing acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%du3dt(:,:,4) + enddo + + !---dv3dt + idx = idx + 1 + IPD_Diag(idx)%name = 'dv3dt1' + IPD_Diag(idx)%output_name = 'VDFVA' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Vertical diffusion meridional acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dv3dt(:,:,1) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dv3dt2' + IPD_Diag(idx)%output_name = 'GWDV' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Gravity wave drag meridional acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dv3dt(:,:,2) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dv3dt3' + IPD_Diag(idx)%output_name = 'CNVV' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Convective meridional momentum mixing acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dv3dt(:,:,3) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dv3dt4' + IPD_Diag(idx)%output_name = 'CNGWDV' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Convective Gravity wave drag meridional acceleration [m/s**2] at model layers' + IPD_Diag(idx)%unit = 'm/s**2' + IPD_Diag(idx)%type_stat_proc = 'acc_rtime' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dv3dt(:,:,4) + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'cldcov' + IPD_Diag(idx)%output_name = 'CDLYR' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Amount of non-convective cloud [%] at model layers' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'acc_rtimsw' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%cldcov + enddo + + idx = idx + 1 + IPD_Diag(idx)%name = 'dkt_pbl' + IPD_Diag(idx)%output_name = 'DKT_PBL' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'Turbulent heat diffusion coefficient' + IPD_Diag(idx)%unit = 'm**2/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model interfaces' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%dkt + enddo + endif + + if (Model%lgocart) then + !---dqdtv + idx = idx + 1 + IPD_Diag(idx)%name = 'dqdti' + IPD_Diag(idx)%output_name = 'DQDTV' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'gocart_cpl' + IPD_Diag(idx)%desc = 'instantaneous total moisture tendency [kg/kg/s]' + IPD_Diag(idx)%unit = 'kg/kg/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Coupling(nb)%dqdti + enddo + endif + + ! GFS_SFCPROP CONTAINER DATA: with ialb=0: climatological albedo scheme + !---alnsf + idx = idx + 1 + IPD_Diag(idx)%name = 'alnsf' + IPD_Diag(idx)%output_name = 'alnsf' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'mean nir albedo with strong cosz dependency' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = '' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%alnsf + enddo + + !---alnwf + idx = idx + 1 + IPD_Diag(idx)%name = 'alnwf' + IPD_Diag(idx)%output_name = 'ALNWF' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'nir albedo with weak cosz dependency [%] at surface' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%alnwf + enddo + + !---alvsf + idx = idx + 1 + IPD_Diag(idx)%name = 'alvsf' + IPD_Diag(idx)%output_name = 'ALVSF' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'uv+vis albedo with strong cosz dependency [%] at surface' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%alvsf + enddo + + !---alvwf + idx = idx + 1 + IPD_Diag(idx)%name = 'alvwf' + IPD_Diag(idx)%output_name = 'ALVWF' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'vis albedo with weak cosz dependency' + IPD_Diag(idx)%unit = '%' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%alvwf + enddo + + !---canopy + idx = idx + 1 + IPD_Diag(idx)%name = 'canopy' + IPD_Diag(idx)%output_name = 'CNWAT' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Canopy water content (kg/m**2)' + IPD_Diag(idx)%unit = 'kg/m**2 ' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%canopy + enddo + + !---f10m + idx = idx + 1 + IPD_Diag(idx)%name = 'f10m' + IPD_Diag(idx)%output_name = 'F10M' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'ratio of 10-meter wind speed to the lowest model layer wind speed [numeric]' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '10 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%f10m + enddo + + !---facsf + idx = idx + 1 + IPD_Diag(idx)%name = 'facsf' + IPD_Diag(idx)%output_name = 'FACSF' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'fractional coverage with strong cosz dependency' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%facsf + enddo + + !---facwf + idx = idx + 1 + IPD_Diag(idx)%name = 'facwf' + IPD_Diag(idx)%output_name = 'FACWF' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'fractional coverage with weak cosz dependency [fraction] ' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%facwf + enddo + + !---ffhh + idx = idx + 1 + IPD_Diag(idx)%name = 'ffhh' + IPD_Diag(idx)%output_name = 'FFHH' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'stability profile function [numeric] for heat at surface' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%ffhh + enddo + + !---ffmm + idx = idx + 1 + IPD_Diag(idx)%name = 'ffmm' + IPD_Diag(idx)%output_name = 'FFMM' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'stability profile function [numeric] for momentum at surface layer' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%ffmm + enddo + + !---uustar + idx = idx + 1 + IPD_Diag(idx)%name = 'uustar' + IPD_Diag(idx)%output_name = 'UUSTAR' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'frictional wind [numeric] at surface layer' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%uustar + enddo + + if (Model%myj_pbl) then + + !---hmix + idx = idx + 1 + IPD_Diag(idx)%name = 'hmix' + IPD_Diag(idx)%output_name = 'HMIX' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'MYJ mixed layer height' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Diag(nb)%hmix + enddo + + !---el_myj + idx = idx + 1 + IPD_Diag(idx)%name = 'el_myj' + IPD_Diag(idx)%output_name = 'EL_MYJ' + IPD_Diag(idx)%mod_name = 'physics' + IPD_Diag(idx)%file_name = 'diag3d' + IPD_Diag(idx)%desc = 'MYJ Mixing Length' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'model layer' + IPD_Diag(idx)%level = 64 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var3p => Diag(nb)%el_myj + enddo + + endif !myj_pbl + + !---slope + idx = idx + 1 + IPD_Diag(idx)%name = 'slope' + IPD_Diag(idx)%output_name = 'SLOPE' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'surface slope type [numeric]' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = '' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%slope + enddo + + !---fice + idx = idx + 1 + IPD_Diag(idx)%name = 'fice' + IPD_Diag(idx)%output_name = 'icec' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'surface ice concentration (ice=1, no ice=0) [fraction]' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%fice + enddo + + !---hice + idx = idx + 1 + IPD_Diag(idx)%name = 'hice' + IPD_Diag(idx)%output_name = 'icetk' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'ice thickness [m] at surface' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%hice + enddo + + !---snoalb + idx = idx + 1 + IPD_Diag(idx)%name = 'snoalb' + IPD_Diag(idx)%output_name = 'mxsalb' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'maximum snow albedo in fraction' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%snoalb + enddo + + !---shdmax + idx = idx + 1 + IPD_Diag(idx)%name = 'shdmax' + IPD_Diag(idx)%output_name = 'SHDMAX' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'maximum fractional coverage of green vegetation' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'max' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%shdmax + enddo + + !---shdmin + idx = idx + 1 + IPD_Diag(idx)%name = 'shdmin' + IPD_Diag(idx)%output_name = 'SHDMIN' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'minimum fractional coverage of green vegetation' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'min' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%shdmin + enddo + + !---snowd + idx = idx + 1 + IPD_Diag(idx)%name = 'snowd' + IPD_Diag(idx)%output_name = 'SNOWD' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'surface snow depth [m]' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%snowd + enddo + + !---stype + idx = idx + 1 + IPD_Diag(idx)%name = 'stype' + IPD_Diag(idx)%output_name = 'sotyp' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'soil type at surface' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%stype + enddo + + !---q2m + idx = idx + 1 + IPD_Diag(idx)%name = 'q2m' + IPD_Diag(idx)%output_name = 'spfh' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'specific humidity [kg/kg] at 2 m above ground' + IPD_Diag(idx)%unit = 'kg/kg' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '2 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%q2m + enddo + + !---t2m + idx = idx + 1 + IPD_Diag(idx)%name = 't2m' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'temperature [K] at 2 m above ground' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '2 m above grnd' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%t2m + enddo + + !---tsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'tsfc' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'surface temperature [K]' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%tsfc + enddo + + !---tg3 + idx = idx + 1 + IPD_Diag(idx)%name = 'tg3' + IPD_Diag(idx)%output_name = 'TG3' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'deep soil temperature [K]' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%tg3 + enddo + + !---tisfc + idx = idx + 1 + IPD_Diag(idx)%name = 'tisfc' + IPD_Diag(idx)%output_name = 'TISFC' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'surface temperature over ice fraction [K]' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%tisfc + enddo + + !---tprcp + idx = idx + 1 + IPD_Diag(idx)%name = 'tprcp' + IPD_Diag(idx)%output_name = 'TPRCP' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'total precipitation at surface [m]' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%tprcp + enddo + + !---vtype + idx = idx + 1 + IPD_Diag(idx)%name = 'vtype' + IPD_Diag(idx)%output_name = 'VGTYP' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'vegetation type [index]' + IPD_Diag(idx)%unit = 'index' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%vtype + enddo + + !---weasd + idx = idx + 1 + IPD_Diag(idx)%name = 'weasd' + IPD_Diag(idx)%output_name = 'WEASD' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Water equivalent of accumulated snow depth [kg/m**2] at surface' + IPD_Diag(idx)%unit = 'kg/m**2' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%weasd + enddo + + !---hgtsfc + idx = idx + 1 + IPD_Diag(idx)%name = 'hgtsfc' + IPD_Diag(idx)%output_name = 'HGT' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'surface geopotential height [gpm]' + IPD_Diag(idx)%unit = 'gpm' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%oro + enddo + + if (Model%myj_pbl) then + + !---QZ0 + idx = idx + 1 + IPD_Diag(idx)%name = 'QZ0' + IPD_Diag(idx)%output_name = 'QZ0' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Q at z=z0' + IPD_Diag(idx)%unit = 'kg/kg' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%QZ0 + enddo + + !---THZ0 + idx = idx + 1 + IPD_Diag(idx)%name = 'THZ0' + IPD_Diag(idx)%output_name = 'THZ0' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'TH at z=z0' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%THZ0 + enddo + + !---UZ0 + idx = idx + 1 + IPD_Diag(idx)%name = 'UZ0' + IPD_Diag(idx)%output_name = 'UZ0' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'U at z=z0' + IPD_Diag(idx)%unit = 'm/s' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%UZ0 + enddo + + !---VZ0 + idx = idx + 1 + IPD_Diag(idx)%name = 'VZ0' + IPD_Diag(idx)%output_name = 'VZ0' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'V at z=z0' + IPD_Diag(idx)%unit = 'kg/kg' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%VZ0 + enddo + + endif ! myj_pbl + + !---slmsk + idx = idx + 1 + IPD_Diag(idx)%name = 'slmsk' + IPD_Diag(idx)%output_name = 'LAND' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'sea-land-ice mask (0-sea, 1-land, 2-ice)' + IPD_Diag(idx)%unit = 'numeric' + IPD_Diag(idx)%type_stat_proc = '' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%slmsk + enddo + + !---zorl + idx = idx + 1 + IPD_Diag(idx)%name = 'zorl' + IPD_Diag(idx)%output_name = 'sfcr' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'surface roughness [m]' + IPD_Diag(idx)%unit = 'm' + IPD_Diag(idx)%type_stat_proc = ' ' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%zorl + enddo + + !---vfrac + idx = idx + 1 + IPD_Diag(idx)%name = 'vfrac' + IPD_Diag(idx)%output_name = 'veg' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'sfc' + IPD_Diag(idx)%desc = 'vegetation fraction' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = 'sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%vfrac + enddo + + !---slc 0-10cm + idx = idx + 1 + IPD_Diag(idx)%name = 'slc' + IPD_Diag(idx)%output_name = 'soill' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'liquid soil moisture content at 0-10cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '0-10cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%slc(:,1) + enddo + + !---slc 10-40cm + idx = idx + 1 + IPD_Diag(idx)%name = 'slc' + IPD_Diag(idx)%output_name = 'soill' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'liquid soil moisture content at 10-40cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '10-40cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%slc(:,2) + enddo + + !---slc 40-100cm + idx = idx + 1 + IPD_Diag(idx)%name = 'slc' + IPD_Diag(idx)%output_name = 'SLC' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'liquid soil moisture content at 40-100cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '40-100cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%slc(:,3) + enddo + + !---slc 100-200cm + idx = idx + 1 + IPD_Diag(idx)%name = 'slc' + IPD_Diag(idx)%output_name = 'soill' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'liquid soil moisture content at 100-200cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '100-200cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%slc(:,4) + enddo + + !---smc 0-10cm + idx = idx + 1 + IPD_Diag(idx)%name = 'smc' + IPD_Diag(idx)%output_name = 'soilw' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Volumetric soil moist content (frac) at 0-10cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '0-10cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%smc(:,1) + enddo + + !---smc 10-40cm + idx = idx + 1 + IPD_Diag(idx)%name = 'smc' + IPD_Diag(idx)%output_name = 'soilw' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Volumetric soil moist content (frac) at 10-40cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '10-40cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%smc(:,2) + enddo + + !---smc 40-100cm + idx = idx + 1 + IPD_Diag(idx)%name = 'smc' + IPD_Diag(idx)%output_name = 'soilw' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Volumetric soil moist content (frac) at 40-100cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '40-100cm' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%smc(:,3) + enddo + + !---smc 100-200cm + idx = idx + 1 + IPD_Diag(idx)%name = 'smc' + IPD_Diag(idx)%output_name = 'soilw' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'Volumetric soil moist content (frac) at 100-200cm below land surface' + IPD_Diag(idx)%unit = 'fraction' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '100-200cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%smc(:,4) + enddo + + !---stc 0-10cm + idx = idx + 1 + IPD_Diag(idx)%name = 'stc' + IPD_Diag(idx)%output_name = 'TMP' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = ' ' + IPD_Diag(idx)%desc = 'soil temperature at 0-10cm below land surface' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '0-10cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%stc(:,1) + enddo + + !---stc 10-40cm + idx = idx + 1 + IPD_Diag(idx)%name = 'stc' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'soil temperature at 10-40cm below land surface' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '10-40cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%stc(:,2) + enddo + + !---stc 40-100cm + idx = idx + 1 + IPD_Diag(idx)%name = 'stc' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'soil temperature at 40-100cm below land surface' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '40-100cm below land surface' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%stc(:,3) + enddo + + !---stc 100-200cm + idx = idx + 1 + IPD_Diag(idx)%name = 'stc' + IPD_Diag(idx)%output_name = 'tmp' + IPD_Diag(idx)%mod_name = 'surface' + IPD_Diag(idx)%file_name = 'flx' + IPD_Diag(idx)%desc = 'soil temperature at 100-200cm below land surface' + IPD_Diag(idx)%unit = 'K' + IPD_Diag(idx)%type_stat_proc = 'inst' + IPD_Diag(idx)%level_type = '100-200cm below sfc' + IPD_Diag(idx)%level = 1 + IPD_Diag(idx)%cnvfac = cn_one + IPD_Diag(idx)%zhour = Model%zhour + IPD_Diag(idx)%fcst_hour = Model%fhour + do nb = 1,nblks + IPD_Diag(idx)%data(nb)%var2p => Sfcprop(nb)%stc(:,4) + enddo + + if (idx > size(IPD_Diag)) then + print *,'GFS_populate_IPD_Diag: increase size declaration of IPD_Diag' + stop + endif + + end subroutine diag_populate + +end module physics_diag_layer + diff --git a/GFS_layer/GFS_driver.F90 b/GFS_layer/GFS_driver.F90 new file mode 100644 index 00000000..d28cdb74 --- /dev/null +++ b/GFS_layer/GFS_driver.F90 @@ -0,0 +1,751 @@ +module GFS_driver + + use machine, only: kind_phys + use GFS_typedefs, only: GFS_init_type, & + GFS_statein_type, GFS_stateout_type, & + GFS_sfcprop_type, GFS_coupling_type, & + GFS_control_type, GFS_grid_type, & + GFS_tbd_type, GFS_cldprop_type, & + GFS_radtend_type, GFS_diag_type + use module_radiation_driver, only: GFS_radiation_driver, radupdate + use module_physics_driver, only: GFS_physics_driver + use module_radsw_parameters, only: topfsw_type, sfcfsw_type + use module_radlw_parameters, only: topflw_type, sfcflw_type + use funcphys, only: gfuncphys + use gfdl_cld_mp_mod, only: gfdl_cld_mp_init +#ifndef fvGFS_2017 + use cld_eff_rad_mod, only: cld_eff_rad_init +#endif + use myj_pbl_mod, only: myj_pbl_init + use myj_jsfc_mod, only: myj_jsfc_init + + implicit none + + private + +!-------------------------------------------------------------------------------- +! GFS_init_type +!-------------------------------------------------------------------------------- +! This container is the minimum set of data required from the dycore/atmosphere +! component to allow proper initialization of the GFS physics +! +! Type is defined in GFS_typedefs.F90 +!-------------------------------------------------------------------------------- +! type GFS_init_type +! public +! integer :: me !< my MPI-rank +! integer :: master !< master MPI-rank +! integer :: isc !< starting i-index for this MPI-domain +! integer :: jsc !< starting j-index for this MPI-domain +! integer :: nx !< number of points in i-dir for this MPI rank +! integer :: ny !< number of points in j-dir for this MPI rank +! integer :: levs !< number of vertical levels +! integer :: cnx !< number of points in i-dir for this cubed-sphere face +! !< equal to gnx for lat-lon grids +! integer :: cny !< number of points in j-dir for this cubed-sphere face +! !< equal to gny for lat-lon grids +! integer :: gnx !< number of global points in x-dir (i) along the equator +! integer :: gny !< number of global points in y-dir (j) along any meridian +! integer :: nlunit !< fortran unit number for file opens +! integer :: logunit !< fortran unit number for writing logfile +! integer :: dt_dycore !< dynamics time step in seconds +! integer :: dt_phys !< physics time step in seconds +! integer :: bdat(8) !< model begin date in GFS format (same as idat) +! integer :: cdat(8) !< model current date in GFS format (same as jdat) +! !--- blocking data +! integer, pointer :: blksz(:) !< for explicit data blocking +! !< default blksz(1)=[nx*ny] +! !--- ak/bk for pressure level calculations +! integer, pointer :: ak(:) !< from surface (k=1) to TOA (k=levs) +! integer, pointer :: bk(:) !< from surface (k=1) to TOA (k=levs) +! !--- grid metrics +! real(kind=kind_phys), pointer :: xlon(:,:) !< column longitude for MPI rank +! real(kind=kind_phys), pointer :: xlat(:,:) !< column latitude for MPI rank +! real(kind=kind_phys), pointer :: area(:,:) !< column area for length scale calculations +! +! character(len=32), pointer :: tracer_names(:) !< tracers names to dereference tracer id +! !< based on name location in array +! character(len=65) :: fn_nml !< namelist filename +! character(len=*), pointer :: input_nml_file(:) !< character string containing full namelist +! !< for use with internal file reads +! end type GFS_init_type +!-------------------------------------------------------------------------------- + +!------------------ +! Module parameters +!------------------ + +!---------------------------- +! Module variable definitions +!---------------------------- + real(kind=kind_phys), parameter :: con_24 = 24.0_kind_phys + real(kind=kind_phys), parameter :: con_hr = 3600.0_kind_phys + real(kind=kind_phys), parameter :: con_99 = 99.0_kind_phys + real(kind=kind_phys), parameter :: con_100 = 100.0_kind_phys + real(kind=kind_phys), parameter :: qmin = 1.0e-10 + + integer, allocatable :: blksz(:) + +!---------------- +! Public entities +!---------------- + public GFS_initialize !< GFS initialization routine + public GFS_time_vary_step !< perform operations needed prior radiation or physics + public GFS_radiation_driver !< radiation_driver (was grrad) + public GFS_physics_driver !< physics_driver (was gbphys) + public GFS_stochastic_driver !< stochastic physics + + + CONTAINS +!******************************************************************************************* + + +!-------------- +! GFS initialze +!-------------- + subroutine GFS_initialize (Model, Statein, Stateout, Sfcprop, & + Coupling, Grid, Tbd, Cldprop, Radtend, & + Diag, Init_parm) + + use module_microphysics, only: gsmconst + use cldwat2m_micro, only: ini_micro + use aer_cloud, only: aer_cloud_init + use module_ras, only: ras_init + + + !--- interface variables + type(GFS_control_type), intent(inout) :: Model + type(GFS_statein_type), intent(inout) :: Statein(:) + type(GFS_stateout_type), intent(inout) :: Stateout(:) + type(GFS_sfcprop_type), intent(inout) :: Sfcprop(:) + type(GFS_coupling_type), intent(inout) :: Coupling(:) + type(GFS_grid_type), intent(inout) :: Grid(:) + type(GFS_tbd_type), intent(inout) :: Tbd(:) + type(GFS_cldprop_type), intent(inout) :: Cldprop(:) + type(GFS_radtend_type), intent(inout) :: Radtend(:) + type(GFS_diag_type), intent(inout) :: Diag(:) + type(GFS_init_type), intent(in) :: Init_parm + + !--- local variables + integer :: nb + integer :: nblks + integer :: ntrac + real(kind=kind_phys), allocatable :: si(:) + real(kind=kind_phys), parameter :: p_ref = 101325.0d0 + + + nblks = size(Init_parm%blksz) + ntrac = size(Init_parm%tracer_names) + allocate (blksz(nblks)) + blksz(:) = Init_parm%blksz(:) + + !--- set control properties (including namelist read) + call Model%init (Init_parm%nlunit, Init_parm%fn_nml, & + Init_parm%me, Init_parm%master, & + Init_parm%logunit, Init_parm%isc, & + Init_parm%jsc, Init_parm%nx, Init_parm%ny, & + Init_parm%levs, Init_parm%cnx, Init_parm%cny, & + Init_parm%gnx, Init_parm%gny, & + Init_parm%dt_dycore, Init_parm%dt_phys, & + Init_parm%bdat, Init_parm%cdat, & + Init_parm%iau_offset, & + Init_parm%tracer_names, & + Init_parm%input_nml_file, Init_parm%tile_num, & + Init_parm%blksz) + + + call read_o3data (Model%ntoz, Model%me, Model%master) + call read_h2odata (Model%h2o_phys, Model%me, Model%master) + + do nb = 1,nblks + call Statein (nb)%create (Init_parm%blksz(nb), Model) + call Stateout (nb)%create (Init_parm%blksz(nb), Model) + call Sfcprop (nb)%create (Init_parm%blksz(nb), Model) + call Coupling (nb)%create (Init_parm%blksz(nb), Model) + call Grid (nb)%create (Init_parm%blksz(nb), Model) + call Tbd (nb)%create (Init_parm%blksz(nb), Model) + call Cldprop (nb)%create (Init_parm%blksz(nb), Model) + call Radtend (nb)%create (Init_parm%blksz(nb), Model) + !--- internal representation of diagnostics + call Diag (nb)%create (Init_parm%blksz(nb), Model) + enddo + + !--- populate the grid components + call GFS_grid_populate (Grid, Init_parm%xlon, Init_parm%xlat, Init_parm%area) + + !--- read in and initialize ozone and water + if (Model%ntoz > 0) then + do nb = 1, nblks + call setindxoz (Init_parm%blksz(nb), Grid(nb)%xlat_d, Grid(nb)%jindx1_o3, & + Grid(nb)%jindx2_o3, Grid(nb)%ddy_o3) + enddo + endif + + if (Model%h2o_phys) then + do nb = 1, nblks + call setindxh2o (Init_parm%blksz(nb), Grid(nb)%xlat_d, Grid(nb)%jindx1_h, & + Grid(nb)%jindx2_h, Grid(nb)%ddy_h) + enddo + endif + + !--- Call gfuncphys (funcphys.f) to compute all physics function tables. + call gfuncphys () + + call gsmconst (Model%dtp, Model%me, .TRUE.) + + !--- define sigma level for radiation initialization + !--- The formula converting hybrid sigma pressure coefficients to sigma coefficients follows Eckermann (2009, MWR) + !--- ps is replaced with p0. The value of p0 uses that in http://www.emc.ncep.noaa.gov/officenotes/newernotes/on461.pdf + !--- ak/bk have been flipped from their original FV3 orientation and are defined sfc -> toa + allocate(si(Model%levr+1)) + si = (Init_parm%ak + Init_parm%bk * p_ref - Init_parm%ak(Model%levr+1)) & + / (p_ref - Init_parm%ak(Model%levr+1)) + call rad_initialize (si, Model%levr, Model%ictm, Model%isol, & + Model%ico2, Model%iaer, Model%ialb, Model%iems, & + Model%ntcw, Model%num_p2d, Model%num_p3d, & + Model%npdf3d, Model%ntoz, & + Model%iovr_sw, Model%iovr_lw, Model%isubc_sw, & + Model%isubc_lw, Model%crick_proof, Model%ccnorm, & + Model%norad_precip, Model%idate,Model%iflip, Model%me) + deallocate (si) + + !--- initialize Morrison-Gettleman microphysics + if (Model%ncld == 2) then + call ini_micro (Model%mg_dcs, Model%mg_qcvar, Model%mg_ts_auto_ice) + call aer_cloud_init () + endif + + !--- initialize GFDL Cloud microphysics + if (.not. Model%do_inline_mp .and. Model%ncld == 5) then + call gfdl_cld_mp_init (Model%input_nml_file, Init_parm%logunit) +#ifndef fvGFS_2017 + call cld_eff_rad_init (Model%input_nml_file, Init_parm%logunit) +#endif + endif + + !--- initialize ras + if (Model%ras) call ras_init (Model%levs, Model%me) + + if (Model%myj_pbl) then + do nb = 1, nblks + call myj_pbl_init(EXCH_H=Statein(nb)%exch_h, RESTART=.false., & + IDS=1,IDE=size(Grid(nb)%xlon,1),JDS=1,JDE=1,LM=Model%levs, & + IMS=1,IME=size(Grid(nb)%xlon,1),JMS=1,JME=1, & + ITS=1,ITE=size(Grid(nb)%xlon,1),JTS=1,JTE=1 ) + !Removed many input variables which aren't used + call myj_jsfc_init(USTAR=Sfcprop(nb)%uustar, RESTART=.false. & + ,IDS=1,IDE=size(Grid(nb)%xlon,1),JDS=1,JDE=1,KDS=1,KDE=Model%levs & + ,IMS=1,IME=size(Grid(nb)%xlon,1),JMS=1,JME=1,KMS=1,KME=Model%levs & + ,ITS=1,ITE=size(Grid(nb)%xlon,1),JTS=1,JTE=1,KTS=1,LM =Model%levs ) + enddo + endif + + !--- initialize soil vegetation + call set_soilveg(Model, Model%isot, Model%ivegsrc, Init_parm%logunit, size(Model%input_nml_file), Model%input_nml_file) +! + !--- lsidea initialization + if (Model%lsidea) then + print *,' LSIDEA is active but needs to be reworked for FV3 - shutting down' + stop + !--- NEED TO get the logic from the old phys/gloopb.f initialization area + endif + + !--- sncovr may not exist in ICs from chgres. + !--- FV3GFS handles this as part of the IC ingest + !--- this note is placed here alertng users to study + !--- the FV3GFS_io.F90 module + + end subroutine GFS_initialize + + +!------------------------------------------------------------------------- +! time_vary_step +!------------------------------------------------------------------------- +! routine called prior to radiation and physics steps to handle: +! 1) sets up various time/date variables +! 2) sets up various triggers +! 3) defines random seed indices for radiation (in a reproducible way) +! 5) interpolates coefficients for prognostic ozone calculation +! 6) performs surface data cycling via the GFS gcycle routine +!------------------------------------------------------------------------- + subroutine GFS_time_vary_step (Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag) + + implicit none + + !--- interface variables + type(GFS_control_type), intent(inout) :: Model + type(GFS_statein_type), intent(inout) :: Statein(:) + type(GFS_stateout_type), intent(inout) :: Stateout(:) + type(GFS_sfcprop_type), intent(inout) :: Sfcprop(:) + type(GFS_coupling_type), intent(inout) :: Coupling(:) + type(GFS_grid_type), intent(inout) :: Grid(:) + type(GFS_tbd_type), intent(inout) :: Tbd(:) + type(GFS_cldprop_type), intent(inout) :: Cldprop(:) + type(GFS_radtend_type), intent(inout) :: Radtend(:) + type(GFS_diag_type), intent(inout) :: Diag(:) + !--- local variables + integer :: nb, nblks, k, kdt_iau + logical :: iauwindow_center + real(kind=kind_phys) :: rinc(5) + real(kind=kind_phys) :: sec, sec_zero, fjd + integer :: iyear, imon, iday, ihr, imin, jd0, jd1 + integer :: iw3jdn + + nblks = size(blksz) + !--- Model%jdat is being updated directly inside of FV3GFS_cap.F90 + !--- update calendars and triggers + rinc(1:5) = 0 + call w3difdat(Model%jdat,Model%idat,4,rinc) + sec = rinc(4) + Model%phour = sec/con_hr + !--- set current bucket hour + Model%zhour = Model%phour + Model%fhour = (sec + Model%dtp)/con_hr + Model%kdt = nint((sec + Model%dtp)/Model%dtp) + + Model%ipt = 1 + !Model%lprnt = .false. + Model%lssav = .true. + + !--- radiation triggers + Model%lsswr = (mod(Model%kdt, Model%nsswr) == 1) + Model%lslwr = (mod(Model%kdt, Model%nslwr) == 1) + + if (Model%fixed_solhr) then + !--- set the solar hour based on time initial hour + Model%solhr = mod(0.0+Model%idate(1),con_24) + else + !--- set the solar hour based on a combination of phour and time initial hour + Model%solhr = mod(Model%phour+Model%idate(1),con_24) + endif + + if (Model%lsm == Model%lsm_noahmp) then +! +! Julian day calculation (fcst day of the year) +! we need imn to init lai and sai and yearln and julian to +! pass to noah mp sflx, idate is init, jdat is fcst;idate = jdat when kdt=1 +! jdat is changing +! + + Model%imn = Model%idate(2) + + iyear = Model%jdat(1) + imon = Model%jdat(2) + iday = Model%jdat(3) + ihr = Model%jdat(5) + imin = Model%jdat(6) + + jd1 = iw3jdn(iyear,imon,iday) + jd0 = iw3jdn(iyear,1,1) + fjd = float(ihr)/24.0 + float(imin)/1440.0 + + Model%julian = float(jd1-jd0) + fjd + +! +! Year length +! +! what if the integration goes from one year to another? +! iyr or jyr ? from 365 to 366 or from 366 to 365 +! +! is this against model's noleap yr assumption? + + if (mod(iyear,400) == 0) then + Model%yearlen = 366 + elseif (mod(iyear,100) == 0) then + Model%yearlen = 365 + elseif (mod(iyear,4) == 0) then + Model%yearlen = 366 + else + Model%yearlen = 365 + endif + endif ! if (Model%lsm == Model%lsm_noahmp) +! + + + if ((Model%debug) .and. (Model%me == Model%master)) then + print *,' sec ', sec + print *,' kdt ', Model%kdt + print *,' nsswr ', Model%nsswr + print *,' nslwr ', Model%nslwr + print *,' nscyc ', Model%nscyc + print *,' lsswr ', Model%lsswr + print *,' lslwr ', Model%lslwr + print *,' fhour ', Model%fhour + print *,' phour ', Model%phour + print *,' solhr ', Model%solhr + endif + + !--- radiation time varying routine + if (Model%lsswr .or. Model%lslwr) then + call GFS_rad_time_vary (Model, Statein, Tbd, sec) + endif + + !--- physics time varying routine + call GFS_phys_time_vary (Model, Grid, Tbd) + + !--- repopulate specific time-varying sfc properties for AMIP/forecast runs + if (Model%nscyc > 0) then + if (mod(Model%kdt,Model%nscyc) == 1 .or. (Model%iau_offset > 0 .and. Model%kdt-Model%kdt_prev == 1)) THEN + call gcycle (nblks, Model, Grid(:), Sfcprop(:), Cldprop(:)) + endif + endif + + !--- determine if diagnostics buckets need to be cleared + if (mod(Model%kdt,Model%nszero) == 1 .or. Model%nszero == 1) then + do nb = 1,nblks + call Diag(nb)%phys_zero (Model) + !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED + enddo + endif + if (mod(Model%kdt,max(Model%nszero,min(Model%nsswr,Model%nslwr))) == 1) then + do nb = 1,nblks + call Diag(nb)%rad_zero (Model) + !!!! THIS IS THE POINT AT WHICH DIAG%ZHOUR NEEDS TO BE UPDATED + enddo + endif + if (Model%iau_offset > 0) then + kdt_iau = nint(Model%iau_offset*con_hr/Model%dtp) + if (Model%kdt == kdt_iau+1) then + iauwindow_center = .true. + do nb = 1,nblks + call Diag(nb)%rad_zero (Model) + call Diag(nb)%phys_zero (Model,iauwindow_center=iauwindow_center) + enddo + if(Model%me == Model%master) print *,'in gfs_driver, at iau_center, zero out rad/phys accumulated diag fields, kdt=',Model%kdt,'kdt_iau=',kdt_iau,'iau_offset=',Model%iau_offset + endif + endif + +! kludge for output + if (Model%do_skeb) then + do nb = 1,nblks + do k=1,Model%levs + Diag(nb)%skebu_wts(:,k) = Coupling(nb)%skebu_wts(:,Model%levs-k+1) + Diag(nb)%skebv_wts(:,k) = Coupling(nb)%skebv_wts(:,Model%levs-k+1) + Diag(nb)%diss_est(:,k) = Statein(nb)%diss_est(:,Model%levs-k+1) + enddo + enddo + endif + !if (Model%do_sppt) then + ! do nb = 1,nblks + ! do k=1,Model%levs + ! Diag(nb)%sppt_wts(:,k) = Coupling(nb)%sppt_wts(:,Model%levs-k+1) + ! enddo + ! enddo + !endif + if (Model%do_shum) then + do nb = 1,nblks + do k=1,Model%levs + Diag(nb)%shum_wts(:,k)=Coupling(nb)%shum_wts(:,Model%levs-k+1) + enddo + enddo + endif + + end subroutine GFS_time_vary_step + + +!------------------------------------------------------------------------- +! GFS stochastic_driver +!------------------------------------------------------------------------- +! routine called prior to radiation and physics steps to handle: +! 1) sets up various time/date variables +! 2) sets up various triggers +! 3) defines random seed indices for radiation (in a reproducible way) +! 5) interpolates coefficients for prognostic ozone calculation +! 6) performs surface data cycling via the GFS gcycle routine +!------------------------------------------------------------------------- + subroutine GFS_stochastic_driver (Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag) + + implicit none + + !--- interface variables + type(GFS_control_type), intent(in ) :: Model + type(GFS_statein_type), intent(in ) :: Statein + type(GFS_stateout_type), intent(in ) :: Stateout + type(GFS_sfcprop_type), intent(in ) :: Sfcprop + type(GFS_coupling_type), intent(inout) :: Coupling + type(GFS_grid_type), intent(in ) :: Grid + type(GFS_tbd_type), intent(in ) :: Tbd + type(GFS_cldprop_type), intent(in ) :: Cldprop + type(GFS_radtend_type), intent(in ) :: Radtend + type(GFS_diag_type), intent(inout) :: Diag + !--- local variables + integer :: k, i + real(kind=kind_phys) :: upert, vpert, tpert, qpert, qnew, sppt_vwt + + if (Model%do_sppt) then + do k = 1,size(Statein%tgrs,2) + do i = 1,size(Statein%tgrs,1) + sppt_vwt=1.0 + if (Diag%zmtnblck(i).EQ.0.0) then + sppt_vwt=1.0 + else + if (k.GT.Diag%zmtnblck(i)+2) then + sppt_vwt=1.0 + endif + if (k.LE.Diag%zmtnblck(i)) then + sppt_vwt=0.0 + endif + if (k.EQ.Diag%zmtnblck(i)+1) then + sppt_vwt=0.333333 + endif + if (k.EQ.Diag%zmtnblck(i)+2) then + sppt_vwt=0.666667 + endif + endif + if (Model%use_zmtnblck)then + Coupling%sppt_wts(i,k)=(Coupling%sppt_wts(i,k)-1)*sppt_vwt+1.0 + endif + Diag%sppt_wts(i,Model%levs-k+1)=Coupling%sppt_wts(i,k) + upert = (Stateout%gu0(i,k) - Statein%ugrs(i,k)) * Coupling%sppt_wts(i,k) + vpert = (Stateout%gv0(i,k) - Statein%vgrs(i,k)) * Coupling%sppt_wts(i,k) + tpert = (Stateout%gt0(i,k) - Statein%tgrs(i,k) - Tbd%dtdtr(i,k)) * Coupling%sppt_wts(i,k) + qpert = (Stateout%gq0(i,k,1) - Statein%qgrs(i,k,1)) * Coupling%sppt_wts(i,k) + + Stateout%gu0(i,k) = Statein%ugrs(i,k)+upert + Stateout%gv0(i,k) = Statein%vgrs(i,k)+vpert + + !negative humidity check + qnew = Statein%qgrs(i,k,1)+qpert + if (qnew >= 1.0e-10) then + Stateout%gq0(i,k,1) = qnew + Stateout%gt0(i,k) = Statein%tgrs(i,k) + tpert + Tbd%dtdtr(i,k) + endif + enddo + enddo + + ! instantaneous precip rate going into land model at the next time step + Sfcprop%tprcp(:) = Coupling%sppt_wts(:,15)*Sfcprop%tprcp(:) + Diag%totprcp(:) = Diag%totprcp(:) + (Coupling%sppt_wts(:,15) - 1 )*Diag%rain(:) + ! acccumulated total and convective preciptiation + Diag%cnvprcp(:) = Diag%cnvprcp(:) + (Coupling%sppt_wts(:,15) - 1 )*Diag%rainc(:) + ! bucket precipitation adjustment due to sppt + Diag%totprcpb(:) = Diag%totprcpb(:) + (Coupling%sppt_wts(:,15) - 1 )*Diag%rain(:) + Diag%cnvprcpb(:) = Diag%cnvprcpb(:) + (Coupling%sppt_wts(:,15) - 1 )*Diag%rainc(:) + + + if (Model%cplflx) then + Coupling%rain_cpl(:) = Coupling%rain_cpl(:) + (Coupling%sppt_wts(:,15) - 1.0)*Tbd%drain_cpl(:) + Coupling%snow_cpl(:) = Coupling%snow_cpl(:) + (Coupling%sppt_wts(:,15) - 1.0)*Tbd%dsnow_cpl(:) + endif + + endif + + if (Model%do_shum) then + Stateout%gq0(:,:,1) = Stateout%gq0(:,:,1)*(1.0 + Coupling%shum_wts(:,:)) + endif + + if (Model%do_skeb) then + do k = 1,size(Statein%tgrs,2) + Stateout%gu0(:,k) = Stateout%gu0(:,k)+Coupling%skebu_wts(:,k)*(Statein%diss_est(:,k)) + Stateout%gv0(:,k) = Stateout%gv0(:,k)+Coupling%skebv_wts(:,k)*(Statein%diss_est(:,k)) + enddo + endif + + end subroutine GFS_stochastic_driver + + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! PRIVATE SUBROUTINES +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +!----------------------------------------------------------------------- +! GFS_rad_time_vary +!----------------------------------------------------------------------- +! +! Routine containing all of the setup logic originally in phys/gloopr.f +! +!----------------------------------------------------------------------- + subroutine GFS_rad_time_vary (Model, Statein, Tbd, sec) + + use physparam, only: ipsd0, ipsdlim, iaerflg + use mersenne_twister, only: random_setseed, random_index, random_stat + + implicit none + + type(GFS_control_type), intent(inout) :: Model + type(GFS_statein_type), intent(in) :: Statein(:) + type(GFS_tbd_type), intent(inout) :: Tbd(:) + real(kind=kind_phys), intent(in) :: sec + !--- local variables + type (random_stat) :: stat + integer :: ix, nb, j, i, nblks, ipseed + integer :: numrdm(Model%cnx*Model%cny*2) + + nblks = size(blksz,1) + + call radupdate (Model%idat, Model%jdat, Model%fhswr, Model%dtf, Model%lsswr, & + Model%me, Model%slag, Model%sdec, Model%cdec, Model%solcon, Model%fixed_date ) + + !--- set up random seed index in a reproducible way for entire cubed-sphere face (lat-lon grid) + if ((Model%isubc_lw==2) .or. (Model%isubc_sw==2)) then + ipseed = mod(nint(con_100*sqrt(sec)), ipsdlim) + 1 + ipsd0 + call random_setseed (ipseed, stat) + call random_index (ipsdlim, numrdm, stat) + + !--- set the random seeds for each column in a reproducible way + ix = 0 + nb = 1 + do j = 1,Model%ny + do i = 1,Model%nx + ix = ix + 1 + if (ix .gt. blksz(nb)) then + ix = 1 + nb = nb + 1 + endif + !--- for testing purposes, replace numrdm with '100' + Tbd(nb)%icsdsw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx) + Tbd(nb)%icsdlw(ix) = numrdm(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + Model%cnx*Model%cny) + enddo + enddo + endif ! isubc_lw and isubc_sw + + if (Model%zhao_mic) then + if (Model%kdt == 1) then + do nb = 1,nblks + Tbd(nb)%phy_f3d(:,:,1) = Statein(nb)%tgrs + Tbd(nb)%phy_f3d(:,:,2) = max(qmin,Statein(nb)%qgrs(:,:,1)) + Tbd(nb)%phy_f3d(:,:,3) = Statein(nb)%tgrs + Tbd(nb)%phy_f3d(:,:,4) = max(qmin,Statein(nb)%qgrs(:,:,1)) + Tbd(nb)%phy_f2d(:,1) = Statein(nb)%prsi(:,1) + Tbd(nb)%phy_f2d(:,2) = Statein(nb)%prsi(:,1) + enddo + endif + endif + + end subroutine GFS_rad_time_vary + + +!----------------------------------------------------------------------- +! GFS_phys_time_vary +!----------------------------------------------------------------------- +! +! Routine containing all of the setup logic originally in phys/gloopb.f +! +!----------------------------------------------------------------------- + subroutine GFS_phys_time_vary (Model, Grid, Tbd) + use mersenne_twister, only: random_setseed, random_number + + implicit none + type(GFS_control_type), intent(inout) :: Model + type(GFS_grid_type), intent(inout) :: Grid(:) + type(GFS_tbd_type), intent(inout) :: Tbd(:) + !--- local variables + integer :: nb, ix, k, j, i, nblks, iseed, iskip + real(kind=kind_phys) :: wrk(1) + real(kind=kind_phys) :: rannie(Model%cny) + real(kind=kind_phys) :: rndval(Model%cnx*Model%cny*Model%nrcm) + + nblks = size(blksz,1) + + !--- switch for saving convective clouds - cnvc90.f + !--- aka Ken Campana/Yu-Tai Hou legacy + if ((mod(Model%kdt,Model%nsswr) == 0) .and. (Model%lsswr)) then + !--- initialize,accumulate,convert + Model%clstp = 1100 + min(Model%fhswr/con_hr,Model%fhour,con_99) + elseif (mod(Model%kdt,Model%nsswr) == 0) then + !--- accumulate,convert + Model%clstp = 0100 + min(Model%fhswr/con_hr,Model%fhour,con_99) + elseif (Model%lsswr) then + !--- initialize,accumulate + Model%clstp = 1100 + else + !--- accumulate + Model%clstp = 0100 + endif + + !--- random number needed for RAS and old SAS and when cal_pre=.true. + if ( ((Model%imfdeepcnv <= 0) .or. (Model%cal_pre)) .and. (Model%random_clds) ) then + iseed = mod(con_100*sqrt(Model%fhour*con_hr),1.0d9) + Model%seed0 + call random_setseed(iseed) + call random_number(wrk) + do i = 1,Model%cnx*Model%nrcm + iseed = iseed + nint(wrk(1)) * i + call random_setseed(iseed) + call random_number(rannie) + rndval(1+(i-1)*Model%cny:i*Model%cny) = rannie(1:Model%cny) + enddo + + do k = 1,Model%nrcm + iskip = (k-1)*Model%cnx*Model%cny + ix = 0 + nb = 1 + do j = 1,Model%ny + do i = 1,Model%nx + ix = ix + 1 + if (ix .gt. blksz(nb)) then + ix = 1 + nb = nb + 1 + endif + Tbd(nb)%rann(ix,k) = rndval(i+Model%isc-1 + (j+Model%jsc-2)*Model%cnx + iskip) + enddo + enddo + enddo + endif ! imfdeepcnv, cal_re, random_clds + + !--- o3 interpolation + if (Model%ntoz > 0) then + do nb = 1, nblks + call ozinterpol (Model%me, blksz(nb), Model%idate, Model%fhour, & + Grid(nb)%jindx1_o3, Grid(nb)%jindx2_o3, & + Tbd(nb)%ozpl, Grid(nb)%ddy_o3) + enddo + endif + + !--- h2o interpolation + if (Model%h2o_phys) then + do nb = 1, nblks + call h2ointerpol (Model%me, blksz(nb), Model%idate, Model%fhour, & + Grid(nb)%jindx1_h, Grid(nb)%jindx2_h, & + Tbd(nb)%h2opl, Grid(nb)%ddy_h) + enddo + endif + + end subroutine GFS_phys_time_vary + + +!------------------ +! GFS_grid_populate +!------------------ + subroutine GFS_grid_populate (Grid, xlon, xlat, area) + use physcons, only: pi => con_pi + + implicit none + + type(GFS_grid_type) :: Grid(:) + real(kind=kind_phys), intent(in) :: xlon(:,:) + real(kind=kind_phys), intent(in) :: xlat(:,:) + real(kind=kind_phys), intent(in) :: area(:,:) + + !--- local variables + integer :: nb, ix, blksz, i, j + + blksz = size(Grid(1)%xlon) + + nb = 1 + ix = 0 + do j = 1,size(xlon,2) + do i = 1,size(xlon,1) + ix=ix+1 + if (ix .gt. blksz) then + nb = nb + 1 + ix = 1 + endif + Grid(nb)%xlon(ix) = xlon(i,j) + Grid(nb)%xlat(ix) = xlat(i,j) + Grid(nb)%xlat_d(ix) = xlat(i,j) * 180.0_kind_phys/pi + Grid(nb)%sinlat(ix) = sin(Grid(nb)%xlat(ix)) + Grid(nb)%coslat(ix) = sqrt(1.0_kind_phys - Grid(nb)%sinlat(ix)*Grid(nb)%sinlat(ix)) + Grid(nb)%area(ix) = area(i,j) + Grid(nb)%dx(ix) = sqrt(area(i,j)) + enddo + enddo + + end subroutine GFS_grid_populate + +end module GFS_driver + diff --git a/GFS_layer/GFS_physics_driver.F90 b/GFS_layer/GFS_physics_driver.F90 new file mode 100644 index 00000000..cd09f17e --- /dev/null +++ b/GFS_layer/GFS_physics_driver.F90 @@ -0,0 +1,4104 @@ +module module_physics_driver + + use machine, only: kind_phys + use physcons, only: con_cp, con_fvirt, con_g, con_rd, & + con_rv, con_hvap, con_hfus, & + con_rerth, con_pi, rhc_max, dxmin,& + dxinv, pa2mb, rlapse, con_eps, con_epsm1, con_cvap + use cs_conv, only: cs_convr + use ozne_def, only: levozp, oz_coeff, oz_pres + use h2o_def, only: levh2o, h2o_coeff, h2o_pres + use gfs_fv3_needs, only: get_prs_fv3, get_phi_fv3 + use module_nst_water_prop, only: get_dtzm_2d + use GFS_typedefs, only: GFS_statein_type, GFS_stateout_type, & + GFS_sfcprop_type, GFS_coupling_type, & + GFS_control_type, GFS_grid_type, & + GFS_tbd_type, GFS_cldprop_type, & + GFS_radtend_type, GFS_diag_type + use gfdl_cld_mp_mod, only: gfdl_cld_mp_driver + use funcphys, only: ftdp + use module_ocean, only: update_ocean + use myj_pbl_mod, only: myj_pbl + use myj_jsfc_mod, only: myj_jsfc + use wv_saturation, only: estblf + + use module_sfc_drv, only: sfc_drv + + implicit none + + + !--- CONSTANT PARAMETERS + real(kind=kind_phys), parameter :: hocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: qmin = 1.0e-10 + real(kind=kind_phys), parameter :: rainmin = 1.0d-13 + real(kind=kind_phys), parameter :: p850 = 85000.0 + real(kind=kind_phys), parameter :: epsq = 1.e-20 + real(kind=kind_phys), parameter :: hsub = con_hvap+con_hfus + real(kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + real(kind=kind_phys), parameter :: zero = 0.0d0, onebg = 1.0/con_g + real(kind=kind_phys), parameter :: albdf = 0.06 + real(kind=kind_phys), parameter :: con_p001= 0.001d0 + real(kind=kind_phys), parameter :: con_day = 86400.d0 + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) + real(kind=kind_phys) cont, conq, conw + parameter(cont=con_cp/con_g,conq=con_hvap/con_g,conw=1./con_g) ! for del in pa + + +!> GFS Physics Implementation Layer +!> @brief Layer that invokes individual GFS physics routines +!> @{ +!at tune step===========================================================! +! description: ! +! ! +! usage: ! +! ! +! call gbphys ! +! ! +! --- interface variables ! +! type(GFS_control_type), intent(in) :: Model ! +! type(GFS_statein_type), intent(inout) :: Statein ! +! type(GFS_stateout_type), intent(inout) :: Stateout ! +! type(GFS_sfcprop_type), intent(inout) :: Sfcprop ! +! type(GFS_coupling_type), intent(inout) :: Coupling ! +! type(GFS_grid_type), intent(in) :: Grid ! +! type(GFS_tbd_type), intent(inout :: Tbd ! +! type(GFS_cldprop_type), intent(inout) :: Cldprop ! +! type(GFS_radtend_type), intent(inout) :: Radtend ! +! type(GFS_diag_type), intent(inout) :: Diag ! +! ! +! subprograms called: ! +! ! +! get_prs, dcyc2t2_pre_rad (testing), dcyc2t3, sfc_diff, ! +! sfc_ocean,sfc_drv, sfc_land, sfc_sice, sfc_diag, moninp1, ! +! moninp, moninq1, moninq, gwdps, ozphys, get_phi, ! +! sascnv, sascnvn, rascnv, cs_convr, gwdc, shalcvt3,shalcv,! +! shalcnv, cnvc90, lrgscl, gsmdrive, gscond, precpd, ! +! progt2. ! +! ! +! ! +! program history log: ! +! 19xx - ncep mrf/gfs ! +! 2002 - s. moorthi modify and restructure and add Ferrier ! +! microphysics as an option ! +! 200x - h. juang modify (what?) ! +! nov 2004 - x. wu modify sea-ice model ! +! may 2005 - s. moorthi modify and restructure ! +! 2005 - s. lu modify to include noah lsm ! +! oct 2006 - h. wei modify lsm options to include both ! +! noah and osu lsms. ! +! 2006 - s. moorthi added a. johansson's convective gravity ! +! wave parameterization code ! +! 2007 - s. moorthi added j. han's modified pbl/sas options ! +! dec 2007 - xu li modified the operational version for ! +! nst model ! +! 2008 - s. moorthi applied xu li's nst model to new gfs ! +! mar 2008 - y.-t. hou added sunshine duration var (suntim) as ! +! an input/output argument. ! +! 2008 - jun wang added spfhmax/spfhmin as input/output. ! +! apr 2008 - y.-t. hou added lw sfc emissivity var (sfcemis), ! +! define the lw sfc dn/up fluxes in two forms: atmos! +! and ground. also changed sw sfc net flux direction! +! (positive) from ground -> atmos to the direction ! +! of atmos -> ground. recode the program and add ! +! program documentation block. +! 2008/ - s. moorthi and y.t. hou upgraded the code to more ! +! 2009 modern form and changed all the inputs to MKS units.! +! feb 2009 - s. moorthi upgraded to add Hochun's gocart changes ! +! jul 2009 - s. moorthi added rqtk for sela's semi-lagrangian ! +! aug 2009 - s. moorthi added j. han and h. pan updated shallow ! +! convection package ! +! sep 2009 - s. moorthi updated for the mcica (rrtm3) radiation ! +! dec 2010 - sarah lu lgocart added to input arg; ! +! compute dqdt_v if inline gocart is on ! +! feb 2011 - sarah lu add the option to update surface diag ! +! fields (t2m,q2m,u10m,v10m) at the end ! +! Jun 2011 - s. moorthi and Xu Li - updated the nst model ! +! ! +! sep 2011 - sarah lu correct dqdt_v calculations ! +! apr 2012 - henry juang add idea ! +! sep 2012 - s. moorthi merge with operational version ! +! Mar 2013 - Jun Wang set idea heating rate to tmp tendency ! +! May 2013 - Jun Wang tmp updated after idea phys ! +! Jun 2013 - s. moorthi corrected a bug in 3d diagnostics for T ! +! Aug 2013 - s. moorthi updating J. Whitekar's changes related ! +! to stochastic physics perturnbation ! +! Oct 2013 - Xingren Wu add dusfci/dvsfci ! +! Mar 2014 - Xingren Wu add "_cpl" for coupling ! +! Mar 2014 - Xingren Wu add "nir/vis beam and nir/vis diff" ! +! Apr 2014 - Xingren Wu add "NET LW/SW including nir/vis" ! +! Jan 2014 - Jun Wang merge Moorthi's gwdc change and H.Juang ! +! and F. Yang's energy conversion from GWD! +! jan 2014 - y-t hou revised sw sfc spectral component fluxes! +! for coupled mdl, added estimation of ocean albedo ! +! without ice contamination. ! +! Jun 2014 - Xingren Wu update net SW fluxes over the ocean ! +! (no ice contamination) ! +! Jul 2014 - Xingren Wu add Sea/Land/Ice Mask - slmsk_cpl ! +! Jul 2014 - s. moorthi merge with standalone gfs and cleanup ! +! Aug 2014 - s. moorthi add tracer fixer ! +! Sep 2014 - Sarah Lu disable the option to compute tracer ! +! scavenging in GFS phys (set fscav=0.) ! +! Dec 2014 - Jun Wang add cnvqc_v for gocart ! + +! ==================== defination of variables ==================== ! +! --- 2014 - D. Dazlich Added Chikira-Sugiyama (CS) convection ! +! as an option in opr GFS. ! +! Apr 2015 S. Moorthi Added CS scheme to NEMS/GSM ! +! Jun 2015 S. Moorthi Added SHOC to NEMS/GSM ! +! Aug 2015 - Xu Li change nst_fcst to be nstf_name ! +! and introduce depth mean SST ! +! Sep 2015 - Xingren Wu remove oro_cpl & slmsk_cpl ! +! Sep 2015 - Xingren Wu add sfc_cice ! +! Sep 2015 - Xingren Wu connect CICE output to sfc_cice ! +! Jan 2016 - P. Tripp NUOPC/GSM merge ! +! Mar 2016 - J. Han - add ncnvcld3d integer ! +! for convective cloudiness enhancement ! +! Mar 2016 - J. Han - change newsas & sashal to imfdeepcnv ! +! & imfshalcnv, respectively ! +! Mar 2016 F. Yang add pgr to rayleigh damping call ! +! Mar 2016 S. Moorthi add ral_ts ! +! Mar 2016 Ann Cheng add morrison 2m microphysics (gsfc) ! +! May 2016 S. Moorthi cleanup 2m microphysics implementation ! +! Jun 2016 X. Li change all nst_fld as inout ! +! jul 2016 S. Moorthi fix some bugs in shoc/2m microphysics ! +! au-nv2016a S. Moorthi CS with AW and connect with shoc/2m ! +! Dec 2016 Anning C. Add prognostic rain and snow with 2M ! +! +! ==================== end of description ===================== +! ==================== definition of variables ==================== ! + +!> @details This subroutine is the suite driver for the GFS atmospheric physics and surface. +!! It is responsible for calculating and applying tendencies of the atmospheric state +!! variables due to the atmospheric physics and due to the surface layer scheme. In addition, +!! this routine applies radiative heating rates that were calculated during the +!! antecedent call to the radiation scheme. Code within this subroutine is executed on the +!! physics sub-timestep. The sub-timestep loop is executed in the subroutine gloopb. +!! +!! \section general General Algorithm +!! -# Prepare input variables for calling individual parameterizations. +!! -# Using a two-iteration loop, calculate the state variable tendencies for the surface layer. +!! -# Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. +!! -# Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. +!! -# Apply tendencies to the state variables calculated so far: +!! - for temperature: radiation, surface, PBL, oro. GWD, Rayleigh damping +!! - for momentum: surface, PBL, oro. GWD, Rayleigh damping +!! - for water vapor: surface, PBL +!! -# Calculate and apply the tendency of ozone. +!! -# Prepare input variables for physics routines that update the state variables within their subroutines. +!! -# If SHOC is active and is supposed to be called before convection, call it and update the state variables within. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. +!! -# Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. +!! -# If SHOC is active and is supposed to be called after convection, call it and update the state variables within. +!! -# Prepare for microphysics call by calculating preliminary variables. +!! -# If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. +!! -# Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. +!! -# Determine the precipitation type and update land surface properties if necessary. +!! -# Fill the output variables from the local variables as necessary and deallocate allocatable arrays. +!! \section detailed Detailed Algorithm +!! ## Prepare input variables for calling individual parameterizations. +!! Before calling any parameterizations, there is a section at the beginning of the subroutine for +!! preparing input arguments to the various schemes based on general input to the driver and initializing +!! variables used throughout the driver. +!! - General initialization: +!! - set a flag for running in debug mode and the horizontal index of the column to print +!! - calculate the pressure at layer centers, the exner function at layer centers and interfaces, +!! geopotential at layer centers and interfaces, and the layer-centered pressure difference +!! - calculate the ratio of dynamics time step to physics time step for applying tendencies +!! - initialize local tendency arrays to zero +!! - Radiation: +!! - adjust radiative fluxes and heating rates to the shorter physics time step (from the longer radiation time step), +!! unless idealized physics is true (lsidea) where radiative heating rates are set to 0 +!! - compute diagnostics from the radiation scheme needed for other schemes (e.g., downward longwave flux absorbed by the surface) +!! - accumulate the upward and downward longwave fluxes at the surface +!! - Surface: +!! - set NOAH and OSU scheme variables from gbphys input arguments and initialize local soil moisture variables +!! - set local sea ice variables from gbphys arguments +!! - set up A/O/I coupling variables from gbphys arguments +!! - PBL: +!! - set the number of tracers that are diffused vertically +!! - SHOC: +!! - determine the index of TKE (ntk) in the convectively transported tracer array (clw) +!! - allocate precipitation mixing ratio cloud droplet number concentration arrays +!! - Deep Convection: +!! - determine which tracers in the tracer input array undergo convective transport (valid only for the RAS and Chikira-Sugiyama schemes) and allocate a local convective transported tracer array (clw) +!! - apply an adjustment to the tracers from the dynamics +!! - calculate horizontal grid-related parameters needed for some parameterizations +!! - calculate the maxiumum cloud base updraft speed for the Chikira-Sugiyama scheme +!! - allocate array for cloud water and cloud cover (for non-RAS and non-Chikira-Sugiyama deep convective schemes) +!! - Shallow Convection: +!! - when using the Tiedtke shallow convection scheme with the stratus modifications, find the lowest +!! model level where a temperature inversion exists in the absence of CTEI +!! - Microphysics: +!! - for the Morrison (MGB) scheme, calculate 'FRLAND' if the grid point is over land +!! - allocate arrays associated with the Morrison scheme +!! - assign the local critical relative humidity variables from the gbphys arguments +!! - Gravity Wave Drag: +!! - calculate the deep convective cloud fraction at cloud top for the convective GWD scheme +!! . +!! ## Using a two-iteration loop, calculate the state variable tendencies for the surface layer. +!! - Each iteration of the loop calls the following: +!! - 'sfc_diff' to calculate surface exchange coefficients and near-surface wind +!! - surface energy balances routines are called regardless of surface type; the surface type is checked within each to determine whether the routine is "active" +!! - for the surface energy balance over the ocean, call 'sfc_nst' if NSST is on, otherwise, call 'sfc_ocean' +!! - for the surface energy balance over the land, call 'sfc_drv' for the NOAH model and 'sfc_land' for the OSU model +!! - for the surface energy balance over sea ice, call sfc_sice; if A/O/I coupling, call sfc_cice +!! - The initial iteration has flag_guess = F unless wind < 2 m/s; flag_iter = T +!! - After the initial iteration, flag_guess = F and flag_iter = F (unless wind < 2 m/s and over a land surface or an ocean surface with NSST on) +!! - The following actions are performed after the iteration to calculate surface energy balance: +!! - set surface output variables from their local values +!! - call 'sfc_diag' to calculate state variable values at 2 and 10 m as appropriate from near-surface model levels and the surface exchange coefficients +!! - if A/O/I coupling, set coupling variables from local variables and calculate the open water albedo +!! - finally, accumulate surface-related diagnostics and calculate the max/min values of T and q at 2 m height. +!! . +!! ## Calculate the state variable tendencies due to the PBL (vertical diffusion) scheme. +!! - Call the vertical diffusion scheme (PBL) based on the following logical flags: do_shoc, hybedmf, old_monin, mstrat +!! - the PBL scheme is expected to return tendencies of the state variables +!! - If A/O/I coupling and the surface is sea ice, overwrite some surface-related variables to their states before PBL was called +!! - For diagnostics, do the following: +!! - accumulate surface state variable tendencies and set the instantaneous values for output +!! - accumulate the temperature tendency due to the PBL scheme in dt3dt(:,:,3), subtracting out the radiative heating rate if necessary +!! - accumulate the u, v tendencies due to the PBL in du3dt(:,:,1:2) and dv3dt(:,:,1:2) +!! - accumulate the water vapor tendency due to the PBL in dq3dt(:,:,1) +!! - accumulate the ozone tendency in dq3dt(:,:,5) +!! . +!! ## Calculate the state variable tendencies due to orographic gravity wave drag and Rayleigh damping. +!! - Based on the variable nmtvr, unpack orographic gravity wave varibles from the hprime array +!! - Call 'gwdps' to calculate tendencies of u, v, T, and surface stress +!! - Accumulate gravity wave drag surface stresses. +!! - Accumulate change in u, v, and T due to oro. gravity wave drag in du3dt(:,:,2), dv3dt(:,:,2), and dt3dt(:,:,2) +!! - Call 'rayleigh_damp' to calculate tendencies to u, v, and T due to Rayleigh friction +!! . +!! ## Apply tendencies to the state variables calculated so far. +!! ## Calculate and apply the tendency of ozone. +!! - Call the convective adjustment scheme for IDEA +!! - Call 'ozphys_2015' or 'ozphys' depending on the value of pl_coeff, updating the ozone tracer within and outputing the tendency of ozone in dq3dt(:,:,6) +!! - Call 'h20phys' if necessary ("adaptation of NRL H20 phys for stratosphere and mesophere") +!! . +!! ## Prepare input variables for physics routines that update the state variables within their subroutines. +!! - If diagnostics is active, save the updated values of the state variables in 'dudt', 'dvdt', 'dTdt', and 'dqdt(:,:,1)' +!! - Call 'get_phi' to calculate geopotential from p, q, T +!! - Initialize the cloud water and ice portions of the convectively transported tracer array (clw) and (if the deep convective scheme is not RAS or Chikira-Sugiyama) the convective cloud water and cloud cover. +!! - If the dep convective scheme is RAS or Chikira-Sugiyama, fill the 'clw' array with tracers to be transported by convection +!! - Initialize 'ktop' and 'kbot' (to be modified by all convective schemes except Chikira-Sugiyama) +!! - Prepare for microphysics call (if cloud condensate is in the input tracer array): +!! - all schemes: calculate critical relative humidity +!! - Morrison et al. scheme (occasionally denoted MGB) (when ncld==2): set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water +!! - Ferrier scheme (num_p3d==3): set the cloud water variable and separate hydrometeors into cloud ice, cloud water, and rain; set clw(:,:,1) to cloud ice and clw(:,:,2) to cloud liquid water +!! - Zhao-Carr scheme (num_p3d==4): calculate autoconversion coefficients from input constants and grid info; set set clw(:,:,1) to cloud liquid water +!! - otherwise: set autoconversion parameters like in Zhao-Carr and set critical relative humidity to 1 +!! . +!! ## If SHOC is active and is supposed to be called before convection, call it and update the state variables within. +!! - Prior to calling SHOC, prepare some microphysics variables: +!! - if Morrison et al. scheme: set 'skip_macro', fill clw(:,:,1,2) with cloud ice, liquid from the tracer array, and fill cloud droplet number concentration arrays from the input tracer array +!! - if Zhao-Carr scheme: initialize precip. mixing ratios to 0, fill clw(:,:,1,2) with cloud ice, liquid from the tracer array (as a function of temperature) +!! - Call 'shoc' (modifies state variables within the subroutine) +!! - Afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to deep convection. +!! - Call deep convective scheme according to the parameter 'imfdeepcnv', 'ras', and 'cscnv'. +!! - if imfdeepcnv == 0, 1, or 2, no special processing is needed +!! - if the Chikira-Sugiyama scheme (cscnv), convert rain rate to accumulated rain (rain1) +!! - if RAS, initialize 'ccwfac', 'dlqfac', 'lmh', and revap before the call to 'rascnv' +!! - Zero out 'cld1d' (cloud work function calculated in non-RAS, non-Chikira-Sugiyama schemes) +!! - If 'lgocart', accumulate convective mass fluxes and convective cloud water +!! - Update tracers in the tracer array (gq0) due to convective transport (RAS, CS only) from the 'clw' array +!! - Calculate accumulated surface convective precip. for this physics time step (rainc) +!! - If necessary, accumulate cloud work function, convective precipitation, and convective mass fluxes; accumulate dt3dt(:,:,4), dq3dt(:,:,2), du3dt(:,:,3), dv3dt(:,:,3) as change in state variables due to deep convection +!! - If 'lgocart', repeat the accumulation of convective mass fluxes and convective cloud water; save convective tendency for water vapor in 'dqdt_v' +!! - If PDF-based clouds are active and Zhao-Carr microphysics, save convective cloud cover and water in 'phy_f3d' array +!! - otherwise, if non-PDF-based clouds and the "convective cloudiness enhancement" is active, save convective cloud water in 'phy_f3d' array +!! . +!! ## Calculate the state variable tendencies due to convective gravity wave drag and apply them afterwards. +!! - Calculate the average deep convective heating rate in the column to pass into 'gwdc' +!! - Call 'gwdc' to calculate tendencies of u, v due to convective GWD +!! - For diagnostics, accumulate the vertically-integrated change in u, v due to conv. GWD; accumulate change in u, v, due to conv. GWD in du3dt(:,:,4) and dv3dt(:,:,4) +!! - Calculate updated values of u, v, T using conv. GWD tendencies +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to shallow convection. +!! - If diagnostics are active, set 'dtdt' and 'dqdt' to updated values of T and q before shallow convection +!! - If SHOC is not active, do the following: +!! - for the mass-flux shallow convection scheme (imfdeepcnv == 1), call 'shalcnv' +!! - for the scale- and aerosol-aware scheme (imfshalcnv == 2), call 'samfshalcnv' +!! - for either of the first two schemes, perform the following after the call: +!! - if Zhao-Carr microphysics with PDF-based clouds, save convective cloud water an cover in 'phy_f3d' +!! - if non-PDF-based clouds and convective cloudiness enhancement is active, save convective cloud water in 'phy_f3d' +!! - calculate shallow convective precip. and add it to convective precip; accumulate convective precip. +!! - for the Tiedtke scheme (imfshalcnv == 0), find the top level where shallow convection must stratosphere +!! - if using Moorthi's approach to stratus, call 'shalcv' +!! - otherwise, call 'shalcvt3' +!! - for diagnostics, accumulate the change in water vapor due to shallow convection and save in dqdt_v if 'lgocart'; +!! - save the change in T and q due to shallow convection in dt3dt(:,:,5) and dq3dt(:,:,3); reset dtdt and dqdt to the updated values of T, q after shallow Convection +!! - if 'clw' is not partitioned into ice/water, set 'clw(ice)' to zero +!! - If SHOC is active (and shocaftcnv) +!! - if Morrison et al. scheme: set 'skip_macro' and fill cloud droplet number concentration arrays from the input tracer array +!! - initialize precip. mixing ratios to 0 +!! - call 'shoc' (modifies state variables within the subroutine) +!! - afterward, set updated cloud number concentrations in the tracer array from the updated 'ncpl' and 'ncpi' +!! . +!! ## Prepare for microphysics call by calculating preliminary variables. +!! - For Morrison et al. microphysics, set cloud water and ice arrays to the convecitvely transported values +!! - For Ferrier microphysics, combine convectively transported cloud water and ice with column rain and save in cloud water array +!! - calculate and save ice fraction and rain fraction in phy_f3d(1),(2) +!! - For Zhao-Carr, combine convectively transported cloud water and ice into the cloud water array +!! - Otherwise, combine convectively transported cloud water and ice into the convectively transported cloud water +!! - Call 'cnvc90'; a "legacy routine which determines convective clouds"; outputs 'acv','acvb','acvt','cv','cvb','cvt' +!! . +!! ## If necessary, call the moist convective adjustment subroutine and update the state temperature and moisture variable within. +!! - Updates T, q, 'rain1', cloud water array +!! - Accumulate convective precip +!! - For diagnostics, accumulate the change in T, q due to moist convective adjustment; reset 'dtdt' and 'dqdt' to updated T, q before call to microphysics +!! . +!! ## Calculate and apply the state variable tendencies (within the subroutine) due to microphysics. +!! - If 'lgocart', calculate instantaneous moisture tendency in dqdt_v +!! - If no cloud microphysics (ncld == 0), call 'lrgscl' to update T, q and output large scale precipitation and cloud water +!! - Otherwise, a more advanced microphysics scheme is called (which scheme depends on values of 'num_p3d','do_shoc',and 'ncld') +!! - Ferrier scheme (num_p3d == 3): +!! - calculate droplet number concentration and minimum large ice fraction +!! - call 'gsmdrive' (modifies T, q, cloud water, 'f_ice', 'f_rain', 'f_rimef', 'rain1') +!! - Zhao-Carr-Sundqvist scheme (num_p3d == 4): +!! - if non-PDF-based clouds: +!! - if 'do_shoc', call 'precpd_shoc' (precpd modified for SHOC) +!! - else, call 'gscond' (grid-scale condensation/evaporation); updates water vapor, cloud water, temperature +!! - call 'precpd'; updates water vapor, cloud water, temperature and outputs precip., snow ratio, and rain water path +!! - for PDF-based clouds: +!! - call 'gscondp' followed by 'precpdp' (similar arguments to gscond, precpd above) +!! - Morrison et al. scheme (ncld = 2): +!! - if 'do_shoc', set clw(1),(2) from updated values; set phy_f3d(:,:,1) from phy_f3d(:,:,ntot3d-2) +!! - else, set clw(1),(2) from updated values; set phy_f3d(:,:,1) to cloud cover from previous time step + convective cloud water from convective scheme +!! - call 'm_micro_driver'; updates water vapor, temperature, droplet number concentrations, cloud cover +!! - Combine large scale and convective precip. +!! - For diagnostics, accumulate total surface precipitation and accumulate change in T and q due to microphysics in dt3dt(:,:,6) and dq3dt(:,:,4) +!! . +!! ## Determine the precipitation type and update land surface properties if necessary. +!! - If 'cal_pre', diagnose the surface precipitation type +!! - call 'calpreciptype'; set snow flag to 1 if snow or sleet, 0 otherwise +!! - For rain/snow decision, calculate temperature at 850 hPa (\f$T_{850}\f$) +!! - If not 'cal_pre', set snow flag to 1 if \f$T_{850}\f$ is below freezing +!! - For coupling, accumulate rain if \f$T_{850}\f$ is above freezing, otherwise accumulate snow +!! - If using the OSU land model, accumulate surface snow depth if \f$T_{850}\f$ is below freezing and not over an ocean surface +!! - call 'progt2' (canopy and soil moisture?) and set the soil liquid water equal to soil total water +!! - if 'lgocart', call 'sfc_diag' to update near-surface state variables (this "allows gocart to use filtered wind fields") +!! - If necessary (lssav), update the 2m max/min values of T and q +!! - If necessary (lssav), accumulate total runoff and surface runoff. +!! . +!! ## Fill the output variables from the local variables as necessary and deallocate allocatable arrays. +!! - Set global sea ice thickness and concentration as well as the temperature of the sea ice +!! - Set global soil moisture variables +!! - Calculate precipitable water and water vapor mass change due to all physics for the column +!! - Deallocate arrays for SHOC scheme, deep convective scheme, and Morrison et al. microphysics + + + public GFS_physics_driver + + CONTAINS +!******************************************************************************************* + + subroutine GFS_physics_driver & + (Model, Statein, Stateout, Sfcprop, Coupling, & + Grid, Tbd, Cldprop, Radtend, Diag) + + implicit none +! +! --- interface variables + type(GFS_control_type), intent(in) :: Model + type(GFS_statein_type), intent(inout) :: Statein + type(GFS_stateout_type), intent(inout) :: Stateout + type(GFS_sfcprop_type), intent(inout) :: Sfcprop + type(GFS_coupling_type), intent(inout) :: Coupling + type(GFS_grid_type), intent(in) :: Grid + type(GFS_tbd_type), intent(inout) :: Tbd + type(GFS_cldprop_type), intent(inout) :: Cldprop + type(GFS_radtend_type), intent(inout) :: Radtend + type(GFS_diag_type), intent(inout) :: Diag +! +! --- local variables + + !--- INTEGER VARIABLES + integer :: me, lprint, ipr, ix, im, levs, ntrac, nvdiff, kdt + integer :: i, kk, ic, k, n, k1, iter, levshcm, tracers, & + tottracer, nsamftrac, num2, num3, nshocm, nshoc, ntk, & + itc, nn + integer :: kflip + integer :: ntsd ! for myj + + integer, dimension(size(Grid%xlon,1)) :: & + kbot, ktop, kcnv, soiltyp, vegtype, kpbl, slopetyp, kinver, & + lmh, levshc, islmsk, & + !--- coupling inputs for physics + islmsk_cice + + !--- LOGICAL VARIABLES + logical :: lprnt, revap, do_awdd, trans_aero + + logical, dimension(size(Grid%xlon,1)) :: & + flag_iter, flag_guess, invrsn, skip_macro, & + !--- coupling inputs for physics + flag_cice + + logical, dimension(Model%ntrac-Model%ncld+2,2) :: & + otspt + + !--- REAL VARIABLES + real(kind=kind_phys) :: & + dtf, dtp, rhbbot, rhbtop, rhpbl, frain, tem, tem1, tem2, & + xcosz_loc, zsea1, zsea2, eng0, eng1, dpshc, den, rdt, & + !--- experimental for shoc sub-stepping + dtshoc, & + !--- GFDL Cloud microphysics + crain, csnow, & + z0fun, diag_rain, diag_rain1 + + real(kind=kind_phys), dimension(Model%ntrac-Model%ncld+2) :: & + fscav, fswtr + + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + ccwfac, garea, dlength, cumabs, cice, zice, tice, gflx, & + rain1, raincs, snowmt, cd, cdq, qss, dusfcg, dvsfcg, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, rb, drain, cld1d, evap, hflx, & + stress, t850, ep1d, gamt, gamq, sigmaf, oc, theta, gamma, & + sigma, elvmax, wind, work1, work2, runof, xmu, fm10, fh2, & + tsurf, tx1, tx2, ctei_r, evbs, evcw, trans, sbsno, snowc, & + frland, adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, adjnirbmd, & + adjnirdfd, adjvisbmd, adjvisdfd, gabsbdlw, xcosz, tseal, & + snohf, dlqfac, work3, ctei_rml, cldf, domr, domzr, domip, & + doms, psautco_l, prautco_l, ocalnirbm_cpl, ocalnirdf_cpl, & + ocalvisbm_cpl, ocalvisdf_cpl, dtzm, temrain1, t2mmp, q2mp, & + !--- coupling inputs for physics + dtsfc_cice, dqsfc_cice, dusfc_cice, dvsfc_cice, ulwsfc_cice, & + tisfc_cice, tsea_cice, hice_cice, fice_cice, & + !--- for CS-convection + wcbmax + + logical, dimension(size(Grid%xlon,1)) :: & + wet, dry, icy +! + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + netflxsfc, & ! net surface heat flux + netswsfc, & ! + qflux_restore, & ! + qflux_adj ! +! + +#ifdef fvGFS_2017 + real(kind=kind_phys), dimension(size(Grid%xlon,1),1) :: & + area, land, rain0, snow0, ice0, graupel0, cond0, dep0, & + reevap0, sub0 +#else + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + gsize, hs, land, rain0, snow0, ice0, graupel0, cond0, dep0, & + reevap0, sub0, zvfun +#endif + + real(kind=kind_phys), dimension(size(Grid%xlon,1),4) :: & + oa4, clx + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%lsoil) :: & + smsoil, stsoil, slsoil + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & + del, rhc, dtdt, dudt, dvdt, gwdcu, gwdcv, dtdtc, rainp, & + ud_mf, dd_mf, dt_mf, prnum, dkt, flux_cg, flux_en, & + sigmatot, sigmafrac, specific_heat, final_dynamics_delp, dtdt_gwdps + + !--- GFDL modification for FV3 + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs+1) ::& + del_gz + +#ifdef fvGFS_2017 + real(kind=kind_phys), dimension(size(Grid%xlon,1),1,Model%levs) :: & + delp, dz, uin, vin, pt, qv1, ql1, qr1, qg1, qa1, qn1, qi1, & + qs1, pt_dt, qa_dt, udt, vdt, w, qv_dt, ql_dt, qr_dt, qi_dt, & + qs_dt, qg_dt + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & + phmid, th, tke, exner, exchh1, el1 ! for myj +#else + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs) :: & + delp, dz, uin, vin, pt, qv1, ql1, qr1, qg1, qa1, qnl1, qi1, & + qs1, pt_dt, udt, vdt, w, qv_dt, ql_dt, qr_dt, qi_dt, qni1, & + qs_dt, qg_dt, te, q_con, cappa, & + phmid, th, tke, exner, exchh1, el1 ! for myj +#endif + +! mg, sfc perts + real (kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + z01d, zt1d, bexp1d, xlai1d, alb1d, vegf1d + + real(kind=kind_phys), dimension(Model%levs) :: epsq2 ! myj + real(kind=kind_phys), dimension(Model%levs-1) :: epsL ! myj + + real(kind=kind_phys), dimension(size(Grid%xlon,1),1,Model%levs+1) ::& + phint ! myj + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%ntrac) :: & + dqdt + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,Model%nctp) :: & + sigmai, vverti + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levs,oz_coeff+5) :: & + dq3dt_loc + + real(kind=kind_phys), dimension(size(Grid%xlon,1),1) :: & ! for MYJ scheme + vegfrac, ht, tsfc1, qsfc1, ustar1, z01, pblh1, one, akms1, akhs1, cd1, cdq1, & + hflx1, evap1, rb1, cice1, csnow1, mixh1, u10m1, v10m1, T2m1, Q2m1, & + th2m1, tshelter1, th10m1, qshelter1, q10m1, pshelter1, thz01, qz01, uz01, vz01 + + integer(kind=8), dimension(size(Grid%xlon,1),1) :: & ! for myj + pblk1 + + logical, dimension(size(Grid%xlon,1),1) :: & ! for myj + flag_iter1 + + !--- ALLOCATABLE ELEMENTS + !--- in clw, the first two varaibles are cloud water and ice. + !--- from third to ntrac are convective transportable tracers, + !--- third being the ozone, when ntrac=3 (valid only with ras) + !--- Anning Cheng 9/21/2016 leave a hook here for diagnosed snow, + !--- rain, and their number + real(kind=kind_phys), allocatable :: & + clw(:,:,:), qpl(:,:), qpi(:,:), ncpl(:,:), ncpi(:,:), & + qrn(:,:), qsnw(:,:), ncpr(:,:), ncps(:,:), cnvc(:,:), & + cnvw(:,:) + !--- for 2 M microphysics + real(kind=kind_phys), allocatable, dimension(:) :: & + cn_prc, cn_snr + real(kind=kind_phys), allocatable, dimension(:,:) :: & + qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE + + integer, allocatable, dimension(:) :: clw_trac_idx + real(kind=kind_phys), allocatable, dimension(:,:,:) :: dt3dt_initial, dq3dt_initial + integer :: nwat +! +! +!===> ... begin here + + me = Model%me + ix = size(Grid%xlon,1) + im = size(Grid%xlon,1) + levs = Model%levs + ntrac = Model%ntrac + dtf = Model%dtf + dtp = Model%dtp + kdt = Model%kdt + lprnt = Model%lprnt +! lprnt = (me == 3) !root_pe) .and. (this_pe > 0 ) + nvdiff = ntrac ! vertical diffusion of all tracers! + ipr = min(im,10) + + do i = 1, im + if(nint(Sfcprop%slmsk(i)) == 1) then + frland(i) = 1.0 + dry(i) = .true. + else + frland(i) = 0. + dry(i) = .false. + endif + + z01d(i) = 0. + zt1d(i) = 0. + bexp1d(i) = 0. + xlai1d(i) = 0. + vegf1d(i) = 0. + + enddo + + if (Model%ldiag3d) then + allocate(dt3dt_initial(1:im,1:levs,9)) + allocate(dq3dt_initial(1:im,1:levs,9)) + dt3dt_initial = Diag%dt3dt + dq3dt_initial = Diag%dq3dt + endif + + ! perform aerosol convective transport and PBL diffusion + !trans_aero = Model%cplchm .and. Model%trans_trac + trans_aero = Model%trans_trac +! +! figure out number of extra tracers (other than hydrometeors and could amount) +! + + if (Model%ntiw > 0) then + if (Model%ntclamt > 0) then + nn = ntrac - 2 + else + nn = ntrac - 1 + endif + elseif (Model%ntcw > 0) then + nn = ntrac + else + nn = ntrac + 1 + endif + allocate (clw(ix,levs,nn)) + allocate( clw_trac_idx(nn-2) ) + + + + skip_macro = .false. + + + if (Model%imfdeepcnv >= 0 .or. Model%imfshalcnv > 0 .or. & + (Model%npdf3d == 3 .and. Model%num_p3d == 4) .or. & + (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) ) then + allocate (cnvc(ix,levs), cnvw(ix,levs)) + do k=1,levs + do i=1,im + cnvc(i,k) = 0. + cnvw(i,k) = 0. + enddo + enddo + + if (Model%npdf3d == 3 .and. Model%num_p3d == 4) then + num2 = Model%num_p3d + 2 + num3 = num2 + 1 + elseif (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) then + num2 = Model%num_p3d + 1 + endif + !CCPP: num2 = Model%ncnvw + !CCPP: num3 = Model%ncnvc + endif + +! +! --- set initial quantities for stochastic physics deltas + if (Model%do_sppt) then + Tbd%dtdtr = 0.0 + do i=1,im + Tbd%drain_cpl(i) = Coupling%rain_cpl (i) + Tbd%dsnow_cpl(i) = Coupling%snow_cpl (i) + enddo + endif + + if (Model%do_shoc) then + allocate (qpl(im,levs), qpi(im,levs), ncpl(im,levs), ncpi(im,levs)) + do k=1,levs + do i=1,im + ncpl(i,k) = 0.0 + ncpi(i,k) = 0.0 + enddo + enddo + endif + + if (Model%ncld == 2) then ! For MGB double moment microphysics + allocate (qlcn(im,levs), qicn(im,levs), w_upi(im,levs), & + cf_upi(im,levs), CNV_MFD(im,levs), CNV_PRC3(im,levs), & + CNV_DQLDT(im,levs), clcn(im,levs), cnv_fice(im,levs), & + cnv_ndrop(im,levs), cnv_nice(im,levs)) + allocate (cn_prc(im), cn_snr(im)) + allocate (qsnw(im,levs), ncpr(im,levs), ncps(im,levs)) + else + allocate (qlcn(1,1), qicn(1,1), w_upi(1,1), cf_upi(1,1), & + CNV_MFD(1,1), CNV_PRC3(1,1), CNV_DQLDT(1,1), & + clcn(1,1), cnv_fice(1,1), cnv_ndrop(1,1), cnv_nice(1,1)) + endif + allocate (qrn(im,levs)) + + +#ifdef GFS_HYDRO + call get_prs(im, ix, levs, ntrac, Statein%tgrs, Statein%qgrs, & + Model%thermodyn_id, Model%sfcpress_id, & + Model%gen_coord_hybrid, Statein%prsi, Statein%prsik, & + Statein%prsl, Statein%prslk, Statein%phii, Statein%phil, del) +#else +!GFDL Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization + call get_prs_fv3 (ix, levs, ntrac, Statein%phii, Statein%prsi, & + Statein%tgrs, Statein%qgrs, del, del_gz) +#endif +! + rhbbot = Model%crtrh(1) + rhpbl = Model%crtrh(2) + rhbtop = Model%crtrh(3) +! +! --- ... frain=factor for centered difference scheme correction of rain amount. + + frain = dtf / dtp + + do i= 1, im + if (Model%use_ext_sst .and. Statein%ci(i) > -1. .and. Statein%ci(i) < 2.) then !Avoid bad values + if (Statein%ci(i) >= 0.15 .and. nint(Sfcprop%slmsk(i)) == 0) then !create sea ice + Sfcprop%fice(i) = Statein%ci(i) + Sfcprop%slmsk(i) = 2 + Sfcprop%hice(i) = 0.1 !minimum value + elseif (nint(Sfcprop%slmsk(i)) == 2) then + if (Statein%ci(i) < 0.15) then !remove sea ice + Sfcprop%slmsk(i) = 0 + Sfcprop%fice(i) = 0.0 + Sfcprop%hice(i) = 0.0 + else + Sfcprop%fice(i) = Statein%ci(i) + endif + + endif + endif + enddo + + do i = 1, im + sigmaf(i) = max( Sfcprop%vfrac(i),0.01 ) + islmsk(i) = nint(Sfcprop%slmsk(i)) + + + if (islmsk(i) == 2) then + if (Model%isot == 1) then + soiltyp(i) = 16 + else + soiltyp(i) = 9 + endif + if (Model%ivegsrc == 1) then + vegtype(i) = 15 + elseif(Model%ivegsrc == 2) then + vegtype(i) = 13 + endif + slopetyp(i) = 9 + else + soiltyp(i) = int( Sfcprop%stype(i)+0.5 ) + vegtype(i) = int( Sfcprop%vtype(i)+0.5 ) + slopetyp(i) = int( Sfcprop%slope(i)+0.5 ) !! clu: slope -> slopetyp + endif +! --- ... xw: transfer ice thickness & concentration from global to local variables + zice(i) = Sfcprop%hice(i) + cice(i) = Sfcprop%fice(i) + tice(i) = Sfcprop%tisfc(i) +! +!GFDL work1(i) = (log(coslat(i) / (nlons(i)*latr)) - dxmin) * dxinv +!GFS Moorthi thinks this should be area and not dx +! work1(i) = (log(Grid%dx(i)) - dxmin) * dxinv + work1(i) = (log(Grid%area(i)) - dxmin) * dxinv + work1(i) = max(0.0, min(1.0,work1(i))) + work2(i) = 1.0 - work1(i) + Diag%psurf(i) = Statein%pgr(i) + work3(i) = Statein%prsik(i,1) / Statein%prslk(i,1) +!GFDL tem1 = con_rerth * (con_pi+con_pi)*coslat(i)/nlons(i) +!GFDL tem2 = con_rerth * con_pi / latr +!GFDL garea(i) = tem1 * tem2 + tem1 = Grid%dx(i) + tem2 = Grid%dx(i) + garea(i) = Grid%area(i) + dlength(i) = sqrt( tem1*tem1+tem2*tem2 ) + cldf(i) = Model%cgwf(1)*work1(i) + Model%cgwf(2)*work2(i) + wcbmax(i) = Model%cs_parm(1)*work1(i) + Model%cs_parm(2)*work2(i) + enddo +! + if (Model%cplflx) then + do i = 1, im + islmsk_cice(i) = nint(Coupling%slimskin_cpl(i)) + flag_cice(i) = (islmsk_cice(i) == 4) + + ulwsfc_cice(i) = Coupling%ulwsfcin_cpl(i) + dusfc_cice(i) = Coupling%dusfcin_cpl(i) + dvsfc_cice(i) = Coupling%dvsfcin_cpl(i) + dtsfc_cice(i) = Coupling%dtsfcin_cpl(i) + dqsfc_cice(i) = Coupling%dqsfcin_cpl(i) + tisfc_cice(i) = Sfcprop%tisfc(i) + tsea_cice(i) = Sfcprop%tsfc(i) + fice_cice(i) = Sfcprop%fice(i) + hice_cice(i) = Sfcprop%hice(i) + enddo + endif + +! --- ... transfer soil moisture and temperature from global to local variables + smsoil(:,:) = Sfcprop%smc(:,:) + stsoil(:,:) = Sfcprop%stc(:,:) + slsoil(:,:) = Sfcprop%slc(:,:) !! clu: slc -> slsoil + dudt(:,:) = 0. + dvdt(:,:) = 0. + dtdt(:,:) = 0. + dtdtc(:,:) = 0. + dqdt(:,:,:) = 0. + +! --- ... initialize dtdt with heating rate from dcyc2 + +! --- ... adjust mean radiation fluxes and heating rates to fit for +! faster model time steps. +! sw: using cos of zenith angle as scaling factor +! lw: using surface air skin temperature as scaling factor + + if (Model%pre_rad) then + call dcyc2t3_pre_rad & +! --- inputs: + ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & + Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & + Statein%tgrs(1,1), Statein%tgrs(1,1), Coupling%sfcdsw, & + Coupling%sfcnsw, Coupling%sfcdlw, Radtend%htrsw, Radtend%htrlw,& + Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & + Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & +! --- input/output: + dtdt, & +! --- outputs: + adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & + ) + + else + + call dcyc2t3 & +! --- inputs: + ( Model%solhr, Model%slag, Model%sdec, Model%cdec, Grid%sinlat, & + Grid%coslat, Grid%xlon, Radtend%coszen, Sfcprop%tsfc, & + Statein%tgrs(1,1), Radtend%tsflw, Radtend%semis, & + Coupling%sfcdsw, Coupling%sfcnsw, Coupling%sfcdlw, & + Radtend%htrsw, Radtend%swhc, Radtend%htrlw, Radtend%lwhc, & + Coupling%nirbmui, Coupling%nirdfui, Coupling%visbmui, & + Coupling%visdfui, Coupling%nirbmdi, Coupling%nirdfdi, & + Coupling%visbmdi, Coupling%visdfdi, ix, im, levs, & + Model%daily_mean, & +! --- input/output: + dtdt, dtdtc, & +! --- outputs: + adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd & + ) + +! +! save temp change due to radiation - need for sttp stochastic physics +!--------------------------------------------------------------------- + endif +! + if (Model%lsidea) then !idea jw + dtdt(:,:) = 0. + endif + +! --- convert lw fluxes for land/ocean/sea-ice models +! note: for sw: adjsfcdsw and adjsfcnsw are zenith angle adjusted downward/net fluxes. +! for lw: adjsfcdlw is (sfc temp adjusted) downward fluxe with no emiss effect. +! adjsfculw is (sfc temp adjusted) upward fluxe including emiss effect. +! one needs to be aware that that the absorbed downward lw flux (used by land/ocean +! models as downward flux) is not the same as adjsfcdlw but a value reduced by +! the factor of emissivity. however, the net effects are the same when seeing +! it either above the surface interface or below. +! +! - flux above the interface used by atmosphere model: +! down: adjsfcdlw; up: adjsfculw = sfcemis*sigma*T**4 + (1-sfcemis)*adjsfcdlw +! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) +! - flux below the interface used by lnd/oc/ice models: +! down: sfcemis*adjsfcdlw; up: sfcemis*sigma*T**4 +! net = up - down = sfcemis * (sigma*T**4 - adjsfcdlw) + +! --- ... define the downward lw flux absorbed by ground + + gabsbdlw(:) = Radtend%semis(:) * adjsfcdlw(:) + + if (Model%lssav) then ! --- ... accumulate/save output variables + +! --- ... sunshine duration time is defined as the length of time (in mdl output +! interval) that solar radiation falling on a plane perpendicular to the +! direction of the sun >= 120 w/m2 + + do i = 1, im + if ( xcosz(i) >= czmin ) then ! zenth angle > 89.994 deg + tem1 = adjsfcdsw(i) / xcosz(i) + if ( tem1 >= 120.0 ) then + Diag%suntim(i) = Diag%suntim(i) + dtf + endif + endif + enddo + +! --- ... sfc lw fluxes used by atmospheric model are saved for output + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) adjsfculw(i) = ulwsfc_cice(i) + enddo + endif + Diag%dlwsfc(:) = Diag%dlwsfc(:) + adjsfcdlw(:)*dtf + Diag%ulwsfc(:) = Diag%ulwsfc(:) + adjsfculw(:)*dtf + Diag%psmean(:) = Diag%psmean(:) + Statein%pgr(:)*dtf ! mean surface pressure + + if (Model%ldiag3d) then + if (Model%lsidea) then + Diag%dt3dt(:,:,1) = Diag%dt3dt(:,:,1) + Radtend%lwhd(:,:,1)*dtf + Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + Radtend%lwhd(:,:,2)*dtf + Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + Radtend%lwhd(:,:,3)*dtf + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + Radtend%lwhd(:,:,4)*dtf + Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + Radtend%lwhd(:,:,5)*dtf + Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + Radtend%lwhd(:,:,6)*dtf + else + do k = 1, levs + Diag%dt3dt(:,k,1) = Diag%dt3dt(:,k,1) + Radtend%htrlw(:,k)*dtf + Diag%dt3dt(:,k,2) = Diag%dt3dt(:,k,2) + Radtend%htrsw(:,k)*dtf*xmu(:) + Diag%dt3dt(:,k,8) = Diag%dt3dt(:,k,8) + Radtend%lwhc(:,k)*dtf + Diag%dt3dt(:,k,9) = Diag%dt3dt(:,k,9) + Radtend%swhc(:,k)*dtf*xmu(:) + enddo + endif + endif + endif ! end if_lssav_block + + kcnv(:) = 0 + kinver(:) = levs + invrsn(:) = .false. + tx1(:) = 0.0 + tx2(:) = 10.0 + ctei_r(:) = 10.0 + +! Only used for old shallow convection with mstrat=.true. + + if (((Model%imfshalcnv == 0 .and. Model%shal_cnv) .or. Model%old_monin) & + .and. Model%mstrat) then + ctei_rml(:) = Model%ctei_rm(1)*work1(:) + Model%ctei_rm(2)*work2(:) + do k = 1, levs/2 + do i = 1, im + if (Statein%prsi(i,1)-Statein%prsi(i,k+1) < 0.35*Statein%prsi(i,1) & + .and. (.not. invrsn(i))) then + tem = (Statein%tgrs(i,k+1)-Statein%tgrs(i,k)) / (Statein%prsl(i,k)-Statein%prsl(i,k+1)) + + if (((tem > 0.00010) .and. (tx1(i) < 0.0)) .or. & + ((tem-abs(tx1(i)) > 0.0) .and. (tx2(i) < 0.0))) then + invrsn(i) = .true. + + if (Statein%qgrs(i,k,1) > Statein%qgrs(i,k+1,1)) then + tem1 = Statein%tgrs(i,k+1) + hocp*max(Statein%qgrs(i,k+1,1),qmin) + tem2 = Statein%tgrs(i,k) + hocp*max(Statein%qgrs(i,k,1),qmin) + + tem1 = tem1 / Statein%prslk(i,k+1) - tem2 / Statein%prslk(i,k) + +! --- ... (cp/l)(deltathetae)/(deltatwater) > ctei_rm -> conditon for CTEI + ctei_r(i) = (1.0/hocp)*tem1/(Statein%qgrs(i,k+1,1)-Statein%qgrs(i,k,1) & + + Statein%qgrs(i,k+1,Model%ntcw)-Statein%qgrs(i,k,Model%ntcw)) + else + ctei_r(i) = 10 + endif + + if ( ctei_rml(i) > ctei_r(i) ) then + kinver(i) = k + else + kinver(i) = levs + endif + endif + + tx2(i) = tx1(i) + tx1(i) = tem + endif + enddo + enddo + endif + +! --- ... lu: initialize flag_guess, flag_iter, tsurf + + tsurf(:) = Sfcprop%tsfc(:) + flag_guess(:) = .false. + flag_iter(:) = .true. + drain(:) = 0.0 + ep1d(:) = 0.0 + runof(:) = 0.0 + hflx(:) = 0.0 + evap(:) = 0.0 + evbs(:) = 0.0 + evcw(:) = 0.0 + trans(:) = 0.0 + sbsno(:) = 0.0 + snowc(:) = 0.0 + snohf(:) = 0.0 + Diag%zlvl(:) = Statein%phil(:,1) * onebg + Diag%smcwlt2(:) = 0.0 + Diag%smcref2(:) = 0.0 + + + +! --- ... lu: iter-loop over (sfc_diff,sfc_drv,sfc_ocean,sfc_sice) + + do iter = 1, 2 + +! --- ... surface exchange coefficients +! +! if (lprnt) write(0,*)' tsea=',tsea(ipr),' tsurf=',tsurf(ipr),iter + +!!$ if ( Model%myj_pbl ) then +!!$ !Q2 needs to be saved between timesteps +!!$ !also new: thz0, qz0, uz0, vz0 +!!$ do i=1,im +!!$ ht(i,1) = Sfcprop%oro(i) ! new +!!$ tsfc1(i,1) = Sfcprop%tsfc(i) ! new +!!$ !Note that in the GFS driver, Qsfc is not yet computed. +!!$ ! however it IS used by J-sfc. Need to add qsfc as a +!!$ ! prognostic variable?? +!!$ ! Do **NOT** use q2m over ocean, which will result in tiny fluxes. +!!$ ! Instead use 0.98% RH at lower boundary. +!!$ if (frland(i) < 0.5) then +!!$ qsfc1(i,1) = estblf(tsfc1(i,1))*0.98 ! returns vapor pressure +!!$ qsfc1(i,1) = qsfc1(i,1) / ( con_eps*Statein%prsi(i,1) - qsfc1(i,1)*(con_eps+1.) ) +!!$ else +!!$ qsfc1(i,1) = Sfcprop%q2m(i) +!!$ ! convert moisture to specific humidity. +!!$ qsfc1(i,1) = qsfc1(i,1) / (1. - qsfc1(i,1)) +!!$ endif +!!$ +!!$ !!!****ALSO**** does MYJ want SPECIFIC HUMIDITY or MIXING RATIO?? +!!$ +!!$ thz01(i,1) = Sfcprop%thz0(i) +!!$ qz01(i,1) = Sfcprop%qz0(i) +!!$ uz01(i,1) = Sfcprop%uz0(i) +!!$ vz01(i,1) = Sfcprop%vz0(i) +!!$ +!!$ land(i,1) = 2. - frland(i) ! in NAM & WRF 2 = water, 1 = land :-( +!!$ vegfrac(i,1) = Sfcprop%vfrac(i) ! new +!!$ ustar1(i,1) = Sfcprop%uustar(i) ! new +!!$ z01(i,1) = Sfcprop%zorl(i)*.01 ! convert cm --> m +!!$ pblh1(i,1) = Diag%hpbl(i) !new +!!$ one(i,1) = 1. ! new +!!$ cd1(i,1) = cd(i) ! new +!!$ cdq1(i,1) = cdq(i) !new +!!$ hflx1(i,1) = hflx(i) !new; units are M/m2 +!!$ evap1(i,1) = evap(i) ! new +!!$ rb1(i,1) = rb(i) ! new +!!$ flag_iter1(i,1) = flag_iter(i) +!!$ enddo +!!$ +!!$ do k = 1, levs +!!$ kflip = levs-k+1 +!!$ do i=1,im +!!$ +!!$ dz (i,1,k) = (Statein%phii(i,kflip+1)-Statein%phii(i,kflip))/con_g +!!$ phmid(i,1,k) = Statein%prsl(i,kflip) ! new +!!$ phint(i,1,k) = Statein%prsi(i,kflip+1) ! new +!!$ th (i,1,k) = Statein%tgrs(i,kflip)/Statein%prslk(i,kflip) ! new +!!$ pt (i,1,k) = Statein%tgrs(i,kflip) +!!$ qv1 (i,1,k) = Statein%qgrs(i,kflip,1 ) +!!$ ql1 (i,1,k) = Statein%qgrs(i,kflip,Model%ntcw) +!!$ uin (i,1,k) = Statein%ugrs(i,kflip) +!!$ vin (i,1,k) = Statein%vgrs(i,kflip) +!!$ tke (i,1,k) = Statein%qgrs(i,kflip,Model%ntke) +!!$ +!!$ end do +!!$ enddo +!!$ phint(:,1,levs+1) = Statein%prsi(:,1) ! new +!!$ !Need to set up the z01 variables on the first timestep +!!$ if (thz01(i,1) > 10.) then +!!$ ntsd=1 +!!$ else +!!$ ntsd=0 +!!$ endif +!!$ +!!$ !Discarded arguments: SNOWC, Z0BASE ("background" z0), RMOL, CHS2, CQS2, QFX +!!$ ! FLHC, FLQC, *SHLTR +!!$ !New arguments: stress, wind, flag_iter, CQS +!!$ ! see how NAM computes wind in module_BL_GFSPBL.F90 +!!$ !Outputs: FLX_LH, HFX, AKHS, AKMS, PBLH, RIB, *Z0, CHS, CQS, USTAR, U10, V10, T2, Q2 +!!$ !Want to include improved z0 estimate over ocean +!!$ !also want to compute epsQ2 here +!!$ call myj_jsfc(NTSD=ntsd,EPSL=epsL,EPSQ2=epsQ2,HT=ht,DZ=dz & +!!$ ,PHMID=phmid,PHINT=phint,TH=th,T=pt & +!!$ ,Q=qv1,QC=ql1,U=uin,V=vin,Q2=tke & +!!$ ,TSK=tsfc1,QSFC=qsfc1 & +!!$ ,THZ0=thz01,QZ0=qz01,UZ0=uz01,VZ0=vz01 & +!!$ ,XLAND=land & +!!$ ,VEGFRC=vegfrac & +!!$ ,USTAR=ustar1,Z0=z01,PBLH=pblh1,MAVAIL=one & +!!$ ,AKHS=akhs1,AKMS=akms1 & +!!$ ,CHS=cd1,CQS=cdq1,HFX=hflx1,FLX_LH=evap1 & +!!$ ,U10=u10m1,V10=v10m1,T02=t2m1,TH02=th2m1 & +!!$ ,TSHLTR=tshelter1,TH10=th10m1 & +!!$ ,Q02=q2m1,QSHLTR=qshelter1,Q10=q10m1 & +!!$ ,PSHLTR=pshelter1,RIB=rb1,FLAG_ITER=flag_iter1 & +!!$ ,ITER=iter,REDRAG=Model%redrag,lprnt=lprnt & +!!$ ,IDS=1,IDE=im,JDS=1,JDE=1,KDS=1,KDE=levs & +!!$ ,IMS=1,IME=im,JMS=1,JME=1,KMS=1,KME=levs & +!!$ ,ITS=1,ITE=im,JTS=1,JTE=1,KTS=1,LM=levs) + + + !Restore values +!!$ do i=1,im +!!$ hflx(i) = hflx1(i,1) ! Don't use jsfc's fluxes?? +!!$ evap(i) = evap1(i,1) !NOTE: would want to convert from W/m**2 (in MYJ) to kg/m**2/s (in GFS) +!!$ sfcprop%uustar(i) = ustar1(i,1) +!!$ Sfcprop%ffmm(i) = ustar1(i,1)*0.4/akms1(i,1) ! 0.4 is Von Karman's constant +!!$ Sfcprop%ffhh(i) = ustar1(i,1)*0.4/akhs1(i,1) +!!$ Diag%hpbl(i) = pblh1(i,1) +!!$ rb(i) = rb1(i,1) +!!$ cd(i) = cd1(i,1) +!!$ cdq(i) = cdq1(i,1) +!!$ stress(i) = cd1(i,1)*ustar1(i,1)*ustar1(i,1) +!!$ if (flag_iter1(i,1)) then +!!$ wind(i) = max(sqrt(uin(i,1,1)*uin(i,1,1) + vin(i,1,1)*vin(i,1,1)) & +!!$ + max(0.0, min(Tbd%phy_f2d(i,Model%num_p2d), 30.0)), 1.0) ! The Tbd%quantity appears to be zero +!!$ endif +!!$ Diag%u10m(i) = u10m1(i,1) +!!$ Diag%v10m(i) = v10m1(i,1) +!!$ Sfcprop%t2m(i) = T2m1(i,1) +!!$ Sfcprop%q2m(i) = Q2m1(i,1) + +!!$ Sfcprop%thz0(i) = thz01(i,1) +!!$ Sfcprop%qz0(i) = qz01(i,1) +!!$ Sfcprop%uz0(i) = uz01(i,1) +!!$ Sfcprop%vz0(i) = vz01(i,1) + +!!$ enddo + + !else +!!$ endif + + if (Model%sfc_gfdl) then +! a new and more flexible version of sfc_diff by kgao + call sfc_diff_gfdl(im,Statein%pgr, Statein%ugrs, Statein%vgrs,& + Statein%tgrs, Statein%qgrs, Diag%zlvl, Sfcprop%snowd, & + Sfcprop%tsfc, Sfcprop%zorl, Sfcprop%ztrl, cd, & + cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & + wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & + sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & + tsurf, flag_iter, Model%redrag, Model%z0s_max, & + Model%do_z0_moon, Model%do_z0_hwrf15, & + Model%do_z0_hwrf17, Model%do_z0_hwrf17_hwonly, & + Model%wind_th_hwrf) + else +! GFS original sfc_diff modified by kgao + call sfc_diff (im,Statein%pgr, Statein%ugrs, Statein%vgrs,& + Statein%tgrs, Statein%qgrs, Diag%zlvl, & + Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%zorl, cd, & + cdq, rb, Statein%prsl(1,1), work3, islmsk, stress, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%uustar, & + wind, Tbd%phy_f2d(1,Model%num_p2d), fm10, fh2, & + sigmaf, vegtype, Sfcprop%shdmax, Model%ivegsrc, & + tsurf, flag_iter, Model%redrag, Model%czil_sfc, & + Model%z0s_max, & + Model%do_z0_moon, Model%do_z0_hwrf15, & + Model%do_z0_hwrf17, Model%do_z0_hwrf17_hwonly, & + Model%wind_th_hwrf) + endif + !endif + + !endif + +! --- ... lu: update flag_guess + + do i = 1, im + if (iter == 1 .and. wind(i) < 2.0) then + flag_guess(i) = .true. + endif + enddo + + if (Model%nstf_name(1) > 0) then + + do i = 1, im + if ( islmsk(i) == 0 ) then + tem = (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse + tseal(i) = Sfcprop%tsfc(i) + tem + tsurf(i) = tsurf(i) + tem + endif + enddo + + call sfc_nst (im, Model%lsoil, Statein%pgr, Statein%ugrs, & + Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Sfcprop%tref, cd, cdq, Statein%prsl(1,1), work3, & + islmsk, Grid%xlon, Grid%sinlat, stress, & + Radtend%semis, gabsbdlw, adjsfcnsw, Sfcprop%tprcp, & + dtf, kdt, Model%solhr, xcosz, & + Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & + flag_guess, Model%nstf_name, lprnt, ipr, & +! --- Input/output + tseal, tsurf, Sfcprop%xt, Sfcprop%xs, Sfcprop%xu, & + Sfcprop%xv, Sfcprop%xz, Sfcprop%zm, Sfcprop%xtts, & + Sfcprop%xzts, Sfcprop%dt_cool, Sfcprop%z_c, & + Sfcprop%c_0, Sfcprop%c_d, Sfcprop%w_0, Sfcprop%w_d,& + Sfcprop%d_conv, Sfcprop%ifd, Sfcprop%qrain, & +! --- outputs: + qss, gflx, Diag%cmm, Diag%chh, evap, hflx, ep1d) + +! if (lprnt) print *,' tseaz2=',tseal(ipr),' tref=',tref(ipr), +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',2.0*xt(ipr)/xz(ipr), +! & ' kdt=',kdt + + do i = 1, im + if ( islmsk(i) == 0 ) then + tsurf(i) = tsurf(i) - (Sfcprop%oro(i)-Sfcprop%oro_uf(i)) * rlapse + endif + enddo + +! --- ... run nsst model ... --- + + if (Model%nstf_name(1) > 1) then + zsea1 = 0.001*real(Model%nstf_name(4)) + zsea2 = 0.001*real(Model%nstf_name(5)) + call get_dtzm_2d (Sfcprop%xt, Sfcprop%xz, Sfcprop%dt_cool, & + Sfcprop%z_c, Sfcprop%slmsk, zsea1, zsea2, & + im, 1, dtzm) + do i = 1, im + if ( islmsk(i) == 0 ) then + Sfcprop%tsfc(i) = max(271.2,Sfcprop%tref(i) + dtzm(i)) - & + (Sfcprop%oro(i)-Sfcprop%oro_uf(i))*rlapse + endif + enddo + endif + +! if (lprnt) print *,' tseaz2=',tsea(ipr),' tref=',tref(ipr), & +! & ' dt_cool=',dt_cool(ipr),' dt_warm=',dt_warm(ipr),' kdt=',kdt + + else + +! --- ... surface energy balance over ocean + + call sfc_ocean & +! --- inputs: + (im, Statein%pgr, Statein%ugrs, Statein%vgrs, Statein%tgrs, & + Statein%qgrs, Sfcprop%tsfc, cd, cdq, Statein%prsl(1,1), & + work3, islmsk, Tbd%phy_f2d(1,Model%num_p2d), flag_iter, & +! --- outputs: + qss, Diag%cmm, Diag%chh, gflx, evap, hflx, ep1d) + + endif ! if ( nstf_name(1) > 0 ) then + +! if (lprnt) write(0,*)' sfalb=',sfalb(ipr),' ipr=',ipr & +! &, ' weasd=',weasd(ipr),' snwdph=',snwdph(ipr) & +! &, ' tprcp=',tprcp(ipr),' kdt=',kdt,' iter=',iter & +! &,' tseabefland=',tsea(ipr) + +! --- ... surface energy balance over land +! + if (Model%lsm == Model%lsm_noah) then ! noah lsm call + +! if (lprnt) write(0,*)' tsead=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! &,' pgr=',pgr(ipr),' sfcemis=',sfcemis(ipr) + + call sfc_drv & +! --- inputs: + (im, Model%lsoil, Statein%pgr, & + Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & + Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & + Sfcprop%tg3, cd, cdq, Statein%prsl(:,1), work3, Diag%zlvl, & + dry, wind, slopetyp, & + Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & + Radtend%sfalb, flag_iter, flag_guess, & + Model%lheatstrg, Model%isot, Model%ivegsrc, & + bexp1d, xlai1d, vegf1d, Model%pertvegf, & +! --- in/outs: + Sfcprop%weasd, Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%tprcp, & + Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & + trans, tsurf, Sfcprop%zorl, & +! --- outputs: + Sfcprop%sncovr, qss, gflx, drain, evap, hflx, ep1d, runof, & + Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & + snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1) + +! if (lprnt) write(0,*)' tseae=',tsea(ipr),' tsurf=',tsurf(ipr),iter +! &,' phy_f2d=',phy_f2d(ipr,num_p2d) + elseif (Model%lsm == Model%lsm_noahmp) then ! noah mp call + call noahmpdrv & +! --- inputs: + (im, Model%lsoil, kdt, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, soiltyp, vegtype, sigmaf, & + Radtend%semis, gabsbdlw, adjsfcdsw, adjsfcnsw, dtf, & + Sfcprop%tg3, cd, cdq, Statein%prsl(:,1), work3, & + Diag%zlvl, dry, wind, slopetyp, & + Sfcprop%shdmin, Sfcprop%shdmax, Sfcprop%snoalb, & + Radtend%sfalb, flag_iter, flag_guess, & + Model%iopt_dveg, Model%iopt_crs, Model%iopt_btr, & + Model%iopt_run, Model%iopt_sfc, Model%iopt_frz, & + Model%iopt_inf, Model%iopt_rad, Model%iopt_alb, & + Model%iopt_snf, Model%iopt_tbot, Model%iopt_stc, & + grid%xlat, xcosz, Model%yearlen, Model%julian, Model%imn,& + Sfcprop%drainncprv, Sfcprop%draincprv, Sfcprop%dsnowprv, & + Sfcprop%dgraupelprv, Sfcprop%diceprv, & +! --- in/outs: + Sfcprop%weasd, Sfcprop%snowd, Sfcprop%tsfc, Sfcprop%tprcp, & + Sfcprop%srflag, smsoil, stsoil, slsoil, Sfcprop%canopy, & + trans, tsurf, Sfcprop%zorl, & +! + Sfcprop%snowxy, Sfcprop%tvxy, Sfcprop%tgxy, Sfcprop%canicexy, & + Sfcprop%canliqxy, Sfcprop%eahxy, Sfcprop%tahxy, Sfcprop%cmxy, & + Sfcprop%chxy, Sfcprop%fwetxy, Sfcprop%sneqvoxy, & + Sfcprop%alboldxy, Sfcprop%qsnowxy, Sfcprop%wslakexy, & + Sfcprop%zwtxy, Sfcprop%waxy, Sfcprop%wtxy, Sfcprop%tsnoxy, & + Sfcprop%zsnsoxy, Sfcprop%snicexy, Sfcprop%snliqxy, & + Sfcprop%lfmassxy, Sfcprop%rtmassxy, & + Sfcprop%stmassxy, Sfcprop%woodxy, Sfcprop%stblcpxy, & + Sfcprop%fastcpxy, Sfcprop%xlaixy, Sfcprop%xsaixy, & + Sfcprop%taussxy, Sfcprop%smoiseq, Sfcprop%smcwtdxy, & + Sfcprop%deeprechxy, Sfcprop%rechxy, & +! --- outputs: + Sfcprop%sncovr, qss, gflx, drain, evap, hflx, ep1d, runof, & + Diag%cmm, Diag%chh, evbs, evcw, sbsno, snowc, Diag%soilm, & + snohf, Diag%smcwlt2, Diag%smcref2, Diag%wet1, t2mmp, q2mp) + + endif + +! if (lprnt) write(0,*)' tseabeficemodel =',tsea(ipr),' me=',me & +! &, ' kdt=',kdt + +! --- ... surface energy balance over seaice + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + islmsk (i) = islmsk_cice(i) + endif + enddo + endif + + call sfc_sice & +! --- inputs: + (im, Model%lsoil, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, dtf, Radtend%semis, gabsbdlw, & + adjsfcnsw, adjsfcdsw, Sfcprop%srflag, cd, cdq, & + Statein%prsl(1,1), work3, islmsk, & + Tbd%phy_f2d(1,Model%num_p2d), flag_iter, Model%mom4ice, & + Model%lsm, lprnt, ipr, & +! --- input/outputs: + zice, cice, tice, Sfcprop%weasd, Sfcprop%tsfc, & + Sfcprop%tprcp, stsoil, ep1d, & +! --- outputs: + Sfcprop%snowd, qss, snowmt, gflx, Diag%cmm, Diag%chh, evap, & + hflx) + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + islmsk(i) = nint(Sfcprop%slmsk(i)) + endif + enddo + + call sfc_cice & +! --- inputs: + (im, Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + cd, cdq, Statein%prsl(1,1), work3, islmsk_cice, & + Tbd%phy_f2d(1,Model%num_p2d),flag_iter, dqsfc_cice, & + dtsfc_cice, & +! --- outputs: + qss, Diag%cmm, Diag%chh, evap, hflx) + endif + +! --- ... lu: update flag_iter and flag_guess + + do i = 1, im + flag_iter(i) = .false. + flag_guess(i) = .false. + + if (iter == 1 .and. wind(i) < 2.0) then + if ((islmsk(i) == 1) .or. ((islmsk(i) == 0) .and. & + (Model%nstf_name(1) > 0))) then + flag_iter(i) = .true. + endif + endif + +! if(islmsk(i) == 1 .and. iter == 1) then +! if (wind(i) < 2.0) flag_iter(i) = .true. +! elseif (islmsk(i) == 0 .and. iter == 1 & +! & .and. nstf_name(1) > 0) then +! if (wind(i) < 2.0) flag_iter(i) = .true. +! endif + enddo + + enddo ! end iter_loop + + Diag%epi(:) = ep1d(:) + Diag%dlwsfci(:) = adjsfcdlw(:) + Diag%ulwsfci(:) = adjsfculw(:) + Diag%uswsfci(:) = adjsfcdsw(:) - adjsfcnsw(:) + Diag%dswsfci(:) = adjsfcdsw(:) + Diag%gfluxi(:) = gflx(:) + Diag%t1(:) = Statein%tgrs(:,1) + Diag%q1(:) = Statein%qgrs(:,1,1) + Diag%u1(:) = Statein%ugrs(:,1) + Diag%v1(:) = Statein%vgrs(:,1) + Sfcprop%qsfc(:) = qss(:) + +! --- ... update near surface fields + + !if (.not. Model%myj_pbl) then + call sfc_diag (im, Statein%pgr, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, Sfcprop%tsfc, qss, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, & + Sfcprop%t2m, Sfcprop%q2m, work3, evap, & + Sfcprop%ffmm, Sfcprop%ffhh, fm10, fh2) + !endif + + Tbd%phy_f2d(:,Model%num_p2d) = 0.0 + + if (Model%lsm == Model%lsm_noahmp) then + do i=1,im + if (dry(i)) then + Sfcprop%t2m(i) = t2mmp(i) + Sfcprop%q2m(i) = q2mp(i) + endif + enddo + endif + + + if (Model%cplflx) then + Coupling%dlwsfci_cpl (:) = adjsfcdlw(:) + Coupling%dswsfci_cpl (:) = adjsfcdsw(:) + Coupling%dlwsfc_cpl (:) = Coupling%dlwsfc_cpl(:) + adjsfcdlw(:)*dtf + Coupling%dswsfc_cpl (:) = Coupling%dswsfc_cpl(:) + adjsfcdsw(:)*dtf + Coupling%dnirbmi_cpl (:) = adjnirbmd(:) + Coupling%dnirdfi_cpl (:) = adjnirdfd(:) + Coupling%dvisbmi_cpl (:) = adjvisbmd(:) + Coupling%dvisdfi_cpl (:) = adjvisdfd(:) + Coupling%dnirbm_cpl (:) = Coupling%dnirbm_cpl(:) + adjnirbmd(:)*dtf + Coupling%dnirdf_cpl (:) = Coupling%dnirdf_cpl(:) + adjnirdfd(:)*dtf + Coupling%dvisbm_cpl (:) = Coupling%dvisbm_cpl(:) + adjvisbmd(:)*dtf + Coupling%dvisdf_cpl (:) = Coupling%dvisdf_cpl(:) + adjvisdfd(:)*dtf + Coupling%nlwsfci_cpl (:) = adjsfcdlw(:) - adjsfculw(:) + Coupling%nlwsfc_cpl (:) = Coupling%nlwsfc_cpl(:) + Coupling%nlwsfci_cpl(:)*dtf + Coupling%t2mi_cpl (:) = Sfcprop%t2m(:) + Coupling%q2mi_cpl (:) = Sfcprop%q2m(:) + Coupling%u10mi_cpl (:) = Diag%u10m(:) + Coupling%v10mi_cpl (:) = Diag%v10m(:) + Coupling%tsfci_cpl (:) = Sfcprop%tsfc(:) + Coupling%psurfi_cpl (:) = Statein%pgr(:) + +! --- estimate mean albedo for ocean point without ice cover and apply +! them to net SW heat fluxes + + do i = 1, im + if (islmsk(i) /= 1) then ! not a land point +! --- compute open water albedo + xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) + ocalnirdf_cpl(i) = 0.06 + ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & + & + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & + & * (xcosz_loc-1.0)) + ocalvisdf_cpl(i) = 0.06 + ocalvisbm_cpl(i) = ocalnirbm_cpl(i) + + Coupling%nnirbmi_cpl(i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i) + Coupling%nnirdfi_cpl(i) = adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i) + Coupling%nvisbmi_cpl(i) = adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i) + Coupling%nvisdfi_cpl(i) = adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i) + else + Coupling%nnirbmi_cpl(i) = adjnirbmd(i) - adjnirbmu(i) + Coupling%nnirdfi_cpl(i) = adjnirdfd(i) - adjnirdfu(i) + Coupling%nvisbmi_cpl(i) = adjvisbmd(i) - adjvisbmu(i) + Coupling%nvisdfi_cpl(i) = adjvisdfd(i) - adjvisdfu(i) + endif + Coupling%nswsfci_cpl(i) = Coupling%nnirbmi_cpl(i) + Coupling%nnirdfi_cpl(i) + & + Coupling%nvisbmi_cpl(i) + Coupling%nvisdfi_cpl(i) + Coupling%nswsfc_cpl(i) = Coupling%nswsfc_cpl(i) + Coupling%nswsfci_cpl(i)*dtf + Coupling%nnirbm_cpl(i) = Coupling%nnirbm_cpl(i) + Coupling%nnirbmi_cpl(i)*dtf + Coupling%nnirdf_cpl(i) = Coupling%nnirdf_cpl(i) + Coupling%nnirdfi_cpl(i)*dtf + Coupling%nvisbm_cpl(i) = Coupling%nvisbm_cpl(i) + Coupling%nvisbmi_cpl(i)*dtf + Coupling%nvisdf_cpl(i) = Coupling%nvisdf_cpl(i) + Coupling%nvisdfi_cpl(i)*dtf + enddo + endif + + if (Model%lssav) then + Diag%gflux(:) = Diag%gflux(:) + gflx(:) * dtf + Diag%evbsa(:) = Diag%evbsa(:) + evbs(:) * dtf + Diag%evcwa(:) = Diag%evcwa(:) + evcw(:) * dtf + Diag%transa(:) = Diag%transa(:) + trans(:) * dtf + Diag%sbsnoa(:) = Diag%sbsnoa(:) + sbsno(:) * dtf + Diag%snowca(:) = Diag%snowca(:) + snowc(:) * dtf + Diag%snohfa(:) = Diag%snohfa(:) + snohf(:) * dtf + Diag%ep(:) = Diag%ep(:) + ep1d(:) * dtf + + Diag%tmpmax(:) = max(Diag%tmpmax(:),Sfcprop%t2m(:)) + Diag%tmpmin(:) = min(Diag%tmpmin(:),Sfcprop%t2m(:)) + + Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) + Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + + do i=1, im + !find max wind speed then decompose + tem = sqrt(Diag%u10m(i)**2 + Diag%v10m(i)**2 ) + if (tem > Diag%wind10mmax(i)) then + Diag%wind10mmax(i) = tem + Diag%u10mmax(i) = Diag%u10m(i) + Diag%v10mmax(i) = Diag%v10m(i) + endif + + !Compute dew point, first using vapor pressure + tem = max(Statein%pgr(i) * Sfcprop%q2m(i) / ( con_eps - con_epsm1 * Sfcprop%q2m(i)), 1.e-8) + Diag%dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + enddo + + + + endif + +!!!!!!!!!!!!!!!!!Commented by Moorthi on July 18, 2012 !!!!!!!!!!!!!!!!!!! +! do i = 1, im +! --- ... compute coefficient of evaporation in evapc +! +! if (evapc(i) > 1.0e0) evapc(i) = 1.0e0 +! --- ... over snow cover or ice or sea, coef of evap =1.0e0 +! if (weasd(i) > 0.0 .or. slmsk(i) /= 1.0) evapc(i) = 1.0e0 +! enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! --- ... Boundary Layer and Free atmospheic turbulence parameterization + +! if (lprnt) write(0,*)' tsea3=',tsea(ipr),' slmsk=',slmsk(ipr) & +! &, ' kdt=',kdt,' evap=',evap(ipr) +! if (lprnt) write(0,*)' dtdtb=',(dtdt(ipr,k),k=1,15) + +! do i = 1, im +! if (islmsk(i) == 0) then +! oro_land(i) = 0.0 +! else +! oro_land(i) = oro(i) +! endif +! enddo + +! write(0,*)' before monin clstp=',clstp,' kdt=',kdt,' lat=',lat + + dusfc1(:) = 0. + dvsfc1(:) = 0. + dtsfc1(:) = 0. + dqsfc1(:) = 0. + + if (Model%do_shoc) then + call moninshoc(ix, im, levs, ntrac, Model%ntcw, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), prnum, Model%ntke, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, & + Diag%v10m, Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx,& + evap, stress, wind, kpbl, Statein%prsi, del, Statein%prsl,& + Statein%prslk, Statein%phii, Statein%phil, dtp, dusfc1, & + dvsfc1, dtsfc1, dqsfc1, dkt, Diag%hpbl, kinver, & + Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, lprnt, ipr, me) + elseif ( Model%no_pbl ) then + + !Dummy PBL routine to deposit tendencies into first layer?? + !Fluxes already have layer 1 density divided out (as per sfc_drv.f) + ! as well as the appropriate proportionality constants + rdt = 1./dtp + do i=1,im + Diag%hpbl(i) = ( Statein%phil(i,2) - Statein%phil(i,1) ) * onebg + kpbl(i) = 1 + tem2 = con_g / ( Statein%phil(i,2) - Statein%phil(i,1) ) + !heat + dtdt(i,1) = dtdt(i,1) + hflx(i) * tem2 + dtsfc1(i) = dtsfc1(i) + hflx(i) * cont * tem2 * del(i,1) + !moisture + dqdt(i,1,1) = dqdt(i,1,1) + evap(i) * tem2 + dqsfc1(i) = dqsfc1(i) + evap(i) * conq * tem2 * del(i,1) + !if (i == 1) then + ! print*, 'no_pbl: ', hflx(i), cont, del(i,1), Diag%hpbl(i) + !endif + !momentum ---- not yet right + tem1 = stress(i) / max(wind(i),1.e-2) + tem1 = tem1 * dtp * tem2 + tem1 = 1. / ( 1. + tem1) - 1. + tem1 = tem1 * rdt + dudt(i,1) = dudt(i,1) + Statein%ugrs(i,1) * tem1 + dusfc1(i) = dusfc1(i) + Statein%ugrs(i,1) * tem1 * conw * del(i,1) + dvdt(i,1) = dvdt(i,1) + Statein%vgrs(i,1) * tem1 + dvsfc1(i) = dvsfc1(i) + Statein%vgrs(i,1) * tem1 * conw * del(i,1) + enddo + + else + if (Model%hybedmf) then + call moninedmf(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt,& + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), & + rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, Sfcprop%ffmm, & + Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap, stress, & + wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl,& + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr, & + Model%xkzminv, Model%moninq_fac) +! if (lprnt) write(0,*)' dtdtm=',(dtdt(ipr,k),k=1,15) +! if (lprnt) write(0,*)' dqdtm=',(dqdt(ipr,k,1),k=1,15) + + elseif (Model%satmedmf) then + + if (Model%isatmedmf == 0) then + ! initial version of satmedmfvdif (Nov 2018) modified by kgao + call satmedmfvdif(ix, im, levs, nvdiff, & + Model%ntcw, Model%ntiw, Model%ntke, & + dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, garea, islmsk, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx, evap, & + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_ml, Model%xkzm_hl, Model%xkzm_mi, Model%xkzm_hi, & + Model%xkzm_s, Model%xkzminv, Model%do_dk_hb19, & + Model%xkzm_lim, Model%xkgdx, & + Model%rlmn, Model%rlmx, Model%cap_k0_land, dkt) + + elseif (Model%isatmedmf == 1) then + do i=1,im + if (islmsk(i) == 1) then + z0fun = min(max((Sfcprop%zorl(i)*0.01-0.1)/0.9, 0.0), 1.0) ! jih jul2020: (z0fun=0.~1.0) + zvfun(i) = sqrt( max(sigmaf(i), 0.1) * z0fun ) !jih jul2020: over land, zvfun=0 over ocean + else + zvfun(i) = 0. + endif + enddo + ! updated version of satmedmfvdif (May 2019) modified by kgao + call satmedmfvdifq(ix, im, levs, nvdiff, & + Model%ntcw, Model%ntiw, Model%ntke, & + dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, garea, zvfun, islmsk, & + Statein%prsik(1,1), rb, Sfcprop%zorl, Diag%u10m, Diag%v10m, & + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, hflx, evap, & + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_ml, Model%xkzm_hl, Model%xkzm_mi, Model%xkzm_hi, & + Model%xkzm_s, Model%xkzminv, Model%rlmx, Model%zolcru, & + Model%cs0, Model%do_dk_hb19, Model%xkgdx, & + Model%dspfac, Model%bl_upfr, Model%bl_dnfr, dkt, & + flux_cg, flux_en) !cg as up and en as down + endif + + elseif (Model%ysupbl) then + call ysupbl(ix, im, levs, nvdiff, Model%ntcw, Model%ntiw, & + dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Statein%prsi, Statein%prsl, Statein%prslk, & + Statein%phii, Statein%pgr, & + Radtend%htrsw, Radtend%htrlw, xmu, & + Sfcprop%zorl, Sfcprop%uustar, Diag%hpbl, & + Diag%hgamt, Diag%hfxpbl, & + Sfcprop%ffmm, Sfcprop%ffhh, & + islmsk, hflx, evap, wind, rb, & + dusfc1, dvsfc1, dtsfc1, dqsfc1, & + dtp, kpbl, Diag%u10m, Diag%v10m, & + kinver, & + Model%xkzm_m, Model%xkzm_h, Model%xkzm_s, Model%xkzminv, & + Model%dspheat, Model%ysu_ent_fac, dkt, & + flux_cg, flux_en, & + Model%ysu_pfac_q, & + Model%ysu_brcr_ub, Model%ysu_rlam, Model%ysu_afac, & + Model%ysu_bfac, Model%ysu_hpbl_cr, & + Model%tnl_fac, Model%qnl_fac, Model%unl_fac) + + elseif ( Model%myj_pbl) then + +#ifndef fvGFS_2017 + do i=1,im + land(i) = 2. - frland(i) ! see note above + vegfrac(i,1) = Sfcprop%vfrac(i) + ht(i,1) = Sfcprop%oro(i) + tsfc1(i,1) = Sfcprop%tsfc(i) + qsfc1(i,1) = 0. !not used by MYJ !qss(i) ! this is actually q sfc after calling sfc_drv ! + ustar1(i,1) = Sfcprop%uustar(i) + z01(i,1) = Sfcprop%zorl(i)*0.01 ! convert cm --> m + pblh1(i,1) = Diag%hpbl(i) + one(i,1) = 1. + akms1(i,1) = ustar1(i,1)*0.4/Sfcprop%ffmm(i) + akhs1(i,1) = ustar1(i,1)*0.4/Sfcprop%ffhh(i) ! 0.4 is Von Karman's constant in NAM + hflx1(i,1) = hflx(i) !Not used by myj?!? + !den = phmid(i,1,levs)/(con_rd*pt(i,1,levs)*(1. + con_epsm1 * Statein%qgrs(i,levs,1) ) ) + evap1(i,1) = evap(i) + rb1(i,1) = rb(i) + + cice1(i,1) = Sfcprop%fice(i) ! new + csnow1(i,1) = snowc(i) ! new + mixh1(i,1) = 0. ! new; purely diagnostic + + thz01(i,1) = Sfcprop%thz0(i) + qz01(i,1) = Sfcprop%qz0(i) + uz01(i,1) = Sfcprop%uz0(i) + vz01(i,1) = Sfcprop%vz0(i) + enddo + + do k = 1, levs + kflip = levs-k+1 + do i=1,im + + phmid(i,k) = Statein%prsl(i,kflip) + phint(i,1,k) = Statein%prsi(i,kflip+1) + qv1 (i,k) = Statein%qgrs(i,kflip,1 )/ (1. - Statein%qgrs(i,kflip,1 )) + ql1 (i,k) = Statein%qgrs(i,kflip,Model%ntcw) + pt (i,k) = Statein%tgrs(i,kflip) + th (i,k) = Statein%tgrs(i,kflip)/Statein%prslk(i,kflip) + uin (i,k) = Statein%ugrs(i,kflip) + vin (i,k) = Statein%vgrs(i,kflip) + dz (i,k) = (Statein%phii(i,kflip+1)-Statein%phii(i,kflip))/con_g + tke (i,k) = Statein%qgrs(i,kflip,Model%ntke) + + exner(i,k) = Statein%prslk(i,kflip) ! new + exchh1(i,k) = Statein%exch_h(i,kflip) ! new; needs to be a state variable + + pt_dt (i,k) = 0.0 ! this will be the potential temperature increment?? + udt (i,k) = 0.0 + vdt (i,k) = 0.0 + qv_dt (i,k) = 0.0 + ql_dt (i,k) = 0.0 + el1 (i,k) = 0. ! new; purely diagnostic + end do + enddo + phint(:,1,levs+1) = Statein%prsi(:,1) + + !Discarded arguments: STDH (currently not used), CT + !output variables: MIXHT, PBLH, EL_MYJ, tendencies, AKHS, AKMS, *Z0, EXCH_H, tke, KPBL + !NOTE: Look at mixing length (mixh1) + call myj_pbl(DT=dtp,NPHS=1,EPSL=epsL,EPSQ2=epsQ2,HT=ht,DZ=dz & + ,PMID=phmid,PINH=phint,TH=th,T=pt,EXNER=exner,Q=qv1 & + ,CWM=ql1,U=uin,V=vin & + ,TSK=tsfc1,QSFC=qsfc1,CHKLOWQ=one & + ,THZ0=thz01,QZ0=qz01,UZ0=uz01,VZ0=vz01 & + ,XLAND=land,SICE=cice1,SNOW=csnow1 & + ,Q2=tke,EXCH_H=exchh1,USTAR=ustar1& + ,Z0=z01,EL_MYJ=el1,PBLH=pblh1,KPBL=pblk1 & + ,AKHS=akhs1,AKMS=akms1,ELFLX=evap1,MIXHT=mixh1,HFLX=hflx1 & + ,RUBLTEN=udt,RVBLTEN=vdt,RTHBLTEN=pt_dt & + ,RQBLTEN=qv_dt,RQCBLTEN=ql_dt & + ,SPD1=wind,DSPHEAT=Model%dspheat& + ,IDS=1,IDE=im,JDS=1,JDE=1 & + ,IMS=1,IME=im,JMS=1,JME=1 & + ,ITS=1,ITE=im,JTS=1,JTE=1,LM=levs,LPRNT=lprnt) + + !Restore values + !add up tendencies + do i=1,im + Diag%hpbl(i) = pblh1(i,1) + kpbl(i) = pblk1(i,1) + Sfcprop%ffmm(i) = ustar1(i,1)*0.4/akms1(i,1) + Sfcprop%ffhh(i) = ustar1(i,1)*0.4/akhs1(i,1) + Diag%hmix(i) = mixh1(i,1) + + Sfcprop%thz0(i) = thz01(i,1) + Sfcprop%qz0(i) = qz01(i,1) + Sfcprop%uz0(i) = uz01(i,1) + Sfcprop%vz0(i) = vz01(i,1) + enddo + do k=1,levs + kflip = levs-k+1 + do i=1,im + dqdt(i,k,1) = dqdt(i,k,1) + qv_dt(i,kflip)/ (1. + qv_dt(i,kflip)) + dqdt(i,k,Model%ntcw) = dqdt(i,k,Model%ntcw) + ql_dt(i,kflip) + dtdt(i,k) = dtdt(i,k) + pt_dt(i,kflip) * Statein%prslk(i,k) !!! NEED conversion from theta; doing STUPID thing for now + dudt(i,k) = dudt(i,k) + udt(i,kflip) + dvdt(i,k) = dvdt(i,k) + vdt(i,kflip) + dqdt(i,k,Model%ntke) = dqdt(i,k,Model%ntke) + (tke(i,kflip) - Statein%qgrs(i,k,Model%ntke)) / dtp + + !These are the surface tendencies + ! which can be computed as the sum of the tendencies + ! through the atmosphere + ! (only mass/heat/mom source from PBL is the surface) + dusfc1(i) = dusfc1(i) + onebg*del(i,k)*udt(i,kflip) + dvsfc1(i) = dvsfc1(i) + onebg*del(i,k)*vdt(i,kflip) + dtsfc1(i) = dtsfc1(i) + con_cp*onebg*del(i,k)*pt_dt(i,kflip) * Statein%prslk(i,k) !DUMB! + dqsfc1(i) = dqsfc1(i) + con_hvap*onebg*del(i,k)*qv_dt(i,kflip) + +!$%!!$ Stateout%gq0(i,k,Model%ntrw) = qr1(i,1,kflip) + qr_dt(i,1,kflip) * dtp +!$%!!$ Stateout%gq0(i,k,Model%ntiw) = qi1(i,1,kflip) + qi_dt(i,1,kflip) * dtp +!$%!!$ Stateout%gq0(i,k,Model%ntsw) = qs1(i,1,kflip) + qs_dt(i,1,kflip) * dtp +!$%!!$ Stateout%gq0(i,k,Model%ntgl) = qg1(i,1,kflip) + qg_dt(i,1,kflip) * dtp + Stateout%gq0(i,k,Model%ntke) = tke(i,kflip) + Statein%exch_h(i,k) = exchh1(i,kflip) + dkt(i,k) = exchh1(i,kflip) + Diag%el_myj(i,k) = el1(i,kflip) + enddo + enddo +#endif fvGFS_2017 + elseif (.not. Model%old_monin) then + call moninq(ix, im, levs, nvdiff, Model%ntcw, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Radtend%htrsw, Radtend%htrlw, xmu, Statein%prsik(1,1), rb,& + Sfcprop%ffmm, Sfcprop%ffhh, Sfcprop%tsfc, qss, hflx, evap,& + stress, wind, kpbl, Statein%prsi, del, Statein%prsl, & + Statein%prslk, Statein%phii, Statein%phil, dtp, & + Model%dspheat, dusfc1, dvsfc1, dtsfc1, dqsfc1, Diag%hpbl, & + gamt, gamq, dkt, kinver, Model%xkzm_m, Model%xkzm_h, & + Model%xkzm_s, lprnt, ipr, & + Model%xkzminv, Model%moninq_fac, Model%rbcr) + else + if (Model%mstrat) then + call moninp1(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs,& + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%prslk, & + Statein%phii, Statein%phil, dtp, dusfc1, dvsfc1, & + dtsfc1, dqsfc1, Diag%hpbl, gamt, gamq, dkt, kinver, & + Model%xkzm_m, Model%xkzm_h) + else + call moninp(ix, im, levs, nvdiff, dvdt, dudt, dtdt, dqdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, Statein%qgrs, & + Statein%prsik(1,1), rb, Sfcprop%ffmm, Sfcprop%ffhh, & + Sfcprop%tsfc, qss, hflx, evap, stress, wind, kpbl, & + Statein%prsi, del, Statein%prsl, Statein%phii, & + Statein%phil, dtp, dusfc1, dvsfc1, dtsfc1, dqsfc1, & + Diag%hpbl, gamt, gamq, dkt, Model%xkzm_m, Model%xkzm_h) + endif + + endif ! end if_hybedmf + endif ! end if_do_shoc + + if (Model%ldiag3d) then + !!! Diffusion coefficients + !do i=1, im + ! Diag%dkt(i,1) = 0. + !enddo + do k=1,levs + do i=1,im + Diag%dkt(i,k) = dkt(i,k) + enddo + enddo + + !!! nonlocal fluxes + !do i=1, im + ! Diag%flux_cg(i,1) = 0. + ! Diag%flux_en(i,1) = 0. + !enddo + do k=1,levs + do i=1,im + Diag%flux_cg(i,k) = flux_cg(i,k) + Diag%flux_en(i,k) = flux_en(i,k) + enddo + enddo + + endif + + if (Model%cplflx) then + do i = 1, im + if (flag_cice(i)) then + cice(i) = fice_cice(i) + Sfcprop%tsfc(i) = tsea_cice(i) + dusfc1(i) = dusfc_cice(i) + dvsfc1(i) = dvsfc_cice(i) + dqsfc1(i) = dqsfc_cice(i) + dtsfc1(i) = dtsfc_cice(i) + endif + enddo + endif + +! if (lprnt) then +! write(0,*) ' dusfc1=',dusfc1(ipr),' kdt=',kdt,' lat=',lat +! write(0,*)' dtsfc1=',dtsfc1(ipr) +! write(0,*)' dqsfc1=',dqsfc1(ipr) +! write(0,*)' dtdtc=',(dtdt(ipr,k),k=1,15) +! write(0,*)' dqdtc=',(dqdt(ipr,k,1),k=1,15) +! print *,' dudtm=',dudt(ipr,:) +! endif + +! --- ... coupling insertion + + if (Model%cplflx) then + Coupling%dusfc_cpl (:) = Coupling%dusfc_cpl(:) + dusfc1(:)*dtf + Coupling%dvsfc_cpl (:) = Coupling%dvsfc_cpl(:) + dvsfc1(:)*dtf + Coupling%dtsfc_cpl (:) = Coupling%dtsfc_cpl(:) + dtsfc1(:)*dtf + Coupling%dqsfc_cpl (:) = Coupling%dqsfc_cpl(:) + dqsfc1(:)*dtf + Coupling%dusfci_cpl(:) = dusfc1(:) + Coupling%dvsfci_cpl(:) = dvsfc1(:) + Coupling%dtsfci_cpl(:) = dtsfc1(:) + Coupling%dqsfci_cpl(:) = dqsfc1(:) + endif + +! use for slab/mixed layer ocean model + netswsfc = 0. + netflxsfc = 0. + qflux_restore = 0. + do i = 1, im + if (islmsk(i) == 0 ) then +! --- compute open water albedo + xcosz_loc = max( 0.0, min( 1.0, xcosz(i) )) + ocalnirdf_cpl(i) = 0.06 + ocalnirbm_cpl(i) = max(albdf, 0.026/(xcosz_loc**1.7+0.065) & + + 0.15 * (xcosz_loc-0.1) * (xcosz_loc-0.5) & + * (xcosz_loc-1.0)) + ocalvisdf_cpl(i) = 0.06 + ocalvisbm_cpl(i) = ocalnirbm_cpl(i) +! +! netswsfc (i) = adjnirbmd(i)-adjnirbmd(i)*ocalnirbm_cpl(i) + & +! adjnirdfd(i)-adjnirdfd(i)*ocalnirdf_cpl(i) + & +! adjvisbmd(i)-adjvisbmd(i)*ocalvisbm_cpl(i) + & +! adjvisdfd(i)-adjvisdfd(i)*ocalvisdf_cpl(i) + netswsfc (i) = adjsfcnsw(i) + netflxsfc (i) = netswsfc(i) + & !net shortwave + adjsfcdlw(i)-adjsfculw(i) + & !net longwave + dtsfc1(i) * (-1.) + & !sensible heat flux + dqsfc1(i) * (-1.) !latent heat flux + endif + enddo + if (Model%do_ocean) then + call update_ocean (im, dtp, Grid, islmsk, kdt, Model%kdt_prev, netflxsfc, dusfc1*(-1.), dvsfc1*(-1.), & + Sfcprop%tprcp, Statein%tgrs(:,1), qflux_restore, Sfcprop%qfluxadj, & + Sfcprop%mldclim, Sfcprop%tsclim,Sfcprop%ts_clim_iano, Statein%sst, Sfcprop%ts_som, & + Sfcprop%tsfc, Sfcprop%tml, Sfcprop%tml0, Sfcprop%mld, Sfcprop%mld0, & + Sfcprop%huml, Sfcprop%hvml, Sfcprop%tmoml, Sfcprop%tmoml0, Model%iau_offset) + endif + Diag%netflxsfc (:) = Diag%netflxsfc(:) + netflxsfc(:)*dtf + Diag%qflux_restore(:) = Diag%qflux_restore(:) + qflux_restore(:)*dtf + Diag%tclim_iano (:) = Diag%tclim_iano(:) + Sfcprop%ts_clim_iano(:)*dtf + Diag%MLD (:) = Diag%MLD(:) + Sfcprop%mld(:)*dtf +! + if (Model%use_ext_sst .and. .not. Model%do_ocean) then + do i = 1, im + if (islmsk(i) == 0 ) Sfcprop%tsfc(i) = Statein%sst(i) + enddo + endif +!-------------------------------------------------------lssav if loop ---------- + if (Model%lssav) then + Diag%dusfc (:) = Diag%dusfc(:) + dusfc1(:)*dtf + Diag%dvsfc (:) = Diag%dvsfc(:) + dvsfc1(:)*dtf + Diag%dtsfc (:) = Diag%dtsfc(:) + dtsfc1(:)*dtf + Diag%dqsfc (:) = Diag%dqsfc(:) + dqsfc1(:)*dtf + Diag%dusfci(:) = dusfc1(:) + Diag%dvsfci(:) = dvsfc1(:) + Diag%dtsfci(:) = dtsfc1(:) + Diag%dqsfci(:) = dqsfc1(:) +! if (lprnt) then +! write(0,*)' dusfc=',dusfc(ipr),' dusfc1=',dusfc1(ipr),' dtf=', +! & dtf,' kdt=',kdt,' lat=',lat +! endif + + if (Model%ldiag3d) then + if (Model%lsidea) then + Diag%dt3dt(:,:,3) = Diag%dt3dt(:,:,3) + dtdt(:,:)*dtf + else + do k = 1, levs + do i = 1, im + tem = dtdt(i,k) - (Radtend%htrlw(i,k)+Radtend%htrsw(i,k)*xmu(i)) + Diag%dt3dt(i,k,3) = Diag%dt3dt(i,k,3) + tem*dtf + enddo + enddo + endif + Diag%du3dt(:,:,1) = Diag%du3dt(:,:,1) + dudt(:,:) * dtf + Diag%dv3dt(:,:,1) = Diag%dv3dt(:,:,1) + dvdt(:,:) * dtf + if (Model%orogwd) then ! call orographic gravity wave drag + Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) - dudt(:,:) * dtf + Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) - dvdt(:,:) * dtf + endif +! update dqdt_v to include moisture tendency due to vertical diffusion +! if (lgocart) then +! do k = 1, levs +! do i = 1, im +! dqdt_v(i,k) = dqdt(i,k,1) * dtf +! enddo +! enddo +! endif + do k = 1, levs + do i = 1, im + tem = dqdt(i,k,1) * dtf + Diag%dq3dt(i,k,1) = Diag%dq3dt(i,k,1) + tem + enddo + enddo + if (Model%ntoz > 0) then + do k=1,levs + do i=1,im + Diag%dq3dt(i,k,5) = Diag%dq3dt(i,k,5) + dqdt(i,k,Model%ntoz) * dtf + enddo + enddo + endif + endif + + endif ! end if_lssav +!-------------------------------------------------------lssav if loop ---------- + if (Model%orogwd) then ! call orographic gravity wave drag +! +! Orographic gravity wave drag parameterization +! --------------------------------------------- + + if (Model%nmtvr == 14) then ! current operational - as of 2014 + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = Sfcprop%hprime(:,7) + clx(:,2) = Sfcprop%hprime(:,8) + clx(:,3) = Sfcprop%hprime(:,9) + clx(:,4) = Sfcprop%hprime(:,10) + theta(:) = Sfcprop%hprime(:,11) + gamma(:) = Sfcprop%hprime(:,12) + sigma(:) = Sfcprop%hprime(:,13) + elvmax(:) = Sfcprop%hprime(:,14) + elseif (Model%nmtvr == 10) then + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = Sfcprop%hprime(:,7) + clx(:,2) = Sfcprop%hprime(:,8) + clx(:,3) = Sfcprop%hprime(:,9) + clx(:,4) = Sfcprop%hprime(:,10) + elseif (Model%nmtvr == 6) then + oc(:) = Sfcprop%hprime(:,2) + oa4(:,1) = Sfcprop%hprime(:,3) + oa4(:,2) = Sfcprop%hprime(:,4) + oa4(:,3) = Sfcprop%hprime(:,5) + oa4(:,4) = Sfcprop%hprime(:,6) + clx(:,1) = 0.0 + clx(:,2) = 0.0 + clx(:,3) = 0.0 + clx(:,4) = 0.0 + else + oc = 0 ; oa4 = 0 ; clx = 0 ; theta = 0 ; gamma = 0 ; sigma = 0 + elvmax = 0 + + endif ! end if_nmtvr + + dtdt_gwdps = dtdt(:,:) ! gwdps updates dtdt (need the initial value) + +! write(0,*)' before gwd clstp=',clstp,' kdt=',kdt,' lat=',lat + if (ANY(Model%cdmbgwd > 0.)) then + call gwdps(im, ix, im, levs, dvdt, dudt, dtdt, & + Statein%ugrs, Statein%vgrs, Statein%tgrs, & + Statein%qgrs, kpbl, Statein%prsi, del, & + Statein%prsl, Statein%prslk, Statein%phii, & + Statein%phil, dtp, kdt, & + Sfcprop%hprime(1,1), oc, oa4, clx, theta, & + sigma, gamma, elvmax, dusfcg, dvsfcg, & + con_g, con_cp, con_rd, con_rv, Model%lonr, & + Model%nmtvr, Model%cdmbgwd, me, lprnt,ipr, & + Model%gwd_p_crit, Diag%zmtnblck) + endif + +! if (lprnt) print *,' dudtg=',dudt(ipr,:) + + if (Model%lssav) then + Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf + Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + +! if (lprnt) print *,' dugwd=',dugwd(ipr),' dusfcg=',dusfcg(ipr) +! if (lprnt) print *,' dvgwd=',dvgwd(ipr),' dvsfcg=',dvsfcg(ipr) + + if (Model%ldiag3d) then + Diag%du3dt(:,:,2) = Diag%du3dt(:,:,2) + dudt(:,:) * dtf + Diag%dv3dt(:,:,2) = Diag%dv3dt(:,:,2) + dvdt(:,:) * dtf + !Diag%dt3dt(:,:,2) = Diag%dt3dt(:,:,2) + dtdt(:,:) * dtf + Diag%dt3dt(:,:,7) = Diag%dt3dt(:,:,7) + (dtdt(:,:) - dtdt_gwdps(:,:)) * dtf + endif + endif + + endif ! end if_orogwd (orographic gravity wave drag) + +! Rayleigh damping near the model top + if( .not. Model%lsidea .and. Model%ral_ts > 0.0) then + call rayleigh_damp(im, ix, im, levs, dvdt, dudt, dtdt, & + Statein%ugrs, Statein%vgrs, dtp, con_cp, & + Model%levr, Statein%pgr, Statein%prsl, & + Model%prslrd0, Model%ral_ts) + endif + +! if (lprnt) then +! write(0,*)' tgrs1=',(tgrs(ipr,ik),k=1,10) +! write(0,*)' dtdt=',(dtdt(ipr,ik),k=1,10) +! endif + + Stateout%gt0(:,:) = Statein%tgrs(:,:) + dtdt(:,:) * dtp + Stateout%gu0(:,:) = Statein%ugrs(:,:) + dudt(:,:) * dtp + Stateout%gv0(:,:) = Statein%vgrs(:,:) + dvdt(:,:) * dtp +! Linjiong, 09/18/2017, turn off vertical mixing of rain, snow, and graupel + if ((Model%ncld == 5) .and. (.not. Model%mix_precip)) then ! GFDL Cloud microphysics +! if (Model%ncld == 5 ) then ! GFDL Cloud microphysics + ! water vapor + Stateout%gq0(:,:, 1) = Statein%qgrs(:,:, 1) + dqdt(:,:, 1) * dtp + ! cloud water + Stateout%gq0(:,:,Model%ntcw) = Statein%qgrs(:,:,Model%ntcw) + dqdt(:,:,Model%ntcw) * dtp + ! cloud ice + Stateout%gq0(:,:,Model%ntiw) = Statein%qgrs(:,:,Model%ntiw) + dqdt(:,:,Model%ntiw) * dtp + else + Stateout%gq0(:,:,:) = Statein%qgrs(:,:,:) + dqdt(:,:,:) * dtp + endif +! Linjiong, 09/18/2017, turn off vertical mixing of rain, snow, and graupel + +! if (lprnt) then +! write(7000,*)' ugrs=',ugrs(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! write(7000,*)' dudt*dtp=',dudt(ipr,:)*dtp +! write(7000,*)' vgrs=',vgrs(ipr,:) +! write(7000,*)' dvdt*dtp ',dvdt(ipr,:)*dtp +! endif +! if(lprnt) write(1000+me,*)' gq0w=',gq0(ipr,:,ntcw) +! if(lprnt) write(0,*)' gq0i=',gq0(ipr,:,ntiw) + + if (Model%lsidea) then ! idea convective adjustment + call ideaca_up(Statein%prsi,Stateout%gt0,ix,im,levs+1) + endif + +! --- ... ozone physics + + if ((Model%ntoz > 0) .and. (ntrac >= Model%ntoz)) then + if (oz_coeff > 4) then + call ozphys_2015 (ix, im, levs, levozp, dtp, & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gt0, oz_pres, Statein%prsl, & + Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & + dq3dt_loc(1,1,6), me) + if (Model%ldiag3d) then + Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) + Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) + Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) + Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + endif + else + call ozphys (ix, im, levs, levozp, dtp, & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gq0(1,1,Model%ntoz), & + Stateout%gt0, oz_pres, Statein%prsl, & + Tbd%ozpl, oz_coeff, del, Model%ldiag3d, & + dq3dt_loc(1,1,6), me) + if (Model%ldiag3d) then + Diag%dq3dt(:,:,6) = dq3dt_loc(:,:,6) + Diag%dq3dt(:,:,7) = dq3dt_loc(:,:,7) + Diag%dq3dt(:,:,8) = dq3dt_loc(:,:,8) + Diag%dq3dt(:,:,9) = dq3dt_loc(:,:,9) + endif + endif + endif + + if (Model%h2o_phys) then + call h2ophys (ix, im, levs, levh2o, dtp, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,1), h2o_pres, Statein%prsl, & + Tbd%h2opl, h2o_coeff, Model%ldiag3d, & + dq3dt_loc(1,1,1), me) + endif + +! --- ... to side-step the ozone physics + +! if (ntrac >= 2) then +! do k = 1, levs +! gq0(k,ntoz) = qgrs(k,ntoz) +! enddo +! endif + +! if (lprnt) then +! write(0,*) ' levs=',levs,' jcap=',jcap,' dtp',dtp & +! &, ' slmsk=',slmsk(ilon,ilat),' kdt=',kdt +! print *,' rann=',rann,' ncld=',ncld,' iq=',iq,' lat=',lat +! print *,' pgr=',pgr +! print *,' del=',del(ipr,:) +! print *,' prsl=',prsl(ipr,:) +! print *,' prslk=',prslk(ipr,:) +! print *,' rann=',rann(ipr,1) +! write(0,*)' gt0=',gt0(ipr,:) & +! &, ' kdt=',kdt,' xlon=',xlon(ipr),' xlat=',xlat(ipr) +! print *,' dtdt=',dtdt(ipr,:) +! print *,' gu0=',gu0(ipr,:) +! print *,' gv0=',gv0(ipr,:) +! write(0,*) ' gt0=',(gt0(ipr,k),k=1,levs),' kdt=',kdt +! write(0,*)' gq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat +! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat +! write(0,*)' gq1=',(gq0(ipr,k,ntcw),k=1,levs) +! print *,' vvel=',vvel +! endif +! if (lprnt) write(7000,*)' bef convection gu0=',gu0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! if (lprnt) write(7000,*)' bef convection gv0=',gv0(ipr,:) + + if (Model%ldiag3d) then + dtdt(:,:) = Stateout%gt0(:,:) + dudt(:,:) = Stateout%gu0(:,:) + dvdt(:,:) = Stateout%gv0(:,:) + elseif (Model%cnvgwd) then + dtdt(:,:) = Stateout%gt0(:,:) + endif ! end if_ldiag3d/cnvgwd + + if (Model%ldiag3d .or. Model%lgocart) then + dqdt(:,:,1) = Stateout%gq0(:,:,1) + endif ! end if_ldiag3d/lgocart + +#ifdef GFS_HYDRO + call get_phi(im, ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & + Model%thermodyn_id, Model%sfcpress_id, & + Model%gen_coord_hybrid Statein%prsi, Statein%prsik, & + Statein%prsl, Statein%prslk, Statein%phii, Statein%phil) +#else +!GFDL Adjust the height hydrostatically in a way consistent with FV3 discretization + call get_phi_fv3 (ix, levs, ntrac, Stateout%gt0, Stateout%gq0, & + del_gz, Statein%phii, Statein%phil) +#endif + +! if (lprnt) then +! print *,' phii2=',phii(ipr,k=1,levs) +! print *,' phil2=',phil(ipr,:) +! endif + + clw(:,:,1) = 0.0 + clw(:,:,2) = -999.9 + if ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + cnvc(:,:) = 0.0 + cnvw(:,:) = 0.0 + endif + + +! --- ... for convective tracer transport (while using samf) + + itc = 0 + ntk = 0 + tottracer = 0 + + if (Model%cscnv .or. Model%satmedmf .or. Model%trans_trac ) then + tracers = 2 + nn = 1 + do n=2,ntrac + if ( n /= Model%ntcw .and. n /= Model%ntiw .and. n /= Model%ntclamt ) then + tracers = tracers + 1 + clw_trac_idx(nn) = n + nn =nn + 1 + do k=1,levs + do i=1,im + clw(i,k,tracers) = Stateout%gq0(i,k,n) + + enddo + enddo + + if (Model%ntke == n ) then + ntk = tracers + endif + + if (trans_aero .and. Model%ntchs == n) itc = tracers + + endif + enddo + tottracer = tracers - 2 + endif ! end if_ras or cfscnv or samf + + + + ktop(:) = 1 + kbot(:) = levs + +! --- ... calling condensation/precipitation processes +! -------------------------------------------- + + if (Model%ntcw > 0) then + do k=1,levs + do i=1,im + tem = rhbbot - (rhbbot-rhbtop) * (1.0-Statein%prslk(i,k)) + tem = rhc_max * work1(i) + tem * work2(i) + rhc(i,k) = max(0.0, min(1.0,tem)) + enddo + enddo + if (Model%ncld == 2) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + else + if (Model%num_p3d == 4) then ! zhao-carr microphysics + psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) + prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) + clw(:,:,1) = Stateout%gq0(:,:,Model%ntcw) + endif ! end if_num_p3d + endif ! end if (ncld == 2) + else ! if_ntcw + psautco_l(:) = Model%psautco(1)*work1(:) + Model%psautco(2)*work2(:) + prautco_l(:) = Model%prautco(1)*work1(:) + Model%prautco(2)*work2(:) + rhc(:,:) = 1.0 + endif ! end if_ntcw +! +! Call SHOC if do_shoc is true and shocaftcnv is false +! + if (Model%do_shoc .and. .not. Model%shocaftcnv) then + if (Model%ncld == 2) then + skip_macro = Model%do_shoc + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) + ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + elseif (Model%num_p3d == 4) then + do k=1,levs + do i=1,im + qpl(i,k) = 0.0 + qpi(i,k) = 0.0 + if (abs(Stateout%gq0(i,k,Model%ntcw)) < epsq) then + Stateout%gq0(i,k,Model%ntcw) = 0.0 + endif + tem = Stateout%gq0(i,k,Model%ntcw) & + & * max(0.0, MIN(1.0, (TCR-Stateout%gt0(i,k))*TCRF)) + clw(i,k,1) = tem ! ice + clw(i,k,2) = Stateout%gq0(i,k,Model%ntcw) - tem ! water + enddo + enddo + endif + +! dtshoc = 60.0 +! dtshoc = 120.0 +! dtshoc = dtp +! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = dtp / nshocm +! do nshoc=1,nshocm +! if (lprnt) write(1000+me,*)' before shoc tke=',clw(ipr,:,ntk), +! &' kdt=',kdt,' lat=',lat,'xlon=',xlon(ipr),' xlat=',xlat(ipr) + +! phy_f3d(1,1,ntot3d-2) - shoc determined sgs clouds +! phy_f3d(1,1,ntot3d-1) - shoc determined diffusion coefficients +! phy_f3d(1,1,ntot3d ) - shoc determined w'theta' +! +! dqdt(1:im,:,1) = gq0(1:im,:,1) +! dqdt(1:im,:,2) = gq0(1:im,:,ntiw) +! dqdt(1:im,:,3) = gq0(1:im,:,ntcw) +!GFDL lat has no meaning inside of shoc - changed to "1" +!GFDL call shoc(ix, im, 1, levs, levs+1, dtp, me, lat, + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl, & + rhc, Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + clw(1,1,ntk), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), & + Tbd%phy_f3d(1,1,Model%ntot3d), lprnt, ipr, ncpl, ncpi, kdt) + +! if (lprnt) write(0,*)' aftshoccld=',phy_f3d(ipr,:,ntot3d-2)*100 +! if (lprnt) write(0,*)' aftshocice=',clw(ipr,:,1) +! if (lprnt) write(0,*)' aftshocwat=',clw(ipr,:,1) +! write(1000+me,*)' at latitude = ',lat +! rain1 = 0.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),'shoc ') + + if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then + Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) + Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + endif +! do k=1,levs +! do i=1,im +! sgs_cld(i,k) = sgs_cld(i,k) + shoc_cld(i,k) +! enddo +! enddo +! if (lprnt) write(0,*)' gt03=',gt0(ipr,1:10) +! if (lprnt) write(0,*)' tke=',clw(ipr,1:10,ntk) + +! if (lprnt) write(1000+me,*)' after shoc tke=',clw(1,:,ntk), +! &' kdt=',kdt +! enddo +! +! do k=1,levs +! write(1000+me,*)' maxcld=',maxval(sgs_cld(1:im,k)), +! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), +! &' k=',k,' kdt=',kdt,' lat=',lat +! enddo + +! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat +! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat +! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat +! + endif ! if(do_shoc) + +! --- ... calling convective parameterization +! + if (.not. Model%ras .and. .not. Model%cscnv) then + + if (Model%do_deep) then + + if (Model%do_ca) then + do k=1,levs + do i=1,im + Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1)*(1. + Coupling%ca_deep(i)/500.) + enddo + enddo + endif + + + if (Model%imfdeepcnv == 1) then ! no random cloud top + call sascnvn (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1), Stateout%gt0, Stateout%gu0, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Model%ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_deep, Model%c0s_deep, & + Model%c1_deep, Model%betal_deep, Model%betas_deep, & + Model%evfact_deep, Model%evfactl_deep, & + Model%pgcon_deep) + elseif (Model%imfdeepcnv == 2) then + if (Model%ncld == 5 .and. Model%ext_rain_deep) then + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + endif + call mfdeepcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1), & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + Model%ext_rain_deep, qrn, & + cld1d, rain1, kbot, ktop, kcnv, islmsk, & + garea, Statein%vvl, Model%ncld, ud_mf, dd_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_deep, Model%c0s_deep, & + Model%c1_deep, Model%betal_deep, Model%betas_deep, & + Model%evfact_deep, Model%evfactl_deep, & + Model%pgcon_deep, Model%asolfac_deep) +! if (lprnt) print *,' rain1=',rain1(ipr) + if (Model%ncld == 5 .and. Model%ext_rain_deep) then + Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) + endif + elseif (Model%imfdeepcnv == 3) then + if(.not. Model%satmedmf .and. .not. Model%trans_trac) then + nsamftrac = 0 + else + nsamftrac = tottracer + endif + call samfdeepcnv(im, ix, levs, dtp, itc, Model%ntchm, ntk, nsamftrac, & + del, Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:nsamftrac+2), & + Stateout%gq0(:,:,1), Stateout%gt0, & + Stateout%gu0, Stateout%gv0, Model%fscav, Model%do_ca, & + Coupling%ca_deep, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, garea, & + Statein%vvl, Model%ncld, ud_mf, dd_mf, dt_mf, cnvw, cnvc, & + QLCN, QICN, w_upi,cf_upi, CNV_MFD, & + CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE, & + ! imp_physics, & + ! TODO: reorganize ways of calling microphysics + 5, & + Model%clam_deep, Model%c0s_deep, & + Model%c1_deep, Model%betal_deep, Model%betas_deep, & + Model%evfact_deep, Model%evfactl_deep, & + Model%pgcon_deep, Model%asolfac_deep) + + elseif (Model%imfdeepcnv == 0) then ! random cloud top + call sascnv (im, ix, levs, Model%jcap, dtp, del, & + Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1), Stateout%gt0, Stateout%gu0, & + Stateout%gv0, cld1d, rain1, kbot, ktop, kcnv, & + islmsk, Statein%vvl, Tbd%rann, Model%ncld, & + ud_mf, dd_mf, dt_mf, cnvw, cnvc) +! if (lprnt) print *,' rain1=',rain1(ipr),' rann=',rann(ipr,1) + endif + + else ! no deep convection + cld1d = 0. + rain1 = 0. + ud_mf = 0. + dd_mf = 0. + dt_mf = 0. + cnvw = 0. + cnvc = 0. + endif + + + if (Model%npdf3d == 3 .and. Model%num_p3d == 4) then + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = cnvw(i,k) + Tbd%phy_f3d(i,k,num3) = cnvc(i,k) + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo + elseif (Model%npdf3d == 0 .and. Model%ncnvcld3d == 1) then + do k=1,levs + do i=1,im + Tbd%phy_f3d(i,k,num2) = cnvw(i,k) + cnvw(i,k) = 0. + enddo + enddo + endif + + if(Model%do_ca) then + Coupling%cape(:) = cld1d(:) + endif + + + else ! ras or cscnv + if (Model%cscnv) then ! Chikira-Sugiyama convection scheme (via CSU) + + fscav(:) = 0.0 + fswtr(:) = 0.0 +! write(0,*)' bef cs_cconv phii=',phii(ipr,:) +! &,' sizefsc=',size(fscav) +! write(0,*)' bef cs_cconv otspt=',otspt,' kdt=',kdt,' me=',me + dqdt(:,:,1) = Stateout%gq0(:,:,1) + dqdt(:,:,2) = max(0.0,clw(:,:,2)) + dqdt(:,:,3) = max(0.0,clw(:,:,1)) +! if (lprnt) write(0,*)' gq0bfcs=',gq0(ipr,1:35,1) +! if (lprnt) write(0,*)' gq0bfcs3=',gq0(ipr,1:35,3) +! if (lprnt) write(0,*)' gq0bfcs4=',gq0(ipr,1:35,4) + + do_awdd = ((Model%do_aw) .and. (Model%cs_parm(6) > 0.0)) +! if (lprnt) write(0,*)' do_awdd=',do_awdd +!GFDL again lat replaced with "1" +!GFDL & otspt, lat, kdt , & + +! Initialization of otspt has been removed since cs_convr is obsolete in SHiELD + call cs_convr (ix, im, levs, tottracer+3, Model%nctp, otspt, 1, & + kdt, Stateout%gt0, Stateout%gq0(:,:,1:1), rain1, & + clw, Statein%phil, Statein%phii, Statein%prsl, & + Statein%prsi, dtp, dtf, ud_mf, dd_mf, dt_mf, & + Stateout%gu0, Stateout%gv0, fscav, fswtr, & + Tbd%phy_fctd, me, wcbmax, Model%cs_parm(3), & + Model%cs_parm(4), sigmai, sigmatot, vverti, & + Model%do_aw, do_awdd, lprnt, ipr, QLCN, QICN, & + w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld) + +! if (lprnt) write(0,*)' gq0afcs=',gq0(ipr,1:35,1) +! if (lprnt) write(0,*)' gq0afcs3=',gq0(ipr,1:35,3) +! if (lprnt) write(0,*)' gq0afcs4=',gq0(ipr,1:35,4) +! write(1000+me,*)' at latitude = ',lat +! call moist_bud(im,im,ix,levs,me,kdt,con_g,dtp,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' cs_conv') + + rain1(:) = rain1(:) * (dtp*0.001) + if (Model%do_aw) then + do k=1,levs + kk = min(k+1,levs) ! assuming no cloud top reaches the model top + do i = 1,im !DD + sigmafrac(i,k) = 0.5 * (sigmatot(i,k)+sigmatot(i,kk)) + enddo + enddo + endif + +! if (lprnt) then +! write(0,*)' gt01=',gt0(ipr,:),' kdt=',kdt +! write(0,*)' gq01=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*)' clw1=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' clw2=',clw(ipr,:,1),' kdt=',kdt +! write(0,*)' aft cs rain1=',rain1(ipr)*86400 +! write(0,*)' aft cs rain1=',rain1(ipr) +! endif + + else ! ras version 2 + + if ((Model%ccwf(1) >= 0.0) .or. (Model%ccwf(2) >= 0)) then + ccwfac(:) = Model%ccwf(1)*work1(:) + Model%ccwf(2)*work2(:) + dlqfac(:) = Model%dlqf(1)*work1(:) + Model%dlqf(2)*work2(:) + lmh (:) = levs + else + ccwfac(:) = -999.0 + dlqfac(:) = 0.0 + lmh (:) = levs + endif +! if (lprnt) write(0,*) ' calling ras for kdt=',kdt,' me=',me & +! &, ' lprnt=',lprnt,' ccwfac=',ccwfac(ipr) + +! do k=1,levs +! do i=1,im +! dqdt(i,k,1) = gq0(i,k,1) +! dqdt(i,k,2) = max(0.0,clw(i,k,2)) +! dqdt(i,k,3) = max(0.0,clw(i,k,1)) +! enddo +! enddo +! if (lat == 64 .and. kdt == 1) write(0,*)' qliq=',clw(1,:,1) +! if (lat == 64 .and. kdt == 1) write(0,*)' qice=',clw(1,:,2) + + revap = .true. +! if (ncld ==2) revap = .false. + call rascnv (im, ix, levs, dtp, dtf, Tbd%rann, Stateout%gt0, & + Stateout%gq0, Stateout%gu0, Stateout%gv0, clw, & + tottracer, fscav, Statein%prsi, Statein%prsl, & + Statein%prsik, Statein%prslk, Statein%phil, & + Statein%phii, kpbl, cd, rain1, kbot, ktop, kcnv, & + Tbd%phy_f2d(1,Model%num_p2d), Model%flipv, pa2mb, & + me, garea, lmh, ccwfac, Model%nrcm, rhc, ud_mf, & + dd_mf, dt_mf, dlqfac, lprnt, ipr, kdt, revap, QLCN, & + QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, CNV_FICE, CNV_NDROP, CNV_NICE, Model%ncld ) + endif + +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,im,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, dqdt(1,1,1), dqdt(1,1,2), dqdt(1,1,3) +! &, gq0(1,1,1),clw(1,1,2),clw(1,1,1),' ras_conv') +! if(lprnt) write(0,*)' after ras rain1=',rain1(ipr) +! &,' cnv_prc3sum=',sum(cnv_prc3(ipr,1:levs)) +! if (lprnt) write(0,*)' gt04=',gt0(ipr,1:10) +! if (lprnt) write(0,*)' gq04=',gq0(ipr,:,1) + + cld1d = 0 + + if (Model%ldiag3d .or. Model%lgocart) then + Coupling%upd_mfi(:,:) = 0. + Coupling%dwn_mfi(:,:) = 0. + Coupling%det_mfi(:,:) = 0. + endif + if (Model%lgocart) then + Coupling%dqdti(:,:) = 0. + Coupling%cnvqci(:,:) = 0. + endif + + if (Model%lgocart) then + Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain + Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain + Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain + Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2) - & + Stateout%gq0(:,:,Model%ntcw)) * frain + endif ! if (lgocart) + + endif ! end if_not_ras + +! if (lprnt) then +! write(0,*)' aftcnvgt0=',gt0(ipr,:),' kdt=',kdt,' lat=',lat +! write(0,*)' aftcnvgq0=',(gq0(ipr,k,1),k=1,levs),' lat=',lat +! write(0,*)' gq0i2=',(gq0(ipr,k,ntiw),k=1,levs),' lat=',lat +! write(0,*)' aftcnvgq1=',(gq0(ipr,k,ntcw),k=1,levs) +! endif +! + Diag%rainc(:) = frain * rain1(:) +! + if (Model%lssav) then + Diag%cldwrk (:) = Diag%cldwrk (:) + cld1d(:) * dtf + + if (Model%ldiag3d) then + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + Diag%du3dt(:,:,3) = Diag%du3dt(:,:,3) + (Stateout%gu0(:,:)-dudt(:,:)) * frain + Diag%dv3dt(:,:,3) = Diag%dv3dt(:,:,3) + (Stateout%gv0(:,:)-dvdt(:,:)) * frain + + Diag%upd_mf(:,:) = Diag%upd_mf(:,:) + ud_mf(:,:) * (con_g*frain) + Diag%dwn_mf(:,:) = Diag%dwn_mf(:,:) + dd_mf(:,:) * (con_g*frain) + Diag%det_mf(:,:) = Diag%det_mf(:,:) + dt_mf(:,:) * (con_g*frain) + endif ! if (ldiag3d) + + endif ! end if_lssav +! +! update dqdt_v to include moisture tendency due to deep convection + if (Model%lgocart) then + Coupling%dqdti (:,:) = (Stateout%gq0(:,:,1) - dqdt(:,:,1)) * frain + Coupling%upd_mfi(:,:) = Coupling%upd_mfi(:,:) + ud_mf(:,:) * frain + Coupling%dwn_mfi(:,:) = Coupling%dwn_mfi(:,:) + dd_mf(:,:) * frain + Coupling%det_mfi(:,:) = Coupling%det_mfi(:,:) + dt_mf(:,:) * frain + Coupling%cnvqci (:,:) = Coupling%cnvqci (:,:) + (clw(:,:,1)+clw(:,:,2))*frain + endif ! if (lgocart) +! + +! if (lprnt) write(7000,*)' bef cnvgwd gu0=',gu0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +! if (lprnt) write(7000,*)' bef cnvgwd gv0=',gv0(ipr,:) +! +!----------------Convective gravity wave drag parameterization starting -------- + + if (Model%cnvgwd) then ! call convective gravity wave drag + +! --- ... calculate maximum convective heating rate +! cuhr = temperature change due to deep convection + + cumabs(:) = 0.0 + work3 (:) = 0.0 + do k = 1, levs + do i = 1, im + if (k >= kbot(i) .and. k <= ktop(i)) then + cumabs(i) = cumabs(i) + (Stateout%gt0(i,k)-dtdt(i,k)) * del(i,k) + work3(i) = work3(i) + del(i,k) + endif + enddo + enddo + do i=1,im + if (work3(i) > 0.0) cumabs(i) = cumabs(i) / (dtp*work3(i)) + enddo + +! do i = 1, im +! do k = kbot(i), ktop(i) +! do k1 = kbot(i), k +! cumchr(i,k) = cuhr(i,k1) + cumchr(i,k) +! enddo +! cumchr(i,k) = cumchr(i,k) / cumabs(i) +! enddo +! enddo + +! --- ... begin check print ****************************************** + +! if (lprnt) then +! if (kbot(ipr) <= ktop(ipr)) then +! write(*,*) 'kbot <= ktop for (lat,lon) = ', & +! & xlon(ipr)*57.29578,xlat(ipr)*57.29578 +! write(*,*) 'kcnv kbot ktop dlength ',kcnv(ipr), & +! & kbot(ipr),ktop(ipr),dlength(ipr) +! write(*,9000) kdt +!9000 format(/,3x,'k',5x,'cuhr(k)',4x,'cumchr(k)',5x, & +! & 'at kdt = ',i4,/) + +! do k = ktop(ipr), kbot(ipr),-1 +! write(*,9010) k,(86400.*cuhr(ipr,k)),(100.*cumchr(ipr,k)) +!9010 format(2x,i2,2x,f8.2,5x,f6.0) +! enddo +! endif + +! if (fhour >= fhourpr) then +! print *,' before gwdc in gbphys start print' +! write(*,*) 'fhour ix im levs = ',fhour,ix,im,levs +! print *,'dtp dtf = ',dtp,dtf + +! write(*,9100) +!9100 format(//,14x,'pressure levels',// & +! & ' ilev',7x,'prsi',8x,'prsl',8x,'delp',/) + +! k = levs + 1 +! write(*,9110) k,(10.*prsi(ipr,k)) +!9110 format(i4,2x,f10.3) + +! do k = levs, 1, -1 +! write(*,9120) k,(10.*prsl(ipr,k)),(10.*del(ipr,k)) +! write(*,9110) k,(10.*prsi(ipr,k)) +! enddo +!9120 format(i4,12x,2(2x,f10.3)) + +! write(*,9130) +!9130 format(//,10x,'before gwdc in gbphys',//,' ilev',6x, & +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',8x,'dudt',8x,'dvdt',/) + +! do k = levs, 1, -1 +! write(*,9140) k,ugrs(ipr,k),gu0(ipr,k), & +! & vgrs(ipr,k),gv0(ipr,k), & +! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & dudt(ipr,k),dvdt(ipr,k) +! enddo +!9140 format(i4,9(2x,f10.3)) + +! print *,' before gwdc in gbphys end print' +! endif +! endif ! end if_lprnt + +! --- ... end check print ******************************************** + +!GFDL replacing lat with "1" +! call gwdc(im, ix, im, levs, lat, gu0, gv0, gt0, gq0, dtp, & + call gwdc (im, ix, im, levs, 1, Statein%ugrs, Statein%vgrs, & + Statein%tgrs, Statein%qgrs, dtp, Statein%prsl, & + Statein%prsi, del, cumabs, ktop, kbot, kcnv, cldf, & + con_g, con_cp, con_rd, con_fvirt, con_pi, dlength, & + lprnt, ipr, Model%fhour, gwdcu, gwdcv, dusfcg, dvsfcg) + +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' after gwdc in gbphys start print' + +! write(*,9131) +!9131 format(//,10x,'after gwdc in gbphys',//,' ilev',6x, & +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) + +! do k = levs, 1, -1 +! write(*,9141) k,ugrs(ipr,k),gu0(ipr,k), & +! & vgrs(ipr,k),gv0(ipr,k), & +! & tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & gwdcu(ipr,k),gwdcv(ipr,k) +! enddo +!9141 format(i4,9(2x,f10.3)) + +! print *,' after gwdc in gbphys end print' +! endif +! endif + +! --- ... write out cloud top stress and wind tendencies + + if (Model%lssav) then + Diag%dugwd(:) = Diag%dugwd(:) + dusfcg(:)*dtf + Diag%dvgwd(:) = Diag%dvgwd(:) + dvsfcg(:)*dtf + + if (Model%ldiag3d) then + Diag%du3dt(:,:,4) = Diag%du3dt(:,:,4) + gwdcu(:,:) * dtf + Diag%dv3dt(:,:,4) = Diag%dv3dt(:,:,4) + gwdcv(:,:) * dtf + endif + endif ! end if_lssav + +! --- ... update the wind components with gwdc tendencies + + do k = 1, levs + do i = 1, im + eng0 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + Stateout%gu0(i,k) = Stateout%gu0(i,k) + gwdcu(i,k) * dtp + Stateout%gv0(i,k) = Stateout%gv0(i,k) + gwdcv(i,k) * dtp + eng1 = 0.5*(Stateout%gu0(i,k)*Stateout%gu0(i,k)+Stateout%gv0(i,k)*Stateout%gv0(i,k)) + Stateout%gt0(i,k) = Stateout%gt0(i,k) + (eng0-eng1)/(dtp*con_cp) + enddo +! if (lprnt) write(7000,*)' gu0=',gu0(ipr,k),' gwdcu=', +! &gwdcu(ipr,k), ' gv0=', gv0(ipr,k),' gwdcv=',gwdcv(ipr,k) +! &,' k=',k + enddo + +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' after tendency gwdc in gbphys start print' + +! write(*,9132) +!9132 format(//,10x,'after tendency gwdc in gbphys',//,' ilev',6x,& +! & 'ugrs',9x,'gu0',8x,'vgrs',9x,'gv0',8x, & +! & 'tgrs',9x,'gt0',8x,'gt0b',7x,'gwdcu',7x,'gwdcv',/) + +! do k = levs, 1, -1 +! write(*,9142) k,ugrs(ipr,k),gu0(ipr,k),vgrs(ipr,k), & +! & gv0(ipr,k),tgrs(ipr,k),gt0(ipr,k),dtdt(ipr,k), & +! & gwdcu(ipr,k),gwdcv(ipr,k) +! enddo +!9142 format(i4,9(2x,f10.3)) + +! print *,' after tendency gwdc in gbphys end print' +! endif +! endif + + endif ! end if_cnvgwd (convective gravity wave drag) + +! if (lprnt) write(7000,*)' aft cnvgwd gu0=',gu0(ipr,:) +! if (lprnt) write(7000,*)' aft cnvgwd gv0=',gv0(ipr,:) +! &,' lat=',lat,' kdt=',kdt,' me=',me +!----------------Convective gravity wave drag parameterization over -------- + + if (Model%ldiag3d) then + dtdt(:,:) = Stateout%gt0(:,:) + endif + if (Model%ldiag3d .or. Model%lgocart) then + dqdt(:,:,1) = Stateout%gq0(:,:,1) + endif + +! write(0,*)' before do_shoc shal clstp=',clstp,' kdt=',kdt, +! & ' lat=',lat +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' befshalgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' befshalgq0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' befshalgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' befshalgqw=',gq0(ipr,:,3),' kdt=',kdt +! endif + + if (.not. Model%do_shoc) then + + if (Model%shal_cnv) then ! Shallow convection parameterizations +! -------------------------------------- + if (Model%imfshalcnv == 1) then ! opr option now at 2014 + !----------------------- + call shalcnv (im, ix, levs, Model%jcap, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw, Stateout%gq0, & + Stateout%gt0, Stateout%gu0, Stateout%gv0, rain1, & + kbot, ktop, kcnv, islmsk, Statein%vvl, Model%ncld,& + Diag%hpbl, hflx, evap, ud_mf, dt_mf, cnvw, cnvc, & + Model%clam_shal, Model%c0s_shal, Model%c1_shal, & + Model%pgcon_shal) + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = Diag%rainc(:) + raincs(:) +! in shalcnv, 'cnvw' and 'cnvc' are not set to zero: + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + Tbd%phy_f3d(:,:,num2) = cnvw(:,:) + endif + + elseif (Model%imfshalcnv == 2) then + if (Model%ncld == 5 .and. Model%ext_rain_shal) then + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + endif + call mfshalcnv (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Statein%phil, clw(:,:,1:2), & + Stateout%gq0(:,:,1:1), & + Stateout%gt0, Stateout%gu0, Stateout%gv0, & + Model%ext_rain_shal, qrn, & + rain1, kbot, ktop, kcnv, islmsk, garea, & + Statein%vvl, Model%ncld, DIag%hpbl, ud_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_shal, Model%c0s_shal, Model%c1_shal, & + Model%pgcon_shal, Model%asolfac_shal, & + Model%evfact_shal, Model%evfactl_shal) + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = Diag%rainc(:) + raincs(:) +! in mfshalcnv, 'cnvw' and 'cnvc' are set to zero before computation starts: + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + num2 = Model%num_p3d + 2 + num3 = num2 + 1 + Tbd%phy_f3d(:,:,num2) = Tbd%phy_f3d(:,:,num2) + cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = Tbd%phy_f3d(:,:,num3) + cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = Tbd%phy_f3d(:,:,num2) + cnvw(:,:) + endif + if (Model%ncld == 5 .and. Model%ext_rain_shal) then + Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) + endif + + elseif (Model%imfshalcnv == 3) then + if(.not. Model%satmedmf .and. .not. Model%trans_trac) then + nsamftrac = 0 + else + nsamftrac = tottracer + endif + call samfshalcnv (im, ix, levs, dtp, itc, Model%ntchm, ntk, nsamftrac, & + del, Statein%prsl, Statein%pgr, Statein%phil, clw(:,:,1:nsamftrac+2), & + Stateout%gq0(:,:,1), Stateout%gt0, & + Stateout%gu0, Stateout%gv0, Model%fscav, & + rain1, kbot, ktop, kcnv, islmsk, garea, & + Statein%vvl, Model%ncld, Diag%hpbl, ud_mf, & + dt_mf, cnvw, cnvc, & + Model%clam_shal, Model%c0s_shal, Model%c1_shal, & + Model%pgcon_shal, Model%asolfac_shal) + + + raincs(:) = frain * rain1(:) + Diag%rainc(:) = Diag%rainc(:) + raincs(:) +! in mfshalcnv, 'cnvw' and 'cnvc' are set to zero before computation starts: + if ((Model%shcnvcw) .and. (Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then + num2 = Model%num_p3d + 2 + num3 = num2 + 1 + Tbd%phy_f3d(:,:,num2) = Tbd%phy_f3d(:,:,num2) + cnvw(:,:) + Tbd%phy_f3d(:,:,num3) = Tbd%phy_f3d(:,:,num3) + cnvc(:,:) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then + num2 = Model%num_p3d + 1 + Tbd%phy_f3d(:,:,num2) = Tbd%phy_f3d(:,:,num2) + cnvw(:,:) + endif + + elseif (Model%imfshalcnv == 0) then ! modified Tiedtke Shallow convecton + !----------------------------------- + levshc(:) = 0 + do k = 2, levs + do i = 1, im + dpshc = 0.3 * Statein%prsi(i,1) + if (Statein%prsi(i,1)-Statein%prsi(i,k) <= dpshc) levshc(i) = k + enddo + enddo + levshcm = 1 + do i = 1, im + levshcm = max(levshcm, levshc(i)) + enddo + +! if (lprnt) print *,' levshcm=',levshcm,' gt0sh=',gt0(ipr,:) +! &, ' lat=',lat + + if (Model%mstrat) then ! As in CFSv2 + call shalcv (im, ix, levshcm, dtp, del, Statein%prsi, & + Statein%prsl, Statein%prslk,kcnv, Stateout%gq0, & + Stateout%gt0, levshc, Statein%phil, kinver, & + ctei_r, ctei_rml, lprnt, ipr) + else + call shalcvt3 (im, ix, levshcm, dtp, del, Statein%prsi, & + Statein%prsl, Statein%prslk, kcnv, & + Stateout%gq0, Stateout%gt0) + endif +! if (lprnt) print *,' levshcm=',levshcm,' gt0sha=',gt0(ipr,:) + + endif ! end if_imfshalcnv + endif ! end if_shal_cnv + + if (Model%lssav) then +! update dqdt_v to include moisture tendency due to shallow convection + if (Model%lgocart) then + do k = 1, levs + do i = 1, im + tem = (Stateout%gq0(i,k,1)-dqdt(i,k,1)) * frain + Coupling%dqdti(i,k) = Coupling%dqdti(i,k) + tem + enddo + enddo + endif + if (Model%ldiag3d) then + Diag%dt3dt(:,:,5) = Diag%dt3dt(:,:,5) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,3) = Diag%dq3dt(:,:,3) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif ! end if_lssav + +! + do k = 1, levs + do i = 1, im + if (clw(i,k,2) <= -999.0) clw(i,k,2) = 0.0 + enddo + enddo + +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' befshgt0=',gt0(ipr,:) +! write(0,*) ' befshgq0=',gq0(ipr,:,1) +! endif + + elseif (Model%shocaftcnv) then ! if do_shoc is true and shocaftcnv is true call shoc + if (Model%ncld == 2) then + skip_macro = Model%do_shoc + ncpl(:,:) = Stateout%gq0(:,:,Model%ntlnc) + ncpi(:,:) = Stateout%gq0(:,:,Model%ntinc) + +! else +! if (clw(1,1,2) < -999.0) then ! if clw is not partitioned to ice and water +! do k=1,levs +! do i=1,im +! tem = gq0(i,k,ntcw) & +! & * max(0.0, MIN(1.0, (TCR-gt0(i,k))*TCRF)) +! clw(i,k,1) = tem ! ice +! clw(i,k,2) = gq0(i,k,ntcw) - tem ! water +! enddo +! enddo +! endif ! Anning ncld ==2 + endif + qpl(:,:) = 0.0 + qpi(:,:) = 0.0 +! dtshoc = 60.0 +! nshocm = (dtp/dtshoc) + 0.001 +! dtshoc = dtp / nshocm +! do nshoc=1,nshocm +! call shoc(im, 1, levs, levs+1, dtp, me, lat, & +!! call shoc(im, 1, levs, levs+1, dtshoc, me, lat, & +! & prsl(1:im,:), phii (1:im,:), phil(1:im,:),& +! & gu0(1:im,:),gv0(1:im,:), vvl(1:im,:), gt0(1:im,:), & +! & gq0(1:im,:,1), & +! & clw(1:im,:,1), clw(1:im,:,2), qpi, qpl, sgs_cld(1:im,:)& +! &, gq0(1:im,:,ntke), & +! & phy_f3d(1:im,:,ntot3d-1), phy_f3d(1:im,:,ntot3d), & +! & lprnt, ipr, & +! & con_cp, con_g, con_hvap, con_hfus, con_hvap+con_hfus, & +! & con_rv, con_rd, con_pi, con_fvirt) + +!GFDL replace lat with "1: +! call shoc(ix, im, 1, levs, levs+1, dtshoc, me, lat, & + call shoc (ix, im, 1, levs, levs+1, dtp, me, 1, Statein%prsl(1,1), & + Statein%phii(1,1), Statein%phil(1,1), Stateout%gu0(1,1), & + Stateout%gv0(1,1), Statein%vvl(1,1), Stateout%gt0(1,1), & + Stateout%gq0(1,1,1), clw(1,1,1), clw(1,1,2), qpi, qpl,rhc, & + Model%sup, Tbd%phy_f3d(1,1,Model%ntot3d-2), & + Stateout%gq0(1,1,Model%ntke), hflx, evap, prnum, & + Tbd%phy_f3d(1,1,Model%ntot3d-1), Tbd%phy_f3d(1,1,Model%ntot3d),& + lprnt, ipr, ncpl, ncpi, kdt) + + if ((Model%ntlnc > 0) .and. (Model%ntinc > 0) .and. (Model%ncld >= 2)) then + Stateout%gq0(:,:,Model%ntlnc) = ncpl(:,:) + Stateout%gq0(:,:,Model%ntinc) = ncpi(:,:) + endif + +! +! do k=1,levs +! write(1000+me,*)' maxtkh=',maxval(phy_f3d(1:im,k,ntot3d-1)), & +! ' k=',k,' kdt=',kdt,' lat=',lat +! enddo + +! write(0,*)' aft shoc gt0=',gt0(1,:),' lat=',lat +! write(0,*)' aft shoc gq0=',gq0(1,:,1),' lat=',lat +! write(0,*)' aft shoc gu0=',gu0(1,:),' lat=',lat +! + endif ! if( .not. do_shoc) +! +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftshgt0=',gt0(ipr,:) +! write(0,*) ' aftshgq0=',gq0(ipr,:,1) +! endif + +!------------------------------------------------------------------------------ +! --- update the tracers due to deep & shallow cumulus convective transport +! (except for suspended water and ice) +! + if (tottracer > 0) then + do n=1,tottracer + do k=1,levs + do i=1,im + Stateout%gq0(i,k,clw_trac_idx(n)) = clw(i,k,2+n) + enddo + enddo + enddo + endif + + + if (Model%ntcw > 0) then + +! for microphysics + if (Model%ncld == 2) then ! morrison microphysics + Stateout%gq0(:,:,Model%ntiw) = clw(:,:,1) ! ice + Stateout%gq0(:,:,Model%ntcw) = clw(:,:,2) ! water + elseif (Model%num_p3d == 4) then ! if_num_p3d + Stateout%gq0(:,:,Model%ntcw) = clw(:,:,1) + clw(:,:,2) + endif ! end if_num_p3d + + else ! if_ntcw + + clw(:,:,1) = clw(:,:,1) + clw(:,:,2) + + + endif ! end if_ntcw + +! Legacy routine which determines convectve clouds - should be removed at some point + + call cnvc90 (Model%clstp, im, ix, Diag%rainc, kbot, ktop, levs, Statein%prsi, & + Tbd%acv, Tbd%acvb, Tbd%acvt, Cldprop%cv, Cldprop%cvb, Cldprop%cvt) + + if (Model%moist_adj) then ! moist convective adjustment +! --------------------------- +! +! To call moist convective adjustment +! +! if (lprnt) then +! print *,' prsl=',prsl(ipr,:) +! print *,' del=',del(ipr,:) +! print *,' gt0b=',gt0(ipr,:) +! print *,' gq0b=',gq0(ipr,:,1) +! endif + + call mstcnv (im, ix, levs, dtp, Stateout%gt0, Stateout%gq0, & + Statein%prsl,del, Statein%prslk, rain1, & + Stateout%gq0(1,1,Model%ntcw), rhc, lprnt, ipr) + +! if (lprnt) then +! print *,' rain1=',rain1(ipr),' rainc=',rainc(ipr) +! print *,' gt0a=',gt0(ipr,:) +! print *,' gq0a=',gq0(ipr,:,1) +! endif + Diag%rainc(:) = Diag%rainc(:) + frain * rain1(:) + + if(Model%lssav) then +! update dqdt_v to include moisture tendency due to surface processes +! dqdt_v : instaneous moisture tendency (kg/kg/sec) +! if (lgocart) then +! do k=1,levs +! do i=1,im +! tem = (gq0(i,k,1)-dqdt(i,k,1)) * frain +! dqdt_v(i,k) = dqdt_v(i,k) + tem +! dqdt_v(i,k) = dqdt_v(i,k) / dtf +! enddo +! enddo +! endif + if (Model%ldiag3d) then + Diag%dt3dt(:,:,4) = Diag%dt3dt(:,:,4) + (Stateout%gt0(:,:) -dtdt(:,:) ) * frain + Diag%dq3dt(:,:,2) = Diag%dq3dt(:,:,2) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif + endif ! moist convective adjustment over +! + if (Model%ldiag3d .or. Model%do_aw) then + dtdt(:,:) = Stateout%gt0(:,:) + dqdt(:,:,1) = Stateout%gq0(:,:,1) + do n=Model%ntcw,Model%ntcw+Model%ncld-1 + dqdt(:,:,n) = Stateout%gq0(:,:,n) + enddo + endif + +! dqdt_v : instaneous moisture tendency (kg/kg/sec) + if (Model%lgocart) then + Coupling%dqdti(:,:) = Coupling%dqdti(:,:) / dtf + endif +! +! grid-scale condensation/precipitations and microphysics parameterization +! ------------------------------------------------------------------------ + + if (Model%ncld == 0) then ! no cloud microphysics + + call lrgscl (ix, im, levs, dtp, Stateout%gt0, Stateout%gq0, & + Statein%prsl, del, Statein%prslk, rain1, clw) + + elseif (Model%ncld == 1) then ! microphysics with single cloud condensate + + if (Model%num_p3d == 4) then ! call zhao/carr/sundqvist microphysics + + if (Model%npdf3d /= 3) then ! without pdf clouds + +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' beflsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' beflsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' beflsgw0=',gq0(ipr,:,3),' kdt=',kdt +! endif + ! ------------------ + if (Model%do_shoc) then + call precpd_shoc (im, ix, levs, dtp, del, Statein%prsl, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, & + psautco_l, prautco_l, Model%evpco, Model%wminco, & + Tbd%phy_f3d(1,1,Model%ntot3d-2), lprnt, ipr) + else + call gscond (im, ix, levs, dtp, dtf, Statein%prsl, Statein%pgr, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gt0, Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & + Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc,lprnt, ipr) + + call precpd (im, ix, levs, dtp, del, Statein%prsl, & + Stateout%gq0(1,1,1), Stateout%gq0(1,1,Model%ntcw), & + Stateout%gt0, rain1, Diag%sr, rainp, rhc, psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif +! if (lprnt) then +! write(0,*)' prsl=',prsl(ipr,:) +! write(0,*) ' del=',del(ipr,:) +! write(0,*) ' aftlsgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! write(0,*) ' aftlsgw0=',gq0(ipr,:,3),' kdt=',kdt +! write(0,*)' aft precpd rain1=',rain1(1:3),' lat=',lat +! endif + else ! with pdf clouds + ! --------------- + call gscondp (im, ix, levs, dtp, dtf, Statein%prsl, & + Statein%pgr, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + Tbd%phy_f3d(1,1,1), Tbd%phy_f3d(1,1,2), & + Tbd%phy_f2d(1,1), Tbd%phy_f3d(1,1,3), & + Tbd%phy_f3d(1,1,4), Tbd%phy_f2d(1,2), rhc, & + Tbd%phy_f3d(1,1,Model%num_p3d+1), Model%sup, & + lprnt, ipr, kdt) + + call precpdp (im, ix, levs, dtp, del, Statein%prsl, & + Statein%pgr, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), Stateout%gt0, & + rain1, Diag%sr, rainp, rhc, & + Tbd%phy_f3d(1,1,Model%num_p3d+1), psautco_l, & + prautco_l, Model%evpco, Model%wminco, lprnt, ipr) + endif ! end of grid-scale precip/microphysics options + endif ! end if_num_p3d + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr),' rainc=',rainc(ipr),' lat=',lat + + elseif (Model%ncld == 2) then ! MGB double-moment microphysics +! Acheng used clw here for other code to run smoothly and minimum change +! to make the code work. However, the nc and clw should be treated +! in other procceses too. August 28/2015; Hope that can be done next +! year. I believe this will make the physical interaction more reasonable +! Anning 12/5/2015 changed ntcw hold liquid only + if (Model%do_shoc) then + if (Model%fprcp == 0) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + Tbd%phy_f3d(:,:,1) = Tbd%phy_f3d(:,:,Model%ntot3d-2) ! clouds from shoc + end if + elseif ((Model%imfdeepcnv >= 0) .or. (Model%imfshalcnv > 0)) then + if (Model%fprcp == 0) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + ! clouds from t-dt and cnvc + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + Tbd%phy_f3d(:,:,1) = max(0.0, min(1.0,Tbd%phy_f3d(:,:,1)+cnvc(:,:))) + ! clouds from t-dt and cnvc + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + endif + else + ! clouds from t-dt and cnvc + if (Model%fprcp == 0 ) then + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = 0. + qsnw(:,:) = 0. + ncpr(:,:) = 0. + ncps(:,:) = 0. + Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) + else + clw(:,:,1) = Stateout%gq0(:,:,Model%ntiw) ! ice + clw(:,:,2) = Stateout%gq0(:,:,Model%ntcw) ! water + qrn(:,:) = Stateout%gq0(:,:,Model%ntrw) + qsnw(:,:) = Stateout%gq0(:,:,Model%ntsw) + ncpr(:,:) = Stateout%gq0(:,:,Model%ntrnc) + ncps(:,:) = Stateout%gq0(:,:,Model%ntsnc) + Tbd%phy_f3d(:,:,1) = min(1.0, Tbd%phy_f3d(:,:,1)+cnvc(:,:)) + endif + endif +! notice clw ix instead of im +! call m_micro_driver(im,ix,levs,flipv,del,dtp,prsl,prsi, +! & prslk,prsik,pgr,vvl,clw(1,1,2), QLCN, clw(1,1,1),QICN, +! if (lprnt) write(0,*)' cnv_mfdbef=',cnv_mfd(ipr,:),' flipv=',flipv +! if(lprnt) write(0,*) ' befgq0=',gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1bef=',clw(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw2bef=',clw(ipr,:,2),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsb=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! txa(:,:) = gq0(:,:,1) + call m_micro_driver (im, ix, levs, Model%flipv, dtp, Statein%prsl, & + Statein%prsi, Statein%prslk, Statein%prsik, & + Statein%vvl, clw(1,1,2), QLCN, clw(1,1,1), QICN, & + Radtend%htrlw, Radtend%htrsw, w_upi, cf_upi, & + FRLAND, Diag%HPBL, CNV_MFD, CNV_PRC3, CNV_DQLDT, & + CLCN, Stateout%gu0, Stateout%gv0, Diag%dusfc, & + Diag%dvsfc, dusfc1, dvsfc1, dusfc1, dvsfc1, & + CNV_FICE, CNV_NDROP, CNV_NICE, Stateout%gq0(1,1,1), & + Stateout%gq0(1,1,Model%ntcw), & + Stateout%gq0(1,1,Model%ntiw), Stateout%gt0, rain1, & + Diag%sr, Stateout%gq0(1,1,Model%ntlnc), & + Stateout%gq0(1,1,Model%ntinc), Model%fprcp, qrn, & + qsnw, ncpr, ncps, Tbd%phy_f3d(1,1,1), kbot, & + Model%aero_in, skip_macro, cn_prc, cn_snr, lprnt, & + ipr, kdt, Grid%xlat, Grid%xlon) + +! write(1000+me,*)' at latitude = ',lat +! tx1 = 1000.0 +! call moist_bud(im,ix,ix,levs,me,kdt,con_g,tx1,del,rain1 +! &, txa, clw(1,1,2), clw(1,1,1) +! &, gq0(1,1,1),gq0(1,1,ntcw),gq0(1,1,ntcw+1),' m_micro ') + +! if (lprnt) write(0,*) ' rain1=',rain1(ipr)*86400.0, +! &' rainc=',rainc(ipr)*86400.0 +! &,' cn_prc=',cn_prc(ipr),' cn_snr=',cn_snr(ipr) +! if (lprnt) write(0,*) ' aftlsgq0=',gq0(ipr,:,1),' kdt=',kdt +! if (lprnt) write(0,*)' clw1aft=',gq0(ipr,:,ntiw),' kdt=',kdt +! if (lprnt) write(0,*)' cloudsm=',phy_f3d(ipr,:,1)*100,' kdt=',kdt +! if (lprnt) write(0,*)' clw2aft=',gq0(ipr,:,ntcw),' kdt=',kdt + + if (Model%fprcp == 1) then + Stateout%gq0(:,:,Model%ntrw) = qrn(:,:) + Stateout%gq0(:,:,Model%ntsw) = qsnw(:,:) + Stateout%gq0(:,:,Model%ntrnc) = ncpr(:,:) + Stateout%gq0(:,:,Model%ntsnc) = ncps(:,:) + endif + + elseif (Model%ncld == 5) then ! GFDL Cloud microphysics + + if (Model%do_inline_mp) then ! GFDL Cloud microphysics + + tem = dtp * con_p001 / con_day + Statein%prer(:) = Statein%prer(:) * tem + Statein%pres(:) = Statein%pres(:) * tem + Statein%prei(:) = Statein%prei(:) * tem + Statein%preg(:) = Statein%preg(:) * tem + rain1(:) = Statein%prer(:)+Statein%pres(:)+Statein%prei(:)+Statein%preg(:) + Diag%ice(:) = Statein%prei(:) + Diag%snow(:) = Statein%pres(:) + Diag%graupel(:) = Statein%preg(:) + do i = 1, im + ! use rainmin following GFS + diag_rain = Statein%prer(i) + if(Statein%prer(i) < rainmin) diag_rain = zero + if(Statein%prei(i) < rainmin) Diag%ice(i) = zero + if(Statein%pres(i) < rainmin) Diag%snow(i) = zero + if(Statein%preg(i) < rainmin) Diag%graupel(i) = zero + diag_rain1 = diag_rain + Diag%ice(i) + Diag%snow(i) + Diag%graupel(i) + if (diag_rain1 > rainmin) then + Diag%sr(i) = (Diag%ice(i) + Diag%snow(i) + Diag%graupel(i)) & + / diag_rain1 + else + Diag%sr(i) = zero + endif + enddo + + else + +#ifdef fvGFS_2017 + land (:,1) = frland(:) + area (:,1) = Grid%area(:) + rain0 (:,1) = 0.0 + snow0 (:,1) = 0.0 + ice0 (:,1) = 0.0 + graupel0 (:,1) = 0.0 + cond0 (:,1) = 0.0 + dep0 (:,1) = 0.0 + reevap0 (:,1) = 0.0 + sub0 (:,1) = 0.0 + qn1 (:,1,:) = 0.0 + qv_dt (:,1,:) = 0.0 + ql_dt (:,1,:) = 0.0 + qr_dt (:,1,:) = 0.0 + qi_dt (:,1,:) = 0.0 + qs_dt (:,1,:) = 0.0 + qg_dt (:,1,:) = 0.0 + qa_dt (:,1,:) = 0.0 + pt_dt (:,1,:) = 0.0 + udt (:,1,:) = 0.0 + vdt (:,1,:) = 0.0 + do k = 1, levs + qv1 (:,1,k) = Stateout%gq0(:,levs-k+1,1 ) + ql1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntcw) + qr1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntrw) + qi1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntiw) + qs1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntsw) + qg1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntgl) + qa1 (:,1,k) = Stateout%gq0(:,levs-k+1,Model%ntclamt) + pt (:,1,k) = Stateout%gt0(:,levs-k+1) + w (:,1,k) = -Statein%vvl(:,levs-k+1)*con_rd*Stateout%gt0(:,levs-k+1) & + & /Statein%prsl(:,levs-k+1)/con_g + uin (:,1,k) = Stateout%gu0(:,levs-k+1) + vin (:,1,k) = Stateout%gv0(:,levs-k+1) + delp (:,1,k) = del(:,levs-k+1) + dz (:,1,k) = (Statein%phii(:,levs-k+1)-Statein%phii(:,levs-k+2))/con_g + enddo + + seconds = mod(nint(Model%fhour*3600),86400) + + call gfdl_cloud_microphys_driver(qv1, ql1, qr1, qi1, qs1, qg1, qa1, & + qn1, qv_dt, ql_dt, qr_dt, qi_dt, & + qs_dt, qg_dt, qa_dt, pt_dt, pt, w, & + uin, vin, udt, vdt, dz, delp, & + area, dtp, land, rain0, snow0, & + ice0, graupel0, .false., .true., & + 1, im, 1, 1, 1, levs, 1, levs, & + seconds) + + tem = dtp * con_p001 / con_day + rain1(:) = (rain0(:,1)+snow0(:,1)+ice0(:,1)+graupel0(:,1)) * tem + Diag%ice(:) = ice0 (:,1) * tem + Diag%snow(:) = snow0 (:,1) * tem + Diag%graupel(:) = graupel0(:,1) * tem + do i = 1, im + ! use rainmin threshold following GFS + diag_rain = rain0(i,1) * tem + if(diag_rain < rainmin) diag_rain = zero + if(Diag%snow(i) < rainmin) Diag%snow(i) = zero + if(Diag%ice(i) < rainmin) Diag%ice(i) = zero + if(Diag%graupel(i) < rainmin) Diag%graupel(i) = zero + diag_rain1 = diag_rain + Diag%snow(i) + Diag%ice(i) + Diag%graupel(i) + if (diag_rain1 > rainmin) then + Diag%sr(i) = (Diag%snow(i) + Diag%ice(i) + Diag%graupel(i)) & + / diag_rain1 + else + Diag%sr(i) = zero + endif + enddo + do k = 1, levs + Stateout%gq0(:,k,1 ) = qv1(:,1,levs-k+1) + qv_dt(:,1,levs-k+1) * dtp + Stateout%gq0(:,k,Model%ntcw) = ql1(:,1,levs-k+1) + ql_dt(:,1,levs-k+1) * dtp + Stateout%gq0(:,k,Model%ntrw) = qr1(:,1,levs-k+1) + qr_dt(:,1,levs-k+1) * dtp + Stateout%gq0(:,k,Model%ntiw) = qi1(:,1,levs-k+1) + qi_dt(:,1,levs-k+1) * dtp + Stateout%gq0(:,k,Model%ntsw) = qs1(:,1,levs-k+1) + qs_dt(:,1,levs-k+1) * dtp + Stateout%gq0(:,k,Model%ntgl) = qg1(:,1,levs-k+1) + qg_dt(:,1,levs-k+1) * dtp + Stateout%gq0(:,k,Model%ntclamt) = qa1(:,1,levs-k+1) + qa_dt(:,1,levs-k+1) * dtp + Stateout%gt0(:,k) = Stateout%gt0(:,k) + pt_dt(:,1,levs-k+1) * dtp + Stateout%gu0(:,k) = Stateout%gu0(:,k) + udt (:,1,levs-k+1) * dtp + Stateout%gv0(:,k) = Stateout%gv0(:,k) + vdt (:,1,levs-k+1) * dtp + enddo + +#else + hs = Sfcprop%oro(:) * con_g + gsize = sqrt(Grid%area(:)) + rain0 = 0.0 + snow0 = 0.0 + ice0 = 0.0 + graupel0 = 0.0 + cond0 = 0.0 + dep0 = 0.0 + reevap0 = 0.0 + sub0 = 0.0 + qnl1 = 0.0 + qni1 = 0.0 + do k = 1, levs + w (:,k) = -Statein%vvl(:,levs-k+1)*con_rd*Stateout%gt0(:,levs-k+1) & + & /Statein%prsl(:,levs-k+1)/con_g + delp (:,k) = del(:,levs-k+1) + dz (:,k) = (Statein%phii(:,levs-k+1)-Statein%phii(:,levs-k+2))/con_g + enddo + + call gfdl_cld_mp_driver(Stateout%gq0(:,levs:1:-1,1), Stateout%gq0(:,levs:1:-1,Model%ntcw), & + Stateout%gq0(:,levs:1:-1,Model%ntrw), Stateout%gq0(:,levs:1:-1,Model%ntiw), & + Stateout%gq0(:,levs:1:-1,Model%ntsw), Stateout%gq0(:,levs:1:-1,Model%ntgl), & + Stateout%gq0(:,levs:1:-1,Model%ntclamt), qnl1(:,levs:1:-1), qni1(:,levs:1:-1), & + Stateout%gt0(:,levs:1:-1), w, Stateout%gu0(:,levs:1:-1), & + Stateout%gv0(:,levs:1:-1), dz, delp, gsize, dtp, hs, rain0, snow0, ice0, & + graupel0, .false., 1, im, 1, levs, q_con(:,levs:1:-1), cappa(:,levs:1:-1), & + .false., te(:,levs:1:-1), cond0, dep0, reevap0, sub0, .true., Model%do_inline_mp) + + tem = dtp * con_p001 / con_day + rain0(:) = rain0(:) * tem + snow0(:) = snow0(:) * tem + ice0(:) = ice0(:) * tem + graupel0(:) = graupel0(:) * tem + rain1(:) = rain0(:)+snow0(:)+ice0(:)+graupel0(:) + Diag%ice(:) = ice0 (:) + Diag%snow(:) = snow0 (:) + Diag%graupel(:) = graupel0(:) + do i = 1, im + ! use rainmin threshold following GFS + diag_rain = rain0(i) + if(rain0(i) < rainmin) diag_rain = zero + if(snow0(i) < rainmin) Diag%snow(i) = zero + if(ice0(i) < rainmin) Diag%ice(i) = zero + if(graupel0(i) < rainmin) Diag%graupel(i) = zero + diag_rain1 = diag_rain + Diag%snow(i) + Diag%ice(i) + Diag%graupel(i) + if (diag_rain1 > rainmin) then + Diag%sr(i) = (Diag%snow(i) + Diag%ice(i) + Diag%graupel(i)) & + / diag_rain1 + else + Diag%sr(i) = zero + endif + enddo + +#endif + endif + + endif ! end if_ncld +! if (lprnt) write(0,*)' rain1 after ls=',rain1(ipr) +! + if (Model%do_aw) then +! Arakawa-Wu adjustment of large-scale microphysics tendencies: +! reduce by factor of (1-sigma) +! these are microphysics increments. We want to keep (1-sigma) of the increment, +! we will remove sigma*increment from final values +! fsigma = 0. ! don't apply any AW correction, in addition comment next line +! fsigma = sigmafrac + +! adjust sfc rainrate for conservation +! vertically integrate reduction of water increments, reduce precip by that amount + + temrain1(:) = 0.0 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) + Stateout%gt0(i,k) = Stateout%gt0(i,k) - tem1 * (Stateout%gt0(i,k)-dtdt(i,k)) + tem2 = tem1 * (Stateout%gq0(i,k,1)-dqdt(i,k,1)) + Stateout%gq0(i,k,1) = Stateout%gq0(i,k,1) - tem2 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + * tem2 * onebg + enddo + enddo + do n=Model%ntcw,Model%ntcw+Model%ncld-1 + do k = 1,levs + do i = 1,im + tem1 = sigmafrac(i,k) * (Stateout%gq0(i,k,n)-dqdt(i,k,n)) + Stateout%gq0(i,k,n) = Stateout%gq0(i,k,n) - tem1 + temrain1(i) = temrain1(i) - (Statein%prsi(i,k)-Statein%prsi(i,k+1)) & + * tem1 * onebg + enddo + enddo + enddo +! write(1000+me,*)' rain1=',rain1(4),' temrain1=',temrain1(i)*0.001 + rain1(:) = max(rain1(:) - temrain1(:)*0.001, 0.0_kind_phys) + endif + + Diag%rain(:) = Diag%rainc(:) + frain * rain1(:) + + + if (Model%lsm == Model%lsm_noahmp) then + if (Model%ncld == 5 ) then + !GJF: Should all precipitation rates have the same denominator below? + ! It appears that Diag%rain and Diag%rainc are on the dynamics time step, + ! but Diag%snow,graupel,ice are on the physics time step? This doesn't + ! matter as long as dtp=dtf (frain=1). + tem = 1.0 / (dtp*con_p001) + Sfcprop%draincprv(:) = tem * Diag%rainc(:) + Sfcprop%drainncprv(:) = tem * (frain * rain1(:)) + Sfcprop%dsnowprv(:) = tem * Diag%snow(:) + Sfcprop%dgraupelprv(:) = tem * Diag%graupel(:) + Sfcprop%diceprv(:) = tem * Diag%ice(:) + else + Sfcprop%draincprv(:) = 0.0 + Sfcprop%drainncprv(:) = 0.0 + Sfcprop%dsnowprv(:) = 0.0 + Sfcprop%dgraupelprv(:) = 0.0 + Sfcprop%diceprv(:) = 0.0 + endif + end if ! if (Model%lsm == Model%lsm_noahmp) + + + if (Model%cal_pre) then ! hchuang: add dominant precipitation type algorithm + i = min(3,Model%num_p3d) + call calpreciptype (kdt, Model%nrcm, im, ix, levs, levs+1, & + Tbd%rann, Grid%xlat, Grid%xlon, Stateout%gt0, & + Stateout%gq0, Statein%prsl, Statein%prsi, & + Diag%rain, Statein%phii, Model%num_p3d, & + Sfcprop%tsfc, Diag%sr, Tbd%phy_f3d(1,1,i), & ! input + domr, domzr, domip, doms) ! output +! +! if (lprnt) print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ' +! &,DOMR(ipr),DOMZR(ipr),DOMIP(ipr),DOMS(ipr) +! do i=1,im +! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. +! & abs(xlat(i)*57.29578-40.0) .lt. 0.2) +! & print*,'debug calpreciptype: DOMR,DOMZR,DOMIP,DOMS ', +! & DOMR(i),DOMZR(i),DOMIP(i),DOMS(i) +! end do +! HCHUANG: use new precipitation type to decide snow flag for LSM snow accumulation + + ! the following is not for GFDL Cloud microphysics + if( Model%ncld /= 5) then + do i=1,im + if(doms(i) > 0.0 .or. domip(i) > 0.0) then + Sfcprop%srflag(i) = 1. + else + Sfcprop%srflag(i) = 0. + end if + enddo + endif + endif + + if (Model%lssav) then + Diag%cnvprcp(:) = Diag%cnvprcp(:) + Diag%rainc(:) + Diag%totprcp(:) = Diag%totprcp(:) + Diag%rain(:) + Diag%totice (:) = Diag%totice (:) + Diag%ice(:) + Diag%totsnw (:) = Diag%totsnw (:) + Diag%snow(:) + Diag%totgrp (:) = Diag%totgrp (:) + Diag%graupel(:) + + Diag%cnvprcpb(:) = Diag%cnvprcpb(:) + Diag%rainc(:) + Diag%totprcpb(:) = Diag%totprcpb(:) + Diag%rain(:) + Diag%toticeb (:) = Diag%toticeb (:) + Diag%ice(:) + Diag%totsnwb (:) = Diag%totsnwb (:) + Diag%snow(:) + Diag%totgrpb (:) = Diag%totgrpb (:) + Diag%graupel(:) + + if (Model%ldiag3d) then + Diag%dt3dt(:,:,6) = Diag%dt3dt(:,:,6) + (Stateout%gt0(:,:)-dtdt(:,:)) * frain + Diag%dq3dt(:,:,4) = Diag%dq3dt(:,:,4) + (Stateout%gq0(:,:,1)-dqdt(:,:,1)) * frain + endif + endif + +! --- ... estimate t850 for rain-snow decision + + t850(:) = Stateout%gt0(:,1) + + do k = 1, levs-1 + do i = 1, im + if (Statein%prsl(i,k) > p850 .and. Statein%prsl(i,k+1) <= p850) then + t850(i) = Stateout%gt0(i,k) - (Statein%prsl(i,k)-p850) / & + (Statein%prsl(i,k)-Statein%prsl(i,k+1)) * & + (Stateout%gt0(i,k)-Stateout%gt0(i,k+1)) + endif + enddo + enddo + +! --- ... lu: snow-rain detection is performed in land/sice module + + if (Model%cal_pre) then ! hchuang: new precip type algorithm defines srflag + Sfcprop%tprcp(:) = max(0.0, Diag%rain(:)) ! clu: rain -> tprcp + else + do i = 1, im + Sfcprop%tprcp(i) = max(0.0, Diag%rain(i) )! clu: rain -> tprcp + Sfcprop%srflag(i) = 0. ! clu: default srflag as 'rain' (i.e. 0) + if (Model%ncld == 5) then +! determine convective rain/snow by surface temperature +! determine large-scale rain/snow by rain/snow coming out directly from MP + if (Sfcprop%tsfc(i) .ge. 273.15) then + crain = Diag%rainc(i) + csnow = 0.0 + else + crain = 0.0 + csnow = Diag%rainc(i) + endif + if (Model%do_inline_mp) then ! GFDL Cloud microphysics + if ((Statein%pres(i)+Statein%prei(i)+Statein%preg(i)+csnow) .gt. (Statein%prer(i)+crain)) then + Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) + endif + else +#ifdef fvGFS_2017 + if ((snow0(i,1)+ice0(i,1)+graupel0(i,1)+csnow) .gt. (rain0(i,1)+crain)) then +#else + if ((snow0(i)+ice0(i)+graupel0(i)+csnow) .gt. (rain0(i)+crain)) then +#endif + Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) + endif + endif + else + if (t850(i) <= 273.16) then + Sfcprop%srflag(i) = 1. ! clu: set srflag to 'snow' (i.e. 1) + endif + endif + enddo + endif + +! --- ... coupling insertion + + if (Model%cplflx) then + do i = 1, im + if (t850(i) > 273.16) then + Coupling%rain_cpl(i) = Coupling%rain_cpl(i) + Diag%rain(i) + else + Coupling%snow_cpl(i) = Coupling%snow_cpl(i) + Diag%rain(i) + endif + enddo + endif + +! --- ... end coupling insertion + +!!! update surface diagnosis fields at the end of phys package +!!! this change allows gocart to use filtered wind fields +!!! + if (Model%lgocart) then + call sfc_diag (im, Statein%pgr, Stateout%gu0, Stateout%gv0, & + Stateout%gt0, Stateout%gq0, Sfcprop%tsfc, qss, & + Sfcprop%f10m, Diag%u10m, Diag%v10m, Sfcprop%t2m, & + Sfcprop%q2m, work3, evap, Sfcprop%ffmm, & + Sfcprop%ffhh, fm10, fh2) + + if (Model%lssav) then + Diag%tmpmax (:) = max(Diag%tmpmax (:),Sfcprop%t2m(:)) + Diag%tmpmin (:) = min(Diag%tmpmin (:),Sfcprop%t2m(:)) + Diag%spfhmax(:) = max(Diag%spfhmax(:),Sfcprop%q2m(:)) + Diag%spfhmin(:) = min(Diag%spfhmin(:),Sfcprop%q2m(:)) + !find max wind speed then decompose + do i=1, im + tem = sqrt(Diag%u10m(i)**2 + Diag%v10m(i)**2 ) + if (tem > Diag%wind10mmax(i)) then + Diag%wind10mmax(i) = tem + Diag%u10mmax(i) = Diag%u10m(i) + Diag%v10mmax(i) = Diag%v10m(i) + endif + !Compute dew point, first using vapor pressure + tem = max(Statein%pgr(i) * Sfcprop%q2m(i) / ( con_eps - con_epsm1 * Sfcprop%q2m(i)), 1.e-8) + Diag%dpt2m(i) = 243.5 / ( ( 17.67 / log(tem/611.2) ) - 1.) + 273.14 + enddo + endif + endif + +! --- ... total runoff is composed of drainage into water table and +! runoff at the surface and is accumulated in unit of meters + if (Model%lssav) then + tem = dtf + Diag%runoff(:) = Diag%runoff(:) + (drain(:)+runof(:)) * tem + Diag%srunoff(:) = Diag%srunoff(:) + runof(:) * tem + endif + +! --- ... xw: return updated ice thickness & concentration to global array + do i = 1, im + if (islmsk(i) == 2) then + Sfcprop%hice(i) = zice(i) + Sfcprop%fice(i) = cice(i) + Sfcprop%tisfc(i) = tice(i) + else + Sfcprop%hice(i) = 0.0 + Sfcprop%fice(i) = 0.0 + Sfcprop%tisfc(i) = Sfcprop%tsfc(i) + endif + enddo + +! --- ... return updated smsoil and stsoil to global arrays + Sfcprop%smc(:,:) = smsoil(:,:) + Sfcprop%stc(:,:) = stsoil(:,:) + Sfcprop%slc(:,:) = slsoil(:,:) + +! --- ... calculate column precipitable water "pwat" + Diag%pwat(:) = 0.0 + tem = dtf * 0.03456 / 86400.0 + do k = 1, levs + work1(:) = 0.0 + if (Model%ncld > 0) then + do ic = Model%ntcw, Model%ntcw+Model%ncld-1 + work1(:) = work1(:) + Stateout%gq0(:,k,ic) + enddo + endif + Diag%pwat(:) = Diag%pwat(:) + del(:,k)*(Stateout%gq0(:,k,1)+work1(:)) +! if (lprnt .and. i == ipr) write(0,*)' gq0=', +! &gq0(i,k,1),' qgrs=',qgrs(i,k,1),' work2=',work2(i),' k=',k + enddo + Diag%pwat(:) = Diag%pwat(:) * onebg + +! write(1000+me,*)' pwat=',pwat(i),'i=',i,', +! &' rain=',rain(i)*1000.0,' dqsfc1=',dqsfc1(i)*tem,' kdt=',kdt +! &,' e-p=',dqsfc1(i)*tem-rain(i)*1000.0 +! if (lprnt) write(0,*)' pwat=',pwat(ipr),', +! &' rain=',rain(ipr)*1000.0,' dqsfc1=',dqsfc1(ipr)*tem,' kdt=',kdt +! &,' e-p=',dqsfc1(ipr)*tem-rain(ipr)*1000.0 + +! +! if (lprnt .and. rain(ipr) > 5) call mpi_quit(5678) +! if (lat == 45) write(1000+me,*)' pwat=',pwat(1),' kdt=',kdt +! if (lprnt) then +! write(7000,*) ' endgu0=',gu0(ipr,:),' kdt=',kdt +! write(7000,*) ' endgv0=',gv0(ipr,:),' kdt=',kdt,' nnp=',nnp +! write(0,*) ' endgt0=',gt0(ipr,:),' kdt=',kdt +! write(0,*) ' endgq0=',gq0(ipr,:,1),' kdt=',kdt,' lat=',lat +! write(0,*) ' endgw0=',gq0(ipr,:,3),' kdt=',kdt,' lat=',lat +! endif + + if (Model%do_sppt) then + !--- radiation heating rate + Tbd%dtdtr(1:im,:) = Tbd%dtdtr(1:im,:) + dtdtc(1:im,:)*dtf + do i = 1, im + if (t850(i) > 273.16) then + !--- change in change in rain precip + Tbd%drain_cpl(i) = Diag%rain(i) - Tbd%drain_cpl(i) + else + !--- change in change in snow precip + Tbd%dsnow_cpl(i) = Diag%rain(i) - Tbd%dsnow_cpl(i) + endif + enddo + endif + + deallocate (clw) + deallocate (clw_trac_idx) + if (Model%do_shoc) then + deallocate (qpl, qpi, ncpl, ncpi) + endif + if (allocated(cnvc)) deallocate(cnvc) + if (allocated(cnvw)) deallocate(cnvw) + +! +! if (lprnt) write(0,*)' end of gbphys maxu=', +! &maxval(gu0(1:im,1:levs)),' minu=',minval(gu0(1:im,1:levs)) +! &,' maxv=',maxval(gv0(1:im,1:levs)),' minv=', +! & minval(gv0(1:im,1:levs)),' kdt=',kdt,' lat=',lat,' nnp=',nnp +! if (lprnt) write(0,*)' end of gbphys gv0=',gv0(:,120:128) +! if (lprnt) write(0,*)' end of gbphys at kdt=',kdt, +! &' rain=',rain(ipr),' rainc=',rainc(ipr) +! if (lprnt) call mpi_quit(7) +! if (kdt > 2 ) call mpi_quit(70) + if (Model%ncld == 2) then ! For MGB double moment microphysics + + deallocate (qlcn, qicn, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT, clcn, cnv_fice, cnv_ndrop, cnv_nice) + deallocate (qsnw, ncpr, ncps) + endif + deallocate (qrn) + + if (Model%ldiag3d) then + ! Update t_dt_* and q_dt_* diagnostics such that they represent temperature + ! and water vapor tendencies contributed by each component of the physics, + ! consistent with how those tendencies are applied in the dynamical core. + nwat = Statein%nwat + + if (Statein%dycore_hydrostatic) then + call moist_cp_nwat6(Statein%qgrs(1:im,1:levs,1:nwat), Stateout%gq0(1:im,1:levs,1:nwat), & + Statein%prsi(1:im,1:levs+1), im, levs, nwat, 1, Model%ntcw, Model%ntiw, & + Model%ntrw, Model%ntsw, Model%ntgl, specific_heat) + else + call moist_cv_nwat6(Statein%qgrs(1:im,1:levs,1:nwat), Stateout%gq0(1:im,1:levs,1:nwat), & + Statein%prsi(1:im,1:levs+1), im, levs, nwat, 1, Model%ntcw, Model%ntiw, & + Model%ntrw, Model%ntsw, Model%ntgl, specific_heat) + endif + call compute_updated_delp_following_dynamics_definition(Statein%prsi(1:im,1:levs+1), & + dq3dt_initial, Diag%dq3dt, Stateout%gq0(:,:,1:nwat), im, levs, & + nwat, final_dynamics_delp) + call update_temperature_tendency_diagnostics(Diag%t_dt, & + Diag%t_dt_int, final_dynamics_delp, & + dt3dt_initial, Diag%dt3dt, specific_heat, im, levs, dtp) + call update_water_vapor_tendency_diagnostics(Diag%q_dt, Diag%q_dt_int, & + dq3dt_initial, Diag%dq3dt, Statein%qgrs(:,:,1:nwat), Stateout%gq0(:,:,1:nwat), & + final_dynamics_delp, im, levs, nwat, dtp) + endif + + return +!................................... + end subroutine GFS_physics_driver +!----------------------------------- + + + subroutine moist_bud(im,ix,ix2,levs,me,kdt,grav,dtp,delp,rain, & + qv0,ql0,qi0,qv1,ql1,qi1,comp) +! nov 2016 - S. Moorthi - routine to compute local moisture budget + use machine, only : kind_phys + implicit none + character*10 :: comp + integer :: im,ix,ix2,levs,me,kdt + real (kind=kind_phys) :: grav, rain(im), dtp + real (kind=kind_phys), dimension(ix,levs) :: qv0,ql0,qi0,delp + real (kind=kind_phys), dimension(ix2,levs) :: qv1,ql1,qi1 + REAL (kind=kind_phys), dimension(im) :: sumq, sumqv, sumql, sumqi + integer :: i, k +! + sumqv(:) = 0.0 + sumql(:) = 0.0 + sumqi(:) = 0.0 + sumq (:) = 0.0 + do i=1,im + sumqv(:) = sumqv(:) + (qv1(:,k) - qv0(:,k)) * delp(:,k) + sumql(:) = sumql(:) + (ql1(:,k) - ql0(:,k)) * delp(:,k) + sumqi(:) = sumqi(:) + (qi1(:,k) - qi0(:,k)) * delp(:,k) + enddo + sumqv(:) = - sumqv(:) * (1.0/grav) + sumql(:) = - sumql(:) * (1.0/grav) + sumqi(:) = - sumqi(:) * (1.0/grav) + sumq (:) = sumqv(:) + sumql(:) + sumqi(:) + do i=1,im + write(1000+me,*)' in moist_bud:',' i=',i,' sumq=',sumq(i), & + ' sumqv=',sumqv(i),' sumql=',sumql(i),' sumqi=',sumqi(i), & + ' rain=',rain(i)*dtp,' kdt=',kdt,' component=',comp, & + ' qv:=',qv1(i,1),qv0(i,1),' ql=',ql1(i,1),ql0(i,1), & + ' qi=',qi1(i,1), qi0(i,1) +! if(sumq(i) > 100) then +! write(1000+me,*)' i=',i,' sumq=',sumq(i) +! write(1000+me,*)' qv1=',(qv1(i,k),k=1,levs) +! write(1000+me,*)' qv0=',(qv0(i,k),k=1,levs) +! write(1000+me,*)' ql1=',(ql1(i,k),k=1,levs) +! write(1000+me,*)' ql0=',(ql0(i,k),k=1,levs) +! write(1000+me,*)' qi1=',(qi1(i,k),k=1,levs) +! write(1000+me,*)' qi0=',(qi0(i,k),k=1,levs) +! endif + enddo + return + + end subroutine moist_bud + subroutine moist_cv_nwat6(initial_dynamics_q, physics_q, pressure_on_interfaces, & + im, levs, nwat, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, cvm) + integer, intent(in) :: im, levs, nwat, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl + real(kind=kind_phys), dimension(1:im,1:levs,1:nwat), intent(in) :: initial_dynamics_q, physics_q + real(kind=kind_phys), intent(in) :: pressure_on_interfaces(1:im,1:levs+1) + real(kind=kind_phys), intent(out) :: cvm(1:im,1:levs) + + real(kind=kind_phys) :: new_dynamics_q(1:im,1:levs,1:nwat) + real(kind=kind_phys) :: q_vapor(1:im,1:levs) + real(kind=kind_phys) :: q_dry_air(1:im,1:levs) + real(kind=kind_phys) :: q_liquid(1:im,1:levs) + real(kind=kind_phys) :: q_ice(1:im,1:levs) + + real(kind=kind_phys) :: cv_air = con_cp - con_rd ! From fv_mapz.F90 + real(kind=kind_phys) :: cv_vap = 3.0 * con_rv ! From fv_mapz.F90 + real(kind=kind_phys) :: c_liq = 4.1855e+3 ! Hard-coded in fv_mapz.F90 + real(kind=kind_phys) :: c_ice = 1972.0 ! Hard-coded in fv_mapz.F90 + + ! fv_mapz.moist_cv defines branches for using other moist tracer configurations. + ! For simplicity we choose not to replicate that behavior here, since we have + ! only run in one tracer configuration (nwat = 6) so far. We also do not implement + ! the branch of code that is run if the compiler directive MULTI_GASES is defined. + ! In those cases we default to using the specific heat at constant volume for dry + ! air, and emit a warning. +#ifdef MULTI_GASES + write(*,*) 'GFS_physics_driver::moist_cv - moist_cv for tracer configuration not implemented; using default cv_air for t_dt diagnostics' + cvm = cv_air +#else + if (nwat /= 6) then + write(*,*) 'GFS_physics_driver::moist_cv - moist_cv for tracer configuration not implemented; using default cv_air for t_dt diagnostics' + cvm = cv_air + else + call physics_to_dycore_mass_fraction(initial_dynamics_q, physics_q, & + pressure_on_interfaces, im, levs, nwat, new_dynamics_q) + + q_vapor = new_dynamics_q(:,:,ntqv) + q_liquid = new_dynamics_q(:,:,ntcw) + new_dynamics_q(:,:,ntrw) + q_ice = new_dynamics_q(:,:,ntiw) + new_dynamics_q(:,:,ntsw) + new_dynamics_q(:,:,ntgl) + q_dry_air = 1.0 - q_vapor - q_liquid - q_ice + + ! By definition now, the weights sum to 1.0. + cvm = cv_air * q_dry_air + cv_vap * q_vapor + c_liq * q_liquid + c_ice * q_ice + endif +#endif + end subroutine moist_cv_nwat6 + + subroutine moist_cp_nwat6(initial_dynamics_q, physics_q, pressure_on_interfaces, & + im, levs, nwat, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl, cpm) + integer, intent(in) :: im, levs, nwat, ntqv, ntcw, ntiw, ntrw, ntsw, ntgl + real(kind=kind_phys), dimension(1:im,1:levs,1:nwat), intent(in) :: initial_dynamics_q, physics_q + real(kind=kind_phys), intent(in) :: pressure_on_interfaces(1:im,1:levs+1) + real(kind=kind_phys), intent(out) :: cpm(1:im,1:levs) + + real(kind=kind_phys) :: new_dynamics_q(1:im,1:levs,1:nwat) + real(kind=kind_phys) :: q_vapor(1:im,1:levs) + real(kind=kind_phys) :: q_dry_air(1:im,1:levs) + real(kind=kind_phys) :: q_liquid(1:im,1:levs) + real(kind=kind_phys) :: q_ice(1:im,1:levs) + + real(kind=kind_phys) :: cp_air = con_cp ! From fv_mapz.F90 + real(kind=kind_phys) :: cp_vap = con_cvap ! From fv_mapz.F90 + real(kind=kind_phys) :: c_liq = 4.1855e+3 ! Hard-coded in fv_mapz.F90 + real(kind=kind_phys) :: c_ice = 1972.0 ! Hard-coded in fv_mapz.F90 + + ! fv_mapz.moist_cp defines branches for using other moist tracer configurations. + ! For simplicity we choose not to replicate that behavior here, since we have + ! only run in one tracer configuration (nwat = 6) so far. We also do not implement + ! the branch of code that is run if the compiler directive MULTI_GASES is defined. + ! In those cases we default to using the specific heat at constant volume for dry + ! air, and emit a warning. +#ifdef MULTI_GASES + write(*,*) 'GFS_physics_driver::moist_cp - moist_cp for tracer configuration not implemented; using default cp_air for t_dt diagnostics' + cpm = cp_air +#else + if (nwat /= 6) then + write(*,*) 'GFS_physics_driver::moist_cp - moist_cp for tracer configuration not implemented; using default cp_air for t_dt diagnostics' + cpm = cp_air + else + call physics_to_dycore_mass_fraction(initial_dynamics_q, physics_q, & + pressure_on_interfaces, im, levs, nwat, new_dynamics_q) + + q_vapor = new_dynamics_q(:,:,ntqv) + q_liquid = new_dynamics_q(:,:,ntcw) + new_dynamics_q(:,:,ntrw) + q_ice = new_dynamics_q(:,:,ntiw) + new_dynamics_q(:,:,ntsw) + new_dynamics_q(:,:,ntgl) + q_dry_air = 1.0 - q_vapor - q_liquid - q_ice + + ! By definition now, the weights sum to 1.0. + cpm = cp_air * q_dry_air + cp_vap * q_vapor + c_liq * q_liquid + c_ice * q_ice + endif +#endif + end subroutine moist_cp_nwat6 + + subroutine physics_to_dycore_mass_fraction(initial_dynamics_q, physics_q, & + pressure_on_interfaces, im, levs, nwat, new_dynamics_q) + integer, intent(in) :: im, levs, nwat + real(kind=kind_phys), intent(in) :: initial_dynamics_q(1:im,1:levs,1:nwat) + real(kind=kind_phys), intent(in) :: physics_q(1:im,1:levs,1:nwat) + real(kind=kind_phys), intent(in) :: pressure_on_interfaces(1:im,1:levs+1) + real(kind=kind_phys), intent(out) :: new_dynamics_q(1:im,1:levs,1:nwat) + + real(kind=kind_phys) :: delp(1:im,1:levs) + real(kind=kind_phys) :: qwat(1:im,1:levs,1:nwat) + real(kind=kind_phys) :: qt(1:im,1:levs) + integer :: k, t + + ! Follow the procedure used in atmosphere.atmosphere_state_update to convert + ! mass fractions in the physics driver to mass fractions in the dynamical core. + do k = 1, levs + delp(:,k) = pressure_on_interfaces(:,k) - pressure_on_interfaces(:,k+1) + enddo + do t = 1, nwat + qwat(:,:,t) = delp * physics_q(:,:,t) + enddo + qt = sum(qwat, 3) + delp = delp * (1.0 - sum(initial_dynamics_q(:,:,1:nwat), 3)) + qt + do t = 1, nwat + new_dynamics_q(:,:,t) = qwat(:,:,t) / delp + enddo + end subroutine physics_to_dycore_mass_fraction + + ! Scale the temperature increment for each physics component by cp / cvm + ! if the dynamical core is non-hydrostatic or cp / cpm if the dynamical + ! core is hydrostatic to account for how the temperature tendency is + ! adjusted within the dynamical core. + subroutine update_temperature_tendency_diagnostics(t_dt, t_dt_int, & + delp, dt3dt_initial, dt3dt_final, specific_heat, im, levs, timestep) + integer, intent(in) :: im, levs + real(kind=kind_phys), intent(in), dimension(1:im,1:levs,9) :: dt3dt_initial, dt3dt_final + real(kind=kind_phys), intent(inout) :: t_dt(1:im,1:levs,9), t_dt_int(1:im,9) + real(kind=kind_phys), intent(in), dimension(1:im,1:levs) :: specific_heat, delp + real(kind=kind_phys), intent(in) :: timestep + + real(kind=kind_phys), dimension(1:im,1:levs) :: increment + integer :: i + + do i = 1, 9 + increment = dt3dt_final(:,:,i) - dt3dt_initial(:,:,i) + t_dt(:,:,i) = con_cp * increment / (timestep * specific_heat(:,:)) + t_dt_int(:,i) = sum(delp * specific_heat * t_dt(:,:,i), dim=2) / con_g + enddo + end subroutine update_temperature_tendency_diagnostics + + ! Scale the water vapor mass fraction increment for each physics component by + ! (mass of dry air + mass of only water vapor at the start of the physics) / + ! (mass of dry air + mass of all hydrometeors at the end of the physics). + ! + ! This leaves a residual water vapor tendency that cannot be assigned to a single + ! physical process (because the mass of dry air + mass of all hydrometeors changes + ! during the physics). This residual is equal to the initial mass of water vapor going + ! into the physics, multiplied by the difference between + ! 1 / (mass of dry air + mass of all hydrometeors at the end of the physics) and + ! 1 / (mass of dry air + mass of all hydrometeors at the beginning of the physics). + ! This residual is typically small compared to the tendencies induced by the + ! physics parameterizations themselves. + subroutine update_water_vapor_tendency_diagnostics(q_dt, q_dt_int, & + dq3dt_initial, dq3dt_final, q_initial, q_final, delp, im, levs, nwat, timestep) + integer, intent(in) :: im, levs, nwat + real(kind=kind_phys), intent(inout) :: q_dt(1:im,1:levs,5), q_dt_int(1:im,5) + real(kind=kind_phys), intent(in), dimension(1:im,1:levs,1:9) :: dq3dt_initial, dq3dt_final + real(kind=kind_phys), intent(in) :: delp(1:im,1:levs) + real(kind=kind_phys), intent(in), dimension(1:im,1:levs,1:nwat) :: q_initial, q_final + real(kind=kind_phys), intent(in) :: timestep + + integer :: i + real(kind=kind_phys), dimension(1:im,1:levs) :: initial_dynamics_denominator, final_dynamics_denominator, increment + + ! Note a factor of delp = mass of dry air + mass of water vapor at the start of + ! the physics cancels in all of these calculations, so we can work with mass + ! fractions instead of masses for all of these scalings. + initial_dynamics_denominator = 1.0 + sum(q_initial(:,:,2:nwat), 3) + final_dynamics_denominator = 1.0 + sum(dq3dt_final(:,:,1:4) - dq3dt_initial(:,:,1:4), 3) + sum(q_final(:,:,2:nwat), 3) + + do i = 1, 4 + increment = dq3dt_final(:,:,i) - dq3dt_initial(:,:,i) + q_dt(:,:,i) = increment / (timestep * final_dynamics_denominator) + q_dt_int(:,i) = sum(delp * q_dt(:,:,i), dim=2) / con_g + enddo + + ! Compute the residual tendency. + q_dt(:,:,5) = q_initial(:,:,1) * ((1.0 / final_dynamics_denominator) - (1.0 / initial_dynamics_denominator)) / timestep + q_dt_int(:,5) = sum(delp * q_dt(:,:,5), dim=2) / con_g + end subroutine update_water_vapor_tendency_diagnostics + + ! Compute the pressure thickness at the end of the physics following the definition + ! in the dynamical core, where it is defined using the total mass of dry air plus all + ! hydrometeors. + subroutine compute_updated_delp_following_dynamics_definition(pressure_on_interfaces, & + dq3dt_initial, dq3dt_final, q_final, im, levs, nwat, delp) + integer, intent(in) :: im, levs, nwat + real(kind=kind_phys), intent(in), dimension(1:im,1:levs,1:9) :: dq3dt_initial, dq3dt_final + real(kind=kind_phys), intent(in), dimension(1:im,1:levs,1:nwat) :: q_final + real(kind=kind_phys), intent(in), dimension(1:im,1:levs+1) :: pressure_on_interfaces + real(kind=kind_phys), intent(out), dimension(1:im,1:levs) :: delp + + real(kind=kind_phys), dimension(1:im,1:levs) :: initial_mass_of_dry_air_plus_vapor + real(kind=kind_phys), dimension(1:im,1:levs) :: dry_air_plus_hydrometeor_mass_fraction_after_physics + real(kind=kind_phys), dimension(1:im,1:levs) :: change_in_vapor_mass_fraction_due_to_physics + real(kind=kind_phys), dimension(1:im,1:levs) :: final_mass_fraction_of_non_vapor_hydrometeors + real(kind=kind_phys) :: initial_mass_fraction_of_dry_air_plus_vapor = 1.0 + integer :: k + + ! Compute the sum of the mass fractions of dry air and the hydrometeors at the end of + ! the physics driver. These mass fractions use the physics convention in which the + ! denominator is the mass of dry air plus the mass of water vapor at the start of the physics. + change_in_vapor_mass_fraction_due_to_physics = sum(dq3dt_final(:,:,1:4) - dq3dt_initial(:,:,1:4), 3) + final_mass_fraction_of_non_vapor_hydrometeors = sum(q_final(:,:,2:nwat), 3) + dry_air_plus_hydrometeor_mass_fraction_after_physics = initial_mass_fraction_of_dry_air_plus_vapor + & + change_in_vapor_mass_fraction_due_to_physics + & + final_mass_fraction_of_non_vapor_hydrometeors + + ! Compute the mass of dry air plus vapor at the start of the physics. (Note this is + ! implicitly scaled by a factor of gravitational acceleration / grid cell area, but + ! we want to keep this constant factor in our result, so that is fine). + do k = 1, levs + initial_mass_of_dry_air_plus_vapor(:,k) = pressure_on_interfaces(:,k) - pressure_on_interfaces(:,k+1) + enddo + + ! Compute the mass of dry air plus all hydrometeors at the end of the physics. + delp = initial_mass_of_dry_air_plus_vapor * dry_air_plus_hydrometeor_mass_fraction_after_physics + end subroutine compute_updated_delp_following_dynamics_definition +!> @} + +end module module_physics_driver diff --git a/GFS_layer/GFS_radiation_driver.F90 b/GFS_layer/GFS_radiation_driver.F90 new file mode 100644 index 00000000..dcd5f85e --- /dev/null +++ b/GFS_layer/GFS_radiation_driver.F90 @@ -0,0 +1,1907 @@ +!> \file grrad.f This file is the radiation driver module. It prepares +!! the atmospheric profiles and invokes the main radiation calculation. + +!> \defgroup rad RRTMG Shortwave/Longwave Radiation Scheme +!> @{ +!! \brief The GFS radiation scheme +!! \details Radiative processes are among the most complex and +!! computationally intensive parts of all model physics. As an +!! essential component of modeling the atmosphere, radiation directly +!! and indirectly connects all physics processes with model dynamics, +!! and it regulates the overall earth-atmosphere energy exchanges and +!! transformations. +!! +!! The radiation package in GFS physics has standardized component +!! modules (Table 1). The radiation driver module (\ref +!! module_radiation_driver) is the interface with the Interoperable +!! Physics Driver (IPD) for NGGPS, and it has three subroutines called +!! by IPD (Figure 1): +!! - radinit() is called in subroutine nuopc_phys_init to set up +!! radiation related fixed parameters. +!! - radupdate() is called in subroutine nuopc_rad_update to update +!! values between timesteps. +!! - grrad() is called in subroutine nuopc_rad_run, and it is the +!! driver of radiation calculation. +!! \image html ipd_rad.png "Figure 1: Schematic illustration of the communication between the GFS radiation package and IPD " width=10cm +!! +!! The schematic radiation module structure is shown in Table 1. +!! \image html schematic_Rad_mod.png "Table 1: Schematic Radiation Module Structure" width=10cm +!! +!> GFS radiation package is intended to provide a fast and accurate +!! method of determining the total radiative flux at any given +!! location. These calculations provide both the total radiative flux +!! at the ground surface, which is needed to establish the surface +!! energy budget, and the vertical radiative flux divergence, which is +!! used to calculate the radiative heating and cooling rates of a given +!! atmospheric layer. The magnitude of the terms in the surface energy +!! budget can set the stage for moist deep convection and are crucial +!! to the formation of low-level clouds. In addition, the vertical +!! radiative flux divergence can produce substantial cooling, +!! particularly at the tops of clouds, which can have strong dynamical +!! effects on cloud evolution. +!! +!! It uses a correlated-k distribution method and a transmittance lookup +!! table that is linearly scaled by optical depth to achieve high +!! accuracy and efficiency. The algorithm contains 140 unevenly +!! distributed quadrature points (reduced from the original set of 256) +!! to integrate the cumulative probability distribution functions of +!! absorption over 16 spectral bands. It employs the +!! Clough-Kneizys-Davies (CKD_2.4) continuum model (Clough et al. 1992 +!! \cite clough_et_al_1992) to compute absorption by water vapor at the +!! continuum band. Longwave cloud radiative properties external to the +!! RRTM depend on cloud liquid/ice water path and the effective radius +!! of ice particles and water droplets (Hu and Stamnes 1993 \cite +!! hu_and_stamnes_1993; Ebert and Curry 1992 \cite ebert_and_curry_1992). +!! +!! Changes to Radiation Parameterization since 2007: +!! \n The longwave (LW) and the shortwave (SW) radiation +!! parameterizations in NCEP's operational GFS are both modified and +!! optimized versions of the Rapid Radiative Transfer Model for GCMs +!! (RRTMG_LW v2.3 and RRTMG_SW v2.3, respectively) developed at AER +!! (Iacono et al. 2008 \cite iacono_et_al_2008,Mlawer et al. 1997 +!! \cite mlawer_et_al_1997, Iacono et al., 2000 \cite iacono_et_al_2000, +!! Clough et al., 2005 \cite clough_et_al_2005). The LW algorithm +!! contains 140 unevenly distributed g-points (quadrature points) in 16 +!! broad spectral bands, while the SW algorithm includes 112 g-points +!! in 14 bands. In addition to the major atmospheric absorbing gases of +!! ozone, water vapor, and carbon dioxide, the algorithm also includes +!! various minor absorbing species such as methane, nitrous oxide, +!! oxygen, and in the longwave up to four types of halocarbons (CFCs). +!! To represent statistically the unresolved subgrid cloud variability +!! when dealing multi layered clouds, a Monte-Carlo Independent Column +!! Approximation (McICA) method is used in the RRTMG radiative transfer. +!! A maximum-random cloud overlap method is used in both LW and SW +!! radiation calculations. Cloud condensate path and effective radius +!! for water and ice are used for the calculation of cloud-radiative +!! properties. Hu and Stamnes's method (1993) \cite hu_and_stamnes_1993 +!! is used to treat water clouds in both LW and SW parameterizations. +!! For ice clouds. Fu's parameterizations (1996,1998) \cite fu_1996 +!! \cite fu_et_al_1998 are used in the SW and LW, respectively. +!! +!! In the operational GFS, a climatological tropospheric aerosol with +!! a 5-degree horizontal resolution is used in both LW and SW +!! radiations. A generalized spectral mapping formulation was developed +!! to compute radiative properties of various aerosol components for +!! each of the radiation spectral bands. A separate stratospheric +!! volcanic aerosol parameterization was added that is capable of +!! handling volcanic events. In SW, a new table of incoming solar +!! constants is derived covering time period of 1850-2019 (Vandendool, +!! personal communivation). An eleven-year solar cycle approximation +!! will be used for time out of the window period in long term climate +!! simulations. The SW albedo parameterization uses surface vegetation +!! type based seasonal climatology similar to that described in the +!! NCEP OFFICE Note 441 (Hou et al. 2002 \cite hou_et_al_2002) but with +!! a modification in the treatment of solar zenith angle dependency over +!! snow-free land surface (Yang et al. 2008 \cite yang_et_al_2008). +!! Similarly, vegetation type based non-black-body surface emissivity +!! is used for the LW radiation. Concentrations of atmospheric +!! greenhouse gases are either obtained from global network +!! measurements, such as carbon dioxide (CO2), or taking the +!! climatological constants, the actual CO2 value for the forecast time +!! is an estimation based on the most recent five-year observations. In +!! the lower atmosphere (<3km) a monthly mean CO2 distribution in 15 +!! degree horizontal resolution is used, while a global mean monthly +!! value is used in the upper atmosphere. +!! +!> \defgroup module_radiation_driver module_radiation_driver +!> @{ +!! \brief The GFS radiation driver module +!! \details module_radiation_driver prepares the atmospheric profile, +!! invokes the main radiation calculations, and computes radiative +!! fluxes and heating rates for some arbitrary number of vertical +!! columns. This module also regulates the logistic running flow of +!! the computations, such as data initialization and update accordance +!! with forecast timing progress, the sequential order of subroutine +!! calls, and sorting results for final output. +!! There are three externally accessible subroutines: +!! - radinit(): the initialization subroutine of radiation calculations +!! It is invoked by the model's initialization process and is independent +!! with forecat time progress. +!! - radupdate(): calls many update subroutines to check and update +!! radiation required but time varying data sets and module variables. +!! It is placed inside a model's time advancing loop. +!! - grrad(): the driver of radiation calculation subroutines. It sets +!! up profile variables for radiation input, including clouds, surface +!! albedos, atmospheric aerosols, ozone, etc. It is located inside the +!! timing loop, and control the sequence of the radiative process +!! calculations. +!! \version NCEP-Radiation_driver v5.2 Jan 2013 +! ========================================================== !!!!! +! 'module_radiation_driver' descriptions !!!!! +! ========================================================== !!!!! +! ! +! this is the radiation driver module. it prepares atmospheric ! +! profiles and invokes main radiation calculations. ! +! ! +! in module 'module_radiation_driver' there are twe externally ! +! callable subroutine: ! +! ! +! 'radinit' -- initialization routine ! +! input: ! +! ( si, NLAY, me ) ! +! output: ! +! ( none ) ! +! ! +! 'radupdate' -- update time sensitive data used by radiations ! +! input: ! +! ( idate,jdate,deltsw,deltim,lsswr, me ) ! +! output: ! +! ( slag,sdec,cdec,solcon ) ! +! ! +! 'grrad' -- setup and invoke main radiation calls ! +! input: ! +! ( prsi,prsl,prslk,tgrs,qgrs,tracer,vvl,slmsk, ! +! xlon,xlat,tsfc,snowd,sncovr,snoalb,zorl,hprim, ! +! alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, ! +! sinlat,coslat,solhr,jdate,solcon, ! +! cv,cvt,cvb,fcice,frain,rrime,flgmin, ! +! icsdsw,icsdlw, ntcw,ncld,ntoz, NTRAC,NFXR, ! +! dtlw,dtsw, lsswr,lslwr,lssav, ! +! IX, IM, LM, me, lprnt, ipt, kdt,deltaq,sup,cnvw,cnvc, ! +! output: ! +! htrsw,topfsw,sfcfsw,dswcmp,uswcmp,sfalb,coszen,coszdg, ! +! htrlw,topflw,sfcflw,tsflw,semis,cldcov, ! +! input/output: ! +! fluxr ! +! optional output: ! +! htrlw0,htrsw0,htrswb,htrlwb ! +! ! +! ! +! external modules referenced: ! +! 'module physparam' in 'physparam.f' ! +! 'module funcphys' in 'funcphys.f' ! +! 'module physcons' in 'physcons.f' ! +! ! +! 'module module_radiation_gases' in 'radiation_gases.f' ! +! 'module module_radiation_aerosols' in 'radiation_aerosols.f' ! +! 'module module_radiation_surface' in 'radiation_surface.f' ! +! 'module module_radiation_clouds' in 'radiation_clouds.f' ! +! ! +! 'module module_radsw_cntr_para' in 'radsw_xxxx_param.f' ! +! 'module module_radsw_parameters' in 'radsw_xxxx_param.f' ! +! 'module module_radsw_main' in 'radsw_xxxx_main.f' ! +! ! +! 'module module_radlw_cntr_para' in 'radlw_xxxx_param.f' ! +! 'module module_radlw_parameters' in 'radlw_xxxx_param.f' ! +! 'module module_radlw_main' in 'radlw_xxxx_main.f' ! +! ! +! where xxxx may vary according to different scheme selection ! +! ! +! ! +! program history log: ! +! mm-dd-yy ncep - created program grrad ! +! 08-12-03 yu-tai hou - re-written for modulized radiations ! +! 11-06-03 yu-tai hou - modified ! +! 01-18-05 s. moorthi - NOAH/ICE model changes added ! +! 05-10-05 yu-tai hou - modified module structure ! +! 12-xx-05 s. moorthi - sfc lw flux adj by mean temperature ! +! 02-20-06 yu-tai hou - add time variation for co2 data, and ! +! solar const. add sfc emiss change ! +! 03-21-06 s. Moorthi - added surface temp over ice ! +! 07-28-06 yu-tai hou - add stratospheric vocanic aerosols ! +! 03-14-07 yu-tai hou - add generalized spectral band interp ! +! for aerosol optical prop. (sw and lw) ! +! 04-10-07 yu-tai hou - spectral band sw/lw heating rates ! +! 05-04-07 yu-tai hou - make options for clim based and modis ! +! based (h. wei and c. marshall) albedo ! +! 09-05-08 yu-tai hou - add the initial date and time 'idate' ! +! and control param 'ICTM' to the passing param list! +! to handel different time/date requirements for ! +! external data (co2, aeros, solcon, ...) ! +! 10-10-08 yu-tai hou - add the ICTM=-2 option for combining ! +! initial condition data with seasonal cycle from ! +! climatology. ! +! 03-12-09 yu-tai hou - use two time stamps to keep tracking ! +! dates for init cond and fcst time. remove volcanic! +! aerosols data in climate hindcast (ICTM=-2). ! +! 03-16-09 yu-tai hou - included sub-column clouds approx. ! +! control flags isubcsw/isubclw in initialization ! +! subroutine. passed auxiliary cloud control arrays ! +! icsdsw/icsdlw (if isubcsw/isubclw =2, it will be ! +! the user provided permutation seeds) to the sw/lw ! +! radiation calculation programs. also moved cloud ! +! overlapping control flags iovrsw/iovrlw from main ! +! radiation routines to the initialization routines.! +! 04-02-09 yu-tai hou - modified surface control flag iems to ! +! have additional function of if the surface-air ! +! interface have the same or different temperature ! +! for radiation calculations. ! +! 04-03-09 yu-tai hou - modified to add lw surface emissivity ! +! as output variable. changed the sign of sfcnsw to ! +! be positive value denote solar flux goes into the ! +! ground (this is needed to reduce sign confusion ! +! in other part of model) ! +! 09-09-09 fanglin yang (thru s.moorthi) added QME5 QME6 to E-20! +! 01-09-10 sarah lu - added gocart option, revised grrad for! +! gocart coupling. calling argument modifed: ldiag3 ! +! removed; cldcov/fluxr sequence changed; cldcov is ! +! changed from accumulative to instant field and ! +! from input/output to output field ! +! 01-24-10 sarah lu - added aod to fluxr, added prslk and ! +! oz to setaer input argument (for gocart coupling),! +! added tau_gocart to setaer output argument (for, ! +! aerosol diag by index of nv_aod) ! +! 07-08-10 s.moorthi - updated the NEMS version for new physics ! +! 07-28-10 yu-tai hou - changed grrad interface to allow all ! +! components of sw/lw toa/sfc instantaneous values ! +! being passed to the calling program. moved the ! +! computaion of sfc net sw flux (sfcnsw) to the ! +! calling program. merged carlos' nmmb modification.! +! 07-30-10 s. moorthi - corrected some errors associated with ! +! unit changes ! +! 12-02-10 s. moorthi/y. hou - removed the use of aerosol flags ! +! 'iaersw' 'iaerlw' from radiations and replaced ! +! them by using the runtime variable laswflg and ! +! lalwflg defined in module radiation_aerosols. ! +! also replaced param nspc in grrad with the use of ! +! max_num_gridcomp in module radiation_aerosols. ! +! jun 2012 yu-tai hou - added sea/land madk 'slmsk' to the ! +! argument list of subrotine setaer call for the ! +! newly modified horizontal bi-linear interpolation ! +! in climatological aerosols schem. also moved the ! +! virtual temperature calculations in subroutines ! +! 'radiation_clouds' and 'radiation_aerosols' to ! +! 'grrad' to reduce repeat comps. renamed var oz as ! +! tracer to reflect that it carries various prog ! +! tracer quantities. ! +! - modified to add 4 compontents of sw ! +! surface downward fluxes to the output. (vis/nir; ! +! direct/diffused). re-arranged part of the fluxr ! +! variable fields and filled the unused slots for ! +! the new components. added check print of select ! +! data (co2 value for now). ! +! - changed the initialization subrution ! +! 'radinit' into two parts: 'radinit' is called at ! +! the start of model run to set up radiation related! +! fixed parameters; and 'radupdate' is called in ! +! the time-loop to update time-varying data sets ! +! and module variables. ! +! sep 2012 h-m lin/y-t hou added option of extra top layer for ! +! models with low toa ceiling. the extra layer will ! +! help ozone absorption at higher altitude. ! +! nov 2012 yu-tai hou - modified control parameters through ! +! module 'physparam'. ! +! jan 2013 yu-tai hou - updated subr radupdate for including ! +! options of annual/monthly solar constant table. ! +! mar 2013 h-m lin/y-t hou corrected a bug in extra top layer ! +! when using ferrier microphysics. ! +! may 2013 s. mooorthi - removed fpkapx ! +! jul 2013 r. sun - added pdf cld and convective cloud water and! +! cover for radiation ! +! aug 2013 s. moorthi - port from gfs to nems ! +! 13Feb2014 sarah lu - add aerodp to fluxr ! +! Apr 2014 Xingren Wu - add sfc SW downward fluxes nir/vis and ! +! sfcalb to export for A/O/I coupling ! +! jun 2014 y-t hou - revised code to include surface up and ! +! down spectral components sw fluxes as output. ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + + + +!========================================! + module module_radiation_driver ! +!........................................! +! + use physparam + use physcons, only: eps => con_eps, & + & epsm1 => con_epsm1, & + & fvirt => con_fvirt & + &, rocp => con_rocp + use funcphys, only: fpvs + + use module_radiation_astronomy,only: sol_init, sol_update, coszmn + use module_radiation_gases, only: NF_VGAS, getgases, getozn, & + & gas_init, gas_update + use module_radiation_aerosols, only: NF_AESW, NF_AELW, setaer, & + & aer_init, aer_update, & + & NSPC1 + use module_radiation_surface, only: NF_ALBD, sfc_init, setalb, & + & setemis + use module_radiation_clouds, only: NF_CLDS, cld_init, & + & progcld1, progcld2, & + & progcld3, progcld4, & + & progcld5, progcld6, & + & progclduni, diagcld1 + + use module_radsw_parameters, only: topfsw_type, sfcfsw_type, & + & profsw_type,cmpfsw_type,NBDSW + use module_radsw_main, only: rswinit, swrad + + use module_radlw_parameters, only: topflw_type, sfcflw_type, & + & proflw_type, NBDLW + use module_radlw_main, only: rlwinit, lwrad + use GFS_typedefs, only: GFS_statein_type, & + GFS_stateout_type, & + GFS_sfcprop_type, & + GFS_coupling_type, & + GFS_control_type, & + GFS_grid_type, & + GFS_tbd_type, & + GFS_cldprop_type, & + GFS_radtend_type, & + GFS_diag_type +! + implicit none +! + private + +! --- version tag and last revision date + character(40), parameter :: & + & VTAGRAD='NCEP-Radiation_driver v5.2 Jan 2013 ' +! & VTAGRAD='NCEP-Radiation_driver v5.1 Nov 2012 ' +! & VTAGRAD='NCEP-Radiation_driver v5.0 Aug 2012 ' + +!>\name Constant values + +!> lower limit of saturation vapor pressure (=1.0e-10) + real (kind=kind_phys) :: QMIN +!> lower limit of specific humidity (=1.0e-7) + real (kind=kind_phys) :: QME5 +!> lower limit of specific humidity (=1.0e-7) + real (kind=kind_phys) :: QME6 +!> EPSQ=1.0e-12 + real (kind=kind_phys) :: EPSQ +! parameter (QMIN=1.0e-10, QME5=1.0e-5, QME6=1.0e-6, EPSQ=1.0e-12) + parameter (QMIN=1.0e-10, QME5=1.0e-7, QME6=1.0e-7, EPSQ=1.0e-12) +! parameter (QMIN=1.0e-10, QME5=1.0e-20, QME6=1.0e-20, EPSQ=1.0e-12) + +!> lower limit of toa pressure value in mb + real, parameter :: prsmin = 1.0e-6 + +!> control flag for LW surface temperature at air/ground interface +!! (default=0, the value will be set in subroutine radinit) + integer :: itsfc =0 + +!> new data input control variables (set/reset in subroutines radinit/radupdate): + integer :: month0=0, iyear0=0, monthd=0 + +!> control flag for the first time of reading climatological ozone data +!! (set/reset in subroutines radinit/radupdate, it is used only if the +!! control parameter ioznflg=0) + logical :: loz1st =.true. + +!> optional extra top layer on top of low ceiling models +!!\n LTP=0: no extra top layer + integer, parameter :: LTP = 0 ! no extra top layer +! integer, parameter :: LTP = 1 ! add an extra top layer + +!> control flag for extra top layer + logical, parameter :: lextop = (LTP > 0) + +! --- publicly accessible module programs: + + public radinit, radupdate, GFS_radiation_driver + + +! ================= + contains +! ================= + +!> This subroutine initialize a model's radiation process through +!! calling of specific initialization subprograms that directly +!! related to radiation calculations. This subroutine needs to be +!! invoked only once at the start stage of a model's run, and the +!! call is placed outside of both the time advancement loop and +!! horizontal grid loop. +!> \param si model vertical sigma interface +!> \param nlay number of model vertical layers +!> \param me print control flag +!> \section gen_radinit General Algorithm +!> @{ +!----------------------------------- + subroutine radinit( si, NLAY, me ) +!................................... + +! --- inputs: +! & ( si, NLAY, me ) +! --- outputs: +! ( none ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: radinit initialization of radiation calculations ! +! ! +! usage: call radinit ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: wcoss ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input parameters: ! +! si : model vertical sigma interface ! +! NLAY : number of model vertical layers ! +! me : print control flag ! +! ! +! outputs: (none) ! +! ! +! external module variables: (in module physparam) ! +! isolar : solar constant cntrol flag ! +! = 0: use the old fixed solar constant in "physcon" ! +! =10: use the new fixed solar constant in "physcon" ! +! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! +! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! +! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! +! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! +! iaerflg : 3-digit aerosol flag (abc for volc, lw, sw) ! +! a:=0 use background stratospheric aerosol ! +! =1 include stratospheric vocanic aeros ! +! b:=0 no topospheric aerosol in lw radiation ! +! =1 compute tropspheric aero in 1 broad band for lw ! +! =2 compute tropspheric aero in multi bands for lw ! +! c:=0 no topospheric aerosol in sw radiation ! +! =1 include tropspheric aerosols for sw ! +! ico2flg : co2 data source control flag ! +! =0: use prescribed global mean co2 (old oper) ! +! =1: use observed co2 annual mean value only ! +! =2: use obs co2 monthly data with 2-d variation ! +! ictmflg : =yyyy#, external data ic time/date control flag ! +! = -2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! = -1: use user provided external data for the ! +! forecast time, no extrapolation. ! +! = 0: use data at initial cond time, if not ! +! available, use latest, no extrapolation. ! +! = 1: use data at the forecast time, if not ! +! available, use latest and extrapolation. ! +! =yyyy0: use yyyy data for the forecast time, ! +! no further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg : ozone data source control flag ! +! =0: use climatological ozone profile ! +! =1: use interactive ozone profile ! +! ialbflg : albedo scheme control flag ! +! =0: climatology, based on surface veg types ! +! =1: modis retrieval based surface albedo scheme ! +! iemsflg : emissivity scheme cntrl flag (ab 2-digit integer) ! +! a:=0 set sfc air/ground t same for lw radiation ! +! =1 set sfc air/ground t diff for lw radiation ! +! b:=0 use fixed sfc emissivity=1.0 (black-body) ! +! =1 use varying climtology sfc emiss (veg based) ! +! =2 future development (not yet) ! +! icldflg : cloud optical property scheme control flag ! +! =0: use diagnostic cloud scheme ! +! =1: use prognostic cloud scheme (default) ! +! icmphys : cloud microphysics scheme control flag ! +! =1 zhao/carr/sundqvist microphysics scheme ! +! =3 zhao/carr/sundqvist microphysics+pdf cloud & cnvc,cnvw! +! =4 GFDL cloud microphysics ! +! =5 GFDL cloud microphysics + pdf cloud & cnvc and cnvw ! +! iovrsw : control flag for cloud overlap in sw radiation ! +! iovrlw : control flag for cloud overlap in lw radiation ! +! =0: random overlapping clouds ! +! =1: max/ran overlapping clouds ! +! isubcsw : sub-column cloud approx control flag in sw radiation ! +! isubclw : sub-column cloud approx control flag in lw radiation ! +! =0: with out sub-column cloud approximation ! +! =1: mcica sub-col approx. prescribed random seed ! +! =2: mcica sub-col approx. provided random seed ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! lnoprec : precip effect in radiation flag (ferrier microphysics) ! +! =t: snow/rain has no impact on radiation ! +! =f: snow/rain has impact on radiation ! +! ivflip : vertical index direction control flag ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! subroutines called: sol_init, aer_init, gas_init, cld_init, ! +! sfc_init, rlwinit, rswinit ! +! ! +! usage: call radinit ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: NLAY, me + + real (kind=kind_phys), intent(in) :: si(:) + +! --- outputs: (none, to module variables) + +! --- locals: + +! +!===> ... begin here +! +!> -# Set up control variables and external module variables in +!! module physparam + itsfc = iemsflg / 10 ! sfc air/ground temp control + loz1st = (ioznflg == 0) ! first-time clim ozone data read flag + month0 = 0 + iyear0 = 0 + monthd = 0 + + if (me == 0) then +! print *,' NEW RADIATION PROGRAM STRUCTURES -- SEP 01 2004' + print *,' NEW RADIATION PROGRAM STRUCTURES BECAME OPER. ', & + & ' May 01 2007' + print *, VTAGRAD !print out version tag + print *,' - Selected Control Flag settings: ICTMflg=',ictmflg, & + & ' ISOLar =',isolar, ' ICO2flg=',ico2flg,' IAERflg=',iaerflg, & + & ' IALBflg=',ialbflg,' IEMSflg=',iemsflg,' ICLDflg=',icldflg, & + & ' ICMPHYS=',icmphys,' IOZNflg=',ioznflg + print *,' IVFLIP=',ivflip,' IOVRSW=',iovrsw,' IOVRLW=',iovrlw, & + & ' ISUBCSW=',isubcsw,' ISUBCLW=',isubclw +! write(0,*)' IVFLIP=',ivflip,' IOVRSW=',iovrsw,' IOVRLW=',iovrlw,& +! & ' ISUBCSW=',isubcsw,' ISUBCLW=',isubclw + print *,' LCRICK=',lcrick,' LCNORM=',lcnorm,' LNOPREC=',lnoprec + print *,' LTP =',LTP,', add extra top layer =',lextop + + if ( ictmflg==0 .or. ictmflg==-2 ) then + print *,' Data usage is limited by initial condition!' + print *,' No volcanic aerosols' + endif + + if ( isubclw == 0 ) then + print *,' - ISUBCLW=',isubclw,' No McICA, use grid ', & + & 'averaged cloud in LW radiation' + elseif ( isubclw == 1 ) then + print *,' - ISUBCLW=',isubclw,' Use McICA with fixed ', & + & 'permutation seeds for LW random number generator' + elseif ( isubclw == 2 ) then + print *,' - ISUBCLW=',isubclw,' Use McICA with random ', & + & 'permutation seeds for LW random number generator' + else + print *,' - ERROR!!! ISUBCLW=',isubclw,' is not a ', & + & 'valid option ' + stop + endif + + if ( isubcsw == 0 ) then + print *,' - ISUBCSW=',isubcsw,' No McICA, use grid ', & + & 'averaged cloud in SW radiation' + elseif ( isubcsw == 1 ) then + print *,' - ISUBCSW=',isubcsw,' Use McICA with fixed ', & + & 'permutation seeds for SW random number generator' + elseif ( isubcsw == 2 ) then + print *,' - ISUBCSW=',isubcsw,' Use McICA with random ', & + & 'permutation seeds for SW random number generator' + else + print *,' - ERROR!!! ISUBCSW=',isubcsw,' is not a ', & + & 'valid option ' + stop + endif + + if ( isubcsw /= isubclw ) then + print *,' - *** Notice *** ISUBCSW /= ISUBCLW !!!', & + & isubcsw, isubclw + endif + endif + +!> -# Initialization +!! - astronomy initialization routine: +!! call module_radiation_astronomy::sol_init() +!! - aerosols initialization routine: +!! call module_radiation_aerosols::aer_init() +!! - CO2 and other gases intialization routine: +!! call module_radiation_gases::gas_init() +!! - surface intialization routine: +!! call module_radiation_surface::sfc_init() +!! - cloud initialization routine: +!! call module_radiation_clouds::cld_init() +!! - LW radiation initialization routine: +!! call module_radlw_main::rlwinit() +!! - SW radiation initialization routine: +!! call module_radsw_main::rswinit() +! Initialization + + call sol_init ( me ) ! --- ... astronomy initialization routine + + call aer_init ( NLAY, me ) ! --- ... aerosols initialization routine + + call gas_init ( me ) ! --- ... co2 and other gases initialization routine + + call sfc_init ( me ) ! --- ... surface initialization routine + + call cld_init ( si, NLAY, me) ! --- ... cloud initialization routine + + call rlwinit ( me ) ! --- ... lw radiation initialization routine + + call rswinit ( me ) ! --- ... sw radiation initialization routine +! + return +!................................... + end subroutine radinit +!----------------------------------- +!> @} + +!> This subroutine checks and updates time sensitive data used by +!! radiation computations. This subroutine needs to be placed inside +!! the time advancement loop but outside of the horizontal grid loop. +!! It is invoked at radiation calling frequncy but before any actual +!! radiative transfer computations. +!! \param idate NCEP absolute date and time of intial condition +!! (year,month,day,time-zone,hour,minute,second, +!! mil-second) +!! \param jdate NCEP absolute date and time at forecast time +!! (year,month,day,time-zone,hour,minute,second, +!! mil-second) +!! \param deltsw SW radiation calling time interval in seconds +!! \param deltim model advancing time-step duration in seconds +!! \param lsswr logical control flag for SW radiation calculations +!! \param me print control flag +!! \param slag equation of time in radians +!! \param sdec,cdec sine and cosine of the solar declination angle +!! \param solcon solar constant adjusted by sun-earth distance \f$(W/m^2)\f$ +!> \section gen_radupdate General Algorithm +!> @{ +!----------------------------------- + subroutine radupdate( idate,jdate,deltsw,deltim,lsswr, me, & + & slag,sdec,cdec,solcon, fixed_date) +!................................... + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: radupdate calls many update subroutines to check and ! +! update radiation required but time varying data sets and module ! +! variables. ! +! ! +! usage: call radupdate ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm sp ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input parameters: ! +! idate(8) : ncep absolute date and time of initial condition ! +! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! +! jdate(8) : ncep absolute date and time at fcst time ! +! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! +! deltsw : sw radiation calling frequency in seconds ! +! deltim : model timestep in seconds ! +! lsswr : logical flags for sw radiation calculations ! +! me : print control flag ! +! fixed_date : use a fixed date for astronomical calculations ! +! does not affect solar angle calculation ! +! ! +! outputs: ! +! slag : equation of time in radians ! +! sdec, cdec : sin and cos of the solar declination angle ! +! solcon : sun-earth distance adjusted solar constant (w/m2) ! +! ! +! external module variables: ! +! isolar : solar constant cntrl (in module physparam) ! +! = 0: use the old fixed solar constant in "physcon" ! +! =10: use the new fixed solar constant in "physcon" ! +! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx! +! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx! +! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycl apprx! +! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycl apprx! +! ictmflg : =yyyy#, external data ic time/date control flag ! +! = -2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! = -1: use user provided external data for the ! +! forecast time, no extrapolation. ! +! = 0: use data at initial cond time, if not ! +! available, use latest, no extrapolation. ! +! = 1: use data at the forecast time, if not ! +! available, use latest and extrapolation. ! +! =yyyy0: use yyyy data for the forecast time, ! +! no further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ! +! module variables: ! +! loz1st : first-time clim ozone data read flag ! +! ! +! subroutines called: sol_update, aer_update, gas_update ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: idate(:), jdate(:), me + logical, intent(in) :: lsswr, fixed_date + + real (kind=kind_phys), intent(in) :: deltsw, deltim + +! --- outputs: + real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon + +! --- locals: + integer :: iyear, imon, iday, ihour + integer :: kyear, kmon, kday, khour + + logical :: lmon_chg ! month change flag + logical :: lco2_chg ! cntrl flag for updating co2 data + logical :: lsol_chg ! cntrl flag for updating solar constant +! +!===> ... begin here +! +!> -# Set up time stamp at fcst time and that for green house gases +!! (currently co2 only) +! --- ... time stamp at fcst time + + iyear = jdate(1) + imon = jdate(2) + iday = jdate(3) + ihour = jdate(5) + +! --- ... set up time stamp used for green house gases (** currently co2 only) + + if ( ictmflg==0 .or. ictmflg==-2 ) then ! get external data at initial condition time + kyear = idate(1) + kmon = idate(2) + kday = idate(3) + khour = idate(5) + else ! get external data at fcst or specified time + kyear = iyear + kmon = imon + kday = iday + khour = ihour + endif ! end if_ictmflg_block + + if ( month0 /= imon ) then + lmon_chg = .true. + month0 = imon + else + lmon_chg = .false. + endif + +!> -# Call module_radiation_astronomy::sol_update(), yearly update, no +!! time interpolation. + if (lsswr) then + + if ( isolar == 0 .or. isolar == 10 ) then + lsol_chg = .false. + elseif ( iyear0 /= iyear ) then + lsol_chg = .true. + else + lsol_chg = ( isolar==4 .and. lmon_chg ) + endif + iyear0 = iyear + + if ( fixed_date ) then + !This uses astronomy at the initial time but does not + ! alter solar angle? + call sol_update & +! --- inputs: + & ( jdate,idate,kyear,deltsw,deltim,lsol_chg, me, & +! --- outputs: + & slag,sdec,cdec,solcon & + & ) + + else + + call sol_update & +! --- inputs: + & ( jdate,jdate,kyear,deltsw,deltim,lsol_chg, me, & +! --- outputs: + & slag,sdec,cdec,solcon & + & ) + + endif + + endif ! end_if_lsswr_block + +!> -# Call module_radiation_aerosols::aer_update(), monthly update, no +!! time interpolation + if ( lmon_chg ) then + call aer_update ( iyear, imon, me ) + endif + +!> -# Call co2 and other gases update routine: +!! module_radiation_gases::gas_update() + if ( monthd /= kmon ) then + monthd = kmon + lco2_chg = .true. + else + lco2_chg = .false. + endif + + call gas_update ( kyear,kmon,kday,khour,loz1st,lco2_chg, me ) + + if ( loz1st ) loz1st = .false. + +!> -# Call surface update routine (currently not needed) +! call sfc_update ( iyear, imon, me ) + +!> -# Call clouds update routine (currently not needed) +! call cld_update ( iyear, imon, me ) +! + return +!................................... + end subroutine radupdate +!----------------------------------- +!> @} + +!> This subroutine is the driver of main radiation calculations. It +!! sets up column profiles, such as pressure, temperature, moisture, +!! gases, clouds, aerosols, etc., as well as surface radiative +!! characteristics, such as surface albedo, and emissivity. The call +!! of this subroutine is placed inside both the time advancing loop +!! and the horizontal grid loop. +!! \param prsi model level pressure in Pa +!! \param prsl model layer mean pressure in Pa +!! \param prslk exner function = \f$ (p/p0)^{rocp} \f$ +!! \param tgrs model layer mean temperature in K +!! \param qgrs layer specific humidity in gm/gm +!! \param tracer layer prognostic tracer amount mixing-ratio, +!! including: ozone,cloud condensate,aerosols,etc +!! \param vvl layer mean vertical velocity in pa/sec +!! (used only for the legacy diagnostic style of +!! cloud scheme) +!! \param slmsk sea/land mask array (sea:0,land:1,sea-ice:2) +!! \param xlon grid longitude in radians,ok for both 0->2pi or +!! -pi->+pi ranges +!! \param xlat grid latitude in radians, default to pi/2->-pi/2 +!! range, otherwise need to adjust in the called +!! subroutine +!! \param tsfc surface temperature in K +!! \param snowd snow depth water equivalent in mm (used when +!! control flag ialbflg=1) +!! \param sncovr snow cover in fraction (used when contrl flag +!! ialbflg=1) +!! \param snoalb maximum snow albedo in fraction (used when control +!! flag ialbflg=1) +!! \param zorl surface roughness in cm +!! \param hprim topographic standard deviation in m +!! \param alvsf ialbflg=0: uv+visible albedo with strong cosz +!! dependency (z=60) +!!\n ialbflg=1: uv+visible black sky albedo (z=60 degree) +!! \param alnsf ialbflg=0: near IR albedo with strong cosz +!! dependency (z=60) +!!\n ialbflg=1: near IR black sky albedo (z=60 degree) +!! \param alvwf ialbflg=0: uv+visible albedo with weak cosz +!! dependency (z=60) +!!\n ialbflg=1: uv+visible white sky albedo +!! \param alnwf ialbflg=0: near IR albedo with weak cosz +!! dependency (z=60) +!!\n ialbflg=1: near IR white sky albedo +!! \param facsf fractional coverage with strong cosz dependency +!! \param facwf fractional coverage with weak cosz dependency +!! \param fice fraction ice cover over open water grid +!! \param tisfc surface temperature over ice cover in K +!! \param sinlat sine of latitude for the model grid +!! \param coslat cosine of latitude for the model grid +!! \param solhr hour time after 00z at the current time-step +!! \param jdate current forecast date and time (year, month, +!! day,time-zone,hour, minute, second, mil-second) +!! \param solcon solar constant (sun-earth distant adjusted) in \f$W/m^2\f$ +!! \param cv fraction of convective cloud cover +!! (for diagnostic clouds only) +!! \param cvt,cvb convective cloud top/bottom pressure in pa +!! (for diagnostic clouds only) +!! \param fcice fraction of cloud ice content +!! (for Ferrier microphysics scheme only) +!! \param frain fraction of rain water +!! (for Ferrier microphysics scheme only) +!! \param rrime mass ratio of total to unrimed ice content +!! (>= 1, for Ferrier microphysics scheme only) +!! \param flgmin minimum large ice fraction +!! (for Ferrier microphysics scheme only) +!! \param icsdsw,icsdlw auxiliary cloud control arrays for radiations +!! if isubcsw/isubclw (\ref physparam) are set to 2, +!! the arrays contains random seeds for the sub-column +!! cloud overlap scheme, McICA, used in SW/LW radiations +!! \param ntcw =0: no cloud condensate calculated; +!!\n >0: tracer array location index for cloud condensate +!! \param ncld only used when ntcw>0 +!! \param ntoz =0: use climatological ozone profile +!!\n >0: use interactive ozone profile +!! \param NTRAC number of tracers +!! \param NFXR number of fields (second dimension) of I/O array fluxr +!! \param dtlw,dtsw time durations for LW/SW radiation calls in second +!! \param lsswr,lslwr logical control flags for SW/LW radiation calls +!! \param lssav logical control flag for storing 3-d cloud field +!! \param IX,IM horizontal dimension and number of used points +!! \param LM vertical layer dimension +!! \param me control flag for parallel process +!! \param lprnt control flag for diagnostic printout +!! \param ipt grid-point index for diagnostic printout (debugging) +!! \param kdt time-step sequential number +!! \param deltaq half width of pdf cloud uniform total water distribution +!! (for pdf cloud cover scheme) +!! \param sup supersaturation in pdf cloud when t is very low +!! (for pdf cloud cover scheme) +!! \param cnvw layer convective cloud water content +!! (for pdf cloud scheme) +!! \param cnvc layer convective cloud cover +!! (for pdf cloud scheme) +!! \param htrsw total sky SW heating rate in k/sec +!! \param topfsw derived type, SW radiation fluxes at TOA, components: +!! (check module_radsw_parameters for definition) +!! \n %upfxc - total-sky upward SW flux at toa (\f$W/m^2\f$) +!! \n %dnflx - total-sky downward SW flux at toa (\f$W/m^2\f$) +!! \n %upfx0 - clear-sky upward SW flux at toa (\f$W/m^2\f$) +!! \param sfcfsw derived type, SW radiation fluxes at surface, components: +!! (check module_radsw_parameters for definition) +!! \n %upfxc - total-sky upward SW flux at sfc (\f$W/m^2\f$) +!! \n %dnfxc - total-sky downward SW flux at sfc (\f$W/m^2\f$) +!! \n %upfx0 - clear-sky upward SW flux at sfc (\f$W/m^2\f$) +!! \n %dnfx0 - clear-sky downward SW flux at sfc (\f$W/m^2\f$) +!! \param dswcmp downward surface SW spectral components: +!! \n (:, 1) - total-sky sfc downward nir direct flux +!! \n (:, 2) - total-sky sfc downward nir diffused flux +!! \n (:, 3) - total-sky sfc downward uv+vis direct flux +!! \n (:, 4) - total-sky sfc downward uv+vis diffused flux +!! \param uswcmp upward surface SW spectral components: +!! \n (:, 1) - total-sky sfc upward nir direct flux +!! \n (:, 2) - total-sky sfc upward nir diffused flux +!! \n (:, 3) - total-sky sfc upward uv+vis direct flux +!! \n (:, 4) - total-sky sfc upward uv+vis diffused flux +!! \param sfalb mean surface diffused albedo for SW radiation +!! \param coszen mean cosine of solar zenith angle over radiation calling period +!! \param coszdg daytime mean cosine of zenith angle over the radiation +!! calling period +!! \param htrlw total-sky LW heating rate in k/sec +!! \param topflw derived type, LW radiation fluxes at TOA, component: +!! (check module_radlw_paramters for definition) +!! \n %upfxc - total-sky upward LW flux at toa (\f$W/m^2\f$) +!! \n %upfx0 - clear-sky upward LW flux at toa (\f$W/m^2\f$) +!! \param sfcflw derived type, LW radiation fluxes at surface, component: +!! (check module_radlw_paramters for definition) +!! \n %upfxc - total-sky upward LW flux at sfc (\f$W/m^2\f$) +!! \n %upfx0 - clear-sky upward LW flux at sfc (\f$W/m^2\f$) +!! \n %dnfxc - total-sky downward LW flux at sfc (\f$W/m^2\f$) +!! \n %dnfx0 - clear-sky downward LW flux at sfc (\f$W/m^2\f$) +!! \param tsflw surface air temp during LW calculation call in K +!! \param semis surface emissivity in fraction for LW radiation +!! \param cldcov 3-d cloud fraction +!! \param fluxr array for saving time accumulated 2-d fields that are +!! defined as: +!! \n (:, 1) - toa total-sky upward LW radiation flux +!! \n (:, 2) - toa total-sky upward SW radiation flux +!! \n (:, 3) - sfc total-sky upward SW radiation flux +!! \n (:, 4) - sfc total-sky downward SW radiation flux +!! \n (:, 5) - high domain cloud fraction +!! \n (:, 6) - mid domain cloud fraction +!! \n (:, 7) - low domain cloud fraction +!! \n (:, 8) - high domain mean cloud top pressure +!! \n (:, 9) - mid domain mean cloud top pressure +!! \n (:,10) - low domain mean cloud top pressure +!! \n (:,11) - high domain mean cloud base pressure +!! \n (:,12) - mid domain mean cloud base pressure +!! \n (:,13) - low domain mean cloud base pressure +!! \n (:,14) - high domain mean cloud top temperature +!! \n (:,15) - mid domain mean cloud top temperature +!! \n (:,16) - low domain mean cloud top temperature +!! \n (:,17) - total cloud fraction +!! \n (:,18) - boundary layer domain cloud fraction +!! \n (:,19) - sfc total-sky downward LW radiation flux +!! \n (:,20) - sfc total-sky upward LW radiation flux +!! \n (:,21) - sfc total-sky downward SW UV-B radiation flux +!! \n (:,22) - sfc clear-sky downward SW UV-B radiation flux +!! \n (:,23) - TOA incoming solar radiation flux +!! \n (:,24) - sfc UV+visible beam downward SW radiation flux +!! \n (:,25) - sfc UV+visible diffused downward SW radiation flux +!! \n (:,26) - sfc near-IR beam downward SW radiation flux +!! \n (:,27) - sfc near-IR diffused downward SW radiation flux +!! \n (:,28) - toa clear-sky upward LW radiation flux +!! \n (:,29) - toa clear-sky upward SW radiation flux +!! \n (:,30) - sfc clear-sky downward LW radiation flux +!! \n (:,31) - sfc clear-sky upward SW radiation flux +!! \n (:,32) - sfc clear-sky downward SW radiation flux +!! \n (:,33) - sfc clear-sky upward LW radiation flux +!! \n optional: +!! \n (:,34) - aerosol AOD at 550nm (all components) +!! \n (:,35) - aerosol AOD at 550nm for du component +!! \n (:,36) - aerosol AOD at 550nm for bc component +!! \n (:,37) - aerosol AOD at 550nm for oc component +!! \n (:,38) - aerosol AOD at 550nm for su component +!! \n (:,39) - aerosol AOD at 550nm for ss component +!! \param htrswb spectral bands distributed total sky SW heating rate in k/sec +!! \param htrlwb spectral bands distributed total sky LW heating rate in k/sec +!! +!> \section gen_grrad General Algorithm +!> @{ +!----------------------------------- + subroutine GFS_radiation_driver & + (Model, Statein, Stateout, Sfcprop, Coupling, Grid, Tbd, & + Cldprop, Radtend, Diag) + + implicit none + + type(GFS_control_type), intent(in) :: Model + type(GFS_statein_type), intent(in) :: Statein + type(GFS_stateout_type), intent(inout) :: Stateout + type(GFS_sfcprop_type), intent(in) :: Sfcprop + type(GFS_coupling_type), intent(inout) :: Coupling + type(GFS_grid_type), intent(in) :: Grid + type(GFS_tbd_type), intent(in) :: Tbd + type(GFS_cldprop_type), intent(in) :: Cldprop + type(GFS_radtend_type), intent(inout) :: Radtend + type(GFS_diag_type), intent(inout) :: Diag + + +! ================= subprogram documentation block ================ ! +! ! +! this program is the driver of radiation calculation subroutines. * ! +! It sets up profile variables for radiation input, including * ! +! clouds, surface albedos, atmospheric aerosols, ozone, etc. * ! +! * ! +! usage: call grrad * ! +! * ! +! subprograms called: * ! +! setalb, setemis, setaer, getozn, getgases, * ! +! progcld1, progcld2, progclduni, diagcds, * ! +! swrad, lwrad, fpvs * ! +! * ! +! attributes: * ! +! language: fortran 90 * ! +! machine: ibm-sp, sgi * ! +! * ! +! * ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! type(GFS_control_type), intent(in) :: Model ! +! type(GFS_statein_type), intent(in) :: Statein ! +! type(GFS_sfcprop_type), intent(in) :: Sfcprop ! +! type(GFS_grid_type), intent(in) :: Grid ! +! type(GFS_tbd_type), intent(in) :: Tbd ! +! type(GFS_cldprop_type), intent(in) :: Cldprop ! +! ! +! input/output variables: ! +! type(GFS_coupling_type), intent(inout) :: Coupling ! +! type(GFS_radtend_type), intent(inout) :: Radtend ! +! type(GFS_diag_type), intent(inout) :: Diag ! +! ! +! optional: ! +! real(kind=kind_phys), optional, intent(out) :: htrlw0(:,:) ! +! real(kind=kind_phys), optional, intent(out) :: htrsw0(:,:) ! +! ! +! optional output variables: ! +! htrswb(IX,LM,NBDSW) : spectral band total sky sw heating rate ! +! htrlwb(IX,LM,NBDLW) : spectral band total sky lw heating rate ! +! ! +! ! +! definitions of internal variable arrays: ! +! ! +! 1. fixed gases: (defined in 'module_radiation_gases') ! +! gasvmr(:,:,1) - co2 volume mixing ratio ! +! gasvmr(:,:,2) - n2o volume mixing ratio ! +! gasvmr(:,:,3) - ch4 volume mixing ratio ! +! gasvmr(:,:,4) - o2 volume mixing ratio ! +! gasvmr(:,:,5) - co volume mixing ratio ! +! gasvmr(:,:,6) - cf11 volume mixing ratio ! +! gasvmr(:,:,7) - cf12 volume mixing ratio ! +! gasvmr(:,:,8) - cf22 volume mixing ratio ! +! gasvmr(:,:,9) - ccl4 volume mixing ratio ! +! ! +! 2. cloud profiles: (defined in 'module_radiation_clouds') ! +! --- for prognostic cloud --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path ! +! clouds(:,:,3) - mean effective radius for liquid cloud ! +! clouds(:,:,4) - layer cloud ice water path ! +! clouds(:,:,5) - mean effective radius for ice cloud ! +! clouds(:,:,6) - layer rain drop water path ! +! clouds(:,:,7) - mean effective radius for rain drop ! +! clouds(:,:,8) - layer snow flake water path ! +! clouds(:,:,9) - mean effective radius for snow flake ! +! --- for diagnostic cloud --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud optical depth ! +! clouds(:,:,3) - layer cloud single scattering albedo ! +! clouds(:,:,4) - layer cloud asymmetry factor ! +! ! +! 3. surface albedo: (defined in 'module_radiation_surface') ! +! sfcalb( :,1 ) - near ir direct beam albedo ! +! sfcalb( :,2 ) - near ir diffused albedo ! +! sfcalb( :,3 ) - uv+vis direct beam albedo ! +! sfcalb( :,4 ) - uv+vis diffused albedo ! +! ! +! 4. sw aerosol profiles: (defined in 'module_radiation_aerosols') ! +! faersw(:,:,:,1)- sw aerosols optical depth ! +! faersw(:,:,:,2)- sw aerosols single scattering albedo ! +! faersw(:,:,:,3)- sw aerosols asymmetry parameter ! +! ! +! 5. lw aerosol profiles: (defined in 'module_radiation_aerosols') ! +! faerlw(:,:,:,1)- lw aerosols optical depth ! +! faerlw(:,:,:,2)- lw aerosols single scattering albedo ! +! faerlw(:,:,:,3)- lw aerosols asymmetry parameter ! +! ! +! 6. sw fluxes at toa: (defined in 'module_radsw_main') ! +! (topfsw_type -- derived data type for toa rad fluxes) ! +! topfsw(:)%upfxc - total sky upward flux at toa ! +! topfsw(:)%dnfxc - total sky downward flux at toa ! +! topfsw(:)%upfx0 - clear sky upward flux at toa ! +! ! +! 7. lw fluxes at toa: (defined in 'module_radlw_main') ! +! (topflw_type -- derived data type for toa rad fluxes) ! +! topflw(:)%upfxc - total sky upward flux at toa ! +! topflw(:)%upfx0 - clear sky upward flux at toa ! +! ! +! 8. sw fluxes at sfc: (defined in 'module_radsw_main') ! +! (sfcfsw_type -- derived data type for sfc rad fluxes) ! +! sfcfsw(:)%upfxc - total sky upward flux at sfc ! +! sfcfsw(:)%dnfxc - total sky downward flux at sfc ! +! sfcfsw(:)%upfx0 - clear sky upward flux at sfc ! +! sfcfsw(:)%dnfx0 - clear sky downward flux at sfc ! +! ! +! 9. lw fluxes at sfc: (defined in 'module_radlw_main') ! +! (sfcflw_type -- derived data type for sfc rad fluxes) ! +! sfcflw(:)%upfxc - total sky upward flux at sfc ! +! sfcflw(:)%dnfxc - total sky downward flux at sfc ! +! sfcflw(:)%dnfx0 - clear sky downward flux at sfc ! +! ! +!! optional radiation outputs: ! +!! 10. sw flux profiles: (defined in 'module_radsw_main') ! +!! (profsw_type -- derived data type for rad vertical profiles) ! +!! fswprf(:,:)%upfxc - total sky upward flux ! +!! fswprf(:,:)%dnfxc - total sky downward flux ! +!! fswprf(:,:)%upfx0 - clear sky upward flux ! +!! fswprf(:,:)%dnfx0 - clear sky downward flux ! +!! ! +!! 11. lw flux profiles: (defined in 'module_radlw_main') ! +!! (proflw_type -- derived data type for rad vertical profiles) ! +!! flwprf(:,:)%upfxc - total sky upward flux ! +!! flwprf(:,:)%dnfxc - total sky downward flux ! +!! flwprf(:,:)%upfx0 - clear sky upward flux ! +!! flwprf(:,:)%dnfx0 - clear sky downward flux ! +!! ! +!! 12. sw sfc components: (defined in 'module_radsw_main') ! +!! (cmpfsw_type -- derived data type for component sfc fluxes) ! +!! scmpsw(:)%uvbfc - total sky downward uv-b flux at sfc ! +!! scmpsw(:)%uvbf0 - clear sky downward uv-b flux at sfc ! +!! scmpsw(:)%nirbm - total sky sfc downward nir direct flux ! +!! scmpsw(:)%nirdf - total sky sfc downward nir diffused flux ! +!! scmpsw(:)%visbm - total sky sfc downward uv+vis direct flx ! +!! scmpsw(:)%visdf - total sky sfc downward uv+vis diff flux ! +! ! +! external module variables: ! +! ivflip : control flag for in/out vertical indexing ! +! =0 index from toa to surface ! +! =1 index from surface to toa ! +! icmphys : cloud microphysics scheme control flag ! +! =1 zhao/carr/sundqvist microphysics scheme ! +! =3 zhao/carr/sundqvist microphysics +pdf cloud ! +! =4 GFDL cloud microphysics ! +! =5 GFDL cloud microphysics + pdf cloud ! +! ! +! module variables: ! +! itsfc : =0 use same sfc skin-air/ground temp ! +! =1 use diff sfc skin-air/ground temp (not yet) ! +! ! +! ====================== end of definitions ======================= ! +! +! --- local variables: (horizontal dimensioned by IM) + !--- INTEGER VARIABLES + integer :: me, im, lm, nfxr, nkld, ntrac + integer :: i, j, k, k1, lv, itop, ibtc, nday, LP1, LMK, LMP, kd, & + lla, llb, lya, lyb, kt, kb + integer, dimension(size(Grid%xlon,1)) :: idxday + integer, dimension(size(Grid%xlon,1),3) :: mbota, mtopa + + !--- REAL VARIABLES + real(kind=kind_phys) :: raddt, es, qs, delt, tem0d + + real(kind=kind_phys), dimension(size(Grid%xlon,1)) :: & + tsfa, cvt1, cvb1, tem1d, tsfg, tskn + + real(kind=kind_phys), dimension(size(Grid%xlon,1),5) :: cldsa + real(kind=kind_phys), dimension(size(Grid%xlon,1),NSPC1) :: aerodp + real(kind=kind_phys), dimension(size(Grid%xlon,1),NF_ALBD) :: sfcalb + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP) :: & + htswc, htlwc, gcice, grain, grime, htsw0, htlw0, plyr, tlyr, & + qlyr, olyr, rhly, tvly,qstl, vvel, clw, ciw, prslk1, tem2da, & + tem2db, cldcov, deltaq, cnvc, cnvw + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+1+LTP) :: plvl, tlvl + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,2:Model%ntrac) :: tracer1 + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_CLDS) :: clouds + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NF_VGAS) :: gasvmr + + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDSW,NF_AESW)::faersw + real(kind=kind_phys), dimension(size(Grid%xlon,1),Model%levr+LTP,NBDLW,NF_AELW)::faerlw + + !--- TYPED VARIABLES + type (cmpfsw_type), dimension(size(Grid%xlon,1)) :: scmpsw +! +!===> ... begin here +!only call GFS_radiation_driver at radiation time step + if (.not. (Model%lsswr .or. Model%lslwr )) return +! + !--- set commonly used integers + me = Model%me + LM = Model%levr + IM = size(Grid%xlon,1) + NFXR = Model%nfxr + nkld = Model%nkld + NTRAC = Model%ntrac ! tracers in grrad strip off sphum - start tracer1(2:NTRAC) + + LP1 = LM + 1 ! num of in/out levels + +! --- ... set local /level/layer indexes corresponding to in/out variables + + LMK = LM + LTP ! num of local layers + LMP = LMK + 1 ! num of local levels + + if ( lextop ) then + if ( ivflip == 1 ) then ! vertical from sfc upward + kd = 0 ! index diff between in/out and local + kt = 1 ! index diff between lyr and upper bound + kb = 0 ! index diff between lyr and lower bound + lla = LMK ! local index at the 2nd level from top + llb = LMP ! local index at toa level + lya = LM ! local index for the 2nd layer from top + lyb = LP1 ! local index for the top layer + else ! vertical from toa downward + kd = 1 ! index diff between in/out and local + kt = 0 ! index diff between lyr and upper bound + kb = 1 ! index diff between lyr and lower bound + lla = 2 ! local index at the 2nd level from top + llb = 1 ! local index at toa level + lya = 2 ! local index for the 2nd layer from top + lyb = 1 ! local index for the top layer + endif ! end if_ivflip_block + else + kd = 0 + if ( ivflip == 1 ) then ! vertical from sfc upward + kt = 1 ! index diff between lyr and upper bound + kb = 0 ! index diff between lyr and lower bound + else ! vertical from toa downward + kt = 0 ! index diff between lyr and upper bound + kb = 1 ! index diff between lyr and lower bound + endif ! end if_ivflip_block + endif ! end if_lextop_block + + raddt = min(Model%fhswr, Model%fhlwr) +! print *,' in grrad : raddt=',raddt + +!> -# Setup surface ground temperature and ground/air skin temperature +!! if required. + + if ( itsfc == 0 ) then ! use same sfc skin-air/ground temp + do i = 1, IM + tskn(i) = Sfcprop%tsfc(i) + tsfg(i) = Sfcprop%tsfc(i) + enddo + else ! use diff sfc skin-air/ground temp + do i = 1, IM + tskn(i) = Sfcprop%tsfc(i) + tsfg(i) = Sfcprop%tsfc(i) + enddo + endif + +!> -# Prepare atmospheric profiles for radiation input. +! +! convert pressure unit from pa to mb + do k = 1, LM + k1 = k + kd + do i = 1, IM + plvl(i,k1) = 0.01 * Statein%prsi(i,k) ! pa to mb (hpa) + plyr(i,k1) = 0.01 * Statein%prsl(i,k) ! pa to mb (hpa) + tlyr(i,k1) = Statein%tgrs(i,k) + prslk1(i,k1) = Statein%prslk(i,k) + +!> - Compute relative humidity. +! es = min( Statein%prsl(i,k), 0.001 * fpvs( Statein%tgrs(i,k) ) ) ! fpvs in pa + es = min( Statein%prsl(i,k), fpvs( Statein%tgrs(i,k) ) ) ! fpvs and prsl in pa + qs = max( QMIN, eps * es / (Statein%prsl(i,k) + epsm1*es) ) + rhly(i,k1) = max( 0.0, min( 1.0, max(QMIN, Statein%qgrs(i,k,1))/qs ) ) + qstl(i,k1) = qs + enddo + enddo + + !--- recast remaining all tracers (except sphum) forcing them all to be positive + do j = 2, NTRAC + do k = 1, LM + k1 = k + kd + tracer1(:,k1,j) = max(0.0,Statein%qgrs(:,k,j)) + enddo + enddo + + do i = 1, IM + plvl(i,LP1+kd) = 0.01 * Statein%prsi(i,LP1) ! pa to mb (hpa) + enddo + + if ( lextop ) then ! values for extra top layer + do i = 1, IM + plvl(i,llb) = prsmin + if ( plvl(i,lla) <= prsmin ) plvl(i,lla) = 2.0*prsmin + plyr(i,lyb) = 0.5 * plvl(i,lla) + tlyr(i,lyb) = tlyr(i,lya) + prslk1(i,lyb) = (plyr(i,lyb)*0.00001) ** rocp ! plyr in Pa + rhly(i,lyb) = rhly(i,lya) + qstl(i,lyb) = qstl(i,lya) + enddo + +! --- note: may need to take care the top layer amount + tracer1(:,lyb,:) = tracer1(:,lya,:) + endif + +!> - Get layer ozone mass mixing ratio (if use ozone climatology data, +!! call getozn()). + + if (Model%ntoz > 0) then ! interactive ozone generation + olyr(:,:) = max( QMIN, tracer1(:,1:LMK,Model%ntoz) ) + else ! climatological ozone + call getozn (prslk1, Grid%xlat, IM, LMK, & ! --- inputs + olyr) ! --- outputs + endif ! end_if_ntoz + +!> - Call coszmn(), to compute cosine of zenith angle. + if( Model%lsswr ) then + call coszmn (Grid%xlon,Grid%sinlat, & ! --- inputs + Grid%coslat,Model%solhr, IM, me, & + Model%daily_mean, & + Radtend%coszen, Radtend%coszdg) ! --- outputs + endif + +!> - Call getgases(), to set up non-prognostic gas volume mixing +!! ratioes (gasvmr). +! - gasvmr(:,:,1) - co2 volume mixing ratio +! - gasvmr(:,:,2) - n2o volume mixing ratio +! - gasvmr(:,:,3) - ch4 volume mixing ratio +! - gasvmr(:,:,4) - o2 volume mixing ratio +! - gasvmr(:,:,5) - co volume mixing ratio +! - gasvmr(:,:,6) - cf11 volume mixing ratio +! - gasvmr(:,:,7) - cf12 volume mixing ratio +! - gasvmr(:,:,8) - cf22 volume mixing ratio +! - gasvmr(:,:,9) - ccl4 volume mixing ratio + +! --- ... set up non-prognostic gas volume mixing ratioes + + call getgases (plvl, Grid%xlon, Grid%xlat, IM, LMK, & ! --- inputs + gasvmr) ! --- outputs + +!> - Get temperature at layer interface, and layer moisture. + do k = 2, LMK + do i = 1, IM + tem2da(i,k) = log( plyr(i,k) ) + tem2db(i,k) = log( plvl(i,k) ) + enddo + enddo + + if (ivflip == 0) then ! input data from toa to sfc + do i = 1, IM + tem1d (i) = QME6 + tem2da(i,1) = log( plyr(i,1) ) + tem2db(i,1) = 1.0 + tsfa (i) = tlyr(i,LMK) ! sfc layer air temp + tlvl(i,1) = tlyr(i,1) + tlvl(i,LMP) = tskn(i) + enddo + + do k = 1, LM + k1 = k + kd + do i = 1, IM + qlyr(i,k1) = max( tem1d(i), Statein%qgrs(i,k,1) ) + tem1d(i) = min( QME5, qlyr(i,k1) ) + tvly(i,k1) = Statein%tgrs(i,k) * (1.0 + fvirt*qlyr(i,k1)) ! virtual T (K) + enddo + enddo + + if ( lextop ) then + do i = 1, IM + qlyr(i,lyb) = qlyr(i,lya) + tvly(i,lyb) = tvly(i,lya) + enddo + endif + + do k = 2, LMK + do i = 1, IM + tlvl(i,k) = tlyr(i,k) + (tlyr(i,k-1) - tlyr(i,k)) & + & * (tem2db(i,k) - tem2da(i,k)) & + & / (tem2da(i,k-1) - tem2da(i,k)) + enddo + enddo + + else ! input data from sfc to toa + + do i = 1, IM + tem1d (i) = QME6 + tem2da(i,1) = log( plyr(i,1) ) + tem2db(i,1) = log( plvl(i,1) ) + tsfa (i) = tlyr(i,1) ! sfc layer air temp + tlvl(i,1) = tskn(i) + tlvl(i,LMP) = tlyr(i,LMK) + enddo + + do k = LM, 1, -1 + do i = 1, IM + qlyr(i,k) = max( tem1d(i), Statein%qgrs(i,k,1) ) + tem1d(i) = min( QME5, qlyr(i,k) ) + tvly(i,k) = Statein%tgrs(i,k) * (1.0 + fvirt*qlyr(i,k)) ! virtual T (K) + enddo + enddo + + if ( lextop ) then + do i = 1, IM + qlyr(i,lyb) = qlyr(i,lya) + tvly(i,lyb) = tvly(i,lya) + enddo + endif + + do k = 1, LMK-1 + do i = 1, IM + tlvl(i,k+1) = tlyr(i,k) + (tlyr(i,k+1) - tlyr(i,k)) & + & * (tem2db(i,k+1) - tem2da(i,k)) & + & / (tem2da(i,k+1) - tem2da(i,k)) + enddo + enddo + + endif ! end_if_ivflip + +!> - Check for daytime points for SW radiation. + + nday = 0 + do i = 1, IM + if (Radtend%coszen(i) >= 0.0001) then + nday = nday + 1 + idxday(nday) = i + endif + enddo + +!> - Call module_radiation_aerosols::setaer(),to setup aerosols +!! property profile for radiation. + +!check print *,' in grrad : calling setaer ' + + call setaer (plvl, plyr, prslk1, tvly, rhly, Sfcprop%slmsk, & ! --- inputs + tracer1, Grid%xlon, Grid%xlat, IM, LMK, LMP, & + Model%lsswr,Model%lslwr, & + faersw,faerlw,aerodp) ! --- outputs + +!> - Obtain cloud information for radiation calculations +!! (clouds,cldsa,mtopa,mbota) +!!\n for prognostic cloud: +!! - For Zhao/Moorthi's prognostic cloud scheme, +!! call module_radiation_clouds::progcld1() +!! - For Zhao/Moorthi's prognostic cloud+pdfcld, +!! call module_radiation_clouds::progcld3() +!! call module_radiation_clouds::progclduni() for unified cloud and ncld=2 +!> - If cloud condensate is not computed (ntcw=0), using the legacy +!! cloud scheme, compute cloud information based on Slingo's +!! diagnostic cloud scheme (call module_radiation_clouds::diagcld1()) + +! --- ... obtain cloud information for radiation calculations + + if (Model%ntcw > 0) then ! prognostic cloud scheme + if (Model%uni_cld .and. Model%ncld >= 2) then + clw(:,:) = tracer1(:,1:LMK,Model%ntcw) ! cloud water amount + ciw(:,:) = 0.0 + do j = 2, Model%ncld + ciw(:,:) = ciw(:,:) + tracer1(:,1:LMK,Model%ntcw+j-1) ! cloud ice amount + enddo + + do k = 1, LMK + do i = 1, IM + if ( clw(i,k) < EPSQ ) clw(i,k) = 0.0 + if ( ciw(i,k) < EPSQ ) ciw(i,k) = 0.0 + enddo + enddo + else + clw(:,:) = 0.0 + do j = 1, Model%ncld + clw(:,:) = clw(:,:) + tracer1(:,1:LMK,Model%ntcw+j-1) ! cloud condensate amount + enddo + + do k = 1, LMK + do i = 1, IM + if ( clw(i,k) < EPSQ ) clw(i,k) = 0.0 + enddo + enddo + endif +! +! --- add suspended convective cloud water to grid-scale cloud water +! only for cloud fraction & radiation computation +! it is to enhance cloudiness due to suspended convec cloud water +! for zhao/moorthi's (icmphys=1) & +! ferrier's (icmphys=2) microphysics schemes +! + if (Model%shoc_cld) then ! all but MG microphys + cldcov(:,1:LM) = Tbd%phy_f3d(:,1:LM,Model%ntot3d-2) + elseif (Model%ncld == 2) then ! MG microphys (icmphys = 1) + cldcov(:,1:LM) = Tbd%phy_f3d(:,1:LM,1) + else ! neither of the other two cases + cldcov = 0 + endif + + if ((Model%num_p3d == 4) .and. (Model%npdf3d == 3)) then ! icmphys = 3 + deltaq(:,1:LM) = Tbd%phy_f3d(:,1:LM,5) + cnvw (:,1:LM) = Tbd%phy_f3d(:,1:LM,6) + cnvc (:,1:LM) = Tbd%phy_f3d(:,1:LM,7) + elseif ((Model%npdf3d == 0) .and. (Model%ncnvcld3d == 1)) then ! icmphys = 1 + deltaq(:,1:LM) = 0. + cnvw (:,1:LM) = Tbd%phy_f3d(:,1:LM,Model%num_p3d+1) + cnvc (:,1:LM) = 0. + else ! icmphys = 1 (ncld=2) + deltaq = 0.0 + cnvw = 0.0 + cnvc = 0.0 + endif + + if (lextop) then + cldcov(:,lyb) = cldcov(:,lya) + deltaq(:,lyb) = deltaq(:,lya) + cnvw (:,lyb) = cnvw (:,lya) + cnvc (:,lyb) = cnvc (:,lya) + endif + + if (icmphys == 1) then + clw(:,1:LMK) = clw(:,1:LMK) + cnvw(:,1:LMK) + endif +! + + if (icmphys == 1) then ! zhao/moorthi's prognostic cloud scheme + ! or unified cloud and/or with MG microphysics + + if (Model%uni_cld .and. Model%ncld >= 2) then + call progclduni (plyr, plvl, tlyr, tvly, clw, ciw, & ! --- inputs + Grid%xlat, Grid%xlon, Sfcprop%slmsk, & + IM, LMK, LMP, cldcov(:,1:LMK), & + clouds, cldsa, mtopa, mbota) ! --- outputs + else + call progcld1 (plyr ,plvl, tlyr, tvly, qlyr, qstl, & ! --- inputs + rhly, clw, Grid%xlat,Grid%xlon, & + Sfcprop%slmsk, IM, LMK, LMP, & + Model%uni_cld, Model%lmfshal, & + Model%lmfdeep2, cldcov(:,1:LMK), & + clouds, cldsa, mtopa, mbota) ! --- outputs + endif + + elseif(icmphys == 3) then ! zhao/moorthi's prognostic cloud+pdfcld + + call progcld3 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs + clw, cnvw, cnvc, Grid%xlat, Grid%xlon, & + Sfcprop%slmsk,im, lmk, lmp, deltaq, & + Model%sup, Model%kdt, me, & + clouds, cldsa, mtopa, mbota) ! --- outputs + + elseif (icmphys == 4) then ! zhao/moorthi's prognostic cloud scheme + + call progcld4 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs + clw, Grid%xlat, Grid%xlon, Sfcprop%slmsk,& + tracer1(:,1:lmk,Model%ntclamt), im, lmk, & + lmp, & + clouds, cldsa, mtopa, mbota) ! --- outputs + + elseif (icmphys == 5) then ! zhao/moorthi's prognostic cloud scheme + pdf cloud & cnvc and cnvw + + if (.not. Model%cloud_gfdl) then + call progcld5 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs + clw, cnvw, cnvc, Grid%xlat, Grid%xlon, & + Sfcprop%slmsk, tracer1(:,1:lmk,Model%ntclamt),& + im, lmk, lmp, clouds, cldsa, mtopa, mbota) ! --- outputs + else + call progcld6 (plyr, plvl, tlyr, tvly, qlyr, qstl, rhly,& ! --- inputs + clw, cnvw, cnvc, Grid%xlat, Grid%xlon, & + tracer1(:,1:lmk,Model%ntcw), & + tracer1(:,1:lmk,Model%ntrw), & + tracer1(:,1:lmk,Model%ntiw), & + tracer1(:,1:lmk,Model%ntsw), & + tracer1(:,1:lmk,Model%ntgl), & + Sfcprop%slmsk, Sfcprop%snowd, & + tracer1(:,1:lmk,Model%ntclamt),& + im, lmk, lmp, clouds, cldsa, mtopa, mbota) ! --- outputs + endif + + endif ! end if_icmphys + + else ! diagnostic cloud scheme + + cvt1(:) = 0.01 * Cldprop%cvt(:) + cvb1(:) = 0.01 * Cldprop%cvb(:) + + do k = 1, LM + k1 = k + kd + vvel(:,k1) = 0.01 * Statein%vvl(:,k) + enddo + if (lextop) then + vvel(:,lyb) = vvel(:,lya) + endif + +! --- compute diagnostic cloud related quantities + + call diagcld1 (plyr, plvl, tlyr, rhly, vvel, Cldprop%cv, & ! --- inputs + cvt1, cvb1, Grid%xlat, Grid%xlon, & + Sfcprop%slmsk, IM, LMK, LMP, & + clouds, cldsa, mtopa, mbota) ! --- outputs + + endif ! end_if_ntcw + +! --- ... start radiation calculations +! remember to set heating rate unit to k/sec! +!> -# Start SW radiation calculations + if (Model%lsswr) then + +!> - Call module_radiation_surface::setalb() to setup surface albedo. +!! for SW radiation. + + call setalb (Sfcprop%slmsk, Sfcprop%snowd, Sfcprop%sncovr,& ! --- inputs: + Sfcprop%snoalb, Sfcprop%zorl, Radtend%coszen,& + tsfg, tsfa, Sfcprop%hprim, Sfcprop%alvsf, & + Sfcprop%alnsf, Sfcprop%alvwf, Sfcprop%alnwf, & + Sfcprop%facsf, Sfcprop%facwf, Sfcprop%fice, & + Sfcprop%tisfc, IM, & + sfcalb) ! --- outputs + +!> -# Approximate mean surface albedo from vis- and nir- diffuse values. + Radtend%sfalb(:) = max(0.01, 0.5 * (sfcalb(:,2) + sfcalb(:,4))) + + if (nday > 0) then + +!> - Call module_radsw_main::swrad(), to compute SW heating rates and +!! fluxes. +! print *,' in grrad : calling swrad' + + if (Model%swhtr) then + call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs + gasvmr, clouds, Tbd%icsdsw, faersw, & + sfcalb, Radtend%coszen, Model%solcon, & + nday, idxday, im, lmk, lmp, Model%lprnt,& + htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs + hsw0=htsw0, fdncmp=scmpsw) ! --- optional + else + call swrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, & ! --- inputs + gasvmr, clouds, Tbd%icsdsw, faersw, & + sfcalb, Radtend%coszen, Model%solcon, & + nday, idxday, IM, LMK, LMP, Model%lprnt,& + htswc, Diag%topfsw, Radtend%sfcfsw, & ! --- outputs + FDNCMP=scmpsw) ! --- optional + endif + + do k = 1, LM + k1 = k + kd + Radtend%htrsw(:,k) = htswc(:,k1) + enddo + ! --- repopulate the points above levr + if (Model%levr < Model%levs) then + do k = LM,Model%levs + Radtend%htrsw (:,k) = Radtend%htrsw (:,LM) + enddo + endif + + if (Model%swhtr) then + do k = 1, lm + k1 = k + kd + Radtend%swhc(:,k) = htsw0(:,k1) + enddo + ! --- repopulate the points above levr + if (Model%levr < Model%levs) then + do k = LM,Model%levs + Radtend%swhc(:,k) = Radtend%swhc(:,LM) + enddo + endif + endif + +! --- surface down and up spectral component fluxes +!> - Save two spectral bands' surface downward and upward fluxes for +!! output. + + Coupling%nirbmdi(:) = scmpsw(:)%nirbm + Coupling%nirdfdi(:) = scmpsw(:)%nirdf + Coupling%visbmdi(:) = scmpsw(:)%visbm + Coupling%visdfdi(:) = scmpsw(:)%visdf + + Coupling%nirbmui(:) = scmpsw(:)%nirbm * sfcalb(:,1) + Coupling%nirdfui(:) = scmpsw(:)%nirdf * sfcalb(:,2) + Coupling%visbmui(:) = scmpsw(:)%visbm * sfcalb(:,3) + Coupling%visdfui(:) = scmpsw(:)%visdf * sfcalb(:,4) + + else ! if_nday_block + + Radtend%htrsw(:,:) = 0.0 + + Radtend%sfcfsw = sfcfsw_type( 0.0, 0.0, 0.0, 0.0 ) + Diag%topfsw = topfsw_type( 0.0, 0.0, 0.0 ) + scmpsw = cmpfsw_type( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ) + + Coupling%nirbmdi(:) = 0.0 + Coupling%nirdfdi(:) = 0.0 + Coupling%visbmdi(:) = 0.0 + Coupling%visdfdi(:) = 0.0 + + Coupling%nirbmui(:) = 0.0 + Coupling%nirdfui(:) = 0.0 + Coupling%visbmui(:) = 0.0 + Coupling%visdfui(:) = 0.0 + + if (Model%swhtr) then + Radtend%swhc(:,:) = 0 + endif + + endif ! end_if_nday + +! --- radiation fluxes for other physics processes + Coupling%sfcnsw(:) = Radtend%sfcfsw(:)%dnfxc - Radtend%sfcfsw(:)%upfxc + Coupling%sfcdsw(:) = Radtend%sfcfsw(:)%dnfxc + + endif ! end_if_lsswr + +!> -# Start LW radiation calculations + if (Model%lslwr) then + +!> - Call module_radiation_surface::setemis(),to setup surface +!! emissivity for LW radiation. + + call setemis (Grid%xlon, Grid%xlat, Sfcprop%slmsk, & ! --- inputs + Sfcprop%snowd, Sfcprop%sncovr, Sfcprop%zorl, & + tsfg, tsfa, Sfcprop%hprim, IM, & + Radtend%semis) ! --- outputs + +!> - Call module_radlw_main::lwrad(), to compute LW heating rates and +!! fluxes. +! print *,' in grrad : calling lwrad' + + if (Model%lwhtr) then + call lwrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, & ! --- inputs + clouds, Tbd%icsdlw, faerlw, Radtend%semis, & + tsfg, im, lmk, lmp, Model%lprnt, & + htlwc, Diag%topflw, Radtend%sfcflw, & ! --- outputs + hlw0=htlw0) ! --- optional + else + call lwrad (plyr, plvl, tlyr, tlvl, qlyr, olyr, gasvmr, & ! --- inputs + clouds, Tbd%icsdlw, faerlw, Radtend%semis, & + tsfg, IM, LMK, LMP, Model%lprnt, & + htlwc, Diag%topflw, Radtend%sfcflw) ! --- outputs + endif + +!> -# Save calculation results +!> - Save surface air temp for diurnal adjustment at model t-steps + Radtend%tsflw (:) = tsfa(:) + + do k = 1, LM + k1 = k + kd + Radtend%htrlw(:,k) = htlwc(:,k1) + enddo + ! --- repopulate the points above levr + if (Model%levr < Model%levs) then + do k = LM,Model%levs + Radtend%htrlw (:,k) = Radtend%htrlw (:,LM) + enddo + endif + + if (Model%lwhtr) then + do k = 1, lm + k1 = k + kd + Radtend%lwhc(:,k) = htlw0(:,k1) + enddo + ! --- repopulate the points above levr + if (Model%levr < Model%levs) then + do k = LM,Model%levs + Radtend%lwhc(:,k) = Radtend%lwhc(:,LM) + enddo + endif + endif + +! --- radiation fluxes for other physics processes + Coupling%sfcdlw(:) = Radtend%sfcflw(:)%dnfxc + + endif ! end_if_lslwr + +!> - For time averaged output quantities (including total-sky and +!! clear-sky SW and LW fluxes at TOA and surface; conventional +!! 3-domain cloud amount, cloud top and base pressure, and cloud top +!! temperature; aerosols AOD, etc.), store computed results in +!! corresponding slots of array fluxr with appropriate time weights. + +! --- ... collect the fluxr data for wrtsfc + + if (Model%lssav) then + if (Model%lsswr) then + Diag%fluxr(:,34) = Diag%fluxr(:,34) + Model%fhswr*aerodp(:,1) ! total aod at 550nm + Diag%fluxr(:,35) = Diag%fluxr(:,35) + Model%fhswr*aerodp(:,2) ! DU aod at 550nm + Diag%fluxr(:,36) = Diag%fluxr(:,36) + Model%fhswr*aerodp(:,3) ! BC aod at 550nm + Diag%fluxr(:,37) = Diag%fluxr(:,37) + Model%fhswr*aerodp(:,4) ! OC aod at 550nm + Diag%fluxr(:,38) = Diag%fluxr(:,38) + Model%fhswr*aerodp(:,5) ! SU aod at 550nm + Diag%fluxr(:,39) = Diag%fluxr(:,39) + Model%fhswr*aerodp(:,6) ! SS aod at 550nm + endif + +! --- save lw toa and sfc fluxes + if (Model%lslwr) then +! --- lw total-sky fluxes + Diag%fluxr(:,1 ) = Diag%fluxr(:,1 ) + Model%fhlwr * Diag%topflw(:)%upfxc ! total sky top lw up + Diag%fluxr(:,19) = Diag%fluxr(:,19) + Model%fhlwr * Radtend%sfcflw(:)%dnfxc ! total sky sfc lw dn + Diag%fluxr(:,20) = Diag%fluxr(:,20) + Model%fhlwr * Radtend%sfcflw(:)%upfxc ! total sky sfc lw up +! --- lw clear-sky fluxes + Diag%fluxr(:,28) = Diag%fluxr(:,28) + Model%fhlwr * Diag%topflw(:)%upfx0 ! clear sky top lw up + Diag%fluxr(:,30) = Diag%fluxr(:,30) + Model%fhlwr * Radtend%sfcflw(:)%dnfx0 ! clear sky sfc lw dn + Diag%fluxr(:,33) = Diag%fluxr(:,33) + Model%fhlwr * Radtend%sfcflw(:)%upfx0 ! clear sky sfc lw up + endif + +! --- save sw toa and sfc fluxes with proper diurnal sw wgt. coszen=mean cosz over daylight +! part of sw calling interval, while coszdg= mean cosz over entire interval + if (Model%lsswr) then + do i = 1, IM + if (Radtend%coszen(i) > 0.) then +! --- sw total-sky fluxes +! ------------------- + tem0d = Model%fhswr * Radtend%coszdg(i) / Radtend%coszen(i) + Diag%fluxr(i,2 ) = Diag%fluxr(i,2) + Diag%topfsw(i)%upfxc * tem0d ! total sky top sw up + Diag%fluxr(i,3 ) = Diag%fluxr(i,3) + Radtend%sfcfsw(i)%upfxc * tem0d ! total sky sfc sw up + Diag%fluxr(i,4 ) = Diag%fluxr(i,4) + Radtend%sfcfsw(i)%dnfxc * tem0d ! total sky sfc sw dn +! --- sw uv-b fluxes +! -------------- + Diag%fluxr(i,21) = Diag%fluxr(i,21) + scmpsw(i)%uvbfc * tem0d ! total sky uv-b sw dn + Diag%fluxr(i,22) = Diag%fluxr(i,22) + scmpsw(i)%uvbf0 * tem0d ! clear sky uv-b sw dn +! --- sw toa incoming fluxes +! ---------------------- + Diag%fluxr(i,23) = Diag%fluxr(i,23) + Diag%topfsw(i)%dnfxc * tem0d ! top sw dn +! --- sw sfc flux components +! ---------------------- + Diag%fluxr(i,24) = Diag%fluxr(i,24) + scmpsw(i)%visbm * tem0d ! uv/vis beam sw dn + Diag%fluxr(i,25) = Diag%fluxr(i,25) + scmpsw(i)%visdf * tem0d ! uv/vis diff sw dn + Diag%fluxr(i,26) = Diag%fluxr(i,26) + scmpsw(i)%nirbm * tem0d ! nir beam sw dn + Diag%fluxr(i,27) = Diag%fluxr(i,27) + scmpsw(i)%nirdf * tem0d ! nir diff sw dn +! --- sw clear-sky fluxes +! ------------------- + Diag%fluxr(i,29) = Diag%fluxr(i,29) + Diag%topfsw(i)%upfx0 * tem0d ! clear sky top sw up + Diag%fluxr(i,31) = Diag%fluxr(i,31) + Radtend%sfcfsw(i)%upfx0 * tem0d ! clear sky sfc sw up + Diag%fluxr(i,32) = Diag%fluxr(i,32) + Radtend%sfcfsw(i)%dnfx0 * tem0d ! clear sky sfc sw dn + endif + enddo + endif + +! --- save total and boundary layer clouds + + if (Model%lsswr .or. Model%lslwr) then + Diag%fluxr(:,17) = Diag%fluxr(:,17) + raddt * cldsa(:,4) + Diag%fluxr(:,18) = Diag%fluxr(:,18) + raddt * cldsa(:,5) + + do k = 1, nkld + Diag%cloud(:,:,k) = Diag%cloud(:,:,k) + raddt * clouds(:,:,k+1) + enddo + +! --- save cld frac,toplyr,botlyr and top temp, note that the order +! of h,m,l cloud is reversed for the fluxr output. +! --- save interface pressure (pa) of top/bot + + do j = 1, 3 + do i = 1, IM + tem0d = raddt * cldsa(i,j) + itop = mtopa(i,j) - kd + ibtc = mbota(i,j) - kd + Diag%fluxr(i, 8-j) = Diag%fluxr(i, 8-j) + tem0d + Diag%fluxr(i,11-j) = Diag%fluxr(i,11-j) + tem0d * Statein%prsi(i,itop+kt) + Diag%fluxr(i,14-j) = Diag%fluxr(i,14-j) + tem0d * Statein%prsi(i,ibtc+kb) + Diag%fluxr(i,17-j) = Diag%fluxr(i,17-j) + tem0d * Statein%tgrs(i,itop) + enddo + enddo + endif + + endif ! end_if_lssav +! + return +!........................................ + end subroutine GFS_radiation_driver +!---------------------------------------- + + +! +!> @} +!........................................! + end module module_radiation_driver ! +!========================================! +!> @} +!>@} diff --git a/GFS_layer/GFS_restart.F90 b/GFS_layer/GFS_restart.F90 new file mode 100644 index 00000000..14ff47d1 --- /dev/null +++ b/GFS_layer/GFS_restart.F90 @@ -0,0 +1,184 @@ +module physics_restart_layer + + use machine, only: kind_phys + use IPD_typedefs, only: IPD_restart_type + use physics_abstraction_layer, only: control_type, statein_type, & + stateout_type, sfcprop_type, & + coupling_type, grid_type, & + tbd_type, cldprop_type, & + radtend_type, intdiag_type, & + init_type + + public restart_populate + + CONTAINS +!******************************************************************************************* + +!--------------------- +! GFS_restart_populate +!--------------------- + subroutine restart_populate (IPD_Restart, Model, Statein, Stateout, Sfcprop, & + Coupling, Grid, Tbd, Cldprop, Radtend, Diag, Init_parm) +!----------------------------------------------------------------------------------------! +! IPD_METADATA ! +! IPD_Restart%num2d [int*4 ] number of 2D variables to output ! +! IPD_Restart%num3d [int*4 ] number of 3D variables to output ! +! IPD_Restart%name2d [char=32] variable name in restart file ! +! IPD_Restart%name3d [char=32] variable name in restart file ! +! IPD_Restart%fld2d(:,:,:) [real*8 ] pointer to 2D data (im,nblks,MAX_RSTRT) ! +! IPD_Restart%fld3d(:,:,:,:) [real*8 ] pointer to 3D data (im,levs,nblks,MAX_RSTRT) ! +!----------------------------------------------------------------------------------------! + type(IPD_restart_type), intent(inout) :: IPD_Restart + type(control_type), intent(in) :: Model + type(statein_type), intent(in) :: Statein(:) + type(stateout_type), intent(in) :: Stateout(:) + type(sfcprop_type), intent(in) :: Sfcprop(:) + type(coupling_type), intent(in) :: Coupling(:) + type(grid_type), intent(in) :: Grid(:) + type(tbd_type), intent(in) :: Tbd(:) + type(cldprop_type), intent(in) :: Cldprop(:) + type(radtend_type), intent(in) :: Radtend(:) + type(intdiag_type), intent(in) :: Diag(:) + type(init_type), intent(in) :: Init_parm + + !--- local variables + integer :: nblks, num, nb, max_rstrt, offset + character(len=2) :: c2 = '' + + nblks = size(Init_parm%blksz) + max_rstrt = size(IPD_Restart%name2d) + + !TODO lmh 14 jan 2020 + ! The MLO variables should really be saved in sfc_restart + ! and not phy_restart. + IPD_Restart%num2d = 5 + 10 + Model%ntot2d + Model%nctp + IPD_Restart%num3d = Model%ntot3d + + allocate (IPD_Restart%name2d(IPD_Restart%num2d)) + allocate (IPD_Restart%name3d(IPD_Restart%num3d)) + allocate (IPD_Restart%data(nblks,max(IPD_Restart%num2d,IPD_Restart%num3d))) + + IPD_Restart%name2d(:) = ' ' + IPD_Restart%name3d(:) = ' ' + + !--- Cldprop variables + IPD_Restart%name2d(1) = 'cv' + IPD_Restart%name2d(2) = 'cvt' + IPD_Restart%name2d(3) = 'cvb' + do nb = 1,nblks + IPD_Restart%data(nb,1)%var2p => Cldprop(nb)%cv(:) + IPD_Restart%data(nb,2)%var2p => Cldprop(nb)%cvt(:) + IPD_Restart%data(nb,3)%var2p => Cldprop(nb)%cvb(:) + enddo + + !--- Mixed-layer ocean variables + offset = 3 + IPD_Restart%name2d(1+offset) = 'ts_som' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%ts_som(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'tsclim' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%tsclim(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'mldclim' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%mldclim(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'ts_clim_iano' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%ts_clim_iano(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'tml' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%tml(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'tml0' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%tml0(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'mld' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%mld(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'mld0' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%mld0(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'huml' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%huml(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'hvml' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%hvml(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'tmoml' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%tmoml(:) + enddo + + offset = offset + 1 + IPD_Restart%name2d(1+offset) = 'tmoml0' + do nb = 1,nblks + IPD_Restart%data(nb,1+offset)%var2p => Sfcprop(nb)%tmoml0(:) + enddo + + !TODO lmh 14 jan 2020 + ! Most of the phy_restart variables are redundant with the + ! tracers saved in the dynamics, and are not needed. + !--- phy_f2d variables + offset = offset + 1 + do num = 1,Model%ntot2d + !--- set the variable name + write(c2,'(i2.2)') num + IPD_Restart%name2d(num+offset) = 'phy_f2d_'//c2 + do nb = 1,nblks + IPD_Restart%data(nb,num+offset)%var2p => Tbd(nb)%phy_f2d(:,num) + enddo + enddo + + !--- phy_fctd variables + offset = offset + Model%ntot2d + do num = 1, Model%nctp + !--- set the variable name + write(c2,'(i2.2)') num + IPD_Restart%name2d(num+offset) = 'phy_fctd_'//c2 + do nb = 1,nblks + IPD_Restart%data(nb,num+offset)%var2p => Tbd(nb)%phy_fctd(:,num) + enddo + enddo + + !--- phy_f3d variables + do num = 1,Model%ntot3d + !--- set the variable name + write(c2,'(i2.2)') num + IPD_Restart%name3d(num) = 'phy_f3d_'//c2 + do nb = 1,nblks + IPD_Restart%data(nb,num)%var3p => Tbd(nb)%phy_f3d(:,:,num) + enddo + enddo + + end subroutine restart_populate + +end module physics_restart_layer diff --git a/GFS_layer/GFS_typedefs.F90 b/GFS_layer/GFS_typedefs.F90 new file mode 100644 index 00000000..1f6c4a57 --- /dev/null +++ b/GFS_layer/GFS_typedefs.F90 @@ -0,0 +1,3748 @@ +module GFS_typedefs + + use machine, only: kind_phys, kind_evod + use module_radsw_parameters, only: topfsw_type, sfcfsw_type + use module_radlw_parameters, only: topflw_type, sfcflw_type + use ozne_def, only: levozp, oz_coeff + use h2o_def, only: levh2o, h2o_coeff + use gfdl_cld_mp_mod, only: rhow + implicit none + + !--- version of physics + character(len=64) :: version = 'v2017 OPERATIONAL GFS PHYSICS' + + !--- parameter constants used for default initializations + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: huge = 9.9999D15 + real(kind=kind_phys), parameter :: clear_val = zero + !real(kind=kind_phys), parameter :: clear_val = -9.9999e80 + real(kind=kind_phys), parameter :: rann_init = 0.6_kind_phys + real(kind=kind_phys), parameter :: cn_one = 1._kind_phys + real(kind=kind_phys), parameter :: cn_100 = 100._kind_phys + real(kind=kind_phys), parameter :: cn_th = 1000._kind_phys + real(kind=kind_phys), parameter :: cn_hr = 3600._kind_phys + +!---------------- +! Data Containers +!---------------- +! !--- GFS external initialization type +! GFS_init_type +! !--- GFS Derived Data Types (DDTs) +! GFS_statein_type !< prognostic state data in from dycore +! GFS_stateout_type !< prognostic state or tendencies return to dycore +! GFS_sfcprop_type !< surface fields +! GFS_coupling_type !< fields to/from coupling with other components (e.g. land/ice/ocean/etc.) +! !---GFS specific containers +! GFS_control_type !< model control parameters +! GFS_grid_type !< grid and interpolation related data +! GFS_tbd_type !< to be determined data that doesn't fit in any one container +! GFS_clprop_type !< cloud fields needed by radiation from physics +! GFS_radtend_type !< radiation tendencies needed in physics +! GFS_diag_type !< fields targetted for diagnostic output + +!-------------------------------------------------------------------------------- +! GFS_init_type +!-------------------------------------------------------------------------------- +! This container is the minimum set of data required from the dycore/atmosphere +! component to allow proper initialization of the GFS physics +!-------------------------------------------------------------------------------- + type GFS_init_type + integer :: me !< my MPI-rank + integer :: master !< master MPI-rank + integer :: tile_num !< tile number for this MPI rank + integer :: isc !< starting i-index for this MPI-domain + integer :: jsc !< starting j-index for this MPI-domain + integer :: nx !< number of points in i-dir for this MPI rank + integer :: ny !< number of points in j-dir for this MPI rank + integer :: levs !< number of vertical levels + integer :: cnx !< number of points in i-dir for this cubed-sphere face + !< equal to gnx for lat-lon grids + integer :: cny !< number of points in j-dir for this cubed-sphere face + !< equal to gny for lat-lon grids + integer :: gnx !< number of global points in x-dir (i) along the equator + integer :: gny !< number of global points in y-dir (j) along any meridian + integer :: nlunit !< fortran unit number for file opens + integer :: logunit !< fortran unit number for writing logfile + integer :: bdat(8) !< model begin date in GFS format (same as idat) + integer :: cdat(8) !< model current date in GFS format (same as jdat) + integer :: iau_offset !< iau running window length + real(kind=kind_phys) :: dt_dycore !< dynamics time step in seconds + real(kind=kind_phys) :: dt_phys !< physics time step in seconds + !--- blocking data + integer, pointer :: blksz(:) !< for explicit data blocking + !< default blksz(1)=[nx*ny] + !--- ak/bk for pressure level calculations + real(kind=kind_phys), pointer :: ak(:) !< from surface (k=1) to TOA (k=levs) + real(kind=kind_phys), pointer :: bk(:) !< from surface (k=1) to TOA (k=levs) + !--- grid metrics + real(kind=kind_phys), pointer :: xlon(:,:) !< column longitude for MPI rank + real(kind=kind_phys), pointer :: xlat(:,:) !< column latitude for MPI rank + real(kind=kind_phys), pointer :: area(:,:) !< column area for length scale calculations + + character(len=32), pointer :: tracer_names(:) !< tracers names to dereference tracer id + !< based on name location in array + character(len=65) :: fn_nml !< namelist filename + character(len=:), pointer, dimension(:) :: input_nml_file => null() !< character string containing full namelist + !< for use with internal file reads + end type GFS_init_type + + +!---------------------------------------------------------------- +! GFS_statein_type +! prognostic state variables with layer and level specific data +!---------------------------------------------------------------- + type GFS_statein_type + + !--- level geopotential and pressures + real (kind=kind_phys), pointer :: phii (:,:) => null() !< interface geopotential height + real (kind=kind_phys), pointer :: prsi (:,:) => null() !< model level pressure in Pa + real (kind=kind_phys), pointer :: prsik (:,:) => null() !< Exner function at interface + + !--- layer geopotential and pressures + real (kind=kind_phys), pointer :: phil (:,:) => null() !< layer geopotential height + real (kind=kind_phys), pointer :: prsl (:,:) => null() !< model layer mean pressure Pa + real (kind=kind_phys), pointer :: prslk (:,:) => null() !< exner function = (p/p0)**rocp + + !--- prognostic variables + real (kind=kind_phys), pointer :: pgr (:) => null() !< surface pressure (Pa) real + real (kind=kind_phys), pointer :: ugrs (:,:) => null() !< u component of layer wind + real (kind=kind_phys), pointer :: vgrs (:,:) => null() !< v component of layer wind + real (kind=kind_phys), pointer :: vvl (:,:) => null() !< layer mean vertical velocity in pa/sec + real (kind=kind_phys), pointer :: tgrs (:,:) => null() !< model layer mean temperature in k + real (kind=kind_phys), pointer :: qgrs (:,:,:) => null() !< layer mean tracer concentration +! dissipation estimate + real (kind=kind_phys), pointer :: diss_est(:,:) => null() !< model layer mean temperature in k +! soil state variables - for soil SPPT - sfc-perts, mgehne + real (kind=kind_phys), pointer :: smc (:,:) => null() !< soil moisture content + real (kind=kind_phys), pointer :: stc (:,:) => null() !< soil temperature content + real (kind=kind_phys), pointer :: slc (:,:) => null() !< soil liquid water content + + real (kind=kind_phys), pointer :: exch_h (:,:) => null() !< 3D heat exchange coefficient + + !--- precipitation + real (kind=kind_phys), pointer :: prer (:) => null() !< rain + real (kind=kind_phys), pointer :: prei (:) => null() !< ice + real (kind=kind_phys), pointer :: pres (:) => null() !< snow + real (kind=kind_phys), pointer :: preg (:) => null() !< graupel + + !--- sea surface temperature + real (kind=kind_phys), pointer :: sst (:) => null() !< sea surface temperature + real (kind=kind_phys), pointer :: ci (:) => null() !< sea ice fraction + logical, pointer :: dycore_hydrostatic => null() !< whether the dynamical core is hydrostatic + integer, pointer :: nwat => null() !< number of water species used in the model + contains + procedure :: create => statein_create !< allocate array data + + end type GFS_statein_type + + +!------------------------------------------------------------------ +! GFS_stateout_type +! prognostic state or tendencies after physical parameterizations +!------------------------------------------------------------------ + type GFS_stateout_type + + !-- Out (physics only) + real (kind=kind_phys), pointer :: gu0 (:,:) => null() !< updated zonal wind + real (kind=kind_phys), pointer :: gv0 (:,:) => null() !< updated meridional wind + real (kind=kind_phys), pointer :: gt0 (:,:) => null() !< updated temperature + real (kind=kind_phys), pointer :: gq0 (:,:,:) => null() !< updated tracers + + contains + procedure :: create => stateout_create !< allocate array data + end type GFS_stateout_type + + +!--------------------------------------------------------------------------------------- +! GFS_sfcprop_type +! surface properties that may be read in and/or updated by climatology or observations +!--------------------------------------------------------------------------------------- + type GFS_sfcprop_type + + !--- In (radiation and physics) + real (kind=kind_phys), pointer :: slmsk (:) => null() !< sea/land mask array (sea:0,land:1,sea-ice:2) + real (kind=kind_phys), pointer :: oceanfrac(:) => null() !< ocean fraction [0:1] + real (kind=kind_phys), pointer :: landfrac(:) => null() !< land fraction [0:1] + real (kind=kind_phys), pointer :: lakefrac(:) => null() !< lake fraction [0:1] + real (kind=kind_phys), pointer :: tsfc (:) => null() !< surface temperature in k + !< [tsea in gbphys.f] + real (kind=kind_phys), pointer :: tsfco (:) => null() !< sst in K + real (kind=kind_phys), pointer :: tsfcl (:) => null() !< surface temperature over ice fraction + real (kind=kind_phys), pointer :: qsfc (:) => null() !< surface specific humidity in kg/kg +! + real (kind=kind_phys), pointer :: tsclim (:) => null() !< climatological SST in k + real (kind=kind_phys), pointer :: mldclim (:) => null() !< climatological ocean mixed layer depth in m + real (kind=kind_phys), pointer :: qfluxadj (:) => null() !< climatological qflux used for SOM + real (kind=kind_phys), pointer :: ts_som (:) => null() !< predicted SST in SOM or MLM + real (kind=kind_phys), pointer :: ts_clim_iano (:) => null() !< climatological SST plus initial anomaly with decay + + real (kind=kind_phys), pointer :: tml (:) => null() !< ocean mixed layer temp + real (kind=kind_phys), pointer :: tml0 (:) => null() !< ocean mixed layer temp at initial or previous time step + real (kind=kind_phys), pointer :: mld (:) => null() !< ocean mixed layer depth (MLD) + real (kind=kind_phys), pointer :: mld0 (:) => null() !< MLD at initial or previous time step + real (kind=kind_phys), pointer :: huml (:) => null() !< ocean zonal current * MLD + real (kind=kind_phys), pointer :: hvml (:) => null() !< ocean meridional current *MLD + real (kind=kind_phys), pointer :: tmoml (:) => null() !< ocean temp at the above 200 m + real (kind=kind_phys), pointer :: tmoml0 (:) => null() !< ocean temp at the above 200 m at initial or previous time step +! + real (kind=kind_phys), pointer :: tisfc (:) => null() !< surface temperature over ice fraction + real (kind=kind_phys), pointer :: snowd (:) => null() !< snow depth water equivalent in mm ; same as snwdph + real (kind=kind_phys), pointer :: zorl (:) => null() !< composite surface roughness in cm + real (kind=kind_phys), pointer :: zorlo (:) => null() !< ocean surface roughness in cm + real (kind=kind_phys), pointer :: zorll (:) => null() !< land surface roughness in cm + real (kind=kind_phys), pointer :: ztrl (:) => null() !< surface roughness for t and q in cm + real (kind=kind_phys), pointer :: fice (:) => null() !< ice fraction over open water grid + real (kind=kind_phys), pointer :: hprim (:) => null() !< topographic standard deviation in m ! + real (kind=kind_phys), pointer :: hprime (:,:) => null() !< orographic metrics + + !--- In (radiation only) + real (kind=kind_phys), pointer :: sncovr (:) => null() !< snow cover in fraction + real (kind=kind_phys), pointer :: snoalb (:) => null() !< maximum snow albedo in fraction + real (kind=kind_phys), pointer :: alvsf (:) => null() !< mean vis albedo with strong cosz dependency + real (kind=kind_phys), pointer :: alnsf (:) => null() !< mean nir albedo with strong cosz dependency + real (kind=kind_phys), pointer :: alvwf (:) => null() !< mean vis albedo with weak cosz dependency + real (kind=kind_phys), pointer :: alnwf (:) => null() !< mean nir albedo with weak cosz dependency + real (kind=kind_phys), pointer :: facsf (:) => null() !< fractional coverage with strong cosz dependency + real (kind=kind_phys), pointer :: facwf (:) => null() !< fractional coverage with weak cosz dependency + + !--- In (physics only) + real (kind=kind_phys), pointer :: slope (:) => null() !< sfc slope type for lsm + real (kind=kind_phys), pointer :: shdmin (:) => null() !< min fractional coverage of green veg + real (kind=kind_phys), pointer :: shdmax (:) => null() !< max fractnl cover of green veg (not used) + real (kind=kind_phys), pointer :: tg3 (:) => null() !< deep soil temperature + real (kind=kind_phys), pointer :: vfrac (:) => null() !< vegetation fraction + real (kind=kind_phys), pointer :: vtype (:) => null() !< vegetation type + real (kind=kind_phys), pointer :: stype (:) => null() !< soil type + real (kind=kind_phys), pointer :: uustar (:) => null() !< boundary layer parameter + real (kind=kind_phys), pointer :: oro (:) => null() !< orography + real (kind=kind_phys), pointer :: oro_uf (:) => null() !< unfiltered orography + + !--- IN/out MYJ scheme + real (kind=kind_phys), pointer :: QZ0 (:) => null() !< vapor mixing ratio at z=z0 + real (kind=kind_phys), pointer :: THZ0 (:) => null() !< Potential temperature at z=z0 + real (kind=kind_phys), pointer :: UZ0 (:) => null() !< zonal wind at z=z0 + real (kind=kind_phys), pointer :: VZ0 (:) => null() !< meridional wind at z=z0 + + !-- In/Out + real (kind=kind_phys), pointer :: hice (:) => null() !< sea ice thickness + real (kind=kind_phys), pointer :: weasd (:) => null() !< water equiv of accumulated snow depth (kg/m**2) + !< over land and sea ice + real (kind=kind_phys), pointer :: canopy (:) => null() !< canopy water + real (kind=kind_phys), pointer :: ffmm (:) => null() !< fm parameter from PBL scheme + real (kind=kind_phys), pointer :: ffhh (:) => null() !< fh parameter from PBL scheme + real (kind=kind_phys), pointer :: f10m (:) => null() !< fm at 10m - Ratio of sigma level 1 wind and 10m wind + real (kind=kind_phys), pointer :: tprcp (:) => null() !< sfc_fld%tprcp - total precipitation + real (kind=kind_phys), pointer :: srflag (:) => null() !< sfc_fld%srflag - snow/rain flag for precipitation + real (kind=kind_phys), pointer :: slc (:,:) => null() !< liquid soil moisture + real (kind=kind_phys), pointer :: smc (:,:) => null() !< total soil moisture + real (kind=kind_phys), pointer :: stc (:,:) => null() !< soil temperature + + !--- Out + real (kind=kind_phys), pointer :: t2m (:) => null() !< 2 meter temperature + real (kind=kind_phys), pointer :: q2m (:) => null() !< 2 meter humidity + + +! -- In/Out for Noah MP + real (kind=kind_phys), pointer :: snowxy (:) => null() !< + real (kind=kind_phys), pointer :: tvxy (:) => null() !< veg temp + real (kind=kind_phys), pointer :: tgxy (:) => null() !< ground temp + real (kind=kind_phys), pointer :: canicexy(:) => null() !< + real (kind=kind_phys), pointer :: canliqxy(:) => null() !< + real (kind=kind_phys), pointer :: eahxy (:) => null() !< + real (kind=kind_phys), pointer :: tahxy (:) => null() !< + real (kind=kind_phys), pointer :: cmxy (:) => null() !< + real (kind=kind_phys), pointer :: chxy (:) => null() !< + real (kind=kind_phys), pointer :: fwetxy (:) => null() !< + real (kind=kind_phys), pointer :: sneqvoxy(:) => null() !< + real (kind=kind_phys), pointer :: alboldxy(:) => null() !< + real (kind=kind_phys), pointer :: qsnowxy (:) => null() !< + real (kind=kind_phys), pointer :: wslakexy(:) => null() !< + real (kind=kind_phys), pointer :: zwtxy (:) => null() !< + real (kind=kind_phys), pointer :: waxy (:) => null() !< + real (kind=kind_phys), pointer :: wtxy (:) => null() !< + real (kind=kind_phys), pointer :: lfmassxy(:) => null() !< + real (kind=kind_phys), pointer :: rtmassxy(:) => null() !< + real (kind=kind_phys), pointer :: stmassxy(:) => null() !< + real (kind=kind_phys), pointer :: woodxy (:) => null() !< + real (kind=kind_phys), pointer :: stblcpxy(:) => null() !< + real (kind=kind_phys), pointer :: fastcpxy(:) => null() !< + real (kind=kind_phys), pointer :: xsaixy (:) => null() !< + real (kind=kind_phys), pointer :: xlaixy (:) => null() !< + real (kind=kind_phys), pointer :: taussxy (:) => null() !< + real (kind=kind_phys), pointer :: smcwtdxy(:) => null() !< + real (kind=kind_phys), pointer :: deeprechxy(:)=> null() !< + real (kind=kind_phys), pointer :: rechxy (:) => null() !< + real (kind=kind_phys), pointer :: albdvis (:) => null() !< + real (kind=kind_phys), pointer :: albdnir (:) => null() !< + real (kind=kind_phys), pointer :: albivis (:) => null() !< + real (kind=kind_phys), pointer :: albinir (:) => null() !< + real (kind=kind_phys), pointer :: emiss (:) => null() !< + + real (kind=kind_phys), pointer :: snicexy (:,:) => null() !< + real (kind=kind_phys), pointer :: snliqxy (:,:) => null() !< + real (kind=kind_phys), pointer :: tsnoxy (:,:) => null() !< + real (kind=kind_phys), pointer :: smoiseq (:,:) => null() !< + real (kind=kind_phys), pointer :: zsnsoxy (:,:) => null() !< + + + !--- NSSTM variables (only allocated when [Model%nstf_name(1) > 0]) + real (kind=kind_phys), pointer :: tref (:) => null() !< nst_fld%Tref - Reference Temperature + real (kind=kind_phys), pointer :: z_c (:) => null() !< nst_fld%z_c - Sub layer cooling thickness + real (kind=kind_phys), pointer :: c_0 (:) => null() !< nst_fld%c_0 - coefficient1 to calculate d(Tz)/d(Ts) + real (kind=kind_phys), pointer :: c_d (:) => null() !< nst_fld%c_d - coefficient2 to calculate d(Tz)/d(Ts) + real (kind=kind_phys), pointer :: w_0 (:) => null() !< nst_fld%w_0 - coefficient3 to calculate d(Tz)/d(Ts) + real (kind=kind_phys), pointer :: w_d (:) => null() !< nst_fld%w_d - coefficient4 to calculate d(Tz)/d(Ts) + real (kind=kind_phys), pointer :: xt (:) => null() !< nst_fld%xt heat content in DTL + real (kind=kind_phys), pointer :: xs (:) => null() !< nst_fld%xs salinity content in DTL + real (kind=kind_phys), pointer :: xu (:) => null() !< nst_fld%xu u current content in DTL + real (kind=kind_phys), pointer :: xv (:) => null() !< nst_fld%xv v current content in DTL + real (kind=kind_phys), pointer :: xz (:) => null() !< nst_fld%xz DTL thickness + real (kind=kind_phys), pointer :: zm (:) => null() !< nst_fld%zm MXL thickness + real (kind=kind_phys), pointer :: xtts (:) => null() !< nst_fld%xtts d(xt)/d(ts) + real (kind=kind_phys), pointer :: xzts (:) => null() !< nst_fld%xzts d(xz)/d(ts) + real (kind=kind_phys), pointer :: d_conv (:) => null() !< nst_fld%d_conv thickness of Free Convection Layer (FCL) + real (kind=kind_phys), pointer :: ifd (:) => null() !< nst_fld%ifd index to start DTM run or not + real (kind=kind_phys), pointer :: dt_cool(:) => null() !< nst_fld%dt_cool Sub layer cooling amount + real (kind=kind_phys), pointer :: qrain (:) => null() !< nst_fld%qrain sensible heat flux due to rainfall (watts) + + !---- precipitation rates from previous time step for NoahMP LSM + real (kind=kind_phys), pointer :: draincprv (:) => null() !< convective precipitation rate from previous timestep + real (kind=kind_phys), pointer :: drainncprv (:) => null() !< explicit rainfall rate from previous timestep + real (kind=kind_phys), pointer :: diceprv (:) => null() !< ice precipitation rate from previous timestep + real (kind=kind_phys), pointer :: dsnowprv (:) => null() !< snow precipitation rate from previous timestep + real (kind=kind_phys), pointer :: dgraupelprv(:) => null() !< graupel precipitation rate from previous timestep + + + contains + procedure :: create => sfcprop_create !< allocate array data + end type GFS_sfcprop_type + + +!--------------------------------------------------------------------- +! GFS_coupling_type +! fields to/from other coupled components (e.g. land/ice/ocean/etc.) +!--------------------------------------------------------------------- + type GFS_coupling_type + + !--- Out (radiation only) + real (kind=kind_phys), pointer :: nirbmdi(:) => null() !< sfc nir beam sw downward flux (w/m2) + real (kind=kind_phys), pointer :: nirdfdi(:) => null() !< sfc nir diff sw downward flux (w/m2) + real (kind=kind_phys), pointer :: visbmdi(:) => null() !< sfc uv+vis beam sw downward flux (w/m2) + real (kind=kind_phys), pointer :: visdfdi(:) => null() !< sfc uv+vis diff sw downward flux (w/m2) + real (kind=kind_phys), pointer :: nirbmui(:) => null() !< sfc nir beam sw upward flux (w/m2) + real (kind=kind_phys), pointer :: nirdfui(:) => null() !< sfc nir diff sw upward flux (w/m2) + real (kind=kind_phys), pointer :: visbmui(:) => null() !< sfc uv+vis beam sw upward flux (w/m2) + real (kind=kind_phys), pointer :: visdfui(:) => null() !< sfc uv+vis diff sw upward flux (w/m2) + + !--- In (physics only) + real (kind=kind_phys), pointer :: sfcdsw(:) => null() !< total sky sfc downward sw flux ( w/m**2 ) + !< GFS_radtend_type%sfcfsw%dnfxc + real (kind=kind_phys), pointer :: sfcnsw(:) => null() !< total sky sfc netsw flx into ground(w/m**2) + !< difference of dnfxc & upfxc from GFS_radtend_type%sfcfsw + real (kind=kind_phys), pointer :: sfcdlw(:) => null() !< total sky sfc downward lw flux ( w/m**2 ) + !< GFS_radtend_type%sfclsw%dnfxc + + !--- incoming quantities + real (kind=kind_phys), pointer :: dusfcin_cpl(:) => null() !< aoi_fld%dusfcin(item,lan) + real (kind=kind_phys), pointer :: dvsfcin_cpl(:) => null() !< aoi_fld%dvsfcin(item,lan) + real (kind=kind_phys), pointer :: dtsfcin_cpl(:) => null() !< aoi_fld%dtsfcin(item,lan) + real (kind=kind_phys), pointer :: dqsfcin_cpl(:) => null() !< aoi_fld%dqsfcin(item,lan) + real (kind=kind_phys), pointer :: ulwsfcin_cpl(:)=> null() !< aoi_fld%ulwsfcin(item,lan) + !--- only variable needed for cplwav=.TRUE. + real (kind=kind_phys), pointer :: slimskin_cpl(:)=> null() !< aoi_fld%slimskin(item,lan) + + !--- outgoing accumulated quantities + real (kind=kind_phys), pointer :: rain_cpl (:) => null() !< total rain precipitation + real (kind=kind_phys), pointer :: snow_cpl (:) => null() !< total snow precipitation + real (kind=kind_phys), pointer :: dusfc_cpl (:) => null() !< sfc u momentum flux + real (kind=kind_phys), pointer :: dvsfc_cpl (:) => null() !< sfc v momentum flux + real (kind=kind_phys), pointer :: dtsfc_cpl (:) => null() !< sfc sensible heat flux + real (kind=kind_phys), pointer :: dqsfc_cpl (:) => null() !< sfc latent heat flux + real (kind=kind_phys), pointer :: dlwsfc_cpl(:) => null() !< sfc downward lw flux (w/m**2) + real (kind=kind_phys), pointer :: dswsfc_cpl(:) => null() !< sfc downward sw flux (w/m**2) + real (kind=kind_phys), pointer :: dnirbm_cpl(:) => null() !< sfc nir beam downward sw flux (w/m**2) + real (kind=kind_phys), pointer :: dnirdf_cpl(:) => null() !< sfc nir diff downward sw flux (w/m**2) + real (kind=kind_phys), pointer :: dvisbm_cpl(:) => null() !< sfc uv+vis beam dnwd sw flux (w/m**2) + real (kind=kind_phys), pointer :: dvisdf_cpl(:) => null() !< sfc uv+vis diff dnwd sw flux (w/m**2) + real (kind=kind_phys), pointer :: nlwsfc_cpl(:) => null() !< net downward lw flux (w/m**2) + real (kind=kind_phys), pointer :: nswsfc_cpl(:) => null() !< net downward sw flux (w/m**2) + real (kind=kind_phys), pointer :: nnirbm_cpl(:) => null() !< net nir beam downward sw flux (w/m**2) + real (kind=kind_phys), pointer :: nnirdf_cpl(:) => null() !< net nir diff downward sw flux (w/m**2) + real (kind=kind_phys), pointer :: nvisbm_cpl(:) => null() !< net uv+vis beam downward sw rad flux (w/m**2) + real (kind=kind_phys), pointer :: nvisdf_cpl(:) => null() !< net uv+vis diff downward sw rad flux (w/m**2) + + !--- outgoing instantaneous quantities + real (kind=kind_phys), pointer :: dusfci_cpl (:) => null() !< instantaneous sfc u momentum flux + real (kind=kind_phys), pointer :: dvsfci_cpl (:) => null() !< instantaneous sfc v momentum flux + real (kind=kind_phys), pointer :: dtsfci_cpl (:) => null() !< instantaneous sfc sensible heat flux + real (kind=kind_phys), pointer :: dqsfci_cpl (:) => null() !< instantaneous sfc latent heat flux + real (kind=kind_phys), pointer :: dlwsfci_cpl(:) => null() !< instantaneous sfc downward lw flux + real (kind=kind_phys), pointer :: dswsfci_cpl(:) => null() !< instantaneous sfc downward sw flux + real (kind=kind_phys), pointer :: dnirbmi_cpl(:) => null() !< instantaneous sfc nir beam downward sw flux + real (kind=kind_phys), pointer :: dnirdfi_cpl(:) => null() !< instantaneous sfc nir diff downward sw flux + real (kind=kind_phys), pointer :: dvisbmi_cpl(:) => null() !< instantaneous sfc uv+vis beam downward sw flux + real (kind=kind_phys), pointer :: dvisdfi_cpl(:) => null() !< instantaneous sfc uv+vis diff downward sw flux + real (kind=kind_phys), pointer :: nlwsfci_cpl(:) => null() !< instantaneous net sfc downward lw flux + real (kind=kind_phys), pointer :: nswsfci_cpl(:) => null() !< instantaneous net sfc downward sw flux + real (kind=kind_phys), pointer :: nnirbmi_cpl(:) => null() !< instantaneous net nir beam sfc downward sw flux + real (kind=kind_phys), pointer :: nnirdfi_cpl(:) => null() !< instantaneous net nir diff sfc downward sw flux + real (kind=kind_phys), pointer :: nvisbmi_cpl(:) => null() !< instantaneous net uv+vis beam downward sw flux + real (kind=kind_phys), pointer :: nvisdfi_cpl(:) => null() !< instantaneous net uv+vis diff downward sw flux + real (kind=kind_phys), pointer :: t2mi_cpl (:) => null() !< instantaneous T2m + real (kind=kind_phys), pointer :: q2mi_cpl (:) => null() !< instantaneous Q2m + real (kind=kind_phys), pointer :: u10mi_cpl (:) => null() !< instantaneous U10m + real (kind=kind_phys), pointer :: v10mi_cpl (:) => null() !< instantaneous V10m + real (kind=kind_phys), pointer :: tsfci_cpl (:) => null() !< instantaneous sfc temperature + real (kind=kind_phys), pointer :: psurfi_cpl (:) => null() !< instantaneous sfc pressure + + !--- topography-based information for the coupling system + real (kind=kind_phys), pointer :: oro_cpl (:) => null() !< orography ( oro from GFS_sfcprop_type) + real (kind=kind_phys), pointer :: slmsk_cpl (:) => null() !< Land/Sea/Ice mask (slmsk from GFS_sfcprop_type) + + !--- cellular automata + real (kind=kind_phys), pointer :: tconvtend(:,:) => null() + real (kind=kind_phys), pointer :: qconvtend(:,:) => null() + real (kind=kind_phys), pointer :: uconvtend(:,:) => null() + real (kind=kind_phys), pointer :: vconvtend(:,:) => null() + real (kind=kind_phys), pointer :: ca_out (:) => null() ! + real (kind=kind_phys), pointer :: ca_deep (:) => null() ! + real (kind=kind_phys), pointer :: ca_turb (:) => null() ! + real (kind=kind_phys), pointer :: ca_shal (:) => null() ! + real (kind=kind_phys), pointer :: ca_rad (:) => null() ! + real (kind=kind_phys), pointer :: ca_micro (:) => null() ! + real (kind=kind_phys), pointer :: cape (:) => null() ! + + !--- stochastic physics + real (kind=kind_phys), pointer :: shum_wts (:,:) => null() ! + real (kind=kind_phys), pointer :: sppt_wts (:,:) => null() ! + real (kind=kind_phys), pointer :: skebu_wts (:,:) => null() ! + real (kind=kind_phys), pointer :: skebv_wts (:,:) => null() ! + real (kind=kind_phys), pointer :: sfc_wts (:,:) => null() ! mg, sfc-perts + integer :: nsfcpert=6 !< number of sfc perturbations + + !--- instantaneous quantities for GoCart and will be accumulated for 3D diagnostics + real (kind=kind_phys), pointer :: dqdti (:,:) => null() !< instantaneous total moisture tendency (kg/kg/s) + real (kind=kind_phys), pointer :: cnvqci (:,:) => null() !< instantaneous total convective conensate (kg/kg) + real (kind=kind_phys), pointer :: upd_mfi (:,:) => null() !< instantaneous convective updraft mass flux + real (kind=kind_phys), pointer :: dwn_mfi (:,:) => null() !< instantaneous convective downdraft mass flux + real (kind=kind_phys), pointer :: det_mfi (:,:) => null() !< instantaneous convective detrainment mass flux + + contains + procedure :: create => coupling_create !< allocate array data + end type GFS_coupling_type + + +!---------------------------------------------------------------------------------- +! GFS_control_type +! model control parameters input from a namelist and/or derived from others +! list of those that can be modified during the run are at the bottom of the list +!---------------------------------------------------------------------------------- + type GFS_control_type + + integer :: me !< MPI rank designator + integer :: master !< MPI rank of master atmosphere processor + integer :: nlunit !< unit for namelist + character(len=64) :: fn_nml !< namelist filename for surface data cycling + character(len=:), pointer, dimension(:) :: input_nml_file => null() !< character string containing full namelist + !< for use with internal file reads + real(kind=kind_phys) :: fhzero !< seconds between clearing of diagnostic buckets + logical :: ldiag3d !< flag for 3d diagnostic fields + logical :: lssav !< logical flag for storing diagnostics + real(kind=kind_phys) :: fhcyc !< frequency for surface data cycling (secs) + logical :: lgocart !< flag for 3d diagnostic fields for gocart 1 + real(kind=kind_phys) :: fhgoc3d !< seconds between calls to gocart + integer :: thermodyn_id !< valid for GFS only for get_prs/phi + integer :: sfcpress_id !< valid for GFS only for get_prs/phi + logical :: gen_coord_hybrid!< for Henry's gen coord + logical :: sfc_override !< use idealized surface conditions + + !--- set some grid extent parameters + integer :: isc !< starting i-index for this MPI-domain + integer :: jsc !< starting j-index for this MPI-domain + integer :: nx !< number of points in the i-dir for this MPI-domain + integer :: ny !< number of points in the j-dir for this MPI-domain + integer :: levs !< number of vertical levels + integer :: cnx !< number of points in the i-dir for this cubed-sphere face + integer :: cny !< number of points in the j-dir for this cubed-sphere face + integer :: lonr !< number of global points in x-dir (i) along the equator + integer :: latr !< number of global points in y-dir (j) along any meridian + integer :: tile_num + integer :: nblks !< for explicit data blocking: number of blocks + integer, pointer :: blksz(:) !< for explicit data blocking: block sizes of all blocks + + !--- coupling parameters + logical :: cplflx !< default no cplflx collection + logical :: cplwav !< default no cplwav collection + + !--- integrated dynamics through earth's atmosphere + logical :: lsidea + + !--- calendars and time parameters and activation triggers + real(kind=kind_phys) :: dtp !< physics timestep in seconds + real(kind=kind_phys) :: dtf !< dynamics timestep in seconds + integer :: nscyc !< trigger for surface data cycling + integer :: nszero !< trigger for zeroing diagnostic buckets + integer :: idat(1:8) !< initialization date and time + !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) + integer :: idate(4) !< initial date with different size and ordering + !< (hr, mon, day, yr) + !--- radiation control parameters + real(kind=kind_phys) :: fhswr !< frequency for shortwave radiation (secs) + real(kind=kind_phys) :: fhlwr !< frequency for longwave radiation (secs) + integer :: nsswr !< integer trigger for shortwave radiation + integer :: nslwr !< integer trigger for longwave radiation + integer :: levr !< number of vertical levels for radiation calculations + integer :: nfxr !< second dimension for fluxr diagnostic variable (radiation) + integer :: nkld !< second dimension for cloud diagnostic variable (radiation) + logical :: aero_in !< aerosol flag for gbphys + logical :: lmfshal !< parameter for radiation + logical :: lmfdeep2 !< parameter for radiation + integer :: nrcm !< second dimension of random number stream for RAS + integer :: iflip !< iflip - is not the same as flipv + integer :: isol !< use prescribed solar constant + integer :: ico2 !< prescribed global mean value (old opernl) + integer :: ialb !< use climatology alb, based on sfc type + !< 1 => use modis based alb + integer :: iems !< use fixed value of 1.0 + integer :: iaer !< default aerosol effect in sw only + integer :: iovr_sw !< sw: max-random overlap clouds + integer :: iovr_lw !< lw: max-random overlap clouds + integer :: ictm !< ictm=0 => use data at initial cond time, if not + !< available; use latest; no extrapolation. + !< ictm=1 => use data at the forecast time, if not + !< available; use latest; do extrapolation. + !< ictm=yyyy0 => use yyyy data for the forecast time; + !< no extrapolation. + !< ictm=yyyy1 = > use yyyy data for the fcst. If needed, + !< do extrapolation to match the fcst time. + !< ictm=-1 => use user provided external data for + !< the fcst time; no extrapolation. + !< ictm=-2 => same as ictm=0, but add seasonal cycle + !< from climatology; no extrapolation. + integer :: isubc_sw !< sw clouds without sub-grid approximation + integer :: isubc_lw !< lw clouds without sub-grid approximation + !< =1 => sub-grid cloud with prescribed seeds + !< =2 => sub-grid cloud with randomly generated + !< seeds + logical :: crick_proof !< CRICK-Proof cloud water + logical :: ccnorm !< Cloud condensate normalized by cloud cover + logical :: norad_precip !< radiation precip flag for Ferrier/Moorthi + logical :: lwhtr !< flag to output lw heating rate (Radtend%lwhc) + logical :: swhtr !< flag to output sw heating rate (Radtend%swhc) + logical :: fixed_date !< flag to fix astronomy (not solar angle) to initial date + logical :: fixed_solhr !< flag to fix solar angle to initial time + logical :: daily_mean !< flag to replace cosz with daily mean value + + !--- microphysical switch + integer :: ncld !< cnoice of cloud scheme + + !--- GFDL microphysical parameters + logical :: do_inline_mp !< flag for GFDL cloud microphysics + + !--- Z-C microphysical parameters + logical :: zhao_mic !< flag for Zhao-Carr microphysics + real(kind=kind_phys) :: psautco(2) !< [in] auto conversion coeff from ice to snow + real(kind=kind_phys) :: prautco(2) !< [in] auto conversion coeff from cloud to rain + real(kind=kind_phys) :: evpco !< [in] coeff for evaporation of largescale rain + real(kind=kind_phys) :: wminco(2) !< [in] water and ice minimum threshold for Zhao + + !--- M-G microphysical parameters + integer :: fprcp !< no prognostic rain and snow (MG) + real(kind=kind_phys) :: mg_dcs !< Morrison-Gettleman microphysics parameters + real(kind=kind_phys) :: mg_qcvar + real(kind=kind_phys) :: mg_ts_auto_ice !< ice auto conversion time scale + + !--- land/surface model parameters + integer :: lsm !< flag for land surface model lsm=1 for noah lsm + integer :: lsm_noah=1 !< flag for NOAH land surface model + integer :: lsm_noahmp=2 !< flag for NOAH land surface model + integer :: lsoil !< number of soil layers + integer :: ivegsrc !< ivegsrc = 0 => USGS, + !< ivegsrc = 1 => IGBP (20 category) + !< ivegsrc = 2 => UMD (13 category) + integer :: isot !< isot = 0 => Zobler soil type ( 9 category) + !< isot = 1 => STATSGO soil type (19 category) + logical :: mom4ice !< flag controls mom4 sea ice + logical :: use_ufo !< flag for gcycle surface option + real(kind=kind_phys) :: czil_sfc !< Zilintkinivich constant + + ! -- the Noah MP options + + integer :: iopt_dveg ! 1-> off table lai 2-> on 3-> off;4->off;5 -> on + integer :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + integer :: iopt_stc !snow/soil temperature time scheme (only layer 1) + + !--- tuning parameters for physical parameterizations + logical :: ras !< flag for ras convection scheme + logical :: flipv !< flag for vertical direction flip (ras) + !< .true. implies surface at k=1 + logical :: trans_trac !< flag for convective transport of tracers (RAS only) + logical :: old_monin !< flag for diff monin schemes + logical :: orogwd !< flag for orog gravity wave drag + logical :: cnvgwd !< flag for conv gravity wave drag + logical :: mstrat !< flag for moorthi approach for stratus + logical :: moist_adj !< flag for moist convective adjustment + logical :: cscnv !< flag for Chikira-Sugiyama convection + logical :: cal_pre !< flag controls precip type algorithm + logical :: do_aw !< AW scale-aware option in cs convection + logical :: do_shoc !< flag for SHOC + logical :: shocaftcnv !< flag for SHOC + logical :: shoc_cld !< flag for clouds + logical :: uni_cld !< flag for clouds in grrad + logical :: h2o_phys !< flag for stratosphere h2o + logical :: pdfcld !< flag for pdfcld + logical :: shcnvcw !< flag for shallow convective cloud + logical :: redrag !< flag for reduced drag coeff. over sea + logical :: sfc_gfdl !< flag for using updated sfc layer scheme + real(kind=kind_phys) :: z0s_max !< a limiting value for z0 under high winds + logical :: do_z0_moon !< flag for using z0 scheme in Moon et al. 2007 (kgao) + logical :: do_z0_hwrf15 !< flag for using z0 scheme in 2015 HWRF (kgao) + logical :: do_z0_hwrf17 !< flag for using z0 scheme in 2017 HWRF (kgao) + logical :: do_z0_hwrf17_hwonly !< flag for using z0 scheme in 2017 HWRF only under high wind (kgao) + real(kind=kind_phys) :: wind_th_hwrf !< wind speed threshold when z0 level off as in HWRF (kgao) + logical :: hybedmf !< flag for hybrid edmf pbl scheme + logical :: myj_pbl !< flag for NAM MYJ tke scheme + logical :: ysupbl !< flag for ysu pbl scheme (version in WRFV3.8) + logical :: satmedmf !< flag for scale-aware TKE-based moist edmf + !< vertical turbulent mixing scheme + logical :: no_pbl !< disable PBL (for LES) + logical :: cap_k0_land !< flag for applying limter on background diff in inversion layer over land in satmedmfdiff.f + logical :: do_dk_hb19 !< flag for using hb19 background diff formula in satmedmfdiff.f + logical :: dspheat !< flag for tke dissipative heating + logical :: lheatstrg !< flag for canopy heat storage parameterization + real(kind=kind_phys) :: hour_canopy !< tunable time scale for canopy heat storage parameterization + real(kind=kind_phys) :: afac_canopy !< tunable enhancement factor for canopy heat storage parameterization + real(kind=kind_phys) :: xkzm_m !< [in] bkgd_vdif_m background vertical diffusion for momentum for ocean points + real(kind=kind_phys) :: xkzm_h !< [in] bkgd_vdif_h background vertical diffusion for heat q for ocean points + real(kind=kind_phys) :: xkzm_ml !< [in] bkgd_vdif_m background vertical diffusion for momentum for land points + real(kind=kind_phys) :: xkzm_hl !< [in] bkgd_vdif_h background vertical diffusion for heat q for land points + real(kind=kind_phys) :: xkzm_mi !< [in] bkgd_vdif_m background vertical diffusion for momentum for ice points + real(kind=kind_phys) :: xkzm_hi !< [in] bkgd_vdif_h background vertical diffusion for heat q for ice points + real(kind=kind_phys) :: xkzm_s !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion + real(kind=kind_phys) :: xkzm_lim !< [in] background vertical diffusion limit + real(kind=kind_phys) :: xkzm_fac !< [in] background vertical diffusion factor + real(kind=kind_phys) :: xkzminv !< diffusivity in inversion layers + real(kind=kind_phys) :: xkgdx !< [in] background vertical diffusion threshold + real(kind=kind_phys) :: rlmn !< [in] lower-limter on asymtotic mixing length in satmedmfdiff.f + real(kind=kind_phys) :: rlmx !< [in] upper-limter on asymtotic mixing length in satmedmfdiff.f + real(kind=kind_phys) :: zolcru !< [in] a threshold for activating the surface-driven updraft transports in satmedmfdifq.f + real(kind=kind_phys) :: cs0 !< [in] a parameter that controls the shear effect on the mixing length in satmedmfdifq.f + real(kind=kind_phys) :: moninq_fac !< turbulence diffusion coefficient factor + real(kind=kind_phys) :: dspfac !< tke dissipative heating factor + real(kind=kind_phys) :: bl_upfr !< updraft fraction in boundary layer mass flux scheme + real(kind=kind_phys) :: bl_dnfr !< downdraft fraction in boundary layer mass flux scheme + real(kind=kind_phys) :: ysu_ent_fac !< Entrainment factor in YSU scheme + real(kind=kind_phys) :: ysu_pfac_q !< Exponent in scalar vertical mixing + real(kind=kind_phys) :: ysu_brcr_ub !< critical bulk Richardson number in YSU scheme + real(kind=kind_phys) :: ysu_rlam !< mixing length parameter in YSU scheme + real(kind=kind_phys) :: ysu_afac !< afac parameter in YSU scheme + real(kind=kind_phys) :: ysu_bfac !< bfac parameter in YSU scheme + real(kind=kind_phys) :: ysu_hpbl_cr !< critical hpbl for turning on entrainment fluxes in YSU + real(kind=kind_phys) :: tnl_fac !< controls nonlocal mixing of t in YSU scheme (1. or 0.) + real(kind=kind_phys) :: qnl_fac !< controls nonlocal mixing of q in YSU scheme (1. or 0.) + real(kind=kind_phys) :: unl_fac !< controls nonlocal mixing of wind in YSU scheme (1. or 0.) + logical :: cnvcld + logical :: cloud_gfdl !< flag for GFDL cloud radii scheme + logical :: random_clds !< flag controls whether clouds are random + logical :: shal_cnv !< flag for calling shallow convection + integer :: imfshalcnv !< flag for mass-flux shallow convection scheme + !< 1: July 2010 version of mass-flux shallow conv scheme + !< current operational version as of 2016 + !< 2: scale- & aerosol-aware mass-flux shallow conv scheme (2017) + !< 3: scale- & aerosol-aware mass-flux shallow conv scheme (2020) + !< 0: modified Tiedtke's eddy-diffusion shallow conv scheme + !< -1: no shallow convection used + integer :: imfdeepcnv !< flag for mass-flux deep convection scheme + !< 1: July 2010 version of SAS conv scheme + !< current operational version as of 2016 + !< 2: scale- & aerosol-aware mass-flux deep conv scheme (2017) + !< 3: scale- & aerosol-aware mass-flux deep conv scheme (2020) + !< 0: old SAS Convection scheme before July 2010 + integer :: isatmedmf !< flag for scale-aware TKE-based moist edmf scheme + !< 0: initial version of satmedmf (Nov 2018) modified by kgao at GFDL + !< 1: updated version of satmedmf (May 2019) modified by kgao at GFDL + logical :: do_deep !< whether to do deep convection + integer :: nmtvr !< number of topographic variables such as variance etc + !< used in the GWD parameterization + integer :: jcap !< number of spectral wave trancation used only by sascnv shalcnv + real(kind=kind_phys) :: cs_parm(10) !< tunable parameters for Chikira-Sugiyama convection + real(kind=kind_phys) :: flgmin(2) !< [in] ice fraction bounds + real(kind=kind_phys) :: cgwf(2) !< multiplication factor for convective GWD + real(kind=kind_phys) :: ccwf(2) !< multiplication factor for critical cloud + !< workfunction for RAS + real(kind=kind_phys) :: cdmbgwd(2) !< multiplication factors for cdmb and gwd + real(kind=kind_phys) :: gwd_p_crit !< Optional level above which GWD stress decays with height + real(kind=kind_phys) :: sup !< supersaturation in pdf cloud when t is very low + real(kind=kind_phys) :: ctei_rm(2) !< critical cloud top entrainment instability criteria + !< (used if mstrat=.true.) + real(kind=kind_phys) :: crtrh(3) !< critical relative humidity at the surface + !< PBL top and at the top of the atmosphere + real(kind=kind_phys) :: dlqf(2) !< factor for cloud condensate detrainment + !< from cloud edges for RAS + integer :: seed0 !< random seed for radiation + + real(kind=kind_phys) :: rbcr !< Critical Richardson Number in the PBL scheme + logical :: mix_precip !< Whether to apply PBL mixing to precipitating hydrometeors + + !--- Rayleigh friction + real(kind=kind_phys) :: prslrd0 !< pressure level from which Rayleigh Damping is applied + real(kind=kind_phys) :: ral_ts !< time scale for Rayleigh damping in days + + !--- mass flux deep convection + logical :: ext_rain_deep !< Whether to extract rain water from the deep convection + real(kind=kind_phys) :: clam_deep !< c_e for deep convection (Han and Pan, 2011, eq(6)) + real(kind=kind_phys) :: c0s_deep !< conversion parameter of detrainment from liquid water into convetive precipitaiton + real(kind=kind_phys) :: c1_deep !< conversion parameter of detrainment from liquid water into grid-scale cloud water + real(kind=kind_phys) :: betal_deep !< downdraft heat flux contribution over land + real(kind=kind_phys) :: betas_deep !< downdraft heat flux contribution over ocean + real(kind=kind_phys) :: evfact_deep !< evaporation factor + real(kind=kind_phys) :: evfactl_deep !< evaporation factor over land + real(kind=kind_phys) :: pgcon_deep !< control the reduction in momentum transport + !< 0.7 : Gregory et al. (1997, QJRMS) + !< 0.55: Zhang & Wu (2003, JAS) + real(kind=kind_phys) :: asolfac_deep !< aerosol-aware parameter based on Lim & Hong (2012) + !< asolfac= cx / c0s(=.002) + !< cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) + !< Nccn: CCN number concentration in cm^(-3) + !< Until a realistic Nccn is provided, typical Nccns are assumed + !< as Nccn=100 for sea and Nccn=7000 for land + + !--- mass flux shallow convection + logical :: ext_rain_shal !< Whether to extract rain water from the shallow convection + real(kind=kind_phys) :: clam_shal !< c_e for shallow convection (Han and Pan, 2011, eq(6)) + real(kind=kind_phys) :: c0s_shal !< conversion parameter of detrainment from liquid water into convetive precipitaiton + real(kind=kind_phys) :: c1_shal !< conversion parameter of detrainment from liquid water into grid-scale cloud water + real(kind=kind_phys) :: pgcon_shal !< control the reduction in momentum transport + !< 0.7 : Gregory et al. (1997, QJRMS) + !< 0.55: Zhang & Wu (2003, JAS) + real(kind=kind_phys) :: asolfac_shal !< aerosol-aware parameter based on Lim & Hong (2012) + !< asolfac= cx / c0s(=.002) + !< cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) + !< Nccn: CCN number concentration in cm^(-3) + !< Until a realistic Nccn is provided, typical Nccns are assumed + !< as Nccn=100 for sea and Nccn=7000 for land + real(kind=kind_phys) :: evfact_shal !< rain evaporation efficiency over the ocean + real(kind=kind_phys) :: evfactl_shal !< rain evaporation efficiency over the land + + !--- near surface temperature model + logical :: nst_anl !< flag for NSSTM analysis in gcycle/sfcsub + integer :: lsea + integer :: nstf_name(5) !< flag 0 for no nst 1 for uncoupled nst and 2 for coupled NST + !< nstf_name contains the NSST related parameters + !< nstf_name(1) : 0 = NSSTM off, 1 = NSSTM on but uncoupled, 2 = + !< nstf_name(2) : 1 = NSSTM spin up on, 0 = NSSTM spin up off + !< nstf_name(3) : 1 = NSST analysis on, 0 = NSSTM analysis off + !< nstf_name(4) : zsea1 in mm + !< nstf_name(5) : zsea2 in mm + +!--- fractional grid + logical :: frac_grid !< flag for fractional grid + logical :: ignore_lake !< flag for ignoring lakes + real(kind=kind_phys) :: min_lakeice !< minimum lake ice value + real(kind=kind_phys) :: min_seaice !< minimum sea ice value + real(kind=kind_phys) :: min_lake_height !< minimum lake height value + real(kind=kind_phys) :: rho_h2o !< density of fresh water + + !---cellular automata control parameters + integer :: nca !< number of independent cellular automata + integer :: nlives !< cellular automata lifetime + integer :: ncells !< cellular automata finer grid + real(kind=kind_phys) :: nfracseed !< cellular automata seed probability + integer :: nseed !< cellular automata seed frequency + logical :: do_ca !< cellular automata main switch + logical :: ca_sgs !< switch for sgs ca + logical :: ca_global !< switch for global ca + logical :: ca_smooth !< switch for gaussian spatial filter + logical :: isppt_deep !< switch for combination with isppt_deep. OBS! Switches off SPPT on other tendencies! + integer :: iseed_ca !< seed for random number generation in ca scheme + integer :: nspinup !< number of iterations to spin up the ca + real(kind=kind_phys) :: nthresh !< threshold used for perturbed vertical velocity + + + !--- stochastic physics control parameters + logical :: do_sppt + logical :: use_zmtnblck + logical :: do_shum + logical :: do_skeb + integer :: skeb_npass + logical :: do_sfcperts + integer :: nsfcpert=6 + real(kind=kind_phys) :: pertz0(5) ! mg, sfc-perts + real(kind=kind_phys) :: pertzt(5) ! mg, sfc-perts + real(kind=kind_phys) :: pertshc(5) ! mg, sfc-perts + real(kind=kind_phys) :: pertlai(5) ! mg, sfc-perts + real(kind=kind_phys) :: pertalb(5) ! mg, sfc-perts + real(kind=kind_phys) :: pertvegf(5) ! mg, sfc-perts + !--- tracer handling + character(len=32), pointer :: tracer_names(:) !< array of initialized tracers from dynamic core + integer :: ntrac !< number of tracers + integer :: ntoz !< tracer index for ozone mixing ratio + integer :: ntcw !< tracer index for cloud condensate (or liquid water) + integer :: ntiw !< tracer index for ice water + integer :: ntrw !< tracer index for rain water + integer :: ntsw !< tracer index for snow water + integer :: ntgl !< tracer index for graupel + integer :: ntclamt !< tracer index for cloud amount + integer :: ntlnc !< tracer index for liquid number concentration + integer :: ntinc !< tracer index for ice number concentration + integer :: ntrnc !< tracer index for rain number concentration + integer :: ntsnc !< tracer index for snow number concentration + integer :: ntgnc !< tracer index for graupel number concentration + integer :: ntke !< tracer index for kinetic energy + integer :: nto !< tracer index for oxygen ion + integer :: nto2 !< tracer index for oxygen + integer :: ntwa !< tracer index for water friendly aerosol + integer :: ntia !< tracer index for ice friendly aerosol + integer :: ntchm !< number of chemical tracers + integer :: ntchs !< tracer index for first chemical tracer + logical, pointer :: ntdiag(:) => null() !< array to control diagnostics for chemical tracers + real(kind=kind_phys), pointer :: fscav(:) => null() !< array of aerosol scavenging coefficients + + + !--- derived totals for phy_f*d + integer :: ntot2d !< total number of variables for phyf2d + integer :: ntot3d !< total number of variables for phyf3d + integer :: num_p2d !< number of 2D arrays needed for microphysics + integer :: num_p3d !< number of 3D arrays needed for microphysics + integer :: nshoc_2d !< number of 2d fields for SHOC + integer :: nshoc_3d !< number of 3d fields for SHOC + integer :: ncnvcld3d !< number of convective 3d clouds fields + integer :: npdf3d !< number of 3d arrays associated with pdf based clouds/microphysics + integer :: nctp !< number of cloud types in Chikira-Sugiyama scheme + + !--- debug flag + logical :: debug + logical :: pre_rad !< flag for testing purpose + logical :: do_ocean !< flag for slab ocean model + logical :: use_ext_sst !< flag for using external SST forcing (or any external SST dataset, passed from the dynamics or nudging) + + !--- variables modified at each time step + integer :: ipt !< index for diagnostic printout point + logical :: lprnt !< control flag for diagnostic print out + logical :: lsswr !< logical flags for sw radiation calls + logical :: lslwr !< logical flags for lw radiation calls + real(kind=kind_phys) :: solhr !< hour time after 00z at the t-step + real(kind=kind_phys) :: solcon !< solar constant (sun-earth distant adjusted) [set via radupdate] + real(kind=kind_phys) :: slag !< equation of time ( radian ) [set via radupdate] + real(kind=kind_phys) :: sdec !< sin of the solar declination angle [set via radupdate] + real(kind=kind_phys) :: cdec !< cos of the solar declination angle [set via radupdate] + real(kind=kind_phys) :: clstp !< index used by cnvc90 (for convective clouds) + !< legacy stuff - does not affect forecast + real(kind=kind_phys) :: phour !< previous forecast hour + real(kind=kind_phys) :: fhour !< curent forecast hour + real(kind=kind_phys) :: zhour !< previous hour diagnostic buckets emptied + integer :: kdt !< current forecast iteration + integer :: kdt_prev !< last step + integer :: jdat(1:8) !< current forecast date and time + !< (yr, mon, day, t-zone, hr, min, sec, mil-sec) + integer :: imn !< initial forecast month + real(kind=kind_phys) :: julian !< julian day using midnight of January 1 of forecast year as initial epoch + integer :: yearlen !< length of the current forecast year in days + +!--- IAU + integer :: iau_offset + real(kind=kind_phys) :: iau_delthrs ! iau time interval (to scale increments) in hours + character(len=240) :: iau_inc_files(7)! list of increment files + character(len=32) :: iau_forcing_var(20) ! list of tracers with IAU forcing + real(kind=kind_phys) :: iaufhrs(7) ! forecast hours associated with increment files + logical :: iau_filter_increments, iau_drymassfixer + + contains + procedure :: init => control_initialize + procedure :: print => control_print + end type GFS_control_type + + +!-------------------------------------------------------------------- +! GFS_grid_type +! grid data needed for interpolations and length-scale calculations +!-------------------------------------------------------------------- + type GFS_grid_type + + real (kind=kind_phys), pointer :: xlon (:) => null() !< grid longitude in radians, ok for both 0->2pi + !! or -pi -> +pi ranges + real (kind=kind_phys), pointer :: xlat (:) => null() !< grid latitude in radians, default to pi/2 -> + !! -pi/2 range, otherwise adj in subr called + + real (kind=kind_phys), pointer :: xlat_d (:) => null() !< grid latitude in degrees, default to 90 -> + !! -90 range, otherwise adj in subr called + real (kind=kind_phys), pointer :: sinlat (:) => null() !< sine of the grids corresponding latitudes + real (kind=kind_phys), pointer :: coslat (:) => null() !< cosine of the grids corresponding latitudes + real (kind=kind_phys), pointer :: area (:) => null() !< area of the grid cell + real (kind=kind_phys), pointer :: dx (:) => null() !< relative dx for the grid cell + + !--- grid-related interpolation data for prognostic ozone + real (kind=kind_phys), pointer :: ddy_o3 (:) => null() !< interpolation weight for ozone + integer, pointer :: jindx1_o3 (:) => null() !< interpolation low index for ozone + integer, pointer :: jindx2_o3 (:) => null() !< interpolation high index for ozone + + !--- grid-related interpolation data for stratosphere water + real (kind=kind_phys), pointer :: ddy_h (:) => null() !< interpolation weight for h2o + integer, pointer :: jindx1_h (:) => null() !< interpolation low index for h2o + integer, pointer :: jindx2_h (:) => null() !< interpolation high index for h2o + contains + procedure :: create => grid_create !< allocate array data + end type GFS_grid_type + + +!----------------------------------------------- +! GFS_tbd_type +! data not yet assigned to a defined container +!----------------------------------------------- + type GFS_tbd_type + + !--- radiation random seeds + integer, pointer :: icsdsw (:) => null() !< (rad. only) auxiliary cloud control arrays passed to main + integer, pointer :: icsdlw (:) => null() !< (rad. only) radiations. if isubcsw/isubclw (input to init) + !< (rad. only) are set to 2, the arrays contains provided + !< (rad. only) random seeds for sub-column clouds generators + + !--- In + real (kind=kind_phys), pointer :: ozpl (:,:,:) => null() !< ozone forcing data + real (kind=kind_phys), pointer :: h2opl (:,:,:) => null() !< water forcing data + + !--- active when ((.not. newsas .or. cal_pre) .and. random_clds) + real (kind=kind_phys), pointer :: rann (:,:) => null() !< random number array (0-1) + + !--- In/Out + real (kind=kind_phys), pointer :: acv (:) => null() !< array containing accumulated convective clouds + real (kind=kind_phys), pointer :: acvb (:) => null() !< arrays used by cnvc90 bottom + real (kind=kind_phys), pointer :: acvt (:) => null() !< arrays used by cnvc90 top (cnvc90.f) + + !--- Stochastic physics properties calculated in physics_driver + real (kind=kind_phys), pointer :: dtdtr (:,:) => null() !< temperature change due to radiative heating per time step (K) + real (kind=kind_phys), pointer :: dtotprcp (:) => null() !< change in totprcp (diag_type) + real (kind=kind_phys), pointer :: dcnvprcp (:) => null() !< change in cnvprcp (diag_type) + real (kind=kind_phys), pointer :: drain_cpl (:) => null() !< change in rain_cpl (coupling_type) + real (kind=kind_phys), pointer :: dsnow_cpl (:) => null() !< change in show_cpl (coupling_type) + + !--- phy_f*d variables needed for seamless restarts and moving data between grrad and gbphys + real (kind=kind_phys), pointer :: phy_fctd (:,:) => null() !< For CS convection + real (kind=kind_phys), pointer :: phy_f2d (:,:) => null() !< 2d arrays saved for restart + real (kind=kind_phys), pointer :: phy_f3d (:,:,:) => null() !< 3d arrays saved for restart + + contains + procedure :: create => tbd_create !< allocate array data + end type GFS_tbd_type + + +!------------------------------------------------------------------ +! GFS_cldprop_type +! cloud properties and tendencies needed by radiation from physics +!------------------------------------------------------------------ + type GFS_cldprop_type + + !--- In (radiation) + !--- In/Out (physics) + real (kind=kind_phys), pointer :: cv (:) => null() !< fraction of convective cloud ; phys + real (kind=kind_phys), pointer :: cvt (:) => null() !< convective cloud top pressure in pa ; phys + real (kind=kind_phys), pointer :: cvb (:) => null() !< convective cloud bottom pressure in pa ; phys, cnvc90 + + contains + procedure :: create => cldprop_create !< allocate array data + end type GFS_cldprop_type + + +!----------------------------------------- +! GFS_radtend_type +! radiation tendencies needed by physics +!----------------------------------------- + type GFS_radtend_type + + type (sfcfsw_type), pointer :: sfcfsw(:) => null() !< sw radiation fluxes at sfc + !< [dim(im): created in grrad.f], components: + !! (check module_radsw_parameters for definition) + !!\n %upfxc - total sky upward sw flux at sfc (w/m**2) + !!\n %upfx0 - clear sky upward sw flux at sfc (w/m**2) + !!\n %dnfxc - total sky downward sw flux at sfc (w/m**2) + !!\n %dnfx0 - clear sky downward sw flux at sfc (w/m**2) + + type (sfcflw_type), pointer :: sfcflw(:) => null() !< lw radiation fluxes at sfc + !< [dim(im): created in grrad.f], components: + !! (check module_radlw_paramters for definition) + !!\n %upfxc - total sky upward lw flux at sfc (w/m**2) + !!\n %upfx0 - clear sky upward lw flux at sfc (w/m**2) + !!\n %dnfxc - total sky downward lw flux at sfc (w/m**2) + !!\n %dnfx0 - clear sky downward lw flux at sfc (w/m**2) + + !--- Out (radiation only) + real (kind=kind_phys), pointer :: htrsw (:,:) => null() !< swh total sky sw heating rate in k/sec + real (kind=kind_phys), pointer :: htrlw (:,:) => null() !< hlw total sky lw heating rate in k/sec + real (kind=kind_phys), pointer :: sfalb (:) => null() !< mean surface diffused sw albedo + + real (kind=kind_phys), pointer :: coszen(:) => null() !< mean cos of zenith angle over rad call period + real (kind=kind_phys), pointer :: tsflw (:) => null() !< surface air temp during lw calculation in k + real (kind=kind_phys), pointer :: semis (:) => null() !< surface lw emissivity in fraction + + !--- In/Out (???) (radiaition only) + real (kind=kind_phys), pointer :: coszdg(:) => null() !< daytime mean cosz over rad call period + + !--- In/Out (???) (physics only) + real (kind=kind_phys), pointer :: swhc (:,:) => null() !< clear sky sw heating rates ( k/s ) + real (kind=kind_phys), pointer :: lwhc (:,:) => null() !< clear sky lw heating rates ( k/s ) + real (kind=kind_phys), pointer :: lwhd (:,:,:) => null() !< idea sky lw heating rates ( k/s ) + + contains + procedure :: create => radtend_create !< allocate array data + end type GFS_radtend_type + +!---------------------------------------------------------------- +! GFS_diag_type +! internal diagnostic type used as arguments to gbphys and grrad +!---------------------------------------------------------------- + type GFS_diag_type + + !! Input/Output only in radiation + real (kind=kind_phys), pointer :: fluxr (:,:) => null() !< to save time accumulated 2-d fields defined as:! + !< hardcoded field indices, opt. includes aerosols! + real (kind=kind_phys), pointer :: cloud (:,:,:) => null() !< to save time accumulated 3-d fields defined as:! + !< hardcoded field indices + type (topfsw_type), pointer :: topfsw(:) => null() !< sw radiation fluxes at toa, components: + ! %upfxc - total sky upward sw flux at toa (w/m**2) + ! %dnfxc - total sky downward sw flux at toa (w/m**2) + ! %upfx0 - clear sky upward sw flux at toa (w/m**2) + type (topflw_type), pointer :: topflw(:) => null() !< lw radiation fluxes at top, component: + ! %upfxc - total sky upward lw flux at toa (w/m**2) + ! %upfx0 - clear sky upward lw flux at toa (w/m**2) + + ! Input/output - used by physics + real (kind=kind_phys), pointer :: srunoff(:) => null() !< surface water runoff (from lsm) + real (kind=kind_phys), pointer :: evbsa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: evcwa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: snohfa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: transa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: sbsnoa (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: snowca (:) => null() !< noah lsm diagnostics + real (kind=kind_phys), pointer :: soilm (:) => null() !< soil moisture + real (kind=kind_phys), pointer :: tmpmin (:) => null() !< min temperature at 2m height (k) + real (kind=kind_phys), pointer :: tmpmax (:) => null() !< max temperature at 2m height (k) + real (kind=kind_phys), pointer :: dusfc (:) => null() !< u component of surface stress + real (kind=kind_phys), pointer :: dvsfc (:) => null() !< v component of surface stress + real (kind=kind_phys), pointer :: dtsfc (:) => null() !< sensible heat flux (w/m2) + real (kind=kind_phys), pointer :: dqsfc (:) => null() !< latent heat flux (w/m2) + real (kind=kind_phys), pointer :: totprcp(:) => null() !< accumulated total precipitation (kg/m2) + real (kind=kind_phys), pointer :: totprcpb(:) => null() !< accumulated total precipitation in bucket(kg/m2) + real (kind=kind_phys), pointer :: gflux (:) => null() !< groud conductive heat flux + real (kind=kind_phys), pointer :: dlwsfc (:) => null() !< time accumulated sfc dn lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: ulwsfc (:) => null() !< time accumulated sfc up lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: suntim (:) => null() !< sunshine duration time (s) + real (kind=kind_phys), pointer :: runoff (:) => null() !< total water runoff + real (kind=kind_phys), pointer :: ep (:) => null() !< potential evaporation + real (kind=kind_phys), pointer :: cldwrk (:) => null() !< cloud workfunction (valid only with sas) + real (kind=kind_phys), pointer :: dugwd (:) => null() !< vertically integrated u change by OGWD + real (kind=kind_phys), pointer :: dvgwd (:) => null() !< vertically integrated v change by OGWD + real (kind=kind_phys), pointer :: psmean (:) => null() !< surface pressure (kPa) + real (kind=kind_phys), pointer :: cnvprcp(:) => null() !< accumulated convective precipitation (kg/m2) + real (kind=kind_phys), pointer :: cnvprcpb(:) => null() !< accumulated convective precipitation in bucket (kg/m2) + real (kind=kind_phys), pointer :: spfhmin(:) => null() !< minimum specific humidity + real (kind=kind_phys), pointer :: spfhmax(:) => null() !< maximum specific humidity + real (kind=kind_phys), pointer :: u10mmax(:) => null() !< maximum u-wind + real (kind=kind_phys), pointer :: v10mmax(:) => null() !< maximum v-wind + real (kind=kind_phys), pointer :: wind10mmax(:) => null() !< maximum wind speed + real (kind=kind_phys), pointer :: rain (:) => null() !< total rain at this time step + real (kind=kind_phys), pointer :: rainc (:) => null() !< convective rain at this time step + real (kind=kind_phys), pointer :: ice (:) => null() !< ice fall at this time step + real (kind=kind_phys), pointer :: snow (:) => null() !< snow fall at this time step + real (kind=kind_phys), pointer :: graupel(:) => null() !< graupel fall at this time step + real (kind=kind_phys), pointer :: totice (:) => null() !< accumulated ice precipitation (kg/m2) + real (kind=kind_phys), pointer :: totsnw (:) => null() !< accumulated snow precipitation (kg/m2) + real (kind=kind_phys), pointer :: totgrp (:) => null() !< accumulated graupel precipitation (kg/m2) + real (kind=kind_phys), pointer :: toticeb(:) => null() !< accumulated ice precipitation in bucket (kg/m2) + real (kind=kind_phys), pointer :: totsnwb(:) => null() !< accumulated snow precipitation in bucket (kg/m2) + real (kind=kind_phys), pointer :: totgrpb(:) => null() !< accumulated graupel precipitation in bucket (kg/m2) + + ! Output - only in physics + real (kind=kind_phys), pointer :: u10m (:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: v10m (:) => null() !< 10 meater u/v wind speed + real (kind=kind_phys), pointer :: dpt2m (:) => null() !< 2 meter dew point temperature + real (kind=kind_phys), pointer :: zlvl (:) => null() !< layer 1 height (m) + real (kind=kind_phys), pointer :: psurf (:) => null() !< surface pressure (Pa) + real (kind=kind_phys), pointer :: hpbl (:) => null() !< pbl height (m) + real (kind=kind_phys), pointer :: hgamt (:) => null() !< ysu counter-gradient flux + real (kind=kind_phys), pointer :: hfxpbl (:) => null() !< ysu entrainment flux + real (kind=kind_phys), pointer :: pwat (:) => null() !< precipitable water + real (kind=kind_phys), pointer :: t1 (:) => null() !< layer 1 temperature (K) + real (kind=kind_phys), pointer :: q1 (:) => null() !< layer 1 specific humidity (kg/kg) + real (kind=kind_phys), pointer :: u1 (:) => null() !< layer 1 zonal wind (m/s) + real (kind=kind_phys), pointer :: v1 (:) => null() !< layer 1 merdional wind (m/s) + real (kind=kind_phys), pointer :: chh (:) => null() !< thermal exchange coefficient + real (kind=kind_phys), pointer :: cmm (:) => null() !< momentum exchange coefficient + real (kind=kind_phys), pointer :: dlwsfci(:) => null() !< instantaneous sfc dnwd lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: ulwsfci(:) => null() !< instantaneous sfc upwd lw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: dswsfci(:) => null() !< instantaneous sfc dnwd sw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: uswsfci(:) => null() !< instantaneous sfc upwd sw flux ( w/m**2 ) + real (kind=kind_phys), pointer :: dusfci (:) => null() !< instantaneous u component of surface stress + real (kind=kind_phys), pointer :: dvsfci (:) => null() !< instantaneous v component of surface stress + real (kind=kind_phys), pointer :: dtsfci (:) => null() !< instantaneous sfc sensible heat flux + real (kind=kind_phys), pointer :: dqsfci (:) => null() !< instantaneous sfc latent heat flux + real (kind=kind_phys), pointer :: gfluxi (:) => null() !< instantaneous sfc ground heat flux + real (kind=kind_phys), pointer :: epi (:) => null() !< instantaneous sfc potential evaporation + real (kind=kind_phys), pointer :: smcwlt2(:) => null() !< wilting point (volumetric) + real (kind=kind_phys), pointer :: smcref2(:) => null() !< soil moisture threshold (volumetric) + real (kind=kind_phys), pointer :: wet1 (:) => null() !< normalized soil wetness + real (kind=kind_phys), pointer :: sr (:) => null() !< snow ratio : ratio of snow to total precipitation +! + + real (kind=kind_phys), pointer :: ca_out (:) => null() !< cellular automata fraction + real (kind=kind_phys), pointer :: ca_deep (:) => null() !< cellular automata fraction + real (kind=kind_phys), pointer :: ca_turb (:) => null() !< cellular automata fraction + real (kind=kind_phys), pointer :: ca_shal (:) => null() !< cellular automata fraction + real (kind=kind_phys), pointer :: ca_rad (:) => null() !< cellular automata fraction + real (kind=kind_phys), pointer :: ca_micro (:) => null() !< cellular automata fraction + + real (kind=kind_phys), pointer :: diss_est(:,:) => null() !< dissipation rate for skeb + real (kind=kind_phys), pointer :: skebu_wts(:,:) => null() !< 10 meter u wind speed + real (kind=kind_phys), pointer :: skebv_wts(:,:) => null() !< 10 meter v wind speed + real (kind=kind_phys), pointer :: sppt_wts(:,:) => null() !< + real (kind=kind_phys), pointer :: shum_wts(:,:) => null() !< + real (kind=kind_phys), pointer :: zmtnblck(:) => null() ! null() !net surface heat flux + real (kind=kind_phys), pointer :: qflux_restore (:) => null() !restoring term for diagnosis only + real (kind=kind_phys), pointer :: tclim_iano (:) => null() !climatological SST with initial anomaly + real (kind=kind_phys), pointer :: MLD (:) => null() !ocean mixed layer depth + real (kind=kind_phys), pointer :: ps_dt (:) => null() !surface pressure tendency +! + ! Output - MYJ diagnostics + real (kind=kind_phys), pointer :: hmix (:) => null() ! Mixed layer height + real (kind=kind_phys), pointer :: el_myj (:,:) => null() ! mixing length +! + !--- accumulated quantities for 3D diagnostics + real (kind=kind_phys), pointer :: du3dt (:,:,:) => null() !< u momentum change due to physics + !< lz note: 1: pbl, 2: oro gwd, 3: rf, 4: con gwd + real (kind=kind_phys), pointer :: dv3dt (:,:,:) => null() !< v momentum change due to physics + !< lz note: 1: pbl, 2: oro gwd, 3: rf, 4: con gwd + real (kind=kind_phys), pointer :: dt3dt (:,:,:) => null() !< temperature change due to physics + !< lz note: 1: lw, 2: sw, 3: pbl, 4: deep con, 5: shal con, 6: mp + real (kind=kind_phys), pointer :: t_dt(:,:,:) => null() !< temperature tendency due to physics + real (kind=kind_phys), pointer :: t_dt_int(:,:) => null() !< vertically integrated temperature change due to physics scaled by cp / cvm or cp / cpm + real (kind=kind_phys), pointer :: dq3dt (:,:,:) => null() !< moisture change due to physics + !< lz note: 1: pbl, 2: deep con, 3: shal con, 4: mp, 5: ozone + real (kind=kind_phys), pointer :: q_dt(:,:,:) => null() !< specific humidity tendency due to physics + real (kind=kind_phys), pointer :: q_dt_int(:,:) => null() !< vertically integrated moisture tendency due to physics, adjusted to dycore mass fraction convention + real (kind=kind_phys), pointer :: dkt (:,:) => null() + real (kind=kind_phys), pointer :: flux_cg(:,:) => null() + real (kind=kind_phys), pointer :: flux_en(:,:) => null() + + !--- accumulated quantities for 3D diagnostics + real (kind=kind_phys), pointer :: upd_mf (:,:) => null() !< instantaneous convective updraft mass flux + real (kind=kind_phys), pointer :: dwn_mf (:,:) => null() !< instantaneous convective downdraft mass flux + real (kind=kind_phys), pointer :: det_mf (:,:) => null() !< instantaneous convective detrainment mass flux + real (kind=kind_phys), pointer :: cldcov (:,:) => null() !< instantaneous 3D cloud fraction + + contains + procedure :: create => diag_create + procedure :: rad_zero => diag_rad_zero + procedure :: phys_zero => diag_phys_zero + end type GFS_diag_type + +!---------------- +! PUBLIC ENTITIES +!---------------- + public GFS_init_type + public GFS_statein_type, GFS_stateout_type, GFS_sfcprop_type, & + GFS_coupling_type + public GFS_control_type, GFS_grid_type, GFS_tbd_type, & + GFS_cldprop_type, GFS_radtend_type, GFS_diag_type + +!******************************************************************************************* + CONTAINS + +!------------------------ +! GFS_statein_type%create +!------------------------ + subroutine statein_create (Statein, IM, Model) + implicit none + + class(GFS_statein_type) :: Statein + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + !--- level geopotential and pressures + allocate (Statein%phii (IM,Model%levs+1)) + allocate (Statein%prsi (IM,Model%levs+1)) + allocate (Statein%prsik (IM,Model%levs+1)) + + Statein%phii = clear_val + Statein%prsi = clear_val + Statein%prsik = clear_val + + !--- layer geopotential and pressures + allocate (Statein%phil (IM,Model%levs)) + allocate (Statein%prsl (IM,Model%levs)) + allocate (Statein%prslk (IM,Model%levs)) + + Statein%phil = clear_val + Statein%prsl = clear_val + Statein%prslk = clear_val + + !--- shared radiation and physics variables + allocate (Statein%vvl (IM,Model%levs)) + allocate (Statein%tgrs (IM,Model%levs)) + + Statein%vvl = clear_val + Statein%tgrs = clear_val +! stochastic physics SKEB variable + allocate (Statein%diss_est(IM,Model%levs)) + Statein%diss_est= clear_val + !--- physics only variables + allocate (Statein%pgr (IM)) + allocate (Statein%ugrs (IM,Model%levs)) + allocate (Statein%vgrs (IM,Model%levs)) + allocate (Statein%qgrs (IM,Model%levs,Model%ntrac)) + + Statein%qgrs = clear_val + Statein%pgr = clear_val + Statein%ugrs = clear_val + Statein%vgrs = clear_val + + if (Model%myj_pbl) then + allocate (Statein%exch_h(IM, Model%levs)) + Statein%exch_h = clear_val + endif + + + allocate (Statein%prer(IM)) + allocate (Statein%prei(IM)) + allocate (Statein%pres(IM)) + allocate (Statein%preg(IM)) + + Statein%prer = clear_val + Statein%prei = clear_val + Statein%pres = clear_val + Statein%preg = clear_val + + allocate (Statein%sst(IM)) + allocate (Statein%ci(IM)) + + Statein%sst = clear_val + Statein%ci = -999. ! if below zero it is empty so don't use it + + allocate(Statein%dycore_hydrostatic) + Statein%dycore_hydrostatic = .true. + + allocate(Statein%nwat) + Statein%nwat = 6 + +!--- soil state variables - for soil SPPT - sfc-perts, mgehne + allocate (Statein%smc (IM,Model%lsoil)) + allocate (Statein%stc (IM,Model%lsoil)) + allocate (Statein%slc (IM,Model%lsoil)) + + Statein%smc = clear_val + Statein%stc = clear_val + Statein%slc = clear_val + + end subroutine statein_create + + +!------------------------- +! GFS_stateout_type%create +!------------------------- + subroutine stateout_create (Stateout, IM, Model) + + implicit none + + class(GFS_stateout_type) :: Stateout + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + allocate (Stateout%gu0 (IM,Model%levs)) + allocate (Stateout%gv0 (IM,Model%levs)) + allocate (Stateout%gt0 (IM,Model%levs)) + allocate (Stateout%gq0 (IM,Model%levs,Model%ntrac)) + + Stateout%gu0 = clear_val + Stateout%gv0 = clear_val + Stateout%gt0 = clear_val + Stateout%gq0 = clear_val + + end subroutine stateout_create + + +!------------------------ +! GFS_sfcprop_type%create +!------------------------ + subroutine sfcprop_create (Sfcprop, IM, Model) + + implicit none + + class(GFS_sfcprop_type) :: Sfcprop + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + !--- physics and radiation + allocate (Sfcprop%slmsk (IM)) + allocate (Sfcprop%oceanfrac(IM)) + allocate (Sfcprop%landfrac (IM)) + allocate (Sfcprop%lakefrac (IM)) + allocate (Sfcprop%tsfc (IM)) + allocate (Sfcprop%tsfco (IM)) + allocate (Sfcprop%tsfcl (IM)) + allocate (Sfcprop%qsfc (IM)) + allocate (Sfcprop%tsclim (IM)) + allocate (Sfcprop%mldclim(IM)) + allocate (Sfcprop%qfluxadj(IM)) + allocate (Sfcprop%ts_som (IM)) + allocate (Sfcprop%ts_clim_iano (IM)) + allocate (Sfcprop%tml (IM)) + allocate (Sfcprop%tml0 (IM)) + allocate (Sfcprop%mld (IM)) + allocate (Sfcprop%mld0 (IM)) + allocate (Sfcprop%huml (IM)) + allocate (Sfcprop%hvml (IM)) + allocate (Sfcprop%tmoml (IM)) + allocate (Sfcprop%tmoml0 (IM)) + allocate (Sfcprop%tisfc (IM)) + allocate (Sfcprop%snowd (IM)) + allocate (Sfcprop%zorl (IM)) + allocate (Sfcprop%zorlo (IM)) + allocate (Sfcprop%zorll (IM)) + allocate (Sfcprop%ztrl (IM)) + allocate (Sfcprop%fice (IM)) + allocate (Sfcprop%hprim (IM)) + allocate (Sfcprop%hprime (IM,Model%nmtvr)) + + Sfcprop%slmsk = clear_val + Sfcprop%oceanfrac = clear_val + Sfcprop%landfrac = clear_val + Sfcprop%lakefrac = clear_val + Sfcprop%tsfc = clear_val + Sfcprop%tsfco = clear_val + Sfcprop%tsfcl = clear_val + Sfcprop%qsfc = clear_val + Sfcprop%tsclim = clear_val + Sfcprop%mldclim = clear_val + Sfcprop%qfluxadj= clear_val + Sfcprop%ts_som = clear_val + Sfcprop%ts_clim_iano = clear_val + Sfcprop%tml = clear_val + Sfcprop%tml0 = clear_val + Sfcprop%mld = clear_val + Sfcprop%mld0 = clear_val + Sfcprop%huml = clear_val + Sfcprop%hvml = clear_val + Sfcprop%tmoml = clear_val + Sfcprop%tmoml0 = clear_val + Sfcprop%tisfc = clear_val + Sfcprop%snowd = clear_val + Sfcprop%zorl = clear_val + Sfcprop%zorlo = clear_val + Sfcprop%zorll = clear_val + Sfcprop%ztrl = clear_val + Sfcprop%fice = clear_val + Sfcprop%hprim = clear_val + Sfcprop%hprime = clear_val + + !--- In (radiation only) + allocate (Sfcprop%sncovr (IM)) + allocate (Sfcprop%snoalb (IM)) + allocate (Sfcprop%alvsf (IM)) + allocate (Sfcprop%alnsf (IM)) + allocate (Sfcprop%alvwf (IM)) + allocate (Sfcprop%alnwf (IM)) + allocate (Sfcprop%facsf (IM)) + allocate (Sfcprop%facwf (IM)) + + Sfcprop%sncovr = clear_val + Sfcprop%snoalb = clear_val + Sfcprop%alvsf = clear_val + Sfcprop%alnsf = clear_val + Sfcprop%alvwf = clear_val + Sfcprop%alnwf = clear_val + Sfcprop%facsf = clear_val + Sfcprop%facwf = clear_val + + !--- physics surface props + !--- In + allocate (Sfcprop%slope (IM)) + allocate (Sfcprop%shdmin (IM)) + allocate (Sfcprop%shdmax (IM)) + allocate (Sfcprop%snoalb (IM)) + allocate (Sfcprop%tg3 (IM)) + allocate (Sfcprop%vfrac (IM)) + allocate (Sfcprop%vtype (IM)) + allocate (Sfcprop%stype (IM)) + allocate (Sfcprop%uustar (IM)) + allocate (Sfcprop%oro (IM)) + allocate (Sfcprop%oro_uf (IM)) + + Sfcprop%slope = clear_val + Sfcprop%shdmin = clear_val + Sfcprop%shdmax = clear_val + Sfcprop%snoalb = clear_val + Sfcprop%tg3 = clear_val + Sfcprop%vfrac = clear_val + Sfcprop%vtype = clear_val + Sfcprop%stype = clear_val + Sfcprop%uustar = clear_val + Sfcprop%oro = clear_val + Sfcprop%oro_uf = clear_val + + if (Model%myj_pbl) then + allocate (Sfcprop%QZ0 (IM)) + allocate (Sfcprop%THZ0 (IM)) + allocate (Sfcprop%UZ0 (IM)) + allocate (Sfcprop%VZ0 (IM)) + + Sfcprop%QZ0 = clear_val + Sfcprop%THZ0 = clear_val + Sfcprop%UZ0 = clear_val + Sfcprop%VZ0 = clear_val + endif + + !--- In/Out + allocate (Sfcprop%hice (IM)) + allocate (Sfcprop%weasd (IM)) + allocate (Sfcprop%sncovr (IM)) + allocate (Sfcprop%canopy (IM)) + allocate (Sfcprop%ffmm (IM)) + allocate (Sfcprop%ffhh (IM)) + allocate (Sfcprop%f10m (IM)) + allocate (Sfcprop%tprcp (IM)) + allocate (Sfcprop%srflag (IM)) + allocate (Sfcprop%slc (IM,Model%lsoil)) + allocate (Sfcprop%smc (IM,Model%lsoil)) + allocate (Sfcprop%stc (IM,Model%lsoil)) + + Sfcprop%hice = clear_val + Sfcprop%weasd = clear_val + Sfcprop%sncovr = clear_val + Sfcprop%canopy = clear_val + Sfcprop%ffmm = clear_val + Sfcprop%ffhh = clear_val + Sfcprop%f10m = clear_val + Sfcprop%tprcp = clear_val + Sfcprop%srflag = clear_val + Sfcprop%slc = clear_val + Sfcprop%smc = clear_val + Sfcprop%stc = clear_val + + !--- Out + allocate (Sfcprop%t2m (IM)) + allocate (Sfcprop%q2m (IM)) + + Sfcprop%t2m = clear_val + Sfcprop%q2m = clear_val + + if (Model%nstf_name(1) > 0) then + allocate (Sfcprop%tref (IM)) + allocate (Sfcprop%z_c (IM)) + allocate (Sfcprop%c_0 (IM)) + allocate (Sfcprop%c_d (IM)) + allocate (Sfcprop%w_0 (IM)) + allocate (Sfcprop%w_d (IM)) + allocate (Sfcprop%xt (IM)) + allocate (Sfcprop%xs (IM)) + allocate (Sfcprop%xu (IM)) + allocate (Sfcprop%xv (IM)) + allocate (Sfcprop%xz (IM)) + allocate (Sfcprop%zm (IM)) + allocate (Sfcprop%xtts (IM)) + allocate (Sfcprop%xzts (IM)) + allocate (Sfcprop%d_conv (IM)) + allocate (Sfcprop%ifd (IM)) + allocate (Sfcprop%dt_cool(IM)) + allocate (Sfcprop%qrain (IM)) + + Sfcprop%tref = zero + Sfcprop%z_c = zero + Sfcprop%c_0 = zero + Sfcprop%c_d = zero + Sfcprop%w_0 = zero + Sfcprop%w_d = zero + Sfcprop%xt = zero + Sfcprop%xs = zero + Sfcprop%xu = zero + Sfcprop%xv = zero + Sfcprop%xz = zero + Sfcprop%zm = zero + Sfcprop%xtts = zero + Sfcprop%xzts = zero + Sfcprop%d_conv = zero + Sfcprop%ifd = zero + Sfcprop%dt_cool = zero + Sfcprop%qrain = zero + endif + + if (Model%lsm == Model%lsm_noahmp ) then + +! Noah MP allocate and init when used +! + + allocate (Sfcprop%snowxy (IM)) + allocate (Sfcprop%tvxy (IM)) + allocate (Sfcprop%tgxy (IM)) + allocate (Sfcprop%canicexy (IM)) + allocate (Sfcprop%canliqxy (IM)) + allocate (Sfcprop%eahxy (IM)) + allocate (Sfcprop%tahxy (IM)) + allocate (Sfcprop%cmxy (IM)) + allocate (Sfcprop%chxy (IM)) + allocate (Sfcprop%fwetxy (IM)) + allocate (Sfcprop%sneqvoxy (IM)) + allocate (Sfcprop%alboldxy (IM)) + allocate (Sfcprop%qsnowxy (IM)) + allocate (Sfcprop%wslakexy (IM)) + allocate (Sfcprop%zwtxy (IM)) + allocate (Sfcprop%waxy (IM)) + allocate (Sfcprop%wtxy (IM)) + allocate (Sfcprop%lfmassxy (IM)) + allocate (Sfcprop%rtmassxy (IM)) + allocate (Sfcprop%stmassxy (IM)) + allocate (Sfcprop%woodxy (IM)) + allocate (Sfcprop%stblcpxy (IM)) + allocate (Sfcprop%fastcpxy (IM)) + allocate (Sfcprop%xsaixy (IM)) + allocate (Sfcprop%xlaixy (IM)) + allocate (Sfcprop%taussxy (IM)) + allocate (Sfcprop%smcwtdxy (IM)) + allocate (Sfcprop%deeprechxy (IM)) + allocate (Sfcprop%rechxy (IM)) + allocate (Sfcprop%albdvis (IM)) + allocate (Sfcprop%albdnir (IM)) + allocate (Sfcprop%albivis (IM)) + allocate (Sfcprop%albinir (IM)) + allocate (Sfcprop%emiss (IM)) + allocate (Sfcprop%snicexy (IM,-2:0)) + allocate (Sfcprop%snliqxy (IM,-2:0)) + allocate (Sfcprop%tsnoxy (IM,-2:0)) + allocate (Sfcprop%smoiseq (IM, 1:4)) + allocate (Sfcprop%zsnsoxy (IM,-2:4)) + + Sfcprop%snowxy = clear_val + Sfcprop%tvxy = clear_val + Sfcprop%tgxy = clear_val + Sfcprop%canicexy = clear_val + Sfcprop%canliqxy = clear_val + Sfcprop%eahxy = clear_val + Sfcprop%tahxy = clear_val + Sfcprop%cmxy = clear_val + Sfcprop%chxy = clear_val + Sfcprop%fwetxy = clear_val + Sfcprop%sneqvoxy = clear_val + Sfcprop%alboldxy = clear_val + Sfcprop%qsnowxy = clear_val + Sfcprop%wslakexy = clear_val + Sfcprop%zwtxy = clear_val + Sfcprop%waxy = clear_val + Sfcprop%wtxy = clear_val + Sfcprop%lfmassxy = clear_val + Sfcprop%rtmassxy = clear_val + Sfcprop%stmassxy = clear_val + Sfcprop%woodxy = clear_val + Sfcprop%stblcpxy = clear_val + Sfcprop%fastcpxy = clear_val + Sfcprop%xsaixy = clear_val + Sfcprop%xlaixy = clear_val + Sfcprop%taussxy = clear_val + Sfcprop%smcwtdxy = clear_val + Sfcprop%deeprechxy = clear_val + Sfcprop%rechxy = clear_val + Sfcprop%albdvis = clear_val + Sfcprop%albdnir = clear_val + Sfcprop%albivis = clear_val + Sfcprop%albinir = clear_val + Sfcprop%emiss = clear_val + + Sfcprop%snicexy = clear_val + Sfcprop%snliqxy = clear_val + Sfcprop%tsnoxy = clear_val + Sfcprop%smoiseq = clear_val + Sfcprop%zsnsoxy = clear_val + + allocate(Sfcprop%draincprv (IM)) + allocate(Sfcprop%drainncprv (IM)) + allocate(Sfcprop%diceprv (IM)) + allocate(Sfcprop%dsnowprv (IM)) + allocate(Sfcprop%dgraupelprv(IM)) + + Sfcprop%draincprv = clear_val + Sfcprop%drainncprv = clear_val + Sfcprop%diceprv = clear_val + Sfcprop%dsnowprv = clear_val + Sfcprop%dgraupelprv = clear_val + + + + end if + + + + + end subroutine sfcprop_create + + +!------------------------- +! GFS_coupling_type%create +!------------------------- + subroutine coupling_create (Coupling, IM, Model) + + implicit none + + class(GFS_coupling_type) :: Coupling + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + !--- radiation out + !--- physics in + allocate (Coupling%nirbmdi (IM)) + allocate (Coupling%nirdfdi (IM)) + allocate (Coupling%visbmdi (IM)) + allocate (Coupling%visdfdi (IM)) + allocate (Coupling%nirbmui (IM)) + allocate (Coupling%nirdfui (IM)) + allocate (Coupling%visbmui (IM)) + allocate (Coupling%visdfui (IM)) + + Coupling%nirbmdi = clear_val + Coupling%nirdfdi = clear_val + Coupling%visbmdi = clear_val + Coupling%visdfdi = clear_val + Coupling%nirbmui = clear_val + Coupling%nirdfui = clear_val + Coupling%visbmui = clear_val + Coupling%visdfui = clear_val + + allocate (Coupling%sfcdsw (IM)) + allocate (Coupling%sfcnsw (IM)) + allocate (Coupling%sfcdlw (IM)) + + Coupling%sfcdsw = clear_val + Coupling%sfcnsw = clear_val + Coupling%sfcdlw = clear_val + + if (Model%cplflx .or. Model%do_sppt) then + allocate (Coupling%rain_cpl (IM)) + allocate (Coupling%snow_cpl (IM)) + + Coupling%rain_cpl = clear_val + Coupling%snow_cpl = clear_val + endif + + if (Model%cplflx) then + !--- incoming quantities + allocate (Coupling%slimskin_cpl (IM)) + allocate (Coupling%dusfcin_cpl (IM)) + allocate (Coupling%dvsfcin_cpl (IM)) + allocate (Coupling%dtsfcin_cpl (IM)) + allocate (Coupling%dqsfcin_cpl (IM)) + allocate (Coupling%ulwsfcin_cpl (IM)) + + Coupling%slimskin_cpl = clear_val + Coupling%dusfcin_cpl = clear_val + Coupling%dvsfcin_cpl = clear_val + Coupling%dtsfcin_cpl = clear_val + Coupling%dqsfcin_cpl = clear_val + Coupling%ulwsfcin_cpl = clear_val + + !--- accumulated quantities + allocate (Coupling%dusfc_cpl (IM)) + allocate (Coupling%dvsfc_cpl (IM)) + allocate (Coupling%dtsfc_cpl (IM)) + allocate (Coupling%dqsfc_cpl (IM)) + allocate (Coupling%dlwsfc_cpl (IM)) + allocate (Coupling%dswsfc_cpl (IM)) + allocate (Coupling%dnirbm_cpl (IM)) + allocate (Coupling%dnirdf_cpl (IM)) + allocate (Coupling%dvisbm_cpl (IM)) + allocate (Coupling%dvisdf_cpl (IM)) + allocate (Coupling%nlwsfc_cpl (IM)) + allocate (Coupling%nswsfc_cpl (IM)) + allocate (Coupling%nnirbm_cpl (IM)) + allocate (Coupling%nnirdf_cpl (IM)) + allocate (Coupling%nvisbm_cpl (IM)) + allocate (Coupling%nvisdf_cpl (IM)) + + Coupling%dusfc_cpl = clear_val + Coupling%dvsfc_cpl = clear_val + Coupling%dtsfc_cpl = clear_val + Coupling%dqsfc_cpl = clear_val + Coupling%dlwsfc_cpl = clear_val + Coupling%dswsfc_cpl = clear_val + Coupling%dnirbm_cpl = clear_val + Coupling%dnirdf_cpl = clear_val + Coupling%dvisbm_cpl = clear_val + Coupling%dvisdf_cpl = clear_val + Coupling%nlwsfc_cpl = clear_val + Coupling%nswsfc_cpl = clear_val + Coupling%nnirbm_cpl = clear_val + Coupling%nnirdf_cpl = clear_val + Coupling%nvisbm_cpl = clear_val + Coupling%nvisdf_cpl = clear_val + + !--- instantaneous quantities + allocate (Coupling%dusfci_cpl (IM)) + allocate (Coupling%dvsfci_cpl (IM)) + allocate (Coupling%dtsfci_cpl (IM)) + allocate (Coupling%dqsfci_cpl (IM)) + allocate (Coupling%dlwsfci_cpl (IM)) + allocate (Coupling%dswsfci_cpl (IM)) + allocate (Coupling%dnirbmi_cpl (IM)) + allocate (Coupling%dnirdfi_cpl (IM)) + allocate (Coupling%dvisbmi_cpl (IM)) + allocate (Coupling%dvisdfi_cpl (IM)) + allocate (Coupling%nlwsfci_cpl (IM)) + allocate (Coupling%nswsfci_cpl (IM)) + allocate (Coupling%nnirbmi_cpl (IM)) + allocate (Coupling%nnirdfi_cpl (IM)) + allocate (Coupling%nvisbmi_cpl (IM)) + allocate (Coupling%nvisdfi_cpl (IM)) + allocate (Coupling%t2mi_cpl (IM)) + allocate (Coupling%q2mi_cpl (IM)) + allocate (Coupling%u10mi_cpl (IM)) + allocate (Coupling%v10mi_cpl (IM)) + allocate (Coupling%tsfci_cpl (IM)) + allocate (Coupling%psurfi_cpl (IM)) + allocate (Coupling%oro_cpl (IM)) + allocate (Coupling%slmsk_cpl (IM)) + + Coupling%dusfci_cpl = clear_val + Coupling%dvsfci_cpl = clear_val + Coupling%dtsfci_cpl = clear_val + Coupling%dqsfci_cpl = clear_val + Coupling%dlwsfci_cpl = clear_val + Coupling%dswsfci_cpl = clear_val + Coupling%dnirbmi_cpl = clear_val + Coupling%dnirdfi_cpl = clear_val + Coupling%dvisbmi_cpl = clear_val + Coupling%dvisdfi_cpl = clear_val + Coupling%nlwsfci_cpl = clear_val + Coupling%nswsfci_cpl = clear_val + Coupling%nnirbmi_cpl = clear_val + Coupling%nnirdfi_cpl = clear_val + Coupling%nvisbmi_cpl = clear_val + Coupling%nvisdfi_cpl = clear_val + Coupling%t2mi_cpl = clear_val + Coupling%q2mi_cpl = clear_val + Coupling%u10mi_cpl = clear_val + Coupling%v10mi_cpl = clear_val + Coupling%tsfci_cpl = clear_val + Coupling%psurfi_cpl = clear_val +!! Coupling%oro_cpl = clear_val !< pointer to sfcprop%oro +!! Coupling%slmsk_cpl = clear_val !< pointer to sfcprop%slmsk + endif + + + !-- cellular automata + if (Model%do_ca) then + allocate (Coupling%tconvtend (IM,Model%levs)) + allocate (Coupling%qconvtend (IM,Model%levs)) + allocate (Coupling%uconvtend (IM,Model%levs)) + allocate (Coupling%vconvtend (IM,Model%levs)) + allocate (Coupling%cape (IM)) + allocate (Coupling%ca_out (IM)) + allocate (Coupling%ca_deep (IM)) + allocate (Coupling%ca_turb (IM)) + allocate (Coupling%ca_shal (IM)) + allocate (Coupling%ca_rad (IM)) + allocate (Coupling%ca_micro (IM)) + Coupling%ca_out = clear_val + Coupling%ca_deep = clear_val + Coupling%ca_turb = clear_val + Coupling%ca_shal = clear_val + Coupling%ca_rad = clear_val + Coupling%ca_micro = clear_val + Coupling%cape = clear_val + Coupling%tconvtend = clear_val + Coupling%qconvtend = clear_val + Coupling%uconvtend = clear_val + Coupling%vconvtend = clear_val + endif + + + !--- stochastic physics option + if (Model%do_sppt) then + allocate (Coupling%sppt_wts (IM,Model%levs)) + Coupling%sppt_wts = clear_val + endif + + !--- stochastic shum option + if (Model%do_shum) then + allocate (Coupling%shum_wts (IM,Model%levs)) + Coupling%shum_wts = clear_val + endif + + !--- stochastic skeb option + if (Model%do_skeb) then + allocate (Coupling%skebu_wts (IM,Model%levs)) + allocate (Coupling%skebv_wts (IM,Model%levs)) + + Coupling%skebu_wts = clear_val + Coupling%skebv_wts = clear_val + endif + +!--- stochastic physics option + if (Model%do_sfcperts) then + allocate (Coupling%sfc_wts (IM,Model%nsfcpert)) + Coupling%sfc_wts = clear_val + endif + + !--- needed for either GoCart or 3D diagnostics + if (Model%lgocart .or. Model%ldiag3d) then + allocate (Coupling%dqdti (IM,Model%levs)) + allocate (Coupling%cnvqci (IM,Model%levs)) + allocate (Coupling%upd_mfi (IM,Model%levs)) + allocate (Coupling%dwn_mfi (IM,Model%levs)) + allocate (Coupling%det_mfi (IM,Model%levs)) + + Coupling%dqdti = clear_val + Coupling%cnvqci = clear_val + Coupling%upd_mfi = clear_val + Coupling%dwn_mfi = clear_val + Coupling%det_mfi = clear_val + endif + + end subroutine coupling_create + + +!---------------------- +! GFS_control_type%init +!---------------------- + subroutine control_initialize (Model, nlunit, fn_nml, me, master, & + logunit, isc, jsc, nx, ny, levs, & + cnx, cny, gnx, gny, dt_dycore, & + dt_phys, idat, jdat, iau_offset, & + tracer_names, input_nml_file, & + tile_num, blksz) + + !--- modules + use physcons, only: max_lon, max_lat, min_lon, min_lat, & + dxmax, dxmin, dxinv, con_rerth, con_pi + use mersenne_twister, only: random_setseed, random_number + use module_ras, only: nrcmax + use parse_tracers, only: get_tracer_index + use wam_f107_kp_mod, only: f107_kp_size, f107_kp_interval, & + f107_kp_skip_size, f107_kp_data_size + implicit none + + !--- interface variables + class(GFS_control_type) :: Model + integer, intent(in) :: nlunit + character(len=64), intent(in) :: fn_nml + integer, intent(in) :: me + integer, intent(in) :: master + integer, intent(in) :: logunit + integer, intent(in) :: tile_num + integer, intent(in) :: isc + integer, intent(in) :: jsc + integer, intent(in) :: nx + integer, intent(in) :: ny + integer, intent(in) :: levs + integer, intent(in) :: cnx + integer, intent(in) :: cny + integer, intent(in) :: gnx + integer, intent(in) :: gny + real(kind=kind_phys), intent(in) :: dt_dycore + real(kind=kind_phys), intent(in) :: dt_phys + integer, intent(in) :: iau_offset + integer, intent(in) :: idat(8) + integer, intent(in) :: jdat(8) + character(len=32), intent(in) :: tracer_names(:) + character(len=:), intent(in), dimension(:), pointer :: input_nml_file + integer, intent(in) :: blksz(:) + !--- local variables + integer :: n, i, j + integer :: ios + integer :: seed0 + logical :: exists + real(kind=kind_phys) :: tem + real(kind=kind_phys) :: rinc(5) + real(kind=kind_evod) :: wrk(1) + real(kind=kind_phys), parameter :: con_hr = 3600. + + !--- BEGIN NAMELIST VARIABLES + real(kind=kind_phys) :: fhzero = 0.0 !< seconds between clearing of diagnostic buckets + logical :: ldiag3d = .false. !< flag for 3d diagnostic fields + logical :: lssav = .false. !< logical flag for storing diagnostics + real(kind=kind_phys) :: fhcyc = 0. !< frequency for surface data cycling (secs) + logical :: lgocart = .false. !< flag for 3d diagnostic fields for gocart 1 + real(kind=kind_phys) :: fhgoc3d = 0.0 !< seconds between calls to gocart + integer :: thermodyn_id = 1 !< valid for GFS only for get_prs/phi + integer :: sfcpress_id = 1 !< valid for GFS only for get_prs/phi + logical :: sfc_override = .false. !< use idealized surface conditions + + !--- coupling parameters + logical :: cplflx = .false. !< default no cplflx collection + logical :: cplwav = .false. !< default no cplwav collection + + !--- integrated dynamics through earth's atmosphere + logical :: lsidea = .false. + + !--- radiation parameters + real(kind=kind_phys) :: fhswr = 3600. !< frequency for shortwave radiation (secs) + real(kind=kind_phys) :: fhlwr = 3600. !< frequency for longwave radiation (secs) + integer :: levr = -99 !< number of vertical levels for radiation calculations + integer :: nfxr = 39 !< second dimension of input/output array fluxr + integer :: nkld = 8 !< second dimension of input/output array fluxr + logical :: aero_in = .false. !< flag for initializing aero data + integer :: iflip = 1 !< iflip - is not the same as flipv + integer :: isol = 0 !< use prescribed solar constant + integer :: ico2 = 0 !< prescribed global mean value (old opernl) + integer :: ialb = 0 !< use climatology alb, based on sfc type + !< 1 => use modis based alb + integer :: iems = 0 !< use fixed value of 1.0 + integer :: iaer = 1 !< default aerosol effect in sw only + integer :: iovr_sw = 1 !< sw: max-random overlap clouds + integer :: iovr_lw = 1 !< lw: max-random overlap clouds + integer :: ictm = 1 !< ictm=0 => use data at initial cond time, if not + !< available; use latest; no extrapolation. + !< ictm=1 => use data at the forecast time, if not + !< available; use latest; do extrapolation. + !< ictm=yyyy0 => use yyyy data for the forecast time; + !< no extrapolation. + !< ictm=yyyy1 = > use yyyy data for the fcst. If needed, + !< do extrapolation to match the fcst time. + !< ictm=-1 => use user provided external data for + !< the fcst time; no extrapolation. + !< ictm=-2 => same as ictm=0, but add seasonal cycle + !< from climatology; no extrapolation. + integer :: isubc_sw = 0 !< sw clouds without sub-grid approximation + integer :: isubc_lw = 0 !< lw clouds without sub-grid approximation + !< =1 => sub-grid cloud with prescribed seeds + !< =2 => sub-grid cloud with randomly generated + !< seeds + logical :: crick_proof = .false. !< CRICK-Proof cloud water + logical :: ccnorm = .false. !< Cloud condensate normalized by cloud cover + logical :: norad_precip = .false. !< radiation precip flag for Ferrier/Moorthi + logical :: lwhtr = .true. !< flag to output lw heating rate (Radtend%lwhc) + logical :: swhtr = .true. !< flag to output sw heating rate (Radtend%swhc) + logical :: fixed_date = .false. !< flag to fix astronomy (not solar angle) to initial date + logical :: fixed_solhr = .false. !< flag to fix solar angle to initial time + logical :: daily_mean = .false. !< flag to replace cosz with daily mean value + + !--- GFDL microphysical parameters + logical :: do_inline_mp = .false. !< flag for GFDL cloud microphysics + + !--- Z-C microphysical parameters + integer :: ncld = 1 !< cnoice of cloud scheme + logical :: zhao_mic = .false. !< flag for Zhao-Carr microphysics + real(kind=kind_phys) :: psautco(2) = (/6.0d-4,3.0d-4/) !< [in] auto conversion coeff from ice to snow + real(kind=kind_phys) :: prautco(2) = (/1.0d-4,1.0d-4/) !< [in] auto conversion coeff from cloud to rain + real(kind=kind_phys) :: evpco = 2.0d-5 !< [in] coeff for evaporation of largescale rain + real(kind=kind_phys) :: wminco(2) = (/1.0d-5,1.0d-5/) !< [in] water and ice minimum threshold for Zhao + + !--- M-G microphysical parameters + integer :: fprcp = 0 !< no prognostic rain and snow (MG) + real(kind=kind_phys) :: mg_dcs = 350.0 !< Morrison-Gettleman microphysics parameters + real(kind=kind_phys) :: mg_qcvar = 2.0 + real(kind=kind_phys) :: mg_ts_auto_ice = 3600.0 !< ice auto conversion time scale + + !--- land/surface model parameters + integer :: lsm = 1 !< flag for land surface model to use =0 for osu lsm; =1 for noah lsm + integer :: lsoil = 4 !< number of soil layers + integer :: ivegsrc = 2 !< ivegsrc = 0 => USGS, + !< ivegsrc = 1 => IGBP (20 category) + !< ivegsrc = 2 => UMD (13 category) + integer :: isot = 0 !< isot = 0 => Zobler soil type ( 9 category) + !< isot = 1 => STATSGO soil type (19 category) + logical :: mom4ice = .false. !< flag controls mom4 sea ice + logical :: use_ufo = .false. !< flag for gcycle surface option + real(kind=kind_phys) :: czil_sfc = 0.8 !< Zilintkivitch constant + + ! -- to use Noah MP, lsm needs to be set to 2 and both ivegsrc and isot are set + ! to 1 - MODIS IGBP and STATSGO - the defaults are the same as in the + ! scripts;change from namelist + + integer :: iopt_dveg = 4 ! 4 -> off (use table lai; use maximum vegetation fraction) + integer :: iopt_crs = 1 !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer :: iopt_btr = 1 !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer :: iopt_run = 3 !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer :: iopt_sfc = 1 !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer :: iopt_frz = 1 !supercooled liquid water (1-> ny06; 2->koren99) + integer :: iopt_inf = 1 !frozen soil permeability (1-> ny06; 2->koren99) + integer :: iopt_rad = 3 !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer :: iopt_alb = 2 !snow surface albedo (1->bats; 2->class) + integer :: iopt_snf = 1 !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer :: iopt_tbot = 2 !lower boundary of soil temperature (1->zero-flux; 2->noah) + integer :: iopt_stc = 1 !snow/soil temperature time scheme (only layer 1) + + !--- tuning parameters for physical parameterizations + logical :: ras = .false. !< flag for ras convection scheme + logical :: flipv = .true. !< flag for vertical direction flip (ras) + !< .true. implies surface at k=1 + logical :: trans_trac = .false. !< flag for convective transport of tracers (RAS only) + logical :: old_monin = .false. !< flag for diff monin schemes + logical :: orogwd = .true. !< flag for oro gravity wave drag + logical :: cnvgwd = .false. !< flag for conv gravity wave drag + logical :: mstrat = .false. !< flag for moorthi approach for stratus + logical :: moist_adj = .false. !< flag for moist convective adjustment + logical :: cscnv = .false. !< flag for Chikira-Sugiyama convection + logical :: cal_pre = .false. !< flag controls precip type algorithm + logical :: do_aw = .false. !< AW scale-aware option in cs convection + logical :: do_shoc = .false. !< flag for SHOC + logical :: shocaftcnv = .false. !< flag for SHOC + logical :: shoc_cld = .false. !< flag for SHOC in grrad + logical :: h2o_phys = .false. !< flag for stratosphere h2o + logical :: pdfcld = .false. !< flag for pdfcld + logical :: shcnvcw = .false. !< flag for shallow convective cloud + logical :: redrag = .false. !< flag for reduced drag coeff. over sea + logical :: sfc_gfdl = .false. !< flag for using new sfc layer scheme by kgao at GFDL + real(kind=kind_phys) :: z0s_max = .317e-2 !< a limiting value for z0 under high winds + logical :: do_z0_moon = .false. !< flag for using z0 scheme in Moon et al. 2007 + logical :: do_z0_hwrf15 = .false. !< flag for using z0 scheme in 2015 HWRF + logical :: do_z0_hwrf17 = .false. !< flag for using z0 scheme in 2017 HWRF + logical :: do_z0_hwrf17_hwonly = .false. !< flag for using z0 scheme in 2017 HWRF only under high wind + real(kind=kind_phys) :: wind_th_hwrf = 33. !< wind speed threshold when z0 level off as in HWRF + logical :: hybedmf = .false. !< flag for hybrid edmf pbl scheme + logical :: myj_pbl = .false. !< flag for NAM MYJ tke-based scheme + logical :: ysupbl = .false. !< flag for hybrid edmf pbl scheme + logical :: satmedmf = .false. !< flag for scale-aware TKE-based moist edmf + !< vertical turbulent mixing scheme + logical :: no_pbl = .false. !< disable PBL (for LES) + logical :: cap_k0_land = .true. !< flag for applying limter on background diff in inversion + logical :: do_dk_hb19 = .false. !< flag for using hb19 formula for background diff + logical :: dspheat = .false. !< flag for tke dissipative heating + logical :: lheatstrg = .false. !< flag for canopy heat storage parameterization + real(kind=kind_phys) :: hour_canopy = 0.0d0 !< tunable time scale for canopy heat storage parameterization + real(kind=kind_phys) :: afac_canopy = 1.0d0 !< tunable enhancement factor for canopy heat storage parameterization + real(kind=kind_phys) :: xkzm_m = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum over ocean + real(kind=kind_phys) :: xkzm_h = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q over ocean + real(kind=kind_phys) :: xkzm_ml = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum over land + real(kind=kind_phys) :: xkzm_hl = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q over land + real(kind=kind_phys) :: xkzm_mi = 1.0d0 !< [in] bkgd_vdif_m background vertical diffusion for momentum over ice + real(kind=kind_phys) :: xkzm_hi = 1.0d0 !< [in] bkgd_vdif_h background vertical diffusion for heat q over ice + real(kind=kind_phys) :: xkzm_s = 1.0d0 !< [in] bkgd_vdif_s sigma threshold for background mom. diffusion + real(kind=kind_phys) :: xkzm_lim = 0.01 !< [in] background vertical diffusion limit + real(kind=kind_phys) :: xkzm_fac = 1.0 !< [in] background vertical diffusion factor + real(kind=kind_phys) :: xkzminv = 0.15 !< diffusivity in inversion layers + real(kind=kind_phys) :: xkgdx = 25.e3 !< [in] background vertical diffusion threshold + real(kind=kind_phys) :: rlmn = 30. !< [in] lower-limter on asymtotic mixing length in satmedmfdiff.f + real(kind=kind_phys) :: rlmx = 300. !< [in] upper-limter on asymtotic mixing length in satmedmfdiff.f + real(kind=kind_phys) :: zolcru = -0.02 !< [in] a threshold for activating the surface-driven updraft transports in satmedmfdifq.f + real(kind=kind_phys) :: cs0 = 0.2 !< [in] a parameter that controls the shear effect on the mixing length in satmedmfdifq.f + real(kind=kind_phys) :: moninq_fac = 1.0 !< turbulence diffusion coefficient factor + real(kind=kind_phys) :: dspfac = 1.0 !< tke dissipative heating factor + real(kind=kind_phys) :: bl_upfr = 0.13 !< updraft fraction in boundary layer mass flux scheme + real(kind=kind_phys) :: bl_dnfr = 0.1 !< downdraft fraction in boundary layer mass flux scheme + real(kind=kind_phys) :: ysu_ent_fac = 0.15 !< Entrainment factor in YSU scheme + real(kind=kind_phys) :: ysu_pfac_q = 2.0 !< Exponent in scalar vertical mixing + real(kind=kind_phys) :: ysu_brcr_ub = 0.0 + real(kind=kind_phys) :: ysu_rlam = 30.0 + real(kind=kind_phys) :: ysu_afac = 6.8 + real(kind=kind_phys) :: ysu_bfac = 6.8 + real(kind=kind_phys) :: ysu_hpbl_cr = 0.0 + real(kind=kind_phys) :: tnl_fac = 1.0 + real(kind=kind_phys) :: qnl_fac = 1.0 + real(kind=kind_phys) :: unl_fac = 1.0 + logical :: cnvcld = .false. + logical :: cloud_gfdl = .false. !< flag for GFDL cloud radii scheme + logical :: random_clds = .false. !< flag controls whether clouds are random + logical :: shal_cnv = .true. !< flag for calling shallow convection + integer :: imfshalcnv = 1 !< flag for mass-flux shallow convection scheme + !< 1: July 2010 version of mass-flux shallow conv scheme + !< current operational version as of 2016 + !< 2: scale- & aerosol-aware mass-flux shallow conv scheme (2017) + !< 3: scale- & aerosol-aware mass-flux shallow conv scheme (2020) + !< 0: modified Tiedtke's eddy-diffusion shallow conv scheme + !< -1: no shallow convection used + integer :: imfdeepcnv = 1 !< flag for mass-flux deep convection scheme + !< 1: July 2010 version of SAS conv scheme + !< current operational version as of 2016 + !< 2: scale- & aerosol-aware mass-flux deep conv scheme (2017) + !< 3: scale- & aerosol-aware mass-flux deep conv scheme (2020) + integer :: isatmedmf = 0 !< flag for scale-aware TKE-based moist edmf scheme + logical :: do_deep = .true. !< whether to do deep convection + integer :: nmtvr = 14 !< number of topographic variables such as variance etc + !< used in the GWD parameterization + integer :: jcap = 1 !< number of spectral wave trancation used only by sascnv shalcnv + real(kind=kind_phys) :: cs_parm(10) = (/5.0,2.5,1.0e3,3.0e3,20.0,-999.,-999.,0.,0.,0./) + real(kind=kind_phys) :: flgmin(2) = (/0.180,0.220/) !< [in] ice fraction bounds + real(kind=kind_phys) :: cgwf(2) = (/0.5d0,0.05d0/) !< multiplication factor for convective GWD + real(kind=kind_phys) :: ccwf(2) = (/1.0d0,1.0d0/) !< multiplication factor for critical cloud + !< workfunction for RAS + real(kind=kind_phys) :: cdmbgwd(2) = (/2.0d0,0.25d0/) !< multiplication factors for cdmb and gwd + real(kind=kind_phys) :: gwd_p_crit = 0. !< Optional level above which GWD stress decays with height + real(kind=kind_phys) :: sup = 1.1 !< supersaturation in pdf cloud when t is very low + real(kind=kind_phys) :: ctei_rm(2) = (/10.0d0,10.0d0/) !< critical cloud top entrainment instability criteria + !< (used if mstrat=.true.) + real(kind=kind_phys) :: crtrh(3) = (/0.90d0,0.90d0,0.90d0/) !< critical relative humidity at the surface + !< PBL top and at the top of the atmosphere + real(kind=kind_phys) :: dlqf(2) = (/0.0d0,0.0d0/) !< factor for cloud condensate detrainment + !< from cloud edges for RAS + real(kind=kind_phys) :: rbcr = 0.25 !< Critical Richardson Number in PBL scheme + logical :: mix_precip = .true. !< Whether to apply PBL mixing to precipitating hydrometeors + + !--- Rayleigh friction + real(kind=kind_phys) :: prslrd0 = 0.0d0 !< pressure level from which Rayleigh Damping is applied + real(kind=kind_phys) :: ral_ts = 0.0d0 !< time scale for Rayleigh damping in days + + !--- mass flux deep convection + logical :: ext_rain_deep = .false. !< Whether to extract rain water from the deep convection + real(kind=kind_phys) :: clam_deep = 0.1 !< c_e for deep convection (Han and Pan, 2011, eq(6)) + real(kind=kind_phys) :: c0s_deep = 0.002 !< conversion parameter of detrainment from liquid water into convetive precipitaiton + real(kind=kind_phys) :: c1_deep = 0.002 !< conversion parameter of detrainment from liquid water into grid-scale cloud water + real(kind=kind_phys) :: betal_deep = 0.05 !< downdraft heat flux contribution over land + real(kind=kind_phys) :: betas_deep = 0.05 !< downdraft heat flux contribution over ocean + real(kind=kind_phys) :: evfact_deep = 0.3 !< evaporation factor + real(kind=kind_phys) :: evfactl_deep = 0.3 !< evaporation factor over land + real(kind=kind_phys) :: pgcon_deep = 0.55 !< control the reduction in momentum transport + !< 0.7 : Gregory et al. (1997, QJRMS) + !< 0.55: Zhang & Wu (2003, JAS) + real(kind=kind_phys) :: asolfac_deep = 0.89 !< aerosol-aware parameter based on Lim & Hong (2012) + !< asolfac= cx / c0s(=.002) + !< cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) + !< Nccn: CCN number concentration in cm^(-3) + !< Until a realistic Nccn is provided, typical Nccns are assumed + !< as Nccn=100 for sea and Nccn=7000 for land + + !--- mass flux shallow convection + logical :: ext_rain_shal = .false. !< Whether to extract rain water from the shallow convection + real(kind=kind_phys) :: clam_shal = 0.3 !< c_e for shallow convection (Han and Pan, 2011, eq(6)) + real(kind=kind_phys) :: c0s_shal = 0.002 !< conversion parameter of detrainment from liquid water into convetive precipitaiton + real(kind=kind_phys) :: c1_shal = 5.e-4 !< conversion parameter of detrainment from liquid water into grid-scale cloud water + real(kind=kind_phys) :: pgcon_shal = 0.55 !< control the reduction in momentum transport + !< 0.7 : Gregory et al. (1997, QJRMS) + !< 0.55: Zhang & Wu (2003, JAS) + real(kind=kind_phys) :: asolfac_shal = 0.89 !< aerosol-aware parameter based on Lim & Hong (2012) + !< asolfac= cx / c0s(=.002) + !< cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) + !< Nccn: CCN number concentration in cm^(-3) + !< Until a realistic Nccn is provided, typical Nccns are assumed + !< as Nccn=100 for sea and Nccn=7000 for land + real(kind=kind_phys) :: evfact_shal = 0.3 !< rain evaporation efficiency over the ocean + real(kind=kind_phys) :: evfactl_shal = 0.3 !< rain evaporation efficiency over the land + + !--- near surface temperature model + logical :: nst_anl = .false. !< flag for NSSTM analysis in gcycle/sfcsub + integer :: lsea = 0 + integer :: nstf_name(5) = (/0,0,1,0,5/) !< flag 0 for no nst 1 for uncoupled nst and 2 for coupled NST + !< nstf_name contains the NSSTM related parameters + !< nstf_name(1) : 0 = NSSTM off, 1 = NSSTM on but uncoupled + !< 2 = NSSTM on and coupled + !< nstf_name(2) : 1 = NSSTM spin up on, 0 = NSSTM spin up off + !< nstf_name(3) : 1 = NSSTM analysis on, 0 = NSSTM analysis off + !< nstf_name(4) : zsea1 in mm + !< nstf_name(5) : zsea2 in mm + +!--- fractional grid + logical :: frac_grid = .false. !< flag for fractional grid + logical :: ignore_lake = .true. !< flag for ignoring lakes + real(kind=kind_phys) :: min_lakeice = 0.15d0 !< minimum lake ice value + real(kind=kind_phys) :: min_seaice = 1.0d-11 !< minimum sea ice value + real(kind=kind_phys) :: min_lake_height = 250.0 !< minimum lake height value + real(kind=kind_phys) :: rho_h2o = rhow !< fresh water density + + +!---Cellular automaton options + integer :: nca = 1 + integer :: ncells = 5 + integer :: nlives = 10 + real(kind=kind_phys) :: nfracseed = 0.5 + integer :: nseed = 100000 + integer :: iseed_ca = 0 + integer :: nspinup = 1 + logical :: do_ca = .false. + logical :: ca_sgs = .false. + logical :: ca_global = .false. + logical :: ca_smooth = .false. + logical :: isppt_deep = .false. + real(kind=kind_phys) :: nthresh = 0.0 + + + + !--- stochastic physics control parameters + logical :: do_sppt = .false. + logical :: use_zmtnblck = .false. ! if true, do not apply perturbations below the + ! dividing streamline diagnosed by + ! the gravity wave drag, mountain blocking scheme + logical :: do_shum = .false. + logical :: do_skeb = .false. + integer :: skeb_npass = 11 + logical :: do_sfcperts = .false. ! mg, sfc-perts + integer :: nsfcpert = 6 ! mg, sfc-perts + real(kind=kind_phys) :: pertz0 = -999. + real(kind=kind_phys) :: pertzt = -999. + real(kind=kind_phys) :: pertshc = -999. + real(kind=kind_phys) :: pertlai = -999. + real(kind=kind_phys) :: pertalb = -999. + real(kind=kind_phys) :: pertvegf = -999. + + !--- IAU options + real(kind=kind_phys) :: iau_delthrs = 0 !< iau time interval (to scale increments) + character(len=240) :: iau_inc_files(7) = '' !< list of increment files + character(len=32) :: iau_forcing_var(20) = '' !< list of tracers with IAU forcing + real(kind=kind_phys) :: iaufhrs(7) = -1 !< forecast hours associated with increment files + logical :: iau_filter_increments = .false. !< filter IAU increments + logical :: iau_drymassfixer = .false. !< IAU dry mass fixer + + !--- debug flag + logical :: debug = .false. + logical :: lprnt = .false. + logical :: pre_rad = .false. !< flag for testing purpose + logical :: do_ocean = .false. !< flag for slab ocean model + logical :: use_ext_sst = .false. !< flag for using external SST forcing (or any external SST dataset, passed from the dynamics or nudging) + +!--- aerosol scavenging factors + character(len=20) :: fscav_aero(20) = 'default' + + !--- END NAMELIST VARIABLES + + NAMELIST /gfs_physics_nml/ & + !--- general parameters + fhzero, ldiag3d, lssav, fhcyc, lgocart, fhgoc3d, & + thermodyn_id, sfcpress_id, sfc_override, & + !--- coupling parameters + cplflx, cplwav, lsidea, & + !--- radiation parameters + fhswr, fhlwr, levr, nfxr, aero_in, iflip, isol, ico2, ialb, & + isot, iems, iaer, iovr_sw, iovr_lw, ictm, isubc_sw, & + isubc_lw, crick_proof, ccnorm, lwhtr, swhtr, nkld, & + fixed_date, fixed_solhr, daily_mean, & + !--- microphysical parameterizations + ncld, do_inline_mp, zhao_mic, psautco, prautco, evpco, & + wminco, fprcp, mg_dcs, mg_qcvar, mg_ts_auto_ice, & + !--- land/surface model control + lsm, lsoil, nmtvr, ivegsrc, mom4ice, use_ufo, czil_sfc, & + ! Noah MP options + iopt_dveg,iopt_crs,iopt_btr,iopt_run,iopt_sfc, iopt_frz, & + iopt_inf, iopt_rad,iopt_alb,iopt_snf,iopt_tbot,iopt_stc, & + !--- physical parameterizations + ras, trans_trac, old_monin, cnvgwd, mstrat, moist_adj, & + cscnv, cal_pre, do_aw, do_shoc, shocaftcnv, shoc_cld, & + h2o_phys, pdfcld, shcnvcw, redrag, sfc_gfdl, z0s_max, & + do_z0_moon, do_z0_hwrf15, do_z0_hwrf17, & + do_z0_hwrf17_hwonly, wind_th_hwrf, & + hybedmf, dspheat, lheatstrg, hour_canopy, afac_canopy, & + cnvcld, no_pbl, xkzm_lim, xkzm_fac, xkgdx, & + rlmn, rlmx, zolcru, cs0, & + xkzm_m, xkzm_h, xkzm_ml, xkzm_hl, xkzm_mi, xkzm_hi, & + xkzm_s, xkzminv, moninq_fac, dspfac, & + bl_upfr, bl_dnfr, ysu_ent_fac, ysu_pfac_q, & + ysu_brcr_ub, ysu_rlam, ysu_afac, ysu_bfac, ysu_hpbl_cr, & + tnl_fac, qnl_fac, unl_fac, & + random_clds, shal_cnv, imfshalcnv, imfdeepcnv, isatmedmf, & + do_deep, jcap,& + cs_parm, flgmin, cgwf, ccwf, cdmbgwd, sup, ctei_rm, crtrh, & + dlqf,rbcr,mix_precip,orogwd,myj_pbl,ysupbl,satmedmf, & + cap_k0_land,do_dk_hb19,cloud_gfdl,gwd_p_crit, & + !--- Rayleigh friction + prslrd0, ral_ts, & + !--- mass flux deep convection + clam_deep, c0s_deep, c1_deep, betal_deep, & + betas_deep, evfact_deep, evfactl_deep, pgcon_deep, & + asolfac_deep, ext_rain_deep, & + !--- mass flux shallow convection + clam_shal, c0s_shal, c1_shal, pgcon_shal, asolfac_shal, & + ext_rain_shal, evfact_shal, evfactl_shal, & + !--- near surface temperature model + nst_anl, lsea, nstf_name, & + frac_grid, min_lakeice, min_seaice, min_lake_height, & + ignore_lake, & + !--- cellular automata + nca, ncells, nlives, nfracseed,nseed, nthresh, do_ca, & + ca_sgs, ca_global,iseed_ca,ca_smooth,isppt_deep,nspinup, & + !--- stochastic physics + do_sppt, do_shum, do_skeb, do_sfcperts, & + !--- IAU + iau_delthrs,iaufhrs,iau_inc_files,iau_forcing_var, & + iau_filter_increments,iau_drymassfixer, & + !--- debug options + debug, pre_rad, do_ocean, use_ext_sst, lprnt, & + !--- aerosol scavenging factors ('name:value' string array) + fscav_aero + + !--- other parameters + integer :: nctp = 0 !< number of cloud types in CS scheme + logical :: gen_coord_hybrid = .false. !< for Henry's gen coord + + !--- SHOC parameters + integer :: nshoc_2d = 0 !< number of 2d fields for SHOC + integer :: nshoc_3d = 0 !< number of 3d fields for SHOC + + !--- convective clouds + integer :: ncnvcld3d = 0 !< number of convective 3d clouds fields + + !--- read in the namelist +#ifdef INTERNAL_FILE_NML + allocate(Model%input_nml_file, mold=input_nml_file) + Model%input_nml_file => input_nml_file + read(Model%input_nml_file, nml=gfs_physics_nml) +#else + inquire (file=trim(fn_nml), exist=exists) + if (.not. exists) then + write(6,*) 'GFS_namelist_read:: namelist file: ',trim(fn_nml),' does not exist' + stop + else + open (unit=nlunit, file=fn_nml, READONLY, status='OLD', iostat=ios) + endif + rewind(nlunit) + read (nlunit, nml=gfs_physics_nml) + close (nlunit) +#endif + !--- write version number and namelist to log file --- + if (me == master) then + write(logunit, '(a80)') '================================================================================' + write(logunit, '(a64)') version + write(logunit, nml=gfs_physics_nml) + endif + + !--- MPI parameters + Model%me = me + Model%master = master + Model%nlunit = nlunit + Model%fn_nml = fn_nml + Model%fhzero = fhzero + Model%ldiag3d = ldiag3d + Model%lssav = lssav + Model%fhcyc = fhcyc + Model%lgocart = lgocart + Model%fhgoc3d = fhgoc3d + Model%thermodyn_id = thermodyn_id + Model%sfcpress_id = sfcpress_id + Model%gen_coord_hybrid = gen_coord_hybrid + Model%sfc_override = sfc_override + + !--- set some grid extent parameters + Model%tile_num = tile_num + Model%isc = isc + Model%jsc = jsc + Model%nx = nx + Model%ny = ny + Model%levs = levs + Model%cnx = cnx + Model%cny = cny + Model%lonr = gnx + Model%latr = gny + Model%nblks = size(blksz) + allocate(Model%blksz(1:Model%nblks)) + Model%blksz = blksz + + !--- coupling parameters + Model%cplflx = cplflx + Model%cplwav = cplwav + + !--- integrated dynamics through earth's atmosphere + Model%lsidea = lsidea + + !--- calendars and time parameters and activation triggers + Model%dtp = dt_phys + Model%dtf = dt_dycore + Model%nscyc = nint(fhcyc*3600./Model%dtp) + Model%nszero = nint(Model%fhzero*con_hr/Model%dtp) + Model%idat(1:8) = idat(1:8) + Model%idate = 0 + Model%idate(1) = Model%idat(5) + Model%idate(2) = Model%idat(2) + Model%idate(3) = Model%idat(3) + Model%idate(4) = Model%idat(1) + Model%iau_offset = iau_offset + + !--- radiation control parameters + Model%fhswr = fhswr + Model%fhlwr = fhlwr + Model%nsswr = nint(fhswr/Model%dtp) + Model%nslwr = nint(fhlwr/Model%dtp) + if (levr < 0) then + Model%levr = levs + else + Model%levr = levr + endif + Model%nfxr = nfxr + Model%nkld = nkld + Model%aero_in = aero_in + Model%iflip = iflip + Model%isol = isol + Model%ico2 = ico2 + Model%ialb = ialb + Model%iems = iems + Model%iaer = iaer + Model%iovr_sw = iovr_sw + Model%iovr_lw = iovr_lw + Model%ictm = ictm + Model%isubc_sw = isubc_sw + Model%isubc_lw = isubc_lw + Model%crick_proof = crick_proof + Model%ccnorm = ccnorm + Model%lwhtr = lwhtr + Model%swhtr = swhtr + Model%fixed_date = fixed_date + Model%fixed_solhr = fixed_solhr + Model%daily_mean = daily_mean + + !--- microphysical switch + Model%ncld = ncld + !--- GFDL microphysical parameters + Model%do_inline_mp = do_inline_mp + !--- Zhao-Carr MP parameters + Model%zhao_mic = zhao_mic + Model%psautco = psautco + Model%prautco = prautco + Model%evpco = evpco + Model%wminco = wminco + !--- Morroson-Gettleman MP parameters + Model%fprcp = fprcp + Model%mg_dcs = mg_dcs + Model%mg_qcvar = mg_qcvar + Model%mg_ts_auto_ice = mg_ts_auto_ice + + !--- land/surface model parameters + Model%lsm = lsm + Model%lsoil = lsoil + Model%ivegsrc = ivegsrc + Model%isot = isot + Model%mom4ice = mom4ice + Model%use_ufo = use_ufo + Model%czil_sfc = czil_sfc + +! Noah MP options from namelist +! + Model%iopt_dveg = iopt_dveg + Model%iopt_crs = iopt_crs + Model%iopt_btr = iopt_btr + Model%iopt_run = iopt_run + Model%iopt_sfc = iopt_sfc + Model%iopt_frz = iopt_frz + Model%iopt_inf = iopt_inf + Model%iopt_rad = iopt_rad + Model%iopt_alb = iopt_alb + Model%iopt_snf = iopt_snf + Model%iopt_tbot = iopt_tbot + Model%iopt_stc = iopt_stc + + + !--- tuning parameters for physical parameterizations + Model%ras = ras + Model%flipv = flipv + Model%trans_trac = trans_trac + Model%old_monin = old_monin + Model%orogwd = orogwd + Model%cnvgwd = cnvgwd + Model%mstrat = mstrat + Model%moist_adj = moist_adj + Model%cscnv = cscnv + Model%cal_pre = cal_pre + Model%do_aw = do_aw + Model%do_shoc = do_shoc + Model%shocaftcnv = shocaftcnv + Model%shoc_cld = shoc_cld + Model%h2o_phys = h2o_phys + Model%pdfcld = pdfcld + Model%shcnvcw = shcnvcw + Model%redrag = redrag + Model%sfc_gfdl = sfc_gfdl + Model%z0s_max = z0s_max + Model%do_z0_moon = do_z0_moon + Model%do_z0_hwrf15 = do_z0_hwrf15 + Model%do_z0_hwrf17 = do_z0_hwrf17 + Model%do_z0_hwrf17_hwonly = do_z0_hwrf17_hwonly + Model%wind_th_hwrf = wind_th_hwrf + Model%hybedmf = hybedmf + Model%myj_pbl = myj_pbl + Model%ysupbl = ysupbl + Model%satmedmf = satmedmf + Model%no_pbl = no_pbl + Model%cap_k0_land = cap_k0_land + Model%do_dk_hb19 = do_dk_hb19 + Model%dspheat = dspheat + Model%lheatstrg = lheatstrg + Model%hour_canopy = hour_canopy + Model%afac_canopy = afac_canopy + Model%xkzm_m = xkzm_m + Model%xkzm_h = xkzm_h + Model%xkzm_ml = xkzm_ml + Model%xkzm_hl = xkzm_hl + Model%xkzm_mi = xkzm_mi + Model%xkzm_hi = xkzm_hi + Model%xkzm_s = xkzm_s + Model%xkzm_lim = xkzm_lim + Model%xkzm_fac = xkzm_fac + Model%xkzminv = xkzminv + Model%xkgdx = xkgdx + Model%rlmn = rlmn + Model%rlmx = rlmx + Model%zolcru = zolcru + Model%cs0 = cs0 + Model%moninq_fac = moninq_fac + Model%dspfac = dspfac + Model%bl_upfr = bl_upfr + Model%bl_dnfr = bl_dnfr + Model%ysu_ent_fac = ysu_ent_fac + Model%ysu_pfac_q = ysu_pfac_q + Model%ysu_brcr_ub = ysu_brcr_ub + Model%ysu_rlam = ysu_rlam + Model%ysu_afac = ysu_afac + Model%ysu_bfac = ysu_bfac + Model%ysu_hpbl_cr = ysu_hpbl_cr + Model%tnl_fac = tnl_fac + Model%qnl_fac = qnl_fac + Model%unl_fac = unl_fac + Model%cnvcld = cnvcld + Model%cloud_gfdl = cloud_gfdl + Model%random_clds = random_clds + Model%shal_cnv = shal_cnv + Model%imfshalcnv = imfshalcnv + Model%imfdeepcnv = imfdeepcnv + Model%isatmedmf = isatmedmf + Model%do_deep = do_deep + Model%nmtvr = nmtvr + Model%jcap = jcap + Model%cs_parm = cs_parm + Model%flgmin = flgmin + Model%cs_parm = cs_parm + Model%cgwf = cgwf + Model%ccwf = ccwf + Model%cdmbgwd = cdmbgwd + Model%gwd_p_crit = gwd_p_crit + Model%sup = sup + Model%ctei_rm = ctei_rm + Model%crtrh = crtrh + Model%dlqf = dlqf + Model%rbcr = rbcr + Model%mix_precip = mix_precip + + !--- Rayleigh friction + Model%prslrd0 = prslrd0 + Model%ral_ts = ral_ts + + !--- mass flux deep convection + Model%ext_rain_deep = ext_rain_deep + Model%clam_deep = clam_deep + Model%c0s_deep = c0s_deep + Model%c1_deep = c1_deep + Model%betal_deep = betal_deep + Model%betas_deep = betas_deep + Model%evfact_deep = evfact_deep + Model%evfactl_deep = evfactl_deep + Model%pgcon_deep = pgcon_deep + Model%asolfac_deep = asolfac_deep + + !--- mass flux shallow convection + Model%ext_rain_shal = ext_rain_shal + Model%clam_shal = clam_shal + Model%c0s_shal = c0s_shal + Model%c1_shal = c1_shal + Model%pgcon_shal = pgcon_shal + Model%asolfac_shal = asolfac_shal + Model%evfact_shal = evfact_shal + Model%evfactl_shal = evfactl_shal + + !--- near surface temperature model + Model%nst_anl = nst_anl + Model%lsea = lsea + Model%nstf_name = nstf_name + +!--- fractional grid + Model%frac_grid = frac_grid + Model%ignore_lake = ignore_lake + Model%min_lakeice = min_lakeice + Model%min_seaice = min_seaice + Model%min_lake_height = min_lake_height + Model%rho_h2o = rho_h2o + + !--- stochastic physics options + ! do_sppt, do_shum, do_skeb and do_sfcperts are namelist variables in group + ! physics that are parsed here and then compared in init_stochastic_physics + ! to the stochastic physics namelist parametersto ensure consistency. + Model%do_sppt = do_sppt + Model%use_zmtnblck = use_zmtnblck + Model%do_shum = do_shum + Model%do_skeb = do_skeb + Model%do_sfcperts = do_sfcperts ! mg, sfc-perts + Model%nsfcpert = nsfcpert ! mg, sfc-perts + Model%pertz0 = pertz0 + Model%pertzt = pertzt + Model%pertshc = pertshc + Model%pertlai = pertlai + Model%pertalb = pertalb + Model%pertvegf = pertvegf + + !--- cellular automata options + Model%nca = nca + Model%ncells = ncells + Model%nlives = nlives + Model%nfracseed = nfracseed + Model%nseed = nseed + Model%ca_global = ca_global + Model%do_ca = do_ca + Model%ca_sgs = ca_sgs + Model%iseed_ca = iseed_ca + Model%ca_smooth = ca_smooth + Model%isppt_deep = isppt_deep + Model%nspinup = nspinup + Model%nthresh = nthresh + + ! IAU flags + !--- iau parameters + Model%iaufhrs = iaufhrs + Model%iau_inc_files = iau_inc_files + Model%iau_forcing_var = iau_forcing_var + Model%iau_delthrs = iau_delthrs + Model%iau_filter_increments = iau_filter_increments + Model%iau_drymassfixer = iau_drymassfixer + if(Model%me==0) print *,' model init,iaufhrs=',Model%iaufhrs + + !--- tracer handling + Model%ntrac = size(tracer_names) + allocate (Model%tracer_names(Model%ntrac)) + Model%tracer_names(:) = tracer_names(:) + Model%ntoz = get_tracer_index(Model%tracer_names, 'o3mr', Model%me, Model%master, Model%debug) + Model%ntcw = get_tracer_index(Model%tracer_names, 'liq_wat', Model%me, Model%master, Model%debug) + Model%ntiw = get_tracer_index(Model%tracer_names, 'ice_wat', Model%me, Model%master, Model%debug) + Model%ntrw = get_tracer_index(Model%tracer_names, 'rainwat', Model%me, Model%master, Model%debug) + Model%ntsw = get_tracer_index(Model%tracer_names, 'snowwat', Model%me, Model%master, Model%debug) + Model%ntgl = get_tracer_index(Model%tracer_names, 'graupel', Model%me, Model%master, Model%debug) + Model%ntclamt = get_tracer_index(Model%tracer_names, 'cld_amt', Model%me, Model%master, Model%debug) + Model%ntlnc = get_tracer_index(Model%tracer_names, 'water_nc', Model%me, Model%master, Model%debug) + Model%ntinc = get_tracer_index(Model%tracer_names, 'ice_nc', Model%me, Model%master, Model%debug) + Model%ntrnc = get_tracer_index(Model%tracer_names, 'rain_nc', Model%me, Model%master, Model%debug) + Model%ntsnc = get_tracer_index(Model%tracer_names, 'snow_nc', Model%me, Model%master, Model%debug) + Model%ntgnc = get_tracer_index(Model%tracer_names, 'graupel_nc', Model%me, Model%master, Model%debug) + Model%ntke = get_tracer_index(Model%tracer_names, 'sgs_tke', Model%me, Model%master, Model%debug) + Model%ntwa = get_tracer_index(Model%tracer_names, 'liq_aero', Model%me, Model%master, Model%debug) + Model%ntia = get_tracer_index(Model%tracer_names, 'ice_aero', Model%me, Model%master, Model%debug) + Model%ntchm = 0 + Model%ntchs = get_tracer_index(Model%tracer_names, 'so2', Model%me, Model%master, Model%debug) + if (Model%ntchs > 0) then + Model%ntchm = get_tracer_index(Model%tracer_names, 'pp10', Model%me, Model%master, Model%debug) + if (Model%ntchm > 0) then + Model%ntchm = Model%ntchm - Model%ntchs + 1 + allocate(Model%ntdiag(Model%ntchm)) + ! -- turn on all tracer diagnostics to .true. by default, except for so2 + Model%ntdiag(1) = .false. + Model%ntdiag(2:) = .true. + ! -- turn off diagnostics for DMS + n = get_tracer_index(Model%tracer_names, 'DMS', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%ntdiag(n) = .false. + ! -- turn off diagnostics for msa + n = get_tracer_index(Model%tracer_names, 'msa', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%ntdiag(n) = .false. + endif + endif + + ! -- setup aerosol scavenging factors + allocate(Model%fscav(Model%ntchm)) + if (Model%ntchm > 0) then + ! -- initialize to default + Model%fscav = 0.6_kind_phys + n = get_tracer_index(Model%tracer_names, 'seas1', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%fscav(n) = 1.0_kind_phys + n = get_tracer_index(Model%tracer_names, 'seas2', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%fscav(n) = 1.0_kind_phys + n = get_tracer_index(Model%tracer_names, 'seas3', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%fscav(n) = 1.0_kind_phys + n = get_tracer_index(Model%tracer_names, 'seas4', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%fscav(n) = 1.0_kind_phys + n = get_tracer_index(Model%tracer_names, 'seas5', Model%me, Model%master, Model%debug) - Model%ntchs + 1 + if (n > 0) Model%fscav(n) = 1.0_kind_phys + ! -- read factors from namelist + do i = 1, size(fscav_aero) + j = index(fscav_aero(i),":") + if (j > 1) then + read(fscav_aero(i)(j+1:), *, iostat=ios) tem + if (ios /= 0) cycle + if (adjustl(fscav_aero(i)(:j-1)) == "*") then + Model%fscav = tem + exit + else + n = get_tracer_index(Model%tracer_names, adjustl(fscav_aero(i)(:j-1)), Model%me, Model%master, Model%debug) & + - Model%ntchs + 1 + if (n > 0) Model%fscav(n) = tem + endif + endif + enddo + endif + + !--- quantities to be used to derive phy_f*d totals + Model%nshoc_2d = nshoc_2d + Model%nshoc_3d = nshoc_3d + Model%ncnvcld3d = ncnvcld3d + Model%nctp = nctp + + !--- debug flag + Model%debug = debug + Model%pre_rad = pre_rad + Model%do_ocean = do_ocean + Model%use_ext_sst = use_ext_sst + Model%lprnt = lprnt + + !--- set initial values for time varying properties + Model%ipt = 1 + !Model%lprnt = .false. + Model%lsswr = .false. + Model%lslwr = .false. + Model%solhr = -9999. + Model%solcon = -9999. + Model%slag = -9999. + Model%sdec = -9999. + Model%cdec = -9999. + Model%clstp = -9999 + rinc(1:5) = 0 + call w3difdat(jdat,idat,4,rinc) + Model%phour = rinc(4)/con_hr + Model%fhour = (rinc(4) + Model%dtp)/con_hr + Model%zhour = mod(Model%phour,Model%fhzero) + Model%kdt = 0 + Model%kdt_prev = 0 + Model%jdat(1:8) = jdat(1:8) + + !--- stored in wam_f107_kp module + f107_kp_size = 56 + f107_kp_skip_size = 0 + f107_kp_data_size = 56 + f107_kp_interval = 10800 + + !--- BEGIN CODE FROM GFS_PHYSICS_INITIALIZE + !--- define physcons module variables + tem = con_rerth*con_rerth*(con_pi+con_pi)*con_pi + dxmax = log(tem/(max_lon*max_lat)) + dxmin = log(tem/(min_lon*min_lat)) + dxinv = 1.0d0 / (dxmax-dxmin) + if (Model%me == Model%master) write(0,*)' dxmax=',dxmax,' dxmin=',dxmin,' dxinv=',dxinv + + !--- set nrcm + if (Model%ras) then + Model%nrcm = min(nrcmax, Model%levs-1) * (Model%dtp/1200.d0) + 0.10001d0 + else + Model%nrcm = 2 + endif + + !--- cal_pre + if (Model%cal_pre) then + Model%random_clds = .true. + endif + !--- END CODE FROM GFS_PHYSICS_INITIALIZE + + + !--- BEGIN CODE FROM COMPNS_PHYSICS + !--- shoc scheme + if (do_shoc) then + Model%nshoc_3d = 3 + Model%nshoc_2d = 0 + Model%shal_cnv = .false. + Model%imfshalcnv = -1 + Model%hybedmf = .false. + Model%ysupbl = .false. + Model%satmedmf = .false. + if (Model%me == Model%master) print *,' Simplified Higher Order Closure Model used for', & + ' Boundary layer and Shallow Convection', & + ' nshoc_3d=',Model%nshoc_3d, & + ' nshoc_2d=',Model%nshoc_2d, & + ' ntke=',Model%ntke + endif + + !--- set number of cloud types + if (Model%cscnv) then + Model%nctp = nint(Model%cs_parm(5)) + Model%nctp = max(Model%nctp,10) + if (Model%cs_parm(7) < 0.0) Model%cs_parm(7) = Model%dtp + endif + Model%nctp = max(Model%nctp,1) + + !--- output information about the run + if (Model%me == Model%master) then + if (Model%lsm == Model%lsm_noah) then + print *,' NOAH Land Surface Model used' + elseif (Model%lsm == Model%lsm_noahmp) then + if (Model%ivegsrc /= 1) then + print *,'Vegetation type must be IGBP if Noah MP is used' + stop + elseif (Model%isot /= 1) then + print *,'Soil type must be STATSGO if Noah MP is used' + stop + endif + print *, 'New Noah MP Land Surface Model will be used' + print *, 'The Physics options are' + + print *,'iopt_dveg = ', Model%iopt_dveg + print *,'iopt_crs = ', Model%iopt_crs + print *,'iopt_btr = ', Model%iopt_btr + print *,'iopt_run = ', Model%iopt_run + print *,'iopt_sfc = ', Model%iopt_sfc + print *,'iopt_frz = ', Model%iopt_frz + print *,'iopt_inf = ', Model%iopt_inf + print *,'iopt_rad = ', Model%iopt_rad + print *,'iopt_alb = ', Model%iopt_alb + print *,'iopt_snf = ', Model%iopt_snf + print *,'iopt_tbot = ',Model%iopt_tbot + print *,'iopt_stc = ', Model%iopt_stc + + + + elseif (Model%lsm == 0) then + print *,' OSU no longer supported - job aborted' + stop + else + print *,' Unsupported LSM type - job aborted - lsm=',Model%lsm + stop + endif + + print *,' nst_anl=',Model%nst_anl,' use_ufo=',Model%use_ufo,' frac_grid=',Model%frac_grid,& + ' ignore_lake=',ignore_lake + print *,' min_lakeice=',Model%min_lakeice,' min_seaice=',Model%min_seaice, & + 'min_lake_height=',Model%min_lake_height + + print*, ' czil_sfc=', Model%czil_sfc + if (Model%nstf_name(1) > 0 ) then + print *,' NSSTM is active ' + print *,' nstf_name(1)=',Model%nstf_name(1) + print *,' nstf_name(2)=',Model%nstf_name(2) + print *,' nstf_name(3)=',Model%nstf_name(3) + print *,' nstf_name(4)=',Model%nstf_name(4) + print *,' nstf_name(5)=',Model%nstf_name(5) + endif + if (.not. Model%cscnv) then + if (Model%ras) then + print *,' RAS Convection scheme used with ccwf=',Model%ccwf + Model%imfdeepcnv = -1 + else + if (Model%do_deep) then + if (Model%imfdeepcnv == 0) then + print *,' old SAS Convection scheme before July 2010 used' + elseif(Model%imfdeepcnv == 1) then + print *,' July 2010 version of SAS conv scheme used' + elseif(Model%imfdeepcnv == 2 .or. Model%imfdeepcnv == 3) then + print *,' scale & aerosol-aware mass-flux deep conv scheme' + endif + else + print*, ' Deep convection scheme disabled' + endif + endif + else + if (Model%do_aw) then + print *,'Chikira-Sugiyama convection scheme with Arakawa-Wu'& + &, ' unified parameterization used' + else + print *,'Chikira-Sugiyama convection scheme used' + endif + print *,' cs_parm=',Model%cs_parm,' nctp=',Model%nctp + endif + if (.not. Model%old_monin .and. .not. Model%do_shoc) print *,' New PBL scheme used' + if (.not. Model%shal_cnv) then + Model%imfshalcnv = -1 + print *,' No shallow convection used' + else + if (Model%imfshalcnv == 0) then + print *,' modified Tiedtke eddy-diffusion shallow conv scheme used' + elseif (Model%imfshalcnv == 1) then + print *,' July 2010 version of mass-flux shallow conv scheme used' + elseif (Model%imfshalcnv == 2 .or. Model%imfshalcnv == 3) then + print *,' scale- & aerosol-aware mass-flux shallow conv scheme (2017)' + else + print *,' unknown mass-flux scheme in use - defaulting to no shallow convection' + Model%imfshalcnv = -1 + endif + endif + if (Model%orogwd) print *,' Orographic GWD parameterization used' + if (Model%cnvgwd) print *,' Convective GWD parameterization used' + if (Model%crick_proof) print *,' CRICK-Proof cloud water used in radiation ' + if (Model%ccnorm) print *,' Cloud condensate normalized by cloud cover for radiation' + + print *,' Radiative heating calculated at',Model%levr, ' layers' + if (Model%iovr_sw == 0) then + print *,' random cloud overlap for Shortwave IOVR_SW=',Model%iovr_sw + else + print *,' max-random cloud overlap for Shortwave IOVR_SW=',Model%iovr_sw + endif + if (Model%iovr_lw == 0) then + print *,' random cloud overlap for Longwave IOVR_LW=',Model%iovr_lw + else + print *,' max-random cloud overlap for Longwave IOVR_LW=',Model%iovr_lw + endif + if (Model%isubc_sw == 0) then + print *,' no sub-grid cloud for Shortwave ISUBC_SW=',Model%isubc_sw + else + print *,' sub-grid cloud for Shortwave ISUBC_SW=',Model%isubc_sw + endif + if (Model%isubc_lw == 0) then + print *,' no sub-grid cloud for Longwave ISUBC_LW=',Model%isubc_lw + else + print *,' sub-grid cloud for Longwave ISUBC_LW=',Model%isubc_lw + endif + endif + + !--- set up cloud schemes and tracer elements + if (Model%ncld <= 1) then + if (Model%zhao_mic) then ! default setup for Zhao Microphysics + Model%npdf3d = 0 + Model%num_p3d = 4 + Model%num_p2d = 3 + if (Model%pdfcld) then + Model%npdf3d = 3 + else + Model%shcnvcw = .false. + endif + if (Model%me == Model%master) print *,' Using Zhao/Carr/Sundqvist Microphysics' + else + print *,' Ferrier Microphysics scheme has been deprecated - job aborted' + stop + endif + elseif (Model%ncld == 2) then + Model%npdf3d = 0 + Model%num_p3d = 1 + Model%num_p2d = 1 + Model%pdfcld = .false. + Model%shcnvcw = .false. + if (Model%me == Model%master) print *,' Using Morrison-Gettelman double moment', & + ' microphysics',' aero_in=',Model%aero_in, & + ' mg_dcs=',Model%mg_dcs,' mg_qcvar=',Model%mg_qcvar, & + ' mg_ts_auto_ice=',Model%mg_ts_auto_ice + elseif (Model%ncld == 5) then + if (Model%pdfcld) then + Model%npdf3d = 3 + else + Model%npdf3d = 0 + endif + Model%num_p3d = 4 + Model%num_p2d = 1 + Model%shcnvcw = .false. + Model%cnvcld = .false. + if (Model%me == Model%master) print *,' Using GFDL Cloud Microphysics' + endif + + Model%uni_cld = .false. + if ((Model%shoc_cld) .or. (Model%ncld == 2)) then + Model%uni_cld = .true. + endif + + if(Model%ras .or. Model%cscnv) Model%cnvcld = .false. + if(Model%do_shoc .or. Model%pdfcld) Model%cnvcld = .false. + if(Model%cnvcld) Model%ncnvcld3d = 1 + + !--- derived totals for phy_f*d + Model%ntot2d = Model%num_p2d + Model%nshoc_2d + Model%ntot3d = Model%num_p3d + Model%nshoc_3d + Model%npdf3d + Model%ncnvcld3d + if (me == Model%master) print *,' num_p3d=',Model%num_p3d,' num_p2d=',Model%num_p2d, & + ' crtrh=',Model%crtrh,' npdf3d=',Model%npdf3d, & + ' pdfcld=',Model%pdfcld,' shcnvcw=',Model%shcnvcw, & + ' cnvcld=',Model%cnvcld,' ncnvcld3d=',Model%ncnvcld3d, & + ' do_shoc=',Model%do_shoc,' nshoc3d=',Model%nshoc_3d, & + ' nshoc_2d=',Model%nshoc_2d,' shoc_cld=',Model%shoc_cld,& + ' ntot3d=',Model%ntot3d,' ntot2d=',Model%ntot2d, & + ' shocaftcnv=',Model%shocaftcnv,' cloud_gfdl=',Model%cloud_gfdl + + !--- END CODE FROM COMPNS_PHYSICS + + + !--- BEGIN CODE FROM GLOOPR + !--- set up parameters for Xu & Randell's cloudiness computation (Radiation) + Model%lmfshal = (Model%shal_cnv .and. (Model%imfshalcnv > 0)) + Model%lmfdeep2 = (Model%imfdeepcnv == 2 .or. Model%imfdeepcnv == 3) + !--- END CODE FROM GLOOPR + + !--- BEGIN CODE FROM GLOOPB + !--- set up random number seed needed for RAS and old SAS and when cal_pre=.true. + if ((Model%imfdeepcnv <= 0) .or. (Model%cal_pre)) then + if (Model%random_clds) then + seed0 = Model%idate(1) + Model%idate(2) + Model%idate(3) + Model%idate(4) + call random_setseed(seed0) + call random_number(wrk) + Model%seed0 = seed0 + nint(wrk(1)*1000.0d0) + endif + endif + !--- END CODE FROM GLOOPB + + call Model%print () + + end subroutine control_initialize + + +!------------------ +! GFS_control%print +!------------------ + subroutine control_print(Model) + + implicit none + + !--- interface variables + class(GFS_control_type) :: Model + + if (Model%me == Model%master) then + print *, ' ' + print *, 'basic control parameters' + print *, ' me : ', Model%me + print *, ' master : ', Model%master + print *, ' nlunit : ', Model%nlunit + print *, ' fn_nml : ', trim(Model%fn_nml) + print *, ' fhzero : ', Model%fhzero + print *, ' ldiag3d : ', Model%ldiag3d + print *, ' lssav : ', Model%lssav + print *, ' fhcyc : ', Model%fhcyc + print *, ' lgocart : ', Model%lgocart + print *, ' fhgoc3d : ', Model%fhgoc3d + print *, ' thermodyn_id : ', Model%thermodyn_id + print *, ' sfcpress_id : ', Model%sfcpress_id + print *, ' gen_coord_hybrid : ', Model%gen_coord_hybrid + print *, ' sfc_override : ', Model%sfc_override + print *, ' ' + print *, 'grid extent parameters' + print *, ' isc : ', Model%isc + print *, ' jsc : ', Model%jsc + print *, ' nx : ', Model%nx + print *, ' ny : ', Model%ny + print *, ' levs : ', Model%levs + print *, ' cnx : ', Model%cnx + print *, ' cny : ', Model%cny + print *, ' lonr : ', Model%lonr + print *, ' latr : ', Model%latr + print *, ' blksz(1) : ', Model%blksz(1) + print *, ' blksz(nblks) : ', Model%blksz(Model%nblks) + print *, ' ' + print *, 'coupling parameters' + print *, ' cplflx : ', Model%cplflx + print *, ' cplwav : ', Model%cplwav + print *, ' ' + print *, 'integrated dynamics through earth atmosphere' + print *, ' lsidea : ', Model%lsidea + print *, ' ' + print *, 'calendars and time parameters and activation triggers' + print *, ' dtp : ', Model%dtp + print *, ' dtf : ', Model%dtf + print *, ' nscyc : ', Model%nscyc + print *, ' nszero : ', Model%nszero + print *, ' idat : ', Model%idat + print *, ' idate : ', Model%idate + print *, ' ' + print *, 'radiation control parameters' + print *, ' fhswr : ', Model%fhswr + print *, ' fhlwr : ', Model%fhlwr + print *, ' nsswr : ', Model%nsswr + print *, ' nslwr : ', Model%nslwr + print *, ' levr : ', Model%levr + print *, ' nfxr : ', Model%nfxr + print *, ' nkld : ', Model%nkld + print *, ' aero_in : ', Model%aero_in + print *, ' lmfshal : ', Model%lmfshal + print *, ' lmfdeep2 : ', Model%lmfdeep2 + print *, ' nrcm : ', Model%nrcm + print *, ' iflip : ', Model%iflip + print *, ' isol : ', Model%isol + print *, ' ico2 : ', Model%ico2 + print *, ' ialb : ', Model%ialb + print *, ' iems : ', Model%iems + print *, ' iaer : ', Model%iaer + print *, ' iovr_sw : ', Model%iovr_sw + print *, ' iovr_lw : ', Model%iovr_lw + print *, ' ictm : ', Model%ictm + print *, ' isubc_sw : ', Model%isubc_sw + print *, ' isubc_lw : ', Model%isubc_lw + print *, ' crick_proof : ', Model%crick_proof + print *, ' ccnorm : ', Model%ccnorm + print *, ' norad_precip : ', Model%norad_precip + print *, ' lwhtr : ', Model%lwhtr + print *, ' swhtr : ', Model%swhtr + print *, ' fixed_date : ', Model%fixed_date + print *, ' fixed_solhr : ', Model%fixed_solhr + print *, ' daily_mean : ', Model%daily_mean + print *, ' ' + print *, 'microphysical switch' + print *, ' ncld : ', Model%ncld + print *, ' GFDL microphysical parameters' + print *, ' do_inline_mp : ', Model%do_inline_mp + print *, ' Z-C microphysical parameters' + print *, ' zhao_mic : ', Model%zhao_mic + print *, ' psautco : ', Model%psautco + print *, ' prautco : ', Model%prautco + print *, ' evpco : ', Model%evpco + print *, ' wminco : ', Model%wminco + print *, ' M-G microphysical parameters' + print *, ' fprcp : ', Model%fprcp + print *, ' mg_dcs : ', Model%mg_dcs + print *, ' mg_qcvar : ', Model%mg_qcvar + print *, ' mg_ts_auto_ice : ', Model%mg_ts_auto_ice + print *, ' ' + print *, 'land/surface model parameters' + print *, ' lsm : ', Model%lsm + print *, ' lsoil : ', Model%lsoil + print *, ' ivegsrc : ', Model%ivegsrc + print *, ' isot : ', Model%isot + print *, ' mom4ice : ', Model%mom4ice + print *, ' use_ufo : ', Model%use_ufo + print *, ' czil_sfc : ', Model%czil_sfc + + if (Model%lsm == Model%lsm_noahmp) then + print *, ' Noah MP LSM is used, the options are' + print *, ' iopt_dveg : ', Model%iopt_dveg + print *, ' iopt_crs : ', Model%iopt_crs + print *, ' iopt_btr : ', Model%iopt_btr + print *, ' iopt_run : ', Model%iopt_run + print *, ' iopt_sfc : ', Model%iopt_sfc + print *, ' iopt_frz : ', Model%iopt_frz + print *, ' iopt_inf : ', Model%iopt_inf + print *, ' iopt_rad : ', Model%iopt_rad + print *, ' iopt_alb : ', Model%iopt_alb + print *, ' iopt_snf : ', Model%iopt_snf + print *, ' iopt_tbot : ', Model%iopt_tbot + print *, ' iopt_stc : ', Model%iopt_stc + + endif + + print *, ' ' + print *, 'tuning parameters for physical parameterizations' + print *, ' ras : ', Model%ras + print *, ' flipv : ', Model%flipv + print *, ' trans_trac : ', Model%trans_trac + print *, ' old_monin : ', Model%old_monin + print *, ' orogwd : ', Model%orogwd + print *, ' cnvgwd : ', Model%cnvgwd + print *, ' mstrat : ', Model%mstrat + print *, ' moist_adj : ', Model%moist_adj + print *, ' cscnv : ', Model%cscnv + print *, ' cal_pre : ', Model%cal_pre + print *, ' do_aw : ', Model%do_aw + print *, ' do_shoc : ', Model%do_shoc + print *, ' shocaftcnv : ', Model%shocaftcnv + print *, ' shoc_cld : ', Model%shoc_cld + print *, ' uni_cld : ', Model%uni_cld + print *, ' h2o_phys : ', Model%h2o_phys + print *, ' pdfcld : ', Model%pdfcld + print *, ' shcnvcw : ', Model%shcnvcw + print *, ' redrag : ', Model%redrag + print *, ' sfc_gfdl : ', Model%sfc_gfdl + print *, ' z0s_max : ', Model%z0s_max + print *, ' do_z0_moon : ', Model%do_z0_moon + print *, ' do_z0_hwrf15 : ', Model%do_z0_hwrf15 + print *, ' do_z0_hwrf17 : ', Model%do_z0_hwrf17 + print *, ' do_z0_hwrf17_hwonly : ', Model%do_z0_hwrf17_hwonly + print *, ' wind_th_hwrf : ', Model%wind_th_hwrf + print *, ' hybedmf : ', Model%hybedmf + print *, ' myj_pbl : ', Model%myj_pbl + print *, ' ysupbl : ', Model%ysupbl + print *, ' satmedmf : ', Model%satmedmf + print *, ' no_pbl : ', Model%no_pbl + print *, ' cap_k0_land : ', Model%cap_k0_land + print *, ' do_dk_hb19 : ', Model%do_dk_hb19 + print *, ' dspheat : ', Model%dspheat + print *, ' lheatstrg : ', Model%lheatstrg + print *, ' hour_canopy : ', Model%hour_canopy + print *, ' afac_canopy : ', Model%afac_canopy + print *, ' xkzm_m : ', Model%xkzm_m + print *, ' xkzm_h : ', Model%xkzm_h + print *, ' xkzm_ml : ', Model%xkzm_ml + print *, ' xkzm_hl : ', Model%xkzm_hl + print *, ' xkzm_mi : ', Model%xkzm_mi + print *, ' xkzm_hi : ', Model%xkzm_hi + print *, ' xkzm_s : ', Model%xkzm_s + print *, ' xkzm_lim : ', Model%xkzm_lim + print *, ' xkzm_fac : ', Model%xkzm_fac + print *, ' xkzminv : ', Model%xkzminv + print *, ' xkgdx : ', Model%xkgdx + print *, ' rlmn : ', Model%rlmn + print *, ' rlmx : ', Model%rlmx + print *, ' zolcru : ', Model%zolcru + print *, ' cs0 : ', Model%cs0 + print *, ' moninq_fac : ', Model%moninq_fac + print *, ' dspfac : ', Model%dspfac + print *, ' bl_upfr : ', Model%bl_upfr + print *, ' bl_dnfr : ', Model%bl_dnfr + print *, ' ysu_ent_fac : ', Model%ysu_ent_fac + print *, ' ysu_pfac_q : ', Model%ysu_pfac_q + print *, ' ysu_brcr_ub : ', Model%ysu_brcr_ub + print *, ' ysu_rlam : ', Model%ysu_rlam + print *, ' ysu_afac : ', Model%ysu_afac + print *, ' ysu_bfac : ', Model%ysu_bfac + print *, ' ysu_hpbl_cr : ', Model%ysu_hpbl_cr + print *, ' tnl_fac : ', Model%tnl_fac + print *, ' qnl_fac : ', Model%qnl_fac + print *, ' unl_fac : ', Model%unl_fac + print *, ' cnvcld : ', Model%cnvcld + print *, ' cloud_gfdl : ', Model%cloud_gfdl + print *, ' random_clds : ', Model%random_clds + print *, ' shal_cnv : ', Model%shal_cnv + print *, ' imfshalcnv : ', Model%imfshalcnv + print *, ' imfdeepcnv : ', Model%imfdeepcnv + print *, ' isatmedmf : ', Model%isatmedmf + print *, ' do_deep : ', Model%do_deep + print *, ' nmtvr : ', Model%nmtvr + print *, ' jcap : ', Model%jcap + print *, ' cs_parm : ', Model%cs_parm + print *, ' flgmin : ', Model%flgmin + print *, ' cgwf : ', Model%cgwf + print *, ' ccwf : ', Model%ccwf + print *, ' cdmbgwd : ', Model%cdmbgwd + print *, ' gwd_p_crit : ', Model%gwd_p_crit + print *, ' sup : ', Model%sup + print *, ' ctei_rm : ', Model%ctei_rm + print *, ' crtrh : ', Model%crtrh + print *, ' dlqf : ', Model%dlqf + print *, ' seed0 : ', Model%seed0 + print *, ' rbcr : ', Model%rbcr + print *, ' ' + print *, 'Rayleigh friction' + print *, ' prslrd0 : ', Model%prslrd0 + print *, ' ral_ts : ', Model%ral_ts + print *, ' ' + print *, 'mass flux deep convection' + print *, ' ext_rain_deep : ', Model%ext_rain_deep + print *, ' clam_deep : ', Model%clam_deep + print *, ' c0s_deep : ', Model%c0s_deep + print *, ' c1_deep : ', Model%c1_deep + print *, ' betal_deep : ', Model%betal_deep + print *, ' betas_deep : ', Model%betas_deep + print *, ' evfact_deep : ', Model%evfact_deep + print *, ' evfactl_deep : ', Model%evfactl_deep + print *, ' pgcon_deep : ', Model%pgcon_deep + print *, ' asolfac_deep : ', Model%asolfac_deep + print *, ' ' + print *, 'mass flux shallow convection' + print *, ' ext_rain_shal : ', Model%ext_rain_shal + print *, ' clam_shal : ', Model%clam_shal + print *, ' c0s_shal : ', Model%c0s_shal + print *, ' c1_shal : ', Model%c1_shal + print *, ' pgcon_shal : ', Model%pgcon_shal + print *, ' asolfac_shal : ', Model%asolfac_shal + print *, ' evfact_shal : ', Model%evfact_shal + print *, ' evfactl_shal : ', Model%evfactl_shal + print *, ' ' + print *, 'near surface temperature model' + print *, ' nst_anl : ', Model%nst_anl + print *, ' lsea : ', Model%lsea + print *, ' nstf_name : ', Model%nstf_name + print *, ' ' + print *, 'stochastic physics' + print *, ' do_sppt : ', Model%do_sppt + print *, ' do_shum : ', Model%do_shum + print *, ' do_skeb : ', Model%do_skeb + print *, ' do_sfcperts : ', Model%do_sfcperts + print *, ' ' + print *, 'cellular automata' + print *, ' nca : ', Model%ncells + print *, ' ncells : ', Model%ncells + print *, ' nlives : ', Model%nlives + print *, ' nfracseed : ', Model%nfracseed + print *, ' nseed : ', Model%nseed + print *, ' ca_global : ', Model%ca_global + print *, ' ca_sgs : ', Model%ca_sgs + print *, ' do_ca : ', Model%do_ca + print *, ' iseed_ca : ', Model%iseed_ca + print *, ' ca_smooth : ', Model%ca_smooth + print *, ' isppt_deep : ', Model%isppt_deep + print *, ' nspinup : ', Model%nspinup + print *, ' nthresh : ', Model%nthresh + print *, ' ' + print *, 'tracers' + print *, ' tracer_names : ', Model%tracer_names + print *, ' ntrac : ', Model%ntrac + print *, ' ntoz : ', Model%ntoz + print *, ' ntcw : ', Model%ntcw + print *, ' ntiw : ', Model%ntiw + print *, ' ntrw : ', Model%ntrw + print *, ' ntsw : ', Model%ntsw + print *, ' ntgl : ', Model%ntgl + print *, ' ntclamt : ', Model%ntclamt + print *, ' ntlnc : ', Model%ntlnc + print *, ' ntinc : ', Model%ntinc + print *, ' ntrnc : ', Model%ntrnc + print *, ' ntsnc : ', Model%ntsnc + print *, ' ntgnc : ', Model%ntgnc + print *, ' ntke : ', Model%ntke + print *, ' nto : ', Model%nto + print *, ' nto2 : ', Model%nto2 + print *, ' ntwa : ', Model%ntwa + print *, ' ntia : ', Model%ntia + print *, ' ntchm : ', Model%ntchm + print *, ' ntchs : ', Model%ntchs + print *, ' fscav : ', Model%fscav + print *, ' ' + print *, 'derived totals for phy_f*d' + print *, ' ntot2d : ', Model%ntot2d + print *, ' ntot3d : ', Model%ntot3d + print *, ' num_p2d : ', Model%num_p2d + print *, ' num_p3d : ', Model%num_p3d + print *, ' nshoc_2d : ', Model%nshoc_2d + print *, ' nshoc_3d : ', Model%nshoc_3d + print *, ' ncnvcld3d : ', Model%ncnvcld3d + print *, ' npdf3d : ', Model%npdf3d + print *, ' nctp : ', Model%nctp + print *, ' ' + print *, 'debug flags' + print *, ' debug : ', Model%debug + print *, ' pre_rad : ', Model%pre_rad + print *, ' do_ocean : ', Model%do_ocean + print *, ' use_ext_sst : ', Model%use_ext_sst + print *, ' ' + print *, 'variables modified at each time step' + print *, ' ipt : ', Model%ipt + print *, ' lprnt : ', Model%lprnt + print *, ' lsswr : ', Model%lsswr + print *, ' lslwr : ', Model%lslwr + print *, ' solhr : ', Model%solhr + print *, ' solcon : ', Model%solcon + print *, ' slag : ', Model%slag + print *, ' sdec : ', Model%sdec + print *, ' cdec : ', Model%cdec + print *, ' clstp : ', Model%clstp + print *, ' phour : ', Model%phour + print *, ' fhour : ', Model%fhour + print *, ' zhour : ', Model%zhour + print *, ' kdt : ', Model%kdt + print *, ' jdat : ', Model%jdat + endif + + end subroutine control_print + + +!---------------- +! GFS_grid%create +!---------------- + subroutine grid_create (Grid, IM, Model) + + implicit none + + class(GFS_grid_type) :: Grid + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + allocate (Grid%xlon (IM)) + allocate (Grid%xlat (IM)) + allocate (Grid%xlat_d (IM)) + allocate (Grid%sinlat (IM)) + allocate (Grid%coslat (IM)) + allocate (Grid%area (IM)) + allocate (Grid%dx (IM)) + + Grid%xlon = clear_val + Grid%xlat = clear_val + Grid%xlat_d = clear_val + Grid%sinlat = clear_val + Grid%coslat = clear_val + Grid%area = clear_val + Grid%dx = clear_val + + !--- ozone active + if ( Model%ntoz > 0 ) then + allocate (Grid%ddy_o3 (IM)) + allocate (Grid%jindx1_o3 (IM)) + allocate (Grid%jindx2_o3 (IM)) + endif + + !--- stratosphere h2o active + if ( Model%h2o_phys ) then + allocate (Grid%ddy_h (IM)) + allocate (Grid%jindx1_h (IM)) + allocate (Grid%jindx2_h (IM)) + endif + end subroutine grid_create + + +!-------------------- +! GFS_tbd_type%create +!-------------------- + subroutine tbd_create (Tbd, IM, Model) + + implicit none + + class(GFS_tbd_type) :: Tbd + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + !--- In + !--- sub-grid cloud radiation + if ( Model%isubc_lw == 2 .or. Model%isubc_sw == 2 ) then + allocate (Tbd%icsdsw (IM)) + allocate (Tbd%icsdlw (IM)) + endif + + !--- ozone and stratosphere h2o needs + allocate (Tbd%ozpl (IM,levozp,oz_coeff)) + allocate (Tbd%h2opl (IM,levh2o,h2o_coeff)) + Tbd%ozpl = clear_val + Tbd%h2opl = clear_val + + allocate (Tbd%rann (IM,Model%nrcm)) + Tbd%rann = rann_init + + !--- In/Out + allocate (Tbd%acv (IM)) + allocate (Tbd%acvb (IM)) + allocate (Tbd%acvt (IM)) + + Tbd%acv = clear_val + Tbd%acvb = clear_val + Tbd%acvt = clear_val + + if (Model%do_sppt) then + allocate (Tbd%dtdtr (IM,Model%levs)) + allocate (Tbd%dtotprcp (IM)) + allocate (Tbd%dcnvprcp (IM)) + allocate (Tbd%drain_cpl (IM)) + allocate (Tbd%dsnow_cpl (IM)) + + Tbd%dtdtr = clear_val + Tbd%dtotprcp = clear_val + Tbd%dcnvprcp = clear_val + Tbd%drain_cpl = clear_val + Tbd%dsnow_cpl = clear_val + endif + + allocate (Tbd%phy_fctd (IM,Model%nctp)) + allocate (Tbd%phy_f2d (IM,Model%ntot2d)) + allocate (Tbd%phy_f3d (IM,Model%levs,Model%ntot3d)) + + Tbd%phy_fctd = clear_val + Tbd%phy_f2d = clear_val + Tbd%phy_f3d = clear_val + + end subroutine tbd_create + + +!------------------------ +! GFS_cldprop_type%create +!------------------------ + subroutine cldprop_create (Cldprop, IM, Model) + + implicit none + + class(GFS_cldprop_type) :: Cldprop + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + allocate (Cldprop%cv (IM)) + allocate (Cldprop%cvt (IM)) + allocate (Cldprop%cvb (IM)) + + Cldprop%cv = clear_val + Cldprop%cvt = clear_val + Cldprop%cvb = clear_val + + end subroutine cldprop_create + + +!****************************************** +! GFS_radtend_type%create +!****************************************** + subroutine radtend_create (Radtend, IM, Model) + + implicit none + + class(GFS_radtend_type) :: Radtend + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + !--- Out (radiation only) + allocate (Radtend%sfcfsw (IM)) + allocate (Radtend%sfcflw (IM)) + + Radtend%sfcfsw%upfxc = clear_val + Radtend%sfcfsw%upfx0 = clear_val + Radtend%sfcfsw%dnfxc = clear_val + Radtend%sfcfsw%dnfx0 = clear_val + Radtend%sfcflw%upfxc = clear_val + Radtend%sfcflw%upfx0 = clear_val + Radtend%sfcflw%dnfxc = clear_val + Radtend%sfcflw%dnfx0 = clear_val + + allocate (Radtend%htrsw (IM,Model%levs)) + allocate (Radtend%htrlw (IM,Model%levs)) + allocate (Radtend%sfalb (IM)) + allocate (Radtend%coszen (IM)) + allocate (Radtend%tsflw (IM)) + allocate (Radtend%semis (IM)) + + Radtend%htrsw = clear_val + Radtend%htrlw = clear_val + Radtend%sfalb = clear_val + Radtend%coszen = clear_val + Radtend%tsflw = clear_val + Radtend%semis = clear_val + + !--- In/Out (???) (radiation only) + allocate (Radtend%coszdg (IM)) + + Radtend%coszdg = clear_val + + !--- In/Out (???) (physics only) + allocate (Radtend%swhc (IM,Model%levs)) + allocate (Radtend%lwhc (IM,Model%levs)) + allocate (Radtend%lwhd (IM,Model%levs,6)) + + Radtend%lwhd = clear_val + Radtend%lwhc = clear_val + Radtend%swhc = clear_val + + end subroutine radtend_create + + +!---------------- +! GFS_diag%create +!---------------- + subroutine diag_create (Diag, IM, Model) + class(GFS_diag_type) :: Diag + integer, intent(in) :: IM + type(GFS_control_type), intent(in) :: Model + + !--- Radiation + allocate (Diag%fluxr (IM,Model%nfxr)) + allocate (Diag%cloud (IM,Model%levs,Model%nkld)) + allocate (Diag%topfsw (IM)) + allocate (Diag%topflw (IM)) + !--- Physics + !--- In/Out + allocate (Diag%srunoff (IM)) + allocate (Diag%evbsa (IM)) + allocate (Diag%evcwa (IM)) + allocate (Diag%snohfa (IM)) + allocate (Diag%transa (IM)) + allocate (Diag%sbsnoa (IM)) + allocate (Diag%snowca (IM)) + allocate (Diag%soilm (IM)) + allocate (Diag%tmpmin (IM)) + allocate (Diag%tmpmax (IM)) + allocate (Diag%dusfc (IM)) + allocate (Diag%dvsfc (IM)) + allocate (Diag%dtsfc (IM)) + allocate (Diag%dqsfc (IM)) + allocate (Diag%totprcp (IM)) + allocate (Diag%totprcpb(IM)) + allocate (Diag%gflux (IM)) + allocate (Diag%dlwsfc (IM)) + allocate (Diag%netflxsfc (IM)) + allocate (Diag%qflux_restore (IM)) + allocate (Diag%MLD (IM)) + allocate (Diag%tclim_iano (IM)) + if (Model%myj_pbl) then + allocate (Diag%hmix (IM)) + allocate (Diag%el_myj (IM, Model%levs)) + endif + allocate (Diag%ulwsfc (IM)) + allocate (Diag%suntim (IM)) + allocate (Diag%runoff (IM)) + allocate (Diag%ep (IM)) + allocate (Diag%cldwrk (IM)) + allocate (Diag%dugwd (IM)) + allocate (Diag%dvgwd (IM)) + allocate (Diag%psmean (IM)) + allocate (Diag%cnvprcp (IM)) + allocate (Diag%cnvprcpb(IM)) + allocate (Diag%spfhmin (IM)) + allocate (Diag%spfhmax (IM)) + allocate (Diag%u10mmax (IM)) + allocate (Diag%v10mmax (IM)) + allocate (Diag%wind10mmax (IM)) + allocate (Diag%rain (IM)) + allocate (Diag%rainc (IM)) + allocate (Diag%ice (IM)) + allocate (Diag%snow (IM)) + allocate (Diag%graupel (IM)) + allocate (Diag%totice (IM)) + allocate (Diag%totsnw (IM)) + allocate (Diag%totgrp (IM)) + allocate (Diag%toticeb (IM)) + allocate (Diag%totsnwb (IM)) + allocate (Diag%totgrpb (IM)) + allocate (Diag%u10m (IM)) + allocate (Diag%v10m (IM)) + allocate (Diag%dpt2m (IM)) + allocate (Diag%zlvl (IM)) + allocate (Diag%psurf (IM)) + allocate (Diag%hpbl (IM)) + allocate (Diag%hgamt (IM)) + allocate (Diag%hfxpbl (IM)) + allocate (Diag%pwat (IM)) + allocate (Diag%t1 (IM)) + allocate (Diag%q1 (IM)) + allocate (Diag%u1 (IM)) + allocate (Diag%v1 (IM)) + allocate (Diag%chh (IM)) + allocate (Diag%cmm (IM)) + allocate (Diag%dlwsfci (IM)) + allocate (Diag%ulwsfci (IM)) + allocate (Diag%dswsfci (IM)) + allocate (Diag%uswsfci (IM)) + allocate (Diag%dusfci (IM)) + allocate (Diag%dvsfci (IM)) + allocate (Diag%dtsfci (IM)) + allocate (Diag%dqsfci (IM)) + allocate (Diag%gfluxi (IM)) + allocate (Diag%epi (IM)) + allocate (Diag%smcwlt2 (IM)) + allocate (Diag%smcref2 (IM)) + allocate (Diag%wet1 (IM)) + allocate (Diag%sr (IM)) + + allocate (Diag%diss_est(IM,Model%levs)) + allocate (Diag%skebu_wts(IM,Model%levs)) + allocate (Diag%skebv_wts(IM,Model%levs)) + allocate (Diag%sppt_wts(IM,Model%levs)) + allocate (Diag%shum_wts(IM,Model%levs)) + allocate (Diag%zmtnblck(IM)) + + !--- 3D diagnostics + if (Model%ldiag3d) then + allocate (Diag%du3dt (IM,Model%levs,4)) + allocate (Diag%dv3dt (IM,Model%levs,4)) + allocate (Diag%dt3dt (IM,Model%levs,9)) + allocate (Diag%t_dt (IM,Model%levs,9)) + allocate (Diag%t_dt_int (IM,9)) + allocate (Diag%dq3dt (IM,Model%levs,oz_coeff+5)) + allocate (Diag%q_dt (IM,Model%levs,oz_coeff+5)) + allocate (Diag%q_dt_int (IM,oz_coeff+5)) + allocate (Diag%dkt (IM,Model%levs)) + allocate (Diag%flux_cg(IM,Model%levs)) + allocate (Diag%flux_en(IM,Model%levs)) + !--- needed to allocate GoCart coupling fields + allocate (Diag%upd_mf (IM,Model%levs)) + allocate (Diag%dwn_mf (IM,Model%levs)) + allocate (Diag%det_mf (IM,Model%levs)) + allocate (Diag%cldcov (IM,Model%levs)) + endif + + allocate (Diag%ps_dt(IM)) + + call Diag%rad_zero (Model) + call Diag%phys_zero (Model, linit=.true.) + + end subroutine diag_create + +!----------------------- +! GFS_diag%rad_zero +!----------------------- + subroutine diag_rad_zero(Diag, Model) + class(GFS_diag_type) :: Diag + type(GFS_control_type), intent(in) :: Model + + Diag%fluxr = zero + Diag%cloud = zero + Diag%topfsw%upfxc = zero + Diag%topfsw%dnfxc = zero + Diag%topfsw%upfx0 = zero + Diag%topflw%upfxc = zero + Diag%topflw%upfx0 = zero + if (Model%ldiag3d) then + Diag%cldcov = zero + endif + + + end subroutine diag_rad_zero + +!------------------------ +! GFS_diag%phys_zero +!------------------------ + subroutine diag_phys_zero (Diag, Model, linit, iauwindow_center) + class(GFS_diag_type) :: Diag + type(GFS_control_type), intent(in) :: Model + logical,optional, intent(in) :: linit, iauwindow_center + + logical set_totprcp + + !--- In/Out + Diag%srunoff = zero + Diag%evbsa = zero + Diag%evcwa = zero + Diag%snohfa = zero + Diag%transa = zero + Diag%sbsnoa = zero + Diag%snowca = zero + Diag%soilm = zero + Diag%tmpmin = huge + Diag%tmpmax = zero + Diag%dusfc = zero + Diag%dvsfc = zero + Diag%dtsfc = zero + Diag%dqsfc = zero + Diag%gflux = zero + Diag%dlwsfc = zero + Diag%netflxsfc = zero + Diag%qflux_restore = zero + Diag%MLD = zero + Diag%tclim_iano = zero + Diag%ulwsfc = zero + Diag%suntim = zero + Diag%runoff = zero + Diag%ep = zero + Diag%cldwrk = zero + Diag%dugwd = zero + Diag%dvgwd = zero + Diag%psmean = zero + Diag%spfhmin = huge + Diag%spfhmax = zero + Diag%u10mmax = zero + Diag%v10mmax = zero + Diag%wind10mmax = zero + Diag%rain = zero + Diag%rainc = zero + Diag%ice = zero + Diag%snow = zero + Diag%graupel = zero + + !--- Out + Diag%u10m = zero + Diag%v10m = zero + Diag%dpt2m = zero + Diag%zlvl = zero + Diag%psurf = zero + Diag%hpbl = zero + Diag%hgamt = zero + Diag%hfxpbl = zero + Diag%pwat = zero + Diag%t1 = zero + Diag%q1 = zero + Diag%u1 = zero + Diag%v1 = zero + Diag%chh = zero + Diag%cmm = zero + Diag%dlwsfci = zero + Diag%ulwsfci = zero + Diag%dswsfci = zero + Diag%uswsfci = zero + Diag%dusfci = zero + Diag%dvsfci = zero + Diag%dtsfci = zero + Diag%dqsfci = zero + Diag%gfluxi = zero + Diag%epi = zero + Diag%smcwlt2 = zero + Diag%smcref2 = zero + Diag%wet1 = zero + Diag%sr = zero + Diag%diss_est = zero + Diag%skebu_wts = zero + Diag%skebv_wts = zero + Diag%sppt_wts = zero + Diag%shum_wts = zero + Diag%zmtnblck = zero + Diag%totprcpb = zero + Diag%cnvprcpb = zero + Diag%toticeb = zero + Diag%totsnwb = zero + Diag%totgrpb = zero + + if (Model%do_ca) then + Diag%ca_out = zero + Diag%ca_deep = zero + Diag%ca_turb = zero + Diag%ca_shal = zero + Diag%ca_rad = zero + Diag%ca_micro = zero + endif + + if (Model%ldiag3d) then + Diag%du3dt = zero + Diag%dv3dt = zero + Diag%dt3dt = zero + Diag%dq3dt = zero + Diag%dkt = zero + Diag%flux_cg = zero + Diag%flux_en = zero + Diag%upd_mf = zero + Diag%dwn_mf = zero + Diag%det_mf = zero + endif + + Diag%ps_dt = zero + + set_totprcp = .false. + if (present(linit) ) set_totprcp = linit + if (present(iauwindow_center) ) set_totprcp = iauwindow_center + if (set_totprcp) then + if (Model%me == 0) print *,'set_totprcp T kdt=', Model%kdt + Diag%totprcp = zero + Diag%cnvprcp = zero + Diag%totice = zero + Diag%totsnw = zero + Diag%totgrp = zero + endif + + end subroutine diag_phys_zero + +end module GFS_typedefs diff --git a/IPD_layer/IPD_driver.F90 b/IPD_layer/IPD_driver.F90 new file mode 100644 index 00000000..a0e4c0be --- /dev/null +++ b/IPD_layer/IPD_driver.F90 @@ -0,0 +1,141 @@ +module IPD_driver + + use IPD_typedefs, only: IPD_init_type, & + IPD_control_type, IPD_data_type, & + IPD_diag_type, IPD_restart_type + + use physics_abstraction_layer, only: initialize, time_vary_step, & + radiation_step1, physics_step1, & + physics_step2 + + use physics_diag_layer, only: diag_populate + + use physics_restart_layer, only: restart_populate + + implicit none + +!------------------------------------------------------! +! IPD containers ! +!------------------------------------------------------! +! type(GFS_control_type) :: IPD_Control ! +! type(IPD_data_type) allocatable :: IPD_Data(:) ! +! type(IPD_diag_type), :: IPD_Diag(:) ! +! type(IPD_restart_type), :: IPD_Restart ! +!------------------------------------------------------! + +!---------------- +! Public Entities +!---------------- +! functions + public IPD_initialize + public IPD_setup_step + public IPD_radiation_step + public IPD_physics_step1 + public IPD_physics_step2 + + CONTAINS +!******************************************************************************************* + + +!---------------- +! IPD Initialize +!---------------- + subroutine IPD_initialize (IPD_control, IPD_Data, IPD_Diag, IPD_Restart, IPD_init_parm) + type(IPD_control_type), intent(inout) :: IPD_Control + type(IPD_data_type), intent(inout) :: IPD_Data(:) + type(IPD_diag_type), intent(inout) :: IPD_Diag(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + type(IPD_init_type), intent(in) :: IPD_init_parm + + !--- initialize the physics suite + call initialize (IPD_Control, IPD_Data(:)%Statein, IPD_Data(:)%Stateout, & + IPD_Data(:)%Sfcprop, IPD_Data(:)%Coupling, IPD_Data(:)%Grid, & + IPD_Data(:)%Tbd, IPD_Data(:)%Cldprop, IPD_Data(:)%Radtend, & + IPD_Data(:)%Intdiag, IPD_init_parm) + + + !--- populate/associate the Diag container elements + call diag_populate (IPD_Diag, IPD_control, IPD_Data%Statein, IPD_Data%Stateout, & + IPD_Data%Sfcprop, IPD_Data%Coupling, IPD_Data%Grid, & + IPD_Data%Tbd, IPD_Data%Cldprop, IPD_Data%Radtend, & + IPD_Data%Intdiag, IPD_init_parm) + + + !--- allocate and populate/associate the Restart container elements + call restart_populate (IPD_Restart, IPD_control, IPD_Data%Statein, IPD_Data%Stateout, & + IPD_Data%Sfcprop, IPD_Data%Coupling, IPD_Data%Grid, & + IPD_Data%Tbd, IPD_Data%Cldprop, IPD_Data%Radtend, & + IPD_Data%Intdiag, IPD_init_parm) + + end subroutine IPD_initialize + + +!--------------------------------------------- +! IPD setup step +! surface data cycling, random streams, etc +!--------------------------------------------- + subroutine IPD_setup_step (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) + type(IPD_control_type), intent(inout) :: IPD_Control + type(IPD_data_type), intent(inout) :: IPD_Data(:) + type(IPD_diag_type), intent(inout) :: IPD_Diag(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + + call time_vary_step (IPD_Control, IPD_Data(:)%Statein, IPD_Data(:)%Stateout, & + IPD_Data(:)%Sfcprop, IPD_Data(:)%Coupling, IPD_Data(:)%Grid, & + IPD_Data(:)%Tbd, IPD_Data(:)%Cldprop, IPD_Data(:)%Radtend, & + IPD_Data(:)%Intdiag) + + end subroutine IPD_setup_step + + +!-------------------- +! IPD radiation step +!-------------------- + subroutine IPD_radiation_step (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) + type(IPD_control_type), intent(inout) :: IPD_Control + type(IPD_data_type), intent(inout) :: IPD_Data + type(IPD_diag_type), intent(inout) :: IPD_Diag(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + + call radiation_step1 (IPD_control, IPD_Data%Statein, IPD_Data%Stateout, & + IPD_Data%Sfcprop, IPD_Data%Coupling, IPD_Data%Grid, & + IPD_Data%Tbd, IPD_Data%Cldprop, IPD_Data%Radtend, & + IPD_Data%Intdiag) + + end subroutine IPD_radiation_step + + +!------------------- +! IPD physics step1 +!------------------- + subroutine IPD_physics_step1 (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) + type(IPD_control_type), intent(inout) :: IPD_Control + type(IPD_data_type), intent(inout) :: IPD_Data + type(IPD_diag_type), intent(inout) :: IPD_Diag(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + + call physics_step1 (IPD_control, IPD_Data%Statein, IPD_Data%Stateout, & + IPD_Data%Sfcprop, IPD_Data%Coupling, IPD_Data%Grid, & + IPD_Data%Tbd, IPD_Data%Cldprop, IPD_Data%Radtend, & + IPD_Data%Intdiag) + + end subroutine IPD_physics_step1 + + +!------------------- +! IPD physics step2 +!------------------- + subroutine IPD_physics_step2 (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) + type(IPD_control_type), intent(inout) :: IPD_Control + type(IPD_data_type), intent(inout) :: IPD_Data + type(IPD_diag_type), intent(inout) :: IPD_Diag(:) + type(IPD_restart_type), intent(inout) :: IPD_Restart + + call physics_step2 (IPD_control, IPD_Data%Statein, IPD_Data%Stateout, & + IPD_Data%Sfcprop, IPD_Data%Coupling, IPD_Data%Grid, & + IPD_Data%Tbd, IPD_Data%Cldprop, IPD_Data%Radtend, & + IPD_Data%Intdiag) + + end subroutine IPD_physics_step2 + +end module IPD_driver diff --git a/IPD_layer/IPD_typedefs.F90 b/IPD_layer/IPD_typedefs.F90 new file mode 100644 index 00000000..da1e3571 --- /dev/null +++ b/IPD_layer/IPD_typedefs.F90 @@ -0,0 +1,76 @@ +module IPD_typedefs + use machine, only: kind_phys + + use physics_abstraction_layer, only: IPD_control_type => control_type, & + IPD_init_type => init_type, & + statein_type, stateout_type, & + sfcprop_type, coupling_type, & + grid_type, tbd_type, & + cldprop_type, radtend_type, & + intdiag_type + +!-------------------- +! IPD sub-containers +!-------------------- + type IPD_data_type + type(statein_type) :: Statein + type(stateout_type) :: Stateout + type(sfcprop_type) :: Sfcprop + type(coupling_type) :: Coupling + type(grid_type) :: Grid + type(tbd_type) :: Tbd + type(cldprop_type) :: Cldprop + type(radtend_type) :: Radtend + type(intdiag_type) :: Intdiag + end type IPD_data_type + + + type var_subtype + real(kind=kind_phys), pointer :: var2p(:) => null() !< 2D data saved in packed format [dim(ix)] + real(kind=kind_phys), pointer :: var3p(:,:) => null() !< 3D data saved in packed format [dim(ix,levs)] + end type var_subtype + +!------------------------------------------- +! IPD_restart_type +! data necessary for reproducible restarts +!------------------------------------------- + type IPD_restart_type + integer :: num2d !< current number of registered 2D restart variables + integer :: num3d !< current number of registered 3D restart variables + character(len=32), allocatable :: name2d(:) !< variable name as it will appear in the restart file + character(len=32), allocatable :: name3d(:) !< variable name as it will appear in the restart file + type(var_subtype), allocatable :: data(:,:) !< holds pointers to data in packed format (allocated to (nblks,max(2d/3dfields)) + end type IPD_restart_type + +!---------------------------------------- +! IPD_diag_type +! fields targetted as diagnostic output +!---------------------------------------- + type IPD_diag_type + character(len=32) :: name !< variable name in source + character(len=32) :: output_name !< output name for variable + character(len=32) :: mod_name !< module name (e.g. physics, radiation, etc) + character(len=32) :: file_name !< output file name for variable + character(len=128) :: desc !< long description of field + character(len=32) :: unit !< units associated with fields + character(len=32) :: type_stat_proc !< type of statistic processing: + !< average, accumulation, maximal, minimal, etc. + character(len=32) :: level_type !< vertical level of the field + integer :: level !< vertical level(s) + real(kind=kind_phys) :: cnvfac !< conversion factors to output in specified units + real(kind=kind_phys) :: zhour !< forecast hour when bucket was last emptied for statistical processing + real(kind=kind_phys) :: fcst_hour !< current forecast hour (same as fhour) + type(var_subtype), allocatable :: data(:) !< holds pointers to data in packed format (allocated to nblks) + end type IPD_diag_type + + public kind_phys + public IPD_control_type + public IPD_data_type + public IPD_restart_type + public IPD_diag_type + public IPD_init_type + + CONTAINS +!******************************************************************************************* + +end module IPD_typedefs diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 00000000..0927556b --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,157 @@ +### GNU LESSER GENERAL PUBLIC LICENSE + +Version 3, 29 June 2007 + +Copyright (C) 2007 Free Software Foundation, Inc. + + +Everyone is permitted to copy and distribute verbatim copies of this +license document, but changing it is not allowed. + +This version of the GNU Lesser General Public License incorporates the +terms and conditions of version 3 of the GNU General Public License, +supplemented by the additional permissions listed below. + +#### 0. Additional Definitions. + +As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the +GNU General Public License. + +"The Library" refers to a covered work governed by this License, other +than an Application or a Combined Work as defined below. + +An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + +A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + +The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + +The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + +#### 1. Exception to Section 3 of the GNU GPL. + +You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + +#### 2. Conveying Modified Versions. + +If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + +- a) under this License, provided that you make a good faith effort + to ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or +- b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + +#### 3. Object Code Incorporating Material from Library Header Files. + +The object code form of an Application may incorporate material from a +header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + +- a) Give prominent notice with each copy of the object code that + the Library is used in it and that the Library and its use are + covered by this License. +- b) Accompany the object code with a copy of the GNU GPL and this + license document. + +#### 4. Combined Works. + +You may convey a Combined Work under terms of your choice that, taken +together, effectively do not restrict modification of the portions of +the Library contained in the Combined Work and reverse engineering for +debugging such modifications, if you also do each of the following: + +- a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. +- b) Accompany the Combined Work with a copy of the GNU GPL and this + license document. +- c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. +- d) Do one of the following: + - 0) Convey the Minimal Corresponding Source under the terms of + this License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + - 1) Use a suitable shared library mechanism for linking with + the Library. A suitable mechanism is one that (a) uses at run + time a copy of the Library already present on the user's + computer system, and (b) will operate properly with a modified + version of the Library that is interface-compatible with the + Linked Version. +- e) Provide Installation Information, but only if you would + otherwise be required to provide such information under section 6 + of the GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the Application + with a modified version of the Linked Version. (If you use option + 4d0, the Installation Information must accompany the Minimal + Corresponding Source and Corresponding Application Code. If you + use option 4d1, you must provide the Installation Information in + the manner specified by section 6 of the GNU GPL for conveying + Corresponding Source.) + +#### 5. Combined Libraries. + +You may place library facilities that are a work based on the Library +side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + +- a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities, conveyed under the terms of this License. +- b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + +#### 6. Revised Versions of the GNU Lesser General Public License. + +The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +as you received it specifies that a certain numbered version of the +GNU Lesser General Public License "or any later version" applies to +it, you have the option of following the terms and conditions either +of that published version or of any later version published by the +Free Software Foundation. If the Library as you received it does not +specify a version number of the GNU Lesser General Public License, you +may choose any version of the GNU Lesser General Public License ever +published by the Free Software Foundation. + +If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/README.md b/README.md new file mode 100644 index 00000000..eba9e5eb --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +# SHiELD_physics + +SHiELD_physics contains the infrastructure and physical parameterizations used within the SHiELD atmosphere model. + +More information is available on the [GFDL SHiELD page](https://www.gfdl.noaa.gov/shield/). + +# History & Attribution + +```FV3GFS```, ```GFS_layer```, and ```gsmphys``` contain derivative code (baseline 2017 GFS) plus innovations developed by GFDL during and subsequent to the NGGPS Phase II and III (competition and implementation phases). + +```IPD_layer``` was developed by GFDL personnel, with community input, under funding from NWS Office of Science and Technology Integration. + +```atmos_drivers``` is derivative code from the NOAA-GFDL [Atmospheric Drivers project](https://github.com/NOAA-GFDL/atmos_drivers). This will be removed in a future release. + +```simple_coupler``` is derivative code from the NOAA-GFDL [FMS Coupler project](https://github.com/NOAA-GFDL/FMSCoupler). This will be removed in a future release. + +# Disclaimer + +The United States Department of Commerce (DOC) GitHub project code is provided +on an 'as is' basis and the user assumes responsibility for its use. DOC has +relinquished control of the information and no longer has responsibility to +protect the integrity, confidentiality, or availability of the information. Any +claims against the Department of Commerce stemming from the use of its GitHub +project will be governed by all applicable Federal law. Any reference to +specific commercial products, processes, or services by service mark, +trademark, manufacturer, or otherwise, does not constitute or imply their +endorsement, recommendation or favoring by the Department of Commerce. The +Department of Commerce seal and logo, or the seal and logo of a DOC bureau, +shall not be used in any manner to imply endorsement of any commercial product +or activity by DOC or the United States Government. + +This project code is made available through GitHub but is managed by NOAA-GFDL +at https://gitlab.gfdl.noaa.gov diff --git a/atmos_drivers/coupled/atmos_model.F90 b/atmos_drivers/coupled/atmos_model.F90 new file mode 100644 index 00000000..783b76bd --- /dev/null +++ b/atmos_drivers/coupled/atmos_model.F90 @@ -0,0 +1,826 @@ + +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Atmos Drivers project. +!* +!* This is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* It is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +module atmos_model_mod +!----------------------------------------------------------------------- +! +! Driver for the atmospheric model, contains routines to advance the +! atmospheric model state by one time step. +! + +! +! This version of atmos_model_mod has been designed around the implicit +! version diffusion scheme of the GCM. It requires two routines to advance +! the atmospheric model one time step into the future. These two routines +! correspond to the down and up sweeps of the standard tridiagonal solver. +! Most atmospheric processes (dynamics,radiation,etc.) are performed +! in the down routine. The up routine finishes the vertical diffusion +! and computes moisture related terms (convection,large-scale condensation, +! and precipitation). + +! The boundary variables needed by other component models for coupling +! are contained in a derived data type. A variable of this derived type +! is returned when initializing the atmospheric model. It is used by other +! routines in this module and by coupling routines. The contents of +! this derived type should only be modified by the atmospheric model. + +! + +use mpp_mod, only: mpp_pe, mpp_root_pe, mpp_clock_id, mpp_clock_begin +use mpp_mod, only: mpp_clock_end, CLOCK_COMPONENT, MPP_CLOCK_SYNC +use mpp_mod, only: mpp_min, mpp_max, mpp_error, mpp_chksum +use mpp_domains_mod, only: domain2d +use mpp_mod, only: mpp_get_current_pelist_name +#ifdef INTERNAL_FILE_NML +use mpp_mod, only: input_nml_file +#else +use fms_mod, only: open_namelist_file +#endif +use fms_mod, only: file_exist, error_mesg +use fms_mod, only: close_file, write_version_number, stdlog, stdout +use fms_mod, only: clock_flag_default +use fms_mod, only: check_nml_error +use diag_manager_mod, only: diag_send_complete_instant +use time_manager_mod, only: time_type, get_time, get_date, & + operator(+), operator(-) +use field_manager_mod, only: MODEL_ATMOS +use tracer_manager_mod, only: get_number_tracers, get_tracer_names +use xgrid_mod, only: grid_box_type +use atmosphere_mod, only: atmosphere_init +use atmosphere_mod, only: atmosphere_restart +use atmosphere_mod, only: atmosphere_end +use atmosphere_mod, only: atmosphere_state_update +use atmosphere_mod, only: atmos_phys_driver_statein +use atmosphere_mod, only: atmosphere_control_data +use atmosphere_mod, only: atmosphere_resolution, atmosphere_domain +use atmosphere_mod, only: atmosphere_grid_bdry, atmosphere_grid_ctr +use atmosphere_mod, only: atmosphere_dynamics, atmosphere_diag_axes +use atmosphere_mod, only: atmosphere_etalvls, atmosphere_hgt +!rab use atmosphere_mod, only: atmosphere_tracer_postinit +use atmosphere_mod, only: atmosphere_diss_est, atmosphere_nggps_diag +use atmosphere_mod, only: atmosphere_scalar_field_halo +use atmosphere_mod, only: set_atmosphere_pelist +use atmosphere_mod, only: atmosphere_coarse_graining_parameters +use atmosphere_mod, only: atmosphere_coarse_diag_axes +use atmosphere_mod, only: atmosphere_coarsening_strategy +use atmosphere_mod, only: Atm, mygrid +use block_control_mod, only: block_control_type, define_blocks_packed +use IPD_typedefs, only: IPD_init_type, IPD_control_type, & + IPD_data_type, IPD_diag_type, & + IPD_restart_type, kind_phys +use IPD_driver, only: IPD_initialize, IPD_setup_step, & + IPD_radiation_step, & + IPD_physics_step1, & + IPD_physics_step2 +#ifdef STOCHY +use stochastic_physics, only: init_stochastic_physics, & + run_stochastic_physics +use stochastic_physics_sfc, only: run_stochastic_physics_sfc +#endif +use FV3GFS_io_mod, only: FV3GFS_restart_read, FV3GFS_restart_write, & + FV3GFS_IPD_checksum, & + gfdl_diag_register, gfdl_diag_output, & + FV3GFS_restart_write_coarse, FV3GFS_diag_register_coarse, & + sfc_data_override +use FV3GFS_io_mod, only: register_diag_manager_controlled_diagnostics, register_coarse_diag_manager_controlled_diagnostics +use FV3GFS_io_mod, only: send_diag_manager_controlled_diagnostic_data +use fv_iau_mod, only: iau_external_data_type,getiauforcing,iau_initialize +use module_ocean, only: ocean_init +!----------------------------------------------------------------------- + +implicit none +private + +public update_atmos_radiation_physics +public update_atmos_model_state +public update_atmos_model_dynamics +public atmos_model_init, atmos_model_end, atmos_data_type +public atmos_model_restart +!----------------------------------------------------------------------- + +! + type atmos_data_type + type (domain2d) :: domain ! domain decomposition + integer :: axes(4) ! axis indices (returned by diag_manager) for the atmospheric grid + ! (they correspond to the x, y, pfull, phalf axes) + real, pointer, dimension(:,:) :: lon_bnd => null() ! local longitude axis grid box corners in radians. + real, pointer, dimension(:,:) :: lat_bnd => null() ! local latitude axis grid box corners in radians. + real(kind=kind_phys), pointer, dimension(:,:) :: lon => null() ! local longitude axis grid box centers in radians. + real(kind=kind_phys), pointer, dimension(:,:) :: lat => null() ! local latitude axis grid box centers in radians. + type (time_type) :: Time ! current time + type (time_type) :: Time_step ! atmospheric time step. + type (time_type) :: Time_init ! reference time. + integer :: iau_offset ! iau running window length + integer, pointer :: pelist(:) =>null() ! pelist where atmosphere is running. + logical :: pe ! current pe. + type(grid_box_type) :: grid ! hold grid information needed for 2nd order conservative flux exchange + ! to calculate gradient on cubic sphere grid. + integer :: layout(2) ! computer task laytout + logical :: regional ! true if domain is regional + logical :: bounded_domain ! true if domain is bounded + real(kind=8), pointer, dimension(:) :: ak + real(kind=8), pointer, dimension(:) :: bk + real(kind=8), pointer, dimension(:,:,:) :: layer_hgt + real(kind=8), pointer, dimension(:,:,:) :: level_hgt + real(kind=kind_phys), pointer, dimension(:,:) :: dx + real(kind=kind_phys), pointer, dimension(:,:) :: dy + real(kind=8), pointer, dimension(:,:) :: area + type(domain2d) :: coarse_domain ! domain decomposition of the coarse grid + logical :: write_coarse_restart_files ! whether to write coarse restart files + logical :: write_only_coarse_intermediate_restarts ! whether to write only coarse intermediate restart files + character(len=64) :: coarsening_strategy ! Strategy for coarse-graining diagnostics and restart files +end type atmos_data_type +! + +integer :: fv3Clock, getClock, overrideClock, updClock, setupClock, radClock, physClock + +!----------------------------------------------------------------------- +integer :: blocksize = 1 +logical :: chksum_debug = .false. +logical :: dycore_only = .false. +logical :: debug = .false. +logical :: sync = .false. +logical :: first_time_step = .true. +logical :: fprint = .true. +real, dimension(4096) :: fdiag = 0. ! xic: TODO: this is hard coded, space can run out in some cases. Should make it allocatable. +logical :: fdiag_override = .false. ! lmh: if true overrides fdiag and fhzer: all quantities are zeroed out after every calcluation, output interval and accumulation/avg/max/min are controlled by diag_manager, fdiag controls output interval only +namelist /atmos_model_nml/ blocksize, chksum_debug, dycore_only, debug, sync, first_time_step, fdiag, fprint, fdiag_override +type (time_type) :: diag_time, diag_time_fhzero +logical :: fdiag_fix = .false. + +!--- concurrent and decoupled radiation and physics variables +!---------------- +! IPD containers +!---------------- +type(IPD_control_type) :: IPD_Control +type(IPD_data_type), allocatable :: IPD_Data(:) ! number of blocks +type(IPD_diag_type) :: IPD_Diag(250) +type(IPD_restart_type) :: IPD_Restart + +!-------------- +! IAU container +!-------------- +type(iau_external_data_type) :: IAU_Data + +!----------------- +! Block container +!----------------- +type (block_control_type), target :: Atm_block + +!----------------------------------------------------------------------- + +character(len=128) :: version = '$Id$' +character(len=128) :: tagname = '$Name$' + +real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + +contains + +!####################################################################### +! +! +! +! Called every time step as the atmospheric driver to compute the +! atmospheric tendencies for dynamics, radiation, vertical diffusion of +! momentum, tracers, and heat/moisture. For heat/moisture only the +! downward sweep of the tridiagonal elimination is performed, hence +! the name "_down". +! + +! + +! +! Derived-type variable that contains fields needed by the flux exchange module. +! These fields describe the atmospheric grid and are needed to +! compute/exchange fluxes with other component models. All fields in this +! variable type are allocated for the global grid (without halo regions). +! + +subroutine update_atmos_radiation_physics (Atmos) +!----------------------------------------------------------------------- + type (atmos_data_type), intent(in) :: Atmos +!--- local variables--- + integer :: nb, jdat(8) + integer :: nthrds + +#ifdef OPENMP + nthrds = omp_get_max_threads() +#else + nthrds = 1 +#endif + + if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "statein driver" +!--- get atmospheric state from the dynamic core + call set_atmosphere_pelist() + call mpp_clock_begin(getClock) + if (IPD_control%do_skeb) call atmosphere_diss_est (IPD_control%skeb_npass) ! do smoothing for SKEB + call atmos_phys_driver_statein (IPD_data, Atm_block) + call mpp_clock_end(getClock) + +!--- get varied surface data + call mpp_clock_begin(overrideClock) + call sfc_data_override (Atmos%Time, IPD_data, Atm_block, IPD_Control) + call mpp_clock_end(overrideClock) + +!--- if dycore only run, set up the dummy physics output state as the input state + if (dycore_only) then + do nb = 1,Atm_block%nblks + IPD_Data(nb)%Stateout%gu0 = IPD_Data(nb)%Statein%ugrs + IPD_Data(nb)%Stateout%gv0 = IPD_Data(nb)%Statein%vgrs + IPD_Data(nb)%Stateout%gt0 = IPD_Data(nb)%Statein%tgrs + IPD_Data(nb)%Stateout%gq0 = IPD_Data(nb)%Statein%qgrs + enddo + else + if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "setup step" + +!--- update IPD_Control%jdat(8) + jdat(:) = 0 + call get_date (Atmos%Time, jdat(1), jdat(2), jdat(3), & + jdat(5), jdat(6), jdat(7)) + IPD_Control%jdat(:) = jdat(:) +!--- execute the IPD atmospheric setup step + call mpp_clock_begin(setupClock) + call IPD_setup_step (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) + +#ifdef STOCHY +!--- call stochastic physics pattern generation / cellular automata + if (IPD_Control%do_sppt .OR. IPD_Control%do_shum .OR. IPD_Control%do_skeb .OR. IPD_Control%do_sfcperts) then + call run_stochastic_physics(IPD_Control, IPD_Data(:)%Grid, IPD_Data(:)%Coupling, nthrds) + end if +#endif + + call mpp_clock_end(setupClock) + + if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "radiation driver" +!--- execute the IPD atmospheric radiation subcomponent (RRTM) + call mpp_clock_begin(radClock) +!$OMP parallel do default (none) & +!$OMP schedule (dynamic,1), & +!$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) & +!$OMP private (nb) + do nb = 1,Atm_block%nblks + call IPD_radiation_step (IPD_Control, IPD_Data(nb), IPD_Diag, IPD_Restart) + enddo + call mpp_clock_end(radClock) + + if (chksum_debug) then + if (mpp_pe() == mpp_root_pe()) print *,'RADIATION STEP ', IPD_Control%kdt, IPD_Control%fhour + call FV3GFS_IPD_checksum(IPD_Control, IPD_Data, Atm_block) + endif + + if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "physics driver" +!--- execute the IPD atmospheric physics step1 subcomponent (main physics driver) + call mpp_clock_begin(physClock) +!$OMP parallel do default (none) & +!$OMP schedule (dynamic,1), & +!$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) & +!$OMP private (nb) + do nb = 1,Atm_block%nblks + call IPD_physics_step1 (IPD_Control, IPD_Data(nb), IPD_Diag, IPD_Restart) + enddo + call mpp_clock_end(physClock) + + if (chksum_debug) then + if (mpp_pe() == mpp_root_pe()) print *,'PHYSICS STEP1 ', IPD_Control%kdt, IPD_Control%fhour + call FV3GFS_IPD_checksum(IPD_Control, IPD_Data, Atm_block) + endif + + if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "stochastic physics driver" +!--- execute the IPD atmospheric physics step2 subcomponent (stochastic physics driver) + call mpp_clock_begin(physClock) +!$OMP parallel do default (none) & +!$OMP schedule (dynamic,1), & +!$OMP shared (Atm_block, IPD_Control, IPD_Data, IPD_Diag, IPD_Restart) & +!$OMP private (nb) + do nb = 1,Atm_block%nblks + call IPD_physics_step2 (IPD_Control, IPD_Data(nb), IPD_Diag, IPD_Restart) + enddo + call mpp_clock_end(physClock) + + if (chksum_debug) then + if (mpp_pe() == mpp_root_pe()) print *,'PHYSICS STEP2 ', IPD_Control%kdt, IPD_Control%fhour + call FV3GFS_IPD_checksum(IPD_Control, IPD_Data, Atm_block) + endif + call getiauforcing(IPD_Control,IAU_data) + if (mpp_pe() == mpp_root_pe() .and. debug) write(6,*) "end of radiation and physics step" + endif + +!----------------------------------------------------------------------- + end subroutine update_atmos_radiation_physics +! + + +!####################################################################### +! +! +! +! Routine to initialize the atmospheric model +! + +subroutine atmos_model_init (Atmos, Time_init, Time, Time_step, iau_offset) + +#ifdef OPENMP + use omp_lib +#endif + use mpp_mod, only: mpp_npes + + type (atmos_data_type), intent(inout) :: Atmos + type (time_type), intent(in) :: Time_init, Time, Time_step + integer, intent(in) :: iau_offset +!--- local variables --- + integer :: unit, ntdiag, ntfamily, i, j, k + integer :: mlon, mlat, nlon, nlat, nlev, sec, dt, sec_prev + integer :: ierr, io, logunit + integer :: idx, tile_num + integer :: isc, iec, jsc, jec + integer :: isd, ied, jsd, jed + integer :: blk, ibs, ibe, jbs, jbe + real(kind=kind_phys) :: dt_phys + real, allocatable :: q(:,:,:,:), p_half(:,:,:) + character(len=80) :: control + character(len=64) :: filename, filename2, pelist_name + character(len=132) :: text + logical :: p_hydro, hydro, fexist + logical, save :: block_message = .true. + type(IPD_init_type) :: Init_parm + integer :: bdat(8), cdat(8) + integer :: ntracers + integer :: kdt_prev + character(len=32), allocatable, target :: tracer_names(:) + integer :: coarse_diagnostic_axes(4) + integer :: nthrds + !----------------------------------------------------------------------- + +!---- set the atmospheric model time ------ + + Atmos % Time_init = Time_init + Atmos % Time = Time + Atmos % Time_step = Time_step + Atmos % iau_offset = iau_offset + call get_time (Atmos % Time_step, sec) + call get_time (Atmos%Time - Atmos%Time_init, sec_prev) + dt_phys = real(sec) ! integer seconds + kdt_prev = int(sec_prev / dt_phys) + + logunit = stdlog() + +!----------------------------------------------------------------------- +! initialize atmospheric model ----- + +!---------- initialize atmospheric dynamics ------- + call atmosphere_init (Atmos%Time_init, Atmos%Time, Atmos%Time_step,& + Atmos%grid, Atmos%area, IAU_Data) + + IF ( file_exist('input.nml')) THEN +#ifdef INTERNAL_FILE_NML + read(input_nml_file, nml=atmos_model_nml, iostat=io) + ierr = check_nml_error(io, 'atmos_model_nml') +#else + unit = open_namelist_file ( ) + ierr=1 + do while (ierr /= 0) + read (unit, nml=atmos_model_nml, iostat=io, end=10) + ierr = check_nml_error(io,'atmos_model_nml') + enddo + 10 call close_file (unit) +#endif + endif +!----------------------------------------------------------------------- + call atmosphere_resolution (nlon, nlat, global=.false.) + call atmosphere_resolution (mlon, mlat, global=.true.) + call alloc_atmos_data_type (nlon, nlat, Atmos) + call atmosphere_domain (Atmos%domain, Atmos%layout, Atmos%regional, Atmos%bounded_domain) + call atmosphere_diag_axes (Atmos%axes) + call atmosphere_etalvls (Atmos%ak, Atmos%bk, flip=.true.) + call atmosphere_grid_bdry (Atmos%lon_bnd, Atmos%lat_bnd, global=.false.) + call atmosphere_grid_ctr (Atmos%lon, Atmos%lat) + call atmosphere_hgt (Atmos%layer_hgt, 'layer', relative=.false., flip=.true.) + call atmosphere_hgt (Atmos%level_hgt, 'level', relative=.false., flip=.true.) + call atmosphere_coarse_graining_parameters(Atmos%coarse_domain, Atmos%write_coarse_restart_files, Atmos%write_only_coarse_intermediate_restarts) + call atmosphere_coarsening_strategy(Atmos%coarsening_strategy) + +!----------------------------------------------------------------------- +!--- before going any further check definitions for 'blocks' +!----------------------------------------------------------------------- + call atmosphere_control_data (isc, iec, jsc, jec, nlev, p_hydro, hydro, tile_num) + call define_blocks_packed ('atmos_model', Atm_block, isc, iec, jsc, jec, nlev, & + blocksize, block_message) + + allocate(IPD_Data(Atm_block%nblks)) + +#ifdef OPENMP + nthrds = omp_get_max_threads() +#else + nthrds = 1 +#endif + +!--- update IPD_Control%jdat(8) + bdat(:) = 0 + call get_date (Time_init, bdat(1), bdat(2), bdat(3), & + bdat(5), bdat(6), bdat(7)) + cdat(:) = 0 + call get_date (Time, cdat(1), cdat(2), cdat(3), & + cdat(5), cdat(6), cdat(7)) + call get_number_tracers(MODEL_ATMOS, num_tracers=ntracers) + allocate (tracer_names(ntracers)) + do i = 1, ntracers + call get_tracer_names(MODEL_ATMOS, i, tracer_names(i)) + enddo +!--- setup IPD Init_parm + Init_parm%me = mpp_pe() + Init_parm%master = mpp_root_pe() + Init_parm%tile_num = tile_num + Init_parm%isc = isc + Init_parm%jsc = jsc + Init_parm%nx = nlon + Init_parm%ny = nlat + Init_parm%levs = nlev + Init_parm%cnx = mlon + Init_parm%cny = mlat + Init_parm%gnx = Init_parm%cnx*4 + Init_parm%gny = Init_parm%cny*2 + Init_parm%nlunit = 9999 + Init_parm%logunit = logunit + Init_parm%bdat(:) = bdat(:) + Init_parm%cdat(:) = cdat(:) + Init_parm%dt_dycore = dt_phys + Init_parm%dt_phys = dt_phys + Init_parm%iau_offset = Atmos%iau_offset + Init_parm%blksz => Atm_block%blksz + Init_parm%ak => Atmos%ak + Init_parm%bk => Atmos%bk + Init_parm%xlon => Atmos%lon + Init_parm%xlat => Atmos%lat + Init_parm%area => Atmos%area + Init_parm%tracer_names => tracer_names + +#ifdef INTERNAL_FILE_NML + allocate(Init_parm%input_nml_file, mold=input_nml_file) + Init_parm%input_nml_file => input_nml_file + Init_parm%fn_nml='using internal file' +#else + pelist_name=mpp_get_current_pelist_name() + Init_parm%fn_nml='input_'//trim(pelist_name)//'.nml' + inquire(FILE=Init_parm%fn_nml, EXIST=fexist) + if (.not. fexist ) then + Init_parm%fn_nml='input.nml' + endif +#endif + + call IPD_initialize (IPD_Control, IPD_Data, IPD_Diag, IPD_Restart, Init_parm) + +#ifdef STOCHY + if (IPD_Control%do_sppt .OR. IPD_Control%do_shum .OR. IPD_Control%do_skeb .OR. IPD_Control%do_sfcperts) then + ! Initialize stochastic physics + call init_stochastic_physics(IPD_Control, Init_parm, mpp_npes(), nthrds) + if (mpp_pe() == mpp_root_pe()) print *,'do_skeb=',IPD_Control%do_skeb + end if + + if (IPD_Control%do_sfcperts) then + ! Get land surface perturbations here (move to GFS_time_vary + ! step if wanting to update each time-step) + call run_stochastic_physics_sfc(IPD_Control, IPD_Data(:)%Grid, IPD_Data(:)%Coupling) + end if +#endif + + Atm(mygrid)%flagstruct%do_diss_est = IPD_Control%do_skeb + +! initialize the IAU module + call iau_initialize (IPD_Control,IAU_data,Init_parm) + + IPD_Control%kdt_prev = kdt_prev + +!--- initialize slab ocean model or mixed layer ocean model +#ifdef INTERNAL_FILE_NML + if (IPD_Control%do_ocean) call ocean_init (IPD_Control, Init_parm%logunit, input_nml_file) +#else + if (IPD_Control%do_ocean) call ocean_init (IPD_Control, Init_parm%logunit) +#endif + + Init_parm%blksz => null() + Init_parm%ak => null() + Init_parm%bk => null() + Init_parm%xlon => null() + Init_parm%xlat => null() + Init_parm%area => null() + Init_parm%tracer_names => null() + deallocate (tracer_names) + + !--- update tracers in FV3 with any initialized during the physics/radiation init phase +!rab call atmosphere_tracer_postinit (IPD_Data, Atm_block) + + call atmosphere_nggps_diag (Time, init=.true.) + call gfdl_diag_register (Time, IPD_Data(:)%Sfcprop, IPD_Data(:)%IntDiag, IPD_Data%Cldprop, & + Atm_block, Atmos%axes, IPD_Control%nfxr, IPD_Control%ldiag3d, & + IPD_Control%nkld, IPD_Control%levs) + call register_diag_manager_controlled_diagnostics(Time, IPD_Data(:)%IntDiag, Atm_block%nblks, Atmos%axes) + if (Atm(mygrid)%coarse_graining%write_coarse_diagnostics) then + call atmosphere_coarse_diag_axes(coarse_diagnostic_axes) + call FV3GFS_diag_register_coarse(Time, coarse_diagnostic_axes) + call register_coarse_diag_manager_controlled_diagnostics(Time, coarse_diagnostic_axes) + endif + if (.not. dycore_only) & + call FV3GFS_restart_read (IPD_Data, IPD_Restart, Atm_block, IPD_Control, Atmos%domain) + if (chksum_debug) then + if (mpp_pe() == mpp_root_pe()) print *,'RESTART READ ', IPD_Control%kdt, IPD_Control%fhour + call FV3GFS_IPD_checksum(IPD_Control, IPD_Data, Atm_block) + endif + + !--- set the initial diagnostic timestamp + diag_time = Time + if (Atmos%iau_offset > zero) then + call get_time (Atmos%Time - Atmos%Time_init, sec) + if (sec < Atmos%iau_offset*3600) then + diag_time = Atmos%Time_init + diag_time_fhzero = Atmos%Time + endif + endif + + !---- print version number to logfile ---- + + call write_version_number ( version, tagname ) + !--- write the namelist to a log file + if (mpp_pe() == mpp_root_pe()) then + unit = stdlog( ) + write (unit, nml=atmos_model_nml) + call close_file (unit) + endif + + !--- get fdiag +#ifdef GFS_PHYS +!--- check fdiag to see if it is an interval or a list + if (fdiag_override) then + if (mpp_pe() == mpp_root_pe()) write(6,*) "---OVERRIDING fdiag: USING SETTINGS IN diag_table for GFS PHYSICS DIAGS" + IPD_Control%fhzero = dt_phys / 3600. + if (mpp_pe() == mpp_root_pe()) write(6,*) "---fhzero IS SET TO dt_atmos: ALL DIAGNOSTICS ARE SINGLE-STEP" + else + if (nint(fdiag(2)) == 0) then + fdiag_fix = .true. + do i = 2, size(fdiag,1) + fdiag(i) = fdiag(1) * i + enddo + endif + if (mpp_pe() == mpp_root_pe()) write(6,*) "---fdiag",fdiag(1:40) + endif +#endif + + setupClock = mpp_clock_id( 'GFS Step Setup ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + overrideClock = mpp_clock_id( 'GFS Override ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + radClock = mpp_clock_id( 'GFS Radiation ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + physClock = mpp_clock_id( 'GFS Physics ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + getClock = mpp_clock_id( 'Dynamics get state ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + updClock = mpp_clock_id( 'Dynamics update state ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + if (sync) then + fv3Clock = mpp_clock_id( 'FV3 Dycore ', flags=clock_flag_default+MPP_CLOCK_SYNC, grain=CLOCK_COMPONENT ) + else + fv3Clock = mpp_clock_id( 'FV3 Dycore ', flags=clock_flag_default, grain=CLOCK_COMPONENT ) + endif + +!----------------------------------------------------------------------- +end subroutine atmos_model_init +! + + +!####################################################################### +! +subroutine update_atmos_model_dynamics (Atmos) +! run the atmospheric dynamics to advect the properties + type (atmos_data_type), intent(in) :: Atmos + + call set_atmosphere_pelist() + call mpp_clock_begin(fv3Clock) + call atmosphere_dynamics (Atmos%Time) + call mpp_clock_end(fv3Clock) + +end subroutine update_atmos_model_dynamics +! + + +!####################################################################### +! +subroutine update_atmos_model_state (Atmos) +! to update the model state after all concurrency is completed + type (atmos_data_type), intent(inout) :: Atmos +!--- local variables + integer :: isec,seconds,isec_fhzero + real(kind=kind_phys) :: time_int, time_intfull + integer :: is, ie, js, je, kt + + call set_atmosphere_pelist() + call mpp_clock_begin(fv3Clock) + call mpp_clock_begin(updClock) + call atmosphere_state_update (Atmos%Time, IPD_Data, IAU_Data, Atm_block) + call mpp_clock_end(updClock) + call mpp_clock_end(fv3Clock) + + if (chksum_debug) then + if (mpp_pe() == mpp_root_pe()) print *,'UPDATE STATE ', IPD_Control%kdt, IPD_Control%fhour + call FV3GFS_IPD_checksum(IPD_Control, IPD_Data, Atm_block) + endif + +!------ advance time ------ + Atmos % Time = Atmos % Time + Atmos % Time_step + + call atmosphere_control_data(is, ie, js, je, kt) + call send_diag_manager_controlled_diagnostic_data(Atmos%Time, & + Atm_block, IPD_Data, IPD_Control%nx, IPD_Control%ny, IPD_Control%levs, & + Atm(mygrid)%coarse_graining%write_coarse_diagnostics, & + real(Atm(mygrid)%delp(is:ie,js:je,:), kind=kind_phys), & + Atmos%coarsening_strategy, real(Atm(mygrid)%ptop, kind=kind_phys)) + + call get_time (Atmos%Time - diag_time, isec) + call get_time (Atmos%Time - Atmos%Time_init, seconds) + + time_int = real(isec) + if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (fdiag_fix .and. mod(seconds, nint(fdiag(1)*3600.0)) .eq. 0) .or. (IPD_Control%kdt == 1 .and. first_time_step) ) then + if (mpp_pe() == mpp_root_pe()) write(6,*) "---isec,seconds",isec,seconds + if (mpp_pe() == mpp_root_pe()) write(6,*) ' gfs diags time since last bucket empty: ',time_int/3600.,'hrs' + call atmosphere_nggps_diag(Atmos%Time) + endif + if (ANY(nint(fdiag(:)*3600.0) == seconds) .or. (fdiag_fix .and. mod(seconds, nint(fdiag(1)*3600.0)) .eq. 0) .or. first_time_step) then + if(Atmos%iau_offset > zero) then + if( time_int - Atmos%iau_offset*3600. > zero ) then + time_int = time_int - Atmos%iau_offset*3600. + else if(seconds == Atmos%iau_offset*3600) then + call get_time (Atmos%Time - diag_time_fhzero, isec_fhzero) + time_int = real(isec_fhzero) + if (mpp_pe() == mpp_root_pe()) write(6,*) "---iseczero",isec_fhzero + endif + endif + time_intfull = real(seconds) + if(Atmos%iau_offset > zero) then + if( time_intfull - Atmos%iau_offset*3600. > zero) then + time_intfull = time_intfull - Atmos%iau_offset*3600. + endif + endif + call gfdl_diag_output(Atmos%Time, Atm_block, IPD_Data, IPD_Control%nx, IPD_Control%ny, fprint, & + IPD_Control%levs, 1, 1, 1.d0, time_int, time_intfull, & + IPD_Control%fhswr, IPD_Control%fhlwr, & + mod(seconds, nint(fdiag(1)*3600.0)) .eq. 0, & + Atm(mygrid)%coarse_graining%write_coarse_diagnostics,& + real(Atm(mygrid)%delp(is:ie,js:je,:), kind=kind_phys), & + Atmos%coarsening_strategy, real(Atm(mygrid)%ptop, kind=kind_phys)) + call diag_send_complete_instant (Atmos%Time) + if (mod(isec,nint(3600*IPD_Control%fhzero)) == 0) diag_time = Atmos%Time + endif + + end subroutine update_atmos_model_state +! + + + +!####################################################################### +! +! +! +! termination routine for atmospheric model +! + +! +! Call once to terminate this module and any other modules used. +! This routine writes a restart file and deallocates storage +! used by the derived-type variable atmos_boundary_data_type. +! + +! + +! +! Derived-type variable that contains fields needed by the flux exchange module. +! + +subroutine atmos_model_end (Atmos) + type (atmos_data_type), intent(inout) :: Atmos +!---local variables + integer :: idx + +!----------------------------------------------------------------------- +!---- termination routine for atmospheric model ---- + + call atmosphere_end (Atmos % Time, Atmos%grid) + if (.not. dycore_only) then + call FV3GFS_restart_write (IPD_Data, IPD_Restart, Atm_block, & + IPD_Control, Atmos%domain) + if (Atmos%write_coarse_restart_files) then + call FV3GFS_restart_write_coarse(IPD_Data, IPD_Restart, Atm_block, & + IPD_Control, Atmos%coarse_domain) + endif + endif + +end subroutine atmos_model_end + +! +!####################################################################### +! +! +! Write out restart files registered through register_restart_file +! +subroutine atmos_model_restart(Atmos, timestamp) + type (atmos_data_type), intent(inout) :: Atmos + character(len=*), intent(in) :: timestamp + + call atmosphere_restart(timestamp) + if (.not. dycore_only) then + if (.not. Atmos%write_only_coarse_intermediate_restarts) then + call FV3GFS_restart_write (IPD_Data, IPD_Restart, Atm_block, & + IPD_Control, Atmos%domain, timestamp) + endif + if (Atmos%write_coarse_restart_files) then + call FV3GFS_restart_write_coarse(IPD_Data, IPD_Restart, Atm_block, & + IPD_Control, Atmos%coarse_domain, timestamp) + endif + endif +end subroutine atmos_model_restart +! + +!####################################################################### +!####################################################################### +! +! +! +! Print checksums of the various fields in the atmos_data_type. +! + +! +! Routine to print checksums of the various fields in the atmos_data_type. +! + +! + +! +! Derived-type variable that contains fields in the atmos_data_type. +! +! +! +! Label to differentiate where this routine in being called from. +! +! +! +! An integer to indicate which timestep this routine is being called for. +! +! +subroutine atmos_data_type_chksum(id, timestep, atm) +type(atmos_data_type), intent(in) :: atm + character(len=*), intent(in) :: id + integer , intent(in) :: timestep + integer :: n, outunit + +100 format("CHECKSUM::",A32," = ",Z20) +101 format("CHECKSUM::",A16,a,'%',a," = ",Z20) + + outunit = stdout() + write(outunit,*) 'BEGIN CHECKSUM(Atmos_data_type):: ', id, timestep + write(outunit,100) ' atm%lon_bnd ', mpp_chksum(atm%lon_bnd ) + write(outunit,100) ' atm%lat_bnd ', mpp_chksum(atm%lat_bnd ) + write(outunit,100) ' atm%lon ', mpp_chksum(atm%lon ) + write(outunit,100) ' atm%lat ', mpp_chksum(atm%lat ) + +end subroutine atmos_data_type_chksum + +! + + subroutine alloc_atmos_data_type (nlon, nlat, Atmos) + integer, intent(in) :: nlon, nlat + type(atmos_data_type), intent(inout) :: Atmos + allocate ( Atmos % lon_bnd (nlon+1,nlat+1), & + Atmos % lat_bnd (nlon+1,nlat+1), & + Atmos % lon (nlon,nlat), & + Atmos % lat (nlon,nlat) ) + + end subroutine alloc_atmos_data_type + + subroutine dealloc_atmos_data_type (Atmos) + type(atmos_data_type), intent(inout) :: Atmos + deallocate (Atmos%lon_bnd, & + Atmos%lat_bnd, & + Atmos%lon, & + Atmos%lat ) + end subroutine dealloc_atmos_data_type + +end module atmos_model_mod diff --git a/atmos_drivers/solo/atmos_model.F90 b/atmos_drivers/solo/atmos_model.F90 new file mode 100644 index 00000000..bcf18d88 --- /dev/null +++ b/atmos_drivers/solo/atmos_model.F90 @@ -0,0 +1,356 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Atmos Drivers project. +!* +!* This is free software: you can redistribute it and/or modify it under +!* the terms of the GNU Lesser General Public License as published by +!* the Free Software Foundation, either version 3 of the License, or (at +!* your option) any later version. +!* +!* It is distributed in the hope that it will be useful, but WITHOUT +!* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +!* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +!* for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS. If not, see . +!*********************************************************************** + +program atmos_model + +!----------------------------------------------------------------------- +! +! Main program for running a stand-alone atmospheric dynamical core. +! +!----------------------------------------------------------------------- + +use atmosphere_mod, only: atmosphere_init, atmosphere_end, atmosphere, atmosphere_domain + +use time_manager_mod, only: time_type, set_time, get_time, & + operator(+), operator (<), operator (>), & + operator (/=), operator (/), operator (*) + +use fms_affinity_mod, only: fms_affinity_init, fms_affinity_set + +use fms_mod, only: check_nml_error, & + error_mesg, FATAL, WARNING, & + mpp_pe, mpp_root_pe, fms_init, fms_end, & + stdlog, stdout, write_version_number, & + mpp_clock_id, mpp_clock_begin, & + mpp_clock_end, CLOCK_COMPONENT +use fms2_io_mod, only: file_exists, ascii_read + +use mpp_mod, only: mpp_set_current_pelist, input_nml_file +use mpp_domains_mod, only: domain2d +use diag_manager_mod, only: diag_manager_init, diag_manager_end, get_base_date + +use field_manager_mod, only: MODEL_ATMOS +use tracer_manager_mod, only: register_tracers +use memutils_mod, only: print_memuse_stats +use constants_mod, only: SECONDS_PER_HOUR, SECONDS_PER_MINUTE +use sat_vapor_pres_mod, only: sat_vapor_pres_init + +implicit none + +!----------------------------------------------------------------------- + +character(len=128), parameter :: version = & +'$Id$' + +character(len=128), parameter :: tag = & +'$Name$' + +!----------------------------------------------------------------------- +! ----- model time ----- +! there is no calendar associated with model of this type +! therefore, year=0, month=0 are assumed + + type (time_type) :: Time, Time_init, Time_end, Time_step_atmos + integer :: num_atmos_calls, na + +! ----- model initial date ----- + + integer :: date_init(6) ! note: year=month=0 + +! ----- timing flags ----- + + integer :: id_init, id_loop, id_end + integer, parameter :: timing_level = 1 + +!----------------------------------------------------------------------- + character(len=80) :: text +!----------------------------------------------------------------------- + type(domain2d), save :: atmos_domain ! This variable must be treated as read-only +!----------------------------------------------------------------------- + + integer, dimension(4) :: current_time = (/ 0, 0, 0, 0 /) + integer :: days=0, hours=0, minutes=0, seconds=0 + integer :: dt_atmos = 0 + integer :: memuse_interval = 72 + integer :: atmos_nthreads = 1 + logical :: use_hyper_thread = .false. + + namelist /main_nml/ current_time, dt_atmos, & + days, hours, minutes, seconds, & + memuse_interval, atmos_nthreads, & + use_hyper_thread + +!####################################################################### + + call fms_init ( ) + call fms_affinity_init + call sat_vapor_pres_init + call atmos_model_init + +! ------ atmosphere integration loop ------- + + call mpp_clock_begin (id_loop) + + do na = 1, num_atmos_calls + + call atmosphere (Time) + + Time = Time + Time_step_atmos + + if(modulo(na,memuse_interval) == 0) then + write( text,'(a,i4)' )'Main loop at timestep=',na + call print_memuse_stats(text) + endif + + enddo + + call mpp_clock_end (id_loop) + +! ------ end of atmospheric time step loop ----- + + call atmos_model_end + call fms_end + +contains + +!####################################################################### + + subroutine atmos_model_init + +!----------------------------------------------------------------------- + integer :: unit, ierr, io, logunit + integer :: ntrace, ntprog, ntdiag, ntfamily + integer :: date(6) + type (time_type) :: Run_length +!$ integer :: omp_get_thread_num + integer :: get_cpu_affinity, base_cpu + character(len=:), dimension(:), allocatable :: restart_file !< Restart file saved as a string + integer :: time_stamp_unit !< Unif of the time_stamp file + integer :: ascii_unit !< Unit of a dummy ascii file +!----------------------------------------------------------------------- +!----- initialization timing identifiers ---- + + id_init = mpp_clock_id ('MAIN: initialization', grain=CLOCK_COMPONENT) + id_loop = mpp_clock_id ('MAIN: time loop' , grain=CLOCK_COMPONENT) + id_end = mpp_clock_id ('MAIN: termination' , grain=CLOCK_COMPONENT) + + logunit = stdlog() + + call mpp_clock_begin (id_init) + +!------------------------------------------- +! how many tracers have been registered? +! (will print number below) + call register_tracers ( MODEL_ATMOS, ntrace, ntprog, ntdiag, ntfamily ) + + +!----- read namelist ------- + + read (input_nml_file, nml=main_nml, iostat=io) + ierr = check_nml_error(io, 'main_nml') + +!----- write namelist to logfile ----- + + call write_version_number (version,tag) + if ( mpp_pe() == mpp_root_pe() ) write (logunit, nml=main_nml) + + if (dt_atmos == 0) then + call error_mesg ('program atmos_model', 'dt_atmos has not been specified', FATAL) + endif + +!----- read restart file ----- + + if (file_exists('INPUT/atmos_model.res')) then + call ascii_read('INPUT/atmos_model.res', restart_file) + read(restart_file(1), *) date + deallocate(restart_file) + else + ! use namelist time if restart file does not exist + date(1:2) = 0 + date(3:6) = current_time + endif + +!----- write current/initial date actually used to logfile file ----- + + if ( mpp_pe() == mpp_root_pe() ) then + write (logunit,16) date(3:6) + endif + + 16 format (' current time used = day',i5,' hour',i3,2(':',i2.2)) + +! print number of tracers to logfile + if (mpp_pe() == mpp_root_pe()) then + write (logunit, '(a,i3)') 'Number of tracers =', ntrace + write (logunit, '(a,i3)') 'Number of prognostic tracers =', ntprog + write (logunit, '(a,i3)') 'Number of diagnostic tracers =', ntdiag + endif + +!----------------------------------------------------------------------- +!------ initialize diagnostics manager ------ + + call diag_manager_init + +!----- always override initial/base date with diag_manager value ----- + +!----- get the base date in the diag_table from the diag_manager ---- +! this base date is typically the starting date for the +! experiment and is subtracted from the current date + + call get_base_date ( date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6) ) + + ! make sure base date does not have a year or month specified + if ( date_init(1)+date_init(2) /= 0 ) then + call error_mesg ('program atmos_model', 'invalid base base - & + &must have year = month = 0', FATAL) + endif + +!----- set initial and current time types ------ +!----- set run length and compute ending time ----- +#ifdef MARS_GCM +! Dont allow minutes in the Mars model + date_init(5)= 0.0 +#endif MARS_GCM + Time_init = set_time(date_init(4)*int(SECONDS_PER_HOUR)+date_init(5)*int(SECONDS_PER_MINUTE)+date_init(6),date_init(3)) + Time = set_time(date (4)*int(SECONDS_PER_HOUR)+date (5)*int(SECONDS_PER_MINUTE)+date (6),date (3)) + Run_length = set_time( hours*int(SECONDS_PER_HOUR)+ minutes*int(SECONDS_PER_MINUTE)+ seconds,days ) + Time_end = Time + Run_length + +!----------------------------------------------------------------------- +!----- write time stamps (for start time and end time) ------ + + if ( mpp_pe().EQ.mpp_root_pe() ) open(newunit = time_stamp_unit, file='time_stamp.out', status='replace', form='formatted') + + if ( mpp_pe() == mpp_root_pe() ) write (time_stamp_unit,20) date + +! compute ending time in days,hours,minutes,seconds + call get_time ( Time_end, date(6), date(3) ) ! gets sec,days + date(4) = date(6)/int(SECONDS_PER_HOUR); date(6) = date(6) - date(4)*int(SECONDS_PER_HOUR) +#ifdef MARS_GCM + date(5) = 0 ; date(6) = date(6) - date(5)*int(SECONDS_PER_MINUTE) +#else + date(5) = date(6)/int(SECONDS_PER_MINUTE) ; date(6) = date(6) - date(5)*int(SECONDS_PER_MINUTE) +#endif + if ( mpp_pe() == mpp_root_pe() ) write (time_stamp_unit,20) date + + if ( mpp_pe().EQ.mpp_root_pe() ) close(time_stamp_unit) + + 20 format (6i7,2x,'day') ! can handle day <= 999999 + +!----------------------------------------------------------------------- +!--- compute the time steps --- +! determine number of iterations through the time integration loop +! must be evenly divisible + + Time_step_atmos = set_time (dt_atmos,0) + num_atmos_calls = Run_length / Time_step_atmos + +!----------------------------------------------------------------------- +!----- initial (base) time must not be greater than current time ----- + + if ( Time_init > Time ) call error_mesg ('program atmos_model', & + 'initial time is greater than current time', FATAL) + +!----- make sure run length is a multiple of atmos time step ------ + + if ( num_atmos_calls * Time_step_atmos /= Run_length ) & + call error_mesg ('program atmos_model', & + 'run length must be multiple of atmosphere time step', FATAL) + +!----------------------------------------------------------------------- +!------ initialize atmospheric model ------ + + !--- setting affinity +!$ call fms_affinity_set('ATMOS', use_hyper_thread, atmos_nthreads) +!$ call omp_set_num_threads(atmos_nthreads) + if (mpp_pe() .eq. mpp_root_pe()) then + unit=stdout() + write(unit,*) ' starting ',atmos_nthreads,' OpenMP threads per MPI-task' + call flush(unit) + endif + + call atmosphere_init (Time_init, Time, Time_step_atmos) + call atmosphere_domain(atmos_domain) + +!----------------------------------------------------------------------- +! open and close dummy file in restart dir to check if dir exists + call mpp_set_current_pelist() + if ( mpp_pe().EQ.mpp_root_pe() ) then + open(newunit = ascii_unit, file='RESTART/file', status='replace', form='formatted') + close(ascii_unit,status="delete") + endif + +! ---- terminate timing ---- + call mpp_clock_end (id_init) + +!----------------------------------------------------------------------- + + call print_memuse_stats('atmos_model_init') + end subroutine atmos_model_init + +!####################################################################### + + subroutine atmos_model_end + + integer :: date(6) + integer :: restart_unit !< Unit for the coupler restart file +!----------------------------------------------------------------------- + call mpp_clock_begin (id_end) + + call atmosphere_end + +!----- compute current time in days,hours,minutes,seconds ----- + + date(1:2) = 0 + call get_time ( Time, date(6), date(3) ) + date(4) = date(6)/int(SECONDS_PER_HOUR); date(6) = date(6) - date(4)*int(SECONDS_PER_HOUR) +#ifdef MARS_GCM + date(5) = 0 ; date(6) = date(6) - date(5)*int(SECONDS_PER_MINUTE) +#else + date(5) = date(6)/int(SECONDS_PER_MINUTE); date(6) = date(6) - date(5)*int(SECONDS_PER_MINUTE) +#endif MARS_GCM + +!----- check time versus expected ending time ---- + + if (Time /= Time_end) call error_mesg ('program atmos_model', & + 'final time does not match expected ending time', WARNING) + +!----- write restart file ------ + + if ( mpp_pe() == mpp_root_pe() ) then + open(newunit = restart_unit, file='RESTART/atmos_model.res', status='replace', form='formatted') + write (restart_unit,'(6i6,8x,a)') date, & + 'Current model time: year, month, day, hour, minute, second' + close(restart_unit) + endif + +!----- final output of diagnostic fields ---- + call diag_manager_end (Time) + + call mpp_clock_end (id_end) +!----------------------------------------------------------------------- + + end subroutine atmos_model_end + +!####################################################################### +! routines to set/get date when no calendar is set (i.e., yr=0 and mo=0) +!####################################################################### + +end program atmos_model + diff --git a/gsmphys/GFDL_parse_tracers.F90 b/gsmphys/GFDL_parse_tracers.F90 new file mode 100644 index 00000000..c8112710 --- /dev/null +++ b/gsmphys/GFDL_parse_tracers.F90 @@ -0,0 +1,41 @@ +module parse_tracers + + integer, parameter :: NO_TRACER = -99 + + public get_tracer_index, NO_TRACER + +CONTAINS + + function get_tracer_index (tracer_names, name, me, master, debug) + + character(len=32), intent(in) :: tracer_names(:) + character(len=*), intent(in) :: name + integer, intent(in) :: me + integer, intent(in) :: master + logical, intent(in) :: debug + !--- local variables + integer :: get_tracer_index + integer :: i + + get_tracer_index = NO_TRACER + + do i=1, size(tracer_names) + if (trim(name) == trim(tracer_names(i))) then + get_tracer_index = i + exit + endif + enddo + + if (debug .and. (me == master)) then + if (get_tracer_index == NO_TRACER) then + print *,' PE ',me,' tracer with name '//trim(name)//' not found' + else + print *,' PE ',me,' tracer FOUND:',trim(name) + endif + endif + + return + + end function get_tracer_index + +end module parse_tracers diff --git a/gsmphys/aer_cloud.F b/gsmphys/aer_cloud.F new file mode 100644 index 00000000..5a42dcca --- /dev/null +++ b/gsmphys/aer_cloud.F @@ -0,0 +1,3994 @@ + MODULE aer_cloud + +#ifdef GEOS5 + use MAPL_ConstantsMod, r8 => MAPL_R8 +#endif +#ifdef NEMS_GSM + use physcons, only: MAPL_PI=>con_pi + use machine, only : r8 => kind_phys +#endif + +! according to the models of Nenes & Seinfeld (2003), Fountoukis and Nenes (2005) and Barahona and Nenes (2008, 2009). +! *** Code Developer: Donifan Barahona donifan.o.barahona@nasa.gov +! +!======================================================================= +! + + implicit none + private + + public :: aerosol_activate + public :: AerConversion + public :: AerConversion1 + public :: AerProps + public :: getINsubset + public :: init_Aer + public :: aer_cloud_init + public :: vertical_vel_variance + + + integer, parameter :: nsmx_par=20, npgauss=10 + + + + type :: AerProps +! sequence + real, dimension(nsmx_par) :: num, dpg, sig, den, kap + &, fdust, fsoot, forg + integer :: nmods + end type AerProps + + interface assignment (=) + module procedure copy_aer + end interface + + +!================================================================== + + +! +!================================================================= + +! + real*8, dimension(npgauss) :: xgs_par, wgs_par +! + +!Global aux variables + + type(AerProps) :: AerPr_base_clean, AerPr_base_polluted + + real*8 :: base_mass_so4_polluted, base_mass_so4_clean, + & base_mass_ss, frac_dust(5), frac_bc, frac_org, + & ahet_dust(5), ahet_bc + +!================================================================== + +! +!================================================================= + + real*8 :: sh_ice, doin_ice,vmin_ice, acorr_dust, acorr_bc + &, denw_par, cpair_par, dhv_par + + integer :: typeofspec_ice + logical :: purehet_ice, purehom_ice, is_gocart + +!================================================================== +! +!========================== + + integer, parameter :: maxit_par=100 + + real, parameter :: amw_par=18d-3, ama_par=29d-3 + &, grav_par=9.81d0, rgas_par=8.31d0 + &, accom_par=1.0d0, eps_par=1d-6 + &, zero_par=1.0e-20, great_par=1d20 + &, pi_par=3.1415927d0, sq2pi_par=sqrt(pi_par) + &, sq2_par=1.41421356237d0 +! + &, wmw_ice=018d0, amw_ice=0.029d0 + &, rgas_ice=8.314d0, grav_ice=9.81d0 + &, cpa_ice=1005.1d0, pi_ice=pi_par + &, depcoef_ice=0.1d0, thaccom_ice=0.7d0 +! + &, To_ice=272.15d0, Tmin_ice=185.d0 + &, Pmin_ice=100.0d0, Thom=236.0d0 + &, rv_ice=rgas_ice/wmw_ice + + + CONTAINS + + subroutine aer_cloud_init() + + real*8 :: daux, sigaux + integer ::ix + + call AerConversion_base + + acorr_dust = 2.7e7 + acorr_bc = 8.0e7 + + do ix = 1, 5 + daux = AerPr_base_polluted%dpg(ix) + sigaux = AerPr_base_polluted%sig(ix) + frac_dust(ix) = 0.5d0*(1d0 + & - erfapp(log(0.1e-6/daux)/(sigaux*sq2_par))) + + ahet_dust(ix) = daux*daux*daux*0.52*acorr_dust + & * exp(4.5*sigaux*sigaux) + + end do + + + daux = AerPr_base_polluted%dpg(12) + sigaux = AerPr_base_polluted%sig(12) + frac_bc = 0.5d0*(1d0-erfapp(log(0.1e-6/daux)/(sigaux*sq2_par))) + ahet_bc = daux*daux*daux*0.52*acorr_bc* exp(4.5*sigaux*sigaux) + + daux = AerPr_base_polluted%dpg(13) + sigaux = AerPr_base_polluted%sig(13) + frac_org = 0.5d0*(1d0-erfapp(log(0.1e-6/daux)/(sigaux*sq2_par))) + + end subroutine aer_cloud_init + + + +! SUBROUTNE AEROSOL ACTIVATE: sets the variables needed for +!the activation subroutines and return the activated droplet and ice number concentration + +! ===============Input=============: +! tparc_in = T (K) +! pparc_in = P (pa) +! sigwparc_in = variance of the distribution of updraft velocity (m s-1) +! wparc_ls = mean of the distribution of updraft velocity (m s-1) +! Aer_Props = AerProps structure containing the aerosol properties Aerosol number concentration (Kg-1) +! npre_in = number concentration of prexisting ice crystals (#/Kg) +! dpre_in = mass-weighted diameter of prexisting ice crystals (m) +! ccn_diagr8 = array of supersaturations for CCN diagnostics (in-out) + +! Ndropr8 = Current droplet number concentration (Kg -1) +! qc = Liquid water mixing ratio (Kg/Kg) +! use_average_v = .false. integrate over the updraft distribution. True: use the mean vertical velocity +! CCN_param = CCN activation parameterization. 1- Fountoukis and Nenes (2005), 2-Abdul_Razzak and Ghan (2002) (def = 2) +! IN_param = IN activation spectrum (default is 5) +! ===============Output=============: + +! cdncr8 = Activated cloud droplet number concentration (Kg-1) +! smaxliqr8 = Maximum supersaturation w.r.t liquid during droplet activation +! incr8 = Nucleated ice crystal concentration (Kg-1) +! smaxicer8 = Maximum supersaturation w.r.t. ice during ice nucleation +! nheticer8 = Nucleated ice crystal concentration by het freezing (Kg-1) +! INimmr8 = Nucleated nc by droplet immersion freezing in mixed-phase clouds (Kg-1) +! dINimmr8 = Ice crystal number tendency by immersion freezing (Kg-1 s-1) +! Ncdepr8 = Nucleated nc by deposition ice nucleation (Kg-1) +! Ncdhfr8 = Nucleated nc by immersion in aerosol (Kg -1) +! sc_icer8 = Critical saturation ratio in cirrus +! fdust_depr8 = Fraction of deposition ice nuclei that are dust +! fdust_immr8 = Fraction of immersion mixed-phase ice nuclei that are dust +! fdust_dhfr8 = Fraction of immersion ice nuclei that are dust (not mixed-phase) +! nlimr8 = Limiting ice nuclei concentration (m-3) + +!=================================================================================== + + + subroutine aerosol_activate(tparc_in, pparc_in, sigwparc_in, + & wparc_ls, Aer_Props, npre_in, dpre_in, ccn_diagr8, Ndropr8, + & cdncr8, smaxliqr8, incr8, smaxicer8, nheticer8, INimmr8, + & dINimmr8, Ncdepr8, Ncdhfr8, sc_icer8, fdust_immr8, fdust_depr8, + & fdust_dhfr8, nlimr8, use_average_v, CCN_param, IN_param, fd_dust, + & fd_soot, pfrz_inc_r8, sigma_nuc, rhi_cell,nccn) + + + + + type(AerProps), intent(in) :: Aer_Props + + logical :: use_average_v + + real(r8), intent(in) :: tparc_in, pparc_in, sigwparc_in, + & wparc_ls, npre_in, dpre_in, Ndropr8, fd_soot, fd_dust, + & sigma_nuc, rhi_cell + integer, intent(in) :: CCN_param, IN_param, nccn + + real(r8), dimension(:), intent(inout) :: ccn_diagr8 + + real(r8), intent(out) :: cdncr8, smaxliqr8, incr8, smaxicer8, + & nheticer8, INimmr8, dINimmr8, Ncdepr8, Ncdhfr8, sc_icer8, + & fdust_immr8, fdust_depr8, fdust_dhfr8, nlimr8, pfrz_inc_r8 + + type(AerProps) :: Aeraux + + + integer :: k, n, I, J, naux + + + real*8 :: nact, wparc, tparc,pparc, accom,sigw, smax, antot, + & ccn_at_s, sigwparc +! real*8, allocatable, dimension(:) :: smax_diag + real*8, dimension(nccn) :: smax_diag + + + real*8 :: nhet, nice, smaxice, nlim, air_den, frac, norg, nbc, + & nhom, dorg, dbc, kappa, INimm, dINimm, aux + +!Anning Cheng move allocable array here for thread safety, 5/4/2016 +! real*8, allocatable, dimension(:) :: sg_par, tp_par, dpg_par, + real*8, dimension(nsmx_par) :: sg_par, tp_par, dpg_par + &, sig_par, vhf_par, ams_par + &, dens_par, deni_par, amfs_par + &, kappa_par, ndust_ice, sigdust_ice + &, ddust_ice +! real*8, allocatable, dimension(:) :: ndust_ice, sigdust_ice, +! & ddust_ice + real*8 :: temp_par, pres_par + real*8 :: akoh_par, alfa_par, bet2_par + real*8 aka_par, dv_par, psat_par, dair_par,surt_par,ddry_ice, + & np_ice,nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice, + & g1_ice, g2_ice,gdoin_ice, z_ice, norg_ice, sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,Nhet_dep,fdust_imm,fdust_dep,fdust_dhf, + & waux_ice,fdrop_dust,fdrop_bc,D_preex, N_preex, + & one_over_tao_preex,P_ice, T_ice,miuv_ice,Nhet_dhf,denice_ice, + & vpresw_ice,vpresi_ice,denair_ice + real*8 :: ntot + integer :: nmodes,act_param,nbindust_ice + logical :: use_av_v + +!=============inputs================ + tparc = tparc_in + pparc = pparc_in + sigwparc = sigwparc_in + miuv_ice = wparc_ls + air_den = pparc*28.8d-3/rgas_par/tparc + N_preex = max(npre_in*air_den, zero_par) + D_preex = max(dpre_in, 1.0e-9) + use_av_v = use_average_v + act_param = 2 + typeofspec_ice = 5 + + + + smaxicer8 = zero_par + smaxice = zero_par + cdncr8 = zero_par + smaxliqr8 = zero_par + incr8 = zero_par + smaxice = max(2.349d0-(tparc/259d0) -1.0 , 0.0) + nheticer8 = zero_par + nlimr8 = zero_par + sc_ice = max(2.349d0-(tparc/259d0), 1.0) + If (tparc > Thom) sc_ice =1.0 + + INimmr8 = zero_par + dINimmr8 = zero_par + Ncdepr8 = zero_par + Ncdhfr8 = zero_par + fdust_immr8 = zero_par + fdust_dhfr8 = zero_par + fdust_depr8 = zero_par + fdust_imm = zero_par + fdust_dhf = zero_par + fdust_dep = zero_par + pfrz_inc_r8 = zero_par + + nact = zero_par + smax = zero_par + sc_icer8 = sc_ice + + is_gocart = .true. + + if (sum(Aer_Props%num) <= 1.0e2) then + return + end if + + nmodes = max(Aer_Props%nmods, 1) + +! allocate (dpg_par(nmodes)) +! allocate (vhf_par(nmodes)) +! allocate (ams_par(nmodes)) +! allocate (dens_par(nmodes)) +! allocate (sig_par(nmodes)) +! allocate (tp_par(nmodes)) +! allocate (amfs_par(nmodes)) +! allocate (deni_par(nmodes)) +! allocate (sg_par(nmodes)) +! allocate (smax_diag(size(ccn_diagr8))) + +! allocate (kappa_par(nmodes)) + + + smax_diag = 0.01 + sigw = zero_par + do n=1,nmodes + dpg_par(n) = zero_par + vhf_par(n) = zero_par + ams_par(n) = zero_par + dens_par(n) = zero_par + sig_par(n) = 1d0 + tp_par(n) = zero_par + amfs_par(n) = zero_par + deni_par(n) = zero_par + kappa_par(n) = zero_par + enddo + + call init_Aer(Aeraux) + + do n=1,nmodes + tp_par(n) = DBLE(Aer_Props%num(n))*air_den + dpg_par(n) = max(DBLE(Aer_Props%dpg(n)), 1.0e-10) + sig_par(n) = DBLE(Aer_Props%sig(n)) + kappa_par(n) = max(DBLE(Aer_Props%kap(n)), 0.001) + dens_par(n) = DBLE(Aer_Props%den(n)) + vhf_par(n) = 3.0 + if (kappa_par(n) > 0.01) then + ams_par(n) = 18.0e-3*1.7*3.0/kappa_par(n) + else + ams_par(n) = 900.0e-3 + tp_par(n) = 0.0 + endif + amfs_par(n) = 1.0 + deni_par(n) = dens_par(n) + enddo + + kappa_par = max(kappa_par, 0.001) + dpg_par = max(dpg_par, 1.0e-10) + temp_par = max(tparc, 245.0) + pres_par = max(pparc, 34000.0) + + antot = sum(tp_par) + ntot = antot + + wparc = max(max(0.8d0*sigwparc, 0.01)+ wparc_ls, 0.01) + + + act_param = CCN_param + +!============== Calculate cloud droplet number concentration=================== + + if (tparc > 245.0) then + if (antot > 1.0) then + + call ccnspec (tparc,pparc,nmodes + &, amfs_par,dens_par,deni_par,vhf_par,ams_par + &, sg_par,tp_par,akoh_par,surt_par,temp_par,pres_par + &, dv_par,act_param,aka_par, psat_par,dair_par + &, ntot,dpg_par) + + if (wparc >= 0.005) then + if (act_param > 1) then + + call arg_activ (wparc,0.d0,nact,smax,nmodes,tp_par + &, dpg_par,kappa_par,sig_par,temp_par, pres_par) + + else + + call pdfactiv (wparc,0.d0,nact,smax,nmodes + &, alfa_par,bet2_par,akoh_par,sg_par,tp_par + &, temp_par, pres_par,aka_par, dv_par, psat_par + &, dair_par,ntot,sig_par) + + endif + endif + + cdncr8 = max(nact/air_den, zero_par) + smaxliqr8 = max(smax, zero_par) + +!============ Calculate diagnostic CCN number concentration================== + + smax_diag = ccn_diagr8 + +! do k =1, size (smax_diag) + do k =1, nccn + call ccn_at_super (smax_diag(k), ccn_at_s,nmodes, + & sig_par,sg_par,tp_par) + ccn_diagr8 (k) = ccn_at_s + end do + + end if + end if + + +! ========================================================================================== +! ========================================================================================== +!========================== Ice crystal nucleation parameterization ====================== +! ========================================================================================== + dbc_ice = 1.0e-9 + nbc_ice = zero_par + norg_ice = zero_par + dorg_ice = 1.0e-9 + sigbc_ice = zero_par + sigorg_ice = zero_par + ddry_ice = 1.0e-9 + np_ice = zero_par + nin_ice = 0. + kdust_ice = 0. + kbc_ice = 0. + shdust_ice = 0. + shbc_ice = 0. + effdust_ice = 0. + effbc_ice = 0. + del1dust_ice = 0. + si0dust_ice = 0. + del1bc_ice = 0. + si0bc_ice = 0. + + naux = 0 + do k = 1, nmodes + if (kappa_par(k) > 0.1) then + np_ice = np_ice + tp_par(k) + ddry_ice = ddry_ice + dpg_par(k) + naux = naux + 1 + end if + end do + ddry_ice = ddry_ice/max(naux , 1) + frac = 1.0 + np_ice = frac*np_ice + +!get dust from input structure + + call getINsubset(1, Aer_Props, Aeraux) + nbindust_ice = max(Aeraux%nmods, 1) + +! allocate(ndust_ice(nbindust_ice)) +! allocate(sigdust_ice(nbindust_ice)) +! allocate(ddust_ice(nbindust_ice)) + + + do n=1,nbindust_ice + ddust_ice(n) = DBLE(Aeraux%dpg(n)) + ndust_ice(n) = DBLE(Aeraux%num(n))*air_den + sigdust_ice(n) = DBLE(Aeraux%sig(n)) + enddo + + +!Black carbon. Only a single mode considered. Use average size and sigma + + call getINsubset(2, Aer_Props, Aeraux) + naux = max(Aeraux%nmods, 1) + dbc_ice = DBLE(sum(Aeraux%dpg(1:naux)))/naux + nbc_ice = DBLE(sum(Aeraux%num(1:naux)))*air_den + sigbc_ice = DBLE(sum(Aeraux%sig(1:naux)))/naux + + + + call getINsubset(3, Aer_Props, Aeraux) + naux = max(Aeraux%nmods, 1) + dorg_ice = DBLE(sum(Aeraux%dpg(1:naux)))/naux + norg_ice = DBLE(sum(Aeraux%num(1:naux)))*air_den + sigorg_ice = DBLE(sum(Aeraux%sig(1:naux)))/naux + + + nhet = zero_par + nice = zero_par + nlim = zero_par + INimm = zero_par + dINimm = zero_par + Nhet_dep = zero_par + Nhet_dhf = zero_par + antot=sum(ndust_ice)+ norg_ice+ nbc_ice+ np_ice + + sigwparc=max(0.01, sigwparc) + sigwparc=min(5.0, sigwparc) + waux_ice=max(wparc_ls + sigwparc*0.8, 0.01) + + +!===========Calculate nucleated crystal number. Follows Barahona and Nenes (2008, 2009)============== + + purehet_ice= .FALSE. + purehom_ice= .FALSE. + + + if (antot > 1.0e2) then + if (tparc < To_ice) then + + CALL prop_ice(tparc, pparc, denice_ice,ddry_ice + &, nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice + &, g1_ice, g2_ice,gdoin_ice, z_ice,lambda_ice + &, kdust_ice, kbc_ice, shdust_ice, shbc_ice + &, effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice + &, si0bc_ice,nbc_ice,D_preex, N_preex + &, one_over_tao_preex,P_ice, T_ice,act_param + &, ndust_ice,vpresw_ice,vpresi_ice,denair_ice) + + + if (tparc > Thom) then + + fdrop_dust = fd_dust + fdrop_bc = fd_soot + + if (sum(ndust_ice)+ norg_ice+ nbc_ice .gt. 1.e3) then + + call INimmersion(INimm, dINimm, waux_ice,dbc_ice,sigbc_ice + &, nbc_ice,fdust_imm,fdrop_dust,fdrop_bc,ndust_ice + &, sigdust_ice,ddust_ice,nbindust_ice + &, vpresw_ice,vpresi_ice,T_ice) + + + ndust_ice = max(ndust_ice*(1.0-fdrop_dust), 0.0) + nbc_ice = max(nbc_ice*(1.0-fdrop_bc), 0.0) + + + call IceParam (sigwparc, denice_ice,ddry_ice,np_ice + &, nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice + &, g1_ice, g2_ice,gdoin_ice, z_ice,lambda_ice,sc_ice + &, norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice + &, kdust_ice, kbc_ice, shdust_ice, shbc_ice + &, effdust_ice, effbc_ice, del1dust_ice, si0dust_ice + &, del1bc_ice, si0bc_ice,nbc_ice,one_over_tao_preex + &, nhet, nice, smaxice, nlim,Nhet_dep,Nhet_dhf,fdust_dep + &, P_ice,T_ice,ndust_ice,sigdust_ice,ddust_ice,nbindust_ice + &, use_av_v,miuv_ice,vpresw_ice,vpresi_ice,denair_ice) + end if + + sc_ice = 1.0 + + else + + call IceParam (sigwparc, denice_ice,ddry_ice,np_ice + &, nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice + &, g1_ice, g2_ice,gdoin_ice, z_ice,lambda_ice,sc_ice + &, norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice + &, kdust_ice, kbc_ice, shdust_ice, shbc_ice + &, effdust_ice, effbc_ice, del1dust_ice, si0dust_ice + &, del1bc_ice, si0bc_ice,nbc_ice,one_over_tao_preex + &, nhet, nice, smaxice, nlim,Nhet_dep,Nhet_dhf,fdust_dep + &, P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice + &, use_av_v,miuv_ice,vpresw_ice,vpresi_ice,denair_ice) + + end if + + aux = (sc_ice - rhi_cell)/(sq2_par*sigma_nuc) + + pfrz_inc_r8 = 1.0d0- 0.5d0*(1.0d0+erf(aux)) + pfrz_inc_r8 = min(max(pfrz_inc_r8, 0.0), 0.999) + + end if + end if + + +!======================== use sc_ice only for cirrus + If (tparc > Thom) sc_ice =1.0 +!========================== + +!All # m-3 except those passed to MG later + smaxicer8 = min(max(smaxice, zero_par), 2.0) + nheticer8 = min(max(nhet, zero_par), 1e10) + incr8 = min(max(nice/air_den, zero_par), 1e10) + nlimr8 = min(max(nlim, zero_par), 1e10) + sc_icer8 = min(max(sc_ice, 1.0), 2.0) + INimmr8 = min(max(INimm, zero_par), 1e10) + dINimmr8 = min(max(dINimm/air_den, zero_par), 1e10) + Ncdepr8 = min(max(Nhet_dep, zero_par), 1e10) + Ncdhfr8 = min(max(Nhet_dhf, zero_par), 1e10) + fdust_immr8 = min(max(fdust_imm, zero_par), 1e10) + fdust_depr8 = min(max(fdust_dep, zero_par), 1e10) + fdust_dhfr8 = min(max(fdust_dhf, zero_par), 1e10) + +! deallocate (ndust_ice) +! deallocate (sigdust_ice) +! deallocate (ddust_ice) +! deallocate (dpg_par) +! deallocate (vhf_par) +! deallocate (ams_par) +! deallocate (dens_par) +! deallocate (sig_par) +! deallocate (tp_par) +! deallocate (amfs_par) +! deallocate (deni_par) +! deallocate (sg_par) +! deallocate (smax_diag) + +! deallocate (kappa_par) + + + +2033 return + + END subroutine aerosol_activate +! + + +!======================================================================= +! +! *** SUBROUTINE AerConversion_base +! *** This subrotine sets basic properties of the aerosol size distributions when using GOCART aerosol +!****Mass-number conversion based on Barahona at al. GMD, 2014. +!======================================================================= + +!Output: + + + +! + SUBROUTINE AerConversion_base () + + integer, parameter :: NMDM = 20 + real, dimension(NMDM) :: TPI, DPGI, SIGI, DENSI, KAPPAS, FDUST, + & FSOOT, FORG, TPI_aux, DPGI_aux, SIGI_aux + + real:: aux + integer:: nmod, K + + do k=1,NMDM + TPI(k) = 0.0 + DPGI(k) = 1.0e-9 + SIGI(k) = 2.0 + DENSI(k) = 2200.0 + KAPPAS(k) = 0.01 + FDUST(k) = 0.0 + FSOOT(k) = 0.0 + FORG(k) = 0.0 + enddo + nmod = 13 + +! Gocart aerosol size distributions for dust + +!!!!!!!!!!!!!!====================================== +!!!!!!!!! Dust +!!!!!!!!!!!!!!====================================== + + + do k=1,5 + SIGI(k) = log(1.8) + DENSI(k) = 1700.0 + KAPPAS(k) = 0.0001 + FDUST(k) = 1.0 + enddo + + + + DPGI (1) = 1.46e-6 + + DPGI (2) = 2.80e-6 + + DPGI (3) = 4.80e-6 +!! Dust 4: 3-6 + DPGI (4) = 9.0e-6 +!! Dust 5: 6-10 + DPGI (5) = 16.0e-6 + + DO K =1 , 5 + TPI(K) = 6.0/(DENSI(K)*pi_par*exp(4.5*SIGI(K)*SIGI(K))*DPGI(K)* + & DPGI(K)*DPGI(K)) + END DO + +!!!!!!!!!!!!!!====================================== +!!!!!!!!! Sea Salt (Using 3 modes based on Barahona et al. GMD. 2014. +!!!!!!!!!!!!!!====================================== + + + + DENSI(6:8) = 2200.0 + KAPPAS(6:8) = 1.28 + + + + TPI (6) = 100e6 + DPGI (6) = .01e-6 + SIGI (6) = log(1.6) + + TPI (7) = 60.0e6 + DPGI (7) = 0.071e-6 + SIGI (7) = log(2.0) + + TPI (8) = 3.1e6 + DPGI (8) = 0.62e-6 + SIGI (8) = log(2.7) + + aux = 0. + DO K =6 , 8 + aux = (TPI(K)*DENSI(K)*pi_par*exp(4.5*SIGI(K)*SIGI(K))*DPGI(K)* + & DPGI(K)*DPGI(K))/6.0 + aux + END DO + base_mass_ss = aux + + + + + KAPPAS(9:11) = 0.65 + DENSI(9:11) = 1650.0 + +! Different size distributions for polluted and clean environments + + + TPI (9) = 1.06e11 + DPGI (9) = .014e-6 + SIGI (9) = log(1.8d0) + + TPI (10) = 3.2e10 + DPGI (10) = 0.054e-6 + SIGI (10) = log(2.16) + + TPI (11) = 5.4e6 + DPGI (11) = 0.86e-6 + SIGI (11) = log(2.21) + + aux = 0. + DO K =9, 11 + aux = (TPI(K)*DENSI(K)*pi_par*exp(4.5*SIGI(K)*SIGI(K))*DPGI(K)* + & DPGI(K)*DPGI(K))/6.0 + aux + END DO + base_mass_so4_polluted = aux + + + + + TPI_aux (9) = 1.0e9 + DPGI_aux (9) = .016e-6 + SIGI_aux (9) = log(1.6d0) + + TPI_aux (10) = 8.0e8 + DPGI_aux (10) = 0.067e-6 + SIGI_aux (10) = log(2.1) + + TPI_aux (11) = 2.0e6 + DPGI_aux (11) = 0.93e-6 + SIGI_aux (11) = log(2.2) + + + aux = 0. + DO K =9, 11 + aux =(TPI_aux(K)*DENSI(K)*pi_par*exp(4.5*SIGI_aux(K)* + & SIGI_aux(K))*DPGI_aux(K)*DPGI_aux(K)*DPGI_aux(K))/6.0 + aux + END DO + base_mass_so4_clean = aux + + + + + DPGI (12) = 0.0118*2.e-6 + SIGI (12) = log(2.00) + DENSI(12) = 1600.0 + KAPPAS(12) = 0.0001 + FSOOT(12) = 1.0 + TPI(12) = 6.0/(DENSI(12)*pi_par*exp(4.5*SIGI(12)*SIGI(12))* + & DPGI(12)*DPGI(12)*DPGI(12)) + + + + DPGI (13) = 0.0212*2.e-6 + SIGI (13) = log(2.20) + DENSI(13) = 900.0 + KAPPAS(13) = 0.0001 + FORG(13) = 1.0 + TPI(13) = 6.0/(DENSI(13)*pi_par*exp(4.5*SIGI(13)*SIGI(13))* + & DPGI(13)*DPGI(13)*DPGI(13)) + + call init_Aer(AerPr_base_polluted) + call init_Aer(AerPr_base_clean) + + + do k=1,nmod + AerPr_base_polluted%num(k) = TPI(k) + AerPr_base_polluted%dpg(k) = DPGI(k) + AerPr_base_polluted%sig(k) = SIGI(k) + AerPr_base_polluted%kap(k) = KAPPAS(k) + AerPr_base_polluted%den(k) = DENSI(k) + AerPr_base_polluted%fdust(k) = FDUST(k) + AerPr_base_polluted%fsoot(k) = FSOOT(k) + AerPr_base_polluted%forg(k) = FORG(k) + enddo + AerPr_base_polluted%nmods = nmod + + AerPr_base_clean = AerPr_base_polluted + AerPr_base_clean%num(9:11) = TPI_aux(9:11) + AerPr_base_clean%dpg(9:11) = DPGI_aux(9:11) + AerPr_base_clean%sig(9:11) = SIGI_aux(9:11) + + RETURN +! + END SUBROUTINE AerConversion_base + + +!======================================================================= +! +! *** SUBROUTINE AerConversion +! *** This subrotine sets the properties of the aerosol distributions +!****Mass-number conversion based on Barahona at al. GMD, 2014. +!======================================================================= +!Input. + +!Output: + + + +! + SUBROUTINE AerConversion (aer_mass, AerPr, kappa, SULFATE, ORG, + & BCARBON, DUST, SEASALT) + + + type(AerProps), intent (out), dimension(:,:,:) :: AerPr + + + real, dimension(:,:,:,:), intent(in) :: aer_mass + real, intent (out), dimension(:,:,:) :: kappa, DUST, SULFATE, + & BCARBON, ORG, SEASALT + real:: aux, densSO4, densORG, k_SO4, k_ORG, k_SS, tot_mass, dens, + & kappa_aux, tx1 + + integer :: i,j,k,l + integer :: im, jm, lm + type(AerProps) :: AeroAux + real, dimension(size(aer_mass,4)) :: aer_mass_tmp + + im = size(aer_mass,1) + jm = size(aer_mass,2) + lm = size(aer_mass,3) + + call init_Aer(AeroAux) + + do k = 1, lm + do j = 1, jm + do i = 1, im + aer_mass_tmp(:) = aer_mass(i,j,k,:) + + + tot_mass = aer_mass_tmp(11) + aer_mass_tmp (15) + & + aer_mass_tmp (14) + densSO4 = 1700.0 + densORG = 1600.0 + k_SO4 = 0.65 + k_ORG = 0.2 + kappa_aux = 0.65 + + + + if (tot_mass > 2.0e-20) then + tx1 = 1.0 / tot_mass + dens = (aer_mass_tmp(11)*densSO4 + & + sum(aer_mass_tmp(14:15))*densORG) * tx1 + kappa_aux = (aer_mass_tmp(11)*k_SO4 + & + sum(aer_mass_tmp(14:15))*k_ORG) * tx1 + else + dens = 1750.0 + kappa_aux = 0.65 + end if + + + if (tot_mass > 5.0e-8) then + AeroAux = AerPr_base_polluted + AeroAux%num(9:11) = AeroAux%num(9:11)*tot_mass + & / base_mass_so4_polluted + else + AeroAux = AerPr_base_clean + AeroAux%num(9:11) = AeroAux%num(9:11)*tot_mass + & / base_mass_so4_clean + end if + + AeroAux%kap(9:11) = max(kappa_aux, 0.001) + AeroAux%den(9:11) = dens + SULFATE(i,j,k) = SUM(AeroAux%num(9:11)) + kappa_aux = kappa_aux*tot_mass + + + + + AeroAux%num(1:5) = AeroAux%num(1:5) *aer_mass_tmp(1:5) + kappa_aux = kappa_aux + & + AeroAux%kap(1)*sum(aer_mass_tmp(1:5)) + DUST(i,j,k) = sum(AeroAux%num(1:5)) + + + tot_mass = sum(aer_mass_tmp(6:10)) + AeroAux%num(6:8) = AeroAux%num(6:8)*tot_mass/base_mass_ss + kappa_aux = kappa_aux + AeroAux%kap(6)*tot_mass + SEASALT(i,j,k ) = sum(AeroAux%num(6:8)) + + + AeroAux%num(12) = AeroAux%num(12) *aer_mass_tmp(13) + kappa_aux = kappa_aux + & + AeroAux%kap(12)*aer_mass_tmp(13) + BCARBON(i,j,k) = AeroAux%num(12) + + + AeroAux%num(13) = AeroAux%num(13) *aer_mass_tmp(15) + ORG(i, j, k) = AeroAux%num(13) + tot_mass = sum(aer_mass_tmp) + + if (tot_mass > 0.0) then + kappa(i,j,k) = kappa_aux/tot_mass + end if + + AerPr(i,j,k) = AeroAux + + end do + end do + end do + + RETURN +! + END SUBROUTINE AerConversion + +!======================================================================= +!======================================================================= +! + SUBROUTINE AerConversion1 (aer_mass, AerPr) + + + type(AerProps), dimension(:,:) :: AerPr +! type(AerProps), intent (out), dimension(:,:) :: AerPr + + + real, dimension(:,:,:) :: aer_mass +! real, dimension(:,:,:), intent(in) :: aer_mass + real:: aux, densSO4, densORG, k_SO4, k_ORG, k_SS, tot_mass, dens, + & kappa_aux, tx1, tx2 + + integer :: i,k,l,im,lm + type(AerProps) :: AeroAux + real, dimension(size(aer_mass,3)) :: aer_mass_tmp + + im = size(aer_mass,1) + lm = size(aer_mass,2) + + call init_Aer(AeroAux) + + do k = 1, lm + do i = 1, im + aer_mass_tmp(:) = aer_mass(i,k,:) + + + tot_mass = aer_mass_tmp(11) + aer_mass_tmp (15) + & + aer_mass_tmp (14) + densSO4 = 1700.0 + densORG = 1600.0 + k_SO4 = 0.65 + k_ORG = 0.2 + kappa_aux = 0.65 + + + + if (tot_mass > 2.0e-20) then + tx1 = 1.0 / tot_mass + tx2 = aer_mass_tmp(14) + aer_mass_tmp(15) + dens = (aer_mass_tmp(11)*densSO4 + tx2*densORG) * tx1 + kappa_aux = (aer_mass_tmp(11)*k_SO4 + tx2*k_ORG) * tx1 + else + dens = 1750.0 + kappa_aux = 0.65 + end if + + + if (tot_mass > 5.0e-8) then + AeroAux = AerPr_base_polluted + AeroAux%num(9:11) = AeroAux%num(9:11)*tot_mass + & / base_mass_so4_polluted + else + AeroAux = AerPr_base_clean + AeroAux%num(9:11) = AeroAux%num(9:11)*tot_mass + & / base_mass_so4_clean + end if + + AeroAux%kap(9:11) = max(kappa_aux, 0.001) + AeroAux%den(9:11) = dens + kappa_aux = kappa_aux*tot_mass + + + + + AeroAux%num(1:5) = AeroAux%num(1:5) *aer_mass_tmp(1:5) + kappa_aux = kappa_aux + & + AeroAux%kap(1)*sum(aer_mass_tmp(1:5)) + + + tot_mass = sum(aer_mass_tmp(6:10)) + AeroAux%num(6:8) = AeroAux%num(6:8)*tot_mass/base_mass_ss + kappa_aux = kappa_aux + AeroAux%kap(6)*tot_mass + + + AeroAux%num(12) = AeroAux%num(12)*aer_mass_tmp(13) + kappa_aux = kappa_aux+AeroAux%kap(12)*aer_mass_tmp(13) + + + AeroAux%num(13) = AeroAux%num(13) *aer_mass_tmp(15) + tot_mass = sum(aer_mass_tmp) + + + AerPr(i,k) = AeroAux + + end do + end do + + RETURN +! + END SUBROUTINE AerConversion1 + +!======================================================================= +!======================================================================= +!======================================================================= + +!*********** Calculate subgrid scale distribution of vertical velocity**** +! ==================================================================== + + subroutine vertical_vel_variance(omeg, lc_turb, tm_gw, pm_gw, + & rad_cool, uwind_gw, tausurf_gw, nm_gw, LCCIRRUS, Nct, Wct, ksa1, + & fcn, KH, FRLAND, ZPBL, Z, maxkhpbl, wparc_ls, wparc_gw, + & wparc_cgw, wparc_turb, LTS) + + + real(r8), intent(in) :: omeg, tm_gw, lc_turb, rad_cool, uwind_gw, + & pm_gw + real , intent(in) :: LCCIRRUS, KH, ZPBL, Z, FRLAND, nm_gw, + & tausurf_gw, ksa1, fcn, maxkhpbl, Nct, Wct, LTS + + real(r8), intent(out) :: wparc_ls, wparc_gw, wparc_cgw, + & wparc_turb + + real(r8) :: rho_gw, k_gw, h_gw, c2_gw, dummyW, maxkh, Wbreak + + + +!!!:========= mean V Large scale and radiative cooling + rho_gw = pm_gw*28.8d-3/rgas_par/tm_gw + + + wparc_ls =-omeg/rho_gw/grav_ice + cpa_ice*rad_cool/grav_ice + +!!!======== Orographic Gravity gwave (and brackground) initiated (According to Barahona et al. 2013 GMD) + + wparc_gw = 0.0 + k_gw = 2d0*pi_par/LCCIRRUS + + h_gw= k_gw*rho_gw*uwind_gw*nm_gw + + if (h_gw .gt. 0.0) then + h_gw=sqrt(2.0*tausurf_gw/h_gw) + else + h_gw = 0.0 + end if + + Wbreak = 0.133*k_gw*uwind_gw/nm_gw + + wparc_gw = k_gw*uwind_gw*h_gw*0.133 + wparc_gw = min(wparc_gw, Wbreak) + wparc_gw = wparc_gw*wparc_gw + + +!!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep + + wparc_cgw = 0.0 + c2_gw = (nm_gw+Nct)/Nct + wparc_cgw = sqrt(ksa1)*fcn*c2_gw*Wct*0.6334 + wparc_cgw = min(wparc_cgw, Wbreak) + wparc_cgw = wparc_cgw*wparc_cgw + +!!!:=========Subgrid scale variance from turbulence + + + wparc_turb=KH/lc_turb + + + if (LTS > 20.0) then + wparc_turb=maxkhpbl/lc_turb + end if + + + wparc_turb= wparc_turb*wparc_turb + + + + end subroutine vertical_vel_variance +!======================================================================= +!======================================================================= +!======================================================================= + +!======================================================================= +!Extracts aerosol props with INactive = typ + subroutine getINsubset(typ, aerin, aerout) + +! typ : type of aerosol needed: 1 dust, 2 soot, 3 organics +! nbins: number of modes with num>0 + + type(AerProps), intent (in) :: aerin + type(AerProps), intent (inout) :: aerout + integer, intent(in) :: typ + + integer:: k, bin + + call init_Aer(aerout) + bin = 0 + + do k=1, aerin%nmods + + if (typ == 1) then + if (aerin%fdust(k) > 0.9) then + bin = bin + 1 + call copy_mode(aerout,aerin, k,bin) + end if + elseif (typ == 2) then + if (aerin%fsoot(k) > 0.9) then + bin = bin + 1 + call copy_mode(aerout,aerin, k,bin) + end if + elseif (typ == 3) then + if (aerin%forg(k) > 0.9) then + bin = bin + 1 + call copy_mode(aerout,aerin, k,bin) + end if + end if + + end do + + aerout%nmods = max(bin, 1) + + end subroutine getINsubset + +!========================subroutines to handle aer strucuture===================================== + + + subroutine copy_Aer(a,b) + + type (AerProps), intent(out) :: a + type (AerProps), intent(in) :: b + + a%num = b%num + a%sig = b%sig + a%dpg = b%dpg + a%kap = b%kap + a%den = b%den + a%fdust = b%fdust + a%fsoot = b%fsoot + a%forg = b%forg + a%nmods = b%nmods + + end subroutine copy_Aer + + subroutine copy_mode(a_out,a_in, mode_in, mode_out) + type (AerProps), intent(out) :: a_out + type (AerProps), intent(in) :: a_in + integer, intent (in) :: mode_in, mode_out + + a_out%num(mode_out)= a_in%num(mode_in) + a_out%sig(mode_out) = a_in%sig(mode_in) + a_out%dpg(mode_out) = a_in%dpg(mode_in) + a_out%kap(mode_out) = a_in%kap(mode_in) + a_out%den(mode_out) = a_in%den(mode_in) + a_out%fdust(mode_out) = a_in%fdust(mode_in) + a_out%fsoot(mode_out) = a_in%fsoot(mode_in) + a_out%forg(mode_out) = a_in%forg(mode_in) + + end subroutine copy_mode + + subroutine init_Aer(aerout) + + type (AerProps), intent(inout) :: aerout + integer n + + do n=1,nsmx_par + aerout%num(n) = 0. + aerout%dpg(n) = 1.0e-9 + aerout%sig(n) = 2.0 + aerout%kap(n) = 0.2 + aerout%den(n) = 2200.0 + aerout%fdust(n) = 0.0 + aerout%fsoot(n) = 0.0 + aerout%forg(n) = 0.0 + enddo + aerout%nmods = 1 + + end subroutine init_Aer + + + +!!!!!!!!!!!!!!====================================== +!!!!!!!!! Subroutine ARG_act: finds the activated droplet number following Abdul_Razzak and Ghan 2000. +!Written by Donifan Barahona +!!donifan.o.barahona@nasa.gov +!!!!!!!!!!!!!!==================================== + + subroutine arg_activ (wparc,sigw,nact,smax,nmodes,tp_par, + & dpg_par,kappa_par,sig_par,temp_par, pres_par) + + + real*8, intent(in) :: wparc, sigw + integer, intent(in):: nmodes + real*8, intent(out) :: nact, smax + real*8 :: SMI(nmodes),tp_par(nmodes) + real*8, dimension(nmodes)::dpg_par,kappa_par,sig_par + + real*8 :: alfa, beta, Akoh, G, T, fi, gi, nui, citai, ui, aux1, + & PACT, auxx, aux,temp_par, pres_par + integer :: I, INDEX + + T = min(max(temp_par, 243.0), 323.0) + alfa=2.8915E-08*(T*T) - 2.1328E-05*T + 4.2523E-03 + beta=exp(3.49996E-04*T*T - 2.27938E-01*T + 4.20901E+01) + G=exp(-2.94362E-06*T*T*T + 2.77941E-03*T*T - 8.92889E-01*T + + & 1.18787E+02) + Akoh= 0.66e-6/T + + + DO I = 1, nmodes + aux =0.667*Akoh/dpg_par(I) + SMI (I) = (aux*sqrt(aux))/SQRT(2.0*kappa_par(I)) + END DO + + + + SMI=MAX(SMI, 1.0e-5) + aux =alfa*wparc*G + aux = aux*sqrt(aux)/(2.d0*pi_par*980.d0*beta) + citai = 0.667*Akoh*SQRT(alfa*wparc*G) + + auxx=0.0 + DO INDEX =1, nmodes + if (tp_par(INDEX) .gt. 0.0) then + fi=0.5*exp(2.5*sig_par(INDEX)) + gi=1.0+0.25*sig_par(INDEX) + nui=aux/tp_par(INDEX) + aux1=fi*((citai/nui)*sqrt(citai/nui)) + gi*(SMI(INDEX)* + &SMI(INDEX) /(nui+(3.0*citai)))**0.75 + aux1=aux1/(SMI(INDEX)*SMI(INDEX)) + auxx=auxx+aux1 + + end if + end do + + + if (auxx .gt. 0.0) then + smax = 1/sqrt(auxx) + else + nact = 0.0 + return + end if + + + auxx = 0.0 + + + DO INDEX = 1, nmodes + ui = sq2_par*log(SMI(INDEX)/smax)/3.0 + aux1 = 0.5*tp_par(INDEX)*(1.0-ERFAPP(ui)) + auxx = auxx + aux1 + END DO + + nact = auxx + + + End Subroutine arg_activ + +!=================================================================================================== + +!=================================================================================================== + + + + +!===================================================================================================== + subroutine ccn_at_super (super,ccn_at_s,nmodes, + & sig_par,sg_par,tp_par) + + integer :: j, I,nmodes + real*8 :: dlgsg, dlgsp, orism5, ndl, nds, super, ccn_at_s + real*8, dimension(nmodes) :: sig_par,sg_par,tp_par + + ndl = 0d0 + + do j=1, nmodes + + dlgsg = sig_par(j) + + if (sg_par(j) .gt. 0.0) then + if (super .gt. 0.0) then + dlgsp = dlog(sg_par(j)/super) + else + dlgsp = dlog(sg_par(j)/0.01) + end if + else + dlgsp = 0.0 + + end if + orism5 = 2.d0*dlgsp/(3d0*sq2_par*dlgsg) + ndl = (tp_par(j)/2.0)*(1.0-erf(orism5))+ndl + + end do + + ccn_at_s = ndl + + end subroutine ccn_at_super + +!======================================================================= + +! subroutine ccnspec +!------------------------------ +! DESCRIPTION +! +! *** subroutine ccnspec +! *** this subroutine calculates the ccn spectrum of the aerosol using +! the appropriate form of kohler theory and assuming a lognormal aerosol size dist +! +! *** written by athanasios nenes +!! +! Code Developer +! Donifan Barahona +! donifanb@umbc.edu +!======================================================================= +! + subroutine ccnspec (tparc,pparc,nmodes, + & amfs_par,dens_par,deni_par,vhf_par,ams_par, + & sg_par,tp_par,akoh_par,surt_par,temp_par,pres_par + & ,dv_par,act_param,aka_par, psat_par,dair_par, + & ntot,dpg_par) +! + + integer :: nmodes,i,j,k + real*8 :: tparc, pparc, amfi,denp,vlfs,par1, par2 + real*8, dimension(nmodes)::amfs_par,dens_par,deni_par, + & vhf_par,ams_par,sg_par,tp_par,dpg_par + real*8 akoh_par,surt_par,temp_par,pres_par, + & aka_par, dv_par, psat_par,dair_par,ntot + integer act_param + + + ntot=zero_par + temp_par = max(tparc, 245.0) + pres_par = max(pparc, 34000.0) +! + call props(pres_par,temp_par,surt_par,dv_par,act_param, + & aka_par, psat_par,dair_par) + + +! + akoh_par = 4d0*amw_par*surt_par/rgas_par/temp_par/denw_par +! + + do k=1,nmodes + + + amfi = max(1.0d0-amfs_par(k),zero_par) + denp = amfs_par(k)*dens_par(k) + amfi*deni_par(k) + vlfs = amfs_par(k)/dens_par(k)/(amfs_par(k)/dens_par(k)+ amfi/ + &deni_par(k)) + par1 = 4d0*denw_par*ams_par(k)/27d0/vhf_par(k)/denp/amw_par/ + & dpg_par(k)**3 + + + par1 = par1/vlfs + par2 = sqrt(max(par1*akoh_par*akoh_par*akoh_par, zero_par)) + sg_par(k)= max(exp(par2) - 1d0, zero_par) + ntot=ntot+tp_par(k) + enddo +! + + +! *** end of subroutine ccnspec **************************************** +! + return + end subroutine ccnspec + + +!======================================================================= +! ------------------------------- +! DESCRIPTION +! +! *** subroutine pdfactiv +! *** this subroutine calculates the ccn activation fraction according +! to the nenes and seinfeld (2003) parameterization, with +! modification for non-contunuum effects as proposed by fountoukis +! and nenes (2005). this routine calculates for a pdf of +! updraft velocities. +! +! *** written by athanasios nenes +! +! Code Developer +! Donifan Barahona +! donifanb@umbc.edu + +!======================================================================= +! + subroutine pdfactiv (wparc,sigw, nact,smax,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par, + & temp_par, pres_par,aka_par, dv_par, psat_par, + & dair_par,ntot,sig_par) +! +! + integer :: i, isec,nmodes + real*8 :: tpart, nact, nacti,wparc,smax,ntot, tx1 + real*8 :: pdf, dpnmx,sigw,plimt,probi,whi,wlo, scal, wpi,smaxi, + & alfa_par,bet2_par,akoh_par,sg_par(nmodes),tp_par(nmodes), + & tparc,pparc,temp_par, pres_par,aka_par, dv_par, psat_par, + & dair_par,sig_par(nmodes) + real*8 :: wpdbg(npgauss), pddbg(npgauss), nadbg(npgauss), + & smdbg(npgauss) +! +! *** case where updraft is very small +! + if (wparc <= 1d-6) then + smax = 0d0 + nact = 0d0 + isec = 1 + dpnmx = great_par + return + endif +! +! *** single updraft case +! + if (sigw < 1e-10) then + call activate (wparc,nact,smax,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par, + & temp_par, pres_par,aka_par, dv_par, psat_par, + & dair_par,ntot,sig_par) + wpdbg(1) = wparc + pddbg(1) = 1.0 + nadbg(1) = nact + smdbg(1) = smax +! +! *** pdf of updrafts +! + else + nact = zero_par + smax = zero_par + plimt = 1e-3 + probi = sqrt(-2.0*log(plimt*sigw*sq2pi_par)) + whi = wparc + sigw*probi + wlo = 0.05 + scal = 0.5*(whi-wlo) + do i=1,npgauss + wpi = wlo + scal*(1.0-xgs_par(i)) + call activate (wpi,nacti,smaxi,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par, + & temp_par, pres_par,aka_par, dv_par, psat_par, + & dair_par,ntot,sig_par) + tx1 = (wpi-wparc)/ sigw + pdf = (1.0/sq2pi_par/sigw) * exp(-0.5*tx1*tx1) + nact = nact + wgs_par(i)*(pdf*nacti) + smax = smax + wgs_par(i)*(pdf*smaxi) + wpdbg(i) = wpi + pddbg(i) = pdf + nadbg(i) = nacti + smdbg(i) = smaxi + if (pdf < plimt) exit + enddo + nact = nact*scal + smax = smax*scal + endif +! + return +! +! *** end of subroutine pdfactiv **************************************** +! + end subroutine pdfactiv + + + +!======================================================================= + +! DESCRIPTION +! +! *** subroutine activate +! *** this subroutine calculates the ccn activation fraction according +! to the nenes and seinfeld (2003) parameterization, with +! modification for non-contunuum effects as proposed by fountoukis +! and nenes (2005). +! + +!======================================================================= +! + subroutine activate (wparc,ndroplet,smax,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par,temp_par, pres_par, + & aka_par, dv_par, psat_par,dair_par,ntot,sig_par) + +! + integer :: i,niter,nmodes + + real*8 :: ndrpl, wparc, beta,cf1, cf2,x1,sinteg1,sinteg2,y1, x2, + &y2,x3,y3, sign,smax, ent_par, ndroplet, nrdpl,bet1_par, + & alfa_par,bet2_par,akoh_par,sg_par(nmodes),tp_par(nmodes), + & temp_par, pres_par,aka_par, dv_par, psat_par,dair_par,ntot, + & wparcel,sig_par(nmodes) +! +! *** setup common block variables +! + wparcel = wparc + + sinteg1=zero_par + sinteg2=zero_par + nrdpl = zero_par + +! *** setup constants +! + alfa_par = grav_par*amw_par*dhv_par/cpair_par/rgas_par/temp_par / + &temp_par -grav_par*ama_par/rgas_par/temp_par + + bet1_par = pres_par*ama_par/psat_par/amw_par + amw_par*dhv_par* + & dhv_par/cpair_par/rgas_par/temp_par/temp_par + bet2_par = rgas_par*temp_par*denw_par/psat_par/dv_par/amw_par/ + & 4d0 +dhv_par*denw_par/4d0/aka_par/temp_par*(dhv_par* amw_par/ + &rgas_par/temp_par - 1d0) + beta = 0.5d0*pi_par*bet1_par*denw_par/bet2_par/alfa_par/ wparc/ + &dair_par + + + cf1 = 0.5d0*(((1.d0/bet2_par)/(alfa_par*wparc))**0.5d0) + cf2 = akoh_par/3d0 + +! +! *** INITIAL VALUES FOR BISECTION ************************************** + +! *** initial values for bisection ************************************** +! + x1 = 1.0d-5 + + if (ntot .gt. zero_par) then + call sintegral (x1,ndrpl,sinteg1,sinteg2,wparcel,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par,sig_par) + end if + + y1 = (sinteg1*cf1+sinteg2*cf2)*beta*x1 - 1d0 +! + x2 = 1d0 + if (ntot .gt. zero_par) then + call sintegral (x2,ndrpl,sinteg1,sinteg2,wparcel,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par,sig_par) + end if + + y2 = (sinteg1*cf1+sinteg2*cf2)*beta*x2 - 1d0 +! +! *** perform bisection ************************************************* +! +20 do 30 i=1,maxit_par + x3 = 0.5*(x1+x2) +! + if (ntot .gt. zero_par) then + call sintegral (x3,ndrpl,sinteg1,sinteg2,wparcel,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par,sig_par) + end if + + y3 = (sinteg1*cf1+sinteg2*cf2)*beta*x3 - 1d0 + + if (sign(1.d0,y1)*sign(1.d0,y3) .le. zero_par) then +! ! (y1*y3 .le. zero) + y2 = y3 + x2 = x3 + else + y1 = y3 + x1 = x3 + endif +! + if (abs(x2-x1) .le. eps_par*x1) goto 40 + niter = i + + +30 continue +! +! *** converged ; return ************************************************ +! +40 x3 = 0.5*(x1+x2) +! + if (ntot .gt. zero_par) then + call sintegral (x2,ndrpl,sinteg1,sinteg2,wparcel,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par,sig_par) + end if + + + y3 = (sinteg1*cf1+sinteg2*cf2)*beta*x3 - 1d0 + smax = x3 + + ndroplet=ndrpl + return +! +! *** end of subroutine activate **************************************** +! + end subroutine activate + + +!======================================================================= +! +! *** subroutine sintegral +! *** this subroutine calculates the condensation integrals, according +! to the population splitting algorithm of nenes and seinfeld (2003) +! modal formulation according to fountoukis and nenes (2004) +! +! *** written by athanasios nenes +! +!! Code Developer +! Donifan Barahona +! donifanb@umbc.edu +!======================================================================= +! + subroutine sintegral (spar, summa, sum, summat,wparcel,nmodes, + & alfa_par,bet2_par,akoh_par,sg_par,tp_par,sig_par) + +! + integer ::j,i,k,nmodes + real*8 :: sum, summat, summa, nd(nsmx_par), integ1(nsmx_par), + & integ2(nsmx_par),alfa_par,bet2_par,akoh_par,sg_par(nmodes), + & tp_par(nmodes),sig_par(nmodes) + real*8 :: descr,spar,ratio, ssplt2, ssplt1, sqrt, ssplt, sqtwo, + & dlgsg,dlgsp, ekth,wparcel + real*8 :: orism1, orism2, orism3, orism4, orism5 +! +! *** here is where the criterion with the descriminant is put. when it +! is < 0, then set crit2 = .true. otherwise, set the two values of +! ssplt and continue. +! + descr = 1d0 - (16d0/9d0)*alfa_par*wparcel*bet2_par* (akoh_par/ + &spar**2)**2 +! + if (descr.le.0d0) then + ratio = (2.0d7/3.0)*akoh_par*spar**(-0.3824) + if (ratio.gt.1.0) ratio = 1.0 + ssplt2 = spar*ratio + else + ssplt1 = 0.5d0*(1d0-sqrt(descr)) + ssplt2 = 0.5d0*(1d0+sqrt(descr)) + ssplt1 = sqrt(ssplt1)*spar + ssplt2 = sqrt(ssplt2)*spar + endif +! + ssplt = ssplt2 +! +! *** calculate integrals +! + sum = 0 + summat = 0 + summa = 0 +! + sqtwo = sqrt(2d0) + +! + do 999 j = 1, nmodes +! + dlgsg = sig_par(j) + dlgsp = dlog(sg_par(j)/spar) + orism1 = 2.d0*dlog(sg_par(j)/ssplt2)/(3.d0*sqtwo*dlgsg ) + orism2 = orism1 - 3.d0*dlgsg/(2.d0*sqtwo) + orism3 = 2.d0*dlgsp/(3.d0*sqtwo*dlgsg)-3.d0*dlgsg/(2.d0*sqtwo) + orism4 = orism1 + 3.d0*dlgsg/sqtwo + orism5 = 2.d0*dlgsp/(3*sqtwo*dlgsg) + ekth = exp(9d0/2d0*dlgsg*dlgsg) + integ1(j) = tp_par(j)*spar*((1-erf(orism1)) - 0.5d0*((sg_par(j)/ + &spar)**2)*ekth*(1-erf(orism4))) + + integ2(j) = (exp(9d0/8d0*dlgsg*dlgsg)*tp_par(j)/sg_par(j))* + & (erf(orism2) - erf(orism3)) +! +! *** calculate number of drops +! + nd(j) = (tp_par(j)/2.0)*(1.0-erf(orism5)) +! + sum = sum + integ1(j) + summat = summat + integ2(j) + summa = summa + nd(j) +999 continue +! + return + end subroutine sintegral + +!======================================================================= + +! DESCRIPTION +! +! *** subroutine props +! *** this subroutine calculates the thermophysical properties for the CCN activ param +! +! *** written by athanasios nenes +! Code Developer +! Donifan Barahona +! donifanb@umbc.edu + +!======================================================================= +! + subroutine props(pres_par,temp_par,surt_par,dv_par,act_param, + & aka_par, psat_par,dair_par) +! +! + real*8 :: presa,dbig,dlow,coef,aka_par, dv_par, psat_par + real*8 :: pres_par,temp_par,surt_par,dair_par + integer act_param +! + denw_par = 1d3 + dhv_par = 2.25d6 + cpair_par = 1.0061d3 + presa = pres_par/1.013d5 + dair_par = pres_par*ama_par/rgas_par/temp_par + aka_par = (4.39+0.071*temp_par)*1d-3 + surt_par = sft(temp_par) + + if (act_param .le. 1) then + dv_par = (0.211d0/presa)*(temp_par/273d0)**1.94 + dv_par = dv_par*1d-4 + dbig = 5.0d-6 + dlow = 0.207683*((accom_par)**(-0.33048)) + dlow = dlow*1d-6 + + + + coef = ((2*pi_par*amw_par/(rgas_par*temp_par))**0.5) + + dv_par = (dv_par/(dbig-dlow))*((dbig-dlow)-(2*dv_par/accom_par) * + &coef*(dlog((dbig+(2*dv_par/accom_par)*coef)/(dlow+ (2*dv_par/ + &accom_par)*coef)))) + + psat_par = vpres(temp_par)*(1e5/1.0d3) + + + + end if +! + return +! +! *** end of subroutine props ******************************************* +! + end subroutine props + + + +!PHYSICAL PROPERTIES for Nenes CDNC Activation + + + +!======================================================================= +! +! *** function vpres +! *** this function calculates saturated water vapour pressure as a +! function of temperature. valid for temperatures between -50 and +! 50 c. +! +! ======================== arguments / usage =========================== +! +! input: +! [t] +! real variable. +! ambient temperature expressed in kelvin. +! +! output: +! [vpres] +! real variable. +! saturated vapor pressure expressed in mbar. +! +!======================================================================= +! + real*8 function vpres (t) +! + integer ::i + real*8 :: a(0:6), t,ttemp, vp + data a/6.107799610e+0, 4.436518521e-1, 1.428945805e-2, + & 2.650648471e-4, 3.031240396e-6, 2.034080948e-8, 6.136820929e-11/ +! +! calculate polynomial (without exponentiation). +! + ttemp = t-273.0d0 + vp = a(6)*ttemp + do i=5,1,-1 + vp = (vp + a(i))*ttemp + enddo + vpres = vp + a(0) +! +! end of function vpres +! + return + end function vpres + + + +!======================================================================= +! +! *** function sft +! *** this function calculates water surface tension as a +! function of temperature. valid for temperatures between -40 and +! 40 c. +! +! ======================== arguments / usage =========================== +! +! input: +! [t] +! real variable. +! ambient temperature expressed in kelvin. +! +! output: +! [sft] +! real variable. +! surface tension expressed in j m-2. +! +!======================================================================= +! + real*8 function sft (t) +! + implicit none + +! + real*8 :: t,tpars +! + tpars = t-273.15d0 + sft = 0.0761-1.55e-4*tpars +! + return + end function sft + + +! *********************************************************************** +! + subroutine gauleg (x,w,n) +! +! calculation of points and weights for n point gauss integration +! *********************************************************************** +! + integer :: n,m,i,j + real*8 :: x(n), w(n),xm,xl,z,p1,p2,p3,pp,z1 + real*8, parameter :: eps_par=1.e-6 + real*8, parameter :: x1=-1.0, x2=1.0 +! +! calculation +! + m=(n+1)/2d0 + xm=0.5d0*(x2+x1) + xl=0.5d0*(x2-x1) + do 12 i=1,m + z=cos(pi_par*(i-.25d0)/(n+.5d0)) + 1 continue + p1=1.d0 + p2=0.d0 + do 11 j=1,n + p3=p2 + p2=p1 + p1=((2.d0*j-1.)*z*p2-(j-1.d0)*p3)/j + 11 continue + pp=n*(z*p1-p2)/(z*z-1.d0) + z1=z + z=z1-p1/pp + if(abs(z-z1).gt.eps_par)go to 1 + x(i)=xm-xl*z + x(n+1-i)=xm+xl*z + w(i)=2.d0*xl/((1.d0-z*z)*pp*pp) + w(n+1-i)=w(i) + 12 continue + return + end subroutine gauleg + +!C======================================================================= +!C +!C *** REAL FUNCTION erf (overwrites previous versions) +!C *** THIS SUBROUTINE CALCULATES THE ERROR FUNCTION USING A +!C *** POLYNOMIAL APPROXIMATION +!C +!C======================================================================= +!C + REAL*8 FUNCTION erf(x) + REAL*8 :: x + REAL*8 :: AA(4), axx, y + DATA AA /0.278393d0,0.230389d0,0.000972d0,0.078108d0/ + + y = dabs(dble(x)) + axx = 1.d0 + y*(AA(1)+y*(AA(2)+y*(AA(3)+y*AA(4)))) + axx = axx*axx + axx = axx*axx + axx = 1.d0 - (1.d0/axx) + if(x.le.0.) then + erf = -axx + else + erf = axx + endif + RETURN + END FUNCTION + + +!======================================================================= +! +! *** real function erf +! *** this subroutine calculates the error function +! +! *** obtained from numerical recipies +! +!======================================================================= +! + +! +! real*8 :: x + +! if(x.lt.0.)then +! erf=-gammp(.5d0,x**2) +! else +! erf=gammp(.5d0,x**2) +! endif +! return + +! end function erf + +! +!======================================================================= +! + real*8 function gammln(xx) +! +!======================================================================= +! +! + integer :: j + real*8 :: cof(6),stp,half,one,fpf,x,tmp,ser,xx +! + data cof,stp/76.18009173d0,-86.50532033d0,24.01409822d0, - + &1.231739516d0,.120858003d-2,-.536382d-5,2.50662827465d0/ + data half,one,fpf/0.5d0,1.0d0,5.5d0/ + x=xx-one + tmp=x+fpf + tmp=(x+half)*log(tmp)-tmp + ser=one + do 11 j=1,6 + x=x+one + ser=ser+cof(j)/x + 11 continue + gammln=tmp+log(stp*ser) + return + end function gammln + + +! +!======================================================================= +! +! real*8 function gammp(a,x) +! +!======================================================================= +! +! real*8 :: a,x,gln,gamser,gammcf + +! if(x.lt.0.d0.or.a.le.0.d0)pause +! if(x.lt.a+1.d0)then +! call gser(gamser,a,x,gln) +! gammp=gamser +! else +! call gcf(gammcf,a,x,gln) +! gammp=1.d0-gammcf +! endif +! return +! end function gammp + + +! +!======================================================================= +! +! subroutine gcf(gammcf,a,x,gln) +! +!======================================================================= +! +! +! integer :: n +! integer, parameter :: itmax=100 +! real*8, parameter :: eps_par=3.e-7 +! real*8 :: gln, gold,a0,a1,x,b0,b1,fac,an, & +! float,ana,a,anf,g,gammcf +! gln=gammln(a) +! gold=0. +! a0=1. +! a1=x +! b0=0. +! b1=1. +! fac=1. +! do 11 n=1,itmax +! an=float(n) +! ana=an-a +! a0=(a1+a0*ana)*fac +! b0=(b1+b0*ana)*fac +! anf=an*fac +! a1=x*a0+anf*a1 +! b1=x*b0+anf*b1 +! if(a1.ne.0.)then +! fac=1./a1 +! g=b1*fac +! if(abs((g-gold)/g).lt.eps_par)go to 1 +! gold=g +! endif +!1 continue +! pause 'a too large, itmax too small' +! gammcf=exp(-x+a*log(x)-gln)*g +! return +! end subroutine gcf + + +! +!======================================================================= +!sft +! subroutine gser(gamser,a,x,gln) +! +!======================================================================= +! + +! integer :: n +! integer, parameter :: itmax=100 +! real*8, parameter :: eps_par=3.e-7 +! real*8 :: gln,x,gamser,a,ap,sum,del,abs + +! gln=gammln(a) +! if(x.le.0.)then +! if(x.lt.0.)pause +! gamser=0. +! return +! endif +! ap=a +! sum=1./a +! del=sum +! do 11 n=1,itmax +! ap=ap+1. +! del=del*x/ap +! sum=sum+del +! if(abs(del).lt.abs(sum)*eps_par)go to 1 +!1 continue +! pause 'a too large, itmax too small' +! gamser=sum*exp(-x+a*log(x)-gln) +! return +! end subroutine gser + +! +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! + +! + +!************************************************************************* +! +! ICE NUCLEATION PARAMETERIZATION FILES START HERE +! +! ************************************************************************ +! +! +!====================================================================== +! +! Code Developer +! Donifan Barahona, GA TECH +! donifan@gatech.edu +! ------------------------------- +! DESCRIPTION +! + +!*********************************************************** +!** Parameterization of ICE crystal number concentration +!** for large scale models. +!** Donifan Barahona, Athanasios Nenes +! JGR, 111, D11211, 2008 +! ACP, 9, 369-381, 2009 +! ACP 9, 5933-5948, 2009 +! Homogeneoeus and heterogeneous nucleation considered +!*** SI units unless otherwise specified. +! +! +! *** WRITTEN BY DONIFAN BARAHONA +! +!======================================================================= + + + + SUBROUTINE IceParam (sigma_w, denice_ice,ddry_ice,np_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice, + & g1_ice, g2_ice,gdoin_ice, z_ice,lambda_ice,sc_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,one_over_tao_preex, + & nhet, nice, smax, nlim,Nhet_dep,Nhet_dhf,fdust_dep + & ,P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & use_av_v,miuv_ice,vpresw_ice,vpresi_ice,denair_ice) + + real*8, intent(in) :: sigma_w,denice_ice,ddry_ice,np_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice, + & g1_ice, g2_ice,gdoin_ice, z_ice, lambda_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,one_over_tao_preex,P_ice, T_ice, + & vpresw_ice,vpresi_ice,denair_ice + real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + + + real*8, intent(out) :: nice, nhet, smax, nlim,Nhet_dep,Nhet_dhf + & ,fdust_dep + + real*8 :: wpar_ice, sigmav_ice,vmax_ice,miuv_ice + integer, intent(in)::nbindust_ice + logical use_av_v + + + + + vmin_ice=0.005d0 + vmax_ice=2.5d0 + sigmav_ice=sigma_w + vmax_ice= max(min(miuv_ice+(4d0*sigmav_ice), vmax_ice), + & vmin_ice +0.01) + + if ((sigmav_ice .lt. 0.05) .or. (T_ice .gt. Thom)) then + use_av_v= .TRUE. + end if + + if (vmax_ice .gt. vmin_ice + 0.01) then + if (use_av_v) then + wpar_ice=min(max(miuv_ice + sigma_w*0.8, vmin_ice), vmax_ice) + CALL nice_param(wpar_ice, denice_ice,ddry_ice,np_ice,nin_ice, + & alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,one_over_tao_preex, + & nice, smax, nhet, nlim,Nhet_dep,Nhet_dhf,fdust_dep, + & P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice,denair_ice) + else + call nice_Vdist(denice_ice,ddry_ice,np_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,one_over_tao_preex, + & nice, smax, nhet, nlim,Nhet_dep,Nhet_dhf,fdust_dep, + & P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice + & ,vpresw_ice,vpresi_ice,denair_ice) + end IF + else + nice = zero_par + nhet = zero_par + nlim = 1.0e10 + smax = zero_par + end if + + + return + END subroutine IceParam + + +!************************************************************* +! Subroutine nice_Vdist. Calculates the ice crystal number concentration +! at the maximum supersaturation using a PDF of updraft using a +! sixth order Gauss-Legendre quadrature +! Inputs: T, and P all SI units) +! Output NC, smax, nhet, nlim (m-3) +! Barahona and Nenes, JGR, D11211 (2008) and ACPD, 15665-15698, (2008) +! Written by Donifan Barahona +!************************************************************ + + + subroutine nice_Vdist(denice_ice,ddry_ice,np_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,one_over_tao_preex, + & nice, smax, nhet, nlim,Nhet_dep,Nhet_dhf,fdust_dep, + & P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice,denair_ice) + + real*8 :: quadx(6), wpar, sum1, quadw(6), dp, sum2, sum3, sum4, + & sum5, x1, x2 + real*8, intent(out) :: nice, smax, nhet, nlim,Nhet_dep,Nhet_dhf + & ,fdust_dep + real*8 wpar_icex,denice_ice,ddry_ice,np_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & normv_ice,sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice,sc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,one_over_tao_preex,P_ice, T_ice, + & vpresw_ice,vpresi_ice,denair_ice + real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + + INTEGER :: INDEX,nbindust_ice + + DATA quadx/0.23861918d0, -0.23861918d0, 0.66120939d0, - + &0.66120939d0, 0.93246951d0, -0.93246951d0/ + + DATA quadw/0.46791393d0, 0.46791393d0, 0.36076157d0, + & 0.36076157d0, 0.17132449d0, 0.17132449d0/ + + + + x1=(vmin_ice-miuv_ice)/(sq2_par*sigmav_ice) + x2=(vmax_ice-miuv_ice)/(sq2_par*sigmav_ice) + + x2=max(x1 +0.01, x2) + normv_ice=(ERFAPP(x2)-ERFAPP(x1))*0.5d0 + + sum1=0d0 + sum2=0d0 + sum3=0d0 + sum4=0d0 + sum5=0d0 + + DO INDEX =1, 6 + wpar=max(0.5d0*(((vmax_ice-vmin_ice)*quadx(INDEX)) +(vmax_ice+ + & vmin_ice)), 0.01) + + + CALL nice_param(wpar, denice_ice,ddry_ice,np_ice,nin_ice, + & alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,one_over_tao_preex, + & nice, smax, nhet, nlim,Nhet_dep,Nhet_dhf,fdust_dep, + & P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice,denair_ice) + + CALL gausspdf(wpar, dp, sigmav_ice,miuv_ice,normv_ice) + sum1=sum1+(nice*dp*quadw(INDEX)) + sum2=sum2+(smax*dp*quadw(INDEX)) + sum3=sum3+(nhet*dp*quadw(INDEX)) + sum4=sum4+(nlim*dp*quadw(INDEX)) + sum5=sum5+(sc_ice*dp*quadw(INDEX)) + + + + END DO + nice=sum1*(vmax_ice-vmin_ice)*0.5d0 + smax=sum2*(vmax_ice-vmin_ice)*0.5d0 + nhet=sum3*(vmax_ice-vmin_ice)*0.5d0 + nlim=sum4*(vmax_ice-vmin_ice)*0.5d0 + sc_ice=sum5*(vmax_ice-vmin_ice)*0.5d0 + RETURN + + + END subroutine nice_Vdist + +!************************************************************* + +!************************************************************* + real*8 function ERFAPP(x) + + real*8, intent(in) :: x + real*8 :: a + a = x*x*(1.27324d0+(0.147d0*x*x))/(1d0+(0.147d0*x*x)) + ERFAPP = SQRT(1d0-exp(-a)) + + if (x .lt. 0.0) then + ERFAPP = - ERFAPP + end if + + end function ERFAPP + + + +!************************************************************* +! Subroutine Het_freezing. Use only for mixed phase clouds . Inputs: Wpar, T, and P all SI units) +! Output Nc=Nhet (m-3) +! ! Written by Donifan Barahona +!************************************************************ + + +! SUBROUTINE Het_freezing(nhet, nice, smax) + +! real*8, intent(out) :: nice, nhet, smax +! real*8, intent(in) :: np_ice + +! real*8 :: I, SX, NHET_, DSH + +! nhet=zero_par +! smax=zero_par +! nice=zero_par + +! SX=vpresw_ice/vpresi_ice +! call INSPEC_ice(SX-1.0, NHET_, DSH,np_ice) +! sc_ice=1.0 +! nhet=max(NHET_, zero_par) +! nice=nhet +! smax=max(SX-1.0, zero_par) + + +! END SUBROUTINE Het_freezing + + +!************************************************************* +! Subroutine nice_param. This is the implementation of the Barahona and Nenes(2008, 2009) +! parameterization +! Written by Donifan Barahona +!************************************************************ + + + subroutine nice_param(wpar_icex,denice_ice,ddry_ice,np_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,sc_ice,one_over_tao_preex, + & nice, smax, nhet, nlim_,Nhet_dep,Nhet_dhf,fdust_dep, + & P_ice, T_ice,ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice,denair_ice) + + real*8, intent(in) :: wpar_icex,denice_ice,np_ice,nin_ice, + & alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice,miuv_ice, + & sigmav_ice,g1_ice, g2_ice,gdoin_ice, z_ice,vmax_ice, + & norg_ice,sigorg_ice,dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, ddry_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,one_over_tao_preex,P_ice, T_ice, + & vpresw_ice,vpresi_ice,denair_ice + real*8, intent(out) :: nice, smax, nhet, nlim_,Nhet_dep,Nhet_dhf + & ,fdust_dep + + real*8 :: AUX1, AUX2, G, DPMAX, MIU, MONVOL, FDS, NLIM, DLIM, + & DSTAR, DS, NSTAR, NHOM, FC, PHIDO, AUXNC, SIZECORR, DSH, NHET_, + & F1, F2, SAUX, SUP, SLOW, SHALF, FHALF, DPMIN, GAM, wpar_ice, + & preex_effect, swsat, sstep,sc_ice,lambda_ice + real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + + integer :: INDEX, maxiter_s,nbindust_ice + + + + + + preex_effect=1.0-(one_over_tao_preex*(shom_ice)/alfa_ice/ + & ((shom_ice+1.0))/wpar_icex) + swsat = vpresw_ice/vpresi_ice -1d0 + + + if (preex_effect .le. 0.0) then + nhet=0d0 + NHOM=0d0 + smax=shom_ice + DSH =0.d0 + FDS=1.d0 + + sc_ice = shom_ice + 1.d0 + nice = 0.d0 + nlim_=0d0 + return + else + + wpar_ice = wpar_icex*preex_effect + end if + + + + + if (np_ice .gt. 1.0) then + + MONVOL=np_ice*1.0d-6*ddry_ice*ddry_ice*ddry_ice + AUX1=1.6397d-14*T_ice-3.1769d-12 + DPMAX=AUX1*(MONVOL**(-0.373d0))*(wpar_ice**(-0.05)) + IF (DPMAX.GT.1.0d-4) THEN + DPMAX=1.0d-4 + END IF + + else + DPMAX=1.0d-4 + + endif + + + DPMIN=dliq_ice+(0.02/sqrt(alfa_ice*wpar_ice*g1_ice)) + DPMAX=max(DPMAX,DPMIN) + + AUX1=DPMAX-dliq_ice + AUX2=dlog((g2_ice+(g1_ice*DPMAX))/(g2_ice+(g1_ice*dliq_ice))) + G=1.3346d0*((g1_ice*AUX1)-(g2_ice*AUX2))/(AUX1*g1_ice*g1_ice) + lambda_ice=lambda_ice/sqrt(wpar_ice) + AUX1 = g1_ice*alfa_ice*wpar_ice + NSTAR=(AUX1*SQRT(AUX1))/beta_ice/z_ice/sq2_par + + GAM=g2_ice/g1_ice + + + + + FDS=1d0 + NHOM=0d0 + + + + if (typeofspec_ice .ge. 0d0) then + + call INSPEC_ice(shom_ice,NHET_,DSH,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice + & ,vpresw_ice,vpresi_ice) + SIZECORR=EXP(-2d0/lambda_ice/shom_ice) + DSTAR=((4d0*DSH*DSH/3d0)+(2d0*DSH*(shom_ice-DSH))) /(shom_ice- + &DSH+1d0) + + if (DSTAR .gt. 0.0) then + NLIM=min(NSTAR*(shom_ice+1d0)/shom_ice/sqrt(DSTAR)/SIZECORR, + & 1.e10) + else + NLIM=1.e10 + end if + + else + DSH=shom_ice-sh_ice + DSTAR=((4d0*DSH*DSH/3d0)+(2d0*DSH*(shom_ice-DSH))) /(shom_ice- + &DSH+1d0) + DLIM=-GAM+sqrt((GAM*GAM)+(2d0*DSTAR/g1_ice/alfa_ice/wpar_ice)) + NLIM=alfa_ice*wpar_ice*(shom_ice+1d0)/z_ice/beta_ice/shom_ice + NLIM=NLIM*((g1_ice*DLIM)+g2_ice)/DLIM/DLIM + NHET_=nin_ice + end if + + + nlim_=min(NLIM, 1d10) + nlim_=max(NLIM, 1d-6) + + if (NHET_ .gt. 0.0) then + AUX1 =NHET_/nlim_ + FDS=1d0-(AUX1*SQRT(AUX1)) + else + FDS = 1d0 + end if + + + + if (purehom_ice) then + FDS=1.0d0 + end if + + if ((purehet_ice) .or. (T_ice .GE. Thom)) then + FDS = 0d0 + end if + + + IF (FDS .GE. 1.e-10) THEN + + MIU=FDS*alfa_ice*(shom_ice+1d0)*wpar_ice*koft_ice/shom_ice + + PHIDO=sqrt(pi_ice*G/MIU/2d0)*(G/MIU) + AUXNC=2d0*denair_ice/beta_ice/koft_ice/denice_ice/pi_ice/np_ice + FC=AUXNC/PHIDO + + + + if (np_ice .gt.0d0) then + + IF (FC .le. 0.6d0) then + NHOM=np_ice*EXP(-FC)*(1.0d0-EXP(-FC)) + else + NHOM=np_ice/(1d0+EXP((9d0-2d0*FC)/7d0)) + end if + + else + NHOM=0d0 + end if + + smax=shom_ice + nhet=NHET_ + if (purehom_ice) NHET_ = 0.d0 + + + ELSE + + + NHOM = 0d0 + + + smax=0d0 + nhet=0d0 + SAUX=0.01d0 + + if (typeofspec_ice .lt. 0d0) SAUX=sh_ice+0.00000000001d0 + + F1= FINDSMAX(SAUX,DSH, + & NHET_,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice,lambda_ice, + & gdoin_ice,alfa_ice,wpar_ice,GAM,g1_ice,g2_ice,z_ice, + & beta_ice,nin_ice,vpresw_ice,vpresi_ice,NSTAR) + F2=1.0 + sstep = 0.05d0 + maxiter_s = int(1d0/sstep) + 1 + + do INDEX =1, maxiter_s + + if (SAUX .ge. swsat) then + F2=F1 + SAUX = swsat + exit + end if + + + SAUX=SAUX+sstep + F2=FINDSMAX(SAUX,DSH, + & NHET_,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice,lambda_ice, + & gdoin_ice,alfa_ice,wpar_ice,GAM,g1_ice,g2_ice,z_ice, + & beta_ice,nin_ice,vpresw_ice,vpresi_ice,NSTAR) + IF (F2*F1 .lt. 0d0) exit + + end do + + if (F2*F1 .gt.0d0) then + nhet=0d0 + smax=SAUX + else + + if (SAUX .lt. swsat) then + + + SUP=SAUX + SLOW=SAUX-(sstep + 0.001d0) + + DO INDEX=1,50 + SHALF=0.5d0*(SUP+SLOW) + FHALF=FINDSMAX(SHALF,DSH, + & NHET_,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice,lambda_ice, + & gdoin_ice,alfa_ice,wpar_ice,GAM,g1_ice,g2_ice,z_ice, + & beta_ice,nin_ice,vpresw_ice,vpresi_ice,NSTAR) + + IF (SIGN(1.d0,F1)*SIGN(1.d0,FHALF) .LE. 0d0) THEN + F2 = FHALF + SUP = SHALF + ELSE + F1 = FHALF + SLOW = SHALF + ENDIF + + + IF (ABS(SLOW-SUP) .LE. 5d-3) exit + END DO + else + SHALF = swsat + end if + + smax=SHALF + + end if + + if ((smax .gt. shom_ice) .and.(T_ice .LE. Thom)) smax=shom_ice + + if (typeofspec_ice .ge. 0d0) then + call INSPEC_ice(smax, nhet,DSH,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice) + else + nhet=nin_ice + end if + + END IF + + + nice=NHOM+nhet + sc_ice=max(smax+1.0-DSH, 1.0) + + + if (.true.) then + + if (FDS .gt. 0.0) then + sc_ice = (shom_ice+1.0)*FDS + sc_ice*(1.0-FDS) + end if + end if + + sc_ice=min(shom_ice+1.0, sc_ice) + + + return + + END subroutine nice_param +!************************************************************* + real*8 function FINDSMAX(SX,DSH, + & NHET_,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice,lambda_ice, + & gdoin_ice,alfa_ice,wpar_ice,GAM,g1_ice,g2_ice,z_ice, + & beta_ice,nin_ice,vpresw_ice,vpresi_ice,NSTAR) + real*8, intent(in) :: SX + real*8 :: tao + real*8 :: DSTAR, SIZECORR, DSH, NSTAR,DLIM + integer nbindust_ice + real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + real*8 shom_ice,NHET_,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & lambda_ice, + & gdoin_ice,alfa_ice,wpar_ice,GAM,g1_ice,g2_ice,z_ice, + & beta_ice,nin_ice,vpresw_ice,vpresi_ice + + if (typeofspec_ice .ge. 0d0) then + + call INSPEC_ice(SX,NHET_,DSH,np_ice,norg_ice,sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice) + SIZECORR=EXP(-2d0/lambda_ice/SX) + DSTAR=((4d0*DSH*DSH/3d0)+(2d0*DSH*(SX-DSH)))/(SX-DSH+1d0) + DSTAR=DSTAR+(gdoin_ice*alfa_ice*wpar_ice) + + + tao=NHET_*SIZECORR*SX*sqrt(DSTAR)/(SX+1d0)/NSTAR + + + else + DSH=SX-sh_ice + DSTAR=((4d0*DSH*DSH/3d0)+(2d0*DSH*(SX-DSH))) /(SX-DSH+1d0) + DLIM=-GAM+sqrt((GAM*GAM)+(2d0*DSTAR/g1_ice/alfa_ice/wpar_ice)) + tao=alfa_ice*wpar_ice*(SX+1d0)/z_ice/beta_ice/SX + tao=tao*((g1_ice*DLIM)+g2_ice)/DLIM/DLIM/nin_ice + + end if + + + FINDSMAX=1d0-tao + + end function FINDSMAX + + +!************************************************************* +! Function VPRESWATER. Calculates the saturated vapor pressure +! of water (Pa) according to Murphy & Koop (2005) +! T in K (173.15-373.15) +!************************************************************ + + real*8 function VPRESWATER_ice(T) + + real*8, intent(in) :: T + real*8 :: A(0:9) + + DATA A/54.842763d0, -6763.22d0, -4.21d0, 0.000367d0, 0.0415d0, + & 218.8d0, 53.878d0, -1331.22d0, -9.44523d0, 0.014025d0/ + + + VPRESWATER_ice = A(0)+(A(1)/T)+(A(2)*LOG(T))+(A(3)*T)+ + & (TANH(A(4)*(T-A(5)))*((A(6)+(A(7)/T))+ (A(8)*LOG(T))+ (A(9)*T))) + + VPRESWATER_ice=EXP(VPRESWATER_ice) + + return + END function VPRESWATER_ice + +!************************************************************* +! Function VPRESICE. Calculates the saturated vapor pressure +! of ice (pa) according to Murphy & Koop (2005) +! T in K (>110) +!************************************************************ + + real*8 function VPRESICE(T) + + real*8, intent(in) :: T + real*8 :: A(0:3) + + DATA A/9.550426d0, -5723.265d0, 3.53068d0, -0.00728332d0/ + + + VPRESICE = A(0)+(A(1)/T)+(A(2)*LOG(T))+(A(3)*T) + VPRESICE=EXP(VPRESICE) + + return + END function VPRESICE + +!************************************************************* +! Function DHSUB. Calculates the latent heat of sublimation +! of ice (J/Kg) according to Murphy & Koop (2005) +! T in K (>30) +!************************************************************ + + real*8 function DHSUB_ice(T) + + real*8, intent(in) :: T + real*8 :: A(0:4) + + + DATA A/46782.5d0, 35.8925d0, -0.07414d0, 541.5d0, 123.75d0/ + + DHSUB_ice = A(0) + (A(1) * T) + (A(2)*T*T) + (A(3) * EXP(-((T/ + & A(4))**2))) + + DHSUB_ice=1000d0*DHSUB_ice/18d0 + return + END function DHSUB_ice + +!************************************************************* +! Function ICEDENSITY. Calculates the DENSITY OF ICE +! of ice (Kg/m3) according to PK97 +! T in K (>30) +!************************************************************ + + real*8 function DENSITYICE(T) + + real*8, intent(in) :: T + real*8 :: A(0:2), TTEMP + + DATA A/0.9167d0, -1.75d-4, -5.0d-7/ + + TTEMP=T-273d0 + + DENSITYICE= 1000d0*(A(0)+(A(1)*TTEMP)+(A(2)*TTEMP*TTEMP)) + return + END function DENSITYICE + +!************************************************************* +! Function WATDENSITY. Calculates the DENSITY OF ICE +! of liquid water (Kg/m3) according to PK97 +! T in K (>240) +!************************************************************ + + real*8 function WATDENSITY_ice(T) + + real*8, intent(in) :: T + real*8 :: A(0:6), TTEMP, WATDENSITY + INTEGER :: I + + + DATA A/0.99986d0, 6.690d-5, -8.486d-6, 1.518d-7, -6.9984d-9, - + &3.6449d-10, -7.497d-12 / + + TTEMP=T-273D0 + + IF (TTEMP .le. -40d0) THEN + TTEMP=-40d0 + END IF + + WATDENSITY=A(6)*TTEMP + + IF (T .GE. 240.0) THEN + DO I=5,1, -1 + WATDENSITY= (WATDENSITY+A(I))*(TTEMP) + ENDDO + WATDENSITY=WATDENSITY + A(0) + ELSE + WATDENSITY=0.979d0 + END IF + + WATDENSITY=WATDENSITY*1000d0 + WATDENSITY_ice=WATDENSITY + return + END function WATDENSITY_ice + + +!************************************************************* +! Subroutine PROPERTIES. Set physical an thermodynamic +! properties at T and P for ice param +!************************************************************ + + + SUBROUTINE prop_ice(T, P, denice_ice,ddry_ice, + & nin_ice,alfa_ice,beta_ice,shom_ice, koft_ice, dliq_ice, + & g1_ice, g2_ice,gdoin_ice, z_ice,lambda_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,D_preex, N_preex,one_over_tao_preex, + & P_ice, T_ice,act_param,ndust_ice,vpresw_ice,vpresi_ice, + & denair_ice) + + real*8, intent(in) :: T, P,ddry_ice,nbc_ice,D_preex, N_preex + real*8, intent(out) :: alfa_ice,beta_ice,shom_ice, + & koft_ice, dliq_ice,g1_ice, g2_ice,gdoin_ice, z_ice, + & lambda_ice,kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,one_over_tao_preex,P_ice, T_ice + + real*8 :: AUX, AUX1, AUX2, SW, fice, mice, Tc, hdust, hbc, b0, + & b1, b2, b3, x, T0bc, T0dust, gam, gamma,NIN_ICE, + & Tr, vw, den_m, Eact, Toact, Dact, acc, n1, Siw, rgo, + & ngo, mw_molec,dhs_ice,denwat_ice,denice_ice,vpresw_ice, + & vpresi_ice,denair_ice,diff_ice,aircond_ice + + real*8,dimension(:) :: ndust_ice + integer, intent(in) :: act_param + + + T_ice = min(max(T, Tmin_ice), To_ice) + P_ice = max(P, Pmin_ice) + dliq_ice = 1.0d-6 + + +! rv_ice = rgas_ice/wmw_ice + dhs_ice = DHSUB_ice(T_ice) + vpresw_ice = VPRESWATER_ice(T_ice) + vpresi_ice = VPRESICE(T_ice) + denice_ice = DENSITYICE(T_ice) + denwat_ice = WATDENSITY_ice(T_ice) + denair_ice = P_ice*amw_ice/rgas_ice/T_ice + + + diff_ice=(0.211d0*101325d0/P_ice)*((T_ice/273d0)**1.94d0)*1.0d-4 + AUX1=1.0e-3*(4.39d0+0.071d0*T_ice) + + + AUX2=(2d0*AUX1/(thaccom_ice*1.0d-6*denair_ice*cpa_ice)) *((58.0d- + &3*pi_ice/(rgas_ice*T_ice))**0.5d0) + + aircond_ice=AUX1/(1.d0+AUX2) + + + + + AUX1=grav_ice*dhs_ice/rv_ice/T_ice/T_ice/cpa_ice + AUX2=grav_ice*amw_ice/rgas_ice/T_ice + alfa_ice=AUX1-AUX2 + beta_ice=amw_ice*P_ice/wmw_ice/vpresi_ice + gamma=1.5d0*dhs_ice*dhs_ice/rv_ice/T_ice/T_ice/cpa_ice + + beta_ice=beta_ice+gamma + + + + shom_ice=2.349d0-(T_ice/259d0) + SW=shom_ice*vpresi_ice/vpresw_ice + shom_ice=shom_ice-1d0 + koft_ice=(0.0240d0*T_ice*T_ice)-(8.035d0*T_ice)+934.0d0 + + + + + + if (SW .lt. 0.99) then + AUX1=(1d0/(1d0-SW))-1.1764d0 + else + AUX1=(1d0/0.01)-1.1764d0 + end if + dliq_ice=ddry_ice*0.9344d0*(AUX1**0.333) + + + + AUX1=denice_ice*rv_ice*T_ice/vpresi_ice/diff_ice + AUX2=dhs_ice*denice_ice/aircond_ice/T_ice + AUX2=AUX2*((dhs_ice/rv_ice/T_ice)-1.0d0) + g1_ice=(AUX1+AUX2)/4.0d0 + + + one_over_tao_preex = beta_ice*denice_ice*pi_ice*0.5* D_preex* + &N_preex/g1_ice/denair_ice + + + + g2_ice=denice_ice*rv_ice*T_ice/2.0d0/vpresi_ice/depcoef_ice + g2_ice=g2_ice*((2.0d0*pi_ice/rv_ice/T_ice)**0.5d0) + + doin_ice=1.0d-6 + gdoin_ice=(g1_ice*0.5d0*doin_ice*doin_ice)+(g2_ice*doin_ice) + z_ice=denice_ice*pi_ice/2.0d0/denair_ice + + gam=g2_ice/g1_ice + lambda_ice=1d0/sqrt(alfa_ice*g1_ice*gam*gam) + + + + + + if (typeofspec_ice .lt. 0) then + sh_ice=0.3d0 + nin_ice=(sum(ndust_ice)+nbc_ice)*0.05d0 + elseif (typeofspec_ice .eq. 3) then + + shdust_ice = 0.2d0 + effdust_ice=0.6d0 + shbc_ice = 0.35d0 + effbc_ice=0.05d0 + mice = 0.96d0 + fice=0.25d0*((mice*mice*mice)-(3d0*mice)+2d0) + kdust_ice=koft_ice*fice + mice = 0.76d0 + fice=0.25d0*((mice*mice*mice)-(3d0*mice)+2d0) + kbc_ice=koft_ice*fice + elseif (typeofspec_ice .eq. 4) then + + Tc=T_ice-273.15d0 + hdust=0.15d0 + T0dust=-40d0 + b0=-1.0261d0; b1=3.1656d-3; b2=5.3938d-4; b3=8.2584d-6 + x=b0+(b1*Tc)+(b2*Tc*Tc)+(b3*Tc*Tc*Tc) + si0dust_ice=1d0+(10d0**x) + del1dust_ice=cubicint_ice(Tc, T0dust, T0dust+5d0, 1d0, hdust) + hbc=0d0 + T0bc=-50d0 + b0=0.5652d0; b1=1.085d-2; b2=-3.118d-5 + si0bc_ice=b0+(b1*T_ice)+(b2*T_ice*T_ice)-0.1d0 + del1bc_ice=cubicint_ice(Tc, T0bc, T0bc+5d0, 1d0, hbc) + end if + + RETURN + + END SUBROUTINE prop_ice + +!************************************************************* +! Subroutine gauspdf (normalized width of the updraft distribution). +!************************************************************ + + SUBROUTINE gausspdf(x, dp, sigmav_ice,miuv_ice,normv_ice) + + + real*8, intent(in) :: x + real*8 sigmav_ice,miuv_ice,normv_ice + real*8, intent(out) :: dp + + sigmav_ice =max(sigmav_ice, 0.01) + normv_ice =max(normv_ice, 0.01) + + + dp=EXP(-0.5d0*(x-miuv_ice)*(x-miuv_ice)/sigmav_ice/sigmav_ice) / + &sigmav_ice/sq2pi_par/(normv_ice + 0.001) + + + RETURN + + + END SUBROUTINE gausspdf + + +!************************************************************* +! Function cubicint_ice (cubic interpolation between y1 and y2 within a and b). +!************************************************************ + + real*8 function cubicint_ice(y, y1, y2, a, b) + + real*8, intent(in) :: y, y1, y2, a, b + real*8 :: A_, B_, a0, a1, a2, a3, d, AUX + + if (y .le. y1) then + d=a + goto 5065 + end if + + if (y .ge. y2) then + d=b + goto 5065 + end if + + + AUX=y2-y1 + A_=6d0*(a-b)/(AUX*AUX*AUX) + B_=a+(A_*(y1*y1*y1)/6d0)-(A_*(y1*y1)*y2*0.5d0) + + a0=B_ + a1=A_*y1*y2 + a2=-A_*(y1+y2)*0.5d0 + a3=A_/3d0 + d=a0+(a1*y)+(a2*y*y)+(a3*y*y*y) + + + 5065 cubicint_ice=d + + + end function cubicint_ice + +!************************************************************* +! Function dcubicint_ice (used in the PDA08 spectrum). +!************************************************************ + + real*8 function dcubicint_ice(y, y1, y2, a, b) + + real*8, intent(in) :: y, y1, y2, a, b + real*8 :: A_, a0, a1, a2, a3, d, AUX + + if (y .le. y1) then + d=0 + goto 5065 + end if + + if (y .ge. y2) then + d=0 + goto 5065 + end if + + + AUX=y2-y1 + A_=6d0*(a-b)/(AUX*AUX*AUX) + + a1=A_*y1*y2 + a2=-A_*(y1+y2)*0.5d0 + a3=A_/3d0 + d=(a1)+(2d0*a2*y)+(3d0*a3*y*y) + + + 5065 dcubicint_ice=d + + + end function dcubicint_ice + +!************************************************************* +! Function PDG07 (simplified ice nucleation +! spectra according to Phillips et. al. 2007). +! si is supersaturation wrt ice and T is in K +!************************************************************ + + real*8 function PDG07_ice(si, T) + + real*8, intent(in) :: si, T + real*8 :: N + + if (T .le. 243d0)then + N=1000d0*exp(-0.388d0)*(exp(3.88d0*si)-1d0) + else + N=60d0*exp(-0.639d0)*(exp(12.96d0*si)-1d0) + end if + + PDG07_ice=N + + end function PDG07_ice + + + + +!************************************************************* +! Subroutine INSPEC_ice +! Provides the Ice Nuclei concentration (m-3) +! and the chracteristic freezing threeshold, DSh (Barahona & Nenes 2009), at given +! si and T. The variable typeofspec_ice (integer) has the values +! 1 Meyers et. al. 1992 +! 2 Phillips et. al. 2007 +! 3 Barahona 2011 +! 4 Phillips et. al. 2008 (simplifed) +! 5 Phillips et. al. 2013 (simplifed) +! si is supersaturation wrt ice and T is in K + +! Written by Donifan Barahona +! donifan.o.barahona@nasa.gov + +!************************************************************ + + subroutine INSPEC_ice(six, N, Dsh,np_ice,norg_ice, sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice, + & ndust_ice, sigdust_ice,ddust_ice,nbindust_ice, + & vpresw_ice,vpresi_ice) + + real*8, intent(in) :: six,np_ice,norg_ice, sigorg_ice, + & dorg_ice, dbc_ice,sigbc_ice, + & kdust_ice, kbc_ice, shdust_ice, shbc_ice, + & effdust_ice, effbc_ice, del1dust_ice, si0dust_ice, del1bc_ice, + & si0bc_ice,nbc_ice,P_ice, T_ice + real*8, intent(out) :: N, Dsh,Nhet_dep,Nhet_dhf,fdust_dep + real*8 :: Nd, Nbc, aux, Si_, SW, del0, ddel0, fc, delw0, ddelw0, + & SW0, Hdust, Hbc, Nbase, dNd, dNbc, dNbase, dH, dfc, Ndaux, + & dNdaux, dNorg, Norg, Ndustaux, frac, aux2, Dx2, fdep, Ndep, Ndhf, + & dNdep, dNdhf, si, dfrac, Ncdep_, Ncdhf_ , fglassy, Nglassy, + & dNglassy, SIW, D_grid_bio, n_grid_bio,vpresw_ice,vpresi_ice + + real*8, dimension(3) :: sig_array, the_array, frac_array + real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + + real :: n_iw, DSh_s , nbc_s, dbc_s, Asolo + real, dimension (nbindust_ice) :: ndust_s, ddust_s + integer :: index, kindex, mode,nbindust_ice + + si=six + Si_=si+1d0 + SW=Si_*vpresi_ice/vpresw_ice + Nd = zero_par + Nbc = zero_par + Norg = zero_par + Nglassy = zero_par + + dNd = zero_par + dNbc = zero_par + dNorg = zero_par + dNglassy = zero_par + + if ((six .lt. 0.02) .or. (T_ice .gt. 270.0)) then + N=0d0 + Dsh=si + return + end if + + if (SW .ge. 1.0) then + SW=1.0 + Si_=vpresw_ice/vpresi_ice + si=Si_-1.0 + end if + SIW=vpresw_ice/vpresi_ice + + sig_array = 0.0 + the_array = 0.0 + frac_array = 0.0 + + + select case (typeofspec_ice) + + case(1) + N=1000d0*exp(-0.639d0)*(exp(12.96d0*si)-1d0) + Dsh=1d0/12.96d0 + + case(2) + N=PDG07_ice(si, T_ice) + if (T_ice .le. 243d0)then + Dsh=1d0/3.88d0 + else + Dsh=1d0/12.96d0 + end if + + case(3) + + Ndustaux=0.0d0 + DO index=1, nbindust_ice + + Ndustaux=Ndustaux+ndust_ice(index) + end do + + + if (si .le.shdust_ice) then + Nd=(si/shdust_ice)*Ndustaux*effdust_ice* exp(-kdust_ice* + &(shdust_ice-si)) + dNd=Nd*((1d0/si)+kdust_ice) + + else + Nd=Ndustaux*effdust_ice + dNd=0d0 + end if + + + if (si .le.shbc_ice) then + Nbc=(si/shbc_ice)*nbc_ice*effbc_ice* exp(-kbc_ice*(shbc_ice-si)) + dNbc=Nbc*((1d0/si)+kbc_ice) + else + Nbc=nbc_ice*effbc_ice + dNbc=0d0 + end if + + N=Nd+Nbc + if (((dNd+dNbc) .gt. 0d0) .and. (N .gt. 0.0)) then + Dsh=N/(dNd+dNbc) + else + Dsh=0.0 + end if + + case(4) + + + + SW0=0.97d0 + delw0=cubicint_ice(SW, SW0, 1d0, 0d0, 1d0) + ddelw0=dcubicint_ice(SW, SW0, 1d0, 0d0, 1d0) + + Nbase=PDG07_ice(si, T_ice) + + + if (T_ice .le. 243d0)then + dNbase=3.88d0*Nbase + else + dNbase=12.96d0*Nbase + end if + + + del0=cubicint_ice(Si_, si0dust_ice, si0dust_ice+0.1d0, 0d0, 1d0) + ddel0=dcubicint_ice(Si_, si0dust_ice, si0dust_ice+0.1d0, 0d0, + & 1d0) + + fc=0.5d0*del1dust_ice*del0 + dfc=0.5d0*del1dust_ice*ddel0 + + Hdust=fc+((1d0-fc)*delw0) + dH=(dfc*(1d0-delw0))+(ddelw0*(1d0-fc)) + + if (Hdust .gt. 1d0) then + Hdust=1d0 + dH=0d0 + end if + + + aux=(2d0/3d0)*Hdust*(Nbase/0.76d0)*pi_ice/5.0d-7/4d0 + aux2=(2d0/3d0)*pi_ice/0.76d0/5.0d-7/4d0 + + Nd=0d0 + dNd=0d0 + + DO index =1, nbindust_ice + + + Dx2=ddust_ice(index)*ddust_ice(index)*ddust_ice(index)*0.52* + &acorr_dust + + frac=0.5d0*(1d0-erfapp(-log(ddust_ice(index)/0.1e-6) / + &sigdust_ice(index)/sq2_par)) + + Ndaux=frac*ndust_ice(index)*(1d0-exp(-aux*Dx2)) + + Nd=Nd+Ndaux + Ndaux=(frac*ndust_ice(index)-Ndaux) + dNdaux=Ndaux*((dH*Nbase)+(Hdust*dNbase))*aux2*Dx2 + + dNd=dNd+dNdaux + + END DO + + + + + del0=cubicint_ice(Si_, si0bc_ice, si0bc_ice+0.1d0, 0d0, 1d0) + ddel0=dcubicint_ice(Si_, si0bc_ice, si0bc_ice+0.1d0, 0d0, 1d0) + + fc=0.5d0*del1bc_ice*del0 + Hbc=fc+((1d0-fc)*delw0) + dfc=0.5d0*del1bc_ice*ddel0 + dH=(dfc*(1d0-delw0))+(ddelw0*(1d0-fc)) + + + if (Hbc .gt. 1d0) then + Hbc=1d0 + dH=0d0 + end if + + frac=0.5d0*(1d0 -erfapp(-log(dbc_ice/0.1e-6) /sigbc_ice/ + &sq2_par)) + + + Dx2=dbc_ice*dbc_ice*dbc_ice*0.52*acorr_bc + + aux=((1d0/3d0)-0.06d0)*Hbc*(Nbase/0.76d0)*pi_ice/2.7d-7 + aux2=((1d0/3d0)-0.06d0)*pi_ice/0.76d0/2.7d-7 + + Nbc=nbc_ice*frac*(1d0-exp(-aux*Dx2)) + dNbc=(nbc_ice*frac-Nbc)*((dH*Nbase)+(Hbc*dNbase))*aux2*Dx2 + + + + + frac=0.5d0*(1d0-erfapp(-log(dorg_ice/0.1e-6) /sigorg_ice/ + &sq2_par)) + + Dx2=dorg_ice*dorg_ice + + aux=0.06d0*Hbc*(Nbase/0.76d0)*pi_ice/9.1d-7 + aux2=0.06d0*pi_ice/0.76d0/9.1d-7 + + + Norg=norg_ice*frac*(1d0-exp(-aux*Dx2)) + dNorg=(norg_ice*frac-Norg)*((dH*Nbase)+(Hbc*dNbase))*aux2*Dx2 + + + + + N=Nd+Nbc+Norg + + fdust_dep = Nd + Nhet_dep = N + + + if (.FALSE.) then + + if (T_ice .lt. 210.0) then + Nglassy= min(0.01 +0.0045*(210.0 -T_ice), 0.1) + fglassy= 7.7211*1e-3*Si_ - 9.2688*1e-3 + fglassy=min(fglassy, 3.3587e-3) + fglassy=max(fglassy, 0.0) + else + Nglassy = 0.0 + fglassy = 0.0 + end if + Nglassy = np_ice*Nglassy*fglassy + dNglassy =Nglassy*7.7211*1e-3 + N=N+Nglassy + + end if + + + + if ((dNd+dNbc+dNorg+dNglassy) .gt. 0d0) then + Dsh=N/(dNd+dNbc+dNorg+dNglassy) + else + Dsh=0.0 + end if + + + case (5) + + + + D_grid_bio =dorg_ice + + + + n_grid_bio = 0.0 + + if (is_gocart) then + ndust_s = SNGL(frac_dust*ndust_ice) + nbc_s = SNGL(frac_bc*nbc_ice) + Asolo = SNGL(0.25d0*frac_org*norg_ice*pi_par*dorg_ice*dorg_ice) + else + + + DO index =1, nbindust_ice + frac=0.5d0*(1d0-erfapp(log(0.1e-6/ddust_ice(index)) / + &sigdust_ice(index)/sq2_par)) + ndust_s(index) = SNGL(frac*ndust_ice(index)) + end do + + frac=0.5d0*(1d0-erfapp(log(0.1e-6/dbc_ice) /sigbc_ice/sq2_par)) + + nbc_s = SNGL(frac*nbc_ice) + + frac=0.5d0*(1d0-erfapp(log(0.1e-6/dorg_ice) /sigorg_ice/ + &sq2_par))*0.25d0 + + Asolo = SNGL(frac*norg_ice*pi_par*dorg_ice*dorg_ice) + end if + + ddust_s=SNGL(ddust_ice) + dbc_s = SNGL(dbc_ice*1.0) + + call EMPIRICAL_PARAM_PHILLIPS(SNGL(Si_), SNGL(SIW), SNGL(SW), (/ + &ddust_s/), (/ndust_s/), 5, (/dbc_s/), (/nbc_s/), 1, (/ + &SNGL(D_grid_bio)/), (/SNGL(n_grid_bio)/), 1, Asolo, n_iw, DSh_s + & ,Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice) + + N=DBLE(n_iw) + DSh=DBLE(DSh_s) + + case default + N=zero_par + Dsh=0.0 + end select + + if (Dsh .ge. si) then + Dsh=si + end if + + if (T_ice .gt. 255.0) then + N=zero_par + Dsh=zero_par + end if + + end subroutine INSPEC_ice + + +!************************************************************* +! Subroutine INimmersion +! Provides the Immersion IN (for activated droplets) concentration at given T(K) according to Barahona et al. GMD, 2014. +! Written by Donifan Barahona +! donifan.o.barahona@nasa.gov +!======================================== + + subroutine INimmersion(INconc, dINconc, wparcel,dbc_ice,sigbc_ice + & ,nbc_ice,fdust_imm,fdrop_dust,fdrop_bc,ndust_ice, sigdust_ice, + & ddust_ice,nbindust_ice,vpresw_ice,vpresi_ice,T_ice) + + real*8, intent (in) :: wparcel,dbc_ice,sigbc_ice,nbc_ice + & ,fdrop_dust,fdrop_bc + real*8, intent (out) :: INconc, dINconc,fdust_imm + real*8 :: Nd, Nd_unc, Nd_coa, Nbc, ahet, frac, dfrac, Naux,dNaux, + & Tx, nssoot, nsdust, ninbkg, SX , dnsd, dnss, dNd, dNbc, coolr, + & min_ns_dust, min_ns_soot, dninbkg,vpresw_ice,vpresi_ice,T_ice + + real*8, dimension(3) :: sig_array, the_array, frac_array + real*8, dimension(:) :: ndust_ice, sigdust_ice,ddust_ice + integer :: index, kindex, nbindust_ice + + if (T_ice .lt. Thom) then + INconc = zero_par + dINconc = zero_par + return + end if + + if (T_ice .ge. To_ice) then + INconc = zero_par + dINconc = zero_par + return + end if + + Tx=T_ice -273.16 + coolr=5.0e-3*wparcel + min_ns_dust= 3.75e6 + min_ns_soot= 3.75e9 + + SX=(vpresw_ice/vpresi_ice)-1.0 + + + ninbkg = 0.0 + dninbkg=0.0 + + + + + + nsdust= max(exp(-0.517*Tx + 8.934)-min_ns_dust, 0.0) + dnsd = max(0.517*nsdust, 0.0) + + nssoot= max(1.0e4*exp(-0.0101*Tx*Tx - 0.8525*Tx + 0.7667)- + &min_ns_soot, 0.0) + dnss = max(-(-2.0*0.0101*Tx -0.8525)*nssoot, 0.0) + + Naux=zero_par + dNaux=zero_par + + + if (is_gocart) then + + DO index =1,nbindust_ice + + ahet= ahet_dust(index) + Naux=(1.0-exp(-nsdust*ahet))*ndust_ice(index)+Naux + dNaux = exp(-nsdust*ahet)*ndust_ice(index)*dnsd*coolr*ahet+dNaux + END DO + ahet = ahet_bc + else + + DO index =1,nbindust_ice + + ahet= ddust_ice(index)*ddust_ice(index)*ddust_ice(index)*0.52* + &acorr_dust* exp(4.5*sigdust_ice(index)*sigdust_ice(index)) + Naux=(1.0-exp(-nsdust*ahet))*ndust_ice(index)+Naux + dNaux = exp(-nsdust*ahet)*ndust_ice(index)*dnsd*coolr*ahet+dNaux + END DO + + ahet=dbc_ice*dbc_ice*dbc_ice*0.52*acorr_bc* exp(4.5*sigbc_ice* + &sigbc_ice) + end if + + + Nd=Naux*fdrop_dust + dNd=dNaux*fdrop_dust + + Nbc=nbc_ice*(1.0-exp(-nssoot*ahet))*fdrop_bc + dNbc= nbc_ice*exp(-nssoot*ahet)*fdrop_bc*dnss*coolr*ahet + + + + + INconc=Nbc+ Nd + ninbkg + dINconc=dNbc+dNd + dninbkg + fdust_imm = Nd + + + end subroutine INimmersion + +! +!======================================================================================= +!======================================================================================= +!======================================================================================= +!!==================================================================================== +! EMPIRICAL PARAMETERISATION (Phillips et al. 2013, JAS) +! Code contributed by Vaughan Phillips, University of Leeds +! Implementation: Donifan Barahona donifan.o.barahona@nasa.gov +!==================================================================================== + + + SUBROUTINE EMPIRICAL_PARAM_PHILLIPS(SI, SIW, SW, D_grid_dust, + & n_grid_dust, ijstop_dust, D_grid_soot, n_grid_soot, ijstop_soot, + & D_grid_bio, n_grid_bio, ijstop_bio, A_solo, n_iw, DSH, + & Nhet_dep,Nhet_dhf,fdust_dep,P_ice, T_ice) + implicit none + real, intent(IN):: SI, SIW, SW, A_solo,P_ice, T_ice + real, dimension(:), intent(IN):: D_grid_dust, n_grid_dust, + & D_grid_soot, n_grid_soot, D_grid_bio, n_grid_bio + integer, intent(IN):: ijstop_dust, ijstop_soot, ijstop_bio +! integer ijstop_dust, ijstop_soot, ijstop_bio + + real :: nin_a_nuc_dust, nin_a_nuc_soot, nin_a_nuc_bio, + & nin_a_nuc_solo, num_ic_dust_imm, num_ic_soot_imm, num_ic_bio_imm, + & num_ic_solo_imm + + real, intent (inout) :: DSH, n_iw + real, intent (out) :: Nhet_dep,Nhet_dhf,fdust_dep + + real :: dn_in_dust, dn_in_soot, dn_in_bio, dn_in_solo, dNall, + & dNaux, naux, SS_w, dH_frac_dust, dH_frac_soot, dH_frac_solo, aux, + & dfdep, temperature_K, P_SAT, ahet_aux + + + + REAL :: RHO_CFDC, BASE_DUST_OMEGA, BASE_SOOT_PHILIC_OMEGA, + & BASE_BIO_OMEGA, ALPHA_DUST, ALPHA_SOOT, ALPHA_bio, + & FRACTION_DEPNUCL_WARM_DUST, PIE, BASE_SOLO_OMEGA, + & TEMP_MAX_DUST_DEGC, TEMP_MAX_SOOT_DEGC, TEMP_MAX_bio_DEGC, + & GLASS_FRAC + PARAMETER( BASE_DUST_OMEGA = 2.0e-6, BASE_SOOT_PHILIC_OMEGA = 1.e- + &7, BASE_BIO_OMEGA = 0.89e-6, BASE_SOLO_OMEGA = 5.6e-5, + & GLASS_FRAC = 0.5, ALPHA_DUST = 2./3., ALPHA_SOOT = 1./3. - 0.03, + & ALPHA_bio = 0.03, RHO_CFDC = 50000./(287.*228.15), + & FRACTION_DEPNUCL_WARM_DUST = 0.15, PIE = 3.1415926, + & TEMP_MAX_DUST_DEGC = -10., TEMP_MAX_SOOT_DEGC = -15., + & TEMP_MAX_bio_DEGC = -2.) + + real :: FAC_CORRECT_RH = 2., rho_AIDA + real:: H_frac_dust, n_in, n_in_dust, n_in_ultra, n_in_dust_ultra, + & CIHENC_dust, ESW, ESI, SS_i, n_in_soot_ultra, H_frac_soot, + & H_frac_bio, n_in_soot, n_in_bio, n_in_bio_ultra, CIHENC_soot, + & CIHENC_bio, delta_Si, delta_T, delta_Sw, n_in_max, SS_iw, rho + + real :: H_frac_solO, RHI, n_in_solO, n_in_solO_star, CIHENC_solO, + & Psi_solO + + real :: mu, S_i_0, RH_crit, S_i_w_warm, S_i_w_cold, S_i_w, + & tc_HM_degC + real :: S_w_0, dep_frac, n_in_hat, n_in_tilde + real*4 :: dH1smooth + real :: EPS = 0.622 + integer :: ij +!intrinsic :: exp, DEXP, SIZE, DBLE + + + +!print *, SIZE(n_grid_dust(:)) + if(ijstop_dust .ne. SIZE(n_grid_dust)) stop 6366 + if(ijstop_soot .ne. SIZE(n_grid_soot)) stop 6366 + if(ijstop_bio .ne. SIZE(n_grid_bio)) stop 6366 +! ijstop_dust = SIZE(n_grid_dust) +! ijstop_soot = SIZE(n_grid_soot) +! ijstop_bio = SIZE(n_grid_bio) + + + +!Naux=12.96 !default + naux =0.0 +! Nall =dNaux +! Sh=0.0 + n_iw=0.0 + nin_a_nuc_dust=0.0; nin_a_nuc_soot=0.0; nin_a_nuc_bio= + &0.0; nin_a_nuc_solo=0.0 + num_ic_dust_imm=0.0; num_ic_soot_imm=0.0; num_ic_bio_imm= + &0.0; num_ic_solo_imm=0.0 +! AnningC uncom following four lines + n_in_dust=0.0; dn_in_dust=0.0;n_in_soot=0.0 + dn_in_soot=0.0; dn_in_bio=0.0; n_in_bio=0.0; + dn_in_solO=0.0;n_in_solO=0.0;n_in_dust_ultra=0.0 + n_in_soot_ultra=0.0;n_in_bio_ultra=0.0; + + + H_frac_dust = 0.0 + H_frac_soot = 0.0 + H_frac_solo = 0.0 +! H1smooth=0.0 + aux=0.0 + + temperature_K=SNGL(T_ice) + P_SAT =SNGL(P_ice) + +!A_solo = 1e-7 !m2 kg-1 + + +!==================================================================================== +! COMPUTATION BLOCK +! +!==================================================================================== +! + rho_AIDA = 90000./(287.*205.) + + rho = P_SAT/(287.*temperature_K) + + Psi_solO = A_solO/BASE_SOLO_OMEGA + SS_i = min(max(SI-1.0, 0.0), 1.0) + SS_w = min(max(SW-1.0, -1.0), 1.0) + SS_iw = min(max(SIW - 1.0, 0.0), 1.0) + + + if(SS_i > 0.0) then + if(temperature_K < 273.15 .and. temperature_K > 273.15 - + & 90. ) then + + + if(SS_w > 0.) then + SS_i = SS_iw + SS_w = 0.0 + end if + + +! S_i_zero = 1.15 !this is taken care of + + + delta_Si = H_1_smooth(SS_i + 1, 1.1, 1.2, 0.0, 1.,dH1smooth); + delta_T = H_1_smooth(-(temperature_K-273.15), 35., 40., + & FRACTION_DEPNUCL_WARM_DUST, 1.,dH1smooth); + delta_Sw = H_1_smooth(SS_w + 1.0, 0.97, 1., 0., 1.,dH1smooth); + + tc_HM_degC = temperature_K - 273.15 + + + S_i_0 = 1. + 10.**(8.2584e-6*tc_HM_degC*tc_HM_degC*tc_HM_degC + + & 5.3938E-4*tc_HM_degC*tc_HM_degC + 3.1656E-3*tc_HM_degC - 1.0261) + + + S_w_0 = 0.97 + + aux =H_1_smooth(-(temperature_K-273.15), 35., 40., + & FRACTION_DEPNUCL_WARM_DUST, 1.,dH1smooth)/FAC_CORRECT_RH + + dep_frac = H_1_smooth(SS_i + 1, S_i_0, S_i_0 + 0.1, 0.,1., + & dH1smooth)* aux + dfdep=dH1smooth*aux + + aux= H_1_smooth(SS_w + 1.0, S_w_0, 1., 0.,1.,dH1smooth) + + H_frac_dust = dep_frac + (1. - dep_frac)*aux + + dH_frac_dust = dfdep + (SIW*(1. - dep_frac)*dH1smooth)- aux* + &dfdep + + if(H_frac_dust > 1.) H_frac_dust = 1. + + if ((H_frac_dust .gt. 1.0e-6) .and. (H_frac_dust .lt. 1.)) then + dH_frac_dust = dH_frac_dust/H_frac_dust + else + dH_frac_dust =0.0 + end if + + + S_i_0 = 1.2 + + aux =H_1_smooth(-(temperature_K-273.15), 65., 75., 0.,1., + & dH1smooth) + dep_frac = H_1_smooth(SS_i + 1, S_i_0, S_i_0+0.1, 0.,1., + & dH1smooth)*aux + H_frac_solO = dep_frac + dH_frac_solo=0.0 + if ((H_frac_solo .gt. 1.0e-6) .and. (H_frac_solo .lt. 1.)) then + dH_frac_solo = dH1smooth/H_frac_solo + end if + if(H_frac_solO > 1.) H_frac_solO = 1. + + + S_w_0 = 0.97 + + S_i_0 = 1.3 +! + aux = H_1_smooth(-(temperature_K-273.15), 40., 50., 0.,1., + & dH1smooth) / FAC_CORRECT_RH + dep_frac = H_1_smooth(SS_i + 1, S_i_0, S_i_0+0.1, 0.,1., + & dH1smooth)* aux + + dfdep= dH1smooth*aux + + aux = H_1_smooth(SS_w + 1.0, S_w_0, 1., 0.,1.,dH1smooth) + H_frac_soot = dep_frac + (1. - dep_frac)*aux + if(H_frac_soot > 1.) H_frac_soot = 1. + + dH_frac_soot = dfdep + (SIW*(1. - dep_frac)*dH1smooth)- aux* + &dfdep + if ((H_frac_soot .gt. 1.0e-6) .and. (H_frac_soot .lt. 1.)) then + dH_frac_soot = dH_frac_soot/H_frac_soot + else + dH_frac_soot =0.0 + end if + + + H_frac_bio = H_frac_soot + + if(temperature_K < 273.15 .and. temperature_K >= 273.15 - + & 35.) then + n_in = 1.E3* (exp(12.96*SS_i - 0.639)/RHO_CFDC) *0.0587* + &FAC_CORRECT_RH + if( temperature_K > 273.15 -5. .and. temperature_K < 273.15 - + & 2. ) then + n_in = n_in*H_1_smooth(-(temperature_K-273.15), 2., 5., 0., 1., + & dH1smooth) + endif + if(temperature_K >= 273.15 - 2. ) n_in = 0. + + + if(temperature_K < 273.15 -25. ) then + n_in_tilde = 1000.*(exp(0.1296*(SS_i*100.-10.))**0.3)* + &FAC_CORRECT_RH/RHO_CFDC + n_in_hat = n_in + + if(temperature_K >= 273.15 - 30.) n_in_max = 1.E3* (exp(12.96* + &SS_iw - 0.639)/RHO_CFDC) *0.0587*FAC_CORRECT_RH + if(temperature_K < 273.15 - 30.) n_in_max = 1000.*(exp(0.1296* + &(SS_iw*100.-10.))**0.3)*FAC_CORRECT_RH/RHO_CFDC + + if(n_in_hat > n_in_max) n_in_hat = n_in_max + if(n_in_tilde > n_in_max) n_in_tilde = n_in_max + + + + n_in = n_in_hat * ((n_in_tilde/n_in_hat)**(H_1_smooth(- + &(temperature_K-273.15), 25., 35., 0., 1.,dH1smooth))) + + + if(n_in > n_in_max) n_in = n_in_max + + endif + n_in_dust = 0. + dn_in_dust = 0. + + + if(temperature_K < 273.15 - 30.) then + dnaux = 3.88 + else + dnaux = 12.96 + end if + + + naux=0.0 + do ij = 1, ijstop_dust + if (is_gocart) then + mu = n_in*ALPHA_DUST*H_frac_dust*ahet_dust(ij)/BASE_DUST_OMEGA + else + ahet_aux = PIE*D_grid_dust(ij)*D_grid_dust(ij)*D_grid_dust(ij)* + &4.73*acorr_dust/6.0 + mu = n_in*ALPHA_DUST*H_frac_dust*ahet_aux/BASE_DUST_OMEGA + end if + naux = (1. - exp(-mu))*n_grid_dust(ij) + n_in_dust = n_in_dust + naux + dn_in_dust = max(mu*(n_grid_dust(ij)-naux)*(dnaux + + & dH_frac_dust), 0.0) + dn_in_dust + + enddo + + if( temperature_K > 273.15 +TEMP_MAX_DUST_DEGC - + & 20. .and. temperature_K < 273.15 + TEMP_MAX_DUST_DEGC) then + n_in_dust = n_in_dust*H_1_smooth(-(temperature_K-273.15),- + &TEMP_MAX_DUST_DEGC,-TEMP_MAX_DUST_DEGC+20., 0., 1.,dH1smooth) + endif + if(temperature_K >= 273.15 + TEMP_MAX_DUST_DEGC) n_in_dust = 0. + + + n_in_soot = 0. + dn_in_soot = 0. + do ij = 1, ijstop_soot + + if (is_gocart) then + mu = n_in*ALPHA_SOOT*H_frac_soot*ahet_bc/BASE_SOOT_PHILIC_OMEGA + else + ahet_aux = PIE*D_grid_soot(ij)*D_grid_soot(ij)*D_grid_soot(ij)* + &16.4*acorr_bc/6.0 + mu = n_in*ALPHA_SOOT*H_frac_soot*ahet_aux/BASE_SOOT_PHILIC_OMEGA + end if + naux = (1. - exp(-mu))*n_grid_soot(ij) + n_in_soot = n_in_soot + naux + dn_in_soot = max(mu*(n_grid_soot(ij)-naux)*(dnaux+dH_frac_soot), + & 0.0) + dn_in_soot + + enddo + + if( temperature_K > 273.15 + TEMP_MAX_SOOT_DEGC - + & 10. .and. temperature_K < 273.15 + TEMP_MAX_SOOT_DEGC) then + n_in_soot = n_in_soot*H_1_smooth(-(temperature_K-273.15),- + &TEMP_MAX_SOOT_DEGC,-TEMP_MAX_SOOT_DEGC+10., 0., 1.,dH1smooth) + + endif + if(temperature_K >= 273.15 + TEMP_MAX_SOOT_DEGC) n_in_soot = 0. + + n_in_bio = 0. + dn_in_bio = 0. + + + do ij = 1, ijstop_bio + mu = n_in*ALPHA_bio*H_frac_bio*PIE*(D_grid_bio(ij)**2.) / + &BASE_BIO_OMEGA + + mu = n_in*ALPHA_bio*H_frac_bio + naux = (1. - exp(-mu))*n_grid_bio(ij) + + + + + n_in_bio = n_in_bio + naux + dn_in_bio = max(mu*(n_grid_bio(ij)-naux)*dnaux, 0.0) + dn_in_bio + + + enddo + + + if( temperature_K > 273.15 + TEMP_MAX_bio_DEGC - + & 3. .and. temperature_K < 273.15 + TEMP_MAX_bio_DEGC) then + n_in_bio = n_in_bio*H_1_smooth(-(temperature_K-273.15),- + &TEMP_MAX_bio_DEGC,-TEMP_MAX_bio_DEGC+3., 0., 1.,dH1smooth) + + endif + if(temperature_K >= 273.15 + TEMP_MAX_bio_DEGC ) n_in_bio = 0. + + + + else + n_in = 0.; n_in_ultra = 0.; n_in_dust = 0.; n_in_soot = + & 0.; n_in_bio = 0.; + endif + + if(temperature_K < 273.15 - 35.) then + n_in_ultra = 1000.*(exp(0.1296*(SS_i*100.-10.))**0.3)* + &FAC_CORRECT_RH/RHO_CFDC + dnaux = 3.88 + naux=0.0 + + + RHI = (SS_i+1.)*100. + if(RHI < 0.) RHI = 0. + n_in_solO_star = 1000.e6*(7.7211e-5 * RHI - 9.2688e-3)/rho_AIDA + + + n_in_dust_ultra = 0.; + dn_in_dust = 0.0 + do ij = 1, ijstop_dust + + if (is_gocart) then + mu = n_in_ultra*ALPHA_DUST*H_frac_dust*ahet_dust(ij)/ + &BASE_DUST_OMEGA + else + ahet_aux = PIE*D_grid_dust(ij)*D_grid_dust(ij)*D_grid_dust(ij)* + &4.73*acorr_dust/6.0 + mu = n_in_ultra*ALPHA_DUST*H_frac_dust*ahet_aux/BASE_DUST_OMEGA + end if + + + + naux = (1. - exp(-mu))*n_grid_dust(ij) + n_in_dust_ultra = n_in_dust_ultra + naux + dn_in_dust = max(mu*(n_grid_dust(ij)-naux)*(dnaux +dH_frac_dust), + & 0.0) + dn_in_dust + + + + enddo + + + + n_in_soot_ultra = 0.0 + dn_in_soot = 0.0 + do ij = 1, ijstop_soot + + if (is_gocart) then + mu = n_in_ultra*ALPHA_SOOT*H_frac_soot*ahet_bc/ + &BASE_SOOT_PHILIC_OMEGA + else + ahet_aux = PIE*D_grid_soot(ij)*D_grid_soot(ij)*D_grid_soot(ij)* + &16.4*acorr_bc/6.0 + mu = n_in_ultra*ALPHA_SOOT*H_frac_soot*ahet_aux/ + &BASE_SOOT_PHILIC_OMEGA + end if + + + + naux = (1. - exp(-mu))*n_grid_soot(ij) + n_in_soot_ultra = n_in_soot_ultra + naux + dn_in_soot = max(mu*(n_grid_soot(ij)-naux)*(dnaux +dH_frac_soot), + & 0.0) + dn_in_soot + + enddo + + + n_in_bio_ultra = 0. + dn_in_bio = 0.0 + + + + + + + + + + + n_in_solO = Psi_solO*glass_frac*H_frac_solO*n_in_solO_star + dn_in_solO =max(Psi_solO*glass_frac* (H_frac_solO*77211.0*100.0/ + &rho_AIDA + n_in_solO_star*dH_frac_solo), 0.0) + + + else + n_in_ultra = 0.; n_in_dust_ultra = 0.; n_in_soot_ultra = + & 0.; n_in_solO = 0.; n_in_bio_ultra = 0.; + endif + + + + n_in_dust = n_in_dust + n_in_dust_ultra; + n_in_soot = n_in_soot + n_in_soot_ultra; + n_in_bio = n_in_bio + n_in_bio_ultra; + + + + +! PROBLEM: how to ensure that the frozen fraction does not exceed 1 ? + + if (.false.) then + if(n_in_dust + n_in_bio + n_in_soot + n_in_solO > 0.) then + + CIHENC_dust = n_in_dust - nin_a_nuc_dust + if(CIHENC_dust < 0.) CIHENC_dust = 0. + + CIHENC_soot = n_in_soot - nin_a_nuc_soot + if(CIHENC_soot < 0.) CIHENC_soot = 0. + + CIHENC_bio = n_in_bio - nin_a_nuc_bio + if(CIHENC_bio < 0.) CIHENC_bio = 0. + + CIHENC_solO = n_in_solO - nin_a_nuc_solO + if(CIHENC_solO < 0.) CIHENC_solO = 0. + + + n_iw = n_iw + CIHENC_dust + nin_a_nuc_dust = nin_a_nuc_dust + CIHENC_dust + num_ic_dust_imm = num_ic_dust_imm + CIHENC_dust + + n_iw = n_iw + CIHENC_soot + nin_a_nuc_soot = nin_a_nuc_soot + CIHENC_soot + num_ic_soot_imm = num_ic_soot_imm + CIHENC_soot + + n_iw = n_iw + CIHENC_bio + nin_a_nuc_bio = nin_a_nuc_bio + CIHENC_bio + num_ic_bio_imm = num_ic_bio_imm + CIHENC_bio + + n_iw = n_iw + CIHENC_solO + nin_a_nuc_solO = nin_a_nuc_solO + CIHENC_solO + num_ic_solO_imm = num_ic_solO_imm + CIHENC_solO + + + endif + end if + endif + endif + + n_iw = n_in_dust + n_in_bio + n_in_soot + n_in_solO + dNall = dn_in_dust + dn_in_bio + dn_in_soot + dn_in_solO + + if (n_iw .gt. zero_par) then + fdust_dep = DBLE(n_in_dust/n_iw) + end if + Nhet_dep = DBLE(n_in_dust) + Nhet_dhf = DBLE(n_in_solO) + + + + + if (( dNall > 0.) .and. (n_iw .gt. 0.0)) then + Dsh=max(min(n_iw/dNall, SS_i), 0.005) + else + Dsh=0.005 + end if + + + END SUBROUTINE EMPIRICAL_PARAM_PHILLIPS + + real function H_1(X, X_1, X_2, Hlo) + real, intent(in) :: Hlo, X, X_1, X_2 + + if(X >= X_2) H_1 = 1 + if(X <= X_1) H_1 = Hlo + if(X > X_1 .and. X < X_2) H_1 = (X - X_1)/(X_2 - X_1) + + if( X_2 <= X_1) stop 91919 + + return + end function + + + real function H_1_smooth(X, X_1, X_2, Hlo, Hhi,dH1smooth) + real, intent(in) :: Hlo, Hhi, X, X_1, X_2 + real*4,intent(out) :: dH1smooth + real :: a_0, a_1, a_2, a_3, A, B + + if(X >= X_2) H_1_smooth = Hhi + if(X <= X_1) H_1_smooth = Hlo + + if(X >= X_2) dH1smooth = 0.0 + if(X <= X_1) dH1smooth = 0.0 + + if(X > X_1 .and. X < X_2) then + A = 6.*(Hlo - Hhi)/(X_2**3. - X_1**3. + 3.*(X_2*X_1*X_1 - X_1* + &X_2*X_2) ) + a_3 = (A/3.) + a_2 = -(A/2.)*(X_1 + X_2) + a_1 = A*X_2*X_1 + B = Hlo + A*(X_1**3.)/6. - A*X_1*X_1*X_2/2. + a_0 = B + H_1_smooth = a_0 + a_1*X + a_2*X*X + a_3*X*X*X + dH1smooth = a_1 + 2.0*a_2*X + 3.0*a_3*X*X + endif + +!H1smooth =min(dH1smooth , 1000000.0) +!H1smooth =max(dH1smooth , 0.0) + + if( X_2 <= X_1) stop 91919 + + return + end function + + + + + +! END ICE PARAMETERIZATION DONIF +! +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + + + END MODULE aer_cloud + + + + + + diff --git a/gsmphys/calpreciptype.f90 b/gsmphys/calpreciptype.f90 new file mode 100644 index 00000000..7260b974 --- /dev/null +++ b/gsmphys/calpreciptype.f90 @@ -0,0 +1,1412 @@ + subroutine calpreciptype(kdt,nrcm,im,ix,lm,lp1,randomno, & + xlat,xlon, & + gt0,gq0,prsl,prsi,prec, & !input + phii,n3dfercld,tskin,sr,phy_f3d, & !input + domr,domzr,domip,doms) !output + +!$$$ subprogram documentation block +! . . . +! subprogram: calpreciptype compute dominant precip type +! prgrmmr: chuang org: w/np2 date: 2008-05-28 +! +! +! abstract: +! this routine computes precipitation type. +! . it is adopted from post but was made into a column to used by gfs model +! +! -------------------------------------------------------------------- + use funcphys, only : fpvs,ftdp,fpkap,ftlcl,stma,fthe + use physcons +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + real, parameter :: pthresh = 0.0, oneog = 1.0/con_g + integer,parameter :: nalg = 5 +! +! declare variables. +! + integer,intent(in) :: kdt,nrcm,im,ix,lm,lp1,n3dfercld + real,intent(in) :: xlat(im),xlon(im) + real,intent(in) :: randomno(ix,nrcm) + real(kind=kind_phys),dimension(im), intent(in) :: prec,sr,tskin + real(kind=kind_phys),dimension(ix,lm), intent(in) :: gt0,gq0,prsl,phy_f3d + real(kind=kind_phys),dimension(ix,lp1),intent(in) :: prsi,phii + real(kind=kind_phys),dimension(im), intent(out) :: domr,domzr,domip,doms + + integer, dimension(nalg) :: sleet,rain,freezr,snow + real(kind=kind_phys),dimension(lm) :: t,q,pmid,f_rimef + real(kind=kind_phys),dimension(lp1) :: pint,zint + real(kind=kind_phys), allocatable :: twet(:),rh(:),td(:) +! + integer i,iwx,isno,iip,izr,irain,k,k1 + real(kind=kind_phys) es,qc,pv,tdpd,pr,tr,pk,tlcl,thelcl,qwet, & + time_vert,time_ncep,time_ramer,time_bourg,time_revised,& + time_dominant,btim,timef,ranl(2) + +! +! computes wet bulb here since two algorithms use it +! lp1=lm+1 +! convert geopotential to height +! do l=1,lp1 +! zint(l)=zint(l)/con_g +! end do +! don't forget to flip 3d arrays around because gfs counts from bottom up + + allocate ( twet(lm),rh(lm),td(lm) ) + +! print*,'debug calpreciptype: ', im,lm,lp1,nrcm + +! time_vert = 0. +! time_ncep = 0. +! time_ramer = 0. +! time_bourg = 0. +! time_revised = 0. + + do i=1,im + if (prec(i) > pthresh) then + do k=1,lm + k1 = lm-k+1 + t(k1) = gt0(i,k) + q(k1) = gq0(i,k) + pmid(k1) = prsl(i,k) ! pressure in pascals + f_rimef(k1) = phy_f3d(i,k) +! +! compute wet bulb temperature +! + pv = pmid(k1)*q(k1)/(con_eps-con_epsm1*q(k1)) + td(k1) = ftdp(pv) + tdpd = t(k1)-td(k1) +! if (pmid(k1) >= 50000.) then ! only compute twet below 500mb to save time + if (tdpd > 0.) then + pr = pmid(k1) + tr = t(k1) + pk = fpkap(pr) + tlcl = ftlcl(tr,tdpd) + thelcl = fthe(tlcl,pk*tlcl/tr) + call stma(thelcl,pk,twet(k1),qwet) + else + twet(k1) = t(k1) + endif +! endif + es = min(fpvs(t(k1)), pmid(k1)) + qc = con_eps*es / (pmid(k1)+con_epsm1*es) + rh(k1) = max(con_epsq,q(k1)) / qc + + k1 = lp1-k+1 + pint(k1) = prsi(i,k) + zint(k1) = phii(i,k) * oneog + + enddo + pint(1) = prsi(i,lp1) + zint(1) = phii(i,lp1) * oneog + +!------------------------------------------------------------------------------- +! if(kdt>15.and.kdt<20) time_vert = time_vert + (timef() - btim) +! debug print statement +! if (abs(xlon(i)*57.29578-114.0) .lt. 0.2 .and. & +! abs(xlat(i)*57.29578-40.0) .lt. 0.2)then +! print*,'debug in calpreciptype: i,im,lm,lp1,xlon,xlat,prec,tskin,sr,nrcm,randomno,n3dfercld ', & +! i,im,lm,lp1,xlon(i)*57.29578,xlat(i)*57.29578,prec(i),tskin(i),sr(i), & +! nrcm,randomno(i,1:nrcm),n3dfercld +! do l=1,lm +! print*,'debug in calpreciptype: l,t,q,p,pint,z,twet', & +! l,t(l),q(l), & +! pmid(l),pint(l),zint(l),twet(l) +! end do +! print*,'debug in calpreciptype: lp1,pint,z ', lp1,pint(lp1),zint(lp1) +! end if +! end debug print statement +! call wetbulb(lm,con_rocp,con_epsq,t,q,pmid,twet) +! if(kdt>10.and.kdt<20)btim = timef() +!------------------------------------------------------------------------------- +! +! instantaneous precipitation type. + + call calwxt(lm,lp1,t,q,pmid,pint,con_fvirt,con_rog,con_epsq,zint,iwx,twet) + snow(1) = mod(iwx,2) + sleet(1) = mod(iwx,4)/2 + freezr(1) = mod(iwx,8)/4 + rain(1) = iwx/8 + +! dominant precipitation type + +!gsm if dominant precip type is requested, 4 more algorithms +!gsm will be called. the tallies are then summed in calwxt_dominant + +! ramer algorithm +! allocate ( rh(lm),td(lm) ) +! do l=1,lm +!hc: use rh and td consistent with gfs ice physics +! es=fpvs(t(l)) +! es=min(es,pmid(l)) +! qc=con_eps*es/(pmid(l)+con_epsm1*es) +! rh(l)=max(con_epsq,q(l))/qc +! pv = pmid(l)*q(l)/(con_eps-con_epsm1*q(l)) +! td(l)=ftdp(pv) +! end do +! if(kdt>10.and.kdt<20)btim = timef() + +! write(0,*)' i=',i,' lm=',lm,' lp1=',lp1,' t=',t(1),q(1),pmid(1) & +! &,' pint=',pint(1),' prec=',prec(i),' pthresh=',pthresh + + call calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,iwx) + +! + snow(2) = mod(iwx,2) + sleet(2) = mod(iwx,4)/2 + freezr(2) = mod(iwx,8)/4 + rain(2) = iwx/8 + +! bourgouin algorithm +! iseed=44641*(int(sdat(1)-1)*24*31+int(sdat(2))*24+ihrst)+ & +! & mod(ifhr*60+ifmin,44641)+4357 + + ranl = randomno(i,1:2) + call calwxt_bourg(lm,lp1,ranl,con_g,t,q,pmid,pint,zint(1),iwx) + +! + snow(3) = mod(iwx,2) + sleet(3) = mod(iwx,4)/2 + freezr(3) = mod(iwx,8)/4 + rain(3) = iwx/8 +! +! revised ncep algorithm +! + call calwxt_revised(lm,lp1,t,q,pmid,pint, & + con_fvirt,con_rog,con_epsq,zint,twet,iwx) +! + snow(4) = mod(iwx,2) + sleet(4) = mod(iwx,4)/2 + freezr(4) = mod(iwx,8)/4 + rain(4) = iwx/8 +! +! explicit algorithm (under 18 not admitted without parent or guardian) + + if(n3dfercld == 3) then ! ferrier's scheme + call calwxt_explicit(lm,tskin(i),sr(i),f_rimef,iwx) + snow(5) = mod(iwx,2) + sleet(5) = mod(iwx,4)/2 + freezr(5) = mod(iwx,8)/4 + rain(5) = iwx/8 + else + snow(5) = 0 + sleet(5) = 0 + freezr(5) = 0 + rain(5) = 0 + endif +! + call calwxt_dominant(nalg,rain(1),freezr(1),sleet(1), & + snow(1),domr(i),domzr(i),domip(i),doms(i)) + + else ! prec < pthresh + domr(i) = 0. + domzr(i) = 0. + domip(i) = 0. + doms(i) = 0. + end if + enddo ! end loop for i + + deallocate (twet,rh,td) + return + end +! +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +! + subroutine calwxt(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,iwx,twet) +! +! file: calwxt.f +! written: 11 november 1993, michael baldwin +! revisions: +! 30 sept 1994-setup new decision tree (m baldwin) +! 12 june 1998-conversion to 2-d (t black) +! 01-10-25 h chuang - modified to process hybrid model output +! 02-01-15 mike baldwin - wrf version +! +! +! routine to compute precipitation type using a decision tree +! approach that uses variables such as integrated wet bulb temp +! below freezing and lowest layer temperature +! +! see baldwin and contorno preprint from 13th weather analysis +! and forecasting conference for more details +! (or baldwin et al, 10th nwp conference preprint) +! +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! input: +! t,q,pmid,htm,lmh,zint +! + integer,intent(in) :: lm,lp1 + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: zint,pint + integer,intent(out) :: iwx + real,intent(in) :: d608,rog,epsq + + +! output: +! iwx - instantaneous weather type. +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain +! +! internal: +! +! real, allocatable :: twet(:) + real, parameter :: d00=0.0 + integer karr,licee + real tcold,twarm + +! subroutines called: +! wetbulb +! +! +! initialize weather type array to zero (ie, off). +! we do this since we want iwx to represent the +! instantaneous weather type on return. +! +! +! allocate local storage +! + + integer l,lice,iwrml,ifrzl + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4, & + surfw,surfc,dzkl,area1,pintk1,pintk2,pm150,pkl,tkl,qkl + +! allocate ( twet(lm) ) +! + iwx = 0 +! +! find coldest and warmest temps in saturated layer between +! 70 mb above ground and 500 mb +! also find highest saturated layer in that range +! +!meb + psfck = pint(lm+1) +!meb + tdchk = 2.0 + 760 tcold = t(lm) + twarm = t(lm) + licee = lm +! + do l=1,lm + qkl = q(l) + qkl = max(epsq,qkl) + tkl = t(l) + pkl = pmid(l) +! +! skip past this if the layer is not between 70 mb above ground and 500 mb +! + if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle + a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) + tdkl = (237.3*a) / (17.269-a) + 273.15 + tdpre = tkl - tdkl + if (tdpre < tdchk .and. tkl < tcold) tcold = tkl + if (tdpre < tdchk .and. tkl > twarm) twarm = tkl + if (tdpre < tdchk .and. l < licee) licee = l + enddo +! +! if no sat layer at dew point dep=tdchk, increase tdchk +! and start again (but don't make tdchk > 6) +! + if (tcold == t(lm) .and. tdchk < 6.0) then + tdchk = tdchk + 2.0 + goto 760 + endif +! +! lowest layer t +! + karr = 0 + tlmhk = t(lm) +! +! decision tree time +! + if (tcold > 269.15) then + if (tlmhk <= 273.15) then + +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(i,j),8)/4 +! if (izr.lt.1) iwx(i,j)=iwx(i,j)+4 + + iwx = iwx + 4 + goto 850 + else +! turn on the flag for rain = 8 +! if its not on already +! irain=iwx(i,j)/8 +! if (irain.lt.1) iwx(i,j)=iwx(i,j)+8 + + iwx = iwx + 8 + goto 850 + endif + endif + karr = 1 + 850 continue +! +! compute wet bulb only at points that need it +! +! call wetbulb(lm,t,q,pmid,karr,twet) +! call wetfrzlvl(twet,zwet) +! + if (karr > 0) then + lice=licee +!meb + psfck = pint(lm+1) +!meb + tlmhk = t(lm) + twrmk = twarm +! +! twet area variables calculate only what is needed +! from ground to 150 mb above surface from ground to tcold layer +! and from ground to 1st layer where wet bulb t < 0.0 +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! +! areap4 is the area of twet above -4 c below highest sat lyr +! + areas8 = d00 + areap4 = d00 + surfw = d00 + surfc = d00 +! + do l=lm,lice,-1 + area1 = (twet(l)-269.15) * (zint(l)-zint(l+1)) + if (twet(l) >= 269.15) areap4 = areap4 + area1 + enddo +! + if (areap4 < 3000.0) then +! turn on the flag for snow = 1 +! if its not on already +! isno=mod(iwx(i,j),2) +! if (isno.lt.1) iwx(i,j)=iwx(i,j)+1 + + iwx = iwx + 1 + return + endif +! +! areas8 is the net area of twet w.r.t. freezing in lowest 150mb +! + pintk1 = psfck + pm150 = psfck - 15000. +! + do l=lm,1,-1 + pintk2 = pint(l) + if (pintk1 >= pm150) then + dzkl = zint(l)-zint(l+1) +! sum partial layer if in 150 mb agl layer + if (pintk2 < pm150) & + dzkl = t(l)*(q(l)*d608+1.0)*rog*log(pintk1/pm150) + area1 = (twet(l)-273.15)*dzkl + areas8 = areas8 + area1 + endif + pintk1 = pintk2 + enddo +! +! surfw is the area of twet above freezing between the ground +! and the first layer above ground below freezing +! surfc is the area of twet below freezing between the ground +! and the warmest sat layer +! + ifrzl = 0 + iwrml = 0 +! + do l=lm,1,-1 + if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 + if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 +! + if (iwrml == 0 .or. ifrzl == 0) then +! if(pmid(l) < 50000.)print*,'need twet above 500mb' + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-273.15)*dzkl + if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 + if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 + endif + enddo + if(surfc < -3000.0 .or. (areas8 < -3000.0 .and. surfw < 50.0)) then +! turn on the flag for ice pellets = 2 if its not on already +! iip=mod(iwx(i,j),4)/2 +! if (iip.lt.1) iwx(i,j)=iwx(i,j)+2 + iwx = iwx + 2 +! + elseif(tlmhk < 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(k),8)/4 +! if (izr.lt.1) iwx(k)=iwx(k)+4 + iwx = iwx + 4 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx(k)/8 +! if (irain.lt.1) iwx(k)=iwx(k)+8 + iwx = iwx + 8 + endif + endif +!--------------------------------------------------------- +! deallocate (twet) + + return + end +! +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! +! dophase is a subroutine written and provided by jim ramer at noaa/fsl +! +! ramer, j, 1993: an empirical technique for diagnosing precipitation +! type from model output. preprints, 5th conf. on aviation +! weather systems, vienna, va, amer. meteor. soc., 227-230. +! +! code adapted for wrf post 24 august 2005 g manikin +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! + subroutine calwxt_ramer(lm,lp1,t,q,pmid,rh,td,pint,ptyp) + +! subroutine dophase(pq, ! input pressure sounding mb +! + t, ! input temperature sounding k +! + pmid, ! input pressure +! + pint, ! input interface pressure +! + q, ! input spec humidityfraction +! + lmh, ! input number of levels in sounding +! + ptyp) ! output(2) phase 2=rain, 3=frzg, 4=solid, +! 6=ip jc 9/16/99 +! use params_mod +! use ctlblk_mod +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! + real,parameter :: twice=266.55,rhprcp=0.80,deltag=1.02, & + & emelt=0.045,rlim=0.04,slim=0.85 + real,parameter :: twmelt=273.15,tz=273.15,efac=1.0 ! specify in params now +! + integer*4 i, k1, lll, k2, toodry +! + real xxx ,mye, icefrac + integer, intent(in) :: lm,lp1 + real,dimension(lm), intent(in) :: t,q,pmid,rh,td + real,dimension(lp1),intent(in) :: pint + integer, intent(out) :: ptyp +! + real,dimension(lm) :: tq,pq,rhq,twq +! + integer j,l,lev,ii + real rhmax,twmax,ptop,dpdrh,twtop,rhtop,wgt1,wgt2, & + rhavg,dtavg,dpk,ptw,pbot +! real b,qtmp,rate,qc + real,external :: xmytw +! +! initialize. + icefrac = -9999. +! + + ptyp = 0 + do l = 1,lm + lev = lp1 - l +! p(l)=pmid(l) +! qc=pq0/p(l) * exp(a2*(t(l)-a3)/(t(l)-a4)) +!gsm forcing q (qtmp) to be positive to deal with negative q values +! causing problems later in this subroutine +! qtmp=max(h1m12,q(l)) +! rhqtmp(lev)=qtmp/qc + rhq(lev) = rh(l) + pq(lev) = pmid(l) * 0.01 + tq(lev) = t(l) + enddo + + +! +!cc rate restriction removed by john cortinas 3/16/99 +! +! construct wet-bulb sounding, locate generating level. + twmax = -999.0 + rhmax = 0.0 + k1 = 0 ! top of precip generating layer + k2 = 0 ! layer of maximum rh +! + if (rhq(1) < rhprcp) then + toodry = 1 + else + toodry = 0 + end if +! + pbot = pq(1) +! nq=lm + do l = 1, lm +! xxx = tdofesat(esat(tq(l))*rhq(l)) +! xxx = td(l) !hc: use td consistent with gfs ice physics + xxx = td(lp1-l) !hc: use td consistent with gfs ice physics + if (xxx < -500.) return + twq(l) = xmytw(tq(l),xxx,pq(l)) + twmax = max(twq(l),twmax) + if (pq(l) >= 400.0) then + if (rhq(l) > rhmax) then + rhmax = rhq(l) + k2 = l + end if +! + if (l /= 1) then + if (rhq(l) >= rhprcp .or. toodry == 0) then + if (toodry /= 0) then + dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) + pbot = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) +! + ptw = pq(l) + toodry = 0 + else if (rhq(l)>= rhprcp) then + ptw = pq(l) + else + toodry = 1 + dpdrh = log(pq(l)/pq(l-1)) / (rhq(l)-rhq(l-1)) + ptw = exp(log(pq(l))+(rhprcp-rhq(l))*dpdrh) + +!lin dpdrh = (pq(i)-pq(i-1))/(rhq(i)-rhq(i-1)) +!lin ptw = pq(i)+(rhprcp-rhq(i))*dpdrh +! + end if +! + if (pbot/ptw >= deltag) then +!lin if (pbot-ptw.lt.deltag) goto 2003 + k1 = l + ptop = ptw + end if + end if + end if + end if + enddo +! +! gross checks for liquid and solid precip which dont require generating level. +! + if (twq(1) >= 273.15+2.0) then + ptyp = 8 ! liquid + icefrac = 0.0 + return + end if +! + if (twmax <= twice) then + icefrac = 1.0 + ptyp = 1 ! solid + return + end if +! +! check to see if we had no success with locating a generating level. +! + if (k1 == 0) return +! + if (ptop == pq(k1)) then + twtop = twq(k1) + rhtop = rhq(k1) + k2 = k1 + k1 = k1 - 1 + else + k2 = k1 + k1 = k1 - 1 + wgt1 = log(ptop/pq(k2)) / log(pq(k1)/pq(k2)) + wgt2 = 1.0 - wgt1 + twtop = twq(k1) * wgt1 + twq(k2) * wgt2 + rhtop = rhq(k1) * wgt1 + rhq(k2) * wgt2 + end if +! +! calculate temp and wet-bulb ranges below precip generating level. + do l = 1, k1 + twmax = max(twq(l),twmax) + enddo +! +! gross check for solid precip, initialize ice fraction. +! if (i.eq.1.and.j.eq.1) write (*,*) 'twmax=',twmax,twice,'twtop=',twtop + + if (twtop <= twice) then + icefrac = 1.0 + if (twmax <= twmelt) then ! gross check for solid precip. + ptyp = 1 ! solid precip + return + end if + lll = 0 + else + icefrac = 0.0 + lll = 1 + end if +! +! loop downward through sounding from highest precip generating level. + 30 continue +! + if (icefrac >= 1.0) then ! starting as all ice + if (twq(k1) < twmelt) go to 40 ! cannot commence melting + if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h + wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dtavg = (twmelt-twq(k1)) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye=emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else if (icefrac <= 0.0) then ! starting as all liquid + lll = 1 +! goto 1020 + if (twq(k1) > twice) go to 40 ! cannot commence freezing + if (twq(k1) == twtop) then + wgt1 = 0.5 + else + wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) + end if + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dtavg = twmelt - (twq(k1)+twice) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else if ((twq(k1) <= twmelt).and.(twq(k1) < twmelt)) then ! mix + rhavg = (rhq(k1)+rhtop) * 0.5 + dtavg = twmelt - (twq(k1)+twtop) * 0.5 + dpk = log(pq(k1)/ptop) !lin dpk=pq(k1)-ptop +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + else ! mix where tw curve crosses twmelt in layer + if (twq(k1) == twtop) go to 40 ! both equal twmelt, nothing h + wgt1 = (twmelt-twq(k1)) / (twtop-twq(k1)) + wgt2 = 1.0 - wgt1 + rhavg = rhtop + wgt2 * (rhq(k1)-rhtop) * 0.5 + dtavg = (twmelt-twtop) * 0.5 + dpk = wgt2 * log(pq(k1)/ptop) !lin dpk=wgt2*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + icefrac = min(1.0,max(icefrac,0.0)) + if (icefrac <= 0.0) then +! goto 1020 + if (twq(k1) > twice) go to 40 ! cannot commence freezin + wgt1 = (twice-twq(k1)) / (twtop-twq(k1)) + dtavg = twmelt - (twq(k1)+twice) * 0.5 + else + dtavg = (twmelt-twq(k1)) * 0.5 + end if + rhavg = rhq(k1) + wgt1 * (rhtop-rhq(k1)) * 0.5 + dpk = wgt1 * log(pq(k1)/ptop) !lin dpk=wgt1*(pq(k1)-ptop) +! mye = emelt*(1.0-(1.0-rhavg)*efac) + mye = emelt * rhavg ** efac + icefrac = icefrac + dpk * dtavg / mye + end if +! + icefrac = min(1.0,max(icefrac,0.0)) + +! if (i.eq.1.and.j.eq.1) write (*,*) 'new icefrac:', icefrac, icefrac +! +! get next level down if there is one, loop back. + 40 continue + if (k1 > 1) then + twtop = twq(k1) + ptop = pq(k1) + rhtop = rhq(k1) + k1 = k1 - 1 + go to 30 + end if +! +! determine precip type based on snow fraction and surface wet-bulb. +! + if (icefrac >= slim) then + if (lll /= 0) then + ptyp = 2 ! ice pellets jc 9/16/99 + else + ptyp = 1 ! snow + end if + else if (icefrac <= rlim) then + if (twq(1).lt.tz) then + ptyp = 4 ! freezing precip + else + ptyp = 8 ! rain + end if + else + if (twq(1) < tz) then +!gsm not sure what to do when 'mix' is predicted; in previous +!gsm versions of this code for which i had to have an answer, +!gsm i chose sleet. here, though, since we have 4 other +!gsm algorithms to provide an answer, i will not declare a +!gsm type from the ramer in this situation and allow the +!gsm other algorithms to make the call. + + ptyp = 0 ! don't know +! ptyp = 5 ! mix + else +! ptyp = 5 ! mix + ptyp = 0 ! don't know + end if + end if + + return +! + end +! +! +!-------------------------------------------------------------------------- + function xmytw(t,td,p) +! + implicit none +! + integer*4 cflag, l + real f, c0, c1, c2, k, kd, kw, ew, t, td, p, ed, fp, s, & + & de, xmytw + data f, c0, c1, c2 /0.0006355, 26.66082, 0.0091379024, 6106.3960/ +! + xmytw = (t+td) / 2 + if (td >= t) return +! + if (t < 100.0) then + k = t + 273.15 + kd = td + 273.15 + if (kd >= k) return + cflag = 1 + else + k = t + kd = td + cflag = 0 + end if +! + ed = c0 - c1 * kd - c2 / kd + if (ed < -14.0 .or. ed > 7.0) return + ed = exp(ed) + ew = c0 - c1 * k - c2 / k + if (ew < -14.0 .or. ew > 7.0) return + ew = exp(ew) + fp = p * f + s = (ew-ed) / (k-kd) + kw = (k*fp+kd*s) / (fp+s) +! + do l = 1, 5 + ew = c0 - c1 * kw - c2 / kw + if (ew < -14.0 .or. ew > 7.0) return + ew = exp(ew) + de = fp * (k-kw) + ed - ew + if (abs(de/ew) < 1e-5) exit + s = ew * (c1-c2/(kw*kw)) - fp + kw = kw - de / s + enddo +! +! print *, 'kw ', kw + if (cflag /= 0) then + xmytw = kw - 273.15 + else + xmytw = kw + end if +! + return + end +! +! +!$$$ subprogram documentation block +! +! subprogram: calwxt_bourg calculate precipitation type (bourgouin) +! prgmmr: baldwin org: np22 date: 1999-07-06 +! +! abstract: this routine computes precipitation type +! using a decision tree approach that uses the so-called +! "energy method" of bourgouin of aes (canada) 1992 +! +! program history log: +! 1999-07-06 m baldwin +! 1999-09-20 m baldwin make more consistent with bourgouin (1992) +! 2005-08-24 g manikin added to wrf post +! 2007-06-19 m iredell mersenne twister, best practices +! 2008-03-03 g manikin added checks to prevent stratospheric warming +! episodes from being seen as "warm" layers +! impacting precip type +! +! usage: call calwxt_bourg(im,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1, & +! & iseed,g, & +! & t,q,pmid,pint,lmh,zint,ptype) +! input argument list: +! im integer i dimension +! jm integer j dimension +! jsta_2l integer j dimension start point (including haloes) +! jend_2u integer j dimension end point (including haloes) +! jsta integer j dimension start point (excluding haloes) +! jend integer j dimension end point (excluding haloes) +! lm integer k dimension +! lp1 integer k dimension plus 1 +! iseed integer random number seed +! g real gravity (m/s**2) +! pthresh real precipitation threshold (m) +! t real(im,jsta_2l:jend_2u,lm) mid layer temp (k) +! q real(im,jsta_2l:jend_2u,lm) specific humidity (kg/kg) +! pmid real(im,jsta_2l:jend_2u,lm) mid layer pressure (pa) +! pint real(im,jsta_2l:jend_2u,lp1) interface pressure (pa) +! lmh real(im,jsta_2l:jend_2u) max number of layers +! zint real(im,jsta_2l:jend_2u,lp1) interface height (m) +! output argument list: +! ptype real(im,jm) instantaneous weather type () +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain +! in other words... +! ptype=1 snow +! ptype=2 ice pellets/mix with ice pellets +! ptype=4 freezing rain/mix with freezing rain +! ptype=8 rain +! +! modules used: +! mersenne_twister pseudo-random number generator +! +! subprograms called: +! random_number pseudo-random number generator +! +! attributes: +! language: fortran 90 +! +! remarks: vertical order of arrays must be layer 1 = top +! and layer lmh = bottom +! +!$$$ + subroutine calwxt_bourg(lm,lp1,rn,g,t,q,pmid,pint,zint,ptype) + implicit none +! +! input: + integer,intent(in) :: lm,lp1 + real,intent(in) :: g,rn(2) + real,intent(in), dimension(lm) :: t, q, pmid + real,intent(in), dimension(lp1) :: pint, zint +! +! output: + integer, intent(out) :: ptype +! + integer ifrzl,iwrml,l,lhiwrm + real pintk1,areane,tlmhk,areape,pintk2,surfw,area1,dzkl,psfck,r1,r2 +! +! initialize weather type array to zero (ie, off). +! we do this since we want ptype to represent the +! instantaneous weather type on return. +! + ptype = 0 + psfck = pint(lm+1) + +! find the depth of the warm layer based at the surface +! this will be the cut off point between computing +! the surface based warm air and the warm air aloft +! +! lowest layer t +! + tlmhk = t(lm) + iwrml = lm + 1 + if (tlmhk >= 273.15) then + do l = lm, 2, -1 + if (t(l) >= 273.15 .and. t(l-1) < 273.15 .and. & + & iwrml == lm+1) iwrml = l + end do + end if +! +! now find the highest above freezing level +! + lhiwrm = lm + 1 + do l = lm, 1, -1 +! gsm added 250 mb check to prevent stratospheric warming situations +! from counting as warm layers aloft + if (t(l) >= 273.15 .and. pmid(l) > 25000.) lhiwrm = l + end do + +! energy variables +! surfw is the positive energy between the ground +! and the first sub-freezing layer above ground +! areane is the negative energy between the ground +! and the highest layer above ground +! that is above freezing +! areape is the positive energy "aloft" +! which is the warm energy not based at the ground +! (the total warm energy = surfw + areape) +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! dzkl is the thickness of the layer +! ifrzl is a flag that tells us if we have hit +! a below freezing layer +! + pintk1 = psfck + ifrzl = 0 + areane = 0.0 + areape = 0.0 + surfw = 0.0 + + do l = lm, 1, -1 + if (ifrzl == 0 .and. t(l) <= 273.15) ifrzl = 1 + pintk2 = pint(l) + dzkl = zint(l)-zint(l+1) + if (t(l) >= 273.15 .and. pmid(l) > 25000.) then + area1 = log(t(l)/273.15) * g * dzkl + if (l < iwrml) then + areape = areape + area1 + else + surfw = surfw + area1 + endif + elseif (l > lhiwrm) then + area1 = log(t(l)/273.15) * g * dzkl + areane = areane + abs(area1) + endif + pintk1 = pintk2 + enddo + +! +! decision tree time +! + if (areape < 2.0) then ! very little or no positive energy aloft, check for + ! positive energy just above the surface to determine rain vs. snow + if (surfw < 5.6) then ! not enough positive energy just above the surface snow = 1 + ptype = 1 + else if (surfw > 13.2) then ! enough positive energy just above the surface rain = 8 + ptype = 8 + else ! transition zone, assume equally likely rain/snow + ! picking a random number, if <=0.5 snow + r1 = rn(1) + if (r1 <= 0.5) then ! snow = 1 + ptype = 1 + else ! rain = 8 + ptype = 8 + end if + end if +! + else ! some positive energy aloft, check for enough negative energy + ! to freeze and make ice pellets to determine ip vs. zr + + if (areane > 66.0+0.66*areape) then +! enough negative area to make ip, +! now need to check if there is enough positive energy +! just above the surface to melt ip to make rain + if (surfw < 5.6) then ! not enough energy at the surface to melt ip ice pellets = 2 + ptype = 2 + elseif (surfw > 13.2) then ! enough energy at the surface to melt ip rain = 8 + ptype = 8 + else ! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip + r1 = rn(1) + if (r1 <= 0.5) then ! ice pellets = 2 + ptype = 2 + else ! rain = 8 + ptype = 8 + end if + end if + elseif (areane < 46.0+0.66*areape) then +! not enough negative energy to refreeze, check surface temp to determine rain vs. zr + if (tlmhk < 273.15) then ! freezing rain = 4 + ptype = 4 + else ! rain = 8 + ptype = 8 + end if + else +! transition zone, assume equally likely ip/zr picking a random number, if <=0.5 ip + r1 = rn(1) + if (r1 <= 0.5) then +! still need to check positive energy just above the surface to melt ip vs. rain + if (surfw < 5.6) then ! ice pellets = 2 + ptype = 2 + else if (surfw > 13.2) then ! rain = 8 + ptype = 8 + else +! transition zone, assume equally likely ip/rain picking a random number, if <=0.5 ip + r2 = rn(2) + if (r2 <= 0.5) then ! ice pellets = 2 + ptype = 2 + else ! rain = 8 + ptype = 8 + end if + end if + else +! not enough negative energy to refreeze, check surface temp to determine rain vs. zr + if (tlmhk < 273.15) then ! freezing rain = 4 + ptype = 4 + else ! rain = 8 + ptype = 8 + end if + end if + end if + end if +! + return + end +! +! + subroutine calwxt_revised(lm,lp1,t,q,pmid,pint, & + d608,rog,epsq,zint,twet,iwx) +! +! file: calwxt.f +! written: 11 november 1993, michael baldwin +! revisions: +! 30 sept 1994-setup new decision tree (m baldwin) +! 12 june 1998-conversion to 2-d (t black) +! 01-10-25 h chuang - modified to process hybrid model output +! 02-01-15 mike baldwin - wrf version +! 05-07-07 binbin zhou - add prec for rsm +! 05-08-24 geoff manikin - modified the area requirements +! to make an alternate algorithm +! +! +! routine to compute precipitation type using a decision tree +! approach that uses variables such as integrated wet bulb temp +! below freezing and lowest layer temperature +! +! see baldwin and contorno preprint from 13th weather analysis +! and forecasting conference for more details +! (or baldwin et al, 10th nwp conference preprint) +! +! since the original version of the algorithm has a high bias +! for freezing rain and sleet, the goal is to balance that bias +! with a version more likely to predict snow +! +! use params_mod +! use ctlblk_mod +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! list of variables needed +! parameters: +! d608,rog,h1,d00 +!hc parameter(d608=0.608,rog=287.04/9.8,h1=1.0,d00=0.0) +! +! input: +! t,q,pmid,htm,lmh,zint + + integer,intent(in) :: lm,lp1 + real,dimension(lm),intent(in) :: t,q,pmid,twet + real,dimension(lp1),intent(in) :: pint,zint + real,intent(in) :: d608,rog,epsq +! output: +! iwx - instantaneous weather type. +! acts like a 4 bit binary +! 1111 = rain/freezing rain/ice pellets/snow +! where the one's digit is for snow +! the two's digit is for ice pellets +! the four's digit is for freezing rain +! and the eight's digit is for rain + integer, intent(out) :: iwx +! internal: +! + real, parameter :: d00=0.0 + integer karr,licee + real tcold,twarm +! + integer l,lmhk,lice,iwrml,ifrzl + real psfck,tdchk,a,tdkl,tdpre,tlmhk,twrmk,areas8,areap4,area1, & + surfw,surfc,dzkl,pintk1,pintk2,pm150,qkl,tkl,pkl,area0,areap0 + +! subroutines called: +! wetbulb +! +! +! initialize weather type array to zero (ie, off). +! we do this since we want iwx to represent the +! instantaneous weather type on return. +! +! +! allocate local storage +! +! + iwx = 0 + lmhk=lm +! +! find coldest and warmest temps in saturated layer between +! 70 mb above ground and 500 mb +! also find highest saturated layer in that range +! +!meb + psfck = pint(lp1) +!meb + tdchk = 2.0 + 760 tcold = t(lmhk) + twarm = t(lmhk) + licee = lmhk +! + do l=1,lmhk + qkl = q(l) + qkl = max(epsq,qkl) + tkl = t(l) + pkl = pmid(l) +! +! skip past this if the layer is not between 70 mb above ground +! and 500 mb +! + if (pkl < 50000.0 .or. pkl > psfck-7000.0) cycle + a = log(qkl*pkl/(6.1078*(0.378*qkl+0.622))) + tdkl = (237.3*a)/(17.269-a)+273.15 + tdpre = tkl-tdkl + if (tdpre < tdchk .and. tkl < tcold) tcold = tkl + if (tdpre < tdchk .and. tkl > twarm) twarm = tkl + if (tdpre < tdchk .and. l < licee) licee = l + enddo +! +! if no sat layer at dew point dep=tdchk, increase tdchk +! and start again (but don't make tdchk > 6) +! + if (tcold == t(lmhk) .and. tdchk < 6.0) then + tdchk = tdchk + 2.0 + goto 760 + endif +! +! lowest layer t +! + karr = 0 + lmhk = lm + tlmhk = t(lmhk) +! +! decision tree time +! + if (tcold > 269.15) then + if (tlmhk <= 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx,8)/4 +! if (izr.lt.1) iwx=iwx+4 + iwx = iwx + 4 + goto 850 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx/8 +! if (irain.lt.1) iwx=iwx+8 + iwx = iwx + 8 + goto 850 + endif + endif + karr = 1 + 850 continue +! + if (karr > 0)then + lmhk = lm + lice = licee +!meb + psfck = pint(lp1) +!meb + tlmhk = t(lmhk) + twrmk = twarm +! +! twet area variables +! calculate only what is needed +! from ground to 150 mb above surface +! from ground to tcold layer +! and from ground to 1st layer where wet bulb t < 0.0 +! +! pintk1 is the pressure at the bottom of the layer +! pintk2 is the pressure at the top of the layer +! +! areap4 is the area of twet above -4 c below highest sat lyr +! areap0 is the area of twet above 0 c below highest sat lyr +! + areas8 = d00 + areap4 = d00 + areap0 = d00 + surfw = d00 + surfc = d00 + +! + do l=lmhk,lice,-1 + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-269.15)*dzkl + area0 = (twet(l)-273.15)*dzkl + if (twet(l) >= 269.15) areap4 = areap4 + area1 + if (twet(l) >= 273.15) areap0 = areap0 + area0 + enddo +! +! if (areap4.lt.3000.0) then turn on the flag for snow = 1 if its not on already +! isno=mod(iwx,2) +! if (isno.lt.1) iwx=iwx+1 +! iwx=iwx+1 +! go to 1900 +! endif + if (areap0 < 350.0) then ! turn on the flag for snow = 1 + iwx = iwx + 1 + return + endif +! +! areas8 is the net area of twet w.r.t. freezing in lowest 150mb +! + pintk1 = psfck + pm150 = psfck - 15000. +! + do l=lmhk,1,-1 + pintk2 = pint(l) + if(pintk1 >= pm150) then + dzkl = zint(l)-zint(l+1) +! +! sum partial layer if in 150 mb agl layer +! + if(pintk2 < pm150) dzkl = t(l)*(q(l)*d608+1.0)*rog* & + log(pintk1/pm150) + area1 = (twet(l)-273.15)*dzkl + areas8 = areas8 + area1 + endif + pintk1=pintk2 + enddo +! +! surfw is the area of twet above freezing between the ground +! and the first layer above ground below freezing +! surfc is the area of twet below freezing between the ground +! and the warmest sat layer +! + ifrzl = 0 + iwrml = 0 +! + do l=lmhk,1,-1 + if (ifrzl == 0 .and. t(l) < 273.15) ifrzl = 1 + if (iwrml == 0 .and. t(l) >= twrmk) iwrml = 1 +! + if (iwrml == 0 .or. ifrzl == 0) then +! if(pmid(l) .lt. 50000.)print*,'twet needed above 500mb' + dzkl = zint(l)-zint(l+1) + area1 = (twet(l)-273.15)*dzkl + if(ifrzl == 0 .and. twet(l) >= 273.15) surfw = surfw + area1 + if(iwrml == 0 .and. twet(l) <= 273.15) surfc = surfc + area1 + endif + enddo + if (surfc < -3000.0 .or. & + & (areas8 < -3000.0 .and. surfw < 50.0)) then +! turn on the flag for ice pellets = 2 if its not on already +! iip=mod(iwx,4)/2 +! if (iip.lt.1) iwx=iwx+2 + iwx = iwx + 2 + return + endif +! + if (tlmhk < 273.15) then +! turn on the flag for freezing rain = 4 if its not on already +! izr=mod(iwx(k),8)/4 +! if (izr.lt.1) iwx(k)=iwx(k)+4 + iwx = iwx + 4 + else +! turn on the flag for rain = 8 if its not on already +! irain=iwx(k)/8 +! if (irain.lt.1) iwx(k)=iwx(k)+8 + iwx = iwx + 8 + endif +! print *, 'revised check ', iwx(500,800) + endif + + return + end +! +! + subroutine calwxt_explicit(lm,tskin,sr,f_rimef,iwx) +! +! file: calwxt.f +! written: 24 august 2005, g manikin and b ferrier +! +! routine to compute precipitation type using explicit fields +! from the model microphysics + +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! list of variables needed +! parameters: +! +! input: + integer, intent(in) :: lm + real,intent(in) :: tskin, sr + real,intent(in) :: f_rimef(lm) + integer,intent(out) :: iwx + real snow +! real psfc +! +! allocate local storage +! + iwx = 0 + +!gsm the rsm is currently incompatible with this routine +!gsm according to b ferrier, there may be a way to write +!gsm a version of this algorithm to work with the rsm +!gsm microphysics, but it doesn't exist at this time + +! a snow ratio less than 0.5 eliminates snow and sleet +! use the skin temperature to distinguish rain from freezing rain +! note that 2-m temperature may be a better choice if the model +! has a cold bias for skin temperature +! + if (sr < 0.5) then +! surface (skin) potential temperature and temperature. +! psfc=pmid(lm) +! tskin=ths*(psfc/p1000)**capa + + if (tskin < 273.15) then ! freezing rain = 4 + iwx = iwx + 4 + else ! rain = 8 + iwx = iwx + 8 + endif + else +! +! distinguish snow from sleet with the rime factor +! + if(f_rimef(lm) >= 10) then ! sleet = 2 + iwx = iwx + 2 + else + snow = 1 + iwx = iwx + 1 + endif + endif + end +! +! + subroutine calwxt_dominant(nalg,rain,freezr,sleet,snow, & + & domr,domzr,domip,doms) +! +! written: 24 august 2005, g manikin +! +! this routine takes the precip type solutions from different +! algorithms and sums them up to give a dominant type +! +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! +! input: + integer,intent(in) :: nalg + real,intent(out) :: doms,domr,domzr,domip + integer,dimension(nalg),intent(in) :: rain,snow,sleet,freezr + integer l + real totsn,totip,totr,totzr +!-------------------------------------------------------------------------- +! print* , 'into dominant' + domr = 0. + doms = 0. + domzr = 0. + domip = 0. +! + totsn = 0 + totip = 0 + totr = 0 + totzr = 0 +! loop over the number of different algorithms that are used + do l = 1, nalg + if (rain(l) > 0) then + totr = totr + 1 + elseif (snow(l) > 0) then + totsn = totsn + 1 + elseif (sleet(l) > 0) then + totip = totip + 1 + elseif (freezr(l) > 0) then + totzr = totzr + 1 + endif + enddo + +! ties are broken to favor the most dangerous form of precip +! freezing rain > snow > sleet > rain + if (totsn > totip) then + if (totsn > totzr) then + if (totsn >= totr) then + doms = 1 + else + domr = 1 + endif + elseif (totzr >= totr) then + domzr = 1 + else + domr = 1 + endif + else if (totip > totzr) then + if (totip >= totr) then + domip = 1 + else + domr = 1 + endif + else if (totzr >= totr) then + domzr = 1 + else + domr = 1 + endif +! + return + end diff --git a/gsmphys/cldmacro.F b/gsmphys/cldmacro.F new file mode 100644 index 00000000..34568dac --- /dev/null +++ b/gsmphys/cldmacro.F @@ -0,0 +1,2372 @@ + module cldmacro +!======================================================================= +! Anning Cheng 2/18/2016 replaced GEO condensation scheme +! with those from 2M microphysics + use wv_saturation, only: + & epsqs,ttrice,hlatv,hlatf,pcf,rgasv +! & ,vqsatd2_water_single, +! & vqsatd2_ice_single,vqsatd2_single + use funcphys, only : fpvs, fpvsl, fpvsi +! use GEOS_UtilsMod, only:QSAT=>GEOS_Qsat, DQSAT=>GEOS_DQsat, +! & QSATLQ=>GEOS_QsatLQU, QSATIC=>GEOS_QsatICE +#ifdef GEOS5 + use MAPL_ConstantsMod, only: MAPL_TICE , MAPL_CP , MAPL_GRAV , + & MAPL_ALHS , MAPL_ALHL , MAPL_ALHF , MAPL_RGAS , MAPL_H2OMW, + & MAPL_AIRMW, MAPL_RVAP , MAPL_PI , MAPL_R8 , MAPL_R4 + use MAPL_BaseMod, only: MAPL_UNDEF +#endif +#ifdef NEMS_GSM + use physcons, MAPL_TICE => con_t0c, MAPL_GRAV => con_g, + & MAPL_CP => con_cp, MAPL_ALHL => con_hvap, + & MAPL_ALHF => con_hfus, MAPL_PI => con_pi, + & MAPL_RGAS => con_rd, MAPL_RVAP => con_rv +#endif + + + implicit none + + +! save + private + + PUBLIC MACRO_CLOUD + PUBLIC UPDATE_CLD + public meltfrz_inst + public fix_up_clouds_2M + PUBLIC CLOUD_PTR_STUBS + +!! Some parameters set by PHYSPARAMS + + integer :: NSMAX, DISABLE_RAD, ICEFRPWR, pdfflag + &, FR_LS_WAT, FR_LS_ICE, FR_AN_WAT, FR_AN_ICE + + real :: CNV_BETA + real :: ANV_BETA + real :: LS_BETA + real :: RH00 + real :: C_00 + real :: LWCRIT + real :: C_ACC + real :: C_EV_R + real :: C_EV_S + real :: CLDVOL2FRC + real :: RHSUP_ICE + real :: SHR_EVAP_FAC + real :: MIN_CLD_WATER + real :: CLD_EVP_EFF + real :: LS_SDQV2 + real :: LS_SDQV3 + real :: LS_SDQVT1 + real :: ANV_SDQV2 + real :: ANV_SDQV3 + real :: ANV_SDQVT1 + real :: ANV_TO_LS + real :: N_WARM + real :: N_ICE + real :: N_ANVIL + real :: N_PBL + real :: ANV_ICEFALL_C + real :: LS_ICEFALL_C + real :: REVAP_OFF_P + real :: CNVENVFC + real :: WRHODEP + real :: T_ICE_ALL + real :: CNVICEPARAM + real :: CNVDDRFC + real :: ANVDDRFC + real :: LSDDRFC + integer :: tanhrhcrit + real :: minrhcrit + real :: maxrhcrit + real :: turnrhcrit + real :: turnrhcrit_upper + real :: MIN_RI, MAX_RI, MIN_RL, MAX_RL, RI_ANV + real :: maxrhcritland + + + real, parameter :: T_ICE_MAX = MAPL_TICE + real, parameter :: RHO_W = 1.0e3 + real, parameter :: MIN_CLD_FRAC = 1.0e-8 + real, parameter :: MAPL_ALHS = MAPL_ALHL+MAPL_ALHF + + real, parameter :: alhlbcp = MAPL_ALHL/MAPL_CP + &, alhfbcp = MAPL_ALHF/MAPL_CP + &, alhsbcp = alhlbcp+alhfbcp + + + real, parameter :: PI_0 = 4.*atan(1.) + real omeps, trinv + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + contains + + + subroutine macro_cloud(IRUN, LM, DT, PP_dev, PPE_dev + &, EXNP_dev, FRLAND_dev, RMFDTR_dev + &, QLWDTR_dev, QRN_CU_dev, CNV_UPDFRC_dev + &, U_dev, V_dev, TH_dev, Q_dev + &, QLW_LS_dev, QLW_AN_dev, QIW_LS_dev + &, QIW_AN_dev, ANVFRC_dev, CLDFRC_dev + &, PRECU_dev, CUARF_dev, SNRCU_dev + &, PHYSPARAMS, SCLMFDFR, QST3_dev + &, DZET_dev, QDDF3_dev, RHX_dev + &, REV_CN_dev, RSU_CN_dev, ACLL_CN_dev + &, ACIL_CN_dev,PFL_CN_dev, PFI_CN_dev + &, PDFL_dev, PDFI_dev + &, ALPHT_dev, CFPDF_dev, DQRL_dev + &, VFALLSN_CN_dev + &, VFALLRN_CN_dev, CNV_FICE_dev + &, CNV_NDROP_dev, CNV_NICE_dev, SCICE_dev + &, NCPL_dev, NCPI_dev, PFRZ_dev + &, QRAIN_CN, QSNOW_CN + &, KCBL, lprnt, ipr ) + + integer, intent(in ) :: IRUN, LM + real, intent(in ) :: DT + real, intent(in ), dimension(IRUN, LM) :: PP_dev + real, intent(in ), dimension(IRUN,0:LM) :: PPE_dev + real, intent(in ), dimension(IRUN, LM) :: EXNP_dev + real, intent(in ), dimension(IRUN ) :: FRLAND_dev + real, intent(in ), dimension(IRUN, LM) :: RMFDTR_dev + real, intent(in ), dimension(IRUN, LM) :: QLWDTR_dev + real, intent(inout), dimension(IRUN, LM) :: QRN_CU_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_UPDFRC_dev + real, intent(in ), dimension(IRUN, LM) :: U_dev + real, intent(in ), dimension(IRUN, LM) :: V_dev + real, intent(inout), dimension(IRUN, LM) :: TH_dev + real, intent(inout), dimension(IRUN, LM) :: Q_dev + real, intent(inout), dimension(IRUN, LM) :: QLW_LS_dev + real, intent(inout), dimension(IRUN, LM) :: QLW_AN_dev + real, intent(inout), dimension(IRUN, LM) :: QIW_LS_dev + real, intent(inout), dimension(IRUN, LM) :: QIW_AN_dev + real, intent(inout), dimension(IRUN, LM) :: ANVFRC_dev + real, intent(inout), dimension(IRUN, LM) :: CLDFRC_dev + real, intent( out), dimension(IRUN ) :: PRECU_dev + real, intent( out), dimension(IRUN ) :: CUARF_dev + real, intent( out), dimension(IRUN ) :: SNRCU_dev + real, intent(in ), dimension(58 ) :: PHYSPARAMS + real, intent(in ) :: SCLMFDFR + real, intent(in ), dimension(IRUN, LM) :: QST3_dev + real, intent(in ), dimension(IRUN, LM) :: DZET_dev + real, intent(in ), dimension(IRUN, LM) :: QDDF3_dev + real, intent( out), dimension(IRUN, LM) :: RHX_dev + real, intent( out), dimension(IRUN, LM) :: REV_CN_dev + real, intent( out), dimension(IRUN, LM) :: RSU_CN_dev + real, intent( out), dimension(IRUN, LM) :: ACLL_CN_dev + real, intent( out), dimension(IRUN, LM) :: ACIL_CN_dev + real, intent( out), dimension(IRUN,0:LM) :: PFL_CN_dev + real, intent( out), dimension(IRUN,0:LM) :: PFI_CN_dev + real, intent( out), dimension(IRUN, LM) :: PDFL_dev + real, intent( out), dimension(IRUN, LM) :: PDFI_dev + real, intent( out), dimension(IRUN, LM) :: ALPHT_dev + real, intent( out), dimension(IRUN, LM) :: CFPDF_dev + real, intent( out), dimension(IRUN, LM) :: DQRL_dev + real, intent( out), dimension(IRUN, LM) :: VFALLSN_CN_dev + real, intent( out), dimension(IRUN, LM) :: VFALLRN_CN_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_FICE_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_NDROP_dev + real, intent(inout), dimension(IRUN, LM) :: CNV_NICE_dev + real, intent(inout), dimension(IRUN, LM) :: SCICE_dev + real, intent(inout), dimension(IRUN, LM) :: NCPL_dev + real, intent(inout), dimension(IRUN, LM) :: NCPI_dev + real, intent(out), dimension(IRUN, LM) :: PFRZ_dev + real, intent(out), dimension(IRUN, LM) :: QRAIN_CN + real, intent(out), dimension(IRUN, LM) :: QSNOW_CN + + real, dimension(IRUN, LM) :: FRZ_PP_dev + integer, intent(in), dimension(IRUN) :: KCBL + logical lprnt + integer ipr + + +! GPU The GPUs need to know how big local arrays are during compile-time +! as the GPUs cannot allocate memory themselves. This command resets +! this a priori size to LM for the CPU. + + + integer :: I , J , K , L + + integer :: FRACTION_REMOVAL + + real :: MASS, iMASS, TOTFRC, QRN_CU_1D, QSN_CU, QRN_ALL, QSN_ALL + &, QTMP1, QTMP2, QTMP3, QTOT, TEMP, RHCRIT, AA3, BB3, ALPHA + &, VFALL, VFALLRN, VFALLSN, TOT_PREC_UPD, AREA_UPD_PRC + &, AREA_UPD_PRC_tolayer, U_above,U_below, V_above,V_below + &, DZET_above,DZET_below, PRN_CU_above, PSN_CU_above + &, EVAP_DD_CU_above, SUBL_DD_CU_above + &, NIX, TOTAL_WATER, dti, tx1, tend, fqi + + logical :: use_autoconv_timescale +! + real, parameter :: RL_cub = 1.0e-15, RI_cub = 6.4e-14 +! + + omeps = 1. - epsqs + + dti = 1.0 /dt + trinv = 1.0/ttrice + CNV_BETA = PHYSPARAMS(1) + ANV_BETA = PHYSPARAMS(2) + LS_BETA = PHYSPARAMS(3) + RH00 = PHYSPARAMS(4) + C_00 = PHYSPARAMS(5) + LWCRIT = PHYSPARAMS(6) + C_ACC = PHYSPARAMS(7) + C_EV_R = PHYSPARAMS(8) + C_EV_S = PHYSPARAMS(56) + CLDVOL2FRC = PHYSPARAMS(9) + RHSUP_ICE = PHYSPARAMS(10) + SHR_EVAP_FAC = PHYSPARAMS(11) + MIN_CLD_WATER = PHYSPARAMS(12) + CLD_EVP_EFF = PHYSPARAMS(13) + NSMAX = INT( PHYSPARAMS(14) ) + LS_SDQV2 = PHYSPARAMS(15) + LS_SDQV3 = PHYSPARAMS(16) + LS_SDQVT1 = PHYSPARAMS(17) + ANV_SDQV2 = PHYSPARAMS(18) + ANV_SDQV3 = PHYSPARAMS(19) + ANV_SDQVT1 = PHYSPARAMS(20) + ANV_TO_LS = PHYSPARAMS(21) + N_WARM = PHYSPARAMS(22) + N_ICE = PHYSPARAMS(23) + N_ANVIL = PHYSPARAMS(24) + N_PBL = PHYSPARAMS(25) + DISABLE_RAD = INT( PHYSPARAMS(26) ) + ANV_ICEFALL_C = PHYSPARAMS(28) + LS_ICEFALL_C = PHYSPARAMS(29) + REVAP_OFF_P = PHYSPARAMS(30) + CNVENVFC = PHYSPARAMS(31) + WRHODEP = PHYSPARAMS(32) + T_ICE_ALL = PHYSPARAMS(33) + MAPL_TICE + CNVICEPARAM = PHYSPARAMS(34) + ICEFRPWR = INT( PHYSPARAMS(35) + .001 ) + CNVDDRFC = PHYSPARAMS(36) + ANVDDRFC = PHYSPARAMS(37) + LSDDRFC = PHYSPARAMS(38) + tanhrhcrit = INT( PHYSPARAMS(41) ) + minrhcrit = PHYSPARAMS(42) + maxrhcrit = PHYSPARAMS(43) + turnrhcrit = PHYSPARAMS(45) + maxrhcritland = PHYSPARAMS(46) + fr_ls_wat = INT( PHYSPARAMS(47) ) + fr_ls_ice = INT( PHYSPARAMS(48) ) + fr_an_wat = INT( PHYSPARAMS(49) ) + fr_an_ice = INT( PHYSPARAMS(50) ) + MIN_RL = PHYSPARAMS(51) + MIN_RI = PHYSPARAMS(52) + MAX_RL = PHYSPARAMS(53) + MAX_RI = PHYSPARAMS(54) + RI_ANV = PHYSPARAMS(55) + pdfflag = INT(PHYSPARAMS(57)) + + + turnrhcrit_upper = PHYSPARAMS(58) + + use_autoconv_timescale = .false. + + + RUN_LOOP: DO I = 1, IRUN +! Anning initialization here + PRN_CU_above = 0. + PSN_CU_above = 0. + EVAP_DD_CU_above = 0. + SUBL_DD_CU_above = 0. + + K_LOOP: DO K = 1, LM + + if (K == 1) then + TOT_PREC_UPD = 0. + AREA_UPD_PRC = 0. + end if + + if (K == LM ) then + PRECU_dev(I) = 0. + SNRCU_dev(I) = 0. + CUARF_dev(I) = 0. + end if + + + QRN_CU_1D = 0. + QSN_CU = 0. + VFALL = 0. + + PFL_CN_dev(I,K) = 0. + PFI_CN_dev(I,K) = 0. + + IF (K == 1) THEN + PFL_CN_dev(I,0) = 0. + PFI_CN_dev(I,0) = 0. + END IF + + + + RHX_dev(I,K) = 0.0 + REV_CN_dev(I,K) = 0.0 + RSU_CN_dev(I,K) = 0.0 + ACLL_CN_dev(I,K) = 0.0 + ACIL_CN_dev(I,K) = 0.0 + PDFL_dev(I,K) = 0.0 + PDFI_dev(I,K) = 0.0 + ALPHT_dev(I,K) = 0.0 + CFPDF_dev(I,K) = 0.0 + DQRL_dev(I,K) = 0.0 + VFALLSN_CN_dev(I,K) = 0.0 + VFALLRN_CN_dev(I,K) = 0.0 + VFALLSN = 0.0 + VFALLRN = 0.0 + + +! DNDCNV_dev(I, K) = 0.0 +! DNCCNV_dev(I, K) = 0.0 +! RAS_DT_dev(I, K) = 0.0 + + QRAIN_CN(I,K) = 0.0 + QSNOW_CN(I,K) = 0.0 + NIX = 0.0 + + + QRN_CU_1D = QRN_CU_dev(I,K) + + MASS = (PPE_dev(I,K) - PPE_dev(I,K-1)) + & * (100./MAPL_GRAV) + iMASS = 1.0 / MASS + TEMP = EXNP_dev(I,K) * TH_dev(I,K) + FRZ_PP_dev(I,K) = 0.00 + + +! NOT USED??? - Moorthi +! TOTAL_WATER = (QIW_AN_dev(I,K) + QLW_AN_dev(I,K) +! & + QIW_LS_dev(I,K) + QLW_LS_dev(I,K))*MASS +! & + QLWDTR_dev(I,K)*DT + + +! update of number concentration due to convective detrainment + + if (TEMP < T_ICE_ALL) then + fQi = 1.0 + elseif (TEMP > T_ICE_MAX) then + fQi = 0.0 + else + fQi = CNV_FICE_dev(I,K) + end if + tx1 = (1.0-fQi)*QLWDTR_dev(I,K) + if (tx1 > 0.0 .and. CNV_NDROP_dev(I,K) <= 0.0) then + CNV_NDROP_dev(I,K) = tx1 / ( 1.333 * MAPL_PI *RL_cub*997.0) + end if + + tx1 = fQi*QLWDTR_dev(I,K) + if (tx1 > 0.0 .and. CNV_NICE_dev(I,K) <= 0.0) then + CNV_NICE_dev(I,K) = tx1 / ( 1.333 * MAPL_PI *RI_cub*500.0) + end if + + tx1 = iMASS*DT + NCPL_dev(I,K) = max(NCPL_dev(I,K)+CNV_NDROP_dev(I,K)*tx1,0.0) + NCPI_dev(I,K) = max(NCPI_dev(I,K)+CNV_NICE_dev(I,K)*tx1,0.0) + + + TEND = RMFDTR_dev(I,K)*iMASS * SCLMFDFR + ANVFRC_dev(I,K) = min(ANVFRC_dev(I,K) + TEND*DT, 1.0) + +! + +! DCNVi_dev(I,K) = (QIW_AN_dev(I,K) - DCNVi_dev(I,K) ) * DTi +! DCNVL_dev(I,K) = (QLW_AN_dev(I,K) - DCNVL_dev(I,K) ) * DTi +! DNDCNV_dev(I,K) = (NCPL_dev(I,K) - DNDCNV_dev(I,K)) * DTi +! DNCCNV_dev(I,K) = (NCPI_dev(I,K) - DNCCNV_dev(I,K)) * DTi + + + if (k == 1 .or. k == lm) then + U_above = 0.0 + U_below = 0.0 + V_above = 0.0 + V_below = 0.0 + DZET_above = 0.0 + DZET_below = 0.0 + else + U_above = U_dev(i,k-1) + U_below = U_dev(i,k+1) + V_above = V_dev(i,k-1) + V_below = V_dev(i,k+1) + DZET_above = DZET_dev(i,k-1) + DZET_below = DZET_dev(i,k+1) + end if + + call pdf_spread (K, LM, U_dev(I,K), U_above, U_below, + & V_dev(I,K), V_above, V_below, + & DZET_above, DZET_below, CNV_UPDFRC_dev(I,K), + & PP_dev(I,K), ALPHA, ALPHT_dev(I,K), + & FRLAND_dev(I) ) + + + ALPHA = MAX( ALPHA , 1.0 - RH00 ) + + RHCRIT = 1.0 - ALPHA + +!================================ + + + call Pfreezing (ALPHA , PP_dev(I,K) , TEMP , Q_dev(I,K), + & QLW_LS_dev(I,K), QLW_AN_dev(I,K), + & QIW_LS_dev(I,K), QIW_AN_dev(I,K), + & SCICE_dev(I,K) , CLDFRC_dev(I,K), + & ANVFRC_dev(I,K), PFRZ_dev(I,K) ) + + +!=============Collect convective precip============== + +!*********************** begin of if(false)******************************** + if(.false.) then + QTMP1 = 0. + QTMP2 = 0. + QTMP3 = 0. + QRN_ALL = 0. + QSN_ALL = 0. + + if ( TEMP < MAPL_TICE ) then +! QTMP2 = QRN_CU_1D + QSN_CU = QRN_CU_1D + QRN_CU_1D = 0. + TEMP = TEMP + QSN_CU * ALHFbCP + end if + + AREA_UPD_PRC_tolayer = 0.0 + + + TOT_PREC_UPD = TOT_PREC_UPD + ((QRN_CU_1D + QSN_CU) * MASS) + AREA_UPD_PRC = AREA_UPD_PRC + (CNV_UPDFRC_dev(I,K)* + & (QRN_CU_1D + QSN_CU )* MASS) + + if ( TOT_PREC_UPD > 0.0 ) AREA_UPD_PRC_tolayer = + & MAX( AREA_UPD_PRC/TOT_PREC_UPD, 1.E-6 ) + + AREA_UPD_PRC_tolayer = CNV_BETA * AREA_UPD_PRC_tolayer + + IF (K == LM) THEN + if (TOT_PREC_UPD > 0.0) AREA_UPD_PRC = MAX( AREA_UPD_PRC/ + & TOT_PREC_UPD, 1.E-6 ) + AREA_UPD_PRC = CNV_BETA * AREA_UPD_PRC + CUARF_dev(I) = MIN( AREA_UPD_PRC, 1.0 ) + END IF + + + CALL MICRO_AA_BB_3 (TEMP,PP_dev(I,K),QST3_dev(I,K),AA3,BB3) + + + QTMP1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) + QTMP2 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) + QTOT = QTMP1 + QTMP2 + + call PRECIP3 (K, LM, DT, FRLAND_dev(I), RHCRIT, QRN_CU_1D, + & QSN_CU, QTMP1, QTMP2, TEMP, Q_dev(I,K), mass, + & imass, PP_dev(I,K), DZET_dev(I,K), + & QDDF3_dev(I,K), AA3,BB3,AREA_UPD_PRC_tolayer, + & PRECU_dev(I), SNRCU_dev(I), PRN_CU_above, + & PSN_CU_above, EVAP_DD_CU_above, + & SUBL_DD_CU_above, REV_CN_dev(I,K), + & RSU_CN_dev(I,K), ACLL_CN_dev(I,K), + & ACIL_CN_dev(I,K), PFL_CN_dev(I,K), + & PFI_CN_dev(I,K), VFALLRN, VFALLSN, + & FRZ_PP_dev(I,K), CNVENVFC, CNVDDRFC, + & ANVFRC_dev(I,k), CLDFRC_dev(I,k), + & PP_dev(I,KCBL(I)),i) + + VFALLSN_CN_dev(I,K) = VFALLSN + VFALLRN_CN_dev(I,K) = VFALLRN + + if (.not. use_autoconv_timescale) then + if (VFALLSN .NE. 0.) then + QSN_ALL = QSN_ALL + PFI_CN_dev(I,K)/VFALLSN + end if + if (VFALLRN .NE. 0.) then + QRN_ALL = QRN_ALL + PFL_CN_dev(I,K)/VFALLRN + end if + end if + +! if (.true.) then + + tx1 = QLW_LS_dev(I,K) + QLW_AN_dev(I,K) + IF (tx1 > 1.e-20 ) THEN + QTMP3 = 1.0 / tx1 + ELSE + QTMP3 = 0.0 + END IF + tx1 = QTMP1 * QTMP3 + QLW_LS_dev(I,K) = QLW_LS_dev(I,K) * tx1 + QLW_AN_dev(I,K) = QLW_AN_dev(I,K) * tx1 + NCPL_dev(I, K) = NCPL_dev(I,K) * tx1 + + tx1 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) + IF (tx1 > 1.0e-20 ) THEN + QTMP3 = 1.0 / tx1 + ELSE + QTMP3 = 0.0 + END IF + tx1 = QTMP2 * QTMP3 + QIW_LS_dev(I,K) = QIW_LS_dev(I,K) * tx1 + QIW_AN_dev(I,K) = QIW_AN_dev(I,K) * tx1 + NCPI_dev(I, K) = NCPI_dev(I,K) * tx1 + + + QTMP3 = QIW_LS_dev(I,K) + QIW_AN_dev(I,K) + & + QLW_LS_dev(I,K) + QLW_AN_dev(I,K) + + If (QTOT > 0.0) then + tx1 = QTMP3/QTOT + CLDFRC_dev(I,k) = CLDFRC_dev(I,k)*tx1 + ANVFRC_dev(I,k) = ANVFRC_dev(I,k)*tx1 + end if + +! end if + + + tx1 = (MAPL_RGAS*0.01) * temp / PP_dev(I,K) + + QRAIN_CN(I,K) = QRN_ALL * tx1 + QSNOW_CN(I,K) = QSN_ALL * tx1 + QRN_CU_dev(I,K) = QRN_CU_1D + + TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) + + IF ( TOTFRC > 1.00 ) THEN + tx1 = 1.0 / TOTFRC + CLDFRC_dev(I,k) = CLDFRC_dev(I,k) * tx1 + ANVFRC_dev(I,k) = ANVFRC_dev(I,k) * tx1 + END IF + + TOTFRC = CLDFRC_dev(I,K) + ANVFRC_dev(I,K) + + end if +!*********************** end of if(false)******************************** + + CALL fix_up_clouds_2M( Q_dev(I,K) , TEMP , QLW_LS_dev(I,K), + & QIW_LS_dev(I,K), CLDFRC_dev(I,K), QLW_AN_dev(I,K), + & QIW_AN_dev(I,K), ANVFRC_dev(I,K), NCPL_dev(I, K), + & NCPI_dev(I, K)) + + + TH_dev(I,K) = TEMP / EXNP_dev(I,K) + + end do K_LOOP + + + end do RUN_LOOP + + END SUBROUTINE MACRO_CLOUD + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! P R O C E S S S U B R O U T I N E S !! +!! * * * * * !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! P R O C E S S S U B R O U T I N E S !! +!! * * * * * !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!! !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! P R O C E S S S U B R O U T I N E S !! +!! * * * * * !! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine pdf_spread (K,LM, U,U_above,U_below, V,V_above, + & V_below, DZ_above,DZ_below, UPDF, + & PP,ALPHA, ALPHT_DIAG, FRLAND ) + + integer, intent(in) :: k,lm + real, intent(in) :: U, U_above, U_below, V, V_above, V_below + &, DZ_above, DZ_below, UPDF, PP, FRLAND + + real, intent(out) :: ALPHA, ALPHT_DIAG + + real :: tempmaxrh, slope, slope_up, turnrhcrit_up + &, aux1, aux2, maxalpha, A1,A2,A3 + + slope = 20.0 + slope_up = 20.0 + + turnrhcrit_up = turnrhcrit_upper + + maxalpha = 1.0 - minrhcrit + + aux1 = min(max((pp- turnrhcrit)/slope, -20.0), 20.0) + aux2 = min(max((turnrhcrit_up - pp)/slope_up, -20.0), 20.0) + + if (frland > 0.05) then + aux1 = 1.0 + else + aux1 = 1.0 / (1.0+exp(aux1)) + end if + + aux2 = 1.0 / (1.0+exp(aux2)) + + + alpha = maxalpha*aux1*aux2*2 !Anning + + ALPHA = MIN( ALPHA , 0.4 ) + ALPHT_DIAG = ALPHA + + end subroutine pdf_spread + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine fix_up_clouds_2M( QV, TE, QLC, QIC, CF, QLA, QIA, AF, + & NL, NI ) + + real, intent(inout) :: TE,QV,QLC,CF,QLA,AF,QIC,QIA, NL, NI + + real, parameter :: qmin = 1.0e-11, cfmin = 1.0e-4 + &, nmin = 1.0e-3, RL_cub = 1.0e-15 + &, RI_cub = 6.4e-14 + +! if(.false.) then +! if (AF < cfmin) then +! QV = QV + QLA + QIA +! TE = TE - ALHLbCP*QLA - ALHSbCP*QIA +! AF = 0. +! QLA = 0. +! QIA = 0. + + +! if ( CF < cfmin) then +! QV = QV + QLC + QIC +! TE = TE - ALHLbCP*QLC - ALHSbCP*QIC +! CF = 0. +! QLC = 0. +! QIC = 0. +! end if +! end if +! end if + +! Anning make some changes here +! if (AFqmin) AF=cfmin +! if(CFqmin) CF=cfmin + + + if (QLC < qmin .and. QLC > 0.) then + QV = QV + QLC + TE = TE - ALHLbCP*QLC + QLC = 0. + end if + + if (QIC < qmin .and. QIC > 0.) then + QV = QV + QIC + TE = TE - ALHSbCP*QIC + QIC = 0. + end if + + + if (QLA < qmin .and. QLA > 0.) then + QV = QV + QLA + TE = TE - ALHLbCP*QLA + QLA = 0. + end if + + if (QIA < qmin .and. QIA > 0.) then + QV = QV + QIA + TE = TE - ALHSbCP*QIA + QIA = 0. + end if + + + if (QLA+QIA < qmin .and. QLA+QIA > 0.) then + QV = QV + QLA + QIA + TE = TE - ALHLbCP*QLA - ALHSbCP*QIA + AF = 0. + QLA = 0. + QIA = 0. + end if + + if (QLC+QIC < qmin .and. QLC+QIC > 0. ) then + QV = QV + QLC + QIC + TE = TE - ALHLbCP*QLC - ALHSbCP*QIC + CF = 0. + QLC = 0. + QIC = 0. + end if + + if ((QLA+QLC) <= qmin) then + NL = 0.0 + end if + + if ((QIA+QIC) <= qmin) then + NI = 0.0 + end if + +! make sure N > 0 if Q >0 + if (QLA+QLC > qmin .and. NL <= nmin) then + NL = max((QLA+QLC)/( 1.333 * MAPL_PI *RL_cub*997.0), nmin) + end if + + if (QIA+QIC > qmin .and. NI <= nmin) then + NI = max((QIA+QIC)/( 1.333 * MAPL_PI *RI_cub*500.0), nmin) + end if + + + end subroutine fix_up_clouds_2M + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine update_cld( irun, lm, DT, ALPHA, + & PDFSHAPE, PL, QV, QCl, + & QAl, QCi, QAi, TE, CF, AF, + & SCICE, NI, NL, NCnuc, RHcmicro) + + integer, intent(in) :: irun, lm, pdfshape + real, intent(in) :: DT + real, intent(in), dimension(irun,lm) :: ALPHA,PL, NCnuc + real, intent(inout), dimension(irun,lm) :: te, qv, qcl, qci + &, CF,QAl,QAi,AF, NI, RHCmicro, NL, SCICE + + real :: CFO,pl100 + real :: QT, DQ + + real :: QSx,DQsx + + real :: QCx, QC, QA + + real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA + + real :: esl, esi, esn !temp use only Anning + + integer :: i,k + + + pdfflag = PDFSHAPE + do k=1,lm + do i=1,irun + if(QV(i,k) > 1.e-6) then + pl100=pl(i,k)*100 + QC = QCl(i,k) + QCi(i,k) + QA = QAl(i,k) + QAi(i,k) + !Anning do not let empty cloud exist + if(QC.le.0.) CF(i,k)=0. + if(QA.le.0.) AF(i,k)=0. + QT = QC + QA + QV(i,k) + CFALL = AF(i,k) + CF(i,k) + + if (QA+QC > 0.0) then + FQA = QA / (QA+QC) + else + FQA = 0.0 + end if +!================================================ +! First find the cloud fraction that would correspond to the current +! condensate +! QSLIQ = QSATLQ( TE , PL*100.0 , DQ=DQx ) +! QSICE = QSATIC( TE , PL*100.0 , DQ=DQx ) +! call vqsatd2_water_single(TE(i,k),PL(i,k)*100.0, +! & esl,QSLIQ,DQx) +! call vqsatd2_ice_single(TE(i,k),PL(i,k)*100.0, +! & esi,QSICE,DQx) + esl=min(fpvsl(TE(i,k)),pl100) + QSLIQ= min(epsqs*esl/(pl100-omeps*esl),1.) + esi=min(fpvsi(TE(i,k)),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + + if ((QC+QA) > 0.0) then + QSx = ( (QCl(i,k)+QAl(i,k))*QSLIQ + & + (QCi(i,k)+QAi(i,k))*QSICE ) / (QC+QA) + else +! DQSx = DQSAT( TEo , PL , 35.0, QSAT=QSx ) +! call vqsatd2_single( TE(i,k), pl(i,k)*100., esl,QSx,DQSx) + esn=min(fpvs(TE(i,k)),pl100) + QSx= min(epsqs*esn/(pl100-omeps*esn),1.) + + end if + + if (TE(i,k) > T_ICE_ALL) SCICE(i,k) = 1.0 + QCx = QC + QA + QX = QT - QSx*SCICE(i,k) + CFo = 0. +! recalculate QX if too low and SCICE 0.0)) then + CFo = (1.0+SQRT(1.0-(QX/QCx))) + if (CFo > 1.e-6) then + CFo = min(1.0/CFo, 1.0) + DQ = 2.0*QCx/(CFo*CFo) + else + CFo = 0.0 + end if + else + if (QCx > 0.0) then + CFo = 1.0 + end if + DQ = 2.0*ALPHA(i,k)*QSx + end if + + if (QSx > 0.0) then + RHCmicro(i,k) = SCICE(i,k) - 0.5*DQ/Qsx + else + RHCmicro(i,k) = 0.0 + end if + + CFALL = max(CFo, 0.0) + CFALL = min(CFo, 1.0) + + CF(i,k) = CFALL*(1.0-FQA) + AF(i,k) = CFALL*FQA + + +! if ((TE(i,k) <= T_ICE_ALL)) cycle + + + call hystpdf( DT, ALPHA(i,k), PDFSHAPE, PL(i,k), QV(i,k) + &, QCl(i,k), QAl(i,k), QCi(i,k) + &, QAi(i,k), TE(i,k), CF(i,k), AF(i,k) + &, SCICE(i,k), NI(i,k), NL(i,k), i, k ) + + !Anning do not let empty cloud exist + if(QCl(i,k)+QCi(i,k).le.0.) CF(i,k)=0. + if(QAl(i,k)+QAi(i,k).le.0.) AF(i,k)=0. + end if + enddo + enddo + + + end subroutine update_cld + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine hystpdf( DT, ALPHA, PDFSHAPE, PL, QV, QCl, QAl, + & QCi, QAi, TE, CF, AF, SCICE, NI, NL, i, k) + + real, intent(in) :: DT,ALPHA,PL + integer, intent(in) :: pdfshape + real, intent(inout) :: TE,QV,QCl,QCi,CF,QAl,QAi,AF, NI, NL, + & SCICE + + + real :: QCO, QVO, CFO, QAO, TAU, SCICE_x + real :: QT, QMX, QMN, DQ, QVtop, sigmaqt1, sigmaqt2, qsnx + + real :: TEO,QSx,DQsx,QS,DQs + + real :: TEp, QSp, CFp, QVp, QCp + real :: TEn, QSn, CFn, QVn, QCn + + real :: QCx, QVx, CFx, QAx, QC, QA, fQi, fQi_A + real :: dQAi, dQAl, dQCi, dQCl + + real :: QX, QSLIQ, QSICE, CFALL, DQx, FQA, DQSI, DQSL, LHcorr, + & fQip,pl100 + + real :: tmpARR + real :: esn,desdt,weight,tc,hlatsb,hlatvp,hltalt,tterm,gam + logical lflg + real :: ALHX, DQCALL + + + integer :: N, nmax,i,k + + + pdfflag = PDFSHAPE + pl100=pl*100 + + QC = QCl + QCi + QA = QAl + QAi + QT = QC + QA + QV + CFALL = AF+CF + FQA = 0.0 + fQi = 0.0 + tmpARR = 0.0 + nmax = 20 + QAx = 0.0 + + if (QA+QC > 0.0) FQA = QA / (QA+QC) + if (QA > 0.0) fQi_A = QAi / QA + if (QT > 0.0) fQi = (QCI+QAI) / QT + if (TE < T_ICE_ALL) fQi = 1.0 + if ( AF < 1.0 ) tmpARR = 1. / (1.-AF) + + TEo = TE + + fQi = ice_fraction( TEn ) +! DQS = DQSAT( TE, PL, QSAT=QSx ) Anning changed to the foollowing +! DQSx = DQSAT( TE, PL, QSAT=QSx ) +! call vqsatd2_single( TE, pl*100., esn,QSx,DQSx) + esn=min(fpvs(TE),pl100) + QSx= min(epsqs*esn/(pl100-omeps*esn),1.) + tc = TE - MAPL_TICE + lflg = (tc >= -ttrice .and. tc < 0.) + weight = min(-tc*trinv,1.0) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0*tc + if (TE < MAPL_TICE) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + & +tc*(pcf(4) + tc*pcf(5)))) + else + tterm = 0. + end if + desdt = hltalt*esn/(rgasv*TE*TE) + tterm*trinv + gam = hltalt*qsx*pl100*desdt/(MAPL_cp*esn*(pl100-omeps*esn)) + if (qsx == 1.0) gam = 0.0 + DQSx=(MAPL_cp/hltalt)*gam + + CFx = CF*tmpARR + QCx = QC*tmpARR + QVx = ( QV - QSx*AF )*tmpARR + +! if ( AF >= 1.0 ) QVx = QSx*1.e-4 + if ( AF > 0. ) QAx = QA/AF + + QT = QCx + QVx + + TEp = TEo + QSn = QSx + TEn = TEo + CFn = CFx + QVn = QVx + QCn = QCx + DQS = DQSx + + + do n=1,nmax + + QVp = QVn + QCp = QCn + CFp = CFn + TEp = TEn + fQip= fQi + + if(pdfflag < 2) then + sigmaqt1 = ALPHA*QSn + sigmaqt2 = ALPHA*QSn + elseif(pdfflag == 2) then + sigmaqt1 = ALPHA*QSn + sigmaqt2 = ALPHA*QSn + elseif(pdfflag == 4) then + sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + endif + + qsnx = qsn*SCICE + if ((QCI >= 0.0) .and. (qsn > qt)) qsnx = qsn + + call pdffrac(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,CFn) + call pdfcondensate(PDFSHAPE,qt,sigmaqt1,sigmaqt2,qsnx,QCn, CFn) + + DQCALL = QCn - QCp + CF = CFn * ( 1.-AF) + +! call Bergeron_iter (DT, PL, TEp, QT, QCi, QAi, QCl, QAl, +! & CF, AF, NL, NI, DQCALL, fQi) + + if ( AF > 0. ) then + QAo = QAx + else + QAo = 0. + end if + + + ALHX = (1.0-fQi)*alhlbcp + fQi*alhsbcp + + if(pdfflag == 1) then + QCn = QCp + (QCn- QCp) + & / (1. - (CFn*(ALPHA-1.) - QCn/QSn) *DQS*ALHX) + elseif(pdfflag == 2) then + if (n.ne.nmax) QCn = QCp + ( QCn - QCp ) *0.5 + endif + + QVn = QVp - (QCn - QCp) + TEn = TEp + ((1.0-fQi)*alhlbcp + fQi*alhsbcp) + & *((QCn - QCp)*(1.-AF) + (QAo-QAx)*AF) + + if (abs(Ten - Tep) < 0.00001) exit + +! DQS = DQSAT( TEn, PL, QSAT=QSn ) +! call vqsatd2_single( TEn, pl*100., esn,QSn,DQS) + esn=min(fpvs(TEn),pl100) + QSn= min(epsqs*esn/(pl100-omeps*esn),1.) + tc = TEn - MAPL_TICE + lflg = (tc >= -ttrice .and. tc < 0.) + weight = min(-tc*trinv,1.0) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0*tc + if (TEn < MAPL_TICE) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + & +tc*(pcf(4) + tc*pcf(5)))) + else + tterm = 0. + end if + desdt = hltalt*esn/(rgasv*TEn*TEn) + tterm*trinv + gam = hltalt*QSn*pl100*desdt/(MAPL_cp*esn*(pl100-omeps*esn)) + if (qsx == 1.0) gam = 0.0 + DQS=(MAPL_cp/hltalt)*gam + + enddo + + CFo = CFn + CF = CFn + QCo = QCn + QVo = QVn + TEo = TEn + + if ( AF < 1.0 ) then + CF = CFo * ( 1.-AF) + QCo = QCo * ( 1.-AF) + QAo = QAo * AF + else + CF = 0. + QAo = QA + QC + QCo = 0. + QT = QAo + QV + QAo = MAX( QT - QSx, 0. ) + end if + + dQCl = 0.0 + dQCi = 0.0 + dQAl = 0.0 + dQAi = 0.0 + +!large scale QCx is not in envi + + QCx = QCo - QC +! Anning Cheng prevented unstable here + if (QCx < -1.e-3) QCx = -1.e-3 + if (QCx < 0.0) then + dQCl = max(QCx, -QCl) + dQCi = max(QCx - dQCl, -QCi) + else + dQCl = (1.0-fQi)*QCx + dQCi = fQi * QCx + end if + +!Anvil QAx is not in anvil + QAx = QAo - QA +! Anning Cheng prevented unstable here + if(QAx < -1.e-3) QAx = -1.e-3 + + if (QAx < 0.0) then + dQAl = max(QAx, -QAl) + dQAi = max(QAx - dQAl, -QAi) + else + dQAl = (1.0-fQi)*QAx + dQAi = QAx*fQi + end if + +! if(.false.) then !Anning turn it off causing unstable +! if ( AF < 1.e-5 ) then +! dQAi = -QAi +! dQAl = -QAl +! end if +! if ( CF < 1.e-5 ) then +! dQCi = -QCi +! dQCl = -QCl +! end if +! end if + + QAi = QAi + dQAi + QAl = QAl + dQAl + QCi = QCi + dQCi + QCl = QCl + dQCl + QV = QV - ( dQAi+dQCi+dQAl+dQCl) + + + TE = TE + (alhlbcp * (dQAi+dQCi+dQAl+dQCl) + & + alhfbcp * (dQAi+dQCi)) + + + + if ( QAo <= 0. ) then + QV = QV + QAi + QAl + TE = TE - alhsbcp*QAi - alhlbcp*QAl + QAi = 0. + QAl = 0. + AF = 0. + end if + + CALL fix_up_clouds_2M(QV, TE, QCl, QCi, CF, QAl, QAi, AF, NL, NI) + + end subroutine hystpdf + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine pdffrac (flag,qtmean,sigmaqt1,sigmaqt2,qstar,clfrac) + implicit none + + integer flag + + real qtmean + real sigmaqt1 + real sigmaqt2 + real qstar + real clfrac + + real :: qtmode, qtmin, qtmax + + + real :: qtmedian, aux + + if(flag.eq.1) then + if((qtmean+sigmaqt1).lt.qstar) then + clfrac = 0. + else + if(sigmaqt1.gt.0.) then + clfrac = min((qtmean + sigmaqt1 - qstar),2.*sigmaqt1) + & /(2.*sigmaqt1) + else + clfrac = 1. + endif + endif + elseif(flag.eq.2) then + qtmode = qtmean + (sigmaqt1-sigmaqt2)/3. + qtmin = min(qtmode-sigmaqt1,0.) + qtmax = qtmode + sigmaqt2 + if(qtmax.lt.qstar) then + clfrac = 0. + elseif ( (qtmode.le.qstar).and.(qstar.lt.qtmax) ) then + clfrac = (qtmax-qstar)*(qtmax-qstar) / + & ((qtmax-qtmin)*(qtmax-qtmode)) + elseif ( (qtmin.le.qstar).and.(qstar.lt.qtmode) ) then + clfrac = 1. - ((qstar-qtmin)*(qstar-qtmin) + & /( (qtmax-qtmin)*(qtmode-qtmin))) + elseif ( qstar.le.qtmin ) then + clfrac = 1. + endif + elseif(flag.eq.4) then + if (qtmean .gt. 1.0e-20) then + qtmedian = qtmean*exp(-0.5*sigmaqt1*sigmaqt1) + aux = log(qtmedian/qstar)/sqrt(2.0)/sigmaqt1 + aux=min(max(aux, -20.0), 20.0) + clfrac=0.5*(1.0+erf_app(aux)) + else + clfrac = 0.0 + end if + endif + + return + end subroutine pdffrac + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine pdfcondensate (flag,qtmean4,sigmaqt14,sigmaqt24, + & qstar4,condensate4, clfrac4) + implicit none + + integer flag + + real qtmean4, sigmaqt14, sigmaqt24, qstar4, condensate4, clfrac4 + + real *8 :: qtmode, qtmin, qtmax, constA, constB, cloudf + &, term1, term2, term3 + &, qtmean, sigmaqt1, sigmaqt2, qstar, condensate + &, qtmedian, aux, clfrac, tx1 + + qtmean = dble(qtmean4) + sigmaqt1 = dble(sigmaqt14) + sigmaqt2 = dble(sigmaqt24) + qstar = dble(qstar4) + clfrac = dble(clfrac4) + + if(flag == 1) then + if(qtmean+sigmaqt1 < qstar) then + condensate = 0.d0 + elseif(qstar > qtmean-sigmaqt1) then + if(sigmaqt1 > 0.d0) then + tx1 = min(qtmean+sigmaqt1-qstar, 2.d0*sigmaqt1) + condensate = tx1*tx1 / (4.d0*sigmaqt1) + else + condensate = qtmean - qstar + endif + else + condensate = qtmean - qstar + endif + elseif(flag == 2) then + qtmode = qtmean + (sigmaqt1-sigmaqt2)/3.d0 + qtmin = min(qtmode-sigmaqt1,0.d0) + qtmax = qtmode + sigmaqt2 + if ( qtmax < qstar ) then + condensate = 0.d0 + elseif ( qtmode <= qstar .and. qstar < qtmax ) then + constB = 2.d0 / ( (qtmax - qtmin)*(qtmax-qtmode) ) + cloudf = (qtmax-qstar)*(qtmax-qstar) * 0.5d0 * constB + term1 = (qstar*qstar*qstar)/3.d0 + term2 = (qtmax*qstar*qstar)/2.d0 + term3 = (qtmax*qtmax*qtmax)/6.d0 + condensate = constB * (term1-term2+term3) - qstar*cloudf + elseif ( qtmin <= qstar .and. qstar < qtmode ) then + constA = 2.d0 / ((qtmax-qtmin)*(qtmode-qtmin)) + cloudf = 1.d0 - (qstar-qtmin)*(qstar-qtmin)*0.5d0*constA + term1 = qstar*qstar*qstar/3.d0 + term2 = qtmin*qstar*qstar/2.d0 + term3 = qtmin*qtmin*qtmin/6.d0 + condensate = qtmean - (constA*(term1-term2+term3)) + & - qstar*cloudf + elseif ( qstar <= qtmin ) then + condensate = qtmean - qstar + endif + + elseif(flag == 4) then + + if (qtmean > 1.0e-20) then + aux = 0.5*sigmaqt1*sigmaqt1 + qtmedian = qtmean*exp(-aux) + aux = (aux + log(qtmedian/qstar))/(sqrt(2.0)*sigmaqt1) + aux = min(max(aux, -20.0), 20.0) + aux = 1.0 + dble(erf_app(sngl(aux))) + condensate = (0.5*qtmean*aux/qstar - clfrac) * qstar + condensate= min(condensate, qtmean) + else + condensate = 0.0 + end if + + endif + condensate4 = real(condensate) + + return + end subroutine pdfcondensate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine cnvsrc( DT, ICEPARAM, SCLMFDFR, MASS, iMASS, PL, + & TE, QV, DCF, DMF, QLA, QIA, CF, AF, QS, + & NL, NI, CNVFICE, CNVNDROP, CNVNICE) + + real, intent(in) :: DT, ICEPARAM, SCLMFDFR, MASS, iMASS, QS + &, DMF,PL, DCF, CF + real, intent(inout) :: TE, AF,QV, QLA, QIA, NI, NL + &, CNVFICE, CNVNDROP, CNVNICE + + real :: TEND,QVx,QCA,fQi + + integer, parameter :: STRATEGY = 3 + real, parameter :: RL_cub = 1.0e-15, RI_cub = 6.4e-14 + &, minrhx = 0.001 + + fQi = 0.0 + + if (TE < T_ICE_ALL) then + fQi = 1.0 + elseif (TE > T_ICE_MAX) then + fQi = 0.0 + else + fQi = CNVFICE + end if + + +! TEND = DCF*iMASS + +! QLA = QLA + (1.0-fQi)* TEND*DT +! QIA = QIA + fQi * TEND*DT + + + if ( ( (1.0-fQi)*DCF > 0.0) .and. (CNVNDROP <= 0.0)) then + CNVNDROP = (1.0-fQi)*DCF/( 1.333 * MAPL_PI *RL_cub*997.0) + end if + + if ((fQi*DCF > 0.0) .and. (CNVNICE <= 0.0)) then + CNVNICE = fQi*DCF/( 1.333 * MAPL_PI *RI_cub*500.0) + end if + + NL = max(NL + CNVNDROP*iMASS*DT, 0.0) + NI = max(NI + CNVNICE*iMASS*DT, 0.0) + +! TE = TE + (alhsbcp-alhlbcp) * fQi * TEND * DT + +! QCA = QLA + QIA + + TEND = DMF*iMASS * SCLMFDFR + AF = min(AF + TEND*DT, 1.0) + + if ( AF < 1.0 ) then + QVx = ( QV - QS * AF )/(1.-AF) + else + QVx = QS + end if + +! if (STRATEGY == 1) then +! if ( (( QVx - minrhx*QS ) < 0.0 ) .and. (AF > 0.) ) then +! AF = (QV - minrhx*QS )/( QS*(1.0-minrhx) ) +! end if +! if ( AF < 0. ) then +! AF = 0. +! QV = QV + QLA + QIA +! TE = TE - (alhlbcp*QLA + alhsbcp*QIA) +! QLA = 0. +! QIA = 0. +! end if +! else if (STRATEGY == 2) then +! if ( (( QVx - minrhx*QS ) < 0.0 ) .and. (AF > 0.) ) then +! QV = QV + (1.-AF)*( minrhx*QS - QVx ) +! QCA = QCA - (1.-AF)*( minrhx*QS - QVx ) +! TE = TE - (1.-AF)*( minrhx*QS - QVx )* alhlbcp +! end if +! end if + + end subroutine cnvsrc + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + subroutine PRECIP3( K,LM , DT , FRLAND , RHCR3 , QPl , QPi , + & QCl , QCi , TE , QV , mass , imass , PL , dZE , QDDF3 , AA , BB , + & AREA , RAIN , SNOW , PFl_above , PFi_above , EVAP_DD_above, + & SUBL_DD_above, REVAP_DIAG , RSUBL_DIAG , ACRLL_DIAG , + & ACRIL_DIAG , PFL_DIAG , PFI_DIAG , VFALLRN , VFALLSN , FRZ_DIAG , + & ENVFC,DDRFC, AF, CF, PCBL,i ) + + + integer, intent(in) :: K,LM,i + + real, intent(in ) :: DT + + real, intent(inout) :: QV,QPl,QPi,QCl,QCi,TE + + real, intent(in ) :: mass,imass + real, intent(in ) :: PL + real, intent(in ) :: AA,BB + real, intent(in ) :: RHCR3 + real, intent(in ) :: dZE + real, intent(in ) :: QDDF3 + real, intent( out) :: RAIN,SNOW + real, intent(in ) :: AREA + real, intent(in ) :: FRLAND + + real, intent(inout) :: PFl_above, PFi_above + real, intent(inout) :: EVAP_DD_above, SUBL_DD_above + + real, intent( out) :: REVAP_DIAG + real, intent( out) :: RSUBL_DIAG + real, intent( out) :: ACRLL_DIAG,ACRIL_DIAG + real, intent( out) :: PFL_DIAG, PFI_DIAG + real, intent(inout) :: FRZ_DIAG + real, intent( out) :: VFALLSN, VFALLRN + + real, intent(in ) :: ENVFC,DDRFC + + real, intent(in ) :: AF,CF, PCBL + + + real :: PFi,PFl,QS,dQS,ENVFRAC + real,save :: TKo,QKo,QSTKo,DQSTKo,RH_BOX,T_ED,QPlKo,QPiKo + real :: Ifactor,RAINRAT0,SNOWRAT0 + real :: FALLRN,FALLSN,VEsn,VErn,NRAIN,NSNOW,Efactor + + real :: TinLAYERrn,DIAMrn,DROPRAD + real :: TinLAYERsn,DIAMsn,FLAKRAD,pl100 + + real :: EVAP,SUBL,ACCR,MLTFRZ,EVAPx,SUBLx + real :: EVAP_DD,SUBL_DD,DDFRACT + real :: LANDSEAF + + real :: tmpARR, CFR, aux + + real, parameter :: TRMV_L = 1.0 + + real :: TAU_FRZ, TAU_MLT, QSICE, DQSI + + integer :: NS, NSMX, itr,L + + logical, parameter :: taneff = .true. + + real, parameter :: B_SUB = 1.00 + real esl,esi, esn,desdt,weight,tc,hlatsb,hlatvp,hltalt,tterm, + & gam + logical lflg + + + pl100=pl*100 + if(taneff) then + aux = min(max((pl- PCBL)/10.0, -20.0), 20.0) + aux = 1.0/(1.0+exp(-aux)) + envfrac = ENVFC + (1.0-ENVFC)*aux + envfrac = min(envfrac,1.) + else + ENVFRAC = ENVFC + endif + + CFR= AF+CF + if ( CFR < 0.99) then + tmpARR = 1./(1.-CFR) + else + tmpARR = 0.0 + end if + + + IF ( AREA > 0. ) THEN + Ifactor = 1./ ( AREA ) + ELSE + Ifactor = 1.00 + END if + + Ifactor = MAX( Ifactor, 1.) + + PFL_DIAG = 0. + PFI_DIAG = 0. + ACRIL_DIAG = 0. + ACRLL_DIAG = 0. + REVAP_DIAG = 0. + RSUBL_DIAG = 0. + + +! dQS = DQSAT( TE, PL, QSAT = QS ) +! call vqsatd2_single( TE, pl*100., esl,QS,DQS) + esn=min(fpvs(TE),pl100) + QS= min(epsqs*esn/(pl100-omeps*esn),1.) +! TKO is not defined yet here Anning Cheng + TKO = TE +! QSICE = QSATIC( min(TKo, T_ICE_MAX), PL*100.0 , DQ=DQSI ) +! call vqsatd2_ice_single(min(TKo, T_ICE_MAX),PL*100.0, +! & esl,QSICE,DQSI) + esi=min(fpvsi(TKo),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + hltalt = hlatv + hlatf + desdt = hltalt*esi/(rgasv*TKo*TKo) + if (QSICE < 1.0) then + gam = hltalt*QSICE*pl100*desdt/(MAPL_CP*esi + & * (pl100 - omeps*esi)) + else + gam = 0.0 + endif + DQSI = (MAPL_CP/hltalt)*gam + + + DDFRACT = DDRFC + + IF (K == 1) THEN + PFl = QPl*MASS + PFi = QPi*MASS + + EVAP_DD = 0. + SUBL_DD = 0. + + VFALLRN = 0.0 + VFALLSN = 0.0 + ELSE + QPl = QPl + PFl_above * iMASS + PFl = 0.00 + QPi = QPi + PFi_above * iMASS + PFi = 0.00 + + + ACCR = B_SUB * C_ACC * ( QPl*MASS ) *QCl + + ACCR = MIN( ACCR , QCl ) + + QPl = QPl + ACCR + QCl = QCl - ACCR + + ACRLL_DIAG = ACCR / DT + + + ACCR = B_SUB * C_ACC * ( QPi*MASS ) *QCl + + ACCR = MIN( ACCR , QCl ) + + QPi = QPi + ACCR + QCl = QCl - ACCR + + TE = TE + alhfbcp*ACCR + + ACRIL_DIAG = ACCR / DT + + RAINRAT0 = Ifactor*QPl*MASS/DT + SNOWRAT0 = Ifactor*QPi*MASS/DT + + call MARSHPALMQ2(RAINRAT0,PL,DIAMrn,NRAIN,FALLrn,VErn) + call MARSHPALMQ2(SNOWRAT0,PL,DIAMsn,NSNOW,FALLsn,VEsn) + + IF ( FRLAND < 0.1 ) THEN + + END IF + + VFALLRN = FALLrn + VFALLSN = FALLsn + + TinLAYERrn = dZE / ( max(FALLrn,0.)+0.01 ) + TinLAYERsn = dZE / ( max(FALLsn,0.)+0.01 ) + + TAU_FRZ = 5000. + + MLTFRZ = 0.0 + IF ( (TE > MAPL_TICE ) .and. (TE <= MAPL_TICE+5. ) ) THEN + MLTFRZ = TinLAYERsn * QPi *( TE - MAPL_TICE ) / TAU_FRZ + MLTFRZ = MIN( QPi , MLTFRZ ) + TE = TE - alhfbcp*MLTFRZ + QPl = QPl + MLTFRZ + QPi = QPi - MLTFRZ + END IF + FRZ_DIAG = FRZ_DIAG - MLTFRZ / DT + + MLTFRZ = 0.0 + IF ( TE > MAPL_TICE+5. ) THEN + MLTFRZ = QPi + TE = TE - alhfbcp*MLTFRZ + QPl = QPl + MLTFRZ + QPi = QPi - MLTFRZ + END IF + FRZ_DIAG = FRZ_DIAG - MLTFRZ / DT + + MLTFRZ = 0.0 + if ( K >= LM-1 ) THEN + IF ( TE > MAPL_TICE+0. ) THEN + MLTFRZ = QPi + TE = TE - alhfbcp*MLTFRZ + QPl = QPl + MLTFRZ + QPi = QPi - MLTFRZ + END IF + endif + FRZ_DIAG = FRZ_DIAG - MLTFRZ / DT + + + MLTFRZ = 0.0 + IF ( TE <= MAPL_TICE ) THEN + TE = TE + alhfbcp*QPl + QPi = QPl + QPi + MLTFRZ = QPl + QPl = 0. + END IF + FRZ_DIAG = FRZ_DIAG + MLTFRZ / DT + + + QKo = QV + TKo = TE + QPlKo = QPl + QPiKo = QPi + + do itr = 1,3 + +! DQSTKo = DQSAT ( TKo , PL,QSAT=QSTko ) +! call vqsatd2_single(TKo, pl*100., esl,QSTko,DQSTKo) + esn=min(fpvs(TKo),pl100) + QSTko= min(epsqs*esn/(pl100-omeps*esn),1.) + tc = TKo - MAPL_TICE + lflg = (tc >= -ttrice .and. tc < 0.) + weight = min(-tc*trinv,1.0) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0*tc + if (TKo < MAPL_TICE) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + & +tc*(pcf(4) + tc*pcf(5)))) + else + tterm = 0. + end if + desdt = hltalt*esn/(rgasv*TKo*TKo) + tterm*trinv + DQSTKo=(epsqs + omeps*QSTko)/(pl100 - omeps*esn)*desdt + +! QSICE = QSATIC( min(TKo, T_ICE_MAX), PL*100.0 , DQ=DQSI ) +! call vqsatd2_ice_single(min(TKo, T_ICE_MAX),PL*100.0, +! & esl,QSICE,DQSI) + esi=min(fpvsi(TKo),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + hltalt = hlatv + hlatf + desdt = hltalt*esi/(rgasv*TKo*TKo) + if (QSICE < 1.0) then + gam = hltalt*QSICE*pl100*desdt/(MAPL_CP*esi + & * (pl100 - omeps*esi)) + else + gam = 0.0 + endif + DQSI = (MAPL_CP/hltalt)*gam + + QSTKo = MAX( QSTKo , 1.0e-7 ) + QSICE = MAX( QSICE , 1.0e-7 ) + + if (tmpARR > 0.0) then + QKo =(QKo -QSTKo*CFR)*tmpARR + RH_BOX = QKo/QSTKo + else + RH_BOX = QKo/QSTKo + end if + + IF ( RH_BOX < RHCR3 ) THEN + Efactor = RHO_W * ( AA + BB ) / (RHCR3 - RH_BOX ) + else + Efactor = 9.99e9 + end if + + + LANDSEAF = 1.00 + + + if ( ( RH_BOX < RHCR3 ) .AND. ( DIAMrn > 0.00 ) .AND. + & ( PL > 100.) .AND. ( PL < REVAP_OFF_P ) ) then + DROPRAD = 0.5*DIAMrn + T_ED = Efactor * DROPRAD**2 + T_ED = T_ED * ( 1.0 + DQSTKo*alhlbcp ) + + EVAP = QPl*(1.0 - EXP( -C_EV_R * VErn * LANDSEAF *ENVFRAC* + & TinLAYERrn / T_ED ) ) + ELSE + EVAP = 0.0 + END if + + + + if (tmpARR > 0.0) then + QKo = (QKo -QSICE*CFR)*tmpARR + RH_BOX = QKo/QSICE + else + RH_BOX = QKo/QSICE + end if + IF ( RH_BOX < RHCR3 ) THEN + Efactor = 0.5*RHO_W * ( AA+BB ) / (RHCR3-RH_BOX ) + else + Efactor = 9.99e9 + end if + + + if ( ( RH_BOX < RHCR3 ) .AND. ( DIAMsn > 0.00 ) .AND. + & ( PL > 100. ) .AND. ( PL < REVAP_OFF_P ) ) then + FLAKRAD = 0.5*DIAMsn + T_ED = Efactor * FLAKRAD**2 + T_ED = T_ED * ( 1.0 + DQSI*alhsbcp) + SUBL = QPi*(1.0 - EXP( -C_EV_S * VEsn * LANDSEAF * ENVFRAC + & * TinLAYERsn / T_ED ) ) + + ELSE + SUBL = 0.0 + END IF + + if (itr == 1) then + EVAPx = EVAP + SUBLx = SUBL + else + EVAP = (EVAP+EVAPx) /2.0 + SUBL = (SUBL+SUBLx) /2.0 + endif + + EVAP = EVAP*(1.-CFR) + SUBL = SUBL*(1.-CFR) +! Anning prevent negative QPi and QPl + SUBL = min(QPi, max(SUBL,0.)) + EVAP = min(QPl, max(EVAP,0.)) + + + QKo =QKo + EVAP + SUBL + TKo = TKo - EVAP * alhlbcp - SUBL * alhsbcp + + enddo + QPi = QPi - SUBL + QPl = QPl - EVAP + + + EVAP_DD = EVAP_DD_above + DDFRACT*EVAP*MASS + EVAP = EVAP - DDFRACT*EVAP + SUBL_DD = SUBL_DD_above + DDFRACT*SUBL*MASS + SUBL = SUBL - DDFRACT*SUBL + + + QV = QV + EVAP + SUBL + TE = TE - EVAP * alhlbcp - SUBL * alhsbcp + + REVAP_DIAG = EVAP / DT + RSUBL_DIAG = SUBL / DT + + PFl = QPl*MASS + PFi = QPi*MASS + + PFL_DIAG = PFl/DT + PFI_DIAG = PFi/DT + end if + + + + EVAP = QDDF3*EVAP_DD/MASS + SUBL = QDDF3*SUBL_DD/MASS +! Anning prevent negative QPi and QPl + SUBL = min(QPi, max(SUBL,0.)) + EVAP = min(QPl, max(EVAP,0.)) + QV = QV + EVAP + SUBL + TE = TE - EVAP * alhlbcp - SUBL * alhsbcp + REVAP_DIAG = REVAP_DIAG + EVAP / DT + RSUBL_DIAG = RSUBL_DIAG + SUBL / DT + + IF (K == LM) THEN + RAIN = PFl/DT + SNOW = PFi/DT + END IF + + QPi = 0. + QPl = 0. + + PFl_above = PFl + PFi_above = Pfi + + EVAP_DD_above = EVAP_DD + SUBL_DD_above = SUBL_DD + + end subroutine precip3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine MARSHPALMQ2(RAIN,PR,DIAM3,NTOTAL,W,VE) + + real, intent(in ) :: RAIN,PR + real, intent(out) :: DIAM3,NTOTAL,W,VE + + real :: RAIN_DAY,LAMBDA,A,B,SLOPR,DIAM1 + + real, parameter :: N0 = 0.08 + + INTEGER :: IQD + + real :: RX(8) , D3X(8) + + + + RX = (/ 0. , 5. , 20. , 80. , 320. , 1280., 4*1280., 16*1280. /) + D3X = (/ 0.019, 0.032, 0.043, 0.057, 0.076, 0.102, 0.137 , + & 0.183 /) + + RAIN_DAY = RAIN * 3600. *24. + + IF ( RAIN_DAY <= 0.00 ) THEN + DIAM1 = 0.00 + DIAM3 = 0.00 + NTOTAL= 0.00 + W = 0.00 + END IF + + DO IQD = 1,7 + IF ( (RAIN_DAY <= RX(IQD+1)) .AND. (RAIN_DAY > RX(IQD))) THEN + SLOPR =( D3X(IQD+1)-D3X(IQD) ) / ( RX(IQD+1)-RX(IQD)) + DIAM3 = D3X(IQD) + (RAIN_DAY-RX(IQD))*SLOPR + END IF + END DO + + IF ( RAIN_DAY >= RX(8) ) THEN + DIAM3=D3X(8) + END IF + + NTOTAL = 0.019*DIAM3 + + DIAM3 = 0.664 * DIAM3 + + W = (2483.8 * DIAM3 + 80.)*SQRT(1000./PR) + + VE = MAX( 0.99*W/100. , 1.000 ) + + DIAM1 = 3.0*DIAM3 + + DIAM1 = DIAM1/100. + DIAM3 = DIAM3/100. + W = W/100. + NTOTAL = NTOTAL*1.0e6 + + end subroutine MARSHPALMQ2 +!========================================================== + + subroutine MICRO_AA_BB_3(TEMP,PR,Q_SAT,AA,BB) + + real, intent(in ) :: TEMP,Q_SAT + real, intent(in ) :: PR + real, intent(out) :: AA,BB + + real :: E_SAT + + real, parameter :: EPSILON = 0.622 + real, parameter :: K_COND = 2.4e-2 + real, parameter :: DIFFU = 2.2e-5 + + E_SAT = 100.* PR * Q_SAT /( (EPSILON) + (1.0-(EPSILON))*Q_SAT ) + + AA = ( GET_ALHX3(TEMP)**2 ) / ( K_COND*MAPL_RVAP*(TEMP**2) ) + + + BB = MAPL_RVAP*TEMP / ( DIFFU*(1000./PR)*E_SAT ) + + end subroutine MICRO_AA_BB_3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function LDRADIUS3(PL,TE,QCL,NN) RESULT(RADIUS) + + real, intent(in) :: TE,PL,NN,QCL + real :: RADIUS + + real :: MUU,RHO + + + RHO = 100.*PL / (MAPL_RGAS*TE ) + MUU = QCL * RHO + RADIUS = MUU/(NN*RHO_W*(4./3.)*MAPL_PI) + RADIUS = RADIUS**(1./3.) + + + end function LDRADIUS3 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + function ICE_FRACTION (TEMP) RESULT(ICEFRCT) + real, intent(in) :: TEMP + real :: ICEFRCT + + ICEFRCT = 0.00 + if ( TEMP <= T_ICE_ALL ) then + ICEFRCT = 1.000 + else if ( (TEMP > T_ICE_ALL) .AND. (TEMP <= T_ICE_MAX) ) then + ICEFRCT = 1.00 - ( TEMP - T_ICE_ALL ) / ( T_ICE_MAX - + & T_ICE_ALL ) + end if + ICEFRCT = MIN(ICEFRCT,1.00) + ICEFRCT = MAX(ICEFRCT,0.00) + + ICEFRCT = ICEFRCT**ICEFRPWR + + end function ICE_FRACTION + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + function GET_ALHX3(T) RESULT(ALHX3) + + real, intent(in) :: T + real :: ALHX3 + + real :: T_X + + T_X = T_ICE_MAX + + if ( T < T_ICE_ALL ) then + ALHX3=MAPL_ALHS + end if + + if ( T > T_X ) then + ALHX3=MAPL_ALHL + end if + + if ( (T <= T_X) .and. (T >= T_ICE_ALL) ) then + ALHX3 = MAPL_ALHS + (MAPL_ALHL-MAPL_ALHS) + & *( T - T_ICE_ALL )/( T_X - T_ICE_ALL ) + end if + + end function GET_ALHX3 + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + real function ICEFRAC(T,T_TRANS,T_FREEZ) + + real, intent(in) :: T + real, intent(in),optional :: T_TRANS + real, intent(in),optional :: T_FREEZ + + real :: T_X,T_F + + if (present( T_TRANS )) then + T_X = T_TRANS + else + T_X = T_ICE_MAX + endif + if (present( T_FREEZ )) then + T_F = T_FREEZ + else + T_F = T_ICE_ALL + endif + + + if ( T < T_F ) ICEFRAC=1.000 + + if ( T > T_X ) ICEFRAC=0.000 + + if ( T <= T_X .and. T >= T_F ) then + ICEFRAC = 1.00 - ( T - T_F ) /( T_X - T_F ) + endif + + end function ICEFRAC + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!Parititions DQ into ice and liquid. Follows Morrison and Gettelman, 2008 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine Bergeron_iter ( DTIME , PL , TE , QV , QILS , QICN , + & QLLS , QLCN , CF , AF , NL , NI , DQALL , FQI ) + + real , intent(in ) :: DTIME, PL, TE + real , intent(inout ) :: DQALL + real , intent(in) :: QV, QLLS, QLCN, QICN, QILS + real , intent(in) :: CF, AF, NL, NI + real, intent (out) :: FQI + real :: DC, TEFF,QCm,DEP, QC, QS, RHCR, DQSL, DQSI, QI, TC, DIFF, + & DENAIR, DENICE, AUX, DCF, QTOT, LHCORR, QL, DQI, DQL, QVINC, + & QSLIQ, CFALL, new_QI, new_QL, QSICE, fQI_0, QS_0, DQS_0, FQA, + & NIX + real esl,esi, esn,desdt,weight,hlatsb,hlatvp,hltalt,tterm, + & gam,pl100 + + + pl100=pl*100 + DIFF = 0.0 + DEP=0.0 + QI = QILS + QICN + QL = QLLS +QLCN + QTOT=QI+QL + FQA = 0.0 + if (QTOT .gt. 0.0) FQA = (QICN+QILS)/QTOT + NIX= (1.0-FQA)*NI + + DQALL=DQALL/DTIME + CFALL= min(CF+AF, 1.0) + TC=TE-273.0 + fQI_0 = fQI + + + + if (TE .ge. T_ICE_MAX) then + FQI = 0.0 + elseif(TE .le. T_ICE_ALL) then + FQI = 1.0 + else + + + FQI = 0.0 + if (QILS .le. 0.0) return + + QVINC= QV +! QSLIQ = QSATLQ( TE , PL*100.0 , DQ=DQSL ) +! call vqsatd2_water_single(TE,PL*100.0,esl,QSLIQ,DQSL) + esl=min(fpvsl(TE),pl100) + QSLIQ= min(epsqs*esl/(pl100-omeps*esl),1.) + +! QSICE = QSATIC( TE , PL*100.0 , DQ=DQSI ) +! call vqsatd2_ice_single(TE,PL*100.0,esl,QSICE,DQSI) + esi=min(fpvsi(TE),pl100) + QSICE= min(epsqs*esi/(pl100-omeps*esi),1.) + hltalt = hlatv + hlatf + desdt = hltalt*esi/(rgasv*TE*TE) + if (QSICE < 1.0) then + gam = hltalt*QSICE*pl100*desdt/(MAPL_CP*esi + & * (pl100 - omeps*esi)) + else + gam = 0.0 + endif + DQSI = (MAPL_CP/hltalt)*gam + + + + + QVINC =MIN(QVINC, QSLIQ) + + DIFF=(0.211*1013.25/(PL+0.1))*(((TE+0.1)/273.0)**1.94)*1e-4 + DENAIR = PL*100.0/MAPL_RGAS/TE + DENICE = 1000.0*(0.9167 - 1.75e-4*TC -5.0e-7*TC*TC) + LHcorr = ( 1.0 + DQSI*alhsbcp) + + if ((NIX .gt. 1.0) .and. (QILS .gt. 1.0e-10)) then + DC = max((QILS/(NIX*DENICE*MAPL_PI))**(0.333), 20.0e-6) + else + DC = 20.0e-6 + end if + + + TEFF= NIX*DENAIR*2.0*MAPL_PI*DIFF*DC/LHcorr + + DEP=0.0 + if ((TEFF .gt. 0.0) .and. (QILS .gt. 1.0e-14)) then + AUX =max(min(DTIME*TEFF, 20.0), 0.0) + DEP=(QVINC-QSICE)*(1.0-EXP(-AUX))/DTIME + end if + + DEP=MAX(DEP, -QILS/DTIME) + + DQI = 0.0 + DQL = 0.0 + FQI=0.0 + + if (DQALL .ge. 0.0) then + + if (DEP .gt. 0.0) then + DQI = min(DEP, DQALL + QLLS/DTIME) + DQL = DQALL - DQI + else + DQL=DQALL + DQI = 0.0 + end if + end if + + + if (DQALL .lt. 0.0) then + DQL = max(DQALL, -QLLS/DTIME) + DQI = max(DQALL - DQL, -QILS/DTIME) + end if + + if (DQALL .ne. 0.0) FQI=max(min(DQI/DQALL, 1.0), 0.0) + end if + end subroutine Bergeron_iter + + + +!============================================================================= +! Subroutine Pfreezing: calculates the probability of finding a supersaturated parcel in the grid cell +!SC_ICE is the effective freezing point for ice (Barahona & Nenes. 2009) +! Modified 02/19/15. in situ nucleation only occurs in the non_convective part of the grid cell + + + subroutine Pfreezing ( ALPHA , PL , TE , QV , QCl , QAl , QCi , + & QAi , SC_ICE , CF , AF , PF ) + + + + real , intent(in) :: PL,ALPHA, QV, SC_ICE, AF, TE, QCl, QCi, QAl, + & QAi, CF + real , intent(out) :: PF + + + real :: qt, QCx, QSn, tmpARR, CFALL, QVx, CFio, QA, QAx, QC, QI, + & QL, DQSx + real :: sigmaqt1, sigmaqt2, qsnx + real :: esl, esi,pl100 + + pl100=pl*100 + + QA = QAl + QAi + QC = QCl + QCi + CFALL = AF + + if ( CFALL >= 1.0 ) then + PF = 0.0 + return + end if + +! QSn = QSATIC( TE , PL*100.0 , DQ=DQSx ) +! call vqsatd2_ice_single(TE,PL*100.0,esl,QSn,DQSx) + esi=min(fpvsi(TE),pl100) + QSn= min(epsqs*esi/(pl100-omeps*esi),1.) + + QSn = MAX( QSn , 1.0e-9 ) + + + + tmpARR = 0.0 + if ( CFALL < 0.99 ) then + tmpARR = 1./(1.0-CFALL) + end if + + QCx = QC*tmpARR + QVx = ( QV - QSn*CFALL )*tmpARR +! QVx = QV*tmpARR + + qt = QCx + QVx + + CFio = 0.0 + + QSn = QSn*SC_ICE + + if(pdfflag.lt.2) then + sigmaqt1 = max(ALPHA, 0.1)*QSn + sigmaqt2 = max(ALPHA, 0.1)*QSn + elseif(pdfflag.eq.2) then +! for triangular, symmetric: sigmaqt1 = sigmaqt2 = alpha*qsn (alpha is half width) +! for triangular, skewed r : sigmaqt1 < sigmaqt2 +! try: skewed right below 500 mb +!!! if(pl.lt.500.) then + sigmaqt1 = ALPHA*QSn + sigmaqt2 = ALPHA*QSn + elseif(pdfflag .eq. 4) then + sigmaqt1 = max(ALPHA/sqrt(3.0), 0.001) + endif + + + + call pdffrac(pdfflag,qt,sigmaqt1,sigmaqt2,qsn,CFio) + + PF = CFio*(1.0-CFALL) + + PF = min(max(PF, 0.0), 0.999) + + + end subroutine Pfreezing + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!Instantaneous freezing of condensate!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + subroutine meltfrz_inst(IM, LM, TE, QCL, QAL, QCI, QAI, NL, NI) + + integer, intent(in) :: IM, LM + real , intent(inout), dimension(:,:) :: TE,QCL,QCI, QAL, QAI, + & NI, NL + + real , dimension(im,lm) :: fQi,dQil, DQmax, QLTOT, QITOT, FQAL, + & FQAI, dNil, FQA + + QITOT = QCI+QAI + QLTOT = QCL + QAL + FQA = 0.0 + + where (QITOT+QLTOT > 0.0) + FQA= (QAI+QAL)/(QITOT+QLTOT) + end where + + dQil = 0.0 + dNil = 0.0 + DQmax = 0.0 + + where( TE <= T_ICE_ALL ) + DQmax = (T_ICE_ALL - TE)/(alhsbcp-alhlbcp) + dQil = min(QLTOT , DQmax) + end where + + where ((dQil <= DQmax) .and. (dQil > 0.0)) + dNil = NL + end where + + where ((dQil > DQmax) .and. (dQil > 0.0)) + dNil = NL*DQmax/dQil + end where + + dQil = max( 0., dQil ) +! Anning for moisture conservation 11/22/2016 +! QITOT = max(QITOT + dQil, 0.0) +! QLTOT = max(QLTOT - dQil, 0.0) + dQil = min(QLTOT,dQil) + QITOT = QITOT + dQil + QLTOT = QLTOT - dQil + NL = NL - dNil + NI = NI + dNil + TE = TE + (alhsbcp-alhlbcp)*dQil + + dQil = 0.0 + dNil = 0.0 + DQmax = 0.0 + + + where( TE > T_ICE_MAX ) + DQmax = (TE-T_ICE_MAX) / (alhsbcp-alhlbcp) + dQil = min(QITOT, DQmax) + endwhere + + where ((dQil .le. DQmax) .and. (dQil .gt. 0.0)) + dNil = NI + end where + where ((dQil .gt. DQmax) .and. (dQil .gt. 0.0)) + dNil = NI*DQmax/dQil + end where + dQil = max( 0., dQil ) +! Anning for moisture conservation 11/22/2016 +! QLTOT = max(QLTOT+ dQil, 0.) +! QITOT = max(QITOT - dQil, 0.) + dQil = min(QITOT,dQil) + QITOT = QITOT - dQil + QLTOT = QLTOT + dQil + NL = NL + dNil + NI = NI - dNil + + TE = TE - (alhsbcp-alhlbcp)*dQil + + QCI = QITOT*(1.0-FQA) + QAI = QITOT*FQA + QCL = QLTOT*(1.0-FQA) + QAL = QLTOT*FQA + + end subroutine meltfrz_inst + + + +!====================================== + subroutine cloud_ptr_stubs ( + & SMAXL, SMAXI, WSUB, CCN01, CCN04, CCN1, NHET_NUC, NLIM_NUC, SO4, + & ORG, BCARBON, DUST, SEASALT, NCPL_VOL, NCPI_VOL, NRAIN, NSNOW, + & CDNC_NUC, INC_NUC, SAT_RAT, QSTOT, QRTOT, CLDREFFS, CLDREFFR, + & DQVDT_micro,DQIDT_micro, DQLDT_micro, DTDT_micro, RL_MASK, + & RI_MASK, KAPPA, SC_ICE, CFICE, CFLIQ, RHICE, RHLIQ, RAD_CF, + & RAD_QL, RAD_QI, RAD_QS, RAD_QR, RAD_QV, CLDREFFI, CLDREFFL, + & NHET_IMM, NHET_DEP, NHET_DHF, DUST_IMM, DUST_DEP, DUST_DHF, SCF, + & SCF_ALL, SIGW_GW, SIGW_CNV, SIGW_TURB, SIGW_RC, RHCmicro, + & DNHET_IMM, NONDUST_IMM, NONDUST_DEP, BERG, BERGSO, MELT, + & DNHET_CT, DTDT_macro, QCRES, DT_RASP, FRZPP_LS, SNOWMELT_LS, + & QIRES, AUTICE, PFRZ, DNCNUC, DNCHMSPLIT, DNCSUBL, DNCAUTICE, + & DNCACRIS, DNDCCN, DNDACRLS, DNDEVAPC, DNDACRLR, DNDAUTLIQ) +! & DNDCNV, DNCCNV) + + + + real , pointer , dimension(:,:,:) :: SMAXL,SMAXI, WSUB, CCN01, + & CCN04, CCN1, NHET_NUC, NLIM_NUC, SO4, ORG, BCARBON, DUST, + & SEASALT, NCPL_VOL, NCPI_VOL, NRAIN, NSNOW, CDNC_NUC, INC_NUC, + & SAT_RAT, QSTOT, QRTOT, CLDREFFS, CLDREFFR, DQVDT_micro, + &DQIDT_micro, DQLDT_micro, DTDT_micro, RL_MASK, RI_MASK, KAPPA, + & SC_ICE, CFICE, CFLIQ, RHICE, RHLIQ, ALPH, RAD_CF, RAD_QL, RAD_QI, + & RAD_QS, RAD_QR, RAD_QV, CLDREFFI, CLDREFFL, NHET_IMM, NHET_DEP, + & NHET_DHF, DUST_IMM, DUST_DEP, DUST_DHF, SCF, SCF_ALL, SIGW_GW, + & SIGW_CNV, SIGW_TURB, SIGW_RC, RHCmicro, DNHET_IMM, NONDUST_IMM, + & NONDUST_DEP, BERG, BERGSO, MELT, DNHET_CT, DTDT_macro, QCRES, + & DT_RASP, FRZPP_LS, SNOWMELT_LS, QIRES, AUTICE, PFRZ, DNCNUC, + & DNCHMSPLIT, DNCSUBL, DNCAUTICE, DNCACRIS, DNDCCN, DNDACRLS, + & DNDEVAPC, DNDACRLR, DNDAUTLIQ +! & DNDEVAPC, DNDACRLR, DNDAUTLIQ, DNDCNV, DNCCNV + + +!DONIF + + IF( ASSOCIATED(SMAXL) ) SMAXL = 0. + IF( ASSOCIATED(SMAXI) ) SMAXI = 0. + IF( ASSOCIATED(WSUB) ) WSUB = 0. + IF( ASSOCIATED(CCN01) ) CCN01 = 0. + IF( ASSOCIATED(CCN04) ) CCN04 = 0. + IF( ASSOCIATED(CCN1) ) CCN1 = 0. + IF( ASSOCIATED(NHET_NUC) ) NHET_NUC = 0. + IF( ASSOCIATED(NLIM_NUC) ) NLIM_NUC = 0. + IF( ASSOCIATED(SO4) ) SO4 = 0. + IF( ASSOCIATED(ORG) ) ORG = 0. + IF( ASSOCIATED(BCARBON) ) BCARBON = 0. + IF( ASSOCIATED(DUST) ) DUST = 0. + IF( ASSOCIATED(SEASALT) ) SEASALT = 0. + IF( ASSOCIATED(NCPL_VOL) ) NCPL_VOL = 0. + IF( ASSOCIATED(NCPI_VOL) ) NCPI_VOL = 0. + + IF( ASSOCIATED(NRAIN) ) NRAIN = 0. + IF( ASSOCIATED(NSNOW) ) NSNOW = 0. + IF( ASSOCIATED(CDNC_NUC) ) CDNC_NUC = 0. + IF( ASSOCIATED(INC_NUC) ) INC_NUC = 0. + IF( ASSOCIATED(SAT_RAT) ) SAT_RAT = 0. + IF( ASSOCIATED(QSTOT) ) QSTOT = 0. + IF( ASSOCIATED(QRTOT) ) QRTOT = 0. + + IF( ASSOCIATED(DQVDT_micro) ) DQVDT_micro = 0. + IF( ASSOCIATED(DQIDT_micro) ) DQIDT_micro = 0. + IF( ASSOCIATED(DQLDT_micro) ) DQLDT_micro = 0. + IF( ASSOCIATED(DTDT_micro) ) DTDT_micro = 0. + IF( ASSOCIATED(DTDT_macro) ) DTDT_macro = 0. + + IF( ASSOCIATED(RL_MASK) ) RL_MASK = 0. + IF( ASSOCIATED(RI_MASK) ) RI_MASK = 0. + IF( ASSOCIATED(KAPPA) ) KAPPA = 0. + IF( ASSOCIATED(SC_ICE)) SC_ICE = 0. + IF( ASSOCIATED(RHICE) ) RHICE = 0. + IF( ASSOCIATED(RHLIQ) ) RHLIQ = 0. + IF( ASSOCIATED(CFICE) ) CFICE = 0. + IF( ASSOCIATED(CFLIQ) ) CFLIQ = 0. + IF( ASSOCIATED(ALPH) ) ALPH = 0. + + + IF( ASSOCIATED(RAD_CF) ) RAD_CF = 0. + IF( ASSOCIATED(RAD_QL) ) RAD_QL = 0. + IF( ASSOCIATED(RAD_QI) ) RAD_QI = 0. + IF( ASSOCIATED(RAD_QS) ) RAD_QS = 0. + IF( ASSOCIATED(RAD_QR) ) RAD_QR = 0. + IF( ASSOCIATED(RAD_QV) ) RAD_QV = 0. + IF( ASSOCIATED(CLDREFFI) ) CLDREFFI = 0. + IF( ASSOCIATED(CLDREFFL) ) CLDREFFL = 0. + IF( ASSOCIATED(CLDREFFS) ) CLDREFFS = 0. + IF( ASSOCIATED(CLDREFFR) ) CLDREFFR = 0. + + IF( ASSOCIATED(NHET_IMM) ) NHET_IMM = 0. + IF( ASSOCIATED(NHET_DEP) ) NHET_DEP = 0. + IF( ASSOCIATED(NHET_DHF) ) NHET_DHF = 0. + IF( ASSOCIATED(DUST_IMM) ) DUST_IMM = 0. + IF( ASSOCIATED(DUST_DEP) ) DUST_DEP = 0. + IF( ASSOCIATED(DUST_DHF) ) DUST_DHF = 0. + IF( ASSOCIATED(NONDUST_IMM) ) NONDUST_IMM = 0. + IF( ASSOCIATED(NONDUST_DEP) ) NONDUST_DEP = 0. + + + IF( ASSOCIATED(SCF) ) SCF = 0. + IF( ASSOCIATED(SCF_ALL) ) SCF_ALL = 0. + IF( ASSOCIATED(SIGW_GW) ) SIGW_GW = 0. + IF( ASSOCIATED(SIGW_CNV) ) SIGW_CNV = 0. + IF( ASSOCIATED(SIGW_TURB) ) SIGW_TURB = 0. + IF( ASSOCIATED(SIGW_RC) ) SIGW_RC = 0. + IF( ASSOCIATED(RHCmicro) ) RHCmicro = 0. + IF( ASSOCIATED(DNHET_IMM) ) DNHET_IMM = 0. + IF( ASSOCIATED(BERG) ) BERG = 0. + IF( ASSOCIATED(BERGSO)) BERGSO = 0. + IF( ASSOCIATED(MELT) ) MELT = 0. + IF( ASSOCIATED(DNHET_CT) ) DNHET_CT = 0. + IF( ASSOCIATED(DT_RASP) ) DT_RASP = 0. + + IF( ASSOCIATED(QCRES) ) QCRES = 0. + IF( ASSOCIATED(QIRES) ) QIRES = 0. + IF( ASSOCIATED(AUTICE) ) AUTICE = 0. + IF( ASSOCIATED(FRZPP_LS) ) FRZPP_LS = 0. + IF( ASSOCIATED(SNOWMELT_LS) ) SNOWMELT_LS = 0. + IF( ASSOCIATED(PFRZ) ) PFRZ = 0. + + IF( ASSOCIATED(DNCNUC) ) DNCNUC = 0. + IF( ASSOCIATED(DNCSUBL) ) DNCSUBL = 0. + IF( ASSOCIATED(DNCHMSPLIT) ) DNCHMSPLIT = 0. + IF( ASSOCIATED(DNCAUTICE) ) DNCAUTICE = 0. + IF( ASSOCIATED(DNCACRIS) ) DNCACRIS = 0. + IF( ASSOCIATED(DNDCCN) ) DNDCCN = 0. + IF( ASSOCIATED(DNDACRLS) ) DNDACRLS = 0. + IF( ASSOCIATED(DNDACRLR) ) DNDACRLR = 0. + IF( ASSOCIATED(DNDEVAPC) ) DNDEVAPC = 0. + IF( ASSOCIATED(DNDAUTLIQ) ) DNDAUTLIQ = 0. +! IF( ASSOCIATED(DNDCNV) ) DNDCNV = 0. +! IF( ASSOCIATED(DNCCNV) ) DNCCNV = 0. + + end subroutine cloud_ptr_stubs + +!C======================================================================= +!C +!C *** REAL FUNCTION erf (overwrites previous versions) +!C *** THIS SUBROUTINE CALCULATES THE ERROR FUNCTION USING A +!C *** POLYNOMIAL APPROXIMATION +!C +!C======================================================================= +!C + REAL FUNCTION erf_app(x) + REAL :: x + REAL*8:: AA(4), axx, y + DATA AA /0.278393d0,0.230389d0,0.000972d0,0.078108d0/ + + y = dabs(dble(x)) + axx = 1.d0 + y*(AA(1)+y*(AA(2)+y*(AA(3)+y*AA(4)))) + axx = axx*axx + axx = axx*axx + axx = 1.d0 - (1.d0/axx) + if(x.le.0.) then + erf_app = sngl(-axx) + else + erf_app = sngl(axx) + endif + RETURN + END FUNCTION + + end module cldmacro diff --git a/gsmphys/cldwat2m_micro.F b/gsmphys/cldwat2m_micro.F new file mode 100644 index 00000000..75446f29 --- /dev/null +++ b/gsmphys/cldwat2m_micro.F @@ -0,0 +1,5498 @@ + module cldwat2m_micro + +!--------------------------------------------------------------------------------- +! Purpose: +! CAM Interface for microphysics +! +! Author: Andrew Gettelman, Hugh Morrison. +! Contributions from: Xiaohong Liu and Steve Ghan +! December 2005-May 2010 +! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) +! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) +! for questions contact Hugh Morrison, Andrew Gettelman +! e-mail: morrison@ucar.edu, andrew@ucar.edu +!--------------------------------------------------------------------------------- + +#ifdef NEMS_GSM + use machine, only : r8 => kind_phys + use physcons, gravit => con_g, rair => con_rd, & + & rh2o => con_rv, epsilon => con_eps, & + & tmelt => con_tice, cpair => con_cp, & + & latvap => con_hvap, latice => con_hfus + use wv_saturation, only : estblf, hlatv, tmin, hlatf, rgasv, pcf,& + & epsqs, ttrice, vqsatd2,cp, & + & vqsatd2_single,polysvp,gestbl + use funcphys, only : fpvs, fpvsl, fpvsi +#endif + +#ifdef GEOS5 + use MAPL_ConstantsMod, r8 => MAPL_R8 + use wv_saturation, only: estblf, hlatv, tmin, hlatf, rgasv, & + & pcf, cp, epsqs, ttrice, vqsatd2, & + & vqsatd2_single,polysvp,gestbl +#endif + +#ifdef CAM + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use physconst, only: gravit, rair, tmelt, cpair, rh2o, + & r_universal, mwh2o, rhoh2o + use physconst, only: latvap, latice + use abortutils, only: endrun + use error_function, only: erf,erfc + use wv_saturation, only: estblf, hlatv, tmin, hlatf, rgasv, & + & pcf, cp, epsqs, ttrice, vqsatd2, & + & vqsatd2_single,polysvp + use cam_history, only: addfld, add_default, phys_decomp, & + & outfld + use cam_logfile, only: iulog + use rad_constituents, only: rad_cnst_get_clim_info, + & rad_cnst_get_clim_aer_props + use phys_control, only: phys_getopts + use cldwat2m_macro, only: rhmini, rhmaxi +#endif + + + implicit none + + real(r8), parameter :: zero=0.0_r8, one=1.0_r8, two=2.0_r8 & + &, three=3.0_r8, four=4.0_r8, five=5.0_r8 & + &, half=0.5_r8, oneb3=one/three & + &, onebcp=one/cpair +#ifdef NEMS_GSM +! + integer, parameter :: iulog = 6 + + real(r8), parameter :: rhmini = 0.80_r8 + real(r8), parameter :: rhmaxi = 1.1_r8 +! real(r8), parameter :: r_universal = 6.02214e26*1.38065e-23 +! real(r8), parameter :: r_universal = con_rgas * 1000.0 + real(r8), parameter :: mwh2o = 18.016 + real(r8), parameter :: rhoh2o = 1.000e3 + + logical :: ip = .true. + real(r8) :: tmn = 173.16_r8, tmx = 375.16_r8, trice = 35.00_r8 +#endif + + +#ifdef GEOS5 +!++jtb +! + real(r8), parameter :: rhmini = 0.80_r8 + real(r8), parameter :: rhmaxi = 1.1_r8 + integer, parameter :: iulog = 6 + + + + real(r8), parameter :: gravit = MAPL_GRAV + real(r8), parameter :: rair = MAPL_RGAS + real(r8), parameter :: tmelt = MAPL_TICE + real(r8), parameter :: cpair = MAPL_CP + real(r8), parameter :: rh2o = MAPL_RVAP + real(r8), parameter :: r_universal = MAPL_RUNIV + real(r8), parameter :: mwh2o = MAPL_H2OMW + real(r8), parameter :: rhoh2o = MAPL_RHOWTR + real(r8), parameter :: latvap = MAPL_ALHL + real(r8), parameter :: latice = MAPL_ALHF + real(r8), parameter :: epsilon = MAPL_VIREPS + + + logical :: ip = .true. + real(r8) :: tmn = 173.16_r8 + real(r8) :: tmx = 375.16_r8 + real(r8) :: trice = 35.00_r8 +#endif +!--jtb + + + private +! save + + logical, public :: liu_in = .false. + + + public :: ini_micro, mmicro_pcond,gamma,derf + +!constants remaped + real(r8), private:: g, ginv + real(r8), private:: r + real(r8), private:: rv +! real(r8), private:: rr ! not used + real(r8), private:: cpp + real(r8), private:: rhow, pirhow + real(r8), private:: xxlv + real(r8), private:: xlf, xlfocp, cpoxlf + real(r8), private:: xxls + + real(r8), private:: rhosn, pirhosn + real(r8), private:: rhoi, pirhoi + + real(r8), private:: ac,bc,as,bs,ai,bi,ar,br + real(r8), private:: ci,di,oneodi + real(r8), private:: cs,ds + real(r8), private:: cr,dr + real(r8), private:: f1s,f2s + real(r8), private:: Eii + real(r8), private:: Ecc + real(r8), private:: Ecr + real(r8), private:: f1r,f2r + real(r8), private:: DCS, ts_auto_ice + real(r8), private:: qsmall + real(r8), private:: qvsmall + real(r8), private:: bimm,aimm + real(r8), private:: rhosu + real(r8), private:: mi0 + real(r8), private:: rin + real(r8), private:: qcvar + real(r8), private:: pi + +! Additional constants to help speed up code + + real(r8), private:: cons1, cons2, cons3, cons4, cons5 + &, cons6, cons7, cons8, cons9, cons10 + &, cons11, cons12, cons13, cons14, cons15 + &, cons16, cons17, cons18, cons19, cons20 + &, cons21, cons22, cons23, cons24, cons25 + &, cons27, cons28 + + real(r8), private:: lammini, lammaxi, lamminr, lammaxr + &, lammins, lammaxs + +! parameters for snow/rain fraction for convective clouds + real(r8), private, parameter :: tmax_fsnow = tmelt + &, tmin_fsnow = tmelt-5._r8 + +!needed for findsp + real(r8), private:: tt0 + +!switch for specification of droplet and crystal number + + real(r8), private:: csmin,csmax,minrefl,mindbz + + + contains + +!=============================================================================== + + subroutine ini_micro(Dcs_, QCVAR_, ts_auto_ice_) + +!----------------------------------------------------------------------- +! +! Purpose: +! initialize constants for the morrison microphysics +! called from stratiform.F90 +! +! Author: Andrew Gettelman Dec 2005 +! +!----------------------------------------------------------------------- + +#ifdef CAM + use cloud_fraction, only: cldfrc_getparams +#endif + real(r8), intent(in) :: Dcs_, QCVAR_, ts_auto_ice_ + + + integer k, l, m, iaer + real(r8) surften, arg, derf + + character(len=16) :: eddy_scheme = ' ' + logical :: history_microphysics + + + +#ifdef CAM + + call phys_getopts(eddy_scheme_out = eddy_scheme, + & history_microphysics_out = history_microphysics ) + + + call addfld ('QRAIN ','kg/kg ',pver, 'A','Diagnostic grid- + &mean rain mixing ratio' ,phys_decomp) + call addfld ('QSNOW ','kg/kg ',pver, 'A','Diagnostic grid- + &mean snow mixing ratio' ,phys_decomp) + call addfld ('NRAIN ','m-3 ',pver, 'A','Diagnostic grid- + &mean rain number conc' ,phys_decomp) + call addfld ('NSNOW ','m-3 ',pver, 'A','Diagnostic grid- + &mean snow number conc' ,phys_decomp) + + + call addfld ('RERCLD ','m ',pver, 'A', + &'Diagnostic effective radius of Liquid Cloud and Rain' , + &phys_decomp) + + call addfld ('DSNOW ','m ',pver, 'A','Diagnostic grid- + &mean snow diameter' ,phys_decomp) + + + call addfld ('MGFLXPRC ','kg/m2/s ',pver+1, 'A','Diagnostic grid- + &mean rain flux at layer interface', phys_decomp) + call addfld ('MGFLXSNW ','kg/m2/s ',pver+1, 'A','Diagnostic grid- + &mean snow flux at layer interface', phys_decomp) + + + call addfld ('REFL ','DBz ',pver, 'A', + &'94 GHz radar reflectivity' ,phys_decomp) + call addfld ('AREFL ','DBz ',pver, 'A', + &'Average 94 GHz radar reflectivity' ,phys_decomp) + call addfld ('FREFL ','fraction ',pver, 'A', + &'Fractional occurance of radar reflectivity' ,phys_decomp) + + call addfld ('CSRFL ','DBz ',pver, 'A', + &'94 GHz radar reflectivity (CloudSat thresholds)' ,phys_decomp) + call addfld ('ACSRFL ','DBz ',pver, 'A', + &'Average 94 GHz radar reflectivity (CloudSat thresholds)' , + &phys_decomp) + call addfld ('FCSRFL ','fraction ',pver, 'A', + &'Fractional occurance of radar reflectivity (CloudSat thresholds)' + & ,phys_decomp) + + call addfld ('AREFLZ ','mm^6/m^3 ',pver, 'A', + &'Average 94 GHz radar reflectivity' ,phys_decomp) + + + call addfld ('NCAL ','#/m3 ',pver, 'A', + &'Number Concentation Activated for Liquid',phys_decomp) + call addfld ('NCAI ','#/m3 ',pver, 'A', + &'Number Concentation Activated for Ice',phys_decomp) + + + + call addfld ('AQRAIN ','kg/kg ',pver, 'A', + &'Average rain mixing ratio' ,phys_decomp) + call addfld ('AQSNOW ','kg/kg ',pver, 'A', + &'Average snow mixing ratio' ,phys_decomp) + call addfld ('ANRAIN ','m-3 ',pver, 'A', + &'Average rain number conc' ,phys_decomp) + call addfld ('ANSNOW ','m-3 ',pver, 'A', + &'Average snow number conc' ,phys_decomp) + call addfld ('ADRAIN ','Micron ',pver, 'A', + &'Average rain effective Diameter' ,phys_decomp) + call addfld ('ADSNOW ','Micron ',pver, 'A', + &'Average snow effective Diameter' ,phys_decomp) + call addfld ('FREQR ','fraction ',pver, 'A', + &'Fractional occurance of rain' ,phys_decomp) + call addfld ('FREQS ','fraction ',pver, 'A', + &'Fractional occurance of snow' ,phys_decomp) + + if ( history_microphysics) then + call add_default ('AQSNOW ', 1, ' ') + call add_default ('FREQR ', 1, ' ') + call add_default ('FREQS ', 1, ' ') + call add_default ('AQRAIN ', 1, ' ') + call add_default ('AQSNOW ', 1, ' ') + call add_default ('ANRAIN ', 1, ' ') + call add_default ('ANSNOW ', 1, ' ') + end if + +#endif +!--jtb commented out when GEOS5 + +!declarations for morrison codes (transforms variable names) + + g = gravit + ginv = one / g + r = rair + rv = rh2o +! rr = r_universal + cpp = cpair + cp = cpair + rhow = rhoh2o + +! latent heats + + xxlv = latvap + xlf = latice + xxls = xxlv + xlf + xlfocp = xlf / cpair + cpoxlf = cpair / xlf + +! write(0,*)' xlfocp=',xlfocp,' cpoxlf=',cpoxlf +! parameters below from Reisner et al. (1998) +! density parameters (kg/m3) + + rhosn = 100._r8 + rhoi = 500._r8 + rhow = 1000._r8 + + +! fall speed parameters, V = aD^b +! V is in m/s + +! droplets + ac = 3.e7_r8 + bc = two + +! snow + as = 11.72_r8 + bs = 0.41_r8 + +! cloud ice + ai = 700._r8 + bi = one + +! rain + ar = 841.99667_r8 + br = 0.8_r8 + +! particle mass-diameter relationship +! currently we assume spherical particles for cloud ice/snow +! m = cD^d + +! pi= 3.1415927_r8 +! pi= 3.1415926535897931_r8 + + pi = four*atan(one) + + pirhow = pi * rhow + pirhosn = pi * rhosn + pirhoi = pi * rhoi + +! cloud ice mass-diameter relationship + + ci = pirhoi/6._r8 + di = three + oneodi = one / di + +! snow mass-diameter relationship + + cs = pirhosn/6._r8 + ds = three + +! drop mass-diameter relationship + + cr = pirhow/6._r8 + dr = three + +! ventilation parameters for snow +! hall and prupacher + + f1s = 0.86_r8 + f2s = 0.28_r8 + +! collection efficiency, aggregation of cloud ice and snow + + Eii = 0.1_r8 + +! collection efficiency, accretion of cloud water by rain + + Ecr = one + +! ventilation constants for rain + + f1r = 0.78_r8 + f2r = 0.32_r8 + +! autoconversion size threshold for cloud ice to snow (m) + + Dcs = Dcs_ * 1.0e-6_r8 +! ice autoconversion time scale (default 180s) + + ts_auto_ice = ts_auto_ice_ + +! smallest mixing ratio considered in microphysics + + qsmall = 1.e-18_r8 + qvsmall = 1.e-6_r8 + +! immersion freezing parameters, bigg 1953 + + bimm = 100._r8 + aimm = 0.66_r8 + +! typical air density at 850 mb + + rhosu = 85000._r8/(rair * tmelt) + +! mass of new crystal due to aerosol freezing and growth (kg) + + mi0 = (four/three)*pirhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) + + +! radius of contact nuclei aerosol (m) + + rin = 0.1e-6_r8 + +! 1 / relative variance of sub-grid cloud water distribution +! see morrison and gettelman, 2008, J. Climate for details + + + + qcvar = QCVAR_ + +! freezing temperature + tt0 = 273.15_r8 + + +!++jtb + tmn = 173.16_r8 + tmx = 375.16_r8 + trice = 35.00_r8 + ip = .true. + + call gestbl(tmn ,tmx ,trice ,ip ,epsilon , latvap ,latice ,rh2o , + & cpair ,tmelt ) + +!--jtb (08/18/10) + +! pi = 4._r8*atan(1.0_r8) + + + csmin = -30._r8 + csmax = 26._r8 + mindbz = -99._r8 + + minrefl = 1.26e-10_r8 + +! Define constants to help speed up code (limit calls to gamma function) + + cons1 = gamma(one+di) +! cons1 = gamma(one+miu_ice+ di)/gamma(one+miu_ice) + + cons2 = gamma(qcvar+2.47_r8) + cons3 = gamma(qcvar) + cons4 = gamma(one+br) + cons5 = gamma(four+br) + cons6 = gamma(one+ds) + cons7 = gamma(one+bs) + cons8 = gamma(four+bs) + cons9 = gamma(qcvar+two) + cons10 = gamma(qcvar+one) + cons11 = gamma(three+bs) + cons12 = gamma(qcvar+1.15_r8) + cons13 = gamma((five+br)*half) + cons14 = gamma((five+bs)*half) + cons15 = gamma(qcvar+bc/three) + + + + + + cons18 = qcvar**2.47_r8 + cons19 = qcvar*qcvar + cons20 = qcvar**1.15_r8 + cons21 = qcvar**(bc/three) + cons22 = (four/three)*pirhow*(25.e-6_r8)**3 + cons23 = dcs*dcs*dcs + cons24 = dcs*dcs + cons25 = dcs**bs + cons27 = xxlv*xxlv + cons28 = xxls*xxls + + lammaxi = one / 1.e-6_r8 + lammini = one / (one*dcs) + lammaxr = one / 20.e-6_r8 + lamminr = one / 500.e-6_r8 + lammaxs = one / 10.e-6_r8 + lammins = one / 2000.e-6_r8 + + return + end subroutine ini_micro + +!=============================================================================== +!microphysics routine for each timestep goes here... + + subroutine mmicro_pcond ( lchnk, ncol, deltatin, tn, ttend, + & pcols, pver, + & qn, qtend, cwtend, qc, qi, nc, ni,fprcp,qrn,qsnw,nrn,nsnw, + & p, pdel, cldn, liqcldf, + & icecldf, cldo, pint, rpdel, zm, rate1ord_cw2pr_st, naai, +! & icecldf, cldo, pint, rpdel, zm, omega, rate1ord_cw2pr_st, naai, + & npccnin, rndst,nacon, rhdfda, rhu00, fice, tlat, qvlat, qctend, + & qitend, nctend, nitend, effc, effc_fn, effi, prect, preci, + & nevapr, evapsnow, prain, prodsnow, cmeout, deffi, pgamrad, + & lamcrad,qsout2,qrout2, drout2, qcsevap,qisevap,qvres, + & cmeiout, vtrmc,vtrmi,qcsedten,qisedten, prao, + & prco,mnuccco,mnuccto, + & msacwio,psacwso, bergso,bergo,melto,homoo,qcreso,prcio,praio, + & qireso, mnuccro,pracso,meltsdt,frzrdt, ncal, ncai, mnuccdo, + & nnuccto, + & nsout2, nrout2, ncnst, ninst, nimm, miu_disp, nsoot, rnsoot, + & ui_scale, dcrit, nnuccdo, nnuccco, nsacwio, nsubio, nprcio, + & npraio, npccno, npsacwso, nsubco, nprao, nprc1o, tlataux, + & nbincontactdust, lprint,xlat,xlon) +! & nbincontactdust, ts_auto_ice,xlat,xlon) + + +!Author: Hugh Morrison, Andrew Gettelman, NCAR +! e-mail: morrison@ucar.edu, andrew@ucar.edu + + use wv_saturation, only: vqsatd, vqsatd_water + +#ifdef CAM + use constituents, only: pcnst + real(r8), parameter :: ncnst = 100.0e6 + real(r8), parameter :: ninst = 0.10e6 +#endif + +!--jtb (08/18/10) Is this still needed? Pcnst is not used. + + integer, intent (in) :: pcols, pver,fprcp + real(r8), intent (in) :: ncnst + real(r8), intent (in) :: ninst + real(r8), intent (in) :: nimm (pcols,pver) + real(r8), intent (in) :: miu_disp , ui_scale, dcrit +! real(r8), intent (in) :: miu_disp , ui_scale, dcrit, ts_auto_ice + real(r8), intent (in) :: nsoot (pcols,pver) , rnsoot (pcols,pver) + & ,xlon,xlat +! integer, intent(in) :: ktrop_min + + + logical lprint + + + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + real(r8), intent(in) :: deltatin + real(r8), intent(in) :: tn(pcols,pver) + real(r8), intent(in) :: ttend(pcols,pver) + real(r8), intent(in) :: qn(pcols,pver) + real(r8), intent(in) :: qtend(pcols,pver) + real(r8), intent(in) :: cwtend(pcols,pver) + + real(r8), intent(inout) :: qc(pcols,pver) + real(r8), intent(inout) :: qi(pcols,pver) + real(r8), intent(inout) :: nc(pcols,pver) + real(r8), intent(inout) :: ni(pcols,pver) + real(r8), intent(inout) :: qrn(pcols,pver) + real(r8), intent(inout) :: qsnw(pcols,pver) + real(r8), intent(inout) :: nrn(pcols,pver) + real(r8), intent(inout) :: nsnw(pcols,pver) + real(r8), intent(in) :: p(pcols,pver) + real(r8), intent(in) :: pdel(pcols,pver) + real(r8), intent(in) :: cldn(pcols,pver) + real(r8), intent(in) :: icecldf(pcols,pver) + real(r8), intent(in) :: liqcldf(pcols,pver) + real(r8), intent(inout) :: cldo(pcols,pver) + real(r8), intent(in) :: pint(pcols,pver+1) + + real(r8), intent(in) :: rpdel(pcols,pver) + real(r8), intent(in) :: zm(pcols,pver) +! real(r8), intent(in) :: omega(pcols,pver) + + real(r8), intent(out) :: rate1ord_cw2pr_st(pcols,pver) + +! Inputs for aerosol activation + real(r8), intent(in) :: naai(pcols,pver) + real(r8), intent(inout) :: npccnin(pcols,pver) + integer :: nbincontactdust + real(r8), intent(in), dimension(pcols,pver, 10) :: rndst, nacon + + + real(r8), intent(in) :: rhdfda(pcols,pver) + real(r8), intent(in) :: rhu00(pcols,pver) + real(r8), intent(in) :: fice(pcols,pver) + + real(r8), intent(out) :: tlat(pcols,pver) + + real(r8), intent(out) :: tlataux(pcols,pver) + + real(r8), intent(out) :: qvlat(pcols,pver) + real(r8), intent(out) :: qctend(pcols,pver) + real(r8), intent(out) :: qitend(pcols,pver) + real(r8), intent(out) :: nctend(pcols,pver) + real(r8), intent(out) :: nitend(pcols,pver) + real(r8), intent(out) :: effc(pcols,pver) + real(r8), intent(out) :: effc_fn(pcols,pver) + real(r8), intent(out) :: effi(pcols,pver) + real(r8), intent(out) :: prect(pcols) + real(r8), intent(out) :: preci(pcols) + real(r8), intent(out) :: nevapr(pcols,pver) + real(r8), intent(out) :: evapsnow(pcols,pver) + real(r8), intent(out) :: prain(pcols,pver) + real(r8), intent(out) :: prodsnow(pcols,pver) + real(r8), intent(out) :: cmeout(pcols,pver) + real(r8), intent(out) :: deffi(pcols,pver) + real(r8), intent(out) :: pgamrad(pcols,pver) + real(r8), intent(out) :: lamcrad(pcols,pver) + + real(r8), intent(out) :: qcsevap(pcols,pver) + real(r8), intent(out) :: qisevap(pcols,pver) + real(r8), intent(out) :: qvres(pcols,pver) + real(r8), intent(out) :: cmeiout(pcols,pver) + real(r8), intent(out) :: vtrmc(pcols,pver) + real(r8), intent(out) :: vtrmi(pcols,pver) + real(r8), intent(out) :: qcsedten(pcols,pver) + real(r8), intent(out) :: qisedten(pcols,pver) +! microphysical process rates for output (mixing ratio tendencies) + real(r8), intent(out) :: prao(pcols,pver) + real(r8), intent(out) :: prco(pcols,pver) + real(r8), intent(out) :: mnuccco(pcols,pver) + real(r8), intent(out) :: mnuccto(pcols,pver) + real(r8), intent(out) :: msacwio(pcols,pver) + real(r8), intent(out) :: psacwso(pcols,pver) + real(r8), intent(out) :: bergso(pcols,pver) + real(r8), intent(out) :: bergo(pcols,pver) + real(r8), intent(out) :: melto(pcols,pver) + real(r8), intent(out) :: homoo(pcols,pver) + real(r8), intent(out) :: qcreso(pcols,pver) + real(r8), intent(out) :: prcio(pcols,pver) + real(r8), intent(out) :: praio(pcols,pver) + real(r8), intent(out) :: qireso(pcols,pver) + real(r8), intent(out) :: mnuccro(pcols,pver) + real(r8), intent(out) :: pracso (pcols,pver) + real(r8), intent(out) :: meltsdt(pcols,pver) + real(r8), intent(out) :: frzrdt (pcols,pver) + real(r8), intent(out) :: mnuccdo(pcols,pver) + real(r8), intent(out) :: nnuccto(pcols,pver) + + real(r8), intent(out) :: nnuccdo(pcols,pver) + real(r8), intent(out) :: nnuccco(pcols,pver) + real(r8), intent(out) :: nsacwio(pcols,pver) + real(r8), intent(out) :: nsubio(pcols,pver) + real(r8), intent(out) :: nprcio(pcols,pver) + real(r8), intent(out) :: npraio(pcols,pver) + + real(r8), intent(out) :: npccno(pcols,pver) + real(r8), intent(out) :: npsacwso(pcols,pver) + real(r8), intent(out) :: nsubco(pcols,pver) + real(r8), intent(out) :: nprao(pcols,pver) + real(r8), intent(out) :: nprc1o(pcols,pver) + +! local workspace +! all units mks unless otherwise stated + +! temporary variables for sub-stepping + + real(r8) :: t1(pcols,pver) + real(r8) :: q1(pcols,pver) + real(r8) :: qc1(pcols,pver) + real(r8) :: qi1(pcols,pver) + real(r8) :: nc1(pcols,pver) + real(r8) :: ni1(pcols,pver) + real(r8) :: tlat1(pcols,pver) + real(r8) :: qvlat1(pcols,pver) + real(r8) :: qctend1(pcols,pver) + real(r8) :: qitend1(pcols,pver) + real(r8) :: nctend1(pcols,pver) + real(r8) :: nitend1(pcols,pver) + real(r8) :: prect1(pcols) + real(r8) :: preci1(pcols) + + real(r8) :: tlat1_aux(pcols,pver) + + +! hm 5/12/11 +! temporary variable for old nc before updating with activation tendency + real(r8) :: ncold(pcols,pver) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + real(r8) :: deltat, dti, deltam + real(r8) :: omsm + real(r8) :: dto2 + real(r8) :: mincld + real(r8), dimension(pcols,pver) :: q, t, rho, irho, rhof, dv + &, mu, sc, kap, cldmax, cldm + &, icldm, lcldm, cme, cmei + &, cwml, cwmi, lcldn, lcldo + &, nctend_mixnuc, npccn + + real(r8), dimension(pcols) :: icwc, calpha, cbeta, cbetah + &, cgamma, cgamah, rcgama + &, cmec1, cmec2, cmec3, cmec4 + + real(r8), dimension(pver) :: nnuccd, mnuccd + &, qcsinksum_rate1ord + &, qcsum_rate1ord + + real(r8) :: qtmp, dum, dum1, dum2, qcld + &, arg, alpha + + + real(r8) :: qcic(pcols,pver) + real(r8) :: qiic(pcols,pver) + real(r8) :: qniic(pcols,pver) + real(r8) :: qric(pcols,pver) + real(r8) :: ncic(pcols,pver) + real(r8) :: niic(pcols,pver) + real(r8) :: nsic(pcols,pver) + real(r8) :: nric(pcols,pver) + real(r8) :: lami(pver) + real(r8) :: n0i(pver) + real(r8) :: lamc(pver) + real(r8) :: n0c(pver) + real(r8) :: lams(pver) + real(r8) :: n0s(pver) + real(r8) :: lamr(pver) + real(r8) :: n0r(pver) + real(r8) :: cdist1(pver) +! combined size of precip & cloud drops + real(r8) :: rercld(pcols,pver) + real(r8) :: arcld(pcols,pver) + real(r8) :: Actmp + real(r8) :: Artmp + + real(r8) :: pgam(pver) + real(r8) :: lammax + real(r8) :: lammin + real(r8) :: nacnt + real(r8) :: mnuccc(pver) + real(r8) :: nnuccc(pver) + + real(r8) :: mnucct(pver) + real(r8) :: nnucct(pver) + real(r8) :: msacwi(pver) + real(r8) :: nsacwi(pver) + + real(r8) :: prc(pver) + real(r8) :: nprc(pver) + real(r8) :: nprc1(pver) + real(r8) :: nsagg(pver) + real(r8) :: dc0 + real(r8) :: ds0 + real(r8) :: eci + real(r8) :: psacws(pver) + real(r8) :: npsacws(pver) + real(r8) :: uni + real(r8) :: umi + real(r8) :: uns(pver) + real(r8) :: ums(pver) + real(r8) :: unr(pver) + real(r8) :: umr(pver) + real(r8) :: unc + real(r8) :: umc + real(r8) :: pracs(pver) + real(r8) :: npracs(pver) + real(r8) :: mnuccr(pver) + real(r8) :: nnuccr(pver) + real(r8) :: pra(pver) + real(r8) :: npra(pver) + real(r8) :: nragg(pver) + real(r8) :: prci(pver) + real(r8) :: nprci(pver) + real(r8) :: prai(pver) + real(r8) :: nprai(pver) + real(r8) :: qvs + real(r8) :: qvi + real(r8) :: dqsdt + real(r8) :: dqsidt + real(r8) :: ab + real(r8) :: qclr + real(r8) :: abi,oneoabi + real(r8) :: epss + real(r8) :: epsr + real(r8) :: pre(pver) + real(r8) :: prds(pver) + real(r8) :: qce + real(r8) :: qie + real(r8) :: nce + real(r8) :: nie + real(r8) :: ratio + real(r8) :: dumc(pcols,pver) + real(r8) :: dumnc(pcols,pver) + real(r8) :: dumi(pcols,pver) + real(r8) :: dumni(pcols,pver) + real(r8) :: dums(pcols,pver) + real(r8) :: dumns(pcols,pver) + real(r8) :: dumr(pcols,pver) + real(r8) :: dumnr(pcols,pver) +! below are parameters for cloud water and cloud ice sedimentation calculations + real(r8) :: fr(pver) + real(r8) :: fnr(pver) + real(r8) :: fc(pver) + real(r8) :: fnc(pver) + real(r8) :: fi(pver) + real(r8) :: fni(pver) + real(r8) :: fs(pver) + real(r8) :: fns(pver) + real(r8) :: faloutr(pver) + real(r8) :: faloutnr(pver) + real(r8) :: faloutc(pver) + real(r8) :: faloutnc(pver) + real(r8) :: falouti(pver) + real(r8) :: faloutni(pver) + real(r8) :: falouts(pver) + real(r8) :: faloutns(pver) + real(r8) :: faltndr + real(r8) :: faltndnr + real(r8) :: faltndc + real(r8) :: faltndnc + real(r8) :: faltndi + real(r8) :: faltndni + real(r8) :: faltnds + real(r8) :: faltndns + real(r8) :: faltndqie + real(r8) :: faltndqce +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + real(r8) :: relhum(pcols,pver) + real(r8) :: csigma(pcols) + real(r8) :: rgvm + real(r8) :: arn(pcols,pver) + real(r8) :: asn(pcols,pver) + real(r8) :: acn(pcols,pver) + real(r8) :: ain(pcols,pver) + real(r8) :: nsubi(pver) + real(r8) :: nsubc(pver) + real(r8) :: nsubs(pver) + real(r8) :: nsubr(pver) + real(r8) :: mtime + real(r8) :: dz(pcols,pver) + +!fice variable + real(r8) :: nfice(pcols,pver) + +!add variables for rain and snow flux at layer interfaces + real(r8) :: rflx(pcols,pver+1) + real(r8) :: sflx(pcols,pver+1) + + real(r8) :: rflx1(pcols,pver+1) + real(r8) :: sflx1(pcols,pver+1) + +! returns from function/subroutine calls + real(r8) :: tsp(pcols,pver) + real(r8) :: qsp(pcols,pver) + real(r8) :: qsphy(pcols,pver) + real(r8) :: qs(pcols) + real(r8) :: es(pcols) + real(r8) :: esl(pcols,pver) + real(r8) :: esi(pcols,pver) +! real(r8) :: gammas(pcols) + +! sum of source/sink terms for diagnostic precip + + real(r8) :: qnitend(pcols,pver) + real(r8) :: nstend(pcols,pver) + real(r8) :: qrtend(pcols,pver) + real(r8) :: nrtend(pcols,pver) + real(r8) :: qrtot + real(r8) :: nrtot + real(r8) :: qstot + real(r8) :: nstot + +! new terms for Bergeron process + + real(r8) :: dumnnuc + real(r8) :: ninew + real(r8) :: qinew + real(r8) :: qvl + real(r8) :: epsi + real(r8) :: prd + real(r8) :: berg(pcols,pver) + real(r8) :: bergs(pver) + +!bergeron terms + real(r8) :: bergtsf + real(r8) :: rhin + +! diagnostic rain/snow for output to history +! values are in-precip (local) !!!! + + real(r8) :: qrout(pcols,pver) + real(r8) :: nrout(pcols,pver) + real(r8) :: nsout(pcols,pver) + real(r8) :: dsout(pcols,pver) + real(r8) :: qsout(pcols,pver) + + +!averageed rain/snow for history + real(r8) , intent(out) :: qrout2(pcols,pver) + real(r8) , intent(out) :: qsout2(pcols,pver) + real(r8) , intent(out) :: nrout2(pcols,pver) + real(r8) , intent(out) :: nsout2(pcols,pver) + real(r8) :: freqs(pcols,pver) + real(r8) :: freqr(pcols,pver) + real(r8) :: dumfice + real(r8), intent(out) :: drout2(pcols,pver) + real(r8) :: dsout2(pcols,pver) + +!ice nucleation, droplet activation + real(r8) :: dum2i(pcols,pver) + real(r8) :: dum2l(pcols,pver) + real(r8) :: ncmax(pcols,pver) + real(r8) :: nimax + +!output fields for number conc + real(r8) :: ncai(pcols,pver) + real(r8) :: ncal(pcols,pver) + +! loop array variables + integer i,k,nstep,n, l + integer ii,kk, m, ind_aux, km, kp + +! loop variables for sub-step solution + integer iter,it,ltrue(pcols) + +! used in contact freezing via dust particles + real(r8) tcnt, viscosity, mfp, nslipsoot, ndfaersoot + real(r8), dimension(nbincontactdust) :: ndfaer, nslip, slip + + +! used in ice effective radius + real(r8) bbi, cci, ak, iciwc, rvi, riter + +! used in Bergeron processe and water vapor deposition + real(r8) Tk, deles, Aprpr, Bprpr, Cice, qi0, Crate, qidep + +! mean cloud fraction over the time step + real(r8) cldmw(pcols,pver) + +! used in secondary ice production + real(r8) ni_secp + +! variabels to check for RH after rain evap + + real(r8) :: esn + real(r8) :: qsn + real(r8) :: ttmp + + + real(r8) :: refl(pcols,pver) + real(r8) :: rainrt(pcols,pver) + real(r8) :: rainrt1(pcols,pver) + real(r8) :: csrfl(pcols,pver) + real(r8) :: arefl(pcols,pver) + real(r8) :: acsrfl(pcols,pver) + real(r8) :: frefl(pcols,pver) + real(r8) :: fcsrfl(pcols,pver) + real(r8) :: areflz(pcols,pver) + real(r8) :: tmp, miu_ice(pver) + real(r8) :: cons16 + real(r8) :: cons17 + + real(r8) dmc,ssmc,dstrn + + real(r8), parameter :: cdnl = 0.e6_r8 + +! integer, parameter :: auto_option=3 ! dcrit only used with auto_option=4 +! integer, parameter :: auto_option=2 ! dcrit only used with auto_option=4 + integer, parameter :: auto_option=1 ! dcrit only used with auto_option=4 +! integer, parameter :: auto_option=4 ! dcrit only used with auto_option=4 + real(r8) :: beta6, xs, nssoot, nsdust, taux, psc, Bh, vaux, aux, + & LW, NW, tx1, tx2, tx3, tx4, tx5, omeps, esloesi + &, rdz, rdzi + + +! note: number will be adjusted as needed to keep mean size within bounds, +! even when cosntant droplet or ice number is used + +! ***note: Even if constant cloud ice number is set, ice number is allowed +! to evolve based on process rates. This is needed in order to calculate +! the change in mass due to ice nucleation. All other ice microphysical +! processes are consistent with the specified constant ice number if +! this switch is turned on. + + logical :: nccons,nicons + + + omeps = one - epsqs + + nccons = .false. + nicons = .false. +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +! initialize output fields for number conc qand ice nucleation + do k=1,pver + miu_ice(k) = zero + enddo + do k=1,pver + do i=1,ncol + ncai(i,k) = zero + ncal(i,k) = zero + +!Initialize rain size + rercld(i,k) = zero + arcld(i,k) = zero + +!initialize radiation output variables + pgamrad(i,k) = zero + lamcrad(i,k) = zero + deffi (i,k) = zero +!initialize radiation output variables +!initialize water vapor tendency term output + qcsevap(i,k) = zero + qisevap(i,k) = zero + qvres (i,k) = zero + cmeiout (i,k) = zero + vtrmc (i,k) = zero + vtrmi (i,k) = zero + qcsedten (i,k) = zero + qisedten (i,k) = zero + + prao(i,k) = zero + prco(i,k) = zero + + mnuccco(i,k) = zero + mnuccto(i,k) = zero + msacwio(i,k) = zero + psacwso(i,k) = zero + bergso(i,k) = zero + bergo(i,k) = zero + melto(i,k) = zero + homoo(i,k) = zero + qcreso(i,k) = zero + prcio(i,k) = zero + praio(i,k) = zero + qireso(i,k) = zero + mnuccro(i,k) = zero + pracso (i,k) = zero + meltsdt(i,k) = zero + frzrdt (i,k) = zero + mnuccdo(i,k) = zero + nnuccto(i,k) = zero + + + nnuccdo(i,k) = zero + nnuccco(i,k) = zero + nsacwio(i,k) = zero + nsubio(i,k) = zero + nprcio(i,k) = zero + npraio(i,k) = zero + + npccno(i,k) = zero + npsacwso(i,k) = zero + nsubco(i,k) = zero + nprao(i,k) = zero + nprc1o(i,k) = zero + enddo + enddo + +! assign variable deltat for sub-stepping... + deltat = deltatin + dti = one / deltat + deltam = one / max(deltat, 150.0_r8) + +! parameters for scheme + +! omsm = 0.99999_r8 + omsm = 0.99999999_r8 + dto2 = 0.5_r8*deltat + mincld = 0.00001_r8 + +! initialize time-varying parameters + + do k=1,pver + do i=1,ncol + +! initialize multi-level fields + t(i,k) = tn(i,k) + q(i,k) = qn(i,k) + rho(i,k) = p(i,k) / (r*t(i,k)) + irho(i,k) = one / rho(i,k) + dv(i,k) = 8.794E-5_r8*t(i,k)**1.81_r8/p(i,k) + tx1 = t(i,k) * sqrt(t(i,k)) / (t(i,k)+120._r8) + mu(i,k) = 1.496E-6_r8 * tx1 + sc(i,k) = mu(i,k)/(rho(i,k)*dv(i,k)) + kap(i,k) = 1.414e3_r8 * 1.496e-6_r8 * tx1 + +! air density adjustment for fallspeed parameters +! includes air density correction factor to the +! power of 0.54 following Heymsfield and Bansemer 2007 + + rhof(i,k) = (rhosu*irho(i,k))**0.54 + + arn(i,k) = ar * rhof(i,k) + asn(i,k) = as * rhof(i,k) + acn(i,k) = ac * rhof(i,k) + ain(i,k) = ai * rhof(i,k) + +! get dz from dp and hydrostatic approx +! keep dz positive (define as layer k-1 - layer k) + + dz(i,k) = pdel(i,k) * irho(i,k) * ginv + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! droplet activation +! hm, modify 5/12/11 +! get provisional droplet number after activation. This is used for +! all microphysical process calculations, for consistency with update of +! droplet mass before microphysics + +! calculate potential for droplet activation if cloud water is present +! tendency from activation (npccnin) is read in from companion routine + +! hm note: npccn is no longer needed below this code - so this can +! be rewwritten and this parameters can be removed + + lcldm(i,k) = max(liqcldf(i,k),mincld) + if (qc(i,k) >= qsmall) then + npccn(i,k) = max( (lcldm(i,k)*npccnin(i,k)-nc(i,k)) + & * deltam, zero) + ncold(i,k) = nc(i,k) + nc(i,k) = nc(i,k) + npccn(i,k)*deltat + else + npccn(i,k) = zero + end if + +! initialization + t1(i,k) = t(i,k) + q1(i,k) = q(i,k) + qc1(i,k) = qc(i,k) + qi1(i,k) = qi(i,k) + nc1(i,k) = nc(i,k) + ni1(i,k) = ni(i,k) + +! initialize tendencies to zero + tlat1(i,k) = zero + tlat1_aux(i,k) = zero + + qvlat1(i,k) = zero + qctend1(i,k) = zero + qitend1(i,k) = zero + nctend1(i,k) = zero + nitend1(i,k) = zero + +! initialize precip output + qrout(i,k) = zero + qsout(i,k) = zero + nrout(i,k) = zero + nsout(i,k) = zero + dsout(i,k) = zero + +! initialize variables for trop_mozart + nevapr(i,k) = zero + evapsnow(i,k) = zero + prain(i,k) = zero + prodsnow(i,k) = zero + cmeout(i,k) = zero + +! for refl calc + rainrt1(i,k) = zero + +! initialize precip fraction and output tendencies + cldmax(i,k) = mincld + +!initialize aerosol number +! naer2(i,k,:) = zero + dum2l(i,k) = zero + dum2i(i,k) = zero + ncmax(i,k) = zero + +! for debug purpose +! prect(1:ncol)=0._r8 +! preci(1:ncol)=0._r8 +! tlat(1:ncol,1:pver)=0._r8 +! qvlat(1:ncol,1:pver)=0._r8 +! qctend(1:ncol,1:pver)=0._r8 +! qitend(1:ncol,1:pver)=0._r8 +! nctend(1:ncol,1:pver)=0._r8 + + enddo + enddo + +! initialize avg precip rate + do i=1,ncol + prect1(i) = zero + preci1(i) = zero + end do +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!Get humidity and saturation vapor pressures big loop1 + + do k=1,pver + +! find wet bulk temperature and saturation value for provisional t and q without +! condensation + +! call vqsatd_water(t(1,k),p(1,k),es,qs,gammas,ncol) + + do i=1,ncol + +#ifdef NEMS_GSM + esl(i,k) = min(fpvsl(t(i,k)), p(i,k)) + esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) +#else + esl(i,k) = min(polysvp(t(i,k),0), p(i,k)) + esi(i,k) = min(polysvp(t(i,k),1), p(i,k)) +#endif + + esloesi = esl(i,k) / esi(i,k) +! hm fix, make sure when above freezing that esi=esl, not active yet + if (t(i,k) > tmelt) esi(i,k) = esl(i,k) + + qs(i) = epsqs*esl(i,k)/(p(i,k)-omeps*esl(i,k)) + + relhum(i,k) = min(q(i,k)/qs(i), one) !Anning limiting relhum + +! if (lprint .and. k==29) write(0,*)' esl=',esl(i,k) +! &,' esi=',esi(i,k),' pres=',p(i,k),' t=',t(i,k) +! &,' relhum=',relhum(i,k),' q=',q(i,k),' qs=',qs(i) + +! get cloud fraction, check for minimum + + cldm(i,k) = max(cldn(i,k), mincld) + cldmw(i,k) = max(cldn(i,k), mincld) + + icldm(i,k) = max(icecldf(i,k), mincld) + lcldm(i,k) = max(liqcldf(i,k), mincld) + + + if (qc(i,k) >= qsmall) then + tx1 = one / lcldm(i,k) + dum2l(i,k) = (ncold(i,k)+npccn(i,k)*deltat) * tx1 + dum2l(i,k) = max(dum2l(i,k),cdnl*irho(i,k)) + ncmax(i,k) = max(dum2l(i,k)*lcldm(i,k), zero) + dum2l(i,k) = npccn(i,k)*deltat*tx1 + else + dum2l(i,k) = zero + end if + + + +! calculate nfice based on liquid and ice mmr (no rain and snow mmr available yet) + + nfice(i,k) = zero + dumfice = qc(i,k) + qi(i,k) + if (dumfice > qsmall .and. qi(i,k) > qsmall) then + nfice(i,k) = qi(i,k)/dumfice + endif + + if (t(i,k) < tmelt - five) then + if (liu_in) then + +! if aerosols interact with ice set number of activated ice nuclei + dum2 = naai(i,k) + + else +! cooper curve (factor of 1000 is to convert from L-1 to m-3) + dum2 = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k)))*1000._r8 +! put limit on number of nucleated crystals, set to number at T=-30 C +! cooper (limit to value at -35 C) + dum2 = min(dum2, 208.9e3_r8)*irho(i,k) + endif + + dumnnuc = max((dum2*icldm(i,k)-ni(i,k))*deltam, zero) + + +! get provisional ni and qi after nucleation in order to calculate +! Bergeron process below + ninew = ni(i,k) + dumnnuc*deltat + qinew = qi(i,k) + dumnnuc*deltat*mi0 +!T>268 + else + ninew = ni(i,k) + qinew = qi(i,k) + end if + +! Initialize CME components + + cme(i,k) = zero + cmei(i,k) = zero + + +!------------------------------------------------------------------- +!Bergeron process +! make sure to initialize bergeron process to zero + berg(i,k) = zero + prd = zero + +!condensation loop. + +! get in-cloud qi and ni after nucleation + if (icldm(i,k) > zero) then + tx1 = one / icldm(i,k) + qiic(i,k) = qinew * tx1 + niic(i,k) = ninew * tx1 + else + qiic(i,k) = zero + niic(i,k) = zero + endif + + + if (nicons) then + niic(i,k) = ninst*irho(i,k) + end if + + + +!if T < 0 C then bergeron. + if (t(i,k) < 273.15) then +!if ice exists + if (qi(i,k) > qsmall) then + + bergtsf = zero + + qvi = epsqs*esi(i,k) / (p(i,k)-omeps*esi(i,k)) + qvl = epsqs*esl(i,k) / (p(i,k)-omeps*esl(i,k)) + + dqsidt = xxls*qvi / (rv*t(i,k)*t(i,k)) + abi = one + dqsidt*xxls/cpp + oneoabi = one / abi + +! get ice size distribution parameters + + if (qiic(i,k) >= qsmall) then + + lami(k) = (cons1*ci*niic(i,k)/qiic(i,k))**oneodi + +! miu_ice=mui_hemp_l(lami(k)) + miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, + & 10.0_r8), 0.1_r8) + tx1 = one + miu_ice(k) + tx2 = one / gamma(tx1) + aux = (gamma(tx1+di)*tx2) ** oneodi + lami(k) = aux*lami(k) + n0i(k) = niic(i,k) * lami(k)**tx1 * tx2 + + +! check for slope +! adjust vars + if (lami(k) < lammini*aux) then + miu_ice(k) = zero + lami(k) = lammini + n0i(k) = lami(k)**(di+one)*qiic(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + else if (lami(k) > lammaxi*aux) then + miu_ice(k) = zero + lami(k) = lammaxi + n0i(k) = lami(k)**(di+one)*qiic(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + end if + + epsi = (miu_ice(k)+two)*(miu_ice(k)+one)*pi* + & niic(i,k)*rho(i,k)*Dv(i,k)/lami(k) + +!if liquid exists + if (qc(i,k) > qsmall) then + +!begin bergeron process +! do bergeron (vapor deposition with RHw=1) +! code to find berg (a rate) goes here + +! calculate Bergeron process + + prd = epsi*(qvl-qvi)*oneoabi + + else + prd = zero + end if + +! multiply by cloud fraction and transfer of existing cloud liquid to ice + + berg(i,k) = max(zero, prd*min(icldm(i,k),lcldm(i,k))) + + end if ! qiic(i,k) >= qsmall + + + if (berg(i,k) > zero) then + tx1 = qc(i,k) * dti + bergtsf = max(zero, tx1/berg(i,k)) + if(bergtsf < one) berg(i,k) = max(zero, tx1) + endif + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (bergtsf < one .or. icldm(i,k) > lcldm(i,k)) then + + if (qiic(i,k) >= qsmall) then + +! first case is for case when liquid water is present, but is completely depleted in time step, i.e., bergrsf > 0 but < 1 + + if (qc(i,k) >= qsmall) then + rhin = (one + relhum(i,k)) * half + if (rhin*esloesi > one) then + prd = epsi*(rhin*qvl-qvi)*oneoabi + +! multiply by cloud fraction assuming liquid/ice maximum overlap and add to cmei + cmei(i,k) = cmei(i,k) + & + prd * min(icldm(i,k),lcldm(i,k)) + & * (one- bergtsf) +! if (lprint .and. k == 29) write(0,*)' cmei1=',cmei(i,k), +! &' prd=',prd,' bergtsf=',bergtsf + + end if + end if + +! moved here by Moorthi +! note: for case of no liquid, need to set liquid cloud fraction to zero +! store liquid cloud fraction in 'dum' + if (qc(i,k) < qsmall) then + dum = zero + else + dum = lcldm(i,k) + end if + +! second case is for pure ice cloud, either no liquid, or icldm > lcldm + if (qc(i,k) < qsmall) then + +! note: for case of no liquid, need to set liquid cloud fraction to zero +! store liquid cloud fraction in 'dum' + +!Moorthi if (qc(i,k) < qsmall) then +! dum = 0._r8 +! else +! dum = lcldm(i,k) +! end if + +! set RH to grid-mean value for pure ice cloud + rhin = relhum(i,k) + + if (rhin*esloesi > one) then + + prd = epsi*(rhin*qvl-qvi)*oneoabi + +! multiply by relevant cloud fraction for pure ice cloud +! assuming maximum overlap of liquid/ice + cmei(i,k) = cmei(i,k) + & + prd * max((icldm(i,k)-dum), zero) +! if (lprint .and. k == 29) write(0,*)' cmei2=',cmei(i,k), +! &' prd=',prd,' icldm=',icldm(i,k),' dum=',dum + + end if + end if + end if + end if + +! if deposition, it should not reduce grid mean rhi below 1.0 + if(cmei(i,k) > zero .and. relhum(i,k)*esloesi > one) + & cmei(i,k) = min(cmei(i,k),(q(i,k)-qs(i)/esloesi) + & * oneoabi * dti) + +! if (lprint .and. k == 29) write(0,*)' cmei3=',cmei(i,k) + + end if ! if (qi(i,k) > qsmall) + + +!------------------------------------------------------------------- + end if +!.............................................................. + +! evaporation should not exceed available water + + tx1 = qc(i,k)*dti + if (-berg(i,k) < -tx1) berg(i,k) = max(tx1, zero) ! is this correct????? + +! berg(i,k) = min(berg(i,k), qc(i,k)/deltat) ! Moorthi - ask anning + +!sublimation process... + + if (relhum(i,k)*esloesi < one .and. + & qiic(i,k) >= qsmall ) then + + qvi = epsqs*esi(i,k)/(p(i,k)-omeps*esi(i,k)) + qvl = epsqs*esl(i,k)/(p(i,k)-omeps*esl(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)*t(i,k)) + abi = one + dqsidt*xxls/cpp + oneoabi = one / abi + +! get ice size distribution parameters + + lami(k) = (cons1*ci*niic(i,k)/qiic(i,k))**oneodi + +! miu_ice(k)=mui_hemp_l(lami(k)) + miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, + & 10.0_r8), 0.1_r8) + tx1 = one + miu_ice(k) + tx2 = one / gamma(tx1) + aux = (gamma(tx1+di) * tx2) ** oneodi + lami(k) = aux*lami(k) + + n0i(k) = niic(i,k) * lami(k)**tx1 * tx2 +! check for slope +! adjust vars + if (lami(k) < lammini*aux) then + miu_ice(k) = zero + lami(k) = lammini + n0i(k) = lami(k)**(di+one)*qiic(i,k)/(ci*cons1) + else if (lami(k) > lammaxi*aux) then + miu_ice(k) = zero + lami(k) = lammaxi + n0i(k) = lami(k)**(di+one)*qiic(i,k)/(ci*cons1) + end if + + epsi = (miu_ice(k)+two)*(miu_ice(k)+one)*pi* + & niic(i,k)*rho(i,k)*Dv(i,k) / lami(k) + +! modify for ice fraction below + prd = epsi*(relhum(i,k)*qvl-qvi)*oneoabi * icldm(i,k) + cmei(i,k) = min(prd, zero) + +! if (lprint .and. k == 29) write(0,*)' cmei3a=',cmei(i,k) +! &,' prd=',prd + endif + +! sublimation should not exceed available ice + + cmei(i,k) = max(cmei(i,k), -qi(i,k)*dti) + +! if (lprint .and. k == 29) write(0,*)' cmei3b=',cmei(i,k) +! &,' qi=',qi(i,k),' deltat=',deltat + +! sublimation should not increase grid mean rhi above 1.0 + if(cmei(i,k) < zero .and. relhum(i,k)*esloesi < one) + & cmei(i,k) = min(zero, max(cmei(i,k),(q(i,k)-qs(i) + & /esloesi) * oneoabi * dti )) +! if (lprint .and. k == 29) write(0,*)' cmei3c=',cmei(i,k) +! &,' q=',q(i,k),' qs=',qs(i),' esi=',esi(i,k) +! &,' esl=',esl(i,k),' abi=',abi + +! limit cmei due for roundoff error + + cmei(i,k) = cmei(i,k)*omsm +! if (lprint .and. k == 29) write(0,*)' cmei4=',cmei(i,k), +! &' omsm=',omsm + +! conditional for ice nucleation + + if (t(i,k) < (tmelt - five)) then + if ( liu_in ) then + +! using Liu et al. (2007)/Barahona & Nenes (2009) ice nucleation with hooks into simulated aerosol +! ice nucleation rate (dum2) has already been calculated and read in (naai) + + dum2i(i,k) = naai(i,k) + else + +! cooper curve (factor of 1000 is to convert from L-1 to m-3) + dum2i(i,k) = 0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k))) + & * 1000._r8 +! put limit on number of nucleated crystals, set to number at T=-30 C +! cooper (limit to value at -35 C) + dum2i(i,k) = min(dum2i(i,k),208.9e3_r8)*irho(i,k) + endif + else + dum2i(i,k) = zero + end if + + end do ! end big i loop + end do !end big loop1 - k loop + +!! + do i=1,ncol + rflx1(i,1) = zero ! initialize sub-step precip flux variables + sflx1(i,1) = zero + + rflx(i,1) = zero ! initialize final precip flux variables. + sflx(i,1) = zero + ltrue(i) = 0 + end do + do k=1,pver + do i=1,ncol + cldo(i,k) = cldn(i,k) + + rflx1(i,k+1) = zero ! initialize sub-step precip flux variables + sflx1(i,k+1) = zero + + rflx(i,k+1) = zero ! initialize final precip flux variables. + sflx(i,k+1) = zero + +! skip microphysical calculations if no cloud water + + if ((qc(i,k) >= qsmall .or. qi(i,k) >= qsmall .or. + & cmei(i,k) >= qsmall).and.q(i,k)>=qvsmall) ltrue(i) = 1 + + rate1ord_cw2pr_st(i,k) = zero + end do + end do +!! + + +! assign number of sub-steps to iter +! use 2 sub-steps, following tests described in MG2008 +! Anning Cheng 9/17/2016 + if(fprcp==1) then + iter = 1 + else + iter = 2 + end if + + riter = one / float(iter) +! get sub-step time step + deltat = deltat * riter + dti = one / deltat + +! since activation/nucleation processes are fast, need to take into account +! factor mtime = mixing timescale in cloud / model time step +! mixing time can be interpreted as cloud depth divided by sub-grid vertical velocity +! for now mixing timescale is assumed to be 1 timestep for modal aerosols, 20 min bulk + +! note: mtime for bulk aerosols was set to: mtime=deltat/1200._r8 + + mtime = one + +!!!! skip calculations if no cloud water + + do i=1,ncol !big i loop2 + if (ltrue(i) == 0) then + prect(i) = zero + preci(i) = zero + do k=1,pver + tlat(i,k) = zero + qvlat(i,k) = zero + qctend(i,k) = zero + qitend(i,k) = zero + qnitend(i,k) = zero + qrtend(i,k) = zero + nctend(i,k) = zero + nitend(i,k) = zero + nrtend(i,k) = zero + nstend(i,k) = zero + qniic(i,k) = zero + qric(i,k) = zero + nsic(i,k) = zero + nric(i,k) = zero + rainrt(i,k) = zero + enddo + + else + + do k=1,pver + qcsinksum_rate1ord(k) = zero + qcsum_rate1ord(k) = zero + enddo + + +!!!!!!!!! begin sub-step!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!..................................................................................................... + do it=1,iter ! big iter loop + +! initialize sub-step microphysical tendencies + + do k=1,pver + tlat(i,k) = zero + qvlat(i,k) = zero + qctend(i,k) = zero + qitend(i,k) = zero + qnitend(i,k) = zero + qrtend(i,k) = zero + nctend(i,k) = zero + nitend(i,k) = zero + nrtend(i,k) = zero + nstend(i,k) = zero + +! initialize diagnostic precipitation to zero + + qniic(i,k) = zero + qric(i,k) = zero + nsic(i,k) = zero + nric(i,k) = zero + + rainrt(i,k) = zero + + enddo + + +! begin new i,k loop, calculate new cldmax after adjustment to cldm above + +! initialize vertically-integrated rain and snow tendencies + + qrtot = zero + nrtot = zero + qstot = zero + nstot = zero + +! initialize precip at surface + + prect(i) = zero + preci(i) = zero + + do k=1,pver + + km = k - 1 +! set cwml and cwmi to current qc and qi + + cwml(i,k) = qc(i,k) + cwmi(i,k) = qi(i,k) + +! initialize precip fallspeeds to zero + + ums(k) = zero + uns(k) = zero + umr(k) = zero + unr(k) = zero + +! calculate precip fraction based on maximum overlap assumption + + if (k == 1) then + cldmax(i,k) = cldm(i,k) + else +! if rain or snow mix ratio is smaller than +! threshold, then set cldmax to cloud fraction at current level + if (qric(i,km) >= qsmall .or. + & qniic(i,km) >= qsmall) then + cldmax(i,k) = max(cldmax(i,km),cldm(i,k)) + else + cldmax(i,k) = cldm(i,k) + end if + end if + + rdz = rho(i,k) * dz(i,k) + rdzi = one / rdz + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +! ice nucleation if activated nuclei exist at t<-5C AND rhmini + 5% + + if (dum2i(i,k) > zero .and. t(i,k) < (tmelt-five) .and. + & relhum(i,k)*esl(i,k)/esi(i,k) > rhmini+0.05_r8) then + +!if NCAI > 0. then set numice = ncai (as before) +!note: this is gridbox averaged + + nimax = dum2i(i,k)*icldm(i,k) +! nnuccd(k) = (dum2i(i,k)-ni(i,k)/icldm(i,k))/deltat*icldm(i,k) + nnuccd(k) = max(zero, (nimax-ni(i,k))*dti) + +!Calc mass of new particles using new crystal mass... +!also this will be multiplied by mtime as nnuccd is... + + mnuccd(k) = nnuccd(k) * mi0 + +! add mnuccd to cmei.... + cmei(i,k)= cmei(i,k) + mnuccd(k) * mtime + +! if (lprint .and. k == 29) write(0,*)' cmei5=',cmei(i,k) + +! limit cmei + + qvi = epsqs*esi(i,k)/(p(i,k)-omeps*esi(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)*t(i,k)) + abi = one + dqsidt*xxls/cpp + cmei(i,k) = min(cmei(i,k),(q(i,k)-qvi)/(abi*deltat)) + +! limit for roundoff error + cmei(i,k) = cmei(i,k)*omsm + +! if (lprint .and. k == 29) write(0,*)' cmei6=',cmei(i,k) + else + nnuccd(k) = zero + nimax = zero + mnuccd(k) = zero + end if + + +!c............................................................................ +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! obtain in-cloud values of cloud water/ice mixing ratios and number concentrations +! for microphysical process calculations +! units are kg/kg for mixing ratio, 1/kg for number conc + +! limit in-cloud values to 0.005 kg/kg + + tx1 = one / lcldm(i,k) + tx2 = one / icldm(i,k) + qcic(i,k) = min(cwml(i,k)*tx1, 5.e-3_r8) + qiic(i,k) = min(cwmi(i,k)*tx2, 5.e-3_r8) + ncic(i,k) = max(nc(i,k)*tx1, zero) + niic(i,k) = max(ni(i,k)*tx2, zero) + + + if (nccons) then + ncic(i,k) = ncnst*irho(i,k) + end if + + if (nicons) then + niic(i,k) = ninst*irho(i,k) + end if + + tx1 = qc(i,k) - berg(i,k)*deltat + if (tx1 < qsmall) then + qcic(i,k) = zero + ncic(i,k) = zero + if (tx1 < zero) then + berg(i,k) = qc(i,k)*dti*omsm + end if + end if + + tx1 = qi(i,k) + (cmei(i,k)+berg(i,k))*deltat + if (tx1 < qsmall) then + qiic(i,k) = zero + niic(i,k) = zero + if (tx1 < zero) then + cmei(i,k) = (-qi(i,k)*dti-berg(i,k))*omsm +! if (lprint .and. k == 29) write(0,*)' cmei7=',cmei(i,k) + end if + end if + +! add to cme output + + cmeout(i,k) = cmeout(i,k) + cmei(i,k) + +! decrease in number concentration due to sublimation/evap +! divide by cloud fraction to get in-cloud decrease +! don't reduce Nc due to bergeron process + +!Moved it here since nsubi since cmei was not limited before(DONIF 03/13/2015) + if (cmei(i,k) < zero .and. qi(i,k) > qsmall + & .and. cldm(i,k) > mincld) then + nsubi(k) = cmei(i,k)*ni(i,k) / (qi(i,k)*cldm(i,k)) + else + nsubi(k) = zero + end if + + nsubc(k) = zero + + + + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! get size distribution parameters based on in-cloud cloud water/ice +! these calculations also ensure consistency between number and mixing ratio +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +!...................................................................... +! cloud ice + + if (qiic(i,k) >= qsmall) then + +! add upper limit to in-cloud number concentration to prevent numerical error + niic(i,k) = min(niic(i,k),qiic(i,k)*1.e20_r8) + + + lami(k) = (cons1*ci*niic(i,k)/qiic(i,k))**oneodi + +! miu_ice(k)=mui_hemp_l(lami(k)) + miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, + & 10.0_r8), 0.1_r8) + tx1 = one + miu_ice(k) + tx2 = one / gamma(tx1) + aux = (gamma(tx1+di) * tx2) **oneodi + lami(k) = aux*lami(k) + + n0i(k) = niic(i,k)*lami(k)**tx1 * tx2 + +! check for slope +! adjust vars + + if (lami(k) < lammini) then + lami(k) = lammini + n0i(k) = lami(k)**(di+one)*qiic(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + else if (lami(k) > lammaxi) then + lami(k) = lammaxi + n0i(k) = lami(k)**(di+one)*qiic(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + end if + + else + lami(k) = zero + n0i(k) = zero + end if + + if (qcic(i,k) >= qsmall) then + +! add upper limit to in-cloud number concentration to prevent numerical error + ncic(i,k) = min(ncic(i,k),qcic(i,k)*1.e20_r8) + + ncic(i,k) = max(ncic(i,k),cdnl*irho(i,k)) + +! get pgam from fit to observations of martin et al. 1994 + + pgam(k) = 0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k)) + & + 0.2714_r8 + + + if (.true.) then + if ((ncic(i,k) > 1.0e-3) .and. + & (qcic(i,k) > 1.0e-11)) then + xs = 0.07_r8*(1000._r8*qcic(i,k)/ncic(i,k)) + & **(-0.14_r8) + else + xs = 1.2 + end if + + xs = max(min(xs, 1.7_r8), 1.1_r8) + xs = xs*xs*xs + xs = (xs + sqrt(xs+8.0_r8)*sqrt(xs) - four)/8.0_r8 + pgam(k) = sqrt(xs) + + end if + + + + pgam(k) = one / (pgam(k)*pgam(k)) - one + pgam(k) = max(two, min(15._r8, pgam(k))) + + +! calculate lamc + tx1 = pirhow * gamma(pgam(k)+four) + tx3 = gamma(pgam(k)+one) + tx2 = 6._r8 * qcic(i,k) * tx3 + + lamc(k) = (tx1*ncic(i,k)/tx2) ** oneb3 + +! lammin, 50 micron diameter max mean size + + lammin = (pgam(k)+one) / 50.e-6_r8 + lammax = (pgam(k)+one) / 2.e-6_r8 + + if (lamc(k) < lammin) then + lamc(k) = lammin + ncic(i,k) = tx2*lamc(k)*lamc(k)*lamc(k) / tx1 + else if (lamc(k) > lammax) then + lamc(k) = lammax + ncic(i,k) = tx2*lamc(k)*lamc(k)*lamc(k) / tx1 + end if + +! parameter to calculate droplet freezing + + cdist1(k) = ncic(i,k) / tx3 + + else + lamc(k) = zero + cdist1(k) = zero + end if + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! begin micropysical process calculations +!................................................................. +! autoconversion of cloud liquid water to rain +! formula from Khrouditnov and Kogan (2000), modified for sub-grid distribution of qc +! minimum qc of 1 x 10^-8 prevents floating point error + + xs = 0.0 + + if (qcic(i,k) >= 1.e-8_r8) then + +! nprc is increase in rain number conc due to autoconversion +! nprc1 is decrease in cloud droplet conc due to autoconversion + +! assume exponential sub-grid distribution of qc, resulting in additional +! factor related to qcvar below + + +! prc(k) = cons2/(cons3*cons18)*1350._r8 +! & * qcic(i,k)**2.47_r8 +! & * (1.e-6_r8*ncic(i,k)*rho(i,k))**(-1.79_r8) + + if (auto_option == 1) then + + tx1 = qcic(i,k)*rho(i, k)/3.0e-4 + prc(k) = 1.0e-3 * qcic(i,k) * (one-exp(-tx1*tx1)) + & * gamma(one+qcvar)/(cons3*qcvar) + + elseif (auto_option == 2) then + + tx1 = qcic(i,k)*rho(i, k)/7.5e-4 + tx1 = tx1 * tx1 + prc(k) = 1.0e-4 * qcic(i,k) * (one-exp(-tx1*tx1)) + & * gamma(one+qcvar)/(cons3*qcvar) + + elseif (auto_option == 3) then + + tx1 = qcic(i,k) / 3.0e-4 + + prc(k) = 1.0e-3 * (one-EXP(-tx1*tx1)) + & * cons2/(cons3*cons18) + & / (1.e-6_r8/50.0*ncic(i,k)*rho(i,k))**1.79_r8 + + elseif (auto_option == 4) then + + xs = one / (one+pgam(k)) + + beta6 = (one+3.0*xs)*(one+4.0*xs)*(one+5.0*xs) + & / ((one+xs)*(one+xs+xs)) + + LW = 1.0e-3_r8 * qcic(i,k) * rho(i,k) + NW = ncic(i,k) * rho(i,k) * 1.e-6_r8 + + xs = min(20.0, 1.03e16*(LW*LW)/(NW*SQRT(NW))) + prc(k) = 1.1e10*beta6*LW*LW*LW + & * (one-exp(-(xs**miu_disp))) / NW + prc(k) = prc(k)*1.0e3*irho(i,k) + prc(k) = prc(k) * gamma(two+qcvar) + & / (gamma(qcvar)*(qcvar*qcvar)) + + prc(k) = prc(k)*dcrit + + xs = 1/xs + else + prc(k) = cons2/(cons3*cons18)*1350._r8 + & * qcic(i,k)**2.47_r8 + & * (1.e-6_r8*ncic(i,k)*rho(i,k))**(-1.79_r8) + endif + + nprc(k) = prc(k)/cons22 + + nprc1(k) = ncic(i,k)*prc(k) / (qcic(i,k)*(one+xs)) + + else + prc(k) = zero + nprc(k) = zero + nprc1(k) = zero + endif + + + +! add autoconversion to precip from above to get provisional rain mixing ratio +! and number concentration (qric and nric) + +! 0.45 m/s is fallspeed of new rain drop (80 micron diameter) + + if(fprcp==1) then + qric(i,k) = min(qrn(i,k)/lcldm(i,k), 5.e-3_r8) + nric(i,k) = max(nrn(i,k)/lcldm(i,k), zero) + else + dum = 0.45_r8 + dum1 = 0.45_r8 + + if (k == 1) then + tx1 = lcldm(i,k)*dz(i,k)/(cldmax(i,k)*dum) + qric(i,k) = prc(k) * tx1 + nric(i,k) = nprc(k) * tx1 + else + if (qric(i,km) >= qsmall) then +! dum=umr(k-1) +! dum1=unr(k-1) +! Anning Cheng find a possible untable case here + dum = max(umr(km),dum) + dum1 = max(unr(km),dum1) + endif + +! no autoconversion of rain number if rain/snow falling from above +! this assumes that new drizzle drops formed by autoconversion are rapidly collected +! by the existing rain/snow particles from above + + if (qric(i,km) >= 1.e-9_r8 .or. + & qniic(i,km) >= 1.e-9_r8) then + nprc(k) = zero + endif + + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) + qric(i,k) = (tx1*umr(km)*qric(i,km) + & + (rdz*((pra(km)+prc(k))*lcldm(i,k) + & + (pre(km)-pracs(km)-mnuccr(km))*cldmax(i,k)))) + & / (dum*tx3) + + +! nric(i,k) = (rho(i,k-1)*unr(k-1)*nric(i,k-1)*cldmax(i,k-1)+ +! & (rho(i,k)*dz(i,k)*(nprc(k)*lcldm(i,k)+(nsubr(k-1)-npracs(k-1)- +! &nnuccr(k-1)+nragg(k-1))*cldmax(i,k)))) /(dum1*rho(i,k)*cldmax(i, +! &k)) + +! Anning nsubr never given a value before + nric(i,k) = (tx1*unr(km)*nric(i,km) + & + (rdz*(nprc(k)*lcldm(i,k) + & +(-npracs(km)-nnuccr(km)+nragg(km))*cldmax(i,k)))) + & / (dum1*tx3) + + endif + endif !fprcp + +!....................................................................... +! Autoconversion of cloud ice to snow (Ice_aut) +! similar to Ferrier (1994) + + if (t(i,k) <= 273.15_r8 .and. qiic(i,k) >= qsmall) then + +! note: assumes autoconversion timescale of 180 sec +!vaux = 180.0_r8*10.0_r8 + + if (.false.) then + vaux = ts_auto_ice * 10.0_r8 + + nprci(k) = (niic(i, k)/vaux)*exp(-lami(k)*dcs) + tx1 = one / lami(k) + tx2 = tx1 * tx1 + prci(k) = pi*irho(i,k)*niic(i,k)*lami(k) + & / (6._r8*vaux) + & * (cons23*tx1+three*cons24*tx2 + & + 6._r8*dcs*tx1*tx2+6._r8*tx2*tx2) + & * exp(-lami(k)*dcs) + + else + +! miu_ice(k) = mui_hemp_l(lami(k)) + miu_ice(k) =max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, + & 10.0_r8), 0.1_r8) + tx1 = lami(k)*dcs + nprci(k) = (niic(i,k)/ts_auto_ice) + & * (one - gamma_incomp(miu_ice(k), tx1)) + + prci(k) = (qiic(i,k)/ts_auto_ice) + & * (one - gamma_incomp(miu_ice(k)+three, tx1)) + + end if + else + prci(k) = zero + nprci(k) = zero + end if + + +! add autoconversion to flux from level above to get provisional snow mixing ratio +! and number concentration (qniic and nsic) +! Anning Cheng 9/16/2016 forecasting rain and snow, corresponding to MG2 + if(fprcp==1) then + qniic(i,k) = min(qsnw(i,k)/icldm(i,k), 5.e-3_r8) + nsic(i,k) = max(nsnw(i,k)/icldm(i,k), 0._r8) + else + + dum = (asn(i,k)*cons25) + dum1 = (asn(i,k)*cons25) + + if (k == 1) then + tx1 = icldm(i,k)*dz(i,k)/(cldmax(i,k)*dum) + qniic(i,k) = prci(k) * tx1 + nsic(i,k) = nprci(k) * tx1 + else + if (qniic(i,km) >= qsmall) then + dum = ums(km) + dum1 = uns(km) + end if + + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) + qniic(i,k) = (tx1*ums(km)*qniic(i,km) + (rdz* + & ((prci(k)+prai(km)+psacws(km)+bergs(km))*icldm(i,k) + & +(prds(km)+pracs(km)+mnuccr(km))*cldmax(i,k)))) + & / (dum*tx3) + +! nsic(i,k) = (rho(i,k-1)*uns(k-1)*nsic(i,k-1)*cldmax(i,k-1)+ +! & (rho(i,k)*dz(i,k)*(nprci(k)*icldm(i,k)+(nsubs(k-1)+nsagg(k-1)+ +! &nnuccr(k-1))*cldmax(i,k)))) /(dum1*rho(i,k)*cldmax(i,k)) + +! nsubs never given a value before + nsic(i,k) = (tx1*uns(km)*nsic(i,km) + & + (rdz*(nprci(k)*icldm(i,k)+(nsagg(km) + & + nnuccr(km))*cldmax(i,k)))) /(dum1*tx3) + + end if + end if !fprcp + +! if precip mix ratio is zero so should number concentration + + if (qniic(i,k) < qsmall) then + qniic(i,k) = zero + nsic(i,k) = zero + end if + + if (qric(i,k) < qsmall) then + qric(i,k) = zero + nric(i,k) = zero + end if + +! make sure number concentration is a positive number to avoid +! taking root of negative later + + nric(i,k) = max(nric(i,k),zero) + nsic(i,k) = max(nsic(i,k),zero) + +!....................................................................... +! get size distribution parameters for precip +!...................................................................... +! rain + + if (qric(i,k) >= qsmall) then + lamr(k) = (pirhow*nric(i,k)/qric(i,k))**oneb3 + n0r(k) = nric(i,k)*lamr(k) + +! check for slope +! adjust vars + + if (lamr(k) < lamminr) then + lamr(k) = lamminr + tx1 = lamminr * lamminr + n0r(k) = tx1 * tx1 * qric(i,k)/pirhow + nric(i,k) = n0r(k)/lamr(k) + else if (lamr(k) > lammaxr) then + lamr(k) = lammaxr + tx1 = lammaxr * lammaxr + n0r(k) = tx1 * tx1 * qric(i,k)/pirhow + nric(i,k) = n0r(k)/lamr(k) + end if + +! provisional rain number and mass weighted mean fallspeed (m/s) + + tx1 = arn(i,k) / lamr(k) ** br + tx2 = 9.1_r8*rhof(i,k) + unr(k) = min(tx1*cons4, tx2) + umr(k) = min(tx1*(cons5/6._r8), tx2) + + else + lamr(k) = zero + n0r(k) = zero + umr(k) = zero + unr(k) = zero + end if + +!...................................................................... +! snow + + if (qniic(i,k) >= qsmall) then + lams(k) = (cons6*cs*nsic(i,k) / qniic(i,k))**(one/ds) + n0s(k) = nsic(i,k)*lams(k) + +! check for slope +! adjust vars + + if (lams(k) < lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + else if (lams(k) > lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + end if + +! provisional snow number and mass weighted mean fallspeed (m/s) + + tx1 = asn(i,k) / lams(k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(k) = min(tx1*(cons8/6._r8), tx2) + uns(k) = min(tx1*cons7, tx2) + + else + lams(k) = zero + n0s(k) = zero + ums(k) = zero + uns(k) = zero + end if + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +checked up to here moorthi + +! heterogeneous freezing of cloud water + + if (qcic(i,k) >= qsmall .and. t(i,k) < 269.15_r8) then + +! immersion freezing (Bigg, 1953) + + tx2 = one / (lamc(k) * lamc(k) * lamc(k)) + tx3 = min(aimm*(273.15_r8-t(i,k)), 25.0) + tx1 = cdist1(k) * tx2 * bimm * exp(tx3) + mnuccc(k) = cons9/(cons3*cons19)* pi*pirhow/36._r8 + & * gamma(7._r8+pgam(k))*tx1*tx2 + + nnuccc(k) = cons10/(cons3*qcvar)* pi/6._r8 + & * gamma(pgam(k)+four) * tx1 + + if (.true.) then + nnuccc(k) = nimm(i,k) + mnuccc(k) = nimm(i,k)*qcic(i,k)/max(cdist1(k), one) + end if + +! contact freezing (-40 nnuccd(k)) then + dum = (nnuccd(k)/(nnuccc(k)*lcldm(i,k))) +! scale mixing ratio of droplet freezing with limit + mnuccc(k) = mnuccc(k)*dum + nnuccc(k) = nnuccd(k)/lcldm(i,k) + end if +#endif + + + if ((nnucct(k)+nnuccc(k))*deltat > ncic(i, k)) then + + tx1 = tx2 * tx3 + nnuccc(k) = ncic(i, k)*dti + mnuccc(k) = cons9/(cons3*cons19)* pi*pirhow/36._r8 + & * cdist1(k)*gamma(7._r8+pgam(k))*ncic(i,k) + & * tx1 * tx1 + + nnucct(k) = zero + mnucct(k) = zero + end if + + + else + mnuccc(k) = zero + nnuccc(k) = zero + mnucct(k) = zero + nnucct(k) = zero + end if + +!....................................................................... +! snow self-aggregation from passarelli, 1978, used by reisner, 1998 +! this is hard-wired for bs = 0.4 for now +! ignore self-collection of cloud ice + + if (qniic(i,k) >= qsmall .and. t(i,k) <= 273.15_r8) then + tx1 = (two+bs)*oneb3 + nsagg(k) = -1108._r8*asn(i,k)*Eii* pi**((one-bs)*oneb3) + & * (rho(i,k)*qniic(i,k)/rhosn) ** tx1 + & * (nsic(i,k)*rho(i,k))**((four-bs)*oneb3) + & / (four*720._r8*rho(i,k)) + else + nsagg(k) = zero + end if + +!....................................................................... +! accretion of cloud droplets onto snow/graupel +! here use continuous collection equation with +! simple gravitational collection kernel +! ignore collisions between droplets/cloud ice +! since minimum size ice particle for accretion is 50 - 150 micron + +! ignore collision of snow with droplets above freezing + + if (qniic(i,k) >= qsmall .and. t(i,k) <= tmelt + & .and. qcic(i,k) >= qsmall) then + +! put in size dependent collection efficiency +! mean diameter of snow is area-weighted, since +! accretion is function of crystal geometric area +! collection efficiency is approximation based on stoke's law (Thompson et al. 2004) + + dc0 = (pgam(k)+one)/lamc(k) + ds0 = one/lams(k) + dum = dc0*dc0*uns(k)*rhow/(9._r8*mu(i,k)*ds0) + eci = dum*dum/((dum+0.4_r8)*(dum+0.4_r8)) + + eci = min(one, max(eci, zero)) + + +! no impact of sub-grid distribution of qc since psacws +! is linear in qc + + tx1 = pi/four*asn(i,k)*rho(i,k)*n0s(k)*Eci*cons11 + & / lams(k)**(bs+three) + psacws(k) = tx1 * qcic(i,k) + npsacws(k) = tx1 * ncic(i,k) + else + psacws(k) = zero + npsacws(k) = zero + end if + +! add secondary ice production due to accretion of droplets by snow +! (Hallet-Mossop process) (from Cotton et al., 1986) + + if((t(i,k) < 270.16_r8) .and. (t(i,k) >= 268.16_r8)) then + ni_secp = 0.5*3.5e8_r8*(270.16_r8-t(i,k))*psacws(k) + nsacwi(k) = ni_secp + msacwi(k) = min(ni_secp*mi0, psacws(k)) + else if((t(i,k) < 268.16_r8) .and. + & (t(i,k) >= 265.16_r8)) then + ni_secp = oneb3*3.5e8_r8*(t(i,k)-265.16_r8)*psacws(k) + nsacwi(k) = ni_secp + msacwi(k) = min(ni_secp*mi0, psacws(k)) + else + ni_secp = zero + nsacwi(k) = zero + msacwi(k) = zero + endif + psacws(k) = max(zero, psacws(k)-ni_secp*mi0) + +!....................................................................... +! accretion of rain water by snow +! formula from ikawa and saito, 1991, used by reisner et al., 1998 + + if (qric(i,k) >= 1.e-8_r8 .and. qniic(i,k) >= 1.e-8_r8 + & .and. t(i,k) <= 273.15_r8) then +! Anning decrease pracs it can reach 2.3e5 so/1.e6 + tx1 = 1.2_r8*umr(k) - 0.95_r8*ums(k) + tx2 = sqrt(tx1*tx1+0.08_r8*ums(k)*umr(k)) + tx1 = one / lamr(k) + tx3 = one / lams(k) + tx4 = tx1 * tx1 + tx5 = pi * ecr * rho(i,k) *n0r(k) * n0s(k) + + pracs(k) = pirhow*tx2*tx5 * + & (tx4*tx4*tx3*(five*tx4+tx3*(two*tx1+half*tx3))) + + + tx2 = unr(k) - uns(k) + tx2 = sqrt(1.7_r8*tx2*tx2 + 0.3_r8*unr(k)*uns(k)) + + npracs(k) = half*tx2*tx5*tx1*tx3*(tx4+tx3*(tx1+tx3)) + + else + pracs(k) = zero + npracs(k) = zero + end if + +!....................................................................... +! heterogeneous freezing of rain drops +! follows from Bigg (1953) + +! if (t(i,k).lt.269.15_r8 .and. qric(i,k).ge.qsmall) then +! Anning change to prevent huge value of mnuccr + + if (t(i,k) < 269.15_r8 .and. qric(i,k) >= qsmall + & .and. t(i,k) > 260.0_r8) then + +! tx1 = exp(min(aimm*(273.15_r8-t(i,k))-one, 50.0)) + tx1 = exp(min(aimm*(273.15_r8-t(i,k))-one, 25.0)) + tx2 = 1.0 / (lamr(k)*lamr(k)*lamr(k)) + + nnuccr(k) = pi * nric(i,k) * bimm * tx1 * tx2 + mnuccr(k) = 20._r8 * pirhow * nnuccr(k) * tx2 + + else + mnuccr(k) = zero + nnuccr(k) = zero + + end if + +!....................................................................... +! accretion of cloud liquid water by rain +! formula from Khrouditnov and Kogan (2000) +! gravitational collection kernel, droplet fall speed neglected + + if (qric(i,k) >= qsmall .and. qcic(i,k) >= qsmall) then + +! include sub-grid distribution of cloud water + + pra(k) = cons12/(cons3*cons20) + & * 67._r8*(qcic(i,k)*qric(i,k))**1.15_r8 + npra(k) = pra(k) * (ncic(i,k)/qcic(i,k)) + + else + pra(k) = zero + npra(k) = zero + end if + +!Not done above +!....................................................................... +! Self-collection of rain drops +! from Beheng(1994) + + if (qric(i,k) >= qsmall) then + nragg(k) = -8._r8*nric(i,k)*qric(i,k)*rho(i,k) + else + nragg(k) = zero + end if + +!....................................................................... +! Accretion of cloud ice by snow +! For this calculation, it is assumed that the Vs >> Vi +! and Ds >> Di for continuous collection + + if (qniic(i,k) >= qsmall .and. qiic(i,k) >= qsmall + & .and.t(i,k) <= 273.15_r8) then + + tx1 = (pi/four)*asn(i,k)*rho(i,k)*n0s(k)*Eii*cons11 + & / lams(k)**(bs+three) + prai(k) = tx1 * qiic(i,k) + nprai(k) = tx1 * niic(i,k) + + nprai(k)= min(nprai(k), 1.0e10) + + else + prai(k) = zero + nprai(k) = zero + end if + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! calculate evaporation/sublimation of rain and snow +! note: evaporation/sublimation occurs only in cloud-free portion of grid cell +! in-cloud condensation/deposition of rain and snow is neglected +! except for transfer of cloud water to snow through bergeron process + +! initialize evap/sub tendncies + pre(k) = zero + prds(k) = zero + +! evaporation of rain +! only calculate if there is some precip fraction > cloud fraction + + if (qcic(i,k)+qiic(i,k) < 1.e-6_r8 .or. + & cldmax(i,k) > lcldm(i,k)) then + +! set temporary cloud fraction to zero if cloud water + ice is very small +! this will ensure that evaporation/sublimation of precip occurs over +! entire grid cell, since min cloud fraction is specified otherwise + if (qcic(i,k)+qiic(i,k) < 1.e-6_r8) then + dum = zero + else + dum = lcldm(i,k) + end if + +! saturation vapor pressure +! esn = polysvp(t(i,k),0) + esn = min(fpvsl(t(i,k)), p(i,k)) + qsn = min(epsqs*esn/(p(i,k)-omeps*esn), one) + +! recalculate saturation vapor pressure for liquid and ice + esl(i,k) = esn +! esi(i,k) = polysvp(t(i,k),1) + esi(i,k) = min(fpvsi(t(i,k)), p(i,k)) +! hm fix, make sure when above freezing that esi=esl, not active yet + if (t(i,k) > tmelt) esi(i,k) = esl(i,k) + +! calculate q for out-of-cloud region + + qclr = (q(i,k)-dum*qsn) / (one-dum) + + if (qric(i,k) >= qsmall) then + + qvs = epsqs*esl(i,k)/(p(i,k)-omeps*esl(i,k)) + dqsdt = xxlv*qvs/(rv*t(i,k)*t(i,k)) + ab = one + dqsdt*xxlv/cpp + epsr = (pi+pi)*n0r(k)*rho(i,k)*Dv(i,k) + & * (f1r/(lamr(k)*lamr(k)) + & + f2r*sqrt(arn(i,k)*rho(i,k)/mu(i,k)) + & * sc(i,k)**oneb3 + & * cons13 / lamr(k)**((five+br)*half)) + + pre(k) = epsr*(qclr-qvs)/ab + +! only evaporate in out-of-cloud region +! and distribute across cldmax + pre(k) = min(pre(k)*(cldmax(i,k)-dum), zero) + pre(k) = pre(k) / cldmax(i,k) + + end if + +! sublimation of snow + if (qniic(i,k) >= qsmall) then + qvi = epsqs*esi(i,k)/(p(i,k)-omeps*esi(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)*t(i,k)) + abi = one + dqsidt*xxls/cpp + epss = (pi+pi)*n0s(k)*rho(i,k)*Dv(i,k) + & * (f1s/(lams(k)*lams(k)) + & + f2s*sqrt((asn(i,k)*rho(i,k)/mu(i,k))) + & * sc(i,k)**oneb3 + & * cons14/ lams(k)**((five+bs)*half)) + prds(k) = epss*(qclr-qvi)/abi + +! only sublimate in out-of-cloud region and distribute over cldmax + prds(k) = min(prds(k)*(cldmax(i,k)-dum), zero) + prds(k) = prds(k)/cldmax(i,k) + end if + + +! make sure RH not pushed above 100% due to rain evaporation/snow sublimation +! get updated RH at end of time step based on cloud water/ice condensation/evap + + tx1 = pre(k) * cldmax(i,k) + tx2 = prds(k) * cldmax(i,k) + qtmp = q(i,k) - (cmei(i,k)+tx1+tx2) * deltat + ttmp = t(i,k) + (tx1*xxlv + (cmei(i,k)+tx2)*xxls) + & * (deltat/cpp) + +!limit range of temperatures! + ttmp = max(180._r8,min(ttmp,323._r8)) + +! esn = polysvp(ttmp,0) + esn = min(fpvsl(ttmp), p(i,k)) + qsn = min(epsqs*esn/(p(i,k)-omeps*esn), one) + +! modify precip evaporation rate if q > qsat + if (qtmp > qsn) then + if (pre(k)+prds(k) < -1.e-20) then + dum1 = pre(k) / (pre(k)+prds(k)) +! recalculate q and t after cloud water cond but without precip evap + qtmp = q(i,k) - cmei(i,k)*deltat + ttmp = t(i,k) + cmei(i,k)*xxls*deltat/cpp +! esn = polysvp(ttmp,0) + esn = min(fpvsl(ttmp), p(i,k)) + qsn = min(epsqs*esn/(p(i,k)-omeps*esn), one) + tx1 = one / (cpp*rv*ttmp*ttmp) + dum = min(zero, (qtmp-qsn)/(one+cons27*qsn*tx1)) + +! modify rates if needed, divide by cldmax to get local (in-precip) value + pre(k) = dum*dum1/(deltat*cldmax(i,k)) + +! do separately using RHI for prds.... +! esn = polysvp(ttmp,1) + esn = min(fpvsi(ttmp), p(i,k)) + qsn = min(epsqs*esn/(p(i,k)-omeps*esn), one) + dum = min(zero, (qtmp-qsn)/(one+cons28*qsn*tx1)) + +! modify rates if needed, divide by cldmax to get local (in-precip) value + prds(k) = dum*(one-dum1)/(deltat*cldmax(i,k)) + end if + end if + + end if + +! bergeron process - evaporation of droplets and deposition onto snow + if (qniic(i,k) >= qsmall .and. qcic(i,k) >= qsmall + & .and. t(i,k) < tmelt) then + qvi = epsqs*esi(i,k)/(p(i,k)-omeps*esi(i,k)) + qvs = epsqs*esl(i,k)/(p(i,k)-omeps*esl(i,k)) + dqsidt = xxls*qvi/(rv*t(i,k)*t(i,k)) + abi = one + dqsidt*xxls/cpp + epss = (pi+pi)*n0s(k)*rho(i,k)*Dv(i,k) + & * (f1s/(lams(k)*lams(k)) + & + f2s*sqrt(asn(i,k)*rho(i,k)/mu(i,k)) + & * sc(i,k)**oneb3 + & * cons14 / (lams(k)**((five+bs)*half))) + bergs(k) = epss*(qvs-qvi)/abi + else + bergs(k) = zero + end if + + + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! conservation to ensure no negative values of cloud water/precipitation +! in case microphysical process rates are large + +! make sure and use end-of-time step values for cloud water, ice, due +! condensation/deposition + +! note: for check on conservation, processes are multiplied by omsm +! to prevent problems due to round off error + +! include mixing timescale (mtime) + + qce = max(qc(i,k)-berg(i,k)*deltat, zero) + nce = nc(i,k) + npccn(i,k)*deltat*mtime + qie = qi(i,k) + (cmei(i,k)+berg(i,k))*deltat + nie = ni(i,k) + nnuccd(k)*deltat*mtime + +! conservation of qc + + tx1 = lcldm(i,k) * deltat + dum = (prc(k) + pra(k) + mnuccc(k) + mnucct(k) + & + msacwi(k) + psacws(k) + bergs(k)) * tx1 + + if (dum > qce) then + + ratio = qce/dum * omsm + + prc(k) = prc(k) * ratio + pra(k) = pra(k) * ratio + mnuccc(k) = mnuccc(k) * ratio + mnucct(k) = mnucct(k) * ratio + msacwi(k) = msacwi(k) * ratio + psacws(k) = psacws(k) * ratio + bergs(k) = bergs(k) * ratio + end if + +! conservation of nc + + + dum = (nprc1(k) + npra(k) + nnuccc(k) + nnucct(k) + & + npsacws(k) - nsubc(k)) * tx1 + + if (dum > nce) then + ratio = nce/dum * omsm + + nprc1(k) = nprc1(k) * ratio + npra(k) = npra(k) * ratio + nnuccc(k) = nnuccc(k) * ratio + nnucct(k) = nnucct(k) * ratio + npsacws(k) = npsacws(k) * ratio + nsubc(k) = nsubc(k) * ratio + end if + +! conservation of qi + + dum = ((-mnuccc(k)-mnucct(k)-msacwi(k))*lcldm(i,k) + & + (prci(k)+prai(k))*icldm(i,k)) * deltat + + if (dum > qie) then + if (prci(k)+prai(k) > zero) then + ratio = (qie*dti + & +(mnuccc(k)+mnucct(k)+msacwi(k))*lcldm(i,k)) + & / ((prci(k)+prai(k))*icldm(i,k))*omsm + else + ratio = zero + end if + + prci(k) = prci(k)*ratio + prai(k) = prai(k)*ratio + end if + +! conservation of ni + + dum = ((-nnucct(k)-nsacwi(k))*lcldm(i,k) + & + (nprci(k)+ nprai(k)-nsubi(k))*icldm(i,k))*deltat + + if (dum > nie) then + if ( abs(nprci(k)+nprai(k)-nsubi(k)) > zero) then + ratio = (nie*dti+(nnucct(k)+nsacwi(k))*lcldm(i,k)) + & / ((nprci(k)+nprai(k)-nsubi(k))*icldm(i,k))*omsm + else + + ratio = zero + end if + nprci(k) = nprci(k) * ratio + nprai(k) = nprai(k) * ratio + nsubi(k) = nsubi(k) * ratio + end if + +! for preciptiation conservation, use logic that vertical integral +! of tendency from current level to top of model (i.e., qrtot) cannot be negative + +! conservation of rain mixing rat + + if ( ((prc(k)+pra(k))*lcldm(i,k) + & + (-mnuccr(k)+pre(k)-pracs(k))*cldmax(i,k))*rdz + & + qrtot < zero) then + + if (-pre(k)+pracs(k)+mnuccr(k) >= qsmall) then + + ratio = (qrtot*rdzi + (prc(k)+pra(k))*lcldm(i,k)) + & / ((-pre(k)+pracs(k)+mnuccr(k))*cldmax(i,k))*omsm + + pre(k) = pre(k) * ratio + pracs(k) = pracs(k) * ratio + mnuccr(k) = mnuccr(k) * ratio + end if + end if + +! conservation of nr - for now neglect evaporation of nr + + nsubr(k) = zero + + if ((nprc(k)*lcldm(i,k)+(-nnuccr(k)+nsubr(k)-npracs(k) + + & nragg(k))*cldmax(i,k))*rdz + nrtot < zero) then + + if (-nsubr(k)-nragg(k)+npracs(k)+nnuccr(k) >= qsmall) + & then + ratio = (nrtot*rdzi+nprc(k)*lcldm(i,k)) + & / ((-nsubr(k)-nragg(k)+npracs(k) + & +nnuccr(k))*cldmax(i,k))*omsm + + nsubr(k) = nsubr(k) * ratio + npracs(k) = npracs(k) * ratio + nnuccr(k) = nnuccr(k) * ratio + nragg(k) = nragg(k) * ratio + end if + end if + +! conservation of snow mix ratio + + tx1 = (bergs(k)+psacws(k))*lcldm(i,k) + & + (prai(k)+prci(k))*icldm(i,k) + if ((tx1+(pracs(k)+ mnuccr(k)+prds(k))*cldmax(i,k)) + & *rdz+qstot < zero) then + + if (-prds(k) >= qsmall) then + + ratio = (qstot*rdzi + tx1 + & + (pracs(k)+mnuccr(k))*cldmax(i,k)) + & / (-prds(k)*cldmax(i,k))*omsm + + prds(k) = prds(k) * ratio + end if + end if + +! conservation of ns + +! calculate loss of number due to sublimation +! for now neglect sublimation of ns + nsubs(k) = zero + + if ((nprci(k)*icldm(i,k) + & +(nnuccr(k)+nsubs(k)+nsagg(k))*cldmax(i,k)) + & * rdz + nstot < zero) then + + if (-nsubs(k)-nsagg(k) >= qsmall) then + + ratio = (nstot*rdzi + & + nprci(k)*icldm(i,k)+ nnuccr(k)*cldmax(i,k)) + & / ((-nsubs(k)-nsagg(k))*cldmax(i,k))*omsm + + nsubs(k) = nsubs(k) * ratio + nsagg(k) = nsagg(k) * ratio + end if + end if + +! get tendencies due to microphysical conversion processes +! note: tendencies are multiplied by appropaiate cloud/precip +! fraction to get grid-scale values +! note: cmei is already grid-average values + + qvlat(i,k) = qvlat(i,k) + & - (pre(k)+prds(k))*cldmax(i,k) - cmei(i,k) +! if (lprint .and. k == 29) write(0,*)' qvlata=',qvlat(i,k), +! &' pre=',pre(k),' prds=',prds(k),' cldmax=',cldmax(i,k),cmei(i,k) +! &,' it=',it + + tlat(i,k) = tlat(i,k) + & + pre(k)*cldmax(i,k) * xxlv + & + (prds(k)*cldmax(i,k)+cmei(i,k)) * xxls + & + ((bergs(k)+psacws(k)+mnuccc(k)+ + & mnucct(k)+msacwi(k))*lcldm(i,k) + & + (mnuccr(k)+ pracs(k))*cldmax(i,k) + & + berg(i,k)) * xlf + + +! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 +! & .and.xlat<1.347.and.k==38) +! & write(*,*)"anning_m0",pre(k),prds(k),cmei(i,k), +! & bergs(k),psacws(k), +! & mnuccc(k),mnucct(k),msacwi(k),mnuccr(k),pracs(k),berg(i,k) + + qctend(i,k) = qctend(i,k) + & + (-pra(k)-prc(k)-mnuccc(k)-mnucct(k) + & -msacwi(k)-psacws(k)-bergs(k))*lcldm(i,k) + & - berg(i,k) + + qitend(i,k) = qitend(i,k) + & + (mnuccc(k)+mnucct(k)+msacwi(k))*lcldm(i,k) + & + (-prci(k)-prai(k))*icldm(i,k) + & + cmei(i,k) + berg(i,k) + + qrtend(i,k) = qrtend(i,k) + & + (pra(k)+prc(k))*lcldm(i,k) + & + (pre(k)-pracs(k)-mnuccr(k))*cldmax(i,k) + + qnitend(i,k) = qnitend(i,k) + & + (prai(k)+prci(k))*icldm(i,k) + & + (psacws(k)+bergs(k))*lcldm(i,k) + & + (prds(k)+pracs(k)+mnuccr(k))*cldmax(i,k) + +! if (lprint) write(0,*)' k=',k,' qnitend=',qnitend(i,k), +! & prai(k), prci(k), icldm(i,k),psacws(k),bergs(k),lcldm(i,k) +! &,prds(k),pracs(k),mnuccr(k),' cldmax=',cldmax(i,k) + +! add output for cmei (accumulate)!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + cmeiout(i,k) = cmeiout(i,k) + cmei(i,k) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +! assign variables for trop_mozart, these are grid-average +! evaporation/sublimation is stored here as positive term + + evapsnow(i,k) = evapsnow(i,k) + prds(k) * cldmax(i,k) + nevapr(i,k) = nevapr(i,k) + pre(k) * cldmax(i,k) + +! change to make sure prain is positive: do not remove snow from +! prain used for wet deposition + prain(i,k) = prain(i,k) + & + (pra(k)+prc(k))*lcldm(i,k) + & + (-pracs(k)-mnuccr(k))*cldmax(i,k) + + prodsnow(i,k) = prodsnow(i,k) + & + (prai(k)+prci(k))*icldm(i,k) + & + (psacws(k)+bergs(k))*lcldm(i,k) + & + (pracs(k)+mnuccr(k))*cldmax(i,k) + +! following are used to calculate 1st order conversion rate of cloud water +! to rain and snow (1/s), for later use in aerosol wet removal routine +! previously, wetdepa used (prain/qc) for this, and the qc in wetdepa may be smaller than the qc +! used to calculate pra, prc, ... in this routine +! qcsinksum_rate1ord = sum over iterations{ rate of direct transfer of cloud water to rain & snow } +! (no cloud ice or bergeron terms) +! qcsum_rate1ord = sum over iterations{ qc used in calculation of the transfer terms } + + qcsinksum_rate1ord(k) = qcsinksum_rate1ord(k) + & +(pra(k)+prc(k)+psacws(k))*lcldm(i,k) + qcsum_rate1ord(k) = qcsum_rate1ord(k) + qc(i,k) + +! microphysics output, note this is grid-averaged + prao(i,k) = prao(i,k) + pra(k) * lcldm(i,k) + prco(i,k) = prco(i,k) + prc(k) * lcldm(i,k) + mnuccco(i,k) = mnuccco(i,k) + mnuccc(k) * lcldm(i,k) + mnuccto(i,k) = mnuccto(i,k) + mnucct(k) * lcldm(i,k) + msacwio(i,k) = msacwio(i,k) + msacwi(k) * lcldm(i,k) + psacwso(i,k) = psacwso(i,k) + psacws(k) * lcldm(i,k) + bergso(i,k) = bergso(i,k) + bergs(k) * lcldm(i,k) + bergo(i,k) = bergo(i,k) + berg(i,k) + prcio(i,k) = prcio(i,k) + prci(k) * icldm(i,k) + praio(i,k) = praio(i,k) + prai(k) * icldm(i,k) + mnuccro(i,k) = mnuccro(i,k) + mnuccr(k) * cldmax(i,k) + pracso (i,k) = pracso (i,k) + pracs (k) * cldmax(i,k) + + mnuccdo(i,k) = mnuccdo(i,k) + mnuccd(k) + nnuccto(i,k) = nnuccto(i,k) + nnucct(k) * lcldm(i,k) + + nnuccdo(i,k) = nnuccdo(i,k) + nnuccd(k) + nnuccco(i,k) = nnuccco(i,k) + nnuccc(k) * lcldm(i,k) + nsacwio(i,k) = nsacwio(i,k) + nsacwi(k) * icldm(i,k) + nsubio(i,k) = nsubio(i,k) + nsubi(k) * icldm(i,k) + nprcio(i,k) = nprcio(i,k) + nprci(k) * icldm(i,k) + npraio(i,k) = npraio(i,k) + nprai(k) * icldm(i,k) + + npccno(i, k) = npccno(i,k) + npccn(i,k)*lcldm(i,k) + npsacwso(i,k) = npsacwso(i,k) + npsacws(k)*lcldm(i,k) + nsubco(i,k) = nsubco(i,k) + nsubc(k) * lcldm(i,k) + nprao(i,k) = nprao(i,k) + npra(k) * lcldm(i,k) + nprc1o(i,k) = nprc1o(i,k) + nprc1(k) * lcldm(i,k) + + +! multiply activation/nucleation by mtime to account for fast timescale + + nctend(i,k) = nctend(i,k) + npccn(i,k)*mtime + & + (-nnuccc(k)-nnucct(k)-npsacws(k)+nsubc(k) + & -npra(k)-nprc1(k))*lcldm(i,k) + + nitend(i,k) = nitend(i,k) + nnuccd(k)*mtime + & + (nnuccc(k)+nnucct(k)+nsacwi(k))*lcldm(i,k) + & + (nsubi(k)-nprci(k)- nprai(k))*icldm(i,k) + + nstend(i,k) = nstend(i,k) + & + (nsubs(k)+ nsagg(k)+nnuccr(k))*cldmax(i,k) + & + nprci(k)*icldm(i,k) + + nrtend(i,k) = nrtend(i,k) + nprc(k)*lcldm(i,k) + & + (nsubr(k)-npracs(k)-nnuccr(k)+nragg(k)) + & * cldmax(i,k) + +! make sure that nc and ni at advanced time step do not exceed +! maximum (existing N + source terms*dt), which is possible due to +! fast nucleation timescale + + if (nctend(i,k) > zero .and. + & nc(i,k)+nctend(i,k)*deltat > ncmax(i,k)) then + nctend(i,k) = max(zero, (ncmax(i,k)-nc(i,k))*dti) + end if + if (nitend(i,k) > zero .and. + & ni(i,k)+nitend(i,k)*deltat > nimax) then + nitend(i,k) = max(zero, (nimax-ni(i,k))*dti) + end if + + +! get final values for precipitation q and N, based on +! flux of precip from above, source/sink term, and terminal fallspeed +! see eq. 15-16 in MG2008 + if(fprcp==0) then +! rain + + if (qric(i,k) >= qsmall) then + if (k == 1) then + qric(i,k) = qrtend(i,k)*dz(i,k)/(cldmax(i,k)*umr(k)) + nric(i,k) = nrtend(i,k)*dz(i,k)/(cldmax(i,k)*unr(k)) + else + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) + + qric(i,k) = (tx1*umr(km)*qric(i,km) + & + rdz*qrtend(i,k)) / (umr(k)*tx3) + + nric(i,k) = (tx1*unr(km)*nric(i,km) + & + rdz*nrtend(i,k)) / (unr(k)*tx3) + + end if + else + qric(i,k) = zero + nric(i,k) = zero + end if + +! snow + + if (qniic(i,k) >= qsmall) then + if (k == 1) then + tx1 = dz(i,k)/cldmax(i,k) + qniic(i,k) = qnitend(i,k)*tx1/ums(k) + nsic(i,k) = nstend(i,k)*tx1/uns(k) + else + tx1 = rho(i,km) * cldmax(i,km) + tx3 = rho(i,k) * cldmax(i,k) + + qniic(i,k) = (tx1*ums(km)*qniic(i,km) + & + rdz*qnitend(i,k)) / (ums(k)*tx3) + nsic(i,k) = (tx1*uns(km)*nsic(i,km) + & + rdz*nstend(i,k)) / (uns(k)*tx3) + end if + else + qniic(i,k) = zero + nsic(i,k) = zero + end if + +! calculate precipitation flux at surface +! divide by density of water to get units of m/s + + tx1 = rdz/rhow + prect(i) = prect(i) + (qrtend(i,k)+ qnitend(i,k))*tx1 + preci(i) = preci(i) + qnitend(i,k)*tx1 + +! if (lprint) write(0,*)' prect=',prect(i),' preci=',preci(i) +! &,' qrtend=',qrtend(i,k),' qnitend=',qnitend(i,k),' rdz=',rdz +! &,' k=',k,' it=',it, 'rhow=',rhow,' rho=',rho(i,k),' dz=',dz(i,k) + + + + rainrt(i,k) = qric(i,k)*rho(i,k)*umr(k) + & / rhow*3600._r8*1000._r8 + +! vertically-integrated precip source/sink terms (note: grid-averaged) + + qrtot = max(qrtot + qrtend(i,k)*rdz, zero) + qstot = max(qstot + qnitend(i,k)*rdz, zero) + nrtot = max(nrtot + nrtend(i,k)*rdz, zero) + nstot = max(nstot + nstend(i,k)*rdz, zero) + +!!!! done up to here - Moorthi +! calculate melting and freezing of precip +! melt snow at +2 C + taux = 1.0 + + if (.true.) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 > 275.15_r8) then + + if (qstot > zero) then + +! make sure melting snow doesn't reduce temperature below threshold + dum = xlfocp*qstot*rdzi + if (tx1-dum*deltat < 273.15_r8) then + tx2 = (tx1-275.15_r8) * dti + dum = min(one,max(zero,tx2/dum)) + else + dum = one + end if + + qric(i,k) = qric(i,k) + dum*qniic(i,k) + nric(i,k) = nric(i,k) + dum*nsic(i,k) + qniic(i,k) = (one-dum)*qniic(i,k) + nsic(i,k) = (one-dum)*nsic(i,k) +! heating tendency + tmp = -xlf*dum*qstot*rdzi + meltsdt(i,k) = meltsdt(i,k) + tmp + + tlat(i,k) = tlat(i,k) + tmp + +! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 +! & .and.xlat<1.347.and.k==38) +! & write(*,*)"anning_m1",tmp + + qrtot = qrtot + dum*qstot + nrtot = nrtot + dum*nstot + qstot = (one-dum)*qstot + nstot = (one-dum)*nstot + preci(i) = (one-dum)*preci(i) + endif + endif + + end if + tlataux(i, k) = tlat(i, k) + +! freeze all rain at -5C for Arctic + if(.true.) then +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 < tmelt-five) then + + if (qrtot > zero) then + +! make sure freezing rain doesn't increase temperature above threshold + dum = xlfocp*qrtot*rdzi + if (tx1+dum*deltat > tmelt-five) then + tx2 = -(tx1 - (tmelt-five)) * dti + dum = min(one,max(zero,tx2/dum)) + else + dum = one + endif + qniic(i,k) = qniic(i,k) + dum*qric(i,k) + nsic(i,k) = nsic(i,k) + dum*nric(i,k) + qric(i,k) = (one-dum)*qric(i,k) + nric(i,k) = (one-dum)*nric(i,k) +! heating tendency + tmp = xlf*dum*qrtot*rdzi + frzrdt(i,k) = frzrdt(i,k) + tmp + + tlat(i,k) = tlat(i,k) + tmp + +! if(xlon<0.01.and.xlon>-0.01.and.xlat>1.346 +! & .and.xlat<1.347.and.k==38) +! & write(*,*)"anning_m2",tmp + + qstot = qstot + dum*qrtot + qrtot = (one-dum)*qrtot + nstot = nstot + dum*nrtot + nrtot = (one-dum)*nrtot + preci(i) = preci(i) + dum*(prect(i)-preci(i)) + end if + end if + end if + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +! if rain/snow mix ratio is zero so should number concentration + + if (qniic(i,k) < qsmall) then + qniic(i,k) = zero + nsic(i,k) = zero + end if + + if (qric(i,k) < qsmall) then + qric(i,k) = zero + nric(i,k) = zero + end if + +! make sure number concentration is a positive number to avoid +! taking root of negative + + nric(i,k) = max(nric(i,k), zero) + nsic(i,k) = max(nsic(i,k), zero) + +!....................................................................... +! get size distribution parameters for fallspeed calculations +!...................................................................... +! rain + + if (qric(i,k) >= qsmall) then + lamr(k) = (pirhow*nric(i,k)/qric(i,k))**oneb3 + n0r(k) = nric(i,k)*lamr(k) + +! check for slope +! change lammax and lammin for rain and snow +! adjust vars + + if (lamr(k) < lamminr) then + lamr(k) = lamminr + tx1 = lamr(k) * lamr(k) + n0r(k) = tx1*tx1*qric(i,k)/pirhow + nric(i,k) = n0r(k)/lamr(k) + else if (lamr(k) > lammaxr) then + lamr(k) = lammaxr + tx1 = lamr(k) * lamr(k) + n0r(k) = tx1*tx1*qric(i,k)/pirhow + nric(i,k) = n0r(k)/lamr(k) + end if + + +! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + tx1 = arn(i,k) / lamr(k)**br + tx2 = 9.1_r8*rhof(i,k) + unr(k) = min(tx1*cons4, tx2) + umr(k) = min(tx1*(cons5/6._r8),tx2) + + else + lamr(k) = zero + n0r(k) = zero + umr(k) = zero + unr(k) = zero + end if + +!calculate mean size of combined rain and snow + + if (lamr(k) > zero) then + Artmp = n0r(k) * (0.5*pi) / (lamr(k)*lamr(k)*lamr(k)) + else + Artmp = zero + endif + + if (lamc(k) > zero) then + Actmp = cdist1(k) * pi * gamma(pgam(k)+three) + & / (four * lamc(k)*lamc(k)) + else + Actmp = zero + endif + + if (Actmp > zero .or.Artmp > zero) then + rercld(i,k) = rercld(i,k) + three*(qric(i,k)+qcic(i,k)) + & /(four*rhow*(Actmp+Artmp)) + arcld(i,k) = arcld(i,k) + one + endif + +!...................................................................... +! snow + + if (qniic(i,k) >= qsmall) then + lams(k) = (cons6*cs*nsic(i,k) / qniic(i,k))**(one/ds) + n0s(k) = nsic(i,k)*lams(k) + +! check for slope +! adjust vars + + if (lams(k) < lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + + else if (lams(k) > lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+one)*qniic(i,k)/(cs*cons6) + nsic(i,k) = n0s(k)/lams(k) + end if + +! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + + tx1 = asn(i,k) / lams(k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(k) = min(tx1*(cons8/6._r8), tx2) + uns(k) = min(tx1*cons7, tx2) + + else + lams(k) = zero + n0s(k) = zero + ums(k) = zero + uns(k) = zero + end if + +!c........................................................................ +! sum over sub-step for average process rates + +! convert rain/snow q and N for output to history, note, +! output is for gridbox average + + qrout(i,k) = qrout(i,k) + qric(i,k)*cldmax(i,k) + qsout(i,k) = qsout(i,k) + qniic(i,k)*cldmax(i,k) + tx1 = rho(i,k)*cldmax(i,k) + nrout(i,k) = nrout(i,k) + nric(i,k)*tx1 + nsout(i,k) = nsout(i,k) + nsic(i,k)*tx1 + + end if !fprcp Anning Cheng 9/16/2016 + tlat1(i,k) = tlat1(i,k) + tlat(i,k) + tlat1_aux(i,k) = tlat1_aux(i,k) + tlataux(i,k) + + qvlat1(i,k) = qvlat1(i,k) + qvlat(i,k) + qctend1(i,k) = qctend1(i,k) + qctend(i,k) + qitend1(i,k) = qitend1(i,k) + qitend(i,k) + nctend1(i,k) = nctend1(i,k) + nctend(i,k) + nitend1(i,k) = nitend1(i,k) + nitend(i,k) + + t(i,k) = t(i,k) + tlat(i,k)*deltat/cpp + q(i,k) = q(i,k) + qvlat(i,k)*deltat + qc(i,k) = qc(i,k) + qctend(i,k)*deltat + qi(i,k) = qi(i,k) + qitend(i,k)*deltat + nc(i,k) = nc(i,k) + nctend(i,k)*deltat + ni(i,k) = ni(i,k) + nitend(i,k)*deltat + + rainrt1(i,k) = rainrt1(i,k) + rainrt(i,k) + +!divide rain radius over substeps for average + if (arcld(i,k) > zero) then + rercld(i,k) = rercld(i,k) / arcld(i,k) + end if +!calculate precip fluxes and adding them to summing sub-stepping variables + + rflx(i,1) = zero + sflx(i,1) = zero + + + rflx(i,k+1) = qrout(i,k)*rho(i,k)*umr(k) + sflx(i,k+1) = qsout(i,k)*rho(i,k)*ums(k) + + + rflx1(i,k+1) = rflx1(i,k+1) + rflx(i,k+1) + sflx1(i,k+1) = sflx1(i,k+1) + sflx(i,k+1) + +!c........................................................................ + + enddo ! big k loop + + prect1(i) = prect1(i) + prect(i) + preci1(i) = preci1(i) + preci(i) + +! if (lprint) write(0,*)' prect1=',prect1(i),' prect=', +! &prect(i),' iter=',iter,' it=',it + + enddo !end of big iter loop + + do k = 1, pver + rate1ord_cw2pr_st(i,k) = qcsinksum_rate1ord(k) + + & / max(qcsum_rate1ord(k),1.0e-30_r8) + enddo + + endif ! end of if (ltrue(i) == 0) then + enddo ! end of big i loop2 + +! convert dt from sub-step back to full time step + + deltat = deltat*real(iter) + dti = one / deltat + + +!............................................................................. + + do i=1,ncol !big i loop3 + + if (ltrue(i) == 0) then ! skip all calculations if no cloud water + + do k=1,pver + ! assign default values for effective radius + effc(i,k) = 10._r8 + effi(i,k) = 25._r8 + effc_fn(i,k) = 10._r8 + lamcrad(i,k) = zero + pgamrad(i,k) = zero + deffi(i,k) = zero + end do + + else +! + nstep = 1 ! initialize nstep for sedimentation sub-steps + +! divide precip rate by number of sub-steps to get average over time step + + prect(i) = prect1(i) * riter + preci(i) = preci1(i) * riter + +! if (lprint) write(0,*)' prect=',prect(i),' prect1=',prect1(i) +! &,' riter=',riter + + do k=1,pver + +! assign variables back to start-of-timestep values before updating after sub-steps + + t(i,k) = t1(i,k) + q(i,k) = q1(i,k) + qc(i,k) = qc1(i,k) + qi(i,k) = qi1(i,k) + nc(i,k) = nc1(i,k) + ni(i,k) = ni1(i,k) + +! divide microphysical tendencies by number of sub-steps to get average over time step + + tlat(i,k) = tlat1(i,k) * riter + qvlat(i,k) = qvlat1(i,k) * riter + qctend(i,k) = qctend1(i,k) * riter + qitend(i,k) = qitend1(i,k) * riter + nctend(i,k) = nctend1(i,k) * riter + nitend(i,k) = nitend1(i,k) * riter + + tlataux(i,k) = tlat1_aux(i,k) * riter + + + rainrt(i,k) = rainrt1(i,k) * riter + +! divide by number of sub-steps to find final values + rflx(i,k+1) = rflx1(i,k+1) * riter + sflx(i,k+1) = sflx1(i,k+1) * riter + +! divide output precip q and N by number of sub-steps to get average over time step + + qrout(i,k) = qrout(i,k) * riter + qsout(i,k) = qsout(i,k) * riter + nrout(i,k) = nrout(i,k) * riter + nsout(i,k) = nsout(i,k) * riter + +! divide trop_mozart variables by number of sub-steps to get average over time step + + nevapr(i,k) = nevapr(i,k) * riter + evapsnow(i,k) = evapsnow(i,k) * riter + prain(i,k) = prain(i,k) * riter + prodsnow(i,k) = prodsnow(i,k) * riter + cmeout(i,k) = cmeout(i,k) * riter + + cmeiout(i,k) = cmeiout(i,k) * riter + meltsdt(i,k) = meltsdt(i,k) * riter + frzrdt (i,k) = frzrdt (i,k) * riter + + +! microphysics output + prao(i,k) = prao(i,k) * riter + prco(i,k) = prco(i,k) * riter + mnuccco(i,k) = mnuccco(i,k) * riter + mnuccto(i,k) = mnuccto(i,k) * riter + msacwio(i,k) = msacwio(i,k) * riter + psacwso(i,k) = psacwso(i,k) * riter + bergso(i,k) = bergso(i,k) * riter + bergo(i,k) = bergo(i,k) * riter + prcio(i,k) = prcio(i,k) * riter + praio(i,k) = praio(i,k) * riter + + mnuccdo(i,k) = mnuccdo(i,k) * riter + mnuccto(i,k) = mnuccto(i,k) * riter + + mnuccro(i,k) = mnuccro(i,k) * riter + pracso (i,k) = pracso (i,k) * riter + +!!!!DONIFFFF========================== + nnuccdo(i,k) = nnuccdo(i,k) * riter + nnuccco(i,k) = nnuccco(i,k) * riter + nsacwio(i,k) = nsacwio(i,k) * riter + nsubio(i,k) = nsubio(i,k) * riter + nprcio(i,k) = nprcio(i,k) * riter + npraio(i,k) = npraio(i,k) * riter + + npccno(i,k) = npccno(i,k) * riter + npsacwso(i,k) = npsacwso(i,k) * riter + nsubco(i,k) = nsubco(i,k) * riter + nprao(i,k) = nprao(i,k) * riter + nprc1o(i,k) = nprc1o(i,k) * riter + +!===================================== + + +! modify to include snow. in prain & evap (diagnostic here: for wet dep) + + prain(i,k) = prain(i,k) + prodsnow(i,k) + +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! calculate sedimentation for cloud water and ice +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +! update in-cloud cloud mixing ratio and number concentration +! with microphysical tendencies to calculate sedimentation, assign to dummy vars +! note: these are in-cloud values***, hence we divide by cloud fraction + + tx1 = one / lcldm(i,k) + tx2 = one / icldm(i,k) + dumc(i,k) = (qc(i,k) + qctend(i,k)*deltat) * tx1 + dumi(i,k) = (qi(i,k) + qitend(i,k)*deltat) * tx2 + dumnc(i,k) = max((nc(i,k)+nctend(i,k)*deltat)*tx1, zero) + dumni(i,k) = max((ni(i,k)+nitend(i,k)*deltat)*tx2, zero) + + if (nccons) then + dumnc(i,k) = ncnst*irho(i,k) + end if + + if (nicons) then + dumni(i,k) = ninst*irho(i,k) + end if + +! obtain new slope parameter to avoid possible singularity + + if (dumi(i,k) >= qsmall) then +! add upper limit to in-cloud number concentration to prevent numerical error + dumni(i,k) = min(dumni(i,k),dumi(i,k)*1.e20_r8) + lami(k) = (cons1*ci* dumni(i,k)/dumi(i,k))**oneodi + +! miu_ice(k)=mui_hemp_l(lami(k)) Anning changed here + miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, + & 10.0_r8), 0.1_r8) + tx1 = one + miu_ice(k) + tx2 = one / gamma(tx1) + aux = (gamma(tx1+di)*tx2) ** oneodi + lami(k) = aux*lami(k) + + n0i(k) = niic(i,k)*lami(k)**tx1 * tx2 + + + if (lami(k) < lammini*aux) then + lami(k) = lammini + miu_ice(k) = zero + niic(i,k) = n0i(k)/lami(k) + end if + if (lami(k) > lammaxi*aux) then + lami(k) = lammaxi + miu_ice(k) = zero + niic(i,k) = n0i(k)/lami(k) + end if + + else + lami(k) = zero + end if + + if (dumc(i,k) >= qsmall) then +! add upper limit to in-cloud number concentration to prevent numerical error + dumnc(i,k) = min(dumnc(i,k),dumc(i,k)*1.e20_r8) +! add lower limit to in-cloud number concentration + dumnc(i,k) = max(dumnc(i,k),cdnl*irho(i,k)) + tx1 = 0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k) = max(two, min(15._r8, one/(tx1*tx1)-one)) + + lamc(k) = (cr*dumnc(i,k)*gamma(pgam(k)+four) + & / (dumc(i,k)*gamma(pgam(k)+one)))**oneb3 + lammin = (pgam(k)+one) / 50.e-6_r8 + lammax = (pgam(k)+one) / 2.e-6_r8 + lamc(k) = min(lammax, max(lamc(k),lammin)) + else + lamc(k) = zero + end if + +! calculate number and mass weighted fall velocity for droplets +! include effects of sub-grid distribution of cloud water + + + if (dumc(i,k) >= qsmall) then + tx1 = lamc(k) ** bc + unc = acn(i,k)*gamma(one+bc+pgam(k)) + & / (tx1*gamma(pgam(k)+one)) + umc = acn(i,k)*gamma(four+bc+pgam(k)) + & / (tx1*gamma(pgam(k)+four)) +! fallspeed for output + vtrmc(i,k) = umc + else + umc = zero + unc = zero + end if + + + +! calculate number and mass weighted fall velocity for cloud ice + + if (dumi(i,k) >= qsmall) then + cons16 = gamma(one+bi+miu_ice(k))/gamma(one+miu_ice(k)) + cons17 = gamma(four+bi+miu_ice(k))/gamma(four+miu_ice(k)) + + tx1 = ain(i,k) / lami(k)**bi + tx2 = 1.2_r8*rhof(i,k) + uni = min(tx1*cons16, tx2) + umi = min(tx1*cons17, tx2) +! fallspeed + vtrmi(i,k) = umi + else + umi = zero + uni = zero + end if + +!DONIFFFF tune up sedimentation vel!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + umi = umi*ui_scale + uni = uni*ui_scale +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + tx1 = g*rho(i,k) + fi(k) = tx1*umi + fni(k) = tx1*uni + fc(k) = tx1*umc + fnc(k) = tx1*unc + +! calculate number of split time steps to ensure courant stability criteria +! for sedimentation calculations + + rgvm = max(fi(k),fc(k),fni(k),fnc(k)) + nstep = max(int(rgvm*deltat/pdel(i,k)+one),nstep) + +! redefine dummy variables - sedimentation is calculated over grid-scale +! quantities to ensure conservation + + dumc(i,k) = qc(i,k) + qctend(i,k)*deltat + dumi(i,k) = qi(i,k) + qitend(i,k)*deltat + dumnc(i,k) = max(nc(i,k) + nctend(i,k)*deltat, zero) + dumni(i,k) = max(ni(i,k) + nitend(i,k)*deltat, zero) + + if (dumc(i,k) < qsmall) dumnc(i,k) = zero + if (dumi(i,k) < qsmall) dumni(i,k) = zero + + end do ! end of k loop + + do n = 1,nstep + + do k = 1,pver + falouti(k) = max(fi(k) * dumi(i,k), zero) + faloutni(k) = max(fni(k) * dumni(i,k), zero) + faloutc(k) = max(fc(k) * dumc(i,k), zero) + faloutnc(k) = max(fnc(k) * dumnc(i,k), zero) + end do + +! top of model + + k = 1 + tx1 = one / pdel(i,k) + faltndi = falouti(k) * tx1 + faltndni = faloutni(k) * tx1 + faltndc = faloutc(k) * tx1 + faltndnc = faloutnc(k) * tx1 + +! add fallout terms to microphysical tendencies + + tx2 = one / float(nstep) + tx3 = deltat*tx2 + + qitend(i,k) = qitend(i,k) - faltndi * tx2 + nitend(i,k) = nitend(i,k) - faltndni * tx2 + qctend(i,k) = qctend(i,k) - faltndc * tx2 + nctend(i,k) = nctend(i,k) - faltndnc * tx2 + +! sedimentation tendencies for output + qcsedten(i,k) = qcsedten(i,k) - faltndc * tx2 + qisedten(i,k) = qisedten(i,k) - faltndi * tx2 + + dumi(i,k) = dumi(i,k) - faltndi *tx3 + dumni(i,k) = dumni(i,k) - faltndni*tx3 + dumc(i,k) = dumc(i,k) - faltndc *tx3 + dumnc(i,k) = dumnc(i,k) - faltndnc*tx3 + + do k = 2,pver + +! for cloud liquid and ice, if cloud fraction increases with height +! then add flux from above to both vapor and cloud water of current level +! this means that flux entering clear portion of cell from above evaporates +! instantly + tx4 = tx1 + tx1 = one / pdel(i,k) + + if (lcldm(i,k-1) > zero) then + dum = min(one, lcldm(i,k)/lcldm(i,k-1)) + else + dum = min(one, lcldm(i,k)) + endif + if (icldm(i,k-1) > zero) then + dum1 = min(one, icldm(i,k)/icldm(i,k-1)) + else + dum1 = min(one, icldm(i,k)) + endif + + faltndqie = (falouti(k) - falouti(k-1)) * tx1 + faltndi = (falouti(k) - dum1*falouti(k-1)) * tx1 + faltndni = (faloutni(k) - dum1*faloutni(k-1)) * tx1 + + faltndqce = (faloutc(k) - faloutc(k-1)) * tx1 + faltndc = (faloutc(k) - dum*faloutc(k-1)) * tx1 + faltndnc = (faloutnc(k)- dum*faloutnc(k-1)) * tx1 + +! add fallout terms to eulerian tendencies + + qitend(i,k) = qitend(i,k) - faltndi * tx2 + nitend(i,k) = nitend(i,k) - faltndni * tx2 + qctend(i,k) = qctend(i,k) - faltndc * tx2 + nctend(i,k) = nctend(i,k) - faltndnc * tx2 + + +! sedimentation tendencies for output + qcsedten(i,k) = qcsedten(i,k) - faltndc * tx2 + qisedten(i,k) = qisedten(i,k) - faltndi * tx2 + +! add terms to to evap/sub of cloud water + + qvlat(i,k) = qvlat(i,k) - (faltndqie-faltndi) * tx2 + +! if (lprint .and. k == 29) write(0,*)' qvlatb=',qvlat(i,k), +! &' tx2=',tx2,' faltndqie=',faltndqie,' faltndi=',faltndi +! for output + qisevap(i,k) = qisevap(i,k) + (faltndqie-faltndi) * tx2 + + + qvlat(i,k) = qvlat(i,k) - (faltndqce-faltndc) * tx2 +! if (lprint .and. k == 29) write(0,*)' qvlatc=',qvlat(i,k), +! &' tx2=',tx2,' faltndqce=',faltndqce,' faltndc=',faltndc + + qcsevap(i,k) = qcsevap(i,k) + (faltndqce-faltndc) * tx2 + + + tlat(i,k) = tlat(i,k) + ((faltndqie-faltndi)*xxls + & + (faltndqce-faltndc)*xxlv) * tx2 + + + dumi(i,k) = dumi(i,k) - faltndi * tx3 + dumni(i,k) = dumni(i,k) - faltndni * tx3 + dumc(i,k) = dumc(i,k) - faltndc * tx3 + dumnc(i,k) = dumnc(i,k) - faltndnc * tx3 + + Fni(K) = MAX(Fni(K)*tx1, Fni(K-1)*tx4) * pdel(i,K) + FI(K) = MAX(FI(K)*tx1, FI(K-1)*tx4) * pdel(i,K) + fnc(k) = max(fnc(k)*tx1, fnc(k-1)*tx4) * pdel(i,k) + Fc(K) = MAX(Fc(K)*tx1, Fc(K-1)*tx4) * pdel(i,K) + + end do ! end of k loop + +! units below are m/s +! cloud water/ice sedimentation flux at surface +! is added to precip flux at surface to get total precip (cloud + precip water) +! rate + +! if (lprint) write(0,*)' befend prect=',prect(i),' preci=',preci(i) + tx3 = tx2 / (g*1000._r8) + prect(i) = prect(i) + (faloutc(pver)+falouti(pver)) * tx3 + preci(i) = preci(i) + falouti(pver) * tx3 + +! if (lprint) write(0,*)' end prect=',prect(i),' preci=',preci(i) + + end do ! end of n loop + + +! end sedimentation +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! calculate sedimentation for rain and snow +! Anning Cheng 9/19/2016, forecast rain and snow +! reuse dummy variable for cloud water and ice +! iter =1 for fprcp >= 1 +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! initialize nstep for sedimentation sub-steps +! reuse dumc, dumi, dumnc, and dumni + if(fprcp==1) then + nstep = 1 + + do k=1,pver + +! tx1 = one / lcldm(i,k) +! tx2 = one / icldm(i,k) + dumc(i,k) = max((qrn(i,k)+qrtend(i,k)*deltat),zero) + dumi(i,k) = max((qsnw(i,k)+qnitend(i,k)*deltat),zero) + dumnc(i,k) = max((nrn(i,k)+nrtend(i,k)*deltat),zero) + dumni(i,k) = max((nsnw(i,k)+nstend(i,k)*deltat),zero) + +! if rain/snow mix ratio is zero so should number concentration + + if (dumi(i,k) < qsmall) then + dumi(i,k) = zero + dumni(i,k) = zero + endif + + if (dumc(i,k) < qsmall) then + dumc(i,k) = zero + dumnc(i,k) = zero + endif + +! make sure number concentration is a positive number to avoid +! taking root of negative + + dumnc(i,k) = max(dumnc(i,k),zero) + dumni(i,k) = max(dumni(i,k),zero) + +!....................................................................... +! get size distribution parameters for fallspeed calculations +!...................................................................... +! rain + + if (dumc(i,k) >= qsmall) then + lamr(k) = (pi*rhow*dumnc(i,k)/dumc(i,k))**oneb3 + n0r(k) = dumnc(i,k)*lamr(k) + +! check for slope +! change lammax and lammin for rain and snow +! adjust vars + + if (lamr(k) < lamminr) then + + lamr(k) = lamminr + + n0r(k) = lamr(k)**4*dumc(i,k)/(pi*rhow) + dumnc(i,k) = n0r(k)/lamr(k) + else if (lamr(k) > lammaxr) then + lamr(k) = lammaxr + n0r(k) = lamr(k)**4*dumc(i,k)/(pi*rhow) + dumnc(i,k) = n0r(k)/lamr(k) + end if + + +! 'final' values of number and mass weighted mean fallspeed for rain (m/s) + + tx1 = arn(i,k) / lamr(k)**br + tx2 = 9.1_r8*rhof(i,k) + unr(k) = min(tx1*cons4, tx2) + umr(k) = min(tx1*(cons5/6._r8),tx2) + + else + lamr(k) = zero + n0r(k) = zero + umr(k) = zero + unr(k) = zero + end if + +!...................................................................... +! snow + + if (dumi(i,k) >= qsmall) then + lams(k) = (cons6*cs*dumni(i,k)/ dumi(i,k))**(one/ds) + n0s(k) = dumni(i,k)*lams(k) + +! check for slope +! adjust vars + + if (lams(k) < lammins) then + lams(k) = lammins + n0s(k) = lams(k)**(ds+one)*dumi(i,k)/(cs*cons6) + dumni(i,k) = n0s(k)/lams(k) + + else if (lams(k) > lammaxs) then + lams(k) = lammaxs + n0s(k) = lams(k)**(ds+one)*dumi(i,k)/(cs*cons6) + dumni(i,k) = n0s(k)/lams(k) + end if + +! 'final' values of number and mass weighted mean fallspeed for snow (m/s) + + tx1 = asn(i,k) / lams(k)**bs + tx2 = 1.2_r8*rhof(i,k) + ums(k) = min(tx1*(cons8/6._r8), tx2) + uns(k) = min(tx1*cons7, tx2) + + else + lams(k) = zero + n0s(k) = zero + ums(k) = zero + uns(k) = zero + end if + + tx1 = g*rho(i,k) + fi(k) = tx1*ums(k) + fni(k) = tx1*uns(k) + fc(k) = tx1*umr(k) + fnc(k) = tx1*unr(k) + +! calculate number of split time steps to ensure courant stability criteria +! for sedimentation calculations + + rgvm = max(fi(k),fc(k),fni(k),fnc(k)) + nstep = max(int(rgvm*deltat/pdel(i,k)+one),nstep) + +! redefine dummy variables - sedimentation is calculated over grid-scale +! quantities to ensure conservation + + qrn(i,k) = (qrn(i,k) + qrtend(i,k)*deltat) + qsnw(i,k) = (qsnw(i,k) + qnitend(i,k)*deltat) + nrn(i,k) = max((nrn(i,k) + nrtend(i,k)*deltat),zero) + nsnw(i,k) = max((nsnw(i,k) + nstend(i,k)*deltat),zero) + + if (qrn(i,k) < qsmall) nrn(i,k) = zero + if (qsnw(i,k) < qsmall) nsnw(i,k) = zero + + enddo ! end of k loop + + tx2 = one / float(nstep) + tx3 = deltat*tx2 + do n = 1,nstep + + do k = 1,pver + falouti(k) = max(fi(k) * qsnw(i,k),zero) + faloutni(k) = max(fni(k) * nsnw(i,k),zero) + faloutc(k) = max(fc(k) * qrn(i,k),zero) + faloutnc(k) = max(fnc(k) * nrn(i,k),zero) + end do + +! top of model + + k = 1 + tx1 = one / pdel(i,k) + faltndi = falouti(k) * tx1 + faltndni = faloutni(k) * tx1 + faltndc = faloutc(k) * tx1 + faltndnc = faloutnc(k) * tx1 + +! add fallout terms to microphysical tendencies + +! qnitend(i,k) = qnitend(i,k) - faltndi * tx2 +! nstend(i,k) = nstend(i,k) - faltndni * tx2 +! qrtend(i,k) = qrtend(i,k) - faltndc * tx2 +! nrtend(i,k) = nrtend(i,k) - faltndnc * tx2 + +! sedimentation tendencies for output + + qsnw(i,k) = qsnw(i,k) - faltndi *tx3 + nsnw(i,k) = nsnw(i,k) - faltndni*tx3 + qrn(i,k) = qrn(i,k) - faltndc *tx3 + nrn(i,k) = nrn(i,k) - faltndnc*tx3 + + do k = 2,pver + +! for rain and snow + tx1 = one / pdel(i,k) +! dum = min(one, lcldm(i,k)/lcldm(i,k-1)) +! dum1 = min(one, icldm(i,k)/icldm(i,k-1)) + + faltndc = (faloutc(k)- faloutc(k-1)) * tx1 + faltndnc = (faloutnc(k)- faloutnc(k-1)) * tx1 + + faltndi = (falouti(k) - falouti(k-1)) * tx1 + faltndni = (faloutni(k) - faloutni(k-1)) * tx1 + + qsnw(i,k) = qsnw(i,k) - faltndi * tx3 + nsnw(i,k) = nsnw(i,k) - faltndni * tx3 + qrn(i,k) = qrn(i,k) - faltndc * tx3 + nrn(i,k) = nrn(i,k) - faltndnc * tx3 + + end do + + + tx5 = tx2 / (g*1000._r8) + prect(i) = prect(i) + (faloutc(pver)+falouti(pver)) * tx5 + preci(i) = preci(i) + (falouti(pver)) * tx5 + + end do ! end of n loop + end if !fprcp ==1 +! end sedimentation for rain and snow +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! get new update for variables that includes sedimentation tendency +! note : here dum variables are grid-average, NOT in-cloud + +! DONE UP TO HERE + do k=1,pver + if (fprcp==1) then +! calculate melting and freezing of precip +! melt snow at +2 C + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 > 275.15_r8) then + if (qsnw(i,k) > zero) then + +! make sure melting snow doesn't reduce temperature below threshold + dum = xlfocp*qsnw(i,k) + + if (tx1-dum < 273.15_r8) then + tx2 = tx1-275.15_r8 + dum = min(one,max(zero,tx2/dum)) + else + dum = one + end if + + qrn(i,k) = qrn(i,k) + dum*qsnw(i,k) + nrn(i,k) = nrn(i,k) + dum*nsnw(i,k) + qsnw(i,k) = (one-dum)*qsnw(i,k) + nsnw(i,k) = (one-dum)*nsnw(i,k) +! heating tendency + tmp = -xlf*dum*qsnw(i,k)/deltat + + tlat(i,k) = tlat(i,k) + tmp + + preci(i) = (one-dum)*preci(i) + end if + end if + +! freeze all rain at -5C for Arctic +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 < tmelt-five) then + + if (qrn(i,k) > zero) then + +! make sure freezing rain doesn't increase temperature above threshold + dum = xlfocp*qrn(i,k) + if (tx1+dum > tmelt-five) then + tx2 = -(tx1-(tmelt-5._r8)) + dum = min(one,max(zero,tx2/dum)) + else + dum = one + end if + + qsnw(i,k) = qsnw(i,k) + dum*qrn(i,k) + nsnw(i,k) = nsnw(i,k) + dum*nrn(i,k) + qrn(i,k) = (one-dum)*qrn(i,k) + nrn(i,k) = (one-dum)*nrn(i,k) +! heating tendency + tmp = xlf*dum*qrn(i,k)/deltat + + tlat(i,k) = tlat(i,k) + tmp + + preci(i) = preci(i) + dum*(prect(i)-preci(i)) + end if + end if + +! if rain/snow mix ratio is zero so should number concentration + + if (qsnw(i,k) < qsmall) then + nsnw(i,k) = zero + end if + + if (qrn(i,k) < qsmall) then + nrn(i,k) = zero + end if + +! make sure number concentration is a positive number to avoid +! taking root of negative + + nrn(i,k) = max(nrn(i,k),zero) + nsnw(i,k) = max(nsnw(i,k),zero) + +!....................................................................... + end if !fprcp ==1 + + + + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) + + + if (nccons) then + dumnc(i,k) = ncnst * irho(i,k) * lcldm(i,k) + endif + + if (nicons) then + dumni(i,k) = ninst * irho(i,k) * icldm(i,k) + endif + + if (dumc(i,k) < qsmall) dumnc(i,k) = zero + if (dumi(i,k) < qsmall) dumni(i,k) = zero + +! calculate instantaneous processes (melting, homogeneous freezing) + + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 > tmelt) then + if (dumi(i,k) > zero) then + +! limit so that melting does not push temperature below freezing + dum = dumi(i,k)*xlfocp + if (tx1-dum < tmelt) then + dum = (tx1-tmelt)*cpoxlf / dumi(i,k) + dum = max(zero, min(one, dum)) + else + dum = one + end if + + tx2 = dum*dumi(i,k)*dti + qctend(i,k) = qctend(i,k) + tx2 +! for output + melto(i,k) = tx2 + +! assume melting ice produces droplet +! mean volume radius of 8 micron + + nctend(i,k) = nctend(i,k) + three*tx2 + & / (four*pi*5.12e-16_r8*rhow) + + qitend(i,k) = ((one-dum)*dumi(i,k)-qi(i,k)) * dti + nitend(i,k) = ((one-dum)*dumni(i,k)-ni(i,k)) * dti + tlat(i,k) = tlat(i,k) - xlf*tx2 + + endif + endif + +! homogeneously freeze droplets between -35 C and -40 C + + tx1 = t(i,k) + tlat(i,k)*onebcp*deltat + if (tx1 < 233.15_r8) then + + if (dumc(i,k) > zero .and. qc(i,k) > zero) then + +! limit so that freezing does not push temperature above threshold + dum = dumc(i,k)*xlfocp + if (tx1+dum > 233.15_r8) then + dum = -(tx1-233.15_r8)*cpoxlf / dumc(i,k) + dum = max(zero, min(one, dum)) + else + dum = one + end if + + tx2 = dum*dumc(i,k)*dti + qitend(i,k) = qitend(i,k) + tx2 +! for output + homoo(i,k) = tx2 + +! assume 25 micron mean volume radius of homogeneously frozen droplets +! consistent with size of detrained ice in stratiform.F90 + + nitend(i,k) = nitend(i,k) + dum*three*dumc(i,k) + & / (four*3.14_r8*1.563e-14_r8* 500._r8) * dti + qctend(i,k) = ((one-dum)*dumc(i,k)-qc(i,k)) * dti + nctend(i,k) = ((one-dum)*dumnc(i,k)-nc(i,k)) * dti + tlat(i,k) = tlat(i,k) + xlf*tx2 + + endif + endif + +! remove any excess over-saturation, which is possible due to non-linearity when adding +! together all microphysical processes +! follow code similar to old CAM scheme +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! qsn = min(epsqs*esn/(p(i,k)-omeps*esn),one) +! if (qtmp > qsn .and. qsn > 0) then +! expression below is approximate since there may be ice deposition +! dum = (qtmp-qsn)/(one+cons27*qsn/(cpp*rv*ttmp**2))/deltat +! add to output cme +! now add to tendencies, partition between liquid and ice based on temperature +! now add to tendencies, partition between liquid and ice based on te +! dum = (qtmp-qsn)/(one+(xxls*dum1+xxlv*(one-dum1))**2 & +! *qsn/(cpp*rv*ttmp**2))/deltat +! +! qctend(i,k)=qctend(i,k)+dum*(one-dum1) +! for output +! qcreso(i,k)=dum*(one-dum1) +! qitend(i,k)=qitend(i,k)+dum*dum1 +! qireso(i,k)=dum*dum1 +! qvlat(i,k)=qvlat(i,k)-dum +! for output +! qvres(i,k)=-dum +! tlat(i,k)=tlat(i,k)+dum*(one-dum1)*xxlv+dum*dum1*xxls +! end if +!end if + +!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!1 + + +!............................................................................... +! calculate effective radius for pass to radiation code +! if no cloud water, default value is 10 micron for droplets, +! 25 micron for cloud ice + +! update cloud variables after instantaneous processes to get effective radius +! variables are in-cloud to calculate size dist parameters + + tx1 = one / lcldm(i,k) + tx2 = one / icldm(i,k) + dumc(i,k) = max(qc(i,k)+qctend(i,k)*deltat, zero) * tx1 + dumi(i,k) = max(qi(i,k)+qitend(i,k)*deltat, zero) * tx2 + dumnc(i,k) = max(nc(i,k)+nctend(i,k)*deltat, zero) * tx1 + dumni(i,k) = max(ni(i,k)+nitend(i,k)*deltat, zero) * tx2 + +! if ((dumc(i, k)*1e6 .gt. 1.0) .and. dumnc(i, k) .lt. 1e-20) then! + +! print *, 'dumnc', dumnc(i,k)*1e-6 +! print *, 'dumc', dumc(i, k)*1e6 +! print *, i, k + +! end if + + if (nccons) then + dumnc(i,k) = ncnst * irho(i,k) + end if + + if (nicons) then + dumni(i,k) = ninst * irho(i,k) + end if + + +! limit in-cloud mixing ratio of water and ice to reasonable value of 5 g kg-1 + + dumc(i,k) = min(dumc(i,k),5.e-3_r8) + dumi(i,k) = min(dumi(i,k),5.e-3_r8) + +!................... +! cloud ice effective radius + + if (dumi(i,k) >= qsmall) then +! add upper limit to in-cloud number concentration to prevent numerical error + dumni(i,k) = min(dumni(i,k),dumi(i,k)*1.e20_r8) + lami(k) = (cons1*ci* dumni(i,k)/dumi(i,k))**oneodi + +! miu_ice(k) = mui_hemp_l(lami(k)) + miu_ice(k) = max(min(0.008_r8*(lami(k)*0.01)**0.87_r8, + & 10.0_r8), 0.1_r8) + tx1 = one + miu_ice(k) + tx2 = one / gamma(tx1) + aux = (gamma(tx1+di)*tx2) ** oneodi + lami(k) = aux*lami(k) + n0i(k) = niic(i,k) * lami(k)**tx1 * tx2 + + if (lami(k) < lammini*aux) then + miu_ice(k) = zero + lami(k) = lammini + n0i(k) = lami(k)**(di+one)*dumi(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) +! adjust number conc if needed to keep mean size in reasonable range + nitend(i,k) = (niic(i,k)*icldm(i,k)-ni(i,k))/deltat + else if (lami(k) > lammaxi*aux) then + miu_ice(k) = zero + lami(k) = lammaxi + n0i(k) = lami(k)**(di+one)*dumi(i,k)/(ci*cons1) + niic(i,k) = n0i(k)/lami(k) + nitend(i,k) = (niic(i,k)*icldm(i,k)-ni(i,k))/deltat + end if + + effi(i,k) = 1.e6_r8*gamma(four+miu_ice(k)) + & / (two*lami(k)*gamma(three+miu_ice(k))) + else + effi(i,k) = 25._r8 + end if + +!................... +! cloud droplet effective radius + + + if (dumc(i,k) >= qsmall) then + +! add upper limit to in-cloud number concentration to prevent numerical error + dumnc(i,k) = min(dumnc(i,k),dumc(i,k)*1.e20_r8) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! set tendency to ensure minimum droplet concentration +! after update by microphysics, except when lambda exceeds bounds on mean drop +! size or if there is no cloud water + if (dumnc(i,k) < cdnl*irho(i,k)) then + nctend(i,k) = (cdnl*irho(i,k)*cldm(i,k)-nc(i,k))*dti + end if + dumnc(i,k) = max(dumnc(i,k),cdnl*irho(i,k)) + + if (nccons) then +! make sure nc is consistence with the constant N by adjusting tendency, need +! to multiply by cloud fraction +! note that nctend may be further adjusted below if mean droplet size is +! out of bounds + + nctend(i,k) = (ncnst*irho(i,k)*lcldm(i,k)-nc(i,k)) + & * dti + end if + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + tx1 = 0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k) = max(two, min(15._r8, one/(tx1*tx1)-one)) + + tx1 = gamma(pgam(k)+one) + tx2 = gamma(pgam(k)+four) + lamc(k) = (cr*dumnc(i,k)*tx2 + & / (dumc(i,k)*tx1))**oneb3 + lammin = (pgam(k)+one) / 50.e-6_r8 + lammax = (pgam(k)+one) / 2.e-6_r8 + if (lamc(k) < lammin) then + lamc(k) = lammin + ncic(i,k) = 6._r8*lamc(k)*lamc(k)*lamc(k)*dumc(i,k) + & * tx1 / (pirhow*tx2) +! adjust number conc if needed to keep mean size in reasonable range + nctend(i,k) = (ncic(i,k)*lcldm(i,k)-nc(i,k))*dti + + else if (lamc(k) > lammax) then + lamc(k) = lammax + ncic(i,k) = 6._r8*lamc(k)*lamc(k)*lamc(k)*dumc(i,k) + & * tx1 / (pirhow*tx2) +! adjust number conc if needed to keep mean size in reasonable range + nctend(i,k) = (ncic(i,k)*lcldm(i,k)-nc(i,k))*dti + end if + + effc(i,k) = tx2 / (gamma(pgam(k)+three)*lamc(k)*2.e6_r8) +!assign output fields for shape here + lamcrad(i,k) = lamc(k) + pgamrad(i,k) = pgam(k) + + else + effc(i,k) = 10._r8 + lamcrad(i,k) = zero + pgamrad(i,k) = zero + end if + + +! ice effective diameter for david mitchell's optics + deffi(i,k) = effi(i,k) * (rhoi / 917._r8*two) + + +!!! recalculate effective radius for constant number, in order to separate +! first and second indirect effects +! assume constant number of 10^8 kg-1 + + dumnc(i,k) = 1.e8 + + if (dumc(i,k) >= qsmall) then + tx1 = 0.0005714_r8*(ncic(i,k)/1.e6_r8*rho(i,k))+0.2714_r8 + pgam(k) = max(two, min(15._r8, one/(tx1*tx1)-one)) + tx2 = gamma(pgam(k)+four) + lamc(k) = (cr*dumnc(i,k)*tx2 + & / (dumc(i,k)*gamma(pgam(k)+one)))**oneb3 + lammin = (pgam(k)+one) / 50.e-6_r8 + lammax = (pgam(k)+one) / 2.e-6_r8 + if (lamc(k) < lammin) then + lamc(k) = lammin + else if (lamc(k) > lammax) then + lamc(k) = lammax + end if + effc_fn(i,k) = tx2/(gamma(pgam(k)+three)*lamc(k)*2.e6_r8) + + else + effc_fn(i,k) = 10._r8 + end if + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1! + + end do ! end of k loop after n loop + + + endif ! end of if (ltrue(i) == 0) loop + +! convert dt from sub-step back to full time step + + deltat = deltat*real(iter) + dti = one / deltat + + + do k=1,pver +! if updated q (after microphysics) is zero, then ensure updated n is also zero + + if (qc(i,k)+qctend(i,k)*deltat < qsmall) + & nctend(i,k) = -nc(i,k) * dti + if (qi(i,k)+qitend(i,k)*deltat < qsmall) + & nitend(i,k) = -ni(i,k) * dti + end do + + + end do !end big i loop3 + + +!print*, 'nctend', 1.0e-6*nctend*deltat + +! hm add rain/snow mixing ratio and number concentration as diagnostic + +#ifdef CAM + call outfld('QRAIN',qrout, pcols, lchnk) + call outfld('QSNOW',qsout, pcols, lchnk) + call outfld('NRAIN',nrout, pcols, lchnk) + call outfld('NSNOW',nsout, pcols, lchnk) +#endif + +! add snow output + do k=1,pver + do i = 1,ncol + if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then + dsout(i,k) = (pirhosn * nsout(i,k)/qsout(i,k)) **(-oneb3) + endif + end do + end do + +#ifdef CAM + call outfld('DSNOW',dsout, pcols, lchnk) + +! add ip fluxes as output fields + call outfld('MGFLXPRC',rflx, pcols, lchnk) + call outfld('MGFLXSNW',sflx, pcols, lchnk) +#endif + + do k=1,pver + do i = 1,ncol + if ((qc(i,k)+qctend(i,k)*deltat >= qsmall) .and. + & (cldmax(i,k) > zero) .and. (lcldm(i, k) > zero) .and. + & (nc(i,k)+nctend(i,k)*deltat > 0.0)) then + + tx1 = rho(i,k) / lcldm(i,k) + tx2 = (qc(i,k)+qctend(i,k)*deltat)*tx1*1000._r8 + dum = tx2 * tx2 * lcldm(i,k) + & / (0.109_r8*(nc(i,k)+nctend(i,k)*deltat) + & *tx1*1.e-6_r8*cldmax(i,k)) + else + dum = zero + end if + if (qi(i,k)+qitend(i,k)*deltat >= qsmall) then + dum1 = ((qi(i,k)+qitend(i,k)*deltat)*rho(i,k)/icldm(i,k) + & * 1000._r8/0.1_r8)**(one/0.63_r8) + & * icldm(i,k)/cldmax(i,k) + else + dum1 = zero + end if + + if (qsout(i,k) >= qsmall) then + dum1 = dum1 + (qsout(i,k)*rho(i,k)*1000._r8/0.1_r8) + & **(one/0.63_r8) + end if + + refl(i,k) = dum + dum1 + + if (rainrt(i,k) >= 0.001) then + dum = log10(rainrt(i,k)**6._r8) + 16._r8 + dum = 10._r8**(dum/10._r8) + else + dum = 0. + end if + + refl(i,k) = refl(i,k) + dum + + areflz(i,k) = refl(i,k) + + if (refl(i,k) > minrefl) then + refl(i,k) = 10._r8*log10(refl(i,k)) + else + refl(i,k) = -9999._r8 + end if + + if (refl(i,k) > mindbz) then + arefl(i,k) = refl(i,k) + frefl(i,k) = one + else + arefl(i,k) = zero + areflz(i,k) = zero + frefl(i,k) = zero + end if + + csrfl(i,k) = min(csmax,refl(i,k)) + + if (csrfl(i,k) > csmin) then + acsrfl(i,k) = refl(i,k) + fcsrfl(i,k) = one + else + acsrfl(i,k) = zero + fcsrfl(i,k) = zero + end if + + end do + end do + +#ifdef CAM + call outfld('REFL',refl, pcols, lchnk) + call outfld('AREFL',arefl, pcols, lchnk) + call outfld('AREFLZ',areflz, pcols, lchnk) + call outfld('FREFL',frefl, pcols, lchnk) + call outfld('CSRFL',csrfl, pcols, lchnk) + call outfld('ACSRFL',acsrfl, pcols, lchnk) + call outfld('FCSRFL',fcsrfl, pcols, lchnk) + + call outfld('RERCLD',rercld, pcols, lchnk) +#endif + +! averaging for snow and rain number and diameter + + do k=1,pver + do i = 1,ncol + qrout2(i,k) = zero + nrout2(i,k) = zero + drout2(i,k) = zero + freqr(i,k) = zero + + qsout2(i,k) = zero + nsout2(i,k) = zero + dsout2(i,k) = zero + freqs(i,k) = zero + + if (qrout(i,k) > 1.e-7_r8 .and. nrout(i,k) > zero) then + qrout2(i,k) = qrout(i,k) + nrout2(i,k) = nrout(i,k) + drout2(i,k) = (pirhow*nrout(i,k) / qrout(i,k))**(-oneb3) + freqr(i,k) = one + endif + if (qsout(i,k) > 1.e-7_r8 .and. nsout(i,k) > zero) then + qsout2(i,k) = qsout(i,k) + nsout2(i,k) = nsout(i,k) + dsout2(i,k) = (pirhosn*nsout(i,k) / qsout(i,k))**(-oneb3) + freqs(i,k) = one + endif + +! output activated liquid and ice (convert from #/kg -> #/m3) + ncai(i,k) = dum2i(i,k)*rho(i,k) + ncal(i,k) = dum2l(i,k)*rho(i,k) + end do + end do + + +#ifdef CAM + call outfld('NCAL',ncal, pcols,lchnk) + call outfld('NCAI',ncai, pcols,lchnk) + +!add averaged output fields. + call outfld('AQRAIN',qrout2, pcols,lchnk) + call outfld('AQSNOW',qsout2, pcols,lchnk) + call outfld('ANRAIN',nrout2, pcols,lchnk) + call outfld('ANSNOW',nsout2, pcols,lchnk) + call outfld('ADRAIN',drout2, pcols,lchnk) + call outfld('ADSNOW',dsout2, pcols,lchnk) + call outfld('FREQR',freqr, pcols,lchnk) + call outfld('FREQS',freqs, pcols,lchnk) +#endif + +!redefine fice here.... + do k=1,pver + do i=1,ncol + nfice(i,k) = zero + tx1 = qc(i,k) + qctend(i,k)*deltat ! water + tx2 = qi(i,k) + qitend(i,k)*deltat ! ice + dumfice = qsout(i,k) + qrout(i,k) + tx1 + tx2 + if (dumfice > zero) then + nfice(i,k) = (qsout(i,k) + tx2) / dumfice + endif + enddo + enddo + +#ifdef CAM + call outfld('FICE',nfice, pcols, lchnk) +#endif + + return + end subroutine mmicro_pcond + +#ifdef CAM + +!############################################################################## + + subroutine findsp1 (lchnk, ncol, q, t, p, tsp, qsp) +!----------------------------------------------------------------------- +! +! Purpose: +! find the wet bulb temperature for a given t and q +! in a longitude height section +! wet bulb temp is the temperature and spec humidity that is +! just saturated and has the same enthalpy +! if q > qs(t) then tsp > t and qsp = qs(tsp) < q +! if q < qs(t) then tsp < t and qsp = qs(tsp) > q +! +! Method: +! a Newton method is used +! first guess uses an algorithm provided by John Petch from the UKMO +! we exclude points where the physical situation is unrealistic +! e.g. where the temperature is outside the range of validity for the +! saturation vapor pressure, or where the water vapor pressure +! exceeds the ambient pressure, or the saturation specific humidity is +! unrealistic +! +! Author: P. Rasch +! +!----------------------------------------------------------------------- +! +! input arguments +! + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + + real(r8), intent(in) :: q(pcols,pver) + real(r8), intent(in) :: t(pcols,pver) + real(r8), intent(in) :: p(pcols,pver) +! +! output arguments +! + real(r8), intent(out) :: tsp(pcols,pver) + real(r8), intent(out) :: qsp(pcols,pver) +! +! local variables +! + integer i + integer k + logical lflg + integer iter + integer l + logical :: error_found + + real(r8) omeps + real(r8) trinv + real(r8) es + real(r8) desdt +! real(r8) desdp ! change in sat vap pressure wrt pressure + real(r8) dqsdt + real(r8) dgdt + real(r8) g + real(r8) weight(pcols) + real(r8) hlatsb + real(r8) hlatvp + real(r8) hltalt(pcols,pver) + real(r8) tterm + real(r8) qs + real(r8) tc + +! work variables + real(r8) t1, q1, dt, dq + real(r8) dtm, dqm + real(r8) qvd, a1, tmp + real(r8) rair + real(r8) r1b, c1, c2, c3 + real(r8) denom + real(r8) dttol + real(r8) dqtol + integer doit(pcols) + real(r8) enin(pcols), enout(pcols) + real(r8) tlim(pcols) + + omeps = one - epsqs + trinv = one / ttrice + a1 = 7.5_r8*log(10._r8) + rair = 287.04_r8 + c3 = rair*a1/cp + dtm = zero + dqm = zero + dttol = 1.e-4_r8 + dqtol = 1.e-4_r8 +! tmin = 173.16 ! the coldest temperature we can deal with +! +! max number of times to iterate the calculation + iter = 10 +! + do k = 1,pver + +! +! first guess on the wet bulb temperature +! + do i = 1,ncol + +#ifdef DEBUG + if ( (lchnk == lchnklook(nlook) ) .and. (i == + & icollook(nlook) ) ) then + write (iulog,*) ' ' + write (iulog,*) ' level, t, q, p', k, t(i,k), q(i,k), p(i,k) + endif +#endif + +! limit the temperature range to that relevant to the sat vap pres tables +#if ( defined WACCM_PHYS ) + tlim(i) = min(max(t(i,k),128._r8),373._r8) +#else + tlim(i) = min(max(t(i,k),173._r8),373._r8) +#endif + es = estblf(tlim(i)) + denom = p(i,k) - omeps*es + qs = epsqs*es/denom + doit(i) = 0 + enout(i) = one +! make sure a meaningful calculation is possible + if (p(i,k) > 5._r8*es .and. qs > zero .and. qs < 0.5_r8) then +! +! Saturation specific humidity +! + qs = min(epsqs*es/denom,one) +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! +! Weighting of hlat accounts for transition from water to ice +! polynomial expression approximates difference between es over +! water and es over ice from 0 to -ttrice (C) (min of ttrice is +! -40): required for accurate estimate of es derivative in transition +! range from ice to water also accounting for change of hlatv with t +! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw +! + tc = tlim(i) - tt0 + lflg = (tc >= -ttrice .and. tc < zero) + weight(i) = min(-tc*trinv,one) + hlatsb = hlatv + weight(i)*hlatf + hlatvp = hlatv - 2369.0_r8*tc + if (tlim(i) < tt0) then + hltalt(i,k) = hlatsb + else + hltalt(i,k) = hlatvp + end if + enin(i) = cp*tlim(i) + hltalt(i,k)*q(i,k) + +! make a guess at the wet bulb temp using a UKMO algorithm (from J. Petch) + tmp = q(i,k) - qs + c1 = hltalt(i,k)*c3 + c2 = (tlim(i) + 36._r8)**2 + r1b = c2/(c2 + c1*qs) + qvd = r1b*tmp + tsp(i,k) = tlim(i) + ((hltalt(i,k)/cp)*qvd) +#ifdef DEBUG + if ( (lchnk == lchnklook(nlook) ) .and. (i == + & icollook(nlook) ) ) then + write (iulog,*) ' relative humidity ', q(i,k)/qs + write (iulog,*) ' first guess ', tsp(i,k) + endif +#endif + es = estblf(tsp(i,k)) + qsp(i,k) = min(epsqs*es/(p(i,k) - omeps*es),one) + else + doit(i) = 1 + tsp(i,k) = tlim(i) + qsp(i,k) = q(i,k) + enin(i) = one + endif + end do +! +! now iterate on first guess +! + do l = 1, iter + dtm = 0 + dqm = 0 + do i = 1,ncol + if (doit(i) == 0) then + es = estblf(tsp(i,k)) +! +! Saturation specific humidity +! + qs = min(epsqs*es/(p(i,k) - omeps*es),one) +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! +! Weighting of hlat accounts for transition from water to ice +! polynomial expression approximates difference between es over +! water and es over ice from 0 to -ttrice (C) (min of ttrice is +! -40): required for accurate estimate of es derivative in transition +! range from ice to water also accounting for change of hlatv with t +! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw +! + tc = tsp(i,k) - tt0 + lflg = (tc >= -ttrice .and. tc < zero) + weight(i) = min(-tc*trinv,one) + hlatsb = hlatv + weight(i)*hlatf + hlatvp = hlatv - 2369.0_r8*tc + if (tsp(i,k) < tt0) then + hltalt(i,k) = hlatsb + else + hltalt(i,k) = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3)+tc*(pcf(4) + tc* + &pcf(5)))) + else + tterm = zero + end if + desdt = hltalt(i,k)*es/(rgasv*tsp(i,k)*tsp(i,k)) + tterm*trinv + dqsdt = (epsqs + omeps*qs)/(p(i,k) - omeps*es)*desdt +! g = cp*(tlim(i)-tsp(i,k)) + hltalt(i,k)*q(i,k)- hltalt(i,k)*qsp(i,k) + g = enin(i) - (cp*tsp(i,k) + hltalt(i,k)*qsp(i,k)) + dgdt = -(cp + hltalt(i,k)*dqsdt) + t1 = tsp(i,k) - g/dgdt + dt = abs(t1 - tsp(i,k))/t1 + tsp(i,k) = max(t1,tmin) + es = estblf(tsp(i,k)) + q1 = min(epsqs*es/(p(i,k) - omeps*es),one) + dq = abs(q1 - qsp(i,k))/max(q1,1.e-12_r8) + qsp(i,k) = q1 +#ifdef DEBUG + if ( (lchnk == lchnklook(nlook) ) .and. (i == + & icollook(nlook) ) ) then + write (iulog,*) ' rel chg lev, iter, t, q ', k, l, dt, dq, g + endif +#endif + dtm = max(dtm,dt) + dqm = max(dqm,dq) +! if converged at this point, exclude it from more iterations + if (dt < dttol .and. dq < dqtol) then + doit(i) = 2 + endif + enout(i) = cp*tsp(i,k) + hltalt(i,k)*qsp(i,k) +! bail out if we are too near the end of temp range +#if ( defined WACCM_PHYS ) + if (tsp(i,k) < 130.16_r8) then +#else + if (tsp(i,k) < 174.16_r8) then +#endif + doit(i) = 4 + endif + else + endif + end do + + if (dtm < dttol .and. dqm < dqtol) then + go to 10 + endif + + end do + 10 continue + + error_found = .false. + if (dtm > dttol .or. dqm > dqtol) then + do i = 1,ncol + if (doit(i) == 0) error_found = .true. + end do + if (error_found) then + do i = 1,ncol + if (doit(i) == 0) then + write (iulog,*) ' findsp not converging at point i, k ', i, k + write (iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), + & enin(i) + write (iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), + & enout(i) + call endrun ('FINDSP') + endif + end do + endif + endif + do i = 1,ncol + if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+ + &enout(i))) > 1.e-4_r8) then + error_found = .true. + endif + end do + if (error_found) then + do i = 1,ncol + if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+ + &enout(i))) > 1.e-4_r8) then + write (iulog,*) ' the enthalpy is not conserved for point ', i, + & k, enin(i), enout(i) + write (iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), + & enin(i) + write (iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), + & enout(i) + call endrun ('FINDSP') + endif + end do + endif + + end do + + return + end subroutine findsp1 + + + subroutine findsp1_water (lchnk, ncol, q, t, p, tsp, qsp) +!----------------------------------------------------------------------- +! +! Purpose: +! find the wet bulb temperature for a given t and q +! in a longitude height section +! wet bulb temp is the temperature and spec humidity that is +! just saturated and has the same enthalpy +! if q > qs(t) then tsp > t and qsp = qs(tsp) < q +! if q < qs(t) then tsp < t and qsp = qs(tsp) > q +! +! Method: +! a Newton method is used +! first guess uses an algorithm provided by John Petch from the UKMO +! we exclude points where the physical situation is unrealistic +! e.g. where the temperature is outside the range of validity for the +! saturation vapor pressure, or where the water vapor pressure +! exceeds the ambient pressure, or the saturation specific humidity is +! unrealistic +! +! Author: P. Rasch +! +!----------------------------------------------------------------------- +! +! input arguments +! + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + + real(r8), intent(in) :: q(pcols,pver) + real(r8), intent(in) :: t(pcols,pver) + real(r8), intent(in) :: p(pcols,pver) +! +! output arguments +! + real(r8), intent(out) :: tsp(pcols,pver) + real(r8), intent(out) :: qsp(pcols,pver) +! +! local variables +! + integer i + integer k + logical lflg + integer iter + integer l + logical :: error_found + + real(r8) omeps + real(r8) trinv + real(r8) es + real(r8) desdt +! real(r8) desdp ! change in sat vap pressure wrt pressure + real(r8) dqsdt + real(r8) dgdt + real(r8) g + real(r8) weight(pcols) + real(r8) hlatsb + real(r8) hlatvp + real(r8) hltalt(pcols,pver) + real(r8) tterm + real(r8) qs + real(r8) tc + +! work variables + real(r8) t1, q1, dt, dq + real(r8) dtm, dqm + real(r8) qvd, a1, tmp + real(r8) rair + real(r8) r1b, c1, c2, c3 + real(r8) denom + real(r8) dttol + real(r8) dqtol + integer doit(pcols) + real(r8) enin(pcols), enout(pcols) + real(r8) tlim(pcols) + + omeps = one - epsqs + a1 = 7.5_r8*log(10._r8) + rair = 287.04_r8 + c3 = rair*a1/cp + dtm = zero + dqm = zero + dttol = 1.e-4_r8 + dqtol = 1.e-4_r8 +! +! max number of times to iterate the calculation + iter = 8 +! + do k = 1,pver + +! +! first guess on the wet bulb temperature +! + do i = 1,ncol + +#ifdef DEBUG + if ( (lchnk == lchnklook(nlook) ) .and. (i == + & icollook(nlook) ) ) then + write (iulog,*) ' ' + write (iulog,*) ' level, t, q, p', k, t(i,k), q(i,k), p(i,k) + endif +#endif +! limit the temperature range to that relevant to the sat vap pres tables +#if ( defined WACCM_PHYS ) + tlim(i) = min(max(t(i,k),128._r8),373._r8) +#else + tlim(i) = min(max(t(i,k),173._r8),373._r8) +#endif + + es = polysvp(tlim(i),0) + denom = p(i,k) - omeps*es + qs = epsqs*es/denom + doit(i) = 0 + enout(i) = one +! make sure a meaningful calculation is possible + if (p(i,k) > 5._r8*es .and. qs > zero .and. qs < 0.5_r8) then +! +! Saturation specific humidity +! + qs = min(epsqs*es/denom,one) +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 + +! +! No icephs or water to ice transition +! + hlatvp = hlatv - 2369.0*(tlim(i)-tt0) + hlatsb = hlatv + if (tlim(i) < tt0) then + hltalt(i,k) = hlatsb + else + hltalt(i,k) = hlatvp + end if +!--xl + enin(i) = cp*tlim(i) + hltalt(i,k)*q(i,k) + +! make a guess at the wet bulb temp using a UKMO algorithm (from J. Petch) + tmp = q(i,k) - qs + c1 = hltalt(i,k)*c3 + c2 = (tlim(i) + 36._r8)**2 + r1b = c2/(c2 + c1*qs) + qvd = r1b*tmp + tsp(i,k) = tlim(i) + ((hltalt(i,k)/cp)*qvd) +#ifdef DEBUG + if ( (lchnk == lchnklook(nlook) ) .and. (i == + & icollook(nlook) ) ) then + write (iulog,*) ' relative humidity ', q(i,k)/qs + write (iulog,*) ' first guess ', tsp(i,k) + endif +#endif + es = polysvp(tsp(i,k),0) + qsp(i,k) = min(epsqs*es/(p(i,k) - omeps*es),one) + else + doit(i) = 1 + tsp(i,k) = tlim(i) + qsp(i,k) = q(i,k) + enin(i) = one + endif + end do +! +! now iterate on first guess +! + do l = 1, iter + dtm = 0 + dqm = 0 + do i = 1,ncol + if (doit(i) == 0) then + es = polysvp(tsp(i,k),0) +! +! Saturation specific humidity +! + qs = min(epsqs*es/(p(i,k) - omeps*es),one) +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! +! +! No icephs or water to ice transition +! + hlatvp = hlatv - 2369.0*(tsp(i,k)-tt0) + hlatsb = hlatv + if (tsp(i,k) < tt0) then + hltalt(i,k) = hlatsb + else + hltalt(i,k) = hlatvp + end if + desdt = hltalt(i,k)*es/(rgasv*tsp(i,k)*tsp(i,k)) + dqsdt = (epsqs + omeps*qs)/(p(i,k) - omeps*es)*desdt + g = enin(i) - (cp*tsp(i,k) + hltalt(i,k)*qsp(i,k)) + dgdt = -(cp + hltalt(i,k)*dqsdt) + t1 = tsp(i,k) - g/dgdt + dt = abs(t1 - tsp(i,k))/t1 + tsp(i,k) = max(t1,tmin) + + es = polysvp(tsp(i,k),0) + q1 = min(epsqs*es/(p(i,k) - omeps*es),one) + dq = abs(q1 - qsp(i,k))/max(q1,1.e-12_r8) + qsp(i,k) = q1 +#ifdef DEBUG + if ( (lchnk == lchnklook(nlook) ) .and. (i == + & icollook(nlook) ) ) then + write (iulog,*) ' rel chg lev, iter, t, q ', k, l, dt, dq, g + endif +#endif + dtm = max(dtm,dt) + dqm = max(dqm,dq) +! if converged at this point, exclude it from more iterations + if (dt < dttol .and. dq < dqtol) then + doit(i) = 2 + endif + enout(i) = cp*tsp(i,k) + hltalt(i,k)*qsp(i,k) +! bail out if we are too near the end of temp range +#if ( defined WACCM_PHYS ) + if (tsp(i,k) < 130.16_r8) then +#else + if (tsp(i,k) < 174.16_r8) then +#endif + doit(i) = 4 + endif + else + endif + end do + + if (dtm < dttol .and. dqm < dqtol) then + go to 10 + endif + + end do + 10 continue + + error_found = .false. + if (dtm > dttol .or. dqm > dqtol) then + do i = 1,ncol + if (doit(i) == 0) error_found = .true. + end do + if (error_found) then + do i = 1,ncol + if (doit(i) == 0) then + write (iulog,*) ' findsp not converging at point i, k ', i, k + write (iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), + & enin(i) + write (iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), + & enout(i) + call endrun ('FINDSP') + endif + end do + endif + endif + do i = 1,ncol + if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+ + &enout(i))) > 1.e-4_r8) then + error_found = .true. + endif + end do + if (error_found) then + do i = 1,ncol + if (doit(i) == 2 .and. abs((enin(i)-enout(i))/(enin(i)+ + &enout(i))) > 1.e-4_r8) then + write (iulog,*) ' the enthalpy is not conserved for point ', i, + & k, enin(i), enout(i) + write (iulog,*) ' t, q, p, enin ', t(i,k), q(i,k), p(i,k), + & enin(i) + write (iulog,*) ' tsp, qsp, enout ', tsp(i,k), qsp(i,k), + & enout(i) + call endrun ('FINDSP') + endif + end do + endif + + end do + + return + end subroutine findsp1_water +#endif +!--jtb : end of GEOS5 exclusion (begins at top of findsp) + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! error function in single precision +! +! Copyright(C) 1996 Takuya OOURA (email: ooura@mmm.t.u-tokyo.ac.jp). +! You may use, copy, modify this code for any purpose and +! without fee. You may distribute this ORIGINAL package. + + function derf(x) + implicit real (a - h, o - z) + real(r8) a,b,x + dimension a(0 : 64), b(0 : 64) + integer i,k + data (a(i), i = 0, 12) / 0.00000000005958930743d0, - + &0.00000000113739022964d0, 0.00000001466005199839d0, - + &0.00000016350354461960d0, 0.00000164610044809620d0, - + &0.00001492559551950604d0, 0.00012055331122299265d0, - + &0.00085483269811296660d0, 0.00522397762482322257d0, - + &0.02686617064507733420d0, 0.11283791670954881569d0, - + &0.37612638903183748117d0, 1.12837916709551257377d0 / + data (a(i), i = 13, 25) / 0.00000000002372510631d0, - + &0.00000000045493253732d0, 0.00000000590362766598d0, - + &0.00000006642090827576d0, 0.00000067595634268133d0, - + &0.00000621188515924000d0, 0.00005103883009709690d0, - + &0.00037015410692956173d0, 0.00233307631218880978d0, - + &0.01254988477182192210d0, 0.05657061146827041994d0, - + &0.21379664776456006580d0, 0.84270079294971486929d0 / + data (a(i), i = 26, 38) / 0.00000000000949905026d0, - + &0.00000000018310229805d0, 0.00000000239463074000d0, - + &0.00000002721444369609d0, 0.00000028045522331686d0, - + &0.00000261830022482897d0, 0.00002195455056768781d0, - + &0.00016358986921372656d0, 0.00107052153564110318d0, - + &0.00608284718113590151d0, 0.02986978465246258244d0, - + &0.13055593046562267625d0, 0.67493323603965504676d0 / + data (a(i), i = 39, 51) / 0.00000000000382722073d0, - + &0.00000000007421598602d0, 0.00000000097930574080d0, - + &0.00000001126008898854d0, 0.00000011775134830784d0, - + &0.00000111992758382650d0, 0.00000962023443095201d0, - + &0.00007404402135070773d0, 0.00050689993654144881d0, - + &0.00307553051439272889d0, 0.01668977892553165586d0, - + &0.08548534594781312114d0, 0.56909076642393639985d0 / + data (a(i), i = 52, 64) / 0.00000000000155296588d0, - + &0.00000000003032205868d0, 0.00000000040424830707d0, - + &0.00000000471135111493d0, 0.00000005011915876293d0, - + &0.00000048722516178974d0, 0.00000430683284629395d0, - + &0.00003445026145385764d0, 0.00024879276133931664d0, - + &0.00162940941748079288d0, 0.00988786373932350462d0, - + &0.05962426839442303805d0, 0.49766113250947636708d0 / + data (b(i), i = 0, 12) / -0.00000000029734388465d0, + & 0.00000000269776334046d0, -0.00000000640788827665d0, - + &0.00000001667820132100d0, -0.00000021854388148686d0, + & 0.00000266246030457984d0, 0.00001612722157047886d0, - + &0.00025616361025506629d0, 0.00015380842432375365d0, + & 0.00815533022524927908d0, -0.01402283663896319337d0, - + &0.19746892495383021487d0, 0.71511720328842845913d0 / + data (b(i), i = 13, 25) / -0.00000000001951073787d0, - + &0.00000000032302692214d0, 0.00000000522461866919d0, + & 0.00000000342940918551d0, -0.00000035772874310272d0, + & 0.00000019999935792654d0, 0.00002687044575042908d0, - + &0.00011843240273775776d0, -0.00080991728956032271d0, + & 0.00661062970502241174d0, 0.00909530922354827295d0, - + &0.20160072778491013140d0, 0.51169696718727644908d0 / + data (b(i), i = 26, 38) / 0.00000000003147682272d0, - + &0.00000000048465972408d0, 0.00000000063675740242d0, + & 0.00000003377623323271d0, -0.00000015451139637086d0, - + &0.00000203340624738438d0, 0.00001947204525295057d0, + & 0.00002854147231653228d0, -0.00101565063152200272d0, + & 0.00271187003520095655d0, 0.02328095035422810727d0, - + &0.16725021123116877197d0, 0.32490054966649436974d0 / + data (b(i), i = 39, 51) / 0.00000000002319363370d0, - + &0.00000000006303206648d0, -0.00000000264888267434d0, + & 0.00000002050708040581d0, 0.00000011371857327578d0, - + &0.00000211211337219663d0, 0.00000368797328322935d0, + & 0.00009823686253424796d0, -0.00065860243990455368d0, - + &0.00075285814895230877d0, 0.02585434424202960464d0, - + &0.11637092784486193258d0, 0.18267336775296612024d0 / + data (b(i), i = 52, 64) / -0.00000000000367789363d0, + & 0.00000000020876046746d0, -0.00000000193319027226d0, - + &0.00000000435953392472d0, 0.00000018006992266137d0, - + &0.00000078441223763969d0, -0.00000675407647949153d0, + & 0.00008428418334440096d0, -0.00017604388937031815d0, - + &0.00239729611435071610d0, 0.02064129023876022970d0, - + &0.06905562880005864105d0, 0.09084526782065478489d0 / + w = abs(x) + if (w .lt. 2.2d0) then + t = w * w + k = int(t) + t = t - k + k = k * 13 + y = ((((((((((((a(k) * t + a(k + 1)) * t + a(k + 2)) * t + a(k + + & 3)) * t + a(k + 4)) * t + a(k + 5)) * t + a(k + 6)) * t + a(k + + & 7)) * t + a(k + 8)) * t + a(k + 9)) * t + a(k + 10)) * t + a(k + + & 11)) * t + a(k + 12)) * w + else if (w .lt. 6.9d0) then + k = int(w) + t = w - k + k = 13 * (k - 2) + y = (((((((((((b(k) * t + b(k + 1)) * t + b(k + 2)) * t + b(k + + & 3)) * t + b(k + 4)) * t + b(k + 5)) * t + b(k + 6)) * t + b(k + + & 7)) * t + b(k + 8)) * t + b(k + 9)) * t + b(k + 10)) * t + b(k + + & 11)) * t + b(k + 12) + y = y * y + y = y * y + y = y * y + y = 1 - y * y + else + y = 1 + end if + if (x .lt. 0) y = -y + derf = y + end function derf +! + + +!cccccccccccccccccccccDONIFccccccccccccccccccccccccccccccccccccccccccccccccc + + + +!********************************** + FUNCTION MUI_HEMP(T) + + + real(r8) :: MUI_HEMP + REAL(r8), intent(in) :: T + REAL(r8) :: TC, mui, lambdai + TC=T-273.15_r8 + + TC=MIN(MAX(TC, -70.0), -15.0) + + if (TC > -27.0) then + lambdai = 6.8_r8*exp(-0.096_r8*TC) + else + lambdai = 24.8_r8*exp(-0.049_r8*TC) + end if + + mui=(0.13_r8*(lambdai**0.64_r8))-two + mui=max(mui, 1.5_r8) + MUI_HEMP=mui + + + END FUNCTION MUI_HEMP + + +!cccccccccccccccccccccDONIFccccccccccccccccccccccccccccccccccccccccccccccccc + + + +!********************************** + FUNCTION MUI_HEMP_L(lambda) + + + real(r8) :: MUI_HEMP_L + REAL(r8), intent(in) :: lambda + REAL(r8) :: TC, mui, lx + lx = lambda*0.01 + + mui=(0.008_r8*(lx**0.87_r8)) + mui=max(min(mui, 10.0_r8), 0.1_r8) + MUI_HEMP_L=mui !Anning for multithread to work + + + END FUNCTION MUI_HEMP_L + + + + + FUNCTION gamma_incomp(muice, x) + + + + real(r8) :: gamma_incomp + REAL(r8), intent(in) :: muice, x + REAL(r8) :: xog, kg, alfa, auxx + alfa = min(max(muice+1._r8, 1._r8), 20._r8) + + xog = log(alfa -0.3068_r8) + kg = 1.44818*(alfa**0.5357_r8) + auxx = max(min(kg*(log(x)-xog), 30._r8), -30._r8) + gamma_incomp= one/(one +exp(-auxx)) + gamma_incomp = max(gamma_incomp, 1.0e-20) + + END FUNCTION gamma_incomp + + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + + FUNCTION GAMMA(X) + +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +!D DOUBLE PRECISION FUNCTION DGAMMA(X) +!---------------------------------------------------------------------- +! +! THIS ROUTINE CALCULATES THE GAMMA FUNCTION FOR A REAL ARGUMENT X. +! COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1. +! THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE GAMMA +! FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS. COEFFICIENTS +! FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED. +! THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2. +! THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE +! COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE +! MACHINE-DEPENDENT CONSTANTS. +! +! +!******************************************************************* +!******************************************************************* +! +! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS +! +! BETA - RADIX FOR THE FLOATING-POINT REPRESENTATION +! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS +! XBIG - THE LARGEST ARGUMENT FOR WHICH GAMMA(X) IS REPRESENTABLE +! IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION +! GAMMA(XBIG) = BETA**MAXEXP +! XINF - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER; +! APPROXIMATELY BETA**MAXEXP +! EPS - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT +! 1.0+EPS .GT. 1.0 +! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT +! 1/XMININ IS MACHINE REPRESENTABLE +! +! APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE: +! +! BETA MAXEXP XBIG +! +! CRAY-1 (S.P.) 2 8191 966.961 +! CYBER 180/855 +! UNDER NOS (S.P.) 2 1070 177.803 +! IEEE (IBM/XT, +! SUN, ETC.) (S.P.) 2 128 35.040 +! IEEE (IBM/XT, +! SUN, ETC.) (D.P.) 2 1024 171.624 +! IBM 3033 (D.P.) 16 63 57.574 +! VAX D-FORMAT (D.P.) 2 127 34.844 +! VAX G-FORMAT (D.P.) 2 1023 171.489 +! +! XINF EPS XMININ +! +! CRAY-1 (S.P.) 5.45E+2465 7.11E-15 1.84E-2466 +! CYBER 180/855 +! UNDER NOS (S.P.) 1.26E+322 3.55E-15 3.14E-294 +! IEEE (IBM/XT, +! SUN, ETC.) (S.P.) 3.40E+38 1.19E-7 1.18E-38 +! IEEE (IBM/XT, +! SUN, ETC.) (D.P.) 1.79D+308 2.22D-16 2.23D-308 +! IBM 3033 (D.P.) 7.23D+75 2.22D-16 1.39D-76 +! VAX D-FORMAT (D.P.) 1.70D+38 1.39D-17 5.88D-39 +! VAX G-FORMAT (D.P.) 8.98D+307 1.11D-16 1.12D-308 +! +!******************************************************************* +!******************************************************************* +! +! ERROR RETURNS +! +! THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR +! WHEN OVERFLOW WOULD OCCUR. THE COMPUTATION IS BELIEVED +! TO BE FREE OF UNDERFLOW AND OVERFLOW. +! +! +! INTRINSIC FUNCTIONS REQUIRED ARE: +! +! INT, DBLE, EXP, LOG, REAL, SIN +! +! +! REFERENCES: AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL +! FUNCTIONS W. J. CODY, LECTURE NOTES IN MATHEMATICS, +! 506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON +! (ED.), SPRINGER VERLAG, BERLIN, 1976. +! +! COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND +! SONS, NEW YORK, 1968. +! +! LATEST MODIFICATION: OCTOBER 12, 1989 +! +! AUTHORS: W. J. CODY AND L. STOLTZ +! APPLIED MATHEMATICS DIVISION +! ARGONNE NATIONAL LABORATORY +! ARGONNE, IL 60439 +! +!---------------------------------------------------------------------- + INTEGER I,N + LOGICAL PARITY + + REAL(r8) :: gamma,CONV,FACT,RES,SUM,X,XDEN,XNUM,Y,Y1,YSQ,Z + real(r8) :: C(7),P(8),Q(8) +!---------------------------------------------------------------------- +! MATHEMATICAL CONSTANTS +!---------------------------------------------------------------------- + real(r8), parameter :: ONE=1.0E0_r8, HALF=0.5E0_r8, & + & TWELVE=12.0E0_r8, TWO=2.0E0_r8, & + & ZERO=0.0E0_r8, & + & PI=3.1415926535897932384626434E0_r8, & + & SQRTPI=0.9189385332046727417803297E0_r8 + +!D DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/, +!D 1 SQRTPI/0.9189385332046727417803297D0/, +!D 2 PI/3.1415926535897932384626434D0/ +!---------------------------------------------------------------------- +! MACHINE DEPENDENT PARAMETERS +!---------------------------------------------------------------------- + real(r8), parameter :: XBIG=35.040E0_r8, XMININ=1.18E-38_r8, & + & EPS=1.19E-7_r8, XINF=3.4E38_r8 + +!D DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/, +!D 1 XINF/1.79D308/ +!---------------------------------------------------------------------- +! NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX +! APPROXIMATION OVER (1,2). +!---------------------------------------------------------------------- + DATA P/-1.71618513886549492533811E+0_r8, + &2.47656508055759199108314E+1_r8, -3.79804256470945635097577E+2_r8, + &6.29331155312818442661052E+2_r8, 8.66966202790413211295064E+2_r8,- + &3.14512729688483675254357E+4_r8, -3.61444134186911729807069E+4_r8, + &6.64561438202405440627855E+4_r8/ + DATA Q/-3.08402300119738975254353E+1_r8, + &3.15350626979604161529144E+2_r8, -1.01515636749021914166146E+3_r8, + &-3.10777167157231109440444E+3_r8, 2.25381184209801510330112E+4_r8, + &4.75584627752788110767815E+3_r8, -1.34659959864969306392456E+5_r8, + &-1.15132259675553483497211E+5_r8/ +!D DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1, +!D 1 -3.79804256470945635097577D+2,6.29331155312818442661052D+2, +!D 2 8.66966202790413211295064D+2,-3.14512729688483675254357D+4, +!D 3 -3.61444134186911729807069D+4,6.64561438202405440627855D+4/ +!D DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2, +!D 1 -1.01515636749021914166146D+3,-3.10777167157231109440444D+3, +!D 2 2.25381184209801510330112D+4,4.75584627752788110767815D+3, +!D 3 -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/ +!---------------------------------------------------------------------- +! COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF). +!---------------------------------------------------------------------- + DATA C/-1.910444077728E-03_r8,8.4171387781295E-04_r8, - + &5.952379913043012E-04_r8,7.93650793500350248E-04_r8, - + &2.777777777777681622553E-03_r8,8.333333333333333331554247E-02_r8, + & 5.7083835261E-03_r8/ +!D DATA C/-1.910444077728D-03,8.4171387781295D-04, +!D 1 -5.952379913043012D-04,7.93650793500350248D-04, +!D 2 -2.777777777777681622553D-03,8.333333333333333331554247D-02, +!D 3 5.7083835261D-03/ +!---------------------------------------------------------------------- +! STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT +!---------------------------------------------------------------------- + CONV(I) = REAL(I,r8) +!D CONV(I) = DBLE(I) + PARITY = .FALSE. + FACT = ONE + N = 0 + Y = X + IF(Y <= ZERO) THEN +!---------------------------------------------------------------------- +! ARGUMENT IS NEGATIVE +!---------------------------------------------------------------------- + Y = -X + Y1 = AINT(Y) + RES = Y - Y1 + IF(RES.NE.ZERO)THEN + IF(Y1.NE.AINT(Y1*HALF)*TWO) PARITY = .TRUE. + FACT = -PI/SIN(PI*RES) + Y = Y + ONE + ELSE + RES=XINF + GOTO 900 + ENDIF + ENDIF +!---------------------------------------------------------------------- +! ARGUMENT IS POSITIVE +!---------------------------------------------------------------------- + IF(Y.LT.EPS)THEN +!---------------------------------------------------------------------- +! ARGUMENT .LT. EPS +!---------------------------------------------------------------------- + IF(Y.GE.XMININ)THEN + RES = ONE/Y + ELSE + RES = XINF + GOTO 900 + ENDIF + ELSEIF(Y.LT.TWELVE)THEN + Y1 = Y + IF(Y.LT.ONE)THEN +!---------------------------------------------------------------------- +! 0.0 .LT. ARGUMENT .LT. 1.0 +!---------------------------------------------------------------------- + Z = Y + Y = Y + ONE + ELSE +!---------------------------------------------------------------------- +! 1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY +!---------------------------------------------------------------------- + N = INT(Y) - 1 + Y = Y - CONV(N) + Z = Y - ONE + ENDIF +!---------------------------------------------------------------------- +! EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0 +!---------------------------------------------------------------------- + XNUM = ZERO + XDEN = ONE + DO 260 I=1,8 + XNUM = (XNUM+P(I))*Z + XDEN = XDEN*Z + Q(I) +260 CONTINUE + RES = XNUM/XDEN + ONE + IF(Y1.LT.Y)THEN +!---------------------------------------------------------------------- +! ADJUST RESULT FOR CASE 0.0 .LT. ARGUMENT .LT. 1.0 +!---------------------------------------------------------------------- + RES = RES/Y1 + ELSEIF(Y1.GT.Y)THEN +!---------------------------------------------------------------------- +! ADJUST RESULT FOR CASE 2.0 .LT. ARGUMENT .LT. 12.0 +!---------------------------------------------------------------------- + DO 290 I=1,N + RES = RES*Y + Y = Y + ONE +290 CONTINUE + ENDIF + ELSE +!---------------------------------------------------------------------- +! EVALUATE FOR ARGUMENT .GE. 12.0, +!---------------------------------------------------------------------- + IF(Y.LE.XBIG)THEN + YSQ = Y*Y + SUM = C(7) + DO 350 I=1,6 + SUM = SUM / YSQ + C(I) +350 CONTINUE + SUM = SUM / Y - Y + SQRTPI + SUM = SUM + (Y-HALF)*LOG(Y) + RES = EXP(SUM) + ELSE + RES = XINF + GOTO 900 + ENDIF + ENDIF +!---------------------------------------------------------------------- +! FINAL ADJUSTMENTS AND RETURN +!---------------------------------------------------------------------- + IF(PARITY) RES = -RES + IF(FACT.NE.ONE) RES = FACT/RES +900 GAMMA = RES +!D900 DGAMMA = RES + RETURN +! ---------- LAST LINE OF GAMMA ---------- + END function gamma + + + + end module cldwat2m_micro diff --git a/gsmphys/cnvc90.f b/gsmphys/cnvc90.f new file mode 100644 index 00000000..82e75553 --- /dev/null +++ b/gsmphys/cnvc90.f @@ -0,0 +1,90 @@ + SUBROUTINE CNVC90(CLSTP,IM,IX,RN,KBOT,KTOP,KM,PRSI, + 1 ACV,ACVB,ACVT,CV,CVB,CVT) +cc + USE MACHINE, ONLY :kind_phys + implicit none + integer i,ibot,im,itop,km,lc,lz,n,ncc,ix + real(kind=kind_phys) ah,cc1,cc2,clstp,cvb0,p1,p2,rkbot,rktop,val +cc + integer KBOT(IM),KTOP(IM) + real(kind=kind_phys) RN(IM), ACV(IM), ACVB(IM), ACVT(IM), + & CV(IM), CVB(IM), CVT(IM) + real(kind=kind_phys) prsi(ix,km+1) + integer NMD(IM) + real(kind=kind_phys) PMD(IM) +! + real (kind=kind_phys), parameter :: cons_100=100.0 + real(kind=kind_phys) R_KBOT_I, R_KTOP_I +! + PARAMETER(NCC=9) + real(kind=kind_phys) CC(NCC),P(NCC) + DATA CC/0.,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8/ + DATA P/.14,.31,.70,1.6,3.4,7.7,17.,38.,85./ + DATA CVB0/100./ +! + LZ=0 + LC=0 + IF(CLSTP.GE.1000.) LZ=1 + IF(CLSTP.GE.1100..OR.(CLSTP.LT.1000..AND.CLSTP.GE.100.)) LC=1 + AH=MOD(CLSTP,cons_100) + IF(LZ.NE.0) THEN + DO I=1,IM + ACV(I) = 0. + ACVB(I) = CVB0 + ACVT(I) = 0. + ENDDO + ENDIF + IF(LC.NE.0) THEN + DO I=1,IM + IF(RN(I).GT.0.) THEN + ACV(I) = ACV(I)+RN(I) + R_KBOT_I= KBOT(I) + ACVB(I) = MIN(ACVB(I),R_KBOT_I) + R_KTOP_I= KTOP(I) + ACVT(I) = MAX(ACVT(I),R_KTOP_I) + ENDIF + ENDDO + ENDIF + IF(AH.GT.0.01.AND.AH.LT.99.99) THEN + DO I=1,IM + IF(ACV(I).GT.0.) THEN +! CVB(I) = ACVB(I) +! CVT(I) = ACVT(I) +c.... convert cvt and cvb to pressures + ITOP = NINT(ACVT(I)) + CVT(I) = PRSI(i,ITOP+1) + IBOT = NINT(ACVB(I)) + CVB(I) = PRSI(i,IBOT) + ELSE +! CVB(I) = CVB0 + CVB(I) = 0. + CVT(I) = 0. + ENDIF + PMD(I) = ACV(I)*(24.E+3/AH) + NMD(I) = 0 + ENDDO + DO N=1,NCC + DO I=1,IM + IF(PMD(I).GT.P(N)) NMD(I) = N + ENDDO + ENDDO + DO I=1,IM + IF(NMD(I).EQ.0) THEN + CV(I) = 0. +! CVB(I) = CVB0 + CVB(I) = 0. + CVT(I) = 0. + ELSEIF(NMD(I).EQ.NCC) THEN + CV(I) = CC(NCC) + ELSE + CC1 = CC(NMD(I)) + CC2 = CC(NMD(I)+1) + P1 = P(NMD(I)) + P2 = P(NMD(I)+1) + CV(I) = CC1 + (CC2-CC1)*(PMD(I)-P1)/(P2-P1) + ENDIF + ENDDO + ENDIF + RETURN + END + diff --git a/gsmphys/co2hc.f b/gsmphys/co2hc.f new file mode 100644 index 00000000..08c353db --- /dev/null +++ b/gsmphys/co2hc.f @@ -0,0 +1,1738 @@ +!*********************************************************************** +! File co2hc.f +!*********************************************************************** +! File history +! Feb 28, 2008: changes by RAA in subroutine co2cc in O interpolation +! to parameterization grid +! Jan 2007: Made by Rashid Akmaev from three predecessor files: +! co2pro.f +! qnir1.f +! co2c.f +! Apr 06 2012 Henry Juang, initial implement for NEMS +! Oct 12 2012 Jun Wang change reading files by 1 pe reading and +! broardcasting to all pes +! +! Contains modules and subroutines +! 1) To create a global mean vertical CO2 profile either according +! to Fomichev et al. (1998) model or (loosely) according to +! CRISTA-1/2 satellite data of Grossmann (2005) and Kostsov +! (2005), both personal communications. +! 2) To calculate IR CO2 cooling in 15-mu band by an updated version +! of Fomichev et al. (1998) code +! 3) To calculate CO2 heating rates in the near infrared (Ogibalov +! and Fomichev, 2003). +! +! Contains +! module co2pro_mod - data for global CO2 profiles +! module co2c_mod - data for IR cooling +! module qnir_mod - data for NIR heating +! subroutine co2pro_pre - prepare Fomichev profile +! subroutine co2cri_pre - prepare CRISTA profile +! subroutine co2cc - calculate IR cooling +! subroutine co2cin - initialize IR cooling calculations +! subroutine qnirc - calculate NIR heating +! +! Calls spline interpolation routines from file splin.f +! splin1 +! splin2 +! +! Reads reference IR matrices from 4 files +! coeff_lte.150 +! coeff_lte.360 +! coeff_lte.540 +! coeff_lte.720 +! +!*********************************************************************** + + module co2pro_mod + +! Module to keep data and procedures for preparation of CO2 vertical +! profile based on CRISTA data (or F1998 model) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! May 2005: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Profile on model grid +!hmhj real,dimension(:),allocatable,save:: co2my + real,dimension(:),allocatable:: co2my + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Profile parameters +! +! - Surface VMR + integer,parameter:: ico2am = 361 +! This is a cut from radparm for reference as of Dec 7, 2006 +! CO2 calculation parameters introduced into mtparm Aug 7, 2002, moved +! here Sep 13, 2002 +! +! parameter (ico2am = 313) +! parameter (ico2am = 720) +! parameter (ico2am = 360) +! 1980(1975) +! parameter (ico2am = 331) +! 2000(1995) +! parameter (ico2am = 361) +! Test +! parameter (ico2am = 400) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! - Start diffusive equilibrium at +! real, parameter:: xdiff=17.75 + real, parameter:: xdiff=16.5 + integer, parameter:: idiff=int(4.*xdiff+1.5) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Initial parameters +! +! Victor's initial x-grid 0-20 and CO2 and pressure profiles on it after +! Fomichev et al. (1998). Pressure calculated in co2cin + integer,parameter:: ivic0=81 +!hmhj real,dimension(ivic0),save:: co2vic,pvic + real,dimension(ivic0):: co2vic,pvic + real,parameter,dimension(ivic0):: xvic0=(/ & + & .00, .25, .50, .75, 1.00, 1.25, 1.50, 1.75, & + & 2.00, 2.25, 2.50, 2.75, 3.00, 3.25, 3.50, 3.75, & + & 4.00, 4.25, 4.50, 4.75, 5.00, 5.25, 5.50, 5.75, & + & 6.00, 6.25, 6.50, 6.75, 7.00, 7.25, 7.50, 7.75, & + & 8.00, 8.25, 8.50, 8.75, 9.00, 9.25, 9.50, 9.75, & + & 10.00, 10.25, 10.50, 10.75, 11.00, 11.25, 11.50, 11.75, & + & 12.00, 12.25, 12.50, 12.75, 13.00, 13.25, 13.50, 13.75, & + & 14.00, 14.25, 14.50, 14.75, 15.00, 15.25, 15.50, 15.75, & + & 16.00, 16.25, 16.50, 16.75, 17.00, 17.25, 17.50, 17.75, & + & 18.00, 18.25, 18.50, 18.75, 19.00, 19.25, 19.50, 19.75, & + & 20.00 /) +! Victor's initial profile + real,parameter,dimension(ivic0):: co2vi0=(/ & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, 3.600E-04, & + & 3.580E-04, 3.540E-04, 3.500E-04, 3.410E-04, 3.280E-04, & + & 3.110E-04, 2.930E-04, 2.750E-04, 2.560E-04, 2.370E-04, & + & 2.180E-04, 1.990E-04, 1.800E-04, 1.610E-04, 1.420E-04, & + & 1.240E-04, 1.060E-04, 9.000E-05, 7.800E-05, 6.800E-05, & + & 5.900E-05, 5.100E-05, 4.400E-05, 3.700E-05, 3.000E-05, & + & 2.400E-05, 1.900E-05, 1.400E-05, 1.000E-05, 7.000E-06, & + & 5.000E-06 /) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! interface +! subroutine splin1(x1,y1,x2,y2,n1,n2) +! implicit none +! integer,intent(in):: n1,n2 +! real,intent(in):: x1(n1),y1(n1),x2(n2) +! real,intent(out):: y2(n2) +! end subroutine splin1 +! end interface + + end module co2pro_mod + +!*********************************************************************** + + module co2c_mod + +! Module to keep data related to CO2 cooling calculations + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Dec 2006: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Fixed parameters +! +! -Transition log-pressure level from recurrence relation to +! cooling-to-space (should be greater or equal to 16.5, Victor +! recommends 16.5) +! -Corresponding array index for full parameterization grid +! + real,parameter:: xinter=16.5 + integer,parameter:: ivict=int(4.*xinter+1.1),itm50=ivict-50 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Variables prepared in co2cin +! -Number of first model layer (counted upwards) above xinter +! +!hmhj integer,save:: lraint + integer lraint +! +! -Cooling matrices on fixed Victor grid +! +!hmhj real,dimension(43,57),save:: vamat,vbmat + real,dimension(43,57):: vamat,vbmat +! +! -Escape functions for recurrence formula on Victor grid needed for +! x > 12.5 (index=1-itm50) +! +!hmhj real,save:: alvic(itm50) + real alvic(itm50) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + interface + subroutine splin1(x1,y1,x2,y2,n1,n2) + implicit none + integer,intent(in):: n1,n2 + real,intent(in):: x1(n1),y1(n1),x2(n2) + real,intent(out):: y2(n2) + end subroutine splin1 +! + subroutine splin2(x1,y1,x2,y2,n1,n2,jm,km) + implicit none + integer,intent(in):: jm,km,n1,n2 + real,intent(in):: x1(n1),y1(jm,n1),x2(n2) + real,intent(out):: y2(jm,n2) + end subroutine splin2 + end interface + + end module co2c_mod + +!*********************************************************************** + + module qnir_mod + +! Module to keep data and a procedure necessary for calculation of +! CO2 heating in NIR after Ogibalov and Fomichev (2003) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! May 16, 2003: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! CO2 vertical column amounts (calculated in co2cin) on param. +! log-pressure grid x=2-14, dx=.25, index=1-49 +! + integer,parameter:: imnir=49 +!hmhj real,save:: co2nir(imnir) + real co2nir(imnir) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Parameterization data +! Log-pressure grid for heating calculation +! + real,parameter,dimension(imnir):: xnir=(/ & + & 2.00, 2.25, 2.50, 2.75, 3.00, 3.25, 3.50, & + & 3.75, 4.00, 4.25, 4.50, 4.75, 5.00, 5.25, & + & 5.50, 5.75, 6.00, 6.25, 6.50, 6.75, 7.00, & + & 7.25, 7.50, 7.75, 8.00, 8.25, 8.50, 8.75, & + & 9.00, 9.25, 9.50, 9.75, 10.00, 10.25, 10.50, & + & 10.75, 11.00, 11.25, 11.50, 11.75, 12.00, 12.25, & + & 12.50, 12.75, 13.00, 13.25, 13.50, 13.75, 14.00/) +! +! Above x=14 the heating rate is extrapolated to 0 at xtopn +! + real,parameter:: xtopn=15.5,rdxnir=1./(xtopn-xnir(imnir)) +! +! Tables of log(CO2 column amounts) and normalized heating rates +! taken and rearranged from Victor's pco2nir +! + real,parameter,dimension(10,imnir):: lnco2n=reshape((/ & + & 47.5235, 48.0588, 48.5941, 49.1295, 49.6653, & + & 50.2009, 50.7366, 51.2721, 51.8074, 52.3427, & + & 47.2737, 47.8092, 48.3446, 48.8802, 49.4155, & + & 49.9510, 50.4867, 51.0215, 51.5578, 52.0931, & + & 47.0244, 47.5598, 48.0954, 48.6304, 49.1661, & + & 49.7016, 50.2373, 50.7729, 51.3082, 51.8435, & + & 46.7749, 47.3102, 47.8456, 48.3809, 48.9168, & + & 49.4522, 49.9878, 50.5233, 51.0590, 51.5941, & + & 46.5254, 47.0611, 47.5963, 48.1318, 48.6676, & + & 49.2027, 49.7383, 50.2737, 50.8096, 51.3445, & + & 46.2756, 46.8111, 47.3467, 47.8820, 48.4173, & + & 48.9531, 49.4886, 50.0241, 50.5596, 51.0951, & + & 46.0263, 46.5615, 47.0973, 47.6327, 48.1682, & + & 48.7035, 49.2393, 49.7747, 50.3101, 50.8458, & + & 45.7769, 46.3125, 46.8479, 47.3833, 47.9189, & + & 48.4541, 48.9898, 49.5255, 50.0607, 50.5964, & + & 45.5275, 46.0626, 46.5987, 47.1342, 47.6693, & + & 48.2050, 48.7409, 49.2762, 49.8115, 50.3468, & + & 45.2780, 45.8133, 46.3488, 46.8846, 47.4198, & + & 47.9553, 48.4906, 49.0262, 49.5621, 50.0974, & + & 45.0284, 45.5639, 46.0995, 46.6350, 47.1704, & + & 47.7061, 48.2415, 48.7776, 49.3125, 49.8481, & + & 44.7791, 45.3146, 45.8502, 46.3853, 46.9209, & + & 47.4563, 47.9922, 48.5274, 49.0633, 49.5987, & + & 44.5294, 45.0650, 45.6006, 46.1360, 46.6717, & + & 47.2070, 47.7425, 48.2781, 48.8136, 49.3490, & + & 44.2797, 44.8156, 45.3511, 45.8866, 46.4226, & + & 46.9575, 47.4930, 48.0287, 48.5637, 49.0996, & + & 44.0305, 44.5667, 45.1019, 45.6371, 46.1730, & + & 46.7082, 47.2435, 47.7791, 48.3145, 48.8502, & + & 43.7816, 44.3173, 44.8521, 45.3877, 45.9233, & + & 46.4585, 46.9944, 47.5297, 48.0653, 48.6004, & + & 43.5320, 44.0676, 44.6027, 45.1384, 45.6740, & + & 46.2096, 46.7449, 47.2802, 47.8159, 48.3513, & + & 43.2825, 43.8177, 44.3540, 44.8889, 45.4245, & + & 45.9598, 46.4951, 47.0312, 47.5664, 48.1020, & + & 43.0329, 43.5684, 44.1047, 44.6395, 45.1749, & + & 45.7103, 46.2456, 46.7812, 47.3172, 47.8524, & + & 42.7836, 43.3188, 43.8544, 44.3899, 44.9253, & + & 45.4609, 45.9964, 46.5323, 47.0677, 47.6029, & + & 42.5341, 43.0693, 43.6049, 44.1405, 44.6758, & + & 45.2112, 45.7469, 46.2820, 46.8176, 47.3533, & + & 42.2842, 42.8200, 43.3555, 43.8906, 44.4266, & + & 44.9619, 45.4974, 46.0329, 46.5681, 47.1039, & + & 42.0343, 42.5702, 43.1057, 43.6412, 44.1763, & + & 44.7123, 45.2478, 45.7833, 46.3187, 46.8546, & + & 41.7851, 42.3208, 42.8563, 43.3917, 43.9273, & + & 44.4626, 44.9982, 45.5337, 46.0695, 46.6050, & + & 41.5355, 42.0709, 42.6062, 43.1418, 43.6773, & + & 44.2129, 44.7483, 45.2838, 45.8193, 46.3548, & + & 41.2854, 41.8209, 42.3564, 42.8920, 43.4274, & + & 43.9626, 44.4982, 45.0339, 45.5693, 46.1052, & + & 41.0354, 41.5714, 42.1066, 42.6420, 43.1775, & + & 43.7130, 44.2481, 44.7841, 45.3194, 45.8548, & + & 40.7855, 41.3210, 41.8560, 42.3920, 42.9272, & + & 43.4629, 43.9983, 44.5339, 45.0695, 45.6048, & + & 40.5352, 41.0705, 41.6061, 42.1417, 42.6770, & + & 43.2125, 43.7480, 44.2833, 44.8190, 45.3543, & + & 40.2843, 40.8201, 41.3556, 41.8906, 42.4264, & + & 42.9621, 43.4974, 44.0328, 44.5685, 45.1039, & + & 40.0335, 40.5690, 41.1046, 41.6405, 42.1755, & + & 42.7112, 43.2466, 43.7826, 44.3178, 44.8530, & + & 39.7821, 40.3180, 40.8534, 41.3889, 41.9246, & + & 42.4599, 42.9956, 43.5308, 44.0661, 44.6023, & + & 39.5306, 40.0662, 40.6014, 41.1370, 41.6729, & + & 42.2078, 42.7434, 43.2791, 43.8149, 44.3501, & + & 39.2785, 39.8138, 40.3493, 40.8848, 41.4203, & + & 41.9552, 42.4910, 43.0267, 43.5622, 44.0977, & + & 39.0251, 39.5607, 40.0964, 40.6314, 41.1671, & + & 41.7027, 42.2382, 42.7733, 43.3091, 43.8444, & + & 38.7707, 39.3061, 39.8421, 40.3771, 40.9128, & + & 41.4485, 41.9836, 42.5191, 43.0550, 43.5902, & + & 38.5153, 39.0507, 39.5867, 40.1219, 40.6571, & + & 41.1928, 41.7279, 42.2641, 42.7993, 43.3347, & + & 38.2577, 38.7934, 39.3288, 39.8642, 40.3996, & + & 40.9352, 41.4712, 42.0061, 42.5418, 43.0771, & + & 37.9979, 38.5335, 39.0689, 39.6045, 40.1402, & + & 40.6754, 41.2109, 41.7466, 42.2820, 42.8175, & + & 37.7354, 38.2710, 38.8062, 39.3420, 39.8773, & + & 40.4129, 40.9481, 41.4838, 42.0192, 42.5544, & + & 37.4684, 38.0036, 38.5390, 39.0747, 39.6102, & + & 40.1457, 40.6812, 41.2169, 41.7525, 42.2877, & + & 37.1969, 37.7321, 38.2674, 38.8029, 39.3387, & + & 39.8744, 40.4095, 40.9450, 41.4800, 42.0164, & + & 36.9174, 37.4533, 37.9888, 38.5242, 39.0597, & + & 39.5950, 40.1305, 40.6661, 41.2018, 41.7370, & + & 36.6321, 37.1678, 37.7030, 38.2386, 38.7742, & + & 39.3095, 39.8456, 40.3809, 40.9160, 41.4515, & + & 36.3383, 36.8738, 37.4095, 37.9450, 38.4802, & + & 39.0158, 39.5514, 40.0867, 40.6221, 41.1578, & + & 36.0350, 36.5703, 37.1060, 37.6411, 38.1769, & + & 38.7122, 39.2474, 39.7832, 40.3189, 40.8543, & + & 35.7230, 36.2585, 36.7940, 37.3293, 37.8649, & + & 38.4006, 38.9361, 39.4711, 40.0068, 40.5427, & + & 35.4046, 35.9397, 36.4754, 37.0111, 37.5464, & + & 38.0818, 38.6173, 39.1529, 39.6886, 40.2241, & + & 35.0799, 35.6155, 36.1510, 36.6865, 37.2225, & + & 37.7577, 38.2930, 38.8286, 39.3639, 39.8996/), & + & (/10,imnir/)) + real,parameter,dimension(10,imnir):: qco2n=reshape((/ & + & 1.966E-02, 1.493E-02, 1.127E-02, 8.224E-03, 5.478E-03, & + & 3.549E-03, 2.319E-03, 1.585E-03, 1.095E-03, 7.710E-04, & + & 1.947E-02, 1.495E-02, 1.147E-02, 8.681E-03, 6.035E-03, & + & 3.990E-03, 2.542E-03, 1.660E-03, 1.098E-03, 7.520E-04, & + & 1.977E-02, 1.510E-02, 1.157E-02, 8.899E-03, 6.456E-03, & + & 4.475E-03, 2.888E-03, 1.823E-03, 1.159E-03, 7.658E-04, & + & 2.065E-02, 1.551E-02, 1.173E-02, 9.002E-03, 6.710E-03, & + & 4.861E-03, 3.257E-03, 2.036E-03, 1.271E-03, 8.150E-04, & + & 2.240E-02, 1.633E-02, 1.204E-02, 9.105E-03, 6.851E-03, & + & 5.096E-03, 3.553E-03, 2.266E-03, 1.431E-03, 9.079E-04, & + & 2.532E-02, 1.771E-02, 1.258E-02, 9.279E-03, 6.948E-03, & + & 5.215E-03, 3.745E-03, 2.486E-03, 1.628E-03, 1.054E-03, & + & 2.867E-02, 1.961E-02, 1.347E-02, 9.619E-03, 7.083E-03, & + & 5.289E-03, 3.858E-03, 2.668E-03, 1.827E-03, 1.235E-03, & + & 3.108E-02, 2.166E-02, 1.491E-02, 1.032E-02, 7.343E-03, & + & 5.385E-03, 3.922E-03, 2.794E-03, 1.983E-03, 1.401E-03, & + & 3.215E-02, 2.336E-02, 1.670E-02, 1.154E-02, 7.864E-03, & + & 5.559E-03, 3.980E-03, 2.869E-03, 2.074E-03, 1.515E-03, & + & 3.247E-02, 2.443E-02, 1.820E-02, 1.302E-02, 8.719E-03, & + & 5.893E-03, 4.073E-03, 2.912E-03, 2.102E-03, 1.557E-03, & + & 3.260E-02, 2.492E-02, 1.898E-02, 1.413E-02, 9.668E-03, & + & 6.411E-03, 4.244E-03, 2.939E-03, 2.070E-03, 1.521E-03, & + & 3.283E-02, 2.509E-02, 1.918E-02, 1.456E-02, 1.030E-02, & + & 6.954E-03, 4.462E-03, 2.926E-03, 1.955E-03, 1.389E-03, & + & 3.311E-02, 2.517E-02, 1.912E-02, 1.454E-02, 1.048E-02, & + & 7.279E-03, 4.633E-03, 2.832E-03, 1.754E-03, 1.167E-03, & + & 3.347E-02, 2.527E-02, 1.904E-02, 1.436E-02, 1.038E-02, & + & 7.301E-03, 4.652E-03, 2.652E-03, 1.510E-03, 9.121E-04, & + & 3.385E-02, 2.543E-02, 1.900E-02, 1.415E-02, 1.011E-02, & + & 7.051E-03, 4.437E-03, 2.357E-03, 1.228E-03, 6.481E-04, & + & 3.427E-02, 2.560E-02, 1.898E-02, 1.394E-02, 9.687E-03, & + & 6.539E-03, 3.919E-03, 1.854E-03, 8.449E-04, 3.623E-04, & + & 3.482E-02, 2.588E-02, 1.905E-02, 1.376E-02, 9.105E-03, & + & 5.806E-03, 3.041E-03, 7.391E-04, 1.560E-04, 5.546E-06, & + & 3.565E-02, 2.642E-02, 1.933E-02, 1.374E-02, 9.426E-03, & + & 5.977E-03, 3.180E-03, 1.608E-03, 2.737E-04,-4.588E-04, & + & 3.720E-02, 2.751E-02, 2.010E-02, 1.414E-02, 9.465E-03, & + & 5.748E-03, 2.723E-03, 1.085E-03,-2.727E-04,-9.037E-04, & + & 3.977E-02, 2.947E-02, 2.160E-02, 1.523E-02, 1.012E-02, & + & 6.076E-03, 2.777E-03, 1.015E-03,-4.369E-04,-1.083E-03, & + & 4.356E-02, 3.241E-02, 2.394E-02, 1.711E-02, 1.154E-02, & + & 7.115E-03, 3.501E-03, 1.533E-03,-1.011E-04,-8.841E-04, & + & 4.848E-02, 3.623E-02, 2.703E-02, 1.974E-02, 1.235E-02, & + & 7.411E-03, 3.807E-03, 2.160E-03, 7.999E-04,-2.293E-04, & + & 5.433E-02, 4.077E-02, 3.059E-02, 2.279E-02, 1.544E-02, & + & 1.010E-02, 5.858E-03, 2.882E-03, 1.407E-03, 7.218E-04, & + & 6.076E-02, 4.559E-02, 3.430E-02, 2.589E-02, 1.840E-02, & + & 1.272E-02, 8.205E-03, 4.929E-03, 2.952E-03, 1.811E-03, & + & 6.726E-02, 5.041E-02, 3.787E-02, 2.875E-02, 2.106E-02, & + & 1.513E-02, 1.035E-02, 6.732E-03, 4.363E-03, 2.845E-03, & + & 7.346E-02, 5.507E-02, 4.135E-02, 3.130E-02, 2.328E-02, & + & 1.715E-02, 1.215E-02, 8.214E-03, 5.523E-03, 3.710E-03, & + & 7.948E-02, 5.945E-02, 4.459E-02, 3.360E-02, 2.507E-02, & + & 1.872E-02, 1.354E-02, 9.343E-03, 6.411E-03, 4.385E-03, & + & 8.539E-02, 6.343E-02, 4.739E-02, 3.562E-02, 2.646E-02, & + & 1.978E-02, 1.445E-02, 1.007E-02, 6.980E-03, 4.829E-03, & + & 9.095E-02, 6.684E-02, 4.951E-02, 3.710E-02, 2.745E-02, & + & 2.038E-02, 1.488E-02, 1.040E-02, 7.240E-03, 5.048E-03, & + & 9.545E-02, 6.941E-02, 5.086E-02, 3.797E-02, 2.798E-02, & + & 2.061E-02, 1.491E-02, 1.041E-02, 7.243E-03, 5.073E-03, & + & 9.806E-02, 7.108E-02, 5.163E-02, 3.819E-02, 2.805E-02, & + & 2.052E-02, 1.467E-02, 1.019E-02, 7.067E-03, 4.970E-03, & + & 9.848E-02, 7.186E-02, 5.208E-02, 3.810E-02, 2.771E-02, & + & 2.014E-02, 1.420E-02, 9.780E-03, 6.758E-03, 4.784E-03, & + & 9.690E-02, 7.176E-02, 5.240E-02, 3.791E-02, 2.712E-02, & + & 1.953E-02, 1.357E-02, 9.243E-03, 6.346E-03, 4.533E-03, & + & 9.375E-02, 7.099E-02, 5.269E-02, 3.781E-02, 2.646E-02, & + & 1.878E-02, 1.282E-02, 8.591E-03, 5.842E-03, 4.228E-03, & + & 8.980E-02, 7.195E-02, 5.433E-02, 3.832E-02, 2.699E-02, & + & 1.908E-02, 1.296E-02, 9.182E-03, 5.925E-03, 3.868E-03, & + & 8.497E-02, 6.957E-02, 5.414E-02, 3.881E-02, 2.687E-02, & + & 1.849E-02, 1.219E-02, 8.462E-03, 5.292E-03, 3.443E-03, & + & 8.002E-02, 6.581E-02, 5.308E-02, 3.926E-02, 2.557E-02, & + & 1.657E-02, 1.024E-02, 6.176E-03, 3.913E-03, 2.962E-03, & + & 7.459E-02, 6.401E-02, 5.311E-02, 4.028E-02, 2.777E-02, & + & 1.799E-02, 1.086E-02, 7.060E-03, 3.951E-03, 2.430E-03, & + & 6.906E-02, 6.070E-02, 5.202E-02, 4.080E-02, 2.846E-02, & + & 1.806E-02, 1.028E-02, 6.375E-03, 3.257E-03, 1.881E-03, & + & 6.237E-02, 5.626E-02, 4.974E-02, 4.035E-02, 2.864E-02, & + & 1.795E-02, 9.533E-03, 5.546E-03, 2.451E-03, 1.293E-03, & + & 5.748E-02, 5.295E-02, 4.800E-02, 4.009E-02, 2.897E-02, & + & 1.810E-02, 8.951E-03, 4.800E-03, 1.684E-03, 7.912E-04, & + & 5.032E-02, 4.733E-02, 4.389E-02, 3.758E-02, 2.754E-02, & + & 1.710E-02, 7.578E-03, 3.405E-03, 3.974E-04,-2.644E-05, & + & 5.011E-02, 4.733E-02, 4.419E-02, 3.838E-02, 2.856E-02, & + & 1.797E-02, 7.578E-03, 2.883E-03,-4.478E-04,-5.690E-04, & + & 4.976E-02, 4.688E-02, 4.375E-02, 3.825E-02, 2.886E-02, & + & 1.845E-02, 7.419E-03, 2.025E-03,-1.811E-03,-1.643E-03, & + & 6.052E-02, 5.599E-02, 5.142E-02, 4.474E-02, 3.456E-02, & + & 2.330E-02, 1.072E-02, 3.492E-03,-1.946E-03,-2.301E-03, & + & 7.280E-02, 6.608E-02, 5.953E-02, 5.132E-02, 4.042E-02, & + & 2.853E-02, 1.467E-02, 5.302E-03,-2.188E-03,-3.693E-03, & + & 8.215E-02, 7.354E-02, 6.532E-02, 5.586E-02, 4.450E-02, & + & 3.234E-02, 1.778E-02, 6.528E-03,-2.953E-03,-6.105E-03, & + & 8.764E-02, 7.782E-02, 6.851E-02, 5.813E-02, 4.656E-02, & + & 3.428E-02, 1.948E-02, 7.008E-03,-3.956E-03,-8.995E-03, & + & 9.172E-02, 8.098E-02, 7.095E-02, 5.969E-02, 4.784E-02, & + & 3.539E-02, 2.052E-02, 7.584E-03,-4.132E-03,-1.079E-02/), & + & (/10,imnir/)) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + contains + subroutine lint1(x1,y1,n1,yleft,yright,x,y) +! +! A very simple linear interpolation of y1(x1) into y(x) +! ***x1 is assumed in ascending order*** + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Apr 16, 2003: Rashid Akmaev +! Made from lint for a scalar argument + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! Array dimension + integer,intent(in):: n1 + real,intent(in):: x1(n1),y1(n1),yleft,yright,x + real,intent(out):: y +! Work memory + integer:: i + real:: dx + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(x.lt.x1(1)) then + y=yleft + elseif(x.gt.x1(n1)) then + y=yright + else + do i=2,n1 + dx=x-x1(i) + if(dx.le.0.) then + y=y1(i)+(y1(i)-y1(i-1))*dx/(x1(i)-x1(i-1)) + return + endif + enddo + endif + end subroutine lint1 + + end module qnir_mod + +!*********************************************************************** + + subroutine co2pro_pre(xmodel,lmodel,mumod) + +! Routine to prepare CO2 global mean profile optionally based on +! Fomichev et al. (1998) or CRISTA data. +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Jan 2006: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use co2pro_mod + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Input parameters +! xmodel(lmodel) - model grid (going up from LB) +! mumod(lmodel) - model molecular mass (g/mol) on the grid +! + integer,intent(in):: lmodel + real,intent(in):: xmodel(lmodel),mumod(lmodel) +! +! Output profiles (in co2pro_mod) +! co2vic(ivic0) - CO2 on Victor initial grid +! co2my(lmodel) - CO2 on model grid + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Work variables and arrays +! + integer:: l,lradif + real:: vicmu(ivic0) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Check parameter consistency +! + if(xvic0(ivic0)<12.5) then + write(6,*) & + & '***Stop in co2pro_pre: Full Victor grid too low?' + write(6,'(i8)') xvic0(ivic0) + stop + endif + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Allocate model profile kept in co2pro_mod +! + allocate(co2my(lmodel)) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Correct Victor's CO2 model for diffusive equilibrium above +! xdiff (corresponding index of .25 grid idiff) set in co2pro_mod +! Find model layer of xmodel grid just above xdiff +! + lradif=lmodel+1 + do l=1,lmodel + if(xmodel(l).ge.xdiff) then + lradif=l + exit + endif + enddo +! +! Prepare auxiliary array of mu on Vick's grid above interface +! level of x=12.5 (index=50) +! + call splin1(xmodel,mumod,xvic0,vicmu,lmodel,ivic0) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Initialize CO2 on Vick's grid and normalize it by surface VMR +! + co2vic(:)=(real(ico2am)/360.)*co2vi0(:) +! +! Correct Victor's model for diffusive equilibrium if necessary (if +! ifdiff>ivic0, the loop is not executed) +! + do l=idiff,ivic0 + co2vic(l)=exp(alog(co2vic(l-1))+(xvic0(l)-xvic0(l-1))*(1.- & + & 23.*(1./vicmu(l)+1./vicmu(l-1)))) + enddo +! +! Construct CO2 mixing ratio profile on model grid, calculate CO2 +! column amount. Note: Victor's CO2 model (for x=0-20) is already +! normalized for CO2 amount +! + do l=1,lmodel + co2my(l)=0. + enddo +! +! Below xdiff interpolate Vick's CO2 model on model grid +! + call splin1(xvic0,co2vic,xmodel,co2my,ivic0,lradif-1) +! +! Above xdiff use diffusive equilibrium if necessary (if lradif>lmodel, +! the loop is not executed) +! + do l=lradif,lmodel + co2my(l)=exp(alog(co2my(l-1))+(xmodel(l)-xmodel(l-1))*(1.- & + & 23.*(1./mumod(l)+1./mumod(l-1)))) + enddo + + end subroutine co2pro_pre + +!*********************************************************************** + + subroutine crico2_pre(xmodel,lmodel,mumod) + +! Routine to prepare CO2 global mean profile based on CRISTA data. + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Jan 2006: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use co2pro_mod + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Input parameters +! xmodel(lmodel) - model grid (going up from LB) +! mumod(lmodel) - model molecular mass (g/mol) on the grid +! + integer,intent(in):: lmodel + real,intent(in):: xmodel(lmodel),mumod(lmodel) +! +! +! Output profiles (in co2pro_mod) +! co2vic(ivic0) - CO2 on Victor initial grid +! co2my(lmodel) - CO2 on model grid + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Table loosely based on CRISTA data +! + integer,parameter:: icrist=5 + real,parameter,dimension(icrist):: & + & xcrist=(/ 9.0, 10.0, 13., 15.5, 17.0 /), & + & cvcris=(/ 360e-6, 355e-6, 260e-6, 100e-6, 40e-6 /) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Work space +! + integer:: l,lradif,lvic1,lvic2 + real:: vicmu(ivic0) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Check parameter consistency +! + if(xvic0(ivic0)<12.5) then + write(6,*) & + & '***Stop in co2pro_pre: Full Victor grid too low?' + write(6,'(i8)') xvic0(ivic0) + stop + endif + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Allocate model profile kept in co2pro_mod +! + allocate(co2my(lmodel)) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Correct Victor's CO2 model for diffusive equilibrium above +! xdiff (corresponding index of .25 grid idiff) set in co2pro_mod +! Find model layer of xmodel grid just above xdiff +! + lradif=lmodel+1 + do l=1,lmodel + if(xmodel(l).ge.xdiff) then + lradif=l + exit + endif + enddo +! +! Prepare auxiliary array of mu on Vick's grid [only used below +! between x=12.5 (l=50) and xdiff (l=idiff)] +! + call splin1(xmodel,mumod,xvic0,vicmu,lmodel,ivic0) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Initialize CO2 on Victor's grid by his standard profile (normalized +! to surface VMR 360 ppm) +! + co2vic(:)=co2vi0(:) +! +! Correct Victor's model for CRISTA data and diffusive equilibrium +! if necessary +! First find the levels within CRISTA range +! + lvic1=1 + do l=1,ivic0 + if(xvic0(l).ge.xcrist(1)) then + lvic1=l + exit + endif + enddo + lvic2=ivic0 + do l=1,ivic0 + if(xvic0(l).gt.xcrist(icrist)) then + lvic2=l-1 + exit + endif + enddo +! +! Do spline interpolation for these levels +! + call splin1(xcrist,cvcris,xvic0(lvic1:lvic2), & + & co2vic(lvic1:lvic2),icrist,lvic2-lvic1+1) +! +! Do diffusion if applicable +! + if(idiff.gt.lvic2) then + write(6,*) & + & '***Stop in co2pro_pre: Diffusion above CRISTA?' + write(6,'(2i8)') idiff,lvic2 + stop + endif +! (if ifdiff>ivic0, the loop is not executed) + do l=idiff,ivic0 + co2vic(l)=exp(alog(co2vic(l-1))+(xvic0(l)-xvic0(l-1))*(1.- & + & 23.*(1./vicmu(l)+1./vicmu(l-1)))) + enddo +! +! Now normalize the profile to the surface mixing ratio +! + co2vic(:)=(real(ico2am)/360.)*co2vic(:) +! +! Construct CO2 mixing ratio profile on model grid using the profile +! just calculated on Victor's grid. Note: that profile is already +! normalized for CO2 surface VMR +! + do l=1,lmodel + co2my(l)=0. + enddo +! +! Below xdiff interpolate from Victor's grid to model grid +! + call splin1(xvic0,co2vic,xmodel,co2my,ivic0,lradif-1) +! +! Above xdiff use diffusive equilibrium (if lradif>lmodel, the loop +! is not executed) +! + do l=lradif,lmodel + co2my(l)=exp(alog(co2my(l-1))+(xmodel(l)-xmodel(l-1))*(1.- & + & 23.*(1./mumod(l-1)+1./mumod(l)))) + enddo + + end subroutine crico2_pre + +!*********************************************************************** + + subroutine co2cc(im,jm,xtemp,temp,ltemp,xhr,hrate,lhr,mu,ro1, & + & ro2,rn2) + +! Routine to calculate CO2 cooling in 3-d on model vertical grid using +! Victor's new parameterization (Fomichev et al., 1998) updated in 1999. + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! History +! Feb 28, 2008: changes by RAA in O interpolation to parameterization +! grid +! Dec 2006: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use co2c_mod + use co2pro_mod, only:xvic0,pvic,co2vic,co2my + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine arguments +! INPUT +! -array dimensions: first array index, "longitude" index, +! vertical T-grid, vertical heating-rate grid (generally +! lhr < ltemp) +! + integer,intent(in):: im,jm,ltemp,lhr +! +! - input temperature and its log-pressure grid [x=ln(1e5/p)] (xtemp +! should normally extend down to the surface x=0) +! - output heating-rate log-pressure grid (should normally start above +! x=2) +! - molecular mass (g/mol) +! - VMR of O, O2, N2 on heating-rate grid +! + real,intent(in):: temp(im,ltemp),xtemp(ltemp), & + & xhr(lhr),mu(im,lhr),ro1(im,lhr),ro2(im,lhr),rn2(im,lhr) +! +! OUTPUT +! - output heating rate (J/kg) +! + real,intent(out):: hrate(im,lhr) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Internal workspace +! Fixed parameters +! -collisional deactivation rate by O [1/(cm**3 s)] +! +! real,parameter:: zco2o=1.5e-12 + real,parameter:: zco2o=3.e-12 +! +! -composition on Victor grid needed for x above 12.5 (index=1-itm50), +! stored here in case it can be reused +! + real,dimension(im,itm50):: vicn2,vico2,vico1,vicmu +! +! Temp workspace +! + integer:: i,iwork,j,l + real:: d1,d2,work1,work2,zn2,zo2,ztotal + real:: vict(im,ivict),vich(im,ivict-8),vics(im,ivict), & + & vlamb(im,itm50),htilda(jm),flux(jm) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Boltzmann constant multiplied by 1e6 to convert pressure in Pa to +! number density in 1/cm**3 +! + real,parameter:: bol106=1.3807e-17 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Victor's data (with his original comments): +! ak = h*c/k*V - to determine the Planck function, k - Boltzmann's +! constant + real,parameter:: ak=960.217 +! +! a10 - Einstine's (***Victor's classic spelling!!!***) coefficient +! for the fundamental band for the main isotope (1/s) + real,parameter:: eina10=1.5988 +! +! const - constant using to determine the heating rate: +! const = Na*h*c*V*Gv'/Gv*Avv*1.03, where +! Na - Avogadro number, h- Planck's constant, c- light speed, +! V - frequency of the fundamental vibrational transition in +! the main isotope, Gv'/Gv = 2 - ratio of the statistical weights +! for the fundamental transition, Av'v - Einstine coefficient for +! the fundamental band of the main isotope, 1.03 - correction to +! account for others than funndamental bands in the reccurence +! formula +! +! data const/2.63187e11/ +! +! Victor's const multiplied by 1e-4 to convert from erg/(g*s) to W/kg +! +! data conmy/2.63187e7/ +! +! In updated parameterization Victor changed const apparently having +! removed the 1.03 factor (see the paragraph above): +! const - constant using to determine the heating rate: +! const = Na*h*c*V*Gv'/Gv*Avv, where +! Na - Avogadro number, h- Planck's constant, c- light speed, +! V - frequency of the fundamental vibrational transition in +! the main isotope, Gv'/Gv = 2 - ratio of the statistical +! weights for the fundamental transition, Av'v - Einstine +! coefficient for the fundamental band of the main isotope. +! data const/2.55521e11/, constb/8.82325e9/ +! + real,parameter:: conmy=2.55521e7 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate composition on Victor grid above x=12.5 (index 50) for +! recurrent formula +! + call splin2(xhr,mu,xvic0(51:),vicmu,lhr,itm50,im,jm) + call splin2(xhr,rn2,xvic0(51:),vicn2,lhr,itm50,im,jm) + call splin2(xhr,ro2,xvic0(51:),vico2,lhr,itm50,im,jm) +! +! Feb 28, 2008 +! idea change: the following portion of the code commented out and +! replaced by RAA +!c For O interpolation find first model layer with [O]>.0 +!c +! iwork=0 +! do j=1,jm +! do l=1,lhr +!c idea change +!c if(ro1(j,l).gt.0.) then +! if(ro1(j,l).gt.1.e-7) then +! exit +! endif +! enddo +! iwork=max(iwork,l) +! enddo +!c print*,'www1',iwork,xhr(iwork),lhr +! if(iwork==0 .or. xhr(iwork)>12.5) then +! write(6,*) '***Stop, co2cc: [O] is zero or negative***' +!c print*,'www',iwork,ro1(1:jm,iwork-1) +! write(6,*) iwork,xhr(iwork) +! stop +! endif +! call splin2(xhr(iwork),ro1(1:im,iwork:),xvic0(51),vico1, & +! & lhr-iwork+1,itm50,im,jm) +! + call splin2(xhr,ro1,xvic0(51:),vico1,lhr,itm50,im,jm) +! +! idea add: make sure O is non-negative +! + vico1(:,:)=max(vico1(:,:),0.) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate heating rate for LTR/recurrence part. Convert Tin to +! parameterization grid at x=0-xinter and calculate "source function" +! using spline for T interpolation +! + call splin2(xtemp,temp,xvic0,vict,ltemp,ivict,im,jm) + do i=1,ivict + do j=1,jm + vics(j,i)=exp(-ak/vict(j,i)) + enddo + enddo + iwork=ivict-8 + do i=1,iwork + do j=1,jm + vich(j,i)=0. + enddo + enddo +! +! LTR heating (x=2-12.5, i=1-43) in W/kg +! + do i=1,43 + do l=1,57 + do j=1,jm + vich(j,i)=(vamat(i,l)+vbmat(i,l)*vics(j,i+8))*vics(j,l)+ & + & vich(j,i) + enddo + enddo + enddo +! +! Calculate lambda for the recurrence-formula part (x=12.5-xinter, +! i=1-itm50, full index 51-ivict) +! + do i=1,itm50 +! +! No temperature dependence of collisional rate CO2-O +! + do j=1,jm + work1=vict(j,i+50)**(-1./3.) + zn2=5.5e-17*sqrt(vict(j,i+50))+6.7e-10*exp(-83.8*work1) + zo2=1.e-15*exp((564.*work1-230.9)*work1+23.37) +! +! Total collisional deactivation rate (factor in second line converts +! pressure to total number density) +! + ztotal=pvic(i+50)*(vico1(j,i)*zco2o+vicn2(j,i)*zn2+ & + & vico2(j,i)*zo2)/(bol106*vict(j,i+50)) +! +! Probability of photon survival +! + vlamb(j,i)=eina10/(eina10+ztotal) + enddo + enddo +! +! Boundary condition at x=12.5 (recurrence index 1, heating index 43, +! total index 51) +! + do j=1,jm + htilda(j)=vich(j,43)*vicmu(j,1)/ & + & (conmy*co2vic(51)*(1.-vlamb(j,1))) + enddo +! +! Recurrent formula +! + do i=2,itm50 + d1=.25*alvic(i)+.75*alvic(i-1) + d2=.75*alvic(i)+.25*alvic(i-1) + work1=1.-d1 + work2=1.-d2 + do j=1,jm + htilda(j)=((((1.-vlamb(j,i-1)*work1)*htilda(j))+ & + & d1*vics(j,i+49))-d2*vics(j,i+50))/(1.-vlamb(j,i)*work2) + vich(j,i+42)=conmy*co2vic(i+50)*htilda(j)*(1.-vlamb(j,i))/ & + & vicmu(j,i) + enddo + enddo +! +! Transfer heating back from parameterization grid at x=2-xinter to +! model heating-rate grid by spline interpolation. +! + call splin2(xvic0(9:),vich,xhr,hrate,iwork,lraint-1,im,jm) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate heating on model grid above xinter. First find lower +! boundary condition at xinter. +! + do j=1,jm + flux(j)=htilda(j)+vics(j,ivict) + enddo +! +! Assume that the upper portion of Tin is specified at model layers, +! for which hrate is calculated, that is Tin(ltemp) corresponds to +! hrate(lhr) +! + iwork=ltemp-lhr + do l=lraint,lhr +! +! No temperature dependence of collisional rate CO2-O +! + do j=1,jm + work1=temp(j,l+iwork)**(-1./3.) + zn2=5.5e-17*sqrt(temp(j,l+iwork))+6.7e-10*exp(-83.8*work1) + zo2=1.e-15*exp((564.*work1-230.9)*work1+23.37) +! +! Total collisional deactivation rate (factor in last line converts +! pressure to total number density). Pressure is recalculated here +! from input log-pressure (xhr). +! + ztotal=1e5*exp(-xhr(l))*(zco2o*ro1(j,l)+rn2(j,l)*zn2+ & + & ro2(j,l)*zo2)/(bol106*temp(j,l+iwork)) +! +! Heating rate +! + hrate(j,l)=conmy*co2my(l)*(1.-eina10/(eina10+ & + & ztotal))*(flux(j)-exp(-ak/temp(j,l+iwork)))/mu(j,l) + enddo + enddo + + end subroutine co2cc + +!*********************************************************************** + + subroutine co2cin(xmod,pmod,mu,gr,lmod,me,mpi_ior,mpi_comm) + +! Routine to prepare matrices and other parameters for implementation +! of full CO2 cooling scheme by Fomichev et al. (1998) modified later +! (Victor Fomichev, personal communication, 1999) to account for updated +! non-LTE calculations by Ogibalov. This version made to accomodate CO2 +! profiles different from the one suggested by Fomichev et al. (1998). +! Since CO2 profiles are assumed to be global means, the +! parameterization parameters are considered global means as well and +! may be precalculated once. If variable CO2 profiles are available, +! some of these calculations should be done "on line". + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Dec 2006: Rashid Akmaev +! Oct 2012: Jun Wang: change reading for MPI environment + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use co2c_mod + use co2pro_mod, only:xvic0,pvic,co2vic,co2my + use qnir_mod, only:imnir,co2nir + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + + include 'mpif.h' +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine arguments +! INPUT +! -log-pressure grid for heating rate calculation going up +! -other variables on this grid (these are meant here as global means +! to prepare LTR matrices, escape functions, and CO2 column amounts for +! NIR heating calculations): +! pressure (Pa) +! global mean VMR of N2,O2, and O +! global mean molecular weight (g/mol) +! gravity (m/sec**2) +! + integer,intent(in)::lmod + real,intent(in),dimension(lmod)::xmod,pmod,mu,gr + integer, intent(in) :: me ! my pe + integer, intent(in) :: mpi_ior ! mpi real for io + integer, intent(in) :: mpi_comm ! mpi communicator +! +! -directory where matrix files are located +! +!hmhj character(len=*),intent(in):: dir +! +! Subroutine OUTPUT is placed in modules +! co2c_mod for use by co2cc and +! qnir_mod for use by qnirc + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Internal work space +! Fixed parameters +! -Avogadro number (1/mol) made parameter Mar 11, 1999 +! + real,parameter:: ana=6.022e23 +! +! Temp work space +! + integer:: i,j,l,info + real:: w1,wcolmy(lmod),war1(100),war2(100) + real:: vmu(ivict),vgrav(ivict) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Cooling scheme parameters +! This section adopted from Victor's parcof: +! matrix coefficients for basic CO2 vmr of 150,360,540 and 720 ppm +! (basically these arrays give log(coeficient/vmr) +! + real a150(43,57),b150(43,57), a360(43,57),b360(43,57), & + & a540(43,57),b540(43,57), a720(43,57),b720(43,57) +! +! CO2 column amount and corresponding escape functions (eventually, +! their log) +! + real uco2ro(51), alo(51) +! +! CO2 column amount at X(67) grid, calculated for basic CO2 profile of +! 360ppm: +! (note, this profile exibits CO2 vmr=const up to x=12.25 and decreases +! with height above this level) +! +! ***Another note (RAA): it only goes up to x=14*** +! + real uco2o(57) +! +! corrections to escape functions to calculate coefficients for the +! reccurence formula between x=12.5 and 13.75 +! + real cor150(6), cor360(6), cor540(6), cor720(6) +! +! auxiliary arrays (dimension of uco2 changed to 81 from 67, that is +! x changed from 16.5 to 20) +! Nov 2, 2006: dimension changed again to ivict +! + real uref(4), co2int(4), uco2(ivict) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! This section also adopted from Victor's parcof (new version - arrays +! cor* certainly changed) +! uco2ro(51),alo(51),uco2o(57), and cor150(6),cor360(6),cor540(6), +! cor720(6) are given below: +! + data uco2ro/2.699726E+11,5.810773E+11,1.106722E+12,1.952319E+12, & + & 3.306797E+12,5.480155E+12,8.858565E+12,1.390142E+13, & + & 2.129301E+13,3.209300E+13,4.784654E+13,7.091442E+13, & + & 1.052353E+14,1.565317E+14,2.320320E+14,3.415852E+14, & + & 4.986668E+14,7.212717E+14,1.033831E+15,1.469497E+15, & + & 2.073209E+15,2.905406E+15,4.044901E+15,5.596946E+15, & + & 7.700499E+15,1.052205E+16,1.425730E+16,1.913609E+16, & + & 2.546953E+16,3.366464E+16,4.421144E+16,5.775381E+16, & + & 7.514254E+16,9.747013E+16,1.261393E+17,1.629513E+17, & + & 2.102188E+17,2.709114E+17,3.488423E+17,4.489076E+17, & + & 5.773939E+17,7.423736E+17,9.542118E+17,1.226217E+18, & + & 1.575480E+18,2.023941E+18,2.599777E+18,3.339164E+18, & + & 4.288557E+18,5.507602E+18,7.072886E+18/ + data alo /-2.410106E-04,-5.471415E-04,-1.061586E-03,-1.879789E-03,& + & -3.166020E-03,-5.185436E-03,-8.216667E-03,-1.250894E-02,& + & -1.838597E-02,-2.631114E-02,-3.688185E-02,-5.096491E-02,& + & -7.004056E-02,-9.603746E-02,-1.307683E-01,-1.762946E-01,& + & -2.350226E-01,-3.095215E-01,-4.027339E-01,-5.178570E-01,& + & -6.581256E-01,-8.265003E-01,-1.024684E+00,-1.252904E+00,& + & -1.509470E+00,-1.788571E+00,-2.081700E+00,-2.379480E+00,& + & -2.675720E+00,-2.967325E+00,-3.252122E+00,-3.530485E+00,& + & -3.803720E+00,-4.072755E+00,-4.338308E+00,-4.601048E+00,& + & -4.861585E+00,-5.120370E+00,-5.377789E+00,-5.634115E+00,& + & -5.889388E+00,-6.143488E+00,-6.396436E+00,-6.648774E+00,& + & -6.901465E+00,-7.155207E+00,-7.409651E+00,-7.663536E+00,& + & -7.915682E+00,-8.165871E+00,-8.415016E+00/ + data uco2o /7.760162E+21,6.043619E+21,4.706775E+21,3.665639E+21, & + & 2.854802E+21,2.223321E+21,1.731524E+21,1.348511E+21, & + & 1.050221E+21,8.179120E+20,6.369897E+20,4.960873E+20, & + & 3.863524E+20,3.008908E+20,2.343332E+20,1.824981E+20, & + & 1.421289E+20,1.106894E+20,8.620418E+19,6.713512E+19, & + & 5.228412E+19,4.071814E+19,3.171055E+19,2.469544E+19, & + & 1.923206E+19,1.497717E+19,1.166347E+19,9.082750E+18, & + & 7.072886E+18,5.507602E+18,4.288557E+18,3.339164E+18, & + & 2.599777E+18,2.023941E+18,1.575480E+18,1.226217E+18, & + & 9.542118E+17,7.423736E+17,5.773939E+17,4.489076E+17, & + & 3.488423E+17,2.709114E+17,2.102188E+17,1.629513E+17, & + & 1.261393E+17,9.747013E+16,7.514254E+16,5.775381E+16, & + & 4.421144E+16,3.366464E+16,2.546953E+16,1.913609E+16, & + & 1.425730E+16,1.052205E+16,7.700499E+15,5.596946E+15, & + & 4.044901E+15/ + data (cor150(i),i=1,6) /2.158307E-01,1.423648E-01,1.204398E-01, & + & 7.631008E-02,3.199162E-02,6.634180E-04/ + data (cor360(i),i=1,6) /5.661261E-01,4.570891E-01,3.339225E-01, & + & 1.890883E-01,8.223990E-02,3.202579E-02/ + data (cor540(i),i=1,6) /6.959335E-01,6.015297E-01,4.714436E-01, & + & 3.011133E-01,1.535200E-01,5.512478E-02/ + data (cor720(i),i=1,6) /8.005666E-01,6.939198E-01,5.522208E-01, & + & 3.629121E-01,1.910115E-01,7.053397E-02/ + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! T must be known from x=0 to x=xinter(face) (16.5-20). +! Calculate Victor's pressure (kept in co2pro_mod) from surface x=0 to +! xinter + do l=1,ivict + pvic(l)=1e5*exp(-xvic0(l)) + enddo +! call mymaxmin(pvic,ivict,ivict,1,' co2cin: pvic ') +! +! Find first model layer just above xinter +! + lraint=1 + do l=1,lmod + if(xmod(l).ge.xinter) then + lraint=l + exit + endif + enddo +! +! Determine if model configuration is consistent (T must be known up +! to xinter). +! + if(xmod(lmod).lt.xinter) then + write(6,*) '***Stop in co2cin: model UB below Xinterface***' + write(6,*) ' lmod= ',lmod + write(6,*) ' xmod(lmod)= ',xmod(lmod) + write(6,*) ' xinter= ',xinter + stop + endif + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Prepare CO2 profile +! +! F98 model profile + call co2pro_pre(xmod,lmod,mu) + write(6,*) 'F98 CO2 model' +! call mymaxmin(xmod,ivict,ivict,1,' co2cin: xmod ') +! CRISTA based model profile +! call crico2_pre(xmod,lmod,mu) +! write(6,*) 'CRISTA CO2 model' + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate auxiliary arrays of global mean molecular weight and +! gravity on full Victor grid for CO2 column amount calculation. +! Find first level of Victor grid above lowest model layer and +! interpolate + i=1 + do l=1,ivict + if(xvic0(l).ge.xmod(1)) then + i=l + exit + endif + enddo + j=i-1 + call splin1(xmod,mu,xvic0(i),vmu(i),lmod,ivict-j) + call splin1(xmod,gr,xvic0(i),vgrav(i),lmod,ivict-j) +! +! Below x(i) assume constant mu and g +! + do l=1,j + vmu(l)=mu(1) + vgrav(l)=gr(1) + enddo +! call mymaxmin(vmu,j,j,1,' co2cin: vmu ') +! call mymaxmin(vgrav,j,j,1,' co2cin: vgrav ') +! +! Calculate CO2 column amounts for matrix interpolation and for +! CO2 heating rates in the near IR. +! +! CO2 column amount above model upper layer (coefficient .1 transfers +! it to cm**-2 if g and p are in SI units and CO2 molecular weight +! is in g/mol) +! + wcolmy(lmod)=.1*ana*co2my(lmod)*pmod(lmod)/(gr(lmod)*46.) +! +! CO2 column amount for model layers above x=xinter +! + w1=.1*.5*ana + do l=lmod-1,lraint,-1 + wcolmy(l)=wcolmy(l+1)+w1*(pmod(l)-pmod(l+1))* & + & (co2my(l)/(mu(l)*gr(l))+co2my(l+1)/(mu(l+1)*gr(l+1))) + enddo +! +! CO2 column amount at and below xinter on Victor's parameterization +! grid. Use column amount on model grid to calculate upper +! boundary condition. +! + uco2(ivict)=wcolmy(lraint)+w1*(pvic(ivict)-pmod(lraint))* & + & (co2vic(ivict)/(vmu(ivict)*vgrav(ivict))+ & + & co2my(lraint)/(mu(lraint)*gr(lraint))) + do l=ivict-1,1,-1 + uco2(l)=uco2(l+1)+w1*(pvic(l)-pvic(l+1))* & + & (co2vic(l)/(vmu(l)*vgrav(l))+ & + & co2vic(l+1)/(vmu(l+1)*vgrav(l+1))) + enddo +! +! Save column amounts for output and use in NIR calculations at +! x=2-14 +! + if(xinter.ge.14.) then + do l=1,imnir + co2nir(l)=uco2(l+8) + enddo + else + write(6,*) 'Stop in co2cin: xinter < 14' + stop + endif + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Read in Victor's reference matrices (this part is adopted from parcof) +! + 100 format((/)) + 101 format((1x,5E15.6)) +!hmhj open(10,file=dir//'/coeff_lte.150',status = 'OLD') +!hmhj open(11,file=dir//'/coeff_lte.360',status = 'OLD') +!hmhj open(12,file=dir//'/coeff_lte.540',status = 'OLD') +!hmhj open(13,file=dir//'/coeff_lte.720',status = 'OLD') +! +!jw: only pe0 will read the data + if(me==0) then + + open(30,file='global_idea_coeff_lte.150',status = 'OLD') + open(31,file='global_idea_coeff_lte.360',status = 'OLD') + open(32,file='global_idea_coeff_lte.540',status = 'OLD') + open(33,file='global_idea_coeff_lte.720',status = 'OLD') + rewind(30) + rewind(31) + rewind(32) + rewind(33) + read(30,100) + read(31,100) + read(32,100) + read(33,100) + do i=1,43 + read(30,101) (a150(i,j), j=1,57) + read(31,101) (a360(i,j), j=1,57) + read(32,101) (a540(i,j), j=1,57) + read(33,101) (a720(i,j), j=1,57) + enddo +! call mymaxmin(a150,43*57,43*57,1,' co2cin a150 ') +! call mymaxmin(a360,43*57,43*57,1,' co2cin a360 ') +! call mymaxmin(a540,43*57,43*57,1,' co2cin a540 ') +! call mymaxmin(a720,43*57,43*57,1,' co2cin a720 ') + read(30,100) + read(31,100) + read(32,100) + read(33,100) + do i=1,43 + read(30,101) (b150(i,j), j=1,57) + read(31,101) (b360(i,j), j=1,57) + read(32,101) (b540(i,j), j=1,57) + read(33,101) (b720(i,j), j=1,57) + enddo +! call mymaxmin(b150,43*57,43*57,1,' co2cin b150 ') +! call mymaxmin(b360,43*57,43*57,1,' co2cin b360 ') +! call mymaxmin(b540,43*57,43*57,1,' co2cin b540 ') +! call mymaxmin(b720,43*57,43*57,1,' co2cin b720 ') + close(30) + close(31) + close(32) + close(33) +! +!jw pe 0 finish reading + endif + + call mpi_bcast(a150,size(a150),mpi_ior,0,mpi_comm,info) + call mpi_bcast(a360,size(a360),mpi_ior,0,mpi_comm,info) + call mpi_bcast(a540,size(a540),mpi_ior,0,mpi_comm,info) + call mpi_bcast(a720,size(a720),mpi_ior,0,mpi_comm,info) + call mpi_bcast(b150,size(b150),mpi_ior,0,mpi_comm,info) + call mpi_bcast(b360,size(b360),mpi_ior,0,mpi_comm,info) + call mpi_bcast(b540,size(b540),mpi_ior,0,mpi_comm,info) + call mpi_bcast(b720,size(b720),mpi_ior,0,mpi_comm,info) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! This is again from parcof with modifications: Linear interpolation +! is replaced by spline interpolation. +! Interplolate coefficients for the matrix paramerization on Victor +! fixed grid: +! to calculate vamat(i,j) and vbmat(i,j) stored in co2c_mod, +! a spline interpolation of basic coefficients over the CO2 amount +! between x(i) and x(j) (or between x(i-1) and x(i+1) for vamat(i,i) +! and vbmat(i,i)), is used +! + do i = 1, 43 + do j = 1, 57 + if(j.eq.(i+8)) then + w1 = uco2o(i+7)-uco2o(i+9) + war1(1) = uco2(i+7)-uco2(i+9) + else + w1 = abs(uco2o(i+8)-uco2o(j)) + war1(1) = abs(uco2(i+8)-uco2(j)) + end if + uref(1) = w1*150./360. + uref(2) = w1 + uref(3) = w1*540./360. + uref(4) = w1*720./360. + co2int(1)=a150(i,j) + co2int(2)=a360(i,j) + co2int(3)=a540(i,j) + co2int(4)=a720(i,j) + call splin1(uref,co2int,war1,war2,4,1) +! +! Coefficient 1e-4 transforms erg/(g*s) to W/kg +! +! AMAT(i,j)=co2(i+8)*exp(a) + vamat(i,j)=1e-4*co2vic(i+8)*exp(war2(1)) + co2int(1)=b150(i,j) + co2int(2)=b360(i,j) + co2int(3)=b540(i,j) + co2int(4)=b720(i,j) + call splin1(uref,co2int,war1,war2,4,1) +! +! Coefficient 1e-4 transforms erg/(g*s) to W/kg +! +! BMAT(i,j)=co2(i+8)*exp(a) + vbmat(i,j)=1e-4*co2vic(i+8)*exp(war2(1)) + if(j.eq.(i+7).or.j.eq.(i+8).or.j.eq.(i+9)) then + vamat(i,j)=-vamat(i,j) + vbmat(i,j)=-vbmat(i,j) + end if + enddo + enddo + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate parameters for recurrent formula. +! This part adopted from parcof with some modifications: Spline +! interpolation instead of linear and escape functions set to 1 at +! very small CO2 amounts. +! Calculate coeeficients for the reccurence formula: +! between x=12.5 and 13.75 these coefficients (al) are calculated using +! correction to escape function. Starting up from x=14.00 +! parameterization coeficients are equal escape function. + do i=1,itm50 + alvic(i)=0. + enddo + do i=1,6 + if(uco2(i+50).lt.uco2ro(1)) then + war1(1)=0. + else + call splin1(uco2ro,alo,uco2(i+50),war1,51,1) + endif + co2int(1)=cor150(i) + co2int(2)=cor360(i) + co2int(3)=cor540(i) + co2int(4)=cor720(i) + uref(1) =uco2o(i+50)*150./360. + uref(2) =uco2o(i+50) + uref(3) =uco2o(i+50)*540./360. + uref(4) =uco2o(i+50)*720./360. + call splin1(uref,co2int,uco2(i+50),war2,4,1) + alvic(i)=exp(war1(1)+war2(1)) + enddo +! +! Above x=14 there is no correction +! + do i=7,itm50 + if(uco2(i+50).lt.uco2ro(1)) then + war1(1)=0. + else + call splin1(uco2ro,alo,uco2(i+50),war1,51,1) + endif + alvic(i)=exp(war1(1)) + enddo + + end subroutine co2cin + +!*********************************************************************** + + subroutine qnirc(ct,x,co2mr,qnirh,lx) + +! Subroutine to calcuate NIR heating rate in a vertical column after +! Ogibalov and Fomichev (2003) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Dec 2003: Updated +! May 23, 2003: Written by Rashid Akmaev after extensive modifications +! of Victor's co2nir + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use qnir_mod + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine arguments +! INPUT +!- model grid dimension +! + integer,intent(in):: lx +! +!-cosine of solar zenith angle +!-model log-pressure x-grid GOING UP +!-CO2 VMR on model grid (note that since VMR does not change, the +! column CO2 amounts on the fixed parameterization grid are kept +! in qnir_mod). CO2 VMR is also kept in another module but is +! called as an argument to ensure it is on the same grid as +! the heating rate +! + real,intent(in):: ct,x(lx),co2mr(lx) +! +! OUTPUT +!-heating rate in K/s (does not have to be divided by Cp) +! + real,intent(out):: qnirh(lx) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Work space +! + integer:: l + integer,save:: lmnir + logical:: first=.true. + real:: g,dx,hr(imnir) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Check how high the model grid goes compared to param grid, assume +! model pressure near the top of param grid (x=14) does change with +! time (fixed pressure grid near x=14) +! + if(first) then + lmnir=lx + do l=1,lx + if(x(l).gt.xnir(imnir)) then + lmnir=l-1 + exit + endif + enddo +! print *,' qnirc: lmnir=',lmnir + first=.false. + endif +! +! Initialize heating rate +! + do l=1,lx + qnirh(l)=0. + enddo + if(ct.ge.0.) then +! +! Calculate heating, otherwise do nothing. +! First calculate normalized heating on parameterization grid using +! linear interpolation (it is assumed following original code that if +! the CO2 column amount exceeds the largest in the table, qco2n(10,l), +! the normalized heating rate is 0) +! + do l=1,imnir + g=log(co2nir(l)*35./SQRT(1224.*ct**2+1.)) + call lint1(lnco2n(1,l),qco2n(1,l),10,qco2n(1,l), & + & 0.,g,hr(l)) + enddo +! +! Now calculate heating on specified model grid. +! Do spline interpolation (replaced by linear interpolation June 18, +! 2004) below up to x=xnir(imnir), model grid index lmnir +! + do l=1,lmnir + call lint1(xnir,hr,imnir,xnir(1),xnir(imnir),x(l), & + & qnirh(l)) + qnirh(l)=co2mr(l)*qnirh(l) + enddo +! +! Do linear interpolation above, if applicable, to zero at xtopn +! (currently set to 15.5) and above +! + if(lmnir.lt.lx) then + g=hr(imnir)*rdxnir + do l=lmnir+1,lx + dx=xtopn-x(l) + if(dx.ge.0.) then + qnirh(l)=co2mr(l)*dx*g + else + qnirh(l)=0. + endif + enddo + endif + endif + + end subroutine qnirc + +!*********************************************************************** +! End file co2hc.f +!*********************************************************************** +!*********************************************************************** +! File splin.f +!*********************************************************************** +! December 2006: created by Rashid Akmaev + +! Simple spline interpolation subroutines optimized for various numbers +! of input/output arrays. + +! Contains +! subroutine splin1(x1,y1,x2,y2,n1,n2) +! for y1[x1(n1)] -> y2[x2(n2)] +! subroutine splin2(x1,y1,x2,y2,n1,n2,jm,km) +! for km transforms y1[km,x1(n1)] -> y2[km,x2(n2)] on the same grids +! x1 and x2, and jm - first dimension of y1 and y2 + +!*********************************************************************** + + subroutine splin1(x1,y1,x2,y2,n1,n2) + +! A simple routine to interpolate y1[x1(n1)] to y2[x2(n2)] using cubic +! spline. +! Both x1 and x2 are assumed to be ordered in THE SAME, ascending or +! descending, order. + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Oct 2006: Rashid Akmaev + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine arguments +! INPUT + integer,intent(in):: n1,n2 + real,intent(in):: x1(n1),y1(n1),x2(n2) +! OUTPUT + real,intent(out):: y2(n2) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Internal parameters, work space +! + real,parameter:: one_third=1./3. + integer:: i,k,l,nvs + real:: a(n1),dx,dxmh,dy(n1),e(n1),f(n1),g,h(n1),wx1(n1),wx2(n2) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Initialize output +! + y2(:)=0. +! +! Simple check of argument order +! + if(x1(1).lt.x1(n1)) then + wx1(:)=x1(:) + wx2(:)=x2(:) + else +! +! Reverse x1 and x2 (changing sign seems easier than changing order) +! + wx1(:)=-x1(:) + wx2(:)=-x2(:) + endif +! +! Prepare spline coefficients (Note: they depend on y and so have to +! be recalculated every time) + + nvs=n1-1 + do k=1,nvs + h(k)=wx1(k+1)-wx1(k) + dy(k)=(y1(k+1)-y1(k))/h(k) + enddo + a(1)=0. + a(n1)=0. + e(n1)=0. + f(n1)=0. + do k=nvs,2,-1 + g=1./(h(k)*e(k+1)+2.*(h(k-1)+h(k))) + e(k)=-g*h(k-1) + f(k)=g*(3.*(dy(k)-dy(k-1))-h(k)*f(k+1)) + enddo + do k=2,nvs + a(k)=e(k)*a(k-1)+f(k) + enddo +! +! Calculate spline values +! + l=1 + do i=1,n2 + do k=l,nvs + dx=wx2(i)-wx1(k) + dxmh=dx-h(k) + l=k + if(dxmh.le.0.) exit + enddo + g=dx/h(l) + y2(i)=y1(l)+dx*(dy(l)+one_third*dxmh*(a(l)*(2.-g)+ & + & a(l+1)*(1.+g))) + enddo + + end subroutine splin1 + +!*********************************************************************** + + subroutine splin2(x1,y1,x2,y2,n1,n2,jm,km) + +! A simple routine to interpolate km arrays y1[x1(n1)], specified on +! the same grid x1(n1), to km arrays y2[x2(n2)] on the same grid x2(n2) +! using cubic spline, where km<=jm and jm is the first dimension of +! arrays y1 and y2. +! Both grids x1 and x2 are assumed to be ordered in THE SAME, ascending +! or descending, order. + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Dec 2006: Rashid Akmaev +! Made from splin1 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine arguments +! INPUT + integer,intent(in):: jm,km,n1,n2 + real,intent(in):: x1(n1),y1(jm,n1),x2(n2) +! OUTPUT + real,intent(out):: y2(jm,n2) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Internal parameters, work space +! + real,parameter:: one_third=1./3. + integer:: i,j,k,l,nvs + real:: a(km,n1),dx,dxmh,dy(km,n1),e(n1),f(km,n1),g,g2,h(n1), & + & wx1(n1),wx2(n2) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Initialize output +! + y2(:,:)=0. +! +! Simple check of argument order +! + if(x1(1).lt.x1(n1)) then + wx1(:)=x1(:) + wx2(:)=x2(:) + else +! +! Reverse x1 and x2 (changing sign seems easier than changing order) +! + wx1(:)=-x1(:) + wx2(:)=-x2(:) + endif +! +! Prepare spline coefficients +! + nvs=n1-1 + do k=1,nvs + h(k)=wx1(k+1)-wx1(k) + do j=1,km + dy(j,k)=(y1(j,k+1)-y1(j,k))/h(k) + enddo + enddo + e(n1)=0. + do j=1,km + a(j,1)=0. + a(j,n1)=0. + f(j,n1)=0. + enddo +! +! Calculate e and f coefficients +! + do k=nvs,2,-1 + g=1./(h(k)*e(k+1)+2.*(h(k-1)+h(k))) + e(k)=-g*h(k-1) + do j=1,km + f(j,k)=g*(3.*(dy(j,k)-dy(j,k-1))-h(k)*f(j,k+1)) + enddo + enddo +! +! Calculate a coefficients +! + do k=2,nvs + do j=1,km + a(j,k)=e(k)*a(j,k-1)+f(j,k) + enddo + enddo +! +! Calculate spline values +! + l=1 + do i=1,n2 + do k=l,nvs + dx=wx2(i)-wx1(k) + dxmh=dx-h(k) + l=k + if(dxmh.le.0.) exit + enddo + dxmh=one_third*dxmh + g=1.+dx/h(l) + g2=3.-g + do j=1,km + y2(j,i)=y1(j,l)+dx*(dy(j,l)+dxmh*(a(j,l)*g2+a(j,l+1)*g)) + enddo + enddo + + end subroutine splin2 + +!*********************************************************************** +! End file splin.f +!*********************************************************************** diff --git a/gsmphys/cs_conv.f90 b/gsmphys/cs_conv.f90 new file mode 100644 index 00000000..f3030f0a --- /dev/null +++ b/gsmphys/cs_conv.f90 @@ -0,0 +1,3873 @@ +module cs_conv +!--------------------------------------------------------------------------------- +! Purpose: +! +!>--------------------------------------------------------------------------------- +! Purpose: +! +! Interface for Chikira-Sugiyama convection scheme +! +! Author: Minoru Chikira +! History: +! June 26 2014 D. Dazlich - Modified for GFS +! Apr 10 2015 : S. Moorthi - check for allocatable arrays and fix argument for cbmfx +! Oct 2015 : D. Dazlich - Add computation of updraft area fraction (sigma) for +! diagnostic purposes. +! Aug 2016 : D. Dazlich - Create flux form of tendencies and multiply by +! Arakawa-Wu functions of sigma +! Sep 2016 : S. Moorthi - found two bugs - cleanup and some optimization +! Oct 2016 : S. Moorthi - added sigma affects on tracers and CUMFLX and CUMDET +! made many cosmetic changes +! Nov 2016 : S. Moorthi - further optimization and cleanup and several bug fixes +! +! Arakawa-Wu implemtation: for background, consult An Introduction to the +! General Circulation of the Atmosphere, Randall, chapter six. +! Traditional parameterizations compute tendencies like those in eq 103, 105 and 106. +! Because Arakawa-Wu applies different functions to different components to the +! terms within these equations, it requires the terms used in alternate eqns 91 - 93. +! The code required to compute these terms is added within, and the appropriate +! functions of updraft area fraction (sigma) are applied. Thus, AW requires three +! steps: +! computation of the updraft area fraction +! alternative representation of the tendency terms +! application of functions of sigma to the alternative tendency terms +! here, and in gbphys to the large-scale microphysics tendencies. +! +! The bulk of AW is implemented within subroutine CS_CUMLUS, and the routines it calls. +! +!--------------------------------------------------------------------------------- +! + use machine , only : r8 => kind_phys + use physcons, only : cp => con_cp, grav => con_g, & + & rair => con_rd, rvap => con_rv, & + & cliq => con_cliq, cvap => con_cvap, & + & epsv => con_eps, epsvm1 => con_epsm1, & + & epsvt => con_fvirt, & + & el => con_hvap, emelt => con_hfus, t0c => con_t0c + use funcphys, only : fpvs ! this is saturation vapor pressure in funcphys.f + + + implicit none + + private ! Make default type private to the module + + real(r8), parameter :: zero=0.0d0, one=1.0d0, half=0.5d0 + real(r8), parameter :: cpoel=cp/el, cpoesub=cp/(el+emelt), esubocp=1.0/cpoesub, & + elocp=el/cp, oneocp=one/cp, gocp=grav/cp, gravi=one/grav,& + emeltocp=emelt/cp, cpoemelt=cp/emelt + real(r8), parameter :: fact1=(cvap-cliq)/rvap, fact2=el/rvap-fact1*t0c + logical, parameter :: adjustp=.true. + +! Tuning parameters set from namelist +! +! real(r8), save, public :: CLMD = 0.6, & ! entrainment efficiency + real(r8), save, public :: CLMD = 0.7, & ! entrainment efficiency + PA=0.15, & ! factor for buoyancy to affect updraft velocity + CPRES = 0.55, & ! pressure factor for momentum transport + ALP0 = 8.0e7 ! alpha parameter in prognostic closure + +!DD next two parameters control partitioning of water between detrainment +!DD and precipitation. Decrease for more precip +!M REAL(r8), public, save :: PRECZ0 = 1.5e3_r8 ! default = 1.5e3 +!M REAL(r8), public, save :: PRECZ0 = 1.5e3_r8 ! default = 1.5e3 +! REAL(r8), public, save :: PRECZ0 = 1.5e3_r8 ! default = 1.5e3 +! REAL(r8), public, save :: PRECZH = 4.e3_r8 ! default = 4.e3 + +! REAL(r8), public, save :: PRECZ0 = 1.0e3_r8 ! default = 1.5e3 +! REAL(r8), public, save :: PRECZH = 3.e3_r8 ! default = 4.e3 + +! REAL(r8), public, save :: PRECZ0 = 0.5e3_r8 ! default = 1.5e3 +! REAL(r8), public, save :: PRECZH = 2.e3_r8 ! default = 4.e3 + + real(r8), public :: precz0, preczh +! +! Private data +! + real(r8), parameter :: unset_r8 = -999._r8 ! missing value +! + integer :: iulog ! unit to write debugging and diagnostic output + !DD Note - see if I can find corresponding variable in a GFS module +! +! Shared variables +! + integer, parameter :: ITI = 2, ITL = 3 ! index of ice and liquid water + +! logical :: outputflag(100) + +!DD integer, save :: ICHNK ! chunk identifier + +! [INTERNAL PARM] !DD moved to module scope and allocatable + +! logical, save, dimension(50) :: OTSPT1, OTSPT2 + integer, save, dimension(50) :: IMFXR ! 0: mass fixer is not applied + ! tracers which may become negative + ! values e.g. subgrid-PDFs + ! 1: mass fixer is applied, total mass + ! may change through cumulus scheme + ! e.g. moisture, liquid cloud, ice + ! cloud, aerosols + ! 2: mass fixer is applied, total mass + ! never change through cumulus scheme + ! e.g. CO2 + +! LOGICAL, SAVE, ALLOCATABLE, DIMENSION(:) :: OTSPT1 ! tracer transport by updraft, downdraft on/off + ! should not include subgrid PDF and turbulence +! LOGICAL, SAVE, ALLOCATABLE, DIMENSION(:) :: OTSPT2 ! tracer transport by subsidence on/off + ! should include subgrid PDF and turbulence +! INTEGER, SAVE, ALLOCATABLE, DIMENSION(:) :: IMFXR +! REAL(r8), SAVE, ALLOCATABLE, DIMENSION(:) :: FSCAV !DD split declaration and initialization +! REAL(r8), SAVE, ALLOCATABLE, DIMENSION(:) :: FSWTR !DD split declaration and initialization +! +! +! + +! PUBLIC: interfaces +! + public cs_convr ! CS scheme main driver + + contains + +!--------------------------------------------------------------------------------- +! use GFS functions + function FQSAT( T, P ) ! calculate saturation water vapor + + implicit none + + real(r8) :: FQSAT ! saturation water vapor + real(r8), intent(in) :: T ! temperature [K] + real(r8), intent(in) :: P ! pressure [Pa] + +! real(r8), parameter :: one_m10=1.0d-10, & +! ES0 = 611._r8, & ! saturation e at 0 deg C (Pa) +! TQICE = 273.15_r8, & ! T threshold for ice QSAT +! TMELT = 273.15_r8 ! melting point of water + +!DD FQSAT = EPSV * ES0 / P & +!DD * EXP( (EL+EMELT/2._r8*(1._r8-SIGN(1._r8,T-TQICE))) & +!DD /RVAP *( 1._r8/TMELT - 1._r8/T ) ) + + FQSAT = min(p,fpvs(T)) !DD this is saturation vapor pressure + +! FQSAT = EPSV * FQSAT / P !DD This is saturation mixing ratio +! FQSAT = EPSV * FQSAT / (max(p+epsvm1*fqsat,ONE_M10)) !DD&Moo This is saturation specific humidity + FQSAT = min(EPSV*FQSAT/max(p+epsvm1*fqsat,1.0e-10), 1.0) !DD&Moo This is saturation specific humidity + + end function FQSAT +!--------------------------------------------------------------------------------- +! following GFS + function FDQSAT( T, QS ) ! calculate d(qs)/dT + + implicit none + + real(r8) :: FDQSAT ! d(QSAT)/d(T) + real(r8), intent(in) :: T ! temperature [K] + real(r8), intent(in) :: QS ! saturation water vapor [kg/kg] + real(r8) :: wrk + + real(r8), parameter :: fact1=(cvap-cliq)/rvap,fact2=el/rvap-fact1*t0c + +!DD FDQSAT = (EL+EMELT/2._r8*(1._r8-SIGN(1._r8,T-TMELT))) & +!DD * QS / ( RVAP * T*T ) + + wrk = 1.0 / t + FDQSAT = qs * wrk * (fact1 + fact2*wrk) +! FDQSAT = qs * (fact1 / t + fact2 / (t**2)) + + + end function FDQSAT +!--------------------------------------------------------------------------------- + subroutine cs_convr(IM , IJSDIM , KMAX , NTR , nctp, & !DD dimensions + otspt , lat ,kdt , & + t , q , prec , clw , & + zm , zi , pap , paph , & + delta , delti , ud_mf , dd_mf , dt_mf, & + u , v , fscav , fswtr, & + cbmfx , mype , wcbmaxm , precz0in, preczhin, & + sigmai , sigma , vverti , do_aw, do_awdd, & + lprnt, ipr, & +! for coupling to Morrison microphysics + QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, & + CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,ncld) + +!--------------------------------------------------------------------------------- +! Purpose: +! +! Main driver for Chikira-Sugiyama convective scheme +! +! Author: Minoru Chikira +! +!--------------------------------------------------------------------------------- + + implicit none +! +! input arguments +! + INTEGER, INTENT(IN) :: IM,IJSDIM, KMAX, NTR, mype, nctp, ncld, kdt,lat !! DD, for GFS, pass in + logical, intent(in) :: otspt(ntr,2) + + + real(r8), intent(inout) :: t(IM,KMAX) ! temperature at mid-layer (K) + real(r8), intent(inout) :: q(IM,KMAX) ! water vapor array including moisture (kg/kg) + real(r8), intent(inout) :: clw(IM,KMAX,ntr-1) ! tracer array including cloud condensate (kg/kg) + real(r8), intent(in) :: pap(IM,KMAX) ! pressure at mid-layer (Pa) + real(r8), intent(in) :: paph(IM,KMAX+1) ! pressure at boundaries (Pa) + real(r8), intent(in) :: zm(IM,KMAX) ! geopotential at mid-layer (m) + real(r8), intent(in) :: zi(IM,KMAX+1) ! geopotential at boundaries (m) + real(r8), intent(in) :: fscav(ntr), fswtr(ntr), wcbmaxm(ijsdim) + real(r8), intent(in) :: precz0in, preczhin +! added for cs_convr + real(r8), intent(inout) :: u(IM,KMAX) ! zonal wind at mid-layer (m/s) + real(r8), intent(inout) :: v(IM,KMAX) ! meridional wind at mid-layer (m/s) + + real(r8), intent(in) :: DELTA ! physics time step + real(r8), intent(in) :: DELTI ! dynamics time step (model time increment in seconds) + logical, intent(in) :: do_aw, do_awdd +! +! modified arguments +! + real(r8), intent(inout) :: CBMFX(IM,nctp) ! cloud base mass flux (kg/m2/s) +! +! output arguments +! +! updraft, downdraft, and detrainment mass flux (kg/m2/s) + real(r8), intent(inout), dimension(IJSDIM,KMAX) :: ud_mf, dd_mf, dt_mf + + real(r8), intent(out) :: prec(IJSDIM) ! precipitation at surface (including snowfall) (kg/m2/s) + real(r8), intent(out), dimension(ijsdim,kmax) :: qlcn, qicn, w_upi,cnv_mfd, cnv_prc3,& + cnv_dqldt, clcn, cnv_fice, & + cnv_ndrop, cnv_nice, cf_upi + +!DDsigma - output added for AW sigma diagnostics +! interface sigma and vertical velocity by cloud type (1=sfc) + real(r8), intent(out), dimension(IM,KMAX,nctp) :: sigmai, vverti + real(r8), intent(out), dimension(IM,KMAX) :: sigma ! sigma sigma totaled over cloud type - on interfaces (1=sfc) +! sigma terms in eq 91 and 92 + real(r8), dimension(IM,KMAX) :: sfluxterm, qvfluxterm, condterm +!DDsigma +! +! output arguments of CS_CUMLUS +! + real(r8) GTT(IJSDIM,KMAX) ! temperature tendency [K/s] + real(r8) GTQ(IJSDIM,KMAX,NTR) ! tracer tendency [kg/kg/s] + real(r8) GTU(IJSDIM,KMAX) ! zonal velocity tendency [m/s2] + real(r8) GTV(IJSDIM,KMAX) ! meridional velocity tendency [m/s2] + real(r8) GTPRP(IJSDIM,KMAX) ! precipitation (including snowfall) flux at interfaces [kg/m2/s] + real(r8) GSNWP(IJSDIM,KMAX) ! snowfall flux at interfaces [kg/m2/s] + +! real(r8) CMDET(IJSDIM,KMAX) ! detrainment mass flux [kg/m2/s] +! real(r8) GTLDET(IJSDIM,KMAX) ! cloud liquid tendency by detrainment [1/s] +! real(r8) GTIDET(IJSDIM,KMAX) ! cloud ice tendency by detrainment [1/s] + +!DD removed as output arguments +! real(r8) :: jctop(IJSDIM) ! o row of top-of-deep-convection indices passed out. +! real(r8) :: jcbot(IJSDIM) ! o row of base of cloud indices passed out. + +! The following commented by moorthi to save memory for now - oct 2016 +! real(r8) :: dlf(IJSDIM,KMAX) ! scattered version of the detraining cld h2o tend (kg/kg/s) +! real(r8) :: pflx(IJSDIM,KMAX+1) ! scattered precip flux at each level +! real(r8) :: cme(IJSDIM,KMAX) ! condensation - evaporation +! real(r8) :: rliq(IJSDIM) ! reserved liquid (not yet in cldliq) for energy integrals (m/s) +! real(r8) :: flxprec(IJSDIM,KMAX+1) ! precipitation flux (including snowfall) at interfaces (kg/m2/s) +! real(r8) :: flxsnow(IJSDIM,KMAX+1) ! snowfall flux at interfaces (kg/m2/s) + + integer KT(IJSDIM,nctp) ! cloud top index for each cloud type + + real(r8) :: cape(IJSDIM) ! convective available potential energy (J/kg) + real(r8) :: snow(IJSDIM) ! snowfall at surface (kg/m2/s) + +! +! input arguments of CS_CUMLUS +! + real(r8) GDT(IJSDIM,KMAX) ! temperature [K] + real(r8) GDQ(IJSDIM,KMAX,NTR) ! tracers including moisture [kg/kg] !DDsigmadiag + real(r8) GDU(IJSDIM,KMAX) ! zonal wind [m/s] + real(r8) GDV(IJSDIM,KMAX) ! meridional wind [m/s] + real(r8) GDTM(IJSDIM,KMAX+1) ! temperature at boundaries of layers [K] + real(r8) GDP(IJSDIM,KMAX) ! pressure [Pa] + real(r8) GDPM(IJSDIM,KMAX+1) ! pressure at boundaries of layers [Pa] + real(r8) GDZ(IJSDIM,KMAX) ! altitude [m] + real(r8) GDZM(IJSDIM,KMAX+1) ! altitude at boundaries of layers [m] + real(r8) delp(IJSDIM,KMAX) ! altitude at boundaries of layers [m] +! +! local variables +! +!DD real(r8) :: zs(IJSDIM) ! surface height [m] + + integer KTMAX(IJSDIM) ! max of KT + real(r8) :: ftintm, wrk, wrk1, tem + integer i, k, n, ISTS, IENS, kp1, ipr +! integer i, k, n, iunit + +!DD borrowed from RAS to go form total condensate to ice/water separately +! parameter (tf=130.16, tcr=160.16, tcrf=1.0/(tcr-tf),tcl=2.0) +! parameter (tf=230.16, tcr=260.16, tcrf=1.0/(tcr-tf)) + real(r8), parameter :: tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf), tcl=2.0 + logical, save :: first=.true. + logical lprnt + + + precz0 = precz0in + preczh = preczhin +! +! lprnt = lat == 15 .and. kdt <= 2 + if (first) then +! write(1000+mype,*)' precz0=',precz0,' preczh=',preczh,' nctp=',nctp + do i=1,ntr + IMFXR(i) = 0 + enddo +! IMFXR(1) = 1 +! IMFXR(ITL) = 1 +! IMFXR(ITI) = 1 + first = .false. + endif +! + ISTS = 1 + IENS = IJSDIM + + do k=1,KMAX+1 + do i=1,IJSDIM + GDZM(i,k) = zi(i,k) * gravi + GDPM(i,k) = paph(i,k) + enddo + enddo + + do k=1,KMAX + do i=1,IJSDIM + GDT(i,k) = t(i,k) + GDU(i,k) = u(i,k) + GDV(i,k) = v(i,k) + GDZ(i,k) = zm(i,k) * gravi + GDP(i,k) = pap(i,k) + GDQ(i,k,1) = q(i,k) + delp(i,k) = paph(i,k) - paph(i,k+1) + enddo + enddo + +!DD following adapted from ras + if (clw(1,1,2) <= -999.0) then ! input ice/water are together + do k=1,kmax + do i=1,IJSDIM + tem = clw(i,k,1) * MAX(ZERO, MIN(ONE, (TCR-t(i,k))*TCRF)) + clw(i,k,2) = clw(i,k,1) - tem + clw(i,k,1) = tem + enddo + enddo + endif +!DD end ras adaptation + do k=1,kmax + do i=1,ijsdim + tem = min(clw(i,k,1), 0.0) + wrk = min(clw(i,k,2), 0.0) + clw(i,k,1) = clw(i,k,1) - tem + clw(i,k,2) = clw(i,k,2) - wrk + gdq(i,k,1) = gdq(i,k,1) + tem + wrk + enddo + enddo + + do n=2,NTR + do k=1,KMAX + do i=1,IJSDIM + GDQ(i,k,n) = clw(i,k,n-1) !DDsigmadiag + enddo + enddo + enddo +!*************************************************************************************** +! iunit = 400 + mype +! write(iunit,*)kmax,'kmax',delta,'delta',im,'im',ijsdim,'ijsdim',iens,'iens',ists,'ists' !DDdebug +! write(iunit,*),i !DDdebug +! do i = 1, 1 !DDdebug +! write(iunit,*)'gdt' !DDdebug +! write(iunit,*)gdt(I,:) !DDdebug +! write(iunit,*)'gdu' !DDdebug +! write(iunit,*)gdu(I,:) !DDdebug +! write(iunit,*)'gdv' !DDdebug +! write(iunit,*)gdv(I,:) !DDdebug +! do k = 1,ntr !DDdebug +! write(iunit,*)'gdq',k !DDdebug +! write(iunit,*)gdq(I,:,k) !DDdebug +! enddo !DDdebug +! write(iunit,*)'gdz' !DDdebug +! write(iunit,*)gdz(I,:) !DDdebug +! write(iunit,*)'gdp' !DDdebug +! write(iunit,*)gdp(I,:) !DDdebug +! write(iunit,*)'gdzm' !DDdebug +! write(iunit,*)gdzm(I,:) !DDdebug +! write(iunit,*)'gdpm' !DDdebug +! write(iunit,*)gdpm(I,:) !DDdebug +! write(iunit,*)'cbmfx' !DDdebug +! write(iunit,*)cbmfx(I,:) !DDdebug +! enddo !DDdebug +!*************************************************************************************** +! +! calculate temperature at interfaces +! +! call TINTP( IJSDIM, KMAX , & !DD dimensions +! GDTM, & ! output +! GDT, GDP, GDPM, & ! input +! ISTS, IENS ) ! active array size + + DO K=2,KMAX + DO I=ISTS,IENS + wrk = one / GDP(I,K) + wrk1 = one / LOG(GDP(I,K-1)*wrk) + FTINTM = wrk1 * LOG(GDPM(I,K)*wrk) + GDTM(I,K) = FTINTM*GDT(I,K-1) + (one-FTINTM)*GDT(I,K) + ENDDO + ENDDO + + DO I=ISTS,IENS + GDTM(I,KMAX+1) = GDT(I,KMAX) + GDTM(I,1) = GDT(I,1) ! Is this a good approximation ? - Moorthi + ENDDO + +!DDsigma - initialize the sigma diagnostics + do n=1,nctp + do k=1,kmax + do i=ists,iens + sigmai(i,k,n) = zero !DDsigma + vverti(i,k,n) = zero !DDsigma + enddo + enddo + enddo + do k=1,kmax + do i=ists,iens + sigma(i,k) = zero !DDsigma + enddo + enddo +! +! call main routine +! +!*************************************************************************************** + call CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions + otspt(1,1), otspt(1,2), lprnt, ipr,& + GTT , GTQ , GTU , GTV , & ! output +! CMDET , GTLDET, GTIDET, & ! output +! GTPRP , GSNWP , GMFX0 , & ! output +! GMFX1 , cape , KT , & ! output +! dt_mf , GTLDET, GTIDET, & ! output + dt_mf , & ! output + GTPRP , GSNWP , ud_mf , & ! output + dd_mf , cape , KT , & ! output + CBMFX , & ! modified + GDT , GDQ , GDU , GDV , & ! input + GDTM , & ! input + GDP , GDPM , GDZ , GDZM , & ! input + DELTA , DELTI , ISTS , IENS, mype,& ! input + fscav, fswtr, wcbmaxm, nctp, & + sigmai, sigma, vverti, & ! input/output !DDsigma + sfluxterm, qvfluxterm, do_aw, do_awdd)!DDsigmadiag, output +! +! +!DD detrainment has to be added in for GFS +! +! if (lprnt) write(0,*)' aft cs_cum gtqi=',gtq(ipr,:,2) +! if (lprnt) write(0,*)' aft cs_cum gtql=',gtq(ipr,:,3) + do n=2,NTR + do k=1,KMAX + do i=1,IJSDIM + clw(i,k,n-1) = GDQ(i,k,n) + GTQ(i,k,n) * delta +! clw(i,k,1) = GDQ(i,k,2) + (gtq(i,k,2) + gtidet(i,k)) * delta +! clw(i,k,2) = GDQ(i,k,3) + (gtq(i,k,3) + gtldet(i,k)) * delta + enddo + enddo + enddo + +! if (ntr > 3) then ! update tracers +! do n=4,ntr +! do k=1,kmax +! do i=1,ijsdim +! clw(i,k,n-1) = gdq(i,k,n) + gtq(i,k,n) * delta +! enddo +! enddo +! enddo +! endif +! + do k=1,KMAX + do i=1,IJSDIM +!DD heat(i,KMAX-k+1) = CP*GTT(i,k) - EMELT*GTIDET(i,k) +!DD dlf (i,k) = GTLDET(i,k) + GTIDET(i,k) +!DD rliq(i) = (GTLDET(i,k)+GTIDET(i,k))*(GDPM(i,k+1)-GDPM(i,k))/GRAV + + q(i,k) = GDQ(i,k,1) + GTQ(i,k,1) * delta + t(i,k) = GDT(i,k) + GTT(i,k) * delta + u(i,k) = GDU(i,k) + GTU(i,k) * delta + v(i,k) = GDV(i,k) + GTV(i,k) * delta +! +! not used for now - moorthi +! flxprec(i,k) = GTPRP(i,k) +! flxsnow(i,k) = GSNWP(i,k) + +! Set the mass fluxes. +! ud_mf (i,k) = GMFX0(i,k) +! dd_mf (i,k) = GMFX1(i,k) +! dt_mf (i,k) = CMDET(i,k) +! if (lprnt .and. i == ipr) write(0,*)' k=',k,'in cs_conv qv=',q(ipr,k)& +! , ' GDQ=',gdq(ipr,k,1),' gtq=',GTQ(ipr,k,1)*delta,' kdt=',kdt + enddo + enddo +! if (lprnt) write(0,*)' in cs_conv qv=',q(ipr,1:35) + + if (ncld == 2) then ! for 2M microphysics, always output these variables + if (do_aw) then + do k=1,KMAX + kp1 = min(k+1,kmax) + do i=1,IJSDIM + qicn(i,k) = max(0.0, clw(i,k,1)-gdq(i,k,2)) + qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) + +!! qicn(i,k) = max(0.0, (gtq(i,k,2)+gtidet(i,k)) * delta) +!! qlcn(i,k) = max(0.0, (gtq(i,k,3)+gtldet(i,k)) * delta) + cnv_fice(i,k) = qicn(i,k) / max(1.0e-10,qicn(i,k)+qlcn(i,k)) +! + CNV_MFD(i,k) = dt_mf(i,k) * (1.0/delta) +!! CNV_DQLDT(i,k) = dt_mf(i,k) * max(0.0,gtidet(i,k)+gtldet(i,k)) + CNV_DQLDT(i,k) = (qicn(i,k)+qlcn(i,k)) / delta + CNV_PRC3(i,k) = 0.0 + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + cf_upi(i,k) = max(0.0, min(0.5, 0.5*(sigma(i,k)+sigma(i,kp1)))) + CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft +!! clcn(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)/delta),0.25)) + + w_upi(i,k) = 0.0 +!! w_upi(i,k) = ud_mf(i,k)*(t(i,k)+epsvt*gdq(i,k,1)) * rair & +!! / (delta*max(cf_upi(i,k),1.e-12)*gdp(i,k)) + enddo + enddo +!! do n=1,nctp + do k=1,kmax + do i=1,ijsdim +!! w_upi(i,k) = w_upi(i,k) + 0.25*(sigmai(i,k,n)+sigmai(i,k+1,n)) & +!! * (vverti(i,k,n)+vverti(i,k+1,n)) + tem = 0.0 + do n=1,nctp + tem = tem + sigmai(i,k,n) + w_upi(i,k) = w_upi(i,k) + sigmai(i,k,n) * vverti(i,k,n) + enddo + w_upi(i,k) = w_upi(i,k) / max (1.0e-10,tem) + +!! cf_upi(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)/delta),0.25)) +!! & 500*ud_mf(i,k)/delta),0.60)) +!! CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft + +!! w_upi(i,k) = ud_mf(i,k)*(t(i,k)+epsvt*gdq(i,k,1)) * rair & +!! / (delta*max(cf_upi(i,k),1.e-12)*gdp(i,k)) + + enddo + enddo +!! enddo +!! do k=1,kmax +!! do i=1,ijsdim +!! w_upi(i,k) = w_upi(i,k) / max(1.0e-9, 0.5*(sigma(i,k)+sigma(i,k+1))) +!! enddo +!! enddo + else + do k=1,KMAX + do i=1,IJSDIM + qicn(i,k) = max(0.0, clw(i,k,1)-gdq(i,k,2)) + qlcn(i,k) = max(0.0, clw(i,k,2)-gdq(i,k,3)) +! qicn(i,k) = max(0.0, (gtq(i,k,2)+gtidet(i,k)) * delta) +! qlcn(i,k) = max(0.0, (gtq(i,k,3)+gtldet(i,k)) * delta) + cnv_fice(i,k) = qicn(i,k) / max(1.0e-10,qicn(i,k)+qlcn(i,k)) +! + CNV_MFD(i,k) = dt_mf(i,k) * (1/delta) +! CNV_DQLDT(i,k) = max(0.0,gtidet(i,k)+gtldet(i,k)) + CNV_DQLDT(i,k) = (qicn(i,k)+qlcn(i,k)) / delta + CNV_PRC3(i,k) = 0.0 + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + cf_upi(i,k) = max(0.0,min(0.01*log(1.0+500*ud_mf(i,k)/delta),0.25)) +! & 500*ud_mf(i,k)/delta),0.60)) + CLCN(i,k) = cf_upi(i,k) !downdraft is below updraft + + w_upi(i,k) = ud_mf(i,k)*(t(i,k)+epsvt*gdq(i,k,1)) * rair & + / (delta*max(cf_upi(i,k),1.e-12)*gdp(i,k)) + enddo + enddo + endif + endif + +!**************************************************************************** +! do i=1,1 !DDdebug +! write(iunit,*)'gtt' !DDdebug +! write(iunit,*)gtt(I,:) !DDdebug +! do k = 1,ntr !DDdebug +! write(iunit,*)'gtq',k !DDdebug +! write(iunit,*)gtq(I,:,k) !DDdebug +! enddo !DDdebug +! write(iunit,*)'gtu' !DDdebug +! write(iunit,*)gtu(I,:) !DDdebug +! write(iunit,*)'gtv' !DDdebug +! write(iunit,*)gtv(I,:) !DDdebug +! write(iunit,*)'gtprp' !DDdebug +! write(iunit,*)gtprp(I,:) !DDdebug +! write(iunit,*)'gsnwp' !DDdebug +! write(iunit,*)gsnwp(I,:) !DDdebug +! write(iunit,*)'gmfx0' !DDdebug +! write(iunit,*)gmfx0(I,:) !DDdebug +! write(iunit,*)'gmfx1' !DDdebug +! write(iunit,*)gmfx1(I,:) !DDdebug +! write(iunit,*)'cmdet' !DDdebug +! write(iunit,*)cmdet(I,:) !DDdebug +! write(iunit,*)'cbmfx' !DDdebug +! write(iunit,*)cbmfx(I,:) !DDdebug +! write(iunit,*)'kt' !DDdebug +! write(iunit,*)kt(I,:) !DDdebug +! write(iunit,*)'cape' !DDdebug +! write(iunit,*)cape(I) !DDdebug +! write(iunit,*)'gtldet' !DDdebug +! write(iunit,*)gtldet(I,:) !DDdebug +! write(iunit,*)'gtidet' !DDdebug +! write(iunit,*)gtldet(I,:) !DDdebug +! enddo !DDdebug +!**************************************************************************** +! + KTMAX = 1 + do n=1,nctp + do i=1,IJSDIM + KTMAX(i) = max(KTMAX(i), KT(i,n)) + enddo + enddo +! + do i=1,IJSDIM +! jctop(i) = KTMAX(i) + prec(i) = GTPRP(i,1) + snow(i) = GSNWP(i,1) +! rliq(i) = rliq(i)/1000._r8 ! kg/m2/s => m/s + enddo +! if (lprnt) then +! write(0,*)' aft cs_cum prec=',prec(ipr),'GTPRP=',GTPRP(ipr,1) +! endif + +! cme = zero ! temporarily set to be zero +! pflx = zero ! temporarily set to be zero +! jcbot = 1 ! set to be the lowest layer +! if (lprnt) then +! write(2000+mype,*)' gdq=',gdq(13,:,1) +! write(2000+mype,*)' q=',q(13,:) +! endif + +! if (do_aw) then +! call moist_bud(ijsdim,ijsdim,im,kmax,mype,kdt,grav,delta,delp,prec & +! , gdq(1,1,1), gdq(1,1,2), gdq(1,1,3) & +! , q,clw(1,1,1),clw(1,1,2),'cs_conv_aw') +! endif + + end subroutine cs_convr + + +!************************************************************************ +!* Original source code in MIROC5 +!* +!* PACKAGE PCUMC !! physics: cumulus parameterization with +!* state-dependent entrainment rate +!* developed by Minoru Chikira +!* [Note] +!* -This routine works as the prognostic Arakawa-Schubert scheme +!* if OPT_ASMODE is specified. +!* -Specify OPT_NS02 to use entrainment rate of Neggers et al. (2002) +!* -Specify OPT_CUMBGT to check water and energy budget. +!* -Specify OPT_CUMCHK to check range of output values. +!* +!* [HIS] 08/09/19(chikira) MIROC4.1 +!* 08/10/30(hiro) CMT modified +!* 08/11/11(chikira) Neggers et al. (2002) +!* 08/12/3 (chikira) downdraft detrainment modified +!* 08/12/3 (chikira) COSP output +!* 09/02/24(chikira) fix convective inhibition +!* 09/04/16(hiro) CMIP5 output (cbasep,ctopp) +!* 09/09/03(yokohata) COSP +!* 10/11/19(toshi) small bug fix +!* 14/02/07(chikira) CUMDWN bug fix, CMT modified +!************************************************************************ +! cumulus main routine +! -------------------- + SUBROUTINE CS_CUMLUS (im , IJSDIM, KMAX , NTR , & !DD dimensions + otspt1, otspt2, lprnt, ipr, & + GTT , GTQ , GTU , GTV , & ! output +! CMDET , GTLDET, GTIDET, & ! output + CMDET , & ! output + GTPRP , GSNWP , GMFX0 , & ! output + GMFX1 , CAPE , KT , & ! output +! CUMCLW, CUMFRC, + CBMFX , & ! modified + GDT , GDQ , GDU , GDV , & ! input + GDTM , & ! input + GDP , GDPM , GDZ , GDZM , & ! input +! GDCFRC, + DELTA , DELTI , ISTS , IENS, mype,& ! input + fscav, fswtr, wcbmaxm, nctp, & ! + sigmai, sigma, vverti, & ! input/output !DDsigma + sfluxterm, qvfluxterm, do_aw, do_awdd ) ! output !DDsigmadiag +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, mype, nctp, ipr !! DD, for GFS, pass in + logical, intent(in) :: do_aw, do_awdd ! switch to apply Arakawa-Wu to the tendencies + logical, intent(in) :: otspt1(ntr), otspt2(ntr), lprnt +! +! [OUTPUT] + REAL(r8), INTENT(OUT) :: GTT (IJSDIM, KMAX ) !! heating rate + REAL(r8), INTENT(OUT) :: GTQ (IJSDIM, KMAX, NTR) !! change in q + REAL(r8), INTENT(OUT) :: GTU (IJSDIM, KMAX ) !! tendency of u + REAL(r8), INTENT(OUT) :: GTV (IJSDIM, KMAX ) !! tendency of v + REAL(r8), INTENT(OUT) :: CMDET (IJSDIM, KMAX ) !! detrainment mass flux + +! REAL(r8), INTENT(OUT) :: GTLDET(IJSDIM, KMAX ) !! cloud liquid tendency by detrainment +! REAL(r8), INTENT(OUT) :: GTIDET(IJSDIM, KMAX ) !! cloud ice tendency by detrainment + +! assuming there is no flux at the top of the atmospherea - Moorthi + REAL(r8), INTENT(OUT) :: GTPRP (IJSDIM, KMAX ) !! rain+snow flux + REAL(r8), INTENT(OUT) :: GSNWP (IJSDIM, KMAX ) !! snowfall flux + REAL(r8), INTENT(OUT) :: GMFX0 (IJSDIM, KMAX ) !! updraft mass flux + REAL(r8), INTENT(OUT) :: GMFX1 (IJSDIM, KMAX ) !! downdraft mass flux + + REAL(r8), INTENT(OUT) :: CAPE (IJSDIM ) + INTEGER , INTENT(OUT) :: KT (IJSDIM, NCTP ) !! cloud top +! +! [MODIFIED] + REAL(r8), INTENT(INOUT) :: CBMFX (IM, NCTP) !! cloud base mass flux + +!DDsigma - output added for AW sigma diagnostics +! sigma and vert. velocity as a function of cloud type (1==sfc) + real(r8), intent(out), dimension(IM,KMAX,nctp) :: sigmai, vverti + real(r8), intent(out), dimension(IM,KMAX) :: sigma !DDsigma sigma totaled over cloud type - on interfaces (1=sfc) + +! for computing AW flux form of tendencies +! The tendencies are summed over all cloud types + real(r8), intent(out), dimension(IM,KMAX) :: & !DDsigmadiag + sfluxterm, qvfluxterm ! tendencies of DSE and water vapor due to eddy mass flux + real(r8), dimension(IM,KMAX) :: qlfluxterm, qifluxterm ! tendencies of cloud water and cloud ice due to eddy mass flux + +! The fluxes are for an individual cloud type and reused. +! condtermt, condtermq are eddy flux of temperature and water vapor + real(r8), dimension(IM,KMAX) :: condtermt, condtermq, frzterm, & + prectermq, prectermfrz +! +! [INPUT] + REAL(r8), INTENT(IN) :: GDT (IJSDIM, KMAX ) ! temperature T + REAL(r8), INTENT(IN) :: GDQ (IJSDIM, KMAX, NTR) ! humidity, tracer !DDsigmadiag + REAL(r8), INTENT(IN) :: GDU (IJSDIM, KMAX ) ! westerly u + REAL(r8), INTENT(IN) :: GDV (IJSDIM, KMAX ) ! southern wind v + REAL(r8), INTENT(IN) :: GDTM (IJSDIM, KMAX+1 ) ! temperature T + REAL(r8), INTENT(IN) :: GDP (IJSDIM, KMAX ) ! pressure P + REAL(r8), INTENT(IN) :: GDPM (IJSDIM, KMAX+1 ) ! pressure (half lev) + REAL(r8), INTENT(IN) :: GDZ (IJSDIM, KMAX ) ! altitude + REAL(r8), INTENT(IN) :: GDZM (IJSDIM, KMAX+1 ) ! altitude + REAL(r8), INTENT(IN) :: DELTA ! delta(t) (dynamics) + REAL(r8), INTENT(IN) :: DELTI ! delta(t) (internal variable) + INTEGER, INTENT(IN) :: ISTS, IENS ! array range + + real(r8), intent(in) :: fscav(ntr), fswtr(ntr), wcbmaxm(ijsdim) +! +! [INTERNAL WORK] + REAL(r8) GPRCC (IJSDIM, NTR) ! rainfall + REAL(r8) GSNWC (IJSDIM) ! snowfall + REAL(r8) CUMCLW(IJSDIM, KMAX) ! cloud water in cumulus + REAL(r8) CUMFRC(IJSDIM) ! cumulus cloud fraction +!COSP +! REAL(r8) QLIQC (IJSDIM, KMAX) ! cumulus cloud liquid water [kg/kg] +! REAL(r8) QICEC (IJSDIM, KMAX) ! cumulus cloud ice [kg/kg] +! REAL(r8) GPRCPF(IJSDIM, KMAX) ! rainfall flux at full level +! REAL(r8) GSNWPF(IJSDIM, KMAX) ! snowfall flux at full level +! + REAL(r8) GTCFRC(IJSDIM, KMAX) ! change in cloud fraction + REAL(r8) FLIQC (IJSDIM, KMAX) ! liquid ratio in cumulus +! + REAL(r8) GDCFRC(IJSDIM, KMAX) ! cloud fraction +! +! REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice +! REAL(r8) GTQI (IJSDIM, KMAX) ! tendency of cloud ice +! REAL(r8) GTQL (IJSDIM, KMAX) ! tendency of cloud liquid +! + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) GDQS (IJSDIM, KMAX) ! saturate moisture + REAL(r8) FDQS (IJSDIM, KMAX) + REAL(r8) GAM (IJSDIM, KMAX) + REAL(r8) GDS (IJSDIM, KMAX) ! dry static energy + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDHS (IJSDIM, KMAX) ! saturate MSE +! + REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux (half lev) + REAL(r8) GCHB (IJSDIM) ! cloud base MSE-Li*Qi + REAL(r8) GCWB (IJSDIM) ! cloud base total water + REAL(r8) GCUB (IJSDIM) ! cloud base U + REAL(r8) GCVB (IJSDIM) ! cloud base V + REAL(r8) GCIB (IJSDIM) ! cloud base ice + REAL(r8) ELAM (IJSDIM, KMAX, NCTP)! entrainment (rate*massflux) + REAL(r8) GCYT (IJSDIM, NCTP) ! norm. mass flux @top + REAL(r8) GCHT (IJSDIM, NCTP) ! cloud top MSE + REAL(r8) GCQT (IJSDIM, NCTP) ! cloud top q + REAL(r8) GCwT (IJSDIM) ! cloud top total water + REAL(r8) GCUT (IJSDIM, NCTP) ! cloud top U + REAL(r8) GCVT (IJSDIM, NCTP) ! cloud top V + REAL(r8) GCLT (IJSDIM, NCTP) ! cloud top cloud water + REAL(r8) GCIT (IJSDIM, NCTP) ! cloud top cloud ice + REAL(r8) GTPRT (IJSDIM, NCTP) ! precipitation/M + REAL(r8) GCLZ (IJSDIM, KMAX) ! cloud liquid for each CTP + REAL(r8) GCIZ (IJSDIM, KMAX) ! cloud ice for each CTP + + REAL(r8) ACWF (IJSDIM, NCTP) ! cloud work function + REAL(r8) GPRCIZ(IJSDIM, KMAX) ! precipitation + REAL(r8) GSNWIZ(IJSDIM, KMAX) ! snowfall + REAL(r8) GTPRC0(IJSDIM) ! precip. before evap. + + REAL(r8) GMFLX (IJSDIM, KMAX) ! mass flux (updraft+downdraft) + REAL(r8) QLIQ (IJSDIM, KMAX) ! total cloud liquid + REAL(r8) QICE (IJSDIM, KMAX) ! total cloud ice + REAL(r8) GPRCI (IJSDIM, KMAX) ! rainfall generation + REAL(r8) GSNWI (IJSDIM, KMAX) ! snowfall generation + + REAL(r8) GPRCP (IJSDIM, KMAX) ! rainfall flux +! + REAL(r8) GTEVP (IJSDIM, KMAX) ! evaporation+sublimation + REAL(r8) GMDD (IJSDIM, KMAX) ! downdraft mass flux + +! REAL(r8) CUMHGT(IJSDIM, NCTP) ! cloud top height +! REAL(r8) CTOPP (IJSDIM) ! cloud top pressure + + REAL(r8) GDZTR (IJSDIM) ! tropopause height + REAL(r8) FLIQOU(IJSDIM, KMAX) ! liquid ratio in cumulus + INTEGER KB (IJSDIM) + INTEGER KSTRT (IJSDIM) ! tropopause level + REAL(r8) GAMX + REAL(r8) CIN (IJSDIM) + INTEGER JBUOY (IJSDIM) + REAL(r8) DELZ, BUOY, DELWC, DELER + REAL(r8) WCBX (IJSDIM) +! REAL(r8) ERMR (NCTP) ! entrainment rate (ASMODE) +! SAVE ERMR + INTEGER KTMX (NCTP) ! max of cloud top + INTEGER KTMXT ! max of cloud top + REAL(r8) TIMED + REAL(r8) GDCLDX, GDMU2X, GDMU3X +! + LOGICAL OOUT1, OOUT2 + + REAL(r8) HBGT (IJSDIM) ! imbalance in column heat + REAL(r8) WBGT (IJSDIM) ! imbalance in column water + +!DDsigma begin local work variables - all on model interfaces (sfc=1) + REAL(r8) lamdai ! lamda for cloud type ctp + REAL(r8) gdqm, gdlm, gdim ! water vaper + REAL(r8) gdtrm ! water vaper tracer + character(len=4) :: cproc !DDsigmadiag + +! the following are new arguments to cumup to get them out for AW + REAL(r8) wcv (IJSDIM, KMAX) ! in-cloud vertical velocity + REAL(r8) GCTM (IJSDIM, KMAX) ! cloud T (half lev) !DDsigmadiag make output + REAL(r8) GCQM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCwM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GCiM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GClM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) GChM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + +! eddy flux profiles for dse, water vapor, cloud water, cloud ice + REAL(r8), dimension(Kmax+1) :: sfluxtem, qvfluxtem, qlfluxtem, qifluxtem + +! tendency profiles - condensation heating, condensation moistening, heating due to +! freezing, total precip production, frozen precip production + REAL(r8), dimension(ijsdim,Kmax) :: dtcondtem, dqcondtem, dtfrztem, dqprectem,& ! Moorthi + dfrzprectem, lamdaprod ! product of (1+lamda) through cloud type ctp + REAL(r8), dimension(ijsdim,Kmax) :: dtevap, dqevap, dtmelt, dtsubl + +! factor to modify precip rate to force conservation of water. With bug fixes it's +! not doing anything now. + REAL(r8), dimension(ijsdim) :: moistening_aw + real(r8), dimension(ijsdim,kmax) :: gctbl, gcqbl,gcwbl, gcqlbl, gcqibl, & !DDsigmadiag updraft profiles below cloud Base + sigmad ! downdraft area fraction +! rhs_q, rhs_h are residuals of condensed water, MSE budgets to compute condensation, +! and heating due to freezing + real(r8) :: rhs_q, rhs_h, fsigma, delpinv +! real(r8) :: rhs_q, rhs_h, sftem, qftem, qlftem, qiftem, & +! fsigma ! factor to reduce mass flux terms (1-sigma**2) for AW +!DDsigma end local work variables +! +! profiles of heating due to precip evaporation, melting and sublimation, and the +! evap, melting and sublimation rates. + + REAL(r8) dtdwn (IJSDIM, KMAX) ! t tendency downdraft detrainment + REAL(r8) dqvdwn (IJSDIM, KMAX) ! qv tendency downdraft detrainment + REAL(r8) dqldwn (IJSDIM, KMAX) ! ql tendency downdraft detrainment + REAL(r8) dqidwn (IJSDIM, KMAX) ! qi tendency downdraft detrainment + +!DDsigma end local work variables +! +! [INTERNAL PARM] + REAL(r8), parameter :: WCBMIN = zero ! min. of updraft velocity at cloud base +!M REAL(r8) :: WCBMAX = 1.4_r8 ! max. of updraft velocity at cloud base +!M wcbas commented by Moorthi since it is not used +!M REAL(r8) :: WCBAS = 2._r8 ! updraft velocity**2 at cloud base (ASMODE) +!M REAL(r8) :: ERAMIN = 1.e-5_r8 ! min. of entrainment rate + ! used only in OPT_ASMODE +!M REAL(r8) :: ERAMAX = 2.e-3_r8 ! max. of entrainment rate + ! used only in OPT_ASMODE + LOGICAL :: OINICB = .false. ! set 0.d0 to CBMFX when .true. + +! REAL(r8) :: VARMIN = 1.e-13_r8 ! minimum of PDF variance +! REAL(r8) :: VARMAX = 5.e-7_r8 ! maximum of PDF variance +! REAL(r8) :: SKWMAX = 0.566_r8 ! maximum of PDF skewness + + REAL(r8) :: PSTRMX = 400.e2_r8 ! max P of tropopause + REAL(r8) :: PSTRMN = 50.e2_r8 ! min P of tropopause + REAL(r8) :: GCRSTR = 1.e-4_r8 ! crit. dT/dz tropopause + + real(kind=r8) :: tem, esat, mflx_e, cbmfl, tem1, tem2, tem3 + INTEGER :: KBMX, I, K, CTP, ierr, n, kp1, km1, kk, kbi +! + LOGICAL, SAVE :: OFIRST = .TRUE. ! called first time? +! +! [ONCE] + IF (OFIRST) THEN + + OFIRST = .FALSE. + +! fscav = 0._r8 +! fswtr = 0._r8 +! write(0,*)' NTR in cs_conv=',ntr,' mype=',mype +! do n=1,ntr +! FSCAV(n) = 0._r8 !DD split declaration and initialization +! FSWTR(n) = 0._r8 !DD split declaration and initialization +! enddo + + IF (OINICB) THEN + CBMFX = zero + ENDIF + ENDIF ! ofirst if +! + do n=1,ntr + do k=1,kmax + do i=1,ijsdim + gtq(i,k,n) = zero + enddo + enddo + enddo + + do k=1,kmax + do i=1,ijsdim + gtt(i,k) = zero + gtu(i,k) = zero + gtv(i,k) = zero +! gtqi(i,k) = zero +! gtql(i,k) = zero + gmflx(i,k) = zero + gmfx0(i,k) = zero + gprci(i,k) = zero + gsnwi(i,k) = zero + qliq(i,k) = zero + qice(i,k) = zero + gtcfrc(i,k) = zero + cumclw(i,k) = zero + fliqc(i,k) = zero + fliqou(i,k) = zero +! gprcpf(i,k) = zero +! gsnwpf(i,k) = zero + sfluxterm(i,k) = zero + qvfluxterm(i,k) = zero + qlfluxterm(i,k) = zero + qifluxterm(i,k) = zero + condtermt(i,k) = zero + condtermq(i,k) = zero + frzterm(i,k) = zero + prectermq(i,k) = zero + prectermfrz(i,k) = zero + dtdwn(i,k) = zero + dqvdwn(i,k) = zero + dqidwn(i,k) = zero + dqvdwn(i,k) = zero + enddo + enddo + do i=1,ijsdim + gprcc(i,:) = zero + gtprc0(i) = zero + hbgt(i) = zero + wbgt(i) = zero + gdztr(i) = zero + kstrt(i) = kmax + enddo + + do k=1,kmax + do i=1,ijsdim +! GDQI(i,k) = GDQ(i,k,ITI) + GDW(i,k) = GDQ(i,k,1) + GDQ(i,k,ITL) + GDQ(i,k,iti) + enddo + enddo +! + DO K=1,KMAX + DO I=ISTS,IENS + DELP(I,K) = GDPM(I,K) - GDPM(I,K+1) + esat = min(gdp(i,k), fpvs(gdt(i,k))) + GDQS(I,K) = min(EPSV*esat/max(gdp(i,k)+epsvm1*esat, 1.0e-10), 1.0) +! FDQS(I,K) = FDQSAT(GDT(I,K), GDQS(I,K)) + tem = one / GDT(I,K) + FDQS(I,K) = GDQS(I,K) * tem * (fact1 + fact2*tem) + GAM (I,K) = ELOCP*FDQS(I,K) + GDS (I,K) = CP*GDT(I,K) + GRAV*GDZ(I,K) ! layer dry static energy + GDH (I,K) = GDS(I,K) + EL*GDQ(I,K,1) ! layer moist static energy + GDHS(I,K) = GDS(I,K) + EL*GDQS(I,K) ! layer sat. moist static energy + ENDDO + ENDDO +! +! < tropopause > +! + DO K=1,KMAX + kp1 = k + 1 + DO I=ISTS,IENS + GAMX = (GDTM(I,KP1)-GDTM(I,K)) / (GDZM(I,KP1)-GDZM(I,K)) + IF ((GDP(I,K) < PSTRMX .AND. GAMX > GCRSTR) .OR. GDP(I,K) < PSTRMN) THEN + KSTRT(I) = MIN(K, KSTRT(I)) + ENDIF + ENDDO + ENDDO + DO I=ISTS,IENS + K = KSTRT(I) + GDZTR(I) = GDZM(I,K) + ENDDO +! +!DDsigma - arguments added to get subcloud profiles in updraft +! so AW eddy flux tendencies can be computed + +!! Cloud Base properties + CALL CUMBAS(IJSDIM, KMAX , & !DD dimensions + KB , GCYM , KBMX , & ! output + GCHB , GCWB , GCUB , GCVB , & ! output + GCIB , & ! output + GDH , GDW , GDHS , GDQS , & ! input + GDQ(1,1,iti) , GDU , GDV , GDZM , & ! input + GDPM , FDQS , GAM , & ! input + ISTS , IENS , & !) ! input + gctbl, gcqbl,gdq(1,1,1),gcwbl, gcqlbl, gcqibl) ! sub cloud tendencies +! + +!DDsigma some initialization before summing over cloud type + do k=1,kmax ! Moorthi + do i=1,ijsdim + lamdaprod(i,k) = one + dqcondtem(i,k) = zero + dqprectem(i,k) = zero + dfrzprectem(i,k) = zero + dtfrztem(i,k) = zero + dtcondtem(i,k) = zero + enddo + enddo + + DO CTP=1,NCTP ! loop over cloud types + + tem = ctp / DBLE(NCTP) + do i=1,ijsdim + DELWC = tem * (WCBMAXm(i) - WCBMIN) + WCBX(I) = DELWC * DELWC + enddo + +! getting more incloud profiles of variables to compute eddy flux tendencies +! and condensation rates + +!! CUMUP computes In-cloud Properties + + CALL CUMUP(IJSDIM, KMAX, NTR , & !DD dimensions + ACWF(1,CTP) , ELAM(1,1,CTP), & ! output + GCLZ , GCIZ , GPRCIZ , GSNWIZ, & ! output + GCYT(1,CTP) , GCHT(1,CTP) , GCQT (1,CTP), & ! output + GCLT(1,CTP) , GCIT(1,CTP) , GTPRT(1,CTP), & ! output + GCUT(1,CTP) , GCVT(1,CTP) , & ! output + KT (1,CTP) , KTMX(CTP) , & ! output + GCYM , & ! modified + wcv , & ! !DD-sigma new output + GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag + GCIB , & ! input + GDU , GDV , GDH , GDW , & ! input + GDHS , GDQS , GDT , GDTM , & ! input + GDQ , GDQ(1,1,iti) , GDZ , GDZM , & ! input + GDPM , FDQS , GAM , GDZTR , & ! input + CPRES , WCBX , & ! input +! CPRES , WCBX , ERMR(CTP), & ! input + KB , CTP , ISTS , IENS , & ! input + gctm, gcqm, gcwm, gchm, gcwt, gclm, gcim, & ! additional incloud profiles and cloud top total water + cbmfx(1,ctp), dtcondtem, dqcondtem, dtfrztem ) !DDsigmadiag +! +!! CUMBMX computes Cloud Base Mass Flux + + CALL CUMBMX(IJSDIM, KMAX , & !DD dimensions + CBMFX(1,CTP), & ! modified + ACWF (1,CTP), GCYT(1,CTP), GDZM , & ! input + GDW , GDQS , DELP , & ! input + KT (1,CTP), KTMX(CTP) , KB , & ! input + DELTI , ISTS , IENS ) + +!DDsigma - begin sigma computation +! At this point cbmfx is updated and we have everything we need to compute sigma + + if (do_aw) then + do i=ISTS,IENS + do k=1,kmax+1 ! initialize eddy fluxes for this cloud time + sfluxtem(k) = zero + qvfluxtem(k) = zero + qlfluxtem(k) = zero + qifluxtem(k) = zero + enddo + + cbmfl = cbmfx(i,ctp) + kk = kt(i,ctp) ! cloud top index + + if(cbmfl > zero) then ! this should avoid zero wcv in the denominator + kbi = kb(i) ! cloud top index + do k=2,kbi ! compute eddy fluxes below cloud base + tem = - gcym(i,k) * cbmfl + +! first get environment variables at layer interface + GDQM = half * (GDQ(I,K,1) + GDQ(I,K-1,1)) + GDlM = half * (GDQ(I,K,3) + GDQ(I,K-1,3)) + GDiM = half * (GDQ(I,K,2) + GDQ(I,K-1,2)) +! GDwM = half * (GDw(I,K) + GDw(I,K-1)) + +! flux = mass flux * (updraft variable minus environment variable) +!centered differences +! sfluxtem(k) = tem * (gdtm(i,k)-gctbl(i,k)) +! qvfluxtem(k) = tem * (gdqm-gcqbl(i,k)) +! qlfluxtem(k) = tem * (gdlm-gcqlbl(i,k)) +! qifluxtem(k) = tem * (gdim-gcqibl(i,k)) + +!upstream - This better matches what the original CS tendencies do + sfluxtem(k) = tem * (gdt(i,k)+gocp*(gdz(i,k)-gdzm(i,k))-gctbl(i,k)) + qvfluxtem(k) = tem * (gdq(i,k,1)-gcqbl(i,k)) + qlfluxtem(k) = tem * (gdq(i,k,3)-gcqlbl(i,k)) + qifluxtem(k) = tem * (gdq(i,k,2)-gcqibl(i,k)) + + enddo + do k=kbi,kk ! loop from cloud base to cloud top + km1 = k - 1 + rhs_h = zero + rhs_q = zero +! get environment variables interpolated to layer interface + GDQM = half * (GDQ(I,K,1) + GDQ(I,KM1,1)) ! as computed in cumup +! GDwM = half * (GDw(I,K) + GDw(I,KM1 )) + GDlM = half * (GDQ(I,K,3) + GDQ(I,KM1,3)) + GDiM = half * (GDQ(I,K,2) + GDQ(I,KM1,2)) + mflx_e = gcym(i,k) * cbmfl ! mass flux at level k for cloud ctp + +! this is the computation of lamda for a cloud type, and then updraft area fraction +! (sigmai for a single cloud type) +! gdtvm = gdtm(i,k) * (1 + epsvt * gdqm) +! gdrhom = gdpm(i,k) / (rair * gdtvm) ! gas law +! gdrhom = gdpm(i,k) / (rair * gdtm(i,k)*(one+epsvt*gdqm)) ! gas law +! lamdai = mflx_e / (gdrhom*wcv(i,k)) + + lamdai = mflx_e * rair * gdtm(i,k)*(one+epsvt*gdqm) & + / (gdpm(i,k)*wcv(i,k)) + lamdaprod(i,k) = lamdaprod(i,k) * (one+lamdai) + vverti(i,k,ctp) = wcv(i,k) + sigmai(i,k,ctp) = lamdai / lamdaprod(i,k) + sigma(i,k) = sigma(i,k) + sigmai(i,k,ctp) +! fsigma = 1.0 ! no aw effect, comment following lines to undo AW +! fsigma = (one - sigmai(i,k,ctp)*sigmai(i,k,ctp)) + fsigma = one - sigma(i,k) +! fsigma = (one - sigmai(i,k,ctp)) * (one - sigmai(i,k,ctp)) + +! compute tendencies based on mass flux, and tendencies based on condensation +! fsigma is the AW reduction of flux tendencies + + if(k > kbi) then ! uncomment for test +! flux = mass flux * (updraft variable minus environment variable) + + tem = - fsigma * mflx_e +!centered +! sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) +! qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) +! qlfluxtem(k) = tem * (gdlm-gclm(i,k)) +! qifluxtem(k) = tem * (gdim-gcim(i,k)) + +!upstream - This better matches what the original CS tendencies do + if(k < kk) then + sfluxtem(k) = tem * (gdt(i,k)+gocp*gdz(i,k)-gctm(i,k)) + qvfluxtem(k) = tem * (gdq(i,k,1)-gcqm(i,k)) + qlfluxtem(k) = tem * (gdq(i,k,3)-gclm(i,k)) + qifluxtem(k) = tem * (gdq(i,k,2)-gcim(i,k)) + else +! centered at top of cloud + sfluxtem(k) = tem * (gdtm(i,k)+gocp*gdzm(i,k)-gctm(i,k)) + qvfluxtem(k) = tem * (gdqm-gcqm(i,k)) + qlfluxtem(k) = tem * (gdlm-gclm(i,k)) + qifluxtem(k) = tem * (gdim-gcim(i,k)) + endif + +! the condensation terms - these come from the MSE and condensed water budgets for +! an entraining updraft +! if(k > kb(i)) then ! comment for test +! if(k <= kk) then ! Moorthi +! if(k < kt(i,ctp)) then +! rhs_h = cbmfl*(gcym(i,k)*gchm(i,k) - (gcym(i,km1)*gchm(i,km1) & +! + GDH(I,Km1 )*(gcym(i,k)-gcym(i,km1))) ) +! rhs_q = cbmfl*(gcym(i,k)*(gcwm(i,k)-gcqm(i,k)) & +! - (gcym(i,km1)*(gcwm(i,km1)-gcqm(i,km1)) & +! + (GDw( I,Km1 )-gdq(i,km1,1))*(gcym(i,k)-gcym(i,km1))) ) + tem = cbmfl * (one - sigma(i,k)) + tem1 = gcym(i,k) * (one - sigma(i,k)) + tem2 = gcym(i,km1) * (one - sigma(i,km1)) + rhs_h = cbmfl * (tem1*gchm(i,k) - (tem2*gchm(i,km1) & + + GDH(I,Km1)*(tem1-tem2)) ) + rhs_q = cbmfl * (tem1*(gcwm(i,k)-gcqm(i,k)) & + - (tem2*(gcwm(i,km1)-gcqm(i,km1)) & + + (GDw(I,Km1)-gdq(i,km1,1))*(tem1-tem2)) ) + +! ELSE +! rhs_h = cbmfl*(gcht(i,ctp) - (gcym(i,k-1)*gchm(i,k-1) + GDH( I,K-1 )*(gcyt(i,ctp)-gcym(i,k-1))) ) +! rhs_q = cbmfl*((gcwt(i)-gcqt(i,ctp)) - (gcym(i,k-1)*(gcwm(i,k-1)-gcqm(i,k-1)) + (GDw( I,K-1 )-gdq(i,k-1,1))*(gcyt(i,ctp)-gcym(i,k-1))) ) +! endif + +! + dqcondtem(i,km1) = -rhs_q ! condensation +! dqprectem(i,km1) = cbmfl * (GPRCIZ(i,k) + GSNWIZ(i,k)) + dqprectem(i,km1) = tem * (GPRCIZ(i,k) + GSNWIZ(i,k)) ! total precip production +! dfrzprectem(i,km1) = cbmfl * GSNWIZ(i,k) + dfrzprectem(i,km1) = tem * GSNWIZ(i,k) ! production of frozen precip + dtfrztem(i,km1) = rhs_h*oneocp ! heating due to freezing +! total temperature tendency due to in cloud microphysics + dtcondtem(i,km1) = - elocp * dqcondtem(i,km1) + dtfrztem(i,km1) + + endif ! if(k > kbi) then + enddo ! end of k=kbi,kk loop + + endif ! end of if(cbmfl > zero) + + +! get tendencies by difference of fluxes, sum over cloud type + + do k = 1,kk + delpinv = grav / delp(I,k) +! cloud microphysical tendencies for single cloud type + dtcondtem(i,k) = dtcondtem(i,k) * delpinv + dqcondtem(i,k) = dqcondtem(i,k) * delpinv + dqprectem(i,k) = dqprectem(i,k) * delpinv + dtfrztem(i,k) = dtfrztem(i,k) * delpinv +! sum cloud microphysical tendencies over all cloud types + condtermt(i,k) = condtermt(i,k) + dtcondtem(i,k) + condtermq(i,k) = condtermq(i,k) + dqcondtem(i,k) + prectermq(i,k) = prectermq(i,k) + dqprectem(i,k) + prectermfrz(i,k) = prectermfrz(i,k) + dfrzprectem(i,k) + frzterm(i,k) = frzterm(i,k) + dtfrztem(i,k) + +! flux tendencies - compute the vertical flux divergence + sfluxterm(i,k) = sfluxterm(i,k) - (sfluxtem(k+1) - sfluxtem(k)) * delpinv + qvfluxterm(i,k) = qvfluxterm(i,k) - (qvfluxtem(k+1) - qvfluxtem(k)) * delpinv + qlfluxterm(i,k) = qlfluxterm(i,k) - (qlfluxtem(k+1) - qlfluxtem(k)) * delpinv + qifluxterm(i,k) = qifluxterm(i,k) - (qifluxtem(k+1) - qifluxtem(k)) * delpinv + + enddo + + enddo ! end of i loop + + endif ! end of do_aw if !DDsigma - end sigma computation for AW + +! +! Cloud Mass Flux & Precip. + CALL CUMFLX(IM , IJSDIM, KMAX , & !DD dimensions + GMFX0 , GPRCI , GSNWI , & ! output + QLIQ , QICE , GTPRC0, & ! output + CBMFX(1,CTP) , GCYM , GPRCIZ , GSNWIZ , & ! input + GTPRT(1,CTP) , GCLZ , GCIZ , & ! input + KB , KT(1,CTP) , KTMX(CTP) , & ! input + ISTS , IENS, sigma ) ! input + + ENDDO ! end of cloud type ctp loop + +! + do k=1,kmax + do i=ists,iens + GMFLX(I,k) = GMFX0(I,k) ! contains net updraft mass flux for all clouds + enddo + enddo + KTMXT = 3 + DO CTP=1,NCTP + IF (KTMX(CTP) > KTMXT) KTMXT = KTMX(CTP) + ENDDO + DO K=1,KTMXT + DO I=ISTS,IENS + CUMCLW(I,K) = QLIQ(I,K) + QICE(I,K) + IF (CUMCLW(I,K) > zero) THEN + FLIQC(I,K) = QLIQ(I,K) / CUMCLW(I,K) + FLIQOU(I,K) = FLIQC(I,K) + ENDIF + ENDDO + ENDDO +! +! Cumulus Cloudiness + CALL CUMCLD(IJSDIM, KMAX , & !DD dimensions + CUMCLW, QLIQ , QICE , FLIQC , & ! modified + CUMFRC, & ! output + GMFLX , KTMXT , ISTS , IENS ) ! input +! +! Cloud Detrainment Heating + CALL CUMDET(im , IJSDIM, KMAX , NTR , & !DD dimensions + CMDET , & ! output +! CMDET , GTLDET, GTIDET, & ! output + GTT , GTQ , GTCFRC, GTU , GTV , & ! modified +! GTQI , & ! modified + GDH , GDQ , GDCFRC, GDU , GDV , & ! input + CBMFX , GCYT , DELP , GCHT , GCQT , & ! input + GCLT , GCIT , GCUT , GCVT , GDQ(1,1,iti), & ! input + KT , ISTS , IENS, nctp, sigmai ) ! input + +! if (lprnt) write(0,*)' after cumdet gtqi=',gtq(ipr,:,2) + +!for now area fraction of the downdraft is zero, it will be computed +! within cumdwn and applied there +! Get AW downdraft eddy flux and microphysical tendencies out of downdraft code. + do k=1,kmax + do i=ists,iens + sigmad(i,k) = zero + enddo + enddo + +! cumulus downdraft - Melt & Freeze & Evaporation + CALL CUMDWN(IM , IJSDIM, KMAX , NTR , & ! DD dimensions + GTT , GTQ , GTU , GTV , & ! modified + GMFLX , & ! modified updraft+downdraft flux +! GTQI , GMFLX , & ! modified + GPRCP , GSNWP , GTEVP , GMDD , & ! output + GPRCI , GSNWI , & ! input + GDH , GDW , GDQ , GDQ(1,1,iti) , & ! input + GDQS , GDS , GDHS , GDT , & ! input + GDU , GDV , GDZ , & ! input + GDZM , GCYM , FDQS , DELP , & ! input + sigmad, do_aw , do_awdd, & ! DDsigma input + dtmelt, dtevap, dtsubl, & ! DDsigma input + dtdwn , dqvdwn, dqldwn, dqidwn, & ! DDsigma input + KB , KTMXT , ISTS , IENS ) ! input + +! if (lprnt) write(0,*)' after cumdwn gtqi=',gtq(ipr,:,2) +! here we substitute the AW tendencies into tendencies to be passed out +! if (do_aw) then + do k=1,kmax + do i=ists,iens + sigma(i,k) = sigma(i,k) + sigmad(i,k) + enddo + enddo + +! AW lump all heating together, compute qv term + do k=1,kmax + do i=ists,iens + dqevap(i,k) = - dtevap(i,k)*cpoel - dtsubl(i,k)*cpoesub + dtevap(i,k) = dtevap(i,k) + dtsubl(i,k) + dtsubl(i,k) = zero + enddo + enddo + +! do i=1,ijsdim +! moistening_aw(i) = zero +! enddo +! DO K = 1, KMAX +! DO I = ISTS, IENS +! tem = frzterm(i,k)*cpoEMELT - prectermfrz(i,k) +! gtt(i,k) = dtdwn(i,k) + sfluxterm(i,k) + condtermt(i,k) & +! + dtmelt(i,k) + dtevap(i,k) +! gtq(i,k,1) = dqvdwn(i,k) + qvfluxterm(i,k) + condtermq(i,k) & +! + dqevap(i,k) +! gtq(i,k,itl) = dqldwn(i,k) + qlfluxterm(i,k) - condtermq(i,k) & +! - prectermq(i,k) - tem +! gtq(i,k,iti) = dqidwn(i,k) + qifluxterm(i,k) + tem +! detrainment terms get zeroed +! gtldet(i,k) = zero +! gtidet(i,k) = zero +! column-integrated total water tendency - used to impose water conservation +! moistening_aw(i) = moistening_aw(i) & +! + (gtq(i,k,1)+gtq(i,k,itl)+gtq(i,k,iti)) * delp(i,k)*gravi +! ENDDO +! ENDDO +! +! This code ensures conservation of water. In fact, no adjustment of the precip +! is occuring now which is a good sign! DD +! DO I=ISTS,IENS +! if(gprcp(i,1)+gsnwp(i,1) > 1.e-12_r8) then +! moistening_aw(i) = - moistening_aw(i) / (gprcp(i,1)+gsnwp(i,1)) +! endif +! if (abs(1.0-moistening_aw(i)) > 0.3 .and. gprcp(i,1) > 0.0) & +! write(1000+mype,*)' moistening_aw=', & +! moistening_aw(i),' i=',i,' xlon=',xlon(i),' xlat=',xlat(i),' kdt=',kdt& +! , ' gprcp=',gprcp(i,1:5) +! ENDDO +! write(1000+mype,*)' moistening_aw=',moistening_aw +! do k=1,kmax +! DO I = ISTS, IENS +! gprcp(i,k) = gprcp(i,k) * moistening_aw(i) +! gsnwp(i,k) = gsnwp(i,k) * moistening_aw(i) +! ENDDO +! enddo + +! else + +! Cloud Subsidence Heating + CALL CUMSBH(IM , IJSDIM, KMAX , NTR , & !DD dimensions + GTT , GTQ , & ! modified +! GTT , GTQ , GTQI , & ! modified + GTU , GTV , & ! modified + GDH , GDQ , GDQ(1,1,iti) , & ! input + GDU , GDV , & ! input + DELP , GMFLX , GMFX0 , & ! input + KTMXT , CPRES , ISTS , IENS ) ! input + +! if (lprnt) write(0,*)' after cumsbh gtqi=',gtq(ipr,:,2) +! endif +! +! for now the following routines appear to be of no consequence to AW - DD +! +! Tracer Updraft + CALL CUMUPR(im , IJSDIM, KMAX , NTR , & !DD dimensions + GTQ , GPRCC , & ! modified + GDQ , CBMFX , ELAM , GDZ , GDZM , & ! input + GCYM , GCYT , GCQT , GCLT , GCIT , & ! input + GTPRT , GTEVP , GTPRC0, & ! input + KB , KBMX , KT , KTMX , KTMXT , & ! input + DELP , OTSPT1, ISTS , IENS, & ! input + fscav, fswtr, nctp) +! +! Tracer Downdraft + CALL CUMDNR(im ,IJSDIM , KMAX , NTR , & !DD dimensions + GTQ , & ! modified + GDQ , GMDD , DELP , & ! input + KTMXT , OTSPT1, ISTS , IENS ) ! input +! +! Tracer Subsidence + CALL CUMSBR(im , IJSDIM,KMAX , NTR , & !DD dimensions + GTQ , & ! modified + GDQ , DELP , & ! input + GMFLX , KTMXT , OTSPT2, & ! input + ISTS , IENS ) ! input + +! if (lprnt) write(0,*)' after cumsbr gtqi=',gtq(ipr,:,2) +! +! do k=1,kmax +! do i=ISTS,IENS +! GTQ(I,k,ITI) = GTQI(I,k) +! enddo +! enddo +! +! Tracer mass fixer without detrainment + CALL CUMFXR(IM , IJSDIM, KMAX , NTR , & !DD dimensions + GTQ , & ! modified + GDQ , DELP , DELTA , KTMXT , IMFXR, & ! input + ISTS , IENS ) ! input +! +! do k=1,kmax +! do i=ISTS,IENS +! GTQL(I,k) = GTQ(I,k,ITL) + GTLDET(I,k) + GTIDET(I,k) +! enddo +! enddo +! +! Tracer mass fixer with detrainment +! CALL CUMFXR1(IM , IJSDIM, KMAX , & !DD dimensions +! GTQL , & ! modified +! GDQ(1,1,ITL), DELP, DELTA, KTMXT, IMFXR(ITL), & ! input +! ISTS , IENS ) ! input +! + DO K=1,KMAX + DO I=ISTS, IENS +! GTLDET(I,k) = GTQL(I,k) - GTQ(I,k,ITL) - GTIDET(I,k) + +! tendencies of subgrid PDF (turned off) +! GDCLDX = GDCFRC( I,K ) + GTCFRC( I,K )*DELTA +! GDCLDX = MIN( MAX( GDCLDX, 0.D0 ), one ) +! GTCFRC( I,K ) = ( GDCLDX - GDCFRC( I,K ) )/DELTA +! +! GDMU2X = GDQ( I,K,IMU2 ) + GTQ( I,K,IMU2 )*DELTA +! GDMU2X = MIN( MAX( GDMU2X,VARMIN ),VARMAX ) +! GDMU3X = GDQ( I,K,IMU3 ) + GTQ( I,K,IMU3 )*DELTA +! GDMU3X = MIN( MAX( GDMU3X,-SKWMAX ),SKWMAX ) +! GTQ( I,K,IMU2 ) = ( GDMU2X - GDQ( I,K,IMU2 ))/DELTA +! GTQ( I,K,IMU3 ) = ( GDMU3X - GDQ( I,K,IMU3 ))/DELTA +! + tem = DELP(I,K)*GRAVI + HBGT(I) = HBGT(I) + (CP*GTT(I,K) + EL*GTQ(I,K,1) & + - EMELT*GTQ(I,K,ITI)) * tem +! - EMELT*(GTQ(I,K,ITI)+GTIDET(I,K))) * tem + WBGT(I) = WBGT(I) + (GTQ(I,K,1) + GTQ(I,K,ITL) + GTQ(I,K,ITI)) * tem +! + GTLDET(I,K) + GTIDET(I,K)) * tem + ENDDO + ENDDO + + +! here we substitute the AW tendencies into tendencies to be passed out + if(do_aw) then + do i=1,ijsdim + moistening_aw(i) = zero + enddo + tem2 = one / delta + DO K=1,KMAX + DO I=ISTS,IENS + tem = frzterm(i,k)*cpoEMELT - prectermfrz(i,k) + gtt(i,k) = dtdwn(i,k) + sfluxterm(i,k) + condtermt(i,k) & + + dtmelt(i,k) + dtevap(i,k) + gtq(i,k,1) = dqvdwn(i,k) + qvfluxterm(i,k) + condtermq(i,k) & + + dqevap(i,k) + gtq(i,k,itl) = dqldwn(i,k) + qlfluxterm(i,k) - condtermq(i,k) & + - prectermq(i,k) - tem + gtq(i,k,iti) = dqidwn(i,k) + qifluxterm(i,k) + tem +! detrainment terms get zeroed +! gtldet(i,k) = zero +! gtidet(i,k) = zero + + tem1 = - gdq(i,k,itl)*tem2 + if (gtq(i,k,itl) < tem1) then + tem3 = gtq(i,k,itl) - tem1 + gtq(i,k,1) = gtq(i,k,1) + tem3 + gtq(i,k,itl) = tem1 + gtt(i,k) = gtt(i,k) - elocp*tem3 + endif + tem1 = - gdq(i,k,iti)*tem2 + if (gtq(i,k,iti) < tem1) then + tem3 = gtq(i,k,iti) - tem1 + gtq(i,k,1) = gtq(i,k,1) + tem3 + gtq(i,k,iti) = tem1 + gtt(i,k) = gtt(i,k) - esubocp*tem3 + endif +! tem1 = - gdq(i,k,1)*tem2 +! if (gtq(i,k,1) < tem1) then +! gtt(i,k) = gtt(i,k) + elocp*(gtq(i,k,1)-tem1) +! gtq(i,k,1) = tem1 +! endif + +! column-integrated total water tendency - to be used to impose water conservation + moistening_aw(i) = moistening_aw(i) & + + (gtq(i,k,1)+gtq(i,k,itl)+gtq(i,k,iti)) * delp(i,k)/grav + ENDDO + ENDDO + endif + +! if (lprnt) then +! write(0,*)' after doaw dqvdwn=',dqvdwn(ipr,:) +! write(0,*)' after doaw qvfluxterm=',qvfluxterm(ipr,:) +! write(0,*)' after doaw dqevap=',dqevap(ipr,:) +! write(0,*)' after doaw condtermq=',condtermq(ipr,:) +! write(0,*)' after doaw dqidwn=',dqidwn(ipr,:) +! write(0,*)' after doaw qifluxterm=',qifluxterm(ipr,:) +! write(0,*)' after doaw prectermfrz=',prectermfrz(ipr,:) +! write(0,*)' after doaw frzterm=',frzterm(ipr,:) +! write(0,*)' after doaw gtqv=',gtq(ipr,:,1) +! write(0,*)' after doaw gtqi=',gtq(ipr,:,2) +! write(0,*)' after doaw gtql=',gtq(ipr,:,3) +! endif +! + DO I=ISTS,IENS + HBGT(I) = HBGT(I) - EMELT*GSNWC(I) + WBGT(I) = WBGT(I) + GPRCC(I,1) + GSNWC(I) +! CTOPP(I) = 1.D6 + ENDDO +! +! The following commented out because they are unused +! DO CTP=1,NCTP +! DO I=ISTS, IENS +! kk = kt(i,ctp) +! IF (KK > KB(I) ) THEN +! CUMHGT(I,CTP) = GDZ(I,KK) +! CTOPP(I) = MIN(CTOPP(I), GDP(I,KK)) +! ELSE +! CUMHGT (I,CTP) = -999.D0 +! ENDIF +! ENDDO +! ENDDO +! DO I=ISTS,IENS +! IF(CTOPP(I) >= 1.D6) THEN +! CTOPP(I) = -999.D0 +! ENDIF +! ENDDO +! +! This code ensures conservation of water. In fact, no adjustment of the precip +! is occuring now which is a good sign! DD + if(do_aw .and. adjustp) then + DO I = ISTS, IENS + if(gprcp(i,1)+gsnwp(i,1) > 1.e-12_r8) then + moistening_aw(i) = - moistening_aw(i) / (gprcp(i,1)+gsnwp(i,1)) + endif + ENDDO + do k=1,kmax + DO I = ISTS, IENS + gprcp(i,k) = gprcp(i,k) * moistening_aw(i) + gsnwp(i,k) = gsnwp(i,k) * moistening_aw(i) + ENDDO + enddo + +! if (lprnt) then +! write(1000+mype,*)' moistening_aw=',moistening_aw(1:ijsdim) +! write(1000+mype,*)' gprcp=',gprcp(1:ijsdim,1) +! endif + + endif + + +! commnting out becasue these are not used +! DO K=1,KMAX +! kp1 = min(k+1,kmax) +! DO I=ISTS,IENS +! GPRCPF(I,K) = half * (GPRCP(I,K) + GPRCP(I,KP1)) +! GSNWPF(I,K) = half * (GSNWP(I,K) + GSNWP(I,KP1)) +! ENDDO +! ENDDO +! + do i=ISTS,IENS + GPRCC(I,1) = GPRCP(I,1) + GSNWC(I ) = GSNWP(I,1) + enddo + do k=1,kmax + do i=ISTS,IENS + GTPRP(I,k) = GPRCP(I,k) + GSNWP(I,k) + enddo + enddo +! + +!COSP +!necessary? +! DO K=1,KMAX +! DO I=ISTS,IENS +! QLIQC(I,K) = QLIQ(I,K) +! QICEC(I,K) = QICE(I,K) +! ENDDO +! ENDDO +! +! IF ( OOUT1 .OR. OOUT2 ) THEN + DO I=ISTS,IENS + CAPE(i) = zero + CIN(i) = zero + JBUOY(i) = 0 + enddo + DO K=2,KMAX + DO I=ISTS,IENS + IF (K >= KB(I)) THEN + BUOY = (GDH(I,1)-GDHS(I,K)) / ((one+ELOCP*FDQS(I,K)) * CP*GDT(I,K)) + ELSE + BUOY = (GDS(I,1)-GDS(I,K)) / (CP*GDT(I,K)) + END IF + DELZ = GDZM(I,K+1) - GDZM(I,K) + IF (BUOY > zero .AND. JBUOY(I) /= 0) THEN + CAPE(I) = CAPE(I) + BUOY*GRAV*DELZ + JBUOY(I) = 2 + ELSEIF (BUOY < zero .AND. JBUOY(I) /= 2) THEN + CIN(I) = CIN(I) - BUOY*GRAV*DELZ + JBUOY(I) = 1 + ENDIF + ENDDO + ENDDO + DO I=ISTS,IENS + IF (JBUOY(I) /= 2) CIN(I) = -999.D0 + ENDDO + +!DD provide GFS with a separate downdraft mass flux + DO K=1,KMAX + DO I=ISTS,IENS + GMFX1(I,K) = GMFX0(I,K) - GMFLX(I,K) + ENDDO + ENDDO + +! + END SUBROUTINE CS_CUMLUS +!*********************************************************************** + SUBROUTINE CUMBAS & !! cloud base + ( IJSDIM, KMAX , & !DD dimensions + KB , GCYM , KBMX , & ! output + GCHB , GCWB , GCUB , GCVB , & ! output + GCIB , & ! output + GDH , GDW , GDHS , GDQS , & ! input + GDQI , GDU , GDV , GDZM , & ! input + GDPM , FDQS , GAM , & ! input + ISTS , IENS , gctbl, gcqbl ,gdq, gcwbl, gcqlbl, gcqibl ) ! input !DDsigmadiag add updraft profiles below cloud base +! +! + IMPLICIT NONE + INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in +! +! [OUTPUT] + INTEGER KB (IJSDIM) ! cloud base + REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux (half lev) + INTEGER KBMX + REAL(r8) GCHB (IJSDIM) ! cloud base MSE + REAL(r8) GCWB (IJSDIM) ! cloud base total water + REAL(r8) GCUB (IJSDIM) ! cloud base U + REAL(r8) GCVB (IJSDIM) ! cloud base V + REAL(r8) GCIB (IJSDIM) ! cloud base ice + +!DDsigma added to arglist for AW, subcloud updraft profiles: temperature, water vapor +! total water, cloud water, and cloud ice respectively + REAL(r8), dimension(ijsdim,kmax) :: gctbl, gcqbl, gcwbl, gcqlbl, gcqibl !DDsigmadiag +! +! [INPUT] + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDq (IJSDIM, KMAX) ! water vapor !DDsigmadiag + REAL(r8) GDHS (IJSDIM, KMAX) ! saturate MSE + REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity + REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice + REAL(r8) GDU (IJSDIM, KMAX) ! u-velocity + REAL(r8) GDV (IJSDIM, KMAX) ! v-velocity + REAL(r8) GDZM (IJSDIM, KMAX+1) ! Altitude (half lev) + REAL(r8) GDPM (IJSDIM, KMAX+1) ! pressure (half lev) + REAL(r8) FDQS (IJSDIM, KMAX) + REAL(r8) GAM (IJSDIM, KMAX) + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8) CBASE (IJSDIM) ! one over cloud base height +! REAL(r8) CBASEP(IJSDIM) ! cloud base pressure + REAL(r8) DELZ, QSL, GAMX, wrk + REAL(r8), dimension(ijsdim,kmax) :: gchbl !DDsigmadiag + real(r8), dimension(ijsdim) :: gcqb + INTEGER I, K, kp1 +! +! [INTERNAL PARM] + INTEGER :: KMAXM1 + INTEGER :: KLCLB !! LCL base level + INTEGER :: KCB !! fix cloud bottom + INTEGER :: KBMAX !! cloud base max + INTEGER :: KBOFS !! cloud base offset + + KMAXM1 = KMAX-1 + KLCLB = 1 ! LCL base level + KCB = 0 ! fix cloud bottom + KBMAX = KMAXM1 ! cloud base max + KBOFS = 0 ! cloud base offset +! + do k=1,kmax + do i=ists,iens + GCYM(I,k) = zero + enddo + enddo +! + IF (KCB > 0) THEN + DO I=ISTS,IENS + KB(I) = KCB + ENDDO + ELSE + DO I=ISTS,IENS + KB(I) = KBMAX + ENDDO + DO K=KBMAX-1,KLCLB+1,-1 + DO I=ISTS,IENS + GAMX = FDQS(I,K) / (one+GAM(I,K)) * oneocp + QSL = GDQS(I,K) + GAMX * (GDH(I,KLCLB)-GDHS(I,K)) + IF (GDW(I,KLCLB) >= QSL) THEN + KB(I) = K + KBOFS + ENDIF + ENDDO + ENDDO + ENDIF +! + KBMX = 1 + DO I=ISTS,IENS + KBMX = MAX(KBMX, KB(I)) + CBASE (I) = one / (GDZM(I,KB(I)) - GDZM(I,1)) +! CBASEP(I) = GDPM(I,KB(I)) + ENDDO +! + DO K=1,KBMX + DO I=ISTS,IENS + IF (K <= KB(I)) THEN + GCYM(I,K) = sqrt((GDZM(I,K)-GDZM(I,1)) * CBASE(i)) + ENDIF + ENDDO + ENDDO +! + DO I=ISTS,IENS + GCHB(I) = zero + GCWB(I) = zero + GCUB(I) = zero + GCVB(I) = zero + GCIB(I) = zero + GCQB(I) = zero + ENDDO + do k=1,kmax + do i=ists,iens + GChbl(i,k) = zero + gcqbl(i,k) = zero + gcqlbl(i,k) = zero + gcqibl(i,k) = zero + gctbl(i,k) = zero + gcwbl(i,k) = zero + enddo + enddo +! + DO K=1,KBMX + kp1 = min(k+1, kmax) + DO I=ISTS,IENS + IF (K < KB(I)) THEN + DELZ = GCYM(I,Kp1) - GCYM(I,K) + GCHB(I) = GCHB(I) + DELZ * GDH (I,K) + GCWB(I) = GCWB(I) + DELZ * GDW (I,K) + GCUB(I) = GCUB(I) + DELZ * GDU (I,K) + GCVB(I) = GCVB(I) + DELZ * GDV (I,K) + GCIB(I) = GCIB(I) + DELZ * GDQI(I,K) + GCqB(I) = GCqB(I) + DELZ * GDQ (I,K) +! get subcloud profiles to pass out and do AW eddy flux tendencies +! removing the normalized mass flux weighting + wrk = one / gcym(i,kp1) + gchbl(i,kp1) = gchb(i) * wrk + gcqbl(i,kp1) = gcqb(i) * wrk + gcqibl(i,kp1) = gcib(i) * wrk + gcwbl(i,kp1) = gcwb(i) * wrk + gcqlbl(i,kp1) = gcwbl(i,kp1) - (gcqibl(i,kp1)+gcqbl(i,kp1)) + gctbl(i,kp1) = (gchbl(i,kp1) - grav*gdzm(i,kp1) - el*gcqbl(i,kp1)) * oneocp + ENDIF + ENDDO + ENDDO +! + END SUBROUTINE CUMBAS +!*********************************************************************** + SUBROUTINE CUMUP & !! in-cloud properties + ( IJSDIM, KMAX , NTR , & !DD dimensions + ACWF , ELAM , & ! output + GCLZ , GCIZ , GPRCIZ, GSNWIZ, & ! output + GCYT , GCHT , GCQT , & ! output + GCLT , GCIT , GTPRT , & ! output + GCUT , GCVT , & ! output + KT , KTMX , & ! output + GCYM , & ! modified + wcv , & ! !DDsigma new output + GCHB , GCWB , GCUB , GCVB , & ! input !DDsigmadiag + GCIB , & ! input + GDU , GDV , GDH , GDW , & ! input + GDHS , GDQS , GDT , GDTM , & ! input + GDQ , GDQI , GDZ , GDZM , & ! input + GDPM , FDQS , GAM , GDZTR , & ! input + CPRES , WCB , & ! input +! CPRES , WCB , ERMR , & ! input + KB , CTP , ISTS , IENS, & ! input + gctm , gcqm, gcwm, gchm, gcwt, gclm, gcim, & + cbmfx , dtcond, dqcond, dtfrz ) !DDsigmadiag +! +!DD AW the above line of arguments were previously local, and often scalars. +! Dimensions were added to them to save profiles for each grid point. +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, KMAX, NTR ! DD, for GFS, pass in +! +! [OUTPUT] + REAL(r8) ACWF (IJSDIM) ! cloud work function + REAL(r8) ELAM (IJSDIM, KMAX) ! entrainment (rate*massflux) + REAL(r8) GCLZ (IJSDIM, KMAX) ! cloud liquid water*eta + REAL(r8) GCIZ (IJSDIM, KMAX) ! cloud ice*eta + REAL(r8) GPRCIZ(IJSDIM, KMAX) ! rain generation*eta + REAL(r8) GSNWIZ(IJSDIM, KMAX) ! snow generation*eta + REAL(r8) GCYT (IJSDIM) ! norm. mass flux @top + REAL(r8) GCHT (IJSDIM) ! cloud top MSE*eta + REAL(r8) GCQT (IJSDIM) ! cloud top moisture*eta + REAL(r8) GCLT (IJSDIM) ! cloud top liquid water*eta + REAL(r8) GCIT (IJSDIM) ! cloud top ice*eta + REAL(r8) GTPRT (IJSDIM) ! cloud top (rain+snow)*eta + REAL(r8) GCUT (IJSDIM) ! cloud top u*eta + REAL(r8) GCVT (IJSDIM) ! cloud top v*eta + REAL(r8) GCwT (IJSDIM) ! cloud top v*eta + INTEGER KT (IJSDIM) ! cloud top + INTEGER KTMX ! max of cloud top + REAL(r8) WCV (IJSDIM, KMAX) ! updraft velocity (half lev) !DD sigma make output +! +! [MODIFIED] + REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux +! +! [INPUT] + REAL(r8) GCHB (IJSDIM) ! MSE at cloud base + REAL(r8) GCWB (IJSDIM) ! total water @cloud base + REAL(r8) GCUB (IJSDIM) ! U at cloud base + REAL(r8) GCVB (IJSDIM) ! V at cloud base + REAL(r8) GCIB (IJSDIM) ! cloud ice at cloud base + REAL(r8) GDU (IJSDIM, KMAX) ! U + REAL(r8) GDV (IJSDIM, KMAX) ! V + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDHS (IJSDIM, KMAX) ! saturation MSE + REAL(r8) GDQS (IJSDIM, KMAX) ! saturation q + REAL(r8) GDT (IJSDIM, KMAX) ! T + REAL(r8) GDTM (IJSDIM, KMAX+1) ! T (half lev) + REAL(r8) GDQ (IJSDIM, KMAX, NTR)! q !!DDsigmadiag + REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice + REAL(r8) GDZ (IJSDIM, KMAX) ! z + REAL(r8) GDZM (IJSDIM, KMAX+1) ! z (half lev) + REAL(r8) GDPM (IJSDIM, KMAX+1) ! p (half lev) + REAL(r8) FDQS (IJSDIM, KMAX) + REAL(r8) GAM (IJSDIM, KMAX) + REAL(r8) GDZTR (IJSDIM) ! tropopause height + REAL(r8) CPRES ! pres. fac. for cum. fric. + REAL(r8) WCB(ijsdim) ! updraft velocity**2 @base +! REAL(r8) ERMR ! entrainment rate (ASMODE) + INTEGER KB (IJSDIM) + INTEGER CTP, ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8) myGCHt ! cloud top h *eta (half lev) + REAL(r8) GCHMZ (IJSDIM, KMAX) ! cloud h *eta (half lev) + REAL(r8) GCWMZ (IJSDIM, KMAX) ! cloud Qt*eta (half lev) + REAL(r8) GCqMZ (IJSDIM, KMAX) ! cloud qv*eta (half lev) + REAL(r8) GCUMZ (IJSDIM, KMAX) ! cloud U *eta (half lev) + REAL(r8) GCVMZ (IJSDIM, KMAX) ! cloud V *eta (half lev) + REAL(r8) GCIMZ (IJSDIM, KMAX) ! cloud Qi*eta (half lev) + REAL(r8) GTPRMZ(IJSDIM, KMAX) ! rain+snow *eta (half lev) +! + REAL(r8) BUOY (IJSDIM, KMAX) ! buoyancy + REAL(r8) BUOYM (IJSDIM, KMAX) ! buoyancy (half lev) + REAL(r8) WCM (IJSDIM, KMAX) ! updraft velocity**2 (half lev) +!DD sigma make output REAL(r8) WCV ( IJSDIM, KMAX+1 ) !! updraft velocity (half lev) + REAL(r8) GCY (IJSDIM, KMAX) ! norm. mass flux + REAL(r8) ELAR (IJSDIM, KMAX) ! entrainment rate +! + REAL(r8) GCHM (IJSDIM, KMAX) ! cloud MSE (half lev) + REAL(r8) GCWM (IJSDIM, KMAX) ! cloud Qt (half lev) !DDsigmadiag + REAL(r8) GCTM (IJSDIM, KMAX) ! cloud T (half lev) !DDsigmadiag make output + REAL(r8) GCQM (IJSDIM, KMAX) ! cloud q (half lev) !DDsigmadiag make output + REAL(r8) dtcond(IJSDIM, KMAX) ! in cloud condensation heating DDsigmadiag make output + REAL(r8) dqcond(IJSDIM, KMAX) ! in cloud condensation water vapor tendency !DDsigmadiag make output + REAL(r8) dtfrz (IJSDIM, KMAX) ! in cloud temperature tendency due to freezing !DDsigmadiag make output + REAL(r8) cbmfx (IJSDIM) ! cloud base mass flux !DDsigmadiag make output + REAL(r8) GCLM (IJSDIM, KMAX) ! cloud liquid ( half lev) + REAL(r8) GCIM (IJSDIM, KMAX) ! cloud ice (half lev) + REAL(r8) GCUM (IJSDIM, KMAX) ! cloud U (half lev) + REAL(r8) GCVM (IJSDIM, KMAX) ! cloud V (half lev) +! + REAL(r8), dimension(IJSDIM) :: WCM_, ELARM1, GDZMKB + REAL(r8) GDQSM, GDHSM, GDQM, GDSM, GDCM, FDQSM, GCCM, gdtrm, & + DELZ, ELADZ, DCTM , CPGMI, DELC, FICE, ELARM2,GCCMZ, & + PRECR, GTPRIZ, DELZL, GCCT, DCT, WCVX, PRCZH, wrk + INTEGER K, I, kk, km1, kp1 + CHARACTER CTNUM*2 +! +!DD#ifdef OPT_CUMBGT +!DD REAL(r8) HBGT (IJSDIM) ! heat budget +!DD REAL(r8) WBGT (IJSDIM) ! water budget +!DD REAL(r8) PBGT (IJSDIM) ! precipitation budget +!DD REAL(r8) MBGT (IJSDIM) ! mass budget +!DD REAL(r8) GTPRX (IJSDIM) ! (rain+snow)*eta at top +!DD REAL(r8) GSNWT (IJSDIM) ! cloud top snow*eta +!DD REAL(r8) HBMX, WBMX, PBMX, MBMX +!DD SAVE HBMX, WBMX, PBMX, MBMX +!DD#endif +! +! [INTERNAL PARAM] + + REAL(r8), SAVE :: CLMP +!DD REAL(r8) :: PRECZ0 = 1.5e3_r8 ! move to module scope for tuning +!DD REAL(r8) :: PRECZH = 4.e3_r8 ! move to module scope for tuning + REAL(r8) :: ZTREF = 1._r8 + REAL(r8) :: PB = 1._r8 +!m REAL(r8) :: TAUZ = 5.e3_r8 + REAL(r8) :: TAUZ = 1.e4_r8 + REAL(r8) :: ELMD = 2.4e-3 ! for Neggers and Siebesma (2002) + REAL(r8) :: ELAMIN = zero ! min. of entrainment rate + REAL(r8) :: ELAMAX = 4.e-3 ! max. of entrainment rate +!m REAL(r8) :: ELAMAX = 5.e-3 ! max. of entrainment rate + REAL(r8) :: WCCRT = zero +!m REAL(r8) :: WCCRT = 0.01 + REAL(r8) :: TSICE = 268.15_r8 ! compatible with macrop_driver + REAL(r8) :: TWICE = 238.15_r8 ! compatible with macrop_driver + REAL(r8) :: EPSln = 1.e-10 + +! REAL(r8) :: esat, tem + REAL(r8) :: esat, tem, rhs_h, rhs_q + + LOGICAL, SAVE :: OFIRST = .TRUE. +! +! [INTERNAL FUNC] + REAL(r8) FPREC ! precipitation ratio in condensate + REAL(r8) FRICE ! ice ratio in cloud water + REAL(r8) Z ! altitude + REAL(r8) ZH ! scale height + REAL(r8) T ! temperature +! + FPREC(Z,ZH) = MIN(MAX(one-EXP(-(Z-PRECZ0)/ZH), zero), one) + FRICE(T) = MIN(MAX((TSICE-T)/(TSICE-TWICE), zero), one) +! +! Note: iteration is not made to diagnose cloud ice for simplicity +! + IF (OFIRST) THEN + CLMP = 2.D0*(one-CLMD)*PA + OFIRST = .FALSE. + ENDIF + + do i=ists,iens + ACWF (I) = zero + GCYT (I) = zero + GCHT (I) = zero + GCQT (I) = zero + GCLT (I) = zero + GCIT (I) = zero + GTPRT(I) = zero + GCUT (I) = zero + GCVT (I) = zero + GCwT (I) = zero + enddo + do k=1,kmax + do i=ists,iens + ELAM (I,k) = unset_r8 + GCLZ (I,k) = zero + GCIZ (I,k) = zero + GPRCIZ(I,k) = zero + GSNWIZ(I,k) = zero +! + GCHMZ (I,k) = zero + GCWMZ (I,k) = zero + GCqMZ (I,k) = zero + GCIMZ (I,k) = zero + GCUMZ (I,k) = zero + GCVMZ (I,k) = zero + GTPRMZ(I,k) = zero + + dtcond(i,k) = zero + dqcond(i,k) = zero + dtfrz(i,k) = zero +! + BUOY (I,k) = unset_r8 + BUOYM (I,k) = unset_r8 + WCM (I,k) = unset_r8 + WCV (I,k) = unset_r8 + GCY (I,k) = unset_r8 + ELAR (I,k) = unset_r8 +! + GCHM (I,k) = unset_r8 + GCWM (I,k) = unset_r8 + GCTM (I,k) = unset_r8 + GCQM (I,k) = unset_r8 + GCLM (I,k) = unset_r8 + GCIM (I,k) = unset_r8 + GCUM (I,k) = unset_r8 + GCVM (I,k) = unset_r8 + enddo + enddo + +!#ifdef SYS_SX + DO K=1,KMAX + DO I=ISTS, IENS + IF (K > KB(I)) THEN + GCYM(I,K) = zero + ENDIF + ENDDO + ENDDO +!#else +! DO I=ISTS,IENS +! GCYM(I,KB(I)+1:KMAX) = zero +! ENDDO +!#endif + DO I=ISTS,IENS + GDZMKB(I) = GDZM(I,KB(I)) ! cloud base height + ENDDO +! +! < cloud base properties > +! + DO I=ISTS,IENS + K = KB(I) + GCHM(I,K) = GCHB(I) + GCWM(I,K) = GCWB(I) + WCM (I,K) = WCB(i) + GCUM(I,K) = GCUB(I) + GCVM(I,K) = GCVB(I) +! + esat = min(gdpm(i,k), fpvs(gdtm(i,k))) + GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 1.0) + gdsm = CP*GDTM(I,K) + GRAV*GDZMKB(I) ! dse + GDHSM = gdsm + EL*GDQSM ! saturated mse +! FDQSM = FDQSAT(GDTM(I,K), GDQSM) + tem = one / GDTM(I,K) + FDQSM = GDQSM * tem * (fact1 + fact2*tem) +! + tem = one / (CP+EL*FDQSM) + DCTM = (GCHB(I) - GDHSM) * tem + GCQM(I,K) = min(GDQSM + FDQSM*DCTM, GCWM(I,K)) + GCCM = MAX(GCWM(I,K)-GCQM(I,K), zero) +! GCTM(I,K) = GDT(I,K) + DCTM ! old + GCTM(I,K) = (GCHB(I) - gdsm - el*gcqm(i,k)) * oneocp + dctm ! new +! + GCIM(I,K) = FRICE(GCTM(I,K)) * GCCM ! cloud base ice + GCLM(I,K) = MAX(GCCM-GCIM(I,K), zero) ! cloud base liquid + GCHM(I,K) = GCHM(I,K) + EMELT * (GCIM(I,K)-GCIB(I)) + DCTM = (GCHM(I,K) - GDHSM) * tem +! GCTM(I,K) = dctm + GDT(I,K) + gocp*gdzm(i,k) !DD old AW convert to DSE + GCTM(I,K) = dctm + (GCHB(I) - el*gcqm(i,k)) * oneocp ! new, make dse +! + GDQM = half * (GDQ(I,K,1) + GDQ(I,K-1,1)) + GDCM = half * (GDQ(I,K,ITL) + GDQI(I,K) & + + GDQ(I,K-1,ITL) + GDQI(I,K-1)) + +! + BUOYM(I,K) = (DCTM/GDTM(I,K) + EPSVT*(GCQM(I,K)-GDQM) - GCCM + GDCM )*GRAV +! +!DD#ifdef OPT_ASMODE +!DD ELARM1(I) = ERMR +!DD#elif defined OPT_NS02 +!DD ELARM1(I) = ELMD / SQRT(WCM(I,K)) +!DD#else + ELARM1(I) = CLMD*PA*BUOYM(I,K)/WCM(I,K) +!DD#endif + ELARM1(I) = MIN(MAX(ELARM1(I), ELAMIN), ELAMAX) +! + GCHMZ (I,K) = GCHM(I,K) + GCWMZ (I,K) = GCWM(I,K) + GCqMZ (I,K) = GCqM(I,K) + GCUMZ (I,K) = GCUM(I,K) + GCVMZ (I,K) = GCVM(I,K) + GCIMZ (I,K) = GCIM(I,K) + WCM_(I) = WCM(I,K) + ENDDO +! +! < in-cloud properties > +! + DO K=3,KMAX + km1 = k - 1 + DO I=ISTS,IENS + IF (K > KB(I) .AND. WCM_(I) > WCCRT) THEN + WCV(I,KM1) = SQRT(MAX(WCM_(I), zero)) + DELZ = GDZM(I,K) - GDZM(I,KM1) + GCYM(I,K) = GCYM(I,KM1) * EXP(ELARM1(I)*DELZ) + ELADZ = GCYM(I,K) - GCYM(I,KM1) +! + GCHMZ(I,K) = GCHMZ(I,KM1) + GDH(I,KM1)*ELADZ + GCWMZ(I,K) = GCWMZ(I,KM1) + GDW(I,KM1)*ELADZ +! + esat = min(gdpm(i,k), fpvs(gdtm(i,k))) + GDQSM = min(EPSV*esat/max(gdpm(i,k)+epsvm1*esat, 1.0e-10), 1.0) + GDHSM = CP*GDTM(I,K ) + GRAV*GDZM(I,K) + EL*GDQSM +! FDQSM = FDQSAT(GDTM(I,K), GDQSM) + tem = one / GDTM(I,K) + FDQSM = GDQSM * tem * (fact1 + fact2*tem) + CPGMI = one / (CP + EL*FDQSM) + + PRCZH = PRECZH * MIN(GDZTR(I)/ZTREF, one) + PRECR = FPREC(GDZM(I,K)-GDZMKB(I), PRCZH ) +! + wrk = one / GCYM(I,K) + DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI + GCQMZ(i,k) = (GDQSM+FDQSM*DCTM) * GCYM(I,K) + GCQMZ(i,k) = MIN(GCQMZ(i,k), GCWMZ(I,K)) + GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i,k)) + GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) + GCCMZ = GCWMZ(I,K) - GCQMZ(i,k) - GTPRMZ(I,K ) + DELC = MIN(GCCMZ, zero) + GCCMZ = GCCMZ - DELC + GCQMZ(i,k) = GCQMZ(i,k) + DELC +! + FICE = FRICE(GDTM(I,K)+DCTM ) + GCIMZ(I,K) = FICE*GCCMZ + GSNWIZ(I,KM1) = FICE * (GTPRMZ(I,K)-GTPRMZ(I,KM1)) + GCHMZ(I,K) = GCHMZ(I,K) + EMELT * (GCIMZ(I,K) + GSNWIZ(I,KM1) & + - GCIMZ(I,KM1) - GDQI(I,KM1)*ELADZ) + DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI +! + GDQM = half * (GDQ(I,K,1) + GDQ(I,KM1,1)) + GDCM = half * (GDQ(I,K,ITL) + GDQI(I,K) & + + GDQ(I,KM1,ITL) + GDQI(I,KM1)) + GCQM(I,K) = GCQMZ(i,k)*wrk + GCCM = GCCMZ*wrk +! + BUOYM(I,K) = (DCTM/GDTM(I,K) & + + EPSVT*(GCQM(I,K)-GDQM )-GCCM+GDCM) * GRAV + BUOY(I,KM1) = half * (BUOYM(I,K)+BUOYM(I,KM1)) +! +!DD#ifdef OPT_ASMODE +!DD WCM(I,K ) & +!DD = (WCM_(I) + 2.D0*PA*DELZ*BUOY(I,KM1) ) & +!DD / (one + 2.D0*PB*DELZ*ERMR) +!DD#elif OPT_NS02 +!DD WCM(I,K ) = WCM_(I ) & +!DD + 2.D0*DELZ*(PA*BUOYM(I,KM1)-ELMD*WCV(I,KM1)) +!DD WCM(I,K ) = MAX(WCM(I,K ), zero ) +!DD WCVX = SQRT(half*(WCM(I,K )+WCM_(I))) +!DD WCM(I,K) = WCM_(I) + 2.D0*DELZ*(PA*BUOY(I,KM1)-ELMD*WCVX) +!DD#else + IF (BUOY(I,KM1) > zero) THEN + WCM(I,K) = (WCM_(I) + CLMP*DELZ*BUOY(I,KM1)) & + / (one + DELZ/TAUZ) + ELSE + WCM(I,K) = (WCM_(I) + PA*(DELZ+DELZ)*BUOY(I,KM1) ) & + / (one + DELZ/TAUZ + (DELZ+DELZ)*ELAMIN ) + ENDIF +!DD#endif +! +!DD#ifdef OPT_ASMODE +!DD ELARM2 = ERMR +!DD#elif OPT_NS02 +!DD ELARM2 = ELMD/SQRT(MAX(WCM(I,K), EPSln)) +!DD#else + ELARM2 = CLMD*PA*BUOYM(I,K) / MAX(WCM(I,K), EPSln) +!DD#endif + ELARM2 = MIN(MAX(ELARM2, ELAMIN), ELAMAX) + ELAR(I,KM1) = half * (ELARM1(I) + ELARM2) + GCYM(I,K) = GCYM(I,KM1) * EXP(ELAR(I,KM1)*DELZ) + ELADZ = GCYM(I,K) - GCYM(I,KM1) + ELAM(I,KM1) = ELADZ / DELZ +! + GCHMZ(I,K) = GCHMZ(I,KM1) + GDH(I,KM1)*ELADZ + GCWMZ(I,K) = GCWMZ(I,KM1) + GDW(I,KM1)*ELADZ + GCUMZ(I,K) = GCUMZ(I,KM1) + GDU(I,KM1)*ELADZ + GCVMZ(I,K) = GCVMZ(I,KM1) + GDV(I,KM1)*ELADZ +! + wrk = one / GCYM(I,K) + DCTM = (GCHMZ(I,K)*wrk - GDHSM) * CPGMI + GCQMZ(i,k) = (GDQSM+FDQSM*DCTM) * GCYM(I,K) + GCQMZ(i,k) = MIN(GCQMZ(i,k), GCWMZ(I,K)) + GTPRMZ(I,K) = PRECR * (GCWMZ(I,K)-GCQMZ(i,k)) + GTPRMZ(I,K) = MAX(GTPRMZ(I,K), GTPRMZ(I,KM1)) + GCCMZ = GCWMZ(I,K) - GCQMZ(i,k) - GTPRMZ(I,K) + DELC = MIN(GCCMZ, zero) + GCCMZ = GCCMZ - DELC + GCQMZ(i,k) = GCQMZ(i,k) + DELC + GCCM = GCCMZ*wrk + GCQM(I,K) = GCQMZ(i,k)*wrk +! + FICE = FRICE(GDTM(I,K)+DCTM ) + GCIMZ(I,K) = FICE*GCCMZ + GCIM(I,K) = GCIMZ(I,K)*wrk + GCLM(I,K) = MAX(GCCM-GCIM(I,K), zero) + GTPRIZ = GTPRMZ(I,K) - GTPRMZ(I,KM1) + GSNWIZ(I,KM1) = FICE*GTPRIZ + GPRCIZ(I,KM1) = (one-FICE )*GTPRIZ + GCHMZ(I,K) = GCHMZ(I,K) + EMELT*(GCIMZ(I,K) + GSNWIZ(I,KM1) & + - GCIMZ(I,KM1) - GDQI(I,KM1)*ELADZ ) + GCHM(I,K) = GCHMZ(I,K)*wrk + DCTM = (GCHM(I,K)-GDHSM) * CPGMI +! GCTM(I,K) = dctm + GDTM(I,K) + gocp*gdzm(i,k) ! old, make dse + GCTM(I,K) = dctm + (GCHM(I,K) - el*gcqm(i,k)) * oneocp ! new, make dse +! + GCWM(I,K) = GCWMZ(I,K)*wrk + GCUM(I,K) = GCUMZ(I,K)*wrk + GCVM(I,K) = GCVMZ(I,K)*wrk + DELZL = GDZ(I,KM1)-GDZM(I,KM1) + GCY (I,KM1) = GCYM(I,KM1) * EXP(ELAR(I,KM1)*DELZL) + GCLZ(I,KM1) = half * (GCLM(I,K) + GCLM(I,KM1)) * GCY(I,KM1) + GCIZ(I,KM1) = half * (GCIM(I,K) + GCIM(I,KM1)) * GCY(I,KM1) + IF (BUOY(I,KM1) > zero) THEN + ACWF(I) = ACWF(I) + BUOY(I,KM1)*GCY(I,KM1)*DELZ + ENDIF +! + ELARM1(I) = ELARM2 + WCM_(I) = WCM(I,K) + + rhs_h = cbmfx(i)*(gchmz(i,k) - (gchmz(i,km1) + GDH(I,KM1)*ELADZ)) + rhs_q = cbmfx(i)*(gcwmz(i,k)-gcqmz(i,k) & + - (gcwmz(i,km1)-gcqmz(i,km1) & + + (GDw(I,KM1)-gdq(i,km1,1))*ELADZ)) + dqcond(i,km1) = -rhs_q + dtfrz(i,km1) = rhs_h*oneocp + dtcond(i,km1) = -ELocp*DQCOND(i,km1) + + ENDIF ! IF (K > KB(I) .AND. WCM_(I) > WCCRT) THEN + ENDDO + ENDDO +! +! < find cloud top > +! + DO I=ISTS,IENS + KT(I) = -1 + enddo + DO K=KMAX,2,-1 + DO I=ISTS,IENS + IF (K > KB(I) .AND. KT(I) == -1 & + .AND. BUOYM(I,K) > zero .AND. WCM(I,K) > WCCRT) THEN + KT(I) = K + ENDIF + ENDDO + ENDDO +! + KTMX = 2 + DO I=ISTS,IENS + kt(i) = min(kt(i), kmax-1) + KTMX = max(ktmx, KT(I)) + ENDDO +! + DO I=ISTS,IENS + kk = kt(i) + IF (KK > 0 ) then + do k=kk+1,kmax + GCYM(I,K) = zero + enddo + do k=kk,kmax + GCLZ (I,K) = zero + GCIZ (I,K) = zero + GPRCIZ(I,K) = zero + GSNWIZ(I,K) = zero + dtcond(i,k) = 0.0 + dqcond(i,k) = 0.0 + dtfrz(i,k) = 0.0 + enddo + ELSE + do k=kb(i)+1,kmax + GCYM(I,K) = zero + enddo + do k=1,kmax + GCLZ (I,k) = zero + GCIZ (I,k) = zero + GPRCIZ(I,k) = zero + GSNWIZ(I,k) = zero + dtcond(i,k) = 0.0 + dqcond(i,k) = 0.0 + dtfrz(i,k) = 0.0 + enddo + ENDIF + ENDDO +! +! < cloud top properties > +! + DO I=ISTS,IENS + IF (KT(I) > 0) THEN + K = KT(I) + kp1 = k + 1 + GCYT(I) = GCY(I,K) + ELADZ = GCYT(I) - GCYM(I,K) + ELAM(I,K) = ELADZ / (GDZ(I,K)-GDZM(I,K)) +! + GCHT(I) = GCHMZ(I,K) + GDH(I,K)*ELADZ + GCWT(i) = GCWMZ(I,K) + GDW(I,K)*ELADZ + GCUT(I) = GCUMZ(I,K) + GDU(I,K)*ELADZ + GCVT(I) = GCVMZ(I,K) + GDV(I,K)*ELADZ +! + DCT = (GCHT(I)/GCYT(I) - GDHS(I,K)) & + / (CP*(one + GAM(I,K))) + GCQT(I) = (GDQS(I,K) + FDQS(I,K)*DCT) * GCYT(I) + GCQT(I) = MIN(GCQT(I), GCWT(i)) + PRCZH = PRECZH * MIN(GDZTR(I)/ZTREF, one) + GTPRT(I) = FPREC(GDZ(I,K)-GDZMKB(I), PRCZH) * (GCWT(i)-GCQT(I)) + GTPRT(I) = MAX(GTPRT(I), GTPRMZ(I,K)) + GCCT = GCWT(i) - GCQT(I) - GTPRT(I) + DELC = MIN(GCCT, zero) + GCCT = GCCT - DELC + GCQT(I) = GCQT(I) + DELC +! + FICE = FRICE(GDT(I,K)+DCT) + GCIT(I) = FICE*GCCT + GCLT(I) = (one-FICE) * GCCT + GTPRIZ = GTPRT(I) - GTPRMZ(I,K) + GPRCIZ(I,K) = (one-FICE) * GTPRIZ + GSNWIZ(I,K) = FICE * GTPRIZ + GCHT(I) = GCHT(I) & + + EMELT * (GCIT(I) + GSNWIZ(I,K) - GCIMZ(I,K) - GDQI(I,K)*ELADZ) +! + GCUT(I) = GCUT(I)*(one-CPRES) + GCY(I,K)*GDU(I,K)*CPRES + GCVT(I) = GCVT(I)*(one-CPRES) + GCY(I,K)*GDV(I,K)*CPRES + GCLZ(I,K) = GCLT(I) + GCIZ(I,K) = GCIT(I) + +!DD AW get the cloud top values denormalized and put into profile + mygcht = gcht(I) - el*(gcwt(i) - gcqt(i)) + + wrk = one / gcyt(i) + gctm(i,kp1) = wrk * (mygcht - el*gcqt(i)) * oneocp +!Moorthi gcqm(i,kp1) = gcqt(i) + gcqm(i,kp1) = gcqt(i)*wrk ! check this - oct17 2016 + gcim(i,kp1) = gcit(i)*wrk + gclm(i,kp1) = gclt(i)*wrk +! + rhs_q = cbmfx(i)*( gcwt(i)-gcqt(i) - (gcwmz(i,k)-gcqmz(i,k) & + + (GDw(I,K)-gdq(i,k,1))*ELADZ) ) + dqcond(i,k) = -rhs_q + rhs_h = cbmfx(i)*(gcht(i) - (gchmz(i,k) + GDH(I,K)*ELADZ)) + + dtfrz(i,k) = rhs_h * oneocp + dtcond(i,k) = -ELocp*DQCOND(i,k) + ENDIF + ENDDO +! +!DD#ifdef OPT_CUMBGT /* budget check */ +!DD HBGT ( ISTS:IENS ) = 0.D0 +!DD WBGT ( ISTS:IENS ) = 0.D0 +!DD PBGT ( ISTS:IENS ) = 0.D0 +!DD MBGT ( ISTS:IENS ) = 0.D0 +!DD GTPRX( ISTS:IENS ) = 0.D0 +!DD GSNWT( ISTS:IENS ) = 0.D0 +!DD! +!DD IF ( CTP .EQ. 1 ) THEN +!DD HBMX = 0.D0 +!DD WBMX = 0.D0 +!DD PBMX = 0.D0 +!DD MBMX = 0.D0 +!DD END IF +!DD! +!DD DO K = 2, KMAX +!DD DO I = ISTS, IENS +!DD IF ( K .GE. KB( I ) .AND. K .LT. KT( I ) ) THEN +!DD ELADZ = GCYM( I,K+1 ) - GCYM( I,K ) +!DD DELZ = GDZM( I,K+1 ) - GDZM( I,K ) +!DD HBGT( I ) = HBGT( I ) + ( GDH( I,K )-EMELT*GDQI( I,K ) )*ELADZ +!DD WBGT( I ) = WBGT( I ) + GDW( I,K )*ELADZ +!DD MBGT( I ) = MBGT( I ) + ELAM( I,K )*DELZ +!DD GTPRX( I ) = GTPRX( I ) + GPRCIZ( I,K ) + GSNWIZ( I,K ) +!DD GSNWT( I ) = GSNWT( I ) + GSNWIZ( I,K ) +!DD END IF +!DD END DO +!DD END DO +!DD! +!DD DO I = ISTS, IENS +!DD IF ( KT( I ) .GT. KB( I ) ) THEN +!DD ELADZ = GCYT( I ) - GCYM( I,KT(I) ) +!DD DELZ = GDZ( I,KT(I) )-GDZM( I,KT(I) ) +!DD GTPRX( I ) = GTPRX( I ) + GPRCIZ( I,KT(I) ) + GSNWIZ( I,KT(I) ) +!DD GSNWT( I ) = GSNWT( I ) + GSNWIZ( I,KT(I) ) +!DD HBGT( I ) = HBGT( I ) + GCHB( I ) - EMELT*GCIB( I ) & +!DD + ( GDH( I,KT(I) )-EMELT*GDQI( I,KT(I) ) ) *ELADZ & +!DD - ( GCHT(I)-EMELT*( GCIT(I)+GSNWT(I) ) ) +!DD WBGT( I ) = WBGT( I ) & +!DD + GCWB( I ) + GDW( I,KT(I) )*ELADZ & +!DD - GCQT( I ) - GCLT( I ) - GCIT( I ) & +!DD - GTPRT( I ) +!DD MBGT( I ) = MBGT( I ) + one + ELAM( I,KT(I) )*DELZ & +!DD - GCYT( I ) +!DD PBGT( I ) = GTPRT( I ) - GTPRX( I ) +!DD! +!DD IF ( ABS( HBGT(I) ) .GT. ABS( HBMX ) ) HBMX = HBGT(I) +!DD IF ( ABS( WBGT(I) ) .GT. ABS( WBMX ) ) WBMX = WBGT(I) +!DD IF ( ABS( PBGT(I) ) .GT. ABS( PBMX ) ) PBMX = PBGT(I) +!DD IF ( ABS( MBGT(I) ) .GT. ABS( MBMX ) ) MBMX = MBGT(I) +!DD END IF +!DD END DO +!DD! +!DD IF ( CTP .EQ. NCTP ) THEN +!DD WRITE( iulog,* ) '### CUMUP(rank=',irank,'): energy imbalance =', HBMX +!DD WRITE( iulog,* ) '### CUMUP(rank=',irank,'): water imbalance =', WBMX +!DD WRITE( iulog,* ) '### CUMUP(rank=',irank,'): precipitation imbalance =', PBMX +!DD WRITE( iulog,* ) '### CUMUP(rank=',irank,'): mass imbalance =', MBMX +!DD END IF +!DD#endif +! +! WRITE( CTNUM, '(I2.2)' ) CTP +! + END SUBROUTINE CUMUP +!*********************************************************************** + SUBROUTINE CUMBMX & !! cloud base mass flux + ( IJSDIM, KMAX , & !DD dimensions + CBMFX , & ! modified + ACWF , GCYT , GDZM , & ! input + GDW , GDQS , DELP , & ! input + KT , KTMX , KB , & ! input + DELT , ISTS , IENS ) ! input +! +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) CBMFX (IJSDIM) ! cloud base mass flux +! +! [INPUT] + REAL(r8) ACWF (IJSDIM) ! cloud work function + REAL(r8) GCYT (IJSDIM) ! norm mass flux @top + REAL(r8) GDZM (IJSDIM, KMAX+1) ! height + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity + REAL(r8) DELP (IJSDIM, KMAX) ! delt pressure + INTEGER KT (IJSDIM) ! cloud top + INTEGER KTMX ! max. of cloud top + INTEGER KB (IJSDIM) ! cloud base + REAL(r8) DELT ! time step + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8), dimension(ijsdim) :: QX, QSX, RHM + INTEGER I, K + REAL(r8) ALP, FMAX1, wrk +! +! [INTERNAL PARAM] + REAL(r8) :: FMAX = 1.5e-2_r8 ! maximum flux + REAL(r8) :: RHMCRT = zero ! critical val. of RH@ all could +! REAL(r8) :: RHMCRT = 0.5_r8 ! critical val. of RH@ all could + REAL(r8) :: ALP1 = zero + REAL(r8) :: TAUD = 1.e3_r8 + REAL(r8) :: ZFMAX = 3.5e3_r8 + REAL(r8) :: ZDFMAX = 5.e2_r8 +! REAL(r8) :: FMAXP = 2._r8 + REAL(r8) :: EPSln = 1.e-10_r8 +! + do i=ists,iens + qx(i) = zero + qsx(i) = zero + enddo +! + DO K=1,KTMX + DO I=ISTS,IENS + IF (K >= KB(I) .AND. K <= KT(I)) THEN + QX (I) = QX (I) + GDW (I,K) * DELP(I,K) + QSX(I) = QSX(I) + GDQS(I,K) * DELP(I,K) + ENDIF + ENDDO + ENDDO + DO I=ISTS,IENS + RHM(I) = min(one, max(zero, QX(I)/MAX(QSX(I),EPSln))) + ENDDO +! + wrk = one + delt/(taud+taud) + DO I=ISTS,IENS + IF (KT(I) > KB(I) .AND. RHM(I) >= RHMCRT) THEN + ALP = ALP0 + ALP1 * (GDZM(I,KT(I))-GDZM(I,KB(I))) + FMAX1 = (one - TANH((GDZM(I,1)-ZFMAX)/ZDFMAX)) * half +! FMAX1 = FMAX * FMAX1**FMAXP + FMAX1 = FMAX * FMAX1 * FMAX1 +! CBMFX(I) = CBMFX(I) + MAX(ACWF(I), zero)/(ALP+ALP)*DELT +! CBMFX(I) = CBMFX(I) / (one + DELT/(TAUD+TAUD)) + CBMFX(I) = (CBMFX(I) + MAX(ACWF(I), zero)/(ALP+ALP)*DELT) * wrk + CBMFX(I) = MIN(max(CBMFX(I), zero), FMAX1/GCYT(I)) + ELSE + CBMFX(I) = zero + ENDIF + ENDDO +! + END SUBROUTINE CUMBMX +!*********************************************************************** + SUBROUTINE CUMFLX & !! cloud mass flux + ( IM , IJSDIM, KMAX , & !DD dimensions + GMFLX , GPRCI , GSNWI , & ! output + QLIQ , QICE , GTPRC0, & ! output + CBMFX , GCYM , GPRCIZ, GSNWIZ, & ! input + GTPRT , GCLZ , GCIZ , & ! input + KB , KT , KTMX , & ! input + ISTS , IENS , sigma ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, KMAX, IM !! DD, for GFS, pass in +! +! [OUTPUT] + REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux + REAL(r8) GPRCI (IJSDIM, KMAX) !! rainfall generation + REAL(r8) GSNWI (IJSDIM, KMAX) !! snowfall generation + REAL(r8) QLIQ (IJSDIM, KMAX) !! cloud liquid + REAL(r8) QICE (IJSDIM, KMAX) !! cloud ice + REAL(r8) GTPRC0(IJSDIM) !! precip. before evap. +! +! [INPUT] + REAL(r8) CBMFX (IJSDIM) !! cloud base mass flux + REAL(r8) GCYM (IJSDIM, KMAX) !! normalized mass flux + REAL(r8) sigma (IJSDIM, KMAX) !! AW sigma + REAL(r8) GPRCIZ(IJSDIM, KMAX) !! precipitation/M + REAL(r8) GSNWIZ(IJSDIM, KMAX) !! snowfall/M + REAL(r8) GTPRT (IJSDIM) !! rain+snow @top + REAL(r8) GCLZ (IJSDIM, KMAX) !! cloud liquid/M + REAL(r8) GCIZ (IJSDIM, KMAX) !! cloud ice/M + real(r8) tem + INTEGER KB (IJSDIM) !! cloud base + INTEGER KT (IJSDIM) !! cloud top + INTEGER KTMX !! max of cloud top + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + INTEGER I, K +! +!M DO K=1,KTMX +!M DO I=ISTS,IENS +!M GMFLX(I,K) = GMFLX(I,K) + GCYM(I,K)*CBMFX(I) +!M ENDDO +!M ENDDO +! + DO K=1,KTMX + DO I=ISTS,IENS + tem = CBMFX(I) * (one - sigma(i,k)) + GMFLX(I,K) = GMFLX(I,K) + tem * GCYM(I,K) + GPRCI(I,K) = GPRCI(I,K) + tem * GPRCIZ(I,K) + GSNWI(I,K) = GSNWI(I,K) + tem * GSNWIZ(I,K) + QLIQ(I,K) = QLIQ (I,K) + tem * GCLZ(I,K) + QICE(I,K) = QICE (I,K) + tem * GCIZ(I,K) + +! GMFLX(I,K) = GMFLX(I,K) + GCYM(I,K) * CBMFX(I) +! GPRCI(I,K) = GPRCI(I,K) + GPRCIZ(I,K) * CBMFX(I) +! GSNWI(I,K) = GSNWI(I,K) + GSNWIZ(I,K) * CBMFX(I) +! QLIQ(I,K) = QLIQ (I,K) + GCLZ(I,K) * CBMFX(I) +! QICE(I,K) = QICE (I,K) + GCIZ(I,K) * CBMFX(I) + ENDDO + ENDDO +! + DO I= ISTS,IENS + GTPRC0(I) = GTPRC0(I) + GTPRT(I) * CBMFX(I) + ENDDO +! +!M DO K = 1, KTMX +!M DO I = ISTS, IENS +!M QLIQ(I,K) = QLIQ(I,K) + GCLZ(I,K)*CBMFX(I) +!M QICE(I,K) = QICE(I,K) + GCIZ(I,K)*CBMFX(I) +!M ENDDO +!M ENDDO +! + END SUBROUTINE CUMFLX +!*********************************************************************** + SUBROUTINE CUMDET & !! detrainment + ( im , IJSDIM, KMAX , NTR , & !DD dimensions + CMDET , & ! output +! CMDET , GTLDET, GTIDET, & ! output + GTT , GTQ , GTCFRC, GTU , GTV , & ! modified +! GTQI , & ! modified + GDH , GDQ , GDCFRC, GDU , GDV , & ! input + CBMFX , GCYT , DELP , GCHT , GCQT , & ! input + GCLT , GCIT , GCUT , GCVT , GDQI , & ! input + KT , ISTS , IENS , nctp , sigi ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, nctp !! DD, for GFS, pass in +! +! [OUTPUT] + REAL(r8) CMDET (IJSDIM, KMAX) !! detrainment mass flux +! REAL(r8) GTLDET(IJSDIM, KMAX) !! cloud liquid tendency by detrainment +! REAL(r8) GTIDET(IJSDIM, KMAX) !! cloud ice tendency by detrainment +! +! [MODIFY] + REAL(r8) GTT (IJSDIM, KMAX) !! temperature tendency + REAL(r8) GTQ (IJSDIM, KMAX, NTR) !! moisture tendency + REAL(r8) GTCFRC(IJSDIM, KMAX) !! cloud fraction tendency + REAL(r8) GTU (IJSDIM, KMAX) !! u tendency + REAL(r8) GTV (IJSDIM, KMAX) !! v tendency +! REAL(r8) GTQI (IJSDIM, KMAX) !! cloud ice tendency +! +! [INPUT] + REAL(r8) GDH (IJSDIM, KMAX) !! moist static energy + REAL(r8) GDQ (IJSDIM, KMAX, NTR) !! humidity qv + REAL(r8) GDCFRC(IJSDIM, KMAX) !! cloud fraction + REAL(r8) GDU (IJSDIM, KMAX) + REAL(r8) GDV (IJSDIM, KMAX) + REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) CBMFX (IM, NCTP) !! cloud base mass flux + REAL(r8) GCYT (IJSDIM, NCTP) !! detraining mass flux + REAL(r8) GCHT (IJSDIM, NCTP) !! detraining MSE + REAL(r8) GCQT (IJSDIM, NCTP) !! detraining qv + REAL(r8) GCLT (IJSDIM, NCTP) !! detraining ql + REAL(r8) GCIT (IJSDIM, NCTP) !! detraining qi + REAL(r8) GCUT (IJSDIM, NCTP) !! detraining u + REAL(r8) GCVT (IJSDIM, NCTP) !! detraining v + REAL(r8) GDQI (IJSDIM, KMAX) !! cloud ice + REAL(r8) sigi (IJSDIM, KMAX,nctp) !! cloud fraction + INTEGER KT (IJSDIM, NCTP) !! cloud top + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8) sigma(ijsdim) + REAL(r8) GTHCI, GTQVCI, GTQLCI, GTQICI, GTXCI, tem +!M REAL(r8) GTCCI +!M REAL(r8) GTUCI, GTVCI + INTEGER I, K, CTP, kk +! +! +!PARALLEL_FORBID + + do k=1,kmax + DO I=ISTS,IENS + CMDET (I,k) = zero +! GTLDET(I,k) = zero +! GTIDET(I,k) = zero + enddo + enddo + do i=ists,iens + sigma(i) = zero + enddo + +!PARALLEL_FORBID + DO CTP=1,NCTP + DO I=ISTS,IENS + K = KT(I,CTP) + IF (K > 0) THEN + sigma(i) = sigma(i) + sigi(i,k,ctp) + tem = CBMFX(I,CTP) * (one - sigma(i)) + GTXCI = GRAV/DELP(I,K)*tem + + GTHCI = GTXCI * (GCHT(I,CTP) - GCYT(I,CTP)*GDH(I,K)) + GTQVCI = GTXCI * (GCQT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,1)) + GTQLCI = GTXCI * (GCLT(I,CTP) - GCYT(I,CTP)*GDQ(I,K,ITL)) + GTQICI = GTXCI * (GCIT(I,CTP) - GCYT(I,CTP)*GDQI(I,K)) +! + GTQ(I,K,1) = GTQ(I,K,1) + GTQVCI + GTT(I,K) = GTT(I,K) + (GTHCI - EL*GTQVCI) * oneocp +! ql tendency by detrainment is treated by stratiform scheme + GTQ(I,K,ITL) = GTQ(I,K,ITL) + GTQLCI +! GTLDET(I,K) = GTLDET(I,K) + GTQLCI +! qi tendency by detrainment is treated by stratiform scheme +! GTQI (I,K) = GTQI(I,K) + GTQICI +! GTIDET(I,K) = GTIDET(I,K) + GTQICI + GTQ(I,K,ITI) = GTQ(I,K,ITI) + GTQICI + + GTCFRC(I,K) = GTCFRC(I,K) + GTXCI * (GCYT(I,CTP) - GCYT(I,CTP)*GDCFRC(I,K)) + GTU(I,K) = GTU(I,K) + GTXCI * (GCUT(I,CTP) - GCYT(I,CTP)*GDU(I,K)) + GTV(I,K) = GTV(I,K) + GTXCI * (GCVT(I,CTP) - GCYT(I,CTP)*GDV(I,K)) +! + CMDET(I,K ) = CMDET(I,K) + GCYT(I,CTP) * tem + ENDIF + ENDDO + ENDDO +! + END SUBROUTINE CUMDET +!*********************************************************************** + SUBROUTINE CUMSBH & !! adiabat. descent + ( IM , IJSDIM, KMAX , NTR ,& !DD dimensions + GTT , GTQ , & ! modified +! GTT , GTQ , GTQI , & ! modified + GTU , GTV , & ! modified + GDH , GDQ , GDQI , & ! input + GDU , GDV , & ! input + DELP , GMFLX , GMFX0 , & ! input + KTMX , CPRES , ISTS , IENS ) ! input +! +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, IM, KMAX, NTR !! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTT (IJSDIM, KMAX) !! Temperature tendency + REAL(r8) GTQ (IJSDIM, KMAX, NTR) !! Moisture etc tendency +! REAL(r8) GTQI (IJSDIM, KMAX) + REAL(r8) GTU (IJSDIM, KMAX) !! u tendency + REAL(r8) GTV (IJSDIM, KMAX) !! v tendency +! +! [INPUT] + REAL(r8) GDH (IJSDIM, KMAX) + REAL(r8) GDQ (IJSDIM, KMAX, NTR) !! humidity etc + REAL(r8) GDQI (IJSDIM, KMAX) + REAL(r8) GDU (IJSDIM, KMAX) + REAL(r8) GDV (IJSDIM, KMAX) + REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux (updraft+downdraft) + REAL(r8) GMFX0 (IJSDIM, KMAX) !! mass flux (updraft only) + INTEGER KTMX + REAL(r8) CPRES !! pressure factor for cumulus friction + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + INTEGER I, K, KM, KP + REAL(r8) SBH0, SBQ0, SBL0, SBI0, SBC0, SBS0, & + SBH1, SBQ1, SBL1, SBI1, SBC1, SBS1, FX1, & + SBU0, SBV0, SBU1, SBV1, GTHCI, GTQVCI, & + GTQLCI, GTQICI, GTM2CI, GTM3CI, wrk, wrk1 +!M REAL(r8) GTUCI, GTVCI, wrk, wrk1 + REAL(r8) FX(ISTS:IENS) + + REAL(r8), dimension(IJSDIM, KMAX) :: GTLSBH, GTISBH +! +! + FX = zero + do k=1,kmax + do i=ists,iens + GTLSBH(i,k) = zero + GTISBH(i,k) = zero + enddo + enddo +! + DO K=KTMX,1,-1 + KM = MAX(K-1, 1) + KP = MIN(K+1, KMAX) + DO I=ISTS,IENS + SBH0 = GMFLX(I,KP) * (GDH(I,KP)-GDH(I,K)) + SBQ0 = GMFLX(I,KP) * (GDQ(I,KP,1)-GDQ(I,K,1)) + SBL0 = GMFLX(I,KP) * (GDQ(I,KP,ITL )-GDQ(I,K,ITL)) + SBI0 = GMFLX(I,KP) * (GDQI(I,KP)-GDQI(I,K)) + SBU0 = GMFLX(I,KP) * (GDU(I,KP)-GDU(I,K)) & + - GMFX0(I,KP) * (GDU(I,KP)-GDU(I,K))*CPRES + SBV0 = GMFLX(I,KP) * (GDV(I,KP)-GDV(I,K)) & + - GMFX0(I,KP) * (GDV(I,KP)-GDV(I,K))*CPRES +! + SBH1 = GMFLX(I,K) * (GDH(I,K)-GDH(I,KM)) + SBQ1 = GMFLX(I,K) * (GDQ(I,K,1)-GDQ(I,KM,1)) + SBL1 = GMFLX(I,K) * (GDQ(I,K,ITL)-GDQ(I,KM,ITL)) + SBI1 = GMFLX(I,K) * (GDQI(I,K)-GDQI(I,KM)) + SBU1 = GMFLX(I,K) * (GDU(I,K)-GDU(I,KM)) & + - GMFX0(I,K) * (GDU(I,K)-GDU(I,KM))*CPRES + SBV1 = GMFLX(I,K) * (GDV(I,K)-GDV(I,KM)) & + - GMFX0(I,K) * (GDV(I,K)-GDV(I,KM))*CPRES +! +!#ifndef SYS_SX /* original */ + IF (GMFLX(I,K) > GMFLX(I,KP)) THEN + FX1 = half + ELSE + FX1 = zero + ENDIF +!#else /* optimized for NEC SX series */ +! FX1 = 0.25D0 - SIGN(0.25D0,GMFLX(I,K+1)-GMFLX(I,K)) !! 0.5 or 0. +!#endif +! + wrk = GRAV / DELP(I,K) + wrk1 = one - FX(I) + GTHCI = wrk * (wrk1*SBH0 + FX1 *SBH1) + GTQVCI = wrk * (wrk1*SBQ0 + FX1 *SBQ1) + GTQLCI = wrk * (wrk1*SBL0 + FX1 *SBL1) + GTQICI = wrk * (wrk1*SBI0 + FX1 *SBI1) +!M GTUCI = wrk * (wrk1*SBU0 + FX1 *SBU1) +!M GTVCI = wrk * (wrk1*SBV0 + FX1 *SBV1) +! + GTT (I,K ) = GTT(I,K) + (GTHCI-EL*GTQVCI)*oneocp + GTQ (I,K,1 ) = GTQ(I,K,1) + GTQVCI + GTQ (I,K,ITL) = GTQ(I,K,ITL) + GTQLCI + GTQ (I,K,ITI) = GTQ(I,K,ITI) + GTQICI +! GTQI(I,K) = GTQI(I,K) + GTQICI +!M GTU (I,K) = GTU(I,K) + GTUCI +!M GTV (I,K) = GTV(I,K) + GTVCI + GTU (I,K) = GTU(I,K) + wrk * (wrk1*SBU0 + FX1*SBU1) + GTV (I,K) = GTV(I,K) + wrk * (wrk1*SBV0 + FX1*SBV1) + + GTLSBH(I,K) = GTQLCI + GTISBH(I,K) = GTQICI +! +! SBC0 = GMFLX(I,K+1) * (GDQ(I,KP,IMU2)-GDQ(I,K,IMU2)) +! SBS0 = GMFLX(I,K+1) * (GDQ(I,KP,IMU3)-GDQ(I,K,IMU3)) +! SBC1 = GMFLX(I,K) * (GDQ(I,K,IMU2)-GDQ(I,KM,IMU2)) +! SBS1 = GMFLX(I,K) * (GDQ(I,K,IMU3)-GDQ(I,KM,IMU3)) +! GTM2CI = GRAV/DELP(I,K) +! & *(( one-FX(I))*SBC0 + FX1 *SBC1) +! GTM3CI = GRAV/DELP(I,K) +! & *((one-FX(I))*SBS0 + FX1 *SBS1) +! GTQ(I,K,IMU2) = GTQ(I,K,IMU2) + GTM2CI +! GTQ(I,K,IMU3) = GTQ(I,K,IMU3) + GTM3CI +! + FX(I) = FX1 + enddo + enddo +! + END SUBROUTINE CUMSBH +!*********************************************************************** +! + SUBROUTINE CUMDWN & ! Freeze & Melt & Evaporation + ( IM , IJSDIM, KMAX , NTR , & !DD dimensions + GTT , GTQ , GTU , GTV , & ! modified + GMFLX , & ! modified +! GTQI , GMFLX , & ! modified + GPRCP , GSNWP , GTEVP , GMDD , & ! output + GPRCI , GSNWI , & ! input + GDH , GDW , GDQ , GDQI , & ! input + GDQS , GDS , GDHS , GDT , & ! input + GDU , GDV , GDZ , & ! input + GDZM , GCYM , FDQS , DELP , & ! input + sigmad, do_aw , do_awdd , & !DDsigma input + gtmelt, gtevap, gtsubl, & !DDsigma input + dtdwn , dqvdwn, dqldwn, dqidwn, & !DDsigma input + KB , KTMX , ISTS , IENS ) ! input +! +! DD AW : modify to get eddy fluxes and microphysical tendencies for AW +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR ! DD, for GFS, pass in + logical, intent(in) :: do_aw, do_awdd +! +! [MODIFY] + REAL(r8) GTT (IJSDIM, KMAX) ! Temperature tendency + REAL(r8) GTQ (IJSDIM, KMAX, NTR) ! Moisture etc tendency + REAL(r8) GTU (IJSDIM, KMAX) ! u tendency + REAL(r8) GTV (IJSDIM, KMAX) ! v tendency +! REAL(r8) GTQI (IJSDIM, KMAX) ! cloud ice tendency + REAL(r8) GMFLX (IJSDIM, KMAX) ! mass flux +! +! [OUTPUT] + REAL(r8) GPRCP (IJSDIM, KMAX) ! rainfall flux + REAL(r8) GSNWP (IJSDIM, KMAX) ! snowfall flux + REAL(r8) GTEVP (IJSDIM, KMAX) ! evaporation+sublimation + REAL(r8) GMDD (IJSDIM, KMAX) ! downdraft mass flux + +!AW microphysical tendencies + REAL(r8) gtmelt (IJSDIM, KMAX) ! t tendency ice-liq + REAL(r8) gtevap (IJSDIM, KMAX) ! t tendency liq-vapor + REAL(r8) gtsubl (IJSDIM, KMAX) ! t tendency ice-vapor +!AW eddy flux tendencies + REAL(r8) dtdwn (IJSDIM, KMAX) ! t tendency downdraft detrainment + REAL(r8) dqvdwn (IJSDIM, KMAX) ! qv tendency downdraft detrainment + REAL(r8) dqldwn (IJSDIM, KMAX) ! ql tendency downdraft detrainment + REAL(r8) dqidwn (IJSDIM, KMAX) ! qi tendency downdraft detrainment +! AW downdraft area fraction (assumed zero for now) + REAL(r8) sigmad (IM,KMAX) !DDsigma cloud downdraft area fraction + +! [INPUT] + REAL(r8) GPRCI (IJSDIM, KMAX) ! rainfall generation + REAL(r8) GSNWI (IJSDIM, KMAX) ! snowfall generation + REAL(r8) GDH (IJSDIM, KMAX) ! moist static energy + REAL(r8) GDW (IJSDIM, KMAX) ! total water + REAL(r8) GDQ (IJSDIM, KMAX, NTR)! humidity etc + REAL(r8) GDQI (IJSDIM, KMAX) ! cloud ice + REAL(r8) GDQS (IJSDIM, KMAX) ! saturate humidity + REAL(r8) GDS (IJSDIM, KMAX) ! dry static energy + REAL(r8) GDHS (IJSDIM, KMAX) ! saturate moist static energy + REAL(r8) GDT (IJSDIM, KMAX) ! air temperature T + REAL(r8) GDU (IJSDIM, KMAX) ! u-velocity + REAL(r8) GDV (IJSDIM, KMAX) ! v-velocity + REAL(r8) GDZ (IJSDIM, KMAX) ! altitude + REAL(r8) GDZM (IJSDIM, KMAX+1) ! altitude (half lev) + REAL(r8) GCYM (IJSDIM, KMAX) ! norm. mass flux + REAL(r8) FDQS (IJSDIM, KMAX) + REAL(r8) DELP (IJSDIM, KMAX) + INTEGER KB (IJSDIM) + INTEGER KTMX, ISTS, IENS +! +! [INTERNAL WORK] +! Note: Some variables have 3-dimensions for the purpose of budget check. + REAL(r8) EVAPD (IJSDIM, KMAX) ! evap. in downdraft + REAL(r8) SUBLD (IJSDIM, KMAX) ! subl. in downdraft + REAL(r8) EVAPE (IJSDIM, KMAX) ! evap. in environment + REAL(r8) SUBLE (IJSDIM, KMAX) ! subl. in environment + REAL(r8) EVAPX (IJSDIM, KMAX) ! evap. env. to DD + REAL(r8) SUBLX (IJSDIM, KMAX) ! subl. env. to DD + REAL(r8) GMDDE (IJSDIM, KMAX) ! downdraft entrainment + REAL(r8) SNMLT (IJSDIM, KMAX) ! melt - freeze + REAL(r8) GCHDD (IJSDIM, KMAX) ! MSE detrainment + REAL(r8) GCWDD (IJSDIM, KMAX) ! water detrainment + REAL(r8) GTTEV (IJSDIM, KMAX) ! T tendency by evaporation + REAL(r8) GTQEV (IJSDIM, KMAX) ! q tendency by evaporation + REAL(r8) GCHD (ISTS:IENS) ! downdraft MSE + REAL(r8) GCWD (ISTS:IENS) ! downdraft q +! profiles of downdraft variables for AW flux tendencies + REAL(r8) GCdseD(ISTS:IENS, KMAX) ! downdraft dse + REAL(r8) GCqvD (ISTS:IENS, KMAX) ! downdraft qv + REAL(r8) GCqlD (ISTS:IENS, KMAX) ! downdraft ql + REAL(r8) GCqiD (ISTS:IENS, KMAX) ! downdraft qi + + REAL(r8) GCUD (ISTS:IENS) ! downdraft u + REAL(r8) GCVD (ISTS:IENS) ! downdraft v + REAL(r8) FSNOW (ISTS:IENS) + REAL(r8) GMDDD (ISTS:IENS) + + REAL(r8) GDTW, GCHX, GCTX, GCQSX, GTPRP, EVSU, GTEVE, LVIC, & + DQW, DTW, GDQW, DZ, GCSD, FDET, GDHI, GMDDX, & + GMDDMX, GCHDX, GCWDX, GCUDD, GCVDD, GTHCI, GTQVCI, & + GTQLCI, GTQICI, wrk, wrk1, wrk2, wrk3, wrk4, & + WMX, HMX, DDWMX, DDHMX, dp_above, dp_below, fsigma, & + fmelt, fevp + +!M REAL(r8) GTHCI, GTQVCI, GTQLCI, GTQICI, GTUCI, GTVCI +!DD#ifdef OPT_CUMBGT +! Water, energy, downdraft water and downdraft energy budgets + REAL(r8), dimension(ISTS:IENS) :: WBGT, HBGT, DDWBGT, DDHBGT, tx1 + integer ij, i, k, kp1 +!DD#endif +! +! [INTERNAL PARM] + REAL(r8), parameter :: TWSNOW = 273.15_r8 ! wet-bulb temp. rain/snow + REAL(r8), parameter :: FTMLT = 4._r8 ! temp. factor for melt + REAL(r8), parameter :: GMFLXC = 5.e-2_r8 ! critical mass flux + REAL(r8), parameter :: VTERMS = 2._r8 ! terminal velocity of snowflake + REAL(r8), parameter :: MELTAU = 10._r8 ! melting timescale +! + REAL(r8), parameter :: EVAPR = 0.3_r8 ! evaporation factor +! REAL(r8), parameter :: EVAPR = 0._r8 ! evaporation factor + REAL(r8), parameter :: REVPDD = 1._r8 ! max rate of DD to evapolation + REAL(r8), parameter :: RDDR = 5.e-4_r8 ! DD rate (T0 R0 W0)^-1 +! REAL(r8), parameter :: RDDR = 0._r8 ! DD rate (T0 R0 W0)^-1 + REAL(r8), parameter :: RDDMX = 0.5_r8 ! norm. flux of downdraft + REAL(r8), parameter :: VTERM = 5._r8 ! term. vel. of precip. + REAL(r8), parameter :: EVATAU = 2._r8 ! evaporation/sublimation timescale + REAL(r8), parameter :: ZDMIN = 5.e2_r8 ! min altitude of downdraft detrainment + real(r8), parameter :: evapovtrm=EVAPR/VTERM + +!NOTE +! downdraft area ffraction still needs to be computed for AW, assumed zero for now, +! as passed in. + +! +! Note: It is assumed that condensate evaporates in downdraft air. +! + do k=1,kmax + do i=ists,iens + GPRCP (I,k) = zero + GSNWP (I,k) = zero + GMDD (I,k) = zero + GTEVP (I,k) = zero + EVAPD (I,k) = zero + SUBLD (I,k) = zero + EVAPE (I,k) = zero + SUBLE (I,k) = zero + EVAPX (I,k) = zero + SUBLX (I,k) = zero + GMDDE (I,k) = zero + SNMLT (I,k) = zero + GCHDD (I,k) = zero + GCWDD (I,k) = zero + GTTEV (I,k) = zero + GTQEV (I,k) = zero + GCdseD(I,k) = zero + GCqvD (I,k) = zero + GCqlD (I,k) = zero + GCqiD (I,k) = zero + gtevap(I,k) = zero + gtmelt(I,k) = zero + gtsubl(I,k) = zero + enddo + enddo +! testing on oct 17 2016 + if (do_aw) then + if (.not. do_awdd) then + do k=1,kmax + do i=ists,iens + dtdwn (i,k) = gtt(i,k) + dqvdwn(i,k) = gtq(i,k,1) + dqldwn(i,k) = gtq(i,k,itl) + dqidwn(i,k) = gtq(i,k,iti) + enddo + enddo + else + do k=1,kmax + do i=ists,iens + dtdwn (I,k) = zero + dqvdwn(I,k) = zero + dqldwn(I,k) = zero + dqidwn(I,k) = zero + enddo + enddo + endif + endif +! + do i=ists,iens + GCHD(I) = zero + GCWD(I) = zero + GCUD(I) = zero + GCVD(I) = zero + enddo +! + DO K=KTMX,1,-1 ! loop A + kp1 = min(k+1,kmax) +! +! < precipitation melt & freeze > +! + DO I=ISTS,IENS + GTPRP = GPRCP(I,KP1) + GSNWP(I,KP1) + IF (GTPRP > zero) THEN + FSNOW(I) = GSNWP(I,KP1) / GTPRP + ELSE + FSNOW(I) = zero + ENDIF + LVIC = ELocp + EMELTocp*FSNOW(I) + GDTW = GDT(I,K) - LVIC*(GDQS(I,K) - GDQ(I,K,1)) & + / (one + LVIC*FDQS(I,K)) + IF (GDTW < TWSNOW) THEN + GSNWP(I,K) = GSNWP(I,KP1) + GPRCI(I,K) + GSNWI(I,K) + GTTEV(I,K) = EMELToCP*GPRCI(I,K) * GRAV/DELP(I,K) + SNMLT(I,K) = -GPRCI(I,K) + ELSE + DZ = GDZM(I,KP1) - GDZM(I,K) + FMELT = (one + FTMLT*(GDTW - TWSNOW)) & + * (one - TANH(GMFLX(I,KP1)/GMFLXC)) & + * (one - TANH(VTERMS*MELTAU/DZ)) + SNMLT(I,K) = GSNWP(I,KP1)*max(min(FMELT, one), zero) + GSNWP(I,K) = GSNWP(I,KP1)+GSNWI(I,K) - SNMLT(I,K) + GPRCP(I,K) = GPRCP(I,KP1)+GPRCI(I,K) + SNMLT(I,K) + GTTEV(I,K) = -EMELToCP*SNMLT(I,K) * GRAV/DELP(I,K) + ENDIF +!DD heating rate due to precip melting for AW + gtmelt(i,k) = gtmelt(i,k) + GTTEV(I,K) + ENDDO +! +! < downdraft > +! + DO I=ISTS,IENS ! loop B + wrk = grav / delp(i,k) + wrk1 = oneocp * wrk + DZ = GDZM(I,KP1) - GDZM(I,K) + FEVP = (one - TANH(EVATAU*VTERM/DZ)) + IF (GMDD(I,KP1) > zero) THEN + GCHX = GCHD(I) / GMDD(I,KP1) + GCTX = GDT(I,K) + (GCHX-GDHS(I,K)) / (CP+EL*FDQS(I,K)) + GCQSX = GDQS(I,K) + FDQS(I,K) * (GCTX - GDT(I,K)) + GCQSX = GCQSX*GMDD(I,KP1) + EVSU = MAX(GCQSX-GCWD(I), zero) * FEVP + GTPRP = GPRCP(I,K) + GSNWP(I,K) + IF (GTPRP > zero) THEN + FSNOW(I) = GSNWP(I,K) / GTPRP + ELSE + FSNOW(I) = zero + ENDIF + EVAPD(I,K) = min(EVSU*(one-FSNOW(I)), GPRCP(I,K)) + SUBLD(I,K) = min(EVSU*FSNOW(I), GSNWP(I,K)) + GPRCP(I,K) = GPRCP(I,K) - EVAPD(I,K) + GSNWP(I,K) = GSNWP(I,K) - SUBLD(I,K) +! temperature tendencies due to evaporation and sublimation of precip +! This is within downdraft + gtevap(i,k) = gtevap(i,k) - elocp * evapd(i,k) * wrk + gtsubl(i,k) = gtsubl(i,k) - esubocp * subld(i,k) * wrk + GCWD(I) = GCWD(I) + EVAPD(I,K) + SUBLD(I,K) + GCHD(I) = GCHD(I) - EMELT*SUBLD(I,K) + ENDIF + + GMDD(I,K) = GMDD(I,KP1) +! + LVIC = ELocp + EMELTocp*FSNOW(I) + DQW = (GDQS(I,K) - GDW(I,K)) / (one + LVIC*FDQS(I,K)) + DQW = MAX(DQW, zero) + DTW = LVIC*DQW + GDQW = GDW(I,K) + DQW*FEVP +! + EVSU = min(one, EVAPOVTRM*DQW*DZ*FEVP) + EVAPE(I,K) = EVSU*GPRCP(I,K) + SUBLE(I,K) = EVSU*GSNWP(I,K) + GTEVP(I,K) = EVAPD(I,K) + SUBLD(I,K) + EVAPE(I,K) + SUBLE(I,K) +! + GTPRP = GPRCP(I,K) + GSNWP(I,K) + GPRCP(I,K) = GPRCP(I,K) - EVAPE(I,K) + GSNWP(I,K) = GSNWP(I,K) - SUBLE(I,K) +! additional temperature tendencies due to evaporation and sublimation of precip +! This is outside of downdraft + gtevap(i,k) = gtevap(i,k) - el*evape(i,k) * wrk1 + gtsubl(i,k) = gtsubl(i,k) - (el+emelt)*suble(i,k) * wrk1 +! + GMDDD(I) = zero + IF (GDZ(I,K)-GDZM(I,1) > ZDMIN) THEN + GTEVE = EVAPE(I,K) + SUBLE(I,K) + GMDDMX = REVPDD*GTEVE/MAX(DQW, 1.D-10) + GMDDE(I,K) = RDDR * (DTW*GTPRP*DELP(I,K)) + GMDDE(I,K) = MAX(MIN(GMDDE(I,K), GMDDMX), zero) + GMDDX = GMDD(I,KP1) + GMDDE(I,K) + EVSU = GMDDE(I,K)*DQW*FEVP + IF (GTEVE > zero) THEN + FSNOW(I) = SUBLE(I,K) / GTEVE + ELSE + FSNOW(I) = zero + END IF + EVAPX(I,K) = (one-FSNOW(I)) * EVSU + SUBLX(I,K) = FSNOW(I) * EVSU +! + IF (GMDDX > zero) THEN + GDHI = GDH(I,K) - EMELT*GDQI(I,K) + GCHDX = GCHD(I) + GDHI*GMDDE(I,K) - EMELT*SUBLX(I,K) + GCWDX = GCWD(I) + GDQW*GMDDE(I,K) + GCSD = (GCHDX - EL*GCWDX) / GMDDX + IF (GCSD < GDS(I,K)) THEN + GCHD(I) = GCHDX + GCWD(I) = GCWDX + GCUD(I) = GCUD(I) + GDU(I,K)*GMDDE(I,K) + GCVD(I) = GCVD(I) + GDV(I,K)*GMDDE(I,K) + GMDD(I,K) = GMDDX + EVAPE(I,K) = EVAPE(I,K) - EVAPX(I,K) + SUBLE(I,K) = SUBLE(I,K) - SUBLX(I,K) + EVAPD(I,K) = EVAPD(I,K) + EVAPX(I,K) + SUBLD(I,K) = SUBLD(I,K) + SUBLX(I,K) + GMDDD(I) = zero + ELSE + GMDDE(I,K) = zero + GMDDD(I) = GMDD(I,KP1) + ENDIF + ENDIF + ELSE + GMDDD(I) = DZ / (GDZM(I,KP1)-GDZM(I,1)) * GMDD(I,KP1) + ENDIF +! + GMDDD(I) = MAX(GMDDD(I), GMDD(I,K)-RDDMX*GMFLX(I,K)) +! + IF (GMDDD(I) > zero) THEN + FDET = GMDDD(I)/GMDD(I,K) + GCHDD(I,K) = FDET*GCHD(I) + GCWDD(I,K) = FDET*GCWD(I) + GCUDD = FDET*GCUD(I) + GCVDD = FDET*GCVD(I) +! + GTHCI = wrk * (GCHDD(I,K) - GMDDD(I)*GDH(I,K)) + GTQVCI = wrk * (GCWDD(I,K) - GMDDD(I)*GDQ(I,K,1)) + GTQLCI = -wrk * GMDDD(I)*GDQ(I,K,ITL) + GTQICI = -wrk * GMDDD(I)*GDQI(I,K) +! + GTT (I,K) = GTT(I,K) + (GTHCI - EL*GTQVCI)*oneoCP + GTQ (I,K,1) = GTQ(I,K,1) + GTQVCI + GTQ (I,K,ITL) = GTQ(I,K,ITL) + GTQLCI + GTQ (I,K,ITI) = GTQ(I,K,ITI) + GTQICI +! GTQI(I,K) = GTQI(I,K) + GTQICI + + GTU (I,K) = GTU(I,K) + wrk * (GCUDD - GMDDD(I)*GDU(I,K)) + GTV (I,K) = GTV(I,K) + wrk * (GCVDD - GMDDD(I)*GDV(I,K)) +! + GCHD(I) = GCHD(I) - GCHDD(I,K) + GCWD(I) = GCWD(I) - GCWDD(I,K) + GCUD(I) = GCUD(I) - GCUDD + GCVD(I) = GCVD(I) - GCVDD + GMDD(I,K) = GMDD(I,K) - GMDDD(I) + ENDIF + GCdseD(I,K) = GCHD(I) - el*GCWD(I) + GCqvD (I,K) = GCWD(I) + ENDDO ! loop B +! + ENDDO ! loop A +! + do i=ists,iens + tx1(i) = GRAV / DELP(I,1) + enddo + DO K=1,KTMX + kp1 = min(k+1,kmax) + DO I=ISTS,IENS + wrk = tx1(i) + tx1(i) = GRAV / DELP(I,kp1) + + GTTEV(I,K) = GTTEV(I,K) - wrk & + * (ELocp*EVAPE(I,K)+(ELocp+EMELTocp)*SUBLE(I,K)) + GTT(I,K) = GTT(I,K) + GTTEV(I,K) +! + GTQEV(I,K) = GTQEV(I,K) + (EVAPE(I,K)+SUBLE(I,K)) * wrk + GTQ(I,K,1) = GTQ(I,K,1) + GTQEV(I,K) +! + GMFLX(I,K) = GMFLX(I,K) - GMDD(I,K) + +! AW tendencies due to vertical divergence of eddy fluxes + if (do_awdd .and. k > 1) then + fsigma = one - sigmad(i,kp1) + dp_below = wrk * (one - sigmad(i,k)) + dp_above = tx1(i) * (one - sigmad(i,kp1)) + + wrk1 = gmdd(i,kp1) * (gdt(i,k)+gocp*gdz(i,k)) - gcdsed(i,kp1)*oneocp + wrk2 = gmdd(i,kp1) * gdq(i,k,1) - gcqvd(i,kp1) + wrk3 = gmdd(i,kp1) * gdq(i,k,itl) + wrk4 = gmdd(i,kp1) * gdqi(i,k) + + dtdwn(i,k) = dtdwn(i,k) + dp_below * wrk1 + dqvdwn(i,k) = dqvdwn(i,k) + dp_below * wrk2 + dqldwn(i,k) = dqldwn(i,k) + dp_below * wrk3 ! gcqld=0 - gcqld(i,k)) + dqidwn(i,k) = dqidwn(i,k) + dp_below * wrk4 ! gcqid=0 - gcqid(i,k)) + + dtdwn(i,kp1) = dtdwn(i,kp1) - dp_above * wrk1 + dqvdwn(i,kp1) = dqvdwn(i,kp1) - dp_above * wrk2 + dqldwn(i,kp1) = dqldwn(i,kp1) - dp_above * wrk3 ! gcqld=0 - gcqld(i,k)) + dqidwn(i,kp1) = dqidwn(i,kp1) - dp_above * wrk4 ! gcqid=0 - gcqid(i,k)) + endif + + ENDDO ! end of i loop + ENDDO ! end of k loop +! + if (.not. do_awdd) then + do k=1,kmax + do i=ists,iens + dtdwn(i,k) = gtt(i,k) - dtdwn(i,k) + dqvdwn(i,k) = gtq(i,k,1) - dqvdwn(i,k) + dqldwn(i,k) = gtq(i,k,itl) - dqldwn(i,k) + dqidwn(i,k) = gtq(i,k,iti) - dqidwn(i,k) +!! dqidwn(i,k) = gtqi(i,k) - dqidwn(i,k) + enddo + enddo + endif +! + END SUBROUTINE CUMDWN +!*********************************************************************** + SUBROUTINE CUMCLD & !! cloudiness + ( IJSDIM, KMAX , & !DD dimensions + CUMCLW, QLIQ , QICE , FLIQC , & ! modified + CUMFRC, & ! output + GMFLX , KTMX , ISTS, IENS ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in +! +! [OUTPUT] + REAL(r8) CUMFRC(IJSDIM) ! cumulus cloud fraction +! +! [MODIFY] + REAL(r8) CUMCLW(IJSDIM, KMAX) ! cloud water in cumulus + REAL(r8) QLIQ (IJSDIM, KMAX) ! cloud liquid + REAL(r8) QICE (IJSDIM, KMAX) ! cloud ice + REAL(r8) FLIQC (IJSDIM, KMAX) ! liquid ratio in cumulus +! +! [INPUT] + REAL(r8) GMFLX (IJSDIM, KMAX) ! cumulus mass flux + INTEGER KTMX + INTEGER ISTS, IENS +! +! [WORK] + INTEGER I, K + REAL(r8) CUMF, QC, wrk + LOGICAL, SAVE :: OFIRST = .TRUE. +! +! [INTERNAL PARAM] + REAL(r8) :: FACLW = 0.1_r8 ! Mc->CLW + REAL(r8) :: CMFMIN = 2.e-3_r8 ! Mc->cloudiness + REAL(r8) :: CMFMAX = 3.e-1_r8 ! Mc->cloudiness + REAL(r8) :: CLMIN = 1.e-3_r8 ! cloudiness Min. + REAL(r8) :: CLMAX = 0.1_r8 ! cloudiness Max. + REAL(r8), SAVE :: FACLF +! + IF (OFIRST) THEN + FACLF = (CLMAX-CLMIN) / LOG(CMFMAX/CMFMIN) + OFIRST = .FALSE. + END IF +! + CUMFRC(ISTS:IENS) = zero + DO K=1,KTMX + DO I=ISTS,IENS + CUMFRC(I) = MAX(CUMFRC(I), GMFLX(I,K)) + ENDDO + ENDDO + DO I=ISTS,IENS + IF (CUMFRC(I) > zero) THEN + CUMF = LOG(MAX(CUMFRC(I), CMFMIN)/CMFMIN) + CUMFRC(I) = MIN(FACLF*CUMF+CLMIN, CLMAX) + ENDIF + ENDDO +! + DO K=1,KTMX + DO I=ISTS,IENS + IF (GMFLX(I,K) > zero) THEN + wrk = FACLW / GMFLX(I,K) * CUMFRC(I) + QLIQ (I,K) = wrk * QLIQ(I,K) + QICE (I,K) = wrk * QICE(I,K) + CUMCLW(I,K) = wrk * CUMCLW(I,K) + QC = QLIQ(I,K) + QICE(I,K) + IF (QC > zero) THEN + FLIQC(I,K) = QLIQ(I,K) / QC + ENDIF + ENDIF + ENDDO + ENDDO +! + END SUBROUTINE CUMCLD +!*********************************************************************** + SUBROUTINE CUMUPR & !! Tracer Updraft + ( im , IJSDIM, KMAX , NTR , & !DD dimensions + GTR , GPRCC , & ! modified + GDR , CBMFX , ELAM , GDZ , GDZM , & ! input + GCYM , GCYT , GCQT , GCLT , GCIT , & ! input + GTPRT , GTEVP , GTPRC0, & ! input + KB , KBMX , KT , KTMX , KTMXT , & ! input + DELP , OTSPT , ISTS , IENS, & ! input + fscav, fswtr, nctp) +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: im, IJSDIM, KMAX, NTR, nctp !! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTR (IJSDIM, KMAX, NTR) + REAL(r8) GPRCC (IJSDIM, NTR) +! +! [INPUT] + REAL(r8) GDR (IJSDIM, KMAX, NTR) + REAL(r8) CBMFX (IM, NCTP) + REAL(r8) ELAM (IJSDIM, KMAX, NCTP) + REAL(r8) GDZ (IJSDIM, KMAX) + REAL(r8) GDZM (IJSDIM, KMAX+1) + REAL(r8) GCYM (IJSDIM, KMAX) + REAL(r8) GCYT (IJSDIM, NCTP) + REAL(r8) GCQT (IJSDIM, NCTP) + REAL(r8) GCLT (IJSDIM, NCTP) + REAL(r8) GCIT (IJSDIM, NCTP) + REAL(r8) GTPRT (IJSDIM, NCTP) + REAL(r8) GTEVP (IJSDIM, KMAX) + REAL(r8) GTPRC0(IJSDIM) !! precip. before evap. + real(r8) fscav(ntr), fswtr(ntr) + INTEGER KB (IJSDIM ) + INTEGER KBMX + INTEGER KT (IJSDIM, NCTP) + INTEGER KTMX (NCTP) + INTEGER KTMXT + REAL(r8) DELP (IJSDIM, KMAX) + LOGICAL OTSPT (NTR) !! transport with this routine? + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + INTEGER I, K, LT, TP, CTP + REAL(r8) :: GCRTD, SCAV, GCWT, GPRCR, evpf, cbmfxl + REAL(r8), dimension(ists:iens) :: GCRB, GCRT, DR, gtprc0i +! REAL(r8), dimension(ists:iens,kmax) :: DGCB, DZ, RDZM, EVPF + REAL(r8), dimension(ists:iens,kmax) :: DZ, RDZM +! REAL(r8), dimension(ists:iens,nctp) :: DZT, RGCWT, MASK1, MASK2 + REAL(r8), dimension(ists:iens,nctp) :: DZT, RGCWT, MASK1 +! +! DO K=1,KBMX +! DO I=ISTS,IENS +! DGCB(I,K) = GCYM(I,K+1) - GCYM(I,K) +! ENDDO +! ENDDO + do i=ists,iens + if (gtprc0(i) > zero) then + gtprc0i(i) = one / gtprc0(i) + else + gtprc0i(i) = zero + endif + enddo + DO K=1,KTMXT + DO I=ISTS,IENS + DZ (I,K) = GDZM(I,K+1) - GDZM(I,K) + RDZM(I,K) = GRAV / DELP(I,K) +! EVPF(I,K) = zero +! IF (GTPRC0(I) > zero) THEN +! EVPF(I,K) = GTEVP(I,K) / GTPRC0(I) +! ENDIF + ENDDO + ENDDO + DO CTP=1,NCTP + DO I=ISTS,IENS + K = KT(I,CTP) +! + GCWT = GCQT(I,CTP) + GCLT(I,CTP) + GCIT(I,CTP) + RGCWT(I,CTP) = zero + IF (GCWT > zero) THEN + RGCWT(I,CTP) = one / GCWT + ENDIF +! + MASK1(I,CTP) = zero + DZT (I,CTP) = zero + IF (K > KB(I)) THEN + MASK1(I,CTP) = one + DZT (I,CTP) = GDZ(I,K) - GDZM(I,K) + ENDIF +! MASK2(I,CTP) = zero +! IF (CBMFX(I,CTP) > zero) then +! MASK2(I,CTP) = one +! ENDIF + ENDDO + ENDDO +! + DO LT=1,NTR ! outermost tracer LT loop +! + IF (OTSPT(LT)) THEN + GCRB = zero + DO K=1,KBMX + DO I=ISTS,IENS + IF (K < KB(I)) THEN +! GCRB(I) = GCRB(I) + DGCB(I,K) * GDR(I,K,LT) + GCRB(I) = GCRB(I) + (GCYM(I,K+1)-GCYM(I,K))* GDR(I,K,LT) + ENDIF + ENDDO + ENDDO +! + DO CTP=1,NCTP + DR = zero + DO K=2,KTMX(CTP) + DO I=ISTS,IENS + IF (K >= KB(I) .AND. K < KT(I,CTP)) THEN + DR(I) = DR(I) + DZ(I,K) * ELAM(I,K,CTP) * GDR(I,K,LT) + ENDIF + ENDDO + ENDDO +! + DO I=ISTS,IENS + K = MAX(KT(I,CTP),1) + DR(I) = DR(I) + DZT(I,CTP) * ELAM(I,K,CTP) * GDR (I,K,LT) & + * MASK1(I,CTP) + GCRT(I) = (GCRB(I) + DR(I)) * MASK1(I,CTP) +! + SCAV = FSCAV(LT)*GTPRT(I,CTP) + FSWTR(LT)*GTPRT(I,CTP)*RGCWT(I,CTP) + SCAV = MIN(SCAV, one) + GCRTD = GCRT(I) * (one - SCAV) + cbmfxl = max(zero, CBMFX(I,CTP)) + GPRCR = SCAV * GCRT(I) * CBMFXl + + GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * CBMFXl & + * (GCRTD - GCYT(I,CTP) * GDR(I,K,LT)) + GPRCC(I,LT) = GPRCC(I,LT) + GPRCR + +! GPRCR = SCAV * GCRT(I) * CBMFX(I,CTP) +! GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * CBMFX(I,CTP) & +! * (GCRTD - GCYT(I,CTP) * GDR(I,K,LT)) * MASK2(I,CTP) +! GPRCC(I,LT) = GPRCC(I,LT) + GPRCR * MASK2(I,CTP) + ENDDO + ENDDO +! + DO K=KTMXT,1,-1 + DO I=ISTS,IENS + evpf = GTEVP(i,k) * gtprc0i(i) + GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * GPRCC(I,LT) * EVPF + GPRCC(I,LT) = GPRCC(I,LT) * (one - EVPF) +! GTR(I,K,LT) = GTR(I,K,LT) + RDZM(I,K) * GPRCC(I,LT) * EVPF(I,K) +! GPRCC(I,LT) = GPRCC(I,LT) * (one - EVPF(I,K)) + ENDDO + ENDDO +! + ENDIF +! + ENDDO ! outermost tracer LT loop +! + END SUBROUTINE CUMUPR +!*********************************************************************** + SUBROUTINE CUMDNR & !! Tracer Downdraft + ( IM , IJSDIM, KMAX , NTR , & !DD dimensions + GTR , & ! modified + GDR , GMDD , DELP , & ! input + KTMX , OTSPT , ISTS , IENS ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR !! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTR (IJSDIM, KMAX, NTR) ! Temperature tendency +! +! [INPUT] + REAL(r8) GDR (IJSDIM, KMAX, NTR) + REAL(r8) GMDD (IJSDIM, KMAX) ! downdraft mass flux + REAL(r8) DELP (IJSDIM, KMAX ) + LOGICAL OTSPT (NTR) + INTEGER KTMX, ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8) GCRD (ISTS:IENS) ! downdraft q + REAL(r8) GMDDE, GMDDD, GCRDD + INTEGER I, K, LT, kp1 +! +! + DO LT=1,NTR + IF (OTSPT(LT)) THEN + GCRD = zero + DO K=KTMX,1,-1 + kp1 = min(k+1,kmax) + DO I=ISTS,IENS + GMDDE = GMDD(I,K) - GMDD(I,KP1) + IF (GMDDE >= zero) THEN + GCRD(I) = GCRD(I) + GDR(I,K,LT)*GMDDE + ELSEIF (GMDD(I,KP1) > zero) THEN + GMDDD = - GMDDE + GCRDD = GMDDD/GMDD(I,KP1) * GCRD(I) + GTR(I,K,LT) = GTR(I,K,LT) + GRAV/DELP(I,K) & + * (GCRDD - GMDDD*GDR(I,K,LT)) + GCRD(I) = GCRD(I) - GCRDD + ENDIF + ENDDO + ENDDO + ENDIF + ENDDO +! + END SUBROUTINE CUMDNR +!*********************************************************************** + SUBROUTINE CUMSBR & !! Tracer Subsidence + ( IM , IJSDIM, KMAX , NTR , & !DD dimensions + GTR , & ! modified + GDR , DELP , & ! input + GMFLX , KTMX , OTSPT , & ! input + ISTS, IENS ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR !! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTR (IJSDIM, KMAX, NTR) !! tracer tendency +! +! [INPUT] + REAL(r8) GDR (IJSDIM, KMAX, NTR) !! tracer + REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) GMFLX (IJSDIM, KMAX) !! mass flux + INTEGER KTMX + LOGICAL OTSPT (NTR) !! tracer transport on/off + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + INTEGER I, K, KM, KP, LT + REAL(r8) SBR0, SBR1, FX1 + REAL(r8) FX(ISTS:IENS) +! + DO LT=1,NTR + IF (OTSPT(LT)) THEN + DO I=ISTS,IENS + FX(I) = zero + enddo + DO K=KTMX,1,-1 + KM = MAX(K-1, 1) + KP = MIN(K+1, KMAX) + DO I=ISTS,IENS + SBR0 = GMFLX(I,KP) * (GDR(I,KP,LT) - GDR(I,K,LT)) + SBR1 = GMFLX(I,K) * (GDR(I,K,LT) - GDR(I,KM,LT)) + IF (GMFLX(I,K) > GMFLX(I,KP)) THEN + FX1 = half + ELSE + FX1 = zero + END IF + GTR(I,K,LT) = GTR(I,K,LT) + GRAV/DELP(I,K) & + * ((one-FX(I))*SBR0 + FX1*SBR1) + FX(I) = FX1 + ENDDO + ENDDO + ENDIF + ENDDO +! + END SUBROUTINE CUMSBR +!********************************************************************* + SUBROUTINE CUMFXR & ! Tracer mass fixer + ( IM , IJSDIM, KMAX , NTR , & !DD dimensions + GTR , & ! modified + GDR , DELP , DELTA , KTMX , IMFXR , & ! input + ISTS , IENS ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX, NTR !! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTR (IJSDIM, KMAX, NTR) ! tracer tendency +! +! [INPUT] + REAL(r8) GDR (IJSDIM, KMAX, NTR) ! tracer + REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELTA ! time step + INTEGER KTMX + INTEGER IMFXR (NTR) + ! 0: mass fixer is not applied + ! tracers which may become negative values + ! e.g. subgrid-PDFs + ! 1: mass fixer is applied, total mass may change through cumulus scheme + ! e.g. moisture, liquid cloud, ice cloud, aerosols + ! 2: mass fixer is applied, total mass never change through cumulus scheme + ! e.g. CO2 + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8) GDR1 + REAL(r8) GDR2 (ISTS:IENS, KMAX) + REAL(r8), dimension(ISTS:IENS) :: TOT0, TOT1, TRAT + REAL(r8) FWAT + INTEGER I, K, LT +! +! Attention: tracers are forced to be positive unless IMFXR=0. +! + DO LT=1,NTR + SELECT CASE (IMFXR(LT)) + CASE (0) + CYCLE + CASE (1) + FWAT = one + CASE (2) + FWAT = zero + CASE DEFAULT + EXIT + END SELECT +! + DO I=ISTS,IENS + TOT0(I) = zero + TOT1(I) = zero + enddo +! + DO K=KTMX,1,-1 + DO I=ISTS,IENS + IF (GTR(I,K,LT) /= zero) THEN + GDR1 = GDR(I,K,LT) + DELTA*GTR(I,K,LT) + GDR2(I,K) = MAX(GDR1, zero) + GDR1 = GDR1 * FWAT + GDR(I,K,LT)*(one - FWAT) + TOT0(I) = TOT0(I) + GDR1 *(DELP(I,K)*GRAVI) + TOT1(I) = TOT1(I) + GDR2(I,K)*(DELP(I,K)*GRAVI) + ENDIF + ENDDO + ENDDO +! + DO I=ISTS,IENS + IF (TOT1(I) > zero ) THEN + TRAT(I) = MAX(TOT0(I), zero) / TOT1(I) + ELSE + TRAT(I) = one + ENDIF + ENDDO +! + DO K=KTMX,1,-1 + DO I=ISTS,IENS + IF (GTR(I,K,LT) /= zero ) THEN + GDR2(I,K ) = GDR2(I,K)*TRAT(I) + GTR (I,K,LT) = (GDR2(I,K)-GDR(I,K,LT)) / DELTA + ENDIF + ENDDO + ENDDO +! + ENDDO ! LT-loop +! + END SUBROUTINE CUMFXR +!********************************************************************* + SUBROUTINE CUMFXR1 & ! Tracer mass fixer + ( IM , IJSDIM, KMAX , & !DD dimensions + GTR , & ! modified + GDR , DELP , DELTA , KTMX , IMFXR , & ! input + ISTS , IENS ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IM, IJSDIM, KMAX ! DD, for GFS, pass in +! +! [MODIFY] + REAL(r8) GTR (IJSDIM, KMAX) ! tracer tendency +! +! [INPUT] + REAL(r8) GDR (IJSDIM, KMAX) ! tracer + REAL(r8) DELP (IJSDIM, KMAX) + REAL(r8) DELTA ! time step + INTEGER KTMX + INTEGER IMFXR + ! 0: mass fixer is not applied + ! tracers which may become negative values + ! e.g. subgrid-PDFs + ! 1: mass fixer is applied, total mass may change through cumulus scheme + ! e.g. moisture, liquid cloud, ice cloud, aerosols + ! 2: mass fixer is applied, total mass never change through cumulus scheme + ! e.g. CO2 + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + REAL(r8) GDR1 + REAL(r8) GDR2 (ISTS:IENS, KMAX) + REAL(r8), dimension(ISTS:IENS) :: TOT0, TOT1, TRAT + REAL(r8) FWAT + INTEGER I, K +! +! Attention: tracers are forced to be positive unless IMFXR=0. +! + SELECT CASE (IMFXR) + CASE (0) + RETURN + CASE (1) + FWAT = one + CASE (2) + FWAT = zero + CASE DEFAULT + RETURN + END SELECT +! + DO I=ISTS,IENS + TOT0(I) = zero + TOT1(I) = zero + enddo +! + DO K=KTMX,1,-1 + DO I=ISTS,IENS + IF (GTR(I,K) /= zero) THEN + GDR1 = GDR(I,K) + DELTA*GTR(I,K) + GDR2(I,K) = MAX(GDR1, zero) + GDR1 = GDR1*FWAT + GDR(I,K)*(one - FWAT) + TOT0(I) = TOT0(I) + GDR1 *(DELP(I,K)*GRAVI) + TOT1(I) = TOT1(I) + GDR2(I,K)*(DELP(I,K)*GRAVI) + ENDIF + ENDDO + ENDDO +! + DO I=ISTS,IENS + IF (TOT1(I) > zero) THEN + TRAT(I) = MAX(TOT0(I), zero) / TOT1(I) + ELSE + TRAT(I) = one + ENDIF + ENDDO +! + DO K=KTMX,1,-1 + DO I=ISTS,IENS + IF (GTR(I,K) /= zero) THEN + GDR2(I,K) = GDR2(I,K)*TRAT(I) + GTR (I,K) = (GDR2(I,K)-GDR(I,K)) / DELTA + ENDIF + ENDDO + ENDDO +! + END SUBROUTINE CUMFXR1 +!********************************************************************* + SUBROUTINE CUMCHK & ! check range of output values + ( IJSDIM, KMAX , NTR , & !DD dimensions + GTT , GTQ , GTU , GTV , & ! input + GTCFRC, GPRCC , GSNWC , CUMCLW, & ! input + CUMFRC, FLIQC , GTPRP , & ! input + ISTS , IENS ) ! input +! + IMPLICIT NONE + + INTEGER, INTENT(IN) :: IJSDIM, KMAX, NTR ! DD, for GFS, pass in +! +! [INPUT] + REAL(r8) GTT (IJSDIM, KMAX) ! heating rate + REAL(r8) GTQ (IJSDIM, KMAX, NTR) ! change in q + REAL(r8) GTU (IJSDIM, KMAX) ! tendency of u + REAL(r8) GTV (IJSDIM, KMAX) ! tendency of v + REAL(r8) GPRCC (IJSDIM, NTR ) ! rainfall + REAL(r8) GSNWC (IJSDIM) ! snowfall + REAL(r8) CUMCLW(IJSDIM, KMAX) ! cloud water in cumulus + REAL(r8) CUMFRC(IJSDIM) ! cumulus cloud fraction + REAL(r8) GTCFRC(IJSDIM, KMAX) ! change in cloud fraction + REAL(r8) FLIQC (IJSDIM, KMAX) ! liquid ratio in cumulus + REAL(r8) GTPRP (IJSDIM, KMAX) ! rain+snow flux +! + INTEGER ISTS, IENS +! +! [INTERNAL WORK] + INTEGER I, K +! +! [INTERNAL PARM] + REAL(r8) :: GTTMAX = 1.e-2_r8 + REAL(r8) :: GTQVMAX = 1.e-4_r8 + REAL(r8) :: GTQLMAX = 1.e-5_r8 + REAL(r8) :: GTUMAX = 1.e-2_r8 + REAL(r8) :: GTVMAX = 1.e-2_r8 + REAL(r8) :: GTCFMAX = 1.e-3_r8 + REAL(r8) :: PRCCMAX = 1.e-2_r8 + REAL(r8) :: SNWCMAX = 1.e-2_r8 + REAL(r8) :: CLWMAX = 1.e-3_r8 + REAL(r8) :: TPRPMAX = 1.e-2_r8 + REAL(r8) :: GTQIMAX = 1.e-5_r8 + REAL(r8) :: GTM2MAX = 1._r8 + REAL(r8) :: GTM3MAX = 1._r8 +! + DO K=1,KMAX + DO I=ISTS, IENS + IF (ABS(GTT(I,K)) > GTTMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTT(',I,',',K,')=',GTT(I,K) + ENDIF + IF (ABS(GTQ(I,K,1) ) > GTQVMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTQ(',I,',',K,',1 )=', GTQ(I,K,1) + ENDIF + IF (ABS(GTQ(I,K,ITL)) > GTQLMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTQ(',I,',',K,',ITL )=', GTQ(I,K,ITL) + ENDIF + IF (ABS(GTU(I,K)) > GTUMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTU(',I,',',K,')=',GTU(I,K) + END IF + IF (ABS(GTV(I,K)) > GTVMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTV(',I,',',K,')=',GTV(I,K) + ENDIF + IF (ABS(GTCFRC(I,K)) > GTCFMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTCFRC(',I,',',K,')=', GTCFRC(I,K) + ENDIF + IF (CUMCLW(I,K) > CLWMAX .OR. CUMCLW(I,K) < zero) THEN + WRITE(iulog,*) '### CUMCHK: CUMCLW(',I,',',K,')=', CUMCLW(I,K) + ENDIF + IF (FLIQC(I,K) > one .OR. FLIQC(I,K) < zero) THEN + WRITE(iulog,*) '### CUMCHK: FLIQC(',I,',',K,')=', FLIQC(I,K) + ENDIF + IF (GTPRP(I,K) > TPRPMAX .OR. GTPRP(I,K) < zero) THEN + WRITE(iulog,*) '### CUMCHK: GTPRP(',I,',',K,')=', GTPRP(I,K) + ENDIF + IF (ABS(GTQ(I,K,ITI)) > GTQIMAX) THEN + WRITE(iulog,*) '### CUMCHK: GTQ(',I,',',K,',ITI )=', GTQ(I,K,ITI) + ENDIF +! IF (ABS(GTQ(I,K,IMU2) ) > GTM2MAX) THEN +! WRITE(iulog,*) '### CUMCHK: GTQ(',I,',',K,',IMU2 )=', GTQ(I,K,IMU2) +! ENDIF +! IF (ABS(GTQ(I,K,IMU3)) > GTM3MAX) THEN +! WRITE(iulog,*) '### CUMCHK: GTQ(',I,',',K,',IMU3 )=', GTQ(I,K,IMU3) +! ENDIF + ENDDO + ENDDO +! + DO I=ISTS,IENS + IF (GPRCC(I,1) > PRCCMAX .OR. GPRCC(I,1) < zero) THEN + WRITE(iulog,*) '### CUMCHK: GPRCC(',I,')=',GPRCC(I,1) + END IF + IF (GSNWC(I) > SNWCMAX .OR. GSNWC(I) < zero) THEN + WRITE(iulog,*) '### CUMCHK: GSNWC(',I,')=',GSNWC(I) + END IF + IF (CUMFRC(I) > one .OR. CUMFRC(I) < zero) THEN + WRITE(iulog,*) '### CUMCHK: CUMFRC(',I,')=',CUMFRC(I) + ENDIF + ENDDO +! + END SUBROUTINE CUMCHK +!*********************************************************************** + SUBROUTINE TINTP & ! vertical interpolation of temperature + ( IJSDIM, KMAX , & !DD dimensions + GDTM , & ! output + GDT , GDP , GDPM , & ! input + ISTS , IENS ) ! input + + IMPLICIT NONE + INTEGER, INTENT(IN) :: IJSDIM, KMAX ! DD, for GFS, pass in +!* +!* [OUTPUT] + REAL(r8) GDTM (IJSDIM, KMAX+1) ! temperature (half lev) +!* +!* [INPUT] + REAL(r8) GDT (IJSDIM, KMAX) ! temperature (full lev) + REAL(r8) GDP (IJSDIM, KMAX) ! pressure (full lev) + REAL(r8) GDPM (IJSDIM, KMAX+1) ! pressure (half lev) + INTEGER ISTS, IENS ! range of active grids +!* +!* [INTERNAL WORK] +! REAL(r8) FTINT ( KMAX ) ! intrp. coef. +! REAL(r8) FTINTM( KMAX ) ! intrp. coef. + real (r8) :: wrk, wrk1, ftintm + + INTEGER I, K +!* +!* < interp. temp. > +!* + DO K=2,KMAX + DO I=ISTS,IENS + wrk = one / GDP(I,K) + wrk1 = one / LOG(GDP(I,K-1)*wrk) + FTINTM = wrk1 * LOG(GDPM(I,K)*wrk) + GDTM(I,K) = FTINTM *GDT(I,K-1) + (1.0-FTINTM)*GDT(I,K) +! FTINTM( K ) = wrk1 * LOG(GDPM(I,K)*wrk) +! FTINT ( K ) = wrk1 * LOG(GDP(I,K-1)/GDPM(I,K)) +! GDTM( I,K ) = FTINTM(K)*GDT(I,K-1) + FTINT(K)*GDT(I,K) + ENDDO + ENDDO + + DO I = ISTS, IENS + GDTM(I,KMAX+1) = GDT(I,KMAX) + GDTM(I,1 ) = GDT(I,1) + ENDDO + + RETURN + END SUBROUTINE TINTP +!*********************************************************************** + +end module cs_conv diff --git a/gsmphys/date_def.f b/gsmphys/date_def.f new file mode 100644 index 00000000..2907d741 --- /dev/null +++ b/gsmphys/date_def.f @@ -0,0 +1,13 @@ + module date_def + use machine, ONLY: kind_evod + implicit none + +!jw integer idate(4) +!jw real(kind=kind_evod) fhour,shour,thour,z00 + real(kind=kind_evod) shour,thour,z00 + real(kind=kind_evod),target :: fhour, zhour + integer,target :: idate(4),idate7(7) +! + REAL(KIND=KIND_EVOD) ,ALLOCATABLE :: spdmax(:) + + end module date_def diff --git a/gsmphys/dcyc2.f b/gsmphys/dcyc2.f new file mode 100644 index 00000000..12f3d57b --- /dev/null +++ b/gsmphys/dcyc2.f @@ -0,0 +1,250 @@ +! ===================================================================== ! +! description: ! +! ! +! dcyc2t3 fits radiative fluxes and heating rates from a coarse ! +! radiation calc time interval into model's more frequent time steps.! +! solar heating rates and fluxes are scaled by the ratio of cosine ! +! of zenith angle at the current time to the mean value used in ! +! radiation calc. surface downward lw flux is scaled by the ratio ! +! of current surface air temperature (temp**4) to the corresponding ! +! temperature saved during lw radiation calculation. upward lw flux ! +! at the surface is computed by current ground surface temperature. ! +! surface emissivity effect will be taken in other part of the model.! +! ! +! usage: ! +! ! +! call dcyc2t3 ! +! inputs: ! +! ( solhr,slag,sdec,cdec,sinlat,coslat, ! +! xlon,coszen,tsea,tf,tsflw,sfcemis, ! +! sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, ! +! sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, ! +! sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, ! +! ix, im, levs, ! +! input/output: ! +! dtdt,dtdtc, ! +! outputs: ! +! adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, ! +! adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, ! +! adjdnnbmd,adjdnndfd,adjdnvbmd,adjdnvdfd) ! +! ! +! ! +! program history: ! +! 198? nmc mrf - created, similar as treatment in gfdl ! +! radiation treatment ! +! 1994 y. hou - modified solar zenith angle calculation ! +! nov 2004 x. wu - add sfc sw downward flux to the variable ! +! list for sea-ice model ! +! mar 2008 y. hou - add cosine of zenith angle as output for ! +! sunshine duration time calc. ! +! sep 2008 y. hou - separate net sw and downward lw in slrad, ! +! changed the sign of sfc net sw to consistent with ! +! other parts of the mdl (positive value defines from ! +! atmos to the ground). rename output fluxes as adjusted! +! fluxes. other minor changes such as renaming some of ! +! passing argument names to be consistent with calling ! +! program. ! +! apr 2009 y. hou - integrated with the new parallel model ! +! along with other modifications ! +! mar 2011 y. hou - minor modification including rearrange ! +! loop orders and loop structures to improve efficiency ! +! mar 2014 x. wu - add sfc nir/vis bm/df to the variable ! +! list for the coupled model input ! +! jul 2014 s moorthi - merge gfs and nems versions ! +! jun 2014 y. hou - revised to include both up and down sw ! +! spectral component fluxes ! +! Oct 2014 y. hous s. moorthi - add emissivity contribution to ! +! upward longwave flux ! +! ! +! subprograms called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! solhr - real, forecast time in 24-hour form (hr) ! +! slag - real, equation of time in radians ! +! sdec, cdec - real, sin and cos of the solar declination angle ! +! sinlat(im), coslat(im): ! +! - real, sin and cos of latitude ! +! xlon (im) - real, longitude in radians ! +! coszen (im) - real, avg of cosz over daytime sw call interval ! +! tsea (im) - real, ground surface temperature (k) ! +! tf (im) - real, surface air (layer 1) temperature (k) ! +! sfcemis(im) - real, surface emissivity (fraction) ! +! tsflw (im) - real, sfc air (layer 1) temp in k saved in lw call ! +! sfcdsw (im) - real, total sky sfc downward sw flux ( w/m**2 ) ! +! sfcnsw (im) - real, total sky sfc net sw into ground (w/m**2) ! +! sfcdlw (im) - real, total sky sfc downward lw flux ( w/m**2 ) ! +! swh(ix,levs) - real, total sky sw heating rates ( k/s ) ! +! swhc(ix,levs) - real, clear sky sw heating rates ( k/s ) ! +! hlw(ix,levs) - real, total sky lw heating rates ( k/s ) ! +! hlwc(ix,levs) - real, clear sky lw heating rates ( k/s ) ! +! sfcnirbmu(im)- real, tot sky sfc nir-beam sw upward flux (w/m2) ! +! sfcnirdfu(im)- real, tot sky sfc nir-diff sw upward flux (w/m2) ! +! sfcvisbmu(im)- real, tot sky sfc uv+vis-beam sw upward flux (w/m2)! +! sfcvisdfu(im)- real, tot sky sfc uv+vis-diff sw upward flux (w/m2)! +! sfcnirbmd(im)- real, tot sky sfc nir-beam sw downward flux (w/m2) ! +! sfcnirdfd(im)- real, tot sky sfc nir-diff sw downward flux (w/m2) ! +! sfcvisbmd(im)- real, tot sky sfc uv+vis-beam sw dnward flux (w/m2)! +! sfcvisdfd(im)- real, tot sky sfc uv+vis-diff sw dnward flux (w/m2)! +! ix, im - integer, horiz. dimention and num of used points ! +! levs - integer, vertical layer dimension ! +! ! +! input/output: ! +! dtdt(im,levs)- real, model time step adjusted total radiation ! +! heating rates ( k/s ) ! +! dtdtc(im,levs)- real, model time step adjusted clear sky radiation! +! heating rates ( k/s ) ! +! ! +! outputs: ! +! adjsfcdsw(im)- real, time step adjusted sfc dn sw flux (w/m**2) ! +! adjsfcnsw(im)- real, time step adj sfc net sw into ground (w/m**2)! +! adjsfcdlw(im)- real, time step adjusted sfc dn lw flux (w/m**2) ! +! adjsfculw(im)- real, sfc upward lw flux at current time (w/m**2) ! +! adjnirbmu(im)- real, t adj sfc nir-beam sw upward flux (w/m2) ! +! adjnirdfu(im)- real, t adj sfc nir-diff sw upward flux (w/m2) ! +! adjvisbmu(im)- real, t adj sfc uv+vis-beam sw upward flux (w/m2) ! +! adjvisdfu(im)- real, t adj sfc uv+vis-diff sw upward flux (w/m2) ! +! adjnirbmd(im)- real, t adj sfc nir-beam sw downward flux (w/m2) ! +! adjnirdfd(im)- real, t adj sfc nir-diff sw downward flux (w/m2) ! +! adjvisbmd(im)- real, t adj sfc uv+vis-beam sw dnward flux (w/m2) ! +! adjvisdfd(im)- real, t adj sfc uv+vis-diff sw dnward flux (w/m2) ! +! xmu (im) - real, time step zenith angle adjust factor for sw ! +! xcosz (im) - real, cosine of zenith angle at current time step ! +! ! +! ==================== end of description ===================== ! + +!----------------------------------- + subroutine dcyc2t3 & +!................................... +! --- inputs: + & ( solhr,slag,sdec,cdec,sinlat,coslat, & + & xlon,coszen,tsea,tf,tsflw,sfcemis, & + & sfcdsw,sfcnsw,sfcdlw,swh,swhc,hlw,hlwc, & + & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & + & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & + & ix, im, levs, daily_mean, & +! --- input/output: + & dtdt,dtdtc, & +! --- outputs: + & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, & + & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & + & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd & + & ) +! + use machine, only : kind_phys + use physcons, only : con_pi, con_sbc + + implicit none +! +! --- constant parameters: + real(kind=kind_phys), parameter :: f_eps = 0.0001, hour12 = 12.0 + +! --- inputs: + integer, intent(in) :: ix, im, levs + + real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec + + real(kind=kind_phys), dimension(im), intent(in) :: & + & sinlat, coslat, xlon, coszen, tsea, tf, tsflw, sfcdlw, & + & sfcdsw, sfcnsw, sfcemis + real(kind=kind_phys), dimension(im), intent(in) :: & + & sfcnirbmu, sfcnirdfu, sfcvisbmu, sfcvisdfu, & + & sfcnirbmd, sfcnirdfd, sfcvisbmd, sfcvisdfd + + real(kind=kind_phys), dimension(ix,levs), intent(in) :: swh, hlw + &, swhc, hlwc& + + logical, intent(in) :: daily_mean + +! --- input/output: + real(kind=kind_phys), dimension(im,levs), intent(inout) :: dtdt & + &, dtdtc + +! --- outputs: + real(kind=kind_phys), dimension(im), intent(out) :: & + & adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + & adjnirbmu, adjnirdfu, adjvisbmu, adjvisdfu, & + & adjnirbmd, adjnirdfd, adjvisbmd, adjvisdfd + +! --- locals: + integer :: i, k + real(kind=kind_phys) :: cns, ss, cc, ch, tem1, tem2 +! +!===> ... begin here +! + cns = con_pi * (solhr - hour12) / hour12 + slag +! + do i = 1, im + +! --- ... lw time-step adjustment +! ----------------------- +! --- ... adjust sfc downward lw flux to account for t changes in layer 1 +! compute 4th power of the ratio of layer 1 tf over the mean value tsflw + + tem1 = tf(i) / tsflw(i) + tem2 = tem1 * tem1 + adjsfcdlw(i) = sfcdlw(i) * tem2 * tem2 + +! --- ... compute sfc upward lw flux from current sfc temp, +! note: sfc emiss effect is not appied here, and will be dealt in other place + + tem2 = tsea(i) * tsea(i) + adjsfculw(i) = sfcemis(i) * con_sbc * tem2 * tem2 + & + (1.0 - sfcemis(i)) * adjsfcdlw(i) +! +! --- ... sw time-step adjustment +! ----------------------- + + ss = sinlat(i) * sdec + cc = coslat(i) * cdec + ch = cc * cos( xlon(i)+cns ) + xcosz(i) = ch + ss ! cosine of solar zenith angle at current time + +! --- ... replace cosz with daily mean value + + if (daily_mean) then + xcosz(i) = coszen(i) + endif + +! --- ... normalize by average value over radiation period for daytime. + + if ( xcosz(i) > f_eps .and. coszen(i) > f_eps ) then + xmu(i) = xcosz(i) / coszen(i) + else + xmu(i) = 0.0 + endif + +! --- ... adjust sfc net and downward sw fluxes for zenith angle changes +! note: sfc emiss effect will not be appied here + + adjsfcnsw(i) = sfcnsw(i) * xmu(i) + adjsfcdsw(i) = sfcdsw(i) * xmu(i) + + adjnirbmu(i) = sfcnirbmu(i) * xmu(i) + adjnirdfu(i) = sfcnirdfu(i) * xmu(i) + adjvisbmu(i) = sfcvisbmu(i) * xmu(i) + adjvisdfu(i) = sfcvisdfu(i) * xmu(i) + + adjnirbmd(i) = sfcnirbmd(i) * xmu(i) + adjnirdfd(i) = sfcnirdfd(i) * xmu(i) + adjvisbmd(i) = sfcvisbmd(i) * xmu(i) + adjvisdfd(i) = sfcvisdfd(i) * xmu(i) + enddo + +! --- ... adjust sw heating rates with zenith angle change and +! add with lw heating to temperature tendency + + do k = 1, levs + do i = 1, im + dtdt(i,k) = dtdt(i,k) + swh(i,k)*xmu(i) + hlw(i,k) + dtdtc(i,k) = dtdtc(i,k) + swhc(i,k)*xmu(i) + hlwc(i,k) + enddo + enddo +! + return +!................................... + end subroutine dcyc2t3 +!----------------------------------- + diff --git a/gsmphys/dcyc2.pre.rad.f b/gsmphys/dcyc2.pre.rad.f new file mode 100644 index 00000000..c303a286 --- /dev/null +++ b/gsmphys/dcyc2.pre.rad.f @@ -0,0 +1,206 @@ +! ===================================================================== ! +! description: ! +! ! +! dcyc2t3_pre_rad is a testing/debuging utility program mimic the ! +! original dcyc2t3 program that fits radiatibe fluxes and heating ! +! rates from a coarse time interval of radiation calculations onto ! +! the model's more frequent time steps. ! +! (note: although contains some side-effect, this program is mainly ! +! used for testing purpose, but not for regular fcst mode. ! +! no significant modifications done after it was created) ! +! ! +! usage: ! +! ! +! call dcyc2t3_pre rad ! +! inputs: ! +! ( solhr,slag,sdec,cdec,sinlat,coslat, ! +! xlon,coszen,tsea,tf,tsflw, ! +! sfcdsw,sfcnsw,sfcdlw,swh,hlw, ! +! sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, ! +! sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, ! +! ix, im, levs, ! +! input/output: ! +! dtdt, ! +! outputs: ! +! adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, ! +! adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, ! +! adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd) ! +! ! +! ! +! program history: ! +! 198? nmc mrf - created subr dcyc2, similar to treatment ! +! in gfdl radiation approximation scheme ! +! 1994 y. hou - modified solar zenith angle calculation ! +! 200? j. sala - modified from dcyc2 to create a testing ! +! debuging program ! +! nov 2004 x. wu - add sfc sw downward flux to the variable ! +! list for sea-ice model ! +! mar 2008 y. hou - following updates in dcyc2t3, add cosine ! +! of zenith angle as output for sunshine ! +! duration time calculation. ! +! sep 2008 y. hou - separate net sw and downward lw in slrad, ! +! change the sign of sfc net sw to consistent with other! +! parts of the mdl (positive value defines from atmos to! +! the ground). rename output fluxes as adjusted fluxes. ! +! other minor changes such as renaming some passing ! +! argument names to be consistent with calling subr. ! +! mar 2014 x. wu - add sfc nir/vis bm/df to the variable ! +! list for the coupled model input ! +! jun 2014 y. hou - revised to include both up and down sw ! +! spectral component fluxes ! +! ! +! ! +! subprograms called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! solhr - real, forecast time in 24-hour form (hr) ! +! slag - real, equation of time in radians ! +! sdec, cdec - real, sin and cos of the solar declination angle ! +! sinlat(im), coslat(im): ! +! - real, sin and cos of latitude ! +! xlon (im) - real, longitude in radians ! +! coszen (im) - real, avg of cosz over daytime sw call interval ! +! tsea (im) - real, ground surface temperature (k) ! +! tf (im) - real, surface air (layer 1) temperature (k) ! +! tsflw (im) - real, sfc air (layer 1) temp in k saved in lw call ! +! sfcdsw (im) - real, total sky sfc downward sw flux (w/m**2) ! +! sfcnsw (im) - real, total sky sfc net sw into ground (w/m**2) ! +! sfcdlw (im) - real, total sky sfc downward lw flux (w/m**2) ! +! swh(ix,levs) - real, total sky sw heating rates ( k/s ) ! +! hlw(ix,levs) - real, total sky lw heating rates ( k/s ) ! +! sfcnirbmu(im)- real, tot sky sfc nir-beam sw upward flux (w/m2) ! +! sfcnirdfu(im)- real, tot sky sfc nir-diff sw upward flux (w/m2) ! +! sfcvisbmu(im)- real, tot sky sfc uv+vis-beam sw upward flux (w/m2)! +! sfcvisdfu(im)- real, tot sky sfc uv+vis-diff sw upward flux (w/m2)! +! sfcnirbmd(im)- real, tot sky sfc nir-beam sw downward flux (w/m2) ! +! sfcnirdfd(im)- real, tot sky sfc nir-diff sw downward flux (w/m2) ! +! sfcvisbmd(im)- real, tot sky sfc uv+vis-beam sw dnward flux (w/m2)! +! sfcvisdfd(im)- real, tot sky sfc uv+vis-diff sw dnward flux (w/m2)! +! ix, im - integer, horiz. dimention and num of used points ! +! levs - integer, vertical layer dimension ! +! ! +! input/output: ! +! dtdt(im,levs)- real, model time step adjusted total radiation ! +! heating rates ( k/s ) ! +! ! +! outputs: ! +! adjsfcdsw(im)- real, time step adjusted sfc dn sw flux (w/m**2) ! +! adjsfcnsw(im)- real, time step adj sfc net sw into ground (w/m**2)! +! adjsfcdlw(im)- real, time step adjusted sfc dn lw flux (w/m**2) ! +! adjsfculw(im)- real, sfc upward lw flux at current time (w/m**2) ! +! adjnirbmu(im)- real, t adj sfc nir-beam sw upward flux (w/m2) ! +! adjnirdfu(im)- real, t adj sfc nir-diff sw upward flux (w/m2) ! +! adjvisbmu(im)- real, t adj sfc uv+vis-beam sw upward flux (w/m2) ! +! adjvisdfu(im)- real, t adj sfc uv+vis-diff sw upward flux (w/m2) ! +! adjnirbmd(im)- real, t adj sfc nir-beam sw downward flux (w/m2) ! +! adjnirdfd(im)- real, t adj sfc nir-diff sw downward flux (w/m2) ! +! adjvisbmd(im)- real, t adj sfc uv+vis-beam sw dnward flux (w/m2) ! +! adjvisdfd(im)- real, t adj sfc uv+vis-diff sw dnward flux (w/m2) ! +! xmu (im) - real, time step zenith angle adjust factor for sw ! +! xcosz (im) - real, cosine of zenith angle at current time step ! +! ! +! ==================== end of description ===================== ! + +!----------------------------------- + subroutine dcyc2t3_pre_rad & +!................................... +! --- inputs: + & ( solhr,slag,sdec,cdec,sinlat,coslat, & + & xlon,coszen,tsea,tf,tsflw, & + & sfcdsw,sfcnsw,sfcdlw,swh,hlw, & + & sfcnirbmu,sfcnirdfu,sfcvisbmu,sfcvisdfu, & + & sfcnirbmd,sfcnirdfd,sfcvisbmd,sfcvisdfd, & + & ix, im, levs, & +! --- input/output: + & dtdt, & +! --- outputs: + & adjsfcdsw,adjsfcnsw,adjsfcdlw,adjsfculw,xmu,xcosz, & + & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & + & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd & + & ) +! + use machine, only : kind_phys + use physcons, only : con_pi, con_sbc, con_jcal + + implicit none +! +! --- constant parameters: + real(kind=kind_phys), parameter :: cnwatt = -con_jcal*1.0e4/60.0 + +! --- inputs: + integer, intent(in) :: ix, im, levs + + real(kind=kind_phys), intent(in) :: solhr, slag, cdec, sdec + + real(kind=kind_phys), dimension(im), intent(in) :: & + & sinlat, coslat, xlon, coszen, tsea, tf, tsflw, sfcdlw, & + & sfcdsw, sfcnsw + real(kind=kind_phys), dimension(im), intent(in) :: & + & sfcnirbmu, sfcnirdfu, sfcvisbmu, sfcvisdfu, & + & sfcnirbmd, sfcnirdfd, sfcvisbmd, sfcvisdfd + + real(kind=kind_phys), dimension(ix,levs), intent(in) :: swh, hlw + +! --- input/output: + real(kind=kind_phys), dimension(im,levs), intent(inout) :: dtdt + +! --- outputs: + real(kind=kind_phys), dimension(im), intent(out) :: & + & adjsfcdsw, adjsfcnsw, adjsfcdlw, adjsfculw, xmu, xcosz, & + & adjnirbmu,adjnirdfu,adjvisbmu,adjvisdfu, & + & adjnirbmd,adjnirdfd,adjvisbmd,adjvisdfd + +! --- locals: + integer :: i, k + real(kind=kind_phys) :: cns, ss, cc, ch, tem +! +!===> ... begin here +! + xmu(:) = 1.0 + cc = 0.1 + ss = 0.0 + ch = 350.0 / cnwatt + + do i = 1, im + xcosz(i) = xmu(i) + if (xmu(i) > 0.01 .and. cc > 0.01) then + xmu(i) = xmu(i) / cc + else + xmu(i) = 0.0 + endif + + adjsfcdsw(i) = sfcdsw(i) * xmu(i) + adjsfcnsw(i) = ss * xmu(i) + + adjnirbmu(i) = sfcnirbmd(i) * xmu(i) + adjnirdfu(i) = sfcnirdfd(i) * xmu(i) + adjvisbmu(i) = sfcvisbmd(i) * xmu(i) + adjvisdfu(i) = sfcvisdfd(i) * xmu(i) + + adjnirbmd(i) = sfcnirbmd(i) * xmu(i) + adjnirdfd(i) = sfcnirdfd(i) * xmu(i) + adjvisbmd(i) = sfcvisbmd(i) * xmu(i) + adjvisdfd(i) = sfcvisdfd(i) * xmu(i) + + tem = tf(i) / tsflw(i) + tem = tem * tem + adjsfcdlw(i) = ch * tem * tem + tem = tsea(i) * tsea(i) + adjsfculw(i) = con_sbc * tem * tem + enddo + +! --- ... will not change dtdt value +! do k = 1, levs +! do i = 1, im +! dtdt(i,k) = dtdt(i,k) + 0.0 +! enddo +! enddo +! + return +!................................... + end subroutine dcyc2t3_pre_rad +!----------------------------------- + diff --git a/gsmphys/efield.f b/gsmphys/efield.f new file mode 100644 index 00000000..64fb1bc6 --- /dev/null +++ b/gsmphys/efield.f @@ -0,0 +1,3241 @@ + + module efield +!--------------------------------------------------------------------- +! description: calculates the electric potential for a given year, +! day of year,UT, F10.7, B_z(K_p) +! - low/midlatitudes electric potential is from an empirical model from +! L.Scherliess ludger@gaim.cass.usu.edu +! - high latitude electric potential is from Weimer96 model +! - the transition zone is smoothed +! - output is the horizontal global electric field in magnetic coordinates direction +! at every magnetic local time grid point expressed in degrees (0 deg-0MLT; 360deg 24 MLT) +! +! input +! integer :: iday, ! day number of year +! iyear ! year +! real:: ut, ! universal time +! F10.7, ! solar flux (see ionosphere module) +! bz ! component of IMF (see ionosphere module) +! output +! real :: & +! ed1(0:nmlon,0:nmlat), & ! zonal electric field Ed1 [V/m] +! ed2(0:nmlon,0:nmlat) ! meridional electric field Ed2/sin I_m [V/m] +! +! notes: +! +! - !to be done (commented out): input S_a F10.7/ Kp from WACCM and calculate B_z +! from these inputs +! - assume regular geomagnetic grid +! - uses average year 365.24 days/year 30.6001 day/mo s. Weimer +! - get_tilt works only for iyear >= 1900 +! - Weimer model 1996, Dan Weimer (not with the updates from B.Emery) +! - fixed parameters: B_z, B_y units nT CHANGE THIS +! F10.7 +! - we assume that the reference height is 300km for the emperical potential model +! - as a first approximation the electric field is constant in height +! WATCH what is the upper boundary condition in WACCM +! - for all the calculation done here we set the reference height to the same +! value as in tiegcm (hr=130km) +! - 12/15/03 input value iseasav : replaced by day -> month and day of month +! - 12/15/03 S_aM calculated according to Scherliess draft paper and added +! S_aM(corrected) = 90*(S_aM+1) to get variation in fig 1 Scherliess draft +! +! Apr 06 2012 Henry Juang, initial implement for nems +! Nov 20 2014 Jun Wang, change JULDAY to JULDAY_WAM +! +! Author: A. Maute Dec 2003 am 12/30/03 +!------------------------------------------------------------------------------ + +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use physconst, only: pi +! use abortutils, only: endrun +! use cam_logfile, only: iulog + + implicit none + + public :: efield_init, ! interface routine + & get_efield ! interface routine + public :: ed1, ! zonal electric field Ed1 [V/m] + & ed2, ! meridional electric field Ed2 [V/m] + & potent, ! electric potential [V] + & nmlon, nmlat, ! dimension of mag. grid + & dlatm, dlonm, ! grid spacing of mag. grid + & ylonm, ylatm ! magnetic longitudes/latitudes (degc) + &,iday,iyear,iday_m,imo,f107d,by,bz,ut + + public :: Coef , Cn,ML,MM1,MaxL,MaxM,MaxN,ALAMN,ALAMX,ALAMR, + &STPD,STP2,CSTP,SSTP,CX,ST,CT,AM,EPOCH,TH0,PH0,DIPOLE +! private + + integer :: + & iday, ! day number of year + & iyear, ! year + & iday_m, ! day of month + & imo !month + real :: ut ! universal time + +!---------------------------------------------------------------------- +! solar parameters +!---------------------------------------------------------------------- + real :: f107d ! 10.7 cm solar flux + real :: by ! By component of IMF [nT] + real :: bz ! Bz component of IMF [nT] + private +!---------------------------------------------------------------------- +! mag. grid dimensions (assumed resolution of 2deg) +!---------------------------------------------------------------------- + integer, parameter :: + &nmlon = 180, ! mlon + &nmlat = 90, ! mlat + &nmlath= nmlat/2, ! mlat/2 + &nmlonh= nmlon/2, ! mlon/2 + &nmlonp1 = nmlon+1, ! mlon+1 + &nmlatp1 = nmlat+1, ! mlat+1 + &iulog=10 + + real :: + & ylatm(0:nmlat), ! magnetic latitudes (deg) + & ylonm(0:nmlon), ! magnetic longitudes (deg) + & dlonm, ! delon lon grid spacing + & dlatm ! delat lat grid spacing + +!---------------------------------------------------------------------- +! array on magnetic grid: +!---------------------------------------------------------------------- + real :: + & potent(0:nmlon,0:nmlat),! electric potential [V] + & ed1(0:nmlon,0:nmlat), ! zonal electric field Ed1 [V/m] + & ed2(0:nmlon,0:nmlat) ! meridional electric field Ed2/sin I_m [V/m] + + real :: + & date, ! iyear+iday+ut + & day ! iday+ut + + logical, parameter :: iutav=.false. ! .true. means UT-averaging + ! .false. means no UT-averaging +! real, parameter :: v_sw = 400. ! solar wind velocity [km/s] + real, parameter :: v_sw = 450. ! solar wind velocity [km/s] + +!---------------------------------------------------------------------- +! boundary for Weimer +!---------------------------------------------------------------------- + real, parameter :: bnd_wei = 44. ! colat. [deg] + integer :: nmlat_wei + +!---------------------------------------------------------------------- +! flag for choosing factors for empirical low latitude model +!---------------------------------------------------------------------- + integer, parameter :: iseasav = 0 ! flag for season + +!---------------------------------------------------------------------- +! constants: +!---------------------------------------------------------------------- + real, parameter :: + &r_e = 6.371e6, ! radius_earth [m] (same as for apex.F90) + & h_r = 130.0e3, ! reference height [m] (same as for apex.F90) + &dy2yr= 365.24, ! day per avg. year used in Weimer + &dy2mo= 30.6001, ! day per avg. month used in Weimer + &pi=3.141592653 + + real + & rtd , ! radians -> deg + & dtr, ! deg -> radians + & sqr2, + & hr2rd, ! pi/12 hrs + & dy2rd, ! 2*pi/365.24 average year + & deg2mlt, ! for mlon to deg + & mlt2deg, ! for mlt to mlon + & sinIm_mag(0:nmlat) ! sinIm + + integer :: jmin, jmax ! latitude index for interpolation of + ! northward e-field ed2 at mag. equator + +!---------------------------------------------------------------------- +! for spherical harmonics +!---------------------------------------------------------------------- + integer, parameter :: + & nm = 19, + & mm = 18, + & nmp = nm + 1, + & mmp = mm + 1 + + real :: r(0:nm,0:mm) ! R_n^m + real :: pmopmmo(0:mm) ! sqrt(1+1/2m) + +!---------------------------------------------------------------------- +! index for factors f_m(mlt),f_l(UT),f_-k(d) +!---------------------------------------------------------------------- + integer, parameter :: ni = 1091 ! for n=12 m=-18:18 + integer :: imax ! max number of index + integer,dimension(0:ni) :: kf,lf, mf, nf, jf + real :: ft(1:3,0:2) ! used for f_-k(season,k) + + real :: a_klnm(0:ni) ! A_klm + real :: a_lf(0:ni) ! A_klmn^lf for minimum + real :: a_hf(0:ni) ! A_klmn^hf for maximum +!---------------------------------------------------------------------- +!replace wei96.f common block +!---------------------------------------------------------------------- + real :: Coef(0:1,0:8,0:3) + real :: Cn(0:3,0:1,0:4,0:1,0:8,0:3) + integer ML,MM1,MaxL,MaxM,MaxN + real ALAMN,ALAMX,ALAMR,STPD,STP2,CSTP,SSTP + real CX(9),ST(6),CT(6),AM(3,3,11) + real , parameter :: EPOCH=1980.,TH0=11.19,PH0=-70.76, + & DIPOLE=.30574 + +!---------------------------------------------------------------------- +! high_latitude boundary +!---------------------------------------------------------------------- + real, parameter :: + &ef_max = 0.015, ! max e-field for high latitude boundary location [V/m] + &lat_sft = 54. ! shift of highlat_bnd to 54 deg + integer :: ilat_sft ! index of shift for high latitude boundary + integer, parameter :: nmax_sin = 2 ! max. wave number to be represented + logical, parameter :: debug =.false. +! + contains + + subroutine efield_init +!hmhj subroutine efield_init(efield_lflux_file, efield_hflux_file, +!hmhj&efield_wei96_file) +!-------------------------------------------------------------------- +! Purpose: read in and set up coefficients needed for electric field +! calculation (independent of time & geog. location) +! +! Method: +! +! Author: A. Maute Dec 2003 am 12/17/03 +!------------------------------------------------------------------- +!hmhj character(len=*), intent(in) :: efield_lflux_file +!hmhj character(len=*), intent(in) :: efield_hflux_file +!hmhj character(len=*), intent(in) :: efield_wei96_file + + character(len=*), parameter :: + & efield_lflux_file='global_idea_coeff_lflux.dat', + & efield_hflux_file='global_idea_coeff_hflux.dat', + & efield_wei96_file='global_idea_wei96.cofcnts' + + call constants ! calculate constants +!----------------------------------------------------------------------- +! low/midlatitude potential from Scherliess model +!----------------------------------------------------------------------- + call read_acoef (efield_lflux_file, efield_hflux_file) ! read in A_klnm for given S_aM + call index_quiet ! set up index for f_m(mlt),f_l(UT),f_-k(d) + call prep_fk ! set up the constant factors for f_k + call prep_pnm ! set up the constant factors for P_n^m & dP/d phi +!----------------------------------------------------------------------- +!following part should be independent of time & location if IMF constant +!----------------------------------------------------------------------- + call ReadCoef (efield_wei96_file) + + end subroutine efield_init + + subroutine get_efield +!----------------------------------------------------------------------- +! Purpose: calculates the global electric potential field on the +! geomagnetic grid (MLT in deg) and derives the electric field +! +! Method: +! +! Author: A. Maute Dec 2003 am 12/17/03 +!----------------------------------------------------------------------- + +! use time_manager, only : get_curr_calday, get_curr_date +! use mo_solar_parms, only : get_solar_parms +! use mag_parms, only : get_mag_parms +! use cam_control_mod, only: magfield_fix_year +! use spmd_utils, only: masterproc + + integer :: idum1, idum2, tod ! time of day [s] + real kp + +!----------------------------------------------------------------------- +! get current calendar day of year & date components +! valid at end of current timestep +!----------------------------------------------------------------------- +! iday = get_curr_calday() ! day of year +! call get_curr_date (iyear,imo,iday_m,tod)! year, time of day [sec] +! iyear = magfield_fix_year +! iyear = 1995 + +! if( iyear < 1900 ) then +! write(iulog,"(/,'>>> get_efield: year < 1900 not possible: +! &year=',i5)") iyear +! call endrun +! end if + + tod=ut*3600. +! ut = tod/3600. ! UT of day [sec] + +!----------------------------------------------------------------------- +! get solar parms +!----------------------------------------------------------------------- +! call get_solar_parms( f107_s = f107d ) +!----------------------------------------------------------------------- +! get mag parms +!----------------------------------------------------------------------- +! call get_mag_parms( by = by, bz = bz ) +! print*,by,bz,f107d,ut +!#ifdef EFIELD_DIAGS +! if( masterproc ) then +! write(iulog,*) 'get_efield: f107d,by,bz = ', f107d,by,bz +! end if +!#endif +!----------------------------------------------------------------------- +! ajust S_a +!----------------------------------------------------------------------- + call adj_S_a +!----------------------------------------------------------------------- +! calculate global electric potential +!----------------------------------------------------------------------- + call GlobalElPotential +! print*,'pot_efield',potent(149,66),potent(149,64) + +!----------------------------------------------------------------------- +! calculate derivative of global electric potential +!----------------------------------------------------------------------- + call DerivPotential +! print*,'ed2_efield',ed2(149,65),potent(149,66),potent(149,64) + + end subroutine get_efield + + subroutine GlobalElPotential +!----------------------------------------------------------------------- +! Purpose: calculates the global electric potential field on the +! geomagnetic grid (MLT in deg) +! +! Method: rewritten code from Luedger Scherliess (11/20/99 LS) +! routine to calculate the global electric potential in magnetic +! Apex coordinates (Latitude and MLT). +! High Latitude Model is Weimer 1996. +! Midlatitude model is Scherliess 1999. +! Interpolation in a transition region at about 60 degree +! magnetic apex lat +! +! Author: A. Maute Dec 2003 am 12/17/03 +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + integer :: ilon, ilat, idlat + integer :: ihlat_bnd(0:nmlon) ! high latitude boundary + integer :: itrans_width(0:nmlon) ! width of transition zone + real :: mlt, mlon, mlat, mlat_90, pot + real :: pot_midlat(0:nmlon,0:nmlat) ! potential from L. Scherliess model + real :: pot_highlat(0:nmlon,0:nmlat) ! potential from Weimer model + real :: pot_highlats(0:nmlon,0:nmlat)! smoothed potential from Weimer model + +!----------------------------------------------------------------------- +! Externals +!----------------------------------------------------------------------- + real,external :: EpotVal ! in wei96.f + +!----------------------------------------------------------------------- +! convert to date and day +!----------------------------------------------------------------------- + day = iday + ut/24. + date = iyear + day/dy2yr + +!----------------------------------------------------------------------- +! low/midlatitude electric potential - empirical model Scherliess 1999 +!----------------------------------------------------------------------- +!$omp parallel do private(ilat, ilon, mlat, pot) + do ilat = 0,nmlath ! Calculate only for one magn. hemisphere + mlat = ylatm(ilat) ! mag. latitude + do ilon = 0,nmlon ! lon. loop + call efield_mid( mlat, ylonm(ilon), pot ) + pot_midlat(ilon,ilat+nmlath) = pot ! SH/NH symmetry + pot_midlat(ilon,nmlath-ilat) = pot + end do + end do +! print*,'www1','midlat',pot_midlat(149,66) + +!----------------------------------------------------------------------- +! hight latitude potential from Weimer model +! at the poles Weimer potential is not longitudinal dependent +!----------------------------------------------------------------------- + call prep_weimer ! calculate IMF angle & magnitude, tilt + +!$omp parallel do private(ilat, ilon, mlat_90, pot) + do ilat = 0,nmlat_wei ! Calculate only for one magn. hemisphere + mlat_90 = 90. - ylatm(ilat) ! mag. latitude + do ilon = 0,nmlon + pot = 1000.*EpotVal( mlat_90, ylonm(ilon)*deg2mlt ) ! calculate potential (kv -> v) +!----------------------------------------------------------------------- +! NH/SH symmetry +!----------------------------------------------------------------------- + pot_highlat(ilon,ilat) = pot + pot_highlat(ilon,nmlat-ilat) = pot + pot_highlats(ilon,ilat) = pot + pot_highlats(ilon,nmlat-ilat) = pot +! bad value com from EpotVal +! if(ilat.eq.22.and.ilon.eq.148) +! & print*,'www2',ilat,ilon,pot,mlat_90,ylonm(ilon)*deg2mlt + end do + end do +! print*,'www2','highlat',ut,by,bz,pot_highlat(0:180,68),nmlat_wei + +!----------------------------------------------------------------------- +! weighted smoothing of high latitude potential +!----------------------------------------------------------------------- + idlat = 2 ! smooth over -2:2 = 5 grid points + call pot_latsmo( pot_highlats, idlat ) +! print*,'www2','highlat',ut,pot_highlat(0:180,45) +!----------------------------------------------------------------------- +! calculate the height latitude bounday ihl_bnd +! 1. calculate E field from weimar model +! boundary is set where the total electric field exceeds +! 0.015 V/m (corresp. approx. to 300 m/s) +! 2. moved halfways to 54 deg +! output : index 0-pole nmlath-equator +!----------------------------------------------------------------------- + call highlat_getbnd( ihlat_bnd ) +!----------------------------------------------------------------------- +! 3. adjust high latitude boundary sinusoidally +! calculate width of transition zone +!----------------------------------------------------------------------- + call bnd_sinus( ihlat_bnd, itrans_width ) +!----------------------------------------------------------------------- +! 4. ajust high latitude potential to low latitude potential +!----------------------------------------------------------------------- +! print*,'www30',ihlat_bnd + call highlat_adjust( pot_highlats, pot_highlat, pot_midlat, + &ihlat_bnd ) +! print*,'www3','highlat',ut,pot_highlat(145:153,68) +! print*,'www3','midlat',ut,pot_midlat(145:153,68) +!----------------------------------------------------------------------- +! interpolation of high and low/midlatitude potential in the +! transition zone and put it into global potent array +!----------------------------------------------------------------------- + call interp_poten( pot_highlats, pot_highlat, pot_midlat, + &ihlat_bnd, itrans_width) +! print*,'www4','potent',ut,by,bz,potent(0:181,68) +!----------------------------------------------------------------------- +! potential weighted smoothing in latitude +!----------------------------------------------------------------------- + idlat = 2 ! smooth over -2:2 = 5 grid points + call pot_latsmo2( potent, idlat ) +! print*,'www5','pot_efield',potent(149,68) +!----------------------------------------------------------------------- +! potential smoothing in longitude +!----------------------------------------------------------------------- + idlat = nmlon/48 ! smooth over -idlat:idlat grid points + call pot_lonsmo( potent, idlat ) +! print*,'www6','pot_efield',ut,by,bz,potent(0:180,68) +!----------------------------------------------------------------------- +! output +!----------------------------------------------------------------------- +! output ( change later to netcdf file) +! do ilat=0,nmlat +! do ilon=0,nmlon +! write(iulog,'(4(x,f12.5))') ylatm(ilat),ylonm(ilon), & +! potent(ilon,ilat),potent(ilon,nmlat-ilat) +! write(iulog,'(4(x,f12.5))') ylatm(ilat),ylonm(ilon), & +! potent(ilon,ilat),potent(ilon,nmlat-ilat) +! write(iulog,'(f10.3)') potent(ilon,ilat) +! end do +! end do + + end subroutine GlobalElPotential + + subroutine ff( ph, mt, f ) +!----------------------------------------------------------------------- +!Purpose: calculate F for normalized associated Legendre polynomial P_n^m +! Ref.: Richmond J.Atm.Ter.Phys. 1974 +! +! Method: f_m(phi) = sqrt(2) sin(m phi) m > 0 +! = 1 m = 0 +! = sqrt(2) cos(m phi) m < 0 +! +! Author: A. Maute Nov 2003 am 11/18/03 +!----------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! dummy arguments +!----------------------------------------------------------------------- + integer,intent(in) :: mt + real,intent(in) :: ph ! geo. longitude of 0SLT (ut*15) + real,intent(out) :: f(-mt:mt) + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + integer :: m, i, j, mmo + real :: sp, cp + + sp = sin( ph/rtd ) + cp = cos( ph/rtd ) + f(0) = 1.e0 + + f(-1) = sqr2*cp + f(1) = sqr2*sp + do m = 2,mt + mmo = m - 1 + f(m) = f(-mmo)*sp + cp*f(mmo) + f(-m) = f(-mmo)*cp - sp*f(mmo) + end do + + end subroutine ff + + subroutine pnm( ct, p ) +!---------------------------------------------------------------- +! Purpose: normalized associated Legendre polynomial P_n^m +! Ref.: Richmond J.Atm.Ter.Phys. 1974 +! Method: +! P_m^m = sqrt(1+1/2m)*si*P_m-1^m-1 m>0 +! P_n^m = [cos*P_n-1^m - R_n-1^m*P_n-2^m ]/R_n^m n>m>=0 +! dP/d phi = n*cos*P_n^m/sin-(2*n+1)*R_n^m*P_n-1^m/sin n>=m>=0 +! R_n^m = sqrt[ (n^2-m^2)/(4n^2-1) ] +! +! Author: A. Maute Nov 2003 am 11/18/03 +!-------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! dummy arguments +!----------------------------------------------------------------------- + real, intent(inout) :: ct ! cos(colat) + real, intent(inout) :: p(0:nm,0:mm) + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + integer :: mp, m, n, np + real :: pm2, st + +! ct = min( ct,.99 ) ! cos(colat) + st = sqrt( 1. - ct*ct ) ! sin(colat) + + p(0,0) = 1. + do mp = 1,mmp ! m+1=1,mm+1 + m = mp - 1 + if( m >= 1 ) then + p(m,m) = pmopmmo(m)*p(m-1,m-1)*st + end if + pm2 = 0. + do n = mp,nm ! n=m+1,N + np = n + 1 + p(n,m) = (ct*p(n-1,m) - r(n-1,m)*pm2)/r(n,m) + pm2 = p(n-1,m) + end do + end do + + end subroutine pnm + + subroutine prep_pnm +!----------------------------------------------------------------- +! Purpose: constant factors for normalized associated Legendre polynomial P_n^m +! Ref.: Richmond J.Atm.Ter.Phys. 1974 +! +! Method: +! PmoPmmo(m) = sqrt(1+1/2m) +! R_n^m = sqrt[ (n^2-m^2)/(4n^2-1) ] +! +! Author: A. Maute Nov 2003 am 11/18/03 +!----------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------- +! local variables +!----------------------------------------------------------------------- + integer :: mp, m, n + real :: xms, xns, den + + do mp = 1, mmp ! m+1 = 1,mm+1 + m = mp - 1 + xms = m*m + if( mp /= 1 ) then + pmopmmo(m) = sqrt( 1. + .5/M ) + end if + do n = m,nm ! n = m,N + xns = n*n + den = max(4.*xns - 1.,1.) + r(n,m) = sqrt( (xns - xms)/den ) + end do + end do + + end subroutine prep_pnm + + subroutine index_quiet +!----------------------------------------------------------------- +! Purpose: set up index for factors f_m(mlt),f_l(UT),f_-k(d) to +! describe the electric potential Phi for the empirical model +! +! Method: +! Phi = sum_k sum_l sum_m sum_n [ A_klmn * P_n^m *f_m(mlt)*f_l(UT)*f_-k(d)] +! - since the electric potential is symmetric about the equator +! n+m odd terms are set zero resp. not used +! - in the summation for calculation Phi the index have the following +! range n=1,12 and m=-n,n, k=0,2 l=-2,2 +! +! Author: A. Maute Nov 2003 am 11/18/03 +!---------------------------------------------------------------- + + implicit none + +!---------------------------------------------------------------- +! ... local variables +!---------------------------------------------------------------- + integer :: i, j, k, l, n, m + + i = 0 ! initialize + j = 1 + do k = 2,0,-1 + do l = -2,2 + if( k == 2 .and. abs(l) == 2 ) then + cycle + end if + do n = 1,12 + do m = -18,18 + if( abs(m) <= n ) then ! |m| < n + if( (((n-m)/2)*2) == (n-m) ) then ! only n+m even + if( n-abs(m) <= 9 ) then ! n-|m| <= 9 why? + kf(i) = 2-k + lf(i) = l + nf(i) = n + mf(i) = m + jf(i) = j + i = i + 1 ! counter + end if + end if + end if + end do ! m + end do ! n + end do ! l + end do ! k + + imax = i - 1 + if(imax /= ni ) then ! check if imax == ni +! write(iulog,'(a19,i5,a18,i5)') 'index_quiet: imax= ',imax, +! & ' not equal to ni =',ni + stop + end if +! if(debug) write(iulog,*) 'imax=',imax + + end subroutine index_quiet + + subroutine read_acoef (efield_lflux_file, efield_hflux_file) +!---------------------------------------------------------------- +! Purpose: +! 1. read in coefficients A_klmn^lf for solar cycle minimum and +! A_klmn^hf for maximum +! 2. adjust S_a (f107d) such that if S_a<80 or S_a > 220 it has reasonable numbers +! S_aM = [atan{(S_a-65)^2/90^2}-a90]/[a180-a90] +! a90 = atan [(90-65)/90]^2 +! a180 = atan [(180-65)/90]^2 +! 3. inter/extrapolation of the coefficient to the actual flux which is +! given by the user +! A_klmn = S_aM [A_klmn^hf-A_klmn^lf]/90. + 2*A_klmn^lf-A_klmn^hf +! +! Method: +! +! Author: A. Maute Nov 2003 am 11/19/03 +!--------------------------------------------------------------- + +! use ioFileMod, only : getfil +! use units, only : getunit, freeunit + + character(len=*), intent(in) :: efield_lflux_file + character(len=*), intent(in) :: efield_hflux_file + + integer :: i,ios,unit,istat +! character (len=13):: locfn + character (len=256):: locfn + +!------------------------------------------------------------------ +! get coefficients file for solar minimum: +!----------------------------------------------------------------- +! unit = getunit() + unit = 11 +! call getfil( efield_lflux_file, locfn, 0 ) + locfn=efield_lflux_file + +!------------------------------------------------------------------ +! open datafile with coefficients A_klnm +!------------------------------------------------------------------ +! write(iulog,*) 'read_acoef: open file ',trim(locfn), +! &' unit ',unit + open(unit=unit,file=trim(locfn), + & status = 'old',iostat = ios) +! if(ios.gt.0) then +! write(iulog,*) +! &'read_acoef: error in opening coeff_lf file', +! &' unit ',unit +! call endrun +! end if + +!---------------------------------------------------------------------------- +! read datafile with coefficients A_klnm +!-------------------------------------------------------------------- +! write(iulog,*) 'read_acoef: read file ',trim(locfn),' unit ',unit + read(unit,*,iostat = ios) a_lf +! if(ios.gt.0) then +! write(iulog,*) +! &'read_acoef: error in reading coeff_lf file',' unit ',unit +! call endrun +! end if + +!-------------------------------------------------------------------- +! close & free unit +!-------------------------------------------------------------------- + close(unit) +! call freeunit(unit) +! write(iulog,*) 'read_acoef: free unit ',unit + +!-------------------------------------------------------------------- +! get coefficients file for solar maximum: +!-------------------------------------------------------------------- +! unit = getunit() + unit = 10 +! call getfil( efield_hflux_file, locfn, 0 ) + locfn= efield_hflux_file + +!------------------------------------------------------------------- +! open datafile with coefficients A_klnm +!------------------------------------------------------------------ +! write(iulog,*) 'read_acoef: open file ',trim(locfn),' unit ',unit + open(unit=unit,file=trim(locfn), + & status = 'old',iostat = ios) +! if(ios.gt.0) then +! write(iulog,*) +! &'read_acoef: error in opening coeff_hf file',' unit ',unit +! call endrun +! end if + +!----------------------------------------------------------------- +! read datafile with coefficients A_klnm +!---------------------------------------------------------------- +! write(iulog,*) 'read_acoef: read file ',trim(locfn) + read(unit,*,iostat = ios) a_hf +! if(ios.gt.0) then +! write(iulog,*) +! &'read_acoef: error in reading coeff_hf file',' unit ',unit +! call endrun +! end if + +!--------------------------------------------------------------- +! close & free unit +!-------------------------------------------------------------- + close(unit) +! call freeunit(unit) +! write(iulog,*) 'read_acoef: free unit ',unit + + end subroutine read_acoef + + subroutine adj_S_a +!------------------------------------------------------------------ +! adjust S_a -> S_aM eqn.8-11 Scherliess draft +!------------------------------------------------------------------ + + implicit none + +!----------------------------------------------------------------- +! local variables +!------------------------------------------------------------------ + integer :: i + real :: x2, y2, a90, a180, S_aM + + x2 = 90.*90. + y2 = (90. - 65.) + y2 = y2*y2 + a90 = atan2(y2,x2) + y2 = (180. - 65.) + y2 = y2*y2 + a180 = atan2(y2,x2) +! y2 = (S_a-65.) + y2 = (f107d - 65.) + y2 = y2*y2 + S_aM = (atan2(y2,x2) - a90)/(a180 - a90) + S_aM = 90.*(1. + S_aM) +! if(debug) write(iulog,*) 'f107d=',f107d,' S_aM =',S_aM +! if(debug) write(iulog,*) 'By=',by + +!----------------------------------------------------------------- +! inter/extrapolate to S_a (f107d) +!---------------------------------------------------------------- + do i = 0,ni ! eqn.8 Scherliess draft + a_klnm(i) = S_aM*(a_hf(i)-a_lf(i))/90.+ + &2.*a_lf(i)- a_hf(i) +! for testing like in original code +! a_klnm(i)=S_a*(a_hf(i)-a_lf(i))/90.+2.*a_lf(i)-a_hf(i) +! a_klnm(i)=f107d*(a_hf(i)-a_lf(i))/90.+2.*a_lf(i)-a_hf(i) + end do + + end subroutine adj_S_a + + subroutine constants +!--------------------------------------------------------------- +! Purpose: set up constant values (e.g. magnetic grid, convertion +! constants etc) +! +! Method: +! +! Author: A. Maute Nov 2003 am 11/19/03 +!-------------------------------------------------------------------- + +!------------------------------------------------------------------- +! local variables +!-------------------------------------------------------------------- + integer :: i,j + real :: fac,lat + + rtd = 180./pi ! radians -> deg + dtr = pi/180. ! deg -> radians + sqr2 = sqrt(2.e0) + hr2rd = pi/12. ! pi/12 hrs + dy2rd = 2.*pi/dy2yr ! 2*pi/365.24 average year + deg2mlt = 24./360. ! convert degrees to MLT hours + mlt2deg = 360./24. ! for mlt to mlon + +!------------------------------------------------------------------- +! Set grid deltas: +!------------------------------------------------------------------- + dlatm = 180./nmlat + dlonm = 360./nmlon + +!------------------------------------------------------------------- +! Set magnetic latitude array +!------------------------------------------------------------------- + do j = 0,nmlat + ylatm(j) = j*dlatm + lat = (ylatm(j) - 90.)*dtr + fac = cos(lat) ! sinIm = 2*sin(lam_m)/sqrt[4-3*cos^2(lam_m)] + fac = 4. - 3.*fac*fac + fac = 2./sqrt( fac ) + sinIm_mag(j) = fac*sin( lat ) + end do + +!------------------------------------------------------------------ +! Set magnetic longitude array +!------------------------------------------------------------------ + do i = 0,nmlon + ylonm(i) = i*dlonm + end do ! i=1,nmlonp1 + +!----------------------------------------------------------------- +! find boundary index for weimer +!------------------------------------------------------------------ + do j = 0,nmlat + nmlat_wei = j + if( bnd_wei <= ylatm(j) ) then + exit + end if + end do + +!------------------------------------------------------------------- +! find latitudinal shift +!------------------------------------------------------------------- + do j = 0,nmlat + ilat_sft = j + if( lat_sft <= ylatm(j) ) then + exit + end if + end do + +!------------------------------------------------------------------ +! find index for linear interpolation of ed2 at mag.equator +! use 12 deg - same as in TIEGCM +!------------------------------------------------------------------ + do j = 0,nmlat + lat = ylatm(j) - 90. + if( lat <= -12. ) then + jmin = j + else if( lat > 12. ) then + jmax = j + exit + end if + end do + + end subroutine constants + + subroutine prep_fk +!------------------------------------------------------------------- +! Purpose: set up constants factors for f_-k(day) used for empirical model +! to calculate the electric potential +! +! Method: +! +! Author: A. Maute Nov 2003 am 11/19/03 +!------------------------------------------------------------------- + + ft(1,0) = .75*sqrt( 6.e0 )/pi + ft(1,1) = 2.e0*ft(1,0) + ft(1,2) = 1.e0 + ft(2,0) = ft(1,0) + ft(2,1) = -ft(1,1) + ft(2,2) = 1.e0 + ft(3,0) = ft(2,1) + ft(3,1) = 0. + ft(3,2) = 1.e0 + + end subroutine prep_fk + + subroutine set_fkflfs( fk, fl, fs ) +!------------------------------------------------------------------ +! Purpose: set f_-k(day) depending on seasonal flag used for empirical model +! to calculate the electric potential +! +! Method: +! +! Author: A. Maute Nov 2003 am 11/20/03 +!----------------------------------------------------------------- + +!----------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------- + real, intent(out) :: + & fk(0:2), ! f_-k(day) + & fl(-2:2), ! f_l(ut) + & fs(2) ! f_s(f10.7) +!------------------------------------------------------------------ +! local variables +!------------------------------------------------------------------- + integer :: lp + real :: ang + real :: lon_ut + +!------------------------------------------------------------------ +! f_-k(day) +! use factors for iseasav == 0 - Scherliess had iseasav as an input parameter +!------------------------------------------------------------------ + lp = iseasav + if( iseasav == 0 ) then + ang = (day + 9.)*dy2rd + fk(0) = sqr2*cos( 2.*ang ) + fk(1) = sqr2*cos( ang ) + fk(2) = 1. + else if( iseasav >= 1 .and. iseasav <= 3 ) then + fk(0) = ft(lp,0) + fk(1) = ft(lp,1) + fk(2) = ft(lp,2) + else if( iseasav == 4 ) then + fk(0) =0. + fk(1) =0. + fk(2) =1. + end if + +!----------------------------------------------------------------- +! f_l(ut) +!----------------------------------------------------------------- + lon_ut = 15.*ut ! 15.*mlt - xmlon + 69. + call ff( lon_ut, 2, fl ) + if( iutav ) then ! UT-averaging + + ang = fl(0) + fl(:) = 0. + fl(0) = ang + + end if + +!----------------------------------------------------------------- +! f_s(f10.7) only fs(1) used +!----------------------------------------------------------------- + fs(1) = 1. +! fs(2) = S_a + fs(2) = f107d + + end subroutine set_fkflfs + + subroutine efield_mid( mlat, mlon, pot ) +!------------------------------------------------------------------ +! Purpose: calculate the electric potential for low and +! midlatitudes from an empirical model (Scherliess 1999) +! +! Method: +! +! Author: A. Maute Nov 2003 am 11/20/03 +!------------------------------------------------------------------- + +!------------------------------------------------------------------ +! ... dummy arguments +!------------------------------------------------------------------- + real, intent(in) :: mlat, mlon + real, intent(out) :: pot ! electric potential (V) + +!------------------------------------------------------------------- +! local variables +!------------------------------------------------------------------- + integer :: i, mp, np, nn + real :: mod_mlat, ct, x + real :: fk(0:2) ! f_-k(day) + real :: fl(-2:2) ! f_l(ut) + real :: fs(2) ! f_s(f10.7) + real :: f(-18:18) + real :: p(0:nm,0:mm) ! P_n^m spherical harmonics + + pot = 0. ! initialize + + mod_mlat = mlat + if( abs(mlat) <= 0.5 ) then + mod_mlat = 0.5 ! avoid geomag.equator + end if + +!------------------------------------------------------------------ +! set f_-k, f_l, f_s depending on seasonal flag +!------------------------------------------------------------------ + call set_fkflfs( fk, fl, fs ) + +!------------------------------------------------------------------ +! spherical harmonics +!------------------------------------------------------------------ + ct = cos( (90. - mod_mlat)*dtr ) ! magnetic colatitude + call pnm( ct, p ) ! calculate P_n^m + call ff( mlon, 18, f ) ! calculate f_m (phi) why 18 if N=12 + + do i = 0,imax + mp = mf(i) + np = nf(i) + nn = abs(mp) ! P_n^m = P_n^-m + x = a_klnm(i)* fl(lf(i)) * fk(kf(i)) * fs(jf(i)) + pot = pot + x*f(mp)*p(np,nn) + end do + + end subroutine efield_mid + + subroutine prep_weimer +!----------------------------------------------------------------- +! Purpose: for Weimer model calculate IMF angle, IMF magnitude +! tilt of earth +! +! Method: using functions and subroutines from Weimer Model 1996 +! output: angle, & ! IMF angle +! bt, & ! IMF magnitude +! tilt ! tilt of earth +! +! Author: A. Maute Nov 2003 am 11/20/03 +!----------------------------------------------------------------- + +!----------------------------------------------------------------- +! local variables +!----------------------------------------------------------------- + real :: + & angle, ! IMF angle + & bt, ! IMF magnitude + & tilt ! tilt of earth + +!----------------------------------------------------------------- +! function declarations +!----------------------------------------------------------------- + real, external :: get_tilt ! in wei96.f + + if( by == 0. .and. bz == 0.) then + angle = 0. + else + angle = atan2( by,bz ) + end if + + angle = angle*rtd + call adjust( angle ) + bt = sqrt( by*by + bz*bz ) +!------------------------------------------------------------------- +! use month and day of month - calculated with average no.of days per month +! as in Weimer +!------------------------------------------------------------------- +! if(debug) write(iulog,*) 'prep_weimer: day->day of month', +! &iday,imo,iday_m,ut + tilt = get_tilt( iyear, imo, iday_m, ut ) + +! if(debug) then +! write(iulog,"(/,'efield prep_weimer:')") +! write(iulog,*) ' Bz =',bz +! write(iulog,*) ' By =',by +! write(iulog,*) ' Bt =',bt +! write(iulog,*) ' angle=',angle +! write(iulog,*) ' VSW =',v_sw +! write(iulog,*) ' tilt =',tilt +! end if + + call SetModel( angle, bt, tilt, v_sw ) + + end subroutine prep_weimer + + subroutine pot_latsmo( pot, idlat ) ! pots == pot_highlats +!-------------------------------------------------------------------- +! Purpose: smoothing in latitude of potential +! +! Method: weighted smoothing in latitude +! assume regular grid spacing +! +! Author: A. Maute Nov 2003 am 11/20/03 +!------------------------------------------------------------------- + +!------------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------------- + integer, intent(in) :: idlat + real, intent(inout) :: pot(0:nmlon,0:nmlat) + +!------------------------------------------------------------------- +! local variables +!------------------------------------------------------------------ + integer :: ilon, ilat, id + real :: wgt, del + real :: w(-idlat:idlat) +! real :: pot_smo(0:nmlat) ! temp array for smooth. potential + real :: pot_smo(0:nmlon,0:nmlat_wei) ! temp array for smooth. potential + +!------------------------------------------------------------------ +! weighting factors (regular grid spacing) +!------------------------------------------------------------------ + wgt = 0. + do id = -idlat,idlat + del = abs(id)*dlatm ! delta lat_m + w(id) = 1./(del + 1.) + wgt = wgt + w(id) + end do + wgt = 1./wgt + +! do ilon = 0,nmlon +! do ilat = idlat,nmlat_wei-idlat +! do ilat = idlat,nmlat-idlat +! pot_smo(ilat) = 0. +! do id = -idlat,idlat ! org. was degree now grid points +! pot_smo(ilat) = pot_smo(ilat) + w(id)*pot(ilon,ilat+id) +! write(iulog,"('pot_latsmo: ilon=',i3,' ilat=',i3,' id=',i3,' pot(ilon,ilat+id)=',e12.4)") ilon,ilat,id,pot(ilon,ilat+id) +! end do +! pot_smo(ilat) = pot_smo(ilat)*wgt +! pot_smo(nmlat-ilat) = pot_smo(ilat) +! end do +! pot(ilon,idlat:nmlat-idlat) = & ! copy back into pot +! pot_smo(idlat:nmlat-idlat) +! pot(ilon,idlat:nmlat_wei-idlat) = pot_smo(idlat:nmlat_wei-idlat) +! pot(ilon,nmlat-nmlat_wei+idlat:nmlat) = pot_smo(nmlat-nmlat_wei+idlat:nmlat) +! pot(ilon,nmlat-nmlat_wei+idlat:nmlat-idlat) = pot_smo(nmlat-nmlat_wei+idlat:nmlat-idlat) +! end do + +!$omp parallel do private(ilat) + do ilat = idlat,nmlat_wei-idlat + pot_smo(:,ilat) = matmul( pot(:,ilat-idlat:ilat+idlat),w )*wgt + end do + + do ilat = idlat,nmlat_wei-idlat + pot(:,ilat) = pot_smo(:,ilat) + pot(:,nmlat-ilat) = pot_smo(:,ilat) + end do + + end subroutine pot_latsmo + + subroutine pot_latsmo2( pot, idlat ) +!------------------------------------------------------------------ +! Purpose: smoothing in latitude of potential +! +! Method: weighted smoothing in latitude +! assume regular grid spacing +! +! Author: A. Maute Nov 2003 am 11/20/03 +!------------------------------------------------------------------ + +!------------------------------------------------------------------ +! ... dummy arguments +!------------------------------------------------------------------ + integer, intent(in) :: idlat + real, intent(inout) :: pot(0:nmlon,0:nmlat) + +!------------------------------------------------------------------ +! local variables +!------------------------------------------------------------------ + integer :: ilon, ilat, id + real :: wgt, del + real :: w(-idlat:idlat) +! real :: pot_smo(0:nmlat) ! temp array for smooth. potential + real :: pot_smo(0:nmlon,0:nmlath) ! temp array for smooth. potential + +!------------------------------------------------------------------- +! weighting factors (regular grid spacing) +!------------------------------------------------------------------- + wgt = 0. + do id = -idlat,idlat + del = abs(id)*dlatm ! delta lat_m + w(id) = 1./(del + 1.) + wgt = wgt + w(id) + end do + wgt = 1./wgt + +! do ilon = 0,nmlon +! do ilat = idlat,nmlath-idlat ! ilat = 5:175 +! pot_smo(ilat) = 0. +! do id = -idlat,idlat ! org. was degree now grid points +! pot_smo(ilat) = pot_smo(ilat) + w(id)*pot(ilon,ilat+id) +! end do +! pot_smo(ilat) = pot_smo(ilat)*wgt +! end do +! pot(ilon,idlat:nmlath-idlat) = pot_smo(idlat:nmlath-idlat) ! copy back into pot +! end do + +!$omp parallel do private(ilat) + do ilat = idlat,nmlath-idlat + pot_smo(:,ilat) = matmul( pot(:,ilat-idlat:ilat+idlat),w )*wgt + end do + + do ilat = idlat,nmlath-idlat + pot(:,ilat) = pot_smo(:,ilat) + end do + + end subroutine pot_latsmo2 + + subroutine pot_lonsmo( pot, idlon ) +!------------------------------------------------------------------- +! Purpose: smoothing in longitude of potential +! +! Method: weighted smoothing in longitude +! assume regular grid spacing +! +! Author: A. Maute Nov 2003 am 11/20/03 +!------------------------------------------------------------------- + +!------------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------------- + integer, intent(in) :: idlon + real, intent(inout) :: pot(0:nmlon,0:nmlat) + +!------------------------------------------------------------------- +! local variables +!------------------------------------------------------------------- + integer :: ilon, ilat, id, iabs + real :: wgt, del + real :: w(-idlon:idlon) + real :: pot_smo(0:nmlath) ! temp array for smooth. potential + real :: tmp(-idlon:nmlon+idlon) ! temp array for smooth. potential + +!------------------------------------------------------------------- +! weighting factors (regular grid spacing) +!------------------------------------------------------------------- + wgt = 0. + do id = -idlon,idlon + del = abs(id)*dlonm ! delta lon_m + w(id) = 1./(del + 1.) + wgt = wgt + w(id) + end do + wgt = 1./wgt + +!------------------------------------------------------------------- +! averaging +!------------------------------------------------------------------- +! do ilon = 0,nmlon +! do ilat = 0,nmlath +! pot_smo(ilat) = 0. +! do id = -idlon,idlon ! org. was degree now grid points +! iabs = ilon + id +! if( iabs > nmlon ) then +! iabs = iabs - nmlon ! test if wrap around +! end if +! if( iabs < 0 ) then +! iabs = iabs + nmlon ! test if wrap around +! end if +! pot_smo(ilat) = pot_smo(ilat) + w(id)*pot(iabs,ilat) +! end do +! pot_smo(ilat) = pot_smo(ilat)*wgt +! pot(ilon,ilat) = pot_smo(ilat) ! copy back into pot +! pot(ilon,nmlat-ilat) = pot_smo(ilat) ! copy back into pot +! end do +! end do +! print*,'www7','pot_efield',pot(149,66),idlon,w + +!$omp parallel do private(ilat,ilon,tmp) + do ilat = 0,nmlath + tmp(0:nmlon) = pot(0:nmlon,ilat) + tmp(-idlon:-1) = pot(nmlon-idlon:nmlon-1,ilat) + tmp(nmlon+1:nmlon+idlon) = pot(1:idlon,ilat) + do ilon = 0,nmlon + pot(ilon,ilat)=dot_product(tmp(ilon-idlon:ilon+idlon),w)*wgt + pot(ilon,nmlat-ilat) = pot(ilon,ilat) +! if(ilon.eq.149.and.nmlat-ilat.eq.66) +! &print*,'www9',pot(ilon,nmlat-ilat),tmp(ilon-idlon:ilon+idlon),wgt + end do + end do +! print*,'www8','pot_efield',pot(149,66) + + end subroutine pot_lonsmo + + subroutine highlat_getbnd( ihlat_bnd ) +!------------------------------------------------------------------ +! Purpose: calculate the height latitude bounday index ihl_bnd +! +! Method: +! 1. calculate E field from weimar model +! boundary is set where the total electric field exceeds +! 0.015 V/m (corresp. approx. to 300 m/s) +! 2. moved halfways to 54 deg not necessarily equatorwards as in the +! original comment from L. Scherliess- or? +! +! Author: A. Maute Nov 2003 am 11/20/03 +!------------------------------------------------------------------- + +!------------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------------- + integer, intent(out) :: ihlat_bnd(0:nmlon) + +!------------------------------------------------------------------ +! local variables +!------------------------------------------------------------------ + integer :: ilon, ilat, ilat_sft_rvs + real :: mlat, mlt, es, ez, e_tot + + ilat_sft_rvs = nmlath - ilat_sft ! pole =0, equ=90 +!$omp parallel do private(ilat,ilon,mlt,mlat,es,ez,e_tot) + do ilon = 0,nmlon ! long. + ihlat_bnd(ilon) = 0 + mlt = ylonm(ilon)*deg2mlt ! mag.local time ? + do ilat = nmlat_wei+1,0,-1 ! lat. loop moving torwards pole + mlat = 90. - ylatm(ilat) ! mag. latitude pole = 90 equator = 0 + call gecmp( mlat, mlt, es, ez ) ! get electric field + e_tot = sqrt( es**2 + ez**2 ) + if( abs(e_tot) >= ef_max ) then ! e-filed > limit -> boundary + ihlat_bnd(ilon) = ilat - (ilat - ilat_sft_rvs)/2 ! shift boundary to lat_sft (54deg) + exit + end if + end do + end do + +! write(iulog,"('highlat_getbnd: ihlat_bnd=',/,(12i6))") ihlat_bnd + + end subroutine highlat_getbnd + + subroutine bnd_sinus( ihlat_bnd, itrans_width ) +!------------------------------------------------------------------ +! Purpose: +! 1. adjust high latitude boundary (ihlat_bnd) sinusoidally +! 2. width of transition zone from midlatitude potential to high latitude +! potential (itrans_width) +! +! Method: +! 1.adjust boundary sinusoidally +! max. wave number to be represented nmax_sin +! RHS(mi) = Sum_phi Sum_(mi=-nmax_sin)^_(mi=nmax_sin) f_mi(phi)*hlat_bnd(phi) +! U(mi,mk) = Sum_phi Sum_(mi=-nmax_sin)^_(mi=nmax_sin) f_mi(phi) * +! Sum_(mk=-nmax_sin)^_(mk=nmax_sin) f_mk(phi) +! single values decomposition of U +! solving U*LSG = RHS +! calculating hlat_bnd: +! hlat_bnd = Sum_(mi=-nmax_sin)^_(mi=nmax_sin) f_mi(phi)*LSG(mi) +! +! 2. width of transition zone from midlatitude potential to high latitude +! potential +! trans_width(phi)=8.-2.*cos(phi) +! +! Author: A. Maute Nov 2003 am 11/20/03 +!------------------------------------------------------------------ + +! use sv_decomp, only : svdcmp, svbksb + +!---------------------------------------------------------------------------- +! ... dummy arguments +!---------------------------------------------------------------------------- + integer, intent(inout) :: ihlat_bnd(0:nmlon) ! loaction of boundary + integer, intent(out) :: itrans_width(0:nmlon) ! width of transition zone + +!----------------------------------------------------------------- +! local variables +!----------------------------------------------------------------- + integer, parameter :: nmax_a = 2*nmax_sin+1 ! absolute array length + integer, parameter :: ishf = nmax_sin+1 + integer :: ilon, i, i1, j, bnd + real :: sum, mlon + real :: rhs(nmax_a) + real :: lsg(nmax_a) + real :: u(nmax_a,nmax_a) + real :: v(nmax_a,nmax_a) + real :: w(nmax_a,nmax_a) + real :: f(-nmax_sin:nmax_sin,0:nmlon) + +!------------------------------------------------------------------ +! Sinusoidal Boundary calculation +!------------------------------------------------------------------ + rhs(:) = 0. + lsg(:) = 0. + u(:,:) = 0. + v(:,:) = 0. + w(:,:) = 0. + + do ilon = 0,nmlon ! long. + bnd = nmlath - ihlat_bnd(ilon) ! switch from pole=0 to pole =90 + call ff( ylonm(ilon), nmax_sin, f(-nmax_sin,ilon) ) + do i = -nmax_sin,nmax_sin + i1 = i + ishf + rhs(i1) = rhs(i1) + f(i,ilon) * bnd +! write(iulog,*) 'rhs ',ilon,i1,bnd,f(i,ilon),rhs(i+ishf) + do j = -nmax_sin,nmax_sin + u(i1,j+ishf) = u(i1,j+ishf) + f(i,ilon)*f(j,ilon) +! write(iulog,*) 'u ',ilon,i1,j+ishf,u(i+ishf,j+ishf) + end do + end do + end do + +! if (debug) write(iulog,*) ' Single Value Decomposition' + call svdcmp( u, nmax_a, nmax_a, nmax_a, nmax_a, w, v ) + +! if (debug) write(iulog,*) ' Solving' + call svbksb( u, w, v, nmax_a, nmax_a, nmax_a, nmax_a, rhs, lsg ) +! + do ilon = 0,nmlon ! long. +! sum = 0. + sum = dot_product( lsg(-nmax_sin+ishf:nmax_sin+ishf), + &f(-nmax_sin:nmax_sin,ilon) ) +! do i = -nmax_sin,nmax_sin +! sum = sum + lsg(i+ishf)*f(i,ilon) +! end do + ihlat_bnd(ilon) = nmlath - int( sum + .5 ) ! closest point + itrans_width(ilon) = + &int( 8. - 2.*cos( ylonm(ilon)*dtr ) + .5 )/dlatm ! 6 to 10 deg. + end do +! write(iulog,"('bnd_sinus: ihlat_bnd=',/,(12i6))") ihlat_bnd +! write(iulog,"('bnd_sinus: itrans_width=',/,(12i6))") itrans_width + + end subroutine bnd_sinus + + subroutine highlat_adjust( pot_highlats, pot_highlat, + &pot_midlat, ihlat_bnd ) +!------------------------------------------------------------------ +! Purpose: Adjust mid/low latitude electric potential and high latitude +! potential such that there are continous across the mid to high +! latitude boundary +! +! Method: +! 1. integrate Phi_low/mid(phi,bnd) along the boundary mid to high latitude +! 2. integrate Phi_high(phi,bnd) along the boundary mid to high latitude +! 3. adjust Phi_high by delta = +! Int_phi Phi_high(phi,bnd) d phi/360. - Int_phi Phi_low/mid(phi,bnd) d phi/360. +! +! Author: A. Maute Nov 2003 am 11/21/03 +!------------------------------------------------------------------ + +!------------------------------------------------------------------ +! ... dummy arguments +!------------------------------------------------------------------ + integer, intent(in) :: ihlat_bnd(0:nmlon) ! boundary mid to high latitude + real, intent(in) :: pot_midlat(0:nmlon,0:nmlat) ! low/mid latitude potentail + real, intent(inout) :: pot_highlat(0:nmlon,0:nmlat)! high_lat potential + real, intent(inout) :: pot_highlats(0:nmlon,0:nmlat)! high_lat potential! smoothed high_lat potential + +!------------------------------------------------------------------ +! local: +!------------------------------------------------------------------ + integer :: bnd, ilon, ilat, ilatS, ibnd60, ibnd_hl + real :: pot60, pot_hl, del + +!------------------------------------------------------------------- +! 1. integrate Phi_low/mid(phi,bnd) along the boundary mid to high latitude +! 2. integrate Phi_high(phi,bnd) along the boundary mid to high latitude +!------------------------------------------------------------------- + pot60 = 0. + pot_hl = 0. + do ilon = 1,nmlon ! long. ! bnd -> eq to pole 0:90 + ibnd60 = nmlat - ihlat_bnd(ilon) ! 0:180 pole to pole + ibnd_hl = ihlat_bnd(ilon) ! colatitude + pot60 = pot60 + pot_midlat(ilon,ibnd60) + pot_hl = pot_hl + pot_highlats(ilon,ibnd_hl) + end do + pot60 = pot60/(nmlon) + pot_hl = pot_hl/(nmlon) +! print*,'www300',pot60,pot_hl,nmlat_wei,nmlon + +! if (debug) write(iulog,*) 'Mid-Latitude Boundary Potential =', +! &pot60 +! if (debug) write(iulog,*) 'High-Latitude Boundary Potential=', +! &pot_hl + +!------------------------------------------------------------------- +! 3. adjust Phi_high by delta = +! Int_phi Phi_high(phi,bnd) d phi/360. - Int_phi Phi_low/mid(phi,bnd) d phi/360. +!------------------------------------------------------------------- + del = pot_hl - pot60 + +!$omp parallel do private(ilat,ilon,ilats) + do ilat = 0,nmlat_wei ! colatitude + ilats = nmlat - ilat + do ilon = 0,nmlon + pot_highlat(ilon,ilat) = pot_highlat(ilon,ilat) - del + pot_highlat(ilon,ilats) = pot_highlat(ilon,ilats) - del + pot_highlats(ilon,ilat) = pot_highlats(ilon,ilat) - del + pot_highlats(ilon,ilats) = pot_highlats(ilon,ilats) - del + end do + end do + + end subroutine highlat_adjust + + subroutine interp_poten( pot_highlats, pot_highlat, pot_midlat, + &ihlat_bnd, itrans_width ) +!------------------------------------------------------------------- +! Purpose: construct a smooth global electric potential field +! +! Method: construct one global potential field +! 1. low/mid latitude: |lam| < bnd-trans_width +! Phi(phi,lam) = Phi_low(phi,lam) +! 2. high latitude: |lam| > bnd+trans_width +! Phi(phi,lam) = Phi_hl(phi,lam) +! 3. transition zone: bnd-trans_width <= lam <= bnd+trans_width +! a. interpolate between high and low/midlatitude potential +! Phi*(phi,lam) = 1/15*[ 5/(2*trans_width) * {Phi_low(phi,bnd-trans_width)* +! [-lam+bnd+trans_width] + Phi_hl(phi,bnd+trans_width)* +! [lam-bnd+trans_width]} + 10/(2*trans_width) {Phi_low(phi,lam)* +! [-lam+bnd+trans_width] + Phi_hl(phi,lam)* +! [lam-bnd+trans_width]}] +! b. Interpolate between just calculated Potential and the high latitude +! potential in a 3 degree zone poleward of the boundary: +! bnd+trans_width < lam <= bnd+trans_width+ 3 deg +! Phi(phi,lam) = 1/3 { [3-(lam-bnd-trans_width)]* Phi*(phi,lam) + +! [lam-bnd-trans_width)]* Phi_hl*(phi,lam) } +! +! Author: A. Maute Nov 2003 am 11/21/03 +!------------------------------------------------------------------ + +!------------------------------------------------------------------ +! ... dummy arguments +!------------------------------------------------------------------ + integer, intent(in) :: ihlat_bnd(0:nmlon) + integer, intent(in) :: itrans_width(0:nmlon) + real, intent(in) :: pot_highlats(0:nmlon,0:nmlat) + real, intent(in) :: pot_highlat(0:nmlon,0:nmlat) + real, intent(in) :: pot_midlat(0:nmlon,0:nmlat) + +!------------------------------------------------------------------- +! local variables +!------------------------------------------------------------------- + real, parameter :: fac = 1./3. + integer :: ilon, ilat + integer :: ibnd, tw, hb1, hb2, lat_ind + integer :: j1, j2 + real :: a, b, lat, b1, b2 + real :: wrk1, wrk2 + +!$omp parallel do private(ilat,ilon,ibnd,tw) + do ilon = 0,nmlon + ibnd = ihlat_bnd(ilon) ! high latitude boundary index + tw = itrans_width(ilon) ! width of transition zone (index) +!------------------------------------------------------------------- +! 1. low/mid latitude: |lam| < bnd-trans_width +! Phi(phi,lam) = Phi_low(phi,lam) +!------------------------------------------------------------------- + do ilat = 0,nmlath-(ibnd+tw+1) + potent(ilon,nmlath+ilat) = pot_midlat(ilon,nmlath+ilat) + potent(ilon,nmlath-ilat) = pot_midlat(ilon,nmlath+ilat) + end do +!------------------------------------------------------------------ +! 2. high latitude: |lam| > bnd+trans_width +! Phi(phi,lam) = Phi_hl(phi,lam) +!------------------------------------------------------------------ + do ilat = 0,ibnd-tw-1 + potent(ilon,ilat) = pot_highlats(ilon,nmlat-ilat) + potent(ilon,nmlat-ilat) = pot_highlats(ilon,nmlat-ilat) + end do + end do +!------------------------------------------------------------------ +! 3. transition zone: bnd-trans_width <= lam <= bnd+trans_width +!------------------------------------------------------------------ +! a. interpolate between high and low/midlatitude potential +! update only southern hemisphere (northern hemisphere is copied +! after smoothing) +!------------------------------------------------------------------ +!!$omp parallel do private(ilat,ilon,ibnd,tw,a,b,b1,b2,hb1,hb2, +! &lat_ind,j1,j2,wrk1,wrk2) + do ilon = 0,nmlon + ibnd = ihlat_bnd(ilon) ! high latitude boundary index + tw = itrans_width(ilon) ! width of transition zone (index) + a = 1./(2.*tw) + b1 = (nmlath - ibnd + tw)*a + b2 = (nmlath - ibnd - tw)*a + hb1 = nmlath - (ibnd + tw) + j1 = nmlath - hb1 + hb2 = nmlath - (ibnd - tw) + j2 = nmlath - hb2 + wrk1 = pot_midlat(ilon,j1) + wrk2 = pot_highlats(ilon,j2) +! write(iulog,*) 'pot_all ',ilon,hb1,hb2,nmlath -ibnd,tw + do ilat = ibnd-tw,ibnd+tw + lat_ind = nmlath - ilat + potent(ilon,ilat) = + & fac*((wrk1 + 2.*pot_midlat(ilon,ilat))*(b1 - a*lat_ind) + & + (wrk2 + 2.*pot_highlats(ilon,ilat))*(a*lat_ind - b2)) + potent(ilon,nmlat-ilat) = potent(ilon,ilat) + end do +!------------------------------------------------------------------ +! b. Interpolate between just calculated Potential and the high latitude +! potential in a 3 degree zone poleward of the boundary +!------------------------------------------------------------------ + do ilat = hb2+1,nmlath + a = max( 3./dlatm - (ilat - hb2 - 1),0. ) + b = 3./dlatm - a + potent(ilon,nmlath-ilat) = (a*potent(ilon,nmlath-ilat) + & + b*pot_highlat(ilon,nmlath-ilat))/3.*dlatm + potent(ilon,nmlath+ilat) = potent(ilon,nmlath-ilat) + end do + end do + + end subroutine interp_poten + + subroutine DerivPotential +!----------------------------------------------------------------- +! Purpose: calulates the electric field [V/m] from the electric potential +! +! Method: Richmond [1995] eqn 5.9-5.10 +! ed1(:,:) = Ed1 = - 1/[R cos lam_m] d PHI/d phi_m +! ed2(:,:) = Ed2 = 1/R d PHI/d lam_m /sin I_m +! R = R_e + h_r we assume a reference height of 130 km which is also +! used in the TIEGCM code +! +! Author: A. Maute Dec 2003 am 12/16/03 +!----------------------------------------------------------------- + + integer :: i, j, ip1f, ip2f, ip3f + real :: coslm, r, fac, wrk + real :: wrk1d(0:nmlon) + + r = r_e + h_r ! earth radius + reference height [m] +!----------------------------------------------------------------- +! ed2= Ed2 is the equatorward/downward component of the electric field, at all +! geomagnetic grid points (central differencing) +!----------------------------------------------------------------- + fac = .5/(dlatm*dtr*r) +!$omp parallel do private(j, i, wrk ) + do j = 1,nmlath-1 ! southern hemisphere +! idea + wrk = fac/sinIm_mag(j) +! wrk = fac + do i = 0,nmlon + ed2(i,j) = (potent(i,j+1) - potent(i,j-1))*wrk + end do + end do + +!$omp parallel do private(j, i, wrk ) + do j = nmlath+1,nmlat-1 ! northern hemisphere + wrk = fac/sinIm_mag(j) + do i = 0,nmlon + ed2(i,j) = (potent(i,j+1) - potent(i,j-1))*wrk + end do + end do + +!----------------------------------------------------------------------- +! Interpolate of ed2 between between -12 <= lam_m <= 12 degrees: +!----------------------------------------------------------------------- + wrk1d(:) = ed2(:,jmax) - ed2(:,jmin) + do j = jmin+1,jmax-1 + fac = (ylatm(j) - ylatm(jmin))/(ylatm(jmax) - ylatm(jmin)) + do i = 0,nmlon + ed2(i,j) = ed2(i,jmin) + fac*wrk1d(i) + end do + end do + +!----------------------------------------------------------------------- +! ed1= Ed1 is the zonal component of the electric field, at all +! geomagnetic grid points (central differencing) +!----------------------------------------------------------------------- + fac = .5/(dlonm*dtr*r) +!$omp parallel do private(j, i, wrk, coslm ) + do j = 1,nmlat-1 + coslm = ylatm(j) - 90. + coslm = cos( coslm*dtr ) + wrk = fac/coslm + do i = 1,nmlon-1 + ed1(i,j) = -(potent(i+1,j) - potent(i-1,j))*wrk + end do + i = 0 + ed1(i,j) = -(potent(i+1,j) - potent(nmlon-1,j))*wrk + ed1(nmlon,j) = ed1(i,j) + end do + +!----------------------------------------------------------------------- +! Poles: +!----------------------------------------------------------------------- + do i = 0,nmlon + ip1f = i + nmlon/4 + if( ip1f > nmlon ) then + ip1f = ip1f - nmlon + end if + ip2f = i + nmlon/2 + if( ip2f > nmlon ) then + ip2f = ip2f - nmlon + end if + ip3f = i + 3*nmlon/4 + if( ip3f > nmlon ) then + ip3f = ip3f - nmlon + end if + ed1(i,0)=.25*(ed1(i,1)-ed1(ip2f,1)+ed2(ip1f,1)-ed2(ip3f,1)) + ed1(i,nmlat) = .25*(ed1(i,nmlat-1) - ed1(ip2f,nmlat-1) + & + ed2(ip1f,nmlat-1) - ed2(ip3f,nmlat-1)) + ed2(i,0)=.25*(ed2(i,1)-ed2(ip2f,1)-ed1(ip1f,1)+ed1(ip3f,1)) + ed2(i,nmlat) = .25*(ed2(i,nmlat-1) - ed2(ip2f,nmlat-1) + & - ed1(ip1f,nmlat-1) + ed1(ip3f,nmlat-1)) + end do + + end subroutine DerivPotential + + end module efield +! +! Purpose: +! Subroutines to calculate the electric potentials from the Weimer '96 model of +! the polar cap ionospheric electric potentials. +! +! Method: +! +! To use, first call subroutine ReadCoef once. +! Next, call SetModel with the specified input parameters. +! The function EpotVal(gLAT,gMLT) can then be used repeatively to get the +! electric potential at the desired location in geomagnetic coordinates. +! Subroutines to calculate the electric potentials from the Weimer '96 model of +! the polar cap ionospheric electric potentials. +! +! +! Author: A. Maute Dec 2003 +! This code is protected by copyright and is +! distributed for research or educational use only. +! Commerical use without written permission from Dan Weimer/MRC is prohibited. +! +!*********************** Copyright 1996, Dan Weimer/MRC *********************** +!================================================================== + + FUNCTION EpotVal(gLAT,gMLT) +! +!----------------------------------------------------------------------- +! Return the value of the electric potential in kV at +! corrected geomagnetic coordinates gLAT (degrees) and gMLT (hours). +! +! Must first call ReadCoef and SetModel to set up the model coeficients for +! the desired values of Bt, IMF clock angle, Dipole tilt angle, and SW Vel. +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only: Coef =>Coef,ML=>ML,MM=>MM1 + implicit none +! +!-----------------------------Return Value------------------------------ +! + real EpotVal +! +!-------------------------------Commons--------------------------------- +! +! INTEGER ML,MM +! REAL Coef(0:1,0:8,0:3),pi +! COMMON/SetCoef/Coef,pi,ML,MM + real pi +! +!------------------------------Arguments-------------------------------- +! + REAL gLAT,gMLT +! +!---------------------------Local variables----------------------------- +! + integer limit,l,m + + Real Theta,Phi,Z,ct,Phim + real r + REAL Plm(0:20,0:20) +! +!----------------------------------------------------------------------- +! + pi=3.141592653 + r=90.-gLAT + IF(r .LT. 45.)THEN + Theta=r*pi/45. + Phi=gMLT*pi/12. + Z=Coef(0,0,0) + ct=COS(Theta) + CALL Legendre(ct,ML,MM,Plm) + DO l=1,ML + Z=Z + Coef(0,l,0)*Plm(l,0) + IF(l.LT.MM)THEN + limit=l + ELSE + limit=MM + ENDIF + DO m=1,limit + phim=phi*m + Z=Z + Coef(0,l,m)*Plm(l,m)*COS(phim) + + & Coef(1,l,m)*Plm(l,m)*SIN(phim) + ENDDO + ENDDO + ELSE + Z=0. + ENDIF + EpotVal=Z +! print*,'www0',Z,Coef,Plm,ct + RETURN + END FUNCTION EpotVal + +!================================================================================================ + + SUBROUTINE ReadCoef (wei96_file) +! +!----------------------------------------------------------------------- +! +! Read in the data file with the model coefficients +! +!*********************** Copyright 1996, Dan Weimer/MRC *********************** +! +! NCAR addition (Jan 97): initialize constants used in GECMP +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use ioFileMod, only : getfil +! use units, only : getunit, freeunit +! use abortutils, only : endrun +! use cam_logfile, only : iulog + use efield, only: ALAMN =>ALAMN,ALAMX=>ALAMX,ALAMR=>ALAMR, + &STPD=>STPD,STP2=>STP2,CSTP=>CSTP,SSTP=>SSTP, + &Cn=>Cn,MaxL=>MaxL,MaxM=>MaxM,MaxN=>MaxN + implicit none +! +!-------------------------------Commons--------------------------------- +! +! real alamn, alamx, alamr, stpd, stp2, cstp, sstp +! COMMON /CECMP/ ALAMN,ALAMX,ALAMR,STPD,STP2,CSTP,SSTP +! ALAMN = Absolute min latitude (deg) of model +! ALAMX = Absolute max latitude (deg) for normal gradient calc. +! STPD = Angular dist (deg) of step @ 300km above earth (r=6371km) +! STP2 = Denominator in gradient calc + +! +!------------------------------Arguments-------------------------------- +! + character(len=*), intent(in) :: wei96_file +! +!-----------------------------Parameters------------------------------ +! + real d2r, r2d + PARAMETER ( D2R = 0.0174532925199432957692369076847 , + & R2D = 57.2957795130823208767981548147) +! +!---------------------------Local variables----------------------------- +! + INTEGER udat,unit,ios + integer ll,mm,k,m,klimit,kk,nn,ii,i,n,ilimit,mlimit,l + + REAL C(0:3) + real stpr, step + + CHARACTER*15 skip + + INTEGER iulog +! INTEGER MaxL,MaxM,MaxN,iulog +! REAL Cn( 0:3 , 0:1 , 0:4 , 0:1 , 0:8 , 0:3 ) +! COMMON /AllCoefs/Cn,MaxL,MaxM,MaxN + + character(len=256) :: locfn +! +!----------------------------------------------------------------------- + iulog=14 + STEP = 10. + STPR = STEP/6671. + STPD = STPR*R2D + STP2 = 2.*STEP + CSTP = COS (STPR) + SSTP = SQRT (1. - CSTP*CSTP) + ALAMN = 45. + ALAMX = 90. - STPD + ALAMR = ALAMN*D2R +! End NCAR addition +! +! get coeff_file +! unit= getunit() + unit= 600 +! print*, 'Weimer: getting file ',trim(wei96_file), +! &' unit ',unit +! call getfil( wei96_file, locfn, 0 ) + locfn= wei96_file +! +! write(iulog,*) 'Weimer: opening file ',trim(locfn), +! &' unit ',unit +! OPEN(unit=unit,file=trim(locfn), + open(unit=unit,file=locfn,status = 'old',iostat = ios) + if(ios.gt.0) then + print*, 'Weimer: error in opening wei96.cofcnts', + &' unit ',unit +! call endrun + endif + 900 FORMAT(A15) +c1000 FORMAT(3I8) + 1000 format(3i8) + 2000 FORMAT(3I2) + 3000 FORMAT(2I2,4E15.6) +! READ(udat,900) skip +! write(iulog,*) 'Weimer: reading file ',trim(locfn), +! &' unit ',unit +! READ(unit,1000,iostat = ios) MaxL,MaxM,MaxN + read(unit,1000,iostat = ios) MaxL,MaxM,MaxN +! print*,'www0',ios,MaxL,MaxM,MaxN +! if(ios.gt.0) then +! write(iulog,*) +! &'ReadCoef: error in reading wei96.cofcnts file', +! &' unit ',unit +! call endrun +! endif + DO l=0,MaxL + IF(l.LT.MaxM)THEN + mlimit=l + ELSE + mlimit=MaxM + ENDIF + DO m=0,mlimit + IF(m.LT.1)THEN + klimit=0 + ELSE + klimit=1 + ENDIF + DO k=0,klimit + read(unit,2000,iostat = ios) ll,mm,kk +! print*,k,ll,mm,kk +! if(ios.gt.0) then +! write(iulog,*) +! &'ReadCoef: error in reading wei96.cofcnts file',' unit ', +! &unit +! call endrun +! endif +! IF(ll.NE.l .OR. mm.NE.m .OR. kk.NE.k)THEN +! WRITE(IULOG,*)'Data File Format Error' +! CALL ENDRUN +! ENDIF + DO n=0,MaxN + IF(n.LT.1)THEN + ilimit=0 + ELSE + ilimit=1 + ENDIF + DO i=0,ilimit + READ(unit,3000,iostat = ios) nn,ii,C +! print*,'www0',nn,ii,C,i,n,k,l,m +! if(ios.gt.0) then +! write(iulog,*) 'ReadCoef: error in reading', +! & ' wei96.cofcnts file',' unit ',unit +! call endrun +! endif +! IF(nn.NE.n .OR. ii.NE.i)THEN +! WRITE(IULOG,*)'Data File Format Error' +! CALL ENDRUN +! ENDIF + Cn(0,i,n,k,l,m)=C(0) + Cn(1,i,n,k,l,m)=C(1) + Cn(2,i,n,k,l,m)=C(2) + Cn(3,i,n,k,l,m)=C(3) + ENDDO + ENDDO + ENDDO + ENDDO + ENDDO +! + close(unit) +! call freeunit(unit) +! + RETURN + END SUBROUTINE ReadCoef + +!================================================================================================ + + FUNCTION FSVal(omega,MaxN,FSC) +! +!----------------------------------------------------------------------- +! Evaluate a Sine/Cosine Fourier series for N terms up to MaxN +! at angle omega, given the coefficients in FSC +! +!*********************** Copyright 1996, Dan Weimer/MRC *************** +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +!-----------------------------Return Value------------------------------ +! + real FSVal +! +!------------------------------Arguments-------------------------------- +! + INTEGER MaxN +! REAL omega,FSC(0:1,0:*) + REAL omega,FSC(0:1,0:4) +! +!---------------------------Local variables----------------------------- +! + INTEGER n + REAL Y,theta +! +!----------------------------------------------------------------------- +! + Y=0. + DO n=0,MaxN + theta=omega*n + Y=Y + FSC(0,n)*COS(theta) + FSC(1,n)*SIN(theta) + ENDDO + FSVal=Y +! print*,'www00',Y,FSC + RETURN + END FUNCTION FSVal + +!================================================================================================ + + SUBROUTINE SetModel(angle,Bt,Tilt,SWVel) +! +!----------------------------------------------------------------------- +! Calculate the complete set of spherical harmonic coefficients, +! given an arbitrary IMF angle (degrees from northward toward +Y), +! magnitude Bt (nT), dipole tilt angle (degrees), +! and solar wind velocity (km/sec). +! Returns the Coef in the common block SetCoef. +! +!*********************** Copyright 1996, Dan Weimer/MRC *********************** +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only: Cn=>Cn,MaxL=>MaxL,MaxM=>MaxM,MaxN=>MaxN + &,Coef=>coef,ML=>ML,MM=>MM1 + implicit none +! +!-------------------------------Commons--------------------------------- +! +! INTEGER MaxL,MaxM,MaxN +! REAL Cn( 0:3 , 0:1 , 0:4 , 0:1 , 0:8 , 0:3 ) +! COMMON /AllCoefs/Cn,MaxL,MaxM,MaxN + +! INTEGER ML,MM +! REAL Coef(0:1,0:8,0:3),pi +! COMMON/SetCoef/Coef,pi,ML,MM + real pi +! +!------------------------------Arguments-------------------------------- +! + REAL angle,Bt,Tilt,SWVel +! +!---------------------------Local variables----------------------------- +! + integer n, k, ilimit, i, klimit, l, m, mlimit + REAL FSC(0:1,0:4), fsval, omega, sintilt +! +!----------------------------------------------------------------------- +! + pi=3.141592653 + ML=MaxL + MM=MaxM + SinTilt=SIN(Tilt*pi/180.) +! SinTilt=SIND(Tilt) + + omega=angle*pi/180. + + fsc(1,0) = 0. + DO l=0,MaxL + IF(l.LT.MaxM)THEN + mlimit=l + ELSE + mlimit=MaxM + ENDIF + DO m=0,mlimit + IF(m.LT.1)THEN + klimit=0 + ELSE + klimit=1 + ENDIF + DO k=0,klimit +! Retrieve the regression coefficients and evaluate the function +! as a function of Bt,Tilt,and SWVel to get each Fourier coefficient. + DO n=0,MaxN + IF(n.LT.1)THEN + ilimit=0 + ELSE + ilimit=1 + ENDIF + DO i=0,ilimit + FSC(i,n)=Cn(0,i,n,k,l,m) + Bt*Cn(1,i,n,k,l,m) + + & SinTilt*Cn(2,i,n,k,l,m) + SWVel*Cn(3,i,n,k,l,m) + ENDDO + ENDDO +! Next evaluate the Fourier series as a function of angle. + Coef(k,l,m)=FSVal(omega,MaxN,FSC) + ENDDO + ENDDO + ENDDO +! print*,'www000',FSC(0,0),Cn,Bt,SinTilt,SWVel + RETURN + END SUBROUTINE SetModel + +!================================================================================================ + + SUBROUTINE LEGENDRE(x,lmax,mmax,Plm) +! +!----------------------------------------------------------------------- +! compute Associate Legendre Function P_l^m(x) +! for all l up to lmax and all m up to mmax. +! returns results in array Plm +! if X is out of range ( abs(x)>1 ) then value is returned as if x=1. +! +!*********************** Copyright 1996, Dan Weimer/MRC *********************** +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use cam_logfile, only : iulog + + implicit none +! +!------------------------------Arguments-------------------------------- +! + integer lmax, mmax + real x, Plm(0:20,0:20) +! +!---------------------------Local variables----------------------------- +! + integer m, lm2, l, iulog + real xx, fact + iulog=14 +! +!----------------------------------------------------------------------- +! + DO l=0,20 + DO m=0,20 + Plm(l,m)=0. + ENDDO + ENDDO + xx=MIN(x,1.) + xx=MAX(xx,-1.) +! IF(lmax .LT. 0 .OR. mmax .LT. 0 .OR. mmax .GT. lmax )THEN +! write(iulog,*)'Bad arguments to Legendre' +! RETURN +! ENDIF +! First calculate all Pl0 for l=0 to l + Plm(0,0)=1. + IF(lmax.GT.0)Plm(1,0)=xx + IF (lmax .GT. 1 )THEN + DO L=2,lmax + Plm(L,0)=( (2.*L-1)*xx*Plm(L-1,0) - + &(L-1)*Plm(L-2,0) )/L + ENDDO + ENDIF + IF (mmax .EQ. 0 )RETURN + fact=SQRT( (1.-xx)*(1.+xx) ) + DO M=1,mmax + DO L=m,lmax + lm2=MAX(L-2,0) + Plm(L,M)=Plm(lm2,M) - ( 2*L-1)*fact*Plm(L-1,M-1) + ENDDO + ENDDO + RETURN + END SUBROUTINE LEGENDRE + +!================================================================================================ + +!*********************** Copyright 1996, Dan Weimer/MRC *********************** + +!CC NCAR MODIFIED (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! The following routines (translib.for) were added to return the dipole tilt. C +! GET_TILT was initially a procedure (TRANS), here it has been changed into C +! a function which returns the dipole tilt. C +! Barbara Emery (emery@ncar.ucar.edu) and William Golesorkhi, HAO/NCAR (3/96) C +!CC NCAR MODIFIED (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +! COORDINATE TRANSFORMATION UTILITIES +!********************************************************************** + FUNCTION GET_TILT(YEAR,MONTH,DAY,HOUR) +! +!----------------------------------------------------------------------- +!CC NCAR MODIFIED (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! The following line initially was: C +! SUBROUTINE TRANS(YEAR,MONTH,DAY,HOUR,IDBUG) C +! It has been changed to return the dipole tilt from this function call. C +!CC NCAR MODIFIED (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! THIS SUBROUTINE DERIVES THE ROTATION MATRICES AM(I,J,K) FOR 11 +! TRANSFORMATIONS, IDENTIFIED BY K. +! K=1 TRANSFORMS GSE to GEO +! K=2 " GEO to MAG +! K=3 " GSE to MAG +! K=4 " GSE to GSM +! K=5 " GEO to GSM +! K=6 " GSM to MAG +! K=7 " GSE to GEI +! K=8 " GEI to GEO +! K=9 " GSM to SM +! K=10 " GEO to SM +! K=11 " MAG to SM +! +! IF IDBUG IS NOT 0, THEN OUTPUTS DIAGNOSTIC INFORMATION TO +! FILE UNIT=IDBUG +! +! The formal names of the coordinate systems are: +! GSE - Geocentric Solar Ecliptic +! GEO - Geographic +! MAG - Geomagnetic +! GSM - Geocentric Solar Magnetospheric +! SM - Solar Magnetic +! +! THE ARRAY CX(I) ENCODES VARIOUS ANGLES, STORED IN DEGREES +! ST(I) AND CT(I) ARE SINES & COSINES. +! +! Program author: D. R. Weimer +! +! Some of this code has been copied from subroutines which had been +! obtained from D. Stern, NASA/GSFC. Other formulas are from "Space +! Physics Coordinate Transformations: A User Guide" by M. Hapgood (1991). +! +! The formulas for the calculation of Greenwich mean sidereal time (GMST) +! and the sun's location are from "Almanac for Computers 1990", +! U.S. Naval Observatory. +! +!----------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only:CX=>CX,ST=>ST,CT=>CT,AM=>AM + &,EPOCH=>EPOCH,TH0=>TH0,PH0=>PH0,DIPOLE=>DIPOLE + + implicit none +! +!-----------------------------Return Value-------------------------- +! + real get_tilt +! +!-------------------------------Commons--------------------------------- +! +! real cx, st, ct, am +! COMMON/TRANSDAT/CX(9),ST(6),CT(6),AM(3,3,11) + +! real epoch, th0, ph0, dipole +! COMMON/MFIELD/EPOCH,TH0,PH0,DIPOLE +! DATA EPOCH,TH0,PH0,DIPOLE/1980.,11.19,-70.76,.30574/ +! +!------------------------------Arguments-------------------------------- +! + INTEGER YEAR, MONTH, DAY + REAL HOUR +! +!-----------------------------Parameters------------------------------ +! + INTEGER GSEGEO,GEOGSE,GEOMAG,MAGGEO + INTEGER GSEMAG,MAGGSE,GSEGSM,GSMGSE + INTEGER GEOGSM,GSMGEO,GSMMAG,MAGGSM + INTEGER GSEGEI,GEIGSE,GEIGEO,GEOGEI + INTEGER GSMSM,SMGSM,GEOSM,SMGEO,MAGSM,SMMAG + + PARAMETER (GSEGEO= 1,GEOGSE=-1,GEOMAG= 2,MAGGEO=-2) + PARAMETER (GSEMAG= 3,MAGGSE=-3,GSEGSM= 4,GSMGSE=-4) + PARAMETER (GEOGSM= 5,GSMGEO=-5,GSMMAG= 6,MAGGSM=-6) + PARAMETER (GSEGEI= 7,GEIGSE=-7,GEIGEO= 8,GEOGEI=-8) + PARAMETER (GSMSM = 9,SMGSM =-9,GEOSM =10,SMGEO=-10) + PARAMETER (MAGSM =11,SMMAG =-11) +! +!---------------------------Local variables----------------------------- +! + integer IDBUG + integer j, k, jd, iyr, i, mjd + + REAL UT, T0, GMSTD, GMSTH, ECLIP, MA, LAMD, SUNLON, pi + real b32, b33, b3 +! +!-------------------------External Functions---------------------------- +! + integer julday_wam + external julday_wam +! +!----------------------------------------------------------------------- +! +! EPOCH=1980. +! TH0=11.19 +! PH0=-70.76 +! DIPOLE=.30574 + pi=3.141592653 +! pi=2.*ASIN(1.) +!CC NCAR MODIFICATION (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! IDBUG=0 to prevent printing data to the screen or writing data to a file. C + IDBUG = 0 +!CC NCAR MODIFICATION (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + IF(YEAR.LT.1900)THEN + IYR=1900+YEAR + ELSE + IYR=YEAR + ENDIF + UT=HOUR + JD=JULDAY_WAM(MONTH,DAY,IYR) + MJD=JD-2400001 +! T0=(real(MJD,r8)-51544.5)/36525.0 + T0=(float(MJD)-51544.5)/36525.0 + GMSTD=100.4606184 +36000.770*T0 +3.87933E-4*T0*T0 + + & 15.0410686*UT + CALL ADJUST(GMSTD) + GMSTH=GMSTD*24./360. + ECLIP=23.439 - 0.013*T0 + MA=357.528 + 35999.050*T0 + 0.041066678*UT + CALL ADJUST(MA) + LAMD=280.460 + 36000.772*T0 + 0.041068642*UT + CALL ADJUST(LAMD) + SUNLON=LAMD + (1.915-0.0048*T0)*SIN(MA*pi/180.) + 0.020* + & SIN(2.*MA*pi/180.) + CALL ADJUST(SUNLON) +! IF(IDBUG.NE.0)THEN +! WRITE(IDBUG,*) YEAR,MONTH,DAY,HOUR +! WRITE(IDBUG,*) 'MJD=',MJD +! WRITE(IDBUG,*) 'T0=',T0 +! WRITE(IDBUG,*) 'GMSTH=',GMSTH +! WRITE(IDBUG,*) 'ECLIPTIC OBLIQUITY=',ECLIP +! WRITE(IDBUG,*) 'MEAN ANOMALY=',MA +! WRITE(IDBUG,*) 'MEAN LONGITUDE=',LAMD +! WRITE(IDBUG,*) 'TRUE LONGITUDE=',SUNLON +! ENDIF + + CX(1)= GMSTD + CX(2) = ECLIP + CX(3) = SUNLON + CX(4) = TH0 + CX(5) = PH0 +! Derived later: +! CX(6) = Dipole tilt angle +! CX(7) = Angle between sun and magnetic pole +! CX(8) = Subsolar point latitude +! CX(9) = Subsolar point longitude + + DO I=1,5 + ST(I) = SIN(CX(I)*pi/180.) + CT(I) = COS(CX(I)*pi/180.) + ENDDO +! + AM(1,1,GSEGEI) = CT(3) + AM(1,2,GSEGEI) = -ST(3) + AM(1,3,GSEGEI) = 0. + AM(2,1,GSEGEI) = ST(3)*CT(2) + AM(2,2,GSEGEI) = CT(3)*CT(2) + AM(2,3,GSEGEI) = -ST(2) + AM(3,1,GSEGEI) = ST(3)*ST(2) + AM(3,2,GSEGEI) = CT(3)*ST(2) + AM(3,3,GSEGEI) = CT(2) +! + AM(1,1,GEIGEO) = CT(1) + AM(1,2,GEIGEO) = ST(1) + AM(1,3,GEIGEO) = 0. + AM(2,1,GEIGEO) = -ST(1) + AM(2,2,GEIGEO) = CT(1) + AM(2,3,GEIGEO) = 0. + AM(3,1,GEIGEO) = 0. + AM(3,2,GEIGEO) = 0. + AM(3,3,GEIGEO) = 1. +! + DO I=1,3 + DO J=1,3 + AM(I,J,GSEGEO) = AM(I,1,GEIGEO)*AM(1,J,GSEGEI) + + &AM(I,2,GEIGEO)*AM(2,J,GSEGEI) +AM(I,3,GEIGEO)*AM(3,J,GSEGEI) + ENDDO + ENDDO +! + AM(1,1,GEOMAG) = CT(4)*CT(5) + AM(1,2,GEOMAG) = CT(4)*ST(5) + AM(1,3,GEOMAG) =-ST(4) + AM(2,1,GEOMAG) =-ST(5) + AM(2,2,GEOMAG) = CT(5) + AM(2,3,GEOMAG) = 0. + AM(3,1,GEOMAG) = ST(4)*CT(5) + AM(3,2,GEOMAG) = ST(4)*ST(5) + AM(3,3,GEOMAG) = CT(4) +! + DO I=1,3 + DO J=1,3 + AM(I,J,GSEMAG) = AM(I,1,GEOMAG)*AM(1,J,GSEGEO) + + &AM(I,2,GEOMAG)*AM(2,J,GSEGEO) +AM(I,3,GEOMAG)*AM(3,J,GSEGEO) + ENDDO + ENDDO +! + B32 = AM(3,2,GSEMAG) + B33 = AM(3,3,GSEMAG) + B3 = SQRT(B32*B32+B33*B33) + IF (B33.LE.0.) B3 = -B3 +! + AM(2,2,GSEGSM) = B33/B3 + AM(3,3,GSEGSM) = AM(2,2,GSEGSM) + AM(3,2,GSEGSM) = B32/B3 + AM(2,3,GSEGSM) =-AM(3,2,GSEGSM) + AM(1,1,GSEGSM) = 1. + AM(1,2,GSEGSM) = 0. + AM(1,3,GSEGSM) = 0. + AM(2,1,GSEGSM) = 0. + AM(3,1,GSEGSM) = 0. +! + DO I=1,3 + DO J=1,3 + AM(I,J,GEOGSM) = AM(I,1,GSEGSM)*AM(J,1,GSEGEO) + + &AM(I,2,GSEGSM)*AM(J,2,GSEGEO) + + &AM(I,3,GSEGSM)*AM(J,3,GSEGEO) + ENDDO + ENDDO +! + DO I=1,3 + DO J=1,3 + AM(I,J,GSMMAG) = AM(I,1,GEOMAG)*AM(J,1,GEOGSM) + + &AM(I,2,GEOMAG)*AM(J,2,GEOGSM) + + &AM(I,3,GEOMAG)*AM(J,3,GEOGSM) + ENDDO + ENDDO +! + ST(6) = AM(3,1,GSEMAG) + CT(6) = SQRT(1.-ST(6)*ST(6)) + CX(6) = ASIN(ST(6)*pi/180.) + + AM(1,1,GSMSM) = CT(6) + AM(1,2,GSMSM) = 0. + AM(1,3,GSMSM) = -ST(6) + AM(2,1,GSMSM) = 0. + AM(2,2,GSMSM) = 1. + AM(2,3,GSMSM) = 0. + AM(3,1,GSMSM) = ST(6) + AM(3,2,GSMSM) = 0. + AM(3,3,GSMSM) = CT(6) +! + DO I=1,3 + DO J=1,3 + AM(I,J,GEOSM) = AM(I,1,GSMSM)*AM(1,J,GEOGSM) + + &AM(I,2,GSMSM)*AM(2,J,GEOGSM) + + &AM(I,3,GSMSM)*AM(3,J,GEOGSM) + ENDDO + ENDDO +! + DO I=1,3 + DO J=1,3 + AM(I,J,MAGSM) = AM(I,1,GSMSM)*AM(J,1,GSMMAG) + + & AM(I,2,GSMSM)*AM(J,2,GSMMAG) + + &AM(I,3,GSMSM)*AM(J,3,GSMMAG) + ENDDO + ENDDO + +! + CX(7)=ATAN2( AM(2,1,11) , AM(1,1,11) ) + + CX(7)=CX(7)*180./pi + CX(8)=ASIN( AM(3,1,1)*pi/180. ) + CX(9)=ATAN2( AM(2,1,1) , AM(1,1,1) ) + CX(9)=CX(9)*180./pi + + IF(IDBUG.NE.0)THEN +! WRITE(IDBUG,*) 'Dipole tilt angle=',CX(6) +! WRITE(IDBUG,*) 'Angle between sun and magnetic pole=', +! &CX(7) +! WRITE(IDBUG,*) 'Subsolar point latitude=',CX(8) +! WRITE(IDBUG,*) 'Subsolar point longitude=',CX(9) + + DO K=1,11 +! WRITE(IDBUG,1001) K + DO I=1,3 +! WRITE(IDBUG,1002) (AM(I,J,K),J=1,3) + ENDDO + ENDDO + 1001 FORMAT(' ROTATION MATRIX ',I2) + 1002 FORMAT(3F9.5) + ENDIF + +!CC NCAR MODIFICATION (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! The next line was added to return the dipole tilt from this function call. C + GET_TILT = CX(6) +!CC NCAR MODIFICATION (3/96) CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + RETURN + END FUNCTION GET_TILT + +!====================================================================== + + SUBROUTINE ROTATE (X,Y,Z,I) +! +!----------------------------------------------------------------------- +! THIS SUBROUTINE APPLIES TO THE VECTOR (X,Y,Z) THE ITH ROTATION +! MATRIX AM(N,M,I) GENERATED BY SUBROUTINE TRANS +! IF I IS NEGATIVE, THEN THE INVERSE ROTATION IS APPLIED +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +!------------------------------Arguments-------------------------------- +! + integer i + REAL X,Y,Z +! +!---------------------------Local variables----------------------------- +! + REAL A(3) +! +!----------------------------------------------------------------------- +! + A(1)=X + A(2)=Y + A(3)=Z + CALL ROTATEV(A,A,I) + X=A(1) + Y=A(2) + Z=A(3) + + RETURN + END SUBROUTINE ROTATE + +!====================================================================== + + SUBROUTINE ROTATEV (A,B,I) +! +!----------------------------------------------------------------------- +! THIS SUBROUTINE APPLIES TO THE VECTOR A(3) THE ITH ROTATION +! MATRIX AM(N,M,I) GENERATED BY SUBROUTINE TRANS +! AND OUTPUTS THE CONVERTED VECTOR B(3), WITH NO CHANGE TO A. +! IF I IS NEGATIVE, THEN THE INVERSE ROTATION IS APPLIED +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 +! use cam_logfile, only : iulog +! use abortutils, only : endrun + use efield, only:CX=>CX,ST=>ST,CT=>CT,AM=>AM + + implicit none +! +!-------------------------------Commons--------------------------------- +! +! real cx, st, ct, am +! COMMON/TRANSDAT/CX(9),ST(6),CT(6),AM(3,3,11) +! +!------------------------------Arguments-------------------------------- +! + integer i + REAL A(3),B(3) +! +!---------------------------Local variables----------------------------- +! + integer id, j, iulog + real xa, ya, za + iulog=14 +! +!----------------------------------------------------------------------- +! +! IF(I.EQ.0 .OR. IABS(I).GT.11)THEN +! WRITE(IULOG,*)'ROTATEV CALLED WITH UNDEFINED TRANSFORMATION' +! CALL ENDRUN +! ENDIF + + XA = A(1) + YA = A(2) + ZA = A(3) + IF(I.GT.0)THEN + ID=I + DO J=1,3 + B(J) = XA*AM(J,1,ID) + YA*AM(J,2,ID) + ZA*AM(J,3,ID) + ENDDO + ELSE + ID=-I + DO J=1,3 + B(J) = XA*AM(1,J,ID) + YA*AM(2,J,ID) + ZA*AM(3,J,ID) + ENDDO + ENDIF + RETURN + END SUBROUTINE ROTATEV + +!================================================================================================ + + SUBROUTINE FROMCART(R,LAT,LONG,POS) +! +!----------------------------------------------------------------------- +! CONVERT CARTESIAN COORDINATES POS(3) +! TO SPHERICAL COORDINATES R, LATITUDE, AND LONGITUDE (DEGREES) +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +!------------------------------Arguments-------------------------------- +! + REAL R, LAT, LONG, POS(3) +! +!---------------------------Local variables----------------------------- +! + real pi +! +!----------------------------------------------------------------------- +! +! pi=2.*ASIN(1.) + pi=3.141592653 + R=SQRT(POS(1)*POS(1) + POS(2)*POS(2) + POS(3)*POS(3)) + IF(R.EQ.0.)THEN + LAT=0. + LONG=0. + ELSE + LAT=ASIN(POS(3)*pi/180./R) + LONG=ATAN2(POS(2),POS(1)) + LONG=LONG*180./pi + ENDIF + RETURN + END SUBROUTINE FROMCART + +!================================================================================================ + + SUBROUTINE TOCART(R,LAT,LONG,POS) +! +!----------------------------------------------------------------------- +! CONVERT SPHERICAL COORDINATES R, LATITUDE, AND LONGITUDE (DEGREES) +! TO CARTESIAN COORDINATES POS(3) +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +!------------------------------Arguments-------------------------------- +! + REAL R, LAT, LONG, POS(3) +! +!---------------------------Local variables----------------------------- +! + real pi, stc, ctc, sf, cf +! +!----------------------------------------------------------------------- +! +! pi=2.*ASIN(1.) + pi=3.141592653 + STC = SIN(LAT*pi/180.) + CTC = COS(LAT*pi/180.) + SF = SIN(LONG*pi/180.) + CF = COS(LONG*pi/180.) + POS(1) = R*CTC*CF + POS(2) = R*CTC*SF + POS(3) = R*STC + RETURN + END SUBROUTINE TOCART + +!================================================================================================ + + SUBROUTINE ADJUST(ANGLE) +! +!----------------------------------------------------------------------- +! ADJUST AN ANGLE IN DEGREES TO BE IN RANGE OF 0 TO 360. +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +!------------------------------Arguments-------------------------------- +! + real angle +! +!----------------------------------------------------------------------- +! + 10 CONTINUE + IF(ANGLE.LT.0.)THEN + ANGLE=ANGLE+360. + GOTO 10 + ENDIF + 20 CONTINUE + IF(ANGLE.GE.360.)THEN + ANGLE=ANGLE-360. + GOTO 20 + ENDIF + RETURN + END SUBROUTINE ADJUST + +!================================================================================================ + + INTEGER FUNCTION JULDAY_WAM(MM,ID,IYYY) +! +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + implicit none +! +!------------------------------Arguments-------------------------------- +! + integer mm, id, iyyy +! +!-----------------------------Parameters------------------------------ +! + integer igreg + PARAMETER (IGREG=15+31*(10+12*1582)) +! +!---------------------------Local variables----------------------------- +! + integer ja, jm, jy +! +!----------------------------------------------------------------------- +! +!!!compiler warning IF (IYYY.EQ.0) PAUSE 'There is no Year Zero.' + IF (IYYY.EQ.0) STOP 'There is no Year Zero.' + IF (IYYY.LT.0) IYYY=IYYY+1 + IF (MM.GT.2) THEN + JY=IYYY + JM=MM+1 + ELSE + JY=IYYY-1 + JM=MM+13 + ENDIF + JULDAY_WAM=INT(365.25*JY)+INT(30.6001*JM)+ID+1720995 + IF (ID+31*(MM+12*IYYY).GE.IGREG) THEN + JA=INT(0.01*JY) + JULDAY_WAM=JULDAY_WAM+2-JA+INT(0.25*JA) + ENDIF + RETURN + END FUNCTION JULDAY_WAM + +!================================================================================================ + + FUNCTION MLT(MagLong) +! +!----------------------------------------------------------------------- +! given magnetic longitude in degrees, return Magnetic Local Time +! assuming that TRANS has been called with the date & time to calculate +! the rotation matrices. +! +! btf 11/06/03: +! Call sub adjust instead of referencing it as a function +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only: CX=>CX,ST=>ST,CT=>CT,AM=>AM + implicit none +! +!-----------------------------Return Value------------------------------ +! + real mlt +! +!-------------------------------Commons--------------------------------- +! +! real cx, st, ct, am +! COMMON/TRANSDAT/CX(9),ST(6),CT(6),AM(3,3,11) + +! +!------------------------------Arguments-------------------------------- +! + REAL MagLong +! +!---------------------------Local variables----------------------------- +! + REAL angle, rotangle +! +!----------------------------------------------------------------------- +! + RotAngle=CX(7) +! MLT=ADJUST(Maglong+RotAngle+180.)/15. + angle = Maglong+RotAngle+180. + call adjust(angle) + mlt = angle/15. + RETURN + END FUNCTION MLT + +!================================================================================================ + + FUNCTION MagLong(MLT) +! +!----------------------------------------------------------------------- +! return magnetic longitude in degrees, given Magnetic Local Time +! assuming that TRANS has been called with the date & time to calculate +! the rotation matrices. +! +! btf 11/06/03: +! Call sub adjust instead of referencing it as a function +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only:CX=>CX,ST=>ST,CT=>CT,AM=>AM + implicit none +! +!-----------------------------Return Value------------------------------ +! + real MagLong +! +!-------------------------------Commons--------------------------------- +! +! real cx, st, ct, am +! COMMON/TRANSDAT/CX(9),ST(6),CT(6),AM(3,3,11) +! +!------------------------------Arguments-------------------------------- +! + REAL MLT +! +!---------------------------Local variables----------------------------- +! + REAL angle, rotangle +! +!----------------------------------------------------------------------- +! + RotAngle=CX(7) + angle=MLT*15.-RotAngle-180. +! MagLong=ADJUST(angle) + call adjust(angle) + MagLong = angle + RETURN + END FUNCTION MagLong + +!================================================================================================ + + SUBROUTINE SunLoc(SunLat,SunLong) +! +!----------------------------------------------------------------------- +! Return latitude and longitude of sub-solar point. +! Assumes that TRANS has previously been called with the +! date & time to calculate the rotation matrices. +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only:CX=>CX,ST=>ST,CT=>CT,AM=>AM + implicit none +! +!-------------------------------Commons--------------------------------- +! +! real cx, st, ct, am +! COMMON/TRANSDAT/CX(9),ST(6),CT(6),AM(3,3,11) +! +!------------------------------Arguments-------------------------------- +! + Real SunLat,SunLong +! +!----------------------------------------------------------------------- +! + SunLong=CX(9) + SunLat=CX(8) + RETURN + END SUBROUTINE SunLoc + +!================================================================================================ + + SUBROUTINE GECMP (AMLA,RMLT,ET,EP) +! +!----------------------------------------------------------------------- +! Get Electric field components for the Weimer electrostatic +! potential model. Before use, first load coefficients (CALL +! READCOEF) and initialize model conditions (CALL SETMODEL). +! +! INPUTS: +! AMLA = Absolute value of magnetic latitude (deg) +! RMLT = Magnetic local time (hours). +! RETURNS: +! ET = Etheta (magnetic equatorward*) E field component (V/m) +! EP = Ephi (magnetic eastward) E field component (V/m) +! +! * ET direction is along the magnetic meridian away from the +! current hemisphere; i.e., when ET > 0, the direction is +! southward when RMLA > 0 +! northward when RMLA < 0 +! +! NCAR addition (Jan 97). R.Barnes +!----------------------------------------------------------------------- +! +! use shr_kind_mod, only: r8 => shr_kind_r8 + use efield, only: ALAMN =>ALAMN,ALAMX=>ALAMX,ALAMR=>ALAMR, + &STPD=>STPD,STP2=>STP2,CSTP=>CSTP,SSTP=>SSTP + implicit none +! +!-------------------------------Commons--------------------------------- +! +! CECMP contains constants initialized in READCOEF +! real alamn, alamx, alamr, stpd, stp2, cstp, sstp +! COMMON /CECMP/ ALAMN,ALAMX,ALAMR,STPD,STP2,CSTP,SSTP +! +!------------------------------Arguments-------------------------------- +! + real amla, rmlt, et, ep +! +!-----------------------------Parameters------------------------------ +! + real d2r, r2d + PARAMETER ( D2R = 0.0174532925199432957692369076847 , + & R2D = 57.2957795130823208767981548147) +! +!---------------------------Local variables----------------------------- +! + real p1, p2 + real xmlt, xmlt1, kpol, dphi, amla1 +! +!-------------------------External Functions---------------------------- +! + real epotval + external epotval +! +!----------------------------------------------------------------------- +! + ET = -99999. + EP = -99999. + IF (AMLA .LT. 0.) GO TO 100 + +! Calculate -(latitude gradient) by stepping 10 km along the +! meridian in each direction (flipping coordinates when going +! over pole to keep lat <= 90). + KPOL = 0 + XMLT = RMLT + 10 XMLT1 = XMLT + AMLA1 = AMLA + STPD + IF (AMLA1 .GT. 90.) THEN + AMLA1 = 180. - AMLA1 + XMLT1 = XMLT1 + 12. + ENDIF + P1 = EPOTVAL (AMLA1 ,XMLT1) + P2 = EPOTVAL (AMLA-STPD,XMLT ) + IF (KPOL .EQ. 1) GO TO 20 + ET = (P1 - P2) / STP2 + +! Calculate -(lon gradient). For most latitudes, step along a +! great circle. However, limit minimum latitude to the model +! minimum (distorting the path onto a latitude line). Also, +! avoid a divide by zero at the pole avoid by using Art's trick +! where Ephi(90,lon) = Etheta(90,lon+90) + IF (AMLA .LT. ALAMX) THEN + AMLA1 = MAX (ASIN(SIN(AMLA*D2R)*CSTP) , ALAMR) + DPHI = ASIN (SSTP/SIN(AMLA1))*R2D + AMLA1 = AMLA1*R2D + P1 = EPOTVAL (AMLA1,XMLT+DPHI) + P2 = EPOTVAL (AMLA1,XMLT-DPHI) + ELSE + AMLA = 90. + XMLT = XMLT + 6. + KPOL = 1 + GO TO 10 + ENDIF + 20 EP = (P2 - P1) / STP2 + IF (KPOL .EQ. 1) EP = -EP + +! Below model minimum lat, the potential is value at min lat + IF (AMLA .LT. ALAMN) THEN + ET = 0. + EP = EP * COS(ALAMR)/COS(AMLA*D2R) + ENDIF + + 100 RETURN + END SUBROUTINE GECMP + +!===================================================================== + subroutine svdcmp( a, m, n, mp, np, w, v ) +!------------------------------------------------------------------------- +! purpose: singular value decomposition +! +! method: +! given a matrix a(1:m,1:n), with physical dimensions mp by np, +! this routine computes its singular value decomposition, +! the matrix u replaces a on output. the +! diagonal matrix of singular values w is output as a vector +! w(1:n). the matrix v (not the transpose v^t) is output as +! v(1:n,1:n). +! +! author: a. maute dec 2003 +! (* copyright (c) 1985 numerical recipes software -- svdcmp *! +! from numerical recipes 1986 pp. 60 or can be find on web-sites +!------------------------------------------------------------------------- + implicit none + integer, parameter :: nmax = 1600 +!------------------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------------------- + integer, intent(in) :: m + integer, intent(in) :: n + integer, intent(in) :: mp + integer, intent(in) :: np + real, intent(inout) :: a(mp,np) + real, intent(out) :: v(np,np) + real, intent(out) :: w(np) + +!------------------------------------------------------------------------- +! ... local variables +!------------------------------------------------------------------------- + integer :: i, its, j, k, l, nm + real :: anorm + real :: c + real :: f + real :: g + real :: h + real :: s + real :: scale + real :: x, y, z + real :: rv1(nmax) + logical :: cnd1 + logical :: cnd2 + + g = 0.0 + scale = 0.0 + anorm = 0.0 + + do i = 1,n !loop1 + l = i + 1 + rv1(i) = scale*g + g = 0.0 + s = 0.0 + scale = 0.0 + if( i <= m ) then + do k = i,m + scale = scale + abs(a(k,i)) + end do + if( scale /= 0.0 ) then + do k = i,m + a(k,i) = a(k,i)/scale + s = s + a(k,i)*a(k,i) + end do + f = a(i,i) + g = -sign(sqrt(s),f) + h = f*g - s + a(i,i) = f - g + if( i /= n ) then + do j = l,n + s = 0.0 + do k = i,m + s = s + a(k,i)*a(k,j) + end do + f = s/h + do k = i,m + a(k,j) = a(k,j) + f*a(k,i) + end do + end do + end if + do k = i,m + a(k,i) = scale*a(k,i) + end do + endif + endif + w(i) = scale *g + g = 0.0 + s = 0.0 + scale = 0.0 + if( i <= m .and. i /= n ) then + do k = l,n + scale = scale + abs(a(i,k)) + end do + if( scale /= 0.0 ) then + do k = l,n + a(i,k) = a(i,k)/scale + s = s + a(i,k)*a(i,k) + end do + f = a(i,l) + g = -sign(sqrt(s),f) + h = f*g - s + a(i,l) = f - g + do k = l,n + rv1(k) = a(i,k)/h + end do + if( i /= m ) then + do j = l,m + s = 0.0 + do k = l,n + s = s + a(j,k)*a(i,k) + end do + do k = l,n + a(j,k) = a(j,k) + s*rv1(k) + end do + end do + end if + do k = l,n + a(i,k) = scale*a(i,k) + end do + end if + end if + anorm = max( anorm,(abs(w(i)) + abs(rv1(i))) ) + enddo !loop1 + + do i = n,1,-1 + if( i < n ) then + if( g /= 0.0 ) then + do j = l,n + v(j,i) = (a(i,j)/a(i,l))/g + end do + do j = l,n + s = 0.0 + do k = l,n + s = s + a(i,k)*v(k,j) + end do + do k = l,n + v(k,j) = v(k,j) + s*v(k,i) + end do + end do + end if + do j = l,n + v(i,j) = 0.0 + v(j,i) = 0.0 + end do + end if + v(i,i) = 1.0 + g = rv1(i) + l = i + end do + + do i = n,1,-1 + l = i + 1 + g = w(i) + if( i < n ) then + do j = l,n + a(i,j) = 0.0 + end do + end if + if( g /= 0.0 ) then + g = 1./g + if( i /= n ) then + do j = l,n + s = 0.0 + do k = l,m + s = s + a(k,i)*a(k,j) + end do + f = (s/a(i,i))*g + do k = i,m + a(k,j) = a(k,j) + f*a(k,i) + end do + end do + end if + do j = i,m + a(j,i) = a(j,i)*g + end do + else + do j = i,m + a(j,i) = 0.0 + end do + end if + a(i,i) = a(i,i) + 1.0 + end do + + do k = n,1,-1 + do its = 1,30 !loop2 + do l = k,1,-1 + nm = l - 1 + cnd1 = abs( rv1(l) ) + anorm == anorm + if( cnd1 ) then + cnd2 = .false. + exit + end if + cnd2 = abs( w(nm) ) + anorm == anorm + if( cnd2 ) then + cnd1 = .true. + exit + else if( l == 1 ) then + cnd1 = .true. + cnd2 = .true. + end if + end do + + if( cnd2 ) then + c = 0.0 + s = 1.0 + do i = l,k + f = s*rv1(i) + if( (abs(f) + anorm) /= anorm ) then + g = w(i) + h = sqrt(f*f + g*g) + w(i) = h + h = 1.0/h + c = (g*h) + s = -(f*h) + do j = 1,m + y = a(j,nm) + z = a(j,i) + a(j,nm) = (y*c) + (z*s) + a(j,i) = -(y*s) + (z*c) + end do + end if + end do + end if + + if( cnd1 ) then + z = w(k) + if( l == k ) then + if( z < 0.0 ) then + w(k) = -z + do j = 1,n + v(j,k) = -v(j,k) + end do + end if +! exit loop2 + go to 20 + end if + end if + + x = w(l) + nm = k - 1 + y = w(nm) + g = rv1(nm) + h = rv1(k) + f = ((y - z)*(y + z) + (g - h)*(g + h))/(2.0*h*y) + g = sqrt( f*f + 1.0 ) + f = ((x - z)*(x + z) + h*((y/(f + sign(g,f))) - h))/x + c = 1.0 + s = 1.0 + do j = l,nm + i = j + 1 + g = rv1(i) + y = w(i) + h = s*g + g = c*g + z = sqrt( f*f + h*h ) + rv1(j) = z + c = f/z + s = h/z + f = (x*c)+(g*s) + g = -(x*s)+(g*c) + h = y*s + y = y*c + do nm = 1,n + x = v(nm,j) + z = v(nm,i) + v(nm,j) = (x*c)+(z*s) + v(nm,i) = -(x*s)+(z*c) + end do + z = sqrt( f*f + h*h ) + w(j) = z + if( z /= 0.0 ) then + z = 1.0/z + c = f*z + s = h*z + end if + f = (c*g)+(s*y) + x = -(s*g)+(c*y) + do nm = 1,m + y = a(nm,j) + z = a(nm,i) + a(nm,j) = (y*c)+(z*s) + a(nm,i) = -(y*s)+(z*c) + end do + end do + rv1(l) = 0.0 + rv1(k) = f + w(k) = x + end do !loop2 + 20 continue + end do + + end subroutine svdcmp + +!------------------------------------------------------------------------- +! purpose: solves a*x = b +! +! method: +! solves a*x = b for a vector x, where a is specified by the arrays +! u,w,v as returned by svdcmp. m and n +! are the logical dimensions of a, and will be equal for square matrices. +! mp and np are the physical dimensions of a. b(1:m) is the input right-hand +! side. x(1:n) is the output solution vector. no input quantities are +! destroyed, so the routine may be called sequentially with different b +! +! author: a. maute dec 2002 +! (* copyright (c) 1985 numerical recipes software -- svbksb *! +! from numerical recipes 1986 pp. 57 or can be find on web-sites +!------------------------------------------------------------------------- + + subroutine svbksb( u, w, v, m, n, mp, np, b, x ) +!------------------------------------------------------------------------- +! ... dummy arguments +!------------------------------------------------------------------------- + implicit none + integer, parameter :: nmax = 1600 + integer, intent(in) :: m + integer, intent(in) :: n + integer, intent(in) :: mp + integer, intent(in) :: np + real , intent(in) :: u(mp,np) + real , intent(in) :: w(np) + real , intent(in) :: v(np,np) + real , intent(in) :: b(mp) + real , intent(out) :: x(np) + +!------------------------------------------------------------------------- +! ... local variables +!------------------------------------------------------------------------- + integer :: i, j, jj + real :: s + real :: tmp(nmax) + + do j = 1,n + s = 0. + if( w(j) /= 0. ) then + do i = 1,m + s = s + u(i,j)*b(i) + end do + s = s/w(j) + endif + tmp(j) = s + end do + + do j = 1,n + s = 0. + do jj = 1,n + s = s + v(j,jj)*tmp(jj) + end do + x(j) = s + end do + + end subroutine svbksb diff --git a/gsmphys/funcphys.f90 b/gsmphys/funcphys.f90 new file mode 100644 index 00000000..e8014f0f --- /dev/null +++ b/gsmphys/funcphys.f90 @@ -0,0 +1,2899 @@ +!------------------------------------------------------------------------------- +module funcphys +!$$$ Module Documentation Block +! +! Module: funcphys API for basic thermodynamic physics +! Author: Iredell Org: W/NX23 Date: 1999-03-01 +! +! Abstract: This module provides an Application Program Interface +! for computing basic thermodynamic physics functions, in particular +! (1) saturation vapor pressure as a function of temperature, +! (2) dewpoint temperature as a function of vapor pressure, +! (3) equivalent potential temperature as a function of temperature +! and scaled pressure to the kappa power, +! (4) temperature and specific humidity along a moist adiabat +! as functions of equivalent potential temperature and +! scaled pressure to the kappa power, +! (5) scaled pressure to the kappa power as a function of pressure, and +! (6) temperature at the lifting condensation level as a function +! of temperature and dewpoint depression. +! The entry points required to set up lookup tables start with a "g". +! All the other entry points are functions starting with an "f" or +! are subroutines starting with an "s". These other functions and +! subroutines are elemental; that is, they return a scalar if they +! are passed only scalars, but they return an array if they are passed +! an array. These other functions and subroutines can be inlined, too. +! +! Program History Log: +! 1999-03-01 Mark Iredell +! 1999-10-15 Mark Iredell SI unit for pressure (Pascals) +! 2001-02-26 Mark Iredell Ice phase changes of Hong and Moorthi +! +! Public Variables: +! krealfp Integer parameter kind or length of reals (=kind_phys) +! +! Public Subprograms: +! gpvsl Compute saturation vapor pressure over liquid table +! +! fpvsl Elementally compute saturation vapor pressure over liquid +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvslq Elementally compute saturation vapor pressure over liquid +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvslx Elementally compute saturation vapor pressure over liquid +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! gpvsi Compute saturation vapor pressure over ice table +! +! fpvsi Elementally compute saturation vapor pressure over ice +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsiq Elementally compute saturation vapor pressure over ice +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsix Elementally compute saturation vapor pressure over ice +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! gpvs Compute saturation vapor pressure table +! +! fpvs Elementally compute saturation vapor pressure +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsq Elementally compute saturation vapor pressure +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! fpvsx Elementally compute saturation vapor pressure +! function result Real(krealfp) saturation vapor pressure in Pascals +! t Real(krealfp) temperature in Kelvin +! +! gtdpl Compute dewpoint temperature over liquid table +! +! ftdpl Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdplq Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdplx Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdplxg Elementally compute dewpoint temperature over liquid +! function result Real(krealfp) dewpoint temperature in Kelvin +! t Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! gtdpi Compute dewpoint temperature table over ice +! +! ftdpi Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpiq Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpix Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpixg Elementally compute dewpoint temperature over ice +! function result Real(krealfp) dewpoint temperature in Kelvin +! t Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! gtdp Compute dewpoint temperature table +! +! ftdp Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpq Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpx Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! ftdpxg Elementally compute dewpoint temperature +! function result Real(krealfp) dewpoint temperature in Kelvin +! t Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! gthe Compute equivalent potential temperature table +! +! fthe Elementally compute equivalent potential temperature +! function result Real(krealfp) equivalent potential temperature in Kelvin +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! ftheq Elementally compute equivalent potential temperature +! function result Real(krealfp) equivalent potential temperature in Kelvin +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! fthex Elementally compute equivalent potential temperature +! function result Real(krealfp) equivalent potential temperature in Kelvin +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! gtma Compute moist adiabat tables +! +! stma Elementally compute moist adiabat temperature and moisture +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! stmaq Elementally compute moist adiabat temperature and moisture +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! stmax Elementally compute moist adiabat temperature and moisture +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! stmaxg Elementally compute moist adiabat temperature and moisture +! tg Real(krealfp) guess parcel temperature in Kelvin +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! gpkap Compute pressure to the kappa table +! +! fpkap Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) pressure in Pascals +! +! fpkapq Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) pressure in Pascals +! +! fpkapo Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) surface pressure in Pascals +! +! fpkapx Elementally raise pressure to the kappa power. +! function result Real(krealfp) p over 1e5 Pa to the kappa power +! p Real(krealfp) pressure in Pascals +! +! grkap Compute pressure to the 1/kappa table +! +! frkap Elementally raise pressure to the 1/kappa power. +! function result Real(krealfp) pressure in Pascals +! pkap Real(krealfp) p over 1e5 Pa to the 1/kappa power +! +! frkapq Elementally raise pressure to the kappa power. +! function result Real(krealfp) pressure in Pascals +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! frkapx Elementally raise pressure to the kappa power. +! function result Real(krealfp) pressure in Pascals +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! gtlcl Compute LCL temperature table +! +! ftlcl Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! ftlclq Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! ftlclo Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! ftlclx Elementally compute LCL temperature. +! function result Real(krealfp) temperature at the LCL in Kelvin +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! gfuncphys Compute all physics function tables +! +! Attributes: +! Language: Fortran 90 +! +!$$$ + use machine,only:kind_phys + use physcons + implicit none + private +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Public Variables +! integer,public,parameter:: krealfp=selected_real_kind(15,45) + integer,public,parameter:: krealfp=kind_phys +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Private Variables + real(krealfp),parameter:: psatb=con_psat*1.e-5 + integer,parameter:: nxpvsl=7501 + real(krealfp) c1xpvsl,c2xpvsl,tbpvsl(nxpvsl) + integer,parameter:: nxpvsi=7501 + real(krealfp) c1xpvsi,c2xpvsi,tbpvsi(nxpvsi) + integer,parameter:: nxpvs=7501 + real(krealfp) c1xpvs,c2xpvs,tbpvs(nxpvs) + integer,parameter:: nxtdpl=5001 + real(krealfp) c1xtdpl,c2xtdpl,tbtdpl(nxtdpl) + integer,parameter:: nxtdpi=5001 + real(krealfp) c1xtdpi,c2xtdpi,tbtdpi(nxtdpi) + integer,parameter:: nxtdp=5001 + real(krealfp) c1xtdp,c2xtdp,tbtdp(nxtdp) + integer,parameter:: nxthe=241,nythe=151 + real(krealfp) c1xthe,c2xthe,c1ythe,c2ythe,tbthe(nxthe,nythe) + integer,parameter:: nxma=151,nyma=121 + real(krealfp) c1xma,c2xma,c1yma,c2yma,tbtma(nxma,nyma),tbqma(nxma,nyma) +! integer,parameter:: nxpkap=5501 + integer,parameter:: nxpkap=11001 + real(krealfp) c1xpkap,c2xpkap,tbpkap(nxpkap) + integer,parameter:: nxrkap=5501 + real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap) + integer,parameter:: nxtlcl=151,nytlcl=61 + real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Public Subprograms + public gpvsl,fpvsl,fpvslq,fpvslx + public gpvsi,fpvsi,fpvsiq,fpvsix + public gpvs,fpvs,fpvsq,fpvsx + public gtdpl,ftdpl,ftdplq,ftdplx,ftdplxg + public gtdpi,ftdpi,ftdpiq,ftdpix,ftdpixg + public gtdp,ftdp,ftdpq,ftdpx,ftdpxg + public gthe,fthe,ftheq,fthex + public gtma,stma,stmaq,stmax,stmaxg + public gpkap,fpkap,fpkapq,fpkapo,fpkapx + public grkap,frkap,frkapq,frkapx + public gtlcl,ftlcl,ftlclq,ftlclo,ftlclx + public gfuncphys +contains +!------------------------------------------------------------------------------- + subroutine gpvsl +!$$$ Subprogram Documentation Block +! +! Subprogram: gpvsl Compute saturation vapor pressure table over liquid +! Author: N Phillips W/NMC2X2 Date: 30 dec 82 +! +! Abstract: Computes saturation vapor pressure table as a function of +! temperature for the table lookup function fpvsl. +! Exact saturation vapor pressures are calculated in subprogram fpvslx. +! The current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gpvsl +! +! Subprograms called: +! (fpvslx) inlinable function to compute saturation vapor pressure +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180.0_krealfp + xmax=330.0_krealfp + xinc=(xmax-xmin)/(nxpvsl-1) +! c1xpvsl=1.-xmin/xinc + c2xpvsl=1./xinc + c1xpvsl=1.-xmin*c2xpvsl + do jx=1,nxpvsl + x=xmin+(jx-1)*xinc + t=x + tbpvsl(jx)=fpvslx(t) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function fpvsl(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsl Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsl. See documentation for fpvslx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsl is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvsl(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsl Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsl + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) + jx=min(xj,nxpvsl-1._krealfp) + fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpvslq(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvslq Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A quadratic interpolation is done between values in a lookup table +! computed in gpvsl. See documentation for fpvslx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 9 decimal places. +! On the Cray, fpvslq is about 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvslq(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvslq Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvslq + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) + jx=min(max(nint(xj),2),nxpvsl-1) + dxj=xj-jx + fj1=tbpvsl(jx-1) + fj2=tbpvsl(jx) + fj3=tbpvsl(jx+1) + fpvslq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpvslx(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvslx Compute saturation vapor pressure over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute saturation vapor pressure from temperature. +! The water model assumes a perfect gas, constant specific heats +! for gas and liquid, and neglects the volume of the liquid. +! The model does account for the variation of the latent heat +! of condensation with temperature. The ice option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: pvsl=fpvslx(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvslx Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvslx + real(krealfp),intent(in):: t + real(krealfp),parameter:: dldt=con_cvap-con_cliq + real(krealfp),parameter:: heat=con_hvap + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) tr +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/t + fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gpvsi +!$$$ Subprogram Documentation Block +! +! Subprogram: gpvsi Compute saturation vapor pressure table over ice +! Author: N Phillips W/NMC2X2 Date: 30 dec 82 +! +! Abstract: Computes saturation vapor pressure table as a function of +! temperature for the table lookup function fpvsi. +! Exact saturation vapor pressures are calculated in subprogram fpvsix. +! The current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gpvsi +! +! Subprograms called: +! (fpvsix) inlinable function to compute saturation vapor pressure +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180.0_krealfp + xmax=330.0_krealfp + xinc=(xmax-xmin)/(nxpvsi-1) +! c1xpvsi=1.-xmin/xinc + c2xpvsi=1./xinc + c1xpvsi=1.-xmin*c2xpvsi + do jx=1,nxpvsi + x=xmin+(jx-1)*xinc + t=x + tbpvsi(jx)=fpvsix(t) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function fpvsi(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsi Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvsi. See documentation for fpvsix for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvsi is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsi(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsi Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsi + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) + jx=min(xj,nxpvsi-1._krealfp) + fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpvsiq(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsiq Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A quadratic interpolation is done between values in a lookup table +! computed in gpvsi. See documentation for fpvsix for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 9 decimal places. +! On the Cray, fpvsiq is about 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsiq(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsiq Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsiq + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) + jx=min(max(nint(xj),2),nxpvsi-1) + dxj=xj-jx + fj1=tbpvsi(jx-1) + fj2=tbpvsi(jx) + fj3=tbpvsi(jx+1) + fpvsiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpvsix(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsix Compute saturation vapor pressure over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute saturation vapor pressure from temperature. +! The water model assumes a perfect gas, constant specific heats +! for gas and ice, and neglects the volume of the ice. +! The model does account for the variation of the latent heat +! of condensation with temperature. The liquid option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsi=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvsi=fpvsix(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsix Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsix + real(krealfp),intent(in):: t + real(krealfp),parameter:: dldt=con_cvap-con_csol + real(krealfp),parameter:: heat=con_hvap+con_hfus + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) tr +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/t + fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gpvs +!$$$ Subprogram Documentation Block +! +! Subprogram: gpvs Compute saturation vapor pressure table +! Author: N Phillips W/NMC2X2 Date: 30 dec 82 +! +! Abstract: Computes saturation vapor pressure table as a function of +! temperature for the table lookup function fpvs. +! Exact saturation vapor pressures are calculated in subprogram fpvsx. +! The current implementation computes a table with a length +! of 7501 for temperatures ranging from 180. to 330. Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gpvs +! +! Subprograms called: +! (fpvsx) inlinable function to compute saturation vapor pressure +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180.0_krealfp + xmax=330.0_krealfp + xinc=(xmax-xmin)/(nxpvs-1) +! c1xpvs=1.-xmin/xinc + c2xpvs=1./xinc + c1xpvs=1.-xmin*c2xpvs + do jx=1,nxpvs + x=xmin+(jx-1)*xinc + t=x + tbpvs(jx)=fpvsx(t) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function fpvs(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvs Compute saturation vapor pressure +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A linear interpolation is done between values in a lookup table +! computed in gpvs. See documentation for fpvsx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 6 decimal places. +! On the Cray, fpvs is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvs=fpvs(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvs Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvs + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) + jx=min(xj,nxpvs-1._krealfp) + fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpvsq(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsq Compute saturation vapor pressure +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute saturation vapor pressure from the temperature. +! A quadratic interpolation is done between values in a lookup table +! computed in gpvs. See documentation for fpvsx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is almost 9 decimal places. +! On the Cray, fpvsq is about 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvs=fpvsq(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsq Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsq + real(krealfp),intent(in):: t + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) + jx=min(max(nint(xj),2),nxpvs-1) + dxj=xj-jx + fj1=tbpvs(jx-1) + fj2=tbpvs(jx) + fj3=tbpvs(jx+1) + fpvsq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpvsx(t) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpvsx Compute saturation vapor pressure +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute saturation vapor pressure from temperature. +! The saturation vapor pressure over either liquid and ice is computed +! over liquid for temperatures above the triple point, +! over ice for temperatures 20 degress below the triple point, +! and a linear combination of the two for temperatures in between. +! The water model assumes a perfect gas, constant specific heats +! for gas, liquid and ice, and neglects the volume of the condensate. +! The model does account for the variation of the latent heat +! of condensation and sublimation with temperature. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The reference for this computation is Emanuel(1994), pages 116-117. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: pvs=fpvsx(t) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! +! Output argument list: +! fpvsx Real(krealfp) saturation vapor pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpvsx + real(krealfp),intent(in):: t + real(krealfp),parameter:: tliq=con_ttp + real(krealfp),parameter:: tice=con_ttp-20.0 + real(krealfp),parameter:: dldtl=con_cvap-con_cliq + real(krealfp),parameter:: heatl=con_hvap + real(krealfp),parameter:: xponal=-dldtl/con_rv + real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) + real(krealfp),parameter:: dldti=con_cvap-con_csol + real(krealfp),parameter:: heati=con_hvap+con_hfus + real(krealfp),parameter:: xponai=-dldti/con_rv + real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) + real(krealfp) tr,w,pvl,pvi +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/t + if(t.ge.tliq) then + fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + elseif(t.lt.tice) then + fpvsx=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + else + w=(t-tice)/(tliq-tice) + pvl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + pvi=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + fpvsx=w*pvl+(1.-w)*pvi + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtdpl +!$$$ Subprogram Documentation Block +! +! Subprogram: gtdpl Compute dewpoint temperature over liquid table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature table as a function of +! vapor pressure for inlinable function ftdpl. +! Exact dewpoint temperatures are calculated in subprogram ftdplxg. +! The current implementation computes a table with a length +! of 5001 for vapor pressures ranging from 1 to 10001 Pascals +! giving a dewpoint temperature range of 208 to 319 Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gtdpl +! +! Subprograms called: +! (ftdplxg) inlinable function to compute dewpoint temperature over liquid +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,t,x,pv +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=1 + xmax=10001 + xinc=(xmax-xmin)/(nxtdpl-1) + c1xtdpl=1.-xmin/xinc + c2xtdpl=1./xinc + t=208.0 + do jx=1,nxtdpl + x=xmin+(jx-1)*xinc + pv=x + t=ftdplxg(t,pv) + tbtdpl(jx)=t + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function ftdpl(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpl Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A linear interpolation is done between values in a lookup table +! computed in gtdpl. See documentation for ftdplxg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpl is about 75 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdpl(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpl Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpl + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) + jx=min(xj,nxtdpl-1._krealfp) + ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdplq(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdplq Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A quadratic interpolation is done between values in a lookup table +! computed in gtdpl. see documentation for ftdplxg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.00001 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdplq is about 60 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdplq(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdplq Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdplq + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) + jx=min(max(nint(xj),2),nxtdpl-1) + dxj=xj-jx + fj1=tbtdpl(jx-1) + fj2=tbtdpl(jx) + fj3=tbtdpl(jx+1) + ftdplq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdplx(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdplx Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute dewpoint temperature from vapor pressure. +! An approximate dewpoint temperature for function ftdplxg +! is obtained using ftdpl so gtdpl must be already called. +! See documentation for ftdplxg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdplx(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdplx Real(krealfp) dewpoint temperature in Kelvin +! +! Subprograms called: +! (ftdpl) inlinable function to compute dewpoint temperature over liquid +! (ftdplxg) inlinable function to compute dewpoint temperature over liquid +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdplx + real(krealfp),intent(in):: pv + real(krealfp) tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tg=ftdpl(pv) + ftdplx=ftdplxg(tg,pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdplxg(tg,pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdplxg Compute dewpoint temperature over liquid +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute dewpoint temperature from vapor pressure. +! A guess dewpoint temperature must be provided. +! The water model assumes a perfect gas, constant specific heats +! for gas and liquid, and neglects the volume of the liquid. +! The model does account for the variation of the latent heat +! of condensation with temperature. The ice option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The formula is inverted by iterating Newtonian approximations +! for each pvs until t is found to within 1.e-6 Kelvin. +! This function can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: tdpl=ftdplxg(tg,pv) +! +! Input argument list: +! tg Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdplxg Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdplxg + real(krealfp),intent(in):: tg,pv + real(krealfp),parameter:: terrm=1.e-6 + real(krealfp),parameter:: dldt=con_cvap-con_cliq + real(krealfp),parameter:: heat=con_hvap + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) t,tr,pvt,el,dpvt,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + do i=1,100 + tr=con_ttp/t + pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) + el=heat+dldt*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + terr=(pvt-pv)/dpvt + t=t-terr + if(abs(terr).le.terrm) exit + enddo + ftdplxg=t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtdpi +!$$$ Subprogram Documentation Block +! +! Subprogram: gtdpi Compute dewpoint temperature over ice table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature table as a function of +! vapor pressure for inlinable function ftdpi. +! Exact dewpoint temperatures are calculated in subprogram ftdpixg. +! The current implementation computes a table with a length +! of 5001 for vapor pressures ranging from 0.1 to 1000.1 Pascals +! giving a dewpoint temperature range of 197 to 279 Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gtdpi +! +! Subprograms called: +! (ftdpixg) inlinable function to compute dewpoint temperature over ice +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,t,x,pv +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0.1 + xmax=1000.1 + xinc=(xmax-xmin)/(nxtdpi-1) + c1xtdpi=1.-xmin/xinc + c2xtdpi=1./xinc + t=197.0 + do jx=1,nxtdpi + x=xmin+(jx-1)*xinc + pv=x + t=ftdpixg(t,pv) + tbtdpi(jx)=t + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function ftdpi(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpi Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A linear interpolation is done between values in a lookup table +! computed in gtdpi. See documentation for ftdpixg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpi is about 75 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpi(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpi Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpi + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) + jx=min(xj,nxtdpi-1._krealfp) + ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdpiq(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpiq Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A quadratic interpolation is done between values in a lookup table +! computed in gtdpi. see documentation for ftdpixg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.00001 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpiq is about 60 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpiq(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpiq Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpiq + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) + jx=min(max(nint(xj),2),nxtdpi-1) + dxj=xj-jx + fj1=tbtdpi(jx-1) + fj2=tbtdpi(jx) + fj3=tbtdpi(jx+1) + ftdpiq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdpix(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpix Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute dewpoint temperature from vapor pressure. +! An approximate dewpoint temperature for function ftdpixg +! is obtained using ftdpi so gtdpi must be already called. +! See documentation for ftdpixg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpix(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpix Real(krealfp) dewpoint temperature in Kelvin +! +! Subprograms called: +! (ftdpi) inlinable function to compute dewpoint temperature over ice +! (ftdpixg) inlinable function to compute dewpoint temperature over ice +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpix + real(krealfp),intent(in):: pv + real(krealfp) tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tg=ftdpi(pv) + ftdpix=ftdpixg(tg,pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdpixg(tg,pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpixg Compute dewpoint temperature over ice +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute dewpoint temperature from vapor pressure. +! A guess dewpoint temperature must be provided. +! The water model assumes a perfect gas, constant specific heats +! for gas and ice, and neglects the volume of the ice. +! The model does account for the variation of the latent heat +! of sublimation with temperature. The liquid option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvs=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The formula is inverted by iterating Newtonian approximations +! for each pvs until t is found to within 1.e-6 Kelvin. +! This function can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdpi=ftdpixg(tg,pv) +! +! Input argument list: +! tg Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpixg Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpixg + real(krealfp),intent(in):: tg,pv + real(krealfp),parameter:: terrm=1.e-6 + real(krealfp),parameter:: dldt=con_cvap-con_csol + real(krealfp),parameter:: heat=con_hvap+con_hfus + real(krealfp),parameter:: xpona=-dldt/con_rv + real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) + real(krealfp) t,tr,pvt,el,dpvt,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + do i=1,100 + tr=con_ttp/t + pvt=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) + el=heat+dldt*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + terr=(pvt-pv)/dpvt + t=t-terr + if(abs(terr).le.terrm) exit + enddo + ftdpixg=t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtdp +!$$$ Subprogram Documentation Block +! +! Subprogram: gtdp Compute dewpoint temperature table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature table as a function of +! vapor pressure for inlinable function ftdp. +! Exact dewpoint temperatures are calculated in subprogram ftdpxg. +! The current implementation computes a table with a length +! of 5001 for vapor pressures ranging from 0.5 to 1000.5 Pascals +! giving a dewpoint temperature range of 208 to 319 Kelvin. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: call gtdp +! +! Subprograms called: +! (ftdpxg) inlinable function to compute dewpoint temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,t,x,pv +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0.5 + xmax=10000.5 + xinc=(xmax-xmin)/(nxtdp-1) + c1xtdp=1.-xmin/xinc + c2xtdp=1./xinc + t=208.0 + do jx=1,nxtdp + x=xmin+(jx-1)*xinc + pv=x + t=ftdpxg(t,pv) + tbtdp(jx)=t + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function ftdp(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdp Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A linear interpolation is done between values in a lookup table +! computed in gtdp. See documentation for ftdpxg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.02 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdp is about 75 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdp(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdp Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdp + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) + jx=min(xj,nxtdp-1._krealfp) + ftdp=tbtdp(jx)+(xj-jx)*(tbtdp(jx+1)-tbtdp(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdpq(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpq Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute dewpoint temperature from vapor pressure. +! A quadratic interpolation is done between values in a lookup table +! computed in gtdp. see documentation for ftdpxg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.00001 Kelvin +! for dewpoint temperatures greater than 250 Kelvin, +! but decreases to 0.002 Kelvin for a dewpoint around 230 Kelvin. +! On the Cray, ftdpq is about 60 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdpq(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpq Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpq + real(krealfp),intent(in):: pv + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) + jx=min(max(nint(xj),2),nxtdp-1) + dxj=xj-jx + fj1=tbtdp(jx-1) + fj2=tbtdp(jx) + fj3=tbtdp(jx+1) + ftdpq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdpx(pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpx Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute dewpoint temperature from vapor pressure. +! An approximate dewpoint temperature for function ftdpxg +! is obtained using ftdp so gtdp must be already called. +! See documentation for ftdpxg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdpx(pv) +! +! Input argument list: +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpx Real(krealfp) dewpoint temperature in Kelvin +! +! Subprograms called: +! (ftdp) inlinable function to compute dewpoint temperature +! (ftdpxg) inlinable function to compute dewpoint temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpx + real(krealfp),intent(in):: pv + real(krealfp) tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tg=ftdp(pv) + ftdpx=ftdpxg(tg,pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftdpxg(tg,pv) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftdpxg Compute dewpoint temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute dewpoint temperature from vapor pressure. +! A guess dewpoint temperature must be provided. +! The saturation vapor pressure over either liquid and ice is computed +! over liquid for temperatures above the triple point, +! over ice for temperatures 20 degress below the triple point, +! and a linear combination of the two for temperatures in between. +! The water model assumes a perfect gas, constant specific heats +! for gas, liquid and ice, and neglects the volume of the condensate. +! The model does account for the variation of the latent heat +! of condensation and sublimation with temperature. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formula +! pvsl=con_psat*(tr**xa)*exp(xb*(1.-tr)) +! where tr is ttp/t and other values are physical constants. +! The reference for this decision is Emanuel(1994), pages 116-117. +! The formula is inverted by iterating Newtonian approximations +! for each pvs until t is found to within 1.e-6 Kelvin. +! This function can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! 2001-02-26 Iredell ice phase +! +! Usage: tdp=ftdpxg(tg,pv) +! +! Input argument list: +! tg Real(krealfp) guess dewpoint temperature in Kelvin +! pv Real(krealfp) vapor pressure in Pascals +! +! Output argument list: +! ftdpxg Real(krealfp) dewpoint temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftdpxg + real(krealfp),intent(in):: tg,pv + real(krealfp),parameter:: terrm=1.e-6 + real(krealfp),parameter:: tliq=con_ttp + real(krealfp),parameter:: tice=con_ttp-20.0 + real(krealfp),parameter:: dldtl=con_cvap-con_cliq + real(krealfp),parameter:: heatl=con_hvap + real(krealfp),parameter:: xponal=-dldtl/con_rv + real(krealfp),parameter:: xponbl=-dldtl/con_rv+heatl/(con_rv*con_ttp) + real(krealfp),parameter:: dldti=con_cvap-con_csol + real(krealfp),parameter:: heati=con_hvap+con_hfus + real(krealfp),parameter:: xponai=-dldti/con_rv + real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) + real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + do i=1,100 + tr=con_ttp/t + if(t.ge.tliq) then + pvt=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + el=heatl+dldtl*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + elseif(t.lt.tice) then + pvt=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + el=heati+dldti*(t-con_ttp) + dpvt=el*pvt/(con_rv*t**2) + else + w=(t-tice)/(tliq-tice) + pvtl=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) + pvti=con_psat*(tr**xponai)*exp(xponbi*(1.-tr)) + pvt=w*pvtl+(1.-w)*pvti + ell=heatl+dldtl*(t-con_ttp) + eli=heati+dldti*(t-con_ttp) + dpvt=(w*ell*pvtl+(1.-w)*eli*pvti)/(con_rv*t**2) + endif + terr=(pvt-pv)/dpvt + t=t-terr + if(abs(terr).le.terrm) exit + enddo + ftdpxg=t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gthe +!$$$ Subprogram Documentation Block +! +! Subprogram: gthe Compute equivalent potential temperature table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute equivalent potential temperature table +! as a function of LCL temperature and pressure over 1e5 Pa +! to the kappa power for function fthe. +! Equivalent potential temperatures are calculated in subprogram fthex +! the current implementation computes a table with a first dimension +! of 241 for temperatures ranging from 183.16 to 303.16 Kelvin +! and a second dimension of 151 for pressure over 1e5 Pa +! to the kappa power ranging from 0.04**rocp to 1.10**rocp. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gthe +! +! Subprograms called: +! (fthex) inlinable function to compute equiv. pot. temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx,jy + real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=con_ttp-90._krealfp + xmax=con_ttp+30._krealfp + ymin=0.04_krealfp**con_rocp + ymax=1.10_krealfp**con_rocp + xinc=(xmax-xmin)/(nxthe-1) + c1xthe=1.-xmin/xinc + c2xthe=1./xinc + yinc=(ymax-ymin)/(nythe-1) + c1ythe=1.-ymin/yinc + c2ythe=1./yinc + do jy=1,nythe + y=ymin+(jy-1)*yinc + pk=y + do jx=1,nxthe + x=xmin+(jx-1)*xinc + t=x + tbthe(jx,jy)=fthex(t,pk) + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function fthe(t,pk) +!$$$ Subprogram Documentation Block +! +! Subprogram: fthe Compute equivalent potential temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute equivalent potential temperature at the LCL +! from temperature and pressure over 1e5 Pa to the kappa power. +! A bilinear interpolation is done between values in a lookup table +! computed in gthe. see documentation for fthex for details. +! Input values outside table range are reset to table extrema, +! except zero is returned for too cold or high LCLs. +! The interpolation accuracy is better than 0.01 Kelvin. +! On the Cray, fthe is almost 6 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: the=fthe(t,pk) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! fthe Real(krealfp) equivalent potential temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fthe + real(krealfp),intent(in):: t,pk + integer jx,jy + real(krealfp) xj,yj,ftx1,ftx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) + yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) + if(xj.ge.1..and.yj.ge.1.) then + jx=min(xj,nxthe-1._krealfp) + jy=min(yj,nythe-1._krealfp) + ftx1=tbthe(jx,jy)+(xj-jx)*(tbthe(jx+1,jy)-tbthe(jx,jy)) + ftx2=tbthe(jx,jy+1)+(xj-jx)*(tbthe(jx+1,jy+1)-tbthe(jx,jy+1)) + fthe=ftx1+(yj-jy)*(ftx2-ftx1) + else + fthe=0. + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftheq(t,pk) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftheq Compute equivalent potential temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute equivalent potential temperature at the LCL +! from temperature and pressure over 1e5 Pa to the kappa power. +! A biquadratic interpolation is done between values in a lookup table +! computed in gthe. see documentation for fthex for details. +! Input values outside table range are reset to table extrema, +! except zero is returned for too cold or high LCLs. +! The interpolation accuracy is better than 0.0002 Kelvin. +! On the Cray, ftheq is almost 3 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: the=ftheq(t,pk) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! ftheq Real(krealfp) equivalent potential temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftheq + real(krealfp),intent(in):: t,pk + integer jx,jy + real(krealfp) xj,yj,dxj,dyj + real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 + real(krealfp) ftx1,ftx2,ftx3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) + yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) + if(xj.ge.1..and.yj.ge.1.) then + jx=min(max(nint(xj),2),nxthe-1) + jy=min(max(nint(yj),2),nythe-1) + dxj=xj-jx + dyj=yj-jy + ft11=tbthe(jx-1,jy-1) + ft12=tbthe(jx-1,jy) + ft13=tbthe(jx-1,jy+1) + ft21=tbthe(jx,jy-1) + ft22=tbthe(jx,jy) + ft23=tbthe(jx,jy+1) + ft31=tbthe(jx+1,jy-1) + ft32=tbthe(jx+1,jy) + ft33=tbthe(jx+1,jy+1) + ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 + ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 + ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 + ftheq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 + else + ftheq=0. + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- +! elemental function fthex(t,pk) + function fthex(t,pk) +!$$$ Subprogram Documentation Block +! +! Subprogram: fthex Compute equivalent potential temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute equivalent potential temperature at the LCL +! from temperature and pressure over 1e5 Pa to the kappa power. +! Equivalent potential temperature is constant for a saturated parcel +! rising adiabatically up a moist adiabat when the heat and mass +! of the condensed water are neglected. Ice is also neglected. +! The formula for equivalent potential temperature (Holton) is +! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) +! where t is the temperature, pv is the saturated vapor pressure, +! pd is the dry pressure p-pv, el is the temperature dependent +! latent heat of condensation hvap+dldt*(t-ttp), and other values +! are physical constants defined in parameter statements in the code. +! Zero is returned if the input values make saturation impossible. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: the=fthex(t,pk) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! pk Real(krealfp) LCL pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! fthex Real(krealfp) equivalent potential temperature in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fthex + real(krealfp),intent(in):: t,pk + real(krealfp) p,tr,pv,pd,el,expo,expmax +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + p=pk**con_cpor + tr=con_ttp/t + pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + pd=p-pv + if(pd.gt.pv) then + el=con_hvap+con_dldt*(t-con_ttp) + expo=el*con_eps*pv/(con_cp*t*pd) + fthex=t*pd**(-con_rocp)*exp(expo) + else + fthex=0. + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtma +!$$$ Subprogram Documentation Block +! +! Subprogram: gtma Compute moist adiabat tables +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature and specific humidity tables +! as a function of equivalent potential temperature and +! pressure over 1e5 Pa to the kappa power for subprogram stma. +! Exact parcel temperatures are calculated in subprogram stmaxg. +! The current implementation computes a table with a first dimension +! of 151 for equivalent potential temperatures ranging from 200 to 500 +! Kelvin and a second dimension of 121 for pressure over 1e5 Pa +! to the kappa power ranging from 0.01**rocp to 1.10**rocp. +! +! Program History Log: +! 91-05-07 Iredell +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call gtma +! +! Subprograms called: +! (stmaxg) inlinable subprogram to compute parcel temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx,jy + real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,pk,the,t,q,tg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=200._krealfp + xmax=500._krealfp + ymin=0.01_krealfp**con_rocp + ymax=1.10_krealfp**con_rocp + xinc=(xmax-xmin)/(nxma-1) + c1xma=1.-xmin/xinc + c2xma=1./xinc + yinc=(ymax-ymin)/(nyma-1) + c1yma=1.-ymin/yinc + c2yma=1./yinc + do jy=1,nyma + y=ymin+(jy-1)*yinc + pk=y + tg=xmin*y + do jx=1,nxma + x=xmin+(jx-1)*xinc + the=x + call stmaxg(tg,the,pk,t,q) + tbtma(jx,jy)=t + tbqma(jx,jy)=q + tg=t + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental subroutine stma(the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stma Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature and specific humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! Bilinear interpolations are done between values in a lookup table +! computed in gtma. See documentation for stmaxg for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.01 Kelvin +! and 5.e-6 kg/kg for temperature and humidity, respectively. +! On the Cray, stma is about 35 times faster than exact calculation. +! This subprogram should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell expand table +! 1999-03-01 Iredell f90 module +! +! Usage: call stma(the,pk,tma,qma) +! +! Input argument list: +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: the,pk + real(krealfp),intent(out):: tma,qma + integer jx,jy + real(krealfp) xj,yj,ftx1,ftx2,qx1,qx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) + yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) + jx=min(xj,nxma-1._krealfp) + jy=min(yj,nyma-1._krealfp) + ftx1=tbtma(jx,jy)+(xj-jx)*(tbtma(jx+1,jy)-tbtma(jx,jy)) + ftx2=tbtma(jx,jy+1)+(xj-jx)*(tbtma(jx+1,jy+1)-tbtma(jx,jy+1)) + tma=ftx1+(yj-jy)*(ftx2-ftx1) + qx1=tbqma(jx,jy)+(xj-jx)*(tbqma(jx+1,jy)-tbqma(jx,jy)) + qx2=tbqma(jx,jy+1)+(xj-jx)*(tbqma(jx+1,jy+1)-tbqma(jx,jy+1)) + qma=qx1+(yj-jy)*(qx2-qx1) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental subroutine stmaq(the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stmaq Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature and specific humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! Biquadratic interpolations are done between values in a lookup table +! computed in gtma. See documentation for stmaxg for details. +! Input values outside table range are reset to table extrema. +! the interpolation accuracy is better than 0.0005 Kelvin +! and 1.e-7 kg/kg for temperature and humidity, respectively. +! On the Cray, stmaq is about 25 times faster than exact calculation. +! This subprogram should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell quadratic interpolation +! 1999-03-01 Iredell f90 module +! +! Usage: call stmaq(the,pk,tma,qma) +! +! Input argument list: +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tmaq Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: the,pk + real(krealfp),intent(out):: tma,qma + integer jx,jy + real(krealfp) xj,yj,dxj,dyj + real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 + real(krealfp) ftx1,ftx2,ftx3 + real(krealfp) q11,q12,q13,q21,q22,q23,q31,q32,q33,qx1,qx2,qx3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) + yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) + jx=min(max(nint(xj),2),nxma-1) + jy=min(max(nint(yj),2),nyma-1) + dxj=xj-jx + dyj=yj-jy + ft11=tbtma(jx-1,jy-1) + ft12=tbtma(jx-1,jy) + ft13=tbtma(jx-1,jy+1) + ft21=tbtma(jx,jy-1) + ft22=tbtma(jx,jy) + ft23=tbtma(jx,jy+1) + ft31=tbtma(jx+1,jy-1) + ft32=tbtma(jx+1,jy) + ft33=tbtma(jx+1,jy+1) + ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 + ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 + ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 + tma=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 + q11=tbqma(jx-1,jy-1) + q12=tbqma(jx-1,jy) + q13=tbqma(jx-1,jy+1) + q21=tbqma(jx,jy-1) + q22=tbqma(jx,jy) + q23=tbqma(jx,jy+1) + q31=tbqma(jx+1,jy-1) + q32=tbqma(jx+1,jy) + q33=tbqma(jx+1,jy+1) + qx1=(((q31+q11)/2-q21)*dxj+(q31-q11)/2)*dxj+q21 + qx2=(((q32+q12)/2-q22)*dxj+(q32-q12)/2)*dxj+q22 + qx3=(((q33+q13)/2-q23)*dxj+(q33-q13)/2)*dxj+q23 + qma=(((qx3+qx1)/2-qx2)*dyj+(qx3-qx1)/2)*dyj+qx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental subroutine stmax(the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stmax Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Exactly compute temperature and humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! An approximate parcel temperature for subprogram stmaxg +! is obtained using stma so gtma must be already called. +! See documentation for stmaxg for details. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: call stmax(the,pk,tma,qma) +! +! Input argument list: +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Subprograms called: +! (stma) inlinable subprogram to compute parcel temperature +! (stmaxg) inlinable subprogram to compute parcel temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: the,pk + real(krealfp),intent(out):: tma,qma + real(krealfp) tg,qg +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call stma(the,pk,tg,qg) + call stmaxg(tg,the,pk,tma,qma) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental subroutine stmaxg(tg,the,pk,tma,qma) +!$$$ Subprogram Documentation Block +! +! Subprogram: stmaxg Compute moist adiabat temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: exactly compute temperature and humidity of a parcel +! lifted up a moist adiabat from equivalent potential temperature +! at the LCL and pressure over 1e5 Pa to the kappa power. +! A guess parcel temperature must be provided. +! Equivalent potential temperature is constant for a saturated parcel +! rising adiabatically up a moist adiabat when the heat and mass +! of the condensed water are neglected. Ice is also neglected. +! The formula for equivalent potential temperature (Holton) is +! the=t*(pd**(-rocp))*exp(el*eps*pv/(cp*t*pd)) +! where t is the temperature, pv is the saturated vapor pressure, +! pd is the dry pressure p-pv, el is the temperature dependent +! latent heat of condensation hvap+dldt*(t-ttp), and other values +! are physical constants defined in parameter statements in the code. +! The formula is inverted by iterating Newtonian approximations +! for each the and p until t is found to within 1.e-4 Kelvin. +! The specific humidity is then computed from pv and pd. +! This subprogram can be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell exact computation +! 1999-03-01 Iredell f90 module +! +! Usage: call stmaxg(tg,the,pk,tma,qma) +! +! Input argument list: +! tg Real(krealfp) guess parcel temperature in Kelvin +! the Real(krealfp) equivalent potential temperature in Kelvin +! pk Real(krealfp) pressure over 1e5 Pa to the kappa power +! +! Output argument list: +! tma Real(krealfp) parcel temperature in Kelvin +! qma Real(krealfp) parcel specific humidity in kg/kg +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp),intent(in):: tg,the,pk + real(krealfp),intent(out):: tma,qma + real(krealfp),parameter:: terrm=1.e-4 + real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + t=tg + p=pk**con_cpor + do i=1,100 + tr=con_ttp/t + pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + pd=p-pv + el=con_hvap+con_dldt*(t-con_ttp) + expo=el*con_eps*pv/(con_cp*t*pd) + thet=t*pd**(-con_rocp)*exp(expo) + dthet=thet/t*(1.+expo*(con_dldt*t/el+el*p/(con_rv*t*pd))) + terr=(thet-the)/dthet + t=t-terr + if(abs(terr).le.terrm) exit + enddo + tma=t + tr=con_ttp/t + pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + pd=p-pv + qma=con_eps*pv/(pd+con_eps*pv) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + subroutine gpkap +!$$$ Subprogram documentation block +! +! Subprogram: gpkap Compute coefficients for p**kappa +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Computes pressure to the kappa table as a function of pressure +! for the table lookup function fpkap. +! Exact pressure to the kappa values are calculated in subprogram fpkapx. +! The current implementation computes a table with a length +! of 5501 for pressures ranging up to 110000 Pascals. +! +! Program History Log: +! 94-12-30 Iredell +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: call gpkap +! +! Subprograms called: +! fpkapx function to compute exact pressure to the kappa +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0._krealfp + xmax=110000._krealfp + xinc=(xmax-xmin)/(nxpkap-1) + c1xpkap=1.-xmin/xinc + c2xpkap=1./xinc + do jx=1,nxpkap + x=xmin+(jx-1)*xinc + p=x + tbpkap(jx)=fpkapx(p) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function fpkap(p) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpkap raise pressure to the kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the kappa power. +! A linear interpolation is done between values in a lookup table +! computed in gpkap. See documentation for fpkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy ranges from 9 decimal places +! at 100000 Pascals to 5 decimal places at 1000 Pascals. +! On the Cray, fpkap is over 5 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: pkap=fpkap(p) +! +! Input argument list: +! p Real(krealfp) pressure in Pascals +! +! Output argument list: +! fpkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkap + real(krealfp),intent(in):: p + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) + jx=min(xj,nxpkap-1._krealfp) + fpkap=tbpkap(jx)+(xj-jx)*(tbpkap(jx+1)-tbpkap(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpkapq(p) +!$$$ Subprogram Documentation Block +! +! Subprogram: fpkapq raise pressure to the kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the kappa power. +! A quadratic interpolation is done between values in a lookup table +! computed in gpkap. see documentation for fpkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy ranges from 12 decimal places +! at 100000 Pascals to 7 decimal places at 1000 Pascals. +! On the Cray, fpkap is over 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: pkap=fpkapq(p) +! +! Input argument list: +! p Real(krealfp) pressure in Pascals +! +! Output argument list: +! fpkapq Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkapq + real(krealfp),intent(in):: p + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) + jx=min(max(nint(xj),2),nxpkap-1) + dxj=xj-jx + fj1=tbpkap(jx-1) + fj2=tbpkap(jx) + fj3=tbpkap(jx+1) + fpkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + function fpkapo(p) +!$$$ Subprogram documentation block +! +! Subprogram: fpkapo raise surface pressure to the kappa power. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Raise surface pressure over 1e5 Pa to the kappa power +! using a rational weighted chebyshev approximation. +! The numerator is of order 2 and the denominator is of order 4. +! The pressure range is 40000-110000 Pa and kappa is defined in fpkapx. +! The accuracy of this approximation is almost 8 decimal places. +! On the Cray, fpkap is over 10 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! +! Usage: pkap=fpkapo(p) +! +! Input argument list: +! p Real(krealfp) surface pressure in Pascals +! p should be in the range 40000 to 110000 +! +! Output argument list: +! fpkapo Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkapo + real(krealfp),intent(in):: p + integer,parameter:: nnpk=2,ndpk=4 + real(krealfp):: cnpk(0:nnpk)=(/3.13198449e-1,5.78544829e-2,& + 8.35491871e-4/) + real(krealfp):: cdpk(0:ndpk)=(/1.,8.15968401e-2,5.72839518e-4,& + -4.86959812e-7,5.24459889e-10/) + integer n + real(krealfp) pkpa,fnpk,fdpk +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + pkpa=p*1.e-3_krealfp + fnpk=cnpk(nnpk) + do n=nnpk-1,0,-1 + fnpk=pkpa*fnpk+cnpk(n) + enddo + fdpk=cdpk(ndpk) + do n=ndpk-1,0,-1 + fdpk=pkpa*fdpk+cdpk(n) + enddo + fpkapo=fnpk/fdpk +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function fpkapx(p) +!$$$ Subprogram documentation block +! +! Subprogram: fpkapx raise pressure to the kappa power. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: raise pressure over 1e5 Pa to the kappa power. +! Kappa is equal to rd/cp where rd and cp are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 94-12-30 Iredell made into inlinable function +! 1999-03-01 Iredell f90 module +! +! Usage: pkap=fpkapx(p) +! +! Input argument list: +! p Real(krealfp) pressure in Pascals +! +! Output argument list: +! fpkapx Real(krealfp) p over 1e5 Pa to the kappa power +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) fpkapx + real(krealfp),intent(in):: p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + fpkapx=(p/1.e5_krealfp)**con_rocp +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine grkap +!$$$ Subprogram documentation block +! +! Subprogram: grkap Compute coefficients for p**(1/kappa) +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Computes pressure to the 1/kappa table as a function of pressure +! for the table lookup function frkap. +! Exact pressure to the 1/kappa values are calculated in subprogram frkapx. +! The current implementation computes a table with a length +! of 5501 for pressures ranging up to 110000 Pascals. +! +! Program History Log: +! 94-12-30 Iredell +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: call grkap +! +! Subprograms called: +! frkapx function to compute exact pressure to the 1/kappa +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx + real(krealfp) xmin,xmax,xinc,x,p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=0._krealfp + xmax=fpkapx(110000._krealfp) + xinc=(xmax-xmin)/(nxrkap-1) + c1xrkap=1.-xmin/xinc + c2xrkap=1./xinc + do jx=1,nxrkap + x=xmin+(jx-1)*xinc + p=x + tbrkap(jx)=frkapx(p) + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function frkap(pkap) +!$$$ Subprogram Documentation Block +! +! Subprogram: frkap raise pressure to the 1/kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. +! A linear interpolation is done between values in a lookup table +! computed in grkap. See documentation for frkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 7 decimal places. +! On the IBM, fpkap is about 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: p=frkap(pkap) +! +! Input argument list: +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Output argument list: +! frkap Real(krealfp) pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) frkap + real(krealfp),intent(in):: pkap + integer jx + real(krealfp) xj +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) + jx=min(xj,nxrkap-1._krealfp) + frkap=tbrkap(jx)+(xj-jx)*(tbrkap(jx+1)-tbrkap(jx)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function frkapq(pkap) +!$$$ Subprogram Documentation Block +! +! Subprogram: frkapq raise pressure to the 1/kappa power. +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Raise pressure over 1e5 Pa to the 1/kappa power. +! A quadratic interpolation is done between values in a lookup table +! computed in grkap. see documentation for frkapx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 11 decimal places. +! On the IBM, fpkap is almost 4 times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 94-12-30 Iredell standardized kappa, +! increased range and accuracy +! 1999-03-01 Iredell f90 module +! 1999-03-24 Iredell table lookup +! +! Usage: p=frkapq(pkap) +! +! Input argument list: +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Output argument list: +! frkapq Real(krealfp) pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) frkapq + real(krealfp),intent(in):: pkap + integer jx + real(krealfp) xj,dxj,fj1,fj2,fj3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) + jx=min(max(nint(xj),2),nxrkap-1) + dxj=xj-jx + fj1=tbrkap(jx-1) + fj2=tbrkap(jx) + fj3=tbrkap(jx+1) + frkapq=(((fj3+fj1)/2-fj2)*dxj+(fj3-fj1)/2)*dxj+fj2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function frkapx(pkap) +!$$$ Subprogram documentation block +! +! Subprogram: frkapx raise pressure to the 1/kappa power. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: raise pressure over 1e5 Pa to the 1/kappa power. +! Kappa is equal to rd/cp where rd and cp are physical constants. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 94-12-30 Iredell made into inlinable function +! 1999-03-01 Iredell f90 module +! +! Usage: p=frkapx(pkap) +! +! Input argument list: +! pkap Real(krealfp) p over 1e5 Pa to the kappa power +! +! Output argument list: +! frkapx Real(krealfp) pressure in Pascals +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) frkapx + real(krealfp),intent(in):: pkap +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + frkapx=pkap**(1/con_rocp)*1.e5_krealfp +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gtlcl +!$$$ Subprogram Documentation Block +! +! Subprogram: gtlcl Compute equivalent potential temperature table +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute lifting condensation level temperature table +! as a function of temperature and dewpoint depression for function ftlcl. +! Lifting condensation level temperature is calculated in subprogram ftlclx +! The current implementation computes a table with a first dimension +! of 151 for temperatures ranging from 180.0 to 330.0 Kelvin +! and a second dimension of 61 for dewpoint depression ranging from +! 0 to 60 Kelvin. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: call gtlcl +! +! Subprograms called: +! (ftlclx) inlinable function to compute LCL temperature +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + integer jx,jy + real(krealfp) xmin,xmax,ymin,ymax,xinc,yinc,x,y,tdpd,t +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xmin=180._krealfp + xmax=330._krealfp + ymin=0._krealfp + ymax=60._krealfp + xinc=(xmax-xmin)/(nxtlcl-1) + c1xtlcl=1.-xmin/xinc + c2xtlcl=1./xinc + yinc=(ymax-ymin)/(nytlcl-1) + c1ytlcl=1.-ymin/yinc + c2ytlcl=1./yinc + do jy=1,nytlcl + y=ymin+(jy-1)*yinc + tdpd=y + do jx=1,nxtlcl + x=xmin+(jx-1)*xinc + t=x + tbtlcl(jx,jy)=ftlclx(t,tdpd) + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- + elemental function ftlcl(t,tdpd) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftlcl Compute LCL temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. +! A bilinear interpolation is done between values in a lookup table +! computed in gtlcl. See documentation for ftlclx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.0005 Kelvin. +! On the Cray, ftlcl is ? times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: tlcl=ftlcl(t,tdpd) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlcl Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlcl + real(krealfp),intent(in):: t,tdpd + integer jx,jy + real(krealfp) xj,yj,ftx1,ftx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) + yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) + jx=min(xj,nxtlcl-1._krealfp) + jy=min(yj,nytlcl-1._krealfp) + ftx1=tbtlcl(jx,jy)+(xj-jx)*(tbtlcl(jx+1,jy)-tbtlcl(jx,jy)) + ftx2=tbtlcl(jx,jy+1)+(xj-jx)*(tbtlcl(jx+1,jy+1)-tbtlcl(jx,jy+1)) + ftlcl=ftx1+(yj-jy)*(ftx2-ftx1) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftlclq(t,tdpd) +!$$$ Subprogram Documentation Block +! +! Subprogram: ftlclq Compute LCL temperature +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. +! A biquadratic interpolation is done between values in a lookup table +! computed in gtlcl. see documentation for ftlclx for details. +! Input values outside table range are reset to table extrema. +! The interpolation accuracy is better than 0.000003 Kelvin. +! On the Cray, ftlclq is ? times faster than exact calculation. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: tlcl=ftlclq(t,tdpd) +! +! Input argument list: +! t Real(krealfp) LCL temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlcl Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlclq + real(krealfp),intent(in):: t,tdpd + integer jx,jy + real(krealfp) xj,yj,dxj,dyj + real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 + real(krealfp) ftx1,ftx2,ftx3 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) + yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) + jx=min(max(nint(xj),2),nxtlcl-1) + jy=min(max(nint(yj),2),nytlcl-1) + dxj=xj-jx + dyj=yj-jy + ft11=tbtlcl(jx-1,jy-1) + ft12=tbtlcl(jx-1,jy) + ft13=tbtlcl(jx-1,jy+1) + ft21=tbtlcl(jx,jy-1) + ft22=tbtlcl(jx,jy) + ft23=tbtlcl(jx,jy+1) + ft31=tbtlcl(jx+1,jy-1) + ft32=tbtlcl(jx+1,jy) + ft33=tbtlcl(jx+1,jy+1) + ftx1=(((ft31+ft11)/2-ft21)*dxj+(ft31-ft11)/2)*dxj+ft21 + ftx2=(((ft32+ft12)/2-ft22)*dxj+(ft32-ft12)/2)*dxj+ft22 + ftx3=(((ft33+ft13)/2-ft23)*dxj+(ft33-ft13)/2)*dxj+ft23 + ftlclq=(((ftx3+ftx1)/2-ftx2)*dyj+(ftx3-ftx1)/2)*dyj+ftx2 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + function ftlclo(t,tdpd) +!$$$ Subprogram documentation block +! +! Subprogram: ftlclo Compute LCL temperature. +! Author: Phillips org: w/NMC2X2 Date: 29 dec 82 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. the formula used is +! a polynomial taken from Phillips mstadb routine which empirically +! approximates the original exact implicit relationship. +! (This kind of approximation is customary (inman, 1969), but +! the original source for this particular one is not yet known. -MI) +! Its accuracy is about 0.03 Kelvin for a dewpoint depression of 30. +! This function should be expanded inline in the calling routine. +! +! Program History Log: +! 91-05-07 Iredell made into inlinable function +! 1999-03-01 Iredell f90 module +! +! Usage: tlcl=ftlclo(t,tdpd) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlclo Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlclo + real(krealfp),intent(in):: t,tdpd + real(krealfp),parameter:: clcl1= 0.954442e+0,clcl2= 0.967772e-3,& + clcl3=-0.710321e-3,clcl4=-0.270742e-5 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ftlclo=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + elemental function ftlclx(t,tdpd) +!$$$ Subprogram documentation block +! +! Subprogram: ftlclx Compute LCL temperature. +! Author: Iredell org: w/NMC2X2 Date: 25 March 1999 +! +! Abstract: Compute temperature at the lifting condensation level +! from temperature and dewpoint depression. A parcel lifted +! adiabatically becomes saturated at the lifting condensation level. +! The water model assumes a perfect gas, constant specific heats +! for gas and liquid, and neglects the volume of the liquid. +! The model does account for the variation of the latent heat +! of condensation with temperature. The ice option is not included. +! The Clausius-Clapeyron equation is integrated from the triple point +! to get the formulas +! pvlcl=con_psat*(trlcl**xa)*exp(xb*(1.-trlcl)) +! pvdew=con_psat*(trdew**xa)*exp(xb*(1.-trdew)) +! where pvlcl is the saturated parcel vapor pressure at the LCL, +! pvdew is the unsaturated parcel vapor pressure initially, +! trlcl is ttp/tlcl and trdew is ttp/tdew. The adiabatic lifting +! of the parcel is represented by the following formula +! pvdew=pvlcl*(t/tlcl)**(1/kappa) +! This formula is inverted by iterating Newtonian approximations +! until tlcl is found to within 1.e-6 Kelvin. Note that the minimum +! returned temperature is 180 Kelvin. +! +! Program History Log: +! 1999-03-25 Iredell +! +! Usage: tlcl=ftlclx(t,tdpd) +! +! Input argument list: +! t Real(krealfp) temperature in Kelvin +! tdpd Real(krealfp) dewpoint depression in Kelvin +! +! Output argument list: +! ftlclx Real(krealfp) temperature at the LCL in Kelvin +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none + real(krealfp) ftlclx + real(krealfp),intent(in):: t,tdpd + real(krealfp),parameter:: terrm=1.e-4,tlmin=180.,tlminx=tlmin-5. + real(krealfp) tr,pvdew,tlcl,ta,pvlcl,el,dpvlcl,terr,terrp + integer i +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + tr=con_ttp/(t-tdpd) + pvdew=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr)) + tlcl=t-tdpd + do i=1,100 + tr=con_ttp/tlcl + ta=t/tlcl + pvlcl=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr))*ta**(1/con_rocp) + el=con_hvap+con_dldt*(tlcl-con_ttp) + dpvlcl=(el/(con_rv*t**2)+1/(con_rocp*tlcl))*pvlcl + terr=(pvlcl-pvdew)/dpvlcl + tlcl=tlcl-terr + if(abs(terr).le.terrm.or.tlcl.lt.tlminx) exit + enddo + ftlclx=max(tlcl,tlmin) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end function +!------------------------------------------------------------------------------- + subroutine gfuncphys +!$$$ Subprogram Documentation Block +! +! Subprogram: gfuncphys Compute all physics function tables +! Author: N Phillips w/NMC2X2 Date: 30 dec 82 +! +! Abstract: Compute all physics function tables. Lookup tables are +! set up for computing saturation vapor pressure, dewpoint temperature, +! equivalent potential temperature, moist adiabatic temperature and humidity, +! pressure to the kappa, and lifting condensation level temperature. +! +! Program History Log: +! 1999-03-01 Iredell f90 module +! +! Usage: call gfuncphys +! +! Subprograms called: +! gpvsl compute saturation vapor pressure over liquid table +! gpvsi compute saturation vapor pressure over ice table +! gpvs compute saturation vapor pressure table +! gtdpl compute dewpoint temperature over liquid table +! gtdpi compute dewpoint temperature over ice table +! gtdp compute dewpoint temperature table +! gthe compute equivalent potential temperature table +! gtma compute moist adiabat tables +! gpkap compute pressure to the kappa table +! grkap compute pressure to the 1/kappa table +! gtlcl compute LCL temperature table +! +! Attributes: +! Language: Fortran 90. +! +!$$$ + implicit none +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + call gpvsl + call gpvsi + call gpvs + call gtdpl + call gtdpi + call gtdp + call gthe + call gtma + call gpkap + call grkap + call gtlcl +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine +!------------------------------------------------------------------------------- +end module diff --git a/gsmphys/gcm_shoc.f90 b/gsmphys/gcm_shoc.f90 new file mode 100644 index 00000000..63805727 --- /dev/null +++ b/gsmphys/gcm_shoc.f90 @@ -0,0 +1,1713 @@ + +! Implementation of the Simplified High Order Closure (SHOC) scheme +! of Bogenschutz and Krueger (2013), J. Adv. Model. Earth Syst, 5, 195-211, +! doi: 10.1002/jame.200118. (further referred to as BK13) +! in a single column form suitable for use in a GCM physics package. +! Alex Belochitski, heavily based on the code of Peter Bogenschutz. +! S Moorthi - optimization, cleanup, improve and customize for gsm + + + + subroutine shoc(ix, nx, ny, nzm, nz, dtn, me, lat, & + prsl, phii, phil, u, v, omega, tabs, & +! qwv, qi, qc, qpi, qpl, cld_sgs, & + qwv, qi, qc, qpi, qpl, rhc, supice, cld_sgs, & + tke, hflx, evap, prnum, tkh, wthv_sec,lprnt,ipr,& + ncpl,ncpi) + + use funcphys , only : fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice + +! Map constants of the NCEP GFS to those of SHOC + + use physcons, cp => con_cp, & ! Specific heat of air, J/kg/K + ggr => con_g, & ! Gravity acceleration, m/s2 + lcond => con_hvap, & ! Latent heat of condensation, J/kg + lfus => con_hfus, & ! Latent heat of fusion, J/kg + rv => con_rv, & ! Gas constant for water vapor, J/kg/K + rgas => con_rd, & ! Gas constant for dry air, J/kg/K + pi => con_pi, & ! Pi + epsv => con_fvirt + + implicit none + + real, parameter :: lsub = lcond+lfus, fac_cond = lcond/cp, fac_fus = lfus/cp, & + cpolv = cp/lcond, & + fac_sub = lsub/cp, ggri = 1.0/ggr, kapa = rgas/cp, & + gocp = ggr/cp, rog = rgas*ggri, sqrt2 = sqrt(2.0), & + sqrtpii = 1.0/sqrt(pi+pi), epsterm = rgas/rv, twoby3 = 2.0/3.0, & + onebeps = 1.0/epsterm, twoby15 = 2.0 / 15.0, & + onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=1.0, & +! onebrvcp= 1.0/(rv*cp), skew_facw=1.2, skew_fact=0.0, & + tkef1=0.5, tkef2=1.0-tkef1, tkhmax=1000.0, cefac=1.5, & + zero=0.0, one=1.0, half=0.5, two=2.0, eps=0.622, & +! scrit=5.0e-6 + scrit=1.0e-5 +! scrit=1.0e-6 +! skew_facw=1.2, skew_fact=0.5 +! onebeps = 1.0/epsterm, twoby15 = 2.0 / 15.0, skew_facw=1.2 ! orig + +! real, parameter :: supice=1.05 + + logical lprnt + integer ipr + integer, intent(in) :: ix ! max number of points in the physics window in the x + integer, intent(in) :: nx ! Number of points in the physics window in the x + integer, intent(in) :: ny ! and y directions + integer, intent(in) :: me ! MPI rank + integer, intent(in) :: lat ! latitude + + integer, intent(in) :: nzm ! Number of vertical layers + integer, intent(in) :: nz ! Number of layer interfaces (= nzm + 1) + real, intent(in) :: dtn ! Physics time step, s + real, intent(in) :: hflx(nx) + real, intent(in) :: evap(nx) + +! The interface is talored to GFS in a sense that input variables are 2D + + real, intent(in) :: prsl (ix,ny,nzm) ! mean layer presure + real, intent(in) :: phii (ix,ny,nz ) ! interface geopotential height + real, intent(in) :: phil (ix,ny,nzm) ! layer geopotential height + real, intent(in) :: u (ix,ny,nzm) ! u-wind, m/s + real, intent(in) :: v (ix,ny,nzm) ! v-wind, m/s + real, intent(in) :: omega (ix,ny,nzm) ! omega, Pa/s + real, intent(inout) :: tabs (ix,ny,nzm) ! temperature, K + real, intent(inout) :: qwv (ix,ny,nzm) ! water vapor mixing ratio, kg/kg + real, intent(inout) :: qc (ix,ny,nzm) ! cloud water mixing ratio, kg/kg + real, intent(inout) :: qi (ix,ny,nzm) ! cloud ice mixing ratio, kg/kg +! Anning Cheng 03/11/2016 SHOC feedback to number concentration + real, intent(inout) :: ncpl (nx,ny,nzm) ! cloud water number concentration,/m^3 + real, intent(inout) :: ncpi (nx,ny,nzm) ! cloud ice number concentration,/m^3 + real, intent(inout) :: qpl (nx,ny,nzm) ! rain mixing ratio, kg/kg + real, intent(inout) :: qpi (nx,ny,nzm) ! snow mixing ratio, kg/kg + real, intent(inout) :: rhc (nx,ny,nzm) ! critical relative humidity + real, intent(in) :: supice ! ice supersaturation parameter + real, intent(inout) :: cld_sgs(ix,ny,nzm) ! sgs cloud fraction +! real, intent(inout) :: cld_sgs(nx,ny,nzm) ! sgs cloud fraction + real, intent(inout) :: tke (ix,ny,nzm) ! turbulent kinetic energy. m**2/s**2 +! real, intent(inout) :: tk (nx,ny,nzm) ! eddy viscosity + real, intent(inout) :: tkh (ix,ny,nzm) ! eddy diffusivity + real, intent(inout) :: prnum (nx,ny,nzm) ! turbulent Prandtl number + real, intent(inout) :: wthv_sec (ix,ny,nzm) ! Buoyancy flux, K*m/s + +! SHOC tunable parameters + + real, parameter :: lambda = 0.04 +! real, parameter :: min_tke = 1e-6 ! Minumum TKE value, m**2/s**2 + real, parameter :: min_tke = 1e-4 ! Minumum TKE value, m**2/s**2 +! real, parameter :: max_tke = 400.0 ! Maximum TKE value, m**2/s**2 + real, parameter :: max_tke = 225.0 ! Maximum TKE value, m**2/s**2 +! real, parameter :: max_tke = 100.0 ! Maximum TKE value, m**2/s**2 +! real, parameter :: max_tke = 5. ! Maximum TKE value, m**2/s**2 +! Maximum turbulent eddy length scale, m + real, parameter :: max_eddy_length_scale = 2000. +! Maximum "return-to-isotropy" time scale, s + real, parameter :: max_eddy_dissipation_time_scale = 2000. + real, parameter :: Pr = 1.0 ! Prandtl number +! real, parameter :: Prnum = 1.0 ! Prandtl number + +! Constants for the TKE dissipation term based on Deardorff (1980) + real, parameter :: pt19=0.19, pt51=0.51, pt01=0.01 + real, parameter :: Cs = 0.15 + real, parameter :: Ck = 0.1 ! Coeff in the eddy diffusivity - TKE relationship, see Eq. 7 in BK13 +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.2 +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 3.0 , Ces = Ce +! real, parameter :: Ce = Ck**3/(0.7*Cs**4) * 2.5 , Ces = Ce * 3.0 / 2.5 +! real, parameter :: Ces = Ce/0.7*3.0 + +! real, parameter :: Ce = Ck**3/(0.7*Cs**4), Ces = Ce*3.0/0.7 ! Commented Moor + + real, parameter :: Ce = Ck**3/Cs**4, Ces = Ce*3.0/0.7 + +! real, parameter :: vonk=0.35 ! Von Karman constant + real, parameter :: vonk=0.4 ! Von Karman constant Moorthi - as in GFS + real, parameter :: tscale=400.! time scale set based off of similarity results of BK13, s + real, parameter :: w_tol_sqd = 4.0e-04 ! Min vlaue of second moment of w +! real, parameter :: w_tol_sqd = 1.0e-04 ! Min vlaue of second moment of w + real, parameter :: w_thresh = 0.0, thresh = 0.0 + + +! These parameters are a tie-in with a microphysical scheme +! Double check their values for the Zhao-Carr scheme. + real, parameter :: tbgmin = 258.16 ! Minimum temperature for cloud water., K (ZC) +! real, parameter :: tbgmin = 253.16 ! Minimum temperature for cloud water., K + real, parameter :: tbgmax = 273.16 ! Maximum temperature for cloud ice, K + real, parameter :: a_bg = one/(tbgmax-tbgmin) +! +! Parameters to tune the second order moments- No tuning is performed currently + + real, parameter :: thl2tune = 1.0, qw2tune = 1.0, qwthl2tune = 1.0, & +! thl_tol = 1.e-4, rt_tol = 1.e-8, basetemp = 300.0 + thl_tol = 1.e-2, rt_tol = 1.e-4, basetemp = 300.0 + + integer, parameter :: nitr=6 + +! Local variables. Note that pressure is in millibars in the SHOC code. + + real zl (nx,ny,nzm) ! height of the pressure levels above surface, m + real zi (nx,ny,nz) ! height of the interface levels, m + real adzl (nx,ny,nzm) ! layer thickness i.e. zi(k+1)-zi(k) - defined at levels + real adzi (nx,ny,nz) ! level thickness i.e. zl(k)-zl(k-1) - defined at interface + + real hl (nx,ny,nzm) ! liquid/ice water static energy , K + real qv (nx,ny,nzm) ! water vapor, kg/kg + real qcl (nx,ny,nzm) ! liquid water (condensate), kg/kg + real qci (nx,ny,nzm) ! ice water (condensate), kg/kg + real w (nx,ny,nzm) ! z-wind, m/s + real bet (nx,ny,nzm) ! ggr/tv0 + real gamaz (nx,ny,nzm) ! ggr/cp*z + +! Moments of the trivariate double Gaussian PDF for the SGS total water mixing ratio +! SGS liquid/ice static energy, and vertical velocity + + real qw_sec (nx,ny,nzm) ! Second moment total water mixing ratio, kg^2/kg^2 + real thl_sec (nx,ny,nzm) ! Second moment liquid/ice static energy, K^2 + real qwthl_sec(nx,ny,nzm) ! Covariance tot. wat. mix. ratio and static energy, K*kg/kg + real wqw_sec (nx,ny,nzm) ! Turbulent flux of tot. wat. mix., kg/kg*m/s + real wthl_sec (nx,ny,nzm) ! Turbulent flux of liquid/ice static energy, K*m/s + real w_sec (nx,ny,nzm) ! Second moment of vertical velocity, m**2/s**2 + real w3 (nx,ny,nzm) ! Third moment of vertical velocity, m**3/s**3 + real wqp_sec (nx,ny,nzm) ! Turbulent flux of precipitation, kg/kg*m/s + +! Eddy length formulation + real smixt (nx,ny,nzm) ! Turbulent length scale, m + real isotropy (nx,ny,nzm) ! "Return-to-isotropy" eddy dissipation time scale, s +! real isotropy_debug (nx,ny,nzm) ! Return to isotropy scale, s without artificial limits + real brunt (nx,ny,nzm) ! Moist Brunt-Vaisalla frequency, s^-1 + real conv_vel2(nx,ny,nzm) ! Convective velocity scale cubed, m^3/s^3 + +! Output of SHOC + real diag_frac, diag_qn, diag_qi, diag_ql + +! real diag_frac(nx,ny,nzm) ! SGS cloud fraction +! real diag_qn (nx,ny,nzm) ! SGS cloud+ice condensate, kg/kg +! real diag_qi (nx,ny,nzm) ! SGS ice condensate, kg/kg +! real diag_ql (nx,ny,nzm) ! SGS liquid condensate, kg/kg + + +! Horizontally averaged variables +! real conv_vel(nzm) ! Convective velocity scale cubed, m^3/s^3 + real wqlsb (nzm) ! liquid water flux, kg/kg/ m/s + real wqisb (nzm) ! ice flux, kg/kg m/s +! real thlv (nzm) ! Grid-scale level-average virtual potential temperature +! (not used) + + +! Local variables + + real, dimension(nx,ny,nzm) :: tkesbdiss +! real, dimension(nx,ny,nzm) :: tkesbbuoy, tkesbshear, tkesbdiss, tkesbbuoy_debug & +! tkebuoy_sgs, total_water, tscale1_debug, brunt2 + + real, dimension(nx,ny,nzm) :: total_water, brunt2, def2, thv + + real, dimension(nx,ny) :: denom, numer, l_inf, cldarr + + real lstarn, depth, omn, betdz, bbb, term, qsatt, dqsat, & + thedz, conv_var, tkes, skew_w, skew_qw, aterm, w1_1, w1_2, w2_1, & + w2_2, w3var, thl1_1, thl1_2, thl2_1, thl2_2, qw1_1, qw1_2, qw2_1, & + qw2_2, ql1, ql2, w_ql1, w_ql2, & + r_qwthl_1, r_wqw_1, r_wthl_1, testvar, s1, s2, std_s1, std_s2, C1, C2, & + thl_first, qw_first, w_first, Tl1_1, Tl1_2, betatest, pval, pkap, & + w2thl, w2qw,w2ql, w2ql_1, w2ql_2, & + thec, thlsec, qwsec, qwthlsec, wqwsec, wthlsec, thestd,dum, & + cqt1, cthl1, cqt2, cthl2, qn1, qn2, qi1, qi2, omn1, omn2, & + basetemp2, beta1, beta2, qs1, qs2, & + esval1_1, esval2_1, esval1_2, esval2_2, om1, om2, & + lstarn1, lstarn2, sqrtw2, sqrtthl, sqrtqt, & + sqrtstd1, sqrtstd2, tsign, tvar, sqrtw2t, wqls, wqis, & + sqrtqw2_1, sqrtqw2_2, sqrtthl2_1, sqrtthl2_2, sm, prespot, & + corrtest1, corrtest2, wrk, wrk1, wrk2, wrk3, onema, pfac, sfac, sfaci + + + integer i,j,k,km1,ku,kd,ka,kb + +! Map GFS variables to those of SHOC - SHOC operates on 3D fields +! Here a Y-dimension is added to the input variables, along with some unit conversions + + do k=1,nz + do j=1,ny + do i=1,nx + zi(i,j,k) = phii(i,j,k) * ggri + enddo + enddo + enddo +! +! move water from vapor to condensate if the condensate is negative +! + + do k=1,nzm + do j=1,ny + do i=1,nx + if (qc(i,j,k) < zero) then + wrk = qwv(i,j,k) + qc(i,j,k) + if (wrk >= zero) then + qwv(i,j,k) = wrk + tabs(i,j,k) = tabs(i,j,k) - fac_cond * qc(i,j,k) + qc(i,j,k) = zero + else + qc(i,j,k) = zero + tabs(i,j,k) = tabs(i,j,k) + fac_cond * qwv(i,j,k) + qwv(i,j,k) = zero + endif + endif + if (qi(i,j,k) < zero) then + wrk = qwv(i,j,k) + qi(i,j,k) + if (wrk >= zero) then + qwv(i,j,k) = wrk + tabs(i,j,k) = tabs(i,j,k) - fac_sub * qi(i,j,k) + qi(i,j,k) = zero + else + qi(i,j,k) = zero + tabs(i,j,k) = tabs(i,j,k) + fac_sub * qwv(i,j,k) + qwv(i,j,k) = zero + endif + endif + enddo + enddo + enddo + + + do k=1,nzm + do j=1,ny + do i=1,nx + zl(i,j,k) = phil(i,j,k) * ggri + wrk = one / prsl(i,j,k) + qv(i,j,k) = max(qwv(i,j,k), zero) + thv(i,j,k) = tabs(i,j,k) * (one+epsv*qv(i,j,k)) + w(i,j,k) = - rog * omega(i,j,k) * thv(i,j,k) * wrk + qcl(i,j,k) = max(qc(i,j,k), zero) + qci(i,j,k) = max(qi(i,j,k), zero) +! + qpl(i,j,k) = zero ! comment or remove when using with prognostic rain/snow + qpi(i,j,k) = zero ! comment or remove when using with prognostic rain/snow + wqp_sec(i,j,k) = zero ! Turbulent flux of precipiation +! + total_water(i,j,k) = qcl(i,j,k) + qci(i,j,k) + qv(i,j,k) + + prespot = (100000.0*wrk) ** kapa ! Exner function + bet(i,j,k) = ggr/(tabs(i,j,k)*prespot) ! Moorthi + thv(i,j,k) = thv(i,j,k)*prespot ! Moorthi +! +! Lapse rate * height = reference temperature + gamaz(i,j,k) = gocp * zl(i,j,k) + +! Liquid/ice water static energy - ! Note the the units are degrees K + hl(i,j,k) = tabs(i,j,k) + gamaz(i,j,k) - fac_cond*(qcl(i,j,k)+qpl(i,j,k)) & + - fac_fus *(qci(i,j,k)+qpi(i,j,k)) + w3(i,j,k) = zero + enddo + enddo + enddo + + +! Define vertical grid increments for later use in the vertical differentiation + + do k=2,nzm + km1 = k - 1 + do j=1,ny + do i=1,nx + adzi(i,j,k) = (zl(i,j,k) - zl(i,j,km1)) + adzl(i,j,km1) = (zi(i,j,k) - zi(i,j,km1)) + enddo + enddo + enddo + do j=1,ny + do i=1,nx + adzi(i,j,1) = (zl(i,j,1)-zi(i,j,1)) ! unused in the code + adzi(i,j,nz) = adzi(i,j,nzm) ! at the top - probably unused + adzl(i,j,nzm) = adzi(i,j,nzm) +! + wthl_sec(i,j,1) = hflx(i) + wqw_sec(i,j,1) = evap(i) + enddo + enddo + + + call tke_shoc() ! Integrate prognostic TKE equation forward in time + + +! diagnose second order moments of the subgrid PDF following +! Redelsperger J.L., and G. Sommeria, 1986, JAS, 43, 2619-2635 sans the use of stabilty +! weighting functions - Result is in global variables w_sec, thl_sec, qw_sec, and qwthl_sec + +! call diag_moments(total_water,tke,tkh) + +! Second moment of vertical velocity. +! Note that Eq 6 in BK13 gives a different expression that is dependent on +! vertical gradient of grid scale vertical velocity + + do k=1,nzm + ku = k+1 + kd = k-1 + ka = ku + kb = k + if (k == 1) then + kd = k + kb = ka + elseif (k == nzm) then + ku = k + ka = kb + endif + do j=1,ny + do i=1,nx + if (tke(i,j,k) > zero) then + wrk = half*(tkh(i,j,ka)+tkh(i,j,kb))*(w(i,j,ku) - w(i,j,kd)) & + * sqrt(tke(i,j,k)) / (zl(i,j,ku) - zl(i,j,kd)) +! / (sqrt(tke(i,j,k)) * (zl(i,j,ku) - zl(i,j,kd))) + w_sec(i,j,k) = max(twoby3 * tke(i,j,k) - twoby15 * wrk, zero) + else + w_sec(i,j,k) = zero + endif + enddo + enddo + enddo + + do k=2,nzm + + km1 = k-1 + do j=1,ny + do i=1,nx + +! Use backward difference in the vertical, use averaged values of "return-to-isotropy" +! time scale and diffusion coefficient + + wrk1 = one / adzi(i,j,k) ! adzi(k) = (zl(k)-zl(km1)) + wrk3 = max(tkh(i,j,k),pt01) * wrk1 + + sm = half*(isotropy(i,j,k)+isotropy(i,j,km1))*wrk1*wrk3 ! Tau*Kh/dz^2 + +! SGS vertical flux liquid/ice water static energy. Eq 1 in BK13 + + wrk1 = hl(i,j,k) - hl(i,j,km1) + wthl_sec(i,j,k) = - wrk3 * wrk1 + +! SGS vertical flux of total water. Eq 2 in BK13 + + wrk2 = total_water(i,j,k) - total_water(i,j,km1) + wqw_sec(i,j,k) = - wrk3 * wrk2 + +! Second moment of liquid/ice water static energy. Eq 4 in BK13 + + thl_sec(i,j,k) = thl2tune * sm * wrk1 * wrk1 + +! Second moment of total water mixing ratio. Eq 3 in BK13 + + qw_sec(i,j,k) = qw2tune * sm * wrk2 * wrk2 + +! Covariance of total water mixing ratio and liquid/ice water static energy. +! Eq 5 in BK13 + + qwthl_sec(i,j,k) = qwthl2tune * sm * wrk1 * wrk2 + + enddo ! i loop + enddo ! j loop + enddo ! k loop + +! These would be at the surface - do we need them? + do j=1,ny + do i=1,nx +! wthl_sec(i,j,1) = wthl_sec(i,j,2) +! wqw_sec(i,j,1) = wqw_sec(i,j,2) + thl_sec(i,j,1) = thl_sec(i,j,2) + qw_sec(i,j,1) = qw_sec(i,j,2) + qwthl_sec(i,j,1) = qwthl_sec(i,j,2) + enddo + enddo + +! Diagnose the third moment of SGS vertical velocity + + call canuto() + +! Recover parameters of the subgrid PDF using diagnosed moments +! and calculate SGS cloudiness, condensation and it's effects on temeperature +! and moisture variables + + call assumed_pdf() + +contains + + subroutine tke_shoc() + +! This subroutine solves the TKE equation, +! Heavily based on SAM's tke_full.f90 by Marat Khairoutdinov + + real grd,betdz,Cek,Cee,lstarn, lstarp, bbb, omn, omp,qsatt,dqsat, smix, & + buoy_sgs,ratio,a_prod_sh,a_prod_bu,a_diss,a_prod_bu_debug, buoy_sgs_debug, & + tscale1, wrk, wrk1, wtke, wtk2, rdtn + integer i,j,k,ku,kd,itr + + rdtn = one / dtn + + call tke_shear_prod(def2) ! Calculate shear production of TKE + +! Ensure values of TKE are reasonable + + do k=1,nzm + do j=1,ny + do i=1,nx + tke(i,j,k) = max(min_tke,tke(i,j,k)) + tkesbdiss(i,j,k) = zero +! tkesbshear(i,j,k) = zero +! tkesbbuoy(i,j,k) = zero + enddo + enddo + enddo + + call eddy_length() ! Find turbulent mixing length + call check_eddy() ! Make sure it's reasonable + + do k=1,nzm + ku = k+1 + kd = k + +! Cek = Ce * 3.5 +! Cek = Ce * 3.0 +! Cek = Ce * 2.0 +! Cek = Ce * 1.5 + Cek = Ce * cefac +! Cek = Ces + + if(k == 1) then + ku = 2 + kd = 2 + Cek = Ces + elseif(k == nzm) then + ku = k + kd = k + Cek = Ces + endif + + + do j=1,ny + do i=1,nx + grd = adzl(i,j,k) ! adzl(k) = zi(k+1)-zi(k) + +! wrk = zl(i,j,k) / grd + 1.5 +! cek = one + 2.0 / (wrk*wrk -3.3) + +! TKE boyancy production term. wthv_sec (buoyancy flux) is calculated in +! assumed_pdf(). The value used here is from the previous time step +! basetemp (300) is virt. temperature. Why is it constant? + +! a_prod_bu = (ggr/basetemp)*wthv_sec(i,j,k) +! a_prod_bu = bet(i,j,k)*wthv_sec(i,j,k) + a_prod_bu = ggr / thv(i,j,k) * wthv_sec(i,j,k) + +! If wthv_sec from subgrid PDF is not available use Brunt-Vaisalla frequency from eddy_length() +! wrk = (half*ck) * (tkh(i,j,ku)+tkh(i,j,kd)) + wrk = half * (tkh(i,j,ku)+tkh(i,j,kd)) + +!Obtain Brunt-Vaisalla frequency from diagnosed SGS buoyancy flux +!Presumably it is more precise than BV freq. calculated in eddy_length()? + + buoy_sgs = - a_prod_bu / (wrk + 0.0001) ! tkh is eddy thermal diffussivity +! buoy_sgs = - a_prod_bu / (prnum*wrk + 0.0001) ! tk is eddy viscosity + +!Compute $c_k$ (variable Cee) for the TKE dissipation term following Deardorff (1980) + + if (buoy_sgs <= zero) then + smix = grd + else +! smix = min(grd,max(0.1*grd, sqrt(0.76*wrk/sqrt(buoy_sgs+1.e-10)))) +! smix = min(grd,max(0.1*grd, sqrt(0.76*wrk/(Ck*sqrt(buoy_sgs+1.e-10))))) + smix = min(grd,max(0.1*grd, 0.76*sqrt(tke(i,j,k)/(buoy_sgs+1.e-10)))) + endif + + ratio = smix/grd + Cee = Cek* (pt19 + pt51*ratio) + wrk = half * wrk * (prnum(i,j,ku) + prnum(i,j,kd)) + a_prod_sh = min(tkhmax,(wrk+0.001))*def2(i,j,k) ! TKE shear production term + + +! smixt (turb. mixing lenght) is calculated in eddy_length() +! Explicitly integrate TKE equation forward in time +! a_diss = Cee/smixt(i,j,k)*tke(i,j,k)**1.5 ! TKE dissipation term +! tke(i,j,k) = max(zero,tke(i,j,k)+dtn*(max(zero,a_prod_sh+a_prod_bu)-a_diss)) + +! Semi-implicitly integrate TKE equation forward in time + + wtke = tke(i,j,k) + wtk2 = wtke + wrk = (dtn*Cee)/smixt(i,j,k) + wrk1 = wtke + dtn*(a_prod_sh+a_prod_bu) + + do itr=1,nitr ! iterate for implicit solution + wtke = min(max(min_tke, wtke), max_tke) + a_diss = wrk*sqrt(wtke) ! Coefficient in the TKE dissipation term + wtke = wrk1 / (1+a_diss) + wtke = tkef1*wtke + tkef2*wtk2 ! tkef1+tkef2 = 1.0 + wtk2 = wtke + + enddo + + tke(i,j,k) = min(max(min_tke, wtke), max_tke) + + tscale1 = (dtn+dtn) / a_diss ! See Eq 8 in BK13 + + a_diss = rdtn*a_diss*tke(i,j,k) ! TKE dissipation term, epsilon + + +! Calculate "return-to-isotropy" eddy dissipation time scale, see Eq. 8 in BK13 + + if (buoy_sgs <= zero) then + isotropy(i,j,k) = min(max_eddy_dissipation_time_scale,tscale1) + else + isotropy(i,j,k) = min(max_eddy_dissipation_time_scale, & + tscale1/(one+lambda*buoy_sgs*tscale1*tscale1)) + endif + + +! TKE budget terms + + tkesbdiss(i,j,k) = a_diss +! tkesbshear(i,j,k) = a_prod_sh +! tkesbbuoy(i,j,k) = a_prod_bu +! tkesbbuoy_debug(i,j,k) = a_prod_bu_debug +! tkebuoy_sgs(i,j,k) = buoy_sgs + + enddo ! i loop + enddo ! j loop + enddo ! k +! + wrk = half * ck + do k=2,nzm + do j=1,ny + do i=1,nx + + wrk1 = wrk / (prnum(i,j,k) + prnum(i,j,k-1)) + + tkh(i,j,k) = wrk1 * (isotropy(i,j,k) + isotropy(i,j,k-1)) & + * (tke(i,j,k) + tke(i,j,k-1)) ! Eddy thermal diffusivity + tkh(i,j,k) = min(tkh(i,j,k),tkhmax) + enddo ! i + enddo ! j + enddo ! k + + end subroutine tke_shoc + + + subroutine tke_shear_prod(def2) + +! Calculate TKE shear production term + + real, intent(out):: def2(nx,ny,nzm) + + real rdzw_up, rdzw_dn, wrku(2), wrkv(2), wrkw(2) + real txd(nx,ny) + integer i,j,k,kb,kc + +! do k=1,nzm +! do j=1,ny +! do i=1,nx +! def2(i,j,k) = zero +! enddo +! enddo +! enddo + +! Calculate TKE shear production term + + do k=1,nzm + + kb = k-1 + kc = k+1 + + if (k == 1) then + + do j=1,ny + do i=1,nx + rdzw_up = one/adzi(i,j,kc) + wrku(1) = (u(i,j,kc)-u(i,j,k))*rdzw_up + wrkv(1) = (v(i,j,kc)-v(i,j,k))*rdzw_up +! wrkw(1) = (w(i,j,kc)-w(i,j,k))*rdzw_up + def2(i,j,1) = wrku(1)*wrku(1) + wrkv(1)*wrkv(1) !+ 2*wrkw(1) * wrkw(1) + txd(i,j) = rdzw_up + enddo + enddo + + elseif (k < nzm ) then + do j=1,ny + do i=1,nx + rdzw_up = one/adzi(i,j,kc) + rdzw_dn = txd(i,j) + wrku(1) = (u(i,j,kc)-u(i,j,k))*rdzw_up + wrku(2) = (u(i,j,k)-u(i,j,kb))*rdzw_dn + wrkv(1) = (v(i,j,kc)-v(i,j,k))*rdzw_up + wrkv(2) = (v(i,j,k)-v(i,j,kb))*rdzw_dn +! wrkw(1) = (w(i,j,kc)-w(i,j,k))*rdzw_up +! wrkw(2) = (w(i,j,k)-w(i,j,kb))*rdzw_dn + + def2(i,j,k) = half * (wrku(1)*wrku(1) + wrku(2)*wrku(2) & + + wrkv(1)*wrkv(1) + wrkv(2)*wrkv(2)) ! & +! + wrkw(1)*wrkw(1) + wrkw(2)*wrkw(2) + txd(i,j) = rdzw_up + enddo + enddo + else + do j=1,ny + do i=1,nx + rdzw_dn = txd(i,j) + wrku(2) = (u(i,j,k)-u(i,j,kb))*rdzw_dn + wrkv(2) = (v(i,j,k)-v(i,j,kb))*rdzw_dn +! wrkw(2) = (w(i,j,k)-w(i,j,kb))*rdzw_dn + def2(i,j,k) = wrku(2)*wrku(2) + wrkv(2)*wrkv(2) !+ 2*wrkw(2) * wrkw(2) + enddo + enddo + endif + + enddo ! k loop + + + end subroutine tke_shear_prod + + subroutine eddy_length() + +! This subroutine computes the turbulent length scale based on a new +! formulation described in BK13 + +! Local variables + real wrk, wrk1, wrk2, wrk3 + integer i, j, k, kk, kl, ku, kb, kc, kli, kui + + do j=1,ny + do i=1,nx + cldarr(i,j) = zero + numer(i,j) = zero + denom(i,j) = zero + enddo + enddo + +! Find the length scale outside of clouds, that includes boundary layers. + + do k=1,nzm + do j=1,ny + do i=1,nx + +! Reinitialize the mixing length related arrays to zero + smixt(i,j,k) = one ! shoc_mod module variable smixt + brunt(i,j,k) = zero + +!Eq. 11 in BK13 (Eq. 4.13 in Pete's dissertation) +!Outside of cloud, integrate from the surface to the cloud base +!Should the 'if' below check if the cloud liquid < a small constant instead? + + if (qcl(i,j,k)+qci(i,j,k) <= zero) then + tkes = sqrt(tke(i,j,k)) * adzl(i,j,k) + numer(i,j) = numer(i,j) + tkes*zl(i,j,k) ! Numerator in Eq. 11 in BK13 + denom(i,j) = denom(i,j) + tkes ! Denominator in Eq. 11 in BK13 + else + cldarr(i,j) = one ! Take note of columns containing cloud. + endif + enddo + enddo + enddo + +! Calculate the measure of PBL depth, Eq. 11 in BK13 (Is this really PBL depth?) + do j=1,ny + do i=1,nx + if (denom(i,j) > zero .and. numer(i,j) > zero) then + l_inf(i,j) = 0.1 * (numer(i,j)/denom(i,j)) + else + l_inf(i,j) = 100. + endif + enddo + enddo + +!Calculate length scale outside of cloud, Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) + do k=1,nzm + + kb = k-1 + kc = k+1 + + do j=1,ny + do i=1,nx + +! vars module variable bet (=ggr/tv0) ; grid module variable adzi + + if (k == 1) then + kb = 1 + kc = 2 + thedz = adzi(i,j,kc) + elseif (k == nzm) then + kb = nzm-1 + kc = nzm + thedz = adzi(i,j,k) + else + thedz = (adzi(i,j,kc)+adzi(i,j,k)) ! = (z(k+1)-z(k-1)) + endif + betdz = bet(i,j,k) / thedz + + + tkes = sqrt(tke(i,j,k)) + +! Compute local Brunt-Vaisalla frequency + + wrk = qcl(i,j,k) + qci(i,j,k) + if (wrk > zero) then ! If in the cloud + +! Find the in-cloud Brunt-Vaisalla frequency + + omn = qcl(i,j,k) / (wrk+1.e-20) ! Ratio of liquid water to total water + +! Latent heat of phase transformation based on relative water phase content +! fac_cond = lcond/cp, fac_fus = lfus/cp + + lstarn = fac_cond + (one-omn)*fac_fus + +! Derivative of saturation mixing ratio over water/ice wrt temp. based on relative water phase content + dqsat = omn * dtqsatw(tabs(i,j,k),prsl(i,j,k)) & + + (one-omn) * dtqsati(tabs(i,j,k),prsl(i,j,k)) + +! Saturation mixing ratio over water/ice wrt temp based on relative water phase content + + qsatt = omn * qsatw(tabs(i,j,k),prsl(i,j,k)) & + + (one-omn) * qsati(tabs(i,j,k),prsl(i,j,k)) + +! liquid/ice moist static energy static energy divided by cp? + + bbb = (one + epsv*qsatt-wrk-qpl(i,j,k)-qpi(i,j,k) & + + 1.61*tabs(i,j,k)*dqsat) / (one+lstarn*dqsat) + +! Calculate Brunt-Vaisalla frequency using centered differences in the vertical + + brunt(i,j,k) = betdz*(bbb*(hl(i,j,kc)-hl(i,j,kb)) & + + (bbb*lstarn - (one+lstarn*dqsat)*tabs(i,j,k)) & + * (total_water(i,j,kc)-total_water(i,j,kb)) & + + (bbb*fac_cond - (one+fac_cond*dqsat)*tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + + (bbb*fac_sub - (one+fac_sub*dqsat)*tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) + + else ! outside of cloud + +! Find outside-of-cloud Brunt-Vaisalla frequency +! Only unsaturated air, rain and snow contribute to virt. pot. temp. +! liquid/ice moist static energy divided by cp? + + bbb = one + epsv*qv(i,j,k) - qpl(i,j,k) - qpi(i,j,k) + brunt(i,j,k) = betdz*( bbb*(hl(i,j,kc)-hl(i,j,kb)) & + + epsv*tabs(i,j,k)*(total_water(i,j,kc)-total_water(i,j,kb)) & + + (bbb*fac_cond-tabs(i,j,k))*(qpl(i,j,kc)-qpl(i,j,kb)) & + + (bbb*fac_sub -tabs(i,j,k))*(qpi(i,j,kc)-qpi(i,j,kb)) ) + endif + +! Reduction of mixing length in the stable regions (where B.-V. freq. > 0) is required. +! Here we find regions of Brunt-Vaisalla freq. > 0 for later use. + + if (brunt(i,j,k) >= zero) then + brunt2(i,j,k) = brunt(i,j,k) + else + brunt2(i,j,k) = zero + endif + +! Calculate turbulent length scale in the boundary layer. +! See Eq. 10 in BK13 (Eq. 4.12 in Pete's dissertation) + +! Keep the length scale adequately small near the surface following Blackadar (1984) +! Note that this is not documented in BK13 and was added later for SP-CAM runs + +! if (k == 1) then +! term = 600.*tkes +! smixt(i,j,k) = term + (0.4*zl(i,j,k)-term)*exp(-zl(i,j,k)*0.01) +! else + +! tscale is the eddy turnover time scale in the boundary layer and is +! an empirically derived constant + + if (tkes > zero .and. l_inf(i,j) > zero) then + wrk1 = one / (tscale*tkes*vonk*zl(i,j,k)) + wrk2 = one / (tscale*tkes*l_inf(i,j)) + wrk1 = wrk1 + wrk2 + pt01 * brunt2(i,j,k) / tke(i,j,k) + wrk1 = sqrt(one / max(wrk1,1.0e-8)) * (one/0.3) +! smixt(i,j,k) = min(max_eddy_length_scale, 2.8284*sqrt(wrk1)/0.3) + smixt(i,j,k) = min(max_eddy_length_scale, wrk1) + +! smixt(i,j,k) = min(max_eddy_length_scale,(2.8284*sqrt(1./((1./(tscale*tkes*vonk*zl(i,j,k))) & +! + (1./(tscale*tkes*l_inf(i,j)))+0.01*(brunt2(i,j,k)/tke(i,j,k)))))/0.3) +! else +! smixt(i,j,k) = zero + endif + +! endif + + enddo + + enddo + enddo + + +! Now find the in-cloud turbulence length scale +! See Eq. 13 in BK13 (Eq. 4.18 in Pete's disseration) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Remove after coupling to subgrid PDF. +!wthv_sec = -300/ggr*brunt*tk +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! determine cubed convective velocity scale (conv_vel2) inside the cloud + +! call conv_scale() ! inlining the relevant code + + do j=1,ny + do i=1,nx + conv_vel2(i,j,1) = zero ! Convective velocity scale cubed + enddo + enddo + ! Integrate velocity scale in the vertical + do k=2,nzm + do j=1,ny + do i=1,nx + conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & + + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) + enddo + enddo + enddo + + do j=1,ny + do i=1,nx + + if (cldarr(i,j) == 1) then ! If there's a cloud in this column + + kl = 0 + ku = 0 + do k=2,nzm-3 + +! Look for the cloud base in this column +! thresh (=0) is a variable local to eddy_length(). Should be a module constant. + wrk = qcl(i,j,k) + qci(i,j,k) + if (wrk > thresh .and. kl == 0) then + kl = k + endif + +! Look for the cloud top in this column + if (wrk > thresh .and. qcl(i,j,k+1)+qci(i,j,k+1) <= thresh) then + ku = k +! conv_vel2 (Cubed convective velocity scale) is calculated in conv_scale() +! Use the value of conv_vel2 at the top of the cloud. + conv_var = conv_vel2(i,j,k)**(one/3.) + endif + +! Compute the mixing length scale for the cloud layer that we just found + if (kl > 0 .and. ku > 0 .and. ku-kl > 1) then + + if (conv_var > 0) then ! If convective vertical velocity scale > 0 + + depth = (zl(i,j,ku)-zl(i,j,kl)) + adzl(i,j,kl) + + + do kk=kl,ku +! in-cloud turbulence length scale, Eq. 13 in BK13 (Eq. 4.18) + + wrk = conv_var/(depth*sqrt(tke(i,j,kk))) + wrk = wrk * wrk + pt01*brunt2(i,j,kk)/tke(i,j,kk) + + smixt(i,j,kk) = min(max_eddy_length_scale, (one/0.3)*sqrt(one/wrk)) + + enddo + + endif ! If convective vertical velocity scale > 0 + kl = zero + ku = zero + endif ! if inside the cloud layer + + enddo ! k=2,nzm-3 + endif ! if in the cloudy column + enddo ! i=1,nx + enddo ! j=1,ny + + + end subroutine eddy_length + + + subroutine conv_scale() + +! This subroutine calculates the cubed convective velocity scale needed +! for the definition of the length scale in clouds +! See Eq. 16 in BK13 (Eq. 4.21 in Pete's dissertation) + + integer i, j, k + +!!!!!!!!! +!! A bug in formulation of conv_vel +! Obtain it by averaging conv_vel2 in the horizontal +!!!!!!!!!! + +! conv_vel(1)=zero ! Horizontally averaged convective velocity scale cubed + do j=1,ny + do i=1,nx + conv_vel2(i,j,1) = zero ! Convective velocity scale cubed + enddo + enddo +! Integrate velocity scale in the vertical + do k=2,nzm +! conv_vel(k)=conv_vel(k-1) + do j=1,ny + do i=1,nx +!********************************************************************** +!Do not include grid-scale contribution to convective velocity scale in GCM applications +! conv_vel(k)=conv_vel(k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+tvws(k)) +! conv_vel(k)=conv_vel(k)+2.5*adzi(i,j,k)*bet(i,j,k)*(tvws(k)) +!Do not include grid-scale contribution to convective velocity scale in GCM applications +! conv_vel2(i,j,k)=conv_vel2(i,j,k-1)+2.5*adzi(k)*bet(k)*(tvwle(k)+wthv_sec(i,j,k)) +!********************************************************************** + + conv_vel2(i,j,k) = conv_vel2(i,j,k-1) & + + 2.5*adzi(i,j,k)*bet(i,j,k)*wthv_sec(i,j,k) + enddo + enddo + enddo + + end subroutine conv_scale + + + subroutine check_eddy() + +! This subroutine checks eddy length values + + integer i, j, k, kb, ks, zend + real wrk +! real zstart, zthresh, qthresh + +! Temporary kludge for marine stratocumulus under very strong inversions at coarse resolution +! Placement until some explicity PBL top is put in +! Not used. +! zthresh = 100. +! qthresh = -6.0 + + do k=1,nzm + + if (k == nzm) then + kb = k + else + kb = k+1 + endif + + do j=1,ny + do i=1,nx + + wrk = 0.1*adzl(i,j,k) + ! Minimum 0.1 of local dz + smixt(i,j,k) = max(wrk, min(max_eddy_length_scale,smixt(i,j,k))) + +! If chracteristic grid dimension in the horizontal< 1000m, set lengthscale to +! be not larger that that. +! if (sqrt(dx*dy) .le. 1000.) smixt(i,j,k)=min(sqrt(dx*dy),smixt(i,j,k)) + + if (qcl(i,j,kb) == 0 .and. qcl(i,j,k) > 0 .and. brunt(i,j,k) > 1.e-4) then +!If just above the cloud top and atmosphere is stable, set to 0.1 of local dz + smixt(i,j,k) = wrk + endif + + enddo ! i + enddo ! j + enddo ! k + + end subroutine check_eddy + + subroutine canuto() + +! Subroutine impements an analytic expression for the third moment of SGS vertical velocity +! based on Canuto et at, 2001, JAS, 58, 1169-1172 (further referred to as C01) +! This allows to avoid having a prognostic equation for the third moment. +! Result is returned in a global variable w3 defined at the interface levels. + +! Local variables + integer i, j, k, kb, kc + + real bet2, f0, f1, f2, f3, f4, f5, iso, isosqr, & + omega0, omega1, omega2, X0, Y0, X1, Y1, AA0, AA1, buoy_sgs2, & + thedz, thedz2, cond, wrk, wrk1, wrk2, wrk3, avew +! +! See Eq. 7 in C01 (B.7 in Pete's dissertation) + real, parameter :: c=7.0, a0=0.52/(c*c*(c-2.)), a1=0.87/(c*c), & + a2=0.5/c, a3=0.6/(c*(c-2.)), a4=2.4/(3.*c+5.), & + a5=0.6/(c*(3.*c+5)) +!Moorthi a5=0.6/(c*(3.+5.*c)) + +! do k=1,nzm + do k=2,nzm + + kb = k-1 + kc = k+1 + + do j=1,ny + do i=1,nx + + if(k == 1) then + kb = 1 + kc = 2 + thedz = adzl(i,j,kc) + thedz2 = thedz + elseif(k == nzm) then + kb = nzm-1 + kc = nzm + thedz = adzl(i,j,k) + thedz2 = thedz + else +! thedz = adzl(i,j,k) +! thedz2 = adzl(i,j,kc)+adzl(i,j,k) + thedz = adzl(i,j,k) ! Moorthi jul08 + thedz2 = adzl(i,j,k)+adzl(i,j,kb) ! Moorthi jul08 + endif + + thedz = one / thedz + thedz2 = one / thedz2 + + iso = half*(isotropy(i,j,k)+isotropy(i,j,kb)) + isosqr = iso*iso ! Two-level average of "return-to-isotropy" time scale squared + buoy_sgs2 = isosqr*half*(brunt(i,j,k)+brunt(i,j,kb)) + bet2 = half*(bet(i,j,k)+bet(i,j,kb)) !Two-level average of BV frequency squared + + +! Compute functions f0-f5, see Eq, 8 in C01 (B.8 in Pete's dissertation) + + + avew = half*(w_sec(i,j,k)+w_sec(i,j,kb)) + cond = 1.2*sqrt(max(1.0e-20,2.*avew*avew*avew)) + wrk1 = bet2*iso + wrk2 = thedz2*wrk1*wrk1*iso + wrk3 = thl_sec(i,j,kc) - thl_sec(i,j,kb) + + f0 = wrk2 * wrk1 * wthl_sec(i,j,k) * wrk3 + + wrk = wthl_sec(i,j,kc) - wthl_sec(i,j,kb) + + f1 = wrk2 * (wrk*wthl_sec(i,j,k) + half*avew*wrk3) + + wrk1 = bet2*isosqr + f2 = thedz*wrk1*wthl_sec(i,j,k)*(w_sec(i,j,k)-w_sec(i,j,kb)) & + + (thedz2+thedz2)*bet(i,j,k)*isosqr*wrk + + f3 = thedz2*wrk1*wrk + thedz*bet2*isosqr*(wthl_sec(i,j,k)*(tke(i,j,k)-tke(i,j,kb))) + + wrk1 = thedz*iso*avew + f4 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb) + tke(i,j,k)-tke(i,j,kb)) + + f5 = wrk1*(w_sec(i,j,k)-w_sec(i,j,kb)) + + +! Compute the "omega" terms, see Eq. 6 in C01 (B.6 in Pete's dissertation) + + omega0 = a4 / (one-a5*buoy_sgs2) + omega1 = omega0 / (c+c) + omega2 = omega1*f3+(5./4.)*omega0*f4 + +! Compute the X0, Y0, X1, Y1 terms, see Eq. 5 a-b in C01 (B.5 in Pete's dissertation) + + wrk1 = one / (one-(a1+a3)*buoy_sgs2) + wrk2 = one / (one-a3*buoy_sgs2) + X0 = wrk1 * (a2*buoy_sgs2*(one-a3*buoy_sgs2)) + Y0 = wrk2 * (two*a2*buoy_sgs2*X0) + X1 = wrk1 * (a0*f0+a1*f1+a2*(one-a3*buoy_sgs2)*f2) + Y1 = wrk2 * (two*a2*(buoy_sgs2*X1+(a0/a1)*f0+f1)) + +! Compute the A0, A1 terms, see Eq. 5d in C01 (B.5 in Pete's dissertation) + + AA0 = omega0*X0 + omega1*Y0 + AA1 = omega0*X1 + omega1*Y1 + omega2 + +! Finally, we have the third moment of w, see Eq. 4c in C01 (B.4 in Pete's dissertation) +! cond is an estimate of third moment from second oment - If the third moment is larger +! than the estimate - limit w3. + + w3(i,j,k) = max(-cond, min(cond, (AA1-1.2*X1-1.5*f5)/(c-1.2*X0+AA0))) + +! Implemetation of the C01 approach in this subroutine is nearly complete +! (the missing part are Eqs. 5c and 5e which are very simple) +! therefore it's easy to diagnose other third order moments obtained in C01 using this code. + + enddo + enddo + enddo + do j=1,ny + do i=1,nx + w3(i,j,1) = w3(i,j,2) + enddo + enddo + + end subroutine canuto + + subroutine assumed_pdf() + +! Compute SGS buoyancy flux, SGS cloud fraction, and SGS condensation +! using assumed analytic double-gaussian PDF for SGS vertical velocity, +! moisture, and liquid/ice water static energy, based on the +! general approach of Larson et al 2002, JAS, 59, 3519-3539, +! and Golaz et al 2002, JAS, 59, 3540-3551 +! References in the comments in this code are given to +! the Appendix A of Pete Bogenschutz's dissertation. + +! Local variables + + integer i,j,k,ku,kd + real wrk, wrk1, wrk2, wrk3, wrk4, bastoeps, eps_ss1, eps_ss2 + +! bastoeps = basetemp / epsterm + + +! Initialize for statistics + do k=1,nzm + wqlsb(k) = zero + wqisb(k) = zero + enddo + + DO k=1,nzm + + kd = k + ku = k + 1 + if (k == nzm) ku = k + + DO j=1,ny + DO i=1,nx + +! Initialize cloud variables to zero + diag_qn = zero + diag_frac = zero + diag_ql = zero + diag_qi = zero + + pval = prsl(i,j,k) + pfac = pval * 1.0e-5 + pkap = pfac ** kapa + sfac = scrit * pfac + sfaci = one / sfac + +! Read in liquid/ice static energy, total water mixing ratio, +! and vertical velocity to variables PDF needs + thl_first = hl(i,j,k) + qw_first = total_water(i,j,k) +! w_first = half*(w(i,j,kd)+w(i,j,ku)) + w_first = w(i,j,k) + + +! GET ALL INPUT VARIABLES ON THE SAME GRID +! Points to be computed with relation to thermo point +! Read in points that need to be averaged + + w3var = half*(w3(i,j,kd)+w3(i,j,ku)) + thlsec = max(zero, half*(thl_sec(i,j,kd)+thl_sec(i,j,ku)) ) + qwsec = max(zero, half*(qw_sec(i,j,kd)+qw_sec(i,j,ku)) ) + qwthlsec = half * (qwthl_sec(i,j,kd) + qwthl_sec(i,j,ku)) + wqwsec = half * (wqw_sec(i,j,kd) + wqw_sec(i,j,ku)) + wthlsec = half * (wthl_sec(i,j,kd) + wthl_sec(i,j,ku)) + +! w3var = w3(i,j,k) +! thlsec = max(zero,thl_sec(i,j,k)) +! qwsec = max(zero,qw_sec(i,j,k)) +! qwthlsec = qwthl_sec(i,j,k) +! wqwsec = wqw_sec(i,j,k) +! wthlsec = wthl_sec(i,j,k) + +! Compute square roots of some variables so we don't have to do it again + if (w_sec(i,j,k) > zero) then + sqrtw2 = sqrt(w_sec(i,j,k)) + else + sqrtw2 = zero + endif + if (thlsec > zero) then + sqrtthl = sqrt(thlsec) + else + sqrtthl = zero + endif + if (qwsec > zero) then + sqrtqt = sqrt(qwsec) + else + sqrtqt = zero + endif + + +! Find parameters of the double Gaussian PDF of vertical velocity + +! Skewness of vertical velocity +! Skew_w = w3var / w_sec(i,j,k)**(3./2.) +! Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi + + IF (w_sec(i,j,k) <= w_tol_sqd) THEN ! If variance of w is too small then + ! PDF is a sum of two delta functions + Skew_w = zero + w1_1 = w_first + w1_2 = w_first + w2_1 = zero + w2_2 = zero + aterm = half + onema = half + ELSE + + Skew_w = w3var / (sqrtw2*sqrtw2*sqrtw2) ! Moorthi +! Proportionality coefficients between widths of each vertical velocity +! gaussian and the sqrt of the second moment of w + w2_1 = 0.4 + w2_2 = 0.4 + +! Compute realtive weight of the first PDF "plume" +! See Eq A4 in Pete's dissertaion - Ensure 0.01 < a < 0.99 + + wrk = one - w2_1 + aterm = max(pt01,min(half*(one-Skew_w*sqrt(one/(4.*wrk*wrk*wrk+Skew_w*Skew_w))),0.99)) + onema = one - aterm + + sqrtw2t = sqrt(wrk) + +! Eq. A.5-A.6 + wrk = sqrt(onema/aterm) + w1_1 = sqrtw2t * wrk + w1_2 = - sqrtw2t / wrk + + w2_1 = w2_1 * w_sec(i,j,k) + w2_2 = w2_2 * w_sec(i,j,k) + + ENDIF + +! Find parameters of the PDF of liquid/ice static energy + + IF (thlsec <= thl_tol*thl_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN + thl1_1 = thl_first + thl1_2 = thl_first + thl2_1 = zero + thl2_2 = zero + sqrtthl2_1 = zero + sqrtthl2_2 = zero + ELSE + + corrtest1 = max(-one,min(one,wthlsec/(sqrtw2*sqrtthl))) + + thl1_1 = -corrtest1 / w1_2 ! A.7 + thl1_2 = -corrtest1 / w1_1 ! A.8 + + wrk1 = thl1_1 * thl1_1 + wrk2 = thl1_2 * thl1_2 + wrk3 = one - aterm*wrk1 - onema*wrk2 + wrk4 = -skew_fact*Skew_w - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 ! testing - Moorthi +! wrk4 = - aterm*wrk1*thl1_1 - onema*wrk2*thl1_2 + wrk = 3. * (thl1_2-thl1_1) + if (wrk /= zero) then + thl2_1 = thlsec * min(100.,max(zero,( 3.*thl1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + thl2_2 = thlsec * min(100.,max(zero,(-3.*thl1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + else + thl2_1 = zero + thl2_2 = zero + endif +! + thl1_1 = thl1_1*sqrtthl + thl_first + thl1_2 = thl1_2*sqrtthl + thl_first + + sqrtthl2_1 = sqrt(thl2_1) + sqrtthl2_2 = sqrt(thl2_2) + + ENDIF + +! FIND PARAMETERS FOR TOTAL WATER MIXING RATIO + + IF (qwsec <= rt_tol*rt_tol .or. abs(w1_2-w1_1) <= w_thresh) THEN + qw1_1 = qw_first + qw1_2 = qw_first + qw2_1 = zero + qw2_2 = zero + sqrtqw2_1 = zero + sqrtqw2_2 = zero + ELSE + + corrtest2 = max(-one,min(one,wqwsec/(sqrtw2*sqrtqt))) + + qw1_1 = - corrtest2 / w1_2 ! A.7 + qw1_2 = - corrtest2 / w1_1 ! A.8 + + tsign = abs(qw1_2-qw1_1) + + Skew_qw = skew_facw*Skew_w + +! IF (tsign > 0.4) THEN +! Skew_qw = skew_facw*Skew_w +! ELSE IF (tsign <= 0.2) THEN +! Skew_qw = zero +! ELSE +! Skew_qw = (skew_facw/0.2) * Skew_w * (tsign-0.2) +! ENDIF + + wrk1 = qw1_1 * qw1_1 + wrk2 = qw1_2 * qw1_2 + wrk3 = one - aterm*wrk1 - onema*wrk2 + wrk4 = Skew_qw - aterm*wrk1*qw1_1 - onema*wrk2*qw1_2 + wrk = 3. * (qw1_2-qw1_1) + + if (wrk /= zero) then + qw2_1 = qwsec * min(100.,max(zero,( 3.*qw1_2*wrk3-wrk4)/(aterm*wrk))) ! A.10 + qw2_2 = qwsec * min(100.,max(zero,(-3.*qw1_1*wrk3+wrk4)/(onema*wrk))) ! A.11 + else + qw2_1 = zero + qw2_2 = zero + endif +! + qw1_1 = qw1_1*sqrtqt + qw_first + qw1_2 = qw1_2*sqrtqt + qw_first + + sqrtqw2_1 = sqrt(qw2_1) + sqrtqw2_2 = sqrt(qw2_2) + + ENDIF + +! CONVERT FROM TILDA VARIABLES TO "REAL" VARIABLES + + w1_1 = w1_1*sqrtw2 + w_first + w1_2 = w1_2*sqrtw2 + w_first + +! FIND WITHIN-PLUME CORRELATIONS + + testvar = aterm*sqrtqw2_1*sqrtthl2_1 + onema*sqrtqw2_2*sqrtthl2_2 + + IF (testvar == 0) THEN + r_qwthl_1 = zero + ELSE + r_qwthl_1 = max(-one,min(one,(qwthlsec-aterm*(qw1_1-qw_first)*(thl1_1-thl_first)-onema*(qw1_2-qw_first)*(thl1_2-thl_first))/testvar)) ! A.12 + ENDIF + +! BEGIN TO COMPUTE CLOUD PROPERTY STATISTICS + + Tl1_1 = thl1_1 - gamaz(i,j,k) + fac_cond*qpl(i,j,k) + fac_sub*qpi(i,j,k) + Tl1_2 = thl1_2 - gamaz(i,j,k) + fac_cond*qpl(i,j,k) + fac_sub*qpi(i,j,k) + +! Now compute qs + + esval1_1 = zero + esval1_2 = zero + esval2_1 = zero + esval2_2 = zero + om1 = one + om2 = one + eps_ss1 = eps + eps_ss2 = eps + +! Partition based on temperature for the first plume + + IF (Tl1_1 >= tbgmax) THEN +! esval1_1 = fpvs(Tl1_1) + esval1_1 = fpvsl(Tl1_1) +! esval1_1 = esatw(Tl1_1) + lstarn1 = lcond + ELSE IF (Tl1_1 < tbgmin) THEN +! esval1_1 = fpvs(Tl1_1) + esval1_1 = fpvsi(Tl1_1) +! esval1_1 = esati(Tl1_1) + lstarn1 = lsub + eps_ss1 = eps * supice + ELSE +! esval1_1 = fpvs(Tl1_1) +! esval2_1 = fpvs(Tl1_1) + esval1_1 = fpvsl(Tl1_1) + esval2_1 = fpvsi(Tl1_1) +! esval2_1 = fpvsi(Tl1_1) +! esval1_1 = esatw(Tl1_1) +! esval2_1 = esati(Tl1_1) + om1 = max(zero, min(one, a_bg*(Tl1_1-tbgmin))) + lstarn1 = lcond + (one-om1)*lfus + eps_ss2 = eps * supice + ENDIF + + qs1 = om1 * (eps_ss1*esval1_1/max(esval1_1,pval-0.378*esval1_1)) & + + (one-om1) * (eps_ss2*esval2_1/max(esval2_1,pval-0.378*esval2_1)) +! qs1 = om1 * (eps*esval1_1/max(esval1_1,pval-esval1_1)) & +! + (one-om1) * (eps*esval2_1/max(esval2_1,pval-esval2_1)) + +! beta1 = (rgas/rv)*(lstarn1/(rgas*Tl1_1))*(lstarn1/(cp*Tl1_1)) + beta1 = (lstarn1*lstarn1*onebrvcp) / (Tl1_1*Tl1_1) ! A.18 + + +! Are the two plumes equal? If so then set qs and beta +! in each column to each other to save computation + IF (Tl1_1 == Tl1_2) THEN + qs2 = qs1 + beta2 = beta1 + ELSE + + eps_ss1 = eps + eps_ss2 = eps + + IF (Tl1_2 < tbgmin) THEN +! esval1_2 = fpvs(Tl1_2) + esval1_2 = fpvsi(Tl1_2) +! esval1_2 = esati(Tl1_2) + lstarn2 = lsub + eps_ss1 = eps * supice + ELSE IF (Tl1_2 >= tbgmax) THEN +! esval1_2 = fpvs(Tl1_2) + esval1_2 = fpvsl(Tl1_2) +! esval1_2 = esatw(Tl1_2) + lstarn2 = lcond + ELSE +! esval1_2 = fpvs(Tl1_2) +! esval2_2 = fpvs(Tl1_2) + esval1_2 = fpvsl(Tl1_2) + esval2_2 = fpvsi(Tl1_2) +! esval2_2 = fpvsi(Tl1_2) +! esval1_2 = esatw(Tl1_2) +! esval2_2 = esati(Tl1_2) + om2 = max(zero, min(one, a_bg*(Tl1_2-tbgmin))) + lstarn2 = lcond + (one-om2)*lfus + eps_ss2 = eps * supice + ENDIF + + qs2 = om2 * (eps_ss1*esval1_2/max(esval1_2,pval-0.378*esval1_2)) & + + (one-om2) * (eps_ss2*esval2_2/max(esval2_2,pval-0.378*esval2_2)) +! qs2 = om2 * (eps*esval1_2/max(esval1_2,pval-esval1_2)) & +! + (one-om2) * (eps*esval2_2/max(esval2_2,pval-esval2_2)) + +! beta2 = (rgas/rv)*(lstarn2/(rgas*Tl1_2))*(lstarn2/(cp*Tl1_2)) ! A.18 + beta2 = (lstarn2*lstarn2*onebrvcp) / (Tl1_2*Tl1_2) ! A.18 + + ENDIF + + qs1 = qs1 * rhc(i,j,k) + qs2 = qs2 * rhc(i,j,k) + +! Now compute cloud stuff - compute s term + + cqt1 = one / (one+beta1*qs1) ! A.19 + wrk = qs1 * (one+beta1*qw1_1) * cqt1 + s1 = qw1_1 - wrk ! A.17 + cthl1 = cqt1*wrk*cpolv*beta1*pkap ! A.20 + + wrk1 = cthl1 * cthl1 + wrk2 = cqt1 * cqt1 +! std_s1 = sqrt(max(zero,wrk1*thl2_1+wrk2*qw2_1-2.*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) + std_s1 = sqrt(max(zero, wrk1*thl2_1+wrk2*qw2_1 & + - two*cthl1*sqrtthl2_1*cqt1*sqrtqw2_1*r_qwthl_1)) + + qn1 = zero + C1 = zero + + IF (std_s1 > zero) THEN + wrk = s1 / (std_s1*sqrt2) + C1 = max(zero, min(one, half*(one+erf(wrk)))) ! A.15 +! if (lprnt .and. i == ipr) write(0,*)' in shoc wrk=',wrk,' s1=','std=',std_s1,& +! ' c1=',c1*100,' qs1=',qs1,' qw1_1=',qw1_1 + + IF (C1 > zero) qn1 = s1*C1 + (std_s1*sqrtpii)*exp(-wrk*wrk) ! A.16 + if (qn1 < sfac) then + c1 = qn1 * sfaci + endif + ELSEIF (s1 > zero) THEN + C1 = min(one, max(zero,s1*sfaci)) + qn1 = s1 + ENDIF + +! now compute non-precipitating cloud condensate + +! If two plumes exactly equal, then just set many of these +! variables to themselves to save on computation. + IF (qw1_1 == qw1_2 .and. thl2_1 == thl2_2 .and. qs1 == qs2) THEN + s2 = s1 + cthl2 = cthl1 + cqt2 = cqt1 + std_s2 = std_s1 + C2 = C1 + qn2 = qn1 + ELSE + + cqt2 = one / (one+beta2*qs2) + wrk = qs2 * (one+beta2*qw1_2) * cqt2 + s2 = qw1_2 - wrk + cthl2 = wrk*cqt2*cpolv*beta2*pkap + wrk1 = cthl2 * cthl2 + wrk2 = cqt2 * cqt2 +! std_s2 = sqrt(max(zero,wrk1*thl2_2+wrk2*qw2_2-2.*cthl2*sqrtthl2_2*cqt2*sqrtqw2_2*r_qwthl_1)) + std_s2 = sqrt(max(zero, wrk1*thl2_2+wrk2*qw2_2 & + - two*cthl2*sqrtthl2_2*cqt2*sqrtqw2_2*r_qwthl_1)) + + qn2 = zero + C2 = zero + + IF (std_s2 > zero) THEN + wrk = s2 / (std_s2*sqrt2) + C2 = max(zero, min(one, half*(one+erf(wrk)))) + IF (C2 > zero) qn2 = s2*C2 + (std_s2*sqrtpii)*exp(-wrk*wrk) + if (qn2 < sfac) then + c2 = qn2 * sfaci + endif + ELSEIF (s2 > zero) THEN + C2 = min(one, max(zero,s2*sfaci)) + qn2 = s2 + ENDIF + + ENDIF + +! finally, compute the SGS cloud fraction + diag_frac = aterm*C1 + onema*C2 + + om1 = max(zero, min(one, (Tl1_1-tbgmin)*a_bg)) + om2 = max(zero, min(one, (Tl1_2-tbgmin)*a_bg)) + + qn1 = min(qn1,qw1_1) + qn2 = min(qn2,qw1_2) + + ql1 = qn1*om1 + ql2 = qn2*om2 + + qi1 = qn1 - ql1 + qi2 = qn2 - ql2 + +! if (lprnt .and. i == ipr) write(0,*)' in shoc qi=',qi1,qi2,' ql=',ql1,ql2,& +! ' c1=',c1,' c2=',c2,' s1=',s1,' s2=',s2,' k=',k + + diag_qn = min(max(zero, aterm*qn1 + onema*qn2), total_water(i,j,k)) + diag_ql = min(max(zero, aterm*ql1 + onema*ql2), diag_qn) + diag_qi = diag_qn - diag_ql + + +! Update temperature variable based on diagnosed cloud properties + om1 = max(zero, min(one, (tabs(i,j,k)-tbgmin)*a_bg)) + lstarn1 = lcond + (one-om1)*lfus + tabs(i,j,k) = hl(i,j,k) - gamaz(i,j,k) + fac_cond*(diag_ql+qpl(i,j,k)) & + + fac_sub *(diag_qi+qpi(i,j,k)) & + + tkesbdiss(i,j,k) * (dtn/cp) ! tke dissipative heating + +! Update moisture fields + +! Update ncpl and ncpi Anning Cheng 03/11/2016 + ncpl(i,j,k) = diag_ql/max(qc(i,j,k),1.e-10)*ncpl(i,j,k) + ncpi(i,j,k) = (1-diag_qi/max(qi(i,j,k),1.e-10))*ncpi(i,j,k) + qc(i,j,k) = diag_ql + qi(i,j,k) = diag_qi + qwv(i,j,k) = total_water(i,j,k) - diag_qn + cld_sgs(i,j,k) = diag_frac + + +! Compute the liquid water flux + wqls = aterm * ((w1_1-w_first)*ql1) + onema * ((w1_2-w_first)*ql2) + wqis = aterm * ((w1_1-w_first)*qi1) + onema * ((w1_2-w_first)*qi2) + +! Compute statistics for the fluxes so we don't have to save these variables + wqlsb(k) = wqlsb(k) + wqls + wqisb(k) = wqisb(k) + wqis + +! diagnostic buoyancy flux. Includes effects from liquid water, ice +! condensate, liquid & ice precipitation +! wrk = epsv * basetemp + wrk = epsv * thv(i,j,k) + + bastoeps = onebeps * thv(i,j,k) + + wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & + + (fac_cond-bastoeps)*wqls & + + (fac_sub-bastoeps) *wqis & + + ((lstarn1/cp)-thv(i,j,k))*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) + +! wthv_sec(i,j,k) = wthlsec + wrk*wqwsec & +! + (fac_cond-bastoeps)*wqls & +! + (fac_sub-bastoeps)*wqis & +! + ((lstarn1/cp)-basetemp)*half*(wqp_sec(i,j,kd)+wqp_sec(i,j,ku)) + + ENDDO + ENDDO + ENDDO + + + end subroutine assumed_pdf + + +! Saturation vapor pressure and mixing ratio subroutines +! Based on Flatau et al (1992), J. App. Met., 31, 1507-1513 +! Code by Marat Khairoutdinov + + + real function esatw(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 6.11239921, 0.443987641, 0.142986287e-1, & + 0.264847430e-3, 0.302950461e-5, 0.206739458e-7, & + 0.640689451e-10, -0.952447341e-13,-0.976195544e-15/ + real dt + dt = max(-80.,t-273.16) + esatw = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + end function esatw + + real function qsatw(t,p) +! implicit none + real t ! temperature (K) + real p ! pressure (Pa) + real esat +! esat = fpvs(t) + esat = fpvsl(t) + qsatw = 0.622 * esat/max(esat,p-0.378*esat) +! esat = esatw(t) +! qsatw = 0.622 * esat/max(esat,p-esat) + end function qsatw + + + real function esati(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 6.11147274, 0.503160820, 0.188439774e-1, & + 0.420895665e-3, 0.615021634e-5, 0.602588177e-7, & + 0.385852041e-9, 0.146898966e-11, 0.252751365e-14/ + real dt +! real esatw + if(t > 273.15) then + esati = esatw(t) + else if(t.gt.185.) then + dt = t-273.16 + esati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + else ! use some additional interpolation below 184K + dt = max(-100.,t-273.16) + esati = 0.00763685 + dt*(0.000151069+dt*7.48215e-07) + endif + end function esati + + real function qsati(t,p) + real t ! temperature (K) + real p ! pressure (Pa) + real esat !,esati +! esat = fpvs(t) + esat = fpvsi(t) + qsati = 0.622 * esat/max(esat,p-0.378*esat) +! esat = esati(t) +! qsati = 0.622 * esat/max(esat,p-esat) + end function qsati + + real function dtesatw(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 0.443956472, 0.285976452e-1, 0.794747212e-3, & + 0.121167162e-4, 0.103167413e-6, 0.385208005e-9, & + -0.604119582e-12, -0.792933209e-14, -0.599634321e-17/ + real dt + dt = max(-80.,t-273.16) + dtesatw = a0 + dt* (a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + end function dtesatw + + real function dtqsatw(t,p) + real t ! temperature (K) + real p ! pressure (Pa) +! real dtesatw + dtqsatw = 100.0*0.622*dtesatw(t)/p + end function dtqsatw + + real function dtesati(t) + real t ! temperature (K) + real a0,a1,a2,a3,a4,a5,a6,a7,a8 + data a0,a1,a2,a3,a4,a5,a6,a7,a8 / & + 0.503223089, 0.377174432e-1, 0.126710138e-2, & + 0.249065913e-4, 0.312668753e-6, 0.255653718e-8, & + 0.132073448e-10, 0.390204672e-13, 0.497275778e-16/ + real dt +! real dtesatw + if(t > 273.15) then + dtesati = dtesatw(t) + else if(t > 185.) then + dt = t-273.16 + dtesati = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt))))))) + else ! use additional interpolation below 185K + dt = max(-100.,t-273.16) + dtesati = 0.0013186 + dt*(2.60269e-05+dt*1.28676e-07) + endif + end function dtesati + + + real function dtqsati(t,p) + real t ! temperature (K) + real p ! pressure (Pa) +! real dtesati + dtqsati = 100.0*0.622*dtesati(t)/p + end function dtqsati + +end subroutine shoc diff --git a/gsmphys/gcycle.F90 b/gsmphys/gcycle.F90 new file mode 100644 index 00000000..45839916 --- /dev/null +++ b/gsmphys/gcycle.F90 @@ -0,0 +1,256 @@ + SUBROUTINE GCYCLE (nblks, Model, Grid, Sfcprop, Cldprop) +! +! + USE MACHINE, only: kind_phys + USE PHYSCONS, only: PI => con_PI + USE GFS_typedefs, only: GFS_control_type, GFS_grid_type, & + GFS_sfcprop_type, GFS_cldprop_type + implicit none + + integer :: nblks + type(GFS_control_type), intent(in) :: Model + type(GFS_grid_type), intent(in) :: Grid(nblks) + type(GFS_sfcprop_type), intent(inout) :: Sfcprop(nblks) + type(GFS_cldprop_type), intent(inout) :: Cldprop(nblks) + +! +! Local variables +! --------------- + integer :: & + I_INDEX(Model%nx*Model%ny), & + J_INDEX(Model%nx*Model%ny) + + real(kind=kind_phys) :: & + RLA (Model%nx*Model%ny), & + RLO (Model%nx*Model%ny), & + SLMASK (Model%nx*Model%ny), & + OROG (Model%nx*Model%ny), & + OROG_UF (Model%nx*Model%ny), & + SLIFCS (Model%nx*Model%ny), & + TSFFCS (Model%nx*Model%ny), & + TSCLIM (Model%nx*Model%ny), & + MLDCLIM (Model%nx*Model%ny), & + QFLUXADJ(Model%nx*Model%ny), & + SNOFCS (Model%nx*Model%ny), & + ZORFCS (Model%nx*Model%ny), & + TG3FCS (Model%nx*Model%ny), & + CNPFCS (Model%nx*Model%ny), & + AISFCS (Model%nx*Model%ny), & + F10MFCS(Model%nx*Model%ny), & + VEGFCS (Model%nx*Model%ny), & + VETFCS (Model%nx*Model%ny), & + SOTFCS (Model%nx*Model%ny), & + CVFCS (Model%nx*Model%ny), & + CVBFCS (Model%nx*Model%ny), & + CVTFCS (Model%nx*Model%ny), & + SWDFCS (Model%nx*Model%ny), & + SIHFCS (Model%nx*Model%ny), & + SICFCS (Model%nx*Model%ny), & + SITFCS (Model%nx*Model%ny), & + VMNFCS (Model%nx*Model%ny), & + VMXFCS (Model%nx*Model%ny), & + SLPFCS (Model%nx*Model%ny), & + ABSFCS (Model%nx*Model%ny), & + ALFFC1 (Model%nx*Model%ny*2), & + ALBFC1 (Model%nx*Model%ny*4), & + SMCFC1 (Model%nx*Model%ny*Model%lsoil), & + STCFC1 (Model%nx*Model%ny*Model%lsoil), & + SLCFC1 (Model%nx*Model%ny*Model%lsoil) + + character(len=6) :: tile_num_ch + real(kind=kind_phys) :: sig1t, pifac + integer :: npts, len, nb, ix, jx, ls, ios + logical :: exists +! +!@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ +! +! if (Model%me .eq. 0) print *,' nlats=',nlats,' lonsinpe=' +! *,lonsinpe(0,1) + + tile_num_ch = " " + if (Model%tile_num < 10) then + write(tile_num_ch, "(a4,i1)") "tile", Model%tile_num + else + write(tile_num_ch, "(a4,i2)") "tile", Model%tile_num + endif + + len = 0 + do jx = Model%jsc, (Model%jsc+Model%ny-1) + do ix = Model%isc, (Model%isc+Model%nx-1) + len = len + 1 + i_index(len) = ix + j_index(len) = jx + enddo + enddo + + sig1t = 0.0 + npts = Model%nx*Model%ny +! + pifac = 180.0 / pi + len = 0 + do nb = 1,nblks + do ix = 1,size(Grid(nb)%xlat,1) + len = len + 1 + RLA (len) = Grid(nb)%xlat (ix) * pifac + RLO (len) = Grid(nb)%xlon (ix) * pifac + OROG (len) = Sfcprop(nb)%oro (ix) + OROG_UF (len) = Sfcprop(nb)%oro_uf (ix) + SLIFCS (len) = Sfcprop(nb)%slmsk (ix) + if (Model%do_ocean) then + if (Model%kdt == 1 .or. (Model%iau_offset > 0 .and. Model%kdt-Model%kdt_prev == 1)) then + TSFFCS (len) = Sfcprop(nb)%tsfc (ix) + else + TSFFCS (len) = Sfcprop(nb)%ts_clim_iano (ix) + endif + else + if ( Model%nstf_name(1) > 0 ) then + TSFFCS(len) = Sfcprop(nb)%tref (ix) + else + TSFFCS(len) = Sfcprop(nb)%tsfc (ix) + endif + endif + SNOFCS (len) = Sfcprop(nb)%weasd (ix) + ZORFCS (len) = Sfcprop(nb)%zorl (ix) + TG3FCS (len) = Sfcprop(nb)%tg3 (ix) + CNPFCS (len) = Sfcprop(nb)%canopy (ix) + F10MFCS (len) = Sfcprop(nb)%f10m (ix) + VEGFCS (len) = Sfcprop(nb)%vfrac (ix) + VETFCS (len) = Sfcprop(nb)%vtype (ix) + SOTFCS (len) = Sfcprop(nb)%stype (ix) + CVFCS (len) = Cldprop(nb)%cv (ix) + CVBFCS (len) = Cldprop(nb)%cvb (ix) + CVTFCS (len) = Cldprop(nb)%cvt (ix) + SWDFCS (len) = Sfcprop(nb)%snowd (ix) + SIHFCS (len) = Sfcprop(nb)%hice (ix) + SICFCS (len) = Sfcprop(nb)%fice (ix) + SITFCS (len) = Sfcprop(nb)%tisfc (ix) + VMNFCS (len) = Sfcprop(nb)%shdmin (ix) + VMXFCS (len) = Sfcprop(nb)%shdmax (ix) + SLPFCS (len) = Sfcprop(nb)%slope (ix) + ABSFCS (len) = Sfcprop(nb)%snoalb (ix) + + ALFFC1 (len ) = Sfcprop(nb)%facsf (ix) + ALFFC1 (len + npts) = Sfcprop(nb)%facwf (ix) + + ALBFC1 (len ) = Sfcprop(nb)%alvsf (ix) + ALBFC1 (len + npts ) = Sfcprop(nb)%alvwf (ix) + ALBFC1 (len + npts*2) = Sfcprop(nb)%alnsf (ix) + ALBFC1 (len + npts*3) = Sfcprop(nb)%alnwf (ix) + + do ls = 1,Model%lsoil + SMCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%smc (ix,ls) + STCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%stc (ix,ls) + SLCFC1 (len + (ls-1)*npts) = Sfcprop(nb)%slc (ix,ls) + enddo + + IF (SLIFCS(len) .LT. 0.1 .OR. SLIFCS(len) .GT. 1.5) THEN + SLMASK(len) = 0 + ELSE + SLMASK(len) = 1 + ENDIF + + IF (SLIFCS(len) .EQ. 2) THEN + AISFCS(len) = 1. + ELSE + AISFCS(len) = 0. + ENDIF + +! if (Model%me .eq. 0) +! & print *,' len=',len,' rla=',rla(len),' rlo=',rlo(len) + ENDDO !-----END BLOCK SIZE LOOP------------------------------ + ENDDO !-----END BLOCK LOOP------------------------------- + +! check +! call mymaxmin(slifcs,len,len,1,'slifcs') +! call mymaxmin(slmask,len,len,1,'slmsk') +! +#ifndef INTERNAL_FILE_NML + inquire (file=trim(Model%fn_nml),exist=exists) + if (.not. exists) then + write(6,*) 'gcycle:: namelist file: ',trim(Model%fn_nml),' does not exist' + stop + else + open (unit=Model%nlunit, file=trim(Model%fn_nml), READONLY, status='OLD', iostat=ios) + rewind (Model%nlunit) + endif +#endif + CALL SFCCYCLE (9998, npts, Model%lsoil, SIG1T, Model%fhcyc, & + Model%idate(4), Model%idate(2), & + Model%idate(3), Model%idate(1), & + Model%phour, RLA, RLO, SLMASK, & + OROG, OROG_UF, Model%USE_UFO, Model%nst_anl, & + SIHFCS, SICFCS, SITFCS, SWDFCS, SLCFC1, & + VMNFCS, VMXFCS, SLPFCS, ABSFCS, TSFFCS, TSCLIM, & + SNOFCS, ZORFCS, ALBFC1, MLDCLIM, QFLUXADJ, TG3FCS, CNPFCS, & + SMCFC1, STCFC1, SLIFCS, AISFCS, F10MFCS, & + VEGFCS, VETFCS, SOTFCS, ALFFC1, CVFCS, & + CVBFCS, CVTFCS, Model%me, Model%nlunit, & + size(Model%input_nml_file), & + Model%input_nml_file, & + Model%ialb, Model%isot, Model%ivegsrc, & + trim(tile_num_ch), i_index, j_index) +#ifndef INTERNAL_FILE_NML + close (Model%nlunit) +#endif + + len = 0 + do nb = 1,nblks + do ix = 1,size(Grid(nb)%xlat,1) + len = len + 1 + Sfcprop(nb)%slmsk (ix) = SLIFCS (len) +! + Sfcprop(nb)%ts_clim_iano (ix) = TSFFCS (len) + if (Model%do_ocean) then + Sfcprop(nb)%tsclim (ix) = TSCLIM (len) + Sfcprop(nb)%mldclim (ix) = MLDCLIM (len) + Sfcprop(nb)%qfluxadj (ix)= QFLUXADJ (len) + else + if ( Model%nstf_name(1) > 0 ) then + Sfcprop(nb)%tref(ix) = TSFFCS (len) + else + Sfcprop(nb)%tsfc(ix) = TSFFCS (len) + endif + endif +! + Sfcprop(nb)%weasd (ix) = SNOFCS (len) + Sfcprop(nb)%zorl (ix) = ZORFCS (len) + Sfcprop(nb)%tg3 (ix) = TG3FCS (len) + Sfcprop(nb)%canopy (ix) = CNPFCS (len) + Sfcprop(nb)%f10m (ix) = F10MFCS (len) + Sfcprop(nb)%vfrac (ix) = VEGFCS (len) + Sfcprop(nb)%vtype (ix) = VETFCS (len) + Sfcprop(nb)%stype (ix) = SOTFCS (len) + Cldprop(nb)%cv (ix) = CVFCS (len) + Cldprop(nb)%cvb (ix) = CVBFCS (len) + Cldprop(nb)%cvt (ix) = CVTFCS (len) + Sfcprop(nb)%snowd (ix) = SWDFCS (len) + Sfcprop(nb)%hice (ix) = SIHFCS (len) + Sfcprop(nb)%fice (ix) = SICFCS (len) + Sfcprop(nb)%tisfc (ix) = SITFCS (len) + Sfcprop(nb)%shdmin (ix) = VMNFCS (len) + Sfcprop(nb)%shdmax (ix) = VMXFCS (len) + Sfcprop(nb)%slope (ix) = SLPFCS (len) + Sfcprop(nb)%snoalb (ix) = ABSFCS (len) + + Sfcprop(nb)%facsf (ix) = ALFFC1 (len ) + Sfcprop(nb)%facwf (ix) = ALFFC1 (len + npts) + + Sfcprop(nb)%alvsf (ix) = ALBFC1 (len ) + Sfcprop(nb)%alvwf (ix) = ALBFC1 (len + npts ) + Sfcprop(nb)%alnsf (ix) = ALBFC1 (len + npts*2) + Sfcprop(nb)%alnwf (ix) = ALBFC1 (len + npts*3) + do ls = 1,Model%lsoil + Sfcprop(nb)%smc (ix,ls) = SMCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%stc (ix,ls) = STCFC1 (len + (ls-1)*npts) + Sfcprop(nb)%slc (ix,ls) = SLCFC1 (len + (ls-1)*npts) + enddo + ENDDO !-----END BLOCK SIZE LOOP------------------------------ + ENDDO !-----END BLOCK LOOP------------------------------- + +! check +! call mymaxmin(slifcs,len,len,1,'slifcs') +! + if (Model%me .eq. 0) print*,'executed gcycle during hour=',Model%fhour + + RETURN + END diff --git a/gsmphys/get_prs.f b/gsmphys/get_prs.f new file mode 100644 index 00000000..5994d0e6 --- /dev/null +++ b/gsmphys/get_prs.f @@ -0,0 +1,380 @@ + subroutine GET_PRS(im,ix,levs,ntrac,t,q, + & thermodyn_id, sfcpress_id, + & gen_coord_hybrid, + & prsi,prki,prsl,prkl,phii,phil,del) +! & prsi,prki,prsl,prkl,phii,phil,del,lprnt) +! + USE MACHINE , ONLY : kind_phys +! use resol_def , only : thermodyn_id, sfcpress_id +! use namelist_physics_def , only : gen_coord_hybrid + use physcons , only : cp => con_cp, nu => con_fvirt + &, rd => con_rd, rkap => con_rocp + USE tracer_const + implicit none +! + integer im, ix, levs, ntrac, thermodyn_id, sfcpress_id + logical gen_coord_hybrid +! logical gen_coord_hybrid, lprnt + real(kind=kind_phys) prsi(ix,levs+1), prki(ix,levs+1) + &, phii(ix,levs+1), phil(ix,levs) + &, prsl(ix,levs), prkl(ix,levs) + &, del(ix,levs), T(ix,levs) + &, q(ix,levs,ntrac) + real(kind=kind_phys) xcp(ix,levs), xr(ix,levs), kappa(ix,levs) + real(kind=kind_phys) tem, dphib, dphit, dphi + real (kind=kind_phys), parameter :: zero=0.0, p00i=1.0e-5 + &, rkapi=1.0/rkap, rkapp1=1.0+rkap + integer i, k, n +! + do k=1,levs + do i=1,im + del(i,k) = PRSI(i,k) - PRSI(i,k+1) + enddo + enddo +! + if( gen_coord_hybrid ) then ! hmhj + if( thermodyn_id.eq.3 ) then ! Enthalpy case +! +! hmhj : This is for generalized hybrid (Henry) with finite difference +! in the vertical and enthalpy as the prognostic (thermodynamic) +! variable. However, the input "t" here is the temperature, +! not enthalpy (because this subroutine is called by gbphys where +! only temperature is available). +! + if (prki(1,1) <= zero .or. prkl(1,1) <= zero) then + call GET_CPR(im,ix,levs,ntrac,q,xcp,xr) +! + do k=1,levs + do i=1,im + kappa(i,k) = xr(i,k)/xcp(i,k) + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prkl(i,k) = (prsl(i,k)*p00i) ** kappa(i,k) + enddo + enddo + do k=2,levs + do i=1,im + tem = 0.5 * (kappa(i,k) + kappa(i,k-1)) + prki(i,k-1) = (prsi(i,k)*p00i) ** tem + enddo + enddo + do i=1,im + prki(i,1) = (prsi(i,1)*p00i) ** kappa(i,1) + enddo + k = levs + 1 + if (prsi(1,k) .gt. 0.0) then + do i=1,im + prki(i,k) = (prsi(i,k)*p00i) ** kappa(i,levs) + enddo + endif +! + do i=1,im + phii(i,1) = 0.0 ! Ignoring topography height here + enddo + DO k=1,levs + do i=1,im + TEM = xr(i,k) * T(i,k) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & / (PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI +! if(k == 1 .and. i == 1) print *,' xr=',xr(1,1),' T=',t(1,1) +! &,' prsi=',prsi(1,1),prsi(1,2),' tem=',tem,' dphi=',dphi + ENDDO + ENDDO + endif + if (prsl(1,1) <= 0.0) then + do k=1,levs + do i=1,im + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + enddo + enddo + endif + if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + do i=1,im + phii(i,1) = 0.0 ! Ignoring topography height here + enddo + call GET_R(im,ix,levs,ntrac,q,xr) + DO k=1,levs + do i=1,im + TEM = xr(i,k) * T(i,k) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & / (PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI +! if(k == 1 .and. i == 1) print *,' xr=',xr(1,1),' T=',t(1,1) +! &,' prsi=',prsi(1,1),prsi(1,2),' tem=',tem,' dphi=',dphi + ENDDO + ENDDO + endif + else ! gc Virtual Temp case + if (prki(1,1) <= zero .or. prkl(1,1) <= zero) then + do k=1,levs + do i=1,im + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + prkl(i,k) = (prsl(i,k)*p00i) ** rkap + enddo + enddo + do k=1,levs+1 + do i=1,im + prki(i,k) = (prsi(i,k)*p00i) ** rkap + enddo + enddo + do i=1,im + phii(i,1) = 0.0 ! Ignoring topography height here + enddo + DO k=1,levs + do i=1,im + TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & / (PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI +! if (k == 1 .and. phil(i,k) < 0.0) write(0,*)' phil=',phil(i,k) +! &,' dphi=',dphi,' prsi=',prsi(i,k),prsi(i,k+1),' tem=',tem + ENDDO + ENDDO + endif + if (prsl(1,1) <= 0.0) then + do k=1,levs + do i=1,im + prsl(i,k) = (PRSI(i,k) + PRSI(i,k+1))*0.5 + enddo + enddo + endif + if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + do i=1,im + phii(i,1) = 0.0 ! Ignoring topography height here + enddo + DO k=1,levs + do i=1,im + TEM = rd * T(i,k)*(1.0+NU*max(Q(i,k,1),zero)) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & / (PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI + ENDDO + ENDDO + endif + endif + else ! Not gc Virtual Temp (Orig Joe) + if (prki(1,1) <= zero) then +! Pressure is in Pa!!!! +! if (lprnt) write(0,*)' prsi=',prsi(1,:) + do i=1,im + prki(i,1) = (prsi(i,1)*p00i) ** rkap + enddo + do k=1,levs + do i=1,im + prki(i,k+1) = (prsi(i,k+1)*p00i) ** rkap + tem = rkapp1 * del(i,k) + prkl(i,k) = (prki(i,k)*PRSI(i,k)-prki(i,k+1)*PRSI(i,k+1)) + & / tem + enddo + enddo +! if (lprnt) write(0,*)' prki=',prki(1,:) +! if (lprnt) write(0,*)' prkl=',prkl(1,:) + + elseif (prkl(1,1) <= zero) then + do k=1,levs + do i=1,im + tem = rkapp1 * del(i,k) + prkl(i,k) = (prki(i,k)*PRSI(i,k)-prki(i,k+1)*PRSI(i,k+1)) + & / tem + enddo + enddo + endif + if (prsl(1,1) <= 0.0) then + do k=1,levs + do i=1,im + PRSL(i,k) = 100.0 * PRKL(i,k) ** rkapi + enddo + enddo + endif + if (phil(1,levs) <= 0.0) then ! If geopotential is not given, calculate + do i=1,im + phii(i,1) = 0.0 ! Ignoring topography height here + enddo + DO k=1,levs + do i=1,im + TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + & / PRKL(i,k) + DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM + DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM + phil(i,k) = phii(i,k) + DPHIB + phii(i,k+1) = phil(i,k) + DPHIT + ENDDO + ENDDO +! if (lprnt)write(0,*)' in get_prs phil=',phil(1,1),'t=',t(1,1), +! &' q=',q(1,1,1),' nu=',nu,' prkl=',prkl(1,1),prki(1,1),' cp=',cp + endif + endif +! + return + end + subroutine GET_PHI(im,ix,levs,ntrac,t,q, + & thermodyn_id, sfcpress_id, + & gen_coord_hybrid, + & prsi,prki,prsl,prkl,phii,phil) +! + USE MACHINE , ONLY : kind_phys +! use resol_def , only : thermodyn_id, sfcpress_id +! use namelist_physics_def , only : gen_coord_hybrid + use physcons , only : cp => con_cp, nu => con_fvirt + &, rd => con_rd, rkap => con_rocp + USE tracer_const + implicit none +! + integer im, ix, levs, ntrac, thermodyn_id, sfcpress_id + logical gen_coord_hybrid + real(kind=kind_phys) prsi(ix,levs+1), prsl(ix,levs) + &, prki(ix,levs+1), prkl(ix,levs) + &, phii(ix,levs+1), phil(ix,levs) + &, T(ix,levs), q(ix,levs,ntrac) + real(kind=kind_phys) xr(ix,levs) + real(kind=kind_phys) tem, dphib, dphit, dphi + real (kind=kind_phys), parameter :: zero=0.0 + integer i, k, n +! + do i=1,im + phii(i,1) = zero ! Ignoring topography height here + enddo + if( gen_coord_hybrid ) then ! hmhj + if( thermodyn_id.eq.3 ) then ! Enthalpy case + call GET_R(im,ix,levs,ntrac,q,xr) + DO k=1,levs + do i=1,im + TEM = xr(i,k) * T(i,k) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & /(PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI +! if(k <= 4 .and. i == 1) print *,' xr=',xr(1,k),' T=',t(1,k) +! &,' prsi=',prsi(1,k),prsi(1,k+1),' tem=',tem,' dphi=',dphi,' k=',k + ENDDO + ENDDO +! + else ! gc Virtual Temp + DO k=1,levs + do i=1,im + TEM = RD * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + DPHI = (PRSI(i,k) - PRSI(i,k+1)) * TEM + & /(PRSI(i,k) + PRSI(i,k+1)) + phil(i,k) = phii(i,k) + DPHI + phii(i,k+1) = phil(i,k) + DPHI + ENDDO + ENDDO + endif + else ! Not gc Virt Temp (Orig Joe) + DO k=1,levs + do i=1,im + TEM = CP * T(i,k) * (1.0 + NU*max(Q(i,k,1),zero)) + & / PRKL(i,k) + DPHIB = (PRKI(i,k) - PRKL(i,k)) * TEM + DPHIT = (PRKL(i,k ) - PRKI(i,k+1)) * TEM + phil(i,k) = phii(i,k) + DPHIB + phii(i,k+1) = phil(i,k) + DPHIT + ENDDO + ENDDO + endif +! + return + end + subroutine GET_CPR(im,ix,levs,ntrac,q,xcp,xr) +! + USE MACHINE , ONLY : kind_phys + USE tracer_const + implicit none +! + real (kind=kind_phys), parameter :: zero=0.0 + integer im, ix, levs, ntrac + real(kind=kind_phys) q(ix,levs,ntrac) + real(kind=kind_phys) xcp(ix,levs),xr(ix,levs),sumq(ix,levs) + integer i, k, n +! + sumq = zero + xr = zero + xcp = zero + do n=1,ntrac + if( ri(n) > 0.0 ) then + do k=1,levs + do i=1,im + xr(i,k) = xr(i,k) + q(i,k,n) * ri(n) + xcp(i,k) = xcp(i,k) + q(i,k,n) * cpi(n) + sumq(i,k) = sumq(i,k) + q(i,k,n) + enddo + enddo + endif + enddo + do k=1,levs + do i=1,im + xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) + xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) + enddo + enddo +! + return + end + subroutine GET_R(im,ix,levs,ntrac,q,xr) +! + USE MACHINE , ONLY : kind_phys + USE tracer_const + implicit none +! + real (kind=kind_phys), parameter :: zero=0.0 + integer im, ix, levs, ntrac + real(kind=kind_phys) q(ix,levs,ntrac) + real(kind=kind_phys) xr(ix,levs),sumq(ix,levs) + integer i, k, n +! + sumq = zero + xr = zero + do n=1,ntrac + if( ri(n) > 0.0 ) then + do k=1,levs + do i=1,im + xr(i,k) = xr(i,k) + q(i,k,n) * ri(n) + sumq(i,k) = sumq(i,k) + q(i,k,n) + enddo + enddo + endif + enddo + do k=1,levs + do i=1,im + xr(i,k) = (1.-sumq(i,k))*ri(0) + xr(i,k) + enddo + enddo +! + return + end + subroutine GET_CP(im,ix,levs,ntrac,q,xcp) +! + USE MACHINE , ONLY : kind_phys + USE tracer_const + implicit none +! + real (kind=kind_phys), parameter :: zero=0.0 + integer im, ix, levs, ntrac + real(kind=kind_phys) q(ix,levs,ntrac) + real(kind=kind_phys) xcp(ix,levs),sumq(ix,levs) + integer i, k, n +! + sumq = zero + xcp = zero + do n=1,ntrac + if( cpi(n) > 0.0 ) then + do k=1,levs + do i=1,im + xcp(i,k) = xcp(i,k) + q(i,k,n) * cpi(n) + sumq(i,k) = sumq(i,k) + q(i,k,n) + enddo + enddo + endif + enddo + do k=1,levs + do i=1,im + xcp(i,k) = (1.-sumq(i,k))*cpi(0) + xcp(i,k) + enddo + enddo +! + return + end diff --git a/gsmphys/get_prs_fv3.f90 b/gsmphys/get_prs_fv3.f90 new file mode 100644 index 00000000..756a632e --- /dev/null +++ b/gsmphys/get_prs_fv3.f90 @@ -0,0 +1,60 @@ +module gfs_fv3_needs + + use machine, only: kind_phys + use physcons, only: con_fvirt + +!--- public declarations + public get_prs_fv3, get_phi_fv3 + +!--- local variables + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: half = 0.5_kind_phys + +contains + + subroutine get_prs_fv3(ix, levs, ntrac, phii, prsi, tgrs, qgrs, del, del_gz) + integer, intent(in) :: ix, levs, ntrac + real(kind=kind_phys), dimension(ix,levs+1), intent(in) :: phii + real(kind=kind_phys), dimension(ix,levs+1), intent(in) :: prsi + real(kind=kind_phys), dimension(ix,levs), intent(in) :: tgrs + real(kind=kind_phys), dimension(ix,levs,ntrac), intent(in) :: qgrs + real(kind=kind_phys), dimension(ix,levs), intent(inout) :: del + real(kind=kind_phys), dimension(ix,levs+1), intent(inout) :: del_gz + +! SJL: Adjust the geopotential height hydrostatically in a way consistent with FV3 discretization +! del_gz is a temp array recording the old info before (t,q) are adjusted + do k=1,levs + do i=1,ix + del(i,k) = prsi(i,k) - prsi(i,k+1) + del_gz(i,k) = (phii(i,k+1) - phii(i,k)) / & + (tgrs(i,k)*(1.+con_fvirt*max(zero,qgrs(i,k,1)))) + enddo + enddo + + end subroutine get_prs_fv3 + + + subroutine get_phi_fv3(ix, levs, ntrac, gt0, gq0, del_gz, phii, phil) + integer, intent(in) :: ix, levs, ntrac + real(kind=kind_phys), dimension(ix,levs), intent(in) :: gt0 + real(kind=kind_phys), dimension(ix,levs,ntrac), intent(in) :: gq0 + real(kind=kind_phys), dimension(ix,levs+1), intent(inout) :: del_gz + real(kind=kind_phys), dimension(ix,levs+1), intent(inout) :: phii + real(kind=kind_phys), dimension(ix,levs), intent(inout) :: phil + +! SJL: Adjust the heighz hydrostatically in a way consistent with FV3 discretization + do i=1,ix + phii(i,1) = zero + enddo + do k=1,levs + do i=1,ix + del_gz(i,k) = del_gz(i,k)*gt0(i,k) * & + & (1.+con_fvirt*max(zero,gq0(i,k,1))) + phii(i,k+1) = phii(i,k) + del_gz(i,k) + phil(i,k) = half*(phii(i,k) + phii(i,k+1)) + enddo + enddo + + end subroutine get_phi_fv3 + +end module gfs_fv3_needs diff --git a/gsmphys/gfs_phy_tracer_config.f b/gsmphys/gfs_phy_tracer_config.f new file mode 100644 index 00000000..8795a921 --- /dev/null +++ b/gsmphys/gfs_phy_tracer_config.f @@ -0,0 +1,232 @@ +! +!! ! Module: gfs_phy_tracer_config +! +! ! Description: gfs physics tracer configuration module +! +! ! Revision history: +! Oct 16 2009 Sarah Lu, adopted from dyn fc +! Nov 21 2009 Sarah Lu, chem tracer specified from ChemRegistry +! Dec 10 2009 Sarah Lu, add doing_GOCART +! Jan 12 2010 Sarah Lu, add trcindx +! Feb 08 2009 Sarah Lu, ri/cpi added to gfs_phy_tracer_type +! Aug 17 2010 Sarah Lu, remove debug print +! Oct 16 2010 Sarah Lu, add fscav +! Aug 08 2011 Jun Wang, remove gocart dependency when not running GOCART +! Sep 17 2011 Sarah Lu, revise chem tracer initialization +! Nov 11 2011 Sarah Lu, allocate but not assign value for cpi/ri array +! Apr 06 2012 Henry Juang, relax hardwire num_tracer, add tracer 4 and 5 +! Apr 23 2012 Jun Wang, remove save attibute for gfs_phy_tracer (already defined) +! --- -- 2016 Anning Cheng add ntiw,ntlnc,ntinc +! May 03 2016 S Moorthi add nto, nto2 +! ------------------------------------------------------------------------- +! + module gfs_phy_tracer_config + use machine , only : kind_phys + + implicit none + SAVE +! +! tracer specification: add fscav +! + type gfs_phy_tracer_type + character*20 , pointer :: chem_name(:) ! chem_tracer name + character*20 , pointer :: vname(:) ! variable name + real(kind=kind_phys), pointer :: ri(:) + real(kind=kind_phys), pointer :: cpi(:) + real(kind=kind_phys), pointer :: fscav(:) + integer :: ntrac, ntrac_met, ntrac_chem + logical :: doing_DU, doing_SU, doing_SS + &, doing_OC, doing_BC, doing_GOCART + endtype gfs_phy_tracer_type + + type (gfs_phy_tracer_type) :: gfs_phy_tracer +! +! misc tracer options +! + logical :: glbsum = .true. +! + +! --- public interface + public tracer_config_init, trcindx + + contains + +! ------------------------------------------------------------------- +! ------------------------------------------------------------------- +! subroutine tracer_config_init (gfs_phy_tracer,ntrac, + subroutine tracer_config_init (ntrac,ntoz,ntcw,ncld, + & ntiw,ntlnc,ntinc, + & fprcp,ntrw,ntsw,ntrnc,ntsnc, + & ntke,nto,nto2,me) + +c +c This subprogram sets up gfs_phy_tracer +c + implicit none +! input + integer, intent(in) :: me, ntoz,ntcw,ncld,ntke, + & ntiw,ntlnc,ntinc,nto,nto2, + & fprcp,ntrw,ntsw,ntrnc,ntsnc +! output +! type (gfs_phy_tracer_type), intent(out) :: gfs_phy_tracer +! input/output + integer, intent(inout) :: ntrac +! local + integer :: i, j, status, ierr + character*20 :: rgname + +! initialize ntrac_chem (the default is no chemistry) + gfs_phy_tracer%ntrac_chem = 0 + gfs_phy_tracer%doing_GOCART = .false. + +! initialize chem tracers + call gocart_tracer_config(me) +! call gocart_tracer_config(gfs_phy_tracer,me) + +! ntrac_met = number of met tracers +!hmhj if ( ntoz < ntcw ) then +!hmhj gfs_phy_tracer%ntrac_met = ntcw + ncld - 1 +!hmhj else +!hmhj gfs_phy_tracer%ntrac_met = ntoz +!hmhj endif +!hmhj if ( gfs_phy_tracer%ntrac_met /= ntrac ) then +!hmhj print *,'LU_TRC: ERROR ! inconsistency in ntrac:', +!hmhj& ntrac, gfs_phy_tracer%ntrac_met +!hmhj stop 222 +!hmhj endif +! input ntrac is meteorological tracers + gfs_phy_tracer%ntrac_met = ntrac + +! update ntrac = total number of tracers + gfs_phy_tracer%ntrac = gfs_phy_tracer%ntrac_met + + & gfs_phy_tracer%ntrac_chem + ntrac = gfs_phy_tracer%ntrac + + if(me==0) then + print *, 'LU_TRCp: ntrac_met =',gfs_phy_tracer%ntrac_met + print *, 'LU_TRCp: ntrac_chem=',gfs_phy_tracer%ntrac_chem + print *, 'LU_TRCp: ntrac =',gfs_phy_tracer%ntrac + endif + +! Set up tracer name, cpi, and ri + if ( gfs_phy_tracer%ntrac > 0 ) then + allocate(gfs_phy_tracer%vname(ntrac), stat=status) + if( status /= 0 ) then + print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me + return + endif + allocate(gfs_phy_tracer%ri(0:ntrac), stat=status) + if( status /= 0 ) then + print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me + return + endif + allocate(gfs_phy_tracer%cpi(0:ntrac), stat=status) + if( status /= 0 ) then + print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me + return + endif + allocate(gfs_phy_tracer%fscav(ntrac), stat=status) + if( status /= 0 ) then + print *,'LU_TRC: alloc error - gfs_dyn_tracer :',status,me + return + endif + +!--- fill in met tracers + gfs_phy_tracer%vname(1) = 'spfh' + if(ntoz > 0) gfs_phy_tracer%vname(ntoz) = 'o3mr' + if(ntcw > 0) gfs_phy_tracer%vname(ntcw) = 'clwmr' + if(ntiw > 0) gfs_phy_tracer%vname(ntiw) = 'climr' + if(ntlnc > 0) gfs_phy_tracer%vname(ntlnc) = 'lnc' + if(ntinc > 0) gfs_phy_tracer%vname(ntinc) = 'inc' + if(ntrw > 0) gfs_phy_tracer%vname(ntrw) = 'rnmr' + if(ntsw > 0) gfs_phy_tracer%vname(ntsw) = 'snwmr' + if(ntrnc > 0) gfs_phy_tracer%vname(ntrnc) = 'rnc' + if(ntsnc > 0) gfs_phy_tracer%vname(ntsnc) = 'snc' + if(ntke > 0) gfs_phy_tracer%vname(ntke) = 'tke' + if(nto > 0) gfs_phy_tracer%vname(nto) = 'o' + if(nto2 > 0) gfs_phy_tracer%vname(nto2) = 'o2' + + + gfs_phy_tracer%fscav(1:gfs_phy_tracer%ntrac_met) = 0. + +!--- fill in chem tracers + if ( gfs_phy_tracer%ntrac_chem > 0 ) then + do i = 1,gfs_phy_tracer%ntrac_chem + j = i + gfs_phy_tracer%ntrac_met + rgname = trim(gfs_phy_tracer%chem_name(i)) + if(me==0)print *, 'LU_TRC_phy: vname=',j,rgname + gfs_phy_tracer%vname(j) = rgname + enddo + endif + + endif !! + + return + + end subroutine tracer_config_init +! ------------------------------------------------------------------- +! ------------------------------------------------------------------- + function trcindx( specname, tracer ) + implicit none + + character*(*), intent(in) :: specname + type (gfs_phy_tracer_type), intent(in) :: tracer + + character*10 :: name1, name2 + integer :: i, trcindx + +! -- set default value + trcindx = -999 + +! -- convert specname to upper case + call fixchar(specname, name1, 1) + do i = 1, tracer%ntrac + call fixchar(tracer%vname(i), name2, 1) + if( name1 == name2 ) then + trcindx = i + exit + endif + enddo + + return + end function trcindx + +! ------------------------------------------------------------------- + subroutine fixchar(name_in, name_out, option) + implicit none + + character*(*), intent(in) :: name_in + character*(*), intent(out) :: name_out + integer, intent(in) :: option + + character*10 :: temp + integer :: i, ic + + name_out= ' ' + temp = trim(adjustl(name_in)) + do i = 1, len_trim(temp) + ic = IACHAR(temp(i:i)) + if(option == 1 ) then !<--- convert to upper case + if(ic .ge. 97 .and. ic .le. 122) then + name_out(i:i) = CHAR( IC-32 ) + else + name_out(i:i) = temp(i:i) + endif + endif + if(option == 2 ) then !<--- convert to lower case + if(ic .ge. 65 .and. ic .le. 90) then + name_out(i:i) = CHAR( IC+32 ) + else + name_out(i:i) = temp(i:i) + endif + endif + + enddo + name_out=trim(name_out) + return + + end subroutine fixchar + +! ========================================================================= + + end module gfs_phy_tracer_config diff --git a/gsmphys/gocart_tracer_config_stub.f b/gsmphys/gocart_tracer_config_stub.f new file mode 100644 index 00000000..d6df297c --- /dev/null +++ b/gsmphys/gocart_tracer_config_stub.f @@ -0,0 +1,17 @@ +! +!! ! Subroutine : gocart_tracer_config +! +! ! Description: stub for resetting gfs phys when gocart is running +! +! ! Revision history: +! Aug 09 2011 Jun Wang, initial code +! ------------------------------------------------------------------------- +! + subroutine gocart_tracer_config() +! + +! print *,'TRAC_CONFIG: gocart is not running.' + + return + + end subroutine gocart_tracer_config diff --git a/gsmphys/gscond.f b/gsmphys/gscond.f new file mode 100644 index 00000000..52fc3a16 --- /dev/null +++ b/gsmphys/gscond.f @@ -0,0 +1,521 @@ +!> \file gscond.f +!! This file contains the subroutine that calculates grid-scale +!! condensation and evaporation for use in the Zhao and Carr (1997) +!! \cite zhao_and_carr_1997 scheme. + +!> \defgroup MPscheme Grid-scale Condensation, Evaporation and Precipitation +!! @{ +!! \brief The GFS scheme for large-scale condensation and precipitation +!! , based on Zhao and Carr (1997) \cite zhao_and_carr_1997 +!! and Sundqvist et al. (1989) \cite sundqvist_et_al_1989 . +!! \image html schematic_MPS.png "Figure 1: Schematic illustration of the precipitation scheme" width=10cm +!! \details Figure 1 shows a schematic illustration of this scheme. +!! There are two sources of prognostic cloud condensate, convective +!! detrainment (see convection) and grid-sale +!! condensate. The sinks of cloud condensate are grid-scale +!! precipitation and evaporation of the cloud condensate. Evaporation +!! of rain in the unsaturated layers below the level of condensation +!! is also taken into account. All precipitation that penetrates the +!! lowest atmospheric layer is allowed to fall to the surface. +!! Subsequent to the May 2001 implementation, excessive amounts of +!! light precipitation were noted. This was addressed through a minor +!! implementation in August 2001, which involved a slight modification +!! of the autoconversion rate of ice. At the same time, an +!! empirically-based calculation of the effective radius for ice +!! crystals (Heymsfield and McFarquhar 1996 +!! \cite heymsfield_and_mcfarquhar_1996) was introduced. +!> \section tune Important Tunable Parameters +!! The parameters below, which can be set through a namelist, influence +!! the amount of cloud condensate in the atmosphere and thus the cloud +!! radiative properties: +!! - PSAUTCO, PRAUTCO: Auto conversion coefficients (ice and water) +!! - WMINCO(2): Coefficients for minimum value of cloud condensate to +!! conversion from condensate (water and ice) to precipitation +!! - EVPCO: Coefficient for evaporation of precipitation +!! +!! \section intramps Intraphysics Communication +!! - Routine GSCOND is called from GBPHYS after call to SHALCNV +!! - Routine PRECPD is called from GBPHYS after call to GSCOND + +!> \defgroup condense Grid-Scale Condensation and Evaporation of Cloud +!! This subroutine computes grid-scale condensation and evaporation of +!! cloud condensate. +!! +!> There are two sources of condensation, one from large-scale +!! processes and the other from convective processes. Both of them +!! produce either cloud water or cloud ice, depending on the cloud +!! substance at and above the grid point at current and previous time +!! steps, and on the temperature. Evaporation of cloud is allowed at +!! points where the relative humidity is lower than the critical value +!! required for condensation. +!! @{ + +!> \param[in] ix horizontal dimension +!! \param[in] im horizontal number of used pts +!! \param[in] km vertical layer dimension +!! \param[in] dt physics time step in seconds +!! \param[in] dtf dynamics time step in seconds +!! \param[in] prsl pressure values for model layers +!! \param[in] ps surface pressure (Pa) +!! \param[in,out] q model layer specific humidity (gm/gm) +!! \param[in,out] cwm model layer cloud condensate +!! \param[in,out] t model layer mean temperature (K) +!! \param[in,out] tp model layer mean temperature (K) saved for +!! restart +!! \param[in,out] qp model layer specific humidity (gm/gm) saved +!! for restart +!! \param[in,out] psp surface pressure (Pa) saved for restart +!! \param[in,out] tp1 updated model layer mean temperature (K) saved +!! for restart +!! \param[in,out] qp1 updated model layer specific humidity (gm/gm) +!! saved for restart +!! \param[in,out] psp1 updated surface pressure (Pa) saved for +!! restart +!! \param[in] u the critical value of relative humidity for +!! large-scale condensation +!! \param[in] lprnt logical print flag +!! \param[in] ipr check print point for debugging +!! +!! \section def Definition of symbols +!! - \f$C_{g}\f$: grid-scale condensation rate (\f$s^{-1}\f$) +!! - \f$E_{c}\f$: evaporation rate of cloud (\f$s^{-1}\f$) +!> \section gen_algorithm General Algorithm +!> @{ + subroutine gscond (im,ix,km,dt,dtf,prsl,ps,q,cwm,t & + &, tp, qp, psp, tp1, qp1, psp1, u, lprnt, ipr) +! +! ****************************************************************** +! * * +! * subroutine for grid-scale condensation & evaporation * +! * for the mrf model at ncep. * +! * * +! ****************************************************************** +! * * +! * created by: q. zhao jan. 1995 * +! * modified by: h.-l. pan sep. 1998 * +! * modified by: s. moorthi aug. 1998, 1999, 2000 * +! * * +! * references: * +! * * +! ****************************************************************** +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, psat => con_psat, hvap => con_hvap, grav => con_g + &, hfus => con_hfus, ttp => con_ttp, rd => con_rd + &, cp => con_cp, eps => con_eps, epsm1 => con_epsm1 + &, rv => con_rv +! use namelist_def, only: nsdfi,fhdfi + implicit none +! + real (kind=kind_phys) h1 + &, d00, elwv, eliv + &, epsq + &, r, cpr, rcp + parameter (h1=1.e0, d00=0.e0 + &, elwv=hvap, eliv=hvap+hfus + &, epsq=2.e-12, r=rd + &, cpr=cp*r, rcp=h1/cp) +! + real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0 +! + integer im, ix, km, ipr + real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km) & + &, prsl(ix,km), ps(im), dt, dtf & + &, tp(ix,km), qp(ix,km), psp(im) & + &, tp1(ix,km), qp1(ix,km), psp1(im) +! + real (kind=kind_phys) qi(im), qint(im), u(im,km), ccrik, e0 + &, cond, rdt, us, cclimit, climit + &, tmt0, tmt15, qik, cwmik + &, ai, qw, u00ik, tik, pres, pp0, fi + &, at, aq, ap, fiw, elv, qc, rqik + &, rqikk, tx1, tx2, tx3, es, qs + &, tsq, delq, condi, cone0, us00, ccrik1 + &, aa, ab, ac, ad, ae, af, ag + &, el2orc, albycp +! real (kind=kind_phys) vprs(im) + integer iw(im,km), i, k, iwik + logical lprnt +! +!-----------------prepare constants for later uses----------------- +! + el2orc = hvap*hvap / (rv*cp) + albycp = hvap / cp +! write(0,*)' in gscond im=',im,' ix=',ix +! + rdt = h1/dt + us = h1 + cclimit = 1.0e-3 + climit = 1.0e-20 +! + do i = 1, im + iw(i,km) = d00 + enddo +! +! check for first time step +! +! if (tp(1,1) < 1.) then +! do k = 1, km +! do i = 1, im +! tp(i,k) = t(i,k) +! qp(i,k) = max(q(i,k),epsq) +! tp1(i,k) = t(i,k) +! qp1(i,k) = max(q(i,k),epsq) +! enddo +! enddo +! do i = 1, im +! psp(i) = ps(i) +! psp1(i) = ps(i) +! enddo +! endif +! +!************************************************************* +!> -# Begining of grid-scale condensation/evaporation loop (start of +!! k-loop, i-loop) +!************************************************************* +! +! do k = km-1,2,-1 + do k = km,1,-1 +! vprs(:) = 0.001 * fpvs(t(:,k)) ! fpvs in pa +!----------------------------------------------------------------------- +!------------------qw, qi and qint-------------------------------------- + do i = 1, im + tmt0 = t(i,k)-273.16 + tmt15 = min(tmt0,cons_m15) + qik = max(q(i,k),epsq) + cwmik = max(cwm(i,k),climit) +! +! ai = 0.008855 +! bi = 1.0 +! if (tmt0 .lt. -20.0) then +! ai = 0.007225 +! bi = 0.9674 +! end if +! +! the global qsat computation is done in pa + pres = prsl(i,k) +! +! qw = vprs(i) + qw = min(pres, fpvs(t(i,k))) +! + qw = eps * qw / (pres + epsm1 * qw) + qw = max(qw,epsq) +! qi(i) = qw *(bi+ai*min(tmt0,cons_0)) +! qint(i) = qw *(1.-0.00032*tmt15*(tmt15+15.)) + qi(i) = qw + qint(i) = qw +! if (tmt0 .le. -40.) qint(i) = qi(i) + +!> -# Compute ice-water identification number IW. +!!\n The distinction between cloud water and cloud ice is made by the +!! cloud identification number IW, which is zero for cloud water and +!! unity for cloud ice (Table 2 in zhao and Carr (1997) +!! \cite zhao_and_carr_1997): +!! - All clouds are defined to consist of liquid water below the +!! freezing level (\f$T\geq 0^oC\f$) and of ice particles above the +!! \f$T=-15^oC\f$ level. +!! - In the temperature region between \f$-15^oC\f$ and \f$0^oC\f$, +!! clouds may be composed of liquid water or ice. If there are cloud +!! ice particles above this point at the previous or current time step, +!! or if the cloud at this point at the previous time step consists of +!! ice particles, then the cloud substance at this point is considered +!! to be ice particles because of the cloud seeding effect and the +!! memory of its content. Otherwise, all clouds in this region are +!! considered to contain supercooled cloud water. + +!-------------------ice-water id number iw------------------------------ + if(tmt0.lt.-15.0) then + u00ik = u(i,k) + fi = qik - u00ik*qi(i) + if(fi > d00.or.cwmik > climit) then + iw(i,k) = 1 + else + iw(i,k) = 0 + end if + end if +! + if(tmt0.ge.0.0) then + iw(i,k) = 0 + end if +! + if (tmt0 < 0.0 .and. tmt0 >= -15.0) then + iw(i,k) = 0 + if (k < km) then + if (iw(i,k+1) == 1 .and. cwmik > climit) iw(i,k) = 1 + endif + end if + enddo +!> -# Condensation and evaporation of cloud +!--------------condensation and evaporation of cloud-------------------- + do i = 1, im +!> - Compute the changes in t, q and p (\f$A_{t}\f$,\f$A_{q}\f$ and +!! \f$A_{p}\f$) caused by all the processes except grid-scale +!! condensation and evaporation. +!!\f[ +!! A_{t}=(t-tp)/dt +!!\f] +!!\f[ +!! A_{q}=(q-qp)/dt +!!\f] +!!\f[ +!! A_{p}=(prsl-\frac{prsl}{ps} \times psp)/dt +!!\f] +!------------------------at, aq and dp/dt------------------------------- + qik = max(q(i,k),epsq) + cwmik = max(cwm(i,k),climit) + iwik = iw(i,k) + u00ik = u(i,k) + tik = t(i,k) + pres = prsl(i,k) + pp0 = (pres / ps(i)) * psp(i) + at = (tik-tp(i,k)) * rdt + aq = (qik-qp(i,k)) * rdt + ap = (pres-pp0) * rdt +!> - Calculate the saturation specific humidity \f$q_{s}\f$ and the +!! relative humidity \f$f\f$ using IW. +!----------------the satuation specific humidity------------------------ + fiw = float(iwik) + elv = (h1-fiw)*elwv + fiw*eliv + qc = (h1-fiw)*qint(i) + fiw*qi(i) +! if (lprnt) print *,' qc=',qc,' qint=',qint(i),' qi=',qi(i) +!----------------the relative humidity---------------------------------- + if(qc.le.1.0e-10) then + rqik=d00 + else + rqik = qik/qc + endif + +!> - According to Sundqvist et al. (1989) \cite sundqvist_et_al_1989, +!! estimate cloud fraction \f$b\f$ at a grid point from relative +!! humidity \f$f\f$ using the equation +!!\f[ +!! b=1-\left ( \frac{f_{s}-f}{f_{s}-u} \right )^{1/2} +!!\f] +!! for \f$f>u\f$; and \f$b=0\f$ for \f$f1.0\times10^{-3}\f$, condense water vapor +!! in to cloud condensate (\f$C_{g}\f$). +!!\n Using \f$q=fq_{s}\f$, \f$q_{s}=\epsilon e_{s}/p\f$, and the +!! Clausius-Clapeyron equation \f$de_{s}/dT=\epsilon Le_{s}/RT^{2}\f$, +!! where \f$q_{s}\f$ is the saturation specific humidity,\f$e_{s}\f$ +!! is the saturation vapor pressure, \f$R\f$ is the specific gas +!! constant for dry air, \f$f\f$ is the relative humidity, and +!! \f$\epsilon=0.622\f$, the expression for \f$C_{g}\f$ has the form +!!\f[ +!! C_{g}=\frac{M-q_{s}f_{t}}{1+(f\epsilon L^{2}q_{s}/RC_{p}T^{2})}+E_{c} +!!\f] +!! where +!!\f[ +!! M=A_{q}-\frac{f\epsilon Lq_{s}}{RT^{2}}A_{t}+\frac{fq_{s}}{p}A_{p} +!!\f] +!! To close the system, an equation for the relative humidity tendency +!! \f$f_{t}\f$ was derived by Sundqvist et al. (1989) +!! \cite sundqvist_et_al_1989 using the hypothesis that the quantity +!! \f$M+E_{c}\f$ is divided into one part,\f$bM\f$,which condenses +!! in the already cloudy portion of a grid square, and another part, +!! \f$(1-b)M+E_{c}\f$,which is used to increase the relative humidity +!! of the cloud-free portion and the cloudiness in the square. The +!! equation is written as +!!\f[ +!! f_{t}=\frac{2(1-b)(f_{s}-u)[(1-b)M+E_{c}]}{2q_{s}(1-b)(f_{s}-u)+cwm/b} +!!\f] +!! - Check and correct if over condensation occurs. +!! - Update t, q and cwm (according to Eqs(6) and (7) in Zhao and +!! Carr (1997) \cite zhao_and_carr_1997) +!!\f[ +!! cwm=cwm+(C_{g}-E_{c})\times dt +!!\f] +!!\f[ +!! q=q-(C_{g}-E_{c})\times dt +!!\f] +!!\f[ +!! t=t+\frac{L}{C_{p}}(C_{g}-E_{c})\times dt +!!\f] +!!\n where \f$L\f$ is the latent heat of condensation/deposition, and +!! \f$C_{p}\f$ is the specific heat of air at constant pressure. + +!----------------cloud cover ratio ccrik-------------------------------- + if (rqik .lt. u00ik) then + ccrik = d00 + elseif(rqik.ge.us) then + ccrik = us + else + rqikk = min(us,rqik) + ccrik = h1-sqrt((us-rqikk)/(us-u00ik)) + endif +!-----------correct ccr if it is too small in large cwm regions-------- +! if(ccrik.ge.0.01.and.ccrik.le.0.2.and +! & .cwmik.ge.0.2e-3) then +! ccrik=min(1.0,cwmik*1.0e3) +! end if +!---------------------------------------------------------------------- +! if no cloud exists then evaporate any existing cloud condensate +!----------------evaporation of cloud water----------------------------- + e0 = d00 + if (ccrik <= cclimit.and. cwmik > climit) then +! +! first iteration - increment halved +! + tx1 = tik + tx3 = qik +! + es = min(pres, fpvs(tx1)) + qs = u00ik * eps * es / (pres + epsm1*es) + tsq = tx1 * tx1 + delq = 0.5 * (qs - tx3) * tsq / (tsq + el2orc * qs) +! + tx2 = delq + tx1 = tx1 - delq * albycp + tx3 = tx3 + delq +! +! second iteration +! + es = min(pres, fpvs(tx1)) + qs = u00ik * eps * es / (pres + epsm1*es) + tsq = tx1 * tx1 + delq = (qs - tx3) * tsq / (tsq + el2orc * qs) +! + tx2 = tx2 + delq + tx1 = tx1 - delq * albycp + tx3 = tx3 + delq +! +! third iteration +! + es = min(pres, fpvs(tx1)) + qs = u00ik * eps * es / (pres + epsm1*es) + tsq = tx1 * tx1 + delq = (qs - tx3) * tsq / (tsq + el2orc * qs) + tx2 = tx2 + delq +! + e0 = max(tx2*rdt, cons_0) +! if (lprnt .and. i .eq. ipr .and. k .eq. 34) +! & print *,' tx2=',tx2,' qc=',qc,' u00ik=',u00ik,' rqik=',rqik +! &,' cwmik=',cwmik,' e0',e0 + +! e0 = max(qc*(u00ik-rqik)*rdt, cons_0) + e0 = min(cwmik*rdt, e0) + e0 = max(cons_0,e0) + end if +! if cloud cover > 0.2 condense water vapor in to cloud condensate +!-----------the eqs. for cond. has been reorganized to reduce cpu------ + cond = d00 +! if (ccrik .gt. 0.20 .and. qc .gt. epsq) then + if (ccrik .gt. cclimit .and. qc .gt. epsq) then + us00 = us - u00ik + ccrik1 = 1.0 - ccrik + aa = eps*elv*pres*qik + ab = ccrik*ccrik1*qc*us00 + ac = ab + 0.5*cwmik + ad = ab * ccrik1 + ae = cpr*tik*tik + af = ae * pres + ag = aa * elv + ai = cp * aa + cond = (ac-ad)*(af*aq-ai*at+ae*qik*ap)/(ac*(af+ag)) +!-----------check & correct if over condensation occurs----------------- + condi = (qik -u00ik *qc*1.0)*rdt + cond = min(cond, condi) +!----------check & correct if supersatuation is too high---------------- +! qtemp=qik-max(0.,(cond-e0))*dt +! if(qc.le.1.0e-10) then +! rqtmp=0.0 +! else +! rqtmp=qtemp/qc +! end if +! if(rqtmp.ge.1.10) then +! cond=(qik-1.10*qc)*rdt +! end if +!----------------------------------------------------------------------- + cond = max(cond, d00) +!-------------------update of t, q and cwm------------------------------ + end if + cone0 = (cond-e0) * dt + cwm(i,k) = cwm(i,k) + cone0 +! if (lprnt .and. i .eq. ipr) print *,' t=',t(i,k),' cone0',cone0 +! &,' cond=',cond,' e0=',e0,' elv=',elv,' rcp=',rcp,' k=',k +! &,' cwm=',cwm(i,k) + t(i,k) = t(i,k) + elv*rcp*cone0 + q(i,k) = q(i,k) - cone0 + enddo ! end of i-loop! + enddo ! end of k-loop! +! +!********************************************************************* +!> -# End of the condensation/evaporation loop (end of i-loop,k-loop) +!********************************************************************* +! + +!> -# Store \f$t\f$, \f$q\f$, \f$ps\f$ for next time step. + + if (dt > dtf+0.001) then ! three time level + do k = 1, km + do i = 1, im + tp(i,k) = tp1(i,k) + qp(i,k) = qp1(i,k) +! + tp1(i,k) = t(i,k) + qp1(i,k) = max(q(i,k),epsq) + enddo + enddo + do i = 1, im + psp(i) = psp1(i) + psp1(i) = ps(i) + enddo + else ! two time level scheme - tp1, qp1, psp1 not used + do k = 1, km +! write(0,*)' in gscond k=',k,' im=',im,' km=',km + do i = 1, im +! write(0,*)' in gscond i=',i + tp(i,k) = t(i,k) + qp(i,k) = max(q(i,k),epsq) +! qp(i,k) = q(i,k) + tp1(i,k) = tp(i,k) + qp1(i,k) = qp(i,k) + enddo + enddo + do i = 1, im + psp(i) = ps(i) + psp1(i) = ps(i) + enddo + endif +!----------------------------------------------------------------------- + return + end +!> @} +!! @} +!! @} diff --git a/gsmphys/gscondp.f b/gsmphys/gscondp.f new file mode 100755 index 00000000..2cab7dee --- /dev/null +++ b/gsmphys/gscondp.f @@ -0,0 +1,358 @@ + subroutine gscondp (im,ix,km,dt,dtf,prsl,ps,q,cwm,t + &, tp, qp, psp, tp1, qp1, psp1 + &, u,deltaq, sup, lprnt, ipr, kdt) +! +! ****************************************************************** +! * * +! * subroutine for grid-scale condensation & evaporation * +! * for the mrf model at ncep. * +! * * +! ****************************************************************** +! * * +! * created by: q. zhao jan. 1995 * +! * modified by: h.-l. pan sep. 1998 * +! * modified by: s. moorthi aug. 1999, 2000 * +! * * +! * references: * +! * * +! ****************************************************************** +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, psat => con_psat, hvap => con_hvap, grav => con_g + &, hfus => con_hfus, ttp => con_ttp, rd => con_rd + &, cp => con_cp, eps => con_eps, epsm1 => con_epsm1 + &, rv => con_rv, thgni => con_thgni +! use namelist_def, only: nsdfi,fhdfi + + implicit none +! + real (kind=kind_phys) g, h1, h2, h1000 + &, d00, d125, d5, elwv, eliv + &, epsq, tm10, eliw, arcp + &, a1, r, cpr, rcpr, rcp + parameter (h1=1.e0, h2=2.e0, h1000=1000.0 + &, d00=0.e0, d125=.125e0, d5=0.5e0 + &, a1=psat + &, elwv=hvap, eliv=hvap+hfus, g=grav + &, epsq=2.e-12, tm10=ttp-10., r=rd + &, cpr=cp*r, rcpr=h1/cpr, rcp=h1/cp) +! + real(kind=kind_phys), parameter :: cons_0=0.0, cons_m15=-15.0 +! + integer im, ix, km, ipr + real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km) + &, prsl(ix,km), ps(im), dt, dtf + &, tp(ix,km), qp(ix,km), psp(im) + &, tp1(ix,km), qp1(ix,km), psp1(im) + &, deltaq(ix,km),deltaqik + real (kind=kind_phys) qtmp,qwtmp,qtpd,qsc,usc + real (kind=kind_phys), intent(in) :: sup + logical iice + +! + real (kind=kind_phys) qi(im), qint(im), u(im,km), ccrik, e0 + &, cond, rdt, us, cclimit, climit + &, u00b, u00t, tmt0, tmt15, qik, cwmik + &, ai, bi, qw(im,km), u00ik, tik, pres, pp0, fi + &, at, aq, ap, fiw, elv, qc, rqik + &, rqikk, tx1, tx2, tx3, es, qs + &, tsq, delq, condi, cone0, us00, ccrik1 + &, aa, ab, ac, ad, ae, af, ag + &, el2orc, albycp, vprs(im) + integer iw(im,km), i, k, iwik, kdt + logical lprnt +! +!-----------------prepare constants for later uses----------------- +! + + el2orc = hvap*hvap / (rv*cp) + albycp = hvap / cp +! + rdt = h1/dt + us = h1 + cclimit = 1.0e-3 + climit = 1.0e-20 +! + do i = 1, im + iw(i,km) = d00 + enddo +! the global qsat computation is done in cb + do i = 1, im + do k = 1, km + pres = prsl(i,k) + qwtmp = min(pres, fpvs(t(i,k))) + qw(i,k) = eps * qwtmp / (pres + epsm1 * qwtmp) + qw(i,k) = max(qw(i,k),epsq) + enddo + enddo +! if (tp(1,1) .lt. 1.) then +! do k = 1, km +! do i = 1, im +! tp(i,k) = t(i,k) +! qp(i,k) = max(q(i,k),epsq) +! tp1(i,k) = t(i,k) +! qp1(i,k) = max(q(i,k),epsq) +! enddo +! enddo +! do i = 1, im +! psp(i) = ps(i) +! psp1(i) = ps(i) +! enddo +! do k = 1, km +! do i = 1, im +! deltaq(i,k) = (1-u(i,k))*qw(i,k) +! enddo +! enddo +! endif + if(kdt == 1) then + do k = 1, km + do i = 1, im + deltaq(i,k) = (1-u(i,k))*qw(i,k) + enddo + enddo + endif +c +c************************************************************* +c*******begining of grid-scale condensation/evap. loop******* +c************************************************************* +c +! do k = km-1,2,-1 + do k = km,1,-1 +! vprs(:) = fpvs(t(:,k)) ! fpvs in pa +c----------------------------------------------------------------------- +c------------------qw, qi and qint-------------------------------------- + do i = 1, im + tmt0 = t(i,k)-273.16 + tmt15 = min(tmt0,cons_m15) + qik = max(q(i,k),epsq) + cwmik = max(cwm(i,k),climit) + deltaqik = deltaq(i,k) + qi(i) = qw(i,k) + qint(i) = qw(i,k) +! if (tmt0 .le. -40.) qint(i) = qi(i) +c-------------------ice-water id number iw------------------------------ + if(tmt0 < -15.0) then + u00ik = u(i,k) + fi = qik + deltaqik -qi(i) + if(fi > d00.or.cwmik > climit) then + iw(i,k) = 1 + else + iw(i,k) = 0 + end if + end if +c + if(tmt0 >= 0.0) then + iw(i,k) = 0 + end if +c + if (tmt0 < 0.0 .and. tmt0 >= -15.0) then + iw(i,k) = 0 + if (k < km) then + if (iw(i,k+1) == 1 .and. cwmik > climit) iw(i,k) = 1 + endif + end if + enddo +c--------------condensation and evaporation of cloud-------------------- + do i = 1, im +c------------------------at, aq and dp/dt------------------------------- + qik = max(q(i,k),epsq) + cwmik = max(cwm(i,k),climit) + iwik = iw(i,k) + u00ik = u(i,k) + iice = .false. + deltaqik = deltaq(i,k) + tik = t(i,k) + pres = prsl(i,k) + pp0 = (pres / ps(i)) * psp(i) + at = (tik-tp(i,k)) * rdt + aq = (qik-qp(i,k)) * rdt + ap = (pres-pp0) * rdt + if(tik - 273.16 < thgni) then ! has to be consistent with radiation + iice = .true. + endif +c----------------the satuation specific humidity------------------------ + fiw = float(iwik) + elv = (h1-fiw)*elwv + fiw*eliv + qc = (h1-fiw)*qint(i) + fiw*qi(i) +! if (lprnt) print *,' qc=',qc,' qint=',qint(i),' qi=',qi(i) +c----------------the relative humidity---------------------------------- + if(qc <= 1.0e-10) then + rqik=d00 + else + rqik = qik/qc + endif + if(iice) then + qsc = qc * sup + usc = sup + else + qsc = qc + usc = us + endif +c----------------cloud cover ratio ccrik-------------------------------- + if(rqik >= usc) then + ccrik = us + else + qtmp = qik + cwmik -qsc + if(deltaqik > epsq) then + if(qtmp <= -deltaqik) then + ccrik = d00 + elseif(qtmp >= deltaqik) then + ccrik = us + else + ccrik = 0.5 * qtmp / deltaqik + 0.5 + ccrik = max(ccrik, 0.) + ccrik = min(ccrik, 1.) + endif + else + if(qtmp > 0.) then + ccrik = us + else + ccrik = d00 + endif + endif + endif +c-----------correct ccr if it is too small in large cwm regions-------- +c if(ccrik.ge.0.01.and.ccrik.le.0.2.and +c & .cwmik.ge.0.2e-3) then +c ccrik=min(1.0,cwmik*1.0e3) +c end if +c---------------------------------------------------------------------- +! if no cloud exists then evaporate any existing cloud condensate +c----------------evaporation of cloud water----------------------------- + e0 = d00 + if (ccrik <= cclimit.and.cwmik > climit) then +! +! first iteration - increment halved +! + tx1 = tik + tx3 = qik + + es = min(pres, fpvs(tx1)) + qs = eps * es / (pres + epsm1*es) + if(qs < cons_0) then + print*, 'warning : qs - deltaqik < 0.0' + print*, 'qs, deltaqik:',qs,deltaqik + endif + tsq = tx1 * tx1 + delq = 0.5*(qs-deltaqik-tx3)*tsq / (tsq + el2orc*qs) +! + tx2 = delq + tx1 = tx1 - delq * albycp + tx3 = tx3 + delq +! +! second iteration +! + es = min(pres, fpvs(tx1)) + qs = eps * es / (pres + epsm1*es) + if(qs < cons_0) then + print*, 'warning : qs - deltaqik < 0.0' + print*, 'qs, deltaqik:',qs,deltaqik + endif + tsq = tx1 * tx1 + delq = (qs-deltaqik-tx3)*tsq / (tsq + el2orc * qs) +! + tx2 = tx2 + delq + tx1 = tx1 - delq * albycp + tx3 = tx3 + delq +! +! third iteration +! + es = min(pres, fpvs(tx1)) + qs = eps * es / (pres + epsm1*es) + if(qs < cons_0) then + print*, 'warning : qs - deltaqik < 0.0' + print*, 'qs, deltaqik:',qs,deltaqik + endif + tsq = tx1 * tx1 + delq = (qs-deltaqik-tx3)*tsq / (tsq + el2orc * qs) + + tx2 = tx2 + delq + + e0 = max(tx2*rdt, cons_0) + e0 = min(cwmik*rdt, e0) + e0 = max(cons_0,e0) + end if +! if cloud cover > 0.2 condense water vapor in to cloud condensate +c-----------the eqs. for cond. has been reorganized to reduce cpu------ + cond = d00 +! if (ccrik .gt. 0.20 .and. qc .gt. epsq) then + if (ccrik > cclimit .and. qc > epsq) then + us00 = deltaqik / qc + ccrik1 = 1.0 - ccrik + aa = eps*elv*pres*qik + ab = ccrik*ccrik1*deltaqik + ac = ab + 0.5*cwmik+ 0.5 * ccrik * (qc-qsc) + ad = ab * ccrik1 + 0.5*ccrik*ccrik1*qc*(us-usc) + ae = cpr*tik*tik + af = ae * pres + ag = aa * elv + ai = cp * aa + cond = (ac-ad)*(af*aq-ai*at+ae*qik*ap)/(ac*(af+ag)) +c-----------check & correct if over condensation occurs----------------- + condi = (qik -u00ik *qc*1.0)*rdt + cond = min(cond, condi) +c----------check & correct if supersatuation is too high---------------- +c qtemp=qik-max(0.,(cond-e0))*dt +c if(qc.le.1.0e-10) then +c rqtmp=0.0 +c else +c rqtmp=qtemp/qc +c end if +c if(rqtmp.ge.1.10) then +c cond=(qik-1.10*qc)*rdt +c end if +c----------------------------------------------------------------------- + cond = max(cond, d00) +c-------------------update of t, q and cwm------------------------------ + end if + cone0 = (cond-e0) * dt + cwm(i,k) = cwm(i,k) + cone0 +! if (lprnt .and. i .eq. ipr) print *,' t=',t(i,k),' cone0',cone0 +! &,' cond=',cond,' e0=',e0,' elv=',elv,' rcp=',rcp,' k=',k +! &,' cwm=',cwm(i,k) + t(i,k) = t(i,k) + elv*rcp*cone0 + q(i,k) = q(i,k) - cone0 + enddo ! end of i-loop! + enddo ! end of k-loop! +! +!********************************************************************* +!****************end of the condensation/evaporation loop************* +!********************************************************************* +! +!----------------store t, q, ps for next time step + + if (dt > dtf+0.001) then ! three time level + do k = 1, km + do i = 1, im + tp(i,k) = tp1(i,k) + qp(i,k) = qp1(i,k) +! + tp1(i,k) = t(i,k) + qp1(i,k) = max(q(i,k),epsq) + enddo + enddo + do i = 1, im + psp(i) = psp1(i) + psp1(i) = ps(i) + enddo + else ! two time level scheme - tp1, qp1, psp1 not used + do k = 1, km + do i = 1, im + tp(i,k) = t(i,k) + qp(i,k) = max(q(i,k),epsq) + qp(i,k) = q(i,k) + tp1(i,k) = tp(i,k) + qp1(i,k) = qp(i,k) + enddo + enddo + do i = 1, im + psp(i) = ps(i) + psp1(i) = ps(i) + enddo + endif +!----------------------------------------------------------------------- + return + end diff --git a/gsmphys/gwdc.f b/gsmphys/gwdc.f new file mode 100644 index 00000000..fd37d74d --- /dev/null +++ b/gsmphys/gwdc.f @@ -0,0 +1,1353 @@ +!> \file gwdc.f This file is the original code for parameterization of +!! stationary convection forced gravity wave drag based on Chun and +!! Baik(1998) \cite chun_and_baik_1998 + +!> \ingroup gwd +!> \defgroup convective Convective Gravity Wave Drag +!! This subroutine is the parameterization of convective gravity wave +!! drag based on the theory given by Chun and Baik (1998) +!! \cite chun_and_baik_1998 modified for implementation into the +!! GFS/CFS by Ake Johansson(Aug 2005). +!! +!> Parameterizing subgrid-scale convection-induced gravity wave +!! momentum flux for use in large-scale models inherently requires +!! some information from subgrid-scale cumulus parameterization. +!! The methodology for parameterizing the zonal momentum flux induced +!! by thermal forcing can be summarized as follows. From the cloud-base +!! to cloud-top height, the effect of the momentum flux +!! induced by subgrid-scale diabatic forcing is not considered because +!! subgrid-scale cumulus convection in large-scale models is only +!! activated in a conditionally unstable atmosphere. Below the cloud +!! base, the momentum flux is also not considered because of the wave +!! momentum cancellation. At the cloud top, the momentum flux is +!! obtained by eq.(18) and (19) in Chun and Baik (1998) +!! \cite chun_and_baik_1998. Above the cloud top, there are two ways to +!! construct the momentum flux profile. One way is to specify a +!! vertical structure of the momentum flux normalized by the cloud-top +!! value, similar to what has been done for mountain drag +!! parameterization. The other way is to apply the wave saturation +!! hypothesis in order to find wave breaking levels in terms of the +!! Richardon number criterion using the nonlinearity factor of +!! thermally induced waves. +!!@{ + +!> \param[in] IM horizontal number of used pts +!> \param[in] IX horizontal dimension +!> \param[in] IY horizontal number of used pts +!> \param[in] KM vertical layer dimension +!> \param[in] LAT latitude index - used for debug prints +!> \param[in] U1 u component of layer wind +!> \param[in] V1 v component of layer wind +!> \param[in] T1 layer mean temperature (K) +!> \param[in] Q1 layer mean tracer concentration +!> \param[in] PMID1 mean layer pressure +!> \param[in] PINT1 pressure at layer interfaces +!> \param[in] DPMID1 mean layer delta p +!> \param[in] QMAX maximum convective heating rate (k/s) in a +!! horizontal grid point calculated +!! from cumulus parameterization +!> \param[in] KTOP vertical level index for cloud top +!> \param[in] KBOT vertical level index for cloud bottom +!> \param[in] KCNV (0,1) dependent on whether convection occur or not +!> \param[in] CLDF deep convective cloud fraction at the cloud top +!> \param[in] GRAV gravity defined in physcon +!> \param[in] CP specific heat at constant pressure defined in +!! physcon +!> \param[in] RD gas constant air defined in physcon +!> \param[in] FV con_fvirt = con_rv/con_rd-1 +!> \param[in] DLENGTH grid spacing in the direction of basic wind at +!! the cloud top +!> \param[in] LPRNT logical print flag +!> \param[in] IPR check print point for debugging +!> \param[in] FHOUR forecast hour +!> \param[out] UTGWC zonal wind tendency +!> \param[out] VTGWC meridional wind tendency +!> \param[out] TAUCTX wave stress at the cloud top projected in the +!! east +!> \param[out] TAUCTY wave stress at the cloud top projected in the +!! north +!! +!> \section al_gwdc General Algorithm +!> @{ + subroutine gwdc(im,ix,iy,km,lat,u1,v1,t1,q1,deltim, + & pmid1,pint1,dpmid1,qmax,ktop,kbot,kcnv,cldf, + & grav,cp,rd,fv,pi,dlength,lprnt,ipr,fhour, + & utgwc,vtgwc,tauctx,taucty) + +!*********************************************************************** +! aug 2005 Ake Johansson - ORIGINAL CODE FOR PARAMETERIZATION OF CONVECTIVELY FORCED +! GRAVITY WAVE DRAG FROM YONSEI UNIVERSITY, KOREA +! BASED ON THE THEORY GIVEN BY CHUN AND BAIK (JAS, 1998) +! MODIFIED FOR IMPLEMENTATION INTO THE GFS/CFSD BY +! 2013 S. Moorthi - Updated and optimized code for T1534 GFS implementation +! ??? ?? 2015 J. Alpert - reducing the magnitude of tauctmax to fix blow up in L64 GFS +! S. Kar & M. Young +! aug 15 2016 - S. Moorthi - Fix for exessive dissipation which led to blow up in +! 128 level runs with NEMS/GSM +!*********************************************************************** + + USE MACHINE , ONLY : kind_phys + implicit none + +!---------------------------- Arguments -------------------------------- +! +! Input variables +! +! u : midpoint zonal wind +! v : midpoint meridional wind +! t : midpoint temperatures +! pmid : midpoint pressures +! pint : interface pressures +! dpmid : midpoint delta p ( pi(k)-pi(k-1) ) +! lat : latitude index +! qmax : deep convective heating +! kcldtop : Vertical level index for cloud top ( mid level ) +! kcldbot : Vertical level index for cloud bottom ( mid level ) +! kcnv : (0,1) dependent on whether convection occur or not +! +! Output variables +! +! utgwc : zonal wind tendency +! vtgwc : meridional wind tendency +! +!----------------------------------------------------------------------- + + integer im, ix, iy, km, lat, ipr + integer ktop(im),kbot(im),kcnv(im) + +! real(kind=kind_phys) grav,cp,rd,fv,fhour,fhourpr,deltim + real(kind=kind_phys) grav,cp,rd,fv,fhour,deltim,pi + real(kind=kind_phys), dimension(im) :: qmax & + &, tauctx, taucty + real(kind=kind_phys), dimension(im) :: cldf,dlength + real(kind=kind_phys), dimension(ix,km) :: u1,v1,t1,q1, & + & pmid1,dpmid1 +! &, cumchr1 + real(kind=kind_phys), dimension(iy,km) :: utgwc,vtgwc + real(kind=kind_phys), dimension(ix,km+1) :: pint1 + + logical lprnt + +!------------------------- Local workspace ----------------------------- +! +! i, k : Loop index +! kk : Loop index +! cldf : Deep convective cloud fraction at the cloud top. +! ugwdc : Zonal wind after GWDC paramterization +! vgwdc : Meridional wind after GWDC parameterization +! plnmid : Log(pmid) ( mid level ) +! plnint : Log(pint) ( interface level ) +! dpint : Delta pmid ( interface level ) +! tauct : Wave stress at the cloud top calculated using basic-wind +! parallel to the wind vector at the cloud top ( mid level ) +! tauctx : Wave stress at the cloud top projected in the east +! taucty : Wave stress at the cloud top projected in the north +! qmax : Maximum deep convective heating rate ( K s-1 ) in a +! horizontal grid point calculated from cumulus para- +! meterization. ( mid level ) +! wtgwc : Wind tendency in direction to the wind vector at the cloud top level +! due to convectively generated gravity waves ( mid level ) +! utgwcl : Zonal wind tendency due to convectively generated +! gravity waves ( mid level ) +! vtgwcl : Meridional wind tendency due to convectively generated +! gravity waves ( mid level ) +! taugwci : Profile of wave stress calculated using basic-wind +! parallel to the wind vector at the cloud top +! taugwcxi : Profile of zonal component of gravity wave stress +! taugwcyi : Profile of meridional component of gravity wave stress +! +! taugwci, taugwcxi, and taugwcyi are defined at the interface level +! +! bruni : Brunt-Vaisala frequency ( interface level ) +! brunm : Brunt-Vaisala frequency ( mid level ) +! rhoi : Air density ( interface level ) +! rhom : Air density ( mid level ) +! ti : Temperature ( interface level ) +! basicum : Basic-wind profile. Basic-wind is parallel to the wind +! vector at the cloud top level. (mid level) +! basicui : Basic-wind profile. Basic-wind is parallel to the wind +! vector at the cloud top level. ( interface level ) +! riloc : Local Richardson number ( interface level ) +! rimin : Minimum Richardson number including both the basic-state +! and gravity wave effects ( interface level ) +! gwdcloc : Horizontal location where the GWDC scheme is activated. +! break : Horizontal location where wave breaking is occurred. +! critic : Horizontal location where critical level filtering is +! occurred. +! dogwdc : Logical flag whether the GWDC parameterization is +! calculated at a grid point or not. +! +! dogwdc is used in order to lessen CPU time for GWDC calculation. +! +!----------------------------------------------------------------------- + + integer i,ii,k,k1,kk,kb,ilev,npt,kcb,kcldm,npr + integer, dimension(im) :: ipt + + real(kind=kind_phys) tem, tem1, tem2, qtem, wtgwc, tauct, & + & windcltop, shear, nonlinct, nonlin, nonlins,& + & n2, dtdp, crit1, crit2, p1, p2, & +! & n2, dtdp, crit1, crit2, pi, p1, p2, + & gsqr, onebg +! & taus, n2, dtdp, crit1, crit2, pi, p1, p2 + + integer, allocatable :: kcldtop(:),kcldbot(:) + logical, allocatable :: do_gwc(:) + real(kind=kind_phys), allocatable :: tauctxl(:), tauctyl(:), + & gwdcloc(:), break(:), +! & critic(:), +! & critic(:), angle(:), + & cosphi(:), sinphi(:), + & xstress(:), ystress(:), + & ucltop(:), vcltop(:), + & wrk(:), dtfac(:), + & dlen(:), gqmcldlen(:) +! real(kind=kind_phys), allocatable :: plnint(:,:), dpint(:,:), +! & taugwci(:,:), taugwcxi(:,:), +! & taugwcyi(:,:), bruni(:,:), +! & taugwcyi(:,:), bruni(:,:), + real(kind=kind_phys), allocatable :: plnint(:,:), velco(:,:), + & taugwci(:,:), bruni(:,:), + & rhoi(:,:), basicui(:,:), + & ti(:,:), riloc(:,:), + & rimin(:,:), pint(:,:) +! real(kind=kind_phys), allocatable :: ugwdc(:,:), vgwdc(:,:), + real(kind=kind_phys), allocatable :: +! & plnmid(:,:), wtgwc(:,:), + & plnmid(:,:), taugw(:,:), + & utgwcl(:,:), vtgwcl(:,:), + & basicum(:,:), u(:,:),v(:,:), + & t(:,:), spfh(:,:), + & pmid(:,:), dpmid(:,:), +! & pmid(:,:), cumchr(:,:), + & brunm(:,:), rhom(:,:) + +!----------------------------------------------------------------------- +! +! ucltop : Zonal wind at the cloud top ( mid level ) +! vcltop : Meridional wind at the cloud top ( mid level ) +! windcltop : Wind speed at the cloud top ( mid level ) +! shear : Vertical shear of basic wind +! cosphi : Cosine of angle of wind vector at the cloud top +! sinphi : Sine of angle of wind vector at the cloud top +! c1 : Tunable parameter +! c2 : Tunable parameter +! dlength : Grid spacing in the direction of basic wind at the cloud top +! nonlinct : Nonlinear parameter at the cloud top +! nonlin : Nonlinear parameter above the cloud top +! nonlins : Saturation nonlinear parameter +! taus : Saturation gravity wave drag == taugwci(i,k) +! n2 : Square of Brunt-Vaisala frequency +! dtdp : dT/dp +! xstress : Vertically integrated zonal momentum change due to GWDC +! ystress : Vertically integrated meridional momentum change due to GWDC +! crit1 : Variable 1 for checking critical level +! crit2 : Variable 2 for checking critical level +! +!----------------------------------------------------------------------- + + real(kind=kind_phys), parameter :: + & c1=1.41, c2=-0.38, ricrit=0.25 + &, n2min=1.e-32, zero=0.0, one=1.0 + &, taumin=1.0e-20, tauctmax=-20. +! &, taumin=1.0e-20, tauctmax=-5. + &, qmin=1.0e-10, shmin=1.0e-20 + &, rimax=1.0e+20, rimaxm=0.99e+20 + &, rimaxp=1.01e+20, rilarge=0.9e+20 + &, riminx=-1.0e+20, riminm=-1.01e+20 + &, riminp=-0.99e+20, rismall=-0.9e+20 + +! + npt = 0 + do i = 1,im + ipt(i) = 0 + if (kcnv(i) /= 0 .and. qmax(i) > zero) then + npt = npt + 1 + ipt(npt) = i + endif + enddo + do k=1,km + do i=1,im + utgwc(i,k) = 0.0 + vtgwc(i,k) = 0.0 +! brunm(i,k) = 0.0 +! rhom(i,k) = 0.0 + enddo + enddo + do i=1,im + tauctx(i) = 0.0 + taucty(i) = 0.0 + enddo + if (npt == 0) return ! No gwdc calculation done! + +!*********************************************************************** +! +! Begin GWDC +! +!*********************************************************************** + +!----------------------------------------------------------------------- +! Write out incoming variables +!----------------------------------------------------------------------- + +! fhourpr = zero +! if (lprnt) then +! if (fhour >= fhourpr) then +! print *,' ' +! write(*,*) 'Inside GWDC raw input start print at fhour = ', +! & fhour +! write(*,*) 'IX IM KM ',ix,im,km +! write(*,*) 'KBOT KTOP QMAX DLENGTH kcnv ', +! + kbot(ipr),ktop(ipr),qmax(ipr),dlength(ipr),kcnv(ipr) +! write(*,*) 'grav cp rd ',grav,cp,rd + +!-------- Pressure levels ---------- +! write(*,9100) +! ilev=km+1 +! write(*,9110) ilev,(10.*pint1(ipr,ilev)) +! do ilev=km,1,-1 +! write(*,9120) ilev,(10.*pmid1(ipr,ilev)), +! & (10.*dpmid1(ipr,ilev)) +! write(*,9110) ilev,(10.*pint1(ipr,ilev)) +! enddo + +!-------- U1 V1 T1 ---------- +! write(*,9130) +! do ilev=km,1,-1 +! write(*,9140) ilev,U1(ipr,ilev),V1(ipr,ilev),T1(ipr,ilev) +! enddo + +! print *,' ' +! print *,' Inside GWDC raw input end print' +! endif +! endif + +!9100 format(//,14x,'PRESSURE LEVELS',//, +! +' ILEV',6x,'PINT1',7x,'PMID1',6x,'DPMID1',/) +!9110 format(i4,2x,f10.3) +!9120 format(i4,12x,2(2x,f10.3)) +!9130 format(//,' ILEV',7x,'U1',10x,'V1',10x,'T1',/) +!9140 format(i4,3(2x,f10.3)) + +! Allocate local arrays + + allocate (kcldtop(npt), kcldbot(npt), do_gwc(npt)) + allocate (tauctxl(npt), tauctyl(npt), dtfac(npt), + & gwdcloc(npt), break(npt), cosphi(npt), +! & gwdcloc(npt), break(npt), critic(npt), cosphi(npt), + & sinphi(npt), xstress(npt), ystress(npt), wrk(npt), + & ucltop(npt), vcltop(npt),dlen(npt), gqmcldlen(npt)) + +! allocate (plnint(npt,2:km+1), dpint(npt,km+1), +! & taugwci(npt,km+1), taugwcxi(npt,km+1), +! & taugwcyi(npt,km+1), bruni(npt,km+1), + allocate (plnint(npt,2:km+1), + & taugwci(npt,km+1), bruni(npt,km+1), + & rhoi(npt,km+1), basicui(npt,km+1), + & ti(npt,km+1), riloc(npt,km+1), + & rimin(npt,km+1), pint(npt,km+1)) + +! allocate (ugwdc(npt,km), vgwdc(npt,km), + allocate +! & (plnmid(npt,km), wtgwc(npt,km), + & (plnmid(npt,km), velco(npt,km), + & utgwcl(npt,km), vtgwcl(npt,km), + & basicum(npt,km), u(npt,km), v(npt,km), + & t(npt,km), spfh(npt,km), pmid(npt,km), + & dpmid(npt,km), taugw(npt,km), +! & dpmid(npt,km), cumchr(npt,km), + & brunm(npt,km), rhom(npt,km)) + +!----------------------------------------------------------------------- +!> -# Create local arrays with reversed vertical indices +!! and Initialize local variables +!----------------------------------------------------------------------- + gsqr = grav * grav + onebg = one / grav + + if (lprnt) then + npr = 1 + do i=1,npt + if (ipr == ipt(i))then + npr = i + exit + endif + enddo + endif + + do k=1,km + k1 = km - k + 1 + do i=1,npt + ii = ipt(i) + u(i,k) = u1(ii,k1) + v(i,k) = v1(ii,k1) + t(i,k) = t1(ii,k1) + spfh(i,k) = max(q1(ii,k1),qmin) + pmid(i,k) = pmid1(ii,k1) + dpmid(i,k) = dpmid1(ii,k1) * onebg +! cumchr(i,k) = cumchr1(ii,k1) + + rhom(i,k) = pmid(i,k) / (rd*t(i,k)*(1.0+fv*spfh(i,k))) + plnmid(i,k) = log(pmid(i,k)) + utgwcl(i,k) = zero + vtgwcl(i,k) = zero +! ugwdc(i,k) = zero +! vgwdc(i,k) = zero + brunm(i,k) = zero + basicum(i,k) = zero + enddo + enddo + + do k=1,km+1 + k1 = km - k + 2 + do i=1,npt + ii = ipt(i) + pint(i,k) = pint1(ii,k1) + taugwci(i,k) = zero + bruni(i,k) = zero + rhoi(i,k) = zero + ti(i,k) = zero + basicui(i,k) = zero + riloc(i,k) = zero + rimin(i,k) = zero + enddo + enddo + do k=2,km+1 + do i=1,npt + plnint(i,k) = log(pint(i,k)) + enddo + enddo + + do i = 1, npt + ii = ipt(i) + kcldtop(i) = km - ktop(ii) + 1 + kcldbot(i) = km - kbot(ii) + 1 + dlen(i) = dlength(ii) +! (g*qmax(ii)*cldf(ii)*dlength(ii)) + gqmcldlen(i) = grav*qmax(ii)*cldf(ii)*dlen(i) + enddo +! if (lprnt) write(7000,*)' ktop=',ktop(ipr),' kbot=',kbot(ipr) +! &,' kcldtop=',kcldtop(npr),' kcldbot=',kcldbot(npr), +! &' dlength=',dlength(ipr),' qmax=',qmax(ipr),' cldf=',cldf(ipr) + +! if (lprnt) then +! if (fhour.ge.fhourpr) then +! write(*,9200) +! do i=1,im +! write(*,9201) kcnv(i),kcldbot(i),kcldtop(i) +! enddo +! endif +! endif + +!9200 format(//,' Inside GWDC local variables start print',//, +! +2x,'kcnv',2x,'KCLDBOT',2x,'KCLDTOP',//) +!9201 format(i4,2x,i5,4x,i5) + +!*********************************************************************** + +! pi = 2.*asin(1.) + +!----------------------------------------------------------------------- +! +! PRESSURE VARIABLES +! +! Interface 1 ======== pint(1) ********* +! Mid-Level 1 -------- pmid(1) dpmid(1) +! 2 ======== pint(2) dpint(2) +! 2 -------- pmid(2) dpmid(2) +! 3 ======== pint(3) dpint(3) +! 3 -------- pmid(3) dpmid(3) +! 4 ======== pint(4) dpint(4) +! 4 -------- pmid(4) dpmid(4) +! ........ +! 17 ======== pint(17) dpint(17) +! 17 -------- pmid(17) dpmid(17) +! 18 ======== pint(18) dpint(18) +! 18 -------- pmid(18) dpmid(18) +! 19 ======== pint(19) ********* +! +!----------------------------------------------------------------------- + + do i = 1, npt + tauctxl(i) = zero + tauctyl(i) = zero + +!----------------------------------------------------------------------- +! THERMAL VARIABLES +! +! Interface 1 ======== TI(1) RHOI(1) BRUNI(1) +! 1 -------- T(1) RHOM(1) BRUNM(1) +! 2 ======== TI(2) RHOI(2) BRUNI(2) +! 2 -------- T(2) RHOM(2) BRUNM(2) +! 3 ======== TI(3) RHOI(3) BRUNI(3) +! 3 -------- T(3) RHOM(3) BRUNM(3) +! 4 ======== TI(4) RHOI(4) BRUNI(4) +! 4 -------- T(4) RHOM(4) BRUNM(4) +! ........ +! 17 ======== +! 17 -------- T(17) RHOM(17) BRUNM(17) +! 18 ======== TI(18) RHOI(18) BRUNI(18) +! 18 -------- T(18) RHOM(18) BRUNM(18) +! 19 ======== TI(19) RHOI(19) BRUNI(19) +! + +! +!> - The top interface temperature, density, and Brunt-Vaisala +!! frequencies (\f$N\f$) are calculated assuming an isothermal +!! atmosphere above the top mid level. + + ti(i,1) = t(i,1) + rhoi(i,1) = pint(i,1)/(rd*ti(i,1)) + bruni(i,1) = sqrt ( gsqr / (cp*ti(i,1)) ) +! +!> - The bottom interface temperature, density, and Brunt-Vaisala +!! frequencies (\f$N\f$) are calculated assuming an isothermal +!! atmosphere below the bottom mid level. + + ti(i,km+1) = t(i,km) + rhoi(i,km+1) = pint(i,km+1)/(rd*ti(i,km+1)*(1.0+fv*spfh(i,km))) + bruni(i,km+1) = sqrt ( gsqr / (cp*ti(i,km+1)) ) + enddo + +!----------------------------------------------------------------------- +! +!> - The interface level temperature, density, and Brunt-Vaisala +!! frequencies (\f$N\f$) are calculated based on linear interpolation +!! of temperature in ln(P). +! +!----------------------------------------------------------------------- + + do k = 2, km + do i = 1, npt + tem1 = (plnmid(i,k)-plnint(i,k)) / (plnmid(i,k)-plnmid(i,k-1)) + tem2 = one - tem1 + ti(i,k) = t(i,k-1) * tem1 + t(i,k) * tem2 + qtem = spfh(i,k-1) * tem1 + spfh(i,k) * tem2 + rhoi(i,k) = pint(i,k) / ( rd * ti(i,k)*(1.0+fv*qtem) ) + dtdp = (t(i,k)-t(i,k-1)) / (pmid(i,k)-pmid(i,k-1)) + n2 = gsqr / ti(i,k) * ( 1./cp - rhoi(i,k)*dtdp ) + bruni(i,k) = sqrt (max (n2min, n2)) + enddo + enddo + + deallocate (spfh) +!----------------------------------------------------------------------- +! +!> - The mid-level Brunt-Vaisala frequencies (\f$N\f$) are calculated +!! based on interpolated interface temperatures. +!----------------------------------------------------------------------- + + do k = 1, km + do i = 1, npt + dtdp = (ti(i,k+1)-ti(i,k)) / (pint(i,k+1)-pint(i,k)) + n2 = gsqr / t(i,k) * ( 1./cp - rhom(i,k)*dtdp ) + brunm(i,k) = sqrt (max (n2min, n2)) + enddo + enddo + +!----------------------------------------------------------------------- +! PRINTOUT +!----------------------------------------------------------------------- + +! if (lprnt) then +! if (fhour.ge.fhourpr) then + +!-------- Pressure levels ---------- +! write(*,9101) +! do ilev=1,km +! write(*,9111) ilev,(0.01*pint(ipr,ilev)), +! & (0.01*dpint(ipr,ilev)),plnint(ipr,ilev) +! write(*,9121) ilev,(0.01*pmid(ipr,ilev)), +! & (0.01*dpmid(ipr,ilev)),plnmid(ipr,ilev) +! enddo +! ilev=km+1 +! write(*,9111) ilev,(0.01*pint(ipr,ilev)), +! & (0.01*dpint(ipr,ilev)),plnint(ipr,ilev) + +! 2 +!-------- U V T N ---------- +! write(*,9102) +! do ilev=1,km +! write(*,9112) ilev,ti(ipr,ilev),(100.*bruni(ipr,ilev)) +! write(*,9122) ilev,u(ipr,ilev),v(ipr,ilev), +! + t(ipr,ilev),(100.*brunm(ipr,ilev)) +! enddo +! ilev=km+1 +! write(*,9112) ilev,ti(ipr,ilev),(100.*bruni(ipr,ilev)) + +! endif +! endif + +!9101 format(//,14x,'PRESSURE LEVELS',//, +! +' ILEV',4x,'PINT',4x,'PMID',4x,'DPINT',3x,'DPMID',5x,'LNP',/) +!9111 format(i4,1x,f8.2,9x,f8.2,9x,f8.2) +!9121 format(i4,9x,f8.2,9x,f8.2,1x,f8.2) +!9102 format(//' ILEV',5x,'U',7x,'V',5x,'TI',7x,'T', +! +5x,'BRUNI',3x,'BRUNM',//) +!9112 format(i4,16x,f8.2,8x,f8.3) +!9122 format(i4,2f8.2,8x,f8.2,8x,f8.3) + + +!*********************************************************************** +! +! Big loop over grid points ONLY done if kcnv=1 +! +!*********************************************************************** + + kcldm = 1 + do i = 1, npt + kk = kcldtop(i) + kb = kcldbot(i) + kcldm = max(kcldm,kk) + +!----------------------------------------------------------------------- +! +!> -# Calculate the cloud top wind components and speed. +!! Here, ucltop, vcltop, and windcltop are wind components and +!! wind speed at mid-level cloud top index +! +!----------------------------------------------------------------------- + + ucltop(i) = u(i,kk) + vcltop(i) = v(i,kk) +! windcltop = sqrt( ucltop(i)*ucltop(i) + vcltop(i)*vcltop(i) ) + windcltop = 1.0 / sqrt( ucltop(i)*ucltop(i) + & + vcltop(i)*vcltop(i) ) + cosphi(i) = ucltop(i)*windcltop + sinphi(i) = vcltop(i)*windcltop +! angle(i) = acos(cosphi)*180./pi + enddo + +!----------------------------------------------------------------------- +! +!> -# Calculate the basic state wind projected in the direction of the +!! cloud top wind at mid level and interface level (U, UI), where: +!! \n U : Basic-wind speed profile. Basic-wind is parallel to the wind +!! vector at the cloud top level. (mid level) +!! \n UI: Basic-wind speed profile. Basic-wind is parallel to the wind +!! vector at the cloud top level. ( interface level ) +! Input u(i,k) and v(i,k) is defined at mid level +! +!----------------------------------------------------------------------- + + do k=1,km + do i=1,npt + basicum(i,k) = u(i,k)*cosphi(i) + v(i,k)*sinphi(i) + enddo + enddo + +!----------------------------------------------------------------------- +! +! Basic state wind at interface level is also calculated +! based on linear interpolation in ln(Pressure) +! +! In the top and bottom boundaries, basic-state wind at interface level +! is assumed to be vertically uniform. +! +!----------------------------------------------------------------------- + + do i=1,npt + basicui(i,1) = basicum(i,1) + basicui(i,km+1) = basicum(i,km) + enddo + do k=2,km + do i=1,npt + tem1 = (plnmid(i,k)-plnint(i,k)) / (plnmid(i,k)-plnmid(i,k-1)) + tem2 = one - tem1 + basicui(i,k) = basicum(i,k)*tem2 + basicum(i,k-1)*tem1 + enddo + enddo + +!----------------------------------------------------------------------- +! +!> -# Calculate the local Richardson number +!! \f[ +!! Ri=N^2/\eta^2 +!! \f] +!! where \f$\eta\f$ is the vertical shear (\f$dU/dz\f$). + +! basicum : U at mid level +! basicui : UI at interface level +! +! Interface 1 ======== UI(1) rhoi(1) bruni(1) riloc(1) +! Mid-level 1 -------- U(1) +! 2 ======== UI(2) dpint(2) rhoi(2) bruni(2) riloc(2) +! 2 -------- U(2) +! 3 ======== UI(3) dpint(3) rhoi(3) bruni(3) riloc(3) +! 3 -------- U(3) +! 4 ======== UI(4) dpint(4) rhoi(4) bruni(4) riloc(4) +! 4 -------- U(4) +! ........ +! 17 ======== UI(17) dpint(17) rhoi(17) bruni(17) riloc(17) +! 17 -------- U(17) +! 18 ======== UI(18) dpint(18) rhoi(18) bruni(18) riloc(18) +! 18 -------- U(18) +! 19 ======== UI(19) rhoi(19) bruni(19) riloc(19) +! +!----------------------------------------------------------------------- + + do k=2,km + do i=1,npt + shear = grav*rhoi(i,k) * (basicum(i,k) - basicum(i,k-1)) + & / (pmid(i,k) - pmid(i,k-1)) + if ( abs(shear) < shmin ) then + riloc(i,k) = rimax + else + tem = bruni(i,k) / shear + riloc(i,k) = tem * tem + if (riloc(i,k) >= rimax ) riloc(i,k) = rilarge + end if + enddo + enddo + + do i=1,npt + riloc(i,1) = riloc(i,2) + riloc(i,km+1) = riloc(i,km) + enddo + +! if (lprnt.and.(i.eq.ipr)) then +! if (fhour.ge.fhourpr) then +! write(*,9104) ucltop,vcltop,windcltop,angle,kk +! do ilev=1,km +! write(*,9114) ilev,basicui(ipr,ilev),dpint(ipr,ilev), +! + rhoi(ipr,ilev),(100.*bruni(ipr,ilev)),riloc(ilev) +! write(*,9124) ilev,(basicum(ipr,ilev)) +! enddo +! ilev=km+1 +! write(*,9114) ilev,basicui(ipr,ilev),dpint(ipr,ilev), +! + rhoi(ipr,ilev),(100.*bruni(ipr,ilev)),riloc(ilev) +! endif +! endif + +!9104 format(//,'WIND VECTOR AT CLOUDTOP = (',f6.2,' , ',f6.2,' ) = ', +! +f6.2,' IN DIRECTION ',f6.2,4x,'KK = ',i2,//, +! +' ILEV',2x,'BASICUM',2x,'BASICUI',4x,'DPINT',6x,'RHOI',5x, +! +'BRUNI',6x,'RI',/) +!9114 format(i4,10x,f8.2,4(2x,f8.2)) +!9124 format(i4,1x,f8.2) + +!----------------------------------------------------------------------- +! +!> -# Calculate the gravity wave stress at the interface level cloud top. +! +! kcldtopi : The interface level cloud top index +! kcldtop : The midlevel cloud top index +! kcldbot : The midlevel cloud bottom index +! +! A : Find deep convective heating rate maximum +! +! If kcldtop(i) is less than kcldbot(i) in a horizontal grid point, +! it can be thought that there is deep convective cloud. However, +! deep convective heating between kcldbot and kcldtop is sometimes +! zero in spite of kcldtop less than kcldbot. In this case, +! maximum deep convective heating is assumed to be 1.e-30. +! +! B : kk is the vertical index for interface level cloud top +! +! C : Total convective fractional cover (cldf) is used as the +! convective cloud cover for GWDC calculation instead of +! convective cloud cover in each layer (concld). +! a1 = cldf*dlength +! You can see the difference between cldf(i) and concld(i) +! in (4.a.2) in Description of the NCAR Community Climate +! Model (CCM3). +! In NCAR CCM3, cloud fractional cover in each layer in a deep +! cumulus convection is determined assuming total convective +! cloud cover is randomly overlapped in each layer in the +! cumulus convection. +! +! D : Wave stress at cloud top is calculated when the atmosphere +! is dynamically stable at the cloud top +! +! E : Cloud top wave stress and nonlinear parameter are calculated +! using density, temperature, and wind that are defined at mid +! level just below the interface level in which cloud top wave +! stress is defined. +! Nonlinct is defined at the interface level. +! +! F : If the atmosphere is dynamically unstable at the cloud top, +! GWDC calculation in current horizontal grid is skipped. +! +! G : If mean wind at the cloud top is less than zero, GWDC + +!> - Wave stress at cloud top is calculated when the atmosphere +!! is dynamically stable at the cloud top +!! +!> - The cloud top wave stress and nonlinear parameter are calculated +!! using density, temperature, and wind that are defined at mid +!! level just below the interface level in which cloud top wave +!! stress is defined. +!! The parameter \f$\mu\f$ is the nonlinearity factor of thermally +!! induced internal gravity waves defined by eq.(17) in Chun and +!! Baik, 1998 \cite chun_and_baik_1998 +!! \f[ +!! \mu=\frac{gQ_{0}a_{1}}{c_{p}T_{0}NU^{2}} +!! \f] +!! where \f$Q_{0}\f$ is the maximum deep convective heating rate in a +!! horizontal grid point calculated from cumulus parameterization. +!! \f$a_{1}\f$ is the half-width of +!! the forcing function.\f$g\f$ is gravity. \f$c_{p}\f$ is specific +!! heat at constant pressure. \f$T_{0}\f$ is the layer mean +!! temperature (T1). As eqs.(18) and (19) \cite chun_and_baik_1998, +!! the zonal momentum flux is given by +!! \f[ +!! \tau_{x}=-[\rho U^{3}/(N\triangle x)]G(\mu) +!! \f] +!! where +!! \f[ +!! G(\mu)=c_{1}c_2^2 \mu^{2} +!! \f] +!! wher \f$\rho\f$ is the local density. +!! The tunable parameter \f$c_1\f$ is related to the horizontal +!! structure of thermal forcing. The tunable parameter \f$c_2\f$ is +!! related to the basic-state wind and stability and the bottom and +!! top heights of thermal forcing. If the atmosphere is dynamically +!! unstable at the cloud top, the convective GWD calculation is +!! skipped at that grid point. +!! +! - If mean wind at the cloud top is less than zero, GWDC +! calculation in current horizontal grid is skipped. +! + +!> - The stress is capped at tauctmax = - 5\f$n/m^2\f$ +!! in order to prevent numerical instability. +! +!----------------------------------------------------------------------- +!D + do i=1,npt + kk = kcldtop(i) + if ( abs(basicui(i,kk)) > zero .and. riloc(i,kk) > ricrit) then +!E + tem = basicum(i,kk) + tem1 = tem * tem + nonlinct = gqmcldlen(i) / (bruni(i,kk)*t(i,kk)*tem1) ! Mu + tem2 = c2*nonlinct +! RhoU^3c1(c2mu)^2/Ndx + tauct = - rhom(i,kk) * tem * tem1 * c1 * tem2 * tem2 + & / (bruni(i,kk)*dlen(i)) + + tauct = max(tauctmax, tauct) + tauctxl(i) = tauct * cosphi(i) ! X stress at cloud top + tauctyl(i) = tauct * sinphi(i) ! Y stress at cloud top + taugwci(i,kk) = tauct ! *1 + do_gwc(i) = .true. + else +!F + tauctxl(i) = zero + tauctyl(i) = zero + do_gwc(i) = .false. + end if +!H + enddo + +! if (lprnt.and.(i.eq.ipr)) then +! if (fhour.ge.fhourpr) then +! write(*,9210) tauctx(ipr),taucty(ipr),tauct(ipr),angle,kk +! endif +! endif + +!9210 format(/,5x,'STRESS VECTOR = ( ',f8.3,' , ',f8.3,' ) = ',f8.3, +! +' IN DIRECTION ',f6.2,4x,'KK = ',i2,/) + +!----------------------------------------------------------------------- +! +! At this point, mean wind at the cloud top is larger than zero and +! local RI at the cloud top is larger than ricrit (=0.25) +! +! Calculate minimum of Richardson number including both basic-state +! condition and wave effects. +! +! g*Q_0*alpha*dx RI_loc*(1 - mu*|c2|) +! mu = ---------------- RI_min = ----------------------------- +! c_p*N*T*U^2 (1 + mu*RI_loc^(0.5)*|c2|)^2 +! +! Minimum RI is calculated for the following two cases +! +! (1) RIloc < 1.e+20 +! (2) Riloc = 1.e+20 ----> Vertically uniform basic-state wind +! +! RIloc cannot be smaller than zero because N^2 becomes 1.E-32 in the +! case of N^2 < 0.. Thus the sign of RINUM is determined by +! 1 - nonlin*|c2|. +! +!----------------------------------------------------------------------- +!> -# Calculate the minimum Richardson number including both the +!! basic-state condition and wave effects. +!!\f[ +!! Ri_{min}\approx\frac{Ri(1-\mu|c_{2}|)}{(1+\mu Ri^{1/2}|c_{2}|)^{2}} +!!\f] + + do k=kcldm,1,-1 + + do i=1,npt + if (do_gwc(i)) then + kk = kcldtop(i) + if (k > kk) cycle + if ( k /= 1 ) then + tem1 = (u(i,k)+u(i,k-1))*0.5 + tem2 = (v(i,k)+v(i,k-1))*0.5 + crit1 = ucltop(i)*tem1 + crit2 = vcltop(i)*tem2 + velco(i,k) = tem1 * cosphi(i) + tem2 * sinphi(i) + else + crit1 = ucltop(i)*u(i,1) + crit2 = vcltop(i)*v(i,1) + velco(i,1) = u(i,1) * cosphi(i) + v(i,1) * sinphi(i) + end if +! if (lprnt .and. i == npr) write(7000,*)' k=',k,' crit1=', +! &crit1,' crit2=',crit2,' basicui=',basicui(i,k) + + if ( abs(basicui(i,k)) > zero .and. crit1 > zero + & .and. crit2 > zero ) then + tem = basicui(i,k) * basicui(i,k) + nonlin = gqmcldlen(i) / (bruni(i,k)*ti(i,k)*tem) + tem = nonlin*abs(c2) + if ( riloc(i,k) < rimaxm ) then + tem1 = 1 + tem*sqrt(riloc(i,k)) + rimin(i,k) = riloc(i,k) * (1-tem) / (tem1*tem1) + else if((riloc(i,k) > rimaxm) .and. + & (riloc(i,k) < rimaxp)) then + rimin(i,k) = ( 1 - tem) / (tem*tem) + end if + if ( rimin(i,k) <= riminx ) then + rimin(i,k) = rismall + end if + else + rimin(i,k) = riminx + end if +! if (lprnt .and. i == npr) write(7000,*)' rimin=',rimin(i,k) + +!----------------------------------------------------------------------- +! +! If the minimum \f$R_{i}\f$ at interface cloud top is less than or equal to 1/4, +! the convective GWD calculation is skipped at that grid point. +! +!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +! +!> -# Calculate the gravity wave stress profile using the wave +!! saturation hypothesis of Lindzen (1981) \cite lindzen_1981. +! +! Assuming kcldtop(i)=10 and kcldbot=16, +! +! TAUGWCI RIloc RImin UTGWC +! +! Interface 1 ======== - 0.001 -1.e20 +! 1 -------- 0.000 +! 2 ======== - 0.001 -1.e20 +! 2 -------- 0.000 +! 3 ======== - 0.001 -1.e20 +! 3 -------- -.xxx +! 4 ======== - 0.001 2.600 2.000 +! 4 -------- 0.000 +! 5 ======== - 0.001 2.500 2.000 +! 5 -------- 0.000 +! 6 ======== - 0.001 1.500 0.110 +! 6 -------- +.xxx +! 7 ======== - 0.005 2.000 3.000 +! 7 -------- 0.000 +! 8 ======== - 0.005 1.000 0.222 +! 8 -------- +.xxx +! 9 ======== - 0.010 1.000 2.000 +! 9 -------- 0.000 +! kcldtopi 10 ======== $$$ - 0.010 +! kcldtop 10 -------- $$$ yyyyy +! 11 ======== $$$ 0 +! 11 -------- $$$ +! 12 ======== $$$ 0 +! 12 -------- $$$ +! 13 ======== $$$ 0 +! 13 -------- $$$ +! 14 ======== $$$ 0 +! 14 -------- $$$ +! 15 ======== $$$ 0 +! 15 -------- $$$ +! 16 ======== $$$ 0 +! kcldbot 16 -------- $$$ +! 17 ======== 0 +! 17 -------- +! 18 ======== 0 +! 18 -------- +! 19 ======== 0 +! +!----------------------------------------------------------------------- +! +! Even though the cloud top level obtained in deep convective para- +! meterization is defined in mid-level, the cloud top level for +! the GWDC calculation is assumed to be the interface level just +! above the mid-level cloud top vertical level index. +! +!----------------------------------------------------------------------- + +!> - When \f$Ri_{min}\f$ is set to 1/4 based on Lindzen's (1981) +!! \cite lindzen_1981 saturation hypothesis, the nonlinearity factor +!! for wave saturation can be derived by +!! \f[ +!! \mu_{s}=\frac{1}{|c_{2}|}[2\sqrt{2+\frac{1}{\sqrt{Ri}}}-(2+\frac{1}{\sqrt{Ri}})] +!! \f] +!! Then the saturation zonal momentum flux is given by +!! \f[ +!! \tau_{s}=-[\rho U^{3}/(N\triangle x)]c_{1}c_2^2\mu_s^2 +!! \f] + + if (k < kk .and. k > 1) then + if ( abs(taugwci(i,k+1)) > taumin ) then ! TAUGWCI + if ( riloc(i,k) > ricrit ) then ! RIloc + if ( rimin(i,k) > ricrit ) then ! RImin + taugwci(i,k) = taugwci(i,k+1) + elseif (rimin(i,k) > riminp) then + tem = 2.0 + 1.0 / sqrt(riloc(i,k)) + nonlins = (1.0/abs(c2)) * (2.*sqrt(tem) - tem) + tem1 = basicui(i,k) + tem2 = c2*nonlins*tem1 + taugwci(i,k) = - rhoi(i,k) * c1 * tem1 * tem2 * tem2 + & / (bruni(i,k)*dlen(i)) + elseif (rimin(i,k) > riminm) then + taugwci(i,k) = zero +! taugwci(i,k) = taugwci(i,k+1) + end if ! RImin + else + +!> - If the minimum \f$R_{i}\f$ at interface cloud top is less than +!! or equal to 1/4, the convective GWD calculation is skipped at that +!! grid point. + + taugwci(i,k) = zero + end if ! RIloc + else + taugwci(i,k) = zero + end if ! TAUGWCI + + if ( (basicum(i,k+1)*basicum(i,k) ) < 0. ) then + taugwci(i,k+1) = zero + taugwci(i,k) = zero + endif + + if (abs(taugwci(i,k)) > abs(taugwci(i,k+1))) then + taugwci(i,k) = taugwci(i,k+1) + end if + + elseif (k == 1) then + +!> - As an upper boundary condition, upward propagation of gravity +!! wave energy is permitted. + + taugwci(i,1) = taugwci(i,2) + endif + +! if(lprnt .and. i == npr) then +! write(7000,*)'k=',k,' taugwci=',taugwci(i,k), +! &'riloc',riloc(i,k),'riminp=',riminp,' ricrit=',ricrit +! &,'bruni(i,k)=',bruni(i,k),' deln=',bruni(i,k) +! &,'basicui(i,k)=',basicui(i,k),' rimin=',rimin(i,k) +! &,' dlen=',dlen(i),' rhoi=',rhoi(i,k) +! endif + + endif + enddo ! end of i=1,npt loop + enddo ! end of k=kcldm,1,-1 loop + + do i=1,npt + dtfac(i) = 1.0 + enddo + do k=1,km + do i=1,npt + if (do_gwc(i)) then + kk = kcldtop(i) + if (k < kk) then + taugw(i,k) = (taugwci(i,k+1) - taugwci(i,k)) / dpmid(i,k) + if (taugw(i,k) /= 0.0) then + tem = deltim * taugw(i,k) + dtfac(i) = min(dtfac(i), abs(velco(i,k)/tem)) + endif + else + taugw(i,k) = 0.0 + endif + else + taugw(i,k) = 0.0 + endif + enddo + enddo + +!!!!!! Vertical differentiation +!!!!!! +!> -# Calculate wind tendency in direction to the wind vector,zonal +!! wind tendency and meridional wind tendency above the cloud top +!! level due to convectively generated gravity waves. + + do k=1,km + do i=1,npt + if (do_gwc(i)) then + kk = kcldtop(i) + if (k < kk) then +! wtgwc = (taugwci(i,k+1) - taugwci(i,k)) / dpmid(i,k) + wtgwc = taugw(i,k) * dtfac(i) + utgwcl(i,k) = wtgwc * cosphi(i) + vtgwcl(i,k) = wtgwc * sinphi(i) + else + utgwcl(i,k) = zero + vtgwcl(i,k) = zero + endif +! if(lprnt .and. i == npr) then +! write(7000,*)'k=',k,' wtgwc=',wtgwc,' taugwci=',taugwci(i,k), +! &taugwci(i,k+1),' dpmid=',dpmid(i,k),' cosphi=',cosphi(i), +! & ' sinphi=',sinphi(i),' utgwcl=',utgwcl(i,k), +! &'vtgwcl=',vtgwcl(i,k),' dtfac=',dtfac(i) +! endif + endif + enddo + enddo + +!----------------------------------------------------------------------- +! +! Calculate momentum flux = stress deposited above cloup top +! Apply equal amount with opposite sign within cloud +! +!----------------------------------------------------------------------- + + do i=1,npt + xstress(i) = zero + ystress(i) = zero + enddo + do k=1,kcldm + do i=1,npt + if (do_gwc(i)) then + xstress(i) = xstress(i) + utgwcl(i,k)*dpmid(i,k) + ystress(i) = ystress(i) + vtgwcl(i,k)*dpmid(i,k) + endif + enddo + enddo + +!----------------------------------------------------------------------- +! ALT 1 ONLY UPPERMOST LAYER +!----------------------------------------------------------------------- + +! kk = kcldtop(i) +! tem1 = g / dpmid(i,kk) +! utgwc(i,kk) = - tem1 * xstress +! vtgwc(i,kk) = - tem1 * ystress + +!----------------------------------------------------------------------- +! ALT 2 SIN(KT-KB) +!----------------------------------------------------------------------- + + do i=1,npt + if (do_gwc(i)) then + wrk(i) = 0.5 * pi / (pint(i,kcldbot(i)+1)-pint(i,kcldtop(i))) + endif + enddo + do k=1,km + do i=1,npt + if (do_gwc(i)) then + kk = kcldtop(i) + if (k >= kk .and. k <= kcldbot(i)) then + p1 = sin(wrk(i) * (pint(i,k) -pint(i,kk))) + p2 = sin(wrk(i) * (pint(i,k+1)-pint(i,kk))) + tem = - (p2-p1) / dpmid(i,k) + utgwcl(i,k) = tem*xstress(i) + vtgwcl(i,k) = tem*ystress(i) + endif + endif + enddo + enddo + +!----------------------------------------------------------------------- +! ALT 3 FROM KT to KB PROPORTIONAL TO CONV HEATING +!----------------------------------------------------------------------- + +! do k=kcldtop(i),kcldbot(i) +! p1=cumchr(i,k) +! p2=cumchr(i,k+1) +! utgwcl(i,k) = - g*xstress*(p1-p2)/dpmid(i,k) +! enddo + +!----------------------------------------------------------------------- +! +! The GWDC should accelerate the zonal and meridional wind in the +! opposite direction of the previous zonal and meridional wind, +! respectively +! +!----------------------------------------------------------------------- + +! do k=1,kcldtop(i)-1 + +! if (utgwcl(i,k)*u(i,k) .gt. 0.0) then + +!-------------------- x-component------------------- + +! write(6,'(a)') +! + '(GWDC) WARNING: The GWDC should accelerate the zonal wind ' +! write(6,'(a,a,i3,a,i3)') +! + 'in the opposite direction of the previous zonal wind', +! + ' at I = ',i,' and J = ',lat +! write(6,'(4(1x,e17.10))') u(i,kk),v(i,kk),u(i,k),v(i,k) +! write(6,'(a,1x,e17.10))') 'Vcld . V =', +! + u(i,kk)*u(i,k)+v(i,kk)*v(i,k) + +! if(u(i,kcldtop(i))*u(i,k)+v(i,kcldtop(i))*v(i,k).gt.0.0)then +! do k1=1,km +! write(6,'(i2,36x,2(1x,e17.10))') +! + k1,taugwcxi(i,k1),taugwci(i,k1) +! write(6,'(i2,2(1x,e17.10))') k1,utgwcl(i,k1),u(i,k1) +! end do +! write(6,'(i2,36x,1x,e17.10)') (km+1),taugwcxi(i,km+1) +! end if + +!-------------------- Along wind at cloud top ----- + +! do k1=1,km +! write(6,'(i2,36x,2(1x,e17.10))') +! + k1,taugwci(i,k1) +! write(6,'(i2,2(1x,e17.10))') k1,wtgwc(i,k1),basicum(i,k1) +! end do +! write(6,'(i2,36x,1x,e17.10)') (km+1),taugwci(i,km+1) + +! end if + +! if (vtgwc(i,k)*v(i,k) .gt. 0.0) then +! write(6,'(a)') +! + '(GWDC) WARNING: The GWDC should accelerate the meridional wind' +! write(6,'(a,a,i3,a,i3)') +! + 'in the opposite direction of the previous meridional wind', +! + ' at I = ',i,' and J = ',lat +! write(6,'(4(1x,e17.10))') u(i,kcldtop(i)),v(i,kcldtop(i)), +! + u(i,k),v(i,k) +! write(6,'(a,1x,e17.10))') 'Vcld . V =', +! + u(i,kcldtop(i))*u(i,k)+v(i,kcldtop(i))*v(i,k) +! if(u(i,kcldtop(i))*u(i,k)+v(i,kcldtop(i))*v(i,k).gt.0.0)then +! do k1=1,km +! write(6,'(i2,36x,2(1x,e17.10))') +! + k1,taugwcyi(i,k1),taugwci(i,k1) +! write(6,'(i2,2(1x,e17.10))') k1,vtgwc(i,k1),v(i,k1) +! end do +! write(6,'(i2,36x,1x,e17.10)') (km+1),taugwcyi(i,km+1) +! end if +! end if + +! enddo + +!1000 continue + + +!*********************************************************************** + +! if (lprnt) then +! if (fhour.ge.fhourpr) then +!-------- UTGWC VTGWC ---------- +! write(*,9220) +! do ilev=1,km +! write(*,9221) ilev,(86400.*utgwcl(ipr,ilev)), +! + (86400.*vtgwcl(ipr,ilev)) +! enddo +! endif +! endif + +!9220 format(//,14x,'TENDENCY DUE TO GWDC',//, +! +' ILEV',6x,'UTGWC',7x,'VTGWC',/) +!9221 format(i4,2(2x,f10.3)) + +!----------------------------------------------------------------------- +! +! For GWDC performance analysis +! +!----------------------------------------------------------------------- + +! do k = 1, kk-1 +! do i = 1, nct + +! kk = kcldtop(i) + +! if ( (abs(taugwci(i,kk)) > taumin) ) then + +! gwdcloc(i) = one + +! if ( abs(taugwci(i,k)-taugwci(i,kk)) > taumin ) then +! break(i) = 1.0 +! go to 2000 +! endif +! enddo +!2000 continue + +! do k = 1, kk-1 + +! if ( ( abs(taugwci(i,k)).lt.taumin ) .and. +! & ( abs(taugwci(i,k+1)).gt.taumin ) .and. +! & ( basicum(i,k+1)*basicum(i,k) .lt. 0. ) ) then +! critic(i) = 1.0 +! print *,i,k,' inside GWDC taugwci(k) = ',taugwci(i,k) +! print *,i,k+1,' inside GWDC taugwci(k+1) = ',taugwci(i,k+1) +! print *,i,k,' inside GWDC basicum(k) = ',basicum(i,k) +! print *,i,k+1,' inside GWDC basicum(k+1) = ',basicum(i,k+1) +! print *,i,' inside GWDC critic = ',critic(i) +! goto 2010 +! endif +! enddo +!2010 continue + +! endif + +! enddo + +!----------------------------------------------------------------------- +!> -# Convert back local convective GWD tendency arrays to GFS model +!! vertical indices. +! Outgoing (FU1,FV1)=(utgwc,vtgwc) +!----------------------------------------------------------------------- + + do k=1,km + k1 = km - k + 1 + do i=1,npt + ii = ipt(i) + utgwc(ii,k1) = utgwcl(i,k) + + vtgwc(ii,k1) = vtgwcl(i,k) + +! brunm(ii,kk) = brunm(i,k) +! brunm(i,k) = tem + +! rhom(ii,kk) = rhom(i,k) + + enddo +! if (lprnt) write(7000,*)' k=',k,' k1=',k1,' utgwc=' +! &, utgwc(ipr,k1),' vtgwc=',vtgwc(ipr,k1) + enddo + do i=1,npt + ii = ipt(i) + tauctx(ii) = tauctxl(i) + taucty(ii) = tauctyl(i) + enddo + +! if (lprnt) then +! if (fhour.ge.fhourpr) then +!-------- UTGWC VTGWC ---------- +! write(*,9225) +! do ilev=km,1,-1 +! write(*,9226) ilev,(86400.*fu1(ipr,ilev)), +! + (86400.*fv1(ipr,ilev)) +! enddo +! endif +! endif + +!9225 format(//,14x,'TENDENCY DUE TO GWDC - TO GBPHYS',//, +! +' ILEV',6x,'UTGWC',7x,'VTGWC',/) +!9226 format(i4,2(2x,f10.3)) + + deallocate (kcldtop,kcldbot,do_gwc) + deallocate (tauctxl, tauctyl, dtfac, +! & gwdcloc, break, critic, cosphi, + & gwdcloc, break, cosphi, + & sinphi, xstress, ystress, + & dlen, ucltop, vcltop, gqmcldlen, wrk) + + deallocate (plnint, taugwci, velco, + & bruni, rhoi, basicui, + & ti, riloc, rimin, pint) + + deallocate (plnmid, utgwcl, vtgwcl, basicum, u, v, t, + & pmid, dpmid, brunm, rhom, taugw) + + return + end +!> @} +!! @} diff --git a/gsmphys/gwdps.f b/gsmphys/gwdps.f new file mode 100644 index 00000000..4893b642 --- /dev/null +++ b/gsmphys/gwdps.f @@ -0,0 +1,1272 @@ +!> \file gwdps.f +!! This file is the parameterization of orographic gravity wave +!! drag and mountain blocking. + +!> \defgroup gwd Orographic and Convective Gravity Wave Drag +!! @{ +!! Parameterization developed specifically for orographic and +!! convective source of gravity waves are documented separately. +!! +!! At present, global models must be run with horizontal resolutions +!! that cannot typically resolve atmospheric phenomena shorter than +!! ~10-100 km or greater for weather prediction and ~100-1000 km or +!! greater for climate predicition. Many atmospheric processes have +!! shorter horizontal scales than these "subgrid-scale" processes +!! interact with and affect the larger-scale atmosphere in important +!! ways. +!! +!! Atmospheric gravity waves are one such unresolved processes. These +!! waves are generated by lower atmospheric sources. e.g., flow over +!! irregularities at the Earth's surface such as mountains and valleys, +!! uneven distribution of diabatic heat sources asscociated with +!! convective systems, and highly dynamic atmospheric processes such +!! as jet streams and fronts. The dissipation of these waves produces +!! synoptic-scale body forces on the atmospheric flow, known as +!! "gravity wave drag"(GWD), which affects both short-term evolution +!! of weather systems and long-term climate. However, the spatial +!! scales of these waves (in the range of ~5-500 km horizontally) are +!! too short to be fully captured in models, and so GWD must be +!! parameterized. In addition, the role of GWD in driving the global +!! middle atmosphere circulation and thus global mean wind/temperature +!! structures is well established. Thus, GWD parametrizations are now +!! critical components of virtually all large-scale atmospheric models. +!! GFS physics includes parameterizations of gravity waves from two +!! important sources: mountains and convection. +!! +!! Atmospheric flow is significantly influenced by orography creating +!! lift and frictional forces. The representation of orography and its +!! influence in numerical weather prediction models are necessarily +!! divided into the resolvable scales of motion and treated by +!! primitive equations, the remaining sub-grid scales to be treated by +!! parameterization. In terms of large scale NWP models, mountain +!! blocking of wind flow around sub-grid scale orograph is a process +!! that retards motion at various model vertical levels near or in the +!! boundary layer. Flow around the mountain encounters larger +!! frictional forces by being in contact with the mountain surfaces +!! for longer time as well as the interaction of the atmospheric +!! environment with vortex shedding which occurs in numerous +!! observations. Lott and Miller (1997) \cite lott_and_miller_1997, +!! incorporated the dividing streamline and mountain blocking in +!! conjunction with sub-grid scale vertically propagating gravity wave +!! parameterization in the context of NWP. The dividing streamline is +!! seen as a source of gravity waves to the atmosphere above and +!! nonlinear subgrid low-level mountain drag effect below. +!! +!! In a review paper on gravity waves in the middle atmosphere, Fritts +!! (1984) \cite fritts_1984 showed that a large portion of observed +!! gravity wave momentum flux has higher frequencies than those of +!! stationary mountain waves. This phenomenon was explained by cumulus +!! convection, which is an additional source of tropospheric gravity +!! waves, and is particularly important in summertime. When the surface +!! wind and stability are weak, the magnitude of the surface drag and +!! the resultant influence of orographically-induced gravity wave drag +!! on the large-scale flow are relatively small compared with those in +!! wintertime (Palmer et al. 1986 \cite palmer_et_al_1986). In this +!! situation, the relative importance of cumulus convection as a source +!! of gravity waves is larger. In addition, in the tropical regions +!! where persistent convection exists, deep cumulus clouds impinging on +!! the stable stratosphere can generate gravity waves that influence +!! the large-scale flow. +!! +!> \section outlines GWD parameterization in GFS +!! - Gravity-wave drag is simulated as described by Alpert et al. +!! (1988) \cite alpert_et_al_1988. The parameterization includes +!! determination of the momentum flux due to gravity waves at the +!! surface, as well as upper levels. The surface stress is a nonlinear +!! function of the surface wind speed and the local Froude number, +!! following Pierrehumbert (1987) \cite pierrehumbert_1987. Vertical +!! variations in the momentum flux occur when the local Richardson +!! number is less than 0.25 (the stress vanishes), or when wave +!! breaking occurs (local Froude number becomes critical); in the +!! latter case, the momentum flux is reduced according to the +!! Lindzen(1981) \cite lindzen_1981 wave saturation hypothesis. +!! Modifications are made to avoid instability when the critical layer +!! is near the surface, since the time scale for gravity-wave drag is +!! shorter than the model time step. +!! +!! - The treatment of the GWD in the lower troposphere is enhanced +!! according to Kim and Arakawa (1995) \cite kim_and_arakawa_1995 . +!! Orographic Std Dev (HPRIME), Convexity(OC), Asymmetry (OA4) and Lx +!! (CLX4) are input topographic statistics needed (see Appendix in Kim +!! and Arakawa (1995) \cite kim_and_arakawa_1995) . +!! +!! - Mountain blocking influences are incorporated following the Lott +!! and Miller (1997) \cite lott_and_miller_1997 parameterization with +!! minor changes, including their dividing streamline concept. The +!! model subgrid scale orography is represented by four parameters, +!! after Baines and Palmer (1990) \cite baines_and_palmer_1990, the +!! standard deviation (HPRIME), the anisotropy (GAMMA), the slope +!! (SIGMA) and the geographical orientation of the orography (THETA). +!! These are calculated off-line as a function of model resolution in +!! the fortran code ml01rg2.f, with script mlb2.sh (see Appendix: +!! Specification of subgrid-scale orography in Lott and Miller (1997) +!! \cite lott_and_miller_1997). +!! +!! - The orographic GWD parameterizations automatically scales +!! with model resolution. For example, the T574L64 version of GFS uses +!! four times stronger mountain blocking and one half the strength of +!! gravity wave drag than the T383L64 version. +!! +!! - The parameterization of stationary convectively-forced GWD follows +!! the development of Chun and Baik (1998) \cite chun_and_baik_1998 , +!! which was tested in GCMs by Chun et al. (2001,2004) +!! \cite chun_et_al_2001 \cite chun_et_al_2004 was implemented in GFS +!! by Ake Johansson (2008) and the work of the GCWMB staff. Modest +!! positive effects from using the parameterization are seen in the +!! tropical upper troposphere and lower stratosphere. +!! +!!\section intra_gwdps Intraphysics Communication +!! - Routine GWDPS (\ref orographic) is called from GBPHYS after call +!! to MONINEDMF +!! - Routine GWDC (\ref convective) is called from GBPHYS after call +!! to SASCNVN + +!> \ingroup gwd +!> \defgroup orographic Orographic Gravity Wave Drag and Mountain Blocking +!! This subroutine includes orographic gravity wave drag and mountain +!! blocking. +!! +!> The time tendencies of zonal and meridional wind are altered to +!! include the effect of mountain induced gravity wave drag from +!! subgrid scale orography including convective breaking, shear +!! breaking and the presence of critical levels. +!! @{ + +!> \param[in] IM horizontal number of used pts +!> \param[in] IX horizontal dimension +!> \param[in] IY horizontal number of used pts +!> \param[in] KM vertical layer dimension +!> \param[in,out] A non-linear tendency for v wind component +!> \param[in,out] B non-linear tendency for u wind component +!> \param[in,out] C non-linear tendency for temperature (not used) +!> \param[in] U1 zonal wind component of model layer wind (m/s) +!> \param[in] V1 meridional wind component of model layer wind +!! (m/s) +!> \param[in] T1 model layer mean temperature (K) +!> \param[in] Q1 model layer mean specific humidity +!> \param[in] KPBL index for the PBL top layer +!> \param[in] PRSI pressure at layer interfaces +!> \param[in] DEL positive increment of p/psfc across layer +!> \param[in] PRSL mean layer pressure +!> \param[in] PRSLK Exner function at layer +!> \param[in] PHII interface geopotential (\f$m^2/s^2\f$) +!> \param[in] PHIL layer geopotential (\f$m^2/s^2\f$) +!> \param[in] DELTIM physics time step in seconds +!> \param[in] KDT number of the current time step +!> \param[in] HPRIME orographic standard deviation (m) (mtnvar(:,1)) +!> \param[in] OC orographic Convexity (mtnvar(:,2)) +!> \param[in] OA4 orographic Asymmetry (mtnvar(:,3:6)) +!> \param[in] CLX4 Lx, the fractional area covered by the +!! subgrid-scale orography higher than a critical height for a grid +!! box with the interval \f$ \triangle x \f$ (mtnvar(:,7:10)) +!> \param[in] THETA the angle of the mtn with that to the east (x) +!! axis (mtnvar(:,11)) +!> \param[in] SIGMA orographic slope (mtnvar(:,13)) +!> \param[in] GAMMA orographic anisotropy (mtnvar(:,12)) +!> \param[in] ELVMAX orographic maximum (mtnvar(:,14)) +!> \param[out] DUSFC u component of surface stress +!> \param[out] DVSFC v component of surface stress +!> \param[in] G see physcons::con_g +!> \param[in] CP see physcons::con_cp +!> \param[in] RD see physcons::con_tird +!> \param[in] RV see physcons::con_rv +!> \param[in] IMX number of longitude points +!> \param[in] NMTVR number of topographic variables such as +!! variance etc used in the GWD parameterization,current operational, +!! nmtvr=14 +!> \param[in] CDMBGWD multiplication factors for cdmb and gwd +!> \param[in] ME pe number - used for debug prints +!> \param[in] LPRNT logical print flag +!> \param[in] IPR check print point for debugging +!> \section gen_gwdps General Algorithm +!> @{ + SUBROUTINE GWDPS(IM,IX,IY,KM,A,B,C,U1,V1,T1,Q1,KPBL, & + & PRSI,DEL,PRSL,PRSLK,PHII, PHIL,DELTIM,KDT, & + & HPRIME,OC,OA4,CLX4,THETA,SIGMA,GAMMA,ELVMAX, & + & DUSFC,DVSFC,G, CP, RD, RV, IMX, & + & nmtvr, cdmbgwd, me, lprnt, ipr, p_crit, RDXZB) +! +! ******************************************************************** +! -----> I M P L E M E N T A T I O N V E R S I O N <---------- +! +! --- Not in this code -- History of GWDP at NCEP---- +! ---------------- ----------------------- +! VERSION 3 MODIFIED FOR GRAVITY WAVES, LOCATION: .FR30(V3GWD) *J* +!--- 3.1 INCLUDES VARIABLE SATURATION FLUX PROFILE CF ISIGST +!--- 3.G INCLUDES PS COMBINED W/ PH (GLAS AND GFDL) +!----- ALSO INCLUDED IS RI SMOOTH OVER A THICK LOWER LAYER +!----- ALSO INCLUDED IS DECREASE IN DE-ACC AT TOP BY 1/2 +!----- THE NMC GWD INCORPORATING BOTH GLAS(P&S) AND GFDL(MIGWD) +!----- MOUNTAIN INDUCED GRAVITY WAVE DRAG +!----- CODE FROM .FR30(V3MONNX) FOR MONIN3 +!----- THIS VERSION (06 MAR 1987) +!----- THIS VERSION (26 APR 1987) 3.G +!----- THIS VERSION (01 MAY 1987) 3.9 +!----- CHANGE TO FORTRAN 77 (FEB 1989) --- HANN-MING HENRY JUANG +!----- 20070601 ELVMAX bug fix (*j*) +! +! VERSION 4 +! ----- This code ----- +! +!----- MODIFIED TO IMPLEMENT THE ENHANCED LOW TROPOSPHERIC GRAVITY +!----- WAVE DRAG DEVELOPED BY KIM AND ARAKAWA(JAS, 1995). +! Orographic Std Dev (hprime), Convexity (OC), Asymmetry (OA4) +! and Lx (CLX4) are input topographic statistics needed. +! +!----- PROGRAMMED AND DEBUGGED BY HONG, ALPERT AND KIM --- JAN 1996. +!----- debugged again - moorthi and iredell --- may 1998. +!----- +! Further Cleanup, optimization and modification +! - S. Moorthi May 98, March 99. +!----- modified for usgs orography data (ncep office note 424) +! and with several bugs fixed - moorthi and hong --- july 1999. +! +!----- Modified & implemented into NRL NOGAPS +! - Young-Joon Kim, July 2000 +!----- +! VERSION lm MB (6): oz fix 8/2003 +! ----- This code ----- +! +!------ Changed to include the Lott and Miller Mtn Blocking +! with some modifications by (*j*) 4/02 +! From a Principal Coordinate calculation using the +! Hi Res 8 minute orography, the Angle of the +! mtn with that to the East (x) axis is THETA, the slope +! parameter SIGMA. The anisotropy is in GAMMA - all are input +! topographic statistics needed. These are calculated off-line +! as a function of model resolution in the fortran code ml01rg2.f, +! with script mlb2.sh. (*j*) +!----- gwdps_mb.f version (following lmi) elvmax < hncrit (*j*) +! MB3a expt to enhance elvmax mtn hgt see sigfac & hncrit +! gwdps_GWDFIX_v6.f FIXGWD GF6.0 20070608 sigfac=4. +!----- +!----------------------------------------------------------------------C +! USE +! ROUTINE IS CALLED FROM GBPHYS (AFTER CALL TO MONNIN) +! +! PURPOSE +! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- +! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V +! ARE ALTERED TO INCLUDE THE EFFECT OF MOUNTAIN INDUCED +! GRAVITY WAVE DRAG FROM SUB-GRID SCALE OROGRAPHY INCLUDING +! CONVECTIVE BREAKING, SHEAR BREAKING AND THE PRESENCE OF +! CRITICAL LEVELS +! +! INPUT +! A(IY,KM) NON-LIN TENDENCY FOR V WIND COMPONENT +! B(IY,KM) NON-LIN TENDENCY FOR U WIND COMPONENT +! C(IY,KM) NON-LIN TENDENCY FOR TEMPERATURE +! U1(IX,KM) ZONAL WIND M/SEC AT T0-DT +! V1(IX,KM) MERIDIONAL WIND M/SEC AT T0-DT +! T1(IX,KM) TEMPERATURE DEG K AT T0-DT +! Q1(IX,KM) SPECIFIC HUMIDITY AT T0-DT +! +! DELTIM TIME STEP SECS +! SI(N) P/PSFC AT BASE OF LAYER N +! SL(N) P/PSFC AT MIDDLE OF LAYER N +! DEL(N) POSITIVE INCREMENT OF P/PSFC ACROSS LAYER N +! KPBL(IM) is the index of the top layer of the PBL +! ipr & lprnt for diagnostics +! +! OUTPUT +! A, B AS AUGMENTED BY TENDENCY DUE TO GWDPS +! OTHER INPUT VARIABLES UNMODIFIED. +! revision log: +! May 2013 J. Wang change cleff back to opn setting +! Jan 2014 J. Wang merge Henry and Fangin's dissipation heat in gfs to nems +! +! +! ******************************************************************** + USE MACHINE , ONLY : kind_phys + implicit none + integer im, iy, ix, km, imx, kdt, ipr, me + integer KPBL(IM) ! Index for the PBL top layer! + real(kind=kind_phys) deltim, G, CP, RD, RV, cdmbgwd(2), p_crit + real(kind=kind_phys) A(IY,KM), B(IY,KM), C(IY,KM), & + & U1(IX,KM), V1(IX,KM), T1(IX,KM), & + & Q1(IX,KM), PRSI(IX,KM+1), DEL(IX,KM), & + & PRSL(IX,KM), PRSLK(IX,KM), PHIL(IX,KM), & + & PHII(IX,KM+1), RDXZB(IY) + real(kind=kind_phys) OC(IM), OA4(IY,4), CLX4(IY,4) & + &, HPRIME(IM) +! for lm mtn blocking + real(kind=kind_phys) ELVMAX(IM),THETA(IM),SIGMA(IM),GAMMA(IM) + real(kind=kind_phys) wk(IM) + real(kind=kind_phys) bnv2lm(IM,KM),PE(IM),EK(IM),ZBK(IM),UP(IM) + real(kind=kind_phys) DB(IM,KM),ANG(IM,KM),UDS(IM,KM) + real(kind=kind_phys) ZLEN, DBTMP, R, PHIANG, CDmb, DBIM + real(kind=kind_phys) ENG0, ENG1 +! +! Some constants +! + real(kind=kind_phys) pi, dw2min, rimin, ric, bnv2min, efmin + &, efmax,hpmax,hpmin, rad_to_deg, deg_to_rad + PARAMETER (PI=3.1415926535897931) + PARAMETER (RAD_TO_DEG=180.0/PI, DEG_TO_RAD=PI/180.0) + PARAMETER (DW2MIN=1., RIMIN=-100., RIC=0.25, BNV2MIN=1.0E-5) +! PARAMETER (EFMIN=0.0, EFMAX=10.0, hpmax=200.0) + PARAMETER (EFMIN=0.0, EFMAX=10.0, hpmax=2400.0, hpmin=1.0) +! PARAMETER (P_CRIT=30.E2) +! + real(kind=kind_phys) FRC, CE, CEOFRC, frmax, CG, GMAX + &, VELEPS, FACTOP, RLOLEV, RDI +! &, CRITAC, VELEPS, FACTOP, RLOLEV, RDI + parameter (FRC=1.0, CE=0.8, CEOFRC=CE/FRC, frmax=100., CG=0.5) + parameter (GMAX=1.0, VELEPS=1.0, FACTOP=0.5) +! parameter (GMAX=1.0, CRITAC=5.0E-4, VELEPS=1.0, FACTOP=0.5) + parameter (RLOLEV=50000.0) +! parameter (RLOLEV=500.0) +! parameter (RLOLEV=0.5) +! + real(kind=kind_phys) dpmin,hminmt,hncrit,minwnd,sigfac +! --- for lm mtn blocking +! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) + parameter (hncrit=8000.) ! Max value in meters for ELVMAX (*j*) +! hncrit set to 8000m and sigfac added to enhance elvmax mtn hgt + parameter (sigfac=4.0) ! MB3a expt test for ELVMAX factor (*j*) + parameter (hminmt=50.) ! min mtn height (*j*) + parameter (minwnd=0.1) ! min wind component (*j*) + +! parameter (dpmin=00.0) ! Minimum thickness of the reference layer +!! parameter (dpmin=05.0) ! Minimum thickness of the reference layer +! parameter (dpmin=20.0) ! Minimum thickness of the reference layer + ! in centibars + parameter (dpmin=5000.0) ! Minimum thickness of the reference layer + ! in Pa +! + real(kind=kind_phys) FDIR + integer mdir + parameter(mdir=8, FDIR=mdir/(PI+PI)) + integer nwdir(mdir) + data nwdir/6,7,5,8,2,3,1,4/ + save nwdir +! + LOGICAL ICRILV(IM) +! +!---- MOUNTAIN INDUCED GRAVITY WAVE DRAG +! + real(kind=kind_phys) TAUB(IM), XN(IM), YN(IM), UBAR(IM) & + &, VBAR(IM), ULOW(IM), OA(IM), CLX(IM) & + &, ROLL(IM), ULOI(IM), DUSFC(IM), DVSFC(IM) & + &, DTFAC(IM), XLINV(IM), DELKS(IM), DELKS1(IM) +! + real(kind=kind_phys) BNV2(IM,KM), TAUP(IM,KM+1), ri_n(IM,KM) & + &, TAUD(IM,KM), RO(IM,KM), VTK(IM,KM) & + &, VTJ(IM,KM), SCOR(IM), VELCO(IM,KM-1) & + &, bnv2bar(im) +! +! real(kind=kind_phys) VELKO(KM-1) + Integer kref(IM), kint(im), iwk(im), ipt(im) +! for lm mtn blocking + Integer kreflm(IM), iwklm(im) + Integer idxzb(im), ktrial, klevm1, nmtvr +! + real(kind=kind_phys) gor, gocp, fv, gr2, bnv, fr & + &, brvf, cleff, tem, tem1, tem2, temc, temv & + &, wdir, ti, rdz, dw2, shr2, bvf2 & + &, rdelks, efact, coefm, gfobnv & + &, scork, rscor, hd, fro, rim, sira & + &, dtaux, dtauy, pkp1log, pklog + integer kmm1, kmm2, lcap, lcapp1, kbps, kbpsp1,kbpsm1 & + &, kmps, idir, nwd, i, j, k, klcap, kp1, kmpbl, npt, npr & + &, kmll +! &, kmll,kmds,ihit,jhit + logical lprnt +! +! parameter (cdmb = 1.0) ! non-dim sub grid mtn drag Amp (*j*) +! non-dim sub grid mtn drag Amp (*j*) +! cdmb = 1.0/float(IMX/192) +! cdmb = 192.0/float(IMX) + cdmb = 4.0 * 192.0/float(IMX) + if (cdmbgwd(1) >= 0.0) cdmb = cdmb * cdmbgwd(1) +! + npr = 0 + DO I = 1, IM + DUSFC(I) = 0. + DVSFC(I) = 0. + ENDDO +! + DO K = 1, KM + DO I = 1, IM + DB(I,K) = 0. + ANG(I,K) = 0. + UDS(I,K) = 0. + ENDDO + ENDDO +! + RDI = 1.0 / RD + GOR = G/RD + GR2 = G*GOR + GOCP = G/CP + FV = RV/RD - 1 +! +! NCNT = 0 + KMM1 = KM - 1 + KMM2 = KM - 2 + LCAP = KM + LCAPP1 = LCAP + 1 +! +! + IF ( NMTVR .eq. 14) then +! ---- for lm and gwd calculation points + RDXZB(:) = 0. + ipt = 0 + npt = 0 + DO I = 1,IM + IF ( (elvmax(i) .GT. HMINMT) + & .and. (hprime(i) .GT. hpmin) ) then + npt = npt + 1 + ipt(npt) = i + if (ipr .eq. i) npr = npt + ENDIF + ENDDO + IF (npt .eq. 0) RETURN ! No gwd/mb calculation done! +! +! if (lprnt) print *,' npt=',npt,' npr=',npr,' ipr=',ipr,' im=',im +! &,' ipt(npt)=',ipt(npt) +! +! --- iwklm is the level above the height of the of the mountain. +! --- idxzb is the level of the dividing streamline. +! INITIALIZE DIVIDING STREAMLINE (DS) CONTROL VECTOR +! + do i=1,npt + iwklm(i) = 2 + IDXZB(i) = 0 + kreflm(i) = 0 + enddo +! if (lprnt) +! & print *,' in gwdps_lm.f npt,IM,IX,IY,km,me=',npt,IM,IX,IY,km,me +! +! +!> --- Subgrid Mountain Blocking Section +! +!.............................. +!.............................. +! +! (*j*) 11/03: test upper limit on KMLL=km - 1 +! then do not need hncrit -- test with large hncrit first. +! KMLL = km / 2 ! maximum mtnlm height : # of vertical levels / 2 + KMLL = kmm1 +! --- No mtn should be as high as KMLL (so we do not have to start at +! --- the top of the model but could do calc for all levels). +! + DO I = 1, npt + j = ipt(i) + ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) + ENDDO +! + DO K = 1,KMLL + DO I = 1, npt + j = ipt(i) +! --- interpolate to max mtn height for index, iwklm(I) wk[gz] +! --- ELVMAX is limited to hncrit because to hi res topo30 orog. + pkp1log = phil(j,k+1) / G + pklog = phil(j,k) / G +!!!------- ELVMAX(J) = min (ELVMAX(J) + sigfac * hprime(j), hncrit) + if ( ( ELVMAX(j) .le. pkp1log ) .and. + & ( ELVMAX(j) .ge. pklog ) ) THEN +! print *,' in gwdps_lm.f 1 =',k,ELVMAX(j),pklog,pkp1log,me +! --- wk for diags but can be saved and reused. + wk(i) = G * ELVMAX(j) / ( phil(j,k+1) - phil(j,k) ) + iwklm(I) = MAX(iwklm(I), k+1 ) +! print *,' in gwdps_lm.f 2 npt=',npt,i,j,wk(i),iwklm(i),me + endif +! +! --- find at prsl levels large scale environment variables +! --- these cover all possible mtn max heights + VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) + VTK(I,K) = VTJ(I,K) / PRSLK(J,K) + RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY Kg/M**3 + ENDDO + ENDDO +! +! testing for highest model level of mountain top +! +! ihit = 2 +! jhit = 0 +! do i = 1, npt +! j=ipt(i) +! if ( iwklm(i) .gt. ihit ) then +! ihit = iwklm(i) +! jhit = j +! endif +! enddo +! print *, ' mb: kdt,max(iwklm),jhit,phil,me=', +! & kdt,ihit,jhit,phil(jhit,ihit),me + + klevm1 = KMLL - 1 + DO K = 1, klevm1 + DO I = 1, npt + j = ipt(i) + RDZ = g / ( phil(j,k+1) - phil(j,k) ) +! --- Brunt-Vaisala Frequency +!> - Compute Brunt-Vaisala Frequency \f$N\f$. + BNV2LM(I,K) = (G+G) * RDZ * ( VTK(I,K+1)-VTK(I,K) ) + & / ( VTK(I,K+1)+VTK(I,K) ) + bnv2lm(i,k) = max( bnv2lm(i,k), bnv2min ) + ENDDO + ENDDO +! print *,' in gwdps_lm.f 3 npt=',npt,j,RDZ,me +! + DO I = 1, npt + J = ipt(i) + DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,iwklm(i))) + DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,iwklm(i))) + UBAR (I) = 0.0 + VBAR (I) = 0.0 + ROLL (I) = 0.0 + PE (I) = 0.0 + EK (I) = 0.0 + BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2LM(I,1) + ENDDO + +! --- find the dividing stream line height +! --- starting from the level above the max mtn downward +! --- iwklm(i) is the k-index of mtn elvmax elevation +!> - Find the dividing streamline height starting from the level above +!! the maximum mountain height and processing downward. + DO Ktrial = KMLL, 1, -1 + DO I = 1, npt + IF ( Ktrial .LT. iwklm(I) .and. kreflm(I) .eq. 0 ) then + kreflm(I) = Ktrial + ENDIF + ENDDO + ENDDO +! print *,' in gwdps_lm.f 4 npt=',npt,kreflm(npt),me +! +! --- in the layer kreflm(I) to 1 find PE (which needs N, ELVMAX) +! --- make averages, guess dividing stream (DS) line layer. +! --- This is not used in the first cut except for testing and +! --- is the vert ave of quantities from the surface to mtn top. +! + DO I = 1, npt + DO K = 1, Kreflm(I) + J = ipt(i) + RDELKS = DEL(J,K) * DELKS(I) + UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! trial Mean U below + VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! trial Mean V below + ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! trial Mean RO below + RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) + BNV2bar(I) = BNV2bar(I) + BNV2lm(I,K) * RDELKS +! --- these vert ave are for diags, testing and GWD to follow (*j*). + ENDDO + ENDDO +! print *,' in gwdps_lm.f 5 =',i,kreflm(npt),BNV2bar(npt),me +! +! --- integrate to get PE in the trial layer. +! --- Need the first layer where PE>EK - as soon as +! --- IDXZB is not 0 we have a hit and Zb is found. +! + DO I = 1, npt + J = ipt(i) + DO K = iwklm(I), 1, -1 + PHIANG = atan2(V1(J,K),U1(J,K))*RAD_TO_DEG + ANG(I,K) = ( THETA(J) - PHIANG ) + if ( ANG(I,K) .gt. 90. ) ANG(I,K) = ANG(I,K) - 180. + if ( ANG(I,K) .lt. -90. ) ANG(I,K) = ANG(I,K) + 180. + ANG(I,K) = ANG(I,K) * DEG_TO_RAD +! +!> - Compute wind speed UDS +!!\f[ +!! UDS=\max(\sqrt{U1^2+V1^2},minwnd) +!!\f] +!! where \f$ minwnd=0.1 \f$, \f$U1\f$ and \f$V1\f$ are zonal and +!! meridional wind components of model layer wind. + UDS(I,K) = + & MAX(SQRT(U1(J,K)*U1(J,K) + V1(J,K)*V1(J,K)), minwnd) +! --- Test to see if we found Zb previously + IF (IDXZB(I) .eq. 0 ) then + PE(I) = PE(I) + BNV2lm(I,K) * + & ( G * ELVMAX(J) - phil(J,K) ) * + & ( PHII(J,K+1) - PHII(J,K) ) / (G*G) +! --- KE +! --- Wind projected on the line perpendicular to mtn range, U(Zb(K)). +! --- kenetic energy is at the layer Zb +! --- THETA ranges from -+90deg |_ to the mtn "largest topo variations" + UP(I) = UDS(I,K) * cos(ANG(I,K)) + EK(I) = 0.5 * UP(I) * UP(I) + +! --- Dividing Stream lime is found when PE =exceeds EK. + IF ( PE(I) .ge. EK(I) ) THEN + IDXZB(I) = K + RDXZB(J) = real(K,kind=kind_phys) + ENDIF +! --- Then mtn blocked flow is between Zb=k(IDXZB(I)) and surface +! +!> - The dividing streamline height (idxzb), of a subgrid scale +!! obstable, is found by comparing the potential (PE) and kinetic +!! energies (EK) of the upstream large scale wind and subgrid scale air +!! parcel movements. the dividing streamline is found when +!! \f$PE\geq EK\f$. Mountain-blocked flow is defined to exist between +!! the surface and the dividing streamline height (\f$h_d\f$), which +!! can be found by solving an integral equation for \f$h_d\f$: +!!\f[ +!! \frac{U^{2}(h_{d})}{2}=\int_{h_{d}}^{H} N^{2}(z)(H-z)dz +!!\f] +!! where \f$H\f$ is the maximum subgrid scale elevation within the grid +!! box of actual orography, \f$h\f$, obtained from the GTOPO30 dataset +!! from the U.S. Geological Survey. + ENDIF + ENDDO + ENDDO +! +! print *,' in gwdps_lm.f 6 =',phiang,THETA(ipt(npt)),me +! print *,' in gwdps_lm.f 7 =',IDXZB(npt),PE(npt) +! +! if (lprnt .and. npr .gt. 0) then +! print *,' BNV2bar,BNV2lm=',bnv2bar(npr),BNV2lm(npr,1:klevm1) +! print *,' npr,IDXZB,UDS=',npr,IDXZB(npr),UDS(npr,:) +! print *,' PE,UP,EK=',PE(npr),UP(npr),EK(npr) +! endif +! + DO I = 1, npt + J = ipt(i) +! --- Calc if N constant in layers (Zb guess) - a diagnostic only. + ZBK(I) = ELVMAX(J) + & - SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I))/BNV2bar(I) + ENDDO +! +! if (lprnt .and. npr .gt. 0) then +! print *,' iwklm,ZBK=',iwklm(npr),ZBK(npr),IDXZB(npr) +! print *,' Zb=',PHIL(ipr),IDXZB(npr))/G +! print *,' in gwdps_lm.f 8 npt =',npt,ZBK(npt),UP(npt),me +! endif +! +! --- The drag for mtn blocked flow +! + DO I = 1, npt + J = ipt(i) + ZLEN = 0. +! print *,' in gwdps_lm.f 9 =',i,j,IDXZB(i),me + IF ( IDXZB(I) .gt. 0 ) then + DO K = IDXZB(I), 1, -1 + IF ( PHIL(J,IDXZB(I)) .gt. PHIL(J,K) ) then + +!> - Calculate \f$ZLEN\f$, which sums up a number of contributions of +!! elliptic obstables. +!!\f[ +!! ZLEN=\sqrt{[\frac{h_{d}-z}{z+h'}]} +!!\f] +!! where \f$z\f$ is the height, \f$h'\f$ is the orographic standard +!! deviation (HPRIME). + ZLEN = SQRT( ( PHIL(J,IDXZB(I)) - PHIL(J,K) ) / + & ( PHIL(J,K ) + G * hprime(J) ) ) +! --- lm eq 14: +!> - Calculate the drag coefficient to vary with the aspect ratio of +!! the obstable as seen by the incident flow (see eq.14 in Lott and +!! Miller (1997) \cite lott_and_miller_1997) +!!\f[ +!! R=\frac{\cos^{2}\psi+\gamma\sin^{2}\psi}{\gamma\cos^{2}\psi+\sin^{2}\psi} +!!\f] +!! where \f$\psi\f$, which is derived from THETA, is the angle between +!! the incident flow direction and the normal ridge direcion. +!! \f$\gamma\f$ is the orographic anisotropy (GAMMA). + R = cos(ANG(I,K))**2 + GAMMA(J) * sin(ANG(I,K))**2 + if (abs(R) .lt. 1.E-20) then + DB(I,K) = 0.0 + else + R = (gamma(J) * cos(ANG(I,K))**2 + sin(ANG(I,K))**2) / R +! --- (negitive of DB -- see sign at tendency) +!> - In each model layer below the dividing streamlines, a drag from +!! the blocked flow is exerted by the obstacle on the large scale flow. +!! The drag per unit area and per unit height is written (eq.15 in +!! Lott and Miller (1997) \cite lott_and_miller_1997): +!!\f[ +!! D_{b}(z)=-C_{d}\max(2-\frac{1}{R},0)\rho\frac{\sigma}{2h'}ZLEN\max(\cos\psi,\gamma\sin\psi)\frac{UDS}{2} +!!\f] +!! where \f$C_{d}\f$ is a specified constant, \f$\sigma\f$ is the +!! orographic slope. + + DBTMP = 0.25 * CDmb * + & MAX( 2. - R, 0. ) * sigma(J) * + & MAX(cos(ANG(I,K)), gamma(J)*sin(ANG(I,K))) * + & ZLEN / hprime(J) + DB(I,K) = DBTMP * UDS(I,K) + endif +! +! if(lprnt .and. i .eq. npr) then +! print *,' in gwdps_lmi.f 10 npt=',npt,i,j,idxzb(i) +! &, DBTMP,R' ang=',ang(i,k),' gamma=',gamma(j),' K=',K +! print *,' in gwdps_lmi.f 11 K=',k,ZLEN,cos(ANG(I,K)) +! print *,' in gwdps_lmi.f 12 DB=',DB(i,k),sin(ANG(I,K)) +! endif + endif + ENDDO +! if(lprnt) print *,' @K=1,ZLEN,DBTMP=',K,ZLEN,DBTMP + endif + ENDDO +! +!............................. +!............................. +! end mtn blocking section +! + ELSEIF ( NMTVR .ne. 14) then +! ---- for mb not present and gwd (nmtvr .ne .14) + ipt = 0 + npt = 0 + DO I = 1,IM + IF ( hprime(i) .GT. hpmin ) then + npt = npt + 1 + ipt(npt) = i + if (ipr .eq. i) npr = npt + ENDIF + ENDDO + IF (npt .eq. 0) RETURN ! No gwd/mb calculation done! +! +! if (lprnt) print *,' NPR=',npr,' npt=',npt,' IPR=',IPR +! &,' ipt(npt)=',ipt(npt) +! + do i=1,npt + IDXZB(i) = 0 + RDXZB(i) = 0. + enddo + ENDIF +! +!............................. +!............................. +! +!> --- Orographic Gravity Wave Drag Section + KMPBL = km / 2 ! maximum pbl height : # of vertical levels / 2 +! +! Scale cleff between IM=384*2 and 192*2 for T126/T170 and T62 +! + if (imx .gt. 0) then +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/384.0) ! this is inverse of CLEFF! +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 0.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 1.0E-5 * SQRT(FLOAT(IMX)/192)/float(IMX/192) +! cleff = 1.0E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + cleff = 0.5E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! hmhj for ndsl +! jw cleff = 0.1E-5 / SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.0E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! +! cleff = 2.5E-5 * SQRT(FLOAT(IMX)/192.0) ! this is inverse of CLEFF! + endif + if (cdmbgwd(2) >= 0.0) cleff = cleff * cdmbgwd(2) +! + DO K = 1,KM + DO I =1,npt + J = ipt(i) + VTJ(I,K) = T1(J,K) * (1.+FV*Q1(J,K)) + VTK(I,K) = VTJ(I,K) / PRSLK(J,K) + RO(I,K) = RDI * PRSL(J,K) / VTJ(I,K) ! DENSITY TONS/M**3 + TAUP(I,K) = 0.0 + ENDDO + ENDDO + DO K = 1,KMM1 + DO I =1,npt + J = ipt(i) + TI = 2.0 / (T1(J,K)+T1(J,K+1)) + TEM = TI / (PRSL(J,K)-PRSL(J,K+1)) + RDZ = g / (phil(j,k+1) - phil(j,k)) + TEM1 = U1(J,K) - U1(J,K+1) + TEM2 = V1(J,K) - V1(J,K+1) + DW2 = TEM1*TEM1 + TEM2*TEM2 + SHR2 = MAX(DW2,DW2MIN) * RDZ * RDZ + BVF2 = G*(GOCP+RDZ*(VTJ(I,K+1)-VTJ(I,K))) * TI + ri_n(I,K) = MAX(BVF2/SHR2,RIMIN) ! Richardson number +! Brunt-Vaisala Frequency +! TEM = GR2 * (PRSL(J,K)+PRSL(J,K+1)) * TEM +! BNV2(I,K) = TEM * (VTK(I,K+1)-VTK(I,K))/(VTK(I,K+1)+VTK(I,K)) + BNV2(I,K) = (G+G) * RDZ * (VTK(I,K+1)-VTK(I,K)) + & / (VTK(I,K+1)+VTK(I,K)) + bnv2(i,k) = max( bnv2(i,k), bnv2min ) + ENDDO + ENDDO +! print *,' in gwdps_lm.f GWD:14 =',npt,kmm1,bnv2(npt,kmm1) +! +! Apply 3 point smoothing on BNV2 +! +! do k=1,km +! do i=1,im +! vtk(i,k) = bnv2(i,k) +! enddo +! enddo +! do k=2,kmm1 +! do i=1,im +! bnv2(i,k) = 0.25*(vtk(i,k-1)+vtk(i,k+1)) + 0.5*vtk(i,k) +! enddo +! enddo +! +! Finding the first interface index above 50 hPa level +! + do i=1,npt + iwk(i) = 2 + enddo + DO K=3,KMPBL + DO I=1,npt + j = ipt(i) + tem = (prsi(j,1) - prsi(j,k)) + if (tem .lt. dpmin) iwk(i) = k + enddo + enddo +! +!> - Calculate the reference level index: kref=max(2,KPBL+1). where +!! KPBL is the index for the PBL top layer. + KBPS = 1 + KMPS = KM + DO I=1,npt + J = ipt(i) + kref(I) = MAX(IWK(I), KPBL(J)+1 ) ! reference level + DELKS(I) = 1.0 / (PRSI(J,1) - PRSI(J,kref(I))) + DELKS1(I) = 1.0 / (PRSL(J,1) - PRSL(J,kref(I))) + UBAR (I) = 0.0 + VBAR (I) = 0.0 + ROLL (I) = 0.0 + KBPS = MAX(KBPS, kref(I)) + KMPS = MIN(KMPS, kref(I)) +! + BNV2bar(I) = (PRSL(J,1)-PRSL(J,2)) * DELKS1(I) * BNV2(I,1) + ENDDO +! print *,' in gwdps_lm.f GWD:15 =',KBPS,KMPS + KBPSP1 = KBPS + 1 + KBPSM1 = KBPS - 1 + DO K = 1,KBPS + DO I = 1,npt + IF (K .LT. kref(I)) THEN + J = ipt(i) + RDELKS = DEL(J,K) * DELKS(I) + UBAR(I) = UBAR(I) + RDELKS * U1(J,K) ! Mean U below kref + VBAR(I) = VBAR(I) + RDELKS * V1(J,K) ! Mean V below kref +! + ROLL(I) = ROLL(I) + RDELKS * RO(I,K) ! Mean RO below kref + RDELKS = (PRSL(J,K)-PRSL(J,K+1)) * DELKS1(I) + BNV2bar(I) = BNV2bar(I) + BNV2(I,K) * RDELKS + ENDIF + ENDDO + ENDDO +! print *,' in gwdps_lm.f GWD:15B =',bnv2bar(npt) +! +! FIGURE OUT LOW-LEVEL HORIZONTAL WIND DIRECTION AND FIND 'OA' +! +! NWD 1 2 3 4 5 6 7 8 +! WD W S SW NW E N NE SE +! +!> - Calculate low-level horizontal wind direction, the derived +!! orographic asymmetry parameter (OA), and the derived Lx (CLX). + DO I = 1,npt + J = ipt(i) + wdir = atan2(UBAR(I),VBAR(I)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + OA(I) = (1-2*INT( (NWD-1)/4 )) * OA4(J,MOD(NWD-1,4)+1) + CLX(I) = CLX4(J,MOD(NWD-1,4)+1) + ENDDO +! +!-----XN,YN "LOW-LEVEL" WIND PROJECTIONS IN ZONAL +! & MERIDIONAL DIRECTIONS +!-----ULOW "LOW-LEVEL" WIND MAGNITUDE - (= U) +!-----BNV2 BNV2 = N**2 +!-----TAUB BASE MOMENTUM FLUX +!-----= -(RO * U**3/(N*XL)*GF(FR) FOR N**2 > 0 +!-----= 0. FOR N**2 < 0 +!-----FR FROUDE = N*HPRIME / U +!-----G GMAX*FR**2/(FR**2+CG/OC) +! +!-----INITIALIZE SOME ARRAYS +! + DO I = 1,npt + XN(I) = 0.0 + YN(I) = 0.0 + TAUB (I) = 0.0 + ULOW (I) = 0.0 + DTFAC(I) = 1.0 + ICRILV(I) = .FALSE. ! INITIALIZE CRITICAL LEVEL CONTROL VECTOR + +! +!----COMPUTE THE "LOW LEVEL" WIND MAGNITUDE (M/S) +! + ULOW(I) = MAX(SQRT(UBAR(I)*UBAR(I) + VBAR(I)*VBAR(I)), 1.0) + ULOI(I) = 1.0 / ULOW(I) + ENDDO +! + DO K = 1,KMM1 + DO I = 1,npt + J = ipt(i) + VELCO(I,K) = 0.5 * ((U1(J,K)+U1(J,K+1))*UBAR(I) + & + (V1(J,K)+V1(J,K+1))*VBAR(I)) + VELCO(I,K) = VELCO(I,K) * ULOI(I) +! IF ((VELCO(I,K).LT.VELEPS) .AND. (VELCO(I,K).GT.0.)) THEN +! VELCO(I,K) = VELEPS +! ENDIF + ENDDO + ENDDO +! +! +! find the interface level of the projected wind where +! low levels & upper levels meet above pbl +! +! do i=1,npt +! kint(i) = km +! enddo +! do k = 1,kmm1 +! do i = 1,npt +! IF (K .GT. kref(I)) THEN +! if(velco(i,k) .lt. veleps .and. kint(i) .eq. km) then +! kint(i) = k+1 +! endif +! endif +! enddo +! enddo +! WARNING KINT = KREF !!!!!!!!! + do i=1,npt + kint(i) = kref(i) + enddo +! +! if(lprnt) print *,' ubar=',ubar +! &,' vbar=',vbar,' ulow=',ulow,' veleps=',veleps +! + DO I = 1,npt + J = ipt(i) + BNV = SQRT( BNV2bar(I) ) + FR = BNV * ULOI(I) * min(HPRIME(J),hpmax) + FR = MIN(FR, FRMAX) + XN(I) = UBAR(I) * ULOI(I) + YN(I) = VBAR(I) * ULOI(I) +! +! Compute the base level stress and store it in TAUB +! CALCULATE ENHANCEMENT FACTOR, NUMBER OF MOUNTAINS & ASPECT +! RATIO CONST. USE SIMPLIFIED RELATIONSHIP BETWEEN STANDARD +! DEVIATION & CRITICAL HGT +! +!> - Calculate enhancement factor (E),number of mountans (m') and +!! aspect ratio constant. +!!\n As in eq.(4.9),(4.10),(4.11) in Kim and Arakawa (1995) +!! \cite kim_and_arakawa_1995, we define m' and E in such a way that they +!! depend on the geometry and location of the subgrid-scale orography +!! through OA and the nonlinearity of flow above the orography through +!! Fr. OC, which is the orographic convexity, and statistically +!! determine how protruded (sharp) the subgrid-scale orography is, is +!! included in the saturation flux G' in such a way that G' is +!! proportional to OC. The forms of E,m' and G' are: +!!\f[ +!! E(OA,F_{r_{0}})=(OA+2)^{\delta} +!!\f] +!!\f[ +!! \delta=C_{E}F_{r_{0}}/F_{r_{c}} +!!\f] +!!\f[ +!! m'(OA,CLX)=C_{m}\triangle x(1+CLX)^{OA+1} +!!\f] +!!\f[ +!! G'(OC,F_{r_{0}})=\frac{F_{r_{0}}^2}{F_{r_{0}}^2+a^{2}} +!!\f] +!!\f[ +!! a^{2}=C_{G}OC^{-1} +!!\f] +!! where \f$F_{r_{c}}(=1)\f$ is the critical Froude number, +!! \f$F_{r_{0}}\f$ is the Froude number. \f$C_{E}\f$,\f$C_{m}\f$, +!! \f$C_{G}\f$ are constants. + +!> - Calculate the reference-level drag \f$\tau_{0}\f$ (eq.(4.8) in +!! Kim and Arakawa (1995) \cite kim_and_arakawa_1995): +!!\f[ +!! \tau_0=E\frac{m'}{\triangle x}\frac{\rho_{0}U_0^3}{N_{0}}G' +!!\f] +!! where \f$E\f$,\f$m'\f$, and \f$G'\f$ are the enhancement factor, +!! "the number of mountains", and the flux function defined above, +!! respectively. + + EFACT = (OA(I) + 2.) ** (CEOFRC*FR) + EFACT = MIN( MAX(EFACT,EFMIN), EFMAX ) +! + COEFM = (1. + CLX(I)) ** (OA(I)+1.) +! + XLINV(I) = COEFM * CLEFF +! + TEM = FR * FR * OC(J) + GFOBNV = GMAX * TEM / ((TEM + CG)*BNV) ! G/N0 +! + TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * ULOW(I) + & * ULOW(I) * GFOBNV * EFACT ! BASE FLUX Tau0 +! +! tem = min(HPRIME(I),hpmax) +! TAUB(I) = XLINV(I) * ROLL(I) * ULOW(I) * BNV * tem * tem +! + K = MAX(1, kref(I)-1) + TEM = MAX(VELCO(I,K)*VELCO(I,K), 0.1) + SCOR(I) = BNV2(I,K) / TEM ! Scorer parameter below ref level + ENDDO +! if(lprnt) print *,' taub=',taub +! +!----SET UP BOTTOM VALUES OF STRESS +! + DO K = 1, KBPS + DO I = 1,npt + IF (K .LE. kref(I)) TAUP(I,K) = TAUB(I) + ENDDO + ENDDO +! +! Now compute vertical structure of the stress. +! + DO K = KMPS, KMM1 ! Vertical Level K Loop! + KP1 = K + 1 + DO I = 1, npt +! +!-----UNSTABLE LAYER IF RI < RIC +!-----UNSTABLE LAYER IF UPPER AIR VEL COMP ALONG SURF VEL <=0 (CRIT LAY) +!---- AT (U-C)=0. CRIT LAYER EXISTS AND BIT VECTOR SHOULD BE SET (.LE.) +! + IF (K .GE. kref(I)) THEN + ICRILV(I) = ICRILV(I) .OR. ( ri_n(I,K) .LT. RIC) + & .OR. (VELCO(I,K) .LE. 0.0) + ENDIF + ENDDO +! +!> - Compute the drag above the reference level (\f$k\geq kref\f$): +!! - Calculate the ratio of the Scorer parameter (\f$R_{scor}\f$). +!! \n From a series of experiments, Kim and Arakawa (1995) +!! \cite kim_and_arakawa_1995 found that the magnitude of drag divergence +!! tends to be underestimated by the revised scheme in low-level +!! downstream regions with wave breaking. Therefore, at low levels when +!! OA > 0 (i.e., in the "downstream" region) the saturation hypothesis +!! is replaced by the following formula based on the ratio of the +!! the Scorer parameter: +!!\f[ +!! R_{scor}=\min \left[\frac{\tau_i}{\tau_{i+1}},1\right] +!!\f] + DO I = 1,npt + IF (K .GE. kref(I)) THEN + IF (.NOT.ICRILV(I) .AND. TAUP(I,K) .GT. 0.0 ) THEN + TEMV = 1.0 / max(VELCO(I,K), 0.01) +! IF (OA(I) .GT. 0. .AND. PRSI(ipt(i),KP1).GT.RLOLEV) THEN + IF (OA(I).GT.0. .AND. kp1 .lt. kint(i)) THEN + SCORK = BNV2(I,K) * TEMV * TEMV + RSCOR = MIN(1.0, SCORK / SCOR(I)) + SCOR(I) = SCORK + ELSE + RSCOR = 1. + ENDIF +! +!> - The drag above the reference level is expressed as: +!!\f[ +!! \tau=\frac{m'}{\triangle x}\rho NUh_d^2 +!!\f] +!! where \f$h_{d}\f$ is the displacement wave amplitude. In the absence +!! of wave breaking, the displacement amplitude for the \f$i^{th}\f$ +!! layer can be expressed using the drag for the layer immediately +!! below. Thus, assuming \f$\tau_i=\tau_{i+1}\f$, we can get: +!!\f[ +!! h_{d_i}^2=\frac{\triangle x}{m'}\frac{\tau_{i+1}}{\rho_{i}N_{i}U_{i}} +!!\f] + + BRVF = SQRT(BNV2(I,K)) ! Brunt-Vaisala Frequency +! TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*VELCO(I,K)*0.5 + TEM1 = XLINV(I)*(RO(I,KP1)+RO(I,K))*BRVF*0.5 + & * max(VELCO(I,K),0.01) + HD = SQRT(TAUP(I,K) / TEM1) + FRO = BRVF * HD * TEMV +! +! RIM is the MINIMUM-RICHARDSON NUMBER BY SHUTTS (1985) +! +!> - The minimum Richardson number (\f$Ri_{m}\f$) or local +!! wave-modified Richardson number, which determines the onset of wave +!! breaking, is expressed in terms of \f$R_{i}\f$ and +!! \f$F_{r_{d}}=Nh_{d}/U\f$: +!!\f[ +!! Ri_{m}=\frac{Ri(1-Fr_{d})}{(1+\sqrt{Ri}\cdot Fr_{d})^{2}} +!!\f] +!! see eq.(4.6) in Kim and Arakawa (1995) \cite kim_and_arakawa_1995. + + TEM2 = SQRT(ri_n(I,K)) + TEM = 1. + TEM2 * FRO + RIM = ri_n(I,K) * (1.-FRO) / (TEM * TEM) +! +! CHECK STABILITY TO EMPLOY THE 'SATURATION HYPOTHESIS' +! OF LINDZEN (1981) EXCEPT AT TROPOSPHERIC DOWNSTREAM REGIONS +! +!> - Check stability to employ the 'saturation hypothesis' of Lindzen +!! (1981) \cite lindzen_1981 except at tropospheric downstream regions. +!! \n Wave breaking occurs when \f$Ri_{m} 1.e-10) then + do i = 1,npt + j = ipt(i) + do k = km/2, km+1 + if ( prsi(j,k) < p_crit ) then ! scale it to zero @ top + taup(i,k) = taup(i,k) * (prsi(j,k) - prsi(j,km+1)) / + & (p_crit - prsi(j,km+1)) + elseif ( prsi(j,k) < 1.e2) then + taup(i,k) = taup(i,k-1) ! constant stress-> zero Drag + endif + enddo + enddo + endif +!----------------------- SJL mod ------------------------------ + +! +! Calculate - (g/p*)*d(tau)/d(sigma) and Decel terms DTAUX, DTAUY +! + DO K = 1,KM + DO I = 1,npt + TAUD(I,K) = G * (TAUP(I,K+1) - TAUP(I,K)) / DEL(ipt(I),K) + ENDDO + ENDDO +! +!------LIMIT DE-ACCELERATION (MOMENTUM DEPOSITION ) AT TOP TO 1/2 VALUE +!------THE IDEA IS SOME STUFF MUST GO OUT THE 'TOP' +! + if (p_crit <= 1.e-10) then + DO KLCAP = LCAP, KM + DO I = 1,npt + TAUD(I,KLCAP) = TAUD(I,KLCAP) * FACTOP + ENDDO + ENDDO + endif +! +!------IF THE GRAVITY WAVE DRAG WOULD FORCE A CRITICAL LINE IN THE +!------LAYERS BELOW SIGMA=RLOLEV DURING THE NEXT DELTIM TIMESTEP, +!------THEN ONLY APPLY DRAG UNTIL THAT CRITICAL LINE IS REACHED. +! + DO K = 1,KMM1 + DO I = 1,npt + IF (K .GT. kref(I) .and. PRSI(ipt(i),K) .GE. RLOLEV) THEN + IF(TAUD(I,K).NE.0.) THEN + TEM = DELTIM * TAUD(I,K) + DTFAC(I) = MIN(DTFAC(I),ABS(VELCO(I,K)/TEM)) + ENDIF + ENDIF + ENDDO + ENDDO +! +! if(lprnt .and. npr .gt. 0) then +! print *,' before A=',A(npr,:) +! print *,' before B=',B(npr,:) +! endif + +!> - Calculate outputs: A, B, DUSFC, DVSFC (see parameter description). +!! - Below the dividing streamline height (k < idxzb), mountain +!! blocking(\f$D_{b}\f$) is applied. +!! - Otherwise (k>= idxzb), orographic GWD (\f$\tau\f$) is applied. + DO K = 1,KM + DO I = 1,npt + J = ipt(i) + TAUD(I,K) = TAUD(I,K) * DTFAC(I) + DTAUX = TAUD(I,K) * XN(I) + DTAUY = TAUD(I,K) * YN(I) + ENG0 = 0.5*(U1(j,K)*U1(j,K)+V1(J,K)*V1(J,K)) +! --- lm mb (*j*) changes overwrite GWD + if ( K .lt. IDXZB(I) .AND. IDXZB(I) .ne. 0 ) then + DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) + A(J,K) = - DBIM * V1(J,K) + A(J,K) + B(J,K) = - DBIM * U1(J,K) + B(J,K) + ENG1 = ENG0*(1.0-DBIM*DELTIM)*(1.0-DBIM*DELTIM) +! if ( ABS(DBIM * U1(J,K)) .gt. .01 ) +! & print *,' in gwdps_lmi.f KDT=',KDT,I,K,DB(I,K), +! & dbim,idxzb(I),U1(J,K),V1(J,K),me + DUSFC(J) = DUSFC(J) - DBIM * U1(J,K) * DEL(J,K) + DVSFC(J) = DVSFC(J) - DBIM * V1(J,K) * DEL(J,K) + else +! + A(J,K) = DTAUY + A(J,K) + B(J,K) = DTAUX + B(J,K) + ENG1 = 0.5*( + & (U1(J,K)+DTAUX*DELTIM)*(U1(J,K)+DTAUX*DELTIM) + & + (V1(J,K)+DTAUY*DELTIM)*(V1(J,K)+DTAUY*DELTIM)) + DUSFC(J) = DUSFC(J) + DTAUX * DEL(J,K) + DVSFC(J) = DVSFC(J) + DTAUY * DEL(J,K) + endif + C(J,K) = C(J,K) + max(ENG0-ENG1,0.)/CP/DELTIM + ENDDO + ENDDO +! if (lprnt) then +! print *,' in gwdps_lm.f after A=',A(ipr,:) +! print *,' in gwdps_lm.f after B=',B(ipr,:) +! print *,' DB=',DB(ipr,:) +! endif + TEM = -1.0/G + DO I = 1,npt + J = ipt(i) +! TEM = (-1.E3/G) + DUSFC(J) = TEM * DUSFC(J) + DVSFC(J) = TEM * DVSFC(J) + ENDDO +! +! MONITOR FOR EXCESSIVE GRAVITY WAVE DRAG TENDENCIES IF NCNT>0 +! +! IF(NCNT.GT.0) THEN +! IF(LAT.GE.38.AND.LAT.LE.42) THEN +!CMIC$ GUARD 37 +! DO 92 I = 1,IM +! IF(IKOUNT.GT.NCNT) GO TO 92 +! IF(I.LT.319.OR.I.GT.320) GO TO 92 +! DO 91 K = 1,KM +! IF(ABS(TAUD(I,K)) .GT. CRITAC) THEN +! IF(I.LE.IM) THEN +! IKOUNT = IKOUNT+1 +! PRINT 123,I,LAT,KDT +! PRINT 124,TAUB(I),BNV(I),ULOW(I), +! 1 GF(I),FR(I),ROLL(I),HPRIME(I),XN(I),YN(I) +! PRINT 124,(TAUD(I,KK),KK = 1,KM) +! PRINT 124,(TAUP(I,KK),KK = 1,KM+1) +! PRINT 124,(ri_n(I,KK),KK = 1,KM) +! DO 93 KK = 1,KMM1 +! VELKO(KK) = +! 1 0.5*((U1(I,KK)+U1(I,KK+1))*UBAR(I)+ +! 2 (V1(I,KK)+V1(I,KK+1))*VBAR(I))*ULOI(I) +!93 CONTINUE +! PRINT 124,(VELKO(KK),KK = 1,KMM1) +! PRINT 124,(A (I,KK),KK = 1,KM) +! PRINT 124,(DTAUY(I,KK),KK = 1,KM) +! PRINT 124,(B (I,KK),KK = 1,KM) +! PRINT 124,(DTAUX(I,KK),KK = 1,KM) +! GO TO 92 +! ENDIF +! ENDIF +!91 CONTINUE +!92 CONTINUE +!CMIC$ END GUARD 37 +!123 FORMAT(' *** MIGWD PRINT *** I=',I3,' LAT=',I3,' KDT=',I3) +!124 FORMAT(2X, 10E13.6) +! ENDIF +! ENDIF +! +! print *,' in gwdps_lm.f 18 =',A(ipt(1),idxzb(1)) +! &, B(ipt(1),idxzb(1)),me + RETURN + END +!> @} +!! @} +!! @} diff --git a/gsmphys/h2o_def.f b/gsmphys/h2o_def.f new file mode 100644 index 00000000..310a3c79 --- /dev/null +++ b/gsmphys/h2o_def.f @@ -0,0 +1,12 @@ + module h2o_def + use machine , only : kind_phys + implicit none + + integer, parameter :: kh2opltc=29 + + integer latsh2o, levh2o, timeh2o, h2o_coeff + real (kind=kind_phys), allocatable :: h2o_lat(:), h2o_pres(:) + &, h2o_time(:) + real (kind=kind_phys), allocatable :: h2oplin(:,:,:,:) + + end module h2o_def diff --git a/gsmphys/h2oc.f b/gsmphys/h2oc.f new file mode 100644 index 00000000..99e306fd --- /dev/null +++ b/gsmphys/h2oc.f @@ -0,0 +1,894 @@ +c*********************************************************************** +c*********************************************************************** +c File h2ocup.f created for data storage, initialization, and +c calculation of H2O IR cooling rates in the rotational and 6.3-mum +c vibrational bands after Xun Zhu (1999) reusing some of his code and +c data +c September, 2007: made by Rashid Akmaev for a pressure grid going +c upward +! Spr 06 2012 Henry Juang, initial implement for nems +! Oct 2012 Jun Wang, change reading files by 1 pe reading and +! broardcasting to all pes +! Dec 2012 Jun Wang, move init out of column physics +! +c Contains +c module h2ocm +c subroutine h2ocin(p0,lx) ! hmhj modified +c subroutine h2occ(t,p0,wvmmr,qr,qv,lx) +c*********************************************************************** +c*********************************************************************** + + module h2ocm + +c Module to keep data for calculation of H2O IR cooling after Zhu (1994) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c September 30, 2003 +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Parameters +c General + real,parameter:: daysec=86400.,r_daysec=1./daysec + +c Integers precalculated in h2ocin: +c -number of model starting layer (counted from the top) +c -number of model layers in a 1 scale height above the top +C parameterization layer + integer lh2oc,ltop1 + +c Parameterization arrays precalculated for model grid from band data +c in h2ocin: +c -optical band parameters +c -reference H2O MMR +c -interpolation coefficients + real ,allocatable,dimension(:):: gh2ort,gh2ovb,dg1rt,dg2rt, + $ dg1vb,dg2vb,gdp,xx,wvmmrc,coeff + + end module h2ocm + +c*********************************************************************** +c*********************************************************************** + + subroutine h2ocin(p0,lx,me,mpi_ior,mpi_comm) +!hmhj subroutine h2ocin(p0,lx,dir) + +c Subroutine to initialize calculations of H2O IR cooling rates done +c by h2occ after Zhu (1994) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Nov 12, 2008: corrected errors in calculation of gdp +c Sep 24, 2007: made from h2ocin for upward model grid +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use h2ocm + implicit none +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Arguments +c INPUT +c -mid-layer model pressure (Pa) grid levels going up + integer,intent(in):: lx,me,mpi_ior,mpi_comm + real,intent(in),dimension(lx):: p0 + +c -directory where input files are located +!hmhj character(len=*),intent(in):: dir + +c - OUTPUT: placed in the module +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Internal parameters + real,parameter:: delr0=.5,refpre=1./3e3 + real,dimension(lx)::tref + integer,parameter:: lmr=3,lmt=1 + +c Work space + integer:: l,lu + real:: workx + real,dimension(lx,lmr,lmt):: gamyrt,gamyvb +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Allocate 10 module arrays + allocate(gh2ort(lx),gh2ovb(lx),dg1rt(lx),dg2rt(lx), + $ dg1vb(lx),dg2vb(lx),gdp(lx),xx(lx),wvmmrc(lx),coeff(lx)) + +c Initialize module parameters (1 integer and 9 real arrays). These +c internal arrays go down for convenient calculation in the +c cooling-to-space approximation. lh2oc is the starting model level +c (counting down from top) corresponding to approximately 100 km. Above +c that level the cooling rates are extrapolated to 0 within one scale +c height (within ltop1 model layers). If the model top does not reach +c 100 km, lh2oc=1, ltop1=0; if the model bottom is above 100 km, +c lh2oc > lx and cooling rates are set to 0 in the model domain. + lh2oc=lx+1 + ltop1=0 + gh2ort(:)=0. + gh2ovb(:)=0. + dg1rt(:)=0. + dg2rt(:)=0. + dg1vb(:)=0. + dg2vb(:)=0. + wvmmrc(:)=0. + gdp(:)=0. + xx(:)=0. + coeff(:)=0. + +c Precalculate parameters for matrix interpolation + +c Prepare reference atmosphere on model grid and other grid params. In +c the call to wvrefm, the model grid is inversed (goes down from the +c top) for compatibility with Xun's original code and to simplify +c calculations in the cooling-to-space approximation + tref(:)=0. + + call wvrefm(p0(lx:1:-1),wvmmrc,tref,coeff,lx,lh2oc,ltop1) +c print*,'www1',lx,lh2oc,ltop1 + + if(lh2oc > lx) return + + gdp(lh2oc)=(1.+refpre*p0(lx+1-lh2oc))*(p0(lx-lh2oc)- + $ p0(lx+1-lh2oc)) + gdp(lx)=(1.+refpre*p0(1))*(p0(1)-p0(2)) + do l=(lh2oc+1),(lx-1) + lu=lx+1-l + gdp(l)=.5*(1.+refpre*p0(lu))*(p0(lu-1)-p0(lu+1)) + enddo + + workx=0. + do l=lh2oc,lx + workx=workx+delr0*wvmmrc(l)*gdp(l) + xx(l)=1./workx + enddo + + l=lx-lh2oc+1 + + call g1rtxz(l,tref(lh2oc:),p0(l:1:-1),wvmmrc(lh2oc:), + $ lmr,lmt,gamyrt(lh2oc:,:,:),me,mpi_ior,mpi_comm) +!hmhj$ lmr,lmt,gamyrt(lh2oc:,:,:),dir) + call g1vbxz(l,tref(lh2oc:),p0(l:1:-1),wvmmrc(lh2oc:), + $ lmr,lmt,gamyvb(lh2oc:,:,:),me,mpi_ior,mpi_comm) +!hmhj$ lmr,lmt,gamyvb(lh2oc:,:,:),dir) + call gtoaxz(l,lmr,gamyrt(lh2oc:,:,:),gamyvb(lh2oc:,:,:), + $ dg1rt(lh2oc:),dg2rt(lh2oc:),dg1vb(lh2oc:),dg2vb(lh2oc:)) + + do l=lh2oc,lx + gh2ort(l)=gamyrt(l,2,1) + gh2ovb(l)=gamyvb(l,2,1) + enddo + + end subroutine h2ocin + +c*********************************************************************** +c*********************************************************************** + + subroutine h2occ(t,p0,wvmmr,qr,qv,lx) +c Subroutine to calculate H2O IR cooling rates after Zhu (1994). Made +c using his code, substantially rewritten. +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Sep 24, 2007: Made from h2oc_calc for upward pressure grid +c October 1, 2003 +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use h2ocm + implicit none +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Arguments +c - IN: temperature (K), pressure (Pa), and H2O MMR (relative units) +C on the same model grid going up as in h2ocin + integer:: lx + real,intent(in),dimension(lx):: t,p0,wvmmr + +c - OUT: heating rates (K/s) in the rotational and vibrational bands, +c respectively + real,dimension(lx),intent(out):: qr,qv +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Internal parameters +c - inverse of reference H2O MMR + real,parameter:: rrmmr=1./(3.e-6) + +c Work space (most of it kept for historic compatibility reasons) + integer:: l,lu,lw + real:: phiv,thr,thv,gr2,gv2,wk1,wk2,yy +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + qr(:)=0. + qv(:)=0. + + if(lh2oc > lx) return + +c Calculate cooling rates up to layer lh2oc. Index l goes down, lu goes +c up + yy=0. + lw=lx+1 + do l=lh2oc,lx + lu=lw-l + yy=yy+(wvmmr(lu)-wvmmrc(l))*gdp(l) + wk1=yy*xx(l) + wk2=wvmmr(lu)*rrmmr*r_daysec +c +c 2*(4.3E-20/20.5)*air density in m^-3 (Coefficient 2 is due to +c rearranged expression for calculation of qv) +c + phiv=420.*p0(lu)/(1.380658*t(lu)) + thr=81.6/(exp(568.01/t(lu))-1.) ! S*B in K/day + thv=2730.0/(exp(2300.8/t(lu))-1.) ! S*B in K/day + gr2=gh2ort(l)+wk1*(dg1rt(l)+dg2rt(l)*wk1) + gv2=gh2ovb(l)+wk1*(dg1vb(l)+dg2vb(l)*wk1) + qr(lu)=-wk2*thr*gr2 + qv(lu)=-wk2*thv*gv2*phiv/(phiv+gv2) + enddo + +c Extrapolate cooling rates linearly to zero a scale height above lh2oc + if(ltop1 > 0) then + lw=lx+1-lh2oc + do l=1,ltop1 + lu=lw+l + qr(lu)=qr(lw)*(1.-coeff(l)) + qv(lu)=qv(lw)*(1.-coeff(l)) + enddo + endif + + end subroutine h2occ + +c*********************************************************************** +c*********************************************************************** +c End of file h2ocup.f +c*********************************************************************** +c*********************************************************************** + +c*********************************************************************** +c File h2olib contains 10 subroutines/functions used by h2oc.f +c Nov 13, 2008: updated +c subroutine wvrefm +c Sept, 2007: Assembled by Rashid Akmaev +c*********************************************************************** + + FUNCTION BLAC(V,T) +C Planck black-body function J/m/s at the wavenumber v and +C temperature T. B = [2hv**3*c**2]/[exp(hcv/kT)-1] with +C h=6.6262E-34 Js, c=2.998E8 m/s, k=1.381E-23 J/K, v~6.75E4 m^-1. +C f1=2hc*c=1.19109E-16 Jm*m/s, f2=hc/k=0.0143847 mK. + BLAC=1.19109E-16*V**3/(EXP(0.0143847*V/T)-1.0) + + END function blac + +c*********************************************************************** + + FUNCTION ENZ2(Z) +CC +C Calcualte exponential integral from polynomial and rational +C approximation E2(z)=[exp(-z)-zE1(z)]=exp(-z)[1-exp(z)zE1(z)] +CC + IF(Z.LE.1.0) THEN + IF(Z.LE.1.0E-35) THEN + ENZ2=1.0 + RETURN + ENDIF + ENZ=-ALOG(Z)-0.57721566+Z*(0.99999193-Z*(0.24991055 + 1 -Z*(0.05519968-Z*(0.00976004E0-Z*0.00107857)))) + ENZ2=EXP(-Z)-Z*ENZ + RETURN + ENDIF + IF(Z.GE.80.0) THEN + ENZ2=0.0 + RETURN + ENDIF + ENZ=(0.2677737343+Z*(8.6347608925+Z*(18.0590169730+Z* + & (8.5733287401+Z))))/(3.9584969228+Z*(21.0996530827+Z* + & (25.6329561486+Z*(9.5733223454+Z)))) + ENZ2=EXP(-Z)*(1.0-ENZ) + + END function enz2 + +c*********************************************************************** + + subroutine g1rtxz(kus,tus0,pus,rus0,lmr,lmt,gamav, & + & me,mpi_ior,mpi_comm) +!hmhj subroutine g1rtxz(kus,tus0,pus,rus0,lmr,lmt,gamav,dirin) + +c Sept, 2007: made by Rashid Akmaev from Xun Zhu's code for H2O cooling +! + include 'mpif.h' + + integer,intent(in):: kus,lmr,lmt,me,mpi_ior,mpi_comm + real,intent(in):: pus(kus),TUS0(KUS),RUS0(KUS) +!hmhj character(len=*),intent(in) :: dirin + + real,intent(out):: gamav(kus,lmr,lmt) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Internal parameters and work space + PARAMETER (NQUS=17,KFS=20,KM=40,MM4=7,NQ=17) + + real,dimension(km) :: GG,WW + real :: XK2(KFS,NQ,KM,MM4) + real :: PRE(KFS),TEM4(MM4),T77(MM4) + real :: XKUS(KUS,NQ,KM,MM4) + integer info + + dimension TUS(KUS),RUS(KUS) + + dimension VNQ(NQ),VNQS(NQUS),STRB(KUS,NQUS),GAMSP(KUS,NQUS) + & ,QB1(KUS,NQUS),QB2(KUS,NQUS),QBT(KUS,NQUS) + & ,QAL1(KUS,LMR,LMT),QAL2(KUS,LMR,LMT),QALT(KUS,LMR,LMT) + + DIMENSION WK1(KUS),WK2(KUS),WK3(KUS),WK4(KUS) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + DDV=25.0E2 ! unit of bandwidth: m^-1 + V00=50.0E2 ! [nu]0 for H2O in m^-1 + + DO 2 N1=1,NQ + 2 VNQ(N1)=V00+DDV*(FLOAT(N1)-0.5) +! +! open first pe to read the file + if(me==0) then + + OPEN(11,FILE='global_idea_ggww_in4.par',STATUS='OLD') + DO 5 K2=1,KM + 5 READ(11,*) GG(K2),WW(K2) + CLOSE(UNIT=11) + + OPEN(71,FILE='global_idea_h2ort_kg7t.par',STATUS='OLD') + DO 7 ICON=1,MM4 + DO 7 N1=1,NQ + DO 7 K1=1,KFS ! read in the k-coefficient in m*m/kg + READ(71,*) (XK2(K1,N1,K2,ICON),K2=1,KM) + 7 CONTINUE + CLOSE(UNIT=71) + + endif +! +! print *,'bf mpi_bcast, km=',km,'MPI_IOR=',MPI_IOR,mpi_comm, +! & size(gg),mpi_real4 + call mpi_bcast(GG,KM,MPI_REAL8,0,mpi_comm,info) + call mpi_bcast(WW,KM,MPI_REAL8,0,mpi_comm,info) + call mpi_bcast(XK2,MM4*NQ*KFS*KM,MPI_REAL8,0,mpi_comm,info) + + DO 9 M=1,MM4 + TEM4(M)=150.0+FLOAT(M-1)*25.0 ! 7 reference temperatures + 9 T77(M)=TEM4(M) + + KFSM1=KFS-1 + PRE(1)=1.0E-4 + FACT2=10.0E0**0.25E0 + PRE(2)=10.0E0**0.5E0 + PRE(3)=10.0E0 + DO 10 K=4,KFSM1 + PRE(K)=PRE(K-1)*FACT2 + 10 CONTINUE + + PRE(KFS)=1.1E5 ! 20 reference pressures + + DELTR=0.5 + + DO 500 LLR=1,LMR + DO 500 LLT=1,LMT + + DO 33 K=1,KUS + TUS(K)=TUS0(K) + RUS(K)=RUS0(K)*(1.0+DELTR*FLOAT(LLR-2)) + 33 CONTINUE + + CALL INTERK(kus,kfs,km,mm4,nq,pre,xk2,pus,xkus) + + DO 80 N=1,NQUS + VNQS(N)=V00+DDV*(FLOAT(N)-0.5) + CALL QSINGL(WK1,WK2,RUS,PUS,TUS,WK3,WK4,KUS, + & WW,GG,KM,N,VNQS(N),DDV,1,mm4,nq,t77,xkus) + DO 60 K=1,KUS + QB1(K,N)=WK1(K) + QB2(K,N)=WK2(K) + QBT(K,N)=QB1(K,N)+QB2(K,N) + STRB(K,N)=WK3(K) + GAMSP(K,N)=WK4(K) + 60 CONTINUE + 80 CONTINUE + + DO 100 K=1,KUS + QAL1(K,LLR,LLT)=0.0 + QAL2(K,LLR,LLT)=0.0 + QALT(K,LLR,LLT)=0.0 + GAMAV(K,LLR,LLT)=0.0 + SUMX1=0.0 +! + DO 90 N=1,NQUS + QAL1(K,LLR,LLT)=QAL1(K,LLR,LLT)+QB1(K,N) + QAL2(K,LLR,LLT)=QAL2(K,LLR,LLT)+QB2(K,N) + QALT(K,LLR,LLT)=QALT(K,LLR,LLT)+QBT(K,N) + FACX1=STRB(K,N)*BLAC(VNQS(N),TUS(K)) + GAMAV(K,LLR,LLT)=GAMAV(K,LLR,LLT)+FACX1*GAMSP(K,N) + SUMX1=SUMX1+FACX1 + 90 CONTINUE + GAMAV(K,LLR,LLT)=GAMAV(K,LLR,LLT)/SUMX1 + 100 CONTINUE + + 500 CONTINUE + + END subroutine g1rtxz + +c*********************************************************************** + + subroutine g1vbxz(kus,tus0,pus,rus0,lmr,lmt,gamav, & + & me,mpi_ior,mpi_comm) + +c Sept, 2007: made by Rashid Akmaev from Xun Zhu's code for H2O cooling +! + include 'mpif.h' + + integer,intent(in):: kus,lmr,lmt + real,intent(in):: pus(kus),TUS0(KUS),RUS0(KUS) + + real,intent(out):: gamav(kus,lmr,lmt) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Internal parameters and work space + PARAMETER (NQUS=14,KFS=20,KM=30,MM4=7,NQ=14) + + dimension PRE(KFS),TEM4(MM4),GG(KM),WW(KM),XK2(KFS,NQ,KM,MM4) + dimension T77(MM4),XKUS(KUS,NQ,KM,MM4) + + dimension TUS(KUS),RUS(KUS) + + dimension VNQ(NQ),VNQS(NQUS),STRB(KUS,NQUS),GAMSP(KUS,NQUS) + & ,QB1(KUS,NQUS),QB2(KUS,NQUS),QBT(KUS,NQUS) + & ,QAL1(KUS,LMR,LMT),QAL2(KUS,LMR,LMT),QALT(KUS,LMR,LMT) + + DIMENSION WK1(KUS),WK2(KUS),WK3(KUS),WK4(KUS) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + DDV=50.0E2 ! unit of bandwidth: m^-1 + V00=1300.0E2 ! [nu]0 for H2O in m^-1 + + DO 2 N1=1,NQ + 2 VNQ(N1)=V00+DDV*(FLOAT(N1)-0.5) +! +! only pe 0 read the file + if(me==0) then + + OPEN(11,FILE='global_idea_ggww_in1.par',STATUS='OLD') + DO 5 K2=1,KM + 5 READ(11,*) GG(K2),WW(K2) + CLOSE(UNIT=11) + + OPEN(71,FILE='global_idea_h2ovb_kg7t.par',STATUS='OLD') + DO 7 ICON=1,MM4 + DO 7 N1=1,NQ + DO 7 K1=1,KFS ! read in the k-coefficient in m*m/kg + READ(71,*) (XK2(K1,N1,K2,ICON),K2=1,KM) + 7 CONTINUE + CLOSE(UNIT=71) + + endif +! + call mpi_bcast(GG,KM,MPI_IOR,0,mpi_comm,info) + call mpi_bcast(WW,KM,MPI_IOR,0,mpi_comm,info) + call mpi_bcast(XK2,MM4*NQ*KFS*KM,MPI_IOR,0,mpi_comm,info) + + + DO 9 M=1,MM4 + TEM4(M)=150.0+FLOAT(M-1)*25.0 ! 7 reference temperatures + 9 T77(M)=TEM4(M) + + KFSM1=KFS-1 + PRE(1)=1.0E-4 + FACT2=10.0E0**0.25E0 + PRE(2)=10.0E0**0.5E0 + PRE(3)=10.0E0 + DO 10 K=4,KFSM1 + PRE(K)=PRE(K-1)*FACT2 + 10 CONTINUE + + PRE(KFS)=1.1E5 ! 20 reference pressures + + DELTR=0.5 + + DO 500 LLR=1,LMR + DO 500 LLT=1,LMT + + DO 33 K=1,KUS + TUS(K)=TUS0(K) + RUS(K)=RUS0(K)*(1.0+DELTR*FLOAT(LLR-2)) + 33 CONTINUE + + CALL INTERK(kus,kfs,km,mm4,nq,pre,xk2,pus,xkus) + + DO 80 N=1,NQUS + VNQS(N)=V00+DDV*(FLOAT(N)-0.5) + CALL QSINGL(WK1,WK2,RUS,PUS,TUS,WK3,WK4,KUS, + & WW,GG,KM,N,VNQS(N),DDV,1,mm4,nq,t77,xkus) + DO 60 K=1,KUS + QB1(K,N)=WK1(K) + QB2(K,N)=WK2(K) + QBT(K,N)=QB1(K,N)+QB2(K,N) + STRB(K,N)=WK3(K) + GAMSP(K,N)=WK4(K) + 60 CONTINUE + 80 CONTINUE + + DO 100 K=1,KUS + QAL1(K,LLR,LLT)=0.0 + QAL2(K,LLR,LLT)=0.0 + QALT(K,LLR,LLT)=0.0 + GAMAV(K,LLR,LLT)=0.0 + SUMX1=0.0 +! + DO 90 N=1,NQUS + QAL1(K,LLR,LLT)=QAL1(K,LLR,LLT)+QB1(K,N) + QAL2(K,LLR,LLT)=QAL2(K,LLR,LLT)+QB2(K,N) + QALT(K,LLR,LLT)=QALT(K,LLR,LLT)+QBT(K,N) + FACX1=STRB(K,N)*BLAC(VNQS(N),TUS(K)) + GAMAV(K,LLR,LLT)=GAMAV(K,LLR,LLT)+FACX1*GAMSP(K,N) + SUMX1=SUMX1+FACX1 + 90 CONTINUE + GAMAV(K,LLR,LLT)=GAMAV(K,LLR,LLT)/SUMX1 + 100 CONTINUE + + 500 CONTINUE + + END subroutine g1vbxz + +c*********************************************************************** + + subroutine gtoaxz(kus,lmr,gamrt,gamvb,c1rt,c2rt,c1vb,c2vb) + +c Sept, 2007: made by Rashid Akmaev from Xun Zhu's code for H2O cooling + + implicit none + integer,intent(in):: kus,lmr + real,intent(in):: gamrt(kus,lmr),gamvb(kus,lmr) + + real,intent(out):: c1rt(kus),c2rt(kus),c1vb(kus),c2vb(kus) + + integer:: k + + DO K=1,KUS + C1RT(K)=(GAMRT(K,3)-GAMRT(K,1))/2.0 + C1VB(K)=(GAMVB(K,3)-GAMVB(K,1))/2.0 + C2RT(K)=(GAMRT(K,3)+GAMRT(K,1)-2.0*GAMRT(K,2))/2.0 + C2VB(K)=(GAMVB(K,3)+GAMVB(K,1)-2.0*GAMVB(K,2))/2.0 + enddo + + end subroutine gtoaxz + +c*********************************************************************** + + SUBROUTINE INTERK(kus,kfs,km,mm4,nq,pre,xk2,pus,xkus) + + implicit none + integer,intent(in):: kus,kfs,km,mm4,nq + real,intent(in):: pre(kfs),xk2(kfs,nq,km,mm4),pus(kus) + real,intent(out):: xkus(kus,nq,km,mm4) + + integer:: i,k,kref,k2,m,n1 + real:: dy,yk,xx,WR1(2),WR2(2) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + DO 60 K2=1,KUS + + DO 10 K=1,KFS + KREF=K + IF(PUS(K2).LT.PRE(K)) GO TO 12 + 10 CONTINUE + 12 CONTINUE + + IF(KREF.EQ.1) KREF=2 + WR1(1)=ALOG(PRE(KREF-1)) + WR1(2)=ALOG(PRE(KREF)) + + DO 50 N1=1,NQ + DO 50 M=1,MM4 + DO 50 I=1,KM + WR2(1)=ALOG(XK2(KREF-1,N1,I,M)) + WR2(2)=ALOG(XK2(KREF,N1,I,M)) + XX=ALOG(PUS(K2)) + CALL POLINT(WR1,WR2,2,XX,YK,DY) + XKUS(K2,N1,I,M)=EXP(YK) + 50 CONTINUE + + 60 CONTINUE + + END subroutine interk + +c*********************************************************************** + + SUBROUTINE POLINT(XA,YA,N,X,Y,DY) +C Polynomial interpolation from "Numerical Recipes" + PARAMETER (NMAX=10) + DIMENSION XA(N),YA(N),C(NMAX),D(NMAX) + NS=1 + DIF=ABS(X-XA(1)) + DO 11 I=1,N + DIFT=ABS(X-XA(I)) + IF (DIFT.LT.DIF) THEN + NS=I + DIF=DIFT + ENDIF + C(I)=YA(I) + D(I)=YA(I) +11 CONTINUE + Y=YA(NS) + NS=NS-1 + DO 13 M=1,N-1 + DO 12 I=1,N-M + HO=XA(I)-X + HP=XA(I+M)-X + W=C(I+1)-D(I) + DEN=HO-HP +!!!compiler warning IF(DEN.EQ.0.) PAUSE + IF(DEN.EQ.0.) STOP 'DEN.EQ.0. in POLINT' + DEN=W/DEN + D(I)=HP*DEN + C(I)=HO*DEN +12 CONTINUE + IF (2*NS.LT.N-M)THEN + DY=C(NS+1) + ELSE + DY=D(NS) + NS=NS-1 + ENDIF + Y=Y+DY +13 CONTINUE + + END subroutine polint + +c*********************************************************************** + + SUBROUTINE QSINGL(Q1,Q2,RX,PRE,TEM,STR,GAMS,KM, + & WI,GI,IM,N,VM,DVM,ITOP,mm4,nq,t77,xkus) + +C Cooling rate by a single line +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + dimension t77(mm4),xkus(km,nq,im,mm4) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +CCCCC +C To calculate the cooling rate by a single line located at VM in 1/m +C with width DVM. PRE = pressure in pascal, TEM = temperature in Kelvin, +C SI = k-coefficient at GI in m*m/kg, RX = mass mixing ratio +C Q1 & Q2 = cool-to-space & heat exchange cooling rate in K/day, +C ITOP=0 ==> PRE(KM)->0; ITOP=1 ==> PRE(1)->0. +CCCCC + PARAMETER (KMAX=150) + DIMENSION Q1(KM),Q2(KM),RX(KM),PRE(KM),TEM(KM),GAMS(KM) + & ,STR(KM),WI(IM),GI(IM),GAM1(KMAX,KMAX),BJX(KMAX),H00(KMAX) + KMM=KM-1 + PI=3.14159265 + GRAV1=9.8 ! gravitational constant in m s**(-2) + B250=BLAC(VM,250.0) + DO 20 K=1,KM + STR(K)=0.0 + DO 15 I=1,IM + STR(K)=STR(K)+WI(I)*ZXKTP(TEM(K),K,I,N,km,im,mm4,nq,t77,xkus) + 15 CONTINUE + BJX(K)=BLAC(VM,TEM(K))/B250 + H00(K)=2.0*PI*86400.0*RX(K)*(STR(K)*DVM)*B250/1004.0 + 20 CONTINUE + DO 150 I=1,KM + DO 150 J=1,KM + GAM1(I,J)=0.0 + if(j.ne.1) go to 150 + IJ1=MIN0(I,J) + IJ2=MAX0(I,J)-1 + DO 120 L=1,IM + IF(I.EQ.J) GO TO 50 + DELU=0.0 + DO 40 M=IJ1,IJ2 + FAC1=(ZXKTP(TEM(M),M,L,N,km,im,mm4,nq,t77,xkus)+ + $ ZXKTP(TEM(M+1),M+1,L,N,km,im,mm4,nq,t77,xkus))/2.0 + FAC2=(RX(M)+RX(M+1))/2.0 + DP1=ABS(PRE(M)-PRE(M+1)) + DELU=DELU+FAC1*FAC2*DP1 + 40 CONTINUE + DELU=DELU/GRAV1 + GO TO 100 + 50 CONTINUE + IF(I.EQ.1) DP1=ABS(PRE(1)-PRE(2)) + IF(I.EQ.KM) DP1=ABS(PRE(KM)-PRE(KM-1)) + IF(I.NE.1.AND.I.NE.KM) DP1=ABS(PRE(I+1)-PRE(I-1))/2.0 + DP1=DP1*0.5 + DELU=ZXKTP(TEM(I),I,L,N,km,im,mm4,nq,t77,xkus)*RX(I)*DP1/GRAV1 + 100 CONTINUE + GAM1(I,J)=GAM1(I,J)+ + $ WI(L)*ZXKTP(TEM(I),I,L,N,km,im,mm4,nq,t77,xkus)*ENZ2(DELU) + 120 CONTINUE + GAM1(I,J)=GAM1(I,J)/STR(I) + 150 CONTINUE + + DO 200 K=1,KM + IF(ITOP.EQ.0) GAMS(K)=GAM1(K,KM) + IF(ITOP.EQ.1) GAMS(K)=GAM1(K,1) + Q1(K)=-H00(K)*BJX(K)*GAMS(K) + 200 CONTINUE + DO 400 K=1,KM + Q2(K)=0.0 + DO 350 L=2,KM + FAC1=(BJX(L)+BJX(L-1)-2.0*BJX(K))/2.0 + FAC2=FAC1*ABS(GAM1(K,L)-GAM1(K,L-1)) + Q2(K)=Q2(K)+FAC2 + 350 CONTINUE + Q2(K)=Q2(K)*H00(K) + 400 CONTINUE + + END + +c*********************************************************************** + + subroutine wvrefm(pmy,wvmy,tmy,coeff,lmy,lh2o,llin) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Nov 12, 2008: Calculation of lh2o corrected to avoid lh2o=0 +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none + integer,intent(in):: lmy + integer,intent(out):: lh2o,llin + real,dimension(lmy),intent(in):: pmy + real,dimension(lmy),intent(out):: coeff,wvmy,tmy +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + integer:: l + real,dimension(lmy):: xmy +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Log-pressure above which cooling rates are not calculated but +c extrapolated to 0 over a scale height (15 roughly corresponds to +c 100 km) + real,parameter:: xtop=15. + +c Empirical model of H2O MMR and T at 0-115 km based on Xun's models + integer,parameter:: kz0=116 + real,parameter,dimension(kz0):: x0=(/ + $ -1.3074159E-02, 1.0684384E-01, 2.2952638E-01, 3.5510332E-01, + $ 4.8371642E-01, 6.1551599E-01, 7.5066825E-01, 8.8935186E-01, + $ 1.0317549E+00, 1.1780874E+00, 1.3285728E+00, 1.4833737E+00, + $ 1.6404333E+00, 1.7975341E+00, 1.9545796E+00, 2.1115846E+00, + $ 2.2685412E+00, 2.4254411E+00, 2.5822937E+00, 2.7390828E+00, + $ 2.8957331E+00, 3.0520064E+00, 3.2076342E+00, 3.3625239E+00, + $ 3.5166655E+00, 3.6700616E+00, 3.8227218E+00, 3.9746487E+00, + $ 4.1258476E+00, 4.2763270E+00, 4.4260956E+00, 4.5751261E+00, + $ 4.7233255E+00, 4.8703174E+00, 5.0157147E+00, 5.1593975E+00, + $ 5.3013821E+00, 5.4417006E+00, 5.5803912E+00, 5.7174910E+00, + $ 5.8530322E+00, 5.9870543E+00, 6.1195843E+00, 6.2506551E+00, + $ 6.3803027E+00, 6.5085564E+00, 6.6354559E+00, 6.7611041E+00, + $ 6.8858666E+00, 7.0102588E+00, 7.1345618E+00, 7.2589112E+00, + $ 7.3836434E+00, 7.5092845E+00, 7.6361235E+00, 7.7642453E+00, + $ 7.8936802E+00, 8.0244623E+00, 8.1566209E+00, 8.2901811E+00, + $ 8.4251793E+00, 8.5616468E+00, 8.6996208E+00, 8.8391217E+00, + $ 8.9801974E+00, 9.1228883E+00, 9.2672198E+00, 9.4132390E+00, + $ 9.5609850E+00, 9.7105014E+00, 9.8618275E+00, 1.0014991E+01, + $ 1.0169933E+01, 1.0326467E+01, 1.0484460E+01, 1.0643902E+01, + $ 1.0804806E+01, 1.0967206E+01, 1.1131125E+01, 1.1296597E+01, + $ 1.1463650E+01, 1.1632315E+01, 1.1802627E+01, 1.1974618E+01, + $ 1.2148311E+01, 1.2323674E+01, 1.2500403E+01, 1.2677767E+01, + $ 1.2855241E+01, 1.3032687E+01, 1.3210080E+01, 1.3387417E+01, + $ 1.3564666E+01, 1.3741684E+01, 1.3918284E+01, 1.4094282E+01, + $ 1.4269498E+01, 1.4443745E+01, 1.4616840E+01, 1.4788594E+01, + $ 1.4958815E+01, 1.5127306E+01, 1.5293868E+01, 1.5458278E+01, + $ 1.5620313E+01, 1.5779732E+01, 1.5936241E+01, 1.6089528E+01, + $ 1.6239184E+01, 1.6384648E+01, 1.6525018E+01, 1.6659004E+01, + $ 1.6786726E+01, 1.6908743E+01, 1.7025538E+01, 1.7137535E+01/) + real,parameter,dimension(kz0):: mmr0=(/ + $ 6.3427625E-03, 4.6896568E-03, 3.2016360E-03, 2.2034693E-03, + $ 1.4804843E-03, 9.2871409E-04, 5.4321145E-04, 2.9824653E-04, + $ 1.5777393E-04, 8.5725775E-05, 5.6769328E-05, 3.0951885E-05, + $ 1.6396563E-05, 8.6909902E-06, 5.5927135E-06, 3.2080393E-06, + $ 2.1766575E-06, 1.9823482E-06, 2.2125981E-06, 2.2340431E-06, + $ 2.2576351E-06, 2.2822872E-06, 2.3105531E-06, 2.3412808E-06, + $ 2.3789415E-06, 2.4225076E-06, 2.4790281E-06, 2.5442728E-06, + $ 2.6249287E-06, 2.7176809E-06, 2.8232316E-06, 2.9402314E-06, + $ 3.0660555E-06, 3.1990915E-06, 3.3302645E-06, 3.4635988E-06, + $ 3.5798847E-06, 3.6939696E-06, 3.7870371E-06, 3.8757534E-06, + $ 3.9469313E-06, 4.0144905E-06, 4.0577301E-06, 4.0978281E-06, + $ 4.1199851E-06, 4.1398489E-06, 4.1510213E-06, 4.1606770E-06, + $ 4.1631141E-06, 4.1645934E-06, 4.1611823E-06, 4.1571837E-06, + $ 4.1505526E-06, 4.1435602E-06, 4.1325911E-06, 4.1214015E-06, + $ 4.1073816E-06, 4.0932284E-06, 4.0767109E-06, 4.0601122E-06, + $ 4.0385647E-06, 4.0169676E-06, 3.9888507E-06, 3.9607035E-06, + $ 3.9267745E-06, 3.8928269E-06, 3.8521707E-06, 3.8115032E-06, + $ 3.7608379E-06, 3.7101658E-06, 3.6459496E-06, 3.5817291E-06, + $ 3.4989563E-06, 3.4161811E-06, 3.3081287E-06, 3.2000750E-06, + $ 3.0569701E-06, 2.9138647E-06, 2.7265409E-06, 2.5392176E-06, + $ 2.2999015E-06, 2.0605864E-06, 1.7760898E-06, 1.4915889E-06, + $ 1.2209422E-06, 9.5026912E-07, 7.5322985E-07, 5.5612383E-07, + $ 4.2992454E-07, 3.0360226E-07, 2.3203341E-07, 1.6029976E-07, + $ 1.2252130E-07, 8.4579052E-08, 6.5370065E-08, 4.6036091E-08, + $ 3.6250825E-08, 2.6386714E-08, 2.1301281E-08, 1.6171887E-08, + $ 1.3413245E-08, 1.0631554E-08, 9.0590299E-09, 7.4748183E-09, + $ 6.5369535E-09, 5.5932822E-09, 5.0231776E-09, 4.4502798E-09, + $ 4.0987424E-09, 3.7458969E-09, 3.5280209E-09, 3.3095468E-09, + $ 3.1712338E-09, 3.0326432E-09, 2.9426375E-09, 2.8524963E-09/) + real,parameter,dimension(kz0):: tem0=(/ + $ 2.8815000E+02, 2.8165000E+02, 2.7515000E+02, 2.6865000E+02, + $ 2.6215000E+02, 2.5565000E+02, 2.4915000E+02, 2.4265000E+02, + $ 2.3615000E+02, 2.2965000E+02, 2.2315000E+02, 2.1733000E+02, + $ 2.1665000E+02, 2.1665000E+02, 2.1665000E+02, 2.1665000E+02, + $ 2.1665000E+02, 2.1665000E+02, 2.1666000E+02, 2.1670000E+02, + $ 2.1695000E+02, 2.1763000E+02, 2.1856000E+02, 2.1955000E+02, + $ 2.2055000E+02, 2.2155000E+02, 2.2255000E+02, 2.2355000E+02, + $ 2.2455000E+02, 2.2555000E+02, 2.2656000E+02, 2.2764000E+02, + $ 2.2907000E+02, 2.3126000E+02, 2.3389000E+02, 2.3663000E+02, + $ 2.3938000E+02, 2.4213000E+02, 2.4488000E+02, 2.4763000E+02, + $ 2.5038000E+02, 2.5313000E+02, 2.5588000E+02, 2.5863000E+02, + $ 2.6137000E+02, 2.6411000E+02, 2.6679000E+02, 2.6911000E+02, + $ 2.7036000E+02, 2.7066000E+02, 2.7064000E+02, 2.7021000E+02, + $ 2.6871000E+02, 2.6627000E+02, 2.6357000E+02, 2.6082000E+02, + $ 2.5808000E+02, 2.5532000E+02, 2.5257000E+02, 2.4982000E+02, + $ 2.4707000E+02, 2.4432000E+02, 2.4157000E+02, 2.3882000E+02, + $ 2.3607000E+02, 2.3332000E+02, 2.3057000E+02, 2.2782000E+02, + $ 2.2507000E+02, 2.2233000E+02, 2.1959000E+02, 2.1691000E+02, + $ 2.1448000E+02, 2.1237000E+02, 2.1037000E+02, 2.0840000E+02, + $ 2.0643000E+02, 2.0446000E+02, 2.0249000E+02, 2.0052000E+02, + $ 1.9855000E+02, 1.9658000E+02, 1.9461000E+02, 1.9264000E+02, + $ 1.9070000E+02, 1.8892000E+02, 1.8775000E+02, 1.8739000E+02, + $ 1.8733000E+02, 1.8732000E+02, 1.8732000E+02, 1.8732000E+02, + $ 1.8742000E+02, 1.8771000E+02, 1.8819000E+02, 1.8887000E+02, + $ 1.8976000E+02, 1.9086000E+02, 1.9218000E+02, 1.9373000E+02, + $ 1.9553000E+02, 1.9761000E+02, 1.9998000E+02, 2.0268000E+02, + $ 2.0576000E+02, 2.0929000E+02, 2.1335000E+02, 2.1808000E+02, + $ 2.2374000E+02, 2.3078000E+02, 2.4045000E+02, 2.5245000E+02, + $ 2.6445000E+02, 2.7645000E+02, 2.8845000E+02, 3.0045000E+02/) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Note, in the call from uh2oci the model grid is inversed (going down) + do l=1,lmy + xmy(l)=alog(1.e5/pmy(l)) + enddo +c print*,'www1',pmy + +c Determine the first model layer from the top below or about 100 km + lh2o=lmy+1 + do l=1,lmy + if(xmy(l) <= xtop) then + lh2o=l + exit + endif + enddo + + if(lh2o > lmy) then + write(6,*) '***Warning: Model bottom above H2O cooling region' + write(6,'(2f8.2)') xmy(lmy),xtop + write(6,*) '***Cooling rates will be set to 0' + return + endif + + wvmy(:)=0. + tmy(:)=0. + call splin1(x0(kz0:1:-1),mmr0(kz0:1:-1), + $ xmy(lh2o),wvmy(lh2o),kz0,lmy+1-lh2o) + call splin1(x0(kz0:1:-1),tem0(kz0:1:-1), + $ xmy(lh2o),tmy(lh2o),kz0,lmy+1-lh2o) + +c For linear extrapolation of cooling rates upward of xmy(lh2o), count +c how many model layers are between xmy(lh2o) and xmu(lh2o)+1 and +c calculate extrapolation coefficients + if(lh2o > 1) then + llin=0 + do l=1,lh2o-1 + if(xmy(l) < xmy(lh2o)+1.) then + llin=llin+1 + endif + enddo + endif + coeff(:)=0. + if(llin > 0) then + do l=1,llin + coeff(l)=xmy(lh2o-l)-xmy(lh2o) + enddo + endif + + END subroutine wvrefm + +c*********************************************************************** + + real FUNCTION ZXKTP(T,K,I,N,kus,km,mm4,nq,t77,xkus) + + implicit none + integer,intent(in):: i,k,n,kus,km,mm4,nq + real,intent(in):: t,t77(mm4),xkus(kus,nq,km,mm4) + + integer:: jj,jj1,jj3,jja,jjb + real:: y,dy,xt,WR1(3),WR2(3) + + XT=T + IF(T.LE.T77(1)) XT=T77(1) + IF(T.GT.T77(MM4)) XT=T77(MM4) + JJ1=INT((XT-T77(1))/(T77(2)-T77(1)))+1 + IF(JJ1.LE.1) JJ1=2 + IF(JJ1.GE.MM4) JJ1=MM4-1 + JJA=JJ1-1 + JJB=JJ1+1 + + DO 10 JJ=JJA,JJB + JJ3=JJ-JJA+1 + WR1(JJ3)=T77(JJ) + 10 WR2(JJ3)=ALOG(XKUS(K,N,I,JJ)) + + CALL POLINT(WR1,WR2,3,XT,Y,DY) + ZXKTP=EXP(Y) + + END function zxktp + +c*********************************************************************** diff --git a/gsmphys/h2ohdc.f b/gsmphys/h2ohdc.f new file mode 100644 index 00000000..92339afe --- /dev/null +++ b/gsmphys/h2ohdc.f @@ -0,0 +1,165 @@ + subroutine h2ohdc(ctheta,p0,mmr,grav,mu,h2ohr,lx) +c Subroutine to calculate H2O near-IR heating rates after C.D. Walshaw, +c see Fomichev and Shved (1988). +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c File history +c July 2009: Modified from +c hh2oh.f +c for discrete differencing, upward pressure grid, making heating +c rate -> 0 between 7 and 12 scale heights (as recommended by Victor in +c July 2007). The heating rate is now calculated in W/kg. +c Apr 06 2012 Henry Juang, initial implement for nems +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Formal arguments +c IN: +c ctheta - cosine of solar zenith angle +c p0 - model layer pressure (Pa) grid going up +c mmr - H2O MMR (relative units) on model pressure grid going up +c grav - gravity acceleration (m/s^2) on model pressure grid +c mu - atmospheric molecular mass (g/mol) on model pressure grid +c lx - array dimension + integer,intent(in):: lx + real,intent(in):: ctheta + real,dimension(lx),intent(in):: p0,mmr,grav,mu + +c OUT: +c h2ohr - heating rates (W/kg) on model pressure grid + real,dimension(lx),intent(out):: h2ohr + +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Internal parameters + +c Log-pressure of the uppermost extent of the parameterization around +c xtop = 12 sh as recommended by Victor (July 2007), the corresponding +c number of starting model layer, and the fade-off factor between +c xbot = 7 and xtop. +c ***xbot and xtop are assumed to be inside model domain!*** + real,parameter:: xbot=7.,xtop=12.,rdx=1./(xtop-xbot) + integer:: last + real:: factor(lx) + +c Specific H2O data +c h2omu - molecular mass (g/mol) + real,parameter:: h2omu=18.015 + +c Parameterization data after C.D. Walshaw: +c - inverse reference pressure (1/Pa) + real,parameter:: rpref=1./101325. +c - number of bands + integer,parameter:: iband=8 + +c Optical data +c - solar band fluxes times reference bandwidth (W/m^2) +c - l band parameter (m^2/kg) +c - b band parameter (dimensionless) + real,parameter,dimension(iband):: + $ wfband=(/ + $ 14.3, 14.42, 21.39, 25.84, 9.3526, 6.848, 4.85, 1.3986/), + $ lband= + $ (/.00952, .13, .0335, .769, 2.99, 16.7, .138, 29.2/), +c in Fomichev & Shved (1988) lband(7)=.137 but in Victor's code it's +c .138 + $ bband=(/.26, .27, .26, .258, .305, .312, .3, .33/) + +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Work space + integer:: i,l + real:: p0dp(lx),rodfac,u(lx),work(lx),zeta,wb(lx,iband) + +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c Initialize heating rate + h2ohr(:)=0. + + if(ctheta.gt.0.) then +c Calculate heating, otherwise do nothing. + +c "Rodgers factor" to crudely account for sphericity + rodfac=35./sqrt(1224.*ctheta**2+1.) + +c Scan pressure grid (now every call in case the grid changes), +c find model fade-off layer xbot-xtop (assumed to be fully within model +c domain), where heating rate will be assumed linearly go to 0 and stay +c so above. + work(:)=log(1e5/p0(:)) + do l=1,lx + if(work(l).lt.xbot) then + factor(l)=1. + else + i=l + exit + endif + enddo + do l=i,lx + if(work(l).lt.xtop) then + factor(l)=1.-rdx*(work(l)-xbot) + last=l + else + factor(l)=0. + endif + enddo + +c Begin with vertical-column H2O mass calculation for the entire column + work(:)=mmr(:)/grav(:) + +c Mass above the uppermost model layer assuming hydrostatics (diffusive +c equilibrium + u(lx)=(mu(lx)/h2omu)*p0(lx)*work(lx) + +c Integrate down + do l=lx-1,1,-1 + u(l)=u(l+1)+.5*(work(l+1)+work(l))*(p0(l)-p0(l+1)) + enddo + +c Above l=last the heating is zero + work(last+1:lx)=0. + +c For nonzero-heating layers calculate some more preliminaries +c In the top and bottom layers use one-sided differences + work(last)=ctheta*grav(last)*factor(last)/ + $ (p0(last-1)-p0(last)) + work(1)=ctheta*grav(1)*factor(1)/(p0(1)-p0(2)) + +c In other layers use centered differences + do l=2,last-1 + work(l)=ctheta*grav(l)*factor(l)/(p0(l-1)-p0(l+1)) + enddo + + do l=1,last + +c Slant mass + u(l)=rodfac*u(l) + +c Normalize pressure + p0dp(l)=p0(l)*rpref + enddo + +c Calculate band widths + do i=1,iband + do l=1,last + zeta=(p0dp(l)**bband(i))*sqrt(lband(i)*u(l)) + if(zeta.le.1.) then + wb(l,i)=wfband(i)*zeta + else + wb(l,i)=wfband(i)*(1.+log(zeta)) + endif + enddo + enddo + +c Calculate heating rate (W/kg) where nonzero + do i=1,iband + +c In the top and bottom layers use one-sided differences + h2ohr(last)=h2ohr(last)+ + $ work(last)*(wb(last-1,i)-wb(last,i)) + h2ohr(1)=h2ohr(1)+work(1)*(wb(1,i)-wb(2,i)) + +c In other layers use centered differences + do l=2,last-1 + h2ohr(l)=h2ohr(l)+work(l)*(wb(l-1,i)-wb(l+1,i)) + enddo + enddo + endif + + end subroutine h2ohdc diff --git a/gsmphys/h2ointerp.f90 b/gsmphys/h2ointerp.f90 new file mode 100755 index 00000000..c4b213e2 --- /dev/null +++ b/gsmphys/h2ointerp.f90 @@ -0,0 +1,189 @@ + subroutine read_h2odata (h2o_phys, me, master) + use machine, only: kind_phys + use h2o_def +!--- in/out + logical, intent(in) :: h2o_phys + integer, intent(in) :: me + integer, intent(in) :: master +!--- locals + integer :: i, n, k + real(kind=4), allocatable, dimension(:) :: h2o_lat4, h2o_pres4 + real(kind=4), allocatable, dimension(:) :: h2o_time4, tempin + + if (.not. h2o_phys) then + latsh2o = 1 + levh2o = 1 + h2o_coeff = 1 + timeh2o = 1 + + return + endif + + open(unit=kh2opltc,file='INPUT/global_h2oprdlos.f77', form='unformatted', convert='big_endian') + +!--- read in indices +!--- + read (kh2opltc) h2o_coeff, latsh2o, levh2o, timeh2o + if (me == master) then + write(*,*) 'Reading in h2odata from global_h2oprdlos.f77 ' + write(*,*) ' h2o_coeff = ', h2o_coeff + write(*,*) ' latsh2o = ', latsh2o + write(*,*) ' levh2o = ', levh2o + write(*,*) ' timeh2o = ', timeh2o + endif + +!--- read in data +!--- h2o_lat - latitude of data (-90 to 90) +!--- h2o_pres - vertical pressure level (mb) +!--- h2o_time - time coordinate (days) +!--- + allocate (h2o_lat(latsh2o), h2o_pres(levh2o),h2o_time(timeh2o+1)) + allocate (h2o_lat4(latsh2o), h2o_pres4(levh2o),h2o_time4(timeh2o+1)) + rewind (kh2opltc) + read (kh2opltc) h2o_coeff, latsh2o, levh2o, timeh2o, h2o_lat4, h2o_pres4, h2o_time4 + h2o_pres(:) = h2o_pres4(:) +!--- convert pressure levels from mb to ln(Pa) + h2o_pres(:) = log(100.0*h2o_pres(:)) + h2o_lat(:) = h2o_lat4(:) + h2o_time(:) = h2o_time4(:) + deallocate (h2o_lat4, h2o_pres4, h2o_time4) + +!--- read in h2oplin which is in order of (lattitudes, water levels, coeff number, time) +!--- assume latitudes is on a uniform gaussian grid +!--- + allocate (tempin(latsh2o)) + allocate (h2oplin(latsh2o,levh2o,h2o_coeff,timeh2o)) + DO i=1,timeh2o + do n=1,h2o_coeff + DO k=1,levh2o + READ(kh2opltc) tempin + h2oplin(:,k,n,i) = tempin(:) + ENDDO + enddo + ENDDO + deallocate (tempin) + + close(kh2opltc) + + end subroutine read_h2odata +! +!********************************************************************** +! + subroutine setindxh2o(npts,dlat,jindx1,jindx2,ddy) +! +! May 2015 Shrinivas Moorthi - Prepare for H2O interpolation +! + use machine, only: kind_phys + use h2o_def, only: jh2o => latsh2o, h2o_lat, h2o_time +! + implicit none +! + integer npts + integer, dimension(npts) :: jindx1, jindx2 + real(kind=kind_phys) :: dlat(npts),ddy(npts) +! + integer i,j,lat +! + do j=1,npts + jindx2(j) = jh2o + 1 + do i=1,jh2o + if (dlat(j) < h2o_lat(i)) then + jindx2(j) = i + exit + endif + enddo + jindx1(j) = max(jindx2(j)-1,1) + jindx2(j) = min(jindx2(j),jh2o) + if (jindx2(j) /= jindx1(j)) then + ddy(j) = (dlat(j) - h2o_lat(jindx1(j))) & + / (h2o_lat(jindx2(j)) - h2o_lat(jindx1(j))) + else + ddy(j) = 1.0 + endif +! print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), & +! jindx2(j),' h2o_lat=',h2o_lat(jindx1(j)), & +! h2o_lat(jindx2(j)),' ddy=',ddy(j) + enddo + + return + end +! +!********************************************************************** +! + subroutine h2ointerpol(me,npts,idate,fhour,jindx1,jindx2,h2oplout,ddy) +! +! May 2015 Shrinivas Moorthi - Prepare for H2O interpolation +! + use machine , only : kind_phys + use h2o_def + implicit none + integer j,j1,j2,l,npts,nc,n1,n2 + real(kind=kind_phys) fhour,tem, tx1, tx2 +! + + integer jindx1(npts), jindx2(npts) + integer me,idate(4) + integer idat(8),jdat(8) +! + real(kind=kind_phys) ddy(npts) + real(kind=kind_phys) h2oplout(npts,levh2o,h2o_coeff) + real(kind=kind_phys) rinc(5), rjday + integer jdow, jdoy, jday + real(4) rinc4(5) + integer w3kindreal, w3kindint +! + idat = 0 + idat(1) = idate(4) + idat(2) = idate(2) + idat(3) = idate(3) + idat(5) = idate(1) + rinc = 0. + rinc(2) = fhour + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4 = rinc + CALL W3MOVDAT(RINC4,IDAT,JDAT) + else + CALL W3MOVDAT(RINC,IDAT,JDAT) + endif +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + if (rjday < h2o_time(1)) rjday = rjday+365. +! + n2 = timeh2o + 1 + do j=2,timeh2o + if (rjday < h2o_time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + +! +! if (me .eq. 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday +! &,'h2o_time=',h2o_time(n1),h2o_time(n2) +! + + tx1 = (h2o_time(n2) - rjday) / (h2o_time(n2) - h2o_time(n1)) + tx2 = 1.0 - tx1 + if (n2 > timeh2o) n2 = n2 - timeh2o +! + do nc=1,h2o_coeff + do l=1,levh2o + do j=1,npts + j1 = jindx1(j) + j2 = jindx2(j) + tem = 1.0 - ddy(j) + h2oplout(j,l,nc) = & + tx1*(tem*h2oplin(j1,l,nc,n1)+ddy(j)*h2oplin(j2,l,nc,n1)) & + + tx2*(tem*h2oplin(j1,l,nc,n2)+ddy(j)*h2oplin(j2,l,nc,n2)) + enddo + enddo + enddo +! + return + end diff --git a/gsmphys/h2ophys.f b/gsmphys/h2ophys.f new file mode 100755 index 00000000..cc2aa313 --- /dev/null +++ b/gsmphys/h2ophys.f @@ -0,0 +1,100 @@ + subroutine h2ophys (ix, im, levs, kh2o, dt, h2oi, h2oo, ph2o, + & prsl, h2opltc, h2o_coeff, ldiag3d, h2op,me) +! +! May 2015 - Shrinivas Moorthi - Adaptation of NRL H2O physics for +! stratosphere and mesosphere +! +! this code assumes that both prsl and ph2o are from bottom to top +! as are all other variables +! + use machine , only : kind_phys + implicit none +! + integer im, ix, levs, kh2o, h2o_coeff,me + real(kind=kind_phys) h2oi(ix,levs), h2oo(ix,levs), ph2o(kh2o), + & prsl(ix,levs), tin(ix,levs), + & h2opltc(ix,kh2o,h2o_coeff), + & h2op(ix,levs,h2o_coeff), dt +! + integer k,kmax,kmin,l,i,j + logical ldiag3d, flg(im) + real(kind=kind_phys) pmax, pmin, tem, temp + real(kind=kind_phys) wk1(im), wk2(im), wk3(im), pltc(im,h2o_coeff) + &, h2oib(im) + real, parameter :: prsmax=30000.0, pmaxl=log(prsmax) +! +! write(1000+me,*)' in h2ophys ix=',ix, im, levs, kh2o, dt + do l=1,levs + pmin = 1.0e10 + pmax = -1.0e10 +! + do i=1,im + wk1(i) = log(prsl(i,l)) + pmin = min(wk1(i), pmin) + pmax = max(wk1(i), pmax) + pltc(i,:) = 0.0 + enddo + if (pmin < pmaxl) then + kmax = 1 + kmin = 1 + do k=1,kh2o-1 + if (pmin < ph2o(k)) kmax = k + if (pmax < ph2o(k)) kmin = k + enddo +! + do k=kmin,kmax + temp = 1.0 / (ph2o(k) - ph2o(k+1)) + do i=1,im + flg(i) = .false. + if (wk1(i) < ph2o(k) .and. wk1(i) >= ph2o(k+1)) then + flg(i) = .true. + wk2(i) = (wk1(i) - ph2o(k+1)) * temp + wk3(i) = 1.0 - wk2(i) + endif + enddo + do j=1,h2o_coeff + do i=1,im + if (flg(i)) then + pltc(i,j) = wk2(i) * h2opltc(i,k,j) + & + wk3(i) * h2opltc(i,k+1,j) + endif + enddo + enddo + enddo +! + do j=1,h2o_coeff + do i=1,im + if (wk1(i) < ph2o(kh2o)) then + pltc(i,j) = h2opltc(i,kh2o,j) + endif + if (wk1(i) >= ph2o(1)) then + pltc(i,j) = h2opltc(i,1,j) + endif + enddo + enddo + endif + do i=1,im + if (prsl(i,l) < prsmax) then + h2oib(i) = h2oi(i,l) ! no filling + tem = 1.0 / pltc(i,2) ! 1/teff + h2oo(i,l) = (h2oib(i) + (pltc(i,1)+pltc(i,3)*tem)*dt) + & / (1.0 + tem*dt) + else + h2oo(i,l) = h2oi(i,l) + endif + +! if (i == 1) write(1000+me,*)' h2oib=',h2oib(i),' pltc1=', +! &pltc(i,1),' pltc2=', pltc(i,2),' tem=',tem ,' dt=',dt +! &,' l=',l + enddo +! +! if (ldiag3d) then ! h2o change diagnostics +! do i=1,im +! h2op(i,l,1) = h2op(i,l,1) + pltc(i,1)*dt +! h2op(i,l,2) = h2op(i,l,2) + (h2oo(i,l) - h2oib(i)) +! enddo +! endif + enddo ! vertical loop +! + return + end diff --git a/gsmphys/idea_co2.f b/gsmphys/idea_co2.f new file mode 100644 index 00000000..b65d72f0 --- /dev/null +++ b/gsmphys/idea_co2.f @@ -0,0 +1,73 @@ + subroutine idea_co2(im,ix,levs,nlev,ntrac,grav,cp,adr,adt, & + &dtdt,cosz,dtdth) +!hmhj subroutine idea_co2(im,ix,levs,nlev,ntrac,grav,cp,adr,adt,dir, & +!hmhj&dtdt,cosz,dtdth) +! +! Apr 06 2012 Henry Juang, initial implement for nems +! Dec 13 2012 Jun Wang move init step out of column physics +! Feb 13 2012 Jun Wang move gravity array gg to idea_compistion module +! + use co2pro_mod, only: co2my +! use co2c_mod +! use qnir_mod + use physcons, amo2=>con_amo2, amo3=>con_amo3, & + & amh2o=>con_amw + use idea_composition +! + implicit none +! Argument + integer, intent(in) :: im ! number of data points in adt (first dim) + integer, intent(in) :: ix ! max data points in adt (first dim) + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: nlev ! number of pressure levels in calculation + integer, intent(in) :: ntrac ! number of tracer + real, intent(in) :: adr(ix,levs,ntrac) ! tracer + real, intent(in) :: adt(ix,levs) ! temperature + real, intent(in) :: cp(ix,levs) ! J/kg/k + real, intent(in) :: grav(ix,levs) ! g (m/s2) + real, intent(in) :: cosz(im) !cos solar zenith angle +!hmhj character*(*), intent(in) :: dir ! directory located coef files + real, intent(out) :: dtdt(ix,levs) ! cooling rate k/s + real, intent(out) :: dtdth(ix,levs) ! heating rate k/s +! + real pmod(levs),q_n2(ix,nlev),ma(ix,nlev) & + &,q_o(ix,nlev),q_o2(ix,nlev),hold(levs) + integer i,k,kk +! +! precalling + dtdth=0. + dtdt=0. +! + do i=1,im + do k=k43,levs + kk=k-k43+1 + q_n2(i,kk)=1.-adr(i,k,4)-adr(i,k,5)-adr(i,k,1)-adr(i,k,2) + ma(i,kk)=1./(adr(i,k,4)/amo+adr(i,k,5)/amo2+adr(i,k,1)/amh2o+ & + & adr(i,k,2)/amo3+q_n2(i,kk)/amn2) + q_o(i,kk)=adr(i,k,4)*ma(i,kk)/amo + q_o2(i,kk)=adr(i,k,5)*ma(i,kk)/amo2 + q_n2(i,kk)=q_n2(i,kk)*ma(i,kk)/amn2 + enddo + enddo +! print*,'www2',im,ix,q_o(1:im1,nlev) +! CO2 cooling + call co2cc(ix,im,prlog,adt,levs,prlog(k43), & + & dtdt(1,k43),nlev,ma,q_o,q_o2,q_n2) +! J/kg/s to k/s + do i=1,im + do k=k43,levs + dtdt(i,k)=dtdt(i,k)/cp(i,k) + enddo + dtdt(i,1:k43-1)=0. + enddo +! CO2 heating + do i=1,im + call qnirc(cosz(i),prlog(k43),co2my,hold(k43),nlev) + do k=k43,levs +! dtdth(i,k)=hold(k-k43+1) + dtdth(i,k)=hold(k) + enddo + dtdth(i,1:k43-1)=0. + enddo + return + end diff --git a/gsmphys/idea_composition.f b/gsmphys/idea_composition.f new file mode 100644 index 00000000..f8688325 --- /dev/null +++ b/gsmphys/idea_composition.f @@ -0,0 +1,237 @@ + module idea_composition +!------------------------------------------------------------------------- +! hold composition of O O2 N2 +! Apr 06 2012 Henry Juang, initial implement into NEMS +! Mar 08 2012 Jun Wang, add fields for restart +! Oct 20 2015 Weiyu Yang, move f107 and kp to atmos/phys/wam_f107_kp_mod. +!------------------------------------------------------------------------- + implicit none +!hmhj save + real , parameter:: amo =15.9994 ! molecular wght of O ! (g/mol) + real , parameter:: amn2=28.013 ! molecular wght of N2 + real , parameter:: amno=30.0061 ! molecular wght of N0 + real , parameter:: bz=1.3806505e-23! Boltzmann constant + real prlog150(150),h2ora150(80),o3ra150(80) + real amgm(150),amgms(150) ! global mean wght of mix (g/mol) + real, allocatable:: pr_idea(:), prlog(:), ef(:) + real, allocatable:: h2ora(:),o3ra(:) + real, allocatable:: gg(:), prsilvl(:) + integer nlev_h2o,nlevc_h2o,nlev_co2,k41,k71,k110,k105,k100,k43 + integer k91,k47,k64,k81,k87 +! + data prlog150/-.010495013621173093,-.0047796645053569788, & + &.0017317939011674947, & + &.0091445549523354423,.017575964483718530,.027156409259219756, & + &.038029776798164390,.050354098813263921,.064301975566456532, & + &.080060604331725002,.097831430661753094,.11782928094771801, & + &.1402811398792534,.16542406580956714,.19350235130401269, & + &.22476418567991183,.25945740055444533,.29782445285326098, & + &.34009706723024435,.38649056296119455,.43719785635654262, & + &.49238384410129205,.55218040859471984,.61668213110539583, & + &.68594338857491133,.75997679704427235,.83875307597091064, & + &.92220240072958426,1.0102172332720634,1.1026563113455261, & + &1.1993493125965171,1.3001020446943199,1.4047022170280321, & + &1.5129293855161694,1.6245648325694693,1.7393953508635152, & + &1.8572172092097674,1.9778421006194884,2.1011027392385673, & + &2.2268591758946630,2.3550060174351386,2.4854802051244675, & + &2.6182709767607482,2.7534197208872264,2.8909811818384683, & + &3.0309947994264324,3.1734952229335223,3.3185141840359855, & + &3.4660806887940865,3.6162208681691572,3.7689579941351727, & + &3.9243126000728270,4.0823023952198705,4.2429421890712113, & + &4.4062440367083493,4.5722171074490712,4.7408678113152334, & + &4.9121997598293738,5.0862136813095233,5.2629074813405223, & + &5.4422762630064341,5.6243123514382578,5.8090052129405310, & + &5.9963414712632250,6.1863048973029393,6.3788765414713984, & + &6.5740346053768723,6.7717544276443897,6.9720085218050194, & + &7.1747665967259380,7.3799955384809381,7.5876594664001917, & + &7.7977196240960511,8.0101343615235372,8.2248592986929712, & + &8.4418472650864640,8.6610481622066615,8.8824091352082579, & + &9.1058744786331118,9.3313856279708016,9.5588812882688448, & + &9.7882972917212427,10.019566564224711,10.252619320659370, & + &10.487382934517129,10.723781889667228,10.961737871454984, & + &11.201169705433793,11.441993457513469,11.684122340664617, & + &11.927466717621803,12.171934093143912,12.417429143544323, & + &12.663853787366328,12.911107059366048,13.159085134752051, & + &13.407681405572704,13.656786420959016,13.906287867607862, & + &14.156070558238182,14.406016545469104,14.656016536601980, & + &14.906016520565826,15.156016549153117,15.406016561713120, & + &15.656016540294088,15.906016534936020,16.156016568807406, & + &16.406016534338949,16.656016529668964,16.906016577452895, & + &17.156016561083050,17.406016546123016,17.656016537621376, & + &17.906016506464592,18.156016518186942,18.406016541248878, & + &18.656016561606052,18.906016537947128,19.156016514271940, & + &19.406016513968229,19.656016519436953,19.906016540106812, & + &20.156016505341348,20.406016517771079,20.656016529319292, & + &20.906016501516998,21.156016508903946,21.406016525111486, & + &21.656016521424860,21.906016510407873,22.156016517462234, & + &22.406016507059238,22.656016506270586,22.906016547648477, & + &23.156016547534154,23.406016516157738,23.656016508155140, & + &23.906016513141179,24.156016519666711,24.406016497318937, & + &24.656016492779738,24.906016503952380,25.156016485200560, & + &25.406016484453687,25.656016491410533,25.906016498929535, & + &26.156016525642059,26.406016533196180,27.231955945328760/ +! 71-150 in levs=150 + data h2ora150/4.15074772E-06,4.13699000E-06,4.11797890E-06, & + &4.09487986E-06, & + &4.06858733E-06, 4.03597828E-06, 3.99688515E-06, 3.95067808E-06, & + &3.89717454E-06, 3.83486354E-06, 3.76154928E-06, 3.67776509E-06, & + &3.57952092E-06, 3.45696758E-06, 3.30616948E-06, 3.13086436E-06, & + &2.91936568E-06, 2.64976784E-06, 2.33136751E-06, 1.97812350E-06, & + &1.56715103E-06, 1.18281856E-06, 8.41511396E-07, 5.69260876E-07, & + &3.88780697E-07, 2.50438515E-07,1.54300660E-07, 1.02009581E-07, & + &6.65450034E-08, 4.17382808E-08, 2.82805186E-08, 2.01512556E-08, & + &1.41564448E-08, 1.02806445E-08, 7.94408149E-09, 6.32637731E-09, & + &5.12551203E-09, 4.27811892E-09, 3.70565449E-09, 3.31366890E-09, & + &3.03512593E-09, 2.86004858E-09, 3.14079315E-09, 3.43411317E-09, & + &3.75162719E-09, 4.09541203E-09, 4.46698364E-09, 4.86779007E-09, & + &5.29913960E-09,5.76212751E-09, 6.25754557E-09, 6.78577268E-09, & + &7.34664587E-09, 7.93931252E-09, 8.56206704E-09, 9.21217910E-09, & + &9.88572497E-09, 1.05774394E-08, 1.12806111E-08, 1.19870504E-08, & + &1.26871579E-08, 1.33701220E-08, 1.40242598E-08, 1.46374975E-08, & + &1.51979607E-08, 1.56946171E-08, 1.61178886E-08, 1.64601425E-08, & + &1.67159770E-08, 1.68822374E-08, 1.69577319E-08,1.69426375E-08, & + &1.68375826E-08, 1.66423366E-08, 1.63538713E-08, 1.59631314E-08, & + &1.54486221E-08, 1.47606491E-08, 1.37697900E-08, 6.83803988E-09/ +! +! o3(71-150) + data o3ra150/4.10541952E-06,3.47100766E-06,2.87068966E-06, & + &2.35683753E-06, & + &1.96476323E-06,1.68001584E-06,1.46059012E-06,1.28086944E-06, & + & 1.12287103E-06,9.73440677E-07,8.31057093E-07,6.96823493E-07, & + & 5.70485075E-07,4.54900920E-07,3.51380290E-07,2.59055385E-07, & + & 1.83987938E-07,1.33985182E-07,9.93050813E-08,8.12517455E-08, & + & 1.04879335E-07,1.96984693E-07,3.40876799E-07,5.63920720E-07, & + & 8.83452184E-07,1.23309195E-06,1.61560931E-06,1.90510281E-06, & + & 2.00312741E-06,1.98334669E-06,1.75853471E-06,1.44161553E-06, & + & 1.11576928E-06,7.89776361E-07,5.25719302E-07,3.33307290E-07, & + & 1.90201852E-07,9.50490959E-08,4.25181927E-08,1.71517381E-08, & + & 6.31168787E-09,2.32353325E-09,2.00874504E-09,1.66279638E-09, & + & 1.36930561E-09,1.12419760E-09,9.19829659E-10,7.49814512E-10, & + & 6.08729657E-10,4.91976560E-10,3.95658450E-10,3.16475520E-10, & + & 2.51635148E-10,1.98775150E-10,1.55898314E-10,1.21316667E-10, & + & 9.36041570E-11,7.15566049E-11,5.41579312E-11,4.05517867E-11, & + & 3.00178145E-11,2.19518467E-11,1.58493829E-11,1.12917456E-11, & + & 7.93434889E-12,5.49657616E-12,3.75284443E-12,2.52454277E-12, & + & 1.67265129E-12,1.09096239E-12,6.99914181E-13,4.41092526E-13, & + & 2.72463151E-13,1.64366989E-13,9.62680762E-14,5.41996795E-14, & + & 2.88221148E-14,1.39894852E-14,5.72118432E-15,4.70438733E-16/ +! + end module idea_composition +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! contains +!hmhj subroutine idea_composition_init(levs,ak,bk) + subroutine idea_composition_init(levs,plyr) +!------------------------------------------------------------------------- +! get O O2 N2 composition in idea_composition +!------------------------------------------------------------------------- + use idea_composition + implicit none +! Argument + integer, intent(in) :: levs ! number of pressure levels + real, intent(in) :: plyr(levs) +!hmhj real, intent(in) :: ak(levs+1),bk(levs+1) ! hyb levels +! local + integer k +! + if (.not.allocated(pr_idea)) then + print *,' plyr idea_composition_init ',(plyr(k),k=1,levs) + allocate (pr_idea(levs)) + do k=1,levs + pr_idea(k) = plyr(k)/100. ! mb + enddo + endif +! + allocate (prlog(levs)) +! + do k=1,levs + prlog (k) = log(1000./pr_idea(k)) + print *,' idea_composition_init: k pr_idea prlog ',k, + & pr_idea(k),prlog(k) + enddo +! + allocate (h2ora(levs)) + allocate (o3ra(levs)) +! +! init h2o rad + if(levs.eq.150) then + k41=41 + k110=110 + k71=71 + k105=105 + k100=100 +! co2 + k43=43 +! ion + k91=91 +! merge + k47=47 + k64=64 + k81=81 + k87=87 + else + k71=levs + k81=levs + k87=levs + k91=levs + k100=levs + k105=levs + k110=levs + do k=3,levs-2 + if(prlog(k).ge.prlog150(41).and.prlog(k-1).lt.prlog150(41)) & + & k41=k + if(prlog(k).ge.prlog150(71).and.prlog(k-1).lt.prlog150(71)) & + & k71=k + if(prlog(k).le.prlog150(110).and.prlog(k+1).gt.prlog150(110)) & + & k110=k + if(prlog(k).ge.prlog150(100).and.prlog(k-1).lt.prlog150(100)) & + & k100=k + if(prlog(k).le.prlog150(105).and.prlog(k+1).gt.prlog150(105)) & + & k105=k + if(prlog(k).ge.prlog150(43).and.prlog(k-1).lt.prlog150(43)) & + & k43=k + if(prlog(k).ge.prlog150(91).and.prlog(k-1).lt.prlog150(91)) & + & k91=k + if(prlog(k).ge.prlog150(47).and.prlog(k-1).lt.prlog150(47)) & + & k47=k + if(prlog(k).ge.prlog150(64).and.prlog(k-1).lt.prlog150(64)) & + & k64=k + if(prlog(k).ge.prlog150(81).and.prlog(k-1).lt.prlog150(81)) & + & k81=k + if(prlog(k).ge.prlog150(87).and.prlog(k-1).lt.prlog150(87)) & + & k87=k + enddo + endif + nlev_h2o=k110-k41+1 + nlevc_h2o=levs-k71+1 + nlev_co2=levs-k43+1 + if(levs.eq.150) then + h2ora(k71:levs)=h2ora150 + h2ora(1:k71-1)=0. + o3ra(k71:levs)=o3ra150 + o3ra(1:k71-1)=0. + else + call idea_interp(h2ora150,71,150,80,h2ora,levs) + call idea_interp(o3ra150,71,150,80,o3ra,levs) + endif + return + end subroutine idea_composition_init +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_interp(ain,nps,npn,np,aout,levs) + use idea_composition + implicit none + real ain(np),aout(levs),z(np),z1(levs),dz + integer nps,npn,np,levs,kref,k,i + z(1:np)=prlog150(nps:npn) + z1=prlog + do k=1,levs + kref=0 + do i=1,np-1 + if(z1(k).ge.z(i).and.z1(k).le.z(i+1)) then + kref=i + dz=(z1(k)-z(i))/(z(i+1)-z(i)) + endif + enddo + if(kref.ne.0) aout(k)=dz*ain(kref+1)+(1.-dz)*ain(kref) + enddo + return + end subroutine idea_interp diff --git a/gsmphys/idea_dissipation.f b/gsmphys/idea_dissipation.f new file mode 100644 index 00000000..118895fe --- /dev/null +++ b/gsmphys/idea_dissipation.f @@ -0,0 +1,191 @@ + subroutine idea_phys_dissipation(im,ix,levs,grav,prsi,prsl, & + &adu,adv,adt,o_n,o2_n,n2_n,dtp,cp,dt6dt) +!----------------------------------------------------------------------- +! add temp, wind changes due to viscosity and thermal conductivity +! Apr 06 2012 Henry Juang, initial implement for nems +! Dec 17 2013 Jun Wang, using updated dc_i(not up) in tridiagonal solver +!----------------------------------------------------------------------- + implicit none +! Argument + integer, intent(in) :: im ! number of data points in adt (first dim) + integer, intent(in) :: ix ! max data points in adt (first dim) + integer, intent(in) :: levs ! number of pressure levels + real, intent(in) :: dtp ! time step in second + real, intent(in) :: prsi(ix,levs+1) ! pressure + real, intent(in) :: prsl(ix,levs) ! pressure + real, intent(in) :: grav(ix,levs) ! (m/s2) + real, intent(in) :: o_n(ix,levs) ! number density (/cm3) of O + real, intent(in) :: o2_n(ix,levs) ! number density (/cm3) of O2 + real, intent(in) :: n2_n(ix,levs) ! number density (/cm3) of N2 + real, intent(inout) :: adt(ix,levs) ! temperature + real, intent(inout) :: adu(ix,levs) ! u + real, intent(inout) :: adv(ix,levs) ! v + real, intent(inout) :: dt6dt(ix,levs,6) ! + real, intent(in) :: cp(ix,levs) +! Local variables + real up(ix,levs,3),dudt(ix,levs,3) + integer k,i +! + do k=1,levs + do i=1,im + up(i,k,1)=adu(i,k) + up(i,k,2)=adv(i,k) + up(i,k,3)=adt(i,k) + enddo + enddo + call phys_vis_cond(im,ix,levs,grav,prsi,prsl,up,dudt,o_n,o2_n, & + &n2_n,dtp,cp,dt6dt) + do k=1,levs + do i=1,im + adu(i,k)=adu(i,k)+dudt(i,k,1)*dtp + adv(i,k)=adv(i,k)+dudt(i,k,2)*dtp + adt(i,k)=adt(i,k)+dudt(i,k,3)*dtp + enddo + enddo + return + end subroutine idea_phys_dissipation +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine phys_vis_cond(im,ix,levs,grav,prsi,prsl,up,dudt,o_n, & + &o2_n,n2_n,dtp,cp,dt6dt) +!----------------------------------------------------------------------- +! +! calaulate temp, wind tendency caused by viscosity and thermal conductivity +! +!----------------------------------------------------------------------- + use physcons, rgas=>con_rgas, amo2=>con_amo2 + use machine, only : kind_phys + use idea_composition + implicit none +! +! define some constants + real (kind=kind_phys), parameter:: muo =3.9e-7 ! viscosity coefficient +! of O (kg/m/s) + real (kind=kind_phys), parameter:: muo2=4.03e-7 ! viscosity coefficient +! of O2 (kg/m/s) + real (kind=kind_phys), parameter:: mun2=3.43e-7 ! viscosity coefficient +! of N2 (kg/m/s) + real (kind=kind_phys), parameter:: lao =75.9e-5 ! thermal conductivity +! coefficient of O (W/m/K) + real (kind=kind_phys), parameter:: lao2=56.e-5 ! thermal conductivity +! coefficient of O2(W/m/K) + real (kind=kind_phys), parameter:: lan2=56.e-5 ! thermal conductivity +! coefficient of N2(W/m/K) + real (kind=kind_phys), parameter:: cpo =2.5 !specific heats of o + real (kind=kind_phys), parameter:: cpo2=3.5 !specific heats of o2 + real (kind=kind_phys), parameter:: cpn2=3.5 !specific heats of n2 +! Argument + integer, intent(in) :: im ! number of data points in up,dudt(first dim) + integer, intent(in) :: ix ! max data points in fields + integer, intent(in) :: levs ! number of pressure levels + real, intent(in) :: dtp ! time step in second + real, intent(in) :: prsi(ix,levs+1) ! interface pressure in KPa + real, intent(in) :: prsl(ix,levs) ! layer pressure in KPa + real, intent(in) :: grav(ix,levs) ! (m/s2) + real, intent(in) :: o_n(ix,levs) ! number density of O (/cm3) + real, intent(in) :: o2_n(ix,levs) ! number density of O2 (/cm3) + real, intent(in) :: n2_n(ix,levs) ! number density of N2 (/cm3) + real, intent(in) :: up(ix,levs,3) ! input u v t at dt=0 + real, intent(out):: dudt(ix,levs,3) ! tendency + real, intent(in):: cp(ix,levs) ! + real, intent(inout) :: dt6dt(ix,levs,6) ! +! Local variables + real o_ni(levs+1),o2_ni(levs+1),n2_ni(levs+1) + real ma_i(levs+1),mu_i(levs+1),la_i(levs+1),cp1(levs) + real ac(levs),cc(levs),ec_i(levs+1),dc_i(levs+1) + real coef_i(levs+1,2),t_i(levs+1),hs_i(levs+1) + real partb_i(levs+1),parta(levs,2),hold1,dtp1,hold2 + integer k,i,kk,kk1 +! +! set boundary + partb_i(1)=0. + partb_i(levs+1)=0. + ec_i(levs+1)=0. + dc_i(levs+1)=0. + ac(1)=0. + cc(levs)=0. + dtp1=1./dtp +! +! for each longitude +! + do i=1,im +! get compositions at interface pressure levels + o_ni(1)=o_n(i,1) + o2_ni(1)=o2_n(i,1) + n2_ni(1)=n2_n(i,1) +! + do k=2,levs + o_ni(k)=(o_n(i,k-1)+o_n(i,k))*.5 + o2_ni(k)=(o2_n(i,k-1)+o2_n(i,k))*.5 + n2_ni(k)=(n2_n(i,k-1)+n2_n(i,k))*.5 + enddo +! calculate mean mass and coefficient of mu,lambda, cp, 1./cp, +! at interface pressure + do k=1,levs + hold1=1./(o_ni(k)+o2_ni(k)+n2_ni(k)) + hold2=o_ni(k)*amo+o2_ni(k)*amo2+n2_ni(k)*amn2 + ma_i(k)=hold2*hold1 + mu_i(k)=(o_ni(k)*muo+o2_ni(k)*muo2+n2_ni(k)*mun2)*hold1 + la_i(k)=(o_ni(k)*lao+o2_ni(k)*lao2+n2_ni(k)*lan2)*hold1 + enddo +! at layer + do k=1,levs + cp1(k)=1./cp(i,k) + enddo +! calculate temp in interface pressure levels +! calculate scale height + t_i(1)=up(i,1,3) + t_i(levs+1)=up(i,levs,3) + do k=2,levs + t_i(k)=(up(i,k-1,3)+up(i,k,3))*.5 + hs_i(k)=1000.*rgas*t_i(k)/(ma_i(k)*grav(i,k)) + enddo +! now use t_i**0.69 +! calculate viscosity put in coef(*,1) +! calculate thermal conductivity put in coef(*,2) + do k=1,levs + t_i(k)=t_i(k)**(0.69) + coef_i(k,1)=mu_i(k)*t_i(k) + coef_i(k,2)=la_i(k)*t_i(k) +! dt6dt(i,k,2)=mu_i(k)*t_i(k) +! dt6dt(i,k,6)=la_i(k)*t_i(k) + enddo +! solve tridiagonal problem + do k=1,levs + parta(k,1)=dtp*grav(i,k)*.001/(prsi(i,k)-prsi(i,k+1)) + parta(k,2)=parta(k,1)*cp1(k) + enddo + do kk=1,3 + kk1=kk/3+1 + do k=2,levs + partb_i(k)=coef_i(k,kk1)*prsi(i,k)/ & + & (hs_i(k)*(prsl(i,k-1)-prsl(i,k))) + ac(k)=parta(k,kk1)*partb_i(k) + enddo + do k=1,levs-1 + cc(k)=parta(k,kk1)*partb_i(k+1) + enddo + do k=levs,1,-1 + hold1=1./(1.+ac(k)+cc(k)-cc(k)*ec_i(k+1)) + ec_i(k)=ac(k)*hold1 + dc_i(k)=(cc(k)*dc_i(k+1)+up(i,k,kk))*hold1 + enddo + dudt(i,1,kk)=(dc_i(1)-up(i,1,kk))*dtp1 +! recompute dc_i + do k=2,levs + dc_i(k)=dc_i(k)+ec_i(k)*dc_i(k-1) + dudt(i,k,kk)=(dc_i(k)-up(i,k,kk))*dtp1 + enddo + enddo !kk + do k=1,levs + dt6dt(i,k,5)=dudt(i,k,3) + enddo +! u v changes add to temperature tendency due to energy conservation +! do k=1,levs +! dudt(i,k,3)=dudt(i,k,3)-cp1(k)*(up(i,k,1)*dudt(i,k,1) & +! & +up(i,k,2)*dudt(i,k,2)) +! dt6dt(i,k,6)= -1.*cp1(k)*(up(i,k,1)*dudt(i,k,1) & +! & +up(i,k,2)*dudt(i,k,2)) +! enddo + enddo !i + return + end subroutine phys_vis_cond diff --git a/gsmphys/idea_h2o.f b/gsmphys/idea_h2o.f new file mode 100644 index 00000000..c7dd49ce --- /dev/null +++ b/gsmphys/idea_h2o.f @@ -0,0 +1,95 @@ + subroutine idea_h2o(im,ix,levs,nlev,nlevc,ntrac,grav,cp,adr, & + &adt,dth,cosz,dtc) +! +! Apr 06 2012 Henry Juang, initial implement for nems +! Dec 2012 Jun Wang, move init step out of column physics +! + use physcons, amo2=>con_amo2, amo3=>con_amo3, & + & amh2o=>con_amw + use idea_composition +! + implicit none +! Argument + integer, intent(in) :: im ! number of data points in adt (first dim) + integer, intent(in) :: ix ! max data points in adt (first dim) + integer, intent(in) :: levs ! number of pressure levels in GFS + integer, intent(in) :: nlev ! number of pressure levels in heating + integer, intent(in) :: nlevc ! number of pressure levels in cooling + integer, intent(in) :: ntrac ! number of tracer + real, intent(in) :: adr(ix,levs,ntrac) ! tracer + real, intent(in) :: adt(ix,levs) ! temp (k) + real, intent(in) :: grav(ix,levs) ! (m/s2) + real, intent(in) :: cp(ix,levs) ! J/kg/k + real, intent(in) :: cosz(im) ! cos zenith angle + real, intent(out) :: dtc(ix,levs) ! cooling rate k/s + real, intent(out) :: dth(ix,levs) ! heating rate k/s +! + real pmodi(nlev),ggg(nlev), & + &h2ommr(nlev),mu(nlev),rcp(nlev),dthi(nlev), & + &adrn2,rate,dx + real h2ommrc(nlevc),temp(nlevc),qr(nlevc),qv(nlevc),prpa(nlevc) + integer i,k,k1 +! +! cooling idea pressure level 71-150 up ward + prpa(1:nlevc)=100.*pr_idea(k71:levs) + +! print*,'www1',nlev_h2o,nlevc_h2o,k41,k110,k71,k100,k105 +! print*,'www1',h2ora(71),h2ora(150) +! + dtc=0. + dth=0. +! precalling heating +! gg=g + do k=1,nlev + pmodi(k)=pr_idea(k41-1+k)*100. + enddo + do i=1,im + rate=adr(i,k71,1)/h2ora(k71) + do k=1,nlev + k1=k41-1+k + if(k1.le.k71-1) then + h2ommr(k)=adr(i,k1,1) + else + h2ommr(k)=rate*h2ora(k1) + endif + adrn2=1.-adr(i,k1,4)-adr(i,k1,5)-adr(i,k1,1) & + & -adr(i,k1,2) + ggg(k)=grav(i,k1) + mu(k)=1./(adr(i,k1,4)/amo+adr(i,k1,5)/amo2+ & + & adr(i,k1,1)/amh2o+adr(i,k1,2)/amo3+adrn2/amn2) + rcp(k)=1./cp(i,k1) + h2ommr(k)=max(h2ommr(k),0.) + enddo + dthi=0. +! get heating + call h2ohdc(cosz(i),pmodi,h2ommr,ggg,mu,dthi,nlev) +! + do k=k41,k110 + dth(i,k)=rcp(k-k41+1)*dthi(k-k41+1) + enddo + dth(i,1:k41-1)=0. + enddo +! merge to 0. on top + dx=prlog(k105)-prlog(k100) + do i=1,im + do k=k100+1,k105-1 + dth(i,k)=dth(i,k)*(prlog(k105)-prlog(k))/dx + enddo + do k=k105,levs + dth(i,k)=0. + enddo + enddo +! cooling + do i=1,im + rate=adr(i,k71,1)/h2ora(k71) + do k=1,nlevc + h2ommrc(k)=rate*h2ora(k71-1+k) + h2ommrc(k)=max(h2ommrc(k),0.) + temp(k)=adt(i,k+k71-1) + enddo + call h2occ(temp,prpa,h2ommrc,qr,qv,nlevc) + dtc(i,k71:levs)=qr(1:nlevc)+qv(1:nlevc) + dtc(i,1:k71-1)=0. + enddo + return + end diff --git a/gsmphys/idea_ion.f b/gsmphys/idea_ion.f new file mode 100644 index 00000000..1c483005 --- /dev/null +++ b/gsmphys/idea_ion.f @@ -0,0 +1,1845 @@ +! Apr 06 2012 Henry Juang, initial implement for nems +! Dec 2012 Jun Wang, move init out of column physics +! Doc 21 2015 Weiyu yang, add f10.7 and kp inputted data. +!======================================================== +!= GetIonParams = +!======================================================== + subroutine idea_ion(solhr,cospass,zg,o_n,o2_n,n2_n,cp, & + &adu,adv,adt,dudt,dvdt,dtdt,rho,rlat,rlon,ix,im,levs, & + &dayno,utsec,sda,maglon,maglat,btot,dipang,essa) + use wam_f107_kp_mod, only: f107, kp, kdt_3h + use idea_composition + use physcons, pi => con_pi +! use date_def + implicit none + REAL, PARAMETER ::DTR=3.141592653/180.0 + REAL, INTENT(IN) :: o_n(ix,levs) ! number density O (/m3) + REAL, INTENT(IN) :: o2_n(ix,levs) + REAL, INTENT(IN) :: n2_n(ix,levs) + REAL, INTENT(IN) :: rho(ix,levs) ! mass density (kg/m3) + REAL, INTENT(IN) :: zg(ix,levs) ! height (m) + REAL, INTENT(IN) :: cp(ix,levs) ! (J/kg/k) + REAL, INTENT(IN) :: cospass(im)! cos solar zenith angle (rad) + REAL, INTENT(IN) :: rlat(im) ! latitude (rad) + REAL, INTENT(IN) :: rlon(im) ! longitude (rad) + REAL, INTENT(IN) :: solhr ! universal time (h) + INTEGER, INTENT(IN) :: ix !longitude dim size + INTEGER, INTENT(IN) :: im !number of logitude + INTEGER, INTENT(IN) :: levs ! number of pres grid +! INTEGER, INTENT(IN) :: lev1 ! lowest pres level to start + INTEGER, INTENT(IN) :: dayno !calender day + REAL, INTENT(IN) :: adt(ix,levs) ! temperature (k) + REAL, INTENT(IN) :: adu(ix,levs) ! zonal wind (m/s) + REAL, INTENT(IN) :: adv(ix,levs) ! meridional wind (m/s) +! input Magnetic and electric parameters +! REAL, INTENT(in) :: elx(im) +! REAL, INTENT(in) :: ely(im) !electric field + REAL, INTENT(in) :: maglon(im) !magnetic longitude (rad) + REAL, INTENT(in) :: maglat(im) !magnetic latitude (rad) + REAL, INTENT(in) :: btot(im) !mapgnetic field strength + REAL, INTENT(in) :: dipang(im) !Dip angle (degree) + REAL, INTENT(in) :: essa(im) !magnetic local time + REAL, INTENT(in) :: sda ! solar declination angle (rad) + REAL, INTENT(in) :: utsec !universal time +! output + REAL, INTENT(out) :: dtdt(ix,levs) ! temperature change (k/s) + REAL, INTENT(out) :: dudt(ix,levs) ! zonal wind change (m/s2) + REAL, INTENT(out) :: dvdt(ix,levs) ! meridional change wind (m/s2) +! local + REAL :: f107_local, kp_local + real rlt(im),sza(im),jh(ix,levs) & + &,rinc(5) + INTEGER i,k +! get sza in rad + sza=acos(cospass) +! get local time in rad + rlt=(rlon/(15.*pi/180.)+solhr)/24.*2.*pi +! get ion_drag + f107_local = f107(kdt_3h) + kp_local = kp(kdt_3h) + call GetIonParams(dayno,utsec,f107_local,kp_local,sda,sza,rlat,zg,& + & o_n, o2_n, n2_n,adu,adv,adt,rho,rlt,rlon,ix,im,levs,k91, & + & btot,dipang,maglon,maglat,essa, & + & dudt,dvdt,jh) + do i=1,im + do k=1,levs + dtdt(i,k)=jh(i,k)/cp(i,k) + enddo + enddo + return + end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE GetIonParams(dayno,utsec,f107,kp,sda,sza,rlat,ht, & + & o_n, o2_n, n2_n,adu,adv,adt,rho,rlt,rlon,ix,im,levs,lev1, & + & btot,dipang,maglon,maglat,essa, & + & dudt,dvdt,jh) + use physcons, pi => con_pi + implicit none + REAL, PARAMETER ::DTR=3.141592653/180.0, ELCH=1.602e-19 + REAL, INTENT(IN) :: o_n(ix,levs) ! number density O (/m3) + REAL, INTENT(IN) :: o2_n(ix,levs) + REAL, INTENT(IN) :: n2_n(ix,levs) + REAL, INTENT(IN) :: adt(ix,levs) ! temperature (k) + REAL, INTENT(IN) :: adu(ix,levs) ! zonal wind (m/s) + REAL, INTENT(IN) :: adv(ix,levs) ! meridional wind (m/s) + REAL, INTENT(IN) :: rho(ix,levs) ! mass density (kg/m3) + REAL, INTENT(IN) :: ht(ix,levs) ! geopotential height (m) + REAL, INTENT(IN) :: f107 + REAL, INTENT(IN) :: kp + REAL, INTENT(IN) :: sda ! solar declination angle (rad) + REAL, INTENT(IN) :: sza(im)! solar zenith angle (rad) + REAL, INTENT(IN) :: rlt(im) ! local time (rad) + REAL, INTENT(IN) :: rlat(im) ! latitude (rad) + REAL, INTENT(IN) :: rlon(im) ! longitude (rad) + REAL, INTENT(IN) :: utsec ! universal time (s) +! REAL, INTENT(in) :: elx(im) +! REAL, INTENT(in) :: ely(im) !electric field + REAL, INTENT(in) :: maglon(im) !magnetic longitude (rad) + REAL, INTENT(in) :: maglat(im) !magnetic latitude (rad) + REAL, INTENT(in) :: btot(im) !mapgnetic field strength + REAL, INTENT(in) :: dipang(im) !Dip angle (degree) + REAL, INTENT(in) :: essa(im) !magnetic local time + INTEGER, INTENT(IN) :: dayno !day + INTEGER, INTENT(IN) :: ix !longitude dim size + INTEGER, INTENT(IN) :: im !number of logitude + INTEGER, INTENT(IN) :: levs ! number of pres grid + INTEGER, INTENT(IN) :: lev1 ! lowest pres level to start + + REAL, INTENT(OUT) :: dvdt(ix,levs)!(m/s2) + REAL, INTENT(OUT) :: dudt(ix,levs)!(m/s2) + REAL, INTENT(OUT) :: jh(ix,levs)! (J/kg/s) +! local + real ht1(levs),v1(levs),nden(levs),o2n(levs),on(levs), & + & n2n(levs),elx(im),ely(im),ssa,elz(im),ee1(im), & + & ee2(im),cosdif,sindif,sdip,cdip,btheta,bphi,elecx, & + & elecy,dif,dlat,dlon + INTEGER k,i +! Ion drag variables : +! +! teff(levs) 1d local array of temperature +! pion1(levs) number density O+ +! pion2(levs) number desntiy NO+ +! pion3(levs) number density O2+ +! r +! sigped pedersen conductivity +! sighall hall conductivity +! jphi(levs) eastward curreil +! jth(levs) southward +! rvin(levs) Ion/Neutral collision frequency param +! ramin(levs) mean ion mass +! a5 Meridional ion drag term +! b5 Zonal ion drag term +! c7 Joule heating term +! + REAL :: teff(levs), pion1(levs), pion2(levs) + REAL :: sigped, sighal, pion3(levs) + REAL :: rvin(levs), ramin(levs) + REAL :: r, brad, bth, dip + REAL :: a5, b5, c7 + REAL :: jth,jrad + REAL :: jphi + REAL :: eden(ix,levs) !electron density +!=================================================================== +!= Calculate Electric Field and magnetic field = +!=================================================================== + call idea_geteb(im,ix,dayno,utsec,f107,kp,maglat,maglon, & + &essa,ee1,ee2) +! ee1=0. +! ee2=0. +! =================================================================== +! = Calculate Electron Density = +! =================================================================== +! CHIU ionosphere for electron density (Earth_chiu_model.f90). + DO i = 1,im + do k=1,levs + ht1(k)=ht(i,k) + enddo + CALL EARTH_CHIU_MODEL(sda,sza(i),maglat(i), & + & maglon(i),rlt(i), rlat(i), f107, & + & dipang(i)*DTR, dayno, ht1, eden,i,lev1, & + & levs,ix) + ENDDO +! print*,'chiuok' +! print*,'eden',eden(1,lev1:levs) + +!r================================================================= +!r= Calculate Ion Drag, Joule Heating and Particle = +!r= Precipitation terms = +!r================================================================= + DO i = 1, im + DO k = lev1,levs + nden(k)=o_n(i,k)+o2_n(i,k)+n2_n(i,k) + teff(k) = adt(i,k) + v1(k)=-1.*adv(i,k) ! v1 positive south + on(k)=o_n(i,k) + o2n(k)=o2_n(i,k) + n2n(k)=n2_n(i,k) + enddo + do k=lev1,levs + dudt(i,k) = 0. + dvdt(i,k) = 0. + jh(i,k) = 0. + pion1(k) = on(k) + pion2(k) = 0.5*(o2n(k)+n2n(k)) + pion3(k) = 0.5*(o2n(k)+n2n(k)) + ENDDO +! Get ion neutral collision frequency + CALL IONNEUT(on,o2n,n2n,pion1,pion2,pion3,teff,rvin,ramin,levs, & + &lev1) +! print*,'ionneut ok' +! Calculate ion drag and electron deposition +! jth - N/S electrical conductivity +! jphi - E/W electrical conductivity +! DO k=lev1,levs + dip = dipang(i)*DTR + sdip =sin(dip) !new + cdip =cos(dip) !new +! + elecx =ee2(i)*sdip + elecy =ee1(i) +! + ssa=rlon(i)+(utsec/3600.-12.)*pi/12. + dif =essa(i)*pi/180.-ssa ! check unit + cosdif =cos(dif) + sindif =sin(dif) +! + elz(i) =-1.*ee2(i)*cdip + if(sdip.ge.0.) then + elx(i) =elecx*cosdif-elecy*sindif + ely(i) =elecx*sindif+elecy*cosdif + else + elx(i) =elecx*cosdif+elecy*sindif + ely(i) =-1.*elecx*sindif+elecy*cosdif + endif +! dlat=rlat(i)*180./3.14159 +! dlon=rlon(i)*180./3.14159 +! if(abs(dlat-60.).lt.1..and.abs(dlon-270.).lt. & +! &1.) then +! print*,'www1',utsec,ee1(i),ee2(i),elx(i),ely(i),cosdif, & +! &sindif +! print*,'www2',rlon(i),ssa,essa(i),dif,sdip,elecx,elecy +! endif +! + btheta =-1.*btot(i)*cdip*cosdif !new + bphi =-1.*btot(i)*cdip*sindif !new + bth = btot(i) ! In teslas, so no *1.e-9 + brad = -1.*bth*sdip + DO k=lev1,levs + r = (ramin(k)*rvin(k))/(ELCH*bth) + sigped = (eden(i,k)*ELCH*r)/(bth*(1.0+r**2)) + sighal = sigped*r + jphi = sigped*(ely(i)-v1(k)*brad) & + & - sighal*(elx(i) + adu(i,k)*brad)/sdip !new + jth = sigped*(elx(i) + adu(i,k)*brad) + & + & sighal*(ely(i)-v1(k)*brad)*sdip !new + jrad = sigped*(elz(i) - adu(i,k)*btheta+v1(k)*bphi) & + & -sighal*(ely(i)-v1(k)*brad)*cdip !new + a5 =(jphi*brad-jrad*bphi)/rho(i,k) !new + b5 = -1.*(jth*brad-jrad*btheta)/rho(i,k) !new + c7 =(jth*(elx(i)+adu(i,k)*brad)+ & + & jphi*(ely(i)-v1(k)*brad)+jrad*elz(i))/rho(i,k) !new +! Calculation of ion drag terms END + dvdt(i,k) =-1.* a5 + dudt(i,k) = b5 + jh(i,k) = c7 + ENDDO + DO k=1,lev1-1 + dvdt(i,k) = 0. + dudt(i,k) = 0. + jh(i,k) = 0. + enddo + ENDDO + RETURN + END SUBROUTINE GetIonParams +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + SUBROUTINE IONNEUT(P1,P2,P3,PI1,PI2,PI3, T,VIN,AMIn,NMAx,n0) + + !*** Start of declarations inserted by SPAG + REAL :: a , AMIn , amu , b , factor , P1 , P2 , P3 , & + & PI1 , PI2 , PI3, & + & sum , T , v1 , v2 , VIN + INTEGER :: n , NMAx, n0 + !*** END of declarations inserted by SPAG + DIMENSION P1(NMAx) , P2(NMAx) , P3(NMAx) , T(NMAx) , VIN(NMAx) , & + & AMIn(NMAx) , & + & a(3) , b(3) , PI1(NMAx) , PI2(NMAx), PI3(NMAx) + REAL :: mi1 , mi2, mi3, summol + + DATA mi1 , mi2, mi3/16. , 30., 32./ + !******************************************************************** + ! The following a,b, are cooeficients used to caculate ion-neutral + ! collision frequency. Tim's Thesis 3.5a,3.5b. mjh 1.9.97 + !******************************************************************** + + DATA a/3.42E-11 , 6.66E-10 , 6.82E-10/ + DATA b/2.44E-10 , 4.28E-10 , 4.34E-10/ + amu = 1.66E-27 +!c ** +!c ** + factor = 1.0 +!c ** +!c ** + + + DO 100 n = n0 , NMAx + summol = PI2(n) + PI3(n) + sum = PI1(n) + PI2(n) + PI3(n) + v2 = b(1)*P1(n) + b(2)*P2(n) + b(3)*P3(n) + v1 = a(3)*P3(n) + a(2)*P2(n) + a(1)*P1(n)*factor*SQRT(T(n)) & + & *(1.08-0.139*LOG10(T(n))+4.51E-03*LOG10(T(n))**2) + if(summol.lt.1.e-90) summol=0.0 + if(v1.lt.1.e-90) v1=0.0 + if(v2.lt.1.e-90) v2=0.0 +! if(pi1(n).lt.1.e-90) pi1(n)=0.0 +! if(iout.eq.1) write(6,*) 'here 5',n + VIN(n) = (v1*PI1(n)+v2*summol)*1.E-06/sum + AMIn(n) = (PI1(n)*mi1+PI2(n)*mi2+PI3(n)*mi3)*amu/sum + 100 CONTINUE + + RETURN + END SUBROUTINE IONNEUT +!** $Id: chiu_model.f90,v 1.1.1.1 2006/06/04 18:19:13 cwplot Exp $ +!r +!r chui_model.f Chiu ionosphere, to return electron density. +!r Converted to run F90, but not changed. mjh +!r +!r +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE Earth_CHIU_MODEL(sda,sza,thmag,phimr,rlt,rlat, & + &f107, dip, nday,ht1d,eden3d,ilon,lev1,ht_dim,lon_dim) + + + REAL, INTENT(IN) :: sda, sza, thmag, phimr, rlt + REAL, INTENT(IN) :: rlat, f107, dip + INTEGER, INTENT(IN) :: nday,ht_dim,lon_dim,lev1 + REAL, INTENT(IN) :: ht1d(ht_dim) + + REAL, INTENT(OUT) :: eden3d(lon_dim,ht_dim) + +!*** Start of declarations inserted by SPAG + REAL :: abstmg , beta , cbp , cosrlt , costmg , cosza , dipf , & + & DTR , e , f , flong , g , g5 , g6 , g7 , g8 , gel , gel1 , & + & gsm, a, rh + REAL :: P , pb , PI , qel , rd , rgamma , RHO , rk , rl , & + & rt , s , sap ,sintmg + REAL :: ty1 , ty2 , u , V , w , wr , x , y, alp,rr,fz, fn + INTEGER :: i +!*** End of declarations inserted by SPAG + +!- define parameters + + PARAMETER (PI=3.141592653) + PARAMETER (DTR=PI/180.0) + + DIMENSION f(3) , pb(3) , s(3) , rd(3) , rl(3) , rt(3) , e(3) , & + & u(3) , V(3) , P(3) , flong(3) , dipf(3), alp(3), a(3) & + & ,rh(3), rr(3), fz(3), fn(3) + + REAL :: z(ht_dim) + + INTEGER :: n + +! absolutely no idea what these are. Imported from tucan.f + DATA alp/.5 , .5 , 1./ + DATA p/110. , 180. , 0./ + DATA a/1.36 , 2.44 , 0.66/ + DATA rh/10. , 34. , 0./ + + rho = (f107-50.)/100. + ty = (nday+15.5)*12./365. + IF ( ty > 12.0 ) ty = ty - 12.0 + + abstmg = ABS(THMag) + cosza = COS(SZA) + sintmg = SIN(THMag) + costmg = COS(THMag) + cosrlt = COS(RLT) + + + ty1 = SIN(PI/12.0*TY) + ty2 = COS(PI/6.0*TY) + P(1) = 110. + P(2) = 180. + f(1) = 0.0 + f(2) = 0.0 + pb(1) = 1.0 + pb(2) = 1.0 + s(1) = SQRT(1.0+1.15*RHO) + s(2) = SQRT(1.0+1.24*RHO+0.25*RHO**2) + rl(1) = 1.0 + rl(2) = 1.0 + e(1) = 1.0 + e(2) = 1.0 + flong(1) = 1.0 + flong(2) = 1.0 + dipf(1) = 1.0 + dipf(2) = 1.0 + g5 = SIN(PHImr) + g6 = SIN(PHImr/2.0) + g7 = SQRT(ABS(g5)) + g8 = COS(PHImr/2.0-PI/20.0) + sap = SIN(SDA)*sintmg + f(3) = EXP(-(2.92*SIN(PI/2.0-abstmg))**6) + IF ( THMag <= 0.0 ) THEN + cbp = 0.0 + IF ( g7 /= 0.0 ) cbp = ty1*(0.5*g6-0.5*g5-g6**8)-(1.0+ty1) & + & *ty2*g5/g7*EXP(-4.0*g6*g6) + pb(3) = (2.5+2.0*RHO+ty2*(0.5+(1.3+0.5*RHO)*g8**4) & + & +(1.3+0.5*RHO)*COS(RLT-PI*(1.0+cbp))) & + & *(1.0+0.4*ty1*ty1*EXP(-ty1*g8**4)) + ELSE + wr = EXP(-1.2*(COS(THMag-DTR*23.5*cosrlt)-costmg)) + pb(3) = (2.0+1.0*RHO)*wr*(1.0+0.3*ty1) + ENDIF + s(3) = (1.0+RHO+0.204*RHO**2+0.05*RHO**3) + IF ( RHO > 1.1 ) s(3) = 2.41 + 1.53*(s(3)-2.41)*(sintmg)**2 + P(3) = 240 + 75.0*RHO + 83.0*RHO*sap*costmg + & + & 30.0*COS(RLT-4.5*ABS(THMag)-PI) & + & + 10.0*costmg*COS(PI/3.0*(TY-4.5)) + rd(1) = EXP(2.0*(cosza/ABS(cosza)*SQRT(ABS(cosza))-1.0)) + rd(2) = EXP((1.0+0.5*LOG(1.0+30.0*RHO))*(cosza/ABS(cosza)*SQRT(ABS& + & (cosza))-1.0)) + rd(3) = (0.9+0.32*sap)*(1.0+sap*(COS(RLT+PI/4.0))**2) & + & *EXP(-1.1*(1.0+COS(RLT-0.873))) + qel = 1.0 - 0.15*EXP(-SQRT((12.0*THMag+1.05)**2+(TY/2.0-3.0)**2)) + rl(3) = (1.2-0.5*(costmg)**2) & + & *(1.0+0.05*RHO*(sintmg)**3*COS(PI*TY/6.0)) & + & *(EXP(3.0*COS(0.5*THMag*(SIN(RLT)-1.0))))*qel + w = COS(RLAt+SDA*cosrlt) - COS(RLAt) + rt(1) = EXP(-0.4*w) + rt(2) = EXP(-0.25*w) + beta = 1.3 + 0.139*RHO**2 + 0.009*RHO**3 + rk = 1.0 + 0.085*(COS(THMag-PI/6.0)*(COS(PI/12.0*(TY-2.0))) & + & **3+COS(THMag+PI/4.0)*(COS(PI/12.0*(TY-8.0)))**2) + x = 0.7*(rk+0.178*RHO**2/s(3)*COS(PI/3.0*(TY-4.3))) & + & *EXP(-beta*(COS(THMag+SDA*cosrlt)-costmg)) + y = 0.2*(1.0-SIN(abstmg-0.524))*(1.0+0.6*COS(PI/3.0*(TY-3.94))) & + & *COS(PI/6.0*(TY-1.0)) + (0.13-0.06*SIN(ABS(abstmg-PI/9.0))) & + & *COS(PI/3.*(TY-4.5)) - (0.15+0.3*SIN(abstmg))*(1.-cosrlt) & + & **0.25*(COS(THMag+SDA))**3 + rt(3) = x + y/s(3) + g = (1.0+0.6*SQRT(RHO)-0.2*RHO)*EXP(0.25*(1.0+COS(RLT-4.01))) + gel = (costmg)**8*(COS(abstmg-0.262))**12 + gel1 = 1.0 + 0.05*(0.5-COS(PI*TY/3.0)+COS(PI*TY/6.0)) + e(3) = (1.0-0.4*(costmg)**10) & + & *(1.0+0.6*(costmg)**10*(COS(RLT+PI/4.0))**2)*(1.0+g*gel) & + & *gel1 + rgamma = 1.0 + 0.03*(0.5-COS(PI*TY/3.0)+COS(PI*TY/6.0)) + gsm=0.15-(1.0+RHO)*(SIN(THMag/2.0))**2*EXP(-0.33*(TY-6.0)**2) + flong(3) = 1.0 + 0.1*(costmg)**3*COS(2.0*(PHImr-7.0*PI/18.0)) + dipf(3)=rgamma*(1.0+gsm*EXP(-18.0*(ABS(DIP)-2.0*PI/9.0)**2)) + DO i = 1 , 3 + u(i) = s(i)*rd(i)*rl(i)*rt(i)*e(i)*flong(i)*dipf(i) + V(i) = f(i)*pb(i) + (1.0-f(i))*u(i) + enddo + DO n = lev1 , ht_dim + z(n) = ht1d(n)/1000. + IF ( z(n) <= p(3) ) rh(3) = 2.0*(20.0+0.1*z(n)) + IF ( z(n) > p(3) ) rh(3) = 2.0*(20.0+0.1*p(3)) + DO i = 1 , 3 + rr(i) = (z(n)-p(i))/rh(i) + fz(i) = EXP(alp(i)*(1.0-rr(i)-EXP(-rr(i)))) + fn(i) = a(i)*fz(i)*v(i) + enddo + eden3d(ilon,n) = (fn(1)+fn(2)+fn(3))*1.E11 + ENDDO + do n=1,lev1-1 + eden3d(ilon,n)=0. + enddo + RETURN + END SUBROUTINE EARTH_CHIU_MODEL +! idea + subroutine idea_geteb(im,ix,dayno,utsec,f107,kp,maglat,maglon, & + &essa,ee1,ee2) + use efield + use date_def + use physcons, pi => con_pi + implicit none + integer, intent(in) :: im ! number of data points in efield + integer, intent(in) :: ix ! max data points in efield + integer, intent(in) :: dayno ! calender day + real, intent(in) :: utsec ! second + real, intent(in) :: f107 ! + real, intent(in) :: kp ! + real, intent(in) :: maglat(im) ! magnetic latitude (rad) + real, intent(in) :: maglon(im) ! magnetic longitude (rad) + real, intent(in) :: essa(im) ! degree + real, intent(out) :: ee1(im) ! electric field x direction mV/m + real, intent(out) :: ee2(im) ! electric field y direction mV/m +! character*(*), intent(in) :: dir ! directory located coef files +! local + integer i,k,iref,jref + real utsec_last,dx,dy,aa,bb,maglond,maglatd, & + &ed11(0:nmlon,0:nmlat),ed22(0:nmlon,0:nmlat) +! + data utsec_last/-1./ + save utsec_last,ed11,ed22 +!hmhj save ylatm1,ylonm1 +! initiate +! calculate efield only if diff time step + if(utsec.ne.utsec_last) then + utsec_last=utsec + iday = dayno ! day of year + imo=idate(2) + iday_m=idate(3) + iyear = 1995 + f107d=f107 + ut=utsec/3600. + bz = .433726 - kp*(.0849999*kp + .0810363) & + & + f107d*(.00793738 - .00219316*kp) + by=0. + call get_efield +! print*,'www' +! print'(8f10.4)',potent(0:180,68) + ed11=ed1 + ed22=ed2 +! print*,'ed2',ed2(149,65) + endif +! +! call locate(maglon,maglat,ed1,ed2,elx,ely) + do k=1,im + maglatd=maglat(k)/pi*180. +!hmhj + jref=0 + dy=0.0 + do i=0,nmlat-1 +!hmhj if(maglatd.ge.ylatm1(i)-90..and.maglatd.le.ylatm1(i+1)-90.) & + if(maglatd.ge.ylatm (i)-90..and.maglatd.le.ylatm (i+1)-90.) & + &then + jref=i +!hmhj dy=(maglatd-ylatm1(i)+90.)/(ylatm1(i+1)-ylatm1(i)) + dy=(maglatd-ylatm (i)+90.)/(ylatm (i+1)-ylatm (i)) + endif + enddo +! print*,'wwwlat',k,maglatd,jref,dy +! maglond=maglon(k)/pi*180. + maglond=essa(k)+180. + if(maglond.lt.0.) maglond=maglond+360. + if(maglond.gt.360.) maglond=maglond-360. +!hmhj + iref=0 + dx=0.0 + do i=0,nmlon-1 +!hmhj if(maglond.ge.ylonm1(i).and.maglond.le.ylonm1(i+1)) then + if(maglond.ge.ylonm (i).and.maglond.le.ylonm (i+1)) then + iref=i +!hmhj dx=(maglond-ylonm1(i))/(ylonm1(i+1)-ylonm1(i)) + dx=(maglond-ylonm (i))/(ylonm (i+1)-ylonm (i)) + endif + enddo +! print*,'wwwlon',k,maglond,iref,dx + aa=(1.-dx)*ed11(iref,jref)+dx*ed11(iref+1,jref) + bb=(1.-dx)*ed11(iref,jref+1)+dx*ed11(iref+1,jref+1) + ee1(k)=(1.-dy)*aa+dy*bb + aa=(1.-dx)*ed22(iref,jref)+dx*ed22(iref+1,jref) + bb=(1.-dx)*ed22(iref,jref+1)+dx*ed22(iref+1,jref+1) + ee2(k)=(1.-dy)*aa+dy*bb +! if(ely(k).gt.100.) print*,'ely',utsec,ed22(iref,jref), & +! &ed22(iref+1,jref),ed22(iref+1,jref),ed22(iref+1,jref+1), & +! &maglond,maglatd,iref,jref +! if(ely(k).gt.100.) ely(k)=0. + enddo +! ee1=1000.*ee1 +! ee2=1000.*ee2 +! correct direction? 365.25day? + return + end +! +!r=========================================================== +!r= Earth Electric and Magnetic Field +!r=========================================================== +!r + SUBROUTINE getmag(ix,im,utsec,rlat,rlon,sda, & + &btot,dipang,maglon,maglat,essa) + + use physcons, pi => con_pi + IMPLICIT NONE + +! REAL(prcn) high_lat_limit Limit in degrees above +! which foster used. Below this limit, Richmond +! field used +! real, PARAMETER ::high_lat_limit=60. + real, PARAMETER:: R0e = 6.370E06 + real, PARAMETER:: DTR = pi/180. + real, PARAMETER:: ELCH = 1.062e-19 +! Input parameters + INTEGER, INTENT(IN) :: ix !longitude dimension + INTEGER, INTENT(IN) :: im !number of longitude + REAL, INTENT(IN) :: utsec !UT second + REAL, INTENT(IN) :: rlat(im) ! geo latitude (rad) + REAL, INTENT(IN) :: rlon(im) ! geo longitude (rad) + REAL, INTENT(IN) :: sda ! solar diclination angle (rad) +! Output Magnetic and electric parameters +! REAL, INTENT(OUT) :: elx(im) +! REAL, INTENT(OUT) :: ely(im) !electric field + REAL, INTENT(OUT) :: maglon(im) !magnetic longitude (rad) + REAL, INTENT(OUT) :: maglat(im) !magnetic latitude (rad) + REAL, INTENT(OUT) :: btot(im) !mapgnetic field strength + REAL, INTENT(OUT) :: dipang(im) !Dip angle (degree) + REAL, INTENT(OUT) :: essa(im) !magnetic local time +! Local + real cormag(im),cmorg(im) + integer i +! set elx ely zero first +! elx=0. +! ely=0. +! get cormag btot dipang in grid + call interp_field(ix,im,rlat,rlon,cormag,btot,dipang) +! get maglon,maglat + call SPOLE(ix,im,RLAT,rlon,utsec,SDA,maglon,ESSA,CMORG) + do i=1,im + maglat(i)=pi/2.-cormag(i)*DTR + enddo + return + end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine interp_field(ix,im,rlat,rlon,cormago,btoto,dipango) + implicit none + integer,intent(in) :: ix ! max number of longitude + integer,intent(in) :: im ! number of longitude + real, intent(in) :: rlat(im) ! latitude (rad) + real, intent(in) :: rlon(im) ! longitude (rad) + real, intent(out) :: cormago(im),btoto(im),dipango(im) ! field value +! local variable + real cormag(20,91),btot(20,91),dipang(20,91),glat(91),glon(20) + real dll,dl,ddlat,ddlon,a1,a2,b1,b2,aa,bb + integer i,iref,jref,jref1 + data cormag/163.68,163.68,163.68,163.68,163.68, & + &163.68,163.68,163.68,163.68,163.68, & + &163.68,163.68,163.68,163.68,163.68, & + &163.68,163.68,163.68,163.68,163.68, & + &162.60,163.12,163.64,164.18,164.54, & + &164.90,165.16,165.66,166.00,165.86, & + &165.20,164.38,163.66,162.94,162.42, & + &162.00,161.70,161.70,161.80,162.14, & + &161.20,162.18,163.26,164.44,165.62, & + &166.60,167.42,167.80,167.38,166.82, & + &166.00,164.66,163.26,162.16,161.18, & + &160.40,159.94,159.80,159.98,160.44, & + &159.80,161.14,162.70,164.50,166.26, & + &167.90,169.18,169.72,169.36,168.24, & + &166.70,164.80,162.90,161.18,159.74, & + &158.60,157.94,157.80,157.98,158.72, & + &158.40,160.10,162.02,164.28,166.64, & + &169.00,170.80,171.72,171.06,169.46, & + &167.10,164.64,162.18,160.02,158.20, & + &156.80,156.04,155.80,156.16,157.02, & + &157.00,158.96,161.24,163.86,166.72, & + &169.80,172.42,173.72,172.82,170.34, & + &167.30,164.22,161.34,158.74,156.60, & + &155.00,154.08,153.90,154.36,155.36, & + &155.50,157.72,160.36,163.32,166.60, & + &170.20,173.70,175.64,174.18,170.80, & + &167.10,163.56,160.24,157.36,154.96, & + &153.10,152.08,151.92,152.46,153.76, & + &154.10,156.52,159.36,162.52,166.24, & + &170.30,174.62,177.48,175.04,170.82, & + &166.60,162.70,159.02,155.88,153.22, & + &151.20,150.08,149.92,150.64,152.20, & + &152.80,155.32,158.28,161.70,165.58, & + &170.00,174.84,178.46,175.18,170.38, & + &165.80,161.64,157.80,154.38,151.52, & + &149.30,148.18,148.02,148.92,150.60, & + &151.40,154.08,157.18,160.68,164.78, & + &169.40,174.34,177.44,174.28,169.44, & + &164.70,160.34,156.30,152.78,149.72, & + &147.40,146.18,146.04,147.12,149.04, & + &150.10,152.88,156.00,159.58,163.78, & + &168.50,173.28,175.60,172.86,168.14, & + &163.40,158.98,154.88,151.10,147.98, & + &145.50,144.18,144.14,145.40,147.48, & + &148.80,151.68,154.88,158.48,162.68, & + &167.40,171.76,173.60,171.12,166.68, & + &162.00,157.48,153.28,149.50,146.18, & + &143.50,142.18,142.24,143.68,145.98, & + &147.50,150.54,153.68,157.28,161.42, & + &166.10,170.10,171.48,169.22,164.98, & + &160.40,155.88,151.68,147.80,144.34, & + &141.60,140.18,140.26,141.98,144.62, & + &146.30,149.34,152.48,155.98,160.08, & + &164.60,168.34,169.38,167.20,163.18, & + &158.60,154.18,149.98,146.02,142.54, & + &139.70,138.18,138.46,140.26,143.16, & + &145.10,148.14,151.18,154.60,158.68, & + &163.10,166.48,167.28,165.18,161.32, & + &156.90,152.48,148.28,144.32,140.74, & + &137.80,136.22,136.48,138.64,141.76, & + &143.90,146.98,149.98,153.30,157.24, & + &161.40,164.52,165.16,162.86,159.42, & + &155.00,150.68,146.48,142.52,138.94, & + &135.90,134.22,134.68,137.02,140.40, & + &142.70,145.84,148.76,151.92,155.74, & + &159.70,162.52,162.96,160.98,157.42, & + &153.10,148.84,144.68,140.82,137.20, & + &134.00,132.32,132.80,135.42,139.10, & + &141.60,144.74,147.46,150.52,154.20, & + &158.00,160.46,160.76,158.86,155.36, & + &151.20,146.94,142.88,139.02,135.40, & + &132.10,130.32,131.00,133.80,137.74, & + &140.50,143.58,146.24,149.12,152.60, & + &156.20,158.40,158.66,156.76,153.36, & + &149.30,145.04,141.08,137.30,133.60, & + &130.30,128.42,129.12,132.28,136.44, & + &139.30,142.48,144.94,147.64,150.48, & + &154.30,156.34,156.36,154.56,151.26, & + &147.30,143.14,139.20,135.50,131.90, & + &128.40,126.52,127.32,130.76,135.18, & + &138.20,141.28,143.72,146.24,149.26, & + &152.40,154.24,154.16,152.36,149.16, & + &145.30,141.24,137.30,133.70,130.10, & + &126.60,124.62,125.54,129.16,133.92, & + &137.10,140.18,142.42,144.66,147.62, & + &150.50,152.18,151.96,150.16,147.10, & + &143.30,139.24,135.50,131.90,128.36, & + &124.80,122.72,123.74,127.64,132.62, & + &135.90,139.02,141.12,143.18,145.92, & + &148.60,149.98,149.76,148.04,145.00, & + &141.20,137.30,133.60,130.10,126.60, & + &123.00,120.86,121.96,126.12,131.36, & + &134.80,137.88,139.80,141.68,144.08, & + &146.60,147.88,147.56,145.84,142.90, & + &139.20,135.30,131.70,128.28,124.86, & + &121.30,118.96,120.18,124.70,130.16, & + &133.60,136.72,138.48,140.10,142.38, & + &144.60,145.72,145.34,143.64,140.80, & + &137.10,133.30,129.72,126.48,123.10, & + &119.50,117.16,118.48,123.18,128.86, & + &132.40,135.42,137.08,138.50,140.54, & + &142.60,143.52,143.06,141.44,138.70, & + &135.10,131.30,127.82,124.58,121.40, & + &117.70,115.26,116.70,121.66,127.60, & + &131.20,134.22,135.66,136.82,138.70, & + &140.60,141.36,140.86,139.24,136.50, & + &133.00,129.30,125.92,122.78,119.60, & + &116.00,113.40,114.92,120.16,126.30, & + &130.00,132.92,134.24,135.14,136.80, & + &138.60,139.16,138.64,137.12,134.40, & + &130.90,127.20,123.92,120.96,117.90, & + &114.20,111.56,113.12,118.64,124.90, & + &128.70,131.56,132.74,133.44,134.90, & + &136.50,137.00,136.36,134.82,132.30, & + &128.70,125.16,121.94,119.06,116.10, & + &112.50,109.70,111.42,117.14,123.60, & + &127.30,130.16,131.22,131.66,133.00, & + &134.50,134.80,134.14,132.62,130.14, & + &126.60,123.06,119.94,117.16,114.30, & + &110.70,107.80,109.64,115.62,122.24, & + &125.90,128.76,129.62,129.96,131.06, & + &132.40,132.60,131.86,130.42,128.00, & + &124.50,120.96,117.96,115.26,112.54, & + &108.90,105.94,107.86,114.02,120.84, & + &124.05,126.79,127.55,127.83,128.90, & + &130.21,130.41,129.71,128.33,125.96, & + &122.49,118.96,115.97,113.26,110.52, & + &106.89,104.01,106.00,112.21,119.06, & + &122.19,124.82,125.48,125.69,126.73, & + &128.03,128.22,127.55,126.23,123.92, & + &120.47,116.97,113.97,111.26,108.50, & + &104.89,102.08,104.14,110.41,117.29, & + &120.34,122.85,123.40,123.56,124.57, & + &125.84,126.03,125.40,124.14,121.88, & + &118.46,114.97,111.98,109.26,106.48, & + &102.88,100.15,102.28,108.60,115.51, & + &118.49,120.88,121.33,121.42,122.40, & + &123.65,123.84,123.24,122.04,119.83, & + &116.45,112.97,109.98,107.26,104.46, & + &100.87, 98.22,100.42,106.79,113.74, & + &116.63,118.91,119.26,119.29,120.24, & + &121.47,121.65,121.09,119.95,117.79, & + &114.43,110.98,107.99,105.26,102.44, & + & 98.87, 96.29, 98.56,104.98,111.96, & + &114.78,116.94,117.19,117.15,118.07, & + &119.28,119.46,118.93,117.86,115.75, & + &112.42,108.98,106.00,103.26,100.42, & + & 96.86, 94.36, 96.70,103.18,110.19, & + &112.93,114.97,115.12,115.02,115.91, & + &117.09,117.27,116.78,115.76,113.71, & + &110.41,106.98,104.00,101.26, 98.40, & + & 94.85, 92.43, 94.84,101.37,108.41, & + &111.07,113.00,113.04,112.88,113.74, & + &114.91,115.08,114.62,113.67,111.67, & + &108.39,104.99,102.01, 99.26, 96.38, & + & 92.85, 90.51, 92.97, 99.56,106.64, & + &109.22,111.03,110.97,110.75,111.58, & + &112.72,112.89,112.47,111.57,109.63, & + &106.38,102.99,100.01, 97.26, 94.36, & + & 90.84, 88.58, 91.11, 97.75,104.86, & + &107.37,109.06,108.90,108.61,109.41, & + &110.53,110.70,110.31,109.48,107.59, & + &104.37,100.99, 98.02, 95.26, 92.34, & + & 88.83, 86.65, 89.25, 95.95,103.09, & + &105.51,107.09,106.83,106.48,107.25, & + &108.35,108.51,108.16,107.39,105.55, & + &102.35, 99.00, 96.03, 93.26, 90.32, & + & 86.83, 84.72, 87.39, 94.14,101.31, & + &103.66,105.12,104.76,104.34,105.08, & + &106.16,106.32,106.00,105.29,103.50, & + &100.34, 97.00, 94.03, 91.26, 88.30, & + & 84.82, 82.79, 85.53, 92.33, 99.54, & + &101.81,103.15,102.68,102.21,102.92, & + &103.97,104.13,103.85,103.20,101.46, & + & 98.33, 95.00, 92.04, 89.26, 86.28, & + & 82.81, 80.86, 83.67, 90.52, 97.76, & + & 99.95,101.18,100.61,100.07,100.75, & + &101.79,101.94,101.69,101.10, 99.42, & + & 96.31, 93.01, 90.04, 87.26, 84.26, & + & 80.81, 78.93, 81.81, 88.72, 95.99, & + & 98.10, 99.21, 98.54, 97.94, 98.59, & + & 99.60, 99.75, 99.54, 99.01, 97.38, & + & 94.30, 91.01, 88.05, 85.26, 82.24, & + & 78.80, 77.00, 79.95, 86.91, 94.21, & + & 96.25, 97.24, 96.47, 95.81, 96.43, & + & 97.41, 97.56, 97.39, 96.92, 95.34, & + & 92.29, 89.01, 86.06, 83.26, 80.22, & + & 76.79, 75.07, 78.09, 85.10, 92.43, & + & 94.39, 95.27, 94.40, 93.67, 94.26, & + & 95.23, 95.37, 95.23, 94.82, 93.30, & + & 90.27, 87.02, 84.06, 81.26, 78.20, & + & 74.79, 73.14, 76.23, 83.30, 90.66, & + & 92.54, 93.30, 92.32, 91.54, 92.10, & + & 93.04, 93.18, 93.08, 92.73, 91.26, & + & 88.26, 85.02, 82.07, 79.26, 76.18, & + & 72.78, 71.21, 74.37, 81.49, 88.88, & + & 90.69, 91.33, 90.25, 89.40, 89.93, & + & 90.85, 90.99, 90.92, 90.63, 89.21, & + & 86.25, 83.02, 80.07, 77.26, 74.16, & + & 70.77, 69.28, 72.51, 79.68, 87.11, & + & 88.83, 89.36, 88.18, 87.27, 87.77, & + & 88.67, 88.80, 88.77, 88.54, 87.17, & + & 84.23, 81.03, 78.08, 75.26, 72.14, & + & 68.77, 67.35, 70.65, 77.87, 85.33, & + & 86.98, 87.39, 86.11, 85.13, 85.60, & + & 86.48, 86.61, 86.61, 86.45, 85.13, & + & 82.22, 79.03, 76.09, 73.26, 70.12, & + & 66.76, 65.42, 68.79, 76.07, 83.56, & + & 85.13, 85.42, 84.04, 83.00, 83.44, & + & 84.29, 84.42, 84.46, 84.35, 83.09, & + & 80.21, 77.03, 74.09, 71.26, 68.10, & + & 64.75, 63.49, 66.93, 74.26, 81.78, & + & 83.27, 83.45, 81.96, 80.86, 81.27, & + & 82.11, 82.23, 82.30, 82.26, 81.05, & + & 78.19, 75.04, 72.10, 69.26, 66.08, & + & 62.75, 61.57, 65.06, 72.45, 80.01, & + & 81.42, 81.48, 79.89, 78.73, 79.11, & + & 79.92, 80.04, 80.15, 80.16, 79.01, & + & 76.18, 73.04, 70.10, 67.26, 64.06, & + & 60.74, 59.64, 63.20, 70.64, 78.23, & + & 79.57, 79.51, 77.82, 76.59, 76.94, & + & 77.73, 77.85, 77.99, 78.07, 76.97, & + & 74.17, 71.04, 68.11, 65.26, 62.04, & + & 58.73, 57.71, 61.34, 68.84, 76.46, & + & 77.71, 77.54, 75.75, 74.46, 74.78, & + & 75.55, 75.66, 75.84, 75.98, 74.93, & + & 72.15, 69.05, 66.12, 63.26, 60.02, & + & 56.73, 55.78, 59.48, 67.03, 74.68, & + & 75.86, 75.57, 73.68, 72.32, 72.61, & + & 73.36, 73.47, 73.68, 73.88, 72.88, & + & 70.14, 67.05, 64.12, 61.26, 58.00, & + & 54.72, 53.85, 57.62, 65.22, 72.91, & + & 74.01, 73.60, 71.60, 70.19, 70.45, & + & 71.17, 71.28, 71.53, 71.79, 70.84, & + & 68.13, 65.05, 62.13, 59.26, 55.98, & + & 52.71, 51.92, 55.76, 63.41, 71.13, & + & 72.15, 71.63, 69.53, 68.05, 68.28, & + & 68.99, 69.09, 69.37, 69.69, 68.80, & + & 66.11, 63.06, 60.13, 57.26, 53.96, & + & 50.71, 49.99, 53.90, 61.61, 69.36, & + & 70.30, 69.66, 67.46, 65.92, 66.12, & + & 66.80, 66.90, 67.22, 67.60, 66.76, & + & 64.10, 61.06, 58.14, 55.26, 51.94, & + & 48.70, 48.06, 52.04, 59.80, 67.58, & + & 67.70, 67.06, 65.08, 63.72, 63.98, & + & 64.60, 64.80, 65.12, 65.60, 64.86, & + & 62.40, 59.26, 56.24, 53.18, 49.84, & + & 46.60, 46.12, 50.12, 57.52, 64.80, & + & 64.90, 64.42, 62.70, 61.62, 61.78, & + & 62.40, 62.60, 63.04, 63.58, 63.00, & + & 60.60, 57.46, 54.42, 51.18, 47.70, & + & 44.60, 44.22, 48.02, 55.06, 61.92, & + & 62.10, 61.72, 60.32, 59.50, 59.68, & + & 60.20, 60.46, 60.94, 61.58, 61.00, & + & 58.70, 55.66, 52.52, 49.18, 45.60, & + & 42.50, 42.22, 46.00, 52.60, 58.98, & + & 59.20, 59.18, 58.12, 57.32, 57.48, & + & 58.00, 58.30, 58.84, 59.48, 59.04, & + & 56.90, 53.86, 50.62, 47.10, 43.50, & + & 40.50, 40.28, 43.98, 50.22, 56.18, & + & 56.40, 56.64, 55.84, 55.20, 55.38, & + & 55.80, 56.16, 56.84, 57.48, 57.04, & + & 55.10, 52.06, 48.70, 45.10, 41.40, & + & 38.40, 38.28, 41.88, 47.94, 53.44, & + & 53.70, 54.14, 53.56, 53.10, 53.24, & + & 53.70, 54.06, 54.74, 55.38, 55.14, & + & 53.20, 50.26, 46.80, 43.10, 39.34, & + & 36.40, 36.38, 39.96, 45.56, 50.84, & + & 51.10, 51.70, 51.36, 51.00, 51.14, & + & 51.50, 51.96, 52.64, 53.38, 53.08, & + & 51.30, 48.36, 44.90, 41.02, 37.24, & + & 34.40, 34.38, 37.86, 43.28, 48.20, & + & 48.50, 49.26, 49.18, 48.90, 49.04, & + & 49.40, 49.86, 50.64, 51.28, 51.08, & + & 49.40, 46.46, 42.98, 39.02, 35.14, & + & 32.40, 32.48, 35.72, 41.00, 45.70, & + & 46.00, 46.96, 46.98, 46.80, 46.94, & + & 47.30, 47.76, 48.54, 49.28, 49.08, & + & 47.40, 44.56, 41.08, 37.02, 33.14, & + & 30.40, 30.58, 33.84, 38.72, 43.20, & + & 43.50, 44.62, 44.80, 44.80, 44.94, & + & 45.20, 45.76, 46.54, 47.18, 46.98, & + & 45.50, 42.66, 39.08, 35.02, 31.14, & + & 28.40, 28.58, 31.82, 36.52, 40.80, & + & 41.20, 42.32, 42.54, 42.70, 42.84, & + & 43.20, 43.66, 44.44, 45.08, 44.98, & + & 43.50, 40.76, 37.08, 33.04, 29.04, & + & 26.40, 26.68, 29.82, 34.34, 38.40, & + & 38.80, 40.12, 40.60, 40.70, 40.84, & + & 41.10, 41.62, 42.34, 42.98, 42.88, & + & 41.50, 38.76, 35.18, 31.04, 27.14, & + & 24.50, 24.78, 27.70, 32.14, 36.06, & + & 36.50, 37.88, 38.50, 38.68, 38.84, & + & 39.10, 39.56, 40.34, 40.88, 40.82, & + & 39.40, 36.76, 33.18, 29.12, 25.14, & + & 22.50, 22.88, 25.90, 29.96, 33.86, & + & 34.30, 35.68, 36.42, 36.68, 36.84, & + & 37.10, 37.56, 38.24, 38.88, 38.72, & + & 37.40, 34.76, 31.18, 27.12, 23.14, & + & 20.60, 20.98, 23.90, 27.88, 31.66, & + & 32.10, 33.58, 34.32, 34.68, 34.84, & + & 35.10, 35.56, 36.24, 36.78, 36.62, & + & 35.30, 32.72, 29.18, 25.14, 21.24, & + & 18.70, 19.08, 21.90, 25.88, 29.42, & + & 29.90, 31.48, 32.32, 32.68, 32.84, & + & 33.10, 33.56, 34.22, 34.68, 34.42, & + & 33.20, 30.72, 27.28, 23.22, 19.34, & + & 16.80, 17.24, 20.00, 23.78, 27.32, & + & 27.70, 29.38, 30.24, 30.68, 30.94, & + & 31.20, 31.66, 32.22, 32.58, 32.32, & + & 31.10, 28.62, 25.28, 21.32, 17.48, & + & 15.00, 15.38, 18.18, 21.80, 25.22, & + & 25.70, 27.28, 28.24, 28.78, 29.04, & + & 29.30, 29.66, 30.22, 30.50, 30.22, & + & 29.00, 26.62, 23.30, 19.42, 15.64, & + & 13.10, 13.54, 16.28, 19.80, 23.12, & + & 23.60, 25.24, 26.24, 26.78, 27.14, & + & 27.40, 27.76, 28.22, 28.40, 28.12, & + & 26.80, 24.52, 21.30, 17.52, 13.78, & + & 11.30, 11.74, 14.48, 17.90, 21.12, & + & 21.60, 23.24, 24.34, 24.88, 25.24, & + & 25.50, 25.86, 26.22, 26.40, 25.98, & + & 24.70, 22.48, 19.40, 15.72, 12.04, & + & 9.50, 9.94, 12.58, 16.02, 19.12, & + & 19.60, 21.24, 22.34, 22.98, 23.34, & + & 23.70, 24.00, 24.30, 24.40, 23.88, & + & 22.60, 20.48, 17.52, 14.00, 10.34, & + & 7.80, 8.18, 10.88, 14.22, 17.18, & + & 17.60, 19.34, 20.44, 21.16, 21.54, & + & 21.90, 22.16, 22.40, 22.32, 21.78, & + & 20.60, 18.48, 15.62, 12.20, 8.68, & + & 6.00, 6.44, 9.18, 12.42, 15.28, & + & 15.80, 17.44, 18.54, 19.26, 19.74, & + & 20.10, 20.30, 20.50, 20.32, 19.72, & + & 18.50, 16.54, 13.84, 10.68, 7.14, & + & 4.40, 4.74, 7.58, 10.74, 13.48, & + & 14.00, 15.54, 16.74, 17.46, 17.94, & + & 18.30, 18.50, 18.58, 18.32, 17.72, & + & 16.50, 14.64, 12.24, 9.18, 5.84, & + & 2.90, 3.30, 6.16, 9.14, 11.84, & + & 12.30, 13.78, 14.94, 15.66, 16.24, & + & 16.50, 16.70, 16.70, 16.42, 15.78, & + & 14.60, 12.90, 10.66, 7.86, 4.88, & + & 1.60, 1.72, 4.96, 7.84, 10.24, & + & 10.70, 12.14, 13.24, 13.96, 14.44, & + & 14.80, 14.90, 14.88, 14.52, 13.92, & + & 12.80, 11.30, 9.28, 6.94, 4.32, & + & 1.80, 1.94, 4.34, 6.78, 8.94, & + & 9.40, 10.58, 11.64, 12.36, 12.74, & + & 13.10, 13.20, 13.08, 12.72, 12.12, & + & 11.10, 9.86, 8.30, 6.50, 4.60, & + & 3.10, 3.16, 4.50, 6.20, 7.90, & + & 8.40, 9.42, 10.14, 10.76, 11.14, & + & 11.40, 11.40, 11.38, 11.02, 10.46, & + & 9.70, 8.72, 7.64, 6.46, 5.42, & + & 4.60, 4.70, 5.34, 6.24, 7.36, & + & 7.90, 8.46, 8.92, 9.28, 9.54, & + & 9.70, 9.70, 9.68, 9.42, 9.06, & + & 8.60, 8.08, 7.56, 7.02, 6.56, & + & 6.30, 6.30, 6.52, 6.96, 7.38, & + & 8.15, 8.15, 8.15, 8.15, 8.15, & + & 8.15, 8.15, 8.15, 8.15, 8.15, & + & 8.15, 8.15, 8.15, 8.15, 8.15, & + & 8.15, 8.15, 8.15, 8.15, 8.15/ +!btot + data btot/49163.,49163.,49163.,49162.,49162., & + &49162.,49162.,49162.,49162.,49162., & + &49162.,49162.,49162.,49162.,49162., & + &49162.,49163.,49163.,49163.,49163., & + &47958.,48108.,48361.,48693.,49069., & + &49452.,49801.,50081.,50266.,50338., & + &50293.,50136.,49884.,49561.,49197., & + &48826.,48484.,48202.,48009.,47924., & + &46690.,46983.,47489.,48160.,48925., & + &49701.,50403.,50959.,51316.,51444., & + &51340.,51020.,50519.,49882.,49167., & + &48438.,47761.,47200.,46810.,46633., & + &45370.,45799.,46556.,47571.,48736., & + &49915.,50974.,51796.,52306.,52470., & + &52293.,51806.,51060.,50121.,49067., & + &47991.,46989.,46155.,45571.,45296., & + &44008.,44566.,45571.,46935.,48509., & + &50100.,51514.,52591.,53233.,53410., & + &53144.,52486.,51503.,50273.,48893., & + &47481.,46165.,45068.,44295.,43925., & + &42618.,43297.,44545.,46261.,48252., & + &50261.,52026.,53341.,54091.,54257., & + &53887.,53055.,51842.,50335.,48643., & + &46906.,45286.,43939.,42989.,42527., & + &41210.,42003.,43488.,45557.,47970., & + &50400.,52511.,54044.,54875.,55005., & + &54515.,53509.,52077.,50308.,48315., & + &46263.,44352.,42770.,41658.,41113., & + &39796.,40694.,42410.,44830.,47669., & + &50520.,52966.,54697.,55580.,55649., & + &55025.,53844.,52206.,50190.,47910., & + &45553.,43364.,41564.,40310.,39693., & + &38387.,39383.,41321.,44089.,47353., & + &50622.,53389.,55294.,56201.,56184., & + &55414.,54061.,52229.,49984.,47430., & + &44779.,42323.,40326.,38951.,38278., & + &36996.,38080.,40230.,43340.,47027., & + &50705.,53778.,55830.,56734.,56609., & + &55682.,54158.,52149.,49693.,46879., & + &43944.,41235.,39062.,37591.,36878., & + &35633.,36796.,39144.,42589.,46691., & + &50769.,54128.,56301.,57175.,56922., & + &55828.,54140.,51968.,49320.,46263., & + &43054.,40106.,37779.,36238.,35504., & + &34309.,35539.,38072.,41841.,46349., & + &50811.,54434.,56702.,57521.,57123., & + &55858.,54010.,51690.,48872.,45587., & + &42117.,38943.,36486.,34903.,34167., & + &33035.,34318.,37021.,41101.,46002., & + &50830.,54692.,57028.,57771.,57216., & + &55775.,53772.,51322.,48353.,44859., & + &41141.,37757.,35193.,33597.,32878., & + &31822.,33144.,35995.,40371.,45649., & + &50822.,54897.,57275.,57923.,57204., & + &55585.,53434.,50868.,47770.,44086., & + &40136.,36558.,33910.,32329.,31647., & + &30678.,32022.,35001.,39655.,45291., & + &50785.,55045.,57440.,57978.,57090., & + &55296.,53003.,50335.,47128.,43277., & + &39112.,35357.,32649.,31110.,30485., & + &29614.,30961.,34043.,38954.,44928., & + &50716.,55134.,57521.,57940.,56883., & + &54916.,52487.,49731.,46436.,42438., & + &38079.,34165.,31419.,29950.,29401., & + &28635.,29968.,33125.,38271.,44559., & + &50615.,55160.,57519.,57809.,56587., & + &54454.,51895.,49062.,45697.,41578., & + &37048.,32994.,30232.,28858.,28403., & + &27749.,29049.,32252.,37607.,44185., & + &50478.,55121.,57432.,57592.,56210., & + &53918.,51235.,48336.,44919.,40704., & + &36027.,31854.,29097.,27840.,27495., & + &26960.,28210.,31427.,36965.,43805., & + &50305.,55019.,57262.,57291.,55761., & + &53318.,50518.,47560.,44107.,39821., & + &35027.,30756.,28023.,26903.,26682., & + &26273.,27457.,30656.,36345.,43419., & + &50097.,54851.,57012.,56912.,55245., & + &52662.,49751.,46741.,43266.,38935., & + &34053.,29708.,27017.,26051.,25965., & + &25687.,26794.,29943.,35751.,43028., & + &49852.,54620.,56685.,56460.,54670., & + &51957.,48942.,45886.,42401.,38050., & + &33113.,28718.,26085.,25286.,25344., & + &25202.,26226.,29291.,35183.,42633., & + &49572.,54327.,56283.,55940.,54041., & + &51211.,48098.,45001.,41517.,37171., & + &32212.,27792.,25231.,24606.,24816., & + &24815.,25756.,28707.,34646.,42234., & + &49256.,53973.,55809.,55357.,53363., & + &50429.,47227.,44092.,40617.,36301., & + &31353.,26933.,24457.,24011.,24375., & + &24522.,25386.,28194.,34140.,41832., & + &48906.,53560.,55268.,54715.,52641., & + &49616.,46333.,43164.,39705.,35442., & + &30539.,26146.,23765.,23496.,24015., & + &24317.,25114.,27757.,33669.,41428., & + &48523.,53090.,54662.,54018.,51878., & + &48774.,45420.,42222.,38786.,34597., & + &29772.,25432.,23153.,23057.,23727., & + &24191.,24940.,27398.,33234.,41022., & + &48107.,52565.,53995.,53268.,51075., & + &47907.,44494.,41272.,37864.,33769., & + &29052.,24790.,22620.,22686.,23505., & + &24137.,24860.,27120.,32838.,40615., & + &47658.,51986.,53270.,52468.,50234., & + &47015.,43556.,40316.,36943.,32961., & + &28381.,24221.,22162.,22378.,23338., & + &24146.,24868.,26921.,32481.,40207., & + &47178.,51356.,52488.,51620.,49355., & + &46100.,42609.,39360.,36029.,32176., & + &27759.,23724.,21777.,22126.,23219., & + &24207.,24954.,26800.,32163.,39797., & + &46665.,50675.,51654.,50727.,48441., & + &45163.,41655.,38408.,35126.,31417., & + &27187.,23296.,21461.,21924.,23141., & + &24312.,25109.,26753.,31884.,39386., & + &46121.,49947.,50770.,49789.,47490., & + &44204.,40697.,37463.,34240.,30689., & + &26664.,22938.,21210.,21767.,23097., & + &24450.,25321.,26772.,31640.,38972., & + &45546.,49172.,49839.,48809.,46506., & + &43226.,39738.,36531.,33377.,29996., & + &26194.,22647.,21021.,21649.,23081., & + &24614.,25577.,26849.,31429.,38554., & + &44939.,48353.,48865.,47791.,45489., & + &42230.,38779.,35615.,32544.,29343., & + &25778.,22424.,20891.,21567.,23090., & + &24794.,25862.,26974.,31247.,38131., & + &44303.,47494.,47853.,46738.,44443., & + &41219.,37825.,34722.,31747.,28737., & + &25418.,22269.,20818.,21518.,23119., & + &24983.,26164.,27134.,31089.,37702., & + &43637.,46598.,46808.,45655.,43373., & + &40199.,36880.,33857.,30994.,28183., & + &25119.,22182.,20801.,21501.,23165., & + &25172.,26469.,27318.,30951.,37267., & + &42946.,45672.,45738.,44547.,42283., & + &39173.,35949.,33026.,30292.,27687., & + &24885.,22164.,20840.,21514.,23226., & + &25357.,26764.,27513.,30826.,36826., & + &42231.,44720.,44648.,43423.,41181., & + &38150.,35040.,32237.,29647.,27257., & + &24720.,22217.,20935.,21557.,23301., & + &25532.,27039.,27709.,30712.,36380., & + &41497.,43752.,43550.,42290.,40074., & + &37136.,34160.,31495.,29068.,26899., & + &24630.,22344.,21086.,21632.,23388., & + &25693.,27286.,27897.,30605.,35932., & + &40751.,42775.,42451.,41158.,38973., & + &36142.,33317.,30809.,28562.,26619., & + &24618.,22545.,21294.,21737.,23486., & + &25837.,27499.,28070.,30504.,35484., & + &39999.,41799.,41365.,40038.,37887., & + &35177.,32520.,30187.,28134.,26423., & + &24690.,22823.,21561.,21877.,23595., & + &25964.,27675.,28224.,30408.,35044., & + &39251.,40838.,40301.,38940.,36828., & + &34251.,31777.,29635.,27791.,26316., & + &24848.,23177.,21887.,22051.,23714., & + &26075.,27814.,28357.,30322.,34617., & + &38518.,39903.,39275.,37878.,35806., & + &33375.,31098.,29161.,27539.,26304., & + &25096.,23607.,22273.,22263.,23845., & + &26172.,27921.,28473.,30248.,34212., & + &37811.,39008.,38298.,36863.,34834., & + &32559.,30491.,28770.,27382.,26389., & + &25435.,24112.,22719.,22515.,23989., & + &26262.,28001.,28578.,30195.,33841., & + &37144.,38169.,37384.,35908.,33922., & + &31812.,29964.,28468.,27322.,26573., & + &25865.,24691.,23224.,22809.,24150., & + &26351.,28066.,28678.,30170.,33515., & + &36531.,37399.,36548.,35026.,33081., & + &31144.,29521.,28258.,27362.,26858., & + &26385.,25340.,23788.,23149.,24331., & + &26447.,28127.,28786.,30183.,33245., & + &35987.,36715.,35802.,34227.,32320., & + &30559.,29168.,28142.,27501.,27243., & + &26992.,26056.,24407.,23535.,24538., & + &26562.,28198.,28913.,30245.,33045., & + &35528.,36130.,35159.,33522.,31649., & + &30064.,28905.,28120.,27738.,27724., & + &27682.,26834.,25080.,23971.,24776., & + &26706.,28293.,29072.,30366.,32927., & + &35167.,35659.,34630.,32922.,31074., & + &29662.,28734.,28190.,28070.,28299., & + &28450.,27668.,25803.,24458.,25052., & + &26889.,28427.,29277.,30555.,32901., & + &34917.,35312.,34224.,32433.,30599., & + &29354.,28653.,28351.,28493.,28961., & + &29290.,28555.,26572.,24996.,25372., & + &27122.,28613.,29537.,30818.,32975., & + &34787.,35100.,33949.,32063.,30230., & + &29139.,28658.,28596.,29001.,29705., & + &30196.,29488.,27384.,25586.,25744., & + &27414.,28862.,29861.,31161.,33154., & + &34787.,35027.,33810.,31814.,29967., & + &29016.,28744.,28921.,29588.,30523., & + &31161.,30461.,28233.,26228.,26171., & + &27772.,29181.,30256.,31585.,33440., & + &34918.,35097.,33808.,31689.,29811., & + &28981.,28908.,29321.,30247.,31407., & + &32176.,31469.,29116.,26918.,26659., & + &28199.,29575.,30723.,32087.,33831., & + &35181.,35309.,33942.,31687.,29760., & + &29030.,29144.,29789.,30970.,32348., & + &33234.,32507.,30029.,27655.,27207., & + &28695.,30044.,31261.,32665.,34323., & + &35572.,35658.,34208.,31807.,29812., & + &29160.,29446.,30319.,31750.,33338., & + &34328.,33569.,30966.,28435.,27817., & + &29259.,30584.,31864.,33309.,34907., & + &36083.,36137.,34599.,32042.,29963., & + &29366.,29810.,30905.,32580.,34368., & + &35450.,34649.,31925.,29254.,28485., & + &29885.,31189.,32526.,34011.,35572., & + &36703.,36733.,35107.,32389.,30210., & + &29644.,30231.,31544.,33453.,35430., & + &36591.,35742.,32901.,30108.,29207., & + &30567.,31851.,33237.,34761.,36307., & + &37420.,37436.,35719.,32838.,30548., & + &29993.,30708.,32230.,34364.,36516., & + &37744.,36842.,33890.,30991.,29975., & + &31294.,32558.,33987.,35547.,37098., & + &38219.,38229.,36423.,33381.,30972., & + &30407.,31237.,32960.,35306.,37620., & + &38902.,37944.,34888.,31897.,30783., & + &32057.,33301.,34763.,36357.,37932., & + &39083.,39097.,37206.,34010.,31476., & + &30886.,31817.,33730.,36274.,38733., & + &40058.,39041.,35891.,32821.,31622., & + &32847.,34067.,35555.,37180.,38796., & + &39999.,40024.,38055.,34713.,32055., & + &31426.,32446.,34538.,37265.,39850., & + &41204.,40129.,36894.,33758.,32483., & + &33652.,34845.,36351.,38008.,39677., & + &40949.,40994.,38955.,35482.,32703., & + &32027.,33123.,35381.,38273.,40965., & + &42334.,41200.,37893.,34702.,33359., & + &34464.,35626.,37144.,38829.,40565., & + &41920.,41992.,39893.,36307.,33415., & + &32686.,33846.,36255.,39293.,42070., & + &43440.,42249.,38883.,35648.,34240., & + &35274.,36400.,37923.,39638.,41449., & + &42897.,43002.,40857.,37177.,34186., & + &33400.,34614.,37158.,40320.,43160., & + &44514.,43269.,39859.,36589.,35120., & + &36076.,37161.,38682.,40426.,42320., & + &43868.,44012.,41834.,38083.,35008., & + &34166.,35424.,38085.,41349.,44227., & + &45551.,44253.,40815.,37521.,35993., & + &36862.,37902.,39416.,41191.,43171., & + &44822.,45008.,42813.,39017.,35875., & + &34982.,36272.,39031.,42373.,45264., & + &46542.,45195.,41744.,38437.,36853., & + &37630.,38618.,40120.,41927.,43995., & + &45748.,45980.,43783.,39968.,36781., & + &35842.,37156.,39991.,43385.,46265., & + &47480.,46087.,42641.,39333.,37694., & + &38374.,39306.,40792.,42632.,44787., & + &46637.,46916.,44735.,40928.,37719., & + &36741.,38068.,40956.,44376.,47220., & + &48359.,46924.,43500.,40204.,38513., & + &39092.,39963.,41431.,43304.,45543., & + &47480.,47808.,45660.,41888.,38681., & + &37673.,39002.,41920.,45338.,48122., & + &49171.,47698.,44313.,41042.,39306., & + &39783.,40590.,42036.,43942.,46257., & + &48272.,48647.,46549.,42841.,39659., & + &38631.,39951.,42873.,46262.,48961., & + &49909.,48405.,45075.,41845.,40070., & + &40444.,41186.,42608.,44546.,46928., & + &49005.,49425.,47395.,43777.,40645., & + &39606.,40906.,43805.,47136.,49729., & + &50567.,49038.,45781.,42606.,40801., & + &41075.,41752.,43149.,45115.,47551., & + &49674.,50136.,48190.,44689.,41630., & + &40591.,41858.,44707.,47951.,50419., & + &51141.,49595.,46426.,43321.,41498., & + &41676.,42289.,43660.,45650.,48124., & + &50274.,50775.,48927.,45568.,42606., & + &41576.,42798.,45569.,48698.,51023., & + &51625.,50072.,47005.,43986.,42158., & + &42248.,42800.,44145.,46150.,48645., & + &50803.,51336.,49600.,46407.,43563., & + &42552.,43716.,46381.,49369.,51534., & + &52018.,50466.,47516.,44599.,42779., & + &42790.,43287.,44604.,46616.,49112., & + &51255.,51816.,50204.,47197.,44492., & + &43508.,44602.,47135.,49956.,51950., & + &52316.,50778.,47957.,45157.,43361., & + &43306.,43753.,45042.,47048.,49522., & + &51631.,52212.,50734.,47932.,45385., & + &44435.,45447.,47823.,50454.,52266., & + &52520.,51008.,48328.,45660.,43905., & + &43796.,44201.,45459.,47445.,49874., & + &51927.,52523.,51187.,48605.,46232., & + &45323.,46244.,48440.,50860.,52484., & + &52633.,51159.,48632.,46107.,44409., & + &44264.,44634.,45858.,47807.,50167., & + &52144.,52747.,51558.,49209.,47025., & + &46164.,46984.,48981.,51174.,52604., & + &52659.,51236.,48870.,46502.,44877., & + &44711.,45054.,46240.,48135.,50401., & + &52284.,52886.,51847.,49740.,47755., & + &46948.,47661.,49445.,51397.,52633., & + &52603.,51243.,49048.,46848.,45311., & + &45141.,45464.,46606.,48428.,50577., & + &52348.,52942.,52054.,50194.,48417., & + &47668.,48270.,49830.,51533.,52578., & + &52475.,51190.,49173.,47148.,45714., & + &45558.,45865.,46957.,48685.,50696., & + &52340.,52920.,52179.,50568.,49003., & + &48317.,48808.,50138.,51589.,52447., & + &52284.,51084.,49250.,47410.,46091., & + &45964.,46260.,47292.,48908.,50761., & + &52266.,52825.,52227.,50861.,49509., & + &48890.,49272.,50373.,51575.,52255., & + &52043.,50937.,49291.,47640.,46447., & + &46362.,46649.,47611.,49097.,50777., & + &52133.,52664.,52203.,51074.,49931., & + &49383.,49661.,50540.,51501.,52013., & + &51765.,50761.,49304.,47846.,46787., & + &46755.,47032.,47915.,49255.,50748., & + &51949.,52447.,52112.,51208.,50268., & + &49791.,49976.,50646.,51379.,51738., & + &51465.,50567.,49299.,48035.,47116., & + &47144.,47408.,48202.,49383.,50681., & + &51725.,52185.,51962.,51268.,50520., & + &50115.,50218.,50697.,51222.,51444., & + &51157.,50370.,49287.,48215.,47439., & + &47531.,47778.,48472.,49486.,50585., & + &51471.,51889.,51764.,51258.,50687., & + &50353.,50389.,50701.,51042.,51147., & + &50857.,50180.,49279.,48395.,47759., & + &47913.,48138.,48726.,49567.,50470., & + &51201.,51572.,51529.,51186.,50773., & + &50508.,50492.,50665.,50851.,50861., & + &50579.,50012.,49284.,48579.,48079., & + &48291.,48487.,48964.,49633.,50344., & + &50927.,51247.,51266.,51060.,50783., & + &50583.,50532.,50596.,50661.,50599., & + &50335.,49876.,49311.,48774.,48401., & + &48660.,48821.,49187.,49689.,50220., & + &50662.,50928.,50988.,50889.,50723., & + &50582.,50514.,50501.,50479.,50373., & + &50138.,49782.,49366.,48982.,48723., & + &49016.,49138.,49396.,49742.,50107., & + &50421.,50627.,50707.,50682.,50600., & + &50511.,50441.,50385.,50314.,50191., & + &49996.,49738.,49456.,49204.,49043., & + &49353.,49434.,49591.,49798.,50018., & + &50214.,50356.,50433.,50450.,50424., & + &50376.,50318.,50252.,50169.,50058., & + &49915.,49750.,49582.,49441.,49358., & + &49665.,49705.,49774.,49864.,49961., & + &50052.,50126.,50177.,50201.,50203., & + &50185.,50151.,50105.,50046.,49976., & + &49898.,49819.,49746.,49690.,49661., & + &49945.,49945.,49945.,49945.,49945., & + &49945.,49945.,49945.,49945.,49945., & + &49945.,49945.,49945.,49945.,49945., & + &49945.,49945.,49945.,49945.,49945./ +!dipang + data dipang/-74.12,-74.12,-74.12,-74.12,-74.12, & + &-74.12,-74.12,-74.12,-74.12,-74.12, & + &-74.12,-74.12,-74.12,-74.12,-74.12, & + &-74.12,-74.12,-74.12,-74.12,-74.12, & + &-72.88,-73.07,-73.36,-73.73,-74.14, & + &-74.55,-74.93,-75.23,-75.41,-75.46, & + &-75.37,-75.15,-74.82,-74.44,-74.02, & + &-73.62,-73.27,-73.01,-72.85,-72.80, & + &-71.65,-72.01,-72.56,-73.26,-74.07, & + &-74.91,-75.69,-76.31,-76.70,-76.80, & + &-76.59,-76.12,-75.44,-74.65,-73.82, & + &-73.03,-72.37,-71.87,-71.58,-71.50, & + &-70.44,-70.94,-71.72,-72.74,-73.94, & + &-75.21,-76.42,-77.39,-78.00,-78.13, & + &-77.78,-77.02,-75.97,-74.75,-73.51, & + &-72.36,-71.40,-70.71,-70.31,-70.22, & + &-69.26,-69.89,-70.87,-72.18,-73.75, & + &-75.46,-77.11,-78.47,-79.30,-79.45, & + &-78.91,-77.82,-76.37,-74.74,-73.10, & + &-71.60,-70.38,-69.52,-69.06,-68.98, & + &-68.12,-68.86,-70.02,-71.59,-73.53, & + &-75.67,-77.78,-79.54,-80.61,-80.74, & + &-79.95,-78.49,-76.64,-74.61,-72.59, & + &-70.75,-69.29,-68.30,-67.81,-67.77, & + &-67.04,-67.87,-69.17,-70.99,-73.27, & + &-75.84,-78.42,-80.62,-81.93,-81.98, & + &-80.85,-79.00,-76.77,-74.37,-71.98, & + &-69.82,-68.14,-67.06,-66.58,-66.61, & + &-66.02,-66.93,-68.35,-70.38,-72.99, & + &-75.99,-79.04,-81.69,-83.26,-83.13, & + &-81.58,-79.33,-76.75,-74.01,-71.28, & + &-68.82,-66.93,-65.79,-65.37,-65.50, & + &-65.07,-66.04,-67.55,-69.78,-72.71, & + &-76.11,-79.63,-82.75,-84.58,-84.13, & + &-82.07,-79.44,-76.57,-73.54,-70.50, & + &-67.75,-65.67,-64.49,-64.18,-64.45, & + &-64.21,-65.22,-66.80,-69.19,-72.42, & + &-76.21,-80.18,-83.80,-85.90,-84.90, & + &-82.28,-79.33,-76.24,-72.97,-69.65, & + &-66.61,-64.35,-63.18,-63.02,-63.48, & + &-63.44,-64.48,-66.08,-68.62,-72.12, & + &-76.28,-80.68,-84.80,-87.19,-85.32, & + &-82.19,-79.01,-75.77,-72.32,-68.74, & + &-65.43,-62.99,-61.85,-61.90,-62.59, & + &-62.78,-63.81,-65.42,-68.08,-71.83, & + &-76.33,-81.12,-85.71,-88.36,-85.30, & + &-81.80,-78.49,-75.16,-71.59,-67.78, & + &-64.20,-61.60,-60.51,-60.82,-61.78, & + &-62.22,-63.24,-64.81,-67.55,-71.54, & + &-76.35,-81.46,-86.43,-88.91,-84.84, & + &-81.17,-77.79,-74.44,-70.78,-66.78, & + &-62.94,-60.17,-59.17,-59.79,-61.07, & + &-61.79,-62.77,-64.25,-67.06,-71.26, & + &-76.34,-81.70,-86.81,-88.13,-84.06, & + &-80.34,-76.95,-73.61,-69.90,-65.74, & + &-61.66,-58.72,-57.83,-58.81,-60.46, & + &-61.47,-62.40,-63.76,-66.59,-70.97, & + &-76.28,-81.80,-86.71,-86.90,-83.06, & + &-79.36,-75.99,-72.68,-68.97,-64.67, & + &-60.35,-57.25,-56.50,-57.88,-59.95, & + &-61.28,-62.14,-63.33,-66.15,-70.68, & + &-76.18,-81.75,-86.14,-85.57,-81.94, & + &-78.28,-74.93,-71.67,-67.97,-63.57, & + &-59.03,-55.77,-55.17,-57.02,-59.55, & + &-61.21,-61.99,-62.97,-65.73,-70.39, & + &-76.02,-81.54,-85.25,-84.21,-80.73, & + &-77.12,-73.79,-70.58,-66.91,-62.44, & + &-57.70,-54.28,-53.86,-56.20,-59.23, & + &-61.24,-61.95,-62.68,-65.35,-70.08, & + &-75.79,-81.17,-84.17,-82.83,-79.47, & + &-75.90,-72.59,-69.41,-65.78,-61.27, & + &-56.35,-52.79,-52.56,-55.44,-59.00, & + &-61.38,-62.02,-62.46,-64.98,-69.76, & + &-75.50,-80.64,-82.98,-81.44,-78.17, & + &-74.62,-71.32,-68.17,-64.59,-60.06, & + &-54.99,-51.29,-51.26,-54.71,-58.83, & + &-61.59,-62.18,-62.31,-64.63,-69.42, & + &-75.14,-79.96,-81.71,-80.03,-76.84, & + &-73.31,-69.99,-66.87,-63.33,-58.80, & + &-53.61,-49.77,-49.97,-54.02,-58.71, & + &-61.85,-62.44,-62.23,-64.31,-69.06, & + &-74.69,-79.15,-80.37,-78.60,-75.48, & + &-71.96,-68.61,-65.49,-62.00,-57.49, & + &-52.20,-48.23,-48.67,-53.33,-58.61, & + &-62.14,-62.77,-62.20,-63.99,-68.66, & + &-74.17,-78.21,-78.99,-77.14,-74.08, & + &-70.56,-67.18,-64.04,-60.58,-56.12, & + &-50.74,-46.66,-47.35,-52.64,-58.51, & + &-62.43,-63.15,-62.23,-63.68,-68.21, & + &-73.55,-77.18,-77.55,-75.66,-72.65, & + &-69.11,-65.69,-62.52,-59.08,-54.67, & + &-49.23,-45.05,-46.00,-51.92,-58.38, & + &-62.68,-63.56,-62.30,-63.37,-67.72, & + &-72.84,-76.04,-76.07,-74.14,-71.17, & + &-67.62,-64.13,-60.93,-57.49,-53.13, & + &-47.65,-43.37,-44.60,-51.15,-58.19, & + &-62.87,-63.96,-62.39,-63.04,-67.17, & + &-72.03,-74.80,-74.53,-72.58,-69.64, & + &-66.05,-62.51,-59.24,-55.80,-51.49, & + &-45.98,-41.61,-43.12,-50.32,-57.93, & + &-62.97,-64.32,-62.48,-62.69,-66.55, & + &-71.12,-73.47,-72.93,-70.97,-68.05, & + &-64.42,-60.80,-57.47,-54.00,-49.74, & + &-44.20,-39.75,-41.55,-49.40,-57.57, & + &-62.96,-64.60,-62.54,-62.28,-65.84, & + &-70.10,-72.05,-71.27,-69.29,-66.39, & + &-62.71,-59.01,-55.60,-52.10,-47.88, & + &-42.30,-37.76,-39.88,-48.38,-57.10, & + &-62.82,-64.76,-62.53,-61.81,-65.03, & + &-68.96,-70.53,-69.54,-67.55,-64.65, & + &-60.90,-57.13,-53.63,-50.08,-45.89, & + &-40.27,-35.64,-38.07,-47.24,-56.52, & + &-62.52,-64.78,-62.42,-61.25,-64.11, & + &-67.71,-68.91,-67.73,-65.74,-62.82, & + &-59.00,-55.13,-51.55,-47.94,-43.76, & + &-38.07,-33.37,-36.13,-45.97,-55.81, & + &-62.06,-64.61,-62.17,-60.56,-63.06, & + &-66.32,-67.18,-65.84,-63.84,-60.90, & + &-56.98,-53.02,-49.35,-45.67,-41.49, & + &-35.72,-30.92,-34.03,-44.57,-54.97, & + &-61.42,-64.23,-61.73,-59.72,-61.87, & + &-64.80,-65.35,-63.85,-61.84,-58.87, & + &-54.84,-50.78,-47.02,-43.27,-39.07, & + &-33.18,-28.30,-31.76,-43.02,-53.98, & + &-60.60,-63.61,-61.08,-58.71,-60.51, & + &-63.14,-63.40,-61.77,-59.75,-56.72, & + &-52.57,-48.39,-44.56,-40.73,-36.49, & + &-30.47,-25.49,-29.33,-41.32,-52.85, & + &-59.57,-62.73,-60.18,-57.50,-58.98, & + &-61.33,-61.32,-59.58,-57.56,-54.46, & + &-50.16,-45.87,-41.95,-38.05,-33.76, & + &-27.57,-22.51,-26.73,-39.46,-51.58, & + &-58.34,-61.59,-59.01,-56.06,-57.26, & + &-59.36,-59.12,-57.28,-55.25,-52.07, & + &-47.60,-43.18,-39.19,-35.22,-30.87, & + &-24.49,-19.35,-23.96,-37.44,-50.15, & + &-56.90,-60.16,-57.54,-54.38,-55.34, & + &-57.22,-56.77,-54.85,-52.82,-49.55, & + &-44.89,-40.33,-36.27,-32.25,-27.82, & + &-21.24,-16.03,-21.03,-35.25,-48.55, & + &-55.23,-58.44,-55.78,-52.44,-53.21, & + &-54.91,-54.28,-52.29,-50.27,-46.90, & + &-42.02,-37.31,-33.20,-29.13,-24.62, & + &-17.83,-12.57,-17.95,-32.90,-46.79, & + &-53.33,-56.43,-53.72,-50.23,-50.85, & + &-52.41,-51.63,-49.60,-47.58,-44.10, & + &-38.99,-34.12,-29.96,-25.86,-21.27, & + &-14.28, -8.99,-14.74,-30.39,-44.84, & + &-51.18,-54.13,-51.35,-47.74,-48.27, & + &-49.72,-48.82,-46.76,-44.76,-41.17, & + &-35.80,-30.76,-26.57,-22.44,-17.77, & + &-10.59, -5.33,-11.41,-27.71,-42.71, & + &-48.78,-51.53,-48.68,-44.97,-45.44, & + &-46.83,-45.83,-43.77,-41.80,-38.08, & + &-32.45,-27.23,-23.02,-18.89,-14.15, & + & -6.81, -1.60, -7.99,-24.87,-40.37, & + &-46.12,-48.64,-45.70,-41.93,-42.37, & + &-43.74,-42.67,-40.62,-38.70,-34.86, & + &-28.94,-23.54,-19.33,-15.21,-10.42, & + & -2.96, 2.16, -4.50,-21.87,-37.82, & + &-43.21,-45.46,-42.44,-38.61,-39.06, & + &-40.43,-39.31,-37.31,-35.45,-31.50, & + &-25.29,-19.72,-15.51,-11.43, -6.60, & + & 0.93, 5.93, -0.96,-18.73,-35.05, & + &-40.02,-42.01,-38.90,-35.02,-35.50, & + &-36.90,-35.77,-33.83,-32.05,-28.00, & + &-21.51,-15.76,-11.59, -7.55, -2.71, & + & 4.84, 9.66, 2.60,-15.45,-32.05, & + &-36.58,-38.27,-35.09,-31.18,-31.71, & + &-33.15,-32.03,-30.18,-28.51,-24.38, & + &-17.62,-11.71, -7.58, -3.61, 1.23, & + & 8.72, 13.33, 6.15,-12.05,-28.83, & + &-32.87,-34.28,-31.02,-27.11,-27.68, & + &-29.19,-28.10,-26.37,-24.84,-20.65, & + &-13.63, -7.59, -3.52, 0.37, 5.18, & + & 12.57, 16.93, 9.67, -8.54,-25.39, & + &-28.92,-30.04,-26.73,-22.83,-23.45, & + &-25.03,-24.00,-22.41,-21.03,-16.81, & + &-9.58, -3.44, 0.57, 4.37, 9.12, & + & 16.34, 20.43, 13.15, -4.94,-21.73, & + &-24.75,-25.57,-22.22,-18.36,-19.03, & + &-20.68,-19.72,-18.29,-17.11,-12.90, & + & -5.50, 0.72, 4.64, 8.34, 13.02, & + & 20.02, 23.82, 16.56, -1.27,-17.86, & + &-20.36,-20.91,-17.55,-13.74,-14.45, & + &-16.17,-15.29,-14.05,-13.08, -8.94, & + & -1.41, 4.85, 8.67, 12.27, 16.85, & + & 23.60, 27.08, 19.88, 2.44,-13.82, & + &-15.80,-16.10,-12.74, -9.02, -9.75, & + &-11.52,-10.74, -9.71, -8.97, -4.94, & + & 2.64, 8.90, 12.63, 16.12, 20.60, & + & 27.05, 30.21, 23.11, 6.18, -9.62, & + &-11.10,-11.16, -7.84, -4.23, -4.97, & + & -6.76, -6.10, -5.29, -4.81, -0.93, & + & 6.63, 12.85, 16.48, 19.88, 24.25, & + & 30.38, 33.21, 26.23, 9.91, -5.31, & + & -6.31, -6.15, -2.89, 0.58, -0.16, & + & -1.95, -1.41, -0.82, -0.62, 3.05, & + & 10.53, 16.67, 20.20, 23.52, 27.77, & + & 33.57, 36.08, 29.24, 13.62, -0.91, & + & -1.47, -1.13, 2.05, 5.36, 4.65, & + & 2.88, 3.30, 3.65, 3.57, 6.99, & + & 14.31, 20.34, 23.78, 27.02, 31.16, & + & 36.63, 38.82, 32.14, 17.27, 3.53, & + & 3.37, 3.87, 6.94, 10.08, 9.40, & + & 7.67, 7.98, 8.09, 7.73, 10.85, & + & 17.94, 23.83, 27.19, 30.38, 34.41, & + & 39.55, 41.43, 34.92, 20.86, 7.97, & + & 8.16, 8.80, 11.73, 14.68, 14.06, & + & 12.40, 12.59, 12.48, 11.83, 14.62, & + & 21.42, 27.14, 30.44, 33.58, 37.52, & + & 42.33, 43.92, 37.59, 24.36, 12.37, & + & 12.87, 13.60, 16.40, 19.15, 18.59, & + & 17.02, 17.10, 16.77, 15.84, 18.28, & + & 24.73, 30.26, 33.51, 36.63, 40.48, & + & 44.99, 46.29, 40.14, 27.76, 16.69, & + & 17.44, 18.25, 20.90, 23.45, 22.96, & + & 21.49, 21.47, 20.93, 19.74, 21.80, & + & 27.87, 33.20, 36.41, 39.52, 43.30, & + & 47.53, 48.56, 42.59, 31.05, 20.89, & + & 21.86, 22.71, 25.21, 27.56, 27.15, & + & 25.80, 25.69, 24.96, 23.52, 25.20, & + & 30.84, 35.94, 39.13, 42.25, 45.97, & + & 49.95, 50.72, 44.93, 34.21, 24.95, & + & 26.09, 26.97, 29.32, 31.47, 31.14, & + & 29.92, 29.73, 28.82, 27.15, 28.45, & + & 33.64, 38.51, 41.69, 44.84, 48.52, & + & 52.26, 52.79, 47.18, 37.25, 28.86, & + & 30.11, 31.01, 33.21, 35.18, 34.93, & + & 33.85, 33.59, 32.51, 30.63, 31.55, & + & 36.28, 40.92, 44.10, 47.28, 50.93, & + & 54.46, 54.78, 49.34, 40.15, 32.58, & + & 33.93, 34.83, 36.88, 38.68, 38.51, & + & 37.57, 37.26, 36.03, 33.96, 34.51, & + & 38.76, 43.17, 46.36, 49.60, 53.23, & + & 56.57, 56.69, 51.41, 42.93, 36.12, & + & 37.54, 38.42, 40.33, 41.98, 41.89, & + & 41.09, 40.74, 39.37, 37.12, 37.32, & + & 41.11, 45.29, 48.50, 51.79, 55.41, & + & 58.59, 58.53, 53.40, 45.58, 39.47, & + & 40.92, 41.79, 43.57, 45.08, 45.08, & + & 44.42, 44.03, 42.53, 40.13, 40.01, & + & 43.34, 47.28, 50.52, 53.88, 57.50, & + & 60.53, 60.30, 55.32, 48.10, 42.63, & + & 44.10, 44.94, 46.61, 47.99, 48.07, & + & 47.55, 47.13, 45.53, 42.99, 42.57, & + & 45.46, 49.18, 52.44, 55.86, 59.49, & + & 62.40, 62.01, 57.17, 50.51, 45.61, & + & 47.08, 47.89, 49.44, 50.72, 50.88, & + & 50.51, 50.07, 48.36, 45.71, 45.01, & + & 47.49, 50.98, 54.27, 57.76, 61.41, & + & 64.19, 63.67, 58.96, 52.80, 48.41, & + & 49.87, 50.64, 52.09, 53.27, 53.52, & + & 53.29, 52.84, 51.04, 48.29, 47.34, & + & 49.44, 52.72, 56.03, 59.59, 63.25, & + & 65.93, 65.27, 60.70, 54.99, 51.04, & + & 52.47, 53.21, 54.56, 55.66, 56.00, & + & 55.91, 55.45, 53.57, 50.74, 49.58, & + & 51.32, 54.40, 57.72, 61.35, 65.02, & + & 67.60, 66.83, 62.38, 57.07, 53.51, & + & 54.90, 55.60, 56.86, 57.90, 58.32, & + & 58.37, 57.92, 55.98, 53.08, 51.73, & + & 53.14, 56.04, 59.37, 63.05, 66.74, & + & 69.23, 68.34, 64.01, 59.06, 55.83, & + & 57.17, 57.84, 59.01, 60.00, 60.51, & + & 60.70, 60.26, 58.25, 55.31, 53.80, & + & 54.92, 57.64, 60.97, 64.70, 68.40, & + & 70.80, 69.81, 65.59, 60.96, 58.01, & + & 59.30, 59.91, 61.01, 61.96, 62.58, & + & 62.89, 62.47, 60.42, 57.44, 55.80, & + & 56.67, 59.22, 62.55, 66.32, 70.01, & + & 72.32, 71.23, 67.12, 62.78, 60.07, & + & 61.29, 61.85, 62.88, 63.81, 64.52, & + & 64.97, 64.56, 62.48, 59.48, 57.74, & + & 58.39, 60.78, 64.09, 67.89, 71.58, & + & 73.80, 72.61, 68.61, 64.51, 62.00, & + & 63.16, 63.67, 64.62, 65.55, 66.36, & + & 66.93, 66.55, 64.44, 61.45, 59.63, & + & 60.09, 62.33, 65.61, 69.42, 73.11, & + & 75.24, 73.94, 70.04, 66.17, 63.83, & + & 64.90, 65.36, 66.25, 67.18, 68.09, & + & 68.78, 68.44, 66.32, 63.35, 61.48, & + & 61.77, 63.88, 67.11, 70.93, 74.59, & + & 76.62, 75.23, 71.42, 67.76, 65.55, & + & 66.55, 66.94, 67.78, 68.72, 69.73, & + & 70.54, 70.23, 68.12, 65.18, 63.28, & + & 63.44, 65.41, 68.59, 72.39, 76.03, & + & 77.96, 76.47, 72.76, 69.27, 67.19, & + & 68.09, 68.43, 69.22, 70.18, 71.29, & + & 72.20, 71.93, 69.84, 66.95, 65.05, & + & 65.10, 66.94, 70.05, 73.82, 77.42, & + & 79.25, 77.65, 74.03, 70.72, 68.73, & + & 69.55, 69.83, 70.57, 71.56, 72.76, & + & 73.77, 73.55, 71.50, 68.67, 66.79, & + & 66.74, 68.47, 71.49, 75.20, 78.77, & + & 80.48, 78.78, 75.25, 72.09, 70.19, & + & 70.92, 71.14, 71.85, 72.87, 74.15, & + & 75.26, 75.09, 73.08, 70.35, 68.49, & + & 68.38, 69.99, 72.91, 76.55, 80.05, & + & 81.66, 79.85, 76.41, 73.40, 71.58, & + & 72.23, 72.39, 73.07, 74.11, 75.48, & + & 76.67, 76.55, 74.61, 71.97, 70.17, & + & 70.00, 71.50, 74.30, 77.85, 81.28, & + & 82.77, 80.85, 77.51, 74.64, 72.89, & + & 73.46, 73.58, 74.23, 75.30, 76.73, & + & 77.99, 77.93, 76.07, 73.56, 71.82, & + & 71.61, 73.00, 75.66, 79.09, 82.44, & + & 83.81, 81.78, 78.54, 75.82, 74.13, & + & 74.63, 74.71, 75.34, 76.44, 77.92, & + & 79.24, 79.24, 77.48, 75.10, 73.44, & + & 73.21, 74.48, 77.00, 80.29, 83.54, & + & 84.77, 82.64, 79.51, 76.93, 75.31, & + & 75.76, 75.80, 76.41, 77.52, 79.04, & + & 80.40, 80.46, 78.82, 76.59, 75.03, & + & 74.79, 75.95, 78.31, 81.43, 84.56, & + & 85.65, 83.42, 80.42, 77.98, 76.43, & + & 76.84, 76.86, 77.45, 78.57, 80.09, & + & 81.47, 81.61, 80.11, 78.05, 76.60, & + & 76.34, 77.40, 79.58, 82.52, 85.51, & + & 86.44, 84.12, 81.26, 78.97, 77.50, & + & 77.88, 77.89, 78.46, 79.57, 81.08, & + & 82.47, 82.68, 81.33, 79.46, 78.13, & + & 77.88, 78.83, 80.83, 83.55, 86.38, & + & 87.13, 84.74, 82.05, 79.91, 78.53, & + & 78.90, 78.90, 79.45, 80.53, 82.01, & + & 83.37, 83.66, 82.49, 80.82, 79.62, & + & 79.39, 80.23, 82.03, 84.52, 87.17, & + & 87.70, 85.29, 82.78, 80.81, 79.52, & + & 79.90, 79.89, 80.43, 81.46, 82.87, & + & 84.19, 84.56, 83.58, 82.13, 81.08, & + & 80.86, 81.60, 83.20, 85.45, 87.89, & + & 88.14, 85.76, 83.47, 81.67, 80.48, & + & 80.88, 80.88, 81.39, 82.36, 83.67, & + & 84.92, 85.36, 84.61, 83.39, 82.49, & + & 82.30, 82.94, 84.34, 86.32, 88.54, & + & 88.44, 86.18, 84.12, 82.50, 81.42, & + & 81.87, 81.87, 82.33, 83.22, 84.41, & + & 85.57, 86.07, 85.55, 84.58, 83.85, & + & 83.70, 84.24, 85.43, 87.14, 89.12, & + & 88.58, 86.54, 84.73, 83.31, 82.35, & + & 82.86, 82.86, 83.28, 84.06, 85.09, & + & 86.12, 86.67, 86.40, 85.70, 85.15, & + & 85.04, 85.50, 86.48, 87.90, 89.60, & + & 88.59, 86.85, 85.32, 84.10, 83.27, & + & 83.85, 83.86, 84.21, 84.86, 85.72, & + & 86.60, 87.16, 87.13, 86.72, 86.36, & + & 86.32, 86.69, 87.47, 88.58, 89.63, & + & 88.52, 87.13, 85.89, 84.89, 84.20, & + & 84.87, 84.87, 85.14, 85.65, 86.31, & + & 87.00, 87.53, 87.71, 87.59, 87.45, & + & 87.47, 87.77, 88.33, 89.04, 89.22, & + & 88.39, 87.37, 86.44, 85.67, 85.14, & + & 85.89, 85.89, 86.07, 86.41, 86.85, & + & 87.34, 87.76, 88.04, 88.18, 88.24, & + & 88.35, 88.56, 88.83, 89.00, 88.77, & + & 88.23, 87.58, 86.96, 86.44, 86.08, & + & 86.90, 86.89, 86.98, 87.14, 87.36, & + & 87.61, 87.86, 88.08, 88.26, 88.40, & + & 88.51, 88.57, 88.58, 88.50, 88.32, & + & 88.05, 87.75, 87.45, 87.19, 87.00, & + & 87.85, 87.85, 87.85, 87.85, 87.85, & + & 87.85, 87.85, 87.85, 87.85, 87.85, & + & 87.85, 87.85, 87.85, 87.85, 87.85, & + & 87.85, 87.85, 87.85, 87.85, 87.85/ +! data cormag/163.68,163.68,163.68,163.68,163.68, & +! ............................................... +! & 8.15, 8.15, 8.15, 8.15, 8.15/ +!btot +! data btot/49163.,49163.,49163.,49162.,49162., +! ............................................... +! &49945.,49945.,49945.,49945.,49945./ +!dipang +! data dipang/-74.12,-74.12,-74.12,-74.12,-74.12, +! .................................................. +! & 87.85, 87.85, 87.85, 87.85, 87.85/ + data glat/-1.570796327,-1.535889741,-1.500983156,-1.466076571, & + &-1.431169986, & + &-1.396263401,-1.361356816,-1.326450231,-1.291543646,-1.256637061, & + &-1.221730476,-1.186823891,-1.151917306,-1.117010721,-1.082104136, & + &-1.047197551,-1.012290966,-0.977384381,-0.942477796,-0.907571211, & + &-0.872664626,-0.837758041,-0.802851456,-0.767944871,-0.733038286, & + &-0.698131701,-0.663225116,-0.628318531,-0.593411946,-0.558505361, & + &-0.523598776,-0.488692190,-0.453785605,-0.418879020,-0.383972435, & + &-0.349065850,-0.314159265,-0.279252680,-0.244346095,-0.209439510, & + &-0.174532925,-0.139626340,-0.104719755,-0.069813170,-0.034906585, & + & 0.000000000, 0.034906585, 0.069813170, 0.104719755, 0.139626340, & + & 0.174532925, 0.209439510, 0.244346095, 0.279252680, 0.314159265, & + & 0.349065850, 0.383972435, 0.418879020, 0.453785605, 0.488692190, & + & 0.523598776, 0.558505361, 0.593411946, 0.628318531, 0.663225116, & + & 0.698131701, 0.733038286, 0.767944871, 0.802851456, 0.837758041, & + & 0.872664626, 0.907571211, 0.942477796, 0.977384381, 1.012290966, & + & 1.047197551, 1.082104136, 1.117010721, 1.151917306, 1.186823891, & + & 1.221730476, 1.256637061, 1.291543646, 1.326450231, 1.361356816, & + & 1.396263401, 1.431169986, 1.466076571, 1.500983156, 1.535889741, & + & 1.570796327/ + data glon/0.000000000, 0.314159265, 0.628318531, 0.942477796, & + & 1.256637061, & + &1.570796327, 1.884955592, 2.199114857, 2.513274122, 2.827433388, & + &3.141592653, 3.455751918, 3.769911184, 4.084070449, 4.398229714, & + &4.712388980, 5.026548245, 5.340707510, 5.654866775, 5.969026041/ +! lat lon interval + ddlat= 3.4906585033333331E-002 + ddlon= 0.3141592653000000 +! + do i=1,im +! get latitude index + iref=int(rlat(i)/ddlat)+46 + dl=(rlat(i)-glat(iref))/ddlat +! print*,iref,dl +! get longitude index + jref=int(rlon(i)/ddlon)+1 + jref1=jref+1 + if(jref1.gt.20) jref1=jref1-20 + dll=(rlon(i)-glon(jref))/ddlon +! print*,i,jref,jref1,dll +! + a1=cormag(jref,iref) + a2=cormag(jref1,iref) + b1=cormag(jref,iref+1) + b2=cormag(jref1,iref+1) + aa=(1.-dll)*a1+dll*a2 + bb=(1.-dll)*b1+dll*b2 + cormago(i)=(1.-dl)*aa+dl*bb +! + a1=btot(jref,iref) + a2=btot(jref1,iref) + b1=btot(jref,iref+1) + b2=btot(jref1,iref+1) + aa=(1.-dll)*a1+dll*a2 + bb=(1.-dll)*b1+dll*b2 + btoto(i)=(1.-dl)*aa+dl*bb +! + a1=dipang(jref,iref) + a2=dipang(jref1,iref) + b1=dipang(jref,iref+1) + b2=dipang(jref1,iref+1) + aa=(1.-dll)*a1+dll*a2 + bb=(1.-dll)*b1+dll*b2 + dipango(i)=(1.-dl)*aa+dl*bb +! + enddo + return + end +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE SPOLE(ix,im,RLAT,PHIR,utsec,SDA,PHIMR,ESSA,CMORG) + implicit none + real, PARAMETER ::PI=3.141592653,DTR=PI/180. + integer,intent(in) :: ix ! longitude dimension + integer,intent(in) :: im ! number of longitude + real, intent(in) :: rlat(im) !geo latitude (rad) + real, intent(in) :: phir(im) !geo longitude (rad) + real, intent(in) :: utsec !UT second + real, intent(in) :: sda !solar declination angle (rad) + real, intent(out):: phimr(im) !maglongitude (rad) + real, intent(out):: essa(im) !magnetic local time + real, intent(out):: cmorg(im) +! local variables + real th,th1,phi1,sinth,sinth1,costh1,sinph1,cosph1,ac1,bc1,cc1, & + & ac2,bc2,cc2,phim,ssp,sspr,csda,as1,bs1,cs1,as2,bs2,cs2,gml, & + & cmag + integer i +! + do i=1,im + th=pi/2.-rlat(i) +! +! SET POLE COORD. FOR EACH HEMIS. +! + IF (RLAT(i).GE.0.0) THEN + TH1=9.25*DTR + PHI1=-78.0*DTR + ELSE + TH1=16.32*DTR + PHI1=-54.0*DTR + END IF +! + SINTH=SIN(TH) + SINTH1=SIN(TH1) + COSTH1=COS(TH1) + SINPH1=SIN(PHI1) + COSPH1=COS(PHI1) +! +! do i=1,im + AC1=SINTH*COS(PHIR(i)) + BC1=SINTH*SIN(PHIR(i)) + CC1=COS(TH) + AC2=AC1*COSTH1*COSPH1+BC1*COSTH1*SINPH1-CC1*SINTH1 + IF((ABS(AC2)).LT.0.001)AC2=0.001 + BC2=-AC1*SINPH1+BC1*COSPH1 + CC2=AC1*SINTH1*COSPH1+BC1*SINTH1*SINPH1+CC1*COSTH1 + CMORG(i)=ACOS(CC2) + PHIMR(i)=ATAN2(BC2,AC2) + PHIM=PHIMR(i)/DTR +! SSP=360.-utsec/240. + SSP=180.-utsec/240. + SSPR=SSP*DTR + CSDA=PI/2.-SDA + AS1=COS(SSPR)*SIN(CSDA) + BS1=SIN(SSPR)*SIN(CSDA) + CS1=COS(CSDA) + AS2=AS1*COSTH1*COSPH1+BS1*COSTH1*SINPH1-CS1*SINTH1 + IF((ABS(AS2)).LT.0.001)AS2=0.001 + BS2=-AS1*SINPH1+BS1*COSPH1 + CS2=AS1*SINTH1*COSPH1+BS1*SINTH1*SINPH1+CS1*COSTH1 + GML=ATAN2(BS2,AS2)/DTR + ESSA(i)=PHIM-GML + enddo + RETURN + END diff --git a/gsmphys/idea_o2_o3.f b/gsmphys/idea_o2_o3.f new file mode 100644 index 00000000..1ed15d2f --- /dev/null +++ b/gsmphys/idea_o2_o3.f @@ -0,0 +1,153 @@ + subroutine idea_o2_o3(im,ix,levs,cosz,adt,o2_n,o3_n,rho,cp, & + &zg,grav,dth) +! +! Apr 06 2012 Henry Juang, initial implement for nems +! Jan 02 2013 Jun Wang, move o3ini out of column physics +! + use physcons, pi=>con_pi, avgd=>con_avgd & + & , amo3=> con_amo3 , amo2=> con_amo2 + use idea_composition +! + implicit none +! Argument + integer, intent(in) :: im ! number of data points in adt (first dim) + integer, intent(in) :: ix ! max data points in adt (first dim) + integer, intent(in) :: levs ! number of pressure levels + real, intent(in) :: cosz(im) ! cos zenith angle + real, intent(in) :: adt(ix,levs) !temp(k) + real, intent(in) :: o2_n(ix,levs) ! /m3 + real, intent(in) :: o3_n(ix,levs) ! /m3 + real, intent(in) :: rho(ix,levs) ! kg/m3 + real, intent(in) :: cp(ix,levs) ! J/kg/k + real, intent(in) :: zg(ix,levs) ! height (m) + real, intent(in) :: grav(ix,levs) ! (m/s2) + real, intent(out) :: dth(ix,levs) ! heating rate k/s +! + real hc,fc,dc,hha,fha,dha,hhu,i1,i2,m,dhu,lams,laml & + &,hhz,fhz,dhzo2,dhzo3,hsrb,fsrb,dsrb,ysrb,h1,rodfac + real clmo2(levs),clmo3(levs) + integer i,k +! +! + fc=370. !J/m2/s + dc=2.85E-25 !m2 + fha=5.13 !J/m2/s + dha=8.7E-22 !m2 + i1=0.07 !J/m2/s/A + i2=0.05 + m=0.01273 !/A + lams=2805. + laml=3015. + dhu=1.15e-6 !m2 + fhz=1.5 !J/m2/s + dhzo2=6.e-28 !m2 + dhzo3=4.e-22 !m2 + fsrb=0.0128 !J/m2/s + dsrb=2.07e-24 !m2 + ysrb=0.0152 +! + dth=0. + do i=1,im + if(cosz(i).ge.0.) then + rodfac=35./sqrt(1224.*cosz(i)**2+1.) + clmo2(levs)=1.e3*o2_n(i,levs)*bz*adt(i,levs)*avgd/ & + & (grav(i,levs)*amo2) + clmo3(levs)=1.e3*o3_n(i,levs)*bz*adt(i,levs)*avgd/ & + & (grav(i,levs)*amo3) + do k=levs-1,1,-1 + clmo2(k)=clmo2(k+1)+.5*(o2_n(i,k+1)+o2_n(i,k)) & +! & *(phil(i,k+1)-phil(i,k))/g & + & *(zg(i,k+1)-zg(i,k)) + clmo3(k)=clmo3(k+1)+.5*(o3_n(i,k+1)+o3_n(i,k)) & +! & *(phil(i,k+1)-phil(i,k))/g & + & *(zg(i,k+1)-zg(i,k)) + enddo + clmo2=clmo2*rodfac !rad path + clmo3=clmo3*rodfac + do k=1,levs + hc=fc*dc*exp(-1.*dc*clmo3(k)) + hha=fha*dha*exp(-1.*dha*clmo3(k)) + hhu=(i1+(i2-i1)*exp(-1.*dhu*clmo3(k)*exp(-1.*m*laml)) & + & -i2*exp(-1.*dhu*clmo3(k)*exp(-1.*m*lams))) & + & /(m*clmo3(k)) + hhz=fhz*(dhzo2*o2_n(i,k)+dhzo3*o3_n(i,k))*exp(-1.* & + & dhzo2*clmo2(k)-dhzo3*clmo3(k)) + h1=sqrt(1.+4.*dsrb*clmo2(k)/(pi*ysrb)) + hsrb=fsrb*dsrb*o2_n(i,k)*exp(-.5*pi*ysrb*(h1-1.))/h1 +! dth(i,k)=((hc+hha+hhu)*o3_n(i,k)+hhz+hsrb)/ & +! & (cp(i,k)*rho(i,k)) + dth(i,k)=((hc+hha*ef(k)+hhu)*o3_n(i,k)+hhz+hsrb)/ & + & (cp(i,k)*rho(i,k)) + enddo + else + dth(i,1:levs)=0. + endif + enddo + return + end + subroutine o3pro(im,ix,levs,ntrac,adr,am,n,o3_n) +! + use physcons, amo3=> con_amo3, avgd=> con_avgd + use idea_composition +! + implicit none +! Argument + integer, intent(in) :: im ! number of data points in adt (first dim) + integer, intent(in) :: ix ! max data points in adt (first dim) + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: ntrac ! number of tracer + real, intent(in) :: adr(ix,levs,ntrac) ! gfs tracer + real, intent(in) :: am(ix,levs) ! mixture mol weight kg + real, intent(in) :: n(ix,levs) ! number density /m3 + real, intent(out) :: o3_n(ix,levs) ! /m3 +! + real rate,mo3 + integer i,k +! + mo3=amo3*1.e-3/avgd + do i=1,im + do k=1,k71-1 + o3_n(i,k)=adr(i,k,2)*am(i,k)*n(i,k)/mo3 + enddo + rate=adr(i,k71,2)/o3ra(k71) + do k=k71,levs + o3_n(i,k)=o3ra(k)*rate*am(i,k)*n(i,k)/mo3 + enddo + enddo + return + end + subroutine o3ini(levs) +! + use idea_composition +! + implicit none + integer,intent(in) :: levs ! number of pressure levels + integer i + real c0(2),c1(2),c2(2),c3(2),logp,x + +! data c0/0.66965,0.92621/ +! data c1/-0.009682,0.13396/ +! data c2/0.033093,-0.076863/ +! data c3/0.017938,0.006897/ + data c0/0.66965,0.932363/ + data c1/-0.009682,0.139425/ + data c2/0.033093,-0.076863/ + data c3/0.017938,0.005075/ +! + allocate (ef(levs)) + do i=1,levs + logp=log10(pr_idea(i)) + if(logp.ge.0.) then + ef(i)=c0(2)+c1(2)+c2(2)+c3(2) + elseif(logp.ge.-2) then + x=1.+logp + ef(i)=c0(2)+c1(2)*x+c2(2)*x**2+c3(2)*x**3 + elseif(logp.ge.-4) then + x=3.+logp + ef(i)=c0(1)+c1(1)*x+c2(1)*x**2+c3(1)*x**3 + else + ef(i)=c0(1)-c1(1)+c2(1)-c3(1) + endif + enddo + return + end diff --git a/gsmphys/idea_phys.f b/gsmphys/idea_phys.f new file mode 100644 index 00000000..24bfe8ef --- /dev/null +++ b/gsmphys/idea_phys.f @@ -0,0 +1,605 @@ +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_phys(im,ix,levs,prsi,prsl, & + & adu,adv,adt,adr,ntrac,dtp,lat, & + & solhr,slag,sdec,cdec,sinlat,coslat, & + & xlon,xlat,oro,cozen,swh,hlw,dt6dt, & + & thermodyn_id,sfcpress_id,gen_coord_hybrid,me,& + & mpi_ior,mpi_comm) +!----------------------------------------------------------------------- +! add temp, wind changes due to viscosity and thermal conductivity +! also solar heating +! Apr 06 2012 Henry Juang, initial implement for NEMS +! Jul 26 2012 Jun Wang, add mpi info +! Sep 06 2012 Jun Wang, add changing pressure to cb +! Dec 2012 Jun Wang, change to new rad_merge (from Rashid and Fei) +! May 2013 Jun Wang, tmp updated after rad_merge +! Jun 2013 S. Moorthi Some optimization and cosmetic changes +! Oct 2013 Henry Juang, correct the sequence to get prsi from model top +!----------------------------------------------------------------------- + use physcons, amo2=>con_amo2,avgd => con_avgd + use idea_composition +! + implicit none +! Argument + integer, intent(in) :: im ! number of data points in adt (first dim) + integer, intent(in) :: ix ! max data points in adt (first dim) + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: lat ! latitude index + integer, intent(in) :: ntrac ! number of tracer + integer, intent(in) :: me ! my pe + integer, intent(in) :: mpi_ior ! mpi real for io + integer, intent(in) :: mpi_comm ! mpi communicator +! + real, intent(in) :: dtp ! time step in second + real, intent(inout) :: prsi(ix,levs+1) ! pressure + real, intent(inout) :: prsl(ix,levs) ! pressure + real, intent(in) :: hlw(ix,levs) ! long wave rad (K/s) + real, intent(in) :: swh(ix,levs) ! short wave rad (K/s) + real, intent(in) :: cozen(im) ! time avg(1 hour) cos zenith angle + real, intent(in) :: oro(im) ! surface height (m) + real, intent(in) :: solhr,slag,sdec,cdec ! for solar zenith angle + real, intent(in) :: xlon(im),xlat(im),coslat(im),sinlat(im) + real, intent(inout) :: adr(ix,levs,ntrac) ! tracer + real, intent(inout) :: adt(ix,levs) ! temperature + real, intent(inout) :: adu(ix,levs) ! real u + real, intent(inout) :: adv(ix,levs) ! real v + real, intent(inout) :: dt6dt(ix,levs,6)! diagnostic array + integer,intent(in) :: thermodyn_id, sfcpress_id + logical,intent(in) :: gen_coord_hybrid +! Local variables + real,parameter :: pa2cb=0.001,cb2pa=1000. +! + real cp(ix,levs),cospass(im),dt(ix,levs),rtime1,hold1,n(ix,levs) + real o_n(ix,levs),o2_n(ix,levs),n2_n(ix,levs),o3_n(ix,levs), & + & am(ix,levs),dudt(ix,levs),dvdt(ix,levs),dtdt(ix,levs),xmu(im), & + & dtco2c(ix,levs),dtco2h(ix,levs) & + &,dth2oh(ix,levs),dth2oc(ix,levs),dto3(ix,levs),rho(ix,levs) & + &,wtot(ix,levs),zg(ix,levs) & + &,amin,amax,grav(ix,levs) & + &,prslk(ix,levs),prsik(ix,levs+1),phil(ix,levs),phii(ix,levs+1) +! solar + real utsec,sda,maglat(im),maglon(im),btot(im), & + & dipang(im),essa(im),dlat,dlon + integer i,k,dayno,j1,j2 + +! change to real windl !hmhj already real wind +!hmhj do i=1,im +!hmhj adu(i,1:levs)=adu(i,1:levs)/coslat(i) +!hmhj adv(i,1:levs)=adv(i,1:levs)/coslat(i) +!hmhj enddo ! i +! get phil geopotential from temperature +! change prsi and prsl to centibar from pascal + + do k=1,levs + do i=1,im + prsi(i,k) = prsi(i,k)*pa2cb + prsl(i,k) = prsl(i,k)*pa2cb + enddo + enddo + do i=1,im + prsi(i,levs+1) = prsi(i,levs+1)*pa2cb + enddo + +!hmhj call GET_PHI_gc_h(im,ix,levs,ntrac,adt,adr,prsi,phii,phil) + call get_phi(im,ix,levs,ntrac,adt,adr, & + & thermodyn_id, sfcpress_id, & + & gen_coord_hybrid, & + & prsi,prsik,prsl,prslk,phii,phil) +! get height + call phi2z(im,ix,levs,phil,oro,zg,grav) +! print*,'wwwz',zg(1,1:150) +! print*,'wwwg',grav(1,1:150) +! print*,'wwwp',phil(1,1:150),oro(1) +! +! get composition at layers (/cm3) and rho (kg/m3) + call idea_tracer(im,ix,levs,ntrac,2,grav,prsi,prsl,adt,adr, & + & dtp,o_n,o2_n,n2_n,n,rho,am) +! calculate cp + call getcp_idea(im,ix,levs,ntrac,adr,cp, & + & thermodyn_id,gen_coord_hybrid) +! dissipation + call idea_phys_dissipation(im,ix,levs,grav,prsi,prsl, & + & adu,adv,adt,o_n,o2_n,n2_n,dtp,cp,dt6dt) +! +! get cos solar zenith angle (instant) + call presolar(im,ix,solhr,slag, & + & sinlat,coslat,sdec,cdec,xlon,xlat & + & ,cospass,dayno,utsec,sda & + & ,maglat,maglon,btot,dipang,essa) +! get solar heating and NO cooling then get temp adjustment + call idea_sheat(im,ix,levs,adt,dt,cospass,o_n,o2_n,n2_n,rho, & + & cp,lat,dayno,prsl,zg,grav,am,maglat,dt6dt) +! rtime1=3600.*6. + + do k=1,levs + do i=1,im + adt(i,k) = adt(i,k) + dt(i,k)*dtp +! dt3dt(i,k,1) = dt(i,k)*rtime1 +! +! ion_drag - change to /m3 + o_n(i,k) = o_n(i,k) * 1.e6 + o2_n(i,k) = o2_n(i,k) * 1.e6 + n2_n(i,k) = n2_n(i,k) * 1.e6 + n(i,k) = n(i,k) * 1.e6 + enddo + enddo + + call idea_ion(solhr,cospass,zg,o_n,o2_n,n2_n,cp, & + & adu,adv,adt,dudt,dvdt,dtdt,rho,xlat,xlon,ix,im,levs,& + & dayno,utsec,sda,maglon,maglat,btot,dipang,essa) + +! do i=1,im +! dlat=xlat(i)*180./3.14159 +! dlon=xlon(i)*180./3.14159 +! if(abs(dlat-60.).le.1..and.abs(dlon-270.).le.1.) then +! print*,'www0',solhr,dudt(i,140)*dtp,dvdt(i,140)*dtp, & +! &dtdt(i,140)*dtp,adu(i,140),adv(i,140) +! endif + + do k=1,levs + do i=1,im + adu(i,k) = adu(i,k) + dtp*dudt(i,k) + adv(i,k) = adv(i,k) + dtp*dvdt(i,k) + adt(i,k) = adt(i,k) + dtp*dtdt(i,k) + enddo + enddo + +! change u,V back !hmhj no need to change back, they are real wind +!hmhj do i=1,im +!hmhj adu(i,1:levs)=adu(i,1:levs)*coslat(i) +!hmhj adv(i,1:levs)=adv(i,1:levs)*coslat(i) +!hmhj enddo ! i +! radiation +! co2 cooling, heating + + call idea_co2(im,ix,levs,nlev_co2,ntrac,grav,cp,adr,adt, & + & dtco2c,cospass,dtco2h) + +!hmhj&'/mtb/save/wx20fw/fcst07rd',dtco2c,cospass,dtco2h) +! h2o cooling heating 110-41 down ward + + call idea_h2o(im,ix,levs,nlev_h2o,nlevc_h2o,ntrac,grav,cp, & + & adr,adt,dth2oh,cospass,dth2oc) + + dt6dt(1:im,1:levs,4) = dtco2c +! dt6dt(1:im,1:levs,5) = dth2oc +! dt6dt(1:im,1:levs,6) = dth2oh +! dth2oc=0. +! dth2oh=0. +! o2 o3 heating + + call o3pro(im,ix,levs,ntrac,adr,am,n,o3_n) + call idea_o2_o3(im,ix,levs,cospass,adt,o2_n,o3_n,rho,cp, & + & zg,grav,dto3) +! get xmu + do i=1,im + if(cospass(i) > 0.0001 .and. cozen(i) > 0.0001) then + xmu(i) = cospass(i)/cozen(i) + else + xmu(i) = 0. + endif + enddo +! dt6dt +! do i=1,im +! do k=1,levs +! dt6dt(i,k,2)=dtco2c(i,k) +! dt6dt(i,k,3)=dtco2h(i,k) +! dt6dt(i,k,4)=dth2oc(i,k) +! dt6dt(i,k,5)=dth2oh(i,k) +! dt6dt(i,k,6)=dto3(i,k) +! enddo +! enddo +! merge + call rad_merge(im,ix,levs,hlw,swh,prsi,prsl,wtot, + & xmu,dtco2c,dtco2h,dth2oh,dth2oc,dto3,dt6dt) + do k=1,levs + do i=1,im + adt(i,k) = adt(i,k) + dtp*wtot(i,k) +! dt6dt + dt6dt(i,k,2) = wtot(i,k) +! change prsi and prsl back to pascal + prsi(i,k) = prsi(i,k)*cb2pa + prsl(i,k) = prsl(i,k)*cb2pa + enddo + enddo + do i=1,im + prsi(i,levs+1) = prsi(i,levs+1)*cb2pa + enddo + + return + end subroutine +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine getcp_idea(im,ix,levs,ntrac,adr,xcp, & + & thermodyn_id,gen_coord_hybrid) +! + use tracer_const +!hmhj use resol_def , only: thermodyn_id +!hmhj use namelist_def , only: gen_coord_hybrid +! + implicit none + integer, intent(in) :: im ! number of data points in adr (first dim) + integer, intent(in) :: ix ! max data points in adr (first dim) + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: ntrac ! number of tracer + real, intent(in) :: adr(ix,levs,ntrac) ! tracer kg/kg + real, intent(out) :: xcp(ix,levs) !CP (J/kg/k) + integer thermodyn_id + logical gen_coord_hybrid +! +! local + real sumq(ix,levs),work1 + integer i,j,k,ntb + sumq = 0.0 + xcp = 0.0 + if( gen_coord_hybrid .and. thermodyn_id == 3 ) then + ntb = 1 + elseif (ntrac >= 4) then + ntb = 4 + else + return + endif + do i=ntb,ntrac + if( cpi(i) /= 0.0 ) then + do k=1,levs + do j=1,im + work1 = adr(j,k,i) + sumq(j,k) = sumq(j,k) + work1 + xcp(j,k) = xcp(j,k) + work1*cpi(i) + enddo + enddo + endif + enddo + do k=1,levs + do j=1,im + xcp(j,k) = xcp(j,k) + (1.-sumq(j,k))*cpi(0) + enddo + enddo + return + end + subroutine rad_merge(im,ix,levs,hlw,swh,prsi,prsl,wtot, & + & xmu,dtco2c,dtco2h,dth2oh,dth2oc,dto3,dt6dt) +! + implicit none + integer, intent(in) :: im ! number of data points in hlw,dt..(first dim) + integer, intent(in) :: ix ! max data points in hlw,... (first dim) + integer, intent(in) :: levs ! number of pressure levels + real, parameter :: xb=7.5, xt=8.5, rdx=1./(xt-xb) + real, intent(in) :: hlw(ix,levs) ! GFS lw rad (K/s) + real, intent(in) :: swh(ix,levs) ! GFS sw rad (K/s) + real, intent(in) :: prsi(ix,levs+1) ! pressure + real, intent(in) :: prsl(ix,levs) ! pressure + real, intent(in) :: xmu(im) ! mormalized cos zenith angle + real, intent(in) :: dtco2c(ix,levs) ! idea co2 cooling(K/s) + real, intent(in) :: dtco2h(ix,levs) ! idea co2 heating(K/s) + real, intent(in) :: dth2oc(ix,levs) ! idea h2o cooling(K/s) + real, intent(in) :: dth2oh(ix,levs) ! idea h2o heating(K/s) + real, intent(in) :: dto3(ix,levs) ! idea o3 heating(K/s) + real, intent(out) :: wtot(ix,levs) ! GFS idea combined rad + real, intent(inout) :: dt6dt(ix,levs,6) +! local + real xk,wl,wh + integer i,k,j +! + do k=1,levs + do i=1,im + xk = log(prsi(i,1)/prsl(i,k)) + wh = dtco2c(i,k)+dth2oc(i,k)+dtco2h(i,k)+dth2oh(i,k)+dto3(i,k) + wl = hlw(i,k)+swh(i,k)*xmu(i) + if(xk < xb) then + wtot(i,k) = wl + elseif(xk >= xb .and. xk <= xt) then + wtot(i,k) = (wl*(xt-xk) + wh*(xk-xb))*rdx + else + wtot(i,k) = wh + endif + enddo + enddo + return + end +! + subroutine getmax(ain,n1,n,m,rmin,j1,rmax,j2) + real ain(n1,m) + rmin = 1.e36 + rmax = -1.e36 + i1 = 500 + j1 = 500 + i2 = 500 + j2 = 500 + do j=1,m + do i=1,n + if(rmin > ain(i,j)) then + rmin = ain(i,j) + i1 = i + j1 = j + endif + if(rmax < ain(i,j)) then + rmax = ain(i,j) + i2 = i + j2 = j + endif + enddo + enddo + return + end + subroutine getmax2(ain,ain1,n1,n,m,rmax,j2) + real ain(n1,m),ain1(n1,m) + rmax = -1.e36 + i1 = 500 + j1 = 500 + i2 = 500 + j2 = 500 + do j=1,m + do i=1,n + sq = sqrt(ain(i,j)*ain(i,j) + ain1(i,j)*ain1(i,j)) + if(rmax < sq) then + rmax = sq + i2 = i + j2 = j + endif + enddo + enddo + return + end + subroutine phi2z(im,ix,levs,phi,soro,z,grav) + +! Subroutine to calculate geometric height and gravity from geopotential +! in a hydrostatic atmosphere, assuming a spherically symmetric planet +! and Newton's gravity. + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! File history + +! Feb 26, 2010: Rashid Akmaev +! Loosely based on Hojun Wang's phi2hgt but generalized to rid of +! recursive calculations, include surface orography, and calculate +! gravity. + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Define constants +! - Earth radius (m) and +! - gravity at sea level (m/s**2) + +! If used with GFS/WAM codes "use" this module + use physcons, only: re => con_rerth, g0 => con_g + + implicit none + +! If the module is not available, comment out the "use" line above and +! uncomment this line +! real, parameter:: re = 6.3712e+6, g0 = 9.80665e+0 + + real, parameter:: g0re = g0*re, g0re2 = g0*re*re + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine parameters +! INPUTS +! - array dimensions (following GFS conventios): first actual, first +! maximum, number of levels + + integer, intent(in):: im,ix,levs + +! - geopotential (m**2/s**2) +! - surface orography (m) + + real, intent(in):: phi(ix,levs),soro(im) + +! OUTPUTS +! - height (m) + + real, intent(out):: z(ix,levs) + +! Optional output +! - gravity (m/s**2) + +! real, intent(out), optional:: grav(ix,levs) + real, intent(out):: grav(ix,levs) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Local variables + + integer:: i,l + real:: phis(im) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate surface geopotential + + do i = 1,im + phis(i) = g0re*soro(i)/(re+soro(i)) + enddo + +! Calculate height + + z(:,:) = 0. + do l = 1,levs + do i = 1,im + z(i,l) = re*(phis(i)+phi(i,l))/(g0re-(phis(i)+phi(i,l))) + enddo + enddo + +! ***Optionally*** calculate gravity + +! if(present(grav)) then + grav(:,:) = 0. + do l = 1,levs + do i = 1,im + grav(i,l) = g0re2/((re+z(i,l))*(re+z(i,l))) + enddo + enddo +! endif + end subroutine phi2z +!---------------------------------------------------------------------------- + subroutine gravco2(levs,phi,soro,gg) + +! Subroutine is modified from phi2z above to compute gravity for co2cin, +! the first gaussian point is chosen to represent the whole data domain + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! File history + +! Dec 26, 2012: Jun Wang modified from phi2z from Rashid + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Define constants +! - Earth radius (m) and +! - gravity at sea level (m/s**2) + +! If used with GFS/WAM codes "use" this module + use physcons, only: re => con_rerth, g0 => con_g + + implicit none + +! If the module is not available, comment out the "use" line above and + real, parameter:: g0re = g0*re, g0re2 = g0*re**2 + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine parameters +! INPUTS + + integer, intent(in):: levs + +! - geopotential (m**2/s**2) +! - surface orography (m) + + real, intent(in):: phi(levs),soro + +! OUTPUTS + +! Optional output +! - gravity (m/s**2) + + real, intent(out):: gg(levs) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Local variables + + integer:: i,l + real:: phis + real:: z(levs) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Calculate surface geopotential + + phis = g0re*soro/(re+soro) + print *,'in grevco2 phis=',phis,'phi=',phi(1:100:10),'soro=',soro, + & 're=',re + +! Calculate height + + z(:) = 0. + do l = 1,levs + z(l) = re*(phis+phi(l))/(g0re-(phis+phi(l))) + enddo + +! ***Optionally*** calculate gravity + + gg(:) = 0. + do l = 1,levs + gg(l) = g0re2/((re+z(l))*(re+z(l))) + enddo + print *,'in grevco2 gg=',gg(1:100:10) +! + end subroutine gravco2 +!---------------------------------------------------------------------------- + subroutine getphilvl(levs,ntrac,ps,t,q,dp,gen_coord_hybrid, + & thermodyn_id,phil,prsi) + +! Subroutine computes phi on a single point on model levels from p,tmp, +! and trcers for general + +! hybrid for enthalpy + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! File history + +! Dec 26, 2010: Jun Wang + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + use tracer_const, only : ri + implicit none + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine parameters +! INPUTS + + integer, intent(in):: levs,ntrac + logical, intent(in):: gen_coord_hybrid + integer, intent(in):: thermodyn_id +! +! Local variables + real,parameter :: pa2cb=0.001,zero=0.0 +! - sfc pressure (pascal) +! - pressure thickness (pascal) +! - tmp (k) +! - tracers + + real, intent(in):: ps,t(levs),dp(levs),q(levs,ntrac) + +! OUTPUTS + +! Optional output +! - model layer enthalpy + + real, intent(out):: phil(levs),prsi(levs+1) + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Local variables + real:: tem,dphi,phii,sumq(levs),xr(levs) + integer :: k,n + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! init + + phii = zero + +! Calculate enthalpy +! +! print *,'in getphilvl,thermodyn_id=',thermodyn_id, +! & thermodyn_id.eq.3 + + if( gen_coord_hybrid ) then + if( thermodyn_id == 3 ) then ! Enthalpy case +!get r + sumq = zero + xr = zero + do n=1,ntrac + if( ri(n) > 0.0 ) then + do k=1,levs + xr(k) = xr(k) + q(k,n) * ri(n) + sumq(k) = sumq(k) + q(k,n) + enddo + endif + enddo + do k=1,levs + xr(k) = (1.-sumq(k))*ri(0) + xr(k) + enddo +! +!hmhj prsi(1) = ps*pa2cb +!hmhj do k=1,levs +!hmhj prsi(k+1) = prsi(k)-dp(k)*pa2cb +!hmhj enddo +!hmhj if compute prsi, we from ptop=0 with dp down to psfc + prsi(levs+1) = 0. + do k=levs,1,-1 + prsi(k) = prsi(k+1) + dp(k)*pa2cb + enddo +! print *,'in getphilvl,prsi=',prsi(1:100:10) +! + do k = 1,levs + tem = xr(k) * T(k) + dphi = (prsi(k) - prsi(k+1)) * TEM + & /(prsi(k) + prsi(k+1)) + phil(k) = phii + dphi + phii = phil(k) + dphi + enddo +! + else + print *,'ERROR: No phil is compute, this routine is ', + & 'for gen-hybrid with enthalpy' +! + endif + endif +! + end subroutine getphilvl +!------------------------------------------------------------------ + diff --git a/gsmphys/idea_solar_heating.f b/gsmphys/idea_solar_heating.f new file mode 100644 index 00000000..f0c98a60 --- /dev/null +++ b/gsmphys/idea_solar_heating.f @@ -0,0 +1,1227 @@ + module idea_solar +!--------------------------------------------------------------------------- +! hold effuv,effeuv ro (density (kg/m3)),nps (start pressure levels index) +! Apr 06 2012 Henry Juang, initial implement for nems +! Oct 20 2015 Weiyu Yang - add the f107 and kp inputted data. +!--------------------------------------------------------------------------- + use machine, only : kind_phys + use wam_f107_kp_mod, only: f107, kp, kdt_3h + implicit none +!hmhj save + real (kind=kind_phys), allocatable :: effuv(:), effeuv(:) + integer nps + end module idea_solar +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_solar_init(levs) +!---------------------------------------------------------------------------- +! calculete effuv,effeuv,pr index to start solar heating calc +!---------------------------------------------------------------------------- + use idea_composition, pr=> pr_idea + use physcons, amo2=>con_amo2,avgd => con_avgd + use machine, only : kind_phys + use idea_solar + implicit none +! +! define some constants + integer, intent(in) :: levs !number of pressure level +!c real effeuv17(17),effuv17(17),p17(17),z17(17),dz,noh(17),z(levs), & +!c &nol(17),no17(17),f107_local + real effeuv17(17),effuv17(17),p17(17),z17(17),dz,z(levs), & + & f107_local + integer k,i,kref +! + allocate (effeuv(levs)) + allocate (effuv(levs)) +!c allocate (no_idea(levs)) !no number density (/cm3) +! +! ** EUV and UV heating efficiency on 17 pressure levels + DATA EFFEUV17/8*1.0,.75,.6,.62,.54,.49,.41,.33,.30,.30/ + DATA EFFUV17/5*.28,.29,.32,.38,.4,.4,.4,.39,.34,.26,.19,.17,.16/ +!c data nol/11.88,11.88,11.68,11.83,12.02,12.19,12.38,12.54,12.51, & +!c &12.54,12.38,12.19,11.68,10.96,10.24,9.5,8.76/ +!c data noh/12.57,12.57,12.57,12.92,13.06,13.33,13.24,13.39,13.06, & +!c &13.02,12.65,12.33,11.61,10.96,10.21,9.47,8.73/ +! find nps (2Pa) + do k=1,levs + if(pr(k).le..02) then + nps=k + go to 10 + endif + enddo + 10 continue +! get 17 levels no at f107 + f107_local=f107(kdt_3h) +!c dz=(f107_local-67.)/(243.-67.) +!c do k=1,17 +!c no17(k)=dz*noh(k)+(1.-dz)*nol(k) +!c enddo +! get effuv,effeuv from interplating effuv17, effeuv17 to 150 levs +! get no from interplating no17 to 150 levs + do k=1,17 + p17(k)=5.2285*exp(1.-k) + z17(k)=-1.*log(p17(k)) + enddo + do k=1,levs + z(k)=-1.*log(pr(k)*100.) + enddo + do k=1,levs + kref=0 + do i=1,16 + if(z(k).ge.z17(i).and.z(k).le.z17(i+1)) then + kref=i + dz=(z(k)-z17(i))/(z17(i+1)-z17(i)) + endif + enddo + if(kref.ne.0) then + effuv(k)=dz*effuv17(kref+1)+(1.-dz)*effuv17(kref) + effeuv(k)=dz*effeuv17(kref+1)+(1.-dz)*effeuv17(kref) +!c no_idea(k)=dz*no17(kref+1)+(1.-dz)*no17(kref) + elseif(z(k).lt.z17(1)) then + effuv(k)=effuv17(1) + effeuv(k)=effeuv17(1) +!c no_idea(k)=no17(1) + elseif(z(k).gt.z17(17)) then + effuv(k)=effuv17(17) + effeuv(k)=effeuv17(17) +!c no_idea(k)=no17(17) + endif + enddo +! print*,'effuv' +! print'(10f6.3)',effuv +! print*,'effeuv' +! print'(10f6.3)',effeuv +! result in /cm3 +!c no_idea=1.e-6*10.**(no_idea) +! + return + end subroutine +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_sheat(im,ix,levs,te,dt,cospass,o_n,o2_n,n2_n, & + &ro,cp,lat,dayno,prsl,zg,grav,am,maglat,dt6dt) +!---------------------------------------------------------------------------- +! calculete solar heating, NO coooling from 2Pa up +!---------------------------------------------------------------------------- +!c use idea_solar, no_n => no_idea + use idea_solar + use idea_composition, pr=>pr_idea + use physcons, rgas=>con_rgas, amo2=>con_amo2, & + & avgd => con_avgd + use machine, only : kind_phys + implicit none +! + integer, intent(in) :: im !number of data piont in te + integer, intent(in) :: ix !maxmum data point in te + integer, intent(in) :: levs !number of press level + integer, intent(in) :: lat ! latitude index + integer, intent(in) :: dayno ! calender day + real, intent(in) :: te(ix,levs) !temperature + real, intent(in) :: cospass(im) ! cos zenith angle + real, intent(in) :: maglat(im) ! + real, intent(in) :: cp(ix,levs) ! + real, intent(in) :: o_n(ix,levs) !number density of O(/cm3) + real, intent(in) :: o2_n(ix,levs)!number density of O2 + real, intent(in) :: n2_n(ix,levs)!number density of N2 + real, intent(in) :: am(ix,levs) !mass of mix (kg) + real, intent(in) :: prsl(ix,levs)!layer press (Pa) + real, intent(in) :: zg(ix,levs)!layer height (m) + real, intent(in) :: grav(ix,levs)! (m/s2) + real, intent(in) :: ro(ix,levs) ! density (kg/m3) + real, intent(inout) :: dt6dt(ix,levs,6) ! + real, intent(out) :: dt(ix,levs) ! (K/s)temp change due to solar heating + integer i,k + real t(levs),n2(levs),no(levs),o(levs),o2(levs),ho(levs), & + &ho2(levs),hn2(levs),sheat(levs),qno(levs),f107_local,no_new(levs),& + &amm(levs),prr(levs),alt(levs),nn(levs),sh1(levs),sh2(levs) +!c no=no_n*1.e6 +! rtime1=3600.*6. + f107_local=f107(kdt_3h) +! print*, 'in idea_sheat, kdt_3h, f107_local=',kdt_3h, f107_local + do i=1,im + do k=1,levs + o(k)=o_n(i,k)*1.e6 !/m3 + o2(k)=o2_n(i,k)*1.e6 + n2(k)=n2_n(i,k)*1.e6 + enddo + do k=1,levs + t(k)=te(i,k) + ho(k)=1.e3*rgas*t(k)/(amo*grav(i,k)) !m + ho2(k)=1.e3*rgas*t(k)/(amo2*grav(i,k)) + hn2(k)=1.e3*rgas*t(k)/(amn2*grav(i,k)) + enddo +! try Tim's data +! call gettimdata(pr,n2,no,o,o2,ho,ho2,hn2,t,ro1) +! call gettimdata17(n2,no,o,o2,ho,ho2,hn2,t,ro1) +! call solar_heat(17,1,o,o2,n2,ho,ho2,hn2,effeuv17,effuv17, & +! & f107_local,cospass,sheat) +! call COOLNO1(17,1,t,o,no,qno) +! get heating + call solar_heat(levs,nps,o,o2,n2,ho,ho2,hn2,effeuv,effuv, & + & f107_local,cospass(i),sheat,sh1,sh2) + do k=1,levs +! alt(k)=phil(i,k)/g*1.e-3 !km + alt(k)=zg(i,k)*1.e-3 !km + prr(k)=prsl(i,k) + nn(k)=o(k)+o2(k)+n2(k) + amm(k)=am(i,k)*1.e3*avgd + enddo + call getno(1,1,levs,maglat(i),dayno,alt,prr,nn,amm,no_new) +! get no cooling +!c call COOLNO1(levs,nps,t,o,no,qno) + call COOLNO1(levs,nps,t,o,no_new,qno) +! print*,'www2',no_new(104:123) +!c print*,'www2-old',no(104:123) +! do k=1,17 +! dt=(sheat(k)-qno(k))*dtp/(cp(k)*ro1(k)) +! te(i,k)=t(k)+dt*dtp +! print'(i4,5f7.2,3e11.3)',k,log10(o(k)),log10(o2(k)),log10(n2(k)), & +! &t(k),log10(no(k)),ro1(k),sheat(k)/ro1(k)*.55,qno(k)/ro1(k) + do k=nps,levs +! dt6dt(i,k,1)=qno(k)*rtime1/(cp(i,k)*ro(i,k)) + dt6dt(i,k,1)=qno(k)/(cp(i,k)*ro(i,k)) + dt6dt(i,k,3)=sh1(k)/(cp(i,k)*ro(i,k)) + dt6dt(i,k,4)=sh2(k)/(cp(i,k)*ro(i,k)) + dt(i,k)=(sheat(k)-qno(k))/(cp(i,k)*ro(i,k)) +! dt6dt(i,k,5)=(sheat(k)-qno(k))/(cp(i,k)*ro(i,k)) +! print*,'www2',k,sheat(k),qno(k),dt(i,k) + enddo ! k + do k=1,nps-1 + dt(i,k)=0. + dt6dt(i,k,1)=0. + dt6dt(i,k,3)=0. + dt6dt(i,k,4)=0. + dt6dt(i,k,5)=0. + enddo ! k +! print'(i4,5f7.2,3e11.3)',k,log10(o(150)),log10(o2(150)), & +! &log10(n2(150)), & +! &t(150),log10(no(150)),ro(150,lan),sheat(150)/ro(150,lan)*.55, & +! &qno(150)/ro(150,lan) + enddo !i +! print for pictures +! if(lat.eq.47) then +! do i=1,im +! if(abs(cospass(i)-1.).le..01) then +! do k=87,150 +! print'(i4,5f7.2,1e11.3)',k,log10(o(k)),log10(o2(k)),log10(n2(k)), & +! &t(k),log10(no(k)),ro(k,lan) +! enddo +! endif +! enddo +! endif + return + end +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + SUBROUTINE solar_heat(np,nps,O,O2,N2,HO,HO2,HN2,effeuv,effuv, & + &F107_local,COSPASS,sheat,sh1,sh2) +!------------------------------------------------------------------------- +! calculate solar heating from Tim Fuller-Rowell +!------------------------------------------------------------------------- +!c ** +!c calculates solar heating from EUV and SRC wavelengths +!c assumes a heating efficiency profile on pressure levels +!c code was written in SI units +!c Input: +!c O atomic oxygen number density profile m-3 +!c O2 molecular oxygen number density profile m-3 +!c N2 molecular nitrogen number density profile m-3 +!c HO atomic oxygen scale height profile m +!c HO2 molecular oxygen scale height profile m +!c HN2 molecular nitrogen scale height profile m +!c solar flux F10.7 +!c COSPASS cosine of solar zenith angle +!c Output: +!c SHEAT heating rate profile J/m-3 +!--------------------------------------------------------------------------- + implicit none + integer, intent(in) :: np ! number of pressure levels + integer, intent(in) :: nps !pressure index to start + real, intent(in) :: o(np),o2(np),n2(np) ! number density/m3 + real, intent(in) :: ho(np),ho2(np),hn2(np) ! scale height(m) + real, intent(in) :: effeuv(np),effuv(np) !heating efficiency + real, intent(in) :: f107_local !f10.7cm + real, intent(in) :: cospass !cos zenith angle + real, intent(out) :: sheat(np),sh1(np),sh2(np) !J/m3 heating rate + real SO(np),SO2(np),SN2(np), & + &SFL(57),CSAO(57),CSAO2(57),CSAN2(57),CSIO(57), & + &CSIO2(57),CSIN2(57),SFH(57),SF(57),PAEUV(np,65),SFUV(8), & + &A(8),UVXS(8),RLAM(65) + real coschi,rnight,seco,seco2,secn2,wo,wo2,wn2,tau,tauo,tauo2, & + & taun2,pcc + integer i,j,jj +!c ** +!c number of pressure levels to process for solar heating +!c pressure levels defined by pressure(n)=5.2285*exp(1-n) +!c ** +!c wavelength/energy conversion SI E=hc/lamda + PCC=1.985E-25 +!c ** +!C WAVELENGTHS Angstroms +!C ** + DATA RLAM/18.6,19.0,21.6,21.8,22.1,28.5,28.8,29.5,30.0, & + &30.4,33.7,41.0,43.8,44.0,44.2,45.7,46.4,46.7,47.9,49.2, & + &75.,125.,175.,225.,256.3,284.15,275.,303.31,303.78, & + &325.,368.07,375.,425.,465.22,475.,525.,554.37,584.33, & + &575.,609.76,629.73,625.,675.,730.36,725.,765.15,770.41, & + &789.36,775.,825.,875.,925.,977.62,975.,1025.72,1031.91, & + &1025.,1387.5,1425.,1475.,1525.,1575.,1625.,1675.,1725./ +!C ** +!C REVISED FLUXES BY TORR AND TORR 85 JGR 90 6675 +!C WITH ADDITIONAL VALUES 1 TO 20 FOR WAVELENGTHS BELOW 50A. +!C ** + DATA SFL/ + &.0001,.0001,.0003,.0001,.0003,.0005,.0025,.0022,.0012, & + &.0006,.0011,.0006,.0021,.0008,.0009,.0005,.0027,.0052, & + &.0059,.0043, & + &.38,.13,1.84,.92,.27,.1,.84,.24,6.,.87,.74,.21,.39,.18, & + &.31,.51,.80,1.58,.48,.45,1.5,.17,.22,.39,.17,.2,.24, & + &.79,.87,1.93,4.43,4.22,5.96,1.79,4.38,3.18,3.64/ +!c ** + DATA SFH/ & + &.0016,.0053,.0048,.0016,.0048,.0072,.0211,.0186,.0024, & + &.0104,.0158,.0073,.0130,.0097,.0109,.0061,.0168,.0107, & + &.0121,.0267, & + &1.37,.468,5.7,7.14,1.08,5.72,12.16,4.69,14.39,6.83,1.53, & + &2.54,1.53,.736,1.82,1.64,1.52,4.3,1.048,2.48,3.87,1.37, & + &.539,.746,.429,.439,1.19,1.514,2.454,4.85,12.219,9.85, & + &10.217,4.078,11.85,6.1,6.09/ +!c ** +!c UV FLUX IN SRC AND O2 X-SECTIONS FROM M.R.TORR ET AL +!c JGR 1980 6063 +!c ** + DATA A/9.73,17.93,27.38,51.57,70.99,97.4,205.,374.24/ + DATA UVXS/1.2E-17,1.5E-17,1.3E-17,1.0E-17,6.0E-18,3.4E-18, & + &1.5E-18,5.0E-19/ +!C ** +!C REVISED VALUES FROM SAMSON AND PAREEK 85 +!C ** + DATA CSAO/ & + &.34,.36,.5,.51,.52,.05,.05,.06,.06,.06,.08,.13,.15, & + &.15,.16,.17,.18,.18,.19,.21, & + &0.7,1.7,3.0,5.1,6.2,7.3,7.0,7.7,7.7,8.5,10.,10., & + &11.21,11.25,11.64,11.91,12.13,12.17,11.9,12.23,12.22, & + &12.21,10.04,11.35,8.0,4.18,4.18,4.28,4.23,4.38,4.18,2.12, & + &0.,0.,0.,0.,0./ +!c ** + DATA CSAO2/ & + &.69,.72,.99,1.01,1.05,.10,.11,.11,.12,.12,.16,.26,.3,.31, & + &.31,.34,.35,.36,.38,.41, & + &1.18,3.61,7.27,10.5,12.8,14.8,13.65,15.98,16.,17.19,18.40, & + &18.17,19.39,20.4,21.59,24.06,25.59,22.0,25.04,26.1,25.8, & + &26.02,26.27,25.,29.05,21.98,25.18,26.66,27.09,20.87,9.85, & + &15.54,4.0,16.53,1.6,1.0,1.1/ +!c ** + DATA CSAN2/ & + &.44,.47,.65,.67,.69,1.13,1.13,1.12,1.11,1.10,.1,.16,.19, & + &.19,.19,.21,.22,.22,.24,.25, & + &.6,2.32,5.4,8.15,9.65,10.6,10.8,11.58,11.6, & + &14.6,18.0,17.51,21.07,21.8, & + &21.85,24.53,24.69,23.2,22.38,23.1,23.2,23.22,29.75,26.3, & + &30.94,35.46,26.88,19.26,30.71,15.05,46.63,16.99,.7, & + &36.16,0.,0.,0./ +!c ** + COSCHI=COSPASS + rnight=1.0 + if(coschi.lt.0.07)then + coschi=1.0 + rnight=1.e-6 + end if + do j=1,57 + SF(j)=1.e9*((SFH(j)-SFL(j))*F107_local/172.-0.413 & + & *SFH(j)+1.413*SFL(j)) + if(sf(j).lt.0.0)sf(j)=0.0 + enddo + do j=1,8 + SFUV(j)=A(j)*1.E9*(0.00086*F107_local+0.94) + enddo + do i=nps,np +!c ** + SECO=1./COSCHI + SECO2=SECO + SECN2=SECO + WO=O(i)*HO(i)*SECO*1.e-4 + WO2=O2(i)*HO2(i)*SECO2*1.e-4 + WN2=N2(i)*HN2(i)*SECN2*1.e-4 +!c ** +!c loop over all wavelengths bands +!c ** + sheat(i)=0.0 + sh1(i)=0. + sh2(i)=0. + do j=1,57 + TAUO=CSAO(j)*WO*1.e-18 + TAUO2=CSAO2(j)*WO2*1.e-18 + TAUN2=CSAN2(j)*WN2*1.e-18 + TAU=TAUO+TAUO2+TAUN2 + PAEUV(i,j)=SF(j)*EXP(-TAU)*(CSAO(j)*O(i)+ & + & CSAO2(j)*O2(i)+CSAN2(j)*N2(i))*PCC*rnight*1.e-8/RLAM(j) + sheat(i)=sheat(i)+paeuv(i,j)*effeuv(i) + sh1(i)=sh1(i)+paeuv(i,j)*effeuv(i) + enddo +!c ** +!c add SRC channels +!c ** + do j=58,65 + JJ=j-57 + TAU=UVXS(JJ)*WO2 + PAEUV(i,j)=SFUV(JJ)*EXP(-TAU)*UVXS(JJ)*O2(i)*PCC*rnight & + & /RLAM(j)*1.e10 + sheat(i)=sheat(i)+paeuv(i,j)*effuv(i) + sh2(i)=sh2(i)+paeuv(i,j)*effuv(i) + enddo + enddo + if(nps.ge.2) then + do i=1,nps-1 + sheat(i)=0. + sh1(i)=0. + sh2(i)=0. + enddo + endif + RETURN + END +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + SUBROUTINE COOLNO1(np,nps,T,O,NO,QNO) +!------------------------------------------------------------------------- +! calculate NO cooling from Tim Fuller-Rowell +!------------------------------------------------------------------------- +!c ** +!c input: +!c T temperature profile K +!c O atomic oxygen number density profile m-3 +!c NO nitric oxide number density profile m-3 +!c output: +!c QNO: NO cooling rate J/m-3 +!c ** + implicit none + integer, intent(in):: np !numer of pressure levels + integer, intent(in):: nps ! pressure index to start + real, intent(in) :: O(np),NO(np) !number density/m3 + real, intent(in) :: T(np) !temp (K) + real, intent(out) :: QNO(np) + real K10,HV,A10,BZ,A1,A2,A3,OM1,OM,G + integer i + K10=3.6E-17 + HV=3.726E-20 + A10=13.3 + G=1.0 + BZ=1.38E-23 + A2=5.4E-6*(1./(EXP(HV/BZ/5800.)-1.)) + A3=0.5*EXP(-HV/BZ/247.5) + do i=nps,np + OM1=K10*O(i) + OM=OM1/(OM1+A10) + A1=EXP(-HV/BZ/T(i)) + QNO(i)=HV*NO(i)*OM*A10*G*(A1-A2-A3) + enddo + if(nps.ge.2) then + do i=1,nps-1 + QNO(i)=0. + enddo + endif + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine gettimdata(pr,n2,no,o,o2,ho,ho2,hn2,t,ro) +!-------------------------------------------------------------------------- +! this subrutine is for test solar heating code using Tim's 17 pressure +! level data, interpolate to levs levels. All the argument are output except pr +!-------------------------------------------------------------------------` + implicit none + integer np,i,levs,k,kref,np1 + real r,amo,amn2,amo2,g,avgd,dz + PARAMETER(np=17,r=8.314472,amo=15.9994e-3,amn2=28.013e-3, & + &amo2=31.9999e-3,g=9.80665,avgd=6.0221415e23,np1=150) + REAL n217(np),no17(np),o17(np),o217(np),ho17(np),ho217(np), & + &hn217(np),p17(np),t17(np),ro17(np) + REAL n2(np1),no(np1),o(np1),o2(np1),ho(np1),ho2(np1),hn2(np1), & + &pr(np1),aa(6,np),ax(4,np),t(np1),ro(np1) + real z17(np),z(np1) + data aa/15.70, 20.54, 21.14, 220.00, 70.00, 28.80, & + & 15.26, 20.14, 20.74, 203.46, 76.69, 28.80, & + & 15.46, 19.72, 20.32, 198.00, 82.76, 28.81, & + & 17.30, 19.32, 19.92, 181.44, 88.55, 28.78, & + & 17.81, 18.90, 19.51, 169.96, 93.90, 28.59, & + & 17.75, 18.41, 19.05, 179.45, 99.22, 28.25, & + & 17.51, 17.85, 18.52, 216.21, 105.33, 27.75, & + & 17.09, 17.21, 17.92, 310.67, 113.57, 27.25, & + & 16.76, 16.25, 17.25, 500.30, 126.79, 25.56, & + & 16.34, 15.65, 16.60, 701.86, 147.91, 24.31, & + & 15.93, 14.77, 15.97, 936.50, 178.44, 22.62, & + & 15.53, 14.24, 15.32,1117.86, 219.99, 20.91, & + & 15.15, 13.47, 14.68,1208.59, 271.13, 19.19, & + & 14.77, 12.72, 13.99,1240.81, 329.35, 17.83, & + & 14.37, 11.92, 13.28,1250.56, 392.23, 16.96, & + & 13.95, 11.14, 12.56,1253.07, 457.87, 16.50, & + & 13.52, 10.35, 11.84,1253.07, 524.92, 16.25/ + data ax/ 3.28, 10.56, 13.40, 13.45, & + & 3.28, 10.56, 13.45, 13.45, & + & 4.33, 10.67, 13.55, 13.55, & + & 5.31, 10.73, 13.93, 13.93, & + & 6.81, 10.93, 14.05, 14.06, & + & 8.29, 11.36, 14.32, 14.32, & + & 9.12, 11.73, 14.16, 14.17, & + & 9.79, 12.17, 13.81, 13.82, & + &10.28, 12.53, 13.23, 13.31, & + &10.63, 12.64, 13.01, 13.17, & + &11.55, 13.20, 12.62, 13.30, & + &11.88, 13.28, 12.30, 13.34, & + &11.91, 13.16, 11.59, 13.19, & + &11.58, 12.78, 10.93, 12.82, & + &11.23, 12.43, 10.19, 12.46, & + &10.86, 12.06, 9.44, 12.09, & + &10.49, 11.69, 8.71, 11.72/ + levs=np1 +c + do k=1,np + p17(k)=5.2285*exp(1.-k) + o17(k)=10.**(aa(1,k)) !/m3 + o217(k)=10.**(aa(2,k)) !/m3 + n217(k)=10.**(aa(3,k)) !/m3 + t17(k)=aa(4,k) !K + ho17(k)=r*t17(k)/amo/g !m + ho217(k)=r*t17(k)/amo2/g !m + hn217(k)=r*t17(k)/amn2/g !m + ro17(k)=(o17(k)*amo+o217(k)*amo2+n217(k)*amn2)/avgd !kg/m3 +! for interp + o17(k)=aa(1,k) !/m3 + o217(k)=aa(2,k) !/m3 + n217(k)=aa(3,k) !/m3 + no17(k)=ax(3,k) !/m3 + enddo +! print*,t17 +! interp + do k=1,np + p17(k)=5.2285*exp(1.-k) + z17(k)=-1.*log(p17(k)) + enddo + do k=1,levs + z(k)=-1.*log(pr(k)*100.) + enddo + do k=1,levs + kref=0 + do i=1,16 + if(z(k).ge.z17(i).and.z(k).le.z17(i+1)) then + kref=i + dz=(z(k)-z17(i))/(z17(i+1)-z17(i)) + endif + enddo +! print*,k,kref,dz + if(kref.ne.0) then + no(k)=dz*no17(kref+1)+(1.-dz)*no17(kref) + o(k)=dz*o17(kref+1)+(1.-dz)*o17(kref) + n2(k)=dz*n217(kref+1)+(1.-dz)*n217(kref) + o2(k)=dz*o217(kref+1)+(1.-dz)*o217(kref) + ho(k)=dz*ho17(kref+1)+(1.-dz)*ho17(kref) + ho2(k)=dz*ho217(kref+1)+(1.-dz)*ho217(kref) + hn2(k)=dz*hn217(kref+1)+(1.-dz)*hn217(kref) + t(k)=dz*t17(kref+1)+(1.-dz)*t17(kref) + ro(k)=dz*ro17(kref+1)+(1.-dz)*ro17(kref) + elseif(z(k).lt.z17(1)) then + no(k)=no17(1) + o(k)=o17(1) + n2(k)=n217(1) + o2(k)=o217(1) + ho(k)=ho17(1) + ho2(k)=ho217(1) + hn2(k)=hn217(1) + ro(k)=ro17(1) + t(k)=t17(1) + elseif(z(k).gt.z17(17)) then + no(k)=no17(17) + o(k)=o17(17) + n2(k)=n217(17) + o2(k)=o217(17) + ho(k)=ho17(17) + ho2(k)=ho217(17) + hn2(k)=hn217(17) + ro(k)=ro17(17) + t(k)=t17(17) + endif + o(k)=10.**o(k) !/m3 + o2(k)=10.**o2(k) !/m3 + no(k)=10.**no(k) !/m3 + n2(k)=10.**n2(k) !/m3 + enddo + return + end +ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine gettimdata17(n217,no17,o17,o217,ho17,ho217,hn217, & + &t17,ro17) +!-------------------------------------------------------------------------- +! this subrutine is for test solar heating code using Tim's 17 pressure +! level data, All the argument are output +!-------------------------------------------------------------------------` + implicit none + integer np,i,levs,k + real r,amo,amn2,amo2,g,avgd + PARAMETER(np=17,r=8.314472,amo=15.9994e-3,amn2=28.013e-3, & + &amo2=31.9999e-3,g=9.80665,avgd=6.0221415e23) + REAL n217(np),no17(np),o17(np),o217(np),ho17(np),ho217(np), & + &hn217(np),p17(np),t17(np),ro17(np) + REAL aa(6,np),ax(4,np) + data aa/15.70, 20.54, 21.14, 220.00, 70.00, 28.80, & + & 15.26, 20.14, 20.74, 203.46, 76.69, 28.80, & + & 15.46, 19.72, 20.32, 198.00, 82.76, 28.81, & + & 17.30, 19.32, 19.92, 181.44, 88.55, 28.78, & + & 17.81, 18.90, 19.51, 169.96, 93.90, 28.59, & + & 17.75, 18.41, 19.05, 179.45, 99.22, 28.25, & + & 17.51, 17.85, 18.52, 216.21, 105.33, 27.75, & + & 17.09, 17.21, 17.92, 310.67, 113.57, 27.25, & + & 16.76, 16.25, 17.25, 500.30, 126.79, 25.56, & + & 16.34, 15.65, 16.60, 701.86, 147.91, 24.31, & + & 15.93, 14.77, 15.97, 936.50, 178.44, 22.62, & + & 15.53, 14.24, 15.32,1117.86, 219.99, 20.91, & + & 15.15, 13.47, 14.68,1208.59, 271.13, 19.19, & + & 14.77, 12.72, 13.99,1240.81, 329.35, 17.83, & + & 14.37, 11.92, 13.28,1250.56, 392.23, 16.96, & + & 13.95, 11.14, 12.56,1253.07, 457.87, 16.50, & + & 13.52, 10.35, 11.84,1253.07, 524.92, 16.25/ + data ax/ 3.28, 10.56, 13.40, 13.45, & + & 3.28, 10.56, 13.45, 13.45, & + & 4.33, 10.67, 13.55, 13.55, & + & 5.31, 10.73, 13.93, 13.93, & + & 6.81, 10.93, 14.05, 14.06, & + & 8.29, 11.36, 14.32, 14.32, & + & 9.12, 11.73, 14.16, 14.17, & + & 9.79, 12.17, 13.81, 13.82, & + &10.28, 12.53, 13.23, 13.31, & + &10.63, 12.64, 13.01, 13.17, & + &11.55, 13.20, 12.62, 13.30, & + &11.88, 13.28, 12.30, 13.34, & + &11.91, 13.16, 11.59, 13.19, & + &11.58, 12.78, 10.93, 12.82, & + &11.23, 12.43, 10.19, 12.46, & + &10.86, 12.06, 9.44, 12.09, & + &10.49, 11.69, 8.71, 11.72/ + levs=np +c + do k=1,np + o17(k)=10.**(aa(1,k)) !/m3 + o217(k)=10.**(aa(2,k)) !/m3 + n217(k)=10.**(aa(3,k)) !/m3 + no17(k)=10.**(ax(3,k)) !/m3 + t17(k)=aa(4,k) !K + ho17(k)=r*t17(k)/amo/g !m + ho217(k)=r*t17(k)/amo2/g !m + hn217(k)=r*t17(k)/amn2/g !m + ro17(k)=(o17(k)*amo+o217(k)*amo2+n217(k)*amn2)/avgd !kg/m3 +! for interp + enddo + return + end +cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + SUBROUTINE presolar(IM,IX,SOLHR,SLAG, & + & SINLAT,COSLAT,SDEC,CDEC,xlon,xlat & + & ,XMU,dayno,utsec,sda & + & ,maglat,maglon,btot,dipang,essa) +!------------------------------------------------------------------------ +! calculate solar zenith angle +!------------------------------------------------------------------------ + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, PI => con_PI + use date_def + implicit none +!Argument +! input + integer IM,IX + real(kind=kind_phys) sdec,slag,solhr,cdec + real(kind=kind_phys) SINLAT(ix),COSLAT(ix),XLON(ix),xlat(ix) +! output + real XMU(ix) !cos solar zenith angle +! Output Magnetic and electric parameters +! REAL, INTENT(OUT) :: elx(im) +! REAL, INTENT(OUT) :: ely(im) !electric field + REAL, INTENT(OUT) :: maglon(im) !magnetic longitude (rad) + REAL, INTENT(OUT) :: maglat(im) !magnetic latitude (rad) + REAL, INTENT(OUT) :: btot(im) !mapgnetic field strength + REAL, INTENT(OUT) :: dipang(im) !Dip angle (degree) + REAL, INTENT(OUT) :: essa(im) !magnetic local time + REAL, INTENT(OUT) :: sda ! solar declination angle (rad) +! Output time parameters + REAL, INTENT(OUT) :: utsec !universal time + INTEGER, INTENT(OUT) :: dayno !calendar day +! local vareable + INTEGER i,idat(8),jdat(8),jdow,jday + real(kind=kind_phys) cns,ss,cc,ch,rinc(5),ty +! COMPUTE COSINE OF SOLAR ZENITH ANGLE FOR BOTH HEMISPHERES. + CNS = PI*(SOLHR-12.)/12.+SLAG + DO I=1,IM + SS = SINLAT(I) * SDEC + CC = COSLAT(I) * CDEC + CH = CC * COS(XLON(I)+CNS) + XMU(I) = CH + SS + ENDDO +! get day number year number UTsec + idat=0 + idat(1)=idate(4) + idat(2)=idate(2) + idat(3)=idate(3) + idat(5)=idate(1) + rinc=0. + rinc(2)=fhour + call w3movdat(rinc,idat,jdat) + call w3doxdat(jdat,jdow,dayno,jday) +! print*,'www',dayno,fhour + utsec=solhr*3600. +! get solar declination angle + ty = (dayno+15.5)*12./365. + IF ( ty > 12.0 ) ty = ty - 12.0 + sda = ATAN(0.434*SIN(PI/6.0*(ty-3.17))) +! sda = asin(sdec) +! print*,'www8',sda,asin(sdec) +! get maglat maglon + call getmag(ix,im,utsec,xlat,xlon,sda, & + &btot,dipang,maglon,maglat,essa) + btot=btot*1.e-9 + RETURN + END + subroutine getno(im,ix,levs,mlat,doy,alt,pr,n,am,no) + use idea_composition + use wam_f107_kp_mod, only: f107, kp, kdt_3h + implicit none +!Argument + integer, intent(in) :: im !number of Mag latitude + integer, intent(in) :: ix !number of forst dimension + integer, intent(in) :: levs !number of pressure level + integer, intent(in) :: doy ! calenderday + real, intent(in) :: mlat(im) ! magnetic latitude in degree + real, intent(in) :: alt(ix,levs) !in km + real, intent(in) :: pr(levs) !in Pa + real, intent(in) :: am(ix,levs) !avg mass g/mol + real, intent(in) :: n(ix,levs) !/m3 number density + real, intent(out) :: no(ix,levs) ! number density of NO (/m3) +! local + real eof(33,16,3),nom(33,16),z16(16),dx(levs),kp_local,f107_local, & + &lat33(33),dz(levs),dl(im),m1,m2,m3,theta0,dec,zm(16) + integer iref(im),kref(levs),i,k,il,k1,k2 +c + data eof/-5247514.,-6069866.,-7046389.,-7712040.,-7475652., & + &-6521992.,-5779488.,-4680550.,-3503355.,-2386292.,-1809640., & + &-1232984.,-802252.5,-372340.8,-233625.,-247101.9,-152984.2, & + &-378208.4,-602054.8,-704482.2,-1130871.,-1553946.,-2005179., & + & -2550362.,-3406166.,-3918725.,-4902982.,-5478586.,-5895833., & + & -5706694.,-5069246.,-3955380.,-2953330., & + &-6038898.,-7092100.,-8222954.,-8946294.,-8772684.,-7650816., & + & -6768808.,-5482080.,-4198284.,-3027250.,-2116341.,-1498316., & + &-920285.5,-590980.9,-373686.9,-190410.6,-239284.8,-381577.1, & + &-654327.9,-843799.7,-1368418.,-1729119.,-2461879.,-3166525., & + &-4184515.,-4789708.,-5817856.,-6588944.,-7023782.,-6818994., & + &-5932706.,-4507758.,-3687829., & + &-6969458.,-8250042.,-9574323.,-1.051643e+07,-1.013241e+07, & + &-9114658.,-7905622.,-6488483.,-4945043.,-3636914.,-2527723., & + &-1808088.,-1109162.,-633211.2,-415173.8,-253677.3,-307635.4, & + &-407807.,-769923.1,-1152213.,-1609747.,-2170163.,-2871240., & + &-3794409.,-4839386.,-5881801.,-7136790.,-8115624.,-8560489., & + &-8109927.,-6876457.,-5306579.,-4396376., & + &-8046132.,-9649696.,-1.09464e+07,-1.204336e+07,-1.146817e+07, & + &-1.089248e+07,-9494700.,-7821164.,-6030920.,-4454593.,-3061204., & + &-2223948.,-1433917.,-740196.4,-599572.5,-432156.3,-419470.9, & + &-706885.4,-1032811.,-1439622.,-1897172.,-2741821.,-3532401., & + &-4442855.,-5662857.,-7226030.,-8847662.,-1.005568e+07, & + &-1.036662e+07,-9516017.,-8073862.,-5997690.,-5221294., & + &-9129519.,-1.115334e+07,-1.229467e+07,-1.377534e+07,-1.336406e+07,& + &-1.261571e+07,-1.127514e+07,-9378255.,-7344430.,-5450040., & + &-3878616.,-2748751.,-1786833.,-1141964.,-984780.8,-706063.4, & + &-649638.8,-1016723.,-1419590.,-1880392.,-2193050.,-3247191., & + &-4214684.,-5243782.,-6833144.,-8950396.,-1.102497e+07, & + &-1.23908e+07,-1.257e+07,-1.140126e+07,-9301236.,-7032514., & + &-5679984., & + &-1.056073e+07,-1.226184e+07,-1.409111e+07,-1.60509e+07, & + &-1.593818e+07,-1.478319e+07,-1.342692e+07,-1.138179e+07, & + &-9208966.,-6722660.,-5084906.,-3512189.,-2327560.,-1806689., & + &-1514532.,-1080780.,-1051349.,-1523702.,-1805517.,-2314509., & + &-2736008.,-3959913.,-4995312.,-6450705.,-8425629.,-1.123888e+07, & + &-1.374101e+07,-1.551322e+07,-1.528153e+07,-1.362144e+07, & + &-1.089468e+07,-8475252.,-5989985., & + &-1.151357e+07,-1.344059e+07,-1.628318e+07,-1.831117e+07, & + &-1.868885e+07,-1.793377e+07,-1.627429e+07,-1.407746e+07, & + &-1.163246e+07,-8556876.,-6473252.,-4540662.,-3254795.,-2627365., & + &-2067724.,-1621486.,-1696266.,-2003412.,-2413986.,-2967150., & + &-3663475.,-4878293.,-5978525.,-7894496.,-1.060695e+07, & + &-1.412827e+07,-1.709277e+07,-1.938935e+07,-1.894935e+07, & + &-1.645988e+07,-1.301559e+07,-1.007491e+07,-7017845., & + &-1.278202e+07,-1.546777e+07,-1.839902e+07,-2.126996e+07, & + &-2.224764e+07,-2.164401e+07,-1.993985e+07,-1.737438e+07, & + &-1.438734e+07,-1.110813e+07,-8382776.,-6098025.,-4643484., & + &-3396795.,-2781976.,-2367481.,-2464792.,-2681164.,-3189622., & + &-3833930.,-4773418.,-5781984.,-7389096.,-9414154.,-1.31758e+07, & + &-1.75727e+07,-2.155447e+07,-2.432159e+07,-2.384924e+07, & + &-2.059898e+07,-1.591331e+07,-1.187653e+07,-8291959., & + &-1.499052e+07,-1.808507e+07,-2.113212e+07,-2.543446e+07, & + &-2.703178e+07,-2.664454e+07,-2.451988e+07,-2.133364e+07, & + &-1.783693e+07,-1.410975e+07,-1.077553e+07,-8007652.,-6111540., & + &-4467203.,-3706028.,-3252944.,-3303344.,-3827547.,-4401341., & + &-5043524.,-5920190.,-7222662.,-9096529.,-1.179622e+07, & + &-1.603885e+07,-2.141876e+07,-2.670152e+07,-3.057304e+07, & + &-3.058411e+07,-2.663012e+07,-2.033983e+07,-1.459393e+07, & + &-1.001286e+07, & + &-1.831681e+07,-2.22191e+07,-2.55585e+07,-3.140621e+07, & + &-3.361916e+07,-3.326336e+07,-2.997734e+07,-2.614696e+07, & + &-2.194762e+07,-1.702339e+07,-1.318224e+07,-9849552.,-7534498., & + &-6071376.,-4926836.,-4352171.,-4336826.,-4878423.,-5463988., & + &-6115170.,-7130386.,-8790494.,-1.102214e+07,-1.490303e+07, & + &-1.958257e+07,-2.590418e+07,-3.235639e+07,-3.777672e+07, & + &-3.93543e+07,-3.492081e+07,-2.707286e+07,-1.944128e+07, & + &-1.316116e+07, & + &-2.377451e+07,-2.792029e+07,-3.290989e+07,-4.000966e+07, & + &-4.212796e+07,-4.055546e+07,-3.617584e+07,-3.089867e+07, & + &-2.566711e+07,-1.954078e+07,-1.52248e+07,-1.143733e+07, & + &-8857369.,-7301910.,-6248646.,-5475254.,-5320822.,-5696930., & + &-6025682.,-6856452.,-8183936.,-1.02042e+07,-1.324781e+07, & + &-1.754751e+07,-2.334451e+07,-3.096561e+07,-3.909159e+07, & + &-4.662714e+07,-5.03075e+07,-4.601564e+07,-3.606484e+07, & + &-2.686934e+07,-1.765236e+07, & + &-3.055708e+07,-3.602473e+07,-4.312628e+07,-5.083733e+07, & + &-5.134407e+07,-4.783135e+07,-4.119072e+07,-3.408647e+07, & + &-2.759005e+07,-2.074799e+07,-1.588136e+07,-1.217633e+07, & + &-9702639.,-7796016.,-6927890.,-6371548.,-6159546.,-6192992., & + &-6571300.,-7418758.,-8830681.,-1.126385e+07,-1.447512e+07, & + &-1.933939e+07,-2.584862e+07,-3.476215e+07,-4.531472e+07, & + &-5.626805e+07,-6.28497e+07,-5.956211e+07,-4.689528e+07, & + &-3.554812e+07,-2.294755e+07, & + &-3.615576e+07,-4.475599e+07,-5.378362e+07,-6.034626e+07, & + &-5.831976e+07,-5.200245e+07,-4.278119e+07,-3.373483e+07, & + &-2.638541e+07,-1.963828e+07,-1.494567e+07,-1.179412e+07, & + &-9506393.,-7834650.,-7171875.,-6708864.,-6231308,-6242322., & + &-6637734.,-7218400.,-8757761.,-1.104336e+07,-1.398759e+07, & + &-1.897072e+07,-2.570359e+07,-3.506066e+07,-4.73507e+07, & + &-6.203831e+07,-7.339174e+07,-7.23998e+07,-5.747045e+07, & + &-4.238988e+07,-2.744211e+07, & + &-3.871022e+07,-4.920625e+07,-5.955764e+07,-6.360899e+07, & + &-5.876267e+07,-4.942194e+07,-3.87213e+07,-2.908438e+07, & + &-2.138209e+07,-1.59806e+07,-1.242386e+07,-1.012207e+07, & + &-8467976,-7318800,-6853774,-6213230,-5668098.,-5685148., & + &-5958562.,-6409051.,-7596764.,-9116276.,-1.175655e+07, & + &-1.581505e+07,-2.220477e+07,-3.103819e+07,-4.345313e+07, & + &-5.977948e+07,-7.641549e+07,-7.934251e+07,-6.347728e+07, & + &-4.462917e+07,-2.834482e+07, & + &-3.57445e+07,-4.646349e+07,-5.553925e+07,-5.707475e+07, & + &-5.03307e+07,-3.960313e+07,-2.911814e+07,-2.095385e+07, & + &-1.41673e+07,-1.090228e+07,-8578298.,-7370734.,-6619473., & + &-6290864.,-5831174.,-5703259.,-5150547.,-4824520.,-4816210., & + &-5154248.,-5639925.,-6234228.,-7960974.,-1.115471e+07, & + &-1.671155e+07,-2.400684e+07,-3.496165e+07,-5.034799e+07, & + &-6.865742e+07,-7.517185e+07,-6.079964e+07,-4.097551e+07, & + &-2.525763e+07, & + &-2.709748e+07,-3.74319e+07,-4.330479e+07,-4.227697e+07, & + &-3.572979e+07,-2.630141e+07,-1.828288e+07,-1.227928e+07, & + &-8122793.,-6214670.,-4957134.,-4658456.,-4642014.,-4874148., & + &-4937673.,-4905970.,-4485041.,-3991234.,-3730586.,-3562796., & + &-3596555.,-3772070.,-4680470.,-6938800.,-1.118435e+07, & + &-1.607187e+07,-2.44831e+07,-3.691874e+07,-5.237388e+07, & + &-5.850094e+07,-4.780516e+07,-3.156013e+07,-1.88358e+07, & +! &-5.850094e+07,-4.780516e+07,-3.156013e+07,-1.88358e+07/ +! data eof2/-3550722.,-4999868.,-6029446.,-6607816.,-6798872., & + &-3550722.,-4999868.,-6029446.,-6607816.,-6798872., & + &-6556119., & + &-5851844.,-5105981.,-4227900.,-3332964.,-2709887.,-2012516., & + &-1347839.,-858926.1,-398978.9,285539.2,1116062.,2062128., & + &2772248.,3378420.,3903072.,4770542.,5352842.,5933570.,6471496., & + &6704952.,6349468.,5615903.,4622920.,3660178.,2579021.,1603797., & + &1167462., & + &-4453830.,-5830580.,-6664141.,-7325691.,-7336244.,-7197354., & + &-6489768.,-5646758.,-4684139.,-3745124.,-3111786.,-2403234., & + &-1450249.,-921302.1,-353973.4,463077.1,1367812.,2282826., & + &3134991.,3858350.,4516656.,5441888.,6147992.,6914916.,7288510., & + &7147760.,6462147.,5621066.,4603148.,3210620.,2387941.,1321321., & + &1046460., & + &-4708342.,-6382134.,-6983833.,-7804986.,-7873086.,-7695303., & + &-6937803.,-5955056.,-5131108.,-4221447.,-3475260.,-2447103., & + &-1724581.,-1091036.,-347057.8,504642.2,1608005.,2635887.,3526253.,& + &4465333.,5261456.,6084238.,6908202.,7746244.,7951130.,7597998., & + &6592439.,5277250.,3843090,2512705.,1588969.,703104.9,927493.4, & + &-4685088.,-6567670.,-6971900.,-7850017.,-8074569.,-7805665., & + &-7095178.,-6286066.,-5510380.,-4574820.,-3782092.,-2760814., & + &-2044360.,-1090093.,-265385.7,609069.1,1723909.,3128296.,4069255.,& + &5084559.,5997733.,6820324.,7716854.,8281178.,8245150.,7663310., & + &6265819.,4249998.,2349481.,982298.2,-20058.97,-64966.82,613551.1, & + &-4697492.,-6440296.,-6497082.,-7212652.,-7385836.,-7325560., & + &-6856076.,-6334871.,-5608214.,-4778506.,-3950506.,-3102535., & + &-2286452.,-1233180.,-315501.1,604756.6,2000721.,3537246.,4564460.,& + &5642454.,6562336.,7604769.,8382037.,8633313.,8450591.,7239076., & + &5160092.,2471956.,320319.,-1445840.,-1933416.,-1197185.,307289.1, & + &-4498376.,-6264558.,-5793368.,-5828142.,-6042533.,-6500122., & + &-6153824.,-5854354.,-5337567.,-4908172.,-4187290.,-3227545., & + &-2388492.,-1485795.,-493459.5,705965.1,2318738.,3912988.,5223462.,& + &6211511.,7344585.,8498396.,8951045.,9033699.,8503844.,6452912., & + &3220496.,-136648.8,-2728090.,-4737084.,-4446586.,-2933130., & + &-105684., & + &-3582402.,-4924574.,-4255880.,-3520741.,-3968931.,-4755766., & + &-4953638.,-5166255.,-4887805.,-4717018.,-4223476.,-3530105., & + &-2519241.,-1623204.,-545867.8,784475.6,2406287.,4298338., & + &5810763.,6884838.,8025496.,9266424.,9595524.,9538755.,8247420., & + &5519249.,1025285.,-3582593.,-6813954.,-8874215.,-8354157., & + &-5715388.,-1160188., & + &-1826248.,-2728064.,-1482540.,-303616.3,-1170324.,-2487811., & + &-3301422.,-3970471.,-4256004.,-4484016.,-4290775.,-3965588., & + &-2838772.,-1742834.,-613410.1,730439.4,2616912.,4670268., & + &6436481.,7715498.,8908482.,1.024675e+07,1.045545e+07,1.004943e+07,& + &8060278.,4473366.,-1478069.,-7895714.,-1.209433e+07,-1.416813e+07,& + &-1.349315e+07,-9079429.,-3614306., & + &1495344.,365904.4,2686130.,3628202.,2206317.,249844.3, & + &-1440797.,-2490130.,-3533194.,-4495477.,-4718896.,-4409241., & + &-3443172.,-2150731.,-788457.2,648578.7,2877919.,5436550., & + &7079374.,8784376.,1.023441e+07,1.134754e+07,1.18273e+07, & + &1.095829e+07,8295394.,3432043.,-4429692.,-1.294127e+07, & + &-1.86596e+07,-2.172068e+07,-2.092779e+07,-1.469124e+07,-6513079., & + &7566286.,5669165.,8313054.,8916941.,6676137.,3327969., & + &612284.9,-1089442.,-2940050.,-4542409.,-5137538.,-4963334., & + &-4124808.,-2813968.,-1249376.,638691.3,3150280.,6079466., & + &7932640.,9931984.,1.182114e+07,1.291923e+07,1.362208e+07, & + &1.227164e+07,8982291.,2310723.,-7345317.,-1.824287e+07, & + &-2.636511e+07,-3.161505e+07,-3.145881e+07,-2.33066e+07, & + &-1.10414e+07, & + &1.713696e+07,1.426501e+07,1.602415e+07,1.560995e+07, & + &1.169762e+07,6779151.,3042913.,-112688.,-2928124.,-4686552., & + &-5598730.,-5347326.,-4528528.,-2927713.,-1207992.,994963.9, & + &3811544.,6820194.,9034366.,1.112203e+07,1.347644e+07,1.523938e+07,& + &1.56908e+07,1.403863e+07,9744265.,1380405.,-1.045777e+07, & + &-2.363129e+07,-3.421596e+07,-4.232818e+07,-4.397456e+07, & + &-3.379269e+07,-1.831733e+07, & + &2.941875e+07,2.569069e+07,2.592953e+07,2.348308e+07,1.784609e+07, & + &1.168591e+07,5910614.,620696.9,-2942742.,-5104643.,-5987772., & + &-5068594.,-3756314.,-1676618.,407250.2,2591781.,5491882., & + &8457570.,1.06792e+07,1.300713e+07,1.556461e+07,1.807675e+07, & + &1.845039e+07,1.651338e+07,1.106265e+07,1363794.,-1.236063e+07, & + &-2.667743e+07,-3.860363e+07,-4.945452e+07,-5.444406e+07, & + &-4.473249e+07,-2.528791e+07, & + &4.398493e+07,3.902301e+07,3.703364e+07,3.291616e+07,2.66609e+07, & + &1.881227e+07,9952347.,2832138.,-2061332.,-5120051.,-5810617., & + &-4621194.,-2539200.,5480.091,2613887.,5206930.,8533702., & + &1.140208e+07,1.353265e+07,1.578132e+07,1.84296e+07,2.065287e+07, & + &2.100688e+07,1.874341e+07,1.244249e+07,2941914,-1.051553e+07, & + &-2.417196e+07,-3.537312e+07,-4.797264e+07,-5.571877e+07, & + &-5.059598e+07,-2.957026e+07, & + &5.950389e+07,5.268292e+07,4.882452e+07,4.391716e+07,3.700496e+07, & + &2.783868e+07,1.657407e+07,7688949.,880993.7,-3441981.,-4827442., & + &-4436195.,-2571542.,277526.4,3510918.,7135644.,1.140301e+07, & + &1.422313e+07,1.589656e+07,1.787341e+07,1.924645e+07,2.017422e+07, & + &2.002363e+07,1.747199e+07,1.169677e+07,3826066.,-7398834., & + &-1.855361e+07,-2.815611e+07,-3.89391e+07,-4.88555e+07, & + &-4.920498e+07,-3.014652e+07, & + &7.190888e+07,6.576423e+07,5.922896e+07,5.277818e+07, & + &4.534657e+07,3.586671e+07,2.449271e+07,1.405145e+07,5944550., & + &669667.2,-1976898.,-2822942.,-2409899.,-392324.2,2919008., & + &7121085.,1.155499e+07,1.403946e+07,1.523995e+07,1.64521e+07, & + &1.653957e+07,1.6117e+07,1.489731e+07,1.217794e+07,7301966., & + &934352.8,-8035936.,-1.695871e+07,-2.455439e+07,-3.288879e+07, & + &-4.343476e+07,-4.602783e+07,-2.791496e+07, & + &7.31755e+07,6.847934e+07,6.042688e+07,5.195875e+07,4.625756e+07, & + &3.804738e+07,2.859586e+07,1.759356e+07,9442344.,4235804.,1198366.,& + &-370487.3,-1000932.,-791819.4,1073756.,4216116.,7964550., & + &1.050299e+07,1.137061e+07,1.227149e+07,1.237492e+07,1.154301e+07, & + &9690036.,6569700.,1841862.,-4916258.,-1.337377e+07,-2.205146e+07, & + &-2.780837e+07,-3.468295e+07,-4.391114e+07,-4.427488e+07, & +! &-2.567899e+07/ + &-2.567899e+07, & +! data eof3/314622.4,446157.7,148496.8,-499168.8,-984649.5, & + &314622.4,446157.7,148496.8,-499168.8,-984649.5, & + &-1573071., & + &-2062517.,-2301275.,-2360370.,-2388202.,-2384845.,-2463211., & + &-2464774.,-2289638.,-2075672.,-2070251.,-2006550.,-1703989., & + &-1755430.,-1612282.,-1459101.,-1434679.,-1182009.,-758098.2, & + &-591213.4,9495.456,492213.9,858164.4,1426467.,1966256.,2271615., & + &1465998.,1343640., & + &830839.1,777802.1,486524.3,-189759.3,-911942.7,-1625400., & + &-2354770.,-2611929.,-2809774.,-2826629.,-2819800.,-2847167., & + &-2729571.,-2553134.,-2478144.,-2303860.,-2302584.,-2031971., & + &-2039559.,-1879516.,-1694394.,-1562735.,-1364759.,-872511.6, & + &-656795.5,33083.57,557997.2,1113055.,1628759.,2457284.,2648616., & + &1674851.,1625487., & + &1409924.,1019259.,883528.6,232237.5,-726269.4,-1708267.,-2430381.,& + &-2978283.,-3171439.,-3163603.,-3234439.,-3252424.,-3001476., & + &-2865035.,-2928616.,-2601377.,-2539364.,-2472430.,-2427976., & + &-2146706.,-2112735.,-1784020.,-1652875.,-1233708.,-507537., & + &110354.9,750772.4,1623374.,2083827.,3006348.,3095268.,1818044., & + &1877051., & + &1554329.,1321874.,1500238.,817836.6,-143493.1,-1426526.,-2522952.,& + &-3295829.,-3467110.,-3623347.,-3678847.,-3697243.,-3496563., & + &-3338830.,-3344515.,-3088807.,-2954478.,-2810228.,-2761952., & + &-2629170.,-2548421.,-2191438.,-2080080.,-1366911.,-560841.6, & + &84850.73,1128723.,2202335.,2901654.,3544543.,3390544.,2107183., & + &2068180., & + &2104222.,1963978.,2377411.,1629444.,680337.6,-978751.7,-2429675, & + &-3598742.,-4087000.,-4188937.,-4276332.,-4169694.,-4061433., & + &-3901978.,-3836869.,-3532741.,-3523958.,-3291452.,-3176570., & + &-3165892.,-2979024.,-2630462.,-2306031.,-1650492.,-735568.4, & + &203098.6,1561690.,2727543.,3631779.,4043107.,3605264.,2252031., & + &2239855., & + &3237609.,2645918.,3307854.,3065398.,1997126.,-117285.6,-2216635., & + &-3839580.,-4672208.,-4908996.,-4916144.,-4835156.,-4755798., & + &-4547915.,-4524278.,-4193978.,-4171761.,-3956728.,-3786645., & + &-3742429.,-3451387.,-3167889.,-2732456.,-2144256.,-843505.1, & + &200478.3,1661352.,3333076.,4285979.,4586444.,4023968.,2263111., & + &2269976., & + &4136324.,3685260.,4534184.,5182235.,3862269.,917375.2,-1806512., & + &-4026184.,-5332140.,-5646671.,-5825562.,-5684395.,-5717667., & + &-5540103.,-5296860.,-5168160.,-4956880.,-4770304.,-4736606., & + &-4496550.,-4157802.,-3914586.,-3454898.,-2611904.,-1165725., & + &244.4664,1982738.,4039884.,5297042.,5591376.,4278206.,2220066., & + &2366916., & + &4996856.,5349637.,6983288.,7890998.,6178988.,2371306.,-1390749., & + &-4386270.,-6130552.,-6473580.,-7121288.,-6808043.,-6868183., & + &-6781514.,-6398884.,-6347426.,-6171113.,-6093226.,-6071333., & + &-5642187.,-5228752.,-4949383.,-4255686.,-3223986.,-1720856., & + &-159110.9,2444674.,4918448.,6666186.,6823784.,4425610.,2192190., & + &2701361., & + &6690670.,7588610.,1.049304e+07,1.170568e+07,9152625.,3904538., & + &-955672.4,-4989505.,-7254350.,-8016101.,-8635893.,-8580988., & + &-8466865.,-8466263.,-8250060.,-8159519.,-7985556.,-7881800., & + &-7653272.,-7354888.,-6916090.,-6360451.,-5320331.,-4118812., & + &-2363889.,-459975.6,2553537.,5872735.,8262008.,8103138.,4863052., & + &1876987.,2857482., & + &9939955.,1.14642e+07,1.534415e+07,1.698387e+07,1.276268e+07, & + &5420422.,-915903.6,-6198363.,-9079450.,-1.020251e+07, & + &-1.094061e+07,-1.098656e+07,-1.101355e+07,-1.081624e+07, & + &-1.067883e+07,-1.059778e+07,-1.03633e+07,-1.013347e+07,-9833245., & + &-9736407.,-9079433.,-8300264.,-6936270.,-5537809.,-3477706., & + &-1152812.,2425573.,6665913.,1.035781e+07,1.019174e+07,5766342., & + &1730073.,3162636., & + &1.494946e+07,1.726946e+07,2.214678e+07,2.367381e+07,1.70876e+07, & + &7260400.,-1434200.,-7895262.,-1.145331e+07,-1.284597e+07, & + &-1.378986e+07,-1.398675e+07,-1.400286e+07,-1.380998e+07, & + &-1.336018e+07,-1.336776e+07,-1.322488e+07,-1.305702e+07, & + &-1.266709e+07,-1.265451e+07,-1.195389e+07,-1.086899e+07, & + &-9396855.,-7644320.,-5433612.,-2396577.,1558667.,6935419., & + &1.2749e+07,1.354243e+07,7440482.,1822069.,3576621., & + &2.213311e+07,2.505027e+07,3.084354e+07,3.112081e+07,2.165618e+07, & + &8888783.,-1594052.,-9273081.,-1.372354e+07,-1.545695e+07, & + &-1.661899e+07,-1.687489e+07,-1.677181e+07,-1.651928e+07, & + &-1.614854e+07,-1.583899e+07,-1.5904e+07,-1.570557e+07, & + &-1.544649e+07,-1.547859e+07,-1.492712e+07,-1.376983e+07, & + &-1.211128e+07,-1.030239e+07,-8309643.,-5251016.,-1408855., & + &4889775.,1.325489e+07,1.743002e+07,9871301.,1404936.,3010461., & + &3.027075e+07,3.35656e+07,3.887665e+07,3.756202e+07,2.462149e+07, & + &9886700.,-1876612.,-9858467.,-1.469433e+07,-1.654207e+07, & + &-1.800527e+07,-1.831783e+07,-1.817502e+07,-1.781354e+07, & + &-1.759599e+07,-1.740031e+07,-1.711981e+07,-1.687534e+07, & + &-1.706992e+07,-1.695779e+07,-1.666422e+07,-1.582873e+07, & + &-1.475557e+07,-1.375978e+07,-1.245482e+07,-1.044283e+07, & + &-7293340.,-1420241.,9347988.,1.824247e+07,1.148862e+07,67750.86, & + &624175.9, & + &3.515765e+07,3.98675e+07,4.256014e+07,3.825883e+07,2.298996e+07, & + &9057747.,-2523603.,-9560562.,-1.344351e+07,-1.526331e+07, & + &-1.650179e+07,-1.683278e+07,-1.69626e+07,-1.685137e+07, & + &-1.652839e+07,-1.68815e+07,-1.646901e+07,-1.609741e+07, & + &-1.619644e+07,-1.593374e+07,-1.599815e+07,-1.601084e+07, & + &-1.608505e+07,-1.625913e+07,-1.58795e+07,-1.518091e+07, & + &-1.350664e+07,-9224277.,920863.5,1.245405e+07,8706156.,-3269526., & + &-3591942., & + &3.495094e+07,3.954528e+07,3.865825e+07,3.040881e+07,1.634854e+07, & + &6431264.,-2748187.,-8106492.,-1.082093e+07,-1.198362e+07, & + &-1.264837e+07,-1.284358e+07,-1.312204e+07,-1.345812e+07, & + &-1.349921e+07,-1.393504e+07,-1.418651e+07,-1.372457e+07, & + &-1.307195e+07,-1.282841e+07,-1.285081e+07,-1.331461e+07, & + &-1.406216e+07,-1.486777e+07,-1.549234e+07,-1.569016e+07, & + &-1.603876e+07,-1.411711e+07,-7560620.,2211198.,1879234., & + &-6793946.,-6259334., & + &2.680579e+07,2.889269e+07,2.573243e+07,1.673862e+07,8003554., & + &3180288.,-2928452.,-6162048.,-7837038.,-8195929.,-8039965., & + &-8158206.,-8137698.,-8740260.,-9274056.,-9451374.,-9828972., & + &-9618083.,-8969771.,-8284313.,-8544111.,-8548799.,-9328801., & + &-1.038032e+07,-1.160811e+07,-1.27403e+07,-1.426203e+07, & + &-1.46988e+07,-1.130563e+07,-5754158.,-4201252.,-6628762., & + &-4627180./ + data nom/2.163787e+07,2.264605e+07,2.274347e+07,2.173493e+07, & + &2.039849e+07,1.880722e+07,1.76798e+07,1.680914e+07,1.630783e+07, & + &1.610751e+07,1.623668e+07,1.647026e+07,1.677793e+07,1.710239e+07, & + &1.732502e+07,1.741656e+07,1.718139e+07,1.704608e+07,1.717123e+07, & + &1.701905e+07,1.683441e+07,1.701138e+07,1.713214e+07,1.755397e+07, & + &1.83162e+07,1.941603e+07,2.079224e+07,2.216768e+07,2.381818e+07, & + &2.465965e+07,2.488819e+07,2.360805e+07,2.185616e+07, & + &2.395929e+07,2.571351e+07,2.600882e+07,2.482161e+07,2.319194e+07, & + &2.13226e+07,1.985675e+07,1.892028e+07,1.825046e+07,1.803146e+07, & + &1.813286e+07,1.844819e+07,1.870602e+07,1.903964e+07,1.9304e+07, & + &1.940898e+07,1.915396e+07,1.899582e+07,1.921486e+07,1.895607e+07, & + &1.882105e+07,1.887761e+07,1.906222e+07,1.955113e+07,2.049175e+07, & + &2.176387e+07,2.329378e+07,2.51547e+07,2.720574e+07,2.827226e+07, & + &2.831094e+07,2.653534e+07,2.478283e+07, & + &2.70667e+07,2.944748e+07,2.974632e+07,2.840199e+07,2.645661e+07, & + &2.412907e+07,2.234219e+07,2.118365e+07,2.04225e+07,2.019091e+07, & + &2.016388e+07,2.044097e+07,2.073596e+07,2.116464e+07,2.146072e+07, & + &2.131395e+07,2.125275e+07,2.105004e+07,2.118592e+07,2.096015e+07, & + &2.085018e+07,2.078729e+07,2.104133e+07,2.164236e+07,2.277652e+07, & + &2.426221e+07,2.627279e+07,2.884485e+07,3.105395e+07,3.267815e+07, & + &3.229646e+07,3.001993e+07,2.756194e+07, & + &3.071515e+07,3.357783e+07,3.420302e+07,3.281923e+07,3.017425e+07, & + &2.748872e+07,2.544925e+07,2.393332e+07,2.290231e+07,2.257314e+07, & + &2.24508e+07,2.255884e+07,2.299098e+07,2.326585e+07,2.346156e+07, & + &2.334174e+07,2.319696e+07,2.304891e+07,2.309934e+07,2.302795e+07, & + &2.275552e+07,2.279855e+07,2.324276e+07,2.396374e+07,2.516545e+07, & + &2.717029e+07,2.98037e+07,3.308022e+07,3.561846e+07,3.756591e+07, & + &3.721541e+07,3.389425e+07,3.092844e+07, & + &3.484532e+07,3.880602e+07,3.974362e+07,3.804968e+07,3.466702e+07, & + &3.150972e+07,2.890467e+07,2.709869e+07,2.573434e+07,2.495072e+07, & + &2.486717e+07,2.488102e+07,2.524911e+07,2.515065e+07,2.533103e+07, & + &2.529204e+07,2.526981e+07,2.505555e+07,2.514982e+07,2.513823e+07, & + &2.496043e+07,2.492324e+07,2.544142e+07,2.635059e+07,2.779676e+07, & + &3.04932e+07,3.392106e+07,3.802177e+07,4.127946e+07,4.353376e+07, & + &4.277174e+07,3.819595e+07,3.469122e+07, & + &3.96806e+07,4.456492e+07,4.632832e+07,4.457974e+07,4.065932e+07, & + &3.67155e+07,3.313204e+07,3.082811e+07,2.911806e+07,2.795613e+07, & + &2.759524e+07,2.733264e+07,2.729889e+07,2.72596e+07,2.74638e+07, & + &2.742819e+07,2.745385e+07,2.725184e+07,2.744125e+07,2.741077e+07, & + &2.738589e+07,2.745291e+07,2.785498e+07,2.906646e+07,3.110815e+07, & + &3.458355e+07,3.903459e+07,4.436781e+07,4.844528e+07,5.112772e+07, & + &4.960073e+07,4.337774e+07,3.865246e+07, & + &4.568726e+07,5.171574e+07,5.464674e+07,5.303889e+07,4.848093e+07, & + &4.334518e+07,3.890633e+07,3.579912e+07,3.340917e+07,3.168858e+07, & + &3.08861e+07,3.033714e+07,2.988109e+07,3.002307e+07,2.990195e+07, & + &3.007158e+07,3.006888e+07,2.993791e+07,3.024532e+07,3.025844e+07, & + &3.058776e+07,3.0703e+07,3.130527e+07,3.281924e+07,3.550659e+07, & + &4.004791e+07,4.594895e+07,5.26851e+07,5.820912e+07,6.093561e+07, & + &5.846027e+07,4.96592e+07,4.359543e+07, & + &5.368096e+07,6.131866e+07,6.568315e+07,6.438405e+07,5.892377e+07, & + &5.224846e+07,4.684366e+07,4.252441e+07,3.934412e+07,3.695518e+07, & + &3.555099e+07,3.457401e+07,3.401536e+07,3.395793e+07,3.362273e+07, & + &3.398065e+07,3.42364e+07,3.428816e+07,3.480887e+07,3.491505e+07, & + &3.544976e+07,3.586662e+07,3.66769e+07,3.847001e+07,4.197232e+07, & + &4.78369e+07,5.546106e+07,6.415266e+07,7.134121e+07,7.420132e+07, & + &6.979627e+07,5.72952e+07,4.993969e+07, & + &6.53104e+07,7.453446e+07,8.100446e+07,8.015896e+07,7.345339e+07, & + &6.493999e+07,5.79416e+07,5.203926e+07,4.782874e+07,4.491525e+07, & + &4.273095e+07,4.12204e+07,4.053718e+07,4.013189e+07,4.007326e+07, & + &4.043734e+07,4.095824e+07,4.181807e+07,4.258386e+07,4.302553e+07, & + &4.362337e+07,4.456518e+07,4.56506e+07,4.7806e+07,5.219165e+07, & + &5.91082e+07,6.871569e+07,8.002242e+07,8.94702e+07,9.290822e+07, & + &8.539098e+07,6.837956e+07,5.788086e+07, & + &8.241265e+07,9.371211e+07,1.024948e+08,1.019437e+08,9.335783e+07, & + &8.249221e+07,7.330364e+07,6.608382e+07,6.057803e+07,5.651128e+07, & + &5.38513e+07,5.189693e+07,5.087567e+07,5.0381e+07,5.051617e+07, & + &5.102923e+07,5.193482e+07,5.372715e+07,5.464499e+07,5.584988e+07, & + &5.694717e+07,5.818657e+07,5.960329e+07,6.233852e+07,6.760946e+07, & + &7.555777e+07,8.737924e+07,1.018224e+08,1.144415e+08,1.187061e+08, & + &1.07561e+08,8.470163e+07,6.950075e+07, & + &1.068594e+08,1.20901e+08,1.319313e+08,1.308652e+08,1.192304e+08, & + &1.053605e+08,9.363336e+07,8.427575e+07,7.728734e+07,7.227872e+07, & + &6.918546e+07,6.704826e+07,6.561225e+07,6.514464e+07,6.50228e+07, & + &6.602658e+07,6.737998e+07,6.989546e+07,7.13997e+07,7.293089e+07, & + &7.467998e+07,7.630994e+07,7.836858e+07,8.191821e+07,8.817689e+07, & + &9.77793e+07,1.120285e+08,1.303363e+08,1.467539e+08,1.524302e+08, & + &1.366695e+08,1.058218e+08,8.650502e+07, & + &1.367971e+08,1.535834e+08,1.670364e+08,1.643997e+08,1.483795e+08, & + &1.306866e+08,1.153159e+08,1.033887e+08,9.493343e+07,8.927709e+07, & + &8.57227e+07,8.329807e+07,8.154209e+07,8.05483e+07,8.017469e+07, & + &8.092742e+07,8.283765e+07,8.59034e+07,8.830183e+07,9.039071e+07, & + &9.290147e+07,9.540966e+07,9.833059e+07,1.02818e+08,1.101918e+08, & + &1.214563e+08,1.385164e+08,1.60778e+08,1.81532e+08,1.90058e+08, & + &1.691848e+08,1.305031e+08,1.053786e+08, & + &1.640431e+08,1.828668e+08,1.972162e+08,1.925819e+08,1.720869e+08, & + &1.499314e+08,1.308151e+08,1.164679e+08,1.066657e+08,1.000556e+08, & + &9.604018e+07,9.317108e+07,9.095914e+07,8.960517e+07,8.908926e+07, & + &8.926566e+07,9.118091e+07,9.473096e+07,9.755328e+07,1.004717e+08, & + &1.037069e+08,1.070067e+08,1.107363e+08,1.15808e+08,1.241896e+08, & + &1.363584e+08,1.552138e+08,1.79958e+08,2.055298e+08,2.189036e+08, & + &1.94399e+08,1.508483e+08,1.208035e+08, & + &1.761562e+08,1.940855e+08,2.072946e+08,2.008541e+08,1.766197e+08, & + &1.519577e+08,1.31129e+08,1.147103e+08,1.033798e+08,9.583854e+07, & + &9.139016e+07,8.865574e+07,8.694153e+07,8.67141e+07,8.721718e+07, & + &8.802787e+07,8.907978e+07,9.154098e+07,9.354178e+07,9.541453e+07, & + &9.77203e+07,1.006788e+08,1.050258e+08, 1.109418e+08,1.199948e+08, & + &1.328088e+08,1.511808e+08,1.762166e+08,2.050085e+08,2.235726e+08, & + &2.006752e+08,1.5661e+08,1.249316e+08, & + &1.657279e+08,1.800129e+08,1.883615e+08,1.793923e+08,1.55644e+08, & + &1.324502e+08,1.128458e+08,9.618882e+07,8.407297e+07,7.604598e+07, & + &7.161786e+07,6.979342e+07,7.032928e+07,7.246097e+07,7.520003e+07, & + &7.675004e+07,7.677053e+07,7.644136e+07,7.633523e+07,7.566713e+07, & + &7.557913e+07,7.72312e+07,8.146875e+07,8.81042e+07,9.775342e+07, & + &1.103463e+08,1.275029e+08,1.508316e+08,1.778392e+08,1.985617e+08, & + &1.808708e+08,1.411881e+08,1.101232e+08, & + &1.414566e+08,1.496452e+08,1.503433e+08,1.387637e+08,1.192389e+08, & + &1.002085e+08,8.43259e+07,6.953819e+07,5.813887e+07,5.053431e+07, & + &4.624784e+07,4.569546e+07,4.75228e+07,5.108193e+07,5.464553e+07, & + &5.582265e+07,5.497499e+07,5.299077e+07,5.203736e+07,4.993874e+07, & + &4.893956e+07,4.963887e+07,5.297103e+07,5.864174e+07,6.762337e+07, & + &7.840697e+07,9.357496e+07,1.128747e+08,1.333854e+08,1.49082e+08, & + &1.359941e+08,1.054389e+08,7.915589e+07/ + data lat33/-80.,-75.,-70.,-65.,-60.,-55.,-50.,-45.,-40.,-35., & + &-30.,-25.,-20.,-15.,-10.,-5.,0.,5.,10.,15.,20.,25.,30.,35.,40., & + &45.,50.,55.,60.,65.,70.,75.,80./ + data z16/150.0003,146.667,143.3337,140.0003,136.667,133.3337, & + &130.0003,126.667,123.3337,120.0003,116.667,113.3337,110.0003, & + &106.667,103.3337,100.0003/ +! + kp_local=kp(kdt_3h) + f107_local=f107(kdt_3h) + if(kp_local.lt.0.7) kp_local=0.7 + if(f107_local.lt.70.) f107_local=70. +! print*, 'in getno, kdt_3h, f107_local=',kdt_3h, f107_local, & +! & kp_local +! d logp using for extent up + do k=2,levs + dx(k)=log(pr(k-1))-log(pr(k)) + enddo +! print*,'dx',dx +! find interp latitude + do il=1,im + do i=1,32 + if(mlat(il).ge.lat33(i).and.mlat(il).le.lat33(i+1)) then + iref(il)=i + dl(il)=(mlat(il)-lat33(i))/(lat33(i+1)-lat33(i)) + endif + enddo + enddo +! print*,zm +!... eof1 - kp + m1 = kp_local * 0.689254 - 1.53366 +!... eof2 - declination + theta0 = 360.*float(doy - 1)/365.*3.1415926/180. + dec = 0.006918 & + & - 0.399912 * cos(theta0) + 0.070257 * sin(theta0) & + & - 0.006758 * cos(2.*theta0) + 0.000907 * sin(2.*theta0) & + & - 0.002697 * cos(3.*theta0) + 0.001480 * sin(3.*theta0) + dec = dec * 180./3.1415927 + m2 = -0.31978 & + & + dec * 0.097309 & + & + dec**2 * 0.00048979 & + & - dec**3 * 0.00010360 +!... eof3 - f107 + m3 = alog10(f107_local) * 6.35777 - 13.8163 +!... zonal mean distrib. is sum of mean and eofs + do il=1,im + do k=1,16 + zm(k) =dl(il)*(nom(iref(il)+1,k) & + & - m1 * eof(iref(il)+1,k,1) & + & + m2 * eof(iref(il)+1,k,2) & + & - m3 * eof(iref(il)+1,k,3))+ & + & (1.-dl(il))*(nom(iref(il),k) & + & - m1 * eof(iref(il),k,1) & + & + m2 * eof(iref(il),k,2) & + & - m3 * eof(iref(il),k,3)) + enddo + zm = zm*1.e6 ! zm in m-3 +! vertical interp, from k1 to k2-1, extend k2 to levs, keep +! cons 1 to k1-1 + k1=0 + k2=0 + kref=0 + do k=2,levs-1 + if(alt(il,k).lt.z16(16).or.alt(il,k).gt.z16(1)) go to 20 + if(kref(k-1).eq.0.and.k1.eq.0) k1=k + do i=1,15 + if(alt(il,k).ge.z16(i+1).and.alt(il,k).le.z16(i)) then + kref(k)=i + dz(k)=(alt(il,k)-z16(i))/(z16(i+1)-z16(i)) + endif + enddo + if(kref(k).ne.0) & + & no(il,k)=dz(k)*zm(kref(k)+1)+(1.-dz(k))*zm(kref(k)) + go to 30 + 20 continue + if((kref(k-1).ne.0).and.k2.eq.0.and.k1.ne.0) k2=k + 30 continue + enddo +! if(k1.eq.0.or.k2.eq.0)print*,'www7',il,k1,k2,alt(il,1:150) + no(il,1:k1-1)=no(il,k1) +! extend up + if(k2.gt.100) then + do k=k2,levs + no(il,k)=no(il,k-1)*n(il,k)/n(il,k-1)* & + & exp(dx(k)*(1.-.5*amno*(1./am(il,k-1)+1./am(il,k)))) + enddo + endif + do k=1,levs + no(il,k)=max(no(il,k),0.) + enddo +! + enddo !il + return + end diff --git a/gsmphys/idea_tracer.f b/gsmphys/idea_tracer.f new file mode 100644 index 00000000..21f618c9 --- /dev/null +++ b/gsmphys/idea_tracer.f @@ -0,0 +1,419 @@ + module idea_tracer_mod +!----------------------------------------------------------------------- +! hold jprofile +! Apr 06 2012 Henry Juang, initial implement for nems +! Oct 20 2015 Weiyu Yang, add f10.7 inputted data. +!----------------------------------------------------------------------- + implicit none +!hmhj save + real, allocatable:: jj(:) + end module idea_tracer_mod +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_tracer_init(levs) + use idea_tracer_mod + implicit none + integer, intent(in):: levs !number of pres levels + allocate (jj(levs)) + call jprofile(levs,jj) + return + end subroutine +!cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_tracer(im,ix,levs,ntrac,ntrac_i,grav,prsi,prsl, & + &adt,q,dtp,n1,n2,n3,n,rho,am) +! + use physcons, only : amo2=>con_amo2,avgd => con_avgd, & + & amo3 => con_amo3,amh2o => con_amw + use idea_composition, only : bz,amo,amn2 + use idea_tracer_mod + implicit none +! Argument + integer, intent(in) :: im ! number of data points in up,dudt(first dim) + integer, intent(in) :: ix ! max data points in fields + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: ntrac ! number of tracer (total) + integer, intent(in) :: ntrac_i ! number of tracer add by IDEA + real, intent(in) :: prsi(ix,levs+1) ! interface pressure in KPa + real, intent(in) :: prsl(ix,levs) ! layer pressure in KPa + real, intent(in) :: grav(ix,levs) ! (m/s2) + real, intent(in) :: adt(ix,levs) ! input temp at dt=0 + real, intent(in) :: dtp ! time step in second + real, intent(inout) :: q(ix,levs,ntrac) ! input output tracer + real, intent(out) :: n1(ix,levs) ! number density of o (/cm3) + real, intent(out) :: n2(ix,levs) ! number density of o2 (/cm3) + real, intent(out) :: n3(ix,levs) ! number density of n2 (/cm3) + real, intent(out) :: n(ix,levs) ! total number density (/cm3) + real, intent(out) :: rho(ix,levs) ! density of (kg/m3) + real, intent(out) :: am(ix,levs) ! avg mass of mix (kg) +! local argument + real dq1(ix,levs,ntrac_i),dq2(ix,levs,ntrac_i),mh2o,mo3, & + &qin(ix,levs,ntrac_i), mo,mo2,mn2,qsumo(ix,levs) + integer i,k,in +! + do in=1,ntrac_i + do i=1,im + do k=1,levs + qin(i,k,in)=max(q(i,k,ntrac-ntrac_i+in),0.) + enddo + enddo + enddo + do i=1,im + do k=1,levs + qsumo(i,k)=q(i,k,1)+q(i,k,2) + enddo + enddo +! change unit from g/mol to kg + mo=amo*1.e-3/avgd + mo2=amo2*1.e-3/avgd + mn2=amn2*1.e-3/avgd + mh2o=amh2o*1.e-3/avgd + mo3=amo3*1.e-3/avgd +! at layer , here n,n1,n2 unit is /m3 , rho is in kg/m3 + do i=1,im + do k=1,levs + am(i,k)=1./(qin(i,k,1)/mo+qin(i,k,2)/mo2+q(i,k,1)/mh2o+ & + & q(i,k,2)/mo3+(1.-qin(i,k,1)-qin(i,k,2)-qsumo(i,k))/mn2) +! am(i,k)=1./(qin(i,k,1)/mo+qin(i,k,2)/mo2+ & +! & (1.-qin(i,k,1)-qin(i,k,2))/mn2) + n(i,k)=prsl(i,k)*1000./(bz*adt(i,k)) + n1(i,k)=qin(i,k,1)*am(i,k)*n(i,k)/mo + n2(i,k)=qin(i,k,2)*am(i,k)*n(i,k)/mo2 +! rho(i,k)=n1(i,k)*mo+n2(i,k)*mo2+(n(i,k)-n1(i,k)-n2(i,k))*mn2 + rho(i,k)=am(i,k)*n(i,k) + enddo + enddo +! + call idea_tracer_m(im,ix,levs,ntrac_i,grav,prsi,prsl,adt,dtp, & + &qin,am,dq1) + call idea_tracer_c(im,ix,levs,ntrac_i,adt,dtp,jj,n1,n2,n,rho, & + &qin,dq2) +! print*,'www5',q(1:im,levs,4),dq1(1:im,levs,1),dq2(1:im,levs,1) +! print*,'www5',dq1(1:im,levs,1),adt(1:im,levs) + do in=1,ntrac_i + do i=1,im + do k=1,levs + q(i,k,in+ntrac-ntrac_i)=q(i,k,in+ntrac-ntrac_i)+ & + & dq1(i,k,in)+dq2(i,k,in) + q(i,k,in+ntrac-ntrac_i)=max(q(i,k,in+ntrac-ntrac_i),0.) + enddo + enddo + enddo +! change n unit from /m3 to /cm3 to use in dissipation and solar_heating + do i=1,im + do k=1,levs + n1(i,k)=n1(i,k)*1.e-6 + n2(i,k)=n2(i,k)*1.e-6 + n(i,k)=n(i,k)*1.e-6 + n3(i,k)=n(i,k)-n1(i,k)-n2(i,k) + enddo + enddo + return + end +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + subroutine idea_tracer_m(im,ix,levs,ntrac_i,grav,prsi,prsl,adt, & + &dtp,qin,am,dq) +!----------------------------------------------------------------------- +! +! calaulate tracer changes caused by molecular diffusion +! +!----------------------------------------------------------------------- + use physcons, only :rgas=>con_rgas, amo2=>con_amo2, & + & avgd => con_avgd + use machine, only : kind_phys + use idea_composition + implicit none +! Argument + integer, intent(in) :: im ! number of data points in up,dudt(first dim) + integer, intent(in) :: ix ! max data points in fields + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: ntrac_i ! number of tracer add by IDEA + real, intent(in) :: dtp ! time step in second + real, intent(in) :: prsi(ix,levs+1) ! interface pressure in KPa + real, intent(in) :: prsl(ix,levs) ! layer pressure in KPa + real, intent(in) :: grav(ix,levs) ! (m/s2) + real, intent(in) :: adt(ix,levs) ! input temp at dt=0 + real, intent(in) :: qin(ix,levs,ntrac_i) ! input tracer + real, intent(in) :: am(ix,levs) ! avg mass of mix (kg) + real, intent(out):: dq(ix,levs,ntrac_i) ! output tracer changes +!local variables + real n1_i(levs+1),n2_i(levs+1),n3_i(levs+1),n_i(levs+1) + real t_i(levs+1),am_i(levs+1),qout(ix,levs,ntrac_i) + real beta(2,2,levs+1),a(2,2,levs),b(2,2,levs),c(2,2,levs) + real ggg(2,2),ee(2,2,levs+1),f(2,levs+1), & + & d12,d13,d23,a12,a13,a23,s12,s13,s23,mo,mo2,mn2, & + & dp1(levs),dp1_i(levs+1) + real partb_i(levs+1),parta(levs),hold1,dtp1,hold2 + integer k,i,kk,kk1,in +! change unit from g/mol to kg + mo=amo*1.e-3/avgd + mo2=amo2*1.e-3/avgd + mn2=amn2*1.e-3/avgd +! some constants + a12=9.69e18 + a13=9.69e18 + a23=8.3e18 +c + s12=0.774 + s13=0.774 + s23=0.724 +! set boundary + beta(1:2,1:2,1)=0. + beta(1:2,1:2,levs+1)=0. + a(1:2,1:2,1)=0. + c(1:2,1:2,levs)=0. + ee(1:2,1:2,levs+1)=0. + f(1:2,levs+1)=0. +! + dtp1=1./dtp + t_i=0. + am_i=0. + n_i=0. + n1_i=0. + n2_i=0. + n3_i=0. +! +! for each longitude +! + do i=1,im +! calculate temp in interface pressure levels +! get compositions at interface pressure levels + do k=2,levs + t_i(k)=(adt(i,k-1)+adt(i,k))*.5 + am_i(k)=.5*(am(i,k-1)+am(i,k)) + n_i(k)=prsi(i,k)*1000./bz/t_i(k) + n1_i(k)=.5*(qin(i,k,1)+qin(i,k-1,1))*am_i(k)*n_i(k)/mo + n2_i(k)=.5*(qin(i,k,2)+qin(i,k-1,2))*am_i(k)*n_i(k)/mo2 + n3_i(k)=n_i(k)-n1_i(k)-n2_i(k) + enddo + if(i.eq.6) then +! print*,'www6-n1_i',i,n1_i(2:levs) +! print*,'www6-n_i',i,n_i(2:levs) +! print*,'www6-t_i',i,t_i(2:levs) +! print*,'www6-am_i',i,am_i(2:levs) + endif +!printout +! if(i.eq.1) then +! do k=1,levs +! print'(i3,6e11.4,2f5.0)',k,prsi(1,k),prsl(1,k),coef_i(k,1), & +! &coef_i(k,2),cp(k),hs_i(k),t_i(k),up(i,k,3) +! enddo +! endif +! calculate beta at interface pressure + do k=2,levs + d12=a12*t_i(k)**(s12) + d13=a13*t_i(k)**(s13) + d23=a23*t_i(k)**(s23) + hold1=1./(n1_i(k)*d23+n2_i(k)*d13+n3_i(k)*d12) + beta(1,1,k)=hold1*d13*mo*(n1_i(k)*mn2*d23+ & + & (n2_i(k)*mo2+n3_i(k)*mn2)*d12) + beta(2,2,k)=hold1*d23*mo2*(n2_i(k)*mn2*d13+ & + & (n1_i(k)*mo+n3_i(k)*mn2)*d12) + beta(1,2,k)=hold1*d23*mo*n1_i(k)*(mn2*d13-mo2*d12) + beta(2,1,k)=hold1*d13*mo2*n2_i(k)*(mn2*d23-mo*d12) +! if(i.eq.6) print*,'www6-beta',i,k,beta(1,1,k),hold1,n1_i(k), & +! & n2_i(k),n3_i(k),d12,d13,d23,t_i(k),mo2,mn2 + enddo +! if(i.eq.6) print*,'www6-beta',i,beta(1,1,2:levs) +! solve tridiagonal problem + do k=1,levs + dp1(k)=1./(prsi(i,k)-prsi(i,k+1)) + parta(k)=dtp*grav(i,k)*.001*dp1(k)/bz + enddo + do k=2,levs + dp1_i(k)=1./(prsl(i,k-1)-prsl(i,k)) + partb_i(k)=.5*(grav(i,k)+grav(i,k-1))/t_i(k) + enddo + do k=2,levs + hold1=parta(k)*partb_i(k) + hold2=am(i,k-1)*prsl(i,k-1)*dp1_i(k) + a(1,1,k)=hold1*beta(1,1,k)*(hold2/mo-.5) + a(1,2,k)=hold1*beta(1,2,k)*(hold2/mo2-.5) + a(2,1,k)=hold1*beta(2,1,k)*(hold2/mo-.5) + a(2,2,k)=hold1*beta(2,2,k)*(hold2/mo2-.5) + enddo +! print*,'www6-a',i,a(1:2,1:2,levs-3:levs) + do k=1,levs-1 + hold1=parta(k)*partb_i(k+1) + hold2=am(i,k+1)*prsl(i,k+1)*dp1_i(k+1) + c(1,1,k)=hold1*beta(1,1,k+1)*(hold2/mo+.5) + c(1,2,k)=hold1*beta(1,2,k+1)*(hold2/mo2+.5) + c(2,1,k)=hold1*beta(2,1,k+1)*(hold2/mo+.5) + c(2,2,k)=hold1*beta(2,2,k+1)*(hold2/mo2+.5) + enddo + do k=2,levs-1 + hold1=am(i,k)*prsl(i,k)*dp1_i(k+1) + hold2=am(i,k)*prsl(i,k)*dp1_i(k) + b(1,1,k)=1.+parta(k)*(partb_i(k+1)*beta(1,1,k+1)*(hold1/mo-.5) & + & +partb_i(k)*beta(1,1,k)*(hold2/mo+.5)) + b(2,2,k)=1.+parta(k)*(partb_i(k+1)*beta(2,2,k+1)*(hold1/mo2-.5) & + & +partb_i(k)*beta(2,2,k)*(hold2/mo2+.5)) + b(1,2,k)=parta(k)*(partb_i(k+1)*beta(1,2,k+1)*(hold1/mo2-.5) & + & +partb_i(k)*beta(1,2,k)*(hold2/mo2+.5)) + b(2,1,k)=parta(k)*(partb_i(k+1)*beta(2,1,k+1)*(hold1/mo-.5) & + & +partb_i(k)*beta(2,1,k)*(hold2/mo+.5)) + enddo + hold1=am(i,1)*prsl(i,1)*dp1_i(2) + b(1,1,1)=1.+parta(1)*partb_i(2)*beta(1,1,2)*(hold1/mo-.5) + b(2,2,1)=1.+parta(1)*partb_i(2)*beta(2,2,2)*(hold1/mo2-.5) + b(1,2,1)=parta(1)*partb_i(2)*beta(1,2,2)*(hold1/mo2-.5) + b(2,1,1)=parta(1)*partb_i(2)*beta(2,1,2)*(hold1/mo-.5) + hold2=am(i,levs)*prsl(i,levs)*dp1_i(levs) + b(1,1,levs)=1.+parta(levs)*partb_i(levs)*beta(1,1,levs)* & + &(hold2/mo+.5) + b(2,2,levs)=1.+parta(levs)*partb_i(levs)*beta(2,2,levs)* & + &(hold2/mo2+.5) + b(1,2,levs)=parta(levs)*partb_i(levs)*beta(1,2,levs)* & + &(hold2/mo2+.5) + b(2,1,levs)=parta(levs)*partb_i(levs)*beta(2,1,levs)* & + &(hold2/mo+.5) + do k=levs,1,-1 + ggg(1,1)=b(2,2,k)-c(2,1,k)*ee(1,2,k+1)-c(2,2,k)*ee(2,2,k+1) + ggg(2,2)=b(1,1,k)-c(1,1,k)*ee(1,1,k+1)-c(1,2,k)*ee(2,1,k+1) + ggg(1,2)=-1.*b(1,2,k)+c(1,1,k)*ee(1,2,k+1)+c(1,2,k)*ee(2,2,k+1) + ggg(2,1)=-1.*b(2,1,k)+c(2,1,k)*ee(1,1,k+1)+c(2,2,k)*ee(2,1,k+1) + hold1=1./(ggg(1,1)*ggg(2,2)-ggg(1,2)*ggg(2,1)) + ggg=ggg*hold1 + ee(1,1,k)=ggg(1,1)*a(1,1,k)+ggg(1,2)*a(2,1,k) + ee(1,2,k)=ggg(1,1)*a(1,2,k)+ggg(1,2)*a(2,2,k) + ee(2,1,k)=ggg(2,1)*a(1,1,k)+ggg(2,2)*a(2,1,k) + ee(2,2,k)=ggg(2,1)*a(1,2,k)+ggg(2,2)*a(2,2,k) + f(1,k)=ggg(1,1)*(qin(i,k,1)+c(1,1,k)*f(1,k+1) & + &+c(1,2,k)*f(2,k+1))+ggg(1,2)*(qin(i,k,2)+c(2,1,k)*f(1,k+1) & + &+c(2,2,k)*f(2,k+1)) + f(2,k)=ggg(2,1)*(qin(i,k,1)+c(1,1,k)*f(1,k+1) & + &+c(1,2,k)*f(2,k+1))+ggg(2,2)*(qin(i,k,2)+c(2,1,k)*f(1,k+1) & + &+c(2,2,k)*f(2,k+1)) + enddo + do in=1,ntrac_i + qout(i,1,in)=f(in,1) + dq(i,1,in)=qout(i,1,in)-qin(i,1,in) + enddo + do k=2,levs + qout(i,k,1)=ee(1,1,k)*qout(i,k-1,1)+ee(1,2,k)*qout(i,k-1,2)+ & + & f(1,k) + qout(i,k,2)=ee(2,1,k)*qout(i,k-1,1)+ee(2,2,k)*qout(i,k-1,2)+ & + & f(2,k) + do in=1,ntrac_i + dq(i,k,in)=qout(i,k,in)-qin(i,k,in) + enddo + enddo + enddo !i + return + end subroutine +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc! + subroutine idea_tracer_c(im,ix,levs,ntrac_i,adt,dtp,jj,n1,n2, & + &n,rho,qin,dq) +!----------------------------------------------------------------------- +! +! calaulate tracer changes caused by chemistry reaction +! +!----------------------------------------------------------------------- + use physcons, only : rgas=>con_rgas, amo2=>con_amo2 + use physcons, only : avgd => con_avgd + use machine, only : kind_phys + use idea_composition + implicit none +! +! Argument + integer, intent(in) :: im ! number of data points in up,dudt(first dim) + integer, intent(in) :: ix ! max data points in fields + integer, intent(in) :: levs ! number of pressure levels + integer, intent(in) :: ntrac_i ! number of tracer add by IDEA + real, intent(in) :: dtp ! time step in second + real, intent(in) :: adt(ix,levs) ! input temp at dt=0 + real, intent(in) :: qin(ix,levs,ntrac_i) ! input tracer + real, intent(in) :: jj(levs) ! input photo diss rate + real, intent(in) :: n1(ix,levs)! number density of o + real, intent(in) :: n2(ix,levs)! number density of o2 + real, intent(in) :: n(ix,levs)! number density of mixture + real, intent(in) :: rho(ix,levs)! density of mixture + real, intent(out):: dq(ix,levs,ntrac_i) ! output +! Local variables + real k1,k2,p1,p2,L1,L2,mo,mo2,mn2,qout(ix,levs,ntrac_i) + integer k,i +! + mo=amo*1.e-3/avgd + mo2=amo2*1.e-3/avgd + mn2=amn2*1.e-3/avgd +! + do k=1,levs + do i=1,im +! get coefficent array o o2 n2 + k1=4.7e-45*(300./adt(i,k))**2 + k2=6.e-46*(300./adt(i,k))**(2.3) + p1=2.*jj(k)*n2(i,k)*mo/rho(i,k) + p2=k1*n1(i,k)**2*n(i,k)*mo2/rho(i,k) + L1=2.*k1*n1(i,k)*n(i,k)+k2*n2(i,k)*n(i,k) + L2=k2*n1(i,k)*n(i,k)+jj(k) + qout(i,k,1)=(qin(i,k,1)+p1*dtp)/(1.+L1*dtp) + qout(i,k,2)=(qin(i,k,2)+p2*dtp)/(1.+L2*dtp) + dq(i,k,1)=qout(i,k,1)-qin(i,k,1) + dq(i,k,2)=qout(i,k,2)-qin(i,k,2) + enddo + enddo + return + end subroutine +!------------------------------------------------------------------------- + SUBROUTINE jprofile(levs,J) +! get photo dissociation rate + use wam_f107_kp_mod, only: f107, kdt_3h + implicit none + integer, parameter :: np=17 !number of pressure levels of orig + integer, intent(in) :: levs !number of pressure levels of output + real, intent(out):: J(levs) +! local variables + real JI(np),FHT(np),C(np),J17(np) + integer k +! + DATA C/8*0.900,0.680,0.43,0.18,6*-0.066/ + DATA JI/.4e-8,.78e-8,1.5e-8,3.e-8,6.8e-8,.15e-6,.34e-6,.77e-6, & + &1.07e-6,1.35e-6,1.6e-6,1.81e-6,2.05e-6,2.23e-6,2.36e-6,2.5e-6, & + &2.57e-6/ + DATA FHT/8*1.2,1.85,2.50,3.150,6*3.8/ +! calculate photo dissociation rate (/s) in Tims 17 pressure grid + do k=1,17 + J17(k)=JI(k)*((FHT(k)-1.0)*f107(kdt_3h)/176.+C(k)) + enddo +! interplate to GFS pressure grid + call z17toz(levs,J17,J,0.) + return + end +!------------------------------------------------------------------------- + subroutine z17toz(levs,ain,aout,down) +! interpolate 17 pressure levels (from Tim's grid) to +! idea pressure grid pr(levs) + use idea_composition, only : pr=> pr_idea + implicit none + integer, parameter :: np=17 !number of pressure levels of input + integer, intent(in) :: levs !number of pressure levels of output + real, intent(in) :: ain(np) !input field in 17 pressure grid + real, intent(in) :: down !field value under 5.2285Pa + real, intent(out):: aout(levs)!output in levs pressure grid +!local variable + real p17(np),z17(np),z(levs),dz + integer kref,k,i +! + do k=1,np + p17(k)=5.2285*exp(1.-k) + z17(k)=-1.*log(p17(k)) + enddo + do k=1,levs + z(k)=-1.*log(pr(k)*100.) + enddo + do k=1,levs + kref=0 + do i=1,np-1 + if(z(k).ge.z17(i).and.z(k).le.z17(i+1)) then + kref=i + dz=(z(k)-z17(i))/(z17(i+1)-z17(i)) + endif + enddo + if(kref.ne.0) then + aout(k)=dz*ain(kref+1)+(1.-dz)*ain(kref) + elseif(z(k).lt.z17(1)) then + aout(k)=down + elseif(z(k).gt.z17(17)) then + aout(k)=ain(17) + endif + enddo + return + end diff --git a/gsmphys/ideaca.f b/gsmphys/ideaca.f new file mode 100644 index 00000000..e2db22ef --- /dev/null +++ b/gsmphys/ideaca.f @@ -0,0 +1,232 @@ +!*********************************************************************** +!*********************************************************************** +! 07/28/08 File ideaca.f created by Rashid Akmaev for a dry convective +! adjustment (CA) scheme for IDEA based on early codes written +! after Akmaev (MWR, 1991). +! Temperature is assumed to be specified in fixed pressure layers +! going up (decreasing pressure), but only minor changes are needed +! for layers going down, for temperature specified at levels, for +! vertical coordinate spacing depending on geographic location, or +! for variable critical lapse rate. +! +! Apr 06 2012 Henry Juang, initial implement for nems +! Dec 2012 Jun Wang, move init out of column physics +! Jan 2013 Jun Wang, fix the neutral layer index k when mdoel top +! layer has instability and affects adjacent +! layers underneath +! Dec 2015 Rashid Akmaev: +! 1. Fixed the indexing bug found by Jun in 2013 +! 2. Reset the offset pressure from .1 (apparently cb?) to 100. (Pa) +! 3. Reset the critical lapse rate to 9.5 K/km typical at ~100 km +! +! Contains +! module ideaca_mod +! subroutine ideaca_init(p,nl) +! subroutine ideaca_up(p,t,ix,im,nlev) +! +!*********************************************************************** + + module ideaca_mod + +! Module to keep data for dry CA routines +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! 07/28/08 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + implicit none +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Parameters +! - critical lapse rate gamma=g/Cp (K/km) +! - R/g +! - R/Cp + + real,parameter:: gamma=9.5,rdg=.287/9.5,rdcp=rdg*gamma + +! - starting pressure level above which dry CA is applied, set +! currently to the stratopause level (***should be in Pascals if +! ideaca_init is called from gloopb***) + + real,parameter:: p0=100. +! This was for testing (07/30/08, 12/02/15) +! real,parameter:: p0=100001. + +! Variables +! - model index offset for temperature (i.e., pressure layer number +! above which CA is applied) and work array dimension +! - CA procedure weigths + + integer loff,nlay + real,dimension(:),allocatable:: r,q +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + interface + subroutine ideaca_init(p,nl) + integer,intent(in):: nl + real,dimension(nl),intent(in):: p + end subroutine ideaca_init + end interface +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + end module ideaca_mod + +!*********************************************************************** + + subroutine ideaca_init(p,nl) + +! Initialize dry convective adjusment for IDEA +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use ideaca_mod, except => ideaca_init + implicit none +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! INPUT +! Total number of interface pressure levels + + integer,intent(in):: nl + +! Interface pressure levels + + real,dimension(nl),intent(in):: p +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Internal variables + + integer:: l + real,dimension(:),allocatable:: pm,dp +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Find index offset, assuming pressure index goes up (in decreasing +! pressure), calculate the number of layers to adjust + + do l=1,nl + if(p(l) <= p0) then + loff=l-1 + exit + endif + enddo + nlay=(nl-1)-loff + +! Allocate permanent and temporary arrays + + allocate(r(nlay),q(nlay)) + allocate(pm(nlay),dp(nlay)) + + do l=1,nlay + pm(l)=.5*(p(loff+l)+p(loff+l+1)) + dp(l)=p(loff+l)-p(loff+l+1) + enddo + +! Calculate weight arrays (a more general expression is used, which +! makes no difference and may be simplified in case of constant +! gamma) + + r(1)=1. + do l=2,nlay + r(l)=r(l-1)*(p(loff+l)/pm(l))**rdcp* & + & (pm(l-1)/p(loff+l))**rdcp + enddo + q(:)=dp(:)/r(:) +! + deallocate(pm,dp) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + end subroutine ideaca_init + +!*********************************************************************** + + subroutine ideaca_up(p,t,ix,im,nlev) + +! Dry convective adjusment of mid-layer temperatures going up for IDEA +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + use ideaca_mod + implicit none +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Subroutine arguments +! - input array dimensions, number of interface levels +! - interface pressures +!*** RA: Note pressure is no longer used, it's a leftover for +!*** compatibility with previous version where ideaca_init was +!*** called from inside this subroutine +! - layer temperatures + + integer,intent(in):: ix,im,nlev + real,intent(in):: p(ix,nlev) + real,intent(inout):: t(ix,nlev-1) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Internal variables + + integer:: i,j,k,l,n + integer,dimension(nlev):: nml + real,dimension(nlev):: teta,tpp,pdp +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! Outer (horizontal) loop + + do n=1,im + +! Initialize first combined layer with first model layer + + i=1 + k=i + nml(k)=1 + teta(k)=t(n,loff+1)*r(1) + pdp(k)=q(1) + tpp(k)=teta(k)*q(1) + +! Scan model layers (e.g., going up from the first layer above offset) + + do l=2,nlay + +! Initialize next layer with current model layer + + nml(k+1)=1 + teta(k+1)=t(n,loff+l)*r(l) + pdp(k+1)=q(l) + tpp(k+1)=teta(k+1)*q(l) + +! Recursively check stability with immediately underlying (combined) +! layer, until a stable stratification is found or the bottom layer +! is reached + + do j=k,1,-1 + +! For model layers going down this inequality should be reversed + + if(teta(j) <= teta(j+1)) then + +! Stable stratification - do not combine layers, advance index of +! combined layers (the number of combined layers created to this +! point), go to next model layer + + i=j+1 + exit + else + +! Unstable - combine the two layers just compared, j+1 and j, into one +! layer j, remember its index (the number of combined layers +! created to this point) + + pdp(j)=pdp(j+1)+pdp(j) + tpp(j)=tpp(j+1)+tpp(j) + nml(j)=nml(j+1)+nml(j) + teta(j)=tpp(j)/pdp(j) + i=j + endif + enddo + k=i + enddo + +! Retrieve temperature from potential temperature of (combined) layers, +! set starting model layer index + + l=1 + i=l + do j=1,k + +! Scan all model layer within each neutral layer, reset starting index + + do l=i,i+nml(j)-1 + t(n,loff+l)=teta(j)/r(l) + enddo + i=l + enddo + enddo +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end subroutine ideaca_up + +!*********************************************************************** +!*********************************************************************** diff --git a/gsmphys/iounitdef.f b/gsmphys/iounitdef.f new file mode 100644 index 00000000..61c711bb --- /dev/null +++ b/gsmphys/iounitdef.f @@ -0,0 +1,94 @@ +!!!!! ========================================================== !!!!! +!!!!! module "module_iounitdef description !!!!! +!!!!! ========================================================== !!!!! +! ! +! this module defines fortran unit numbers for input/output data ! +! files for the ncep gfs model. ! +! ! +! name type description unit no. ! +! --------------------------------------------------------------- ! +! NISIGI - input, sigma file 1 11 ! +! NISIGI2 - input, sigma file 2 12 ! +! NISFCI - input, surface initial data 14 ! +! ! +! NIMTNVR - input, montain variance file 24 ! +! NIDTBTH - input, equivalent potential temperature file 27 ! +! NICO2TR - input, co2 transm table for gfdl-lw only 15 ! +! NICO2CN - input, monthly/yearly 2-d co2 data (shared) 102 ! +! NIO3PRD - input, ozone production climatology 28 ! +! NIO3LOS - input, ozone destruction climatology 29 ! +! NIO3CLM - input, ozone climatology distribution 48 ! +! NINAMSF - input, namelist for surface file 35 ! +! NISFCYC - input, surface cycle files 101 ! +! NIRADSF - input, radiation surface data files (shared) 102 ! +! NICLTUN - input, cloud tuning table 43 ! +! NIMICPH - input, micro physics data file 1 ! +! NIAERCM - input, aerosols climatology (shared) 102 ! +! ! +! NOSIGR1 - output, first time level sigma restart file 51 ! +! NOSIGR2 - output, second time level sigma restart file 52 ! +! NOSFCR - output, surface restart file 53 ! +! NOSIGF - output, sigma file for post process 61 ! +! NOSFCF - output, surface file for post process 62 ! +! NOFLXF - output, flux file for post process 63 ! +! NOD3DF - output, 3-d file for post process 64 ! +! NOAERF - output, 2-d file for post process 65 ! +!hchuang code change [+1L] +! NOG3DF - output, 3-d file for GFS-GOCART specific 69 ! +! NOLOGF - output, log file 99 ! +! ! +! NIOFRAD - in/out, temperary radiation data file (shared) 16 ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + +!========================================! + module module_iounitdef ! +!........................................! +! + implicit none +! + public + +! --- ... input units + + integer, parameter :: NISIGI = 11 + integer, parameter :: NISIGI2 = 12 + integer, parameter :: NISFCI = 14 + integer, parameter :: NICO2TR = 15 + integer, parameter :: NICO2CN = 102 + integer, parameter :: NIMTNVR = 24 + integer, parameter :: NIDTBTH = 27 + integer, parameter :: NIO3PRD = 28 + integer, parameter :: NIO3LOS = 29 + integer, parameter :: NINAMSF = 35 + integer, parameter :: NICLTUN = 43 + integer, parameter :: NIO3CLM = 48 + integer, parameter :: NIMICPH = 1 + integer, parameter :: NISFCYC = 101 + integer, parameter :: NIAERCM = 102 + integer, parameter :: NIRADSF = 102 + +! --- ... output units + + integer, parameter :: NOSIGR1 = 51 + integer, parameter :: NOSIGR2 = 52 + integer, parameter :: NOSFCR = 53 + integer, parameter :: NOSIGF = 61 + integer, parameter :: NOSFCF = 62 + integer, parameter :: NOFLXF = 63 + integer, parameter :: NOD3DF = 64 + integer, parameter :: NOAERF = 65 ! for g2d_fld +!hchuang code change [+1L] + integer, parameter :: NOG3DF = 69 + integer, parameter :: NOLOGF = 99 + +! --- ... in/out units + + integer, parameter :: NIOFRAD = 16 + +! +!........................................! + end module module_iounitdef ! +!========================================! diff --git a/gsmphys/lrgsclr.f b/gsmphys/lrgsclr.f new file mode 100644 index 00000000..a198614d --- /dev/null +++ b/gsmphys/lrgsclr.f @@ -0,0 +1,289 @@ + SUBROUTINE LRGSCL(IX,IM,KM,DT,T1,Q1,PRSL,DEL,PRSLK,RAIN,CLW) +! + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS , ONLY : fpvs, ftdp, fthe, stma, ftlcl + USE PHYSCONS, HVAP => con_HVAP, CP => con_CP, RV => con_RV + &, EPS => con_eps, EPSM1 => con_epsm1, ROCP => con_ROCP + &, grav => con_g + implicit none +! +! include 'constant.h' +! + integer IX , IM, KM + real(kind=kind_phys) T1(IX,KM), Q1(IX,KM), PRSL(IX,KM), + & DEL(IX,KM), PRSLK(IX,KM), RAIN(IM), + & CLW(IM,KM), DT +! +! LOCAL VARIABLES +! + integer k, kmax, I + real(kind=kind_phys) dpovg, EI, el2orc, + & elocp, + & pk, qcond, qevap, + & rnevap, SLKLCL,TDPD, + & THELCL, TLCL, val0, val1 +! +! +! PHYSICAL PARAMETERS + PARAMETER(ELOCP=HVAP/CP, EL2ORC=HVAP*HVAP/(RV*CP)) +! +! + real(kind=kind_phys) TO(IM,KM), QO(IM,KM), QS(IM,KM), + & THE(IM,KM), DQ(IM,KM), RAINLVL(IM,KM), + & ES(IM,KM), DQINT(IM), PINT(IM), + & DELQBAR(IM), DELTBAR(IM), THEBAR(IM), + & THEINT(IM) + integer KMLEV(IM,KM), KE(IM), KK(IM), KS(IM) + LOGICAL FLG(IM), TOPFLG(IM), TOTFLG +cc +cc-------------------------------------------------------------------- +cc + real(kind=kind_phys) cons_0 !constant + real(kind=kind_phys) cons_1pdm8 !constant +cc + cons_0 = 0.d0 !constant + cons_1pdm8 = 1.d-8 !constant +cc +cc-------------------------------------------------------------------- +cc + KMAX = KM + DO K = 1, KM + do i=1,im + IF (PRSL(I,K) .GT. 6000.0) KMAX = K + 1 + enddo + ENDDO +C +C SURFACE PRESSURE UNIT IS CB +C + DO I=1,IM +! PSK(I) = FPKAP(PS(I)) + RAIN(I) = 0. + DELTBAR(I) = 0. + DELQBAR(I) = 0. + FLG(I) = .FALSE. + TOPFLG(I) = .FALSE. + KE(I) = kmax + 1 + KS(I) = 0 + ENDDO + TOTFLG = .FALSE. +C +C COLUMN VARIABLES +C PRSL IS PRESSURE OF THE LAYER (Pa) +C TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN +C QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 +C + DO K = 1, KMAX + DO I=1,IM +! PFLD(I,k) = PS(I) * SL(K) + TO(I,k) = T1(I,k) + QO(I,k) = Q1(I,k) + ENDDO + ENDDO +C +C MODEL CONSISTENT SATURATION MIXING RATIO +C +! es(:,:) = 0.001 * fpvs(t1(1:IM,:)) ! fpvs in Pa + DO K = 1, KMAX + DO I=1,IM + es(I,k) = min(PRSL(I,k), fpvs(t1(I,k))) ! fpvs in Pa + QS(I,k) = EPS * ES(I,k) / (PRSL(I,k) + EPSM1*ES(I,k)) + QS(I,k) = MAX(QS(I,k),cons_1pdm8) !constant + ENDDO + ENDDO + DO K = 1, KMAX + DO I=1,IM + IF(QO(I,k).GT.QS(I,k)) FLG(I) = .TRUE. + ENDDO + ENDDO +!! + DO I=1,IM + IF(FLG(I)) TOTFLG = .TRUE. + ENDDO + IF(.NOT.TOTFLG) RETURN +!! + DO K = 1, KMAX + DO I = 1, IM + DQ(I,k) = 0. + THE(I,k) = TO(I,k) + ENDDO + ENDDO +C +C COMPUTE THETA-E +C + DO K = 1, KMAX + DO I = 1, IM + IF(FLG(I)) THEN +! PK = PSK(I) * SLK(K) + PK = PRSLK(I,K) + THE(I,k) = FTHE(TO(I,k),PK) + IF(THE(I,k).EQ.0.) THEN + THE(I,k) = TO(I,k) / PK + ENDIF +C THE(I,k) = TO(I,k) * ((PRSL(I,k)-ES(I,k))*.01) ** (-ROCP) +C & * EXP(ELOCP * QS(I,k) / TO(I,k)) + DQ(I,k) = QO(I,k)- QS(I,k) +C +C MODIFICATION OF THETA-E FOR SUPER-SATURATION +C + THE(I,k)= THE(I,k) * (1. + HVAP*MAX(DQ(I,k),cons_0) !constant + & /(CP*TO(I,k))) + ENDIF + ENDDO + ENDDO + DO K = 1, KMAX + DO I = 1, IM + KMLEV(I,k) = 0 + RAINLVL(I,k) = 0. + ENDDO + ENDDO +C +C STARTING POINT OF ADJUSTMENT +C + K = 1 + DO I = 1, IM + KK(I) = 0 + DQINT(I) = 0. + THEINT(I) = 0. + THEBAR(I) = 0. + PINT(I) = 0. +C +C FOR CONDITIONALLY UNSTABLE AND SUPERSATURATED LAYERS, +C OBTAIN INTEGRATED THETA AND Q-QS +C +C KMLEV KEEPS TRACK OF THE NUMBER OF LAYERS THAT SATISFIES +C THE CONDITION FOR ADJUSTMENT +C + IF(DQ(I,k).GT.0..AND.THE(I,k).GE.THE(I,K+1).AND.FLG(I)) THEN + DQINT(I) = DQINT(I) + DQ(I,k) * DEL(I,K) + THEINT(I) = THEINT(I) + THE(I,k) * DEL(I,K) + PINT(I) = PINT(I) + DEL(I,K) + KK(I) = KK(I) + 1 + KMLEV(I,k) = KK(I) + ENDIF + ENDDO + DO K = 2, KMAX - 1 + DO I = 1, IM + IF(DQ(I,k).GT.0..AND.THE(I,k).GE.THE(I,K+1).AND.FLG(I)) THEN + DQINT(I) = DQINT(I) + DQ(I,k) * DEL(I,K) + THEINT(I) = THEINT(I) + THE(I,k) * DEL(I,K) + PINT(I) = PINT(I) + DEL(I,K) + KK(I) = KK(I) + 1 + KMLEV(I,k) = KK(I) + ENDIF + ENDDO + DO I = 1, IM + IF(PINT(I).GT.0.)THEBAR(I) = THEINT(I) / PINT(I) +C +C IF THE LAYER BELOW SATISFIES THE CONDITION AND THE PRESENT +C LAYER IS COLDER THAN THE ADJSUTED THETA-E, +C THE LAYER IS INCLUDED IF THE INTEGRATED MOISTURE EXCESS +C CAN BE MAINTAINED +C + IF(KMLEV(I,k).EQ.0.AND.KMLEV(I,K-1).GT.0.AND. + & THEBAR(I).GE.THE(I,k).AND..NOT.TOPFLG(I)) THEN + DQINT(I) = DQINT(I) + DQ(I,k) * DEL(I,K) + ENDIF + IF(KMLEV(I,k).EQ.0.AND.KMLEV(I,K-1).GT.0.AND. + & THEBAR(I).GE.THE(I,k).AND.DQINT(I).GT.0. + & .AND..NOT.TOPFLG(I)) THEN + KK(I) = KK(I) + 1 + KMLEV(I,k) = KK(I) + TOPFLG(I) = .TRUE. +! PK = PSK(I) * SLK(K) + EI = PRSL(I,k) * QO(I,k) + & / (EPS - EPSM1*QO(I,k)) + EI = MIN(MAX(EI,cons_1pdm8),ES(I,k)) !constant + TDPD = MAX(TO(I,k)-FTDP(EI),cons_0) !constant + TLCL = FTLCL(TO(I,k), TDPD) + SLKLCL = PRSLK(I,K) * TLCL / TO(I,k) + THELCL = FTHE(TLCL,SLKLCL) + IF(THELCL.NE.0.) THEN + THE(I,k) = THELCL +C THE(I,k) = TO(I,k) * ((PRSL(I,k) - EI)*.01) ** (-ROCP) +C & * EXP(ELOCP * MAX(QO(I,k),1.E-8) / TO(I,k)) + ENDIF + THEINT(I) = THEINT(I) + THE(I,k) * DEL(I,K) + PINT(I) = PINT(I) + DEL(I,K) + ENDIF + ENDDO +C +C RESET THE INTEGRAL IF THE LAYER IS NOT IN THE CLOUD +C + DO I = 1, IM + IF(KMLEV(I,k).EQ.0.AND.KMLEV(I,K-1).GT.0) THEN + THEBAR(I) = THEINT(I) / PINT(I) + DQINT(I) = 0. + THEINT(I) = 0. + PINT(I) = 0. + KK(I) = 0 + KS(I) = k - 1 + KE(I) = KS(I) - KMLEV(I,k-1) + 1 + FLG(I) = .false. + ENDIF + ENDDO + enddo +C +C When within A CLOUD LAYER, COMPUTE THE MOIST-ADIABATIC +C (TO AND QO) USING THE AVERAGED THETA-E AND THE RESULTANT RAIN +C + do k = 1, kmax + DO I = 1, IM + if(k.ge.KE(I).and.k.le.KS(I)) then +! PK = PSK(I) * SLK(K) + PK = PRSLK(I,K) +! TO(I,k) = FTMA(THEBAR(I),PK,QO(I,k)) + CALL STMA(THEBAR(i),PK,TO(I,k),QO(I,k)) + THE(I,k) = THEBAR(I) + QS(I,k) = QO(I,k) + DPOVG = DEL(I,K) * (1.0/grav) + RAINLVL(I,k) = (Q1(I,k) - QO(I,k)) * dpovg + DELTBAR(I) = DELTBAR(I) + (TO(I,k) - T1(I,k)) * dpovg / PK + DELQBAR(I) = DELQBAR(I) + (QO(I,k) - Q1(I,k)) * dpovg + ENDIF +C +C THIS STEP TAKES CARE OF STABLE HEATING +C + IF(KMLEV(I,k).EQ.0.AND.DQ(I,k).GT.0.) THEN + QCOND = (QO(I,k)-QS(I,k)) / + & (1.+EL2ORC*QS(I,k)/(TO(I,K)*TO(I,K))) + QO(I,k) = QO(I,k) - QCOND + TO(I,k) = TO(I,k) + QCOND * ELOCP +! PK = PSK(I) * SLK(K) + PK = PRSLK(I,K) +C TO(I,k) = FTMA(THE(I,k),PK,QO(I,k)) + DPOVG = DEL(I,K) * (1.0/grav) + RAINLVL(I,k) = (Q1(I,k) - QO(I,k)) * dpovg + DELTBAR(I) = DELTBAR(I) + (TO(I,k) - T1(I,k)) * dpovg / PK + DELQBAR(I) = DELQBAR(I) + (QO(I,k) - Q1(I,k)) * dpovg + QS(I,k) = QO(I,k) + ENDIF + ENDDO + ENDDO +C +C EVAPORATION OF FALLING RAIN +C + DO K = KMAX, 1, -1 + DO I = 1, IM + T1(I,k) = TO(I,k) + Q1(I,k) = QO(I,k) + DPOVG = DEL(I,K) * (1.0/grav) + RAIN(I) = RAIN(I) + RAINLVL(I,k) + CLW(I,k) * DPOVG + DQ(I,k) = (QO(I,k) - QS(I,k)) / + & (1. + EL2ORC*QS(I,k)/(TO(I,K)*TO(I,K))) + IF(RAIN(I).GT.0..AND.RAINLVL(I,k).LE.0.) THEN + QEVAP = -DQ(I,k)*(1.-EXP(-0.32*SQRT(DT*RAIN(I)))) + RNEVAP = MIN(QEVAP*DPOVG,RAIN(I)) + Q1(I,k) = Q1(I,k)+RNEVAP/DPOVG + T1(I,k) = T1(I,k)-RNEVAP/DPOVG*ELOCP + RAIN(I) = RAIN(I)-RNEVAP + DELTBAR(I) = DELTBAR(I) - RNEVAP * ELOCP + DELQBAR(I) = DELQBAR(I) + RNEVAP + ENDIF + ENDDO + ENDDO + DO I = 1, IM + RAIN(I) = MAX(RAIN(I),cons_0) !constant + ENDDO +!! + RETURN + END diff --git a/gsmphys/m_micro_driver.f90 b/gsmphys/m_micro_driver.f90 new file mode 100644 index 00000000..49b6a146 --- /dev/null +++ b/gsmphys/m_micro_driver.f90 @@ -0,0 +1,1262 @@ + subroutine m_micro_driver(im, ix, lm, flipv, dt_i & + &, prsl_i, prsi_i, prslk_i, prsik_i & + &, omega_i, QLLS_i, QLCN_i, QILS_i, QICN_i& + &, lwheat_i, swheat_i, w_upi, cf_upi & + &, FRLAND, ZPBL, CNV_MFD_i, CNV_PRC3_i & + &, CNV_DQLDT_i, CLCN_i, u_i, v_i & + &, TAUGWX, TAUGWY, TAUX, TAUY & + &, TAUOROX, TAUOROY, CNV_FICE_i & + &, CNV_NDROP_i,CNV_NICE_i, q_io, lwm_o & + &, qi_o, t_io, rn_o, sr_o & + &, ncpl_io, ncpi_io, fprcp, rnw_io & + &, snw_io, ncpr_io, ncps_io, CLLS_io, KCBL & + &, aero_in, skip_macro, cn_prc2, cn_snr & + &, lprnt, ipr, kdt, xlat, xlon) + + use machine , only: kind_phys + use physcons, grav => con_g, pi => con_pi, & + & rgas => con_rd, cp => con_cp, & + & hvap => con_hvap, hfus => con_hfus, & + & ttp => con_ttp, tice => con_t0c, & + & eps => con_eps, epsm1 => con_epsm1, & + & VIREPS => con_fvirt, & + & latvap => con_hvap, latice => con_hfus + + use funcphys, only: fpvs ! saturation vapor pressure for water-ice mixed +! use funcphys, only: fpvsl, fpvsi, fpvs ! saturation vapor pressure for water,ice & mixed + use aer_cloud, only: AerProps, getINsubset,init_aer, & + & aerosol_activate,AerConversion1 + use cldmacro, only: macro_cloud,meltfrz_inst,update_cld, & + & meltfrz_inst + use cldwat2m_micro,only: mmicro_pcond + +! use wv_saturation, only: aqsat + + implicit none +! Anning Cheng July 2015 writing the interface for GSM. Based on GMAO version of M-2M, +! and Donifan's nuclei activation, notice the vertical coordinate is top-down +! opposite to the GSM dynamic core, much work is still needed to consistently +! treat other parts of the model +!------------------------------------ +! input +! real, parameter :: r_air = 3.47d-3 + real, parameter :: one=1.0, oneb3=one/3.0, onebcp=one/cp, & + & kapa=rgas*onebcp, cpbg=cp/grav, & + & lvbcp=hvap*onebcp, lsbcp=(hvap+hfus)*onebcp +! & lvbcp=latvap/cp,lsbcp=(latvap+latice)/cp + + integer, parameter :: ncolmicro = 1 + integer,intent(in) :: im, ix,lm, ipr, kdt, fprcp + logical,intent(in) :: flipv, aero_in, skip_macro, lprnt + real (kind=kind_phys), intent(in):: dt_i + + real (kind=kind_phys), dimension(ix,lm),intent(in) :: & + & prsl_i,u_i,v_i,prslk_i,omega_i, QLLS_i,QILS_i, & + & lwheat_i,swheat_i + real (kind=kind_phys), dimension(ix,0:lm),intent(in):: prsi_i, & + & prsik_i + real (kind=kind_phys), dimension(im,lm),intent(in) :: & + & CNV_DQLDT_i, CLCN_i, QLCN_i, QICN_i, & + & CNV_MFD_i, CNV_PRC3_i, cf_upi, CNV_FICE_i, CNV_NDROP_i, & + & CNV_NICE_i, w_upi + real (kind=kind_phys),dimension(im),intent(in):: TAUGWX, & + & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY, FRLAND,ZPBL,xlat,xlon +! & TAUGWY, TAUX, TAUY, TAUOROX, TAUOROY,ps_i,FRLAND,ZPBL +! & CNVPRCP + +! output + real (kind=kind_phys),dimension(ix,lm) :: lwm_o, qi_o + real (kind=kind_phys),dimension(im) :: rn_o,sr_o + +! input and output + real (kind=kind_phys),dimension(ix,lm),intent(inout):: q_io, t_io, & + & ncpl_io,ncpi_io,CLLS_io + real (kind=kind_phys),dimension(im,lm),intent(inout):: rnw_io,snw_io,& + & ncpr_io, ncps_io +!Moo real (kind=kind_phys),dimension(im,lm),intent(inout):: CLLS_io + + +! Local variables + integer kcldtopcvn,i,k,ll, kbmin, NAUX, nbincontactdust,l + integer, dimension(im) :: kct + real (kind=kind_phys) T_ICE_ALL, USE_AV_V,BKGTAU,LCCIRRUS, & + & NPRE_FRAC, Nct, Wct, fcn, ksa1, tauxr8, DT_Moist, dt_r8, & + & TMAXLL, USURF,LTS_UP, LTS_LOW, MIN_EXP, fracover, c2_gw, est3 + + real(kind=kind_phys), allocatable, dimension(:,:) :: & + & CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE + + real(kind=kind_phys), dimension(IM,LM)::ncpl,ncpi,omega,SC_ICE, & + & RAD_CF, radheat,Q1,U1,V1,TH1,PLO, ZLO,PK, temp, & + & QLLS, QLCN, QILS,QICN, CNV_CVW,CNV_UPDF,SMAXL,SMAXI, & + & NHET_NUC, NLIM_NUC, CDNC_NUC,INC_NUC,CNN01,CNN04,CNN1,DNHET_IMM, & + & NHET_IMM,NHET_DEP,NHET_DHF,DUST_IMM,DUST_DEP, DUST_DHF,WSUB, & + & SIGW_GW,SIGW_CNV,SIGW_TURB,SIGW_RC,REV_CN_X,REV_LS_X,RSU_CN_X, & + & RSU_LS_X, ALPHT_X, DLPDF_X, DIPDF_X,rnw,snw,ncpr,ncps, & + & ACLL_CN_X,ACIL_CN_X, PFRZ, FQA,QCNTOT,QTOT,QL_TOT,qi_tot,blk_l + + real(kind=kind_phys), dimension(IM,LM):: DQRL_X, RHCmicro, & + & CNV_DQLDT, CLCN,CLLS, & + & CCN01,CCN04,CCN1 + + real(kind=kind_phys), dimension(IM,LM):: QST3,DZET,QDDF3, & + & MASS,RHX_X, CFPDF_X, & + & VFALLSN_CN_X, QSNOW_CN, & + & VFALLRN_CN_X, QRAIN_CN + + real(kind=kind_phys), dimension(IM,LM+1):: ZET + real(kind=kind_phys),dimension(IM,0:LM) :: PLE, PKE, kh,PFI_CN_X,& + PFL_CN_X + + real(kind=kind_phys),dimension(0:LM) ::SIGE + real(kind=kind_phys),dimension(LM) :: rhdfdar8, rhu00r8, & + & ttendr8,qtendr8, cwtendr8,npre8, npccninr8,ter8, & + & plevr8,ndropr8,qir8,qcr8,wparc_turb,qvr8, nir8,ncr8, & + & nimmr8,nsootr8,rnsootr8,omegr8,qrr8,qsr8,nrr8,nsr8 + + real(kind=kind_phys), dimension(1:LM,10) :: rndstr8,naconr8 + + real(kind=kind_phys), dimension(IM) :: CN_PRC2,CN_SNR,CN_ARFX,& + & LS_SNR,LS_PRC2, TPREC, & + & VMIP,twat +! Anning Cheng 10/24/2016 twat for total water, diagnostic purpose + integer, dimension(IM) :: KCBL + + real(kind=kind_phys), dimension (LM) :: uwind_gw,vwind_gw, & + & tm_gw, pm_gw, nm_gw, h_gw, rho_gw, theta_tr, khaux, qcaux, & + & dummyW , wparc_cgw, cfaux, dpre8, & + & wparc_ls,wparc_gw, swparc,smaxliq,smaxicer8,nheticer8, & + & nhet_immr8,dnhet_immr8,nhet_depr8,nhet_dhfr8,sc_icer8, & + & dust_immr8,dust_depr8,dust_dhfr8,nlimicer8,cldfr8,liqcldfr8, & + & icecldfr8,cldor8, pdelr8, & + & rpdelr8,lc_turb,zmr8,ficer8,rate1ord_cw2pr, tlatr8, qvlatr8, & + & qctendr8, qitendr8, nctendr8, nitendr8, effcr8, effc_fnr8, & + & effir8, nevaprr8, evapsnowr8, prainr8, & + & prodsnowr8, cmeoutr8, deffir8, pgamradr8, lamcradr8,qsoutr8, & + & qroutr8,droutr8, qcsevapr8,qisevapr8, qvresr8, & + & cmeioutr8 + + real(kind=kind_phys), dimension(1) :: prectr8, precir8 + + real(kind=kind_phys), dimension (LM) :: vtrmcr8,vtrmir8, & + & qcsedtenr8,qisedtenr8, praor8,prcor8,mnucccor8, mnucctor8, & + & msacwior8,psacwsor8, bergsor8,bergor8,meltor8, homoor8, & + & qcresor8, & + & prcior8, praior8,qiresor8, mnuccror8,pracsor8, meltsdtr8, & + & frzrdtr8, & + & ncalr8, ncair8, mnuccdor8, nnucctor8, nsoutr8, nroutr8, & + & nnuccdor8, nnucccor8,naair8, & + & nsacwior8, nsubior8, nprcior8, npraior8, npccnor8, npsacwsor8, & + & nsubcor8, npraor8, nprc1or8, tlatauxr8,pfrz_inc_r8 + + real(kind=kind_phys), dimension (0:LM) :: pi_gw, rhoi_gw, & + & ni_gw, ti_gw + + real(kind=kind_phys), dimension(LM+1) :: pintr8, kkvhr8 + + real (kind=kind_phys), parameter :: disp_liu=2., ui_scale=1.0 & + &, dcrit=20.0e-6 & +! &, ts_autice=1800.0 & +! &, ts_autice=3600.0 & !time scale + &, ninstr8 = 0.1e6 & + &, ncnstr8 = 100.0e6 + + real(kind=kind_phys):: k_gw, maxkh, tausurf_gw, overscale, tx1, rh1_r8 + + real(kind=kind_phys),dimension(3) :: ccn_diag + real(kind=kind_phys),dimension(58) :: cloudparams + + integer, parameter :: CCN_PARAM=2, IN_PARAM=5 + + real(kind=kind_phys), parameter ::fdust_drop=1.0, fsoot_drop=0.1 & + &, sigma_nuc_r8=0.28,SCLMFDFR=0.03 +! &, sigma_nuc_r8=0.28,SCLMFDFR=0.1 + + type (AerProps), dimension (IM,LM) :: AeroProps + type (AerProps) :: AeroAux, AeroAux_b + real, allocatable, dimension(:,:,:) :: AERMASSMIX + + logical :: use_average_v + + +!================================== +!====2-moment Microhysics= +!================== Start Stratiform cloud processes========================================== +!set up initial values + + data USE_AV_V/1./, BKGTAU/0.015/, LCCIRRUS/500./, NPRE_FRAC/1./, & + & TMAXLL/296./, fracover/1./, LTS_LOW/12./, LTS_UP/24./, & + & MIN_EXP/0.5/ + + data cloudparams/10.,4.,4.,1.,2.e-3,8.e-4,2.,1.,-1.,0.,1.3, & + &1.0e-9, 3.3e-4,20.,4.8,4.8,230.,1.0,1.0,230.,14400.,50.,0.01,0.1, & + &200.,0.,0., 0.5,0.5,2000.,0.8,0.5,-40.0,1.0,4.0,0.0,0.0,0.0, & + &1.0e-3,8.0e-4,1.0,0.95, 1.0,0.0,980.0,1.,1.,1.,0.,0.,1.e-5,2.e-5, & + &2.1e-5,4e-5,3e-5,0.1,1.,150./ + + + + + if(flipv) then + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM + Q1(i,k) = q_io(i,ll) + U1(i,k) = u_i(i,ll) + V1(i,k) = v_i(i,ll) + omega(i,k) = omega_i(i,ll) + ncpl(i,k) = ncpl_io(i,ll) + ncpi(i,k) = ncpi_io(i,ll) + rnw(i,k) = rnw_io(i,ll) + snw(i,k) = snw_io(i,ll) + ncpr(i,k) = ncpr_io(i,ll) + ncps(i,k) = ncps_io(i,ll) +! QLLS is the total cloud water + QLLS(i,k) = QLLS_i(i,ll)-QLCN_i(i,ll) + QLCN(i,k) = QLCN_i(i,ll) + QILS(i,k) = QILS_i(i,ll)-QICN_i(i,ll) + QICN(i,k) = QICN_i(i,ll) + CNV_CVW(i,k) = w_upi(i,ll) + CNV_UPDF(i,k) = cf_upi(i,ll) + CNV_DQLDT(I,K) = CNV_DQLDT_i(I,ll) + CLCN(I,k) = CLCN_i(I,ll) + CLLS(I,k) = CLLS_io(I,ll) + PLO(i,k) = prsl_i(i,ll)*0.01 + PK(i,k) = prslk_i(i,ll) + TH1(i,k) = t_io(i,ll)/prslk_i(i,ll) + radheat(i,k) = lwheat_i(i,ll) + swheat_i(i,ll) + + END DO + END DO + DO K=0, LM + ll = lm-k + DO I = 1,IM + PKE(i,k) = prsik_i(i,ll) + PLE(i,k) = prsi_i(i,ll) *.01 ! interface pressure in hPa + END DO + END DO + if (.not. skip_macro) then + allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & + &, CNV_NDROP(im,lm), CNV_NICE(im,lm)) + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM + CNV_MFD(i,k) = CNV_MFD_i(i,ll) + CNV_PRC3(i,k) = CNV_PRC3_i(i,ll) + CNV_FICE(i,k) = CNV_FICE_i(i,ll) + CNV_NDROP(i,k) = CNV_NDROP_i(i,ll) + CNV_NICE(i,k) = CNV_NICE_i(i,ll) + enddo + enddo + endif + + else + DO K=1, LM + DO I = 1,IM + Q1(i,k) = q_io(i,k) + U1(i,k) = u_i(i,k) + V1(i,k) = v_i(i,k) + omega(i,k) = omega_i(i,k) + ncpl(i,k) = ncpl_io(i,k) + ncpi(i,k) = ncpi_io(i,k) + ncpi(i,k) = ncpi_io(i,k) + rnw(i,k) = rnw_io(i,k) + snw(i,k) = snw_io(i,k) + ncpr(i,k) = ncpr_io(i,k) + ncps(i,k) = ncps_io(i,k) +! QLLS is the total cloud water + QLLS(i,k) = QLLS_i(i,k)-QLCN_i(i,k) + QLCN(i,k) = QLCN_i(i,k) + QILS(i,k) = QILS_i(i,k)-QICN_i(i,k) + QICN(i,k) = QICN_i(i,k) + CNV_CVW(i,k) = w_upi(i,k) + CNV_UPDF(i,k) = cf_upi(i,k) + CNV_DQLDT(I,K) = CNV_DQLDT_i(I,k) + CLCN(I,k) = CLCN_i(I,k) + CLLS(I,k) = CLLS_io(I,k) + PLO(i,k) = prsl_i(i,k)*0.01 + PK(i,k) = prslk_i(i,k) + TH1(i,k) = t_io(i,k)/prslk_i(i,k) + radheat(i,k) = lwheat_i(i,k) + swheat_i(i,k) + + END DO + END DO + DO K=0, LM + DO I = 1,IM + PKE(i,k) = prsik_i(i,k) + PLE(i,k) = prsi_i(i,k) *.01 ! interface pressure in hPa + END DO + END DO + if (.not. skip_macro) then + allocate(CNV_MFD(im,lm), CNV_PRC3(im,lm), CNV_FICE(im,lm) & + &, CNV_NDROP(im,lm), CNV_NICE(im,lm)) + DO K=1, LM + DO I = 1,IM + CNV_MFD(i,k) = CNV_MFD_i(i,k) + CNV_PRC3(i,k) = CNV_PRC3_i(i,k) + CNV_FICE(i,k) = CNV_FICE_i(i,k) + CNV_NDROP(i,k) = CNV_NDROP_i(i,k) + CNV_NICE(i,k) = CNV_NICE_i(i,k) + enddo + enddo + endif + endif +! + DT_MOIST = dt_i + dt_r8 = dt_i + + do i=1,im + KCBL(i) = max(LM-KCBL(i),10) + ZET(i,LM+1) = 0.0 + vmip(i) = 0.0 + KCT(i) = 10 + enddo + + DO I=1, IM + DO K = LM-2, 10, -1 + If ((CNV_DQLDT(I,K) <= 1.0e-9) .and. & + & (CNV_DQLDT(I,K+1) > 1.0e-9)) then + KCT(I) = K+1 + exit + end if + END DO + END DO + + do L=LM,1,-1 + do i=1,im + tx1 = cpbg * TH1 (i,L) * (1.0+VIREPS*Q1(i,L)) + ZLO(i,L ) = ZET(i,L+1) + tx1 * (PKE(i,L)-PK (i,L )) + ZET(i,L) = ZLO(i,L) + tx1 * (PK (i,L)-PKE(i,L-1)) + DZET(i,L) = ZET(i,L) - ZET(i,L+1) +! + temp(i,l) = th1(i,l) * PK(i,l) + tx1 = plo(i,l)*100.0 + est3 = min(tx1, fpvs(temp(i,l))) + qst3(i,l) = min(eps*est3/max(tx1+epsm1*est3,1.0e-10),1.0) + MASS(i,l) = (ple(i,l) - ple(i,l-1)) * (100.0/grav) + enddo + enddo +!------------------------------------------------------------------------------ +! call aqsat(temp,plo*100.,est3,qst3,im,im,lm,1,lm) +! do k=1,lm +! do i=1,im +! DZET(i,k) = TH1(i,k) * (pke(i,k)-pke(i,k-1)) & +! & * cpbg * (1.0 + vireps*q1(i,k)) +! MASS(i,k) = (ple(i,k) - ple(i,k-1)) * (100.0/grav) +! end do +! end do + +! do k=1,lm +! do i=1,im +! temp(i,k) = th1(i,k) * PK(i,k) +! est3 = fpvs(temp(i,k)) +! qst3(i,k) = min(eps*est3/max(plo(i,k)*100.0+epsm1*est3,1.0e-10),1.0) +! enddo +! enddo +! call aqsat(temp,plo*100.,est3,qst3,im,im,lm,1,lm) +! do k=1,lm +! do i=1,im +! DZET(i,k) = TH1(i,k) * (pke(i,k)-pke(i,k-1)) & +! & * cpbg * (1.0 + vireps*q1(i,k)) +! MASS(i,k) = (ple(i,k) - ple(i,k-1)) * (100.0/grav) +! enddo +! enddo + +! do i=1,im +! ZET(i,LM+1) = 0.0 +! vmip(i) = 0.0 +! enddo +!------------------------------------------------------------------------------ + + DO K = LM, 1, -1 + do i=1,im + if (zet(i,k) < 3000.0) then + qddf3(i,k) = - (zet(i,k) - 3000.0) * zet(i,k) * mass(i,k) + else + qddf3(i,k) = 0.0 + endif + vmip(i) = vmip(i) + qddf3(i,k) + enddo + END DO + do i=1,im + if (vmip(i) /= 0.0) vmip(i) = 1.0 / vmip(i) + enddo + DO K = 1,LM + do i=1,im + QDDF3(i,K) = QDDF3(i,K) * VMIP(i) + enddo + END DO + + + do l=lm-1,1,-1 + do i=1,im + tx1 = 0.5 * (temp(i,l+1) + temp(i,l)) + kh(i,l) = 3.55e-7*tx1**2.5*(rgas*0.01) / ple(i,l) !kh molecule diff only needing refinement + enddo + end do + do i=1,im + kh(i,0) = kh(i,1) + kh(i,lm) = kh(i,lm-1) + enddo + do L=LM,1,-1 + do i=1,im + blk_l(i,l) = 1.0 / ( 1.0/max(0.15*ZPBL(i),0.4*zlo(i,lm-1))& + & + 1.0/(zlo(i,l)*.4) ) + + SC_ICE(i,l) = 1.0 + NCPL(i,l) = MAX( NCPL(i,l), 0.) + NCPI(i,l) = MAX( NCPI(i,l), 0.) + RAD_CF(i,l) = max(0.0, min(CLLS(i,l)+CLCN(i,l), 1.0)) + CDNC_NUC(i,l) = 0.0 + INC_NUC(i,l) = 0.0 + + enddo + end do + T_ICE_ALL = TICE - 40.0 + + + + do l=1,lm + rhdfdar8(l) = 1.e-8 + rhu00r8(l) = 0.95 + + ttendr8(l) = 0. + qtendr8(l) = 0. + cwtendr8(l) = 0. + + npccninr8(l) = 0. + enddo + do k=1,10 + do l=1,lm + rndstr8(l,k) = 2.0e-7 + enddo + enddo + +!need an estimate of convective area +!======================================================================================================================= +!======================================================================================================================= +!===================================Nucleation of cloud droplets and ice crystals ====================================== +! Aerosol cloud interactions. Calculate maxCCN tendency using Fountoukis and nenes (2005) or Abdul Razzak and Ghan (2002) +! liquid Activation Parameterization +! Ice activation follows the Barahona & Nenes ice activation scheme, ACP, (2008, 2009). +! Written by Donifan Barahona and described in Barahona et al. (2013) +!======================================================================================================================= +!======================================================================================================================= +!======================================================================================================================= + if(aero_in) then + allocate(AERMASSMIX (IM,LM, 15)) + AERMASSMIX = 1.e-15 + call AerConversion1 (AERMASSMIX, AeroProps) + deallocate(AERMASSMIX) + end if + use_average_v = .false. + if (USE_AV_V > 0.0) then + use_average_v = .true. + end if + + k_gw = (pi+pi) / LCCIRRUS + +!------------------------------------------------------------------------------- + do I=1,IM ! beginning of first big I loop + + kcldtopcvn = KCT(I) + + tausurf_gw = min(0.5*SQRT(TAUOROX(I)*TAUOROX(I) & + & + TAUOROY(I)*TAUOROY(I)), 10.0) + do k=1,lm + + uwind_gw(k) = min(0.5*SQRT( U1(I,k)*U1(I,k) & + & + V1(I,k)*V1(I,k)), 50.0) + +! tausurf_gw =tausurf_gw + max (tausurf_gw, min(0.5*SQRT(TAUX(I , J)**2+TAUY(I , J)**2), 10.0)*BKGTAU) !adds a minimum value from unresolved sources + + + pm_gw(k) = 100.0*PLO(I,k) + tm_gw(k) = TEMP(I,k) + theta_tr(k) = TH1(I,k) + + nm_gw(k) = 0.0 + rho_gw(k) = pm_gw(k) /(RGAS*tm_gw(k)) + + ter8(k) = TEMP(I,k) + plevr8(k) = 100.*PLO(I,k) + ndropr8(k) = NCPL(I,k) + qir8(k) = QILS(I,k) + QICN(I,k) + qcr8(k) = QLLS(I,k) + QLCN(I,k) + qcaux(k) = qcr8(k) + + npccninr8(k) = 0.0 + naair8(k) = 0.0 + + npre8(k) = 0.0 + + if (RAD_CF(I,k) > 0.01 .and. qir8(k) > 0.0) then + npre8(k) = NPRE_FRAC*NCPI(I,k) + else + npre8(k) = 0.0 + endif + + omegr8(k) = OMEGA(I,k) + lc_turb(k) = max(blk_l(I,k), 50.0) +! rad_cooling(k) = RADheat(I,k) + + if (npre8(k) > 0.0 .and. qir8(k) > 0.0) then + dpre8(k) = ( qir8(k)/(6.0*npre8(k)*900.0*PI))**(1.0/3.0) + else + dpre8(k) = 1.0e-9 + endif + wparc_ls(k) = -omegr8(k) / (rho_gw(k)*GRAV) & + & + cpbg * radheat(i,k) +! & + cpbg * rad_cooling(k) + enddo + do k=0,lm + pi_gw(k) = 100.0*PLE(I,k) + rhoi_gw(k) = 0.0 + ni_gw(k) = 0.0 + ti_gw(k) = 0.0 + enddo + + +! ==================================================================== +!*********** Calculate subgrid scale distribution in vertical velocity**** +! ==================================================================== + + + call gw_prof (1, LM, 1, tm_gw, pm_gw, pi_gw, rhoi_gw, ni_gw, & + & ti_gw, nm_gw) + + do k=1,lm + nm_gw(k) = max(nm_gw(k), 0.005) + h_gw(k) = k_gw*rho_gw(k)*uwind_gw(k)*nm_gw(k) + if (h_gw(K) > 0.0) then + h_gw(K) = sqrt(2.0*tausurf_gw/h_gw(K)) + end if + + wparc_gw(k) = k_gw*uwind_gw(k)*h_gw(k)*0.133 + + wparc_cgw(k) = 0.0 + end do + +!!!======== Subgrid variability from Convective Sources According to Barahona et al. 2014 in prep + + if (kcldtopcvn > 20) then + + ksa1 = 1.0 + Nct = nm_gw(kcldtopcvn) + Wct = max(CNV_CVW(I,kcldtopcvn), 0.0) + + fcn = maxval(CNV_UPDF(I,kcldtopcvn:LM)) + + do k=1,kcldtopcvn + c2_gw = (nm_gw(k) + Nct) / Nct + wparc_cgw(k) = sqrt(ksa1*fcn*fcn*12.56* & + & 1.806*c2_gw*c2_gw)*Wct*0.133 + enddo + + end if + + do k=1,lm + dummyW(k) = 0.133*k_gw*uwind_gw(k)/nm_gw(k) + enddo + + do K=1, LM-5, 1 + if (wparc_cgw(K)+wparc_gw(K) > dummyW(K)) then + exit + end if + end do + + do l=1,min(k,lm-5) + wparc_cgw(l) = 0.0 + wparc_gw(l) = 0.0 + enddo + + + + kbmin = KCBL(I) + kbmin = min(int(kbmin), LM-1)-4 + do K = 1, LM + wparc_turb(k) = KH(I,k) / lc_turb(k) + dummyW(k) = 10.0 + enddo + + if (FRLAND(I) < 0.1 .and. ZPBL(I) < 800.0 .and. & + & TEMP(I,LM) < 298.0 .and. TEMP(I,LM) > 274.0 ) then + do K = 1, LM + dummyW(k) = max(min((ZET(I,k+1)-ZPBL(I))*0.01,10.0),-10.0) + dummyW(k) = 1.0 / (1.0+exp(dummyW(k))) + enddo + maxkh = max(maxval(KH(I,kbmin:LM-1)*nm_gw(kbmin:LM-1)/ & + & 0.17), 0.3) + do K = 1, LM + wparc_turb(k) = (1.0-dummyW(k))*wparc_turb(k) & + & + dummyW(k)*maxkh + enddo + + end if + + wparc_turb(kbmin:LM) = max(wparc_turb(kbmin:LM), 0.2) + + + +!!!:=========Total variance + + do K = 1, LM + swparc(k) = sqrt(wparc_gw(k) * wparc_gw(k) & + & + wparc_turb(k) * wparc_turb(k) & + & + wparc_cgw(k) * wparc_cgw(k)) + enddo + + +! ========================================================================================== +! ========================Activate the aerosols ============================================ + + do K = 1, LM + + if (plevr8(K) > 100.0) then + + + ccn_diag(1) = 0.001 + ccn_diag(2) = 0.004 + ccn_diag(3) = 0.01 + + + + if (K > 2 .and. K <= LM-2) then + tauxr8 = (ter8(K-1) + ter8(K+1) + ter8(K)) * oneb3 + end if + + if(aero_in) then + AeroAux = AeroProps(I, K) + else + call init_Aer(AeroAux) + call init_Aer(AeroAux_b) + end if + + pfrz_inc_r8(k) = 0.0 + rh1_r8 = 0.0 !related to cnv_dql_dt, needed to changed soon + + + call aerosol_activate(tauxr8, plevr8(K), swparc(K), & + & wparc_ls(K), AeroAux, npre8(k), dpre8(k), ccn_diag, & + & ndropr8(k), npccninr8(K), smaxliq(K), & +! & ndropr8(k), qcr8(K), npccninr8(K), smaxliq(K), & + & naair8(K), smaxicer8(K), nheticer8(K), nhet_immr8(K), & + & dnhet_immr8(K), nhet_depr8(k), nhet_dhfr8(k), & + & sc_icer8(k), dust_immr8(K), dust_depr8(k), & + & dust_dhfr8(k), nlimicer8(k), use_average_v, & + & CCN_PARAM, IN_PARAM, fdust_drop, & + & fsoot_drop,pfrz_inc_r8(K),sigma_nuc_r8, rh1_r8, & + & size(ccn_diag)) + + + CCN01(I,K) = max(ccn_diag(1)*1e-6, 0.0) + CCN04(I,K) = max(ccn_diag(2)*1e-6, 0.0) + CCN1 (I,K) = max(ccn_diag(3)*1e-6, 0.0) + + + + else + ccn_diag(:) = 0.0 + smaxliq(K) = 0.0 + swparc(K) = 0.0 + smaxicer8(K) = 0.0 + nheticer8(K) = 0.0 + sc_icer8(K) = 2.0 +! sc_icer8(K) = 1.0 + naair8(K) = 0.0 + npccninr8(K) = 0.0 + nlimicer8(K) = 0.0 + nhet_immr8(K) = 0.0 + dnhet_immr8(K) = 0.0 + nhet_depr8(K) = 0.0 + nhet_dhfr8(K) = 0.0 + dust_immr8(K) = 0.0 + dust_depr8(K) = 0.0 + dust_dhfr8(K) = 0.0 + + end if + + SMAXL(I,k) = smaxliq(k) * 100.0 + SMAXI(I,k) = smaxicer8(k) * 100.0 + NHET_NUC(I,k) = nheticer8(k) * 1e-6 + NLIM_NUC(I,k) = nlimicer8(k) * 1e-6 + SC_ICE(I,k) = min(max(sc_icer8(k),1.0),2.0) +! SC_ICE(I,k) = min(max(sc_icer8(k),1.0),1.2) + if(temp(i,k) > T_ICE_ALL) SC_ICE(i,k)=1.0 + CDNC_NUC(I,k) = npccninr8(k) + INC_NUC (I,k) = naair8(k) + NHET_IMM(I,k) = max(nhet_immr8(k), 0.0) + DNHET_IMM(I,k) = max(dnhet_immr8(k), 0.0) + NHET_DEP(I,k) = nhet_depr8(k) * 1e-6 + NHET_DHF(I,k) = nhet_dhfr8(k) * 1e-6 + DUST_IMM(I,k) = max(dust_immr8(k), 0.0)*1e-6 + DUST_DEP(I,k) = max(dust_depr8(k), 0.0)*1e-6 + DUST_DHF(I,k) = max(dust_dhfr8(k), 0.0)*1e-6 + WSUB (I,k) = wparc_ls(k) + swparc(k)*0.8 + SIGW_GW (I,k) = wparc_gw(k) * wparc_gw(k) + SIGW_CNV (I,k) = wparc_cgw(k) * wparc_cgw(k) + SIGW_TURB (I,k) = wparc_turb(k) * wparc_turb(k) + + enddo ! end of K loop + enddo ! end of first big I loop +!------------------------------------------------------------------------------- + +! SC_ICE=MIN(MAX(SC_ICE, 1.0), 2.0) +! WHERE (TEMP .gt. T_ICE_ALL) +! SC_ICE=1.0 +! END WHERE + +!===========================End cloud particle nucleation======================= +! ----------------------------- +! +!===========================Begin Cloud Macrophysics =========================== +! ------------------ + + do k=1,lm + do i=1,im + REV_CN_X(i,k) = 0.0 + REV_LS_X(i,k) = 0.0 + RSU_CN_X(i,k) = 0.0 + RSU_LS_X(i,k) = 0.0 +! CFX(i,k) = INC_NUC(i,k) + NHET_IMM(i,k) + enddo + enddo + do k=0,lm + do i=1,im + PFI_CN_X(i,k) = 0.0 + PFL_CN_X(i,k) = 0.0 + enddo + enddo + + if(lprnt) write(0,*)' skip_macro=',skip_macro + + if (.not. skip_macro) then + +! if (lprnt) write(0,*) ' in micro qicn2=',qicn(ipr,25),' kdt=',kdt& +! &,' qils=',qils(ipr,25) + + call macro_cloud (IM, LM, DT_MOIST, PLO, PLE, PK, FRLAND, & + & CNV_MFD, CNV_DQLDT, CNV_PRC3, CNV_UPDF, & + & U1, V1, TH1, Q1, QLLS, QLCN, QILS, QICN, & + & CLCN, CLLS, CN_PRC2, CN_ARFX, CN_SNR, & + & CLOUDPARAMS, SCLMFDFR, QST3, DZET, QDDF3, & + & RHX_X, REV_CN_X, RSU_CN_X, & + & ACLL_CN_X, ACIL_CN_X, PFL_CN_X, & + & PFI_CN_X, DLPDF_X, DIPDF_X, & + & ALPHT_X, CFPDF_X, DQRL_X, VFALLSN_CN_X, & + & VFALLRN_CN_X, CNV_FICE, CNV_NDROP, CNV_NICE, & + & SC_ICE, NCPL, NCPI, PFRZ, & + & QRAIN_CN, QSNOW_CN, KCBL, lprnt, ipr) + +! if (lprnt) write(0,*) ' in micro qicn3=',qicn(ipr,25) +! if(lprnt) write(0,*)' aft macro_cloud clcn=',clcn(ipr,:) +! if(lprnt) write(0,*)' aft macro_cloud q1=',q1(ipr,:) +! if(lprnt) write(0,*)' aft macro_cloud qils=',qils(ipr,:) + + do k=1,lm + do i=1,im + if (CNV_MFD(i,k) > 1.0e-6) then + tx1 = 1.0 / CNV_MFD(i,k) + CNV_NDROP(i,k) = CNV_NDROP(i,k) * tx1 + CNV_NICE(i,k) = CNV_NICE(i,k) * tx1 + else + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + endif + temp(i,k) = th1(i,k) * PK(i,k) + RAD_CF(i,k) = min(CLLS(i,k)+CLCN(i,k), 1.0) + + if (PFRZ(i,k) > 0.0) then + INC_NUC(i,k) = INC_NUC(i,k) * PFRZ(i,k) + NHET_NUC(i,k) = NHET_NUC(i,k) * PFRZ(i,k) + else + INC_NUC(i,k) = 0.0 + NHET_NUC(i,k) = 0.0 + endif + + enddo + enddo + + +!make sure QI , NI stay within T limits + call meltfrz_inst(IM, LM, TEMP, QLLS, QLCN, QILS, QICN, NCPL, & + & NCPI) + +!============ a little treatment of cloud before micorphysics +! call update_cld(im,lm,DT_MOIST, ALPHT_X & +! &, INT(CLOUDPARAMS(57)), PLO , Q1, QLLS & +! &, QLCN, QILS, QICN, TEMP & +! &, CLLS, CLCN, SC_ICE, NCPI & +! &, NCPL, INC_NUC, RHCmicro ) +!============ Put cloud fraction back in contact with the PDF (Barahona et al., GMD, 2014)============ + + else + do i=1,im + CN_PRC2(i) = 0.0 + CN_SNR(i) = 0.0 + enddo + + + endif ! .not. skip_macro + + +!===========================End of Cloud Macrophysics ======================== +! -------------------------- +! + + + + +!TVQX1 = SUM( ( Q1 + QLCN + QICN )*DM, 3) + + do k=1,lm + do i=1,im + QCNTOT(i,k) = QLCN(i,k) + QICN(i,k) + QTOT(i,k) = QCNTOT(i,k) + QLLS(i,k) + QILS(i,k) + QL_TOT(i,k) = QLCN(i,k) + QLLS(i,k) + QI_TOT(i,k) = QICN(i,k) + QILS(i,k) + if (QTOT(i,k) > 0.0) then + FQA(i,k) = min(max(QCNTOT(i,k)/QTOT(i,k), 0.0), 1.0) + else + FQA(i,k) = 0.0 + endif +! Anning if negative, borrow water and ice from vapor 11/23/2016 + if (QL_TOT(i,k) < 0.0) then + Q1(i,k) = Q1(i,k) + QL_TOT(i,k) + TEMP(i,k) = TEMP(i,k) - lvbcp*QL_TOT(i,k) + QL_TOT(i,k) = 0.0 + endif + if (QI_TOT(i,k) < 0.0) then + Q1(i,k) = Q1(i,k) + QI_TOT(i,k) + TEMP(i,k) = TEMP(i,k) - lsbcp*QI_TOT(i,k) + QI_TOT(i,k) = 0.0 + endif + enddo + enddo + +!============================================================================================= +!===========================Two-moment stratiform microphysics =============================== +!===========This is the implementation of the Morrison and Gettelman (2008) microphysics ===== +!============================================================================================= + + do I=1,IM + LS_SNR(i) = 0.0 + LS_PRC2(i) = 0.0 + + nbincontactdust = 1 + + do l=1,10 + do k=1,lm + naconr8(k,l) = 0.0 + rndstr8(k,l) = 2.0e-7 + enddo + enddo + do k=1,lm + npccninr8(k) = 0.0 + naair8(k) = 0.0 + omegr8(k) = 0.0 + + tx1 = MIN(CLLS(I,k) + CLCN(I,k), 0.99) + if (tx1 > 0.0) then + cldfr8(k) = min(max(tx1, 0.00001), 1.0) + else + cldfr8(k) = 0.0 + endif + + liqcldfr8(k) = cldfr8(k) + icecldfr8(k) = cldfr8(k) + + + cldor8(k) = cldfr8(k) + ter8(k) = TEMP(I,k) + qvr8(k) = Q1(I,k) + + qcr8(k) = QL_TOT(I,k) + qir8(k) = QI_TOT(I,k) + ncr8(k) = MAX(NCPL(I,k), 0.0) + nir8(k) = MAX(NCPI(I,k), 0.0) + qrr8(k) = rnw(I,k) + qsr8(k) = snw(I,k) + nrr8(k) = MAX(NCPR(I,k), 0.0) + nsr8(k) = MAX(NCPS(I,k), 0.0) + + + naair8(k) = INC_NUC(I,k) + npccninr8(k) = CDNC_NUC(I,k) + + if (cldfr8(k) >= 0.001) then + nimmr8(k) = min(DNHET_IMM(I,k),ncr8(k)/(cldfr8(k)*DT_MOIST)) + else + nimmr8(k) = 0.0 + endif + + + if(aero_in) then + AeroAux = AeroProps(I, K) + else + call init_Aer(AeroAux) + end if + call getINsubset(1, AeroAux, AeroAux_b) + naux = AeroAux_b%nmods + if (nbincontactdust < naux) then + nbincontactdust = naux + end if + naconr8(K, 1:naux) = AeroAux_b%num(1:naux) + rndstr8(K, 1:naux) = AeroAux_b%dpg(1:naux) * 0.5 + +! Get black carbon properties for contact ice nucleation + call getINsubset(2, AeroAux, AeroAux_b) + nsootr8 (K) = sum(AeroAux_b%num) + naux = AeroAux_b%nmods + rnsootr8 (K) = sum(AeroAux_b%dpg(1:naux))/naux + + pdelr8(k) = (PLE(I,k) - PLE(I,k-1)) * 100.0 + rpdelr8(k) = 1./pdelr8(k) + plevr8(k) = 100.*PLO(I,k) + zmr8(k) = ZLO(I,k) + ficer8(k) = qir8(k) /( qcr8(k)+qir8(k) + 1.e-10 ) + omegr8(k) = WSUB(I,k) + + END DO + do k=1,lm+1 + pintr8(k) = PLE(I,k-1) * 100.0 + kkvhr8(k) = KH(I,k-1) + END DO + + kbmin = KCBL(I) + +!!!Call to MG microphysics. Lives in cldwat2m_micro.f +! ttendr8, qtendr8,cwtendr8, not used so far Anning noted August 2015 + + call mmicro_pcond ( ncolmicro, ncolmicro, dt_r8, ter8, ttendr8, & + & ncolmicro, LM , qvr8, qtendr8, cwtendr8, qcr8, qir8, ncr8, nir8, & + & fprcp,qrr8, qsr8, nrr8, nsr8, & + & plevr8, pdelr8, cldfr8, liqcldfr8, icecldfr8, cldor8, pintr8, & + & rpdelr8, zmr8, rate1ord_cw2pr, naair8, npccninr8, & +! & rpdelr8, zmr8, omegr8, rate1ord_cw2pr, naair8, npccninr8, & + & rndstr8,naconr8, rhdfdar8, rhu00r8, ficer8, & + & tlatr8, qvlatr8, qctendr8, qitendr8, nctendr8, nitendr8, effcr8, & + & effc_fnr8, effir8, prectr8, precir8, nevaprr8, evapsnowr8, & + & prainr8, prodsnowr8, cmeoutr8, deffir8, pgamradr8, lamcradr8, & + & qsoutr8, qroutr8,droutr8, qcsevapr8,qisevapr8, qvresr8, & + & cmeioutr8, vtrmcr8,vtrmir8, qcsedtenr8,qisedtenr8, praor8,prcor8,& + & mnucccor8, mnucctor8,msacwior8,psacwsor8, bergsor8,bergor8, & + & meltor8, homoor8,qcresor8,prcior8, praior8,qiresor8, mnuccror8, & + & pracsor8, meltsdtr8,frzrdtr8, ncalr8, ncair8, mnuccdor8, & + & nnucctor8, nsoutr8, nroutr8, ncnstr8, ninstr8, nimmr8, disp_liu, & + & nsootr8, rnsootr8, ui_scale, dcrit, nnuccdor8, nnucccor8, & + & nsacwior8, nsubior8, nprcior8, npraior8, npccnor8, npsacwsor8, & + & nsubcor8, npraor8, nprc1or8, tlatauxr8, nbincontactdust, & +! & kbmin, lprint ) + & lprnt,xlat(i),xlon(i)) + + +! if (lprint) write(0,*)' prectr8=',prectr8(1), & +! & ' precir8=',precir8(1) + LS_PRC2(I) = max(1000.*(prectr8(1)-precir8(1)), 0.0) + LS_SNR(I) = max(1000.*precir8(1), 0.0) + + + do k=1,lm + QL_TOT(I,k) = QL_TOT(I,k) + qctendr8(k)*DT_R8 + QI_TOT(I,k) = QI_TOT(I,k) + qitendr8(k)*DT_R8 + Q1(I,k) = Q1(I,k) + qvlatr8(k)*DT_R8 +! if(lprnt .and. i == ipr) write(0,*)' k=',k,' q1aftm=',q1(i,k) & +! &,' qvlatr8=',qvlatr8(k) + TEMP(I,k) = TEMP(I,k) + tlatr8(k)*DT_R8*onebcp + + NCPL(I,k) = MAX(NCPL(I,k) + nctendr8(k) * DT_R8, 0.0) + NCPI(I,k) = MAX(NCPI(I,k) + nitendr8(k) * DT_R8, 0.0) + rnw(I,k) = qrr8(k) + snw(I,k) = qsr8(k) + NCPR(I,k) = nrr8(k) + NCPS(I,k) = nsr8(k) + + + +! CLDREFFL(I,k) = max(effcr8(k)*1.0e-6, 1.0e-6) +! CLDREFFI(I,k) = max(effir8(k)*1.0e-6, 1.0e-6) +! CLDREFFR(I,k) = droutr8(k) * 0.5 +! CLDREFFS(I,k) = 0.192*dsoutr8(k) * 0.5 + + +! QRAIN(I,k) = max(qroutr8(k), 0.0) +! QSNOW(I,k) = max(qsoutr8(k), 0.0) +! NRAIN(I,k) = max(nroutr8(k), 0.0) +! NSNOW(I,k) = max(nsoutr8(k), 0.0) + + + + +! RSU_LS_X(I,k) = evapsnowr8(k) +! REV_LS_X(I,k) = nevaprr8(k) +! SUBLC_X(I,k) = cmeioutr8(k) +! BERGS(I,k) = bergsor8(k) +! FRZ_TT_X(I,k) = mnucccor8(k) + mnucctor8(k) + homoor8(k) +! FRZ_PP_X(I,k) = mnuccror8(k) + pracsor8(k) +! MELT(I,k) = meltor8(k) +! SDM_X(I,k) = qisedtenr8(k) +! EVAPC_X(I,k) = qcsevapr8(k) +! BERG(I,k) = bergor8(k) +! ACIL_LS_X(I,k) = psacwsor8(k) + msacwior8(k, 1:LM) +! QCRES(I,k) = qcresor8(k) +! QIRES(I,k) = qiresor8(k) + +! ACLL_LS_X(I,k) = praor8(k) +! AUT_X(I,k) = prcor8(k) +! AUTICE(I,k) = prcior8(k) +! ACIL_AN_X(I,k) = praior8(k) +! ACLL_AN_X(I,k) = msacwior8(k) + +! FRZPP_LS(I,k) = frzrdtr8(k) * onebcp +! SNOWMELT_LS(I,k) = meltsdtr8(k)* onebcp + + + +! DNHET_CT(I,k) = nnucctor8(k) +! DNHET_IMM(I,k) = nnucccor8(k) +! DNCNUC(I,k) = nnuccdor8(k) +! DNCHMSPLIT(I,k) = nsacwior8(k) +! DNCSUBL (I,k) = nsubior8(k) +! DNCACRIS (I,k) = npraior8(k) +! DNCAUTICE (I,k) = nprcior8(k) + +! DNDCCN(I,k) = npccnor8(k) +! DNDACRLS(I,k) = npsacwsor8(k) +! DNDACRLR(I,k) = npraor8(k) +! DNDEVAPC(I,k) = nsubcor8(k) +! DNDAUTLIQ(I,k) = nprc1or8(k) + + + + +! DQRL_X(I,k) = qroutr8(k)/DT_R8 +! DQVDT_micro(I,k) = qvlatr8(k) +! DQIDT_micro(I,k) = qitendr8(k) +! DQLDT_micro(I,k) = qctendr8(k) +! DTDT_micro(I,k) = tlatr8(k) * onebcp + + enddo ! K loop + + enddo ! I loop +!============================================Finish 2-moment micro implementation=========================== + +!TVQX1 = SUM( ( Q1 + QL_TOT + QI_TOT(1:im,:,:))*DM, 3) & + + + if (.not. skip_macro) then + do k=1,lm + do i=1,im + QLCN(i,k) = QL_TOT(i,k) * FQA(i,k) + QLLS(i,k) = QL_TOT(i,k) - QLCN(i,k) + QICN(i,k) = QI_TOT(i,k) * FQA(i,k) + QILS(i,k) = QI_TOT(i,k) - QICN(i,k) + end do + end do + + call update_cld(im,lm, DT_MOIST, ALPHT_X & + &, INT(CLOUDPARAMS(57)), PLO, Q1, QLLS & + &, QLCN, QILS, QICN, TEMP & + &, CLLS, CLCN, SC_ICE, NCPI & + &, NCPL, INC_NUC, RHCmicro) + + do k=1,lm + do i=1,im + QL_TOT(I,K) = QLLS(I,K) + QLCN(I,K) + QI_TOT(I,K) = QILS(I,K) + QICN(I,K) + end do + end do + deallocate(CNV_MFD,CNV_PRC3,CNV_FICE,CNV_NDROP,CNV_NICE) + endif + +! do I=1,IM +! TPREC(i) = CN_PRC2(i) + LS_PRC2(i) + CN_SNR(i) + LS_SNR(i) +! enddo + + do K= 1, LM + do I=1,IM + if (QI_TOT(i,k) <= 0.0) NCPI(i,k) = 0.0 + if (QL_TOT(i,k) <= 0.0) NCPL(i,k) = 0.0 + end do + end do + + +!=============================================End Stratiform cloud processes========================================== +!====================================================================================================================== +!===========================Clean stuff and send it to radiation ====================================================== +!====================================================================================================================== +! outputs + if(flipv) then + DO K=1, LM + ll = lm-k+1 + DO I = 1,IM + t_io(i,k) = TEMP(i,ll) + q_io(i,k) = Q1(i,ll) + ncpi_io(i,k) = NCPI(i,ll) + ncpl_io(i,k) = NCPL(i,ll) + rnw_io(i,k) = rnw(i,ll) + snw_io(i,k) = snw(i,ll) + ncpr_io(i,k) = NCPR(i,ll) + ncps_io(i,k) = NCPS(i,ll) + lwm_o(i,k) = QL_TOT(i,ll) + qi_o(i,k) = QI_TOT(i,ll) + CLLS_io(i,k) = CLLS(i,ll) + END DO + END DO + else + DO K=1, LM + DO I = 1,IM + t_io(i,k) = TEMP(i,k) + q_io(i,k) = Q1(i,k) + ncpi_io(i,k) = NCPI(i,k) + ncpl_io(i,k) = NCPL(i,k) + rnw_io(i,k) = rnw(i,k) + snw_io(i,k) = snw(i,k) + ncpr_io(i,k) = NCPR(i,k) + ncps_io(i,k) = NCPS(i,k) + lwm_o(i,k) = QL_TOT(i,k) + qi_o(i,k) = QI_TOT(i,k) + CLLS_io(i,k) = CLLS(i,k) + END DO + END DO + end if + DO I = 1,IM + TPREC(i) = CN_PRC2(i) + CN_SNR(i) + LS_PRC2(i) + LS_SNR(i) +! rn_o(i) = TPREC(i) * dt_i * 0.001 + rn_o(i) = (LS_PRC2(i) + LS_SNR(i)) * dt_i * 0.001 + + if (rn_o(i) < 1.e-13) then + sr_o(i) = 0. + else + sr_o(i) = (CN_SNR(i)+LS_SNR(i)) / rn_o(i) + endif + cn_prc2(i) = cn_prc2(i) * dt_i * 0.001 + cn_snr(i) = cn_snr(i) * dt_i * 0.001 + END DO + + +!======================================================================= + + end subroutine m_micro_driver +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!DONIF Calculate the Brunt_Vaisala frequency + +!=============================================================================== + subroutine gw_prof (pcols, pver, ncol, t, pm, pi, rhoi, ni, ti, nm) + use machine , only : kind_phys + use physcons, grav => con_g, cp => con_cp, rgas => con_rd + implicit none +!----------------------------------------------------------------------- +! Compute profiles of background state quantities for the multiple +! gravity wave drag parameterization. +! +! The parameterization is assumed to operate only where water vapor +! concentrations are negligible in determining the density. +!----------------------------------------------------------------------- +!------------------------------Arguments-------------------------------- + integer, intent(in) :: ncol + integer, intent(in) :: pcols + integer, intent(in) :: pver + + + + real(kind=kind_phys), intent(in) :: t(pcols,pver) + real(kind=kind_phys), intent(in) :: pm(pcols,pver) + real(kind=kind_phys), intent(in) :: pi(pcols,0:pver) + + real(kind=kind_phys), intent(out) :: rhoi(pcols,0:pver) + real(kind=kind_phys), intent(out) :: ni(pcols,0:pver) + real(kind=kind_phys), intent(out) :: ti(pcols,0:pver) + real(kind=kind_phys), intent(out) :: nm(pcols,pver) + +!---------------------------Local storage------------------------------- + integer :: ix,kx + + real :: dtdp + real :: n2, cpair, r,g + real :: n2min = 1.e-8 + r = RGAS + cpair = CP + g = GRAV + +!----------------------------------------------------------------------------- +! Determine the interface densities and Brunt-Vaisala frequencies. +!----------------------------------------------------------------------------- + +! The top interface values are calculated assuming an isothermal atmosphere +! above the top level. + kx = 0 + do ix = 1, ncol + ti(ix,kx) = t(ix,kx+1) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = sqrt (g*g / (cpair*ti(ix,kx))) + end do + +! Interior points use centered differences + do kx = 1, pver-1 + do ix = 1, ncol + ti(ix,kx) = 0.5 * (t(ix,kx) + t(ix,kx+1)) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + dtdp = (t(ix,kx+1)-t(ix,kx)) / (pm(ix,kx+1)-pm(ix,kx)) + n2 = g*g/ti(ix,kx) * (1./cpair - rhoi(ix,kx)*dtdp) + ni(ix,kx) = sqrt (max (n2min, n2)) + end do + end do + +! Bottom interface uses bottom level temperature, density; next interface +! B-V frequency. + kx = pver + do ix = 1, ncol + ti(ix,kx) = t(ix,kx) + rhoi(ix,kx) = pi(ix,kx) / (r*ti(ix,kx)) + ni(ix,kx) = ni(ix,kx-1) + end do + +!----------------------------------------------------------------------------- +! Determine the midpoint Brunt-Vaisala frequencies. +!----------------------------------------------------------------------------- + do kx=1,pver + do ix=1,ncol + nm(ix,kx) = 0.5 * (ni(ix,kx-1) + ni(ix,kx)) + end do + end do + + return + end subroutine gw_prof + + +!Find cloud top based on cloud fraction + + subroutine find_cldtop(ncol, pver, cf, kcldtop) + implicit none + + integer, intent(in) :: pver , ncol + real, intent(in) :: cf(ncol,pver) + integer, intent(out) :: kcldtop + integer :: kuppest, ibot, k + real :: stab, cfcrit, cf00, cfp1 + + + ibot = pver-1 + kcldtop = ibot+1 + kuppest = 20 + cfcrit = 1e-2 + + + do k = kuppest , ibot + cfp1 = cf(ncol, k+1) + + if ( ( cfp1 >= cfcrit ) ) then + kcldtop = k +1 + exit + end if + end do + + if (kcldtop >= ibot) then + kcldtop = pver + return + endif + + + end subroutine find_cldtop diff --git a/gsmphys/machine.F b/gsmphys/machine.F new file mode 100644 index 00000000..ce07f8c3 --- /dev/null +++ b/gsmphys/machine.F @@ -0,0 +1,31 @@ + MODULE MACHINE + + IMPLICIT NONE + +#ifndef SINGLE_PREC + integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & + &, kind_evod = 8, kind_dbl_prec = 8 & + &, kind_qdt_prec = 16 & + &, kind_rad = 8 & + &, kind_phys = 8 ,kind_taum=8 & + &, kind_grid = 8 & + &, kind_REAL = 8 &! used in cmp_comm + &, kind_INTEGER = 4 ! -,,- + +#else + integer, parameter :: kind_io4 = 4, kind_io8 = 8 , kind_ior = 8 & + &, kind_evod = 4, kind_dbl_prec = 8 & + &, kind_qdt_prec = 16 & + &, kind_rad = 4 & + &, kind_phys = 4 ,kind_taum=4 & + &, kind_grid = 4 & + &, kind_REAL = 4 &! used in cmp_comm + &, kind_INTEGER = 4 ! -,,- + +#endif + +! + real(kind=kind_evod), parameter :: mprec = 1.e-12 ! machine precision to restrict dep + real(kind=kind_evod), parameter :: grib_undef = 9.99e20 ! grib undefine value +! + END MODULE MACHINE diff --git a/gsmphys/mersenne_twister.f b/gsmphys/mersenne_twister.f new file mode 100644 index 00000000..b5c69cb8 --- /dev/null +++ b/gsmphys/mersenne_twister.f @@ -0,0 +1,498 @@ +!$$$ Module Documentation Block +! +! Module: mersenne_twister Modern random number generator +! Prgmmr: Iredell Org: W/NX23 date: 2005-06-14 +! +! Abstract: This module calculates random numbers using the Mersenne twister. +! (It has been adapted to a Fortran 90 module from open source software. +! The comments from the original software are given below in the remarks.) +! The Mersenne twister (aka MT19937) is a state-of-the-art random number +! generator based on Mersenne primes and originally developed in 1997 by +! Matsumoto and Nishimura. It has a period before repeating of 2^19937-1, +! which certainly should be good enough for geophysical purposes. :-) +! Considering the algorithm's robustness, it runs fairly speedily. +! (Some timing statistics are given below in the remarks.) +! This adaptation uses the standard Fortran 90 random number interface, +! which can generate an arbitrary number of random numbers at one time. +! The random numbers generated are uniformly distributed between 0 and 1. +! The module also can generate random numbers from a Gaussian distribution +! with mean 0 and standard deviation 1, using a Numerical Recipes algorithm. +! The module also can generate uniformly random integer indices. +! There are also thread-safe versions of the generators in this adaptation, +! necessitating the passing of generator states which must be kept private. +! +! Program History Log: +! 2005-06-14 Mark Iredell +! +! Usage: +! The module can be compiled with 4-byte reals or with 8-byte reals, but +! 4-byte integers are required. The module should be endian-independent. +! The Fortran 90 interfaces random_seed and random_number are overloaded +! and can be used as in the standard by adding the appropriate use statement +! use mersenne_twister +! In the below use cases, harvest is a real array of arbitrary size, +! and iharvest is an integer array of arbitrary size. +! To generate uniformly distributed random numbers between 0 and 1, +! call random_number(harvest) +! To generate Gaussian distributed random numbers with 0 mean and 1 sigma, +! call random_gauss(harvest) +! To generate uniformly distributed random integer indices between 0 and n, +! call random_index(n,iharvest) +! In standard "saved" mode, the random number generator can be used without +! setting a seed. But to set a seed, only 1 non-zero integer is required, e.g. +! call random_setseed(4357) ! set default seed +! The full generator state can be set via the standard interface random_seed, +! but it is recommended to use this method only to restore saved states, e.g. +! call random_seed(size=lsave) ! get size of generator state seed array +! allocate isave(lsave) ! allocate seed array +! call random_seed(get=isave) ! fill seed array (then maybe save to disk) +! call random_seed(put=isave) ! restore state (after read from disk maybe) +! Locally kept generator states can also be saved in a seed array, e.g. +! type(random_stat):: stat +! call random_seed(get=isave,stat=stat) ! fill seed array +! call random_seed(put=isave,stat=stat) ! restore state +! To generate random numbers in a threaded region, the "thread-safe" mode +! must be used where generator states of type random_state are passed, e.g. +! type(random_stat):: stat(8) +! do i=1,8 ! threadable loop +! call random_setseed(7171*i,stat(i)) ! thread-safe call +! enddo +! do i=1,8 ! threadable loop +! call random_number(harvest,stat(i)) ! thread-safe call +! enddo +! do i=1,8 ! threadable loop +! call random_gauss(harvest,stat(i)) ! thread-safe call +! enddo +! do i=1,8 ! threadable loop +! call random_index(n,iharvest,stat(i))! thread-safe call +! enddo +! There is also a relatively inefficient "interactive" mode available, where +! setting seeds and generating random numbers are done in the same call. +! There is also a functional mode available, returning one value at a time. +! +! Public Defined Types: +! random_stat Generator state (private contents) +! +! Public Subprograms: +! random_seed determine size or put or get state +! size optional integer output size of seed array +! put optional integer(:) input seed array +! get optional integer(:) output seed array +! stat optional type(random_stat) (thread-safe mode) +! random_setseed set seed (thread-safe mode) +! inseed integer seed input +! stat type(random_stat) output +! random_setseed set seed (saved mode) +! inseed integer seed input +! random_number get mersenne twister random numbers (thread-safe mode) +! harvest real(:) numbers output +! stat type(random_stat) input +! random_number get mersenne twister random numbers (saved mode) +! harvest real(:) numbers output +! random_number get mersenne twister random numbers (interactive mode) +! harvest real(:) numbers output +! inseed integer seed input +! random_number_f get mersenne twister random number (functional mode) +! harvest real number output +! random_gauss get gaussian random numbers (thread-safe mode) +! harvest real(:) numbers output +! stat type(random_stat) input +! random_gauss get gaussian random numbers (saved mode) +! harvest real(:) numbers output +! random_gauss get gaussian random numbers (interactive mode) +! harvest real(:) numbers output +! inseed integer seed input +! random_gauss_f get gaussian random number (functional mode) +! harvest real number output +! random_index get random indices (thread-safe mode) +! imax integer maximum index input +! iharvest integer(:) numbers output +! stat type(random_stat) input +! random_index get random indices (saved mode) +! imax integer maximum index input +! iharvest integer(:) numbers output +! random_index get random indices (interactive mode) +! imax integer maximum index input +! iharvest integer(:) numbers output +! inseed integer seed input +! random_index_f get random index (functional mode) +! imax integer maximum index input +! iharvest integer number output +! +! Remarks: +! (1) Here are the comments in the original open source code: +! A C-program for MT19937: Real number version +! genrand() generates one pseudorandom real number (double) +! which is uniformly distributed on [0,1]-interval, for each +! call. sgenrand(seed) set initial values to the working area +! of 624 words. Before genrand(), sgenrand(seed) must be +! called once. (seed is any 32-bit integer except for 0). +! Integer generator is obtained by modifying two lines. +! Coded by Takuji Nishimura, considering the suggestions by +! Topher Cooper and Marc Rieffel in July-Aug. 1997. +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Library General Public +! License as published by the Free Software Foundation; either +! version 2 of the License, or (at your option) any later +! version. +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. +! See the GNU Library General Public License for more details. +! You should have received a copy of the GNU Library General +! Public License along with this library; if not, write to the +! Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA +! 02111-1307 USA +! Copyright (C) 1997 Makoto Matsumoto and Takuji Nishimura. +! When you use this, send an email to: matumoto@math.keio.ac.jp +! with an appropriate reference to your work. +! Fortran translation by Hiroshi Takano. Jan. 13, 1999. +! +! (2) On a single IBM Power4 processor on the NCEP operational cluster (2005) +! each Mersenne twister random number takes less than 30 ns, about 3 times +! slower than the default random number generator, and each random number +! from a Gaussian distribution takes less than 150 ns. +! +! Attributes: +! Language: Fortran 90 +! +!$$$ + module mersenne_twister + private +! Public declarations + public random_stat + public random_seed + public random_setseed + public random_number + public random_number_f + public random_gauss + public random_gauss_f + public random_index + public random_index_f +! Parameters + integer,parameter:: n=624 + integer,parameter:: m=397 + integer,parameter:: mata=-1727483681 ! constant vector a + integer,parameter:: umask=-2147483648 ! most significant w-r bits + integer,parameter:: lmask =2147483647 ! least significant r bits + integer,parameter:: tmaskb=-1658038656 ! tempering parameter + integer,parameter:: tmaskc=-272236544 ! tempering parameter + integer,parameter:: mag01(0:1)=(/0,mata/) + integer,parameter:: iseed=4357 + integer,parameter:: nrest=n+6 +! Defined types + type random_stat + private + integer:: mti=n+1 + integer:: mt(0:n-1) + integer:: iset + real:: gset + end type +! Saved data + type(random_stat),save:: sstat +! Overloaded interfaces + interface random_setseed + module procedure random_setseed_s + module procedure random_setseed_t + end interface + interface random_number + module procedure random_number_i + module procedure random_number_s + module procedure random_number_t + end interface + interface random_gauss + module procedure random_gauss_i + module procedure random_gauss_s + module procedure random_gauss_t + end interface + interface random_index + module procedure random_index_i + module procedure random_index_s + module procedure random_index_t + end interface +! All the subprograms + contains +! Subprogram random_seed +! Sets and gets state; overloads Fortran 90 standard. + subroutine random_seed(size,put,get,stat) + implicit none + integer,intent(out),optional:: size + integer,intent(in),optional:: put(nrest) + integer,intent(out),optional:: get(nrest) + type(random_stat),intent(inout),optional:: stat + if(present(size)) then ! return size of seed array +! if(present(put).or.present(get))& +! call errmsg('RANDOM_SEED: more than one option set - some ignored') + size=nrest + elseif(present(put)) then ! restore from seed array +! if(present(get))& +! call errmsg('RANDOM_SEED: more than one option set - some ignored') + if(present(stat)) then + stat%mti=put(1) + stat%mt=put(2:n+1) + stat%iset=put(n+2) + stat%gset=transfer(put(n+3:nrest),stat%gset) + if(stat%mti.lt.0.or.stat%mti.gt.n.or.any(stat%mt.eq.0).or. + & stat%iset.lt.0.or.stat%iset.gt.1) then + call random_setseed_t(iseed,stat) +! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used') + endif + else + sstat%mti=put(1) + sstat%mt=put(2:n+1) + sstat%iset=put(n+2) + sstat%gset=transfer(put(n+3:nrest),sstat%gset) + if(sstat%mti.lt.0.or.sstat%mti.gt.n.or.any(sstat%mt.eq.0) + & .or.sstat%iset.lt.0.or.sstat%iset.gt.1) then + call random_setseed_t(iseed,sstat) +! call errmsg('RANDOM_SEED: invalid seeds put - default seeds used') + endif + endif + elseif(present(get)) then ! save to seed array + if(present(stat)) then + if(stat%mti.eq.n+1) call random_setseed_t(iseed,stat) + get(1)=stat%mti + get(2:n+1)=stat%mt + get(n+2)=stat%iset + get(n+3:nrest)=transfer(stat%gset,get,nrest-(n+3)+1) + else + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + get(1)=sstat%mti + get(2:n+1)=sstat%mt + get(n+2)=sstat%iset + get(n+3:nrest)=transfer(sstat%gset,get,nrest-(n+3)+1) + endif + else ! reset default seed + if(present(stat)) then + call random_setseed_t(iseed,stat) + else + call random_setseed_t(iseed,sstat) + endif + endif + end subroutine +! Subprogram random_setseed_s +! Sets seed in saved mode. + subroutine random_setseed_s(inseed) + implicit none + integer,intent(in):: inseed + call random_setseed_t(inseed,sstat) + end subroutine +! Subprogram random_setseed_t +! Sets seed in thread-safe mode. + subroutine random_setseed_t(inseed,stat) + implicit none + integer,intent(in):: inseed + type(random_stat),intent(out):: stat + integer ii,mti + ii=inseed + if(ii.eq.0) ii=iseed + stat%mti=n + stat%mt(0)=iand(ii,-1) + do mti=1,n-1 + stat%mt(mti)=iand(69069*stat%mt(mti-1),-1) + enddo + stat%iset=0 + stat%gset=0. + end subroutine +! Subprogram random_number_f +! Generates random numbers in functional mode. + function random_number_f() result(harvest) + implicit none + real:: harvest + real h(1) + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + call random_number_t(h,sstat) + harvest=h(1) + end function +! Subprogram random_number_i +! Generates random numbers in interactive mode. + subroutine random_number_i(harvest,inseed) + implicit none + real,intent(out):: harvest(:) + integer,intent(in):: inseed + type(random_stat) stat + call random_setseed_t(inseed,stat) + call random_number_t(harvest,stat) + end subroutine +! Subprogram random_number_s +! Generates random numbers in saved mode; overloads Fortran 90 standard. + subroutine random_number_s(harvest) + implicit none + real,intent(out):: harvest(:) + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + call random_number_t(harvest,sstat) + end subroutine +! Subprogram random_number_t +! Generates random numbers in thread-safe mode. + subroutine random_number_t(harvest,stat) + implicit none + real,intent(out):: harvest(:) + type(random_stat),intent(inout):: stat + integer j,kk,y + integer tshftu,tshfts,tshftt,tshftl + tshftu(y)=ishft(y,-11) + tshfts(y)=ishft(y,7) + tshftt(y)=ishft(y,15) + tshftl(y)=ishft(y,-18) + do j=1,size(harvest) + if(stat%mti.ge.n) then + do kk=0,n-m-1 + y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask)) + stat%mt(kk)=ieor(ieor(stat%mt(kk+m),ishft(y,-1)), + & mag01(iand(y,1))) + enddo + do kk=n-m,n-2 + y=ior(iand(stat%mt(kk),umask),iand(stat%mt(kk+1),lmask)) + stat%mt(kk)=ieor(ieor(stat%mt(kk+(m-n)),ishft(y,-1)), + & mag01(iand(y,1))) + enddo + y=ior(iand(stat%mt(n-1),umask),iand(stat%mt(0),lmask)) + stat%mt(n-1)=ieor(ieor(stat%mt(m-1),ishft(y,-1)), + & mag01(iand(y,1))) + stat%mti=0 + endif + y=stat%mt(stat%mti) + y=ieor(y,tshftu(y)) + y=ieor(y,iand(tshfts(y),tmaskb)) + y=ieor(y,iand(tshftt(y),tmaskc)) + y=ieor(y,tshftl(y)) + if(y.lt.0) then + harvest(j)=(real(y)+2.0**32)/(2.0**32-1.0) + else + harvest(j)=real(y)/(2.0**32-1.0) + endif + stat%mti=stat%mti+1 + enddo + end subroutine +! Subprogram random_gauss_f +! Generates Gaussian random numbers in functional mode. + function random_gauss_f() result(harvest) + implicit none + real:: harvest + real h(1) + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + call random_gauss_t(h,sstat) + harvest=h(1) + end function +! Subprogram random_gauss_i +! Generates Gaussian random numbers in interactive mode. + subroutine random_gauss_i(harvest,inseed) + implicit none + real,intent(out):: harvest(:) + integer,intent(in):: inseed + type(random_stat) stat + call random_setseed_t(inseed,stat) + call random_gauss_t(harvest,stat) + end subroutine +! Subprogram random_gauss_s +! Generates Gaussian random numbers in saved mode. + subroutine random_gauss_s(harvest) + implicit none + real,intent(out):: harvest(:) + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + call random_gauss_t(harvest,sstat) + end subroutine +! Subprogram random_gauss_t +! Generates Gaussian random numbers in thread-safe mode. + subroutine random_gauss_t(harvest,stat) + implicit none + real,intent(out):: harvest(:) + type(random_stat),intent(inout):: stat + integer mx,my,mz,j + real r2(2),r,g1,g2 + mz=size(harvest) + if(mz.le.0) return + mx=0 + if(stat%iset.eq.1) then + mx=1 + harvest(1)=stat%gset + stat%iset=0 + endif + my=(mz-mx)/2*2+mx + do + call random_number_t(harvest(mx+1:my),stat) + do j=mx,my-2,2 + call rgauss(harvest(j+1),harvest(j+2),r,g1,g2) + if(r.lt.1.) then + harvest(mx+1)=g1 + harvest(mx+2)=g2 + mx=mx+2 + endif + enddo + if(mx.eq.my) exit + enddo + if(my.lt.mz) then + do + call random_number_t(r2,stat) + call rgauss(r2(1),r2(2),r,g1,g2) + if(r.lt.1.) exit + enddo + harvest(mz)=g1 + stat%gset=g2 + stat%iset=1 + endif + contains +! Numerical Recipes algorithm to generate Gaussian random numbers. + subroutine rgauss(r1,r2,r,g1,g2) + real,intent(in):: r1,r2 + real,intent(out):: r,g1,g2 + real v1,v2,fac + v1=2.*r1-1. + v2=2.*r2-1. + r=v1**2+v2**2 + if(r.lt.1.) then + fac=sqrt(-2.*log(r)/r) + g1=v1*fac + g2=v2*fac + endif + end subroutine + end subroutine +! Subprogram random_index_f +! Generates random indices in functional mode. + function random_index_f(imax) result(iharvest) + implicit none + integer,intent(in):: imax + integer:: iharvest + integer ih(1) + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + call random_index_t(imax,ih,sstat) + iharvest=ih(1) + end function +! Subprogram random_index_i +! Generates random indices in interactive mode. + subroutine random_index_i(imax,iharvest,inseed) + implicit none + integer,intent(in):: imax + integer,intent(out):: iharvest(:) + integer,intent(in):: inseed + type(random_stat) stat + call random_setseed_t(inseed,stat) + call random_index_t(imax,iharvest,stat) + end subroutine +! Subprogram random_index_s +! Generates random indices in saved mode. + subroutine random_index_s(imax,iharvest) + implicit none + integer,intent(in):: imax + integer,intent(out):: iharvest(:) + if(sstat%mti.eq.n+1) call random_setseed_t(iseed,sstat) + call random_index_t(imax,iharvest,sstat) + end subroutine +! Subprogram random_index_t +! Generates random indices in thread-safe mode. + subroutine random_index_t(imax,iharvest,stat) + implicit none + integer,intent(in):: imax + integer,intent(out):: iharvest(:) + type(random_stat),intent(inout):: stat + integer,parameter:: mh=n + integer i1,i2,mz + real h(mh) + mz=size(iharvest) + do i1=1,mz,mh + i2=min((i1-1)+mh,mz) + call random_number_t(h(:i2-(i1-1)),stat) + iharvest(i1:i2)=max(ceiling(h(:i2-(i1-1))*imax),1) + enddo + end subroutine + end module diff --git a/gsmphys/mfdeepcnv.f b/gsmphys/mfdeepcnv.f new file mode 100755 index 00000000..a6c734da --- /dev/null +++ b/gsmphys/mfdeepcnv.f @@ -0,0 +1,2265 @@ + subroutine mfdeepcnv(im,ix,km,delt,delp,prslp,psp,phil,ql, + & q1,t1,u1,v1,er,qr,cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, + & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, + & clam,c0s,c1,betal,betas,evfact,evfactl,pgcon,asolfac) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + logical, intent(in) :: er + integer, intent(in) :: im, ix, km, ncloud + integer, intent(in) :: islimsk(im) + real(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), intent(in) :: psp(im), delp(ix,km), + & prslp(ix,km), garea(im), dot(ix,km), phil(ix,km) + + integer, intent(inout) :: kcnv(im) + real(kind=kind_phys), intent(inout) :: ql(ix,km,2), + & q1(ix,km), t1(ix,km), u1(ix,km), v1(ix,km), qr(ix,km) + + integer, intent(out) :: kbot(im), ktop(im) + real(kind=kind_phys), intent(out) :: cldwrk(im), + & rn(im), cnvw(ix,km), cnvc(ix,km), + & ud_mf(im,km),dd_mf(im,km), dt_mf(im,km) +! +!------local variables + integer i, indx, jmn, k, kk, km1, n +! integer latd,lond +! + real(kind=kind_phys) clam, cxlamu, cxlamd, + & xlamde, xlamdd, + & crtlamu, crtlamd +! +! real(kind=kind_phys) detad + real(kind=kind_phys) adw, aup, aafac, + & beta, betal, betas, + & c0l, c0s, d0, + & c1, asolfac, + & dellat, delta, desdt, dg, + & dh, dhh, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, + & dxcrtas, dxcrtuf, + & dv1h, dv2h, dv3h, + & dv1q, dv2q, dv3q, + & dz, dz1, e1, edtmax, + & edtmaxl, edtmaxs, el2orc, elocp, + & es, etah, + & cthk, dthk, + & evef, evfact, evfactl, fact1, + & fact2, factor, + & g, gamma, pprime, cm, + & qlk, qrch, qs, + & rain, rfact, shear, tfac, + & val, val1, val2, + & w1, w1l, w1s, w2, + & w2l, w2s, w3, w3l, + & w3s, w4, w4l, w4s, + & rho, betaw, + & xdby, xpw, xpwd, +! & xqrch, mbdt, tem, + & xqrch, tem, tem1, tem2, + & ptem, ptem1, ptem2, + & pgcon +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), ktconn(im), + & jmin(im), lmin(im), kbmax(im), + & kbm(im), kmax(im) +! +! real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), + real(kind=kind_phys) aa1(im), + & ps(im), del(ix,km), prsl(ix,km), + & umean(im), tauadv(im), gdx(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & edto(im), edtx(im), fld(im), + & hcdo(im,km), hmax(im), hmin(im), + & ucdo(im,km), vcdo(im,km),aa2(im), + & pdot(im), po(im,km), + & pwavo(im), pwevo(im), mbdt(im), + & qcdo(im,km), qcond(im), qevap(im), + & rntot(im), vshear(im), xaa0(im), + & xk(im), xlamd(im), cina(im), + & xmb(im), xmbmax(im), xpwav(im), + & xpwev(im), xlamx(im), + & delubar(im),delvbar(im) +! + real(kind=kind_phys) c0(im) +cj + real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, + & cinacr, cinacrmx, cinacrmn +cj +! +! parameters for updraft velocity calculation + real(kind=kind_phys) bet1, cd1, f1, gam1, + & bb1, bb2, wucb +! +c physical parameters +! parameter(g=grav,asolfac=0.89) + parameter(g=grav) + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) +! parameter(c0s=.002,c1=.002,d0=.01) + parameter(d0=.01) +! parameter(c0l=c0s*asolfac) +! +! asolfac: aerosol-aware parameter based on Lim & Hong (2012) +! asolfac= cx / c0s(=.002) +! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) +! Nccn: CCN number concentration in cm^(-3) +! Until a realistic Nccn is provided, typical Nccns are assumed +! as Nccn=100 for sea and Nccn=7000 for land +! + parameter(cm=1.0,delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(cthk=200.,dthk=25.) + parameter(cinpcrmx=180.,cinpcrmn=120.) +! parameter(cinacrmx=-120.,cinacrmn=-120.) + parameter(cinacrmx=-120.,cinacrmn=-80.) + parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) + parameter(betaw=.03,dxcrtas=8.e3,dxcrtuf=15.e3) +! +! local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km) +! for updraft velocity calculation + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) + real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) +! +c cloud water +! real(kind=kind_phys) tvo(im,km) + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + & dbyo(im,km), zo(im,km), + & xlamue(im,km), xlamud(im,km), + & fent1(im,km), fent2(im,km), frh(im,km), + & heo(im,km), heso(im,km), + & qrcd(im,km), dellah(im,km), dellaq(im,km), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & eta(im,km), etad(im,km), zi(im,km), + & qrcko(im,km), qrcdo(im,km), + & pwo(im,km), pwdo(im,km), c0t(im,km), + & tx1(im), sumx(im), cnvwt(im,km) +! &, rhbar(im) +! + logical :: rain_ext(im) + logical totflg, cnvflg(im), asqecflg(im), flg(im) +! +! asqecflg: flag for the quasi-equilibrium assumption of Arakawa-Schubert +! +! real(kind=kind_phys) pcrit(15), acritt(15), acrit(15) +!! save pcrit, acritt +! data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., +! & 350.,300.,250.,200.,150./ +! data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, +! & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ +c gdas derived acrit +c data acritt/.203,.515,.521,.566,.625,.665,.659,.688, +c & .743,.813,.886,.947,1.138,1.377,1.896/ + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +! +!************************************************************************ +! convert input Pa terms to Cb terms -- Moorthi + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! +! + km1 = km - 1 +c +c initialize arrays +c + do i=1,im + cnvflg(i) = .true. + rn(i)=0. + mbdt(i)=10. + kbot(i)=km+1 + ktop(i)=0 + kbcon(i)=km + ktcon(i)=1 + ktconn(i)=1 + dtconv(i) = 3600. + cldwrk(i) = 0. + pdot(i) = 0. + lmin(i) = 1 + jmin(i) = 1 + qlko_ktcon(i) = 0. + edt(i) = 0. + edto(i) = 0. + edtx(i) = 0. +! acrt(i) = 0. +! acrtfct(i) = 1. + aa1(i) = 0. + aa2(i) = 0. + xaa0(i) = 0. + cina(i) = 0. + pwavo(i)= 0. + pwevo(i)= 0. + xpwav(i)= 0. + xpwev(i)= 0. + vshear(i) = 0. + gdx(i) = sqrt(garea(i)) + enddo +! + do i=1,im + if(islimsk(i) == 1) then + c0(i) = c0s*asolfac + else + c0(i) = c0s + endif + enddo + do k = 1, km + do i = 1, im + if(t1(i,k) > 273.16) then + c0t(i,k) = c0(i) + else + tem = d0 * (t1(i,k) - 273.16) + tem1 = exp(tem) + c0t(i,k) = c0(i) * tem1 + endif + enddo + enddo +! + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +! hchuang code change + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dd_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +c +! do k = 1, 15 +! acrit(k) = acritt(k) * (975. - pcrit(k)) +! enddo +! + dt2 = delt +! val = 1200. + val = 600. + dtmin = max(dt2, val ) +! val = 5400. + val = 10800. + dtmax = max(dt2, val ) +c model tunable parameters are all here + edtmaxl = .3 + edtmaxs = .3 +! clam = .1 + aafac = .1 +! betal = .15 +! betas = .15 +! betal = .05 +! betas = .05 +c evef = 0.07 +! evfact = 0.3 +! evfactl = 0.3 +! + crtlamu = 1.0e-4 + crtlamd = 1.0e-4 +! + cxlamu = 1.0e-3 + cxlamd = 1.0e-4 + xlamde = 1.0e-4 + xlamdd = 1.0e-4 +! +! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) +! pgcon = 0.55 ! Zhang & Wu (2003,JAS) +! + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c + do i=1,im + kbmax(i) = km + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) > 0.04) kmax(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.45) kbmax(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + enddo + enddo + do i=1,im + kmax(i) = min(km,kmax(i)) + kbmax(i) = min(kbmax(i),kmax(i)) + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and initially assume +c updraft entrainment rate as an inverse function of height +c + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + xlamue(i,k) = clam / zi(i,k) +! xlamue(i,k) = max(xlamue(i,k), crtlamu) + enddo + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c + do k = 1, km + do i = 1, im + if (k <= kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + eta(i,k) = 1. + fent1(i,k)= 1. + fent2(i,k)= 1. + frh(i,k) = 0. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + etad(i,k) = 1. + hcdo(i,k) = 0. + qcdo(i,k) = 0. + ucdo(i,k) = 0. + vcdo(i,k) = 0. + qrcd(i,k) = 0. + qrcdo(i,k)= 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + pwdo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) + wu2(i,k) = 0. + buo(i,k) = 0. + drag(i,k) = 0. + cnvwt(i,k)= 0. + endif + enddo + enddo +c +c column variables +c p is pressure of the layer (mb) +c t is temperature at t-dt (k)..tn +c q is mixing ratio at t-dt (kg/kg)..qn +c to is temperature at t+dt (k)... this is after advection and turbulan +c qo is mixing ratio at t+dt (kg/kg)..q1 +c + do k = 1, km + do i=1,im + if (k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c + do k = 1, km + do i=1,im + if (k <= kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy +c this is the level where updraft starts +c + do i=1,im + hmax(i) = heo(i,1) + kb(i) = 1 + enddo + do k = 2, km + do i=1,im + if (k <= kbm(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c + do k = 1, km1 + do i=1,im + if (k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! + do k = 1, km1 + do i=1,im + if (k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + frh(i,k) = 1. - min(qo(i,k)/qeso(i,k), 1.) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo +c +c look for the level of free convection as cloud base +c + do i=1,im + flg(i) = .true. + kbcon(i) = kmax(i) + enddo + do k = 1, km1 + do i=1,im + if (flg(i) .and. k <= kbmax(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i=1,im + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +c +c turn off convection if pressure depth between parcel source level +c and cloud base is larger than a critical value, cinpcr +c + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + ptem = 1. - tem + ptem1= .5*(cinpcrmx-cinpcrmn) + cinpcr = cinpcrmx - ptem * ptem1 + tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(tem1 > cinpcr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c assume that updraft entrainment rate above cloud base is +c same as that at cloud base +c + do i=1,im + if(cnvflg(i)) then + xlamx(i) = xlamue(i,kbcon(i)) + endif + enddo + do k = 2, km1 + do i=1,im + if(cnvflg(i).and. + & (k > kbcon(i) .and. k < kmax(i))) then + xlamue(i,k) = xlamx(i) + endif + enddo + enddo +c +c specify a background (turbulent) detrainment rate for the updrafts +c + do k = 1, km1 + do i=1,im + if(cnvflg(i) .and. k < kmax(i)) then + xlamud(i,k) = xlamx(i) +! xlamud(i,k) = crtlamd + endif + enddo + enddo +c +c functions rapidly decreasing with height, mimicking a cloud ensemble +c (Bechtold et al., 2008) +c + do k = 2, km1 + do i=1,im + if(cnvflg(i).and. + & (k > kbcon(i) .and. k < kmax(i))) then + tem = qeso(i,k)/qeso(i,kbcon(i)) + fent1(i,k) = tem**2 + fent2(i,k) = tem**3 + endif + enddo + enddo +c +c final entrainment and detrainment rates as the sum of turbulent part and +c organized entrainment depending on the environmental relative humidity +c (Bechtold et al., 2008) +c + do k = 2, km1 + do i=1,im + if(cnvflg(i) .and. + & (k > kbcon(i) .and. k < kmax(i))) then + tem = cxlamu * frh(i,k) * fent2(i,k) + xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem +! tem1 = cxlamd * frh(i,k) +! xlamud(i,k) = xlamud(i,k) + tem1 + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c determine updraft mass flux for the subcloud layers +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < kbcon(i) .and. k >= kb(i)) then + dz = zi(i,k+1) - zi(i,k) + tem = 0.5*(xlamud(i,k)+xlamud(i,k+1)) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-tem + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do i = 1, im + flg(i) = cnvflg(i) + enddo + do k = 2, km1 + do i = 1, im + if(flg(i))then + if(k > kbcon(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5*(xlamud(i,k)+xlamud(i,k-1)) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-tem + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + if(eta(i,k) <= 0.) then + kmax(i) = k + ktconn(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute updraft cloud properties +c + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + pwavo(i) = 0. + endif + enddo +c +c cloud property is modified by the entrainment process +c +! cm is an enhancement factor in entrainment rates for momentum +! + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + endif + endif + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kmax(i)) then + if(k >= kbcon(i) .and. dbyo(i,k) > 0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem > dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c calculate convective inhibition +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kbcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + cina(i) = cina(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + cina(i) = cina(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then +! + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + tem = 1. - tem + tem1= .5*(cinacrmx-cinacrmn) + cinacr = cinacrmx - tem * tem1 +! +! cinacr = cinacrmx + if(cina(i) < cinacr) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon(i) = 1 + enddo + do k = 2, km1 + do i = 1, im + if (flg(i) .and. k < kmax(i)) then + if(k > kbcon1(i) .and. dbyo(i,k) < 0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i = 1, im + if(cnvflg(i)) then + if(ktcon(i) == 1 .and. ktconn(i) > 1) then + ktcon(i) = ktconn(i) + endif + tem = pfld(i,kbcon(i))-pfld(i,ktcon(i)) + if(tem < cthk) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c search for downdraft originating level above theta-e minimum +c + do i = 1, im + if(cnvflg(i)) then + hmin(i) = heo(i,kbcon1(i)) + lmin(i) = kbmax(i) + jmin(i) = kbmax(i) + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i) .and. k <= kbmax(i)) then + if(k > kbcon1(i) .and. heo(i,k) < hmin(i)) then + lmin(i) = k + 1 + hmin(i) = heo(i,k) + endif + endif + enddo + enddo +c +c make sure that jmin(i) is within the cloud +c + do i = 1, im + if(cnvflg(i)) then + jmin(i) = min(lmin(i),ktcon(i)-1) + jmin(i) = max(jmin(i),kbcon1(i)+1) + if(jmin(i) >= ktcon(i)) cnvflg(i) = .false. + endif + enddo +c +c specify upper limit of mass flux at cloud base +c + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (g * dt2) +! +! mbdt(i) = 0.1 * dp / g +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c + do i = 1, im + if (cnvflg(i)) then +! aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) +! rhbar(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c check if there is excess moisture to release latent heat +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0 .and. k > jmin(i)) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif +! aa1(i) = aa1(i) - dz * g * qlk * etah +! aa1(i) = aa1(i) - dz * g * qlk + buo(i,k) = buo(i,k) - g * qlk + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + pwavo(i) = pwavo(i) + pwo(i,k) +! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp + cnvwt(i,k) = etah * qlk * g / dp + endif +! +! compute buoyancy and drag for updraft velocity +! + if(k >= kbcon(i)) then + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + buo(i,k) = buo(i,k) + g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + drag(i,k) = max(xlamue(i,k),xlamud(i,k)) + endif +! + endif + endif + enddo + enddo +c +! do i = 1, im +! if(cnvflg(i)) then +! indx = ktcon(i) - kb(i) - 1 +! rhbar(i) = rhbar(i) / float(indx) +! endif +! enddo +c +c calculate cloud work function +c +! do k = 2, km1 +! do i = 1, im +! if (cnvflg(i)) then +! if(k >= kbcon(i) .and. k < ktcon(i)) then +! dz1 = zo(i,k+1) - zo(i,k) +! gamma = el2orc * qeso(i,k) / (to(i,k)**2) +! rfact = 1. + delta * cp * gamma +! & * to(i,k) / hvap +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * (g / (cp * to(i,k))) +! & dz1 * (g / (cp * to(i,k))) +! & * dbyo(i,k) / (1. + gamma) +! & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) +! endif +! endif +! enddo +! enddo +! +! calculate cloud work function +! + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) +! aa1(i) = aa1(i) + buo(i,k) * dz1 * eta(i,k) + aa1(i) = aa1(i) + buo(i,k) * dz1 + endif + endif + enddo + enddo +! + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the onvective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c + do i = 1, im + if (cnvflg(i)) then + aa2(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + if(k >= ktcon(i) .and. k < kmax(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa2(i) = aa2(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact +! val = 0. +! aa2(i) = aa2(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) + if(aa2(i) < 0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= ktcon(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + pwavo(i) = pwavo(i) + pwo(i,k) +! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +! +! compute updraft velocity square(wu2) +! +! bb1 = 2. * (1.+bet1*cd1) +! bb2 = 2. / (f1*(1.+gam1)) +! +! bb1 = 3.9 +! bb2 = 0.67 +! +! bb1 = 2.0 +! bb2 = 4.0 +! + bb1 = 4.0 + bb2 = 0.8 +! + do i = 1, im + if (cnvflg(i)) then + k = kbcon1(i) + tem = po(i,k) / (rd * to(i,k)) + wucb = -0.01 * dot(i,k) / (tem * g) + if(wucb > 0.) then + wu2(i,k) = wucb * wucb + else + wu2(i,k) = 0. + endif + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo +! +! compute updraft velocity average over the whole cumulus +! + do i = 1, im + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) cnvflg(i)=.false. + endif + enddo +c +c exchange ktcon with ktcon1 +c + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c + if(ncloud > 0) then +c +c compute liquid and vapor separation at cloud top +c + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then +ccccc print *, ' aa1(i) before dwndrft =', aa1(i) +ccccc endif +c +c------- downdraft calculations +c +c--- compute precipitation efficiency in terms of windshear +c + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + edto(i)=edt(i) + edtx(i)=edt(i) + endif + enddo +c +c determine detrainment rate between 1 and kbcon +c + do i = 1, im + if(cnvflg(i)) then + sumx(i) = 0. + endif + enddo + do k = 1, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= 1 .and. k < kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + beta = betas + if(islimsk(i) == 1) beta = betal + if(cnvflg(i)) then + dz = (sumx(i)+zi(i,1))/float(kbcon(i)) + tem = 1./float(kbcon(i)) + xlamd(i) = (1.-beta**tem)/dz + endif + enddo +c +c determine downdraft mass flux +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)-1) then + if(k < jmin(i) .and. k >= kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = xlamdd - xlamde + etad(i,k) = etad(i,k+1) * (1. - ptem * dz) + else if(k < kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = xlamd(i) + xlamdd - xlamde + etad(i,k) = etad(i,k+1) * (1. - ptem * dz) + endif + endif + enddo + enddo +c +c--- downdraft moisture properties +c + do i = 1, im + if(cnvflg(i)) then + jmn = jmin(i) + hcdo(i,jmn) = heo(i,jmn) + qcdo(i,jmn) = qo(i,jmn) + qrcdo(i,jmn)= qo(i,jmn) + ucdo(i,jmn) = uo(i,jmn) + vcdo(i,jmn) = vo(i,jmn) + pwevo(i) = 0. + endif + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* + & (heo(i,k)+heo(i,k+1)))/factor + dbyo(i,k) = hcdo(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem - pgcon + ptem1= tem + pgcon + ucdo(i,k) = ((1.-tem)*ucdo(i,k+1)+ptem*uo(i,k+1) + & +ptem1*uo(i,k))/factor + vcdo(i,k) = ((1.-tem)*vcdo(i,k+1)+ptem*vo(i,k+1) + & +ptem1*vo(i,k))/factor + endif + enddo + enddo +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrcdo(i,k) = qeso(i,k)+ + & (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k) +! detad = etad(i,k+1) - etad(i,k) +cj + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5* + & (qo(i,k)+qo(i,k+1)))/factor +cj +! pwdo(i,k) = etad(i,k+1) * qcdo(i,k+1) - +! & etad(i,k) * qrcdo(i,k) +! pwdo(i,k) = pwdo(i,k) - detad * +! & .5 * (qrcdo(i,k) + qrcdo(i,k+1)) +cj + pwdo(i,k) = etad(i,k) * (qcdo(i,k) - qrcdo(i,k)) + pwevo(i) = pwevo(i) + pwdo(i,k) + endif + enddo + enddo +c +c--- final downdraft strength dependent on precip +c--- efficiency (edt), normalized condensate (pwav), and +c--- evaporate (pwev) +c + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(cnvflg(i)) then + if(pwevo(i) < 0.) then + edto(i) = -edto(i) * pwavo(i) / pwevo(i) + edto(i) = min(edto(i),edtmax) + else + edto(i) = 0. + endif + endif + enddo +c +c--- downdraft cloudwork functions +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + gamma = el2orc * qeso(i,k) / to(i,k)**2 + dhh=hcdo(i,k) + dt=to(i,k) + dg=gamma + dh=heso(i,k) + dz=-1.*(zo(i,k+1)-zo(i,k)) +! aa1(i)=aa1(i)+edto(i)*dz*etad(i,k) + aa1(i)=aa1(i)+edto(i)*dz + & *(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. +! aa1(i)=aa1(i)+edto(i)*dz*etad(i,k) + aa1(i)=aa1(i)+edto(i)*dz + & *g*delta*max(val,(qeso(i,k)-qo(i,k))) + endif + enddo + enddo + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) then + cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + dp = 1000. * del(i,1) + dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1) + & - heo(i,1)) * g / dp + dellaq(i,1) = edto(i) * etad(i,1) * (qrcdo(i,1) + & - qo(i,1)) * g / dp + dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1) + & - uo(i,1)) * g / dp + dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1) + & - vo(i,1)) * g / dp + endif + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i) .and. k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k > jmin(i)) adw = 0. + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) +c + if(k <= kbcon(i)) then + ptem = xlamde + ptem1 = xlamd(i)+xlamdd + else + ptem = xlamde + ptem1 = xlamdd + endif +cj + dellah(i,k) = dellah(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz + & + aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz + & + aup*tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qcdo(i,k-1))*dz + & ) *g/dp +cj + tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) + tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) + ptem1=etad(i,k)*(uo(i,k)-ucdo(i,k)) + ptem2=etad(i,k-1)*(uo(i,k-1)-ucdo(i,k-1)) + dellau(i,k) = dellau(i,k) + + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp +cj + tem1=eta(i,k)*(vo(i,k)-vcko(i,k)) + tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1)) + ptem1=etad(i,k)*(vo(i,k)-vcdo(i,k)) + ptem2=etad(i,k-1)*(vo(i,k-1)-vcdo(i,k-1)) + dellav(i,k) = dellav(i,k) + + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp +cj + endif + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - uo(i,indx-1)) * g / dp + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - vo(i,indx-1)) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo +c +c------- final changed variable per unit mass flux +c +! if grid size is less than a threshold value (dxcrtas), +! the quasi-equilibrium assumption of Arakawa-Schubert is not +! used any longer. +! + do i = 1, im + asqecflg(i) = cnvflg(i) + if(asqecflg(i) .and. gdx(i) < dxcrtas) then + asqecflg(i) = .false. + endif + enddo +! + do k = 1, km + do i = 1, im + if (asqecflg(i) .and. k <= kmax(i)) then + if(k > ktcon(i)) then + qo(i,k) = q1(i,k) + to(i,k) = t1(i,k) + endif + if(k <= ktcon(i)) then + qo(i,k) = dellaq(i,k) * mbdt(i) + q1(i,k) + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + to(i,k) = dellat * mbdt(i) + t1(i,k) + val = 1.e-10 + qo(i,k) = max(qo(i,k), val ) + endif + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- the above changed environment is now used to calulate the +c--- effect the arbitrary cloud (with unit mass flux) +c--- would have on the stability, +c--- which then is used to calculate the real mass flux, +c--- necessary to keep this change in balance with the large-scale +c--- destabilization. +c +c--- environmental conditions again, first heights +c + do k = 1, km + do i = 1, im + if(asqecflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c--- moist static energy +c + do k = 1, km1 + do i = 1, im + if(asqecflg(i) .and. k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo + do k = 1, km1 + do i = 1, im + if(asqecflg(i) .and. k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + endif + enddo + enddo + do i = 1, im + if(asqecflg(i)) then + k = kmax(i) + heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo +c +c**************************** static control +c +c------- moisture and cloud work functions +c + do i = 1, im + if(asqecflg(i)) then + xaa0(i) = 0. + xpwav(i) = 0. + endif + enddo +c + do i = 1, im + if(asqecflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + qcko(i,indx) = qo(i,indx) + endif + enddo + do k = 2, km1 + do i = 1, im + if (asqecflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + endif + endif + enddo + enddo + do k = 2, km1 + do i = 1, im + if (asqecflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + xdby = hcko(i,k) - heso(i,k) + xqrch = qeso(i,k) + & + gamma * xdby / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor +cj + dq = eta(i,k) * (qcko(i,k) - xqrch) +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + if(ncloud > 0 .and. k > jmin(i)) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + if(k < ktcon1(i)) then +! xaa0(i) = xaa0(i) - dz * g * qlk * etah + xaa0(i) = xaa0(i) - dz * g * qlk + endif + qcko(i,k) = qlk + xqrch + xpw = etah * c0t(i,k) * dz * qlk + xpwav(i) = xpwav(i) + xpw + endif + endif + if(k >= kbcon(i) .and. k < ktcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + xaa0(i) = xaa0(i) +! & + dz1 * eta(i,k) * (g / (cp * to(i,k))) + & + dz1 * (g / (cp * to(i,k))) + & * xdby / (1. + gamma) + & * rfact + val=0. + xaa0(i) = xaa0(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +c +c------- downdraft calculations +c +c--- downdraft moisture properties +c + do i = 1, im + if(asqecflg(i)) then + jmn = jmin(i) + hcdo(i,jmn) = heo(i,jmn) + qcdo(i,jmn) = qo(i,jmn) + qrcd(i,jmn) = qo(i,jmn) + xpwev(i) = 0. + endif + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (asqecflg(i) .and. k < jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* + & (heo(i,k)+heo(i,k+1)))/factor + endif + enddo + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (asqecflg(i) .and. k < jmin(i)) then + dq = qeso(i,k) + dt = to(i,k) + gamma = el2orc * dq / dt**2 + dh = hcdo(i,k) - heso(i,k) + qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh +! detad = etad(i,k+1) - etad(i,k) +cj + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5* + & (qo(i,k)+qo(i,k+1)))/factor +cj +! xpwd = etad(i,k+1) * qcdo(i,k+1) - +! & etad(i,k) * qrcd(i,k) +! xpwd = xpwd - detad * +! & .5 * (qrcd(i,k) + qrcd(i,k+1)) +cj + xpwd = etad(i,k) * (qcdo(i,k) - qrcd(i,k)) + xpwev(i) = xpwev(i) + xpwd + endif + enddo + enddo +c + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(asqecflg(i)) then + if(xpwev(i) >= 0.) then + edtx(i) = 0. + else + edtx(i) = -edtx(i) * xpwav(i) / xpwev(i) + edtx(i) = min(edtx(i),edtmax) + endif + endif + enddo +c +c +c--- downdraft cloudwork functions +c +c + do k = km1, 1, -1 + do i = 1, im + if (asqecflg(i) .and. k < jmin(i)) then + gamma = el2orc * qeso(i,k) / to(i,k)**2 + dhh=hcdo(i,k) + dt= to(i,k) + dg= gamma + dh= heso(i,k) + dz=-1.*(zo(i,k+1)-zo(i,k)) +! xaa0(i)=xaa0(i)+edtx(i)*dz*etad(i,k) + xaa0(i)=xaa0(i)+edtx(i)*dz + & *(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. +! xaa0(i)=xaa0(i)+edtx(i)*dz*etad(i,k) + xaa0(i)=xaa0(i)+edtx(i)*dz + & *g*delta*max(val,(qeso(i,k)-qo(i,k))) + endif + enddo + enddo +c +c calculate critical cloud work function +c +! do i = 1, im +! if(cnvflg(i)) then +! if(pfld(i,ktcon(i)) < pcrit(15))then +! acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i))) +! & /(975.-pcrit(15)) +! else if(pfld(i,ktcon(i)) > pcrit(1))then +! acrt(i)=acrit(1) +! else +! k = int((850. - pfld(i,ktcon(i)))/50.) + 2 +! k = min(k,15) +! k = max(k,2) +! acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))* +! & (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k)) +! endif +! endif +! enddo +! do i = 1, im +! if(cnvflg(i)) then +! if(islimsk(i) == 1) then +! w1 = w1l +! w2 = w2l +! w3 = w3l +! w4 = w4l +! else +! w1 = w1s +! w2 = w2s +! w3 = w3s +! w4 = w4s +! endif +c +c modify critical cloud workfunction by cloud base vertical velocity +c +! if(pdot(i) <= w4) then +! acrtfct(i) = (pdot(i) - w4) / (w3 - w4) +! elseif(pdot(i) >= -w4) then +! acrtfct(i) = - (pdot(i) + w4) / (w4 - w3) +! else +! acrtfct(i) = 0. +! endif +! val1 = -1. +! acrtfct(i) = max(acrtfct(i),val1) +! val2 = 1. +! acrtfct(i) = min(acrtfct(i),val2) +! acrtfct(i) = 1. - acrtfct(i) +c +c modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent +c +c if(rhbar(i) >= .8) then +c acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10. +c endif +c +c modify adjustment time scale by cloud base vertical velocity +c +! dtconv(i) = dt2 + max((1800. - dt2),0.) * +! & (pdot(i) - w2) / (w1 - w2) +c dtconv(i) = max(dtconv(i), dt2) +c dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2) +! +! dtconv(i) = max(dtconv(i),dtmin) +! dtconv(i) = min(dtconv(i),dtmax) +c +! endif +! enddo +! +! compute convective turn-over time +! + do i= 1, im + if(cnvflg(i)) then + tem = zi(i,ktcon1(i)) - zi(i,kbcon1(i)) + dtconv(i) = tem / wc(i) + tfac = 1. + gdx(i) / 75000. + dtconv(i) = tfac * dtconv(i) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = min(dtconv(i),dtmax) + endif + enddo +! +! compute advective time scale using a mean cloud layer wind speed +! + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv(i) = gdx(i) / umean(i) + endif + enddo +c +c compute cloud base mass flux as a function of the mean +c updraft velcoity for the grid sizes where +c the quasi-equilibrium assumption of Arakawa-Schubert is not +c valid any longer. +c + do i= 1, im + if(cnvflg(i) .and. .not.asqecflg(i)) then + k = kbcon(i) + rho = po(i,k)*100. / (rd*to(i,k)) + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + xmb(i) = tfac*betaw*rho*wc(i) + endif + enddo +c +c compute cloud base mass flux using +c the quasi-equilibrium assumption of Arakawa-Schubert +c + do i= 1, im + if(asqecflg(i)) then +! fld(i)=(aa1(i)-acrt(i)*acrtfct(i))/dtconv(i) + fld(i)=aa1(i)/dtconv(i) + if(fld(i) <= 0.) then + asqecflg(i) = .false. + cnvflg(i) = .false. + endif + endif + if(asqecflg(i)) then +c xaa0(i) = max(xaa0(i),0.) + xk(i) = (xaa0(i) - aa1(i)) / mbdt(i) + if(xk(i) >= 0.) then + asqecflg(i) = .false. + cnvflg(i) = .false. + endif + endif +c +c--- kernel, cloud base mass flux +c + if(asqecflg(i)) then + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + xmb(i) = -tfac * fld(i) / xk(i) +! xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +!--- modified Grell & Freitas' (2014) updraft fraction which uses +! actual entrainment rate at cloud base +! + do i = 1, im + if(cnvflg(i)) then + tem = min(max(xlamx(i), 7.e-5), 3.e-4) + tem = 0.2 / tem + tem1 = 3.14 * tem * tem + sigmagfm(i) = tem1 / garea(i) + sigmagfm(i) = max(sigmagfm(i), 0.001) + sigmagfm(i) = min(sigmagfm(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! + do i = 1, im + if(cnvflg(i)) then + if (gdx(i) < dxcrtuf) then + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i) = xmb(i) * scaldfunc(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +c +c restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- feedback: simply the changes from the cloud with unit mass flux +c--- multiplied by the mass flux necessary to keep the +c--- equilibrium with the larger-scale. +c + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k <= ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k <= ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + rain_ext(i) = .false. + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k >= jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + ! the following 6 lines extract all rain water, Linjiong Zhou + if (er) then + dp = 1000. * del(i,k) + qr(i,k) = qr(i,k) + rain * xmb(i) * dt2 * g / dp + if (rain .gt. 0.0) rain_ext(i) = .true. + rain = 0.0 + endif + rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo + do k = km, 1, -1 + do i = 1, im + if (k <= kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i) .and. k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k >= jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + ! the following line extract all rain water, Linjiong Zhou + if (er) rain = 0.0 + rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 + endif + if(flg(i) .and. k < ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i) > 0. .and. qcond(i) < 0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i) > 0. .and. qcond(i) < 0. .and. + & delq2(i) > rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i) > 0. .and. qevap(i) > 0.) then + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + rn(i) = rn(i) - .001 * qevap(i) * dp / g + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me == 31 .and. cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' deep delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +c +c precipitation rate converted to actual precip +c in unit of m instead of kg +c + do i = 1, im + if(cnvflg(i)) then +c +c in the event of upper level rain evaporation and lower level downdraft +c moistening, rn can become negative, in this case, we back out of the +c heating and the moistening +c + if(rn(i) < 0. .and. .not.flg(i)) rn(i) = 0. + if(rn(i) <= 0. .and. (.not. rain_ext(i))) then + rn(i) = 0. + else + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 1 + cldwrk(i) = aa1(i) + endif + endif + enddo +c +c convective cloud water +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (rn(i) > 0. .or. rain_ext(i))) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +c +c convective cloud cover +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (rn(i) > 0. .or. rain_ext(i))) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo + +c +c cloud water +c + if (ncloud > 0) then +! + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (rn(i) > 0. .or. rain_ext(i))) then +! if (k > kb(i) .and. k <= ktcon(i)) then + if (k >= kbcon(i) .and. k <= ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (ql(i,k,2) > -999.0) then + ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice + ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water + else + ql(i,k,1) = ql(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +c + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) <= 0. .and. (.not. rain_ext(i))) then + if (k <= kmax(i)) then + t1(i,k) = to(i,k) + q1(i,k) = qo(i,k) + u1(i,k) = uo(i,k) + v1(i,k) = vo(i,k) + endif + endif + enddo + enddo +! +! hchuang code change +! + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. (rn(i) > 0. .or. rain_ext(i))) then + if(k >= kb(i) .and. k < ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i) .and. (rn(i) > 0. .or. rain_ext(i))) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. (rn(i) > 0. .or. rain_ext(i))) then + if(k >= 1 .and. k <= jmin(i)) then + dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!! + return + end diff --git a/gsmphys/mfpbl.f b/gsmphys/mfpbl.f new file mode 100755 index 00000000..d534c1e2 --- /dev/null +++ b/gsmphys/mfpbl.f @@ -0,0 +1,392 @@ +!> \file mfpbl.f +!! This file contains the subroutine that calculates the updraft properties and mass flux for use in the Hybrid EDMF PBL scheme. + +!> \ingroup PBL +!! \brief This subroutine is used for calculating the mass flux and updraft properties. +!! +!! The mfpbl routines works as follows: if the PBL is convective, first, the ascending parcel entrainment rate is calculated as a function of height. Next, a surface parcel is initiated according to surface layer properties and the updraft buoyancy is calculated as a function of height. Next, using the buoyancy and entrainment values, the parcel vertical velocity is calculated using a well known steady-state budget equation. With the profile of updraft vertical velocity, the PBL height is recalculated as the height where the updraft vertical velocity returns to 0, and the entrainment profile is updated with the new PBL height. Finally, the mass flux profile is calculated using the updraft vertical velocity and assumed updraft fraction and the updraft properties are calculated using the updated entrainment profile, surface values, and environmental profiles. +!! \param[in] im number of used points +!! \param[in] ix horizontal dimension +!! \param[in] km vertical layer dimension +!! \param[in] ntrac number of tracers +!! \param[in] delt physics time step +!! \param[in] cnvflg flag to denote a strongly unstable (convective) PBL +!! \param[in] zl height of grid centers +!! \param[in] zm height of grid interfaces +!! \param[in] thvx virtual potential temperature at grid centers (\f$ K \f$) +!! \param[in] q1 layer mean tracer concentration (units?) +!! \param[in] t1 layer mean temperature (\f$ K \f$) +!! \param[in] u1 u component of layer wind (\f$ m s^{-1} \f$) +!! \param[in] v1 v component of layer wind (\f$ m s^{-1} \f$) +!! \param[in,out] hpbl PBL top height (m) +!! \param[in,out] kpbl PBL top index +!! \param[in] sflx total surface heat flux (units?) +!! \param[in] ustar surface friction velocity +!! \param[in] wstar convective velocity scale +!! \param[out] xmf updraft mass flux +!! \param[in,out] tcko updraft temperature (\f$ K \f$) +!! \param[in,out] qcko updraft tracer concentration (units?) +!! \param[in,out] ucko updraft u component of horizontal momentum (\f$ m s^{-1} \f$) +!! \param[in,out] vcko updraft v component of horizontal momentum (\f$ m s^{-1} \f$) +!! +!! \section general General Algorithm +!! -# Determine an updraft parcel's entrainment rate, buoyancy, and vertical velocity. +!! -# Recalculate the PBL height (previously calculated in moninedmf) and the parcel's entrainment rate. +!! -# Calculate the mass flux profile and updraft properties. +!! \section detailed Detailed Algorithm +!! @{ + subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg, & + & zl,zm,thvx,q1,t1,u1,v1,hpbl,kpbl, & + & sflx,ustar,wstar,xmf,tcko,qcko,ucko,vcko) +! + use machine , only : kind_phys + use physcons, grav => con_g, cp => con_cp +! + implicit none +! + integer im, ix, km, ntrac +! &, me + integer kpbl(im) + logical cnvflg(im) + real(kind=kind_phys) delt + real(kind=kind_phys) q1(ix,km,ntrac), t1(ix,km), & + & u1(ix,km), v1(ix,km), & + & thvx(im,km), & + & zl(im,km), zm(im,km+1), & + & hpbl(im), sflx(im), ustar(im), & + & wstar(im), xmf(im,km), & + & tcko(im,km),qcko(im,km,ntrac), & + & ucko(im,km),vcko(im,km) +! +c local variables and arrays +! + integer i, j, k, n, kmpbl +! + real(kind=kind_phys) dt2, dz, ce0, + & h1, factor, gocp, + & g, c1, d1, + & b1, f1, bb1, bb2, + & alp, a1, qmin, zfmin, + & xmmx, rbint, tau, +! & rbint, tau, + & tem, tem1, tem2, + & ptem, ptem1, ptem2, + & pgcon +! + real(kind=kind_phys) sigw1(im), usws3(im), xlamax(im), + & rbdn(im), rbup(im), delz(im) +! + real(kind=kind_phys) wu2(im,km), xlamue(im,km), + & thvu(im,km), zi(im,km), + & buo(im,km) +! + logical totflg, flg(im) +! +c physical parameters + parameter(g=grav) + parameter(gocp=g/cp) +! parameter(ce0=0.37,qmin=1.e-8,alp=1.0,pgcon=0.55) + parameter(ce0=0.38,qmin=1.e-8,alp=1.0,pgcon=0.55) + parameter(a1=0.08,b1=0.5,f1=0.15,c1=0.3,d1=2.58,tau=500.) + parameter(zfmin=1.e-8,h1=0.33333333) +! +c----------------------------------------------------------------------- +! +!************************************************************************ +! + kmpbl = km/2 + 1 + dt2 = delt +!> Since the mfpbl subroutine is called regardless of whether the PBL is convective, a check of the convective PBL flag is performed and the subroutine returns back to moninedmf (with the output variables set to the initialized values) if the PBL is not convective. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do k = 1, km + do i=1,im + if (cnvflg(i)) then + zi(i,k) = zm(i,k+1) + endif + enddo + enddo +!> ## Determine an updraft parcel's entrainment rate, buoyancy, and vertical velocity. +!! Calculate the entrainment rate according to equation 16 in Siebesma et al. (2007) \cite siebesma_et_al_2007 for all levels (xlamue) and a default entrainment rate (xlamax) for use above the PBL top. + do i=1,im + if(cnvflg(i)) then + k = kpbl(i) / 2 + k = max(k, 1) + delz(i) = zl(i,k+1) - zl(i,k) + xlamax(i) = ce0 / delz(i) + endif + enddo + do k = 1, kmpbl + do i=1,im + if(cnvflg(i)) then + if(k < kpbl(i)) then + ptem = 1./(zi(i,k)+delz(i)) + tem = max((hpbl(i)-zi(i,k)+delz(i)) ,delz(i)) + ptem1 = 1./tem + xlamue(i,k) = ce0 * (ptem+ptem1) + else + xlamue(i,k) = xlamax(i) + endif + endif + enddo + enddo +c +c compute thermal excess +c +!> Using equations 17 and 7 from Siebesma et al (2007) \cite siebesma_et_al_2007 along with \f$u_*\f$, \f$w_*\f$, and the previously diagnosed PBL height, the initial \f$\theta_v\f$ of the updraft (and its surface buoyancy) is calculated. + do i=1,im + if(cnvflg(i)) then + tem = zl(i,1)/hpbl(i) + usws3(i) = (ustar(i)/wstar(i))**3. + tem1 = usws3(i) + 0.6*tem + tem2 = max((1.-tem), zfmin) + ptem = (tem1**h1) * sqrt(tem2) + sigw1(i) = 1.3 * ptem * wstar(i) + ptem1 = alp * sflx(i) / sigw1(i) + thvu(i,1) = thvx(i,1) + ptem1 + buo(i,1) = g * (thvu(i,1)/thvx(i,1)-1.) + endif + enddo +c +c compute potential temperature and buoyancy for updraft air parcel +c +!> From the second level to the middle of the vertical domain, the updraft virtual potential temperature is calculated using the entraining updraft equation as in equation 10 of Siebesma et al (2007) \cite siebesma_et_al_2007, discretized as +!! \f[ +!! \frac{\theta_{v,u}^k - \theta_{v,u}^{k-1}}{\Delta z}=-\epsilon^{k-1}\left[\frac{1}{2}\left(\theta_{v,u}^k + \theta_{v,u}^{k-1}\right)-\frac{1}{2}\left(\overline{\theta_{v}}^k + \overline{\theta_v}^{k-1}\right)\right] +!! \f] +!! where the superscript \f$k\f$ denotes model level, and subscript \f$u\f$ denotes an updraft property, and the overbar denotes the grid-scale mean value. + do k = 2, kmpbl + do i=1,im + if(cnvflg(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = xlamue(i,k-1) * dz + ptem = 2. + tem + ptem1 = (2. - tem) / ptem + tem1 = tem * (thvx(i,k)+thvx(i,k-1)) / ptem + thvu(i,k) = ptem1 * thvu(i,k-1) + tem1 + buo(i,k) = g * (thvu(i,k)/thvx(i,k)-1.) + endif + enddo + enddo +c +c compute updraft velocity square(wu2) +c +!> Rather than use the vertical velocity equation given as equation 15 in Siebesma et al (2007) \cite siebesma_et_al_2007 (which parameterizes the pressure term in terms of the updraft vertical velocity itself), this scheme uses the more widely used form of the steady state vertical velocity equation given as equation 6 in Soares et al. (2004) \cite soares_et_al_2004 discretized as +!! \f[ +!! \frac{w_{u,k}^2 - w_{u,k-1}^2}{\Delta z} = -2b_1\frac{1}{2}\left(\epsilon_k + \epsilon_{k-1}\right)\frac{1}{2}\left(w_{u,k}^2 + w_{u,k-1}^2\right) + 2b_2B +!! \f] +!! The constants used in the scheme are labeled \f$bb1 = 2b_1\f$ and \f$bb2 = 2b_2\f$ and are tuned to be equal to 1.8 and 3.5, respectively, close to the values proposed by Soares et al. (2004) \cite soares_et_al_2004 . +! tem = 1.-2.*f1 +! bb1 = 2. * b1 / tem +! bb2 = 2. / tem +! from soares et al. (2004,qjrms) +! bb1 = 2. +! bb2 = 4. +! +! from bretherton et al. (2004, mwr) +! bb1 = 4. +! bb2 = 2. +! +! from our tuning + bb1 = 1.8 + bb2 = 3.5 +! + do i = 1, im + if(cnvflg(i)) then +! +! tem = zi(i,1)/hpbl(i) +! tem1 = usws3(i) + 0.6*tem +! tem2 = max((1.-tem), zfmin) +! ptem = (tem1**h1) * sqrt(tem2) +! ptem1 = 1.3 * ptem * wstar(i) +! wu2(i,1) = d1*d1*ptem1*ptem1 +! + dz = zi(i,1) + tem = 0.5*bb1*xlamue(i,1)*dz + tem1 = bb2 * buo(i,1) * dz + ptem1 = 1. + tem + wu2(i,1) = tem1 / ptem1 +! + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(cnvflg(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25*bb1*(xlamue(i,k)+xlamue(i,k-1))*dz + tem1 = bb2 * buo(i,k) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + endif + enddo + enddo +c +c update pbl height as the height where updraft velocity vanishes +c +!> ## Recalculate the PBL height and the parcel's entrainment rate. +!! Find the level where the updraft vertical velocity is less than zero and linearly interpolate to find the height where it would be exactly zero. Set the PBL height to this determined height. + do i=1,im + flg(i) = .true. + if(cnvflg(i)) then + flg(i) = .false. + rbup(i) = wu2(i,1) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + rbup(i) = wu2(i,k) + kpbl(i) = k + flg(i) = rbup(i).le.0. + endif + enddo + enddo + do i = 1,im + if(cnvflg(i)) then + k = kpbl(i) + if(rbdn(i) <= 0.) then + rbint = 0. + elseif(rbup(i) >= 0.) then + rbint = 1. + else + rbint = rbdn(i)/(rbdn(i)-rbup(i)) + endif + hpbl(i) = zi(i,k-1) + rbint*(zi(i,k)-zi(i,k-1)) + endif + enddo +c +!> Recalculate the entrainment rate as before except use the updated value of the PBL height. + do i=1,im + if(cnvflg(i)) then + k = kpbl(i) / 2 + k = max(k, 1) + delz(i) = zl(i,k+1) - zl(i,k) + xlamax(i) = ce0 / delz(i) + endif + enddo +c +c update entrainment rate +c +! do k = 1, kmpbl +! do i=1,im +! if(cnvflg(i)) then +! if(k < kpbl(i)) then +! tem = tau * sqrt(wu2(i,k)) +! tem1 = 1. / tem +! ptem = ce0 / zi(i,k) +! xlamue(i,k) = max(tem1, ptem) +! else +! xlamue(i,k) = xlamax(i) +! endif +! endif +! enddo +! enddo +! + do k = 1, kmpbl + do i=1,im + if(cnvflg(i)) then + if(k < kpbl(i)) then + ptem = 1./(zi(i,k)+delz(i)) + tem = max((hpbl(i)-zi(i,k)+delz(i)) ,delz(i)) + ptem1 = 1./tem + xlamue(i,k) = ce0 * (ptem+ptem1) + else + xlamue(i,k) = xlamax(i) + endif + endif + enddo + enddo +c +c updraft mass flux as a function of sigmaw +c (0.3*sigmaw[square root of vertical turbulence variance]) +c +!> ## Calculate the mass flux profile and updraft properties. +! do k = 1, kmpbl +! do i=1,im +! if(cnvflg(i) .and. k < kpbl(i)) then +! tem = zi(i,k)/hpbl(i) +! tem1 = usws3(i) + 0.6*tem +! tem2 = max((1.-tem), zfmin) +! ptem = (tem1**h1) * sqrt(tem2) +! ptem1 = 1.3 * ptem * wstar(i) +! xmf(i,k) = c1 * ptem1 +! endif +! enddo +! enddo +c +c updraft mass flux as a function of updraft velocity profile +c +!> Calculate the mass flux: +!! \f[ +!! M = a_uw_u +!! \f] +!! where \f$a_u\f$ is the tunable parameter that represents the fractional area of updrafts (currently set to 0.08). Limit the computed mass flux to be less than \f$\frac{\Delta z}{\Delta t}\f$. This is different than what is done in Siebesma et al. (2007) \cite siebesma_et_al_2007 where the mass flux is the product of a tunable constant and the diagnosed standard deviation of \f$w\f$. + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + xmf(i,k) = a1 * sqrt(wu2(i,k)) + dz = zl(i,k+1) - zl(i,k) + xmmx = dz / dt2 + xmf(i,k) = min(xmf(i,k),xmmx) + endif + enddo + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c compute updraft property +c +!> The updraft properties are calculated according to the entraining updraft equation +!! \f[ +!! \frac{\partial \phi}{\partial z}=-\epsilon\left(\phi_u - \overline{\phi}\right) +!! \f] +!! where \f$\phi\f$ is \f$T\f$ or \f$q\f$. The equation is discretized according to +!! \f[ +!! \frac{\phi_{u,k} - \phi_{u,k-1}}{\Delta z}=-\epsilon_{k-1}\left[\frac{1}{2}\left(\phi_{u,k} + \phi_{u,k-1}\right)-\frac{1}{2}\left(\overline{\phi}_k + \overline{\phi}_{k-1}\right)\right] +!! \f] +!! The exception is for the horizontal momentum components, which have been modified to account for the updraft-induced pressure gradient force, and use the following equation, following Han and Pan (2006) \cite han_and_pan_2006 +!! \f[ +!! \frac{\partial v}{\partial z} = -\epsilon\left(v_u - \overline{v}\right)+d_1\frac{\partial \overline{v}}{\partial z} +!! \f] +!! where \f$d_1=0.55\f$ is a tunable constant. + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon +! + tcko(i,k) = ((1.-tem)*tcko(i,k-1)+tem* + & (t1(i,k)+t1(i,k-1))-gocp*dz)/factor + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*u1(i,k) + & +ptem1*u1(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*v1(i,k) + & +ptem1*v1(i,k-1))/factor + endif + enddo + enddo + do n = 1, ntrac + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem + + qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* + & (q1(i,k,n)+q1(i,k-1,n)))/factor + endif + enddo + enddo + enddo +! + return + end +!> @} diff --git a/gsmphys/mfpblt.f b/gsmphys/mfpblt.f new file mode 100644 index 00000000..3a09ad13 --- /dev/null +++ b/gsmphys/mfpblt.f @@ -0,0 +1,440 @@ + subroutine mfpblt(im,ix,km,kmpbl,ntcw,ntrac1,delt, + & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, + & gdx,hpbl,kpbl,vpert,buo,xmf, + & tcko,qcko,ucko,vcko,xlamue) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp + &, rv => con_rv, hvap => con_hvap + &, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 +! + implicit none +! + integer im, ix, km, kmpbl, ntcw, ntrac1 +! &, me + integer kpbl(im) + logical cnvflg(im) + real(kind=kind_phys) delt + real(kind=kind_phys) q1(ix,km,ntrac1), + & t1(ix,km), u1(ix,km), v1(ix,km), + & plyr(im,km),pix(im,km),thlx(im,km), + & thvx(im,km),zl(im,km), zm(im,km), + & gdx(im), + & hpbl(im), vpert(im), + & buo(im,km), xmf(im,km), + & tcko(im,km),qcko(im,km,ntrac1), + & ucko(im,km),vcko(im,km), + & xlamue(im,km-1) +! +c local variables and arrays +! + integer i, j, k, n, ndc + integer kpblx(im), kpbly(im) +! + real(kind=kind_phys) dt2, dz, ce0, cm, + & factor, gocp, + & g, b1, f1, + & bb1, bb2, + & alp, a1, pgcon, + & qmin, qlmin, xmmx, rbint, + & tem, tem1, tem2, + & ptem, ptem1, ptem2 +! + real(kind=kind_phys) elocp, el2orc, qs, es, + & tlu, gamma, qlu, + & thup, thvu, dq +! + real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), + & xlamuem(im,km-1) +! + real(kind=kind_phys) wu2(im,km), thlu(im,km), + & qtx(im,km), qtu(im,km) +! + real(kind=kind_phys) xlamavg(im), sigma(im), + & scaldfunc(im), sumx(im) +! + logical totflg, flg(im) +! +! physical parameters + parameter(g=grav) + parameter(gocp=g/cp) + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) + parameter(ce0=0.4,cm=1.0) + parameter(qmin=1.e-8,qlmin=1.e-12) + parameter(alp=1.0,pgcon=0.55) + parameter(a1=0.13,b1=0.5,f1=0.15) +! +!************************************************************************ +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +! + dt2 = delt +!! + do k = 1, km + do i=1,im + if (cnvflg(i)) then + buo(i,k) = 0. + wu2(i,k) = 0. + qtx(i,k) = q1(i,k,1) + q1(i,k,ntcw) + endif + enddo + enddo +! +! compute thermal excess +! + do i=1,im + if(cnvflg(i)) then + ptem = alp * vpert(i) + ptem = min(ptem, 3.0) + thlu(i,1)= thlx(i,1) + ptem + qtu(i,1) = qtx(i,1) + buo(i,1) = g * ptem / thvx(i,1) + endif + enddo +! +! compute entrainment rate +! + do k = 1, kmpbl + do i=1,im + if(cnvflg(i)) then + dz = zl(i,k+1) - zl(i,k) + if(k < kpbl(i)) then + ptem = 1./(zm(i,k)+dz) + tem = max((hpbl(i)-zm(i,k)+dz) ,dz) + ptem1 = 1./tem + xlamue(i,k) = ce0 * (ptem+ptem1) + else + xlamue(i,k) = ce0 / dz + endif + xlamuem(i,k) = cm * xlamue(i,k) + endif + enddo + enddo +! +! compute buoyancy for updraft air parcel +! + do k = 2, kmpbl + do i=1,im + if(cnvflg(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* + & (thlx(i,k-1)+thlx(i,k)))/factor + qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* + & (qtx(i,k-1)+qtx(i,k)))/factor +! + tlu = thlu(i,k) / pix(i,k) + es = 0.01 * fpvs(tlu) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtu(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tlu**2) + qlu = dq / (1. + gamma) + qtu(i,k) = qs + qlu + tem1 = 1. + fv * qs - qlu + thup = thlu(i,k) + pix(i,k) * elocp * qlu + thvu = thup * tem1 + else + tem1 = 1. + fv * qtu(i,k) + thvu = thlu(i,k) * tem1 + endif + buo(i,k) = g * (thvu / thvx(i,k) - 1.) +! + endif + enddo + enddo +! +! compute updraft velocity square(wu2) +! +! tem = 1.-2.*f1 +! bb1 = 2. * b1 / tem +! bb2 = 2. / tem +! from Soares et al. (2004,QJRMS) +! bb1 = 2. +! bb2 = 4. +! +! from Bretherton et al. (2004, MWR) +! bb1 = 4. +! bb2 = 2. +! +! from our tuning + bb1 = 2.0 + bb2 = 4.0 +! + do i = 1, im + if(cnvflg(i)) then + dz = zm(i,1) + tem = 0.5*bb1*xlamue(i,1)*dz + tem1 = bb2 * buo(i,1) * dz + ptem1 = 1. + tem + wu2(i,1) = tem1 / ptem1 + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(cnvflg(i)) then + dz = zm(i,k) - zm(i,k-1) + tem = 0.25*bb1*(xlamue(i,k)+xlamue(i,k-1))*dz + tem1 = bb2 * buo(i,k) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + endif + enddo + enddo +! +! update pbl height as the height where updraft velocity vanishes +! + do i=1,im + flg(i) = .true. + kpbly(i) = kpbl(i) + if(cnvflg(i)) then + flg(i) = .false. + rbup(i) = wu2(i,1) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + rbup(i) = wu2(i,k) + kpblx(i)= k + flg(i) = rbup(i).le.0. + endif + enddo + enddo + do i = 1,im + if(cnvflg(i)) then + k = kpblx(i) + if(rbdn(i) <= 0.) then + rbint = 0. + elseif(rbup(i) >= 0.) then + rbint = 1. + else + rbint = rbdn(i)/(rbdn(i)-rbup(i)) + endif + hpblx(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) + endif + enddo +! + do i = 1,im + if(cnvflg(i)) then + if(kpbl(i) > kpblx(i)) then + kpbl(i) = kpblx(i) + hpbl(i) = hpblx(i) + endif + endif + enddo +! +! update entrainment rate +! + do k = 1, kmpbl + do i=1,im + if(cnvflg(i) .and. kpbly(i) > kpblx(i)) then + dz = zl(i,k+1) - zl(i,k) + if(k < kpbl(i)) then + ptem = 1./(zm(i,k)+dz) + tem = max((hpbl(i)-zm(i,k)+dz) ,dz) + ptem1 = 1./tem + xlamue(i,k) = ce0 * (ptem+ptem1) + else + xlamue(i,k) = ce0 / dz + endif + xlamuem(i,k) = cm * xlamue(i,k) + endif + enddo + enddo +! +! compute entrainment rate averaged over the whole pbl +! + do i = 1, im + xlamavg(i) = 0. + sumx(i) = 0. + enddo + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + dz = zl(i,k+1) - zl(i,k) + xlamavg(i) = xlamavg(i) + xlamue(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + xlamavg(i) = xlamavg(i) / sumx(i) + endif + enddo +! +! updraft mass flux as a function of updraft velocity profile +! + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + if(wu2(i,k) > 0.) then + tem = sqrt(wu2(i,k)) + else + tem = 0. + endif + xmf(i,k) = a1 * tem + endif + enddo + enddo +! +!--- compute updraft fraction as a function of mean entrainment rate +! (Grell & Freitas, 2014) +! + do i = 1, im + if(cnvflg(i)) then + tem = 0.2 / xlamavg(i) + tem1 = 3.14 * tem * tem + sigma(i) = tem1 / (gdx(i) * gdx(i)) + sigma(i) = max(sigma(i), 0.001) + sigma(i) = min(sigma(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! + do i = 1, im + if(cnvflg(i)) then + if (sigma(i) > a1) then + scaldfunc(i) = (1.-sigma(i)) * (1.-sigma(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + endif + enddo +! +! final scale-aware updraft mass flux +! + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + xmf(i,k) = scaldfunc(i) * xmf(i,k) + dz = zl(i,k+1) - zl(i,k) + xmmx = dz / dt2 + xmf(i,k) = min(xmf(i,k),xmmx) + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute updraft property using updated entranment rate +! + do i=1,im + if(cnvflg(i)) then + thlu(i,1)= thlx(i,1) + endif + enddo +! +! do i=1,im +! if(cnvflg(i)) then +! ptem1 = max(qcko(i,1,ntcw), 0.) +! tlu = thlu(i,1) / pix(i,1) +! tcko(i,1) = tlu + elocp * ptem1 +! endif +! enddo +! + do k = 2, kmpbl + do i=1,im + if(cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* + & (thlx(i,k-1)+thlx(i,k)))/factor + qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* + & (qtx(i,k-1)+qtx(i,k)))/factor +! + tlu = thlu(i,k) / pix(i,k) + es = 0.01 * fpvs(tlu) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtu(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tlu**2) + qlu = dq / (1. + gamma) + qtu(i,k) = qs + qlu + qcko(i,k,1) = qs + qcko(i,k,ntcw) = qlu + tcko(i,k) = tlu + elocp * qlu + else + qcko(i,k,1) = qtu(i,k) + qcko(i,k,ntcw) = 0. + tcko(i,k) = tlu + endif +! + endif + enddo + enddo +! + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamuem(i,k-1) * dz + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*u1(i,k) + & +ptem1*u1(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*v1(i,k) + & +ptem1*v1(i,k-1))/factor + endif + enddo + enddo +! + if(ntcw > 2) then +! + do n = 2, ntcw-1 + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* + & (q1(i,k,n)+q1(i,k-1,n)))/factor + endif + enddo + enddo + enddo +! + endif +! + ndc = ntrac1 - ntcw +! + if(ndc > 0) then +! + do n = ntcw+1, ntrac1 + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* + & (q1(i,k,n)+q1(i,k-1,n)))/factor + endif + enddo + enddo + enddo +! + endif +! + return + end diff --git a/gsmphys/mfpbltq.f b/gsmphys/mfpbltq.f new file mode 100644 index 00000000..a95a1a01 --- /dev/null +++ b/gsmphys/mfpbltq.f @@ -0,0 +1,457 @@ + subroutine mfpbltq(im,ix,km,kmpbl,ntcw,ntrac1,delt, + & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, + & gdx,hpbl,kpbl,vpert,buo,xmf, + & tcko,qcko,ucko,vcko,xlamue,a1) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp + &, rv => con_rv, hvap => con_hvap + &, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 +! + implicit none +! + integer im, ix, km, kmpbl, ntcw, ntrac1 +! &, me + integer kpbl(im) + logical cnvflg(im) + real(kind=kind_phys) delt + real(kind=kind_phys) q1(ix,km,ntrac1), + & t1(ix,km), u1(ix,km), v1(ix,km), + & plyr(im,km),pix(im,km),thlx(im,km), + & thvx(im,km),zl(im,km), zm(im,km), + & gdx(im), hpbl(im), vpert(im), + & buo(im,km), xmf(im,km), + & tcko(im,km),qcko(im,km,ntrac1), + & ucko(im,km),vcko(im,km), + & xlamue(im,km-1) +! +c local variables and arrays +! + integer i, j, k, n, ndc + integer kpblx(im), kpbly(im) +! + real(kind=kind_phys) dt2, dz, ce0, cm, + & factor, gocp, + & g, b1, f1, + & bb1, bb2, + & alp, vprtmax, a1, pgcon, + & qmin, qlmin, xmmx, rbint, + & tem, tem1, tem2, + & ptem, ptem1, ptem2 +! + real(kind=kind_phys) elocp, el2orc, qs, es, + & tlu, gamma, qlu, + & thup, thvu, dq +! + real(kind=kind_phys) rbdn(im), rbup(im), hpblx(im), + & xlamuem(im,km-1) + real(kind=kind_phys) delz(im), xlamax(im) +! + real(kind=kind_phys) wu2(im,km), thlu(im,km), + & qtx(im,km), qtu(im,km) +! + real(kind=kind_phys) xlamavg(im), sigma(im), + & scaldfunc(im), sumx(im) +! + logical totflg, flg(im) +! +! physical parameters + parameter(g=grav) + parameter(gocp=g/cp) + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) + parameter(ce0=0.4,cm=1.0) + parameter(qmin=1.e-8,qlmin=1.e-12) + parameter(alp=1.5,vprtmax=3.0,pgcon=0.55) + parameter(b1=0.5,f1=0.15) +! +!************************************************************************ +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! + dt2 = delt +! + do k = 1, km + do i=1,im + if (cnvflg(i)) then + buo(i,k) = 0. + wu2(i,k) = 0. + qtx(i,k) = q1(i,k,1) + q1(i,k,ntcw) + endif + enddo + enddo +! +! compute thermal excess +! + do i=1,im + if(cnvflg(i)) then + ptem = alp * vpert(i) + ptem = min(ptem, vprtmax) + thlu(i,1)= thlx(i,1) + ptem + qtu(i,1) = qtx(i,1) + buo(i,1) = g * ptem / thvx(i,1) + endif + enddo +! +! compute entrainment rate +! + do i=1,im + if(cnvflg(i)) then + k = kpbl(i) / 2 + k = max(k, 1) + delz(i) = zl(i,k+1) - zl(i,k) + xlamax(i) = ce0 / delz(i) + endif + enddo +! + do k = 1, kmpbl + do i=1,im + if(cnvflg(i)) then + if(k < kpbl(i)) then + ptem = 1./(zm(i,k)+delz(i)) + tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) + ptem1 = 1./tem + xlamue(i,k) = ce0 * (ptem+ptem1) + else + xlamue(i,k) = xlamax(i) + endif +! + xlamuem(i,k) = cm * xlamue(i,k) + endif + enddo + enddo +! +! compute buoyancy for updraft air parcel +! + do k = 2, kmpbl + do i=1,im + if(cnvflg(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* + & (thlx(i,k-1)+thlx(i,k)))/factor + qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* + & (qtx(i,k-1)+qtx(i,k)))/factor +! + tlu = thlu(i,k) / pix(i,k) + es = 0.01 * fpvs(tlu) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtu(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tlu**2) + qlu = dq / (1. + gamma) + qtu(i,k) = qs + qlu + tem1 = 1. + fv * qs - qlu + thup = thlu(i,k) + pix(i,k) * elocp * qlu + thvu = thup * tem1 + else + tem1 = 1. + fv * qtu(i,k) + thvu = thlu(i,k) * tem1 + endif + buo(i,k) = g * (thvu / thvx(i,k) - 1.) +! + endif + enddo + enddo +! +! compute updraft velocity square(wu2) +! +! tem = 1.-2.*f1 +! bb1 = 2. * b1 / tem +! bb2 = 2. / tem +! from Soares et al. (2004,QJRMS) +! bb1 = 2. +! bb2 = 4. +! +! from Bretherton et al. (2004, MWR) +! bb1 = 4. +! bb2 = 2. +! +! from our tuning + bb1 = 2.0 + bb2 = 4.0 +! + do i = 1, im + if(cnvflg(i)) then + dz = zm(i,1) + tem = 0.5*bb1*xlamue(i,1)*dz + tem1 = bb2 * buo(i,1) * dz + ptem1 = 1. + tem + wu2(i,1) = tem1 / ptem1 + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(cnvflg(i)) then + dz = zm(i,k) - zm(i,k-1) + tem = 0.25*bb1*(xlamue(i,k)+xlamue(i,k-1))*dz + tem1 = bb2 * buo(i,k) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + endif + enddo + enddo +! +! update pbl height as the height where updraft velocity vanishes +! + do i=1,im + flg(i) = .true. + kpblx(i) = 1 + kpbly(i) = kpbl(i) + if(cnvflg(i)) then + flg(i) = .false. + rbup(i) = wu2(i,1) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + rbup(i) = wu2(i,k) + kpblx(i)= k + flg(i) = rbup(i).le.0. + endif + enddo + enddo + do i = 1,im + if(cnvflg(i)) then + k = kpblx(i) + if(rbdn(i) <= 0.) then + rbint = 0. + elseif(rbup(i) >= 0.) then + rbint = 1. + else + rbint = rbdn(i)/(rbdn(i)-rbup(i)) + endif + hpblx(i) = zm(i,k-1) + rbint*(zm(i,k)-zm(i,k-1)) + endif + enddo +! + do i = 1,im + if(cnvflg(i)) then + if(kpblx(i) < kpbl(i)) then + kpbl(i) = kpblx(i) + hpbl(i) = hpblx(i) + endif + if(kpbl(i) <= 1) cnvflg(i)=.false. + endif + enddo +! +! update entrainment rate +! + do i=1,im + if(cnvflg(i)) then + k = kpbl(i) / 2 + k = max(k, 1) + delz(i) = zl(i,k+1) - zl(i,k) + xlamax(i) = ce0 / delz(i) + endif + enddo +! + do k = 1, kmpbl + do i=1,im + if(cnvflg(i) .and. kpblx(i) < kpbly(i)) then +! if(cnvflg(i)) then + if(k < kpbl(i)) then + ptem = 1./(zm(i,k)+delz(i)) + tem = max((hpbl(i)-zm(i,k)+delz(i)) ,delz(i)) + ptem1 = 1./tem + xlamue(i,k) = ce0 * (ptem+ptem1) + else + xlamue(i,k) = xlamax(i) + endif +! + xlamuem(i,k) = cm * xlamue(i,k) + endif + enddo + enddo +! +! compute entrainment rate averaged over the whole pbl +! + do i = 1, im + xlamavg(i) = 0. + sumx(i) = 0. + enddo + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + dz = zl(i,k+1) - zl(i,k) + xlamavg(i) = xlamavg(i) + xlamue(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + xlamavg(i) = xlamavg(i) / sumx(i) + endif + enddo +! +! updraft mass flux as a function of updraft velocity profile +! + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + xmf(i,k) = a1 * sqrt(wu2(i,k)) + endif + enddo + enddo +! +!--- compute updraft fraction as a function of mean entrainment rate +! (Grell & Freitas, 2014) +! + do i = 1, im + if(cnvflg(i)) then + tem = 0.2 / xlamavg(i) + tem1 = 3.14 * tem * tem + sigma(i) = tem1 / (gdx(i) * gdx(i)) + sigma(i) = max(sigma(i), 0.001) + sigma(i) = min(sigma(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! + do i = 1, im + if(cnvflg(i)) then + if (sigma(i) > a1) then + scaldfunc(i) = (1.-sigma(i)) * (1.-sigma(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + endif + enddo +! +! final scale-aware updraft mass flux +! + do k = 1, kmpbl + do i = 1, im + if (cnvflg(i) .and. k < kpbl(i)) then + xmf(i,k) = scaldfunc(i) * xmf(i,k) + dz = zl(i,k+1) - zl(i,k) + xmmx = dz / dt2 + xmf(i,k) = min(xmf(i,k),xmmx) + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute updraft property using updated entranment rate +! + do i=1,im + if(cnvflg(i)) then + thlu(i,1)= thlx(i,1) + endif + enddo +! +! do i=1,im +! if(cnvflg(i)) then +! ptem1 = max(qcko(i,1,ntcw), 0.) +! tlu = thlu(i,1) / pix(i,1) +! tcko(i,1) = tlu + elocp * ptem1 +! endif +! enddo +! + do k = 2, kmpbl + do i=1,im + if(cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + thlu(i,k) = ((1.-tem)*thlu(i,k-1)+tem* + & (thlx(i,k-1)+thlx(i,k)))/factor + qtu(i,k) = ((1.-tem)*qtu(i,k-1)+tem* + & (qtx(i,k-1)+qtx(i,k)))/factor +! + tlu = thlu(i,k) / pix(i,k) + es = 0.01 * fpvs(tlu) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtu(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tlu**2) + qlu = dq / (1. + gamma) + qtu(i,k) = qs + qlu + qcko(i,k,1) = qs + qcko(i,k,ntcw) = qlu + tcko(i,k) = tlu + elocp * qlu + else + qcko(i,k,1) = qtu(i,k) + qcko(i,k,ntcw) = 0. + tcko(i,k) = tlu + endif +! + endif + enddo + enddo +! + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamuem(i,k-1) * dz + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*u1(i,k) + & +ptem1*u1(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*v1(i,k) + & +ptem1*v1(i,k-1))/factor + endif + enddo + enddo +! + if(ntcw > 2) then +! + do n = 2, ntcw-1 + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* + & (q1(i,k,n)+q1(i,k-1,n)))/factor + endif + enddo + enddo + enddo +! + endif +! + ndc = ntrac1 - ntcw +! + if(ndc > 0) then +! + do n = ntcw+1, ntrac1 + do k = 2, kmpbl + do i = 1, im + if (cnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! + qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem* + & (q1(i,k,n)+q1(i,k-1,n)))/factor + endif + enddo + enddo + enddo +! + endif +! + return + end diff --git a/gsmphys/mfscu.f b/gsmphys/mfscu.f new file mode 100644 index 00000000..692950bd --- /dev/null +++ b/gsmphys/mfscu.f @@ -0,0 +1,545 @@ + subroutine mfscu(im,ix,km,kmscu,ntcw,ntrac1,delt, + & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, + & thlx,thvx,thlvx,gdx,thetae,radj, + & krad,mrad,radmin,buo,xmfd, + & tcdo,qcdo,ucdo,vcdo,xlamde) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp + &, rv => con_rv, hvap => con_hvap + &, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 +! + implicit none +! + integer im, ix, km, kmscu, ntcw, ntrac1 +! &, me + integer krad(im), mrad(im) +! + logical cnvflg(im) + real(kind=kind_phys) delt + real(kind=kind_phys) q1(ix,km,ntrac1),t1(ix,km), + & u1(ix,km), v1(ix,km), + & plyr(im,km), pix(im,km), + & thlx(im,km), + & thvx(im,km), thlvx(im,km), + & gdx(im), radj(im), + & zl(im,km), zm(im,km), + & thetae(im,km), radmin(im), + & buo(im,km), xmfd(im,km), + & tcdo(im,km), qcdo(im,km,ntrac1), + & ucdo(im,km), vcdo(im,km), + & xlamde(im,km-1) +! +! local variables and arrays +! +! + integer i,j,indx, k, n, kk, ndc + integer krad1(im), mradx(im), mrady(im) +! + real(kind=kind_phys) dt2, dz, ce0, cm, + & gocp, factor, g, tau, + & b1, f1, bb1, bb2, + & a1, a2, a11, a22, + & cteit, pgcon, + & qmin, qlmin, + & xmmx, tem, tem1, tem2, + & ptem, ptem1, ptem2 +! + real(kind=kind_phys) elocp, el2orc, qs, es, + & tld, gamma, qld, thdn, + & thvd, dq +! + real(kind=kind_phys) wd2(im,km), thld(im,km), + & qtx(im,km), qtd(im,km), + & thlvd(im), hrad(im), + & xlamdem(im,km-1), ra1(im), ra2(im) +! + real(kind=kind_phys) xlamavg(im), sigma(im), + & scaldfunc(im), sumx(im) +! + logical totflg, flg(im) +! + real(kind=kind_phys) actei, cldtime +! +c physical parameters + parameter(g=grav) + parameter(gocp=g/cp) + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) + parameter(ce0=0.4,cm=1.0,pgcon=0.55) + parameter(qmin=1.e-8,qlmin=1.e-12) + parameter(b1=0.45,f1=0.15) + parameter(a1=0.12,a2=0.5) + parameter(a11=0.2,a22=1.0) + parameter(cldtime=500.) + parameter(actei = 0.7) +! parameter(actei = 0.23) +! +!************************************************************************ +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +! + dt2 = delt +!! + do k = 1, km + do i=1,im + if(cnvflg(i)) then + buo(i,k) = 0. + wd2(i,k) = 0. + qtx(i,k) = q1(i,k,1) + q1(i,k,ntcw) + endif + enddo + enddo +! + do i = 1, im + if(cnvflg(i)) then + hrad(i) = zm(i,krad(i)) + krad1(i) = krad(i)-1 + endif + enddo +! + do i = 1, im + if(cnvflg(i)) then + k = krad(i) + tem = zm(i,k+1)-zm(i,k) + tem1 = cldtime*radmin(i)/tem + tem1 = max(tem1, -3.0) + thld(i,k)= thlx(i,k) + tem1 + qtd(i,k) = qtx(i,k) + thlvd(i) = thlvx(i,k) + tem1 + buo(i,k) = - g * tem1 / thvx(i,k) + endif + enddo +! +! specify downdraft fraction +! + do i=1,im + if(cnvflg(i)) then + ra1(i) = a1 + ra2(i) = a11 + endif + enddo +! +! if the condition for cloud-top instability is met, +! increase downdraft fraction +! + do i = 1, im + if(cnvflg(i)) then + k = krad(i) + tem = thetae(i,k) - thetae(i,k+1) + tem1 = qtx(i,k) - qtx(i,k+1) + if (tem > 0. .and. tem1 > 0.) then + cteit= cp*tem/(hvap*tem1) + if(cteit > actei) then + ra1(i) = a2 + ra2(i) = a22 + endif + endif + endif + enddo +! +! compute radiative flux jump at stratocumulus top +! + do i = 1, im + if(cnvflg(i)) then + radj(i) = -ra2(i) * radmin(i) + endif + enddo +! +! first-quess level of downdraft extension (mrad) +! + do i = 1, im + flg(i) = cnvflg(i) + mrad(i) = krad(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k < krad(i)) then + if(thlvd(i) <= thlvx(i,k)) then + mrad(i) = k + else + flg(i)=.false. + endif + endif + enddo + enddo + do i=1,im + if (cnvflg(i)) then + kk = krad(i)-mrad(i) + if(kk < 1) cnvflg(i)=.false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! compute entrainment rate +! + do k = 1, kmscu + do i=1,im + if(cnvflg(i)) then + dz = zl(i,k+1) - zl(i,k) + if(k >= mrad(i) .and. k < krad(i)) then + if(mrad(i) == 1) then + ptem = 1./(zm(i,k)+dz) + else + ptem = 1./(zm(i,k)-zm(i,mrad(i)-1)+dz) + endif + tem = max((hrad(i)-zm(i,k)+dz) ,dz) + ptem1 = 1./tem + xlamde(i,k) = ce0 * (ptem+ptem1) + else + xlamde(i,k) = ce0 / dz + endif + xlamdem(i,k) = cm * xlamde(i,k) + endif + enddo + enddo +! +! compute buoyancy for downdraft air parcel +! + do k = kmscu,1,-1 + do i=1,im + if(cnvflg(i) .and. k < krad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* + & (thlx(i,k)+thlx(i,k+1)))/factor + qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* + & (qtx(i,k)+qtx(i,k+1)))/factor +! + tld = thld(i,k) / pix(i,k) + es = 0.01 * fpvs(tld) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtd(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tld**2) + qld = dq / (1. + gamma) + qtd(i,k) = qs + qld + tem1 = 1. + fv * qs - qld + thdn = thld(i,k) + pix(i,k) * elocp * qld + thvd = thdn * tem1 + else + tem1 = 1. + fv * qtd(i,k) + thvd = thld(i,k) * tem1 + endif + buo(i,k) = g * (1. - thvd / thvx(i,k)) +! + endif + enddo + enddo +! +! compute downdraft velocity square(wd2) +! +! tem = 1.-2.*f1 +! bb1 = 2. * b1 / tem +! bb2 = 2. / tem +! from Soares et al. (2004,QJRMS) +! bb1 = 2. +! bb2 = 4. +! +! from Bretherton et al. (2004, MWR) +! bb1 = 4. +! bb2 = 2. +! +! from our tuning + bb1 = 2.0 + bb2 = 4.0 +! + do i = 1, im + if(cnvflg(i)) then + k = krad1(i) + dz = zm(i,k+1) - zm(i,k) +! tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz + tem = 0.5*bb1*xlamde(i,k)*dz + tem1 = bb2 * buo(i,k+1) * dz + ptem1 = 1. + tem + wd2(i,k) = tem1 / ptem1 + endif + enddo + do k = kmscu,1,-1 + do i = 1, im + if(cnvflg(i) .and. k < krad1(i)) then + dz = zm(i,k+1) - zm(i,k) + tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz + tem1 = bb2 * buo(i,k+1) * dz + ptem = (1. - tem) * wd2(i,k+1) + ptem1 = 1. + tem + wd2(i,k) = (ptem + tem1) / ptem1 + endif + enddo + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + mrady(i) = mrad(i) + if(flg(i)) mradx(i) = krad(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k < krad(i)) then + if(wd2(i,k) > 0.) then + mradx(i) = k + else + flg(i)=.false. + endif + endif + enddo + enddo +! + do i = 1,im + if(cnvflg(i)) then + if(mrad(i) < mradx(i)) then + mrad(i) = mradx(i) + endif + endif + enddo +! + do i=1,im + if (cnvflg(i)) then + kk = krad(i)-mrad(i) + if(kk < 1) cnvflg(i)=.false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! update entrainment rate +! + do k = 1, kmscu + do i=1,im + if(cnvflg(i) .and. mrady(i) < mradx(i)) then + dz = zl(i,k+1) - zl(i,k) + if(k >= mrad(i) .and. k < krad(i)) then + if(mrad(i) == 1) then + ptem = 1./(zm(i,k)+dz) + else + ptem = 1./(zm(i,k)-zm(i,mrad(i)-1)+dz) + endif + tem = max((hrad(i)-zm(i,k)+dz) ,dz) + ptem1 = 1./tem + xlamde(i,k) = ce0 * (ptem+ptem1) + else + xlamde(i,k) = ce0 / dz + endif + xlamdem(i,k) = cm * xlamde(i,k) + endif + enddo + enddo +! +! compute entrainment rate averaged over the whole downdraft layers +! + do i = 1, im + xlamavg(i) = 0. + sumx(i) = 0. + enddo + do k = kmscu, 1, -1 + do i = 1, im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + dz = zl(i,k+1) - zl(i,k) + xlamavg(i) = xlamavg(i) + xlamde(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + xlamavg(i) = xlamavg(i) / sumx(i) + endif + enddo +! +! compute downdraft mass flux +! + do k = kmscu, 1, -1 + do i = 1, im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + if(wd2(i,k) > 0.) then + tem = sqrt(wd2(i,k)) + else + tem = 0. + endif + xmfd(i,k) = ra1(i) * tem + endif + enddo + enddo +! +!--- compute downdraft fraction as a function of mean entrainment rate +! (Grell & Freitas, 2014) +! + do i = 1, im + if(cnvflg(i)) then + tem = 0.2 / xlamavg(i) + tem1 = 3.14 * tem * tem + sigma(i) = tem1 / (gdx(i) * gdx(i)) + sigma(i) = max(sigma(i), 0.001) + sigma(i) = min(sigma(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! + do i = 1, im + if(cnvflg(i)) then + if (sigma(i) > ra1(i)) then + scaldfunc(i) = (1.-sigma(i)) * (1.-sigma(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + endif + enddo +! +! final scale-aware downdraft mass flux +! + do k = kmscu, 1, -1 + do i = 1, im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + xmfd(i,k) = scaldfunc(i) * xmfd(i,k) + dz = zl(i,k+1) - zl(i,k) + xmmx = dz / dt2 + xmfd(i,k) = min(xmfd(i,k),xmmx) + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute downdraft property using updated entranment rate +! + do i = 1, im + if(cnvflg(i)) then + k = krad(i) + thld(i,k)= thlx(i,k) + endif + enddo +! +! do i = 1, im +! if(cnvflg(i)) then +! k = krad(i) +! ptem1 = max(qcdo(i,k,ntcw), 0.) +! tld = thld(i,k) / pix(i,k) +! tcdo(i,k) = tld + elocp * ptem1 +! qcdo(i,k,1) = qcdo(i,k,1)+0.2*qcdo(i,k,1) +! qcdo(i,k,ntcw) = qcdo(i,k,ntcw)+0.2*qcdo(i,k,ntcw) +! endif +! enddo +! + do k = kmscu,1,-1 + do i=1,im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* + & (thlx(i,k)+thlx(i,k+1)))/factor + qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* + & (qtx(i,k)+qtx(i,k+1)))/factor +! + tld = thld(i,k) / pix(i,k) + es = 0.01 * fpvs(tld) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtd(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tld**2) + qld = dq / (1. + gamma) + qtd(i,k) = qs + qld + qcdo(i,k,1) = qs + qcdo(i,k,ntcw) = qld + tcdo(i,k) = tld + elocp * qld + else + qcdo(i,k,1) = qtd(i,k) + qcdo(i,k,ntcw) = 0. + tcdo(i,k) = tld + endif +! + endif + enddo + enddo +! + do k = kmscu, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamdem(i,k) * dz + factor = 1. + tem + ptem = tem - pgcon + ptem1= tem + pgcon +! + ucdo(i,k) = ((1.-tem)*ucdo(i,k+1)+ptem*u1(i,k+1) + & +ptem1*u1(i,k))/factor + vcdo(i,k) = ((1.-tem)*vcdo(i,k+1)+ptem*v1(i,k+1) + & +ptem1*v1(i,k))/factor + endif + endif + enddo + enddo +! + if(ntcw > 2) then +! + do n = 2, ntcw-1 + do k = kmscu, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* + & (q1(i,k,n)+q1(i,k+1,n)))/factor + endif + endif + enddo + enddo + enddo +! + endif +! + ndc = ntrac1 - ntcw +! + if(ndc > 0) then +! + do n = ntcw+1, ntrac1 + do k = kmscu, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* + & (q1(i,k,n)+q1(i,k+1,n)))/factor + endif + endif + enddo + enddo + enddo +! + endif +! + return + end diff --git a/gsmphys/mfscuq.f b/gsmphys/mfscuq.f new file mode 100644 index 00000000..cb770700 --- /dev/null +++ b/gsmphys/mfscuq.f @@ -0,0 +1,539 @@ + subroutine mfscuq(im,ix,km,kmscu,ntcw,ntrac1,delt, + & cnvflg,zl,zm,q1,t1,u1,v1,plyr,pix, + & thlx,thvx,thlvx,gdx,thetae, + & krad,mrad,radmin,buo,xmfd, + & tcdo,qcdo,ucdo,vcdo,xlamde,a1) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp + &, rv => con_rv, hvap => con_hvap + &, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 +! + implicit none +! + integer im, ix, km, kmscu, ntcw, ntrac1 +! &, me + integer krad(im), mrad(im) +! + logical cnvflg(im) + real(kind=kind_phys) delt + real(kind=kind_phys) q1(ix,km,ntrac1),t1(ix,km), + & u1(ix,km), v1(ix,km), + & plyr(im,km), pix(im,km), + & thlx(im,km), + & thvx(im,km), thlvx(im,km), + & gdx(im), + & zl(im,km), zm(im,km), + & thetae(im,km), radmin(im), + & buo(im,km), xmfd(im,km), + & tcdo(im,km), qcdo(im,km,ntrac1), + & ucdo(im,km), vcdo(im,km), + & xlamde(im,km-1) +! +! local variables and arrays +! +! + integer i,j,indx, k, n, kk, ndc + integer krad1(im) +! + real(kind=kind_phys) dt2, dz, ce0, cm, + & gocp, factor, g, tau, + & b1, f1, bb1, bb2, + & a1, a2, + & cteit, pgcon, + & qmin, qlmin, + & xmmx, tem, tem1, tem2, + & ptem, ptem1, ptem2 +! + real(kind=kind_phys) elocp, el2orc, qs, es, + & tld, gamma, qld, thdn, + & thvd, dq +! + real(kind=kind_phys) wd2(im,km), thld(im,km), + & qtx(im,km), qtd(im,km), + & thlvd(im), hrad(im), + & xlamdem(im,km-1), ra1(im) + real(kind=kind_phys) delz(im), xlamax(im) +! + real(kind=kind_phys) xlamavg(im), sigma(im), + & scaldfunc(im), sumx(im) +! + logical totflg, flg(im) +! + real(kind=kind_phys) actei, cldtime +! +c physical parameters + parameter(g=grav) + parameter(gocp=g/cp) + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) + parameter(ce0=0.4,cm=1.0,pgcon=0.55) + parameter(qmin=1.e-8,qlmin=1.e-12) + parameter(b1=0.45,f1=0.15) + parameter(a2=0.5) + parameter(cldtime=500.) + parameter(actei = 0.7) +! parameter(actei = 0.23) +! +!************************************************************************ +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + dt2 = delt +! + do k = 1, km + do i=1,im + if(cnvflg(i)) then + buo(i,k) = 0. + wd2(i,k) = 0. + qtx(i,k) = q1(i,k,1) + q1(i,k,ntcw) + endif + enddo + enddo +! + do i = 1, im + if(cnvflg(i)) then + hrad(i) = zm(i,krad(i)) + krad1(i) = krad(i)-1 + endif + enddo +! + do i = 1, im + if(cnvflg(i)) then + k = krad(i) + tem = zm(i,k+1)-zm(i,k) + tem1 = cldtime*radmin(i)/tem + tem1 = max(tem1, -3.0) + thld(i,k)= thlx(i,k) + tem1 + qtd(i,k) = qtx(i,k) + thlvd(i) = thlvx(i,k) + tem1 + buo(i,k) = - g * tem1 / thvx(i,k) + endif + enddo +! +! specify downdraft fraction +! + do i=1,im + if(cnvflg(i)) then + ra1(i) = a1 + endif + enddo +! +! if the condition for cloud-top instability is met, +! increase downdraft fraction +! + do i = 1, im + if(cnvflg(i)) then + k = krad(i) + tem = thetae(i,k) - thetae(i,k+1) + tem1 = qtx(i,k) - qtx(i,k+1) + if (tem > 0. .and. tem1 > 0.) then + cteit= cp*tem/(hvap*tem1) + if(cteit > actei) then + ra1(i) = a2 + endif + endif + endif + enddo +! +! first-quess level of downdraft extension (mrad) +! + do i = 1, im + flg(i) = cnvflg(i) + mrad(i) = krad(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k < krad(i)) then + if(thlvd(i) <= thlvx(i,k)) then + mrad(i) = k + else + flg(i)=.false. + endif + endif + enddo + enddo + do i=1,im + if (cnvflg(i)) then + kk = krad(i)-mrad(i) + if(kk < 1) cnvflg(i)=.false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! compute entrainment rate +! + do i=1,im + if(cnvflg(i)) then + k = mrad(i) + (krad(i)-mrad(i)) / 2 + k = max(k, mrad(i)) + delz(i) = zl(i,k+1) - zl(i,k) + xlamax(i) = ce0 / delz(i) + endif + enddo +! + do k = 1, kmscu + do i=1,im + if(cnvflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + if(mrad(i) == 1) then + ptem = 1./(zm(i,k)+delz(i)) + else + ptem = 1./(zm(i,k)-zm(i,mrad(i)-1)+delz(i)) + endif + tem = max((hrad(i)-zm(i,k)+delz(i)) ,delz(i)) + ptem1 = 1./tem + xlamde(i,k) = ce0 * (ptem+ptem1) + else + xlamde(i,k) = xlamax(i) + endif +! + xlamdem(i,k) = cm * xlamde(i,k) + endif + enddo + enddo +! +! compute buoyancy for downdraft air parcel +! + do k = kmscu,1,-1 + do i=1,im + if(cnvflg(i) .and. k < krad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* + & (thlx(i,k)+thlx(i,k+1)))/factor + qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* + & (qtx(i,k)+qtx(i,k+1)))/factor +! + tld = thld(i,k) / pix(i,k) + es = 0.01 * fpvs(tld) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtd(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tld**2) + qld = dq / (1. + gamma) + qtd(i,k) = qs + qld + tem1 = 1. + fv * qs - qld + thdn = thld(i,k) + pix(i,k) * elocp * qld + thvd = thdn * tem1 + else + tem1 = 1. + fv * qtd(i,k) + thvd = thld(i,k) * tem1 + endif + buo(i,k) = g * (1. - thvd / thvx(i,k)) +! + endif + enddo + enddo +! +! compute downdraft velocity square(wd2) +! +! tem = 1.-2.*f1 +! bb1 = 2. * b1 / tem +! bb2 = 2. / tem +! from Soares et al. (2004,QJRMS) +! bb1 = 2. +! bb2 = 4. +! +! from Bretherton et al. (2004, MWR) +! bb1 = 4. +! bb2 = 2. +! +! from our tuning + bb1 = 2.0 + bb2 = 4.0 +! + do i = 1, im + if(cnvflg(i)) then + k = krad1(i) + dz = zm(i,k+1) - zm(i,k) +! tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz + tem = 0.5*bb1*xlamde(i,k)*dz + tem1 = bb2 * buo(i,k+1) * dz + ptem1 = 1. + tem + wd2(i,k) = tem1 / ptem1 + endif + enddo + do k = kmscu,1,-1 + do i = 1, im + if(cnvflg(i) .and. k < krad1(i)) then + dz = zm(i,k+1) - zm(i,k) + tem = 0.25*bb1*(xlamde(i,k)+xlamde(i,k+1))*dz + tem1 = bb2 * buo(i,k+1) * dz + ptem = (1. - tem) * wd2(i,k+1) + ptem1 = 1. + tem + wd2(i,k) = (ptem + tem1) / ptem1 + endif + enddo + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + if(flg(i)) mrad(i) = krad(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k < krad(i)) then + if(wd2(i,k) > 0.) then + mrad(i) = k + else + flg(i)=.false. + endif + endif + enddo + enddo +! + do i=1,im + if (cnvflg(i)) then + kk = krad(i)-mrad(i) + if(kk < 1) cnvflg(i)=.false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! update entrainment rate +! + do i=1,im + if(cnvflg(i)) then + k = mrad(i) + (krad(i)-mrad(i)) / 2 + k = max(k, mrad(i)) + delz(i) = zl(i,k+1) - zl(i,k) + xlamax(i) = ce0 / delz(i) + endif + enddo +! + do k = 1, kmscu + do i=1,im + if(cnvflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + if(mrad(i) == 1) then + ptem = 1./(zm(i,k)+delz(i)) + else + ptem = 1./(zm(i,k)-zm(i,mrad(i)-1)+delz(i)) + endif + tem = max((hrad(i)-zm(i,k)+delz(i)) ,delz(i)) + ptem1 = 1./tem + xlamde(i,k) = ce0 * (ptem+ptem1) + else + xlamde(i,k) = xlamax(i) + endif +! + xlamdem(i,k) = cm * xlamde(i,k) + endif + enddo + enddo +! +! compute entrainment rate averaged over the whole downdraft layers +! + do i = 1, im + xlamavg(i) = 0. + sumx(i) = 0. + enddo + do k = kmscu, 1, -1 + do i = 1, im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + dz = zl(i,k+1) - zl(i,k) + xlamavg(i) = xlamavg(i) + xlamde(i,k) * dz + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + xlamavg(i) = xlamavg(i) / sumx(i) + endif + enddo +! +! compute downdraft mass flux +! + do k = kmscu, 1, -1 + do i = 1, im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + xmfd(i,k) = ra1(i) * sqrt(wd2(i,k)) + endif + enddo + enddo +! +!--- compute downdraft fraction as a function of mean entrainment rate +! (Grell & Freitas, 2014) +! + do i = 1, im + if(cnvflg(i)) then + tem = 0.2 / xlamavg(i) + tem1 = 3.14 * tem * tem + sigma(i) = tem1 / (gdx(i) * gdx(i)) + sigma(i) = max(sigma(i), 0.001) + sigma(i) = min(sigma(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! + do i = 1, im + if(cnvflg(i)) then + if (sigma(i) > ra1(i)) then + scaldfunc(i) = (1.-sigma(i)) * (1.-sigma(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + endif + enddo +! +! final scale-aware downdraft mass flux +! + do k = kmscu, 1, -1 + do i = 1, im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + xmfd(i,k) = scaldfunc(i) * xmfd(i,k) + dz = zl(i,k+1) - zl(i,k) + xmmx = dz / dt2 + xmfd(i,k) = min(xmfd(i,k),xmmx) + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute downdraft property using updated entranment rate +! + do i = 1, im + if(cnvflg(i)) then + k = krad(i) + thld(i,k)= thlx(i,k) + endif + enddo +! +! do i = 1, im +! if(cnvflg(i)) then +! k = krad(i) +! ptem1 = max(qcdo(i,k,ntcw), 0.) +! tld = thld(i,k) / pix(i,k) +! tcdo(i,k) = tld + elocp * ptem1 +! qcdo(i,k,1) = qcdo(i,k,1)+0.2*qcdo(i,k,1) +! qcdo(i,k,ntcw) = qcdo(i,k,ntcw)+0.2*qcdo(i,k,ntcw) +! endif +! enddo +! + do k = kmscu,1,-1 + do i=1,im + if(cnvflg(i) .and. + & (k >= mrad(i) .and. k < krad(i))) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + thld(i,k) = ((1.-tem)*thld(i,k+1)+tem* + & (thlx(i,k)+thlx(i,k+1)))/factor + qtd(i,k) = ((1.-tem)*qtd(i,k+1)+tem* + & (qtx(i,k)+qtx(i,k+1)))/factor +! + tld = thld(i,k) / pix(i,k) + es = 0.01 * fpvs(tld) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k)+epsm1*es)) + dq = qtd(i,k) - qs +! + if (dq > 0.) then + gamma = el2orc * qs / (tld**2) + qld = dq / (1. + gamma) + qtd(i,k) = qs + qld + qcdo(i,k,1) = qs + qcdo(i,k,ntcw) = qld + tcdo(i,k) = tld + elocp * qld + else + qcdo(i,k,1) = qtd(i,k) + qcdo(i,k,ntcw) = 0. + tcdo(i,k) = tld + endif +! + endif + enddo + enddo +! + do k = kmscu, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamdem(i,k) * dz + factor = 1. + tem + ptem = tem - pgcon + ptem1= tem + pgcon +! + ucdo(i,k) = ((1.-tem)*ucdo(i,k+1)+ptem*u1(i,k+1) + & +ptem1*u1(i,k))/factor + vcdo(i,k) = ((1.-tem)*vcdo(i,k+1)+ptem*v1(i,k+1) + & +ptem1*v1(i,k))/factor + endif + endif + enddo + enddo +! + if(ntcw > 2) then +! + do n = 2, ntcw-1 + do k = kmscu, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* + & (q1(i,k,n)+q1(i,k+1,n)))/factor + endif + endif + enddo + enddo + enddo +! + endif +! + ndc = ntrac1 - ntcw +! + if(ndc > 0) then +! + do n = ntcw+1, ntrac1 + do k = kmscu, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! + qcdo(i,k,n) = ((1.-tem)*qcdo(i,k+1,n)+tem* + & (q1(i,k,n)+q1(i,k+1,n)))/factor + endif + endif + enddo + enddo + enddo +! + endif +! + return + end diff --git a/gsmphys/mfshalcnv.f b/gsmphys/mfshalcnv.f new file mode 100755 index 00000000..201e7386 --- /dev/null +++ b/gsmphys/mfshalcnv.f @@ -0,0 +1,1451 @@ + subroutine mfshalcnv(im,ix,km,delt,delp,prslp,psp,phil,ql, + & q1,t1,u1,v1,er,qr,rn,kbot,ktop,kcnv,islimsk,garea, + & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, +! & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc,me) + & clam,c0s,c1,pgcon,asolfac,evfact,evfactl) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + logical, intent(in) :: er + integer im, ix, km, ncloud, + & kbot(im), ktop(im), kcnv(im) +! &, me + real(kind=kind_phys) delt + real(kind=kind_phys) psp(im), delp(ix,km), prslp(ix,km) + real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), + & ql(ix,km,2),q1(ix,km), t1(ix,km), + & u1(ix,km), v1(ix,km), qr(ix,km), +! & u1(ix,km), v1(ix,km), rcs(im), + & rn(im), garea(im), + & dot(ix,km), phil(ix,km), hpbl(im), + & cnvw(ix,km),cnvc(ix,km) +! hchuang code change mass flux output + &, ud_mf(im,km),dt_mf(im,km) +! + integer i,j,indx, k, kk, km1, n + integer kpbl(im) + integer, dimension(im), intent(in) :: islimsk +! + real(kind=kind_phys) dellat, delta, + & c0l, c0s, d0, + & c1, asolfac, + & desdt, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, dxcrt, + & dv1h, dv2h, dv3h, + & dv1q, dv2q, dv3q, + & dz, dz1, e1, clam, + & el2orc, elocp, aafac, cm, + & es, etah, h1, + & evef, evfact, evfactl, fact1, + & fact2, factor, dthk, + & g, gamma, pprime, betaw, + & qlk, qrch, qs, + & rfact, shear, tfac, + & val, val1, val2, + & w1, w1l, w1s, w2, + & w2l, w2s, w3, w3l, + & w3s, w4, w4l, w4s, + & rho, tem, tem1, tem2, + & ptem, ptem1, + & pgcon +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), ktconn(im), + & kbm(im), kmax(im) +! + real(kind=kind_phys) aa1(im), cina(im), + & umean(im), tauadv(im), gdx(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & pdot(im), po(im,km), + & qcond(im), qevap(im), hmax(im), + & rntot(im), vshear(im), + & xlamud(im), xmb(im), xmbmax(im), + & delubar(im), delvbar(im) +! + real(kind=kind_phys) c0(im) +c + real(kind=kind_phys) crtlamd +! + real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, + & cinacr, cinacrmx, cinacrmn +! +! parameters for updraft velocity calculation + real(kind=kind_phys) bet1, cd1, f1, gam1, + & bb1, bb2, wucb +cc +c physical parameters +! parameter(g=grav,asolfac=0.89) + parameter(g=grav) + parameter(elocp=hvap/cp, + & el2orc=hvap*hvap/(rv*cp)) +! parameter(c0s=0.002,c1=5.e-4,d0=.01) + parameter(d0=.01) +! parameter(c0l=c0s*asolfac) +! +! asolfac: aerosol-aware parameter based on Lim & Hong (2012) +! asolfac= cx / c0s(=.002) +! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) +! Nccn: CCN number concentration in cm^(-3) +! Until a realistic Nccn is provided, typical Nccns are assumed +! as Nccn=100 for sea and Nccn=7000 for land +! + parameter(cm=1.0,delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(dthk=25.) + parameter(cinpcrmx=180.,cinpcrmn=120.) +! parameter(cinacrmx=-120.,cinacrmn=-120.) + parameter(cinacrmx=-120.,cinacrmn=-80.) + parameter(crtlamd=3.e-4) + parameter(dtmax=10800.,dtmin=600.) + parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) + parameter(betaw=.03,dxcrt=15.e3) + parameter(h1=0.33333333) +c local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km) +! for updraft velocity calculation + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) + real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) +! +c cloud water +! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), + & dbyo(im,km), zo(im,km), xlamue(im,km), + & heo(im,km), heso(im,km), + & dellah(im,km), dellaq(im,km), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & qrcko(im,km), eta(im,km), + & zi(im,km), pwo(im,km), c0t(im,km), + & sumx(im), tx1(im), cnvwt(im,km) +! + logical totflg, cnvflg(im), flg(im) +! + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +! +!************************************************************************ +! convert input Pa terms to Cb terms -- Moorthi + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! + km1 = km - 1 +c +c initialize arrays +c + do i=1,im + cnvflg(i) = .true. + if(kcnv(i) == 1) cnvflg(i) = .false. + if(cnvflg(i)) then + kbot(i)=km+1 + ktop(i)=0 + endif + rn(i)=0. + kbcon(i)=km + ktcon(i)=1 + ktconn(i)=1 + kb(i)=km + pdot(i) = 0. + qlko_ktcon(i) = 0. + edt(i) = 0. + aa1(i) = 0. + cina(i) = 0. + vshear(i) = 0. + gdx(i) = sqrt(garea(i)) + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(islimsk(i) == 1) then + c0(i) = c0s*asolfac + else + c0(i) = c0s + endif + enddo +! + do k = 1, km + do i = 1, im + if(t1(i,k) > 273.16) then + c0t(i,k) = c0(i) + else + tem = d0 * (t1(i,k) - 273.16) + tem1 = exp(tem) + c0t(i,k) = c0(i) * tem1 + endif + enddo + enddo +! + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +! hchuang code change + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +c + dt2 = delt +! +c model tunable parameters are all here +! clam = .3 + aafac = .1 +c evef = 0.07 +! evfact = 0.3 +! evfactl = 0.3 +! +! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) +! pgcon = 0.55 ! Zhang & Wu (2003,JAS) + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c + do i=1,im + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.60) kmax(i) = k + 1 + enddo + enddo + do i=1,im + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and compute +c updraft entrainment rate as an inverse function of height +c + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + xlamue(i,k) = clam / zi(i,k) + enddo + enddo + do i=1,im + xlamue(i,km) = xlamue(i,km1) + enddo +c +c pbl height +c + do i=1,im + flg(i) = cnvflg(i) + kpbl(i)= 1 + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= hpbl(i)) then + kpbl(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kpbl(i)= min(kpbl(i),kbm(i)) + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + eta(i,k) = 1. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) + wu2(i,k) = 0. + buo(i,k) = 0. + drag(i,k) = 0. + cnvwt(i,k) = 0. + endif + enddo + enddo +c +c column variables +c p is pressure of the layer (mb) +c t is temperature at t-dt (k)..tn +c q is mixing ratio at t-dt (kg/kg)..qn +c to is temperature at t+dt (k)... this is after advection and turbulan +c qo is mixing ratio at t+dt (kg/kg)..q1 +c + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy within pbl +c this is the level where updraft starts +c + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kpbl(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo +c +c look for the level of free convection as cloud base +c + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i=1,im + if(cnvflg(i)) then + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +c +c turn off convection if pressure depth between parcel source level +c and cloud base is larger than a critical value, cinpcr +c + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + ptem = 1. - tem + ptem1= .5*(cinpcrmx-cinpcrmn) + cinpcr = cinpcrmx - ptem * ptem1 + tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(tem1 > cinpcr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c specify the detrainment rate for the updrafts +c + do i = 1, im + if(cnvflg(i)) then + xlamud(i) = xlamue(i,kbcon(i)) +! xlamud(i) = crtlamd + endif + enddo +c +c determine updraft mass flux for the subcloud layers +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < kbcon(i) .and. k >= kb(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do i = 1, im + flg(i) = cnvflg(i) + enddo + do k = 2, km1 + do i = 1, im + if(flg(i))then + if(k > kbcon(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + if(eta(i,k) <= 0.) then + kmax(i) = k + ktconn(i) = k + kbm(i) = min(kbm(i),kmax(i)) + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute updraft cloud property +c + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + endif + enddo +c +! cm is an enhancement factor in entrainment rates for momentum +! + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + endif + endif + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k >= kbcon(i) .and. dbyo(i,k) > 0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem > dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c calculate convective inhibition +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kbcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + cina(i) = cina(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + cina(i) = cina(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then +! + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + tem = 1. - tem + tem1= .5*(cinacrmx-cinacrmn) + cinacr = cinacrmx - tem * tem1 +! +! cinacr = cinacrmx + if(cina(i) < cinacr) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c limited to the level of P/Ps=0.7 +c + do i = 1, im + flg(i) = cnvflg(i) + if(flg(i)) ktcon(i) = kbm(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kbcon1(i) .and. dbyo(i,k) < 0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c +c specify upper limit of mass flux at cloud base +c + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (g * dt2) +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c below lfc check if there is excess moisture to release latent heat +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + buo(i,k) = buo(i,k) - g * qlk + qcko(i,k)= qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif +! +! compute buoyancy and drag for updraft velocity +! + if(k >= kbcon(i)) then + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + buo(i,k) = buo(i,k) + g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + drag(i,k) = max(xlamue(i,k),xlamud(i)) + endif +! + endif + endif + enddo + enddo +c +c calculate cloud work function +c +! do k = 2, km1 +! do i = 1, im +! if (cnvflg(i)) then +! if(k >= kbcon(i) .and. k < ktcon(i)) then +! dz1 = zo(i,k+1) - zo(i,k) +! gamma = el2orc * qeso(i,k) / (to(i,k)**2) +! rfact = 1. + delta * cp * gamma +! & * to(i,k) / hvap +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * (g / (cp * to(i,k))) +! & dz1 * (g / (cp * to(i,k))) +! & * dbyo(i,k) / (1. + gamma) +! & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) +! endif +! endif +! enddo +! enddo +! do i = 1, im +! if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. +! enddo +! +! calculate cloud work function +! + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) + aa1(i) = aa1(i) + buo(i,k) * dz1 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the onvective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c limited to the level of P/Ps=0.7 +c + do i = 1, im + if (cnvflg(i)) then + aa1(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon1(i) = kbm(i) + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + if(k >= ktcon(i) .and. k < kbm(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa1(i) = aa1(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) + if(aa1(i) < 0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= ktcon(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +! +! compute updraft velocity square(wu2) +! +! bb1 = 2. * (1.+bet1*cd1) +! bb2 = 2. / (f1*(1.+gam1)) +! +! bb1 = 3.9 +! bb2 = 0.67 +! +! bb1 = 2.0 +! bb2 = 4.0 +! + bb1 = 4.0 + bb2 = 0.8 +! + do i = 1, im + if (cnvflg(i)) then + k = kbcon1(i) + tem = po(i,k) / (rd * to(i,k)) + wucb = -0.01 * dot(i,k) / (tem * g) + if(wucb > 0.) then + wu2(i,k) = wucb * wucb + else + wu2(i,k) = 0. + endif + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo +! +! compute updraft velocity averaged over the whole cumulus +! + do i = 1, im + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) cnvflg(i)=.false. + endif + enddo +c +c exchange ktcon with ktcon1 +c + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c + if(ncloud > 0) then +c +c compute liquid and vapor separation at cloud top +c + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +c--- compute precipitation efficiency in terms of windshear +c + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + endif + enddo +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = xlamud(i) +cj + dellah(i,k) = dellah(i,k) + + & ( eta(i,k)*dv1h - eta(i,k-1)*dv3h + & - tem*eta(i,k-1)*dv2h*dz + & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ( eta(i,k)*dv1q - eta(i,k-1)*dv3q + & - tem*eta(i,k-1)*dv2q*dz + & + tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & ) *g/dp +cj + tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) + tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) + dellau(i,k) = dellau(i,k) + (tem1-tem2) * g/dp +cj + tem1=eta(i,k)*(vo(i,k)-vcko(i,k)) + tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1)) + dellav(i,k) = dellav(i,k) + (tem1-tem2) * g/dp +cj + endif + endif + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - uo(i,indx-1)) * g / dp + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - vo(i,indx-1)) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo +! +! +! compute convective turn-over time +! + do i= 1, im + if(cnvflg(i)) then + tem = zi(i,ktcon1(i)) - zi(i,kbcon1(i)) + dtconv(i) = tem / wc(i) + tfac = 1. + gdx(i) / 75000. + dtconv(i) = tfac * dtconv(i) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = max(dtconv(i),dt2) + dtconv(i) = min(dtconv(i),dtmax) + endif + enddo +! +! compute advective time scale using a mean cloud layer wind speed +! + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv(i) = gdx(i) / umean(i) + endif + enddo +c +c compute cloud base mass flux as a function of the mean +c updraft velcoity +c + do i= 1, im + if(cnvflg(i)) then + k = kbcon(i) + rho = po(i,k)*100. / (rd*to(i,k)) + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + xmb(i) = tfac*betaw*rho*wc(i) + endif + enddo +! +!--- modified Grell & Freitas' (2014) updraft fraction which uses +! actual entrainment rate at cloud base +! + do i = 1, im + if(cnvflg(i)) then + tem = min(max(xlamue(i,kbcon(i)), 2.e-4), 6.e-4) + tem = 0.2 / tem + tem1 = 3.14 * tem * tem + sigmagfm(i) = tem1 / garea(i) + sigmagfm(i) = max(sigmagfm(i), 0.001) + sigmagfm(i) = min(sigmagfm(i), 0.999) + endif + enddo +! +!--- compute scale-aware function based on Arakawa & Wu (2013) +! +! + do i = 1, im + if(cnvflg(i)) then + if (gdx(i) < dxcrt) then + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i) = xmb(i) * scaldfunc(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo +! + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < ktcon(i) .and. k > kb(i)) then + ! the following 5 lines extract all rain water, Linjiong Zhou + if (er) then + dp = 1000. * del(i,k) + qr(i,k) = qr(i,k) + pwo(i,k) * xmb(i) * dt2 * g / dp + pwo(i,k) = 0.0 + endif + rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo +c +c evaporating rain +c + do k = km, 1, -1 + do i = 1, im + if (k <= kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i)) then + if(k < ktcon(i) .and. k > kb(i)) then + ! the following line extract all rain water, Linjiong Zhou + if (er) pwo(i,k) = 0.0 + rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + if(flg(i) .and. k < ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i) > 0. .and. qcond(i) < 0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i) > 0. .and. qcond(i) < 0. .and. + & delq2(i) > rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i) > 0. .and. qevap(i) > 0.) then + tem = .001 * dp / g + tem1 = qevap(i) * tem + if(tem1 > rn(i)) then + qevap(i) = rn(i) / tem + rn(i) = 0. + else + rn(i) = rn(i) - tem1 + endif + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me == 31 .and. cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' shallow delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +cj + do i = 1, im + if(cnvflg(i)) then + if(rn(i) < 0. .or. .not.flg(i)) rn(i) = 0. + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 2 + endif + enddo +c +c convective cloud water +c + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + +c +c convective cloud cover +c + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.2) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo + +c +c cloud water +c + if (ncloud > 0) then +! + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then +! if (k > kb(i) .and. k <= ktcon(i)) then + if (k >= kbcon(i) .and. k <= ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (ql(i,k,2) > -999.0) then + ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice + ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water + else + ql(i,k,1) = ql(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +! +! hchuang code change +! + do k = 1, km + do i = 1, im + if(cnvflg(i)) then + if(k >= kb(i) .and. k < ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo +!! + return + end diff --git a/gsmphys/module_bfmicrophysics.f b/gsmphys/module_bfmicrophysics.f new file mode 100644 index 00000000..49a20f47 --- /dev/null +++ b/gsmphys/module_bfmicrophysics.f @@ -0,0 +1,3199 @@ + MODULE module_microphysics +! + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS + USE PHYSCONS, CP => con_CP, RD => con_RD, RV => con_RV & + &, T0C => con_T0C, HVAP => con_HVAP, HFUS => con_HFUS & + &, EPS => con_EPS, EPSM1 => con_EPSM1 & + &, EPS1 => con_FVirt, pi => con_pi, grav => con_g + implicit none +! +!--- Common block of constants used in column microphysics +! + real,private :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & + &CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, CRAUT, ESW0, & + &QAUTx, RFmax, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, & + &RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, RR_DR3, RR_DRmax +! + integer, private :: mic_step +! +!--- Common block for lookup table used in calculating growth rates of +! nucleated ice crystals growing in water saturated conditions +!--- Discretized growth rates of small ice crystals after their nucleation +! at 1 C intervals from -1 C to -35 C, based on calculations by Miller +! and Young (1979, JAS) after 600 s of growth. Resultant growth rates +! are multiplied by physics time step in GSMCONST. +! + INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 + REAL,PRIVATE,DIMENSION(MY_T1:MY_T2) :: MY_GROWTH +! +!--- Parameters for ice lookup tables, which establish the range of mean ice +! particle diameters; from a minimum mean diameter of 0.05 mm (DMImin) to a +! maximum mean diameter of 1.00 mm (DMImax). The tables store solutions +! at 1 micron intervals (DelDMI) of mean ice particle diameter. +! + REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & + & XMImin=1.e6*DMImin, XMImax=1.e6*DMImax,& + & DelDMI=1.e-6 + INTEGER, PRIVATE,PARAMETER :: MDImin=XMImin, MDImax=XMImax +! +!--- Various ice lookup tables +! + REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & + & ACCRI,MASSI,SDENS,VSNOWI,VENTI1,VENTI2 +! +!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 450 microns +! (0.45 mm), assuming an exponential size distribution. +! + REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=.45e-3, & + & XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax,& + & DelDMR=1.e-6, NLImin=100. +! &, NLImin=100., NLImax=20.E3 + INTEGER, PRIVATE,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax +! +!--- Factor of 1.5 for RECImin, RESNOWmin, & RERAINmin accounts for +! integrating exponential distributions for effective radius +! (i.e., the r**3/r**2 moments). +! +! INTEGER, PRIVATE, PARAMETER :: INDEXSmin=300 +!! INTEGER, PRIVATE, PARAMETER :: INDEXSmin=200 + INTEGER, PRIVATE, PARAMETER :: INDEXSmin=100 + REAL, PRIVATE, PARAMETER :: RERAINmin=1.5*XMRmin & +! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=8.0 +! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=7.5 + &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=10. +! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=15. +! &, RECImin=1.5*XMImin, RESNOWmin=1.5*INDEXSmin, RECWmin=5. + +! +!--- Various rain lookup tables +!--- Rain lookup tables for mean rain drop diameters from DMRmin to DMRmax, +! assuming exponential size distributions for the rain drops +! + REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & + & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 +! +!--- Common block for riming tables +!--- VEL_RF - velocity increase of rimed particles as functions of crude +! particle size categories (at 0.1 mm intervals of mean ice particle +! sizes) and rime factor (different values of Rime Factor of 1.1**N, +! where N=0 to Nrime). +! + INTEGER, PRIVATE,PARAMETER :: Nrime=40 + REAL, DIMENSION(2:9,0:Nrime),PRIVATE :: VEL_RF +! +!--- The following variables are for microphysical statistics +! + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + INTEGER NSTATS(ITLO:ITHI,4) + REAL QMAX(ITLO:ITHI,5), QTOT(ITLO:ITHI,22) +! + REAL, PRIVATE, PARAMETER :: & +! & T_ICE=-10., T_ICE_init=-5. !- Ver1 +!!! &, T_ICE=-20. !- Ver2 + & T_ICE=-40., T_ICE_init=-15. !- Ver2 +! & T_ICE=-30., T_ICE_init=-5. !- Ver2 +! +! Some other miscellaneous parameters +! + REAL, PRIVATE, PARAMETER :: Thom=T_ICE, TNW=50., TOLER=1.0E-20 & +! REAL, PRIVATE, PARAMETER :: Thom=T_ICE, TNW=50., TOLER=5.E-7 +! REAL, PRIVATE, PARAMETER :: Thom=-35., TNW=50., TOLER=5.E-7 + +! &, emisCU=.75/1.66 ! Used for convective cloud l/w emissivity + +! Assume fixed cloud ice effective radius + &, RECICE=RECImin & + &, EPSQ=1.0E-20 & +! &, EPSQ=1.E-12 & + &, FLG0P1=0.1, FLG0P2=0.2, FLG1P0=1.0 +! +! + CONTAINS +! +!####################################################################### +!------- Initialize constants & lookup tables for microphysics --------- +!####################################################################### +! + SUBROUTINE GSMCONST (DTPG,mype,first) +! + implicit none +!------------------------------------------------------------------------------- +!--- SUBPROGRAM DOCUMENTATION BLOCK +! PRGRMMR: Ferrier ORG: W/NP22 DATE: February 2001 +!------------------------------------------------------------------------------- +! ABSTRACT: +! * Reads various microphysical lookup tables used in COLUMN_MICRO +! * Lookup tables were created "offline" and are read in during execution +! * Creates lookup tables for saturation vapor pressure w/r/t water & ice +!------------------------------------------------------------------------------- +! +! USAGE: CALL GSMCONST FROM SUBROUTINE GSMDRIVE AT MODEL START TIME +! +! INPUT ARGUMENT LIST: +! DTPH - physics time step (s) +! +! OUTPUT ARGUMENT LIST: +! NONE +! +! OUTPUT FILES: +! NONE +! +! +! SUBROUTINES: +! MY_GROWTH_RATES - lookup table for growth of nucleated ice +! +! UNIQUE: NONE +! +! LIBRARY: NONE +! +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE : IBM SP +! + integer mype + real dtpg + logical first +! +!--- Parameters & data statement for local calculations +! + REAL, PARAMETER :: C1=1./3., DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, & + & N0r0=8.E6, N0s0=4.E6, RHOL=1000., RHOS=100., & + & XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 + INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 +! + real dtph, bbfr + integer i +! +!--- Added on 5/16/01 for Moorthi +! + logical, parameter :: read_lookup=.false., write_lookup=.false. +! +!------------------------------------------------------------------------ +! ************* Parameters used in ETA model -- Not used in Global Model ***** +! +!--- DPHD, DLMD are delta latitude and longitude at the model (NOT geodetic) equator +! => "DX" is the hypotenuse of the model zonal & meridional grid increments. +! +! DX=111.*(DPHD**2+DLMD**2)**.5 ! Resolution at MODEL equator (km) +! DX=MIN(100., MAX(5., DX) ) +! +!--- Assume the following functional relationship for key constants that +! depend on grid resolution from DXmin (5 km) to DXmax (100 km) resolution: +! +! DXmin=5. +! DXmax=100. +! DX=MIN(DXmax, MAX(DXmin, DX) ) +! +!--- EXtune determines the degree to which the coefficients change with resolution. +! The larger EXtune is, the more sensitive the parameter. +! +! EXtune=1. + +! +!--- FXtune ==> F(DX) is the grid-resolution tuning parameter (from 0 to 1) +! +! FXtune=((DXmax-DX)/(DXmax-DXmin))**EXtune +! FXtune=MAX(0., MIN(1., FXtune)) +! +!--- Calculate grid-averaged RH for the onset of condensation (RHgrd) based on +! simple ***ASSUMED*** (user-specified) values at DXmax and at DXmin. +! +! RH_DXmax=.90 !-- 90% RH at DXmax=100 km +! RH_DXmin=.98 !-- 98% RH at DXmin=5 km +! +!--- Note that RHgrd is right now fixed throughout the domain!! +! +! RHgrd=RH_DXmax+(RH_DXmin-RH_DXmax)*FXtune +! ******************************************************************************** +! +! + if (first) then +! +!--- Read in various lookup tables +! + if ( read_lookup ) then + OPEN (UNIT=1,FILE="eta_micro_lookup.dat",FORM="UNFORMATTED") + READ(1) VENTR1 + READ(1) VENTR2 + READ(1) ACCRR + READ(1) MASSR + READ(1) VRAIN + READ(1) RRATE + READ(1) VENTI1 + READ(1) VENTI2 + READ(1) ACCRI + READ(1) MASSI + READ(1) VSNOWI + READ(1) VEL_RF +! read(1) my_growth ! Applicable only for DTPH=180 s for offline testing + CLOSE (1) + else + CALL ICE_LOOKUP ! Lookup tables for ice + CALL RAIN_LOOKUP ! Lookup tables for rain + if (write_lookup) then + open(unit=1,file='micro_lookup.dat',form='unformatted') + write(1) ventr1 + write(1) ventr2 + write(1) accrr + write(1) massr + write(1) vrain + write(1) rrate + write(1) venti1 + write(1) venti2 + write(1) accri + write(1) massi + write(1) vsnowi + write(1) vel_rf +! write(1) my_growth ! Applicable only for DTPH=180 s ???? + CLOSE (1) + endif + endif +!! +!--- Constants associated with Biggs (1953) freezing of rain, as parameterized +! following Lin et al. (JCAM, 1983) & Reisner et al. (1998, QJRMS). +! + ABFR=-0.66 + BBFR=100. + CBFR=20.*PI*PI*BBFR*RHOL*1.E-21 +! +!--- QAUT0 is the threshold cloud content for autoconversion to rain +! needed for droplets to reach a diameter of 20 microns (following +! Manton and Cotton, 1977; Banta and Hanson, 1987, JCAM). It is +! **STRONGLY** affected by the assumed droplet number concentrations +! XNCW! For example, QAUT0=1.2567, 0.8378, or 0.4189 g/m**3 for +! droplet number concentrations of 300, 200, and 100 cm**-3, respectively. +! +!--- Calculate grid-averaged XNCW based on simple ***ASSUMED*** (user-specified) +! values at DXmax and at DXmin. +! +! XNCW_DXmax=50.E6 !-- 50 /cm**3 at DXmax=100 km +! XNCW_DXmin=200.E6 !-- 200 /cm**3 at DXmin=5 km +! +!--- Note that XNCW is right now fixed throughout the domain!! +! +! XNCW=XNCW_DXmax+(XNCW_DXmin-XNCW_DXmax)*FXtune +! +! QAUT0=PI*RHOL*XNCW*(20.E-6)**3/6. + QAUTx=PI*RHOL*1.0E6*(20.E-6)**3/6. +! +!--- Based on rain lookup tables for mean diameters from 0.05 to 0.45 mm +! * Four different functional relationships of mean drop diameter as +! a function of rain rate (RR), derived based on simple fits to +! mass-weighted fall speeds of rain as functions of mean diameter +! from the lookup tables. +! + RR_DRmin=N0r0*RRATE(MDRmin) ! RR for mean drop diameter of .05 mm + RR_DR1=N0r0*RRATE(MDR1) ! RR for mean drop diameter of .10 mm + RR_DR2=N0r0*RRATE(MDR2) ! RR for mean drop diameter of .20 mm + RR_DR3=N0r0*RRATE(MDR3) ! RR for mean drop diameter of .32 mm + RR_DRmax=N0r0*RRATE(MDRmax) ! RR for mean drop diameter of .45 mm +! + RQR_DRmin=N0r0*MASSR(MDRmin) ! Rain content for mean drop diameter of .05 mm + RQR_DR1=N0r0*MASSR(MDR1) ! Rain content for mean drop diameter of .10 mm + RQR_DR2=N0r0*MASSR(MDR2) ! Rain content for mean drop diameter of .20 mm + RQR_DR3=N0r0*MASSR(MDR3) ! Rain content for mean drop diameter of .32 mm + RQR_DRmax=N0r0*MASSR(MDRmax) ! Rain content for mean drop diameter of .45 mm + C_N0r0=PI*RHOL*N0r0 + CN0r0=1.E6/C_N0r0**.25 + CN0r_DMRmin=1./(PI*RHOL*DMRmin**4) + CN0r_DMRmax=1./(PI*RHOL*DMRmax**4) +! + endif ! If (first) then loop ends here +! +! Find out what microphysics time step should be +! + mic_step = max(1, int(dtpg/600.0+0.5)) +! mic_step = max(1, int(dtpg/300.0+0.5)) + dtph = dtpg / mic_step + if (mype == 0) print *,' DTPG=',DTPG,' mic_step=',mic_step & + &, ' dtph=',dtph +! +!--- Calculates coefficients for growth rates of ice nucleated in water +! saturated conditions, scaled by physics time step (lookup table) +! + CALL MY_GROWTH_RATES (DTPH) +! +!--- CIACW is used in calculating riming rates +! The assumed effective collection efficiency of cloud water rimed onto +! ice is =0.5 below: +! +!Moor CIACW=DTPH*0.25*PI*0.5*(1.E5)**C1 ! commented on 20050422 +! ice is =0.1 below: + CIACW=DTPH*0.25*PI*0.1*(1.E5)**C1 +! CIACW = 0.0 ! Brad's suggestion 20040614 +! +!--- CIACR is used in calculating freezing of rain colliding with large ice +! The assumed collection efficiency is 1.0 +! + CIACR=PI*DTPH +! +!--- CRACW is used in calculating collection of cloud water by rain (an +! assumed collection efficiency of 1.0) +! +!Moor CRACW=DTPH*0.25*PI*1.0 ! commented on 20050422 +! +! assumed collection efficiency of 0.1) + CRACW=DTPH*0.25*PI*0.1 +! CRACW = 0.0 ! Brad's suggestion 20040614 +! + ESW0=FPVSL(T0C) ! Saturation vapor pressure at 0C + RFmax=1.1**Nrime ! Maximum rime factor allowed +! +!------------------------------------------------------------------------ +!--------------- Constants passed through argument list ----------------- +!------------------------------------------------------------------------ +! +!--- Important parameters for self collection (autoconversion) of +! cloud water to rain. +! +!--- CRAUT is proportional to the rate that cloud water is converted by +! self collection to rain (autoconversion rate) +! + CRAUT=1.-EXP(-1.E-3*DTPH) +! +! IF (MYPE == 0) +! & WRITE(6,"(A, A,F6.2,A, A,F5.4, A,F7.3,A, A,F6.2,A, A,F6.3,A)") +! & 'KEY MICROPHYSICAL PARAMETERS FOR ' +! & ,'DX=',DX,' KM:' +! & ,' FXtune=',FXtune +! & ,' RHgrd=',100.*RHgrd,' %' +! & ,' NCW=',1.E-6*XNCW,' /cm**3' +! & ,' QAUT0=',1.E3*QAUT0,' g/kg' +! +!--- For calculating snow optical depths by considering bulk density of +! snow based on emails from Q. Fu (6/27-28/01), where optical +! depth (T) = 1.5*SWP/(Reff*DENS), SWP is snow water path, Reff +! is effective radius, and DENS is the bulk density of snow. +! +! SWP (kg/m**2)=(1.E-3 kg/g)*SWPrad, SWPrad in g/m**2 used in radiation +! T = 1.5*1.E3*SWPrad/(Reff*DENS) +! +! See derivation for MASSI(INDEXS), note equal to RHO*QSNOW/NSNOW +! +! SDENS=1.5e3/DENS, DENS=MASSI(INDEXS)/[PI*(1.E-6*INDEXS)**3] +! + DO I=MDImin,MDImax +!MoorthiSDENS(I)=PI*1.5E-15*FLOAT(I*I*I)/MASSI(I) + SDENS(I)=PI*1.0E-15*FLOAT(I*I*I)/MASSI(I) + ENDDO +! +!----------------------------------------------------------------------- +! + END subroutine gsmconst + +! +!####################################################################### +!--- Sets up lookup table for calculating initial ice crystal growth --- +!####################################################################### +! + SUBROUTINE MY_GROWTH_RATES (DTPH) +! + implicit none +! +!--- Below are tabulated values for the predicted mass of ice crystals +! after 600 s of growth in water saturated conditions, based on +! calculations from Miller and Young (JAS, 1979). These values are +! crudely estimated from tabulated curves at 600 s from Fig. 6.9 of +! Young (1993). Values at temperatures colder than -27C were +! assumed to be invariant with temperature. +! +!--- Used to normalize Miller & Young (1979) calculations of ice growth +! over large time steps using their tabulated values at 600 s. +! Assumes 3D growth with time**1.5 following eq. (6.3) in Young (1993). +! + real dtph, dt_ice + REAL MY_600(MY_T1:MY_T2) +! +!-- 20090714: These values are in g and need to be converted to kg below + DATA MY_600 / & + & 5.5e-8, 1.4E-7, 2.8E-7, 6.E-7, 3.3E-6, & ! -1 to -5 deg C + & 2.E-6, 9.E-7, 8.8E-7, 8.2E-7, 9.4e-7, & ! -6 to -10 deg C + & 1.2E-6, 1.85E-6, 5.5E-6, 1.5E-5, 1.7E-5, & ! -11 to -15 deg C + & 1.5E-5, 1.E-5, 3.4E-6, 1.85E-6, 1.35E-6, & ! -16 to -20 deg C + & 1.05E-6, 1.E-6, 9.5E-7, 9.0E-7 , 9.5E-7, & ! -21 to -25 deg C + & 9.5E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7, & ! -26 to -30 deg C + & 9.E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7 / ! -31 to -35 deg C +! +!----------------------------------------------------------------------- +! + DT_ICE=(DTPH/600.)**1.5 +! MY_GROWTH=DT_ICE*MY_600 ! original version + MY_GROWTH=DT_ICE*MY_600*1.E-3 !-- 20090714: Convert from g to kg +! +!----------------------------------------------------------------------- +! + END subroutine MY_GROWTH_RATES +! +!####################################################################### +!--------------- Creates lookup tables for ice processes --------------- +!####################################################################### +! + subroutine ice_lookup +! + implicit none +!----------------------------------------------------------------------------------- +! +!---- Key diameter values in mm +! +!----------------------------------------------------------------------------------- +! +!---- Key concepts: +! - Actual physical diameter of particles (D) +! - Ratio of actual particle diameters to mean diameter (x=D/MD) +! - Mean diameter of exponentially distributed particles, which is the +! same as 1./LAMDA of the distribution (MD) +! - All quantitative relationships relating ice particle characteristics as +! functions of their diameter (e.g., ventilation coefficients, normalized +! accretion rates, ice content, and mass-weighted fall speeds) are a result +! of using composite relationships for ice crystals smaller than 1.5 mm +! diameter merged with analogous relationships for larger sized aggregates. +! Relationships are derived as functions of mean ice particle sizes assuming +! exponential size spectra and assuming the properties of ice crystals at +! sizes smaller than 1.5 mm and aggregates at larger sizes. +! +!----------------------------------------------------------------------------------- +! +!---- Actual ice particle diameters for which integrated distributions are derived +! - DminI - minimum diameter for integration (.02 mm, 20 microns) +! - DmaxI - maximum diameter for integration (2 cm) +! - DdelI - interval for integration (1 micron) +! + real, parameter :: DminI=.02e-3, DmaxI=20.e-3, DdelI=1.e-6, & + & XImin=1.e6*DminI, XImax=1.e6*DmaxI + integer, parameter :: IDImin=XImin, IDImax=XImax +! +!---- Meaning of the following arrays: +! - diam - ice particle diameter (m) +! - mass - ice particle mass (kg) +! - vel - ice particle fall speeds (m/s) +! - vent1 - 1st term in ice particle ventilation factor +! - vent2 - 2nd term in ice particle ventilation factor +! + real diam(IDImin:IDImax),mass(IDImin:IDImax),vel(IDImin:IDImax), & + & vent1(IDImin:IDImax),vent2(IDImin:IDImax) +! +!----------------------------------------------------------------------------------- +! +!---- Found from trial & error that the m(D) & V(D) mass & velocity relationships +! between the ice crystals and aggregates overlapped & merged near a particle +! diameter sizes of 1.5 mm. Thus, ice crystal relationships are used for +! sizes smaller than 1.5 mm and aggregate relationships for larger sizes. +! + real, parameter :: d_crystal_max=1.5 +! +!---- The quantity xmax represents the maximum value of "x" in which the +! integrated values are calculated. For xmax=20., this means that +! integrated ventilation, accretion, mass, and precipitation rates are +! calculated for ice particle sizes less than 20.*mdiam, the mean particle diameter. +! + real, parameter :: xmax=20. +! +!----------------------------------------------------------------------------------- +! +!---- Meaning of the following arrays: +! - mdiam - mean diameter (m) +! - VENTI1 - integrated quantity associated w/ ventilation effects +! (capacitance only) for calculating vapor deposition onto ice +! - VENTI2 - integrated quantity associated w/ ventilation effects +! (with fall speed) for calculating vapor deposition onto ice +! - ACCRI - integrated quantity associated w/ cloud water collection by ice +! - MASSI - integrated quantity associated w/ ice mass +! - VSNOWI - mass-weighted fall speed of snow, used to calculate precip rates +! +!--- Mean ice-particle diameters varying from 50 microns to 1000 microns (1 mm), +! assuming an exponential size distribution. +! + real mdiam +! +!----------------------------------------------------------------------------------- +!------------- Constants & parameters for ventilation factors of ice --------------- +!----------------------------------------------------------------------------------- +! +!---- These parameters are used for calculating the ventilation factors for ice +! crystals between 0.2 and 1.5 mm diameter (Hall and Pruppacher, JAS, 1976). +! From trial & error calculations, it was determined that the ventilation +! factors of smaller ice crystals could be approximated by a simple linear +! increase in the ventilation coefficient from 1.0 at 50 microns (.05 mm) to +! 1.1 at 200 microns (0.2 mm), rather than using the more complex function of +! 1.0 + .14*(Sc**.33*Re**.5)**2 recommended by Hall & Pruppacher. +! + real, parameter :: cvent1i=.86, cvent2i=.28 +! +!---- These parameters are used for calculating the ventilation factors for larger +! aggregates, where D>=1.5 mm (see Rutledge and Hobbs, JAS, 1983; +! Thorpe and Mason, 1966). +! + real, parameter :: cvent1a=.65, cvent2a=.44 +! + real m_agg,m_bullet,m_column,m_ice,m_plate +! +!---- Various constants +! + real, parameter :: c1=2./3., cexp=1./3. +! + logical :: iprint + logical, parameter :: print_diag=.false. +! +!----------------------------------------------------------------------------------- +!- Constants & parameters for calculating the increase in fall speed of rimed ice -- +!----------------------------------------------------------------------------------- +! +!---- Constants & arrays for estimating increasing fall speeds of rimed ice. +! Based largely on theory and results from Bohm (JAS, 1989, 2419-2427). +! +!-------------------- Standard atmosphere conditions at 1000 mb -------------------- +! + real, parameter :: t_std=288., dens_std=1000.e2/(287.04*288.) +! +!---- These "bulk densities" are the actual ice densities in the ice portion of the +! lattice. They are based on text associated w/ (12) on p. 2425 of Bohm (JAS, +! 1989). Columns, plates, & bullets are assumed to have an average bulk density +! of 850 kg/m**3. Aggregates were assumed to have a slightly larger bulk density +! of 600 kg/m**3 compared with dendrites (i.e., the least dense, most "lacy" & +! tenous ice crystal, which was assumed to be ~500 kg/m**3 in Bohm). +! + real, parameter :: dens_crystal=850., dens_agg=600. +! +!--- A value of Nrime=40 for a logarithmic ratio of 1.1 yields a maximum rime factor +! of 1.1**40 = 45.26 that is resolved in these tables. This allows the largest +! ice particles with a mean diameter of MDImax=1000 microns to achieve bulk +! densities of 900 kg/m**3 for rimed ice. +! +! integer, parameter :: Nrime=40 + real m_rime, & + & rime_factor(0:Nrime), rime_vel(0:Nrime), & + & vel_rime(IDImin:IDImax,Nrime), ivel_rime(MDImin:MDImax,Nrime) +! + integer i, j, jj, k, icount + real c2, cbulk, cbulk_ice, px, dynvis_std, crime1 & + &, crime2, crime3, crime4, crime5, d, c_avg, c_agg & + &, c_bullet, c_column, c_plate, cl_agg, cl_bullet & + &, cl_column, cl_plate, v_agg, v_bullet, v_column & + &, v_plate, wd, ecc_column & + &, cvent1, cvent2, crime_best, rime_m1, rime_m2 & + &, x_rime, re_rime, smom3, pratei, expf & + &, bulk_dens, xmass, xmdiam, ecc_plate, dx +! +!----------------------------------------------------------------------------------- +!----------------------------- BEGIN EXECUTION ------------------------------------- +!----------------------------------------------------------------------------------- +! +! + c2=1./sqrt(3.) +! pi=acos(-1.) + cbulk=6./pi + cbulk_ice=900.*pi/6. ! Maximum bulk ice density allowed of 900 kg/m**3 + px=.4**cexp ! Convert fall speeds from 400 mb (Starr & Cox) to 1000 mb +! +!--------------------- Dynamic viscosity (1000 mb, 288 K) -------------------------- +! + dynvis_std=1.496e-6*t_std**1.5/(t_std+120.) + crime1=pi/24. + crime2=8.*9.81*dens_std/(pi*dynvis_std**2) + crime3=crime1*dens_crystal + crime4=crime1*dens_agg + crime5=dynvis_std/dens_std + do i=0,Nrime + rime_factor(i)=1.1**i + enddo +! +!####################################################################### +! Characteristics as functions of actual ice particle diameter +!####################################################################### +! +!---- M(D) & V(D) for 3 categories of ice crystals described by Starr +!---- & Cox (1985). +! +!---- Capacitance & characteristic lengths for Reynolds Number calculations +!---- are based on Young (1993; p. 144 & p. 150). c-axis & a-axis +!---- relationships are from Heymsfield (JAS, 1972; Table 1, p. 1351). +! + icount=60 +! + if (print_diag) & + & write(7,"(2a)") '---- Increase in fall speeds of rimed ice', & + & ' particles as function of ice particle diameter ----' + do i=IDImin,IDImax + if (icount == 60 .and. print_diag) then + write(6,"(/2a/3a)") 'Particle masses (mg), fall speeds ', & + & '(m/s), and ventilation factors', & + & ' D(mm) CR_mass Mass_bull Mass_col Mass_plat ', & + & ' Mass_agg CR_vel V_bul CR_col CR_pla Aggreg', & + & ' Vent1 Vent2 ' + write(7,"(3a)") ' <----------------------------------',& + & '--------------- Rime Factor --------------------------', & + & '--------------------------->' + write(7,"(a,23f5.2)") ' D(mm)',(rime_factor(k), k=1,5), & + & (rime_factor(k), k=6,40,2) + icount=0 + endif + d=(float(i)+.5)*1.e-3 ! in mm + c_avg=0. + c_agg=0. + c_bullet=0. + c_column=0. + c_plate=0. + cl_agg=0. + cl_bullet=0. + cl_column=0. + cl_plate=0. + m_agg=0. + m_bullet=0. + m_column=0. + m_plate=0. + v_agg=0. + v_bullet=0. + v_column=0. + v_plate=0. + if (d < d_crystal_max) then +! +!---- This block of code calculates bulk characteristics based on average +! characteristics of bullets, plates, & column ice crystals <1.5 mm size +! +!---- Mass-diameter relationships from Heymsfield (1972) & used +! in Starr & Cox (1985), units in mg +!---- "d" is maximum dimension size of crystal in mm, +! +! Mass of pure ice for spherical particles, used as an upper limit for the +! mass of small columns (<~ 80 microns) & plates (<~ 35 microns) +! + m_ice=.48*d**3 ! Mass of pure ice for spherical particle +! + m_bullet=min(.044*d**3, m_ice) + m_column=min(.017*d**1.7, m_ice) + m_plate=min(.026*d**2.5, m_ice) +! + mass(i)=m_bullet+m_column+m_plate +! +!---- These relationships are from Starr & Cox (1985), applicable at 400 mb +!---- "d" is maximum dimension size of crystal in mm, dx in microns +! + dx=1000.*d ! Convert from mm to microns + if (dx <= 200.) then + v_column=8.114e-5*dx**1.585 + v_bullet=5.666e-5*dx**1.663 + v_plate=1.e-3*dx + else if (dx <= 400.) then + v_column=4.995e-3*dx**.807 + v_bullet=3.197e-3*dx**.902 + v_plate=1.48e-3*dx**.926 + else if (dx <= 600.) then + v_column=2.223e-2*dx**.558 + v_bullet=2.977e-2*dx**.529 + v_plate=9.5e-4*dx + else if (dx <= 800.) then + v_column=4.352e-2*dx**.453 + v_bullet=2.144e-2*dx**.581 + v_plate=3.161e-3*dx**.812 + else + v_column=3.833e-2*dx**.472 + v_bullet=3.948e-2*dx**.489 + v_plate=7.109e-3*dx**.691 + endif +! +!---- Reduce fall speeds from 400 mb to 1000 mb +! + v_column=px*v_column + v_bullet=px*v_bullet + v_plate=px*v_plate +! +!---- DIFFERENT VERSION! CALCULATES MASS-WEIGHTED CRYSTAL FALL SPEEDS +! + vel(i)=(m_bullet*v_bullet+m_column*v_column+m_plate*v_plate)/ & + & mass(i) + mass(i)=mass(i)/3. +! +!---- Shape factor and characteristic length of various ice habits, +! capacitance is equal to 4*PI*(Shape factor) +! See Young (1993, pp. 143-152 for guidance) +! +!---- Bullets: +! +!---- Shape factor for bullets (Heymsfield, 1975) + c_bullet=.5*d +!---- Length-width functions for bullets from Heymsfield (JAS, 1972) + if (d > 0.3) then + wd=.25*d**.7856 ! Width (mm); a-axis + else + wd=.185*d**.552 + endif +!---- Characteristic length for bullets (see first multiplicative term on right +! side of eq. 7 multiplied by crystal width on p. 821 of Heymsfield, 1975) + cl_bullet=.5*pi*wd*(.25*wd+d)/(d+wd) +! +!---- Plates: +! +!---- Length-width function for plates from Heymsfield (JAS, 1972) + wd=.0449*d**.449 ! Width or thickness (mm); c-axis +!---- Eccentricity & shape factor for thick plates following Young (1993, p. 144) + ecc_plate=sqrt(1.-wd*wd/(d*d)) ! Eccentricity + c_plate=d*ecc_plate/asin(ecc_plate) ! Shape factor +!---- Characteristic length for plates following Young (1993, p. 150, eq. 6.6) + cl_plate=d+2.*wd ! Characteristic lengths for plates +! +!---- Columns: +! +!---- Length-width function for columns from Heymsfield (JAS, 1972) + if (d > 0.2) then + wd=.1973*d**.414 ! Width (mm); a-axis + else + wd=.5*d ! Width (mm); a-axis + endif +!---- Eccentricity & shape factor for columns following Young (1993, p. 144) + ecc_column=sqrt(1.-wd*wd/(d*d)) ! Eccentricity + c_column=ecc_column*d/log((1.+ecc_column)*d/wd) ! Shape factor +!---- Characteristic length for columns following Young (1993, p. 150, eq. 6.7) + cl_column=(wd+2.*d)/(c1+c2*d/wd) ! Characteristic lengths for columns +! +!---- Convert shape factor & characteristic lengths from mm to m for +! ventilation calculations +! + c_bullet=.001*c_bullet + c_plate=.001*c_plate + c_column=.001*c_column + cl_bullet=.001*cl_bullet + cl_plate=.001*cl_plate + cl_column=.001*cl_column +! +!---- Make a smooth transition between a ventilation coefficient of 1.0 at 50 microns +! to 1.1 at 200 microns +! + if (d > 0.2) then + cvent1=cvent1i + cvent2=cvent2i/3. + else + cvent1=1.0+.1*max(0., d-.05)/.15 + cvent2=0. + endif +! +!---- Ventilation factors for ice crystals: +! + vent1(i)=cvent1*(c_bullet+c_plate+c_column)/3. + vent2(i)=cvent2*(c_bullet*sqrt(v_bullet*cl_bullet) & + & +c_plate*sqrt(v_plate*cl_plate) & + & +c_column*sqrt(v_column*cl_column) ) + crime_best=crime3 ! For calculating Best No. of rimed ice crystals + else +! +!---- This block of code calculates bulk characteristics based on average +! characteristics of unrimed aggregates >= 1.5 mm using Locatelli & +! Hobbs (JGR, 1974, 2185-2197) data. +! +!----- This category is a composite of aggregates of unrimed radiating +!----- assemblages of dendrites or dendrites; aggregates of unrimed +!----- radiating assemblages of plates, side planes, bullets, & columns; +!----- aggregates of unrimed side planes (mass in mg, velocity in m/s) +! + m_agg=(.073*d**1.4+.037*d**1.9+.04*d**1.4)/3. + v_agg=(.8*d**.16+.69*d**.41+.82*d**.12)/3. + mass(i)=m_agg + vel(i)=v_agg +! +!---- Assume spherical aggregates +! +!---- Shape factor is the same as for bullets, = D/2 + c_agg=.001*.5*d ! Units of m +!---- Characteristic length is surface area divided by perimeter +! (.25*PI*D**2)/(PI*D**2) = D/4 + cl_agg=.5*c_agg ! Units of m +! +!---- Ventilation factors for aggregates: +! + vent1(i)=cvent1a*c_agg + vent2(i)=cvent2a*c_agg*sqrt(v_agg*cl_agg) + crime_best=crime4 ! For calculating Best No. of rimed aggregates + endif +! +!---- Convert from shape factor to capacitance for ventilation factors +! + vent1(i)=4.*pi*vent1(i) + vent2(i)=4.*pi*vent2(i) + diam(i)=1.e-3*d ! Convert from mm to m + mass(i)=1.e-6*mass(i) ! Convert from mg to kg +! +!---- Calculate increase in fall speeds of individual rimed ice particles +! + do k=0,Nrime +!---- Mass of rimed ice particle associated with rime_factor(k) + rime_m1=rime_factor(k)*mass(i) + rime_m2=cbulk_ice*diam(i)**3 + m_rime=min(rime_m1, rime_m2) +!---- Best Number (X) of rimed ice particle combining eqs. (8) & (12) in Bohm + x_rime=crime2*m_rime*(crime_best/m_rime)**.25 +!---- Reynolds Number for rimed ice particle using eq. (11) in Bohm + re_rime=8.5*(sqrt(1.+.1519*sqrt(x_rime))-1.)**2 + rime_vel(k)=crime5*re_rime/diam(i) + enddo + do k=1,Nrime + vel_rime(i,k)=rime_vel(k)/rime_vel(0) + enddo + if (print_diag) then + ! + !---- Determine if statistics should be printed out. + ! + iprint=.false. + if (d <= 1.) then + if (mod(i,10) == 0) iprint=.true. + else + if (mod(i,100) == 0) iprint=.true. + endif + if (iprint) then + write(6,"(f7.4,5e11.4,1x,5f7.4,1x,2e11.4)") & + & d,1.e6*mass(i),m_bullet,m_column,m_plate,m_agg, & + & vel(i),v_bullet,v_column,v_plate,v_agg, & + & vent1(i),vent2(i) + write(7,"(f7.4,23f5.2)") d,(vel_rime(i,k), k=1,5), & + & (vel_rime(i,k), k=6,40,2) + icount=icount+1 + endif + endif + enddo +! +!####################################################################### +! Characteristics as functions of mean particle diameter +!####################################################################### +! + VENTI1=0. + VENTI2=0. + ACCRI=0. + MASSI=0. + VSNOWI=0. + VEL_RF=0. + ivel_rime=0. + icount=0 + if (print_diag) then + icount=60 + write(6,"(/2a)") '------------- Statistics as functions of ', & + & 'mean particle diameter -------------' + write(7,"(/2a)") '------ Increase in fall speeds of rimed ice', & + & ' particles as functions of mean particle diameter -----' + endif + do j=MDImin,MDImax + if (icount == 60 .AND. print_diag) then + write(6,"(/2a)") 'D(mm) Vent1 Vent2 ', & + & 'Accrete Mass Vel Dens ' + write(7,"(3a)") ' <----------------------------------', & + & '--------------- Rime Factor --------------------------', & + & '--------------------------->' + write(7,"(a,23f5.2)") 'D(mm)',(rime_factor(k), k=1,5), & + & (rime_factor(k), k=6,40,2) + icount=0 + endif + mdiam=DelDMI*float(j) ! in m + smom3=0. + pratei=0. + rime_vel=0. ! Note that this array is being reused! + do i=IDImin,IDImax + dx=diam(i)/mdiam + if (dx <= xmax) then ! To prevent arithmetic underflows + expf=exp(-dx)*DdelI + VENTI1(J)=VENTI1(J)+vent1(i)*expf + VENTI2(J)=VENTI2(J)+vent2(i)*expf + ACCRI(J)=ACCRI(J)+diam(i)*diam(i)*vel(i)*expf + xmass=mass(i)*expf + do k=1,Nrime + rime_vel(k)=rime_vel(k)+xmass*vel_rime(i,k) + enddo + MASSI(J)=MASSI(J)+xmass + pratei=pratei+xmass*vel(i) + smom3=smom3+diam(i)**3*expf + else + exit + endif + enddo + ! + !--- Increased fall velocities functions of mean diameter (j), + ! normalized by ice content, and rime factor (k) + ! + do k=1,Nrime + ivel_rime(j,k)=rime_vel(k)/MASSI(J) + enddo + ! + !--- Increased fall velocities functions of ice content at 0.1 mm + ! intervals (j_100) and rime factor (k); accumulations here + ! + jj=j/100 + if (jj >= 2 .AND. jj <= 9) then + do k=1,Nrime + VEL_RF(jj,k)=VEL_RF(jj,k)+ivel_rime(j,k) + enddo + endif + bulk_dens=cbulk*MASSI(J)/smom3 + VENTI1(J)=VENTI1(J)/mdiam + VENTI2(J)=VENTI2(J)/mdiam + ACCRI(J)=ACCRI(J)/mdiam + VSNOWI(J)=pratei/MASSI(J) + MASSI(J)=MASSI(J)/mdiam + if (mod(j,10) == 0 .AND. print_diag) then + xmdiam=1.e3*mdiam + write(6,"(f6.3,4e11.4,f6.3,f8.3)") xmdiam,VENTI1(j),VENTI2(j),& + & ACCRI(j),MASSI(j),VSNOWI(j),bulk_dens + write(7,"(f6.3,23f5.2)") xmdiam,(ivel_rime(j,k), k=1,5), & + & (ivel_rime(j,k), k=6,40,2) + icount=icount+1 + endif + enddo +! +!--- Average increase in fall velocities rimed ice as functions of mean +! particle diameter (j, only need 0.1 mm intervals) and rime factor (k) +! + if (print_diag) then + write(7,"(/2a)") ' ------- Increase in fall speeds of rimed ', & + & 'ice particles at reduced, 0.1-mm intervals --------' + write(7,"(3a)") ' <----------------------------------', & + & '--------------- Rime Factor --------------------------', & + & '--------------------------->' + write(7,"(a,23f5.2)") 'D(mm)',(rime_factor(k), k=1,5), & + & (rime_factor(k), k=6,40,2) + endif + do j=2,9 + VEL_RF(j,0)=1. + do k=1,Nrime + VEL_RF(j,k)=.01*VEL_RF(j,k) + enddo + if (print_diag) write(7,"(f4.1,2x,23f5.2)") 0.1*j, & + & (VEL_RF(j,k), k=1,5),(VEL_RF(j,k), k=6,40,2) + enddo +! +!----------------------------------------------------------------------------------- +! + end subroutine ice_lookup +! +!####################################################################### +!-------------- Creates lookup tables for rain processes --------------- +!####################################################################### +! + subroutine rain_lookup + implicit none +! +!--- Parameters & arrays for fall speeds of rain as a function of rain drop +! diameter. These quantities are integrated over exponential size +! distributions of rain drops at 1 micron intervals (DdelR) from minimum +! drop sizes of .05 mm (50 microns, DminR) to maximum drop sizes of 10 mm +! (DmaxR). +! + real, parameter :: DminR=.05e-3, DmaxR=10.e-3, DdelR=1.e-6, & + & XRmin=1.e6*DminR, XRmax=1.e6*DmaxR + integer, parameter :: IDRmin=XRmin, IDRmax=XRmax + real diam(IDRmin:IDRmax), vel(IDRmin:IDRmax) +! +!--- Parameters rain lookup tables, which establish the range of mean drop +! diameters; from a minimum mean diameter of 0.05 mm (DMRmin) to a +! maximum mean diameter of 0.45 mm (DMRmax). The tables store solutions +! at 1 micron intervals (DelDMR) of mean drop diameter. +! + real mdiam, mass +! + logical, parameter :: print_diag=.false. +! + real d, cmass, pi2, expf + integer i, j, i1, i2 +! +!----------------------------------------------------------------------- +!------- Fall speeds of rain as function of rain drop diameter --------- +!----------------------------------------------------------------------- +! + do i=IDRmin,IDRmax + diam(i)=float(i)*DdelR + d=100.*diam(i) ! Diameter in cm + if (d <= .42) then + ! + !--- Rutledge & Hobbs (1983); vel (m/s), d (cm) + ! + vel(i)=max(0., -.267+51.5*d-102.25*d*d+75.7*d**3) + else if (d > 0.42 .and. d <= .58) then + ! + !--- Linear interpolation of Gunn & Kinzer (1949) data + ! + vel(i)=8.92+.25/(.58-.42)*(d-.42) + else + vel(i)=9.17 + endif + enddo + do i=1,100 + i1=(i-1)*100+IDRmin + i2=i1+90 + ! + !--- Print out rain fall speeds only for D<=5.8 mm (.58 cm) + ! + if (diam(i1) > .58e-2) exit + if (print_diag) then + write(6,"(1x)") + write(6,"('D(mm)-> ',10f7.3)") (1000.*diam(j), j=i1,i2,10) + write(6,"('V(m/s)-> ',10f7.3)") (vel(j), j=i1,i2,10) + endif + enddo +! +!----------------------------------------------------------------------- +!------------------- Lookup tables for rain processes ------------------ +!----------------------------------------------------------------------- +! +! pi=acos(-1.) + pi2=2.*pi + cmass=1000.*pi/6. + if (print_diag) then + write(6,"(/'Diam - Mean diameter (mm)' & + & /'VENTR1 - 1st ventilation coefficient (m**2)' & + & /'VENTR2 - 2nd ventilation coefficient (m**3/s**.5)' & + & /'ACCRR - accretion moment (m**4/s)' & + & /'RHO*QR - mass content (kg/m**3) for N0r=8e6' & + & /'RRATE - rain rate moment (m**5/s)' & + & /'VR - mass-weighted rain fall speed (m/s)' & + & /' Diam VENTR1 VENTR2 ACCRR ', & + & 'RHO*QR RRATE VR')") + endif + do j=MDRmin,MDRmax + mdiam=float(j)*DelDMR + VENTR2(J)=0. + ACCRR(J)=0. + MASSR(J)=0. + RRATE(J)=0. + do i=IDRmin,IDRmax + expf=exp(-diam(i)/mdiam)*DdelR + VENTR2(J)=VENTR2(J)+diam(i)**1.5*vel(i)**.5*expf + ACCRR(J)=ACCRR(J)+diam(i)*diam(i)*vel(i)*expf + MASSR(J)=MASSR(J)+diam(i)**3*expf + RRATE(J)=RRATE(J)+diam(i)**3*vel(i)*expf + enddo + ! + !--- Derived based on ventilation, F(D)=0.78+.31*Schmidt**(1/3)*Reynold**.5, + ! where Reynold=(V*D*rho/dyn_vis), V is velocity, D is particle diameter, + ! rho is air density, & dyn_vis is dynamic viscosity. Only terms + ! containing velocity & diameter are retained in these tables. + ! + VENTR1(J)=.78*pi2*mdiam**2 + VENTR2(J)=.31*pi2*VENTR2(J) + ! + MASSR(J)=cmass*MASSR(J) + RRATE(J)=cmass*RRATE(J) + VRAIN(J)=RRATE(J)/MASSR(J) + if (print_diag) write(6,"(f6.3,5g12.5,f6.3)") 1000.*mdiam, & + & ventr1(j),ventr2(j),accrr(j),8.e6*massr(j),rrate(j),vrain(j) + enddo +! +!----------------------------------------------------------------------- +! + end subroutine rain_lookup +! +!############################################################################### +! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL +! (1) Represents sedimentation by preserving a portion of the precipitation +! through top-down integration from cloud-top. Modified procedure to +! Zhao and Carr (1997). +! (2) Microphysical equations are modified to be less sensitive to time +! steps by use of Clausius-Clapeyron equation to account for changes in +! saturation mixing ratios in response to latent heating/cooling. +! (3) Prevent spurious temperature oscillations across 0C due to +! microphysics. +! (4) Uses lookup tables for: calculating two different ventilation +! coefficients in condensation and deposition processes; accretion of +! cloud water by precipitation; precipitation mass; precipitation rate +! (and mass-weighted precipitation fall speeds). +! (5) Assumes temperature-dependent variation in mean diameter of large ice +! (Houze et al., 1979; Ryan et al., 1996). +! -> 8/22/01: This relationship has been extended to colder temperatures +! to parameterize smaller large-ice particles down to mean sizes of MDImin, +! which is 50 microns reached at -55.9C. +! (6) Attempts to differentiate growth of large and small ice, mainly for +! improved transition from thin cirrus to thick, precipitating ice +! anvils. +! -> 8/22/01: This feature has been diminished by effectively adjusting to +! ice saturation during depositional growth at temperatures colder than +! -10C. Ice sublimation is calculated more explicitly. The logic is +! that sources of are either poorly understood (e.g., nucleation for NWP) +! or are not represented in the Eta model (e.g., detrainment of ice from +! convection). Otherwise the model is too wet compared to the radiosonde +! observations based on 1 Feb - 18 March 2001 retrospective runs. +! (7) Top-down integration also attempts to treat mixed-phase processes, +! allowing a mixture of ice and water. Based on numerous observational +! studies, ice growth is based on nucleation at cloud top & +! subsequent growth by vapor deposition and riming as the ice particles +! fall through the cloud. Effective nucleation rates are a function +! of ice supersaturation following Meyers et al. (JAM, 1992). +! -> 8/22/01: The simulated relative humidities were far too moist compared +! to the rawinsonde observations. This feature has been substantially +! diminished, limited to a much narrower temperature range of 0 to -10C. +! (8) Depositional growth of newly nucleated ice is calculated for large time +! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals +! using their ice crystal masses calculated after 600 s of growth in water +! saturated conditions. The growth rates are normalized by time step +! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). +! -> 8/22/01: This feature has been effectively limited to 0 to -10C. +! (9) Ice precipitation rates can increase due to increase in response to +! cloud water riming due to (a) increased density & mass of the rimed +! ice, and (b) increased fall speeds of rimed ice. +! -> 8/22/01: This feature has been effectively limited to 0 to -10C. +!############################################################################### +!############################################################################### +! + SUBROUTINE GSMCOLUMN ( ARAING, ASNOWG, DTPG, I_index, J_index, & + & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & + & THICK_col, WC_col, LM, RHC_col, XNCW, FLGmin, PRINT_diag, psfc) +! + implicit none +! +!############################################################################### +!############################################################################### +! +!------------------------------------------------------------------------------- +!----- NOTE: In this version of the Code threading should be done outside! +!------------------------------------------------------------------------------- +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation +! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 +! Updated: Moorthi for GFS application +!------------------------------------------------------------------------------- +! ABSTRACT: +! * Merges original GSCOND & PRECPD subroutines. +! * Code has been substantially streamlined and restructured. +! * Exchange between water vapor & small cloud condensate is calculated using +! the original Asai (1965, J. Japan) algorithm. See also references to +! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. +! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) +! parameterization. +!------------------------------------------------------------------------------- +! +! USAGE: +! * CALL GSMCOLUMN FROM SUBROUTINE GSMDRIVE +! * SUBROUTINE GSMDRIVE CALLED FROM MAIN PROGRAM EBU +! +! INPUT ARGUMENT LIST: +! DTPH - physics time step (s) +! I_index - I index +! J_index - J index +! LSFC - Eta level of level above surface, ground +! P_col - vertical column of model pressure (Pa) +! QI_col - vertical column of model ice mixing ratio (kg/kg) +! QR_col - vertical column of model rain ratio (kg/kg) +! QV_col - vertical column of model water vapor specific humidity (kg/kg) +! QW_col - vertical column of model cloud water mixing ratio (kg/kg) +! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) +! T_col - vertical column of model temperature (deg K) +! THICK_col - vertical column of model mass thickness (density*height increment) +! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) +! +! +! OUTPUT ARGUMENT LIST: +! ARAIN - accumulated rainfall at the surface (kg) +! ASNOW - accumulated snowfall at the surface (kg) +! QV_col - vertical column of model water vapor specific humidity (kg/kg) +! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) +! QW_col - vertical column of model cloud water mixing ratio (kg/kg) +! QI_col - vertical column of model ice mixing ratio (kg/kg) +! QR_col - vertical column of model rain ratio (kg/kg) +! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) +! T_col - vertical column of model temperature (deg K) +! +! OUTPUT FILES: +! NONE +! +! Subprograms & Functions called: +! * Real Function CONDENSE - cloud water condensation +! * Real Function DEPOSIT - ice deposition (not sublimation) +! +! UNIQUE: NONE +! +! LIBRARY: NONE +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE : IBM SP +! +!------------------------------------------------------------------------- +!--------------- Arrays & constants in argument list --------------------- +!------------------------------------------------------------------------- +! + integer lm + REAL ARAING, ASNOWG, P_col(LM), QI_col(LM), QR_col(LM), QV_col(LM)& + &, QW_col(LM), RimeF_col(LM), T_col(LM), THICK_col(LM), & + & WC_col(LM), RHC_col(LM), XNCW(LM), ARAIN, ASNOW, dtpg, psfc + real flgmin +! + INTEGER I_index, J_index, LSFC +! +! +!------------------------------------------------------------------------- +! +!--- Mean ice-particle diameters varying from 50 microns to 1000 microns +! (1 mm), assuming an exponential size distribution. +! +!---- Meaning of the following arrays: +! - mdiam - mean diameter (m) +! - VENTI1 - integrated quantity associated w/ ventilation effects +! (capacitance only) for calculating vapor deposition onto ice +! - VENTI2 - integrated quantity associated w/ ventilation effects +! (with fall speed) for calculating vapor deposition onto ice +! - ACCRI - integrated quantity associated w/ cloud water collection by ice +! - MASSI - integrated quantity associated w/ ice mass +! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate +! precipitation rates +! + REAL, PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, DelDMI=1.e-6, & + & XMImin=1.e6*DMImin, XMImax=1.e6*DMImax + INTEGER, PARAMETER :: MDImin=XMImin, MDImax=XMImax +! +!------------------------------------------------------------------------- +!------- Key parameters, local variables, & important comments --------- +!----------------------------------------------------------------------- +! +!--- KEY Parameters: +! +!---- Comments on 14 March 2002 +! * Set EPSQ to the universal value of 1.e-12 throughout the code +! condensate. The value of EPSQ will need to be changed in the other +! subroutines in order to make it consistent throughout the Eta code. +! * Set CLIMIT=10.*EPSQ as the lower limit for the total mass of +! condensate in the current layer and the input flux of condensate +! from above (TOT_ICE, TOT_ICEnew, TOT_RAIN, and TOT_RAINnew). +! +!-- NLImax - maximum number concentration of large ice crystals (20,000 /m**3, 20 per liter) +!-- NLImin - minimum number concentration of large ice crystals (100 /m**3, 0.1 per liter) +! + REAL, PARAMETER :: RHOL=1000., XLS=HVAP+HFUS & + +! &, T_ICE=-10. !- Ver1 +! &, T_ICE_init=-5. !- Ver1 +!!! &, T_ICE=-20. !- Ver2 +! &, T_ICE=-40. !- Ver2 +! &, T_ICE_init=-15., !- Ver2 +! +! & CLIMIT=10.*EPSQ, EPS1=RV/RD-1., RCP=1./CP, + + &,CLIMIT=10.*EPSQ, RCP=1./CP, & + & RCPRV=RCP/RV, RRHOL=1./RHOL, XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, & + & XLS3=XLS*XLS/RV, & + & C1=1./3., C2=1./6., C3=3.31/6., & + & DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, N0r0=8.E6, N0rmin=1.e4, & + & N0s0=4.E6, RHO0=1.194, XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, & + & XMR3=1.e6*DMR3, Xratio=.025 + INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 +! +!--- If BLEND=1: +! precipitation (large) ice amounts are estimated at each level as a +! blend of ice falling from the grid point above and the precip ice +! present at the start of the time step (see TOT_ICE below). +!--- If BLEND=0: +! precipitation (large) ice amounts are estimated to be the precip +! ice present at the start of the time step. +! +!--- Extended to include sedimentation of rain on 2/5/01 +! + REAL, PARAMETER :: BLEND=1. +! +!--- This variable is for debugging purposes (if .true.) +! + LOGICAL PRINT_diag +! +!--- Local variables +! + REAL EMAIRI, N0r, NLICE, NSmICE, NLImax, pfac + LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical + + integer lbef, ipass, ixrf, ixs, itdx, idr & + &, index_my, indexr, indexr1, indexs & + &, i, j, k, l, ntimes, item +! &, i, j, k, my_600, i1, i2, l, ntimes + + real flimass, xlimass, vsnow, qi_min, dum, piloss & + &, tot_ice, xsimass, vel_inc, vrimef, rimef1, dum1 & + &, dum2, fws, denomi, dwv & + &, xrf, qw0, dli, xli, fsmall & + &, prevp, tk2, dtph & + &, pievp, picnd, piacr, pracw & + &, praut, pimlt, qtice, qlice & + &, gammar, flarge, wvqw, dynvis & + &, tfactor, denom, gammas, diffus, therm_cond & + &, wvnew, delv, tnew, tot_icenew, rimef & + &, deli, fwr, crevp, ventr, delt & + &, delw, fir, delr, qsinew, qswnew & + &, budget, wsnew, vrain2, tot_rainnew & + &, qtnew, qt, wcnew, abw & + &, aievp, tcc, denomf, abi & + &, sfactor, pidep_max, didep, ventis, ventil & + &, dievp, rqr, rfactor, dwvr, rr, tot_rain & + &, dwv0, qsw0, prloss, qtrain, vrain1 & + &, qsw, ws, esi, esw, wv, wc, rhgrd, rho & + &, rrho, dtrho, wsgrd, qsi, qswgrd, qsigrd & + &, tk, tc, pp, bldtrh & + &, xlv, xlv1, xlf, xlf1, xlv2, denomw, denomwi & + &, qwnew, pcond, pidep, qrnew, qi, qr, qw & + &, piacw, piacwi, piacwr, qv, dwvi & + &, arainnew, thick, asnownew & + &, qinew, qi_min_0c, QSW_l, QSI_l, QSW0_l, SCHMIT_FAC + +! +! +!####################################################################### +!########################## Begin Execution ############################ +!####################################################################### +! + DTPH = DTPG / mic_step + ARAING = 0. ! Total Accumulated rainfall at surface (kg/m**2) + ASNOWG = 0. ! Total Accumulated snowfall at surface (kg/m**2) +! + do ntimes =1,mic_step +! + QI_min_0C = 10.E3*MASSI(MDImin) !- Ver5 + ARAIN = 0. ! Accumulated rainfall at surface for this step (kg/m**2) + ASNOW = 0. ! Accumulated snowfall at surface for this step (kg/m**2) + + INDEXR = MDRmin +! +!----------------------------------------------------------------------- +! + DO L=1,LSFC ! Loop from top (L=1) to surface (L=LSFC) + +!--- Skip this level and go to the next lower level if no condensate +! and very low specific humidities +! + IF (QV_col(L) > EPSQ .OR. WC_col(L) > EPSQ) THEN +! +!----------------------------------------------------------------------- +!------------ Proceed with cloud microphysics calculations ------------- +!----------------------------------------------------------------------- +! + TK = T_col(L) ! Temperature (deg K) + TC = TK-T0C ! Temperature (deg C) + PP = P_col(L) ! Pressure (Pa) + QV = QV_col(L) ! Specific humidity of water vapor (kg/kg) +! WV = QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) + WV = QV ! Water vapor specific humidity (kg/kg) + WC = WC_col(L) ! Grid-scale mixing ratio of total condensate + ! (water or ice; kg/kg) +! WC = WC/(1.-WC) + RHgrd = RHC_col(L) + +! +! Pressure dependen scaling factor for flgmin (tunable) +! +!!! pfac = max(0.5, (min(1.0, pp*0.00002))**2) ! commented on 02182011 +!go pfac = max(0.5, (sqrt(min(1.0, pp*0.00004)))) + pfac = 1.0 +! + CLEAR = .TRUE. +! +!--- Check grid-scale saturation when no condensate is present +! + ESW = min(PP, FPVSL(TK)) ! Saturation vapor pressure w/r/t water +! QSW = EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water + QSW = EPS*ESW/(PP+epsm1*ESW) ! Saturation specific humidity w/r/t water + WS = QSW ! General saturation mixing ratio (water/ice) + QSI = QSW + IF (TC < 0.) THEN + ESI = min(PP,FPVSI(TK)) ! Saturation vapor pressure w/r/t ice +! QSI = EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water + QSI = EPS*ESI/(PP+epsm1*ESI) ! Saturation specific humidity w/r/t water + WS = QSI ! General saturation mixing ratio (water/ice) + if (pp <= esi) ws = wv / rhgrd + ENDIF +! + dum = min(PP, ESW0) + QSW0 = EPS*dum/(PP+epsm1*dum) ! Saturation specific Humidity at 0C +! +!--- Effective grid-scale Saturation mixing ratios +! + QSWgrd = RHgrd*QSW + QSIgrd = RHgrd*QSI + WSgrd = RHgrd*WS + QSW_l = QSWgrd + QSI_l = QSIgrd + QSW0_l = QSW0*RHgrd +! +!--- Check if air is subsaturated and w/o condensate +! + IF (WV > WSgrd .OR. WC > EPSQ) CLEAR = .FALSE. ! Cloudy case + IF (ARAIN > CLIMIT) THEN ! If any rain is falling into layer from above + CLEAR = .FALSE. + ELSE + ARAIN = 0. + ENDIF +! +!--- Check if any ice is falling into layer from above +! +!--- NOTE that "SNOW" in variable names is synonomous with +! large, precipitation ice particles +! + IF (ASNOW > CLIMIT) THEN + CLEAR = .FALSE. + ELSE + ASNOW = 0. + ENDIF +! +!----------------------------------------------------------------------- +!-- Loop to the end if in clear, subsaturated air free of condensate --- +!----------------------------------------------------------------------- +! + IF (.not. CLEAR) THEN +! +!----------------------------------------------------------------------- +!--------- Initialize RHO, THICK & microphysical processes ------------- +!----------------------------------------------------------------------- +! +! +!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; +! (see pp. 63-65 in Fleagle & Businger, 1963) +! + RHO = PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) + RRHO = 1./RHO ! Reciprocal of air density + DTRHO = DTPH*RHO ! Time step * air density + BLDTRH = BLEND*DTRHO ! Blend parameter * time step * air density + THICK = THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G +! + ARAINnew = 0. ! Updated accumulated rainfall at surface + ASNOWnew = 0. ! Updated accumulated snowfall at surface + QI = QI_col(L) ! Ice mixing ratio + QInew = 0. ! Updated ice mixing ratio + QR = QR_col(L) ! Rain mixing ratio + QRnew = 0. ! Updated rain ratio + QW = QW_col(L) ! Cloud water mixing ratio + QWnew = 0. ! Updated cloud water ratio +! + PCOND = 0. ! Condensation (>0) or evaporation (<0) + ! of cloud water (kg/kg) + PIDEP = 0. ! Deposition (>0) or sublimation (<0) + ! of ice crystals (kg/kg) + PIACW = 0. ! Cloud water collection (riming) + ! by precipitation ice (kg/kg; >0) + PIACWI = 0. ! Growth of precip ice by riming (kg/kg; >0) + PIACWR = 0. ! Shedding of accreted cloud water + ! to form rain (kg/kg; >0) + PIACR = 0. ! Freezing of rain onto large ice + ! at supercooled temps (kg/kg; >0) + PICND = 0. ! Condensation (>0) onto wet, melting + ! ice (kg/kg) + PIEVP = 0. ! Evaporation (<0) from wet, melting + ! ice (kg/kg) + PIMLT = 0. ! Melting ice (kg/kg; >0) + PRAUT = 0. ! Cloud water autoconversion to rain (kg/kg; >0) + PRACW = 0. ! Cloud water collection (accretion) by rain (kg/kg; >0) + PREVP = 0. ! Rain evaporation (kg/kg; <0) +! +!--------------------------------------------------------------------------- +!--- Double check input hydrometeor mixing ratios +! +! DUM = WC - (QI+QW+QR) +! DUM1 = ABS(DUM) +! DUM2 = TOLER * MIN(WC, QI+QW+QR) +! IF (DUM1 > DUM2) THEN +! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, +! & ' L=',L +! WRITE(6,"(4(a12,g11.4,1x))") +! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, +! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR +! ENDIF +! +!*********************************************************************** +!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** +!*********************************************************************** +! +!--- Calculate a few variables, which are used more than once below +! +!--- Latent heat of vaporization as a function of temperature from +! Bolton (1980, JAS) +! + XLV = 3.148E6 - 2370*TK ! Latent heat of vaporization (Lv) + XLF = XLS-XLV ! Latent heat of fusion (Lf) + XLV1 = XLV*RCP ! Lv/Cp + XLF1 = XLF*RCP ! Lf/Cp + TK2 = 1./(TK*TK) ! 1./TK**2 + XLV2 = XLV*XLV*QSW_l*TK2/RV ! Lv**2*Qsw_l/(Rv*TK**2) + DENOMW = 1. + XLV2*RCP ! Denominator term, Clausius-Clapeyron correction +! +!--- Basic thermodynamic quantities +! * DYNVIS - dynamic viscosity [ kg/(m*s) ] +! * THERM_COND - thermal conductivity [ J/(m*s*K) ] +! * DIFFUS - diffusivity of water vapor [ m**2/s ] +! +! TFACTOR = TK**1.5/(TK+120.) + TFACTOR = TK*sqrt(TK)/(TK+120.) + DYNVIS = 1.496E-6*TFACTOR + THERM_COND = 2.116E-3*TFACTOR + DIFFUS = 8.794E-5*TK**1.81/PP + SCHMIT_FAC = (RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 +! +!--- Air resistance term for the fall speed of ice following the +! basic research by Heymsfield, Kajikawa, others +! + GAMMAS = (1.E5/PP)**C1 +! +!--- Air resistance for rain fall speed (Beard, 1985, JAOT, p.470) +! + GAMMAR = (RHO0/RHO)**0.4 +! +!---------------------------------------------------------------------- +!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- +!---------------------------------------------------------------------- +! +!--- Determine if conditions supporting ice are present +! + IF (TC < 0. .OR. QI > EPSQ .OR. ASNOW > CLIMIT) THEN + ICE_logical = .TRUE. + ELSE + ICE_logical = .FALSE. + QLICE = 0. + QTICE = 0. + ENDIF +! +!--- Determine if rain is present +! + RAIN_logical = .FALSE. + IF (ARAIN > CLIMIT .OR. QR > EPSQ) RAIN_logical = .TRUE. +! + IF (ICE_logical) THEN +! +!--- IMPORTANT: Estimate time-averaged properties. +! +!--- +! * FLARGE - ratio of number of large ice to total (large & small) ice +! * FSMALL - ratio of number of small ice crystals to large ice particles +! -> Small ice particles are assumed to have a mean diameter of 50 microns. +! * XSIMASS - used for calculating small ice mixing ratio +!--- +! * TOT_ICE - total mass (small & large) ice before microphysics, +! which is the sum of the total mass of large ice in the +! current layer and the input flux of ice from above +! * PILOSS - greatest loss (<0) of total (small & large) ice by +! sublimation, removing all of the ice falling from above +! and the ice within the layer +! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) +! ice mass to the unrimed ice mass (>=1) +! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) +! * VSNOW - Fall speed of rimed snow w/ air resistance correction +! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer +! * XLIMASS - used for calculating large ice mixing ratio +! * FLIMASS - mass fraction of large ice +! * QTICE - time-averaged mixing ratio of total ice +! * QLICE - time-averaged mixing ratio of large ice +! * NLICE - time-averaged number concentration of large ice +! * NSmICE - number concentration of small ice crystals at current level +!--- +!--- Assumed number fraction of large ice particles to total (large & small) +! ice particles, which is based on a general impression of the literature. +! + WVQW = WV + QW ! Water vapor + cloud water +! +!--- 6/19/03 - Deleted some code here .... +! +! ********************************************************* + +! IF (TC >= 0. .OR. WVQW < QSIgrd) THEN +! ! +! !--- Eliminate small ice particle contributions for melting & sublimation +! ! +! FLARGE = FLARGE1 +! ELSE +! ! +! !--- Enhanced number of small ice particles during depositional growth +! ! (effective only when 0C > T >= T_ice [-10C] ) +! ! +! FLARGE = FLARGE2 +! ! +! !--- Larger number of small ice particles due to rime splintering +! ! +! IF (TC >= -8. .AND. TC <= -3.) FLARGE=.5*FLARGE +! +! ENDIF ! End IF (TC >= 0. .OR. WVQW < QSIgrd) +! FSMALL=(1.-FLARGE)/FLARGE +! XSIMASS=RRHO*MASSI(MDImin)*FSMALL +! ********************************************************* +! + IF (QI <= EPSQ .AND. ASNOW <= CLIMIT) THEN + INDEXS = MDImin + FLARGE = 0. !--- Begin 6/19/03 changes + FSMALL = 1. + XSIMASS = RRHO*MASSI(MDImin) !--- End 6/19/03 changes + TOT_ICE = 0. + PILOSS = 0. + RimeF1 = 1. + VrimeF = 1. + VEL_INC = GAMMAS + VSNOW = 0. + EMAIRI = THICK + XLIMASS = RRHO*RimeF1*MASSI(INDEXS) + FLIMASS = XLIMASS/(XLIMASS+XSIMASS) + QLICE = 0. + QTICE = 0. + NLICE = 0. + NSmICE = 0. + ELSE + ! + !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), + ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships + ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). + ! + !--- Begin 6/19/03 changes => allow NLImax to increase & FLARGE to + ! decrease at COLDER temperatures; set FLARGE to zero (i.e., only small + ! ice) if the ice mixing ratio is below QI_min + +! DUM = MAX(0.05, MIN(1., EXP(.0536*TC)) ) + DUM = MAX(0.05, MIN(1., EXP(.0564*TC)) ) + INDEXS = MIN(MDImax, MAX(MDImin, INT(XMImax*DUM) ) ) +! + DUM = MAX(FLGmin*pfac, DUM) + + QI_min = QI_min_0C * dum !- Ver5 ----Not used ---- +!! QI_min = QI_min_0C !- Ver5 +!!! QI_min = QI_min_0C/DUM !- Ver5 + + NLImax = 10.E3/sqrt(DUM) !- Ver3 + IF (TC < 0.) THEN + FLARGE = DUM !- Ver4 + ELSE + FLARGE = 1. + ENDIF + FSMALL = (1.-FLARGE)/FLARGE + XSIMASS = RRHO*MASSI(MDImin)*FSMALL + TOT_ICE = THICK*QI + BLEND*ASNOW + PILOSS = -TOT_ICE/THICK + LBEF = MAX(1,L-1) + RimeF1 = (RimeF_col(L)*THICK*QI & + & + RimeF_col(LBEF)*BLEND*ASNOW)/TOT_ICE + RimeF1 = MIN(RimeF1, RFmax) + VSNOW = 0.0 + DO IPASS=0,1 + IF (RimeF1 .LE. 1.) THEN + RimeF1 = 1. + VrimeF = 1. + ELSE + IXS = MAX(2, MIN(INDEXS/100, 9)) + XRF = 10.492*LOG(RimeF1) + IXRF = MAX(0, MIN(INT(XRF), Nrime)) + IF (IXRF .GE. Nrime) THEN + VrimeF = VEL_RF(IXS,Nrime) + ELSE + VrimeF = VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & + & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) + ENDIF + ENDIF ! End IF (RimeF1 <= 1.) + VEL_INC = GAMMAS*VrimeF + VSNOW = VEL_INC*VSNOWI(INDEXS) + EMAIRI = THICK + BLDTRH*VSNOW + XLIMASS = RRHO*RimeF1*MASSI(INDEXS) + FLIMASS = XLIMASS/(XLIMASS+XSIMASS) + QTICE = TOT_ICE/EMAIRI + QLICE = FLIMASS*QTICE + NLICE = QLICE/XLIMASS + NSmICE = Fsmall*NLICE + ! + IF ( (NLICE >= NLImin .AND. NLICE <= NLImax) & + & .OR. IPASS == 1) THEN + EXIT + ELSE + IF(TC < 0) THEN + XLI = RHO*(QTICE/DUM-XSIMASS)/RimeF1 + IF (XLI <= MASSI(MDImin) ) THEN + INDEXS = MDImin + ELSE IF (XLI <= MASSI(450) ) THEN + DLI = 9.5885E5*XLI**.42066 ! DLI in microns + INDEXS = MIN(MDImax, MAX(MDImin, INT(DLI) ) ) + ELSE IF (XLI <= MASSI(MDImax) ) THEN + DLI = 3.9751E6*XLI**.49870 ! DLI in microns + INDEXS = MIN(MDImax, MAX(MDImin, INT(DLI) ) ) + ELSE + INDEXS = MDImax + ENDIF ! End IF (XLI <= MASSI(MDImin) ) + ENDIF ! End IF (TC < 0) +! +!--- Reduce excessive accumulation of ice at upper levels +! associated with strong grid-resolved ascent +! +!--- Force NLICE to be between NLImin and NLImax +! +!--- 8/22/01: Increase density of large ice if maximum limits +! are reached for number concentration (NLImax) and mean size +! (MDImax). Done to increase fall out of ice. +! +! + + DUM = MAX(NLImin, MIN(NLImax, NLICE) ) + IF (DUM >= NLImax .AND. INDEXS >= MDImax) & + & RimeF1 = RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) +! +! WRITE(6,"(4(a12,g11.4,1x))") +! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, +! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, +! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 + + ENDIF ! End IF ( (NLICE >=NLImin .AND. NLICE >= NLImax) + ENDDO ! End DO IPASS=0,1 + ENDIF ! End IF (QI <= EPSQ .AND. ASNOW <= CLIMIT) + ENDIF ! End IF (ICE_logical) +! +!---------------------------------------------------------------------- +!--------------- Calculate individual processes ----------------------- +!---------------------------------------------------------------------- +! +!--- Cloud water autoconversion to rain and collection by rain +! + IF (QW > EPSQ .AND. TC >= T_ICE) THEN + ! + !--- QW0 could be modified based on land/sea properties, + ! presence of convection, etc. This is why QAUT0 and CRAUT + ! are passed into the subroutine as externally determined + ! parameters. Can be changed in the future if desired. + ! +! QW0 = QAUT0*RRHO + QW0 = QAUTx*RRHO*XNCW(L) + PRAUT = MAX(0., QW-QW0)*CRAUT + IF (QLICE > EPSQ) THEN + ! + !--- Collection of cloud water by large ice particles ("snow") + ! PIACWI=PIACW for riming, PIACWI=0 for shedding + ! +!Moor FWS = MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) ! 20050422 + FWS = MIN(0.1, CIACW*VEL_INC*NLICE*ACCRI(INDEXS) & + & /PP**C1) + PIACW = FWS*QW + IF (TC < 0.) PIACWI = PIACW ! Large ice riming + + ENDIF ! End IF (QLICE > EPSQ) + ENDIF ! End IF (QW > EPSQ .AND. TC >= T_ICE) +! +!---------------------------------------------------------------------- +!--- Loop around some of the ice-phase processes if no ice should be present +!---------------------------------------------------------------------- +! + IF (ICE_logical) THEN +! +!--- Now the pretzel logic of calculating ice deposition +! + IF (TC < T_ICE .AND. (WV > QSIgrd .OR. QW > EPSQ)) THEN +! +!--- Adjust to ice saturation at T DUM) PIDEP = DEPOSIT(PP, RHgrd, DUM1, DUM2) + + DWVi = 0. ! Used only for debugging +! + ELSE IF (TC < 0.) THEN +! +!--- These quantities are handy for ice deposition/sublimation +! PIDEP_max - max deposition or minimum sublimation to ice saturation +! + DENOMI = 1. + XLS2*QSI_l*TK2 + DWVi = MIN(WVQW,QSW_l)-QSI_l + PIDEP_max = MAX(PILOSS, DWVi/DENOMI) + IF (QTICE > 0.) THEN +! +!--- Calculate ice deposition/sublimation +! * SFACTOR - [VEL_INC**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], +! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) +! * Units: SFACTOR - s**.5/m ; ABI - m**2/s ; NLICE - m**-3 ; +! VENTIL, VENTIS - m**-2 ; VENTI1 - m ; +! VENTI2 - m**2/s**.5 ; DIDEP - unitless +! +! SFACTOR = VEL_INC**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 + SFACTOR = sqrt(VEL_INC)*SCHMIT_FAC + ABI = 1./(RHO*XLS3*QSI*TK2/THERM_COND+1./DIFFUS) +! +!--- VENTIL - Number concentration * ventilation factors for large ice +!--- VENTIS - Number concentration * ventilation factors for small ice +! +!--- Variation in the number concentration of ice with time is not +! accounted for in these calculations (could be in the future). +! + VENTIL = (VENTI1(INDEXS) + SFACTOR*VENTI2(INDEXS)) & + & * NLICE + VENTIS = (VENTI1(MDImin) + SFACTOR*VENTI2(MDImin)) & + & * NSmICE + DIDEP = ABI*(VENTIL+VENTIS)*DTPH +! +!--- Account for change in water vapor supply w/ time +! + IF (DIDEP >= Xratio) & + & DIDEP = (1.-EXP(-DIDEP*DENOMI))/DENOMI + IF (DWVi > 0.) THEN + PIDEP = MIN(DWVi*DIDEP, PIDEP_max) + ELSE IF (DWVi < 0.) THEN + PIDEP = MAX(DWVi*DIDEP, PIDEP_max) + ENDIF +! + ELSE IF (WVQW > QSI_l .AND. TC <= T_ICE_init) THEN +! +!--- Ice nucleation in near water-saturated conditions. Ice crystal +! growth during time step calculated using Miller & Young (1979, JAS). +!--- These deposition rates could drive conditions below water saturation, +! which is the basis of these calculations. Intended to approximate +! more complex & computationally intensive calculations. +! + INDEX_MY = MAX(MY_T1, MIN( INT(.5-TC), MY_T2 ) ) +! +!--- DUM1 is the supersaturation w/r/t ice at water-saturated conditions +! +!--- DUM2 is the number of ice crystals nucleated at water-saturated +! conditions based on Meyers et al. (JAM, 1992). +! +!--- Prevent unrealistically large ice initiation (limited by PIDEP_max) +! if DUM2 values are increased in future experiments +! + DUM1 = QSW/QSI - 1. + DUM2 = 1.E3*EXP(12.96*DUM1-0.639) + PIDEP = MIN(PIDEP_max,DUM2*MY_GROWTH(INDEX_MY)*RRHO) +! + ENDIF ! End IF (QTICE > 0.) +! + ENDIF ! End IF (TC < T_ICE .AND. (WV > QSIgrd .OR. QW > EPSQ)) +! +!------------------------------------------------------------------------ +! + ENDIF ! End of IF (ICE_logical)then loop +! +!------------------------------------------------------------------------ +! +!--- Cloud water condensation +! + IF (TC >= T_ICE .AND. (QW > EPSQ .OR. WV > QSWgrd)) THEN + IF (PIACWI == 0. .AND. PIDEP == 0.) THEN + PCOND = CONDENSE (PP, QW, RHgrd, TK, WV) + ELSE !-- Modify cloud condensation in response to ice processes + DUM = XLV*QSWgrd*RCPRV*TK2 + DENOMWI = 1. + XLS*DUM + DENOMF = XLF*DUM + DUM = MAX(0., PIDEP) + PCOND = (WV-QSWgrd-DENOMWI*DUM-DENOMF*PIACWI)/DENOMW + DUM1 = -QW + DUM2 = PCOND - PIACW + IF (DUM2 < DUM1) THEN !--- Limit cloud water sinks + DUM = DUM1/DUM2 + PCOND = DUM*PCOND + PIACW = DUM*PIACW + PIACWI = DUM*PIACWI + ENDIF ! EndIF (DUM2 < DUM1) + ENDIF ! EndIF (PIACWI == 0. .AND. PIDEP == 0.) + ENDIF ! EndIF (TC >= T_ICE .AND. (QW > EPSQ .OR. WV > QSWgrd)) +! +!--- Limit freezing of accreted rime to prevent temperature oscillations, +! a crude Schumann-Ludlam limit (p. 209 of Young, 1993). +! + TCC = TC + XLV1*PCOND + XLS1*PIDEP + XLF1*PIACWI + IF (TCC > 0.) THEN + PIACWI = 0. + TCC = TC + XLV1*PCOND + XLS1*PIDEP + ENDIF +! + IF (TC > 0. .AND. TCC > 0. .AND. ICE_logical) THEN +! +!--- Calculate melting and evaporation/condensation +! * Units: SFACTOR - s**.5/m ; ABI - m**2/s ; NLICE - m**-3 ; +! VENTIL - m**-2 ; VENTI1 - m ; +! VENTI2 - m**2/s**.5 ; CIEVP - /s +! +! SFACTOR = VEL_INC**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 + SFACTOR = sqrt(VEL_INC)*SCHMIT_FAC + VENTIL = NLICE*(VENTI1(INDEXS)+SFACTOR*VENTI2(INDEXS)) + AIEVP = VENTIL*DIFFUS*DTPH + IF (AIEVP < Xratio) THEN + DIEVP = AIEVP + ELSE + DIEVP = 1. - EXP(-AIEVP) + ENDIF +! QSW0 = EPS*ESW0/(PP-ESW0) +! QSW0 = EPS*ESW0/(PP+epsm1*ESW0) +!! dum = min(PP, ESW0) +!! QSW0 = EPS*dum/(PP+epsm1*dum) +! DWV0 = MIN(WV,QSW)-QSW0 + DWV0 = MIN(WV,QSW_l)-QSW0_l + DUM = QW + PCOND + IF (WV < QSW_l .AND. DUM <= EPSQ) THEN + ! + !--- Evaporation from melting snow (sink of snow) or shedding + ! of water condensed onto melting snow (source of rain) + ! + DUM = DWV0*DIEVP + PIEVP = MAX( MIN(0., DUM), PILOSS) + PICND = MAX(0., DUM) + ENDIF ! End IF (WV < QSW_l .AND. DUM <= EPSQ) + PIMLT = THERM_COND*TCC*VENTIL*RRHO*DTPH/XLF + ! + !--- Limit melting to prevent temperature oscillations across 0C + ! + DUM1 = MAX( 0., (TCC+XLV1*PIEVP)/XLF1 ) + PIMLT = MIN(PIMLT, DUM1) + ! + !--- Limit loss of snow by melting (>0) and evaporation + ! + DUM = PIEVP - PIMLT + IF (DUM < PILOSS) THEN + DUM1 = PILOSS/DUM + PIMLT = PIMLT*DUM1 + PIEVP = PIEVP*DUM1 + ENDIF ! End IF (DUM > QTICE) + ENDIF ! End IF (TC > 0. .AND. TCC > 0. .AND. ICE_logical) +! +!--- IMPORTANT: Estimate time-averaged properties. +! +! * TOT_RAIN - total mass of rain before microphysics, which is the sum of +! the total mass of rain in the current layer and the input +! flux of rain from above +! * VRAIN1 - fall speed of rain into grid from above (with air resistance correction) +! * QTRAIN - time-averaged mixing ratio of rain (kg/kg) +! * PRLOSS - greatest loss (<0) of rain, removing all rain falling from +! above and the rain within the layer +! * RQR - rain content (kg/m**3) +! * INDEXR - mean size of rain drops to the nearest 1 micron in size +! * N0r - intercept of rain size distribution (typically 10**6 m**-4) +! + TOT_RAIN = 0. + VRAIN1 = 0. + QTRAIN = 0. + PRLOSS = 0. + RQR = 0. + N0r = 0. + INDEXR = MDRmin + INDEXR1 = INDEXR ! For debugging only + IF (RAIN_logical) THEN + IF (ARAIN <= 0.) THEN + INDEXR = MDRmin + VRAIN1 = 0. + ELSE + ! + !--- INDEXR (related to mean diameter) & N0r could be modified + ! by land/sea properties, presence of convection, etc. + ! + !--- Rain rate normalized to a density of 1.194 kg/m**3 + ! + RR = ARAIN / (DTPH*GAMMAR) + ! + IF (RR <= RR_DRmin) THEN + ! + !--- Assume fixed mean diameter of rain (0.2 mm) for low rain rates, + ! instead vary N0r with rain rate + ! + INDEXR = MDRmin + ELSE IF (RR <= RR_DR1) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.05 and 0.10 mm: + ! V(Dr)=5.6023e4*Dr**1.136, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*5.6023e4*Dr**(4+1.136) = 1.408e15*Dr**5.136, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.123e-3*RR**.1947 -> Dr (microns) = 1.123e3*RR**.1947 + ! + INDEXR = INT( 1.123E3*RR**.1947 + .5 ) + INDEXR = MAX( MDRmin, MIN(INDEXR, MDR1) ) + + ELSE IF (RR <= RR_DR2) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.10 and 0.20 mm: + ! V(Dr)=1.0867e4*Dr**.958, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*1.0867e4*Dr**(4+.958) = 2.731e14*Dr**4.958, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.225e-3*RR**.2017 -> Dr (microns) = 1.225e3*RR**.2017 + ! + INDEXR = INT( 1.225E3*RR**.2017 + .5 ) + INDEXR = MAX( MDR1, MIN(INDEXR, MDR2) ) + + ELSE IF (RR <= RR_DR3) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.20 and 0.32 mm: + ! V(Dr)=2831.*Dr**.80, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*2831.*Dr**(4+.80) = 7.115e13*Dr**4.80, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.3006e-3*RR**.2083 -> Dr (microns) = 1.3006e3*RR**.2083 + ! + INDEXR = INT( 1.3006E3*RR**.2083 + .5 ) + INDEXR = MAX( MDR2, MIN(INDEXR, MDR3) ) + + ELSE IF (RR <= RR_DRmax) THEN + ! + !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables + ! for mean diameters (Dr) between 0.32 and 0.45 mm: + ! V(Dr)=944.8*Dr**.6636, V in m/s and Dr in m + ! RR = PI*1000.*N0r0*944.8*Dr**(4+.6636) = 2.3745e13*Dr**4.6636, + ! RR in kg/(m**2*s) + ! Dr (m) = 1.355e-3*RR**.2144 -> Dr (microns) = 1.355e3*RR**.2144 + ! + INDEXR = INT( 1.355E3*RR**.2144 + .5 ) + INDEXR = MAX( MDR3, MIN(INDEXR, MDRmax) ) + ELSE + ! + !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, + ! instead vary N0r with rain rate + ! + INDEXR = MDRmax + ENDIF ! End IF (RR <= RR_DRmin) etc. +! + VRAIN1 = GAMMAR*VRAIN(INDEXR) + ENDIF ! End IF (ARAIN <= 0.) +! + INDEXR1 = INDEXR ! For debugging only + TOT_RAIN = THICK*QR+BLEND*ARAIN + QTRAIN = TOT_RAIN/(THICK+BLDTRH*VRAIN1) + PRLOSS = -TOT_RAIN/THICK + RQR = RHO*QTRAIN + ! + !--- RQR - time-averaged rain content (kg/m**3) + ! + IF (RQR <= RQR_DRmin) THEN + N0r = MAX(N0rmin, CN0r_DMRmin*RQR) + INDEXR = MDRmin + ELSE IF (RQR >= RQR_DRmax) THEN + N0r = CN0r_DMRmax*RQR + INDEXR = MDRmax + ELSE + N0r = N0r0 +! INDEXR = MAX( XMRmin, MIN(CN0r0*RQR**.25, XMRmax) ) + item = CN0r0*sqrt(sqrt(RQR)) ! Moorthi 07/31/08 + INDEXR = MAX( MDRmin, MIN(item, MDRmax) ) ! Moorthi 07/31/08 + ENDIF + ! + IF (TC < T_ICE) THEN + PIACR = -PRLOSS + ELSE + DWVr = WV - PCOND - QSW_l + DUM = QW + PCOND + IF (DWVr < 0. .AND. DUM <= EPSQ) THEN +! +!--- Rain evaporation +! +! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], +! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) +! +! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; +! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; +! CREVP - unitless +! +! RFACTOR = GAMMAR**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 + RFACTOR = sqrt(GAMMAR)*SCHMIT_FAC + ABW = 1./(RHO*XLV2/THERM_COND+1./DIFFUS) +! +!--- Note that VENTR1, VENTR2 lookup tables do not include the +! 1/Davg multiplier as in the ice tables +! + VENTR = N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) + CREVP = ABW*VENTR*DTPH + IF (CREVP < Xratio) THEN + DUM = DWVr*CREVP + ELSE + DUM = DWVr*(1.-EXP(-CREVP*DENOMW))/DENOMW + ENDIF + PREVP = MAX(DUM, PRLOSS) + ELSE IF (QW > EPSQ) THEN + FWR = CRACW*GAMMAR*N0r*ACCRR(INDEXR) +!Moor PRACW = MIN(1.,FWR)*QW ! 20050422 + PRACW = MIN(0.1,FWR)*QW + ENDIF ! End IF (DWVr < 0. .AND. DUM <= EPSQ) +! + IF (TC < 0. .AND. TCC < 0.) THEN +! +!--- Biggs (1953) heteorogeneous freezing (e.g., Lin et al., 1983) +! - Rescaled mean drop diameter from microns (INDEXR) to mm (DUM) to prevent underflow +! + DUM = .001*FLOAT(INDEXR) + dum1 = dum * dum + DUM = (EXP(ABFR*TC)-1.)*DUM1*DUM1*DUM1*DUM + PIACR = MIN(CBFR*N0r*RRHO*DUM, QTRAIN) + IF (QLICE > EPSQ) THEN + ! + !--- Freezing of rain by collisions w/ large ice + ! + DUM = GAMMAR*VRAIN(INDEXR) + DUM1 = DUM-VSNOW + ! + !--- DUM2 - Difference in spectral fall speeds of rain and + ! large ice, parameterized following eq. (48) on p. 112 of + ! Murakami (J. Meteor. Soc. Japan, 1990) + ! + DUM2 = (DUM1*DUM1+.04*DUM*VSNOW)**.5 + DUM1 = 5.E-12*INDEXR*INDEXR+2.E-12*INDEXR*INDEXS & + & +.5E-12*INDEXS*INDEXS + FIR = MIN(1., CIACR*NLICE*DUM1*DUM2) + ! + !--- Future? Should COLLECTION BY SMALL ICE SHOULD BE INCLUDED??? + ! + PIACR = MIN(PIACR+FIR*QTRAIN, QTRAIN) + ENDIF ! End IF (QLICE > EPSQ) + DUM = PREVP - PIACR + If (DUM < PRLOSS) THEN + DUM1 = PRLOSS/DUM + PREVP = DUM1*PREVP + PIACR = DUM1*PIACR + ENDIF ! End If (DUM < PRLOSS) + ENDIF ! End IF (TC < 0. .AND. TCC < 0.) + ENDIF ! End IF (TC < T_ICE) + ENDIF ! End IF (RAIN_logical) +! +!---------------------------------------------------------------------- +!---------------------- Main Budget Equations ------------------------- +!---------------------------------------------------------------------- +! +! +!----------------------------------------------------------------------- +!--- Update fields, determine characteristics for next lower layer ---- +!----------------------------------------------------------------------- +! +!--- Carefully limit sinks of cloud water +! + DUM1 = PIACW + PRAUT + PRACW - MIN(0.,PCOND) + IF (DUM1 > QW) THEN + DUM = QW/DUM1 + PIACW = DUM*PIACW + PIACWI = DUM*PIACWI + PRAUT = DUM*PRAUT + PRACW = DUM*PRACW + IF (PCOND < 0.) PCOND=DUM*PCOND + ENDIF + PIACWR = PIACW - PIACWI ! TC >= 0C +! +!--- QWnew - updated cloud water mixing ratio +! + DELW = PCOND - PIACW - PRAUT - PRACW + QWnew = QW+DELW + IF (QWnew <= EPSQ) QWnew = 0. + IF (QW > 0. .AND. QWnew /= 0.) THEN + DUM = QWnew/QW + IF (DUM < TOLER) QWnew = 0. + ENDIF +! +!--- Update temperature and water vapor mixing ratios +! + DELT = XLV1 * (PCOND+PIEVP+PICND+PREVP) & + & + XLS1 * PIDEP + XLF1*(PIACWI+PIACR-PIMLT) + Tnew = TK + DELT +! + DELV = -PCOND - PIDEP - PIEVP - PICND - PREVP + WVnew = WV + DELV +! +!--- Update ice mixing ratios +! +!--- +! * TOT_ICEnew - total mass (small & large) ice after microphysics, +! which is the sum of the total mass of large ice in the +! current layer and the flux of ice out of the grid box below +! * RimeF - Rime Factor, which is the mass ratio of total (unrimed & +! rimed) ice mass to the unrimed ice mass (>=1) +! * QInew - updated mixing ratio of total (large & small) ice in layer +! -> TOT_ICEnew=QInew*THICK+BLDTRH*QLICEnew*VSNOW +! -> But QLICEnew=QInew*FLIMASS, so +! -> TOT_ICEnew=QInew*(THICK+BLDTRH*FLIMASS*VSNOW) +! * ASNOWnew - updated accumulation of snow at bottom of grid cell +!--- +! + DELI = 0. + RimeF = 1. + IF (ICE_logical) THEN + DELI = PIDEP + PIEVP + PIACWI + PIACR - PIMLT + TOT_ICEnew = TOT_ICE + THICK*DELI + IF (TOT_ICE > 0. .AND. TOT_ICEnew /= 0.) THEN + DUM = TOT_ICEnew/TOT_ICE + IF (DUM < TOLER) TOT_ICEnew = 0. + ENDIF + IF (TOT_ICEnew <= CLIMIT) THEN + TOT_ICEnew = 0. + RimeF = 1. + QInew = 0. + ASNOWnew = 0. + ELSE + ! + !--- Update rime factor if appropriate + ! + DUM = PIACWI + PIACR + IF (DUM <= EPSQ .AND. PIDEP <= EPSQ) THEN + RimeF = RimeF1 + ELSE + ! + !--- Rime Factor, RimeF = (Total ice mass)/(Total unrimed ice mass) + ! DUM1 - Total ice mass, rimed & unrimed + ! DUM2 - Estimated mass of *unrimed* ice + ! + DUM1 = TOT_ICE + THICK*(PIDEP+DUM) + DUM2 = TOT_ICE/RimeF1 + THICK*PIDEP + IF (DUM2 <= 0.) THEN + RimeF = RFmax + ELSE + RimeF = MIN(RFmax, MAX(1., DUM1/DUM2) ) + ENDIF + ENDIF ! End IF (DUM <= EPSQ .AND. PIDEP <= EPSQ) + QInew = TOT_ICEnew/(THICK+BLDTRH*FLIMASS*VSNOW) + IF (QInew <= EPSQ) QInew = 0. + IF (QI > 0. .AND. QInew /= 0.) THEN + DUM = QInew/QI + IF (DUM < TOLER) QInew = 0. + ENDIF + ASNOWnew = BLDTRH*FLIMASS*VSNOW*QInew + IF (ASNOW > 0. .AND. ASNOWnew /= 0.) THEN + DUM = ASNOWnew/ASNOW + IF (DUM < TOLER) ASNOWnew = 0. + ENDIF + ENDIF ! End IF (TOT_ICEnew <= CLIMIT) + ENDIF ! End IF (ICE_logical) +! +!--- Update rain mixing ratios +! +!--- +! * TOT_RAINnew - total mass of rain after microphysics +! current layer and the input flux of ice from above +! * VRAIN2 - time-averaged fall speed of rain in grid and below +! (with air resistance correction) +! * QRnew - updated rain mixing ratio in layer +! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) +! * ARAINnew - updated accumulation of rain at bottom of grid cell +!--- +! + DELR = PRAUT + PRACW + PIACWR - PIACR + PIMLT & + & + PREVP + PICND + TOT_RAINnew = TOT_RAIN+THICK*DELR + IF (TOT_RAIN > 0. .AND. TOT_RAINnew /= 0.) THEN + DUM = TOT_RAINnew/TOT_RAIN + IF (DUM < TOLER) TOT_RAINnew = 0. + ENDIF + IF (TOT_RAINnew <= CLIMIT) THEN + TOT_RAINnew = 0. + VRAIN2 = 0. + QRnew = 0. + ARAINnew = 0. + ELSE + ! + !--- 1st guess time-averaged rain rate at bottom of grid box + ! + RR = TOT_RAINnew/(DTPH*GAMMAR) + ! + !--- Use same algorithm as above for calculating mean drop diameter + ! (IDR, in microns), which is used to estimate the time-averaged + ! fall speed of rain drops at the bottom of the grid layer. This + ! isn't perfect, but the alternative is solving a transcendental + ! equation that is numerically inefficient and nasty to program + ! (coded in earlier versions of GSMCOLUMN prior to 8-22-01). + ! + IF (RR <= RR_DRmin) THEN + IDR = MDRmin + ELSE IF (RR <= RR_DR1) THEN + IDR = INT( 1.123E3*RR**.1947 + .5 ) + IDR = MAX( MDRmin, MIN(IDR, MDR1) ) + ELSE IF (RR <= RR_DR2) THEN + IDR = INT( 1.225E3*RR**.2017 + .5 ) + IDR = MAX( MDR1, MIN(IDR, MDR2) ) + ELSE IF (RR <= RR_DR3) THEN + IDR = INT( 1.3006E3*RR**.2083 + .5 ) + IDR = MAX( MDR2, MIN(IDR, MDR3) ) + ELSE IF (RR <= RR_DRmax) THEN + IDR = INT( 1.355E3*RR**.2144 + .5 ) + IDR = MAX( MDR3, MIN(IDR, MDRmax) ) + ELSE + IDR = MDRmax + ENDIF ! End IF (RR <= RR_DRmin) + VRAIN2 = GAMMAR*VRAIN(IDR) + QRnew = TOT_RAINnew / (THICK+BLDTRH*VRAIN2) + IF (QRnew <= EPSQ) QRnew = 0. + IF (QR > 0. .AND. QRnew /= 0.) THEN + DUM = QRnew / QR + IF (DUM < TOLER) QRnew = 0. + ENDIF + ARAINnew = BLDTRH*VRAIN2*QRnew + IF (ARAIN > 0. .AND. ARAINnew /= 0.) THEN + DUM = ARAINnew/ARAIN + IF (DUM < TOLER) ARAINnew = 0. + ENDIF + ENDIF ! End IF (TOT_RAINnew < CLIMIT) +! + WCnew = QWnew + QRnew + QInew +! +!---------------------------------------------------------------------- +!-------------- Begin debugging & verification ------------------------ +!---------------------------------------------------------------------- +! +!--- QT, QTnew - total water (vapor & condensate) before & after microphysics, resp. +! +! QT=THICK*(QV+WC_col(l))+ARAIN+ASNOW +! QTnew = THICK*(WVnew/(1.+WVnew)+WCnew/(1.+wcnew)) +! & + ARAINnew + ASNOWnew + + QT = THICK*(WV+WC) + ARAIN + ASNOW + QTnew = THICK*(WVnew+WCnew) + ARAINnew + ASNOWnew + BUDGET = QT-QTnew +! +!--- Additional check on budget preservation, accounting for truncation effects +! + DBG_logical=.FALSE. +! DUM=ABS(BUDGET) +! IF (DUM > TOLER) THEN +! DUM=DUM/MIN(QT, QTnew) +! IF (DUM > TOLER) DBG_logical=.TRUE. +! ENDIF +! +! DUM=(RHgrd+.001)*QSInew +! IF ( (QWnew > EPSQ .OR. QRnew > EPSQ .OR. WVnew > DUM) +! & .AND. TC < T_ICE ) DBG_logical=.TRUE. +! +! IF (TC > 5. .AND. QInewr > EPSQ) DBG_logical=.TRUE. +! + IF ((WVnew < EPSQ .OR. DBG_logical) .AND. PRINT_diag) THEN +! + WRITE(6,"(/2(a,i4),2(a,i2))") '{} i=',I_index,' j=', & + & J_index, ' L=',L,' LSFC=',LSFC +! + ESW = min(PP, FPVSL(Tnew)) +! QSWnew = EPS*ESW/(PP-ESW) + QSWnew = EPS*ESW/(PP+epsm1*ESW) + IF (TC < 0. .OR. Tnew < 0.) THEN + ESI = min(PP, FPVSI(Tnew)) +! QSInew = EPS*ESI/(PP-ESI) + QSInew = EPS*ESI/(PP+epsm1*ESI) + ELSE + QSI = QSW + QSInew = QSWnew + ENDIF + WSnew = QSInew + WRITE(6,"(4(a12,g11.4,1x))") & + & '{} TCold=',TC,'TCnew=',Tnew-T0C,'P=',.01*PP,'RHO=',RHO, & + & '{} THICK=',THICK,'RHold=',WV/WS,'RHnew=',WVnew/WSnew, & + & 'RHgrd=',RHgrd, & + & '{} RHWold=',WV/QSW,'RHWnew=',WVnew/QSWnew,'RHIold=',WV/QSI, & + & 'RHInew=',WVnew/QSInew, & + & '{} QSWold=',QSW,'QSWnew=',QSWnew,'QSIold=',QSI,'QSInew=',QSInew,& + & '{} WSold=',WS,'WSnew=',WSnew,'WVold=',WV,'WVnew=',WVnew, & + & '{} WCold=',WC,'WCnew=',WCnew,'QWold=',QW,'QWnew=',QWnew, & + & '{} QIold=',QI,'QInew=',QInew,'QRold=',QR,'QRnew=',QRnew, & + & '{} ARAINold=',ARAIN,'ARAINnew=',ARAINnew,'ASNOWold=',ASNOW, & + & 'ASNOWnew=',ASNOWnew, & + & '{} TOT_RAIN=',TOT_RAIN,'TOT_RAINnew=',TOT_RAINnew, & + & 'TOT_ICE=',TOT_ICE,'TOT_ICEnew=',TOT_ICEnew, & + & '{} BUDGET=',BUDGET,'QTold=',QT,'QTnew=',QTnew +! + WRITE(6,"(4(a12,g11.4,1x))") & + & '{} DELT=',DELT,'DELV=',DELV,'DELW=',DELW,'DELI=',DELI, & + & '{} DELR=',DELR,'PCOND=',PCOND,'PIDEP=',PIDEP,'PIEVP=',PIEVP, & + & '{} PICND=',PICND,'PREVP=',PREVP,'PRAUT=',PRAUT,'PRACW=',PRACW, & + & '{} PIACW=',PIACW,'PIACWI=',PIACWI,'PIACWR=',PIACWR,'PIMLT=', & + & PIMLT, & + & '{} PIACR=',PIACR +! + IF (ICE_logical) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} RimeF1=',RimeF1,'GAMMAS=',GAMMAS,'VrimeF=',VrimeF, & + & 'VSNOW=',VSNOW, & + & '{} INDEXS=',FLOAT(INDEXS),'FLARGE=',FLARGE,'FSMALL=',FSMALL, & + & 'FLIMASS=',FLIMASS, & + & '{} XSIMASS=',XSIMASS,'XLIMASS=',XLIMASS,'QLICE=',QLICE, & + & 'QTICE=',QTICE, & + & '{} NLICE=',NLICE,'NSmICE=',NSmICE,'PILOSS=',PILOSS, & + & 'EMAIRI=',EMAIRI, & + & '{} RimeF=',RimeF +! + IF (TOT_RAIN > 0. .OR. TOT_RAINnew > 0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} INDEXR1=',FLOAT(INDEXR1),'INDEXR=',FLOAT(INDEXR), & + & 'GAMMAR=',GAMMAR,'N0r=',N0r, & + & '{} VRAIN1=',VRAIN1,'VRAIN2=',VRAIN2,'QTRAIN=',QTRAIN,'RQR=',RQR,& + & '{} PRLOSS=',PRLOSS,'VOLR1=',THICK+BLDTRH*VRAIN1, & + & 'VOLR2=',THICK+BLDTRH*VRAIN2 +! + IF (PRAUT > 0.) WRITE(6,"(a12,g11.4,1x)") '{} QW0=',QW0 +! + IF (PRACW > 0.) WRITE(6,"(a12,g11.4,1x)") '{} FWR=',FWR +! + IF (PIACR > 0.) WRITE(6,"(a12,g11.4,1x)") '{} FIR=',FIR +! + DUM = PIMLT + PICND - PREVP - PIEVP + IF (DUM > 0. .or. DWVi /= 0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} TFACTOR=',TFACTOR,'DYNVIS=',DYNVIS, & + & 'THERM_CON=',THERM_COND,'DIFFUS=',DIFFUS +! + IF (PREVP < 0.) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} RFACTOR=',RFACTOR,'ABW=',ABW,'VENTR=',VENTR,'CREVP=',CREVP, & + & '{} DWVr=',DWVr,'DENOMW=',DENOMW +! + IF (PIDEP /= 0. .AND. DWVi /= 0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} DWVi=',DWVi,'DENOMI=',DENOMI,'PIDEP_max=',PIDEP_max, & + & 'SFACTOR=',SFACTOR, & + & '{} ABI=',ABI,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & + & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & + & '{} VENTIS=',VENTIS,'DIDEP=',DIDEP +! + IF (PIDEP > 0. .AND. PCOND /= 0.) & + & WRITE(6,"(4(a12,g11.4,1x))") & + & '{} DENOMW=',DENOMW,'DENOMWI=',DENOMWI,'DENOMF=',DENOMF, & + & 'DUM2=',PCOND-PIACW +! + IF (FWS > 0.) WRITE(6,"(4(a12,g11.4,1x))") '{} FWS=',FWS +! + DUM = PIMLT + PICND - PIEVP + IF (DUM > 0.) WRITE(6,"(4(a12,g11.4,1x))") & + & '{} SFACTOR=',SFACTOR,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS),& + & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & + & '{} AIEVP=',AIEVP,'DIEVP=',DIEVP,'QSW0=',QSW0,'DWV0=',DWV0 + ! + ENDIF +! +!---------------------------------------------------------------------- +!-------------- Water budget statistics & maximum values -------------- +!---------------------------------------------------------------------- +! + IF (PRINT_diag) THEN + ITdx = MAX( ITLO, MIN( INT(Tnew-T0C), ITHI ) ) + IF (QInew > EPSQ) NSTATS(ITdx,1) = NSTATS(ITdx,1)+1 + IF (QInew > EPSQ .AND. QRnew+QWnew > EPSQ) & + & NSTATS(ITdx,2) = NSTATS(ITdx,2)+1 + IF (QWnew > EPSQ) NSTATS(ITdx,3) = NSTATS(ITdx,3)+1 + IF (QRnew > EPSQ) NSTATS(ITdx,4) = NSTATS(ITdx,4)+1 + ! + QMAX(ITdx,1) = MAX(QMAX(ITdx,1), QInew) + QMAX(ITdx,2) = MAX(QMAX(ITdx,2), QWnew) + QMAX(ITdx,3) = MAX(QMAX(ITdx,3), QRnew) + QMAX(ITdx,4) = MAX(QMAX(ITdx,4), ASNOWnew) + QMAX(ITdx,5) = MAX(QMAX(ITdx,5), ARAINnew) + QTOT(ITdx,1) = QTOT(ITdx,1)+QInew*THICK + QTOT(ITdx,2) = QTOT(ITdx,2)+QWnew*THICK + QTOT(ITdx,3) = QTOT(ITdx,3)+QRnew*THICK + ! + QTOT(ITdx,4) = QTOT(ITdx,4)+PCOND*THICK + QTOT(ITdx,5) = QTOT(ITdx,5)+PICND*THICK + QTOT(ITdx,6) = QTOT(ITdx,6)+PIEVP*THICK + QTOT(ITdx,7) = QTOT(ITdx,7)+PIDEP*THICK + QTOT(ITdx,8) = QTOT(ITdx,8)+PREVP*THICK + QTOT(ITdx,9) = QTOT(ITdx,9)+PRAUT*THICK + QTOT(ITdx,10) = QTOT(ITdx,10)+PRACW*THICK + QTOT(ITdx,11) = QTOT(ITdx,11)+PIMLT*THICK + QTOT(ITdx,12) = QTOT(ITdx,12)+PIACW*THICK + QTOT(ITdx,13) = QTOT(ITdx,13)+PIACWI*THICK + QTOT(ITdx,14) = QTOT(ITdx,14)+PIACWR*THICK + QTOT(ITdx,15) = QTOT(ITdx,15)+PIACR*THICK + ! + QTOT(ITdx,16) = QTOT(ITdx,16)+(WVnew-WV)*THICK + QTOT(ITdx,17) = QTOT(ITdx,17)+(QWnew-QW)*THICK + QTOT(ITdx,18) = QTOT(ITdx,18)+(QInew-QI)*THICK + QTOT(ITdx,19) = QTOT(ITdx,19)+(QRnew-QR)*THICK + QTOT(ITdx,20) = QTOT(ITdx,20)+(ARAINnew-ARAIN) + QTOT(ITdx,21) = QTOT(ITdx,21)+(ASNOWnew-ASNOW) + IF (QInew > 0.) & + & QTOT(ITdx,22) = QTOT(ITdx,22)+QInew*THICK/RimeF + ! + ENDIF +! +!---------------------------------------------------------------------- +!------------------------- Update arrays ------------------------------ +!---------------------------------------------------------------------- +! + T_col(L) = Tnew ! temperature +! +! QV_col(L) = max(EPSQ, WVnew/(1.+WVnew)) ! specific humidity + QV_col(L) = max(0.0, WVnew ) ! specific humidity + WC_col(L) = max(0.0, WCnew) ! total condensate mixing ratio + QI_col(L) = max(0.0, QInew) ! ice mixing ratio + QR_col(L) = max(0.0, QRnew) ! rain mixing ratio + QW_col(L) = max(0.0, QWnew) ! cloud water mixing ratio + RimeF_col(L) = RimeF ! rime factor + ASNOW = ASNOWnew ! accumulated snow + ARAIN = ARAINnew ! accumulated rain +! +!####################################################################### +! + ENDIF ! End of IF (.NOT. CLEAR) THEN + ENDIF ! End of IF (QV_col(L) <= EPSQ .AND. WC_col(L) <= EPSQ) THEN +! + ENDDO ! ##### End "L" loop through model levels ##### +! + ARAING = ARAING + ARAIN + ASNOWG = ASNOWG + ASNOW + enddo ! do for ntimes=1,mic_step +! +!####################################################################### +! +!----------------------------------------------------------------------- +!--------------------------- Return to GSMDRIVE ----------------------- +!----------------------------------------------------------------------- +! + CONTAINS +! END SUBROUTINE GSMCOLUMN +! +!####################################################################### +!--------- Produces accurate calculation of cloud condensation --------- +!####################################################################### +! + REAL FUNCTION CONDENSE (PP, QW, RHgrd, TK, WV) +! + implicit none +! +!--------------------------------------------------------------------------------- +!------ The Asai (1965) algorithm takes into consideration the release of ------ +!------ latent heat in increasing the temperature & in increasing the ------ +!------ saturation mixing ratio (following the Clausius-Clapeyron eqn.). ------ +!--------------------------------------------------------------------------------- +! + real pp, qw, rhgrd, tk, wv + INTEGER, PARAMETER :: HIGH_PRES=kind_phys +! INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) + REAL (KIND=HIGH_PRES), PARAMETER :: & + & RHLIMIT=.001, RHLIMIT1=-RHLIMIT + REAL, PARAMETER :: RCP=1./CP, RCPRV=RCP/RV + REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum, tsq + real wvdum, tdum, xlv, xlv1, xlv2, ws, dwv, esw, rfac +! +!----------------------------------------------------------------------- +! +!--- LV (T) is from Bolton (JAS, 1980) +! +! XLV=3.148E6-2370.*TK +! XLV1=XLV*RCP +! XLV2=XLV*XLV*RCPRV +! + Tdum = TK + WVdum = WV + WCdum = QW + ESW = min(PP, FPVSL(Tdum)) ! Saturation vapor press w/r/t water +! WS = RHgrd*EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water + WS = RHgrd*EPS*ESW/(PP+epsm1*ESW) ! Saturation specific hum w/r/t water + DWV = WVdum - WS ! Deficit grid-scale specific humidity + SSAT = DWV / WS ! Supersaturation ratio + CONDENSE = 0. + rfac = 0.5 ! converges faster with 0.5 + DO WHILE ((SSAT < RHLIMIT1 .AND. WCdum > EPSQ) & + & .OR. SSAT > RHLIMIT) +! + XLV = 3.148E6-2370.*Tdum + XLV1 = XLV*RCP + XLV2 = XLV*XLV*RCPRV +! +! COND = DWV/(1.+XLV2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) + tsq = Tdum*Tdum + COND = rfac*DWV*tsq/(tsq+XLV2*WS) ! Asai (1965, J. Japan) +! COND = DWV*tsq/(tsq+XLV2*WS) ! Asai (1965, J. Japan) + COND = MAX(COND, -WCdum) ! Limit cloud water evaporation + Tdum = Tdum+XLV1*COND ! Updated temperature + WVdum = WVdum-COND ! Updated water vapor mixing ratio + WCdum = WCdum+COND ! Updated cloud water mixing ratio + CONDENSE = CONDENSE + COND ! Total cloud water condensation + ESW = min(PP, FPVSL(Tdum)) ! Updated saturation vapor press w/r/t water +! WS = RHgrd*EPS*ESW/(PP-ESW) ! Updated saturation mixing ratio w/r/t water + WS = RHgrd*EPS*ESW/(PP+epsm1*ESW) ! Updated saturation mixing ratio w/r/t water + DWV = WVdum-WS ! Deficit grid-scale water vapor mixing ratio + SSAT = DWV / WS ! Grid-scale supersaturation ratio + rfac = 1.0 + ENDDO + + END FUNCTION CONDENSE +! +!####################################################################### +!---------------- Calculate ice deposition at T RHLIMIT .OR. SSAT < RHLIMIT1) + ! + !--- Note that XLVS2=LS*LV/(CP*RV)=LV*WS/(RV*T*T)*(LS/CP*DEP1), + ! where WS is the saturation mixing ratio following Clausius- + ! Clapeyron (see Asai,1965; Young,1993,p.405) + ! + DEP=DWV/(1.+XLS2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) + Tdum=Tdum+XLS1*DEP ! Updated temperature + WVdum=WVdum-DEP ! Updated ice mixing ratio + DEPOSIT=DEPOSIT+DEP ! Total ice deposition + ESI=min(PP, FPVSI(Tdum)) ! Updated saturation vapor press w/r/t ice +! WS=RHgrd*EPS*ESI/(PP-ESI) ! Updated saturation mixing ratio w/r/t ice + WS=RHgrd*EPS*ESI/(PP+epsm1*ESI) ! Updated saturation mixing ratio w/r/t ice + DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio + SSAT=DWV/WS ! Grid-scale supersaturation ratio + ENDDO + END FUNCTION DEPOSIT +! + END SUBROUTINE GSMCOLUMN + + + SUBROUTINE rsipath(im, ix, ix2, levs, prsl, prsi, t, q, clw & + &, f_ice, f_rain, f_rime, flgmin & + &, cwatp, cicep, rainp, snowp & + &, recwat, rerain, resnow, lprnt, ipr) +! + implicit none +! +!--------------------CLOUD---------------------------------------------- + integer im, ix, ix2, levs, ipr + real prsl(ix,levs), prsi(ix,levs+1), t(ix,levs), q(ix,levs) & + &, clw(ix2,levs), f_ice(ix2,levs), f_rain(ix2,levs) & + &, f_rime(ix2,levs) & + &, cwatp(ix,levs), rainp(ix,levs), cicep(ix,levs) & + &, snowp(ix,levs), recwat(ix,levs), resnow(ix,levs) & + &, rerain(ix,levs) + real flgmin + real frice, frrain, qcice, qcwat, qrain, qsnow, qtot, sden & + &, cpath, rho, dsnow, flarge, rimef, xsimass, nlice & + &, tc, recw1, drain, xli, dum, NLImax, pfac, pp & + &, snofac, tem +! + real, parameter :: cexp=1./3. + integer i, l, indexs + logical lprnt +! + + RECW1 = 620.3505 / TNW**CEXP ! cloud droplet effective radius + + do l=1,levs + do i=1,im + !--- HYDROMETEOR'S OPTICAL PATH + CWATP(I,L) = 0. + CICEP(I,L) = 0. + RAINP(I,L) = 0. + SNOWP(I,L) = 0. + !--- HYDROMETEOR'S EFFECTIVE RADIUS + RECWAT(I,L) = RECWmin + RERAIN(I,L) = RERAINmin + RESNOW(I,L) = RESNOWmin + ENDDO + ENDDO + + do l=1,levs + DO I=1,im + + ! Assume parameterized condensate is + ! all water for T>=-10C, + ! all ice for T<=-30C, + ! and a linear mixture at -10C > T > -30C + ! + ! * Determine hydrometeor composition of total condensate (QTOT) + ! +! pp = prsl(i,l) * 1000.0 + pp = prsl(i,l) / prsi(i,levs+1) +! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.000025)))) +! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.000025)))) +! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.00002)))) +! pfac = max(0.25, sqrt(sqrt(min(1.0, pp*0.00001)))) +! pfac = max(0.25, sqrt(sqrt(min(1.0, pp)))) +! pfac = max(0.1, sqrt(min(1.0, pp*0.00001))) +! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.000033)))) +! pfac = max(0.5, sqrt(sqrt(min(1.0, pp*0.00004)))) +!go pfac = max(0.5, (sqrt(min(1.0, pp*0.000025)))) + pfac = 1.0 + TC = T(I,L) - t0c + QTOT = clw(I,L) + IF (QTOT > EPSQ) THEN + QCWAT=0. + QCICE=0. + QRAIN=0. + QSNOW=0. + FRice = max(0.0, min(1.0, F_ice(I,L))) + FRrain = max(0.0, min(1.0, F_rain(I,L))) + IF(TC <= Thom) then + QCICE = QTOT + ELSE + QCICE = FRice * QTOT + QCWAT = QTOT - QCICE + QRAIN = FRrain * QCWAT + QCWAT = QCWAT - QRAIN + ENDIF + ! + !--- Air density (RHO), model mass thickness (CPATH) + ! + RHO = PRSL(I,L)/(RD*T(I,L)*(1.+EPS1*Q(I,L))) + CPATH = (PRSI(I,L+1)-PRSI(I,L))*(1000000.0/grav) + + !! CLOUD WATER + ! + !--- Effective radius (RECWAT) & total water path (CWATP) + ! Assume monodisperse distribution of droplets (no factor of 1.5) + ! + IF(QCWAT > 0.) THEN + RECWAT(I,L) = MAX(RECWmin, RECW1*(RHO*QCWAT)**CEXP) + CWATP(I,L) = CPATH*QCWAT ! cloud water path +! tem = 5.0*(1+max(0.0,min(1.0,-0.05*tc))) +! RECWAT(I,L) = max(RECWAT(I,L), tem) + ENDIF + + !! RAIN + ! + !--- Effective radius (RERAIN) & total water path (RAINP) + !--- Factor of 1.5 accounts for r**3/r**2 moments for exponentially + ! distributed drops in effective radius calculations + ! (from M.D. Chou's code provided to Y.-T. Hou) + ! + IF(QRAIN > 0.) THEN + DRAIN = CN0r0*sqrt(sqrt((RHO*QRAIN))) + RERAIN(I,L) = 1.5*MAX(XMRmin, MIN(DRAIN, XMRmax)) + RAINP(I,L) = CPATH*QRAIN ! rain water path + ENDIF + + !! SNOW (large ice) & CLOUD ICE + ! + !--- Effective radius (RESNOW) & total ice path (SNOWP) + !--- Total ice path (CICEP) for cloud ice + !--- Factor of 1.5 accounts for r**3/r**2 moments for exponentially + ! distributed ice particles in effective radius calculations + ! + !--- Separation of cloud ice & "snow" uses algorithm from + ! subroutine GSMCOLUMN + ! + IF(QCICE > 0.) THEN + ! + !--- Mean particle size following Houze et al. (JAS, 1979, p. 160), + ! converted from Fig. 5 plot of LAMDAs. An analogous set of + ! relationships also shown by Fig. 8 of Ryan (BAMS, 1996, p. 66), + ! but with a variety of different relationships that parallel the + ! Houze curves. + ! +! DUM=MAX(0.05, MIN(1., EXP(.0536*TC)) ) + DUM=MAX(0.05, MIN(1., EXP(.0564*TC)) ) + INDEXS=MIN(MDImax, MAX(MDImin, INT(XMImax*DUM) ) ) +! indexs=max(INDEXSmin, indexs) +! NLImax=5.E3/sqrt(DUM) !- Ver3 + DUM=MAX(FLGmin*pfac, DUM) +! DUM=MAX(FLGmin, DUM) +! NLImax=20.E3 !- Ver3 +! NLImax=50.E3 !- Ver3 => comment this line out + NLImax=10.E3/sqrt(DUM) !- Ver3 +! NLImax=5.E3/sqrt(DUM) !- Ver3 +! NLImax=6.E3/sqrt(DUM) !- Ver3 +! NLImax=7.5E3/sqrt(DUM) !- Ver3 +! NLImax=20.E3/DUM !- Ver3 +! NLImax=20.E3/max(0.2,DUM) !- Ver3 +! NLImax=2.0E3/max(0.1,DUM) !- Ver3 +! NLImax=2.5E3/max(0.1,DUM) !- Ver3 +! NLImax=10.E3/max(0.2,DUM) !- Ver3 +! NLImax=4.E3/max(0.2,DUM) !- Ver3 +!Moorthi DSNOW = XMImax*EXP(.0536*TC) +!Moorthi INDEXS = MAX(INDEXSmin, MIN(MDImax, INT(DSNOW))) + ! + !--- Assumed number fraction of large ice to total (large & small) + ! ice particles, which is based on a general impression of the + ! literature. + ! + ! Small ice are assumed to have a mean diameter of 50 microns. + ! + IF(TC >= 0.) THEN + FLARGE=FLG1P0 + ELSE + FLARGE = dum + ENDIF +!------------------------Commented by Moorthi ----------------------------- +! ELSEIF (TC >= -25.) THEN +! +!--- Note that absence of cloud water (QCWAT) is used as a quick +! substitute for calculating water subsaturation as in GSMCOLUMN +! +! IF(QCWAT <= 0. .OR. TC < -8. +! & .OR. TC > -3.)THEN +! FLARGE=FLG0P2 +! ELSE + +!--- Parameterize effects of rime splintering by increasing +! number of small ice particles +! +! FLARGE=FLG0P1 +! ENDIF +! ELSEIF (TC <= -50.) THEN +! FLARGE=.01 +! ELSE +! FLARGE=.2*EXP(.1198*(TC+25)) +! ENDIF +!____________________________________________________________________________ + + RimeF=MAX(1., F_RIME(I,L)) + XSIMASS=MASSI(MDImin)*(1.-FLARGE)/FLARGE +! if (lprnt) print *,' rimef=',rimef,' xsimass=',xsimass +! &,' indexs=',indexs,' massi=',massi(indexs),' flarge=',flarge + NLICE=RHO*QCICE/(XSIMASS+RimeF*MASSI(INDEXS)) + ! + !--- From subroutine GSMCOLUMN: + !--- Minimum number concentration for large ice of NLImin=10/m**3 + ! at T>=0C. Done in order to prevent unrealistically small + ! melting rates and tiny amounts of snow from falling to + ! unrealistically warm temperatures. + ! + IF(TC >= 0.) THEN + NLICE=MAX(NLImin, NLICE) + ELSEIF (NLICE > NLImax) THEN + ! + !--- Ferrier 6/13/01: Prevent excess accumulation of ice + ! + XLI=(RHO*QCICE/NLImax-XSIMASS)/RimeF + + IF(XLI <= MASSI(450) ) THEN + DSNOW=9.5885E5*XLI**.42066 + ELSE + DSNOW=3.9751E6*XLI**.49870 + ENDIF + + INDEXS=MIN(MDImax, MAX(INDEXS, INT(DSNOW))) + NLICE=RHO*QCICE/(XSIMASS+RimeF*MASSI(INDEXS)) + ENDIF + +! if (tc > -20.0 .and. indexs >= indexsmin) then +! snofac = max(0.0, min(1.0, exp(1.0*(tc+20.0)))) +! if (indexs >= indexsmin) then +! if (tc > -20.0 .or. indexs >= indexsmin) then +! if (tc > -40.0) then +! if (tc >= -40.0 .or. prsl(i,l) > 50.0) then +!! if (tc >= -20.0) then +! if (tc >= -20.0 .or. prsl(i,l) > 50.0) then +! if ((tc >= -20.0 .or. +! & prsi(i,levs+1)-prsi(i,l) < 30.0) + if (prsi(i,levs+1)-prsi(i,l) < 40.0 & +! if (prsi(i,levs+1)-prsi(i,l) < 70.0 + & .and. indexs >= indexsmin) then +! & prsi(i,levs)-prsl(i,l) < 20.0) then +! & prsi(i,levs)-prsl(i,l) < 30.0) then +! & prsi(i,levs)-prsl(i,l) < 40.0) then +! snofac = max(0.0, min(1.0, 0.05*(tc+40.0))) +! snofac = max(0.0, min(1.0, 0.1*(tc+25.0))) +! snofac = max(0.0, min(1.0, 0.0667*(tc+25.0))) +! if (indexs > indexsmin) then + QSNOW = MIN(QCICE, NLICE*RimeF*MASSI(INDEXS)/RHO) +! & * snofac + endif +! qsnow = qcice + QCICE = MAX(0., QCICE-QSNOW) +! qsnow = 0.0 + CICEP (I,L) = CPATH*QCICE ! cloud ice path + RESNOW(I,L) = 1.5*FLOAT(INDEXS) + SDEN = SDENS(INDEXS)/RimeF ! 1/snow density + SNOWP (I,L) = CPATH*QSNOW*SDEN ! snow path / snow density +! SNOWP (I,L) = CPATH*QSNOW ! snow path / snow density +! if (lprnt .and. i == ipr) then +! print *,' L=',L,' snowp=',snowp(i,l),' cpath=',cpath +! &,' qsnow=',qsnow,' sden=',sden,' rimef=',rimef,' indexs=',indexs +! &,' sdens=',sdens(indexs),' resnow=',resnow(i,l) +! &,' qcice=',qcice,' cicep=',cicep(i,l) +! endif + + + ENDIF ! END QCICE BLOCK + ENDIF ! QTOT IF BLOCK + + ENDDO + ENDDO +! + END SUBROUTINE rsipath + + + +!----------------------------------- + subroutine rsipath2 & +!................................... + +! --- inputs: + & ( plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime, & + & IM, LEVS, iflip, flgmin, & +! --- outputs: + & cwatp, cicep, rainp, snowp, recwat, rerain, resnow, snden & + & ) + +! ================= subprogram documentation block ================ ! +! ! +! abstract: this program is a modified version of ferrier's original ! +! "rsipath" subprogram. it computes layer's cloud liquid, ice, rain, ! +! and snow water condensate path and the partical effective radius ! +! for liquid droplet, rain drop, and snow flake. ! +! ! +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! plyr (IM,LEVS) : model layer mean pressure in mb (100Pa) ! +! plvl (IM,LEVS+1):model level pressure in mb (100Pa) ! +! tlyr (IM,LEVS) : model layer mean temperature in k ! +! qlyr (IM,LEVS) : layer specific humidity in gm/gm ! +! qcwat (IM,LEVS) : layer cloud liquid water condensate amount ! +! qcice (IM,LEVS) : layer cloud ice water condensate amount ! +! qrain (IM,LEVS) : layer rain drop water amount ! +! rrime (IM,LEVS) : mass ratio of total to unrimed ice ( >= 1 ) ! +! IM : horizontal dimention ! +! LEVS : vertical layer dimensions ! +! iflip : control flag for in/out vertical indexing ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! flgmin : Minimum large ice fraction ! +! lprnt : logical check print control flag ! +! ! +! output variables: ! +! cwatp (IM,LEVS) : layer cloud liquid water path ! +! cicep (IM,LEVS) : layer cloud ice water path ! +! rainp (IM,LEVS) : layer rain water path ! +! snowp (IM,LEVS) : layer snow water path ! +! recwat(IM,LEVS) : layer cloud eff radius for liqid water (micron) ! +! rerain(IM,LEVS) : layer rain water effective radius (micron) ! +! resnow(IM,LEVS) : layer snow flake effective radius (micron) ! +! snden (IM,LEVS) : 1/snow density ! +! ! +! ! +! usage: call rsipath2 ! +! ! +! subroutines called: none ! +! ! +! program history log: ! +! xx-xx-2001 b. ferrier - original program ! +! xx-xx-2004 s. moorthi - modified for use in gfs model ! +! 05-20-2004 y. hou - modified, added vertical index flag! +! to reduce data flipping, and rearrange code to ! +! be comformable with radiation part programs. ! +! ! +! ==================== end of description ===================== ! +! + + implicit none + +! --- constant parameter: + real, parameter :: CEXP= 1.0/3.0 + +! --- inputs: + real, dimension(:,:), intent(in) :: & + & plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime + + integer, intent(in) :: IM, LEVS, iflip + real, dimension(:), intent(in) :: flgmin +! logical, intent(in) :: lprnt + +! --- output: + real, dimension(:,:), intent(out) :: & + & cwatp, cicep, rainp, snowp, recwat, rerain, resnow, snden + +! --- locals: +! real, dimension(IM,LEVS) :: delp, pp1, pp2 + + real :: recw1, dsnow, qsnow, qqcice, flarge, xsimass, pfac, & + & nlice, xli, nlimax, dum, tem, & + & rho, cpath, rc, totcnd, tc + + integer :: i, k, indexs, ksfc, k1 +! +!===> ... begin here +! + recw1 = 620.3505 / TNW**CEXP ! cloud droplet effective radius + + do k = 1, LEVS + do i = 1, IM + !--- hydrometeor's optical path + cwatp(i,k) = 0.0 + cicep(i,k) = 0.0 + rainp(i,k) = 0.0 + snowp(i,k) = 0.0 + snden(i,k) = 0.0 + !--- hydrometeor's effective radius + recwat(i,k) = RECWmin + rerain(i,k) = RERAINmin + resnow(i,k) = RESNOWmin + enddo + enddo + +! --- set up pressure related arrays, convert unit from mb to cb (10Pa) +! cause the rest part uses cb in computation + + if (iflip == 0) then ! data from toa to sfc + ksfc = levs + 1 + k1 = 0 + else ! data from sfc to top + ksfc = 1 + k1 = 1 + endif ! end_if_iflip +! + do k = 1, LEVS + do i = 1, IM + totcnd = qcwat(i,k) + qcice(i,k) + qrain(i,k) + qsnow = 0.0 + if(totcnd > EPSQ) then + +! --- air density (rho), model mass thickness (cpath), temperature in c (tc) + + rho = 0.1 * plyr(i,k) & + & / (RD* tlyr(i,k) * (1.0 + EPS1*qlyr(i,k))) + cpath = abs(plvl(i,k+1) - plvl(i,k)) * (100000.0 / GRAV) + tc = tlyr(i,k) - T0C + +!! cloud water +! +! --- effective radius (recwat) & total water path (cwatp): +! assume monodisperse distribution of droplets (no factor of 1.5) + + if (qcwat(i,k) > 0.0) then + recwat(i,k) = max(RECWmin,recw1*(rho*qcwat(i,k))**CEXP) + cwatp (i,k) = cpath * qcwat(i,k) ! cloud water path +! tem = 5.0*(1.0 + max(0.0, min(1.0,-0.05*tc))) +! recwat(i,k) = max(recwat(i,k), tem) + endif + +!! rain +! +! --- effective radius (rerain) & total water path (rainp): +! factor of 1.5 accounts for r**3/r**2 moments for exponentially +! distributed drops in effective radius calculations +! (from m.d. chou's code provided to y.-t. hou) + + if (qrain(i,k) > 0.0) then + tem = CN0r0 * sqrt(sqrt(rho*qrain(i,k))) + rerain(i,k) = 1.5 * max(XMRmin, min(XMRmax, tem)) + rainp (i,k) = cpath * qrain(i,k) ! rain water path + endif + +!! snow (large ice) & cloud ice +! +! --- effective radius (resnow) & total ice path (snowp) for snow, and +! total ice path (cicep) for cloud ice: +! factor of 1.5 accounts for r**3/r**2 moments for exponentially +! distributed ice particles in effective radius calculations +! separation of cloud ice & "snow" uses algorithm from subroutine gsmcolumn + +! pfac = max(0.5, sqrt(sqrt(min(1.0, pp1(i,k)*0.00004)))) +!go pfac = max(0.5, (sqrt(min(1.0, pp1(i,k)*0.000025)))) + pfac = 1.0 + + if (qcice(i,k) > 0.0) then + +! --- mean particle size following houze et al. (jas, 1979, p. 160), +! converted from fig. 5 plot of lamdas. an analogous set of +! relationships also shown by fig. 8 of ryan (bams, 1996, p. 66), +! but with a variety of different relationships that parallel +! the houze curves. + +! dum = max(0.05, min(1.0, exp(0.0536*tc) )) + dum = max(0.05, min(1.0, exp(0.0564*tc) )) + indexs = min(MDImax, max(MDImin, int(XMImax*dum) )) + DUM=MAX(FLGmin(i)*pfac, DUM) + +! --- assumed number fraction of large ice to total (large & small) ice +! particles, which is based on a general impression of the literature. +! small ice are assumed to have a mean diameter of 50 microns. + + if (tc >= 0.0) then + flarge = FLG1P0 + else + flarge = dum +! flarge = max(FLGmin*pfac, dum) + endif +!------------------------commented by moorthi ----------------------------- +! elseif (tc >= -25.0) then +! +! --- note that absence of cloud water (qcwat) is used as a quick +! substitute for calculating water subsaturation as in gsmcolumn +! +! if (qcwat(i,k) <= 0.0 .or. tc < -8.0 & +! & .or. tc > -3.0) then +! flarge = FLG0P2 +! else +! +! --- parameterize effects of rime splintering by increasing +! number of small ice particles +! +! flarge = FLG0P1 +! endif +! elseif (tc <= -50.0) then +! flarge = 0.01 +! else +! flarge = 0.2 * exp(0.1198*(tc+25.0)) +! endif +!____________________________________________________________________________ + + xsimass = MASSI(MDImin) * (1.0 - flarge) / flarge +! nlimax = 20.0e3 !- ver3 +! NLImax=50.E3 !- Ver3 => comment this line out + NLImax=10.E3/sqrt(DUM) !- Ver3 +! NLImax=5.E3/sqrt(DUM) !- Ver3 +! NLImax=6.E3/sqrt(DUM) !- Ver3 +! NLImax=7.5E3/sqrt(DUM) !- Ver3 + +! indexs = min(MDImax, max(MDImin, int(XMImax*dum) )) +!moorthi dsnow = XMImax * exp(0.0536*tc) +!moorthi indexs = max(INDEXSmin, min(MDImax, int(dsnow))) + +! if (lprnt) print *,' rrime=',rrime,' xsimass=',xsimass, & +! & ' indexs=',indexs,' massi=',massi(indexs),' flarge=',flarge + + tem = rho * qcice(i,k) + nlice = tem / (xsimass +rrime(i,k)*MASSI(indexs)) + +! --- from subroutine gsmcolumn: +! minimum number concentration for large ice of NLImin=10/m**3 +! at t>=0c. done in order to prevent unrealistically small +! melting rates and tiny amounts of snow from falling to +! unrealistically warm temperatures. + + if (tc >= 0.0) then + + nlice = max(NLImin, nlice) + + elseif (nlice > nlimax) then + +! --- ferrier 6/13/01: prevent excess accumulation of ice + + xli = (tem/nlimax - xsimass) / rrime(i,k) + + if (xli <= MASSI(450) ) then + dsnow = 9.5885e5 * xli**0.42066 + else + dsnow = 3.9751e6 * xli** 0.49870 + endif + + indexs = min(MDImax, max(indexs, int(dsnow))) + nlice = tem / (xsimass + rrime(i,k)*MASSI(indexs)) + + endif ! end if_tc block + +! if (abs(plvl(i,ksfc)-plvl(i,k+k1)) < 300.0 & +! if (abs(plvl(i,ksfc)-plvl(i,k+k1)) < 400.0 & +! if (plvl(i,k+k1) > 600.0 & +! & .and. indexs >= INDEXSmin) then +! if (tc > -20.0 .and. indexs >= indexsmin) then + if (plvl(i,ksfc) > 850.0 .and. & +! & plvl(i,k+k1) > 600.0 .and. indexs >= indexsmin) then + & plvl(i,k+k1) > 700.0 .and. indexs >= indexsmin) then ! 20060516 +!! if (plvl(i,ksfc) > 800.0 .and. & +!! & plvl(i,k+k1) > 700.0 .and. indexs >= indexsmin) then +! if (plvl(i,ksfc) > 700.0 .and. & +! & plvl(i,k+k1) > 600.0 .and. indexs >= indexsmin) then + qsnow = min( qcice(i,k), & + & nlice*rrime(i,k)*MASSI(indexs)/rho ) + endif + + qqcice = max(0.0, qcice(i,k)-qsnow) + cicep (i,k) = cpath * qqcice ! cloud ice path + resnow(i,k) = 1.5 * float(indexs) + snden (i,k) = SDENS(indexs) / rrime(i,k) ! 1/snow density + snowp (i,k) = cpath*qsnow ! snow path +! snowp (i,k) = cpath*qsnow*snden(i,k) ! snow path / snow density + +! if (lprnt .and. i == ipr) then +! if (i == 2) then +! print *,' L=',k,' snowp=',snowp(i,k),' cpath=',cpath, & +! & ' qsnow=',qsnow,' sden=',snden(i,k),' rrime=',rrime(i,k),& +! & ' indexs=',indexs,' sdens=',sdens(indexs),' resnow=', & +! & resnow(i,k),' qcice=',qqcice,' cicep=',cicep(i,k) +! endif + + endif ! end if_qcice block + endif ! end if_totcnd block + + enddo + enddo +! +!................................... + end subroutine rsipath2 +!----------------------------------- + + end MODULE module_microphysics + diff --git a/gsmphys/module_nst_model.f90 b/gsmphys/module_nst_model.f90 new file mode 100644 index 00000000..f2b05c11 --- /dev/null +++ b/gsmphys/module_nst_model.f90 @@ -0,0 +1,924 @@ +module nst_module + +! +! the module of diurnal thermocline layer model +! + use machine , only : kind_phys + use module_nst_parameters, only: z_w_max,z_w_min,z_w_ini,eps_z_w,eps_conv, & + eps_sfs,niter_z_w,niter_conv,niter_sfs,ri_c, & + ri_g,omg_m,omg_sh, kw => tc_w,visw,t0k,cp_w, & + z_c_max,z_c_ini,ustar_a_min,delz,exp_const, & + rad2deg,const_rot,tw_max,sst_max + use module_nst_water_prop, only: sw_rad_skin,sw_ps_9b,sw_ps_9b_aw + implicit none + + contains + + subroutine dtm_1p(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & + alpha,beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& + hl_ts,rho,alpha,beta,alon,sinlat,soltim,& + grav,le,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts +! local variables + +! +! input variables +! +! timestep: integration time step in seconds +! rich : critical ri (flow dependent) +! tox : x wind stress (n*m^-2 or kg/m/s^2) +! toy : y wind stress (n*m^-2 or kg/m/s^2) +! i0 : solar radiation flux at the surface (wm^-2) +! q : non-solar heat flux at the surface (wm^-2) +! sss : salinity (ppt) +! sep : sr(e-p) (ppt*m/s) +! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes +! hl_ts : d(hl)/d(ts) +! rho : sea water density (kg*m^-3) +! alpha : thermal expansion coefficient (1/k) +! beta : saline contraction coefficient (1/ppt) +! sinlat : sine (lat) +! grav : gravity accelleration +! le : le=(2.501-.00237*tsea)*1e6 +! d-conv : fcl thickness +! +! inout variables +! +! xt : dtl heat content (m*k) +! xs : dtl salinity content (m*ppt) +! xu : dtl x current content (m*m/s) +! xv : dtl y current content (m*m/s) +! xz : dtl thickness (m) +! xzts : d(xz)/d(ts) (m/k ) +! xtts : d(xt)/d(ts) (m) +! +! logical lprnt + +! if (lprnt) print *,' first xt=',xt + if ( xt <= 0.0 ) then ! dtl doesn't exist yet + call dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,& + beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) + elseif ( xt > 0.0 ) then ! dtl already exists +! +! forward the system one time step +! + call eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha, & + beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + endif ! if ( xt == 0 ) then + + end subroutine dtm_1p + + subroutine eulerm(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho,alpha,& + beta,alon,sinlat,soltim,grav,le,d_conv, & + xt,xs,xu,xv,xz,xzts,xtts) + +! +! subroutine eulerm: integrate one time step with modified euler method +! + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& + hl_ts,rho,alpha,beta,alon,sinlat,soltim,& + grav,le,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts +! local variables + real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0,xzts0,xtts0 + real(kind=kind_phys) :: fw,aw,q_warm + real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1,xzts1,xtts1 + real(kind=kind_phys) :: xt2,xs2,xu2,xv2,xz2,xzts2,xtts2 + real(kind=kind_phys) :: dzw,drho,fc + real(kind=kind_phys) :: alat,speed +! logical lprnt + +! +! input variables +! +! timestep: integration time step in seconds +! rich : critial ri (flow/mass dependent) +! tox : x wind stress (n*m^-2 or kg/m/s^2) +! toy : y wind stress (n*m^-2 or kg/m/s^2) +! i0 : solar radiation flux at the surface (wm^-2) +! q : non-solar heat flux at the surface (wm^-2) +! sss : salinity (ppt) +! sep : sr(e-p) (ppt*m/s) +! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes +! hl_ts : d(hl)/d(ts) +! rho : sea water density (kg*m^-3) +! alpha : thermal expansion coefficient (1/k) +! beta : saline contraction coefficient (1/ppt) +! alon : longitude (deg) +! sinlat : sine (lat) +! soltim : solar time +! grav : gravity accelleration +! le : le=(2.501-.00237*tsea)*1e6 +! d_conv : fcl thickness (m) +! +! inout variables +! +! xt : dtl heat content (m*k) +! xs : dtl salinity content (m*ppt) +! xu : dtl x current content (m*m/s) +! xv : dtl y current content (m*m/s) +! xz : dtl thickness (m) +! xzts : d(xz)/d(ts) (m/k ) +! xtts : d(xt)/d(ts) (m) + + xt0 = xt + xs0 = xs + xu0 = xu + xv0 = xv + xz0 = xz + xtts0 = xtts + xzts0 = xzts + speed = max(1.0e-8, xu0*xu0+xv0*xv0) + + alat = asin(sinlat)*rad2deg + + fc = const_rot*sinlat + + call sw_ps_9b(xz0,fw) + + q_warm = fw*i0-q !total heat abs in warm layer + + call sw_ps_9b_aw(xz0,aw) + + drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep + +! dzw = xz0*(tox*xu0+toy*xv0) / (rho*(xu0*xu0+xv0*xv0)) & +! + xz0*xz0*xz0*drho*grav / (4.0*rich*(xu0*xu0+xv0*xv0)) + dzw = xz0 * ((tox*xu0+toy*xv0) / (rho*speed) & + + xz0*xz0*drho*grav / (4.0*rich*speed)) + + xt1 = xt0 + timestep*q_warm/(rho*cp_w) + xs1 = xs0 + timestep*sep + xu1 = xu0 + timestep*(fc*xv0+tox/rho) + xv1 = xv0 + timestep*(-fc*xu0+toy/rho) + xz1 = xz0 + timestep*dzw + +! if (lprnt) print *,' xt1=',xt1,' xz1=',xz1,' xz0=',xz0,' dzw=',dzw, & +! 'timestep=',timestep,tox,toy,xu0,xv0,rho,drho,grav,rich + + if ( xt1 <= 0.0 .or. xz1 <= 0.0 .or. xz1 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + return + endif + +! call dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt1,xs1,xu1,xv1,xz1,tr_mda,tr_fca,tr_tla,tr_mwa) + + xzts1 = xzts0 + timestep*((1.0/(xu0*xu0+xv0*xv0)) * & + ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz0**3/(4.0*rich*rho)& + +( (tox*xu0+toy*xv0)/rho+(3.0*drho-alpha*i0*aw*xz0/(rho*cp_w)) & + *grav*xz0*xz0/(4.0*rich) )*xzts0 )) + xtts1 = xtts0 + timestep*(i0*aw*xzts0-q_ts)/(rho*cp_w) + +! if ( 2.0*xt1/xz1 > 0.001 ) then +! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_01 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& +! 2.0*xt1/xz1,2.0*xs1/xz1,2.0*xu1/xz1,2.0*xv1/xz1,xz1,xtts1,xzts1,d_conv,t_fcl,te +! endif + + call sw_ps_9b(xz1,fw) + q_warm = fw*i0-q !total heat abs in warm layer + call sw_ps_9b_aw(xz1,aw) + drho = -alpha*q_warm/(rho*cp_w) + omg_m*beta*sep + dzw = xz1*(tox*xu1+toy*xv1) / (rho*(xu1*xu1+xv1*xv1)) & + + xz1*xz1*xz1*drho*grav / (4.0*rich*(xu1*xu1+xv1*xv1)) + + xt2 = xt0 + timestep*q_warm/(rho*cp_w) + xs2 = xs0 + timestep*sep + xu2 = xu0 + timestep*(fc*xv1+tox/rho) + xv2 = xv0 + timestep*(-fc*xu1+toy/rho) + xz2 = xz0 + timestep*dzw + +! if (lprnt) print *,' xt2=',xt2,' xz2=',xz2 + + if ( xt2 <= 0.0 .or. xz2 <= 0.0 .or. xz2 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + return + endif + + xzts2 = xzts0 + timestep*((1.0/(xu1*xu1+xv1*xv1)) * & + ( (alpha*q_ts/cp_w+omg_m*beta*sss*hl_ts/le)*grav*xz1**3/(4.0*rich*rho)& + +( (tox*xu1+toy*xv1)/rho+(3.0*drho-alpha*i0*aw*xz1/(rho*cp_w))* & + grav*xz1*xz1/(4.0*rich) )*xzts1 )) + xtts2 = xtts0 + timestep*(i0*aw*xzts1-q_ts)/(rho*cp_w) + + xt = 0.5*(xt1 + xt2) + xs = 0.5*(xs1 + xs2) + xu = 0.5*(xu1 + xu2) + xv = 0.5*(xv1 + xv2) + xz = 0.5*(xz1 + xz2) + xzts = 0.5*(xzts1 + xzts2) + xtts = 0.5*(xtts1 + xtts2) + + if ( xt <= 0.0 .or. xz < 0.0 .or. xz > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + endif + +! if (lprnt) print *,' xt=',xt,' xz=',xz +! if ( 2.0*xt/xz > 0.001 ) then +! write(*,'(a,i5,2f8.3,4f8.2,f10.6,10f8.4)') 'eulerm_02 : ',kdt,alat,alon,soltim/3600.,i0,q,q_warm,sep,& +! 2.0*xt/xz,2.0*xs/xz,2.0*xu/xz,2.0*xv/xz,xz,xtts,xzts,d_conv,t_fcl,te +! endif + return + + end subroutine eulerm + + subroutine dtm_1p_zwa(kdt,timestep,i0,q,rho,d_conv,xt,xs,xu,xv,xz,tr_mda,tr_fca,tr_tla,tr_mwa) +! apply xz adjustment: minimum depth adjustment (mda) +! free convection adjustment (fca); +! top layer adjustment (tla); +! maximum warming adjustment (mwa) +! + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,i0,q,rho,d_conv + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz + real(kind=kind_phys), intent(out) :: tr_mda,tr_fca,tr_tla,tr_mwa +! local variables + real(kind=kind_phys) :: dz,t0,ttop0,ttop,fw,q_warm + real(kind=kind_phys) :: xz_fca,xz_tla,xz_mwa +! + real(kind=kind_phys) xz_mda + + tr_mda = 0.0; tr_fca = 0.0; tr_tla = 0.0; tr_mwa = 0.0 + +! apply mda + if ( z_w_min > xz ) then + xz_mda = z_w_min + endif +! apply fca + if ( d_conv > 0.0 ) then + xz_fca = 2.0*xt/((2.0*xt/xz)*(1.0-d_conv/(2.0*xz))) + tr_fca = 1.0 + if ( xz_fca >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif +! apply tla + dz = min(xz,max(d_conv,delz)) + call sw_ps_9b(dz,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + if ( q_warm > 0.0 ) then + call cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop0) +! ttop = (2.0*xt/xz)*(1.0-dz/(2.0*xz)) + ttop = ((xt+xt)/xz)*(1.0-dz/(xz+xz)) + if ( ttop > ttop0 ) then + xz_tla = (xt+sqrt(xt*(xt-delz*ttop0)))/ttop0 + tr_tla = 1.0 + if ( xz_tla >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + endif + +! apply mwa + t0 = 2.0*xt/xz + if ( t0 > tw_max ) then + if ( xz >= z_w_max ) then + call dtl_reset_cv(xt,xs,xu,xv,xz) + go to 10 + endif + endif + + xz = max(xz_mda,xz_fca,xz_tla,xz_mwa) + + 10 continue + + end subroutine dtm_1p_zwa + + subroutine dtm_1p_fca(d_conv,xt,xtts,xz,xzts) + +! apply xz adjustment: free convection adjustment (fca); +! + real(kind=kind_phys), intent(in) :: d_conv,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts +! local variables + real(kind=kind_phys) :: t_fcl,t0 +! + t0 = 2.0*xt/xz + t_fcl = t0*(1.0-d_conv/(2.0*xz)) + xz = 2.0*xt/t_fcl +! xzts = 2.0*xtts/t_fcl + + end subroutine dtm_1p_fca + + subroutine dtm_1p_tla(dz,te,xt,xtts,xz,xzts) + +! apply xz adjustment: top layer adjustment (tla); +! + real(kind=kind_phys), intent(in) :: dz,te,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts +! local variables + real(kind=kind_phys) tem +! + tem = xt*(xt-dz*te) + if (tem > 0.0) then + xz = (xt+sqrt(xt*(xt-dz*te)))/te + else + xz = z_w_max + endif +! xzts = xtts*(1.0+0.5*(2.0*xt-dz*te)/sqrt(xt*(xt-dz*te)))/te + end subroutine dtm_1p_tla + + subroutine dtm_1p_mwa(xt,xtts,xz,xzts) + +! apply xz adjustment: maximum warming adjustment (mwa) +! + real(kind=kind_phys), intent(in) :: xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts +! local variables +! + xz = 2.0*xt/tw_max +! xzts = 2.0*xtts/tw_max + end subroutine dtm_1p_mwa + + subroutine dtm_1p_mda(xt,xtts,xz,xzts) + +! apply xz adjustment: minimum depth adjustment (mda) +! + real(kind=kind_phys), intent(in) :: xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts +! local variables + real(kind=kind_phys) :: ta +! + xz = max(z_w_min,xz) + ta = 2.0*xt/xz +! xzts = 2.0*xtts/ta + + end subroutine dtm_1p_mda + + subroutine dtm_1p_mta(dta,xt,xtts,xz,xzts) + +! apply xz adjustment: maximum temperature adjustment (mta) +! + real(kind=kind_phys), intent(in) :: dta,xt,xtts + real(kind=kind_phys), intent(inout) :: xz,xzts +! local variables + real(kind=kind_phys) :: ta +! + ta = max(0.0,2.0*xt/xz-dta) + if ( ta > 0.0 ) then + xz = 2.0*xt/ta + else + xz = z_w_max + endif +! xzts = 2.0*xtts/ta + + end subroutine dtm_1p_mta + +subroutine convdepth(kdt,timestep,i0,q,sss,sep,rho,alpha,beta,xt,xs,xz,d_conv) + +! +! calculate depth for convective adjustment +! + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,i0,q,sss,sep,rho,alpha,beta + real(kind=kind_phys), intent(in) :: xt,xs,xz + real(kind=kind_phys), intent(out) :: d_conv + real(kind=kind_phys) :: t,s,d_conv_ini,d_conv2,fxp,aw,s1,s2,fac1 + integer :: n +! +! input variables +! +! timestep: time step in seconds +! i0 : solar radiation flux at the surface (wm^-2) +! q : non-solar heat flux at the surface (wm^-2) +! sss : salinity (ppt) +! sep : sr(e-p) (ppt*m/s) +! rho : sea water density (kg*m^-3) +! alpha : thermal expansion coefficient (1/k) +! beta : saline contraction coefficient (1/ppt) +! xt : initial heat content (k*m) +! xs : initial salinity content (ppt*m) +! xz : initial dtl thickness (m) +! +! output variables +! +! d_conv : free convection depth (m) + +! t : initial diurnal warming t (k) +! s : initial diurnal warming s (ppt) + + n = 0 + t = 2.0*xt/xz + s = 2.0*xs/xz + + s1 = alpha*rho*t-omg_m*beta*rho*s + + if ( s1 == 0.0 ) then + d_conv = 0.0 + else + + fac1 = alpha*q/cp_w+omg_m*beta*rho*sep + if ( i0 <= 0.0 ) then + d_conv2=(2.0*xz*timestep/s1)*fac1 + if ( d_conv2 > 0.0 ) then + d_conv = sqrt(d_conv2) + else + d_conv = 0.0 + endif + elseif ( i0 > 0.0 ) then + + d_conv_ini = 0.0 + + iter_conv: do n = 1, niter_conv + call sw_ps_9b(d_conv_ini,fxp) + call sw_ps_9b_aw(d_conv_ini,aw) + s2 = alpha*(q-(fxp-aw*d_conv_ini)*i0)/cp_w+omg_m*beta*rho*sep + d_conv2=(2.0*xz*timestep/s1)*s2 + if ( d_conv2 < 0.0 ) then + d_conv = 0.0 + exit iter_conv + endif + d_conv = sqrt(d_conv2) + if ( abs(d_conv-d_conv_ini) < eps_conv .and. n <= niter_conv ) exit iter_conv + d_conv_ini = d_conv + enddo iter_conv + d_conv = max(0.0,min(d_conv,z_w_max)) + endif ! if ( i0 <= 0.0 ) then + + endif ! if ( s1 == 0.0 ) then + +! if ( d_conv > 0.01 ) then +! write(*,'(a,i4,i3,10f9.3,3f10.6,f10.1,f6.2)') ' d_conv : ',kdt,n,d_conv,d_conv_ini,q,i0,rho,cp_w,timestep,xt,xs,xz,sep, & +! s1,s2,d_conv2,aw +! endif + + end subroutine convdepth + + subroutine dtm_onset(kdt,timestep,rich,tox,toy,i0,q,sss,sep,q_ts,hl_ts,rho, & + alpha,beta,alon,sinlat,soltim,grav,le,xt,xs,xu,xv,xz,xzts,xtts) +! +! determine xz iteratively (starting wit fw = 0.5) and then update the other 6 variables +! + + integer,intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,rich,tox,toy,i0,q,sss,sep,q_ts,& + hl_ts,rho,alpha,beta,alon,sinlat,soltim,grav,le + real(kind=kind_phys), intent(out) :: xt,xs,xu,xv,xz,xzts,xtts + real(kind=kind_phys) :: xt0,xs0,xu0,xv0,xz0 + real(kind=kind_phys) :: xt1,xs1,xu1,xv1,xz1 + real(kind=kind_phys) :: fw,aw,q_warm,ft0,fs0,fu0,fv0,fz0,ft1,fs1,fu1,fv1,fz1 + real(kind=kind_phys) :: coeff1,coeff2,ftime,z_w,z_w_tmp,fc,warml,alat + integer :: n +! +! input variables +! +! timestep: time step in seconds +! tox : x wind stress (n*m^-2 or kg/m/s^2) +! toy : y wind stress (n*m^-2 or kg/m/s^2) +! i0 : solar radiation flux at the surface (wm^-2) +! q : non-solar heat flux at the surface (wm^-2) +! sss : salinity (ppt) +! sep : sr(e-p) (ppt*m/s) +! rho : sea water density (kg*m^-3) +! alpha : thermal expansion coefficient (1/k) +! beta : saline contraction coefficient (1/ppt) +! alon : longitude +! sinlat : sine(latitude) +! grav : gravity accelleration +! le : le=(2.501-.00237*tsea)*1e6 +! +! output variables +! +! xt : onset t content in dtl +! xs : onset s content in dtl +! xu : onset u content in dtl +! xv : onset v content in dtl +! xz : onset dtl thickness (m) +! xzts : onset d(xz)/d(ts) (m/k ) +! xtts : onset d(xt)/d(ts) (m) + + fc=1.46/10000.0/2.0*sinlat + alat = asin(sinlat) +! +! initializing dtl (just before the onset) +! + xt0 = 0.0 + xs0 = 0.0 + xu0 = 0.0 + xv0 = 0.0 + + z_w_tmp=z_w_ini + + call sw_ps_9b(z_w_tmp,fw) +! fw=0.5 ! + q_warm=fw*i0-q !total heat abs in warm layer + + if ( abs(alat) > 1.0 ) then + ftime=sqrt((2.0-2.0*cos(fc*timestep))/(fc*fc*timestep)) + else + ftime=timestep + endif + + coeff1=alpha*grav/cp_w + coeff2=omg_m*beta*grav*rho + warml = coeff1*q_warm-coeff2*sep + + if ( warml > 0.0 .and. q_warm > 0.0) then + iters_z_w: do n = 1,niter_z_w + if ( warml > 0.0 .and. q_warm > 0.0 ) then + z_w=sqrt(2.0*rich*ftime/rho)*sqrt(tox**2+toy**2)/sqrt(warml) + else + z_w = z_w_max + exit iters_z_w + endif + +! write(*,'(a,i4,i4,10f9.3,f9.6,f3.0)') ' z_w = ',kdt,n,z_w,z_w_tmp,timestep,q_warm,q,i0,fw,tox,toy,sep,warml,omg_m + + if (abs(z_w - z_w_tmp) < eps_z_w .and. z_w/=z_w_max .and. n < niter_z_w) exit iters_z_w + z_w_tmp=z_w + call sw_ps_9b(z_w_tmp,fw) + q_warm = fw*i0-q + warml = coeff1*q_warm-coeff2*sep + end do iters_z_w + else + z_w=z_w_max + endif + + xz0 = max(z_w,z_w_min) + +! +! update xt, xs, xu, xv +! + if ( z_w < z_w_max .and. q_warm > 0.0) then + + call sw_ps_9b(z_w,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + ft0 = q_warm/(rho*cp_w) + fs0 = sep + fu0 = fc*xv0+tox/rho + fv0 = -fc*xu0+toy/rho + + xt1 = xt0 + timestep*ft0 + xs1 = xs0 + timestep*fs0 + xu1 = xu0 + timestep*fu0 + xv1 = xv0 + timestep*fv0 + + fz0 = xz0*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz0*xz0/(4.0*rich) & + -alpha*grav*q_warm*xz0*xz0/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) + xz1 = xz0 + timestep*fz0 + + xz1 = max(xz1,z_w_min) + + if ( xt1 < 0.0 .or. xz1 > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) + return + endif + + call sw_ps_9b(xz1,fw) + q_warm=fw*i0-q !total heat abs in warm layer + + ft1 = q_warm/(rho*cp_w) + fs1 = sep + fu1 = fc*xv1+tox/rho + fv1 = -fc*xu1+toy/rho + + fz1 = xz1*((tox*xu1+toy*xv1)/rho+omg_m*beta*grav*sep*xz1*xz1/(4.0*rich) & + -alpha*grav*q_warm*xz1*xz1/(4.0*rich*cp_w*rho))/(xu1*xu1+xv1*xv1) + + xt = xt0 + 0.5*timestep*(ft0+ft1) + xs = xs0 + 0.5*timestep*(fs0+fs1) + xu = xu0 + 0.5*timestep*(fu0+fu1) + xv = xv0 + 0.5*timestep*(fv0+fv1) + xz = xz0 + 0.5*timestep*(fz0+fz1) + + xz = max(xz,z_w_min) + + call sw_ps_9b_aw(xz,aw) + +! xzts = (q_ts+(cp_w*omg_m*beta*sss/(le*alpha))*hl_ts)*xz/(i0*xz*aw+2.0*q_warm-2.0*(rho*cp_w*omg_m*beta*sss/alpha)*(sep/sss)) + xzts = (q_ts+omg_m*rho*cp_w*beta*sss*hl_ts*xz/(le*alpha))/(i0*xz*aw+2.0*q_warm-2.0*omg_m*rho*cp_w*beta*sss*sep/(le*alpha)) + xtts = timestep*(i0*aw*xzts-q_ts)/(rho*cp_w) + endif + + if ( xt < 0.0 .or. xz > z_w_max ) then + call dtl_reset(xt,xs,xu,xv,xz,xtts,xzts) + endif + + return + + end subroutine dtm_onset + + subroutine cal_w(kdt,xz,xt,xzts,xtts,w_0,w_d) +! +! abstract: calculate w_0,w_d +! +! input variables +! +! kdt : the number of time step +! xt : dtl heat content +! xz : dtl depth +! xzts : d(zw)/d(ts) +! xtts : d(xt)/d(ts) +! +! output variables +! +! w_0 : coefficint 1 to calculate d(tw)/d(ts) +! w_d : coefficint 2 to calculate d(tw)/d(ts) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xz,xt,xzts,xtts + real(kind=kind_phys), intent(out) :: w_0,w_d + + w_0 = 2.0*(xtts-xt*xzts/xz)/xz + w_d = (2.0*xt*xzts/xz**2-w_0)/xz + +! if ( 2.0*xt/xz > 1.0 ) then +! write(*,'(a,i4,2f9.3,4f10.4))') ' cal_w : ',kdt,xz,xt,w_0,w_d,xzts,xtts +! endif + end subroutine cal_w + + + subroutine cal_ttop(kdt,timestep,q_warm,rho,dz,xt,xz,ttop) +! +! abstract: calculate +! +! input variables +! +! kdt : the number of record +! timestep : the number of record +! q_warm : total heat abs in layer dz +! rho : sea water density +! dz : dz = max(delz,d_conv) top layer thickness defined to adjust xz +! xt : heat content in dtl at previous time +! xz : dtl thickness at previous time +! +! output variables +! +! ttop : the diurnal warming amount at the top layer with thickness of delz + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: timestep,q_warm,rho,dz,xt,xz + real(kind=kind_phys), intent(out) :: ttop + real(kind=kind_phys) :: dt_warm,t0 + + dt_warm = (xt+xt)/xz + t0 = dt_warm*(1.0-dz/(xz+xz)) + ttop = t0 + q_warm*timestep/(rho*cp_w*dz) + + end subroutine cal_ttop + + subroutine app_sfs(kdt,xt,xs,xu,xv,alpha,beta,grav,d_1p,xz) +! +! abstract: adjust dtm-1p dtl thickness by applying shear flow stability with assumed exponetial profile +! +! input variables +! +! kdt : the number of record +! xt : heat content in dtl +! xs : salinity content in dtl +! xu : u-current content in dtl +! xv : v-current content in dtl +! alpha +! beta +! grav +! d_1p : dtl depth before sfs applied +! +! output variables +! +! xz : dtl depth + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xt,xs,xu,xv,alpha,beta,grav,d_1p + real(kind=kind_phys), intent(out) :: xz +! real(kind=kind_phys) :: ze,cc,xz0,l,d_sfs, t_sfs, tem + real(kind=kind_phys) :: cc,l,d_sfs,tem + real(kind=kind_phys), parameter :: c2 = 0.3782 + integer :: n + + cc = ri_g/(grav*c2) + + tem = alpha*xt - beta*xs + if (tem > 0.0) then + d_sfs = sqrt(2.0*cc*(xu*xu+xv*xv)/tem) + else + d_sfs = 0.0 + endif + +! xz0 = d_1p +! iter_sfs: do n = 1, niter_sfs +! l = int_epn(0.0,xz0,0.0,xz0,2) +! d_sfs = cc*(xu*xu+xv*xv)/((alpha*xt-beta*xs)*l) +! write(*,'(a,i6,i3,4f9.4))') ' app_sfs_iter : ',kdt,n,cc,l,xz0,d_sfs +! if ( abs(d_sfs-xz0) < eps_sfs .and. n <= niter_sfs ) exit iter_sfs +! xz0 = d_sfs +! enddo iter_sfs + +! ze = a2*d_sfs ! not used! + + l = int_epn(0.0,d_sfs,0.0,d_sfs,2) + +! t_sfs = xt/l +! xz = (xt+xt) / t_sfs + + xz = l + l + +! write(*,'(a,i6,6f9.4))') ' app_sfs : ',kdt,xz0,d_sfs,d_1p,xz,2.0*xt/d_1p,t_sfs + end subroutine app_sfs + + subroutine cal_tztr(kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr) +! +! abstract: calculate d(tz)/d(ts) +! +! input variables +! +! kdt : the number of record +! xt : heat content in dtl +! xz : dtl depth (m) +! c_0 : coefficint 1 to calculate d(tc)/d(ts) +! c_d : coefficint 2 to calculate d(tc)/d(ts) +! w_0 : coefficint 1 to calculate d(tw)/d(ts) +! w_d : coefficint 2 to calculate d(tw)/d(ts) +! +! output variables +! +! tztr : d(tz)/d(tr) + + integer, intent(in) :: kdt + real(kind=kind_phys), intent(in) :: xt,c_0,c_d,w_0,w_d,zc,zw,z + real(kind=kind_phys), intent(out) :: tztr + + if ( xt > 0.0 ) then + if ( z <= zc ) then +! tztr = 1.0/(1.0-w_0+c_0)+z*(w_d-c_d)/(1.0-w_0+c_0) + tztr = (1.0+z*(w_d-c_d))/(1.0-w_0+c_0) + elseif ( z > zc .and. z < zw ) then +! tztr = (1.0+c_0)/(1.0-w_0+c_0)+z*w_d/(1.0-w_0+c_0) + tztr = (1.0+c_0+z*w_d)/(1.0-w_0+c_0) + elseif ( z >= zw ) then + tztr = 1.0 + endif + elseif ( xt == 0.0 ) then + if ( z <= zc ) then +! tztr = 1.0/(1.0+c_0)-z*c_d/(1.0+c_0) + tztr = (1.0-z*c_d)/(1.0+c_0) + else + tztr = 1.0 + endif + else + tztr = 1.0 + endif + +! write(*,'(a,i4,9f9.4))') ' cal_tztr : ',kdt,xt,c_0,c_d,w_0,w_d,zc,zw,z,tztr + end subroutine cal_tztr + +subroutine cool_skin(ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le,deltat_c,z_c,c_0,c_d) +! +! upper ocean cool-skin parameterizaion, fairall et al, 1996. +! +! input: +! ustar_a : atmosphreic friction velocity at the air-sea interface (m/s) +! f_nsol : the "nonsolar" part of the surface heat flux (w/m^s) +! f_sol_0 : solar radiation at the ocean surface (w/m^2) +! evap : latent heat flux (w/m^2) +! sss : ocean upper mixed layer salinity (ppu) +! alpha : thermal expansion coefficient +! beta : saline contraction coefficient +! rho_w : oceanic density +! rho_a : atmospheric density +! ts : oceanic surface temperature +! q_ts : d(q)/d(ts) : q = the sum of non-solar heat fluxes +! hl_ts : d(hl)/d(ts) +! grav : gravity +! le : +! +! output: +! deltat_c: cool-skin temperature correction (degrees k) +! z_c : molecular sublayer (cool-skin) thickness (m) +! c_0 : coefficient1 to calculate d(tz)/d(ts) +! c_d : coefficient2 to calculate d(tz)/d(ts) + +! + real(kind=kind_phys), intent(in) :: ustar_a,f_nsol,f_sol_0,evap,sss,alpha,beta,rho_w,rho_a,ts,q_ts,hl_ts,grav,le + real(kind=kind_phys), intent(out):: deltat_c,z_c,c_0,c_d +! declare local variables + real(kind=kind_phys), parameter :: a1=0.065, a2=11.0, a3=6.6e-5, a4=8.0e-4, tcw=0.6 & + , tcwi=1.0/tcw + real(kind=kind_phys) :: a_c,b_c,zc_ts,bc1,bc2 + real(kind=kind_phys) :: xi,hb,ustar1_a,bigc,deltaf,fxp + real(kind=kind_phys) :: zcsq + real(kind=kind_phys) :: cc1,cc2,cc3 + + + z_c = z_c_ini ! initial guess + + ustar1_a = max(ustar_a,ustar_a_min) + + call sw_rad_skin(z_c,fxp) + deltaf = f_sol_0*fxp + + hb = alpha*(f_nsol-deltaf)+beta*sss*cp_w*evap/le + bigc = 16*grav*cp_w*(rho_w*visw)**3/(rho_a*rho_a*kw*kw) + + if ( hb > 0 ) then + xi = 6./(1+(bigc*hb/ustar1_a**4)**0.75)**0.3333333 + else + xi = 6.0 + endif + z_c = min(z_c_max,xi*visw/(sqrt(rho_a/rho_w)*ustar1_a )) + + call sw_rad_skin(z_c,fxp) + + deltaf = f_sol_0*fxp + deltaf = f_nsol - deltaf + if ( deltaf > 0 ) then + deltat_c = deltaf * z_c / kw + else + deltat_c = 0. + z_c = 0. + endif +! +! calculate c_0 & c_d +! + if ( z_c > 0.0 ) then + cc1 = 6.0*visw / (tcw*ustar1_a*sqrt(rho_a/rho_w)) + cc2 = bigc*alpha / max(ustar_a,ustar_a_min)**4 + cc3 = beta*sss*cp_w/(alpha*le) + zcsq = z_c * z_c + a_c = a2 + a3/zcsq - (a3/(a4*z_c)+a3/zcsq) * exp(-z_c/a4) + + if ( hb > 0.0 ) then + bc1 = zcsq * (q_ts+cc3*hl_ts) + bc2 = zcsq * f_sol_0*a_c - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq) + zc_ts = bc1/bc2 +! b_c = z_c**2*(q_ts+cc3*hl_ts)/(z_c**2*f_sol_0*a_c-4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*z_c**2)) ! d(z_c)/d(ts) + b_c = (q_ts+cc3*hl_ts)/(f_sol_0*a_c & + - 4.0*(cc1*tcw)**3*(hb/alpha)**0.25/(cc2**0.75*zcsq*zcsq)) ! d(z_c)/d(ts) + c_0 = (z_c*q_ts+(f_nsol-deltaf-f_sol_0*a_c*z_c)*b_c)*tcwi + c_d = (f_sol_0*a_c*z_c*b_c-q_ts)*tcwi + + else + b_c = 0.0 + zc_ts = 0.0 + c_0 = z_c*q_ts*tcwi + c_d = -q_ts*tcwi + endif + +! if ( c_0 < 0.0 ) then +! write(*,'(a,2f12.6,10f10.6)') ' c_0, c_d = ',c_0,c_d,b_c,zc_ts,hb,bc1,bc2,z_c,cc1,cc2,cc3,z_c**2 +! endif + +! c_0 = z_c*q_ts/tcw +! c_d = -q_ts/tcw + + else + c_0 = 0.0 + c_d = 0.0 + endif ! if ( z_c > 0.0 ) then + + end subroutine cool_skin +! +!====================== +! + real function int_epn(z1,z2,zmx,ztr,n) +! +! abstract: calculate a definitive integral of an exponetial curve (power of 2) +! + real(kind_phys) :: z1,z2,zmx,ztr,zi + real(kind_phys) :: fa,fb,fi,int + integer :: m,i,n + + m = nint((z2-z1)/delz) + fa = exp(-exp_const*((z1-zmx)/(ztr-zmx))**n) + fb = exp(-exp_const*((z2-zmx)/(ztr-zmx))**n) + int = 0.0 + do i = 1, m-1 + zi = z1 + delz*float(i) + fi = exp(-exp_const*((zi-zmx)/(ztr-zmx))**n) + int = int + fi + enddo + int_epn = delz*((fa+fb)/2.0 + int) + end function int_epn + + subroutine dtl_reset_cv(xt,xs,xu,xv,xz) + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz + xt = 0.0 + xs = 0.0 + xu = 0.0 + xv = 0.0 + xz = z_w_max + end subroutine dtl_reset_cv + + subroutine dtl_reset(xt,xs,xu,xv,xz,xzts,xtts) + real(kind=kind_phys), intent(inout) :: xt,xs,xu,xv,xz,xzts,xtts + xt = 0.0 + xs = 0.0 + xu = 0.0 + xv = 0.0 + xz = z_w_max + xtts = 0.0 + xzts = 0.0 + end subroutine dtl_reset + + +end module nst_module + diff --git a/gsmphys/module_nst_parameters.f90 b/gsmphys/module_nst_parameters.f90 new file mode 100644 index 00000000..1186177e --- /dev/null +++ b/gsmphys/module_nst_parameters.f90 @@ -0,0 +1,143 @@ +module module_nst_parameters + use machine, only : kind_phys & + ,kind_rad ! for astronomy (date) calculations + ! + ! air constants and coefficients from the atmospehric model + use physcons, only: & + eps => con_eps & + ,cp_a => con_cp & ! spec heat air @p (j/kg/k) + , epsm1 => con_epsm1 & + , hvap => con_hvap & ! lat heat h2o cond (j/kg) + ,sigma_r => con_sbc & ! stefan-boltzmann (w/m2/k4) + ,grav => con_g & ! acceleration due to gravity (kg/m/s^2) + ,omega => con_omega & ! ang vel of earth (1/s) + ,rvrdm1 => con_fvirt & + ,rd => con_rd & + ,rocp => con_rocp & ! r/cp + ,pi => con_pi + ! + ! note: take timestep from here later + public + integer :: & + niter_conv = 5, & + niter_z_w = 5, & + niter_sfs = 5 + real (kind=kind_phys), parameter :: & + ! + ! general constants + sec_in_day=86400. & + ,sec_in_hour=3600. & + ,solar_time_6am=21600.0 & + ,const_rot=0.000073 & ! constant to calculate corioli force + ,ri_c=0.65 & + ,ri_g=0.25 & + ,eps_z_w=0.01 & ! criteria to finish iterations for z_w + ,eps_conv=0.01 & ! criteria to finish iterations for d_conv + ,eps_sfs=0.01 & ! criteria to finish iterations for d_sfs + ,z_w_max=30.0 & ! max warm layer thickness +! ,z_w_max=100.0 & ! max warm layer thickness + ,z_w_min=0.2 & ! min warm layer thickness + ,z_w_ini=0.2 & ! initial warm layer thickness in dtl_onset + ,z_c_max=0.01 & ! maximum of sub-layer thickness (m) + ,z_c_ini=0.001 & ! initial value of z_c + ,ustar_a_min=0.031 & ! minimum of friction wind speed (m/s): 0.031 ~ 1m/s at 10 m hight + ,tau_min=0.005 & ! minimum of wind stress for dtm + ,exp_const=9.5 & ! coefficient in exponet profile + ,delz=0.1 & ! vertical increment for integral calculation (m) + ,von=0.4 & ! von karman's "constant" ! + ,t0k=273.16 & ! celsius to kelvin + ,gray=0.97 & + ,sst_max=308.16 & + ,tw_max=5.0 & + ,wd_max=2.0 & + ,omg_m =1.0 & ! trace factor to apply salinity effect + ,omg_rot = 1.0 & ! trace factor to apply rotation effect + ,omg_sh = 1.0 & ! trace factor to apply sensible heat due to rainfall effect +!dbgz + ,visw=1.e-6 & !m2/s kinematic viscosity water + ,novalue=0 & +! ,novalue=-1.0e+10 & + ,smallnumber=1.e-6 & +! ,timestep_oc=sec_in_day/24. & ! time step in the ocean model (1 hours) + ,timestep_oc=sec_in_day/8. & ! time step in the ocean model (3 hours) + ,radian=2.*pi/180. & + ,rad2deg=180./pi & + ! sea constants and coefficients + ! + ,cp_w=4000. & ! specific heat water (j/kg/k ) + ,rho0_w=1022.0 & ! density water (kg/m3 ) (or 1024.438) + ,vis_w=1.e-6 & ! kinematic viscosity water (m2/s ) + ,tc_w=0.6 & ! thermal conductivity water (w/m/k ) + ,capa_w =3950.0 & ! heat capacity of sea water ! + ! + ! air constants and coefficients + ! + ,thref =1.0e-3 ! reference value of specific volume (m**3/kg) + +!!$!============================================ +!!$ +!!$ ,lvapor=2.453e6 & ! latent heat of vaporization note: make it function of t ????? note the same as hvap +!!$ ,alpha=1 ! thermal expansion coefficient +!!$ ,beta ! saline contraction coefficient +!!$ ,cp=1 !=1 specific heat of sea water +!!$ ,g=1 ! acceleration due to gravity +!!$ ,kw=1 ! thermal conductivity of water +!!$ ,nu=1 !kinematic wiscosity +!!$ ,rho_w=1 !water density +!!$ ,rho_a=1 !air density +!!$ ,l_vapr=2.453e6 +!!$ ,novalue=--1.0e+10 +!!$ +!!$c factors +!!$ beta=1.2 !given as 1.25 in fairall et al.(1996) +!!$ von=0.4 ! von karman's "constant" +!!$c fdg=1.00 ! fairall's lkb rr to von karman adjustment +!!$ fdg=1.00 !based on results from flux workshop august 1995 +!!$ tok=273.16 ! celsius to kelvin +!!$ twopi=3.14159*2. +!!$ +!!$c air constants and coefficients +!!$ rgas=287.1 !j/kg/k gas const. dry air +!!$ xlv=(2.501-0.00237*ts)*1e+6 !j/kg latent heat of vaporization at ts +!!$ cpa=1004.67 !j/kg/k specific heat of dry air (businger 1982) +!!$ cpv=cpa*(1+0.84*q) !moist air - currently not used (businger 1982) +!!$ rhoa=p*100./(rgas*(t+tok)*(1.+.61*q)) !kg/m3 moist air density ( " ) +!!$ visa=1.326e-5*(1+6.542e-3*t+8.301e-6*t*t-4.84e-9*t*t*t) !m2/s +!!$ !kinematic viscosity of dry air - andreas (1989) crrel rep. 89-11 +!!$c +!!$c cool skin constants +!!$ al=2.1e-5*(ts+3.2)**0.79 !water thermal expansion coefft. +!!$ be=0.026 !salinity expansion coefft. +!!$ cpw=4000. !j/kg/k specific heat water +!!$ rhow=1022. !kg/m3 density water +!!$ visw=1.e-6 !m2/s kinematic viscosity water +!!$ tcw=0.6 !w/m/k thermal conductivity water +!!$ bigc=16.*grav*cpw*(rhow*visw)**3/(tcw*tcw*rhoa*rhoa) +!!$ wetc=0.622*xlv*qs/(rgas*(ts+tok)**2) !correction for dq;slope of sat. vap. +!!$ +!!$! +!!$! functions +!!$ +!!$ +!!$ real, parameter :: timestep=86400. !integration time step, second +!!$ +!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 +!!$ real, parameter :: capa =3950.0 !heat capacity of sea water +!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 +!!$ real , parameter :: hslab=50.0 !slab ocean depth +!!$ real , parameter :: bad=-1.0e+10 +!!$ real , parameter :: tmin=2.68e+02 +!!$ real , parameter :: tmax=3.11e+02 +!!$ +!!$ real, parameter :: grav =9.81 !gravity, kg/m/s^2 +!!$ real, parameter :: capa =3950.0 !heat capacity of sea water +!!$ real, parameter :: rhoref = 1024.438 !sea water reference density, kg/m^3 +!!$ real, parameter :: tmin=2.68e+02 !normal minimal temp +!!$ real, parameter :: tmax=3.11e+02 !normal max temp +!!$ real, parameter :: smin=1.0 !normal minimal salt +!!$ real, parameter :: smax=50. !normal maximum salt +!!$ real, parameter :: visct=1.e-5 !viscocity for temperature diffusion +!!$ real, parameter :: viscs=1.e-5 !viscocity for salt diffusion +!!$ +!!$ +end module module_nst_parameters diff --git a/gsmphys/module_nst_water_prop.f90 b/gsmphys/module_nst_water_prop.f90 new file mode 100644 index 00000000..f31d9724 --- /dev/null +++ b/gsmphys/module_nst_water_prop.f90 @@ -0,0 +1,703 @@ +module module_nst_water_prop + use machine, only : kind_phys + use module_nst_parameters, only : t0k + ! + private + public :: rhocoef,density,sw_rad,sw_rad_aw,sw_rad_sum,sw_rad_upper,sw_rad_upper_aw,sw_rad_skin,grv,solar_time_from_julian,compjd, & + sw_ps_9b,sw_ps_9b_aw,get_dtzm_point,get_dtzm_2d + + ! + interface sw_ps_9b + module procedure sw_ps_9b + end interface + interface sw_ps_9b_aw + module procedure sw_ps_9b_aw + end interface + ! + interface sw_rad + module procedure sw_fairall_6exp_v1 ! sw_wick_v1 + end interface + interface sw_rad_aw + module procedure sw_fairall_6exp_v1_aw + end interface + interface sw_rad_sum + module procedure sw_fairall_6exp_v1_sum + end interface + interface sw_rad_upper + module procedure sw_soloviev_3exp_v2 + end interface + interface sw_rad_upper_aw + module procedure sw_soloviev_3exp_v2_aw + end interface + interface sw_rad_skin + module procedure sw_ohlmann_v1 + end interface +contains + ! ------------------------------------------------------ + subroutine rhocoef(t, s, rhoref, alpha, beta) + ! ------------------------------------------------------ + + ! compute thermal expansion coefficient (alpha) + ! and saline contraction coefficient (beta) using + ! the international equation of state of sea water + ! (1980). ref: pond and pickard, introduction to + ! dynamical oceanography, pp310. + ! note: compression effects are not included + + implicit none + real(kind=kind_phys), intent(in) :: t, s, rhoref + real(kind=kind_phys), intent(out) :: alpha, beta + real(kind=kind_phys) :: tc + + tc = t - t0k + + alpha = & + 6.793952e-2 & + - 2.0 * 9.095290e-3 * tc + 3.0 * 1.001685e-4 * tc**2 & + - 4.0 * 1.120083e-6 * tc**3 + 5.0 * 6.536332e-9 * tc**4 & + - 4.0899e-3 * s & + + 2.0 * 7.6438e-5 * tc * s - 3.0 * 8.2467e-7 * tc**2 * s & + + 4.0 * 5.3875e-9 * tc**3 * s & + + 1.0227e-4 * s**1.5 - 2.0 * 1.6546e-6 * tc * s**1.5 + + ! note: rhoref - specify + ! + alpha = -alpha/rhoref + + beta = & + 8.24493e-1 - 4.0899e-3 * tc & + + 7.6438e-5 * tc**2 - 8.2467e-7 * tc**3 & + + 5.3875e-9 * tc**4 - 1.5 * 5.72466e-3 * s**.5 & + + 1.5 * 1.0227e-4 * tc * s**.5 & + - 1.5 * 1.6546e-6 * tc**2 * s**.5 & + + 2.0 * 4.8314e-4 * s + + beta = beta / rhoref + + end subroutine rhocoef + ! ---------------------------------------- + subroutine density(t, s, rho) + ! ---------------------------------------- + implicit none + + ! input + real(kind=kind_phys), intent(in) :: t !unit, k + real(kind=kind_phys), intent(in) :: s !unit, 1/1000 + ! output + real(kind=kind_phys), intent(out) :: rho !unit, kg/m^3 + ! local + real(kind=kind_phys) :: tc + + ! compute density using the international equation + ! of state of sea water 1980, (pond and pickard, + ! introduction to dynamical oceanography, pp310). + ! compression effects are not included + + rho = 0.0 + tc = t - t0k + + ! effect of temperature on density (lines 1-3) + ! effect of temperature and salinity on density (lines 4-8) + rho = & + 999.842594 + 6.793952e-2 * tc & + - 9.095290e-3 * tc**2 + 1.001685e-4 * tc**3 & + - 1.120083e-6 * tc**4 + 6.536332e-9 * tc**5 & + + 8.24493e-1 * s - 4.0899e-3 * tc * s & + + 7.6438e-5 * tc**2 * s - 8.2467e-7 * tc**3 * s & + + 5.3875e-9 * tc**4 * s - 5.72466e-3 * s**1.5 & + + 1.0227e-4 * tc * s**1.5 - 1.6546e-6 * tc**2 * s**1.5 & + + 4.8314e-4 * s**2 + + end subroutine density + ! + !====================== + ! + elemental subroutine sw_ps_9b(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real,intent(in):: z + real,intent(out):: fxp + real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & + ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + ! + if(z>0) then + fxp=1.0-(f(1)*exp(-z/gamma(1))+f(2)*exp(-z/gamma(2))+f(3)*exp(-z/gamma(3))+ & + f(4)*exp(-z/gamma(4))+f(5)*exp(-z/gamma(5))+f(6)*exp(-z/gamma(6))+ & + f(7)*exp(-z/gamma(7))+f(8)*exp(-z/gamma(8))+f(9)*exp(-z/gamma(9))) + else + fxp=0. + endif + ! + end subroutine sw_ps_9b + ! + !====================== + ! + ! + !====================== + ! + elemental subroutine sw_ps_9b_aw(z,aw) + ! + ! d(fw)/d(z) for 9-band + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real,intent(in):: z + real,intent(out):: aw + real, dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & + ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + ! + if(z>0) then + aw=(f(1)/gamma(1))*exp(-z/gamma(1))+(f(2)/gamma(2))*exp(-z/gamma(2))+(f(3)/gamma(3))*exp(-z/gamma(3))+ & + (f(1)/gamma(4))*exp(-z/gamma(4))+(f(2)/gamma(5))*exp(-z/gamma(5))+(f(6)/gamma(6))*exp(-z/gamma(6))+ & + (f(1)/gamma(7))*exp(-z/gamma(7))+(f(2)/gamma(8))*exp(-z/gamma(8))+(f(9)/gamma(9))*exp(-z/gamma(9)) + else + aw=0. + endif + ! + end subroutine sw_ps_9b_aw + ! + !====================== + elemental subroutine sw_fairall_6exp_v1(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z + real(kind=kind_phys),intent(out):: fxp + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & + ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys),dimension(9) :: zgamma + real(kind=kind_phys),dimension(9) :: f_c + ! + if(z>0) then + zgamma=z/gamma + f_c=f*(1.-1./zgamma*(1-exp(-zgamma))) + fxp=sum(f_c) + else + fxp=0. + endif + ! + end subroutine sw_fairall_6exp_v1 + ! + !====================== + ! + ! + elemental subroutine sw_fairall_6exp_v1_aw(z,aw) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! aw: d(fxp)/d(z) + ! + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z + real(kind=kind_phys),intent(out):: aw + real(kind=kind_phys) :: fxp + real(kind=kind_phys), dimension(9), parameter :: f=(/0.237,0.36,0.179,0.087,0.08,0.0246,0.025,0.007,0.0004/) & + ,gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys),dimension(9) :: zgamma + real(kind=kind_phys),dimension(9) :: f_aw + ! + if(z>0) then + zgamma=z/gamma + f_aw=(f/z)*((gamma/z)*(1-exp(-zgamma))-exp(-zgamma)) + aw=sum(f_aw) + +! write(*,'(a,f6.2,f12.6,9f10.4)') 'z,aw in sw_rad_aw : ',z,aw,f_aw + + else + aw=0. + endif + ! + end subroutine sw_fairall_6exp_v1_aw + ! + elemental subroutine sw_fairall_6exp_v1_sum(z,sum) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! following paulson and simpson, 1981 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! sum: for convection depth calculation + ! + ! + implicit none + real(kind=kind_phys),intent(in):: z + real(kind=kind_phys),intent(out):: sum + real(kind=kind_phys), dimension(9), parameter :: gamma=(/34.8,2.27,3.15e-2,5.48e-3,8.32e-4,1.26e-4,3.13e-4,7.82e-5,1.44e-5/) + real(kind=kind_phys),dimension(9) :: zgamma + real(kind=kind_phys),dimension(9) :: f_sum + ! +! zgamma=z/gamma +! f_sum=(zgamma/z)*exp(-zgamma) +! sum=sum(f_sum) + + sum=(1.0/gamma(1))*exp(-z/gamma(1))+(1.0/gamma(2))*exp(-z/gamma(2))+(1.0/gamma(3))*exp(-z/gamma(3))+ & + (1.0/gamma(4))*exp(-z/gamma(4))+(1.0/gamma(5))*exp(-z/gamma(5))+(1.0/gamma(6))*exp(-z/gamma(6))+ & + (1.0/gamma(7))*exp(-z/gamma(7))+(1.0/gamma(8))*exp(-z/gamma(8))+(1.0/gamma(9))*exp(-z/gamma(9)) + ! + end subroutine sw_fairall_6exp_v1_sum + ! + !====================== + + elemental subroutine sw_fairall_simple_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1298) + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z,f_sol_0 + real(kind=kind_phys),intent(out):: df_sol_z + ! + if(z>0) then + df_sol_z=f_sol_0*(0.137+11.0*z-6.6e-6/z*(1.-exp(-z/8.e-4))) + else + df_sol_z=0. + endif + ! + end subroutine sw_fairall_simple_v1 + ! + !====================== + ! + elemental subroutine sw_wick_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (zeng and beljaars, 2005, p.5) + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z,f_sol_0 + real(kind=kind_phys),intent(out):: df_sol_z + ! + if(z>0) then + df_sol_z=f_sol_0*(0.065+11.0*z-6.6e-5/z*(1.-exp(-z/8.e-4))) + else + df_sol_z=0. + endif + ! + end subroutine sw_wick_v1 + ! + !====================== + ! + elemental subroutine sw_soloviev_3exp_v1(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) + ! following soloviev, 1982 + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z,f_sol_0 + real(kind=kind_phys),intent(out):: df_sol_z + real(kind=kind_phys),dimension(3) :: f_c + real(kind=kind_phys), dimension(3), parameter :: f=(/0.45,0.27,0.28/) & + ,gamma=(/12.8,0.357,0.014/) + ! + if(z>0) then + f_c = f*gamma(int(1-exp(-z/gamma))) + df_sol_z = f_sol_0*(1.0-sum(f_c)/z) + else + df_sol_z = 0. + endif + ! + end subroutine sw_soloviev_3exp_v1 + ! + !====================== + ! + elemental subroutine sw_soloviev_3exp_v2(f_sol_0,z,df_sol_z) + ! + ! solar radiation absorbed by the ocean at the depth z (fairall et all, 1996, p. 1301) + ! following soloviev, 1982 + ! + ! input: + ! f_sol_0: solar radiation at the ocean surface (w/m^2) + ! z: depth (m) + ! + ! output: + ! df_sol_z: solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z,f_sol_0 + real(kind=kind_phys),intent(out):: df_sol_z + ! + if(z>0) then + df_sol_z=f_sol_0*(1.0 & + -(0.28*0.014*(1.-exp(-z/0.014)) & + +0.27*0.357*(1.-exp(-z/0.357)) & + +.45*12.82*(1.-exp(-z/12.82)))/z & + ) + else + df_sol_z=0. + endif + ! + end subroutine sw_soloviev_3exp_v2 + + elemental subroutine sw_soloviev_3exp_v2_aw(z,aw) + ! + ! aw = d(fxp)/d(z) + ! following soloviev, 1982 + ! + ! input: + ! z: depth (m) + ! + ! output: + ! aw: d(fxp)/d(z) + ! + implicit none + real(kind=kind_phys),intent(in):: z + real(kind=kind_phys),intent(out):: aw + real(kind=kind_phys):: fxp + ! + if(z>0) then + fxp=(1.0 & + -(0.28*0.014*(1.-exp(-z/0.014)) & + + 0.27*0.357*(1.-exp(-z/0.357)) & + + 0.45*12.82*(1.-exp(-z/12.82)))/z & + ) + aw=1.0-fxp-(0.28*exp(-z/0.014)+0.27*exp(-z/0.357)+0.45*exp(-z/12.82)) + else + aw=0. + endif + end subroutine sw_soloviev_3exp_v2_aw + ! + ! + !====================== + ! + elemental subroutine sw_ohlmann_v1(z,fxp) + ! + ! fraction of the solar radiation absorbed by the ocean at the depth z + ! + ! input: + ! z: depth (m) + ! + ! output: + ! fxp: fraction of the solar radiation absorbed by the ocean at depth z (w/m^2) + ! + implicit none + real(kind=kind_phys),intent(in):: z + real(kind=kind_phys),intent(out):: fxp + ! + if(z>0) then + fxp=.065+11.*z-6.6e-5/z*(1.-exp(-z/8.0e-4)) + else + fxp=0. + endif + ! + end subroutine sw_ohlmann_v1 + ! + +function grv(lat) + real(kind=kind_phys) :: lat + real(kind=kind_phys) :: gamma,c1,c2,c3,c4,pi,phi,x + gamma=9.7803267715 + c1=0.0052790414 + c2=0.0000232718 + c3=0.0000001262 + c4=0.0000000007 + pi=3.141593 + + phi=lat*pi/180 + x=sin(phi) + grv=gamma*(1+(c1*x**2)+(c2*x**4)+(c3*x**6)+(c4*x**8)) + !print *,'grav=',grv,lat +end function grv + +subroutine solar_time_from_julian(jday,xlon,soltim) + ! + ! calculate solar time from the julian date + ! + implicit none + real(kind=kind_phys), intent(in) :: jday + real(kind=kind_phys), intent(in) :: xlon + real(kind=kind_phys), intent(out) :: soltim + real(kind=kind_phys) :: fjd,xhr,xmin,xsec,intime + integer :: nn + ! + fjd=jday-floor(jday) + fjd=jday + xhr=floor(fjd*24.0)-sign(12.0,fjd-0.5) + xmin=nint(fjd*1440.0)-(xhr+sign(12.0,fjd-0.5))*60 + xsec=0 + intime=xhr+xmin/60.0+xsec/3600.0+24.0 + soltim=mod(xlon/15.0+intime,24.0)*3600.0 +end subroutine solar_time_from_julian + +! +!*********************************************************************** +! + subroutine compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) +!fpp$ noconcur r +!$$$ subprogram documentation block +! . . . . +! subprogram: compjd computes julian day and fraction +! prgmmr: kenneth campana org: w/nmc23 date: 89-07-07 +! +! abstract: computes julian day and fraction +! from year, month, day and time utc. +! +! program history log: +! 77-05-06 ray orzol,gfdl +! 98-05-15 iredell y2k compliance +! +! usage: call compjd(jyr,jmnth,jday,jhr,jmn,jd,fjd) +! input argument list: +! jyr - year (4 digits) +! jmnth - month +! jday - day +! jhr - hour +! jmn - minutes +! output argument list: +! jd - julian day. +! fjd - fraction of the julian day. +! +! subprograms called: +! iw3jdn compute julian day number +! +! attributes: +! language: fortran. +! +!$$$ + use machine , only :kind_phys + implicit none +! + integer jyr,jmnth,jday,jhr,jmn,jd + integer iw3jdn + real (kind=kind_phys) fjd + jd=iw3jdn(jyr,jmnth,jday) + if(jhr.lt.12) then + jd=jd-1 + fjd=0.5+jhr/24.+jmn/1440. + else + fjd=(jhr-12)/24.+jmn/1440. + endif + end subroutine compjd + + subroutine get_dtzm_point(xt,xz,dt_cool,zc,z1,z2,dtm) +! ===================================================================== ! +! ! +! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! +! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! +! ! +! usage: ! +! ! +! call get_dtm12 ! +! ! +! inputs: ! +! (xt,xz,dt_cool,zc,z1,z2, ! +! outputs: ! +! dtm) ! +! ! +! program history log: ! +! ! +! 2015 -- xu li createad original code ! +! inputs: ! +! xt - real, heat content in dtl 1 ! +! xz - real, dtl thickness 1 ! +! dt_cool - real, sub-layer cooling amount 1 ! +! zc - sub-layer cooling thickness 1 ! +! z1 - lower bound of depth of sea temperature 1 ! +! z2 - upper bound of depth of sea temperature 1 ! +! outputs: ! +! dtm - mean of dT(z) (z1 to z2) 1 ! +! + use machine , only : kind_phys + + implicit none + + real (kind=kind_phys), intent(in) :: xt,xz,dt_cool,zc,z1,z2 + real (kind=kind_phys), intent(out) :: dtm +! Local variables + real (kind=kind_phys) :: dt_warm,dtw,dtc + +! +! get the mean warming in the range of z=z1 to z=z2 +! + dtw = 0.0 + if ( xt > 0.0 ) then + dt_warm = (xt+xt)/xz ! Tw(0) + if ( z1 < z2) then + if ( z2 < xz ) then + dtw = dt_warm*(1.0-(z1+z2)/(xz+xz)) + elseif ( z1 < xz .and. z2 >= xz ) then + dtw = 0.5*(1.0-z1/xz)*dt_warm*(xz-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < xz ) then + dtw = dt_warm*(1.0-z1/xz) + endif + endif + endif +! +! get the mean cooling in the range of z=z1 to z=z2 +! + dtc = 0.0 + if ( zc > 0.0 ) then + if ( z1 < z2) then + if ( z2 < zc ) then + dtc = dt_cool*(1.0-(z1+z2)/(zc+zc)) + elseif ( z1 < zc .and. z2 >= zc ) then + dtc = 0.5*(1.0-z1/zc)*dt_cool*(zc-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < zc ) then + dtc = dt_cool*(1.0-z1/zc) + endif + endif + endif + +! +! get the mean T departure from Tf in the range of z=z1 to z=z2 +! + dtm = dtw - dtc + + end subroutine get_dtzm_point + + subroutine get_dtzm_2d(xt,xz,dt_cool,zc,slmsk,z1,z2,nx,ny,dtm) +! ===================================================================== ! +! ! +! description: get dtm = mean of dT(z) (z1 - z2) with NSST dT(z) ! +! dT(z) = (1-z/xz)*dt_warm - (1-z/zc)*dt_cool ! +! ! +! usage: ! +! ! +! call get_dtzm_2d ! +! ! +! inputs: ! +! (xt,xz,dt_cool,zc,z1,z2, ! +! outputs: ! +! dtm) ! +! ! +! program history log: ! +! ! +! 2015 -- xu li createad original code ! +! inputs: ! +! xt - real, heat content in dtl 1 ! +! xz - real, dtl thickness 1 ! +! dt_cool - real, sub-layer cooling amount 1 ! +! zc - sub-layer cooling thickness 1 ! +! nx - integer, dimension in x-direction (zonal) 1 ! +! ny - integer, dimension in y-direction (meridional) 1 ! +! z1 - lower bound of depth of sea temperature 1 ! +! z2 - upper bound of depth of sea temperature 1 ! +! outputs: ! +! dtm - mean of dT(z) (z1 to z2) 1 ! +! + use machine , only : kind_phys + + implicit none + + integer, intent(in) :: nx,ny + real (kind=kind_phys), dimension(nx,ny), intent(in) :: xt,xz,dt_cool,zc,slmsk + real (kind=kind_phys), intent(in) :: z1,z2 + real (kind=kind_phys), dimension(nx,ny), intent(out) :: dtm +! Local variables + integer :: i,j + real (kind=kind_phys), dimension(nx,ny) :: dtw,dtc + real (kind=kind_phys) :: dt_warm + + +!$omp parallel do private(j,i) + do j = 1, ny + do i= 1, nx +! +! initialize dtw & dtc as zeros +! + dtw(i,j) = 0.0 + dtc(i,j) = 0.0 + if ( slmsk(i,j) == 0.0 ) then +! +! get the mean warming in the range of z=z1 to z=z2 +! + if ( xt(i,j) > 0.0 ) then + dt_warm = (xt(i,j)+xt(i,j))/xz(i,j) ! Tw(0) + if ( z1 < z2) then + if ( z2 < xz(i,j) ) then + dtw(i,j) = dt_warm*(1.0-(z1+z2)/(xz(i,j)+xz(i,j))) + elseif ( z1 < xz(i,j) .and. z2 >= xz(i,j) ) then + dtw(i,j) = 0.5*(1.0-z1/xz(i,j))*dt_warm*(xz(i,j)-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < xz(i,j) ) then + dtw(i,j) = dt_warm*(1.0-z1/xz(i,j)) + endif + endif + endif +! +! get the mean cooling in the range of z=0 to z=zsea +! + if ( zc(i,j) > 0.0 ) then + if ( z1 < z2) then + if ( z2 < zc(i,j) ) then + dtc(i,j) = dt_cool(i,j)*(1.0-(z1+z2)/(zc(i,j)+zc(i,j))) + elseif ( z1 < zc(i,j) .and. z2 >= zc(i,j) ) then + dtc(i,j) = 0.5*(1.0-z1/zc(i,j))*dt_cool(i,j)*(zc(i,j)-z1)/(z2-z1) + endif + elseif ( z1 == z2 ) then + if ( z1 < zc(i,j) ) then + dtc(i,j) = dt_cool(i,j)*(1.0-z1/zc(i,j)) + endif + endif + endif + endif ! if ( slmsk(i,j) == 0 ) then + enddo + enddo +! +! get the mean T departure from Tf in the range of z=z1 to z=z2 + +!$omp parallel do private(j,i) + do j = 1, ny + do i= 1, nx + if ( slmsk(i,j) == 0.0 ) then + dtm(i,j) = dtw(i,j) - dtc(i,j) + endif + enddo + enddo + + end subroutine get_dtzm_2d + +end module module_nst_water_prop diff --git a/gsmphys/module_sf_noahmp_glacier.f90 b/gsmphys/module_sf_noahmp_glacier.f90 new file mode 100644 index 00000000..0774231e --- /dev/null +++ b/gsmphys/module_sf_noahmp_glacier.f90 @@ -0,0 +1,2991 @@ +module noahmp_glacier_globals + + implicit none + +! ================================================================================================== +!------------------------------------------------------------------------------------------! +! physical constants: ! +!------------------------------------------------------------------------------------------! + + real, parameter :: grav = 9.80616 !acceleration due to gravity (m/s2) + real, parameter :: sb = 5.67e-08 !stefan-boltzmann constant (w/m2/k4) + real, parameter :: vkc = 0.40 !von karman constant + real, parameter :: tfrz = 273.16 !freezing/melting point (k) + real, parameter :: hsub = 2.8440e06 !latent heat of sublimation (j/kg) + real, parameter :: hvap = 2.5104e06 !latent heat of vaporization (j/kg) + real, parameter :: hfus = 0.3336e06 !latent heat of fusion (j/kg) + real, parameter :: cwat = 4.188e06 !specific heat capacity of water (j/m3/k) + real, parameter :: cice = 2.094e06 !specific heat capacity of ice (j/m3/k) + real, parameter :: cpair = 1004.64 !heat capacity dry air at const pres (j/kg/k) + real, parameter :: tkwat = 0.6 !thermal conductivity of water (w/m/k) + real, parameter :: tkice = 2.2 !thermal conductivity of ice (w/m/k) + real, parameter :: tkair = 0.023 !thermal conductivity of air (w/m/k) + real, parameter :: rair = 287.04 !gas constant for dry air (j/kg/k) + real, parameter :: rw = 461.269 !gas constant for water vapor (j/kg/k) + real, parameter :: denh2o = 1000. !density of water (kg/m3) + real, parameter :: denice = 917. !density of ice (kg/m3) + +! =====================================options for different schemes================================ +! options for dynamic vegetation: +! 1 -> off (use table lai; use fveg = shdfac from input) +! 2 -> on (together with opt_crs = 1) +! 3 -> off (use table lai; calculate fveg) +! 4 -> off (use table lai; use maximum vegetation fraction) + + integer :: dveg != 2 ! + +! options for canopy stomatal resistance +! 1-> ball-berry; 2->jarvis + + integer :: opt_crs != 1 !(must 1 when dveg = 2) + +! options for soil moisture factor for stomatal resistance +! 1-> noah (soil moisture) +! 2-> clm (matric potential) +! 3-> ssib (matric potential) + + integer :: opt_btr != 1 !(suggested 1) + +! options for runoff and groundwater +! 1 -> topmodel with groundwater (niu et al. 2007 jgr) ; +! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ; +! 3 -> original surface and subsurface runoff (free drainage) +! 4 -> bats surface and subsurface runoff (free drainage) + + integer :: opt_run != 1 !(suggested 1) + +! options for surface layer drag coeff (ch & cm) +! 1->m-o ; 2->original noah (chen97); 3->myj consistent; 4->ysu consistent. + + integer :: opt_sfc != 1 !(1 or 2 or 3 or 4) + +! options for supercooled liquid water (or ice fraction) +! 1-> no iteration (niu and yang, 2006 jhm); 2: koren's iteration + + integer :: opt_frz != 1 !(1 or 2) + +! options for frozen soil permeability +! 1 -> linear effects, more permeable (niu and yang, 2006, jhm) +! 2 -> nonlinear effects, less permeable (old) + + integer :: opt_inf != 1 !(suggested 1) + +! options for radiation transfer +! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg) +! 2 -> two-stream applied to grid-cell (gap = 0) +! 3 -> two-stream applied to vegetated fraction (gap=1-fveg) + + integer :: opt_rad != 1 !(suggested 1) + +! options for ground snow surface albedo +! 1-> bats; 2 -> class + + integer :: opt_alb != 2 !(suggested 2) + +! options for partitioning precipitation into rainfall & snowfall +! 1 -> jordan (1991); 2 -> bats: when sfctmp sfctmp zero heat flux from bottom (zbot and tbot not used) +! 2 -> tbot at zbot (8m) read from a file (original noah) + + integer :: opt_tbot != 2 !(suggested 2) + +! options for snow/soil temperature time scheme (only layer 1) +! 1 -> semi-implicit; 2 -> full implicit (original noah) + + integer :: opt_stc != 1 !(suggested 1) + +! adjustable parameters for snow processes + + real, parameter :: z0sno = 0.002 !snow surface roughness length (m) (0.002) + real, parameter :: ssi = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + real, parameter :: swemx = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + +!------------------------------------------------------------------------------------------! +end module noahmp_glacier_globals +!------------------------------------------------------------------------------------------! + +module noahmp_glacier_routines + use noahmp_glacier_globals + use module_wrf_utl + implicit none + + public :: noahmp_options_glacier + public :: noahmp_glacier + + private :: atm_glacier + private :: energy_glacier + private :: thermoprop_glacier + private :: csnow_glacier + private :: radiation_glacier + private :: snow_age_glacier + private :: snowalb_bats_glacier + private :: snowalb_class_glacier + private :: glacier_flux + private :: sfcdif1_glacier + private :: tsnosoi_glacier + private :: hrt_glacier + private :: hstep_glacier + private :: rosr12_glacier + private :: phasechange_glacier + + private :: water_glacier + private :: snowwater_glacier + private :: snowfall_glacier + private :: combine_glacier + private :: divide_glacier + private :: combo_glacier + private :: compact_glacier + private :: snowh2o_glacier + + private :: error_glacier + +contains +! +! ================================================================================================== + + subroutine noahmp_glacier (& + iloc ,jloc ,cosz ,nsnow ,nsoil ,dt , & ! in : time/space/model-related + sfctmp ,sfcprs ,uu ,vv ,q2 ,soldn , & ! in : forcing + prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing + qsnow ,sneqvo ,albold ,cm ,ch ,isnow , & ! in/out : + sneqv ,smc ,zsnso ,snowh ,snice ,snliq , & ! in/out : + tg ,stc ,sh2o ,tauss ,qsfc , & ! in/out : + fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : + trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : + qsnbot ,ponding ,ponding1,ponding2,t2m ,q2e , & ! out : + emissi, fpice ,ch2b , esnow) + +! -------------------------------------------------------------------------------------------------- +! initial code: guo-yue niu, oct. 2007 +! modified to glacier: michael barlage, june 2012 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !no. of soil layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: uu !wind speed in eastward dir (m/s) + real , intent(in) :: vv !wind speed in northward dir (m/s) + real , intent(in) :: q2 !mixing ratio (kg/kg) lowest model layer + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: tbot !bottom condition for soil temp. [k] + real , intent(in) :: zlvl !reference height (m) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + + +! input/output : need arbitary intial values + real , intent(inout) :: qsnow !snowfall [mm/s] + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , intent(inout) :: albold !snow albedo at last time step (class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + +! prognostic variables + integer , intent(inout) :: isnow !actual no. of snow layers [-] + real , intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + real , intent(inout) :: snowh !snow height [m] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real , intent(inout) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +! output + real , intent(out) :: fsa !total absorbed solar radiation (w/m2) + real , intent(out) :: fsr !total reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: trad !surface radiative temperature (k) + real , intent(out) :: edir !soil surface evaporation rate (mm/s] + real , intent(out) :: runsrf !surface runoff [mm/s] + real , intent(out) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(out) :: sag !solar rad absorbed by ground (w/m2) + real , intent(out) :: albedo !surface albedo [-] + real , intent(out) :: qsnbot !snowmelt [mm/s] + real , intent(out) :: ponding!surface ponding [mm] + real , intent(out) :: ponding1!surface ponding [mm] + real , intent(out) :: ponding2!surface ponding [mm] + real , intent(out) :: t2m !2-m air temperature over bare ground part [k] + real , intent(out) :: q2e + real , intent(out) :: emissi + real , intent(out) :: fpice + real , intent(out) :: ch2b + real , intent(out) :: esnow + +! local + integer :: iz !do-loop index + integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] + real :: rhoair !density air (kg/m3) + real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] + real :: thair !potential temperature (k) + real :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real :: eair !vapor pressure air (pa) + real, dimension( 1: 2) :: solad !incoming direct solar rad (w/m2) + real, dimension( 1: 2) :: solai !incoming diffuse solar rad (w/m2) + real, dimension( 1:nsoil) :: sice !soil ice content (m3/m3) + real, dimension(-nsnow+1: 0) :: snicev !partial volume ice of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: snliqv !partial volume liq of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: epore !effective porosity [m3/m3] + real :: qdew !ground surface dew rate [mm/s] + real :: qvap !ground surface evap. rate [mm/s] + real :: lathea !latent heat [j/kg] + real :: qmelt !internal pack melt + real :: swdown !downward solar [w/m2] + real :: beg_wb !beginning water for error check + real :: zbot = -8.0 + + character*256 message + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + call atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + qair ,eair ,rhoair ,solad ,solai ,swdown ) + + beg_wb = sneqv + +! snow/soil layer thickness (m); interface depth: zsnso < 0; layer thickness dzsnso > 0 + + do iz = isnow+1, nsoil + if(iz == isnow+1) then + dzsnso(iz) = - zsnso(iz) + else + dzsnso(iz) = zsnso(iz-1) - zsnso(iz) + end if + end do + +! compute energy budget (momentum & energy fluxes and phase changes) + + call energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !in + eair ,sfcprs ,qair ,sfctmp ,lwdn ,uu , & !in + vv ,solad ,solai ,cosz ,zlvl , & !in + tbot ,zbot ,zsnso ,dzsnso , & !in + tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout + smc ,snice ,snliq ,albold ,cm ,ch , & !inout + tauss ,qsfc , & !inout + imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + + sice = max(0.0, smc - sh2o) + sneqvo = sneqv + + qvap = max( fgev/lathea, 0.) ! positive part of fgev [mm/s] > 0 + qdew = abs( min(fgev/lathea, 0.)) ! negative part of fgev [mm/s] > 0 + edir = qvap - qdew + +! compute water budgets (water storages, et components, and runoff) + + call water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , & !in + qvap ,qdew ,ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout + dzsnso ,sh2o ,sice ,ponding,zsnso , & !inout + runsrf ,runsub ,qsnow ,ponding1 ,ponding2,qsnbot,fpice,esnow & !out + ) + +! if(maxval(sice) < 0.0001) then +! write(message,*) "glacier has melted at:",iloc,jloc," are you sure this should be a glacier point?" +! call wrf_debug(10,trim(message)) +! end if + +! water and energy balance check + + call error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & + fsh ,fgev ,ssoil ,sag ,prcp ,edir , & + runsrf ,runsub ,sneqv ,dt ,beg_wb ) + + if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then + snowh = 0.0 + sneqv = 0.0 + end if + + if(swdown.ne.0.) then + albedo = fsr / swdown + else + albedo = -999.9 + end if + + + end subroutine noahmp_glacier +! ================================================================================================== + subroutine atm_glacier (sfcprs ,sfctmp ,q2 ,soldn ,cosz ,thair , & + qair ,eair ,rhoair ,solad ,solai , & + swdown ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + +! outputs + + real , intent(out) :: thair !potential temperature (k) + real , intent(out) :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real , intent(out) :: eair !vapor pressure air (pa) + real, dimension( 1: 2), intent(out) :: solad !incoming direct solar radiation (w/m2) + real, dimension( 1: 2), intent(out) :: solai !incoming diffuse solar radiation (w/m2) + real , intent(out) :: rhoair !density air (kg/m3) + real , intent(out) :: swdown !downward solar filtered by sun angle [w/m2] + +!locals + + real :: pair !atm bottom level pressure (pa) +! -------------------------------------------------------------------------------------------------- + + pair = sfcprs ! atm bottom level pressure (pa) + thair = sfctmp * (sfcprs/pair)**(rair/cpair) +! qair = q2 / (1.0+q2) ! mixing ratio to specific humidity [kg/kg] + qair = q2 ! in wrf, driver converts to specific humidity + + eair = qair*sfcprs / (0.622+0.378*qair) + rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + + if(cosz <= 0.) then + swdown = 0. + else + swdown = soldn + end if + + solad(1) = swdown*0.7*0.5 ! direct vis + solad(2) = swdown*0.7*0.5 ! direct nir + solai(1) = swdown*0.3*0.5 ! diffuse vis + solai(2) = swdown*0.3*0.5 ! diffuse nir + + end subroutine atm_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine energy_glacier (nsnow ,nsoil ,isnow ,dt ,qsnow ,rhoair , & !in + eair ,sfcprs ,qair ,sfctmp ,lwdn ,uu , & !in + vv ,solad ,solai ,cosz ,zref , & !in + tbot ,zbot ,zsnso ,dzsnso , & !in + tg ,stc ,snowh ,sneqv ,sneqvo ,sh2o , & !inout + smc ,snice ,snliq ,albold ,cm ,ch , & !inout + tauss ,qsfc , & !inout + imelt ,snicev ,snliqv ,epore ,qmelt ,ponding, & !out + sag ,fsa ,fsr ,fira ,fsh ,fgev , & !out + trad ,t2m ,ssoil ,lathea ,q2e ,emissi, ch2b ) !out + +! -------------------------------------------------------------------------------------------------- +! -------------------------------------------------------------------------------------------------- +! use noahmp_veg_parameters +! use noahmp_rad_parameters +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: qsnow !snowfall on the ground (mm/s) + real , intent(in) :: rhoair !density air (kg/m3) + real , intent(in) :: eair !vapor pressure air (pa) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: qair !specific humidity (kg/kg) + real , intent(in) :: sfctmp !air temperature (k) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: uu !wind speed in e-w dir (m/s) + real , intent(in) :: vv !wind speed in n-s dir (m/s) + real , dimension( 1: 2), intent(in) :: solad !incoming direct solar rad. (w/m2) + real , dimension( 1: 2), intent(in) :: solai !incoming diffuse solar rad. (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle (0-1) + real , intent(in) :: zref !reference height (m) + real , intent(in) :: tbot !bottom condition for soil temp. (k) + real , intent(in) :: zbot !depth for tbot [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !depth of snow & soil layer-bottom [m] + +! input & output + real , intent(inout) :: tg !ground temperature (k) + real , dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real , intent(inout) :: snowh !snow height [m] + real , intent(inout) :: sneqv !snow mass (mm) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real , dimension(-nsnow+1: 0), intent(inout) :: snice !snow ice mass (kg/m2) + real , dimension(-nsnow+1: 0), intent(inout) :: snliq !snow liq mass (kg/m2) + real , intent(inout) :: albold !snow albedo at last time step(class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: tauss !snow aging factor + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + +! outputs + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] + real , dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume ice [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume liq. water [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real , intent(out) :: qmelt !snowmelt [mm/s] + real , intent(out) :: ponding!pounding at ground [mm] + real , intent(out) :: sag !solar rad. absorbed by ground (w/m2) + real , intent(out) :: fsa !tot. absorbed solar radiation (w/m2) + real , intent(out) :: fsr !tot. reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] + real , intent(out) :: trad !radiative temperature (k) + real , intent(out) :: t2m !2 m height air temperature (k) + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: lathea !latent heat vap./sublimation (j/kg) + real , intent(out) :: q2e + real , intent(out) :: emissi + real , intent(out) :: ch2b !sensible heat conductance, canopy air to zlvl air (m/s) + + +! local + real :: ur !wind speed at height zlvl (m/s) + real :: zlvl !reference height (m) + real :: rsurf !ground surface resistance (s/m) + real :: zpd !zero plane displacement (m) + real :: z0mg !z0 momentum, ground (m) + real :: emg !ground emissivity + real :: fire !emitted ir (w/m2) + real, dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change + real, dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k] + real :: gamma !psychrometric constant (pa/k) + real :: rhsur !raltive humidity in surface soil/snow air space (-) + +! --------------------------------------------------------------------------------------------------- + +! wind speed at reference height: ur >= 1 + + ur = max( sqrt(uu**2.+vv**2.), 1. ) + +! roughness length and displacement height + + z0mg = z0sno + zpd = snowh + + zlvl = zpd + zref + +! thermal properties of soil, snow, lake, and frozen soil + + call thermoprop_glacier (nsoil ,nsnow ,isnow ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out + +! solar radiation: absorbed & reflected by the ground + + call radiation_glacier (dt ,tg ,sneqvo ,sneqv ,cosz , & !in + qsnow ,solad ,solai , & !in + albold ,tauss , & !inout + sag ,fsr ,fsa) !out + +! vegetation and ground emissivity + + emg = 0.98 + +! soil surface resistance for ground evap. + + rhsur = 1.0 + rsurf = 1.0 + +! set psychrometric constant + + lathea = hsub + gamma = cpair*sfcprs/(0.622*lathea) + +! surface temperatures of the ground and energy fluxes + + call glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0mg , & !in + zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + cm ,ch ,tg ,qsfc , & !inout + fira ,fsh ,fgev ,ssoil , & !out + t2m ,q2e ,ch2b) !out + +!energy balance at surface: sag=(irb+shb+evb+ghb) + + fire = lwdn + fira + + if(fire <=0.) call wrf_error_fatal("stop in noah-mp: emitted longwave <0") + + ! compute a net emissivity + emissi = emg + + ! when we're computing a trad, subtract from the emitted ir the + ! reflected portion of the incoming lwdn, so we're just + ! considering the ir originating in the canopy/ground system. + + trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25 + +! 3l snow & 4l soil temperatures + + call tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in + ssoil ,snowh ,zbot ,zsnso ,df , & !in + hcpct , & !in + stc ) !inout + +! adjusting snow surface temperature + if(opt_stc == 2) then + if (snowh > 0.05 .and. tg > tfrz) tg = tfrz + end if + +! energy released or consumed by snow & frozen soil + + call phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out + + + end subroutine energy_glacier +! ================================================================================================== + subroutine thermoprop_glacier (nsoil ,nsnow ,isnow ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out +! ------------------------------------------------------------------------------------------------- +! ------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [s] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers [m] + real , intent(in) :: snowh !snow height [m] + +! outputs + real, dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(out) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(out) :: fact !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + integer :: iz, iz2 + real, dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) + real :: zmid !mid-point soil depth +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + call csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out + + do iz = isnow+1, 0 + df (iz) = tksno(iz) + hcpct(iz) = cvsno(iz) + end do + +! compute soil thermal properties (using noah glacial ice approximations) + + do iz = 1, nsoil + zmid = 0.5 * (dzsnso(iz)) + do iz2 = 1, iz-1 + zmid = zmid + dzsnso(iz2) + end do + hcpct(iz) = 1.e6 * ( 0.8194 + 0.1309*zmid ) + df(iz) = 0.32333 + ( 0.10073 * zmid ) + end do + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + do iz = isnow+1,nsoil + fact(iz) = dt/(hcpct(iz)*dzsnso(iz)) + end do + +! snow/soil interface + + if(isnow == 0) then + df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1)) + else + df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1)) + end if + + + end subroutine thermoprop_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine csnow_glacier (isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out +! -------------------------------------------------------------------------------------------------- +! snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------------------------------------- +! inputs + + integer, intent(in) :: isnow !number of snow layers (-) + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! outputs + + real, dimension(-nsnow+1: 0), intent(out) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0), intent(out) :: tksno !thermal conductivity (w/m/k) + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + do iz = isnow+1, 0 + snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) ) + epore(iz) = 1. - snicev(iz) + snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o)) + enddo + + do iz = isnow+1, 0 + bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz) + cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz) +! cvsno(iz) = 0.525e06 ! constant + enddo + +! thermal conductivity of snow + + do iz = isnow+1, 0 + tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 +! tksno(iz) = 0.35 ! constant +! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) +! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) + enddo + + end subroutine csnow_glacier +!=================================================================================================== + subroutine radiation_glacier (dt ,tg ,sneqvo ,sneqv ,cosz , & !in + qsnow ,solad ,solai , & !in + albold ,tauss , & !inout + sag ,fsr ,fsa) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + real, intent(in) :: dt !time step [s] + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, intent(in) :: qsnow !snowfall (mm/s) + real, dimension(1:2) , intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2) , intent(in) :: solai !incoming diffuse solar radiation (w/m2) + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age + +! output + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + +! local + integer :: ib !number of radiation bands + integer :: nband !number of radiation bands + real :: fage !snow age function (0 - new snow) + real, dimension(1:2) :: albsnd !snow albedo (direct) + real, dimension(1:2) :: albsni !snow albedo (diffuse) + real :: alb !current class albedo + real :: abs !temporary absorbed rad + real :: ref !temporary reflected rad + real :: fsno !snow-cover fraction, = 1 if any snow + real, dimension(1:2) :: albice !albedo land ice: 1=vis, 2=nir + + real,parameter :: mpe = 1.e-6 + +! -------------------------------------------------------------------------------------------------- + + nband = 2 + albsnd = 0.0 + albsni = 0.0 + albice(1) = 0.80 !albedo land ice: 1=vis, 2=nir + albice(2) = 0.55 + +! snow age + + call snow_age_glacier (dt,tg,sneqvo,sneqv,tauss,fage) + +! snow albedos: age even when sun is not present + + if(opt_alb == 1) & + call snowalb_bats_glacier (nband,cosz,fage,albsnd,albsni) + if(opt_alb == 2) then + call snowalb_class_glacier(nband,qsnow,dt,alb,albold,albsnd,albsni) + albold = alb + end if + +! zero summed solar fluxes + + sag = 0. + fsa = 0. + fsr = 0. + + fsno = 0.0 + if(sneqv > 0.0) fsno = 1.0 + +! loop over nband wavebands + + do ib = 1, nband + + albsnd(ib) = albice(ib)*(1.-fsno) + albsnd(ib)*fsno + albsni(ib) = albice(ib)*(1.-fsno) + albsni(ib)*fsno + +! solar radiation absorbed by ground surface + + abs = solad(ib)*(1.-albsnd(ib)) + solai(ib)*(1.-albsni(ib)) + sag = sag + abs + fsa = fsa + abs + + ref = solad(ib)*albsnd(ib) + solai(ib)*albsni(ib) + fsr = fsr + ref + + end do + + end subroutine radiation_glacier +! ================================================================================================== + subroutine snow_age_glacier (dt,tg,sneqvo,sneqv,tauss,fage) +! -------------------------------------------------------------------------------------------------- + implicit none +! ------------------------ code history ------------------------------------------------------------ +! from bats +! ------------------------ input/output variables -------------------------------------------------- +!input + real, intent(in) :: dt !main time step (s) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow water per unit ground area (mm) + +! inout + real, intent(inout) :: tauss !non-dimensional snow age + +!output + real, intent(out) :: fage !snow age + +!local + real :: tage !total aging effects + real :: age1 !effects of grain growth due to vapor diffusion + real :: age2 !effects of grain growth at freezing of melt water + real :: age3 !effects of soot + real :: dela !temporary variable + real :: sge !temporary variable + real :: dels !temporary variable + real :: dela0 !temporary variable + real :: arg !temporary variable +! see yang et al. (1997) j.of climate for detail. +!--------------------------------------------------------------------------------------------------- + + if(sneqv.le.0.0) then + tauss = 0. + else if (sneqv.gt.800.) then + tauss = 0. + else +! tauss = 0. + dela0 = 1.e-6*dt + arg = 5.e3*(1./tfrz-1./tg) + age1 = exp(arg) + age2 = exp(amin1(0.,10.*arg)) + age3 = 0.3 + tage = age1+age2+age3 + dela = dela0*tage + dels = amax1(0.0,sneqv-sneqvo) / swemx + sge = (tauss+dela)*(1.0-dels) + tauss = amax1(0.,sge) + endif + + fage= tauss/(tauss+1.) + + end subroutine snow_age_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine snowalb_bats_glacier (nband,cosz,fage,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: cosz !cosine solar zenith angle + real,intent(in) :: fage !snow age correction + +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + + real :: fzen !zenith angle correction + real :: cf1 !temperary variable + real :: sl2 !2.*sl + real :: sl1 !1/sl + real :: sl !adjustable parameter + real, parameter :: c1 = 0.2 !default in bats + real, parameter :: c2 = 0.5 !default in bats +! real, parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's +! real, parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + sl=2.0 + sl1=1./sl + sl2=2.*sl + cf1=((1.+sl1)/(1.+sl2*cosz)-sl1) + fzen=amax1(cf1,0.) + + albsni(1)=0.95*(1.-c1*fage) + albsni(2)=0.65*(1.-c2*fage) + + albsnd(1)=albsni(1)+0.4*fzen*(1.-albsni(1)) ! vis direct + albsnd(2)=albsni(2)+0.4*fzen*(1.-albsni(2)) ! nir direct + + end subroutine snowalb_bats_glacier +! ================================================================================================== +! -------------------------------------------------------------------------------------------------- + subroutine snowalb_class_glacier (nband,qsnow,dt,alb,albold,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: qsnow !snowfall (mm/s) + real,intent(in) :: dt !time step (sec) + real,intent(in) :: albold !snow albedo at last time step + +! in & out + + real, intent(inout) :: alb ! +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.) + +! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + if (qsnow > 0.) then + alb = alb + min(qsnow*dt,swemx) * (0.84-alb)/(swemx) + endif + + albsni(1)= alb ! vis diffuse + albsni(2)= alb ! nir diffuse + albsnd(1)= alb ! vis direct + albsnd(2)= alb ! nir direct + + end subroutine snowalb_class_glacier +! ================================================================================================== + subroutine glacier_flux (nsoil ,nsnow ,emg ,isnow ,df ,dzsnso ,z0m , & !in + zlvl ,zpd ,qair ,sfctmp ,rhoair ,sfcprs , & !in + ur ,gamma ,rsurf ,lwdn ,rhsur ,smc , & !in + eair ,stc ,sag ,snowh ,lathea ,sh2o , & !in + cm ,ch ,tgb ,qsfc , & !inout + irb ,shb ,evb ,ghb , & !out + t2mb ,q2b ,ehb2) !out + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for glacier. + +! bare soil: +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 +! ---------------------------------------------------------------------- +! use module_model_constants +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + real, intent(in) :: emg !ground emissivity + integer, intent(in) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: qair !specific humidity at height zlvl (kg/kg) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: sfcprs !density air (kg/m3) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: gamma !psychrometric constant (pa/k) + real, intent(in) :: rsurf !ground surface resistance (s/m) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + real, intent(in) :: eair !vapor pressure air at height (pa) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture + real, dimension( 1:nsoil), intent(in) :: sh2o !soil liquid water + real, intent(in) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(in) :: snowh !actual snow depth [m] + real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + +! input/output + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + real, intent(inout) :: tgb !ground temperature (k) + real, intent(inout) :: qsfc !mixing ratio at lowest model layer + +! output +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 + real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] + real, intent(out) :: shb !sensible heat flux (w/m2) [+ to atm] + real, intent(out) :: evb !latent heat flux (w/m2) [+ to atm] + real, intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] + real, intent(out) :: t2mb !2 m height air temperature (k) + real, intent(out) :: q2b !bare ground heat conductance + real, intent(out) :: ehb2 !sensible heat conductance for diagnostics + + +! local variables + integer :: niterb !number of iterations for surface temperature + real :: mpe !prevents overflow error if division by zero + real :: dtg !change in tg, last iteration (k) + integer :: mozsgn !number of times moz changes sign + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + real :: h !temporary sensible heat flux (w/m2) + real :: fv !friction velocity (m/s) + real :: cir !coefficients for ir as function of ts**4 + real :: cgh !coefficients for st as function of ts + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cq2b ! + integer :: iter !iteration index + real :: z0h !roughness length, sensible heat, ground (m) + real :: moz !monin-obukhov stability parameter + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + real :: ramb !aerodynamic resistance for momentum (s/m) + real :: rahb !aerodynamic resistance for sensible heat (s/m) + real :: rawb !aerodynamic resistance for water vapor (s/m) + real :: estg !saturation vapor pressure at tg (pa) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + real :: a !temporary calculation + real :: b !temporary calculation + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + real, dimension( 1:nsoil) :: sice !soil ice + + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + niterb = 5 + mpe = 1e-6 + dtg = 0. + mozsgn = 0 + mozold = 0. + h = 0. + fv = 0.1 + + cir = emg*sb + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + +! ----------------------------------------------------------------- + loop3: do iter = 1, niterb ! begin stability iteration + + z0h = z0m + +! for now, only allow sfcdif1 until others can be fixed + + call sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in + qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & fv ,cm ,ch ,ch2) !out + + ramb = max(1.,1./(cm*ur)) + rahb = max(1.,1./(ch*ur)) + rawb = rahb + +! es and d(es)/dt evaluated at tg + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + csh = rhoair*cpair/rahb + cev = rhoair*cpair/gamma/(rsurf+rawb) + +! surface fluxes and dtg + + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp ) + evb = cev * (estg*rhsur - eair ) + ghb = cgh * (tgb - stc(isnow+1)) + + b = sag-irb-shb-evb-ghb + a = 4.*cir*tgb**3 + csh + cev*destg + cgh + dtg = b/a + + irb = irb + 4.*cir*tgb**3*dtg + shb = shb + csh*dtg + evb = evb + cev*destg*dtg + ghb = ghb + cgh*dtg + +! update ground surface temperature + tgb = tgb + dtg + +! for m-o length + h = csh * (tgb - sfctmp) + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + qsfc = 0.622*(estg*rhsur)/(sfcprs-0.378*(estg*rhsur)) + + end do loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + sice = smc - sh2o + if(opt_stc == 1) then + if ((maxval(sice) > 0.0 .or. snowh > 0.0) .and. tgb > tfrz) then + tgb = tfrz + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp) + evb = cev * (estg*rhsur - eair ) !estg reevaluate ? + ghb = sag - (irb+shb+evb) + end if + end if + +! 2m air temperature + ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2b = ehb2 + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + endif + +! update ch + ch = 1./rahb + + end subroutine glacier_flux +! ================================================================================================== + subroutine esat(t, esw, esi, desw, desi) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + implicit none +!--------------------------------------------------------------------------------------------------- +! in + + real, intent(in) :: t !temperature + +!out + + real, intent(out) :: esw !saturation vapor pressure over water (pa) + real, intent(out) :: esi !saturation vapor pressure over ice (pa) + real, intent(out) :: desw !d(esat)/dt over water (pa/k) + real, intent(out) :: desi !d(esat)/dt over ice (pa/k) + +! local + + real :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water + real :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice + real :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water + real :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice + + parameter (a0=6.107799961 , a1=4.436518521e-01, & + a2=1.428945805e-02, a3=2.650648471e-04, & + a4=3.031240396e-06, a5=2.034080948e-08, & + a6=6.136820929e-11) + + parameter (b0=6.109177956 , b1=5.034698970e-01, & + b2=1.886013408e-02, b3=4.176223716e-04, & + b4=5.824720280e-06, b5=4.838803174e-08, & + b6=1.838826904e-10) + + parameter (c0= 4.438099984e-01, c1=2.857002636e-02, & + c2= 7.938054040e-04, c3=1.215215065e-05, & + c4= 1.036561403e-07, c5=3.532421810e-10, & + c6=-7.090244804e-13) + + parameter (d0=5.030305237e-01, d1=3.773255020e-02, & + d2=1.267995369e-03, d3=2.477563108e-05, & + d4=3.005693132e-07, d5=2.158542548e-09, & + d6=7.131097725e-12) + + esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6)))))) + desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6)))))) + + end subroutine esat +! ================================================================================================== + + subroutine sfcdif1_glacier(iter ,zlvl ,zpd ,z0h ,z0m , & !in + qair ,sfctmp ,h ,rhoair ,mpe ,ur , & !in + & moz ,mozsgn ,fm ,fh ,fm2 ,fh2 , & !inout + & fv ,cm ,ch ,ch2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + integer, intent(in) :: iter !iteration index + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0h !roughness length, sensible heat, ground (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: qair !specific humidity at reference height (kg/kg) + real, intent(in) :: sfctmp !temperature at reference height (k) + real, intent(in) :: h !sensible heat flux (w/m2) [+ to atm] + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: mpe !prevents overflow error if division by zero + real, intent(in) :: ur !wind speed (m/s) + +! in & out + real, intent(inout) :: moz !monin-obukhov stability (z/l) + integer, intent(inout) :: mozsgn !number of times moz changes sign + real, intent(inout) :: fm !momentum stability correction, weighted by prior iters + real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters + +! outputs + real, intent(out) :: fv !friction velocity (m/s) + real, intent(out) :: cm !drag coefficient for momentum + real, intent(out) :: ch !drag coefficient for heat + real, intent(out) :: ch2 !drag coefficient for heat + +! locals + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: tmpcm !temporary calculation for cm + real :: tmpch !temporary calculation for ch + real :: mol !monin-obukhov length (m) + real :: tvir !temporary virtual temperature (k) + real :: tmp1,tmp2,tmp3 !temporary calculation + real :: fmnew !stability correction factor, momentum, for current moz + real :: fhnew !stability correction factor, sen heat, for current moz + real :: moz2 !2/l + real :: tmpcm2 !temporary calculation for cm2 + real :: tmpch2 !temporary calculation for ch2 + real :: fm2new !stability correction factor, momentum, for current moz + real :: fh2new !stability correction factor, sen heat, for current moz + real :: tmp12,tmp22,tmp32 !temporary calculation + + real :: cmfm, chfh, cm2fm2, ch2fh2 + + +! ------------------------------------------------------------------------------------------------- +! monin-obukhov stability parameter moz for next iteration + + mozold = moz + + if(zlvl <= zpd) then + write(*,*) 'critical glacier problem: zlvl <= zpd; model stops', zlvl, zpd + call wrf_error_fatal("stop in noah-mp glacier") + endif + + tmpcm = log((zlvl-zpd) / z0m) + tmpch = log((zlvl-zpd) / z0h) + tmpcm2 = log((2.0 + z0m) / z0m) + tmpch2 = log((2.0 + z0h) / z0h) + + if(iter == 1) then + fv = 0.0 + moz = 0.0 + mol = 0.0 + moz2 = 0.0 + mozold = 0.0 + else + tvir = (1. + 0.61*qair) * sfctmp + tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + mol = -1. * fv**3 / tmp1 + moz = min( (zlvl-zpd)/mol, 1.) + moz2 = min( (2.0 + z0h)/mol, 1.) + endif + +! accumulate number of times moz changes sign. + if (mozold*moz .lt. 0.) mozsgn = mozsgn+1 + if (mozsgn .ge. 2) then + moz = 0. + fm = 0. + fh = 0. + moz2 = 0. + fm2 = 0. + fh2 = 0. + endif + +! evaluate stability-dependent variables using moz from prior iteration + if (moz .lt. 0.) then + tmp1 = (1. - 16.*moz)**0.25 + tmp2 = log((1.+tmp1*tmp1)/2.) + tmp3 = log((1.+tmp1)/2.) + fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963 + fhnew = 2*tmp2 + +! 2-meter + tmp12 = (1. - 16.*moz2)**0.25 + tmp22 = log((1.+tmp12*tmp12)/2.) + tmp32 = log((1.+tmp12)/2.) + fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963 + fh2new = 2*tmp22 + else + fmnew = -5.*moz + fhnew = fmnew + fm2new = -5.*moz2 + fh2new = fm2new + endif + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + if (iter == 1) then + fm = fmnew + fh = fhnew + fm2 = fm2new + fh2 = fh2new + else + fm = 0.5 * (fm+fmnew) + fh = 0.5 * (fh+fhnew) + fm2 = 0.5 * (fm2+fm2new) + fh2 = 0.5 * (fh2+fh2new) + endif + +! exchange coefficients + + fh = min(fh,0.9*tmpch) + fm = min(fm,0.9*tmpcm) + fh2 = min(fh2,0.9*tmpch2) + fm2 = min(fm2,0.9*tmpcm2) + + cmfm = tmpcm-fm + chfh = tmpch-fh + cm2fm2 = tmpcm2-fm2 + ch2fh2 = tmpch2-fh2 + if(abs(cmfm) <= mpe) cmfm = mpe + if(abs(chfh) <= mpe) chfh = mpe + if(abs(cm2fm2) <= mpe) cm2fm2 = mpe + if(abs(ch2fh2) <= mpe) ch2fh2 = mpe + cm = vkc*vkc/(cmfm*cmfm) + ch = vkc*vkc/(cmfm*chfh) + ch2 = vkc*vkc/(cm2fm2*ch2fh2) + +! friction velocity + + fv = ur * sqrt(cm) + ch2 = vkc*fv/ch2fh2 + + end subroutine sfcdif1_glacier +! ================================================================================================== + subroutine tsnosoi_glacier (nsoil ,nsnow ,isnow ,dt ,tbot , & !in + ssoil ,snowh ,zbot ,zsnso ,df , & !in + hcpct , & !in + stc ) !inout +! -------------------------------------------------------------------------------------------------- +! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures +! during melting season may exceed melting point (tfrz) but later in phasechange +! subroutine the snow temperatures are reset to tfrz for melting snow. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + + real, intent(in) :: dt !time step (s) + real, intent(in) :: tbot ! + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, intent(in) :: snowh !snow depth (m) + real, intent(in) :: zbot !from soil surface (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bot. depth from snow surf.(m) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +!input and output + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +!local + + integer :: iz + real :: zbotsno !zbot from snow surface + real, dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts + real :: eflxb !energy influx from soil bottom (w/m2) + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) + +! ---------------------------------------------------------------------- + +! prescribe solar penetration into ice/snow + + phi(isnow+1:nsoil) = 0. + +! adjust zbot from soil surface to zbotsno from snow surface + + zbotsno = zbot - snowh !from snow surface + +! compute ice temperatures + + call hrt_glacier (nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbotsno ,df , & + hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + eflxb ) + + call hstep_glacier (nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) + + end subroutine tsnosoi_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine hrt_glacier (nsnow ,nsoil ,isnow ,zsnso , & !in + stc ,tbot ,zbot ,df , & !in + hcpct ,ssoil ,phi , & !in + ai ,bi ,ci ,rhsts , & !out + botflx ) !out +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + real, intent(in) :: tbot !bottom soil temp. at zbot (k) + real, intent(in) :: zbot !depth of lower boundary condition (m) + !from soil surface not snow surface + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !depth of layer-bottom of snow/soil (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: phi !light through water (w/m2) + +! output + + real, dimension(-nsnow+1:nsoil), intent(out) :: rhsts !right-hand side of the matrix + real, dimension(-nsnow+1:nsoil), intent(out) :: ai !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: bi !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: ci !left-hand side coefficient + real, intent(out) :: botflx !energy influx from soil bottom (w/m2) + +! local + + integer :: k + real, dimension(-nsnow+1:nsoil) :: ddz + real, dimension(-nsnow+1:nsoil) :: denom + real, dimension(-nsnow+1:nsoil) :: dtsdz + real, dimension(-nsnow+1:nsoil) :: eflux + real :: temp1 +! ---------------------------------------------------------------------- + + do k = isnow+1, nsoil + if (k == isnow+1) then + denom(k) = - zsnso(k) * hcpct(k) + temp1 = - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k) + else if (k < nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k) + else if (k == nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k) + if(opt_tbot == 1) then + botflx = 0. + end if + if(opt_tbot == 2) then + dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot) + botflx = -df(k) * dtsdz(k) + end if + eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k) + end if + end do + + do k = isnow+1, nsoil + if (k == isnow+1) then + ai(k) = 0.0 + ci(k) = - df(k) * ddz(k) / denom(k) + if (opt_stc == 1) then + bi(k) = - ci(k) + end if + if (opt_stc == 2) then + bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k)) + end if + else if (k < nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = - df(k ) * ddz(k ) / denom(k) + bi(k) = - (ai(k) + ci (k)) + else if (k == nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - (ai(k) + ci(k)) + end if + rhsts(k) = eflux(k)/ (-denom(k)) + end do + + end subroutine hrt_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine hstep_glacier (nsnow ,nsoil ,isnow ,dt , & !in + ai ,bi ,ci ,rhsts , & !inout + stc ) !inout +! ---------------------------------------------------------------------- +! calculate/update the soil temperature field. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil + integer, intent(in) :: nsnow + integer, intent(in) :: isnow + real, intent(in) :: dt + +! output & input + real, dimension(-nsnow+1:nsoil), intent(inout) :: ai + real, dimension(-nsnow+1:nsoil), intent(inout) :: bi + real, dimension(-nsnow+1:nsoil), intent(inout) :: ci + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + real, dimension(-nsnow+1:nsoil), intent(inout) :: rhsts + +! local + integer :: k + real, dimension(-nsnow+1:nsoil) :: rhstsin + real, dimension(-nsnow+1:nsoil) :: ciin +! ---------------------------------------------------------------------- + + do k = isnow+1,nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + end do + +! copy values for input variables before call to rosr12 + + do k = isnow+1,nsoil + rhstsin(k) = rhsts(k) + ciin(k) = ci(k) + end do + +! solve the tri-diagonal matrix equation + + call rosr12_glacier (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow) + +! update snow & soil temperature + + do k = isnow+1,nsoil + stc (k) = stc (k) + ci (k) + end do + + end subroutine hstep_glacier +! ================================================================================================== + subroutine rosr12_glacier (p,a,b,c,d,delta,ntop,nsoil,nsnow) +! ---------------------------------------------------------------------- +! subroutine rosr12 +! ---------------------------------------------------------------------- +! invert (solve) the tri-diagonal matrix problem shown below: +! ### ### ### ### ### ### +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) # +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) # +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)# +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)# +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + implicit none + + integer, intent(in) :: ntop + integer, intent(in) :: nsoil,nsnow + integer :: k, kk + + real, dimension(-nsnow+1:nsoil),intent(in):: a, b, d + real, dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta + +! ---------------------------------------------------------------------- +! initialize eqn coef c for the lowest soil layer +! ---------------------------------------------------------------------- + c (nsoil) = 0.0 + p (ntop) = - c (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for the 1st soil layer +! ---------------------------------------------------------------------- + delta (ntop) = d (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + p (k) = - c (k) * ( 1.0 / (b (k) + a (k) * p (k -1)) ) + delta (k) = (d (k) - a (k)* delta (k -1))* (1.0/ (b (k) + a (k)& + * p (k -1))) + end do +! ---------------------------------------------------------------------- +! set p to delta for lowest soil layer +! ---------------------------------------------------------------------- + p (nsoil) = delta (nsoil) +! ---------------------------------------------------------------------- +! adjust p for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + kk = nsoil - k + (ntop-1) + 1 + p (kk) = p (kk) * p (kk +1) + delta (kk) + end do +! ---------------------------------------------------------------------- + end subroutine rosr12_glacier +! ---------------------------------------------------------------------- +! ================================================================================================== + subroutine phasechange_glacier (nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! inputs + + integer, intent(in) :: nsnow !maximum no. of snow layers [=3] + integer, intent(in) :: nsoil !no. of soil layers [=4] + integer, intent(in) :: isnow !actual no. of snow layers [<=3] + real, intent(in) :: dt !land model time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: fact !temporary + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! inputs/outputs + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] + real, intent(inout) :: sneqv + real, intent(inout) :: snowh + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] + +! outputs + real, intent(out) :: qmelt !snowmelt rate [mm/s] + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index + real, intent(out) :: ponding!snowmelt when snow has no layer [mm] + +! local + + integer :: j,k !do loop index + real, dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2] + real, dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2] + real, dimension(-nsnow+1:nsoil) :: wmass0 + real, dimension(-nsnow+1:nsoil) :: wice0 + real, dimension(-nsnow+1:nsoil) :: wliq0 + real, dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm] + real, dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm] + real, dimension(-nsnow+1:nsoil) :: heatr !energy residual or loss after melting/freezing + real :: temp1 !temporary variables [kg/m2] + real :: propor + real :: xmf !total latent heat of phase change + +! ---------------------------------------------------------------------- +! initialization + + qmelt = 0. + ponding = 0. + xmf = 0. + + do j = isnow+1,0 ! all snow layers + mice(j) = snice(j) + mliq(j) = snliq(j) + end do + + do j = 1, nsoil ! all soil layers + mliq(j) = sh2o(j) * dzsnso(j) * 1000. + mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000. + end do + + do j = isnow+1,nsoil ! all layers + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = mice(j) + wliq0(j) = mliq(j) + wmass0(j) = mice(j) + mliq(j) + enddo + + do j = isnow+1,nsoil + if (mice(j) > 0. .and. stc(j) >= tfrz) then ! melting + imelt(j) = 1 + endif + if (mliq(j) > 0. .and. stc(j) < tfrz) then ! freezing + imelt(j) = 2 + endif + + ! if snow exists, but its thickness is not enough to create a layer + if (isnow == 0 .and. sneqv > 0. .and. j == 1) then + if (stc(j) >= tfrz) then + imelt(j) = 1 + endif + endif + enddo + +! calculate the energy surplus and loss for melting and freezing + + do j = isnow+1,nsoil + if (imelt(j) > 0) then + hm(j) = (stc(j)-tfrz)/fact(j) + stc(j) = tfrz + endif + + if (imelt(j) == 1 .and. hm(j) < 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + if (imelt(j) == 2 .and. hm(j) > 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + xm(j) = hm(j)*dt/hfus + enddo + +! the rate of melting and freezing for snow without a layer, needs more work. + + if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then + temp1 = sneqv + sneqv = max(0.,temp1-xm(1)) + propor = sneqv/temp1 + snowh = max(0.,propor * snowh) + heatr(1) = hm(1) - hfus*(temp1-sneqv)/dt + if (heatr(1) > 0.) then + xm(1) = heatr(1)*dt/hfus + hm(1) = heatr(1) + imelt(1) = 1 + else + xm(1) = 0. + hm(1) = 0. + imelt(1) = 0 + endif + qmelt = max(0.,(temp1-sneqv))/dt + xmf = hfus*qmelt + ponding = temp1-sneqv + endif + +! the rate of melting and freezing for snow and soil + + do j = isnow+1,nsoil + if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then + + heatr(j) = 0. + if (xm(j) > 0.) then + mice(j) = max(0., wice0(j)-xm(j)) + heatr(j) = hm(j) - hfus*(wice0(j)-mice(j))/dt + else if (xm(j) < 0.) then + mice(j) = min(wmass0(j), wice0(j)-xm(j)) + heatr(j) = hm(j) - hfus*(wice0(j)-mice(j))/dt + endif + + mliq(j) = max(0.,wmass0(j)-mice(j)) + + if (abs(heatr(j)) > 0.) then + stc(j) = stc(j) + fact(j)*heatr(j) + if (j <= 0) then ! snow + if (mliq(j)*mice(j)>0.) stc(j) = tfrz + end if + endif + + if (j > 0) xmf = xmf + hfus * (wice0(j)-mice(j))/dt + + if (j < 1) then + qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt + endif + endif + enddo + heatr = 0.0 + xm = 0.0 + +! deal with residuals in ice/soil + +! first remove excess heat by reducing temperature of layers + + if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then + do j = 1,nsoil + if ( stc(j) > tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + do k = 1,nsoil + if (j .ne. k .and. stc(k) < tfrz .and. heatr(j) > 0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (abs(heatr(k)) > heatr(j)) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 + else + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz + end if + end if + end do + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess cold by increasing temperature of layers (may not be necessary with above loop) + + if (any(stc(1:4) > tfrz) .and. any(stc(1:4) < tfrz)) then + do j = 1,nsoil + if ( stc(j) < tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + do k = 1,nsoil + if (j .ne. k .and. stc(k) > tfrz .and. heatr(j) < -0.1) then + heatr(k) = (stc(k)-tfrz)/fact(k) + if (heatr(k) > abs(heatr(j))) then ! layer absorbs all + heatr(k) = heatr(k) + heatr(j) + stc(k) = tfrz + heatr(k)*fact(k) + heatr(j) = 0.0 + else + heatr(j) = heatr(j) + heatr(k) + heatr(k) = 0.0 + stc(k) = tfrz + end if + end if + end do + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess heat by melting ice + + if (any(stc(1:4) > tfrz) .and. any(mice(1:4) > 0.)) then + do j = 1,nsoil + if ( stc(j) > tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + xm(j) = heatr(j)*dt/hfus + do k = 1,nsoil + if (j .ne. k .and. mice(k) > 0. .and. xm(j) > 0.1) then + if (mice(k) > xm(j)) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 + else + xm(j) = xm(j) - mice(k) + xmf = xmf + hfus * mice(k)/dt + mice(k) = 0.0 + stc(k) = tfrz + end if + mliq(k) = max(0.,wmass0(k)-mice(k)) + end if + end do + heatr(j) = xm(j)*hfus/dt + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + +! now remove excess cold by freezing liquid of layers (may not be necessary with above loop) + + if (any(stc(1:4) < tfrz) .and. any(mliq(1:4) > 0.)) then + do j = 1,nsoil + if ( stc(j) < tfrz ) then + heatr(j) = (stc(j)-tfrz)/fact(j) + xm(j) = heatr(j)*dt/hfus + do k = 1,nsoil + if (j .ne. k .and. mliq(k) > 0. .and. xm(j) < -0.1) then + if (mliq(k) > abs(xm(j))) then ! layer absorbs all + mice(k) = mice(k) - xm(j) + xmf = xmf + hfus * xm(j)/dt + stc(k) = tfrz + xm(j) = 0.0 + else + xm(j) = xm(j) + mliq(k) + xmf = xmf - hfus * mliq(k)/dt + mice(k) = wmass0(k) + stc(k) = tfrz + end if + mliq(k) = max(0.,wmass0(k)-mice(k)) + end if + end do + heatr(j) = xm(j)*hfus/dt + stc(j) = tfrz + heatr(j)*fact(j) + end if + end do + end if + + do j = isnow+1,0 ! snow + snliq(j) = mliq(j) + snice(j) = mice(j) + end do + + do j = 1, nsoil ! soil + sh2o(j) = mliq(j) / (1000. * dzsnso(j)) + sh2o(j) = max(0.0,min(1.0,sh2o(j))) +! smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j)) + smc(j) = 1.0 + end do + + end subroutine phasechange_glacier +! ================================================================================================== + subroutine water_glacier (nsnow ,nsoil ,imelt ,dt ,prcp ,sfctmp , & !in + qvap ,qdew ,ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq ,stc , & !inout + dzsnso ,sh2o ,sice ,ponding,zsnso , & !inout + runsrf ,runsub ,qsnow ,ponding1 ,ponding2,qsnbot,fpice,esnow & !out + ) !out +! ---------------------------------------------------------------------- +! code history: +! initial code: guo-yue niu, oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [1-melt; 2-freeze] + real, intent(in) :: dt !main time step (s) + real, intent(in) :: prcp !precipitation (mm/s) + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: qvap !soil surface evaporation rate[mm/s] + real, intent(in) :: qdew !soil surface dew rate[mm/s] + real, dimension(-nsnow+1: 0), intent(in) :: ficeold !ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + +! input/output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice content [m3/m3] + real , intent(inout) :: ponding ![mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + +! output + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !baseflow (sturation excess) [mm/s] + real, intent(out) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: fpice !precipitation frozen fraction + real, intent(out) :: esnow ! + +! local + real :: qrain !rain at ground srf (mm) [+] + real :: qseva !soil surface evap rate [mm/s] + real :: qsdew !soil surface dew rate [mm/s] + real :: qsnfro !snow surface frost rate[mm/s] + real :: qsnsub !snow surface sublimation rate [mm/s] + real :: snowhin !snow depth increasing rate (m/s) + real :: snoflow !glacier flow [mm/s] + real :: bdfall !density of new snow (mm water/m snow) + real :: replace !replacement water due to sublimation of glacier + real, dimension( 1:nsoil) :: sice_save !soil ice content [m3/m3] + real, dimension( 1:nsoil) :: sh2o_save !soil liquid water content [m3/m3] + integer :: ilev + + +! ---------------------------------------------------------------------- +! initialize + + snoflow = 0. + runsub = 0. + runsrf = 0. + sice_save = sice + sh2o_save = sh2o + +! -------------------------------------------------------------------- +! partition precipitation into rain and snow (from canwater) + +! jordan (1991) + + if(opt_snf == 1 .or. opt_snf == 4) then + if(sfctmp > tfrz+2.5)then + fpice = 0. + else + if(sfctmp <= tfrz+0.5)then + fpice = 1.0 + else if(sfctmp <= tfrz+2.)then + fpice = 1.-(-54.632 + 0.2*sfctmp) + else + fpice = 0.6 + endif + endif + endif + + if(opt_snf == 2) then + if(sfctmp >= tfrz+2.2) then + fpice = 0. + else + fpice = 1.0 + endif + endif + + if(opt_snf == 3) then + if(sfctmp >= tfrz) then + fpice = 0. + else + fpice = 1.0 + endif + endif +! print*, 'fpice: ',fpice + +! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625 +! fresh snow density + + bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb: change to min v3.7 + + qrain = prcp * (1.-fpice) + qsnow = prcp * fpice + snowhin = qsnow/bdfall +! print *, 'qrain, qsnow',qrain,qsnow,qrain*dt,qsnow*dt + +! sublimation, frost, evaporation, and dew + +! qsnsub = 0. +! if (sneqv > 0.) then +! qsnsub = min(qvap, sneqv/dt) +! endif +! qseva = qvap-qsnsub + +! qsnfro = 0. +! if (sneqv > 0.) then +! qsnfro = qdew +! endif +! qsdew = qdew - qsnfro + + qsnsub = qvap ! send total sublimation/frost to snowwater and deal with it there + qsnfro = qdew + esnow = qsnsub*2.83e+6 + + +! print *, 'qvap',qvap,qvap*dt +! print *, 'qsnsub',qsnsub,qsnsub*dt +! print *, 'qseva',qseva,qseva*dt +! print *, 'qsnfro',qsnfro,qsnfro*dt +! print *, 'qdew',qdew,qdew*dt +! print *, 'qsdew',qsdew,qsdew*dt +!print *, 'before snowwater', sneqv,snowh,snice,snliq,sh2o,sice + call snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in + snowhin,qsnow ,qsnfro ,qsnsub ,qrain , & !in + ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +!print *, 'after snowwater', sneqv,snowh,snice,snliq,sh2o,sice +!print *, 'ponding', ponding,ponding1,ponding2 + + !ponding: melting water from snow when there is no layer + + runsrf = (ponding+ponding1+ponding2)/dt + + if(isnow == 0) then + runsrf = runsrf + qsnbot + qrain + else + runsrf = runsrf + qsnbot + endif + + + replace = 0.0 + do ilev = 1,nsoil + replace = replace + dzsnso(ilev)*(sice(ilev) - sice_save(ilev) + sh2o(ilev) - sh2o_save(ilev)) + end do + replace = replace * 1000.0 / dt ! convert to [mm/s] + + sice = min(1.0,sice_save) + sh2o = 1.0 - sice +!print *, 'replace', replace + + ! use runsub as a water balancer, snoflow is snow that disappears, replace is + ! water from below that replaces glacier loss + + runsub = snoflow + replace + + end subroutine water_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine snowwater_glacier (nsnow ,nsoil ,imelt ,dt ,sfctmp , & !in + snowhin,qsnow ,qsnfro ,qsnsub ,qrain , & !in + ficeold,zsoil , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,dzsnso ,zsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (s) + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + real, dimension(-nsnow+1:0) , intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + +! input & output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + +! output + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: snoflow!glacier flow [mm] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local + integer :: iz + real :: bdsnow !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + snoflow = 0.0 + ponding1 = 0.0 + ponding2 = 0.0 + + call snowfall_glacier (nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in + sfctmp , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout + + if(isnow < 0) then !when more than one layer + call compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,imelt ,ficeold, & !in + isnow ,dzsnso ) !inout + + call combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out + + call divide_glacier (nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout + end if + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + + call snowh2o_glacier (nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + ponding1 ,ponding2 , & !inout + qsnbot ) !out + +!to obtain equilibrium state of snow in glacier region + + if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + bdsnow = snice(0) / dzsnso(0) + snoflow = (sneqv - 2000.) + snice(0) = snice(0) - snoflow + dzsnso(0) = dzsnso(0) - snoflow/bdsnow + snoflow = snoflow / dt + end if + +! sum up snow mass for layered snow + + if(isnow /= 0) then + sneqv = 0. + do iz = isnow+1,0 + sneqv = sneqv + snice(iz) + snliq(iz) + enddo + end if + +! reset zsnso and layer thinkness dzsnso + + do iz = isnow+1, 0 + dzsnso(iz) = -dzsnso(iz) + end do + + dzsnso(1) = zsoil(1) + do iz = 2,nsoil + dzsnso(iz) = (zsoil(iz) - zsoil(iz-1)) + end do + + zsnso(isnow+1) = dzsnso(isnow+1) + do iz = isnow+2 ,nsoil + zsnso(iz) = zsnso(iz-1) + dzsnso(iz) + enddo + + do iz = isnow+1 ,nsoil + dzsnso(iz) = -dzsnso(iz) + end do + + end subroutine snowwater_glacier +! ================================================================================================== + subroutine snowfall_glacier (nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in + sfctmp , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !main time step (s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: sfctmp !surface air temperature [k] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: sneqv !swow water equivalent [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !thickness of snow/soil layers (m) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: newnode ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + newnode = 0 + +! shallow snow / no layer + + if(isnow == 0 .and. qsnow > 0.) then + snowh = snowh + snowhin * dt + sneqv = sneqv + qsnow * dt + end if + +! creating a new layer + + if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then + isnow = -1 + newnode = 1 + dzsnso(0)= snowh + snowh = 0. + stc(0) = min(273.16, sfctmp) ! temporary setup + snice(0) = sneqv + snliq(0) = 0. + end if + +! snow with layers + + if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then + snice(isnow+1) = snice(isnow+1) + qsnow * dt + dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt + endif + +! ---------------------------------------------------------------------- + end subroutine snowfall_glacier +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine compact_glacier (nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,imelt ,ficeold, & !in + isnow ,dzsnso ) !inout +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + integer, intent(in) :: nsoil !no. of soil layers [ =4] + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + +! input and output + integer, intent(inout) :: isnow ! actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer thickness [m] + +! local + real, parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3 + real, parameter :: c3 = 2.5e-6 ![1/s] + real, parameter :: c4 = 0.04 ![1/k] + real, parameter :: c5 = 2.0 ! + real, parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] + real, parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to anderson, it is between 0.52e6~1.38e6 + real :: burden !pressure of overlying snow [kg/m2] + real :: ddz1 !rate of settling of snow pack due to destructive metamorphism. + real :: ddz2 !rate of compaction of snow pack due to overburden. + real :: ddz3 !rate of compaction of snow pack due to melt [1/s] + real :: dexpf !expf=exp(-c4*(273.15-stc)). + real :: td !stc - tfrz [k] + real :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s] + real :: void !void (1 - snice - snliq) + real :: wx !water mass (ice + liquid) [kg/m2] + real :: bi !partial density of ice [kg/m3] + real, dimension(-nsnow+1:0) :: fice !fraction of ice at current time step + + integer :: j + +! ---------------------------------------------------------------------- + burden = 0.0 + + do j = isnow+1, 0 + + wx = snice(j) + snliq(j) + fice(j) = snice(j) / wx + void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j) + + ! allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. snice(j) > 0.1) then + bi = snice(j) / dzsnso(j) + td = max(0.,tfrz-stc(j)) + dexpf = exp(-c4*td) + + ! settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! liquid water term + + if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5 + + ! compaction due to overburden + + ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden + + ! compaction occurring during melt + + if (imelt(j) == 1) then + ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j))) + ddz3 = - ddz3/dt ! sometimes too large + else + ddz3 = 0. + end if + + ! time rate of fractional change in dz (units of s-1) + + pdzdtc = (ddz1 + ddz2 + ddz3)*dt + pdzdtc = max(-0.5,pdzdtc) + + ! the change in dz due to compaction + + dzsnso(j) = dzsnso(j)*(1.+pdzdtc) + end if + + ! pressure of overlying snow + + burden = burden + wx + + end do + + end subroutine compact_glacier +! ================================================================================================== + subroutine combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + real, intent(inout) :: sneqv !snow water equivalent [m] + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: ponding1 + real, intent(inout) :: ponding2 + +! local variables: + + integer :: i,j,k,l ! node indices + integer :: isnow_old ! number of top snow layer + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + real :: zwice ! total ice mass in snow + real :: zwliq ! total liquid water in snow + real :: dzmin(3) ! minimum of top snow layer + data dzmin /0.045, 0.05, 0.2/ +! data dzmin /0.025, 0.025, 0.1/ ! mb: change limit +!----------------------------------------------------------------------- + + isnow_old = isnow + + do j = isnow_old+1,0 + if (snice(j) <= .1) then + if(j /= 0) then + snliq(j+1) = snliq(j+1) + snliq(j) + snice(j+1) = snice(j+1) + snice(j) + else + if (isnow_old < -1) then + snliq(j-1) = snliq(j-1) + snliq(j) + snice(j-1) = snice(j-1) + snice(j) + else + ponding1 = ponding1 + snliq(j) ! isnow will get set to zero below + sneqv = snice(j) ! ponding will get added to ponding from + snowh = dzsnso(j) ! phasechange which should be zero here + snliq(j) = 0.0 ! because there it was only calculated + snice(j) = 0.0 ! for thin snow + dzsnso(j) = 0.0 + endif +! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.) +! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.) + endif + + ! shift all elements above this down by one. + if (j > isnow+1 .and. isnow < -1) then + do i = j, isnow+2, -1 + stc(i) = stc(i-1) + snliq(i) = snliq(i-1) + snice(i) = snice(i-1) + dzsnso(i)= dzsnso(i-1) + end do + end if + isnow = isnow + 1 + end if + end do + +! to conserve water in case of too large surface sublimation + + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + + if(isnow ==0) return ! mb: get out if no longer multi-layer + + sneqv = 0. + snowh = 0. + zwice = 0. + zwliq = 0. + + do j = isnow+1,0 + sneqv = sneqv + snice(j) + snliq(j) + snowh = snowh + dzsnso(j) + zwice = zwice + snice(j) + zwliq = zwliq + snliq(j) + end do + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + +! if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit + if (snowh < 0.05 .and. isnow < 0 ) then + isnow = 0 + sneqv = zwice + ponding2 = ponding2 + zwliq ! limit of isnow < 0 means input ponding + if(sneqv <= 0.) snowh = 0. ! should be zero; see above + end if + +! if (snowh < 0.05 ) then +! isnow = 0 +! sneqv = zwice +! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.) +! if(sneqv <= 0.) snowh = 0. +! end if + +! check the snow depth - snow layers combined + + if (isnow < -1) then + + isnow_old = isnow + mssi = 1 + + do i = isnow_old+1,0 + if (dzsnso(i) < dzmin(mssi)) then + + if (i == isnow+1) then + neibor = i + 1 + else if (i == 0) then + neibor = i - 1 + else + neibor = i + 1 + if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1 + end if + + ! node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call combo_glacier (dzsnso(j), snliq(j), snice(j), & + stc(j), dzsnso(l), snliq(l), snice(l), stc(l) ) + + ! now shift all elements above this down one. + if (j-1 > isnow+1) then + do k = j-1, isnow+2, -1 + stc(k) = stc(k-1) + snice(k) = snice(k-1) + snliq(k) = snliq(k-1) + dzsnso(k) = dzsnso(k-1) + end do + end if + + ! decrease the number of snow layers + isnow = isnow + 1 + if (isnow >= -1) exit + else + + ! the layer thickness is greater than the prescribed minimum value + mssi = mssi + 1 + + end if + end do + + end if + + end subroutine combine_glacier +! ================================================================================================== + +! ---------------------------------------------------------------------- + subroutine combo_glacier(dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + real, intent(in) :: dz2 !nodal thickness of 2 elements being combined [m] + real, intent(in) :: wliq2 !liquid water of element 2 [kg/m2] + real, intent(in) :: wice2 !ice of element 2 [kg/m2] + real, intent(in) :: t2 !nodal temperature of element 2 [k] + real, intent(inout) :: dz !nodal thickness of 1 elements being combined [m] + real, intent(inout) :: wliq !liquid water of element 1 + real, intent(inout) :: wice !ice of element 1 [kg/m2] + real, intent(inout) :: t !node temperature of element 1 [k] + +! local + + real :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2). + real :: wliqc !combined liquid water [kg/m2] + real :: wicec !combined ice [kg/m2] + real :: tc !combined node temperature [k] + real :: h !enthalpy of element 1 [j/m2] + real :: h2 !enthalpy of element 2 [j/m2] + real :: hc !temporary + +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq + h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cice*wicec + cwat*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine combo_glacier +! ================================================================================================== + subroutine divide_glacier (nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, intent(in) :: nsoil !no. of soil layers [ =4] + +! input and output + + integer , intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + +! local variables: + + integer :: j !indices + integer :: msno !number of layer (top) to msno (bot) + real :: drr !thickness of the combined [m] + real, dimension( 1:nsnow) :: dz !snow layer thickness [m] + real, dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3] + real, dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3] + real, dimension( 1:nsnow) :: tsno !node temperature [k] + real :: zwice !temporary + real :: zwliq !temporary + real :: propor!temporary + real :: dtdz !temporary +! ---------------------------------------------------------------------- + + do j = 1,nsnow + if (j <= abs(isnow)) then + dz(j) = dzsnso(j+isnow) + swice(j) = snice(j+isnow) + swliq(j) = snliq(j+isnow) + tsno(j) = stc(j+isnow) + end if + end do + + msno = abs(isnow) + + if (msno == 1) then + ! specify a new snow layer + if (dz(1) > 0.05) then + msno = 2 + dz(1) = dz(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + dz(2) = dz(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) + end if + end if + + if (msno > 1) then + if (dz(1) > 0.05) then + drr = dz(1) - 0.05 + propor = drr/dz(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + propor = 0.05/dz(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dz(1) = 0.05 + + call combo_glacier (dz(2), swliq(2), swice(2), tsno(2), drr, & + zwliq, zwice, tsno(1)) + + ! subdivide a new layer +! if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit + if (msno <= 2 .and. dz(2) > 0.10) then + msno = 3 + dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.) + dz(2) = dz(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + dz(3) = dz(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) - dtdz*dz(2)/2. + if (tsno(3) >= tfrz) then + tsno(3) = tsno(2) + else + tsno(2) = tsno(2) + dtdz*dz(2)/2. + endif + + end if + end if + end if + + if (msno > 2) then + if (dz(2) > 0.2) then + drr = dz(2) - 0.2 + propor = drr/dz(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + propor = 0.2/dz(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dz(2) = 0.2 + call combo_glacier (dz(3), swliq(3), swice(3), tsno(3), drr, & + zwliq, zwice, tsno(2)) + end if + end if + + isnow = -msno + + do j = isnow+1,0 + dzsnso(j) = dz(j-isnow) + snice(j) = swice(j-isnow) + snliq(j) = swliq(j-isnow) + stc(j) = tsno(j-isnow) + end do + + +! do j = isnow+1,nsoil +! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j) +! end do + + end subroutine divide_glacier +! ================================================================================================== + subroutine snowh2o_glacier (nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + ponding1 ,ponding2 , & !inout + qsnbot ) !out +! ---------------------------------------------------------------------- +! renew the mass of ice lens (snice) and liquid (snliq) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + integer, intent(in) :: nsnow !maximum no. of snow layers[=3] + integer, intent(in) :: nsoil !no. of soil layers[=4] + real, intent(in) :: dt !time step + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + +! output + + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer depth [m] + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, intent(inout) :: ponding1 + real, intent(inout) :: ponding2 + +! local variables: + + integer :: j !do loop/array indices + real :: qin !water flow into the element (mm/s) + real :: qout !water flow out of the element (mm/s) + real :: wgdif !ice mass after minus sublimation + real, dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer + real, dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer + real, dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice + real :: propor, temp +! ---------------------------------------------------------------------- + +!for the case when sneqv becomes '0' after 'combine' + + if(sneqv == 0.) then + sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) + end if + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. to conserve water, +! excessive sublimation is used to reduce soil water. smaller time steps would tend +! to aviod this problem. + + if(isnow == 0 .and. sneqv > 0.) then + temp = sneqv + sneqv = sneqv - qsnsub*dt + qsnfro*dt + propor = sneqv/temp + snowh = max(0.,propor * snowh) + + if(sneqv < 0.) then + sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.) + sneqv = 0. + snowh = 0. + end if + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + + if(snowh <= 1.e-8 .or. sneqv <= 1.e-6) then + snowh = 0.0 + sneqv = 0.0 + end if + +! for deep snow + + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + + wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt + snice(isnow+1) = wgdif + if (wgdif < 1.e-6 .and. isnow <0) then + call combine_glacier (nsnow ,nsoil , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1, ponding2 ) !inout + endif + !kwm: subroutine combine can change isnow to make it 0 again? + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + snliq(isnow+1) = snliq(isnow+1) + qrain * dt + snliq(isnow+1) = max(0., snliq(isnow+1)) + endif + + endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)? + +! porosity and partial volume + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice)) + epore(j) = 1. - vol_ice(j) + vol_liq(j) = min(epore(j),snliq(j)/(dzsnso(j)*denh2o)) + end if + end do + + qin = 0. + qout = 0. + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + snliq(j) = snliq(j) + qin + if (j <= -1) then + if (epore(j) < 0.05 .or. epore(j+1) < 0.05) then + qout = 0. + else + qout = max(0.,(vol_liq(j)-ssi*epore(j))*dzsnso(j)) + qout = min(qout,(1.-vol_ice(j+1)-vol_liq(j+1))*dzsnso(j+1)) + end if + else + qout = max(0.,(vol_liq(j) - ssi*epore(j))*dzsnso(j)) + end if + qout = qout*1000. + snliq(j) = snliq(j) - qout + qin = qout + end if + end do + +! liquid water from snow bottom to soil + + qsnbot = qout / dt ! mm/s + + end subroutine snowh2o_glacier +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + subroutine error_glacier (iloc ,jloc ,swdown ,fsa ,fsr ,fira , & + fsh ,fgev ,ssoil ,sag ,prcp ,edir , & + runsrf ,runsub ,sneqv ,dt ,beg_wb ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(in) :: fsa !total absorbed solar radiation (w/m2) + real , intent(in) :: fsr !total reflected solar radiation (w/m2) + real , intent(in) :: fira !total net longwave rad (w/m2) [+ to atm] + real , intent(in) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(in) :: fgev !ground evaporation heat (w/m2) [+ to atm] + real , intent(in) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(in) :: sag + + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: edir !soil surface evaporation rate[mm/s] + real , intent(in) :: runsrf !surface runoff [mm/s] + real , intent(in) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(in) :: sneqv !snow water eqv. [mm] + real , intent(in) :: dt !time step [sec] + real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] + + real :: end_wb !water storage at end of a timestep [mm] + real :: errwat !error in water balance [mm/timestep] + real :: erreng !error in surface energy balance [w/m2] + real :: errsw !error in shortwave radiation balance [w/m2] + character(len=256) :: message +! -------------------------------------------------------------------------------------------------- + errsw = swdown - (fsa + fsr) + if (errsw > 0.01) then ! w/m2 + write(*,*) "sag =",sag + write(*,*) "fsa =",fsa + write(*,*) "fsr =",fsr + write(message,*) 'errsw =',errsw + call wrf_message(trim(message)) + call wrf_error_fatal("radiation budget problem in noahmp glacier") + end if + + erreng = sag-(fira+fsh+fgev+ssoil) + if(erreng > 0.01) then + write(message,*) 'erreng =',erreng + call wrf_message(trim(message)) + write(message,'(i6,1x,i6,1x,5f10.4)')iloc,jloc,sag,fira,fsh,fgev,ssoil + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp glacier") + end if + + end_wb = sneqv + errwat = end_wb-beg_wb-(prcp-edir-runsrf-runsub)*dt + + + end subroutine error_glacier +! ================================================================================================== + + subroutine noahmp_options_glacier(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + implicit none + + integer, intent(in) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + integer, intent(in) :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer, intent(in) :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer, intent(in) :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer, intent(in) :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer, intent(in) :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer, intent(in) :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer, intent(in) :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer, intent(in) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + + integer, intent(in) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original noah) + +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + + end subroutine noahmp_options_glacier + +end module noahmp_glacier_routines +! ================================================================================================== + +module module_sf_noahmp_glacier + + use noahmp_glacier_routines + use noahmp_glacier_globals + +end module module_sf_noahmp_glacier + + + + diff --git a/gsmphys/module_sf_noahmplsm.f90 b/gsmphys/module_sf_noahmplsm.f90 new file mode 100644 index 00000000..61f4dc32 --- /dev/null +++ b/gsmphys/module_sf_noahmplsm.f90 @@ -0,0 +1,8201 @@ +module module_sf_noahmplsm + use module_wrf_utl + + implicit none + + public :: noahmp_options + public :: noahmp_sflx + + private :: atm + private :: phenology + private :: precip_heat + private :: energy + private :: thermoprop + private :: csnow + private :: tdfcnd + private :: radiation + private :: albedo + private :: snow_age + private :: snowalb_bats + private :: snowalb_class + private :: groundalb + private :: twostream + private :: surrad + private :: vege_flux + private :: sfcdif1 + private :: sfcdif2 + private :: stomata + private :: canres + private :: esat + private :: ragrb + private :: bare_flux + private :: tsnosoi + private :: hrt + private :: hstep + private :: rosr12 + private :: phasechange + private :: frh2o + + private :: water + private :: canwater + private :: snowwater + private :: snowfall + private :: combine + private :: divide + private :: combo + private :: compact + private :: snowh2o + private :: soilwater + private :: zwteq + private :: infil + private :: srt + private :: wdfcnd1 + private :: wdfcnd2 + private :: sstep + private :: groundwater + private :: shallowwatertable + + private :: carbon + private :: co2flux +! private :: bvocflux +! private :: ch4flux + + private :: error + +! =====================================options for different schemes================================ +! **recommended + + integer :: dveg ! options for dynamic vegetation: + ! 1 -> off (use table lai; use fveg = shdfac from input) + ! 2 -> on (together with opt_crs = 1) + ! 3 -> off (use table lai; calculate fveg) + ! **4 -> off (use table lai; use maximum vegetation fraction) + ! **5 -> on (use maximum vegetation fraction) + + integer :: opt_crs ! options for canopy stomatal resistance + ! **1 -> ball-berry + ! 2 -> jarvis + + integer :: opt_btr ! options for soil moisture factor for stomatal resistance + ! **1 -> noah (soil moisture) + ! 2 -> clm (matric potential) + ! 3 -> ssib (matric potential) + + integer :: opt_run ! options for runoff and groundwater + ! **1 -> topmodel with groundwater (niu et al. 2007 jgr) ; + ! 2 -> topmodel with an equilibrium water table (niu et al. 2005 jgr) ; + ! 3 -> original surface and subsurface runoff (free drainage) + ! 4 -> bats surface and subsurface runoff (free drainage) + ! 5 -> miguez-macho&fan groundwater scheme (miguez-macho et al. 2007 jgr; fan et al. 2007 jgr) + ! (needs further testing for public use) + + integer :: opt_sfc ! options for surface layer drag coeff (ch & cm) + ! **1 -> m-o + ! **2 -> original noah (chen97) + ! **3 -> myj consistent; 4->ysu consistent. mb: removed in v3.7 for further testing + + integer :: opt_frz ! options for supercooled liquid water (or ice fraction) + ! **1 -> no iteration (niu and yang, 2006 jhm) + ! 2 -> koren's iteration + + integer :: opt_inf ! options for frozen soil permeability + ! **1 -> linear effects, more permeable (niu and yang, 2006, jhm) + ! 2 -> nonlinear effects, less permeable (old) + + integer :: opt_rad ! options for radiation transfer + ! 1 -> modified two-stream (gap = f(solar angle, 3d structure ...)<1-fveg) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! **3 -> two-stream applied to vegetated fraction (gap=1-fveg) + + integer :: opt_alb ! options for ground snow surface albedo + ! 1 -> bats + ! **2 -> class + + integer :: opt_snf ! options for partitioning precipitation into rainfall & snowfall + ! **1 -> jordan (1991) + ! 2 -> bats: when sfctmp sfctmp < tfrz + ! 4 -> use wrf microphysics output + + integer :: opt_tbot ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (zbot and tbot not used) + ! **2 -> tbot at zbot (8m) read from a file (original noah) + + integer :: opt_stc ! options for snow/soil temperature time scheme (only layer 1) + ! **1 -> semi-implicit; flux top boundary condition + ! 2 -> full implicit (original noah); temperature top boundary condition + ! 3 -> same as 1, but fsno for ts calculation (generally improves snow; v3.7) + +!------------------------------------------------------------------------------------------! +! physical constants: ! +!------------------------------------------------------------------------------------------! + + real, parameter :: grav = 9.80616 !acceleration due to gravity (m/s2) + real, parameter :: sb = 5.67e-08 !stefan-boltzmann constant (w/m2/k4) + real, parameter :: vkc = 0.40 !von karman constant + real, parameter :: tfrz = 273.16 !freezing/melting point (k) + real, parameter :: hsub = 2.8440e06 !latent heat of sublimation (j/kg) + real, parameter :: hvap = 2.5104e06 !latent heat of vaporization (j/kg) + real, parameter :: hfus = 0.3336e06 !latent heat of fusion (j/kg) + real, parameter :: cwat = 4.188e06 !specific heat capacity of water (j/m3/k) + real, parameter :: cice = 2.094e06 !specific heat capacity of ice (j/m3/k) + real, parameter :: cpair = 1004.64 !heat capacity dry air at const pres (j/kg/k) + real, parameter :: tkwat = 0.6 !thermal conductivity of water (w/m/k) + real, parameter :: tkice = 2.2 !thermal conductivity of ice (w/m/k) + real, parameter :: tkair = 0.023 !thermal conductivity of air (w/m/k) (not used mb: 20140718) + real, parameter :: rair = 287.04 !gas constant for dry air (j/kg/k) + real, parameter :: rw = 461.269 !gas constant for water vapor (j/kg/k) + real, parameter :: denh2o = 1000. !density of water (kg/m3) + real, parameter :: denice = 917. !density of ice (kg/m3) + + integer, private, parameter :: mband = 2 + + type noahmp_parameters ! define a noahmp parameters type + +!------------------------------------------------------------------------------------------! +! from the veg section of mptable.tbl +!------------------------------------------------------------------------------------------! + + logical :: urban_flag + integer :: iswater + integer :: isbarren + integer :: isice + integer :: eblforest + + real :: ch2op !maximum intercepted h2o per unit lai+sai (mm) + real :: dleaf !characteristic leaf dimension (m) + real :: z0mvt !momentum roughness length (m) + real :: hvt !top of canopy (m) + real :: hvb !bottom of canopy (m) + real :: den !tree density (no. of trunks per m2) + real :: rc !tree crown radius (m) + real :: mfsno !snowmelt m parameter () + real :: saim(12) !monthly stem area index, one-sided + real :: laim(12) !monthly leaf area index, one-sided + real :: sla !single-side leaf area per kg [m2/kg] + real :: dilefc !coeficient for leaf stress death [1/s] + real :: dilefw !coeficient for leaf stress death [1/s] + real :: fragr !fraction of growth respiration !original was 0.3 + real :: ltovrc !leaf turnover [1/s] + + real :: c3psn !photosynthetic pathway: 0. = c4, 1. = c3 + real :: kc25 !co2 michaelis-menten constant at 25c (pa) + real :: akc !q10 for kc25 + real :: ko25 !o2 michaelis-menten constant at 25c (pa) + real :: ako !q10 for ko25 + real :: vcmx25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) + real :: avcmx !q10 for vcmx25 + real :: bp !minimum leaf conductance (umol/m**2/s) + real :: mp !slope of conductance-to-photosynthesis relationship + real :: qe25 !quantum efficiency at 25c (umol co2 / umol photon) + real :: aqe !q10 for qe25 + real :: rmf25 !leaf maintenance respiration at 25c (umol co2/m**2/s) + real :: rms25 !stem maintenance respiration at 25c (umol co2/kg bio/s) + real :: rmr25 !root maintenance respiration at 25c (umol co2/kg bio/s) + real :: arm !q10 for maintenance respiration + real :: folnmx !foliage nitrogen concentration when f(n)=1 (%) + real :: tmin !minimum temperature for photosynthesis (k) + + real :: xl !leaf/stem orientation index + real :: rhol(mband) !leaf reflectance: 1=vis, 2=nir + real :: rhos(mband) !stem reflectance: 1=vis, 2=nir + real :: taul(mband) !leaf transmittance: 1=vis, 2=nir + real :: taus(mband) !stem transmittance: 1=vis, 2=nir + + real :: mrp !microbial respiration parameter (umol co2 /kg c/ s) + real :: cwpvt !empirical canopy wind parameter + + real :: wrrat !wood to non-wood ratio + real :: wdpool !wood pool (switch 1 or 0) depending on woody or not [-] + real :: tdlef !characteristic t for leaf freezing [k] + + integer :: nroot !number of soil layers with root present + real :: rgl !parameter used in radiation stress function + real :: rsmin !minimum stomatal resistance [s m-1] + real :: hs !parameter used in vapor pressure deficit function + real :: topt !optimum transpiration air temperature [k] + real :: rsmax !maximal stomatal resistance [s m-1] + + real :: slarea + real :: eps(5) + +!------------------------------------------------------------------------------------------! +! from the rad section of mptable.tbl +!------------------------------------------------------------------------------------------! + + real :: albsat(mband) !saturated soil albedos: 1=vis, 2=nir + real :: albdry(mband) !dry soil albedos: 1=vis, 2=nir + real :: albice(mband) !albedo land ice: 1=vis, 2=nir + real :: alblak(mband) !albedo frozen lakes: 1=vis, 2=nir + real :: omegas(mband) !two-stream parameter omega for snow + real :: betads !two-stream parameter betad for snow + real :: betais !two-stream parameter betad for snow + real :: eg(2) !emissivity + +!------------------------------------------------------------------------------------------! +! from the globals section of mptable.tbl +!------------------------------------------------------------------------------------------! + + real :: co2 !co2 partial pressure + real :: o2 !o2 partial pressure + real :: timean !gridcell mean topgraphic index (global mean) + real :: fsatmx !maximum surface saturated fraction (global mean) + real :: z0sno !snow surface roughness length (m) (0.002) + real :: ssi !liquid water holding capacity for snowpack (m3/m3) + real :: swemx !new snow mass to fully cover old snow (mm) + +!------------------------------------------------------------------------------------------! +! from the soilparm.tbl tables, as functions of soil category. +!------------------------------------------------------------------------------------------! + real :: bexp !b parameter + real :: smcdry !dry soil moisture threshold where direct evap from top + !layer ends (volumetric) (not used mb: 20140718) + real :: smcwlt !wilting point soil moisture (volumetric) + real :: smcref !reference soil moisture (field capacity) (volumetric) + real :: smcmax !porosity, saturated value of soil moisture (volumetric) + real :: f1 !soil thermal diffusivity/conductivity coef (not used mb: 20140718) + real :: psisat !saturated soil matric potential + real :: dksat !saturated soil hydraulic conductivity + real :: dwsat !saturated soil hydraulic diffusivity + real :: quartz !soil quartz content +!------------------------------------------------------------------------------------------! +! from the genparm.tbl file +!------------------------------------------------------------------------------------------! + real :: slope !slope index (0 - 1) + real :: csoil !vol. soil heat capacity [j/m3/k] + real :: zbot !depth (m) of lower boundary soil temperature + real :: czil !calculate roughness length of heat + + real :: kdt !used in compute maximum infiltration rate (in infil) + real :: frzx !used in compute maximum infiltration rate (in infil) + + end type noahmp_parameters + +contains +! +!== begin noahmp_sflx ============================================================================== + + subroutine noahmp_sflx (parameters, & + iloc , jloc , lat , yearlen , julian , cosz , & ! in : time/space-related + dt , dx , dz8w , nsoil , zsoil , nsnow , & ! in : model configuration + shdfac , shdmax , vegtyp , ice , ist , & ! in : vegetation/soil characteristics + smceq , & ! in : vegetation/soil characteristics + sfctmp , sfcprs , psfc , uu , vv , q2 , & ! in : forcing + qc , soldn , lwdn , & ! in : forcing + prcpconv, prcpnonc, prcpshcv, prcpsnow, prcpgrpl, prcphail, & ! in : forcing + tbot , co2air , o2air , foln , ficeold , zlvl , & ! in : forcing + albold , sneqvo , & ! in/out : + stc , sh2o , smc , tah , eah , fwet , & ! in/out : + canliq , canice , tv , tg , qsfc , qsnow , & ! in/out : + isnow , zsnso , snowh , sneqv , snice , snliq , & ! in/out : + zwt , wa , wt , wslake , lfmass , rtmass , & ! in/out : + stmass , wood , stblcp , fastcp , lai , sai , & ! in/out : + cm , ch , tauss , & ! in/out : + smcwtd ,deeprech , rech , & ! in/out : + z0wrf , & + fsa , fsr , fira , fsh , ssoil , fcev , & ! out : + fgev , fctr , ecan , etran , edir , trad , & ! out : + tgb , tgv , t2mv , t2mb , q2v , q2b , & ! out : + runsrf , runsub , apar , psn , sav , sag , & ! out : + fsno , nee , gpp , npp , fveg , albedo , & ! out : + qsnbot , ponding , ponding1, ponding2, rssun , rssha , & ! out : + bgap , wgap , chv , chb , emissi , & ! out : + shg , shc , shb , evg , evb , ghv , & ! out : + ghb , irg , irc , irb , tr , evc , & ! out : + chleaf , chuc , chv2 , chb2 , fpice , pahv , & + pahg , pahb , pah , esnow) + +! -------------------------------------------------------------------------------------------------- +! initial code: guo-yue niu, oct. 2007 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + + integer , intent(in) :: ice !ice (ice = 1) + integer , intent(in) :: ist !surface type 1->soil; 2->lake + integer , intent(in) :: vegtyp !vegetation type + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !no. of soil layers + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: dt !time step [sec] + real, dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf (m) + real , intent(in) :: q2 !mixing ratio (kg/kg) lowest model layer + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: uu !wind speed in eastward dir (m/s) + real , intent(in) :: vv !wind speed in northward dir (m/s) + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(inout) :: zlvl !reference height (m) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + real , intent(in) :: tbot !bottom condition for soil temp. [k] + real , intent(in) :: foln !foliage nitrogen (%) [1-saturated] + real , intent(in) :: shdfac !green vegetation fraction [0.0-1.0] + integer , intent(in) :: yearlen!number of days in the particular year. + real , intent(in) :: julian !julian day of year (floating point) + real , intent(in) :: lat !latitude (radians) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] + real , intent(in) :: prcpconv ! convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpnonc ! non-convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpshcv ! shallow convective precip entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpsnow ! snow entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpgrpl ! graupel entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcphail ! hail entering land model [mm/s] ! mb/an : v3.7 + +!jref:start; in + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(in) :: dx + real , intent(in) :: shdmax !yearly max vegetation fraction +!jref:end + + +! input/output : need arbitary intial values + real , intent(inout) :: qsnow !snowfall [mm/s] + real , intent(inout) :: fwet !wetted or snowed fraction of canopy (-) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , intent(inout) :: eah !canopy air vapor pressure (pa) + real , intent(inout) :: tah !canopy air tmeperature (k) + real , intent(inout) :: albold !snow albedo at last time step (class type) + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: tauss !non-dimensional snow age + +! prognostic variables + integer , intent(inout) :: isnow !actual no. of snow layers [-] + real , intent(inout) :: canliq !intercepted liquid water (mm) + real , intent(inout) :: canice !intercepted ice mass (mm) + real , intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !layer-bottom depth from snow surf [m] + real , intent(inout) :: snowh !snow height [m] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real , intent(inout) :: tv !vegetation temperature (k) + real , intent(inout) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , intent(inout) :: zwt !depth to water table [m] + real , intent(inout) :: wa !water storage in aquifer [mm] + real , intent(inout) :: wt !water in aquifer&saturated soil [mm] + real , intent(inout) :: wslake !lake water storage (can be neg.) (mm) + real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] + real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] + real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + +! output + real , intent(out) :: z0wrf !combined z0 sent to coupled model + real , intent(out) :: fsa !total absorbed solar radiation (w/m2) + real , intent(out) :: fsr !total reflected solar radiation (w/m2) + real , intent(out) :: fira !total net lw rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fcev !canopy evap heat (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evap heat (w/m2) [+ to atm] + real , intent(out) :: fctr !transpiration heat (w/m2) [+ to atm] + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(out) :: trad !surface radiative temperature (k) + real :: ts !surface temperature (k) + real , intent(out) :: ecan !evaporation of intercepted water (mm/s) + real , intent(out) :: etran !transpiration rate (mm/s) + real , intent(out) :: edir !soil surface evaporation rate (mm/s] + real , intent(out) :: runsrf !surface runoff [mm/s] + real , intent(out) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(out) :: psn !total photosynthesis (umol co2/m2/s) [+] + real , intent(out) :: apar !photosyn active energy by canopy (w/m2) + real , intent(out) :: sav !solar rad absorbed by veg. (w/m2) + real , intent(out) :: sag !solar rad absorbed by ground (w/m2) + real , intent(out) :: fsno !snow cover fraction on the ground (-) + real , intent(out) :: fveg !green vegetation fraction [0.0-1.0] + real , intent(out) :: albedo !surface albedo [-] + real :: errwat !water error [kg m{-2}] + real , intent(out) :: qsnbot !snowmelt out bottom of pack [mm/s] + real , intent(out) :: ponding!surface ponding [mm] + real , intent(out) :: ponding1!surface ponding [mm] + real , intent(out) :: ponding2!surface ponding [mm] + real , intent(out) :: esnow + +!jref:start; output + real , intent(out) :: t2mv !2-m air temperature over vegetated part [k] + real , intent(out) :: t2mb !2-m air temperature over bare ground part [k] + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) + real, intent(out) :: bgap + real, intent(out) :: wgap + real, intent(out) :: tgv + real, intent(out) :: tgb + real :: q1 + real, intent(out) :: emissi +!jref:end + +! local + integer :: iz !do-loop index + integer, dimension(-nsnow+1:nsoil) :: imelt !phase change index [1-melt; 2-freeze] + real :: cmc !intercepted water (canice+canliq) (mm) + real :: taux !wind stress: e-w (n/m2) + real :: tauy !wind stress: n-s (n/m2) + real :: rhoair !density air (kg/m3) +! real, dimension( 1: 5) :: vocflx !voc fluxes [ug c m-2 h-1] + real, dimension(-nsnow+1:nsoil) :: dzsnso !snow/soil layer thickness [m] + real :: thair !potential temperature (k) + real :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real :: eair !vapor pressure air (pa) + real, dimension( 1: 2) :: solad !incoming direct solar rad (w/m2) + real, dimension( 1: 2) :: solai !incoming diffuse solar rad (w/m2) + real :: qprecc !convective precipitation (mm/s) + real :: qprecl !large-scale precipitation (mm/s) + real :: igs !growing season index (0=off, 1=on) + real :: elai !leaf area index, after burying by snow + real :: esai !stem area index, after burying by snow + real :: bevap !soil water evaporation factor (0 - 1) + real, dimension( 1:nsoil) :: btrani !soil water transpiration factor (0 - 1) + real :: btran !soil water transpiration factor (0 - 1) + real :: qin !groundwater recharge [mm/s] + real :: qdis !groundwater discharge [mm/s] + real, dimension( 1:nsoil) :: sice !soil ice content (m3/m3) + real, dimension(-nsnow+1: 0) :: snicev !partial volume ice of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: snliqv !partial volume liq of snow [m3/m3] + real, dimension(-nsnow+1: 0) :: epore !effective porosity [m3/m3] + real :: totsc !total soil carbon (g/m2) + real :: totlb !total living carbon (g/m2) + real :: t2m !2-meter air temperature (k) + real :: qdew !ground surface dew rate [mm/s] + real :: qvap !ground surface evap. rate [mm/s] + real :: lathea !latent heat [j/kg] + real :: swdown !downward solar [w/m2] + real :: qmelt !snowmelt [mm/s] + real :: beg_wb !water storage at begin of a step [mm] + real,intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm] + real,intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm] + real,intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm] + real,intent(out) :: shg !ground sen. heat [w/m2] [+ to atm] + real,intent(out) :: evg !ground evap. heat [w/m2] [+ to atm] + real,intent(out) :: ghv !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: irb !net longwave rad. [w/m2] [+ to atm] + real,intent(out) :: shb !sensible heat [w/m2] [+ to atm] + real,intent(out) :: evb !evaporation heat [w/m2] [+ to atm] + real,intent(out) :: ghb !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm] + real,intent(out) :: tr !transpiration heat [w/m2] [+ to atm] + real, intent(out) :: fpice !snow fraction in precipitation + real, intent(out) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(out) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(out) :: pahb !precipitation advected heat - bare ground net (w/m2) + real, intent(out) :: pah !precipitation advected heat - total (w/m2) + +!jref:start + real :: fsrv + real :: fsrg + real,intent(out) :: q2v + real,intent(out) :: q2b + real :: q2e + real :: qfx + real,intent(out) :: chv !sensible heat exchange coefficient over vegetated fraction + real,intent(out) :: chb !sensible heat exchange coefficient over bare-ground + real,intent(out) :: chleaf !leaf exchange coefficient + real,intent(out) :: chuc !under canopy exchange coefficient + real,intent(out) :: chv2 !sensible heat exchange coefficient over vegetated fraction + real,intent(out) :: chb2 !sensible heat exchange coefficient over bare-ground +!jref:end + +! carbon +! inputs + real , intent(in) :: co2air !atmospheric co2 concentration (pa) + real , intent(in) :: o2air !atmospheric o2 concentration (pa) + +! inputs and outputs : prognostic variables + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + real , intent(inout) :: stblcp !stable carbon in deep soil [g/m2] + real , intent(inout) :: fastcp !short-lived carbon, shallow soil [g/m2] + real , intent(inout) :: lai !leaf area index [-] + real , intent(inout) :: sai !stem area index [-] + +! outputs + real , intent(out) :: nee !net ecosys exchange (g/m2/s co2) + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c] + real , intent(out) :: npp !net primary productivity [g/m2/s c] + real :: autors !net ecosystem respiration (g/m2/s c) + real :: heters !organic respiration (g/m2/s c) + real :: troot !root-zone averaged temperature (k) + real :: bdfall !bulk density of new snow (kg/m3) ! mb/an: v3.7 + real :: rain !rain rate (mm/s) ! mb/an: v3.7 + real :: snow !liquid equivalent snow rate (mm/s) ! mb/an: v3.7 + real :: fp ! mb/an: v3.7 + real :: prcp ! mb/an: v3.7 +!more local variables for precip heat mb + real :: qintr !interception rate for rain (mm/s) + real :: qdripr !drip rate for rain (mm/s) + real :: qthror !throughfall for rain (mm/s) + real :: qints !interception (loading) rate for snowfall (mm/s) + real :: qdrips !drip (unloading) rate for intercepted snow (mm/s) + real :: qthros !throughfall of snowfall (mm/s) + real :: qrain !rain at ground srf (mm/s) [+] + real :: snowhin !snow depth increasing rate (m/s) + real :: latheav !latent heat vap./sublimation (j/kg) + real :: latheag !latent heat vap./sublimation (j/kg) + logical :: frozen_ground ! used to define latent heat pathway + logical :: frozen_canopy ! used to define latent heat pathway + + ! intent (out) variables need to be assigned a value. these normally get assigned values + ! only if dveg == 2. + nee = 0.0 + npp = 0.0 + gpp = 0.0 + pahv = 0. + pahg = 0. + pahb = 0. + pah = 0. + +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing + + call atm (parameters,sfcprs ,sfctmp ,q2 , & + prcpconv, prcpnonc,prcpshcv,prcpsnow,prcpgrpl,prcphail, & + soldn ,cosz ,thair ,qair , & + eair ,rhoair ,qprecc ,qprecl ,solad ,solai , & + swdown ,bdfall ,rain ,snow ,fp ,fpice , prcp ) + +! snow/soil layer thickness (m) + + do iz = isnow+1, nsoil + if(iz == isnow+1) then + dzsnso(iz) = - zsnso(iz) + else + dzsnso(iz) = zsnso(iz-1) - zsnso(iz) + end if + end do + +! root-zone temperature + + troot = 0. + do iz=1,parameters%nroot + troot = troot + stc(iz)*dzsnso(iz)/(-zsoil(parameters%nroot)) + enddo + +! total water storage for water balance check + + if(ist == 1) then + beg_wb = canliq + canice + sneqv + wa + do iz = 1,nsoil + beg_wb = beg_wb + smc(iz) * dzsnso(iz) * 1000. + end do + end if + +! vegetation phenology + + call phenology (parameters,vegtyp , snowh , tv , lat , yearlen , julian , & !in + lai , sai , troot , elai , esai ,igs) + +!input gvf should be consistent with lai + if(dveg == 1) then + fveg = shdfac + if(fveg <= 0.05) fveg = 0.05 + else if (dveg == 2 .or. dveg == 3) then + fveg = 1.-exp(-0.52*(lai+sai)) + if(fveg <= 0.05) fveg = 0.05 + else if (dveg == 4 .or. dveg == 5) then + fveg = shdmax + if(fveg <= 0.05) fveg = 0.05 + else + write(*,*) "-------- fatal called in sflx -----------" + call wrf_error_fatal("namelist parameter dveg unknown") + endif + if(parameters%urban_flag .or. vegtyp == parameters%isbarren) fveg = 0.0 + if(elai+esai == 0.0) fveg = 0.0 + + call precip_heat(parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in + elai ,esai ,fveg ,ist , & !in + bdfall ,rain ,snow ,fp , & !in + canliq ,canice ,tv ,sfctmp ,tg , & !in + qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out + +! compute energy budget (momentum & energy fluxes and phase changes) + + call energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in + isnow ,dt ,rhoair ,sfcprs ,qair , & !in + sfctmp ,thair ,lwdn ,uu ,vv ,zlvl , & !in + co2air ,o2air ,solad ,solai ,cosz ,igs , & !in + eair ,tbot ,zsnso ,zsoil , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,pahv ,pahg ,pahb , & !in + qsnow ,dzsnso ,lat ,canliq ,canice ,iloc, jloc , & !in + z0wrf , & + imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out + sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out + tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + trad ,psn ,apar ,ssoil ,btrani ,btran , & !out + ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out + tv ,tg ,stc ,snowh ,eah ,tah , & !inout + sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout + albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout + tauss , & !inout +!jref:start + qc ,qsfc ,psfc , & !in + t2mv ,t2mb ,fsrv , & + fsrg ,rssun ,rssha ,bgap ,wgap, tgv,tgb,& + q1 ,q2v ,q2b ,q2e ,chv ,chb , & !out + emissi ,pah , & + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out +!jref:end + + sice(:) = max(0.0, smc(:) - sh2o(:)) + sneqvo = sneqv + + qvap = max( fgev/latheag, 0.) ! positive part of fgev; barlage change to ground v3.6 + qdew = abs( min(fgev/latheag, 0.)) ! negative part of fgev + edir = qvap - qdew + +! compute water budgets (water storages, et components, and runoff) + + call water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in + vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in + esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in + ficeold,ponding,tg ,ist ,fveg ,iloc,jloc , smceq , & !in + bdfall ,fp ,rain ,snow , & !in mb/an: v3.7 + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout + snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout + sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout + smcwtd ,deeprech,rech , & !inout + cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out + qin ,qdis ,ponding1 ,ponding2,& + qsnbot ,esnow ) !out + +! write(*,'(a20,10f15.5)') 'sflx:runoff=',runsrf*dt,runsub*dt,edir*dt + +! compute carbon budgets (carbon storages and co2 & bvoc fluxes) + + if (dveg == 2 .or. dveg == 5) then + call carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in + dzsnso ,stc ,smc ,tv ,tg ,psn , & !in + foln ,btran ,apar ,fveg ,igs , & !in + troot ,ist ,lat ,iloc ,jloc , & !in + lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout + gpp ,npp ,nee ,autors ,heters ,totsc , & !out + totlb ,lai ,sai ) !out + end if + +! water and energy balance check + + call error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & !in + fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & !in + sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & !in + etran ,edir ,runsrf ,runsub ,dt ,nsoil , & !in + nsnow ,ist ,errwat ,iloc , jloc ,fveg , & + sav ,sag ,fsrv ,fsrg ,zwt ,pah , & + pahv ,pahg ,pahb ) !in ( except errwat, which is out ) + +! urban - jref + qfx = etran + ecan + edir + if ( parameters%urban_flag ) then + qsfc = (qfx/rhoair*ch) + qair + q2b = qsfc + end if + + if(snowh <= 1.e-6 .or. sneqv <= 1.e-3) then + snowh = 0.0 + sneqv = 0.0 + end if + + if(swdown.ne.0.) then + albedo = fsr / swdown + else + albedo = -999.9 + end if + + + end subroutine noahmp_sflx + +!== begin atm ====================================================================================== + + subroutine atm (parameters,sfcprs ,sfctmp ,q2 , & + prcpconv,prcpnonc ,prcpshcv,prcpsnow,prcpgrpl,prcphail , & + soldn ,cosz ,thair ,qair , & + eair ,rhoair ,qprecc ,qprecl ,solad , solai , & + swdown ,bdfall ,rain ,snow ,fp , fpice ,prcp ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! ---------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: sfctmp !surface air temperature [k] + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: prcpconv ! convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpnonc ! non-convective precipitation entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpshcv ! shallow convective precip entering [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpsnow ! snow entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcpgrpl ! graupel entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: prcphail ! hail entering land model [mm/s] ! mb/an : v3.7 + real , intent(in) :: soldn !downward shortwave radiation (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle [0-1] + +! outputs + + real , intent(out) :: thair !potential temperature (k) + real , intent(out) :: qair !specific humidity (kg/kg) (q2/(1+q2)) + real , intent(out) :: eair !vapor pressure air (pa) + real , intent(out) :: rhoair !density air (kg/m3) + real , intent(out) :: qprecc !convective precipitation (mm/s) + real , intent(out) :: qprecl !large-scale precipitation (mm/s) + real, dimension( 1: 2), intent(out) :: solad !incoming direct solar radiation (w/m2) + real, dimension( 1: 2), intent(out) :: solai !incoming diffuse solar radiation (w/m2) + real , intent(out) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(out) :: bdfall !!bulk density of snowfall (kg/m3) ajn + real , intent(out) :: rain !rainfall (mm/s) ajn + real , intent(out) :: snow !liquid equivalent snowfall (mm/s) ajn + real , intent(out) :: fp !fraction of area receiving precipitation ajn + real , intent(out) :: fpice !fraction of ice ajn + real , intent(out) :: prcp !total precipitation [mm/s] ! mb/an : v3.7 + +!locals + + real :: pair !atm bottom level pressure (pa) + real :: prcp_frozen !total frozen precipitation [mm/s] ! mb/an : v3.7 + real, parameter :: rho_grpl = 500.0 ! graupel bulk density [kg/m3] ! mb/an : v3.7 + real, parameter :: rho_hail = 917.0 ! hail bulk density [kg/m3] ! mb/an : v3.7 +! -------------------------------------------------------------------------------------------------- + +!jref: seems like pair should be p1000mb?? + pair = sfcprs ! atm bottom level pressure (pa) + thair = sfctmp * (sfcprs/pair)**(rair/cpair) + + qair = q2 ! in wrf, driver converts to specific humidity + + eair = qair*sfcprs / (0.622+0.378*qair) + rhoair = (sfcprs-0.378*eair) / (rair*sfctmp) + + if(cosz <= 0.) then + swdown = 0. + else + swdown = soldn + end if + + solad(1) = swdown*0.7*0.5 ! direct vis + solad(2) = swdown*0.7*0.5 ! direct nir + solai(1) = swdown*0.3*0.5 ! diffuse vis + solai(2) = swdown*0.3*0.5 ! diffuse nir + + prcp = prcpconv + prcpnonc + prcpshcv + +! if(opt_snf == 4) then + qprecc = prcpconv + prcpshcv + qprecl = prcpnonc +! else +! qprecc = 0.10 * prcp ! should be from the atmospheric model +! qprecl = 0.90 * prcp ! should be from the atmospheric model +! end if + +! fractional area that receives precipitation (see, niu et al. 2005) + + fp = 0.0 + if(qprecc + qprecl > 0.) & + fp = (qprecc + qprecl) / (10.*qprecc + qprecl) + +! partition precipitation into rain and snow. moved from canwat mb/an: v3.7 + +! jordan (1991) + + if(opt_snf == 1) then + if(sfctmp > tfrz+2.5)then + fpice = 0. + else + if(sfctmp <= tfrz+0.5)then + fpice = 1.0 + else if(sfctmp <= tfrz+2.)then + fpice = 1.-(-54.632 + 0.2*sfctmp) + else + fpice = 0.6 + endif + endif + endif + + if(opt_snf == 2) then + if(sfctmp >= tfrz+2.2) then + fpice = 0. + else + fpice = 1.0 + endif + endif + + if(opt_snf == 3) then + if(sfctmp >= tfrz) then + fpice = 0. + else + fpice = 1.0 + endif + endif + +! hedstrom nr and jw pomeroy (1998), hydrol. processes, 12, 1611-1625 +! fresh snow density + + bdfall = min(120.,67.92+51.25*exp((sfctmp-tfrz)/2.59)) !mb/an: change to min + if(opt_snf == 4) then + prcp_frozen = prcpsnow + prcpgrpl + prcphail + if(prcpnonc > 0. .and. prcp_frozen > 0.) then + fpice = min(1.0,prcp_frozen/prcp) + fpice = max(0.0,fpice) + bdfall = bdfall*(prcpsnow/prcp_frozen) + rho_grpl*(prcpgrpl/prcp_frozen) + & + rho_hail*(prcphail/prcp_frozen) + else + fpice = 0.0 + endif + + endif + + rain = prcp * (1.-fpice) + snow = prcp * fpice + + + end subroutine atm + +!== begin phenology ================================================================================ + + subroutine phenology (parameters,vegtyp , snowh , tv , lat , yearlen , julian , & !in + lai , sai , troot , elai , esai , igs) + +! -------------------------------------------------------------------------------------------------- +! vegetation phenology considering vegeation canopy being buries by snow and evolution in time +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in ) :: vegtyp !vegetation type + real , intent(in ) :: snowh !snow height [m] + real , intent(in ) :: tv !vegetation temperature (k) + real , intent(in ) :: lat !latitude (radians) + integer , intent(in ) :: yearlen!number of days in the particular year + real , intent(in ) :: julian !julian day of year (fractional) ( 0 <= julian < yearlen ) + real , intent(in ) :: troot !root-zone averaged temperature (k) + real , intent(inout) :: lai !lai, unadjusted for burying by snow + real , intent(inout) :: sai !sai, unadjusted for burying by snow + +! outputs + real , intent(out ) :: elai !leaf area index, after burying by snow + real , intent(out ) :: esai !stem area index, after burying by snow + real , intent(out ) :: igs !growing season index (0=off, 1=on) + +! locals + + real :: db !thickness of canopy buried by snow (m) + real :: fb !fraction of canopy buried by snow + real :: snowhc !critical snow depth at which short vege + !is fully covered by snow + + integer :: k !index + integer :: it1,it2 !interpolation months + real :: day !current day of year ( 0 <= day < yearlen ) + real :: wt1,wt2 !interpolation weights + real :: t !current month (1.00, ..., 12.00) +! -------------------------------------------------------------------------------------------------- + + if ( dveg == 1 .or. dveg == 3 .or. dveg == 4 ) then + + if (lat >= 0.) then + ! northern hemisphere + day = julian + else + ! southern hemisphere. day is shifted by 1/2 year. + day = mod ( julian + ( 0.5 * yearlen ) , real(yearlen) ) + endif + + t = 12. * day / real(yearlen) + it1 = t + 0.5 + it2 = it1 + 1 + wt1 = (it1+0.5) - t + wt2 = 1.-wt1 + if (it1 .lt. 1) it1 = 12 + if (it2 .gt. 12) it2 = 1 + + lai = wt1*parameters%laim(it1) + wt2*parameters%laim(it2) + sai = wt1*parameters%saim(it1) + wt2*parameters%saim(it2) + endif + if (sai < 0.05) sai = 0.0 ! mb: sai check, change to 0.05 v3.6 + if (lai < 0.05 .or. sai == 0.0) lai = 0.0 ! mb: lai check + + if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. & + ( vegtyp == parameters%isice ) .or. ( parameters%urban_flag ) ) then + lai = 0. + sai = 0. + endif + +!buried by snow + + db = min( max(snowh - parameters%hvb,0.), parameters%hvt-parameters%hvb ) + fb = db / max(1.e-06,parameters%hvt-parameters%hvb) + + if(parameters%hvt> 0. .and. parameters%hvt <= 1.0) then !mb: change to 1.0 and 0.2 to reflect + snowhc = parameters%hvt*exp(-snowh/0.2) ! changes to hvt in mptable + fb = min(snowh,snowhc)/snowhc + endif + + elai = lai*(1.-fb) + esai = sai*(1.-fb) + if (esai < 0.05) esai = 0.0 ! mb: esai check, change to 0.05 v3.6 + if (elai < 0.05 .or. esai == 0.0) elai = 0.0 ! mb: lai check + + if (tv .gt. parameters%tmin) then + igs = 1. + else + igs = 0. + endif + + end subroutine phenology + +!== begin precip_heat ============================================================================== + + subroutine precip_heat (parameters,iloc ,jloc ,vegtyp ,dt ,uu ,vv , & !in + elai ,esai ,fveg ,ist , & !in + bdfall ,rain ,snow ,fp , & !in + canliq ,canice ,tv ,sfctmp ,tg , & !in + qintr ,qdripr ,qthror ,qints ,qdrips ,qthros , & !out + pahv ,pahg ,pahb ,qrain ,qsnow ,snowhin, & !out + fwet ,cmc ) !out + +! ------------------------ code history ------------------------------ +! michael barlage: oct 2013 - split canwater to calculate precip movement for +! tracking of advected heat +! -------------------------------------------------------------------------------------------------- + implicit none +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation type + integer,intent(in) :: ist !surface type 1-soil; 2-lake + real, intent(in) :: dt !main time step (s) + real, intent(in) :: uu !u-direction wind speed [m/s] + real, intent(in) :: vv !v-direction wind speed [m/s] + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: fveg !greeness vegetation fraction (-) + real, intent(in) :: bdfall !bulk density of snowfall (kg/m3) + real, intent(in) :: rain !rainfall (mm/s) + real, intent(in) :: snow !snowfall (mm/s) + real, intent(in) :: fp !fraction of the gridcell that receives precipitation + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: sfctmp !model-level temperature (k) + real, intent(in) :: tg !ground temperature (k) + +! input & output + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + +! output + real, intent(out) :: qintr !interception rate for rain (mm/s) + real, intent(out) :: qdripr !drip rate for rain (mm/s) + real, intent(out) :: qthror !throughfall for rain (mm/s) + real, intent(out) :: qints !interception (loading) rate for snowfall (mm/s) + real, intent(out) :: qdrips !drip (unloading) rate for intercepted snow (mm/s) + real, intent(out) :: qthros !throughfall of snowfall (mm/s) + real, intent(out) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(out) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(out) :: pahb !precipitation advected heat - bare ground net (w/m2) + real, intent(out) :: qrain !rain at ground srf (mm/s) [+] + real, intent(out) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(out) :: snowhin !snow depth increasing rate (m/s) + real, intent(out) :: fwet !wetted or snowed fraction of the canopy (-) + real, intent(out) :: cmc !intercepted water (mm) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + real :: maxsno !canopy capacity for snow interception (mm) + real :: maxliq !canopy capacity for rain interception (mm) + real :: ft !temperature factor for unloading rate + real :: fv !wind factor for unloading rate + real :: pah_ac !precipitation advected heat - air to canopy (w/m2) + real :: pah_cg !precipitation advected heat - canopy to ground (w/m2) + real :: pah_ag !precipitation advected heat - air to ground (w/m2) + real :: icedrip !canice unloading +! -------------------------------------------------------------------- +! initialization + + qintr = 0. + qdripr = 0. + qthror = 0. + qintr = 0. + qints = 0. + qdrips = 0. + qthros = 0. + pah_ac = 0. + pah_cg = 0. + pah_ag = 0. + pahv = 0. + pahg = 0. + pahb = 0. + qrain = 0.0 + qsnow = 0.0 + snowhin = 0.0 + icedrip = 0.0 +! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt +! print*, "precip_heat snow*3600.0:",snow*3600.0 +! print*, "precip_heat rain*3600.0:",rain*3600.0 +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + maxliq = parameters%ch2op * (elai+ esai) + +! average interception and throughfall + + if((elai+ esai).gt.0.) then + qintr = fveg * rain * fp ! interception capability + qintr = min(qintr, (maxliq - canliq)/dt * (1.-exp(-rain*dt/maxliq)) ) + qintr = max(qintr, 0.) + qdripr = fveg * rain - qintr + qthror = (1.-fveg) * rain + canliq=max(0.,canliq+qintr*dt) + else + qintr = 0. + qdripr = 0. + qthror = rain + if(canliq > 0.) then ! for case of canopy getting buried + qdripr = qdripr + canliq/dt + canliq = 0.0 + end if + end if + +! heat transported by liquid water + + pah_ac = fveg * rain * (cwat/1000.0) * (sfctmp - tv) + pah_cg = qdripr * (cwat/1000.0) * (tv - tg) + pah_ag = qthror * (cwat/1000.0) * (sfctmp - tg) +! print*, "precip_heat pah_ac:",pah_ac +! print*, "precip_heat pah_cg:",pah_cg +! print*, "precip_heat pah_ag:",pah_ag + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai) + + if((elai+ esai).gt.0.) then + qints = fveg * snow * fp + qints = min(qints, (maxsno - canice)/dt * (1.-exp(-snow*dt/maxsno)) ) + qints = max(qints, 0.) + ft = max(0.0,(tv - 270.15) / 1.87e5) + fv = sqrt(uu*uu + vv*vv) / 1.56e5 + ! mb: changed below to reflect the rain assumption that all precip gets intercepted + icedrip = max(0.,canice) * (fv+ft) !mb: removed /dt + qdrips = (fveg * snow - qints) + icedrip + qthros = (1.0-fveg) * snow + canice= max(0.,canice + (qints - icedrip)*dt) + else + qints = 0. + qdrips = 0. + qthros = snow + if(canice > 0.) then ! for case of canopy getting buried + qdrips = qdrips + canice/dt + canice = 0.0 + end if + endif +! print*, "precip_heat canopy through:",3600.0*(fveg * snow - qints) +! print*, "precip_heat canopy drip:",3600.0*max(0.,canice) * (fv+ft) + +! wetted fraction of canopy + + if(canice.gt.0.) then + fwet = max(0.,canice) / max(maxsno,1.e-06) + else + fwet = max(0.,canliq) / max(maxliq,1.e-06) + endif + fwet = min(fwet, 1.) ** 0.667 + +! total canopy water + + cmc = canliq + canice + +! heat transported by snow/ice + + pah_ac = pah_ac + fveg * snow * (cice/1000.0) * (sfctmp - tv) + pah_cg = pah_cg + qdrips * (cice/1000.0) * (tv - tg) + pah_ag = pah_ag + qthros * (cice/1000.0) * (sfctmp - tg) + + pahv = pah_ac - pah_cg + pahg = pah_cg + pahb = pah_ag + + if (fveg > 0.0 .and. fveg < 1.0) then + pahg = pahg / fveg ! these will be multiplied by fraction later + pahb = pahb / (1.0-fveg) + elseif (fveg <= 0.0) then + pahb = pahg + pahb ! for case of canopy getting buried + pahg = 0.0 + pahv = 0.0 + elseif (fveg >= 1.0) then + pahb = 0.0 + end if + + pahv = max(pahv,-20.0) ! put some artificial limits here for stability + pahv = min(pahv,20.0) + pahg = max(pahg,-20.0) + pahg = min(pahg,20.0) + pahb = max(pahb,-20.0) + pahb = min(pahb,20.0) + +! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg +! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) +! print*, "precip_heat maxsno:",maxsno +! print*, "precip_heat pah_ac:",pah_ac +! print*, "precip_heat pah_cg:",pah_cg +! print*, "precip_heat pah_ag:",pah_ag + +! print*, "precip_heat pahv:",pahv +! print*, "precip_heat pahg:",pahg +! print*, "precip_heat pahb:",pahb +! print*, "precip_heat fveg:",fveg +! print*, "precip_heat qints*3600.0:",qints*3600.0 +! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 +! print*, "precip_heat qthros*3600.0:",qthros*3600.0 + +! rain or snow on the ground + + qrain = qdripr + qthror + qsnow = qdrips + qthros + snowhin = qsnow/bdfall + + if (ist == 2 .and. tg > tfrz) then + qsnow = 0. + snowhin = 0. + end if +! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 +! print*, "precip_heat qrain*3600.0:",qrain*3600.0 +! print*, "precip_heat snowhin:",snowhin +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq +! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt + + + end subroutine precip_heat + +!== begin error ==================================================================================== + + subroutine error (parameters,swdown ,fsa ,fsr ,fira ,fsh ,fcev , & + fgev ,fctr ,ssoil ,beg_wb ,canliq ,canice , & + sneqv ,wa ,smc ,dzsnso ,prcp ,ecan , & + etran ,edir ,runsrf ,runsub ,dt ,nsoil , & + nsnow ,ist ,errwat, iloc ,jloc ,fveg , & + sav ,sag ,fsrv ,fsrg ,zwt ,pah , & + pahv ,pahg ,pahb ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: ist !surface type 1->soil; 2->lake + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + real , intent(in) :: swdown !downward solar filtered by sun angle [w/m2] + real , intent(in) :: fsa !total absorbed solar radiation (w/m2) + real , intent(in) :: fsr !total reflected solar radiation (w/m2) + real , intent(in) :: fira !total net longwave rad (w/m2) [+ to atm] + real , intent(in) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(in) :: fcev !canopy evaporation heat (w/m2) [+ to atm] + real , intent(in) :: fgev !ground evaporation heat (w/m2) [+ to atm] + real , intent(in) :: fctr !transpiration heat flux (w/m2) [+ to atm] + real , intent(in) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , intent(in) :: fveg + real , intent(in) :: sav + real , intent(in) :: sag + real , intent(in) :: fsrv + real , intent(in) :: fsrg + real , intent(in) :: zwt + + real , intent(in) :: prcp !precipitation rate (kg m-2 s-1) + real , intent(in) :: ecan !evaporation of intercepted water (mm/s) + real , intent(in) :: etran !transpiration rate (mm/s) + real , intent(in) :: edir !soil surface evaporation rate[mm/s] + real , intent(in) :: runsrf !surface runoff [mm/s] + real , intent(in) :: runsub !baseflow (saturation excess) [mm/s] + real , intent(in) :: canliq !intercepted liquid water (mm) + real , intent(in) :: canice !intercepted ice mass (mm) + real , intent(in) :: sneqv !snow water eqv. [mm] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real , intent(in) :: wa !water storage in aquifer [mm] + real , intent(in) :: dt !time step [sec] + real , intent(in) :: beg_wb !water storage at begin of a timesetp [mm] + real , intent(out) :: errwat !error in water balance [mm/timestep] + real, intent(in) :: pah !precipitation advected heat - total (w/m2) + real, intent(in) :: pahv !precipitation advected heat - total (w/m2) + real, intent(in) :: pahg !precipitation advected heat - total (w/m2) + real, intent(in) :: pahb !precipitation advected heat - total (w/m2) + + integer :: iz !do-loop index + real :: end_wb !water storage at end of a timestep [mm] + !kwm real :: errwat !error in water balance [mm/timestep] + real :: erreng !error in surface energy balance [w/m2] + real :: errsw !error in shortwave radiation balance [w/m2] + real :: fsrvg + character(len=256) :: message +! -------------------------------------------------------------------------------------------------- +!jref:start + errsw = swdown - (fsa + fsr) +! errsw = swdown - (sav+sag + fsrv+fsrg) +! write(*,*) "errsw =",errsw + if (abs(errsw) > 0.01) then ! w/m2 + write(*,*) "vegetation!" + write(*,*) "swdown*fveg =",swdown*fveg + write(*,*) "fveg*(sav+sag) =",fveg*sav + sag + write(*,*) "fveg*(fsrv +fsrg)=",fveg*fsrv + fsrg + write(*,*) "ground!" + write(*,*) "(1-.fveg)*swdown =",(1.-fveg)*swdown + write(*,*) "(1.-fveg)*sag =",(1.-fveg)*sag + write(*,*) "(1.-fveg)*fsrg=",(1.-fveg)*fsrg + write(*,*) "fsrv =",fsrv + write(*,*) "fsrg =",fsrg + write(*,*) "fsr =",fsr + write(*,*) "sav =",sav + write(*,*) "sag =",sag + write(*,*) "fsa =",fsa +!jref:end + write(message,*) 'errsw =',errsw + call wrf_message(trim(message)) + call wrf_error_fatal("stop in noah-mp") + end if + + erreng = sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) +pah +! erreng = fveg*sav+sag-(fira+fsh+fcev+fgev+fctr+ssoil) + if(abs(erreng) > 0.01) then + write(message,*) 'erreng =',erreng,' at i,j: ',iloc,jloc + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "net solar: ",fsa + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "net longwave: ",fira + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "total sensible: ",fsh + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "canopy evap: ",fcev + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "ground evap: ",fgev + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "transpiration: ",fctr + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "total ground: ",ssoil + call wrf_message(trim(message)) + write(message,'(a17,4f10.4)') "precip advected: ",pah,pahv,pahg,pahb + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "precip: ",prcp + call wrf_message(trim(message)) + write(message,'(a17,f10.4)') "veg fraction: ",fveg + call wrf_message(trim(message)) + call wrf_error_fatal("energy budget problem in noahmp lsm") + end if + + if (ist == 1) then !soil + end_wb = canliq + canice + sneqv + wa + do iz = 1,nsoil + end_wb = end_wb + smc(iz) * dzsnso(iz) * 1000. + end do + errwat = end_wb-beg_wb-(prcp-ecan-etran-edir-runsrf-runsub)*dt + + else !kwm + errwat = 0.0 !kwm + endif + + end subroutine error + +!== begin energy =================================================================================== + + subroutine energy (parameters,ice ,vegtyp ,ist ,nsnow ,nsoil , & !in + isnow ,dt ,rhoair ,sfcprs ,qair , & !in + sfctmp ,thair ,lwdn ,uu ,vv ,zref , & !in + co2air ,o2air ,solad ,solai ,cosz ,igs , & !in + eair ,tbot ,zsnso ,zsoil , & !in + elai ,esai ,fwet ,foln , & !in + fveg ,pahv ,pahg ,pahb , & !in + qsnow ,dzsnso ,lat ,canliq ,canice ,iloc , jloc, & !in + z0wrf , & + imelt ,snicev ,snliqv ,epore ,t2m ,fsno , & !out + sav ,sag ,qmelt ,fsa ,fsr ,taux , & !out + tauy ,fira ,fsh ,fcev ,fgev ,fctr , & !out + trad ,psn ,apar ,ssoil ,btrani ,btran , & !out + ponding,ts ,latheav , latheag , frozen_canopy,frozen_ground, & !out + tv ,tg ,stc ,snowh ,eah ,tah , & !inout + sneqvo ,sneqv ,sh2o ,smc ,snice ,snliq , & !inout + albold ,cm ,ch ,dx ,dz8w ,q2 , & !inout + tauss , & !inout +!jref:start + qc ,qsfc ,psfc , & !in + t2mv ,t2mb ,fsrv , & + fsrg ,rssun ,rssha ,bgap ,wgap,tgv,tgb,& + q1 ,q2v ,q2b ,q2e ,chv ,chb, emissi,pah ,& + shg,shc,shb,evg,evb,ghv,ghb,irg,irc,irb,tr,evc,chleaf,chuc,chv2,chb2 ) !out +!jref:end + +! -------------------------------------------------------------------------------------------------- +! we use different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. we use 'tile' approach to compute turbulent fluxes, while we use modified two- +! stream to compute radiation transfer. tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. the +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree +! crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / o o o o o o o o / / +! / | | | | | | | | / / +! / o o o o o o o o / / +! / | | |tile1| | | | / tile2 / +! / o o o o o o o o / bare / +! / | | | vegetated | | / / +! / o o o o o o o o / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (yang and friedl, 2003, jgr; niu ang yang, 2004, jgr) +! -------------------------------------- two-stream treats leaves as +! / o o o o o o o o / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / o o o o o o o o / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / o o o o o o o o / the left figure). we assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / o o o o o o o o / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. the 'tile' +! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc + integer , intent(in) :: jloc + integer , intent(in) :: ice !ice (ice = 1) + integer , intent(in) :: vegtyp !vegetation physiology type + integer , intent(in) :: ist !surface type: 1->soil; 2->lake + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: isnow !actual no. of snow layers + real , intent(in) :: dt !time step [sec] + real , intent(in) :: qsnow !snowfall on the ground (mm/s) + real , intent(in) :: rhoair !density air (kg/m3) + real , intent(in) :: eair !vapor pressure air (pa) + real , intent(in) :: sfcprs !pressure (pa) + real , intent(in) :: qair !specific humidity (kg/kg) + real , intent(in) :: sfctmp !air temperature (k) + real , intent(in) :: thair !potential temperature (k) + real , intent(in) :: lwdn !downward longwave radiation (w/m2) + real , intent(in) :: uu !wind speed in e-w dir (m/s) + real , intent(in) :: vv !wind speed in n-s dir (m/s) + real , dimension( 1: 2), intent(in) :: solad !incoming direct solar rad. (w/m2) + real , dimension( 1: 2), intent(in) :: solai !incoming diffuse solar rad. (w/m2) + real , intent(in) :: cosz !cosine solar zenith angle (0-1) + real , intent(in) :: elai !lai adjusted for burying by snow + real , intent(in) :: esai !lai adjusted for burying by snow + real , intent(in) :: fwet !fraction of canopy that is wet [-] + real , intent(in) :: fveg !greeness vegetation fraction (-) + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: canliq !canopy-intercepted liquid water (mm) + real , intent(in) :: canice !canopy-intercepted ice mass (mm) + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: co2air !atmospheric co2 concentration (pa) + real , intent(in) :: o2air !atmospheric o2 concentration (pa) + real , intent(in) :: igs !growing season index (0=off, 1=on) + + real , intent(in) :: zref !reference height (m) + real , intent(in) :: tbot !bottom condition for soil temp. (k) + real , dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bottom depth from snow surf [m] + real , dimension( 1:nsoil), intent(in) :: zsoil !layer-bottom depth from soil surf [m] + real , dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !depth of snow & soil layer-bottom [m] + real, intent(in) :: pahv !precipitation advected heat - vegetation net (w/m2) + real, intent(in) :: pahg !precipitation advected heat - under canopy net (w/m2) + real, intent(in) :: pahb !precipitation advected heat - bare ground net (w/m2) + +!jref:start; in + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dx !horisontal resolution + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(in) :: q2 !mixing ratio (kg/kg) +!jref:end + +! outputs + real , intent(out) :: z0wrf !combined z0 sent to coupled model + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index [1-melt; 2-freeze] + real , dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume ice [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume liq. water [m3/m3] + real , dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real , intent(out) :: fsno !snow cover fraction (-) + real , intent(out) :: qmelt !snowmelt [mm/s] + real , intent(out) :: ponding!pounding at ground [mm] + real , intent(out) :: sav !solar rad. absorbed by veg. (w/m2) + real , intent(out) :: sag !solar rad. absorbed by ground (w/m2) + real , intent(out) :: fsa !tot. absorbed solar radiation (w/m2) + real , intent(out) :: fsr !tot. reflected solar radiation (w/m2) + real , intent(out) :: taux !wind stress: e-w (n/m2) + real , intent(out) :: tauy !wind stress: n-s (n/m2) + real , intent(out) :: fira !total net lw. rad (w/m2) [+ to atm] + real , intent(out) :: fsh !total sensible heat (w/m2) [+ to atm] + real , intent(out) :: fcev !canopy evaporation (w/m2) [+ to atm] + real , intent(out) :: fgev !ground evaporation (w/m2) [+ to atm] + real , intent(out) :: fctr !transpiration (w/m2) [+ to atm] + real , intent(out) :: trad !radiative temperature (k) + real , intent(out) :: t2m !2 m height air temperature (k) + real , intent(out) :: psn !total photosyn. (umolco2/m2/s) [+] + real , intent(out) :: apar !total photosyn. active energy (w/m2) + real , intent(out) :: ssoil !ground heat flux (w/m2) [+ to soil] + real , dimension( 1:nsoil), intent(out) :: btrani !soil water transpiration factor (0-1) + real , intent(out) :: btran !soil water transpiration factor (0-1) +! real , intent(out) :: lathea !latent heat vap./sublimation (j/kg) + real , intent(out) :: latheav !latent heat vap./sublimation (j/kg) + real , intent(out) :: latheag !latent heat vap./sublimation (j/kg) + logical , intent(out) :: frozen_ground ! used to define latent heat pathway + logical , intent(out) :: frozen_canopy ! used to define latent heat pathway + +!jref:start + real , intent(out) :: fsrv !veg. reflected solar radiation (w/m2) + real , intent(out) :: fsrg !ground reflected solar radiation (w/m2) + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) +!jref:end - out for debug + +!jref:start; output + real , intent(out) :: t2mv !2-m air temperature over vegetated part [k] + real , intent(out) :: t2mb !2-m air temperature over bare ground part [k] + real , intent(out) :: bgap + real , intent(out) :: wgap +!jref:end + +! input & output + real , intent(inout) :: ts !surface temperature (k) + real , intent(inout) :: tv !vegetation temperature (k) + real , intent(inout) :: tg !ground temperature (k) + real , dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil temperature [k] + real , intent(inout) :: snowh !snow height [m] + real , intent(inout) :: sneqv !snow mass (mm) + real , intent(inout) :: sneqvo !snow mass at last time step (mm) + real , dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil moisture [m3/m3] + real , dimension( 1:nsoil), intent(inout) :: smc !soil moisture (ice + liq.) [m3/m3] + real , dimension(-nsnow+1: 0), intent(inout) :: snice !snow ice mass (kg/m2) + real , dimension(-nsnow+1: 0), intent(inout) :: snliq !snow liq mass (kg/m2) + real , intent(inout) :: eah !canopy air vapor pressure (pa) + real , intent(inout) :: tah !canopy air temperature (k) + real , intent(inout) :: albold !snow albedo at last time step(class type) + real , intent(inout) :: tauss !non-dimensional snow age + real , intent(inout) :: cm !momentum drag coefficient + real , intent(inout) :: ch !sensible heat exchange coefficient + real , intent(inout) :: q1 +! real :: q2e + real, intent(out) :: emissi + real, intent(out) :: pah !precipitation advected heat - total (w/m2) + +! local + integer :: iz !do-loop index + logical :: veg !true if vegetated surface + real :: ur !wind speed at height zlvl (m/s) + real :: zlvl !reference height (m) + real :: fsun !sunlit fraction of canopy [-] + real :: rb !leaf boundary layer resistance (s/m) + real :: rsurf !ground surface resistance (s/m) + real :: l_rsurf!dry-layer thickness for computing rsurf (sakaguchi and zeng, 2009) + real :: d_rsurf!reduced vapor diffusivity in soil for computing rsurf (sz09) + real :: bevap !soil water evaporation factor (0- 1) + real :: mol !monin-obukhov length (m) + real :: vai !sum of lai + stem area index [m2/m2] + real :: cwp !canopy wind extinction parameter + real :: zpd !zero plane displacement (m) + real :: z0m !z0 momentum (m) + real :: zpdg !zero plane displacement (m) + real :: z0mg !z0 momentum, ground (m) + real :: emv !vegetation emissivity + real :: emg !ground emissivity + real :: fire !emitted ir (w/m2) + + real :: laisun !sunlit leaf area index (m2/m2) + real :: laisha !shaded leaf area index (m2/m2) + real :: psnsun !sunlit photosynthesis (umolco2/m2/s) + real :: psnsha !shaded photosynthesis (umolco2/m2/s) +!jref:start - for debug +! real :: rssun !sunlit stomatal resistance (s/m) +! real :: rssha !shaded stomatal resistance (s/m) +!jref:end - for debug + real :: parsun !par absorbed per sunlit lai (w/m2) + real :: parsha !par absorbed per shaded lai (w/m2) + + real, dimension(-nsnow+1:nsoil) :: fact !temporary used in phase change + real, dimension(-nsnow+1:nsoil) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil) :: hcpct !heat capacity [j/m3/k] + real :: bdsno !bulk density of snow (kg/m3) + real :: fmelt !melting factor for snow cover frac + real :: gx !temporary variable + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) +! real :: gamma !psychrometric constant (pa/k) + real :: gammav !psychrometric constant (pa/k) + real :: gammag !psychrometric constant (pa/k) + real :: psi !surface layer soil matrix potential (m) + real :: rhsur !raltive humidity in surface soil/snow air space (-) + +! temperature and fluxes over vegetated fraction + + real :: tauxv !wind stress: e-w dir [n/m2] + real :: tauyv !wind stress: n-s dir [n/m2] + real,intent(out) :: irc !canopy net lw rad. [w/m2] [+ to atm] + real,intent(out) :: irg !ground net lw rad. [w/m2] [+ to atm] + real,intent(out) :: shc !canopy sen. heat [w/m2] [+ to atm] + real,intent(out) :: shg !ground sen. heat [w/m2] [+ to atm] +!jref:start + real,intent(out) :: q2v + real,intent(out) :: q2b + real,intent(out) :: q2e +!jref:end + real,intent(out) :: evc !canopy evap. heat [w/m2] [+ to atm] + real,intent(out) :: evg !ground evap. heat [w/m2] [+ to atm] + real,intent(out) :: tr !transpiration heat [w/m2] [+ to atm] + real,intent(out) :: ghv !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: tgv !ground surface temp. [k] + real :: cmv !momentum drag coefficient + real,intent(out) :: chv !sensible heat exchange coefficient + +! temperature and fluxes over bare soil fraction + + real :: tauxb !wind stress: e-w dir [n/m2] + real :: tauyb !wind stress: n-s dir [n/m2] + real,intent(out) :: irb !net longwave rad. [w/m2] [+ to atm] + real,intent(out) :: shb !sensible heat [w/m2] [+ to atm] + real,intent(out) :: evb !evaporation heat [w/m2] [+ to atm] + real,intent(out) :: ghb !ground heat flux [w/m2] [+ to soil] + real,intent(out) :: tgb !ground surface temp. [k] + real :: cmb !momentum drag coefficient + real,intent(out) :: chb !sensible heat exchange coefficient + real,intent(out) :: chleaf !leaf exchange coefficient + real,intent(out) :: chuc !under canopy exchange coefficient +!jref:start + real,intent(out) :: chv2 !sensible heat conductance, canopy air to zlvl air (m/s) + real,intent(out) :: chb2 !sensible heat conductance, canopy air to zlvl air (m/s) + real :: noahmpres + +!jref:end + + real, parameter :: mpe = 1.e-6 + real, parameter :: psiwlt = -150. !metric potential for wilting point (m) + real, parameter :: z0 = 0.01 ! bare-soil roughness length (m) (i.e., under the canopy) + +! --------------------------------------------------------------------------------------------------- +! initialize fluxes from veg. fraction + + tauxv = 0. + tauyv = 0. + irc = 0. + shc = 0. + irg = 0. + shg = 0. + evg = 0. + evc = 0. + tr = 0. + ghv = 0. + psnsun = 0. + psnsha = 0. + t2mv = 0. + q2v = 0. + chv = 0. + chleaf = 0. + chuc = 0. + chv2 = 0. + +! wind speed at reference height: ur >= 1 + + ur = max( sqrt(uu**2.+vv**2.), 1. ) + +! vegetated or non-vegetated + + vai = elai + esai + veg = .false. + if(vai > 0.) veg = .true. + +! ground snow cover fraction [niu and yang, 2007, jgr] + + fsno = 0. + if(snowh.gt.0.) then + bdsno = sneqv / snowh + fmelt = (bdsno/100.)**parameters%mfsno + fsno = tanh( snowh /(2.5* z0 * fmelt)) + endif + +! ground roughness length + + if(ist == 2) then + if(tg .le. tfrz) then + z0mg = 0.01 * (1.0-fsno) + fsno * parameters%z0sno + else + z0mg = 0.01 + end if + else + z0mg = z0 * (1.0-fsno) + fsno * parameters%z0sno + end if + +! roughness length and displacement height + + zpdg = snowh + if(veg) then + z0m = parameters%z0mvt + zpd = 0.65 * parameters%hvt + if(snowh.gt.zpd) zpd = snowh + else + z0m = z0mg + zpd = zpdg + end if + + zlvl = max(zpd,parameters%hvt) + zref + if(zpdg >= zlvl) zlvl = zpdg + zref +! ur = ur*log(zlvl/z0m)/log(10./z0m) !input ur is at 10m + +! canopy wind absorption coeffcient + + cwp = parameters%cwpvt + +! thermal properties of soil, snow, lake, and frozen soil + + call thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + smc ,sh2o ,tg ,stc ,ur , & !in + lat ,z0m ,zlvl ,vegtyp , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out + +! solar radiation: absorbed & reflected by the ground and canopy + + call radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in + sneqvo ,sneqv ,dt ,cosz ,snowh , & !in + tg ,tv ,fsno ,qsnow ,fwet , & !in + elai ,esai ,smc ,solad ,solai , & !in + fveg ,iloc ,jloc , & !in + albold ,tauss , & !inout + fsun ,laisun ,laisha ,parsun ,parsha , & !out + sav ,sag ,fsr ,fsa ,fsrv , & + fsrg ,bgap ,wgap ) !out + +! vegetation and ground emissivity + + emv = 1. - exp(-(elai+esai)/1.0) + if (ice == 1) then + emg = 0.98*(1.-fsno) + 1.0*fsno + else + emg = parameters%eg(ist)*(1.-fsno) + 1.0*fsno + end if + +! soil moisture factor controlling stomatal resistance + + btran = 0. + + if(ist ==1 ) then + do iz = 1, parameters%nroot + if(opt_btr == 1) then ! noah + gx = (sh2o(iz)-parameters%smcwlt) / (parameters%smcref-parameters%smcwlt) + end if + if(opt_btr == 2) then ! clm + psi = max(psiwlt,-parameters%psisat*(max(0.01,sh2o(iz))/parameters%smcmax)**(-parameters%bexp) ) + gx = (1.-psi/psiwlt)/(1.+parameters%psisat/psiwlt) + end if + if(opt_btr == 3) then ! ssib + psi = max(psiwlt,-parameters%psisat*(max(0.01,sh2o(iz))/parameters%smcmax)**(-parameters%bexp) ) + gx = 1.-exp(-5.8*(log(psiwlt/psi))) + end if + + gx = min(1.,max(0.,gx)) + btrani(iz) = max(mpe,dzsnso(iz) / (-zsoil(parameters%nroot)) * gx) + btran = btran + btrani(iz) + end do + btran = max(mpe,btran) + + btrani(1:parameters%nroot) = btrani(1:parameters%nroot)/btran + end if + +! soil surface resistance for ground evap. + + bevap = max(0.0,sh2o(1)/parameters%smcmax) + if(ist == 2) then + rsurf = 1. ! avoid being divided by 0 + rhsur = 1.0 + else + + ! rsurf based on sakaguchi and zeng, 2009 + ! taking the "residual water content" to be the wilting point, + ! and correcting the exponent on the d term (typo in sz09 ?) + l_rsurf = (-zsoil(1)) * ( exp ( (1.0 - min(1.0,sh2o(1)/parameters%smcmax)) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 ) + d_rsurf = 2.2e-5 * parameters%smcmax * parameters%smcmax * ( 1.0 - parameters%smcwlt / parameters%smcmax ) ** (2.0+3.0/parameters%bexp) + rsurf = l_rsurf / d_rsurf + + ! older rsurf computations: + ! rsurf = fsno * 1. + (1.-fsno)* exp(8.25-4.225*bevap) !sellers (1992) + ! rsurf = fsno * 1. + (1.-fsno)* exp(8.25-6.0 *bevap) !adjusted to decrease rsurf for wet soil + + if(sh2o(1) < 0.01 .and. snowh == 0.) rsurf = 1.e6 + psi = -parameters%psisat*(max(0.01,sh2o(1))/parameters%smcmax)**(-parameters%bexp) + rhsur = fsno + (1.-fsno) * exp(psi*grav/(rw*tg)) + end if + +! urban - jref + if (parameters%urban_flag .and. snowh == 0. ) then + rsurf = 1.e6 + endif + +! set psychrometric constant + + if (tv .gt. tfrz) then ! barlage: add distinction between ground and + latheav = hvap ! vegetation in v3.6 + frozen_canopy = .false. + else + latheav = hsub + frozen_canopy = .true. + end if + gammav = cpair*sfcprs/(0.622*latheav) + + if (tg .gt. tfrz) then + latheag = hvap + frozen_ground = .false. + else + latheag = hsub + frozen_ground = .true. + end if + gammag = cpair*sfcprs/(0.622*latheag) + +! if (sfctmp .gt. tfrz) then +! lathea = hvap +! else +! lathea = hsub +! end if +! gamma = cpair*sfcprs/(0.622*lathea) + +! surface temperatures of the ground and canopy and energy fluxes + + if (veg .and. fveg > 0) then + tgv = tg + cmv = cm + chv = ch +! YRQ +! write(*,*) 'cm,ch,tv,tgv, YRQ', cm,ch,tv,tgv + call vege_flux (parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in + dt ,sav ,sag ,lwdn ,ur , & !in + uu ,vv ,sfctmp ,thair ,qair , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag , & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg , & !in + z0mg ,emv ,emg ,canliq ,fsno, & !in + canice ,stc ,df ,rssun ,rssha , & !in + rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in + foln ,co2air ,o2air ,btran ,sfcprs , & !in + rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in + eah ,tah ,tv ,tgv ,cmv , & !inout + chv ,dx ,dz8w , & !inout + tauxv ,tauyv ,irg ,irc ,shg , & !out + shc ,evg ,evc ,tr ,ghv , & !out + t2mv ,psnsun ,psnsha , & !out +!jref:start + qc ,qsfc ,psfc , & !in + q2v ,chv2, chleaf, chuc) !inout +!jref:end + end if + + tgb = tg + cmb = cm + chb = ch + call bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in + lwdn ,ur ,uu ,vv ,sfctmp , & !in + thair ,qair ,eair ,rhoair ,snowh , & !in + dzsnso ,zlvl ,zpdg ,z0mg ,fsno, & !in + emg ,stc ,df ,rsurf ,latheag , & !in + gammag ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in + tgb ,cmb ,chb , & !inout + tauxb ,tauyb ,irb ,shb ,evb , & !out + ghb ,t2mb ,dx ,dz8w ,vegtyp , & !out +!jref:start + qc ,qsfc ,psfc , & !in + sfcprs ,q2b, chb2) !in +!jref:end + +!energy balance at vege canopy: sav =(irc+shc+evc+tr) *fveg at fveg +!energy balance at vege ground: sag* fveg =(irg+shg+evg+ghv) *fveg at fveg +!energy balance at bare ground: sag*(1.-fveg)=(irb+shb+evb+ghb)*(1.-fveg) at 1-fveg + + if (veg .and. fveg > 0) then + taux = fveg * tauxv + (1.0 - fveg) * tauxb + tauy = fveg * tauyv + (1.0 - fveg) * tauyb + fira = fveg * irg + (1.0 - fveg) * irb + irc + fsh = fveg * shg + (1.0 - fveg) * shb + shc + fgev = fveg * evg + (1.0 - fveg) * evb + ssoil = fveg * ghv + (1.0 - fveg) * ghb + fcev = evc + fctr = tr + pah = fveg * pahg + (1.0 - fveg) * pahb + pahv + tg = fveg * tgv + (1.0 - fveg) * tgb + t2m = fveg * t2mv + (1.0 - fveg) * t2mb + ts = fveg * tv + (1.0 - fveg) * tgb + cm = fveg * cmv + (1.0 - fveg) * cmb ! better way to average? + ch = fveg * chv + (1.0 - fveg) * chb + q1 = fveg * (eah*0.622/(sfcprs - 0.378*eah)) + (1.0 - fveg)*qsfc + q2e = fveg * q2v + (1.0 - fveg) * q2b + z0wrf = z0m + else + taux = tauxb + tauy = tauyb + fira = irb + fsh = shb + fgev = evb + ssoil = ghb + tg = tgb + t2m = t2mb + fcev = 0. + fctr = 0. + pah = pahb + ts = tg + cm = cmb + ch = chb + q1 = qsfc + q2e = q2b + rssun = 0.0 + rssha = 0.0 + tgv = tgb + chv = chb + z0wrf = z0mg + end if + + fire = lwdn + fira + + if(fire <=0.) then + write(6,*) 'emitted longwave <0; skin t may be wrong due to inconsistent' + write(6,*) 'input of shdfac with lai' + write(6,*) iloc, jloc, 'shdfac=',fveg,'vai=',vai,'tv=',tv,'tg=',tg + write(6,*) 'lwdn=',lwdn,'fira=',fira,'snowh=',snowh + call wrf_error_fatal("stop in noah-mp") + end if + + ! compute a net emissivity + emissi = fveg * ( emg*(1-emv) + emv + emv*(1-emv)*(1-emg) ) + & + (1-fveg) * emg + + ! when we're computing a trad, subtract from the emitted ir the + ! reflected portion of the incoming lwdn, so we're just + ! considering the ir originating in the canopy/ground system. + + trad = ( ( fire - (1-emissi)*lwdn ) / (emissi*sb) ) ** 0.25 + + ! old trad calculation not taking into account emissivity: + ! trad = (fire/sb)**0.25 + + apar = parsun*laisun + parsha*laisha + psn = psnsun*laisun + psnsha*laisha + +! 3l snow & 4l soil temperatures + + call tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in + tbot ,zsnso ,ssoil ,df ,hcpct , & !in + sag ,dt ,snowh ,dzsnso , & !in + tg ,iloc ,jloc , & !in + stc ) !inout + +! adjusting snow surface temperature + if(opt_stc == 2) then + if (snowh > 0.05 .and. tg > tfrz) then + tgv = tfrz + tgb = tfrz + if (veg .and. fveg > 0) then + tg = fveg * tgv + (1.0 - fveg) * tgb + ts = fveg * tv + (1.0 - fveg) * tgb + else + tg = tgb + ts = tgb + end if + end if + end if + +! energy released or consumed by snow & frozen soil + + call phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso ,hcpct ,ist ,iloc ,jloc , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out + + + end subroutine energy + +!== begin thermoprop =============================================================================== + + subroutine thermoprop (parameters,nsoil ,nsnow ,isnow ,ist ,dzsnso , & !in + dt ,snowh ,snice ,snliq , & !in + smc ,sh2o ,tg ,stc ,ur , & !in + lat ,z0m ,zlvl ,vegtyp , & !in + df ,hcpct ,snicev ,snliqv ,epore , & !out + fact ) !out +! ------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: nsoil !number of soil layers + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: isnow !actual no. of snow layers + integer , intent(in) :: ist !surface type + real , intent(in) :: dt !time step [s] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers [m] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real, dimension( 1:nsoil), intent(in) :: sh2o !liquid soil moisture [m3/m3] + real , intent(in) :: snowh !snow height [m] + real, intent(in) :: tg !surface temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil/lake temp. (k) + real, intent(in) :: ur !wind speed at zlvl (m/s) + real, intent(in) :: lat !latitude (radians) + real, intent(in) :: z0m !roughness length (m) + real, intent(in) :: zlvl !reference height (m) + integer , intent(in) :: vegtyp !vegtyp type + +! outputs + real, dimension(-nsnow+1:nsoil), intent(out) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(out) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + real, dimension(-nsnow+1:nsoil), intent(out) :: fact !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0) :: tksno !snow thermal conductivity (j/m3/k) + real, dimension( 1:nsoil) :: sice !soil ice content +! -------------------------------------------------------------------------------------------------- + +! compute snow thermal conductivity and heat capacity + + call csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out + + do iz = isnow+1, 0 + df (iz) = tksno(iz) + hcpct(iz) = cvsno(iz) + end do + +! compute soil thermal properties + + do iz = 1, nsoil + sice(iz) = smc(iz) - sh2o(iz) + hcpct(iz) = sh2o(iz)*cwat + (1.0-parameters%smcmax)*parameters%csoil & + + (parameters%smcmax-smc(iz))*cpair + sice(iz)*cice + call tdfcnd (parameters,df(iz), smc(iz), sh2o(iz)) + end do + + if ( parameters%urban_flag ) then + do iz = 1,nsoil + df(iz) = 3.24 + end do + endif + +! heat flux reduction effect from the overlying green canopy, adapted from +! section 2.1.2 of peters-lidard et al. (1997, jgr, vol 102(d4)). +! not in use because of the separation of the canopy layer from the ground. +! but this may represent the effects of leaf litter (niu comments) +! df1 = df1 * exp (sbeta * shdfac) + +! compute lake thermal properties +! (no consideration of turbulent mixing for this version) + + if(ist == 2) then + do iz = 1, nsoil + if(stc(iz) > tfrz) then + hcpct(iz) = cwat + df(iz) = tkwat !+ keddy * cwat + else + hcpct(iz) = cice + df(iz) = tkice + end if + end do + end if + +! combine a temporary variable used for melting/freezing of snow and frozen soil + + do iz = isnow+1,nsoil + fact(iz) = dt/(hcpct(iz)*dzsnso(iz)) + end do + +! snow/soil interface + + if(isnow == 0) then + df(1) = (df(1)*dzsnso(1)+0.35*snowh) / (snowh +dzsnso(1)) + else + df(1) = (df(1)*dzsnso(1)+df(0)*dzsnso(0)) / (dzsnso(0)+dzsnso(1)) + end if + + + end subroutine thermoprop + +!== begin csnow ==================================================================================== + + subroutine csnow (parameters,isnow ,nsnow ,nsoil ,snice ,snliq ,dzsnso , & !in + tksno ,cvsno ,snicev ,snliqv ,epore ) !out +! -------------------------------------------------------------------------------------------------- +! snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + implicit none +!--------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: isnow !number of snow layers (-) + integer , intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: nsoil !number of soil layers + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow ice mass (kg/m2) + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow liq mass (kg/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + +! outputs + + real, dimension(-nsnow+1: 0), intent(out) :: cvsno !volumetric specific heat (j/m3/k) + real, dimension(-nsnow+1: 0), intent(out) :: tksno !thermal conductivity (w/m/k) + real, dimension(-nsnow+1: 0), intent(out) :: snicev !partial volume of ice [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: snliqv !partial volume of liquid water [m3/m3] + real, dimension(-nsnow+1: 0), intent(out) :: epore !effective porosity [m3/m3] + +! locals + + integer :: iz + real, dimension(-nsnow+1: 0) :: bdsnoi !bulk density of snow(kg/m3) + +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow + + do iz = isnow+1, 0 + snicev(iz) = min(1., snice(iz)/(dzsnso(iz)*denice) ) + epore(iz) = 1. - snicev(iz) + snliqv(iz) = min(epore(iz),snliq(iz)/(dzsnso(iz)*denh2o)) + enddo + + do iz = isnow+1, 0 + bdsnoi(iz) = (snice(iz)+snliq(iz))/dzsnso(iz) + cvsno(iz) = cice*snicev(iz)+cwat*snliqv(iz) +! cvsno(iz) = 0.525e06 ! constant + enddo + +! thermal conductivity of snow + + do iz = isnow+1, 0 + tksno(iz) = 3.2217e-6*bdsnoi(iz)**2. ! stieglitz(yen,1965) +! tksno(iz) = 2e-2+2.5e-6*bdsnoi(iz)*bdsnoi(iz) ! anderson, 1976 +! tksno(iz) = 0.35 ! constant +! tksno(iz) = 2.576e-6*bdsnoi(iz)**2. + 0.074 ! verseghy (1991) +! tksno(iz) = 2.22*(bdsnoi(iz)/1000.)**1.88 ! douvill(yen, 1981) + enddo + + end subroutine csnow + +!== begin tdfcnd =================================================================================== + + subroutine tdfcnd (parameters, df, smc, sh2o) +! -------------------------------------------------------------------------------------------------- +! calculate thermal diffusivity and conductivity of the soil. +! peters-lidard approach (peters-lidard et al., 1998) +! -------------------------------------------------------------------------------------------------- +! code history: +! june 2001 changes: frozen soil condition. +! -------------------------------------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: smc ! total soil water + real, intent(in) :: sh2o ! liq. soil water + real, intent(out) :: df ! thermal diffusivity + +! local variables + real :: ake + real :: gammd + real :: thkdry + real :: thko ! thermal conductivity for other soil components + real :: thkqtz ! thermal conductivity for quartz + real :: thksat ! + real :: thks ! thermal conductivity for the solids + real :: thkw ! water thermal conductivity + real :: satratio + real :: xu + real :: xunfroz +! -------------------------------------------------------------------------------------------------- +! we now get quartz as an input argument (set in routine redprm): +! data quartz /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! -------------------------------------------------------------------------------------------------- +! if the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! -------------------------------------------------------------------------------------------------- +! quartz ....quartz content (soil type dependent) +! -------------------------------------------------------------------------------------------------- +! use as in peters-lidard, 1998 (modif. from johansen, 1975). + +! pablo grunmann, 08/17/98 +! refs.: +! farouki, o.t.,1986: thermal properties of soils. series on rock +! and soil mechanics, vol. 11, trans tech, 136 pp. +! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis, +! university of trondheim, +! peters-lidard, c. d., et al., 1998: the effect of soil thermal +! conductivity parameterization on surface energy fluxes +! and temperatures. journal of the atmospheric sciences, +! vol. 55, pp. 1209-1224. +! -------------------------------------------------------------------------------------------------- +! needs parameters +! porosity(soil type): +! poros = smcmax +! saturation ratio: +! parameters w/(m.k) + satratio = smc / parameters%smcmax + thkw = 0.57 +! if (quartz .le. 0.2) thko = 3.0 + thko = 2.0 +! solids' conductivity +! quartz' conductivity + thkqtz = 7.7 + +! unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen)) + thks = (thkqtz ** parameters%quartz)* (thko ** (1. - parameters%quartz)) + +! unfrozen volume for saturation (porosity*xunfroz) + xunfroz = (sh2o + 1.e-9) / (smc + 1.e-9) +! saturated thermal conductivity + xu = xunfroz * parameters%smcmax + +! dry density in kg/m3 + thksat = thks ** (1. - parameters%smcmax)* tkice ** (parameters%smcmax - xu)* thkw ** & + (xu) + +! dry thermal conductivity in w.m-1.k-1 + gammd = (1. - parameters%smcmax)*2700. + + thkdry = (0.135* gammd+ 64.7)/ (2700. - 0.947* gammd) +! frozen + if ( (sh2o + 0.0005) < smc ) then + ake = satratio +! unfrozen +! range of validity for the kersten number (ake) + else + +! kersten number (using "fine" formula, valid for soils containing at +! least 5% of particles with diameter less than 2.e-6 meters.) +! (for "coarse" formula, see peters-lidard et al., 1998). + + if ( satratio > 0.1 ) then + + ake = log10 (satratio) + 1.0 + +! use k = kdry + else + + ake = 0.0 + end if +! thermal conductivity + + end if + + df = ake * (thksat - thkdry) + thkdry + + + end subroutine tdfcnd + +!== begin radiation ================================================================================ + + subroutine radiation (parameters,vegtyp ,ist ,ice ,nsoil , & !in + sneqvo ,sneqv ,dt ,cosz ,snowh , & !in + tg ,tv ,fsno ,qsnow ,fwet , & !in + elai ,esai ,smc ,solad ,solai , & !in + fveg ,iloc ,jloc , & !in + albold ,tauss , & !inout + fsun ,laisun ,laisha ,parsun ,parsha , & !out + sav ,sag ,fsr ,fsa ,fsrv , & + fsrg ,bgap ,wgap) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: ist !surface type + integer, intent(in) :: ice !ice (ice = 1) + integer, intent(in) :: nsoil !number of soil layers + + real, intent(in) :: dt !time step [s] + real, intent(in) :: qsnow !snowfall (mm/s) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: snowh !snow height (mm) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: elai !lai, one-sided, adjusted for burying by snow + real, intent(in) :: esai !sai, one-sided, adjusted for burying by snow + real, intent(in) :: fwet !fraction of canopy that is wet + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water [m3/m3] + real, dimension(1:2) , intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2) , intent(in) :: solai !incoming diffuse solar radiation (w/m2) + real, intent(in) :: fsno !snow cover fraction (-) + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age. + +! output + real, intent(out) :: fsun !sunlit fraction of canopy (-) + real, intent(out) :: laisun !sunlit leaf area (-) + real, intent(out) :: laisha !shaded leaf area (-) + real, intent(out) :: parsun !average absorbed par for sunlit leaves (w/m2) + real, intent(out) :: parsha !average absorbed par for shaded leaves (w/m2) + real, intent(out) :: sav !solar radiation absorbed by vegetation (w/m2) + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + +!jref:start + real, intent(out) :: fsrv !veg. reflected solar radiation (w/m2) + real, intent(out) :: fsrg !ground reflected solar radiation (w/m2) + real, intent(out) :: bgap + real, intent(out) :: wgap +!jref:end + +! local + real :: fage !snow age function (0 - new snow) + real, dimension(1:2) :: albgrd !ground albedo (direct) + real, dimension(1:2) :: albgri !ground albedo (diffuse) + real, dimension(1:2) :: albd !surface albedo (direct) + real, dimension(1:2) :: albi !surface albedo (diffuse) + real, dimension(1:2) :: fabd !flux abs by veg (per unit direct flux) + real, dimension(1:2) :: fabi !flux abs by veg (per unit diffuse flux) + real, dimension(1:2) :: ftdd !down direct flux below veg (per unit dir flux) + real, dimension(1:2) :: ftid !down diffuse flux below veg (per unit dir flux) + real, dimension(1:2) :: ftii !down diffuse flux below veg (per unit dif flux) +!jref:start + real, dimension(1:2) :: frevi + real, dimension(1:2) :: frevd + real, dimension(1:2) :: fregi + real, dimension(1:2) :: fregd +!jref:end + + real :: fsha !shaded fraction of canopy + real :: vai !total lai + stem area index, one sided + + real,parameter :: mpe = 1.e-6 + logical veg !true: vegetated for surface temperature calculation + +! -------------------------------------------------------------------------------------------------- + +! surface abeldo + + call albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in + dt ,cosz ,fage ,elai ,esai , & !in + tg ,tv ,snowh ,fsno ,fwet , & !in + smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in + iloc ,jloc , & !in + albold ,tauss , & !inout + albgrd ,albgri ,albd ,albi ,fabd , & !out + fabi ,ftdd ,ftid ,ftii ,fsun , & !) !out + frevi ,frevd ,fregd ,fregi ,bgap , & !inout + wgap) + +! surface radiation + + fsha = 1.-fsun + laisun = elai*fsun + laisha = elai*fsha + vai = elai+ esai + if (vai .gt. 0.) then + veg = .true. + else + veg = .false. + end if + + call surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in + laisun ,laisha ,solad ,solai ,fabd , & !in + fabi ,ftdd ,ftid ,ftii ,albgrd , & !in + albgri ,albd ,albi ,iloc ,jloc , & !in + parsun ,parsha ,sav ,sag ,fsa , & !out + fsr , & !out + frevi ,frevd ,fregd ,fregi ,fsrv , & !inout + fsrg) + + end subroutine radiation + +!== begin albedo =================================================================================== + + subroutine albedo (parameters,vegtyp ,ist ,ice ,nsoil , & !in + dt ,cosz ,fage ,elai ,esai , & !in + tg ,tv ,snowh ,fsno ,fwet , & !in + smc ,sneqvo ,sneqv ,qsnow ,fveg , & !in + iloc ,jloc , & !in + albold ,tauss , & !inout + albgrd ,albgri ,albd ,albi ,fabd , & !out + fabi ,ftdd ,ftid ,ftii ,fsun , & !out + frevi ,frevd ,fregd ,fregi ,bgap , & !out + wgap) + +! -------------------------------------------------------------------------------------------------- +! surface albedos. also fluxes (per unit incoming direct and diffuse +! radiation) reflected, transmitted, and absorbed by vegetation. +! also sunlit fraction of the canopy. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: ist !surface type + integer, intent(in) :: ice !ice (ice = 1) + + real, intent(in) :: dt !time step [sec] + real, intent(in) :: qsnow !snowfall + real, intent(in) :: cosz !cosine solar zenith angle for next time step + real, intent(in) :: snowh !snow height (mm) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: elai !lai, one-sided, adjusted for burying by snow + real, intent(in) :: esai !sai, one-sided, adjusted for burying by snow + real, intent(in) :: fsno !fraction of grid covered by snow + real, intent(in) :: fwet !fraction of canopy that is wet + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow mass (mm) + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water (m3/m3) + +! inout + real, intent(inout) :: albold !snow albedo at last time step (class type) + real, intent(inout) :: tauss !non-dimensional snow age + +! output + real, dimension(1: 2), intent(out) :: albgrd !ground albedo (direct) + real, dimension(1: 2), intent(out) :: albgri !ground albedo (diffuse) + real, dimension(1: 2), intent(out) :: albd !surface albedo (direct) + real, dimension(1: 2), intent(out) :: albi !surface albedo (diffuse) + real, dimension(1: 2), intent(out) :: fabd !flux abs by veg (per unit direct flux) + real, dimension(1: 2), intent(out) :: fabi !flux abs by veg (per unit diffuse flux) + real, dimension(1: 2), intent(out) :: ftdd !down direct flux below veg (per unit dir flux) + real, dimension(1: 2), intent(out) :: ftid !down diffuse flux below veg (per unit dir flux) + real, dimension(1: 2), intent(out) :: ftii !down diffuse flux below veg (per unit dif flux) + real, intent(out) :: fsun !sunlit fraction of canopy (-) +!jref:start + real, dimension(1: 2), intent(out) :: frevd + real, dimension(1: 2), intent(out) :: frevi + real, dimension(1: 2), intent(out) :: fregd + real, dimension(1: 2), intent(out) :: fregi + real, intent(out) :: bgap + real, intent(out) :: wgap +!jref:end + +! ------------------------------------------------------------------------ +! ------------------------ local variables ------------------------------- +! local + real :: fage !snow age function + real :: alb + integer :: ib !indices + integer :: nband !number of solar radiation wave bands + integer :: ic !direct beam: ic=0; diffuse: ic=1 + + real :: wl !fraction of lai+sai that is lai + real :: ws !fraction of lai+sai that is sai + real :: mpe !prevents overflow for division by zero + + real, dimension(1:2) :: rho !leaf/stem reflectance weighted by fraction lai and sai + real, dimension(1:2) :: tau !leaf/stem transmittance weighted by fraction lai and sai + real, dimension(1:2) :: ftdi !down direct flux below veg per unit dif flux = 0 + real, dimension(1:2) :: albsnd !snow albedo (direct) + real, dimension(1:2) :: albsni !snow albedo (diffuse) + + real :: vai !elai+esai + real :: gdir !average projected leaf/stem area in solar direction + real :: ext !optical depth direct beam per unit leaf + stem area + +! -------------------------------------------------------------------------------------------------- + + nband = 2 + mpe = 1.e-06 + bgap = 0. + wgap = 0. + +! initialize output because solar radiation only done if cosz > 0 + + do ib = 1, nband + albd(ib) = 0. + albi(ib) = 0. + albgrd(ib) = 0. + albgri(ib) = 0. + fabd(ib) = 0. + fabi(ib) = 0. + ftdd(ib) = 0. + ftid(ib) = 0. + ftii(ib) = 0. + if (ib.eq.1) fsun = 0. + end do + + if(cosz <= 0) goto 100 + +! weight reflectance/transmittance by lai and sai + + do ib = 1, nband + vai = elai + esai + wl = elai / max(vai,mpe) + ws = esai / max(vai,mpe) + rho(ib) = max(parameters%rhol(ib)*wl+parameters%rhos(ib)*ws, mpe) + tau(ib) = max(parameters%taul(ib)*wl+parameters%taus(ib)*ws, mpe) + end do + +! snow age + + call snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage) + +! snow albedos: only if cosz > 0 and fsno > 0 + + if(opt_alb == 1) & + call snowalb_bats (parameters,nband, fsno,cosz,fage,albsnd,albsni) + if(opt_alb == 2) then + call snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc) + albold = alb + end if + +! ground surface albedo + + call groundalb (parameters,nsoil ,nband ,ice ,ist , & !in + fsno ,smc ,albsnd ,albsni ,cosz , & !in + tg ,iloc ,jloc , & !in + albgrd ,albgri ) !out + +! loop over nband wavebands to calculate surface albedos and solar +! fluxes for unit incoming direct (ic=0) and diffuse flux (ic=1) + + do ib = 1, nband + ic = 0 ! direct + call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,tv ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fabd ,albd ,ftdd ,ftid ,gdir , &!) !out + frevd ,fregd ,bgap ,wgap) + + ic = 1 ! diffuse + call twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,tv ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fabi ,albi ,ftdi ,ftii ,gdir , & !) !out + frevi ,fregi ,bgap ,wgap) + + end do + +! sunlit fraction of canopy. set fsun = 0 if fsun < 0.01. + + ext = gdir/cosz * sqrt(1.-rho(1)-tau(1)) + fsun = (1.-exp(-ext*vai)) / max(ext*vai,mpe) + ext = fsun + + if (ext .lt. 0.01) then + wl = 0. + else + wl = ext + end if + fsun = wl + +100 continue + + end subroutine albedo + +!== begin surrad =================================================================================== + + subroutine surrad (parameters,mpe ,fsun ,fsha ,elai ,vai , & !in + laisun ,laisha ,solad ,solai ,fabd , & !in + fabi ,ftdd ,ftid ,ftii ,albgrd , & !in + albgri ,albd ,albi ,iloc ,jloc , & !in + parsun ,parsha ,sav ,sag ,fsa , & !out + fsr , & !) !out + frevi ,frevd ,fregd ,fregi ,fsrv , & + fsrg) !inout + +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + real, intent(in) :: mpe !prevents underflow errors if division by zero + + real, intent(in) :: fsun !sunlit fraction of canopy + real, intent(in) :: fsha !shaded fraction of canopy + real, intent(in) :: elai !leaf area, one-sided + real, intent(in) :: vai !leaf + stem area, one-sided + real, intent(in) :: laisun !sunlit leaf area index, one-sided + real, intent(in) :: laisha !shaded leaf area index, one-sided + + real, dimension(1:2), intent(in) :: solad !incoming direct solar radiation (w/m2) + real, dimension(1:2), intent(in) :: solai !incoming diffuse solar radiation (w/m2) + real, dimension(1:2), intent(in) :: fabd !flux abs by veg (per unit incoming direct flux) + real, dimension(1:2), intent(in) :: fabi !flux abs by veg (per unit incoming diffuse flux) + real, dimension(1:2), intent(in) :: ftdd !down dir flux below veg (per incoming dir flux) + real, dimension(1:2), intent(in) :: ftid !down dif flux below veg (per incoming dir flux) + real, dimension(1:2), intent(in) :: ftii !down dif flux below veg (per incoming dif flux) + real, dimension(1:2), intent(in) :: albgrd !ground albedo (direct) + real, dimension(1:2), intent(in) :: albgri !ground albedo (diffuse) + real, dimension(1:2), intent(in) :: albd !overall surface albedo (direct) + real, dimension(1:2), intent(in) :: albi !overall surface albedo (diffuse) + + real, dimension(1:2), intent(in) :: frevd !overall surface albedo veg (direct) + real, dimension(1:2), intent(in) :: frevi !overall surface albedo veg (diffuse) + real, dimension(1:2), intent(in) :: fregd !overall surface albedo grd (direct) + real, dimension(1:2), intent(in) :: fregi !overall surface albedo grd (diffuse) + +! output + + real, intent(out) :: parsun !average absorbed par for sunlit leaves (w/m2) + real, intent(out) :: parsha !average absorbed par for shaded leaves (w/m2) + real, intent(out) :: sav !solar radiation absorbed by vegetation (w/m2) + real, intent(out) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(out) :: fsa !total absorbed solar radiation (w/m2) + real, intent(out) :: fsr !total reflected solar radiation (w/m2) + real, intent(out) :: fsrv !reflected solar radiation by vegetation + real, intent(out) :: fsrg !reflected solar radiation by ground + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband number (1=vis, 2=nir) + integer :: nband !number of solar radiation waveband classes + + real :: abs !absorbed solar radiation (w/m2) + real :: rnir !reflected solar radiation [nir] (w/m2) + real :: rvis !reflected solar radiation [vis] (w/m2) + real :: laifra !leaf area fraction of canopy + real :: trd !transmitted solar radiation: direct (w/m2) + real :: tri !transmitted solar radiation: diffuse (w/m2) + real, dimension(1:2) :: cad !direct beam absorbed by canopy (w/m2) + real, dimension(1:2) :: cai !diffuse radiation absorbed by canopy (w/m2) +! --------------------------------------------------------------------------------------------- + nband = 2 + +! zero summed solar fluxes + + sag = 0. + sav = 0. + fsa = 0. + +! loop over nband wavebands + + do ib = 1, nband + +! absorbed by canopy + + cad(ib) = solad(ib)*fabd(ib) + cai(ib) = solai(ib)*fabi(ib) + sav = sav + cad(ib) + cai(ib) + fsa = fsa + cad(ib) + cai(ib) + +! transmitted solar fluxes incident on ground + + trd = solad(ib)*ftdd(ib) + tri = solad(ib)*ftid(ib) + solai(ib)*ftii(ib) + +! solar radiation absorbed by ground surface + + abs = trd*(1.-albgrd(ib)) + tri*(1.-albgri(ib)) + sag = sag + abs + fsa = fsa + abs + end do + +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves + + laifra = elai / max(vai,mpe) + if (fsun .gt. 0.) then + parsun = (cad(1)+fsun*cai(1)) * laifra / max(laisun,mpe) + parsha = (fsha*cai(1))*laifra / max(laisha,mpe) + else + parsun = 0. + parsha = (cad(1)+cai(1))*laifra /max(laisha,mpe) + endif + +! reflected solar radiation + + rvis = albd(1)*solad(1) + albi(1)*solai(1) + rnir = albd(2)*solad(2) + albi(2)*solai(2) + fsr = rvis + rnir + +! reflected solar radiation of veg. and ground (combined ground) + fsrv = frevd(1)*solad(1)+frevi(1)*solai(1)+frevd(2)*solad(2)+frevi(2)*solai(2) + fsrg = fregd(1)*solad(1)+fregi(1)*solai(1)+fregd(2)*solad(2)+fregi(2)*solai(2) + + + end subroutine surrad + +!== begin snow_age ================================================================================= + + subroutine snow_age (parameters,dt,tg,sneqvo,sneqv,tauss,fage) +! ---------------------------------------------------------------------- + implicit none +! ------------------------ code history ------------------------------------------------------------ +! from bats +! ------------------------ input/output variables -------------------------------------------------- +!input + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: dt !main time step (s) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: sneqvo !snow mass at last time step(mm) + real, intent(in) :: sneqv !snow water per unit ground area (mm) + +!output + real, intent(out) :: fage !snow age + +!input/output + real, intent(inout) :: tauss !non-dimensional snow age +!local + real :: tage !total aging effects + real :: age1 !effects of grain growth due to vapor diffusion + real :: age2 !effects of grain growth at freezing of melt water + real :: age3 !effects of soot + real :: dela !temporary variable + real :: sge !temporary variable + real :: dels !temporary variable + real :: dela0 !temporary variable + real :: arg !temporary variable +! see yang et al. (1997) j.of climate for detail. +!--------------------------------------------------------------------------------------------------- + + if(sneqv.le.0.0) then + tauss = 0. + else if (sneqv.gt.800.) then + tauss = 0. + else + dela0 = 1.e-6*dt + arg = 5.e3*(1./tfrz-1./tg) + age1 = exp(arg) + age2 = exp(amin1(0.,10.*arg)) + age3 = 0.3 + tage = age1+age2+age3 + dela = dela0*tage + dels = amax1(0.0,sneqv-sneqvo) / parameters%swemx + sge = (tauss+dela)*(1.0-dels) + tauss = amax1(0.,sge) + endif + + fage= tauss/(tauss+1.) + + end subroutine snow_age + +!== begin snowalb_bats ============================================================================= + + subroutine snowalb_bats (parameters,nband,fsno,cosz,fage,albsnd,albsni) +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: cosz !cosine solar zenith angle + real,intent(in) :: fsno !snow cover fraction (-) + real,intent(in) :: fage !snow age correction + +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband class + + real :: fzen !zenith angle correction + real :: cf1 !temperary variable + real :: sl2 !2.*sl + real :: sl1 !1/sl + real :: sl !adjustable parameter + real, parameter :: c1 = 0.2 !default in bats + real, parameter :: c2 = 0.5 !default in bats +! real, parameter :: c1 = 0.2 * 2. ! double the default to match sleepers river's +! real, parameter :: c2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + sl=2.0 + sl1=1./sl + sl2=2.*sl + cf1=((1.+sl1)/(1.+sl2*cosz)-sl1) + fzen=amax1(cf1,0.) + + albsni(1)=0.95*(1.-c1*fage) + albsni(2)=0.65*(1.-c2*fage) + + albsnd(1)=albsni(1)+0.4*fzen*(1.-albsni(1)) ! vis direct + albsnd(2)=albsni(2)+0.4*fzen*(1.-albsni(2)) ! nir direct + + end subroutine snowalb_bats + +!== begin snowalb_class ============================================================================ + + subroutine snowalb_class (parameters,nband,qsnow,dt,alb,albold,albsnd,albsni,iloc,jloc) +! ---------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: nband !number of waveband classes + + real,intent(in) :: qsnow !snowfall (mm/s) + real,intent(in) :: dt !time step (sec) + real,intent(in) :: albold !snow albedo at last time step + +! in & out + + real, intent(inout) :: alb ! +! output + + real, dimension(1:2),intent(out) :: albsnd !snow albedo for direct(1=vis, 2=nir) + real, dimension(1:2),intent(out) :: albsni !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: ib !waveband class + +! --------------------------------------------------------------------------------------------- +! zero albedos for all points + + albsnd(1: nband) = 0. + albsni(1: nband) = 0. + +! when cosz > 0 + + alb = 0.55 + (albold-0.55) * exp(-0.01*dt/3600.) + +! 1 mm fresh snow(swe) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow + + if (qsnow > 0.) then + alb = alb + min(qsnow,parameters%swemx/dt) * (0.84-alb)/(parameters%swemx/dt) + endif + + albsni(1)= alb ! vis diffuse + albsni(2)= alb ! nir diffuse + albsnd(1)= alb ! vis direct + albsnd(2)= alb ! nir direct + + end subroutine snowalb_class + +!== begin groundalb ================================================================================ + + subroutine groundalb (parameters,nsoil ,nband ,ice ,ist , & !in + fsno ,smc ,albsnd ,albsni ,cosz , & !in + tg ,iloc ,jloc , & !in + albgrd ,albgri ) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: nband !number of solar radiation waveband classes + integer, intent(in) :: ice !value of ist for land ice + integer, intent(in) :: ist !surface type + real, intent(in) :: fsno !fraction of surface covered with snow (-) + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: cosz !cosine solar zenith angle (0-1) + real, dimension(1:nsoil), intent(in) :: smc !volumetric soil water content (m3/m3) + real, dimension(1: 2), intent(in) :: albsnd !direct beam snow albedo (vis, nir) + real, dimension(1: 2), intent(in) :: albsni !diffuse snow albedo (vis, nir) + +!output + + real, dimension(1: 2), intent(out) :: albgrd !ground albedo (direct beam: vis, nir) + real, dimension(1: 2), intent(out) :: albgri !ground albedo (diffuse: vis, nir) + +!local + + integer :: ib !waveband number (1=vis, 2=nir) + real :: inc !soil water correction factor for soil albedo + real :: albsod !soil albedo (direct) + real :: albsoi !soil albedo (diffuse) +! -------------------------------------------------------------------------------------------------- + + do ib = 1, nband + inc = max(0.11-0.40*smc(1), 0.) + if (ist .eq. 1) then !soil + albsod = min(parameters%albsat(ib)+inc,parameters%albdry(ib)) + albsoi = albsod + else if (tg .gt. tfrz) then !unfrozen lake, wetland + albsod = 0.06/(max(0.01,cosz)**1.7 + 0.15) + albsoi = 0.06 + else !frozen lake, wetland + albsod = parameters%alblak(ib) + albsoi = albsod + end if + +! increase desert and semi-desert albedos + +! if (ist .eq. 1 .and. isc .eq. 9) then +! albsod = albsod + 0.10 +! albsoi = albsoi + 0.10 +! end if + + albgrd(ib) = albsod*(1.-fsno) + albsnd(ib)*fsno + albgri(ib) = albsoi*(1.-fsno) + albsni(ib)*fsno + end do + + end subroutine groundalb + +!== begin twostream ================================================================================ + + subroutine twostream (parameters,ib ,ic ,vegtyp ,cosz ,vai , & !in + fwet ,t ,albgrd ,albgri ,rho , & !in + tau ,fveg ,ist ,iloc ,jloc , & !in + fab ,fre ,ftd ,fti ,gdir , & !) !out + frev ,freg ,bgap ,wgap) + +! -------------------------------------------------------------------------------------------------- +! use two-stream approximation of dickinson (1983) adv geophysics +! 25:305-353 and sellers (1985) int j remote sensing 6:1335-1372 +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or diffuse +! flux given an underlying surface with known albedo. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: ist !surface type + integer, intent(in) :: ib !waveband number + integer, intent(in) :: ic !0=unit incoming direct; 1=unit incoming diffuse + integer, intent(in) :: vegtyp !vegetation type + + real, intent(in) :: cosz !cosine of direct zenith angle (0-1) + real, intent(in) :: vai !one-sided leaf+stem area index (m2/m2) + real, intent(in) :: fwet !fraction of lai, sai that is wetted (-) + real, intent(in) :: t !surface temperature (k) + + real, dimension(1:2), intent(in) :: albgrd !direct albedo of underlying surface (-) + real, dimension(1:2), intent(in) :: albgri !diffuse albedo of underlying surface (-) + real, dimension(1:2), intent(in) :: rho !leaf+stem reflectance + real, dimension(1:2), intent(in) :: tau !leaf+stem transmittance + real, intent(in) :: fveg !green vegetation fraction [0.0-1.0] + +! output + + real, dimension(1:2), intent(out) :: fab !flux abs by veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: fre !flux refl above veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: ftd !down dir flux below veg layer (per unit in flux) + real, dimension(1:2), intent(out) :: fti !down dif flux below veg layer (per unit in flux) + real, intent(out) :: gdir !projected leaf+stem area in solar direction + real, dimension(1:2), intent(out) :: frev !flux reflected by veg layer (per unit incoming flux) + real, dimension(1:2), intent(out) :: freg !flux reflected by ground (per unit incoming flux) + +! local + real :: omega !fraction of intercepted radiation that is scattered + real :: omegal !omega for leaves + real :: betai !upscatter parameter for diffuse radiation + real :: betail !betai for leaves + real :: betad !upscatter parameter for direct beam radiation + real :: betadl !betad for leaves + real :: ext !optical depth of direct beam per unit leaf area + real :: avmu !average diffuse optical depth + + real :: coszi !0.001 <= cosz <= 1.000 + real :: asu !single scattering albedo + real :: chil ! -0.4 <= xl <= 0.6 + + real :: tmp0,tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9 + real :: p1,p2,p3,p4,s1,s2,u1,u2,u3 + real :: b,c,d,d1,d2,f,h,h1,h2,h3,h4,h5,h6,h7,h8,h9,h10 + real :: phi1,phi2,sigma + real :: ftds,ftis,fres + real :: denfveg + real :: vai_spread +!jref:start + real :: freveg,frebar,ftdveg,ftiveg,ftdbar,ftibar + real :: thetaz +!jref:end + +! variables for the modified two-stream scheme +! niu and yang (2004), jgr + + real, parameter :: pai = 3.14159265 + real :: hd !crown depth (m) + real :: bb !vertical crown radius (m) + real :: thetap !angle conversion from sza + real :: fa !foliage volume density (m-1) + real :: newvai !effective lsai (-) + + real,intent(inout) :: bgap !between canopy gap fraction for beam (-) + real,intent(inout) :: wgap !within canopy gap fraction for beam (-) + + real :: kopen !gap fraction for diffue light (-) + real :: gap !total gap fraction for beam ( <=1-shafac ) + +! ----------------------------------------------------------------- +! compute within and between gaps + vai_spread = vai + if(vai == 0.0) then + gap = 1.0 + kopen = 1.0 + else + if(opt_rad == 1) then + denfveg = -log(max(1.0-fveg,0.01))/(pai*parameters%rc**2) + hd = parameters%hvt - parameters%hvb + bb = 0.5 * hd + thetap = atan(bb/parameters%rc * tan(acos(max(0.01,cosz))) ) + ! bgap = exp(-parameters%den * pai * parameters%rc**2/cos(thetap) ) + bgap = exp(-denfveg * pai * parameters%rc**2/cos(thetap) ) + fa = vai/(1.33 * pai * parameters%rc**3.0 *(bb/parameters%rc)*denfveg) + newvai = hd*fa + wgap = (1.0-bgap) * exp(-0.5*newvai/cosz) + gap = min(1.0-fveg, bgap+wgap) + + kopen = 0.05 + end if + + if(opt_rad == 2) then + gap = 0.0 + kopen = 0.0 + end if + + if(opt_rad == 3) then + gap = 1.0-fveg + kopen = 1.0-fveg + end if + end if + +! calculate two-stream parameters omega, betad, betai, avmu, gdir, ext. +! omega, betad, betai are adjusted for snow. values for omega*betad +! and omega*betai are calculated and then divided by the new omega +! because the product omega*betai, omega*betad is used in solution. +! also, the transmittances and reflectances (tau, rho) are linear +! weights of leaf and stem values. + + coszi = max(0.001, cosz) + chil = min( max(parameters%xl, -0.4), 0.6) + if (abs(chil) .le. 0.01) chil = 0.01 + phi1 = 0.5 - 0.633*chil - 0.330*chil*chil + phi2 = 0.877 * (1.-2.*phi1) + gdir = phi1 + phi2*coszi + ext = gdir/coszi + avmu = ( 1. - phi1/phi2 * log((phi1+phi2)/phi1) ) / phi2 + omegal = rho(ib) + tau(ib) + tmp0 = gdir + phi2*coszi + tmp1 = phi1*coszi + asu = 0.5*omegal*gdir/tmp0 * ( 1.-tmp1/tmp0*log((tmp1+tmp0)/tmp1) ) + betadl = (1.+avmu*ext)/(omegal*avmu*ext)*asu + betail = 0.5 * ( rho(ib)+tau(ib) + (rho(ib)-tau(ib)) & + * ((1.+chil)/2.)**2 ) / omegal + +! adjust omega, betad, and betai for intercepted snow + + if (t .gt. tfrz) then !no snow + tmp0 = omegal + tmp1 = betadl + tmp2 = betail + else + tmp0 = (1.-fwet)*omegal + fwet*parameters%omegas(ib) + tmp1 = ( (1.-fwet)*omegal*betadl + fwet*parameters%omegas(ib)*parameters%betads ) / tmp0 + tmp2 = ( (1.-fwet)*omegal*betail + fwet*parameters%omegas(ib)*parameters%betais ) / tmp0 + end if + + omega = tmp0 + betad = tmp1 + betai = tmp2 + +! absorbed, reflected, transmitted fluxes per unit incoming radiation + + b = 1. - omega + omega*betai + c = omega*betai + tmp0 = avmu*ext + d = tmp0 * omega*betad + f = tmp0 * omega*(1.-betad) + tmp1 = b*b - c*c + h = sqrt(tmp1) / avmu + sigma = tmp0*tmp0 - tmp1 + if ( abs (sigma) < 1.e-6 ) sigma = sign(1.e-6,sigma) + p1 = b + avmu*h + p2 = b - avmu*h + p3 = b + tmp0 + p4 = b - tmp0 + s1 = exp(-h*vai) + s2 = exp(-ext*vai) + if (ic .eq. 0) then + u1 = b - c/albgrd(ib) + u2 = b - c*albgrd(ib) + u3 = f + c*albgrd(ib) + else + u1 = b - c/albgri(ib) + u2 = b - c*albgri(ib) + u3 = f + c*albgri(ib) + end if + tmp2 = u1 - avmu*h + tmp3 = u1 + avmu*h + d1 = p1*tmp2/s1 - p2*tmp3*s1 + tmp4 = u2 + avmu*h + tmp5 = u2 - avmu*h + d2 = tmp4/s1 - tmp5*s1 + h1 = -d*p4 - c*f + tmp6 = d - h1*p3/sigma + tmp7 = ( d - c - h1/sigma*(u1+tmp0) ) * s2 + h2 = ( tmp6*tmp2/s1 - p2*tmp7 ) / d1 + h3 = - ( tmp6*tmp3*s1 - p1*tmp7 ) / d1 + h4 = -f*p3 - c*d + tmp8 = h4/sigma + tmp9 = ( u3 - tmp8*(u2-tmp0) ) * s2 + h5 = - ( tmp8*tmp4/s1 + tmp9 ) / d2 + h6 = ( tmp8*tmp5*s1 + tmp9 ) / d2 + h7 = (c*tmp2) / (d1*s1) + h8 = (-c*tmp3*s1) / d1 + h9 = tmp4 / (d2*s1) + h10 = (-tmp5*s1) / d2 + +! downward direct and diffuse fluxes below vegetation +! niu and yang (2004), jgr. + + if (ic .eq. 0) then + ftds = s2 *(1.0-gap) + gap + ftis = (h4*s2/sigma + h5*s1 + h6/s1)*(1.0-gap) + else + ftds = 0. + ftis = (h9*s1 + h10/s1)*(1.0-kopen) + kopen + end if + ftd(ib) = ftds + fti(ib) = ftis + +! flux reflected by the surface (veg. and ground) + + if (ic .eq. 0) then + fres = (h1/sigma + h2 + h3)*(1.0-gap ) + albgrd(ib)*gap + freveg = (h1/sigma + h2 + h3)*(1.0-gap ) + frebar = albgrd(ib)*gap !jref - separate veg. and ground reflection + else + fres = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen + freveg = (h7 + h8) *(1.0-kopen) + albgri(ib)*kopen + frebar = 0 !jref - separate veg. and ground reflection + end if + fre(ib) = fres + + frev(ib) = freveg + freg(ib) = frebar + +! flux absorbed by vegetation + + fab(ib) = 1. - fre(ib) - (1.-albgrd(ib))*ftd(ib) & + - (1.-albgri(ib))*fti(ib) + +!if(iloc == 1.and.jloc == 2) then +! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," gap: ",gap," ftd: ",ftd(ib)," fti: ",fti(ib)," fre: ", & +! fre(ib)," fab: ",fab(ib)," albgrd: ",albgrd(ib)," albgri: ",albgri(ib) +!end if + + end subroutine twostream + +!== begin vege_flux ================================================================================ + + subroutine vege_flux(parameters,nsnow ,nsoil ,isnow ,vegtyp ,veg , & !in + dt ,sav ,sag ,lwdn ,ur , & !in + uu ,vv ,sfctmp ,thair ,qair , & !in + eair ,rhoair ,snowh ,vai ,gammav ,gammag, & !in + fwet ,laisun ,laisha ,cwp ,dzsnso , & !in + zlvl ,zpd ,z0m ,fveg , & !in + z0mg ,emv ,emg ,canliq ,fsno, & !in + canice ,stc ,df ,rssun ,rssha , & !in + rsurf ,latheav ,latheag ,parsun ,parsha ,igs , & !in + foln ,co2air ,o2air ,btran ,sfcprs , & !in + rhsur ,iloc ,jloc ,q2 ,pahv ,pahg , & !in + eah ,tah ,tv ,tg ,cm , & !inout + ch ,dx ,dz8w , & ! + tauxv ,tauyv ,irg ,irc ,shg , & !out + shc ,evg ,evc ,tr ,gh , & !out + t2mv ,psnsun ,psnsha , & !out + qc ,qsfc ,psfc , & !in + q2v ,cah2 ,chleaf ,chuc ) !inout + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve for vegetation (tv) and +! ground (tg) temperatures that balance the surface energy budgets + +! vegetated: +! -sav + irc[tv] + shc[tv] + evc[tv] + tr[tv] = 0 +! -sag + irg[tg] + shg[tg] + evg[tg] + gh[tg] = 0 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + logical, intent(in) :: veg !true if vegetated surface + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: isnow !actual no. of snow layers + integer, intent(in) :: vegtyp !vegetation physiology type + real, intent(in) :: fveg !greeness vegetation fraction (-) + real, intent(in) :: sav !solar rad absorbed by veg (w/m2) + real, intent(in) :: sag !solar rad absorbed by ground (w/m2) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: uu !wind speed in eastward dir (m/s) + real, intent(in) :: vv !wind speed in northward dir (m/s) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: thair !potential temp at reference height (k) + real, intent(in) :: eair !vapor pressure air at zlvl (pa) + real, intent(in) :: qair !specific humidity at zlvl (kg/kg) + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: dt !time step (s) + real, intent(in) :: fsno !snow fraction + + real, intent(in) :: snowh !actual snow depth [m] + real, intent(in) :: fwet !wetted fraction of canopy + real, intent(in) :: cwp !canopy wind parameter + + real, intent(in) :: vai !total leaf area index + stem area index + real, intent(in) :: laisun !sunlit leaf area index, one-sided (m2/m2) + real, intent(in) :: laisha !shaded leaf area index, one-sided (m2/m2) + real, intent(in) :: zlvl !reference height (m) + + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0m !roughness length, momentum (m) + real, intent(in) :: z0mg !roughness length, momentum, ground (m) + real, intent(in) :: emv !vegetation emissivity + real, intent(in) :: emg !ground emissivity + + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thinkness of snow/soil layers (m) + real, intent(in) :: canliq !intercepted liquid water (mm) + real, intent(in) :: canice !intercepted ice mass (mm) + real, intent(in) :: rsurf !ground surface resistance (s/m) +! real, intent(in) :: gamma !psychrometric constant (pa/k) +! real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gammav !psychrometric constant (pa/k) + real, intent(in) :: latheav !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gammag !psychrometric constant (pa/k) + real, intent(in) :: latheag !latent heat of vaporization/subli (j/kg) + real, intent(in) :: parsun !par absorbed per unit sunlit lai (w/m2) + real, intent(in) :: parsha !par absorbed per unit shaded lai (w/m2) + real, intent(in) :: foln !foliage nitrogen (%) + real, intent(in) :: co2air !atmospheric co2 concentration (pa) + real, intent(in) :: o2air !atmospheric o2 concentration (pa) + real, intent(in) :: igs !growing season index (0=off, 1=on) + real, intent(in) :: sfcprs !pressure (pa) + real, intent(in) :: btran !soil water transpiration factor (0 to 1) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + + real , intent(in) :: qc !cloud water mixing ratio + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: dx !grid spacing + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: dz8w !thickness of lowest layer + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real, intent(in) :: pahv !precipitation advected heat - canopy net in (w/m2) + real, intent(in) :: pahg !precipitation advected heat - ground net in (w/m2) + +! input/output + real, intent(inout) :: eah !canopy air vapor pressure (pa) + real, intent(inout) :: tah !canopy air temperature (k) + real, intent(inout) :: tv !vegetation temperature (k) + real, intent(inout) :: tg !ground temperature (k) + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + +! output +! -fsa + fira + fsh + (fcev + fctr + fgev) + fcst + ssoil = 0 + real, intent(out) :: tauxv !wind stress: e-w (n/m2) + real, intent(out) :: tauyv !wind stress: n-s (n/m2) + real, intent(out) :: irc !net longwave radiation (w/m2) [+= to atm] + real, intent(out) :: shc !sensible heat flux (w/m2) [+= to atm] + real, intent(out) :: evc !evaporation heat flux (w/m2) [+= to atm] + real, intent(out) :: irg !net longwave radiation (w/m2) [+= to atm] + real, intent(out) :: shg !sensible heat flux (w/m2) [+= to atm] + real, intent(out) :: evg !evaporation heat flux (w/m2) [+= to atm] + real, intent(out) :: tr !transpiration heat flux (w/m2)[+= to atm] + real, intent(out) :: gh !ground heat (w/m2) [+ = to soil] + real, intent(out) :: t2mv !2 m height air temperature (k) + real, intent(out) :: psnsun !sunlit leaf photosynthesis (umolco2/m2/s) + real, intent(out) :: psnsha !shaded leaf photosynthesis (umolco2/m2/s) + real, intent(out) :: chleaf !leaf exchange coefficient + real, intent(out) :: chuc !under canopy exchange coefficient + + real, intent(out) :: q2v + real :: cah !sensible heat conductance, canopy air to zlvl air (m/s) + real :: u10v !10 m wind speed in eastward dir (m/s) + real :: v10v !10 m wind speed in eastward dir (m/s) + real :: wspd + +! ------------------------ local variables ---------------------------------------------------- + real :: cw !water vapor exchange coefficient + real :: fv !friction velocity (m/s) + real :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) + real :: z0h !roughness length, sensible heat (m) + real :: z0hg !roughness length, sensible heat (m) + real :: rb !bulk leaf boundary layer resistance (s/m) + real :: ramc !aerodynamic resistance for momentum (s/m) + real :: rahc !aerodynamic resistance for sensible heat (s/m) + real :: rawc !aerodynamic resistance for water vapor (s/m) + real :: ramg !aerodynamic resistance for momentum (s/m) + real :: rahg !aerodynamic resistance for sensible heat (s/m) + real :: rawg !aerodynamic resistance for water vapor (s/m) + + real, intent(out) :: rssun !sunlit leaf stomatal resistance (s/m) + real, intent(out) :: rssha !shaded leaf stomatal resistance (s/m) + + real :: mol !monin-obukhov length (m) + real :: dtv !change in tv, last iteration (k) + real :: dtg !change in tg, last iteration (k) + + real :: air,cir !coefficients for ir as function of ts**4 + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cgh !coefficients for st as function of ts + real :: atr,ctr !coefficients for tr as function of esat[ts] + real :: ata,bta !coefficients for tah as function of ts + real :: aea,bea !coefficients for eah as function of esat[ts] + + real :: estv !saturation vapor pressure at tv (pa) + real :: estg !saturation vapor pressure at tg (pa) + real :: destv !d(es)/dt at ts (pa/k) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + real :: fhg !sen heat stability correction, ground + real :: hcan !canopy height (m) [note: hcan >= z0mg] + + real :: a !temporary calculation + real :: b !temporary calculation + real :: cvh !sensible heat conductance, leaf surface to canopy air (m/s) + real :: caw !latent heat conductance, canopy air zlvl air (m/s) + real :: ctw !transpiration conductance, leaf to canopy air (m/s) + real :: cew !evaporation conductance, leaf to canopy air (m/s) + real :: cgw !latent heat conductance, ground to canopy air (m/s) + real :: cond !sum of conductances (s/m) + real :: uc !wind speed at top of canopy (m/s) + real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) + real :: h !temporary sensible heat flux (w/m2) + real :: hg !temporary sensible heat flux (w/m2) + + real :: moz !monin-obukhov stability parameter + real :: mozg !monin-obukhov stability parameter + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + real :: thstar !surface exchange at 2m + + real :: thvair + real :: thah + real :: rahc2 !aerodynamic resistance for sensible heat (s/m) + real :: rawc2 !aerodynamic resistance for water vapor (s/m) + real, intent(out):: cah2 !sensible heat conductance for diagnostics + real :: ch2v !exchange coefficient for 2m over vegetation. + real :: cq2v !exchange coefficient for 2m over vegetation. + real :: eah2 !2m vapor pressure over canopy + real :: qfx !moisture flux + real :: e1 + + + real :: vaie !total leaf area index + stem area index,effective + real :: laisune !sunlit leaf area index, one-sided (m2/m2),effective + real :: laishae !shaded leaf area index, one-sided (m2/m2),effective + + integer :: k !index + integer :: iter !iteration index + +!jref - niterc test from 5 to 20 + integer, parameter :: niterc = 20 !number of iterations for surface temperature +!jref - niterg test from 3-5 + integer, parameter :: niterg = 5 !number of iterations for ground temperature + integer :: mozsgn !number of times moz changes sign + real :: mpe !prevents overflow error if division by zero + + integer :: liter !last iteration + + + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + + character(len=80) :: message + + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) +! --------------------------------------------------------------------------------------------- + + mpe = 1e-6 + liter = 0 + fv = 0.1 + +! --------------------------------------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! --------------------------------------------------------------------------------------------- + dtv = 0. + dtg = 0. + moz = 0. + mozsgn = 0 + mozold = 0. + hg = 0. + h = 0. + qfx = 0. + +! YRQ +! write(*,*) 'tv,tg,stc in input:YRQ', tv,tg,stc + +! convert grid-cell lai to the fractional vegetated area (fveg) + + vaie = min(6.,vai / fveg) + laisune = min(6.,laisun / fveg) + laishae = min(6.,laisha / fveg) + +! saturation vapor pressure at ground temperature + + t = tdc(tg) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + +!jref - consistent surface specific humidity for sfcdif3 and sfcdif4 + + qsfc = 0.622*eair/(psfc-0.378*eair) + +! canopy height + + hcan = parameters%hvt + uc = ur*log(hcan/z0m)/log(zlvl/z0m) + uc = ur*log((hcan-zpd+z0m)/z0m)/log(zlvl/z0m) ! mb: add zpd v3.7 + if((hcan-zpd) <= 0.) then + write(message,*) "critical problem: hcan <= zpd" + call wrf_message ( message ) + write(message,*) 'i,j point=',iloc, jloc + call wrf_message ( message ) + write(message,*) 'hcan =',hcan + call wrf_message ( message ) + write(message,*) 'zpd =',zpd + call wrf_message ( message ) + write (message, *) 'snowh =',snowh + call wrf_message ( message ) + call wrf_error_fatal ( "critical problem in module_sf_noahmplsm:vegeflux" ) + end if + +! prepare for longwave rad. + + air = -emv*(1.+(1.-emv)*(1.-emg))*lwdn - emv*emg*sb*tg**4 + cir = (2.-emv*(1.-emg))*emv*sb + +! --------------------------------------------------------------------------------------------- + loop1: do iter = 1, niterc ! begin stability iteration + + if(iter == 1) then + z0h = z0m + z0hg = z0mg + else + z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) + z0hg = z0mg !* exp(-czil*0.4*258.2*sqrt(fv*z0mg)) + end if + +! aerodyn resistances between heights zlvl and d+z0v + + if(opt_sfc == 1) then + call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + zlvl ,zpd ,z0m ,z0h ,ur , & !in + mpe ,iloc ,jloc , & !in + moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + cm ,ch ,fv ,ch2 ) !out + endif + + if(opt_sfc == 2) then + call sfcdif2(parameters,iter ,z0m ,tah ,thair ,ur , & !in + zlvl ,iloc ,jloc , & !in + cm ,ch ,moz ,wstar , & !in + fv ) !out + ! undo the multiplication by windspeed that sfcdif2 + ! applies to exchange coefficients ch and cm: + ch = ch / ur + cm = cm / ur + endif + + ramc = max(1.,1./(cm*ur)) + rahc = max(1.,1./(ch*ur)) + rawc = rahc + +! aerodyn resistance between heights z0g and d+z0v, rag, and leaf +! boundary layer resistance, rb + + call ragrb(parameters,iter ,vaie ,rhoair ,hg ,tah , & !in + zpd ,z0mg ,z0hg ,hcan ,uc , & !in + z0h ,fv ,cwp ,vegtyp ,mpe , & !in + tv ,mozg ,fhg ,iloc ,jloc , & !inout + ramg ,rahg ,rawg ,rb ) !out + +! es and d(es)/dt evaluated at tv + + t = tdc(tv) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estv = esatw + destv = dsatw + else + estv = esati + destv = dsati + end if + +! stomatal resistance + + if(iter == 1) then + if (opt_crs == 1) then ! ball-berry + call stomata (parameters,vegtyp,mpe ,parsun ,foln ,iloc , jloc , & !in + tv ,estv ,eah ,sfctmp,sfcprs, & !in + o2air ,co2air,igs ,btran ,rb , & !in + rssun ,psnsun) !out + + call stomata (parameters,vegtyp,mpe ,parsha ,foln ,iloc , jloc , & !in + tv ,estv ,eah ,sfctmp,sfcprs, & !in + o2air ,co2air,igs ,btran ,rb , & !in + rssha ,psnsha) !out + end if + + if (opt_crs == 2) then ! jarvis + call canres (parameters,parsun,tv ,btran ,eah ,sfcprs, & !in + rssun ,psnsun,iloc ,jloc ) !out + + call canres (parameters,parsha,tv ,btran ,eah ,sfcprs, & !in + rssha ,psnsha,iloc ,jloc ) !out + end if + end if + +! prepare for sensible heat flux above veg. + + cah = 1./rahc + cvh = 2.*vaie/rb + cgh = 1./rahg + cond = cah + cvh + cgh + ata = (sfctmp*cah + tg*cgh) / cond + bta = cvh/cond + csh = (1.-bta)*rhoair*cpair*cvh + +! prepare for latent heat flux above veg. + + caw = 1./rawc + cew = fwet*vaie/rb + ctw = (1.-fwet)*(laisune/(rb+rssun) + laishae/(rb+rssha)) + cgw = 1./(rawg+rsurf) + cond = caw + cew + ctw + cgw + aea = (eair*caw + estg*cgw) / cond + bea = (cew+ctw)/cond + cev = (1.-bea)*cew*rhoair*cpair/gammav ! barlage: change to vegetation v3.6 + ctr = (1.-bea)*ctw*rhoair*cpair/gammav + +! evaluate surface fluxes with current temperature and solve for dts + + tah = ata + bta*tv ! canopy air t. + eah = aea + bea*estv ! canopy air e + + irc = fveg*(air + cir*tv**4) + shc = fveg*rhoair*cpair*cvh * ( tv-tah) + evc = fveg*rhoair*cpair*cew * (estv-eah) / gammav ! barlage: change to v in v3.6 + tr = fveg*rhoair*cpair*ctw * (estv-eah) / gammav + if (tv > tfrz) then + evc = min(canliq*latheav/dt,evc) ! barlage: add if block for canice in v3.6 + else + evc = min(canice*latheav/dt,evc) + end if + + b = sav-irc-shc-evc-tr+pahv !additional w/m2 + a = fveg*(4.*cir*tv**3 + csh + (cev+ctr)*destv) !volumetric heat capacity + dtv = b/a + + irc = irc + fveg*4.*cir*tv**3*dtv + shc = shc + fveg*csh*dtv + evc = evc + fveg*cev*destv*dtv + tr = tr + fveg*ctr*destv*dtv + +! update vegetation surface temperature + tv = tv + dtv +! tah = ata + bta*tv ! canopy air t; update here for consistency + +! for computing m-o length in the next iteration + h = rhoair*cpair*(tah - sfctmp) /rahc + hg = rhoair*cpair*(tg - tah) /rahg + +! consistent specific humidity from canopy air vapor pressure + qsfc = (0.622*eah)/(sfcprs-0.378*eah) + + if (liter == 1) then + exit loop1 + endif + if (iter >= 5 .and. abs(dtv) <= 0.01 .and. liter == 0) then + liter = 1 + endif + + end do loop1 ! end stability iteration + +! under-canopy fluxes and tg + + air = - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 + cir = emg*sb + csh = rhoair*cpair/rahg + cev = rhoair*cpair/(gammag*(rawg+rsurf)) ! barlage: change to ground v3.6 + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) +! write(*,*)'inside tg=',tg,'stc(1)=',stc(1) + + loop2: do iter = 1, niterg + + t = tdc(tg) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + irg = cir*tg**4 + air + shg = csh * (tg - tah ) + evg = cev * (estg*rhsur - eah ) + gh = cgh * (tg - stc(isnow+1)) + + b = sag-irg-shg-evg-gh+pahg + a = 4.*cir*tg**3+csh+cev*destg+cgh + dtg = b/a + + irg = irg + 4.*cir*tg**3*dtg + shg = shg + csh*dtg + evg = evg + cev*destg*dtg + gh = gh + cgh*dtg + tg = tg + dtg + + end do loop2 + +! tah = (cah*sfctmp + cvh*tv + cgh*tg)/(cah + cvh + cgh) + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + if(opt_stc == 1 .or. opt_stc == 3) then + if (snowh > 0.05 .and. tg > tfrz) then + tg = tfrz + if(opt_stc == 3) tg = (1.-fsno)*tg + fsno*tfrz ! mb: allow tg>0c during melt v3.7 + irg = cir*tg**4 - emg*(1.-emv)*lwdn - emg*emv*sb*tv**4 + shg = csh * (tg - tah) + evg = cev * (estg*rhsur - eah) + gh = sag+pahg - (irg+shg+evg) + end if + end if + +! wind stresses + + tauxv = -rhoair*cm*ur*uu + tauyv = -rhoair*cm*ur*vv + +! consistent vegetation air temperature and vapor pressure since tg is not consistent with the tah/eah +! calculation. +! tah = sfctmp + (shg+shc)/(rhoair*cpair*cah) +! tah = sfctmp + (shg*fveg+shc)/(rhoair*cpair*cah) ! ground flux need fveg +! eah = eair + (evc+fveg*(tr+evg))/(rhoair*caw*cpair/gammag ) +! qfx = (qsfc-qair)*rhoair*caw !*cpair/gammag + +! 2m temperature over vegetation ( corrected for low cq2v values ) + if (opt_sfc == 1 .or. opt_sfc == 2) then +! cah2 = fv*1./vkc*log((2.+z0h)/z0h) + cah2 = fv*vkc/log((2.+z0h)/z0h) + cah2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2v = cah2 + if (cah2 .lt. 1.e-5 ) then + t2mv = tah +! q2v = (eah*0.622/(sfcprs - 0.378*eah)) + q2v = qsfc + else + t2mv = tah - (shg+shc/fveg)/(rhoair*cpair) * 1./cah2 +! q2v = (eah*0.622/(sfcprs - 0.378*eah))- qfx/(rhoair*fv)* 1./vkc * log((2.+z0h)/z0h) + q2v = qsfc - ((evc+tr)/fveg+evg)/(latheav*rhoair) * 1./cq2v + endif + endif + +! update ch for output + ch = cah + chleaf = cvh + chuc = 1./rahg + + end subroutine vege_flux + +!== begin bare_flux ================================================================================ + + subroutine bare_flux (parameters,nsnow ,nsoil ,isnow ,dt ,sag , & !in + lwdn ,ur ,uu ,vv ,sfctmp , & !in + thair ,qair ,eair ,rhoair ,snowh , & !in + dzsnso ,zlvl ,zpd ,z0m ,fsno , & !in + emg ,stc ,df ,rsurf ,lathea , & !in + gamma ,rhsur ,iloc ,jloc ,q2 ,pahb , & !in + tgb ,cm ,ch , & !inout + tauxb ,tauyb ,irb ,shb ,evb , & !out + ghb ,t2mb ,dx ,dz8w ,ivgtyp , & !out + qc ,qsfc ,psfc , & !in + sfcprs ,q2b ,ehb2 ) !in + +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for bare soil fraction. + +! bare soil: +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !number of soil layers + integer, intent(in) :: isnow !actual no. of snow layers + real, intent(in) :: dt !time step (s) + real, intent(in) :: sag !solar radiation absorbed by ground (w/m2) + real, intent(in) :: lwdn !atmospheric longwave radiation (w/m2) + real, intent(in) :: ur !wind speed at height zlvl (m/s) + real, intent(in) :: uu !wind speed in eastward dir (m/s) + real, intent(in) :: vv !wind speed in northward dir (m/s) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: thair !potential temperature at height zlvl (k) + real, intent(in) :: qair !specific humidity at height zlvl (kg/kg) + real, intent(in) :: eair !vapor pressure air at height (pa) + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: snowh !actual snow depth [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !thickness of snow/soil layers (m) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: emg !ground emissivity + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !soil/snow temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity of snow/soil (w/m/k) + real, intent(in) :: rsurf !ground surface resistance (s/m) + real, intent(in) :: lathea !latent heat of vaporization/subli (j/kg) + real, intent(in) :: gamma !psychrometric constant (pa/k) + real, intent(in) :: rhsur !raltive humidity in surface soil/snow air space (-) + real, intent(in) :: fsno !snow fraction + +!jref:start; in + integer , intent(in) :: ivgtyp + real , intent(in) :: qc !cloud water mixing ratio + real , intent(inout) :: qsfc !mixing ratio at lowest model layer + real , intent(in) :: psfc !pressure at lowest model layer + real , intent(in) :: sfcprs !pressure at lowest model layer + real , intent(in) :: dx !horisontal grid spacing + real , intent(in) :: q2 !mixing ratio (kg/kg) + real , intent(in) :: dz8w !thickness of lowest layer +!jref:end + real, intent(in) :: pahb !precipitation advected heat - ground net in (w/m2) + +! input/output + real, intent(inout) :: tgb !ground temperature (k) + real, intent(inout) :: cm !momentum drag coefficient + real, intent(inout) :: ch !sensible heat exchange coefficient + +! output +! -sab + irb[tg] + shb[tg] + evb[tg] + ghb[tg] = 0 + + real, intent(out) :: tauxb !wind stress: e-w (n/m2) + real, intent(out) :: tauyb !wind stress: n-s (n/m2) + real, intent(out) :: irb !net longwave rad (w/m2) [+ to atm] + real, intent(out) :: shb !sensible heat flux (w/m2) [+ to atm] + real, intent(out) :: evb !latent heat flux (w/m2) [+ to atm] + real, intent(out) :: ghb !ground heat flux (w/m2) [+ to soil] + real, intent(out) :: t2mb !2 m height air temperature (k) +!jref:start + real, intent(out) :: q2b !bare ground heat conductance + real :: ehb !bare ground heat conductance + real :: u10b !10 m wind speed in eastward dir (m/s) + real :: v10b !10 m wind speed in eastward dir (m/s) + real :: wspd +!jref:end + +! local variables + + real :: taux !wind stress: e-w (n/m2) + real :: tauy !wind stress: n-s (n/m2) + real :: fira !total net longwave rad (w/m2) [+ to atm] + real :: fsh !total sensible heat flux (w/m2) [+ to atm] + real :: fgev !ground evaporation heat flux (w/m2)[+ to atm] + real :: ssoil !soil heat flux (w/m2) [+ to soil] + real :: fire !emitted ir (w/m2) + real :: trad !radiative temperature (k) + real :: tah !"surface" temperature at height z0h+zpd (k) + + real :: cw !water vapor exchange coefficient + real :: fv !friction velocity (m/s) + real :: wstar !friction velocity n vertical direction (m/s) (only for sfcdif2) + real :: z0h !roughness length, sensible heat, ground (m) + real :: rb !bulk leaf boundary layer resistance (s/m) + real :: ramb !aerodynamic resistance for momentum (s/m) + real :: rahb !aerodynamic resistance for sensible heat (s/m) + real :: rawb !aerodynamic resistance for water vapor (s/m) + real :: mol !monin-obukhov length (m) + real :: dtg !change in tg, last iteration (k) + + real :: cir !coefficients for ir as function of ts**4 + real :: csh !coefficients for sh as function of ts + real :: cev !coefficients for ev as function of esat[ts] + real :: cgh !coefficients for st as function of ts + +!jref:start + real :: rahb2 !aerodynamic resistance for sensible heat 2m (s/m) + real :: rawb2 !aerodynamic resistance for water vapor 2m (s/m) + real,intent(out) :: ehb2 !sensible heat conductance for diagnostics + real :: ch2b !exchange coefficient for 2m temp. + real :: cq2b !exchange coefficient for 2m temp. + real :: thvair !virtual potential air temp + real :: thgh !potential ground temp + real :: emb !momentum conductance + real :: qfx !moisture flux + real :: estg2 !saturation vapor pressure at 2m (pa) + integer :: vegtyp !vegetation type set to isbarren + real :: e1 +!jref:end + + real :: estg !saturation vapor pressure at tg (pa) + real :: destg !d(es)/dt at tg (pa/k) + real :: esatw !es for water + real :: esati !es for ice + real :: dsatw !d(es)/dt at tg (pa/k) for water + real :: dsati !d(es)/dt at tg (pa/k) for ice + + real :: a !temporary calculation + real :: b !temporary calculation + real :: h !temporary sensible heat flux (w/m2) + real :: moz !monin-obukhov stability parameter + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: fm !momentum stability correction, weighted by prior iters + real :: fh !sen heat stability correction, weighted by prior iters + integer :: mozsgn !number of times moz changes sign + real :: fm2 !monin-obukhov momentum adjustment at 2m + real :: fh2 !monin-obukhov heat adjustment at 2m + real :: ch2 !surface exchange at 2m + + integer :: iter !iteration index + integer :: niterb !number of iterations for surface temperature + real :: mpe !prevents overflow error if division by zero +!jref:start +! data niterb /3/ + data niterb /5/ + save niterb + real :: t, tdc !kelvin to degree celsius with limit -50 to +50 + tdc(t) = min( 50., max(-50.,(t-tfrz)) ) + +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + mpe = 1e-6 + dtg = 0. + moz = 0. + mozsgn = 0 + mozold = 0. + h = 0. + qfx = 0. + fv = 0.1 + + cir = emg*sb + cgh = 2.*df(isnow+1)/dzsnso(isnow+1) + +! ----------------------------------------------------------------- + loop3: do iter = 1, niterb ! begin stability iteration + + if(iter == 1) then + z0h = z0m + else + z0h = z0m !* exp(-czil*0.4*258.2*sqrt(fv*z0m)) + end if + + if(opt_sfc == 1) then + call sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + zlvl ,zpd ,z0m ,z0h ,ur , & !in + mpe ,iloc ,jloc , & !in + moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + cm ,ch ,fv ,ch2 ) !out + endif + + if(opt_sfc == 2) then + call sfcdif2(parameters,iter ,z0m ,tgb ,thair ,ur , & !in + zlvl ,iloc ,jloc , & !in + cm ,ch ,moz ,wstar , & !in + fv ) !out + ! undo the multiplication by windspeed that sfcdif2 + ! applies to exchange coefficients ch and cm: + ch = ch / ur + cm = cm / ur + if(snowh > 0.) then + cm = min(0.01,cm) ! cm & ch are too large, causing + ch = min(0.01,ch) ! computational instability + end if + + endif + + ramb = max(1.,1./(cm*ur)) + rahb = max(1.,1./(ch*ur)) + rawb = rahb + +!jref - variables for diagnostics + emb = 1./ramb + ehb = 1./rahb + +! es and d(es)/dt evaluated at tg + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + destg = dsatw + else + estg = esati + destg = dsati + end if + + csh = rhoair*cpair/rahb + cev = rhoair*cpair/gamma/(rsurf+rawb) + +! surface fluxes and dtg + + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp ) + evb = cev * (estg*rhsur - eair ) + ghb = cgh * (tgb - stc(isnow+1)) + + b = sag-irb-shb-evb-ghb+pahb + a = 4.*cir*tgb**3 + csh + cev*destg + cgh + dtg = b/a + + irb = irb + 4.*cir*tgb**3*dtg + shb = shb + csh*dtg + evb = evb + cev*destg*dtg + ghb = ghb + cgh*dtg + +! update ground surface temperature + tgb = tgb + dtg + +! for m-o length + h = csh * (tgb - sfctmp) + + t = tdc(tgb) + call esat(t, esatw, esati, dsatw, dsati) + if (t .gt. 0.) then + estg = esatw + else + estg = esati + end if + qsfc = 0.622*(estg*rhsur)/(psfc-0.378*(estg*rhsur)) + + qfx = (qsfc-qair)*cev*gamma/cpair + + end do loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and tg > tfrz: reset tg = tfrz. reevaluate ground fluxes. + + if(opt_stc == 1 .or. opt_stc == 3) then + if (snowh > 0.05 .and. tgb > tfrz) then + tgb = tfrz + if(opt_stc == 3) tgb = (1.-fsno)*tgb + fsno*tfrz ! mb: allow tg>0c during melt v3.7 + irb = cir * tgb**4 - emg*lwdn + shb = csh * (tgb - sfctmp) + evb = cev * (estg*rhsur - eair ) !estg reevaluate ? + ghb = sag+pahb - (irb+shb+evb) + end if + end if + +! wind stresses + + tauxb = -rhoair*cm*ur*uu + tauyb = -rhoair*cm*ur*vv + +!jref:start; errors in original equation corrected. +! 2m air temperature + if(opt_sfc == 1 .or. opt_sfc ==2) then + ehb2 = fv*vkc/log((2.+z0h)/z0h) + ehb2 = fv*vkc/(log((2.+z0h)/z0h)-fh2) + cq2b = ehb2 + if (ehb2.lt.1.e-5 ) then + t2mb = tgb + q2b = qsfc + else + t2mb = tgb - shb/(rhoair*cpair) * 1./ehb2 + q2b = qsfc - evb/(lathea*rhoair)*(1./cq2b + rsurf) + endif + if (parameters%urban_flag) q2b = qsfc + end if + +! update ch + ch = ehb + + end subroutine bare_flux + +!== begin ragrb ==================================================================================== + + subroutine ragrb(parameters,iter ,vai ,rhoair ,hg ,tah , & !in + zpd ,z0mg ,z0hg ,hcan ,uc , & !in + z0h ,fv ,cwp ,vegtyp ,mpe , & !in + tv ,mozg ,fhg ,iloc ,jloc , & !inout + ramg ,rahg ,rawg ,rb ) !out +! -------------------------------------------------------------------------------------------------- +! compute under-canopy aerodynamic resistance rag and leaf boundary layer +! resistance rb +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: iter !iteration index + integer, intent(in) :: vegtyp !vegetation physiology type + real, intent(in) :: vai !total lai + stem area index, one sided + real, intent(in) :: rhoair !density air (kg/m3) + real, intent(in) :: hg !ground sensible heat flux (w/m2) + real, intent(in) :: tv !vegetation temperature (k) + real, intent(in) :: tah !air temperature at height z0h+zpd (k) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0mg !roughness length, momentum, ground (m) + real, intent(in) :: hcan !canopy height (m) [note: hcan >= z0mg] + real, intent(in) :: uc !wind speed at top of canopy (m/s) + real, intent(in) :: z0h !roughness length, sensible heat (m) + real, intent(in) :: z0hg !roughness length, sensible heat, ground (m) + real, intent(in) :: fv !friction velocity (m/s) + real, intent(in) :: cwp !canopy wind parameter + real, intent(in) :: mpe !prevents overflow error if division by zero + +! in & out + + real, intent(inout) :: mozg !monin-obukhov stability parameter + real, intent(inout) :: fhg !stability correction + +! outputs + real :: ramg !aerodynamic resistance for momentum (s/m) + real :: rahg !aerodynamic resistance for sensible heat (s/m) + real :: rawg !aerodynamic resistance for water vapor (s/m) + real :: rb !bulk leaf boundary layer resistance (s/m) + + + real :: kh !turbulent transfer coefficient, sensible heat, (m2/s) + real :: tmp1 !temporary calculation + real :: tmp2 !temporary calculation + real :: tmprah2 !temporary calculation for aerodynamic resistances + real :: tmprb !temporary calculation for rb + real :: molg,fhgnew,cwpc +! -------------------------------------------------------------------------------------------------- +! stability correction to below canopy resistance + + mozg = 0. + molg = 0. + + if(iter > 1) then + tmp1 = vkc * (grav/tah) * hg/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + molg = -1. * fv**3 / tmp1 + mozg = min( (zpd-z0mg)/molg, 1.) + end if + + if (mozg < 0.) then + fhgnew = (1. - 15.*mozg)**(-0.25) + else + fhgnew = 1.+ 4.7*mozg + endif + + if (iter == 1) then + fhg = fhgnew + else + fhg = 0.5 * (fhg+fhgnew) + endif + + cwpc = (cwp * vai * hcan * fhg)**0.5 +! cwpc = (cwp*fhg)**0.5 + + tmp1 = exp( -cwpc*z0hg/hcan ) + tmp2 = exp( -cwpc*(z0h+zpd)/hcan ) + tmprah2 = hcan*exp(cwpc) / cwpc * (tmp1-tmp2) + +! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. + + kh = max ( vkc*fv*(hcan-zpd), mpe ) + ramg = 0. + rahg = tmprah2 / kh + rawg = rahg + +! leaf boundary layer resistance + + tmprb = cwpc*50. / (1. - exp(-cwpc/2.)) + rb = tmprb * sqrt(parameters%dleaf/uc) +! rb = 200 + + end subroutine ragrb + +!== begin sfcdif1 ================================================================================== + + subroutine sfcdif1(parameters,iter ,sfctmp ,rhoair ,h ,qair , & !in + & zlvl ,zpd ,z0m ,z0h ,ur , & !in + & mpe ,iloc ,jloc , & !in + & moz ,mozsgn ,fm ,fh ,fm2,fh2, & !inout + & cm ,ch ,fv ,ch2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient cm for momentum and ch for heat +! ------------------------------------------------------------------------------------------------- + implicit none +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: iter !iteration index + real, intent(in) :: sfctmp !temperature at reference height (k) + real, intent(in) :: rhoair !density air (kg/m**3) + real, intent(in) :: h !sensible heat flux (w/m2) [+ to atm] + real, intent(in) :: qair !specific humidity at reference height (kg/kg) + real, intent(in) :: zlvl !reference height (m) + real, intent(in) :: zpd !zero plane displacement (m) + real, intent(in) :: z0h !roughness length, sensible heat, ground (m) + real, intent(in) :: z0m !roughness length, momentum, ground (m) + real, intent(in) :: ur !wind speed (m/s) + real, intent(in) :: mpe !prevents overflow error if division by zero +! in & out + + integer, intent(inout) :: mozsgn !number of times moz changes sign + real, intent(inout) :: moz !monin-obukhov stability (z/l) + real, intent(inout) :: fm !momentum stability correction, weighted by prior iters + real, intent(inout) :: fh !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fm2 !sen heat stability correction, weighted by prior iters + real, intent(inout) :: fh2 !sen heat stability correction, weighted by prior iters + +! outputs + + real, intent(out) :: cm !drag coefficient for momentum + real, intent(out) :: ch !drag coefficient for heat + real, intent(out) :: fv !friction velocity (m/s) + real, intent(out) :: ch2 !drag coefficient for heat + +! locals + real :: mol !monin-obukhov length (m) + real :: tmpcm !temporary calculation for cm + real :: tmpch !temporary calculation for ch + real :: fmnew !stability correction factor, momentum, for current moz + real :: fhnew !stability correction factor, sen heat, for current moz + real :: mozold !monin-obukhov stability parameter from prior iteration + real :: tmp1,tmp2,tmp3,tmp4,tmp5 !temporary calculation + real :: tvir !temporary virtual temperature (k) + real :: moz2 !2/l + real :: tmpcm2 !temporary calculation for cm2 + real :: tmpch2 !temporary calculation for ch2 + real :: fm2new !stability correction factor, momentum, for current moz + real :: fh2new !stability correction factor, sen heat, for current moz + real :: tmp12,tmp22,tmp32 !temporary calculation + + real :: cmfm, chfh, cm2fm2, ch2fh2 +! ------------------------------------------------------------------------------------------------- +! monin-obukhov stability parameter moz for next iteration + + mozold = moz + + if(zlvl <= zpd) then + write(*,*) 'critical problem: zlvl <= zpd; model stops' + call wrf_error_fatal("stop in noah-mp") + endif + + tmpcm = log((zlvl-zpd) / z0m) + tmpch = log((zlvl-zpd) / z0h) + tmpcm2 = log((2.0 + z0m) / z0m) + tmpch2 = log((2.0 + z0h) / z0h) + + if(iter == 1) then + fv = 0.0 + moz = 0.0 + mol = 0.0 + moz2 = 0.0 + else + tvir = (1. + 0.61*qair) * sfctmp + tmp1 = vkc * (grav/tvir) * h/(rhoair*cpair) + if (abs(tmp1) .le. mpe) tmp1 = mpe + mol = -1. * fv**3 / tmp1 + moz = min( (zlvl-zpd)/mol, 1.) + moz2 = min( (2.0 + z0h)/mol, 1.) + endif + +! accumulate number of times moz changes sign. + + if (mozold*moz .lt. 0.) mozsgn = mozsgn+1 + if (mozsgn .ge. 2) then + moz = 0. + fm = 0. + fh = 0. + moz2 = 0. + fm2 = 0. + fh2 = 0. + endif + +! evaluate stability-dependent variables using moz from prior iteration + if (moz .lt. 0.) then + tmp1 = (1. - 16.*moz)**0.25 + tmp2 = log((1.+tmp1*tmp1)/2.) + tmp3 = log((1.+tmp1)/2.) + fmnew = 2.*tmp3 + tmp2 - 2.*atan(tmp1) + 1.5707963 + fhnew = 2*tmp2 + +! 2-meter + tmp12 = (1. - 16.*moz2)**0.25 + tmp22 = log((1.+tmp12*tmp12)/2.) + tmp32 = log((1.+tmp12)/2.) + fm2new = 2.*tmp32 + tmp22 - 2.*atan(tmp12) + 1.5707963 + fh2new = 2*tmp22 + else + fmnew = -5.*moz + fhnew = fmnew + fm2new = -5.*moz2 + fh2new = fm2new + endif + +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next + + if (iter == 1) then + fm = fmnew + fh = fhnew + fm2 = fm2new + fh2 = fh2new + else + fm = 0.5 * (fm+fmnew) + fh = 0.5 * (fh+fhnew) + fm2 = 0.5 * (fm2+fm2new) + fh2 = 0.5 * (fh2+fh2new) + endif + +! exchange coefficients + + fh = min(fh,0.9*tmpch) + fm = min(fm,0.9*tmpcm) + fh2 = min(fh2,0.9*tmpch2) + fm2 = min(fm2,0.9*tmpcm2) + + cmfm = tmpcm-fm + chfh = tmpch-fh + cm2fm2 = tmpcm2-fm2 + ch2fh2 = tmpch2-fh2 + if(abs(cmfm) <= mpe) cmfm = mpe + if(abs(chfh) <= mpe) chfh = mpe + if(abs(cm2fm2) <= mpe) cm2fm2 = mpe + if(abs(ch2fh2) <= mpe) ch2fh2 = mpe + cm = vkc*vkc/(cmfm*cmfm) + ch = vkc*vkc/(cmfm*chfh) + ch2 = vkc*vkc/(cm2fm2*ch2fh2) + +! friction velocity + + fv = ur * sqrt(cm) + ch2 = vkc*fv/ch2fh2 + + end subroutine sfcdif1 + +!== begin sfcdif2 ================================================================================== + + subroutine sfcdif2(parameters,iter ,z0 ,thz0 ,thlm ,sfcspd , & !in + zlm ,iloc ,jloc , & !in + akms ,akhs ,rlmo ,wstar2 , & !in + ustar ) !out + +! ------------------------------------------------------------------------------------------------- +! subroutine sfcdif (renamed sfcdif_off to avoid clash with eta pbl) +! ------------------------------------------------------------------------------------------------- +! calculate surface layer exchange coefficients via iterative process. +! see chen et al (1997, blm) +! ------------------------------------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: iter + real, intent(in) :: zlm, z0, thz0, thlm, sfcspd + real, intent(inout) :: akms + real, intent(inout) :: akhs + real, intent(inout) :: rlmo + real, intent(inout) :: wstar2 + real, intent(out) :: ustar + + real zz, pslmu, pslms, pslhu, pslhs + real xx, pspmu, yy, pspms, psphu, psphs + real zilfc, zu, zt, rdz, cxch + real dthv, du2, btgh, zslu, zslt, rlogu, rlogt + real zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4 + + real xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, rlmn, & + & rlma + + integer ilech, itr + + integer, parameter :: itrmx = 5 + real, parameter :: wwst = 1.2 + real, parameter :: wwst2 = wwst * wwst + real, parameter :: vkrm = 0.40 + real, parameter :: excm = 0.001 + real, parameter :: beta = 1.0 / 270.0 + real, parameter :: btg = beta * grav + real, parameter :: elfc = vkrm * btg + real, parameter :: wold = 0.15 + real, parameter :: wnew = 1.0 - wold + real, parameter :: pihf = 3.14159265 / 2. + real, parameter :: epsu2 = 1.e-4 + real, parameter :: epsust = 0.07 + real, parameter :: epsit = 1.e-4 + real, parameter :: epsa = 1.e-8 + real, parameter :: ztmin = -5.0 + real, parameter :: ztmax = 1.0 + real, parameter :: hpbl = 1000.0 + real, parameter :: sqvisc = 258.2 + real, parameter :: ric = 0.183 + real, parameter :: rric = 1.0 / ric + real, parameter :: fhneu = 0.8 + real, parameter :: rfc = 0.191 + real, parameter :: rfac = ric / ( fhneu * rfc * rfc ) + +! ---------------------------------------------------------------------- +! note: the two code blocks below define functions +! ---------------------------------------------------------------------- +! lech's surface functions + pslmu (zz)= -0.96* log (1.0-4.5* zz) + pslms (zz)= zz * rric -2.076* (1. -1./ (zz +1.)) + pslhu (zz)= -0.96* log (1.0-4.5* zz) + pslhs (zz)= zz * rfac -2.076* (1. -1./ (zz +1.)) +! paulson's surface functions + pspmu (xx)= -2.* log ( (xx +1.)*0.5) - log ( (xx * xx +1.)*0.5) & + & +2.* atan (xx) & + &- pihf + pspms (yy)= 5.* yy + psphu (xx)= -2.* log ( (xx * xx +1.)*0.5) + psphs (yy)= 5.* yy + +! this routine sfcdif can handle both over open water (sea, ocean) and +! over solid surface (land, sea-ice). +! ---------------------------------------------------------------------- +! ztfc: ratio of zoh/zom less or equal than 1 +! c......ztfc=0.1 +! czil: constant c in zilitinkevich, s. s.1995,:note about zt +! ---------------------------------------------------------------------- + ilech = 0 + +! ---------------------------------------------------------------------- + zilfc = - parameters%czil * vkrm * sqvisc + zu = z0 + rdz = 1./ zlm + cxch = excm * rdz + dthv = thlm - thz0 + +! beljars correction of ustar + du2 = max (sfcspd * sfcspd,epsu2) + btgh = btg * hpbl + + if(iter == 1) then + if (btgh * akhs * dthv .ne. 0.0) then + wstar2 = wwst2* abs (btgh * akhs * dthv)** (2./3.) + else + wstar2 = 0.0 + end if + ustar = max (sqrt (akms * sqrt (du2+ wstar2)),epsust) + rlmo = elfc * akhs * dthv / ustar **3 + end if + +! zilitinkevitch approach for zt + zt = max(1.e-6,exp (zilfc * sqrt (ustar * z0))* z0) + zslu = zlm + zu + zslt = zlm + zt + rlogu = log (zslu / zu) + rlogt = log (zslt / zt) + +! ---------------------------------------------------------------------- +! 1./monin-obukkhov length-scale +! ---------------------------------------------------------------------- + zetalt = max (zslt * rlmo,ztmin) + rlmo = zetalt / zslt + zetalu = zslu * rlmo + zetau = zu * rlmo + zetat = zt * rlmo + + if (ilech .eq. 0) then + if (rlmo .lt. 0.)then + xlu4 = 1. -16.* zetalu + xlt4 = 1. -16.* zetalt + xu4 = 1. -16.* zetau + xt4 = 1. -16.* zetat + xlu = sqrt (sqrt (xlu4)) + xlt = sqrt (sqrt (xlt4)) + xu = sqrt (sqrt (xu4)) + + xt = sqrt (sqrt (xt4)) + psmz = pspmu (xu) + simm = pspmu (xlu) - psmz + rlogu + pshz = psphu (xt) + simh = psphu (xlt) - pshz + rlogt + else + zetalu = min (zetalu,ztmax) + zetalt = min (zetalt,ztmax) + psmz = pspms (zetau) + simm = pspms (zetalu) - psmz + rlogu + pshz = psphs (zetat) + simh = psphs (zetalt) - pshz + rlogt + end if +! ---------------------------------------------------------------------- +! lech's functions +! ---------------------------------------------------------------------- + else + if (rlmo .lt. 0.)then + psmz = pslmu (zetau) + simm = pslmu (zetalu) - psmz + rlogu + pshz = pslhu (zetat) + simh = pslhu (zetalt) - pshz + rlogt + else + zetalu = min (zetalu,ztmax) + zetalt = min (zetalt,ztmax) + psmz = pslms (zetau) + simm = pslms (zetalu) - psmz + rlogu + pshz = pslhs (zetat) + simh = pslhs (zetalt) - pshz + rlogt + end if +! ---------------------------------------------------------------------- + end if + +! ---------------------------------------------------------------------- +! beljaars correction for ustar +! ---------------------------------------------------------------------- + ustar = max (sqrt (akms * sqrt (du2+ wstar2)),epsust) + +! zilitinkevitch fix for zt + zt = max(1.e-6,exp (zilfc * sqrt (ustar * z0))* z0) + zslt = zlm + zt +!----------------------------------------------------------------------- + rlogt = log (zslt / zt) + ustark = ustar * vkrm + akms = max (ustark / simm,cxch) +!----------------------------------------------------------------------- +! if statements to avoid tangent linear problems near zero +!----------------------------------------------------------------------- + akhs = max (ustark / simh,cxch) + + if (btgh * akhs * dthv .ne. 0.0) then + wstar2 = wwst2* abs (btgh * akhs * dthv)** (2./3.) + else + wstar2 = 0.0 + end if +!----------------------------------------------------------------------- + rlmn = elfc * akhs * dthv / ustar **3 +!----------------------------------------------------------------------- +! if(abs((rlmn-rlmo)/rlma).lt.epsit) go to 110 +!----------------------------------------------------------------------- + rlma = rlmo * wold+ rlmn * wnew +!----------------------------------------------------------------------- + rlmo = rlma + +! write(*,'(a20,10f15.6)')'sfcdif: rlmo=',rlmo,rlmn,elfc , akhs , dthv , ustar +! end do +! ---------------------------------------------------------------------- + end subroutine sfcdif2 + +!== begin esat ===================================================================================== + + subroutine esat(t, esw, esi, desw, desi) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + implicit none +!--------------------------------------------------------------------------------------------------- +! in + + real, intent(in) :: t !temperature + +!out + + real, intent(out) :: esw !saturation vapor pressure over water (pa) + real, intent(out) :: esi !saturation vapor pressure over ice (pa) + real, intent(out) :: desw !d(esat)/dt over water (pa/k) + real, intent(out) :: desi !d(esat)/dt over ice (pa/k) + +! local + + real :: a0,a1,a2,a3,a4,a5,a6 !coefficients for esat over water + real :: b0,b1,b2,b3,b4,b5,b6 !coefficients for esat over ice + real :: c0,c1,c2,c3,c4,c5,c6 !coefficients for dsat over water + real :: d0,d1,d2,d3,d4,d5,d6 !coefficients for dsat over ice + + parameter (a0=6.107799961 , a1=4.436518521e-01, & + a2=1.428945805e-02, a3=2.650648471e-04, & + a4=3.031240396e-06, a5=2.034080948e-08, & + a6=6.136820929e-11) + + parameter (b0=6.109177956 , b1=5.034698970e-01, & + b2=1.886013408e-02, b3=4.176223716e-04, & + b4=5.824720280e-06, b5=4.838803174e-08, & + b6=1.838826904e-10) + + parameter (c0= 4.438099984e-01, c1=2.857002636e-02, & + c2= 7.938054040e-04, c3=1.215215065e-05, & + c4= 1.036561403e-07, c5=3.532421810e-10, & + c6=-7.090244804e-13) + + parameter (d0=5.030305237e-01, d1=3.773255020e-02, & + d2=1.267995369e-03, d3=2.477563108e-05, & + d4=3.005693132e-07, d5=2.158542548e-09, & + d6=7.131097725e-12) + + esw = 100.*(a0+t*(a1+t*(a2+t*(a3+t*(a4+t*(a5+t*a6)))))) + esi = 100.*(b0+t*(b1+t*(b2+t*(b3+t*(b4+t*(b5+t*b6)))))) + desw = 100.*(c0+t*(c1+t*(c2+t*(c3+t*(c4+t*(c5+t*c6)))))) + desi = 100.*(d0+t*(d1+t*(d2+t*(d3+t*(d4+t*(d5+t*d6)))))) + + end subroutine esat + +!== begin stomata ================================================================================== + + subroutine stomata (parameters,vegtyp ,mpe ,apar ,foln ,iloc , jloc, & !in + tv ,ei ,ea ,sfctmp ,sfcprs , & !in + o2 ,co2 ,igs ,btran ,rb , & !in + rs ,psn ) !out +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation physiology type + + real, intent(in) :: igs !growing season index (0=off, 1=on) + real, intent(in) :: mpe !prevents division by zero errors + + real, intent(in) :: tv !foliage temperature (k) + real, intent(in) :: ei !vapor pressure inside leaf (sat vapor press at tv) (pa) + real, intent(in) :: ea !vapor pressure of canopy air (pa) + real, intent(in) :: apar !par absorbed per unit lai (w/m2) + real, intent(in) :: o2 !atmospheric o2 concentration (pa) + real, intent(in) :: co2 !atmospheric co2 concentration (pa) + real, intent(in) :: sfcprs !air pressure at reference height (pa) + real, intent(in) :: sfctmp !air temperature at reference height (k) + real, intent(in) :: btran !soil water transpiration factor (0 to 1) + real, intent(in) :: foln !foliage nitrogen concentration (%) + real, intent(in) :: rb !boundary layer resistance (s/m) + +! output + real, intent(out) :: rs !leaf stomatal resistance (s/m) + real, intent(out) :: psn !foliage photosynthesis (umol co2 /m2/ s) [always +] + +! in&out + real :: rlb !boundary layer resistance (s m2 / umol) +! --------------------------------------------------------------------------------------------- + +! ------------------------ local variables ---------------------------------------------------- + integer :: iter !iteration index + integer :: niter !number of iterations + + data niter /3/ + save niter + + real :: ab !used in statement functions + real :: bc !used in statement functions + real :: f1 !generic temperature response (statement function) + real :: f2 !generic temperature inhibition (statement function) + real :: tc !foliage temperature (degree celsius) + real :: cs !co2 concentration at leaf surface (pa) + real :: kc !co2 michaelis-menten constant (pa) + real :: ko !o2 michaelis-menten constant (pa) + real :: a,b,c,q !intermediate calculations for rs + real :: r1,r2 !roots for rs + real :: fnf !foliage nitrogen adjustment factor (0 to 1) + real :: ppf !absorb photosynthetic photon flux (umol photons/m2/s) + real :: wc !rubisco limited photosynthesis (umol co2/m2/s) + real :: wj !light limited photosynthesis (umol co2/m2/s) + real :: we !export limited photosynthesis (umol co2/m2/s) + real :: cp !co2 compensation point (pa) + real :: ci !internal co2 (pa) + real :: awc !intermediate calculation for wc + real :: vcmx !maximum rate of carbonylation (umol co2/m2/s) + real :: j !electron transport (umol co2/m2/s) + real :: cea !constrain ea or else model blows up + real :: cf !s m2/umol -> s/m + + f1(ab,bc) = ab**((bc-25.)/10.) + f2(ab) = 1. + exp((-2.2e05+710.*(ab+273.16))/(8.314*(ab+273.16))) + real :: t +! --------------------------------------------------------------------------------------------- + +! initialize rs=rsmax and psn=0 because will only do calculations +! for apar > 0, in which case rs <= rsmax and psn >= 0 + + cf = sfcprs/(8.314*sfctmp)*1.e06 + rs = 1./parameters%bp * cf + psn = 0. + + if (apar .le. 0.) return + + fnf = min( foln/max(mpe,parameters%folnmx), 1.0 ) + tc = tv-tfrz + ppf = 4.6*apar + j = ppf*parameters%qe25 + kc = parameters%kc25 * f1(parameters%akc,tc) + ko = parameters%ko25 * f1(parameters%ako,tc) + awc = kc * (1.+o2/ko) + cp = 0.5*kc/ko*o2*0.21 + vcmx = parameters%vcmx25 / f2(tc) * fnf * btran * f1(parameters%avcmx,tc) + +! first guess ci + + ci = 0.7*co2*parameters%c3psn + 0.4*co2*(1.-parameters%c3psn) + +! rb: s/m -> s m**2 / umol + + rlb = rb/cf + +! constrain ea + + cea = max(0.25*ei*parameters%c3psn+0.40*ei*(1.-parameters%c3psn), min(ea,ei) ) + +! ci iteration +!jref: c3psn is equal to 1 for all veg types. + do iter = 1, niter + wj = max(ci-cp,0.)*j/(ci+2.*cp)*parameters%c3psn + j*(1.-parameters%c3psn) + wc = max(ci-cp,0.)*vcmx/(ci+awc)*parameters%c3psn + vcmx*(1.-parameters%c3psn) + we = 0.5*vcmx*parameters%c3psn + 4000.*vcmx*ci/sfcprs*(1.-parameters%c3psn) + psn = min(wj,wc,we) * igs + + cs = max( co2-1.37*rlb*sfcprs*psn, mpe ) + a = parameters%mp*psn*sfcprs*cea / (cs*ei) + parameters%bp + b = ( parameters%mp*psn*sfcprs/cs + parameters%bp ) * rlb - 1. + c = -rlb + if (b .ge. 0.) then + q = -0.5*( b + sqrt(b*b-4.*a*c) ) + else + q = -0.5*( b - sqrt(b*b-4.*a*c) ) + end if + r1 = q/a + r2 = c/q + rs = max(r1,r2) + ci = max( cs-psn*sfcprs*1.65*rs, 0. ) + end do + +! rs, rb: s m**2 / umol -> s/m + + rs = rs*cf + + end subroutine stomata + +!== begin canres =================================================================================== + + subroutine canres (parameters,par ,sfctmp,rcsoil ,eah ,sfcprs , & !in + rc ,psn ,iloc ,jloc ) !out + +! -------------------------------------------------------------------------------------------------- +! calculate canopy resistance which depends on incoming solar radiation, +! air temperature, atmospheric water vapor pressure deficit at the +! lowest model level, and soil moisture (preferably unfrozen soil +! moisture rather than total) +! -------------------------------------------------------------------------------------------------- +! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin and +! noilhan (1990, blm). chen et al (1996, jgr, vol 101(d3), 7251-7268), +! eqns 12-14 and table 2 of sec. 3.1.2 +! -------------------------------------------------------------------------------------------------- +!niu use module_noahlsm_utility +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + real, intent(in) :: par !par absorbed per unit sunlit lai (w/m2) + real, intent(in) :: sfctmp !canopy air temperature + real, intent(in) :: sfcprs !surface pressure (pa) + real, intent(in) :: eah !water vapor pressure (pa) + real, intent(in) :: rcsoil !soil moisture stress factor + +!outputs + + real, intent(out) :: rc !canopy resistance per unit lai + real, intent(out) :: psn !foliage photosynthesis (umolco2/m2/s) + +!local + + real :: rcq + real :: rcs + real :: rct + real :: ff + real :: q2 !water vapor mixing ratio (kg/kg) + real :: q2sat !saturation q2 + real :: dqsdt2 !d(q2sat)/d(t) + +! rsmin, rsmax, topt, rgl, hs are canopy stress parameters set in redprm +! ---------------------------------------------------------------------- +! initialize canopy resistance multiplier terms. +! ---------------------------------------------------------------------- + rc = 0.0 + rcs = 0.0 + rct = 0.0 + rcq = 0.0 + +! compute q2 and q2sat + + q2 = 0.622 * eah / (sfcprs - 0.378 * eah) !specific humidity [kg/kg] + q2 = q2 / (1.0 + q2) !mixing ratio [kg/kg] + + call calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) + +! contribution due to incoming solar radiation + + ff = 2.0 * par / parameters%rgl + rcs = (ff + parameters%rsmin / parameters%rsmax) / (1.0+ ff) + rcs = max (rcs,0.0001) + +! contribution due to air temperature + + rct = 1.0- 0.0016* ( (parameters%topt - sfctmp)**2.0) + rct = max (rct,0.0001) + +! contribution due to vapor pressure deficit + + rcq = 1.0/ (1.0+ parameters%hs * max(0.,q2sat-q2)) + rcq = max (rcq,0.01) + +! determine canopy resistance due to all factors + + rc = parameters%rsmin / (rcs * rct * rcq * rcsoil) + psn = -999.99 ! psn not applied for dynamic carbon + + end subroutine canres + +!== begin calhum =================================================================================== + + subroutine calhum(parameters,sfctmp, sfcprs, q2sat, dqsdt2) + + implicit none + + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: sfctmp, sfcprs + real, intent(out) :: q2sat, dqsdt2 + real, parameter :: a2=17.67,a3=273.15,a4=29.65, elwv=2.501e6, & + a23m4=a2*(a3-a4), e0=0.611, rv=461.0, & + epsilon=0.622 + real :: es, sfcprsx + +! q2sat: saturated mixing ratio + es = e0 * exp ( elwv/rv*(1./a3 - 1./sfctmp) ) +! convert sfcprs from pa to kpa + sfcprsx = sfcprs*1.e-3 + q2sat = epsilon * es / (sfcprsx-es) +! convert from g/g to g/kg + q2sat = q2sat * 1.e3 +! q2sat is currently a 'mixing ratio' + +! dqsdt2 is calculated assuming q2sat is a specific humidity + dqsdt2=(q2sat/(1+q2sat))*a23m4/(sfctmp-a4)**2 + +! dg q2sat needs to be in g/g when returned for sflx + q2sat = q2sat / 1.e3 + + end subroutine calhum + +!== begin tsnosoi ================================================================================== + + subroutine tsnosoi (parameters,ice ,nsoil ,nsnow ,isnow ,ist , & !in + tbot ,zsnso ,ssoil ,df ,hcpct , & !in + sag ,dt ,snowh ,dzsnso , & !in + tg ,iloc ,jloc , & !in + stc ) !inout +! -------------------------------------------------------------------------------------------------- +! compute snow (up to 3l) and soil (4l) temperature. note that snow temperatures +! during melting season may exceed melting point (tfrz) but later in phasechange +! subroutine the snow temperatures are reset to tfrz for melting snow. +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: ice ! + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + integer, intent(in) :: ist !surface type + + real, intent(in) :: dt !time step (s) + real, intent(in) :: tbot ! + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, intent(in) :: sag !solar rad. absorbed by ground (w/m2) + real, intent(in) :: snowh !snow depth (m) + real, intent(in) :: tg !ground temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !layer-bot. depth from snow surf.(m) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +!input and output + + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +!local + + integer :: iz + real :: zbotsno !zbot from snow surface + real, dimension(-nsnow+1:nsoil) :: ai, bi, ci, rhsts + real :: eflxb !energy influx from soil bottom (w/m2) + real, dimension(-nsnow+1:nsoil) :: phi !light through water (w/m2) + + real, dimension(-nsnow+1:nsoil) :: tbeg + real :: err_est !heat storage error (w/m2) + real :: ssoil2 !ground heat flux (w/m2) (for energy check) + real :: eflxb2 !heat flux from the bottom (w/m2) (for energy check) + character(len=256) :: message +! ---------------------------------------------------------------------- +! compute solar penetration through water, needs more work + + phi(isnow+1:nsoil) = 0. + +! adjust zbot from soil surface to zbotsno from snow surface + + zbotsno = parameters%zbot - snowh !from snow surface + +! snow/soil heat storage for energy balance check + + do iz = isnow+1, nsoil + tbeg(iz) = stc(iz) + enddo + +! compute soil temperatures + + call hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbotsno ,dt , & + df ,hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + eflxb ) + + call hstep (parameters,nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) + +! update ground heat flux just for energy check, but not for final output +! otherwise, it would break the surface energy balance + + if(opt_tbot == 1) then + eflxb2 = 0. + else if(opt_tbot == 2) then + eflxb2 = df(nsoil)*(tbot-stc(nsoil)) / & + (0.5*(zsnso(nsoil-1)+zsnso(nsoil)) - zbotsno) + end if + + ! skip the energy balance check for now, until we can make it work + ! right for small time steps. + return + +! energy balance check + + err_est = 0.0 + do iz = isnow+1, nsoil + err_est = err_est + (stc(iz)-tbeg(iz)) * dzsnso(iz) * hcpct(iz) / dt + enddo + + if (opt_stc == 1) then ! semi-implicit + err_est = err_est - (ssoil +eflxb) + else ! full-implicit + ssoil2 = df(isnow+1)*(tg-stc(isnow+1))/(0.5*dzsnso(isnow+1)) !m. barlage + err_est = err_est - (ssoil2+eflxb2) + endif + + if (abs(err_est) > 1.) then ! w/m2 + write(message,*) 'tsnosoi is losing(-)/gaining(+) false energy',err_est,' w/m2' + call wrf_message(trim(message)) + write(message,'(i6,1x,i6,1x,i3,f18.13,5f20.12)') & + iloc, jloc, ist,err_est,ssoil,snowh,tg,stc(isnow+1),eflxb + call wrf_message(trim(message)) + !niu stop + end if + + end subroutine tsnosoi + +!== begin hrt ====================================================================================== + + subroutine hrt (parameters,nsnow ,nsoil ,isnow ,zsnso , & + stc ,tbot ,zbot ,dt , & + df ,hcpct ,ssoil ,phi , & + ai ,bi ,ci ,rhsts , & + botflx ) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no of soil layers (4) + integer, intent(in) :: nsnow !maximum no of snow layers (3) + integer, intent(in) :: isnow !actual no of snow layers + real, intent(in) :: tbot !bottom soil temp. at zbot (k) + real, intent(in) :: zbot !depth of lower boundary condition (m) + !from soil surface not snow surface + real, intent(in) :: dt !time step (s) + real, intent(in) :: ssoil !ground heat flux (w/m2) + real, dimension(-nsnow+1:nsoil), intent(in) :: zsnso !depth of layer-bottom of snow/soil (m) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + real, dimension(-nsnow+1:nsoil), intent(in) :: df !thermal conductivity [w/m/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity [j/m3/k] + real, dimension(-nsnow+1:nsoil), intent(in) :: phi !light through water (w/m2) + +! output + + real, dimension(-nsnow+1:nsoil), intent(out) :: rhsts !right-hand side of the matrix + real, dimension(-nsnow+1:nsoil), intent(out) :: ai !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: bi !left-hand side coefficient + real, dimension(-nsnow+1:nsoil), intent(out) :: ci !left-hand side coefficient + real, intent(out) :: botflx !energy influx from soil bottom (w/m2) + +! local + + integer :: k + real, dimension(-nsnow+1:nsoil) :: ddz + real, dimension(-nsnow+1:nsoil) :: dz + real, dimension(-nsnow+1:nsoil) :: denom + real, dimension(-nsnow+1:nsoil) :: dtsdz + real, dimension(-nsnow+1:nsoil) :: eflux + real :: temp1 +! ---------------------------------------------------------------------- + + do k = isnow+1, nsoil + if (k == isnow+1) then + denom(k) = - zsnso(k) * hcpct(k) + temp1 = - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = df(k) * dtsdz(k) - ssoil - phi(k) + else if (k < nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k+1) + ddz(k) = 2.0 / temp1 + dtsdz(k) = 2.0 * (stc(k) - stc(k+1)) / temp1 + eflux(k) = (df(k)*dtsdz(k) - df(k-1)*dtsdz(k-1)) - phi(k) + else if (k == nsoil) then + denom(k) = (zsnso(k-1) - zsnso(k)) * hcpct(k) + temp1 = zsnso(k-1) - zsnso(k) + if(opt_tbot == 1) then + botflx = 0. + end if + if(opt_tbot == 2) then + dtsdz(k) = (stc(k) - tbot) / ( 0.5*(zsnso(k-1)+zsnso(k)) - zbot) + botflx = -df(k) * dtsdz(k) + end if + eflux(k) = (-botflx - df(k-1)*dtsdz(k-1) ) - phi(k) + end if + end do + + do k = isnow+1, nsoil + if (k == isnow+1) then + ai(k) = 0.0 + ci(k) = - df(k) * ddz(k) / denom(k) + if (opt_stc == 1) then + bi(k) = - ci(k) + end if + if (opt_stc == 2) then + bi(k) = - ci(k) + df(k)/(0.5*zsnso(k)*zsnso(k)*hcpct(k)) + end if + else if (k < nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = - df(k ) * ddz(k ) / denom(k) + bi(k) = - (ai(k) + ci (k)) + else if (k == nsoil) then + ai(k) = - df(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - (ai(k) + ci(k)) + end if + rhsts(k) = eflux(k)/ (-denom(k)) + end do + + end subroutine hrt + +!== begin hstep ==================================================================================== + + subroutine hstep (parameters,nsnow ,nsoil ,isnow ,dt , & + ai ,bi ,ci ,rhsts , & + stc ) +! ---------------------------------------------------------------------- +! calculate/update the soil temperature field. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil + integer, intent(in) :: nsnow + integer, intent(in) :: isnow + real, intent(in) :: dt + +! output & input + real, dimension(-nsnow+1:nsoil), intent(inout) :: rhsts + real, dimension(-nsnow+1:nsoil), intent(inout) :: ai + real, dimension(-nsnow+1:nsoil), intent(inout) :: bi + real, dimension(-nsnow+1:nsoil), intent(inout) :: ci + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc + +! local + integer :: k + real, dimension(-nsnow+1:nsoil) :: rhstsin + real, dimension(-nsnow+1:nsoil) :: ciin +! ---------------------------------------------------------------------- + + do k = isnow+1,nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + end do + + +! copy values for input variables before call to rosr12 + + do k = isnow+1,nsoil + rhstsin(k) = rhsts(k) + ciin(k) = ci(k) + end do + +! solve the tri-diagonal matrix equation + + + call rosr12 (ci,ai,bi,ciin,rhstsin,rhsts,isnow+1,nsoil,nsnow) + +! update snow & soil temperature + + do k = isnow+1,nsoil + stc (k) = stc (k) + ci (k) + end do + + end subroutine hstep + +!== begin rosr12 =================================================================================== + + subroutine rosr12 (p,a,b,c,d,delta,ntop,nsoil,nsnow) +! ---------------------------------------------------------------------- +! subroutine rosr12 +! ---------------------------------------------------------------------- +! invert (solve) the tri-diagonal matrix problem shown below: +! ### ### ### ### ### ### +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) # +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) # +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)# +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)# +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + implicit none + + integer, intent(in) :: ntop + integer, intent(in) :: nsoil,nsnow + integer :: k, kk + + real, dimension(-nsnow+1:nsoil),intent(in):: a, b, d + real, dimension(-nsnow+1:nsoil),intent(inout):: c,p,delta + +! ---------------------------------------------------------------------- +! initialize eqn coef c for the lowest soil layer +! ---------------------------------------------------------------------- + c (nsoil) = 0.0 + p (ntop) = - c (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for the 1st soil layer +! ---------------------------------------------------------------------- + delta (ntop) = d (ntop) / b (ntop) +! ---------------------------------------------------------------------- +! solve the coefs for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + p (k) = - c (k) * ( 1.0 / (b (k) + a (k) * p (k -1)) ) + delta (k) = (d (k) - a (k)* delta (k -1))* (1.0/ (b (k) + a (k)& + * p (k -1))) + end do +! ---------------------------------------------------------------------- +! set p to delta for lowest soil layer +! ---------------------------------------------------------------------- + p (nsoil) = delta (nsoil) +! ---------------------------------------------------------------------- +! adjust p for soil layers 2 thru nsoil +! ---------------------------------------------------------------------- + do k = ntop+1,nsoil + kk = nsoil - k + (ntop-1) + 1 + p (kk) = p (kk) * p (kk +1) + delta (kk) + end do +! ---------------------------------------------------------------------- + end subroutine rosr12 + +!== begin phasechange ============================================================================== + + subroutine phasechange (parameters,nsnow ,nsoil ,isnow ,dt ,fact , & !in + dzsnso ,hcpct ,ist ,iloc ,jloc , & !in + stc ,snice ,snliq ,sneqv ,snowh , & !inout + smc ,sh2o , & !inout + qmelt ,imelt ,ponding ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers [=3] + integer, intent(in) :: nsoil !no. of soil layers [=4] + integer, intent(in) :: isnow !actual no. of snow layers [<=3] + integer, intent(in) :: ist !surface type: 1->soil; 2->lake + real, intent(in) :: dt !land model time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: fact !temporary + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: hcpct !heat capacity (j/m3/k) + +! outputs + integer, dimension(-nsnow+1:nsoil), intent(out) :: imelt !phase change index + real, intent(out) :: qmelt !snowmelt rate [mm/s] + real, intent(out) :: ponding!snowmelt when snow has no layer [mm] + +! inputs and outputs + + real, intent(inout) :: sneqv + real, intent(inout) :: snowh + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water [m3/m3] + real, dimension(-nsnow+1:0) , intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0) , intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: j !do loop index + real, dimension(-nsnow+1:nsoil) :: hm !energy residual [w/m2] + real, dimension(-nsnow+1:nsoil) :: xm !melting or freezing water [kg/m2] + real, dimension(-nsnow+1:nsoil) :: wmass0 + real, dimension(-nsnow+1:nsoil) :: wice0 + real, dimension(-nsnow+1:nsoil) :: wliq0 + real, dimension(-nsnow+1:nsoil) :: mice !soil/snow ice mass [mm] + real, dimension(-nsnow+1:nsoil) :: mliq !soil/snow liquid water mass [mm] + real, dimension(-nsnow+1:nsoil) :: supercool !supercooled water in soil (kg/m2) + real :: heatr !energy residual or loss after melting/freezing + real :: temp1 !temporary variables [kg/m2] + real :: propor + real :: smp !frozen water potential (mm) + real :: xmf !total latent heat of phase change + +! ---------------------------------------------------------------------- +! initialization + + qmelt = 0. + ponding = 0. + xmf = 0. + + do j = -nsnow+1, nsoil + supercool(j) = 0.0 + end do + + do j = isnow+1,0 ! all layers + mice(j) = snice(j) + mliq(j) = snliq(j) + end do + + do j = 1, nsoil ! soil + mliq(j) = sh2o(j) * dzsnso(j) * 1000. + mice(j) = (smc(j) - sh2o(j)) * dzsnso(j) * 1000. + end do + + do j = isnow+1,nsoil ! all layers + imelt(j) = 0 + hm(j) = 0. + xm(j) = 0. + wice0(j) = mice(j) + wliq0(j) = mliq(j) + wmass0(j) = mice(j) + mliq(j) + enddo + + if(ist == 1) then + do j = 1,nsoil + if (opt_frz == 1) then + if(stc(j) < tfrz) then + smp = hfus*(tfrz-stc(j))/(grav*stc(j)) !(m) + supercool(j) = parameters%smcmax*(smp/parameters%psisat)**(-1./parameters%bexp) + supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) + end if + end if + if (opt_frz == 2) then + call frh2o (parameters,supercool(j),stc(j),smc(j),sh2o(j)) + supercool(j) = supercool(j)*dzsnso(j)*1000. !(mm) + end if + enddo + end if + + do j = isnow+1,nsoil + if (mice(j) > 0. .and. stc(j) >= tfrz) then !melting + imelt(j) = 1 + endif + if (mliq(j) > supercool(j) .and. stc(j) < tfrz) then + imelt(j) = 2 + endif + + ! if snow exists, but its thickness is not enough to create a layer + if (isnow == 0 .and. sneqv > 0. .and. j == 1) then + if (stc(j) >= tfrz) then + imelt(j) = 1 + endif + endif + enddo + +! calculate the energy surplus and loss for melting and freezing + + do j = isnow+1,nsoil + if (imelt(j) > 0) then + hm(j) = (stc(j)-tfrz)/fact(j) + stc(j) = tfrz + endif + + if (imelt(j) == 1 .and. hm(j) < 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + if (imelt(j) == 2 .and. hm(j) > 0.) then + hm(j) = 0. + imelt(j) = 0 + endif + xm(j) = hm(j)*dt/hfus + enddo + +! the rate of melting and freezing for snow without a layer, needs more work. + + if (isnow == 0 .and. sneqv > 0. .and. xm(1) > 0.) then + temp1 = sneqv + sneqv = max(0.,temp1-xm(1)) + propor = sneqv/temp1 + snowh = max(0.,propor * snowh) + heatr = hm(1) - hfus*(temp1-sneqv)/dt + if (heatr > 0.) then + xm(1) = heatr*dt/hfus + hm(1) = heatr + else + xm(1) = 0. + hm(1) = 0. + endif + qmelt = max(0.,(temp1-sneqv))/dt + xmf = hfus*qmelt + ponding = temp1-sneqv + endif + +! the rate of melting and freezing for snow and soil + + do j = isnow+1,nsoil + if (imelt(j) > 0 .and. abs(hm(j)) > 0.) then + + heatr = 0. + if (xm(j) > 0.) then + mice(j) = max(0., wice0(j)-xm(j)) + heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt + else if (xm(j) < 0.) then + if (j <= 0) then ! snow + mice(j) = min(wmass0(j), wice0(j)-xm(j)) + else ! soil + if (wmass0(j) < supercool(j)) then + mice(j) = 0. + else + mice(j) = min(wmass0(j) - supercool(j),wice0(j)-xm(j)) + mice(j) = max(mice(j),0.0) + endif + endif + heatr = hm(j) - hfus*(wice0(j)-mice(j))/dt + endif + + mliq(j) = max(0.,wmass0(j)-mice(j)) + + if (abs(heatr) > 0.) then + stc(j) = stc(j) + fact(j)*heatr + if (j <= 0) then ! snow + if (mliq(j)*mice(j)>0.) stc(j) = tfrz + end if + endif + + xmf = xmf + hfus * (wice0(j)-mice(j))/dt + + if (j < 1) then + qmelt = qmelt + max(0.,(wice0(j)-mice(j)))/dt + endif + endif + enddo + + do j = isnow+1,0 ! snow + snliq(j) = mliq(j) + snice(j) = mice(j) + end do + + do j = 1, nsoil ! soil + sh2o(j) = mliq(j) / (1000. * dzsnso(j)) + smc(j) = (mliq(j) + mice(j)) / (1000. * dzsnso(j)) + end do + + end subroutine phasechange + +!== begin frh2o ==================================================================================== + + subroutine frh2o (parameters,free,tkelv,smc,sh2o) + +! ---------------------------------------------------------------------- +! subroutine frh2o +! ---------------------------------------------------------------------- +! calculate amount of supercooled liquid soil water content if +! temperature is below 273.15k (tfrz). requires newton-type iteration +! to solve the nonlinear implicit equation given in eqn 17 of koren et al +! (1999, jgr, vol 104(d16), 19569-19585). +! ---------------------------------------------------------------------- +! new version (june 2001): much faster and more accurate newton +! iteration achieved by first taking log of eqn cited above -- less than +! 4 (typically 1 or 2) iterations achieves convergence. also, explicit +! 1-step solution option for special case of parameter ck=0, which +! reduces the original implicit equation to a simpler explicit form, +! known as the "flerchinger eqn". improved handling of solution in the +! limit of freezing point temperature tfrz. +! ---------------------------------------------------------------------- +! input: + +! tkelv.........temperature (kelvin) +! smc...........total soil moisture content (volumetric) +! sh2o..........liquid soil moisture content (volumetric) +! b.............soil type "b" parameter (from redprm) +! psisat........saturated soil matric potential (from redprm) + +! output: +! free..........supercooled liquid water content [m3/m3] +! ---------------------------------------------------------------------- + implicit none + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: sh2o,smc,tkelv + real, intent(out) :: free + real :: bx,denom,df,dswl,fk,swl,swlk + integer :: nlog,kcount +! parameter(ck = 0.0) + real, parameter :: ck = 8.0, blim = 5.5, error = 0.005, & + dice = 920.0 + character(len=80) :: message + +! ---------------------------------------------------------------------- +! limits on parameter b: b < 5.5 (use parameter blim) +! simulations showed if b > 5.5 unfrozen water content is +! non-realistically high at very low temperatures. +! ---------------------------------------------------------------------- + bx = parameters%bexp +! ---------------------------------------------------------------------- +! initializing iterations counter and iterative solution flag. +! ---------------------------------------------------------------------- + + if (parameters%bexp > blim) bx = blim + nlog = 0 + +! ---------------------------------------------------------------------- +! if temperature not significantly below freezing (tfrz), sh2o = smc +! ---------------------------------------------------------------------- + kcount = 0 + if (tkelv > (tfrz- 1.e-3)) then + free = smc + else + +! ---------------------------------------------------------------------- +! option 1: iterated solution in koren et al, jgr, 1999, eqn 17 +! ---------------------------------------------------------------------- +! initial guess for swl (frozen content) +! ---------------------------------------------------------------------- + if (ck /= 0.0) then + swl = smc - sh2o +! ---------------------------------------------------------------------- +! keep within bounds. +! ---------------------------------------------------------------------- + if (swl > (smc -0.02)) swl = smc -0.02 +! ---------------------------------------------------------------------- +! start of iterations +! ---------------------------------------------------------------------- + if (swl < 0.) swl = 0. +1001 continue + if (.not.( (nlog < 10) .and. (kcount == 0))) goto 1002 + nlog = nlog +1 + df = alog ( ( parameters%psisat * grav / hfus ) * ( ( 1. + ck * swl )**2.) * & + ( parameters%smcmax / (smc - swl) )** bx) - alog ( - ( & + tkelv - tfrz)/ tkelv) + denom = 2. * ck / ( 1. + ck * swl ) + bx / ( smc - swl ) + swlk = swl - df / denom +! ---------------------------------------------------------------------- +! bounds useful for mathematical solution. +! ---------------------------------------------------------------------- + if (swlk > (smc -0.02)) swlk = smc - 0.02 + if (swlk < 0.) swlk = 0. + +! ---------------------------------------------------------------------- +! mathematical solution bounds applied. +! ---------------------------------------------------------------------- + dswl = abs (swlk - swl) +! if more than 10 iterations, use explicit method (ck=0 approx.) +! when dswl less or eq. error, no more iterations required. +! ---------------------------------------------------------------------- + swl = swlk + if ( dswl <= error ) then + kcount = kcount +1 + end if +! ---------------------------------------------------------------------- +! end of iterations +! ---------------------------------------------------------------------- +! bounds applied within do-block are valid for physical solution. +! ---------------------------------------------------------------------- + goto 1001 +1002 continue + free = smc - swl + end if +! ---------------------------------------------------------------------- +! end option 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! option 2: explicit solution for flerchinger eq. i.e. ck=0 +! in koren et al., jgr, 1999, eqn 17 +! apply physical bounds to flerchinger solution +! ---------------------------------------------------------------------- + if (kcount == 0) then + write(message, '("flerchinger used in new version. iterations=", i6)') nlog + call wrf_message(trim(message)) + fk = ( ( (hfus / (grav * ( - parameters%psisat)))* & + ( (tkelv - tfrz)/ tkelv))** ( -1/ bx))* parameters%smcmax + if (fk < 0.02) fk = 0.02 + free = min (fk, smc) +! ---------------------------------------------------------------------- +! end option 2 +! ---------------------------------------------------------------------- + end if + end if +! ---------------------------------------------------------------------- + end subroutine frh2o +! ---------------------------------------------------------------------- +! ================================================================================================== +! **********************end of energy subroutines*********************** +! ================================================================================================== + +!== begin water ==================================================================================== + + subroutine water (parameters,vegtyp ,nsnow ,nsoil ,imelt ,dt ,uu , & !in + vv ,fcev ,fctr ,qprecc ,qprecl ,elai , & !in + esai ,sfctmp ,qvap ,qdew ,zsoil ,btrani , & !in + ficeold,ponding,tg ,ist ,fveg ,iloc ,jloc ,smceq , & !in + bdfall ,fp ,rain ,snow, & !in mb/an: v3.7 + qsnow ,qrain ,snowhin,latheav,latheag,frozen_canopy,frozen_ground, & !in mb + isnow ,canliq ,canice ,tv ,snowh ,sneqv , & !inout + snice ,snliq ,stc ,zsnso ,sh2o ,smc , & !inout + sice ,zwt ,wa ,wt ,dzsnso ,wslake , & !inout + smcwtd ,deeprech,rech , & !inout + cmc ,ecan ,etran ,fwet ,runsrf ,runsub , & !out + qin ,qdis ,ponding1 ,ponding2, & + qsnbot ,esnow) +! ---------------------------------------------------------------------- +! code history: +! initial code: guo-yue niu, oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: vegtyp !vegetation type + integer, intent(in) :: nsnow !maximum no. of snow layers + integer , intent(in) :: ist !surface type 1-soil; 2-lake + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [1-melt; 2-freeze] + real, intent(in) :: dt !main time step (s) + real, intent(in) :: uu !u-direction wind speed [m/s] + real, intent(in) :: vv !v-direction wind speed [m/s] + real, intent(in) :: fcev !canopy evaporation (w/m2) [+ to atm ] + real, intent(in) :: fctr !transpiration (w/m2) [+ to atm] + real, intent(in) :: qprecc !convective precipitation (mm/s) + real, intent(in) :: qprecl !large-scale precipitation (mm/s) + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: qvap !soil surface evaporation rate[mm/s] + real, intent(in) :: qdew !soil surface dew rate[mm/s] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, dimension( 1:nsoil), intent(in) :: btrani !soil water stress factor (0 to 1) + real, dimension(-nsnow+1: 0), intent(in) :: ficeold !ice fraction at last timestep +! real , intent(in) :: ponding ![mm] + real , intent(in) :: tg !ground temperature (k) + real , intent(in) :: fveg !greeness vegetation fraction (-) + real , intent(in) :: bdfall !bulk density of snowfall (kg/m3) ! mb/an: v3.7 + real , intent(in) :: fp !fraction of the gridcell that receives precipitation ! mb/an: v3.7 + real , intent(in) :: rain !rainfall (mm/s) ! mb/an: v3.7 + real , intent(in) :: snow !snowfall (mm/s) ! mb/an: v3.7 + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) + real , intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real , intent(in) :: qrain !rain at ground srf (mm) [+] + real , intent(in) :: snowhin !snow depth increasing rate (m/s) + +! input/output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + real, intent(inout) :: tv !vegetation temperature (k) + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow/soil layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !depth of snow/soil layer-bottom + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice content [m3/m3] + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: zwt !the depth to water table [m] + real, intent(inout) :: wa !water storage in aquifer [mm] + real, intent(inout) :: wt !water storage in aquifer + !+ stuarated soil [mm] + real, intent(inout) :: wslake !water storage in lake (can be -) (mm) + real , intent(inout) :: ponding ![mm] + real, intent(inout) :: smcwtd !soil water content between bottom of the soil and water table [m3/m3] + real, intent(inout) :: deeprech !recharge to or from the water table when deep [m] + real, intent(inout) :: rech !recharge to or from the water table when shallow [m] (diagnostic) + +! output + real, intent(out) :: cmc !intercepted water per ground area (mm) + real, intent(out) :: ecan !evap of intercepted water (mm/s) [+] + real, intent(out) :: etran !transpiration rate (mm/s) [+] + real, intent(out) :: fwet !wetted/snowed fraction of canopy (-) + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !baseflow (sturation excess) [mm/s] + real, intent(out) :: qin !groundwater recharge [mm/s] + real, intent(out) :: qdis !groundwater discharge [mm/s] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + real, intent(out) :: esnow + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real , intent(in) :: latheav !latent heat vap./sublimation (j/kg) + real , intent(in) :: latheag !latent heat vap./sublimation (j/kg) + logical , intent(in) :: frozen_ground ! used to define latent heat pathway + logical , intent(in) :: frozen_canopy ! used to define latent heat pathway + + +! local + integer :: iz + real :: qinsur !water input on soil surface [m/s] + real :: qseva !soil surface evap rate [mm/s] + real :: qsdew !soil surface dew rate [mm/s] + real :: qsnfro !snow surface frost rate[mm/s] + real :: qsnsub !snow surface sublimation rate [mm/s] + real, dimension( 1:nsoil) :: etrani !transpiration rate (mm/s) [+] + real, dimension( 1:nsoil) :: wcnd !hydraulic conductivity (m/s) + real :: qdrain !soil-bottom free drainage [mm/s] + real :: snoflow !glacier flow [mm/s] + real :: fcrmax !maximum of fcr (-) + + real, parameter :: wslmax = 5000. !maximum lake water storage (mm) + + +! ---------------------------------------------------------------------- +! initialize + + etrani(1:nsoil) = 0. + snoflow = 0. + runsub = 0. + qinsur = 0. + +! canopy-intercepted snowfall/rainfall, drips, and throughfall + + call canwater (parameters,vegtyp ,dt , & !in + fcev ,fctr ,elai , & !in + esai ,tg ,fveg ,iloc , jloc, & !in + bdfall ,frozen_canopy , & !in + canliq ,canice ,tv , & !inout + cmc ,ecan ,etran , & !out + fwet ) !out + +! sublimation, frost, evaporation, and dew + + qsnsub = 0. + if (sneqv > 0.) then + qsnsub = min(qvap, sneqv/dt) + endif + qseva = qvap-qsnsub + esnow = qsnsub*2.83e+6 + + qsnfro = 0. + if (sneqv > 0.) then + qsnfro = qdew + endif + qsdew = qdew - qsnfro + + call snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in + & sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in + & qrain ,ficeold,iloc ,jloc , & !in + & isnow ,snowh ,sneqv ,snice ,snliq , & !inout + & sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout + & qsnbot ,snoflow,ponding1 ,ponding2) !out + + if(frozen_ground) then + sice(1) = sice(1) + (qsdew-qseva)*dt/(dzsnso(1)*1000.) + qsdew = 0.0 + qseva = 0.0 + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + +! convert units (mm/s -> m/s) + + !ponding: melting water from snow when there is no layer + qinsur = (ponding+ponding1+ponding2)/dt * 0.001 +! qinsur = ponding/dt * 0.001 + + if(isnow == 0) then + qinsur = qinsur+(qsnbot + qsdew + qrain) * 0.001 + else + qinsur = qinsur+(qsnbot + qsdew) * 0.001 + endif + + qseva = qseva * 0.001 + + do iz = 1, parameters%nroot + etrani(iz) = etran * btrani(iz) * 0.001 + enddo + + +! lake/soil water balances + + if (ist == 2) then ! lake + runsrf = 0. + if(wslake >= wslmax) runsrf = qinsur*1000. !mm/s + wslake = wslake + (qinsur-qseva)*1000.*dt -runsrf*dt !mm + else ! soil + call soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + qinsur ,qseva ,etrani ,sice ,iloc , jloc , & !in + sh2o ,smc ,zwt ,vegtyp , & !inout + smcwtd, deeprech , & !inout + runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out + + if(opt_run == 1) then + call groundwater (parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in + stc ,wcnd ,fcrmax ,iloc ,jloc , & !in + sh2o ,zwt ,wa ,wt , & !inout + qin ,qdis ) !out + runsub = qdis !mm/s + end if + + if(opt_run == 3 .or. opt_run == 4) then + runsub = runsub + qdrain !mm/s + end if + + do iz = 1,nsoil + smc(iz) = sh2o(iz) + sice(iz) + enddo + + if(opt_run == 5) then + call shallowwatertable (parameters,nsnow ,nsoil, zsoil, dt , & !in + dzsnso ,smceq ,iloc , jloc , & !in + smc ,zwt ,smcwtd ,rech, qdrain ) !inout + + sh2o(nsoil) = smc(nsoil) - sice(nsoil) + runsub = runsub + qdrain !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here + wa = 0. + endif + + endif + + runsub = runsub + snoflow !mm/s + + end subroutine water + +!== begin canwater ================================================================================= + + subroutine canwater (parameters,vegtyp ,dt , & !in + fcev ,fctr ,elai , & !in + esai ,tg ,fveg ,iloc , jloc , & !in + bdfall ,frozen_canopy , & !in + canliq ,canice ,tv , & !inout + cmc ,ecan ,etran , & !out + fwet ) !out + +! ------------------------ code history ------------------------------ +! canopy hydrology +! -------------------------------------------------------------------- + implicit none +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer,intent(in) :: iloc !grid index + integer,intent(in) :: jloc !grid index + integer,intent(in) :: vegtyp !vegetation type + real, intent(in) :: dt !main time step (s) + real, intent(in) :: fcev !canopy evaporation (w/m2) [+ = to atm] + real, intent(in) :: fctr !transpiration (w/m2) [+ = to atm] + real, intent(in) :: elai !leaf area index, after burying by snow + real, intent(in) :: esai !stem area index, after burying by snow + real, intent(in) :: tg !ground temperature (k) + real, intent(in) :: fveg !greeness vegetation fraction (-) + logical , intent(in) :: frozen_canopy ! used to define latent heat pathway + real , intent(in) :: bdfall !bulk density of snowfall (kg/m3) ! mb/an: v3.7 + +! input & output + real, intent(inout) :: canliq !intercepted liquid water (mm) + real, intent(inout) :: canice !intercepted ice mass (mm) + real, intent(inout) :: tv !vegetation temperature (k) + +! output + real, intent(out) :: cmc !intercepted water (mm) + real, intent(out) :: ecan !evaporation of intercepted water (mm/s) [+] + real, intent(out) :: etran !transpiration rate (mm/s) [+] + real, intent(out) :: fwet !wetted or snowed fraction of the canopy (-) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + real :: maxsno !canopy capacity for snow interception (mm) + real :: maxliq !canopy capacity for rain interception (mm) + real :: qevac !evaporation rate (mm/s) + real :: qdewc !dew rate (mm/s) + real :: qfroc !frost rate (mm/s) + real :: qsubc !sublimation rate (mm/s) + real :: qmeltc !melting rate of canopy snow (mm/s) + real :: qfrzc !refreezing rate of canopy liquid water (mm/s) + real :: canmas !total canopy mass (kg/m2) +! -------------------------------------------------------------------- +! initialization + + ecan = 0.0 + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + maxliq = parameters%ch2op * (elai+ esai) + +! evaporation, transpiration, and dew + + if (.not.frozen_canopy) then ! barlage: change to frozen_canopy + etran = max( fctr/hvap, 0. ) + qevac = max( fcev/hvap, 0. ) + qdewc = abs( min( fcev/hvap, 0. ) ) + qsubc = 0. + qfroc = 0. + else + etran = max( fctr/hsub, 0. ) + qevac = 0. + qdewc = 0. + qsubc = max( fcev/hsub, 0. ) + qfroc = abs( min( fcev/hsub, 0. ) ) + endif + +! canopy water balance. for convenience allow dew to bring canliq above +! maxh2o or else would have to re-adjust drip + + qevac = min(canliq/dt,qevac) + canliq=max(0.,canliq+(qdewc-qevac)*dt) + if(canliq <= 1.e-06) canliq = 0.0 + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + maxsno = 6.6*(0.27+46./bdfall) * (elai+ esai) + + qsubc = min(canice/dt,qsubc) + canice= max(0.,canice + (qfroc-qsubc)*dt) + if(canice.le.1.e-6) canice = 0. + +! wetted fraction of canopy + + if(canice.gt.0.) then + fwet = max(0.,canice) / max(maxsno,1.e-06) + else + fwet = max(0.,canliq) / max(maxliq,1.e-06) + endif + fwet = min(fwet, 1.) ** 0.667 + +! phase change + + qmeltc = 0. + qfrzc = 0. + + if(canice.gt.1.e-6.and.tv.gt.tfrz) then + qmeltc = min(canice/dt,(tv-tfrz)*cice*canice/denice/(dt*hfus)) + canice = max(0.,canice - qmeltc*dt) + canliq = max(0.,canliq + qmeltc*dt) + tv = fwet*tfrz + (1.-fwet)*tv + endif + + if(canliq.gt.1.e-6.and.tv.lt.tfrz) then + qfrzc = min(canliq/dt,(tfrz-tv)*cwat*canliq/denh2o/(dt*hfus)) + canliq = max(0.,canliq - qfrzc*dt) + canice = max(0.,canice + qfrzc*dt) + tv = fwet*tfrz + (1.-fwet)*tv + endif + +! total canopy water + + cmc = canliq + canice + +! total canopy evaporation + + ecan = qevac + qsubc - qdewc - qfroc + + end subroutine canwater + +!== begin snowwater ================================================================================ + + subroutine snowwater (parameters,nsnow ,nsoil ,imelt ,dt ,zsoil , & !in + sfctmp ,snowhin,qsnow ,qsnfro ,qsnsub , & !in + qrain ,ficeold,iloc ,jloc , & !in + isnow ,snowh ,sneqv ,snice ,snliq , & !inout + sh2o ,sice ,stc ,zsnso ,dzsnso , & !inout + qsnbot ,snoflow,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (s) + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, intent(in) :: sfctmp !surface air temperature [k] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + real, dimension(-nsnow+1:0) , intent(in) :: ficeold!ice fraction at last timestep + +! input & output + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso !depth of snow/soil layer-bottom + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !snow/soil layer thickness [m] + +! output + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + real, intent(out) :: snoflow!glacier flow [mm] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local + integer :: iz,i + real :: bdsnow !bulk density of snow (kg/m3) +! ---------------------------------------------------------------------- + snoflow = 0.0 + ponding1 = 0.0 + ponding2 = 0.0 + + call snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin, & !in + sfctmp ,iloc ,jloc , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout + +! mb: do each if block separately + + if(isnow < 0) & ! when multi-layer + call compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,zsoil ,imelt ,ficeold,iloc , jloc ,& !in + isnow ,dzsnso ,zsnso ) !inout + + if(isnow < 0) & !when multi-layer + call combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out + + if(isnow < 0) & !when multi-layer + call divide (parameters,nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout + + call snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain ,iloc ,jloc , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + qsnbot ,ponding1 ,ponding2) !out + +!set empty snow layers to zero + + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo + +!to obtain equilibrium state of snow in glacier region + + if(sneqv > 2000.) then ! 2000 mm -> maximum water depth + bdsnow = snice(0) / dzsnso(0) + snoflow = (sneqv - 2000.) + snice(0) = snice(0) - snoflow + dzsnso(0) = dzsnso(0) - snoflow/bdsnow + snoflow = snoflow / dt + end if + +! sum up snow mass for layered snow + + if(isnow < 0) then ! mb: only do for multi-layer + sneqv = 0. + do iz = isnow+1,0 + sneqv = sneqv + snice(iz) + snliq(iz) + enddo + end if + +! reset zsnso and layer thinkness dzsnso + + do iz = isnow+1, 0 + dzsnso(iz) = -dzsnso(iz) + end do + + dzsnso(1) = zsoil(1) + do iz = 2,nsoil + dzsnso(iz) = (zsoil(iz) - zsoil(iz-1)) + end do + + zsnso(isnow+1) = dzsnso(isnow+1) + do iz = isnow+2 ,nsoil + zsnso(iz) = zsnso(iz-1) + dzsnso(iz) + enddo + + do iz = isnow+1 ,nsoil + dzsnso(iz) = -dzsnso(iz) + end do + + end subroutine snowwater + +!== begin snowfall ================================================================================= + + subroutine snowfall (parameters,nsoil ,nsnow ,dt ,qsnow ,snowhin , & !in + sfctmp ,iloc ,jloc , & !in + isnow ,snowh ,dzsnso ,stc ,snice , & !inout + snliq ,sneqv ) !inout +! ---------------------------------------------------------------------- +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !main time step (s) + real, intent(in) :: qsnow !snow at ground srf (mm/s) [+] + real, intent(in) :: snowhin!snow depth increasing rate (m/s) + real, intent(in) :: sfctmp !surface air temperature [k] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, intent(inout) :: snowh !snow depth [m] + real, intent(inout) :: sneqv !swow water equivalent [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso !thickness of snow/soil layers (m) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + +! local + + integer :: newnode ! 0-no new layers, 1-creating new layers +! ---------------------------------------------------------------------- + newnode = 0 + +! shallow snow / no layer + + if(isnow == 0 .and. qsnow > 0.) then + snowh = snowh + snowhin * dt + sneqv = sneqv + qsnow * dt + end if + +! creating a new layer + + if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.025) then !mb: change limit +! if(isnow == 0 .and. qsnow>0. .and. snowh >= 0.05) then + isnow = -1 + newnode = 1 + dzsnso(0)= snowh + snowh = 0. + stc(0) = min(273.16, sfctmp) ! temporary setup + snice(0) = sneqv + snliq(0) = 0. + end if + +! snow with layers + + if(isnow < 0 .and. newnode == 0 .and. qsnow > 0.) then + snice(isnow+1) = snice(isnow+1) + qsnow * dt + dzsnso(isnow+1) = dzsnso(isnow+1) + snowhin * dt + endif + +! ---------------------------------------------------------------------- + end subroutine snowfall + +!== begin combine ================================================================================== + + subroutine combine (parameters,nsnow ,nsoil ,iloc ,jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc + integer, intent(in) :: jloc + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + real, intent(inout) :: sneqv !snow water equivalent [m] + real, intent(inout) :: snowh !snow depth [m] + real, intent(out) :: ponding1 + real, intent(out) :: ponding2 + +! local variables: + + integer :: i,j,k,l ! node indices + integer :: isnow_old ! number of top snow layer + integer :: mssi ! node index + integer :: neibor ! adjacent node selected for combination + real :: zwice ! total ice mass in snow + real :: zwliq ! total liquid water in snow + + real :: dzmin(3) ! minimum of top snow layer +! data dzmin /0.045, 0.05, 0.2/ + data dzmin /0.025, 0.025, 0.1/ ! mb: change limit +!----------------------------------------------------------------------- + + isnow_old = isnow + + do j = isnow_old+1,0 + if (snice(j) <= .1) then + if(j /= 0) then + snliq(j+1) = snliq(j+1) + snliq(j) + snice(j+1) = snice(j+1) + snice(j) + else + if (isnow_old < -1) then ! mb/km: change to isnow + snliq(j-1) = snliq(j-1) + snliq(j) + snice(j-1) = snice(j-1) + snice(j) + else + if(snice(j) >= 0.) then + ponding1 = snliq(j) ! isnow will get set to zero below; ponding1 will get + sneqv = snice(j) ! added to ponding from phasechange ponding should be + snowh = dzsnso(j) ! zero here because it was calculated for thin snow + else ! snice over-sublimated earlier + ponding1 = snliq(j) + snice(j) + if(ponding1 < 0.) then ! if snice and snliq sublimates remove from soil + sice(1) = max(0.0,sice(1)+ponding1/(dzsnso(1)*1000.)) + ponding1 = 0.0 + end if + sneqv = 0.0 + snowh = 0.0 + end if + snliq(j) = 0.0 + snice(j) = 0.0 + dzsnso(j) = 0.0 + endif +! sh2o(1) = sh2o(1)+snliq(j)/(dzsnso(1)*1000.) +! sice(1) = sice(1)+snice(j)/(dzsnso(1)*1000.) + endif + + ! shift all elements above this down by one. + if (j > isnow+1 .and. isnow < -1) then + do i = j, isnow+2, -1 + stc(i) = stc(i-1) + snliq(i) = snliq(i-1) + snice(i) = snice(i-1) + dzsnso(i)= dzsnso(i-1) + end do + end if + isnow = isnow + 1 + end if + end do + +! to conserve water in case of too large surface sublimation + + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + + if(isnow ==0) return ! mb: get out if no longer multi-layer + + sneqv = 0. + snowh = 0. + zwice = 0. + zwliq = 0. + + do j = isnow+1,0 + sneqv = sneqv + snice(j) + snliq(j) + snowh = snowh + dzsnso(j) + zwice = zwice + snice(j) + zwliq = zwliq + snliq(j) + end do + +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. + + if (snowh < 0.025 .and. isnow < 0 ) then ! mb: change limit +! if (snowh < 0.05 .and. isnow < 0 ) then + isnow = 0 + sneqv = zwice + ponding2 = zwliq ! limit of isnow < 0 means input ponding + if(sneqv <= 0.) snowh = 0. ! should be zero; see above + end if + +! if (snowh < 0.05 ) then +! isnow = 0 +! sneqv = zwice +! sh2o(1) = sh2o(1) + zwliq / (dzsnso(1) * 1000.) +! if(sneqv <= 0.) snowh = 0. +! end if + +! check the snow depth - snow layers combined + + if (isnow < -1) then + + isnow_old = isnow + mssi = 1 + + do i = isnow_old+1,0 + if (dzsnso(i) < dzmin(mssi)) then + + if (i == isnow+1) then + neibor = i + 1 + else if (i == 0) then + neibor = i - 1 + else + neibor = i + 1 + if ((dzsnso(i-1)+dzsnso(i)) < (dzsnso(i+1)+dzsnso(i))) neibor = i-1 + end if + + ! node l and j are combined and stored as node j. + if (neibor > i) then + j = neibor + l = i + else + j = i + l = neibor + end if + + call combo (parameters,dzsnso(j), snliq(j), snice(j), & + stc(j), dzsnso(l), snliq(l), snice(l), stc(l) ) + + ! now shift all elements above this down one. + if (j-1 > isnow+1) then + do k = j-1, isnow+2, -1 + stc(k) = stc(k-1) + snice(k) = snice(k-1) + snliq(k) = snliq(k-1) + dzsnso(k) = dzsnso(k-1) + end do + end if + + ! decrease the number of snow layers + isnow = isnow + 1 + if (isnow >= -1) exit + else + + ! the layer thickness is greater than the prescribed minimum value + mssi = mssi + 1 + + end if + end do + + end if + + end subroutine combine + +!== begin divide =================================================================================== + + subroutine divide (parameters,nsnow ,nsoil , & !in + isnow ,stc ,snice ,snliq ,dzsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, intent(in) :: nsoil !no. of soil layers [ =4] + +! input and output + + integer , intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso!snow layer depth [m] + +! local variables: + + integer :: j !indices + integer :: msno !number of layer (top) to msno (bot) + real :: drr !thickness of the combined [m] + real, dimension( 1:nsnow) :: dz !snow layer thickness [m] + real, dimension( 1:nsnow) :: swice !partial volume of ice [m3/m3] + real, dimension( 1:nsnow) :: swliq !partial volume of liquid water [m3/m3] + real, dimension( 1:nsnow) :: tsno !node temperature [k] + real :: zwice !temporary + real :: zwliq !temporary + real :: propor!temporary + real :: dtdz !temporary +! ---------------------------------------------------------------------- + + do j = 1,nsnow + if (j <= abs(isnow)) then + dz(j) = dzsnso(j+isnow) + swice(j) = snice(j+isnow) + swliq(j) = snliq(j+isnow) + tsno(j) = stc(j+isnow) + end if + end do + + msno = abs(isnow) + + if (msno == 1) then + ! specify a new snow layer + if (dz(1) > 0.05) then + msno = 2 + dz(1) = dz(1)/2. + swice(1) = swice(1)/2. + swliq(1) = swliq(1)/2. + dz(2) = dz(1) + swice(2) = swice(1) + swliq(2) = swliq(1) + tsno(2) = tsno(1) + end if + end if + + if (msno > 1) then + if (dz(1) > 0.05) then + drr = dz(1) - 0.05 + propor = drr/dz(1) + zwice = propor*swice(1) + zwliq = propor*swliq(1) + propor = 0.05/dz(1) + swice(1) = propor*swice(1) + swliq(1) = propor*swliq(1) + dz(1) = 0.05 + + call combo (parameters,dz(2), swliq(2), swice(2), tsno(2), drr, & + zwliq, zwice, tsno(1)) + + ! subdivide a new layer + if (msno <= 2 .and. dz(2) > 0.20) then ! mb: change limit +! if (msno <= 2 .and. dz(2) > 0.10) then + msno = 3 + dtdz = (tsno(1) - tsno(2))/((dz(1)+dz(2))/2.) + dz(2) = dz(2)/2. + swice(2) = swice(2)/2. + swliq(2) = swliq(2)/2. + dz(3) = dz(2) + swice(3) = swice(2) + swliq(3) = swliq(2) + tsno(3) = tsno(2) - dtdz*dz(2)/2. + if (tsno(3) >= tfrz) then + tsno(3) = tsno(2) + else + tsno(2) = tsno(2) + dtdz*dz(2)/2. + endif + + end if + end if + end if + + if (msno > 2) then + if (dz(2) > 0.2) then + drr = dz(2) - 0.2 + propor = drr/dz(2) + zwice = propor*swice(2) + zwliq = propor*swliq(2) + propor = 0.2/dz(2) + swice(2) = propor*swice(2) + swliq(2) = propor*swliq(2) + dz(2) = 0.2 + call combo (parameters,dz(3), swliq(3), swice(3), tsno(3), drr, & + zwliq, zwice, tsno(2)) + end if + end if + + isnow = -msno + + do j = isnow+1,0 + dzsnso(j) = dz(j-isnow) + snice(j) = swice(j-isnow) + snliq(j) = swliq(j-isnow) + stc(j) = tsno(j-isnow) + end do + + +! do j = isnow+1,nsoil +! write(*,'(i5,7f10.3)') j, dzsnso(j), snice(j), snliq(j),stc(j) +! end do + + end subroutine divide + +!== begin combo ==================================================================================== + + subroutine combo(parameters,dz, wliq, wice, t, dz2, wliq2, wice2, t2) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- + +! ----------------------------------------------------------------------s +! input + + type (noahmp_parameters), intent(in) :: parameters + real, intent(in) :: dz2 !nodal thickness of 2 elements being combined [m] + real, intent(in) :: wliq2 !liquid water of element 2 [kg/m2] + real, intent(in) :: wice2 !ice of element 2 [kg/m2] + real, intent(in) :: t2 !nodal temperature of element 2 [k] + real, intent(inout) :: dz !nodal thickness of 1 elements being combined [m] + real, intent(inout) :: wliq !liquid water of element 1 + real, intent(inout) :: wice !ice of element 1 [kg/m2] + real, intent(inout) :: t !node temperature of element 1 [k] + +! local + + real :: dzc !total thickness of nodes 1 and 2 (dzc=dz+dz2). + real :: wliqc !combined liquid water [kg/m2] + real :: wicec !combined ice [kg/m2] + real :: tc !combined node temperature [k] + real :: h !enthalpy of element 1 [j/m2] + real :: h2 !enthalpy of element 2 [j/m2] + real :: hc !temporary + +!----------------------------------------------------------------------- + + dzc = dz+dz2 + wicec = (wice+wice2) + wliqc = (wliq+wliq2) + h = (cice*wice+cwat*wliq) * (t-tfrz)+hfus*wliq + h2= (cice*wice2+cwat*wliq2) * (t2-tfrz)+hfus*wliq2 + + hc = h + h2 + if(hc < 0.)then + tc = tfrz + hc/(cice*wicec + cwat*wliqc) + else if (hc.le.hfus*wliqc) then + tc = tfrz + else + tc = tfrz + (hc - hfus*wliqc) / (cice*wicec + cwat*wliqc) + end if + + dz = dzc + wice = wicec + wliq = wliqc + t = tc + + end subroutine combo + +!== begin compact ================================================================================== + + subroutine compact (parameters,nsnow ,nsoil ,dt ,stc ,snice , & !in + snliq ,zsoil ,imelt ,ficeold,iloc , jloc , & !in + isnow ,dzsnso ,zsnso ) !inout +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers [ =4] + integer, intent(in) :: nsnow !maximum no. of snow layers [ =3] + integer, dimension(-nsnow+1:0) , intent(in) :: imelt !melting state index [0-no melt;1-melt] + real, intent(in) :: dt !time step (sec) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow layer temperature [k] + real, dimension(-nsnow+1: 0), intent(in) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1: 0), intent(in) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil srf + real, dimension(-nsnow+1: 0), intent(in) :: ficeold!ice fraction at last timestep + +! input and output + integer, intent(inout) :: isnow ! actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(inout) :: zsnso ! depth of snow/soil layer-bottom + +! local + real, parameter :: c2 = 21.e-3 ![m3/kg] ! default 21.e-3 + real, parameter :: c3 = 2.5e-6 ![1/s] + real, parameter :: c4 = 0.04 ![1/k] + real, parameter :: c5 = 2.0 ! + real, parameter :: dm = 100.0 !upper limit on destructive metamorphism compaction [kg/m3] + real, parameter :: eta0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to anderson, it is between 0.52e6~1.38e6 + real :: burden !pressure of overlying snow [kg/m2] + real :: ddz1 !rate of settling of snow pack due to destructive metamorphism. + real :: ddz2 !rate of compaction of snow pack due to overburden. + real :: ddz3 !rate of compaction of snow pack due to melt [1/s] + real :: dexpf !expf=exp(-c4*(273.15-stc)). + real :: td !stc - tfrz [k] + real :: pdzdtc !nodal rate of change in fractional-thickness due to compaction [fraction/s] + real :: void !void (1 - snice - snliq) + real :: wx !water mass (ice + liquid) [kg/m2] + real :: bi !partial density of ice [kg/m3] + real, dimension(-nsnow+1:0) :: fice !fraction of ice at current time step + + integer :: j + +! ---------------------------------------------------------------------- + burden = 0.0 + + do j = isnow+1, 0 + + wx = snice(j) + snliq(j) + fice(j) = snice(j) / wx + void = 1. - (snice(j)/denice + snliq(j)/denh2o) / dzsnso(j) + + ! allow compaction only for non-saturated node and higher ice lens node. + if (void > 0.001 .and. snice(j) > 0.1) then + bi = snice(j) / dzsnso(j) + td = max(0.,tfrz-stc(j)) + dexpf = exp(-c4*td) + + ! settling as a result of destructive metamorphism + + ddz1 = -c3*dexpf + + if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm)) + + ! liquid water term + + if (snliq(j) > 0.01*dzsnso(j)) ddz1=ddz1*c5 + + ! compaction due to overburden + + ddz2 = -(burden+0.5*wx)*exp(-0.08*td-c2*bi)/eta0 ! 0.5*wx -> self-burden + + ! compaction occurring during melt + + if (imelt(j) == 1) then + ddz3 = max(0.,(ficeold(j) - fice(j))/max(1.e-6,ficeold(j))) + ddz3 = - ddz3/dt ! sometimes too large + else + ddz3 = 0. + end if + + ! time rate of fractional change in dz (units of s-1) + + pdzdtc = (ddz1 + ddz2 + ddz3)*dt + pdzdtc = max(-0.5,pdzdtc) + + ! the change in dz due to compaction + + dzsnso(j) = dzsnso(j)*(1.+pdzdtc) + end if + + ! pressure of overlying snow + + burden = burden + wx + + end do + + end subroutine compact + +!== begin snowh2o ================================================================================== + + subroutine snowh2o (parameters,nsnow ,nsoil ,dt ,qsnfro ,qsnsub , & !in + qrain ,iloc ,jloc , & !in + isnow ,dzsnso ,snowh ,sneqv ,snice , & !inout + snliq ,sh2o ,sice ,stc , & !inout + qsnbot ,ponding1 ,ponding2) !out +! ---------------------------------------------------------------------- +! renew the mass of ice lens (snice) and liquid (snliq) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers[=3] + integer, intent(in) :: nsoil !no. of soil layers[=4] + real, intent(in) :: dt !time step + real, intent(in) :: qsnfro !snow surface frost rate[mm/s] + real, intent(in) :: qsnsub !snow surface sublimation rate[mm/s] + real, intent(in) :: qrain !snow surface rain rate[mm/s] + +! output + + real, intent(out) :: qsnbot !melting water out of snow bottom [mm/s] + +! input and output + + integer, intent(inout) :: isnow !actual no. of snow layers + real, dimension(-nsnow+1:nsoil), intent(inout) :: dzsnso ! snow layer depth [m] + real, intent(inout) :: snowh !snow height [m] + real, intent(inout) :: sneqv !snow water eqv. [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snice !snow layer ice [mm] + real, dimension(-nsnow+1:0), intent(inout) :: snliq !snow layer liquid water [mm] + real, dimension( 1:nsoil), intent(inout) :: sh2o !soil liquid moisture (m3/m3) + real, dimension( 1:nsoil), intent(inout) :: sice !soil ice moisture (m3/m3) + real, dimension(-nsnow+1:nsoil), intent(inout) :: stc !snow layer temperature [k] + +! local variables: + + integer :: j !do loop/array indices + real :: qin !water flow into the element (mm/s) + real :: qout !water flow out of the element (mm/s) + real :: wgdif !ice mass after minus sublimation + real, dimension(-nsnow+1:0) :: vol_liq !partial volume of liquid water in layer + real, dimension(-nsnow+1:0) :: vol_ice !partial volume of ice lens in layer + real, dimension(-nsnow+1:0) :: epore !effective porosity = porosity - vol_ice + real :: propor, temp + real :: ponding1, ponding2 +! ---------------------------------------------------------------------- + +!for the case when sneqv becomes '0' after 'combine' + + if(sneqv == 0.) then + sice(1) = sice(1) + (qsnfro-qsnsub)*dt/(dzsnso(1)*1000.) ! barlage: sh2o->sice v3.6 + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. to conserve water, +! excessive sublimation is used to reduce soil water. smaller time steps would tend +! to aviod this problem. + + if(isnow == 0 .and. sneqv > 0.) then + temp = sneqv + sneqv = sneqv - qsnsub*dt + qsnfro*dt + propor = sneqv/temp + snowh = max(0.,propor * snowh) + + if(sneqv < 0.) then + sice(1) = sice(1) + sneqv/(dzsnso(1)*1000.) + sneqv = 0. + snowh = 0. + end if + if(sice(1) < 0.) then + sh2o(1) = sh2o(1) + sice(1) + sice(1) = 0. + end if + end if + + if(snowh <= 1.e-8 .or. sneqv <= 1.e-6) then + snowh = 0.0 + sneqv = 0.0 + end if + +! for deep snow + + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + + wgdif = snice(isnow+1) - qsnsub*dt + qsnfro*dt + snice(isnow+1) = wgdif + if (wgdif < 1.e-6 .and. isnow <0) then + call combine (parameters,nsnow ,nsoil ,iloc, jloc , & !in + isnow ,sh2o ,stc ,snice ,snliq , & !inout + dzsnso ,sice ,snowh ,sneqv , & !inout + ponding1, ponding2 ) !out + endif + !kwm: subroutine combine can change isnow to make it 0 again? + if ( isnow < 0 ) then !kwm added this if statement to prevent out-of-bounds array references + snliq(isnow+1) = snliq(isnow+1) + qrain * dt + snliq(isnow+1) = max(0., snliq(isnow+1)) + endif + + endif !kwm -- can the endif be moved toward the end of the subroutine (just set qsnbot=0)? + +! porosity and partial volume + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + vol_ice(j) = min(1., snice(j)/(dzsnso(j)*denice)) + epore(j) = 1. - vol_ice(j) + vol_liq(j) = min(epore(j),snliq(j)/(dzsnso(j)*denh2o)) + end if + end do + + qin = 0. + qout = 0. + + !kwm looks to me like loop index / if test can be simplified. + + do j = -nsnow+1, 0 + if (j >= isnow+1) then + snliq(j) = snliq(j) + qin + if (j <= -1) then + if (epore(j) < 0.05 .or. epore(j+1) < 0.05) then + qout = 0. + else + qout = max(0.,(vol_liq(j)-parameters%ssi*epore(j))*dzsnso(j)) + qout = min(qout,(1.-vol_ice(j+1)-vol_liq(j+1))*dzsnso(j+1)) + end if + else + qout = max(0.,(vol_liq(j) - parameters%ssi*epore(j))*dzsnso(j)) + end if + qout = qout*1000. + snliq(j) = snliq(j) - qout + qin = qout + end if + end do + +! liquid water from snow bottom to soil + + qsnbot = qout / dt ! mm/s + + end subroutine snowh2o + +!== begin soilwater ================================================================================ + + subroutine soilwater (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + qinsur ,qseva ,etrani ,sice ,iloc , jloc, & !in + sh2o ,smc ,zwt ,vegtyp ,& !inout + smcwtd, deeprech ,& !inout + runsrf ,qdrain ,runsub ,wcnd ,fcrmax ) !out + +! ---------------------------------------------------------------------- +! calculate surface runoff and soil moisture. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, intent(in) :: dt !time step (sec) + real, intent(in) :: qinsur !water input on soil surface [mm/s] + real, intent(in) :: qseva !evap from soil surface [mm/s] + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(1:nsoil), intent(in) :: etrani !evapotranspiration from soil layers [mm/s] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer depth [m] + real, dimension(1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + + integer, intent(in) :: vegtyp + +! input & output + real, dimension(1:nsoil), intent(inout) :: sh2o !soil liquid water content [m3/m3] + real, dimension(1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: zwt !water table depth [m] + real, intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3] + real , intent(inout) :: deeprech + +! output + real, intent(out) :: qdrain !soil-bottom free drainage [mm/s] + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: runsub !subsurface runoff [mm/s] + real, intent(out) :: fcrmax !maximum of fcr (-) + real, dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s) + +! local + integer :: k,iz !do-loop index + integer :: iter !iteration index + real :: dtfine !fine time step (s) + real, dimension(1:nsoil) :: rhstt !right-hand side term of the matrix + real, dimension(1:nsoil) :: ai !left-hand side term + real, dimension(1:nsoil) :: bi !left-hand side term + real, dimension(1:nsoil) :: ci !left-hand side term + + real :: fff !runoff decay factor (m-1) + real :: rsbmx !baseflow coefficient [mm/s] + real :: pddum !infiltration rate at surface (m/s) + real :: fice !ice fraction in frozen soil + real :: wplus !saturation excess of the total soil [m] + real :: rsat !accumulation of wplus (saturation excess) [m] + real :: sicemax!maximum soil ice content (m3/m3) + real :: sh2omin!minimum soil liquid water content (m3/m3) + real :: wtsub !sum of wcnd(k)*dzsnso(k) + real :: mh2o !water mass removal (mm) + real :: fsat !fractional saturated area (-) + real, dimension(1:nsoil) :: mliq ! + real :: xs ! + real :: watmin ! + real :: qdrain_save ! + real :: epore !effective porosity [m3/m3] + real, dimension(1:nsoil) :: fcr !impermeable fraction due to frozen soil + integer :: niter !iteration times soil moisture (-) + real :: smctot !2-m averaged soil moisture (m3/m3) + real :: dztot !2-m soil depth (m) + real, parameter :: a = 4.0 +! ---------------------------------------------------------------------- + runsrf = 0.0 + pddum = 0.0 + rsat = 0.0 + +! for the case when snowmelt water is too large + + do k = 1,nsoil + epore = max ( 1.e-4 , ( parameters%smcmax - sice(k) ) ) + rsat = rsat + max(0.,sh2o(k)-epore)*dzsnso(k) + sh2o(k) = min(epore,sh2o(k)) + end do + +!impermeable fraction due to frozen soil + + do k = 1,nsoil + fice = min(1.0,sice(k)/parameters%smcmax) + fcr(k) = max(0.0,exp(-a*(1.-fice))- exp(-a)) / & + (1.0 - exp(-a)) + end do + +! maximum soil ice content and minimum liquid water of all layers + + sicemax = 0.0 + fcrmax = 0.0 + sh2omin = parameters%smcmax + do k = 1,nsoil + if (sice(k) > sicemax) sicemax = sice(k) + if (fcr(k) > fcrmax) fcrmax = fcr(k) + if (sh2o(k) < sh2omin) sh2omin = sh2o(k) + end do + +!subsurface runoff for runoff scheme option 2 + + if(opt_run == 2) then + fff = 2.0 + rsbmx = 4.0 + call zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt) + runsub = (1.0-fcrmax) * rsbmx * exp(-parameters%timean) * exp(-fff*zwt) ! mm/s + end if + +!surface runoff and infiltration rate using different schemes + +!jref impermable surface at urban + if ( parameters%urban_flag ) fcr(1)= 0.95 + + if(opt_run == 1) then + fff = 6.0 + fsat = parameters%fsatmx*exp(-0.5*fff*(zwt-2.0)) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 5) then + fff = 6.0 + fsat = parameters%fsatmx*exp(-0.5*fff*max(-2.0-zwt,0.)) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 2) then + fff = 2.0 + fsat = parameters%fsatmx*exp(-0.5*fff*zwt) + if(qinsur > 0.) then + runsrf = qinsur * ( (1.0-fcr(1))*fsat + fcr(1) ) + pddum = qinsur - runsrf ! m/s + end if + end if + + if(opt_run == 3) then + call infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in + sicemax,qinsur , & !in + pddum ,runsrf ) !out + end if + + if(opt_run == 4) then + smctot = 0. + dztot = 0. + do k = 1,nsoil + dztot = dztot + dzsnso(k) + smctot = smctot + smc(k)*dzsnso(k) + if(dztot >= 2.0) exit + end do + smctot = smctot/dztot + fsat = max(0.01,smctot/parameters%smcmax) ** 4. !bats + + if(qinsur > 0.) then + runsrf = qinsur * ((1.0-fcr(1))*fsat+fcr(1)) + pddum = qinsur - runsrf ! m/s + end if + end if + +! determine iteration times and finer time step + + niter = 1 + + if(opt_inf == 1) then !opt_inf =2 may cause water imbalance + niter = 3 + if (pddum*dt>dzsnso(1)*parameters%smcmax ) then + niter = niter*2 + end if + end if + + dtfine = dt / niter + +! solve soil moisture + + qdrain_save = 0.0 + do iter = 1, niter + call srt (parameters,nsoil ,zsoil ,dtfine ,pddum ,etrani , & !in + qseva ,sh2o ,smc ,zwt ,fcr , & !in + sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in + rhstt ,ai ,bi ,ci ,qdrain , & !out + wcnd ) !out + + call sstep (parameters,nsoil ,nsnow ,dtfine ,zsoil ,dzsnso , & !in + sice ,iloc ,jloc ,zwt , & !in + sh2o ,smc ,ai ,bi ,ci , & !inout + rhstt ,smcwtd ,qdrain ,deeprech, & !inout + wplus) !out + rsat = rsat + wplus + qdrain_save = qdrain_save + qdrain + end do + + qdrain = qdrain_save/niter + + runsrf = runsrf * 1000. + rsat * 1000./dt ! m/s -> mm/s + qdrain = qdrain * 1000. + +!wrf_hydro_djg... +!yw infxsrt = runsrf * dt !mm/s -> mm + +! removal of soil water due to groundwater flow (option 2) + + if(opt_run == 2) then + wtsub = 0. + do k = 1, nsoil + wtsub = wtsub + wcnd(k)*dzsnso(k) + end do + + do k = 1, nsoil + mh2o = runsub*dt*(wcnd(k)*dzsnso(k))/wtsub ! mm + sh2o(k) = sh2o(k) - mh2o/(dzsnso(k)*1000.) + end do + end if + +! limit mliq to be greater than or equal to watmin. +! get water needed to bring mliq equal watmin from lower layer. + + if(opt_run /= 1) then + do iz = 1, nsoil + mliq(iz) = sh2o(iz)*dzsnso(iz)*1000. + end do + + watmin = 0.01 ! mm + do iz = 1, nsoil-1 + if (mliq(iz) .lt. 0.) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz ) = mliq(iz ) + xs + mliq(iz+1) = mliq(iz+1) - xs + end do + + iz = nsoil + if (mliq(iz) .lt. watmin) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz) = mliq(iz) + xs + runsub = runsub - xs/dt + if(opt_run == 5)deeprech = deeprech - xs*1.e-3 + + do iz = 1, nsoil + sh2o(iz) = mliq(iz) / (dzsnso(iz)*1000.) + end do + end if + + end subroutine soilwater + +!== begin zwteq ==================================================================================== + + subroutine zwteq (parameters,nsoil ,nsnow ,zsoil ,dzsnso ,sh2o ,zwt) +! ---------------------------------------------------------------------- +! calculate equilibrium water table depth (niu et al., 2005) +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: nsnow !maximum no. of snow layers + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer depth [m] + real, dimension(1:nsoil), intent(in) :: sh2o !soil liquid water content [m3/m3] + +! output + + real, intent(out) :: zwt !water table depth [m] + +! locals + + integer :: k !do-loop index + integer, parameter :: nfine = 100 !no. of fine soil layers of 6m soil + real :: wd1 !water deficit from coarse (4-l) soil moisture profile + real :: wd2 !water deficit from fine (100-l) soil moisture profile + real :: dzfine !layer thickness of the 100-l soil layers to 6.0 m + real :: temp !temporary variable + real, dimension(1:nfine) :: zfine !layer-bottom depth of the 100-l soil layers to 6.0 m +! ---------------------------------------------------------------------- + + wd1 = 0. + do k = 1,nsoil + wd1 = wd1 + (parameters%smcmax-sh2o(k)) * dzsnso(k) ! [m] + enddo + + dzfine = 3.0 * (-zsoil(nsoil)) / nfine + do k =1,nfine + zfine(k) = float(k) * dzfine + enddo + + zwt = -3.*zsoil(nsoil) - 0.001 ! initial value [m] + + wd2 = 0. + do k = 1,nfine + temp = 1. + (zwt-zfine(k))/parameters%psisat + wd2 = wd2 + parameters%smcmax*(1.-temp**(-1./parameters%bexp))*dzfine + if(abs(wd2-wd1).le.0.01) then + zwt = zfine(k) + exit + endif + enddo + + end subroutine zwteq + +!== begin infil ==================================================================================== + + subroutine infil (parameters,nsoil ,dt ,zsoil ,sh2o ,sice , & !in + sicemax,qinsur , & !in + pddum ,runsrf ) !out +! -------------------------------------------------------------------------------- +! compute inflitration rate at soil surface and surface runoff +! -------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsoil !no. of soil layers + real, intent(in) :: dt !time step (sec) + real, dimension(1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(1:nsoil), intent(in) :: sh2o !soil liquid water content [m3/m3] + real, dimension(1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + real, intent(in) :: qinsur !water input on soil surface [mm/s] + real, intent(in) :: sicemax!maximum soil ice content (m3/m3) + +! outputs + real, intent(out) :: runsrf !surface runoff [mm/s] + real, intent(out) :: pddum !infiltration rate at surface + +! locals + integer :: ialp1, j, jj, k + real :: val + real :: ddt + real :: px + real :: dt1, dd, dice + real :: fcr + real :: sum + real :: acrt + real :: wdf + real :: wcnd + real :: smcav + real :: infmax + real, dimension(1:nsoil) :: dmax + integer, parameter :: cvfrz = 3 +! -------------------------------------------------------------------------------- + + if (qinsur > 0.0) then + dt1 = dt /86400. + smcav = parameters%smcmax - parameters%smcwlt + +! maximum infiltration rate + + dmax(1)= -zsoil(1) * smcav + dice = -zsoil(1) * sice(1) + dmax(1)= dmax(1)* (1.0-(sh2o(1) + sice(1) - parameters%smcwlt)/smcav) + + dd = dmax(1) + + do k = 2,nsoil + dice = dice + (zsoil(k-1) - zsoil(k) ) * sice(k) + dmax(k) = (zsoil(k-1) - zsoil(k)) * smcav + dmax(k) = dmax(k) * (1.0-(sh2o(k) + sice(k) - parameters%smcwlt)/smcav) + dd = dd + dmax(k) + end do + + val = (1. - exp ( - parameters%kdt * dt1)) + ddt = dd * val + px = max(0.,qinsur * dt) + infmax = (px * (ddt / (px + ddt)))/ dt + +! impermeable fraction due to frozen soil + + fcr = 1. + if (dice > 1.e-2) then + acrt = cvfrz * parameters%frzx / dice + sum = 1. + ialp1 = cvfrz - 1 + do j = 1,ialp1 + k = 1 + do jj = j +1,ialp1 + k = k * jj + end do + sum = sum + (acrt ** (cvfrz - j)) / float(k) + end do + fcr = 1. - exp (-acrt) * sum + end if + +! correction of infiltration limitation + + infmax = infmax * fcr + +! jref for urban areas +! if ( parameters%urban_flag ) infmax == infmax * 0.05 + + call wdfcnd2 (parameters,wdf,wcnd,sh2o(1),sicemax) + infmax = max (infmax,wcnd) + infmax = min (infmax,px) + + runsrf= max(0., qinsur - infmax) + pddum = qinsur - runsrf + + end if + + end subroutine infil + +!== begin srt ====================================================================================== + + subroutine srt (parameters,nsoil ,zsoil ,dt ,pddum ,etrani , & !in + qseva ,sh2o ,smc ,zwt ,fcr , & !in + sicemax,fcrmax ,iloc ,jloc ,smcwtd , & !in + rhstt ,ai ,bi ,ci ,qdrain , & !out + wcnd ) !out +! ---------------------------------------------------------------------- +! calculate the right hand side of the time tendency term of the soil +! water diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil + real, dimension(1:nsoil), intent(in) :: zsoil + real, intent(in) :: dt + real, intent(in) :: pddum + real, intent(in) :: qseva + real, dimension(1:nsoil), intent(in) :: etrani + real, dimension(1:nsoil), intent(in) :: sh2o + real, dimension(1:nsoil), intent(in) :: smc + real, intent(in) :: zwt ! water table depth [m] + real, dimension(1:nsoil), intent(in) :: fcr + real, intent(in) :: fcrmax !maximum of fcr (-) + real, intent(in) :: sicemax!maximum soil ice content (m3/m3) + real, intent(in) :: smcwtd !soil moisture between bottom of the soil and the water table + +! output + + real, dimension(1:nsoil), intent(out) :: rhstt + real, dimension(1:nsoil), intent(out) :: ai + real, dimension(1:nsoil), intent(out) :: bi + real, dimension(1:nsoil), intent(out) :: ci + real, dimension(1:nsoil), intent(out) :: wcnd !hydraulic conductivity (m/s) + real, intent(out) :: qdrain !bottom drainage (m/s) + +! local + integer :: k + real, dimension(1:nsoil) :: ddz + real, dimension(1:nsoil) :: denom + real, dimension(1:nsoil) :: dsmdz + real, dimension(1:nsoil) :: wflux + real, dimension(1:nsoil) :: wdf + real, dimension(1:nsoil) :: smx + real :: temp1 + real :: smxwtd !soil moisture between bottom of the soil and water table + real :: smxbot !soil moisture below bottom to calculate flux + +! niu and yang (2006), j. of hydrometeorology +! ---------------------------------------------------------------------- + + if(opt_inf == 1) then + do k = 1, nsoil + call wdfcnd1 (parameters,wdf(k),wcnd(k),smc(k),fcr(k)) + smx(k) = smc(k) + end do + if(opt_run == 5)smxwtd=smcwtd + end if + + if(opt_inf == 2) then + do k = 1, nsoil + call wdfcnd2 (parameters,wdf(k),wcnd(k),sh2o(k),sicemax) + smx(k) = sh2o(k) + end do + if(opt_run == 5)smxwtd=smcwtd*sh2o(nsoil)/smc(nsoil) !same liquid fraction as in the bottom layer + end if + + do k = 1, nsoil + if(k == 1) then + denom(k) = - zsoil (k) + temp1 = - zsoil (k+1) + ddz(k) = 2.0 / temp1 + dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1 + wflux(k) = wdf(k) * dsmdz(k) + wcnd(k) - pddum + etrani(k) + qseva + else if (k < nsoil) then + denom(k) = (zsoil(k-1) - zsoil(k)) + temp1 = (zsoil(k-1) - zsoil(k+1)) + ddz(k) = 2.0 / temp1 + dsmdz(k) = 2.0 * (smx(k) - smx(k+1)) / temp1 + wflux(k) = wdf(k ) * dsmdz(k ) + wcnd(k ) & + - wdf(k-1) * dsmdz(k-1) - wcnd(k-1) + etrani(k) + else + denom(k) = (zsoil(k-1) - zsoil(k)) + if(opt_run == 1 .or. opt_run == 2) then + qdrain = 0. + end if + if(opt_run == 3) then + qdrain = parameters%slope*wcnd(k) + end if + if(opt_run == 4) then + qdrain = (1.0-fcrmax)*wcnd(k) + end if + if(opt_run == 5) then !gmm new m-m&f water table dynamics formulation + temp1 = 2.0 * denom(k) + if(zwt < zsoil(nsoil)-denom(nsoil))then +!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom + smxbot = smx(k) - (smx(k)-smxwtd) * denom(k) * 2./ (denom(k) + zsoil(k) - zwt) + else + smxbot = smxwtd + endif + dsmdz(k) = 2.0 * (smx(k) - smxbot) / temp1 + qdrain = wdf(k ) * dsmdz(k ) + wcnd(k ) + end if + wflux(k) = -(wdf(k-1)*dsmdz(k-1))-wcnd(k-1)+etrani(k) + qdrain + end if + end do + + do k = 1, nsoil + if(k == 1) then + ai(k) = 0.0 + bi(k) = wdf(k ) * ddz(k ) / denom(k) + ci(k) = - bi (k) + else if (k < nsoil) then + ai(k) = - wdf(k-1) * ddz(k-1) / denom(k) + ci(k) = - wdf(k ) * ddz(k ) / denom(k) + bi(k) = - ( ai (k) + ci (k) ) + else + ai(k) = - wdf(k-1) * ddz(k-1) / denom(k) + ci(k) = 0.0 + bi(k) = - ( ai (k) + ci (k) ) + end if + rhstt(k) = wflux(k) / (-denom(k)) + end do + +! ---------------------------------------------------------------------- + end subroutine srt + +!== begin sstep ==================================================================================== + + subroutine sstep (parameters,nsoil ,nsnow ,dt ,zsoil ,dzsnso , & !in + sice ,iloc ,jloc ,zwt , & !in + sh2o ,smc ,ai ,bi ,ci , & !inout + rhstt ,smcwtd ,qdrain ,deeprech, & !inout + wplus ) !out + +! ---------------------------------------------------------------------- +! calculate/update soil moisture content values +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +!input + + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsoil ! + integer, intent(in) :: nsnow ! + real, intent(in) :: dt + real, intent(in) :: zwt + real, dimension( 1:nsoil), intent(in) :: zsoil + real, dimension( 1:nsoil), intent(in) :: sice + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m] + +!input and output + real, dimension(1:nsoil), intent(inout) :: sh2o + real, dimension(1:nsoil), intent(inout) :: smc + real, dimension(1:nsoil), intent(inout) :: ai + real, dimension(1:nsoil), intent(inout) :: bi + real, dimension(1:nsoil), intent(inout) :: ci + real, dimension(1:nsoil), intent(inout) :: rhstt + real , intent(inout) :: smcwtd + real , intent(inout) :: qdrain + real , intent(inout) :: deeprech + +!output + real, intent(out) :: wplus !saturation excess water (m) + +!local + integer :: k + real, dimension(1:nsoil) :: rhsttin + real, dimension(1:nsoil) :: ciin + real :: stot + real :: epore + real :: wminus +! ---------------------------------------------------------------------- + wplus = 0.0 + + do k = 1,nsoil + rhstt (k) = rhstt(k) * dt + ai (k) = ai(k) * dt + bi (k) = 1. + bi(k) * dt + ci (k) = ci(k) * dt + end do + +! copy values for input variables before calling rosr12 + + do k = 1,nsoil + rhsttin(k) = rhstt(k) + ciin(k) = ci(k) + end do + +! call rosr12 to solve the tri-diagonal matrix + + call rosr12 (ci,ai,bi,ciin,rhsttin,rhstt,1,nsoil,0) + + do k = 1,nsoil + sh2o(k) = sh2o(k) + ci(k) + enddo + +! excessive water above saturation in a layer is moved to +! its unsaturated layer like in a bucket + +!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table + if(opt_run == 5) then + +!update smcwtd + + if(zwt < zsoil(nsoil)-dzsnso(nsoil))then +!accumulate qdrain to update deep water table and soil moisture later + deeprech = deeprech + dt * qdrain + else + smcwtd = smcwtd + dt * qdrain / dzsnso(nsoil) + wplus = max((smcwtd-parameters%smcmax), 0.0) * dzsnso(nsoil) + wminus = max((1.e-4-smcwtd), 0.0) * dzsnso(nsoil) + + smcwtd = max( min(smcwtd,parameters%smcmax) , 1.e-4) + sh2o(nsoil) = sh2o(nsoil) + wplus/dzsnso(nsoil) + +!reduce fluxes at the bottom boundaries accordingly + qdrain = qdrain - wplus/dt + deeprech = deeprech - wminus + endif + + endif + + do k = nsoil,2,-1 + epore = max ( 1.e-4 , ( parameters%smcmax - sice(k) ) ) + wplus = max((sh2o(k)-epore), 0.0) * dzsnso(k) + sh2o(k) = min(epore,sh2o(k)) + sh2o(k-1) = sh2o(k-1) + wplus/dzsnso(k-1) + end do + + epore = max ( 1.e-4 , ( parameters%smcmax - sice(1) ) ) + wplus = max((sh2o(1)-epore), 0.0) * dzsnso(1) + sh2o(1) = min(epore,sh2o(1)) + + end subroutine sstep + +!== begin wdfcnd1 ================================================================================== + + subroutine wdfcnd1 (parameters,wdf,wcnd,smc,fcr) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + real,intent(in) :: smc + real,intent(in) :: fcr + +! output + real,intent(out) :: wcnd + real,intent(out) :: wdf + +! local + real :: expon + real :: factr + real :: vkwgt +! ---------------------------------------------------------------------- + +! soil water diffusivity + + factr = max(0.01, smc/parameters%smcmax) + expon = parameters%bexp + 2.0 + wdf = parameters%dwsat * factr ** expon + wdf = wdf * (1.0 - fcr) + +! hydraulic conductivity + + expon = 2.0*parameters%bexp + 3.0 + wcnd = parameters%dksat * factr ** expon + wcnd = wcnd * (1.0 - fcr) + + end subroutine wdfcnd1 + +!== begin wdfcnd2 ================================================================================== + + subroutine wdfcnd2 (parameters,wdf,wcnd,smc,sice) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + real,intent(in) :: smc + real,intent(in) :: sice + +! output + real,intent(out) :: wcnd + real,intent(out) :: wdf + +! local + real :: expon + real :: factr + real :: vkwgt +! ---------------------------------------------------------------------- + +! soil water diffusivity + + factr = max(0.01, smc/parameters%smcmax) + expon = parameters%bexp + 2.0 + wdf = parameters%dwsat * factr ** expon + + if (sice > 0.0) then + vkwgt = 1./ (1. + (500.* sice)**3.) + wdf = vkwgt * wdf + (1.-vkwgt)*parameters%dwsat*(0.2/parameters%smcmax)**expon + end if + +! hydraulic conductivity + + expon = 2.0*parameters%bexp + 3.0 + wcnd = parameters%dksat * factr ** expon + + end subroutine wdfcnd2 + +!== begin groundwater ============================================================================== + + subroutine groundwater(parameters,nsnow ,nsoil ,dt ,sice ,zsoil , & !in + stc ,wcnd ,fcrmax ,iloc ,jloc , & !in + sh2o ,zwt ,wa ,wt , & !inout + qin ,qdis ) !out +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: iloc !grid index + integer, intent(in) :: jloc !grid index + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + real, intent(in) :: dt !timestep [sec] + real, intent(in) :: fcrmax!maximum fcr (-) + real, dimension( 1:nsoil), intent(in) :: sice !soil ice content [m3/m3] + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension( 1:nsoil), intent(in) :: wcnd !hydraulic conductivity (m/s) + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature (k) + +! input and output + real, dimension( 1:nsoil), intent(inout) :: sh2o !liquid soil water [m3/m3] + real, intent(inout) :: zwt !the depth to water table [m] + real, intent(inout) :: wa !water storage in aquifer [mm] + real, intent(inout) :: wt !water storage in aquifer + !+ saturated soil [mm] +! output + real, intent(out) :: qin !groundwater recharge [mm/s] + real, intent(out) :: qdis !groundwater discharge [mm/s] + +! local + real :: fff !runoff decay factor (m-1) + real :: rsbmx !baseflow coefficient [mm/s] + integer :: iz !do-loop index + integer :: iwt !layer index above water table layer + real, dimension( 1:nsoil) :: dzmm !layer thickness [mm] + real, dimension( 1:nsoil) :: znode !node depth [m] + real, dimension( 1:nsoil) :: mliq !liquid water mass [kg/m2 or mm] + real, dimension( 1:nsoil) :: epore !effective porosity [-] + real, dimension( 1:nsoil) :: hk !hydraulic conductivity [mm/s] + real, dimension( 1:nsoil) :: smc !total soil water content [m3/m3] + real(kind=8) :: s_node!degree of saturation of iwt layer + real :: dzsum !cumulative depth above water table [m] + real :: smpfz !matric potential (frozen effects) [mm] + real :: ka !aquifer hydraulic conductivity [mm/s] + real :: wh_zwt!water head at water table [mm] + real :: wh !water head at layer above zwt [mm] + real :: ws !water used to fill air pore [mm] + real :: wtsub !sum of hk*dzmm + real :: watmin!minimum soil vol soil moisture [m3/m3] + real :: xs !excessive water above saturation [mm] + real, parameter :: rous = 0.2 !specific yield [-] + real, parameter :: cmic = 0.20 !microprore content (0.0-1.0) + !0.0-close to free drainage +! ------------------------------------------------------------- + qdis = 0.0 + qin = 0.0 + +! derive layer-bottom depth in [mm] +!kwm: derive layer thickness in mm + + dzmm(1) = -zsoil(1)*1.e3 + do iz = 2, nsoil + dzmm(iz) = 1.e3 * (zsoil(iz - 1) - zsoil(iz)) + enddo + +! derive node (middle) depth in [m] +!kwm: positive number, depth below ground surface in m + znode(1) = -zsoil(1) / 2. + do iz = 2, nsoil + znode(iz) = -zsoil(iz-1) + 0.5 * (zsoil(iz-1) - zsoil(iz)) + enddo + +! convert volumetric soil moisture "sh2o" to mass + + do iz = 1, nsoil + smc(iz) = sh2o(iz) + sice(iz) + mliq(iz) = sh2o(iz) * dzmm(iz) + epore(iz) = max(0.01,parameters%smcmax - sice(iz)) + hk(iz) = 1.e3*wcnd(iz) + enddo + +! the layer index of the first unsaturated layer, +! i.e., the layer right above the water table + + iwt = nsoil + do iz = 2,nsoil + if(zwt .le. -zsoil(iz) ) then + iwt = iz-1 + exit + end if + enddo + +! groundwater discharge [mm/s] + + fff = 6.0 + rsbmx = 5.0 + + qdis = (1.0-fcrmax)*rsbmx*exp(-parameters%timean)*exp(-fff*(zwt-2.0)) + +! matric potential at the layer above the water table + + s_node = min(1.0,smc(iwt)/parameters%smcmax ) + s_node = max(s_node,real(0.01,kind=8)) + smpfz = -parameters%psisat*1000.*s_node**(-parameters%bexp) ! m --> mm + smpfz = max(-120000.0,cmic*smpfz) + +! recharge rate qin to groundwater + + ka = hk(iwt) + + wh_zwt = - zwt * 1.e3 !(mm) + wh = smpfz - znode(iwt)*1.e3 !(mm) + qin = - ka * (wh_zwt-wh) /((zwt-znode(iwt))*1.e3) + qin = max(-10.0/dt,min(10./dt,qin)) + +! water storage in the aquifer + saturated soil + + wt = wt + (qin - qdis) * dt !(mm) + + if(iwt.eq.nsoil) then + wa = wa + (qin - qdis) * dt !(mm) + wt = wa + zwt = (-zsoil(nsoil) + 25.) - wa/1000./rous !(m) + mliq(nsoil) = mliq(nsoil) - qin * dt ! [mm] + + mliq(nsoil) = mliq(nsoil) + max(0.,(wa - 5000.)) + wa = min(wa, 5000.) + else + + if (iwt.eq.nsoil-1) then + zwt = -zsoil(nsoil) & + - (wt-rous*1000*25.) / (epore(nsoil))/1000. + else + ws = 0. ! water used to fill soil air pores + do iz = iwt+2,nsoil + ws = ws + epore(iz) * dzmm(iz) + enddo + zwt = -zsoil(iwt+1) & + - (wt-rous*1000.*25.-ws) /(epore(iwt+1))/1000. + endif + + wtsub = 0. + do iz = 1, nsoil + wtsub = wtsub + hk(iz)*dzmm(iz) + end do + + do iz = 1, nsoil ! removing subsurface runoff + mliq(iz) = mliq(iz) - qdis*dt*hk(iz)*dzmm(iz)/wtsub + end do + end if + + zwt = max(1.5,zwt) + +! +! limit mliq to be greater than or equal to watmin. +! get water needed to bring mliq equal watmin from lower layer. +! + watmin = 0.01 + do iz = 1, nsoil-1 + if (mliq(iz) .lt. 0.) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz ) = mliq(iz ) + xs + mliq(iz+1) = mliq(iz+1) - xs + end do + + iz = nsoil + if (mliq(iz) .lt. watmin) then + xs = watmin-mliq(iz) + else + xs = 0. + end if + mliq(iz) = mliq(iz) + xs + wa = wa - xs + wt = wt - xs + + do iz = 1, nsoil + sh2o(iz) = mliq(iz) / dzmm(iz) + end do + + end subroutine groundwater + +!== begin shallowwatertable ======================================================================== + + subroutine shallowwatertable (parameters,nsnow ,nsoil ,zsoil, dt , & !in + dzsnso ,smceq ,iloc ,jloc , & !in + smc ,wtd ,smcwtd ,rech, qdrain ) !inout +! ---------------------------------------------------------------------- +!diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, +!according to the miguez-macho&fan scheme +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + integer, intent(in) :: nsnow !maximum no. of snow layers + integer, intent(in) :: nsoil !no. of soil layers + integer, intent(in) :: iloc,jloc + real, intent(in) :: dt + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of soil layer-bottom [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso ! snow/soil layer thickness [m] + real, dimension( 1:nsoil), intent(in) :: smceq !equilibrium soil water content [m3/m3] + +! input and output + real, dimension( 1:nsoil), intent(inout) :: smc !total soil water content [m3/m3] + real, intent(inout) :: wtd !the depth to water table [m] + real, intent(inout) :: smcwtd !soil moisture between bottom of the soil and the water table [m3/m3] + real, intent(out) :: rech ! groundwater recharge (net vertical flux across the water table), positive up + real, intent(inout) :: qdrain + +! local + integer :: iz !do-loop index + integer :: iwtd !layer index above water table layer + integer :: kwtd !layer index where the water table layer is + real :: wtdold + real :: dzup + real :: smceqdeep + real, dimension( 0:nsoil) :: zsoil0 +! ------------------------------------------------------------- + + +zsoil0(1:nsoil) = zsoil(1:nsoil) +zsoil0(0) = 0. + +!find the layer where the water table is + do iz=nsoil,1,-1 + if(wtd + 1.e-6 < zsoil0(iz)) exit + enddo + iwtd=iz + + + kwtd=iwtd+1 !layer where the water table is + if(kwtd.le.nsoil)then !wtd in the resolved layers + wtdold=wtd + if(smc(kwtd).gt.smceq(kwtd))then + + if(smc(kwtd).eq.parameters%smcmax)then !wtd went to the layer above + wtd=zsoil0(iwtd) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + iwtd=iwtd-1 + kwtd=kwtd-1 + if(kwtd.ge.1)then + if(smc(kwtd).gt.smceq(kwtd))then + wtdold=wtd + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ), zsoil0(iwtd)) + rech=rech-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + endif + endif + else !wtd stays in the layer + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ), zsoil0(iwtd)) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + endif + + else !wtd has gone down to the layer below + wtd=zsoil0(kwtd) + rech=-(wtdold-wtd) * (parameters%smcmax-smceq(kwtd)) + kwtd=kwtd+1 + iwtd=iwtd+1 +!wtd crossed to the layer below. now adjust it there + if(kwtd.le.nsoil)then + wtdold=wtd + if(smc(kwtd).gt.smceq(kwtd))then + wtd = min( ( smc(kwtd)*dzsnso(kwtd) & + - smceq(kwtd)*zsoil0(iwtd) + parameters%smcmax*zsoil0(kwtd) ) / & + ( parameters%smcmax-smceq(kwtd) ) , zsoil0(iwtd) ) + else + wtd=zsoil0(kwtd) + endif + rech = rech - (wtdold-wtd) * & + (parameters%smcmax-smceq(kwtd)) + + else + wtdold=wtd +!restore smoi to equilibrium value with water from the ficticious layer below +! smcwtd=smcwtd-(smceq(nsoil)-smc(nsoil)) +! qdrain = qdrain - 1000 * (smceq(nsoil)-smc(nsoil)) * dzsnso(nsoil) / dt +! smc(nsoil)=smceq(nsoil) +!adjust wtd in the ficticious layer below + smceqdeep = parameters%smcmax * ( -parameters%psisat / ( -parameters%psisat - dzsnso(nsoil) ) ) ** (1./parameters%bexp) + wtd = min( ( smcwtd*dzsnso(nsoil) & + - smceqdeep*zsoil0(nsoil) + parameters%smcmax*(zsoil0(nsoil)-dzsnso(nsoil)) ) / & + ( parameters%smcmax-smceqdeep ) , zsoil0(nsoil) ) + rech = rech - (wtdold-wtd) * & + (parameters%smcmax-smceqdeep) + endif + + endif + elseif(wtd.ge.zsoil0(nsoil)-dzsnso(nsoil))then +!if wtd was already below the bottom of the resolved soil crust + wtdold=wtd + smceqdeep = parameters%smcmax * ( -parameters%psisat / ( -parameters%psisat - dzsnso(nsoil) ) ) ** (1./parameters%bexp) + if(smcwtd.gt.smceqdeep)then + wtd = min( ( smcwtd*dzsnso(nsoil) & + - smceqdeep*zsoil0(nsoil) + parameters%smcmax*(zsoil0(nsoil)-dzsnso(nsoil)) ) / & + ( parameters%smcmax-smceqdeep ) , zsoil0(nsoil) ) + rech = -(wtdold-wtd) * (parameters%smcmax-smceqdeep) + else + rech = -(wtdold-(zsoil0(nsoil)-dzsnso(nsoil))) * (parameters%smcmax-smceqdeep) + wtdold=zsoil0(nsoil)-dzsnso(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzsnso(nsoil)/(parameters%smcmax-smceqdeep) + wtd=wtdold-dzup + rech = rech - (parameters%smcmax-smceqdeep)*dzup + smcwtd=smceqdeep + endif + + + endif + +if(iwtd.lt.nsoil)smcwtd=parameters%smcmax + +end subroutine shallowwatertable + +! ================================================================================================== +! ********************* end of water subroutines ****************************************** +! ================================================================================================== + +!== begin carbon =================================================================================== + + subroutine carbon (parameters,nsnow ,nsoil ,vegtyp ,dt ,zsoil , & !in + dzsnso ,stc ,smc ,tv ,tg ,psn , & !in + foln ,btran ,apar ,fveg ,igs , & !in + troot ,ist ,lat ,iloc ,jloc , & !in + lfmass ,rtmass ,stmass ,wood ,stblcp ,fastcp , & !inout + gpp ,npp ,nee ,autors ,heters ,totsc , & !out + totlb ,xlai ,xsai ) !out +! ------------------------------------------------------------------------------------------ + implicit none +! ------------------------------------------------------------------------------------------ +! inputs (carbon) + + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer , intent(in) :: vegtyp !vegetation type + integer , intent(in) :: nsnow !number of snow layers + integer , intent(in) :: nsoil !number of soil layers + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: dt !time step (s) + real, dimension( 1:nsoil), intent(in) :: zsoil !depth of layer-bottom from soil surface + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k] + real, dimension( 1:nsoil), intent(in) :: smc !soil moisture (ice + liq.) [m3/m3] + real , intent(in) :: tv !vegetation temperature (k) + real , intent(in) :: tg !ground temperature (k) + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: btran !soil water transpiration factor (0 to 1) + real , intent(in) :: psn !total leaf photosyn (umolco2/m2/s) [+] + real , intent(in) :: apar !par by canopy (w/m2) + real , intent(in) :: igs !growing season index (0=off, 1=on) + real , intent(in) :: fveg !vegetation greenness fraction + real , intent(in) :: troot !root-zone averaged temperature (k) + integer , intent(in) :: ist !surface type 1->soil; 2->lake + +! input & output (carbon) + + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + real , intent(inout) :: stblcp !stable carbon in deep soil [g/m2] + real , intent(inout) :: fastcp !short-lived carbon in shallow soil [g/m2] + +! outputs: (carbon) + + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s c] + real , intent(out) :: npp !net primary productivity [g/m2/s c] + real , intent(out) :: nee !net ecosystem exchange [g/m2/s co2] + real , intent(out) :: autors !net ecosystem respiration [g/m2/s c] + real , intent(out) :: heters !organic respiration [g/m2/s c] + real , intent(out) :: totsc !total soil carbon [g/m2 c] + real , intent(out) :: totlb !total living carbon ([g/m2 c] + real , intent(out) :: xlai !leaf area index [-] + real , intent(out) :: xsai !stem area index [-] +! real , intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1] + +! local variables + + integer :: j !do-loop index + real :: wroot !root zone soil water [-] + real :: wstres !water stress coeficient [-] (1. for wilting ) + real :: lapm !leaf area per unit mass [m2/g] +! ------------------------------------------------------------------------------------------ + + if ( ( vegtyp == parameters%iswater ) .or. ( vegtyp == parameters%isbarren ) .or. & + ( vegtyp == parameters%isice ) .or. (parameters%urban_flag) ) then + xlai = 0. + xsai = 0. + gpp = 0. + npp = 0. + nee = 0. + autors = 0. + heters = 0. + totsc = 0. + totlb = 0. + lfmass = 0. + rtmass = 0. + stmass = 0. + wood = 0. + stblcp = 0. + fastcp = 0. + + return + end if + + lapm = parameters%sla / 1000. ! m2/kg -> m2/g + +! water stress + + wstres = 1.- btran + + wroot = 0. + do j=1,parameters%nroot + wroot = wroot + smc(j)/parameters%smcmax * dzsnso(j) / (-zsoil(parameters%nroot)) + enddo + + call co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in + dzsnso ,stc ,psn ,troot ,tv , & !in + wroot ,wstres ,foln ,lapm , & !in + lat ,iloc ,jloc ,fveg , & !in + xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout + fastcp ,stblcp ,wood , & !inout + gpp ,npp ,nee ,autors ,heters , & !out + totsc ,totlb ) !out + +! call bvoc (parameters,vocflx, vegtyp, vegfac, apar, tv) +! call ch4 + + end subroutine carbon + +!== begin co2flux ================================================================================== + + subroutine co2flux (parameters,nsnow ,nsoil ,vegtyp ,igs ,dt , & !in + dzsnso ,stc ,psn ,troot ,tv , & !in + wroot ,wstres ,foln ,lapm , & !in + lat ,iloc ,jloc ,fveg , & !in + xlai ,xsai ,lfmass ,rtmass ,stmass , & !inout + fastcp ,stblcp ,wood , & !inout + gpp ,npp ,nee ,autors ,heters , & !out + totsc ,totlb ) !out +! ----------------------------------------------------------------------------------------- +! the original code is from re dickinson et al.(1998), modifed by guo-yue niu, 2004 +! ----------------------------------------------------------------------------------------- + implicit none +! ----------------------------------------------------------------------------------------- + +! input + + type (noahmp_parameters), intent(in) :: parameters + integer , intent(in) :: iloc !grid index + integer , intent(in) :: jloc !grid index + integer , intent(in) :: vegtyp !vegetation physiology type + integer , intent(in) :: nsnow !number of snow layers + integer , intent(in) :: nsoil !number of soil layers + real , intent(in) :: dt !time step (s) + real , intent(in) :: lat !latitude (radians) + real , intent(in) :: igs !growing season index (0=off, 1=on) + real, dimension(-nsnow+1:nsoil), intent(in) :: dzsnso !snow/soil layer thickness [m] + real, dimension(-nsnow+1:nsoil), intent(in) :: stc !snow/soil temperature [k] + real , intent(in) :: psn !total leaf photosynthesis (umolco2/m2/s) + real , intent(in) :: troot !root-zone averaged temperature (k) + real , intent(in) :: tv !leaf temperature (k) + real , intent(in) :: wroot !root zone soil water + real , intent(in) :: wstres !soil water stress + real , intent(in) :: foln !foliage nitrogen (%) + real , intent(in) :: lapm !leaf area per unit mass [m2/g] + real , intent(in) :: fveg !vegetation greenness fraction + +! input and output + + real , intent(inout) :: xlai !leaf area index from leaf carbon [-] + real , intent(inout) :: xsai !stem area index from leaf carbon [-] + real , intent(inout) :: lfmass !leaf mass [g/m2] + real , intent(inout) :: rtmass !mass of fine roots [g/m2] + real , intent(inout) :: stmass !stem mass [g/m2] + real , intent(inout) :: fastcp !short lived carbon [g/m2] + real , intent(inout) :: stblcp !stable carbon pool [g/m2] + real , intent(inout) :: wood !mass of wood (incl. woody roots) [g/m2] + +! output + + real , intent(out) :: gpp !net instantaneous assimilation [g/m2/s] + real , intent(out) :: npp !net primary productivity [g/m2] + real , intent(out) :: nee !net ecosystem exchange (autors+heters-gpp) + real , intent(out) :: autors !net ecosystem resp. (maintance and growth) + real , intent(out) :: heters !organic respiration + real , intent(out) :: totsc !total soil carbon (g/m2) + real , intent(out) :: totlb !total living carbon (g/m2) + +! local + + real :: cflux !carbon flux to atmosphere [g/m2/s] + real :: lfmsmn !minimum leaf mass [g/m2] + real :: rswood !wood respiration [g/m2] + real :: rsleaf !leaf maintenance respiration per timestep [g/m2] + real :: rsroot !fine root respiration per time step [g/m2] + real :: nppl !leaf net primary productivity [g/m2/s] + real :: nppr !root net primary productivity [g/m2/s] + real :: nppw !wood net primary productivity [g/m2/s] + real :: npps !wood net primary productivity [g/m2/s] + real :: dielf !death of leaf mass per time step [g/m2] + + real :: addnpplf !leaf assimil after resp. losses removed [g/m2] + real :: addnppst !stem assimil after resp. losses removed [g/m2] + real :: carbfx !carbon assimilated per model step [g/m2] + real :: grleaf !growth respiration rate for leaf [g/m2/s] + real :: grroot !growth respiration rate for root [g/m2/s] + real :: grwood !growth respiration rate for wood [g/m2/s] + real :: grstem !growth respiration rate for stem [g/m2/s] + real :: leafpt !fraction of carbon allocated to leaves [-] + real :: lfdel !maximum leaf mass available to change [g/m2/s] + real :: lftovr !stem turnover per time step [g/m2] + real :: sttovr !stem turnover per time step [g/m2] + real :: wdtovr !wood turnover per time step [g/m2] + real :: rssoil !soil respiration per time step [g/m2] + real :: rttovr !root carbon loss per time step by turnover [g/m2] + real :: stablc !decay rate of fast carbon to slow carbon [g/m2/s] + real :: woodf !calculated wood to root ratio [-] + real :: nonlef !fraction of carbon to root and wood [-] + real :: rootpt !fraction of carbon flux to roots [-] + real :: woodpt !fraction of carbon flux to wood [-] + real :: stempt !fraction of carbon flux to stem [-] + real :: resp !leaf respiration [umol/m2/s] + real :: rsstem !stem respiration [g/m2/s] + + real :: fsw !soil water factor for microbial respiration + real :: fst !soil temperature factor for microbial respiration + real :: fnf !foliage nitrogen adjustemt to respiration (<= 1) + real :: tf !temperature factor + real :: rf !respiration reduction factor (<= 1) + real :: stdel + real :: stmsmn + real :: sapm !stem area per unit mass (m2/g) + real :: diest +! -------------------------- constants ------------------------------- + real :: bf !parameter for present wood allocation [-] + real :: rswoodc !wood respiration coeficient [1/s] + real :: stovrc !stem turnover coefficient [1/s] + real :: rsdryc !degree of drying that reduces soil respiration [-] + real :: rtovrc !root turnover coefficient [1/s] + real :: wstrc !water stress coeficient [-] + real :: laimin !minimum leaf area index [m2/m2] + real :: xsamin !minimum leaf area index [m2/m2] + real :: sc + real :: sd + real :: vegfrac + +! respiration as a function of temperature + + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- + +! constants + rtovrc = 2.0e-8 !original was 2.0e-8 + rsdryc = 40.0 !original was 40.0 + rswoodc = 3.0e-10 ! + bf = 0.90 !original was 0.90 ! carbon to roots + wstrc = 100.0 + laimin = 0.05 + xsamin = 0.05 ! mb: change to prevent vegetation from not growing back in spring + + sapm = 3.*0.001 ! m2/kg -->m2/g + lfmsmn = laimin/lapm + stmsmn = xsamin/sapm +! --------------------------------------------------------------------------------- + +! respiration + + if(igs .eq. 0.) then + rf = 0.5 + else + rf = 1.0 + endif + + fnf = min( foln/max(1.e-06,parameters%folnmx), 1.0 ) + tf = parameters%arm**( (tv-298.16)/10. ) + resp = parameters%rmf25 * tf * fnf * xlai * rf * (1.-wstres) ! umol/m2/s + rsleaf = min((lfmass-lfmsmn)/dt,resp*12.e-6) ! g/m2/s + + rsroot = parameters%rmr25*(rtmass*1e-3)*tf *rf* 12.e-6 ! g/m2/s + rsstem = parameters%rms25*((stmass-stmsmn)*1e-3)*tf *rf* 12.e-6 ! g/m2/s + rswood = rswoodc * r(tv) * wood*parameters%wdpool + +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g co2; 1 umol -> 12.e-6 g carbon; + + carbfx = psn * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon + +! fraction of carbon into leaf versus nonleaf + + leafpt = exp(0.01*(1.-exp(0.75*xlai))*xlai) + if(vegtyp == parameters%eblforest) leafpt = exp(0.01*(1.-exp(0.50*xlai))*xlai) + + nonlef = 1.0 - leafpt + stempt = xlai/10.0*leafpt + leafpt = leafpt - stempt + +! fraction of carbon into wood versus root + + if(wood.gt.0) then + woodf = (1.-exp(-bf*(parameters%wrrat*rtmass/wood))/bf)*parameters%wdpool + else + woodf = 0. + endif + + rootpt = nonlef*(1.-woodf) + woodpt = nonlef*woodf + +! leaf and root turnover per time step + + lftovr = parameters%ltovrc*5.e-7*lfmass + sttovr = parameters%ltovrc*5.e-7*stmass + rttovr = rtovrc*rtmass + wdtovr = 9.5e-10*wood + +! seasonal leaf die rate dependent on temp and water stress +! water stress is set to 1 at permanent wilting point + + sc = exp(-0.3*max(0.,tv-parameters%tdlef)) * (lfmass/120.) + sd = exp((wstres-1.)*wstrc) + dielf = lfmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc) + diest = stmass*1.e-6*(parameters%dilefw * sd + parameters%dilefc*sc) + +! calculate growth respiration for leaf, rtmass and wood + + grleaf = max(0.0,parameters%fragr*(leafpt*carbfx - rsleaf)) + grstem = max(0.0,parameters%fragr*(stempt*carbfx - rsstem)) + grroot = max(0.0,parameters%fragr*(rootpt*carbfx - rsroot)) + grwood = max(0.0,parameters%fragr*(woodpt*carbfx - rswood)) + +! impose lower t limit for photosynthesis + + addnpplf = max(0.,leafpt*carbfx - grleaf-rsleaf) + addnppst = max(0.,stempt*carbfx - grstem-rsstem) +! addnpplf = leafpt*carbfx - grleaf-rsleaf ! mb: test kjetil +! addnppst = stempt*carbfx - grstem-rsstem ! mb: test kjetil + if(tv.lt.parameters%tmin) addnpplf =0. + if(tv.lt.parameters%tmin) addnppst =0. + +! update leaf, root, and wood carbon +! avoid reducing leaf mass below its minimum value but conserve mass + + lfdel = (lfmass - lfmsmn)/dt + stdel = (stmass - stmsmn)/dt + dielf = min(dielf,lfdel+addnpplf-lftovr) + diest = min(diest,stdel+addnppst-sttovr) + +! net primary productivities + + nppl = max(addnpplf,-lfdel) + npps = max(addnppst,-stdel) + nppr = rootpt*carbfx - rsroot - grroot + nppw = woodpt*carbfx - rswood - grwood + +! masses of plant components + + lfmass = lfmass + (nppl-lftovr-dielf)*dt + stmass = stmass + (npps-sttovr-diest)*dt ! g/m2 + rtmass = rtmass + (nppr-rttovr) *dt + + if(rtmass.lt.0.0) then + rttovr = nppr + rtmass = 0.0 + endif + wood = (wood+(nppw-wdtovr)*dt)*parameters%wdpool + +! soil carbon budgets + + fastcp = fastcp + (rttovr+lftovr+sttovr+wdtovr+dielf+diest)*dt ! mb: add diest v3.7 + + fst = 2.0**( (stc(1)-283.16)/10. ) + fsw = wroot / (0.20+wroot) * 0.23 / (0.23+wroot) + rssoil = fsw * fst * parameters%mrp* max(0.,fastcp*1.e-3)*12.e-6 + + stablc = 0.1*rssoil + fastcp = fastcp - (rssoil + stablc)*dt + stblcp = stblcp + stablc*dt + +! total carbon flux + + cflux = - carbfx + rsleaf + rsroot + rswood + rsstem & ! mb: add rsstem,grstem,0.9*rssoil v3.7 + + 0.9*rssoil + grleaf + grroot + grwood + grstem ! g/m2/s + +! for outputs + + gpp = carbfx !g/m2/s c + npp = nppl + nppw + nppr +npps !g/m2/s c + autors = rsroot + rswood + rsleaf + rsstem + & !g/m2/s c mb: add rsstem, grstem v3.7 + grleaf + grroot + grwood + grstem !g/m2/s c mb: add 0.9* v3.7 + heters = 0.9*rssoil !g/m2/s c + nee = (autors + heters - gpp)*44./12. !g/m2/s co2 + totsc = fastcp + stblcp !g/m2 c + totlb = lfmass + rtmass +stmass + wood !g/m2 c mb: add stmass v3.7 + +! leaf area index and stem area index + + xlai = max(lfmass*lapm,laimin) + xsai = max(stmass*sapm,xsamin) + + end subroutine co2flux + +!== begin bvocflux ================================================================================= + +! subroutine bvocflux(parameters,vocflx, vegtyp, vegfrac, apar, tv ) +! +! ------------------------------------------------------------------------------------------ +! implicit none +! ------------------------------------------------------------------------------------------ +! +! ------------------------ code history --------------------------- +! source file: bvoc +! purpose: bvoc emissions +! description: +! volatile organic compound emission +! this code simulates volatile organic compound emissions +! following the algorithm presented in guenther, a., 1999: modeling +! biogenic volatile organic compound emissions to the atmosphere. in +! reactive hydrocarbons in the atmosphere, ch. 3 +! this model relies on the assumption that 90% of isoprene and monoterpene +! emissions originate from canopy foliage: +! e = epsilon * gamma * density * delta +! the factor delta (longterm activity factor) applies to isoprene emission +! from deciduous plants only. we neglect this factor at the present time. +! this factor is discussed in guenther (1997). +! subroutine written to operate at the patch level. +! in final implementation, remember: +! 1. may wish to call this routine only as freq. as rad. calculations +! 2. may wish to place epsilon values directly in pft-physiology file +! ------------------------ input/output variables ----------------- +! input +! integer ,intent(in) :: vegtyp !vegetation type +! real ,intent(in) :: vegfrac !green vegetation fraction [0.0-1.0] +! real ,intent(in) :: apar !photosynthesis active energy by canopy (w/m2) +! real ,intent(in) :: tv !vegetation canopy temperature (k) +! +! output +! real ,intent(out) :: vocflx(5) ! voc fluxes [ug c m-2 h-1] +! +! local variables +! +! real, parameter :: r = 8.314 ! univ. gas constant [j k-1 mol-1] +! real, parameter :: alpha = 0.0027 ! empirical coefficient +! real, parameter :: cl1 = 1.066 ! empirical coefficient +! real, parameter :: ct1 = 95000.0 ! empirical coefficient [j mol-1] +! real, parameter :: ct2 = 230000.0 ! empirical coefficient [j mol-1] +! real, parameter :: ct3 = 0.961 ! empirical coefficient +! real, parameter :: tm = 314.0 ! empirical coefficient [k] +! real, parameter :: tstd = 303.0 ! std temperature [k] +! real, parameter :: bet = 0.09 ! beta empirical coefficient [k-1] +! +! integer ivoc ! do-loop index +! integer ityp ! do-loop index +! real epsilon(5) +! real gamma(5) +! real density +! real elai +! real par,cl,reciprod,ct +! +! epsilon : +! +! do ivoc = 1, 5 +! epsilon(ivoc) = parameters%eps(vegtyp,ivoc) +! end do +! +! gamma : activity factor. units [dimensionless] +! +! reciprod = 1. / (r * tv * tstd) +! ct = exp(ct1 * (tv - tstd) * reciprod) / & +! (ct3 + exp(ct2 * (tv - tm) * reciprod)) +! +! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) +! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) +! +! gamma(1) = cl * ct ! for isoprenes +! +! do ivoc = 2, 5 +! gamma(ivoc) = exp(bet * (tv - tstd)) +! end do +! +! foliage density +! +! transform vegfrac to lai +! +! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) +! density = elai / (parameters%slarea(vegtyp) * 0.5) +! +! calculate the voc flux +! +! do ivoc = 1, 5 +! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density +! end do +! +! end subroutine bvocflux +! ================================================================================================== +! ********************************* end of carbon subroutines ***************************** +! ================================================================================================== + +!== begin noahmp_options =========================================================================== + + subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + implicit none + + integer, intent(in) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + integer, intent(in) :: iopt_crs !canopy stomatal resistance (1-> ball-berry; 2->jarvis) + integer, intent(in) :: iopt_btr !soil moisture factor for stomatal resistance (1-> noah; 2-> clm; 3-> ssib) + integer, intent(in) :: iopt_run !runoff and groundwater (1->simgm; 2->simtop; 3->schaake96; 4->bats) + integer, intent(in) :: iopt_sfc !surface layer drag coeff (ch & cm) (1->m-o; 2->chen97) + integer, intent(in) :: iopt_frz !supercooled liquid water (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_inf !frozen soil permeability (1-> ny06; 2->koren99) + integer, intent(in) :: iopt_rad !radiation transfer (1->gap=f(3d,cosz); 2->gap=0; 3->gap=1-fveg) + integer, intent(in) :: iopt_alb !snow surface albedo (1->bats; 2->class) + integer, intent(in) :: iopt_snf !rainfall & snowfall (1-jordan91; 2->bats; 3->noah) + integer, intent(in) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->noah) + + integer, intent(in) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original noah) + +! ------------------------------------------------------------------------------------------------- + + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + + end subroutine noahmp_options + + +end module module_sf_noahmplsm + + diff --git a/gsmphys/module_wrf_utl.f90 b/gsmphys/module_wrf_utl.f90 new file mode 100644 index 00000000..3c3c4426 --- /dev/null +++ b/gsmphys/module_wrf_utl.f90 @@ -0,0 +1,53 @@ +module module_wrf_utl + implicit none +contains + +subroutine wrf_error_fatal(string) + implicit none + character(len=*), intent(in) :: string + print*, string + stop +end subroutine wrf_error_fatal + +subroutine wrf_message(msg) + implicit none + character(len=*), intent(in) :: msg + write(*,'(A)') msg +end subroutine wrf_message + +logical function wrf_dm_on_monitor() result (return_value) + implicit none + return_value = .TRUE. +end function wrf_dm_on_monitor + +subroutine wrf_dm_bcast_real(rval, ival) + implicit none + real, intent(in) :: rval + integer, intent(in) :: ival +end subroutine wrf_dm_bcast_real + +subroutine wrf_dm_bcast_integer(ival1, ival2) + implicit none + real, intent(in) :: ival1 + integer, intent(in) :: ival2 +end subroutine wrf_dm_bcast_integer + +subroutine wrf_dm_bcast_string(sval, ival) + implicit none + character(len=*), intent(in) :: sval + integer, intent(in) :: ival +end subroutine wrf_dm_bcast_string + +subroutine wrf_debug( level , str ) + implicit none + character*(*) str + integer , intent (in) :: level + call wrf_message( str ) + return +end subroutine wrf_debug + +end module module_wrf_utl + + + + diff --git a/gsmphys/moninedmf.f b/gsmphys/moninedmf.f new file mode 100755 index 00000000..1c42c6d7 --- /dev/null +++ b/gsmphys/moninedmf.f @@ -0,0 +1,1307 @@ +!> \file moninedmf.f +!! Contains most of the hybrid eddy-diffusivity mass-flux scheme except for the +!! subroutine that calculates the mass flux and updraft properties. + +!> \defgroup PBL Hybrid Eddy-diffusivity Mass-flux Scheme +!! @{ +!! \brief The Hybrid EDMF scheme is a first-order turbulent transport scheme used for subgrid-scale vertical turbulent mixing in the PBL and above. It blends the traditional first-order approach that has been used and improved over the last several years with a more recent scheme that uses a mass-flux approach to calculate the countergradient diffusion terms. +!! +!! The PBL scheme's main task is to calculate tendencies of temperature, moisture, and momentum due to vertical diffusion throughout the column (not just the PBL). The scheme is an amalgamation of decades of work, starting from the initial first-order PBL scheme of Troen and Mahrt (1986) \cite troen_and_mahrt_1986, implemented according to Hong and Pan (1996) \cite hong_and_pan_1996 and modified by Han and Pan (2011) \cite han_and_pan_2011 and Han et al. (2015) \cite han_et_al_2015 to include top-down mixing due to stratocumulus layers from Lock et al. (2000) \cite lock_et_al_2000 and replacement of counter-gradient terms with a mass flux scheme according to Siebesma et al. (2007) \cite siebesma_et_al_2007 and Soares et al. (2004) \cite soares_et_al_2004. Recently, heating due to TKE dissipation was also added according to Han et al. (2015) \cite han_et_al_2015. +!! +!! \section diagram Calling Hierarchy Diagram +!! \image html Hybrid_EDMF_Flowchart.png "Diagram depicting how the Hybrid EDMF PBL scheme is called from the GSM physics time loop" height=2cm +!! \section intraphysics Intraphysics Communication +!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. + +!> \brief This subroutine contains all of logic for the Hybrid EDMF PBL scheme except for the calculation of the updraft properties and mass flux. +!! +!! The scheme works on a basic level by calculating background diffusion coefficients and updating them according to which processes are occurring in the column. The most important difference in diffusion coefficients occurs between those levels in the PBL and those above the PBL, so the PBL height calculation is of utmost importance. An initial estimate is calculated in a "predictor" step in order to calculate Monin-Obukhov similarity values and a corrector step recalculates the PBL height based on updated surface thermal characteristics. Using the PBL height and the similarity parameters, the diffusion coefficients are updated below the PBL top based on Hong and Pan (1996) \cite hong_and_pan_1996 (including counter-gradient terms). Diffusion coefficients in the free troposphere (above the PBL top) are calculated according to Louis (1979) \cite louis_1979 with updated Richardson number-dependent functions. If it is diagnosed that PBL top-down mixing is occurring according to Lock et al. (2000) \cite lock_et_al_2000 , then then diffusion coefficients are updated accordingly. Finally, for convective boundary layers (defined as when the Obukhov length exceeds a threshold), the counter-gradient terms are replaced using the mass flux scheme of Siebesma et al. (2007) \cite siebesma_et_al_2007 . In order to return time tendencies, a fully implicit solution is found using tridiagonal matrices, and time tendencies are "backed out." Before returning, the time tendency of temperature is updated to reflect heating due to TKE dissipation following Han et al. (2015) \cite han_et_al_2015 . +!! +!! \param[in] ix horizontal dimension +!! \param[in] im number of used points +!! \param[in] km vertical layer dimension +!! \param[in] ntrac number of tracers +!! \param[in] ntcw cloud condensate index in the tracer array +!! \param[in,out] dv v-momentum tendency (\f$ m s^{-2} \f$) +!! \param[in,out] du u-momentum tendency (\f$ m s^{-2} \f$) +!! \param[in,out] tau temperature tendency (\f$ K s^{-1} \f$) +!! \param[in,out] rtg moisture tendency (\f$ kg kg^{-1} s^{-1} \f$) +!! \param[in] u1 u component of layer wind (\f$ m s^{-1} \f$) +!! \param[in] v1 v component of layer wind (\f$ m s^{-1} \f$) +!! \param[in] t1 layer mean temperature (\f$ K \f$) +!! \param[in] q1 layer mean tracer concentration (units?) +!! \param[in] swh total sky shortwave heating rate (\f$ K s^-1 \f$) +!! \param[in] hlw total sky longwave heating rate (\f$ K s^-1 \f$) +!! \param[in] xmu time step zenith angle adjust factor for shortwave +!! \param[in] psk Exner function at surface interface? +!! \param[in] rbsoil surface bulk Richardson number +!! \param[in] zorl surface roughness (units?) +!! \param[in] u10m 10-m u wind (\f$ m s^{-1} \f$) +!! \param[in] v10m 10-m v wind (\f$ m s^{-1} \f$) +!! \param[in] fm fm parameter from PBL scheme +!! \param[in] fh fh parameter from PBL scheme +!! \param[in] tsea ground surface temperature (K) +!! \param[in] qss surface saturation humidity (units?) +!! \param[in] heat surface sensible heat flux (units?) +!! \param[in] evap evaporation from latent heat flux (units?) +!! \param[in] stress surface wind stress? (\f$ cm*v^2\f$ in sfc_diff subroutine) (units?) +!! \param[in] spd1 surface wind speed? (units?) +!! \param[out] kpbl PBL top index +!! \param[in] prsi pressure at layer interfaces (units?) +!! \param[in] del pressure difference between level k and k+1 (units?) +!! \param[in] prsl mean layer pressure (units?) +!! \param[in] prslk Exner function at layer +!! \param[in] phii interface geopotential height (units?) +!! \param[in] phil layer geopotential height (units?) +!! \param[in] delt physics time step (s) +!! \param[in] dspheat flag for TKE dissipative heating +!! \param[out] dusfc surface u-momentum tendency (units?) +!! \param[out] dvsfc surface v-momentum tendency (units?) +!! \param[out] dtsfc surface temperature tendency (units?) +!! \param[out] dqsfc surface moisture tendency (units?) +!! \param[out] hpbl PBL top height (m) +!! \param[out] hgamt counter gradient mixing term for temperature (units?) +!! \param[out] hgamq counter gradient mixing term for moisture (units?) +!! \param[out] dkt diffusion coefficient for temperature (units?) +!! \param[in] kinver index location of temperature inversion +!! \param[in] xkzm_m background vertical diffusion coefficient for momentum (units?) +!! \param[in] xkzm_h background vertical diffusion coefficeint for heat, moisture (units?) +!! \param[in] xkzm_s sigma threshold for background momentum diffusion (units?) +!! \param[in] lprnt flag to print some output +!! \param[in] ipr index of point to print +!! +!! \section general General Algorithm +!! -# Compute preliminary variables from input arguments. +!! -# Calculate the first estimate of the PBL height ("Predictor step"). +!! -# Calculate Monin-Obukhov similarity parameters. +!! -# Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). +!! -# Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion. +!! -# Calculate the inverse Prandtl number. +!! -# Compute diffusion coefficients below the PBL top. +!! -# Compute diffusion coefficients above the PBL top. +!! -# If the PBL is convective, call the mass flux scheme to replace the countergradient terms. +!! -# Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs. +!! -# Solve for the temperature and moisture tendencies due to vertical mixing. +!! -# Calculate heating due to TKE dissipation and add to the tendency for temperature. +!! -# Solve for the horizontal momentum tendencies and add them to output tendency terms. +!! \section detailed Detailed Algorithm +!! @{ + subroutine moninedmf(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, & + & u1,v1,t1,q1,swh,hlw,xmu, & + & psk,rbsoil,zorl,u10m,v10m,fm,fh, & + & tsea,qss,heat,evap,stress,spd1,kpbl, & + & prsi,del,prsl,prslk,phii,phil,delt,dspheat, & + & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, & + & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, & + & xkzminv,moninq_fac) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, hvap => con_hvap, fv => con_fvirt + implicit none +! +! arguments +! + logical lprnt + integer ipr + integer ix, im, km, ntrac, ntcw, kpbl(im), kinver(im) +! + real(kind=kind_phys) delt, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys) dv(im,km), du(im,km), & + & tau(im,km), rtg(im,km,ntrac), & + & u1(ix,km), v1(ix,km), & + & t1(ix,km), q1(ix,km,ntrac), & + & swh(ix,km), hlw(ix,km), & + & xmu(im), psk(im), & + & rbsoil(im), zorl(im), & + & u10m(im), v10m(im), & + & fm(im), fh(im), & + & tsea(im), qss(im), & + & spd1(im), & + & prsi(ix,km+1), del(ix,km), & + & prsl(ix,km), prslk(ix,km), & + & phii(ix,km+1), phil(ix,km), & + & dusfc(im), dvsfc(im), & + & dtsfc(im), dqsfc(im), & + & hpbl(im), hpblx(im), & + & hgamt(im), hgamq(im) +! + logical dspheat +! flag for tke dissipative heating +! +! locals +! + integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond + integer lcld(im),icld(im),kcld(im),krad(im) + integer kx1(im), kpblx(im) +! +! real(kind=kind_phys) betaq(im), betat(im), betaw(im), + real(kind=kind_phys) evap(im), heat(im), phih(im), & + & phim(im), rbdn(im), rbup(im), & + & stress(im),beta(im), sflux(im), & + & z0(im), crb(im), wstar(im), & + & zol(im), ustmin(im), ustar(im), & + & thermal(im),wscale(im), wscaleu(im) +! + real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), & + & qlx(im,km), thetae(im,km), & + & qtx(im,km), bf(im,km-1), diss(im,km), & + & radx(im,km-1), & + & govrth(im), hrad(im), & +! & hradm(im), radmin(im), vrad(im), & + & radmin(im), vrad(im), & + & zd(im), zdd(im), thlvx1(im) +! + real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1), & + & zi(im,km+1), zl(im,km), xkzo(im,km-1), & + & dku(im,km-1), dkt(im,km-1), xkzmo(im,km-1), & + & cku(im,km-1), ckt(im,km-1), & + & ti(im,km-1), shr2(im,km-1), & + & al(im,km-1), ad(im,km), & + & au(im,km-1), a1(im,km), & + & a2(im,km*ntrac) +! + real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), & + & ucko(im,km), vcko(im,km), xmf(im,km) +! + real(kind=kind_phys) prinv(im), rent(im) +! + logical pblflg(im), sfcflg(im), scuflg(im), flg(im) + logical ublflg(im), pcnvflg(im) +! +! pcnvflg: true for convective(strongly unstable) pbl +! ublflg: true for unstable but not convective(strongly unstable) pbl +! + real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, + & cfac, conq, cont, conw, + & dk, dkmax, dkmin, + & dq1, dsdz2, dsdzq, dsdzt, + & dsdzu, dsdzv, + & dsig, dt2, dthe1, dtodsd, + & dtodsu, dw2, dw2min, g, + & gamcrq, gamcrt, gocp, + & gravi, f0, + & prnum, prmax, prmin, pfac, crbcon, + & qmin, tdzmin, qtend, crbmin,crbmax, + & rbint, rdt, rdz, qlmin, + & ri, rimin, rl2, rlam, rlamun, + & rone, rzero, sfcfrac, + & spdk2, sri, zol1, zolcr, zolcru, + & robn, ttend, + & utend, vk, vk2, + & ust3, wst3, + & vtend, zfac, vpert, cteit, + & rentf1, rentf2, radfac, + & zfmin, zk, tem, tem1, tem2, + & xkzm, xkzmu, xkzminv, + & ptem, ptem1, ptem2, tx1(im), tx2(im) +! + real(kind=kind_phys) moninq_fac +! + real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, + & cldtime +cc + parameter(gravi=1.0/grav) + parameter(g=grav) + parameter(gocp=g/cp) + parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa +! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa + parameter(rlam=30.0,vk=0.4,vk2=vk*vk) + parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5) + parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) + parameter(crbcon=0.25,crbmin=0.15,crbmax=0.35) + parameter(wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) +! parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(qmin=1.e-8, zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(tdzmin=1.e-3,qlmin=1.e-12,f0=1.e-4) + parameter(h1=0.33333333,h2=0.66666667) +! parameter(cldtime=500.,xkzminv=0.3) + parameter(cldtime=500.) +! parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3) +! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) + parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) + parameter(rentf1=0.2,rentf2=1.0,radfac=0.85) + parameter(iun=84) +! +! parameter (zstblmax = 2500., qlcr=1.0e-5) +! parameter (zstblmax = 2500., qlcr=3.0e-5) +! parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (zstblmax = 2500., qlcr=1.0e-4) + parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (actei = 0.23) + parameter (actei = 0.7) +c +c----------------------------------------------------------------------- +c + 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) + 602 format(1x,' k',' z',' t',' th', + 1 ' tvh',' q',' u',' v', + 2 ' sp') + 603 format(1x,i5,8f9.1) + 604 format(1x,' sfc',9x,f9.1,18x,f9.1) + 605 format(1x,' k zl spd2 thekv the1v' + 1 ,' thermal rbup') + 606 format(1x,i5,6f8.2) + 607 format(1x,' kpbl hpbl fm fh hgamt', + 1 ' hgamq ws ustar cd ch') + 608 format(1x,i5,9f8.2) + 609 format(1x,' k pr dkt dku ',i5,3f8.2) + 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', + 1 ' sr2 ',2f8.2,2e10.2) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +!> ## Compute preliminary variables from input arguments + +! compute preliminary variables +! + if (ix .lt. im) stop +! +! iprt = 0 +! if(iprt.eq.1) then +!cc latd = 0 +! lond = 0 +! else +!cc latd = 0 +! lond = 0 +! endif +! + dt2 = delt + rdt = 1. / dt2 + km1 = km - 1 + kmpbl = km / 2 +!> - Compute physical height of the layer centers and interfaces from the geopotential height (zi and zl) + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo +!> - Compute reciprocal of \f$ \Delta z \f$ (rdzt) + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + enddo + enddo +!> - Compute reciprocal of pressure (tx1, tx2) + do i=1,im + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + enddo +!> - Compute background vertical diffusivities for scalars and momentum (xkzo and xkzmo) + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) + +! vertical background diffusivity for momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_m + kx1(i) = k + 1 + else + if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) + tem1 = 1.0 - prsi(i,k+1) * tx2(i) + tem1 = tem1 * tem1 * 5.0 + xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! if (lprnt) then +! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) +! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) +! endif +! +! diffusivity in the inversion layer is set to be xkzminv (m^2/s) +!> - The background scalar vertical diffusivity is limited to be less than or equal to xkzminv + do k = 1,kmpbl + do i=1,im +! if(zi(i,k+1) > 200..and.zi(i,k+1) < zstblmax) then + if(zi(i,k+1) > 250.) then + tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) + if(tem1 > 1.e-5) then + xkzo(i,k) = min(xkzo(i,k),xkzminv) + endif + endif + enddo + enddo +!> - Some output variables and logical flags are initialized + do i = 1,im + z0(i) = 0.01 * zorl(i) + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + wscale(i)= 0. + wscaleu(i)= 0. + kpbl(i) = 1 + hpbl(i) = zi(i,1) + hpblx(i) = zi(i,1) + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + ublflg(i)= .false. + pcnvflg(i)= .false. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + rent(i) = rentf1 + hrad(i) = zi(i,1) +! hradm(i) = zi(i,1) + krad(i) = 1 + icld(i) = 0 + lcld(i) = km1 + kcld(i) = km1 + zd(i) = 0. + endif + enddo +!> - Compute \f$\theta\f$ (theta), \f$q_l\f$ (qlx), \f$q_t\f$ (qtx), \f$\theta_e\f$ (thetae), \f$\theta_v\f$ (thvx), \f$\theta_{l,v}\f$ (thlvx) + do k = 1,km + do i = 1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + qlx(i,k) = max(q1(i,k,ntcw),qlmin) + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + ptem = qlx(i,k) + ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) + thetae(i,k)= theta(i,k)*(1.+ptem1) + thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) !lowest layer virtual potential temperature + ptem2 = theta(i,k)-(hvap/cp)*ptem + thlvx(i,k) = ptem2*(1.+fv*qtx(i,k)) + enddo + enddo +!> - Initialize diffusion coefficients to 0 and calculate the total radiative heating rate (dku, dkt, radx) + do k = 1,km1 + do i = 1,im + dku(i,k) = 0. + dkt(i,k) = 0. + dktx(i,k) = 0. + cku(i,k) = 0. + ckt(i,k) = 0. + tem = zi(i,k+1)-zi(i,k) + radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) + enddo + enddo +!> - Set lcld to first index above 2.5km + do i=1,im + flg(i) = scuflg(i) + enddo + do k = 1, km1 + do i=1,im + if(flg(i).and.zl(i,k) >= zstblmax) then + lcld(i)=k + flg(i)=.false. + endif + enddo + enddo +! +! compute virtual potential temp gradient (bf) and winshear square +!> - Compute \f$\frac{\partial \theta_v}{\partial z}\f$ (bf) and the wind shear squared (shr2) + do k = 1, km1 + do i = 1, im + rdz = rdzt(i,k) + bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdz + ti(i,k) = 2./(t1(i,k)+t1(i,k+1)) + dw2 = (u1(i,k)-u1(i,k+1))**2 + & + (v1(i,k)-v1(i,k+1))**2 + shr2(i,k) = max(dw2,dw2min)*rdz*rdz + enddo + enddo +!> - Calculate \f$\frac{g}{\theta}\f$ (govrth), \f$\beta = \frac{\Delta t}{\Delta z}\f$ (beta), \f$u_*\f$ (ustar), total surface flux (sflux), and set pblflag to false if the total surface energy flux is into the surface + do i = 1,im + govrth(i) = g/theta(i,1) + enddo +! + do i=1,im + beta(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! + do i=1,im + ustar(i) = sqrt(stress(i)) + enddo +! + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + enddo +!> ## Calculate the first estimate of the PBL height (``Predictor step") +!! The calculation of the boundary layer height follows Troen and Mahrt (1986) \cite troen_and_mahrt_1986 section 3. The approach is to find the level in the column where a modified bulk Richardson number exceeds a critical value. +!! +!! The temperature of the thermal is of primary importance. For the initial estimate of the PBL height, the thermal is assumed to have one of two temperatures. If the boundary layer is stable, the thermal is assumed to have a temperature equal to the surface virtual temperature. Otherwise, the thermal is assumed to have the same virtual potential temperature as the lowest model level. For the stable case, the critical bulk Richardson number becomes a function of the wind speed and roughness length, otherwise it is set to a tunable constant. +! compute the pbl height +! + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) +! + if(pblflg(i)) then !unstable + thermal(i) = thvx(i,1) + crb(i) = crbcon + else !stable (requires surface virtual temperature) + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + enddo +!> Given the thermal's properties and the critical Richardson number, a loop is executed to find the first level above the surface where the modified Richardson number is greater than the critical Richardson number, using equation 10a from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 (also equation 8 from Hong and Pan (1996) \cite hong_and_pan_1996): +!! \f[ +!! h = Ri\frac{T_0\left|\vec{v}(h)\right|^2}{g\left(\theta_v(h) - \theta_s\right)} +!! \f] +!! where \f$h\f$ is the PBL height, \f$Ri\f$ is the Richardson number, \f$T_0\f$ is the virtual potential temperature near the surface, \f$\left|\vec{v}\right|\f$ is the wind speed, and \f$\theta_s\f$ is for the thermal. Rearranging this equation to calculate the modified Richardson number at each level, k, for comparison with the critical value yields: +!! \f[ +!! Ri_k = gz(k)\frac{\left(\theta_v(k) - \theta_s\right)}{\theta_v(1)*\vec{v}(k)} +!! \f] + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo +!> Once the level is found, some linear interpolation is performed to find the exact height of the boundary layer top (where \f$Ri = Ri_{cr}\f$) and the PBL height and the PBL top index are saved (hpblx and kpblx, respectively) + do i = 1,im + if(kpbl(i) > 1) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + else + hpbl(i) = zl(i,1) + kpbl(i) = 1 + endif + kpblx(i) = kpbl(i) + hpblx(i) = hpbl(i) + enddo +! +! compute similarity parameters +!> ## Calculate Monin-Obukhov similarity parameters +!! Using the initial guess for the PBL height, Monin-Obukhov similarity parameters are calculated. They are needed to refine the PBL height calculation and for calculating diffusion coefficients. +!! +!! First, calculate the Monin-Obukhov nondimensional stability parameter, commonly referred to as \f$\zeta\f$ using the following equation from Businger et al. (1971) \cite businger_et_al_1971 (equation 28): +!! \f[ +!! \zeta = Ri_{sfc}\frac{F_m^2}{F_h} = \frac{z}{L} +!! \f] +!! where \f$F_m\f$ and \f$F_h\f$ are surface Monin-Obukhov stability functions calculated in sfc_diff.f and \f$L\f$ is the Obukhov length. Then, the nondimensional gradients of momentum and temperature (phim and phih) are calculated using equations 5 and 6 from Hong and Pan (1996) \cite hong_and_pan_1996 depending on the surface layer stability. Then, the velocity scale valid for the surface layer (\f$w_s\f$, wscale) is calculated using equation 3 from Hong and Pan (1996) \cite hong_and_pan_1996. For the neutral and unstable PBL above the surface layer, the convective velocity scale, \f$w_*\f$, is calculated according to: +!! \f[ +!! w_* = \left(\frac{g}{\theta_0}h\overline{w'\theta_0'}\right)^{1/3} +!! \f] +!! and the mixed layer velocity scale is then calculated with equation 6 from Troen and Mahrt (1986) \cite troen_and_mahrt_1986 +!! \f[ +!! w_s = (u_*^3 + 7\epsilon k w_*^3)^{1/3} +!! \f] + do i=1,im + zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + if(sfcflg(i)) then + zol(i) = min(zol(i),-zfmin) + else + zol(i) = max(zol(i),zfmin) + endif + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then +! phim(i) = (1.-aphi16*zol1)**(-1./4.) +! phih(i) = (1.-aphi16*zol1)**(-1./2.) + tem = 1.0 / (1. - aphi16*zol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + endif + wscale(i) = ustar(i)/phim(i) + ustmin(i) = ustar(i)/aphi5 + wscale(i) = max(wscale(i),ustmin(i)) + enddo + do i=1,im + if(pblflg(i)) then + if(zol(i) < zolcru .and. kpbl(i) > 1) then + pcnvflg(i) = .true. + else + ublflg(i) = .true. + endif + wst3 = govrth(i)*sflux(i)*hpbl(i) + wstar(i)= wst3**h1 + ust3 = ustar(i)**3. + wscaleu(i) = (ust3+wfac*vk*wst3*sfcfrac)**h1 + wscaleu(i) = max(wscaleu(i),ustmin(i)) + endif + enddo +! +! compute counter-gradient mixing term for heat and moisture +!> ## Update thermal properties of surface parcel and recompute PBL height ("Corrector step"). +!! Next, the counter-gradient terms for temperature and humidity are calculated using equation 4 of Hong and Pan (1996) \cite hong_and_pan_1996 and are used to calculate the "scaled virtual temperature excess near the surface" (equation 9 in Hong and Pan (1996) \cite hong_and_pan_1996) so that the properties of the thermal are updated to recalculate the PBL height. + do i = 1,im + if(ublflg(i)) then + hgamt(i) = min(cfac*heat(i)/wscaleu(i),gamcrt) + hgamq(i) = min(cfac*evap(i)/wscaleu(i),gamcrq) + vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert = min(vpert,gamcrt) + thermal(i)= thermal(i)+max(vpert,0.) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + endif + enddo +! +! enhance the pbl height by considering the thermal excess +!> The PBL height calculation follows the same procedure as the predictor step, except that it uses an updated virtual potential temperature for the thermal. + do i=1,im + flg(i) = .true. + if(ublflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(ublflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + if(kpbl(i) <= 1) then + ublflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! +! look for stratocumulus +!> ## Determine whether stratocumulus layers exist and compute quantities needed for enhanced diffusion +!! - Starting at the PBL top and going downward, if the level is less than 2.5 km and \f$q_l>q_{l,cr}\f$ then set kcld = k (find the cloud top index in the PBL). If no cloud water above the threshold is found, scuflg is set to F. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i) .and. k <= lcld(i)) then + if(qlx(i,k).ge.qlcr) then + kcld(i)=k + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false. + enddo +!> - Starting at the PBL top and going downward, if the level is less than the cloud top, find the level of the minimum radiative heating rate within the cloud. If the level of the minimum is the lowest model level or the minimum radiative heating rate is positive, then set scuflg to F. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i) .and. k <= kcld(i)) then + if(qlx(i,k) >= qlcr) then + if(radx(i,k) < radmin(i)) then + radmin(i)=radx(i,k) + krad(i)=k + endif + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false. + if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false. + enddo +!> - Starting at the PBL top and going downward, count the number of levels below the minimum radiative heating rate level that have cloud water above the threshold. If there are none, then set the scuflg to F. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,2,-1 + do i = 1, im + if(flg(i) .and. k <= krad(i)) then + if(qlx(i,k) >= qlcr) then + icld(i)=icld(i)+1 + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. icld(i) < 1) scuflg(i)=.false. + enddo +!> - Find the height of the interface where the minimum in radiative heating rate is located. If this height is less than the second model interface height, then set the scuflg to F. + do i = 1, im + if(scuflg(i)) then + hrad(i) = zi(i,krad(i)+1) +! hradm(i)= zl(i,krad(i)) + endif + enddo +! + do i = 1, im + if(scuflg(i) .and. hrad(i) - Calculate the hypothetical \f$\theta_v\f$ at the minimum radiative heating level that a parcel would reach due to radiative cooling after a typical cloud turnover time spent at that level. + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = zi(i,k+1)-zi(i,k) + tem1 = cldtime*radmin(i)/tem + thlvx1(i) = thlvx(i,k)+tem1 +! if(thlvx1(i) > thlvx(i,k-1)) scuflg(i)=.false. + endif + enddo +!> - Determine the distance that a parcel would sink downwards starting from the level of minimum radiative heating rate by comparing the hypothetical minimum \f$\theta_v\f$ calculated above with the environmental \f$\theta_v\f$. + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i) .and. k <= krad(i))then + if(thlvx1(i) <= thlvx(i,k))then + tem=zi(i,k+1)-zi(i,k) + zd(i)=zd(i)+tem + else + flg(i)=.false. + endif + endif + enddo + enddo +!> - Calculate the cloud thickness, where the cloud top is the in-cloud minimum radiative heating level and the bottom is determined previously. + do i = 1, im + if(scuflg(i))then + kk = max(1, krad(i)+1-icld(i)) + zdd(i) = hrad(i)-zi(i,kk) + endif + enddo +!> - Find the largest between the cloud thickness and the distance of a sinking parcel, then determine the smallest of that number and the height of the minimum in radiative heating rate. Set this number to \f$zd\f$. Using \f$zd\f$, calculate the characteristic velocity scale of cloud-top radiative cooling-driven turbulence. + do i = 1, im + if(scuflg(i))then + zd(i) = max(zd(i),zdd(i)) + zd(i) = min(zd(i),hrad(i)) + tem = govrth(i)*zd(i)*(-radmin(i)) + vrad(i)= tem**h1 + endif + enddo +! +! compute inverse prandtl number +!> ## Calculate the inverse Prandtl number +!! For an unstable PBL, the Prandtl number is calculated according to Hong and Pan (1996) \cite hong_and_pan_1996, equation 10, whereas for a stable boundary layer, the Prandtl number is simply \f$Pr = \frac{\phi_h}{\phi_m}\f$. + do i = 1, im + if(ublflg(i)) then + tem = phih(i)/phim(i)+cfac*vk*sfcfrac + else + tem = phih(i)/phim(i) + endif + prinv(i) = 1.0 / tem + prinv(i) = min(prinv(i),prmax) + prinv(i) = max(prinv(i),prmin) + enddo + do i = 1, im + if(zol(i) > zolcr) then + kpbl(i) = 1 + endif + enddo +! +! compute diffusion coefficients below pbl +!> ## Compute diffusion coefficients below the PBL top +!! Below the PBL top, the diffusion coefficients (\f$K_m\f$ and \f$K_h\f$) are calculated according to equation 2 in Hong and Pan (1996) \cite hong_and_pan_1996 where a different value for \f$w_s\f$ (PBL vertical velocity scale) is used depending on the PBL stability. \f$K_h\f$ is calculated from \f$K_m\f$ using the Prandtl number. The calculated diffusion coefficients are checked so that they are bounded by maximum values and the local background diffusion coefficients. + do k = 1, kmpbl + do i=1,im + if(k < kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = zi(i,k+1) * (zfac**pfac) * moninq_fac ! lmh suggested by kg + if(pblflg(i)) then + tem1 = vk * wscaleu(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + else + tem1 = vk * wscale(i) * tem +! dku(i,k) = xkzmo(i,k) + tem1 +! dkt(i,k) = xkzo(i,k) + tem1 * prinv(i) + dku(i,k) = tem1 + dkt(i,k) = tem1 * prinv(i) + endif + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + endif + enddo + enddo +! +! compute diffusion coefficients based on local scheme above pbl +!> ## Compute diffusion coefficients above the PBL top +!! Diffusion coefficients above the PBL top are computed as a function of local stability (gradient Richardson number), shear, and a length scale from Louis (1979) \cite louis_1979 : +!! \f[ +!! K_{m,h}=l^2f_{m,h}(Ri_g)\left|\frac{\partial U}{\partial z}\right| +!! \f] +!! The functions used (\f$f_{m,h}\f$) depend on the local stability. First, the gradient Richardson number is calculated as +!! \f[ +!! Ri_g=\frac{\frac{g}{T}\frac{\partial \theta_v}{\partial z}}{\frac{\partial U}{\partial z}^2} +!! \f] +!! where \f$U\f$ is the horizontal wind. For the unstable case (\f$Ri_g < 0\f$), the Richardson number-dependent functions are given by +!! \f[ +!! f_h(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.286\sqrt{\left|Ri_g\right|}}\\ +!! \f] +!! \f[ +!! f_m(Ri_g) = 1 + \frac{8\left|Ri_g\right|}{1 + 1.746\sqrt{\left|Ri_g\right|}}\\ +!! \f] +!! For the stable case, the following formulas are used +!! \f[ +!! f_h(Ri_g) = \frac{1}{\left(1 + 5Ri_g\right)^2}\\ +!! \f] +!! \f[ +!! Pr = \frac{K_h}{K_m} = 1 + 2.1Ri_g +!! \f] +!! The source for the formulas used for the Richardson number-dependent functions is unclear. They are different than those used in Hong and Pan (1996) \cite hong_and_pan_1996 as the previous documentation suggests. They follow equation 14 of Louis (1979) \cite louis_1979 for the unstable case, but it is unclear where the values of the coefficients \f$b\f$ and \f$c\f$ from that equation used in this scheme originate. Finally, the length scale, \f$l\f$ is calculated according to the following formula from Hong and Pan (1996) \cite hong_and_pan_1996 +!! \f[ +!! \frac{1}{l} = \frac{1}{kz} + \frac{1}{l_0}\\ +!! \f] +!! \f[ +!! or\\ +!! \f] +!! \f[ +!! l=\frac{l_0kz}{l_0+kz} +!! \f] +!! where \f$l_0\f$ is currently 30 m for stable conditions and 150 m for unstable. Finally, the diffusion coefficients are kept in a range bounded by the background diffusion and the maximum allowable values. + do k = 1, km1 + do i=1,im + if(k >= kpbl(i)) then + bvf2 = g*bf(i,k)*ti(i,k) + ri = max(bvf2/shr2(i,k),rimin) + zk = vk*zi(i,k+1) + if(ri < 0.) then ! unstable regime + rl2 = zk*rlamun/(rlamun+zk) + dk = rl2*rl2*sqrt(shr2(i,k)) + sri = sqrt(-ri) +! dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri)) +! dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) + dku(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + dkt(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else ! stable regime + rl2 = zk*rlam/(rlam+zk) +!! tem = rlam * sqrt(0.01*prsi(i,k)) +!! rl2 = zk*tem/(tem+zk) + dk = rl2*rl2*sqrt(shr2(i,k)) + tem1 = dk/(1+5.*ri)**2 +! + if(k >= kpblx(i)) then + prnum = 1.0 + 2.1*ri + prnum = min(prnum,prmax) + else + prnum = 1.0 + endif +! dku(i,k) = xkzmo(i,k) + tem1 * prnum +! dkt(i,k) = xkzo(i,k) + tem1 + dku(i,k) = tem1 * prnum + dkt(i,k) = tem1 + endif +! + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) +! + endif +! + enddo + enddo +! + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute components for mass flux mixing by large thermals +!> ## If the PBL is convective, call the mass flux scheme to replace the countergradient terms. +!! If the PBL is convective, the updraft properties are initialized to be the same as the state variables and the subroutine mfpbl is called. + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + tcko(i,k) = t1(i,k) + ucko(i,k) = u1(i,k) + vcko(i,k) = v1(i,k) + xmf(i,k) = 0. + endif + enddo + enddo + do kk = 1, ntrac + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + qcko(i,k,kk) = q1(i,k,kk) + endif + enddo + enddo + enddo +!> For details of the mfpbl subroutine, step into its documentation ::mfpbl + call mfpbl(im,ix,km,ntrac,dt2,pcnvflg, + & zl,zi,thvx,q1,t1,u1,v1,hpbl,kpbl, + & sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute diffusion coefficients for cloud-top driven diffusion +! if the condition for cloud-top instability is met, +! increase entrainment flux at cloud top +! +!> ## Compute enhanced diffusion coefficients related to stratocumulus-topped PBLs +!! If a stratocumulus layer has been identified in the PBL, the diffusion coefficients in the PBL are modified in the following way. +!! +!! -# First, the criteria for CTEI is checked, using the threshold from equation 13 of Macvean and Mason (1990) \cite macvean_and_mason_1990. If the criteria is met, the cloud top diffusion is increased: +!! \f[ +!! K_h^{Sc} = -c\frac{\Delta F_R}{\rho c_p}\frac{1}{\frac{\partial \theta_v}{\partial z}} +!! \f] +!! where the constant \f$c\f$ is set to 0.2 if the CTEI criterion is not met and 1.0 if it is. +!! +!! -# Calculate the diffusion coefficients due to stratocumulus mixing according to equation 5 in Lock et al. (2000) \cite lock_et_al_2000 for every level below the stratocumulus top using the characteristic stratocumulus velocity scale previously calculated. The diffusion coefficient for momentum is calculated assuming a constant inverse Prandtl number of 0.75. + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = thetae(i,k) - thetae(i,k+1) + tem1 = qtx(i,k) - qtx(i,k+1) + if (tem > 0. .and. tem1 > 0.) then + cteit= cp*tem/(hvap*tem1) + if(cteit > actei) rent(i) = rentf2 + endif + endif + enddo + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem1 = max(bf(i,k),tdzmin) + ckt(i,k) = -rent(i)*radmin(i)/tem1 + cku(i,k) = ckt(i,k) + endif + enddo +! + do k = 1, kmpbl + do i=1,im + if(scuflg(i) .and. k < krad(i)) then + tem1=hrad(i)-zd(i) + tem2=zi(i,k+1)-tem1 + if(tem2 > 0.) then + ptem= tem2/zd(i) + if(ptem.ge.1.) ptem= 1. + ptem= tem2*ptem*sqrt(1.-ptem) + ckt(i,k) = radfac*vk*vrad(i)*ptem + cku(i,k) = 0.75*ckt(i,k) + ckt(i,k) = max(ckt(i,k),dkmin) + ckt(i,k) = min(ckt(i,k),dkmax) + cku(i,k) = max(cku(i,k),dkmin) + cku(i,k) = min(cku(i,k),dkmax) + endif + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!> After \f$K_h^{Sc}\f$ has been determined from the surface to the top of the stratocumulus layer, it is added to the value for the diffusion coefficient calculated previously using surface-based mixing [see equation 6 of Lock et al. (2000) \cite lock_et_al_2000 ]. + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat and moisture +! +!> ## Solve for the temperature and moisture tendencies due to vertical mixing. +!! The tendencies of heat, moisture, and momentum due to vertical diffusion are calculated using a two-part process. First, a solution is obtained using an implicit time-stepping scheme, then the time tendency terms are "backed out". The tridiagonal matrix elements for the implicit solution for temperature and moisture are prepared in this section, with differing algorithms depending on whether the PBL was convective (substituting the mass flux term for counter-gradient term), unstable but not convective (using the computed counter-gradient terms), or stable (no counter-gradient terms). + do i=1,im + ad(i,1) = 1. + a1(i,1) = t1(i,1) + beta(i) * heat(i) + a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo + + if(ntrac >= 2) then + do k = 2, ntrac + is = (k-1) * km + do i = 1, im + a2(i,1+is) = q1(i,1,k) + enddo + enddo + endif +! + do k = 1,km1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + if(pcnvflg(i) .and. k < kpbl(i)) then + tem2 = dsig * rdz + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ad(i,k) = ad(i,k)-au(i,k)-ptem1 + ad(i,k+1) = 1.-al(i,k)+ptem2 + au(i,k) = au(i,k)-ptem1 + al(i,k) = al(i,k)+ptem2 + ptem = tcko(i,k) + tcko(i,k+1) + dsdzt = tem1 * gocp + a1(i,k) = a1(i,k)+dtodsd*dsdzt-ptem1*ptem + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+ptem2*ptem + ptem = qcko(i,k,1) + qcko(i,k+1,1) + a2(i,k) = a2(i,k) - ptem1 * ptem + a2(i,k+1) = q1(i,k+1,1) + ptem2 * ptem + elseif(ublflg(i) .and. k < kpbl(i)) then + ptem1 = dsig * dktx(i,k) * rdz + tem = 1.0 / hpbl(i) + dsdzt = tem1 * gocp - ptem1 * hgamt(i) * tem + dsdzq = - ptem1 * hgamq(i) * tem + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + a2(i,k) = a2(i,k)+dtodsd*dsdzq + a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq + else + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + dsdzt = tem1 * gocp + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + a2(i,k+1) = q1(i,k+1,1) + endif +! + enddo + enddo +! + if(ntrac >= 2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + if(pcnvflg(i) .and. k < kpbl(i)) then + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + tem = dsig * rdzt(i,k) + ptem = 0.5 * tem * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem1 = qcko(i,k,kk) + qcko(i,k+1,kk) + a2(i,k+is) = a2(i,k+is) - ptem1*tem1 + a2(i,k+1+is)= q1(i,k+1,kk) + ptem2*tem1 + else + a2(i,k+1+is) = q1(i,k+1,kk) + endif + enddo + enddo + enddo + endif +! +! solve tridiagonal problem for heat and moisture +! +!> The tridiagonal system is solved by calling the internal ::tridin subroutine. + call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) +! +! recover tendencies of heat and moisture +! +!> After returning with the solution, the tendencies for temperature and moisture are recovered. + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) * rdt + qtend = (a2(i,k)-q1(i,k,1))*rdt + tau(i,k) = tau(i,k)+ttend + rtg(i,k,1) = rtg(i,k,1)+qtend + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend + enddo + enddo + if(ntrac >= 2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk)+qtend + enddo + enddo + enddo + endif +! +! compute tke dissipation rate +! +!> ## Calculate heating due to TKE dissipation and add to the tendency for temperature +!! Following Han et al. (2015) \cite han_et_al_2015 , turbulence dissipation contributes to the tendency of temperature in the following way. First, turbulence dissipation is calculated by equation 17 of Han et al. (2015) \cite han_et_al_2015 for the PBL and equation 16 for the surface layer. + if(dspheat) then +! + do k = 1,km1 + do i = 1,im + diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) +! diss(i,k) = dku(i,k)*shr2(i,k) + enddo + enddo +! +! add dissipative heating at the first model layer +! +!> Next, the temperature tendency is updated following equation 14. + do i = 1,im + tem = govrth(i)*sflux(i) + tem1 = tem + stress(i)*spd1(i)/zl(i,1) + tem2 = 0.5 * (tem1+diss(i,1)) + tem2 = max(tem2, 0.) + ttend = tem2 / cp + tau(i,1) = tau(i,1)+0.5*ttend + enddo +! +! add dissipative heating above the first model layer +! + do k = 2,km1 + do i = 1,im + tem = 0.5 * (diss(i,k-1)+diss(i,k)) + tem = max(tem, 0.) + ttend = tem / cp + tau(i,k) = tau(i,k) + 0.5*ttend + enddo + enddo +! + endif +! +! compute tridiagonal matrix elements for momentum +! +!> ## Solve for the horizontal momentum tendencies and add them to the output tendency terms +!! As with the temperature and moisture tendencies, the horizontal momentum tendencies are calculated by solving tridiagonal matrices after the matrices are prepared in this section. + do i=1,im + ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + a1(i,1) = u1(i,1) + a2(i,1) = v1(i,1) + enddo +! + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + if(pcnvflg(i) .and. k < kpbl(i)) then + tem2 = dsig * rdz + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ad(i,k) = ad(i,k)-au(i,k)-ptem1 + ad(i,k+1) = 1.-al(i,k)+ptem2 + au(i,k) = au(i,k)-ptem1 + al(i,k) = al(i,k)+ptem2 + ptem = ucko(i,k) + ucko(i,k+1) + a1(i,k) = a1(i,k) - ptem1 * ptem + a1(i,k+1) = u1(i,k+1) + ptem2 * ptem + ptem = vcko(i,k) + vcko(i,k+1) + a2(i,k) = a2(i,k) - ptem1 * ptem + a2(i,k+1) = v1(i,k+1) + ptem2 * ptem + else + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + a1(i,k+1) = u1(i,k+1) + a2(i,k+1) = v1(i,k+1) + endif +! + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) +! +! recover tendencies of momentum +! +!> Finally, the tendencies are recovered from the tridiagonal solutions. + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k))*rdt + vtend = (a2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k) + utend + dv(i,k) = dv(i,k) + vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend +! +! for dissipative heating for ecmwf model +! +! tem1 = 0.5*(a1(i,k)+u1(i,k)) +! tem2 = 0.5*(a2(i,k)+v1(i,k)) +! diss(i,k) = -(tem1*utend+tem2*vtend) +! diss(i,k) = max(diss(i,k),0.) +! ttend = diss(i,k) / cp +! tau(i,k) = tau(i,k) + ttend +! + enddo + enddo + +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end +!> @} + +c----------------------------------------------------------------------- +!> \ingroup PBL +!! \brief Routine to solve the tridiagonal system to calculate temperature and moisture at \f$ t + \Delta t \f$; part of two-part process to calculate time tendencies due to vertical diffusion. +!! +!! Origin of subroutine unknown. + subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2) +cc + use machine , only : kind_phys + implicit none + integer k,n,l,i + real(kind=kind_phys) fk +cc + real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n), & + & au(l,n-1),a1(l,n),a2(l,n) +c----------------------------------------------------------------------- + do i=1,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + a1(i,1) = fk*r1(i,1) + a2(i,1) = fk*r2(i,1) + enddo + do k=2,n-1 + do i=1,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1)) + a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(i,k-1)) + enddo + enddo + do i=1,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1)) + a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1)) + enddo + do k=n-1,1,-1 + do i=1,l + a1(i,k) = a1(i,k)-au(i,k)*a1(i,k+1) + a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1) + enddo + enddo +c----------------------------------------------------------------------- + return + end +c----------------------------------------------------------------------- +!> \ingroup PBL +!! \brief Routine to solve the tridiagonal system to calculate u- and v-momentum at \f$ t + \Delta t \f$; part of two-part process to calculate time tendencies due to vertical diffusion. +!! +!! Origin of subroutine unknown. + subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2) +cc + use machine , only : kind_phys + implicit none + integer is,k,kk,n,nt,l,i + real(kind=kind_phys) fk(l) +cc + real(kind=kind_phys) cl(l,2:n), cm(l,n), cu(l,n-1), & + & r1(l,n), r2(l,n*nt), & + & au(l,n-1), a1(l,n), a2(l,n*nt), & + & fkk(l,2:n-1) +c----------------------------------------------------------------------- + do i=1,l + fk(i) = 1./cm(i,1) + au(i,1) = fk(i)*cu(i,1) + a1(i,1) = fk(i)*r1(i,1) + enddo + do k = 1, nt + is = (k-1) * n + do i = 1, l + a2(i,1+is) = fk(i) * r2(i,1+is) + enddo + enddo + do k=2,n-1 + do i=1,l + fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fkk(i,k)*cu(i,k) + a1(i,k) = fkk(i,k)*(r1(i,k)-cl(i,k)*a1(i,k-1)) + enddo + enddo + do kk = 1, nt + is = (kk-1) * n + do k=2,n-1 + do i=1,l + a2(i,k+is) = fkk(i,k)*(r2(i,k+is)-cl(i,k)*a2(i,k+is-1)) + enddo + enddo + enddo + do i=1,l + fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + a1(i,n) = fk(i)*(r1(i,n)-cl(i,n)*a1(i,n-1)) + enddo + do k = 1, nt + is = (k-1) * n + do i = 1, l + a2(i,n+is) = fk(i)*(r2(i,n+is)-cl(i,n)*a2(i,n+is-1)) + enddo + enddo + do k=n-1,1,-1 + do i=1,l + a1(i,k) = a1(i,k) - au(i,k)*a1(i,k+1) + enddo + enddo + do kk = 1, nt + is = (kk-1) * n + do k=n-1,1,-1 + do i=1,l + a2(i,k+is) = a2(i,k+is) - au(i,k)*a2(i,k+is+1) + enddo + enddo + enddo +c----------------------------------------------------------------------- + return + end +!> @} diff --git a/gsmphys/moninp.f b/gsmphys/moninp.f new file mode 100644 index 00000000..550d75c4 --- /dev/null +++ b/gsmphys/moninp.f @@ -0,0 +1,547 @@ +CFPP$ NOCONCUR R + SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, + & U1,V1,T1,Q1, + & PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL, +! & PSK,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1,KPBL, + & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM, + & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ,DKT,xkzm_m,xkzm_h) +! + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP + &, HVAP => con_HVAP, ROG => con_ROG, FV => con_FVirt + implicit none +! +! Arguments +! + integer IX, IM, KM, ntrac, KPBL(IM) +! + real(kind=kind_phys) DELTIM + real(kind=kind_phys) DV(IM,KM), DU(IM,KM), + & TAU(IM,KM), RTG(IM,KM,ntrac), + & U1(IX,KM), V1(IX,KM), + & T1(IX,KM), Q1(IX,KM,ntrac), + & PSK(IM), RBSOIL(IM), +! & CD(IM), CH(IM), + & FM(IM), FH(IM), + & TSEA(IM), QSS(IM), + & SPD1(IM), +! & DPHI(IM), SPD1(IM), + & PRSI(IX,KM+1), DEL(IX,KM), + & PRSL(IX,KM), PRSLK(IX,KM), + & PHII(IX,KM+1), PHIL(IX,KM), + & DUSFC(IM), + & dvsfc(IM), dtsfc(IM), + & DQSFC(IM), HPBL(IM), + & HGAMT(IM), hgamq(IM) +! +! Locals +! + integer i,iprt,is,iun,k,kk,kmpbl,lond +! real(kind=kind_phys) betaq(IM), betat(IM), betaw(IM), + real(kind=kind_phys) evap(IM), heat(IM), phih(IM), + & phim(IM), rbdn(IM), rbup(IM), + & the1(IM), stress(im), beta(im), + & the1v(IM), thekv(IM), thermal(IM), + & thesv(IM), ustar(IM), wscale(IM) +! & thesv(IM), ustar(IM), wscale(IM), zl1(IM) +! + real(kind=kind_phys) RDZT(IM,KM-1), + & ZI(IM,KM+1), ZL(IM,KM), + & DKU(IM,KM-1), DKT(IM,KM-1), + & AL(IM,KM-1), AD(IM,KM), + & AU(IM,KM-1), A1(IM,KM), + & A2(IM,KM*ntrac), THETA(IM,KM) + logical pblflg(IM), sfcflg(IM), stable(IM) +! + real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, + & cfac, conq, cont, conw, + & conwrc, dk, dkmax, dkmin, + & dq1, dsdz2, dsdzq, dsdzt, + & dsig, dt, dthe1, dtodsd, + & dtodsu, dw2, dw2min, g, + & gamcrq, gamcrt, gocp, gor, gravi, + & hol, pfac, prmax, prmin, prinv, + & prnum, qmin, qtend, rbcr, + & rbint, rdt, rdz, +! & rbint, rdt, rdz, rdzt1, + & ri, rimin, rl2, rlam, rlamun, + & rone, rzero, sfcfrac, + & sflux, shr2, spdk2, sri, + & tem, ti, ttend, tvd, + & tvu, utend, vk, vk2, + & vpert, vtend, xkzo(im,km), zfac, + & zfmin, zk, tem1, xkzm_m, xkzm_h +cc + parameter (gravi=1.0/grav) + PARAMETER(g=grav) + PARAMETER(GOR=G/RD,GOCP=G/CP) + PARAMETER(CONT=CP/G,CONQ=HVAP/G,CONW=1./G) +! PARAMETER(RLAM=150.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) + PARAMETER(RLAM=30.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) +! PARAMETER(RLAM=50.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) + PARAMETER(DW2MIN=0.0001,DKMIN=0.0,DKMAX=1000.,RIMIN=-100.) + PARAMETER(RBCR=0.25,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) +! PARAMETER(RBCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) +! PARAMETER(QMIN=1.E-8,XKZM=3.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(QMIN=1.E-8,XKZM=2.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(QMIN=1.E-8,XKZM=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) + PARAMETER(QMIN=1.E-8, ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(QMIN=1.E-8,XKZM=0.5,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(QMIN=1.E-8,XKZM=0.25,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(QMIN=1.E-8,XKZM=0.10,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(QMIN=1.E-8,XKZM=0.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3) + PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=150.0) +! PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=30.0) + PARAMETER(IUN=84) +! +C +C----------------------------------------------------------------------- +C + 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1) + 602 FORMAT(1X,' K',' Z',' T',' TH', + 1 ' TVH',' Q',' U',' V', + 2 ' SP') + 603 FORMAT(1X,I5,8F9.1) + 604 FORMAT(1X,' SFC',9X,F9.1,18X,F9.1) + 605 FORMAT(1X,' K ZL SPD2 THEKV THE1V' + 1 ,' THERMAL RBUP') + 606 FORMAT(1X,I5,6F8.2) + 607 FORMAT(1X,' KPBL HPBL FM FH HGAMT', + 1 ' HGAMQ WS USTAR CD CH') + 608 FORMAT(1X,I5,9F8.2) + 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2) + 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', + 1 ' SR2 ',2F8.2,2E10.2) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COMPUTE PRELIMINARY VARIABLES +C + if (IX .lt. im) stop +! +! IPRT = 0 +! IF(IPRT.EQ.1) THEN +CCC LATD = 0 +! LOND = 0 +! ELSE +CCC LATD = 0 +! LOND = 0 +! ENDIF +C + DT = 2. * DELTIM + RDT = 1. / DT + KMPBL = KM / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo +! + do k=1,kmpbl + do i=1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + enddo + enddo +C + DO K = 1,KM-1 + DO I=1,IM + RDZT(I,K) = 1.0 / (ZL(I,K+1) - ZL(I,K)) + ENDDO + ENDDO +C + DO I = 1,IM + DUSFC(I) = 0. + DVSFC(I) = 0. + DTSFC(I) = 0. + DQSFC(I) = 0. + HGAMT(I) = 0. + HGAMQ(I) = 0. + WSCALE(I) = 0. + KPBL(I) = 1 + HPBL(I) = ZI(I,2) + PBLFLG(I) = .TRUE. + SFCFLG(I) = .TRUE. + IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE. + ENDDO +!! + DO I=1,IM +! RDZT1 = GOR * prSL(i,1) / DEL(i,1) +! BET1 = DT*RDZT1*SPD1(I)/T1(I,1) +! BETA(I) = DT*RDZT1/T1(I,1) + BETA(I) = DT / (zi(i,2)-zi(i,1)) +! BETAW(I) = BET1*CD(I) +! BETAT(I) = BET1*CH(I) +! BETAQ(I) = DPHI(I)*BETAT(I) + ENDDO +C + DO I=1,IM +! ZL1(i) = 0.-(T1(I,1)+TSEA(I))/2.*LOG(PRSL(I,1)/PRSI(I,1))*ROG +! USTAR(I) = SQRT(CD(I)*SPD1(I)**2) + USTAR(I) = SQRT(STRESS(I)) + ENDDO +C + DO I=1,IM + THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN)) + THE1(I) = THETA(I,1) + THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1,1),QMIN)) + THERMAL(I) = THE1V(I) +! DTHE1 = (THE1(I)-TSEA(I)) +! DQ1 = (MAX(Q1(I,1,1),QMIN) - MAX(QSS(I),QMIN)) +! HEAT(I) = -CH(I)*SPD1(I)*DTHE1 +! EVAP(I) = -CH(I)*SPD1(I)*DQ1 + ENDDO +C +C +C COMPUTE THE FIRST GUESS OF PBL HEIGHT +C + DO I=1,IM + STABLE(I) = .FALSE. +! ZL(i,1) = ZL1(i) + RBUP(I) = RBSOIL(I) + ENDDO + DO K = 2, KMPBL + DO I = 1, IM + IF(.NOT.STABLE(I)) THEN + RBDN(I) = RBUP(I) +! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * +! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG + THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + SPDK2 = MAX((U1(i,k)**2+V1(i,k)**2),1.) + RBUP(I) = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 + KPBL(I) = K + STABLE(I) = RBUP(I).GT.RBCR + ENDIF + ENDDO + ENDDO +C + DO I = 1,IM + K = KPBL(I) + IF(RBDN(I).GE.RBCR) THEN + RBINT = 0. + ELSEIF(RBUP(I).LE.RBCR) THEN + RBINT = 1. + ELSE + RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) + ENDIF + HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) + IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 + ENDDO +!! + DO I=1,IM + HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN) + IF(SFCFLG(I)) THEN + HOL = MIN(HOL,-ZFMIN) + ELSE + HOL = MAX(HOL,ZFMIN) + ENDIF +C +! HOL = HOL*HPBL(I)/ZL1(I)*SFCFRAC + HOL = HOL*HPBL(I)/ZL(I,1)*SFCFRAC + IF(SFCFLG(I)) THEN +! PHIM = (1.-APHI16*HOL)**(-1./4.) +! PHIH = (1.-APHI16*HOL)**(-1./2.) + TEM = 1.0 / (1. - APHI16*HOL) + PHIH(I) = SQRT(TEM) + PHIM(I) = SQRT(PHIH(I)) + ELSE + PHIM(I) = (1.+APHI5*HOL) + PHIH(I) = PHIM(I) + ENDIF + WSCALE(I) = USTAR(I)/PHIM(I) +! WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16) + WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5) + ENDDO +C +C COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION +C UNDER UNSTABLE CONDITIONS +C + DO I = 1,IM + SFLUX = HEAT(I) + EVAP(I)*FV*THE1(I) + IF(SFCFLG(I).AND.SFLUX.GT.0.0) THEN + HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT) + HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ) + VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I) + VPERT = MIN(VPERT,GAMCRT) + THERMAL(I) = THERMAL(I) + MAX(VPERT,0.) + HGAMT(I) = MAX(HGAMT(I),0.0) + HGAMQ(I) = MAX(HGAMQ(I),0.0) + ELSE + PBLFLG(I) = .FALSE. + ENDIF + ENDDO +C + DO I = 1,IM + IF(PBLFLG(I)) THEN + KPBL(I) = 1 + HPBL(I) = ZI(I,2) + ENDIF + ENDDO +C +C ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL +C + DO I = 1, IM + IF(PBLFLG(I)) THEN + STABLE(I) = .FALSE. + RBUP(I) = RBSOIL(I) + ENDIF + ENDDO + DO K = 2, KMPBL + DO I = 1, IM + IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN + RBDN(I) = RBUP(I) +! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * +! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG + THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + SPDK2 = MAX((U1(i,k)**2+V1(i,k)**2),1.) + RBUP(I) = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 + KPBL(I) = K + STABLE(I) = RBUP(I).GT.RBCR + ENDIF + ENDDO + ENDDO +C + DO I = 1,IM + IF(PBLFLG(I)) THEN + K = KPBL(I) + IF(RBDN(I).GE.RBCR) THEN + RBINT = 0. + ELSEIF(RBUP(I).LE.RBCR) THEN + RBINT = 1. + ELSE + RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) + ENDIF + HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1)) + IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 + IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. + ENDIF + ENDDO +!! + DO K = 1,KM-1 + DO I=1,IM + tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) + ENDDO + ENDDO +!! +C +C COMPUTE DIFFUSION COEFFICIENTS BELOW PBL +C + DO K = 1, KMPBL + DO I=1,IM + IF(KPBL(I).GT.K) THEN + PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) + PRINV = MIN(PRINV,PRMAX) + PRINV = MAX(PRINV,PRMIN) +! ZFAC = MAX((1.-(ZI(I,K+1)-ZL1(I))/ +! 1 (HPBL(I)-ZL1(I))), ZFMIN) + ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ + 1 (HPBL(I)-ZL(I,1))), ZFMIN) +! DKU(i,k) = XKZO(i,k) + WSCALE(I)*VK*ZI(I,K+1) +! 1 * ZFAC**PFAC + DKU(i,k) = xkzm_m + WSCALE(I)*VK*ZI(I,K+1) * ZFAC**PFAC + DKT(i,k) = (DKU(i,k)-xkzm_m)*PRINV + xkzo(i,k) + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) + ENDIF + ENDDO + ENDDO +C +C COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) +C + DO K = 1, KM-1 + DO I=1,IM + IF(K.GE.KPBL(I)) THEN +! TI = 0.5*(T1(i,k)+T1(i,K+1)) + TI = 2.0 / (T1(i,k)+T1(i,K+1)) +! RDZ = RDZT(I,K)/TI +! RDZ = RDZT(I,K) * TI + RDZ = RDZT(I,K) + + DW2 = ((U1(i,k)-U1(i,K+1))**2 + (V1(i,k)-V1(i,K+1))**2) + SHR2 = MAX(DW2,DW2MIN)*RDZ*RDZ + TVD = T1(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + TVU = T1(i,K+1)*(1.+FV*MAX(Q1(i,K+1,1),QMIN)) +! BVF2 = G*(GOCP+RDZ*(TVU-TVD))/TI + BVF2 = G*(GOCP+RDZ*(TVU-TVD)) * TI + RI = MAX(BVF2/SHR2,RIMIN) + ZK = VK*ZI(I,K+1) +! RL2 = (ZK*RLAM/(RLAM+ZK))**2 +! DK = RL2*SQRT(SHR2) +! RL2 = ZK*RLAM/(RLAM+ZK) +! DK = RL2*RL2*SQRT(SHR2) + IF(RI.LT.0.) THEN ! UNSTABLE REGIME + RL2 = ZK*RLAMUN/(RLAMUN+ZK) + DK = RL2*RL2*SQRT(SHR2) + SRI = SQRT(-RI) +! DKU(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.746*SRI)) + DKU(i,k) = XKZM_M + DK*(1+8.*(-RI)/(1+1.746*SRI)) + DKT(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.286*SRI)) + ELSE ! STABLE REGIME + RL2 = ZK*RLAM/(RLAM+ZK) +! tem = rlam * sqrt(0.01*prsi(i,k)) +! RL2 = ZK*tem/(tem+ZK) + DK = RL2*RL2*SQRT(SHR2) + DKT(i,k) = XKZO(i,k) + DK/(1+5.*RI)**2 + PRNUM = 1.0 + 2.1*RI + PRNUM = MIN(PRNUM,PRMAX) +! DKU(i,k) = (DKT(i,k)-XKZO(i,k))*PRNUM + XKZO(i,k) + DKU(i,k) = (DKT(i,k)-XKZO(i,k))*PRNUM + XKZM_M + ENDIF +C + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) +C +CCC IF(I.EQ.LOND.AND.LAT.EQ.LATD) THEN +CCC PRNUM = DKU(k)/DKT(k) +CCC WRITE(IUN,610) K,PRNUM,DKT(k),DKU(k),RL2,RI, +CCC 1 BVF2,SHR2 +CCC ENDIF +C + ENDIF + ENDDO + ENDDO +C +C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE +C + DO I=1,IM + AD(I,1) = 1. + A1(I,1) = T1(i,1) + BETA(i) * HEAT(I) + A2(I,1) = Q1(i,1,1) + BETA(i) * EVAP(I) +! A1(I,1) = T1(i,1)-BETAT(I)*(THETA(i,1)-TSEA(I)) +! A2(I,1) = Q1(i,1,1)-BETAQ(I)* +! & (MAX(Q1(i,1,1),QMIN)-MAX(QSS(I),QMIN)) + ENDDO + if(ntrac.ge.2) then + do k = 2, ntrac + is = (k-1) * km + do i = 1, im + A2(I,1+is) = Q1(i,1,k) + enddo + enddo + endif +C + DO K = 1,KM-1 + DO I = 1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) +! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1)) + RDZ = RDZT(I,K) + tem1 = DSIG * DKT(i,k) * RDZ + IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN +! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP-HGAMT(I)/HPBL(I)) +! DSDZQ = DSIG*DKT(i,k)*RDZ*(-HGAMQ(I)/HPBL(I)) + tem = 1.0 / HPBL(I) + DSDZT = tem1 * (GOCP-HGAMT(I)*tem) + DSDZQ = tem1 * (-HGAMQ(I)*tem) + A2(I,k) = A2(I,k)+DTODSD*DSDZQ + A2(I,k+1) = Q1(i,k+1,1)-DTODSU*DSDZQ + ELSE +! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP) + DSDZT = tem1 * GOCP + A2(I,k+1) = Q1(i,k+1,1) + ENDIF +! DSDZ2 = DSIG*DKT(i,k)*RDZ*RDZ + DSDZ2 = tem1 * RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + A1(I,k) = A1(I,k)+DTODSD*DSDZT + A1(I,k+1) = T1(i,k+1)-DTODSU*DSDZT + ENDDO + ENDDO + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km - 1 + do i = 1, im + A2(I,k+1+is) = Q1(i,k+1,kk) + enddo + enddo + enddo + endif +C +C SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE +C + CALL TRIDIN(IM,KM,ntrac,AL,AD,AU,A1,A2,AU,A1,A2) +C +C RECOVER TENDENCIES OF HEAT AND MOISTURE +C + DO K = 1,KM + DO I = 1,IM + TTEND = (A1(I,k)-T1(i,k))*RDT + QTEND = (A2(I,k)-Q1(i,k,1))*RDT + TAU(i,k) = TAU(i,k)+TTEND + RTG(I,k,1) = RTG(i,k,1)+QTEND + DTSFC(I) = DTSFC(I)+CONT*DEL(I,K)*TTEND + DQSFC(I) = DQSFC(I)+CONQ*DEL(I,K)*QTEND + ENDDO + ENDDO + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km + do i = 1, im + QTEND = (A2(I,K+is)-Q1(i,K,kk))*RDT + RTG(i,K,kk) = RTG(i,K,kk)+QTEND + enddo + enddo + enddo + endif +C +C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM +C + DO I=1,IM +! AD(I,1) = 1.+BETAW(I) + AD(I,1) = 1.0 + BETA(i) * STRESS(I) / SPD1(I) + A1(I,1) = U1(i,1) + A2(I,1) = V1(i,1) +! AD(I,1) = 1.0 +! tem = 1.0 + BETA(I) * STRESS(I) / SPD1(I) +! A1(I,1) = U1(i,1) * tem +! A2(I,1) = V1(i,1) * tem + ENDDO +C + DO K = 1,KM-1 + DO I=1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) +! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,k+1)) + RDZ = RDZT(I,K) + DSDZ2 = DSIG*DKU(i,k)*RDZ*RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + A1(I,k+1) = U1(i,k+1) + A2(I,k+1) = V1(i,k+1) + ENDDO + ENDDO +C +C SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM +C + CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) +C +C RECOVER TENDENCIES OF MOMENTUM +C + DO K = 1,KM + DO I = 1,IM + UTEND = (A1(I,k)-U1(i,k))*RDT + VTEND = (A2(I,k)-V1(i,k))*RDT + DU(i,k) = DU(i,k) + UTEND + DV(i,k) = DV(i,k) + VTEND + DUSFC(I) = DUSFC(I) + CONW*DEL(I,K)*UTEND + DVSFC(I) = DVSFC(I) + CONW*DEL(I,K)*VTEND + ENDDO + ENDDO +!! + RETURN + END diff --git a/gsmphys/moninp1.f b/gsmphys/moninp1.f new file mode 100644 index 00000000..f03f87d2 --- /dev/null +++ b/gsmphys/moninp1.f @@ -0,0 +1,556 @@ +CFPP$ NOCONCUR R + SUBROUTINE MONINP1(IX,IM,KM,ntrac,DV,DU,TAU,RTG, + & U1,V1,T1,Q1, + & PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL, +! & PSK,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1,KPBL, + & PRSI,DEL,PRSL,PRSLK,PHII,PHIL,DELTIM, + & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ,DKT +! &, kinver, ctei_r, ctei_rm, xkzm_m, xkzm_h) + &, kinver, xkzm_m, xkzm_h) +! &, kinver, oro, ctei_r, ctei_rm, xkzm_m, xkzm_h) +! + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP + &, HVAP => con_HVAP, ROG => con_ROG, FV => con_FVirt + implicit none +! +! This code assumes that terrain height is not included in PHII and PHIL +! +! Arguments +! + integer IX, IM, KM, ntrac, KPBL(IM) + integer kinver(im) +! + real(kind=kind_phys) DELTIM + real(kind=kind_phys) DV(IM,KM), DU(IM,KM), + & TAU(IM,KM), RTG(IM,KM,ntrac), + & U1(IX,KM), V1(IX,KM), + & T1(IX,KM), Q1(IX,KM,ntrac), + & PSK(IM), RBSOIL(IM), +! & CD(IM), CH(IM), + & FM(IM), FH(IM), + & TSEA(IM), QSS(IM), + & SPD1(IM), +! & DPHI(IM), SPD1(IM), + & PRSI(IX,KM+1), DEL(IX,KM), + & PRSL(IX,KM), PRSLK(IX,KM), + & PHII(IX,KM+1), PHIL(IX,KM), + & DUSFC(IM), + & dvsfc(IM), dtsfc(IM), + & DQSFC(IM), HPBL(IM), + & HGAMT(IM), hgamq(IM) +! &, ctei_r(im), ctei_rm +! & HGAMT(IM), hgamq(IM), oro(im), +! +! Locals +! + integer i,iprt,is,iun,k,kk,kmpbl,lond +! real(kind=kind_phys) betaq(IM), betat(IM), betaw(IM), + real(kind=kind_phys) evap(IM), heat(IM), phih(IM), + & phim(IM), rbdn(IM), rbup(IM), + & the1(IM), stress(im), beta(im), + & the1v(IM), thekv(IM), thermal(IM), + & thesv(IM), ustar(IM), wscale(IM) +! & thesv(IM), ustar(IM), wscale(IM), zl1(IM) +! + real(kind=kind_phys) RDZT(IM,KM-1), + & ZI(IM,KM+1), ZL(IM,KM), + & DKU(IM,KM-1), DKT(IM,KM-1), + & AL(IM,KM-1), AD(IM,KM), + & AU(IM,KM-1), A1(IM,KM), + & A2(IM,KM*ntrac), THETA(IM,KM) + logical pblflg(IM), sfcflg(IM), stable(IM) +! + real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, + & cfac, conq, cont, conw, + & conwrc, dk, dkmax, dkmin, + & dq1, dsdz2, dsdzq, dsdzt, + & dsig, dt, dthe1, dtodsd, + & dtodsu, dw2, dw2min, g, + & gamcrq, gamcrt, gocp, gor, gravi, + & hol, pfac, prmax, prmin, prinv, + & prnum, qmin, qtend, rbcr, + & rbint, rdt, rdz, +! & rbint, rdt, rdz, rdzt1, + & ri, rimin, rl2, rlam, rlamun, + & rone, rzero, sfcfrac, + & shr2, spdk2, sri, +! & sflux, shr2, spdk2, sri, + & tem, ti, ttend, tvd, + & tvu, utend, vk, vk2, + & vpert, vtend, xkzo(im,km), zfac, + & zfmin, zk, tem1, xkzm_m, xkzm_h + &, xkzm_loc(im), sflux(im) +! + parameter (gravi=1.0/grav) + PARAMETER(g=grav) + PARAMETER(GOR=G/RD,GOCP=G/CP) + PARAMETER(CONT=CP/G,CONQ=HVAP/G,CONW=1.0/G) +! PARAMETER(RLAM=150.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) + PARAMETER(RLAM=30.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) +! PARAMETER(RLAM=50.0,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.) + PARAMETER(DW2MIN=0.0001,DKMIN=0.0,DKMAX=1000.,RIMIN=-100.) + PARAMETER(RBCR=0.25,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) +! PARAMETER(RBCR=0.5,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1) +! PARAMETER(QMIN=1.E-8,XKZM=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.) + PARAMETER(QMIN=1.E-8, ZFMIN=1.E-8,APHI5=5.,APHI16=16.) +! PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3) + PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=150.0) +! PARAMETER(GAMCRT=3.,GAMCRQ=0., RLAMUN=30.0) + PARAMETER(IUN=84) +! +C +C----------------------------------------------------------------------- +C + 601 FORMAT(1X,' MONINP LAT LON STEP HOUR ',3I6,F6.1) + 602 FORMAT(1X,' K',' Z',' T',' TH', + 1 ' TVH',' Q',' U',' V', + 2 ' SP') + 603 FORMAT(1X,I5,8F9.1) + 604 FORMAT(1X,' SFC',9X,F9.1,18X,F9.1) + 605 FORMAT(1X,' K ZL SPD2 THEKV THE1V' + 1 ,' THERMAL RBUP') + 606 FORMAT(1X,I5,6F8.2) + 607 FORMAT(1X,' KPBL HPBL FM FH HGAMT', + 1 ' HGAMQ WS USTAR CD CH') + 608 FORMAT(1X,I5,9F8.2) + 609 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2) + 610 FORMAT(1X,' K PR DKT DKU ',I5,3F8.2,' L2 RI T2', + 1 ' SR2 ',2F8.2,2E10.2) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COMPUTE PRELIMINARY VARIABLES +C + if (IX .lt. im) stop +! +! IPRT = 0 +! IF(IPRT.EQ.1) THEN +CCC LATD = 0 +! LOND = 0 +! ELSE +CCC LATD = 0 +! LOND = 0 +! ENDIF +C + DT = 2. * DELTIM + RDT = 1. / DT + KMPBL = KM / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo +! + do k=1,kmpbl + do i=1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + enddo + enddo +C + DO K = 1,KM-1 + DO I=1,IM + RDZT(I,K) = 1.0 / (ZL(I,K+1) - ZL(I,K)) + ENDDO + ENDDO +C + DO I = 1,IM + DUSFC(I) = 0. + DVSFC(I) = 0. + DTSFC(I) = 0. + DQSFC(I) = 0. + HGAMT(I) = 0. + HGAMQ(I) = 0. + WSCALE(I) = 0. + KPBL(I) = 1 + HPBL(I) = ZI(I,2) + PBLFLG(I) = .TRUE. + SFCFLG(I) = .TRUE. + IF(RBSOIL(I).GT.0.0) SFCFLG(I) = .FALSE. + ENDDO +!! + DO I=1,IM +! RDZT1 = GOR * prSL(i,1) / DEL(i,1) +! BET1 = DT*RDZT1*SPD1(I)/T1(I,1) +! BETA(I) = DT*RDZT1/T1(I,1) + BETA(I) = DT / (zi(i,2)-zi(i,1)) +! BETAW(I) = BET1*CD(I) +! BETAT(I) = BET1*CH(I) +! BETAQ(I) = DPHI(I)*BETAT(I) + ENDDO +C + DO I=1,IM +! ZL1(i) = 0.-(T1(I,1)+TSEA(I))/2.*LOG(PRSL(I,1)/PRSI(I,1))*ROG +! USTAR(I) = SQRT(CD(I)*SPD1(I)**2) + USTAR(I) = SQRT(STRESS(I)) + ENDDO +C + DO I=1,IM + THESV(I) = TSEA(I)*(1.+FV*MAX(QSS(I),QMIN)) + THE1(I) = THETA(I,1) + THE1V(I) = THE1(I)*(1.+FV*MAX(Q1(I,1,1),QMIN)) + THERMAL(I) = THE1V(I) +! DTHE1 = (THE1(I)-TSEA(I)) +! DQ1 = (MAX(Q1(I,1,1),QMIN) - MAX(QSS(I),QMIN)) +! HEAT(I) = -CH(I)*SPD1(I)*DTHE1 +! EVAP(I) = -CH(I)*SPD1(I)*DQ1 + ENDDO +C +C +C COMPUTE THE FIRST GUESS OF PBL HEIGHT +C + DO I=1,IM + STABLE(I) = .FALSE. +! ZL(i,1) = ZL1(i) + RBUP(I) = RBSOIL(I) + ENDDO + DO K = 2, KMPBL + DO I = 1, IM + IF(.NOT.STABLE(I)) THEN + RBDN(I) = RBUP(I) +! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * +! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG + THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + SPDK2 = MAX((U1(i,k)**2+V1(i,k)**2),1.) + RBUP(I) = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 + KPBL(I) = K + STABLE(I) = RBUP(I).GT.RBCR + ENDIF + ENDDO + ENDDO +C + DO I = 1,IM + K = KPBL(I) + IF(RBDN(I).GE.RBCR) THEN + RBINT = 0. + ELSEIF(RBUP(I).LE.RBCR) THEN + RBINT = 1. + ELSE + RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) + ENDIF + HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1)) + IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 + ENDDO +!! + DO I=1,IM + HOL = MAX(RBSOIL(I)*FM(I)*FM(I)/FH(I),RIMIN) + IF(SFCFLG(I)) THEN + HOL = MIN(HOL,-ZFMIN) + ELSE + HOL = MAX(HOL,ZFMIN) + ENDIF +C +! HOL = HOL*HPBL(I)/ZL1(I)*SFCFRAC + HOL = HOL*HPBL(I)/ZL(I,1)*SFCFRAC + IF(SFCFLG(I)) THEN +! PHIM = (1.-APHI16*HOL)**(-1./4.) +! PHIH = (1.-APHI16*HOL)**(-1./2.) + TEM = 1.0 / (1. - APHI16*HOL) + PHIH(I) = SQRT(TEM) + PHIM(I) = SQRT(PHIH(I)) + ELSE + PHIM(I) = (1.+APHI5*HOL) + PHIH(I) = PHIM(I) + ENDIF + WSCALE(I) = USTAR(I)/PHIM(I) +! WSCALE(I) = MIN(WSCALE(I),USTAR(I)*APHI16) + WSCALE(I) = MAX(WSCALE(I),USTAR(I)/APHI5) + ENDDO +C +C COMPUTE THE SURFACE VARIABLES FOR PBL HEIGHT ESTIMATION +C UNDER UNSTABLE CONDITIONS +C + DO I = 1,IM + SFLUX(i) = HEAT(I) + EVAP(I)*FV*THE1(I) + IF(SFCFLG(I).AND.SFLUX(i).GT.0.0) THEN + HGAMT(I) = MIN(CFAC*HEAT(I)/WSCALE(I),GAMCRT) + HGAMQ(I) = MIN(CFAC*EVAP(I)/WSCALE(I),GAMCRQ) + VPERT = HGAMT(I) + FV*THE1(I)*HGAMQ(I) + VPERT = MIN(VPERT,GAMCRT) + THERMAL(I) = THERMAL(I) + MAX(VPERT,0.) + HGAMT(I) = MAX(HGAMT(I),0.0) + HGAMQ(I) = MAX(HGAMQ(I),0.0) + ELSE + PBLFLG(I) = .FALSE. + ENDIF + ENDDO +C + DO I = 1,IM + IF(PBLFLG(I)) THEN + KPBL(I) = 1 + HPBL(I) = ZI(I,2) + ENDIF + ENDDO +C +C ENHANCE THE PBL HEIGHT BY CONSIDERING THE THERMAL +C + DO I = 1, IM + IF(PBLFLG(I)) THEN + STABLE(I) = .FALSE. + RBUP(I) = RBSOIL(I) + ENDIF + ENDDO + DO K = 2, KMPBL + DO I = 1, IM + IF(.NOT.STABLE(I).AND.PBLFLG(I)) THEN + RBDN(I) = RBUP(I) +! ZL(I,k) = ZL(I,K-1) - (T1(i,k)+T1(i,K-1))/2 * +! & LOG(PRSL(I,K)/PRSL(I,K-1)) * ROG + THEKV(I) = THETA(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + SPDK2 = MAX((U1(i,k)**2+V1(i,k)**2),1.) + RBUP(I) = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2 + KPBL(I) = K + STABLE(I) = RBUP(I).GT.RBCR + ENDIF + ENDDO + ENDDO +C + DO I = 1,IM + IF(PBLFLG(I)) THEN + K = KPBL(I) + IF(RBDN(I).GE.RBCR) THEN + RBINT = 0. + ELSEIF(RBUP(I).LE.RBCR) THEN + RBINT = 1. + ELSE + RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I)) + ENDIF + HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1)) + IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 + IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. + ENDIF + ENDDO +!! +! DO I=1,IM +! xkzm_loc(i) = max(xkzm_min, min(xkzm, oro(i)*0.001)) +! xkzm_loc(i) = min(xkzm_h, xkzm_min + oro(i)*0.002) +! ENDDO + DO K = 1,KM-1 + DO I=1,IM + if (k .lt. kinver(i)) then +! if (k < kinver(i) .or. ctei_r(i) > ctei_rm) then + tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) + tem1 = tem1 * tem1 * 10.0 ! opr +! xkzo(i,k) = xkzm_loc(i) * min(1.0, exp(-tem1)) + xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) +! xkzo(i,k) = xkzm_h + else + xkzo(i,k) = 0.0 + endif + ENDDO + ENDDO +!! +! +! COMPUTE DIFFUSION COEFFICIENTS BELOW PBL +! + DO K = 1, KMPBL + DO I=1,IM + IF(KPBL(I).GT.K) THEN + PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) + PRINV = MIN(PRINV,PRMAX) + PRINV = MAX(PRINV,PRMIN) + ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ + 1 (HPBL(I)-ZL(I,1))), ZFMIN) + DKU(i,k) = xkzm_m + WSCALE(I)*VK*ZI(I,K+1) * ZFAC**PFAC + DKT(i,k) = (DKU(i,k)-xkzm_m)*PRINV + xkzo(i,k) + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) + ENDIF + ENDDO + ENDDO +! +! COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) +! + DO K = 1, KM-1 + DO I=1,IM + IF(K.GE.KPBL(I)) THEN +! TI = 0.5*(T1(i,k)+T1(i,K+1)) + TI = 2.0 / (T1(i,k)+T1(i,K+1)) +! RDZ = RDZT(I,K)/TI +! RDZ = RDZT(I,K) * TI + RDZ = RDZT(I,K) + + DW2 = ((U1(i,k)-U1(i,K+1))**2 + (V1(i,k)-V1(i,K+1))**2) + SHR2 = MAX(DW2,DW2MIN)*RDZ*RDZ + TVD = T1(i,k)*(1.+FV*MAX(Q1(i,k,1),QMIN)) + TVU = T1(i,K+1)*(1.+FV*MAX(Q1(i,K+1,1),QMIN)) +! BVF2 = G*(GOCP+RDZ*(TVU-TVD))/TI + BVF2 = G*(GOCP+RDZ*(TVU-TVD)) * TI + RI = MAX(BVF2/SHR2,RIMIN) + ZK = VK*ZI(I,K+1) +! RL2 = (ZK*RLAM/(RLAM+ZK))**2 +! DK = RL2*SQRT(SHR2) +! RL2 = ZK*RLAM/(RLAM+ZK) +! DK = RL2*RL2*SQRT(SHR2) + IF(RI < 0.) THEN ! UNSTABLE REGIME + RL2 = ZK*RLAMUN/(RLAMUN+ZK) + DK = RL2*RL2*SQRT(SHR2) + SRI = SQRT(-RI) + DKU(i,k) = XKZM_M + DK*(1+8.*(-RI)/(1+1.746*SRI)) + DKT(i,k) = XKZO(i,k) + DK*(1+8.*(-RI)/(1+1.286*SRI)) + ELSE ! STABLE REGIME + RL2 = ZK*RLAM/(RLAM+ZK) +! tem = rlam * sqrt(0.01*prsi(i,k)) +! RL2 = ZK*tem/(tem+ZK) + DK = RL2*RL2*SQRT(SHR2) + DKT(i,k) = XKZO(i,k) + DK/(1+5.*RI)**2 + PRNUM = 1.0 + 2.1*RI + PRNUM = MIN(PRNUM,PRMAX) + DKU(i,k) = (DKT(i,k)-XKZO(i,k))*PRNUM + XKZM_M + ENDIF +C + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) +C +CCC IF(I.EQ.LOND.AND.LAT.EQ.LATD) THEN +CCC PRNUM = DKU(k)/DKT(k) +CCC WRITE(IUN,610) K,PRNUM,DKT(k),DKU(k),RL2,RI, +CCC 1 BVF2,SHR2 +CCC ENDIF +C + ENDIF + ENDDO + ENDDO +C +C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE +C + DO I=1,IM + AD(I,1) = 1. + A1(I,1) = T1(i,1) + BETA(i) * HEAT(I) + A2(I,1) = Q1(i,1,1) + BETA(i) * EVAP(I) +! A1(I,1) = T1(i,1)-BETAT(I)*(THETA(i,1)-TSEA(I)) +! A2(I,1) = Q1(i,1,1)-BETAQ(I)* +! & (MAX(Q1(i,1,1),QMIN)-MAX(QSS(I),QMIN)) + ENDDO + if(ntrac.ge.2) then + do k = 2, ntrac + is = (k-1) * km + do i = 1, im + A2(I,1+is) = Q1(i,1,k) + enddo + enddo + endif +C + DO K = 1,KM-1 + DO I = 1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) +! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,K+1)) + RDZ = RDZT(I,K) + tem1 = DSIG * DKT(i,k) * RDZ + IF(PBLFLG(I).AND.K.LT.KPBL(I)) THEN +! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP-HGAMT(I)/HPBL(I)) +! DSDZQ = DSIG*DKT(i,k)*RDZ*(-HGAMQ(I)/HPBL(I)) + tem = 1.0 / HPBL(I) + DSDZT = tem1 * (GOCP-HGAMT(I)*tem) + DSDZQ = tem1 * (-HGAMQ(I)*tem) + A2(I,k) = A2(I,k)+DTODSD*DSDZQ + A2(I,k+1) = Q1(i,k+1,1)-DTODSU*DSDZQ + ELSE +! DSDZT = DSIG*DKT(i,k)*RDZ*(GOCP) + DSDZT = tem1 * GOCP + A2(I,k+1) = Q1(i,k+1,1) + ENDIF +! DSDZ2 = DSIG*DKT(i,k)*RDZ*RDZ + DSDZ2 = tem1 * RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + A1(I,k) = A1(I,k)+DTODSD*DSDZT + A1(I,k+1) = T1(i,k+1)-DTODSU*DSDZT + ENDDO + ENDDO + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km - 1 + do i = 1, im + A2(I,k+1+is) = Q1(i,k+1,kk) + enddo + enddo + enddo + endif +C +C SOLVE TRIDIAGONAL PROBLEM FOR HEAT AND MOISTURE +C + CALL TRIDIN(IM,KM,ntrac,AL,AD,AU,A1,A2,AU,A1,A2) +C +C RECOVER TENDENCIES OF HEAT AND MOISTURE +C + DO K = 1,KM + DO I = 1,IM + TTEND = (A1(I,k)-T1(i,k))*RDT + QTEND = (A2(I,k)-Q1(i,k,1))*RDT + TAU(i,k) = TAU(i,k)+TTEND + RTG(I,k,1) = RTG(i,k,1)+QTEND + DTSFC(I) = DTSFC(I)+CONT*DEL(I,K)*TTEND + DQSFC(I) = DQSFC(I)+CONQ*DEL(I,K)*QTEND + ENDDO + ENDDO + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km + do i = 1, im + QTEND = (A2(I,K+is)-Q1(i,K,kk))*RDT + RTG(i,K,kk) = RTG(i,K,kk)+QTEND + enddo + enddo + enddo + endif +C +C COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR MOMENTUM +C + DO I=1,IM +! AD(I,1) = 1.+BETAW(I) + AD(I,1) = 1.0 + BETA(i) * STRESS(I) / SPD1(I) + A1(I,1) = U1(i,1) + A2(I,1) = V1(i,1) +! AD(I,1) = 1.0 +! tem = 1.0 + BETA(I) * STRESS(I) / SPD1(I) +! A1(I,1) = U1(i,1) * tem +! A2(I,1) = V1(i,1) * tem + ENDDO +C + DO K = 1,KM-1 + DO I=1,IM + DTODSD = DT/DEL(I,K) + DTODSU = DT/DEL(I,K+1) + DSIG = PRSL(I,K)-PRSL(I,K+1) +! RDZ = RDZT(I,K)*2./(T1(i,k)+T1(i,k+1)) + RDZ = RDZT(I,K) + DSDZ2 = DSIG*DKU(i,k)*RDZ*RDZ + AU(I,k) = -DTODSD*DSDZ2 + AL(I,k) = -DTODSU*DSDZ2 + AD(I,k) = AD(I,k)-AU(I,k) + AD(I,k+1) = 1.-AL(I,k) + A1(I,k+1) = U1(i,k+1) + A2(I,k+1) = V1(i,k+1) + ENDDO + ENDDO +C +C SOLVE TRIDIAGONAL PROBLEM FOR MOMENTUM +C + CALL TRIDI2(IM,KM,AL,AD,AU,A1,A2,AU,A1,A2) +C +C RECOVER TENDENCIES OF MOMENTUM +C + DO K = 1,KM + DO I = 1,IM + UTEND = (A1(I,k)-U1(i,k))*RDT + VTEND = (A2(I,k)-V1(i,k))*RDT + DU(i,k) = DU(i,k) + UTEND + DV(i,k) = DV(i,k) + VTEND + DUSFC(I) = DUSFC(I) + CONW*DEL(I,K)*UTEND + DVSFC(I) = DVSFC(I) + CONW*DEL(I,K)*VTEND + ENDDO + ENDDO +!! + RETURN + END diff --git a/gsmphys/moninq.f b/gsmphys/moninq.f new file mode 100644 index 00000000..8eccc66c --- /dev/null +++ b/gsmphys/moninq.f @@ -0,0 +1,942 @@ +cfpp$ noconcur r + subroutine moninq(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, + & uo,vo,t1,q1,swh,hlw,xmu, + & psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,deltim,dspheat, + & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt, + & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr, + & xkzminv,moninq_fac,rbcr) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, hvap => con_hvap, fv => con_fvirt + implicit none +! +! arguments +! + logical lprnt + integer ipr + integer ix, im, km, ntrac, ntcw, kpbl(im), kpblx(im), kinver(im) +! + real(kind=kind_phys) deltim, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys) dv(im,km), du(im,km), + & tau(im,km), rtg(im,km,ntrac), + & uo(ix,km), vo(ix,km), + & t1(ix,km), q1(ix,km,ntrac), + & swh(ix,km), hlw(ix,km), + & xmu(im), + & psk(im), rbsoil(im), +! & cd(im), ch(im), + & fm(im), fh(im), + & tsea(im), qss(im), + & spd1(im), +! & dphi(im), spd1(im), + & prsi(ix,km+1), del(ix,km), + & prsl(ix,km), prslk(ix,km), + & phii(ix,km+1), phil(ix,km), + & dusfc(im), + & dvsfc(im), dtsfc(im), + & dqsfc(im), hpbl(im), hpblx(im), + & hgamt(im), hgamq(im) +! &, hgamu(im), hgamv(im), hgams(im) +! + logical dspheat +! flag for tke dissipative heating +! +! locals +! + integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond + integer lcld(im),icld(im),kcld(im),krad(im) + integer kx1(im) +! integer kemx(im), kx1(im) +! +! real(kind=kind_phys) betaq(im), betat(im), betaw(im), + real(kind=kind_phys) evap(im), heat(im), phih(im), + & phim(im), rbdn(im), rbup(im), + & stress(im),beta(im), sflux(im), + & ustar(im), wscale(im), thermal(im), + & wstar3(im) +! + real(kind=kind_phys) thvx(im,km), thlvx(im,km), + & qlx(im,km), thetae(im,km), + & qtx(im,km), bf(im,km-1), diss(im,km), + & u1(im,km), v1(im,km), radx(im,km-1), + & govrth(im), hrad(im), cteit(im), +! & hradm(im), radmin(im), vrad(im), + & radmin(im), vrad(im), + & zd(im), zdd(im), thlvx1(im) +! + real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1),dkux(im,km-1), + & zi(im,km+1), zl(im,km), xkzo(im,km-1), + & dku(im,km-1), dkt(im,km-1), xkzmo(im,km-1), + & cku(im,km-1), ckt(im,km-1), + & ti(im,km-1), shr2(im,km-1), + & al(im,km-1), ad(im,km), + & au(im,km-1), a1(im,km), + & a2(im,km*ntrac), theta(im,km) +! +! real(kind=kind_phys) prinv(im), hpbl01(im), rent(im) + real(kind=kind_phys) prinv(im), rent(im) +! + logical pblflg(im), sfcflg(im), scuflg(im), flg(im) +! + real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, + & cfac, conq, cont, conw, + & dk, dkmax, dkmin, + & dq1, dsdz2, dsdzq, dsdzt, + & dsdzu, dsdzv, sfac, + & dsig, dt, dthe1, dtodsd, + & dtodsu, dw2, dw2min, g, + & gamcrq, gamcrt, gocp, gor, gravi, + & hol, hol1, pfac, prmax, prmin, + & prnum, qmin, tdzmin, qtend, + & rbint, rdt, rdz, qlmin, +! & rbint, rdt, rdz, rdzt1, + & ri, rimin, rl2, rlam, rlamun, + & rone, rzero, sfcfrac, + & spdk2, sri, + & tem, ttend, tvd, + & tvu, utend, vk, vk2, + & vtend, zfac, vpert, cpert, + & rentf1, rentf2, radfac, + & zfmin, zk, tem1, tem2, + & xkzm, xkzmu, xkzminv, + & ptem, ptem1, ptem2, tx1(im), tx2(im) +! + real(kind=kind_phys) moninq_fac, rbcr +! + real(kind=kind_phys) zstblmax,h1, h2, qlcr, actei, + & cldtime, u01, v01, delu, delv +cc + parameter(gravi=1.0/grav) + parameter(g=grav) + parameter(gor=g/rd,gocp=g/cp) + parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa +! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa + parameter(rlam=30.0,vk=0.4,vk2=vk*vk) + parameter(prmin=0.25,prmax=4.) + parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) +! parameter(rbcr=0.25,wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) + parameter(wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) +! parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(qmin=1.e-8, zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(tdzmin=1.e-3,qlmin=1.e-12,cpert=0.25,sfac=5.4) + parameter(h1=0.33333333,h2=0.66666667) +! parameter(cldtime=500.,xkzminv=0.3) + parameter(cldtime=500.) +! parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3) +! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) + parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) + parameter(rentf1=0.2,rentf2=1.0,radfac=0.85) + parameter(iun=84) +! +! parameter (zstblmax = 2500., qlcr=1.0e-5) +! parameter (zstblmax = 2500., qlcr=3.0e-5) +! parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (zstblmax = 2500., qlcr=1.0e-4) + parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (actei = 0.23) + parameter (actei = 0.7) +c +c----------------------------------------------------------------------- +c + 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) + 602 format(1x,' k',' z',' t',' th', + 1 ' tvh',' q',' u',' v', + 2 ' sp') + 603 format(1x,i5,8f9.1) + 604 format(1x,' sfc',9x,f9.1,18x,f9.1) + 605 format(1x,' k zl spd2 thekv the1v' + 1 ,' thermal rbup') + 606 format(1x,i5,6f8.2) + 607 format(1x,' kpbl hpbl fm fh hgamt', + 1 ' hgamq ws ustar cd ch') + 608 format(1x,i5,9f8.2) + 609 format(1x,' k pr dkt dku ',i5,3f8.2) + 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', + 1 ' sr2 ',2f8.2,2e10.2) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + if (ix .lt. im) stop +! +! iprt = 0 +! if(iprt.eq.1) then +!cc latd = 0 +! lond = 0 +! else +!cc latd = 0 +! lond = 0 +! endif +! + dt = 2. * deltim + rdt = 1. / dt + km1 = km - 1 + kmpbl = km / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + u1(i,k) = uo(i,k) + v1(i,k) = vo(i,k) + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo +! + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + enddo + enddo +! + do i=1,im + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + enddo + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) + +! vertical background diffusivity for momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_m + kx1(i) = k + 1 + else + if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) + tem1 = 1.0 - prsi(i,k+1) * tx2(i) + tem1 = tem1 * tem1 * 5.0 + xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! if (lprnt) then +! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) +! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) +! endif +! +! diffusivity in the inversion layer is set to be xkzminv (m^2/s) +! + do k = 1,kmpbl + do i=1,im +! if(zi(i,k+1).gt.200..and.zi(i,k+1).lt.zstblmax) then + if(zi(i,k+1).gt.250.) then + tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) + if(tem1 .gt. 1.e-5) then + xkzo(i,k) = min(xkzo(i,k),xkzminv) + endif + endif + enddo + enddo +! + do i = 1,im + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + hgamt(i) = 0. + hgamq(i) = 0. +! hgamu(i) = 0. +! hgamv(i) = 0. +! hgams(i) = 0. + wscale(i)= 0. + kpbl(i) = 1 + kpblx(i) = 1 + hpbl(i) = zi(i,1) + hpblx(i) = zi(i,1) + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i).gt.0.0) sfcflg(i) = .false. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + cteit(i) = 0. + rent(i) = rentf1 + hrad(i) = zi(i,1) +! hradm(i) = zi(i,1) + krad(i) = 1 + icld(i) = 0 + lcld(i) = km1 + kcld(i) = km1 + zd(i) = 0. + endif + enddo +! + do k = 1,km + do i = 1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + qlx(i,k) = max(q1(i,k,ntcw),qlmin) + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + ptem = qlx(i,k) + ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) + thetae(i,k)= theta(i,k)*(1.+ptem1) + thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) + ptem2 = theta(i,k)-(hvap/cp)*ptem + thlvx(i,k) = ptem2*(1.+fv*qtx(i,k)) + enddo + enddo + do k = 1,km1 + do i = 1,im + dku(i,k) = 0. + dkt(i,k) = 0. + dktx(i,k) = 0. + dkux(i,k) = 0. + cku(i,k) = 0. + ckt(i,k) = 0. + tem = zi(i,k+1)-zi(i,k) + radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) + enddo + enddo +! + do i=1,im + flg(i) = scuflg(i) + enddo + do k = 1, km1 + do i=1,im + if(flg(i).and.zl(i,k).ge.zstblmax) then + lcld(i)=k + flg(i)=.false. + endif + enddo + enddo +! +! compute virtual potential temp gradient (bf) and winshear square +! + do k = 1, km1 + do i = 1, im + rdz = rdzt(i,k) + bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdz + ti(i,k) = 2./(t1(i,k)+t1(i,k+1)) + dw2 = (u1(i,k)-u1(i,k+1))**2 + & +(v1(i,k)-v1(i,k+1))**2 + shr2(i,k) = max(dw2,dw2min)*rdz*rdz + enddo + enddo +! + do i = 1,im + govrth(i) = g/theta(i,1) + enddo +! + do i=1,im + beta(i) = dt / (zi(i,2)-zi(i,1)) + enddo +! + do i=1,im + ustar(i) = sqrt(stress(i)) + thermal(i) = thvx(i,1) + enddo +! +! compute the first guess pbl height +! + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i).gt.rbcr + endif + enddo + enddo + do i = 1,im + k = kpbl(i) + if(rbdn(i).ge.rbcr) then + rbint = 0. + elseif(rbup(i).le.rbcr) then + rbint = 1. + else + rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + hpblx(i) = hpbl(i) + kpblx(i) = kpbl(i) + enddo +! +! compute similarity parameters +! + do i=1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(sfcflg(i).and.sflux(i).gt.0.) then + hol = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + hol = min(hol,-zfmin) +! + hol1 = hol*hpbl(i)/zl(i,1)*sfcfrac +! phim(i) = (1.-aphi16*hol1)**(-1./4.) +! phih(i) = (1.-aphi16*hol1)**(-1./2.) + tem = 1.0 / (1. - aphi16*hol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + wstar3(i) = govrth(i)*sflux(i)*hpbl(i) + tem1 = ustar(i)**3. + wscale(i) = (tem1+wfac*vk*wstar3(i)*sfcfrac)**h1 +! wscale(i) = ustar(i)/phim(i) +! wscale(i) = min(wscale(i),ustar(i)*aphi16) + wscale(i) = max(wscale(i),ustar(i)/aphi5) + else + pblflg(i)=.false. + endif + enddo +! +! compute counter-gradient mixing term for heat and moisture +! + do i = 1,im + if(pblflg(i)) then + hgamt(i) = min(cfac*heat(i)/wscale(i),gamcrt) + hgamq(i) = min(cfac*evap(i)/wscale(i),gamcrq) + vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert = min(vpert,gamcrt) + thermal(i)= thermal(i)+max(vpert,0.) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + endif + enddo +! +! compute large-scale mixing term for momentum +! +! do i = 1,im +! flg(i) = pblflg(i) +! kemx(i)= 1 +! hpbl01(i)= sfcfrac*hpbl(i) +! enddo +! do k = 1, kmpbl +! do i = 1, im +! if(flg(i).and.zl(i,k).gt.hpbl01(i)) then +! kemx(i) = k +! flg(i) = .false. +! endif +! enddo +! enddo +! do i = 1, im +! if(pblflg(i)) then +! kk = kpbl(i) +! if(kemx(i).le.1) then +! ptem = u1(i,1)/zl(i,1) +! ptem1 = v1(i,1)/zl(i,1) +! u01 = ptem*hpbl01(i) +! v01 = ptem1*hpbl01(i) +! else +! tem = zl(i,kemx(i))-zl(i,kemx(i)-1) +! ptem = (u1(i,kemx(i))-u1(i,kemx(i)-1))/tem +! ptem1 = (v1(i,kemx(i))-v1(i,kemx(i)-1))/tem +! tem1 = hpbl01(i)-zl(i,kemx(i)-1) +! u01 = u1(i,kemx(i)-1)+ptem*tem1 +! v01 = v1(i,kemx(i)-1)+ptem1*tem1 +! endif +! if(kk.gt.kemx(i)) then +! delu = u1(i,kk)-u01 +! delv = v1(i,kk)-v01 +! tem2 = sqrt(delu**2+delv**2) +! tem2 = max(tem2,0.1) +! ptem2 = -sfac*ustar(i)*ustar(i)*wstar3(i) +! 1 /(wscale(i)**4.) +! hgamu(i) = ptem2*delu/tem2 +! hgamv(i) = ptem2*delv/tem2 +! tem = sqrt(u1(i,kk)**2+v1(i,kk)**2) +! tem1 = sqrt(u01**2+v01**2) +! ptem = tem - tem1 +! if(ptem.gt.0.) then +! hgams(i)=-sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.) +! else +! hgams(i)=sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.) +! endif +! else +! hgams(i) = 0. +! endif +! endif +! enddo +! +! enhance the pbl height by considering the thermal excess +! + do i=1,im + flg(i) = .true. + if(pblflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) +! spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) +! kgao - change bulk ri defination + spdk2 = max(((u1(i,k)-u1(i,1))**2 + & +(v1(i,k)-v1(i,1))**2),1.) + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i).gt.rbcr + endif + enddo + enddo + do i = 1,im + if(pblflg(i)) then + k = kpbl(i) + if(rbdn(i).ge.rbcr) then + rbint = 0. + elseif(rbup(i).le.rbcr) then + rbint = 1. + else + rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! look for stratocumulus +! + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i).and.k.le.lcld(i)) then + if(qlx(i,k).ge.qlcr) then + kcld(i)=k + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i).and.kcld(i).eq.km1) scuflg(i)=.false. + enddo +! + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i).and.k.le.kcld(i)) then + if(qlx(i,k).ge.qlcr) then + if(radx(i,k).lt.radmin(i)) then + radmin(i)=radx(i,k) + krad(i)=k + endif + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i).and.krad(i).le.1) scuflg(i)=.false. + if(scuflg(i).and.radmin(i).ge.0.) scuflg(i)=.false. + enddo +! + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,2,-1 + do i = 1, im + if(flg(i).and.k.le.krad(i)) then + if(qlx(i,k).ge.qlcr) then + icld(i)=icld(i)+1 + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i).and.icld(i).lt.1) scuflg(i)=.false. + enddo +! + do i = 1, im + if(scuflg(i)) then + hrad(i) = zi(i,krad(i)+1) +! hradm(i)= zl(i,krad(i)) + endif + enddo +! + do i = 1, im + if(scuflg(i).and.hrad(i).lt.zi(i,2)) scuflg(i)=.false. + enddo +! + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = zi(i,k+1)-zi(i,k) + tem1 = cldtime*radmin(i)/tem + thlvx1(i) = thlvx(i,k)+tem1 +! if(thlvx1(i).gt.thlvx(i,k-1)) scuflg(i)=.false. + endif + enddo +! + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i).and.k.le.krad(i))then + if(thlvx1(i).le.thlvx(i,k))then + tem=zi(i,k+1)-zi(i,k) + zd(i)=zd(i)+tem + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i))then + kk = max(1, krad(i)+1-icld(i)) + zdd(i) = hrad(i)-zi(i,kk) + endif + enddo + do i = 1, im + if(scuflg(i))then + zd(i) = max(zd(i),zdd(i)) + zd(i) = min(zd(i),hrad(i)) + tem = govrth(i)*zd(i)*(-radmin(i)) + vrad(i)= tem**h1 + endif + enddo +! +! compute inverse prandtl number +! + do i = 1, im + if(pblflg(i)) then + tem = phih(i)/phim(i)+cfac*vk*sfcfrac +! prinv(i) = (1.0-hgams(i))/tem + prinv(i) = 1.0 / tem + prinv(i) = min(prinv(i),prmax) + prinv(i) = max(prinv(i),prmin) + endif + enddo +! +! compute diffusion coefficients below pbl +! + do k = 1, kmpbl + do i=1,im + if(pblflg(i).and.k.lt.kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + tem = wscale(i)*vk*zi(i,k+1)*zfac**pfac * moninq_fac ! lmh suggested by kg +! dku(i,k) = xkzo(i,k)+wscale(i)*vk*zi(i,k+1) +! 1 *zfac**pfac + dku(i,k) = xkzmo(i,k) + tem + dkt(i,k) = xkzo(i,k) + tem * prinv(i) + dku(i,k) = min(dku(i,k),dkmax) +! dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) +! dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + dkux(i,k)= dku(i,k) + endif + enddo + enddo +! +! compute diffusion coefficients based on local scheme +! + do i = 1, im + if(.not.pblflg(i)) then + kpbl(i) = 1 + endif + enddo + do k = 1, km1 + do i=1,im + if(k.ge.kpbl(i)) then + bvf2 = g*bf(i,k)*ti(i,k) + ri = max(bvf2/shr2(i,k),rimin) + zk = vk*zi(i,k+1) + if(ri.lt.0.) then ! unstable regime + rl2 = zk*rlamun/(rlamun+zk) + dk = rl2*rl2*sqrt(shr2(i,k)) + sri = sqrt(-ri) + dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri)) + dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) + else ! stable regime + rl2 = zk*rlam/(rlam+zk) +!! tem = rlam * sqrt(0.01*prsi(i,k)) +!! rl2 = zk*tem/(tem+zk) + dk = rl2*rl2*sqrt(shr2(i,k)) + tem1 = dk/(1+5.*ri)**2 + if(k.ge.kpblx(i)) then + prnum = 1.0 + 2.1*ri + prnum = min(prnum,prmax) + else + prnum = 1.0 + endif + dkt(i,k) = xkzo(i,k) + tem1 + dku(i,k) = xkzmo(i,k) + tem1 * prnum + endif +! + dku(i,k) = min(dku(i,k),dkmax) +! dku(i,k) = max(dku(i,k),xkzmo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) +! dkt(i,k) = max(dkt(i,k),xkzo(i,k)) +! + endif +! + enddo + enddo +! +! compute diffusion coefficients for cloud-top driven diffusion +! if the condition for cloud-top instability is met, +! increase entrainment flux at cloud top +! + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = thetae(i,k) - thetae(i,k+1) + tem1 = qtx(i,k) - qtx(i,k+1) + if (tem.gt.0..and.tem1.gt.0.) then + cteit(i)= cp*tem/(hvap*tem1) + if(cteit(i).gt.actei) rent(i) = rentf2 + endif + endif + enddo + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem1 = max(bf(i,k),tdzmin) + ckt(i,k) = -rent(i)*radmin(i)/tem1 + cku(i,k) = ckt(i,k) + endif + enddo +! + do k = 1, kmpbl + do i=1,im + if(scuflg(i).and.k.lt.krad(i)) then + tem1=hrad(i)-zd(i) + tem2=zi(i,k+1)-tem1 + if(tem2.gt.0.) then + ptem= tem2/zd(i) + if(ptem.ge.1.) ptem= 1. + ptem= tem2*ptem*sqrt(1.-ptem) + ckt(i,k) = radfac*vk*vrad(i)*ptem + cku(i,k) = 0.75*ckt(i,k) + ckt(i,k) = max(ckt(i,k),dkmin) + ckt(i,k) = min(ckt(i,k),dkmax) + cku(i,k) = max(cku(i,k),dkmin) + cku(i,k) = min(cku(i,k),dkmax) + endif + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo + enddo +! +! compute tridiagonal matrix elements for heat and moisture +! + do i=1,im + ad(i,1) = 1. + a1(i,1) = t1(i,1) + beta(i) * heat(i) + a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo + + if(ntrac.ge.2) then + do k = 2, ntrac + is = (k-1) * km + do i = 1, im + a2(i,1+is) = q1(i,1,k) + enddo + enddo + endif +! + do k = 1,km1 + do i = 1,im + dtodsd = dt/del(i,k) + dtodsu = dt/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) +! rdz = rdzt(i,k)*2./(t1(i,k)+t1(i,k+1)) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + + if(pblflg(i).and.k.lt.kpbl(i)) then +! dsdzt = dsig*dkt(i,k)*rdz*(gocp-hgamt(i)/hpbl(i)) +! dsdzq = dsig*dkt(i,k)*rdz*(-hgamq(i)/hpbl(i)) + ptem1 = dsig * dktx(i,k) * rdz + tem = 1.0 / hpbl(i) + dsdzt = tem1 * gocp - ptem1*hgamt(i)*tem + dsdzq = ptem1 * (-hgamq(i)*tem) + a2(i,k) = a2(i,k)+dtodsd*dsdzq + a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq + else +! dsdzt = dsig*dkt(i,k)*rdz*(gocp) + dsdzt = tem1 * gocp + a2(i,k+1) = q1(i,k+1,1) + endif +! dsdz2 = dsig*dkt(i,k)*rdz*rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + enddo + enddo + + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + a2(i,k+1+is) = q1(i,k+1,kk) + enddo + enddo + enddo + endif +! +! solve tridiagonal problem for heat and moisture +! + call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) + +! +! recover tendencies of heat and moisture +! + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k))*rdt + qtend = (a2(i,k)-q1(i,k,1))*rdt + tau(i,k) = tau(i,k)+ttend + rtg(i,k,1) = rtg(i,k,1)+qtend + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend + enddo + enddo + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk)+qtend + enddo + enddo + enddo + endif +! +! compute tke dissipation rate +! + if(dspheat) then +! + do k = 1,km1 + do i = 1,im + diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k) +! diss(i,k) = dku(i,k)*shr2(i,k) + enddo + enddo +! +! add dissipative heating at the first model layer +! + do i = 1,im + tem = govrth(i)*sflux(i) + tem1 = tem + stress(i)*spd1(i)/zl(i,1) + tem2 = 0.5 * (tem1+diss(i,1)) + tem2 = max(tem2, 0.) + ttend = tem2 / cp + tau(i,1) = tau(i,1)+0.5*ttend + enddo +! +! add dissipative heating above the first model layer +! + do k = 2,km1 + do i = 1,im + tem = 0.5 * (diss(i,k-1)+diss(i,k)) + tem = max(tem, 0.) + ttend = tem / cp + tau(i,k) = tau(i,k) + 0.5*ttend + enddo + enddo +! + endif +! +! compute tridiagonal matrix elements for momentum +! + do i=1,im + ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + a1(i,1) = u1(i,1) + a2(i,1) = v1(i,1) + enddo +! + do k = 1,km1 + do i=1,im + dtodsd = dt/del(i,k) + dtodsu = dt/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*rdz +! if(pblflg(i).and.k.lt.kpbl(i))then +! ptem1 = dsig*dkux(i,k)*rdz +! dsdzu = ptem1*(-hgamu(i)/hpbl(i)) +! dsdzv = ptem1*(-hgamv(i)/hpbl(i)) +! a1(i,k) = a1(i,k)+dtodsd*dsdzu +! a1(i,k+1) = u1(i,k+1)-dtodsu*dsdzu +! a2(i,k) = a2(i,k)+dtodsd*dsdzv +! a2(i,k+1) = v1(i,k+1)-dtodsu*dsdzv +! else + a1(i,k+1) = u1(i,k+1) + a2(i,k+1) = v1(i,k+1) +! endif +! dsdz2 = dsig*dku(i,k)*rdz*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) +! +! recover tendencies of momentum +! + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k))*rdt + vtend = (a2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k) + utend + dv(i,k) = dv(i,k) + vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + enddo + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! pbl height for diagnostic purpose +! + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end diff --git a/gsmphys/moninq1.f b/gsmphys/moninq1.f new file mode 100644 index 00000000..0389f13b --- /dev/null +++ b/gsmphys/moninq1.f @@ -0,0 +1,940 @@ +cfpp$ noconcur r + subroutine moninq1(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, + & u1,v1,t1,q1,swh,hlw,xmu, + & psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,deltim, + & dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt,kinver) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, hvap => con_hvap, rog => con_rog, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! +! arguments +! + integer ix, im, km, ntrac, ntcw, kpbl(im), kpblx(im) + integer kinver(im) +! + real(kind=kind_phys) deltim + real(kind=kind_phys) dv(im,km), du(im,km), + & tau(im,km), rtg(im,km,ntrac), + & u1(ix,km), v1(ix,km), + & t1(ix,km), q1(ix,km,ntrac), + & swh(ix,km), hlw(ix,km), + & xmu(im), + & psk(im), rbsoil(im), +! & cd(im), ch(im), + & fm(im), fh(im), + & tsea(im), qss(im), + & spd1(im), +! & dphi(im), spd1(im), + & prsi(ix,km+1), del(ix,km), + & prsl(ix,km), prslk(ix,km), + & phii(ix,km+1), phil(ix,km), + & dusfc(im), + & dvsfc(im), dtsfc(im), + & dqsfc(im), hpbl(im), hpblx(im), + & hgamt(im), hgamq(im), + & hgamu(im), hgamv(im), hgams(im) +! +! locals +! + integer i,is,k,kk,km1,kmpbl +! integer iprt,latd,lond + integer lcld(im),icld(im),kcld(im),krad(im) + integer kemx(im) +! +! real(kind=kind_phys) betaq(im), betat(im), betaw(im), + real(kind=kind_phys) evap(im), heat(im), phih(im), + & phim(im), rbdn(im), rbup(im), + & stress(im),beta(im), + & ustar(im), wscale(im), thermal(im), + & ust3(im), wstar3(im), + & sumz(im), sumt(im) + &, entflx(im),sflux(im) +! + real(kind=kind_phys) thlx(im,km), thlvx(im,km), tlx(im,km), + & thvx(im,km), qlx(im,km), + & qtx(im,km), bf(im,km-1), + & govrth(im), hrad(im), radx(im,km-1), + & hradm(im), radmin(im), vrad(im), + & zd(im), thlvx1(im) +! + real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1),dkux(im,km-1), + & zi(im,km+1), zl(im,km), xkzo(im,km), + & dku(im,km-1), dkt(im,km-1), + & dkuy(im,km-1),dkty(im,km-1), + & cku(im,km-1), ckt(im,km-1), + & al(im,km-1), ad(im,km), + & au(im,km-1), a1(im,km), + & a2(im,km*ntrac), theta(im,km) +! + real(kind=kind_phys) hol(im), prinv(im), hpbl01(im) +! + logical pblflg(im), sfcflg(im), scuflg(im), flg(im) +! + real(kind=kind_phys) aphi16, aphi5, bvf2, wfac, + & cfac, conq, cont, conw, + & dk, dkmax, dkmin, + & dsdz2, dsdzq, dsdzt, + & dsdzu, dsdzv, sfac, + & dsig, dt, dtodsd, + & dtodsu, dw2, dw2min, g, + & gamcrq, gamcrt, gocp, gravi, + & hol1, pfac, prmax, prmin, + & prnum, qmin, tdzmin, qtend, rbcr, + & rbint, rdt, rdz, qlmin, +! & rbint, rdt, rdz, rdzt1, + & ri, rimin, rl2, rlam, rlamun, + & sfcfrac, + & shr2, spdk2, sri, + & tem, ti, ttend, + & utend, vk, + & vtend, zfac, vpert, cpert, + & entfac, rentfac,radfac, + & zfmin, zk, tem1, tem2, xkzm, + & ptem, ptem1, ptem2 +! + real(kind=kind_phys) zstblmax,h1, + & qlcr, cldtime,alpri, chiri, + & u01, v01, delu, delv +cc + parameter(gravi=1.0/grav) + parameter(g=grav) + parameter(gocp=g/cp) + parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) + parameter(alpri=hvap/rd,chiri=eps*hvap*hvap/cp/rd) + parameter(rlam=30.0,vk=0.4) + parameter(prmin=0.25,prmax=4.) + parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.) + parameter(rbcr=0.25,wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1) +! parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(qmin=1.e-8,xkzm=0.25,zfmin=1.e-8,aphi5=5.,aphi16=16.) + parameter(tdzmin=1.e-3,qlmin=1.e-12,cpert=0.25,sfac=5.4) + parameter(h1=0.33333333) + parameter(cldtime=500.) +! parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0) + parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0) + parameter(entfac=0.2,rentfac=0.2,radfac=0.85) +! +! parameter (zstblmax = 2500., qlcr=3.0e-5) +! parameter (zstblmax = 2500., qlcr=3.5e-5) +! parameter (zstblmax = 2500., qlcr=4.5e-5) + parameter (zstblmax = 2500., qlcr=5.0e-5) +c +c----------------------------------------------------------------------- +c + 601 format(1x,' moninp lat lon step hour ',3i6,f6.1) + 602 format(1x,' k',' z',' t',' th', + 1 ' tvh',' q',' u',' v', + 2 ' sp') + 603 format(1x,i5,8f9.1) + 604 format(1x,' sfc',9x,f9.1,18x,f9.1) + 605 format(1x,' k zl spd2 thekv the1v' + 1 ,' thermal rbup') + 606 format(1x,i5,6f8.2) + 607 format(1x,' kpbl hpbl fm fh hgamt', + 1 ' hgamq ws ustar cd ch') + 608 format(1x,i5,9f8.2) + 609 format(1x,' k pr dkt dku ',i5,3f8.2) + 610 format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2', + 1 ' sr2 ',2f8.2,2e10.2) +c - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +c compute preliminary variables +c + if (ix .lt. im) stop +! +! iprt = 0 +! if(iprt.eq.1) then +ccc latd = 0 +! lond = 0 +! else +ccc latd = 0 +! lond = 0 +! endif +c + dt = 2. * deltim + rdt = 1. / dt + km1 = km - 1 + kmpbl = km / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo +c + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + enddo + enddo +c + do k = 1,km1 + do i=1,im + if (k .lt. kinver(i)) then + tem1 = 1.0 - prsi(i,k+1) / prsi(i,1) + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm * min(1.0, exp(-tem1)) + else + xkzo(i,k) = 0.0 + endif + enddo + enddo +c + do i = 1,im + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + hgamt(i) = 0. + hgamq(i) = 0. + hgamu(i) = 0. + hgamv(i) = 0. + hgams(i) = 0. + wscale(i)= 0. + entflx(i)= 0. + kpbl(i) = 1 + hpbl(i) = zi(i,1) + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i).gt.0.0) sfcflg(i) = .false. + sumz(i) = 0. + sumt(i) = 0. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + hrad(i) = zi(i,1) + icld(i) = 0 + lcld(i) = km1 + kcld(i) = km1 + krad(i) = km1 + zd(i) = 0. + endif + enddo +! + do k = 1,km + do i = 1,im + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + qlx(i,k) = max(q1(i,k,ntcw),qlmin) + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + ptem = qlx(i,k) + ptem1 = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k)) + thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem) + tlx(i,k) = t1(i,k)-(hvap/cp)*ptem + thlx(i,k) = theta(i,k)-(hvap/cp)*ptem + thlvx(i,k) = thlx(i,k)*(1.+fv*qtx(i,k)) + enddo + enddo + do k = 1,km1 + do i = 1,im + dku(i,k) = 0. + dkt(i,k) = 0. + dktx(i,k) = 0. + dkux(i,k) = 0. + dkty(i,k) = 0. + dkuy(i,k) = 0. + cku(i,k) = 0. + ckt(i,k) = 0. + tem = zi(i,k+1)-zi(i,k) + radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) + enddo + enddo +c + do i=1,im + flg(i) = scuflg(i) + enddo + do k = 1, km1 + do i=1,im + if(flg(i).and.zl(i,k).ge.zstblmax) then + lcld(i)=k + flg(i)=.false. + endif + enddo + enddo +c +c compute buoyancy flux +c + do k = 1, km1 + do i = 1, im + bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdzt(i,k) + enddo + enddo +c + do i = 1,im + govrth(i) = g/theta(i,1) + enddo +c + do i=1,im + beta(i) = dt / (zi(i,2)-zi(i,1)) + enddo +c + do i=1,im + ustar(i) = sqrt(stress(i)) + enddo +c +c compute the first guess pbl height +c + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i).or.sflux(i).le.0.0) pblflg(i)=.false. + enddo +c + do i=1,im + flg(i) = .true. + if(pblflg(i)) then + flg(i) = .false. + sumz(i) = zl(i,1) + if(scuflg(i)) then + rbup(i) = thlvx(i,1) + else + rbup(i) = thvx(i,1) + endif + sumt(i) = rbup(i)*zl(i,1) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + tem = zl(i,k)-zl(i,k-1) + sumz(i) = sumz(i)+tem + if(scuflg(i)) then + tem1 = 0.5*(thlvx(i,k)+thlvx(i,k-1)) + rbup(i) = thlvx(i,k) + else + tem1 = 0.5*(thvx(i,k)+thvx(i,k-1)) + rbup(i) = thvx(i,k) + endif + sumt(i) = sumt(i)+tem1*tem + thermal(i)= sumt(i)/sumz(i)+cpert + kpbl(i) = k + flg(i) = rbup(i).gt.thermal(i) + endif + enddo + enddo + do i = 1,im + if(pblflg(i)) then + k = kpbl(i) + if(rbdn(i).ge.thermal(i)) then + rbint = 0. + elseif(rbup(i).le.thermal(i)) then + rbint = 1. + else + rbint = (thermal(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + kpbl(i) = kpbl(i) - 1 + endif + enddo +c + do i = 1, im + if(pblflg(i)) then + hpbl01(i) = sfcfrac*hpbl(i) + if(scuflg(i)) then + thermal(i) = thlvx(i,1) + else + thermal(i) = thvx(i,1) + endif + endif + enddo +c +c compute similarity parameters +c + do i=1,im + if(pblflg(i)) then + hol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + hol(i) = min(hol(i),-zfmin) +c + hol1 = hol(i)*hpbl(i)/zl(i,1)*sfcfrac +! phim(i) = (1.-aphi16*hol1)**(-1./4.) +! phih(i) = (1.-aphi16*hol1)**(-1./2.) + tem = 1.0 / (1. - aphi16*hol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + ptem = max(heat(i)+fv*theta(i,1)*evap(i),0.) + wstar3(i) = govrth(i)*ptem*hpbl(i) + ust3(i) = ustar(i)**3. + wscale(i) = (ust3(i)+wfac*vk*wstar3(i)*sfcfrac)**h1 +! wscale(i) = ustar(i)/phim(i) +! wscale(i) = min(wscale(i),ustar(i)*aphi16) + wscale(i) = max(wscale(i),ustar(i)/aphi5) + endif + enddo +c +c compute counter-gradient mixing term for heat and moisture +c + do i = 1,im + if(pblflg(i)) then + hgamt(i) = min(cfac*heat(i)/wscale(i),gamcrt) + hgamq(i) = min(cfac*evap(i)/wscale(i),gamcrq) + vpert = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert = min(vpert,gamcrt) + thermal(i)= thermal(i)+max(vpert,0.) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) + endif + enddo +c +c compute large-scale mixing term for momentum +c + do i = 1,im + flg(i) = pblflg(i) + kemx(i)= 1 + enddo + do k = 1, kmpbl + do i = 1, im + if(flg(i).and.zl(i,k).gt.hpbl01(i)) then + kemx(i) = k + flg(i) = .false. + endif + enddo + enddo + do i = 1, im + if(pblflg(i)) then + kk = kpbl(i) + if(kemx(i).le.1) then + ptem = u1(i,1)/zl(i,1) + ptem1 = v1(i,1)/zl(i,1) + u01 = ptem*hpbl01(i) + v01 = ptem1*hpbl01(i) + else + tem = zl(i,kemx(i))-zl(i,kemx(i)-1) + ptem = (u1(i,kemx(i))-u1(i,kemx(i)-1))/tem + ptem1 = (v1(i,kemx(i))-v1(i,kemx(i)-1))/tem + tem1 = hpbl01(i)-zl(i,kemx(i)-1) + u01 = u1(i,kemx(i)-1)+ptem*tem1 + v01 = v1(i,kemx(i)-1)+ptem1*tem1 + endif + delu = u1(i,kk)-u01 + delv = v1(i,kk)-v01 + tem2 = sqrt(delu**2+delv**2) + tem2 = max(tem2,0.1) + ptem2 = -sfac*ustar(i)*ustar(i)*wstar3(i) + 1 /(wscale(i)**4.) + hgamu(i) = ptem2*delu/tem2 + hgamv(i) = ptem2*delv/tem2 + tem = sqrt(u1(i,kk)**2+v1(i,kk)**2) + tem1 = sqrt(u01**2+v01**2) + ptem = tem - tem1 + if(ptem.gt.0.) then + hgams(i) = -sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.) + else + hgams(i) = sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.) + endif + endif + enddo +c +c enhance the pbl height by considering the thermal excess +c + do i=1,im + flg(i) = .true. + if(pblflg(i)) then + flg(i) = .false. + if(scuflg(i)) then + rbup(i) = thlvx(i,1) + else + rbup(i) = thvx(i,1) + endif + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + if(scuflg(i)) then + rbup(i) = thlvx(i,k) + else + rbup(i) = thvx(i,k) + endif + kpblx(i) = k + flg(i) = rbup(i).gt.thermal(i) + endif + enddo + enddo + do i = 1,im + if(pblflg(i)) then + k = kpblx(i) + if(rbdn(i).ge.thermal(i)) then + rbint = 0. + elseif(rbup(i).le.thermal(i)) then + rbint = 1. + else + rbint = (thermal(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + kpblx(i) = kpblx(i) - 1 + if(hpblx(i).gt.hpbl(i)) then + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + if(kpbl(i).le.1) pblflg(i)=.false. + endif + endif + enddo +c +c look for stratocumulus-topped pbl +c + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i).and.k.le.lcld(i)) then + if(qlx(i,k).ge.qlcr) then + kcld(i)=k + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i).and.kcld(i).eq.km1) scuflg(i)=.false. + enddo +c + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i).and.k.le.kcld(i)) then + if(qlx(i,k).ge.qlcr) then + if(radx(i,k).lt.radmin(i)) then + radmin(i)=radx(i,k) + krad(i)=k + endif + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i).and.krad(i).eq.km1) scuflg(i)=.false. + if(scuflg(i).and.krad(i).le.1) scuflg(i)=.false. + if(scuflg(i).and.radmin(i).ge.0.) scuflg(i)=.false. + enddo +c + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,2,-1 + do i = 1, im + if(flg(i).and.k.le.krad(i)) then + if(qlx(i,k).ge.qlcr) then + icld(i)=icld(i)+1 + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i).and.icld(i).lt.2) scuflg(i)=.false. + enddo +c + do i = 1, im + if(scuflg(i)) then + hrad(i) = zi(i,krad(i)+1) + hradm(i)= zl(i,krad(i)) + endif + enddo +c + do i = 1, im + if(scuflg(i).and.hrad(i).lt.200.) scuflg(i)=.false. + enddo +c + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = zi(i,k+1)-zi(i,k) + tem1 = cldtime*radmin(i)/tem + thlvx1(i) = thlvx(i,k)+tem1 + if(thlvx1(i).gt.thlvx(i,k-1)) scuflg(i)=.false. + endif + enddo +c + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmpbl,1,-1 + do i = 1, im + if(flg(i).and.k.le.krad(i))then + if(thlvx1(i).le.thlvx(i,k))then + tem=zi(i,k+1)-zi(i,k) + zd(i)=zd(i)+tem + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i))then + zd(i) = min(zd(i),hrad(i)) + tem = govrth(i)*zd(i)*(-radmin(i)) + vrad(i)= tem**h1 + endif + enddo +c + do i = 1, im + if(scuflg(i).and.pblflg(i)) then + if(hpbl(i).ge.hradm(i)) then + hpbl(i)=hrad(i) + kpbl(i)=krad(i) + endif + endif + enddo +c +c compute inverse prandtl number +c + do i = 1, im + if(pblflg(i)) then + tem = phih(i)/phim(i)+cfac*vk*sfcfrac + prinv(i) = (1.0-hgams(i))/tem + prinv(i) = min(prinv(i),prmax) + prinv(i) = max(prinv(i),prmin) + endif + enddo +c +c compute entrainment flux at pbl top +c + do i = 1, im + if(pblflg(i)) then + ptem=(theta(i,1)/g)*ust3(i) + entflx(i)=entfac*(sflux(i)+5.*ptem/hpbl(i)) + endif + enddo +c +c compute diffusion coefficients below pbl +c + do k = 1, kmpbl + do i=1,im + if(pblflg(i).and.k.lt.kpbl(i)) then +! zfac = max((1.-(zi(i,k+1)-zl(i,1))/ +! 1 (hpbl(i)-zl(i,1))), zfmin) + zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin) + dku(i,k) = wscale(i)*vk*zi(i,k+1) + 1 *zfac**pfac +! dku(i,k) = xkzo(i,k)+wscale(i)*vk*zi(i,k+1) +! 1 *zfac**pfac + dkt(i,k) = dku(i,k)*prinv(i) + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzo(i,k)) + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dktx(i,k)= dkt(i,k) + dkux(i,k)= dku(i,k) + endif + enddo + enddo +c + do i = 1, im + if(pblflg(i)) then + k = kpbl(i) + if(bf(i,k).gt.0.) then + ptem = max(bf(i,k),tdzmin) + dkt(i,k) = entflx(i)/ptem + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = dkt(i,k) + endif + endif + enddo +c +c compute diffusion coefficients based on local scheme, +c which are applied to nighttime stable boundary layer and +c free atmosphere over pbl in the daytime unstable condition +c + do k = 1, km1 + do i=1,im +!! if(k.ge.kpbl(i)) then + rdz = rdzt(i,k) + dw2 = ((u1(i,k)-u1(i,k+1))**2 + & + (v1(i,k)-v1(i,k+1))**2) + shr2 = max(dw2,dw2min)*rdz*rdz +! if(qlx(i,k).ge.qlcr.and.qlx(i,k+1).ge.qlcr) then + if(qlx(i,k).ge.qlcr.or.qlx(i,k+1).ge.qlcr) then + ti = 2./(t1(i,k)+t1(i,k+1)) + tem = .5*(max(q1(i,k,1),qmin)+max(q1(i,k+1,1),qmin)) + tem1 = alpri*tem*ti + tem2 = chiri*tem*ti*ti + ptem = (tem2-tem1)/(1.+tem2) + ptem1= bf(i,k)/thvx(i,k+1)-g*ptem*ti/cp + bvf2 = (1.+tem1)*g*ptem1 + else + bvf2 = g*bf(i,k)/thvx(i,k+1) + endif + ri = max(bvf2/shr2,rimin) + zk = vk*zi(i,k+1) + if(ri.lt.0.) then ! unstable regime + rl2 = zk*rlamun/(rlamun+zk) + dk = rl2*rl2*sqrt(shr2) + sri = sqrt(-ri) +! dkuy(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri)) +! dkty(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri)) + dkuy(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + dkty(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else ! stable regime + rl2 = zk*rlam/(rlam+zk) +!! tem = rlam * sqrt(0.01*prsi(i,k)) +!! rl2 = zk*tem/(tem+zk) + dk = rl2*rl2*sqrt(shr2) +! dkty(i,k)= xkzo(i,k) + dk/(1+5.*ri)**2 + dkty(i,k)= dk/(1.+5.*ri)**2 + prnum = 1.0 + 2.1*ri + prnum = min(prnum,prmax) +! dkuy(i,k)= (dkty(i,k)-xkzo(i,k))*prnum + xkzo(i,k) + dkuy(i,k)= dkty(i,k)*prnum + endif +c + dkuy(i,k) = min(dkuy(i,k),dkmax) + dkuy(i,k) = max(dkuy(i,k),xkzo(i,k)) + dkty(i,k) = min(dkty(i,k),dkmax) + dkty(i,k) = max(dkty(i,k),xkzo(i,k)) +c +!! endif +c + enddo + enddo +c +c compute diffusion coefficients for cloud-top driven diffusion +c + do i = 1, im + if(scuflg(i)) then + k = krad(i) + if(bf(i,k).gt.0.) then + tem1 = max(bf(i,k),tdzmin) + ckt(i,k) = -rentfac*radmin(i)/tem1 + cku(i,k) = ckt(i,k) + endif + endif + enddo +c + do k = 1, kmpbl + do i=1,im + if(scuflg(i).and.k.lt.krad(i)) then + tem1=hrad(i)-zd(i) + tem2=zi(i,k+1)-tem1 + if(tem2.gt.0.) then + ptem= tem2/zd(i) + if(ptem.ge.1.) ptem= 1. + ptem= tem2*ptem*sqrt(1.-ptem) + ckt(i,k) = radfac*vk*vrad(i)*ptem + cku(i,k) = 0.75*ckt(i,k) + ckt(i,k) = max(ckt(i,k),dkmin) + ckt(i,k) = min(ckt(i,k),dkmax) + cku(i,k) = max(cku(i,k),dkmin) + cku(i,k) = min(cku(i,k),dkmax) + endif + endif + enddo + enddo +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, kmpbl + do i=1,im + if(scuflg(i)) then + dkt(i,k) = dkt(i,k)+ckt(i,k) + dku(i,k) = dku(i,k)+cku(i,k) + dkt(i,k) = min(dkt(i,k),dkmax) + dku(i,k) = min(dku(i,k),dkmax) + endif + enddo + enddo +c + do k = 1, km1 + do i=1,im + dkt(i,k) = max(dkt(i,k),dkty(i,k)) + dku(i,k) = max(dku(i,k),dkuy(i,k)) + enddo + enddo +c +c compute tridiagonal matrix elements for heat and moisture +c + do i=1,im + ad(i,1) = 1. + a1(i,1) = t1(i,1) + beta(i) * heat(i) + a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo + if(ntrac.ge.2) then + do k = 2, ntrac + is = (k-1) * km + do i = 1, im + a2(i,1+is) = q1(i,1,k) + enddo + enddo + endif +c + do k = 1,km1 + do i = 1,im + dtodsd = dt/del(i,k) + dtodsu = dt/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) +! rdz = rdzt(i,k)*2./(t1(i,k)+t1(i,k+1)) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + if(pblflg(i).and.k.lt.kpbl(i)) then +! dsdzt = dsig*dkt(i,k)*rdz*(gocp-hgamt(i)/hpbl(i)) +! dsdzq = dsig*dkt(i,k)*rdz*(-hgamq(i)/hpbl(i)) + ptem1 = dsig * dktx(i,k) * rdz + tem = 1.0 / hpbl(i) + dsdzt = tem1 * gocp - ptem1*hgamt(i)*tem + dsdzq = ptem1 * (-hgamq(i)*tem) + a2(i,k) = a2(i,k)+dtodsd*dsdzq + a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq + else +! dsdzt = dsig*dkt(i,k)*rdz*(gocp) + dsdzt = tem1 * gocp + a2(i,k+1) = q1(i,k+1,1) + endif +! dsdz2 = dsig*dkt(i,k)*rdz*rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + enddo + enddo + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + a2(i,k+1+is) = q1(i,k+1,kk) + enddo + enddo + enddo + endif +c +c solve tridiagonal problem for heat and moisture +c + call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2) +c +c recover tendencies of heat and moisture +c + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k))*rdt + qtend = (a2(i,k)-q1(i,k,1))*rdt + tau(i,k) = tau(i,k)+ttend + rtg(i,k,1) = rtg(i,k,1)+qtend + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend + enddo + enddo + if(ntrac.ge.2) then + do kk = 2, ntrac + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk)+qtend + enddo + enddo + enddo + endif +c +c compute tridiagonal matrix elements for momentum +c + do i=1,im + ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + a1(i,1) = u1(i,1) + a2(i,1) = v1(i,1) + enddo +c + do k = 1,km1 + do i=1,im + dtodsd = dt/del(i,k) + dtodsu = dt/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*rdz + if(pblflg(i).and.k.lt.kpbl(i))then + ptem1 = dsig*dkux(i,k)*rdz + dsdzu = ptem1*(-hgamu(i)/hpbl(i)) + dsdzv = ptem1*(-hgamv(i)/hpbl(i)) + a1(i,k) = a1(i,k)+dtodsd*dsdzu + a1(i,k+1) = u1(i,k+1)-dtodsu*dsdzu + a2(i,k) = a2(i,k)+dtodsd*dsdzv + a2(i,k+1) = v1(i,k+1)-dtodsu*dsdzv + else + a1(i,k+1) = u1(i,k+1) + a2(i,k+1) = v1(i,k+1) + endif +! dsdz2 = dsig*dku(i,k)*rdz*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +c +c solve tridiagonal problem for momentum +c + call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) +c +c recover tendencies of momentum +c + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k))*rdt + vtend = (a2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k) + utend + dv(i,k) = dv(i,k) + vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c estimate the pbl height for diagnostic purpose +c + do i = 1, im + if(scuflg(i)) then + thermal(i) = thlvx(i,1) + else + thermal(i) = thvx(i,1) + endif + flg(i) = .false. + rbup(i)= rbsoil(i) + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + if(scuflg(i)) then + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + else + rbup(i) = (thvx(i,k)-thermal(i))* + & (g*zl(i,k)/thvx(i,1))/spdk2 + endif + kpbl(i)= k + flg(i) = rbup(i).gt.rbcr + endif + enddo + enddo +c + do i = 1,im + k = kpbl(i) + if(rbdn(i).ge.rbcr) then + rbint = 0. + elseif(rbup(i).le.rbcr) then + rbint = 1. + else + rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end diff --git a/gsmphys/moninshoc.f b/gsmphys/moninshoc.f new file mode 100644 index 00000000..ca4c1a11 --- /dev/null +++ b/gsmphys/moninshoc.f @@ -0,0 +1,475 @@ +!!!!! ========================================================== !!!!! +! subroutine 'moninshoc' computes pbl height and applies vertical diffusion +! using the coefficient provided by the SHOC scheme (from previous step) +! 1015-05-04 - Shrinivas Moorthi - original version based on monin +! + subroutine moninshoc(ix,im,km,ntrac,ntcw,dv,du,tau,rtg, + & u1,v1,t1,q1,tkh,prnum,ntke, + & psk,rbsoil,zorl,u10m,v10m,fm,fh, + & tsea,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,delt, + & dusfc,dvsfc,dtsfc,dqsfc,dkt,hpbl, + & kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr,me) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, hvap => con_hvap, fv => con_fvirt + implicit none +! +! arguments +! + logical lprnt + integer ipr, me , ix, im, km, ntrac, ntcw, ntke + integer, dimension(im) :: kinver, kpbl +! + real(kind=kind_phys) delt, xkzm_m, xkzm_h, xkzm_s + real(kind=kind_phys), dimension(im,km) :: du, dv, tau, prnum +! + real(kind=kind_phys), dimension(im,km,ntrac) :: rtg + + real(kind=kind_phys), dimension(ix,km) :: u1, v1, t1, tkh + &, prsl, del, phil, prslk + real(kind=kind_phys), dimension(ix,km+1) :: prsi, phii + real(kind=kind_phys), dimension(ix,km,ntrac) :: q1 + real(kind=kind_phys), dimension(im) :: psk, rbsoil, zorl + &, spd1, u10m, v10m + &, fm, fh, tsea, hpbl + &, dusfc, dvsfc + &, dtsfc, dqsfc +! +! locals +! + integer i,iprt,is,k,kk,km1,kmpbl + integer kx1(im) +! + logical pblflg(im), sfcflg(im), flg(im) + + real(kind=kind_phys), dimension(im) :: evap, heat, phih, phim + &, rbdn, rbup, sflux, z0, crb, zol, thermal + &, stress, beta, tx1, tx2 +! + real(kind=kind_phys), dimension(im,km) :: theta, thvx, zl, a1, ad + real(kind=kind_phys), dimension(im,km-1):: xkzo, xkzmo, al, au + &, dku, dkt, rdzt +! &, dku, dkt, rdzt, prnum +! + real(kind=kind_phys) zi(im,km+1), a2(im,km*(ntrac+1)) +! + real(kind=kind_phys) dsdz2, dsdzq, dsdzt, dsig, dt2, rdt + &, dtodsd, dtodsu, rdz, tem, tem1, ptem + &, ttend, utend, vtend, qtend + &, spdk2, rbint, ri, zol1, robn, bvf2 +! + real(kind=kind_phys), parameter :: gravi=1.0/grav, zolcr=0.2, + & zolcru=-0.5, rimin=-100., sfcfrac=0.1, + & crbcon=0.25, crbmin=0.15, crbmax=0.35, + & qmin=1.e-8, zfmin=1.e-8, qlmin=1.e-12, + & aphi5=5., aphi16=16., f0=1.e-4 + &, cont=cp/grav, conq=hvap/grav,conw=1.0/grav + &, dkmin=0.0, dkmax=1000., xkzminv=0.3 + &, gocp=grav/cp, prmin=0.25, prmax=4.0 + &, vk=0.4, cfac=6.5 +! +!----------------------------------------------------------------------- +! +! compute preliminary variables +! + if (ix < im) stop +! + if (lprnt) write(0,*)' in moninshoc tsea=',tsea(ipr) + dt2 = delt + rdt = 1. / dt2 + km1 = km - 1 + kmpbl = km / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo +! + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + prnum(i,k) = 1.0 + enddo + enddo +! Setup backgrond diffision + do i=1,im + prnum(i,km) = 1.0 + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + enddo + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1)) + +! vertical background diffusivity for momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_m + kx1(i) = k + 1 + else + if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) + tem1 = 1.0 - prsi(i,k+1) * tx2(i) + tem1 = tem1 * tem1 * 5.0 + xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! if (lprnt) then +! print *,' xkzo=',(xkzo(ipr,k),k=1,km1) +! print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1) +! endif +! +! diffusivity in the inversion layer is set to be xkzminv (m^2/s) +! + do k = 1,kmpbl + do i=1,im + if(zi(i,k+1) > 250.) then + tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k) + if(tem1 > 1.e-5) then + xkzo(i,k) = min(xkzo(i,k),xkzminv) + endif + endif + enddo + enddo +! +! + do i = 1,im + z0(i) = 0.01 * zorl(i) + kpbl(i) = 1 + hpbl(i) = zi(i,1) + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do k = 1,km + do i = 1,im + tem = max(q1(i,k,ntcw),qlmin) + theta(i,k) = t1(i,k) * psk(i) / prslk(i,k) + thvx(i,k) = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-tem) + enddo + enddo +! + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + beta(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! +! compute the pbl height +! +! write(0,*)' IN moninbl u10=',u10m(1:5),' v10=',v10m(1:5) + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) +! + if(pblflg(i)) then + thermal(i) = thvx(i,1) + crb(i) = crbcon + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = max(1.0, sqrt(u10m(i)*u10m(i) + v10m(i)*v10m(i))) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + enddo + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)),1.) + rbup(i) = (thvx(i,k)-thermal(i))*phil(i,k) + & / (thvx(i,1)*spdk2) + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(kpbl(i) > 1) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + else + hpbl(i) = zl(i,1) + kpbl(i) = 1 + endif + enddo +! +! compute similarity parameters +! + do i=1,im + zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + if(sfcflg(i)) then + zol(i) = min(zol(i),-zfmin) + else + zol(i) = max(zol(i),zfmin) + endif + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then +! phim(i) = (1.-aphi16*zol1)**(-1./4.) +! phih(i) = (1.-aphi16*zol1)**(-1./2.) + tem = 1.0 / (1. - aphi16*zol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + endif + enddo +! +! enhance the pbl height by considering the thermal excess +! + do i=1,im + flg(i) = .true. + if (pblflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)),1.) + rbup(i) = (thvx(i,k)-thermal(i)) * phil(i,k) + & / (thvx(i,1)*spdk2) + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if (pblflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + if (k > 1) then + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1 + if(kpbl(i) <= 1) then + pblflg(i) = .false. + endif + else + pblflg(i) = .false. + endif + endif + if (pblflg(i)) then + tem = phih(i)/phim(i)+cfac*vk*sfcfrac + else + tem = phih(i)/phim(i) + endif + prnum(i,1) = min(prmin,max(prmax,tem)) + enddo +! + do i = 1, im + if(zol(i) > zolcr) then + kpbl(i) = 1 + endif + enddo +! +! compute Prandtl number above boundary layer +! + do k = 1, km1 + do i=1,im + if(k >= kpbl(i)) then + rdz = rdzt(i,k) + tem = u1(i,k)-u1(i,k+1) + tem1 = v1(i,k)-v1(i,k+1) + tem = (tem*tem + tem1*tem1) * rdz * rdz + bvf2 = (0.5*grav)*(thvx(i,k+1)-thvx(i,k))*rdz + & / (t1(i,k)+t1(i,k+1)) + ri = max(bvf2/tem,rimin) + if(ri < 0.) then ! unstable regime + prnum(i,k) = 1.0 + else + prnum(i,k) = min(1.0 + 2.1*ri, prmax) + endif + elseif (k > 1) then + prnum(i,k) = prnum(i,1) + endif +! +! prnum(i,k) = 1.0 + prnum(i,k) = max(prmin, min(prmax, prnum(i,k))) + tem = tkh(i,k+1) * prnum(i,k) + dku(i,k) = max(min(tem+xkzmo(i,k), dkmax), xkzmo(i,k)) + dkt(i,k) = max(min(tkh(i,k+1)+xkzo(i,k), dkmax), xkzo(i,k)) + enddo + enddo +! +! compute tridiagonal matrix elements for heat and moisture +! + do i=1,im + ad(i,1) = 1. + a1(i,1) = t1(i,1) + beta(i) * heat(i) + a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo + + if(ntrac > 2) then + do k = 2, ntrac-1 + is = (k-1) * km + do i = 1, im + a2(i,1+is) = q1(i,1,k) + enddo + enddo + endif +! + do k = 1,km1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + dsdzt = tem1 * gocp + a1(i,k) = a1(i,k)+dtodsd*dsdzt + a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + a2(i,k+1) = q1(i,k+1,1) +! + enddo + enddo +! + if(ntrac > 2) then + do kk = 2, ntrac-1 + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + a2(i,k+1+is) = q1(i,k+1,kk) + enddo + enddo + enddo + endif +! +! solve tridiagonal problem for heat and moisture +! + call tridin(im,km,ntrac-1,al,ad,au,a1,a2,au,a1,a2) + +! +! recover tendencies of heat and moisture +! + do k = 1,km + do i = 1,im + ttend = (a1(i,k)-t1(i,k)) * rdt + qtend = (a2(i,k)-q1(i,k,1)) * rdt + tau(i,k) = tau(i,k) + ttend + rtg(i,k,1) = rtg(i,k,1) + qtend + dtsfc(i) = dtsfc(i) + cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i) + conq*del(i,k)*qtend + enddo + enddo + if(ntrac > 2) then + do kk = 2, ntrac-1 + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (a2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk) + qtend + enddo + enddo + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i=1,im + ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i) + a1(i,1) = u1(i,1) + a2(i,1) = v1(i,1) + enddo + if (ntke > 0) then + do i = 1, im + a2(i,1+km) = q1(i,1,ntke) + enddo + endif +! + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig*dku(i,k)*rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 +! + ad(i,k) = ad(i,k) - au(i,k) + ad(i,k+1) = 1.0 - al(i,k) + a1(i,k+1) = u1(i,k+1) + a2(i,k+1) = v1(i,k+1) +! + enddo + enddo + if (ntke > 0) then ! solve tridiagonal problem for momentum and tke + do k = 1, km1 + do i = 1, im + a2(i,k+1+km) = q1(i,k+1,ntke) + enddo + enddo + call tridin(im,km,3,al,ad,au,a1,a2,au,a1,a2) +! + do k = 1, km ! recover tendencies of tke + do i = 1, im + qtend = (a2(i,k+km)-q1(i,k,ntke))*rdt + rtg(i,k,ntke) = rtg(i,k,ntke) + qtend + enddo + enddo + else ! solve tridiagonal problem for momentum + call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2) + endif +! +! recover tendencies of momentum +! + do k = 1,km + do i = 1,im + utend = (a1(i,k)-u1(i,k))*rdt + vtend = (a2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k) + utend + dv(i,k) = dv(i,k) + vtend + dusfc(i) = dusfc(i) + conw*del(i,k)*utend + dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend + enddo + enddo +! + return + end diff --git a/gsmphys/mstadb.f b/gsmphys/mstadb.f new file mode 100644 index 00000000..a3de3ea7 --- /dev/null +++ b/gsmphys/mstadb.f @@ -0,0 +1,80 @@ +C----------------------------------------------------------------------- + SUBROUTINE MSTADBT3(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV, + & KLCL,KBOT,KTOP,TCLD,QCLD) +cyt INCLUDE DBMSTADB; +cc + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS , ONLY : FTDP, FTHE, FTLCL, STMA + USE PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt + implicit none +cc +cc + integer k,k1,k2,km,i,im + real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl + real(kind=kind_phys) tma,tvcld,tvenv +cc + real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM), + & QENV(IM,KM), TCLD(IM,KM), QCLD(IM,KM) + INTEGER KLCL(IM), KBOT(IM), KTOP(IM) +C LOCAL ARRAYS + real(kind=kind_phys) SLKMA(IM), THEMA(IM) +C----------------------------------------------------------------------- +C DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. +C COMPUTE ITS LIFTING CONDENSATION LEVEL. +! + DO I=1,IM + SLKMA(I) = 0. + THEMA(I) = 0. + ENDDO + DO K=K1,K2 + DO I=1,IM + PV = PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) + TDPD = TENV(I,K)-FTDP(PV) + IF(TDPD.GT.0.) THEN + TLCL = FTLCL(TENV(I,K),TDPD) + SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K) + ELSE + TLCL = TENV(I,K) + SLKLCL = PRSLK(I,K) + ENDIF + THELCL=FTHE(TLCL,SLKLCL) + IF(THELCL.GT.THEMA(I)) THEN + SLKMA(I) = SLKLCL + THEMA(I) = THELCL + ENDIF + ENDDO + ENDDO +C----------------------------------------------------------------------- +C SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP +C THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. + DO I=1,IM + KLCL(I)=KM+1 + KBOT(I)=KM+1 + KTOP(I)=0 + ENDDO + DO K=1,KM + DO I=1,IM + TCLD(I,K)=0. + QCLD(I,K)=0. + ENDDO + ENDDO + DO K=K1,KM + DO I=1,IM + IF(PRSLK(I,K).LE.SLKMA(I)) THEN + KLCL(I)=MIN(KLCL(I),K) + CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA) +! TMA=FTMA(THEMA(I),PRSLK(I,K),QMA) + TVCLD=TMA*(1.+FV*QMA) + TVENV=TENV(I,K)*(1.+FV*QENV(I,K)) + IF(TVCLD.GT.TVENV) THEN + KBOT(I)=MIN(KBOT(I),K) + KTOP(I)=MAX(KTOP(I),K) + TCLD(I,K)=TMA-TENV(I,K) + QCLD(I,K)=QMA-QENV(I,K) + ENDIF + ENDIF + ENDDO + ENDDO +C----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/mstadbtn.f b/gsmphys/mstadbtn.f new file mode 100644 index 00000000..4bf650e0 --- /dev/null +++ b/gsmphys/mstadbtn.f @@ -0,0 +1,91 @@ +C----------------------------------------------------------------------- + SUBROUTINE MSTADBTN(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV,ctei, + & KLCL,KBOT,KTOP,TCLD,QCLD,ktopm,lprnt,ipr,ind) +! + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS , ONLY : FTDP, FTHE, FTLCL, STMA + USE PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt + implicit none +! + logical lprnt, ctei(im) + integer ktopm(im), ind(im), ipr +! + integer k,k1,k2,km,i,im + real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl + real(kind=kind_phys) tma,tvcld,tvenv +! + real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM), + & QENV(IM,KM), TCLD(IM,KM), QCLD(IM,KM) + INTEGER KLCL(IM), KBOT(IM), KTOP(IM) +! LOCAL ARRAYS + real(kind=kind_phys) SLKMA(IM), THEMA(IM) + logical find_ctop(im) +!----------------------------------------------------------------------- +! DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. +! COMPUTE ITS LIFTING CONDENSATION LEVEL. +! + DO I=1,IM + SLKMA(I) = 0. + THEMA(I) = 0. + ENDDO + DO K=K1,K2 + DO I=1,IM + PV = PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) + TDPD = TENV(I,K)-FTDP(PV) + IF(TDPD.GT.0.) THEN + TLCL = FTLCL(TENV(I,K),TDPD) + SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K) + ELSE + TLCL = TENV(I,K) + SLKLCL = PRSLK(I,K) + ENDIF + THELCL=FTHE(TLCL,SLKLCL) + IF(THELCL.GT.THEMA(I)) THEN + SLKMA(I) = SLKLCL + THEMA(I) = THELCL + ENDIF + ENDDO + ENDDO +!----------------------------------------------------------------------- +! SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP +! THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. + DO I=1,IM + KLCL(I)=KM+1 + KBOT(I)=KM+1 + KTOP(I)=0 + find_ctop(i) = .true. + ENDDO + DO K=1,KM + DO I=1,IM + TCLD(I,K)=0. + QCLD(I,K)=0. + ENDDO + ENDDO + DO K=K1,KM + DO I=1,IM +! if (lprnt .and. ind(i) == ipr) print *,' prslk=' +! &,prslk(i,k),' slkma=',slkma(i),' k=',k,' km=',km + IF(PRSLK(I,K).LE.SLKMA(I) .and. k <= ktopm(I)-1) THEN + KLCL(I) = MIN(KLCL(I),K) + CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA) +! TMA = FTMA(THEMA(I),PRSLK(I,K),QMA) + TVCLD = TMA*(1.+FV*QMA) + TVENV = TENV(I,K)*(1.+FV*QENV(I,K)) + +! if (lprnt .and. ind(i) == ipr) print *,' tvcld=' +! &,tvcld,' tvenv=',tvenv,' ktop=',ktop(i),' kbot=',kbot(i) + + IF(TVCLD > TVENV .and. find_ctop(i)) THEN + KBOT(I) = MIN(KBOT(I),K) + KTOP(I) = MAX(KTOP(I),K) + TCLD(I,K) = TMA - TENV(I,K) + QCLD(I,K) = QMA - QENV(I,K) + ELSEIF (KTOP(I) > 0 .and. .not. ctei(i)) THEN + find_ctop(i) = .false. + ENDIF + ENDIF + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/mstadbtn2.f b/gsmphys/mstadbtn2.f new file mode 100644 index 00000000..4bf650e0 --- /dev/null +++ b/gsmphys/mstadbtn2.f @@ -0,0 +1,91 @@ +C----------------------------------------------------------------------- + SUBROUTINE MSTADBTN(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV,ctei, + & KLCL,KBOT,KTOP,TCLD,QCLD,ktopm,lprnt,ipr,ind) +! + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS , ONLY : FTDP, FTHE, FTLCL, STMA + USE PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt + implicit none +! + logical lprnt, ctei(im) + integer ktopm(im), ind(im), ipr +! + integer k,k1,k2,km,i,im + real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl + real(kind=kind_phys) tma,tvcld,tvenv +! + real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM), + & QENV(IM,KM), TCLD(IM,KM), QCLD(IM,KM) + INTEGER KLCL(IM), KBOT(IM), KTOP(IM) +! LOCAL ARRAYS + real(kind=kind_phys) SLKMA(IM), THEMA(IM) + logical find_ctop(im) +!----------------------------------------------------------------------- +! DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2. +! COMPUTE ITS LIFTING CONDENSATION LEVEL. +! + DO I=1,IM + SLKMA(I) = 0. + THEMA(I) = 0. + ENDDO + DO K=K1,K2 + DO I=1,IM + PV = PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K)) + TDPD = TENV(I,K)-FTDP(PV) + IF(TDPD.GT.0.) THEN + TLCL = FTLCL(TENV(I,K),TDPD) + SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K) + ELSE + TLCL = TENV(I,K) + SLKLCL = PRSLK(I,K) + ENDIF + THELCL=FTHE(TLCL,SLKLCL) + IF(THELCL.GT.THEMA(I)) THEN + SLKMA(I) = SLKLCL + THEMA(I) = THELCL + ENDIF + ENDDO + ENDDO +!----------------------------------------------------------------------- +! SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP +! THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT. + DO I=1,IM + KLCL(I)=KM+1 + KBOT(I)=KM+1 + KTOP(I)=0 + find_ctop(i) = .true. + ENDDO + DO K=1,KM + DO I=1,IM + TCLD(I,K)=0. + QCLD(I,K)=0. + ENDDO + ENDDO + DO K=K1,KM + DO I=1,IM +! if (lprnt .and. ind(i) == ipr) print *,' prslk=' +! &,prslk(i,k),' slkma=',slkma(i),' k=',k,' km=',km + IF(PRSLK(I,K).LE.SLKMA(I) .and. k <= ktopm(I)-1) THEN + KLCL(I) = MIN(KLCL(I),K) + CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA) +! TMA = FTMA(THEMA(I),PRSLK(I,K),QMA) + TVCLD = TMA*(1.+FV*QMA) + TVENV = TENV(I,K)*(1.+FV*QENV(I,K)) + +! if (lprnt .and. ind(i) == ipr) print *,' tvcld=' +! &,tvcld,' tvenv=',tvenv,' ktop=',ktop(i),' kbot=',kbot(i) + + IF(TVCLD > TVENV .and. find_ctop(i)) THEN + KBOT(I) = MIN(KBOT(I),K) + KTOP(I) = MAX(KTOP(I),K) + TCLD(I,K) = TMA - TENV(I,K) + QCLD(I,K) = QMA - QENV(I,K) + ELSEIF (KTOP(I) > 0 .and. .not. ctei(i)) THEN + find_ctop(i) = .false. + ENDIF + ENDIF + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/mstcnv.f b/gsmphys/mstcnv.f new file mode 100644 index 00000000..c8469951 --- /dev/null +++ b/gsmphys/mstcnv.f @@ -0,0 +1,316 @@ + SUBROUTINE MSTCNV(IM,IX,KM,DT,T1,Q1,PRSL,DELPA,PRSLK,RAIN,CLW + &, rhc,lprnt,ipr) +!! + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS , ONLY : fpvs, ftdp, fthe, stma, ftlcl + USE PHYSCONS, HVAP => con_HVAP, CP => con_CP, RV => con_RV + &, EPS => con_eps, EPSM1 => con_epsm1, grav => con_g + implicit none +!! +! PHYSICAL PARAMETERS + real(kind=kind_phys) elocp, el2orc + PARAMETER(ELOCP=HVAP/CP, EL2ORC=HVAP*HVAP/(RV*CP)) +! real(kind=kind_phys), parameter :: pres_min=40000.0 ! in Pascals + real(kind=kind_phys), parameter :: pres_min=6000.0 ! in Pascals +! +! + logical lprnt + integer im,ix,km,ipr + real(kind=kind_phys) dt,rain(im) +! + real(kind=kind_phys) PRSL(IX,KM), PRSLK(IX,KM), DELPA(IX,KM) + real(kind=kind_phys) T1(IX,KM), Q1(IX,KM), CLW(IX,KM) + &, rhc(im,km) +! +! LOCAL VARIABLES +! + real(kind=kind_phys) P(IM,KM), TO(IM,KM), QO(IM,KM), QS(IM,KM) + &, THE(IM,KM), DQ(IM,KM), RAINLVL(IM,KM) + &, ES(IM,KM), DEL(IM,KM) + real(kind=kind_phys) pint(im), delqbar(im), deltbar(im), dqint(im) + &, ei(im), thebar(im), theint(im) + &, qevap, dpovg, rnevap, slklcl, tdpd + &, thelcl, tlcl, pmin + integer KMLEV(im,KM), k, kmax, kk(im), ks(im), ke(im), i +! + LOGICAL FLG(im), TOPFLG(im), TOTFLG +! + real(kind=kind_phys), parameter :: cons_0=0.d0, + & cons_1pdm8=1.d-8 +! + KMAX = 0 + DO K = 1, KM + pmin = 0.0 + do i=1,im + pmin = min(prsl(i,k), pmin) + enddo +! IF(pmin .GT. 6000.0) KMAX = K + 1 ! input pressure is in Pa + IF(pmin .GE. pres_min) KMAX = K + 1 ! input pressure is in Pa + ENDDO +! if (lprnt) print *,' kmax=',kmax +! +! SURFACE PRESSURE UNIT IS Pa +! + do i=1,im + RAIN(i) = 0. + DELTBAR(i) = 0. + DELQBAR(i) = 0. + FLG(i) = .FALSE. + ks(i) = 0 +! ke(i) = kmax + 1 + TOPFLG(i) = .FALSE. + enddo + do k=1,kmax + do i=1,im +! if (lprnt .and. i == ipr) print *,' p=',p(i,k) +! &,' ke=',ke(i) + if (p(i,k) >= pres_min) ke(i) = k + 1 + enddo + enddo + TOTFLG = .FALSE. +! if (lprnt) print *,' ke0=',ke(ipr),' ks0=',ks(ipr) +! &,' i=',ipr,'p=',p(ipr,kmax) +! +cselaDG3 IF(LAT.EQ.LATD) THEN +cselaDG3 PRINT *, ' T AND Q BEFORE ADJUSTMENT' +cselaDG3 PRINT 6000, (T1(k)-273.16,K=1,KMAX) +cselaDG3 PRINT 6000, (Q1(k)*1.E3,K=1,KMAX) +cselaDG3 PRINT *, ' PS =', PS +cselaDG3 ENDIF +! +! +! COLUMN VARIABLES +! P IS PRESSURE OF THE LAYER (Pa) +! TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN +! QO IS MIXING RATIO AT T+DT (KG/KG)..Q1 +! + DO K = 1, KMAX + do i=1,im + P(i,k) = PRSL(I,K) + TO(i,k) = T1(i,k) + QO(i,k) = Q1(i,k) + DEL(i,k) = DELPA(i,k) * 0.001 ! Convert from Pa to kPa (aka Cb) + enddo + ENDDO +! if (lprnt) then +! print *,' toin=',to(ipr,:) +! print *,' pin=',p(ipr,:) +! print *,' prslk=',prslk(ipr,:) +! endif +! +! MODEL CONSISTENT SATURATION MIXING RATIO +! + DO K = 1, KMAX + do i=1,im + if (p(i,k) >= pres_min) then + ES(i,k) = min(P(i,k), FPVS(T1(i,k))) + QS(i,k) = EPS * ES(i,k) / (P(i,k) + EPSM1 * ES(i,k)) + QS(i,k) = MAX(QS(i,k),cons_1pdm8) + IF(QO(i,k) .GT. QS(i,k)) FLG(i) = .TRUE. + endif + enddo + ENDDO + do i=1,im + IF (FLG(i)) TOTFLG = .TRUE. + enddo + IF (.NOT. TOTFLG) RETURN +! + DO K = 1, KMAX + do i=1,im + DQ(i,k) = 0. + THE(i,k) = TO(i,k) + enddo + ENDDO +! if (lprnt) print *,' qs=',(qs(ipr,k),k=1,kmax) +! +! COMPUTE THETA-E +! + DO K = 1, KMAX + do i=1,im + IF(FLG(i) .and. p(i,k) >= pres_min) THEN + THE(i,k) = FTHE(TO(i,k),prslk(i,k)) + IF (THE(i,k) .EQ. 0.) THEN + THE(i,k) = TO(i,k) / prslk(i,k) + ENDIF +C THE(i,k) = TO(i,k) * ((P(i,k) - ES(i,k))*0.01) ** (-ROCP) +C & * EXP(ELOCP * QS(i,k) / TO(i,k)) + DQ(i,k) = QO(i,k)- QS(i,k) +! +! MODIFICATION OF THETA-E FOR SUPER-SATURATION +! + THE(i,k)= THE(i,k) * (1. + HVAP*MAX(DQ(i,k),cons_0) + & / (CP*TO(i,k))) +! if (lprnt .and. i .eq. ipr) print *,' k=',k,' the=',the(i,k) +! &,' dq=',dq(i,k) + ENDIF + enddo + ENDDO +! +cselaDG3 IF(LAT.EQ.LATD.AND.FLG(LOND)) THEN +cselaDG3 PRINT *, ' THETA-E, QS AND DQ BEFORE ADJUSTMENT' +cselaDG3 PRINT 6000, (THE(k)-273.16,K=1,KMAX) +cselaDG3 PRINT 6000, (QS(k)*1.E3,K=1,KMAX) +cselaDG3 PRINT 6000, (DQ(k)*1.E3,K=1,KMAX) +cselaDG3 ENDIF +! + DO K = 1, KMAX + do i=1,im + KMLEV(i,k) = 0 + RAINLVL(i,k) = 0. + enddo + ENDDO +! +! STARTING POINT OF ADJUSTMENT +! + k = 1 + do i=1,im + KK(i) = 0 + DQINT(i) = 0. + THEINT(i) = 0. + THEBAR(i) = 0. + PINT(i) = 0. +! +! FOR CONDITIONALLY UNSTABLE AND SUPERSATURATED LAYERS, +! OBTAIN INTEGRATED THETA AND Q-QS +! +! KMLEV KEEPS TRACK OF THE NUMBER OF LAYERS THAT SATISFIES +! THE CONDITION FOR ADJUSTMENT +! + IF(DQ(i,k).GT.0..AND.THE(i,k).GE.THE(i,K+1).AND.FLG(i)) THEN + DQINT(i) = DQINT(i) + DQ(i,k) * DEL(i,K) + THEINT(i) = THEINT(i) + THE(i,k) * DEL(i,K) + PINT(i) = PINT(i) + DEL(i,K) + KK(i) = KK(i) + 1 + KMLEV(i,k) = KK(i) + ENDIF + enddo +! if (lprnt) print *,' kmlev=',kmlev(ipr,k),' k=',k + DO K = 2, KMAX - 1 + do i=1,im + if(p(i,k) >= pres_min) then + IF(DQ(i,k).GT.0..AND.THE(i,k).GE.THE(i,K+1).AND.FLG(i)) THEN + DQINT(i) = DQINT(i) + DQ(i,k) * DEL(i,K) + THEINT(i) = THEINT(i) + THE(i,k) * DEL(i,K) + PINT(i) = PINT(i) + DEL(i,K) + KK(i) = KK(i) + 1 + KMLEV(i,k) = KK(i) + ENDIF +! if (lprnt) print *,' kmlev=',kmlev(ipr,k),' k=',k +! + IF (PINT(i) .GT. 0.)THEBAR(i) = THEINT(i) / PINT(i) +! +! IF THE LAYER BELOW SATISFIES THE CONDITION AND THE PRESENT +! LAYER IS COLDER THAN THE ADJSUTED THETA-E, +! THE LAYER IS INCLUDED IF THE INTEGRATED MOISTURE EXCESS +! CAN BE MAINTAINED +! + IF (KMLEV(i,k) .EQ.0 .AND. KMLEV(i,K-1) .GT. 0 .AND. + & THEBAR(i) .GE. THE(i,k) .AND. .NOT. TOPFLG(i)) THEN + DQINT(i) = DQINT(i) + DQ(i,k) * DEL(i,K) +! ENDIF +! IF (KMLEV(i,k) .EQ. 0 .AND. KMLEV(i,K-1) .GT. 0 .AND. +! & THEBAR(i) .GE. THE(i,k) .AND. DQINT(i) .GT. 0. +! & .AND. .NOT. TOPFLG(i)) THEN + if (dqint(i) .gt. 0) then + KK(i) = KK(i) + 1 + KMLEV(i,k) = KK(i) + TOPFLG(i) = .TRUE. + EI(i) = P(i,k) * QO(i,k) / (EPS - EPSM1 * QO(i,k)) + EI(i) = MIN(MAX(EI(i),cons_1pdm8),ES(i,k)) !constant + TDPD = MAX(TO(i,k)-FTDP(EI(i)),cons_0) !constant + TLCL = FTLCL(TO(i,k), TDPD) + SLKLCL = prSLK(i,K) * TLCL / TO(i,k) + THELCL = FTHE(TLCL,SLKLCL) + IF(THELCL.NE.0.) THEN + THE(i,k) = THELCL +C THE(i,k) = TO(i,k) * ((P(i,k) - EI(i))*.01) ** (-ROCP) +C & * EXP(ELOCP * MAX(QO(i,k),1.E-8) / TO(i,k)) + ENDIF + THEINT(i) = THEINT(i) + THE(i,k) * DEL(i,K) + PINT(i) = PINT(i) + DEL(i,K) + endif + ENDIF + endif +! +! RESET THE INTEGRAL IF THE LAYER IS NOT IN THE CLOUD +! +! if (lprnt) print *,' kmlev3=',kmlev(ipr,k),' k=',k + IF (KMLEV(i,k) .EQ. 0 .AND. KMLEV(i,K-1) .GT. 0) THEN + THEBAR(i) = THEINT(i) / PINT(i) + DQINT(i) = 0. + THEINT(i) = 0. + PINT(i) = 0. + KK(i) = 0 + ks(i) = k - 1 + ke(i) = ks(i) - kmlev(i,k-1) + 1 + flg(i) = .false. + ENDIF + enddo + enddo +! +! When within A CLOUD LAYER, COMPUTE THE MOIST-ADIABATIC +! (TO AND QO) USING THE AVERAGED THETA-E AND THE RESULTANT RAIN +! +! if (lprnt) print *,' ke=',ke(ipr),' ks=',ks(ipr) + do k = 1, kmax + do i=1,im + if (k .ge. ke(i) .and. k .le. ks(i)) then + CALL STMA(THEBAR(i),PRSLK(i,k),TO(i,k),QO(i,k)) + THE(i,k) = THEBAR(i) + QS(i,k) = QO(i,k) +! + DPOVG = DEL(i,K) / grav + RAINLVL(i,k) = (Q1(i,k) - QO(i,k)) * DPOVG + clw(i,k) = clw(i,k) + Q1(i,k) - QO(i,k) + DELTBAR(i) = DELTBAR(i) + (TO(i,k) - T1(i,k)) * DPOVG + & / PRSLK(i,k) + DELQBAR(i) = DELQBAR(i) - RAINLVL(i,K) +! if (lprnt) print *,' k=',k,' to=',to(i,k),' qo=',qo(i,k), +! & ' rainlvl=',rainlvl(i,k) + ENDIF + enddo + ENDDO +! +! EVAPORATION OF FALLING RAIN +! +! DO K = KMAX, 1, -1 +! do i=1,im +! T1(i,k) = TO(i,k) +! Q1(i,k) = QO(i,k) +! DPOVG = DEL(i,K) / grav +! IF (RAIN(i) .GT. 0. .AND. RAINLVL(i,k) .LE. 0.) THEN +! DQ(i,k) = (QO(i,k) - QS(i,k)*rhc(i,k)) +! & / (1. + EL2ORC*QS(i,k)/(TO(i,k)*TO(i,k))) +! QEVAP =-DQ(i,k)*(1.-EXP(-0.32*SQRT(DT*RAIN(i)))) +!! & -clw(i,k) +! RNEVAP = MIN(QEVAP*DPOVG,RAIN(i)) +! Q1(i,k) = Q1(i,k)+RNEVAP/DPOVG +! T1(i,k) = T1(i,k)-RNEVAP/DPOVG*ELOCP +! RAIN(i) = RAIN(i) - RNEVAP +! DELTBAR(i) = DELTBAR(i) - RNEVAP * ELOCP +! DELQBAR(i) = DELQBAR(i) + RNEVAP +! ELSE +! RAIN(i) = RAIN(i) + RAINLVL(i,k) +! ENDIF +! enddo +! ENDDO +! +cselaDG3 IF(LAT.EQ.LATD.AND.FLG(LOND)) THEN +cselaDG3 PRINT *, ' THETA-E AFTER ADJUSTMENT' +cselaDG3 PRINT 6000, (THE(k)-273.16,K=1,KMAX) +cselaDG3 PRINT *, ' T AND Q AFTER ADJUSTMENT' +cselaDG3 PRINT 6000, (T1(k)-273.16,K=1,KMAX) +cselaDG3 PRINT 6000, (Q1(k)*1.E3,K=1,KMAX) +cselaDG3 PRINT *, ' DELTBAR, DELQBAR =', DELTBAR*CP,DELQBAR*HVAP +cselaDG3 PRINT *, ' RAIN =', HVAP*RAIN +cselaDG3 ENDIF +!6000 FORMAT(2X,0P,11(F6.2,1H,)) +!6100 FORMAT(2X,3P11F7.2) +! +! do i=1,im +! RAIN(i) = MAX(RAIN(i),cons_0) +! enddo +! if (lprnt) print *,' rain_in_mst=',rain(ipr) +! + RETURN + END diff --git a/gsmphys/myj_jsfc.F90 b/gsmphys/myj_jsfc.F90 new file mode 100644 index 00000000..cba1ee9d --- /dev/null +++ b/gsmphys/myj_jsfc.F90 @@ -0,0 +1,1345 @@ +!----------------------------------------------------------------------- +! +!! SEE ALSO INIT BELOW + MODULE MYJ_JSFC_MOD +! +!----------------------------------------------------------------------- +! +!*** THE J SURFACE SCHEME +! +!----------------------------------------------------------------------- +! +! Switched to using FMS/GFS constants where possible, hard-coded others --- lmh 25oct17 +!!$ USE MODULE_CONSTANTS,ONLY : A2,A3,A4,CP,ELWV & +!!$ ,G,P608,PI,PQ0,R_D,R_V,CAPPA + + use machine, only: kind_phys + use physcons, only: CP => con_cp, & + G=>con_g, R_D=>con_rd, & + R_V=>con_rv, elwv=>con_hvap, eliv=>con_hfus, & + PI=>con_pi +! +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! + PRIVATE +! + PUBLIC :: myj_jsfc, myj_jsfc_init +! + INTEGER :: ITRMX=5 ! Iteration count for mixing length computation +! + + integer, PARAMETER:: kfpt=kind_phys + integer, PARAMETER:: kint=8 + integer, PARAMETER:: klog=4 + + real(kind=kfpt), PARAMETER:: & + a2=17.2693882 & ! saturation spec. humidity formula coeff. + ,a3=273.15 & ! saturation spec. humidity formula coeff. + ,a4=35.86 & ! saturation spec. humidity formula coeff. + ,eliwv=2.683e6 & ! latent heat, mix ice/water - vapor + ,ep_1=R_V/R_D - 1. & + ,epsq=1.e-12 & ! floor value for specific humidity (kg/kg) + ,p608=R_V/R_D - 1. & ! factor for water vapor in virtual temperature (same as ep_1) + ,pq0=379.90516 & ! water vapor pressure for tetens formula + ,rhowater=1000. & ! density of water (kg/m3) + ,cappa=R_D/CP + + REAL,PARAMETER :: VKARMAN=0.4 + + REAL,PARAMETER :: XLV=ELWV + REAL,PARAMETER :: ELOCP=2.72E6/CP + REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 + REAL,PARAMETER :: GLKBR=10.,GLKBS=30. & + ,QVISC=2.1E-5,RIC=0.505,SMALL=0.35 & + ,SQPR=0.84,SQSC=0.84,SQVISC=258.2 & + ,TVISC=2.1E-5 & + ,USTC=0.7,USTR=0.225,VISC=1.5E-5 & + ,WWST=1.2,ZTFC=1. + REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC + + REAL,PARAMETER :: CZIV=SMALL*GLKBS,GRRS=GLKBR/GLKBS + + REAL,PARAMETER :: RTVISC=1./TVISC,RVISC=1./VISC & + ,ZQRZT=SQSC/SQPR + + REAL,PARAMETER :: USTFC=0.018/G & + ,FZQ1=RTVISC*QVISC*ZQRZT & + ,FZQ2=RTVISC*QVISC*ZQRZT & + ,FZT1=RVISC *TVISC*SQPR & + ,FZT2=CZIV*GRRS*TVISC*SQPR & + ,FZU1=CZIV*VISC + REAL,PARAMETER :: WWST2=WWST*WWST & + ,RQVISC=1./QVISC + + REAL,PARAMETER :: RCAP=1./CAPPA + REAL,PARAMETER :: GOCP02=G/CP*2.,GOCP10=G/CP*10. + REAL,PARAMETER :: EPSU2=1.E-6,EPSUST=1.E-9,EPSZT=1.E-28 + REAL,PARAMETER :: CZIL=0.1,EXCML=0.0001,EXCMS=0.0001 & + & ,FH=1.10,TOPOFAC=9.0e-6 + + REAL,PARAMETER :: ZILFC=-CZIL*VKARMAN*SQVISC + +! +!----------------------------------------------------------------------- + INTEGER, PARAMETER :: KZTM=10001,KZTM2=KZTM-2 +! + REAL :: DZETA1,DZETA2,FH01,FH02,ZTMAX1,ZTMAX2,ZTMIN1,ZTMIN2 +! + REAL,DIMENSION(KZTM) :: PSIH1,PSIH2,PSIM1,PSIM2 +! + INTEGER :: IERR +! +!----------------------------------------------------------------------- +! + CONTAINS +! +!----------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!----------------------------------------------------------------------- + SUBROUTINE MYJ_JSFC(NTSD,EPSL,EPSQ2,HT,DZ & + & ,PHMID,PHINT,TH,T,Q,QC,U,V,Q2 & + & ,TSK,QSFC,THZ0,QZ0,UZ0,VZ0 & + & ,XLAND & + & ,VEGFRC & + & ,USTAR,Z0,PBLH,MAVAIL & + & ,AKHS,AKMS & + & ,CHS,CQS,HFX,FLX_LH & + & ,U10,V10,T02,TH02,TSHLTR,TH10,Q02,QSHLTR,Q10 & + & ,PSHLTR,RIB & ! Added Bulk Richardson No. + & ,FLAG_ITER,ITER,REDRAG,LPRNT & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM +! + INTEGER,INTENT(IN) :: NTSD + !Minimum TKE + real,dimension(kts:lm),intent(inout):: epsq2 + real,dimension(kts:lm-1),intent(inout):: epsl +! + + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HT,MAVAIL,TSK & ! sfc height, moisture availability, Tsfc + & ,XLAND & ! land frac + & ,VEGFRC ! fraction of vegetated land +! + REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: DZ,PHMID ! dz, layer-mean pressure +! + REAL,DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN) :: PHINT ! layer-interface pressure +! + REAL,DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN) :: Q,QC,U,V,Q2,T,TH ! self-explanatory; Q2 is TKE +! + !?SHLTR are for shelter-level diagnostics (redundant with ?10 / ?2 ??) + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: FLX_LH,HFX,PSHLTR & ! ELFLX, TWBS, some sort of diag? + & ,Q10,QSHLTR & ! diags + & ,TH10,TSHLTR,T02 & ! diagnostics + & ,U10,V10,TH02,Q02 ! diagnostics +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS & ! exchange coefficients + & ,PBLH,QSFC,RIB ! PBL height, qsfc, BRN +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: QZ0,THZ0 & !variables at z=z0 + & ,USTAR,UZ0,VZ0 & + & ,Z0 ! time-varying z0 (znt elsewhere) +! +!see definitions in land model + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: CHS,CQS !sfc exchange coeff for heat & moisture, + + LOGICAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: FLAG_ITER + INTEGER, INTENT(IN) :: ITER + LOGICAL, INTENT(IN) :: REDRAG, LPRNT +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: I,J,K,LMH,LPBL +! + REAL :: A,APESFC,B,BTGX,CWMLOW & + & ,DQDT,DTDIF,DTDT,DUDT,DVDT & + & ,FIS & + & ,P02P,P10P,PLOW,PSFC,PTOP,QLOW,QS02,QS10 & + & ,RAPA,RAPA02,RAPA10,RATIOMX,RDZ,SEAMASK,SM & + & ,T02P,T10P,TEM,TH02P,TH10P,THLOW,THELOW,THM & + & ,TLOW,TZ0,ULOW,VLOW,ZSL,WIND +! + REAL,DIMENSION(KTS:LM) :: CWMK,PK,Q2K,QK,THEK,THK,TK,UK,VK +! + REAL,DIMENSION(KTS:LM-1) :: EL,ELM +! + REAL,DIMENSION(KTS:LM+1) :: ZHK +! + REAL,DIMENSION(ITS:ITE,JTS:JTE) :: THSK +! + REAL,DIMENSION(ITS:ITE,JTS:JTE,KTS:LM+1) :: ZINT +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! +!*** MAKE PREPARATIONS +! +!---------------------------------------------------------------------- + DO K=KTS,LM+1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=0. + ENDDO + ENDDO + ENDDO + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,LM+1)=HT(I,J) ! Z at bottom of lowest sigma layer +! +!!!!!!!!! +!!!!!! UNCOMMENT THESE LINES IF USING ETA COORDINATES +!!!!!!!!! +!!!!!! ZINT(I,J,LM+1)=1.E-4 ! Z of bottom of lowest eta layer +!!!!!! ZHK(LM+1)=1.E-4 ! Z of bottom of lowest eta layer +! + ENDDO + ENDDO + + DO K=LM,KTS,-1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=ZINT(I,J,K+1)+DZ(I,J,K) + ENDDO + ENDDO + ENDDO +! +!!$ IF(NTSD==0) then +!!$ DO J=JTS,JTE +!!$ DO I=ITS,ITE +!!$ FIS=HT(I,J)*G +!!$ SM=XLAND(I,J)-1. +!!! Z0(I,J)=SM*Z0SEA+(1.-SM)*(Z0(I,J)*Z0MAX+FIS*FCM+Z0LAND) +!!! Z0(I,J)=SM*Z0SEA+(1.-SM)*(Z0(I,J)*Z0MAX+FIS*FCM+Z0LAND) +!!$ ENDDO +!!$ ENDDO +!!$ ENDIF + + + IF (ITER == 1) THEN + + ! + + DO K=KTS,LM + !At one time EPSL/EPSQ2 had a tapering function. Now they are just constant 0.02 and 0.1 + !! ARG=(PSINT(K)-PSINT(2))/(PSINT(LM)-PSINT(2))*PI + ! int_state%EPSQ2(K-1)=(1.+COS(ARG))*0.09+0.02 + EPSQ2(K)=0.02 + ENDDO + DO K=KTS,LM-1 + EPSL(K) = 0.1 + ENDDO + ! + DO J=JTS,JTE + DO I=ITS,ITE + PBLH(I,J)=-1. + ENDDO + ENDDO + ! + IF(NTSD==0) then + DO J=JTS,JTE + DO I=ITS,ITE + USTAR(I,J)=0.1 +!!$ FIS=HT(I,J)*G +!!$ SM=XLAND(I,J)-1. +!!! Z0(I,J)=SM*Z0SEA+(1.-SM)*(Z0(I,J)*Z0MAX+FIS*FCM+Z0LAND) +!!! Z0(I,J)=SM*Z0SEA+(1.-SM)*(Z0(I,J)*Z0MAX+FIS*FCM+Z0LAND) + ENDDO + ENDDO + ENDIF + ! +!!!! IF(NTSD==1)THEN +!!$ DO J=JTS,JTE +!!$ DO I=ITS,ITE +!!$ CT(I,J)=0. +!!$ ENDDO +!!$ ENDDO +!!!! ENDIF + + + ENDIF ! ITER == 1 +! +!...................................................................... +!$no-mp parallel do & +!$no-mp private (j,i,lmh,ptop,psfc,seamask,k,thk,tk,ratiomx,qk,pk, & +!$no-mp cwmk,thek,q2k,zhk,uk,vk,lpbl,plow,tlow,thlow,thelow, & +!$no-mp qlow,cwmlow,ulow,vlow,zsl,apesfc,tz0,rapa,th02p,th10p, & +!$no-mp rapa02,rapa10,t02p,t10p,p02p,p10p,qs02,qs10) +!...................................................................... +!---------------------------------------------------------------------- + setup_integration: DO J=JTS,JTE +!---------------------------------------------------------------------- +! + DO I=ITS,ITE + + IF (FLAG_ITER(I,J)) THEN +! +!*** LOWEST LAYER ABOVE GROUND MUST BE FLIPPED +! + LMH=LM +! + PTOP=PHINT(I,J,1) + PSFC=PHINT(I,J,LMH+1) +! Define THSK here (for first timestep mostly) + THSK(I,J)=TSK(I,J)/(PSFC*1.E-5)**CAPPA +! +!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) +! + SEAMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=LM,KTS,-1 + THK(K)=TH(I,J,K) + TK(K)=T(I,J,K) + QK(K)=Q(I,J,K) + PK(K)=PHMID(I,J,K) + CWMK(K)=QC(I,J,K) + THEK(K)=(CWMK(K)*(-ELOCP/TK(K))+1.)*THK(K) + Q2K(K)=Q2(I,J,K) +! +! +!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES +! + ZHK(K)=ZINT(I,J,K) +! + ENDDO + ZHK(LM+1)=HT(I,J) ! Z at bottom of lowest sigma layer +! + DO K=LM,KTS,-1 + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + ENDDO +! +!*** FIND THE HEIGHT OF THE PBL +! + LPBL=LMH + DO K=LMH-1,1,-1 + IF(Q2K(K)<=EPSQ2(K)*FH) THEN + LPBL=K + GO TO 110 + ENDIF + ENDDO +! + LPBL=1 +! +!----------------------------------------------------------------------- +!--------------THE HEIGHT OF THE PBL------------------------------------ +!----------------------------------------------------------------------- +! + 110 PBLH(I,J)=ZHK(LPBL)-ZHK(LMH+1) +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE SURFACE EXCHANGE COEFFICIENTS +!*** +!---------------------------------------------------------------------- + PLOW=PK(LMH) + TLOW=TK(LMH) + THLOW=THK(LMH) + THELOW=THEK(LMH) + QLOW=QK(LMH) + CWMLOW=CWMK(LMH) + ULOW=UK(LMH) + VLOW=VK(LMH) + ZSL=(ZHK(LMH)-ZHK(LMH+1))*0.5 + APESFC=(PSFC*1.E-5)**CAPPA + if(NTSD==0) then + TZ0=TSK(I,J) + !Following initialization added lmh 3nov17 + QZ0(I,J)=QSFC(I,J) + WIND = SQRT(ULOW*ULOW + VLOW*VLOW) + UZ0(I,J)=(USTAR(I,J)/WIND)*ULOW + VZ0(I,J)=(USTAR(I,J)/WIND)*VLOW + else + TZ0=THZ0(I,J)*APESFC + endif +! + CALL SFCDIF(NTSD,SEAMASK,THSK(I,J),QSFC(I,J),PSFC & + & ,UZ0(I,J),VZ0(I,J),TZ0,THZ0(I,J),QZ0(I,J) & + & ,USTAR(I,J),Z0(I,J) & + & ,AKMS(I,J),AKHS(I,J),PBLH(I,J),MAVAIL(I,J) & + & ,CHS(I,J),CQS(I,J) & + & ,HFX(I,J),FLX_LH(I,J) & + & ,ULOW,VLOW,TLOW,THLOW,THELOW,QLOW,CWMLOW & + & ,ZSL,PLOW & + & ,VEGFRC(I,J) & !added 5/17/2013 + & ,U10(I,J),V10(I,J),TSHLTR(I,J),TH10(I,J) & + & ,QSHLTR(I,J),Q10(I,J),PSHLTR(I,J) & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM,I,J,ZHK(LMH+1) & + & ,RIB(I,J),REDRAG,LPRNT) ! Added Bulk Richardson No. +! +!*** REMOVE SUPERATURATION AT 2M AND 10M +! + RAPA=APESFC + TH02P=TSHLTR(I,J) + TH10P=TH10(I,J) + TH02(I,J)=TSHLTR(I,J) +! + RAPA02=RAPA-GOCP02/TH02P + RAPA10=RAPA-GOCP10/TH10P +! + T02P=TH02P*RAPA02 + T10P=TH10P*RAPA10 +! 1 may 06 tgs T02(I,J) = T02P + T02(I,J) = TH02(I,J)*APESFC +! + P02P=(RAPA02**RCAP)*1.E5 + P10P=(RAPA10**RCAP)*1.E5 +! + QS02=PQ0/P02P*EXP(A2*(T02P-A3)/(T02P-A4)) + QS10=PQ0/P10P*EXP(A2*(T10P-A3)/(T10P-A4)) +! + IF(QSHLTR(I,J)>QS02)QSHLTR(I,J)=QS02 + IF(Q10 (I,J)>QS10)Q10 (I,J)=QS10 + Q02(I,J)=QSHLTR(I,J)/(1.-QSHLTR(I,J)) +!---------------------------------------------------------------------- +! + ENDIF ! FLAG_ITER + + ENDDO +! +!---------------------------------------------------------------------- +! + ENDDO setup_integration +! +!...................................................................... +!$no-mp end parallel do +!...................................................................... +!---------------------------------------------------------------------- + + END SUBROUTINE MYJ_JSFC +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC & + & ,UZ0,VZ0,TZ0,THZ0,QZ0 & + & ,USTAR,Z0,AKMS,AKHS,PBLH,WETM & + & ,CHS,CQS,HFX,FLX_LH & + & ,ULOW,VLOW,TLOW,THLOW,THELOW,QLOW,CWMLOW & + & ,ZSL,PLOW & + & ,VEGF & !added 5/17/2013 + & ,U10,V10,TH02,TH10,Q02,Q10,PSHLTR & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM & + & ,I,J,ZSFC,RIB,REDRAG,LPRNT) ! Added Bulk Richardson No. +! **************************************************************** +! * * +! * SURFACE LAYER * +! * * +! **************************************************************** +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM,i,j +! + INTEGER,INTENT(IN) :: NTSD +! + REAL,INTENT(IN) :: CWMLOW,PBLH,PLOW,QLOW,PSFC,SEAMASK,ZSFC & + & ,THELOW,THLOW,THS,TLOW,TZ0,ULOW,VLOW,WETM,ZSL & + & ,VEGF +! + REAL,INTENT(OUT) :: CHS,CQS,FLX_LH,HFX & + & ,RIB,PSHLTR,Q02,Q10,TH02,TH10,U10,V10 +! + REAL,INTENT(INOUT) :: AKHS,AKMS,QZ0,THZ0,USTAR,UZ0,VZ0,Z0,QS + + LOGICAL,INTENT(IN) :: REDRAG, LPRNT +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: ITR,K +! + REAL, PARAMETER :: z0s_max = 0.317e-2 +! + REAL :: A,B,BTGH,BTGX,CXCHL,CXCHS,DTHV,DU2,ELFC,FCT & + & ,HLFLX,HSFLX,HV,PSH02,PSH10,PSHZ,PSHZL,PSM10,PSMZ,PSMZL & + & ,RDZ,RDZT,RLMA,RLMN,RLMP & + & ,RLOGT,RLOGU,RWGH,RZ,RZST,RZSU,SIMH,SIMM,TEM,THM & + & ,UMFLX,USTARK,VMFLX,WGHT,WGHTT,WGHTQ,WSTAR2 & + & ,X,XLT,XLT4,XLU,XLU4,XT,XT4,XU,XU4,ZETALT,ZETALU & + & ,ZETAT,ZETAU,ZQ,ZSLT,ZSLU,ZT,ZU,TOPOTERM,ZZIL,CZETMAX, RLMO, QFX +!vcw +! +!*** DIAGNOSTICS +! + REAL :: AKHS02,AKHS10,AKMS02,AKMS10,EKMS10,QSAT10,QSAT2 & + & ,RLNT02,RLNT10,RLNU10,SIMH02,SIMH10,SIMM10,T02,T10 & + & ,TERM1,RLOW,U10E,V10E,WSTAR,XLT02,XLT024,XLT10 & + & ,XLT104,XLU10,XLU104,XU10,XU104,ZT02,ZT10,ZTAT02,ZTAT10 & + & ,ZTAU,ZTAU10,ZU10,ZUUZ +! REAL :: ZILFC1,SNOWZO, Zom_ztmax +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- + RDZ=1./ZSL + CXCHL=EXCML*RDZ + CXCHS=EXCMS*RDZ +! + BTGX=G/THLOW + ELFC=VKARMAN*BTGX +! + IF(PBLH>1000.)THEN + BTGH=BTGX*PBLH + ELSE + BTGH=BTGX*1000. + ENDIF + + WGHT = 0. + WGHTT = 0. + WGHTQ = 0. +! +!---------------------------------------------------------------------- +! +!*** SEA POINTS +! +!---------------------------------------------------------------------- +! + IF(SEAMASK>0.5)THEN +! +!---------------------------------------------------------------------- + DO ITR=1,ITRMX +!---------------------------------------------------------------------- + Z0=MAX(USTFC*USTAR*USTAR,1.59E-5) +!!$ ! Added GFS surface-roughness calculation --- lmh 26 oct 17 +!!$ Z0 = USTFC*USTAR*USTAR ! ustfc = 0.18/g ; larger than 0.14/g in GFS physics +!!$ if (REDRAG) THEN +!!$ Z0 = 100.0 * max(min(z0, z0s_max), 1.e-7) +!!$ ELSE +!!$ Z0 = 100.0 * max(min(z0,.1), 1.e-7) +!!$ ENDIF +! +!*** VISCOUS SUBLAYER, JANJIC MWR 1994 +! +!---------------------------------------------------------------------- + IF(USTAR0)THEN + THZ0=((WGHTT*THLOW+THS)/(WGHTT+1.)+THZ0)*0.5 + QZ0=((WGHTQ*QLOW+QS)/(WGHTQ+1.)+QZ0)*0.5 + ELSE + THZ0=(WGHTT*THLOW+THS)/(WGHTT+1.) + QZ0=(WGHTQ*QLOW+QS)/(WGHTQ+1.) + ENDIF +! + ENDIF +! + IF(USTAR>=USTR.AND.USTAR0)THEN + THZ0=((WGHTT*THLOW+THS)/(WGHTT+1.)+THZ0)*0.5 + QZ0=((WGHTQ*QLOW+QS)/(WGHTQ+1.)+QZ0)*0.5 + ELSE + THZ0=(WGHTT*THLOW+THS)/(WGHTT+1.) + QZ0=(WGHTQ*QLOW+QS)/(WGHTQ+1.) + ENDIF +! + ENDIF +!---------------------------------------------------------------------- + ELSE +!---------------------------------------------------------------------- + ZU=Z0 + UZ0=0. + VZ0=0. +! + ZT=Z0 + THZ0=THS +! + ZQ=Z0 + QZ0=QS +!---------------------------------------------------------------------- + ENDIF +!---------------------------------------------------------------------- + TEM=(TLOW+TZ0)*0.5 + THM=(THELOW+THZ0)*0.5 +! + A=THM*P608 + B=(ELOCP/TEM-1.-P608)*THM +! + DTHV=((THELOW-THZ0)*((QLOW+QZ0+CWMLOW)*(0.5*P608)+1.) & + & +(QLOW-QZ0+CWMLOW)*A+CWMLOW*B) +! + DU2=MAX((ULOW-UZ0)**2+(VLOW-VZ0)**2,EPSU2) + RIB=BTGX*DTHV*ZSL/DU2 +!---------------------------------------------------------------------- +! IF(RIB>=RIC)THEN +!---------------------------------------------------------------------- +! AKMS=MAX( VISC*RDZ,CXCHS) +! AKHS=MAX(TVISC*RDZ,CXCHS) +!---------------------------------------------------------------------- +! ELSE ! turbulent branch +!---------------------------------------------------------------------- + ZSLU=ZSL+ZU + ZSLT=ZSL+ZT +! + RZSU=ZSLU/ZU + RZST=ZSLT/ZT +! + RLOGU=LOG(RZSU) + RLOGT=LOG(RZST) +! +!---------------------------------------------------------------------- +!*** 1./MONIN-OBUKHOV LENGTH +!---------------------------------------------------------------------- +! + RLMO=ELFC*AKHS*DTHV/USTAR**3 +! + ZETALU=ZSLU*RLMO + ZETALT=ZSLT*RLMO + ZETAU=ZU*RLMO + ZETAT=ZT*RLMO +! + ZETALU=MIN(MAX(ZETALU,ZTMIN1),ZTMAX1) + ZETALT=MIN(MAX(ZETALT,ZTMIN1),ZTMAX1) + ZETAU=MIN(MAX(ZETAU,ZTMIN1/RZSU),ZTMAX1/RZSU) + ZETAT=MIN(MAX(ZETAT,ZTMIN1/RZST),ZTMAX1/RZST) +! +!---------------------------------------------------------------------- +!*** WATER FUNCTIONS +!---------------------------------------------------------------------- +! + RZ=(ZETAU-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSMZ=(PSIM1(K+2)-PSIM1(K+1))*RDZT+PSIM1(K+1) +! + RZ=(ZETALU-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSMZL=(PSIM1(K+2)-PSIM1(K+1))*RDZT+PSIM1(K+1) +! + SIMM=PSMZL-PSMZ+RLOGU +! + RZ=(ZETAT-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSHZ=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + RZ=(ZETALT-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSHZL=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + SIMH=(PSHZL-PSHZ+RLOGT)*FH01 +!---------------------------------------------------------------------- + USTARK=USTAR*VKARMAN + if(abs(simm)<1.e-10.or.abs(simh)<1.e-10)then + write(0,*)' simm=',simm,' simh=',simh,' at i=',i,' j=',j + endif + AKMS=MAX(USTARK/SIMM,CXCHS) + AKHS=MAX(USTARK/SIMH,CXCHS) +! +!---------------------------------------------------------------------- +!*** BELJAARS CORRECTION FOR USTAR +!---------------------------------------------------------------------- +! + IF(DTHV<=0.)THEN !zj + WSTAR2=WWST2*ABS(BTGH*AKHS*DTHV)**(2./3.) !zj + ELSE !zj + WSTAR2=0. !zj + ENDIF !zj + USTAR=MAX(SQRT(AKMS*SQRT(DU2+WSTAR2)),EPSUST) +! +!---------------------------------------------------------------------- +! ENDIF ! End of turbulent branch +!---------------------------------------------------------------------- +! + ENDDO ! End of the iteration loop over sea points +! +!---------------------------------------------------------------------- +! +!*** LAND POINTS +! +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- + IF(NTSD==0)THEN + QS=QLOW + ENDIF +! + ZU=Z0 + UZ0=0. + VZ0=0. +! + ZT=ZU*ZTFC + THZ0=THS +! + ZQ=ZT + QZ0=QS +!---------------------------------------------------------------------- + TEM=(TLOW+TZ0)*0.5 + THM=(THELOW+THZ0)*0.5 +! + A=THM*P608 + B=(ELOCP/TEM-1.-P608)*THM +! + DTHV=((THELOW-THZ0)*((QLOW+QZ0+CWMLOW)*(0.5*P608)+1.) & + & +(QLOW-QZ0+CWMLOW)*A+CWMLOW*B) +! + DU2=MAX((ULOW-UZ0)**2+(VLOW-VZ0)**2,EPSU2) + RIB=BTGX*DTHV*ZSL/DU2 +!---------------------------------------------------------------------- +! IF(RIB>=RIC)THEN +! AKMS=MAX( VISC*RDZ,CXCHL) +! AKHS=MAX(TVISC*RDZ,CXCHL) +!---------------------------------------------------------------------- +! ELSE ! Turbulent branch +!---------------------------------------------------------------------- + ZSLU=ZSL+ZU +! + RZSU=ZSLU/ZU +! + RLOGU=LOG(RZSU) + + ZSLT=ZSL+ZU ! u,v and t are at the same level +!---------------------------------------------------------------------- +! +! +!mp Remove Topo modification of ZILFC term +! +! TOPOTERM=TOPOFAC*ZSFC**2. +! TOPOTERM=MAX(TOPOTERM,3.0) +! +!vcw +! RIB modification to ZILFC term +! 7/29/2009 V Wong recommends 5, change pending +! + CZETMAX = 10. +! stable + IF(DTHV>0.)THEN + IF (RIB0.)THEN +! FCT=-10.*(BTGX)**(-1./3.) +! CT=FCT*(HV/(PBLH*PBLH))**(2./3.) +! ELSE +! CT=0. +! ENDIF +! +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!*** THE FOLLOWING DIAGNOSTIC BLOCK PRODUCES 2-m and 10-m VALUES +!*** FOR TEMPERATURE, MOISTURE, AND WINDS. IT IS DONE HERE SINCE +!*** THE VARIOUS QUANTITIES NEEDED FOR THE COMPUTATION ARE LOST +!*** UPON EXIT FROM THE ROTUINE. +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +! + WSTAR=SQRT(WSTAR2)/WWST +! + UMFLX=AKMS*(ULOW -UZ0 ) + VMFLX=AKMS*(VLOW -VZ0 ) + HSFLX=AKHS*(THLOW-THZ0) + HLFLX=AKHS*(QLOW -QZ0 ) +!---------------------------------------------------------------------- +! IF(RIB>=RIC)THEN +!---------------------------------------------------------------------- +! IF(SEAMASK>0.5)THEN +! AKMS10=MAX( VISC/10.,CXCHS) +! AKHS02=MAX(TVISC/02.,CXCHS) +! AKHS10=MAX(TVISC/10.,CXCHS) +! ELSE +! AKMS10=MAX( VISC/10.,CXCHL) +! AKHS02=MAX(TVISC/02.,CXCHL) +! AKHS10=MAX(TVISC/10.,CXCHL) +! ENDIF +!---------------------------------------------------------------------- +! ELSE +!---------------------------------------------------------------------- + ZU10=ZU+10. + ZT02=ZT+02. + ZT10=ZT+10. +! + RLNU10=LOG(ZU10/ZU) + RLNT02=LOG(ZT02/ZT) + RLNT10=LOG(ZT10/ZT) +! + ZTAU10=ZU10*RLMO + ZTAT02=ZT02*RLMO + ZTAT10=ZT10*RLMO +! +!---------------------------------------------------------------------- +!*** SEA +!---------------------------------------------------------------------- +! + IF(SEAMASK>0.5)THEN +! +!---------------------------------------------------------------------- + ZTAU10=MIN(MAX(ZTAU10,ZTMIN1),ZTMAX1) + ZTAT02=MIN(MAX(ZTAT02,ZTMIN1),ZTMAX1) + ZTAT10=MIN(MAX(ZTAT10,ZTMIN1),ZTMAX1) +!---------------------------------------------------------------------- + RZ=(ZTAU10-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSM10=(PSIM1(K+2)-PSIM1(K+1))*RDZT+PSIM1(K+1) +! + SIMM10=PSM10-PSMZ+RLNU10 +! + RZ=(ZTAT02-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH02=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + SIMH02=(PSH02-PSHZ+RLNT02)*FH01 +! + RZ=(ZTAT10-ZTMIN1)/DZETA1 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH10=(PSIH1(K+2)-PSIH1(K+1))*RDZT+PSIH1(K+1) +! + SIMH10=(PSH10-PSHZ+RLNT10)*FH01 +! + AKMS10=MAX(USTARK/SIMM10,CXCHS) + AKHS02=MAX(USTARK/SIMH02,CXCHS) + AKHS10=MAX(USTARK/SIMH10,CXCHS) +! +!---------------------------------------------------------------------- +!*** LAND +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- + ZTAU10=MIN(MAX(ZTAU10,ZTMIN2),ZTMAX2) + ZTAT02=MIN(MAX(ZTAT02,ZTMIN2),ZTMAX2) + ZTAT10=MIN(MAX(ZTAT10,ZTMIN2),ZTMAX2) +!---------------------------------------------------------------------- + RZ=(ZTAU10-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSM10=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1) +! + SIMM10=PSM10-PSMZ+RLNU10 +! + RZ=(ZTAT02-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH02=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) +! + SIMH02=(PSH02-PSHZ+RLNT02)*FH02 +! + RZ=(ZTAT10-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSH10=(PSIH2(K+2)-PSIH2(K+1))*RDZT+PSIH2(K+1) +! + SIMH10=(PSH10-PSHZ+RLNT10)*FH02 +! + AKMS10=USTARK/SIMM10 + AKHS02=USTARK/SIMH02 + AKHS10=USTARK/SIMH10 +! + IF(AKMS10<=CXCHL) AKMS10=AKMS + IF(AKHS02<=CXCHL) AKHS02=AKHS + IF(AKHS10<=CXCHL) AKHS10=AKHS +! +!---------------------------------------------------------------------- + ENDIF +!---------------------------------------------------------------------- +! ENDIF +!---------------------------------------------------------------------- +! + U10 =UMFLX/AKMS10+UZ0 + V10 =VMFLX/AKMS10+VZ0 + TH02=HSFLX/AKHS02+THZ0 + TH10=HSFLX/AKHS10+THZ0 + Q02 =HLFLX/AKHS02+QZ0 + Q10 =HLFLX/AKHS10+QZ0 + TERM1=-0.068283/TLOW + PSHLTR=PSFC*EXP(TERM1) +! +!---------------------------------------------------------------------- +!*** COMPUTE "EQUIVALENT" Z0 TO APPROXIMATE LOCAL SHELTER READINGS. +!---------------------------------------------------------------------- +! + U10E=U10 + V10E=V10 +! + IF(SEAMASK<0.5)THEN + +!1st ZUUZ=MIN(0.5*ZU,0.1) +!1st ZU=MAX(0.1*ZU,ZUUZ) +!tst ZUUZ=amin1(ZU*0.50,0.3) +!tst ZU=amax1(ZU*0.3,ZUUZ) + + ZUUZ=AMIN1(ZU*0.50,0.18) + ZU=AMAX1(ZU*0.35,ZUUZ) +! + ZU10=ZU+10. + RZSU=ZU10/ZU + RLNU10=LOG(RZSU) + + ZETAU=ZU*RLMO + ZTAU10=ZU10*RLMO + + ZTAU10=MIN(MAX(ZTAU10,ZTMIN2),ZTMAX2) + ZETAU=MIN(MAX(ZETAU,ZTMIN2/RZSU),ZTMAX2/RZSU) + + RZ=(ZTAU10-ZTMIN2)/DZETA2 + K=INT(RZ) + RDZT=RZ-REAL(K) + K=MIN(K,KZTM2) + K=MAX(K,0) + PSM10=(PSIM2(K+2)-PSIM2(K+1))*RDZT+PSIM2(K+1) + SIMM10=PSM10-PSMZ+RLNU10 + EKMS10=MAX(USTARK/SIMM10,CXCHL) + + U10E=UMFLX/EKMS10+UZ0 + V10E=VMFLX/EKMS10+VZ0 + + ENDIF +! + U10=U10E + V10=V10E +! +!---------------------------------------------------------------------- +!*** SET OTHER WRF DRIVER ARRAYS +!---------------------------------------------------------------------- +! + RLOW=PLOW/(R_D*TLOW) + CHS=AKHS + CQS=AKHS ! lmh 25oct17 +!!$ CHS2=AKHS02 +!!$ CQS2=AKHS02 + HFX=-RLOW*CP*HSFLX + QFX=-RLOW*HLFLX*WETM + FLX_LH=XLV*QFX +!!$ FLHC=RLOW*CP*AKHS +!!$ FLQC=RLOW*AKHS*WETM +!!! QGH=PQ0/PSHLTR*EXP(A2S*(TSK-A3S)/(TSK-A4S)) +!!$ QGH=((1.-SEAMASK)*PQ0+SEAMASK*PQ0SEA) & +!!$ & /PLOW*EXP(A2S*(TLOW-A3S)/(TLOW-A4S)) +!!$ CPM=CP*(1.+0.8*QLOW) +! +!*** DO NOT COMPUTE QS OVER LAND POINTS HERE SINCE IT IS +!*** A PROGNOSTIC VARIABLE THERE. IT IS OKAY TO USE IT +!*** AS A DIAGNOSTIC OVER WATER SINCE IT WILL CAUSE NO +!*** INTERFERENCE BEFORE BEING RECOMPUTED IN MYJPBL. +! + IF(SEAMASK>0.5)THEN + QS=QLOW+QFX/(RLOW*AKHS) + QS=QS/(1.-QS) + ENDIF +!---------------------------------------------------------------------- +! + !!! DEBUG CODE +! if (lprnt) write(1024,'(A, I, 6(f12.6, 2x))') 'SFCDIF:', i, RIB, DTHV, BTGX, ZSL, DU2 +! if (lprnt) write(1024,'(A, 5(f12.6, 2x))') ' ', UZ0, VZ0, THZ0, QZ0, TZ0 +! if (lprnt) write(1024,'(A, 5(f12.6, 2x))') ' ', AKHS, AKMS, USTAR, Z0, QS, SEAMASK + !!! END DEBUG CODE + END SUBROUTINE SFCDIF +! +!---------------------------------------------------------------------- +!This currently doesn't actually do anything except set up ustar +! and compute some utility arrays +! + SUBROUTINE MYJ_JSFC_INIT(USTAR,RESTART & + & ,IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + LOGICAL,INTENT(IN) :: RESTART +! + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,LM +! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: USTAR +! +!---------------------------------------------------------------------- +!*** LOCAL VARIABLES +!---------------------------------------------------------------------- +! + REAL,DIMENSION(0:30) :: VZ0TBL + REAL,DIMENSION(0:30) :: VZ0TBL_24 +! + INTEGER :: I,IDUM,IRECV,J,JDUM,K,ITF,JTF,KTF,MAXGBL_IVGTYP & + &, MAXLOC_IVGTYP +! +! INTEGER :: MPI_INTEGER,MPI_MAX +! + REAL :: SM_LOC,X,ZETA1,ZETA2,ZRNG1,ZRNG2 +! + REAL :: PIHF=3.1415926/2.,EPS=1.E-6 +!---------------------------------------------------------------------- + VZ0TBL= & + & (/0., & + & 2.653,0.826,0.563,1.089,0.854,0.856,0.035,0.238,0.065,0.076 & + & ,0.011,0.035,0.011,0.000,0.000,0.000,0.000,0.000,0.000,0.000 & + & ,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000,0.000/) + + VZ0TBL_24= (/0., & + & 1.00, 0.07, 0.07, 0.07, 0.07, 0.15, & + & 0.08, 0.03, 0.05, 0.86, 0.80, 0.85, & + & 2.65, 1.09, 0.80, 0.001, 0.04, 0.05, & + & 0.01, 0.04, 0.06, 0.05, 0.03, 0.001, & + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000 /) + +!---------------------------------------------------------------------- +! + JTF=MIN0(JTE,JDE-1) + KTF=MIN0(LM,KDE-1) + ITF=MIN0(ITE,IDE-1) +! +! +!*** FOR NOW, ASSUME SIGMA MODE FOR LOWEST MODEL LAYER +! +!!$ DO J=JTS,JTF +!!$ DO I=ITS,ITF +!!$! USTAR(I,J)=EPSUST +!!$ ENDDO +!!$ ENDDO +!---------------------------------------------------------------------- +! +!!$ IF(.NOT.RESTART)THEN +!!$ MAXLOC_IVGTYP=MAXVAL(IVGTYP) +!!$ CALL MPI_ALLREDUCE(MAXLOC_IVGTYP,MAXGBL_IVGTYP,1,MPI_INTEGER & +!!$ &, MPI_MAX,MPI_COMM_COMP,IRECV) +!!$ MAXGBL_IVGTYP=MAXVAL(IVGTYP) +!!$! +!!$ IF (MAXGBL_IVGTYP<13) THEN !New physics +!!$ DO J=JTS,JTE +!!$ DO I=ITS,ITE +!!$ SM_LOC=SEAMASK(I,J)-1. +!!$ IF(SM_LOC+XICE(I,J)<0.5)THEN +!!$!zj Z0(I,J)=VZ0TBL(IVGTYP(I,J)) +!!$ ENDIF +!!$ ENDDO +!!$ ENDDO +!!$! +!!$ ELSE +!!$! +!!$ DO J=JTS,JTE +!!$ DO I=ITS,ITE +!!$ SM_LOC=SEAMASK(I,J)-1. +!!$ IF(SM_LOC+XICE(I,J)<0.5)THEN +!!$!zj Z0(I,J)=VZ0TBL_24(IVGTYP(I,J)) +!!$ ENDIF +!!$ ENDDO +!!$ ENDDO +!!$! +!!$ ENDIF ! Vegtype check +!!$! +!!$ ENDIF ! Restart check +! +!---------------------------------------------------------------------- + IF(.NOT.RESTART)THEN + DO J=JTS,JTE + DO I=ITS,ITF + USTAR(I,J)=0.1 + ENDDO + ENDDO + ENDIF + +!---------------------------------------------------------------------- +! +!*** COMPUTE SURFACE LAYER INTEGRAL FUNCTIONS +! +!---------------------------------------------------------------------- + FH01=1. + FH02=1. +! +! ZTMIN1=-10.0 +! ZTMAX1=2.0 +! ZTMIN2=-10.0 +! ZTMAX2=2.0 +!org b +! ZTMIN1=-5.0 +! ZTMAX1=1.0 +! ZTMIN2=-5.0 +! ZTMAX2=1.0 +!org e + ZTMIN1=-5.0 + ZTMAX1=9.0 + ZTMIN2=-5.0 + ZTMAX2=9.0 + + ZRNG1=ZTMAX1-ZTMIN1 + ZRNG2=ZTMAX2-ZTMIN2 +! + DZETA1=ZRNG1/(KZTM-1) + DZETA2=ZRNG2/(KZTM-1) +! +!---------------------------------------------------------------------- +!*** FUNCTION DEFINITION LOOP +!---------------------------------------------------------------------- +! + ZETA1=ZTMIN1 + ZETA2=ZTMIN2 +! + DO K=1,KZTM +! +!---------------------------------------------------------------------- +!*** UNSTABLE RANGE +!---------------------------------------------------------------------- +! + IF(ZETA1<0.)THEN +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- + X=SQRT(SQRT(1.-16.*ZETA1)) +! + PSIM1(K)=-2.*LOG((X+1.)/2.)-LOG((X*X+1.)/2.)+2.*ATAN(X)-PIHF + PSIH1(K)=-2.*LOG((X*X+1.)/2.) +! +!---------------------------------------------------------------------- +!*** STABLE RANGE +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- +! +! PSIM1(K)=5.*ZETA1 +! PSIH1(K)=5.*ZETA1 +!---------------------------------------------------------------------- +!*** HOLTSLAG AND DE BRUIN 1988 +!---------------------------------------------------------------------- +! + PSIM1(K)=0.7*ZETA1+0.75*ZETA1*(6.-0.35*ZETA1)*EXP(-0.35*ZETA1) + PSIH1(K)=0.7*ZETA1+0.75*ZETA1*(6.-0.35*ZETA1)*EXP(-0.35*ZETA1) +!---------------------------------------------------------------------- +! + ENDIF +! +!---------------------------------------------------------------------- +!*** UNSTABLE RANGE +!---------------------------------------------------------------------- +! + IF(ZETA2<0.)THEN +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- +! + X=SQRT(SQRT(1.-16.*ZETA2)) +! + PSIM2(K)=-2.*LOG((X+1.)/2.)-LOG((X*X+1.)/2.)+2.*ATAN(X)-PIHF + PSIH2(K)=-2.*LOG((X*X+1.)/2.) +!---------------------------------------------------------------------- +!*** STABLE RANGE +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** PAULSON 1970 FUNCTIONS +!---------------------------------------------------------------------- +! +! PSIM2(K)=5.*ZETA2 +! PSIH2(K)=5.*ZETA2 +! +!---------------------------------------------------------------------- +!*** HOLTSLAG AND DE BRUIN 1988 +!---------------------------------------------------------------------- +! + PSIM2(K)=0.7*ZETA2+0.75*ZETA2*(6.-0.35*ZETA2)*EXP(-0.35*ZETA2) + PSIH2(K)=0.7*ZETA2+0.75*ZETA2*(6.-0.35*ZETA2)*EXP(-0.35*ZETA2) +!---------------------------------------------------------------------- +! + ENDIF +! +!---------------------------------------------------------------------- + IF(K==KZTM)THEN + ZTMAX1=ZETA1 + ZTMAX2=ZETA2 + ENDIF +! + ZETA1=ZETA1+DZETA1 + ZETA2=ZETA2+DZETA2 +!---------------------------------------------------------------------- + ENDDO +!---------------------------------------------------------------------- + ZTMAX1=ZTMAX1-EPS + ZTMAX2=ZTMAX2-EPS +!---------------------------------------------------------------------- +! + END SUBROUTINE MYJ_JSFC_INIT + ! +!---------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!----------------------------------------------------------------------- +! + END MODULE MYJ_JSFC_MOD +! +!----------------------------------------------------------------------- diff --git a/gsmphys/myj_pbl.F90 b/gsmphys/myj_pbl.F90 new file mode 100644 index 00000000..9e2542ac --- /dev/null +++ b/gsmphys/myj_pbl.F90 @@ -0,0 +1,2126 @@ +!----------------------------------------------------------------------- +! + MODULE MYJ_PBL_MOD +! +!----------------------------------------------------------------------- +! +!*** THE MYJ PBL SCHEME +! +!----------------------------------------------------------------------- +! +! Switched to using FMS/GFS constants where possible, hard-coded others --- lmh 25oct17 +!!$ USE MODULE_CONSTANTS,ONLY : A2,A3,A4,CP,ELIV,ELWV,ELIWV & +!!$ ,EP_1,EPSQ & +!!$ ,G,P608,PI,PQ0,R_D,R_V,RHOWATER & +!!$ ,STBOLT,CAPPA + + use machine, only: kind_phys + use physcons, only: CP => con_cp, & + G=>con_g, R_D=>con_rd, & + R_V=>con_rv, elwv=>con_hvap, eliv=>con_hfus, & + PI=>con_pi + +!----------------------------------------------------------------------- +! + IMPLICIT NONE +! +!----------------------------------------------------------------------- +! + PRIVATE +! + PUBLIC:: MYJ_PBL_INIT, MYJ_PBL +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!*** FOR MYJ TURBULENCE +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + + integer, PARAMETER:: kfpt=kind_phys + integer, PARAMETER:: kint=4 + integer, PARAMETER:: klog=4 + + real(kind=kfpt), PARAMETER:: & + a2=17.2693882 & ! saturation spec. humidity formula coeff. + ,a3=273.15 & ! saturation spec. humidity formula coeff. + ,a4=35.86 & ! saturation spec. humidity formula coeff. + ,eliwv=2.683e6 & ! latent heat, mix ice/water - vapor + ,ep_1=R_V/R_D - 1. & + ,epsq=1.e-12 & ! floor value for specific humidity (kg/kg) +! ,p608=R_V/R_D - 1. & ! factor for water vapor in virtual temperature (same as ep_1) + ,pq0=379.90516 & ! water vapor pressure for tetens formula + ,rhowater=1000. & ! density of water (kg/m3) + ,cappa=R_D/CP + +! + REAL(KIND=KFPT),PARAMETER:: & + ELEVFC=0.6 +! + REAL(KIND=KFPT),PARAMETER:: & + VKARMAN=0.4 & +! + ,XLS=ELIV,XLV=ELWV & + ,RLIVWV=XLS/XLV,ELOCP=2.72E6/CP & +! + ,EPS1=1.E-12,EPS2=0. & + ,EPSRU=1.E-7,EPSRS=1.E-7 & + ,EPSTRB=1.E-24 & + ,FH=1.10 & +! + ,ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & +! ,ELFC=0.5,GAM1=0.2222222222222222222 & +! ,ELFC=0.23*0.25,GAM1=0.2222222222222222222 & + ,ELFC=1.,GAM1=0.2222222222222222222 & +! + ,A1=0.659888514560862645 & + ,A2X=0.6574209922667784586 & + ,B1=11.87799326209552761 & + ,B2=7.226971804046074028 & + ,C1=0.000830955950095854396 & + ,ELZ0=0.,ESQ=5.0 & +! + ,SEAFC=0.98,PQ0SEA=PQ0*SEAFC & +! + ,BTG=BETA*G & + ,ESQHF=0.5*5.0 & + ,RB1=1./B1 +! + REAL(KIND=KFPT),PARAMETER:: & + ADNH= 9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + ,ADNM=18.*A1*A1*A2X*(B2-3.*A2X)*BTG & + ,ANMH=-9.*A1*A2X*A2X*BTG*BTG & + ,ANMM=-3.*A1*A2X*(3.*A2X+3.*B2*C1+18.*A1*C1-B2)*BTG & + ,BDNH= 3.*A2X*(7.*A1+B2)*BTG & + ,BDNM= 6.*A1*A1 & + ,BEQH= A2X*B1*BTG+3.*A2X*(7.*A1+B2)*BTG & + ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & + ,BNMH=-A2X*BTG & + ,BNMM=A1*(1.-3.*C1) & + ,BSHH=9.*A1*A2X*A2X*BTG & + ,BSHM=18.*A1*A1*A2X*C1 & + ,BSMH=-3.*A1*A2X*(3.*A2X+3.*B2*C1+12.*A1*C1-B2)*BTG & + ,CESH=A2X & + ,CESM=A1*(1.-3.*C1) & + ,CNV=EP_1*G/BTG +! +!----------------------------------------------------------------------- +!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + AEQH=9.*A1*A2X*A2X*B1*BTG*BTG & + +9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + ,AEQM=3.*A1*A2X*B1*(3.*A2X+3.*B2*C1+18.*A1*C1-B2) & + *BTG+18.*A1*A1*A2X*(B2-3.*A2X)*BTG +! +!----------------------------------------------------------------------- +!*** FORBIDDEN TURBULENCE AREA +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + REQU=-AEQH/AEQM & + ,EPSGH=1.E-9,EPSGM=REQU*EPSGH +! +!----------------------------------------------------------------------- +!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT +!----------------------------------------------------------------------- +! + REAL(KIND=KFPT),PARAMETER:: & + UBRYL=(18.*REQU*A1*A1*A2X*B2*C1*BTG & + +9.*A1*A2X*A2X*B2*BTG*BTG) & + /(REQU*ADNM+ADNH) & + ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY +! + REAL(KIND=KFPT),PARAMETER:: & + AUBH=27.*A1*A2X*A2X*B2*BTG*BTG-ADNH*UBRY3 & + ,AUBM=54.*A1*A1*A2X*B2*C1*BTG -ADNM*UBRY3 & + ,BUBH=(9.*A1*A2X+3.*A2X*B2)*BTG-BDNH*UBRY3 & + ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & + ,CUBR=1. - UBRY3 & + ,RCUBR=1./CUBR +! +!----------------------------------------------------------------------- +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!---LOOK-UP TABLES------------------------------------------------------ +INTEGER(KIND=KINT),PARAMETER:: & + ITBL=401 & ! CONVECTION TABLES, DIMENSION 1 +,JTBL=1201 & ! CONVECTION TABLES, DIMENSION 2 +,KERFM=301 & ! SIZE OF ERF HALF TABLE +,KERFM2=KERFM-2 ! INTERNAL POINTS OF ERF HALF TABLE + +REAL(KIND=KFPT),PARAMETER:: & + PL=2500. & ! LOWER BOUND OF PRESSURE RANGE +,PH=105000. & ! UPPER BOUND OF PRESSURE RANGE +,THL=210. & ! LOWER BOUND OF POTENTIAL TEMPERATURE RANGE +,THH=365. & ! UPPER BOUND OF POTENTIAL TEMPERATURE RANGE +,XEMIN=0. & ! LOWER BOUND OF ERF HALF TABLE +,XEMAX=3. ! UPPER BOUND OF ERF HALF TABLE + +REAL(KIND=KFPT),PRIVATE,SAVE:: & + RDP & ! SCALING FACTOR FOR PRESSURE +,RDQ & ! SCALING FACTOR FOR HUMIDITY +,RDTH & ! SCALING FACTOR FOR POTENTIAL TEMPERATURE +,RDTHE & ! SCALING FACTOR FOR EQUIVALENT POT. TEMPERATURE +,RDXE ! ERF HALF TABLE SCALING FACTOR + +REAL(KIND=KFPT),DIMENSION(1:ITBL),PRIVATE,SAVE:: & + STHE & ! RANGE FOR EQUIVALENT POTENTIAL TEMPERATURE +,THE0 ! BASE FOR EQUIVALENT POTENTIAL TEMPERATURE + +REAL(KIND=KFPT),DIMENSION(1:JTBL),PRIVATE,SAVE:: & + QS0 & ! BASE FOR SATURATION SPECIFIC HUMIDITY +,SQS ! RANGE FOR SATURATION SPECIFIC HUMIDITY + +REAL(KIND=KFPT),DIMENSION(1:KERFM),PRIVATE,SAVE:: & + HERFF ! HALF ERF TABLE + +REAL(KIND=KFPT),DIMENSION(1:ITBL,1:JTBL),PRIVATE,SAVE:: & + PTBL ! SATURATION PRESSURE TABLE + +REAL(KIND=KFPT),DIMENSION(1:JTBL,1:ITBL),PRIVATE,SAVE:: & + TTBL ! TEMPERATURE TABLE +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!----------------------------------------------------------------------- +! + CONTAINS +! +!----------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +!----------------------------------------------------------------------- +! +! REFERENCES: JANJIC (2001), NCEP OFFICE NOTE 437 +! +! ABSTRACT: +! MYJ UPDATES THE TURBULENT KINETIC ENERGY WITH THE PRODUCTION/ +! DISSIPATION TERM AND THE VERTICAL DIFFUSION TERM +! (USING AN IMPLICIT FORMULATION) FROM MELLOR-YAMADA +! LEVEL 2.5 AS EXTENDED BY JANJIC. EXCHANGE COEFFICIENTS FOR +! THE SURFACE LAYER ARE COMPUTED FROM THE MONIN-OBUKHOV THEORY. +! THE TURBULENT VERTICAL EXCHANGE IS THEN EXECUTED. +! +! NOTE: for GFS we may need to remove the viscous sublayer (*Z0) +!----------------------------------------------------------------------- + SUBROUTINE MYJ_PBL(DT,NPHS,EPSL,EPSQ2,HT,DZ & + ,PMID,PINH,TH,T,EXNER,Q,CWM,U,V & + ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0 & + ,XLAND,SICE,SNOW & + ,Q2,EXCH_H,USTAR,Z0,EL_MYJ,PBLH,KPBL & + ,AKHS,AKMS,ELFLX,MIXHT,HFLX & + ,RUBLTEN,RVBLTEN,RTHBLTEN,RQBLTEN,RQCBLTEN & + ,SPD1,DSPHEAT & + ,IDS,IDE,JDS,JDE & + ,IMS,IME,JMS,JME & + ,ITS,ITE,JTS,JTE,LM,LPRNT) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + IDS,IDE,JDS,JDE & + ,IMS,IME,JMS,JME & + ,ITS,ITE,JTS,JTE,LM +! + INTEGER(KIND=KINT),INTENT(IN):: & + NPHS +! + INTEGER(KIND=8),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT):: & + KPBL +! + REAL(KIND=KFPT),INTENT(IN):: & + DT +! + real(kind=kfpt),dimension(1:lm-1),intent(inout):: EPSL + real(kind=kfpt),dimension(1:lm),intent(inout):: EPSQ2 + logical, intent(in) :: LPRNT, DSPHEAT +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(IN):: & + HT,SICE,SNOW & + ,TSK,XLAND & + ,CHKLOWQ,ELFLX,HFLX,SPD1 +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(IN):: & + DZ,EXNER,PMID,Q,CWM,U,V,T,TH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1),INTENT(IN):: & + PINH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(OUT):: & + MIXHT & + ,PBLH +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT):: & + EL_MYJ +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(OUT):: & + RQCBLTEN & + ,RUBLTEN,RVBLTEN & + ,RTHBLTEN,RQBLTEN +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: & + AKHS,AKMS +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT):: & + QSFC,QZ0 & + ,THZ0,USTAR & + ,UZ0,VZ0,Z0 +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM),INTENT(INOUT):: & + EXCH_H & + ,Q2 +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + I,IQTB,ITTB,J,K,LLOW,LMH,LMXL +! + INTEGER(KIND=KINT),DIMENSION(IMS:IME,JMS:JME):: & + LPBL +! + REAL(KIND=KFPT):: & + AKHS_DENS,AKMS_DENS,BQ,BQS00K,BQS10K & + ,DCDT,DELTAZ,DQDT,DTDIF,DTDT,DTTURBL & + ,P00K,P01K,P10K,P11K,PELEVFC,PP1,PSFC,PSP,PTOP & + ,QBT,QFC1,QLOW,QQ1,QX & + ,RDTTURBL,RG,RSQDT,RXNERS,RXNSFC & + ,SEAMASK,SQ,SQS00K,SQS10K & + ,THBT,THNEW,THOLD,TQ,TTH & + ,TI,TEM,TEM1,TEM2,SFLUX,TTEND & + ,ULOW,VLOW,RSTDH,STDFAC,ZSF,ZSX,ZSY,ZUV,WIND +! + REAL(KIND=KFPT),DIMENSION(1:LM):: & + CWMK,PK,PSK,Q2K,QK,RHOK,RXNERK,THEK,THK,THVK,TK,UK,VK +! + REAL(KIND=KFPT),DIMENSION(1:LM-1):: & + AKHK,AKMK,DCOL,EL,GH,GM,DISS +! + REAL(KIND=KFPT),DIMENSION(1:LM+1):: & + ZHK +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME):: & + THSK +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM):: & + RXNER,THV,EXCH_M +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM-1):: & + AKH,AKM +! + REAL(KIND=KFPT),DIMENSION(IMS:IME,JMS:JME,1:LM+1):: & + ZINT +! +!*** Begin debugging + REAL(KIND=KFPT):: ZSL_DIAG + INTEGER(KIND=KINT):: IMD,JMD,PRINT_DIAG +!*** End debugging +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! +!*** Begin debugging + IMD=(IMS+IME)/2 + JMD=(JMS+JME)/2 +!*** End debugging +! +!*** MAKE PREPARATIONS +! +!---------------------------------------------------------------------- + STDFAC=1. +!---------------------------------------------------------------------- + DTTURBL=DT*NPHS + RDTTURBL=1./DTTURBL + RSQDT=SQRT(RDTTURBL) + DTDIF=DTTURBL + RG=1./G +! + DO K=1,LM-1 + DO J=JTS,JTE + DO I=ITS,ITE + AKM(I,J,K)=0. + ENDDO + ENDDO + ENDDO +! + DO K=1,LM+1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=0. + ENDDO + ENDDO + ENDDO + DO K=1,LM + !At one time EPSL/EPSQ2 had a tapering function. Now they are just constant 0.02 and 0.1 + !! ARG=(PSINT(K)-PSINT(2))/(PSINT(LM)-PSINT(2))*PI + ! int_state%EPSQ2(K-1)=(1.+COS(ARG))*0.09+0.02 + EPSQ2(K)=0.02 + ENDDO + DO K=1,LM-1 + EPSL(K) = 0.1 + ENDDO +!!$ if (LPRNT) print*, EPSQ2(:) +!!$ if (LPRNT) print*, EPSL(:) + ! + DO J=JTS,JTE + DO I=ITS,ITE + PBLH(I,J)=-1. + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,LM+1)=HT(I,J) ! Z AT BOTTOM OF LOWEST SIGMA LAYER + ENDDO + ENDDO +! + DO K=LM,1,-1 + DO J=JTS,JTE + DO I=ITS,ITE + ZINT(I,J,K)=ZINT(I,J,K+1)+DZ(I,J,K) + RXNER(I,J,K)=1./EXNER(I,J,K) + THV(I,J,K)=(Q(I,J,K)*0.608+(1.-CWM(I,J,K)))*TH(I,J,K) + ENDDO + ENDDO + ENDDO +! + DO J=JTS,JTE + DO I=ITS,ITE + EL_MYJ(I,J,LM)=0. + ENDDO + ENDDO + +!---------------------------------------------------------------------- +!....................................................................... +!ZJ$NO-MP PARALLEL DO & +!ZJ$NO-MP PRIVATE(J,I,LMH,PTOP,PSFC,SEAMASK,K,TK,THVK,QK,Q2K,RXNERK, & +!ZJ$NO-MP PK,UK,VK,Q2K,ZHK,LMXL,GM,GH,EL,AKMK,AKHK,DELTAZ), & +!ZJ$NO-MP SCHEDULE(DYNAMIC) +!....................................................................... +!---------------------------------------------------------------------- + setup_integration: DO J=JTS,JTE +!---------------------------------------------------------------------- +! + DO I=ITS,ITE +! + LMH=LM +! + PTOP=PINH(I,J,1) + PSFC=PINH(I,J,LMH+1) +! +!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) +! + SEAMASK=XLAND(I,J)-1. +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=LM,1,-1 + PK(K)=PMID(I,J,K) + TK(K)=T(I,J,K) + QK(K)=Q(I,J,K) + THVK(K)=THV(I,J,K) + RXNERK(K)=RXNER(I,J,K) + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + Q2K(K)=Q2(I,J,K) +! +!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES +! + ZHK(K)=ZINT(I,J,K) +! + ENDDO + ZHK(LM+1)=HT(I,J) ! Z AT BOTTOM OF LOWEST SIGMA LAYER +! +!*** POTENTIAL INSTABILITY +! + PELEVFC=PMID(I,J,LMH)*ELEVFC +! + DO K=LMH,1,-1 +!----------------------------------------------------------------------- + IF(K==LMH .OR. PMID(I,J,K)>PELEVFC) THEN +!---PREPARATION FOR SEARCH FOR MAX CAPE--------------------------------- + QBT=QK(K) + THBT=TH(I,J,K) + TTH=(THBT-THL)*RDTH + QQ1=TTH-AINT(TTH) + ITTB=INT(TTH)+1 +!---KEEPING INDICES WITHIN THE TABLE------------------------------------ + IF(ITTB.LT.1)THEN + ITTB=1 + QQ1=0. + ELSE IF(ITTB.GE.JTBL)THEN + ITTB=JTBL-1 + QQ1=0. + ENDIF +!---BASE AND SCALING FACTOR FOR SPEC. HUMIDITY-------------------------- + BQS00K=QS0(ITTB) + SQS00K=SQS(ITTB) + BQS10K=QS0(ITTB+1) + SQS10K=SQS(ITTB+1) +!--------------SCALING SPEC. HUMIDITY & TABLE INDEX--------------------- + BQ=(BQS10K-BQS00K)*QQ1+BQS00K + SQ=(SQS10K-SQS00K)*QQ1+SQS00K + TQ=(QBT-BQ)/SQ*RDQ + PP1=TQ-AINT(TQ) + IQTB=INT(TQ)+1 +!----------------KEEPING INDICES WITHIN THE TABLE----------------------- + IF(IQTB.LT.1)THEN + IQTB=1 + PP1=0. + ELSEIF(IQTB.GE.ITBL)THEN + IQTB=ITBL-1 + PP1=0. + ENDIF +!--------------SATURATION PRESSURE AT FOUR SURROUNDING TABLE PTS.------- + P00K=PTBL(IQTB ,ITTB ) + P10K=PTBL(IQTB+1,ITTB ) + P01K=PTBL(IQTB ,ITTB+1) + P11K=PTBL(IQTB+1,ITTB+1) +!--------------SATURATION POINT VARIABLES AT THE BOTTOM----------------- + PSP=P00K+(P10K-P00K)*PP1+(P01K-P00K)*QQ1 & + +(P00K-P10K-P01K+P11K)*PP1*QQ1 + RXNERS=(1.E5/PSP)**CAPPA + THEK(K)=THBT*EXP(ELOCP*QBT*RXNERS/THBT) + PSK (K)=PSP +!----------------------------------------------------------------------- + ELSE +!----------------------------------------------------------------------- + THEK(K)=THEK(K+1) + PSK (K)=PINH(I,J,1) +!----------------------------------------------------------------------- + ENDIF +!----------------------------------------------------------------------- + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=1 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=2 +!*** End debugging +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE MIXING LENGTH +!*** + CALL MIXLEN(LMH,RSQDT,UK,VK,THVK,THEK & + ,Q2K,EPSL,EPSQ2,ZHK,PK,PSK,RXNERK,GM,GH,EL & + ,PBLH(I,J),LPBL(I,J),LMXL,MIXHT(I,J) & + ,I,J,LM) +! +!---------------------------------------------------------------------- +!*** +!*** SOLVE FOR THE PRODUCTION/DISSIPATION OF +!*** THE TURBULENT KINETIC ENERGY +!*** +! + CALL PRODQ2(LMH,DTTURBL,USTAR(I,J),GM,GH,EL,Q2K & + ,EPSL,EPSQ2,I,J,LM) +! +!---------------------------------------------------------------------- +!*** THE MODEL LAYER (COUNTING UPWARD) CONTAINING THE TOP OF THE PBL +!---------------------------------------------------------------------- +! + KPBL(I,J)=LPBL(I,J) +! +!---------------------------------------------------------------------- +!*** +!*** FIND THE EXCHANGE COEFFICIENTS IN THE FREE ATMOSPHERE +!*** + CALL DIFCOF(LMH,LMXL,GM,GH,EL,TK,Q2K,ZHK,AKMK,AKHK,I,J,LM & + ,PRINT_DIAG) +! + +!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH +!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS 1 TO LM-1. COUNTING +!*** COUNTING UPWARD FROM THE BOTTOM, THOSE SAME COEFFICIENTS EXCH_H +!*** ARE DEFINED ON THE TOPS OF THE LAYERS 1 TO LM-1. +! + DO K=1,LM-1 + AKH(I,J,K)=AKHK(K) + AKM(I,J,K)=AKMK(K) + DELTAZ=0.5*(ZHK(K)-ZHK(K+2)) + EXCH_H(I,J,K)=AKHK(K)*DELTAZ + EXCH_M(I,J,K)=AKMK(K)*DELTAZ + ENDDO +! +!---------------------------------------------------------------------- +!*** +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TURBULENT KINETIC ENERGY +!*** +! + CALL VDIFQ(LMH,DTDIF,Q2K,EL,ZHK,I,J,LM) +! +!*** SAVE THE NEW Q2 AND MIXING LENGTH. +! + DO K=1,LM + Q2(I,J,K)=MAX(Q2K(K),EPSQ2(K)) + IF(K EP_1 + ENDDO +! +!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH +!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS 1 TO LM-1. THESE COEFFICIENTS +!*** ARE ALSO MULTIPLIED BY THE DENSITY AT THE BOTTOM INTERFACE LEVEL. + +!*** REMOVED references to viscous sublayer to be more compatible with GFS +! ** surface driver, and instead lower BC are surface values for TH and Q, and +! ** directional USTAR for U and V. Also removed distinction between land and sea, +! ** which the GFS surface layer handles. Currently Qsfc has the effect of surface +! ** moisture flux incorporated but TH, U, and V do not incorporate their +! ** respective fluxes --- lmh 16 nov 17, gfdl + DO K=1,LM-1 + AKHK(K)=AKH(I,J,K)*0.5*(RHOK(K)+RHOK(K+1)) + ENDDO +! + ZHK(LM+1)=ZINT(I,J,LM+1) +! + SEAMASK=XLAND(I,J)-1. + !THZ0(I,J)=(1.-SEAMASK)*THSK(I,J)+SEAMASK*THZ0(I,J) + !THZ0(I,J) = THSK(I,J) ! want to include surface fluxes too? +! + !LLOW=LM + AKHS_DENS=AKHS(I,J)*RHOK(LM) +! + THZ0(I,J) = THSK(I,J)+HFLX(I,J)*((1.E5/PSFC)**CAPPA)/AKHS_DENS/CP +! + QFC1=CHKLOWQ(I,J)*AKHS_DENS ! no longer using xlv conversion factor + QLOW=QK(LM) + QSFC(I,J)=QLOW+ELFLX(I,J)/QFC1 +!!$ IF(SEAMASK<0.5)THEN +!!$ QFC1=XLV*CHKLOWQ(I,J)*AKHS_DENS +!!$! +!!$ IF(SNOW(I,J)>0..OR.SICE(I,J)>0.5)THEN +!!$ QFC1=QFC1*RLIVWV +!!$ ENDIF +!!$! +!!$ IF(QFC1>0.)THEN +!!$ QLOW=QK(LM) +!!$ QSFC(I,J)=QLOW+ELFLX(I,J)/QFC1 +!!$ ENDIF +!!$! +!!$ ELSE +!!$ PSFC=PINH(I,J,LM+1) +!!$ RXNSFC=(1.E5/PSFC)**CAPPA +!!$ +!!$ QSFC(I,J)=PQ0SEA/PSFC & +!!$ & *EXP(A2*(THSK(I,J)-A3*RXNSFC)/(THSK(I,J)-A4*RXNSFC)) +!!$ ENDIF +! + QZ0 (I,J)=QSFC(I,J) +! QZ0 (I,J)=(1.-SEAMASK)*QSFC(I,J)+SEAMASK*QZ0 (I,J) +! + LMH=LM +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** TEMPERATURE AND WATER VAPOR +!---------------------------------------------------------------------- +! + CALL VDIFH(DTDIF,LMH,THZ0(I,J),QZ0(I,J) & + ,AKHS_DENS,CHKLOWQ(I,J) & + ,THK,QK,CWMK,AKHK,ZHK,RHOK,I,J,LM) +!---------------------------------------------------------------------- +!*** +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=1,LM + RTHBLTEN(I,J,K)=(THK(K)-TH(I,J,K))*RDTTURBL + RQBLTEN(I,J,K)=(QK(K)-Q(I,J,K))*RDTTURBL + RQCBLTEN(I,J,K)=(CWMK(K)-CWM(I,J,K))*RDTTURBL + ENDDO +! +!*** Begin debugging +! IF(I==IMD.AND.J==JMD)THEN +! PRINT_DIAG=0 +! ELSE +! PRINT_DIAG=0 +! ENDIF +! IF(I==227.AND.J==363)PRINT_DIAG=0 +!*** End debugging +! + PSFC=.01*PINH(I,J,LM+1) + ZSL_DIAG=0.5*DZ(I,J,LM) +! +!*** Begin debugging +! IF(PRINT_DIAG==1)THEN +! +! WRITE(6,"(A, 2I5, 2I3, 2F8.2, F6.2, 2F8.2)") & +! '{TURB4 I,J, KPBL, KMXL, PSFC, ZSFC, ZSL, ZPBL, ZMXL = ' & +! , I, J, KPBL(I,J), LM-LMXL+1, PSFC, ZHK(LMH+1), ZSL_DIAG & +! , PBLH(I,J), ZHK(LMXL)-ZHK(LMH+1) +! WRITE(6,"(A, 2F7.2, F7.3, 3E11.4)") & +! '{TURB4 TSK, THSK, QZ0, Q**2_0, AKHS, EXCH_0 = ' & +! , TSK(I,J)-273.15, THSK(I,J), 1000.*QZ0(I,J) & +! , Q2(I,1,J), AKHS(I,J), AKHS(I,J)*ZSL_DIAG +! WRITE(6,"(A)") & +! '{TURB5 K, PMID, PINH_1, TC, TH, DTH, GH, GM, EL, Q**2, AKH, EXCH_H, DZ, DP' +! DO K=1,LM/2 +! WRITE(6,"(A,I3, 2F8.2, 2F8.3, 3E12.4, 4E11.4, F7.2, F6.2)") & +! '{TURB5 ', K, .01*PMID(I,K,J),.01*PINH(I,K,J), T(I,K,J)-273.15 & +! , TH(I,K,J), DTTURBL*RTHBLTEN(I,K,J), GH(K), GM(K) & +! , EL_MYJ(I,K,J), Q2(I,K+1,J), AKH(I,K,J) & +! , EXCH_H(I,K,J), DZ(I,K,J), .01*(PINH(I,K,J)-PINH(I,K+1,J)) +! ENDDO +! +! ELSEIF(PRINT_DIAG==2)THEN +! +! WRITE(6,"(A, 2I5, 2I3, 2F8.2, F6.2, 2F8.2)") & +! '}TURB4 I,J, KPBL, KMXL, PSFC, ZSFC, ZSL, ZPBL, ZMXL = ' & +! , I, J, KPBL(I,J), LM-LMXL+1, PSFC, ZHK(LMH+1), ZSL_DIAG & +! , PBLH(I,J), ZHK(LMXL)-ZHK(LMH+1) +! WRITE(6,"(A, 2F7.2, F7.3, 3E11.4)") & +! '}TURB4 TSK, THSK, QZ0, Q**2_0, AKHS, EXCH_0 = ' & +! , TSK(I,J)-273.15, THSK(I,J), 1000.*QZ0(I,J) & +! , Q2(I,1,J), AKHS(I,J), AKHS(I,J)*ZSL_DIAG +! WRITE(6,"(A)") & +! '}TURB5 K, PMID, PINH_1, TC, TH, DTH, GH, GM, EL, Q**2, AKH, EXCH_H, DZ, DP' +! DO K=1,LM/2 +! WRITE(6,"(A,I3, 2F8.2, 2F8.3, 3E12.4, 4E11.4, F7.2, F6.2)") & +! '}TURB5 ', K, .01*PMID(I,K,J),.01*PINH(I,K,J), T(I,K,J)-273.15 & +! , TH(I,K,J), DTTURBL*RTHBLTEN(I,K,J), GH(K), GM(K) & +! , EL_MYJ(I,K,J), Q2(I,K+1,J), AKH(I,K,J) & +! , EXCH_H(I,K,J), DZ(I,K,J), .01*(PINH(I,K,J)-PINH(I,K+1,J)) +! ENDDO +! ENDIF +!*** End debugging +! +!---------------------------------------------------------------------- +! + SEAMASK=XLAND(I,J)-1. +! +!!$ IF(SEAMASK.LT.0.5.AND.STDH(I,J).GT.1.) THEN +!!$ RSTDH=1./STDH(I,J) +!!$ ELSE +!!$ RSTDH=0. +!!$ ENDIF + ZHK(LM+1)=ZINT(I,J,LM+1) +!!$ ZSF=STDH(I,J)*STDFAC+ZHK(LM+1) +! +!---------------------------------------------------------------------- +! +!*** FILL 1-D VERTICAL ARRAYS +! + DO K=1,LM-1 + AKMK(K)=AKM(I,J,K) + AKMK(K)=AKMK(K)*(RHOK(K)+RHOK(K+1))*0.5 + ENDDO +! + AKMS_DENS=AKMS(I,J)*RHOK(LM) +! + DO K=LM,1,-1 + UK(K)=U(I,J,K) + VK(K)=V(I,J,K) + ZHK(K)=ZINT(I,J,K) + ENDDO + ZHK(LM+1)=ZINT(I,J,LM+1) +! +!---------------------------------------------------------------------- +! + DO K=1,LM-1 +!jun23 IF(SEAMASK.GT.0.5) THEN +!jun23 DCOL(K)=0. +!jun23 ELSE +!jun23 ZUV=(ZHK(K)+ZHK(K+1))*0.5 +!jun23 IF(ZUV.GT.ZSF) THEN +!jun23 DCOL(K)=0. +!jun23 ELSE +!jun23 DCOL(K)=HERF((((ZUV-ZHK(LM+1))*RSTDH)**2)*0.5) +!jun23 ENDIF +!jun23 ENDIF +!WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW + DCOL(K)=0. !ZJ +!MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM + ENDDO +! +!---------------------------------------------------------------------- +!*** CARRY OUT THE VERTICAL DIFFUSION OF +!*** VELOCITY COMPONENTS +!---------------------------------------------------------------------- +! +! flux: stress/spd1 + WIND = sqrt(UK(LM)*UK(LM) + VK(LM)*VK(LM)) + UZ0(I,J) = USTAR(I,J)*UK(LM)/WIND + VZ0(I,J) = USTAR(I,J)*VK(LM)/WIND + CALL VDIFV(LMH,DTDIF,UZ0(I,J),VZ0(I,J) & + & ,AKMS_DENS,DCOL,UK,VK,AKMK,ZHK,RHOK,I,J,LM) +! +!---------------------------------------------------------------------- +!*** +!*** COMPUTE PRIMARY VARIABLE TENDENCIES +!*** + DO K=1,LM + RUBLTEN(I,J,K)=(UK(K)-U(I,J,K))*RDTTURBL + RVBLTEN(I,J,K)=(VK(K)-V(I,J,K))*RDTTURBL + ENDDO +! +! compute tke dissipation rate +! + if(dspheat) then +! + do k = 1,lm-1 ! equals to "k = levs,2,-1" in fv3 solver's k index + ti = 2./(thk(k)+thk(k+1)) + diss(k) = exch_m(i,j,k)*gm(k)-g*ti*exch_h(i,j,k)*gh(k) + enddo +! +! add dissipative heating at the first model layer +! + sflux = hflx(i,j)/rhok(lm)/cp + elflx(i,j)/rhok(lm)*ep_1*thk(lm) ! Kms-1 + tem = g/thk(lm)*sflux + tem1 = tem + ustar(i,j)**2.*spd1(i,j)/(0.5*dz(i,j,lm)) + tem2 = 0.5 * (tem1+diss(lm-1)) + tem2 = max(tem2, 0.) + ttend = tem2 / cp + rthblten(i,j,lm) = rthblten(i,j,lm) + 0.5*ttend +! +! add dissipative heating above the first model layer +! + do k = 2,lm-1 ! equals to "k = levs-1,2,-1" in fv3 solver's k index + tem = 0.5 * (diss(k-1)+diss(k)) + tem = max(tem, 0.) + ttend = tem / cp + rthblten(i,j,k) = rthblten(i,j,k) + 0.5*ttend + enddo +! + endif ! endif dspheat +! + ENDDO +!---------------------------------------------------------------------- +! + ENDDO main_integration + +!JAA!ZJ$NO-MP END PARALLEL DO +! +!---------------------------------------------------------------------- +! + END SUBROUTINE MYJ_PBL +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE MIXLEN & +!---------------------------------------------------------------------- +! ****************************************************************** +! * * +! * LEVEL 2.5 MIXING LENGTH * +! * * +! ****************************************************************** +! + (LMH,RSQDT,U,V,THV,THE,Q2,EPSL,EPSQ2,Z,P,PS,RXNER & + ,GM,GH,EL,PBLH,LPBL,LMXL,MIXHT,I,J,LM) +! +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + LMH,I,J,LM +! + REAL(KIND=KFPT),INTENT(IN):: & + RSQDT +! + INTEGER(KIND=KINT),INTENT(OUT):: & + LMXL,LPBL +! + real(kind=kfpt),dimension(1:lm-1),intent(in):: EPSL + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(IN):: & + P,PS,Q2,EPSQ2,RXNER,THE,THV,U,V +! + REAL(KIND=KFPT),DIMENSION(1:LM+1),INTENT(IN):: & + Z +! + REAL(KIND=KFPT),INTENT(OUT):: & + MIXHT & + ,PBLH +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(OUT):: & + EL,GH,GM +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + K,LPBLM +! + REAL(KIND=KFPT):: & + ADEN,BDEN,AUBR,BUBR,BLMX,CUBRY,DTHV,DZ & + ,EL0,ELOQ2X,GHL,GML & + ,QOL2ST,QOL2UN,QDZL & + ,RDZ,SQ,SREL,SZQ,VKRMZ,WCON +! + REAL(KIND=KFPT),DIMENSION(1:LM):: & + Q1 +! + REAL(KIND=KFPT),DIMENSION(1:LM-1):: & + ELM,REL +! +!---------------------------------------------------------------------- +!*********************************************************************** +!--------1---------2---------3---------4---------5---------6---------7-- + CUBRY=UBRY*1.5 !*2. +!--------------FIND THE HEIGHT OF THE PBL------------------------------- + LPBL=LMH +! + DO K=LMH-1,1,-1 + if(q2(k)-epsq2(k)+epsq2(lm).le.epsq2(lm)*fh) then + LPBL=K + GO TO 110 + ENDIF + ENDDO +! + LPBL=1 +! +!--------------THE HEIGHT OF THE PBL------------------------------------ +! + 110 PBLH=Z(LPBL+1)-Z(LMH+1) +! +!----------------------------------------------------------------------- + DO K=1,LMH + Q1(K)=0. + ENDDO +!----------------------------------------------------------------------- + DO K=1,LMH-1 + DZ=(Z(K)-Z(K+2))*0.5 + RDZ=1./DZ + GML=((U(K)-U(K+1))**2+(V(K)-V(K+1))**2)*RDZ*RDZ + GM(K)=MAX(GML,EPSGM) +! + DTHV=THV(K)-THV(K+1) +!---------------------------------------------------------------------- + IF(DTHV.GT.0.) THEN + IF(THE(K+1).GT.THE(K)) THEN + IF(PS(K+1).GT.P(K)) THEN !>12KM +! + WCON=(P(K+1)-PS(K+1))/(P(K+1)-P(K)) +! + if( & + (q2(k).gt.epsq2(k)) .and. & + (q2(k)*cubry.gt.(dz*wcon*rsqdt)**2) & + ) then +! + DTHV=(THE(K)-THE(K+1))+DTHV +! + ENDIF + ENDIF + ENDIF + ENDIF +!-------------------------------------------------------------------------- +! + GHL=DTHV*RDZ + IF(ABS(GHL)<=EPSGH)GHL=EPSGH + GH(K)=GHL + ENDDO +! +!---------------------------------------------------------------------- +!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP +!---------------------------------------------------------------------- +! + LMXL=LMH +! + DO K=1,LMH-1 + GML=GM(K) + GHL=GH(K) +! + IF(GHL>=EPSGH)THEN + IF(GML/GHL<=REQU)THEN + ELM(K)=EPSL(K) + LMXL=K+1 + ELSE + AUBR=(AUBM*GML+AUBH*GHL)*GHL + BUBR= BUBM*GML+BUBH*GHL + QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR + ELOQ2X=1./MAX(EPSGH, QOL2ST) + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL(K)) + ENDIF + ELSE + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) + ELOQ2X=1./(QOL2UN+EPSRU) ! REPSR1/QOL2UN + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL(K)) + ENDIF + ENDDO +! + IF(ELM(LMH-1)==EPSL(LMH-1))LMXL=LMH +! +!---------------------------------------------------------------------- +!*** THE HEIGHT OF THE MIXED LAYER +!---------------------------------------------------------------------- +! + BLMX=Z(LMXL)-Z(LMH+1) + MIXHT=BLMX +! +!---------------------------------------------------------------------- + DO K=LPBL,LMH + Q1(K)=SQRT(Q2(K)) + ENDDO +!---------------------------------------------------------------------- + SZQ=0. + SQ =0. +! + DO K=1,LMH-1 + QDZL=(Q1(K)+Q1(K+1))*(Z(K+1)-Z(K+2)) + SZQ=(Z(K+1)+Z(K+2)-Z(LMH+1)-Z(LMH+1))*QDZL+SZQ + SQ=QDZL+SQ + ENDDO +! +!---------------------------------------------------------------------- +!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA +!---------------------------------------------------------------------- +! + EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) + EL0=MAX(EL0 ,EL0MIN) +! +!---------------------------------------------------------------------- +!*** ABOVE THE PBL TOP +!---------------------------------------------------------------------- +! + LPBLM=MAX(LPBL-1,1) +! + DO K=1,LPBLM + EL(K)=MIN((Z(K)-Z(K+2))*ELFC,ELM(K)) + REL(K)=EL(K)/ELM(K) + ENDDO +! +!---------------------------------------------------------------------- +!*** INSIDE THE PBL +!---------------------------------------------------------------------- +! + IF(LPBL=EPSGH.AND.GML/GHL<=REQU) & + & .OR.(EQOL2<=EPS2))THEN +! +!---------------------------------------------------------------------- +!*** NO TURBULENCE +!---------------------------------------------------------------------- +! + Q2(K)=EPSQ2(K) + EL(K)=EPSL(K) +!---------------------------------------------------------------------- +! + ELSE +! +!---------------------------------------------------------------------- +!*** TURBULENCE +!---------------------------------------------------------------------- +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE NUMERATOR +!---------------------------------------------------------------------- +! + ANUM=(ANMM*GML+ANMH*GHL)*GHL + BNUM= BNMM*GML+BNMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE NUMERATOR OF THE LINEARIZED EQ. +!---------------------------------------------------------------------- +! + ARHS=-(ANUM*BDEN-BNUM*ADEN)*2. + BRHS=- ANUM*4. + CRHS=- BNUM*2. +! +!---------------------------------------------------------------------- +!*** INITIAL VALUE OF L/Q +!---------------------------------------------------------------------- +! + DLOQ1=EL(K)/SQRT(Q2(K)) +! +!---------------------------------------------------------------------- +!*** FIRST ITERATION FOR L/Q, RHS=0 +!---------------------------------------------------------------------- +! + ELOQ21=1./EQOL2 + ELOQ11=SQRT(ELOQ21) + ELOQ31=ELOQ21*ELOQ11 + ELOQ41=ELOQ21*ELOQ21 + ELOQ51=ELOQ21*ELOQ31 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN1=1./(ADEN*ELOQ41+BDEN*ELOQ21+CDEN) +! +!---------------------------------------------------------------------- +!*** D(RHS)/D(L/Q) +!---------------------------------------------------------------------- +! + RHSP1=(ARHS*ELOQ51+BRHS*ELOQ31+CRHS*ELOQ11)*RDEN1*RDEN1 +! +!---------------------------------------------------------------------- +!*** FIRST-GUESS SOLUTION +!---------------------------------------------------------------------- +! + ELOQ12=ELOQ11+(DLOQ1-ELOQ11)*EXP(RHSP1*DTTURBL) + ELOQ12=MAX(ELOQ12,EPS1) +! +!---------------------------------------------------------------------- +!*** SECOND ITERATION FOR L/Q +!---------------------------------------------------------------------- +! + ELOQ22=ELOQ12*ELOQ12 + ELOQ32=ELOQ22*ELOQ12 + ELOQ42=ELOQ22*ELOQ22 + ELOQ52=ELOQ22*ELOQ32 +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN2=1./(ADEN*ELOQ42+BDEN*ELOQ22+CDEN) + RHS2 =-(ANUM*ELOQ42+BNUM*ELOQ22)*RDEN2+RB1 + RHSP2= (ARHS*ELOQ52+BRHS*ELOQ32+CRHS*ELOQ12)*RDEN2*RDEN2 + RHST2=RHS2/RHSP2 +! +!---------------------------------------------------------------------- +!*** CORRECTED SOLUTION +!---------------------------------------------------------------------- +! + ELOQ13=ELOQ12-RHST2+(RHST2+DLOQ1-ELOQ12)*EXP(RHSP2*DTTURBL) + ELOQ13=AMAX1(ELOQ13,EPS1) +! +!---------------------------------------------------------------------- +!*** TWO ITERATIONS IS ENOUGH IN MOST CASES ... +!---------------------------------------------------------------------- +! + ELOQN=ELOQ13 +! + IF(ELOQN>EPS1)THEN + Q2(K)=EL(K)*EL(K)/(ELOQN*ELOQN) + Q2(K)=AMAX1(Q2(K),EPSQ2(K)) + IF(Q2(K)==EPSQ2(K))THEN + EL(K)=EPSL(K) + ENDIF + ELSE + Q2(K)=EPSQ2(K) + EL(K)=EPSL(K) + ENDIF +! +!---------------------------------------------------------------------- +!*** END OF TURBULENT BRANCH +!---------------------------------------------------------------------- +! + ENDIF +!---------------------------------------------------------------------- +!*** END OF PRODUCTION/DISSIPATION LOOP +!---------------------------------------------------------------------- +! + ENDDO main_integration +! +!---------------------------------------------------------------------- +!*** LOWER BOUNDARY CONDITION FOR Q2 +!---------------------------------------------------------------------- +! + Q2(LMH)=AMAX1(B1**(2./3.)*USTAR*USTAR,EPSQ2(LMH)) +!---------------------------------------------------------------------- +! + END SUBROUTINE PRODQ2 +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE DIFCOF & +! ****************************************************************** +! * * +! * LEVEL 2.5 DIFFUSION COEFFICIENTS * +! * * +! ****************************************************************** + (LMH,LMXL,GM,GH,EL,T,Q2,Z,AKM,AKH,I,J,LM,PRINT_DIAG) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER(KIND=KINT),INTENT(IN):: & + LMH,LMXL,I,J,LM +! + REAL(KIND=KFPT),DIMENSION(1:LM),INTENT(IN):: & + Q2,T +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(IN):: & + EL,GH,GM +! + REAL(KIND=KFPT),DIMENSION(1:LM+1),INTENT(IN):: & + Z +! + REAL(KIND=KFPT),DIMENSION(1:LM-1),INTENT(OUT):: & + AKH,AKM +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER(KIND=KINT):: & + K,KINV +! + REAL(KIND=KFPT):: & + ADEN,AKMIN,BDEN,BESH,BESM,CDEN,D2T,ELL,ELOQ2,ELOQ4,ELQDZ & + ,ESH,ESM,GHL,GML,Q1L,RDEN,RDZ +! +!*** Begin debugging + INTEGER(KIND=KINT),INTENT(IN):: PRINT_DIAG +! REAL(KIND=KFPT):: D2TMIN +!*** End debugging +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! + DO K=1,LMH-1 + ELL=EL(K) +! + ELOQ2=ELL*ELL/Q2(K) + ELOQ4=ELOQ2*ELOQ2 +! + GML=GM(K) + GHL=GH(K) +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS OF THE TERMS IN THE DENOMINATOR +!---------------------------------------------------------------------- +! + ADEN=(ADNM*GML+ADNH*GHL)*GHL + BDEN= BDNM*GML+BDNH*GHL + CDEN= 1. +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SM DETERMINANT +!---------------------------------------------------------------------- +! + BESM=BSMH*GHL +! +!---------------------------------------------------------------------- +!*** COEFFICIENTS FOR THE SH DETERMINANT +!---------------------------------------------------------------------- +! + BESH=BSHM*GML+BSHH*GHL +! +!---------------------------------------------------------------------- +!*** 1./DENOMINATOR +!---------------------------------------------------------------------- +! + RDEN=1./(ADEN*ELOQ4+BDEN*ELOQ2+CDEN) +! +!---------------------------------------------------------------------- +!*** SM AND SH +!---------------------------------------------------------------------- +! + ESM=(BESM*ELOQ2+CESM)*RDEN + ESH=(BESH*ELOQ2+CESH)*RDEN +! +!---------------------------------------------------------------------- +!*** DIFFUSION COEFFICIENTS +!---------------------------------------------------------------------- +! + RDZ=2./(Z(K)-Z(K+2)) + Q1L=SQRT(Q2(K)) + ELQDZ=ELL*Q1L*RDZ + AKM(K)=ELQDZ*ESM + AKH(K)=ELQDZ*ESH +!WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW +! AKM(K)=MAX(AKM(K),RDZ*3.) +! AKH(K)=MAX(AKH(K),RDZ*3.) +!MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM +!---------------------------------------------------------------------- + ENDDO +!---------------------------------------------------------------------- +! +!---------------------------------------------------------------------- +!*** INVERSIONS +!---------------------------------------------------------------------- +! +! IF(LMXL==LMH)THEN +! KINV=LMH +! D2TMIN=0. +! +! DO K=LMH/2,LMH-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! IF(D2T0)THEN +! WRITE(6,"(A,3I3)") '{TURB1 LMXL,LMH,KINV=',LMXL,LMH,KINV +! WRITE(6,"(A,3I3)") '}TURB1 LMXL,LMH,KINV=',LMXL,LMH,KINV +! IF(PRINT_DIAG==1)THEN +! WRITE(6,"(A)") & +! '{TURB3 K, T, D2T, RDZ, Z(K), Z(K+2), AKMIN, AKH ' +! ELSE +! WRITE(6,"(A)") & +! '}TURB3 K, T, D2T, RDZ, Z(K), Z(K+2), AKMIN, AKH ' +! ENDIF +! DO K=LMH-1,KINV-1,-1 +! D2T=T(K-1)-2.*T(K)+T(K+1) +! RDZ=2./(Z(K)-Z(K+2)) +! AKMIN=0.5*RDZ +! IF(PRINT_DIAG==1)THEN +! WRITE(6,"(A,I3,F8.3,2E12.5,2F9.2,2E12.5)") '{TURB3 ' & +! ,K,T(K)-273.15,D2T,RDZ,Z(K),Z(K+2),AKMIN,AKH(K) +! ELSE +! WRITE(6,"(A,I3,F8.3,2E12.5,2F9.2,2E12.5)") '}TURB3 ' & +! ,K,T(K)-273.15,D2T,RDZ,Z(K),Z(K+2),AKMIN,AKH(K) +! ENDIF +! ENDDO +! ENDIF !- IF (PRINT_DIAG > 0) THEN +! ENDIF !- IF(KINV +!$OMP PARALLEL + num_parthds=omp_get_num_threads() +!$OMP END PARALLEL +#else +! num_parthds=8 + num_parthds=1 +#endif + return + end + +!GFDL function num_parthds() +!GFDL integer:: number_of_openMP_threads +!GFDL character(2) :: omp_threads +!GFDL integer :: stat +!GFDL call get_environment_variable("OMP_NUM_THREADS",omp_threads) +!GFDL read(omp_threads,*,iostat=stat)number_of_openMP_threads +!GFDL num_parthds = number_of_openMP_threads +!GFDL return +!GFDL end + diff --git a/gsmphys/ozinterp.f90 b/gsmphys/ozinterp.f90 new file mode 100644 index 00000000..2f1ce3be --- /dev/null +++ b/gsmphys/ozinterp.f90 @@ -0,0 +1,195 @@ + SUBROUTINE read_o3data (ntoz, me, master) + use machine, only: kind_phys + use ozne_def +!--- in/out + integer, intent(in) :: ntoz + integer, intent(in) :: me + integer, intent(in) :: master +!--- locals + integer :: i, n, k + real(kind=4), allocatable, dimension(:) :: oz_lat4, oz_pres4 + real(kind=4), allocatable, dimension(:) :: oz_time4, tempin + + if (ntoz <= 0) then ! Diagnostic ozone + rewind (kozc) + read (kozc,end=101) latsozc, levozc, timeozc, blatc4 + 101 if (levozc < 10 .or. levozc > 100) then + rewind (kozc) + levozc = 17 + latsozc = 18 + blatc = -85.0 + else + blatc = blatc4 + endif + latsozp = 2 + levozp = 1 + timeoz = 1 + oz_coeff = 0 + dphiozc = -(blatc+blatc)/(latsozc-1) + return + endif + + open(unit=kozpl,file='INPUT/global_o3prdlos.f77', form='unformatted', convert='big_endian') + +!--- read in indices +!--- + read (kozpl) oz_coeff, latsozp, levozp, timeoz + if (me == master) then + write(*,*) 'Reading in o3data from global_o3prdlos.f77 ' + write(*,*) ' oz_coeff = ', oz_coeff + write(*,*) ' latsozp = ', latsozp + write(*,*) ' levozp = ', levozp + write(*,*) ' timeoz = ', timeoz + endif + +!--- read in data +!--- oz_lat - latitude of data (-90 to 90) +!--- oz_pres - vertical pressure level (mb) +!--- oz_time - time coordinate (days) +!--- + allocate (oz_lat(latsozp), oz_pres(levozp),oz_time(timeoz+1)) + allocate (oz_lat4(latsozp), oz_pres4(levozp),oz_time4(timeoz+1)) + rewind (kozpl) + read (kozpl) oz_coeff, latsozp, levozp, timeoz, oz_lat4, oz_pres4, oz_time4 + oz_pres(:) = oz_pres4(:) +!--- convert pressure levels from mb to ln(Pa) + oz_pres(:) = log(100.0*oz_pres(:)) + oz_lat(:) = oz_lat4(:) + oz_time(:) = oz_time4(:) + deallocate (oz_lat4, oz_pres4, oz_time4) + +!--- read in ozplin which is in order of (lattitudes, ozone levels, coeff number, time) +!--- assume latitudes is on a uniform gaussian grid +!--- + allocate (tempin(latsozp)) + allocate (ozplin(latsozp,levozp,oz_coeff,timeoz)) + DO i=1,timeoz + DO n=1,oz_coeff + DO k=1,levozp + READ(kozpl) tempin + ozplin(:,k,n,i) = tempin(:) + ENDDO + ENDDO + ENDDO + deallocate (tempin) + + close(kozpl) + + END SUBROUTINE read_o3data +! +!********************************************************************** +! + SUBROUTINE setindxoz(npts,dlat,jindx1,jindx2,ddy) +! + USE MACHINE, ONLY: kind_phys + USE OZNE_DEF, ONLY: jo3 => latsozp, oz_lat +! + implicit none +! + integer npts, JINDX1(npts),JINDX2(npts) + real(kind=kind_phys) dlat(npts),DDY(npts) +! + integer i,j,lat +! + DO J=1,npts + jindx2(j) = jo3 + 1 + do i=1,jo3 + if (dlat(j) < oz_lat(i)) then + jindx2(j) = i + exit + endif + enddo + jindx1(j) = max(jindx2(j)-1,1) + jindx2(j) = min(jindx2(j),jo3) + if (jindx2(j) .ne. jindx1(j)) then + DDY(j) = (dlat(j) - oz_lat(jindx1(j))) & + / (oz_lat(jindx2(j)) - oz_lat(jindx1(j))) + else + ddy(j) = 1.0 + endif +! print *,' j=',j,' dlat=',dlat(j),' jindx12=',jindx1(j), & +! jjindx2(j),' oz_lat=',oz_lat(jindx1(j)), & +! oz_lat(jindx2(j)),' ddy=',ddy(j) + ENDDO + + RETURN + END +! +!********************************************************************** +! + SUBROUTINE ozinterpol(me,npts,IDATE,FHOUR,jindx1,jindx2,ozplout,ddy) +! + USE MACHINE, ONLY : kind_phys + USE OZNE_DEF + implicit none + integer iday,j,j1,j2,l,npts,nc,n1,n2 + real(kind=kind_phys) fhour,tem, tx1, tx2 +! + + integer JINDX1(npts), JINDX2(npts) + integer me,idate(4) + integer IDAT(8),JDAT(8) +! + real(kind=kind_phys) DDY(npts) + real(kind=kind_phys) ozplout(npts,levozp,oz_coeff) + real(kind=kind_phys) RINC(5), rjday + integer jdow, jdoy, jday + real(4) rinc4(5) + integer w3kindreal,w3kindint +! + IDAT=0 + IDAT(1)=IDATE(4) + IDAT(2)=IDATE(2) + IDAT(3)=IDATE(3) + IDAT(5)=IDATE(1) + RINC=0. + RINC(2)=FHOUR + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + rinc4=rinc + CALL W3MOVDAT(RINC4,IDAT,JDAT) + else + CALL W3MOVDAT(RINC,IDAT,JDAT) + endif +! + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jdat,jdow,jdoy,jday) + rjday = jdoy + jdat(5) / 24. + IF (RJDAY .LT. oz_time(1)) RJDAY = RJDAY+365. +! + n2 = timeoz + 1 + do j=2,timeoz + if (rjday .lt. oz_time(j)) then + n2 = j + exit + endif + enddo + n1 = n2 - 1 + +! +! if (me .eq. 0) print *,' n1=',n1,' n2=',n2,' rjday=',rjday +! &,'oz_time=',oz_time(n1),oz_time(n2) +! + + tx1 = (oz_time(n2) - rjday) / (oz_time(n2) - oz_time(n1)) + tx2 = 1.0 - tx1 + + if (n2 > timeoz) n2 = n2 - timeoz +! + do nc=1,oz_coeff + DO L=1,levozp + DO J=1,npts + J1 = JINDX1(J) + J2 = JINDX2(J) + TEM = 1.0 - DDY(J) + ozplout(j,L,nc) = & + tx1*(TEM*ozplin(J1,L,nc,n1)+DDY(J)*ozplin(J2,L,nc,n1)) & + + tx2*(TEM*ozplin(J1,L,nc,n2)+DDY(J)*ozplin(J2,L,nc,n2)) + ENDDO + ENDDO + enddo +! + RETURN + END diff --git a/gsmphys/ozne_def.f b/gsmphys/ozne_def.f new file mode 100644 index 00000000..c33ef0b6 --- /dev/null +++ b/gsmphys/ozne_def.f @@ -0,0 +1,14 @@ + module ozne_def + use machine , only : kind_phys + implicit none + + integer, parameter :: kozpl=28, kozc=48 + + integer latsozp, levozp, timeoz, latsozc, levozc, timeozc + &, oz_coeff + real (kind=kind_phys) blatc, dphiozc + real (kind=kind_phys), allocatable :: oz_lat(:), oz_pres(:) + &, oz_time(:) + real (kind=kind_phys), allocatable :: ozplin(:,:,:,:) + + end module ozne_def diff --git a/gsmphys/ozphys.f b/gsmphys/ozphys.f new file mode 100644 index 00000000..09530f74 --- /dev/null +++ b/gsmphys/ozphys.f @@ -0,0 +1,153 @@ +!> \file ozphys.f +!! This file is ozone sources and sinks. + +!> \defgroup ozn Ozone Sources and Sinks +!! The operational GFS currently parameterizes ozone production and +!! destruction based on monthly mean coefficients provided by Naval +!! Research Laboratory through CHEM2D chemistry model +!! (McCormack et al. 2006 \cite mccormack_et_al_2006). +!! Monthly and zonal mean ozone production rate and ozone destruction +!! rate per unit ozone mixing ratio were provided by NRL based on +!! CHEM2D model. +!! Original version of these terms were provided by NASA/DAO based on +!! NASA 2D Chemistry model - GSM is capable of running both versions +!! +!! \section intra_oz Intraphysics Cummunication +!! - Routine OZPHYS is called from GBPHYS after call to RAYLEIGH_DAMP +!! @{ +!! +!! \param[in] ix,im integer, horizontal dimension and num of used pts +!! \param[in] levs integer, vertical layer dimension +!! \param[in] ko3 integer, number of layers for ozone data +!! \param[in] dt real, physics time step in seconds +!! \param[in] ozi real, updated ozone +!! \param[in] ozo real, updated ozone +!! \param[in] tin real, updated temperature +!! \param[in] po3 real, (ko3), ozone forcing data level pressure +!! (ln(Pa)) +!! \param[in] prsl real, (ix,levs),mean layer pressure +!! \param[in] prdout real, (ix,ko3,pl_coeff),ozone forcing data +!! \param[in] pl_coeff integer, number coefficients in ozone forcing +!! \param[in] delp real, (ix,levs) +!! \param[in] ldiag3d logical, flag for 3d diagnostic fields +!! \param[out] ozp real, ozone change due to physics +!! \param[in] me integer, pe number - used for debug prints +!! \section gen_al General Algorithm +!> @{ + subroutine ozphys (ix, im, levs, ko3, dt, ozi, ozo, tin, po3, & + & prsl, prdout, pl_coeff, delp, ldiag3d, & + & ozp,me) +! +! this code assumes that both prsl and po3 are from bottom to top +! as are all other variables +! + use machine , only : kind_phys + use physcons, only : grav => con_g + implicit none +! + real, parameter :: gravi=1.0/grav + integer im, ix, levs, ko3, pl_coeff,me + real(kind=kind_phys) ozi(ix,levs), ozo(ix,levs), po3(ko3), + & prsl(ix,levs), tin(ix,levs), delp(ix,levs), + & prdout(ix,ko3,pl_coeff), + & ozp(ix,levs,pl_coeff), dt +! + integer k,kmax,kmin,l,i,j + logical ldiag3d, flg(im) + real(kind=kind_phys) pmax, pmin, tem, temp + real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,pl_coeff), + & ozib(im), colo3(im,levs+1) +! + if (pl_coeff > 2) then + colo3(:,levs+1) = 0.0 + do l=levs,1,-1 + do i=1,im + colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l) * gravi + enddo + enddo + endif +! + do l=1,levs + pmin = 1.0e10 + pmax = -1.0e10 +! + do i=1,im + wk1(i) = log(prsl(i,l)) + pmin = min(wk1(i), pmin) + pmax = max(wk1(i), pmax) + prod(i,:) = 0.0 + enddo + kmax = 1 + kmin = 1 + do k=1,ko3-1 + if (pmin < po3(k)) kmax = k + if (pmax < po3(k)) kmin = k + enddo +! + do k=kmin,kmax + temp = 1.0 / (po3(k) - po3(k+1)) + do i=1,im + flg(i) = .false. + if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then + flg(i) = .true. + wk2(i) = (wk1(i) - po3(k+1)) * temp + wk3(i) = 1.0 - wk2(i) + endif + enddo + do j=1,pl_coeff + do i=1,im + if (flg(i)) then + prod(i,j) = wk2(i) * prdout(i,k,j) + & + wk3(i) * prdout(i,k+1,j) + endif + enddo + enddo + enddo +! + do j=1,pl_coeff + do i=1,im + if (wk1(i) < po3(ko3)) then + prod(i,j) = prdout(i,ko3,j) + endif + if (wk1(i) >= po3(1)) then + prod(i,j) = prdout(i,1,j) + endif + enddo + enddo + if (pl_coeff == 2) then + do i=1,im + ozib(i) = ozi(i,l) ! no filling + ozo(i,l) = (ozib(i) + prod(i,1)*dt) / (1.0 + prod(i,2)*dt) + enddo +! + if (ldiag3d) then ! ozone change diagnostics + do i=1,im + ozp(i,l,1) = ozp(i,l,1) + prod(i,1)*dt + ozp(i,l,2) = ozp(i,l,2) + (ozo(i,l) - ozib(i)) + enddo + endif + endif + if (pl_coeff == 4) then + do i=1,im + ozib(i) = ozi(i,l) ! no filling + tem = prod(i,1) + prod(i,3)*tin(i,l) + & + prod(i,4)*colo3(i,l+1) +! if (me .eq. 0) print *,'ozphys tem=',tem,' prod=',prod(i,:) +! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) + ozo(i,l) = (ozib(i) + tem*dt) / (1.0 + prod(i,2)*dt) + enddo + if (ldiag3d) then ! ozone change diagnostics + do i=1,im + ozp(i,l,1) = ozp(i,l,1) + prod(i,1)*dt + ozp(i,l,2) = ozp(i,l,2) + (ozo(i,l) - ozib(i)) + ozp(i,l,3) = ozp(i,l,3) + prod(i,3)*tin(i,l)*dt + ozp(i,l,4) = ozp(i,l,4) + prod(i,4)*colo3(i,l+1)*dt + enddo + endif + endif + enddo ! vertical loop +! + return + end +!! @} +!> @} diff --git a/gsmphys/ozphys_2015.f b/gsmphys/ozphys_2015.f new file mode 100755 index 00000000..1d7cad57 --- /dev/null +++ b/gsmphys/ozphys_2015.f @@ -0,0 +1,108 @@ + subroutine ozphys_2015 (ix, im, levs, ko3, dt, ozi, ozo, tin, po3, + & prsl, prdout, pl_coeff, delp, ldiag3d, + & ozp,me) +! +! this code assumes that both prsl and po3 are from bottom to top +! as are all other variables +! This code is specifically for NRL parameterization and +! climatological T and O3 are in location 5 and 6 of prdout array +! June 2015 - Shrinivas Moorthi +! + use machine , only : kind_phys + use physcons, only : grav => con_g + implicit none +! + real, parameter :: gravi=1.0/grav + integer im, ix, levs, ko3, pl_coeff,me + real(kind=kind_phys) ozi(ix,levs), ozo(ix,levs), po3(ko3), + & prsl(ix,levs), tin(ix,levs), delp(ix,levs), + & prdout(ix,ko3,pl_coeff), + & ozp(ix,levs,4), dt +! + integer k,kmax,kmin,l,i,j + logical ldiag3d, flg(im) + real(kind=kind_phys) pmax, pmin, tem, temp + real(kind=kind_phys) wk1(im), wk2(im), wk3(im), prod(im,pl_coeff), + & ozib(im), colo3(im,levs+1), coloz(im,levs+1) +! + colo3(:,levs+1) = 0.0 + coloz(:,levs+1) = 0.0 +! + do l=levs,1,-1 + pmin = 1.0e10 + pmax = -1.0e10 +! + do i=1,im + wk1(i) = log(prsl(i,l)) + pmin = min(wk1(i), pmin) + pmax = max(wk1(i), pmax) + prod(i,:) = 0.0 + enddo + kmax = 1 + kmin = 1 + do k=1,ko3-1 + if (pmin < po3(k)) kmax = k + if (pmax < po3(k)) kmin = k + enddo +! + do k=kmin,kmax + temp = 1.0 / (po3(k) - po3(k+1)) + do i=1,im + flg(i) = .false. + if (wk1(i) < po3(k) .and. wk1(i) >= po3(k+1)) then + flg(i) = .true. + wk2(i) = (wk1(i) - po3(k+1)) * temp + wk3(i) = 1.0 - wk2(i) + endif + enddo + do j=1,pl_coeff + do i=1,im + if (flg(i)) then + prod(i,j) = wk2(i) * prdout(i,k,j) + & + wk3(i) * prdout(i,k+1,j) + endif + enddo + enddo + enddo +! + do j=1,pl_coeff + do i=1,im + if (wk1(i) < po3(ko3)) then + prod(i,j) = prdout(i,ko3,j) + endif + if (wk1(i) >= po3(1)) then + prod(i,j) = prdout(i,1,j) + endif + enddo + enddo + do i=1,im + colo3(i,l) = colo3(i,l+1) + ozi(i,l) * delp(i,l)*gravi + coloz(i,l) = coloz(i,l+1) + prod(i,6) * delp(i,l)*gravi + prod(i,2) = min(prod(i,2), 0.0) + enddo +! write(1000+me,*) ' colo3=',colo3(1,l),' coloz=',coloz(1,l) +! &,' l=',l + do i=1,im + ozib(i) = ozi(i,l) ! no filling + tem = prod(i,1) - prod(i,2) * prod(i,6) + & + prod(i,3) * (tin(i,l) - prod(i,5)) + & + prod(i,4) * (colo3(i,l)-coloz(i,l)) + +! if (me .eq. 0) print *,'ozphys_2015 tem=',tem,' prod=',prod(i,:) +! &,' ozib=',ozib(i),' l=',l,' tin=',tin(i,l),'colo3=',colo3(i,l+1) + + ozo(i,l) = (ozib(i) + tem*dt) / (1.0 - prod(i,2)*dt) + enddo + if (ldiag3d) then ! ozone change diagnostics + do i=1,im + ozp(i,l,1) = ozp(i,l,1) + (prod(i,1)-prod(i,2)*prod(i,6))*dt + ozp(i,l,2) = ozp(i,l,2) + (ozo(i,l) - ozib(i)) + ozp(i,l,3) = ozp(i,l,3) + prod(i,3)*(tin(i,l)-prod(i,5))*dt + ozp(i,l,4) = ozp(i,l,4) + prod(i,4) + & * (colo3(i,l)-coloz(i,l))*dt + enddo + endif + enddo ! vertical loop +! + return + end diff --git a/gsmphys/physcons.f90 b/gsmphys/physcons.f90 new file mode 100644 index 00000000..4dea5853 --- /dev/null +++ b/gsmphys/physcons.f90 @@ -0,0 +1,172 @@ +!> \file physcons.f +!! This file contains module physcons + +! ========================================================== !!!!! +! module 'physcons' description !!!!! +! ========================================================== !!!!! +! ! +! this module contains some the most frequently used math and ! +! physics constatns for gcm models. ! +! ! +! references: ! +! as set in NMC handbook from Smithsonian tables. ! +! ! +! modification history: ! +! ! +! 1990-04-30 g and rd are made consistent with NWS usage ! +! 2001-10-22 g made consistent with SI usage ! +! 2005-04-13 added molecular weights for gases - y-t hou ! +! 2013-07-12 added temperature for homogen. nuc. for ice. - R.sun ! +! ! +! external modules referenced: ! +! ! +! 'module machine' in 'machine.f' ! +! ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + +!> \ingroup rad +!! \defgroup physcons physcons +!! This module contains some of the most frequently used math and physics +!! constants for GCM models. +!! @{ +!========================================! + module physcons ! +!........................................! +! + use machine, only : kind_phys +! + implicit none +! + public + +!> \name Math constants + +!> pi + real(kind=kind_phys),parameter:: con_pi =3.1415926535897931 +!> square root of 2 + real(kind=kind_phys),parameter:: con_sqrt2 =1.414214e+0 +!> square root of 3 + real(kind=kind_phys),parameter:: con_sqrt3 =1.732051e+0 + +!> \name Geophysics/Astronomy constants + +!> radius of earth (m) + real(kind=kind_phys),parameter:: con_rerth =6.3712e+6 +!> gravity (\f$m/s^{2}\f$) + real(kind=kind_phys),parameter:: con_g =9.80665e+0 +!> ang vel of earth (\f$s^{-1}\f$) + real(kind=kind_phys),parameter:: con_omega =7.2921e-5 +!> std atms pressure (pa) + real(kind=kind_phys),parameter:: con_p0 =1.01325e5 +! real(kind=kind_phys),parameter:: con_solr =1.36822e+3 ! solar constant (W/m2)-aer(2001) +!> solar constant (\f$W/m^{2}\f$)-liu(2002) + real(kind=kind_phys),parameter:: con_solr_old =1.3660e+3 +!> solar constant (\f$W/m^{2}\f$)-nasa-sorce Tim(2008) + real(kind=kind_phys),parameter:: con_solr =1.3608e+3 +! real(kind=kind_phys),parameter:: con_solr =1.36742732e+3 ! solar constant (W/m2)-gfdl(1989) - OPR as of Jan 2006 + +!> \name Thermodynamics constants + +!> molar gas constant (\f$J/mol/K\f$) + real(kind=kind_phys),parameter:: con_rgas =8.314472 +!> gas constant air (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_rd =2.8705e+2 +!> gas constant H2O (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_rv =4.6150e+2 +!> spec heat air at p (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_cp =1.0046e+3 +!> spec heat air at v (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_cv =7.1760e+2 +!> spec heat H2O gas (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_cvap =1.8460e+3 +!> spec heat H2O liq (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_cliq =4.1855e+3 +!> spec heat H2O ice (\f$J/kg/K\f$) + real(kind=kind_phys),parameter:: con_csol =2.1060e+3 +!> lat heat H2O cond (\f$J/kg\f$) + real(kind=kind_phys),parameter:: con_hvap =2.5000e+6 +!> lat heat H2O fusion (\f$J/kg\f$) + real(kind=kind_phys),parameter:: con_hfus =3.3358e+5 +!> pres at H2O 3pt (Pa) + real(kind=kind_phys),parameter:: con_psat =6.1078e+2 +!> temp at 0C (K) + real(kind=kind_phys),parameter:: con_t0c =2.7315e+2 +!> temp at H2O 3pt (K) + real(kind=kind_phys),parameter:: con_ttp =2.7316e+2 +!> temp freezing sea (K) + real(kind=kind_phys),parameter:: con_tice =2.7120e+2 +!> joules per calorie + real(kind=kind_phys),parameter:: con_jcal =4.1855E+0 +!> sea water reference density (\f$kg/m^{3}\f$) + real(kind=kind_phys),parameter:: con_rhw0 =1022.0 +!> min q for computing precip type + real(kind=kind_phys),parameter:: con_epsq =1.0E-12 + +!> \name Secondary constants + + real(kind=kind_phys),parameter:: con_rocp =con_rd/con_cp + real(kind=kind_phys),parameter:: con_cpor =con_cp/con_rd + real(kind=kind_phys),parameter:: con_rog =con_rd/con_g + real(kind=kind_phys),parameter:: con_fvirt =con_rv/con_rd-1. + real(kind=kind_phys),parameter:: con_eps =con_rd/con_rv + real(kind=kind_phys),parameter:: con_epsm1 =con_rd/con_rv-1. + real(kind=kind_phys),parameter:: con_dldt =con_cvap-con_cliq + real(kind=kind_phys),parameter:: con_xpona =-con_dldt/con_rv + real(kind=kind_phys),parameter:: con_xponb =-con_dldt/con_rv+con_hvap/(con_rv*con_ttp) + +!> \name Other Physics/Chemistry constants (source: 2002 CODATA) + +!> speed of light (\f$m/s\f$) + real(kind=kind_phys),parameter:: con_c =2.99792458e+8 +!> planck constant (\f$J/s\f$) + real(kind=kind_phys),parameter:: con_plnk =6.6260693e-34 +!> boltzmann constant (\f$J/K\f$) + real(kind=kind_phys),parameter:: con_boltz =1.3806505e-23 +!> stefan-boltzmann (\f$W/m^{2}/K^{4}\f$) + real(kind=kind_phys),parameter:: con_sbc =5.670400e-8 +!> avogadro constant (\f$mol^{-1}\f$) + real(kind=kind_phys),parameter:: con_avgd =6.0221415e23 +!> vol of ideal gas at 273.15K, 101.325kPa (\f$m^{3}/mol\f$) + real(kind=kind_phys),parameter:: con_gasv =22413.996e-6 +! real(kind=kind_phys),parameter:: con_amd =28.970 ! molecular wght of dry air (g/mol) +!> molecular wght of dry air (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amd =28.9644 +!> molecular wght of water vapor (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amw =18.0154 +!> molecular wght of o3 (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amo3 =47.9982 +! real(kind=kind_phys),parameter:: con_amo3 =48.0 ! molecular wght of o3 (g/mol) +!> molecular wght of co2 (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amco2 =44.011 +!> molecular wght of o2 (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amo2 =31.9999 +!> molecular wght of ch4 (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amch4 =16.043 +!> molecular wght of n2o (\f$g/mol\f$) + real(kind=kind_phys),parameter:: con_amn2o =44.013 +!> temperature the H.G.Nuc. ice starts + real(kind=kind_phys), parameter:: con_thgni =-38.15 + +!> minimum aerosol concentration + real(kind=kind_phys),parameter:: qamin = 1.e-16_kind_phys + + +!> \name Miscellaneous physics related constants (Moorthi - Jul 2014) + +! integer, parameter :: max_lon=16000, max_lat=8000, min_lon=192, min_lat=94 +! integer, parameter :: max_lon=5000, max_lat=2500, min_lon=192, min_lat=94 ! current opr + integer, parameter :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 ! current opr +! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999 ! current opr + real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9999999 ! new +! real(kind=kind_phys), parameter:: rlapse = 0.65e-2, rhc_max = 0.9900 + real(kind=kind_phys), parameter:: cb2mb = 10.0, pa2mb = 0.01 + + real(kind=kind_phys) :: dxmax, dxmin, dxinv + +!........................................! + end module physcons ! +!========================================! +!! @} diff --git a/gsmphys/physparam.f b/gsmphys/physparam.f new file mode 100755 index 00000000..7e5ac8a6 --- /dev/null +++ b/gsmphys/physparam.f @@ -0,0 +1,309 @@ +!> \file physparam.f +!! This file contains module physparam. + +! ========================================================== !!!!! +! module physparam description !!!!! +! ========================================================== !!!!! +! ! +! This module defines commonly used control variables/parameters ! +! in physics related programs. ! +! ! +! Section 1 contains control variables defined in the form of ! +! parameter. They are pre-determined choices and not adjustable ! +! during model's run-time. ! +! ! +! Section 2 contains control variables defined as module variables.! +! They are more flexible to be changed during run-time by either ! +! through input namelist, or through model environment condition. ! +! They are preassigned here as the default values. ! +! ! +!!!!! ========================================================== !!!!! + +!> \ingroup rad +!> \defgroup physparam physparam +!! @{ +!> This module defines commonly used control variables and parameters +!! in physics related programs. +!! +!! Those variables are grouped together in accordance with functionaity +!! and are given brief descriptions and value specifications. There are +!! two types of attributes (parameters vs. save) designated for the +!! control variables. Those with a "parameter" attribute are prescribed +!! with a preferred option value, while the ones with a "save" attribute +!! are given a default value but could be changed at the model's +!! execution-time (usually through an input of name-list file or through +!! run scripts). +!========================================! + module physparam ! +!........................................! +! +! implicit none + +! --- ... define kind parameters here + +! ** if already exist, use the module containing kind definitions + use machine + +! ** otherwise, define kind parameter here +! implicit none +! integer, public, parameter :: kind_io4 = 4 +! integer, public, parameter :: kind_io8 = 8 +! integer, public, parameter :: kind_phys= selected_real_kind(13,60) ! the '60' maps to 64-bit real +! ..... + +! implicit none +! + public + +!================================================================================== +! Section - 1 - +! control flags are pre-set as run-time non-adjuztable parameters. +!================================================================================== + +! ............................................. ! +!> \name -1.1- Control flags for SW radiation +! ............................................. ! + +!> SW heating rate unit control flag: =1:k/day; =2:k/second. + integer,parameter :: iswrate = 2 + +!> SW minor gases effect control flag (CH4 and O2): =0:no; =1:yes. +!!\n =0: minor gases' effects are not included in calculations +!!\n =1: minor gases' effects are included in calculations + integer,parameter :: iswrgas = 1 + +!> SW optical property for liquid clouds +!!\n =0:input cld opt depth, ignoring iswcice setting +!!\n =1:cloud optical property scheme based on Hu and Stamnes(1993) \cite +!! hu_and_stamnes_1993 method + integer,save :: iswcliq = 1 + +!> SW optical property for ice clouds (only iswcliq>0) +!!\n =1:optical property scheme based on Ebert and Curry (1992) +!! \cite ebert_and_curry_1992 method +!!\n =2:optical property scheme based on Streamer v3.0 +!! \cite key_2002 method +!!\n =3:optical property scheme based on Fu's method (1996) +!! \cite fu_1996 method + integer,save :: iswcice = 3 + +!> SW control flag for scattering process approximation +!!\n =1:two-stream delta-eddington (Joseph et al. 1976 +!! \cite joseph_et_al_1976) +!!\n =2:two-stream PIFM (Zdunkowski et al. 1980 +!! \cite zdunkowski_et_al_1980) +!!\n =3:discrete ordinates (Liou, 1973 +!! \cite liou_1973) + integer,parameter :: iswmode = 2 + +! ............................................. ! +!> \name -1.2- Control flags for LW radiation +! ............................................. ! + +!> LW heating rate unit: =1:k/day; =2:k/second. + integer,parameter :: ilwrate = 2 + +!> LW minor gases effect control flag (CH4,N2O,O2,and some CFCs): +!!\n =0: minor gases' effects are not included in calculations +!!\n =1: minor gases' effects are included in calculations + integer,parameter :: ilwrgas = 1 + +!> LW optical property scheme for liquid clouds +!!\n =0:input cloud optical properties directly, not computed within +!!\n =1:input cwp,rew, use Hu and Stamnes(1993) +!! \cite hu_and_stamnes_1993 method + integer,save :: ilwcliq = 1 + +!> LW optical property scheme for ice clouds (only ilwcliq>0) +!!\n =1:optical property scheme based on Ebert and Curry (1992) +!! \cite ebert_and_curry_1992 method +!!\n =2:optical property scheme based on Streamer v3 +!! \cite key_2002 method +!!\n =3:optical property scheme use Fu's method (1998) +!! \cite fu_et_al_1998 method + integer,save :: ilwcice = 3 + +! ............................................. ! +!>\name -1.3- Control flag for LW aerosol property + +!> selects 1 band or multi bands for LW aerosol properties +!!\n =.true.:aerosol properties calculated in 1 broad LW band +!!\n =.false.:aerosol properties calculated in all LW bands +!!\n variable names diff in Opr CFS + logical,parameter :: lalw1bd =.false. + +!================================================================================== +! Section - 2 - +! values of control flags might be re-set in initialization subroutines +! (may be adjusted at run time based on namelist input or run condition) +!================================================================================== + +! ............................................. ! +!>\name -2.1- For module radiation_astronomy +! ............................................. ! + +!> solar constant scheme control flag +!!\n =0:fixed value=1366.0\f$W/m^2\f$(old standard) +!!\n =10:fixed value=1360.8\f$W/m^2\f$(new standard) +!!\n =1:NOAA ABS-scale TSI table (yearly) w 11-yr cycle approx +!!\n =2:NOAA TIM-scale TSI table (yearly) w 11-yr cycle approx +!!\n =3:CMIP5 TIM-scale TSI table (yearly) w 11-yr cycle approx +!!\n =4:CMIP5 TIM-scale TSI table (monthly) w 11-yr cycle approx +!!\n see ISOL in run scripts: Opr GFS=2; Opr CFS=1 + integer, save :: isolar = 0 + +!> external solar constant data table,solarconstant_noaa_a0.txt + character, save :: solar_file*32 +! data solar_file / 'solarconstantdata.txt ' / + data solar_file / 'INPUT/solarconstant_noaa_a0.txt ' / + +! ............................................. ! +!> \name -2.2- For module radiation_aerosols +! ............................................. ! + +!> aerosol model scheme control flag +!!\n =0:seasonal global distributed OPAC aerosol climatology +!!\n =1:monthly global distributed GOCART aerosol climatology +!!\n =2: GOCART prognostic aerosol model +!!\n Opr GFS=0; Opr CFS=n/a + integer, save :: iaermdl = 0 +!> aerosol effect control flag +!!\n 3-digit flag 'abc': +!!\n a-stratospheric volcanic aerols +!!\n b-tropospheric aerosols for LW +!!\n c-tropospheric aerosols for SW +!!\n =0:aerosol effect is not included; =1:aerosol effect is included +!!\n Opr GFS/CFS =111; see IAER in run scripts + integer, save :: iaerflg = 0 +!> LW aerosols effect control flag +!!\n =.true.:aerosol effect is included in LW radiation +!!\n =.false.:aerosol effect is not included in LW radiation + logical, save :: lalwflg = .true. +!> SW aerosols effect control flag +!!\n =.true.:aerosol effect is included in SW radiation +!!\n =.false.:aerosol effect is not included in SW radiation + logical, save :: laswflg = .true. +!> stratospheric volcanic aerosol effect flag +!!\n =.true.:historical events of stratosphere volcanic aerosol effect +!! is included radiation (limited by data availability) +!!\n =.false.:volcanic aerosol effect is not included in radiation + logical, save :: lavoflg = .true. +!> external aerosols data file: aerosol.dat + character, save :: aeros_file*32 +! data aeros_file / 'climaeropac_global.txt ' / + data aeros_file / 'INPUT/aerosol.dat ' / + +! ............................................. ! +!> \name -2.3- For module radiation_gases +! ............................................. ! + +!> co2 data source control flag +!!\n =0:prescribed value(380 ppmv) +!!\n =1:yearly global averaged annual mean from observations +!!\n =2:monthly 15 degree horizontal resolution from observations +!!\n Opr GFS/CFS=2; see ICO2 in run scripts + integer, save :: ico2flg = 0 +!> controls external data at initial time and data usage during +!! forecast time +!!\n =-2:as in 0,but superimpose with seasonal climatology cycle +!!\n =-1:use user data,no extrapolation in overtime +!!\n =0:use IC time to select data,no extrapolation in overtime +!!\n =1:use forecast time to select data,extrapolate when necessary +!!\n =yyyy0:use yyyy year of data, no extrapolation +!!\n =yyyy1:use yyyy year of data, extrapolate when necessary +!!\n Opr GFS/CFS=1; see ICTM in run scripts + integer, save :: ictmflg = 0 +!> ozone data source control flag +!!\n =0:use seasonal climatology ozone data +!!\n >0:use prognostic ozone scheme (also depend on other model control +!! variable at initial time) + integer, save :: ioznflg = 1 +!> external co2 2d monthly obsv data table: co2historicaldata_2004.txt + character, save :: co2dat_file*32 +!> external co2 global annual mean data tb: co2historicaldata_glob.txt + character, save :: co2gbl_file*32 +!> external co2 user defined data table: co2userdata.txt + character, save :: co2usr_file*32 +!> external co2 clim monthly cycle data tb: co2monthlycyc.txt + character, save :: co2cyc_file*32 + data co2dat_file / 'INPUT/co2historicaldata_2004.txt' / !year is run-time selected + data co2gbl_file / 'INPUT/co2historicaldata_glob.txt' / + data co2usr_file / 'INPUT/co2userdata.txt ' / + data co2cyc_file / 'INPUT/co2monthlycyc.txt ' / + +! ............................................. ! +!>\name -2.4- For module radiation_clouds +! ............................................. ! + +!> cloud optical property scheme control flag +!!\n =0:use diagnostic cloud scheme for cloud cover and mean optical properties +!!\n =1:use prognostic cloud scheme for cloud cover and cloud properties + integer, save :: icldflg = 1 +!> cloud micorphysics scheme control flag +!!\n =1:modified Zhao/Carr/Sundqvist scheme (Moorthi, 2001) +!!\n =2:Ferrier microphysics scheme (Ferrier et al. 2002) +!!\n =3:as in 1 but with pdf method defined cloud cover + integer, save :: icmphys = 1 +!> cloud overlapping control flag for SW +!!\n =0:use random cloud overlapping method +!!\n =1:use maximum-random cloud overlapping method +!!\n Opr GFS/CFS=1; see IOVR_SW in run scripts + integer, save :: iovrsw = 1 +!> cloud overlapping control flag for LW +!!\n =0:use random cloud overlapping method +!!\n =1:use maximum-random cloud overlapping method +!!\n Opr GFS/CFS=1; see IOVR_LW in run scripts + integer, save :: iovrlw = 1 +!> eliminating CRICK control flag + logical, save :: lcrick =.false. +!> in-cld condensate control flag + logical, save :: lcnorm =.false. +!> precip effect on radiation flag (Ferrier microphysics) + logical, save :: lnoprec =.false. +!> shallow convetion flag + logical, save :: lsashal =.false. + +! ............................................. ! +!>\name -2.5- For module radiation_surface +! ............................................. ! + +!> surface albedo scheme control flag +!!\n =0:vegetation type based climatological albedo scheme +!!\n =1:seasonal albedo derived from MODIS measurements + integer, save :: ialbflg = 0 +!> surface emissivity scheme control flag +!!\n =0:black-body surface emissivity(=1.0) +!!\n =1:vegetation type based climatology emissivity(<1.0) +!!\n Opr GFS/CFS=1; see IEMS in run scripts + integer, save :: iemsflg = 0 + +!> external sfc emissivity data table: sfc_emissivity_idx.txt + character, save :: semis_file*32 + data semis_file / 'INPUT/sfc_emissivity_idx.txt ' / + +! ............................................. ! +!> \name -2.6- general purpose +! ............................................. ! + +!> vertical profile indexing flag + integer, save :: ivflip = 1 +!> sub-column cloud approx flag in SW radiation +!!\n =0:no McICA approximation in SW radiation +!!\n =1:use McICA with precribed permutation seeds (test mode) +!!\n =2:use McICA with randomly generated permutation seeds +!!\n Opr GFS/CFS=2; see ISUBC_SW in run scripts + integer, save :: isubcsw = 0 +!> sub-column cloud approx flag in LW radiation +!!\n =0:no McICA approximation in LW radiation +!!\n =1:use McICA with prescribed permutation seeds (test mode) +!!\n =2:use McICA with randomly generatedo +!!\n Opr GFS/CFS=2; see ISUBC_LW in run scripts + integer, save :: isubclw = 0 +!> initial permutaion seed for mcica radiation + integer, save :: ipsd0 = 0 + integer, save :: ipsdlim = 1e8 +! +!...................................! + end module physparam ! +!===================================! +!! @} diff --git a/gsmphys/precpd.f b/gsmphys/precpd.f new file mode 100644 index 00000000..9c4ac694 --- /dev/null +++ b/gsmphys/precpd.f @@ -0,0 +1,719 @@ +!> \file precpd.f +!! This file contains the subroutine that calculates precipitation +!! processes from suspended cloud water/ice + +!> \ingroup MPscheme +!> \defgroup precip Precipitation (snow or rain) Production +!! This subroutine computes the conversion from condensation to +!! precipitation (snow or rain) or evaporation of rain. +!! +!> The parameterization of precipitation is required in order to remove +!! water from the atmosphere and transport it to the ground. In the +!! scheme discussed here, simplifications in the precipitation +!! parameterization are used due to computational limitations required +!! by operational NWP models. First, consideration of particle size and +!! shape can be avoided by using the bulk parameterization method +!! introduced by Kessler (1969) \cite kessler_1969. Second, only two +!! types of precipitation, rain and snow, are considered in this +!! scheme. Third, only the most important microphysical processes +!! associated with the formation of rain and snow are included. +!! Figure 2 presents the microphysical processes considered in the +!! precipitation parameterization. +!! \image html precpd-micop.png "Figure 2: Microphysical processes simulated in the precipitation scheme " width=5cm +!! Basically, there are four types of microphysical processes +!! considered here: +!! - production of rain from cloud water +!! (\f$P_{racw}\f$, \f$P_{raut}\f$, \f$P_{sacw}\f$) +!! - production of snow from cloud ice +!! (\f$P_{saut}\f$, \f$P_{saci}\f$) +!! - melting of snow to form rain below the freezing level +!! (\f$P_{sm1}\f$, \f$P_{sm2}\f$) +!! - the evaporation of precipitation +!! (\f$E_{rr}\f$, \f$E_{rs}\f$) +!! +!! The following two equations can be used to calculate the +!! precipitation rates of rain and snow at each module level: +!!\f[ +!! P_{r}(\eta)=\frac{p_{s}-p_{t}}{g\eta_{s}}\int_{\eta}^{\eta_{t}}(P_{raut}+P_{racw}+P_{sacw}+P_{sm1}+P_{sm2}-E_{rr})d\eta +!!\f] +!! and +!!\f[ +!! P_{s}(\eta)=\frac{p_{s}-p_{t}}{g\eta_{s}}\int_{\eta}^{\eta_{t}}(P_{saut}+P_{saci}-P_{sm1}-P_{sm2}-E_{rs})d\eta +!!\f] +!! where \f$p_{s}\f$ and\f$p_{t}\f$ are the surface pressure and the +!! pressure at the top of model domain, respectively, and \f$g\f$ is +!! gravity. The implementation of the precipitation scheme also +!! includes a simplified procedure of computing \f$P_{r}\f$ +!! and \f$P_{s}\f$ (Zhao and Carr(1997) \cite zhao_and_carr_1997). +!! @{ + +!> \param[in] im horizontal number of used pts +!! \param[in] ix horizontal dimension +!! \param[in] km vertical layer dimension +!! \param[in] dt time step in seconds +!! \param[in] del pressure layer thickness (bottom to top) +!! \param[in] prsl pressure values for model layers (bottom to top) +!! \param[in,out] q specific humidity (updated in the code) +!! \param[in,out] cwm condensate mixing ratio (updated in the code) +!! \param[in,out] t temperature (updated in the code) +!! \param[out] rn precipitation over one time-step dt (m/dt) +!! \param[out] sr "snow ratio", ratio of snow to total precipitation +!! \param[out] rainp rainwater path +!! \param[in] u00k the critical value of relative humidity for +!! large-scale condensation +!! \param[in] psautco auto conversion coeff from ice to snow +!! \n = 4.0E-4; defined in module_MP_GFS.F90 +!! \param[in] prautco auto conversion coeff from cloud to rain +!! \n = 1.0E-4; defined in module_MP_GFS.F90 +!! \param[in] evpco coeff for evaporation of largescale rain +!! \n = 2.0E-5; defined in module_MP_GFS.F90 +!! \param[in] wminco coeff for water and ice minimum threshold to +!! conversion from condensate to precipitation +!! \n = \1.0E-5, 1.0E-5\; defined in module_MP_GFS.F90 +!! \param[in] lprnt logical print flag +!! \param[in] jpr check print point for debugging +!> \section general General Algorithm +!> @{ + subroutine precpd (im,ix,km,dt,del,prsl,q,cwm,t,rn,sr & + &, rainp,u00k,psautco,prautco,evpco,wminco & + &, lprnt,jpr) +! +! +! ****************************************************************** +! * * +! * subroutine for precipitation processes * +! * from suspended cloud water/ice * +! * * +! ****************************************************************** +! * * +! * originally created by q. zhao jan. 1995 * +! * ------- * +! * modified and rewritten by shrinivas moorthi oct. 1998 * +! * ----------------- * +! * and hua-lu pan * +! * ---------- * +! * * +! * references: * +! * * +! * zhao and carr (1997), monthly weather review (august) * +! * sundqvist et al., (1989) monthly weather review. (august) * +! * chuang 2013, modify sr to define frozen precipitation fraction* +! ****************************************************************** +! +! in this code vertical indexing runs from surface to top of the +! model +! +! argument list: +! -------------- +! im : inner dimension over which calculation is made +! ix : maximum inner dimension +! km : number of vertical levels +! dt : time step in seconds +! del(km) : pressure layer thickness (bottom to top) +! prsl(km) : pressure values for model layers (bottom to top) +! q(ix,km) : specific humidity (updated in the code) +! cwm(ix,km) : condensate mixing ratio (updated in the code) +! t(ix,km) : temperature (updated in the code) +! rn(im) : precipitation over one time-step dt (m/dt) +!old sr(im) : index (=-1 snow, =0 rain/snow, =1 rain) +!new sr(im) : "snow ratio", ratio of snow to total precipitation +! cll(ix,km) : cloud cover +!hchuang rn(im) unit in m per time step +! precipitation rate conversion 1 mm/s = 1 kg/m2/s +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, hvap => con_hvap, hfus => con_hfus + &, ttp => con_ttp, cp => con_cp + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! include 'constant.h' +! + real (kind=kind_phys) g, h1, h1000 + &, d00 + &, elwv, eliv, row + &, epsq, eliw + &, rcp, rrow + parameter (g=grav, h1=1.e0, h1000=1000.0 + &, d00=0.e0 + &, elwv=hvap, eliv=hvap+hfus, row=1.e3 + &, epsq=2.e-12 + &, eliw=eliv-elwv, rcp=h1/cp, rrow=h1/row) +! + real(kind=kind_phys), parameter :: cons_0=0.0, cons_p01=0.01 + &, cons_20=20.0 + &, cons_m30=-30.0, cons_50=50.0 +! + integer im, ix, km, jpr + real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km) & + &, del(ix,km), prsl(ix,km) & + &, rn(im), sr(im) & + &, dt & + &, rainp(im,km), rnp(im), & + & psautco(im), prautco(im), evpco, wminco(2) +! +! + real (kind=kind_phys) err(im), ers(im), precrl(im) & + &, precsl(im), precrl1(im), precsl1(im) & + &, rq(im), condt(im) & + &, conde(im), rconde(im), tmt0(im) & + &, wmin(im,km), wmink(im), pres(im) & + &, wmini(im,km), ccr(im) & + &, tt(im), qq(im), ww(im) & + &, u00k(im,km) & + &, zaodt + real (kind=kind_phys) cclim(km) +! + integer iw(im,km), ipr(im), iwl(im), iwl1(im) +! + logical comput(im) + logical lprnt +! + real (kind=kind_phys) ke, rdt, us, climit, cws, csm1 + &, crs1, crs2, cr, aa2, dtcp, c00, cmr + &, tem, c1, c2, wwn +! &, tem, c1, c2, u00b, u00t, wwn + &, precrk, precsk, pres1, qk, qw, qi + &, qint, fiw, wws, cwmk, expf + &, psaut, psaci, amaxcm, tem1, tem2 + &, tmt0k, psm1, psm2, ppr + &, rprs, erk, pps, sid, rid, amaxps + &, praut, fi, qc, amaxrq, rqkll + integer i, k, ihpr, n +! +!-----------------------preliminaries --------------------------------- +! +! do k=1,km +! do i=1,im +! cll(i,k) = 0.0 +! enddo +! enddo +! + rdt = h1 / dt +! ke = 2.0e-5 ! commented on 09/10/99 -- opr value +! ke = 2.0e-6 +! ke = 1.0e-5 +!!! ke = 5.0e-5 +!! ke = 7.0e-5 + ke = evpco +! ke = 7.0e-5 + us = h1 + climit = 1.0e-20 + cws = 0.025 +! + zaodt = 800.0 * rdt +! + csm1 = 5.0000e-8 * zaodt + crs1 = 5.00000e-6 * zaodt + crs2 = 6.66600e-10 * zaodt + cr = 5.0e-4 * zaodt + aa2 = 1.25e-3 * zaodt +! + ke = ke * sqrt(rdt) +! ke = ke * sqrt(zaodt) +! + dtcp = dt * rcp +! +! c00 = 1.5e-1 * dt +! c00 = 10.0e-1 * dt +! c00 = 3.0e-1 * dt !05/09/2000 +! c00 = 1.0e-4 * dt !05/09/2000 +! c00 = prautco * dt !05/09/2000 + cmr = 1.0 / 3.0e-4 +! cmr = 1.0 / 5.0e-4 +! c1 = 100.0 + c1 = 300.0 + c2 = 0.5 +! +! +!--------calculate c0 and cmr using lc at previous step----------------- +! + do k=1,km + do i=1,im + tem = (prsl(i,k)*0.00001) +! tem = sqrt(tem) + iw(i,k) = 0.0 +! wmin(i,k) = 1.0e-5 * tem +! wmini(i,k) = 1.0e-5 * tem ! testing for ras +! + + wmin(i,k) = wminco(1) * tem + wmini(i,k) = wminco(2) * tem + + + rainp(i,k) = 0.0 + + enddo + enddo + do i=1,im +! c0(i) = 1.5e-1 +! cmr(i) = 3.0e-4 +! + iwl1(i) = 0 + precrl1(i) = d00 + precsl1(i) = d00 + comput(i) = .false. + rn(i) = d00 + sr(i) = d00 + ccr(i) = d00 +! + rnp(i) = d00 + enddo +!> -# Select columns where rain can be produced, where +!!\f[ +!! cwm > \min (wmin, wmini) +!!\f] +!! where the cloud water and ice conversion threshold: +!! \f[ +!! wmin=wminco(1)\times prsl\times 10^{-5} +!! \f] +!! \f[ +!! wmini=wminco(2)\times prsl\times 10^{-5} +!! \f] + +!------------select columns where rain can be produced-------------- + do k=1, km-1 + do i=1,im + tem = min(wmin(i,k), wmini(i,k)) + if (cwm(i,k) > tem) comput(i) = .true. + enddo + enddo + ihpr = 0 + do i=1,im + if (comput(i)) then + ihpr = ihpr + 1 + ipr(ihpr) = i + endif + enddo +!*********************************************************************** +!-----------------begining of precipitation calculation----------------- +!*********************************************************************** +! do k=km-1,2,-1 + do k=km,1,-1 + do n=1,ihpr + precrl(n) = precrl1(n) + precsl(n) = precsl1(n) + err (n) = d00 + ers (n) = d00 + iwl (n) = 0 +! + i = ipr(n) + tt(n) = t(i,k) + qq(n) = q(i,k) + ww(n) = cwm(i,k) + wmink(n) = wmin(i,k) + pres(n) = prsl(i,k) +! + precrk = max(cons_0, precrl1(n)) + precsk = max(cons_0, precsl1(n)) + wwn = max(ww(n), climit) +! if (wwn .gt. wmink(n) .or. (precrk+precsk) .gt. d00) then + if (wwn > climit .or. (precrk+precsk) > d00) then + comput(n) = .true. + else + comput(n) = .false. + endif + enddo +! +! es(1:ihpr) = fpvs(tt(1:ihpr)) + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + conde(n) = (dt/g) * del(i,k) + condt(n) = conde(n) * rdt + rconde(n) = h1 / conde(n) + qk = max(epsq, qq(n)) + tmt0(n) = tt(n) - 273.16 + wwn = max(ww(n), climit) +! +! pl = pres(n) * 0.01 +! call qsatd(tt(n), pl, qc) +! rq(n) = max(qq(n), epsq) / max(qc, 1.0e-10) +! rq(n) = max(1.0e-10, rq(n)) ! -- relative humidity--- +! +! the global qsat computation is done in pa + pres1 = pres(n) +! qw = es(n) + qw = min(pres1, fpvs(tt(n))) + qw = eps * qw / (pres1 + epsm1 * qw) + qw = max(qw,epsq) +! +! tmt15 = min(tmt0(n), cons_m15) +! ai = 0.008855 +! bi = 1.0 +! if (tmt0(n) .lt. -20.0) then +! ai = 0.007225 +! bi = 0.9674 +! endif +! qi = qw * (bi + ai*min(tmt0(n),cons_0)) +! qint = qw * (1.-0.00032*tmt15*(tmt15+15.)) +! + qi = qw + qint = qw +! if (tmt0(n).le.-40.) qint = qi +! +!-------------------ice-water id number iw------------------------------ +!> -# Compute ice-water identification number IW (see algorithm in +!! \ref condense). + if(tmt0(n) < -15.) then + fi = qk - u00k(i,k)*qi + if(fi > d00 .or. wwn > climit) then + iwl(n) = 1 + else + iwl(n) = 0 + endif +! endif + elseif (tmt0(n) >= 0.) then + iwl(n) = 0 +! +! if(tmt0(n).lt.0.0.and.tmt0(n).ge.-15.0) then + else + iwl(n) = 0 + if(iwl1(n) == 1 .and. wwn > climit) iwl(n) = 1 + endif +! +! if(tmt0(n).ge.0.) then +! iwl(n) = 0 +! endif +!----------------the satuation specific humidity------------------------ + fiw = float(iwl(n)) + qc = (h1-fiw)*qint + fiw*qi +!----------------the relative humidity---------------------------------- + if(qc <= 1.0e-10) then + rq(n) = d00 + else + rq(n) = qk / qc + endif +!----------------cloud cover ratio ccr---------------------------------- +!> -# Calculate cloud fraction \f$b\f$ (see algorithm in \ref condense) + if(rq(n) < u00k(i,k)) then + ccr(n) = d00 + elseif(rq(n) >= us) then + ccr(n) = us + else + rqkll = min(us,rq(n)) + ccr(n) = h1-sqrt((us-rqkll)/(us-u00k(i,k))) + endif +! + endif + enddo +!-------------------ice-water id number iwl------------------------------ +! do n=1,ihpr +! if (comput(n) .and. (ww(n) .gt. climit)) then +! if (tmt0(n) .lt. -15.0 +! * .or. (tmt0(n) .lt. 0.0 .and. iwl1(n) .eq. 1)) +! * iwl(n) = 1 +! cll(ipr(n),k) = 1.0 ! cloud cover! +! cll(ipr(n),k) = min(1.0, ww(n)*cclim(k)) ! cloud cover! +! endif +! enddo +! +!> -# Precipitation production by auto conversion and accretion +!! - The autoconversion of cloud ice to snow (\f$P_{saut}\f$) is simulated +!! using the equation from Lin et al. (1983) \cite lin_et_al_1983 +!!\f[ +!! P_{saut}=a_{1}(cwm-wmini) +!!\f] +!! Since snow production in this process is caused by the increase in +!! size of cloud ice particles due to depositional growth and +!! aggregation of small ice particles, \f$P_{saut}\f$ is a function of +!! temperature as determined by coefficient \f$a_{1}\f$, given by +!! \f[ +!! a_{1}=psautco \times dt \times exp\left[ 0.025\left(T-273.15\right)\right] +!! \f] +!! +!! - The accretion of cloud ice by snow (\f$P_{saci}\f$) in the +!! regions where cloud ice exists is simulated by +!!\f[ +!! P_{saci}=C_{s}cwm P_{s} +!!\f] +!! where \f$P_{s}\f$ is the precipitation rate of snow. The collection +!! coefficient \f$C_{s}\f$ is a function of temperature since the open +!! structures of ice crystals at relative warm temperatures are more +!! likely to stick, given a collision, than crystals of other shapes +!! (Rogers 1979 \cite rogers_1979). Above the freezing level, +!! \f$C_{s}\f$ is expressed by +!!\f[ +!! C_{s}=c_{1}exp\left[ 0.025\left(T-273.15\right)\right] +!!\f] +!! where \f$c_{1}=1.25\times 10^{-3} m^{2}kg^{-1}s^{-1}\f$ are used. +!! \f$C_{s}\f$ is set to zero below the freezing level. +!! +!--- precipitation production -- auto conversion and accretion +! + do n=1,ihpr + if (comput(n) .and. ccr(n) > 0.0) then + wws = ww(n) + cwmk = max(cons_0, wws) + i = ipr(n) +! amaxcm = max(cons_0, cwmk - wmink(n)) + if (iwl(n) == 1) then ! ice phase + amaxcm = max(cons_0, cwmk - wmini(i,k)) + expf = dt * exp(0.025*tmt0(n)) + psaut = min(cwmk, psautco(i)*expf*amaxcm) + ww(n) = ww(n) - psaut + cwmk = max(cons_0, ww(n)) +! cwmk = max(cons_0, ww(n)-wmini(i,k)) + psaci = min(cwmk, aa2*expf*precsl1(n)*cwmk) + + ww(n) = ww(n) - psaci + precsl(n) = precsl(n) + (wws - ww(n)) * condt(n) + else ! liquid water +! +!> - Following Sundqvist et al. (1989) \cite sundqvist_et_al_1989, +!! the autoconversion of cloud water to rain (\f$P_{raut}\f$) can be +!! parameterized from the cloud water mixing ratio \f$m\f$ and cloud +!! coverage \f$b\f$, that is, +!!\f[ +!! P_{raut}=(prautco \times dt )\times (cwm-wmin)\left\{1-exp[-(\frac{cwm-wmin}{m_{r}b})^{2}]\right\} +!!\f] +!! where \f$m_{r}\f$ is \f$3.0\times 10^{-4}\f$. +! for using sundqvist precip formulation of rain +! + amaxcm = max(cons_0, cwmk - wmink(n)) +!! amaxcm = cwmk + tem1 = precsl1(n) + precrl1(n) + tem2 = min(max(cons_0, 268.0-tt(n)), cons_20) + tem = (1.0+c1*sqrt(tem1*rdt)) * (1+c2*sqrt(tem2)) +! + tem2 = amaxcm * cmr * tem / max(ccr(n),cons_p01) + tem2 = min(cons_50, tem2*tem2) +! praut = c00 * tem * amaxcm * (1.0-exp(-tem2)) + praut = (prautco(i)*dt) * tem * amaxcm + & * (1.0-exp(-tem2)) + praut = min(praut, cwmk) + ww(n) = ww(n) - praut +! +!> - Calculate the accretion of cloud water by rain \f$P_{racw}\f$, +!! can be expressed using the cloud mixing ratio \f$cwm\f$ and rainfall +!! rate \f$P_{r}\f$: +!!\f[ +!! P_{saci}=C_{s}cwmP_{r} +!!\f] +!! where \f$C_{r}=5.0\times10^{-4}m^{2}kg^{-1}s{-1}\f$ is the +!! collection coeffiecient. Note that this process is not included in +!! current operational physcics. +! below is for zhao's precip formulation (water) +! +! amaxcm = max(cons_0, cwmk - wmink(n)) +! praut = min(cwmk, c00*amaxcm*amaxcm) +! ww(n) = ww(n) - praut +! +! cwmk = max(cons_0, ww(n)) +! tem1 = precsl1(n) + precrl1(n) +! pracw = min(cwmk, cr*dt*tem1*cwmk) +! ww(n) = ww(n) - pracw +! + precrl(n) = precrl(n) + (wws - ww(n)) * condt(n) +! +!hchuang code change [+1l] : add record to record information in vertical +! turn rnp in unit of ww (cwm and q, kg/kg ???) + rnp(n) = rnp(n) + (wws - ww(n)) + endif + endif + enddo +!> -# Evaporation of precipitation (\f$E_{rr}\f$ and \f$E_{rs}\f$) +!!\n Evaporation of precipitation is an important process that moistens +!! the layers below cloud base. Through this process, some of the +!! precipitating water is evaporated back to the atmosphere and the +!! precipitation efficiency is reduced. +!! - Evaporation of rain is calculated using the equation (Sundqvist +!! 1988 \cite sundqvist_1988): +!!\f[ +!! E_{rr}= evpco \times (u-f)(P_{r})^{\beta} +!!\f] +!! where \f$u\f$ is u00k, \f$f\f$ is the relative humidity. +!! \f$\beta = 0.5\f$ are empirical parameter. +!! - Evaporation of snow is calculated using the equation: +!!\f[ +!! E_{rs}=[C_{rs1}+C_{rs2}(T-273.15)](\frac{u-f}{u})P_{s} +!!\f] +!! where \f$C_{rs1}=5\times 10^{-6}m^{2}kg^{-1}s^{-1}\f$ and +!! \f$C_{rs2}=6.67\times 10^{-10}m^{2}kg^{-1}K^{-1}s^{-1}\f$. The +!! evaporation of melting snow below the freezing level is ignored in +!! this scheme because of the difficulty in the latent heat treatment +!! since the surface of a melting snowflake is usually covered by a +!! thin layer of liquid water. +! +!-----evaporation of precipitation------------------------- +!**** err & ers positive--->evaporation-- negtive--->condensation +! + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + qk = max(epsq, qq(n)) + tmt0k = max(cons_m30, tmt0(n)) + precrk = max(cons_0, precrl(n)) + precsk = max(cons_0, precsl(n)) + amaxrq = max(cons_0, u00k(i,k)-rq(n)) * conde(n) +!---------------------------------------------------------------------- +! increase the evaporation for strong/light prec +!---------------------------------------------------------------------- + ppr = ke * amaxrq * sqrt(precrk) +! ppr = ke * amaxrq * sqrt(precrk*rdt) + if (tmt0(n) .ge. 0.) then + pps = 0. + else + pps = (crs1+crs2*tmt0k) * amaxrq * precsk / u00k(i,k) + end if +!---------------correct if over-evapo./cond. occurs-------------------- + erk=precrk+precsk + if(rq(n).ge.1.0e-10) erk = amaxrq * qk * rdt / rq(n) + if (ppr+pps .gt. abs(erk)) then + rprs = erk / (precrk+precsk) + ppr = precrk * rprs + pps = precsk * rprs + endif + ppr = min(ppr, precrk) + pps = min(pps, precsk) + err(n) = ppr * rconde(n) + ers(n) = pps * rconde(n) + precrl(n) = precrl(n) - ppr +!hchuang code change [+1l] : add record to record information in vertical +! use err for kg/kg/dt not the ppr (mm/dt=kg/m2/dt) +! + rnp(n) = rnp(n) - err(n) +! + precsl(n) = precsl(n) - pps + endif + enddo +!> -# Melting of snow (\f$P_{sm1}\f$ and \f$P_{sm2}\f$) +!!\n In this scheme, we allow snow melting to take place in certain +!! temperature regions below the freezing level in two ways. In both +!! cases, the melted snow is assumed to become raindrops. +!! - One is the continuous melting of snow due to the increase in +!! temperature as it falls down through the freezing level. This +!! process is parameterized as a function of temperature and snow +!! precipitation rate, that is, +!!\f[ +!! P_{sm1}=C_{sm}(T-273.15)^{2}P_{s} +!!\f] +!! where \f$C_{sm}=5\times 10^{-8}m^{2}kg^{-1}K^{-2}s^{-1}\f$ +!! cause the falling snow to melt almost completely before it reaches +!! the \f$T=278.15 K\f$ level. +!! - Another is the immediate melting of melting snow by collection of +!! the cloud water below the freezing level. In order to calculate the +!! melting rate, the collection rate of cloud water by melting snow is +!! computed first. Similar to the collection of cloud water by rain, +!! the collection of cloud water by melting snow can be parameterized +!! to be proportional to the cloud water mixing ratio \f$m\f$ and the +!! precipitation rate of snow \f$P_{s}\f$: +!!\f[ +!! P_{sacw}=C_{r}cwmP_{s} +!!\f] +!! where \f$C_{r}\f$ is the collection coefficient, +!! \f$C_{r}=5.0\times 10^{-4}m^{2}kg^{-1}s^{-1}\f$ . The melting rate +!! of snow then can be computed from +!!\f[ +!! P_{sm2}=C_{ws}P_{sacw} +!!\f] +!! where \f$C_{ws}=0.025\f$. +!--------------------melting of the snow-------------------------------- + do n=1,ihpr + if (comput(n)) then + if (tmt0(n) .gt. 0.) then + amaxps = max(cons_0, precsl(n)) + psm1 = csm1 * tmt0(n) * tmt0(n) * amaxps + psm2 = cws * cr * max(cons_0, ww(n)) * amaxps + ppr = (psm1 + psm2) * conde(n) + if (ppr .gt. amaxps) then + ppr = amaxps + psm1 = amaxps * rconde(n) + endif + precrl(n) = precrl(n) + ppr +! +!hchuang code change [+1l] : add record to record information in vertical +! turn ppr (mm/dt=kg/m2/dt) to kg/kg/dt -> ppr/air density (kg/m3) + rnp(n) = rnp(n) + ppr * rconde(n) +! + precsl(n) = precsl(n) - ppr + else + psm1 = d00 + endif +! +!---------------update t and q------------------------------------------ +!> - Update t and q. +!!\f[ +!! t=t-\frac{L}{C_{p}}(E_{rr}+E_{rs}+P_{sm1})\times dt +!!\f] +!!\f[ +!! q=q+(E_{rr}+E_{rs})\times dt +!!\f] + + tt(n) = tt(n) - dtcp * (elwv*err(n)+eliv*ers(n)+eliw*psm1) + qq(n) = qq(n) + dt * (err(n)+ers(n)) + endif + enddo +! + do n=1,ihpr + iwl1(n) = iwl(n) + precrl1(n) = max(cons_0, precrl(n)) + precsl1(n) = max(cons_0, precsl(n)) + i = ipr(n) + t(i,k) = tt(n) + q(i,k) = qq(n) + cwm(i,k) = ww(n) + iw(i,k) = iwl(n) +!hchuang code change [+1l] : add record to record information in vertical +! rnp = precrl1*rconde(n) unit in kg/kg/dt +! + rainp(i,k) = rnp(n) + enddo +! +! move water from vapor to liquid should the liquid amount be negative +! + do i = 1, im + if (cwm(i,k) < 0.) then + tem = q(i,k) + cwm(i,k) + if (tem >= 0.0) then + q(i,k) = tem + t(i,k) = t(i,k) - elwv * rcp * cwm(i,k) + cwm(i,k) = 0. + elseif (q(i,k) > 0.0) then + cwm(i,k) = tem + t(i,k) = t(i,k) + elwv * rcp * q(i,k) + q(i,k) = 0.0 + endif + endif + enddo +! + enddo ! k loop ends here! +!********************************************************************** +!-----------------------end of precipitation processes----------------- +!********************************************************************** +! +!> -# Compute precipitation at surface (\f$rn\f$)and determine +!! fraction of frozen precipitation (\f$sr\f$). +!!\f[ +!! rn= (P_{r}(\eta_{sfc})+P_{s}(\eta_{sfc}))/10^3 +!!\f] +!!\f[ +!! sr=\frac{P_{s}(\eta_{sfc})}{P_{s}(\eta_{sfc})+P_{r}(\eta_{sfc})} +!!\f] + do n=1,ihpr + i = ipr(n) + rn(i) = (precrl1(n) + precsl1(n)) * rrow ! precip at surface +! +!----sr=1 if sfc prec is rain ; ----sr=-1 if sfc prec is snow +!----sr=0 for both of them or no sfc prec +! +! rid = 0. +! sid = 0. +! if (precrl1(n) .ge. 1.e-13) rid = 1. +! if (precsl1(n) .ge. 1.e-13) sid = -1. +! sr(i) = rid + sid ! sr=1 --> rain, sr=-1 -->snow, sr=0 -->both +! chuang, june 2013: change sr to define fraction of frozen precipitation instead +! because wpc uses it in their winter experiment + + rid = precrl1(n) + precsl1(n) + if (rid < 1.e-13) then + sr(i) = 0. + else + sr(i) = precsl1(n)/rid + endif + enddo +! + return + end +!! @} +!> @} diff --git a/gsmphys/precpd_shoc.f b/gsmphys/precpd_shoc.f new file mode 100644 index 00000000..4e6ed221 --- /dev/null +++ b/gsmphys/precpd_shoc.f @@ -0,0 +1,438 @@ + subroutine precpd_shoc(im,ix,km,dt,del,prsl,q,cwm,t,rn,sr + &, rainp,u00k,psautco,prautco,evpco,wminco + &, cll,lprnt,jpr) +! +! +! Modified for SHOC by S. Moorthi - July 2015 +! +! ****************************************************************** +! * * +! * subroutine for precipitation processes * +! * from suspended cloud water/ice * +! * * +! ****************************************************************** +! * * +! * originally created by q. zhao jan. 1995 * +! * ------- * +! * modified and rewritten by shrinivas moorthi oct. 1998 * +! * ----------------- * +! * and hua-lu pan * +! * ---------- * +! * * +! * references: * +! * * +! * zhao and carr (1997), monthly weather review (august) * +! * sundqvist et al., (1989) monthly weather review. (august) * +! * chuang 2013, modify sr to define frozen precipitation fraction* +! ****************************************************************** +! +! in this code vertical indexing runs from surface to top of the +! model +! +! argument list: +! -------------- +! im : inner dimension over which calculation is made +! ix : maximum inner dimension +! km : number of vertical levels +! dt : time step in seconds +! del(km) : pressure layer thickness (bottom to top) +! prsl(km) : pressure values for model layers (bottom to top) +! q(ix,km) : specific humidity (updated in the code) +! cwm(ix,km) : condensate mixing ratio (updated in the code) +! t(ix,km) : temperature (updated in the code) +! rn(im) : precipitation over one time-step dt (m/dt) +!old sr(im) : index (=-1 snow, =0 rain/snow, =1 rain) +!new sr(im) : "snow ratio", ratio of snow to total precipitation +! cll(ix,km) : sgs cloud cover from shoc +!hchuang rn(im) unit in m per time step +! precipitation rate conversion 1 mm/s = 1 kg/m2/s +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, hvap => con_hvap, hfus => con_hfus + &, ttp => con_ttp, cp => con_cp + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + real (kind=kind_phys), parameter :: g=grav, h1=1.e0 + &, h1000=1000.0, d00=0.e0, epsq=2.e-12 + &, elwv=hvap, eliv=hvap+hfus, row=1.e3 + &, eliw=eliv-elwv, rcp=h1/cp, rrow=h1/row + &, cons_0=0.0, cons_p01=0.01, cons_20=20.0 + &, cons_m30=-30.0, cons_50=50.0 +! + &, climit=1.0e-20, cws=0.025 + &, cmr=1.0/3.0e-4, c1=300.0, c2=0.5 +! + integer im, ix, km, jpr + real (kind=kind_phys), dimension(ix,km) :: q, t, cwm, del, prsl + &, cll + real (kind=kind_phys), dimension(im,km) :: rainp +! real (kind=kind_phys), dimension(im,km) :: rainp, cll + real (kind=kind_phys), dimension(im) :: rn, sr, rnp + &, psautco, prautco + real (kind=kind_phys) dt, evpco, wminco(2) + +! + real (kind=kind_phys), dimension(im,km) :: wmin, wmini, u00k + real (kind=kind_phys), dimension(im) :: err, ers, pres + &, rconde, condt, conde + &, precrl, precsl, tt, qq + &, precrl1, precsl1, ww,rq + &, tmt0, wmink + real (kind=kind_phys) cclim(km), zaodt +! + integer iw(im,km), ipr(im), iwl(im), iwl1(im) +! + logical comput(im) + logical lprnt +! + real (kind=kind_phys) ke, rdt, us, csm1, wwn + &, crs1, crs2, cr, aa2, dtcp, c00 + &, precrk, precsk, pres1, qk, qw, qi + &, qint, fiw, wws, cwmk, expf + &, psaut, psaci, amaxcm, tem, tem1, tem2 + &, tmt0k, psm1, psm2, ppr + &, rprs, erk, pps, sid, rid, amaxps + &, praut, fi, qc, amaxrq + + integer i, k, ihpr, n +! +!-----------------------preliminaries --------------------------------- +! + rdt = h1 / dt + ke = evpco * sqrt(rdt) + us = h1 +! +! zaodt = 800.0 * rdt + zaodt = 1.0 +! + csm1 = 5.0000e-8 * zaodt + crs1 = 5.00000e-6 * zaodt + crs2 = 6.66600e-10 * zaodt + cr = 5.0e-4 * zaodt + aa2 = 1.25e-3 * zaodt +! +! + dtcp = dt * rcp +! +!--------calculate c0 and cmr using lc at previous step----------------- +! + do k=1,km + do i=1,im + tem = (prsl(i,k)*0.00001) +! tem = sqrt(tem) + iw(i,k) = 0.0 +! + wmin(i,k) = wminco(1) * tem + wmini(i,k) = wminco(2) * tem + rainp(i,k) = 0.0 + enddo + enddo + do i=1,im +! c0(i) = 1.5e-1 +! cmr(i) = 3.0e-4 +! + iwl1(i) = 0 + precrl1(i) = d00 + precsl1(i) = d00 + comput(i) = .false. + rn(i) = d00 + sr(i) = d00 +! + rnp(i) = d00 + enddo +!------------select columns where rain can be produced-------------- + do k=1, km-1 + do i=1,im + tem = min(wmin(i,k), wmini(i,k)) + if (cwm(i,k) > tem) comput(i) = .true. + enddo + enddo + ihpr = 0 + do i=1,im + if (comput(i)) then + ihpr = ihpr + 1 + ipr(ihpr) = i + endif + enddo +!*********************************************************************** +!-----------------begining of precipitation calculation----------------- +!*********************************************************************** +! do k=km-1,2,-1 + do k=km,1,-1 + do n=1,ihpr + precrl(n) = precrl1(n) + precsl(n) = precsl1(n) + err (n) = d00 + ers (n) = d00 + iwl (n) = 0 +! + i = ipr(n) + tt(n) = t(i,k) + qq(n) = q(i,k) + ww(n) = cwm(i,k) + wmink(n) = wmin(i,k) + pres(n) = prsl(i,k) +! + precrk = max(cons_0, precrl1(n)) + precsk = max(cons_0, precsl1(n)) + wwn = max(ww(n), climit) +! if (wwn > wmink(n) .or. (precrk+precsk) > d00) then + if (wwn > climit .or. (precrk+precsk) > d00) then + comput(n) = .true. + else + comput(n) = .false. + endif + enddo +! +! es(1:ihpr) = fpvs(tt(1:ihpr)) + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + conde(n) = (dt/g) * del(i,k) + condt(n) = conde(n) * rdt + rconde(n) = h1 / conde(n) + qk = max(epsq, qq(n)) + tmt0(n) = tt(n) - 273.16 + wwn = max(ww(n), climit) +! +! pl = pres(n) * 0.01 +! call qsatd(tt(n), pl, qc) +! rq(n) = max(qq(n), epsq) / max(qc, 1.0e-10) +! rq(n) = max(1.0e-10, rq(n)) ! -- relative humidity--- +! +! the global qsat computation is done in pa + pres1 = pres(n) +! qw = es(n) + qw = min(pres1, fpvs(tt(n))) + qw = max(epsq, eps * qw / (pres1 + epsm1 * qw)) +! + qi = qw + qint = qw +! if (tmt0(n).le.-40.) qint = qi +! +!-------------------ice-water id number iw------------------------------ + if(tmt0(n) < -15.) then +! if(tmt0(n) < -20.) then + fi = qk - u00k(i,k)*qi + if(fi > d00 .or. wwn > climit) then + iwl(n) = 1 + else + iwl(n) = 0 + endif + elseif (tmt0(n) >= 0.) then + iwl(n) = 0 +! + else + iwl(n) = 0 + if(iwl1(n) == 1 .and. wwn > climit) iwl(n) = 1 + endif +! +!----------------the satuation specific humidity------------------------ + fiw = float(iwl(n)) + qc = (h1-fiw)*qint + fiw*qi +!----------------the relative humidity---------------------------------- + if(qc <= 1.0e-10) then + rq(n) = d00 + else + rq(n) = qk / qc + endif +! + endif + enddo +! +!--- precipitation production -- auto conversion and accretion +! + do n=1,ihpr + i = ipr(n) + if (comput(n) .and. cll(i,k) > 0.0) then + wws = ww(n) + cwmk = max(cons_0, wws) +! amaxcm = max(cons_0, cwmk - wmink(n)) + if (iwl(n) == 1) then ! ice phase + amaxcm = max(cons_0, (cwmk-wmini(i,k))/cll(i,k)) + expf = dt * exp(0.025*tmt0(n)) + psaut = min(cwmk, psautco(i)*expf*amaxcm) + + ww(n) = ww(n) - psaut + cwmk = max(cons_0, ww(n)) + +! cwmk = max(cons_0, ww(n)-wmini(i,k)) + psaci = min(cwmk, aa2*expf*precsl1(n)*cwmk) + + ww(n) = ww(n) - psaci + + precsl(n) = precsl(n) + (wws - ww(n)) * condt(n) + else ! liquid water +! +! for using sundqvist precip formulation of rain +! + amaxcm = max(cons_0, (cwmk - wmink(n))) +!! amaxcm = cwmk + tem1 = precsl1(n) + precrl1(n) + tem2 = min(max(cons_0, 268.0-tt(n)), cons_20) + tem = (1.0+c1*sqrt(tem1*rdt)) * (1+c2*sqrt(tem2)) +! + tem2 = amaxcm * cmr * tem / max(cll(i,k),cons_p01) + tem2 = min(cons_50, tem2*tem2) +! praut = c00 * tem * amaxcm * (1.0-exp(-tem2)) + praut = (prautco(i)*dt) * tem * amaxcm + & * (1.0-exp(-tem2)) + praut = min(praut, cwmk) + ww(n) = ww(n) - praut +! +! below is for zhao's precip formulation (water) +! +! amaxcm = max(cons_0, cwmk - wmink(n)) +! praut = min(cwmk, c00*amaxcm*amaxcm) +! ww(n) = ww(n) - praut +! +! cwmk = max(cons_0, ww(n)) +! tem1 = precsl1(n) + precrl1(n) +! pracw = min(cwmk, cr*dt*tem1*cwmk) +! ww(n) = ww(n) - pracw +! + precrl(n) = precrl(n) + (wws - ww(n)) * condt(n) +! +!hchuang code change [+1l] : add record to record information in vertical +! turn rnp in unit of ww (cwm and q, kg/kg ???) + rnp(n) = rnp(n) + (wws - ww(n)) + endif + endif + enddo +! +!-----evaporation of precipitation------------------------- +!**** err & ers positive--->evaporation-- negtive--->condensation +! + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + qk = max(epsq, qq(n)) + tmt0k = max(cons_m30, tmt0(n)) + precrk = max(cons_0, precrl(n)) + precsk = max(cons_0, precsl(n)) + amaxrq = max(cons_0, u00k(i,k)-rq(n)) * conde(n) +! & * (1.0 - cll(i,k)) +!---------------------------------------------------------------------- +! increase the evaporation for strong/light prec +!---------------------------------------------------------------------- + ppr = ke * amaxrq * sqrt(precrk) +! ppr = ke * amaxrq * sqrt(precrk*rdt) + if (tmt0(n) >= 0.) then + pps = 0. + else + pps = (crs1+crs2*tmt0k) * amaxrq * precsk / u00k(i,k) + end if +!---------------correct if over-evapo./cond. occurs-------------------- + erk = precrk + precsk + if(rq(n) >= 1.0e-10) erk = amaxrq * qk * rdt / rq(n) + if (ppr+pps > abs(erk)) then + rprs = erk / (precrk+precsk) + ppr = precrk * rprs + pps = precsk * rprs + endif + ppr = min(ppr, precrk) + pps = min(pps, precsk) + err(n) = ppr * rconde(n) + ers(n) = pps * rconde(n) + precrl(n) = precrl(n) - ppr +!hchuang code change [+1l] : add record to record information in vertical +! use err for kg/kg/dt not the ppr (mm/dt=kg/m2/dt) +! + rnp(n) = rnp(n) - err(n) +! + precsl(n) = precsl(n) - pps + endif + enddo +!--------------------melting of the snow-------------------------------- + do n=1,ihpr + if (comput(n)) then + if (tmt0(n) > 0.) then + amaxps = max(cons_0, precsl(n)) + psm1 = csm1 * tmt0(n) * tmt0(n) * amaxps + psm2 = cws * cr * max(cons_0, ww(n)) * amaxps + ppr = (psm1 + psm2) * conde(n) + if (ppr > amaxps) then + ppr = amaxps + psm1 = amaxps * rconde(n) + endif + precrl(n) = precrl(n) + ppr +! +!hchuang code change [+1l] : add record to record information in vertical +! turn ppr (mm/dt=kg/m2/dt) to kg/kg/dt -> ppr/air density (kg/m3) + rnp(n) = rnp(n) + ppr * rconde(n) +! + precsl(n) = precsl(n) - ppr + else + psm1 = d00 + endif +! +!---------------update t and q------------------------------------------ + tt(n) = tt(n) - dtcp * (elwv*err(n)+eliv*ers(n)+eliw*psm1) + qq(n) = qq(n) + dt * (err(n)+ers(n)) + endif + enddo +! + do n=1,ihpr + iwl1(n) = iwl(n) + precrl1(n) = max(cons_0, precrl(n)) + precsl1(n) = max(cons_0, precsl(n)) + i = ipr(n) + t(i,k) = tt(n) + q(i,k) = qq(n) + cwm(i,k) = ww(n) + iw(i,k) = iwl(n) +!hchuang code change [+1l] : add record to record information in vertical +! rnp = precrl1*rconde(n) unit in kg/kg/dt +! + rainp(i,k) = rnp(n) + enddo +! +! move water from vapor to liquid should the liquid amount be negative +! + do i = 1, im + if (cwm(i,k) < 0.) then + tem = q(i,k) + cwm(i,k) + if (tem >= 0.0) then + q(i,k) = tem + t(i,k) = t(i,k) - elwv * rcp * cwm(i,k) + cwm(i,k) = 0. + elseif (q(i,k) > 0.0) then + cwm(i,k) = tem + t(i,k) = t(i,k) + elwv * rcp * q(i,k) + q(i,k) = 0.0 + endif + endif + enddo +! + enddo ! k loop ends here! +!********************************************************************** +!-----------------------end of precipitation processes----------------- +!********************************************************************** +! + do n=1,ihpr + i = ipr(n) + rn(i) = (precrl1(n) + precsl1(n)) * rrow ! precip at surface +! +!----sr=1 if sfc prec is rain ; ----sr=-1 if sfc prec is snow +!----sr=0 for both of them or no sfc prec +! +! rid = 0. +! sid = 0. +! if (precrl1(n) .ge. 1.e-13) rid = 1. +! if (precsl1(n) .ge. 1.e-13) sid = -1. +! sr(i) = rid + sid ! sr=1 --> rain, sr=-1 -->snow, sr=0 -->both +! chuang, june 2013: change sr to define fraction of frozen precipitation instead +! because wpc uses it in their winter experiment + + rid = precrl1(n) + precsl1(n) + if (rid < 1.e-13) then + sr(i) = 0. + else + sr(i) = precsl1(n)/rid + endif + enddo +! + return + end diff --git a/gsmphys/precpdp.f b/gsmphys/precpdp.f new file mode 100755 index 00000000..83c7202b --- /dev/null +++ b/gsmphys/precpdp.f @@ -0,0 +1,570 @@ + subroutine precpdp (im,ix,km,dt,del,prsl,ps,q,cwm,t,rn,sr + &, rainp,u00k,deltaq + &, psautco,prautco,evpco,wminco + &, lprnt,jpr) +! +! +! ****************************************************************** +! * * +! * subroutine for precipitation processes * +! * from suspended cloud water/ice * +! * * +! ****************************************************************** +! * * +! * originally created by q. zhao jan. 1995 * +! * ------- * +! * modified and rewritten by shrinivas moorthi oct. 1998 * +! * ----------------- * +! * and hua-lu pan * +! * ---------- * +! * * +! * references: * +! * * +! * zhao and carr (1997), monthly weather review (august) * +! * sundqvist et al., (1989) monthly weather review. (august) * +! * chuang 2013, modify sr to define frozen precipitation fraction* +! * * +! ****************************************************************** +! +! in this code vertical indexing runs from surface to top of the +! model +! +! argument list: +! -------------- +! im : inner dimension over which calculation is made +! ix : maximum inner dimension +! km : number of vertical levels +! dt : time step in seconds +! del(km) : pressure layer thickness (bottom to top) +! prsl(km) : pressure values for model layers (bottom to top) +! ps(im) : surface pressure (centibars) +! q(ix,km) : specific humidity (updated in the code) +! cwm(ix,km) : condensate mixing ratio (updated in the code) +! t(ix,km) : temperature (updated in the code) +! rn(im) : precipitation over one time-step dt (m/dt) +!old sr(im) : index (=-1 snow, =0 rain/snow, =1 rain) +!new sr(im) : "snow ratio", ratio of snow to total precipitation +! tcw(im) : vertically integrated liquid water (kg/m**2) +! cll(ix,km) : cloud cover +!hchuang rn(im) unit in m per time step +! precipitation rate conversion 1 mm/s = 1 kg/m2/s +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, hvap => con_hvap, hfus => con_hfus + &, ttp => con_ttp, cp => con_cp + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + real (kind=kind_phys) g, h1, h2, h1000 + &, h1000g, d00, d125, d5 + &, elwv, eliv, row + &, epsq, dldt, tm10, eliw + &, rcp, rrow + parameter (g=grav, h1=1.e0, h2=2.e0, h1000=1000.0 + &, h1000g=h1000/g, d00=0.e0, d125=.125e0, d5=0.5e0 + &, elwv=hvap, eliv=hvap+hfus, row=1.e3 + &, epsq=2.e-12, dldt=2274.e0,tm10=ttp-10.0 + &, eliw=eliv-elwv, rcp=h1/cp, rrow=h1/row) +! + real(kind=kind_phys), parameter :: cons_0=0.0, cons_p01=0.01 + &, cons_20=20.0 + &, cons_m30=-30.0, cons_50=50.0 +! + integer im, ix, km, lat, jpr + real (kind=kind_phys) q(ix,km), t(ix,km), cwm(ix,km) + &, del(ix,km), prsl(ix,km) +! &, cll(im,km), del(ix,km), prsl(ix,km) + &, ps(im), rn(im), sr(im) + &, tcw(im), dt +!hchuang code change [+1l] : add record to record information in vertical in +! addition to total column precrl + &, rainp(im,km), rnp(im), + & deltaq(ix,km),deltaqik,qtmp,qsmqr, + & cwmik,qik,prestmp, + & psautco, prautco, evpco, wminco(2) +! +! + real (kind=kind_phys) err(im), ers(im), precrl(im) + &, precsl(im), precrl1(im), precsl1(im) + &, rq(im), condt(im) + &, conde(im), rconde(im), tmt0(im) + &, wmin(im,km), wmink(im), pres(im) + &, wmini(im,km), ccr(im), cclim(km) + &, tt(im), qq(im), ww(im) + &, wfix(km), u00k(im,km), es(im) + &, zaodt +! + integer iw(im,km), ipr(im), iwl(im), iwl1(im) +! + logical comput(im) + logical lprnt +! + real (kind=kind_phys) ke, rdt, us, cclimit, climit, cws, csm1 + &, crs1, crs2, cr, aa2, dtcp, c00, cmr + &, tem, c1, c2, wwn +! &, tem, c1, c2, u00b, u00t, wwn + &, precrk, precsk, pres1, qk, qw, qi + &, ai, bi, qint, fiw, wws, cwmk, expf + &, psaut, psaci, amaxcm, tem1, tem2 + &, tmt0k, tmt15, psm1, psm2, ppr + &, rprs, erk, pps, sid, rid, amaxps + &, praut, pracw, fi, qc, amaxrq, rqkll + integer i, k, ihpr, n + +! print*, 'psautco,prautco,evpco,wminco:', +! & psautco,prautco,evpco,wminco +! +!-----------------------preliminaries --------------------------------- +! +! do k=1,km +! do i=1,im +! cll(i,k) = 0.0 +! enddo +! enddo +! + rdt = h1 / dt +! ke = 2.0e-5 ! commented on 09/10/99 -- opr value +! ke = 2.0e-6 +! ke = 1.0e-5 +!!! ke = 5.0e-5 +!! ke = 7.0e-5 + ke = evpco +! ke = 7.0e-5 + us = h1 + cclimit = 1.0e-3 + climit = 1.0e-20 + cws = 0.025 +! + zaodt = 800.0 * rdt +! + csm1 = 5.0000e-8 * zaodt + crs1 = 5.00000e-6 * zaodt + crs2 = 6.66600e-10 * zaodt + cr = 5.0e-4 * zaodt + aa2 = 1.25e-3 * zaodt +! + ke = ke * sqrt(rdt) +! ke = ke * sqrt(zaodt) +! + dtcp = dt * rcp +! +! c00 = 1.5e-1 * dt +! c00 = 10.0e-1 * dt +! c00 = 3.0e-1 * dt !05/09/2000 +! c00 = 1.0e-4 * dt !05/09/2000 + c00 = prautco * dt !05/09/2000 +! c00 = 5.0e-5 * dt !06/28/2012 + cmr = 1.0 / 3.0e-4 +! cmr = 1.0 / 5.0e-4 +! c1 = 100.0 + c1 = 300.0 + c2 = 0.5 +! +! +!--------calculate c0 and cmr using lc at previous step----------------- +! + do k=1,km + do i=1,im + tem = (prsl(i,k)*0.00001) +! tem = sqrt(tem) + iw(i,k) = 0.0 +! wmin(i,k) = 1.0e-5 * tem +! wmini(i,k) = 1.0e-5 * tem ! testing for ras +! + + wmin(i,k) = wminco(1) * tem + wmini(i,k) = wminco(2) * tem + + + rainp(i,k) = 0.0 + + enddo + enddo + do i=1,im +! c0(i) = 1.5e-1 +! cmr(i) = 3.0e-4 +! + iwl1(i) = 0 + precrl1(i) = d00 + precsl1(i) = d00 + comput(i) = .false. + rn(i) = d00 + sr(i) = d00 + ccr(i) = d00 +! + rnp(i) = d00 + enddo +!------------select columns where rain can be produced-------------- + do k=1, km-1 + do i=1,im + tem = min(wmin(i,k), wmini(i,k)) + if (cwm(i,k) .gt. tem) comput(i) = .true. + enddo + enddo + ihpr = 0 + do i=1,im + if (comput(i)) then + ihpr = ihpr + 1 + ipr(ihpr) = i + endif + enddo +!*********************************************************************** +!-----------------begining of precipitation calculation----------------- +!*********************************************************************** +! do k=km-1,2,-1 + do k=km,1,-1 + do n=1,ihpr + precrl(n) = precrl1(n) + precsl(n) = precsl1(n) + err (n) = d00 + ers (n) = d00 + iwl (n) = 0 +! + i = ipr(n) + tt(n) = t(i,k) + qq(n) = q(i,k) + ww(n) = cwm(i,k) + wmink(n) = wmin(i,k) + pres(n) = prsl(i,k) +! + precrk = max(cons_0, precrl1(n)) + precsk = max(cons_0, precsl1(n)) + wwn = max(ww(n), climit) +! if (wwn > wmink(n) .or. (precrk+precsk) > d00) then + if (wwn > climit .or. (precrk+precsk) > d00) then + comput(n) = .true. + else + comput(n) = .false. + endif + enddo +! +! es(1:ihpr) = fpvs(tt(1:ihpr)) + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + conde(n) = (dt/g) * del(i,k) + condt(n) = conde(n) * rdt + rconde(n) = h1 / conde(n) + qk = max(epsq, qq(n)) + tmt0(n) = tt(n) - 273.16 + wwn = max(ww(n), climit) +! +! pl = pres(n) * 0.01 +! call qsatd(tt(n), pl, qc) +! rq(n) = max(qq(n), epsq) / max(qc, 1.0e-10) +! rq(n) = max(1.0e-10, rq(n)) ! -- relative humidity--- +! +! the global qsat computation is done in pa + pres1 = pres(n) +! qw = es(n) + qw = min(pres1, fpvs(tt(n))) + qw = eps * qw / (pres1 + epsm1 * qw) + qw = max(qw,epsq) +! +! tmt15 = min(tmt0(n), cons_m15) +! ai = 0.008855 +! bi = 1.0 +! if (tmt0(n) .lt. -20.0) then +! ai = 0.007225 +! bi = 0.9674 +! endif +! qi = qw * (bi + ai*min(tmt0(n),cons_0)) +! qint = qw * (1.-0.00032*tmt15*(tmt15+15.)) +! + qi = qw + qint = qw +! if (tmt0(n).le.-40.) qint = qi +! +!-------------------ice-water id number iw------------------------------ + if(tmt0(n) < -15.) then + fi = qk + deltaq(i,k) -qi + if(fi > d00.or.wwn > climit) then + iwl(n) = 1 + else + iwl(n) = 0 + endif +! endif + elseif (tmt0(n) >= 0.) then + iwl(n) = 0 +! +! if(tmt0(n) < 0.0.and.tmt0(n) >= -15.0) then + else + iwl(n) = 0 + if(iwl1(n) == 1.and.wwn > climit) iwl(n)=1 + endif +! +! if(tmt0(n).ge.0.) then +! iwl(n) = 0 +! endif +!----------------the satuation specific humidity------------------------ + fiw = float(iwl(n)) + qc = (h1-fiw)*qint + fiw*qi +!----------------the relative humidity---------------------------------- + if(qc <= 1.0e-10) then + rq(n) = d00 + else + rq(n) = qk / qc + endif +!----------------cloud cover ratio ccr---------------------------------- + if(rq(n) >= us) then + ccr(n) = us + else + qtmp = qk + wwn -qw + if(deltaq(i,k) > epsq) then + if(qtmp <= -deltaq(i,k)) then + ccr(n) = d00 + elseif(qtmp >= deltaq(i,k)) then + ccr(n) = us + else + ccr(n) = 0.5*qtmp/deltaq(i,k) + 0.5 + ccr(n) = max(ccr(n), 0.) + ccr(n) = min(ccr(n), 1.) + endif + else + if(qtmp > 0.) then + ccr(n) = us + else + ccr(n) = d00 + endif + endif + endif +! + endif + enddo +!-------------------ice-water id number iwl------------------------------ +! do n=1,ihpr +! if (comput(n) .and. (ww(n) .gt. climit)) then +! if (tmt0(n) .lt. -15.0 +! * .or. (tmt0(n) .lt. 0.0 .and. iwl1(n) .eq. 1)) +! * iwl(n) = 1 +! cll(ipr(n),k) = 1.0 ! cloud cover! +! cll(ipr(n),k) = min(1.0, ww(n)*cclim(k)) ! cloud cover! +! endif +! enddo +! +!--- precipitation production -- auto conversion and accretion +! + do n=1,ihpr + if (comput(n) .and. ccr(n) > 0.0) then + wws = ww(n) + cwmk = max(cons_0, wws) +! amaxcm = max(cons_0, cwmk - wmink(n)) + if (iwl(n) == 1) then ! ice phase + amaxcm = max(cons_0, cwmk - wmini(ipr(n),k)) + expf = dt * exp(0.025*tmt0(n)) + psaut = min(cwmk, psautco*expf*amaxcm) + +! psaut = min(cwmk, 2.0e-3*expf*amaxcm) +! psaut = min(cwmk, 1.0e-3*expf*amaxcm) +! psaut = min(cwmk, 7.5e-4*expf*amaxcm) +!!!!!!! psaut = min(cwmk, 7.0e-4*expf*amaxcm) +!b psaut = min(cwmk, 6.5e-4*expf*amaxcm) +!!!! psaut = min(cwmk, 6.0e-4*expf*amaxcm) +! psaut = min(cwmk, 5.0e-4*expf*amaxcm) +! psaut = min(cwmk, 4.0e-4*expf*amaxcm) + + ww(n) = ww(n) - psaut + cwmk = max(cons_0, ww(n)) +! cwmk = max(cons_0, ww(n)-wmini(ipr(n),k)) + psaci = min(cwmk, aa2*expf*precsl1(n)*cwmk) + + ww(n) = ww(n) - psaci + + precsl(n) = precsl(n) + (wws - ww(n)) * condt(n) + else ! liquid water +! +! for using sundqvist precip formulation of rain +! + amaxcm = max(cons_0, cwmk - wmink(n)) +!! amaxcm = cwmk + tem1 = precsl1(n) + precrl1(n) + tem2 = min(max(cons_0, 268.0-tt(n)), cons_20) + tem = (1.0+c1*sqrt(tem1*rdt)) * (1+c2*sqrt(tem2)) +! + tem2 = amaxcm * cmr * tem / max(ccr(n),cons_p01) + tem2 = min(cons_50, tem2*tem2) + praut = c00 * tem * amaxcm * (1.0-exp(-tem2)) + praut = min(praut, cwmk) + ww(n) = ww(n) - praut +! +! below is for zhao's precip formulation (water) +! +! amaxcm = max(cons_0, cwmk - wmink(n)) +! praut = min(cwmk, c00*amaxcm*amaxcm) +! ww(n) = ww(n) - praut +! +! cwmk = max(cons_0, ww(n)) +! tem1 = precsl1(n) + precrl1(n) +! pracw = min(cwmk, cr*dt*tem1*cwmk) +! ww(n) = ww(n) - pracw +! + precrl(n) = precrl(n) + (wws - ww(n)) * condt(n) +! +!hchuang code change [+1l] : add record to record information in vertical +! turn rnp in unit of ww (cwm and q, kg/kg ???) + rnp(n) = rnp(n) + (wws - ww(n)) + endif + endif + enddo +! +!-----evaporation of precipitation------------------------- +!**** err & ers positive--->evaporation-- negtive--->condensation +! + do n=1,ihpr + if (comput(n)) then + i = ipr(n) + qk = max(epsq, qq(n)) + tmt0k = max(cons_m30, tmt0(n)) + precrk = max(cons_0, precrl(n)) + precsk = max(cons_0, precsl(n)) + amaxrq = max(cons_0, u00k(i,k)-rq(n)) * conde(n) +!---------------------------------------------------------------------- +! increase the evaporation for strong/light prec +!---------------------------------------------------------------------- + ppr = ke * amaxrq * sqrt(precrk) +! ppr = ke * amaxrq * sqrt(precrk*rdt) + if (tmt0(n) >= 0.) then + pps = 0. + else + pps = (crs1+crs2*tmt0k) * amaxrq * precsk / u00k(i,k) + end if +!---------------correct if over-evapo./cond. occurs-------------------- + erk=precrk+precsk + if(rq(n)>=1.0e-10) erk = amaxrq * qk * rdt / rq(n) + if (ppr+pps > abs(erk)) then + rprs = erk / (precrk+precsk) + ppr = precrk * rprs + pps = precsk * rprs + endif + ppr = min(ppr, precrk) + pps = min(pps, precsk) + err(n) = ppr * rconde(n) + ers(n) = pps * rconde(n) + precrl(n) = precrl(n) - ppr +!hchuang code change [+1l] : add record to record information in vertical +! use err for kg/kg/dt not the ppr (mm/dt=kg/m2/dt) +! + rnp(n) = rnp(n) - err(n) +! + precsl(n) = precsl(n) - pps + endif + enddo +!--------------------melting of the snow-------------------------------- + do n=1,ihpr + if (comput(n)) then + if (tmt0(n) > 0.) then + amaxps = max(cons_0, precsl(n)) + psm1 = csm1 * tmt0(n) * tmt0(n) * amaxps + psm2 = cws * cr * max(cons_0, ww(n)) * amaxps + ppr = (psm1 + psm2) * conde(n) + if (ppr > amaxps) then + ppr = amaxps + psm1 = amaxps * rconde(n) + endif + precrl(n) = precrl(n) + ppr +! +!hchuang code change [+1l] : add record to record information in vertical +! turn ppr (mm/dt=kg/m2/dt) to kg/kg/dt -> ppr/air density (kg/m3) + rnp(n) = rnp(n) + ppr * rconde(n) +! + precsl(n) = precsl(n) - ppr + else + psm1 = d00 + endif +! +!---------------update t and q------------------------------------------ + tt(n) = tt(n) - dtcp * (elwv*err(n)+eliv*ers(n)+eliw*psm1) + qq(n) = qq(n) + dt * (err(n)+ers(n)) + endif + enddo +! + do n=1,ihpr + iwl1(n) = iwl(n) + precrl1(n) = max(cons_0, precrl(n)) + precsl1(n) = max(cons_0, precsl(n)) + i = ipr(n) + t(i,k) = tt(n) + q(i,k) = qq(n) + cwm(i,k) = ww(n) + iw(i,k) = iwl(n) +!hchuang code change [+1l] : add record to record information in vertical +! rnp = precrl1*rconde(n) unit in kg/kg/dt +! + rainp(i,k) = rnp(n) + enddo +! +! move water from vapor to liquid should the liquid amount be negative +! + do i = 1, im + if (cwm(i,k) < 0.) then + tem = q(i,k) + cwm(i,k) + if (tem >= 0.0) then + q(i,k) = tem + t(i,k) = t(i,k) - elwv * rcp * cwm(i,k) + cwm(i,k) = 0. + elseif (q(i,k) > 0.0) then + cwm(i,k) = tem + t(i,k) = t(i,k) + elwv * rcp * q(i,k) + q(i,k) = 0.0 + endif + endif + enddo + + do i = 1, im + cwmik = max(cwm(i,k),climit) + qik = max(q(i,k),epsq) ! or qp1 + prestmp = prsl(i,k) + qw = min(prestmp, fpvs(t(i,k))) + qw = eps * qw / (prestmp+ epsm1 * qw) + qw = max(qw,epsq) + qsmqr = qw-qik + if(qsmqr > 0.0) then + if(cwmik > epsq) then + deltaqik = + & cwmik + qsmqr+ + & 2.*sqrt(cwmik * qsmqr) + else + deltaqik = (1. - u00k(i,k)) * qw + endif + else ! saturation + deltaqik = (1. - u00k(i,k)) * qw + endif + deltaqik = + & min(deltaqik, cwmik+qik) + deltaqik = + & max(deltaqik,0.0001 * qw) + deltaq(i,k)=deltaqik + enddo +! + enddo ! k loop ends here! +!********************************************************************** +!-----------------------end of precipitation processes----------------- +!********************************************************************** +! + do n=1,ihpr + i = ipr(n) + rn(i) = (precrl1(n) + precsl1(n)) * rrow ! precip at surface +! +!----sr=1 if sfc prec is rain ; ----sr=-1 if sfc prec is snow +!----sr=0 for both of them or no sfc prec +! +! rid = 0. +! sid = 0. +! if (precrl1(n) >= 1.e-13) rid = 1. +! if (precsl1(n) >= 1.e-13) sid = -1. +! sr(i) = rid + sid ! sr=1 --> rain, sr=-1 -->snow, sr=0 -->both +! chuang, june 2013: change sr to define fraction of frozen precipitation instead +! because wpc uses it in their winter experiment + + rid=precrl1(n)+precsl1(n) + if (rid<1.e-13) then + sr(i)=0. + else + sr(i)=precsl1(n)/rid + endif + + enddo +! + return + end diff --git a/gsmphys/progt2.f b/gsmphys/progt2.f new file mode 100644 index 00000000..c4a24a22 --- /dev/null +++ b/gsmphys/progt2.f @@ -0,0 +1,246 @@ + SUBROUTINE PROGT2(IM,KM,RHSCNPY, + & RHSMC,AI,BI,CI,SMC,iSLIMSK, + & CANOPY,PRECIP,RUNOFF,SNOWMT, + & ZSOIL,SOILTYP,SIGMAF,DELT,me) +cc + USE MACHINE , ONLY : kind_phys +! USE MACHINE_RAD , ONLY : kind_phys + implicit none + integer km, IM, me + real(kind=kind_phys) delt + real(kind=kind_phys) RHSCNPY(IM), RHSMC(IM,KM), AI(IM,KM), + & BI(IM,KM), CI(IM,KM), SMC(IM,KM), + & CANOPY(IM), PRECIP(IM), + & RUNOFF(IM), SNOWMT(IM), ZSOIL(IM,KM), + & SIGMAF(IM) + INTEGER SOILTYP(IM), ISLIMSK(IM) +! + integer k, lond, i + real(kind=kind_phys) CNPY(IM), PRCP(IM), TSAT(IM), + & INF(IM), INFMAX(IM), SMSOIL(IM,KM) +! + real(kind=kind_phys) cc, ctfil1, ctfil2, delt2, + & drip, rffact, rhoh2o, + & rzero, scanop, tdif, thsat, KSAT +! + LOGICAL FLAG(IM) +cc + PARAMETER (SCANOP=.5, RHOH2O=1000.) + PARAMETER (CTFIL1=.5, CTFIL2=1.-CTFIL1) +c PARAMETER (CTFIL1=1., CTFIL2=1.-CTFIL1) + PARAMETER (RFFACT=.15) +C +C##DG LATD = 44 + LOND = 353 + DELT2 = DELT * 2. + + DO I=1,IM + FLAG(I) = ISLIMSK(I) == 1 + ENDDO + +C +C PRECIPITATION RATE IS NEEDED IN UNIT OF KG M-2 S-1 +C + DO I=1,IM + IF(FLAG(I)) THEN + PRCP(I) = RHOH2O * (PRECIP(I)+SNOWMT(I)) / DELT + RUNOFF(I) = 0. + CNPY(I) = CANOPY(I) + ENDIF + ENDDO +C##DG IF(LAT.EQ.LATD) THEN +C##DG PRINT *, ' BEFORE RUNOFF CAL, RHSMC =', RHSMC(1) +C##DG ENDIF +C +C UPDATE CANOPY WATER CONTENT +C + DO I=1,IM + IF(FLAG(I)) THEN + RHSCNPY(I) = RHSCNPY(I) + SIGMAF(I) * PRCP(I) + CANOPY(I) = CANOPY(I) + DELT * RHSCNPY(I) + CANOPY(I) = MAX(CANOPY(I),0.) + PRCP(I) = PRCP(I) * (1. - SIGMAF(I)) + IF(CANOPY(I).GT.SCANOP) THEN + DRIP = CANOPY(I) - SCANOP + CANOPY(I) = SCANOP + PRCP(I) = PRCP(I) + DRIP / DELT + ENDIF +C +C CALCULATE INFILTRATION RATE +C + INF(I) = PRCP(I) + TSAT(I) = THSAT(SOILTYP(I)) +C DSAT = FUNCDF(TSAT(I),SOILTYP(I)) +C KSAT = FUNCKT(TSAT(I),SOILTYP(I)) +C INFMAX(I) = -DSAT * (TSAT(I) - SMC(I,1)) +C & / (.5 * ZSOIL(I,1)) +C & + KSAT + INFMAX(I) = (-ZSOIL(I,1)) * + & ((TSAT(I) - SMC(I,1)) / DELT - RHSMC(I,1)) + & * RHOH2O + INFMAX(I) = MAX(RFFACT*INFMAX(I),0.) +C IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = KSAT +C IF(SMC(I,1).GE.TSAT(I)) INFMAX(I) = ZSOIL(I,1) * RHSMC(I,1) + IF(INF(I).GT.INFMAX(I)) THEN + RUNOFF(I) = INF(I) - INFMAX(I) + INF(I) = INFMAX(I) + ENDIF + INF(I) = INF(I) / RHOH2O + RHSMC(I,1) = RHSMC(I,1) - INF(I) / ZSOIL(I,1) + ENDIF + ENDDO +!! +C##DG IF(LAT.EQ.LATD) THEN +C##DG PRINT *, ' PRCP(I), INFMAX(I), RUNOFF =', PRCP(I),INFMAX(I),RUNOFF +C##DG PRINT *, ' SMSOIL =', SMC(1), SMC(2) +C##DG PRINT *, ' RHSMC =', RHSMC(1) +C##DG ENDIF +C +C WE CURRENTLY IGNORE THE EFFECT OF RAIN ON SEA ICE +C +!! +C +C SOLVE THE TRI-DIAGONAL MATRIX +C + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + RHSMC(I,K) = RHSMC(I,K) * DELT2 + AI(I,K) = AI(I,K) * DELT2 + BI(I,K) = 1. + BI(I,K) * DELT2 + CI(I,K) = CI(I,K) * DELT2 + ENDIF + ENDDO + ENDDO +C FORWARD ELIMINATION + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,1) = -CI(I,1) / BI(I,1) + RHSMC(I,1) = RHSMC(I,1) / BI(I,1) + ENDIF + ENDDO + DO K = 2, KM + DO I=1,IM + IF(FLAG(I)) THEN + CC = 1. / (BI(I,K) + AI(I,K) * CI(I,K-1)) + CI(I,K) = -CI(I,K) * CC + RHSMC(I,K)=(RHSMC(I,K)-AI(I,K)*RHSMC(I,K-1))*CC + ENDIF + ENDDO + ENDDO +C BACKWARD SUBSTITUTTION + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,KM) = RHSMC(I,KM) + ENDIF + ENDDO +!! + DO K = KM-1, 1 + DO I=1,IM + IF(FLAG(I)) THEN + CI(I,K) = CI(I,K) * CI(I,K+1) + RHSMC(I,K) + ENDIF + ENDDO + ENDDO + 100 CONTINUE +C +C UPDATE SOIL MOISTURE +C + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + SMSOIL(I,K) = SMC(I,K) + CI(I,K) + SMSOIL(I,K) = MAX(SMSOIL(I,K),0.) + TDIF = MAX(SMSOIL(I,K) - TSAT(I),0.) + RUNOFF(I) = RUNOFF(I) - + & RHOH2O * TDIF * ZSOIL(I,K) / DELT + SMSOIL(I,K) = SMSOIL(I,K) - TDIF + ENDIF + ENDDO + ENDDO + DO K = 1, KM + DO I=1,IM + IF(FLAG(I)) THEN + SMC(I,K) = CTFIL1 * SMSOIL(I,K) + CTFIL2 * SMC(I,K) + ENDIF + ENDDO + ENDDO +c IF(FLAG(I)) THEN +c CANOPY(I) = CTFIL1 * CANOPY(I) + CTFIL2 * CNPY(I) +c ENDIF +C I = 1 +C PRINT *, ' SMC' +C PRINT 6000, SMC(1), SMC(2) +c6000 FORMAT(2(F8.5,',')) + RETURN + END + FUNCTION KTSOIL(THETA,KTYPE) +! + USE MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT, DFKT + implicit none + integer ktype,kw + real(kind=kind_phys) ktsoil, theta, w +! + W = (THETA / TSAT(KTYPE)) * 20. + 1. + KW = W + KW = MIN(KW,21) + KW = MAX(KW,1) + KTSOIL = DFKT(KW,KTYPE) + & + (W - KW) * (DFKT(KW+1,KTYPE) - DFKT(KW,KTYPE)) + RETURN + END + FUNCTION FUNCDF(THETA,KTYPE) +! + USE MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT, DFK + implicit none + integer ktype,kw + real(kind=kind_phys) funcdf,theta,w +! + W = (THETA / TSAT(KTYPE)) * 20. + 1. + KW = W + KW = MIN(KW,21) + KW = MAX(KW,1) + FUNCDF = DFK(KW,KTYPE) + & + (W - KW) * (DFK(KW+1,KTYPE) - DFK(KW,KTYPE)) + RETURN + END + FUNCTION FUNCKT(THETA,KTYPE) +! + USE MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT, KTK + implicit none + integer ktype,kw + real(kind=kind_phys) funckt,theta,w +! + W = (THETA / TSAT(KTYPE)) * 20. + 1. + KW = W + KW = MIN(KW,21) + KW = MAX(KW,1) + FUNCKT = KTK(KW,KTYPE) + & + (W - KW) * (KTK(KW+1,KTYPE) - KTK(KW,KTYPE)) + RETURN + END + FUNCTION THSAT(KTYPE) +! + USE MACHINE , ONLY : kind_phys + USE module_progtm , ONLY : TSAT + implicit none + integer ktype + real(kind=kind_phys) thsat +! + THSAT = TSAT(KTYPE) + RETURN + END + FUNCTION TWLT(KTYPE) + + USE MACHINE , ONLY : kind_phys +! USE module_progtm + implicit none + integer ktype + real(kind=kind_phys) twlt +! + TWLT = .1 + RETURN + END diff --git a/gsmphys/progtm_module.f b/gsmphys/progtm_module.f new file mode 100644 index 00000000..6f5b3fcc --- /dev/null +++ b/gsmphys/progtm_module.f @@ -0,0 +1,93 @@ + module module_progtm + USE MACHINE , ONLY : kind_phys + implicit none + SAVE +! + integer,parameter:: NTYPE=9 + integer,parameter:: NGRID=22 + real(kind=kind_phys) B(NTYPE), SATPSI(NTYPE), SATKT(NTYPE), + & TSAT(NTYPE), + & DFK(NGRID,NTYPE), + & KTK(NGRID,NTYPE), + & DFKT(NGRID,NTYPE) +! +! the nine soil types are: +! 1 ... loamy sand (coarse) +! 2 ... silty clay loam (medium) +! 3 ... light clay (fine) +! 4 ... sandy loam (coarse-medium) +! 5 ... sandy clay (coarse-fine) +! 6 ... clay loam (medium-fine) +! 7 ... sandy clay loam (coarse-med-fine) +! 8 ... loam (organic) +! 9 ... ice (use loamy sand property) +! +! DATA B/4.05,4.38,4.9,5.3,5.39,7.12,7.75,8.52, +! & 10.4,10.4,11.4/ +! DATA SATPSI/.121,.09,.218,.786,.478,.299,.356,.63, +! & .153,.49,.405/ +! DATA SATKT/1.76E-4,1.5633E-4,3.467E-5,7.2E-6,6.95E-6, +! & 6.3E-6,1.7E-6,2.45E-6,2.167E-6,1.033E-6, +! & 1.283E-6/ +! DATA TSAT/.395,.41,.435,.485,.451,.42,.477,.476, +! & .426,.492,.482/ + data b/4.26,8.72,11.55,4.74,10.73,8.17,6.77,5.25,4.26/ + data satpsi/.04,.62,.47,.14,.10,.26,.14,.36,.04/ + data satkt/1.41e-5,.20e-5,.10e-5,.52e-5,.72e-5, + & .25e-5,.45e-5,.34e-5,1.41e-5/ + data tsat/.421,.464,.468,.434,.406,.465,.404,.439,.421/ +! + contains + subroutine GRDDF + USE MACHINE , ONLY : kind_phys + implicit none + integer i, k + real(kind=kind_phys) dynw, f1, f2, theta +! +! GRDDF SETS UP MOISTURE DIFFUSIVITY AND HYDROLIC CONDUCTIVITY +! FOR ALL SOIL TYPES +! GRDDFS SETS UP THERMAL DIFFUSIVITY FOR ALL SOIL TYPES +! + DO K = 1, NTYPE + DYNW = TSAT(K) * .05 + F1 = B(K) * SATKT(K) * SATPSI(K) / TSAT(K) ** (B(K) + 3.) + F2 = SATKT(K) / TSAT(K) ** (B(K) * 2. + 3.) +! +! CONVERT FROM M/S TO KG M-2 S-1 UNIT +! + F1 = F1 * 1000. + F2 = F2 * 1000. + DO I = 1, NGRID + THETA = FLOAT(I-1) * DYNW + THETA = MIN(TSAT(K),THETA) + DFK(I,K) = F1 * THETA ** (B(K) + 2.) + KTK(I,K) = F2 * THETA ** (B(K) * 2. + 3.) + ENDDO + ENDDO + END SUBROUTINE + subroutine GRDKT + USE MACHINE , ONLY : kind_phys + implicit none + integer i, k + real(kind=kind_phys) dynw, f1, theta, pf + DO K = 1, NTYPE + DYNW = TSAT(K) * .05 + F1 = LOG10(SATPSI(K)) + B(K) * LOG10(TSAT(K)) + 2. + DO I = 1, NGRID + THETA = FLOAT(I-1) * DYNW + THETA = MIN(TSAT(K),THETA) + IF(THETA.GT.0.) THEN + PF = F1 - B(K) * LOG10(THETA) + ELSE + PF = 5.2 + ENDIF + IF(PF.LE.5.1) THEN + DFKT(I,K) = EXP(-(2.7+PF)) * 420. + ELSE + DFKT(I,K) = .1744 + ENDIF + ENDDO + ENDDO + END SUBROUTINE +! + end module module_progtm diff --git a/gsmphys/rad_initialize.f b/gsmphys/rad_initialize.f new file mode 100644 index 00000000..dc0f4814 --- /dev/null +++ b/gsmphys/rad_initialize.f @@ -0,0 +1,224 @@ +!----------------------------------- + subroutine rad_initialize & +!................................... +! --- inputs: + & ( si,levr,ictm,isol,ico2,iaer,ialb,iems,ntcw, num_p2d, & + & num_p3d,npdf3d,ntoz,iovr_sw,iovr_lw,isubc_sw,isubc_lw, & + & crick_proof,ccnorm,norad_precip, & + & idate,iflip,me ) +! --- outputs: ( none ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: rad_initialize - a subprogram to initialize radiation ! +! ! +! usage: call rad_initialize ! +! ! +! attributes: ! +! language: fortran 90 ! +! ! +! program history: ! +! mar 2012 - yu-tai hou create the program to initialize fixed ! +! control variables for radiaion processes. this ! +! subroutine is called at the start of model run. ! +! nov 2012 - yu-tai hou modified control parameter through ! +! module 'physparam'. ! +! mar 2014 - sarah lu iaermdl is determined from iaer ! +! jul 2014 - s moorthi add npdf3d for pdf clouds ! +! ! +! ==================== defination of variables ==================== ! +! ! +! input parameters: ! +! si : model vertical sigma interface or equivalence ! +! levr : number of model vertical layers ! +! ictm :=yyyy#, external data time/date control flag ! +! = -2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! = -1: use user provided external data for the ! +! forecast time, no extrapolation. ! +! = 0: use data at initial cond time, if not ! +! available, use latest, no extrapolation. ! +! = 1: use data at the forecast time, if not ! +! available, use latest and extrapolation. ! +! =yyyy0: use yyyy data for the forecast time, ! +! no further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! isol := 0: use the old fixed solar constant in "physcon"! +! =10: use the new fixed solar constant in "physcon"! +! = 1: use noaa ann-mean tsi tbl abs-scale data tabl! +! = 2: use noaa ann-mean tsi tbl tim-scale data tabl! +! = 3: use cmip5 ann-mean tsi tbl tim-scale data tbl! +! = 4: use cmip5 mon-mean tsi tbl tim-scale data tbl! +! ico2 :=0: use prescribed global mean co2 (old oper) ! +! =1: use observed co2 annual mean value only ! +! =2: use obs co2 monthly data with 2-d variation ! +! iaer : 4-digit aerosol flag (dabc for aermdl,volc,lw,sw)! +! d: =0 or none, opac-climatology aerosol scheme ! +! =1 use gocart climatology aerosol scheme ! +! =2 use gocart progostic aerosol scheme ! +! a: =0 use background stratospheric aerosol ! +! =1 incl stratospheric vocanic aeros ! +! b: =0 no topospheric aerosol in lw radiation ! +! =1 include tropspheric aerosols for lw ! +! c: =0 no topospheric aerosol in sw radiation ! +! =1 include tropspheric aerosols for sw ! +! ialb : control flag for surface albedo schemes ! +! =0: climatology, based on surface veg types ! +! =1: modis retrieval based surface albedo scheme ! +! iems : ab 2-digit control flag ! +! a: =0 set sfc air/ground t same for lw radiation ! +! =1 set sfc air/ground t diff for lw radiation ! +! b: =0 use fixed sfc emissivity=1.0 (black-body) ! +! =1 use varying climtology sfc emiss (veg based)! +! =2 future development (not yet) ! +! ntcw :=0 no cloud condensate calculated ! +! >0 array index location for cloud condensate ! +! num_p3d :=3: ferrier's microphysics cloud scheme ! +! =4: zhao/carr/sundqvist microphysics cloud ! +! npdf3d =0 no pdf clouds ! +! =3 (when num_p3d=4) pdf clouds with zhao/carr/ ! +! sundqvist scheme ! +! ntoz : ozone data control flag ! +! =0: use climatological ozone profile ! +! >0: use interactive ozone profile ! +! iovr_sw/iovr_lw : control flag for cloud overlap (sw/lw rad) ! +! =0: random overlapping clouds ! +! =1: max/ran overlapping clouds ! +! isubc_sw/isubc_lw: sub-column cloud approx control flag (sw/lw rad) ! +! =0: with out sub-column cloud approximation ! +! =1: mcica sub-col approx. prescribed random seed ! +! =2: mcica sub-col approx. provided random seed ! +! crick_proof : control flag for eliminating CRICK ! +! ccnorm : control flag for in-cloud condensate mixing ratio! +! norad_precip : control flag for not using precip in radiation ! +! idate(4) : ncep absolute date and time of initial condition ! +! (hour, month, day, year) ! +! iflip : control flag for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! me : print control flag ! +! ! +! subroutines called: radinit ! +! ! +! =================================================================== ! +! + use physparam, only : isolar , ictmflg, ico2flg, ioznflg, iaerflg,& + & iaermdl, laswflg, lalwflg, lavoflg, icldflg, icmphys,& + & iovrsw , iovrlw , lcrick , lcnorm , lnoprec, & + & ialbflg, iemsflg, isubcsw, isubclw, ivflip , ipsd0, & + & kind_phys + + use module_radiation_driver, only : radinit +! + implicit none + +! --- input: + integer, intent(in) :: levr, ictm, isol, ico2, iaer, num_p2d, & + & ntcw, ialb, iems, num_p3d, npdf3d, ntoz, iovr_sw, iovr_lw, & + & isubc_sw, isubc_lw, iflip, me, idate(4) + + real (kind=kind_phys), intent(in) :: si(levr+1) + + logical, intent(in) :: crick_proof, ccnorm, norad_precip + +! --- output: ( none ) + +! --- local: + integer :: icld +! +!===> ... start here +! +! --- set up parameters for radiation initialization + + isolar = isol ! solar constant control flag + + ictmflg= ictm ! data ic time/date control flag + ico2flg= ico2 ! co2 data source control flag + ioznflg= ntoz ! ozone data source control flag + + if ( ictm==0 .or. ictm==-2 ) then + iaerflg = mod(iaer, 100) ! no volcanic aerosols for clim hindcast + else + iaerflg = mod(iaer, 1000) + endif + laswflg= (mod(iaerflg,10) > 0) ! control flag for sw tropospheric aerosol + lalwflg= (mod(iaerflg/10,10) > 0) ! control flag for lw tropospheric aerosol + lavoflg= (iaerflg >= 100) ! control flag for stratospheric volcanic aeros + iaermdl = iaer/1000 ! control flag for aerosol scheme selection + if ( iaermdl < 0 .or. iaermdl > 2) then + print *, ' Error -- IAER flag is incorrect, Abort' + stop 7777 + endif + + if ( ntcw > 0 ) then + icldflg = 1 ! prognostic cloud optical prop scheme + else + icldflg = 0 ! diagnostic cloud optical prop scheme + endif + icmphys = 1 ! default + if ( num_p3d == 4 ) then + if ( num_p2d == 3 ) then + if (npdf3d /= 3) then + icmphys = 1 ! zhao/moorthi's prognostic cloud scheme + else + icmphys = 3 ! zhao+ pdf cloud & cnvc and cnvw + endif + elseif ( num_p2d == 1 ) then + if (npdf3d /= 3) then + icmphys = 4 ! gfdl cloud microphysics + else + icmphys = 5 ! gfdl cloud microphysics + pdf cloud & cnvc and cnvw + endif + endif + endif +! if (ncld == 2) icmphys = 1 ! MG 2m Morrison scheme +! + iovrsw = iovr_sw ! cloud overlapping control flag for sw + iovrlw = iovr_lw ! cloud overlapping control flag for lw + + lcrick = crick_proof ! control flag for eliminating CRICK + lcnorm = ccnorm ! control flag for in-cld condensate + lnoprec = norad_precip ! precip effect on radiation flag (ferrier microphysics) + isubcsw = isubc_sw ! sub-column cloud approx flag in sw radiation + isubclw = isubc_lw ! sub-column cloud approx flag in lw radiation + + ialbflg= ialb ! surface albedo control flag + iemsflg= iems ! surface emissivity control flag + + ivflip = iflip ! vertical index direction control flag + +! --- assign initial permutation seed for mcica cloud-radiation + if ( isubc_sw>0 .or. isubc_lw>0 ) then +! ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + ipsd0 + ipsd0 = 17*idate(1)+43*idate(2)+37*idate(3)+23*idate(4) + endif + + if ( me == 0 ) then + print *,' In rad_initialize, before calling radinit' + print *,' si =',si + print *,' levr=',levr,' ictm=',ictm,' isol=',isol,' ico2=',ico2,& + & ' iaer=',iaer,' ialb=',ialb,' iems=',iems,' ntcw=',ntcw + print *,' np3d=',num_p3d,' ntoz=',ntoz,' iovr_sw=',iovr_sw, & + & ' iovr_lw=',iovr_lw,' isubc_sw=',isubc_sw, & + & ' isubc_lw=',isubc_lw,' iflip=',iflip,' me=',me + print *,' crick_proof=',crick_proof, & + & ' ccnorm=',ccnorm,' norad_precip=',norad_precip + endif + + call radinit & +! --- inputs: + & ( si, levr, me ) +! --- outputs: +! ( none ) + + if ( me == 0 ) then + print *,' Radiation sub-cloud initial seed =',ipsd0, & + & ' IC-idate =',idate + print *,' return from rad_initialize - after calling radinit' + endif +! + return +!................................... + end subroutine rad_initialize +!----------------------------------- diff --git a/gsmphys/radiation_aerosols.f b/gsmphys/radiation_aerosols.f new file mode 100644 index 00000000..71834573 --- /dev/null +++ b/gsmphys/radiation_aerosols.f @@ -0,0 +1,5501 @@ +!> \file radiation_aerosols.f +!! This file contains climatological atmospheric aerosol schemes for +!! radiation computations + +! ========================================================== !!!!! +! 'module_radiation_aerosols' description !!!!! +! ========================================================== !!!!! +! ! +! this module contains climatological atmospheric aerosol schemes for! +! radiation computations. ! +! ! +! in the module, the externally callable subroutines are : ! +! ! +! 'aer_init' -- initialization ! +! inputs: ! +! ( NLAY, me ) ! +! outputs: ! +! ( none ) ! +! ! +! 'aer_update' -- updating aerosol data ! +! inputs: ! +! ( iyear, imon, me ) ! +! outputs: ! +! ( none ) ! +! ! +! 'setaer' -- mapping aeros profile, compute aeros opticals ! +! inputs: ! +! (prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,xlon,xlat, ! +! IMAX,NLAY,NLP1, lsswr,lslwr, ! +! outputs: ! +! (aerosw,aerolw,tau_gocart) ! +!! (aerosw,aerolw,aerodp) ! +! ! +! ! +! external modules referenced: ! +! 'module physparam' in 'physparam.f' ! +! 'module physcons' in 'physcons.f' ! +! 'module module_radsw_parameters' in 'radsw_xxxx#_param.f' ! +! 'module module_radlw_parameters' in 'radlw_xxxx#_param.f' ! +! 'module module_radlw_cntr_para' in 'radsw_xxxx#_param.f' ! +! ! +! output variable definitions: ! +! aerosw(IMAX,NLAY,NBDSW,1) - aerosols optical depth for sw ! +! aerosw(IMAX,NLAY,NBDSW,2) - aerosols single scat albedo for sw ! +! aerosw(IMAX,NLAY,NBDSW,3) - aerosols asymmetry parameter for sw! +! ! +! aerolw(IMAX,NLAY,NBDLW,1) - aerosols optical depth for lw ! +! aerolw(IMAX,NLAY,NBDLW,2) - aerosols single scattering albedo ! +! aerolw(IMAX,NLAY,NBDLW,3) - aerosols asymetry parameter ! +! ! +! ! +! program history: ! +! apr 2003 --- y.-t. hou created ! +! nov 04, 2003 --- y.-t. hou modified version ! +! apr 15, 2005 --- y.-t. hou modified module structure ! +! jul 2006 --- y.-t. hou add volcanic forcing ! +! feb 2007 --- y.-t. hou add generalized spectral band ! +! interpolation for sw aerosol optical properties ! +! mar 2007 --- y.-t. hou add generalized spectral band ! +! interpolation for lw aerosol optical properties ! +! aug 2007 --- y.-t. hou change clim-aer vert domain ! +! from pressure reference to sigma reference ! +! sep 2007 --- y.-t. hou moving temporary allocatable ! +! module variable arrays to subroutine dynamically ! +! allocated arrays (eliminate deallocate calls) ! +! jan 2010 --- sarah lu add gocart option ! +! may 2010 --- sarah lu add geos4-gocart climo ! +! jul 2010 -- s. moorthi - merged NEMS version with new GFS ! +! version ! +! oct 23, 2010 --- Hsin-mu lin modified subr setclimaer to ! +! interpolate the 5 degree aerosol data to small domain based on! +! the nearby 4 points instead of previous nearby assignment by ! +! using the 5 degree data. this process will eliminate the dsw ! +! jagged edges in the east conus where aerosol effect are lagre.! +! dec 2010 --- y.-t. hou modified and optimized bi-linear! +! horizontal interpolation in subr setclimaer. added safe guard ! +! measures in lat/lon indexing and added sea/land mask variable ! +! slmsk as input field to help aerosol profile selection. ! +! jan 2011 --- y.-t. hou divided the program into two ! +! separated interchangeable modules: a climatology aerosol ! +! module, and a gocart aerosol scheme module. the stratospheric ! +! volcanic aerosol part is still within the two driver modules, ! +! and may also become a separate one in the further development.! +! unified in/out argument list for both clim and gocart types of! +! schemes and added vertically integrated aer-opt-dep, aerodp, ! +! to replace tau_gocart as optional output for various species. ! +! aug 2012 --- y.-t. hou changed the initialization subr ! +! 'aerinit' into two parts: 'aer_init' is called at the start ! +! of run to set up module parameters; and 'aer_update' is ! +! called within the time loop to check and update data sets. ! +! nov 2012 --- y.-t. hou modified control parameters thru! +! module 'physparam'. ! +! jan 2013 --- sarah lu and y.-t. hou reintegrate both ! +! opac-clim and gocart schemes into one module to make the ! +! program best utilize common components. added aerosol model ! +! scheme selection control variable iaer_mdl to the namelist. ! +! Aug 2013 --- s. moorthi - merge sarah's gocart changes with! +! yutai's changes ! +! 13Feb2014 --- Sarah lu - compute aod at 550nm ! +! ! +! references for opac climatological aerosols: ! +! hou et al. 2002 (ncep office note 441) ! +! hess et al. 1998 - bams v79 831-844 ! +! ! +! references for gocart interactive aerosols: ! +! chin et al., 2000 - jgr, v105, 24671-24687 ! +! ! +! references for stratosperic volcanical aerosols: ! +! sato et al. 1993 - jgr, v98, d12, 22987-22994 ! +! ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + + + +!> \ingroup rad +!! \defgroup module_radiation_aerosols module_radiation_aerosols +!> @{ +!! This module contains climatological atmospheric aerosol schemes for +!! radiation computations. +!! +!!\version NCEP-Radiation_aerosols v5.2 Jan 2013 +!! +!!\n This module has three externally callable subroutines: +!! - aer_init() -- initialization; called at the start of run to set up +!! module parameters +!! - aer_update() -- updating aerosol data; called within the time loop +!! to check and update data sets +!! - setaer() -- mapping aeros profile, compute aeros opticals +!! +!!\n References: +!! - OPAC climatological aerosols: +!! Hou et al. 2002 \cite hou_et_al_2002; Hess et al. 1998 +!! \cite hess_et_al_1998 +!! - GOCART interactive aerosols: +!! Chin et al., 2000 \cite chin_et_al_2000 +!! - Stratospheric volcanical aerosols: +!! Sato et al. 1993 \cite sato_et_al_1993 +!========================================! + module module_radiation_aerosols ! +!........................................! +! + use physparam,only : iaermdl, iaerflg, lavoflg, lalwflg, laswflg, & + & lalw1bd, aeros_file, ivflip, kind_phys & + &, kind_io4, kind_io8 + use physcons, only : con_pi, con_rd, con_g, con_t0c, con_c, & + & con_boltz, con_plnk, con_amd + + use module_iounitdef, only : NIAERCM + use module_radsw_parameters, only : NBDSW, wvnsw1=>wvnum1, & + & NSWSTR, wvnsw2=>wvnum2 + use module_radlw_parameters, only : NBDLW, wvnlw1, wvnlw2 +! + use funcphys, only : fpkap + use gfs_phy_tracer_config, only : gfs_phy_tracer, trcindx +! + implicit none +! + private + +! --- version tag and last revision date + character(40), parameter :: & + & VTAGAER='NCEP-Radiation_aerosols v5.2 Jan 2013 ' +! & VTAGAER='NCEP-Radiation_aerosols v5.1 Nov 2012 ' +! & VTAGAER='NCEP-Radiation_aerosols v5.0 Aug 2012 ' + +! --- general use parameter constants: +!> num of output fields for SW rad + integer, parameter, public :: NF_AESW = 3 +!> num of output fields for LW rad + integer, parameter, public :: NF_AELW = 3 +!> starting band number in ir region + integer, parameter, public :: NLWSTR = 1 +!> num of species for output aod (opnl) + integer, parameter, public :: NSPC = 5 +!> total+species + integer, parameter, public :: NSPC1 = NSPC + 1 + + real (kind=kind_phys), parameter :: f_zero = 0.0 + real (kind=kind_phys), parameter :: f_one = 1.0 + +! --- module control parameters set in subroutine "aer_init" +!> number of actual bands for sw aerosols; calculated according to +!! laswflg setting + integer, save :: NSWBND = NBDSW +!> number of actual bands for lw aerosols; calculated according to +!! lalwflg and lalw1bd settings + integer, save :: NLWBND = NBDLW +!> total number of bands for sw+lw aerosols + integer, save :: NSWLWBD = NBDSW+NBDLW + +! --------------------------------------------------------------------- ! +! section-1 : module variables for spectral band interpolation ! +! similar to gfdl-sw treatment (2000 version) ! +! --------------------------------------------------------------------- ! + +! --- parameter constants: +!> num of wvnum regions where solar flux is constant + integer, parameter, public :: NWVSOL = 151 + +!> total num of wvnum included + integer, parameter, public :: NWVTOT = 57600 +!> total num of wvnum in ir range + integer, parameter, public :: NWVTIR = 4000 + +!> number of wavenumbers in each region where the solar flux is constant + integer, dimension(NWVSOL), save :: nwvns0 + + data nwvns0 / 100, 11, 14, 18, 24, 33, 50, 83, 12, 12, & + & 13, 15, 15, 17, 18, 20, 21, 24, 26, 30, 32, 37, 42, & + & 47, 55, 64, 76, 91, 111, 139, 179, 238, 333, 41, 42, 45, & + & 46, 48, 51, 53, 55, 58, 61, 64, 68, 71, 75, 79, 84, & + & 89, 95, 101, 107, 115, 123, 133, 142, 154, 167, 181, 197, 217, & + & 238, 263, 293, 326, 368, 417, 476, 549, 641, 758, 909, 101, 103, & + & 105, 108, 109, 112, 115, 117, 119, 122, 125, 128, 130, 134, 137, & + & 140, 143, 147, 151, 154, 158, 163, 166, 171, 175, 181, 185, 190, & + & 196, 201, 207, 213, 219, 227, 233, 240, 248, 256, 264, 274, 282, & + & 292, 303, 313, 325, 337, 349, 363, 377, 392, 408, 425, 444, 462, & + & 483, 505, 529, 554, 580, 610, 641, 675, 711, 751, 793, 841, 891, & + & 947,1008,1075,1150,1231,1323,1425,1538,1667,1633,14300 / + +!> solar flux \f$w/m^2\f$ in each wvnumb region where it is constant + real (kind=kind_phys), dimension(NWVSOL), save :: s0intv + + data s0intv( 1: 50) / & + & 1.60000E-6, 2.88000E-5, 3.60000E-5, 4.59200E-5, 6.13200E-5, & + & 8.55000E-5, 1.28600E-4, 2.16000E-4, 2.90580E-4, 3.10184E-4, & + & 3.34152E-4, 3.58722E-4, 3.88050E-4, 4.20000E-4, 4.57056E-4, & + & 4.96892E-4, 5.45160E-4, 6.00600E-4, 6.53600E-4, 7.25040E-4, & + & 7.98660E-4, 9.11200E-4, 1.03680E-3, 1.18440E-3, 1.36682E-3, & + & 1.57560E-3, 1.87440E-3, 2.25500E-3, 2.74500E-3, 3.39840E-3, & + & 4.34000E-3, 5.75400E-3, 7.74000E-3, 9.53050E-3, 9.90192E-3, & + & 1.02874E-2, 1.06803E-2, 1.11366E-2, 1.15830E-2, 1.21088E-2, & + & 1.26420E-2, 1.32250E-2, 1.38088E-2, 1.44612E-2, 1.51164E-2, & + & 1.58878E-2, 1.66500E-2, 1.75140E-2, 1.84450E-2, 1.94106E-2 / + data s0intv( 51:100) / & + & 2.04864E-2, 2.17248E-2, 2.30640E-2, 2.44470E-2, 2.59840E-2, & + & 2.75940E-2, 2.94138E-2, 3.13950E-2, 3.34800E-2, 3.57696E-2, & + & 3.84054E-2, 4.13490E-2, 4.46880E-2, 4.82220E-2, 5.22918E-2, & + & 5.70078E-2, 6.19888E-2, 6.54720E-2, 6.69060E-2, 6.81226E-2, & + & 6.97788E-2, 7.12668E-2, 7.27100E-2, 7.31610E-2, 7.33471E-2, & + & 7.34814E-2, 7.34717E-2, 7.35072E-2, 7.34939E-2, 7.35202E-2, & + & 7.33249E-2, 7.31713E-2, 7.35462E-2, 7.36920E-2, 7.23677E-2, & + & 7.25023E-2, 7.24258E-2, 7.20766E-2, 7.18284E-2, 7.32757E-2, & + & 7.31645E-2, 7.33277E-2, 7.36128E-2, 7.33752E-2, 7.28965E-2, & + & 7.24924E-2, 7.23307E-2, 7.21050E-2, 7.12620E-2, 7.10903E-2 / + data s0intv(101:151) / 7.12714E-2, & + & 7.08012E-2, 7.03752E-2, 7.00350E-2, 6.98639E-2, 6.90690E-2, & + & 6.87621E-2, 6.52080E-2, 6.65184E-2, 6.60038E-2, 6.47615E-2, & + & 6.44831E-2, 6.37206E-2, 6.24102E-2, 6.18698E-2, 6.06320E-2, & + & 5.83498E-2, 5.67028E-2, 5.51232E-2, 5.48645E-2, 5.12340E-2, & + & 4.85581E-2, 4.85010E-2, 4.79220E-2, 4.44058E-2, 4.48718E-2, & + & 4.29373E-2, 4.15242E-2, 3.81744E-2, 3.16342E-2, 2.99615E-2, & + & 2.92740E-2, 2.67484E-2, 1.76904E-2, 1.40049E-2, 1.46224E-2, & + & 1.39993E-2, 1.19574E-2, 1.06386E-2, 1.00980E-2, 8.63808E-3, & + & 6.52736E-3, 4.99410E-3, 4.39350E-3, 2.21676E-3, 1.33812E-3, & + & 1.12320E-3, 5.59000E-4, 3.60000E-4, 2.98080E-4, 7.46294E-5 / + +! --------------------------------------------------------------------- ! +! section-2 : module variables for stratospheric volcanic aerosols ! +! from historical data (sato et al. 1993) ! +! --------------------------------------------------------------------- ! + +! --- parameter constants: +!> lower limit (year) data available + integer, parameter :: MINVYR = 1850 +!> upper limit (year) data available + integer, parameter :: MAXVYR = 1999 + +!> monthly, 45-deg lat-zone aerosols data set in subroutine 'aer_init' + integer, allocatable, save :: ivolae(:,:,:) + +! --- static control variables: +!> starting year of data in the input file + integer :: kyrstr +!> ending year of data in the input file + integer :: kyrend +!> the year of data in use in the input file + integer :: kyrsav +!> the month of data in use in the input file + integer :: kmonsav + +! --------------------------------------------------------------------- ! +! section-3 : module variables for opac climatological aerosols ! +! optical properties (hess et al. 1989) ! +! --------------------------------------------------------------------- ! + +! --- parameters and constants: +!> num of max componets in a profile + integer, parameter :: NXC = 5 +!> num of aerosols profile structures + integer, parameter :: NAE = 7 +!> num of atmos aerosols domains + integer, parameter :: NDM = 5 +!> num of lon-points in glb aeros data set + integer, parameter :: IMXAE = 72 +!> num of lat-points in glb aeros data set + integer, parameter :: JMXAE = 37 +!> num of bands for clim aer data (opac) + integer, parameter :: NAERBND=61 +!> num of rh levels for rh-dep components + integer, parameter :: NRHLEV =8 +!> num of rh independent aeros species + integer, parameter :: NCM1 = 6 +!> num of rh dependent aeros species + integer, parameter :: NCM2 = 4 + integer, parameter :: NCM = NCM1+NCM2 + +!> predefined relative humidity levels + real (kind=kind_phys), dimension(NRHLEV), save :: rhlev + data rhlev (:) / 0.0, 0.5, 0.7, 0.8, 0.9, 0.95, 0.98, 0.99 / + +! --- the following arrays are for climatological data that are +! allocated and read in subroutine 'clim_aerinit'. +! - global aerosol distribution: +! haer (NDM,NAE) - scale height of aerosols (km) +! prsref(NDM,NAE) - ref pressure lev (sfc to toa) in mb (100Pa) +! sigref(NDM,NAE) - ref sigma lev (sfc to toa) + +!> scale height of aerosols (km) + real (kind=kind_phys), save, dimension(NDM,NAE) :: haer +!> ref pressure lev (sfc to toa) in mb (100Pa) + real (kind=kind_phys), save, dimension(NDM,NAE) :: prsref +!> ref sigma lev (sfc to toa) + real (kind=kind_phys), save, dimension(NDM,NAE) :: sigref + +! --- the following arrays are allocate and setup in subr 'clim_aerinit' +! - for relative humidity independent aerosol optical properties: +! species : insoluble (inso); soot (soot); +! mineral nuc mode (minm); mineral acc mode (miam); +! mineral coa mode (micm); mineral transport(mitr). +! extrhi(NCM1,NSWLWBD) - extinction coefficient for sw+lw spectral band +! scarhi(NCM1,NSWLWBD) - scattering coefficient for sw+lw spectral band +! ssarhi(NCM1,NSWLWBD) - single scattering albedo for sw+lw spectral band +! asyrhi(NCM1,NSWLWBD) - asymmetry parameter for sw+lw spectral band +! - for relative humidity dependent aerosol optical properties: +! species : water soluble (waso); sea salt acc mode(ssam); +! sea salt coa mode(sscm); sulfate droplets (suso). +! rh level: 00%, 50%, 70%, 80%, 90%, 95%, 98%, 99% +! extrhd(NRHLEV,NCM2,NSWLWBD) - extinction coefficient for sw+lw band +! scarhd(NRHLEV,NCM2,NSWLWBD) - scattering coefficient for sw+lw band +! ssarhd(NRHLEV,NCM2,NSWLWBD) - single scattering albedo for sw+lw band +! asyrhd(NRHLEV,NCM2,NSWLWBD) - asymmetry parameter for sw+lw band +! - for stratospheric aerosols optical properties: +! extstra(NSWLWBD) - extinction coefficient for sw+lw band + + real (kind=kind_phys), allocatable, save, dimension(:,:) :: & + & extrhi, scarhi, ssarhi, asyrhi + real (kind=kind_phys), allocatable, save, dimension(:,:,:) :: & + & extrhd, scarhd, ssarhd, asyrhd + real (kind=kind_phys), allocatable, save, dimension(:) :: & + & extstra + +! --- the following arrays are calculated in subr 'clim_aerinit' +! - for topospheric aerosol profile distibution: +! kprfg ( IMXAE*JMXAE) - aeros profile index +! idxcg (NXC*IMXAE*JMXAE) - aeros component index +! cmixg (NXC*IMXAE*JMXAE) - aeros component mixing ratio +! denng ( 2 *IMXAE*JMXAE) - aerosols number density + +!> \name topospheric aerosol profile distribution + +!> aeros component mixing ratio + real (kind=kind_phys), dimension(NXC,IMXAE,JMXAE), save :: cmixg +!> aeros number density + real (kind=kind_phys), dimension( 2 ,IMXAE,JMXAE), save :: denng +!> aeros component index + integer, dimension(NXC,IMXAE,JMXAE), save :: idxcg +!> aeros profile index + integer, dimension( IMXAE,JMXAE), save :: kprfg + +! --------------------------------------------------------------------- ! +! section-4 : module variables for gocart aerosol optical properties ! +! --------------------------------------------------------------------- ! + +!> \name module variables for gocart aerosol optical properties + +! --- parameters and constants: +! - KCM, KCM1, KCM2 are determined from subroutine 'set_aerspc' +!> num of bands for aer data (gocart) + integer, parameter :: KAERBND=61 +!> num of rh levels for rh-dep components + integer, parameter :: KRHLEV =36 +!* integer, parameter :: KCM1 = 8 ! num of rh independent aer !species +!* integer, parameter :: KCM2 = 5 ! num of rh dependent aer species +!* integer, parameter :: KCM = KCM1 + KCM2 +!> num of rh indep aerosols (set in subr set_aerspc) + integer, save :: KCM1 = 0 +!> num of rh dep aerosols (set in subr set_aerspc) + integer, save :: KCM2 = 0 +!> =KCM1+KCM2 (set in subr set_aerspc) + integer, save :: KCM + + real (kind=kind_phys), dimension(KRHLEV) :: rhlev_grt & + data rhlev_grt (:)/ .00, .05, .10, .15, .20, .25, .30, .35, & + & .40, .45, .50, .55, .60, .65, .70, .75, .80, .81, .82, & + & .83, .84, .85, .86, .87, .88, .89, .90, .91, .92, .93, & + & .94, .95, .96, .97, .98, .99 / + +! --- the following arrays are allocate and setup in subr 'gocrt_aerinit' +! ------ gocart aerosol specification ------ +! => transported aerosol species: +! DU (5-bins) +! SS (4 bins for climo mode and 5 bins for fcst mode) +! SU (dms, so2, so4, msa) +! OC (phobic, philic) and BC (phobic, philic) +! => species and lumped species for aerosol optical properties +! DU (5-bins, with 4 sub-groups in the submicron bin ) +! SS (ssam for submicron, sscm for coarse mode) +! SU (so4) +! OC (phobic, philic) and BC (phobic, philic) +! => specification used for aerosol optical properties luts +! DU (8 bins) +! SS (ssam, sscm) +! SU (suso) +! OC (waso) and BC (soot) +! +! - spectral band structure: +! iendwv_grt(KAERBND) - ending wavenumber (cm**-1) for each band +! - relative humidity independent aerosol optical properties: +! ===> species : dust (8 bins) +! rhidext0_grt(KAERBND,KCM1) - extinction coefficient +! rhidssa0_grt(KAERBND,KCM1) - single scattering albedo +! rhidasy0_grt(KAERBND,KCM1) - asymmetry parameter +! - relative humidity dependent aerosol optical properties: +! ===> species : soot, suso, waso, ssam, sscm +! rhdpext0_grt(KAERBND,KRHLEV,KCM2) - extinction coefficient +! rhdpssa0_grt(KAERBND,KRHLEV,KCM2) - single scattering albedo +! rhdpasy0_grt(KAERBND,KRHLEV,KCM2) - asymmetry parameter + +!> spectral band structure: ending wavenumber (\f$cm^-1\f$) for each band + integer, allocatable, dimension(:) :: iendwv_grt +! relative humidity independent aerosol optical properties: +!! species : dust (8 bins) + +!> \name relative humidity independent aerosol optical properties: +!! species : dust (8 bins) + +!> extinction coefficient + real (kind=kind_phys),allocatable, dimension(:,:) :: rhidext0_grt +!> single scattering albedo + real (kind=kind_phys),allocatable, dimension(:,:) :: rhidssa0_grt +!> asymmetry parameter + real (kind=kind_phys), allocatable, dimension(:,:) :: rhidasy0_grt +! +! relative humidity dependent aerosol optical properties: +! species : soot, suso, waso, ssam, sscm + +!> \name relative humidity dependent aerosol optical properties: +!! species : soot, suso, waso, ssam, sscm + +!> extinction coefficient + real (kind=kind_phys),allocatable,dimension(:,:,:) :: rhdpext0_grt +!> single scattering albedo + real (kind=kind_phys),allocatable,dimension(:,:,:) :: rhdpssa0_grt +!> asymmetry parameter + real (kind=kind_phys),allocatable,dimension(:,:,:) :: rhdpasy0_grt + +! - relative humidity independent aerosol optical properties: +! extrhi_grt(KCM1,NSWLWBD) - extinction coefficient for sw+lw spectral band +! ssarhi_grt(KCM1,NSWLWBD) - single scattering albedo for sw+lw spectral band +! asyrhi_grt(KCM1,NSWLWBD) - asymmetry parameter for sw+lw spectral band +! - relative humidity dependent aerosol optical properties: +! extrhd_grt(KRHLEV,KCM2,NSWLWBD) - extinction coefficient for sw+lw band +! ssarhd_grt(KRHLEV,KCM2,NSWLWBD) - single scattering albedo for sw+lw band +! asyrhd_grt(KRHLEV,KCM2,NSWLWBD) - asymmetry parameter for sw+lw band + +!>\name relative humidity independent aerosol optical properties + +!> extinction coefficient for SW+LW spectral band + real (kind=kind_phys),allocatable,save,dimension(:,:) :: & + & extrhi_grt +!> single scattering albedo for SW+LW spectral band + real (kind=kind_phys),allocatable,save,dimension(:,:) :: & + & ssarhi_grt +!> asymmetry parameter for SW+LW spectral band + real (kind=kind_phys),allocatable,save,dimension(:,:) :: & + & asyrhi_grt + +!> \name relative humidity dependent aerosol optical properties + +!> extinction coefficient for SW+LW spectral band + real (kind=kind_phys),allocatable,save,dimension(:,:,:) :: & + & extrhd_grt +!> single scattering albedo for SW+LW band + real (kind=kind_phys),allocatable,save,dimension(:,:,:) :: & + & ssarhd_grt +!> asymmetry parameter for SW+LW band + real (kind=kind_phys),allocatable,save,dimension(:,:,:) :: & + & asyrhd_grt + +!> \name module variables for gocart aerosol clim data set + +! --------------------------------------------------------------------- ! +! section-5 : module variables for gocart aerosol climo data set ! +! --------------------------------------------------------------------- ! +! This version only supports geos3-gocart data set (Jan 2010) +! Modified to support geos4-gocart data set (May 2010) +! +! geos3-gocart vs geos4-gocart +! (1) Use the same module variables +! IMXG,JMXG,KMXG,NMXG,psclmg,dmclmg,geos_rlon,geos_rlat +! (2) Similarity between geos3 and geos 4: +! identical lat/lon grids and aerosol specification; +! direction of vertical index is bottom-up (sfc to toa) +! (3) Difference between geos3 and geos4 +! vertical coordinate (sigma for geos3/hybrid_sigma_pressure for geos4) +! aerosol units (mass concentration for geos3/mixing ratio for geos4) + +!> num of lon-points in geos dataset + integer, parameter :: IMXG = 144 +!> num of lat-points in geos dataset + integer, parameter :: JMXG = 91 +!> num of vertical layers in geos dataset + integer, parameter :: KMXG = 30 +!* integer, parameter :: NMXG = 12 +!> to be determined by set_aerspc + integer, save :: NMXG + + real (kind=kind_phys), parameter :: dltx = 360.0 / float(IMXG) + real (kind=kind_phys), parameter :: dlty = 180.0 / float(JMXG-1) + +! --- the following arrays are allocated and setup in 'rd_gocart_clim' +! - geos-gocart climo data (input dataset) +! psclmg - pressure in cb IMXG*JMXG*KMXG +! dmclmg - aerosol dry mass in g/m3 IMXG*JMXG*KMXG*NMXG +! or aerosol mixing ratio in mol/mol or Kg/Kg + +!> pressure in cb + real (kind=kind_phys),allocatable, save:: psclmg(:,:,:) +!> aerosol dry mass in g/m3 or aerosol mixing ration in mol/mol or Kg/Kg + real (kind=kind_phys),allocatable, save:: dmclmg(:,:,:,:) + +! - geos-gocart lat/lon arrays +!> geos-gocart longitude arrays + real (kind=kind_phys), allocatable, save, dimension(:):: geos_rlon +!> geos-gocart latitude arrays + real (kind=kind_phys), allocatable, save, dimension(:):: geos_rlat + +!> control flag for gocart climo data set: xxxx as default; ver3 for geos3; +!! ver4 for geos4; 0000 for unknown data + character*4, save :: gocart_climo = 'xxxx' + +!> molecular wght of gocart aerosol species + real (kind=kind_io4), allocatable :: molwgt(:) + +! --------------------------------------------------------------------- +! ! +! section-6 : module variables for gocart aerosol scheme options +! ! +! --------------------------------------------------------------------- +! ! + +!> logical parameter for gocart initialization control + logical, save :: lgrtint = .true. + +!> logical parameter for gocart debug print control +! logical, save :: lckprnt = .true. + logical, save :: lckprnt = .false. + +! --- the following index/flag/weight are set up in 'set_aerspc' + +!> merging coefficients for fcst/clim; determined from fdaer + real (kind=kind_phys), save :: ctaer = f_zero ! user specified wgt + +!> option to get fcst gocart aerosol field + logical, save :: get_fcst = .true. +!> option to get clim gocart aerosol field + logical, save :: get_clim = .true. + +! ------ gocart aerosol specification ------ +! => transported aerosol species: +! DU (5-bins) +! SS (4 bins for climo mode and 5 bins for fcst mode) +! SU (dms, so2, so4, msa) +! OC (phobic, philic) and BC (phobic, philic) +! => species and lumped species for aerosol optical properties +! DU (5-bins, with 4 sub-groups in the submicron bin ) +! SS (ssam for submicron, sscm for coarse mode) +! SU (so4) +! OC (phobic, philic) and BC (phobic, philic) +! => specification used for aerosol optical properties luts +! DU (8 bins) +! SS (ssam, sscm) +! SU (suso) +! OC (waso) and BC (soot) +! + +!> index for rh dependent aerosol optical properties (2nd +!! dimension for extrhd_grt, ssarhd_grt, and asyrhd_grt) + integer, save :: isoot, iwaso, isuso, issam, isscm + +! - index for rh independent aerosol optical properties (1st +! dimension for extrhi_grt, ssarhi_grt, and asyrhi_grt) is +! not needed ===> hardwired to 8-bin dust + +! - index for gocart aerosol species to be included in the +! calculations of aerosol optical properties (ext, ssa, asy) +!> index for gocart aerosol species to be included in the +!! calculations of aerosol optical properties (ext, ssa, asy) + type gocart_index_type +! dust + integer :: dust1, dust2, dust3, dust4, dust5 +! sea salt + integer :: ssam, sscm +! sulfate + integer :: suso +! oc + integer :: waso_phobic, waso_philic +! bc + integer :: soot_phobic, soot_philic + endtype + type (gocart_index_type), save :: dm_indx + +!> index for gocart aerosols from prognostic tracer fields + type tracer_index_type +! dust + integer :: du001, du002, du003, du004, du005 +! sea salt + integer :: ss001, ss002, ss003, ss004, ss005 +! sulfate + integer :: so4 +! oc + integer :: ocphobic, ocphilic +! bc + integer :: bcphobic, bcphilic + endtype + type (tracer_index_type), save :: dmfcs_indx + +! - grid components to be included in the aeropt calculations +!> number of aerosol grid components + integer, save :: num_gridcomp = 0 +!> aerosol grid components + character, allocatable , save :: gridcomp(:)*2 + +!> default full-package setting + integer, parameter :: max_num_gridcomp = 5 +!> data max_gridcomp /'DU', 'BC', 'OC', 'SU', 'SS'/ + character*2 :: max_gridcomp(max_num_gridcomp) + data max_gridcomp /'DU', 'BC', 'OC', 'SU', 'SS'/ + +! GOCART code modification end here (Sarah Lu) +! ------------------------! +! ======================================================================= + +!! --- the following are for diagnostic purpose to output aerosol optical depth +! aod from 10 components are grouped into 5 major different species: +! 1:dust (inso,minm,miam,micm,mitr); 2:black carbon (soot) +! 3:water soluble (waso); 4:sulfate (suso); 5:sea salt (ssam,sscm) +! +! idxspc (NCM) - index conversion array +! lspcaod - logical flag for aod from individual species +! +!> index conversion array:data idxspc / 1, 2, 1, 1, 1, 1, 3, 5, 5, 4 / + integer, dimension(NCM) :: idxspc + data idxspc / 1, 2, 1, 1, 1, 1, 3, 5, 5, 4 / +! +! - wvn550 is the wavenumber (1/cm) of wavelenth 550nm for diagnostic aod output +! nv_aod is the sw spectral band covering wvn550 (comp in aer_init) +! +!> the wavenumber (\f$cm^-1\f$) of wavelength 550nm for diagnostic aod output + real (kind=kind_phys), parameter :: wvn550 = 1.0e4/0.55 +!> the sw spectral band covering wvn550 (comp in aer_init) + integer, save :: nv_aod = 1 + +! --- public interfaces + + public aer_init, aer_update, setaer + + +! ================= + contains +! ================= + +!> The initialization program is to set up necessary parameters and +!! working arrays. +!! +!>\param NLAY number of model vertical layers (not used) +!>\param me print message control flag +!>\section gen_al General Algorithm +!! @{ +!----------------------------------- + subroutine aer_init & + & ( NLAY, me ) ! --- inputs +! --- outputs: ( to module variables ) + +! ================================================================== ! +! ! +! aer_init is the initialization program to set up necessary ! +! parameters and working arrays. ! +! ! +! inputs: ! +! NLAY - number of model vertical layers (not used) ! +! me - print message control flag ! +! ! +! outputs: (to module variables) ! +! ! +! external module variables: (in physparam) ! +! iaermdl - tropospheric aerosol model scheme flag ! +! =0 opac-clim; =1 gocart-clim, =2 gocart-prognostic ! +! lalwflg - logical lw aerosols effect control flag ! +! =t compute lw aerosol optical prop ! +! laswflg - logical sw aerosols effect control flag ! +! =t compute sw aerosol optical prop ! +! lavoflg - logical stratosphere volcanic aerosol control flag ! +! =t include volcanic aerosol effect ! +! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! +! =t use 1 broad band optical property ! +! =f use multi bands optical property ! +! ! +! module constants: ! +! NWVSOL - num of wvnum regions where solar flux is constant ! +! NWVTOT - total num of wave numbers used in sw spectrum ! +! NWVTIR - total num of wave numbers used in the ir region ! +! NSWBND - total number of sw spectral bands ! +! NLWBND - total number of lw spectral bands ! +! ! +! usage: call aer_init ! +! ! +! subprograms called: clim_aerinit, gcrt_aerinit, ! +! wrt_aerlog, set_volcaer, set_spectrum, ! +! ! +! ================================================================== ! + +! --- inputs: + integer, intent(in) :: NLAY, me + +! --- output: ( none ) + +! --- locals: + real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux + real (kind=kind_phys), dimension(NWVTIR) :: eirfwv ! one wvn ir flux +! +!===> ... begin here +! + kyrstr = 1 + kyrend = 1 + kyrsav = 1 + kmonsav = 1 + +!> -# Call wrt_aerlog() to write aerosol parameter configuration to output logs. + + if ( me == 0 ) then + + call wrt_aerlog ! write aerosol param info to log file +! --- inputs: (in scope variables) +! --- outputs: ( none ) + + endif + + if ( iaerflg == 0 ) return ! return without any aerosol calculations + +! --- ... in sw, aerosols optical properties are computed for each radiation +! spectral band; while in lw, optical properties can be calculated +! for either only one broad band or for each of the lw radiation bands + + if ( laswflg ) then + NSWBND = NBDSW + else + NSWBND = 0 + endif + + if ( lalwflg ) then + if ( lalw1bd ) then + NLWBND = 1 + else + NLWBND = NBDLW + endif + else + NLWBND = 0 + endif + + NSWLWBD = NSWBND + NLWBND + + if ( iaerflg /= 100 ) then + +!> -# Call set_spectrum() to set up spectral one wavenumber solar/IR +!! fluxes. + + call set_spectrum +! --- inputs: (module constants) +! --- outputs: (in-scope variables) + +!> -# Call clim_aerinit() to invoke tropospheric aerosol initialization. + + if ( iaermdl == 0 ) then ! opac-climatology scheme + + call clim_aerinit & +! --- inputs: + & ( solfwv, eirfwv, me & +! --- outputs: + & ) + +! elseif ( iaermdl == 1 ) then ! gocart-climatology scheme +! elseif ( iaermdl==1 .or. iaermdl==2 ) then ! gocart-clim/prog scheme + +! call gcrt_climinit + +! elseif ( iaermdl == 2 ) then ! gocart-prognostic scheme + +! call gcrt_aerinit + + else + if ( me == 0 ) then + print *,' !!! ERROR in aerosol model scheme selection', & + & ' iaermdl =',iaermdl + stop + endif + endif + + endif ! end if_iaerflg_block + +!> -# Call set_volcaer() to invoke stratospheric volcanic aerosol +!! initialization. + + if ( lavoflg ) then + + call set_volcaer +! --- inputs: (module variables) +! --- outputs: (module variables) + + endif ! end if_lavoflg_block + + +! ================= + contains +! ================= + +!> This subroutine writes aerosol parameter configuration to run log file. +!-------------------------------- + subroutine wrt_aerlog +!................................ +! --- inputs: (in scope variables) +! --- outputs: ( none ) + +! ================================================================== ! +! ! +! subprogram : wrt_aerlog ! +! ! +! write aerosol parameter configuration to run log file. ! +! ! +! ==================== defination of variables =================== ! +! ! +! external module variables: (in physparam) ! +! iaermdl - aerosol scheme flag: 0:opac-clm; 1:gocart-clim; ! +! 2:gocart-prog ! +! iaerflg - aerosol effect control flag: 3-digits (volc,lw,sw) ! +! lalwflg - toposphere lw aerosol effect: =f:no; =t:yes ! +! laswflg - toposphere sw aerosol effect: =f:no; =t:yes ! +! lavoflg - stratospherer volcanic aeros effect: =f:no; =t:yes ! +! ! +! outputs: ( none ) ! +! ! +! subroutines called: none ! +! ! +! usage: call wrt_aerlog ! +! ! +! ================================================================== ! + +! --- inputs: ( none ) +! --- output: ( none ) +! --- locals: + +! +!===> ... begin here +! + print *, VTAGAER ! print out version tag + + if ( iaermdl == 0 ) then + print *,' - Using OPAC-seasonal climatology for tropospheric', & + & ' aerosol effect' + elseif ( iaermdl == 1 ) then + print *,' - Using GOCART-climatology for tropospheric', & + & ' aerosol effect' + elseif ( iaermdl == 2 ) then + print *,' - Using GOCART-prognostic aerosols for tropospheric', & + & ' aerosol effect' + else + print *,' !!! ERROR in selection of aerosol model scheme', & + & ' IAER_MDL =',iaermdl + stop + endif ! end_if_iaermdl_block + + print *,' IAER=',iaerflg,' LW-trop-aer=',lalwflg, & + & ' SW-trop-aer=',laswflg,' Volc-aer=',lavoflg + + if ( iaerflg <= 0 ) then ! turn off all aerosol effects + print *,' - No tropospheric/volcanic aerosol effect included' + print *,' Input values of aerosol optical properties to' & + & ,' both SW and LW radiations are set to zeros' + else + if ( iaerflg >= 100 ) then ! incl stratospheric volcanic aerosols + print *,' - Include stratospheric volcanic aerosol effect' + else ! no stratospheric volcanic aerosols + print *,' - No stratospheric volcanic aerosol effect' + endif + + if ( laswflg ) then ! chcek for sw effect + print *,' - Compute multi-band aerosol optical' & + & ,' properties for SW input parameters' + else + print *,' - No SW radiation aerosol effect, values of' & + & ,' aerosol properties to SW input are set to zeros' + endif + + if ( lalwflg ) then ! check for lw effect + if ( lalw1bd ) then + print *,' - Compute 1 broad-band aerosol optical' & + & ,' properties for LW input parameters' + else + print *,' - Compute multi-band aerosol optical' & + & ,' properties for LW input parameters' + endif + else + print *,' - No LW radiation aerosol effect, values of' & + & ,' aerosol properties to LW input are set to zeros' + endif + endif ! end if_iaerflg_block +! + return +!................................ + end subroutine wrt_aerlog +!-------------------------------- + +!> This subroutine defines the one wavenumber solar fluxes based on toa +!! solar spectral distribution, and define the one wavenumber IR fluxes +!! based on black-body emission distribution at a predefined temperature. +!>\section gel_set_spec General Algorithm +!-------------------------------- + subroutine set_spectrum +!................................ +! --- inputs: (module constants) +! --- outputs: (in-scope variables) + +! ================================================================== ! +! ! +! subprogram : set_spectrum ! +! ! +! define the one wavenumber solar fluxes based on toa solar spectral! +! distrobution, and define the one wavenumber ir fluxes based on ! +! black-body emission distribution at a predefined temperature. ! +! ! +! ==================== defination of variables =================== ! +! ! +!> - inputs: (module constants) +!! - NWVTOT: total num of wave numbers used in sw spectrum +!! - NWVTIR: total num of wave numbers used in the ir region +!! +!> - outputs: (in-scope variables) +!! - solfwv(NWVTOT): solar flux for each individual wavenumber +!! (\f$W/m^2\f$) +!! - eirfwv(NWVTIR): ir flux(273k) for each individual wavenumber +!! (\f$W/m^2\f$) +! ! +! subroutines called: none ! +! ! +! usage: call set_spectrum ! +! ! +! ================================================================== ! + +! --- inputs: (module constants) +! integer :: NWVTOT, NWVTIR + +! --- output: (in-scope variables) +! real (kind=kind_phys), dimension(NWVTOT) :: solfwv ! one wvn sol flux +! real (kind=kind_phys), dimension(NWVTIR) :: eirfwv ! one wvn ir flux + +! --- locals: + real (kind=kind_phys) :: soltot, tmp1, tmp2, tmp3 + + integer :: nb, nw, nw1, nw2, nmax, nmin +! +!===> ... begin here +! +! nmax = min( NWVTOT, nint( maxval(wvnsw2) )) +! nmin = max( 1, nint( minval(wvnsw1) )) + +! --- check print +! print *,' MINWVN, MAXWVN = ',nmin, nmax +! --- ... define the one wavenumber solar fluxes based on toa solar +! spectral distribution + +! soltot1 = f_zero +! soltot = f_zero + do nb = 1, NWVSOL + if ( nb == 1 ) then + nw1 = 1 + else + nw1 = nw1 + nwvns0(nb-1) + endif + + nw2 = nw1 + nwvns0(nb) - 1 + + do nw = nw1, nw2 + solfwv(nw) = s0intv(nb) +! soltot1 = soltot1 + s0intv(nb) +! if ( nw >= nmin .and. nw <= nmax ) then +! soltot = soltot + s0intv(nb) +! endif + enddo + enddo + +! --- ... define the one wavenumber ir fluxes based on black-body +! emission distribution at a predefined temperature + + tmp1 = (con_pi + con_pi) * con_plnk * con_c* con_c + tmp2 = con_plnk * con_c / (con_boltz * con_t0c) + +!$omp parallel do private(nw,tmp3) + do nw = 1, NWVTIR + tmp3 = 100.0 * nw + eirfwv(nw) = (tmp1 * tmp3**3) / (exp(tmp2*tmp3) - 1.0) + enddo +! + return +!................................ + end subroutine set_spectrum +!-------------------------------- + + +!> The initialization program for stratospheric volcanic aerosols. +!----------------------------- + subroutine set_volcaer +!............................. +! --- inputs: ( none ) +! --- outputs: (module variables) + +! ================================================================== ! +! ! +! subprogram : set_volcaer ! +! ! +! this is the initialization progrmam for stratospheric volcanic ! +! aerosols. ! +! ! +! subroutines called: none ! +! ! +! usage: call set_volcaer ! +! ! +! ================================================================== ! + +! --- inputs: (none) + +! --- output: (module variables) +! integer :: ivolae(:,:,:) + +! --- locals: +! +!===> ... begin here +! +! --- allocate data space + + if ( .not. allocated(ivolae) ) then + allocate ( ivolae(12,4,10) ) ! for 12-mon,4-lat_zone,10-year + endif +! + return +!................................ + end subroutine set_volcaer +!-------------------------------- +! +!................................... + end subroutine aer_init +!----------------------------------- +!!@} + + +!> This subroutine is the opac-climatology aerosol initialization +!! program to set up necessary parameters and working arrays. +!>\param solfwv (NWVTOT), solar flux for each individual wavenumber +!! \f$(w/m^2)\f$ +!!\param eirfwv (NWVTIR), IR flux(273k) for each individual wavenumber +!! \f$(w/m^2)\f$ +!!\param me print message control flag +!! +!!\section gen_clim_aerinit General Algorithm +!!@{ +!----------------------------------- + subroutine clim_aerinit & + & ( solfwv, eirfwv, me & ! --- inputs + & ) ! --- outputs + +! ================================================================== ! +! ! +! clim_aerinit is the opac-climatology aerosol initialization program ! +! to set up necessary parameters and working arrays. ! +! ! +! inputs: ! +! solfwv(NWVTOT) - solar flux for each individual wavenumber (w/m2)! +! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! +! me - print message control flag ! +! ! +! outputs: (to module variables) ! +! ! +! external module variables: (in physparam) ! +! iaerflg - abc 3-digit integer aerosol flag (abc:volc,lw,sw) ! +! a: =0 use background stratospheric aerosol ! +! =1 incl stratospheric vocanic aeros (MINVYR-MAXVYR) ! +! b: =0 no topospheric aerosol in lw radiation ! +! =1 include tropspheric aerosols for lw radiation ! +! c: =0 no topospheric aerosol in sw radiation ! +! =1 include tropspheric aerosols for sw radiation ! +! lalwflg - logical lw aerosols effect control flag ! +! =t compute lw aerosol optical prop ! +! laswflg - logical sw aerosols effect control flag ! +! =t compute sw aerosol optical prop ! +! lalw1bd = logical lw aeros propty 1 band vs multi-band cntl flag ! +! =t use 1 broad band optical property ! +! =f use multi bands optical property ! +! ! +! module constants: ! +! NWVSOL - num of wvnum regions where solar flux is constant ! +! NWVTOT - total num of wave numbers used in sw spectrum ! +! NWVTIR - total num of wave numbers used in the ir region ! +! NSWBND - total number of sw spectral bands ! +! NLWBND - total number of lw spectral bands ! +! NAERBND - number of bands for climatology aerosol data ! +! NCM1 - number of rh independent aeros species ! +! NCM2 - number of rh dependent aeros species ! +! ! +! usage: call clim_aerinit ! +! ! +! subprograms called: set_aercoef, optavg ! +! ! +! ================================================================== ! + +! --- inputs: + real (kind=kind_phys), dimension(:) :: solfwv ! one wvn sol flux + real (kind=kind_phys), dimension(:) :: eirfwv ! one wvn ir flux + + integer, intent(in) :: me + +! --- output: ( none ) + +! --- locals: + real (kind=kind_phys), dimension(NAERBND,NCM1) :: & + & rhidext0, rhidsca0, rhidssa0, rhidasy0 + real (kind=kind_phys), dimension(NAERBND,NRHLEV,NCM2):: & + & rhdpext0, rhdpsca0, rhdpssa0, rhdpasy0 + real (kind=kind_phys), dimension(NAERBND) :: straext0 + + real (kind=kind_phys), dimension(NSWBND,NAERBND) :: solwaer + real (kind=kind_phys), dimension(NSWBND) :: solbnd + real (kind=kind_phys), dimension(NLWBND,NAERBND) :: eirwaer + real (kind=kind_phys), dimension(NLWBND) :: eirbnd + + integer, dimension(NSWBND) :: nv1, nv2 + integer, dimension(NLWBND) :: nr1, nr2 +! +!===> ... begin here +! +! --- ... invoke tropospheric aerosol initialization + +!> - call set_aercoef() to invoke tropospheric aerosol initialization. + call set_aercoef +! --- inputs: (in-scope variables, module constants) +! --- outputs: (module variables) + + +! ================= + contains +! ================= + +!> The initialization program for climatological aerosols. The program +!! reads and maps the pre-tabulated aerosol optical spectral data onto +!! corresponding SW radiation spectral bands. +!!\section det_set_aercoef General Algorithm +!! @{ +!-------------------------------- + subroutine set_aercoef +!................................ +! --- inputs: (in-scope variables, module constants) +! --- outputs: (module variables) + +! ================================================================== ! +! ! +! subprogram : set_aercoef ! +! ! +! this is the initialization progrmam for climatological aerosols ! +! ! +! the program reads and maps the pre-tabulated aerosol optical ! +! spectral data onto corresponding sw radiation spectral bands. ! +! ! +! ==================== defination of variables =================== ! +! ! +! inputs: (in-scope variables, module constants) ! +! solfwv(:) - real, solar flux for individual wavenumber (w/m2) ! +! eirfwv(:) - real, lw flux(273k) for individual wavenum (w/m2) ! +! me - integer, select cpu number as print control flag ! +! ! +! outputs: (to the module variables) ! +! ! +! external module variables: (in physparam) ! +! lalwflg - module control flag for lw trop-aer: =f:no; =t:yes ! +! laswflg - module control flag for sw trop-aer: =f:no; =t:yes ! +! aeros_file- external aerosol data file name ! +! ! +! internal module variables: ! +! IMXAE - number of longitude points in global aeros data set ! +! JMXAE - number of latitude points in global aeros data set ! +! wvnsw1,wvnsw2 (NSWSTR:NSWEND) ! +! - start/end wavenumbers for each of sw bands ! +! wvnlw1,wvnlw2 ( 1:NBDLW) ! +! - start/end wavenumbers for each of lw bands ! +! NSWLWBD - total num of bands (sw+lw) for aeros optical properties! +! NSWBND - number of sw spectral bands actually invloved ! +! NLWBND - number of lw spectral bands actually invloved ! +! NIAERCM - unit number for reading input data set ! +! extrhi - extinction coef for rh-indep aeros NCM1*NSWLWBD! +! scarhi - scattering coef for rh-indep aeros NCM1*NSWLWBD! +! ssarhi - single-scat-alb for rh-indep aeros NCM1*NSWLWBD! +! asyrhi - asymmetry factor for rh-indep aeros NCM1*NSWLWBD! +! extrhd - extinction coef for rh-dep aeros NRHLEV*NCM2*NSWLWBD! +! scarhd - scattering coef for rh-dep aeros NRHLEV*NCM2*NSWLWBD! +! ssarhd - single-scat-alb for rh-dep aeros NRHLEV*NCM2*NSWLWBD! +! asyrhd - asymmetry factor for rh-dep aeros NRHLEV*NCM2*NSWLWBD! +! ! +! major local variables: ! +! for handling spectral band structures ! +! iendwv - ending wvnum (cm**-1) for each band NAERBND ! +! for handling optical properties of rh independent species (NCM1) ! +! 1. insoluble (inso); 2. soot (soot); ! +! 3. mineral nuc mode (minm); 4. mineral acc mode (miam); ! +! 5. mineral coa mode (micm); 6. mineral transport(mitr). ! +! rhidext0 - extinction coefficient NAERBND*NCM1 ! +! rhidsca0 - scattering coefficient NAERBND*NCM1 ! +! rhidssa0 - single scattering albedo NAERBND*NCM1 ! +! rhidasy0 - asymmetry parameter NAERBND*NCM1 ! +! for handling optical properties of rh ndependent species (NCM2) ! +! 1. water soluble (waso); 2. sea salt acc mode(ssam); ! +! 3. sea salt coa mode(sscm); 4. sulfate droplets (suso). ! +! rh level (NRHLEV): 00%, 50%, 70%, 80%, 90%, 95%, 98%, 99% ! +! rhdpext0 - extinction coefficient NAERBND,NRHLEV,NCM2! +! rhdpsca0 - scattering coefficient NAERBND,NRHLEV,NCM2! +! rhdpssa0 - single scattering albedo NAERBND,NRHLEV,NCM2! +! rhdpasy0 - asymmetry parameter NAERBND,NRHLEV,NCM2! +! for handling optical properties of stratospheric bkgrnd aerosols ! +! straext0 - extingction coefficients NAERBND ! +! ! +! usage: call set_aercoef ! +! ! +! subprograms called: optavg ! +! ! +! ================================================================== ! +! +! --- inputs: ( none ) +! --- output: ( none ) + +! --- locals: + integer, dimension(NAERBND) :: iendwv + + integer :: i, j, k, m, mb, ib, ii, id, iw, iw1, iw2 + + real (kind=kind_phys) :: sumsol, sumir + + logical :: file_exist + character :: cline*80 +! +!===> ... begin here +! +!> -# Reading climatological aerosols optical data from aeros_file, +!! including: + + inquire (file=aeros_file, exist=file_exist) + + if ( file_exist ) then + close (NIAERCM) + open (unit=NIAERCM,file=aeros_file,status='OLD', & + & action='read',form='FORMATTED') + rewind (NIAERCM) + else + print *,' Requested aerosol data file "',aeros_file, & + & '" not found!' + print *,' *** Stopped in subroutine aero_init !!' + stop + endif ! end if_file_exist_block + +! --- ... skip monthly global distribution + + do m = 1, 12 + read (NIAERCM,12) cline + 12 format(a80/) + + do j = 1, JMXAE + do i = 1, IMXAE + read(NIAERCM,*) id + enddo + enddo + enddo ! end do_m_block + +! --- ... aloocate and input aerosol optical data + + if ( .not. allocated( extrhi ) ) then + allocate ( extrhi ( NCM1,NSWLWBD) ) + allocate ( scarhi ( NCM1,NSWLWBD) ) + allocate ( ssarhi ( NCM1,NSWLWBD) ) + allocate ( asyrhi ( NCM1,NSWLWBD) ) + allocate ( extrhd (NRHLEV,NCM2,NSWLWBD) ) + allocate ( scarhd (NRHLEV,NCM2,NSWLWBD) ) + allocate ( ssarhd (NRHLEV,NCM2,NSWLWBD) ) + allocate ( asyrhd (NRHLEV,NCM2,NSWLWBD) ) + allocate ( extstra( NSWLWBD) ) + endif + +!> - ending wave num for 61 aerosol spectral bands + read(NIAERCM,21) cline + 21 format(a80) + read(NIAERCM,22) iendwv(:) + 22 format(13i6) + +!> - atmos scale height for 5 domains, 7 profs + read(NIAERCM,21) cline + read(NIAERCM,24) haer(:,:) + 24 format(20f4.1) + +!> - reference pressure for 5 domains, 7 profs + read(NIAERCM,21) cline + read(NIAERCM,26) prsref(:,:) + 26 format(10f7.2) + +!> - rh independent ext coef for 61 bands, 6 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhidext0(:,:) + 28 format(8e10.3) + +!> - rh independent sca coef for 61 bands, 6 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhidsca0(:,:) + +!> - rh independent ssa coef for 61 bands, 6 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhidssa0(:,:) + +!> - rh independent asy coef for 61 bands, 6 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhidasy0(:,:) + +!> - rh dependent ext coef for 61 bands, 8 rh lev, 4 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhdpext0(:,:,:) + +!> - rh dependent sca coef for 61 bands, 8 rh lev, 4 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhdpsca0(:,:,:) + +!> - rh dependent ssa coef for 61 bands, 8 rh lev, 4 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhdpssa0(:,:,:) + +!> - rh dependent asy coef for 61 bands, 8 rh lev, 4 species + read(NIAERCM,21) cline + read(NIAERCM,28) rhdpasy0(:,:,:) + +!> - stratospheric background aeros for 61 bands + read(NIAERCM,21) cline + read(NIAERCM,28) straext0(:) + + close (NIAERCM) + +!> -# Convert pressure reference level (in mb) to sigma reference level +!! assume an 1000mb reference surface pressure. + + sigref(:,:) = 0.001 * prsref(:,:) + +!> -# Compute solar flux weights and interval indices for mapping +!! spectral bands between SW radiation and aerosol data. + + if ( laswflg ) then + solbnd (:) = f_zero +!$omp parallel do private(i,j) + do j=1,naerbnd + do i=1,nswbnd + solwaer(i,j) = f_zero + enddo + enddo + +!$omp parallel do private(ib,mb,ii,iw1,iw2,iw,nv_aod,sumsol) + do ib = 1, NSWBND + mb = ib + NSWSTR - 1 + ii = 1 + iw1 = nint(wvnsw1(mb)) + iw2 = nint(wvnsw2(mb)) + + if ( wvnsw2(mb) >= wvn550 .and. wvn550 >= wvnsw1(mb) ) then + nv_aod = ib ! sw band number covering 550nm wavelenth + endif + + Lab_swdowhile : do while ( iw1 > iendwv(ii) ) + if ( ii == NAERBND ) exit Lab_swdowhile + ii = ii + 1 + enddo Lab_swdowhile + + sumsol = f_zero + nv1(ib) = ii + + do iw = iw1, iw2 + solbnd(ib) = solbnd(ib) + solfwv(iw) + sumsol = sumsol + solfwv(iw) + + if ( iw == iendwv(ii) ) then + solwaer(ib,ii) = sumsol + + if ( ii < NAERBND ) then + sumsol = f_zero + ii = ii + 1 + endif + endif + enddo + + if ( iw2 /= iendwv(ii) ) then + solwaer(ib,ii) = sumsol + endif + + nv2(ib) = ii +! frcbnd(ib) = solbnd(ib) / soltot + enddo ! end do_ib_block for sw + endif ! end if_laswflg_block + +!> -# Compute LW flux weights and interval indices for mapping +!! spectral bands between lw radiation and aerosol data. + + if ( lalwflg ) then + eirbnd (:) = f_zero +!$omp parallel do private(i,j) + do j=1,naerbnd + do i=1,nlwbnd + eirwaer(i,j) = f_zero + enddo + enddo + +!$omp parallel do private(ib,ii,iw1,iw2,iw,mb,sumir) + do ib = 1, NLWBND + ii = 1 + if ( NLWBND == 1 ) then +! iw1 = 250 ! corresponding 40 mu + iw1 = 400 ! corresponding 25 mu + iw2 = 2500 ! corresponding 4 mu + else + mb = ib + NLWSTR - 1 + iw1 = nint(wvnlw1(mb)) + iw2 = nint(wvnlw2(mb)) + endif + + Lab_lwdowhile : do while ( iw1 > iendwv(ii) ) + if ( ii == NAERBND ) exit Lab_lwdowhile + ii = ii + 1 + enddo Lab_lwdowhile + + sumir = f_zero + nr1(ib) = ii + + do iw = iw1, iw2 + eirbnd(ib) = eirbnd(ib) + eirfwv(iw) + sumir = sumir + eirfwv(iw) + + if ( iw == iendwv(ii) ) then + eirwaer(ib,ii) = sumir + + if ( ii < NAERBND ) then + sumir = f_zero + ii = ii + 1 + endif + endif + enddo + + if ( iw2 /= iendwv(ii) ) then + eirwaer(ib,ii) = sumir + endif + + nr2(ib) = ii + enddo ! end do_ib_block for lw + endif ! end if_lalwflg_block + +!> -# Call optavg() to compute spectral band mean properties for each +!! species. + + call optavg +! --- inputs: (in-scope variables, module variables) +! --- outputs: (module variables) + +! --- check print +! do ib = 1, NSWBND +! print *,' After optavg, for sw band:',ib +! print *,' extrhi:', extrhi(:,ib) +! print *,' scarhi:', scarhi(:,ib) +! print *,' ssarhi:', ssarhi(:,ib) +! print *,' asyrhi:', asyrhi(:,ib) +! mb = ib + NSWSTR - 1 +! print *,' wvnsw1,wvnsw2 :',wvnsw1(mb),wvnsw2(mb) +! do i = 1, NRHLEV +! print *,' extrhd for rhlev:',i +! print *,extrhd(i,:,ib) +! print *,' scarhd for rhlev:',i +! print *,scarhd(i,:,ib) +! print *,' ssarhd for rhlev:',i +! print *,ssarhd(i,:,ib) +! print *,' asyrhd for rhlev:',i +! print *,asyrhd(i,:,ib) +! enddo +! print *,' extstra:', extstra(ib) +! enddo +! print *,' wvnlw1 :',wvnlw1 +! print *,' wvnlw2 :',wvnlw2 +! do ib = 1, NLWBND +! ii = NSWBND + ib +! print *,' After optavg, for lw band:',ib +! print *,' extrhi:', extrhi(:,ii) +! print *,' scarhi:', scarhi(:,ii) +! print *,' ssarhi:', ssarhi(:,ii) +! print *,' asyrhi:', asyrhi(:,ii) +! do i = 1, NRHLEV +! print *,' extrhd for rhlev:',i +! print *,extrhd(i,:,ii) +! print *,' scarhd for rhlev:',i +! print *,scarhd(i,:,ii) +! print *,' ssarhd for rhlev:',i +! print *,ssarhd(i,:,ii) +! print *,' asyrhd for rhlev:',i +! print *,asyrhd(i,:,ii) +! enddo +! print *,' extstra:', extstra(ii) +! enddo +! + return +!................................ + end subroutine set_aercoef +!-------------------------------- +!! @} + +!> This subroutine computes mean aerosols optical properties over each +!! SW radiation spectral band for each of the species components. This +!! program follows GFDL's approach for thick cloud optical property in +!! SW radiation scheme (2000). +!-------------------------------- + subroutine optavg +!................................ +! --- inputs: (in-scope variables, module variables +! --- outputs: (module variables) + +! ==================================================================== ! +! ! +! subprogram: optavg ! +! ! +! compute mean aerosols optical properties over each sw radiation ! +! spectral band for each of the species components. This program ! +! follows gfdl's approach for thick cloud opertical property in ! +! sw radiation scheme (2000). ! +! ! +! ==================== defination of variables =================== ! +! ! +! major input variables: ! +! nv1,nv2 (NSWBND) - start/end spectral band indices of aerosol data ! +! for each sw radiation spectral band ! +! nr1,nr2 (NLWBND) - start/end spectral band indices of aerosol data ! +! for each ir radiation spectral band ! +! solwaer (NSWBND,NAERBND) ! +! - solar flux weight over each sw radiation band ! +! vs each aerosol data spectral band ! +! eirwaer (NLWBND,NAERBND) ! +! - ir flux weight over each lw radiation band ! +! vs each aerosol data spectral band ! +! solbnd (NSWBND) - solar flux weight over each sw radiation band ! +! eirbnd (NLWBND) - ir flux weight over each lw radiation band ! +! NSWBND - total number of sw spectral bands ! +! NLWBND - total number of lw spectral bands ! +! ! +! external module variables: (in physparam) ! +! laswflg - control flag for sw spectral region ! +! lalwflg - control flag for lw spectral region ! +! ! +! output variables: (to module variables) ! +! ! +! ================================================================== ! + +! --- inputs: +! --- output: + +! --- locals: + real (kind=kind_phys) :: sumk, sums, sumok, sumokg, sumreft, & + & sp, refb, reft, rsolbd, rirbd + + integer :: ib, nb, ni, nh, nc +! +!===> ... begin here +! +! --- ... loop for each sw radiation spectral band + + if ( laswflg ) then + +!$omp parallel do private(nb,nc,sumk,sums,sumok,sumokg,sumreft) +!$omp+private(ni,nh,sp,reft,refb,rsolbd) + do nb = 1, NSWBND + rsolbd = f_one / solbnd(nb) + +! --- for rh independent aerosol species + + do nc = 1, NCM1 ! --- for rh independent aerosol species + sumk = f_zero + sums = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nv1(nb), nv2(nb) + sp = sqrt( (f_one - rhidssa0(ni,nc)) & + & / (f_one - rhidssa0(ni,nc)*rhidasy0(ni,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*solwaer(nb,ni) + + sumk = sumk + rhidext0(ni,nc)*solwaer(nb,ni) + sums = sums + rhidsca0(ni,nc)*solwaer(nb,ni) + sumok = sumok + rhidssa0(ni,nc)*solwaer(nb,ni) & + & * rhidext0(ni,nc) + sumokg = sumokg + rhidssa0(ni,nc)*solwaer(nb,ni) & + & * rhidext0(ni,nc)*rhidasy0(ni,nc) + enddo + + refb = sumreft * rsolbd + + extrhi(nc,nb) = sumk * rsolbd + scarhi(nc,nb) = sums * rsolbd + asyrhi(nc,nb) = sumokg / (sumok + 1.0e-10) + ssarhi(nc,nb) = 4.0*refb & + & / ( (f_one+refb)**2 - asyrhi(nc,nb)*(f_one-refb)**2 ) + enddo ! end do_nc_block for rh-ind aeros + + + do nc = 1, NCM2 ! --- for rh dependent aerosols species + do nh = 1, NRHLEV + sumk = f_zero + sums = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nv1(nb), nv2(nb) + sp = sqrt( (f_one - rhdpssa0(ni,nh,nc)) & + & / (f_one - rhdpssa0(ni,nh,nc)*rhdpasy0(ni,nh,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*solwaer(nb,ni) + + sumk = sumk + rhdpext0(ni,nh,nc)*solwaer(nb,ni) + sums = sums + rhdpsca0(ni,nh,nc)*solwaer(nb,ni) + sumok = sumok + rhdpssa0(ni,nh,nc)*solwaer(nb,ni) & + & * rhdpext0(ni,nh,nc) + sumokg = sumokg + rhdpssa0(ni,nh,nc)*solwaer(nb,ni) & + & * rhdpext0(ni,nh,nc)*rhdpasy0(ni,nh,nc) + enddo + + refb = sumreft * rsolbd + + extrhd(nh,nc,nb) = sumk * rsolbd + scarhd(nh,nc,nb) = sums * rsolbd + asyrhd(nh,nc,nb) = sumokg / (sumok + 1.0e-10) + ssarhd(nh,nc,nb) = 4.0*refb & + & / ( (f_one+refb)**2 - asyrhd(nh,nc,nb)*(f_one-refb)**2 ) + enddo ! end do_nh_block + enddo ! end do_nc_block for rh-dep aeros + +! --- for stratospheric background aerosols + + sumk = f_zero + do ni = nv1(nb), nv2(nb) + sumk = sumk + straext0(ni)*solwaer(nb,ni) + enddo + + extstra(nb) = sumk * rsolbd + +! --- check print +! if ( nb > 6 .and. nb < 10) then +! print *,' in optavg for sw band',nb +! print *,' nv1, nv2:',nv1(nb),nv2(nb) +! print *,' solwaer:',solwaer(nb,nv1(nb):nv2(nb)) +! print *,' extrhi:', extrhi(:,nb) +! do i = 1, NRHLEV +! print *,' extrhd for rhlev:',i +! print *,extrhd(i,:,nb) +! enddo +! print *,' sumk, rsolbd, extstra:',sumk,rsolbd,extstra(nb) +! endif + + enddo ! end do_nb_block for sw + endif ! end if_laswflg_block + +! --- ... loop for each lw radiation spectral band + + if ( lalwflg ) then + +!$omp parallel do private(nb,ib,nc,rirbd,sumk,sums,sumok,sumokg,sumreft) +!$omp+private(ni,nh,sp,reft,refb,rsolbd) + do nb = 1, NLWBND + + ib = NSWBND + nb + rirbd = f_one / eirbnd(nb) + + do nc = 1, NCM1 ! --- for rh independent aerosol species + sumk = f_zero + sums = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nr1(nb), nr2(nb) + sp = sqrt( (f_one - rhidssa0(ni,nc)) & + & / (f_one - rhidssa0(ni,nc)*rhidasy0(ni,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*eirwaer(nb,ni) + + sumk = sumk + rhidext0(ni,nc)*eirwaer(nb,ni) + sums = sums + rhidsca0(ni,nc)*eirwaer(nb,ni) + sumok = sumok + rhidssa0(ni,nc)*eirwaer(nb,ni) & + & * rhidext0(ni,nc) + sumokg = sumokg + rhidssa0(ni,nc)*eirwaer(nb,ni) & + & * rhidext0(ni,nc)*rhidasy0(ni,nc) + enddo + + refb = sumreft * rirbd + + extrhi(nc,ib) = sumk * rirbd + scarhi(nc,ib) = sums * rirbd + asyrhi(nc,ib) = sumokg / (sumok + 1.0e-10) + ssarhi(nc,ib) = 4.0*refb & + & / ( (f_one+refb)**2 - asyrhi(nc,ib)*(f_one-refb)**2 ) + enddo ! end do_nc_block for rh-ind aeros + + do nc = 1, NCM2 ! --- for rh dependent aerosols species + do nh = 1, NRHLEV + sumk = f_zero + sums = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nr1(nb), nr2(nb) + sp = sqrt( (f_one - rhdpssa0(ni,nh,nc)) & + & / (f_one - rhdpssa0(ni,nh,nc)*rhdpasy0(ni,nh,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*eirwaer(nb,ni) + + sumk = sumk + rhdpext0(ni,nh,nc)*eirwaer(nb,ni) + sums = sums + rhdpsca0(ni,nh,nc)*eirwaer(nb,ni) + sumok = sumok + rhdpssa0(ni,nh,nc)*eirwaer(nb,ni) & + & * rhdpext0(ni,nh,nc) + sumokg = sumokg + rhdpssa0(ni,nh,nc)*eirwaer(nb,ni) & + & * rhdpext0(ni,nh,nc)*rhdpasy0(ni,nh,nc) + enddo + + refb = sumreft * rirbd + + extrhd(nh,nc,ib) = sumk * rirbd + scarhd(nh,nc,ib) = sums * rirbd + asyrhd(nh,nc,ib) = sumokg / (sumok + 1.0e-10) + ssarhd(nh,nc,ib) = 4.0*refb & + & / ( (f_one+refb)**2 - asyrhd(nh,nc,ib)*(f_one-refb)**2 ) + enddo ! end do_nh_block + enddo ! end do_nc_block for rh-dep aeros + +! --- for stratospheric background aerosols + + sumk = f_zero + do ni = nr1(nb), nr2(nb) + sumk = sumk + straext0(ni)*eirwaer(nb,ni) + enddo + + extstra(ib) = sumk * rirbd + +! --- check print +! if ( nb >= 1 .and. nb < 5) then +! print *,' in optavg for ir band:',nb +! print *,' nr1, nr2:',nr1(nb),nr2(nb) +! print *,' eirwaer:',eirwaer(nb,nr1(nb):nr2(nb)) +! print *,' extrhi:', extrhi(:,ib) +! do i = 1, NRHLEV +! print *,' extrhd for rhlev:',i +! print *,extrhd(i,:,ib) +! enddo +! print *,' sumk, rirbd, extstra:',sumk,rirbd,extstra(ib) +! endif + + enddo ! end do_nb_block for lw + endif ! end if_lalwflg_block +! + return +!................................ + end subroutine optavg +!-------------------------------- +! +!................................... + end subroutine clim_aerinit +!----------------------------------- +!!@} + + +!> This subroutine checks and updates time varying climatology aerosol +!! data sets. +!! +!>\param iyear 4-digit calender year +!!\param imon month of the year +!!\param me print message control flag +!>\section gen_aer_upd General Algorithm +!! @{ +!----------------------------------- + subroutine aer_update & + & ( iyear, imon, me ) ! --- inputs: +! --- outputs: ( to module variables ) + +! ================================================================== ! +! ! +! aer_update checks and update time varying climatology aerosol ! +! data sets. ! +! ! +! inputs: size ! +! iyear - 4-digit calender year 1 ! +! imon - month of the year 1 ! +! me - print message control flag 1 ! +! ! +! outputs: ( none ) ! +! ! +! external module variables: (in physparam) ! +! lalwflg - control flag for tropospheric lw aerosol ! +! laswflg - control flag for tropospheric sw aerosol ! +! lavoflg - control flag for stratospheric volcanic aerosol ! +! ! +! usage: call aero_update ! +! ! +! subprograms called: trop_update, volc_update ! +! ! +! ================================================================== ! + +! --- inputs: + integer, intent(in) :: iyear, imon, me + +! --- output: ( none ) + +! --- locals: ( none ) +! +!===> ... begin here +! + if ( imon < 1 .or. imon > 12 ) then + print *,' ***** ERROR in specifying requested month !!! ', & + & 'imon=', imon + print *,' ***** STOPPED in subroutinte aer_update !!!' + stop + endif + +!> -# Call trop_update() to update monthly tropospheric aerosol data. + if ( lalwflg .or. laswflg ) then + call trop_update + endif + +!> -# Call volc_update() to update yearly stratospheric volcanic aerosol data. + if ( lavoflg ) then + call volc_update + endif + + +! ================= + contains +! ================= + +!> This subroutine updates the monthly global distribution of aerosol +!! profiles in five degree horizontal resolution. +!-------------------------------- + subroutine trop_update +!................................ +! --- inputs: (in scope variables, module variables) +! --- outputs: (module variables) + +! ================================================================== ! +! ! +! subprogram : trop_update ! +! ! +! updates the monthly global distribution of aerosol profiles in ! +! five degree horizontal resolution. ! +! ! +! ==================== defination of variables =================== ! +! ! +! inputs: (in-scope variables, module constants) ! +! imon - integer, month of the year ! +! me - integer, print message control flag ! +! ! +! outputs: (module variables) ! +! ! +! external module variables: (in physparam) ! +! aeros_file - external aerosol data file name ! +! ! +! internal module variables: ! +! kprfg ( IMXAE*JMXAE) - aeros profile index ! +! idxcg (NXC*IMXAE*JMXAE) - aeros component index ! +! cmixg (NXC*IMXAE*JMXAE) - aeros component mixing ratio ! +! denng ( 2 *IMXAE*JMXAE) - aerosols number density ! +! ! +! NIAERCM - unit number for input data set ! +! ! +! subroutines called: none ! +! ! +! usage: call trop_update ! +! ! +! ================================================================== ! + +! --- inputs: ( none ) +! --- output: ( none ) + +! --- locals: +! real (kind=kind_io8) :: cmix(NXC), denn, tem + real (kind=kind_phys) :: cmix(NXC), denn, tem + integer :: idxc(NXC), kprf + + integer :: i, id, j, k, m, nc + logical :: file_exist + + character :: cline*80, ctyp*3 +! +!===> ... begin here +! +! --- ... reading climatological aerosols data + + inquire (file=aeros_file, exist=file_exist) + + if ( file_exist ) then + close(NIAERCM) + open (unit=NIAERCM,file=aeros_file,status='OLD', & + & action='read',form='FORMATTED') + rewind (NIAERCM) + + if ( me == 0 ) then + print *,' Opened aerosol data file: ',aeros_file + endif + else + print *,' Requested aerosol data file "',aeros_file, & + & '" not found!' + print *,' *** Stopped in subroutine trop_update !!' + stop + endif ! end if_file_exist_block + +!$omp parallel do private(i,j,m) + do j = 1, JMXAE + do i = 1, IMXAE + do m = 1, NXC + idxcg(m,i,j) = 0 + cmixg(m,i,j) = f_zero + enddo + enddo + enddo + +!$omp parallel do private(i,j) + do j = 1, JMXAE + do i = 1, IMXAE + denng(1,i,j) = f_zero + denng(2,i,j) = f_zero + enddo + enddo + +! --- ... loop over 12 month global distribution + + Lab_do_12mon : do m = 1, 12 + + read(NIAERCM,12) cline + 12 format(a80/) + + if ( m /= imon ) then +! if ( me == 0 ) print *,' *** Skipped ',cline + + do j = 1, JMXAE + do i = 1, IMXAE + read(NIAERCM,*) id + enddo + enddo + else + if ( me == 0 ) print *,' --- Reading ',cline + + do j = 1, JMXAE + do i = 1, IMXAE + read(NIAERCM,14) (idxc(k),cmix(k),k=1,NXC),kprf,denn,nc, & + & ctyp + 14 format(5(i2,e11.4),i2,f8.2,i3,1x,a3) + + kprfg(i,j) = kprf + denng(1,i,j) = denn ! num density of 1st layer + if ( kprf >= 6 ) then + denng(2,i,j) = cmix(NXC) ! num density of 2dn layer + else + denng(2,i,j) = f_zero + endif + + tem = f_one + do k = 1, NXC-1 + idxcg(k,i,j) = idxc(k) ! component index + cmixg(k,i,j) = cmix(k) ! component mixing ratio + tem = tem - cmix(k) + enddo + idxcg(NXC,i,j) = idxc(NXC) + cmixg(NXC,i,j) = tem ! to make sure all add to 1. + enddo + enddo + + close (NIAERCM) + exit Lab_do_12mon + endif ! end if_m_block + + enddo Lab_do_12mon + +! -- check print + +! print *,' IDXCG :' +! print 16,idxcg +! 16 format(40i3) +! print *,' CMIXG :' +! print 17,cmixg +! print *,' DENNG :' +! print 17,denng +! print *,' KPRFG :' +! print 17,kprfg +! 17 format(8e16.9) +! + return +!................................ + end subroutine trop_update +!-------------------------------- + + +!> This subroutine searches historical volcanic data sets to find and +!! read in monthly 45-degree lat-zone band of optical depth. +!-------------------------------- + subroutine volc_update +!................................ +! --- inputs: (in scope variables, module variables) +! --- outputs: (module variables) + +! ================================================================== ! +! ! +! subprogram : volc_update ! +! ! +! searches historical volcanic data sets to find and read in ! +! monthly 45-degree lat-zone band data of optical depth. ! +! ! +! ==================== defination of variables =================== ! +! ! +! inputs: (in-scope variables, module constants) ! +! iyear - integer, 4-digit calender year 1 ! +! imon - integer, month of the year 1 ! +! me - integer, print message control flag 1 ! +! NIAERCM - integer, unit number for input data set 1 ! +! ! +! outputs: (module variables) ! +! ivolae - integer, monthly, 45-deg lat-zone volc odp 12*4*10 ! +! kyrstr - integer, starting year of data in the input file ! +! kyrend - integer, ending year of data in the input file ! +! kyrsav - integer, the year of data in use in the input file ! +! kmonsav - integer, the month of data in use in the input file ! +! ! +! subroutines called: none ! +! ! +! usage: call volc_aerinit ! +! ! +! ================================================================== ! + +! --- inputs: (in-scope variables, module constants) +! integer :: iyear, imon, me, NIAERCM + +! --- output: (module variables) +! integer :: ivolae(:,:,:), kyrstr, kyrend, kyrsav, kmonsav + +! --- locals: + integer :: i, j, k + logical :: file_exist + + character :: cline*80, volcano_file*32 + data volcano_file / 'volcanic_aerosols_1850-1859.txt ' / +! +!===> ... begin here +! + kmonsav = imon + + if ( kyrstr<=iyear .and. iyear<=kyrend ) then ! use previously input data + kyrsav = iyear + return + else ! need to input new data + kyrsav = iyear + kyrstr = iyear - mod(iyear,10) + kyrend = kyrstr + 9 + +! --- check print +! print *,' kyrstr, kyrend, kyrsav, kmonsav =', & +! & kyrstr,kyrend,kyrsav,kmonsav + + if ( iyear < MINVYR .or. iyear > MAXVYR ) then +! if ( .not. allocated(ivolae) ) then +! allocate ( ivolae(12,4,10) ) ! for 12-mon,4-lat_zone,10-year +! endif + ivolae(:,:,:) = 1 ! set as lowest value + if ( me == 0 ) then + print *,' Request volcanic date out of range,', & + & ' optical depth set to lowest value' + endif + else + write(volcano_file(19:27),60) kyrstr,kyrend + 60 format(i4.4,'-',i4.4) + + inquire (file=volcano_file, exist=file_exist) + if ( file_exist ) then + close(NIAERCM) + open (unit=NIAERCM,file=volcano_file,status='OLD', & + & action='read',form='FORMATTED') + + read(NIAERCM,62) cline + 62 format(a80) + +! --- check print + if ( me == 0 ) then + print *,' Opened volcanic data file: ',volcano_file + print *, cline + endif + + do k = 1, 10 + do j = 1, 4 + read(NIAERCM,64) (ivolae(i,j,k),i=1,12) + 64 format(12i5) + enddo + enddo + + close (NIAERCM) + else + print *,' Requested volcanic data file "', & + & volcano_file,'" not found!' + print *,' *** Stopped in subroutine VOLC_AERINIT !!' + stop + endif ! end if_file_exist_block + + endif ! end if_iyear_block + endif ! end if_kyrstr_block + +! --- check print + if ( me == 0 ) then + k = mod(kyrsav,10) + 1 + print *,' CHECK: Sample Volcanic data used for month, year:', & + & imon, iyear + print *, ivolae(kmonsav,:,k) + endif +! + return +!................................ + end subroutine volc_update +!-------------------------------- +! +!................................... + end subroutine aer_update +!----------------------------------- +!! @} + + +!> This subroutine computes aerosols optical properties. +!>\param prsi (IMAX,NLP1), pressure at interface in mb +!!\param prsl (IMAX,NLAY), layer mean pressure in mb +!!\param prslk (IMAX,NLAY), exner function = \f$(p/p0)^{rocp}\f$ +!!\param tvly (IMAX,NLAY), layer virtual temperature in K +!!\param rhlay (IMAX,NLAY), layer mean relative humidity +!!\param slmsk (IMAX), sea/land mask (sea:0,land:1,sea-ice:2) +!!\param tracer (IMAX,NLAY,NTRAC), aerosol tracer concentration +!!\param xlon (IMAX), longitude of given points in radiance, ok for +!! both 0->2pi or -pi->+pi ranges +!!\param xlat (IMAX), latitude of given points in radiance, default +!! to pi/2 -> -pi/2, otherwise see in-line comment +!!\param IMAX 1, horizontal dimension of arrays +!!\param NLAY,NLP1 1, vertical dimensions of arrays +!!\param lsswr,lslwr logical flags for sw/lw radiation calls +!!\param aerosw (IMAX,NLAY,NBDSW,NF_AESW), aeros opt properties for sw +!!\n (:,:,:,1): optical depth +!!\n (:,:,:,2): single scattering albedo +!!\n (:,:,:,3): asymmetry parameter +!!\param aerolw (IMAX,NLAY,NBDLW,NF_AELW), aeros opt properties for lw +!!\n (:,:,:,1): optical depth +!!\n (:,:,:,2): single scattering albedo +!!\n (:,:,:,3): asymmetry parameter +!!\param aerodp (IMAX,NSPC1), vertically integrated optical depth +!>\section general_setaer General Algorithm +!> @{ +!----------------------------------- + subroutine setaer & + & ( prsi,prsl,prslk,tvly,rhlay,slmsk,tracer,xlon,xlat, & ! --- inputs + & IMAX,NLAY,NLP1, lsswr,lslwr, & + & aerosw,aerolw & ! --- outputs + &, aerodp & + & ) + +! ================================================================== ! +! ! +! setaer computes aerosols optical properties ! +! ! +! inputs: size ! +! prsi - pressure at interface mb IMAX*NLP1 ! +! prsl - layer mean pressure mb IMAX*NLAY ! +! prslk - exner function = (p/p0)**rocp IMAX*NLAY ! +! tvly - layer virtual temperature k IMAX*NLAY ! +! rhlay - layer mean relative humidity IMAX*NLAY ! +! slmsk - sea/land mask (sea:0,land:1,sea-ice:2) IMAX ! +! tracer - aerosol tracer concentration IMAX*NLAY*NTRAC ! +! xlon - longitude of given points in radiance IMAX ! +! ok for both 0->2pi or -pi->+pi ranges ! +! xlat - latitude of given points in radiance IMAX ! +! default to pi/2 -> -pi/2, otherwise see in-line comment! +! IMAX - horizontal dimension of arrays 1 ! +! NLAY,NLP1-vertical dimensions of arrays 1 ! +! lsswr,lslwr ! +! - logical flags for sw/lw radiation calls 1 ! +! ! +! outputs: ! +! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! +! (:,:,:,1): optical depth ! +! (:,:,:,2): single scattering albedo ! +! (:,:,:,3): asymmetry parameter ! +! aerolw - aeros opt properties for lw IMAX*NLAY*NBDLW*NF_AELW! +! (:,:,:,1): optical depth ! +! (:,:,:,2): single scattering albedo ! +! (:,:,:,3): asymmetry parameter ! +! tau_gocart - 550nm aeros opt depth IMAX*NLAY*MAX_NUM_GRIDCOMP! +!! aerodp - vertically integrated optical depth IMAX*NSPC1 ! +! ! +! external module variable: (in physparam) ! +! iaerflg - aerosol effect control flag (volc,lw,sw, 3-dig) ! +! laswflg - tropospheric aerosol control flag for sw radiation ! +! =f: no sw aeros calc. =t: do sw aeros calc. ! +! lalwflg - tropospheric aerosol control flag for lw radiation ! +! =f: no lw aeros calc. =t: do lw aeros calc. ! +! lavoflg - control flag for stratospheric vocanic aerosols ! +! =t: add volcanic aerosols to the background aerosols ! +! ivflip - control flag for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! internal module variable: (set by subroutine aer_init) ! +! ivolae - stratosphere volcanic aerosol optical depth (fac 1.e4) ! +! 12*4*10 ! +! usage: call setaer ! +! ! +! subprograms called: aer_property ! +! ! +! ================================================================== ! + +! --- inputs: + integer, intent(in) :: IMAX, NLAY, NLP1 + + real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & + & prslk, tvly, rhlay + real (kind=kind_phys), dimension(:), intent(in) :: xlon, xlat, & + & slmsk + real (kind=kind_phys), dimension(:,:,:),intent(in):: tracer + + logical, intent(in) :: lsswr, lslwr + + +! --- outputs: + real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & + & aerosw, aerolw + + real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + +! --- locals: + real (kind=kind_phys), parameter :: psrfh = 5.0 ! ref press (mb) for upper bound + + real (kind=kind_phys), dimension(IMAX) :: alon,alat,volcae,rdelp +! real (kind=kind_phys), dimension(IMAX) :: sumodp + real (kind=kind_phys) :: prsln(NLP1),hz(IMAX,NLP1),dz(IMAX,NLAY) + real (kind=kind_phys) :: tmp1, tmp2, psrfl + + integer :: kcutl(IMAX), kcuth(IMAX) + integer :: i, i1, j, k, m, mb, kh, kl + + logical :: laddsw=.false., laersw=.false. + logical :: laddlw=.false., laerlw=.false. + +! --- conversion constants + real (kind=kind_phys), parameter :: rdg = 180.0 / con_pi + real (kind=kind_phys), parameter :: rovg = 0.001 * con_rd / con_g + +!===> ... begin here + + do m = 1, NF_AESW + do j = 1, NBDSW + do k = 1, NLAY + do i = 1, IMAX + aerosw(i,k,j,m) = f_zero + enddo + enddo + enddo + enddo + + do m = 1, NF_AELW + do j = 1, NBDLW + do k = 1, NLAY + do i = 1, IMAX + aerolw(i,k,j,m) = f_zero + enddo + enddo + enddo + enddo + +! sumodp = f_zero + do i = 1, IMAX + do k = 1, NSPC1 + aerodp(i,k) = f_zero + enddo + enddo + + + if ( .not. (lsswr .or. lslwr) ) then + return + endif + + if ( iaerflg <= 0 ) then + return + endif + + laersw = lsswr .and. laswflg + laerlw = lslwr .and. lalwflg + +!> -# Convert lat/lon from radiance to degree. + + do i = 1, IMAX + alon(i) = xlon(i) * rdg + if (alon(i) < f_zero) alon(i) = alon(i) + 360.0 + alat(i) = xlat(i) * rdg ! if xlat in pi/2 -> -pi/2 range +! alat(i) = 90.0 - xlat(i)*rdg ! if xlat in 0 -> pi range + enddo + +!> -# Compute level height and layer thickness. + + if ( laswflg .or. lalwflg ) then + + lab_do_IMAX : do i = 1, IMAX + + lab_if_flip : if (ivflip == 1) then ! input from sfc to toa + + do k = 1, NLAY + prsln(k) = log(prsi(i,k)) + enddo + prsln(NLP1)= log(prsl(i,NLAY)) + + do k = NLAY, 1, -1 + dz(i,k) = rovg * (prsln(k) - prsln(k+1)) * tvly(i,k) + enddo + dz(i,NLAY) = 2.0 * dz(i,NLAY) + + hz(i,1) = f_zero + do k = 1, NLAY + hz(i,k+1) = hz(i,k) + dz(i,k) + enddo + + else lab_if_flip ! input from toa to sfc + + prsln(1) = log(prsl(i,1)) + do k = 2, NLP1 + prsln(k) = log(prsi(i,k)) + enddo + + do k = 1, NLAY + dz(i,k) = rovg * (prsln(k+1) - prsln(k)) * tvly(i,k) + enddo + dz(i,1) = 2.0 * dz(i,1) + + hz(i,NLP1) = f_zero + do k = NLAY, 1, -1 + hz(i,k) = hz(i,k+1) + dz(i,k) + enddo + + endif lab_if_flip + + enddo lab_do_IMAX + + +!> -# Calculate SW aerosol optical properties for the corresponding +!! frequency bands: +!! - if opac aerosol climatology is used, call aer_property(): this +!! subroutine maps the 5 degree global climatological aerosol data +!! set onto model grids, and compute aerosol optical properties for +!! SW and LW radiations. +!! - if gocart aerosol scheme is used, call setgocartaer(): this +!! subroutine computes sw + lw aerosol optical properties for gocart +!! aerosol species (merged from fcst and clim fields). + +!SARAH +! if ( iaerflg == 1 ) then ! use opac aerosol climatology + if ( iaermdl == 0 ) then ! use opac aerosol climatology + + call aer_property & +! --- inputs: + & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer, & + & alon,alat,slmsk, laersw,laerlw, & + & IMAX,NLAY,NLP1, & +! & IMAX,NLAY,NLP1,NSPC1, & +! --- outputs: + & aerosw,aerolw,aerodp & + & ) + +! --- check print +! do m = 1, NBDSW +! print *,' *** CHECK AEROSOLS PROPERTIES FOR SW BAND =',m, & +! & ' ***' +! do k = 1, 10 +! print *,' LEVEL :',k +! print *,' TAUAER:',aerosw(:,k,m,1) +! print *,' SSAAER:',aerosw(:,k,m,2) +! print *,' ASYAER:',aerosw(:,k,m,3) +! enddo +! enddo +! print *,' *** CHECK AEROSOLS OPTICAL DEPTH FOR 550nm REGION' +! print *, aerodp(:,1) +! if ( laod_out ) then +! do m = 1, NSPC1 +! print *,' *** CHECK AEROSOLS OPTICAL DEPTH FOR SPECIES:', & +! & m +! print *, aerodp(:,m) +! sumodp(:) = sumodp(:) + aerodp(:,m) +! enddo + +! +! print *,' *** CHECK AEROSOLS OPTICAL DEPTH FOR ALL SPECIES:' +! print *, sumodp(:) +! endif +! do m = 1, NBDLW +! print *,' *** CHECK AEROSOLS PROPERTIES FOR LW BAND =',m, & +! & ' ***' +! do k = 1, 10 +! print *,' LEVEL :',k +! print *,' TAUAER:',aerolw(:,k,m,1) +! print *,' SSAAER:',aerolw(:,k,m,2) +! print *,' ASYAER:',aerolw(:,k,m,3) +! enddo +! enddo +! SARAH +! elseif ( iaerflg == 2 ) then ! use gocart aerosol scheme + elseif ( iaermdl == 1 ) then ! use gocart aerosol scheme + + call setgocartaer & + +! --- inputs: + & ( alon,alat,prslk,rhlay,dz,hz,NSWLWBD, & + & prsl,tvly,tracer, & + & IMAX,NLAY,NLP1, ivflip, lsswr,lslwr, & +! --- outputs: + & aerosw,aerolw & + & ) + + endif ! end if_iaerflg_block + + endif ! end if_laswflg_or_lalwflg_block + +!> -# Compute stratosphere volcanic forcing: +!! - select data in 4 lat bands, interpolation at the boundaries +!! - Find lower boundary of stratosphere: polar, fixed at 25000pa +!! (250mb); tropic, fixed at 15000pa (150mb); mid-lat, interpolation +!! - SW: add volcanic aerosol optical depth to the background value +!! - Smoothing profile at boundary if needed +!! - LW: add volcanic aerosol optical depth to the background value +! --- ... stratosphere volcanic forcing + + if ( lavoflg ) then + + if ( iaerflg == 100 ) then + laddsw = lsswr + laddlw = lslwr + else + laddsw = lsswr .and. laswflg + laddlw = lslwr .and. lalwflg + endif + + i1 = mod(kyrsav, 10) + 1 + +! --- select data in 4 lat bands, interpolation at the boundaires + + do i = 1, IMAX + if ( alat(i) > 46.0 ) then + volcae(i) = 1.0e-4 * ivolae(kmonsav,1,i1) + else if ( alat(i) > 44.0 ) then + volcae(i) = 5.0e-5 & + & * (ivolae(kmonsav,1,i1) + ivolae(kmonsav,2,i1)) + else if ( alat(i) > 1.0 ) then + volcae(i) = 1.0e-4 * ivolae(kmonsav,2,i1) + else if ( alat(i) > -1.0 ) then + volcae(i) = 5.0e-5 & + & * (ivolae(kmonsav,2,i1) + ivolae(kmonsav,3,i1)) + else if ( alat(i) >-44.0 ) then + volcae(i) = 1.0e-4 * ivolae(kmonsav,3,i1) + else if ( alat(i) >-46.0 ) then + volcae(i) = 5.0e-5 & + & * (ivolae(kmonsav,3,i1) + ivolae(kmonsav,4,i1)) + else + volcae(i) = 1.0e-4 * ivolae(kmonsav,4,i1) + endif + enddo + + if ( ivflip == 0 ) then ! input data from toa to sfc + +! --- find lower boundary of stratosphere + + do i = 1, IMAX + + tmp1 = abs( alat(i) ) + if ( tmp1 > 70.0 ) then ! polar, fixed at 25000pa (250mb) + psrfl = 250.0 + elseif ( tmp1 < 20.0 ) then ! tropic, fixed at 15000pa (150mb) + psrfl = 150.0 + else ! mid-lat, interpolation + psrfl = 110.0 + 2.0*tmp1 + endif + + kcuth(i) = NLAY - 1 + kcutl(i) = 2 + rdelp(i) = f_one / prsi(i,2) + + lab_do_kcuth0 : do k = 2, NLAY-2 + if ( prsi(i,k) >= psrfh ) then + kcuth(i) = k - 1 + exit lab_do_kcuth0 + endif + enddo lab_do_kcuth0 + + lab_do_kcutl0 : do k = 2, NLAY-2 + if ( prsi(i,k) >= psrfl ) then + kcutl(i) = k - 1 + rdelp(i) = f_one / (prsi(i,k) - prsi(i,kcuth(i))) + exit lab_do_kcutl0 + endif + enddo lab_do_kcutl0 + enddo + +! --- sw: add volcanic aerosol optical depth to the background value + + if ( laddsw ) then + do m = 1, NBDSW + mb = NSWSTR + m - 1 + + if ( wvnsw1(mb) > 20000 ) then ! range of wvlth < 0.5mu + tmp2 = 0.74 + elseif ( wvnsw2(mb) < 20000 ) then ! range of wvlth > 0.5mu + tmp2 = 1.14 + else ! range of wvlth in btwn + tmp2 = 0.94 + endif + tmp1 = (0.275e-4 * (wvnsw2(mb)+wvnsw1(mb))) ** tmp2 + + do i = 1, IMAX + kh = kcuth(i) + kl = kcutl(i) + do k = kh, kl + tmp2 = tmp1 * ((prsi(i,k+1) - prsi(i,k)) * rdelp(i)) + aerosw(i,k,m,1) = aerosw(i,k,m,1) + tmp2*volcae(i) + enddo + +! --- smoothing profile at boundary if needed + + if ( aerosw(i,kl,m,1) > 10.*aerosw(i,kl+1,m,1) ) then + tmp2 = aerosw(i,kl,m,1) + aerosw(i,kl+1,m,1) + aerosw(i,kl ,m,1) = 0.8 * tmp2 + aerosw(i,kl+1,m,1) = 0.2 * tmp2 + endif + enddo ! end do_i_block + enddo ! end do_m_block + +! --- check print +! do i = 1, IMAX +! print *,' LEV PRESS TAU FOR PROFILE:',i, & +! & ' KCUTH, KCUTL =',kcuth(i),kcutl(i) +! kh = kcuth(i) - 1 +! kl = kcutl(i) + 10 +! do k = kh, kl +! write(6,71) k, prsl(i,k), aerosw(i,k,1,1) +! 71 format(i3,2e11.4) +! enddo +! enddo + + endif ! end if_laddsw_block + +! --- lw: add volcanic aerosol optical depth to the background value + + if ( laddlw ) then + if ( NLWBND == 1 ) then + + tmp1 = (0.55 / 11.0) ** 1.2 + do i = 1, IMAX + kh = kcuth(i) + kl = kcutl(i) + do k = kh, kl + tmp2 = tmp1 * ((prsi(i,k+1) - prsi(i,k)) * rdelp(i)) & + & * volcae(i) + do m = 1, NBDLW + aerolw(i,k,m,1) = aerolw(i,k,m,1) + tmp2 + enddo + enddo + enddo ! end do_i_block + + else + + do m = 1, NBDLW + tmp1 = (0.275e-4 * (wvnlw2(m) + wvnlw1(m))) ** 1.2 + + do i = 1, IMAX + kh = kcuth(i) + kl = kcutl(i) + do k = kh, kl + tmp2 = tmp1 * ((prsi(i,k+1)-prsi(i,k)) * rdelp(i)) + aerolw(i,k,m,1) = aerolw(i,k,m,1) + tmp2*volcae(i) + enddo + enddo ! end do_i_block + enddo ! end do_m_block + + endif ! end if_NLWBND_block + endif ! end if_laddlw_block + + else ! input data from sfc to toa + +! --- find lower boundary of stratosphere + + do i = 1, IMAX + + tmp1 = abs( alat(i) ) + if ( tmp1 > 70.0 ) then ! polar, fixed at 25000pa (250mb) + psrfl = 250.0 + elseif ( tmp1 < 20.0 ) then ! tropic, fixed at 15000pa (150mb) + psrfl = 150.0 + else ! mid-lat, interpolation + psrfl = 110.0 + 2.0*tmp1 + endif + + kcuth(i) = 2 + kcutl(i) = NLAY - 1 + rdelp(i) = f_one / prsi(i,NLAY-1) + + lab_do_kcuth1 : do k = NLAY-1, 2, -1 + if ( prsi(i,k) >= psrfh ) then + kcuth(i) = k + exit lab_do_kcuth1 + endif + enddo lab_do_kcuth1 + + lab_do_kcutl1 : do k = NLAY, 2, -1 + if ( prsi(i,k) >= psrfl ) then + kcutl(i) = k + rdelp(i) = f_one / (prsi(i,k) - prsi(i,kcuth(i)+1)) + exit lab_do_kcutl1 + endif + enddo lab_do_kcutl1 + enddo + +! --- sw: add volcanic aerosol optical depth to the background value + + if ( laddsw ) then + do m = 1, NBDSW + mb = NSWSTR + m - 1 + + if ( wvnsw1(mb) > 20000 ) then ! range of wvlth < 0.5mu + tmp2 = 0.74 + elseif ( wvnsw2(mb) < 20000 ) then ! range of wvlth > 0.5mu + tmp2 = 1.14 + else ! range of wvlth in btwn + tmp2 = 0.94 + endif + tmp1 = (0.275e-4 * (wvnsw2(mb)+wvnsw1(mb))) ** tmp2 + + do i = 1, IMAX + kh = kcuth(i) + kl = kcutl(i) + do k = kl, kh + tmp2 = tmp1 * ((prsi(i,k) - prsi(i,k+1)) * rdelp(i)) + aerosw(i,k,m,1) = aerosw(i,k,m,1) + tmp2*volcae(i) + enddo + +! --- smoothing profile at boundary if needed + + if ( aerosw(i,kl,m,1) > 10.*aerosw(i,kl-1,m,1) ) then + tmp2 = aerosw(i,kl,m,1) + aerosw(i,kl-1,m,1) + aerosw(i,kl ,m,1) = 0.8 * tmp2 + aerosw(i,kl-1,m,1) = 0.2 * tmp2 + endif + enddo ! end do_i_block + enddo ! end do_m_block + +! --- check print +! do i = 1, IMAX +! print *,' LEV PRESS TAU FOR PROFILE:',i, & +! & ' KCUTH, KCUTL =',kcuth(i),kcutl(i) +! kh = kcuth(i) + 1 +! kl = kcutl(i) - 10 +! do k = kh, kl, -1 +! write(6,71) NLP1-k,prsl(i,k),aerosw(i,k,1,1) +! enddo +! enddo + + endif ! end if_laddsw_block + +! --- lw: add volcanic aerosol optical depth to the background value + + if ( laddlw ) then + if ( NLWBND == 1 ) then + + tmp1 = (0.55 / 11.0) ** 1.2 + do i = 1, IMAX + kh = kcuth(i) + kl = kcutl(i) + do k = kl, kh + tmp2 = tmp1 * ((prsi(i,k) - prsi(i,k+1)) * rdelp(i)) & + & * volcae(i) + do m = 1, NBDLW + aerolw(i,k,m,1) = aerolw(i,k,m,1) + tmp2 + enddo + enddo + enddo ! end do_i_block + + else + + do m = 1, NBDLW + tmp1 = (0.275e-4 * (wvnlw2(m) + wvnlw1(m))) ** 1.2 + + do i = 1, IMAX + kh = kcuth(i) + kl = kcutl(i) + do k = kl, kh + tmp2 = tmp1 * ((prsi(i,k)-prsi(i,k+1)) * rdelp(i)) + aerolw(i,k,m,1) = aerolw(i,k,m,1) + tmp2*volcae(i) + enddo + enddo ! end do_i_block + enddo ! end do_m_block + + endif ! end if_NLWBND_block + endif ! end if_laddlw_block + + endif ! end if_ivflip_block + + endif ! end if_lavoflg_block +! + return +!................................... + end subroutine setaer +!----------------------------------- +!> @} + + +!> This subroutine maps the 5 degree global climatological aerosol data +!! set onto model grids, and compute aerosol optical properties for SW +!! and LW radiations. +!!\param prsi (IMAX,NLP1), pressure at interface in mb +!!\param prsl (IMAX,NLAY), layer mean pressure(not used) +!!\param prslk (IMAX,NLAY), exner function=\f$(p/p0)^{rocp}\f$ (not used) +!!\param tvly (IMAX,NLAY), layer virtual temperature (not used) +!!\param rhlay (IMAX,NLAY), layer mean relative humidity +!!\param dz (IMAX,NLAY), layer thickness in m +!!\param hz (IMAX,NLP1), level high in m +!!\param tracer (IMAX,NLAY,NTRAC), aer tracer concentrations (not used) +!!\param alon, alat (IMAX), longitude and latitude of given points in degree +!!\param slmsk (IMAX), sea/land mask (sea:0,land:1,sea-ice:2) +!!\param laersw,laerlw logical flag for sw/lw aerosol calculations +!!\param IMAX horizontal dimension of arrays +!!\param NLAY,NLP1 vertical dimensions of arrays +!!\param NSPC num of species for optional aod output fields +!!\param aerosw (IMAX,NLAY,NBDSW,NF_AESW), aeros opt properties for sw +!!\n (:,:,:,1): optical depth +!!\n (:,:,:,2): single scattering albedo +!!\n (:,:,:,3): asymmetry parameter +!!\param aerolw (IMAX,NLAY,NBDLW,NF_AELW), aeros opt properties for lw +!!\n (:,:,:,1): optical depth +!!\n (:,:,:,2): single scattering albedo +!!\n (:,:,:,3): asymmetry parameter +!!\param aerodp (IMAX,NSPC+1), vertically integrated aer-opt-depth +!!\section gel_aer_pro General Algorithm +!> @{ +!----------------------------------- + subroutine aer_property & + & ( prsi,prsl,prslk,tvly,rhlay,dz,hz,tracer, & ! --- inputs: + & alon,alat,slmsk, laersw,laerlw, & + & IMAX,NLAY,NLP1, & + & aerosw,aerolw,aerodp & ! --- outputs: + & ) + +! ================================================================== ! +! ! +! aer_property maps the 5 degree global climatological aerosol data ! +! set onto model grids, and compute aerosol optical properties for sw ! +! and lw radiations. ! +! ! +! inputs: ! +! prsi - pressure at interface mb IMAX*NLP1 ! +! prsl - layer mean pressure (not used) IMAX*NLAY ! +! prslk - exner function=(p/p0)**rocp (not used) IMAX*NLAY ! +! tvly - layer virtual temperature (not used) IMAX*NLAY ! +! rhlay - layer mean relative humidity IMAX*NLAY ! +! dz - layer thickness m IMAX*NLAY ! +! hz - level high m IMAX*NLP1 ! +! tracer - aer tracer concentrations (not used) IMAX*NLAY*NTRAC! +! alon, alat IMAX ! +! - longitude and latitude of given points in degree ! +! slmsk - sea/land mask (sea:0,land:1,sea-ice:2) IMAX ! +! laersw,laerlw 1 ! +! - logical flag for sw/lw aerosol calculations ! +! IMAX - horizontal dimension of arrays 1 ! +! NLAY,NLP1-vertical dimensions of arrays 1 ! +!! NSPC - num of species for optional aod output fields 1 ! +! ! +! outputs: ! +! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! +! (:,:,:,1): optical depth ! +! (:,:,:,2): single scattering albedo ! +! (:,:,:,3): asymmetry parameter ! +! aerolw - aeros opt properties for lw IMAX*NLAY*NBDLW*NF_AELW! +! (:,:,:,1): optical depth ! +! (:,:,:,2): single scattering albedo ! +! (:,:,:,3): asymmetry parameter ! +!! aerodp - vertically integrated aer-opt-depth IMAX*NSPC+1 ! +! ! +! module parameters and constants: ! +! NSWBND - total number of actual sw spectral bands computed ! +! NLWBND - total number of actual lw spectral bands computed ! +! NSWLWBD - total number of sw+lw bands computed ! +! ! +! external module variables: (in physparam) ! +! ivflip - control flag for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! module variable: (set by subroutine aer_init) ! +! kprfg - aerosols profile index IMXAE*JMXAE ! +! 1:ant 2:arc 3:cnt 4:mar 5:des 6:marme 7:cntme ! +! idxcg - aerosols component index NXC*IMXAE*JMXAE ! +! 1:inso 2:soot 3:minm 4:miam 5:micm ! +! 6:mitr 7:waso 8:ssam 9:sscm 10:suso ! +! cmixg - aerosols component mixing ratio NXC*IMXAE*JMXAE ! +! denng - aerosols number density 2 *IMXAE*JMXAE ! +! 1:for domain-1 2:domain-2 (prof marme/cntme only) ! +! ! +! usage: call aer_property ! +! ! +! subprograms called: radclimaer ! +! ! +! ================================================================== ! + +! --- inputs: + integer, intent(in) :: IMAX, NLAY, NLP1 +! integer, intent(in) :: IMAX, NLAY, NLP1, NSPC + logical, intent(in) :: laersw, laerlw + + real (kind=kind_phys), dimension(:,:), intent(in) :: prsi, prsl, & + & prslk, tvly, rhlay, dz, hz + real (kind=kind_phys), dimension(:), intent(in) :: alon, alat, & + & slmsk + real (kind=kind_phys), dimension(:,:,:),intent(in):: tracer + +! --- outputs: + real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & + & aerosw, aerolw + real (kind=kind_phys), dimension(:,:) , intent(out) :: aerodp + +! --- locals: + real (kind=kind_phys), dimension(NCM) :: cmix + real (kind=kind_phys), dimension( 2) :: denn + real (kind=kind_phys), dimension(NSPC) :: spcodp + + real (kind=kind_phys), dimension(NLAY) :: delz, rh1, dz1 + integer, dimension(NLAY) :: idmaer + + real (kind=kind_phys), dimension(NLAY,NSWLWBD):: tauae,ssaae,asyae +!test real (kind=kind_phys), dimension(IMAX,NLAY) :: aersav + + real (kind=kind_phys) :: tmp1, tmp2, rps, dtmp, h1 + real (kind=kind_phys) :: wi, wj, w11, w12, w21, w22 + + integer :: i, ii, i1, i2, i3, j1, j2, j3, k, m, m1, & + & kp, kpa, kpi, kpj + +! --- conversion constants + real (kind=kind_phys), parameter :: dltg = 360.0 / float(IMXAE) + real (kind=kind_phys), parameter :: hdlt = 0.5 * dltg + real (kind=kind_phys), parameter :: rdlt = 1.0 / dltg + +! +!===> ... begin here +! +!> -# Map aerosol data to model grids +!! - Map grid in longitude direction, lon from 0 to 355 deg resolution +!! - Map grid in latitude direction, lat from 90n to 90s in 5 deg resolution + + i1 = 1 + i2 = 2 + j1 = 1 + j2 = 2 + + lab_do_IMAX : do i = 1, IMAX + +! --- map grid in longitude direction, lon from 0 to 355 deg resolution + +! print *,' Seeking lon index for point i =',i + i3 = i1 + lab_do_IMXAE : do while ( i3 <= IMXAE ) + tmp1 = dltg * (i3 - 1) + dtmp = alon(i) - tmp1 +! print *,' alon, i3, tlon, dlon =',alon(i),i3,tmp1,dtmp + + if ( dtmp > dltg ) then + i3 = i3 + 1 + if ( i3 > IMXAE ) then + print *,' ERROR! In setclimaer alon>360. ipt =',i, & + & ', dltg,alon,tlon,dlon =',dltg,alon(i),tmp1,dtmp + stop + endif + elseif ( dtmp >= f_zero ) then + i1 = i3 + i2 = mod(i3,IMXAE) + 1 + wi = dtmp * rdlt + if ( dtmp <= hdlt ) then + kpi = i3 + else + kpi = i2 + endif +! print *,' found i1, i2, wi =',i1,i2,wi + exit lab_do_IMXAE + else + i3 = i3 - 1 + if ( i3 < 1 ) then + print *,' ERROR! In setclimaer alon< 0. ipt =',i, & + & ', dltg,alon,tlon,dlon =',dltg,alon(i),tmp1,dtmp + stop + endif + endif + enddo lab_do_IMXAE + +! --- map grid in latitude direction, lat from 90n to 90s in 5 deg resolution + +! print *,' Seeking lat index for point i =',i + j3 = j1 + lab_do_JMXAE : do while ( j3 <= JMXAE ) + tmp2 = 90.0 - dltg * (j3 - 1) + dtmp = tmp2 - alat(i) +! print *,' alat, j3, tlat, dlat =',alat(i),j3,tmp2,dtmp + + if ( dtmp > dltg ) then + j3 = j3 + 1 + if ( j3 >= JMXAE ) then + print *,' ERROR! In setclimaer alat<-90. ipt =',i, & + & ', dltg,alat,tlat,dlat =',dltg,alat(i),tmp2,dtmp + stop + endif + elseif ( dtmp >= f_zero ) then + j1 = j3 + j2 = j3 + 1 + wj = dtmp * rdlt + if ( dtmp <= hdlt ) then + kpj = j3 + else + kpj = j2 + endif +! print *,' found j1, j2, wj =',j1,j2,wj + exit lab_do_JMXAE + else + j3 = j3 - 1 + if ( j3 < 1 ) then + print *,' ERROR! In setclimaer alat>90. ipt =',i, & + & ', dltg,alat,tlat,dlat =',dltg,alat(i),tmp2,dtmp + stop + endif + endif + enddo lab_do_JMXAE + +!> -# Determin the type of aerosol profile (kp) and scale hight for +!! domain 1 (h1) to be used at this grid point. + + kp = kprfg(kpi,kpj) ! nearest typical aeros profile as default + kpa = max( kprfg(i1,j1),kprfg(i1,j2),kprfg(i2,j1),kprfg(i2,j2) ) + h1 = haer(1,kp) + denn(2) = f_zero + ii = 1 + + if ( kp /= kpa ) then + if ( kpa == 6 ) then ! if ocean prof with mineral aeros overlay + ii = 2 ! need 2 types of densities + if ( slmsk(i) > f_zero ) then ! but actually a land/sea-ice point + kp = 7 ! reset prof index to land + h1 = 0.5*(haer(1,6) + haer(1,7)) ! use a transition scale hight + else + kp = kpa + h1 = haer(1,6) + endif + elseif ( kpa == 7 ) then ! if land prof with mineral aeros overlay + ii = 2 ! need 2 types of densities + if ( slmsk(i) <= f_zero ) then ! but actually an ocean point + kp = 6 ! reset prof index to ocean + h1 = 0.5*(haer(1,6) + haer(1,7)) ! use a transition scale hight + else + kp = kpa + h1 = haer(1,7) + endif + else ! lower atmos without mineral aeros overlay +! h1 = 0.5*(haer(1,kp) + haer(1,kpa)) ! use a transition scale hight + h1 = haer(1,kpa) + kp = kpa + endif + endif + +!> -# Compute horizontal bi-linear interpolation weights + + w11 = (f_one-wi) * (f_one-wj) + w12 = (f_one-wi) * wj + w21 = wi * (f_one-wj) + w22 = wi * wj + +! --- check print +! print *,' Grid pt', i,', alon, alat =',alon(i),alat(i), & +! & ', tlon, tlat =',tmp1,tmp2 +! print *,' lon grid index i1, i2 =',i1,i2,', weight wi =',wi +! print *,' lat grid index j1, j2 =',j1,j2,', weight wj =',wj +! print *,' bi-linear weights w11,w21,w12,w22 =',w11,w21,w12,w22 +! print *,' kp,kpa,slmsk,h1 =',kp,m1,slmsk(i),h1 + +!> -# Do horizontal bi-linear interpolation on aerosol partical density +!! (denn) + + do m = 1, ii ! ii=1 for domain 1; =2 for domain 2. + denn(m) = w11*denng(m,i1,j1) + w12*denng(m,i1,j2) & + & + w21*denng(m,i2,j1) + w22*denng(m,i2,j2) + enddo ! end_do_m_loop + +!> -# Do horizontal bi-linear interpolation on mixing ratios + + cmix(:) = f_zero + do m = 1, NXC + ii = idxcg(m,i1,j1) + if ( ii > 0 ) then + cmix(ii) = cmix(ii) + w11*cmixg(m,i1,j1) + endif + ii = idxcg(m,i1,j2) + if ( ii > 0 ) then + cmix(ii) = cmix(ii) + w12*cmixg(m,i1,j2) + endif + ii = idxcg(m,i2,j1) + if ( ii > 0 ) then + cmix(ii) = cmix(ii) + w21*cmixg(m,i2,j1) + endif + ii = idxcg(m,i2,j2) + if ( ii > 0 ) then + cmix(ii) = cmix(ii) + w22*cmixg(m,i2,j2) + endif + enddo ! end_do_m_loop + +! --- check print +! print *,' denn =',denn(:) +! print *,' cmix =',cmix(:) + +!> -# Prepare to setup domain index array and effective layer thickness, +!! also convert pressure level to sigma level to follow the terrain. + + do k = 1, NLAY + rh1(k) = rhlay(i,k) + dz1(k) = dz (i,k) + enddo + + lab_if_flip : if (ivflip == 1) then ! input from sfc to toa + + if ( prsi(i,1) > 100.0 ) then + rps = f_one / prsi(i,1) + else + print *,' !!! (1) Error in subr radiation_aerosols:', & + & ' unrealistic surface pressure =', i,prsi(i,1) + stop + endif + + ii = 1 + do k = 1, NLAY + if (prsi(i,k+1)*rps < sigref(ii,kp)) then + ii = ii + 1 + if (ii == 2 .and. prsref(2,kp) == prsref(3,kp)) then + ii = 3 + endif + endif + idmaer(k) = ii + + if ( ii > 1 ) then + tmp1 = haer(ii,kp) + else + tmp1 = h1 + endif + + if (tmp1 > f_zero) then + tmp2 = f_one / tmp1 + delz(k) = tmp1 * (exp(-hz(i,k)*tmp2)-exp(-hz(i,k+1)*tmp2)) + else + delz(k) = dz1(k) + endif + enddo + + else lab_if_flip ! input from toa to sfc + + if ( prsi(i,NLP1) > 100.0 ) then + rps = 1.0 / prsi(i,NLP1) + else + print *,' !!! (2) Error in subr radiation_aerosols:', & + & ' unrealistic surface pressure =', i,prsi(i,NLP1) + endif + + ii = 1 + do k = NLAY, 1, -1 + if (prsi(i,k)*rps < sigref(ii,kp)) then + ii = ii + 1 + if (ii == 2 .and. prsref(2,kp) == prsref(3,kp)) then + ii = 3 + endif + endif + idmaer(k) = ii + + if ( ii > 1 ) then + tmp1 = haer(ii,kp) + else + tmp1 = h1 + endif + + if (tmp1 > f_zero) then + tmp2 = f_one / tmp1 + delz(k) = tmp1 * (exp(-hz(i,k+1)*tmp2)-exp(-hz(i,k)*tmp2)) + else + delz(k) = dz1(k) + endif + enddo + + endif lab_if_flip + +! --- check print + +! print *,' in setclimaer, profile:',i +! print *,' rh :',rh1 +! print *,' dz :',dz1 +! print *,' delz :',delz +! print *,' idmaer:',idmaer + +!> -# Call radclimaer() to calculate SW/LW aerosol optical properties +!! for the corresponding frequency bands. + + call radclimaer +! --- inputs: (in-scope variables) +! --- outputs: (in-scope variables) + + if ( laersw ) then + + do m = 1, NBDSW + do k = 1, NLAY + aerosw(i,k,m,1) = tauae(k,m) + aerosw(i,k,m,2) = ssaae(k,m) + aerosw(i,k,m,3) = asyae(k,m) + enddo + enddo + +! --- total aod (optional) + do k = 1, NLAY + aerodp(i,1) = aerodp(i,1) + tauae(k,nv_aod) + enddo + +! --- for diagnostic output (optional) +! if ( lspcaod ) then + do m = 1, NSPC + aerodp(i,m+1) = spcodp(m) + enddo +! endif + + endif ! end if_larsw_block + + if ( laerlw ) then + + if ( NLWBND == 1 ) then + m1 = NSWBND + 1 + do m = 1, NBDLW + do k = 1, NLAY + aerolw(i,k,m,1) = tauae(k,m1) + aerolw(i,k,m,2) = ssaae(k,m1) + aerolw(i,k,m,3) = asyae(k,m1) + enddo + enddo + else + do m = 1, NBDLW + m1 = NSWBND + m + do k = 1, NLAY + aerolw(i,k,m,1) = tauae(k,m1) + aerolw(i,k,m,2) = ssaae(k,m1) + aerolw(i,k,m,3) = asyae(k,m1) + enddo + enddo + endif + + endif ! end if_laerlw_block + + enddo lab_do_IMAX + +! ================= + contains +! ================= + +!> This subroutine computes aerosols optical properties in NSWLWBD +!! bands. there are seven different vertical profile structures. in the +!! troposphere, aerosol distribution at each grid point is composed +!! from up to six components out of ten different substances. +!-------------------------------- + subroutine radclimaer +!................................ + +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ================================================================== ! +! ! +! compute aerosols optical properties in NSWLWBD bands. there are ! +! seven different vertical profile structures. in the troposphere, ! +! aerosol distribution at each grid point is composed from up to ! +! six components out of a total of ten different substances. ! +! ! +! ref: wmo report wcp-112 (1986) ! +! ! +! input variables: ! +! cmix - mixing ratioes of aerosol components - NCM ! +! denn - aerosol number densities - 2 ! +! rh1 - relative humidity - NLAY ! +! delz - effective layer thickness km NLAY ! +! idmaer - aerosol domain index - NLAY ! +! NXC - number of different aerosol components- 1 ! +! NLAY - vertical dimensions - 1 ! +! ! +! output variables: ! +! tauae - optical depth - NLAY*NSWLWBD! +! ssaae - single scattering albedo - NLAY*NSWLWBD! +! asyae - asymmetry parameter - NLAY*NSWLWBD! +!! aerodp - vertically integrated aer-opt-depth - IMAX*NSPC+1 ! +! ! +! ================================================================== ! +! + real (kind=kind_phys) :: crt1, crt2 + parameter (crt1=30.0, crt2=0.03333) + +! --- inputs: +! --- outputs: + +! --- locals: + real (kind=kind_phys) :: cm, hd, hdi, sig0u, sig0l, ratio, tt0, & + & ex00, sc00, ss00, as00, ex01, sc01, ss01, as01, tt1, & + & ex02, sc02, ss02, as02, ex03, sc03, ss03, as03, tt2, & + & ext1, sca1, ssa1, asy1, drh0, drh1, rdrh + + integer :: ih1, ih2, kk, idom, icmp, ib, ii, ic, ic1 + integer :: idx + +!===> ... begin here + + spcodp = f_zero + +!===> ... loop over vertical layers from top to surface + + lab_do_layer : do kk = 1, NLAY + +! --- linear interp coeffs for rh-dep species + + ih2 = 1 + do while ( rh1(kk) > rhlev(ih2) ) + ih2 = ih2 + 1 + if ( ih2 > NRHLEV ) exit + enddo + ih1 = max( 1, ih2-1 ) + ih2 = min( NRHLEV, ih2 ) + + drh0 = rhlev(ih2) - rhlev(ih1) + drh1 = rh1(kk) - rhlev(ih1) + if ( ih1 == ih2 ) then + rdrh = f_zero + else + rdrh = drh1 / drh0 + endif + +! --- assign optical properties in each domain + + idom = idmaer(kk) + + lab_if_idom : if (idom == 5) then +! --- 5th domain - upper stratosphere assume no aerosol + + do ib = 1, NSWLWBD + tauae(kk,ib) = f_zero + if ( ib <= NSWBND ) then + ssaae(kk,ib) = 0.99 + asyae(kk,ib) = 0.696 + else + ssaae(kk,ib) = 0.5 + asyae(kk,ib) = 0.3 + endif + enddo + + elseif (idom == 4) then lab_if_idom +! --- 4th domain - stratospheric layers + + do ib = 1, NSWLWBD + tauae(kk,ib) = extstra(ib) * delz(kk) + if ( ib <= NSWBND ) then + ssaae(kk,ib) = 0.99 + asyae(kk,ib) = 0.696 + else + ssaae(kk,ib) = 0.5 + asyae(kk,ib) = 0.3 + endif + enddo + +! --- compute aod from individual species' contribution (optional) + idx = idxspc(10) ! for sulfate + spcodp(idx) = spcodp(idx) + tauae(kk,nv_aod) + + elseif (idom == 3) then lab_if_idom +! --- 3rd domain - free tropospheric layers +! 1:inso 0.17e-3; 2:soot 0.4; 7:waso 0.59983; n:730 + + do ib = 1, NSWLWBD + ex01 = extrhi(1,ib) + sc01 = scarhi(1,ib) + ss01 = ssarhi(1,ib) + as01 = asyrhi(1,ib) + + ex02 = extrhi(2,ib) + sc02 = scarhi(2,ib) + ss02 = ssarhi(2,ib) + as02 = asyrhi(2,ib) + + ex03 = extrhd(ih1,1,ib) & + & + rdrh * (extrhd(ih2,1,ib) - extrhd(ih1,1,ib)) + sc03 = scarhd(ih1,1,ib) & + & + rdrh * (scarhd(ih2,1,ib) - scarhd(ih1,1,ib)) + ss03 = ssarhd(ih1,1,ib) & + & + rdrh * (ssarhd(ih2,1,ib) - ssarhd(ih1,1,ib)) + as03 = asyrhd(ih1,1,ib) & + & + rdrh * (asyrhd(ih2,1,ib) - asyrhd(ih1,1,ib)) + + ext1 = 0.17e-3*ex01 + 0.4*ex02 + 0.59983*ex03 + sca1 = 0.17e-3*sc01 + 0.4*sc02 + 0.59983*sc03 + ssa1 = 0.17e-3*ss01*ex01 + 0.4*ss02*ex02 + 0.59983*ss03*ex03 + asy1 = 0.17e-3*as01*sc01 + 0.4*as02*sc02 + 0.59983*as03*sc03 + + tauae(kk,ib) = ext1 * 730.0 * delz(kk) + ssaae(kk,ib) = min(f_one, ssa1/ext1) + asyae(kk,ib) = min(f_one, asy1/sca1) + +! --- compute aod from individual species' contribution (optional) + if ( ib==nv_aod ) then + spcodp(1) = spcodp(1) + 0.17e-3*ex01*730.0*delz(kk) ! dust (inso) #1 + spcodp(2) = spcodp(2) + 0.4 *ex02*730.0*delz(kk) ! black carbon #2 + spcodp(3) = spcodp(3) + 0.59983*ex03*730.0*delz(kk) ! water soluble #7 + endif + + enddo + + elseif (idom == 1) then lab_if_idom +! --- 1st domain - mixing layer + + lab_do_ib : do ib = 1, NSWLWBD + ext1 = f_zero + sca1 = f_zero + ssa1 = f_zero + asy1 = f_zero + + lab_do_icmp : do icmp = 1, NCM + ic = icmp + idx = idxspc(icmp) + + cm = cmix(icmp) + lab_if_cm : if ( cm > f_zero ) then + + lab_if_ic : if ( ic <= NCM1 ) then ! component withour rh dep + tt0 = cm * extrhi(ic,ib) + ext1 = ext1 + tt0 + sca1 = sca1 + cm * scarhi(ic,ib) + ssa1 = ssa1 + cm * ssarhi(ic,ib) * extrhi(ic,ib) + asy1 = asy1 + cm * asyrhi(ic,ib) * scarhi(ic,ib) + else lab_if_ic ! component with rh dep + ic1 = ic - NCM1 + + ex00 = extrhd(ih1,ic1,ib) & + & + rdrh * (extrhd(ih2,ic1,ib) - extrhd(ih1,ic1,ib)) + sc00 = scarhd(ih1,ic1,ib) & + & + rdrh * (scarhd(ih2,ic1,ib) - scarhd(ih1,ic1,ib)) + ss00 = ssarhd(ih1,ic1,ib) & + & + rdrh * (ssarhd(ih2,ic1,ib) - ssarhd(ih1,ic1,ib)) + as00 = asyrhd(ih1,ic1,ib) & + & + rdrh * (asyrhd(ih2,ic1,ib) - asyrhd(ih1,ic1,ib)) + + tt0 = cm * ex00 + ext1 = ext1 + tt0 + sca1 = sca1 + cm * sc00 + ssa1 = ssa1 + cm * ss00 * ex00 + asy1 = asy1 + cm * as00 * sc00 + endif lab_if_ic + +! --- compute aod from individual species' contribution (optional) + if ( ib==nv_aod ) then + spcodp(idx) = spcodp(idx) + tt0*denn(1)*delz(kk) ! idx for dif species + endif + + endif lab_if_cm + enddo lab_do_icmp + + tauae(kk,ib) = ext1 * denn(1) * delz(kk) + ssaae(kk,ib) = min(f_one, ssa1/ext1) + asyae(kk,ib) = min(f_one, asy1/sca1) + enddo lab_do_ib + + elseif (idom == 2) then lab_if_idom +! --- 2nd domain - mineral transport layers + + do ib = 1, NSWLWBD + tauae(kk,ib) = extrhi(6,ib) * denn(2) * delz(kk) + ssaae(kk,ib) = ssarhi(6,ib) + asyae(kk,ib) = asyrhi(6,ib) + enddo + +! --- compute aod from individual species' contribution (optional) + spcodp(1) = spcodp(1) + tauae(kk,nv_aod) ! dust + + else lab_if_idom +! --- domain index out off range, assume no aerosol + + do ib = 1, NSWLWBD + tauae(kk,ib) = f_zero + ssaae(kk,ib) = f_one + asyae(kk,ib) = f_zero + enddo + +! write(6,19) kk,idom +! 19 format(/' *** ERROR in sub AEROS: domain index out' & +! &, ' of range! K, IDOM =',3i5,' ***') +! stop 19 + + endif lab_if_idom + + enddo lab_do_layer + +! +!===> ... smooth profile at domain boundaries +! + if ( ivflip == 0 ) then ! input from toa to sfc + + do ib = 1, NSWLWBD + do kk = 2, NLAY + if ( tauae(kk,ib) > f_zero ) then + ratio = tauae(kk-1,ib) / tauae(kk,ib) + else + ratio = f_one + endif + + tt0 = tauae(kk,ib) + tauae(kk-1,ib) + tt1 = 0.2 * tt0 + tt2 = tt0 - tt1 + + if ( ratio > crt1 ) then + tauae(kk,ib) = tt1 + tauae(kk-1,ib) = tt2 + endif + + if ( ratio < crt2 ) then + tauae(kk,ib) = tt2 + tauae(kk-1,ib) = tt1 + endif + enddo ! do_kk_loop + enddo ! do_ib_loop + + else ! input from sfc to toa + + do ib = 1, NSWLWBD + do kk = NLAY-1, 1, -1 + if ( tauae(kk,ib) > f_zero ) then + ratio = tauae(kk+1,ib) / tauae(kk,ib) + else + ratio = f_one + endif + + tt0 = tauae(kk,ib) + tauae(kk+1,ib) + tt1 = 0.2 * tt0 + tt2 = tt0 - tt1 + + if ( ratio > crt1 ) then + tauae(kk,ib) = tt1 + tauae(kk+1,ib) = tt2 + endif + + if ( ratio < crt2 ) then + tauae(kk,ib) = tt2 + tauae(kk+1,ib) = tt1 + endif + enddo ! do_kk_loop + enddo ! do_ib_loop + + endif + +! + return +!................................ + end subroutine radclimaer +!-------------------------------- +! +!................................... + end subroutine aer_property +!----------------------------------- + +!> @} +! ======================================================================= +! GOCART code modification starts here (Sarah lu) ---------------------! +!! +!! gocart_init : set_aerspc, rd_gocart_clim, rd_gocart_luts, optavg_grt +!! setgocartaer: aeropt_grt, map_aermr + +!> The initialization program for gocart aerosols +!! - determine weight and index for aerosol composition/luts +!! - read in monthly global distribution of gocart aerosols +!! - read and map the tabulated aerosol optical spectral data onto +!! corresponding SW/LW radiation spectral bands. +!! +!>\param NWVTOT total num of wave numbers used in sw spectrum +!!\param solfwv (NWVTOT), solar flux for each individual +!! wavenumber (w/m2) +!!\param soltot total solar flux for the spectrual range (w/m2) +!!\param NWVTIR total num of wave numbers used in the ir region +!!\param eirfwv (NWVTIR), ir flux(273k) for each individual +!! wavenumber (w/m2) +!!\param NBDSW num of bands calculated for sw aeros opt prop +!!\param NLWBND num of bands calculated for lw aeros opt prop +!!\param NSWLWBD total num of bands calc for sw+lw aeros opt prop +!!\param imon month of the year +!!\param me print message control flag +!!\param raddt +!!\param fdaer +!>\section gel_go_ini General Algorithm +!! @{ +!----------------------------------- + subroutine gocart_init & + & ( NWVTOT,solfwv,soltot,NWVTIR,eirfwv, & ! --- inputs: + & NBDSW,NLWBND,NSWLWBD,imon,me,raddt,fdaer & ! --- outputs: ( none ) + & ) + +! ================================================================== ! +! ! +! subprogram : gocart_init ! +! ! +! this is the initialization program for gocart aerosols ! +! ! +! - determine weight and index for aerosol composition/luts ! +! - read in monthly global distribution of gocart aerosols ! +! - read and map the tabulated aerosol optical spectral data ! +! onto corresponding sw/lw radiation spectral bands. ! +! ! +! ==================== defination of variables =================== ! +! ! +! inputs: ! +! NWVTOT - total num of wave numbers used in sw spectrum ! +! solfwv(NWVTOT) - solar flux for each individual wavenumber (w/m2)! +! soltot - total solar flux for the spectrual range (w/m2)! +! NWVTIR - total num of wave numbers used in the ir region ! +! eirfwv(NWVTIR) - ir flux(273k) for each individual wavenum (w/m2)! +! NBDSW - num of bands calculated for sw aeros opt prop ! +! NLWBND - num of bands calculated for lw aeros opt prop ! +! NSWLWBD - total num of bands calc for sw+lw aeros opt prop! +! imon - month of the year ! +! me - print message control flag ! +! ! +! outputs: (to the module variables) ! +! ! +! module variables: ! +! NBDSW - total number of sw spectral bands ! +! wvnum1,wvnum2 (NSWSTR:NSWEND) ! +! - start/end wavenumbers for each of sw bands ! +! NBDLW - total number of lw spectral bands ! +! wvnlw1,wvnlw2 (NBDLW) ! +! - start/end wavenumbers for each of lw bands ! +! NSWLWBD - total number of sw+lw bands used in this version ! +! extrhi_grt - extinction coef for rh-indep aeros KCM1*NSWLWBD ! +! ssarhi_grt - single-scat-alb for rh-indep aeros KCM1*NSWLWBD ! +! asyrhi_grt - asymmetry factor for rh-indep aeros KCM1*NSWLWBD ! +! extrhd_grt - extinction coef for rh-dep aeros KRHLEV*KCM2*NSWLWBD! +! ssarhd_grt - single-scat-alb for rh-dep aeros KRHLEV*KCM2*NSWLWBD! +! asyrhd_grt - asymmetry factor for rh-dep aerosKRHLEV*KCM2*NSWLWBD! +! ctaer - merging coefficients for fcst/clim fields ! +! get_fcst - option to get fcst aerosol fields ! +! get_clim - option to get clim aerosol fields ! +! dm_indx - index for aer spec to be included in aeropt calculations ! +! dmfcs_indx - index for prognostic aerosol fields ! +! psclmg - geos3/4-gocart pressure IMXG*JMXG*KMXG ! +! dmclmg - geos3-gocart aerosol dry mass IMXG*JMXG*KMXG*NMXG! +! or geos4-gocart aerosol mixing ratio ! +! ! +! usage: call gocart_init ! +! ! +! subprograms called: set_aerspc, rd_gocart_clim, ! +! rd_gocart_luts, optavg_grt ! +! ! +! ================================================================== ! + + implicit none + +! --- inputs: + integer, intent(in) :: NWVTOT,NWVTIR,NBDSW,NLWBND,NSWLWBD,imon,me + + real (kind=kind_phys), intent(in) :: raddt, fdaer + + real (kind=kind_phys), intent(in) :: solfwv(:),soltot, eirfwv(:) + +! --- output: ( none ) + +! --- locals: + + real (kind=kind_phys), dimension(NBDSW,KAERBND) :: solwaer + real (kind=kind_phys), dimension(NBDSW) :: solbnd + real (kind=kind_phys), dimension(NLWBND,KAERBND) :: eirwaer + real (kind=kind_phys), dimension(NLWBND) :: eirbnd + real (kind=kind_phys) :: sumsol, sumir + + integer, dimension(NBDSW) :: nv1, nv2 + integer, dimension(NLWBND) :: nr1, nr2 + + integer :: i, mb, ib, ii, iw, iw1, iw2 + +!===> ... begin here + +!-------------------------------------------------------------------------- +! (1) determine aerosol specification index and merging coefficients +!-------------------------------------------------------------------------- + + if ( .not. lgrtint ) then + +! --- ... already done aerspc initialization, continue + + continue + + else + +! --- ... set aerosol specification index and merging coefficients + + call set_aerspc(raddt,fdaer) +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + + endif ! end if_lgrtinit_block + +! +!-------------------------------------------------------------------------- +! (2) read gocart climatological data +!-------------------------------------------------------------------------- + +! --- ... read gocart climatological data, if needed + + if ( get_clim ) then + + call rd_gocart_clim +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + + endif + +! +!-------------------------------------------------------------------------- +! (3) read and map the tabulated aerosol optical spectral data +! onto corresponding radiation spectral bands +!-------------------------------------------------------------------------- + + if ( .not. lgrtint ) then + +! --- ... already done optical property interpolation, exit + + return + + else + +! --- ... reset lgrtint + + lgrtint = .false. + +! --- ... read tabulated aerosol optical input data + call rd_gocart_luts +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! --- ... compute solar flux weights and interval indices for mapping +! spectral bands between sw radiation and aerosol data + + solbnd (:) = f_zero + solwaer(:,:) = f_zero + + nv_aod = 1 + + do ib = 1, NBDSW + mb = ib + NSWSTR - 1 + ii = 1 + iw1 = nint(wvnsw1(mb)) + iw2 = nint(wvnsw2(mb)) +! +! --- locate the spectral band for 550nm (for aod diag) +! + if (10000./iw1 >= 0.55 .and. & + & 10000./iw2 <= 0.55 ) then + nv_aod = ib + endif + + Lab_swdowhile : do while ( iw1 > iendwv_grt(ii) ) + if ( ii == KAERBND ) exit Lab_swdowhile + ii = ii + 1 + enddo Lab_swdowhile + + sumsol = f_zero + nv1(ib) = ii + + do iw = iw1, iw2 + solbnd(ib) = solbnd(ib) + solfwv(iw) + sumsol = sumsol + solfwv(iw) + + if ( iw == iendwv_grt(ii) ) then + solwaer(ib,ii) = sumsol + + if ( ii < KAERBND ) then + sumsol = f_zero + ii = ii + 1 + endif + endif + enddo + + if ( iw2 /= iendwv_grt(ii) ) then + solwaer(ib,ii) = sumsol + endif + + nv2(ib) = ii + + if((me==0) .and. lckprnt) print *,'RAD-nv1,nv2:', & + & ib,iw1,iw2,nv1(ib),iendwv_grt(nv1(ib)), & + & nv2(ib),iendwv_grt(nv2(ib)), & + & 10000./iw1, 10000./iw2 + enddo ! end do_ib_block for sw + +! --- check the spectral range for the nv_550 band + if((me==0) .and. lckprnt) then + mb = nv_aod + NSWSTR - 1 + iw1 = nint(wvnsw1(mb)) + iw2 = nint(wvnsw2(mb)) + print *,'RAD-nv_aod:', & + & nv_aod, iw1, iw2, 10000./iw1, 10000./iw2 + endif +! +! --- ... compute ir flux weights and interval indices for mapping +! spectral bands between lw radiation and aerosol data + + eirbnd (:) = f_zero + eirwaer(:,:) = f_zero + + do ib = 1, NLWBND + ii = 1 + if ( NLWBND == 1 ) then + iw1 = 400 ! corresponding 25 mu + iw2 = 2500 ! corresponding 4 mu + else + iw1 = nint(wvnlw1(ib)) + iw2 = nint(wvnlw2(ib)) + endif + + Lab_lwdowhile : do while ( iw1 > iendwv_grt(ii) ) + if ( ii == KAERBND ) exit Lab_lwdowhile + ii = ii + 1 + enddo Lab_lwdowhile + + sumir = f_zero + nr1(ib) = ii + + do iw = iw1, iw2 + eirbnd(ib) = eirbnd(ib) + eirfwv(iw) + sumir = sumir + eirfwv(iw) + + if ( iw == iendwv_grt(ii) ) then + eirwaer(ib,ii) = sumir + + if ( ii < KAERBND ) then + sumir = f_zero + ii = ii + 1 + endif + endif + enddo + + if ( iw2 /= iendwv_grt(ii) ) then + eirwaer(ib,ii) = sumir + endif + + nr2(ib) = ii + + if(me==0 .and. lckprnt) print *,'RAD-nr1,nr2:', & + & ib,iw1,iw2,nr1(ib),iendwv_grt(nr1(ib)), & + & nr2(ib),iendwv_grt(nr2(ib)), & + & 10000./iw1, 10000./iw2 + enddo ! end do_ib_block for lw + +! --- compute spectral band mean properties for each species + + call optavg_grt +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + + if(me==0 .and. lckprnt) then + print *, 'RAD -After optavg_grt, sw band info' + do ib = 1, NBDSW + mb = ib + NSWSTR - 1 + print *,'RAD -wvnsw1,wvnsw2: ',ib,wvnsw1(mb),wvnsw2(mb) + print *,'RAD -lamda1,lamda2: ',ib,10000./wvnsw1(mb), & + & 10000./wvnsw2(mb) + print *,'RAD -extrhi_grt:', extrhi_grt(:,ib) +! do i = 1, KRHLEV + do i = 1, KRHLEV, 10 + print *, 'RAD -extrhd_grt:',i,rhlev_grt(i), & + & extrhd_grt(i,:,ib) + enddo + enddo + print *, 'RAD -After optavg_grt, lw band info' + do ib = 1, NLWBND + ii = NBDSW + ib + print *,'RAD -wvnlw1,wvnlw2: ',ib,wvnlw1(ib),wvnlw2(ib) + print *,'RAD -lamda1,lamda2: ',ib,10000./wvnlw1(ib), & + & 10000./wvnlw2(ib) + print *,'RAD -extrhi_grt:', extrhi_grt(:,ii) +! do i = 1, KRHLEV + do i = 1, KRHLEV, 10 + print *, 'RAD -extrhd_grt:',i,rhlev_grt(i), & + & extrhd_grt(i,:,ii) + enddo + enddo + endif + +! --- ... dealoocate input data arrays no longer needed + deallocate ( iendwv_grt ) + if ( allocated(rhidext0_grt) ) then + deallocate ( rhidext0_grt ) + deallocate ( rhidssa0_grt ) + deallocate ( rhidasy0_grt ) + endif + if ( allocated(rhdpext0_grt) ) then + deallocate ( rhdpext0_grt ) + deallocate ( rhdpssa0_grt ) + deallocate ( rhdpasy0_grt ) + endif + + endif ! end if_lgrtinit_block + +! ================= + contains +! ================= + +!> This subroutine determines merging coefficients ctaer; setup aerosol +!! specification. +!----------------------------- + subroutine set_aerspc(raddt,fdaer) +!............................. +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ==================================================================== ! +! ! +! subprogram: set_aerspc ! +! ! +! determine merging coefficients ctaer; ! +! set up aerosol specification: num_gridcomp, gridcomp, dm_indx, ! +! dmfcs_indx, isoot, iwaso, isuso, issam, isscm ! +! ! +! Aerosol optical properties (ext, ssa, asy) are determined from ! +! NMGX (<=12) aerosol species ! +! ==> DU: dust1 (4 sub-micron bins), dust2, dust3, dust4, dust5 ! +! BC: soot_phobic, soot_philic ! +! OC: waso_phobic, waso_philic ! +! SU: suso (=so4) ! +! SS: ssam (accumulation mode), sscm (coarse mode) ! +! ! +! The current version only supports prognostic aerosols (from GOCART ! +! in-line calculations) and climo aerosols (from GEOS-GOCART runs) ! +! ! +! ================================================================== ! +! + implicit none + +! --- inputs: + real (kind=kind_phys), intent(in) :: raddt, fdaer +! --- output: + +! --- local: +! real (kind=kind_phys) :: raddt + integer :: i, indxr + character*2 :: tp, gridcomp_tmp(max_num_gridcomp) + +!! ===> determine ctaer (user specified weight for fcst fields) +! raddt = min(fhswr,fhlwr) / 24. + if( fdaer >= 99999. ) ctaer = f_one + if((fdaer>0.).and.(fdaer<99999.)) ctaer=exp(-raddt/fdaer) + + if(me==0 .and. lckprnt) then + print *, 'RAD -raddt, fdaer,ctaer: ', raddt, fdaer, ctaer + if (ctaer == f_one ) then + print *, 'LU -aerosol fields determined from fcst' + elseif (ctaer == f_zero) then + print *, 'LU -aerosol fields determined from clim' + else + print *, 'LU -aerosol fields determined from fcst/clim' + endif + endif + +!! ===> determine get_fcst and get_clim +!! if fcst is chosen (ctaer == f_one ), set get_clim to F +!! if clim is chosen (ctaer == f_zero), set get_fcst to F + if ( ctaer == f_one ) get_clim = .false. + if ( ctaer == f_zero ) get_fcst = .false. + +!! ===> determine aerosol species to be included in the calculations +!! of aerosol optical properties (ext, ssa, asy) + +!* If climo option is chosen, the aerosol composition is hardwired +!* to full package. If not, the composition is determined from +!* tracer_config on-the-fly (full package or subset) + lab_if_fcst : if ( get_fcst ) then + +!! use tracer_config to determine num_gridcomp and gridcomp + if ( gfs_phy_tracer%doing_GOCART ) then + if ( gfs_phy_tracer%doing_DU ) then + num_gridcomp = num_gridcomp + 1 + gridcomp_tmp(num_gridcomp) = 'DU' + endif + if ( gfs_phy_tracer%doing_SU ) then + num_gridcomp = num_gridcomp + 1 + gridcomp_tmp(num_gridcomp) = 'SU' + endif + if ( gfs_phy_tracer%doing_SS ) then + num_gridcomp = num_gridcomp + 1 + gridcomp_tmp(num_gridcomp) = 'SS' + endif + if ( gfs_phy_tracer%doing_OC ) then + num_gridcomp = num_gridcomp + 1 + gridcomp_tmp(num_gridcomp) = 'OC' + endif + if ( gfs_phy_tracer%doing_BC ) then + num_gridcomp = num_gridcomp + 1 + gridcomp_tmp(num_gridcomp) = 'BC' + endif +! + if ( num_gridcomp > 0 ) then + allocate ( gridcomp(num_gridcomp) ) + gridcomp(1:num_gridcomp) = gridcomp_tmp(1:num_gridcomp) + else + print *,'ERROR: prognostic aerosols not found,abort',me + stop 1000 + endif + + else ! gfs_phy_tracer%doing_GOCART=F + + print *,'ERROR: prognostic aerosols option off, abort',me + stop 1001 + + endif ! end_if_gfs_phy_tracer%doing_GOCART_if_ + + else lab_if_fcst + +!! set to full package (max_num_gridcomp and max_gridcomp) + num_gridcomp = max_num_gridcomp + allocate ( gridcomp(num_gridcomp) ) + gridcomp(1:num_gridcomp) = max_gridcomp(1:num_gridcomp) + + endif lab_if_fcst + +!! +!! Aerosol specification is determined as such: +!! A. For radiation-aerosol feedback, the specification is based on the aeropt +!! routine from Mian Chin and Hongbin Yu (hydrophobic and hydrophilic for +!! OC/BC; submicron and supermicron for SS, 8-bins (with 4 subgroups for the +!! the submicron bin) for DU, and SO4 for SU) +!! B. For transport, the specification is determined from GOCART in-line module +!! C. For LUTS, (waso, soot, ssam, sscm, suso, dust) is used, based on the +!! the OPAC climo aerosol scheme (implemented by Yu-Tai Hou) + +!!=== determine dm_indx and NMXG + indxr = 0 + dm_indx%waso_phobic = -999 ! OC + dm_indx%soot_phobic = -999 ! BC + dm_indx%ssam = -999 ! SS + dm_indx%suso = -999 ! SU + dm_indx%dust1 = -999 ! DU + do i = 1, num_gridcomp + tp = gridcomp(i) + select case ( tp ) + case ( 'OC') ! consider hydrophobic and hydrophilic + dm_indx%waso_phobic = indxr + 1 + dm_indx%waso_philic = indxr + 2 + indxr = indxr + 2 + case ( 'BC') ! consider hydrophobic and hydrophilic + dm_indx%soot_phobic = indxr + 1 + dm_indx%soot_philic = indxr + 2 + indxr = indxr + 2 + case ( 'SS') ! consider submicron and supermicron + dm_indx%ssam = indxr + 1 + dm_indx%sscm = indxr + 2 + indxr = indxr + 2 + case ( 'SU') ! consider SO4 only + dm_indx%suso = indxr + 1 + indxr = indxr + 1 + case ( 'DU') ! consider all 5 bins + dm_indx%dust1 = indxr + 1 + dm_indx%dust2 = indxr + 2 + dm_indx%dust3 = indxr + 3 + dm_indx%dust4 = indxr + 4 + dm_indx%dust5 = indxr + 5 + indxr = indxr + 5 + case default + print *,'ERROR: aerosol species not supported, abort',me + stop 1002 + end select + enddo +!! + NMXG = indxr ! num of gocart aer spec for opt cal +!! + +!!=== determine dmfcs_indx +!! SS: 5-bins are considered for transport while only two groups +!! (accumulation/coarse modes) are considered for radiation +!! DU: 5-bins are considered for transport while 8 bins (with the +!! submicorn bin exptended to 4 bins) are considered for radiation +!! SU: DMS, SO2, and MSA are not considered for radiation + + if ( get_fcst ) then + if ( gfs_phy_tracer%doing_OC ) then + dmfcs_indx%ocphobic = trcindx ('ocphobic', gfs_phy_tracer) + dmfcs_indx%ocphilic = trcindx ('ocphilic', gfs_phy_tracer) + endif + if ( gfs_phy_tracer%doing_BC ) then + dmfcs_indx%bcphobic = trcindx ('bcphobic', gfs_phy_tracer) + dmfcs_indx%bcphilic = trcindx ('bcphilic', gfs_phy_tracer) + endif + if ( gfs_phy_tracer%doing_SS ) then + dmfcs_indx%ss001 = trcindx ('ss001', gfs_phy_tracer) + dmfcs_indx%ss002 = trcindx ('ss002', gfs_phy_tracer) + dmfcs_indx%ss003 = trcindx ('ss003', gfs_phy_tracer) + dmfcs_indx%ss004 = trcindx ('ss004', gfs_phy_tracer) + dmfcs_indx%ss005 = trcindx ('ss005', gfs_phy_tracer) + endif + if ( gfs_phy_tracer%doing_SU ) then + dmfcs_indx%so4 = trcindx ('so4', gfs_phy_tracer) + endif + if ( gfs_phy_tracer%doing_DU ) then + dmfcs_indx%du001 = trcindx ('du001', gfs_phy_tracer) + dmfcs_indx%du002 = trcindx ('du002', gfs_phy_tracer) + dmfcs_indx%du003 = trcindx ('du003', gfs_phy_tracer) + dmfcs_indx%du004 = trcindx ('du004', gfs_phy_tracer) + dmfcs_indx%du005 = trcindx ('du005', gfs_phy_tracer) + endif + endif + +!! +!!=== determin KCM, KCM1, KCM2 +!! DU: submicron bin (dust1) contains 4 sub-groups (e.g., hardwire +!! 8 bins for aerosol optical properties luts) +!! OC/BC: while hydrophobic aerosols are rh-independent, the luts +!! for hydrophilic aerosols are used (e.g., use the coeff +!! corresponding to rh=0) +!! + indxr = 1 + isoot = -999 + iwaso = -999 + isuso = -999 + issam = -999 + isscm = -999 + do i = 1, num_gridcomp + tp = gridcomp(i) + if ( tp /= 'DU' ) then !<--- non-dust aerosols + select case ( tp ) + case ( 'OC ') + iwaso = indxr + case ( 'BC ') + isoot = indxr + case ( 'SU ') + isuso = indxr + case ( 'SS ') + issam = indxr + isscm = indxr + 1 + end select + if ( tp /= 'SS' ) then + indxr = indxr + 1 + else + indxr = indxr + 2 + endif + else !<--- dust aerosols + KCM1 = 8 ! num of rh independent aer species + endif + enddo + KCM2 = indxr - 1 ! num of rh dependent aer species + KCM = KCM1 + KCM2 ! total num of aer species + +!! +!! check print starts here + if( me == 0 .and. lckprnt) then + print *, 'RAD -num_gridcomp:', num_gridcomp + print *, 'RAD -gridcomp :', gridcomp(:) + print *, 'RAD -NMXG:', NMXG + print *, 'RAD -dm_indx ===> ' + print *, 'RAD -aerspc: dust1=', dm_indx%dust1 + print *, 'RAD -aerspc: dust2=', dm_indx%dust2 + print *, 'RAD -aerspc: dust3=', dm_indx%dust3 + print *, 'RAD -aerspc: dust4=', dm_indx%dust4 + print *, 'RAD -aerspc: dust5=', dm_indx%dust5 + print *, 'RAD -aerspc: ssam=', dm_indx%ssam + print *, 'RAD -aerspc: sscm=', dm_indx%sscm + print *, 'RAD -aerspc: suso=', dm_indx%suso + print *, 'RAD -aerspc: waso_phobic=',dm_indx%waso_phobic + print *, 'RAD -aerspc: waso_philic=',dm_indx%waso_philic + print *, 'RAD -aerspc: soot_phobic=',dm_indx%soot_phobic + print *, 'RAD -aerspc: soot_philic=',dm_indx%soot_philic + + print *, 'RAD -KCM1 =', KCM1 + print *, 'RAD -KCM2 =', KCM2 + print *, 'RAD -KCM =', KCM + if ( KCM2 > 0 ) then + print *, 'RAD -aerspc: issam=', issam + print *, 'RAD -aerspc: isscm=', isscm + print *, 'RAD -aerspc: isuso=', isuso + print *, 'RAD -aerspc: iwaso=', iwaso + print *, 'RAD -aerspc: isoot=', isoot + endif + + if ( get_fcst ) then + print *, 'RAD -dmfcs_indx ===> ' + print *, 'RAD -trc_du001=',dmfcs_indx%du001 + print *, 'RAD -trc_du002=',dmfcs_indx%du002 + print *, 'RAD -trc_du003=',dmfcs_indx%du003 + print *, 'RAD -trc_du004=',dmfcs_indx%du004 + print *, 'RAD -trc_du005=',dmfcs_indx%du005 + print *, 'RAD -trc_so4 =',dmfcs_indx%so4 + print *, 'RAD -trc_ocphobic=',dmfcs_indx%ocphobic + print *, 'RAD -trc_ocphilic=',dmfcs_indx%ocphilic + print *, 'RAD -trc_bcphobic=',dmfcs_indx%bcphobic + print *, 'RAD -trc_bcphilic=',dmfcs_indx%bcphilic + print *, 'RAD -trc_ss001=',dmfcs_indx%ss001 + print *, 'RAD -trc_ss002=',dmfcs_indx%ss002 + print *, 'RAD -trc_ss003=',dmfcs_indx%ss003 + print *, 'RAD -trc_ss004=',dmfcs_indx%ss004 + print *, 'RAD -trc_ss005=',dmfcs_indx%ss005 + endif + endif +!! check print ends here + + return +! ! + end subroutine set_aerspc + +!----------------------------------- +!> This subroutine reads input gocart aerosol optical data from Mie +!! code calculations. +!----------------------------- + subroutine rd_gocart_luts +!............................. +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ==================================================================== ! +! subprogram: rd_gocart_luts ! +! read input gocart aerosol optical data from Mie code calculations ! +! ! +! Remarks (Quanhua (Mark) Liu, JCSDA, June 2008) ! +! The LUT is for NCEP selected 61 wave numbers and 6 aerosols ! +! (dust, soot, suso, waso, ssam, and sscm) and 36 aerosol effective ! +! size in microns. ! +! ! +! The LUT is computed using Mie code with a logorithm size ! +! distribution for each of 36 effective sizes. The standard deviation ! +! sigma of the size, and min/max size follows Chin et al. 2000 ! +! For each effective size, it corresponds a relative humidity value. ! +! ! +! The LUT contains the density, sigma, relative humidity, mean mode ! +! radius, effective size, mass extinction coefficient, single ! +! scattering albedo, asymmetry factor, and phase function ! +! ! +! ================================================================== ! +! + implicit none + +! --- inputs: +! --- output: + +! --- locals: + INTEGER, PARAMETER :: NP = 100, NP2 = 2*NP, nWave=100, & + & nAero=6, n_p=36 + INTEGER :: NW, NS, nH, n_bin + real (kind=kind_io8), Dimension( NP2 ) :: Angle, Cos_Angle, & + & Cos_Weight + real (kind=kind_io8), Dimension(n_p,nAero) :: RH, rm, reff + real (kind=kind_io8), Dimension(nWave,n_p,nAero) :: & + & ext0, sca0, asy0 + real (kind=kind_io8), Dimension(NP2,n_p,nWave,nAero) :: ph0 + real (kind=kind_io8) :: wavelength(nWave), density(nAero), & + & sigma(nAero), wave,n_fac,PI,t1,s1,g1 + CHARACTER(len=80) :: AerosolName(nAero) + INTEGER :: i, j, k, l, ij + + character :: aerosol_file*30 + logical :: file_exist + integer :: indx_dust(8) ! map 36 dust bins to gocart size bins + + data aerosol_file /"NCEP_AEROSOL.bin"/ + data AerosolName/ ' Dust ', ' Soot ', ' SUSO ', ' WASO ', & + & ' SSAM ', ' SSCM '/ + +!! 8 dust bins +!! 1 2 3 4 5 6 7 8 +!! .1-.18, .18-.3, .3-.6, 0.6-1.0, 1.0-1.8, 1.8-3, 3-6, 6-10 <-- def +!! 0.1399 0.2399 0.4499 0.8000 1.3994 2.3964 4.4964 7.9887 <-- reff + data indx_dust/4, 8, 12, 18, 21, 24, 30, 36/ + + PI = acos(-1.d0) + +! -- allocate aerosol optical data + if ( .not. allocated( iendwv_grt ) ) then + allocate ( iendwv_grt (KAERBND) ) + endif + if (.not. allocated(rhidext0_grt) .and. KCM1 > 0 ) then + allocate ( rhidext0_grt(KAERBND,KCM1)) + allocate ( rhidssa0_grt(KAERBND,KCM1)) + allocate ( rhidasy0_grt(KAERBND,KCM1)) + endif + if (.not. allocated(rhdpext0_grt) .and. KCM2 > 0 ) then + allocate ( rhdpext0_grt(KAERBND,KRHLEV,KCM2)) + allocate ( rhdpssa0_grt(KAERBND,KRHLEV,KCM2)) + allocate ( rhdpasy0_grt(KAERBND,KRHLEV,KCM2)) + endif + +! -- read luts + inquire (file = aerosol_file, exist = file_exist) + + if ( file_exist ) then + if(me==0 .and. lckprnt) print *,'RAD -open :',aerosol_file + close (NIAERCM) + open (unit=NIAERCM,file=aerosol_file,status='OLD', & + & action='read',form='UNFORMATTED') + else + print *,' Requested aerosol data file "',aerosol_file, & + & '" not found!', me + print *,' *** Stopped in subroutine RD_GOCART_LUTS !!' + stop 1003 + endif ! end if_file_exist_block + + READ(NIAERCM) (Cos_Angle(i),i=1,NP) + READ(NIAERCM) (Cos_Weight(i),i=1,NP) + READ(NIAERCM) + READ(NIAERCM) + READ(NIAERCM) NW,NS + READ(NIAERCM) + READ(NIAERCM) (wavelength(i),i=1,NW) + +! --- check nAero and NW + if (NW /= KAERBND) then + print *, "Incorrect spectral band, abort ", NW + stop 1004 + endif + +! --- convert wavelength to wavenumber + do i = 1, KAERBND + iendwv_grt(i) = 10000. / wavelength(i) + if(me==0 .and. lckprnt) print *,'RAD -wn,lamda:', & + & i,iendwv_grt(i),wavelength(i) + enddo + + DO j = 1, nAero + if(me==0 .and. lckprnt) print *,'RAD -read LUTs:', & + & j,AerosolName(j) + READ(NIAERCM) + READ(NIAERCM) + READ(NIAERCM) n_bin, density(j), sigma(j) + READ(NIAERCM) + READ(NIAERCM) (RH(i,j),i=1, n_bin) + READ(NIAERCM) + READ(NIAERCM) (rm(i,j),i=1, n_bin) + READ(NIAERCM) + READ(NIAERCM) (reff(i,j),i=1, n_bin) + +! --- check n_bin + if (n_bin /= KRHLEV ) then + print *, "Incorrect rh levels, abort ", n_bin + stop 1005 + endif + +! --- read luts + DO k = 1, NW + READ(NIAERCM) wave,(ext0(k,L,j),L=1,n_bin) + READ(NIAERCM) (sca0(k,L,j),L=1,n_bin) + READ(NIAERCM) (asy0(k,L,j),L=1,n_bin) + READ(NIAERCM) (ph0(1:NP2,L,k,j),L=1,n_bin) + END DO + +! --- map luts input to module variables + if (AerosolName(j) == ' Dust ' ) then + if ( KCM1 > 0) then !<-- only if rh independent aerosols are needed + do i = 1, KCM1 + rhidext0_grt(1:KAERBND,i)=ext0(1:KAERBND,indx_dust(i),j) + rhidssa0_grt(1:KAERBND,i)=sca0(1:KAERBND,indx_dust(i),j) + rhidasy0_grt(1:KAERBND,i)=asy0(1:KAERBND,indx_dust(i),j) + enddo + endif + else + if ( KCM2 > 0) then !<-- only if rh dependent aerosols are needed + if (AerosolName(j) == ' Soot ') ij = isoot + if (AerosolName(j) == ' SUSO ') ij = isuso + if (AerosolName(j) == ' WASO ') ij = iwaso + if (AerosolName(j) == ' SSAM ') ij = issam + if (AerosolName(j) == ' SSCM ') ij = isscm + if ( ij .ne. -999 ) then + rhdpext0_grt(1:KAERBND,1:KRHLEV,ij) = & + & ext0(1:KAERBND,1:KRHLEV,j) + rhdpssa0_grt(1:KAERBND,1:KRHLEV,ij) = & + & sca0(1:KAERBND,1:KRHLEV,j) + rhdpasy0_grt(1:KAERBND,1:KRHLEV,ij) = & + & asy0(1:KAERBND,1:KRHLEV,j) + endif ! if_ij + endif ! if_KCM2 + endif + END DO + + return +!................................... + end subroutine rd_gocart_luts +!----------------------------------- +! ! +!> This subroutine computes mean aerosols optical properties over each +!! SW/LW radiation spectral band for each of the species components. +!! This program follows GFDL's approach for thick cloud optical property +!! in SW radiation scheme (2000). +!----------------------------- + subroutine optavg_grt +!............................. +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ==================================================================== ! +! ! +! subprogram: optavg_grt ! +! ! +! compute mean aerosols optical properties over each sw/lw radiation ! +! spectral band for each of the species components. This program ! +! follows gfdl's approach for thick cloud opertical property in ! +! sw radiation scheme (2000). ! +! ! +! ==================== defination of variables =================== ! +! ! +! input arguments: ! +! nv1,nv2 (NBDSW) - start/end spectral band indices of aerosol data ! +! for each sw radiation spectral band ! +! nr1,nr2 (NLWBND) - start/end spectral band indices of aerosol data ! +! for each ir radiation spectral band ! +! solwaer (NBDSW,KAERBND) ! +! - solar flux weight over each sw radiation band ! +! vs each aerosol data spectral band ! +! eirwaer (NLWBND,KAERBND) ! +! - ir flux weight over each lw radiation band ! +! vs each aerosol data spectral band ! +! solbnd (NBDSW) - solar flux weight over each sw radiation band ! +! eirbnd (NLWBND) - ir flux weight over each lw radiation band ! +! NBDSW - total number of sw spectral bands ! +! NLWBND - total number of lw spectral bands ! +! NSWLWBD - total number of sw+lw spectral bands ! +! ! +! output arguments: (to module variables) ! +! ! +! ================================================================== ! +! + implicit none + +! --- inputs: +! --- output: + +! --- locals: + real (kind=kind_phys) :: sumk, sumok, sumokg, sumreft, & + & sp, refb, reft, rsolbd, rirbd + + integer :: ib, nb, ni, nh, nc +! +!===> ... begin here + +! --- ... allocate aerosol optical data + if (.not. allocated(extrhd_grt) .and. KCM2 > 0 ) then + allocate ( extrhd_grt(KRHLEV,KCM2,NSWLWBD) ) + allocate ( ssarhd_grt(KRHLEV,KCM2,NSWLWBD) ) + allocate ( asyrhd_grt(KRHLEV,KCM2,NSWLWBD) ) + endif + if (.not. allocated(extrhi_grt) .and. KCM1 > 0 ) then + allocate ( extrhi_grt(KCM1,NSWLWBD) ) + allocate ( ssarhi_grt(KCM1,NSWLWBD) ) + allocate ( asyrhi_grt(KCM1,NSWLWBD) ) + endif +! +! --- ... loop for each sw radiation spectral band + + do nb = 1, NBDSW + rsolbd = f_one / solbnd(nb) + +! --- for rh independent aerosol species + + lab_rhi: if (KCM1 > 0 ) then + do nc = 1, KCM1 + sumk = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nv1(nb), nv2(nb) + sp = sqrt( (f_one - rhidssa0_grt(ni,nc)) & + & / (f_one - rhidssa0_grt(ni,nc)*rhidasy0_grt(ni,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*solwaer(nb,ni) + + sumk = sumk + rhidext0_grt(ni,nc)*solwaer(nb,ni) + sumok = sumok + rhidssa0_grt(ni,nc)*solwaer(nb,ni) & + & * rhidext0_grt(ni,nc) + sumokg = sumokg + rhidssa0_grt(ni,nc)*solwaer(nb,ni) & + & * rhidext0_grt(ni,nc)*rhidasy0_grt(ni,nc) + enddo + + refb = sumreft * rsolbd + + extrhi_grt(nc,nb) = sumk * rsolbd + asyrhi_grt(nc,nb) = sumokg / (sumok + 1.0e-10) + ssarhi_grt(nc,nb) = 4.0*refb & + & / ( (f_one+refb)**2 - asyrhi_grt(nc,nb)*(f_one-refb)**2 ) + + enddo ! end do_nc_block for rh-ind aeros + endif lab_rhi + +! --- for rh dependent aerosols species + + lab_rhd: if (KCM2 > 0 ) then + do nc = 1, KCM2 + do nh = 1, KRHLEV + sumk = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nv1(nb), nv2(nb) + sp = sqrt( (f_one - rhdpssa0_grt(ni,nh,nc)) & + & /(f_one-rhdpssa0_grt(ni,nh,nc)*rhdpasy0_grt(ni,nh,nc))) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*solwaer(nb,ni) + + sumk = sumk + rhdpext0_grt(ni,nh,nc)*solwaer(nb,ni) + sumok = sumok + rhdpssa0_grt(ni,nh,nc)*solwaer(nb,ni) & + & * rhdpext0_grt(ni,nh,nc) + sumokg = sumokg + rhdpssa0_grt(ni,nh,nc)*solwaer(nb,ni) & + & * rhdpext0_grt(ni,nh,nc)*rhdpasy0_grt(ni,nh,nc) + enddo + + refb = sumreft * rsolbd + + extrhd_grt(nh,nc,nb) = sumk * rsolbd + asyrhd_grt(nh,nc,nb) = sumokg / (sumok + 1.0e-10) + ssarhd_grt(nh,nc,nb) = 4.0*refb & + & /((f_one+refb)**2 - asyrhd_grt(nh,nc,nb)*(f_one-refb)**2) + enddo ! end do_nh_block + enddo ! end do_nc_block for rh-dep aeros + endif lab_rhd + + enddo ! end do_nb_block for sw + +! --- ... loop for each lw radiation spectral band + + do nb = 1, NLWBND + + ib = NBDSW + nb + rirbd = f_one / eirbnd(nb) + +! --- for rh independent aerosol species + + lab_rhi_lw: if (KCM1 > 0 ) then + do nc = 1, KCM1 + sumk = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nr1(nb), nr2(nb) + sp = sqrt( (f_one - rhidssa0_grt(ni,nc)) & + & / (f_one - rhidssa0_grt(ni,nc)*rhidasy0_grt(ni,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*eirwaer(nb,ni) + + sumk = sumk + rhidext0_grt(ni,nc)*eirwaer(nb,ni) + sumok = sumok + rhidssa0_grt(ni,nc)*eirwaer(nb,ni) & + & * rhidext0_grt(ni,nc) + sumokg = sumokg + rhidssa0_grt(ni,nc)*eirwaer(nb,ni) & + & * rhidext0_grt(ni,nc)*rhidasy0_grt(ni,nc) + enddo + + refb = sumreft * rirbd + + extrhi_grt(nc,ib) = sumk * rirbd + asyrhi_grt(nc,ib) = sumokg / (sumok + 1.0e-10) + ssarhi_grt(nc,ib) = 4.0*refb & + & / ( (f_one+refb)**2 - asyrhi_grt(nc,ib)*(f_one-refb)**2 ) + enddo ! end do_nc_block for rh-ind aeros + endif lab_rhi_lw + +! --- for rh dependent aerosols species + + lab_rhd_lw: if (KCM2 > 0 ) then + do nc = 1, KCM2 + do nh = 1, KRHLEV + sumk = f_zero + sumok = f_zero + sumokg = f_zero + sumreft = f_zero + + do ni = nr1(nb), nr2(nb) + sp = sqrt( (f_one - rhdpssa0_grt(ni,nh,nc)) & + & /(f_one - rhdpssa0_grt(ni,nh,nc)*rhdpasy0_grt(ni,nh,nc)) ) + reft = (f_one - sp) / (f_one + sp) + sumreft = sumreft + reft*eirwaer(nb,ni) + + sumk = sumk + rhdpext0_grt(ni,nh,nc)*eirwaer(nb,ni) + sumok = sumok + rhdpssa0_grt(ni,nh,nc)*eirwaer(nb,ni) & + & * rhdpext0_grt(ni,nh,nc) + sumokg = sumokg+ rhdpssa0_grt(ni,nh,nc)*eirwaer(nb,ni) & + & * rhdpext0_grt(ni,nh,nc)*rhdpasy0_grt(ni,nh,nc) + enddo + + refb = sumreft * rirbd + + extrhd_grt(nh,nc,ib) = sumk * rirbd + asyrhd_grt(nh,nc,ib) = sumokg / (sumok + 1.0e-10) + ssarhd_grt(nh,nc,ib) = 4.0*refb & + & /((f_one+refb)**2 - asyrhd_grt(nh,nc,ib)*(f_one-refb)**2 ) + enddo ! end do_nh_block + enddo ! end do_nc_block for rh-dep aeros + endif lab_rhd_lw + + enddo ! end do_nb_block for lw + +! + return +!................................ + end subroutine optavg_grt +!-------------------------------- +! +!> This subroutine: +!! - 1. read in aerosol dry mass and surface pressure from GEOS3-GOCART +!! C3.1 2000 monthly dataset or aerosol mixing ratio and surface +!! pressure from GEOS4-GOCART 2000-2007 averaged monthly data set. +!! - 2. compute goes lat/lon array (for horizontal mapping) +!----------------------------------- + subroutine rd_gocart_clim +!................................... +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ================================================================== ! +! ! +! subprogram: rd_gocart_clim ! +! ! +! 1. read in aerosol dry mass and surface pressure from GEOS3-GOCART ! +! C3.1 2000 monthly data set ! +! or aerosol mixing ratio and surface pressure from GEOS4-GOCART ! +! 2000-2007 averaged monthly data set ! +! 2. compute goes lat/lon array (for horizontal mapping) ! +! ! +! ==================== defination of variables =================== ! +! ! +! inputs arguments: ! +! imon - month of the year ! +! me - print message control flag ! +! ! +! outputs arguments: (to the module variables) ! +! psclmg - pressure (sfc to toa) cb IMXG*JMXG*KMXG ! +! dmclmg - aerosol dry mass/mixing ratio IMXG*JMXG*KMXG*NMXG ! +! geos_rlon - goes longitude deg IMXG ! +! geos_rlat - goes latitude deg JMXG ! +! ! +! usage: call rd_gocart_clim ! +! ! +! program history: ! +! 05/18/2010 --- Lu Add the option to read GEOS4-GOCART climo ! +! ================================================================== ! +! + implicit none + +! --- inputs: +! --- output: + +! --- locals: + integer, parameter :: MAXSPC = 5 + real (kind=kind_io4), parameter :: PINT = 0.01 + real (kind=kind_io4), parameter :: EPSQ = 0.0 + + integer :: i, j, k, numspci, ii + integer :: icmp, nrecl, nt1, nt2, nn(MAXSPC) + character :: ymd*6, yr*4, mn*2, tp*2, & + & fname*30, fin*30, aerosol_file*40 + logical :: file_exist + + real (kind=kind_io4), dimension(KMXG) :: sig + real (kind=kind_io4), dimension(IMXG,JMXG) :: ps + real (kind=kind_io4), dimension(IMXG,JMXG,KMXG) :: temp + real (kind=kind_io4), dimension(IMXG,JMXG,KMXG,MAXSPC):: buff + real (kind=kind_phys) :: pstmp + +! Add the following variables for GEOS4-GOCART + real (kind=kind_io4), dimension(KMXG):: hyam, hybm + real (kind=kind_io4) :: p0 + + data yr /'2000'/ !!<=== use 2000 as the climo proxy + +!* sigma_coordinate for GEOS3-GOCART +!* P(i,j,k) = PINT + SIG(k) * (PS(i,j) - PINT) + data SIG / & + & 9.98547E-01,9.94147E-01,9.86350E-01,9.74300E-01,9.56950E-01, & + & 9.33150E-01,9.01750E-01,8.61500E-01,8.11000E-01,7.50600E-01, & + & 6.82900E-01,6.10850E-01,5.37050E-01,4.63900E-01,3.93650E-01, & + & 3.28275E-01,2.69500E-01,2.18295E-01,1.74820E-01,1.38840E-01, & + & 1.09790E-01,8.66900E-02,6.84150E-02,5.39800E-02,4.25750E-02, & + & 3.35700E-02,2.39900E-02,1.36775E-02,5.01750E-03,5.30000E-04 / + +!* hybrid_sigma_pressure_coordinate for GEOS4-GOCART +!* p(i,j,k) = a(k)*p0 + b(k)*ps(i,j) + data hyam/ & + & 0, 0.0062694, 0.02377049, 0.05011813, 0.08278809, 0.1186361, & + & 0.1540329, 0.1836373, 0.2043698, 0.2167788, 0.221193, & + & 0.217729, 0.2062951, 0.1865887, 0.1615213, 0.1372958, & + & 0.1167039, 0.09920014, 0.08432171, 0.06656809, 0.04765031, & + & 0.03382346, 0.0237648, 0.01435208, 0.00659734, 0.002826232, & + & 0.001118959, 0.0004086494, 0.0001368611, 3.750308e-05/ + + data hybm / & + & 0.992555, 0.9642, 0.90556, 0.816375, 0.703815, 0.576585, & + & 0.44445, 0.324385, 0.226815, 0.149165, 0.089375, & + & 0.045865, 0.017485, 0.00348, 0, 0, 0, 0, 0, & + & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 / + + data p0 /1013.25 / + +!===> ... begin here + +! --- allocate and initialize gocart climatological data + if ( .not. allocated (dmclmg) ) then + allocate ( dmclmg(IMXG,JMXG,KMXG,NMXG) ) + allocate ( psclmg(IMXG,JMXG,KMXG) ) + allocate ( molwgt(NMXG) ) + endif + + dmclmg(:,:,:,:) = f_zero + psclmg(:,:,:) = f_zero + molwgt(:) = f_zero + +! --- allocate and initialize geos lat and lon arrays + if ( .not. allocated ( geos_rlon )) then + allocate (geos_rlon(IMXG)) + allocate (geos_rlat(JMXG)) + endif + + geos_rlon(:) = f_zero + geos_rlat(:) = f_zero + +! --- compute geos lat and lon arrays + do i = 1, IMXG + geos_rlon(i) = -180. + (i-1)* dltx + end do + do j = 2, JMXG-1 + geos_rlat(j) = -90. + (j-1)* dlty + end do + geos_rlat(1) = -89.5 + geos_rlat(JMXG) = 89.5 + +! --- determine whether GEOS3 or GEOS4 data set is provided + if ( gocart_climo == 'xxxx' ) then + gocart_climo='0000' +! check geos3-gocart climo + aerosol_file = '200001.PS.avg' + inquire (file = aerosol_file, exist = file_exist) + if ( file_exist ) gocart_climo='ver3' +! check geos4-gocart climo + aerosol_file = 'gocart_climo_2000x2007_ps_01.bin' + inquire (file = aerosol_file, exist = file_exist) + if ( file_exist ) gocart_climo='ver4' + endif +! +! +! --- read ps (sfc pressure) and compute 3d pressure field (psclmg) +! + write(mn,'(i2.2)') imon + ymd = yr//mn + aerosol_file = 'null' + if ( gocart_climo == 'ver3' ) then + aerosol_file = ymd//'.PS.avg' + elseif ( gocart_climo == 'ver4' ) then + aerosol_file = 'gocart_climo_2000x2007_ps_'//mn//'.bin' + endif +! + inquire (file = aerosol_file, exist = file_exist) + lab_if_ps : if ( file_exist ) then + + close(NIAERCM) + if ( gocart_climo == 'ver3' ) then + nrecl = 4 * (IMXG * JMXG) + open(NIAERCM, file=trim(aerosol_file), & + & action='read',access='direct',recl=nrecl) + read(NIAERCM, rec=1) ps + do j = 1, JMXG + do i = 1, IMXG + do k = 1, KMXG + pstmp = pint + sig(k) * (ps(i,j) - pint) + psclmg(i,j,k) = 0.1 * pstmp ! convert mb to cb + enddo + enddo + enddo + + elseif ( gocart_climo == 'ver4' ) then + open(NIAERCM, file=trim(aerosol_file), & + & action='read',status='old', form='unformatted') + read(NIAERCM) ps(:,:) + do j = 1, JMXG + do i = 1, IMXG + do k = 1, KMXG + pstmp = hyam(k)*p0 + hybm(k)*ps(i,j) + psclmg(i,j,k) = 0.1 * pstmp ! convert mb to cb + enddo + enddo + enddo + + endif ! ---- end if_gocart_climo + + else lab_if_ps + + print *,' *** Requested aerosol data file "', & + & trim(aerosol_file), '" not found!' + print *,' *** Stopped in RD_GOCART_CLIM ! ', me + stop 1006 + endif lab_if_ps +! +! --- read aerosol dry mass (g/m3) or mixing ratios (mol/mol,kg/kg) +! + lab_do_icmp : do icmp = 1, num_gridcomp + + tp = gridcomp(icmp) + +! determine aerosol_file + aerosol_file = 'null' + if ( gocart_climo == 'ver3' ) then + if(tp == 'DU') fname='.DU.STD.tv20.g.avg' + if(tp == 'SS') fname='.SS.STD.tv17.g.avg' + if(tp == 'SU') fname='.SU.STD.tv15.g.avg' + if(tp == 'OC') fname='.CC.STD.tv15.g.avg' + if(tp == 'BC') fname='.CC.STD.tv15.g.avg' + aerosol_file=ymd//trim(fname) + elseif ( gocart_climo == 'ver4' ) then + fin = 'gocart_climo_2000x2007_' + if(tp == 'DU') fname=trim(fin)//'du_' + if(tp == 'SS') fname=trim(fin)//'ss_' + if(tp == 'SU') fname=trim(fin)//'su_' + if(tp == 'OC') fname=trim(fin)//'cc_' + if(tp == 'BC') fname=trim(fin)//'cc_' + aerosol_file=trim(fname)//mn//'.bin' + endif + + numspci = 4 + if(tp == 'DU') numspci = 5 + inquire (file=trim(aerosol_file), exist = file_exist) + lab_if_aer: if ( file_exist ) then +! + close(NIAERCM) + if ( gocart_climo == 'ver3' ) then + nrecl = 4 * numspci * (IMXG * JMXG * KMXG + 3) + open (NIAERCM, file=trim(aerosol_file), & + & action='read',access='direct', recl=nrecl) + read(NIAERCM,rec=1)(nt1,nt2,nn(i),buff(:,:,:,i),i=1,numspci) + + elseif ( gocart_climo == 'ver4' ) then + open (NIAERCM, file=trim(aerosol_file), & + & action='read',status='old', form='unformatted') + do i = 1, numspci + do k = 1, KMXG + read(NIAERCM) temp(:,:,k) + buff(:,:,k,i) = temp(:,:,k) + enddo + enddo + endif + +!!===> fill dmclmg with working array buff + select case ( tp ) + +! fill in DU from DU: du1, du2, du3, du4, du5 + case ('DU' ) + if ( dm_indx%dust1 /= -999) then + do ii = 1, 5 + dmclmg(:,:,:,dm_indx%dust1+ii-1) = buff(:,:,:,ii) + enddo + else + print *, 'ERROR: invalid DU index, abort! ',me + stop 1007 + endif + +! fill in BC from CC: bc_phobic, oc_phobic, bc_philic, oc_philic + case ('BC' ) + if ( dm_indx%soot_phobic /= -999) then + dmclmg(:,:,:,dm_indx%soot_phobic)=buff(:,:,:,1) + dmclmg(:,:,:,dm_indx%soot_philic)=buff(:,:,:,3) + molwgt(dm_indx%soot_phobic) = 12. + molwgt(dm_indx%soot_philic) = 12. + else + print *, 'ERROR: invalid BC index, abort! ',me + stop 1008 + endif + +! fill in SU from SU: dms, so2, so4, msa + case ('SU' ) + if ( dm_indx%suso /= -999) then + dmclmg(:,:,:,dm_indx%suso) = buff(:,:,:,3) + molwgt(dm_indx%suso) = 96. + else + print *, 'ERROR: invalid SU index, abort! ',me + stop 1009 + endif + +! fill in OC from CC: bc_phobic, oc_phobic, bc_philic, oc_philic + case ('OC' ) + if ( dm_indx%waso_phobic /= -999) then + dmclmg(:,:,:,dm_indx%waso_phobic) = 1.4*buff(:,:,:,2) + dmclmg(:,:,:,dm_indx%waso_philic) = 1.4*buff(:,:,:,4) + molwgt(dm_indx%waso_phobic) = 12. + molwgt(dm_indx%waso_philic) = 12. + else + print *, 'ERROR: invalid OC index, abort! ',me + stop 1010 + endif + +! fill in SS from SS: ss1, ss2, ss3, ss4 + case ('SS' ) + if ( dm_indx%ssam /= -999) then + dmclmg(:,:,:,dm_indx%ssam) = buff(:,:,:,1) + dmclmg(:,:,:,dm_indx%sscm) = buff(:,:,:,2) + & + & buff(:,:,:,3)+buff(:,:,:,4) + else + print *, 'ERROR: invalid SS index, abort! ',me + stop 1011 + endif + + case default + + print *, 'ERROR: invalid aerosol species, abort ',tp + stop 1012 + + end select + + else lab_if_aer + print *,' *** Requested aerosol data file "',aerosol_file, & + & '" not found!' + print *,' *** Stopped in RD_GOCART_CLIM ! ', me + stop 1013 + endif lab_if_aer + + enddo lab_do_icmp + + return +!................................... + end subroutine rd_gocart_clim +!----------------------------------- +! +!................................... + end subroutine gocart_init +!----------------------------------- +!! @} + +!> This subroutine computes SW + LW aerosol optical properties for +!! gocart aerosol species (merged from fcst and clim fields). +!! +!>\param alon IMAX, longitude of given points in degree +!!\param alat IMAX, latitude of given points in degree +!!\param prslk (IMAX,NLAY), pressure in cb +!!\param rhlay (IMAX,NLAY), layer mean relative humidity +!!\param dz (IMAX,NLAY), layer thickness in m +!!\param hz (IMAX,NLP1), level high in m +!!\param NSWLWBD total number of sw+ir bands for aeros opt prop +!!\param prsl (IMAX,NLAY), layer mean pressure in mb +!!\param tvly (IMAX,NLAY), layer mean virtual temperature in K +!!\param trcly (IMAX,NLAY,NTRAC), layer mean specific tracer in g/g +!!\param IMAX horizontal dimension of arrays +!!\param NLAY,NLP1 vertical dimensions of arrays +!!\param ivflip control flag for direction of vertical index +!!\n =0: index from toa to surface +!!\n =1: index from surface to toa +!!\param lsswr,lslwr logical flag for sw/lw radiation calls +!!\param aerosw (IMAX,NLAY,NBDSW,NF_AESW), aeros opt properties for SW +!!\n (:,:,:,1): optical depth +!!\n (:,:,:,2): single scattering albedo +!!\n (:,:,:,3): asymmetry parameter +!!\param aerolw (IMAX,NLAY,NBDLW,NF_AELW), aeros opt properties for LW +!!\n (:,:,:,1): optical depth +!!\n (:,:,:,2): single scattering albedo +!!\n (:,:,:,3): asymmetry parameter +!>\section gen_setgo General Algorithm +!!@{ +!----------------------------------- + subroutine setgocartaer & + & ( alon,alat,prslk,rhlay,dz,hz,NSWLWBD, & ! --- inputs: + & prsl,tvly,trcly, & + & IMAX,NLAY,NLP1, ivflip, lsswr,lslwr, & + & aerosw,aerolw & ! --- outputs: + & ) + + +! ================================================================== ! +! ! +! setgocartaer computes sw + lw aerosol optical properties for gocart ! +! aerosol species (merged from fcst and clim fields) ! +! ! +! inputs: ! +! alon, alat IMAX ! +! - longitude and latitude of given points in degree ! +! prslk - pressure cb IMAX*NLAY ! +! rhlay - layer mean relative humidity IMAX*NLAY ! +! dz - layer thickness m IMAX*NLAY ! +! hz - level high m IMAX*NLP1 ! +! NSWLWBD - total number of sw+ir bands for aeros opt prop 1 ! +! prsl - layer mean pressure mb IMAX*NLAY ! +! tvly - layer mean virtual temperature k IMAX*NLAY ! +! trcly - layer mean specific tracer g/g IMAX*NLAY*NTRAC! +! IMAX - horizontal dimension of arrays 1 ! +! NLAY,NLP1-vertical dimensions of arrays 1 ! +! ivflip - control flag for direction of vertical index 1 ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lsswr,lslwr ! +! - logical flag for sw/lw radiation calls 1 ! +! ! +! outputs: ! +! aerosw - aeros opt properties for sw IMAX*NLAY*NBDSW*NF_AESW! +! (:,:,:,1): optical depth ! +! (:,:,:,2): single scattering albedo ! +! (:,:,:,3): asymmetry parameter ! +! aerolw - aeros opt properties for lw IMAX*NLAY*NBDLW*NF_AELW! +! (:,:,:,1): optical depth ! +! (:,:,:,2): single scattering albedo ! +! (:,:,:,3): asymmetry parameter ! +! tau_gocart - 550nm aeros opt depth IMAX*NLAY*MAX_NUM_GRIDCOMP! +! ! +! module parameters and constants: ! +! NBDSW - total number of sw bands for aeros opt prop 1 ! +! NLWBND - total number of ir bands for aeros opt prop 1 ! +! ! +! module variable: (set by subroutine gocart_init) ! +! dmclmg - aerosols dry mass/mixing ratios IMXG*JMXG*KMXG*NMXG ! +! psclmg - pressure cb IMXG*JMXG*KMXG ! +! ! +! usage: call setgocartaer ! +! ! +! subprograms called: map_aermr, aeropt_grt ! +! ! +! ================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: IMAX,NLAY,NLP1,ivflip,NSWLWBD + logical, intent(in) :: lsswr, lslwr + + real (kind=kind_phys), dimension(:,:), intent(in) :: prslk, & + & prsl, rhlay, tvly, dz, hz + real (kind=kind_phys), dimension(:), intent(in) :: alon, alat + real (kind=kind_phys), dimension(:,:,:), intent(in) :: trcly + +! --- outputs: + real (kind=kind_phys), dimension(:,:,:,:), intent(out) :: & + & aerosw, aerolw + +! --- locals: + real (kind=kind_phys), dimension(NLAY) :: rh1, dz1 + real (kind=kind_phys), dimension(NLAY,NSWLWBD)::tauae,ssaae,asyae + real (kind=kind_phys), dimension(NLAY,max_num_gridcomp) :: & + & tauae_gocart + + real (kind=kind_phys) :: tmp1, tmp2 + + integer :: i, i1, i2, j1, j2, k, m, m1, kp + +! prognostic aerosols on gfs grids + real (kind=kind_phys), dimension(:,:,:),allocatable:: aermr,dmfcs + +! aerosol (dry mass) on gfs grids/levels + real (kind=kind_phys), dimension(:,:), allocatable :: & + & dmanl,dmclm, dmclmx + real (kind=kind_phys), dimension(KMXG) :: pstmp, pkstr + real (kind=kind_phys) :: ptop, psfc, tem, plv, tv, rho + +! --- conversion constants + real (kind=kind_phys), parameter :: hdltx = 0.5 * dltx + real (kind=kind_phys), parameter :: hdlty = 0.5 * dlty + +!===> ... begin here +! + if ( .not. allocated(dmanl) ) then + allocate ( dmclmx(KMXG,NMXG) ) + allocate ( dmanl(NLAY,NMXG) ) + allocate ( dmclm(NLAY,NMXG) ) + + allocate ( aermr(IMAX,NLAY,NMXG) ) + allocate ( dmfcs(IMAX,NLAY,NMXG) ) + endif +! +!> -# Call map_aermr() to map input tracer array (trcly) to local +!! tracer array (aermr). + dmfcs(:,:,:) = f_zero + lab_if_fcst : if ( get_fcst ) then + + call map_aermr +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + + endif lab_if_fcst +! +!> -# Map geos-gocart climo (dmclmg) to gfs grids (dmclm). + lab_do_IMAX : do i = 1, IMAX + + dmclm(:,:) = f_zero + + lab_if_clim : if ( get_clim ) then +! --- map grid in longitude direction + i2 = 1 + j2 = 1 + tmp1 = alon(i) + if (tmp1 > 180.) tmp1 = tmp1 - 360.0 + lab_do_IMXG : do i1 = 1, IMXG + tmp2 = geos_rlon(i1) + if (tmp2 > 180.) tmp2 = tmp2 - 360.0 + if (abs(tmp1-tmp2) <= hdltx) then + i2 = i1 + exit lab_do_IMXG + endif + enddo lab_do_IMXG + +! --- map grid in latitude direction + lab_do_JMXG : do j1 = 1, JMXG + if (abs(alat(i)-geos_rlat(j1)) <= hdlty) then + j2 = j1 + exit lab_do_JMXG + endif + enddo lab_do_JMXG + +! --- update local arrays pstmp and dmclmx + pstmp(:)= psclmg(i2,j2,:)*1000.0 ! cb to Pa + dmclmx(:,:) = dmclmg(i2,j2,:,:) + +! --- map geos-gocart climo (dmclmx) to gfs level (dmclm) + pkstr(:)=fpkap(pstmp(:)) + psfc = pkstr(1) ! pressure at sfc + ptop = pkstr(KMXG) ! pressure at toa + +! --- map grid in verical direction (follow how ozone is mapped +! in radiation_gases routine) + do k = 1, NLAY + kp = k ! from sfc to toa + if(ivflip==0) kp = NLAY - k + 1 ! from toa to sfc + tmp1 = prslk(i,kp) + + do m1 = 1, KMXG - 1 ! from sfc to toa + if(tmp1 > pkstr(m1+1) .and. tmp1 <= pkstr(m1)) then + tmp2 = f_one / (pkstr(m1)-pkstr(m1+1)) + tem = (pkstr(m1) - tmp1) * tmp2 + dmclm(kp,:) = tem * dmclmx(m1+1,:)+ & + & (f_one-tem) * dmclmx(m1,:) + endif + enddo + +!* if(tmp1 > psfc) dmclm(kp,:) = dmclmx(1,:) +!* if(tmp1 < ptop) dmclm(kp,:) = dmclmx(KMXG,:) + + enddo + endif lab_if_clim +! +! --- compute fcst/clim merged aerosol loading (dmanl) and the +! radiation optical properties (aerosw, aerolw) +! + do k = 1, NLAY + +! --- map global to local arrays (rh1 and dz1) + rh1(k) = rhlay(i,k) + dz1(k) = dz (i,k) + +! --- convert from mixing ratio to dry mass (g/m3) + plv = 100. * prsl(i,k) ! convert pressure from mb to Pa + tv = tvly(i,k) ! virtual temp in K + rho = plv / (con_rd * tv) ! air density in kg/m3 + if ( get_fcst ) then + do m = 1, NMXG ! mixing ratio (g/g) + dmfcs(i,k,m) = max(1000.*(rho*aermr(i,k,m)),f_zero) + enddo ! m_do_loop + endif + if ( get_clim .and. (gocart_climo == 'ver4') ) then + do m = 1, NMXG + dmclm(k,m)=1000.*dmclm(k,m)*rho !mixing ratio (g/g) + if ( molwgt(m) /= 0. ) then !mixing ratio (mol/mol) + dmclm(k,m)=dmclm(k,m) * (molwgt(m)/con_amd) + endif + enddo ! m_do_loop + endif + + +! --- determine dmanl from dmclm and dmfcs + do m = 1, NMXG + dmanl(k,m)= ctaer*dmfcs(i,k,m) + & + & ( f_one-ctaer)*dmclm(k,m) + enddo + enddo + +!> -# Call aeropt_grt() to alculate sw/lw aerosol optical properties +!! for the corresponding frequency bands. + + call aeropt_grt +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + + if ( lsswr ) then + + if ( laswflg ) then + + do m = 1, NBDSW + do k = 1, NLAY + aerosw(i,k,m,1) = tauae(k,m) + aerosw(i,k,m,2) = ssaae(k,m) + aerosw(i,k,m,3) = asyae(k,m) + enddo + enddo + + else + + aerosw(:,:,:,:) = f_zero + + endif + + endif ! end if_lsswr_block + + if ( lslwr ) then + + if ( lalwflg ) then + + if ( NLWBND == 1 ) then + m1 = NBDSW + 1 + do m = 1, NBDLW + do k = 1, NLAY + aerolw(i,k,m,1) = tauae(k,m1) + aerolw(i,k,m,2) = ssaae(k,m1) + aerolw(i,k,m,3) = asyae(k,m1) + enddo + enddo + else + do m = 1, NBDLW + m1 = NBDSW + m + do k = 1, NLAY + aerolw(i,k,m,1) = tauae(k,m1) + aerolw(i,k,m,2) = ssaae(k,m1) + aerolw(i,k,m,3) = asyae(k,m1) + enddo + enddo + endif + + else + + aerolw(:,:,:,:) = f_zero + + endif + endif ! end if_lslwr_block + + enddo lab_do_IMAX + +! ================= + contains +! ================= + +!>\ingroup setaer +!> This subroutine maps input tracer fields (trcly) to local tracer +!! array (aermr). +!----------------------------- + subroutine map_aermr +!............................. +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ==================================================================== ! +! ! +! subprogram: map_aermr ! +! ! +! map input tracer fields (trcly) to local tracer array (aermr) ! +! ! +! ==================== defination of variables =================== ! +! ! +! input arguments: ! +! IMAX - horizontal dimension of arrays 1 ! +! NLAY - vertical dimensions of arrays 1 ! +! trcly - layer tracer mass mixing ratio g/g IMAX*NLAY*NTRAC! +! output arguments: (to module variables) ! +! aermr - layer aerosol mass mixing ratio g/g IMAX*NLAY*NMXG ! +! ! +! note: ! +! NTRAC is the number of tracers excluding water vapor ! +! NMXG is the number of prognostic aerosol species ! +! ================================================================== ! +! + implicit none + +! --- inputs: +! --- output: + +! --- local: + integer :: i, indx, ii + character :: tp*2 + +! initialize + aermr(:,:,:) = f_zero + ii = 1 !! <---- trcly does not contain q + +! ==> DU: du1 (submicron bins), du2, du3, du4, du5 + if( gfs_phy_tracer%doing_DU ) then + aermr(:,:,dm_indx%dust1) = trcly(:,:,dmfcs_indx%du001-ii) + aermr(:,:,dm_indx%dust2) = trcly(:,:,dmfcs_indx%du002-ii) + aermr(:,:,dm_indx%dust3) = trcly(:,:,dmfcs_indx%du003-ii) + aermr(:,:,dm_indx%dust4) = trcly(:,:,dmfcs_indx%du004-ii) + aermr(:,:,dm_indx%dust5) = trcly(:,:,dmfcs_indx%du005-ii) + endif + +! ==> OC: oc_phobic, oc_philic + if( gfs_phy_tracer%doing_OC ) then + aermr(:,:,dm_indx%waso_phobic) = & + & trcly(:,:,dmfcs_indx%ocphobic-ii) + aermr(:,:,dm_indx%waso_philic) = & + & trcly(:,:,dmfcs_indx%ocphilic-ii) + endif + +! ==> BC: bc_phobic, bc_philic + if( gfs_phy_tracer%doing_BC ) then + aermr(:,:,dm_indx%soot_phobic) = & + & trcly(:,:,dmfcs_indx%bcphobic-ii) + aermr(:,:,dm_indx%soot_philic) = & + & trcly(:,:,dmfcs_indx%bcphilic-ii) + endif + +! ==> SS: ss1, ss2 (submicron bins), ss3, ss4, ss5 + if( gfs_phy_tracer%doing_SS ) then + aermr(:,:,dm_indx%ssam) = trcly(:,:,dmfcs_indx%ss001-ii) & + & + trcly(:,:,dmfcs_indx%ss002-ii) + aermr(:,:,dm_indx%sscm) = trcly(:,:,dmfcs_indx%ss003-ii) & + & + trcly(:,:,dmfcs_indx%ss004-ii) & + & + trcly(:,:,dmfcs_indx%ss005-ii) + endif + +! ==> SU: so4 + if( gfs_phy_tracer%doing_SU ) then + aermr(:,:,dm_indx%suso) = trcly(:,:,dmfcs_indx%so4-ii) + endif + + return +!................................... + end subroutine map_aermr +!----------------------------------- + + +!>\ingroup setaer +!! This subroutine computes aerosols optical properties in NSWLWBD +!! SW/LW bands. Aerosol distribution at each grid point is composed +!! from up to NMXG aerosol species (from NUM_GRIDCOMP components). +!----------------------------------- + subroutine aeropt_grt +!................................... +! --- inputs: (in scope variables) +! --- outputs: (in scope variables) + +! ================================================================== ! +! ! +! subprogram: aeropt_grt ! +! ! +! compute aerosols optical properties in NSWLWBD sw/lw bands. ! +! Aerosol distribution at each grid point is composed from up to ! +! NMXG aerosol species (from NUM_GRIDCOMP components). ! +! ! +! input variables: ! +! dmanl - aerosol dry mass g/m3 NLAY*NMXG ! +! rh1 - relative humidity % NLAY ! +! dz1 - layer thickness km NLAY ! +! NLAY - vertical dimensions - 1 ! +! ivflip - control flag for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! output variables: ! +! tauae - aerosol optical depth - NLAY*NSWLWBD ! +! ssaae - aerosol single scattering albedo - NLAY*NSWLWBD ! +! asyae - aerosol asymmetry parameter - NLAY*NSWLWBD ! +! ! +! ================================================================== ! +! + implicit none + +! --- inputs: +! --- outputs: + +! --- locals: + real (kind=kind_phys) :: aerdm + real (kind=kind_phys) :: ext1, ssa1, asy1, ex00, ss00, as00, & + & ex01, ss01, as01, exint + real (kind=kind_phys) :: tau, ssa, asy, & + & sum_tau, sum_ssa, sum_asy + +! --- subgroups for sub-micron dust +! --- corresponds to 0.1-0.18, 0.18-0.3, 0.3-0.6, 0.6-1.0 micron + + real (kind=kind_phys) :: fd(4) + data fd / 0.01053,0.08421,0.25263,0.65263 / + + character :: tp*2 + integer :: icmp, n, kk, ib, ih2, ih1, ii, ij, ijk + real (kind=kind_phys) :: drh0, drh1, rdrh + + real (kind=kind_phys) :: qmin !<--lower bound for opt calc + data qmin / 1.e-20 / + +!===> ... begin here + +! --- initialize (assume no aerosols) + tauae = f_zero + ssaae = f_one + asyae = f_zero + + tauae_gocart = f_zero + +!===> ... loop over vertical layers +! + lab_do_layer : do kk = 1, NLAY + +! --- linear interp coeffs for rh-dep species + + ih2 = 1 + do while ( rh1(kk) > rhlev_grt(ih2) ) + ih2 = ih2 + 1 + if ( ih2 > KRHLEV ) exit + enddo + ih1 = max( 1, ih2-1 ) + ih2 = min( KRHLEV, ih2 ) + + drh0 = rhlev_grt(ih2) - rhlev_grt(ih1) + drh1 = rh1(kk) - rhlev_grt(ih1) + if ( ih1 == ih2 ) then + rdrh = f_zero + else + rdrh = drh1 / drh0 + endif + +! --- loop through sw/lw spectral bands + + lab_do_ib : do ib = 1, NSWLWBD + sum_tau = f_zero + sum_ssa = f_zero + sum_asy = f_zero + +! --- loop through aerosol grid components + lab_do_icmp : do icmp = 1, NUM_GRIDCOMP + ext1 = f_zero + ssa1 = f_zero + asy1 = f_zero + + tp = gridcomp(icmp) + + select case ( tp ) + +! -- dust aerosols: no humidification effect + case ( 'DU') + do n = 1, KCM1 + + if (n <= 4) then + aerdm = dmanl(kk,dm_indx%dust1) * fd(n) + else + aerdm = dmanl(kk,dm_indx%dust1+n-4 ) + endif + + if (aerdm < qmin) aerdm = f_zero + ex00 = extrhi_grt(n,ib)*(1000.*dz1(kk))*aerdm + ss00 = ssarhi_grt(n,ib) + as00 = asyrhi_grt(n,ib) + ext1 = ext1 + ex00 + ssa1 = ssa1 + ex00 * ss00 + asy1 = asy1 + ex00 * ss00 * as00 + + enddo + +! -- suso aerosols: with humidification effect + case ( 'SU') + ij = isuso + exint = extrhd_grt(ih1,ij,ib) & + & + rdrh*(extrhd_grt(ih2,ij,ib) - extrhd_grt(ih1,ij,ib)) + ss00 = ssarhd_grt(ih1,ij,ib) & + & + rdrh*(ssarhd_grt(ih2,ij,ib) - ssarhd_grt(ih1,ij,ib)) + as00 = asyrhd_grt(ih1,ij,ib) & + & + rdrh*(asyrhd_grt(ih2,ij,ib) - asyrhd_grt(ih1,ij,ib)) + + aerdm = dmanl(kk, dm_indx%suso) + if (aerdm < qmin) aerdm = f_zero + ex00 = exint*(1000.*dz1(kk))*aerdm + ext1 = ex00 + ssa1 = ex00 * ss00 + asy1 = ex00 * ss00 * as00 + +! -- seasalt aerosols: with humidification effect + case ( 'SS') + do n = 1, 2 !<---- ssam, sscm + ij = issam + (n-1) + exint = extrhd_grt(ih1,ij,ib) & + & + rdrh*(extrhd_grt(ih2,ij,ib) - extrhd_grt(ih1,ij,ib)) + ss00 = ssarhd_grt(ih1,ij,ib) & + & + rdrh*(ssarhd_grt(ih2,ij,ib) - ssarhd_grt(ih1,ij,ib)) + as00 = asyrhd_grt(ih1,ij,ib) & + & + rdrh*(asyrhd_grt(ih2,ij,ib) - asyrhd_grt(ih1,ij,ib)) + + aerdm = dmanl(kk, dm_indx%ssam+n-1) + if (aerdm < qmin) aerdm = f_zero + ex00 = exint*(1000.*dz1(kk))*aerdm + ext1 = ext1 + ex00 + ssa1 = ssa1 + ex00 * ss00 + asy1 = asy1 + ex00 * ss00 * as00 + + enddo + +! -- organic carbon/black carbon: +! using 'waso' and 'soot' for hydrophilic OC and BC +! using 'waso' and 'soot' at RH=0 for hydrophobic OC and BC + case ( 'OC', 'BC') + if(tp == 'OC') then + ii = dm_indx%waso_phobic + ij = iwaso + else + ii = dm_indx%soot_phobic + ij = isoot + endif + +! --- hydrophobic + aerdm = dmanl(kk, ii) + if (aerdm < qmin) aerdm = f_zero + ex00 = extrhd_grt(1,ij,ib)*(1000.*dz1(kk))*aerdm + ss00 = ssarhd_grt(1,ij,ib) + as00 = asyrhd_grt(1,ij,ib) +! --- hydrophilic + aerdm = dmanl(kk, ii+1) + if (aerdm < qmin) aerdm = f_zero + exint = extrhd_grt(ih1,ij,ib) & + & + rdrh*(extrhd_grt(ih2,ij,ib) - extrhd_grt(ih1,ij,ib)) + ex01 = exint*(1000.*dz1(kk))*aerdm + ss01 = ssarhd_grt(ih1,ij,ib) & + & + rdrh*(ssarhd_grt(ih2,ij,ib) - ssarhd_grt(ih1,ij,ib)) + as01 = asyrhd_grt(ih1,ij,ib) & + & + rdrh*(asyrhd_grt(ih2,ij,ib) - asyrhd_grt(ih1,ij,ib)) + + ext1 = ex00 + ex01 + ssa1 = (ex00 * ss00) + (ex01 * ss01) + asy1 = (ex00 * ss00 * as00) + (ex01 * ss01 * as01) + + end select + +! --- determine tau, ssa, asy for each grid component + tau = ext1 + if (ext1 > f_zero) ssa=min(f_one,ssa1/ext1) + if (ssa1 > f_zero) asy=min(f_one,asy1/ssa1) + +! --- save tau at 550 nm for each grid component + if ( ib == nv_aod ) then + do ijk = 1, max_num_gridcomp + if ( tp == max_gridcomp(ijk) ) then + tauae_gocart(kk,ijk) = tau + endif + enddo + endif + +! --- update sum_tau, sum_ssa, sum_asy + sum_tau = sum_tau + tau + sum_ssa = sum_ssa + tau * ssa + sum_asy = sum_asy + tau * ssa * asy + + enddo lab_do_icmp + + +! --- determine total tau, ssa, asy for aerosol mixture + tauae(kk,ib) = sum_tau + if (sum_tau > f_zero) ssaae(kk,ib) = sum_ssa / sum_tau + if (sum_ssa > f_zero) asyae(kk,ib) = sum_asy / sum_ssa + + enddo lab_do_ib + + enddo lab_do_layer + +! + return +!................................... + end subroutine aeropt_grt +!-------------------------------- + +!................................ + end subroutine setgocartaer +!-------------------------------- +!! @} +! +! GOCART code modification end here (Sarah Lu) ------------------------! +! ======================================================================= + +!..........................................! + end module module_radiation_aerosols ! +!==========================================! +!> @} diff --git a/gsmphys/radiation_astronomy.f b/gsmphys/radiation_astronomy.f new file mode 100644 index 00000000..88301b26 --- /dev/null +++ b/gsmphys/radiation_astronomy.f @@ -0,0 +1,1055 @@ +!> \file radiation_astronomy.f +!! This file sets up astronomical quantities for solar radiation +!! calculations. + +! ========================================================== !!!!! +! 'module_radiation_astronomy' description !!!!! +! ========================================================== !!!!! +! ! +! set up astronomy quantities for solar radiation calculations. ! +! ! +! in module 'module_radiation_astronomy', externally accessable ! +! subroutines are listed below: ! +! ! +! 'sol_init' -- initialization ! +! input: ! +! ( me ) ! +! output: ! +! ( none ) ! +! ! +! 'sol_update' -- update astronomy related quantities ! +! input: ! +! ( jdate,kyear,deltsw,deltim,lsol_chg, me ) ! +! output: ! +! ( slag,sdec,cdec,solcon ) ! +! ! +! 'coszmn' -- compute cosin of zenith angles ! +! input: ! +! ( xlon,sinlat,coslat,solhr,IM, me ) ! +! output: ! +! ( coszen,coszdg ) ! +! ! +! ! +! external modules referenced: ! +! 'module physparam' in 'physparam.f' ! +! 'module physcons' in 'physcons.f' ! +! ! +! program history log: ! +! - a collection of programs to track solar-earth position ! +! may 1977 --- ray orzol (gfdl) created program compjd to ! +! computes julian day and fraction from year,month,dayand,time! +! jun 1977 --- robert white (gfdl) created program cdate to ! +! computes calendar month, day, year from julian day value. ! +! jul 1977 --- robert white (gfdl) created program solar to ! +! computes radius vector, declination and right ascension of ! +! sun, equation of time, hour angle, fractional daylight, and ! +! latitudinal mean zenith angle. ! +! fall 1988 --- hualu pan, updated to limit the iterations in ! +! newton method and also ccr reduced to avoid non-convergence.! +! jul 1989 --- kenneth campana modified subr solar and created ! +! subr zenith for computations of effective mean cosz and ! +! daylight fraction. ! +! oct 1990 --- yu-tai hou created subr coszmn to replace ! +! the latitudinal mean cosz by time mean cosz at grid points. ! +! may 1998 --- mark iredell y2k compliance ! +! dec 2003 --- yu-tai hou combined compjd and fcstim and ! +! rewritten programs in fortran 90 compatable modular form. ! +! feb 2006 --- yu-tai hou add 11-yr solar constant cycle ! +! mar 2009 --- yu-tai hou modified solinit for climate ! +! hindcast situation responding to ic time. ! +! aug 2012 --- yu-tai hou modified coszmn to allows sw ! +! radiation calling interval less than 1 hr limit and linked ! +! model time step with numb of cosz evaluations. also changed ! +! the initialization subroutine 'solinit' into two parts: ! +! 'sol_init' is called at the start of run to set up module ! +! parameters; and 'sol_update' is called within the time ! +! loop to check and update data sets. ! +! nov 2012 --- yu-tai hou modified control parameters thru ! +! model 'physparam'. ! +! jan 2013 --- yu-tai hou modified to include new solar ! +! constant tables (noaa_a0, noaa_an, cmip_an, cmip_mn) ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + + + +!> \ingroup rad +!! \defgroup module_radiation_astronomy module_radiation_astronomy +!! @{ +!> This module sets up astronomical quantities for solar radiation +!! calculations. +!! \version NCEP-Radiation_astronomy v5.2 Jan 2013 +!========================================! + module module_radiation_astronomy ! +!........................................! +! + use physparam, only : isolar, solar_file, kind_phys + use physcons, only : con_solr, con_solr_old, con_pi + use module_iounitdef, only : NIRADSF +! + implicit none +! + private + +! --- version tag and last revision date + character(40), parameter :: & + & VTAGAST='NCEP-Radiation_astronomy v5.2 Jan 2013 ' +! & VTAGAST='NCEP-Radiation_astronomy v5.1 Nov 2012 ' + +!>\name Parameter constants + real (kind=kind_phys), parameter :: degrad = 180.0/con_pi + real (kind=kind_phys), parameter :: tpi = 2.0 * con_pi + real (kind=kind_phys), parameter :: hpi = 0.5 * con_pi + real (kind=kind_phys), parameter :: f12 = 12.0 + real (kind=kind_phys), parameter :: f3600 = 3600.0 + real (kind=kind_phys), parameter :: czlimt = 0.0001 ! ~ cos(89.99427) +! real (kind=kind_phys), parameter :: pid12 = con_pi/f12 ! angle per hour + real (kind=kind_phys), parameter :: pid12 = (2.0*asin(1.0))/f12 + +!> \name Module variable (to be set in module_radiation_astronomy::sol_init): + real (kind=kind_phys), public :: solc0 = con_solr + integer :: isolflg = 10 + character(32) :: solar_fname = ' ' + +!> \name Module variables (to be set in module_radiation_astronomy::sol_update) + +!> equation of time + real (kind=kind_phys) :: sollag=0.0 +!> sine of the solar declination angle + real (kind=kind_phys) :: sindec=0.0 +!> cosine of the solar declination angle + real (kind=kind_phys) :: cosdec=0.0 +!> solar angle increment per interation of cosz calc + real (kind=kind_phys) :: anginc=0.0 +!> saved monthly solar constants (isolflg=4 only) + real (kind=kind_phys) :: smon_sav(12) + data smon_sav(1:12) / 12*con_solr / + +!> saved year of data used + integer :: iyr_sav =0 +!> total number of zenith angle iterations + integer :: nstp =6 + + public sol_init, sol_update, coszmn + + +! ================= + contains +! ================= + +!> This subroutine initializes astronomy process, and set up module +!! constants. +!!\param me print message control flag + subroutine sol_init & + & ( me ) ! --- inputs +! --- outputs: ( none ) + +! =================================================================== ! +! ! +! initialize astronomy process, set up module constants. ! +! ! +! inputs: ! +! me - print message control flag ! +! ! +! outputs: (to module variable) ! +! ( none ) ! +! ! +! external module variable: (in physparam) ! +! isolar - = 0: use the old fixed solar constant in "physcon" ! +! =10: use the new fixed solar constant in "physcon" ! +! = 1: use noaa ann-mean tsi tbl abs-scale with cyc apprx ! +! = 2: use noaa ann-mean tsi tbl tim-scale with cyc apprx ! +! = 3: use cmip5 ann-mean tsi tbl tim-scale with cyc apprx! +! = 4: use cmip5 mon-mean tsi tbl tim-scale with cyc apprx! +! solar_file- external solar constant data table ! +! ! +! internal module variable: ! +! isolflg - internal solar constant scheme control flag ! +! solc0 - solar constant (w/m**2) ! +! solar_fname-file name for solar constant table assigned based on ! +! the scheme control flag, isolflg. ! +! ! +! usage: call sol_init ! +! ! +! subprograms called: none ! +! ! +! =================================================================== ! +! + implicit none + +! --- input: + integer, intent(in) :: me + +! --- output: ( none ) + +! --- local: + logical :: file_exist +! +!===> ... begin here +! + if ( me == 0 ) print *, VTAGAST !print out version tag + +! --- initialization + isolflg = isolar + solc0 = con_solr + solar_fname = solar_file + iyr_sav = 0 + nstp = 6 + + if ( isolar == 0 ) then + solc0 = con_solr_old + if ( me == 0 ) then + print *,' - Using old fixed solar constant =', solc0 + endif + elseif ( isolar == 10 ) then + if ( me == 0 ) then + print *,' - Using new fixed solar constant =', solc0 + endif + elseif ( isolar == 1 ) then ! noaa ann-mean tsi in absolute scale + solar_fname(21:32) = 'noaa_a0.txt' + + if ( me == 0 ) then + print *,' - Using NOAA annual mean TSI table in ABS scale', & + & ' with cycle approximation (old values)!' + endif + + inquire (file=solar_fname, exist=file_exist) + if ( .not. file_exist ) then + isolflg = 10 + + if ( me == 0 ) then + print *,' Requested solar data file "',solar_fname, & + & '" not found!' + print *,' Using the default solar constant value =',solc0,& + & ' reset control flag isolflg=',isolflg + endif + endif + elseif ( isolar == 2 ) then ! noaa ann-mean tsi in tim scale + solar_fname(21:32) = 'noaa_an.txt' + + if ( me == 0 ) then + print *,' - Using NOAA annual mean TSI table in TIM scale', & + & ' with cycle approximation (new values)!' + endif + + inquire (file=solar_fname, exist=file_exist) + if ( .not. file_exist ) then + isolflg = 10 + + if ( me == 0 ) then + print *,' Requested solar data file "',solar_fname, & + & '" not found!' + print *,' Using the default solar constant value =',solc0,& + & ' reset control flag isolflg=',isolflg + endif + endif + elseif ( isolar == 3 ) then ! cmip5 ann-mean tsi in tim scale + solar_fname(21:32) = 'cmip_an.txt' + + if ( me == 0 ) then + print *,' - Using CMIP5 annual mean TSI table in TIM scale', & + & ' with cycle approximation' + endif + + inquire (file=solar_fname, exist=file_exist) + if ( .not. file_exist ) then + isolflg = 10 + + if ( me == 0 ) then + print *,' Requested solar data file "',solar_fname, & + & '" not found!' + print *,' Using the default solar constant value =',solc0,& + & ' reset control flag isolflg=',isolflg + endif + endif + elseif ( isolar == 4 ) then ! cmip5 mon-mean tsi in tim scale + solar_fname(21:32) = 'cmip_mn.txt' + + if ( me == 0 ) then + print *,' - Using CMIP5 monthly mean TSI table in TIM scale', & + & ' with cycle approximation' + endif + + inquire (file=solar_fname, exist=file_exist) + if ( .not. file_exist ) then + isolflg = 10 + + if ( me == 0 ) then + print *,' Requested solar data file "',solar_fname, & + & '" not found!' + print *,' Using the default solar constant value =',solc0,& + & ' reset control flag isolflg=',isolflg + endif + endif + else ! selection error + isolflg = 10 + + if ( me == 0 ) then + print *,' - !!! ERROR in selection of solar constant data', & + & ' source, ISOL =',isolar + print *,' Using the default solar constant value =',solc0, & + & ' reset control flag isolflg=',isolflg + endif + endif ! end if_isolar_block +! + return +!................................... + end subroutine sol_init +!----------------------------------- + + +!> This subroutine computes solar parameters at forecast time. +!!\param jdate ncep absolute date and time at fcst time +!! (yr, mon, day, t-zone, hr, min, sec, mil-sec) +!!\param kyear usually kyear=jdate(1). if not, it is for hindcast +!! mode, and it is usually the init cond time and +!! serves as the upper limit of data can be used. +!!\param deltsw time duration in seconds per sw calculation +!!\param deltim timestep in seconds +!!\param lsol_chg logical flags for change solar constant +!!\param me print message control flag +!!\param slag equation of time in radians +!!\param sdec, cdec sin and cos of the solar declination angle +!!\param solcon sun-earth distance adjusted solar constant +!! \f$(w/m^2)\f$ +!>\section gen_sol_update General Algorithm +!! @{ +!----------------------------------- + subroutine sol_update & + & ( jdate,sdate, kyear,deltsw,deltim,lsol_chg, me, & ! --- inputs + & slag, sdec, cdec, solcon & ! --- outputs + & ) + +! =================================================================== ! +! ! +! sol_update computes solar parameters at forecast time ! +! ! +! inputs: ! +! jdate(8)- ncep absolute date and time at fcst time ! +! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! +! sdate(8)- absolute date and time for solar calculations ! +! (yr, mon, day, t-zone, hr, min, sec, mil-sec) ! +! kyear - usually kyear=jdate(1). if not, it is for hindcast mode,! +! and it is usually the init cond time and serves as the ! +! upper limit of data can be used. ! +! deltsw - time duration in seconds per sw calculation ! +! deltim - timestep in seconds ! +! lsol_chg- logical flags for change solar constant ! +! me - print message control flag ! +! ! +! outputs: ! +! slag - equation of time in radians ! +! sdec, cdec - sin and cos of the solar declination angle ! +! solcon - sun-earth distance adjusted solar constant (w/m2) ! +! ! +! ! +! module variable: ! +! solc0 - solar constant (w/m**2) not adjusted by earth-sun dist ! +! isolflg - solar constant control flag ! +! = 0: use the old fixed solar constant ! +! =10: use the new fixed solar constant ! +! = 1: use noaa ann-mean tsi tbl abs-scale with cycle apprx ! +! = 2: use noaa ann-mean tsi tbl tim-scale with cycle apprx ! +! = 3: use cmip5 ann-mean tsi tbl tim-scale with cycle apprx! +! = 4: use cmip5 mon-mean tsi tbl tim-scale with cycle apprx! +! solar_fname-external solar constant data table ! +! sindec - sine of the solar declination angle ! +! cosdec - cosine of the solar declination angle ! +! anginc - solar angle increment per iteration for cosz calc ! +! nstp - total number of zenith angle iterations ! +! smon_sav- saved monthly solar constants (isolflg=4 only) ! +! iyr_sav - saved year of data previously used ! +! ! +! usage: call sol_update ! +! ! +! subprograms called: solar, prtime ! +! ! +! external functions called: iw3jdn ! +! ! +! =================================================================== ! +! + implicit none + +! --- input: + integer, intent(in) :: jdate(:), sdate(:), kyear, me + logical, intent(in) :: lsol_chg + + real (kind=kind_phys), intent(in) :: deltsw, deltim + +! --- output: + real (kind=kind_phys), intent(out) :: slag, sdec, cdec, solcon + +! --- locals: + real (kind=kind_phys), parameter :: hrday = 1.0/24.0 ! frc day/hour + real (kind=kind_phys), parameter :: minday= 1.0/1440.0 ! frc day/minute + real (kind=kind_phys), parameter :: secday= 1.0/86400.0 ! frc day/second + + real (kind=kind_phys) :: smean, solc1, dtswh, smon(12) + real (kind=kind_phys) :: fjd, fjd1, dlt, r1, alp + + integer :: jd, jd1, iyear, imon, iday, ihr, imin, isec + integer :: iw3jdn + integer :: i, iyr, iyr1, iyr2, jyr, nn, nswr, icy1, icy2, icy + + logical :: file_exist + character :: cline*60 +! +!===> ... begin here +! +! --- ... forecast time + iyear = sdate(1) + imon = sdate(2) + iday = sdate(3) + ihr = sdate(5) + imin = sdate(6) + isec = sdate(7) + + if ( lsol_chg ) then ! get solar constant from data table + + if ( iyr_sav == iyear ) then ! same year, no new reading necessary + if ( isolflg==4 ) then + solc0 = smon_sav(imon) + endif + else ! need to read in new data + iyr_sav = iyear + +! --- ... check to see if the solar constant data file existed + + inquire (file=solar_fname, exist=file_exist) + if ( .not. file_exist ) then + print *,' !!! ERROR! Can not find solar constant file!!!' + stop + else + iyr = iyear + + close(NIRADSF) + open (NIRADSF,file=solar_fname,form='formatted', & + & status='old') + rewind NIRADSF + + read (NIRADSF, * ) iyr1,iyr2,icy1,icy2,smean,cline(1:60) +! read (NIRADSF, 24) iyr1,iyr2,icy1,icy2,smean,cline +! 24 format(4i5,f8.2,a60) + + if ( me == 0 ) then + print *,' Updating solar constant with cycle approx' + print *,' Opened solar constant data file: ',solar_fname +!check print *, iyr1, iyr2, icy1, icy2, smean, cline + endif + +! --- ... check if there is a upper year limit put on the data table + +! if ( iyear /= kyear ) then +! icy = icy1 - iyr1 + 1 ! range of the earlest cycle in data table +! if ( kyear-iyr1 < icy ) then ! need data range at least icy years + ! to perform cycle approximation +! if ( me == 0 ) then +! print *,' *** the requested year',iyear,' and upper',& +! & 'limit',kyear,' do not fit the range of data ', & +! & 'table of iyr1, iyr2 =',iyr1,iyr2 +! print *,' USE FIXED SOLAR CONSTANT=',con_solr +! endif +! solc0 = con_solr +! isolflg = 10 + +! elseif ( kyear < iyr2 ) then + +! --- ... because the usage limit put on the historical data table, +! skip those unused data records at first + +! i = iyr2 +! Lab_dowhile0 : do while ( i > kyear ) +! read (NIRADSF,26) jyr, solc1 +! 26 format(i4,f10.4) +! read (NIRADSF,*) jyr, solc1 +! i = i - 1 +! enddo Lab_dowhile0 + +! iyr2 = kyear ! next record will serve the upper limit + +! endif ! end if_kyear_block +! endif ! end if_iyear_block + +! --- ... checking the cycle range + + if ( iyr < iyr1 ) then + icy = icy1 - iyr1 + 1 ! range of the earlest cycle in data table + Lab_dowhile1 : do while ( iyr < iyr1 ) + iyr = iyr + icy + enddo Lab_dowhile1 + + if ( me == 0 ) then + print *,' *** Year',iyear,' out of table range!', & + & iyr1, iyr2 + print *,' Using the closest-cycle year (',iyr,')' + endif + elseif ( iyr > iyr2 ) then + icy = iyr2 - icy2 + 1 ! range of the latest cycle in data table + Lab_dowhile2 : do while ( iyr > iyr2 ) + iyr = iyr - icy + enddo Lab_dowhile2 + + if ( me == 0 ) then + print *,' *** Year',iyear,' out of table range!', & + & iyr1, iyr2 + print *,' Using the closest-cycle year (',iyr,')' + endif + endif + +! --- ... locate the right record for the year of data + + if ( isolflg < 4 ) then ! use annual mean data tables + i = iyr2 + Lab_dowhile3 : do while ( i >= iyr1 ) +! read (NIRADSF,26) jyr, solc1 +! 26 format(i4,f10.4) + read (NIRADSF,*) jyr, solc1 + + if ( i == iyr .and. iyr == jyr ) then + solc0 = smean + solc1 + + if (me == 0) then + print *,' CHECK: Solar constant data used for year',& + & iyr, solc1, solc0 + endif + exit Lab_dowhile3 + else +!check if(me == 0) print *,' Skip solar const data for yr',i + i = i - 1 + endif + enddo Lab_dowhile3 + elseif ( isolflg == 4 ) then ! use monthly mean data tables + i = iyr2 + Lab_dowhile4 : do while ( i >= iyr1 ) +! read (NIRADSF,26) jyr, smon(:) +! 26 format(i4,12f10.4) + read (NIRADSF,*) jyr, smon(1:12) + + if ( i == iyr .and. iyr == jyr ) then + do nn = 1, 12 + smon_sav(nn) = smean + smon(nn) + enddo + solc0 = smean + smon(imon) + + if (me == 0) then + print *,' CHECK: Solar constant data used for year',& + & iyr,' and month',imon + endif + exit Lab_dowhile4 + else +!check if(me == 0) print *,' Skip solar const data for yr',i + i = i - 1 + endif + enddo Lab_dowhile4 + endif ! end if_isolflg_block + + close ( NIRADSF ) + endif ! end if_file_exist_block + + endif ! end if_iyr_sav_block + endif ! end if_lsol_chg_block + +! --- ... calculate forecast julian day and fraction of julian day + + jd1 = iw3jdn(iyear,imon,iday) + +! --- ... unlike in normal applications, where day starts from 0 hr, +! in astronomy applications, day stats from noon. + + if (ihr < 12) then + jd1 = jd1 - 1 + fjd1= 0.5 + float(ihr)*hrday + float(imin)*minday & + & + float(isec)*secday + else + fjd1= float(ihr - 12)*hrday + float(imin)*minday & + & + float(isec)*secday + endif + + fjd1 = fjd1 + jd1 + + jd = int(fjd1) + fjd = fjd1 - jd + +!> -# Call solar() + call solar & +! --- inputs: + & ( jd, fjd, & +! --- outputs: + & r1, dlt, alp & + & ) + +! --- ... calculate sun-earth distance adjustment factor appropriate to date + solcon = solc0 / (r1*r1) + + slag = sollag + sdec = sindec + cdec = cosdec + +! --- ... diagnostic print out + + if (me == 0) then + + !recalculate julian day with forecast date + iyear = jdate(1) + imon = jdate(2) + iday = jdate(3) + ihr = jdate(5) + imin = jdate(6) + isec = jdate(7) + jd1 = iw3jdn(iyear,imon,iday) + + if (ihr < 12) then + jd1 = jd1 - 1 + fjd1= 0.5 + float(ihr)*hrday + float(imin)*minday & + & + float(isec)*secday + else + fjd1= float(ihr - 12)*hrday + float(imin)*minday & + & + float(isec)*secday + endif + + fjd1 = fjd1 + jd1 + + jd = int(fjd1) + fjd = fjd1 - jd + +!> -# Call prtime() + call prtime & +! --- inputs: + & ( jd, fjd, dlt, alp, r1, solcon ) +! --- outputs: ( none ) + + endif + +! --- ... setting up calculation parameters used by subr coszmn + + nswr = nint(deltsw / deltim) ! number of mdl t-step per sw call + dtswh = deltsw / f3600 ! time length in hours + + if ( deltsw >= f3600 ) then ! for longer sw call interval + nn = max(6, min(12, nint(f3600/deltim) )) ! num of calc per hour + nstp = nint(dtswh) * nn + 1 ! num of calc per sw call + else ! for shorter sw sw call interval + nstp = max(2, min(20, nswr)) + 1 +! nn = nint( float(nstp-1)/dtswh ) + endif + + anginc = pid12 * dtswh / float(nstp-1) ! solar angle inc during each calc step + + if ( me == 0 ) then + print *,' for cosz calculations: nswr,deltim,deltsw,dtswh =', & + & nswr,deltim,deltsw,dtswh,' anginc,nstp =',anginc,nstp + endif + +! if (me == 0) print*,'in sol_update completed sr solar' +! + return +!................................... + end subroutine sol_update +!----------------------------------- +!! @} + + +!> This subroutine computes radius vector, declination and right +!! ascension of sun, and equation of time +!----------------------------------- + subroutine solar & + & ( jd, fjd, & ! --- inputs + & r1, dlt, alp & ! --- outputs + & ) + +! =================================================================== ! +! ! +! solar computes radius vector, declination and right ascension of ! +! sun, and equation of time. ! +! ! +! inputs: ! +! jd - julian day ! +! fjd - fraction of the julian day ! +! ! +! outputs: ! +! r1 - earth-sun radius vector ! +! dlt - declination of sun in radians ! +! alp - right ascension of sun in radians ! +! ! +! module variables: ! +! sollag - equation of time in radians ! +! sindec - sine of declination angle ! +! cosdec - cosine of declination angle ! +! ! +! usage: call solar ! +! ! +! external subroutines called: none ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + real (kind=kind_phys), intent(in) :: fjd + integer, intent(in) :: jd + +! --- outputs: + real (kind=kind_phys), intent(out) :: r1, dlt, alp + +! --- locals: + real (kind=kind_phys), parameter :: cyear = 365.25 ! days of year + real (kind=kind_phys), parameter :: ccr = 1.3e-6 ! iteration limit + real (kind=kind_phys), parameter :: tpp = 1.55 ! days between epoch and + ! perihelion passage of 1900 + real (kind=kind_phys), parameter :: svt6 = 78.035 ! days between perihelion passage + ! and march equinox of 1900 + integer, parameter :: jdor = 2415020 ! jd of epoch which is january + ! 0, 1900 at 12 hours ut + + real (kind=kind_phys) :: dat, t1, year, tyear, ec, angin, ador, & + & deleqn, sni, tini, er, qq, e1, ep, cd, eq, date, em, & + & cr, w1, tst, sun + + integer :: jdoe, iter + +!===> ... begin here + +! --- ... computes time in julian centuries after epoch + + t1 = float(jd - jdor) / 36525.0 + +! --- ... computes length of anomalistic and tropical years (minus 365 days) + + year = 0.25964134e0 + 0.304e-5 * t1 + tyear= 0.24219879E0 - 0.614e-5 * t1 + +! --- ... computes orbit eccentricity and angle of earth's inclination from t + + ec = 0.01675104e0 - (0.418e-4 + 0.126e-6 * t1) * t1 + angin= 23.452294e0 - (0.0130125e0 + 0.164e-5 * t1) * t1 + + ador = jdor + jdoe = ador + (svt6 * cyear) / (year - tyear) + +! --- ... deleqn is updated svt6 for current date + + deleqn= float(jdoe - jd) * (year - tyear) / cyear + year = year + 365.0 + sni = sin( angin / degrad ) + tini = 1.0 / tan( angin / degrad ) + er = sqrt( (1.0 + ec) / (1.0 - ec) ) + qq = deleqn * tpi / year + +! --- ... determine true anomaly at equinox + + e1 = 1.0 + cd = 1.0 + iter = 0 + + lab_do_1 : do while ( cd > ccr ) + + ep = e1 - (e1 - ec*sin(e1) - qq) / (1.0 - ec*cos(e1)) + cd = abs(e1 - ep) + e1 = ep + iter = iter + 1 + + if (iter > 10) then + write(6,*) ' ITERATION COUNT FOR LOOP 32 =', iter + write(6,*) ' E, EP, CD =', e1, ep, cd + exit lab_do_1 + endif + + enddo lab_do_1 + + eq = 2.0 * atan( er * tan( 0.5*e1 ) ) + +! --- ... date is days since last perihelion passage + + dat = float(jd - jdor) - tpp + fjd + date = mod(dat, year) + +! --- ... solve orbit equations by newton's method + + em = tpi * date / year + e1 = 1.0 + cr = 1.0 + iter = 0 + + lab_do_2 : do while ( cr > ccr ) + + ep = e1 - (e1 - ec*sin(e1) - em) / (1.0 - ec*cos(e1)) + cr = abs(e1 - ep) + e1 = ep + iter = iter + 1 + + if (iter > 10) then + write(6,*) ' ITERATION COUNT FOR LOOP 31 =', iter + exit lab_do_2 + endif + + enddo lab_do_2 + + w1 = 2.0 * atan( er * tan( 0.5*e1 ) ) + + r1 = 1.0 - ec*cos(e1) + + sindec = sni * sin(w1 - eq) + cosdec = sqrt( 1.0 - sindec*sindec ) + + dlt = asin( sindec ) + alp = asin( tan(dlt)*tini ) + + tst = cos( w1 - eq ) + if (tst < 0.0) alp = con_pi - alp + if (alp < 0.0) alp = alp + tpi + + sun = tpi * (date - deleqn) / year + if (sun < 0.0) sun = sun + tpi + sollag = sun - alp - 0.03255e0 +! + return +!................................... + end subroutine solar +!----------------------------------- + + +!> This subroutine computes mean cos solar zenith angle over SW calling +!! interval. +!!\param xlon (IM), grids' longitudes in radians, work both on +!! zonal, 0->2pi and -pi->+pi arrangements +!!\param sinlat (IM), sine of the corresponding latitudes +!!\param coslat (IM), cosine of the corresponding latitudes +!!\param solhr time after 00z in hours +!!\param IM num of grids in horizontal dimension +!!\param me print message control flag +!!\param coszen (IM), average of cosz for daytime only in sw call +!! interval +!!\param coszdg (IM), average of cosz over entire sw call interval +!----------------------------------- + subroutine coszmn & + & ( xlon,sinlat,coslat,solhr, IM, me, daily_mean, & ! --- inputs + & coszen, coszdg & ! --- outputs + & ) + +! =================================================================== ! +! ! +! coszmn computes mean cos solar zenith angle over sw calling interval ! +! ! +! inputs: ! +! xlon (IM) - grids' longitudes in radians, work both on zonal ! +! 0->2pi and -pi->+pi arrangements ! +! sinlat(IM) - sine of the corresponding latitudes ! +! coslat(IM) - cosine of the corresponding latitudes ! +! solhr - time after 00z in hours ! +! IM - num of grids in horizontal dimension ! +! me - print message control flag ! +! daily_mean - replace cosz with daily mean value ! +! ! +! outputs: ! +! coszen(IM) - average of cosz for daytime only in sw call interval +! coszdg(IM) - average of cosz over entire sw call interval ! +! ! +! module variables: ! +! sollag - equation of time ! +! sindec - sine of the solar declination angle ! +! cosdec - cosine of the solar declination angle ! +! anginc - solar angle increment per iteration for cosz calc ! +! nstp - total number of zenith angle iterations ! +! ! +! usage: call comzmn ! +! ! +! external subroutines called: none ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: IM, me + + real (kind=kind_phys), intent(in) :: sinlat(:), coslat(:), & + & xlon(:), solhr + + logical, intent(in) :: daily_mean + +! --- outputs: + real (kind=kind_phys), intent(out) :: coszen(:), coszdg(:) + +! --- locals: + real (kind=kind_phys) :: coszn, cns, ss, cc, solang, rstp, h, & + & coszenm(IM) + + integer :: istsun(IM), i, it, j, lat + +!===> ... begin here + + solang = pid12 * (solhr - f12) ! solar angle at present time + rstp = 1.0 / float(nstp) + + do i = 1, IM + coszen(i) = 0.0 + istsun(i) = 0 + enddo + + do it = 1, nstp + cns = solang + float(it-1)*anginc + sollag + + do i = 1, IM + ss = sinlat(i) * sindec + cc = coslat(i) * cosdec + + if (it .eq. 1) then + ! compute daily mean cosine solar zenith angle + ! Zhou et al. (2015) GRL + h = acos(min(max(-ss/cc,-1.),1.)) + coszenm(i) = ss*h/con_pi+cc*(sin(h)-sin(-h))/(2*con_pi) + endif + + coszn = ss + cc * cos(cns + xlon(i)) + coszen(i) = coszen(i) + max(0.0, coszn) + if (coszn > czlimt) istsun(i) = istsun(i) + 1 + enddo + enddo + +! --- ... compute time averages + + do i = 1, IM + coszdg(i) = coszen(i) * rstp + if (istsun(i) > 0) coszen(i) = coszen(i) / istsun(i) + enddo +! +! --- ... replace cosz with daily mean value + if (daily_mean) then + do i = 1, IM + coszdg(i) = coszenm(i) + coszen(i) = coszenm(i) + enddo + endif + + return +!................................... + end subroutine coszmn +!----------------------------------- + + +!> This subroutine prints out forecast date, time, and astronomy +!! quantities. +!----------------------------------- + subroutine prtime & + & ( jd, fjd, dlt, alp, r1, solc & ! --- inputs + & ) ! --- outputs: ( none ) + +! =================================================================== ! +! ! +! prtime prints out forecast date, time, and astronomy quantities. ! +! ! +! inputs: +! jd - forecast julian day ! +! fjd - forecast fraction of julian day ! +! dlt - declination angle of sun in radians ! +! alp - right ascension of sun in radians ! +! r1 - earth-sun radius vector in meter ! +! solc - solar constant in w/m^2 ! +! ! +! outputs: ( none ) ! +! ! +! module variables: ! +! sollag - equation of time in radians ! +! ! +! usage: call prtime ! +! ! +! external subroutines called: w3fs26 ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: jd + + real (kind=kind_phys), intent(in) :: fjd, dlt, alp, r1, solc + +! --- outputs: ( none ) + +! --- locals: + real (kind=kind_phys), parameter :: sixty = 60.0 + + character(LEN=1), parameter :: sign = '-' + character(LEN=1), parameter :: sigb = ' ' + + character(LEN=1) :: dsig + character(LEN=4) :: month(12) + + data month / 'JAN.','FEB.','MAR.','APR.','MAY ','JUNE', & + & 'JULY','AUG.','SEP.','OCT.','NOV ','DEC.' / + + integer :: iday, imon, iyear, ihr, ltd, ltm, & + & ihalp, iyy, jda, mfjd, idaywk, idayyr + real (kind=kind_phys) :: xmin, dltd, dltm, dlts, halp, ymin, & + & asec, eqt, eqsec + +!===> ... begin here + +! --- ... get forecast hour and minute from fraction of julian day + + if (fjd >= 0.5) then + jda = jd + 1 + mfjd= nint( fjd*1440.0 ) + ihr = mfjd / 60 - 12 + xmin= float(mfjd) - (ihr + 12)*sixty + else + jda = jd + mfjd= nint( fjd*1440.0 ) + ihr = mfjd / 60 + 12 + xmin= float(mfjd) - (ihr - 12)*sixty + endif + +! --- ... get forecast year, month, and day from julian day + + call w3fs26(jda, iyear,imon,iday, idaywk,idayyr) + +! -- ... compute solar parameters + + dltd = degrad * dlt + ltd = dltd + dltm = sixty * (abs(dltd) - abs(float(ltd))) + ltm = dltm + dlts = sixty * (dltm - float(ltm)) + + if ((dltd < 0.0) .and. (ltd == 0.0)) then + dsig = sign + else + dsig = sigb + endif + + halp = 6.0 * alp / hpi + ihalp= halp + ymin = abs(halp - float(ihalp)) * sixty + iyy = ymin + asec = (ymin - float(iyy)) * sixty + + eqt = 228.55735 * sollag + eqsec= sixty * eqt + + print 101, iday, month(imon), iyear, ihr, xmin, jd, fjd + 101 format('0 FORECAST DATE',9x,i3,a5,i6,' AT',i3,' HRS',f6.2,' MINS'/& + & ' JULIAN DAY',12x,i8,2x,'PLUS',f11.6) + + print 102, r1, halp, ihalp, iyy, asec + 102 format(' RADIUS VECTOR',9x,f10.7/' RIGHT ASCENSION OF SUN', & + & f12.7,' HRS, OR',i4,' HRS',i4,' MINS',f6.1,' SECS') + + print 103, dltd, dsig, ltd, ltm, dlts, eqt, eqsec, sollag, solc + 103 format(' DECLINATION OF THE SUN',f12.7,' DEGS, OR ',a1,i3, & + & ' DEGS',i4,' MINS',f6.1,' SECS'/' EQUATION OF TIME',6x, & + & f12.7,' MINS, OR',f10.2,' SECS, OR',f9.6,' RADIANS'/ & + & ' SOLAR CONSTANT',8X,F12.7,' (DISTANCE AJUSTED)'//) + +! + return +!................................... + end subroutine prtime +!----------------------------------- + +! +!...........................................! + end module module_radiation_astronomy ! +!===========================================! +!> @} diff --git a/gsmphys/radiation_clouds.F b/gsmphys/radiation_clouds.F new file mode 100644 index 00000000..43f27caa --- /dev/null +++ b/gsmphys/radiation_clouds.F @@ -0,0 +1,4209 @@ +!> \file radiation_clouds.f +!! This file contains routines to compute cloud related quantities +!! for radiation computations. +! module_radiation_clouds description !!!!! +! ========================================================== !!!!! +! ! +! the 'radiation_clouds.f' contains: ! +! ! +! 'module_radiation_clouds' --- compute cloud related quantities! +! for radiation computations ! +! ! +! the following are the externally accessable subroutines: ! +! ! +! 'cld_init' --- initialization routine ! +! inputs: ! +! ( si, NLAY, me ) ! +! outputs: ! +! ( none ) ! +! ! +! 'progcld1' --- zhao/moorthi prognostic cloud scheme ! +! inputs: ! +! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! +! xlat,xlon,slmsk, ! +! IX, NLAY, NLP1, ! +! outputs: ! +! clouds,clds,mtop,mbot) ! +! ! +! 'progcld2' --- ferrier prognostic cloud microphysics ! +! inputs: ! +! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, ! +! xlat,xlon,slmsk, f_ice,f_rain,r_rime,flgmin, ! +! IX, NLAY, NLP1, ! +! outputs: ! +! clouds,clds,mtop,mbot) ! +! ! +! 'progcld3' --- zhao/moorthi prognostic cloud + pdfcld! +! inputs: ! +! (plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, cnvw,cnvc, ! +! xlat,xlon,slmsk, ! +! ix, nlay, nlp1, ! +! deltaq,sup,kdt,me, ! +! outputs: ! +! clouds,clds,mtop,mbot) +! ! +! 'progclduni' --- for unified clouds with MG microphys! +! inputs: ! +! (plyr,plvl,tlyr,tvly,clw,ciw, ! +! xlat,xlon,slmsk, ! +! IX, NLAY, NLP1, ! +! outputs: ! +! clouds,clds,mtop,mbot) ! +! ! +! 'diagcld1' --- diagnostic cloud calc routine ! +! inputs: ! +! (plyr,plvl,tlyr,rhly,vvel,cv,cvt,cvb, ! +! xlat,xlon,slmsk, ! +! IX, NLAY, NLP1, ! +! outputs: ! +! clouds,clds,mtop,mbot) ! +! ! +! internal accessable only subroutines: ! +! 'gethml' --- get diagnostic hi, mid, low clouds ! +! ! +! 'rhtable' --- rh lookup table for diag cloud scheme ! +! ! +! ! +! cloud array description: ! +! --- for prognostic cloud: icldflg=1 --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path ! +! clouds(:,:,3) - mean effective radius for liquid cloud ! +! clouds(:,:,4) - layer cloud ice water path ! +! clouds(:,:,5) - mean effective radius for ice cloud ! +! clouds(:,:,6) - layer rain drop water path ! +! clouds(:,:,7) - mean effective radius for rain drop ! +! ** clouds(:,:,8) - layer snow flake water path ! +! clouds(:,:,9) - mean effective radius for snow flake ! +! ** fu's scheme need to be normalized by snow density (g/m**3/1.0e6)! +! --- for diagnostic cloud: icldflg=0 --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud optical depth ! +! clouds(:,:,3) - layer cloud single scattering albedo ! +! clouds(:,:,4) - layer cloud asymmetry factor ! +! ! +! external modules referenced: ! +! ! +! 'module physparam' in 'physparam.f' ! +! 'module physcons' in 'physcons.f' ! +! 'module module_microphysics' in 'module_bfmicrophysics.f' ! +! ! +! ! +! program history log: ! +! nov 1992, y.h., k.a.c, a.k. - cloud parameterization ! +! 'cldjms' patterned after slingo and slingo's work (jgr, ! +! 1992), stratiform clouds are allowed in any layer except ! +! the surface and upper stratosphere. the relative humidity ! +! criterion may cery in different model layers. ! +! mar 1993, kenneth campana - created original crhtab tables ! +! for critical rh look up references. +! feb 1994, kenneth campana - modified to use only one table ! +! for all forecast hours. ! +! oct 1995, kenneth campana - tuned cloud rh curves ! +! rh-cld relation from tables created using mitchell-hahn ! +! tuning technique on airforce rtneph observations. ! +! nov 1995, kenneth campana - the bl relationships used ! +! below llyr, except in marine stratus regions. ! +! apr 1996, kenneth campana - save bl cld amt in cld(,5) ! +! aug 1997, kenneth campana - smooth out last bunch of bins ! +! of the rh look up tables ! +! dec 1998, s. moorthi - added prognostic cloud method ! +! apr 2003, yu-tai hou - rewritten in frotran 90 ! +! modulized form 'module_rad_clouds' from combining the original! +! subroutines 'cldjms', 'cldprp', and 'gcljms'. and seperated ! +! prognostic and diagnostic methods into two packages. ! +! --- 2003, s. moorthi - adapted b. ferrier's prognostic ! +! cloud scheme to ncep gfs model as additional option. ! +! apr 2004, yu-tai hou - separated calculation of the ! +! averaged h,m,l,bl cloud amounts from each of the cld schemes ! +! to become an shared individule subprogram 'gethml'. ! +! may 2004, yu-tai hou - rewritten ferrier's scheme as a ! +! separated program 'progcld2' in the cloud module. ! +! apr 2005, yu-tai hou - modified cloud array and module ! +! structures. ! +! dec 2008, yu-tai hou - changed low-cld calculation, ! +! now cantains clds from sfc layer and upward to the low/mid ! +! boundary (include bl-cld). h,m,l clds domain boundaries are ! +! adjusted for better agreement with observations. ! +! jan 2011, yu-tai hou - changed virtual temperature ! +! as input variable instead of originally computed inside the ! +! two prognostic cld schemes 'progcld1' and 'progcld2'. ! +! aug 2012, yu-tai hou - modified subroutine cld_init ! +! to pass all fixed control variables at the start. and set ! +! their correponding internal module variables to be used by ! +! module subroutines. ! +! nov 2012, yu-tai hou - modified control parameters ! +! thru module 'physparam'. ! +! apr 2013, h.lin/y.hou - corrected error in calculating ! +! llyr for different vertical indexing directions. ! +! jul 2013, r. sun/h. pan - modified to use pdf cloud and ! +! convective cloud cover and water for radiation ! +! ! +! jul 2014 s. moorthi - merging with gfs version ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + +!> \ingroup rad +!! \defgroup module_radiation_clouds module_radiation_clouds +!! @{ +!> This module computes cloud related quantities for radiation +!! computations. +!! +!! Knowledge of cloud properties and their vertical structure is +!! important for meteorological studies due to their impact on both the +!! Earth's radiation budget and adiabatic heating within the atmosphere. +!! Cloud properties in the US National Oceanic and Atmospheric +!! Administration National Centers for Environmental Prediction Global +!! Forecast System (GFS) include (i) cloud liquid/ice water path; (ii) +!! the fraction of clouds; (iii) effective radius of water/ice droplet: +!!\version NCEP-Radiation_clouds v5.1 Nov 2012 +!! +!! This module has three externally accessible subroutines: +!! - cld_init() --- initialization routine +!! - progcld1() --- zhao/moorthi prognostic cloud scheme +!! - progcld2() --- ferrier prognostic cloud microphysics +!! - progcld3() --- zhao/moorthi prognostic cloud + pdfcld +!! - diagcld1() --- diagnostic cloud calculation routine +!! +!! and two internally accessable only subroutines: +!! - gethml() --- get diagnostic hi, mid, low,total,BL clouds +!! - rhtable() --- rh lookup table for diag cloud scheme +!! +!> \section gen_al General Algorithm +!! @{ +!! -# Cloud Liquid/Ice Water Path (LWP,IWP) +!!\n We define the fraction of liquid and ice cloud as: +!!\n Fraction of ice cloud (F): \f$F=(273.16K-T)/20\f$ +!!\n LWP = total cloud condensate path X (1-F) +!!\n IWP = total clod condensate path X F +!! +!! -# GFS Cloud Fraction +!! \n The cloud fraction in a given grid box of the GFS model is +!! computed using the parameterization scheme of Xu and Randall(1996) +!! \cite xu_and_randall_1996 : +!! \f[ +!! \sigma =RH^{k_{1}}\left[1-exp\left(-\frac{k_{2}q_{l}}{\left[\left(1-RH\right)q_{s}\right]^{k_{3}}}\right)\right] +!! \f] +!! Where \f$RH\f$ is relative humidity, \f$q_{l}\f$ is the cloud +!! condensate, \f$q_{s}\f$ is saturation specific humidity, +!! \f$k_{1}(=0.25)\f$, \f$k_{2}(=100)\f$, \f$k_{3}(=0.49)\f$ are the +!! empirical parameters. The cloud condensate is partitioned into +!! cloud water and ice in radiation based on temperature. Cloud drop +!! effective radius ranges 5-10 microns over land depending on +!! temperature. Ice crystal radius is function of ice water content +!! (Heymsfield and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996). +!! Maximum-randomly cloud overlapping is used in both long-wave +!! radiation and short-wave radiation. Convective clouds are not +!! considered in radiation. +!!\n +!! -# The parameterization of effective radius of water/ice droplet +!! (\f$r_{e}\f$) +!>\n Two methods has been used to parameterize cloud properties in the +!! GFS model. The first method makes use of a diagnostic cloud scheme, +!! in which cloud properties are determined based on model-predicted +!! temperature, pressure, and boundary layer circulation from +!! Harshvardhan et al. (1989) \cite harshvardhan_et_al_1989 . The +!! diagnostic scheme is now replaced with a prognostic scheme that uses +!! cloud condensate information instead (NCEP Office Note 441). +!! \n For the parameterization of effective radius,\f$r_{ew}\f$, of +!! water droplet, we fix \f$r_{ew}\f$ to a value of \f$10\mu m\f$ over +!! the oceans. Over the land, \f$\f$ is defined as: +!!\f[ +!! r_{ew} = 5+5\times F +!!\f] +!! Thus, the effective radius of cloud water droplets will reach to a +!! minimum values of \f$5\mu m\f$ when F=0, and to a maximum value of +!! \f$10\mu m\f$ when the ice fraction is increasing. +!! \n For ice clouds, following Heymsfield and McFarquhar (1996) +!! \cite heymsfield_and_mcfarquhar_1996, +!! we have made the effective ice droplet radius to be an empirical +!! function of ice water concentration (IWC) and environmental temperature as: +!! \f[ +!! r_{ei}=\begin{cases}(1250/9.917)IWC^{0.109} & T <-50^0C \\(1250/9.337)IWC^{0.080} & -50^0C \leq T<-40^0C\\(1250/9.208)IWC^{0.055} & -40^0C\leq T <-30^0C\\(1250/9.387)IWC^{0.031} & -30^0C \leq T\end{cases} +!! \f] +!! where IWC and IWP satisfy: +!! \f[ +!! IWP_{\triangle Z}=\int_{\triangle Z} IWCdZ +!! \f] +!! @} +!========================================! + module module_radiation_clouds ! +!........................................! +! + use physparam, only : icldflg, icmphys, iovrsw, iovrlw, & + & lcrick, lcnorm, lnoprec, & + & ivflip, kind_phys, kind_io4 + use physcons, only : con_fvirt, con_ttp, con_rocp, & + & con_t0c, con_pi, con_g, con_rd, & + & con_thgni + use module_microphysics, only : rsipath2 + use module_iounitdef, only : NICLTUN +! + implicit none +! + private + +! --- version tag and last revision date + character(40), parameter :: & + & VTAGCLD='NCEP-Radiation_clouds v5.1 Nov 2012 ' +! & VTAGCLD='NCEP-Radiation_clouds v5.0 Aug 2012 ' + +! --- set constant parameters + real (kind=kind_phys), parameter :: gfac=1.0e5/con_g & + &, gord=con_g/con_rd +!> number of fields in cloud array + integer, parameter, public :: NF_CLDS = 9 +!> number of cloud vertical domains + integer, parameter, public :: NK_CLDS = 3 + +!> pressure limits of cloud domain interfaces (low,mid,high) in mb (0.1kPa) + real (kind=kind_phys), save :: ptopc(NK_CLDS+1,2) + +!org data ptopc / 1050., 642., 350., 0.0, 1050., 750., 500., 0.0 / + data ptopc / 1050., 650., 400., 0.0, 1050., 750., 500., 0.0 / + +! real (kind=kind_phys), parameter :: climit = 0.01 + real (kind=kind_phys), parameter :: climit = 0.001, climit2=0.05 + real (kind=kind_phys), parameter :: ovcst = 1.0 - 1.0e-8 + +!> default liq radius to 10 micron + real (kind=kind_phys), parameter :: reliq_def = 10.0 +!> default ice radius to 50 micron + real (kind=kind_phys), parameter :: reice_def = 50.0 +!> default rain radius to 1000 micron + real (kind=kind_phys), parameter :: rrain_def = 1000.0 +!> default snow radius to 250 micron + real (kind=kind_phys), parameter :: rsnow_def = 250.0 + +!> rh in one percent interval + integer, parameter :: NBIN=100 +!> =1,2 for eastern and western hemispheres + integer, parameter :: NLON=2 +!> =1,4 for 60n-30n,30n-equ,equ-30s,30s-60s + integer, parameter :: NLAT=4 +!> =1,4 for bl,low,mid,hi cld type + integer, parameter :: MCLD=4 +!> =1,2 for land,sea + integer, parameter :: NSEAL=2 + +!> default cld single scat albedo + real (kind=kind_phys), parameter :: cldssa_def = 0.99 +!> default cld asymmetry factor + real (kind=kind_phys), parameter :: cldasy_def = 0.84 + +! --- xlabdy: lat bndry between tuning regions, +/- xlim for transition +! xlobdy: lon bndry between tuning regions +!> lat bndry between tuning regions + real (kind=kind_phys) :: xlabdy(3) +!> lon bndry between tuning regions + real (kind=kind_phys) :: xlobdy(3) +!> +/- xlim for transition + real (kind=kind_phys), parameter :: xlim=5.0 + + data xlabdy / 30.0, 0.0, -30.0 /, xlobdy / 0.0, 180., 360. / + +!> low cloud vertical velocity adjustment boundaries in mb/sec + real (kind=kind_phys), parameter :: vvcld1= 0.0003e0 +!> low cloud vertical velocity adjustment boundaries in mb/sec + real (kind=kind_phys), parameter :: vvcld2=-0.0005e0 + +! --- those data will be set up by "cld_init" +! rhcl : tuned rh relation table for diagnostic cloud scheme + +!> tuned relative humidity relation table for diagnostic cloud scheme + real (kind=kind_phys) :: rhcl(NBIN,NLON,NLAT,MCLD,NSEAL) + +!> upper limit of boundary layer clouds + integer :: llyr = 2 +!> maximum-random cloud overlapping method + integer :: iovr = 1 + + public progcld1, progcld2, progcld3, progcld4, progcld5, & + & progcld6, progclduni, diagcld1, cld_init + + +! ================= + contains +! ================= + + +!> This subroutine is an initialization program for cloud-radiation +!! calculations and sets up boundary layer cloud top. +!!\param si model vertical sigma layer interface +!!\param NLAY vertical layer number +!!\param me print control flag +!!\section gen_cld_init General Algorithm +!> @{ +!----------------------------------- + subroutine cld_init & + & ( si, NLAY, me ) ! --- inputs +! --- outputs: +! ( none ) + +! =================================================================== ! +! ! +! abstract: cld_init is an initialization program for cloud-radiation ! +! calculations. it sets up boundary layer cloud top. ! +! ! +! ! +! inputs: ! +! si (L+1) : model vertical sigma layer interface ! +! NLAY : vertical layer number ! +! me : print control flag ! +! ! +! outputs: (none) ! +! to module variables ! +! ! +! external module variables: (in physparam) ! +! icldflg : cloud optical property scheme control flag ! +! =0: model use diagnostic cloud method ! +! =1: model use prognostic cloud method ! +! icmphys : cloud microphysics scheme control flag ! +! =1: zhao/carr/sundqvist microphysics cloud ! +! =3: zhao/carr/sundqvist microphysics cloud +pdfcld! +! iovrsw/iovrlw : sw/lw control flag for cloud overlapping scheme ! +! =0: random overlapping clouds ! +! =1: max/ran overlapping clouds ! +! ivflip : control flag for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! usage: call cld_init ! +! ! +! subroutines called: rhtable ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: NLAY, me + + real (kind=kind_phys), intent(in) :: si(:) + +! --- outputs: (none) + +! --- locals: + integer :: k, kl, ier + +! +!===> ... begin here +! +! --- set up module variables + + iovr = max( iovrsw, iovrlw ) !cld ovlp used for diag HML cld output + + if (me == 0) print *, VTAGCLD !print out version tag + + if ( icldflg == 0 ) then + if (me == 0) print *,' - Using Diagnostic Cloud Method' + +!> -# Call rhtable() to set up tuned relative humidity table. + + call rhtable( me, ier ) + + if (ier < 0) then + write(6,99) ier + 99 format(3x,' *** Error in finding tuned RH table ***' & + &, /3x,' STOP at calling subroutine RHTABLE !!'/) + stop 99 + endif + else + if (me == 0) then + print *,' - Using Prognostic Cloud Method' + if (icmphys == 1) then + print *,' --- Zhao/Carr/Sundqvist microphysics' + elseif (icmphys == 3) then + print *,' --- zhao/carr/sundqvist + pdf cloud' + elseif (icmphys == 4) then + print *,' --- GFDL Lin cloud microphysics' + elseif (icmphys == 5) then + print *,' --- GFDL Lin cloud microphysics + pdf cloud' + else + print *,' !!! ERROR in cloud microphysc specification!!!', & + & ' icmphys (NP3D) =',icmphys + stop + endif + endif + endif + +!> -# Compute the top of BL cld (llyr), which is the topmost non +!! cld(low) layer for stratiform (at or above lowest 0.1 of the +!! atmosphere). + + if ( ivflip == 0 ) then ! data from toa to sfc + lab_do_k0 : do k = NLAY, 2, -1 + kl = k + if (si(k) < 0.9e0) exit lab_do_k0 + enddo lab_do_k0 + + llyr = kl + else ! data from sfc to top + lab_do_k1 : do k = 2, NLAY + kl = k + if (si(k) < 0.9e0) exit lab_do_k1 + enddo lab_do_k1 + + llyr = kl - 1 + endif ! end_if_ivflip + +! + return +!................................... + end subroutine cld_init +!----------------------------------- +!> @} + +!> This subroutine computes cloud related quantities using +!! zhao/moorthi's prognostic cloud microphysics scheme. +!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) +!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) +!!\param tlyr (IX,NLAY), model layer mean temperature in K +!!\param tvly (IX,NLAY), model layer virtual temperature in K +!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm +!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm +!!\param rhly (IX,NLAY), layer relative humidity \f$ (=qlyr/qstl) \f$ +!!\param clw (IX,NLAY), layer cloud condensate amount +!!\param xlat (IX), grid latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param xlon (IX), grid longitude in radians (not used) +!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) +!!\param IX horizontal dimention +!!\param NLAY,NLP1 vertical layer/level dimensions +!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path (not assigned) +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path (not assigned) +!!\n (:,:,9) - mean eff radius for snow flake (micron) +!!\n *** fu's scheme need to be normalized by snow density \f$ (g/m^3/1.0e6)\f$ +!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl +!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops +!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases +!>\section gen_progcld1 General Algorithm +!> @{ +!----------------------------------- + subroutine progcld1 & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: + & xlat,xlon,slmsk, IX, NLAY, NLP1, & + & uni_cld, lmfshal, lmfdeep2, cldcov, & + & clouds,clds,mtop,mbot & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld1 computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld1 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! uni_cld : logical - true for cloud fraction from shoc ! +! lmfshal : logical - true for mass flux shallow convection ! +! lmfdeep2 : logical - true for mass flux deep convection ! +! cldcov : layer cloud fraction (used when uni_cld=.true. ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + logical, intent(in) :: uni_cld, lmfshal, lmfdeep2 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, cldcov + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! --- constant values +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + clwf(i,k) = 0.0 + enddo + enddo +! + if ( lcrick ) then + do i = 1, IX + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, NLAY-1 + do i = 1, IX + clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k) + enddo + enddo + endif + +!> -# Find top pressure for each cloud domain for given latitude. +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +!> -# Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k+1) - plvl(i,k) + clwt = max(0.0, clwf(i,k)) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo + else ! input data from sfc to toa + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k) - plvl(i,k+1) + clwt = max(0.0, clwf(i,k)) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo + endif ! end_if_ivflip + +!> -# Compute effective liquid cloud droplet radius over land. + + do i = 1, IX + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif + enddo + + if (uni_cld) then ! use unified sgs clouds generated outside + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = cldcov(i,k) + enddo + enddo + + else + +!> -# Calculate layer cloud fraction. + + if ( ivflip == 0 ) then ! input data from toa to sfc + + clwmin = 0.0 + if (.not. lmfshal) then + do k = NLAY, 1, -1 + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 +! tem1 = 1000.0 / tem1 + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = NLAY, 1, -1 + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + endif + + else ! input data from sfc to toa + + clwmin = 0.0 + if (.not. lmfshal) then + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 + +! tem1 = 1000.0 / tem1 + + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwt = 1.0e-6 * (plyr(i,k)*0.001) +! clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clwf(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clwf(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + endif + + endif ! end_if_flip + endif ! if (uni_cld) then + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +!> -# Compute effective ice cloud droplet radius following Heymsfield +!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. + + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) + endif + enddo + enddo + +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) +! clouds(i,k,6) = 0.0 + clouds(i,k,7) = rer(i,k) +! clouds(i,k,8) = 0.0 + clouds(i,k,9) = rei(i,k) + enddo + enddo + + +!> -# Call gethml() to compute low,mid,high,total, and boundary layer +!! cloud fractions and clouds top/bottom layer indices for low, mid, +!! and high clouds. +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progcld1 +!----------------------------------- +!> @} + +!> This subroutine computes cloud related quantities using ferrier's +!! prognostic cloud microphysics scheme. +!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) +!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) +!!\param tlyr (IX,NLAY), model layer mean temperature in K +!!\param tvly (IX,NLAY), model layer virtual temperature in K +!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm +!!\param qstl (IX,NLAY), layer saturate humidity in gm/gm +!!\param rhly (IX,NLAY), layer relative humidity (=qlyr/qstl) +!!\param clw (IX,NLAY), layer cloud condensate amount +!!\param f_ice (IX,NLAY), fraction of layer cloud ice (ferrier micro-phys) +!!\param f_rain (IX,NLAY), fraction of layer rain water (ferrier micro-phys) +!!\param r_rime (IX,NLAY), mass ratio of total ice to unrimed ice (>=1) +!!\param flgmin (IX), minimum large ice fraction +!!\param xlat (IX), grid latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param xlon (IX), grid longitude in radians (not used) +!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) +!!\param IX horizontal dimention +!!\param NLAY,NLP1 vertical layer/level dimensions +!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path \f$(g/m^2)\f$ +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path \f$(g/m^2)\f$ +!!\n (:,:,9) - mean eff radius for snow flake (micron) +!!\n *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) +!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl +!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops +!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases +!>\section gen_progcld2 General Algorithm +!> @{ +!----------------------------------- + subroutine progcld2 & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & ! --- inputs: + & xlat,xlon,slmsk, f_ice,f_rain,r_rime,flgmin, & + & IX, NLAY, NLP1, lmfshal, lmfdeep2, & + & clouds,clds,mtop,mbot & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld2 computes cloud related quantities using ! +! ferrier's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld2 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! f_ice (IX,NLAY) : fraction of layer cloud ice (ferrier micro-phys) ! +! f_rain(IX,NLAY) : fraction of layer rain water (ferrier micro-phys) ! +! r_rime(IX,NLAY) : mass ratio of total ice to unrimed ice (>=1) ! +! flgmin(IX) : minimim large ice fraction ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path (g/m**2) ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path (g/m**2) ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! external module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! lnoprec : precip effect in radiation flag (ferrier scheme) ! +! =t: snow/rain has no impact on radiation ! +! =f: snow/rain has impact on radiation ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- constants + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + logical, intent(in) :: lmfshal, lmfdeep2 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, f_ice, f_rain, r_rime + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + real (kind=kind_phys), dimension(:), intent(in) :: flgmin + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, tem2d, clw2, & + & qcwat, qcice, qrain, fcice, frain, rrime, rsden, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id + +! --- constant values +! real (kind=kind_phys), parameter :: xrc3 = 200. + real (kind=kind_phys), parameter :: xrc3 = 100. + +! +!===> ... begin here +! +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + fcice (i,k) = max(0.0, min(1.0, f_ice(i,k))) + frain (i,k) = max(0.0, min(1.0, f_rain(i,k))) + rrime (i,k) = max(1.0, r_rime(i,k)) + tem2d (i,k) = tlyr(i,k) - con_t0c + enddo + enddo +! + if ( lcrick ) then + do i = 1, IX + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, NLAY-1 + do i = 1, IX + clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k) + enddo + enddo + endif + +!> -# Find top pressure (ptopc) for each cloud domain for given latitude. +! - ptopc(k,i): top pressure of each cld domain (k=1-4 are sfc,l,m, +!! h; i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +!> -# Seperate cloud condensate into liquid, ice, and rain types, and +!! save the liquid+ice condensate in array clw2 for later calculation +!! of cloud fraction. + + do k = 1, NLAY + do i = 1, IX + if (tem2d(i,k) > -40.0) then + qcice(i,k) = clwf(i,k) * fcice(i,k) + tem1 = clwf(i,k) - qcice(i,k) + qrain(i,k) = tem1 * frain(i,k) + qcwat(i,k) = tem1 - qrain(i,k) + clw2 (i,k) = qcwat(i,k) + qcice(i,k) + else + qcice(i,k) = clwf(i,k) + qrain(i,k) = 0.0 + qcwat(i,k) = 0.0 + clw2 (i,k) = clwf(i,k) + endif + enddo + enddo + +!> -# Call module_microphysics::rsipath2(), in Ferrier's scheme, to +!! compute layer's cloud liquid, ice, rain, and snow water condensate +!! path and the partical effective radius for liquid droplet, rain drop, +!! and snow flake. + call rsipath2 & +! --- inputs: + & ( plyr, plvl, tlyr, qlyr, qcwat, qcice, qrain, rrime, & + & IX, NLAY, ivflip, flgmin, & +! --- outputs: + & cwp, cip, crp, csp, rew, rer, res, rsden & + & ) + + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = 1, NLAY + do i = 1, IX + tem2d(i,k) = (con_g * plyr(i,k)) & + & / (con_rd* (plvl(i,k+1) - plvl(i,k))) + enddo + enddo + else ! input data from sfc to toa + do k = 1, NLAY + do i = 1, IX + tem2d(i,k) = (con_g * plyr(i,k)) & + & / (con_rd* (plvl(i,k) - plvl(i,k+1))) + enddo + enddo + endif ! end_if_ivflip + +!> -# Calculate layer cloud fraction. + + if ( ivflip == 0 ) then ! input data from toa to sfc + + clwmin = 0.0 + if (.not. lmfshal) then + do k = NLAY, 1, -1 + do i = 1, IX +! clwt = 1.0e-7 * (plyr(i,k)*0.001) +! clwt = 1.0e-6 * (plyr(i,k)*0.001) + clwt = 2.0e-6 * (plyr(i,k)*0.001) +! clwt = 5.0e-6 * (plyr(i,k)*0.001) +! clwt = 5.0e-6 + + if (clw2(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + +! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) +! tem1 = 100.0 / tem1 + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 +! tem1 = 2400.0 / tem1 +!cnt tem1 = 2500.0 / tem1 +! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) +! tem1 = 2000.0 / tem1 +! tem1 = 1000.0 / tem1 +! tem1 = 100.0 / tem1 + + value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = NLAY, 1, -1 + do i = 1, IX +! clwt = 1.0e-6 * (plyr(i,k)*0.001) + clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clw2(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + endif + + else ! input data from sfc to toa + + clwmin = 0.0e-6 + if (.not. lmfshal) then + do k = 1, NLAY + do i = 1, IX +! clwt = 1.0e-7 * (plyr(i,k)*0.001) +! clwt = 1.0e-6 * (plyr(i,k)*0.001) + clwt = 2.0e-6 * (plyr(i,k)*0.001) +! clwt = 5.0e-6 * (plyr(i,k)*0.001) +! clwt = 5.0e-6 + + if (clw2(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) + +! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) +! tem1 = 100.0 / tem1 + + tem1 = min(max(sqrt(sqrt(onemrh*qstl(i,k))),0.0001),1.0) + tem1 = 2000.0 / tem1 +! tem1 = 2400.0 / tem1 +!cnt tem1 = 2500.0 / tem1 +! tem1 = min(max(sqrt(onemrh*qstl(i,k)),0.0001),1.0) +! tem1 = 2000.0 / tem1 +! tem1 = 1000.0 / tem1 +! tem1 = 100.0 / tem1 + + value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX +! clwt = 1.0e-6 * (plyr(i,k)*0.001) + clwt = 2.0e-6 * (plyr(i,k)*0.001) + + if (clw2(i,k) > clwt) then + onemrh= max( 1.e-10, 1.0-rhly(i,k) ) + clwm = clwmin / max( 0.01, plyr(i,k)*0.001 ) +! + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) !jhan + if (lmfdeep2) then + tem1 = xrc3 / tem1 + else + tem1 = 100.0 / tem1 + endif +! + value = max( min( tem1*(clw2(i,k)-clwm), 50.0 ), 0.0 ) + tem2 = sqrt( sqrt(rhly(i,k)) ) + + cldtot(i,k) = max( tem2*(1.0-exp(-value)), 0.0 ) + endif + enddo + enddo + endif + + endif ! end_if_flip + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + +! When lnoprec = .true. snow/rain has no impact on radiation + if ( lnoprec ) then + do k = 1, NLAY + do i = 1, IX + crp(i,k) = 0.0 + csp(i,k) = 0.0 + enddo + enddo + endif +! + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +!> -# Calculate effective ice cloud droplet radius. + + do k = 1, NLAY + do i = 1, IX + tem1 = tlyr(i,k) - con_ttp + tem2 = cip(i,k) + + if (tem2 > 0.0) then + tem3 = tem2d(i,k) * tem2 / tvly(i,k) + + if (tem1 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem1 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem1 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif + +! if (lprnt .and. k == l) print *,' reiL=',rei(i,k),' icec=', & +! & icec,' cip=',cip(i,k),' tem=',tem,' delt=',delt + + rei(i,k) = max(10.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +!!!! rei(i,k) = max(30.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(50.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(100.0, min(rei(i,k), 300.0)) + endif + enddo + enddo +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) + clouds(i,k,6) = crp(i,k) + clouds(i,k,7) = rer(i,k) +! clouds(i,k,8) = csp(i,k) !ncar scheme + clouds(i,k,8) = csp(i,k) * rsden(i,k) !fu's scheme + clouds(i,k,9) = rei(i,k) + enddo + enddo + + +!> -# Call gethml(), to compute low, mid, high, total, and boundary +!! layer cloud fractions and clouds top/bottom layer indices for low, +!! mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progcld2 +!----------------------------------- +!> @} + +!> This subroutine computes cloud related quantities using +!! zhao/moorthi's prognostic cloud microphysics scheme + pdfcld. +!!\param plyr (ix,nlay), model layer mean pressure in mb (100pa) +!!\param plvl (ix,nlp1), model level pressure in mb (100pa) +!!\param tlyr (ix,nlay), model layer mean temperature in K +!!\param tvly (ix,nlay), model layer virtual temperature in K +!!\param qlyr (ix,nlay), layer specific humidity in gm/gm +!!\param qstl (ix,nlay), layer saturate humidity in gm/gm +!!\param rhly (ix,nlay), layer relative humidity (=qlyr/qstl) +!!\param clw (ix,nlay), layer cloud condensate amount +!!\param xlat (ix), grid latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param xlon (ix), grid longitude in radians (not used) +!!\param slmsk (ix), sea/land mask array (sea:0,land:1,sea-ice:2) +!!\param ix horizontal dimention +!!\param nlay,nlp1 vertical layer/level dimensions +!!\param deltaq (ix,nlay), half total water distribution width +!!\param sup supersaturation +!!\param kdt +!!\param me print control flag +!!\param clouds (ix,nlay,nf_clds), cloud profiles +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud liq water path (g/m**2) +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer cloud ice water path (g/m**2) +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path not assigned +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path not assigned +!!\n (:,:,9) - mean eff radius for snow flake(micron) +!!\param clds (ix,5), fraction of clouds for low, mid, hi, tot, bl +!!\param mtop (ix,3), vertical indices for low, mid, hi cloud tops +!!\param mbot (ix,3), vertical indices for low, mid, hi cloud bases +!!\section gen_progcld3 General Algorithm +!> @{ +!----------------------------------- + subroutine progcld3 & + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & ! --- inputs: + & xlat,xlon,slmsk, & + & ix, nlay, nlp1, & + & deltaq,sup,kdt,me, & + & clouds,clds,mtop,mbot & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld3 computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld3 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! plyr (ix,nlay) : model layer mean pressure in mb (100pa) ! +! plvl (ix,nlp1) : model level pressure in mb (100pa) ! +! tlyr (ix,nlay) : model layer mean temperature in k ! +! tvly (ix,nlay) : model layer virtual temperature in k ! +! qlyr (ix,nlay) : layer specific humidity in gm/gm ! +! qstl (ix,nlay) : layer saturate humidity in gm/gm ! +! rhly (ix,nlay) : layer relative humidity (=qlyr/qstl) ! +! clw (ix,nlay) : layer cloud condensate amount ! +! xlat (ix) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (ix) : grid longitude in radians (not used) ! +! slmsk (ix) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! ix : horizontal dimention ! +! nlay,nlp1 : vertical layer/level dimensions ! +! cnvw (ix,nlay) : layer convective cloud condensate ! +! cnvc (ix,nlay) : layer convective cloud cover ! +! deltaq(ix,nlay) : half total water distribution width ! +! sup : supersaturation ! + +! ! +! output variables: ! +! clouds(ix,nlay,nf_clds) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (ix,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (ix,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (ix,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lcrick : control flag for eliminating crick ! +! =t: apply layer smoothing to eliminate crick ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: ix, nlay, nlp1,kdt + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw +! & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc +! real (kind=kind_phys), dimension(:,:), intent(in) :: deltaq + real (kind=kind_phys), dimension(:,:) :: deltaq, cnvw, cnvc + real (kind=kind_phys) qtmp,qsc,rhs + real (kind=kind_phys), intent(in) :: sup + real (kind=kind_phys), parameter :: epsq = 1.0e-12 + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + integer :: me + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(ix,nlay) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf + + real (kind=kind_phys) :: ptop1(ix,nk_clds+1) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, nlay + do i = 1, ix + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + clwf(i,k) = 0.0 + enddo + enddo +! + if ( lcrick ) then + do i = 1, ix + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, nlay-1 + do i = 1, ix + clwf(i,k) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, nlay + do i = 1, ix + clwf(i,k) = clw(i,k) + enddo + enddo + endif + + if(kdt==1) then + do k = 1, nlay + do i = 1, ix + deltaq(i,k) = (1.-0.95)*qstl(i,k) + enddo + enddo + endif + +!> -# Find top pressure (ptopc) for each cloud domain for given latitude. +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,l,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, ix + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +!> -# Calculate liquid/ice condensate path in \f$ g/m^2 \f$ + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = 1, nlay + do i = 1, ix + delp(i,k) = plvl(i,k+1) - plvl(i,k) + clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo + else ! input data from sfc to toa + do k = 1, nlay + do i = 1, ix + delp(i,k) = plvl(i,k) - plvl(i,k+1) + clwt = max(0.0,(clwf(i,k)+cnvw(i,k))) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo + endif ! end_if_ivflip + +!> -# Calculate effective liquid cloud droplet radius over land. + + do i = 1, ix + if (nint(slmsk(i)) == 1) then + do k = 1, nlay + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif + enddo + +!> -# Calculate layer cloud fraction. + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = nlay, 1, -1 + do i = 1, ix + tem1 = tlyr(i,k) - 273.16 + if(tem1 < con_thgni) then ! for pure ice, has to be consistent with gscond + qsc = sup * qstl(i,k) + rhs = sup + else + qsc = qstl(i,k) + rhs = 1.0 + endif + if(rhly(i,k) >= rhs) then + cldtot(i,k) = 1.0 + else + qtmp = qlyr(i,k) + clwf(i,k) - qsc + if(deltaq(i,k) > epsq) then + if(qtmp < -deltaq(i,k) .or. clwf(i,k) < epsq) then +! if(qtmp < -deltaq(i,k)) then + cldtot(i,k) = 0.0 + elseif(qtmp >= deltaq(i,k)) then + cldtot(i,k) = 1.0 + else + cldtot(i,k) = 0.5*qtmp/deltaq(i,k) + 0.5 + cldtot(i,k) = max(cldtot(i,k),0.0) + cldtot(i,k) = min(cldtot(i,k),1.0) + endif + else + if(qtmp.gt.0) then + cldtot(i,k) = 1.0 + else + cldtot(i,k) = 0.0 + endif + endif + endif + cldtot(i,k) = cnvc(i,k)+(1-cnvc(i,k))*cldtot(i,k) + cldtot(i,k) = max(cldtot(i,k),0.) + cldtot(i,k) = min(cldtot(i,k),1.) + enddo + enddo + else ! input data from sfc to toa + do k = 1, nlay + do i = 1, ix + tem1 = tlyr(i,k) - 273.16 + if(tem1 < con_thgni) then ! for pure ice, has to be consistent with gscond + qsc = sup * qstl(i,k) + rhs = sup + else + qsc = qstl(i,k) + rhs = 1.0 + endif + if(rhly(i,k) >= rhs) then + cldtot(i,k) = 1.0 + else + qtmp = qlyr(i,k) + clwf(i,k) - qsc + if(deltaq(i,k) > epsq) then +! if(qtmp <= -deltaq(i,k) .or. cwmik < epsq) then + if(qtmp <= -deltaq(i,k)) then + cldtot(i,k) = 0.0 + elseif(qtmp >= deltaq(i,k)) then + cldtot(i,k) = 1.0 + else + cldtot(i,k) = 0.5*qtmp/deltaq(i,k) + 0.5 + cldtot(i,k) = max(cldtot(i,k),0.0) + cldtot(i,k) = min(cldtot(i,k),1.0) + endif + else + if(qtmp > 0.) then + cldtot(i,k) = 1.0 + else + cldtot(i,k) = 0.0 + endif + endif + endif + cldtot(i,k) = cnvc(i,k) + (1-cnvc(i,k))*cldtot(i,k) + cldtot(i,k) = max(cldtot(i,k),0.) + cldtot(i,k) = min(cldtot(i,k),1.) + + enddo + enddo + endif ! end_if_flip + + do k = 1, nlay + do i = 1, ix + if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, nlay + do i = 1, ix + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +!> -# Calculate effective ice cloud droplet radius following Heymsfield +!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. + + do k = 1, nlay + do i = 1, ix + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then +! tem3 = gord * cip(i,k) * (plyr(i,k)/delp(i,k)) / tvly(i,k) + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) + endif + enddo + enddo + +! + do k = 1, nlay + do i = 1, ix + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) +! clouds(i,k,6) = 0.0 + clouds(i,k,7) = rer(i,k) +! clouds(i,k,8) = 0.0 + clouds(i,k,9) = rei(i,k) + enddo + enddo + + +!> -# Call gethml() to compute low,mid,high,total, and boundary layer +!! cloud fractions and clouds top/bottom layer indices for low, mid, +!! and high clouds. +! the three cloud domain boundaries are defined by ptopc. the cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & ix,nlay, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progcld3 +!----------------------------------- + +!----------------------------------- + subroutine progcld4 & +!................................... + +! --- inputs: + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw, & + & xlat,xlon,slmsk,cldtot, & + & IX, NLAY, NLP1, & +! --- outputs: + & clouds,clds,mtop,mbot & + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld1 computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld1 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lsashal : control flag for shallow convection ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, cldtot + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + clwf(i,k) = 0.0 + enddo + enddo +! + if ( lcrick ) then + do i = 1, IX + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, NLAY-1 + do i = 1, IX + clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k) + enddo + enddo + endif + +! --- find top pressure for each cloud domain for given latitude +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +! --- compute liquid/ice condensate path in g/m**2 + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k+1) - plvl(i,k) + clwt = max(0.0, clwf(i,k)) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo + else ! input data from sfc to toa + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k) - plvl(i,k+1) + clwt = max(0.0, clwf(i,k)) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) + enddo + enddo + endif ! end_if_ivflip + +! --- effective liquid cloud droplet radius over land + + do i = 1, IX + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif + enddo + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +! --- effective ice cloud droplet radius + + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) + endif + enddo + enddo + +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) +! clouds(i,k,6) = 0.0 + clouds(i,k,7) = rer(i,k) +! clouds(i,k,8) = 0.0 + clouds(i,k,9) = rei(i,k) + enddo + enddo + + +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progcld4 +!----------------------------------- + +!----------------------------------- + subroutine progcld5 & +!................................... + +! --- inputs: + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & + & xlat,xlon,slmsk,cldtot, & + & IX, NLAY, NLP1, & +! --- outputs: + & clouds,clds,mtop,mbot & + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld1 computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld1 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! cnvw (ix,nlay) : layer convective cloud condensate ! +! cnvc (ix,nlay) : layer convective cloud cover ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lsashal : control flag for shallow convection ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc + + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX +#ifdef GFS_CLOUD_OVERLAP + cldcnv(i,k) = cnvc(i,k) +#else + cldcnv(i,k) = 0.0 +#endif + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) + clwf(i,k) = 0.0 + enddo + enddo +! + if ( lcrick ) then + do i = 1, IX + clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) + clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) + enddo + do k = 2, NLAY-1 + do i = 1, IX + clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) + enddo + enddo + else + do k = 1, NLAY + do i = 1, IX + clwf(i,k) = clw(i,k) + cnvw(i,k) + enddo + enddo + endif + +! --- find top pressure for each cloud domain for given latitude +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +! --- compute liquid/ice condensate path in g/m**2 + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k+1) - plvl(i,k) + clwt = max(0.0, clwf(i,k)) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) +#ifndef GFS_CLOUD_OVERLAP + cldtot(i,k) = cnvc(i,k)+(1-cnvc(i,k))*cldtot(i,k) + cldtot(i,k) = max(cldtot(i,k),0.) + cldtot(i,k) = min(cldtot(i,k),1.) +#endif + enddo + enddo + else ! input data from sfc to toa + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k) - plvl(i,k+1) + clwt = max(0.0, clwf(i,k)) * gfac * delp(i,k) + cip(i,k) = clwt * tem2d(i,k) + cwp(i,k) = clwt - cip(i,k) +#ifndef GFS_CLOUD_OVERLAP + cldtot(i,k) = cnvc(i,k)+(1-cnvc(i,k))*cldtot(i,k) + cldtot(i,k) = max(cldtot(i,k),0.) + cldtot(i,k) = min(cldtot(i,k),1.) +#endif + enddo + enddo + endif ! end_if_ivflip + +! --- effective liquid cloud droplet radius over land + + do i = 1, IX + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif + enddo + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +! --- effective ice cloud droplet radius + + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) + endif + enddo + enddo + +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) +! clouds(i,k,6) = 0.0 + clouds(i,k,7) = rer(i,k) +! clouds(i,k,8) = 0.0 + clouds(i,k,9) = rei(i,k) + enddo + enddo + + +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progcld5 +!----------------------------------- + +!----------------------------------- + subroutine progcld6 & +!................................... + +! --- inputs: + & ( plyr,plvl,tlyr,tvly,qlyr,qstl,rhly,clw,cnvw,cnvc, & + & xlat,xlon,qw,qr,qi,qs,qg,slmsk,snowd,cldtot, & + & IX, NLAY, NLP1, & +! --- outputs: + & clouds,clds,mtop,mbot & + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progcld1 computes cloud related quantities using ! +! zhao/moorthi's prognostic cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progcld1 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! qlyr (IX,NLAY) : layer specific humidity in gm/gm ! +! qstl (IX,NLAY) : layer saturate humidity in gm/gm ! +! rhly (IX,NLAY) : layer relative humidity (=qlyr/qstl) ! +! clw (IX,NLAY) : layer cloud condensate amount ! +! cnvw (ix,nlay) : layer convective cloud condensate ! +! cnvc (ix,nlay) : layer convective cloud cover ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lsashal : control flag for shallow convection ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +#ifdef fvGFS_2017 + use gfdl_cloud_microphys_mod, only: cloud_diagnosis +#else + use cld_eff_rad_mod, only: cld_eff_rad +#endif +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, qlyr, qstl, rhly, clw, cnvw, cnvc + + real (kind=kind_phys), dimension(:,:), intent(inout) :: & + & qw, qr, qi, qs, qg + real (kind=kind_phys), dimension(:,:), intent(inout) :: cldtot + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk, snowd + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldcnv, & + & cwp, cip, crp, csp, cgp, rew, rei, res, rer, reg, delp, & + & tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: clwmin, clwm, clwt, onemrh, value, & + & tem1, tem2, tem3 + + integer :: i, k, id, nf + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + +#ifdef fvGFS_2017 + print*, "GFDL MP cloud_diagnosis() not enabled. Stop." + stop 123 +#else +#ifdef GFS_CLOUD_OVERLAP + call cld_eff_rad (1, IX, 1, NLAY, slmsk, plyr*100, & + & abs(plvl(:,1:NLAY)-plvl(:,2:NLAY+1))*100, & + & tlyr, qw, qi, qr, qs, qg, cwp, cip, crp, & + & csp, cgp, rew, rei, rer, res, reg, cldtot, & + & cldtot, snowd, cnvw=cnvw) + cldcnv = cnvc +#else + call cld_eff_rad (1, IX, 1, NLAY, slmsk, plyr*100, & + & abs(plvl(:,1:NLAY)-plvl(:,2:NLAY+1))*100, & + & tlyr, qw, qi, qr, qs, qg, cwp, cip, crp, & + & csp, cgp, rew, rei, rer, res, reg, cldtot, & + & cldtot, snowd, cnvw=cnvw, cnvc=cnvc) + cldcnv = 0.0 +#endif +#endif + +! --- find top pressure for each cloud domain for given latitude +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) + clouds(i,k,6) = crp(i,k) + clouds(i,k,7) = rer(i,k) + clouds(i,k,8) = csp(i,k) + clouds(i,k,9) = res(i,k) + enddo + enddo + + +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progcld6 +!----------------------------------- + +!> @} + +!> This subroutine computes cloud related quantities using +!! zhao/moorthi's prognostic cloud microphysics scheme. +!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) +!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) +!!\param tlyr (IX,NLAY), model layer mean temperature in K +!!\param tvly (IX,NLAY), model layer virtual temperature in K +!!\param qlyr (IX,NLAY), layer specific humidity in gm/gm +!!\param clw (IX,NLAY), layer cloud liquid water amount +!!\param ciw (IX,NLAY), layer cloud ice water amount +!!\param xlat (IX), grid latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param xlon (IX), grid longitude in radians (not used) +!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) +!!\param IX horizontal dimention +!!\param NLAY,NLP1 vertical layer/level dimensions +!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud liq water path \f$(g/m^2)\f$ +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer cloud ice water path \f$(g/m^2)\f$ +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path (not assigned) +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path (not assigned) +!!\n (:,:,9) - mean eff radius for snow flake (micron) +!!\n *** fu's scheme need to be normalized by snow density \f$ (g/m^3/1.0e6)\f$ +!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl +!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops +!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases +!>\section gen_progclduni General Algorithm +!> @{ +!----------------------------------- + subroutine progclduni & + & ( plyr,plvl,tlyr,tvly,clw,ciw, & ! --- inputs: + & xlat,xlon,slmsk, IX, NLAY, NLP1, cldcov, & + & clouds,clds,mtop,mbot & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: progclduni computes cloud related quantities using ! +! for unified cloud microphysics scheme. ! +! ! +! abstract: this program computes cloud fractions from cloud ! +! condensates, calculates liquid/ice cloud droplet effective radius, ! +! and computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud ! +! top and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call progclduni ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! tvly (IX,NLAY) : model layer virtual temperature in k ! +! clw (IX,NLAY) : layer cloud liquid water amount ! +! ciw (IX,NLAY) : layer cloud ice water amount ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians (not used) ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path not assigned ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! *** clouds(:,:,8) - layer snow flake water path not assigned ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! *** fu's scheme need to be normalized by snow density (g/m**3/1.0e6) ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! lmfshal : mass-flux shallow conv scheme flag ! +! lmfdeep2 : scale-aware mass-flux deep conv scheme flag ! +! lcrick : control flag for eliminating CRICK ! +! =t: apply layer smoothing to eliminate CRICK ! +! =f: do not apply layer smoothing ! +! lcnorm : control flag for in-cld condensate ! +! =t: normalize cloud condensate ! +! =f: not normalize cloud condensate ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, tvly, clw, ciw, cldcov + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d +! & cwp, cip, crp, csp, rew, rei, res, rer, delp, tem2d, clwf + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: tem1, tem2, tem3 + + integer :: i, k, id, nf + +! +!===> ... begin here +! + do nf=1,nf_clds + do k=1,nlay + do i=1,ix + clouds(i,k,nf) = 0.0 + enddo + enddo + enddo +! clouds(:,:,:) = 0.0 + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + cwp (i,k) = 0.0 + cip (i,k) = 0.0 + crp (i,k) = 0.0 + csp (i,k) = 0.0 + rew (i,k) = reliq_def ! default liq radius to 10 micron + rei (i,k) = reice_def ! default ice radius to 50 micron + rer (i,k) = rrain_def ! default rain radius to 1000 micron + res (i,k) = rsnow_def ! default snow radius to 250 micron + tem2d (i,k) = min( 1.0, max( 0.0, (con_ttp-tlyr(i,k))*0.05 ) ) +! clwf(i,k) = 0.0 + enddo + enddo +! +! if ( lcrick ) then +! do i = 1, IX +! clwf(i,1) = 0.75*clw(i,1) + 0.25*clw(i,2) +! clwf(i,nlay) = 0.75*clw(i,nlay) + 0.25*clw(i,nlay-1) +! enddo +! do k = 2, NLAY-1 +! do i = 1, IX +! clwf(i,K) = 0.25*clw(i,k-1) + 0.5*clw(i,k) + 0.25*clw(i,k+1) +! enddo +! enddo +! else +! do k = 1, NLAY +! do i = 1, IX +! clwf(i,k) = clw(i,k) +! enddo +! enddo +! endif + +!> -# Find top pressure for each cloud domain for given latitude. +! ptopc(k,i): top presure of each cld domain (k=1-4 are sfc,L,m,h; +! --- i=1,2 are low-lat (<45 degree) and pole regions) + + do id = 1, 4 + tem1 = ptopc(id,2) - ptopc(id,1) + + do i =1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,id) = ptopc(id,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +!> -# Compute cloud liquid/ice condensate path in \f$ g/m^2 \f$ . + + if ( ivflip == 0 ) then ! input data from toa to sfc + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k+1) - plvl(i,k) + tem1 = gfac * delp(i,k) + cip(i,k) = ciw(i,k) * tem1 + cwp(i,k) = clw(i,k) * tem1 + enddo + enddo + else ! input data from sfc to toa + do k = 1, NLAY + do i = 1, IX + delp(i,k) = plvl(i,k) - plvl(i,k+1) + tem1 = gfac * delp(i,k) + cip(i,k) = ciw(i,k) * tem1 + cwp(i,k) = clw(i,k) * tem1 + enddo + enddo + endif ! end_if_ivflip + +!> -# Compute effective liquid cloud droplet radius over land. + + do i = 1, IX + if (nint(slmsk(i)) == 1) then + do k = 1, NLAY + rew(i,k) = 5.0 + 5.0 * tem2d(i,k) + enddo + endif + enddo + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = cldcov(i,k) + enddo + enddo + + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) < climit) then + cldtot(i,k) = 0.0 + cwp(i,k) = 0.0 + cip(i,k) = 0.0 + crp(i,k) = 0.0 + csp(i,k) = 0.0 + endif + enddo + enddo + + if ( lcnorm ) then + do k = 1, NLAY + do i = 1, IX + if (cldtot(i,k) >= climit) then + tem1 = 1.0 / max(climit2, cldtot(i,k)) + cwp(i,k) = cwp(i,k) * tem1 + cip(i,k) = cip(i,k) * tem1 + crp(i,k) = crp(i,k) * tem1 + csp(i,k) = csp(i,k) * tem1 + endif + enddo + enddo + endif + +!> -# Compute effective ice cloud droplet radius following Heymsfield +!! and McFarquhar (1996) \cite heymsfield_and_mcfarquhar_1996. + + do k = 1, NLAY + do i = 1, IX + tem2 = tlyr(i,k) - con_ttp + + if (cip(i,k) > 0.0) then + tem3 = gord * cip(i,k) * plyr(i,k) / (delp(i,k)*tvly(i,k)) + + if (tem2 < -50.0) then + rei(i,k) = (1250.0/9.917) * tem3 ** 0.109 + elseif (tem2 < -40.0) then + rei(i,k) = (1250.0/9.337) * tem3 ** 0.08 + elseif (tem2 < -30.0) then + rei(i,k) = (1250.0/9.208) * tem3 ** 0.055 + else + rei(i,k) = (1250.0/9.387) * tem3 ** 0.031 + endif +! rei(i,k) = max(20.0, min(rei(i,k), 300.0)) +! rei(i,k) = max(10.0, min(rei(i,k), 100.0)) + rei(i,k) = max(10.0, min(rei(i,k), 150.0)) +! rei(i,k) = max(5.0, min(rei(i,k), 130.0)) + endif + enddo + enddo + +! + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = cldtot(i,k) + clouds(i,k,2) = cwp(i,k) + clouds(i,k,3) = rew(i,k) + clouds(i,k,4) = cip(i,k) + clouds(i,k,5) = rei(i,k) +! clouds(i,k,6) = 0.0 + clouds(i,k,7) = rer(i,k) +! clouds(i,k,8) = 0.0 + clouds(i,k,9) = rei(i,k) + enddo + enddo + + +!> -# Call gethml() to compute low,mid,high,total, and boundary layer +!! cloud fractions and clouds top/bottom layer indices for low, mid, +!! and high clouds. +! --- compute low, mid, high, total, and boundary layer cloud fractions +! and clouds top/bottom layer indices for low, mid, and high clouds. +! The three cloud domain boundaries are defined by ptopc. The cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX,NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + + +! + return +!................................... + end subroutine progclduni +!----------------------------------- +!> @} + +!> This subroutine computes cloud fractions for radiation calculations. +!!\param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) +!!\param plvl (IX,NLP1), model level pressure in mb (100Pa) +!!\param tlyr (IX,NLAY), model layer mean temperature in K +!!\param rhly (IX,NLAY), layer relative humidity +!!\param vvel (IX,NLAY), layer mean vertical velocity in mb/sec +!!\param cv (IX), fraction of convective cloud +!!\param cvt, cvb (IX), conv cloud top/bottom pressure in mb +!!\param xlat (IX), grid latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param xlon (IX), grid longitude in radians, ok for both 0->2pi +!! or -pi -> +pi ranges +!!\param slmsk (IX), sea/land mask array (sea:0,land:1,sea-ice:2) +!!\param IX horizontal dimention +!!\param NLAY,NLP1 vertical layer/level dimensions +!!\param clouds (IX,NLAY,NF_CLDS), cloud profiles +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud optical depth +!!\n (:,:,3) - layer cloud single scattering albedo +!!\n (:,:,4) - layer cloud asymmetry factor +!!\param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl +!!\param mtop (IX,3), vertical indices for low, mid, hi cloud tops +!!\param mbot (IX,3), vertical indices for low, mid, hi cloud bases +!!\section gen_diagcld1 General Algorithm +!> @{ +!----------------------------------- + subroutine diagcld1 & + & ( plyr,plvl,tlyr,rhly,vvel,cv,cvt,cvb, & ! --- inputs: + & xlat,xlon,slmsk, & + & IX, NLAY, NLP1, & + & clouds,clds,mtop,mbot & ! --- outputs: + & ) + +! ================= subprogram documentation block ================ ! +! ! +! subprogram: diagcld1 computes cloud fractions for radiation ! +! calculations. ! +! ! +! abstract: clouds are diagnosed from layer relative humidity, and ! +! estimate cloud optical depth from temperature and layer thickness. ! +! then computes the low, mid, high, total and boundary layer cloud ! +! fractions and the vertical indices of low, mid, and high cloud top ! +! and base. the three vertical cloud domains are set up in the ! +! initial subroutine "cld_init". ! +! ! +! usage: call diagcld1 ! +! ! +! subprograms called: gethml ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! plvl (IX,NLP1) : model level pressure in mb (100Pa) ! +! tlyr (IX,NLAY) : model layer mean temperature in k ! +! rhly (IX,NLAY) : layer relative humidity ! +! vvel (IX,NLAY) : layer mean vertical velocity in mb/sec ! +! clw (IX,NLAY) : layer cloud condensate amount (not used) ! +! xlat (IX) : grid latitude in radians, default to pi/2 -> -pi/2! +! range, otherwise see in-line comment ! +! xlon (IX) : grid longitude in radians, ok for both 0->2pi or ! +! -pi -> +pi ranges ! +! slmsk (IX) : sea/land mask array (sea:0,land:1,sea-ice:2) ! +! cv (IX) : fraction of convective cloud ! +! cvt, cvb (IX) : conv cloud top/bottom pressure in mb ! +! IX : horizontal dimention ! +! NLAY,NLP1 : vertical layer/level dimensions ! +! ! +! output variables: ! +! clouds(IX,NLAY,NF_CLDS) : cloud profiles ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud optical depth ! +! clouds(:,:,3) - layer cloud single scattering albedo ! +! clouds(:,:,4) - layer cloud asymmetry factor ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! external module variables: ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IX, NLAY, NLP1 + + real (kind=kind_phys), dimension(:,:), intent(in) :: plvl, plyr, & + & tlyr, rhly, vvel + + real (kind=kind_phys), dimension(:), intent(in) :: xlat, xlon, & + & slmsk, cv, cvt, cvb + +! --- outputs + real (kind=kind_phys), dimension(:,:,:), intent(out) :: clouds + + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop,mbot + +! --- local variables: + real (kind=kind_phys), dimension(IX,NLAY) :: cldtot, cldcnv, & + & cldtau, taufac, dthdp, tem2d + + real (kind=kind_phys) :: ptop1(IX,NK_CLDS+1) + + real (kind=kind_phys) :: cr1, cr2, crk, pval, cval, omeg, value, & + & tem1, tem2 + + integer, dimension(IX):: idom, kcut + +! --- for rh-cl calculation + real (kind=kind_phys) :: xlatdg, xlondg, xlnn, xlss, xrgt, xlft, & + & rhcla(NBIN,NLON,MCLD,NSEAL), rhcld(IX,NBIN,MCLD) + + integer :: ireg, ib, ic, id, id1, il, is, nhalf + + integer :: i, j, k, klowt +! integer :: klowb + + logical :: notstop + +! +!===> ... begin here +! + clouds(:,:,:) = 0.0 + + tem1 = 180.0 / con_pi + + lab_do_i_IX : do i = 1, IX + + xlatdg = xlat(i) * tem1 ! if xlat in pi/2 -> -pi/2 range +! xlatdg = 90.0 - xlat(i)*tem1 ! if xlat in 0 -> pi range + + xlondg = xlon(i) * tem1 + if (xlondg < 0.0) xlondg = xlondg + 360.0 ! if in -180->180, chg to 0->360 range + + ireg = 4 + +!> -# Get rh-cld relation for this lat. + + lab_do_j : do j = 1, 3 + if (xlatdg > xlabdy(j)) then + ireg = j + exit lab_do_j + endif + enddo lab_do_j + + do is = 1, NSEAL + do ic = 1, MCLD + do il = 1, NLON + do ib = 1, NBIN + rhcla(ib,il,ic,is) = rhcl(ib,il,ireg,ic,is) + enddo + enddo + enddo + enddo + +!> -# Linear transition between latitudinal regions. + do j = 1, 3 + xlnn = xlabdy(j) + xlim + xlss = xlabdy(j) - xlim + + if (xlatdg < xlnn .and. xlatdg > xlss) then + do is = 1, NSEAL + do ic = 1, MCLD + do il = 1, NLON + do ib = 1, NBIN + rhcla(ib,il,ic,is) = rhcl(ib,il,j+1,ic,is) & + & + (rhcl(ib,il,j,ic,is)-rhcl(ib,il,j+1,ic,is)) & + & * (xlatdg-xlss) / (xlnn-xlss) + enddo + enddo + enddo + enddo + endif + + enddo ! end_j_loop + +!> -# Get rh-cld relationship for each grid point, interpolating +!! longitudinally between regions if necessary. + + if (slmsk(i) < 1.0) then + is = 2 + else + is = 1 + endif + +! --- which hemisphere (e,w) + + if (xlondg > 180.e0) then + il = 2 + else + il = 1 + endif + + do ic = 1, MCLD + do ib = 1, NBIN + rhcld(i,ib,ic) = rhcla(ib,il,ic,is) + enddo + + lab_do_k : do k = 1, 3 + tem2 = abs(xlondg - xlobdy(k)) + + if (tem2 < xlim) then + id = il + id1= id + 1 + if (id1 > NLON) id1 = 1 + + xlft = xlobdy(k) - xlim + xrgt = xlobdy(k) + xlim + + do ib = 1, NBIN + rhcld(i,ib,ic) = rhcla(ib,id1,ic,is) & + & + (rhcla(ib,id,ic,is) - rhcla(ib,id1,ic,is)) & + & * (xlondg-xrgt)/(xlft-xrgt) + enddo + exit lab_do_k + endif + + enddo lab_do_k + + enddo ! end_do_ic_loop + enddo lab_do_i_IX + +!> -# Find top pressure for each cloud domain. + + do j = 1, 4 + tem1 = ptopc(j,2) - ptopc(j,1) + + do i = 1, IX + tem2 = xlat(i) / con_pi ! if xlat in pi/2 -> -pi/2 range +! tem2 = 0.5 - xlat(i)/con_pi ! if xlat in 0 -> pi range + + ptop1(i,j) = ptopc(j,1) + tem1*max( 0.0, 4.0*abs(tem2)-1.0 ) + enddo + enddo + +!> -# Compute stratiform cloud optical depth. + + do k = 1, NLAY + do i = 1, IX + tem1 = tlyr(i,k) - con_ttp + if (tem1 <= -10.0) then + cldtau(i,k) = max( 0.1e-3, 2.0e-6*(tem1+82.5)**2 ) + else + cldtau(i,k) = min( 0.08, 6.949e-3*tem1+0.08 ) + endif + enddo + enddo + +!> -# Calculate potential temperature and its lapse rate. + + do k = 1, NLAY + do i = 1, IX + cldtot(i,k) = 0.0 + cldcnv(i,k) = 0.0 + tem1 = (plyr(i,k)*0.001) ** (-con_rocp) + tem2d(i,k) = tem1 * tlyr(i,k) + enddo + enddo + + do k = 1, NLAY-1 + do i = 1, IX + dthdp(i,k) = (tem2d(i,k+1)-tem2d(i,k))/(plyr(i,k+1)-plyr(i,k)) + enddo + enddo +! +!> -# Diagnostic method to find cloud amount cldtot, cldcnv. +! + + if ( ivflip == 0 ) then ! input data from toa to sfc + +!> - Find the lowest low cloud top sigma level, computed for each +!! lat cause domain definition changes with latitude. + +! klowb = 1 + klowt = 1 + do k = 1, NLAY + do i = 1, IX +! if (plvl(i,k) < ptop1(i,2)) klowb = k + if (plvl(i,k) < ptop1(i,2)) klowt = max(klowt,k) + taufac(i,k) = plvl(i,k+1) - plvl(i,k) + enddo + enddo + + do i = 1, IX + +!> - Find the stratosphere cut off layer for high cloud (about +!! 250mb). It is assumed to be above the layerwith dthdp less than +!! -0.25 in the high cloud domain. + + kcut(i) = 2 + lab_do_kcut0 : do k = klowt-1, 2, -1 + if (plyr(i,k) <= ptop1(i,3) .and. & + & dthdp(i,k) < -0.25e0) then + kcut(i) = k + exit lab_do_kcut0 + endif + enddo lab_do_kcut0 + +!> - Put convective cloud into 'cldcnv', no merge at this point. + + if (cv(i) >= climit .and. cvt(i) < cvb(i)) then + id = NLAY + id1 = NLAY + + lab_do_k_cvt0 : do k = 2, NLAY + if (cvt(i) <= plyr(i,k)) then + id = k - 1 + exit lab_do_k_cvt0 + endif + enddo lab_do_k_cvt0 + + lab_do_k_cvb0 : do k = NLAY-1, 1, -1 + if (cvb(i) >= plyr(i,k)) then + id1 = k + 1 + exit lab_do_k_cvb0 + endif + enddo lab_do_k_cvb0 + + tem1 = plyr(i,id1) - plyr(i,id) + do k = id, id1 + cldcnv(i,k) = cv(i) + taufac(i,k) = taufac(i,k) * max( 0.25, 1.0-0.125*tem1 ) + cldtau(i,k) = 0.06 + enddo + endif + + enddo ! end_do_i_loop + +!> - Calculate stratiform cloud and put into array 'cldtot' using +!! the cld-rh relationship from table look-up, where tables +!! obtained using k.mitchell frequency distribution tuning. +!bl (observations are daily means from us af rtneph).....k.a.c. +!bl tables created without lowest 10 percent of atmos.....k.a.c. +! (observations are synoptic using -6,+3 window from rtneph) +! tables are created with lowest 10-percent-of-atmos, and are +! --- now used.. 25 october 1995 ... kac. + + do k = NLAY-1, 2, -1 + + if (k < llyr) then + do i = 1, IX + idom(i) = 0 + enddo + + do i = 1, IX + lab_do_ic0 : do ic = 2, 4 + if(plyr(i,k) >= ptop1(i,ic)) then + idom(i) = ic + exit lab_do_ic0 + endif + enddo lab_do_ic0 + enddo + else + do i = 1, IX + idom(i) = 1 + enddo + endif + + do i = 1, IX + id = idom(i) + nhalf = (NBIN + 1) / 2 + + if (id <= 0 .or. k < kcut(i)) then + cldtot(i,k) = 0.0 + elseif (rhly(i,k) <= rhcld(i,1,id)) then + cldtot(i,k) = 0.0 + elseif (rhly(i,k) >= rhcld(i,NBIN,id)) then + cldtot(i,k) = 1.0 + else + ib = nhalf + crk = rhly(i,k) + + notstop = .true. + do while ( notstop ) + nhalf = (nhalf + 1) / 2 + cr1 = rhcld(i,ib, id) + cr2 = rhcld(i,ib+1,id) + + if (crk <= cr1) then + ib = max( ib-nhalf, 1 ) + elseif (crk > cr2) then + ib = min( ib+nhalf, NBIN-1 ) + else + cldtot(i,k) = 0.01 * (ib + (crk - cr1)/(cr2 - cr1)) + notstop = .false. + endif + enddo ! end_do_while + endif + enddo ! end_do_i_loop + + enddo ! end_do_k_loop + +!> - Compute vertical velocity adjustment on low clouds. + + value = vvcld1 - vvcld2 + do k = klowt, llyr+1 + do i = 1, IX + + omeg = vvel(i,k) + cval = cldtot(i,k) + pval = plyr(i,k) + +! --- vertical velocity adjustment on low clouds + + if (cval >= climit .and. pval >= ptop1(i,2)) then + if (omeg >= vvcld1) then + cldtot(i,k) = 0.0 + elseif (omeg > vvcld2) then + tem1 = (vvcld1 - omeg) / value + cldtot(i,k) = cldtot(i,k) * sqrt(tem1) + endif + endif + + enddo ! end_do_i_loop + enddo ! end_do_k_loop + + else ! input data from sfc to toa + +! --- find the lowest low cloud top sigma level, computed for each lat cause +! domain definition changes with latitude... + +! klowb = NLAY + klowt = NLAY + do k = NLAY, 1, -1 + do i = 1, IX +! if (plvl(i,k) < ptop1(i,2)) klowb = k + if (plvl(i,k) < ptop1(i,2)) klowt = min(klowt,k) + taufac(i,k) = plvl(i,k) - plvl(i,k+1) ! dp for later cal cldtau use + enddo + enddo + + do i = 1, IX + +! --- find the stratosphere cut off layer for high cloud (about 250mb). +! it is assumed to be above the layer with dthdp less than -0.25 in +! the high cloud domain + + kcut(i) = NLAY - 1 + lab_do_kcut1 : do k = klowt+1, NLAY-1 + if (plyr(i,k) <= ptop1(i,3) .and. & + & dthdp(i,k) < -0.25e0) then + kcut(i) = k + exit lab_do_kcut1 + endif + enddo lab_do_kcut1 + +! --- put convective cloud into 'cldcnv', no merge at this point.. + + if (cv(i) >= climit .and. cvt(i) < cvb(i)) then + id = 1 + id1 = 1 + + lab_do_k_cvt : do k = NLAY-1, 1, -1 + if (cvt(i) <= plyr(i,k)) then + id = k + 1 + exit lab_do_k_cvt + endif + enddo lab_do_k_cvt + + lab_do_k_cvb : do k = 2, NLAY + if (cvb(i) >= plyr(i,k)) then + id1 = k - 1 + exit lab_do_k_cvb + endif + enddo lab_do_k_cvb + + tem1 = plyr(i,id1) - plyr(i,id) + do k = id1, id + cldcnv(i,k) = cv(i) + taufac(i,k) = taufac(i,k) * max( 0.25, 1.0-0.125*tem1 ) + cldtau(i,k) = 0.06 + enddo + endif + + enddo ! end_do_i_loop + +! --- calculate stratiform cloud and put into array 'cldtot' using +! the cloud-rel.humidity relationship from table look-up..where +! tables obtained using k.mitchell frequency distribution tuning +!bl (observations are daily means from us af rtneph).....k.a.c. +!bl tables created without lowest 10 percent of atmos.....k.a.c. +! (observations are synoptic using -6,+3 window from rtneph) +! tables are created with lowest 10-percent-of-atmos, and are +! --- now used.. 25 october 1995 ... kac. + + do k = 2, NLAY-1 + + if (k > llyr) then + do i = 1, IX + idom(i) = 0 + enddo + + do i = 1, IX + lab_do_ic1 : do ic = 2, 4 + if(plyr(i,k) >= ptop1(i,ic)) then + idom(i) = ic + exit lab_do_ic1 + endif + enddo lab_do_ic1 + enddo + else + do i = 1, IX + idom(i) = 1 + enddo + endif + + do i = 1, IX + id = idom(i) + nhalf = (NBIN + 1) / 2 + + if (id <= 0 .or. k > kcut(i)) then + cldtot(i,k) = 0.0 + elseif (rhly(i,k) <= rhcld(i,1,id)) then + cldtot(i,k) = 0.0 + elseif (rhly(i,k) >= rhcld(i,NBIN,id)) then + cldtot(i,k) = 1.0 + else + ib = nhalf + crk = rhly(i,k) + + notstop = .true. + do while ( notstop ) + nhalf = (nhalf + 1) / 2 + cr1 = rhcld(i,ib, id) + cr2 = rhcld(i,ib+1,id) + + if (crk <= cr1) then + ib = max( ib-nhalf, 1 ) + elseif (crk > cr2) then + ib = min( ib+nhalf, NBIN-1 ) + else + cldtot(i,k) = 0.01 * (ib + (crk - cr1)/(cr2 - cr1)) + notstop = .false. + endif + enddo ! end_do_while + endif + enddo ! end_do_i_loop + + enddo ! end_do_k_loop + +! --- vertical velocity adjustment on low clouds + + value = vvcld1 - vvcld2 + do k = llyr-1, klowt + do i = 1, IX + + omeg = vvel(i,k) + cval = cldtot(i,k) + pval = plyr(i,k) + +! --- vertical velocity adjustment on low clouds + + if (cval >= climit .and. pval >= ptop1(i,2)) then + if (omeg >= vvcld1) then + cldtot(i,k) = 0.0 + elseif (omeg > vvcld2) then + tem1 = (vvcld1 - omeg) / value + cldtot(i,k) = cldtot(i,k) * sqrt(tem1) + endif + endif + + enddo ! end_do_i_loop + enddo ! end_do_k_loop + + endif ! end_if_ivflip + +!> - Calculate diagnostic cloud optical depth. + +! cldtau = cldtau * taufac + + where (cldtot < climit) + cldtot = 0.0 + endwhere + where (cldcnv < climit) + cldcnv = 0.0 + endwhere + + where (cldtot < climit .and. cldcnv < climit) + cldtau = 0.0 + endwhere + + do k = 1, NLAY + do i = 1, IX + clouds(i,k,1) = max(cldtot(i,k), cldcnv(i,k)) + clouds(i,k,2) = cldtau(i,k) * taufac(i,k) + clouds(i,k,3) = cldssa_def + clouds(i,k,4) = cldasy_def + enddo + enddo + +!> -# Call gethml(), to compute low, mid, high, total, and boundary +!! layer cloud fractions and cloud top/bottom layer indices for low, +!! mid, and high clouds. +! the three cloud domain boundaries are defined by ptopc. the cloud +! overlapping method is defined by control flag 'iovr', which may +! be different for lw and sw radiation programs. + + call gethml & +! --- inputs: + & ( plyr, ptop1, cldtot, cldcnv, & + & IX, NLAY, & +! --- outputs: + & clds, mtop, mbot & + & ) + +! + return +!................................... + end subroutine diagcld1 +!----------------------------------- +!> @} + + +!> This subroutine computes high, mid, low, total, and boundary cloud +!! fractions and cloud top/bottom layer indices for model diagnostic +!! output. The three cloud domain boundaries are defined by ptopc. The +!! cloud overlapping method is defined by control flag 'iovr', which is +!! also used by LW and SW radiation programs. +!> \param plyr (IX,NLAY), model layer mean pressure in mb (100Pa) +!> \param ptop1 (IX,4), pressure limits of cloud domain interfaces +!! (sfc,low,mid,high) in mb (100Pa) +!> \param cldtot (IX,NLAY), total or stratiform cloud profile in fraction +!> \param cldcnv (IX,NLAY), convective cloud (for diagnostic scheme only) +!> \param IX horizontal dimension +!> \param NLAY vertical layer dimensions +!> \param clds (IX,5), fraction of clouds for low, mid, hi, tot, bl +!> \param mtop (IX,3),vertical indices for low, mid, hi cloud tops +!> \param mbot (IX,3),vertical indices for low, mid, hi cloud bases +!! +!>\section detail Detailed Algorithm +!! @{ +!----------------------------------- ! + subroutine gethml & + & ( plyr, ptop1, cldtot, cldcnv, & ! --- inputs: + & IX, NLAY, & + & clds, mtop, mbot & ! --- outputs: + & ) + +! =================================================================== ! +! ! +! abstract: compute high, mid, low, total, and boundary cloud fractions ! +! and cloud top/bottom layer indices for model diagnostic output. ! +! the three cloud domain boundaries are defined by ptopc. the cloud ! +! overlapping method is defined by control flag 'iovr', which is also ! +! used by lw and sw radiation programs. ! +! ! +! usage: call gethml ! +! ! +! subprograms called: none ! +! ! +! attributes: ! +! language: fortran 90 ! +! machine: ibm-sp, sgi ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! input variables: ! +! plyr (IX,NLAY) : model layer mean pressure in mb (100Pa) ! +! ptop1 (IX,4) : pressure limits of cloud domain interfaces ! +! (sfc,low,mid,high) in mb (100Pa) ! +! cldtot(IX,NLAY) : total or straiform cloud profile in fraction ! +! cldcnv(IX,NLAY) : convective cloud (for diagnostic scheme only) ! +! IX : horizontal dimention ! +! NLAY : vertical layer dimensions ! +! ! +! output variables: ! +! clds (IX,5) : fraction of clouds for low, mid, hi, tot, bl ! +! mtop (IX,3) : vertical indices for low, mid, hi cloud tops ! +! mbot (IX,3) : vertical indices for low, mid, hi cloud bases ! +! ! +! external module variables: (in physparam) ! +! ivflip : control flag of vertical index direction ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! internal module variables: ! +! iovr : control flag for cloud overlap ! +! =0 random overlapping clouds ! +! =1 max/ran overlapping clouds ! +! ! +! ! +! ==================== end of description ===================== ! +! + implicit none! + +! --- inputs: + integer, intent(in) :: IX, NLAY + + real (kind=kind_phys), dimension(:,:), intent(in) :: plyr, ptop1, & + & cldtot, cldcnv + +! --- outputs + real (kind=kind_phys), dimension(:,:), intent(out) :: clds + + integer, dimension(:,:), intent(out) :: mtop, mbot + +! --- local variables: + real (kind=kind_phys) :: cl1(IX), cl2(IX) + real (kind=kind_phys) :: pcur, pnxt, ccur, cnxt + + integer, dimension(IX):: idom, kbt1, kth1, kbt2, kth2 + integer :: i, k, id, id1, kstr, kend, kinc + +! +!===> ... begin here +! + clds(:,:) = 0.0 + + do i = 1, IX + cl1(i) = 1.0 + cl2(i) = 1.0 + enddo + +! --- total and bl clouds, where cl1, cl2 are fractions of clear-sky view +! layer processed from surface and up + +!> -# Calculate total and BL cloud fractions (maximum-random cloud +!! overlapping is operational). + + if ( ivflip == 0 ) then ! input data from toa to sfc + kstr = NLAY + kend = 1 + kinc = -1 + else ! input data from sfc to toa + kstr = 1 + kend = NLAY + kinc = 1 + endif ! end_if_ivflip + + if ( iovr == 0 ) then ! random overlap + + do k = kstr, kend, kinc + do i = 1, IX + ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) + if (ccur >= climit) cl1(i) = cl1(i) * (1.0 - ccur) + enddo + + if (k == llyr) then + do i = 1, IX + clds(i,5) = 1.0 - cl1(i) ! save bl cloud + enddo + endif + enddo + + do i = 1, IX + clds(i,4) = 1.0 - cl1(i) ! save total cloud + enddo + + else ! max/ran overlap + + do k = kstr, kend, kinc + do i = 1, IX + ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) + if (ccur >= climit) then ! cloudy layer + cl2(i) = min( cl2(i), (1.0 - ccur) ) + else ! clear layer + cl1(i) = cl1(i) * cl2(i) + cl2(i) = 1.0 + endif + enddo + + if (k == llyr) then + do i = 1, IX + clds(i,5) = 1.0 - cl1(i) * cl2(i) ! save bl cloud + enddo + endif + enddo + + do i = 1, IX + clds(i,4) = 1.0 - cl1(i) * cl2(i) ! save total cloud + enddo + + endif ! end_if_iovr + +! --- high, mid, low clouds, where cl1, cl2 are cloud fractions +! layer processed from one layer below llyr and up +! --- change! layer processed from surface to top, so low clouds will +! contains both bl and low clouds. + +!> -# Calculte high, mid, low cloud fractions and vertical indices of +!! cloud tops/bases. + if ( ivflip == 0 ) then ! input data from toa to sfc + + do i = 1, IX + cl1 (i) = 0.0 + cl2 (i) = 0.0 + kbt1(i) = NLAY + kbt2(i) = NLAY + kth1(i) = 0 + kth2(i) = 0 + idom(i) = 1 + mbot(i,1) = NLAY + mtop(i,1) = NLAY + mbot(i,2) = NLAY - 1 + mtop(i,2) = NLAY - 1 + mbot(i,3) = NLAY - 1 + mtop(i,3) = NLAY - 1 + enddo + +!org do k = llyr-1, 1, -1 + do k = NLAY, 1, -1 + do i = 1, IX + id = idom(i) + id1= id + 1 + + pcur = plyr(i,k) + ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) + + if (k > 1) then + pnxt = plyr(i,k-1) + cnxt = min( ovcst, max( cldtot(i,k-1), cldcnv(i,k-1) )) + else + pnxt = -1.0 + cnxt = 0.0 + endif + + if (pcur < ptop1(i,id1)) then + id = id + 1 + id1= id1 + 1 + idom(i) = id + endif + + if (ccur >= climit) then + if (kth2(i) == 0) kbt2(i) = k + kth2(i) = kth2(i) + 1 + + if ( iovr == 0 ) then + cl2(i) = cl2(i) + ccur - cl2(i)*ccur + else + cl2(i) = max( cl2(i), ccur ) + endif + + if (cnxt < climit .or. pnxt < ptop1(i,id1)) then + kbt1(i) = nint( (cl1(i)*kbt1(i) + cl2(i)*kbt2(i) ) & + & / (cl1(i) + cl2(i)) ) + kth1(i) = nint( (cl1(i)*kth1(i) + cl2(i)*kth2(i) ) & + & / (cl1(i) + cl2(i)) ) + cl1 (i) = cl1(i) + cl2(i) - cl1(i)*cl2(i) + + kbt2(i) = k - 1 + kth2(i) = 0 + cl2 (i) = 0.0 + endif ! end_if_cnxt_or_pnxt + endif ! end_if_ccur + + if (pnxt < ptop1(i,id1)) then + clds(i,id) = cl1(i) + mtop(i,id) = min( kbt1(i), kbt1(i)-kth1(i)+1 ) + mbot(i,id) = kbt1(i) + + cl1 (i) = 0.0 + kbt1(i) = k - 1 + kth1(i) = 0 + + if (id1 <= NK_CLDS) then + mbot(i,id1) = kbt1(i) + mtop(i,id1) = kbt1(i) + endif + endif ! end_if_pnxt + + enddo ! end_do_i_loop + enddo ! end_do_k_loop + + else ! input data from sfc to toa + + do i = 1, IX + cl1 (i) = 0.0 + cl2 (i) = 0.0 + kbt1(i) = 1 + kbt2(i) = 1 + kth1(i) = 0 + kth2(i) = 0 + idom(i) = 1 + mbot(i,1) = 1 + mtop(i,1) = 1 + mbot(i,2) = 2 + mtop(i,2) = 2 + mbot(i,3) = 2 + mtop(i,3) = 2 + enddo + +!org do k = llyr+1, NLAY + do k = 1, NLAY + do i = 1, IX + id = idom(i) + id1= id + 1 + + pcur = plyr(i,k) + ccur = min( ovcst, max( cldtot(i,k), cldcnv(i,k) )) + + if (k < NLAY) then + pnxt = plyr(i,k+1) + cnxt = min( ovcst, max( cldtot(i,k+1), cldcnv(i,k+1) )) + else + pnxt = -1.0 + cnxt = 0.0 + endif + + if (pcur < ptop1(i,id1)) then + id = id + 1 + id1= id1 + 1 + idom(i) = id + endif + + if (ccur >= climit) then + if (kth2(i) == 0) kbt2(i) = k + kth2(i) = kth2(i) + 1 + + if ( iovr == 0 ) then + cl2(i) = cl2(i) + ccur - cl2(i)*ccur + else + cl2(i) = max( cl2(i), ccur ) + endif + + if (cnxt < climit .or. pnxt < ptop1(i,id1)) then + kbt1(i) = nint( (cl1(i)*kbt1(i) + cl2(i)*kbt2(i)) & + & / (cl1(i) + cl2(i)) ) + kth1(i) = nint( (cl1(i)*kth1(i) + cl2(i)*kth2(i)) & + & / (cl1(i) + cl2(i)) ) + cl1 (i) = cl1(i) + cl2(i) - cl1(i)*cl2(i) + + kbt2(i) = k + 1 + kth2(i) = 0 + cl2 (i) = 0.0 + endif ! end_if_cnxt_or_pnxt + endif ! end_if_ccur + + if (pnxt < ptop1(i,id1)) then + clds(i,id) = cl1(i) + mtop(i,id) = max( kbt1(i), kbt1(i)+kth1(i)-1 ) + mbot(i,id) = kbt1(i) + + cl1 (i) = 0.0 + kbt1(i) = min(k+1, nlay) + kth1(i) = 0 + + if (id1 <= NK_CLDS) then + mbot(i,id1) = kbt1(i) + mtop(i,id1) = kbt1(i) + endif + endif ! end_if_pnxt + + enddo ! end_do_i_loop + enddo ! end_do_k_loop + + endif ! end_if_ivflip + +! + return +!................................... + end subroutine gethml +!----------------------------------- +!! @} + +!> cld-rh relations obtained from mitchell-hahn procedure. +!----------------------------------- ! + subroutine rhtable & + & ( me & ! --- inputs: + &, ier ) ! --- outputs: + +! =================================================================== ! +! ! +! abstract: cld-rh relations obtained from mitchell-hahn procedure, ! +! here read cld/rh tuning tables for day 0,1,...,5 and merge into 1 ! +! file. ! +! ! +! inputs: ! +! me : check print control flag ! +! ! +! outputs: ! +! ier : error flag ! +! ! +! =================================================================== ! +! + implicit none! + +! --- inputs: + integer, intent(in) :: me + +! --- output: + integer, intent(out) :: ier + +! --- locals: + real (kind=kind_phys), dimension(NBIN,NLON,NLAT,MCLD,NSEAL) :: & + & rhfd, rtnfd, rhcf, rtncf, rhcla + + real (kind=kind_io4), dimension(NBIN,NLON,NLAT,MCLD,NSEAL) :: & + & rhfd4, rtnfd4 + + real(kind=kind_io4) :: fhour + + real(kind=kind_phys) :: binscl, cfrac, clsat, rhsat, cstem + + integer, dimension(NLON,NLAT,MCLD,NSEAL) :: kpts, kkpts + + integer :: icdays(15), idate(4), nbdayi, isat + + integer :: i, i1, j, k, l, m, id, im, iy + +! +!===> ... begin here +! + + ier = 1 + + rewind NICLTUN + + binscl = 1.0 / NBIN + +! --- array initializations + + do m=1,NSEAL + do l=1,MCLD + do k=1,NLAT + do j=1,NLON + do i=1,NBIN + rhcf (i,j,k,l,m) = 0.0 + rtncf(i,j,k,l,m) = 0.0 + rhcla(i,j,k,l,m) = -0.1 + enddo + enddo + enddo + enddo + enddo + + kkpts = 0 + +! --- read the data off the rotating file + + read (NICLTUN,ERR=998,END=999) nbdayi, icdays + + if (me == 0) print 11, nbdayi + 11 format(' from rhtable DAYS ON FILE =',i5) + + do i = 1, nbdayi + id = icdays(i) / 10000 + im = (icdays(i)-id*10000) / 100 + iy = icdays(i)-id*10000-im*100 + if (me == 0) print 51, id,im,iy + 51 format(' from rhtable ARCHV DATA FROM DA,MO,YR=',3i4) + enddo + + read (NICLTUN,ERR=998,END=999) fhour,idate + + do i1 = 1, nbdayi + read (NICLTUN) rhfd4 + rhfd = rhfd4 + + read (NICLTUN) rtnfd4 + rtnfd = rtnfd4 + + read (NICLTUN) kpts + + do m=1,NSEAL + do l=1,MCLD + do k=1,NLAT + do j=1,NLON + do i=1,NBIN + rhcf (i,j,k,l,m) = rhcf (i,j,k,l,m) + rhfd (i,j,k,l,m) + rtncf(i,j,k,l,m) = rtncf(i,j,k,l,m) + rtnfd(i,j,k,l,m) + enddo + enddo + enddo + enddo + enddo + + kkpts = kkpts + kpts + + enddo ! end_do_i1_loop + + do m = 1, NSEAL + do l = 1, MCLD + do k = 1, NLAT + do j = 1, NLON + +! --- compute the cumulative frequency distribution + + do i = 2, NBIN + rhcf (i,j,k,l,m) = rhcf (i-1,j,k,l,m) + rhcf (i,j,k,l,m) + rtncf(i,j,k,l,m) = rtncf(i-1,j,k,l,m) + rtncf(i,j,k,l,m) + enddo ! end_do_i_loop + + if (kkpts(j,k,l,m) > 0) then + do i = 1, NBIN + rhcf (i,j,k,l,m)= rhcf (i,j,k,l,m)/kkpts(j,k,l,m) + rtncf(i,j,k,l,m)=min(1., rtncf(i,j,k,l,m)/kkpts(j,k,l,m)) + enddo + +! --- cause we mix calculations of rh retune with cray and ibm words +! the last value of rhcf is close to but ne 1.0, +! --- so we reset it in order that the 360 loop gives complete tabl + + rhcf(NBIN,j,k,l,m) = 1.0 + + do i = 1, NBIN + lab_do_i1 : do i1 = 1, NBIN + if (rhcf(i1,j,k,l,m) >= rtncf(i,j,k,l,m)) then + rhcla(i,j,k,l,m) = i1 * binscl + exit lab_do_i1 + endif + enddo lab_do_i1 + enddo + + else ! if_kkpts +! --- no critical rh + + do i = 1, NBIN + rhcf (i,j,k,l,m) = -0.1 + rtncf(i,j,k,l,m) = -0.1 + enddo + + if (me == 0) then + print 210, k,j,m + 210 format(' NO CRIT RH FOR LAT=',I3,' AND LON BAND=',I3, & + & ' LAND(=1) SEA=',I3//' MODEL RH ',' OBS RTCLD') + do i = 1, NBIN + print 203, rhcf(i,j,k,l,m), rtncf(i,j,k,l,m) + 203 format(2f10.2) + enddo + endif + + endif ! if_kkpts + + enddo ! end_do_j_loop + enddo ! end_do_k_loop + enddo ! end_do_l_loop + enddo ! end_do_m_loop + + do m = 1, NSEAL + do l = 1, MCLD + do k = 1, NLAT + do j = 1, NLON + + isat = 0 + do i = 1, NBIN-1 + cfrac = binscl * (i - 1) + + if (rhcla(i,j,k,l,m) < 0.0) then + print 1941, i,m,l,k,j + 1941 format(' NEG RHCLA FOR IT,NSL,NC,LAT,LON=',5I4 & + &, '...STOPPP..') + stop + endif + + if (rtncf(i,j,k,l,m) >= 1.0) then + if (isat <= 0) then + isat = i + rhsat = rhcla(i,j,k,l,m) + clsat = cfrac + endif + + rhcla(i,j,k,l,m) = rhsat + (1.0 - rhsat) & + & * (cfrac - clsat) / (1.0 - clsat) + endif + enddo + + rhcla(NBIN,j,k,l,m) = 1.0 + + enddo ! end_do_j_loop + enddo ! end_do_k_loop + enddo ! end_do_l_loop + enddo ! end_do_m_loop + +! --- smooth out the table as it reaches rh=1.0, via linear interpolation +! between location of rh ge .98 and the NBIN bin (where rh=1.0) +! previously rh=1.0 occurred for many of the latter bins in the +! --- table, thereby giving a cloud value of less then 1.0 for rh=1.0 + + rhcl = rhcla + + do m = 1, NSEAL + do l = 1, MCLD + do k = 1, NLAT + do j = 1, NLON + + lab_do_i : do i = 1, NBIN - 2 + cfrac = binscl * i + + if (rhcla(i,j,k,l,m) >= 0.98) then + do i1 = i, NBIN + cstem = binscl * i1 + + rhcl(i1,j,k,l,m) = rhcla(i,j,k,l,m) & + & + (rhcla(NBIN,j,k,l,m) - rhcla(i,j,k,l,m)) & + & * (cstem - cfrac) / (1.0 - cfrac) + enddo + exit lab_do_i + endif + enddo lab_do_i + + enddo ! end_do_j_loop + enddo ! end_do_k_loop + enddo ! end_do_l_loop + enddo ! end_do_m_loop + + if (me == 0) then + print *,'completed rhtable for cloud tuninig tables' + endif + return + + 998 print 988 + 988 format(' from rhtable ERROR READING TABLES') + ier = -1 + return + + 999 print 989 + 989 format(' from rhtable E.O.F READING TABLES') + ier = -1 + return + +!................................... + end subroutine rhtable +!----------------------------------- + + +! +!........................................! + end module module_radiation_clouds ! +!========================================! +!> @} diff --git a/gsmphys/radiation_gases.f b/gsmphys/radiation_gases.f new file mode 100644 index 00000000..2e9615a2 --- /dev/null +++ b/gsmphys/radiation_gases.f @@ -0,0 +1,1169 @@ +!> \file radiation_gases.f +!! This file contains routines that set up ozone climatological +!! profiles and other constant gas profiles, such as co2, ch4, n2o, +!! o2, and those of cfc gases. All data are entered as mixing ratio +!! by volume, except ozone which is mass mixing ratio (g/g). + +! ========================================================== !!!!! +! 'module_radiation_gases' description !!!!! +! ========================================================== !!!!! +! ! +! set up ozone climatological profiles and other constant gas ! +! profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All ! +! data are entered as mixing ratio by volume, except ozone which is ! +! mass mixing ratio (g/g). ! +! ! +! in the module, the externally callabe subroutines are : ! +! ! +! 'gas_init' -- initialization ! +! input: ! +! ( me ) ! +! output: ! +! ( none ) ! +! ! +! 'gas_update' -- read in data and update with time ! +! input: ! +! ( iyear, imon, iday, ihour, loz1st, ldoco2, me ) ! +! output: ! +! ( none ) ! +! ! +! 'getozn' -- setup climatological ozone profile ! +! input: ! +! ( prslk,xlat, ! +! IMAX, LM ) ! +! output: ! +! ( o3mmr ) ! +! ! +! 'getgases' -- setup constant gas profiles for LW and SW ! +! input: ! +! ( plvl, xlon, xlat, ! +! IMAX, LMAX ) ! +! output: ! +! ( gasdat ) ! +! ! +! external modules referenced: ! +! 'module machine' in 'machine.f' ! +! 'module funcphys' in 'funcphys.f' ! +! 'module physcons' in 'physcons.f ! +! 'module module_iounitdef' in 'iounitdef.f' ! +! ! +! unit used for radiative active gases: ! +! ozone : mass mixing ratio (g/g) ! +! co2 : volume mixing ratio (p/p) ! +! n2o : volume mixing ratio (p/p) ! +! ch4 : volume mixing ratio (p/p) ! +! o2 : volume mixing ratio (p/p) ! +! co : volume mixing ratio (p/p) ! +! cfc11 : volume mixing ratio (p/p) ! +! cfc12 : volume mixing ratio (p/p) ! +! cfc22 : volume mixing ratio (p/p) ! +! ccl4 : volume mixing ratio (p/p) ! +! cfc113: volume mixing ratio (p/p) ! +! ! +! ! +! program history: ! +! may 2003 - y-t hou create rad_module.f that collectively ! +! combines several radiation computation supporting ! +! programs into fortran 90 module structure (gases ! +! and aerosols, etc.) ! +! apr 2004 - y-t hou modified to add astronomy and surface ! +! module components. ! +! feb 2005 - y-t hou rewrite the component modules into ! +! separate individule modules for thier corresponding ! +! tasks. here as radiation_gases.f ! +! mar 2006 - y-t hou add initialization subroutine to co2 and ! +! other gases. historical 2-d co2 data are added. ! +! sep 2008 - y-t hou add parameter ictm to control the input ! +! data time at the model initial condition. ! +! oct 2008 - y-t hou modify the initialization code to add the ! +! option of superimposing climatology seasonal cycle ! +! to the initial condition data (currently co2 only) ! +! nov 2008 - y-t hou fix bugs in superimposing climatology ! +! seasonal cycle calculations ! +! aug 2011 - y-t hou fix a bug in subr getgases doing vertical ! +! co2 mapping. (for iflip=0 case, not affact opr). ! +! aug 2012 - y-t hou modified subr getozn. moved the if-first ! +! block to subr gas_init to ensure threading safe in ! +! climatology ozone applications. (not affect gfs) ! +! also changed the initialization subr into two parts:! +! 'gas_init' is called at the start of run to set up ! +! module parameters; and 'gas_update' is called within! +! the time loop to check and update data sets. defined! +! the climatology ozone parameters k1oz,k2oz,facoz as ! +! module variables and are set in subr 'gas_update' ! +! nov 2012 - y-t hou modified control parameters thru module ! +! 'physparam'. ! +! jan 2013 - z. janjic/y. hou modified ilon (longitude index) ! +! computing formula in subroutine getgases to work ! +! properly for models with either of 0->360 or ! +! -180->180 zonal grid directions. ! +! ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + + +!> \ingroup rad +!! \defgroup module_radiation_gases module_radiation_gases +!! @{ +!> This module sets up ozone climatological profiles and other constant +!! gas profiles, such as co2, ch4, n2o, o2, and those of cfc gases. All +!! data are entered as mixing ratio by volume, except ozone which is +!! mass mixing ratio (g/g). +!!\version NCEP-Radiation_gases v5.1 Nov 2012 +!========================================! + module module_radiation_gases ! +!........................................! +! + use physparam, only : ico2flg, ictmflg, ioznflg, ivflip, & + & co2dat_file, co2gbl_file, & + & co2usr_file, co2cyc_file, & + & kind_phys, kind_io4 + use funcphys, only : fpkapx + use physcons, only : con_pi + use ozne_def, only : JMR => latsozc, LOZ => levozc, & + & blte => blatc, dlte=> dphiozc, & + & timeozc => timeozc + use module_iounitdef, only : NIO3CLM, NICO2CN +! + implicit none +! + private + +! --- version tag and last revision date + character(40), parameter :: & + & VTAGGAS='NCEP-Radiation_gases v5.1 Nov 2012 ' +! & VTAGGAS='NCEP-Radiation_gases v5.0 Aug 2012 ' + +!>\name parameter constants + +!> number of gas species + integer, parameter, public :: NF_VGAS = 10 +!> input co2 dat lon points + integer, parameter :: IMXCO2 = 24 +!> input co2 data lat points + integer, parameter :: JMXCO2 = 12 +!> earlist year 2-d co2 data available + integer, parameter :: MINYEAR = 1957 + +!> horizontal resolution in degree + real (kind=kind_phys), parameter :: resco2=15.0 +!> rad->deg conversion + real (kind=kind_phys), parameter :: raddeg=180.0/con_pi +!> pressure limitation for 2-d co2 (mb) + real (kind=kind_phys), parameter :: prsco2=788.0 +!> half of pi + real (kind=kind_phys), parameter :: hfpi =0.5*con_pi + +!>\name parameter constants for gas volume mixing ratioes + + real (kind=kind_phys), parameter :: co2vmr_def = 350.0e-6 + real (kind=kind_phys), parameter :: n2ovmr_def = 0.31e-6 + real (kind=kind_phys), parameter :: ch4vmr_def = 1.50e-6 + real (kind=kind_phys), parameter :: o2vmr_def = 0.209 + real (kind=kind_phys), parameter :: covmr_def = 1.50e-8 +!> aer 2003 value + real (kind=kind_phys), parameter :: f11vmr_def = 3.520e-10 +!> aer 2003 value + real (kind=kind_phys), parameter :: f12vmr_def = 6.358e-10 +!> aer 2003 value + real (kind=kind_phys), parameter :: f22vmr_def = 1.500e-10 +!> aer 2003 value + real (kind=kind_phys), parameter :: cl4vmr_def = 1.397e-10 +!> gfdl 1999 value + real (kind=kind_phys), parameter :: f113vmr_def= 8.2000e-11 + +! --- ozone seasonal climatology parameters defined in module ozne_def +! - 4x5 ozone data parameter +! integer, parameter :: JMR=45, LOZ=17 +! real (kind=kind_phys), parameter :: blte=-86.0, dlte=4.0 +! - geos ozone data +! integer, parameter :: JMR=18, LOZ=17 +! real (kind=kind_phys), parameter :: blte=-85.0, dlte=10.0 + +! --- module variables to be set in subroutin gas_init and/or gas_update + +!> \name variables for climatology ozone (ioznflg = 0) + + real (kind=kind_phys), allocatable :: pkstr(:), o3r(:,:,:) + integer :: k1oz = 0, k2oz = 0 + real (kind=kind_phys) :: facoz = 0.0 + +!>\name arrays for co2 2-d monthly data and global mean values from observed data + + real (kind=kind_phys), allocatable :: co2vmr_sav(:,:,:) + real (kind=kind_phys), allocatable :: co2cyc_sav(:,:,:) + + real (kind=kind_phys) :: co2_glb = co2vmr_def + real (kind=kind_phys) :: gco2cyc(12) + data gco2cyc(:) / 12*0.0 / + + integer :: kyrsav = 0 + integer :: kmonsav = 1 + +! --- public interfaces + + public gas_init, gas_update, getgases, getozn + + +! ================= + contains +! ================= + +!> This subroutine sets up ozone, co2, etc. parameters. If climatology +!! ozone then read in monthly ozone data. +!!\param me print message control flag +!----------------------------------- + subroutine gas_init & + & ( me )! --- inputs: +! --- outputs: ( none ) + +! =================================================================== ! +! ! +! gas_init sets up ozone, co2, etc. parameters. if climatology ozone ! +! then read in monthly ozone data. ! +! ! +! inputs: dimemsion ! +! me - print message control flag 1 ! +! ! +! outputs: (to the module variables) ! +! ( none ) ! +! ! +! external module variables: (in physparam) ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav) ! +! ictmflg - =yyyy#, data ic time/date control flag ! +! = -2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! = -1: use user provided external data for the fcst ! +! time, no extrapolation. ! +! = 0: use data at initial cond time, if not existed! +! then use latest, without extrapolation. ! +! = 1: use data at the forecast time, if not existed! +! then use latest and extrapolate to fcst time.! +! =yyyy0: use yyyy data for the forecast time, no ! +! further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg - ozone data control flag ! +! =0: use climatological ozone profile ! +! >0: use interactive ozone profile ! +! ivflip - vertical profile indexing flag ! +! co2usr_file- external co2 user defined data table ! +! co2cyc_file- external co2 climotology monthly cycle data table ! +! ! +! internal module variables: ! +! pkstr, o3r - arrays for climatology ozone data ! +! ! +! usage: call gas_init ! +! ! +! subprograms called: none ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: me + +! --- output: ( none ) + +! --- locals: + real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat + real (kind=kind_phys) :: co2g1, co2g2 + real (kind=kind_phys) :: pstr(LOZ) + real (kind=kind_io4) :: o3clim4(JMR,LOZ,12), pstr4(LOZ) + + integer :: imond(12), ilat(JMR,12) + integer :: i, j, k, iyr, imo + logical :: file_exist, lextpl + character :: cline*100, cform*8 + data cform / '(24f7.2)' / !! data format in IMXCO2*f7.2 +! +!===> ... begin here +! + if ( me == 0 ) print *, VTAGGAS ! print out version tag + + kyrsav = 0 + kmonsav = 1 + +! --- ... climatology ozone data section + + if ( ioznflg > 0 ) then + if ( me == 0 ) then + print *,' - Using interactive ozone distribution' + endif + else + if ( timeozc /= 12 ) then + print *,' - Using climatology ozone distribution' + print *,' timeozc=',timeozc, ' is not monthly mean', & + & ' - job aborting in subroutin gas_init!!!' + stop + endif + + allocate (pkstr(LOZ), o3r(JMR,LOZ,12)) + rewind NIO3CLM + + if ( LOZ == 17 ) then ! For the operational ozone climatology + do k = 1, LOZ + read (NIO3CLM,15) pstr4(k) + 15 format(f10.3) + enddo + + do imo = 1, 12 + do j = 1, JMR + read (NIO3CLM,16) imond(imo), ilat(j,imo), & + & (o3clim4(j,k,imo),k=1,10) + 16 format(i2,i4,10f6.2) + read (NIO3CLM,20) (o3clim4(j,k,imo),k=11,LOZ) + 20 format(6x,10f6.2) + enddo + enddo + else ! For newer ozone climatology + read (NIO3CLM) + do k = 1, LOZ + read (NIO3CLM) pstr4(k) + enddo + + do imo = 1, 12 + do k = 1, LOZ + read (NIO3CLM) (o3clim4(j,k,imo),j=1,JMR) + enddo + enddo + endif ! end if_LOZ_block +! + do imo = 1, 12 + do k = 1, LOZ + do j = 1, JMR + o3r(j,k,imo) = o3clim4(j,k,imo) * 1.655e-6 + enddo + enddo + enddo + + do k = 1, LOZ + pstr(k) = pstr4(k) + enddo + + if ( me == 0 ) then + print *,' - Using climatology ozone distribution' + print *,' Found ozone data for levels pstr=', & + & (pstr(k),k=1,LOZ) +! print *,' O3=',(o3r(15,k,1),k=1,LOZ) + endif + + do k = 1, LOZ + pkstr(k) = fpkapx(pstr(k)*100.0) + enddo + endif ! end if_ioznflg_block + +! --- ... co2 data section + + co2_glb = co2vmr_def + + lab_ico2 : if ( ico2flg == 0 ) then + + if ( me == 0 ) then + print *,' - Using prescribed co2 global mean value=', & + & co2vmr_def + endif + + else lab_ico2 + + lab_ictm : if ( ictmflg == -1 ) then ! input user provided data + + inquire (file=co2usr_file, exist=file_exist) + if ( .not. file_exist ) then + print *,' Can not find user CO2 data file: ',co2usr_file, & + & ' - Stopped in subroutine gas_init !!' + stop + else + close (NICO2CN) + open(NICO2CN,file=co2usr_file,form='formatted',status='old') + rewind NICO2CN + read (NICO2CN, 25) iyr, cline, co2g1, co2g2 + 25 format(i4,a94,f7.2,16x,f5.2) + co2_glb = co2g1 * 1.0e-6 + + if ( ico2flg == 1 ) then + if ( me == 0 ) then + print *,' - Using co2 global annual mean value from', & + & ' user provided data set:',co2usr_file + print *, iyr,cline(1:94),co2g1,' GROWTH RATE =', co2g2 + endif + elseif ( ico2flg == 2 ) then + allocate ( co2vmr_sav(IMXCO2,JMXCO2,12) ) + + do imo = 1, 12 + read (NICO2CN,cform) co2dat +!check print cform, co2dat + + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2vmr_sav(i,j,imo) = co2dat(i,j) * 1.0e-6 + enddo + enddo + enddo + + if ( me == 0 ) then + print *,' - Using co2 monthly 2-d data from user', & + & ' provided data set:',co2usr_file + print *, iyr,cline(1:94),co2g1,' GROWTH RATE =', co2g2 + + print *,' CHECK: Sample of selected months of CO2 data' + do imo = 1, 12, 3 + print *,' Month =',imo + print *, (co2vmr_sav(1,j,imo),j=1,jmxco2) + enddo + endif + else + print *,' ICO2=',ico2flg,' is not a valid selection', & + & ' - Stoped in subroutine gas_init!!!' + stop + endif ! endif_ico2flg_block + + close (NICO2CN) + endif ! endif_file_exist_block + + else lab_ictm ! input from observed data + + if ( ico2flg == 1 ) then + if ( me == 0 ) then + print *,' - Using observed co2 global annual mean value' + endiF + elseif ( ico2flg == 2 ) then + allocate ( co2vmr_sav(IMXCO2,JMXCO2,12) ) + + if ( me == 0 ) then + print *,' - Using observed co2 monthly 2-d data' + endif + else + print *,' ICO2=',ico2flg,' is not a valid selection', & + & ' - Stoped in subroutine gas_init!!!' + stop + endif + + if ( ictmflg == -2 ) then + inquire (file=co2cyc_file, exist=file_exist) + if ( .not. file_exist ) then + if ( me == 0 ) then + print *,' Can not find seasonal cycle CO2 data: ', & + & co2cyc_file,' - Stopped in subroutine gas_init !!' + endif + stop + else + allocate( co2cyc_sav(IMXCO2,JMXCO2,12) ) + +! --- ... read in co2 2-d seasonal cycle data + close (NICO2CN) + open (NICO2CN,file=co2cyc_file,form='formatted', & + & status='old') + rewind NICO2CN + read (NICO2CN, 35) cline, co2g1, co2g2 + 35 format(a98,f7.2,16x,f5.2) + read (NICO2CN,cform) co2dat ! skip annual mean part + + if ( me == 0 ) then + print *,' - Superimpose seasonal cycle to mean CO2 data' + print *,' Opened CO2 climatology seasonal cycle data',& + & ' file: ',co2cyc_file +!check print *, cline(1:98), co2g1, co2g2 + endif + + do imo = 1, 12 + read (NICO2CN,45) cline, gco2cyc(imo) + 45 format(a58,f7.2) +!check print *, cline(1:58),gco2cyc(imo) + gco2cyc(imo) = gco2cyc(imo) * 1.0e-6 + + read (NICO2CN,cform) co2dat +!check print cform, co2dat + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2cyc_sav(i,j,imo) = co2dat(i,j) * 1.0e-6 + enddo + enddo + enddo + + close (NICO2CN) + endif ! endif_file_exist_block + endif + + endif lab_ictm + endif lab_ico2 + + return +! +!................................... + end subroutine gas_init +!----------------------------------- + +!> This subroutine reads in 2-d monthly co2 data set for a specified +!! year. Data are in a 15 degree lat/lon horizontal resolution. +!!\param iyear year of the requested data for fcst +!!\param imon month of the year +!!\param iday day of the month +!!\param ihour hour of the day +!!\param loz1st clim ozone 1st time update control flag +!!\param ldoco2 co2 update control flag +!!\param me print message control flag +!>\section gen_gas_update General Algorithm +!! @{ +!----------------------------------- + subroutine gas_update & + & ( iyear, imon, iday, ihour, loz1st, ldoco2, me )! --- inputs +! --- outputs: ( none ) + +! =================================================================== ! +! ! +! gas_update reads in 2-d monthly co2 data set for a specified year. ! +! data are in a 15 degree lat/lon horizontal resolution. ! +! ! +! inputs: dimemsion ! +! iyear - year of the requested data for fcst 1 ! +! imon - month of the year 1 ! +! iday - day of the month 1 ! +! ihour - hour of the day 1 ! +! loz1st - clim ozone 1st time update control flag 1 ! +! ldoco2 - co2 update control flag 1 ! +! me - print message control flag 1 ! +! ! +! outputs: (to the module variables) ! +! ( none ) ! +! ! +! external module variables: (in physparam) ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav) ! +! ictmflg - =yyyy#, data ic time/date control flag ! +! = -2: same as 0, but superimpose seasonal cycle ! +! from climatology data set. ! +! = -1: use user provided external data for the fcst ! +! time, no extrapolation. ! +! = 0: use data at initial cond time, if not existed! +! then use latest, without extrapolation. ! +! = 1: use data at the forecast time, if not existed! +! then use latest and extrapolate to fcst time.! +! =yyyy0: use yyyy data for the forecast time, no ! +! further data extrapolation. ! +! =yyyy1: use yyyy data for the fcst. if needed, do ! +! extrapolation to match the fcst time. ! +! ioznflg - ozone data control flag ! +! =0: use climatological ozone profile ! +! >0: use interactive ozone profile ! +! ivflip - vertical profile indexing flag ! +! co2dat_file- external co2 2d monthly obsv data table ! +! co2gbl_file- external co2 global annual mean data table ! +! ! +! internal module variables: ! +! co2vmr_sav - monthly co2 volume mixing ratio IMXCO2*JMXCO2*12 ! +! co2cyc_sav - monthly cycle co2 vol mixing ratio IMXCO2*JMXCO2*12 ! +! co2_glb - global annual mean co2 mixing ratio ! +! gco2cyc - global monthly mean co2 variation 12 ! +! k1oz,k2oz,facoz ! +! - climatology ozone parameters 1 ! +! ! +! usage: call gas_update ! +! ! +! subprograms called: none ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: iyear, imon, iday, ihour, me + + logical, intent(in) :: loz1st, ldoco2 + +! --- output: ( none ) + +! --- locals: + real (kind=kind_phys), dimension(IMXCO2,JMXCO2) :: co2dat, co2ann + real (kind=kind_phys) :: co2g1, co2g2, rate + + integer :: i, id, j, l, iyr, imo, iyr1, iyr2, jyr, idyr + integer, save :: mdays(13), midmon=15, midm=15, midp=45 +! --- number of days in a month + data mdays / 31,28,31,30,31,30,31,31,30,31,30,31,30 / + + logical :: file_exist, lextpl, change + character :: cline*100, cform*8, cfile1*32 + data cform / '(24f7.2)' / !! data format in IMXCO2*f7.2 +! +!===> ... begin here +! +!> - Ozone data section + + if ( ioznflg == 0 ) then + midmon = mdays(imon)/2 + 1 + change = loz1st .or. ( (iday==midmon) .and. (ihour==0) ) +! + if ( change ) then + if ( iday < midmon ) then + k1oz = mod(imon+10, 12) + 1 + midm = mdays(k1oz)/2 + 1 + k2oz = imon + midp = mdays(k1oz) + midmon + else + k1oz = imon + midm = midmon + k2oz = mod(imon, 12) + 1 + midp = mdays(k2oz)/2 + 1 + mdays(k1oz) + endif + endif +! + if (iday < midmon) then + id = iday + mdays(k1oz) + else + id = iday + endif + + facoz = float(id - midm) / float(midp - midm) + endif + +!> - co2 data section + + if ( ico2flg == 0 ) return ! use prescribed global mean co2 data + if ( ictmflg ==-1 ) return ! use user provided co2 data + if ( .not. ldoco2 ) return ! no need to update co2 data + + if ( ictmflg < 0 ) then ! use user provided external data + lextpl = .false. ! no time extrapolation + idyr = iyear ! use the model year + else ! use historically observed data + lextpl = ( mod(ictmflg,10) == 1 ) ! flag for data extrapolation + idyr = ictmflg / 10 ! year of data source used + if ( idyr == 0 ) idyr = iyear ! not specified, use model year + endif + +! --- ... auto select co2 2-d data table for required year + + kmonsav = imon + if ( kyrsav == iyear ) return + kyrsav = iyear + iyr = iyear + +! --- ... for data earlier than MINYEAR (1957), the data are in +! the form of semi-yearly global mean values. otherwise, +! data are monthly mean in horizontal 2-d map. + + Lab_if_idyr : if ( idyr < MINYEAR .and. ictmflg > 0 ) then + + if ( me == 0 ) then + print *,' Requested CO2 data year',iyear,' earlier than', & + & MINYEAR + print *,' Which is the earliest monthly observation', & + & ' data available.' + print *,' Thus, historical global mean data is used' + endif + +! --- ... check to see if requested co2 data file existed + + inquire (file=co2gbl_file, exist=file_exist) + if ( .not. file_exist ) then + print *,' Requested co2 data file "',co2gbl_file, & + & '" not found - Stopped in subroutine gas_update!!' + stop + else + close(NICO2CN) + open (NICO2CN,file=co2gbl_file,form='formatted',status='old') + rewind NICO2CN + + read (NICO2CN, 24) iyr1, iyr2, cline + 24 format(i4,4x,i4,a48) + + if ( me == 0 ) then + print *,' Opened co2 data file: ',co2gbl_file +!check print *, iyr1, iyr2, cline(1:48) + endif + + if ( idyr < iyr1 ) then + iyr = iyr1 +!check if ( me == 0 ) then +! print *,' Using earlist available co2 data, year=',iyr1 +!check endif + endif + + i = iyr2 + Lab_dowhile1 : do while ( i >= iyr1 ) +! read (NICO2CN,26) jyr, co2g1, co2g2 +! 26 format(i4,4x,2f7.2) + read (NICO2CN, *) jyr, co2g1, co2g2 + + if ( i == iyr .and. iyr == jyr ) then + co2_glb = (co2g1+co2g2) * 0.5e-6 + if ( ico2flg == 2 ) then + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2vmr_sav(i,j,1:6) = co2g1 * 1.0e-6 + co2vmr_sav(i,j,7:12) = co2g2 * 1.0e-6 + enddo + enddo + endif + + if ( me == 0 ) print *,' Co2 data for year',iyear, & + & co2_glb + exit Lab_dowhile1 + else +!check if ( me == 0 ) print *,' Skip co2 data for year',i + i = i - 1 + endif + enddo Lab_dowhile1 + + close ( NICO2CN ) + endif ! end if_file_exist_block + + else Lab_if_idyr + +! --- ... set up input data file name + + cfile1 = co2dat_file + write(cfile1(25:28),34) idyr + 34 format(i4.4) + +! --- ... check to see if requested co2 data file existed + + inquire (file=cfile1, exist=file_exist) + if ( .not. file_exist ) then + + Lab_if_ictm : if ( ictmflg > 10 ) then ! specified year of data not found + if ( me == 0 ) then + print *,' Specified co2 data for year',idyr, & + & ' not found !! Need to change namelist ICTM !!' + print *,' *** Stopped in subroutine gas_update !!' + endif + stop + else Lab_if_ictm ! looking for latest available data + if ( me == 0 ) then + print *,' Requested co2 data for year',idyr, & + & ' not found, check for other available data set' + endif + + Lab_dowhile2 : do while ( iyr >= MINYEAR ) + iyr = iyr - 1 + write(cfile1(25:28),34) iyr + + inquire (file=cfile1, exist=file_exist) + if ( me == 0 ) then + print *,' Looking for CO2 file ',cfile1 + endif + + if ( file_exist ) then + exit Lab_dowhile2 + endif + enddo Lab_dowhile2 + + if ( .not. file_exist ) then + if ( me == 0 ) then + print *,' Can not find co2 data source file' + print *,' *** Stopped in subroutine gas_update !!' + endif + stop + endif + endif Lab_if_ictm + endif ! end if_file_exist_block + +! --- ... read in co2 2-d data for the requested month + + close(NICO2CN) + open (NICO2CN,file=cfile1,form='formatted',status='old') + rewind NICO2CN + read (NICO2CN, 36) iyr, cline, co2g1, co2g2 + 36 format(i4,a94,f7.2,16x,f5.2) + + if ( me == 0 ) then + print *,' Opened co2 data file: ',cfile1 + print *, iyr, cline(1:94), co2g1,' GROWTH RATE =', co2g2 + endif + +! --- ... add growth rate if needed + if ( lextpl ) then +! rate = co2g2 * (iyear - iyr) ! rate from early year +! rate = 1.60 * (iyear - iyr) ! avg rate over long period + rate = 2.00 * (iyear - iyr) ! avg rate for recent period + else + rate = 0.0 + endif + + co2_glb = (co2g1 + rate) * 1.0e-6 + if ( me == 0 ) then + print *,' Global annual mean CO2 data for year', & + & iyear, co2_glb + endif + + if ( ictmflg == -2 ) then ! need to calc ic time annual mean first + + if ( ico2flg == 1 ) then + if ( me==0 ) then + print *,' CHECK: Monthly deviations of climatology ', & + & 'to be superimposed on global annual mean' + print *, gco2cyc + endif + elseif ( ico2flg == 2 ) then + co2ann(:,:) = 0.0 + + do imo = 1, 12 + read (NICO2CN,cform) co2dat +!check print cform, co2dat + + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2ann(i,j) = co2ann(i,j) + co2dat(i,j) + enddo + enddo + enddo + + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2ann(i,j) = co2ann(i,j) * 1.0e-6 / float(12) + enddo + enddo + + do imo = 1, 12 + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2vmr_sav(i,j,imo) = co2ann(i,j)+co2cyc_sav(i,j,imo) + enddo + enddo + enddo + + if ( me==0 ) then + print *,' CHECK: Sample of 2-d annual mean of CO2 ', & + & 'data used for year:',iyear + print *, co2ann(1,:) + print *,' CHECK: AFTER adding seasonal cycle, Sample ', & + & 'of selected months of CO2 data for year:',iyear + do imo = 1, 12, 3 + print *,' Month =',imo + print *, co2vmr_sav(1,:,imo) + enddo + endif + endif ! endif_icl2flg_block + + else ! no need to calc ic time annual mean first + + if ( ico2flg == 2 ) then ! directly save monthly data + do imo = 1, 12 + read (NICO2CN,cform) co2dat +!check print cform, co2dat + + do j = 1, JMXCO2 + do i = 1, IMXCO2 + co2vmr_sav(i,j,imo) = (co2dat(i,j) + rate) * 1.0e-6 + enddo + enddo + enddo + + if ( me == 0 ) then + print *,' CHECK: Sample of selected months of CO2 ', & + & 'data used for year:',iyear + do imo = 1, 12, 3 + print *,' Month =',imo + print *, co2vmr_sav(1,:,imo) + enddo + endif + endif ! endif_ico2flg_block + + do imo = 1, 12 + gco2cyc(imo) = 0.0 + enddo + endif ! endif_ictmflg_block + close ( NICO2CN ) + + endif Lab_if_idyr + + return +! +!................................... + end subroutine gas_update +!----------------------------------- +!! @} + +!> This subroutine sets up global distribution of radiation absorbing +!! gases in volume mixing ratio. Currently only co2 has the options +!! from observed values, all other gases are asigned to the +!! climatological values. +!!\param plvl (IMAX,LMAX+1), pressure at model layer interfaces (mb) +!!\param xlon (IMAX), grid longitude in radians, ok both 0->2pi +!! or -pi -> +pi arrangements +!!\param xlat (IMAX), grid latitude in radians, default range to +!! pi/2 -> -pi/2, otherwise see in-line comment +!!\param IMAX, LMAX horizontal/vertical dimensions for output data +!!\param gasdat (IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes +!!\n (:,:,1) - co2 +!!\n (:,:,2) - n2o +!!\n (:,:,3) - ch4 +!!\n (:,:,4) - o2 +!!\n (:,:,5) - co +!!\n (:,:,6) - cfc11 +!!\n (:,:,7) - cfc12 +!!\n (:,:,8) - cfc22 +!!\n (:,:,9) - ccl4 +!!\n (:,:,10) - cfc113 +!----------------------------------- + subroutine getgases & + & ( plvl, xlon, xlat, & ! --- inputs + & IMAX, LMAX, & + & gasdat & ! --- outputs + & ) + +! =================================================================== ! +! ! +! getgases set up global distribution of radiation absorbing gases ! +! in volume mixing ratio. currently only co2 has the options from ! +! observed values, all other gases are asigned to the climatological ! +! values. ! +! ! +! inputs: ! +! plvl(IMAX,LMAX+1)- pressure at model layer interfaces (mb) ! +! xlon(IMAX) - grid longitude in radians, ok both 0->2pi or ! +! -pi -> +pi arrangements ! +! xlat(IMAX) - grid latitude in radians, default range to ! +! pi/2 -> -pi/2, otherwise see in-line comment ! +! IMAX, LMAX - horiz, vert dimensions for output data ! +! ! +! outputs: ! +! gasdat(IMAX,LMAX,NF_VGAS) - gases volume mixing ratioes ! +! (:,:,1) - co2 ! +! (:,:,2) - n2o ! +! (:,:,3) - ch4 ! +! (:,:,4) - o2 ! +! (:,:,5) - co ! +! (:,:,6) - cfc11 ! +! (:,:,7) - cfc12 ! +! (:,:,8) - cfc22 ! +! (:,:,9) - ccl4 ! +! (:,:,10) - cfc113 ! +! ! +! external module variables: (in physparam) ! +! ico2flg - co2 data source control flag ! +! =0: use prescribed co2 global mean value ! +! =1: use input global mean co2 value (co2_glb) ! +! =2: use input 2-d monthly co2 value (co2vmr_sav) ! +! ivflip - vertical profile indexing flag ! +! ! +! internal module variables used: ! +! co2vmr_sav - saved monthly co2 concentration from sub gas_update ! +! co2_glb - saved global annual mean co2 value from gas_update ! +! gco2cyc - saved global seasonal variation of co2 climatology ! +! in 12-month form ! +! ** note: for lower atmos co2vmr_sav may have clim monthly deviations ! +! superimposed on init-cond co2 value, while co2_glb only ! +! contains the global mean value, thus needs to add the ! +! monthly dglobal mean deviation gco2cyc at upper atmos. for ! +! ictmflg/=-2, this value will be zero. ! +! ! +! usage: call getgases ! +! ! +! subprograms called: none ! +! ! +! =================================================================== ! +! + implicit none + +! --- input: + integer, intent(in) :: IMAX, LMAX + real (kind=kind_phys), intent(in) :: plvl(:,:), xlon(:), xlat(:) + +! --- output: + real (kind=kind_phys), intent(out) :: gasdat(:,:,:) + +! --- local: + integer :: i, k, ilat, ilon + + real (kind=kind_phys) :: xlon1, xlat1, tmp + +!===> ... begin here + +! --- ... assign default values + + do k = 1, LMAX + do i = 1, IMAX + gasdat(i,k,1) = co2vmr_def + gasdat(i,k,2) = n2ovmr_def + gasdat(i,k,3) = ch4vmr_def + gasdat(i,k,4) = o2vmr_def + gasdat(i,k,5) = covmr_def + gasdat(i,k,6) = f11vmr_def + gasdat(i,k,7) = f12vmr_def + gasdat(i,k,8) = f22vmr_def + gasdat(i,k,9) = cl4vmr_def + gasdat(i,k,10)= f113vmr_def + enddo + enddo + +! --- ... co2 section + + if ( ico2flg == 1 ) then +! --- use obs co2 global annual mean value only + + do k = 1, LMAX + do i = 1, IMAX + gasdat(i,k,1) = co2_glb + gco2cyc(kmonsav) + enddo + enddo + + elseif ( ico2flg == 2 ) then +! --- use obs co2 monthly data with 2-d variation at lower atmos +! otherwise use global mean value + + tmp = raddeg / resco2 + do i = 1, IMAX + xlon1 = xlon(i) + if ( xlon1 < 0.0 ) xlon1 = xlon1 + con_pi ! if xlon in -pi->pi, convert to 0->2pi + xlat1 = hfpi - xlat(i) ! if xlat in pi/2 -> -pi/2 range +!note xlat1 = xlat(i) ! if xlat in 0 -> pi range + + ilon = min( IMXCO2, int( xlon1*tmp + 1 )) + ilat = min( JMXCO2, int( xlat1*tmp + 1 )) + + if ( ivflip == 0 ) then ! index from toa to sfc + do k = 1, LMAX + if ( plvl(i,k) >= prsco2 ) then + gasdat(i,k,1) = co2vmr_sav(ilon,ilat,kmonsav) + else + gasdat(i,k,1) = co2_glb + gco2cyc(kmonsav) + endif + enddo + else ! index from sfc to toa + do k = 1, LMAX + if ( plvl(i,k+1) >= prsco2 ) then + gasdat(i,k,1) = co2vmr_sav(ilon,ilat,kmonsav) + else + gasdat(i,k,1) = co2_glb + gco2cyc(kmonsav) + endif + enddo + endif + enddo + endif + +! + return +!................................... + end subroutine getgases +!----------------------------------- + +!> This subroutine sets up climatological ozone profile for radiation +!! calculation. This code is originally written by Shrinivas Moorthi. +!!\param prslk (IMAX,LM), exner function = \f$(p/p0)^{rocp}\f$ +!!\param xlat (IMAX), latitude in radians, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param IMAX, LM horizontal and vertical dimensions +!!\param o3mmr (IMAX,LM), output ozone profile in mass mixing +!! ratio (g/g) +!----------------------------------- + subroutine getozn & + & ( prslk,xlat, & ! --- inputs + & IMAX, LM, & + & o3mmr & ! --- outputs + & ) + +! =================================================================== ! +! ! +! getozn sets up climatological ozone profile for radiation calculation! +! ! +! this code is originally written By Shrinivas Moorthi ! +! ! +! inputs: ! +! prslk (IMAX,LM) - exner function = (p/p0)**rocp ! +! xlat (IMAX) - latitude in radians, default to pi/2 -> -pi/2 ! +! range, otherwise see in-line comment ! +! IMAX, LM - horizontal and vertical dimensions ! +! ! +! outputs: ! +! o3mmr (IMAX,LM) - output ozone profile in mass mixing ratio (g/g)! +! ! +! module variables: ! +! k1oz, k2oz - ozone data interpolation indices ! +! facoz - ozone data interpolation factor ! +! ivflip - control flag for direction of vertical index ! +! ! +! usage: call getozn ! +! ! +! =================================================================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: IMAX, LM + + real (kind=kind_phys), intent(in) :: prslk(:,:), xlat(:) + +! --- outputs: + real (kind=kind_phys), intent(out) :: o3mmr(:,:) + +! --- locals: + real (kind=kind_phys) :: o3i(IMAX,LOZ), wk1(IMAX), deglat, elte, & + & tem, tem1, tem2, tem3, tem4, temp + integer :: i, j, k, l, j1, j2, ll +! +!===> ... begin here +! + elte = blte + (JMR-1)*dlte + + do i = 1, IMAX + deglat = xlat(i) * raddeg ! if xlat in pi/2 -> -pi/2 range +! deglat = 90.0 - xlat(i)*raddeg ! if xlat in 0 -> pi range + + if (deglat > blte .and. deglat < elte) then + tem1 = (deglat - blte) / dlte + 1 + j1 = tem1 + j2 = j1 + 1 + tem1 = tem1 - j1 + elseif (deglat <= blte) then + j1 = 1 + j2 = 1 + tem1 = 1.0 + elseif (deglat >= elte) then + j1 = JMR + j2 = JMR + tem1 = 1.0 + endif + + tem2 = 1.0 - tem1 + do j = 1, LOZ + tem3 = tem2*o3r(j1,j,k1oz) + tem1*o3r(j2,j,k1oz) + tem4 = tem2*o3r(j1,j,k2oz) + tem1*o3r(j2,j,k2oz) + o3i(i,j) = tem4*facoz + tem3*(1.0 - facoz) + enddo + enddo + + do l = 1, LM + ll = l + if (ivflip == 1) ll = LM -l + 1 + + do i = 1, IMAX + wk1(i) = prslk(i,ll) + enddo + + do k = 1, LOZ-1 + temp = 1.0 / (pkstr(k+1) - pkstr(k)) + + do i = 1, IMAX + if (wk1(i) > pkstr(k) .and. wk1(i) <= pkstr(k+1)) then + tem = (pkstr(k+1) - wk1(i)) * temp + o3mmr(I,ll) = tem * o3i(i,k) + (1.0 - tem) * o3i(i,k+1) + endif + enddo + enddo + + do i = 1, IMAX + if (wk1(i) > pkstr(LOZ)) o3mmr(i,ll) = o3i(i,LOZ) + if (wk1(i) < pkstr(1)) o3mmr(i,ll) = o3i(i,1) + enddo + enddo +! + return +!................................... + end subroutine getozn +!----------------------------------- + +! +!........................................! + end module module_radiation_gases ! +!========================================! +!> @} diff --git a/gsmphys/radiation_surface.f b/gsmphys/radiation_surface.f new file mode 100644 index 00000000..12006c58 --- /dev/null +++ b/gsmphys/radiation_surface.f @@ -0,0 +1,814 @@ +!> \file radiation_surface.f +!! This file contains routines that set up surface albedo for SW +!! radiation and surface emissivity for LW radiation. + +! ========================================================== !!!!! +! 'module_radiation_surface' description !!!!! +! ========================================================== !!!!! +! ! +! this module sets up surface albedo for sw radiation and surface ! +! emissivity for lw radiation. ! +! ! +! ! +! in the module, the externally callabe subroutines are : ! +! ! +! 'sfc_init' -- initialization radiation surface data ! +! inputs: ! +! ( me ) ! +! outputs: ! +! (none) ! +! ! +! 'setalb' -- set up four-component surface albedoes ! +! inputs: ! +! (slmsk,snowf,sncovr,snoalb,zorlf,coszf,tsknf,tairf,hprif, ! +! alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc ! +! IMAX) ! +! outputs: ! +! (sfcalb) ! +! ! +! 'setemis' -- set up surface emissivity for lw radiation ! +! inputs: ! +! (xlon,xlat,slmsk,snowf,sncovr,zorlf,tsknf,tairf,hprif, ! +! IMAX) ! +! outputs: ! +! (sfcemis) ! +! ! +! external modules referenced: ! +! ! +! 'module machine' in 'machine.f' ! +! 'module physcons' in 'physcons.f' ! +! 'module module_iounitdef' in 'iounitdef.f' ! +! ! +! ! +! program history log: ! +! 1995 y.t. hou - created albaer.f (include albedo ! +! and aerosols calculations) ! +! nov 1997 y.t. hou - modified snow albedo ! +! jan 1998 y.t. hou - included grumbine's sea-ice scheme ! +! feb 1998 h.l. pan - seasonal interpolation in cycle ! +! mar 2000 y.t. hou - modified to use opac aerosol data ! +! apr 2003 y.t. hou - seperate albedo and aerosols into ! +! two subroutines, rewritten in f90 modulized form ! +! jan 2005 s. moorthi - xingren's sea-ice fraction added ! +! apr 2005 y.t. hou - revised module structure ! +! feb 2006 y.t. hou - add varying surface emissivity, ! +! modified sfc albedo structure for modis shceme ! +! Mar 2006 s. moorthi - added surface temp over ice fraction ! +! mar 2007 c. marshall & h. wei ! +! - added modis based sfc albedo scheme ! +! may 2007 y. hou & s. moorthi ! +! - fix bug in modis albedo over ocean ! +! aug 2007 h. wei & s. moorthi ! +! - fix bug in modis albedo over sea-ice ! +! aug 2007 y. hou - fix bug in emissivity over ocean in ! +! the modis scheme option ! +! dec 2008 f. yang - modified zenith angle dependence on ! +! surface albedo over land. (2008 jamc)! +! aug 2012 y. hou - minor modification in initialization ! +! subr 'sfc_init'. ! +! nov 2012 y. hou - modified control parameters through ! +! module 'physparam'. ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + + +!> \ingroup rad +!! \defgroup module_radiation_surface module_radiation_surface +!! @{ +!> This module sets up surface albedo for sw radiation and surface +!! emissivity for lw radiation. +!!\version NCEP-Radiation_surface v5.1 Nov 2012 +!========================================! + module module_radiation_surface ! +!........................................! +! + use physparam, only : ialbflg, iemsflg, semis_file, & + & kind_phys + use physcons, only : con_t0c, con_ttp, con_pi, con_tice + use module_iounitdef, only : NIRADSF +! + implicit none +! + private + +! --- version tag and last revision date + character(40), parameter :: & + & VTAGSFC='NCEP-Radiation_surface v5.1 Nov 2012 ' +! & VTAGSFC='NCEP-Radiation_surface v5.0 Aug 2012 ' + +! --- constant parameters +!> num of sfc albedo components + integer, parameter, public :: NF_ALBD = 4 + +!> num of longitude points in global emis-type map + integer, parameter, public :: IMXEMS = 360 + +!> num of latitude points in global emis-type map + integer, parameter, public :: JMXEMS = 180 + + real (kind=kind_phys), parameter :: f_zero = 0.0 + real (kind=kind_phys), parameter :: f_one = 1.0 + real (kind=kind_phys), parameter :: rad2dg= 180.0 / con_pi + +!> global surface emissivity index array + integer, allocatable :: idxems(:,:) +!> global surface emissivity contrl flag set up in 'sfc_init' + integer :: iemslw = 0 +! + public sfc_init, setalb, setemis + +! ================= + contains +! ================= + + +!> This subroutine is the initialization program for surface radiation +!! related quantities (albedo, emissivity, etc.) +!!\param me print control flag +!>\section gen_sfc_init General Algorithm +!! @{ +!----------------------------------- + subroutine sfc_init & + & ( me )! --- inputs: +! --- outputs: ( none ) + +! =================================================================== ! +! ! +! this program is the initialization program for surface radiation ! +! related quantities (albedo, emissivity, etc.) ! +! ! +! usage: call sfc_init ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! me - print control flag ! +! ! +! outputs: (none) to module variables only ! +! ! +! external module variables: ! +! ialbflg - control flag for surface albedo schemes ! +! =0: climatology, based on surface veg types ! +! =1: ! +! iemsflg - control flag for sfc emissivity schemes (ab:2-dig)! +! a:=0 set sfc air/ground t same for lw radiation ! +! =1 set sfc air/ground t diff for lw radiation ! +! b:=0 use fixed sfc emissivity=1.0 (black-body) ! +! =1 use varying climtology sfc emiss (veg based) ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs: + integer, intent(in) :: me + +! --- outputs: ( none ) + +! --- locals: + integer :: i, k +! integer :: ia, ja + logical :: file_exist + character :: cline*80 +! +!===> ... begin here +! + if ( me == 0 ) print *, VTAGSFC ! print out version tag + +!> - Initialization of surface albedo section +!! \n physparam::ialbflg +!! - = 0: using climatology surface albedo scheme for SW +!! - = 1: using MODIS based land surface albedo for SW + + if ( ialbflg == 0 ) then + + if ( me == 0 ) then + print *,' - Using climatology surface albedo scheme for sw' + endif + + else if ( ialbflg == 1 ) then + + if ( me == 0 ) then + print *,' - Using MODIS based land surface albedo for sw' + endif + + else + print *,' !! ERROR in Albedo Scheme Setting, IALB=',ialbflg + stop + endif ! end if_ialbflg_block + +!> - Initialization of surface emissivity section +!! \n physparam::iemsflg +!! - = 0: fixed SFC emissivity at 1.0 +!! - = 1: input SFC emissivity type map from "semis_file" + + iemslw = mod(iemsflg, 10) ! emissivity control + if ( iemslw == 0 ) then ! fixed sfc emis at 1.0 + + if ( me == 0 ) then + print *,' - Using Fixed Surface Emissivity = 1.0 for lw' + endif + + elseif ( iemslw == 1 ) then ! input sfc emiss type map + +! --- allocate data space + if ( .not. allocated(idxems) ) then + allocate ( idxems(IMXEMS,JMXEMS) ) + endif + +! --- check to see if requested emissivity data file existed + + inquire (file=semis_file, exist=file_exist) + + if ( .not. file_exist ) then + if ( me == 0 ) then + print *,' - Using Varying Surface Emissivity for lw' + print *,' Requested data file "',semis_file,'" not found!' + print *,' Change to fixed surface emissivity = 1.0 !' + endif + + iemslw = 0 + else + close(NIRADSF) + open (NIRADSF,file=semis_file,form='formatted',status='old') + rewind NIRADSF + + read (NIRADSF,12) cline + 12 format(a80) + + read (NIRADSF,14) idxems + 14 format(80i1) + + if ( me == 0 ) then + print *,' - Using Varying Surface Emissivity for lw' + print *,' Opened data file: ',semis_file + print *, cline +!check print *,' CHECK: Sample emissivity index data' +! ia = IMXEMS / 5 +! ja = JMXEMS / 5 +! print *, idxems(1:IMXEMS:ia,1:JMXEMS:ja) + endif + + close(NIRADSF) + endif ! end if_file_exist_block + + else + print *,' !! ERROR in Emissivity Scheme Setting, IEMS=',iemsflg + stop + endif ! end if_iemslw_block + +! + return +!................................... + end subroutine sfc_init +!----------------------------------- +!! @} + + +!> This subroutine computes four components of surface albedos (i.e., +!! vis-nir, direct-diffused) according to control flag ialbflg. +!! \n 1) climatological surface albedo scheme (Briegleb 1992 \cite briegleb_1992) +!! \n 2) MODIS retrieval based scheme from Boston univ. +!!\param slmsk (IMAX), sea(0),land(1),ice(2) mask on fcst model grid +!!\param snowf (IMAX), snow depth water equivalent in mm +!!\param sncovr (IMAX), snow cover over land +!!\param snoalb (IMAX), maximum snow albedo over land (for deep snow) +!!\param zorlf (IMAX), surface roughness in cm +!!\param coszf (IMAX), cosin of solar zenith angle +!!\param tsknf (IMAX), ground surface temperature in K +!!\param tairf (IMAX), lowest model layer air temperature in K +!!\param hprif (IMAX), topographic sdv in m +!!\n --- for ialbflg=0 climtological albedo scheme --- +!!\param alvsf (IMAX), 60 degree vis albedo with strong cosz dependency +!!\param alnsf (IMAX), 60 degree nir albedo with strong cosz dependency +!!\param alvwf (IMAX), 60 degree vis albedo with weak cosz dependency +!!\param alnwf (IMAX), 60 degree nir albedo with weak cosz dependency +!!\n --- for ialbflg=1 MODIS based land albedo scheme --- +!!\param alvsf (IMAX), visible black sky albedo at zenith 60 degree +!!\param alnsf (IMAX), near-ir black sky albedo at zenith 60 degree +!!\param alvwf (IMAX), visible white sky albedo +!!\param alnwf (IMAX), near-ir white sky albedo +!!\param facsf (IMAX), fractional coverage with strong cosz dependency +!!\param facwf (IMAX), fractional coverage with weak cosz dependency +!!\param fice (IMAX), sea-ice fraction +!!\param tisfc (IMAX), sea-ice surface temperature +!!\param IMAX array horizontal dimension +!!\param sfcalb (IMAX,NF_ALBD), mean sfc albedo +!!\n ( :, 1) - near ir direct beam albedo +!!\n ( :, 2) - near ir diffused albedo +!!\n ( :, 3) - uv+vis direct beam albedo +!!\n ( :, 4) - uv+vis diffused albedo +!!\section general General Algorithm +!! @{ +!----------------------------------- + subroutine setalb & + & ( slmsk,snowf,sncovr,snoalb,zorlf,coszf,tsknf,tairf,hprif, & ! --- inputs: + & alvsf,alnsf,alvwf,alnwf,facsf,facwf,fice,tisfc, & + & IMAX, & + & sfcalb & ! --- outputs: + & ) + +! =================================================================== ! +! ! +! this program computes four components of surface albedos (i.e. ! +! vis-nir, direct-diffused) according to controflag ialbflg. ! +! 1) climatological surface albedo scheme (briegleb 1992) ! +! 2) modis retrieval based scheme from boston univ. ! +! ! +! ! +! usage: call setalb ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! +! snowf (IMAX) - snow depth water equivalent in mm ! +! sncovr(IMAX) - ialgflg=0: not used ! +! ialgflg=1: snow cover over land in fraction ! +! snoalb(IMAX) - ialbflg=0: not used ! +! ialgflg=1: max snow albedo over land in fraction ! +! zorlf (IMAX) - surface roughness in cm ! +! coszf (IMAX) - cosin of solar zenith angle ! +! tsknf (IMAX) - ground surface temperature in k ! +! tairf (IMAX) - lowest model layer air temperature in k ! +! hprif (IMAX) - topographic sdv in m ! +! --- for ialbflg=0 climtological albedo scheme --- ! +! alvsf (IMAX) - 60 degree vis albedo with strong cosz dependency ! +! alnsf (IMAX) - 60 degree nir albedo with strong cosz dependency ! +! alvwf (IMAX) - 60 degree vis albedo with weak cosz dependency ! +! alnwf (IMAX) - 60 degree nir albedo with weak cosz dependency ! +! --- for ialbflg=1 modis based land albedo scheme --- ! +! alvsf (IMAX) - visible black sky albedo at zenith 60 degree ! +! alnsf (IMAX) - near-ir black sky albedo at zenith 60 degree ! +! alvwf (IMAX) - visible white sky albedo ! +! alnwf (IMAX) - near-ir white sky albedo ! +! ! +! facsf (IMAX) - fractional coverage with strong cosz dependency ! +! facwf (IMAX) - fractional coverage with weak cosz dependency ! +! fice (IMAX) - sea-ice fraction ! +! tisfc (IMAX) - sea-ice surface temperature ! +! IMAX - array horizontal dimension ! +! ! +! outputs: ! +! sfcalb(IMAX,NF_ALBD) ! +! ( :, 1) - near ir direct beam albedo ! +! ( :, 2) - near ir diffused albedo ! +! ( :, 3) - uv+vis direct beam albedo ! +! ( :, 4) - uv+vis diffused albedo ! +! ! +! module internal control variables: ! +! ialbflg - =0 use the default climatology surface albedo ! +! =1 use modis retrieved albedo and input snow cover! +! for land areas ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IMAX + + real (kind=kind_phys), dimension(:), intent(in) :: & + & slmsk, snowf, zorlf, coszf, tsknf, tairf, hprif, & + & alvsf, alnsf, alvwf, alnwf, facsf, facwf, fice, tisfc, & + & sncovr, snoalb + +! --- outputs + real (kind=kind_phys), dimension(IMAX,NF_ALBD), intent(out) :: & + & sfcalb +! real (kind=kind_phys), dimension(:,:), intent(out) :: sfcalb + +! --- locals: + real (kind=kind_phys) :: asnvb, asnnb, asnvd, asnnd, asevb & + &, asenb, asevd, asend, fsno, fsea, rfcs, rfcw, flnd & + &, asnow, argh, hrgh, fsno0, fsno1, flnd0, fsea0, csnow & + &, a1, a2, b1, b2, b3, ab1bm, ab2bm + + real (kind=kind_phys) ffw, dtgd + + integer :: i, k + +! +!===> ... begin here +! + +!> -# If use climatological albedo scheme: + if ( ialbflg == 0 ) then ! use climatological albedo scheme + + do i = 1, IMAX + +!> - Modified snow albedo scheme - units convert to m (originally +!! snowf in mm; zorlf in cm) + + asnow = 0.02*snowf(i) + argh = min(0.50, max(.025, 0.01*zorlf(i))) + hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) + fsno0 = asnow / (argh + asnow) * hrgh + if (nint(slmsk(i))==0 .and. tsknf(i)>con_tice) fsno0 = f_zero + fsno1 = f_one - fsno0 + flnd0 = min(f_one, facsf(i)+facwf(i)) + fsea0 = max(f_zero, f_one-flnd0) + fsno = fsno0 + fsea = fsea0 * fsno1 + flnd = flnd0 * fsno1 + +!> - Calculate diffused sea surface albedo + + if (tsknf(i) >= 271.5) then + asevd = 0.06 + asend = 0.06 + elseif (tsknf(i) < 271.1) then + asevd = 0.70 + asend = 0.65 + else + a1 = (tsknf(i) - 271.1)**2 + asevd = 0.7 - 4.0*a1 + asend = 0.65 - 3.6875*a1 + endif + +!> - Calculate diffused snow albedo. + + if (nint(slmsk(i)) == 2) then + ffw = f_one - fice(i) + if (ffw < f_one) then + dtgd = max(f_zero, min(5.0, (con_ttp-tisfc(i)) )) + b1 = 0.03 * dtgd + else + b1 = f_zero + endif + + b3 = 0.06 * ffw + asnvd = (0.70 + b1) * fice(i) + b3 + asnnd = (0.60 + b1) * fice(i) + b3 + asevd = 0.70 * fice(i) + b3 + asend = 0.60 * fice(i) + b3 + else + asnvd = 0.90 + asnnd = 0.75 + endif + +!> - Calculate direct snow albedo. + + if (coszf(i) < 0.5) then + csnow = 0.5 * (3.0 / (f_one+4.0*coszf(i)) - f_one) + asnvb = min( 0.98, asnvd+(1.0-asnvd)*csnow ) + asnnb = min( 0.98, asnnd+(1.0-asnnd)*csnow ) + else + asnvb = asnvd + asnnb = asnnd + endif + +!> - Calculate direct sea surface albedo. + + if (coszf(i) > 0.0001) then +! rfcs = 1.4 / (f_one + 0.8*coszf(i)) +! rfcw = 1.3 / (f_one + 0.6*coszf(i)) + rfcs = 2.14 / (f_one + 1.48*coszf(i)) + rfcw = rfcs + + if (tsknf(i) >= con_t0c) then + asevb = max(asevd, 0.026/(coszf(i)**1.7+0.065) & + & + 0.15 * (coszf(i)-0.1) * (coszf(i)-0.5) & + & * (coszf(i)-f_one)) + asenb = asevb + else + asevb = asevd + asenb = asend + endif + else + rfcs = f_one + rfcw = f_one + asevb = asevd + asenb = asend + endif + + a1 = alvsf(i) * facsf(i) + b1 = alvwf(i) * facwf(i) + a2 = alnsf(i) * facsf(i) + b2 = alnwf(i) * facwf(i) + ab1bm = a1*rfcs + b1*rfcw + ab2bm = a2*rfcs + b2*rfcw + sfcalb(i,1) = min(0.99, ab2bm) *flnd + asenb*fsea + asnnb*fsno + sfcalb(i,2) = (a2 + b2) * 0.96 *flnd + asend*fsea + asnnd*fsno + sfcalb(i,3) = min(0.99, ab1bm) *flnd + asevb*fsea + asnvb*fsno + sfcalb(i,4) = (a1 + b1) * 0.96 *flnd + asevd*fsea + asnvd*fsno + + enddo ! end_do_i_loop + +!> -# If use modis based albedo for land area: + else + + do i = 1, IMAX + +!> - Calculate snow cover input directly for land model, no +!! conversion needed. + + fsno0 = sncovr(i) + + if (nint(slmsk(i))==0 .and. tsknf(i)>con_tice) fsno0 = f_zero + + if (nint(slmsk(i)) == 2) then + asnow = 0.02*snowf(i) + argh = min(0.50, max(.025, 0.01*zorlf(i))) + hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) + fsno0 = asnow / (argh + asnow) * hrgh + endif + + fsno1 = f_one - fsno0 + flnd0 = min(f_one, facsf(i)+facwf(i)) + fsea0 = max(f_zero, f_one-flnd0) + fsno = fsno0 + fsea = fsea0 * fsno1 + flnd = flnd0 * fsno1 + +!> - Calculate diffused sea surface albedo. + + if (tsknf(i) >= 271.5) then + asevd = 0.06 + asend = 0.06 + elseif (tsknf(i) < 271.1) then + asevd = 0.70 + asend = 0.65 + else + a1 = (tsknf(i) - 271.1)**2 + asevd = 0.7 - 4.0*a1 + asend = 0.65 - 3.6875*a1 + endif + +!> - Calculate diffused snow albedo, land area use input max snow +!! albedo. + + if (nint(slmsk(i)) == 2) then + ffw = f_one - fice(i) + if (ffw < f_one) then + dtgd = max(f_zero, min(5.0, (con_ttp-tisfc(i)) )) + b1 = 0.03 * dtgd + else + b1 = f_zero + endif + + b3 = 0.06 * ffw + asnvd = (0.70 + b1) * fice(i) + b3 + asnnd = (0.60 + b1) * fice(i) + b3 + asevd = 0.70 * fice(i) + b3 + asend = 0.60 * fice(i) + b3 + else + asnvd = snoalb(i) + asnnd = snoalb(i) + endif + +!> - Calculate direct snow albedo. + + if (nint(slmsk(i)) == 2) then + if (coszf(i) < 0.5) then + csnow = 0.5 * (3.0 / (f_one+4.0*coszf(i)) - f_one) + asnvb = min( 0.98, asnvd+(f_one-asnvd)*csnow ) + asnnb = min( 0.98, asnnd+(f_one-asnnd)*csnow ) + else + asnvb = asnvd + asnnb = asnnd + endif + else + asnvb = snoalb(i) + asnnb = snoalb(i) + endif + +!> - Calculate direct sea surface albedo, use fanglin's zenith angle +!! treatment. + + if (coszf(i) > 0.0001) then + +! rfcs = 1.89 - 3.34*coszf(i) + 4.13*coszf(i)*coszf(i) & +! & - 2.02*coszf(i)*coszf(i)*coszf(i) + rfcs = 1.775/(1.0+1.55*coszf(i)) + + if (tsknf(i) >= con_t0c) then + asevb = max(asevd, 0.026/(coszf(i)**1.7+0.065) & + & + 0.15 * (coszf(i)-0.1) * (coszf(i)-0.5) & + & * (coszf(i)-f_one)) + asenb = asevb + else + asevb = asevd + asenb = asend + endif + else + rfcs = f_one + asevb = asevd + asenb = asend + endif + + ab1bm = min(0.99, alnsf(i)*rfcs) + ab2bm = min(0.99, alvsf(i)*rfcs) + sfcalb(i,1) = ab1bm *flnd + asenb*fsea + asnnb*fsno + sfcalb(i,2) = alnwf(i) *flnd + asend*fsea + asnnd*fsno + sfcalb(i,3) = ab2bm *flnd + asevb*fsea + asnvb*fsno + sfcalb(i,4) = alvwf(i) *flnd + asevd*fsea + asnvd*fsno + + enddo ! end_do_i_loop + + endif ! end if_ialbflg +! + return +!................................... + end subroutine setalb +!----------------------------------- +!! @} + +!> This subroutine computes surface emissivity for LW radiation. +!!\param xlon (IMAX), longitude in radiance, ok for both 0->2pi +!! or -pi -> +pi ranges +!!\param xlat (IMAX), latitude in radiance, default to pi/2 -> +!! -pi/2 range, otherwise see in-line comment +!!\param slmsk (IMAX), sea(0),land(1),ice(2) mask on fcst model grid +!!\param snowf (IMAX), snow depth water equivalent in mm +!!\param sncovr (IMAX), snow cover over land +!!\param zorlf (IMAX), surface roughness in cm +!!\param tsknf (IMAX), ground surface temperature in K +!!\param tairf (IMAX), lowest model layer air temperature in K +!!\param hprif (IMAX), topographic standard deviation in m +!!\param IMAX array horizontal dimension +!!\param sfcemis (IMAX), surface emissivity +!!\section general General Algorithm +!> @{ +!----------------------------------- + subroutine setemis & + & ( xlon,xlat,slmsk,snowf,sncovr,zorlf,tsknf,tairf,hprif, & ! --- inputs: + & IMAX, & + & sfcemis & ! --- outputs: + & ) + +! =================================================================== ! +! ! +! this program computes surface emissivity for lw radiation. ! +! ! +! usage: call setemis ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! xlon (IMAX) - longitude in radiance, ok for both 0->2pi or ! +! -pi -> +pi ranges ! +! xlat (IMAX) - latitude in radiance, default to pi/2 -> -pi/2 ! +! range, otherwise see in-line comment ! +! slmsk (IMAX) - sea(0),land(1),ice(2) mask on fcst model grid ! +! snowf (IMAX) - snow depth water equivalent in mm ! +! sncovr(IMAX) - ialbflg=1: snow cover over land in fraction ! +! zorlf (IMAX) - surface roughness in cm ! +! tsknf (IMAX) - ground surface temperature in k ! +! tairf (IMAX) - lowest model layer air temperature in k ! +! hprif (IMAX) - topographic sdv in m ! +! IMAX - array horizontal dimension ! +! ! +! outputs: ! +! sfcemis(IMAX) - surface emissivity ! +! ! +! ------------------------------------------------------------------- ! +! ! +! surface type definations: ! +! 1. open water 2. grass/wood/shrub land ! +! 3. tundra/bare soil 4. sandy desert ! +! 5. rocky desert 6. forest ! +! 7. ice 8. snow ! +! ! +! input index data lon from 0 towards east, lat from n to s ! +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: IMAX + + real (kind=kind_phys), dimension(:), intent(in) :: & + & xlon,xlat, slmsk, snowf,sncovr, zorlf, tsknf, tairf, hprif + +! --- outputs + real (kind=kind_phys), dimension(:), intent(out) :: sfcemis + +! --- locals: + integer :: i, i1, i2, j1, j2, idx + + real (kind=kind_phys) :: dltg, hdlt, tmp1, tmp2, & + & asnow, argh, hrgh, fsno, fsno0, fsno1 + +! --- reference emiss value for diff surface emiss index +! 1-open water, 2-grass/shrub land, 3-bare soil, tundra, +! 4-sandy desert, 5-rocky desert, 6-forest, 7-ice, 8-snow + + real (kind=kind_phys) :: emsref(8) + data emsref / 0.97, 0.95, 0.94, 0.90, 0.93, 0.96, 0.96, 0.99 / + +! +!===> ... begin here +! +!> -# Set sfcemis default to 1.0 or by surface type and condition. + if ( iemslw == 0 ) then ! sfc emiss default to 1.0 + + sfcemis(:) = f_one + return + + else ! emiss set by sfc type and condition + + dltg = 360.0 / float(IMXEMS) + hdlt = 0.5 * dltg + +! --- ... mapping input data onto model grid +! note: this is a simple mapping method, an upgrade is needed if +! the model grid is much corcer than the 1-deg data resolution + + lab_do_IMAX : do i = 1, IMAX + + if ( nint(slmsk(i)) == 0 ) then ! sea point + + sfcemis(i) = emsref(1) + + else if ( nint(slmsk(i)) == 2 ) then ! sea-ice + + sfcemis(i) = emsref(7) + + else ! land + +! --- map grid in longitude direction + i2 = 1 + j2 = 1 + + tmp1 = xlon(i) * rad2dg + if (tmp1 < f_zero) tmp1 = tmp1 + 360.0 + + lab_do_IMXEMS : do i1 = 1, IMXEMS + tmp2 = dltg * (i1 - 1) + hdlt + + if (abs(tmp1-tmp2) <= hdlt) then + i2 = i1 + exit lab_do_IMXEMS + endif + enddo lab_do_IMXEMS + +! --- map grid in latitude direction + tmp1 = xlat(i) * rad2dg ! if xlat in pi/2 -> -pi/2 range +! tmp1 = 90.0 - xlat(i)*rad2dg ! if xlat in 0 -> pi range + + lab_do_JMXEMS : do j1 = 1, JMXEMS + tmp2 = 90.0 - dltg * (j1 - 1) + + if (abs(tmp1-tmp2) <= hdlt) then + j2 = j1 + exit lab_do_JMXEMS + endif + enddo lab_do_JMXEMS + + + idx = max( 2, idxems(i2,j2) ) + if ( idx >= 7 ) idx = 2 + sfcemis(i) = emsref(idx) + + endif ! end if_slmsk_block + +!> -# Check for snow covered area. + + if ( ialbflg==1 .and. nint(slmsk(i))==1 ) then ! input land area snow cover + + fsno0 = sncovr(i) + fsno1 = f_one - fsno0 + sfcemis(i) = sfcemis(i)*fsno1 + emsref(8)*fsno0 + + else ! compute snow cover from snow depth + if ( snowf(i) > f_zero ) then + asnow = 0.02*snowf(i) + argh = min(0.50, max(.025, 0.01*zorlf(i))) + hrgh = min(f_one, max(0.20, 1.0577-1.1538e-3*hprif(i) ) ) + fsno0 = asnow / (argh + asnow) * hrgh + if (nint(slmsk(i)) == 0 .and. tsknf(i) > 271.2) & + & fsno0=f_zero + fsno1 = f_one - fsno0 + sfcemis(i) = sfcemis(i)*fsno1 + emsref(8)*fsno0 + endif + + endif ! end if_ialbflg + + enddo lab_do_IMAX + + endif ! end if_iemslw_block + +!chk print *,' In setemis, iemsflg, sfcemis =',iemsflg,sfcemis + +! + return +!................................... + end subroutine setemis +!----------------------------------- + +!> @} +! +!.........................................! + end module module_radiation_surface ! +!=========================================! +!> @} diff --git a/gsmphys/radlw_datatb.f b/gsmphys/radlw_datatb.f new file mode 100644 index 00000000..622b72b0 --- /dev/null +++ b/gsmphys/radlw_datatb.f @@ -0,0 +1,32462 @@ +!> \file radlw_datatb.f +!! This file contains the following: +!! - module_radlw_avplank (plank flux data) +!! - module_radlw_ref (reference temperature and pressure) +!! - module_radlw_cldprlw (cloud property coefficients) +!! - module_radlw_kgbnn (absorption coeffients for 16 bands, +!! where nn = 01-16) + +! ============================================================== !!!!! +! lw-rrtm3 radiation package description !!!!! +! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-lw radiation ! +! code from aer inc. ! +! ! +! the rrtm3 package includes these parts: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! the 'radlw_rrtm3_param.f' contains: ! +! ! +! 'module_radlw_parameters' -- band parameters set up ! +! ! +! the 'radlw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radlw_avplank' -- plank flux data ! +! 'module_radlw_ref' -- reference temperature and pressure ! +! 'module_radlw_cldprlw' -- cloud property coefficients ! +! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! +! bands, where nn = 01-16 ! +! ! +! the 'radlw_rrtm3_main.f' contains: ! +! ! +! 'module_radlw_main' -- main lw radiation transfer ! +! ! +! in the main module 'module_radlw_main' there are only two ! +! externally callable subroutines: ! +! ! +! 'lwrad' -- main rrtm1 lw radiation routine ! +! 'rlwinit' -- initialization routine ! +! ! +! all the lw radiation subprograms become contained subprograms ! +! in module 'module_radlw_main' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! compilation sequence is: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use lw modules ! +! ! +! ncep modifications history log: ! +! ! +! see list in program "radlw_rrtm3_main.f" ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + +!> \ingroup module_radlw_main +!> This module contains plank flux data. +!========================================! + module module_radlw_avplank ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NPLNK, NBANDS +! + implicit none +! + private + +!> plank flux data + real (kind=kind_phys), public :: totplnk(NPLNK,NBANDS) + + data totplnk( 1: 50, 1) / & + & 0.14783e-05,0.15006e-05,0.15230e-05,0.15455e-05,0.15681e-05, & + & 0.15908e-05,0.16136e-05,0.16365e-05,0.16595e-05,0.16826e-05, & + & 0.17059e-05,0.17292e-05,0.17526e-05,0.17762e-05,0.17998e-05, & + & 0.18235e-05,0.18473e-05,0.18712e-05,0.18953e-05,0.19194e-05, & + & 0.19435e-05,0.19678e-05,0.19922e-05,0.20166e-05,0.20412e-05, & + & 0.20658e-05,0.20905e-05,0.21153e-05,0.21402e-05,0.21652e-05, & + & 0.21902e-05,0.22154e-05,0.22406e-05,0.22659e-05,0.22912e-05, & + & 0.23167e-05,0.23422e-05,0.23678e-05,0.23934e-05,0.24192e-05, & + & 0.24450e-05,0.24709e-05,0.24968e-05,0.25229e-05,0.25490e-05, & + & 0.25751e-05,0.26014e-05,0.26277e-05,0.26540e-05,0.26805e-05/ + data totplnk( 51:100, 1) / & + & 0.27070e-05,0.27335e-05,0.27602e-05,0.27869e-05,0.28136e-05, & + & 0.28404e-05,0.28673e-05,0.28943e-05,0.29213e-05,0.29483e-05, & + & 0.29754e-05,0.30026e-05,0.30298e-05,0.30571e-05,0.30845e-05, & + & 0.31119e-05,0.31393e-05,0.31669e-05,0.31944e-05,0.32220e-05, & + & 0.32497e-05,0.32774e-05,0.33052e-05,0.33330e-05,0.33609e-05, & + & 0.33888e-05,0.34168e-05,0.34448e-05,0.34729e-05,0.35010e-05, & + & 0.35292e-05,0.35574e-05,0.35857e-05,0.36140e-05,0.36424e-05, & + & 0.36708e-05,0.36992e-05,0.37277e-05,0.37563e-05,0.37848e-05, & + & 0.38135e-05,0.38421e-05,0.38708e-05,0.38996e-05,0.39284e-05, & + & 0.39572e-05,0.39861e-05,0.40150e-05,0.40440e-05,0.40730e-05/ + data totplnk(101:150, 1) / & + & 0.41020e-05,0.41311e-05,0.41602e-05,0.41893e-05,0.42185e-05, & + & 0.42477e-05,0.42770e-05,0.43063e-05,0.43356e-05,0.43650e-05, & + & 0.43944e-05,0.44238e-05,0.44533e-05,0.44828e-05,0.45124e-05, & + & 0.45419e-05,0.45715e-05,0.46012e-05,0.46309e-05,0.46606e-05, & + & 0.46903e-05,0.47201e-05,0.47499e-05,0.47797e-05,0.48096e-05, & + & 0.48395e-05,0.48695e-05,0.48994e-05,0.49294e-05,0.49594e-05, & + & 0.49895e-05,0.50196e-05,0.50497e-05,0.50798e-05,0.51100e-05, & + & 0.51402e-05,0.51704e-05,0.52007e-05,0.52309e-05,0.52612e-05, & + & 0.52916e-05,0.53219e-05,0.53523e-05,0.53827e-05,0.54132e-05, & + & 0.54436e-05,0.54741e-05,0.55047e-05,0.55352e-05,0.55658e-05/ + data totplnk(151:181, 1) / & + & 0.55964e-05,0.56270e-05,0.56576e-05,0.56883e-05,0.57190e-05, & + & 0.57497e-05,0.57804e-05,0.58112e-05,0.58420e-05,0.58728e-05, & + & 0.59036e-05,0.59345e-05,0.59653e-05,0.59962e-05,0.60272e-05, & + & 0.60581e-05,0.60891e-05,0.61201e-05,0.61511e-05,0.61821e-05, & + & 0.62131e-05,0.62442e-05,0.62753e-05,0.63064e-05,0.63376e-05, & + & 0.63687e-05,0.63998e-05,0.64310e-05,0.64622e-05,0.64935e-05, & + & 0.65247e-05/ + data totplnk( 1: 50, 2) / & + & 0.20262e-05,0.20757e-05,0.21257e-05,0.21763e-05,0.22276e-05, & + & 0.22794e-05,0.23319e-05,0.23849e-05,0.24386e-05,0.24928e-05, & + & 0.25477e-05,0.26031e-05,0.26591e-05,0.27157e-05,0.27728e-05, & + & 0.28306e-05,0.28889e-05,0.29478e-05,0.30073e-05,0.30673e-05, & + & 0.31279e-05,0.31890e-05,0.32507e-05,0.33129e-05,0.33757e-05, & + & 0.34391e-05,0.35029e-05,0.35674e-05,0.36323e-05,0.36978e-05, & + & 0.37638e-05,0.38304e-05,0.38974e-05,0.39650e-05,0.40331e-05, & + & 0.41017e-05,0.41708e-05,0.42405e-05,0.43106e-05,0.43812e-05, & + & 0.44524e-05,0.45240e-05,0.45961e-05,0.46687e-05,0.47418e-05, & + & 0.48153e-05,0.48894e-05,0.49639e-05,0.50389e-05,0.51143e-05/ + data totplnk( 51:100, 2) / & + & 0.51902e-05,0.52666e-05,0.53434e-05,0.54207e-05,0.54985e-05, & + & 0.55767e-05,0.56553e-05,0.57343e-05,0.58139e-05,0.58938e-05, & + & 0.59742e-05,0.60550e-05,0.61362e-05,0.62179e-05,0.63000e-05, & + & 0.63825e-05,0.64654e-05,0.65487e-05,0.66324e-05,0.67166e-05, & + & 0.68011e-05,0.68860e-05,0.69714e-05,0.70571e-05,0.71432e-05, & + & 0.72297e-05,0.73166e-05,0.74039e-05,0.74915e-05,0.75796e-05, & + & 0.76680e-05,0.77567e-05,0.78459e-05,0.79354e-05,0.80252e-05, & + & 0.81155e-05,0.82061e-05,0.82970e-05,0.83883e-05,0.84799e-05, & + & 0.85719e-05,0.86643e-05,0.87569e-05,0.88499e-05,0.89433e-05, & + & 0.90370e-05,0.91310e-05,0.92254e-05,0.93200e-05,0.94150e-05/ + data totplnk(101:150, 2) / & + & 0.95104e-05,0.96060e-05,0.97020e-05,0.97982e-05,0.98948e-05, & + & 0.99917e-05,0.10089e-04,0.10186e-04,0.10284e-04,0.10382e-04, & + & 0.10481e-04,0.10580e-04,0.10679e-04,0.10778e-04,0.10877e-04, & + & 0.10977e-04,0.11077e-04,0.11178e-04,0.11279e-04,0.11380e-04, & + & 0.11481e-04,0.11583e-04,0.11684e-04,0.11786e-04,0.11889e-04, & + & 0.11992e-04,0.12094e-04,0.12198e-04,0.12301e-04,0.12405e-04, & + & 0.12509e-04,0.12613e-04,0.12717e-04,0.12822e-04,0.12927e-04, & + & 0.13032e-04,0.13138e-04,0.13244e-04,0.13349e-04,0.13456e-04, & + & 0.13562e-04,0.13669e-04,0.13776e-04,0.13883e-04,0.13990e-04, & + & 0.14098e-04,0.14206e-04,0.14314e-04,0.14422e-04,0.14531e-04/ + data totplnk(151:181, 2) / & + & 0.14639e-04,0.14748e-04,0.14857e-04,0.14967e-04,0.15076e-04, & + & 0.15186e-04,0.15296e-04,0.15407e-04,0.15517e-04,0.15628e-04, & + & 0.15739e-04,0.15850e-04,0.15961e-04,0.16072e-04,0.16184e-04, & + & 0.16296e-04,0.16408e-04,0.16521e-04,0.16633e-04,0.16746e-04, & + & 0.16859e-04,0.16972e-04,0.17085e-04,0.17198e-04,0.17312e-04, & + & 0.17426e-04,0.17540e-04,0.17654e-04,0.17769e-04,0.17883e-04, & + & 0.17998e-04/ + data totplnk( 1: 50, 3) / & + & 1.34822e-06,1.39134e-06,1.43530e-06,1.48010e-06,1.52574e-06, & + & 1.57222e-06,1.61956e-06,1.66774e-06,1.71678e-06,1.76666e-06, & + & 1.81741e-06,1.86901e-06,1.92147e-06,1.97479e-06,2.02898e-06, & + & 2.08402e-06,2.13993e-06,2.19671e-06,2.25435e-06,2.31285e-06, & + & 2.37222e-06,2.43246e-06,2.49356e-06,2.55553e-06,2.61837e-06, & + & 2.68207e-06,2.74664e-06,2.81207e-06,2.87837e-06,2.94554e-06, & + & 3.01356e-06,3.08245e-06,3.15221e-06,3.22282e-06,3.29429e-06, & + & 3.36662e-06,3.43982e-06,3.51386e-06,3.58876e-06,3.66451e-06, & + & 3.74112e-06,3.81857e-06,3.89688e-06,3.97602e-06,4.05601e-06, & + & 4.13685e-06,4.21852e-06,4.30104e-06,4.38438e-06,4.46857e-06/ + data totplnk( 51:100, 3) / & + & 4.55358e-06,4.63943e-06,4.72610e-06,4.81359e-06,4.90191e-06, & + & 4.99105e-06,5.08100e-06,5.17176e-06,5.26335e-06,5.35573e-06, & + & 5.44892e-06,5.54292e-06,5.63772e-06,5.73331e-06,5.82970e-06, & + & 5.92688e-06,6.02485e-06,6.12360e-06,6.22314e-06,6.32346e-06, & + & 6.42455e-06,6.52641e-06,6.62906e-06,6.73247e-06,6.83664e-06, & + & 6.94156e-06,7.04725e-06,7.15370e-06,7.26089e-06,7.36883e-06, & + & 7.47752e-06,7.58695e-06,7.69712e-06,7.80801e-06,7.91965e-06, & + & 8.03201e-06,8.14510e-06,8.25891e-06,8.37343e-06,8.48867e-06, & + & 8.60463e-06,8.72128e-06,8.83865e-06,8.95672e-06,9.07548e-06, & + & 9.19495e-06,9.31510e-06,9.43594e-06,9.55745e-06,9.67966e-06/ + data totplnk(101:150, 3) / & + & 9.80254e-06,9.92609e-06,1.00503e-05,1.01752e-05,1.03008e-05, & + & 1.04270e-05,1.05539e-05,1.06814e-05,1.08096e-05,1.09384e-05, & + & 1.10679e-05,1.11980e-05,1.13288e-05,1.14601e-05,1.15922e-05, & + & 1.17248e-05,1.18581e-05,1.19920e-05,1.21265e-05,1.22616e-05, & + & 1.23973e-05,1.25337e-05,1.26706e-05,1.28081e-05,1.29463e-05, & + & 1.30850e-05,1.32243e-05,1.33642e-05,1.35047e-05,1.36458e-05, & + & 1.37875e-05,1.39297e-05,1.40725e-05,1.42159e-05,1.43598e-05, & + & 1.45044e-05,1.46494e-05,1.47950e-05,1.49412e-05,1.50879e-05, & + & 1.52352e-05,1.53830e-05,1.55314e-05,1.56803e-05,1.58297e-05, & + & 1.59797e-05,1.61302e-05,1.62812e-05,1.64327e-05,1.65848e-05/ + data totplnk(151:181, 3) / & + & 1.67374e-05,1.68904e-05,1.70441e-05,1.71982e-05,1.73528e-05, & + & 1.75079e-05,1.76635e-05,1.78197e-05,1.79763e-05,1.81334e-05, & + & 1.82910e-05,1.84491e-05,1.86076e-05,1.87667e-05,1.89262e-05, & + & 1.90862e-05,1.92467e-05,1.94076e-05,1.95690e-05,1.97309e-05, & + & 1.98932e-05,2.00560e-05,2.02193e-05,2.03830e-05,2.05472e-05, & + & 2.07118e-05,2.08768e-05,2.10423e-05,2.12083e-05,2.13747e-05, & + & 2.15414e-05/ + data totplnk( 1: 50, 4) / & + & 8.90528e-07,9.24222e-07,9.58757e-07,9.94141e-07,1.03038e-06, & + & 1.06748e-06,1.10545e-06,1.14430e-06,1.18403e-06,1.22465e-06, & + & 1.26618e-06,1.30860e-06,1.35193e-06,1.39619e-06,1.44136e-06, & + & 1.48746e-06,1.53449e-06,1.58246e-06,1.63138e-06,1.68124e-06, & + & 1.73206e-06,1.78383e-06,1.83657e-06,1.89028e-06,1.94495e-06, & + & 2.00060e-06,2.05724e-06,2.11485e-06,2.17344e-06,2.23303e-06, & + & 2.29361e-06,2.35519e-06,2.41777e-06,2.48134e-06,2.54592e-06, & + & 2.61151e-06,2.67810e-06,2.74571e-06,2.81433e-06,2.88396e-06, & + & 2.95461e-06,3.02628e-06,3.09896e-06,3.17267e-06,3.24741e-06, & + & 3.32316e-06,3.39994e-06,3.47774e-06,3.55657e-06,3.63642e-06/ + data totplnk( 51:100, 4) / & + & 3.71731e-06,3.79922e-06,3.88216e-06,3.96612e-06,4.05112e-06, & + & 4.13714e-06,4.22419e-06,4.31227e-06,4.40137e-06,4.49151e-06, & + & 4.58266e-06,4.67485e-06,4.76806e-06,4.86229e-06,4.95754e-06, & + & 5.05383e-06,5.15113e-06,5.24946e-06,5.34879e-06,5.44916e-06, & + & 5.55053e-06,5.65292e-06,5.75632e-06,5.86073e-06,5.96616e-06, & + & 6.07260e-06,6.18003e-06,6.28848e-06,6.39794e-06,6.50838e-06, & + & 6.61983e-06,6.73229e-06,6.84573e-06,6.96016e-06,7.07559e-06, & + & 7.19200e-06,7.30940e-06,7.42779e-06,7.54715e-06,7.66749e-06, & + & 7.78882e-06,7.91110e-06,8.03436e-06,8.15859e-06,8.28379e-06, & + & 8.40994e-06,8.53706e-06,8.66515e-06,8.79418e-06,8.92416e-06/ + data totplnk(101:150, 4) / & + & 9.05510e-06,9.18697e-06,9.31979e-06,9.45356e-06,9.58826e-06, & + & 9.72389e-06,9.86046e-06,9.99793e-06,1.01364e-05,1.02757e-05, & + & 1.04159e-05,1.05571e-05,1.06992e-05,1.08422e-05,1.09861e-05, & + & 1.11309e-05,1.12766e-05,1.14232e-05,1.15707e-05,1.17190e-05, & + & 1.18683e-05,1.20184e-05,1.21695e-05,1.23214e-05,1.24741e-05, & + & 1.26277e-05,1.27822e-05,1.29376e-05,1.30939e-05,1.32509e-05, & + & 1.34088e-05,1.35676e-05,1.37273e-05,1.38877e-05,1.40490e-05, & + & 1.42112e-05,1.43742e-05,1.45380e-05,1.47026e-05,1.48680e-05, & + & 1.50343e-05,1.52014e-05,1.53692e-05,1.55379e-05,1.57074e-05, & + & 1.58778e-05,1.60488e-05,1.62207e-05,1.63934e-05,1.65669e-05/ + data totplnk(151:181, 4) / & + & 1.67411e-05,1.69162e-05,1.70920e-05,1.72685e-05,1.74459e-05, & + & 1.76240e-05,1.78029e-05,1.79825e-05,1.81629e-05,1.83440e-05, & + & 1.85259e-05,1.87086e-05,1.88919e-05,1.90760e-05,1.92609e-05, & + & 1.94465e-05,1.96327e-05,1.98199e-05,2.00076e-05,2.01961e-05, & + & 2.03853e-05,2.05752e-05,2.07658e-05,2.09571e-05,2.11491e-05, & + & 2.13418e-05,2.15352e-05,2.17294e-05,2.19241e-05,2.21196e-05, & + & 2.23158e-05/ + data totplnk( 1: 50, 5) / & + & 5.70230e-07,5.94788e-07,6.20085e-07,6.46130e-07,6.72936e-07, & + & 7.00512e-07,7.28869e-07,7.58019e-07,7.87971e-07,8.18734e-07, & + & 8.50320e-07,8.82738e-07,9.15999e-07,9.50110e-07,9.85084e-07, & + & 1.02093e-06,1.05765e-06,1.09527e-06,1.13378e-06,1.17320e-06, & + & 1.21353e-06,1.25479e-06,1.29698e-06,1.34011e-06,1.38419e-06, & + & 1.42923e-06,1.47523e-06,1.52221e-06,1.57016e-06,1.61910e-06, & + & 1.66904e-06,1.71997e-06,1.77192e-06,1.82488e-06,1.87886e-06, & + & 1.93387e-06,1.98991e-06,2.04699e-06,2.10512e-06,2.16430e-06, & + & 2.22454e-06,2.28584e-06,2.34821e-06,2.41166e-06,2.47618e-06, & + & 2.54178e-06,2.60847e-06,2.67626e-06,2.74514e-06,2.81512e-06/ + data totplnk( 51:100, 5) / & + & 2.88621e-06,2.95841e-06,3.03172e-06,3.10615e-06,3.18170e-06, & + & 3.25838e-06,3.33618e-06,3.41511e-06,3.49518e-06,3.57639e-06, & + & 3.65873e-06,3.74221e-06,3.82684e-06,3.91262e-06,3.99955e-06, & + & 4.08763e-06,4.17686e-06,4.26725e-06,4.35880e-06,4.45150e-06, & + & 4.54537e-06,4.64039e-06,4.73659e-06,4.83394e-06,4.93246e-06, & + & 5.03215e-06,5.13301e-06,5.23504e-06,5.33823e-06,5.44260e-06, & + & 5.54814e-06,5.65484e-06,5.76272e-06,5.87177e-06,5.98199e-06, & + & 6.09339e-06,6.20596e-06,6.31969e-06,6.43460e-06,6.55068e-06, & + & 6.66793e-06,6.78636e-06,6.90595e-06,7.02670e-06,7.14863e-06, & + & 7.27173e-06,7.39599e-06,7.52142e-06,7.64802e-06,7.77577e-06/ + data totplnk(101:150, 5) / & + & 7.90469e-06,8.03477e-06,8.16601e-06,8.29841e-06,8.43198e-06, & + & 8.56669e-06,8.70256e-06,8.83957e-06,8.97775e-06,9.11706e-06, & + & 9.25753e-06,9.39915e-06,9.54190e-06,9.68580e-06,9.83085e-06, & + & 9.97704e-06,1.01243e-05,1.02728e-05,1.04224e-05,1.05731e-05, & + & 1.07249e-05,1.08779e-05,1.10320e-05,1.11872e-05,1.13435e-05, & + & 1.15009e-05,1.16595e-05,1.18191e-05,1.19799e-05,1.21418e-05, & + & 1.23048e-05,1.24688e-05,1.26340e-05,1.28003e-05,1.29676e-05, & + & 1.31361e-05,1.33056e-05,1.34762e-05,1.36479e-05,1.38207e-05, & + & 1.39945e-05,1.41694e-05,1.43454e-05,1.45225e-05,1.47006e-05, & + & 1.48797e-05,1.50600e-05,1.52413e-05,1.54236e-05,1.56070e-05/ + data totplnk(151:181, 5) / & + & 1.57914e-05,1.59768e-05,1.61633e-05,1.63509e-05,1.65394e-05, & + & 1.67290e-05,1.69197e-05,1.71113e-05,1.73040e-05,1.74976e-05, & + & 1.76923e-05,1.78880e-05,1.80847e-05,1.82824e-05,1.84811e-05, & + & 1.86808e-05,1.88814e-05,1.90831e-05,1.92857e-05,1.94894e-05, & + & 1.96940e-05,1.98996e-05,2.01061e-05,2.03136e-05,2.05221e-05, & + & 2.07316e-05,2.09420e-05,2.11533e-05,2.13657e-05,2.15789e-05, & + & 2.17931e-05/ + data totplnk( 1: 50, 6) / & + & 2.73493e-07,2.87408e-07,3.01848e-07,3.16825e-07,3.32352e-07, & + & 3.48439e-07,3.65100e-07,3.82346e-07,4.00189e-07,4.18641e-07, & + & 4.37715e-07,4.57422e-07,4.77774e-07,4.98784e-07,5.20464e-07, & + & 5.42824e-07,5.65879e-07,5.89638e-07,6.14115e-07,6.39320e-07, & + & 6.65266e-07,6.91965e-07,7.19427e-07,7.47666e-07,7.76691e-07, & + & 8.06516e-07,8.37151e-07,8.68607e-07,9.00896e-07,9.34029e-07, & + & 9.68018e-07,1.00287e-06,1.03860e-06,1.07522e-06,1.11274e-06, & + & 1.15117e-06,1.19052e-06,1.23079e-06,1.27201e-06,1.31418e-06, & + & 1.35731e-06,1.40141e-06,1.44650e-06,1.49257e-06,1.53965e-06, & + & 1.58773e-06,1.63684e-06,1.68697e-06,1.73815e-06,1.79037e-06/ + data totplnk( 51:100, 6) / & + & 1.84365e-06,1.89799e-06,1.95341e-06,2.00991e-06,2.06750e-06, & + & 2.12619e-06,2.18599e-06,2.24691e-06,2.30895e-06,2.37212e-06, & + & 2.43643e-06,2.50189e-06,2.56851e-06,2.63628e-06,2.70523e-06, & + & 2.77536e-06,2.84666e-06,2.91916e-06,2.99286e-06,3.06776e-06, & + & 3.14387e-06,3.22120e-06,3.29975e-06,3.37953e-06,3.46054e-06, & + & 3.54280e-06,3.62630e-06,3.71105e-06,3.79707e-06,3.88434e-06, & + & 3.97288e-06,4.06270e-06,4.15380e-06,4.24617e-06,4.33984e-06, & + & 4.43479e-06,4.53104e-06,4.62860e-06,4.72746e-06,4.82763e-06, & + & 4.92911e-06,5.03191e-06,5.13603e-06,5.24147e-06,5.34824e-06, & + & 5.45634e-06,5.56578e-06,5.67656e-06,5.78867e-06,5.90213e-06/ + data totplnk(101:150, 6) / & + & 6.01694e-06,6.13309e-06,6.25060e-06,6.36947e-06,6.48968e-06, & + & 6.61126e-06,6.73420e-06,6.85850e-06,6.98417e-06,7.11120e-06, & + & 7.23961e-06,7.36938e-06,7.50053e-06,7.63305e-06,7.76694e-06, & + & 7.90221e-06,8.03887e-06,8.17690e-06,8.31632e-06,8.45710e-06, & + & 8.59928e-06,8.74282e-06,8.88776e-06,9.03409e-06,9.18179e-06, & + & 9.33088e-06,9.48136e-06,9.63323e-06,9.78648e-06,9.94111e-06, & + & 1.00971e-05,1.02545e-05,1.04133e-05,1.05735e-05,1.07351e-05, & + & 1.08980e-05,1.10624e-05,1.12281e-05,1.13952e-05,1.15637e-05, & + & 1.17335e-05,1.19048e-05,1.20774e-05,1.22514e-05,1.24268e-05, & + & 1.26036e-05,1.27817e-05,1.29612e-05,1.31421e-05,1.33244e-05/ + data totplnk(151:181, 6) / & + & 1.35080e-05,1.36930e-05,1.38794e-05,1.40672e-05,1.42563e-05, & + & 1.44468e-05,1.46386e-05,1.48318e-05,1.50264e-05,1.52223e-05, & + & 1.54196e-05,1.56182e-05,1.58182e-05,1.60196e-05,1.62223e-05, & + & 1.64263e-05,1.66317e-05,1.68384e-05,1.70465e-05,1.72559e-05, & + & 1.74666e-05,1.76787e-05,1.78921e-05,1.81069e-05,1.83230e-05, & + & 1.85404e-05,1.87591e-05,1.89791e-05,1.92005e-05,1.94232e-05, & + & 1.96471e-05/ + data totplnk( 1: 50, 7) / & + & 1.25349e-07,1.32735e-07,1.40458e-07,1.48527e-07,1.56954e-07, & + & 1.65748e-07,1.74920e-07,1.84481e-07,1.94443e-07,2.04814e-07, & + & 2.15608e-07,2.26835e-07,2.38507e-07,2.50634e-07,2.63229e-07, & + & 2.76301e-07,2.89864e-07,3.03930e-07,3.18508e-07,3.33612e-07, & + & 3.49253e-07,3.65443e-07,3.82195e-07,3.99519e-07,4.17428e-07, & + & 4.35934e-07,4.55050e-07,4.74785e-07,4.95155e-07,5.16170e-07, & + & 5.37844e-07,5.60186e-07,5.83211e-07,6.06929e-07,6.31355e-07, & + & 6.56498e-07,6.82373e-07,7.08990e-07,7.36362e-07,7.64501e-07, & + & 7.93420e-07,8.23130e-07,8.53643e-07,8.84971e-07,9.17128e-07, & + & 9.50123e-07,9.83969e-07,1.01868e-06,1.05426e-06,1.09073e-06/ + data totplnk( 51:100, 7) / & + & 1.12810e-06,1.16638e-06,1.20558e-06,1.24572e-06,1.28680e-06, & + & 1.32883e-06,1.37183e-06,1.41581e-06,1.46078e-06,1.50675e-06, & + & 1.55374e-06,1.60174e-06,1.65078e-06,1.70087e-06,1.75200e-06, & + & 1.80421e-06,1.85749e-06,1.91186e-06,1.96732e-06,2.02389e-06, & + & 2.08159e-06,2.14040e-06,2.20035e-06,2.26146e-06,2.32372e-06, & + & 2.38714e-06,2.45174e-06,2.51753e-06,2.58451e-06,2.65270e-06, & + & 2.72210e-06,2.79272e-06,2.86457e-06,2.93767e-06,3.01201e-06, & + & 3.08761e-06,3.16448e-06,3.24261e-06,3.32204e-06,3.40275e-06, & + & 3.48476e-06,3.56808e-06,3.65271e-06,3.73866e-06,3.82595e-06, & + & 3.91456e-06,4.00453e-06,4.09584e-06,4.18851e-06,4.28254e-06/ + data totplnk(101:150, 7) / & + & 4.37796e-06,4.47475e-06,4.57293e-06,4.67249e-06,4.77346e-06, & + & 4.87583e-06,4.97961e-06,5.08481e-06,5.19143e-06,5.29948e-06, & + & 5.40896e-06,5.51989e-06,5.63226e-06,5.74608e-06,5.86136e-06, & + & 5.97810e-06,6.09631e-06,6.21597e-06,6.33713e-06,6.45976e-06, & + & 6.58388e-06,6.70950e-06,6.83661e-06,6.96521e-06,7.09531e-06, & + & 7.22692e-06,7.36005e-06,7.49468e-06,7.63084e-06,7.76851e-06, & + & 7.90773e-06,8.04846e-06,8.19072e-06,8.33452e-06,8.47985e-06, & + & 8.62674e-06,8.77517e-06,8.92514e-06,9.07666e-06,9.22975e-06, & + & 9.38437e-06,9.54057e-06,9.69832e-06,9.85762e-06,1.00185e-05, & + & 1.01810e-05,1.03450e-05,1.05106e-05,1.06777e-05,1.08465e-05/ + data totplnk(151:181, 7) / & + & 1.10168e-05,1.11887e-05,1.13621e-05,1.15372e-05,1.17138e-05, & + & 1.18920e-05,1.20718e-05,1.22532e-05,1.24362e-05,1.26207e-05, & + & 1.28069e-05,1.29946e-05,1.31839e-05,1.33749e-05,1.35674e-05, & + & 1.37615e-05,1.39572e-05,1.41544e-05,1.43533e-05,1.45538e-05, & + & 1.47558e-05,1.49595e-05,1.51647e-05,1.53716e-05,1.55800e-05, & + & 1.57900e-05,1.60017e-05,1.62149e-05,1.64296e-05,1.66460e-05, & + & 1.68640e-05/ + data totplnk( 1: 50, 8) / & + & 6.74445e-08,7.18176e-08,7.64153e-08,8.12456e-08,8.63170e-08, & + & 9.16378e-08,9.72168e-08,1.03063e-07,1.09184e-07,1.15591e-07, & + & 1.22292e-07,1.29296e-07,1.36613e-07,1.44253e-07,1.52226e-07, & + & 1.60540e-07,1.69207e-07,1.78236e-07,1.87637e-07,1.97421e-07, & + & 2.07599e-07,2.18181e-07,2.29177e-07,2.40598e-07,2.52456e-07, & + & 2.64761e-07,2.77523e-07,2.90755e-07,3.04468e-07,3.18673e-07, & + & 3.33381e-07,3.48603e-07,3.64352e-07,3.80638e-07,3.97474e-07, & + & 4.14871e-07,4.32841e-07,4.51395e-07,4.70547e-07,4.90306e-07, & + & 5.10687e-07,5.31699e-07,5.53357e-07,5.75670e-07,5.98652e-07, & + & 6.22315e-07,6.46672e-07,6.71731e-07,6.97511e-07,7.24018e-07/ + data totplnk( 51:100, 8) / & + & 7.51266e-07,7.79269e-07,8.08038e-07,8.37584e-07,8.67922e-07, & + & 8.99061e-07,9.31016e-07,9.63797e-07,9.97417e-07,1.03189e-06, & + & 1.06722e-06,1.10343e-06,1.14053e-06,1.17853e-06,1.21743e-06, & + & 1.25726e-06,1.29803e-06,1.33974e-06,1.38241e-06,1.42606e-06, & + & 1.47068e-06,1.51630e-06,1.56293e-06,1.61056e-06,1.65924e-06, & + & 1.70894e-06,1.75971e-06,1.81153e-06,1.86443e-06,1.91841e-06, & + & 1.97350e-06,2.02968e-06,2.08699e-06,2.14543e-06,2.20500e-06, & + & 2.26573e-06,2.32762e-06,2.39068e-06,2.45492e-06,2.52036e-06, & + & 2.58700e-06,2.65485e-06,2.72393e-06,2.79424e-06,2.86580e-06, & + & 2.93861e-06,3.01269e-06,3.08803e-06,3.16467e-06,3.24259e-06/ + data totplnk(101:150, 8) / & + & 3.32181e-06,3.40235e-06,3.48420e-06,3.56739e-06,3.65192e-06, & + & 3.73779e-06,3.82502e-06,3.91362e-06,4.00359e-06,4.09494e-06, & + & 4.18768e-06,4.28182e-06,4.37737e-06,4.47434e-06,4.57273e-06, & + & 4.67254e-06,4.77380e-06,4.87651e-06,4.98067e-06,5.08630e-06, & + & 5.19339e-06,5.30196e-06,5.41201e-06,5.52356e-06,5.63660e-06, & + & 5.75116e-06,5.86722e-06,5.98479e-06,6.10390e-06,6.22453e-06, & + & 6.34669e-06,6.47042e-06,6.59569e-06,6.72252e-06,6.85090e-06, & + & 6.98085e-06,7.11238e-06,7.24549e-06,7.38019e-06,7.51646e-06, & + & 7.65434e-06,7.79382e-06,7.93490e-06,8.07760e-06,8.22192e-06, & + & 8.36784e-06,8.51540e-06,8.66459e-06,8.81542e-06,8.96786e-06/ + data totplnk(151:181, 8) / & + & 9.12197e-06,9.27772e-06,9.43513e-06,9.59419e-06,9.75490e-06, & + & 9.91728e-06,1.00813e-05,1.02471e-05,1.04144e-05,1.05835e-05, & + & 1.07543e-05,1.09267e-05,1.11008e-05,1.12766e-05,1.14541e-05, & + & 1.16333e-05,1.18142e-05,1.19969e-05,1.21812e-05,1.23672e-05, & + & 1.25549e-05,1.27443e-05,1.29355e-05,1.31284e-05,1.33229e-05, & + & 1.35193e-05,1.37173e-05,1.39170e-05,1.41185e-05,1.43217e-05, & + & 1.45267e-05/ + data totplnk( 1: 50, 9) / & + & 2.61522e-08,2.80613e-08,3.00838e-08,3.22250e-08,3.44899e-08, & + & 3.68841e-08,3.94129e-08,4.20820e-08,4.48973e-08,4.78646e-08, & + & 5.09901e-08,5.42799e-08,5.77405e-08,6.13784e-08,6.52001e-08, & + & 6.92126e-08,7.34227e-08,7.78375e-08,8.24643e-08,8.73103e-08, & + & 9.23832e-08,9.76905e-08,1.03240e-07,1.09039e-07,1.15097e-07, & + & 1.21421e-07,1.28020e-07,1.34902e-07,1.42075e-07,1.49548e-07, & + & 1.57331e-07,1.65432e-07,1.73860e-07,1.82624e-07,1.91734e-07, & + & 2.01198e-07,2.11028e-07,2.21231e-07,2.31818e-07,2.42799e-07, & + & 2.54184e-07,2.65983e-07,2.78205e-07,2.90862e-07,3.03963e-07, & + & 3.17519e-07,3.31541e-07,3.46039e-07,3.61024e-07,3.76507e-07/ + data totplnk( 51:100, 9) / & + & 3.92498e-07,4.09008e-07,4.26050e-07,4.43633e-07,4.61769e-07, & + & 4.80469e-07,4.99744e-07,5.19606e-07,5.40067e-07,5.61136e-07, & + & 5.82828e-07,6.05152e-07,6.28120e-07,6.51745e-07,6.76038e-07, & + & 7.01010e-07,7.26674e-07,7.53041e-07,7.80124e-07,8.07933e-07, & + & 8.36482e-07,8.65781e-07,8.95845e-07,9.26683e-07,9.58308e-07, & + & 9.90732e-07,1.02397e-06,1.05803e-06,1.09292e-06,1.12866e-06, & + & 1.16526e-06,1.20274e-06,1.24109e-06,1.28034e-06,1.32050e-06, & + & 1.36158e-06,1.40359e-06,1.44655e-06,1.49046e-06,1.53534e-06, & + & 1.58120e-06,1.62805e-06,1.67591e-06,1.72478e-06,1.77468e-06, & + & 1.82561e-06,1.87760e-06,1.93066e-06,1.98479e-06,2.04000e-06/ + data totplnk(101:150, 9) / & + & 2.09631e-06,2.15373e-06,2.21228e-06,2.27196e-06,2.33278e-06, & + & 2.39475e-06,2.45790e-06,2.52222e-06,2.58773e-06,2.65445e-06, & + & 2.72238e-06,2.79152e-06,2.86191e-06,2.93354e-06,3.00643e-06, & + & 3.08058e-06,3.15601e-06,3.23273e-06,3.31075e-06,3.39009e-06, & + & 3.47074e-06,3.55272e-06,3.63605e-06,3.72072e-06,3.80676e-06, & + & 3.89417e-06,3.98297e-06,4.07315e-06,4.16474e-06,4.25774e-06, & + & 4.35217e-06,4.44802e-06,4.54532e-06,4.64406e-06,4.74428e-06, & + & 4.84595e-06,4.94911e-06,5.05376e-06,5.15990e-06,5.26755e-06, & + & 5.37671e-06,5.48741e-06,5.59963e-06,5.71340e-06,5.82871e-06, & + & 5.94559e-06,6.06403e-06,6.18404e-06,6.30565e-06,6.42885e-06/ + data totplnk(151:181, 9) / & + & 6.55364e-06,6.68004e-06,6.80806e-06,6.93771e-06,7.06898e-06, & + & 7.20190e-06,7.33646e-06,7.47267e-06,7.61056e-06,7.75010e-06, & + & 7.89133e-06,8.03423e-06,8.17884e-06,8.32514e-06,8.47314e-06, & + & 8.62284e-06,8.77427e-06,8.92743e-06,9.08231e-06,9.23893e-06, & + & 9.39729e-06,9.55741e-06,9.71927e-06,9.88291e-06,1.00483e-05, & + & 1.02155e-05,1.03844e-05,1.05552e-05,1.07277e-05,1.09020e-05, & + & 1.10781e-05/ + data totplnk( 1: 50,10) / & + & 8.89300e-09,9.63263e-09,1.04235e-08,1.12685e-08,1.21703e-08, & + & 1.31321e-08,1.41570e-08,1.52482e-08,1.64090e-08,1.76428e-08, & + & 1.89533e-08,2.03441e-08,2.18190e-08,2.33820e-08,2.50370e-08, & + & 2.67884e-08,2.86402e-08,3.05969e-08,3.26632e-08,3.48436e-08, & + & 3.71429e-08,3.95660e-08,4.21179e-08,4.48040e-08,4.76294e-08, & + & 5.05996e-08,5.37201e-08,5.69966e-08,6.04349e-08,6.40411e-08, & + & 6.78211e-08,7.17812e-08,7.59276e-08,8.02670e-08,8.48059e-08, & + & 8.95508e-08,9.45090e-08,9.96873e-08,1.05093e-07,1.10733e-07, & + & 1.16614e-07,1.22745e-07,1.29133e-07,1.35786e-07,1.42711e-07, & + & 1.49916e-07,1.57410e-07,1.65202e-07,1.73298e-07,1.81709e-07/ + data totplnk( 51:100,10) / & + & 1.90441e-07,1.99505e-07,2.08908e-07,2.18660e-07,2.28770e-07, & + & 2.39247e-07,2.50101e-07,2.61340e-07,2.72974e-07,2.85013e-07, & + & 2.97467e-07,3.10345e-07,3.23657e-07,3.37413e-07,3.51623e-07, & + & 3.66298e-07,3.81448e-07,3.97082e-07,4.13212e-07,4.29848e-07, & + & 4.47000e-07,4.64680e-07,4.82898e-07,5.01664e-07,5.20991e-07, & + & 5.40888e-07,5.61369e-07,5.82440e-07,6.04118e-07,6.26410e-07, & + & 6.49329e-07,6.72887e-07,6.97095e-07,7.21964e-07,7.47506e-07, & + & 7.73732e-07,8.00655e-07,8.28287e-07,8.56635e-07,8.85717e-07, & + & 9.15542e-07,9.46122e-07,9.77469e-07,1.00960e-06,1.04251e-06, & + & 1.07623e-06,1.11077e-06,1.14613e-06,1.18233e-06,1.21939e-06/ + data totplnk(101:150,10) / & + & 1.25730e-06,1.29610e-06,1.33578e-06,1.37636e-06,1.41785e-06, & + & 1.46027e-06,1.50362e-06,1.54792e-06,1.59319e-06,1.63942e-06, & + & 1.68665e-06,1.73487e-06,1.78410e-06,1.83435e-06,1.88564e-06, & + & 1.93797e-06,1.99136e-06,2.04582e-06,2.10137e-06,2.15801e-06, & + & 2.21576e-06,2.27463e-06,2.33462e-06,2.39577e-06,2.45806e-06, & + & 2.52153e-06,2.58617e-06,2.65201e-06,2.71905e-06,2.78730e-06, & + & 2.85678e-06,2.92749e-06,2.99946e-06,3.07269e-06,3.14720e-06, & + & 3.22299e-06,3.30007e-06,3.37847e-06,3.45818e-06,3.53923e-06, & + & 3.62161e-06,3.70535e-06,3.79046e-06,3.87695e-06,3.96481e-06, & + & 4.05409e-06,4.14477e-06,4.23687e-06,4.33040e-06,4.42538e-06/ + data totplnk(151:181,10) / & + & 4.52180e-06,4.61969e-06,4.71905e-06,4.81991e-06,4.92226e-06, & + & 5.02611e-06,5.13148e-06,5.23839e-06,5.34681e-06,5.45681e-06, & + & 5.56835e-06,5.68146e-06,5.79614e-06,5.91242e-06,6.03030e-06, & + & 6.14978e-06,6.27088e-06,6.39360e-06,6.51798e-06,6.64398e-06, & + & 6.77165e-06,6.90099e-06,7.03198e-06,7.16468e-06,7.29906e-06, & + & 7.43514e-06,7.57294e-06,7.71244e-06,7.85369e-06,7.99666e-06, & + & 8.14138e-06/ + data totplnk( 1: 50,11) / & + & 2.53767e-09,2.77242e-09,3.02564e-09,3.29851e-09,3.59228e-09, & + & 3.90825e-09,4.24777e-09,4.61227e-09,5.00322e-09,5.42219e-09, & + & 5.87080e-09,6.35072e-09,6.86370e-09,7.41159e-09,7.99628e-09, & + & 8.61974e-09,9.28404e-09,9.99130e-09,1.07437e-08,1.15436e-08, & + & 1.23933e-08,1.32953e-08,1.42522e-08,1.52665e-08,1.63410e-08, & + & 1.74786e-08,1.86820e-08,1.99542e-08,2.12985e-08,2.27179e-08, & + & 2.42158e-08,2.57954e-08,2.74604e-08,2.92141e-08,3.10604e-08, & + & 3.30029e-08,3.50457e-08,3.71925e-08,3.94476e-08,4.18149e-08, & + & 4.42991e-08,4.69043e-08,4.96352e-08,5.24961e-08,5.54921e-08, & + & 5.86277e-08,6.19081e-08,6.53381e-08,6.89231e-08,7.26681e-08/ + data totplnk( 51:100,11) / & + & 7.65788e-08,8.06604e-08,8.49187e-08,8.93591e-08,9.39879e-08, & + & 9.88106e-08,1.03834e-07,1.09063e-07,1.14504e-07,1.20165e-07, & + & 1.26051e-07,1.32169e-07,1.38525e-07,1.45128e-07,1.51982e-07, & + & 1.59096e-07,1.66477e-07,1.74132e-07,1.82068e-07,1.90292e-07, & + & 1.98813e-07,2.07638e-07,2.16775e-07,2.26231e-07,2.36015e-07, & + & 2.46135e-07,2.56599e-07,2.67415e-07,2.78592e-07,2.90137e-07, & + & 3.02061e-07,3.14371e-07,3.27077e-07,3.40186e-07,3.53710e-07, & + & 3.67655e-07,3.82031e-07,3.96848e-07,4.12116e-07,4.27842e-07, & + & 4.44039e-07,4.60713e-07,4.77876e-07,4.95537e-07,5.13706e-07, & + & 5.32392e-07,5.51608e-07,5.71360e-07,5.91662e-07,6.12521e-07/ + data totplnk(101:150,11) / & + & 6.33950e-07,6.55958e-07,6.78556e-07,7.01753e-07,7.25562e-07, & + & 7.49992e-07,7.75055e-07,8.00760e-07,8.27120e-07,8.54145e-07, & + & 8.81845e-07,9.10233e-07,9.39318e-07,9.69113e-07,9.99627e-07, & + & 1.03087e-06,1.06286e-06,1.09561e-06,1.12912e-06,1.16340e-06, & + & 1.19848e-06,1.23435e-06,1.27104e-06,1.30855e-06,1.34690e-06, & + & 1.38609e-06,1.42614e-06,1.46706e-06,1.50886e-06,1.55155e-06, & + & 1.59515e-06,1.63967e-06,1.68512e-06,1.73150e-06,1.77884e-06, & + & 1.82715e-06,1.87643e-06,1.92670e-06,1.97797e-06,2.03026e-06, & + & 2.08356e-06,2.13791e-06,2.19330e-06,2.24975e-06,2.30728e-06, & + & 2.36589e-06,2.42560e-06,2.48641e-06,2.54835e-06,2.61142e-06/ + data totplnk(151:181,11) / & + & 2.67563e-06,2.74100e-06,2.80754e-06,2.87526e-06,2.94417e-06, & + & 3.01429e-06,3.08562e-06,3.15819e-06,3.23199e-06,3.30704e-06, & + & 3.38336e-06,3.46096e-06,3.53984e-06,3.62002e-06,3.70151e-06, & + & 3.78433e-06,3.86848e-06,3.95399e-06,4.04084e-06,4.12907e-06, & + & 4.21868e-06,4.30968e-06,4.40209e-06,4.49592e-06,4.59117e-06, & + & 4.68786e-06,4.78600e-06,4.88561e-06,4.98669e-06,5.08926e-06, & + & 5.19332e-06/ + data totplnk( 1: 50,12) / & + & 2.73921e-10,3.04500e-10,3.38056e-10,3.74835e-10,4.15099e-10, & + & 4.59126e-10,5.07214e-10,5.59679e-10,6.16857e-10,6.79103e-10, & + & 7.46796e-10,8.20335e-10,9.00144e-10,9.86671e-10,1.08039e-09, & + & 1.18180e-09,1.29142e-09,1.40982e-09,1.53757e-09,1.67529e-09, & + & 1.82363e-09,1.98327e-09,2.15492e-09,2.33932e-09,2.53726e-09, & + & 2.74957e-09,2.97710e-09,3.22075e-09,3.48145e-09,3.76020e-09, & + & 4.05801e-09,4.37595e-09,4.71513e-09,5.07672e-09,5.46193e-09, & + & 5.87201e-09,6.30827e-09,6.77205e-09,7.26480e-09,7.78794e-09, & + & 8.34304e-09,8.93163e-09,9.55537e-09,1.02159e-08,1.09151e-08, & + & 1.16547e-08,1.24365e-08,1.32625e-08,1.41348e-08,1.50554e-08/ + data totplnk( 51:100,12) / & + & 1.60264e-08,1.70500e-08,1.81285e-08,1.92642e-08,2.04596e-08, & + & 2.17171e-08,2.30394e-08,2.44289e-08,2.58885e-08,2.74209e-08, & + & 2.90290e-08,3.07157e-08,3.24841e-08,3.43371e-08,3.62782e-08, & + & 3.83103e-08,4.04371e-08,4.26617e-08,4.49878e-08,4.74190e-08, & + & 4.99589e-08,5.26113e-08,5.53801e-08,5.82692e-08,6.12826e-08, & + & 6.44245e-08,6.76991e-08,7.11105e-08,7.46634e-08,7.83621e-08, & + & 8.22112e-08,8.62154e-08,9.03795e-08,9.47081e-08,9.92066e-08, & + & 1.03879e-07,1.08732e-07,1.13770e-07,1.18998e-07,1.24422e-07, & + & 1.30048e-07,1.35880e-07,1.41924e-07,1.48187e-07,1.54675e-07, & + & 1.61392e-07,1.68346e-07,1.75543e-07,1.82988e-07,1.90688e-07/ + data totplnk(101:150,12) / & + & 1.98650e-07,2.06880e-07,2.15385e-07,2.24172e-07,2.33247e-07, & + & 2.42617e-07,2.52289e-07,2.62272e-07,2.72571e-07,2.83193e-07, & + & 2.94147e-07,3.05440e-07,3.17080e-07,3.29074e-07,3.41430e-07, & + & 3.54155e-07,3.67259e-07,3.80747e-07,3.94631e-07,4.08916e-07, & + & 4.23611e-07,4.38725e-07,4.54267e-07,4.70245e-07,4.86666e-07, & + & 5.03541e-07,5.20879e-07,5.38687e-07,5.56975e-07,5.75751e-07, & + & 5.95026e-07,6.14808e-07,6.35107e-07,6.55932e-07,6.77293e-07, & + & 6.99197e-07,7.21656e-07,7.44681e-07,7.68278e-07,7.92460e-07, & + & 8.17235e-07,8.42614e-07,8.68606e-07,8.95223e-07,9.22473e-07, & + & 9.50366e-07,9.78915e-07,1.00813e-06,1.03802e-06,1.06859e-06/ + data totplnk(151:181,12) / & + & 1.09986e-06,1.13184e-06,1.16453e-06,1.19796e-06,1.23212e-06, & + & 1.26703e-06,1.30270e-06,1.33915e-06,1.37637e-06,1.41440e-06, & + & 1.45322e-06,1.49286e-06,1.53333e-06,1.57464e-06,1.61679e-06, & + & 1.65981e-06,1.70370e-06,1.74847e-06,1.79414e-06,1.84071e-06, & + & 1.88821e-06,1.93663e-06,1.98599e-06,2.03631e-06,2.08759e-06, & + & 2.13985e-06,2.19310e-06,2.24734e-06,2.30260e-06,2.35888e-06, & + & 2.41619e-06/ + data totplnk( 1: 50,13) / & + & 4.53634e-11,5.11435e-11,5.75754e-11,6.47222e-11,7.26531e-11, & + & 8.14420e-11,9.11690e-11,1.01921e-10,1.13790e-10,1.26877e-10, & + & 1.41288e-10,1.57140e-10,1.74555e-10,1.93665e-10,2.14613e-10, & + & 2.37548e-10,2.62633e-10,2.90039e-10,3.19948e-10,3.52558e-10, & + & 3.88073e-10,4.26716e-10,4.68719e-10,5.14331e-10,5.63815e-10, & + & 6.17448e-10,6.75526e-10,7.38358e-10,8.06277e-10,8.79625e-10, & + & 9.58770e-10,1.04410e-09,1.13602e-09,1.23495e-09,1.34135e-09, & + & 1.45568e-09,1.57845e-09,1.71017e-09,1.85139e-09,2.00268e-09, & + & 2.16464e-09,2.33789e-09,2.52309e-09,2.72093e-09,2.93212e-09, & + & 3.15740e-09,3.39757e-09,3.65341e-09,3.92579e-09,4.21559e-09/ + data totplnk( 51:100,13) / & + & 4.52372e-09,4.85115e-09,5.19886e-09,5.56788e-09,5.95928e-09, & + & 6.37419e-09,6.81375e-09,7.27917e-09,7.77168e-09,8.29256e-09, & + & 8.84317e-09,9.42487e-09,1.00391e-08,1.06873e-08,1.13710e-08, & + & 1.20919e-08,1.28515e-08,1.36514e-08,1.44935e-08,1.53796e-08, & + & 1.63114e-08,1.72909e-08,1.83201e-08,1.94008e-08,2.05354e-08, & + & 2.17258e-08,2.29742e-08,2.42830e-08,2.56545e-08,2.70910e-08, & + & 2.85950e-08,3.01689e-08,3.18155e-08,3.35373e-08,3.53372e-08, & + & 3.72177e-08,3.91818e-08,4.12325e-08,4.33727e-08,4.56056e-08, & + & 4.79342e-08,5.03617e-08,5.28915e-08,5.55270e-08,5.82715e-08, & + & 6.11286e-08,6.41019e-08,6.71951e-08,7.04119e-08,7.37560e-08/ + data totplnk(101:150,13) / & + & 7.72315e-08,8.08424e-08,8.45927e-08,8.84866e-08,9.25281e-08, & + & 9.67218e-08,1.01072e-07,1.05583e-07,1.10260e-07,1.15107e-07, & + & 1.20128e-07,1.25330e-07,1.30716e-07,1.36291e-07,1.42061e-07, & + & 1.48031e-07,1.54206e-07,1.60592e-07,1.67192e-07,1.74015e-07, & + & 1.81064e-07,1.88345e-07,1.95865e-07,2.03628e-07,2.11643e-07, & + & 2.19912e-07,2.28443e-07,2.37244e-07,2.46318e-07,2.55673e-07, & + & 2.65316e-07,2.75252e-07,2.85489e-07,2.96033e-07,3.06891e-07, & + & 3.18070e-07,3.29576e-07,3.41417e-07,3.53600e-07,3.66133e-07, & + & 3.79021e-07,3.92274e-07,4.05897e-07,4.19899e-07,4.34288e-07, & + & 4.49071e-07,4.64255e-07,4.79850e-07,4.95863e-07,5.12300e-07/ + data totplnk(151:181,13) / & + & 5.29172e-07,5.46486e-07,5.64250e-07,5.82473e-07,6.01164e-07, & + & 6.20329e-07,6.39979e-07,6.60122e-07,6.80767e-07,7.01922e-07, & + & 7.23596e-07,7.45800e-07,7.68539e-07,7.91826e-07,8.15669e-07, & + & 8.40076e-07,8.65058e-07,8.90623e-07,9.16783e-07,9.43544e-07, & + & 9.70917e-07,9.98912e-07,1.02754e-06,1.05681e-06,1.08673e-06, & + & 1.11731e-06,1.14856e-06,1.18050e-06,1.21312e-06,1.24645e-06, & + & 1.28049e-06/ + data totplnk( 1: 50,14) / & + & 1.40113e-11,1.59358e-11,1.80960e-11,2.05171e-11,2.32266e-11, & + & 2.62546e-11,2.96335e-11,3.33990e-11,3.75896e-11,4.22469e-11, & + & 4.74164e-11,5.31466e-11,5.94905e-11,6.65054e-11,7.42522e-11, & + & 8.27975e-11,9.22122e-11,1.02573e-10,1.13961e-10,1.26466e-10, & + & 1.40181e-10,1.55206e-10,1.71651e-10,1.89630e-10,2.09265e-10, & + & 2.30689e-10,2.54040e-10,2.79467e-10,3.07128e-10,3.37190e-10, & + & 3.69833e-10,4.05243e-10,4.43623e-10,4.85183e-10,5.30149e-10, & + & 5.78755e-10,6.31255e-10,6.87910e-10,7.49002e-10,8.14824e-10, & + & 8.85687e-10,9.61914e-10,1.04385e-09,1.13186e-09,1.22631e-09, & + & 1.32761e-09,1.43617e-09,1.55243e-09,1.67686e-09,1.80992e-09/ + data totplnk( 51:100,14) / & + & 1.95212e-09,2.10399e-09,2.26607e-09,2.43895e-09,2.62321e-09, & + & 2.81949e-09,3.02844e-09,3.25073e-09,3.48707e-09,3.73820e-09, & + & 4.00490e-09,4.28794e-09,4.58819e-09,4.90647e-09,5.24371e-09, & + & 5.60081e-09,5.97875e-09,6.37854e-09,6.80120e-09,7.24782e-09, & + & 7.71950e-09,8.21740e-09,8.74271e-09,9.29666e-09,9.88054e-09, & + & 1.04956e-08,1.11434e-08,1.18251e-08,1.25422e-08,1.32964e-08, & + & 1.40890e-08,1.49217e-08,1.57961e-08,1.67140e-08,1.76771e-08, & + & 1.86870e-08,1.97458e-08,2.08553e-08,2.20175e-08,2.32342e-08, & + & 2.45077e-08,2.58401e-08,2.72334e-08,2.86900e-08,3.02122e-08, & + & 3.18021e-08,3.34624e-08,3.51954e-08,3.70037e-08,3.88899e-08/ + data totplnk(101:150,14) / & + & 4.08568e-08,4.29068e-08,4.50429e-08,4.72678e-08,4.95847e-08, & + & 5.19963e-08,5.45058e-08,5.71161e-08,5.98309e-08,6.26529e-08, & + & 6.55857e-08,6.86327e-08,7.17971e-08,7.50829e-08,7.84933e-08, & + & 8.20323e-08,8.57035e-08,8.95105e-08,9.34579e-08,9.75488e-08, & + & 1.01788e-07,1.06179e-07,1.10727e-07,1.15434e-07,1.20307e-07, & + & 1.25350e-07,1.30566e-07,1.35961e-07,1.41539e-07,1.47304e-07, & + & 1.53263e-07,1.59419e-07,1.65778e-07,1.72345e-07,1.79124e-07, & + & 1.86122e-07,1.93343e-07,2.00792e-07,2.08476e-07,2.16400e-07, & + & 2.24568e-07,2.32988e-07,2.41666e-07,2.50605e-07,2.59813e-07, & + & 2.69297e-07,2.79060e-07,2.89111e-07,2.99455e-07,3.10099e-07/ + data totplnk(151:181,14) / & + & 3.21049e-07,3.32311e-07,3.43893e-07,3.55801e-07,3.68041e-07, & + & 3.80621e-07,3.93547e-07,4.06826e-07,4.20465e-07,4.34473e-07, & + & 4.48856e-07,4.63620e-07,4.78774e-07,4.94325e-07,5.10280e-07, & + & 5.26648e-07,5.43436e-07,5.60652e-07,5.78302e-07,5.96397e-07, & + & 6.14943e-07,6.33949e-07,6.53421e-07,6.73370e-07,6.93803e-07, & + & 7.14731e-07,7.36157e-07,7.58095e-07,7.80549e-07,8.03533e-07, & + & 8.27050e-07/ + data totplnk( 1: 50,15) / & + & 3.90483e-12,4.47999e-12,5.13122e-12,5.86739e-12,6.69829e-12, & + & 7.63467e-12,8.68833e-12,9.87221e-12,1.12005e-11,1.26885e-11, & + & 1.43534e-11,1.62134e-11,1.82888e-11,2.06012e-11,2.31745e-11, & + & 2.60343e-11,2.92087e-11,3.27277e-11,3.66242e-11,4.09334e-11, & + & 4.56935e-11,5.09455e-11,5.67338e-11,6.31057e-11,7.01127e-11, & + & 7.78096e-11,8.62554e-11,9.55130e-11,1.05651e-10,1.16740e-10, & + & 1.28858e-10,1.42089e-10,1.56519e-10,1.72243e-10,1.89361e-10, & + & 2.07978e-10,2.28209e-10,2.50173e-10,2.73999e-10,2.99820e-10, & + & 3.27782e-10,3.58034e-10,3.90739e-10,4.26067e-10,4.64196e-10, & + & 5.05317e-10,5.49631e-10,5.97347e-10,6.48689e-10,7.03891e-10/ + data totplnk( 51:100,15) / & + & 7.63201e-10,8.26876e-10,8.95192e-10,9.68430e-10,1.04690e-09, & + & 1.13091e-09,1.22079e-09,1.31689e-09,1.41957e-09,1.52922e-09, & + & 1.64623e-09,1.77101e-09,1.90401e-09,2.04567e-09,2.19647e-09, & + & 2.35690e-09,2.52749e-09,2.70875e-09,2.90127e-09,3.10560e-09, & + & 3.32238e-09,3.55222e-09,3.79578e-09,4.05375e-09,4.32682e-09, & + & 4.61574e-09,4.92128e-09,5.24420e-09,5.58536e-09,5.94558e-09, & + & 6.32575e-09,6.72678e-09,7.14964e-09,7.59526e-09,8.06470e-09, & + & 8.55897e-09,9.07916e-09,9.62638e-09,1.02018e-08,1.08066e-08, & + & 1.14420e-08,1.21092e-08,1.28097e-08,1.35446e-08,1.43155e-08, & + & 1.51237e-08,1.59708e-08,1.68581e-08,1.77873e-08,1.87599e-08/ + data totplnk(101:150,15) / & + & 1.97777e-08,2.08423e-08,2.19555e-08,2.31190e-08,2.43348e-08, & + & 2.56045e-08,2.69302e-08,2.83140e-08,2.97578e-08,3.12636e-08, & + & 3.28337e-08,3.44702e-08,3.61755e-08,3.79516e-08,3.98012e-08, & + & 4.17265e-08,4.37300e-08,4.58143e-08,4.79819e-08,5.02355e-08, & + & 5.25777e-08,5.50114e-08,5.75393e-08,6.01644e-08,6.28896e-08, & + & 6.57177e-08,6.86521e-08,7.16959e-08,7.48520e-08,7.81239e-08, & + & 8.15148e-08,8.50282e-08,8.86675e-08,9.24362e-08,9.63380e-08, & + & 1.00376e-07,1.04555e-07,1.08878e-07,1.13349e-07,1.17972e-07, & + & 1.22751e-07,1.27690e-07,1.32793e-07,1.38064e-07,1.43508e-07, & + & 1.49129e-07,1.54931e-07,1.60920e-07,1.67099e-07,1.73473e-07/ + data totplnk(151:181,15) / & + & 1.80046e-07,1.86825e-07,1.93812e-07,2.01014e-07,2.08436e-07, & + & 2.16082e-07,2.23957e-07,2.32067e-07,2.40418e-07,2.49013e-07, & + & 2.57860e-07,2.66963e-07,2.76328e-07,2.85961e-07,2.95868e-07, & + & 3.06053e-07,3.16524e-07,3.27286e-07,3.38345e-07,3.49707e-07, & + & 3.61379e-07,3.73367e-07,3.85676e-07,3.98315e-07,4.11287e-07, & + & 4.24602e-07,4.38265e-07,4.52283e-07,4.66662e-07,4.81410e-07, & + & 4.96535e-07/ + data totplnk( 1: 50,16) / & + & 0.28639e-12,0.33349e-12,0.38764e-12,0.44977e-12,0.52093e-12, & + & 0.60231e-12,0.69522e-12,0.80111e-12,0.92163e-12,0.10586e-11, & + & 0.12139e-11,0.13899e-11,0.15890e-11,0.18138e-11,0.20674e-11, & + & 0.23531e-11,0.26744e-11,0.30352e-11,0.34401e-11,0.38936e-11, & + & 0.44011e-11,0.49681e-11,0.56010e-11,0.63065e-11,0.70919e-11, & + & 0.79654e-11,0.89357e-11,0.10012e-10,0.11205e-10,0.12526e-10, & + & 0.13986e-10,0.15600e-10,0.17380e-10,0.19342e-10,0.21503e-10, & + & 0.23881e-10,0.26494e-10,0.29362e-10,0.32509e-10,0.35958e-10, & + & 0.39733e-10,0.43863e-10,0.48376e-10,0.53303e-10,0.58679e-10, & + & 0.64539e-10,0.70920e-10,0.77864e-10,0.85413e-10,0.93615e-10/ + data totplnk( 51:100,16) / & + & 0.10252e-09,0.11217e-09,0.12264e-09,0.13397e-09,0.14624e-09, & + & 0.15950e-09,0.17383e-09,0.18930e-09,0.20599e-09,0.22399e-09, & + & 0.24339e-09,0.26427e-09,0.28674e-09,0.31090e-09,0.33686e-09, & + & 0.36474e-09,0.39466e-09,0.42676e-09,0.46115e-09,0.49800e-09, & + & 0.53744e-09,0.57964e-09,0.62476e-09,0.67298e-09,0.72448e-09, & + & 0.77945e-09,0.83809e-09,0.90062e-09,0.96725e-09,0.10382e-08, & + & 0.11138e-08,0.11941e-08,0.12796e-08,0.13704e-08,0.14669e-08, & + & 0.15694e-08,0.16781e-08,0.17934e-08,0.19157e-08,0.20453e-08, & + & 0.21825e-08,0.23278e-08,0.24815e-08,0.26442e-08,0.28161e-08, & + & 0.29978e-08,0.31898e-08,0.33925e-08,0.36064e-08,0.38321e-08/ + data totplnk(101:150,16) / & + & 0.40700e-08,0.43209e-08,0.45852e-08,0.48636e-08,0.51567e-08, & + & 0.54652e-08,0.57897e-08,0.61310e-08,0.64897e-08,0.68667e-08, & + & 0.72626e-08,0.76784e-08,0.81148e-08,0.85727e-08,0.90530e-08, & + & 0.95566e-08,0.10084e-07,0.10638e-07,0.11217e-07,0.11824e-07, & + & 0.12458e-07,0.13123e-07,0.13818e-07,0.14545e-07,0.15305e-07, & + & 0.16099e-07,0.16928e-07,0.17795e-07,0.18699e-07,0.19643e-07, & + & 0.20629e-07,0.21656e-07,0.22728e-07,0.23845e-07,0.25010e-07, & + & 0.26223e-07,0.27487e-07,0.28804e-07,0.30174e-07,0.31600e-07, & + & 0.33084e-07,0.34628e-07,0.36233e-07,0.37902e-07,0.39637e-07, & + & 0.41440e-07,0.43313e-07,0.45259e-07,0.47279e-07,0.49376e-07/ + data totplnk(151:181,16) / & + & 0.51552e-07,0.53810e-07,0.56153e-07,0.58583e-07,0.61102e-07, & + & 0.63713e-07,0.66420e-07,0.69224e-07,0.72129e-07,0.75138e-07, & + & 0.78254e-07,0.81479e-07,0.84818e-07,0.88272e-07,0.91846e-07, & + & 0.95543e-07,0.99366e-07,0.10332e-06,0.10740e-06,0.11163e-06, & + & 0.11599e-06,0.12050e-06,0.12515e-06,0.12996e-06,0.13493e-06, & + & 0.14005e-06,0.14534e-06,0.15080e-06,0.15643e-06,0.16224e-06, & + & 0.16823e-06/ + +!........................................! + end module module_radlw_avplank ! +!========================================! + +!> \ingroup module_radlw_main +!> This module contains reference temperature and pressure. +!! +!! - These pressures are chosen such that the ln of the first one +!! has only a few non-zero digits (i.e. ln(pref(1)) = 6.96000) and +!! each subsequent ln(pref) differs from the previous one by 0.2. +!! - These temperatures are associated with the respective +!! pressures for the MLS standard atmosphere. +!========================================! + module module_radlw_ref ! +!........................................! +! + use physparam, only : kind_phys +! + implicit none +! + public + +! --- reference pressure and temperature + real (kind=kind_phys), dimension(59) :: pref, preflog, tref + +! ... these pressures are chosen such that the ln of the first one +! has only a few non-zero digits (i.e. ln(pref(1)) = 6.96000) and +! each subsequent ln(pref) differs from the previous one by 0.2. + data pref / & + & 1.05363e+03,8.62642e+02,7.06272e+02,5.78246e+02,4.73428e+02, & + & 3.87610e+02,3.17348e+02,2.59823e+02,2.12725e+02,1.74164e+02, & + & 1.42594e+02,1.16746e+02,9.55835e+01,7.82571e+01,6.40715e+01, & + & 5.24573e+01,4.29484e+01,3.51632e+01,2.87892e+01,2.35706e+01, & + & 1.92980e+01,1.57998e+01,1.29358e+01,1.05910e+01,8.67114e+00, & + & 7.09933e+00,5.81244e+00,4.75882e+00,3.89619e+00,3.18993e+00, & + & 2.61170e+00,2.13828e+00,1.75067e+00,1.43333e+00,1.17351e+00, & + & 9.60789e-01,7.86628e-01,6.44036e-01,5.27292e-01,4.31710e-01, & + & 3.53455e-01,2.89384e-01,2.36928e-01,1.93980e-01,1.58817e-01, & + & 1.30029e-01,1.06458e-01,8.71608e-02,7.13612e-02,5.84256e-02, & + & 4.78349e-02,3.91639e-02,3.20647e-02,2.62523e-02,2.14936e-02, & + & 1.75975e-02,1.44076e-02,1.17959e-02,9.65769e-03 / + data preflog / & + & 6.9600e+00, 6.7600e+00, 6.5600e+00, 6.3600e+00, 6.1600e+00, & + & 5.9600e+00, 5.7600e+00, 5.5600e+00, 5.3600e+00, 5.1600e+00, & + & 4.9600e+00, 4.7600e+00, 4.5600e+00, 4.3600e+00, 4.1600e+00, & + & 3.9600e+00, 3.7600e+00, 3.5600e+00, 3.3600e+00, 3.1600e+00, & + & 2.9600e+00, 2.7600e+00, 2.5600e+00, 2.3600e+00, 2.1600e+00, & + & 1.9600e+00, 1.7600e+00, 1.5600e+00, 1.3600e+00, 1.1600e+00, & + & 9.6000e-01, 7.6000e-01, 5.6000e-01, 3.6000e-01, 1.6000e-01, & + & -4.0000e-02,-2.4000e-01,-4.4000e-01,-6.4000e-01,-8.4000e-01, & + & -1.0400e+00,-1.2400e+00,-1.4400e+00,-1.6400e+00,-1.8400e+00, & + & -2.0400e+00,-2.2400e+00,-2.4400e+00,-2.6400e+00,-2.8400e+00, & + & -3.0400e+00,-3.2400e+00,-3.4400e+00,-3.6400e+00,-3.8400e+00, & + & -4.0400e+00,-4.2400e+00,-4.4400e+00,-4.6400e+00 / + +! ... these are the temperatures associated with the respective +! pressures for the MLS standard atmosphere. + data tref / & + & 2.9420E+02, 2.8799E+02, 2.7894E+02, 2.6925E+02, 2.5983E+02, & + & 2.5017E+02, 2.4077E+02, 2.3179E+02, 2.2306E+02, 2.1578E+02, & + & 2.1570E+02, 2.1570E+02, 2.1570E+02, 2.1706E+02, 2.1858E+02, & + & 2.2018E+02, 2.2174E+02, 2.2328E+02, 2.2479E+02, 2.2655E+02, & + & 2.2834E+02, 2.3113E+02, 2.3401E+02, 2.3703E+02, 2.4022E+02, & + & 2.4371E+02, 2.4726E+02, 2.5085E+02, 2.5457E+02, 2.5832E+02, & + & 2.6216E+02, 2.6606E+02, 2.6999E+02, 2.7340E+02, 2.7536E+02, & + & 2.7568E+02, 2.7372E+02, 2.7163E+02, 2.6955E+02, 2.6593E+02, & + & 2.6211E+02, 2.5828E+02, 2.5360E+02, 2.4854E+02, 2.4348E+02, & + & 2.3809E+02, 2.3206E+02, 2.2603E+02, 2.2000E+02, 2.1435E+02, & + & 2.0887E+02, 2.0340E+02, 1.9792E+02, 1.9290E+02, 1.8809E+02, & + & 1.8329E+02, 1.7849E+02, 1.7394E+02, 1.7212E+02 / + + real (kind=kind_phys), dimension(7,59) :: chi_mls + data chi_mls(1,1:12) / & + & 1.8760e-02, 1.2223e-02, 5.8909e-03, 2.7675e-03, 1.4065e-03, & + & 7.5970e-04, 3.8876e-04, 1.6542e-04, 3.7190e-05, 7.4765e-06, & + & 4.3082e-06, 3.3319e-06/ + data chi_mls(1,13:59) / & + & 3.2039e-06, 3.1619e-06, 3.2524e-06, 3.4226e-06, 3.6288e-06, & + & 3.9148e-06, 4.1488e-06, 4.3081e-06, 4.4420e-06, 4.5778e-06, & + & 4.7087e-06, 4.7943e-06, 4.8697e-06, 4.9260e-06, 4.9669e-06, & + & 4.9963e-06, 5.0527e-06, 5.1266e-06, 5.2503e-06, 5.3571e-06, & + & 5.4509e-06, 5.4830e-06, 5.5000e-06, 5.5000e-06, 5.4536e-06, & + & 5.4047e-06, 5.3558e-06, 5.2533e-06, 5.1436e-06, 5.0340e-06, & + & 4.8766e-06, 4.6979e-06, 4.5191e-06, 4.3360e-06, 4.1442e-06, & + & 3.9523e-06, 3.7605e-06, 3.5722e-06, 3.3855e-06, 3.1988e-06, & + & 3.0121e-06, 2.8262e-06, 2.6407e-06, 2.4552e-06, 2.2696e-06, & + & 4.3360e-06, 4.1442e-06/ + + data chi_mls(2,1:12) / & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04/ + data chi_mls(2,13:59) / & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, 3.5500e-04, & + & 3.5500e-04, 3.5471e-04, 3.5427e-04, 3.5384e-04, 3.5340e-04, & + & 3.5500e-04, 3.5500e-04/ + + data chi_mls(3,1:12) / & + & 3.0170e-08, 3.4725e-08, 4.2477e-08, 5.2759e-08, 6.6944e-08, & + & 8.7130e-08, 1.1391e-07, 1.5677e-07, 2.1788e-07, 3.2443e-07, & + & 4.6594e-07, 5.6806e-07/ + data chi_mls(3,13:59) / & + & 6.9607e-07, 1.1186e-06, 1.7618e-06, 2.3269e-06, 2.9577e-06, & + & 3.6593e-06, 4.5950e-06, 5.3189e-06, 5.9618e-06, 6.5113e-06, & + & 7.0635e-06, 7.6917e-06, 8.2577e-06, 8.7082e-06, 8.8325e-06, & + & 8.7149e-06, 8.0943e-06, 7.3307e-06, 6.3101e-06, 5.3672e-06, & + & 4.4829e-06, 3.8391e-06, 3.2827e-06, 2.8235e-06, 2.4906e-06, & + & 2.1645e-06, 1.8385e-06, 1.6618e-06, 1.5052e-06, 1.3485e-06, & + & 1.1972e-06, 1.0482e-06, 8.9926e-07, 7.6343e-07, 6.5381e-07, & + & 5.4419e-07, 4.3456e-07, 3.6421e-07, 3.1194e-07, 2.5967e-07, & + & 2.0740e-07, 1.9146e-07, 1.9364e-07, 1.9582e-07, 1.9800e-07, & + & 7.6343e-07, 6.5381e-07/ + + data chi_mls(4,1:12) / & + & 3.2000e-07, 3.2000e-07, 3.2000e-07, 3.2000e-07, 3.2000e-07, & + & 3.1965e-07, 3.1532e-07, 3.0383e-07, 2.9422e-07, 2.8495e-07, & + & 2.7671e-07, 2.6471e-07/ + data chi_mls(4,13:59) / & + & 2.4285e-07, 2.0955e-07, 1.7195e-07, 1.3749e-07, 1.1332e-07, & + & 1.0035e-07, 9.1281e-08, 8.5463e-08, 8.0363e-08, 7.3372e-08, & + & 6.5975e-08, 5.6039e-08, 4.7090e-08, 3.9977e-08, 3.2979e-08, & + & 2.6064e-08, 2.1066e-08, 1.6592e-08, 1.3017e-08, 1.0090e-08, & + & 7.6249e-09, 6.1159e-09, 4.6672e-09, 3.2857e-09, 2.8484e-09, & + & 2.4620e-09, 2.0756e-09, 1.8551e-09, 1.6568e-09, 1.4584e-09, & + & 1.3195e-09, 1.2072e-09, 1.0948e-09, 9.9780e-10, 9.3126e-10, & + & 8.6472e-10, 7.9818e-10, 7.5138e-10, 7.1367e-10, 6.7596e-10, & + & 6.3825e-10, 6.0981e-10, 5.8600e-10, 5.6218e-10, 5.3837e-10, & + & 9.9780e-10, 9.3126e-10/ + + data chi_mls(5,1:12) / & + & 1.5000e-07, 1.4306e-07, 1.3474e-07, 1.3061e-07, 1.2793e-07, & + & 1.2038e-07, 1.0798e-07, 9.4238e-08, 7.9488e-08, 6.1386e-08, & + & 4.5563e-08, 3.3475e-08/ + data chi_mls(5,13:59) / & + & 2.5118e-08, 1.8671e-08, 1.4349e-08, 1.2501e-08, 1.2407e-08, & + & 1.3472e-08, 1.4900e-08, 1.6079e-08, 1.7156e-08, 1.8616e-08, & + & 2.0106e-08, 2.1654e-08, 2.3096e-08, 2.4340e-08, 2.5643e-08, & + & 2.6990e-08, 2.8456e-08, 2.9854e-08, 3.0943e-08, 3.2023e-08, & + & 3.3101e-08, 3.4260e-08, 3.5360e-08, 3.6397e-08, 3.7310e-08, & + & 3.8217e-08, 3.9123e-08, 4.1303e-08, 4.3652e-08, 4.6002e-08, & + & 5.0289e-08, 5.5446e-08, 6.0603e-08, 6.8946e-08, 8.3652e-08, & + & 9.8357e-08, 1.1306e-07, 1.4766e-07, 1.9142e-07, 2.3518e-07, & + & 2.7894e-07, 3.5001e-07, 4.3469e-07, 5.1938e-07, 6.0407e-07, & + & 6.8946e-08, 8.3652e-08/ + + data chi_mls(6,1:12) / & + & 1.7000e-06, 1.7000e-06, 1.6999e-06, 1.6904e-06, 1.6671e-06, & + & 1.6351e-06, 1.6098e-06, 1.5590e-06, 1.5120e-06, 1.4741e-06, & + & 1.4385e-06, 1.4002e-06/ + data chi_mls(6,13:59) / & + & 1.3573e-06, 1.3130e-06, 1.2512e-06, 1.1668e-06, 1.0553e-06, & + & 9.3281e-07, 8.1217e-07, 7.5239e-07, 7.0728e-07, 6.6722e-07, & + & 6.2733e-07, 5.8604e-07, 5.4769e-07, 5.1480e-07, 4.8206e-07, & + & 4.4943e-07, 4.1702e-07, 3.8460e-07, 3.5200e-07, 3.1926e-07, & + & 2.8646e-07, 2.5498e-07, 2.2474e-07, 1.9588e-07, 1.8295e-07, & + & 1.7089e-07, 1.5882e-07, 1.5536e-07, 1.5304e-07, 1.5072e-07, & + & 1.5000e-07, 1.5000e-07, 1.5000e-07, 1.5000e-07, 1.5000e-07, & + & 1.5000e-07, 1.5000e-07, 1.5000e-07, 1.5000e-07, 1.5000e-07, & + & 1.5000e-07, 1.5000e-07, 1.5000e-07, 1.5000e-07, 1.5000e-07, & + & 1.5000e-07, 1.5000e-07/ + + data chi_mls(7,1:12) / & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090/ + data chi_mls(7,13:59) / & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090, 0.2090, 0.2090, 0.2090, & + & 0.2090, 0.2090/ + +!........................................! + end module module_radlw_ref ! +!========================================! + +!> \ingroup module_radlw_main +!> This module contains cloud property coefficients. +!========================================! + module module_radlw_cldprlw ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NBANDS +! + implicit none +! + public + +!> ipat is bands index for ebert&curry ice cloud (for iflagice=1) + integer :: ipat(NBANDS) +! --- ipat is bands index for ebert & curry ice cloud (for iflagice=1) + data ipat / 1, 2, 3,3,3, 4,4,4, 5,5,5,5,5,5,5,5 / + +!> absrain is the rain drop absorption coefficient \f$(m^{2}/g)\f$ . +! real (kind=kind_phys), parameter :: absrain = 3.07e-3 ! chou coeff + real (kind=kind_phys), parameter :: absrain = 0.33e-3 ! ncar coeff + +!> abssnow0 is the snow flake absorption coefficient (micron), fu coeff + real (kind=kind_phys), parameter :: abssnow0 = 1.5 ! fu coeff +!> abssnow1 is the snow flake absorption coefficient \f$(m^{2}/g)\f$, ncar coeff + real (kind=kind_phys), parameter :: abssnow1 = 2.34e-3 ! ncar coeff + +! === absliq# is the liquid water absorption coefficient (m2/g). + +! --- not in use +! ccm2 method +! real (kind=kind_phys), parameter :: absliqa = 0.0602410 + +! --- not in use +! ccm3 method +! real (kind=kind_phys), parameter :: absliqb = 0.0903614 + +! --- for iflagliq = 1 +!> Hu and Stamnes method \cite hu_and_stamnes_1993 . the liquid water +!! absorption coefficients are listed for a range of effective radii +!! from 2.5 to 59.5 microns in increments of 1.0 micron. + real (kind=kind_phys), dimension(58,NBANDS) :: absliq1 + +! band 1 + data absliq1(:, 1) / & + & 1.64047e-03, 6.90533e-02, 7.72017e-02, 7.78054e-02, 7.69523e-02, & + & 7.58058e-02, 7.46400e-02, 7.35123e-02, 7.24162e-02, 7.13225e-02, & + & 6.99145e-02, 6.66409e-02, 6.36582e-02, 6.09425e-02, 5.84593e-02, & + & 5.61743e-02, 5.40571e-02, 5.20812e-02, 5.02245e-02, 4.84680e-02, & + & 4.67959e-02, 4.51944e-02, 4.36516e-02, 4.21570e-02, 4.07015e-02, & + & 3.92766e-02, 3.78747e-02, 3.64886e-02, 3.53632e-02, 3.41992e-02, & + & 3.31016e-02, 3.20643e-02, 3.10817e-02, 3.01490e-02, 2.92620e-02, & + & 2.84171e-02, 2.76108e-02, 2.68404e-02, 2.61031e-02, 2.53966e-02, & + & 2.47189e-02, 2.40678e-02, 2.34418e-02, 2.28392e-02, 2.22586e-02, & + & 2.16986e-02, 2.11580e-02, 2.06356e-02, 2.01305e-02, 1.96417e-02, & + & 1.91682e-02, 1.87094e-02, 1.82643e-02, 1.78324e-02, 1.74129e-02, & + & 1.70052e-02, 1.66088e-02, 1.62231e-02 / +! band 2 + data absliq1(:, 2) / & + & 2.19486e-01, 1.80687e-01, 1.59150e-01, 1.44731e-01, 1.33703e-01, & + & 1.24355e-01, 1.15756e-01, 1.07318e-01, 9.86119e-02, 8.92739e-02, & + & 8.34911e-02, 7.70773e-02, 7.15240e-02, 6.66615e-02, 6.23641e-02, & + & 5.85359e-02, 5.51020e-02, 5.20032e-02, 4.91916e-02, 4.66283e-02, & + & 4.42813e-02, 4.21236e-02, 4.01330e-02, 3.82905e-02, 3.65797e-02, & + & 3.49869e-02, 3.35002e-02, 3.21090e-02, 3.08957e-02, 2.97601e-02, & + & 2.86966e-02, 2.76984e-02, 2.67599e-02, 2.58758e-02, 2.50416e-02, & + & 2.42532e-02, 2.35070e-02, 2.27997e-02, 2.21284e-02, 2.14904e-02, & + & 2.08834e-02, 2.03051e-02, 1.97536e-02, 1.92271e-02, 1.87239e-02, & + & 1.82425e-02, 1.77816e-02, 1.73399e-02, 1.69162e-02, 1.65094e-02, & + & 1.61187e-02, 1.57430e-02, 1.53815e-02, 1.50334e-02, 1.46981e-02, & + & 1.43748e-02, 1.40628e-02, 1.37617e-02 / +! band 3 + data absliq1(:, 3) / & + & 2.95174e-01, 2.34765e-01, 1.98038e-01, 1.72114e-01, 1.52083e-01, & + & 1.35654e-01, 1.21613e-01, 1.09252e-01, 9.81263e-02, 8.79448e-02, & + & 8.12566e-02, 7.44563e-02, 6.86374e-02, 6.36042e-02, 5.92094e-02, & + & 5.53402e-02, 5.19087e-02, 4.88455e-02, 4.60951e-02, 4.36124e-02, & + & 4.13607e-02, 3.93096e-02, 3.74338e-02, 3.57119e-02, 3.41261e-02, & + & 3.26610e-02, 3.13036e-02, 3.00425e-02, 2.88497e-02, 2.78077e-02, & + & 2.68317e-02, 2.59158e-02, 2.50545e-02, 2.42430e-02, 2.34772e-02, & + & 2.27533e-02, 2.20679e-02, 2.14181e-02, 2.08011e-02, 2.02145e-02, & + & 1.96561e-02, 1.91239e-02, 1.86161e-02, 1.81311e-02, 1.76673e-02, & + & 1.72234e-02, 1.67981e-02, 1.63903e-02, 1.59989e-02, 1.56230e-02, & + & 1.52615e-02, 1.49138e-02, 1.45791e-02, 1.42565e-02, 1.39455e-02, & + & 1.36455e-02, 1.33559e-02, 1.30761e-02 / +! band 4 + data absliq1(:, 4) / & + & 3.00925e-01, 2.36949e-01, 1.96947e-01, 1.68692e-01, 1.47190e-01, & + & 1.29986e-01, 1.15719e-01, 1.03568e-01, 9.30028e-02, 8.36658e-02, & + & 7.71075e-02, 7.07002e-02, 6.52284e-02, 6.05024e-02, 5.63801e-02, & + & 5.27534e-02, 4.95384e-02, 4.66690e-02, 4.40925e-02, 4.17664e-02, & + & 3.96559e-02, 3.77326e-02, 3.59727e-02, 3.43561e-02, 3.28662e-02, & + & 3.14885e-02, 3.02110e-02, 2.90231e-02, 2.78948e-02, 2.69109e-02, & + & 2.59884e-02, 2.51217e-02, 2.43058e-02, 2.35364e-02, 2.28096e-02, & + & 2.21218e-02, 2.14700e-02, 2.08515e-02, 2.02636e-02, 1.97041e-02, & + & 1.91711e-02, 1.86625e-02, 1.81769e-02, 1.77126e-02, 1.72683e-02, & + & 1.68426e-02, 1.64344e-02, 1.60427e-02, 1.56664e-02, 1.53046e-02, & + & 1.49565e-02, 1.46214e-02, 1.42985e-02, 1.39871e-02, 1.36866e-02, & + & 1.33965e-02, 1.31162e-02, 1.28453e-02 / +! band 5 + data absliq1(:, 5) / & + & 2.64691e-01, 2.12018e-01, 1.78009e-01, 1.53539e-01, 1.34721e-01, & + & 1.19580e-01, 1.06996e-01, 9.62772e-02, 8.69710e-02, 7.87670e-02, & + & 7.29272e-02, 6.70920e-02, 6.20977e-02, 5.77732e-02, 5.39910e-02, & + & 5.06538e-02, 4.76866e-02, 4.50301e-02, 4.26374e-02, 4.04704e-02, & + & 3.84981e-02, 3.66948e-02, 3.50394e-02, 3.35141e-02, 3.21038e-02, & + & 3.07957e-02, 2.95788e-02, 2.84438e-02, 2.73790e-02, 2.64390e-02, & + & 2.55565e-02, 2.47263e-02, 2.39437e-02, 2.32047e-02, 2.25056e-02, & + & 2.18433e-02, 2.12149e-02, 2.06177e-02, 2.00495e-02, 1.95081e-02, & + & 1.89917e-02, 1.84984e-02, 1.80269e-02, 1.75755e-02, 1.71431e-02, & + & 1.67283e-02, 1.63303e-02, 1.59478e-02, 1.55801e-02, 1.52262e-02, & + & 1.48853e-02, 1.45568e-02, 1.42400e-02, 1.39342e-02, 1.36388e-02, & + & 1.33533e-02, 1.30773e-02, 1.28102e-02 / +! band 6 + data absliq1(:, 6) / & + & 8.81182e-02, 1.06745e-01, 9.79753e-02, 8.99625e-02, 8.35200e-02, & + & 7.81899e-02, 7.35939e-02, 6.94696e-02, 6.56266e-02, 6.19148e-02, & + & 5.83355e-02, 5.49306e-02, 5.19642e-02, 4.93325e-02, 4.69659e-02, & + & 4.48148e-02, 4.28431e-02, 4.10231e-02, 3.93332e-02, 3.77563e-02, & + & 3.62785e-02, 3.48882e-02, 3.35758e-02, 3.23333e-02, 3.11536e-02, & + & 3.00310e-02, 2.89601e-02, 2.79365e-02, 2.70502e-02, 2.62618e-02, & + & 2.55025e-02, 2.47728e-02, 2.40726e-02, 2.34013e-02, 2.27583e-02, & + & 2.21422e-02, 2.15522e-02, 2.09869e-02, 2.04453e-02, 1.99260e-02, & + & 1.94280e-02, 1.89501e-02, 1.84913e-02, 1.80506e-02, 1.76270e-02, & + & 1.72196e-02, 1.68276e-02, 1.64500e-02, 1.60863e-02, 1.57357e-02, & + & 1.53975e-02, 1.50710e-02, 1.47558e-02, 1.44511e-02, 1.41566e-02, & + & 1.38717e-02, 1.35960e-02, 1.33290e-02 / +! band 7 + data absliq1(:, 7) / & + & 4.32174e-02, 7.36078e-02, 6.98340e-02, 6.65231e-02, 6.41948e-02, & + & 6.23551e-02, 6.06638e-02, 5.88680e-02, 5.67124e-02, 5.38629e-02, & + & 4.99579e-02, 4.86289e-02, 4.70120e-02, 4.52854e-02, 4.35466e-02, & + & 4.18480e-02, 4.02169e-02, 3.86658e-02, 3.71992e-02, 3.58168e-02, & + & 3.45155e-02, 3.32912e-02, 3.21390e-02, 3.10538e-02, 3.00307e-02, & + & 2.90651e-02, 2.81524e-02, 2.72885e-02, 2.62821e-02, 2.55744e-02, & + & 2.48799e-02, 2.42029e-02, 2.35460e-02, 2.29108e-02, 2.22981e-02, & + & 2.17079e-02, 2.11402e-02, 2.05945e-02, 2.00701e-02, 1.95663e-02, & + & 1.90824e-02, 1.86174e-02, 1.81706e-02, 1.77411e-02, 1.73281e-02, & + & 1.69307e-02, 1.65483e-02, 1.61801e-02, 1.58254e-02, 1.54835e-02, & + & 1.51538e-02, 1.48358e-02, 1.45288e-02, 1.42322e-02, 1.39457e-02, & + & 1.36687e-02, 1.34008e-02, 1.31416e-02 / +! band 8 + data absliq1(:, 8) / & + & 1.41881e-01, 7.15419e-02, 6.30335e-02, 6.11132e-02, 6.01931e-02, & + & 5.92420e-02, 5.78968e-02, 5.58876e-02, 5.28923e-02, 4.84462e-02, & + & 4.60839e-02, 4.56013e-02, 4.45410e-02, 4.31866e-02, 4.17026e-02, & + & 4.01850e-02, 3.86892e-02, 3.72461e-02, 3.58722e-02, 3.45749e-02, & + & 3.33564e-02, 3.22155e-02, 3.11494e-02, 3.01541e-02, 2.92253e-02, & + & 2.83584e-02, 2.75488e-02, 2.67925e-02, 2.57692e-02, 2.50704e-02, & + & 2.43918e-02, 2.37350e-02, 2.31005e-02, 2.24888e-02, 2.18996e-02, & + & 2.13325e-02, 2.07870e-02, 2.02623e-02, 1.97577e-02, 1.92724e-02, & + & 1.88056e-02, 1.83564e-02, 1.79241e-02, 1.75079e-02, 1.71070e-02, & + & 1.67207e-02, 1.63482e-02, 1.59890e-02, 1.56424e-02, 1.53077e-02, & + & 1.49845e-02, 1.46722e-02, 1.43702e-02, 1.40782e-02, 1.37955e-02, & + & 1.35219e-02, 1.32569e-02, 1.30000e-02 / +! band 9 + data absliq1(:, 9) / & + & 6.72726e-02, 6.61013e-02, 6.47866e-02, 6.33780e-02, 6.18985e-02, & + & 6.03335e-02, 5.86136e-02, 5.65876e-02, 5.39839e-02, 5.03536e-02, & + & 4.71608e-02, 4.63630e-02, 4.50313e-02, 4.34526e-02, 4.17876e-02, & + & 4.01261e-02, 3.85171e-02, 3.69860e-02, 3.55442e-02, 3.41954e-02, & + & 3.29384e-02, 3.17693e-02, 3.06832e-02, 2.96745e-02, 2.87374e-02, & + & 2.78662e-02, 2.70557e-02, 2.63008e-02, 2.52450e-02, 2.45424e-02, & + & 2.38656e-02, 2.32144e-02, 2.25885e-02, 2.19873e-02, 2.14099e-02, & + & 2.08554e-02, 2.03230e-02, 1.98116e-02, 1.93203e-02, 1.88482e-02, & + & 1.83944e-02, 1.79578e-02, 1.75378e-02, 1.71335e-02, 1.67440e-02, & + & 1.63687e-02, 1.60069e-02, 1.56579e-02, 1.53210e-02, 1.49958e-02, & + & 1.46815e-02, 1.43778e-02, 1.40841e-02, 1.37999e-02, 1.35249e-02, & + & 1.32585e-02, 1.30004e-02, 1.27502e-02 / +! band 10 + data absliq1(:,10) / & + & 7.97040e-02, 7.63844e-02, 7.36499e-02, 7.13525e-02, 6.93043e-02, & + & 6.72807e-02, 6.50227e-02, 6.22395e-02, 5.86093e-02, 5.37815e-02, & + & 5.14682e-02, 4.97214e-02, 4.77392e-02, 4.56961e-02, 4.36858e-02, & + & 4.17569e-02, 3.99328e-02, 3.82224e-02, 3.66265e-02, 3.51416e-02, & + & 3.37617e-02, 3.24798e-02, 3.12887e-02, 3.01812e-02, 2.91505e-02, & + & 2.81900e-02, 2.72939e-02, 2.64568e-02, 2.54165e-02, 2.46832e-02, & + & 2.39783e-02, 2.33017e-02, 2.26531e-02, 2.20314e-02, 2.14359e-02, & + & 2.08653e-02, 2.03187e-02, 1.97947e-02, 1.92924e-02, 1.88106e-02, & + & 1.83483e-02, 1.79043e-02, 1.74778e-02, 1.70678e-02, 1.66735e-02, & + & 1.62941e-02, 1.59286e-02, 1.55766e-02, 1.52371e-02, 1.49097e-02, & + & 1.45937e-02, 1.42885e-02, 1.39936e-02, 1.37085e-02, 1.34327e-02, & + & 1.31659e-02, 1.29075e-02, 1.26571e-02 / +! band 11 + data absliq1(:,11) / & + & 1.49438e-01, 1.33535e-01, 1.21542e-01, 1.11743e-01, 1.03263e-01, & + & 9.55774e-02, 8.83382e-02, 8.12943e-02, 7.42533e-02, 6.70609e-02, & + & 6.38761e-02, 5.97788e-02, 5.59841e-02, 5.25318e-02, 4.94132e-02, & + & 4.66014e-02, 4.40644e-02, 4.17706e-02, 3.96910e-02, 3.77998e-02, & + & 3.60742e-02, 3.44947e-02, 3.30442e-02, 3.17079e-02, 3.04730e-02, & + & 2.93283e-02, 2.82642e-02, 2.72720e-02, 2.61789e-02, 2.53277e-02, & + & 2.45237e-02, 2.37635e-02, 2.30438e-02, 2.23615e-02, 2.17140e-02, & + & 2.10987e-02, 2.05133e-02, 1.99557e-02, 1.94241e-02, 1.89166e-02, & + & 1.84317e-02, 1.79679e-02, 1.75238e-02, 1.70983e-02, 1.66901e-02, & + & 1.62983e-02, 1.59219e-02, 1.55599e-02, 1.52115e-02, 1.48761e-02, & + & 1.45528e-02, 1.42411e-02, 1.39402e-02, 1.36497e-02, 1.33690e-02, & + & 1.30976e-02, 1.28351e-02, 1.25810e-02 / +! band 12 + data absliq1(:,12) / & + & 3.71985e-02, 3.88586e-02, 3.99070e-02, 4.04351e-02, 4.04610e-02, & + & 3.99834e-02, 3.89953e-02, 3.74886e-02, 3.54551e-02, 3.28870e-02, & + & 3.32576e-02, 3.22444e-02, 3.12384e-02, 3.02584e-02, 2.93146e-02, & + & 2.84120e-02, 2.75525e-02, 2.67361e-02, 2.59618e-02, 2.52280e-02, & + & 2.45327e-02, 2.38736e-02, 2.32487e-02, 2.26558e-02, 2.20929e-02, & + & 2.15579e-02, 2.10491e-02, 2.05648e-02, 1.99749e-02, 1.95704e-02, & + & 1.91731e-02, 1.87839e-02, 1.84032e-02, 1.80315e-02, 1.76689e-02, & + & 1.73155e-02, 1.69712e-02, 1.66362e-02, 1.63101e-02, 1.59928e-02, & + & 1.56842e-02, 1.53840e-02, 1.50920e-02, 1.48080e-02, 1.45318e-02, & + & 1.42631e-02, 1.40016e-02, 1.37472e-02, 1.34996e-02, 1.32586e-02, & + & 1.30239e-02, 1.27954e-02, 1.25728e-02, 1.23559e-02, 1.21445e-02, & + & 1.19385e-02, 1.17376e-02, 1.15417e-02 / +! band 13 + data absliq1(:,13) / & + & 3.11868e-02, 4.48357e-02, 4.90224e-02, 4.96406e-02, 4.86806e-02, & + & 4.69610e-02, 4.48630e-02, 4.25795e-02, 4.02138e-02, 3.78236e-02, & + & 3.74266e-02, 3.60384e-02, 3.47074e-02, 3.34434e-02, 3.22499e-02, & + & 3.11264e-02, 3.00704e-02, 2.90784e-02, 2.81463e-02, 2.72702e-02, & + & 2.64460e-02, 2.56698e-02, 2.49381e-02, 2.42475e-02, 2.35948e-02, & + & 2.29774e-02, 2.23925e-02, 2.18379e-02, 2.11793e-02, 2.07076e-02, & + & 2.02470e-02, 1.97981e-02, 1.93613e-02, 1.89367e-02, 1.85243e-02, & + & 1.81240e-02, 1.77356e-02, 1.73588e-02, 1.69935e-02, 1.66392e-02, & + & 1.62956e-02, 1.59624e-02, 1.56393e-02, 1.53259e-02, 1.50219e-02, & + & 1.47268e-02, 1.44404e-02, 1.41624e-02, 1.38925e-02, 1.36302e-02, & + & 1.33755e-02, 1.31278e-02, 1.28871e-02, 1.26530e-02, 1.24253e-02, & + & 1.22038e-02, 1.19881e-02, 1.17782e-02 / +! band 14 + data absliq1(:,14) / & + & 1.58988e-02, 3.50652e-02, 4.00851e-02, 4.07270e-02, 3.98101e-02, & + & 3.83306e-02, 3.66829e-02, 3.50327e-02, 3.34497e-02, 3.19609e-02, & + & 3.13712e-02, 3.03348e-02, 2.93415e-02, 2.83973e-02, 2.75037e-02, & + & 2.66604e-02, 2.58654e-02, 2.51161e-02, 2.44100e-02, 2.37440e-02, & + & 2.31154e-02, 2.25215e-02, 2.19599e-02, 2.14282e-02, 2.09242e-02, & + & 2.04459e-02, 1.99915e-02, 1.95594e-02, 1.90254e-02, 1.86598e-02, & + & 1.82996e-02, 1.79455e-02, 1.75983e-02, 1.72584e-02, 1.69260e-02, & + & 1.66013e-02, 1.62843e-02, 1.59752e-02, 1.56737e-02, 1.53799e-02, & + & 1.50936e-02, 1.48146e-02, 1.45429e-02, 1.42782e-02, 1.40203e-02, & + & 1.37691e-02, 1.35243e-02, 1.32858e-02, 1.30534e-02, 1.28270e-02, & + & 1.26062e-02, 1.23909e-02, 1.21810e-02, 1.19763e-02, 1.17766e-02, & + & 1.15817e-02, 1.13915e-02, 1.12058e-02 / +! band 15 + data absliq1(:,15) / & + & 5.02079e-03, 2.17615e-02, 2.55449e-02, 2.59484e-02, 2.53650e-02, & + & 2.45281e-02, 2.36843e-02, 2.29159e-02, 2.22451e-02, 2.16716e-02, & + & 2.11451e-02, 2.05817e-02, 2.00454e-02, 1.95372e-02, 1.90567e-02, & + & 1.86028e-02, 1.81742e-02, 1.77693e-02, 1.73866e-02, 1.70244e-02, & + & 1.66815e-02, 1.63563e-02, 1.60477e-02, 1.57544e-02, 1.54755e-02, & + & 1.52097e-02, 1.49564e-02, 1.47146e-02, 1.43684e-02, 1.41728e-02, & + & 1.39762e-02, 1.37797e-02, 1.35838e-02, 1.33891e-02, 1.31961e-02, & + & 1.30051e-02, 1.28164e-02, 1.26302e-02, 1.24466e-02, 1.22659e-02, & + & 1.20881e-02, 1.19131e-02, 1.17412e-02, 1.15723e-02, 1.14063e-02, & + & 1.12434e-02, 1.10834e-02, 1.09264e-02, 1.07722e-02, 1.06210e-02, & + & 1.04725e-02, 1.03269e-02, 1.01839e-02, 1.00436e-02, 9.90593e-03, & + & 9.77080e-03, 9.63818e-03, 9.50800e-03 / +! band 16 + data absliq1(:,16) / & + & 5.64971e-02, 9.04736e-02, 8.11726e-02, 7.05450e-02, 6.20052e-02, & + & 5.54286e-02, 5.03503e-02, 4.63791e-02, 4.32290e-02, 4.06959e-02, & + & 3.74690e-02, 3.52964e-02, 3.33799e-02, 3.16774e-02, 3.01550e-02, & + & 2.87856e-02, 2.75474e-02, 2.64223e-02, 2.53953e-02, 2.44542e-02, & + & 2.35885e-02, 2.27894e-02, 2.20494e-02, 2.13622e-02, 2.07222e-02, & + & 2.01246e-02, 1.95654e-02, 1.90408e-02, 1.84398e-02, 1.80021e-02, & + & 1.75816e-02, 1.71775e-02, 1.67889e-02, 1.64152e-02, 1.60554e-02, & + & 1.57089e-02, 1.53751e-02, 1.50531e-02, 1.47426e-02, 1.44428e-02, & + & 1.41532e-02, 1.38734e-02, 1.36028e-02, 1.33410e-02, 1.30875e-02, & + & 1.28420e-02, 1.26041e-02, 1.23735e-02, 1.21497e-02, 1.19325e-02, & + & 1.17216e-02, 1.15168e-02, 1.13177e-02, 1.11241e-02, 1.09358e-02, & + & 1.07525e-02, 1.05741e-02, 1.04003e-02 / + +! === ice cloud coefficients below are used for iflagliq > 0 + +! absice#(j,ib) are the parameters needed to compute the ice water +! absorption coefficients in spectral region ib for iflagice=#. the +! units of absice#(1,ib) are m2/g and absice#(2,ib) has units +! (microns*m^2/g)). + +!> for iflagice = 2 or 3, absice0 are the ice water absorption coefficients used for +!! large ice partical size such as refice > 131 microns. + real (kind=kind_phys), dimension(2) :: absice0 + + data absice0 / 0.005, 1.0 / +!! data absice0 / 0.0029, 1.0 / ! moorthi's coeff + +!> for iflagice = 1, absice1 are the ice water absorption coefficients used for +!! ebert and curry method \cite ebert_and_curry_1992 . + real (kind=kind_phys), dimension(2,5) :: absice1 + + data absice1 / 0.0036, 1.136, 0.0068, 0.600, 0.0003, 1.338, & + & 0.0016, 1.166, 0.0020, 1.118 / + +!> for iflagice =2, absice2 are the ice water absorption coefficients used for +!! streamer method. the absorption coefficients are listed for a range of effective +!! radii from 5.0 to 131.0 microns in increments of 3.0 microns. spherical ice +!! particle parameterization absorption units (abs coef/iwc): +!! \f$\frac{m^{-1}}{gm^{-3}}\f$ + real (kind=kind_phys), dimension(43,NBANDS) :: absice2 + +! band 1 + data absice2(:,1) / & + & 7.798999e-02,6.340479e-02,5.417973e-02,4.766245e-02,4.272663e-02, & + & 3.880939e-02,3.559544e-02,3.289241e-02,3.057511e-02,2.855800e-02, & + & 2.678022e-02,2.519712e-02,2.377505e-02,2.248806e-02,2.131578e-02, & + & 2.024194e-02,1.925337e-02,1.833926e-02,1.749067e-02,1.670007e-02, & + & 1.596113e-02,1.526845e-02,1.461739e-02,1.400394e-02,1.342462e-02, & + & 1.287639e-02,1.235656e-02,1.186279e-02,1.139297e-02,1.094524e-02, & + & 1.051794e-02,1.010956e-02,9.718755e-03,9.344316e-03,8.985139e-03, & + & 8.640223e-03,8.308656e-03,7.989606e-03,7.682312e-03,7.386076e-03, & + & 7.100255e-03,6.824258e-03,6.557540e-03 / +! band 2 + data absice2(:,2) / & + & 2.784879e-02,2.709863e-02,2.619165e-02,2.529230e-02,2.443225e-02, & + & 2.361575e-02,2.284021e-02,2.210150e-02,2.139548e-02,2.071840e-02, & + & 2.006702e-02,1.943856e-02,1.883064e-02,1.824120e-02,1.766849e-02, & + & 1.711099e-02,1.656737e-02,1.603647e-02,1.551727e-02,1.500886e-02, & + & 1.451045e-02,1.402132e-02,1.354084e-02,1.306842e-02,1.260355e-02, & + & 1.214575e-02,1.169460e-02,1.124971e-02,1.081072e-02,1.037731e-02, & + & 9.949167e-03,9.526021e-03,9.107615e-03,8.693714e-03,8.284096e-03, & + & 7.878558e-03,7.476910e-03,7.078974e-03,6.684586e-03,6.293589e-03, & + & 5.905839e-03,5.521200e-03,5.139543e-03 / +! band 3 + data absice2(:,3) / & + & 1.065397e-01,8.005726e-02,6.546428e-02,5.589131e-02,4.898681e-02, & + & 4.369932e-02,3.947901e-02,3.600676e-02,3.308299e-02,3.057561e-02, & + & 2.839325e-02,2.647040e-02,2.475872e-02,2.322164e-02,2.183091e-02, & + & 2.056430e-02,1.940407e-02,1.833586e-02,1.734787e-02,1.643034e-02, & + & 1.557512e-02,1.477530e-02,1.402501e-02,1.331924e-02,1.265364e-02, & + & 1.202445e-02,1.142838e-02,1.086257e-02,1.032445e-02,9.811791e-03, & + & 9.322587e-03,8.855053e-03,8.407591e-03,7.978763e-03,7.567273e-03, & + & 7.171949e-03,6.791728e-03,6.425642e-03,6.072809e-03,5.732424e-03, & + & 5.403748e-03,5.086103e-03,4.778865e-03 / +! band 4 + data absice2(:,4) / & + & 1.804566e-01,1.168987e-01,8.680442e-02,6.910060e-02,5.738174e-02, & + & 4.902332e-02,4.274585e-02,3.784923e-02,3.391734e-02,3.068690e-02, & + & 2.798301e-02,2.568480e-02,2.370600e-02,2.198337e-02,2.046940e-02, & + & 1.912777e-02,1.793016e-02,1.685420e-02,1.588193e-02,1.499882e-02, & + & 1.419293e-02,1.345440e-02,1.277496e-02,1.214769e-02,1.156669e-02, & + & 1.102694e-02,1.052412e-02,1.005451e-02,9.614854e-03,9.202335e-03, & + & 8.814470e-03,8.449077e-03,8.104223e-03,7.778195e-03,7.469466e-03, & + & 7.176671e-03,6.898588e-03,6.634117e-03,6.382264e-03,6.142134e-03, & + & 5.912913e-03,5.693862e-03,5.484308e-03 / +! band 5 + data absice2(:,5) / & + & 2.131806e-01,1.311372e-01,9.407171e-02,7.299442e-02,5.941273e-02, & + & 4.994043e-02,4.296242e-02,3.761113e-02,3.337910e-02,2.994978e-02, & + & 2.711556e-02,2.473461e-02,2.270681e-02,2.095943e-02,1.943839e-02, & + & 1.810267e-02,1.692057e-02,1.586719e-02,1.492275e-02,1.407132e-02, & + & 1.329989e-02,1.259780e-02,1.195618e-02,1.136761e-02,1.082583e-02, & + & 1.032552e-02,9.862158e-03,9.431827e-03,9.031157e-03,8.657217e-03, & + & 8.307449e-03,7.979609e-03,7.671724e-03,7.382048e-03,7.109032e-03, & + & 6.851298e-03,6.607615e-03,6.376881e-03,6.158105e-03,5.950394e-03, & + & 5.752942e-03,5.565019e-03,5.385963e-03 / +! band 6 + data absice2(:,6) / & + & 1.546177e-01,1.039251e-01,7.910347e-02,6.412429e-02,5.399997e-02, & + & 4.664937e-02,4.104237e-02,3.660781e-02,3.300218e-02,3.000586e-02, & + & 2.747148e-02,2.529633e-02,2.340647e-02,2.174723e-02,2.027731e-02, & + & 1.896487e-02,1.778492e-02,1.671761e-02,1.574692e-02,1.485978e-02, & + & 1.404543e-02,1.329489e-02,1.260066e-02,1.195636e-02,1.135657e-02, & + & 1.079664e-02,1.027257e-02,9.780871e-03,9.318505e-03,8.882815e-03, & + & 8.471458e-03,8.082364e-03,7.713696e-03,7.363817e-03,7.031264e-03, & + & 6.714725e-03,6.413021e-03,6.125086e-03,5.849958e-03,5.586764e-03, & + & 5.334707e-03,5.093066e-03,4.861179e-03 / +! band 7 + data absice2(:,7) / & + & 7.583404e-02,6.181558e-02,5.312027e-02,4.696039e-02,4.225986e-02, & + & 3.849735e-02,3.538340e-02,3.274182e-02,3.045798e-02,2.845343e-02, & + & 2.667231e-02,2.507353e-02,2.362606e-02,2.230595e-02,2.109435e-02, & + & 1.997617e-02,1.893916e-02,1.797328e-02,1.707016e-02,1.622279e-02, & + & 1.542523e-02,1.467241e-02,1.395997e-02,1.328414e-02,1.264164e-02, & + & 1.202958e-02,1.144544e-02,1.088697e-02,1.035218e-02,9.839297e-03, & + & 9.346733e-03,8.873057e-03,8.416980e-03,7.977335e-03,7.553066e-03, & + & 7.143210e-03,6.746888e-03,6.363297e-03,5.991700e-03,5.631422e-03, & + & 5.281840e-03,4.942378e-03,4.612505e-03 / +! band 8 + data absice2(:,8) / & + & 9.022185e-02,6.922700e-02,5.710674e-02,4.898377e-02,4.305946e-02, & + & 3.849553e-02,3.484183e-02,3.183220e-02,2.929794e-02,2.712627e-02, & + & 2.523856e-02,2.357810e-02,2.210286e-02,2.078089e-02,1.958747e-02, & + & 1.850310e-02,1.751218e-02,1.660205e-02,1.576232e-02,1.498440e-02, & + & 1.426107e-02,1.358624e-02,1.295474e-02,1.236212e-02,1.180456e-02, & + & 1.127874e-02,1.078175e-02,1.031106e-02,9.864433e-03,9.439878e-03, & + & 9.035637e-03,8.650140e-03,8.281981e-03,7.929895e-03,7.592746e-03, & + & 7.269505e-03,6.959238e-03,6.661100e-03,6.374317e-03,6.098185e-03, & + & 5.832059e-03,5.575347e-03,5.327504e-03 / +! band 9 + data absice2(:,9) / & + & 1.294087e-01,8.788217e-02,6.728288e-02,5.479720e-02,4.635049e-02, & + & 4.022253e-02,3.555576e-02,3.187259e-02,2.888498e-02,2.640843e-02, & + & 2.431904e-02,2.253038e-02,2.098024e-02,1.962267e-02,1.842293e-02, & + & 1.735426e-02,1.639571e-02,1.553060e-02,1.474552e-02,1.402953e-02, & + & 1.337363e-02,1.277033e-02,1.221336e-02,1.169741e-02,1.121797e-02, & + & 1.077117e-02,1.035369e-02,9.962643e-03,9.595509e-03,9.250088e-03, & + & 8.924447e-03,8.616876e-03,8.325862e-03,8.050057e-03,7.788258e-03, & + & 7.539388e-03,7.302478e-03,7.076656e-03,6.861134e-03,6.655197e-03, & + & 6.458197e-03,6.269543e-03,6.088697e-03 / +! band 10 + data absice2(:,10) / & + & 1.593628e-01,1.014552e-01,7.458955e-02,5.903571e-02,4.887582e-02, & + & 4.171159e-02,3.638480e-02,3.226692e-02,2.898717e-02,2.631256e-02, & + & 2.408925e-02,2.221156e-02,2.060448e-02,1.921325e-02,1.799699e-02, & + & 1.692456e-02,1.597177e-02,1.511961e-02,1.435289e-02,1.365933e-02, & + & 1.302890e-02,1.245334e-02,1.192576e-02,1.144037e-02,1.099230e-02, & + & 1.057739e-02,1.019208e-02,9.833302e-03,9.498395e-03,9.185047e-03, & + & 8.891237e-03,8.615185e-03,8.355325e-03,8.110267e-03,7.878778e-03, & + & 7.659759e-03,7.452224e-03,7.255291e-03,7.068166e-03,6.890130e-03, & + & 6.720536e-03,6.558794e-03,6.404371e-03 / +! band 11 + data absice2(:,11) / & + & 1.656227e-01,1.032129e-01,7.487359e-02,5.871431e-02,4.828355e-02, & + & 4.099989e-02,3.562924e-02,3.150755e-02,2.824593e-02,2.560156e-02, & + & 2.341503e-02,2.157740e-02,2.001169e-02,1.866199e-02,1.748669e-02, & + & 1.645421e-02,1.554015e-02,1.472535e-02,1.399457e-02,1.333553e-02, & + & 1.273821e-02,1.219440e-02,1.169725e-02,1.124104e-02,1.082096e-02, & + & 1.043290e-02,1.007336e-02,9.739338e-03,9.428223e-03,9.137756e-03, & + & 8.865964e-03,8.611115e-03,8.371686e-03,8.146330e-03,7.933852e-03, & + & 7.733187e-03,7.543386e-03,7.363597e-03,7.193056e-03,7.031072e-03, & + & 6.877024e-03,6.730348e-03,6.590531e-03 / +! band 12 + data absice2(:,12) / & + & 9.194591e-02,6.446867e-02,4.962034e-02,4.042061e-02,3.418456e-02, & + & 2.968856e-02,2.629900e-02,2.365572e-02,2.153915e-02,1.980791e-02, & + & 1.836689e-02,1.714979e-02,1.610900e-02,1.520946e-02,1.442476e-02, & + & 1.373468e-02,1.312345e-02,1.257858e-02,1.209010e-02,1.164990e-02, & + & 1.125136e-02,1.088901e-02,1.055827e-02,1.025531e-02,9.976896e-03, & + & 9.720255e-03,9.483022e-03,9.263160e-03,9.058902e-03,8.868710e-03, & + & 8.691240e-03,8.525312e-03,8.369886e-03,8.224042e-03,8.086961e-03, & + & 7.957917e-03,7.836258e-03,7.721400e-03,7.612821e-03,7.510045e-03, & + & 7.412648e-03,7.320242e-03,7.232476e-03 / +! band 13 + data absice2(:,13) / & + & 1.437021e-01,8.872535e-02,6.392420e-02,4.991833e-02,4.096790e-02, & + & 3.477881e-02,3.025782e-02,2.681909e-02,2.412102e-02,2.195132e-02, & + & 2.017124e-02,1.868641e-02,1.743044e-02,1.635529e-02,1.542540e-02, & + & 1.461388e-02,1.390003e-02,1.326766e-02,1.270395e-02,1.219860e-02, & + & 1.174326e-02,1.133107e-02,1.095637e-02,1.061442e-02,1.030126e-02, & + & 1.001352e-02,9.748340e-03,9.503256e-03,9.276155e-03,9.065205e-03, & + & 8.868808e-03,8.685571e-03,8.514268e-03,8.353820e-03,8.203272e-03, & + & 8.061776e-03,7.928578e-03,7.803001e-03,7.684443e-03,7.572358e-03, & + & 7.466258e-03,7.365701e-03,7.270286e-03 / +! band 14 + data absice2(:,14) / & + & 1.288870e-01,8.160295e-02,5.964745e-02,4.703790e-02,3.888637e-02, & + & 3.320115e-02,2.902017e-02,2.582259e-02,2.330224e-02,2.126754e-02, & + & 1.959258e-02,1.819130e-02,1.700289e-02,1.598320e-02,1.509942e-02, & + & 1.432666e-02,1.364572e-02,1.304156e-02,1.250220e-02,1.201803e-02, & + & 1.158123e-02,1.118537e-02,1.082513e-02,1.049605e-02,1.019440e-02, & + & 9.916989e-03,9.661116e-03,9.424457e-03,9.205005e-03,9.001022e-03, & + & 8.810992e-03,8.633588e-03,8.467646e-03,8.312137e-03,8.166151e-03, & + & 8.028878e-03,7.899597e-03,7.777663e-03,7.662498e-03,7.553581e-03, & + & 7.450444e-03,7.352662e-03,7.259851e-03 / +! band 15 + data absice2(:,15) / & + & 8.254229e-02,5.808787e-02,4.492166e-02,3.675028e-02,3.119623e-02, & + & 2.718045e-02,2.414450e-02,2.177073e-02,1.986526e-02,1.830306e-02, & + & 1.699991e-02,1.589698e-02,1.495199e-02,1.413374e-02,1.341870e-02, & + & 1.278883e-02,1.223002e-02,1.173114e-02,1.128322e-02,1.087900e-02, & + & 1.051254e-02,1.017890e-02,9.873991e-03,9.594347e-03,9.337044e-03, & + & 9.099589e-03,8.879842e-03,8.675960e-03,8.486341e-03,8.309594e-03, & + & 8.144500e-03,7.989986e-03,7.845109e-03,7.709031e-03,7.581007e-03, & + & 7.460376e-03,7.346544e-03,7.238978e-03,7.137201e-03,7.040780e-03, & + & 6.949325e-03,6.862483e-03,6.779931e-03 / +! band 16 + data absice2(:,16) / & + & 1.382062e-01,8.643227e-02,6.282935e-02,4.934783e-02,4.063891e-02, & + & 3.455591e-02,3.007059e-02,2.662897e-02,2.390631e-02,2.169972e-02, & + & 1.987596e-02,1.834393e-02,1.703924e-02,1.591513e-02,1.493679e-02, & + & 1.407780e-02,1.331775e-02,1.264061e-02,1.203364e-02,1.148655e-02, & + & 1.099099e-02,1.054006e-02,1.012807e-02,9.750215e-03,9.402477e-03, & + & 9.081428e-03,8.784143e-03,8.508107e-03,8.251146e-03,8.011373e-03, & + & 7.787140e-03,7.577002e-03,7.379687e-03,7.194071e-03,7.019158e-03, & + & 6.854061e-03,6.697986e-03,6.550224e-03,6.410138e-03,6.277153e-03, & + & 6.150751e-03,6.030462e-03,5.915860e-03 / + + +!> for iflagice = 3, absice3 are the ice water absorption coefficients used for +!! fu parameterization. particle size 5 - 140 micron in increments of 3 microns. +!! units = m2/g. hexagonal ice particle parameterization absorption units (abs coef/iwc): +!! \f$\frac{m^{-1}}{gm^{-3}}\f$ + real (kind=kind_phys), dimension(46,NBANDS) :: absice3 + +! band 1 + data absice3(:,1) / 3.110649e-03,4.666352e-02, & + & 6.606447e-02,6.531678e-02,6.012598e-02,5.437494e-02,4.906411e-02, & + & 4.441146e-02,4.040585e-02,3.697334e-02,3.403027e-02,3.149979e-02, & + & 2.931596e-02,2.742365e-02,2.577721e-02,2.433888e-02,2.307732e-02, & + & 2.196644e-02,2.098437e-02,2.011264e-02,1.933561e-02,1.863992e-02, & + & 1.801407e-02,1.744812e-02,1.693346e-02,1.646252e-02,1.602866e-02, & + & 1.562600e-02,1.524933e-02,1.489399e-02,1.455580e-02,1.423098e-02, & + & 1.391612e-02,1.360812e-02,1.330413e-02,1.300156e-02,1.269801e-02, & + & 1.239127e-02,1.207928e-02,1.176014e-02,1.143204e-02,1.109334e-02, & + & 1.074243e-02,1.037786e-02,9.998198e-03,9.602126e-03 / +! band 2 + data absice3(:,2) / 3.984966e-04,1.681097e-02, & + & 2.627680e-02,2.767465e-02,2.700722e-02,2.579180e-02,2.448677e-02, & + & 2.323890e-02,2.209096e-02,2.104882e-02,2.010547e-02,1.925003e-02, & + & 1.847128e-02,1.775883e-02,1.710358e-02,1.649769e-02,1.593449e-02, & + & 1.540829e-02,1.491429e-02,1.444837e-02,1.400704e-02,1.358729e-02, & + & 1.318654e-02,1.280258e-02,1.243346e-02,1.207750e-02,1.173325e-02, & + & 1.139941e-02,1.107487e-02,1.075861e-02,1.044975e-02,1.014753e-02, & + & 9.851229e-03,9.560240e-03,9.274003e-03,8.992020e-03,8.713845e-03, & + & 8.439074e-03,8.167346e-03,7.898331e-03,7.631734e-03,7.367286e-03, & + & 7.104742e-03,6.843882e-03,6.584504e-03,6.326424e-03 / +! band 3 + data absice3(:,3) / 6.933163e-02,8.540475e-02, & + & 7.701816e-02,6.771158e-02,5.986953e-02,5.348120e-02,4.824962e-02, & + & 4.390563e-02,4.024411e-02,3.711404e-02,3.440426e-02,3.203200e-02, & + & 2.993478e-02,2.806474e-02,2.638464e-02,2.486516e-02,2.348288e-02, & + & 2.221890e-02,2.105780e-02,1.998687e-02,1.899552e-02,1.807490e-02, & + & 1.721750e-02,1.641693e-02,1.566773e-02,1.496515e-02,1.430509e-02, & + & 1.368398e-02,1.309865e-02,1.254634e-02,1.202456e-02,1.153114e-02, & + & 1.106409e-02,1.062166e-02,1.020224e-02,9.804381e-03,9.426771e-03, & + & 9.068205e-03,8.727578e-03,8.403876e-03,8.096160e-03,7.803564e-03, & + & 7.525281e-03,7.260560e-03,7.008697e-03,6.769036e-03 / +! band 4 + data absice3(:,4) / 1.765735e-01,1.382700e-01, & + & 1.095129e-01,8.987475e-02,7.591185e-02,6.554169e-02,5.755500e-02, & + & 5.122083e-02,4.607610e-02,4.181475e-02,3.822697e-02,3.516432e-02, & + & 3.251897e-02,3.021073e-02,2.817876e-02,2.637607e-02,2.476582e-02, & + & 2.331871e-02,2.201113e-02,2.082388e-02,1.974115e-02,1.874983e-02, & + & 1.783894e-02,1.699922e-02,1.622280e-02,1.550296e-02,1.483390e-02, & + & 1.421064e-02,1.362880e-02,1.308460e-02,1.257468e-02,1.209611e-02, & + & 1.164628e-02,1.122287e-02,1.082381e-02,1.044725e-02,1.009154e-02, & + & 9.755166e-03,9.436783e-03,9.135163e-03,8.849193e-03,8.577856e-03, & + & 8.320225e-03,8.075451e-03,7.842755e-03,7.621418e-03 / +! band 5 + data absice3(:,5) / 2.339673e-01,1.692124e-01, & + & 1.291656e-01,1.033837e-01,8.562949e-02,7.273526e-02,6.298262e-02, & + & 5.537015e-02,4.927787e-02,4.430246e-02,4.017061e-02,3.669072e-02, & + & 3.372455e-02,3.116995e-02,2.894977e-02,2.700471e-02,2.528842e-02, & + & 2.376420e-02,2.240256e-02,2.117959e-02,2.007567e-02,1.907456e-02, & + & 1.816271e-02,1.732874e-02,1.656300e-02,1.585725e-02,1.520445e-02, & + & 1.459852e-02,1.403419e-02,1.350689e-02,1.301260e-02,1.254781e-02, & + & 1.210941e-02,1.169468e-02,1.130118e-02,1.092675e-02,1.056945e-02, & + & 1.022757e-02,9.899560e-03,9.584021e-03,9.279705e-03,8.985479e-03, & + & 8.700322e-03,8.423306e-03,8.153590e-03,7.890412e-03 / +! band 6 + data absice3(:,6) / 1.145369e-01,1.174566e-01, & + & 9.917866e-02,8.332990e-02,7.104263e-02,6.153370e-02,5.405472e-02, & + & 4.806281e-02,4.317918e-02,3.913795e-02,3.574916e-02,3.287437e-02, & + & 3.041067e-02,2.828017e-02,2.642292e-02,2.479206e-02,2.335051e-02, & + & 2.206851e-02,2.092195e-02,1.989108e-02,1.895958e-02,1.811385e-02, & + & 1.734245e-02,1.663573e-02,1.598545e-02,1.538456e-02,1.482700e-02, & + & 1.430750e-02,1.382150e-02,1.336499e-02,1.293447e-02,1.252685e-02, & + & 1.213939e-02,1.176968e-02,1.141555e-02,1.107508e-02,1.074655e-02, & + & 1.042839e-02,1.011923e-02,9.817799e-03,9.522962e-03,9.233688e-03, & + & 8.949041e-03,8.668171e-03,8.390301e-03,8.114723e-03 / +! band 7 + data absice3(:,7) / 1.222345e-02,5.344230e-02, & + & 5.523465e-02,5.128759e-02,4.676925e-02,4.266150e-02,3.910561e-02, & + & 3.605479e-02,3.342843e-02,3.115052e-02,2.915776e-02,2.739935e-02, & + & 2.583499e-02,2.443266e-02,2.316681e-02,2.201687e-02,2.096619e-02, & + & 2.000112e-02,1.911044e-02,1.828481e-02,1.751641e-02,1.679866e-02, & + & 1.612598e-02,1.549360e-02,1.489742e-02,1.433392e-02,1.380002e-02, & + & 1.329305e-02,1.281068e-02,1.235084e-02,1.191172e-02,1.149171e-02, & + & 1.108936e-02,1.070341e-02,1.033271e-02,9.976220e-03,9.633021e-03, & + & 9.302273e-03,8.983216e-03,8.675161e-03,8.377478e-03,8.089595e-03, & + & 7.810986e-03,7.541170e-03,7.279706e-03,7.026186e-03 / +! band 8 + data absice3(:,8) / 6.711058e-02,6.918198e-02, & + & 6.127484e-02,5.411944e-02,4.836902e-02,4.375293e-02,3.998077e-02, & + & 3.683587e-02,3.416508e-02,3.186003e-02,2.984290e-02,2.805671e-02, & + & 2.645895e-02,2.501733e-02,2.370689e-02,2.250808e-02,2.140532e-02, & + & 2.038609e-02,1.944018e-02,1.855918e-02,1.773609e-02,1.696504e-02, & + & 1.624106e-02,1.555990e-02,1.491793e-02,1.431197e-02,1.373928e-02, & + & 1.319743e-02,1.268430e-02,1.219799e-02,1.173682e-02,1.129925e-02, & + & 1.088393e-02,1.048961e-02,1.011516e-02,9.759543e-03,9.421813e-03, & + & 9.101089e-03,8.796559e-03,8.507464e-03,8.233098e-03,7.972798e-03, & + & 7.725942e-03,7.491940e-03,7.270238e-03,7.060305e-03 / +! band 9 + data absice3(:,9) / 1.236780e-01,9.222386e-02, & + & 7.383997e-02,6.204072e-02,5.381029e-02,4.770678e-02,4.296928e-02, & + & 3.916131e-02,3.601540e-02,3.335878e-02,3.107493e-02,2.908247e-02, & + & 2.732282e-02,2.575276e-02,2.433968e-02,2.305852e-02,2.188966e-02, & + & 2.081757e-02,1.982974e-02,1.891599e-02,1.806794e-02,1.727865e-02, & + & 1.654227e-02,1.585387e-02,1.520924e-02,1.460476e-02,1.403730e-02, & + & 1.350416e-02,1.300293e-02,1.253153e-02,1.208808e-02,1.167094e-02, & + & 1.127862e-02,1.090979e-02,1.056323e-02,1.023786e-02,9.932665e-03, & + & 9.646744e-03,9.379250e-03,9.129409e-03,8.896500e-03,8.679856e-03, & + & 8.478852e-03,8.292904e-03,8.121463e-03,7.964013e-03 / +! band 10 + data absice3(:,10) / 1.655966e-01,1.134205e-01, & + & 8.714344e-02,7.129241e-02,6.063739e-02,5.294203e-02,4.709309e-02, & + & 4.247476e-02,3.871892e-02,3.559206e-02,3.293893e-02,3.065226e-02, & + & 2.865558e-02,2.689288e-02,2.532221e-02,2.391150e-02,2.263582e-02, & + & 2.147549e-02,2.041476e-02,1.944089e-02,1.854342e-02,1.771371e-02, & + & 1.694456e-02,1.622989e-02,1.556456e-02,1.494415e-02,1.436491e-02, & + & 1.382354e-02,1.331719e-02,1.284339e-02,1.239992e-02,1.198486e-02, & + & 1.159647e-02,1.123323e-02,1.089375e-02,1.057679e-02,1.028124e-02, & + & 1.000607e-02,9.750376e-03,9.513303e-03,9.294082e-03,9.092003e-03, & + & 8.906412e-03,8.736702e-03,8.582314e-03,8.442725e-03 / +! band 11 + data absice3(:,11) / 1.775615e-01,1.180046e-01, & + & 8.929607e-02,7.233500e-02,6.108333e-02,5.303642e-02,4.696927e-02, & + & 4.221206e-02,3.836768e-02,3.518576e-02,3.250063e-02,3.019825e-02, & + & 2.819758e-02,2.643943e-02,2.487953e-02,2.348414e-02,2.222705e-02, & + & 2.108762e-02,2.004936e-02,1.909892e-02,1.822539e-02,1.741975e-02, & + & 1.667449e-02,1.598330e-02,1.534084e-02,1.474253e-02,1.418446e-02, & + & 1.366325e-02,1.317597e-02,1.272004e-02,1.229321e-02,1.189350e-02, & + & 1.151915e-02,1.116859e-02,1.084042e-02,1.053338e-02,1.024636e-02, & + & 9.978326e-03,9.728357e-03,9.495613e-03,9.279327e-03,9.078798e-03, & + & 8.893383e-03,8.722488e-03,8.565568e-03,8.422115e-03 / +! band 12 + data absice3(:,12) / 9.465447e-02,6.432047e-02, & + & 5.060973e-02,4.267283e-02,3.741843e-02,3.363096e-02,3.073531e-02, & + & 2.842405e-02,2.651789e-02,2.490518e-02,2.351273e-02,2.229056e-02, & + & 2.120335e-02,2.022541e-02,1.933763e-02,1.852546e-02,1.777763e-02, & + & 1.708528e-02,1.644134e-02,1.584009e-02,1.527684e-02,1.474774e-02, & + & 1.424955e-02,1.377957e-02,1.333549e-02,1.291534e-02,1.251743e-02, & + & 1.214029e-02,1.178265e-02,1.144337e-02,1.112148e-02,1.081609e-02, & + & 1.052642e-02,1.025178e-02,9.991540e-03,9.745130e-03,9.512038e-03, & + & 9.291797e-03,9.083980e-03,8.888195e-03,8.704081e-03,8.531306e-03, & + & 8.369560e-03,8.218558e-03,8.078032e-03,7.947730e-03 / +! band 13 + data absice3(:,13) / 1.560311e-01,9.961097e-02, & + & 7.502949e-02,6.115022e-02,5.214952e-02,4.578149e-02,4.099731e-02, & + & 3.724174e-02,3.419343e-02,3.165356e-02,2.949251e-02,2.762222e-02, & + & 2.598073e-02,2.452322e-02,2.321642e-02,2.203516e-02,2.096002e-02, & + & 1.997579e-02,1.907036e-02,1.823401e-02,1.745879e-02,1.673819e-02, & + & 1.606678e-02,1.544003e-02,1.485411e-02,1.430574e-02,1.379215e-02, & + & 1.331092e-02,1.285996e-02,1.243746e-02,1.204183e-02,1.167164e-02, & + & 1.132567e-02,1.100281e-02,1.070207e-02,1.042258e-02,1.016352e-02, & + & 9.924197e-03,9.703953e-03,9.502199e-03,9.318400e-03,9.152066e-03, & + & 9.002749e-03,8.870038e-03,8.753555e-03,8.652951e-03 / +! band 14 + data absice3(:,14) / 1.559547e-01,9.896700e-02, & + & 7.441231e-02,6.061469e-02,5.168730e-02,4.537821e-02,4.064106e-02, & + & 3.692367e-02,3.390714e-02,3.139438e-02,2.925702e-02,2.740783e-02, & + & 2.578547e-02,2.434552e-02,2.305506e-02,2.188910e-02,2.082842e-02, & + & 1.985789e-02,1.896553e-02,1.814165e-02,1.737839e-02,1.666927e-02, & + & 1.600891e-02,1.539279e-02,1.481712e-02,1.427865e-02,1.377463e-02, & + & 1.330266e-02,1.286068e-02,1.244689e-02,1.205973e-02,1.169780e-02, & + & 1.135989e-02,1.104492e-02,1.075192e-02,1.048004e-02,1.022850e-02, & + & 9.996611e-03,9.783753e-03,9.589361e-03,9.412924e-03,9.253977e-03, & + & 9.112098e-03,8.986903e-03,8.878039e-03,8.785184e-03 / +! band 15 + data absice3(:,15) / 1.102926e-01,7.176622e-02, & + & 5.530316e-02,4.606056e-02,4.006116e-02,3.579628e-02,3.256909e-02, & + & 3.001360e-02,2.791920e-02,2.615617e-02,2.464023e-02,2.331426e-02, & + & 2.213817e-02,2.108301e-02,2.012733e-02,1.925493e-02,1.845331e-02, & + & 1.771269e-02,1.702531e-02,1.638493e-02,1.578648e-02,1.522579e-02, & + & 1.469940e-02,1.420442e-02,1.373841e-02,1.329931e-02,1.288535e-02, & + & 1.249502e-02,1.212700e-02,1.178015e-02,1.145348e-02,1.114612e-02, & + & 1.085730e-02,1.058633e-02,1.033263e-02,1.009564e-02,9.874895e-03, & + & 9.669960e-03,9.480449e-03,9.306014e-03,9.146339e-03,9.001138e-03, & + & 8.870154e-03,8.753148e-03,8.649907e-03,8.560232e-03 / +! band 16 + data absice3(:,16) / 1.688344e-01,1.077072e-01, & + & 7.994467e-02,6.403862e-02,5.369850e-02,4.641582e-02,4.099331e-02, & + & 3.678724e-02,3.342069e-02,3.065831e-02,2.834557e-02,2.637680e-02, & + & 2.467733e-02,2.319286e-02,2.188299e-02,2.071701e-02,1.967121e-02, & + & 1.872692e-02,1.786931e-02,1.708641e-02,1.636846e-02,1.570743e-02, & + & 1.509665e-02,1.453052e-02,1.400433e-02,1.351407e-02,1.305631e-02, & + & 1.262810e-02,1.222688e-02,1.185044e-02,1.149683e-02,1.116436e-02, & + & 1.085153e-02,1.055701e-02,1.027961e-02,1.001831e-02,9.772141e-03, & + & 9.540280e-03,9.321966e-03,9.116517e-03,8.923315e-03,8.741803e-03, & + & 8.571472e-03,8.411860e-03,8.262543e-03,8.123136e-03 / + +!........................................! + end module module_radlw_cldprlw ! +!========================================! + +!> \defgroup module_radlw_kgbnn module_radlw_kgbnn +!! \ingroup module_radlw_main +!! @{ + +!*********************************************************************! +! descriptions for module_radlw_kgbnn ! +!.....................................................................! +! ********* the original program descriptions ********* ! +! ! +! rrtm longwave radiative transfer model ! +! atmospheric and environmental research, inc., cambridge, ma ! +! ! +! original version: e. j. mlawer, et al. ! +! revision for ncar ccm: michael j. iacono; september, 1998 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! ! +! this file contains 16 subroutines that include the absorption ! +! coefficients and other data for each of the 16 longwave spectral ! +! bands used in rrtm. here, the data are defined for 16 g-points, ! +! or sub-intervals, per band. these data are combined and weighted ! +! using a mapping procedure in routine rrtmg_lw_init to reduce the ! +! total number of g-points from 256 to 140 for use in the gcm. ! +! ! +! ********* ********* end description ********* ********* ! + +!> This module sets up absorption coefficients for band 01: 10-250 +!! cm-1 (low - h2o; high - h2o) +!========================================! + module module_radlw_kgb01 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG01 +! + implicit none +! + private +! +!> msa01=65 + integer, public :: MSA01 +!> msb01=235 + integer, public :: MSB01 +!> msf01=10 + integer, public :: MSF01 +!> mfr01=4 + integer, public :: MFR01 +!> mmn01=19 + integer, public :: MMN01 + parameter (MSA01=65, MSB01=235, MSF01=10, MFR01=4, MMN01=19) + +!> the array absa(NG01,65) = ka(NG01,5,13) contains absorption coefs +!! at the NG01=10 chosen g-values for a range of pressure levels>~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 1 to 13 and refers to the corresponding +!! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). +!! the third index, ig, goes from 1 to NG01=10, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG01,MSA01) + +!> the array absb(NG01,235) = kb(NG01,5,13:59) contains absorption coefs +!! at the NG01=10 chosen g-values for a range of pressure levels < ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG01=10, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG01,MSB01) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG01=10). + real (kind=kind_phys), public :: selfref(NG01,MSF01) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. The second index +!! runs over the g-channel (1 to NG01=10). + real (kind=kind_phys), public :: forref(NG01,MFR01) + +!> planck fraction mapping level: p = 212.7250 mbar, t = 223.06 k + real (kind=kind_phys), public :: fracrefa(NG01) + +!> planck fraction mapping level: p = 212.7250 mbar, t = 223.06 k +!! these planck fractions were calculated using lower atmosphere +!! parameters. + real (kind=kind_phys), public :: fracrefb(NG01) + + real (kind=kind_phys), public :: ka_mn2(NG01,MMN01) + + real (kind=kind_phys), public :: kb_mn2(NG01,MMN01) + + + data absa(:, 1:33) / & + & 1.193600e-01,3.513800e-01,1.330212e+00,4.853272e+00,2.284154e+01,& + & 1.116260e+02,3.333710e+02,5.746286e+02,1.040900e+03,1.207100e+03,& + & 1.212700e-01,3.550200e-01,1.319757e+00,4.786713e+00,2.252379e+01,& + & 1.106643e+02,3.327048e+02,5.759730e+02,1.060200e+03,1.241400e+03,& + & 1.229000e-01,3.577400e-01,1.304913e+00,4.713986e+00,2.219045e+01,& + & 1.095462e+02,3.330503e+02,5.768036e+02,1.071000e+03,1.306200e+03,& + & 1.232400e-01,3.589400e-01,1.287264e+00,4.641578e+00,2.184150e+01,& + & 1.083289e+02,3.336185e+02,5.766912e+02,1.085300e+03,1.364500e+03,& + & 1.230200e-01,3.574000e-01,1.270102e+00,4.570358e+00,2.147597e+01,& + & 1.070177e+02,3.341679e+02,5.763264e+02,1.101800e+03,1.412300e+03,& + & 9.366600e-02,2.874000e-01,1.087800e+00,4.070402e+00,2.066780e+01,& + & 1.128189e+02,3.643186e+02,6.406790e+02,1.215100e+03,1.467000e+03,& + & 9.633600e-02,2.896100e-01,1.081249e+00,4.015953e+00,2.037104e+01,& + & 1.118726e+02,3.626764e+02,6.438413e+02,1.230300e+03,1.488600e+03,& + & 9.845700e-02,2.911900e-01,1.070530e+00,3.958723e+00,2.005769e+01,& + & 1.107892e+02,3.613056e+02,6.471315e+02,1.234700e+03,1.554700e+03,& + & 9.915500e-02,2.926800e-01,1.056941e+00,3.903525e+00,1.973378e+01,& + & 1.095653e+02,3.604212e+02,6.481821e+02,1.247800e+03,1.626900e+03,& + & 9.933000e-02,2.912800e-01,1.043931e+00,3.849457e+00,1.939847e+01,& + & 1.082509e+02,3.588958e+02,6.490962e+02,1.268000e+03,1.687500e+03,& + & 7.348000e-02,2.314200e-01,8.884229e-01,3.396692e+00,1.845497e+01,& + & 1.129611e+02,3.888886e+02,7.209824e+02,1.419300e+03,1.784700e+03,& + & 7.557100e-02,2.349500e-01,8.832390e-01,3.355601e+00,1.819551e+01,& + & 1.121437e+02,3.866115e+02,7.231889e+02,1.432000e+03,1.799400e+03,& + & 7.799800e-02,2.359500e-01,8.760165e-01,3.313635e+00,1.791376e+01,& + & 1.110591e+02,3.847678e+02,7.268022e+02,1.438200e+03,1.839400e+03,& + & 7.961900e-02,2.373100e-01,8.666666e-01,3.270549e+00,1.762547e+01,& + & 1.097683e+02,3.839314e+02,7.282884e+02,1.446300e+03,1.909700e+03,& + & 8.000000e-02,2.382800e-01,8.565867e-01,3.227601e+00,1.731873e+01,& + & 1.084021e+02,3.820234e+02,7.300975e+02,1.460500e+03,1.986300e+03,& + & 5.841700e-02,1.868400e-01,7.315432e-01,2.847073e+00,1.640865e+01,& + & 1.118745e+02,4.055923e+02,8.105259e+02,1.634100e+03,2.140900e+03,& + & 6.006200e-02,1.909000e-01,7.294171e-01,2.817289e+00,1.618199e+01,& + & 1.111587e+02,4.034557e+02,8.105479e+02,1.647200e+03,2.171700e+03,& + & 6.215000e-02,1.938700e-01,7.241329e-01,2.786490e+00,1.593335e+01,& + & 1.101243e+02,4.023787e+02,8.111006e+02,1.660100e+03,2.195300e+03,& + & 6.402400e-02,1.935500e-01,7.186190e-01,2.754068e+00,1.566954e+01,& + & 1.088884e+02,4.019565e+02,8.109134e+02,1.670000e+03,2.243800e+03,& + & 6.494300e-02,1.951800e-01,7.112514e-01,2.718606e+00,1.539614e+01,& + & 1.075489e+02,4.000566e+02,8.119372e+02,1.684600e+03,2.305900e+03,& + & 4.674200e-02,1.510800e-01,6.037870e-01,2.391540e+00,1.447808e+01,& + & 1.092520e+02,4.197942e+02,9.043316e+02,1.878600e+03,2.541700e+03,& + & 4.817100e-02,1.552500e-01,6.047062e-01,2.369106e+00,1.429319e+01,& + & 1.086970e+02,4.171166e+02,9.027086e+02,1.890400e+03,2.591800e+03,& + & 4.984000e-02,1.583200e-01,6.017935e-01,2.346687e+00,1.407356e+01,& + & 1.078197e+02,4.157043e+02,9.017853e+02,1.902800e+03,2.619600e+03,& + & 5.158000e-02,1.590400e-01,5.980677e-01,2.321015e+00,1.384376e+01,& + & 1.066772e+02,4.152711e+02,9.004906e+02,1.910400e+03,2.659100e+03,& + & 5.297400e-02,1.596200e-01,5.934596e-01,2.292307e+00,1.360965e+01,& + & 1.054005e+02,4.138880e+02,8.994243e+02,1.925000e+03,2.712400e+03,& + & 3.709300e-02,1.221900e-01,4.978293e-01,2.006819e+00,1.264649e+01,& + & 1.052066e+02,4.339479e+02,9.995787e+02,2.149200e+03,3.024200e+03,& + & 3.871200e-02,1.258500e-01,5.008943e-01,1.991241e+00,1.249737e+01,& + & 1.047462e+02,4.305976e+02,9.975084e+02,2.166300e+03,3.068800e+03,& + & 4.003100e-02,1.290100e-01,4.998807e-01,1.974954e+00,1.232072e+01,& + & 1.039770e+02,4.285622e+02,9.957198e+02,2.177600e+03,3.111300e+03,& + & 4.147300e-02,1.309000e-01,4.976969e-01,1.954464e+00,1.213428e+01,& + & 1.030032e+02,4.274488e+02,9.935315e+02,2.183300e+03,3.153400e+03,& + & 4.286800e-02,1.315800e-01,4.946753e-01,1.931586e+00,1.193215e+01,& + & 1.018865e+02,4.255462e+02,9.915904e+02,2.194000e+03,3.207400e+03,& + & 2.951500e-02,9.874300e-02,4.095862e-01,1.678325e+00,1.093942e+01,& + & 9.973681e+01,4.480047e+02,1.096922e+03,2.431000e+03,3.649100e+03,& + & 3.111400e-02,1.018500e-01,4.133892e-01,1.669678e+00,1.082885e+01,& + & 9.942510e+01,4.437111e+02,1.093736e+03,2.456700e+03,3.669500e+03,& + & 3.234400e-02,1.050600e-01,4.146088e-01,1.657254e+00,1.069408e+01,& + & 9.885141e+01,4.403223e+02,1.091921e+03,2.472700e+03,3.693900e+03/ + data absa(:,34:65) / & + & 3.349600e-02,1.076300e-01,4.130025e-01,1.642205e+00,1.053808e+01,& + & 9.810418e+01,4.381100e+02,1.088989e+03,2.480400e+03,3.722900e+03,& + & 3.471500e-02,1.082000e-01,4.116794e-01,1.624081e+00,1.036624e+01,& + & 9.718125e+01,4.354195e+02,1.086363e+03,2.489100e+03,3.790600e+03,& + & 2.354800e-02,7.996600e-02,3.372900e-01,1.397936e+00,9.373395e+00,& + & 9.318855e+01,4.586371e+02,1.197788e+03,2.726100e+03,4.422300e+03,& + & 2.501200e-02,8.292200e-02,3.413721e-01,1.395030e+00,9.299425e+00,& + & 9.309348e+01,4.544842e+02,1.191700e+03,2.755200e+03,4.423200e+03,& + & 2.617600e-02,8.585900e-02,3.436078e-01,1.386746e+00,9.194904e+00,& + & 9.272558e+01,4.511219e+02,1.186527e+03,2.780300e+03,4.429700e+03,& + & 2.725300e-02,8.846200e-02,3.433522e-01,1.375277e+00,9.070149e+00,& + & 9.218125e+01,4.482803e+02,1.181951e+03,2.797000e+03,4.426800e+03,& + & 2.826300e-02,8.928200e-02,3.424004e-01,1.361628e+00,8.928498e+00,& + & 9.146506e+01,4.439193e+02,1.179378e+03,2.814100e+03,4.460800e+03,& + & 1.913600e-02,6.572600e-02,2.831169e-01,1.169990e+00,7.950728e+00,& + & 8.586195e+01,4.626912e+02,1.296161e+03,3.086700e+03,5.350200e+03,& + & 2.042000e-02,6.895400e-02,2.867222e-01,1.169708e+00,7.905115e+00,& + & 8.592706e+01,4.592619e+02,1.289998e+03,3.099400e+03,5.340000e+03,& + & 2.160700e-02,7.178600e-02,2.892116e-01,1.164632e+00,7.829963e+00,& + & 8.573880e+01,4.566414e+02,1.283186e+03,3.117000e+03,5.333800e+03,& + & 2.260700e-02,7.367800e-02,2.901103e-01,1.156284e+00,7.732484e+00,& + & 8.541199e+01,4.539296e+02,1.275164e+03,3.140200e+03,5.314000e+03,& + & 2.350200e-02,7.523300e-02,2.893705e-01,1.145144e+00,7.619259e+00,& + & 8.488612e+01,4.495377e+02,1.270284e+03,3.167900e+03,5.281600e+03,& + & 1.694700e-02,6.001100e-02,2.602021e-01,9.953047e-01,6.741739e+00,& + & 7.786549e+01,4.596587e+02,1.385127e+03,3.526900e+03,6.433300e+03,& + & 1.898600e-02,6.223000e-02,2.593436e-01,9.994519e-01,6.697210e+00,& + & 7.808293e+01,4.573176e+02,1.379413e+03,3.520400e+03,6.425700e+03,& + & 2.061700e-02,6.525400e-02,2.568719e-01,9.994221e-01,6.639799e+00,& + & 7.806792e+01,4.550929e+02,1.372582e+03,3.522500e+03,6.409300e+03,& + & 2.189600e-02,6.703100e-02,2.555179e-01,9.953572e-01,6.560791e+00,& + & 7.789237e+01,4.523494e+02,1.365789e+03,3.534500e+03,6.374400e+03,& + & 2.292800e-02,6.905200e-02,2.545633e-01,9.869050e-01,6.466288e+00,& + & 7.744399e+01,4.483808e+02,1.360537e+03,3.560100e+03,6.316200e+03,& + & 1.472400e-02,5.574300e-02,2.358630e-01,8.308066e-01,5.860127e+00,& + & 6.958767e+01,4.483488e+02,1.462860e+03,4.027100e+03,7.680500e+03,& + & 1.649000e-02,5.709900e-02,2.376393e-01,8.300004e-01,5.810899e+00,& + & 6.984032e+01,4.466177e+02,1.457308e+03,4.009600e+03,7.677800e+03,& + & 1.846800e-02,5.880200e-02,2.346714e-01,8.300051e-01,5.758537e+00,& + & 6.985918e+01,4.451580e+02,1.450433e+03,4.002400e+03,7.646600e+03,& + & 1.987500e-02,6.087500e-02,2.294956e-01,8.293927e-01,5.680820e+00,& + & 6.963681e+01,4.426020e+02,1.445881e+03,4.005200e+03,7.586500e+03,& + & 2.109500e-02,6.269000e-02,2.251394e-01,8.250843e-01,5.593849e+00,& + & 6.911537e+01,4.392723e+02,1.441286e+03,4.024600e+03,7.510600e+03,& + & 1.233200e-02,4.959800e-02,2.104042e-01,6.872789e-01,5.043961e+00,& + & 6.201474e+01,4.288498e+02,1.531632e+03,4.579800e+03,9.107300e+03,& + & 1.399200e-02,5.123400e-02,2.088251e-01,6.895375e-01,5.009066e+00,& + & 6.216300e+01,4.289138e+02,1.524358e+03,4.558500e+03,9.097200e+03,& + & 1.554900e-02,5.265900e-02,2.069473e-01,6.882566e-01,4.952448e+00,& + & 6.207713e+01,4.281520e+02,1.518488e+03,4.550300e+03,9.042800e+03,& + & 1.713700e-02,5.395100e-02,2.025723e-01,6.865166e-01,4.885107e+00,& + & 6.170330e+01,4.265277e+02,1.515506e+03,4.544200e+03,8.944500e+03,& + & 1.819000e-02,5.543100e-02,1.976387e-01,6.850500e-01,4.807973e+00,& + & 6.115202e+01,4.241421e+02,1.509950e+03,4.553200e+03,8.899700e+03,& + & 1.014400e-02,4.193800e-02,1.766623e-01,5.758703e-01,4.289268e+00,& + & 5.485925e+01,4.051891e+02,1.587371e+03,5.191100e+03,1.069900e+04,& + & 1.153900e-02,4.354000e-02,1.751071e-01,5.774601e-01,4.252882e+00,& + & 5.499755e+01,4.057529e+02,1.579188e+03,5.171700e+03,1.066800e+04,& + & 1.286100e-02,4.499000e-02,1.736541e-01,5.752734e-01,4.200737e+00,& + & 5.483432e+01,4.058467e+02,1.574155e+03,5.155300e+03,1.058000e+04,& + & 1.422500e-02,4.607400e-02,1.700864e-01,5.743388e-01,4.136504e+00,& + & 5.449538e+01,4.046072e+02,1.570843e+03,5.139500e+03,1.049300e+04,& + & 1.522400e-02,4.699900e-02,1.662093e-01,5.726528e-01,4.071345e+00,& + & 5.401111e+01,4.026425e+02,1.564332e+03,5.139700e+03,1.047300e+04/ + + + data absb(:, 1:30) / & + & 1.014400e-02,4.193800e-02,1.766623e-01,5.758703e-01,4.289268e+00,& + & 5.485925e+01,4.051891e+02,1.587371e+03,5.191100e+03,1.069900e+04,& + & 1.153900e-02,4.354000e-02,1.751071e-01,5.774601e-01,4.252882e+00,& + & 5.499755e+01,4.057529e+02,1.579188e+03,5.171700e+03,1.066800e+04,& + & 1.286100e-02,4.499000e-02,1.736541e-01,5.752734e-01,4.200737e+00,& + & 5.483432e+01,4.058467e+02,1.574155e+03,5.155300e+03,1.058000e+04,& + & 1.422500e-02,4.607400e-02,1.700864e-01,5.743388e-01,4.136504e+00,& + & 5.449538e+01,4.046072e+02,1.570843e+03,5.139500e+03,1.049300e+04,& + & 1.522400e-02,4.699900e-02,1.662093e-01,5.726528e-01,4.071345e+00,& + & 5.401111e+01,4.026425e+02,1.564332e+03,5.139700e+03,1.047300e+04,& + & 8.432700e-03,3.592800e-02,1.490077e-01,4.913412e-01,3.597405e+00,& + & 4.803045e+01,3.795583e+02,1.625123e+03,5.854700e+03,1.246900e+04,& + & 9.598900e-03,3.744700e-02,1.478901e-01,4.925064e-01,3.566675e+00,& + & 4.799924e+01,3.806922e+02,1.618788e+03,5.828500e+03,1.244300e+04,& + & 1.073400e-02,3.893500e-02,1.472122e-01,4.908730e-01,3.528394e+00,& + & 4.777584e+01,3.805881e+02,1.616526e+03,5.796300e+03,1.233800e+04,& + & 1.189000e-02,3.981600e-02,1.436156e-01,4.906764e-01,3.483612e+00,& + & 4.742774e+01,3.798169e+02,1.611271e+03,5.776600e+03,1.227900e+04,& + & 1.287200e-02,4.066600e-02,1.404734e-01,4.895451e-01,3.428964e+00,& + & 4.698086e+01,3.784275e+02,1.602900e+03,5.771500e+03,1.226000e+04,& + & 6.996700e-03,3.053900e-02,1.250961e-01,4.222657e-01,3.015113e+00,& + & 4.145260e+01,3.530337e+02,1.648415e+03,6.529800e+03,1.451300e+04,& + & 7.967600e-03,3.183600e-02,1.251029e-01,4.221786e-01,2.992619e+00,& + & 4.138936e+01,3.536972e+02,1.645508e+03,6.485800e+03,1.446600e+04,& + & 8.955900e-03,3.308600e-02,1.232455e-01,4.226819e-01,2.960251e+00,& + & 4.119461e+01,3.536062e+02,1.642435e+03,6.450600e+03,1.436100e+04,& + & 9.911900e-03,3.409600e-02,1.209816e-01,4.222659e-01,2.921781e+00,& + & 4.090617e+01,3.526166e+02,1.635296e+03,6.431200e+03,1.436000e+04,& + & 1.053300e-02,3.520300e-02,1.188503e-01,4.205343e-01,2.877553e+00,& + & 4.052653e+01,3.500126e+02,1.627152e+03,6.424300e+03,1.437600e+04,& + & 5.798800e-03,2.554200e-02,1.039381e-01,3.606133e-01,2.522203e+00,& + & 3.552795e+01,3.244815e+02,1.657291e+03,7.211700e+03,1.676900e+04,& + & 6.606800e-03,2.660700e-02,1.037445e-01,3.605956e-01,2.502999e+00,& + & 3.545863e+01,3.249187e+02,1.657190e+03,7.151000e+03,1.670600e+04,& + & 7.455300e-03,2.765400e-02,1.023324e-01,3.609507e-01,2.477357e+00,& + & 3.528161e+01,3.245654e+02,1.650994e+03,7.118900e+03,1.672700e+04,& + & 8.240200e-03,2.862200e-02,1.011007e-01,3.599312e-01,2.447236e+00,& + & 3.499769e+01,3.224892e+02,1.644137e+03,7.100000e+03,1.677500e+04,& + & 8.531000e-03,2.984900e-02,9.963746e-02,3.583706e-01,2.412229e+00,& + & 3.461698e+01,3.193512e+02,1.636774e+03,7.087000e+03,1.679500e+04,& + & 4.805500e-03,2.105900e-02,8.621721e-02,3.060988e-01,2.148814e+00,& + & 3.015527e+01,2.952775e+02,1.650209e+03,7.895300e+03,1.923300e+04,& + & 5.478100e-03,2.215900e-02,8.577229e-02,3.068463e-01,2.131646e+00,& + & 3.008982e+01,2.953814e+02,1.648675e+03,7.829100e+03,1.928500e+04,& + & 6.188400e-03,2.309700e-02,8.521250e-02,3.066416e-01,2.110389e+00,& + & 2.990235e+01,2.937504e+02,1.643788e+03,7.789000e+03,1.938700e+04,& + & 6.814800e-03,2.397000e-02,8.460518e-02,3.052170e-01,2.085996e+00,& + & 2.963261e+01,2.909075e+02,1.637469e+03,7.767000e+03,1.944500e+04,& + & 6.956300e-03,2.502100e-02,8.338927e-02,3.042380e-01,2.057979e+00,& + & 2.928569e+01,2.877027e+02,1.629993e+03,7.748900e+03,1.944300e+04,& + & 3.987700e-03,1.742000e-02,7.091391e-02,2.588769e-01,1.840773e+00,& + & 2.545239e+01,2.648904e+02,1.624103e+03,8.585500e+03,2.208200e+04,& + & 4.542300e-03,1.834400e-02,7.089205e-02,2.594402e-01,1.828667e+00,& + & 2.535451e+01,2.641407e+02,1.623490e+03,8.520800e+03,2.214100e+04,& + & 5.132500e-03,1.922300e-02,7.075569e-02,2.587811e-01,1.812077e+00,& + & 2.516766e+01,2.623628e+02,1.619933e+03,8.466800e+03,2.229600e+04,& + & 5.509800e-03,2.009200e-02,7.017199e-02,2.581146e-01,1.790366e+00,& + & 2.491532e+01,2.598497e+02,1.615516e+03,8.420600e+03,2.236200e+04,& + & 5.694600e-03,2.088700e-02,6.927422e-02,2.574991e-01,1.765575e+00,& + & 2.459914e+01,2.571600e+02,1.606768e+03,8.398000e+03,2.237300e+04/ + data absb(:,31:60) / & + & 3.311000e-03,1.452700e-02,5.874414e-02,2.195227e-01,1.581633e+00,& + & 2.131953e+01,2.335208e+02,1.581395e+03,9.267400e+03,2.539200e+04,& + & 3.788000e-03,1.529400e-02,5.908161e-02,2.197548e-01,1.575160e+00,& + & 2.120052e+01,2.326136e+02,1.581078e+03,9.204900e+03,2.541900e+04,& + & 4.280600e-03,1.607100e-02,5.910353e-02,2.192417e-01,1.560617e+00,& + & 2.102725e+01,2.310802e+02,1.579816e+03,9.132600e+03,2.553300e+04,& + & 4.499600e-03,1.695000e-02,5.873994e-02,2.188461e-01,1.542154e+00,& + & 2.080521e+01,2.289780e+02,1.575271e+03,9.073600e+03,2.562300e+04,& + & 4.678400e-03,1.766000e-02,5.814696e-02,2.185560e-01,1.521241e+00,& + & 2.054420e+01,2.265454e+02,1.564930e+03,9.052500e+03,2.562200e+04,& + & 2.763100e-03,1.205700e-02,4.875163e-02,1.848414e-01,1.357815e+00,& + & 1.782403e+01,2.030134e+02,1.521786e+03,9.910800e+03,2.922700e+04,& + & 3.175600e-03,1.274000e-02,4.912349e-02,1.848562e-01,1.350247e+00,& + & 1.771222e+01,2.023551e+02,1.523089e+03,9.835600e+03,2.922800e+04,& + & 3.580300e-03,1.337500e-02,4.913834e-02,1.846480e-01,1.336997e+00,& + & 1.755870e+01,2.010689e+02,1.522434e+03,9.763600e+03,2.923200e+04,& + & 3.710000e-03,1.421200e-02,4.891038e-02,1.844641e-01,1.322531e+00,& + & 1.736359e+01,1.993669e+02,1.515955e+03,9.714100e+03,2.927200e+04,& + & 3.859800e-03,1.483600e-02,4.855203e-02,1.846215e-01,1.305869e+00,& + & 1.714645e+01,1.972381e+02,1.504126e+03,9.690500e+03,2.928600e+04,& + & 2.311300e-03,1.002400e-02,4.045422e-02,1.549941e-01,1.160499e+00,& + & 1.501422e+01,1.738649e+02,1.446471e+03,1.048600e+04,3.368900e+04,& + & 2.658400e-03,1.063000e-02,4.076300e-02,1.550789e-01,1.152598e+00,& + & 1.489769e+01,1.734622e+02,1.448553e+03,1.041500e+04,3.355600e+04,& + & 2.934700e-03,1.120200e-02,4.081501e-02,1.551843e-01,1.141220e+00,& + & 1.474152e+01,1.726405e+02,1.446026e+03,1.035500e+04,3.351100e+04,& + & 3.048100e-03,1.191800e-02,4.068593e-02,1.554098e-01,1.128795e+00,& + & 1.456505e+01,1.711720e+02,1.438740e+03,1.031700e+04,3.343600e+04,& + & 3.182400e-03,1.246000e-02,4.050209e-02,1.553722e-01,1.115211e+00,& + & 1.437159e+01,1.692746e+02,1.428120e+03,1.028700e+04,3.339900e+04,& + & 1.951000e-03,8.358600e-03,3.349484e-02,1.294550e-01,9.844043e-01,& + & 1.268797e+01,1.479302e+02,1.356798e+03,1.098500e+04,3.864000e+04,& + & 2.238900e-03,8.872100e-03,3.371721e-02,1.297402e-01,9.772945e-01,& + & 1.256544e+01,1.475124e+02,1.358508e+03,1.092000e+04,3.849400e+04,& + & 2.407600e-03,9.431900e-03,3.378756e-02,1.299560e-01,9.678937e-01,& + & 1.242097e+01,1.465223e+02,1.355698e+03,1.087500e+04,3.830400e+04,& + & 2.510600e-03,1.001600e-02,3.370110e-02,1.303530e-01,9.571356e-01,& + & 1.226686e+01,1.450350e+02,1.349453e+03,1.084500e+04,3.811800e+04,& + & 2.629300e-03,1.045100e-02,3.363421e-02,1.302384e-01,9.469851e-01,& + & 1.208673e+01,1.433761e+02,1.339821e+03,1.080400e+04,3.800600e+04,& + & 1.649000e-03,7.002300e-03,2.770825e-02,1.081529e-01,8.306480e-01,& + & 1.088455e+01,1.238507e+02,1.257243e+03,1.139800e+04,4.413500e+04,& + & 1.883300e-03,7.429200e-03,2.788541e-02,1.084674e-01,8.251828e-01,& + & 1.078199e+01,1.232477e+02,1.258616e+03,1.134200e+04,4.389400e+04,& + & 1.983900e-03,7.942500e-03,2.796562e-02,1.087786e-01,8.173557e-01,& + & 1.065735e+01,1.223359e+02,1.256343e+03,1.130800e+04,4.360000e+04,& + & 2.070700e-03,8.400100e-03,2.796006e-02,1.090250e-01,8.089808e-01,& + & 1.050621e+01,1.210715e+02,1.250795e+03,1.127600e+04,4.319100e+04,& + & 2.175700e-03,8.666800e-03,2.797716e-02,1.088907e-01,8.005203e-01,& + & 1.035172e+01,1.195737e+02,1.242990e+03,1.123400e+04,4.306300e+04,& + & 1.392100e-03,5.880500e-03,2.298321e-02,9.053824e-02,7.005726e-01,& + & 9.421341e+00,1.022069e+02,1.151962e+03,1.170900e+04,5.012000e+04,& + & 1.582200e-03,6.241400e-03,2.314073e-02,9.089147e-02,6.958805e-01,& + & 9.315166e+00,1.017995e+02,1.152992e+03,1.167200e+04,4.972300e+04,& + & 1.641600e-03,6.685500e-03,2.323652e-02,9.122551e-02,6.897028e-01,& + & 9.197809e+00,1.009725e+02,1.151422e+03,1.164500e+04,4.927600e+04,& + & 1.713600e-03,7.038000e-03,2.329659e-02,9.131888e-02,6.832330e-01,& + & 9.071070e+00,9.993155e+01,1.146662e+03,1.161400e+04,4.884700e+04,& + & 1.801900e-03,7.188100e-03,2.337516e-02,9.129986e-02,6.764224e-01,& + & 8.937166e+00,9.876683e+01,1.138527e+03,1.157600e+04,4.855000e+04/ + data absb(:,61:90) / & + & 1.175400e-03,4.930000e-03,1.904351e-02,7.569116e-02,5.892978e-01,& + & 8.179385e+00,8.385544e+01,1.045843e+03,1.191400e+04,5.640000e+04,& + & 1.298600e-03,5.265900e-03,1.920163e-02,7.602868e-02,5.852882e-01,& + & 8.083537e+00,8.349017e+01,1.046830e+03,1.189600e+04,5.582400e+04,& + & 1.354600e-03,5.613000e-03,1.933810e-02,7.626621e-02,5.803157e-01,& + & 7.974722e+00,8.289613e+01,1.044506e+03,1.187800e+04,5.526000e+04,& + & 1.418400e-03,5.813900e-03,1.944791e-02,7.639689e-02,5.750631e-01,& + & 7.859206e+00,8.212041e+01,1.038509e+03,1.186200e+04,5.475300e+04,& + & 1.495100e-03,5.974400e-03,1.950885e-02,7.639370e-02,5.700702e-01,& + & 7.747555e+00,8.116056e+01,1.029581e+03,1.183700e+04,5.431800e+04,& + & 9.938400e-04,4.134600e-03,1.578688e-02,6.312154e-02,4.935942e-01,& + & 7.095015e+00,6.910643e+01,9.396095e+02,1.204000e+04,6.274200e+04,& + & 1.069200e-03,4.426800e-03,1.594301e-02,6.348456e-02,4.901479e-01,& + & 7.010754e+00,6.867417e+01,9.402294e+02,1.203100e+04,6.210100e+04,& + & 1.118100e-03,4.699400e-03,1.608285e-02,6.361676e-02,4.865586e-01,& + & 6.918640e+00,6.808493e+01,9.363489e+02,1.202900e+04,6.144900e+04,& + & 1.176700e-03,4.818900e-03,1.618333e-02,6.376781e-02,4.830741e-01,& + & 6.817125e+00,6.742993e+01,9.297413e+02,1.202000e+04,6.083800e+04,& + & 1.242300e-03,4.970000e-03,1.623073e-02,6.383266e-02,4.795228e-01,& + & 6.722241e+00,6.661450e+01,9.218653e+02,1.199800e+04,6.024600e+04,& + & 8.393200e-04,3.447800e-03,1.304439e-02,5.236301e-02,4.109024e-01,& + & 6.129192e+00,5.836709e+01,8.339681e+02,1.207100e+04,6.925600e+04,& + & 8.844600e-04,3.694900e-03,1.317900e-02,5.263729e-02,4.085678e-01,& + & 6.056998e+00,5.780937e+01,8.326719e+02,1.208100e+04,6.849800e+04,& + & 9.249600e-04,3.876000e-03,1.330284e-02,5.281921e-02,4.061403e-01,& + & 5.975415e+00,5.726530e+01,8.285338e+02,1.208900e+04,6.775500e+04,& + & 9.755500e-04,3.980000e-03,1.337050e-02,5.300853e-02,4.037396e-01,& + & 5.890972e+00,5.664834e+01,8.231204e+02,1.208500e+04,6.703500e+04,& + & 1.028600e-03,4.108300e-03,1.341038e-02,5.308676e-02,4.008395e-01,& + & 5.816136e+00,5.589261e+01,8.169800e+02,1.206900e+04,6.625500e+04,& + & 7.065500e-04,2.866200e-03,1.073488e-02,4.328003e-02,3.406788e-01,& + & 5.256366e+00,5.022765e+01,7.314061e+02,1.202100e+04,7.584500e+04,& + & 7.341800e-04,3.072000e-03,1.084328e-02,4.351710e-02,3.392009e-01,& + & 5.193073e+00,4.977106e+01,7.291455e+02,1.205800e+04,7.489000e+04,& + & 7.664700e-04,3.185500e-03,1.094058e-02,4.371445e-02,3.375325e-01,& + & 5.123839e+00,4.923589e+01,7.261499e+02,1.206800e+04,7.403800e+04,& + & 8.085300e-04,3.284400e-03,1.098872e-02,4.388375e-02,3.355316e-01,& + & 5.061271e+00,4.866184e+01,7.222318e+02,1.206800e+04,7.312500e+04,& + & 8.509100e-04,3.384100e-03,1.102586e-02,4.400720e-02,3.331646e-01,& + & 4.996233e+00,4.803567e+01,7.173148e+02,1.207300e+04,7.211900e+04,& + & 5.801600e-04,2.370000e-03,8.752782e-03,3.541844e-02,2.799500e-01,& + & 4.447780e+00,4.314701e+01,6.374967e+02,1.188600e+04,8.241600e+04,& + & 6.055800e-04,2.528900e-03,8.827337e-03,3.562845e-02,2.788537e-01,& + & 4.394529e+00,4.279644e+01,6.360259e+02,1.194000e+04,8.129200e+04,& + & 6.343900e-04,2.604900e-03,8.891873e-03,3.581436e-02,2.775997e-01,& + & 4.342493e+00,4.232577e+01,6.341818e+02,1.197000e+04,8.017200e+04,& + & 6.694000e-04,2.684600e-03,8.928581e-03,3.594100e-02,2.760088e-01,& + & 4.292497e+00,4.183288e+01,6.311666e+02,1.199500e+04,7.898800e+04,& + & 7.018700e-04,2.755500e-03,8.948481e-03,3.605503e-02,2.742040e-01,& + & 4.244228e+00,4.132105e+01,6.275835e+02,1.201700e+04,7.773300e+04,& + & 4.775700e-04,1.952900e-03,7.093579e-03,2.886526e-02,2.291023e-01,& + & 3.733051e+00,3.716626e+01,5.522108e+02,1.167600e+04,8.892300e+04,& + & 4.992400e-04,2.073400e-03,7.146847e-03,2.904003e-02,2.281474e-01,& + & 3.694653e+00,3.679907e+01,5.522026e+02,1.174900e+04,8.752400e+04,& + & 5.244200e-04,2.123600e-03,7.191431e-03,2.919272e-02,2.272006e-01,& + & 3.653622e+00,3.642779e+01,5.512116e+02,1.180800e+04,8.611400e+04,& + & 5.539700e-04,2.176600e-03,7.212682e-03,2.930211e-02,2.258024e-01,& + & 3.615500e+00,3.597555e+01,5.496286e+02,1.186100e+04,8.463300e+04,& + & 5.782900e-04,2.227900e-03,7.223310e-03,2.939120e-02,2.244613e-01,& + & 3.576634e+00,3.559861e+01,5.473504e+02,1.190800e+04,8.308300e+04/ + data absb(:, 91:120) / & + & 3.942000e-04,1.595100e-03,5.698356e-03,2.332178e-02,1.859950e-01,& + & 3.102976e+00,3.188564e+01,4.770407e+02,1.141600e+04,9.512800e+04,& + & 4.112300e-04,1.676100e-03,5.729873e-03,2.346600e-02,1.852558e-01,& + & 3.074604e+00,3.156989e+01,4.778549e+02,1.151500e+04,9.347400e+04,& + & 4.329800e-04,1.710300e-03,5.756101e-03,2.358032e-02,1.843056e-01,& + & 3.042590e+00,3.123311e+01,4.774408e+02,1.160900e+04,9.140900e+04,& + & 4.556300e-04,1.745800e-03,5.771376e-03,2.366834e-02,1.832970e-01,& + & 3.013996e+00,3.090483e+01,4.770090e+02,1.169400e+04,8.960900e+04,& + & 4.743700e-04,1.785600e-03,5.769516e-03,2.373973e-02,1.823908e-01,& + & 2.985547e+00,3.068286e+01,4.760052e+02,1.176400e+04,8.812100e+04,& + & 3.257100e-04,1.296500e-03,4.573862e-03,1.882510e-02,1.508330e-01,& + & 2.570632e+00,2.739472e+01,4.103610e+02,1.110800e+04,1.010900e+05,& + & 3.396000e-04,1.354600e-03,4.587108e-03,1.894185e-02,1.501852e-01,& + & 2.549390e+00,2.709442e+01,4.117716e+02,1.125000e+04,9.905600e+04,& + & 3.570400e-04,1.376700e-03,4.606381e-03,1.902091e-02,1.494812e-01,& + & 2.526947e+00,2.682763e+01,4.123097e+02,1.138500e+04,9.695900e+04,& + & 3.738700e-04,1.401600e-03,4.610044e-03,1.909221e-02,1.488003e-01,& + & 2.506266e+00,2.660391e+01,4.125809e+02,1.150300e+04,9.483800e+04,& + & 3.884900e-04,1.434500e-03,4.614761e-03,1.913289e-02,1.480705e-01,& + & 2.484274e+00,2.642290e+01,4.131173e+02,1.159800e+04,9.272800e+04,& + & 2.674100e-04,1.049700e-03,3.664402e-03,1.518707e-02,1.221016e-01,& + & 2.123546e+00,2.344244e+01,3.531183e+02,1.077300e+04,1.066800e+05,& + & 2.802700e-04,1.091600e-03,3.669808e-03,1.526438e-02,1.215909e-01,& + & 2.108387e+00,2.322781e+01,3.542442e+02,1.096300e+04,1.042600e+05,& + & 2.934900e-04,1.106100e-03,3.680235e-03,1.532142e-02,1.211227e-01,& + & 2.093371e+00,2.303970e+01,3.554292e+02,1.114100e+04,1.017700e+05,& + & 3.063600e-04,1.125900e-03,3.684176e-03,1.536637e-02,1.205480e-01,& + & 2.078998e+00,2.287805e+01,3.569159e+02,1.129400e+04,9.930900e+04,& + & 3.179000e-04,1.149000e-03,3.683579e-03,1.539177e-02,1.200807e-01,& + & 2.062922e+00,2.274045e+01,3.583265e+02,1.142500e+04,9.686400e+04,& + & 2.202900e-04,8.526300e-04,2.949498e-03,1.230204e-02,9.932941e-02,& + & 1.760430e+00,2.010163e+01,3.032903e+02,1.043800e+04,1.118100e+05,& + & 2.307300e-04,8.843900e-04,2.951551e-03,1.236370e-02,9.893663e-02,& + & 1.750234e+00,1.995453e+01,3.049126e+02,1.067300e+04,1.090100e+05,& + & 2.412000e-04,8.929900e-04,2.956847e-03,1.240749e-02,9.859748e-02,& + & 1.739739e+00,1.984498e+01,3.069168e+02,1.088500e+04,1.061900e+05,& + & 2.511600e-04,9.090100e-04,2.960290e-03,1.243701e-02,9.822059e-02,& + & 1.728290e+00,1.973887e+01,3.089631e+02,1.107700e+04,1.033900e+05,& + & 2.597700e-04,9.268300e-04,2.958323e-03,1.244894e-02,9.791181e-02,& + & 1.718001e+00,1.965007e+01,3.108524e+02,1.124900e+04,1.006200e+05,& + & 1.809200e-04,6.896100e-04,2.375210e-03,9.968060e-03,8.084893e-02,& + & 1.459105e+00,1.719463e+01,2.605315e+02,1.008900e+04,1.166900e+05,& + & 1.891300e-04,7.145200e-04,2.376033e-03,1.001759e-02,8.058918e-02,& + & 1.452526e+00,1.713484e+01,2.629484e+02,1.036800e+04,1.135200e+05,& + & 1.972300e-04,7.212500e-04,2.380142e-03,1.004500e-02,8.034907e-02,& + & 1.445624e+00,1.706816e+01,2.656506e+02,1.062100e+04,1.103600e+05,& + & 2.049000e-04,7.340800e-04,2.379463e-03,1.006769e-02,8.011265e-02,& + & 1.438217e+00,1.700435e+01,2.679469e+02,1.085200e+04,1.072400e+05,& + & 2.112000e-04,7.471800e-04,2.377516e-03,1.007276e-02,7.988777e-02,& + & 1.431088e+00,1.699218e+01,2.704497e+02,1.106400e+04,1.041400e+05,& + & 1.477500e-04,5.553800e-04,1.919071e-03,8.076979e-03,6.594389e-02,& + & 1.210502e+00,1.470411e+01,2.243540e+02,9.720100e+03,1.214300e+05,& + & 1.542600e-04,5.745400e-04,1.917172e-03,8.119503e-03,6.574594e-02,& + & 1.206502e+00,1.468387e+01,2.272886e+02,1.004100e+04,1.174100e+05,& + & 1.603800e-04,5.846800e-04,1.916133e-03,8.143572e-03,6.561601e-02,& + & 1.202069e+00,1.465903e+01,2.301404e+02,1.034100e+04,1.144400e+05,& + & 1.664300e-04,5.929500e-04,1.915537e-03,8.162862e-03,6.545745e-02,& + & 1.197894e+00,1.465898e+01,2.327614e+02,1.061400e+04,1.109900e+05,& + & 1.713700e-04,6.031200e-04,1.913701e-03,8.166842e-03,6.530503e-02,& + & 1.193597e+00,1.469704e+01,2.359650e+02,1.086100e+04,1.075900e+05/ + data absb(:,121:150) / & + & 1.200500e-04,4.468700e-04,1.557327e-03,6.562460e-03,5.399734e-02,& + & 1.006517e+00,1.259629e+01,1.929111e+02,9.316300e+03,1.262900e+05,& + & 1.253400e-04,4.622800e-04,1.555399e-03,6.601992e-03,5.388511e-02,& + & 1.004870e+00,1.258826e+01,1.960260e+02,9.680500e+03,1.224800e+05,& + & 1.300100e-04,4.748500e-04,1.550221e-03,6.629754e-03,5.380455e-02,& + & 1.002335e+00,1.262133e+01,1.991228e+02,1.002400e+04,1.186800e+05,& + & 1.349500e-04,4.805200e-04,1.550478e-03,6.642861e-03,5.370264e-02,& + & 1.000943e+00,1.265011e+01,2.022261e+02,1.034200e+04,1.149200e+05,& + & 1.388800e-04,4.882600e-04,1.548488e-03,6.646531e-03,5.361208e-02,& + & 9.986561e-01,1.271110e+01,2.057089e+02,1.063200e+04,1.112000e+05,& + & 9.756000e-05,3.591100e-04,1.262637e-03,5.325036e-03,4.417375e-02,& + & 8.352630e-01,1.074509e+01,1.662733e+02,8.927200e+03,1.307700e+05,& + & 1.017700e-04,3.717600e-04,1.260920e-03,5.360477e-03,4.409955e-02,& + & 8.352534e-01,1.076629e+01,1.695237e+02,9.330700e+03,1.266900e+05,& + & 1.054000e-04,3.827800e-04,1.254620e-03,5.389449e-03,4.405623e-02,& + & 8.353272e-01,1.081340e+01,1.725752e+02,9.716900e+03,1.226000e+05,& + & 1.092400e-04,3.899800e-04,1.253350e-03,5.398355e-03,4.400527e-02,& + & 8.355897e-01,1.088650e+01,1.758759e+02,1.007400e+04,1.185700e+05,& + & 1.125600e-04,3.948700e-04,1.251613e-03,5.403536e-03,4.397471e-02,& + & 8.350216e-01,1.096663e+01,1.797667e+02,1.040200e+04,1.145800e+05,& + & 7.934400e-05,2.882500e-04,1.022358e-03,4.312781e-03,3.608283e-02,& + & 6.925135e-01,9.126984e+00,1.440777e+02,8.552600e+03,1.341300e+05,& + & 8.261500e-05,2.986800e-04,1.020038e-03,4.345658e-03,3.603680e-02,& + & 6.937049e-01,9.189947e+00,1.470725e+02,8.999300e+03,1.301300e+05,& + & 8.536800e-05,3.076100e-04,1.015631e-03,4.370856e-03,3.602297e-02,& + & 6.944242e-01,9.258099e+00,1.502720e+02,9.420600e+03,1.262000e+05,& + & 8.840500e-05,3.150000e-04,1.012791e-03,4.382561e-03,3.601653e-02,& + & 6.960847e-01,9.343501e+00,1.538426e+02,9.815400e+03,1.219100e+05,& + & 9.118600e-05,3.206500e-04,1.010833e-03,4.388161e-03,3.601917e-02,& + & 6.967398e-01,9.435754e+00,1.577634e+02,1.018000e+04,1.176800e+05,& + & 6.457500e-05,2.322100e-04,8.343751e-04,3.520436e-03,2.966079e-02,& + & 5.764234e-01,7.784254e+00,1.248983e+02,8.149400e+03,1.390500e+05,& + & 6.700800e-05,2.411700e-04,8.332454e-04,3.548501e-03,2.967798e-02,& + & 5.788651e-01,7.850520e+00,1.278580e+02,8.635500e+03,1.344800e+05,& + & 6.936900e-05,2.491600e-04,8.293472e-04,3.572675e-03,2.968373e-02,& + & 5.807767e-01,7.939411e+00,1.308233e+02,9.096200e+03,1.299300e+05,& + & 7.174000e-05,2.553900e-04,8.266836e-04,3.585559e-03,2.971778e-02,& + & 5.830478e-01,8.031159e+00,1.344044e+02,9.528500e+03,1.254000e+05,& + & 7.400300e-05,2.614900e-04,8.241710e-04,3.590482e-03,2.974305e-02,& + & 5.849549e-01,8.137189e+00,1.384939e+02,9.930500e+03,1.209500e+05,& + & 5.269700e-05,1.871100e-04,6.822103e-04,2.873991e-03,2.439278e-02,& + & 4.801886e-01,6.623899e+00,1.089390e+02,7.752900e+03,1.430200e+05,& + & 5.433400e-05,1.952000e-04,6.808557e-04,2.898857e-03,2.443601e-02,& + & 4.835084e-01,6.709445e+00,1.115537e+02,8.278800e+03,1.382200e+05,& + & 5.640900e-05,2.018400e-04,6.778570e-04,2.920672e-03,2.446923e-02,& + & 4.857216e-01,6.802094e+00,1.145488e+02,8.776600e+03,1.334600e+05,& + & 5.822800e-05,2.073200e-04,6.751046e-04,2.935994e-03,2.451587e-02,& + & 4.886329e-01,6.913816e+00,1.178088e+02,9.244600e+03,1.287300e+05,& + & 6.001400e-05,2.120800e-04,6.729793e-04,2.941133e-03,2.455875e-02,& + & 4.909497e-01,7.025080e+00,1.219840e+02,9.677300e+03,1.240700e+05,& + & 4.308900e-05,1.504400e-04,5.581555e-04,2.343711e-03,2.006303e-02,& + & 3.996826e-01,5.631420e+00,9.493945e+01,7.376000e+03,1.467500e+05,& + & 4.412000e-05,1.580600e-04,5.561794e-04,2.364997e-03,2.011630e-02,& + & 4.027770e-01,5.718851e+00,9.776510e+01,7.933900e+03,1.417300e+05,& + & 4.581500e-05,1.634900e-04,5.536429e-04,2.385704e-03,2.015340e-02,& + & 4.059117e-01,5.832478e+00,1.008087e+02,8.468100e+03,1.367300e+05,& + & 4.721800e-05,1.681300e-04,5.513420e-04,2.399312e-03,2.021198e-02,& + & 4.088943e-01,5.935563e+00,1.040143e+02,8.968100e+03,1.318200e+05,& + & 4.865800e-05,1.718600e-04,5.493186e-04,2.404927e-03,2.027353e-02,& + & 4.115796e-01,6.053133e+00,1.077793e+02,9.434000e+03,1.269800e+05/ + data absb(:,151:180) / & + & 3.442900e-05,1.214700e-04,4.567436e-04,1.911139e-03,1.649618e-02,& + & 3.323881e-01,4.776971e+00,8.275173e+01,6.981900e+03,1.504700e+05,& + & 3.584700e-05,1.275400e-04,4.550413e-04,1.928533e-03,1.655344e-02,& + & 3.358899e-01,4.878547e+00,8.558285e+01,7.572100e+03,1.452800e+05,& + & 3.714900e-05,1.320200e-04,4.535401e-04,1.946546e-03,1.659720e-02,& + & 3.389940e-01,4.982463e+00,8.861048e+01,8.140900e+03,1.401000e+05,& + & 3.838000e-05,1.360300e-04,4.507841e-04,1.960422e-03,1.665736e-02,& + & 3.423356e-01,5.095083e+00,9.199958e+01,8.674600e+03,1.350000e+05,& + & 3.947900e-05,1.392200e-04,4.488471e-04,1.967194e-03,1.672433e-02,& + & 3.452449e-01,5.220169e+00,9.573755e+01,9.169100e+03,1.294100e+05,& + & 2.716900e-05,9.763100e-05,3.734186e-04,1.557397e-03,1.355455e-02,& + & 2.761778e-01,4.047495e+00,7.234216e+01,6.582700e+03,1.541300e+05,& + & 2.930000e-05,1.025400e-04,3.728353e-04,1.571498e-03,1.360995e-02,& + & 2.794650e-01,4.145757e+00,7.515471e+01,7.208100e+03,1.487800e+05,& + & 3.012800e-05,1.066400e-04,3.711150e-04,1.586524e-03,1.366249e-02,& + & 2.826371e-01,4.258321e+00,7.803878e+01,7.808400e+03,1.434400e+05,& + & 3.117500e-05,1.100000e-04,3.688479e-04,1.599502e-03,1.372245e-02,& + & 2.861057e-01,4.370794e+00,8.134862e+01,8.374000e+03,1.381600e+05,& + & 3.202100e-05,1.127800e-04,3.668478e-04,1.607007e-03,1.378983e-02,& + & 2.890558e-01,4.498500e+00,8.519766e+01,8.898200e+03,1.330000e+05,& + & 2.141100e-05,7.855100e-05,3.049498e-04,1.267381e-03,1.111307e-02,& + & 2.291533e-01,3.427174e+00,6.362709e+01,6.190100e+03,1.576400e+05,& + & 2.378200e-05,8.238600e-05,3.055002e-04,1.278267e-03,1.117145e-02,& + & 2.322803e-01,3.521659e+00,6.618382e+01,6.848500e+03,1.521400e+05,& + & 2.436000e-05,8.625200e-05,3.038523e-04,1.289904e-03,1.122568e-02,& + & 2.352589e-01,3.633312e+00,6.887787e+01,7.479500e+03,1.466500e+05,& + & 2.528700e-05,8.882100e-05,3.016269e-04,1.303037e-03,1.127863e-02,& + & 2.385093e-01,3.740191e+00,7.207152e+01,8.078600e+03,1.405500e+05,& + & 2.602500e-05,9.111300e-05,2.998465e-04,1.309757e-03,1.133820e-02,& + & 2.415825e-01,3.863186e+00,7.597735e+01,8.630300e+03,1.358600e+05,& + & 1.675400e-05,6.308200e-05,2.491341e-04,1.029960e-03,9.105503e-03,& + & 1.899080e-01,2.891210e+00,5.610943e+01,5.802400e+03,1.610400e+05,& + & 1.879500e-05,6.621700e-05,2.496823e-04,1.039676e-03,9.157697e-03,& + & 1.926864e-01,2.984048e+00,5.852342e+01,6.480100e+03,1.554600e+05,& + & 1.993100e-05,6.926400e-05,2.489131e-04,1.049251e-03,9.209641e-03,& + & 1.955293e-01,3.090055e+00,6.120483e+01,7.141300e+03,1.498100e+05,& + & 2.053200e-05,7.159700e-05,2.471870e-04,1.059299e-03,9.263077e-03,& + & 1.986097e-01,3.197479e+00,6.413690e+01,7.770200e+03,1.442200e+05,& + & 2.114500e-05,7.359600e-05,2.451926e-04,1.067084e-03,9.317358e-03,& + & 2.016349e-01,3.314719e+00,6.776067e+01,8.354800e+03,1.387400e+05,& + & 1.306700e-05,5.066800e-05,2.048159e-04,8.357262e-04,7.463298e-03,& + & 1.572614e-01,2.433440e+00,4.949183e+01,5.393800e+03,1.645300e+05,& + & 1.475700e-05,5.314800e-05,2.047054e-04,8.459937e-04,7.514236e-03,& + & 1.597814e-01,2.525746e+00,5.193193e+01,6.087000e+03,1.589100e+05,& + & 1.624700e-05,5.564800e-05,2.044213e-04,8.537071e-04,7.562223e-03,& + & 1.624012e-01,2.624435e+00,5.431958e+01,6.777800e+03,1.531400e+05,& + & 1.657500e-05,5.802300e-05,2.031808e-04,8.616870e-04,7.612026e-03,& + & 1.653270e-01,2.730764e+00,5.716447e+01,7.434100e+03,1.474200e+05,& + & 1.718400e-05,5.946000e-05,2.011333e-04,8.698032e-04,7.665678e-03,& + & 1.680835e-01,2.842383e+00,6.064289e+01,8.049500e+03,1.418000e+05,& + & 1.019300e-05,4.072300e-05,1.687541e-04,6.762672e-04,6.099954e-03,& + & 1.299364e-01,2.045879e+00,4.381018e+01,5.009200e+03,1.677500e+05,& + & 1.152700e-05,4.265200e-05,1.678015e-04,6.869052e-04,6.152895e-03,& + & 1.322824e-01,2.129371e+00,4.620675e+01,5.705200e+03,1.621900e+05,& + & 1.284100e-05,4.471400e-05,1.675079e-04,6.936401e-04,6.198200e-03,& + & 1.346526e-01,2.222329e+00,4.856062e+01,6.411100e+03,1.564000e+05,& + & 1.359900e-05,4.656200e-05,1.668700e-04,6.998837e-04,6.240238e-03,& + & 1.371500e-01,2.318396e+00,5.122704e+01,7.096200e+03,1.505400e+05,& + & 1.394600e-05,4.811000e-05,1.651901e-04,7.065099e-04,6.285452e-03,& + & 1.398677e-01,2.423966e+00,5.433575e+01,7.740900e+03,1.448100e+05/ + data absb(:,181:210) / & + & 7.941700e-06,3.257700e-05,1.389622e-04,5.463982e-04,4.968668e-03,& + & 1.072193e-01,1.706997e+00,3.894784e+01,4.604500e+03,1.710400e+05,& + & 8.997100e-06,3.424100e-05,1.382027e-04,5.553115e-04,5.019336e-03,& + & 1.091856e-01,1.786728e+00,4.112940e+01,5.344600e+03,1.652800e+05,& + & 1.011200e-05,3.584500e-05,1.372852e-04,5.627179e-04,5.060776e-03,& + & 1.112935e-01,1.875282e+00,4.359930e+01,6.046900e+03,1.595700e+05,& + & 1.104500e-05,3.741800e-05,1.367830e-04,5.676953e-04,5.100599e-03,& + & 1.135207e-01,1.964914e+00,4.593274e+01,6.756200e+03,1.536300e+05,& + & 1.128500e-05,3.870400e-05,1.358856e-04,5.724608e-04,5.138900e-03,& + & 1.160527e-01,2.059224e+00,4.893143e+01,7.430200e+03,1.477300e+05,& + & 6.195000e-06,2.654800e-05,1.142017e-04,4.434507e-04,4.061342e-03,& + & 8.850287e-02,1.430374e+00,3.458707e+01,4.241400e+03,1.740100e+05,& + & 7.067800e-06,2.764500e-05,1.146965e-04,4.496430e-04,4.110004e-03,& + & 9.035841e-02,1.501987e+00,3.688433e+01,4.994000e+03,1.681800e+05,& + & 7.957100e-06,2.888700e-05,1.133140e-04,4.570641e-04,4.149426e-03,& + & 9.233982e-02,1.578998e+00,3.911642e+01,5.717700e+03,1.624000e+05,& + & 8.785900e-06,3.024300e-05,1.125404e-04,4.619405e-04,4.182837e-03,& + & 9.423511e-02,1.668998e+00,4.163129e+01,6.431800e+03,1.564800e+05,& + & 9.311600e-06,3.128500e-05,1.118460e-04,4.659609e-04,4.217335e-03,& + & 9.654011e-02,1.756837e+00,4.431282e+01,7.130800e+03,1.505100e+05,& + & 4.812100e-06,2.163200e-05,9.413931e-05,3.602520e-04,3.321665e-03,& + & 7.318085e-02,1.197379e+00,3.075832e+01,3.905800e+03,1.766700e+05,& + & 5.554000e-06,2.230500e-05,9.482170e-05,3.655918e-04,3.369596e-03,& + & 7.487307e-02,1.262034e+00,3.314145e+01,4.643500e+03,1.710400e+05,& + & 6.263400e-06,2.340200e-05,9.411423e-05,3.713657e-04,3.406399e-03,& + & 7.661400e-02,1.333608e+00,3.542573e+01,5.414400e+03,1.649900e+05,& + & 6.996800e-06,2.442000e-05,9.295135e-05,3.763276e-04,3.438850e-03,& + & 7.831394e-02,1.413223e+00,3.771263e+01,6.132000e+03,1.591200e+05,& + & 7.575000e-06,2.542400e-05,9.211663e-05,3.801034e-04,3.470086e-03,& + & 8.039551e-02,1.496788e+00,4.049997e+01,6.834000e+03,1.531800e+05,& + & 3.773200e-06,1.749400e-05,7.787031e-05,2.917190e-04,2.710953e-03,& + & 6.047625e-02,9.987274e-01,2.731742e+01,3.582800e+03,1.792200e+05,& + & 4.340000e-06,1.815800e-05,7.820364e-05,2.969652e-04,2.755494e-03,& + & 6.184768e-02,1.060317e+00,2.963243e+01,4.324200e+03,1.735600e+05,& + & 4.936800e-06,1.894600e-05,7.829726e-05,3.011455e-04,2.790005e-03,& + & 6.339650e-02,1.123929e+00,3.206216e+01,5.083500e+03,1.677200e+05,& + & 5.525500e-06,1.974600e-05,7.716338e-05,3.058237e-04,2.819293e-03,& + & 6.501476e-02,1.195756e+00,3.450973e+01,5.830800e+03,1.616900e+05,& + & 6.050700e-06,2.062600e-05,7.622375e-05,3.092608e-04,2.849085e-03,& + & 6.680782e-02,1.272463e+00,3.709181e+01,6.545500e+03,1.557200e+05,& + & 2.958800e-06,1.406000e-05,6.498269e-05,2.351736e-04,2.207100e-03,& + & 4.984141e-02,8.327580e-01,2.425444e+01,3.273300e+03,1.815300e+05,& + & 3.385500e-06,1.492400e-05,6.437416e-05,2.408144e-04,2.247217e-03,& + & 5.106383e-02,8.835278e-01,2.651729e+01,3.995000e+03,1.762200e+05,& + & 3.893400e-06,1.529600e-05,6.484358e-05,2.440572e-04,2.279711e-03,& + & 5.236843e-02,9.420509e-01,2.904483e+01,4.759000e+03,1.703500e+05,& + & 4.355800e-06,1.604700e-05,6.422153e-05,2.476467e-04,2.305781e-03,& + & 5.385392e-02,1.006056e+00,3.155191e+01,5.530000e+03,1.642200e+05,& + & 4.837700e-06,1.666100e-05,6.318191e-05,2.508873e-04,2.331062e-03,& + & 5.544591e-02,1.076425e+00,3.410120e+01,6.261300e+03,1.581900e+05,& + & 2.263700e-06,1.150200e-05,5.409641e-05,1.913949e-04,1.812767e-03,& + & 4.139308e-02,6.966840e-01,2.155043e+01,2.997300e+03,1.836300e+05,& + & 2.655000e-06,1.218900e-05,5.378751e-05,1.959818e-04,1.847532e-03,& + & 4.244713e-02,7.447507e-01,2.386942e+01,3.703300e+03,1.784800e+05,& + & 3.064000e-06,1.259100e-05,5.369946e-05,1.995299e-04,1.878080e-03,& + & 4.363150e-02,7.968853e-01,2.629102e+01,4.479800e+03,1.725900e+05,& + & 3.467000e-06,1.307200e-05,5.366971e-05,2.021344e-04,1.904098e-03,& + & 4.489577e-02,8.576664e-01,2.882089e+01,5.246800e+03,1.665700e+05,& + & 3.864500e-06,1.358500e-05,5.288031e-05,2.050214e-04,1.927504e-03,& + & 4.637463e-02,9.208700e-01,3.151690e+01,6.005400e+03,1.604200e+05/ + data absb(:,211:235) / & + & 1.739400e-06,9.473100e-06,4.563838e-05,1.557865e-04,1.493661e-03,& + & 3.455495e-02,5.835786e-01,1.925122e+01,2.734700e+03,1.855100e+05,& + & 2.131800e-06,9.900000e-06,4.545426e-05,1.596786e-04,1.526199e-03,& + & 3.545846e-02,6.282760e-01,2.147305e+01,3.452900e+03,1.804300e+05,& + & 2.409200e-06,1.049900e-05,4.475665e-05,1.635121e-04,1.556715e-03,& + & 3.650696e-02,6.754686e-01,2.392610e+01,4.202000e+03,1.747900e+05,& + & 2.771800e-06,1.073000e-05,4.481076e-05,1.659395e-04,1.581755e-03,& + & 3.762834e-02,7.312044e-01,2.655364e+01,4.993200e+03,1.686700e+05,& + & 3.096900e-06,1.120100e-05,4.448881e-05,1.681242e-04,1.605482e-03,& + & 3.898851e-02,7.930304e-01,2.917476e+01,5.736000e+03,1.626700e+05,& + & 1.337900e-06,7.784200e-06,3.794717e-05,1.276226e-04,1.230863e-03,& + & 2.874245e-02,4.906990e-01,1.710831e+01,2.495300e+03,1.872300e+05,& + & 1.696200e-06,8.060900e-06,3.825195e-05,1.304785e-04,1.261127e-03,& + & 2.965448e-02,5.293689e-01,1.941395e+01,3.195600e+03,1.823300e+05,& + & 1.918200e-06,8.632800e-06,3.766703e-05,1.337435e-04,1.289446e-03,& + & 3.060807e-02,5.727603e-01,2.184731e+01,3.936600e+03,1.768700e+05,& + & 2.201900e-06,8.907300e-06,3.740798e-05,1.362225e-04,1.313935e-03,& + & 3.158456e-02,6.223633e-01,2.446152e+01,4.717600e+03,1.708900e+05,& + & 2.505700e-06,9.225800e-06,3.726862e-05,1.380280e-04,1.337532e-03,& + & 3.278351e-02,6.813537e-01,2.718855e+01,5.481800e+03,1.648000e+05,& + & 1.089400e-06,6.127100e-06,3.158340e-05,1.048375e-04,1.012832e-03,& + & 2.400573e-02,4.097914e-01,1.537667e+01,2.261700e+03,1.888600e+05,& + & 1.308600e-06,6.699900e-06,3.239312e-05,1.063566e-04,1.041240e-03,& + & 2.478671e-02,4.453238e-01,1.748305e+01,2.941300e+03,1.842000e+05,& + & 1.525000e-06,7.036800e-06,3.215555e-05,1.089376e-04,1.067794e-03,& + & 2.561376e-02,4.857489e-01,1.986569e+01,3.688100e+03,1.788300e+05,& + & 1.782500e-06,7.446600e-06,3.144232e-05,1.115837e-04,1.091335e-03,& + & 2.660656e-02,5.318314e-01,2.262563e+01,4.449900e+03,1.729900e+05,& + & 2.007800e-06,7.639500e-06,3.121672e-05,1.134173e-04,1.113037e-03,& + & 2.762634e-02,5.850740e-01,2.526450e+01,5.234900e+03,1.668100e+05,& + & 8.250500e-07,4.787300e-06,2.656058e-05,8.599989e-05,8.358993e-04,& + & 2.009312e-02,3.431457e-01,1.389403e+01,2.037000e+03,1.903700e+05,& + & 1.018000e-06,5.561500e-06,2.684447e-05,8.760306e-05,8.608185e-04,& + & 2.080354e-02,3.748374e-01,1.594760e+01,2.714800e+03,1.858100e+05,& + & 1.254800e-06,5.747000e-06,2.731576e-05,8.904149e-05,8.863475e-04,& + & 2.157788e-02,4.117652e-01,1.821223e+01,3.446000e+03,1.806700e+05,& + & 1.458400e-06,6.163700e-06,2.680017e-05,9.118702e-05,9.080531e-04,& + & 2.242998e-02,4.542731e-01,2.088348e+01,4.222400e+03,1.747700e+05,& + & 1.739800e-06,6.370500e-06,2.630685e-05,9.319223e-05,9.287046e-04,& + & 2.336703e-02,5.044867e-01,2.375255e+01,4.990600e+03,1.688100e+05,& + & 7.180200e-07,3.864900e-06,2.256658e-05,7.172499e-05,7.028164e-04,& + & 1.721199e-02,2.936671e-01,1.321355e+01,1.947800e+03,1.910000e+05,& + & 8.678400e-07,4.596600e-06,2.270775e-05,7.318428e-05,7.275395e-04,& + & 1.792357e-02,3.237851e-01,1.519158e+01,2.613000e+03,1.865900e+05,& + & 1.097400e-06,4.796500e-06,2.314181e-05,7.428212e-05,7.522643e-04,& + & 1.865225e-02,3.576812e-01,1.736163e+01,3.352900e+03,1.813200e+05,& + & 1.350400e-06,5.149000e-06,2.293358e-05,7.590926e-05,7.728592e-04,& + & 1.950171e-02,3.997745e-01,1.983285e+01,4.120500e+03,1.756200e+05,& + & 1.431400e-06,5.388000e-06,2.240495e-05,7.783655e-05,7.936564e-04,& + & 2.039213e-02,4.493887e-01,2.278674e+01,4.899000e+03,1.695600e+05/ + + + data selfref(:, :) / & + & 2.168030e+00,3.701490e+00,6.362042e+00,6.498625e+00,6.557401e+00,& + & 6.583180e+00,7.064571e+00,7.464597e+00,7.518950e+00,7.847740e+00,& + & 1.982360e+00,3.431450e+00,5.778778e+00,5.903115e+00,5.954698e+00,& + & 6.024436e+00,6.415106e+00,6.770832e+00,6.688460e+00,6.806730e+00,& + & 1.812600e+00,3.181100e+00,5.249020e+00,5.362198e+00,5.407467e+00,& + & 5.513122e+00,5.825835e+00,6.141552e+00,5.949700e+00,5.903800e+00,& + & 1.657370e+00,2.949020e+00,4.767855e+00,4.870861e+00,4.910594e+00,& + & 5.045202e+00,5.291130e+00,5.570755e+00,5.292540e+00,5.120650e+00,& + & 1.515440e+00,2.733870e+00,4.330824e+00,4.424562e+00,4.459444e+00,& + & 4.616993e+00,4.805899e+00,5.053016e+00,4.707960e+00,4.441380e+00,& + & 1.385670e+00,2.534410e+00,3.933878e+00,4.019174e+00,4.049802e+00,& + & 4.225135e+00,4.365522e+00,4.583395e+00,4.187950e+00,3.852230e+00,& + & 1.267000e+00,2.349510e+00,3.573335e+00,3.650940e+00,3.677838e+00,& + & 3.866529e+00,3.965830e+00,4.157423e+00,3.725380e+00,3.341220e+00,& + & 1.158500e+00,2.178100e+00,3.245858e+00,3.316453e+00,3.340089e+00,& + & 3.538366e+00,3.603021e+00,3.771042e+00,3.313900e+00,2.898000e+00,& + & 1.059290e+00,2.019190e+00,2.948406e+00,3.012624e+00,3.033394e+00,& + & 3.238053e+00,3.273677e+00,3.420571e+00,2.947870e+00,2.513570e+00,& + & 9.685760e-01,1.871880e+00,2.678235e+00,2.736639e+00,2.754912e+00,& + & 2.963225e+00,2.974673e+00,3.102675e+00,2.622270e+00,2.180140e+00/ + + data forref(:, :) / & + & 3.674200E-02,1.066400E-01,2.698528E-01,2.783334E-01,2.878464E-01,& + & 3.080541E-01,3.036985E-01,3.112085E-01,2.122600E-01,1.284700E-01,& + & 4.045000E-02,1.108500E-01,3.051763E-01,3.160518E-01,3.255052E-01,& + & 3.326603E-01,3.477623E-01,3.764727E-01,3.348100E-01,3.211300E-01,& + & 4.695200E-02,1.199900E-01,3.413866E-01,3.665323E-01,3.760285E-01,& + & 3.717261E-01,3.947360E-01,4.344193E-01,4.346800E-01,4.708300E-01,& + & 7.064500E-02,1.661800E-01,3.010472E-01,2.986289E-01,2.913346E-01,& + & 2.864983E-01,2.796532E-01,3.049337E-01,3.068100E-01,3.677800E-01/ + + data ka_mn2(:, :) / & + & 5.120420E-08,2.309380E-07,1.233875E-06,3.404911E-06,3.034329E-06,& + & 2.794253E-06,2.772649E-06,2.803828E-06,3.034470E-06,1.486550E-06,& + & 5.512390E-08,2.416960E-07,1.275577E-06,3.296129E-06,2.942325E-06,& + & 2.723483E-06,2.702214E-06,2.723417E-06,2.885590E-06,1.482830E-06,& + & 5.934360E-08,2.529550E-07,1.318817E-06,3.190927E-06,2.853138E-06,& + & 2.654555E-06,2.633985E-06,2.645397E-06,2.744010E-06,1.479130E-06,& + & 6.388630E-08,2.647380E-07,1.363666E-06,3.089172E-06,2.766672E-06,& + & 2.587417E-06,2.567869E-06,2.569694E-06,2.609380E-06,1.475430E-06,& + & 6.877670E-08,2.770710E-07,1.410189E-06,2.990755E-06,2.682850E-06,& + & 2.522020E-06,2.503811E-06,2.496240E-06,2.481350E-06,1.471740E-06,& + & 7.404150E-08,2.899780E-07,1.458450E-06,2.895555E-06,2.601588E-06,& + & 2.458315E-06,2.441728E-06,2.424955E-06,2.359610E-06,1.468060E-06,& + & 7.970930E-08,3.034860E-07,1.508520E-06,2.803479E-06,2.522806E-06,& + & 2.396268E-06,2.381551E-06,2.355783E-06,2.243840E-06,1.464390E-06,& + & 8.581100E-08,3.176230E-07,1.560477E-06,2.714407E-06,2.446428E-06,& + & 2.335813E-06,2.323214E-06,2.288660E-06,2.133750E-06,1.460720E-06,& + & 9.237970E-08,3.324190E-07,1.614398E-06,2.628246E-06,2.372385E-06,& + & 2.276932E-06,2.266654E-06,2.223520E-06,2.029060E-06,1.457070E-06,& + & 9.945130E-08,3.479040E-07,1.670359E-06,2.544896E-06,2.300594E-06,& + & 2.219573E-06,2.211809E-06,2.160297E-06,1.929510E-06,1.453430E-06,& + & 1.070640E-07,3.641110E-07,1.728450E-06,2.464263E-06,2.230998E-06,& + & 2.163691E-06,2.158616E-06,2.098933E-06,1.834840E-06,1.449790E-06,& + & 1.152600E-07,3.810720E-07,1.788757E-06,2.386262E-06,2.163523E-06,& + & 2.109256E-06,2.107026E-06,2.039384E-06,1.744810E-06,1.446170E-06,& + & 1.240830E-07,3.988240E-07,1.851384E-06,2.310795E-06,2.098102E-06,& + & 2.056222E-06,2.056976E-06,1.981583E-06,1.659210E-06,1.442550E-06,& + & 1.335810E-07,4.174020E-07,1.916406E-06,2.237783E-06,2.034683E-06,& + & 2.004552E-06,2.008422E-06,1.925482E-06,1.577800E-06,1.438940E-06,& + & 1.438070E-07,4.368460E-07,1.983936E-06,2.167142E-06,1.973187E-06,& + & 1.954209E-06,1.961300E-06,1.871024E-06,1.500390E-06,1.435340E-06,& + & 1.548150E-07,4.571960E-07,2.054075E-06,2.098796E-06,1.913573E-06,& + & 1.905157E-06,1.915570E-06,1.818158E-06,1.426770E-06,1.431760E-06,& + & 1.666660E-07,4.784940E-07,2.126946E-06,2.032665E-06,1.855773E-06,& + & 1.857369E-06,1.871185E-06,1.766843E-06,1.356770E-06,1.428170E-06,& + & 1.794240E-07,5.007840E-07,2.202641E-06,1.968674E-06,1.799725E-06,& + & 1.810808E-06,1.828097E-06,1.717031E-06,1.290200E-06,1.424600E-06,& + & 1.931590E-07,5.241120E-07,2.281302E-06,1.906758E-06,1.745393E-06,& + & 1.765440E-06,1.786258E-06,1.668673E-06,1.226900E-06,1.421040E-06/ + + data kb_mn2(:, :) / & + & 5.120420E-08,2.309380E-07,1.233875E-06,3.404911E-06,3.034329E-06,& + & 2.794253E-06,2.772649E-06,2.803828E-06,3.034470E-06,1.486550E-06,& + & 5.512390E-08,2.416960E-07,1.275577E-06,3.296129E-06,2.942325E-06,& + & 2.723483E-06,2.702214E-06,2.723417E-06,2.885590E-06,1.482830E-06,& + & 5.934360E-08,2.529550E-07,1.318817E-06,3.190927E-06,2.853138E-06,& + & 2.654555E-06,2.633985E-06,2.645397E-06,2.744010E-06,1.479130E-06,& + & 6.388630E-08,2.647380E-07,1.363666E-06,3.089172E-06,2.766672E-06,& + & 2.587417E-06,2.567869E-06,2.569694E-06,2.609380E-06,1.475430E-06,& + & 6.877670E-08,2.770710E-07,1.410189E-06,2.990755E-06,2.682850E-06,& + & 2.522020E-06,2.503811E-06,2.496240E-06,2.481350E-06,1.471740E-06,& + & 7.404150E-08,2.899780E-07,1.458450E-06,2.895555E-06,2.601588E-06,& + & 2.458315E-06,2.441728E-06,2.424955E-06,2.359610E-06,1.468060E-06,& + & 7.970930E-08,3.034860E-07,1.508520E-06,2.803479E-06,2.522806E-06,& + & 2.396268E-06,2.381551E-06,2.355783E-06,2.243840E-06,1.464390E-06,& + & 8.581100E-08,3.176230E-07,1.560477E-06,2.714407E-06,2.446428E-06,& + & 2.335813E-06,2.323214E-06,2.288660E-06,2.133750E-06,1.460720E-06,& + & 9.237970E-08,3.324190E-07,1.614398E-06,2.628246E-06,2.372385E-06,& + & 2.276932E-06,2.266654E-06,2.223520E-06,2.029060E-06,1.457070E-06,& + & 9.945130E-08,3.479040E-07,1.670359E-06,2.544896E-06,2.300594E-06,& + & 2.219573E-06,2.211809E-06,2.160297E-06,1.929510E-06,1.453430E-06,& + & 1.070640E-07,3.641110E-07,1.728450E-06,2.464263E-06,2.230998E-06,& + & 2.163691E-06,2.158616E-06,2.098933E-06,1.834840E-06,1.449790E-06,& + & 1.152600E-07,3.810720E-07,1.788757E-06,2.386262E-06,2.163523E-06,& + & 2.109256E-06,2.107026E-06,2.039384E-06,1.744810E-06,1.446170E-06,& + & 1.240830E-07,3.988240E-07,1.851384E-06,2.310795E-06,2.098102E-06,& + & 2.056222E-06,2.056976E-06,1.981583E-06,1.659210E-06,1.442550E-06,& + & 1.335810E-07,4.174020E-07,1.916406E-06,2.237783E-06,2.034683E-06,& + & 2.004552E-06,2.008422E-06,1.925482E-06,1.577800E-06,1.438940E-06,& + & 1.438070E-07,4.368460E-07,1.983936E-06,2.167142E-06,1.973187E-06,& + & 1.954209E-06,1.961300E-06,1.871024E-06,1.500390E-06,1.435340E-06,& + & 1.548150E-07,4.571960E-07,2.054075E-06,2.098796E-06,1.913573E-06,& + & 1.905157E-06,1.915570E-06,1.818158E-06,1.426770E-06,1.431760E-06,& + & 1.666660E-07,4.784940E-07,2.126946E-06,2.032665E-06,1.855773E-06,& + & 1.857369E-06,1.871185E-06,1.766843E-06,1.356770E-06,1.428170E-06,& + & 1.794240E-07,5.007840E-07,2.202641E-06,1.968674E-06,1.799725E-06,& + & 1.810808E-06,1.828097E-06,1.717031E-06,1.290200E-06,1.424600E-06,& + & 1.931590E-07,5.241120E-07,2.281302E-06,1.906758E-06,1.745393E-06,& + & 1.765440E-06,1.786258E-06,1.668673E-06,1.226900E-06,1.421040E-06/ + + data fracrefa(:) / & + & 2.122700e-01,1.889700e-01,2.549100e-01,1.786410e-01,1.173490e-01,& + & 3.829770e-02,5.787100e-03,3.175300e-03,5.316900e-04,7.647600e-05/ + + data fracrefb(:) / & + & 2.122700e-01,1.889700e-01,2.549100e-01,1.786410e-01,1.173490e-01,& + & 3.829770e-02,5.787100e-03,3.175300e-03,5.316900e-04,7.647600e-05/ + +!........................................! + end module module_radlw_kgb01 ! +!========================================! + +!> This module sets up absorption coefficients for band 02: 250-500 +!! cm-1 (low - h2o; high - h2o) +!========================================! + module module_radlw_kgb02 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG02 +! + implicit none +! + private +! +!> msa02=65 + integer, public :: MSA02 +!> msb02=235 + integer, public :: MSB02 +!> msf02=10 + integer, public :: MSF02 +!> mfr02=4 + integer, public :: MFR02 + parameter (MSA02=65, MSB02=235, MSF02=10, MFR02=4) + +!> the array absa(NG02,65) = ka(NG02,5,13) contains absorption coefs +!! at the NG02=12 chosen g-values for a range of pressure levels>~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 1 to 13 and refers to the corresponding +!! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). +!! the third index, ig, goes from 1 to NG02=12, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG02,MSA02) + +!> the array absb(NG02,235) = kb(NG02,5,13:59) contains absorption coefs +!! at the NG02=12 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG02=12, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG02,MSB02) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG02=12). + real (kind=kind_phys), public :: selfref(NG02,MSF02) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG02=12). + real (kind=kind_phys), public :: forref(NG02,MFR02) + +!> planck fraction mapping level: p = 1053.630 mbar, t = 294.2 k + real (kind=kind_phys), public :: fracrefa(NG02) + +!> planck fraction mapping level: p = 3.206e-2 mb, t = 197.92 k + real (kind=kind_phys), public :: fracrefb(NG02) + + data absa(:, 1: 25) / & + & 4.944400E-03,1.002700E-02,2.047500E-02,3.415000E-02,7.412800E-02,& + & 2.061300E-01,6.492400E-01,1.585200E+00,6.013277E+00,1.953498E+01,& + & 3.522639E+01,7.170971E+01,5.945900E-03,1.179100E-02,2.488600E-02,& + & 4.036700E-02,9.032800E-02,2.515700E-01,7.730700E-01,1.893700E+00,& + & 7.217752E+00,2.384686E+01,4.519749E+01,9.302171E+01,7.090900E-03,& + & 1.393200E-02,2.805600E-02,4.928000E-02,1.084500E-01,3.017800E-01,& + & 9.038600E-01,2.223300E+00,8.556270E+00,2.855482E+01,5.673227E+01,& + & 1.171197E+02,8.208200E-03,1.666600E-02,3.168700E-02,5.910000E-02,& + & 1.284200E-01,3.568300E-01,1.038800E+00,2.575900E+00,1.001266E+01,& + & 3.378377E+01,6.952789E+01,1.437207E+02,9.207100E-03,2.012600E-02,& + & 3.601100E-02,6.949900E-02,1.499300E-01,4.154200E-01,1.177300E+00,& + & 2.944700E+00,1.157710E+01,3.948620E+01,8.343575E+01,1.732833E+02,& + & 3.625300E-03,7.405600E-03,1.529300E-02,2.550400E-02,5.642100E-02,& + & 1.581900E-01,5.057700E-01,1.302000E+00,5.404800E+00,1.931877E+01,& + & 3.501349E+01,7.738421E+01,4.386000E-03,8.828500E-03,1.864900E-02,& + & 3.044700E-02,6.893200E-02,1.943200E-01,6.078600E-01,1.560800E+00,& + & 6.539959E+00,2.354261E+01,4.507376E+01,1.016215E+02,5.254100E-03,& + & 1.046000E-02,2.119700E-02,3.732100E-02,8.329400E-02,2.345200E-01,& + & 7.163900E-01,1.840800E+00,7.803242E+00,2.813705E+01,5.690383E+01,& + & 1.292157E+02,6.041900E-03,1.266900E-02,2.410600E-02,4.494400E-02,& + & 9.911100E-02,2.785800E-01,8.285500E-01,2.141500E+00,9.186269E+00,& + & 3.310030E+01,7.035003E+01,1.603019E+02,6.883500E-03,1.528200E-02,& + & 2.748500E-02,5.329800E-02,1.161700E-01,3.258700E-01,9.449300E-01,& + & 2.461400E+00,1.067922E+01,3.845742E+01,8.507015E+01,1.952131E+02,& + & 2.533800E-03,5.266100E-03,1.091800E-02,1.837100E-02,4.091600E-02,& + & 1.153100E-01,3.738400E-01,1.012600E+00,4.588054E+00,1.792464E+01,& + & 3.367887E+01,7.748452E+01,3.098500E-03,6.292800E-03,1.348000E-02,& + & 2.208500E-02,5.038500E-02,1.430600E-01,4.563800E-01,1.223900E+00,& + & 5.608161E+00,2.215926E+01,4.315130E+01,1.038670E+02,3.740000E-03,& + & 7.554000E-03,1.549600E-02,2.722600E-02,6.125700E-02,1.743500E-01,& + & 5.436100E-01,1.455300E+00,6.760208E+00,2.661942E+01,5.466589E+01,& + & 1.344875E+02,4.299600E-03,9.238700E-03,1.776900E-02,3.299400E-02,& + & 7.347400E-02,2.087600E-01,6.356300E-01,1.704000E+00,8.031504E+00,& + & 3.135371E+01,6.808686E+01,1.698614E+02,4.967500E-03,1.118200E-02,& + & 2.039800E-02,3.940300E-02,8.673200E-02,2.463200E-01,7.310800E-01,& + & 1.970200E+00,9.400717E+00,3.654827E+01,8.301260E+01,2.096201E+02,& + & 1.775500E-03,3.783000E-03,7.739500E-03,1.323500E-02,2.943000E-02,& + & 8.328400E-02,2.715700E-01,7.685600E-01,3.798968E+00,1.605929E+01,& + & 3.206772E+01,7.368439E+01,2.197300E-03,4.514400E-03,9.662500E-03,& + & 1.604600E-02,3.655600E-02,1.044400E-01,3.376900E-01,9.402500E-01,& + & 4.696894E+00,2.003915E+01,4.111361E+01,1.012819E+02,2.666400E-03,& + & 5.462200E-03,1.137900E-02,1.981300E-02,4.474200E-02,1.286400E-01,& + & 4.079800E-01,1.131600E+00,5.714865E+00,2.443126E+01,5.195613E+01,& + & 1.344106E+02,3.111100E-03,6.686900E-03,1.313000E-02,2.415600E-02,& + & 5.419900E-02,1.556000E-01,4.829800E-01,1.338600E+00,6.830858E+00,& + & 2.928685E+01,6.466049E+01,1.730232E+02,3.609100E-03,8.143500E-03,& + & 1.517000E-02,2.908200E-02,6.458000E-02,1.853500E-01,5.615800E-01,& + & 1.560500E+00,8.049216E+00,3.446437E+01,7.929820E+01,2.169127E+02,& + & 1.256500E-03,2.748000E-03,5.499500E-03,9.599800E-03,2.121200E-02,& + & 6.016600E-02,1.964800E-01,5.761600E-01,3.098845E+00,1.413651E+01,& + & 3.072892E+01,6.799917E+01,1.578900E-03,3.304200E-03,6.906300E-03,& + & 1.170900E-02,2.660200E-02,7.631500E-02,2.483800E-01,7.135900E-01,& + & 3.877155E+00,1.790609E+01,3.921055E+01,9.627558E+01,1.919600E-03,& + & 3.972600E-03,8.523300E-03,1.433800E-02,3.278000E-02,9.493700E-02,& + & 3.052100E-01,8.683200E-01,4.762634E+00,2.211825E+01,4.949310E+01,& + & 1.310325E+02,2.309600E-03,4.825800E-03,9.812500E-03,1.770700E-02,& + & 4.008400E-02,1.160400E-01,3.659000E-01,1.038800E+00,5.744773E+00,& + & 2.677399E+01,6.173005E+01,1.721304E+02,2.651900E-03,5.951000E-03,& + & 1.136800E-02,2.150500E-02,4.823600E-02,1.395800E-01,4.300500E-01,& + & 1.222800E+00,6.820642E+00,3.193634E+01,7.573209E+01,2.192692E+02/ + data absa(:, 26: 50) / & + & 8.862400E-04,2.006300E-03,3.900200E-03,6.902200E-03,1.515100E-02,& + & 4.300300E-02,1.396600E-01,4.235000E-01,2.468341E+00,1.219654E+01,& + & 2.882590E+01,6.263361E+01,1.117500E-03,2.398400E-03,4.930700E-03,& + & 8.563000E-03,1.912900E-02,5.523000E-02,1.798700E-01,5.326800E-01,& + & 3.133123E+00,1.556280E+01,3.726426E+01,8.841400E+01,1.381800E-03,& + & 2.871300E-03,6.203700E-03,1.039500E-02,2.389700E-02,6.944700E-02,& + & 2.252400E-01,6.560500E-01,3.890294E+00,1.948190E+01,4.706654E+01,& + & 1.235954E+02,1.693400E-03,3.486400E-03,7.310000E-03,1.286900E-02,& + & 2.943600E-02,8.578100E-02,2.740500E-01,7.933400E-01,4.734638E+00,& + & 2.396097E+01,5.869748E+01,1.660609E+02,1.963500E-03,4.313500E-03,& + & 8.468900E-03,1.578700E-02,3.579800E-02,1.042400E-01,3.259300E-01,& + & 9.422300E-01,5.671975E+00,2.890648E+01,7.222433E+01,2.154145E+02,& + & 6.284300E-04,1.484600E-03,2.736900E-03,5.062200E-03,1.071800E-02,& + & 3.049000E-02,9.835300E-02,3.068600E-01,1.933490E+00,1.038320E+01,& + & 2.646348E+01,5.991856E+01,7.925300E-04,1.745300E-03,3.507800E-03,& + & 6.186100E-03,1.380200E-02,3.976900E-02,1.291700E-01,3.922500E-01,& + & 2.492441E+00,1.333433E+01,3.494088E+01,8.256641E+01,1.001200E-03,& + & 2.098100E-03,4.435200E-03,7.564200E-03,1.738900E-02,5.061800E-02,& + & 1.644500E-01,4.901000E-01,3.132172E+00,1.684098E+01,4.485384E+01,& + & 1.145766E+02,1.222200E-03,2.544400E-03,5.509800E-03,9.283500E-03,& + & 2.150500E-02,6.320000E-02,2.036500E-01,5.994400E-01,3.855852E+00,& + & 2.090759E+01,5.622177E+01,1.566366E+02,1.473400E-03,3.105600E-03,& + & 6.346300E-03,1.153000E-02,2.644000E-02,7.759700E-02,2.453100E-01,& + & 7.196700E-01,4.665478E+00,2.553266E+01,6.926113E+01,2.073040E+02,& + & 4.502300E-04,1.121000E-03,1.929400E-03,3.773400E-03,7.491700E-03,& + & 2.157000E-02,6.879500E-02,2.207000E-01,1.487856E+00,8.745265E+00,& + & 2.405343E+01,5.871087E+01,5.648300E-04,1.287900E-03,2.502800E-03,& + & 4.495600E-03,9.912500E-03,2.857300E-02,9.224400E-02,2.868800E-01,& + & 1.947839E+00,1.136738E+01,3.219331E+01,7.956594E+01,7.156800E-04,& + & 1.544900E-03,3.175100E-03,5.574900E-03,1.257800E-02,3.680300E-02,& + & 1.195100E-01,3.634800E-01,2.481517E+00,1.449670E+01,4.211189E+01,& + & 1.082280E+02,8.902600E-04,1.852400E-03,4.025500E-03,6.772100E-03,& + & 1.577000E-02,4.643700E-02,1.505300E-01,4.500700E-01,3.094219E+00,& + & 1.814991E+01,5.348641E+01,1.476106E+02,1.092900E-03,2.256200E-03,& + & 4.759300E-03,8.425300E-03,1.948300E-02,5.762600E-02,1.839200E-01,& + & 5.459700E-01,3.787395E+00,2.234890E+01,6.626404E+01,1.981963E+02,& + & 3.252000E-04,8.557400E-04,1.280600E-03,2.961900E-03,5.116800E-03,& + & 1.515500E-02,4.772000E-02,1.575000E-01,1.121637E+00,7.202352E+00,& + & 2.172719E+01,5.785118E+01,4.040700E-04,9.642300E-04,1.765900E-03,& + & 3.331500E-03,7.036800E-03,2.045000E-02,6.537400E-02,2.083200E-01,& + & 1.494962E+00,9.508649E+00,2.937548E+01,7.751093E+01,5.120900E-04,& + & 1.133600E-03,2.278600E-03,4.062100E-03,9.108900E-03,2.667300E-02,& + & 8.629400E-02,2.677400E-01,1.933591E+00,1.230357E+01,3.886673E+01,& + & 1.042746E+02,6.494900E-04,1.365900E-03,2.893300E-03,4.969400E-03,& + & 1.152700E-02,3.400400E-02,1.104400E-01,3.358400E-01,2.441720E+00,& + & 1.556581E+01,5.013019E+01,1.406601E+02,7.958100E-04,1.659400E-03,& + & 3.611200E-03,6.111700E-03,1.429300E-02,4.262000E-02,1.372100E-01,& + & 4.116900E-01,3.024704E+00,1.937381E+01,6.276931E+01,1.889857E+02,& + & 2.412600E-04,6.684800E-04,8.642900E-04,2.220400E-03,3.698300E-03,& + & 1.085200E-02,3.388100E-02,1.145800E-01,8.519646E-01,5.998988E+00,& + & 1.977045E+01,5.882394E+01,2.958100E-04,7.401600E-04,1.287100E-03,& + & 2.512300E-03,5.062700E-03,1.489300E-02,4.721100E-02,1.539800E-01,& + & 1.153366E+00,8.007828E+00,2.714673E+01,7.753900E+01,3.740400E-04,& + & 8.547900E-04,1.666100E-03,3.017600E-03,6.699100E-03,1.966800E-02,& + & 6.337700E-02,2.004700E-01,1.515323E+00,1.046035E+01,3.630810E+01,& + & 1.034219E+02,4.758500E-04,1.027400E-03,2.120700E-03,3.732100E-03,& + & 8.527500E-03,2.532400E-02,8.229400E-02,2.542000E-01,1.938589E+00,& + & 1.340382E+01,4.717326E+01,1.390180E+02,5.908500E-04,1.234300E-03,& + & 2.695600E-03,4.554500E-03,1.069600E-02,3.199200E-02,1.037400E-01,& + & 3.145200E-01,2.426376E+00,1.683331E+01,5.973290E+01,1.859478E+02/ + data absa(:, 51: 65) / & + & 1.950100E-04,5.502200E-04,7.098900E-04,1.828800E-03,3.048400E-03,& + & 9.051100E-03,2.830400E-02,9.635200E-02,7.434837E-01,5.681689E+00,& + & 2.078122E+01,6.745005E+01,2.415200E-04,6.047300E-04,1.055500E-03,& + & 2.060200E-03,4.191600E-03,1.242200E-02,3.938600E-02,1.294500E-01,& + & 1.007571E+00,7.610196E+00,2.848452E+01,8.902419E+01,3.064900E-04,& + & 6.996300E-04,1.369100E-03,2.483800E-03,5.534600E-03,1.637400E-02,& + & 5.291100E-02,1.685000E-01,1.326750E+00,9.954843E+00,3.808500E+01,& + & 1.180042E+02,3.910400E-04,8.410600E-04,1.745000E-03,3.068500E-03,& + & 7.051300E-03,2.108400E-02,6.867100E-02,2.134300E-01,1.700806E+00,& + & 1.275367E+01,4.933945E+01,1.580657E+02,4.888100E-04,1.009700E-03,& + & 2.218400E-03,3.750800E-03,8.849800E-03,2.664300E-02,8.647700E-02,& + & 2.641800E-01,2.128649E+00,1.600788E+01,6.238418E+01,2.103504E+02,& + & 1.588100E-04,4.497200E-04,5.863000E-04,1.505100E-03,2.517400E-03,& + & 7.533200E-03,2.364300E-02,8.085900E-02,6.432431E-01,5.321027E+00,& + & 2.160492E+01,7.708402E+01,1.976300E-04,4.943600E-04,8.661500E-04,& + & 1.691600E-03,3.471400E-03,1.033800E-02,3.284900E-02,1.086900E-01,& + & 8.739707E-01,7.138283E+00,2.959083E+01,1.017898E+02,2.517700E-04,& + & 5.723900E-04,1.126500E-03,2.046600E-03,4.571800E-03,1.362300E-02,& + & 4.412100E-02,1.414200E-01,1.152064E+00,9.359849E+00,3.948405E+01,& + & 1.347318E+02,3.244100E-04,6.873800E-04,1.435700E-03,2.523900E-03,& + & 5.834100E-03,1.753100E-02,5.724600E-02,1.790500E-01,1.477780E+00,& + & 1.200431E+01,5.105678E+01,1.796750E+02,4.063200E-04,8.303800E-04,& + & 1.822100E-03,3.090500E-03,7.319500E-03,2.217400E-02,7.205200E-02,& + & 2.215900E-01,1.847414E+00,1.503577E+01,6.439994E+01,2.387644E+02,& + & 1.300300E-04,3.674500E-04,4.837200E-04,1.237300E-03,2.077000E-03,& + & 6.256800E-03,1.967800E-02,6.768500E-02,5.527753E-01,4.902282E+00,& + & 2.225079E+01,8.726790E+01,1.621600E-04,4.046000E-04,7.103100E-04,& + & 1.390700E-03,2.868400E-03,8.575400E-03,2.733900E-02,9.102800E-02,& + & 7.519311E-01,6.593505E+00,3.046937E+01,1.151903E+02,2.076800E-04,& + & 4.682800E-04,9.261800E-04,1.684800E-03,3.771800E-03,1.131300E-02,& + & 3.669300E-02,1.183800E-01,9.923565E-01,8.646098E+00,4.048815E+01,& + & 1.531617E+02,2.686400E-04,5.642700E-04,1.178700E-03,2.076400E-03,& + & 4.819200E-03,1.456200E-02,4.758300E-02,1.499000E-01,1.270646E+00,& + & 1.107301E+01,5.226123E+01,2.041494E+02,3.349700E-04,6.838700E-04,& + & 1.499800E-03,2.545500E-03,6.041200E-03,1.843900E-02,5.983800E-02,& + & 1.855900E-01,1.586675E+00,1.389204E+01,6.566659E+01,2.705407E+02/ + + data absb(:, 1: 25) / & + & 1.300000E-04,3.678200E-04,4.832900E-04,1.237500E-03,2.076800E-03,& + & 6.256300E-03,1.967800E-02,6.770300E-02,5.530531E-01,4.905021E+00,& + & 2.226307E+01,8.732056E+01,1.621600E-04,4.046000E-04,7.103100E-04,& + & 1.390700E-03,2.868400E-03,8.575400E-03,2.733900E-02,9.102800E-02,& + & 7.519311E-01,6.593505E+00,3.046937E+01,1.151903E+02,2.076800E-04,& + & 4.682800E-04,9.261800E-04,1.684800E-03,3.771800E-03,1.131300E-02,& + & 3.669300E-02,1.183800E-01,9.923565E-01,8.646098E+00,4.048815E+01,& + & 1.531617E+02,2.686400E-04,5.642700E-04,1.178700E-03,2.076400E-03,& + & 4.819200E-03,1.456200E-02,4.758300E-02,1.499000E-01,1.270646E+00,& + & 1.107301E+01,5.226123E+01,2.041494E+02,3.349700E-04,6.838700E-04,& + & 1.499800E-03,2.545500E-03,6.041200E-03,1.843900E-02,5.983800E-02,& + & 1.855900E-01,1.586675E+00,1.389204E+01,6.566659E+01,2.705407E+02,& + & 1.085000E-04,3.020600E-04,4.157300E-04,1.035200E-03,1.756400E-03,& + & 5.340700E-03,1.685500E-02,5.822200E-02,4.862504E-01,4.570015E+00,& + & 2.345911E+01,1.001579E+02,1.360200E-04,3.353400E-04,5.962100E-04,& + & 1.162600E-03,2.433200E-03,7.287400E-03,2.333200E-02,7.800700E-02,& + & 6.596580E-01,6.151633E+00,3.186175E+01,1.331495E+02,1.755300E-04,& + & 3.890400E-04,7.778100E-04,1.415300E-03,3.182400E-03,9.603100E-03,& + & 3.120000E-02,1.011800E-01,8.669796E-01,8.056362E+00,4.197745E+01,& + & 1.782609E+02,2.268600E-04,4.690800E-04,9.925300E-04,1.741000E-03,& + & 4.062500E-03,1.234400E-02,4.035400E-02,1.278400E-01,1.107368E+00,& + & 1.030318E+01,5.384863E+01,2.374828E+02,2.816200E-04,5.735400E-04,& + & 1.256100E-03,2.141000E-03,5.088900E-03,1.561600E-02,5.054900E-02,& + & 1.581100E-01,1.381359E+00,1.291414E+01,6.747303E+01,3.122435E+02,& + & 9.086400E-05,2.490300E-04,3.574500E-04,8.691600E-04,1.490800E-03,& + & 4.562400E-03,1.444700E-02,5.006900E-02,4.265627E-01,4.224471E+00,& + & 2.448805E+01,1.146573E+02,1.147600E-04,2.771800E-04,5.035600E-04,& + & 9.745000E-04,2.071200E-03,6.202600E-03,1.992600E-02,6.683800E-02,& + & 5.762193E-01,5.675222E+00,3.292823E+01,1.540117E+02,1.483200E-04,& + & 3.257400E-04,6.539100E-04,1.191800E-03,2.693400E-03,8.161600E-03,& + & 2.653900E-02,8.646900E-02,7.543865E-01,7.437331E+00,4.302646E+01,& + & 2.068535E+02,1.908100E-04,3.927100E-04,8.399900E-04,1.461700E-03,& + & 3.435300E-03,1.048000E-02,3.420300E-02,1.090100E-01,9.621639E-01,& + & 9.511734E+00,5.488035E+01,2.749093E+02,2.369800E-04,4.820200E-04,& + & 1.055900E-03,1.809000E-03,4.290900E-03,1.323600E-02,4.274100E-02,& + & 1.346800E-01,1.199380E+00,1.189659E+01,6.859742E+01,3.587524E+02,& + & 7.620200E-05,2.057000E-04,3.075800E-04,7.155600E-04,1.283700E-03,& + & 3.895700E-03,1.237500E-02,4.303800E-02,3.729041E-01,3.860561E+00,& + & 2.516332E+01,1.317036E+02,9.689700E-05,2.304300E-04,4.251200E-04,& + & 8.181200E-04,1.762400E-03,5.279300E-03,1.700700E-02,5.724700E-02,& + & 5.013452E-01,5.191967E+00,3.361380E+01,1.775088E+02,1.252100E-04,& + & 2.732300E-04,5.506300E-04,1.004000E-03,2.285000E-03,6.925900E-03,& + & 2.257000E-02,7.383800E-02,6.546915E-01,6.795976E+00,4.356923E+01,& + & 2.386453E+02,1.603200E-04,3.294000E-04,7.103200E-04,1.231100E-03,& + & 2.912000E-03,8.884600E-03,2.901100E-02,9.287600E-02,8.339132E-01,& + & 8.674408E+00,5.530814E+01,3.157412E+02,1.992500E-04,4.053900E-04,& + & 8.840500E-04,1.528600E-03,3.636600E-03,1.120200E-02,3.615500E-02,& + & 1.146200E-01,1.037258E+00,1.081744E+01,6.891814E+01,4.100336E+02,& + & 6.398400E-05,1.697300E-04,2.642800E-04,5.896500E-04,1.100700E-03,& + & 3.320900E-03,1.057200E-02,3.690500E-02,3.242127E-01,3.488107E+00,& + & 2.539369E+01,1.509522E+02,8.167100E-05,1.922600E-04,3.593900E-04,& + & 6.852100E-04,1.497000E-03,4.481500E-03,1.448000E-02,4.892200E-02,& + & 4.345028E-01,4.684986E+00,3.369204E+01,2.038017E+02,1.056500E-04,& + & 2.290800E-04,4.647600E-04,8.437200E-04,1.937200E-03,5.869800E-03,& + & 1.914800E-02,6.292100E-02,5.664944E-01,6.122466E+00,4.348620E+01,& + & 2.733041E+02,1.344800E-04,2.762700E-04,5.999000E-04,1.037500E-03,& + & 2.463300E-03,7.520400E-03,2.455700E-02,7.898000E-02,7.197708E-01,& + & 7.794669E+00,5.502017E+01,3.600156E+02,1.669600E-04,3.405700E-04,& + & 7.344400E-04,1.297600E-03,3.086800E-03,9.448600E-03,3.054300E-02,& + & 9.724900E-02,8.924907E-01,9.686957E+00,6.838464E+01,4.649345E+02/ + data absb(:, 26: 50) / & + & 5.374900E-05,1.405900E-04,2.262000E-04,4.872600E-04,9.399800E-04,& + & 2.829000E-03,9.018700E-03,3.153900E-02,2.812836E-01,3.119591E+00,& + & 2.514284E+01,1.725588E+02,6.875900E-05,1.601800E-04,3.037100E-04,& + & 5.734200E-04,1.269700E-03,3.808900E-03,1.230800E-02,4.167000E-02,& + & 3.759118E-01,4.184593E+00,3.325525E+01,2.325869E+02,8.903600E-05,& + & 1.918200E-04,3.924200E-04,7.097900E-04,1.637800E-03,4.977300E-03,& + & 1.623000E-02,5.345000E-02,4.888705E-01,5.449038E+00,4.285910E+01,& + & 3.102397E+02,1.127400E-04,2.317100E-04,5.056900E-04,8.735000E-04,& + & 2.080200E-03,6.368400E-03,2.076200E-02,6.695100E-02,6.192504E-01,& + & 6.907857E+00,5.414852E+01,4.064277E+02,1.382400E-04,2.873000E-04,& + & 6.105700E-04,1.099600E-03,2.608200E-03,7.989000E-03,2.575400E-02,& + & 8.233500E-02,7.661204E-01,8.564466E+00,6.718098E+01,5.221488E+02,& + & 4.516000E-05,1.161700E-04,1.934900E-04,4.034600E-04,8.010000E-04,& + & 2.411200E-03,7.696000E-03,2.684000E-02,2.436369E-01,2.760901E+00,& + & 2.448432E+01,1.960246E+02,5.787400E-05,1.335800E-04,2.570300E-04,& + & 4.792300E-04,1.074200E-03,3.246200E-03,1.046200E-02,3.536600E-02,& + & 3.247434E-01,3.693467E+00,3.234538E+01,2.633294E+02,7.495400E-05,& + & 1.604200E-04,3.304500E-04,5.951200E-04,1.384900E-03,4.231600E-03,& + & 1.375700E-02,4.526400E-02,4.209599E-01,4.793346E+00,4.169395E+01,& + & 3.491120E+02,9.448700E-05,1.942400E-04,4.257200E-04,7.347400E-04,& + & 1.756900E-03,5.406000E-03,1.755300E-02,5.656900E-02,5.317288E-01,& + & 6.068155E+00,5.263661E+01,4.548085E+02,1.148500E-04,2.417700E-04,& + & 5.088500E-04,9.290900E-04,2.203000E-03,6.772000E-03,2.171200E-02,& + & 6.949600E-02,6.562262E-01,7.523582E+00,6.528703E+01,5.805857E+02,& + & 3.805000E-05,9.654600E-05,1.660100E-04,3.325200E-04,6.866300E-04,& + & 2.069100E-03,6.594700E-03,2.291800E-02,2.115262E-01,2.439897E+00,& + & 2.368919E+01,2.216178E+02,4.893400E-05,1.118700E-04,2.167900E-04,& + & 4.034000E-04,9.119500E-04,2.779100E-03,8.929500E-03,3.009000E-02,& + & 2.811967E-01,3.244400E+00,3.127030E+01,2.965780E+02,6.337600E-05,& + & 1.346100E-04,2.793800E-04,5.012900E-04,1.175700E-03,3.612200E-03,& + & 1.170700E-02,3.840400E-02,3.633901E-01,4.200375E+00,4.032057E+01,& + & 3.909667E+02,7.939300E-05,1.631900E-04,3.587700E-04,6.212000E-04,& + & 1.488300E-03,4.602800E-03,1.488000E-02,4.792800E-02,4.574454E-01,& + & 5.317863E+00,5.088797E+01,5.061948E+02,9.556500E-05,2.043000E-04,& + & 4.245600E-04,7.873800E-04,1.864700E-03,5.771500E-03,1.833200E-02,& + & 5.883100E-02,5.628974E-01,6.583557E+00,6.300681E+01,6.430230E+02,& + & 3.212100E-05,8.046500E-05,1.397300E-04,2.782400E-04,5.870500E-04,& + & 1.773900E-03,5.651800E-03,1.955600E-02,1.835343E-01,2.139678E+00,& + & 2.274357E+01,2.481140E+02,4.136800E-05,9.351200E-05,1.835600E-04,& + & 3.395900E-04,7.739900E-04,2.372400E-03,7.636200E-03,2.558600E-02,& + & 2.431160E-01,2.838213E+00,3.000905E+01,3.306772E+02,5.358500E-05,& + & 1.126000E-04,2.366000E-04,4.220600E-04,9.975200E-04,3.072900E-03,& + & 9.989700E-03,3.257000E-02,3.128686E-01,3.671241E+00,3.868144E+01,& + & 4.338326E+02,6.674900E-05,1.371200E-04,3.016300E-04,5.245600E-04,& + & 1.260700E-03,3.912300E-03,1.264600E-02,4.058700E-02,3.927711E-01,& + & 4.637386E+00,4.876592E+01,5.589903E+02,7.970400E-05,1.724000E-04,& + & 3.543800E-04,6.665100E-04,1.577100E-03,4.908100E-03,1.551500E-02,& + & 4.975300E-02,4.823975E-01,5.723956E+00,6.023212E+01,7.073226E+02,& + & 2.759700E-05,6.752100E-05,1.202400E-04,2.368600E-04,5.105000E-04,& + & 1.546800E-03,4.955100E-03,1.698800E-02,1.619222E-01,1.908323E+00,& + & 2.201598E+01,2.807742E+02,3.560600E-05,7.910000E-05,1.577500E-04,& + & 2.911100E-04,6.682600E-04,2.053500E-03,6.656200E-03,2.211100E-02,& + & 2.132374E-01,2.522141E+00,2.906818E+01,3.722075E+02,4.606600E-05,& + & 9.485300E-05,2.042400E-04,3.606700E-04,8.588000E-04,2.651200E-03,& + & 8.661100E-03,2.802800E-02,2.731588E-01,3.249877E+00,3.738984E+01,& + & 4.854642E+02,5.691900E-05,1.169400E-04,2.571800E-04,4.483600E-04,& + & 1.083500E-03,3.377000E-03,1.088300E-02,3.485200E-02,3.415288E-01,& + & 4.086002E+00,4.698581E+01,6.224706E+02,6.725200E-05,1.475600E-04,& + & 2.987000E-04,5.722500E-04,1.351400E-03,4.226000E-03,1.328500E-02,& + & 4.260900E-02,4.180874E-01,5.019222E+00,5.789336E+01,7.835770E+02/ + data absb(:, 51: 75) / & + & 2.370300E-05,5.663200E-05,1.042100E-04,2.020300E-04,4.421600E-04,& + & 1.347500E-03,4.346300E-03,1.481100E-02,1.426495E-01,1.702312E+00,& + & 2.116813E+01,3.156430E+02,3.067200E-05,6.721100E-05,1.358100E-04,& + & 2.498500E-04,5.770000E-04,1.776800E-03,5.801900E-03,1.920100E-02,& + & 1.867358E-01,2.239651E+00,2.785880E+01,4.166086E+02,3.925100E-05,& + & 8.087500E-05,1.757600E-04,3.088000E-04,7.390600E-04,2.295900E-03,& + & 7.487400E-03,2.426900E-02,2.380755E-01,2.871586E+00,3.574453E+01,& + & 5.406955E+02,4.862200E-05,9.962400E-05,2.178500E-04,3.854500E-04,& + & 9.310200E-04,2.914100E-03,9.342400E-03,3.011200E-02,2.965504E-01,& + & 3.591337E+00,4.488103E+01,6.890865E+02,5.678300E-05,1.263800E-04,& + & 2.525600E-04,4.911300E-04,1.157200E-03,3.637300E-03,1.139300E-02,& + & 3.666300E-02,3.621136E-01,4.393692E+00,5.518737E+01,8.628609E+02,& + & 2.044400E-05,4.786600E-05,9.064200E-05,1.721500E-04,3.839700E-04,& + & 1.175200E-03,3.808800E-03,1.296500E-02,1.255283E-01,1.520913E+00,& + & 2.019605E+01,3.530780E+02,2.647100E-05,5.731000E-05,1.173600E-04,& + & 2.140900E-04,4.992600E-04,1.543900E-03,5.043900E-03,1.674500E-02,& + & 1.634553E-01,1.991288E+00,2.647982E+01,4.641212E+02,3.353500E-05,& + & 6.915400E-05,1.514200E-04,2.649100E-04,6.368200E-04,1.989500E-03,& + & 6.461700E-03,2.111800E-02,2.074271E-01,2.538807E+00,3.391563E+01,& + & 5.992684E+02,4.144100E-05,8.530100E-05,1.833400E-04,3.334000E-04,& + & 8.009900E-04,2.517000E-03,8.040600E-03,2.609300E-02,2.575182E-01,& + & 3.158890E+00,4.252858E+01,7.595900E+02,4.807000E-05,1.083100E-04,& + & 2.143200E-04,4.212900E-04,9.915500E-04,3.132800E-03,9.763100E-03,& + & 3.168900E-02,3.136243E-01,3.846951E+00,5.234107E+01,9.453167E+02,& + & 1.769100E-05,4.065200E-05,7.865300E-05,1.474400E-04,3.345200E-04,& + & 1.026300E-03,3.336400E-03,1.139300E-02,1.105643E-01,1.361480E+00,& + & 1.915701E+01,3.933803E+02,2.289900E-05,4.893300E-05,1.013900E-04,& + & 1.834100E-04,4.335200E-04,1.344400E-03,4.385500E-03,1.464300E-02,& + & 1.431854E-01,1.772245E+00,2.506590E+01,5.145993E+02,2.873700E-05,& + & 5.925700E-05,1.304600E-04,2.276100E-04,5.497200E-04,1.726400E-03,& + & 5.589100E-03,1.838300E-02,1.809963E-01,2.246912E+00,3.206448E+01,& + & 6.608701E+02,3.477600E-05,7.383500E-05,1.552000E-04,2.882600E-04,& + & 6.894600E-04,2.176100E-03,6.919900E-03,2.264400E-02,2.239763E-01,& + & 2.781962E+00,4.016085E+01,8.331051E+02,4.082000E-05,9.295100E-05,& + & 1.820000E-04,3.613800E-04,8.520400E-04,2.699000E-03,8.373000E-03,& + & 2.740000E-02,2.718826E-01,3.374223E+00,4.948242E+01,1.030628E+03,& + & 1.539100E-05,3.465500E-05,6.834700E-05,1.271200E-04,2.925300E-04,& + & 9.016600E-04,2.930200E-03,1.003800E-02,9.772406E-02,1.222936E+00,& + & 1.816212E+01,4.374975E+02,1.990000E-05,4.169400E-05,8.833000E-05,& + & 1.579500E-04,3.770500E-04,1.175800E-03,3.826900E-03,1.283000E-02,& + & 1.259299E-01,1.582894E+00,2.376227E+01,5.690402E+02,2.470800E-05,& + & 5.093500E-05,1.122100E-04,1.967100E-04,4.763700E-04,1.503100E-03,& + & 4.848400E-03,1.601500E-02,1.585160E-01,1.995343E+00,3.032743E+01,& + & 7.268852E+02,2.943800E-05,6.397900E-05,1.313900E-04,2.504600E-04,& + & 5.954600E-04,1.887100E-03,5.972400E-03,1.963200E-02,1.954428E-01,& + & 2.457948E+00,3.797224E+01,9.083003E+02,3.488400E-05,8.004200E-05,& + & 1.550100E-04,3.110900E-04,7.341000E-04,2.330600E-03,7.193000E-03,& + & 2.370400E-02,2.365639E-01,2.969611E+00,4.669937E+01,1.121556E+03,& + & 1.340100E-05,2.963300E-05,5.943800E-05,1.101200E-04,2.551600E-04,& + & 7.914100E-04,2.569400E-03,8.812300E-03,8.633863E-02,1.098149E+00,& + & 1.719391E+01,4.835690E+02,1.723100E-05,3.556200E-05,7.711000E-05,& + & 1.362600E-04,3.274000E-04,1.026900E-03,3.341400E-03,1.117800E-02,& + & 1.107163E-01,1.411395E+00,2.245179E+01,6.257466E+02,2.130000E-05,& + & 4.385300E-05,9.648400E-05,1.696900E-04,4.127100E-04,1.307400E-03,& + & 4.203500E-03,1.389000E-02,1.388218E-01,1.769418E+00,2.863362E+01,& + & 7.947998E+02,2.504100E-05,5.534800E-05,1.116300E-04,2.169700E-04,& + & 5.142300E-04,1.634800E-03,5.144500E-03,1.699200E-02,1.705266E-01,& + & 2.171404E+00,3.580367E+01,9.911327E+02,2.984300E-05,6.892000E-05,& + & 1.319800E-04,2.676400E-04,6.318300E-04,2.009200E-03,6.171000E-03,& + & 2.049200E-02,2.059277E-01,2.615627E+00,4.395134E+01,1.214128E+03/ + data absb(:, 76:100) / & + & 1.167100E-05,2.543200E-05,5.186500E-05,9.526800E-05,2.221600E-04,& + & 6.937100E-04,2.255700E-03,7.697400E-03,7.621794E-02,9.830786E-01,& + & 1.623335E+01,5.314969E+02,1.482700E-05,3.061400E-05,6.706200E-05,& + & 1.177500E-04,2.838900E-04,8.959200E-04,2.911700E-03,9.712700E-03,& + & 9.729380E-02,1.256633E+00,2.117237E+01,6.842053E+02,1.838300E-05,& + & 3.766500E-05,8.162200E-05,1.481100E-04,3.574800E-04,1.135500E-03,& + & 3.636200E-03,1.204000E-02,1.214737E-01,1.568155E+00,2.701198E+01,& + & 8.643340E+02,2.130700E-05,4.787100E-05,9.518900E-05,1.873900E-04,& + & 4.436700E-04,1.413700E-03,4.428400E-03,1.471600E-02,1.487779E-01,& + & 1.916695E+00,3.372030E+01,1.072441E+03,2.554900E-05,5.932800E-05,& + & 1.125000E-04,2.300200E-04,5.434400E-04,1.732700E-03,5.285900E-03,& + & 1.769600E-02,1.793669E-01,2.302558E+00,4.137375E+01,1.307428E+03,& + & 1.018300E-05,2.184800E-05,4.522900E-05,8.199000E-05,1.942500E-04,& + & 6.079500E-04,1.979100E-03,6.720600E-03,6.737592E-02,8.804866E-01,& + & 1.533805E+01,5.821898E+02,1.279800E-05,2.643200E-05,5.824800E-05,& + & 1.018300E-04,2.464200E-04,7.816600E-04,2.533700E-03,8.438200E-03,& + & 8.559402E-02,1.119413E+00,1.999201E+01,7.435991E+02,1.553500E-05,& + & 3.284400E-05,6.937100E-05,1.288700E-04,3.096600E-04,9.857200E-04,& + & 3.143100E-03,1.045800E-02,1.064290E-01,1.391553E+00,2.549421E+01,& + & 9.368858E+02,1.819700E-05,4.138300E-05,8.130500E-05,1.615500E-04,& + & 3.828500E-04,1.223300E-03,3.808300E-03,1.274000E-02,1.300439E-01,& + & 1.695356E+00,3.182690E+01,1.156571E+03,2.183800E-05,5.104700E-05,& + & 9.598700E-05,1.977900E-04,4.674300E-04,1.493800E-03,4.522700E-03,& + & 1.528200E-02,1.564113E-01,2.031990E+00,3.905742E+01,1.402829E+03,& + & 8.884400E-06,1.868000E-05,3.954800E-05,7.081200E-05,1.691600E-04,& + & 5.323000E-04,1.734800E-03,5.855200E-03,5.951015E-02,7.881512E-01,& + & 1.450670E+01,6.347640E+02,1.104300E-05,2.278200E-05,5.023600E-05,& + & 8.819700E-05,2.140500E-04,6.810600E-04,2.200400E-03,7.352400E-03,& + & 7.525976E-02,9.974532E-01,1.890256E+01,8.085544E+02,1.317200E-05,& + & 2.857800E-05,5.892700E-05,1.120900E-04,2.678200E-04,8.552200E-04,& + & 2.712800E-03,9.075900E-03,9.331670E-02,1.235099E+00,2.409039E+01,& + & 1.011018E+03,1.559300E-05,3.576600E-05,6.936100E-05,1.393200E-04,& + & 3.300800E-04,1.057600E-03,3.269500E-03,1.102200E-02,1.137076E-01,& + & 1.501588E+00,3.013174E+01,1.241435E+03,1.867800E-05,4.377200E-05,& + & 8.198500E-05,1.699000E-04,4.017600E-04,1.285900E-03,3.867100E-03,& + & 1.317500E-02,1.364237E-01,1.796654E+00,3.698551E+01,1.498730E+03,& + & 7.731300E-06,1.597100E-05,3.467200E-05,6.129700E-05,1.472200E-04,& + & 4.659200E-04,1.516800E-03,5.114500E-03,5.258411E-02,7.058484E-01,& + & 1.376998E+01,6.897694E+02,9.551800E-06,1.969000E-05,4.335700E-05,& + & 7.624200E-05,1.859600E-04,5.930300E-04,1.909000E-03,6.399600E-03,& + & 6.626295E-02,8.897034E-01,1.793300E+01,8.741238E+02,1.123700E-05,& + & 2.482500E-05,5.011900E-05,9.737100E-05,2.316200E-04,7.422100E-04,& + & 2.338900E-03,7.875800E-03,8.190917E-02,1.098953E+00,2.287884E+01,& + & 1.087089E+03,1.338200E-05,3.090700E-05,5.923000E-05,1.200400E-04,& + & 2.845500E-04,9.134600E-04,2.804200E-03,9.528300E-03,9.952056E-02,& + & 1.333518E+00,2.866042E+01,1.328167E+03,1.599900E-05,3.756400E-05,& + & 7.008700E-05,1.457800E-04,3.453500E-04,1.106100E-03,3.306300E-03,& + & 1.135100E-02,1.190953E-01,1.594102E+00,3.526052E+01,1.595830E+03,& + & 6.679400E-06,1.380400E-05,3.029100E-05,5.306800E-05,1.282200E-04,& + & 4.075100E-04,1.324500E-03,4.468600E-03,4.649969E-02,6.332059E-01,& + & 1.311180E+01,7.471530E+02,8.278100E-06,1.697700E-05,3.676100E-05,& + & 6.674300E-05,1.614600E-04,5.164300E-04,1.654600E-03,5.575300E-03,& + & 5.836614E-02,7.954880E-01,1.709929E+01,9.418257E+02,9.592400E-06,& + & 2.156200E-05,4.285900E-05,8.435800E-05,2.002100E-04,6.436600E-04,& + & 2.014800E-03,6.832600E-03,7.190849E-02,9.800614E-01,2.187291E+01,& + & 1.165153E+03,1.149600E-05,2.671200E-05,5.062100E-05,1.034100E-04,& + & 2.452800E-04,7.884800E-04,2.406700E-03,8.233100E-03,8.716679E-02,& + & 1.186748E+00,2.744441E+01,1.409639E+03,1.371700E-05,3.227500E-05,& + & 5.982600E-05,1.251400E-04,2.967700E-04,9.509500E-04,2.825600E-03,& + & 9.779800E-03,1.040882E-01,1.417963E+00,3.388099E+01,1.693575E+03/ + data absb(:,101:125) / & + & 5.781500E-06,1.194500E-05,2.634300E-05,4.602100E-05,1.115800E-04,& + & 3.561000E-04,1.154700E-03,3.907500E-03,4.110830E-02,5.687716E-01,& + & 1.255120E+01,8.065112E+02,7.004200E-06,1.485600E-05,3.129100E-05,& + & 5.821000E-05,1.401100E-04,4.493400E-04,1.432200E-03,4.854400E-03,& + & 5.141696E-02,7.124767E-01,1.641404E+01,1.011090E+03,8.209800E-06,& + & 1.869600E-05,3.668500E-05,7.282300E-05,1.731300E-04,5.575300E-04,& + & 1.735500E-03,5.924000E-03,6.317150E-02,8.755015E-01,2.104443E+01,& + & 1.244479E+03,9.848900E-06,2.303700E-05,4.325100E-05,8.909500E-05,& + & 2.113300E-04,6.801500E-04,2.063900E-03,7.115400E-03,7.637257E-02,& + & 1.059141E+00,2.649909E+01,1.505322E+03,1.176600E-05,2.765900E-05,& + & 5.113600E-05,1.073200E-04,2.549600E-04,8.166800E-04,2.412700E-03,& + & 8.421600E-03,9.105290E-02,1.266874E+00,3.284007E+01,1.791565E+03,& + & 4.964100E-06,1.025200E-05,2.261900E-05,3.961100E-05,9.635600E-05,& + & 3.084900E-04,9.973200E-04,3.388500E-03,3.604304E-02,5.073863E-01,& + & 1.197763E+01,8.605342E+02,5.923500E-06,1.285100E-05,2.647900E-05,& + & 5.032500E-05,1.205500E-04,3.877300E-04,1.229900E-03,4.194300E-03,& + & 4.496504E-02,6.343248E-01,1.573548E+01,1.073684E+03,7.009000E-06,& + & 1.607500E-05,3.116000E-05,6.248400E-05,1.485400E-04,4.790900E-04,& + & 1.485100E-03,5.101700E-03,5.513957E-02,7.787021E-01,2.024310E+01,& + & 1.315772E+03,8.389500E-06,1.967000E-05,3.681700E-05,7.613100E-05,& + & 1.807900E-04,5.824200E-04,1.758500E-03,6.109600E-03,6.654969E-02,& + & 9.428567E-01,2.560193E+01,1.584887E+03,1.003700E-05,2.356100E-05,& + & 4.345400E-05,9.141800E-05,2.175800E-04,6.969700E-04,2.048600E-03,& + & 7.210200E-03,7.924418E-02,1.129122E+00,3.187234E+01,1.878681E+03,& + & 4.178000E-06,8.628800E-06,1.904400E-05,3.331400E-05,8.134300E-05,& + & 2.610000E-04,8.424000E-04,2.875500E-03,3.091620E-02,4.433302E-01,& + & 1.121677E+01,8.954015E+02,4.952000E-06,1.084700E-05,2.209400E-05,& + & 4.249300E-05,1.015100E-04,3.272900E-04,1.036500E-03,3.551500E-03,& + & 3.856058E-02,5.543502E-01,1.482130E+01,1.114374E+03,5.879700E-06,& + & 1.353200E-05,2.606900E-05,5.251900E-05,1.249000E-04,4.034400E-04,& + & 1.248200E-03,4.314200E-03,4.725509E-02,6.816553E-01,1.918544E+01,& + & 1.361938E+03,7.028800E-06,1.650200E-05,3.081400E-05,6.385100E-05,& + & 1.517800E-04,4.896100E-04,1.474500E-03,5.154000E-03,5.704114E-02,& + & 8.274832E-01,2.441352E+01,1.636154E+03,8.412300E-06,1.973300E-05,& + & 3.633200E-05,7.654300E-05,1.823900E-04,5.844900E-04,1.714900E-03,& + & 6.086700E-03,6.791454E-02,9.939002E-01,3.055585E+01,1.935028E+03,& + & 3.437000E-06,7.097000E-06,1.566000E-05,2.739700E-05,6.696500E-05,& + & 2.152500E-04,6.945900E-04,2.381900E-03,2.589677E-02,3.780024E-01,& + & 1.025632E+01,9.071883E+02,4.069000E-06,8.924600E-06,1.815000E-05,& + & 3.495600E-05,8.352000E-05,2.697200E-04,8.547900E-04,2.942900E-03,& + & 3.232544E-02,4.743080E-01,1.366081E+01,1.128366E+03,4.833500E-06,& + & 1.113000E-05,2.142000E-05,4.317000E-05,1.027500E-04,3.323600E-04,& + & 1.029000E-03,3.574400E-03,3.967546E-02,5.855423E-01,1.783259E+01,& + & 1.377978E+03,5.776600E-06,1.356400E-05,2.531800E-05,5.246600E-05,& + & 1.248200E-04,4.032000E-04,1.215100E-03,4.274300E-03,4.797381E-02,& + & 7.137071E-01,2.287715E+01,1.654422E+03,6.914000E-06,1.621700E-05,& + & 2.984500E-05,6.287900E-05,1.499300E-04,4.810600E-04,1.413100E-03,& + & 5.050300E-03,5.718591E-02,8.609322E-01,2.882038E+01,1.955507E+03,& + & 2.736600E-06,5.654600E-06,1.248100E-05,2.184200E-05,5.320600E-05,& + & 1.712700E-04,5.541800E-04,1.908000E-03,2.098131E-02,3.111038E-01,& + & 9.010344E+00,8.866869E+02,3.261700E-06,7.091200E-06,1.456700E-05,& + & 2.776900E-05,6.654500E-05,2.150500E-04,6.843100E-04,2.365100E-03,& + & 2.626627E-02,3.928934E-01,1.214704E+01,1.105232E+03,3.861700E-06,& + & 8.866700E-06,1.716000E-05,3.442400E-05,8.199000E-05,2.656200E-04,& + & 8.260500E-04,2.879400E-03,3.234222E-02,4.884466E-01,1.604277E+01,& + & 1.352461E+03,4.622400E-06,1.084200E-05,2.027300E-05,4.191200E-05,& + & 9.976400E-05,3.228800E-04,9.777200E-04,3.453900E-03,3.926263E-02,& + & 5.993257E-01,2.079324E+01,1.627044E+03,5.530800E-06,1.298000E-05,& + & 2.392400E-05,5.031400E-05,1.200100E-04,3.860500E-04,1.139300E-03,& + & 4.090600E-03,4.710200E-02,7.259559E-01,2.644149E+01,1.926258E+03/ + data absb(:,126:150) / & + & 2.176300E-06,4.496400E-06,9.922900E-06,1.735200E-05,4.220800E-05,& + & 1.359200E-04,4.410300E-04,1.525200E-03,1.696072E-02,2.556857E-01,& + & 7.926197E+00,8.635819E+02,2.615500E-06,5.618000E-06,1.170700E-05,& + & 2.197100E-05,5.290200E-05,1.710700E-04,5.466600E-04,1.896100E-03,& + & 2.131937E-02,3.249265E-01,1.082501E+01,1.079056E+03,3.081100E-06,& + & 7.048400E-06,1.372800E-05,2.738900E-05,6.529900E-05,2.118400E-04,& + & 6.616400E-04,2.315400E-03,2.633031E-02,4.069821E-01,1.446455E+01,& + & 1.323625E+03,3.693900E-06,8.648100E-06,1.620800E-05,3.342900E-05,& + & 7.957700E-05,2.580300E-04,7.853100E-04,2.787500E-03,3.207296E-02,& + & 5.026747E-01,1.894617E+01,1.595550E+03,4.415200E-06,1.037700E-05,& + & 1.914700E-05,4.019500E-05,9.589500E-05,3.091700E-04,9.171700E-04,& + & 3.307600E-03,3.880654E-02,6.112013E-01,2.432668E+01,1.892570E+03,& + & 1.731300E-06,3.579400E-06,7.898000E-06,1.377000E-05,3.347200E-05,& + & 1.078500E-04,3.507800E-04,1.218600E-03,1.369585E-02,2.103003E-01,& + & 7.001648E+00,8.400762E+02,2.101700E-06,4.446000E-06,9.382400E-06,& + & 1.741400E-05,4.204100E-05,1.360700E-04,4.364700E-04,1.520400E-03,& + & 1.729851E-02,2.691761E-01,9.692351E+00,1.052390E+03,2.460600E-06,& + & 5.600600E-06,1.099400E-05,2.177800E-05,5.198400E-05,1.688500E-04,& + & 5.298600E-04,1.862500E-03,2.144687E-02,3.393698E-01,1.310378E+01,& + & 1.293842E+03,2.951900E-06,6.905500E-06,1.295600E-05,2.664800E-05,& + & 6.346200E-05,2.061400E-04,6.305600E-04,2.248300E-03,2.631828E-02,& + & 4.211618E-01,1.734536E+01,1.562956E+03,3.526600E-06,8.293500E-06,& + & 1.531900E-05,3.210000E-05,7.659300E-05,2.475500E-04,7.380900E-04,& + & 2.674600E-03,3.198625E-02,5.152432E-01,2.248498E+01,1.850474E+03,& + & 1.346900E-06,2.784900E-06,6.121400E-06,1.069600E-05,2.592500E-05,& + & 8.344500E-05,2.722300E-04,9.504700E-04,1.080731E-02,1.682165E-01,& + & 5.988328E+00,7.967462E+02,1.669300E-06,3.424400E-06,7.414800E-06,& + & 1.345000E-05,3.266000E-05,1.057300E-04,3.409900E-04,1.191900E-03,& + & 1.373786E-02,2.173494E-01,8.432590E+00,1.002376E+03,1.934400E-06,& + & 4.349700E-06,8.641100E-06,1.696800E-05,4.050900E-05,1.317400E-04,& + & 4.162300E-04,1.467900E-03,1.714222E-02,2.763455E-01,1.155654E+01,& + & 1.237706E+03,2.318200E-06,5.388800E-06,1.020300E-05,2.079500E-05,& + & 4.962700E-05,1.614500E-04,4.976300E-04,1.780000E-03,2.119015E-02,& + & 3.451891E-01,1.550089E+01,1.501123E+03,2.766700E-06,6.510300E-06,& + & 1.205200E-05,2.516400E-05,6.003700E-05,1.946500E-04,5.847900E-04,& + & 2.125500E-03,2.583898E-02,4.259348E-01,2.031888E+01,1.790551E+03,& + & 1.046100E-06,2.163400E-06,4.707900E-06,8.292600E-06,2.000300E-05,& + & 6.427400E-05,2.101600E-04,7.379700E-04,8.484136E-03,1.339141E-01,& + & 5.096008E+00,7.516961E+02,1.292700E-06,2.666100E-06,5.879200E-06,& + & 1.030100E-05,2.526700E-05,8.183600E-05,2.652900E-04,9.305500E-04,& + & 1.086617E-02,1.746629E-01,7.310858E+00,9.503164E+02,1.520100E-06,& + & 3.362300E-06,6.781400E-06,1.315000E-05,3.146900E-05,1.023800E-04,& + & 3.257800E-04,1.152300E-03,1.367343E-02,2.238772E-01,1.017124E+01,& + & 1.178855E+03,1.810700E-06,4.185600E-06,8.007500E-06,1.619600E-05,& + & 3.867200E-05,1.260000E-04,3.914600E-04,1.404200E-03,1.702106E-02,& + & 2.819854E-01,1.382605E+01,1.435734E+03,2.165300E-06,5.084900E-06,& + & 9.464900E-06,1.966300E-05,4.692300E-05,1.525600E-04,4.619000E-04,& + & 1.683700E-03,2.082206E-02,3.509792E-01,1.832796E+01,1.719530E+03,& + & 8.065800E-07,1.695100E-06,3.604800E-06,6.432100E-06,1.541100E-05,& + & 4.942500E-05,1.618600E-04,5.719500E-04,6.646346E-03,1.064555E-01,& + & 4.339023E+00,7.078673E+02,1.002200E-06,2.068800E-06,4.569800E-06,& + & 7.993000E-06,1.951900E-05,6.324200E-05,2.059900E-04,7.253100E-04,& + & 8.578858E-03,1.402310E-01,6.338516E+00,8.992170E+02,1.194300E-06,& + & 2.595800E-06,5.344900E-06,1.015300E-05,2.442000E-05,7.946100E-05,& + & 2.545400E-04,9.034100E-04,1.089794E-02,1.811234E-01,8.961333E+00,& + & 1.120610E+03,1.414300E-06,3.247900E-06,6.285400E-06,1.259900E-05,& + & 3.010100E-05,9.819700E-05,3.074900E-04,1.106200E-03,1.365748E-02,& + & 2.300392E-01,1.234072E+01,1.371044E+03,1.694500E-06,3.973300E-06,& + & 7.426300E-06,1.534500E-05,3.663700E-05,1.194000E-04,3.644100E-04,& + & 1.332000E-03,1.684139E-02,2.885673E-01,1.655227E+01,1.648537E+03/ + data absb(:,151:175) / & + & 6.102200E-07,1.315600E-06,2.721600E-06,4.929400E-06,1.168700E-05,& + & 3.739300E-05,1.224400E-04,4.363200E-04,5.115562E-03,8.310293E-02,& + & 3.608072E+00,6.559334E+02,7.684700E-07,1.588900E-06,3.507600E-06,& + & 6.114700E-06,1.486700E-05,4.814200E-05,1.575500E-04,5.571600E-04,& + & 6.664149E-03,1.106708E-01,5.379527E+00,8.382401E+02,9.363700E-07,& + & 1.970300E-06,4.178300E-06,7.722200E-06,1.869800E-05,6.081800E-05,& + & 1.963100E-04,6.986600E-04,8.561860E-03,1.442871E-01,7.748814E+00,& + & 1.050802E+03,1.094500E-06,2.487200E-06,4.893200E-06,9.671100E-06,& + & 2.314000E-05,7.557500E-05,2.387100E-04,8.607400E-04,1.081005E-02,& + & 1.849725E-01,1.082106E+01,1.292610E+03,1.313700E-06,3.072700E-06,& + & 5.766100E-06,1.184000E-05,2.826900E-05,9.233700E-05,2.845800E-04,& + & 1.042100E-03,1.344441E-02,2.341101E-01,1.472212E+01,1.562341E+03,& + & 4.584000E-07,1.008300E-06,2.046800E-06,3.779600E-06,8.767900E-06,& + & 2.803100E-05,9.165600E-05,3.296700E-04,3.897828E-03,6.415715E-02,& + & 2.960903E+00,6.021974E+02,5.861300E-07,1.210800E-06,2.650400E-06,& + & 4.651800E-06,1.126100E-05,3.636400E-05,1.194000E-04,4.243900E-04,& + & 5.134013E-03,8.649916E-02,4.505906E+00,7.749368E+02,7.255800E-07,& + & 1.491800E-06,3.264800E-06,5.813600E-06,1.420900E-05,4.622300E-05,& + & 1.502100E-04,5.360700E-04,6.660909E-03,1.139612E-01,6.626183E+00,& + & 9.775247E+02,8.473100E-07,1.889800E-06,3.782000E-06,7.380800E-06,& + & 1.767300E-05,5.775400E-05,1.840800E-04,6.649400E-04,8.487142E-03,& + & 1.475848E-01,9.403271E+00,1.210020E+03,1.013000E-06,2.348400E-06,& + & 4.470100E-06,9.067700E-06,2.169300E-05,7.096000E-05,2.208400E-04,& + & 8.099500E-04,1.067335E-02,1.883960E-01,1.297552E+01,1.470799E+03,& + & 3.442400E-07,7.759700E-07,1.536100E-06,2.864900E-06,6.593100E-06,& + & 2.095200E-05,6.834300E-05,2.483000E-04,2.957356E-03,4.935408E-02,& + & 2.422132E+00,5.515556E+02,4.450400E-07,9.317800E-07,1.989300E-06,& + & 3.544600E-06,8.508700E-06,2.739600E-05,9.013000E-05,3.223000E-04,& + & 3.935704E-03,6.738364E-02,3.761720E+00,7.144763E+02,5.524200E-07,& + & 1.139600E-06,2.518400E-06,4.404500E-06,1.077600E-05,3.505000E-05,& + & 1.146000E-04,4.102500E-04,5.166939E-03,8.976608E-02,5.646014E+00,& + & 9.072560E+02,6.569100E-07,1.432300E-06,2.939300E-06,5.600300E-06,& + & 1.347800E-05,4.404800E-05,1.415500E-04,5.122900E-04,6.649440E-03,& + & 1.174756E-01,8.158482E+00,1.129945E+03,7.792500E-07,1.791900E-06,& + & 3.460200E-06,6.941900E-06,1.661400E-05,5.441300E-05,1.710200E-04,& + & 6.279400E-04,8.432459E-03,1.514939E-01,1.141379E+01,1.381751E+03,& + & 2.569700E-07,5.964000E-07,1.150300E-06,2.163600E-06,4.908000E-06,& + & 1.550400E-05,5.043800E-05,1.851700E-04,2.219700E-03,3.753465E-02,& + & 1.951992E+00,5.007899E+02,3.326100E-07,7.174300E-07,1.483200E-06,& + & 2.689700E-06,6.375500E-06,2.046900E-05,6.733600E-05,2.427000E-04,& + & 2.987773E-03,5.195442E-02,3.098503E+00,6.534503E+02,4.192100E-07,& + & 8.666400E-07,1.913700E-06,3.334800E-06,8.116000E-06,2.638000E-05,& + & 8.669200E-05,3.114300E-04,3.967874E-03,7.007856E-02,4.749458E+00,& + & 8.355826E+02,5.121800E-07,1.073900E-06,2.282300E-06,4.210900E-06,& + & 1.021300E-05,3.335300E-05,1.081300E-04,3.918900E-04,5.165412E-03,& + & 9.273540E-02,7.000908E+00,1.047796E+03,5.977300E-07,1.358500E-06,& + & 2.671900E-06,5.278500E-06,1.264700E-05,4.146500E-05,1.316000E-04,& + & 4.836300E-04,6.617044E-03,1.208792E-01,9.944111E+00,1.289605E+03,& + & 1.898700E-07,4.587500E-07,8.377700E-07,1.642300E-06,3.591900E-06,& + & 1.128500E-05,3.655300E-05,1.358500E-04,1.637327E-03,2.796480E-02,& + & 1.531407E+00,4.479353E+02,2.456700E-07,5.430300E-07,1.097100E-06,& + & 2.032500E-06,4.703800E-06,1.507100E-05,4.946200E-05,1.800800E-04,& + & 2.232802E-03,3.930451E-02,2.489103E+00,5.892823E+02,3.154400E-07,& + & 6.520200E-07,1.421700E-06,2.501900E-06,6.053400E-06,1.959600E-05,& + & 6.464800E-05,2.331700E-04,3.001470E-03,5.378812E-02,3.902480E+00,& + & 7.596612E+02,3.905300E-07,8.041500E-07,1.773900E-06,3.109200E-06,& + & 7.648500E-06,2.496100E-05,8.156300E-05,2.960300E-04,3.955710E-03,& + & 7.209910E-02,5.882025E+00,9.599128E+02,4.578700E-07,1.016500E-06,& + & 2.044300E-06,3.969700E-06,9.528100E-06,3.124300E-05,1.001800E-04,& + & 3.682600E-04,5.120684E-03,9.511582E-02,8.511992E+00,1.190092E+03/ + data absb(:,176:200) / & + & 1.405800E-07,3.563400E-07,6.140700E-07,1.243800E-06,2.606200E-06,& + & 8.171300E-06,2.634300E-05,9.913500E-05,1.198696E-03,2.070687E-02,& + & 1.193147E+00,3.993415E+02,1.813800E-07,4.138500E-07,8.097200E-07,& + & 1.517600E-06,3.473900E-06,1.104800E-05,3.614200E-05,1.330100E-04,& + & 1.657580E-03,2.957369E-02,1.984506E+00,5.295494E+02,2.348300E-07,& + & 4.996800E-07,1.045300E-06,1.880500E-06,4.498700E-06,1.450700E-05,& + & 4.793300E-05,1.738800E-04,2.257342E-03,4.108124E-02,3.184129E+00,& + & 6.882080E+02,2.933000E-07,6.050500E-07,1.336300E-06,2.338600E-06,& + & 5.708500E-06,1.862600E-05,6.126400E-05,2.227800E-04,3.011524E-03,& + & 5.582426E-02,4.908920E+00,8.765688E+02,3.519700E-07,7.577900E-07,& + & 1.577600E-06,2.959800E-06,7.161800E-06,2.347800E-05,7.598600E-05,& + & 2.794700E-04,3.944536E-03,7.459970E-02,7.247744E+00,1.094918E+03,& + & 1.046200E-07,2.796600E-07,4.389000E-07,9.663700E-07,1.862100E-06,& + & 5.889200E-06,1.886600E-05,7.190400E-05,8.710741E-04,1.523415E-02,& + & 9.229128E-01,3.546856E+02,1.338500E-07,3.160700E-07,5.967600E-07,& + & 1.142100E-06,2.549600E-06,8.059400E-06,2.626300E-05,9.773300E-05,& + & 1.221446E-03,2.212193E-02,1.569784E+00,4.742739E+02,1.734700E-07,& + & 3.784900E-07,7.744900E-07,1.418400E-06,3.324600E-06,1.070000E-05,& + & 3.531100E-05,1.291800E-04,1.685142E-03,3.121603E-02,2.578792E+00,& + & 6.214396E+02,2.205300E-07,4.553900E-07,1.001800E-06,1.752000E-06,& + & 4.257800E-06,1.385400E-05,4.577800E-05,1.669900E-04,2.277440E-03,& + & 4.304700E-02,4.065967E+00,7.977869E+02,2.739600E-07,5.607300E-07,& + & 1.215100E-06,2.202700E-06,5.368400E-06,1.759100E-05,5.742500E-05,& + & 2.112900E-04,3.017208E-03,5.827061E-02,6.133633E+00,1.004252E+03,& + & 7.920500E-08,2.233500E-07,3.023200E-07,7.668100E-07,1.331100E-06,& + & 4.252700E-06,1.355700E-05,5.230700E-05,6.356496E-04,1.123422E-02,& + & 7.180650E-01,3.164464E+02,9.961100E-08,2.461900E-07,4.363200E-07,& + & 8.701500E-07,1.874800E-06,5.898900E-06,1.913900E-05,7.201900E-05,& + & 9.043685E-04,1.658883E-02,1.249317E+00,4.264181E+02,1.289000E-07,& + & 2.883200E-07,5.750100E-07,1.071800E-06,2.471700E-06,7.916000E-06,& + & 2.606400E-05,9.621600E-05,1.263903E-03,2.377130E-02,2.099431E+00,& + & 5.629826E+02,1.669500E-07,3.456300E-07,7.460000E-07,1.323300E-06,& + & 3.189300E-06,1.034100E-05,3.426800E-05,1.255400E-04,1.730706E-03,& + & 3.325778E-02,3.381162E+00,7.283070E+02,2.067000E-07,4.252000E-07,& + & 9.396400E-07,1.643600E-06,4.038600E-06,1.322300E-05,4.347300E-05,& + & 1.602000E-04,2.320621E-03,4.563479E-02,5.210097E+00,9.235004E+02,& + & 6.062800E-08,1.681000E-07,2.182000E-07,5.763800E-07,9.837400E-07,& + & 3.067200E-06,9.729700E-06,3.796900E-05,4.630154E-04,8.262556E-03,& + & 5.581993E-01,2.824977E+02,7.439600E-08,1.918400E-07,3.255800E-07,& + & 6.667400E-07,1.366500E-06,4.314600E-06,1.392600E-05,5.299700E-05,& + & 6.690555E-04,1.242132E-02,9.941828E-01,3.835061E+02,9.604900E-08,& + & 2.212600E-07,4.293300E-07,8.076500E-07,1.839300E-06,5.853700E-06,& + & 1.921600E-05,7.162000E-05,9.475504E-04,1.807590E-02,1.707032E+00,& + & 5.101281E+02,1.245400E-07,2.668100E-07,5.541100E-07,1.001900E-06,& + & 2.388700E-06,7.717900E-06,2.559700E-05,9.431500E-05,1.314332E-03,& + & 2.566413E-02,2.809163E+00,6.648231E+02,1.563800E-07,3.227200E-07,& + & 7.123600E-07,1.244800E-06,3.038800E-06,9.942000E-06,3.286700E-05,& + & 1.214300E-04,1.784590E-03,3.570364E-02,4.417731E+00,8.491036E+02,& + & 4.500200E-08,1.247700E-07,1.614200E-07,4.357900E-07,7.229300E-07,& + & 2.191900E-06,6.956300E-06,2.741300E-05,3.349854E-04,6.039039E-03,& + & 4.310480E-01,2.515201E+02,5.594300E-08,1.518300E-07,2.309600E-07,& + & 5.264100E-07,9.852500E-07,3.141500E-06,1.008500E-05,3.882500E-05,& + & 4.918654E-04,9.245965E-03,7.862801E-01,3.440443E+02,7.153200E-08,& + & 1.705100E-07,3.181500E-07,6.148000E-07,1.361600E-06,4.313000E-06,& + & 1.410300E-05,5.309300E-05,7.059345E-04,1.368480E-02,1.379136E+00,& + & 4.610312E+02,9.284400E-08,2.032500E-07,4.142800E-07,7.636000E-07,& + & 1.779500E-06,5.743500E-06,1.902200E-05,7.066500E-05,9.932344E-04,& + & 1.972035E-02,2.320302E+00,6.052929E+02,1.185200E-07,2.446500E-07,& + & 5.367000E-07,9.410100E-07,2.285800E-06,7.457600E-06,2.475400E-05,& + & 9.172000E-05,1.365712E-03,2.782332E-02,3.722270E+00,7.788007E+02/ + data absb(:,201:225) / & + & 3.255500E-08,9.169700E-08,1.223900E-07,3.263000E-07,5.353900E-07,& + & 1.548900E-06,4.950200E-06,1.965400E-05,2.403566E-04,4.382718E-03,& + & 3.302407E-01,2.232196E+02,4.249000E-08,1.216300E-07,1.592700E-07,& + & 4.117500E-07,7.132200E-07,2.274000E-06,7.264400E-06,2.828900E-05,& + & 3.590972E-04,6.835260E-03,6.169670E-01,3.076795E+02,5.338300E-08,& + & 1.329300E-07,2.341500E-07,4.686600E-07,1.002500E-06,3.163800E-06,& + & 1.030200E-05,3.917900E-05,5.225542E-04,1.029914E-02,1.106434E+00,& + & 4.153973E+02,6.914900E-08,1.554600E-07,3.084800E-07,5.767000E-07,& + & 1.327500E-06,4.257500E-06,1.407000E-05,5.270800E-05,7.452110E-04,& + & 1.508844E-02,1.902379E+00,5.494844E+02,8.972700E-08,1.865400E-07,& + & 4.001000E-07,7.127300E-07,1.715700E-06,5.576700E-06,1.855800E-05,& + & 6.902400E-05,1.038173E-03,2.159963E-02,3.116360E+00,7.121583E+02,& + & 2.369600E-08,6.806600E-08,9.428700E-08,2.450800E-07,3.953200E-07,& + & 1.105500E-06,3.549900E-06,1.417600E-05,1.744438E-04,3.196092E-03,& + & 2.551668E-01,1.995710E+02,3.265300E-08,9.072400E-08,1.177200E-07,& + & 3.122600E-07,5.307400E-07,1.656900E-06,5.269600E-06,2.073400E-05,& + & 2.649392E-04,5.078957E-03,4.898290E-01,2.770889E+02,4.014000E-08,& + & 1.042600E-07,1.760900E-07,3.623400E-07,7.358500E-07,2.335300E-06,& + & 7.568500E-06,2.907700E-05,3.911316E-04,7.785196E-03,8.979262E-01,& + & 3.767082E+02,5.191400E-08,1.198800E-07,2.322600E-07,4.378500E-07,& + & 9.948500E-07,3.173800E-06,1.046200E-05,3.953400E-05,5.659950E-04,& + & 1.159206E-02,1.574672E+00,5.016559E+02,6.744100E-08,1.445900E-07,& + & 2.997200E-07,5.433400E-07,1.294100E-06,4.192900E-06,1.396500E-05,& + & 5.223400E-05,7.990147E-04,1.684334E-02,2.631960E+00,6.546088E+02,& + & 1.724700E-08,5.085300E-08,7.355900E-08,1.886700E-07,2.957400E-07,& + & 7.795900E-07,2.551700E-06,1.022300E-05,1.268190E-04,2.330049E-03,& + & 1.969864E-01,1.787663E+02,2.454600E-08,6.811600E-08,8.815800E-08,& + & 2.384900E-07,3.953400E-07,1.202500E-06,3.833200E-06,1.519400E-05,& + & 1.961036E-04,3.771786E-03,3.900442E-01,2.500808E+02,3.046900E-08,& + & 8.294900E-08,1.262700E-07,2.881200E-07,5.389800E-07,1.724100E-06,& + & 5.567100E-06,2.159200E-05,2.939673E-04,5.879986E-03,7.309793E-01,& + & 3.422110E+02,3.908700E-08,9.308600E-08,1.740100E-07,3.365600E-07,& + & 7.453400E-07,2.367700E-06,7.787000E-06,2.966400E-05,4.317946E-04,& + & 8.898094E-03,1.306133E+00,4.587923E+02,5.084000E-08,1.110600E-07,& + & 2.265900E-07,4.179500E-07,9.751000E-07,3.156700E-06,1.050200E-05,& + & 3.958500E-05,6.177974E-04,1.314073E-02,2.226018E+00,6.026095E+02,& + & 1.251500E-08,3.809700E-08,5.747400E-08,1.388800E-07,2.215800E-07,& + & 5.539300E-07,1.825000E-06,7.330500E-06,9.171155E-05,1.686569E-03,& + & 1.507932E-01,1.597544E+02,1.802500E-08,5.070800E-08,6.741900E-08,& + & 1.805200E-07,2.957500E-07,8.666600E-07,2.780200E-06,1.108900E-05,& + & 1.444621E-04,2.786476E-03,3.087303E-01,2.252002E+02,2.329600E-08,& + & 6.660100E-08,8.906400E-08,2.277000E-07,3.955300E-07,1.267300E-06,& + & 4.080700E-06,1.597600E-05,2.198258E-04,4.421790E-03,5.914644E-01,& + & 3.103140E+02,2.945600E-08,7.309700E-08,1.294900E-07,2.589600E-07,& + & 5.566200E-07,1.761900E-06,5.776000E-06,2.219600E-05,3.278716E-04,& + & 6.797717E-03,1.077987E+00,4.187279E+02,3.830000E-08,8.562600E-08,& + & 1.706700E-07,3.192200E-07,7.361200E-07,2.369500E-06,7.876500E-06,& + & 2.990600E-05,4.765178E-04,1.020676E-02,1.873003E+00,5.535584E+02,& + & 9.021100E-09,2.857500E-08,4.531700E-08,9.921100E-08,1.738700E-07,& + & 3.836200E-07,1.302000E-06,5.223100E-06,6.588611E-05,1.220342E-03,& + & 1.145005E-01,1.423158E+02,1.318300E-08,3.777800E-08,5.204300E-08,& + & 1.362800E-07,2.199900E-07,6.217400E-07,2.009600E-06,8.047500E-06,& + & 1.057056E-04,2.052530E-03,2.418182E-01,2.023769E+02,1.789100E-08,& + & 5.054300E-08,6.542400E-08,1.730900E-07,2.959700E-07,9.300200E-07,& + & 2.978300E-06,1.176900E-05,1.634717E-04,3.307840E-03,4.757559E-01,& + & 2.781575E+02,2.222000E-08,5.722600E-08,9.776100E-08,2.004000E-07,& + & 4.115200E-07,1.306800E-06,4.268800E-06,1.654800E-05,2.473568E-04,& + & 5.173898E-03,8.856949E-01,3.813354E+02,2.885700E-08,6.619300E-08,& + & 1.288200E-07,2.431500E-07,5.543400E-07,1.774000E-06,5.887200E-06,& + & 2.252400E-05,3.649047E-04,7.899390E-03,1.566916E+00,5.074447E+02/ + data absb(:,226:235) / & + & 6.493500E-09,2.127400E-08,3.498800E-08,7.231100E-08,1.381300E-07,& + & 2.638100E-07,9.321600E-07,3.723000E-06,4.743365E-05,8.874735E-04,& + & 8.693139E-02,1.271393E+02,9.647200E-09,2.831900E-08,4.061700E-08,& + & 1.044000E-07,1.656900E-07,4.433000E-07,1.458000E-06,5.848900E-06,& + & 7.749149E-05,1.529303E-03,1.897678E-01,1.824372E+02,1.370600E-08,& + & 3.806100E-08,4.897000E-08,1.324900E-07,2.219700E-07,6.799100E-07,& + & 2.184200E-06,8.684800E-06,1.216676E-04,2.512265E-03,3.846381E-01,& + & 2.548871E+02,1.685800E-08,4.548500E-08,7.160100E-08,1.583900E-07,& + & 3.038600E-07,9.706600E-07,3.163400E-06,1.236300E-05,1.869776E-04,& + & 3.974491E-03,7.311717E-01,3.483199E+02,2.180300E-08,5.133600E-08,& + & 9.743100E-08,1.870700E-07,4.177400E-07,1.331000E-06,4.409700E-06,& + & 1.699900E-05,2.798372E-04,6.128387E-03,1.316511E+00,4.663946E+02,& + & 5.041300E-09,1.678500E-08,2.813100E-08,5.644900E-08,1.115300E-07,& + & 2.012000E-07,7.263400E-07,2.889300E-06,3.761251E-05,7.256240E-04,& + & 7.616846E-02,1.214370E+02,7.547700E-09,2.238900E-08,3.265300E-08,& + & 8.396900E-08,1.301400E-07,3.441500E-07,1.140500E-06,4.577800E-06,& + & 6.195711E-05,1.274860E-03,1.697967E-01,1.748988E+02,1.080000E-08,& + & 3.004700E-08,3.898600E-08,1.057900E-07,1.751300E-07,5.323700E-07,& + & 1.716700E-06,6.844700E-06,9.838250E-05,2.126454E-03,3.502418E-01,& + & 2.450637E+02,1.339200E-08,3.685000E-08,5.567800E-08,1.287000E-07,& + & 2.383200E-07,7.650100E-07,2.495000E-06,9.795500E-06,1.528737E-04,& + & 3.411825E-03,6.727303E-01,3.357825E+02,1.729000E-08,4.130800E-08,& + & 7.693300E-08,1.498700E-07,3.309600E-07,1.053300E-06,3.491900E-06,& + & 1.353400E-05,2.315021E-04,5.286700E-03,1.221836E+00,4.507178E+02/ + + + data selfref(:, :) / & + & 7.256950E-01,9.619960E-01,9.725840E-01,1.247900E+00,1.235740E+00,& + & 1.209210E+00,1.381120E+00,1.303210E+00,1.289824E+00,1.419931E+00,& + & 1.560989E+00,1.669523E+00,6.535910E-01,8.778530E-01,9.026580E-01,& + & 1.143530E+00,1.129280E+00,1.106600E+00,1.267270E+00,1.201270E+00,& + & 1.198051E+00,1.327587E+00,1.460123E+00,1.556237E+00,5.886500E-01,& + & 8.010700E-01,8.377600E-01,1.047900E+00,1.032000E+00,1.012700E+00,& + & 1.162800E+00,1.107300E+00,1.112838E+00,1.241311E+00,1.365824E+00,& + & 1.450815E+00,5.301620E-01,7.310030E-01,7.775270E-01,9.602630E-01,& + & 9.430960E-01,9.267660E-01,1.066940E+00,1.020680E+00,1.033717E+00,& + & 1.160689E+00,1.277656E+00,1.352679E+00,4.774850E-01,6.670640E-01,& + & 7.216260E-01,8.799560E-01,8.618510E-01,8.481240E-01,9.789900E-01,& + & 9.408400E-01,9.602479E-01,1.085347E+00,1.195224E+00,1.261326E+00,& + & 4.300420E-01,6.087180E-01,6.697430E-01,8.063640E-01,7.876050E-01,& + & 7.761550E-01,8.982870E-01,8.672430E-01,8.920257E-01,1.014946E+00,& + & 1.118144E+00,1.176273E+00,3.873130E-01,5.554760E-01,6.215910E-01,& + & 7.389270E-01,7.197550E-01,7.102930E-01,8.242360E-01,7.994030E-01,& + & 8.286737E-01,9.491525E-01,1.046077E+00,1.097071E+00,3.488300E-01,& + & 5.068900E-01,5.769000E-01,6.771300E-01,6.577500E-01,6.500200E-01,& + & 7.562900E-01,7.368700E-01,7.698427E-01,8.876617E-01,9.786811E-01,& + & 1.023300E+00,3.141700E-01,4.625540E-01,5.354230E-01,6.205010E-01,& + & 6.010870E-01,5.948610E-01,6.939450E-01,6.792290E-01,7.152073E-01,& + & 8.301906E-01,9.156608E-01,9.545887E-01,2.829540E-01,4.220960E-01,& + & 4.969270E-01,5.686080E-01,5.493050E-01,5.443840E-01,6.367390E-01,& + & 6.260960E-01,6.644681E-01,7.764753E-01,8.567281E-01,8.905786E-01/ + + + data forref(:, :) / & + & 2.854900E-03,4.828100E-03,6.257000E-03,8.273100E-03,7.905600E-03,& + & 7.784000E-03,1.011500E-02,9.659900E-03,1.022842E-02,1.288835E-02,& + & 1.489441E-02,1.597860E-02,3.003600E-03,5.109300E-03,5.731700E-03,& + & 9.224600E-03,8.982900E-03,8.647700E-03,1.144800E-02,1.039100E-02,& + & 1.047711E-02,1.259355E-02,1.506581E-02,1.664673E-02,3.077100E-03,& + & 5.120600E-03,5.842600E-03,9.572700E-03,1.033800E-02,9.373700E-03,& + & 1.280500E-02,1.127200E-02,1.140053E-02,1.219900E-02,1.458269E-02,& + & 1.684562E-02,3.307200E-03,5.024000E-03,6.847400E-03,8.273600E-03,& + & 8.615100E-03,8.676200E-03,1.147600E-02,1.024600E-02,1.080142E-02,& + & 1.053970E-02,1.035826E-02,1.047106E-02 / + + + data fracrefa(:) / 1.638800e-01,1.524100e-01,& + & 1.429000e-01,1.286400e-01,1.161500e-01,1.004700e-01,8.001300e-02,& + & 6.044500e-02,4.491790e-02,6.339500e-03,3.294200e-03,5.454090e-04/ + + + data fracrefb(:) / 1.469700e-01,1.482600e-01,& + & 1.427800e-01,1.332000e-01,1.196500e-01,1.029700e-01,8.417000e-02,& + & 6.328200e-02,4.753240e-02,6.915200e-03,3.658500e-03,6.127360e-04/ + + +!........................................! + end module module_radlw_kgb02 ! +!========================================! + + +!> This module sets up absorption coefficients for band 03: 500-630 +!! cm-1 (low - h2o, co2; high - h2o, co2) +!========================================! + module module_radlw_kgb03 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG03 +! + implicit none +! + private +! +!> msa03=585 + integer, public :: MSA03 +!> msb03=1175 + integer, public :: MSB03 +!> msf03=10 + integer, public :: MSF03 +!> mfr03=4 + integer, public :: MFR03 +!> maf03=9 + integer, public :: MAF03 +!> mbf03=5 + integer, public :: MBF03 +!> mmn03=19 + integer, public :: MMN03 + + parameter (MSA03=585, MSB03=1175, MSF03=10, MFR03=4) + parameter (MAF03=9, MBF03=5, MMN03=19) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG03=16). + real (kind=kind_phys), public :: forref(NG03,MFR03) + +!> the array absa(NG03,585) = ka(NG03,9,5,13) contains absorption coefs +!! at the NG03=16 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different water +!! vapor to co2 ratios, as expressed through the binary species +!! parameter eta, defined as eta = gas1/(gas1+(rat)*gas2), where rat is +!! the ratio of the reference mls column amount value of gas1 to that +!! of gas2. the 2nd index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 1-5 +!! means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! third index, jp, runs from 1 to 13 and refers to the reference +!! pressure level (e.g. jp = 1 is for a pressure of 1053.63 mb). the +!! fourth index, ig, goes from 1 to NG03=16, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG03,MSA03) + +!> the array absb(NG03,1175) = kb(NG03,5,5,13:59) contains absorption +!! coefs at the NG03=16 g-intervals for a range of pressure levels < +!! ~100mb, temperatures, and ratios of h2o to co2. the first index in +!! the array, js, runs from 1 to 5, and corresponds to different gas +!! amount ratios, as expressed through the binary species parameter +!! eta, defined as eta = gas1/(gas1+rat*gas2), where rat is the ratio +!! of the reference mls column amount value of gas1 to that of gas2. +!! the second index, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that +!! the data are for the corresponding temperature of tref-30, tref-15, +!! tref, tref+15, and tref+30, respectively. the third index, jp, +!! runs from 13 to 59 and refers to the reference pressure level (e.g. +!! jp = 13 is for a pressure of 95.5835 mb). the fourth index, ig, +!! goes from 1 to NG03=16, and tells us which g-interval the absorption +!! coefficients are for. + real (kind=kind_phys), public :: absb(NG03,MSB03) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG03=16). + real (kind=kind_phys), public :: selfref(NG03,MSF03) + +!> planck fraction mapping level: p=212.7250 mbar, t = 223.06 k + real (kind=kind_phys), public :: fracrefa(NG03,MAF03) + +!> planck fraction mapping level: p = 95.8 mbar, t = 215.7 k + real (kind=kind_phys), public :: fracrefb(NG03,MBF03) + +!> the array ka_mxxx(NG03,9,19) contains the absorption coefficient for +!! a minor species at the NG03=16 chosen g-values for a reference pressure +!! level below 100~ mb. the first index in the array, js, runs from 1 +!! to 9, and corresponds to different gas column amount ratios, as +!! expressed through the binary species parameter eta, defined as +!! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +!! reference mls column amount value of gas1 to that of gas2. the +!! second index refers to temperature in 7.2 degree increments. for +!! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers to +!! 195.2, etc. the third index runs over the g-channel (1 to NG03=16). + real (kind=kind_phys), public :: ka_mn2o(NG03,MAF03,MMN03) + +!> the array kb_mxxx contains the absorption coefficient for a minor +!! species at the NG03=16 chosen g-values for a reference pressure +!! level above 100~ mb. the first index in the array, js, runs from +!! 1 to 10, and corresponds to different gas column amounts ratios, +!! as expressed through the binary species parameter eta, defined as +!! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +!! reference mls column amount value of gas1 to that of gas2. the +!! second index refers to temperature in 7.2 degree increments. for +!! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers +!! to 195.2, etc. the third index runs over the g-channel (1 to NG03=16). + real (kind=kind_phys), public :: kb_mn2o(NG03,MBF03,MMN03) + + data absa(:, 1: 20) / & + & 3.188600E-07,1.307300E-06,5.254600E-06,2.019700E-05,1.503300E-04,& + & 5.871000E-04,1.384800E-03,3.569600E-03,7.943300E-03,1.387900E-02,& + & 2.099100E-02,4.432700E-02,8.918900E-02,1.447300E-01,1.699300E-01,& + & 1.725400E-01,1.896900E-04,4.205900E-04,7.118900E-04,1.166700E-03,& + & 2.044600E-03,3.744700E-03,7.426500E-03,1.600700E-02,4.969600E-02,& + & 1.098600E-01,1.451000E-01,1.990100E-01,2.754700E-01,4.519600E-01,& + & 6.231900E-01,6.646200E-01,4.123900E-04,6.756100E-04,1.088200E-03,& + & 1.870300E-03,3.168100E-03,5.659800E-03,1.132800E-02,2.911900E-02,& + & 8.939900E-02,1.919200E-01,2.753000E-01,3.956700E-01,5.475500E-01,& + & 8.969800E-01,1.230200E+00,1.311500E+00,6.466700E-04,8.660900E-04,& + & 1.540700E-03,2.359700E-03,4.092800E-03,7.421500E-03,1.576500E-02,& + & 4.211000E-02,1.289100E-01,2.870000E-01,4.125300E-01,5.884800E-01,& + & 8.146600E-01,1.331600E+00,1.811700E+00,1.931800E+00,8.529200E-04,& + & 1.352000E-03,1.669400E-03,2.844200E-03,4.964500E-03,9.230800E-03,& + & 2.061700E-02,5.486000E-02,1.703100E-01,3.812900E-01,5.488800E-01,& + & 7.747600E-01,1.073400E+00,1.748300E+00,2.353400E+00,2.508400E+00,& + & 1.183600E-03,1.608500E-03,2.048400E-03,3.300400E-03,5.875200E-03,& + & 1.130200E-02,2.576000E-02,6.807600E-02,2.132700E-01,4.752700E-01,& + & 6.831700E-01,9.485300E-01,1.316700E+00,2.132900E+00,2.822400E+00,& + & 3.007600E+00,1.400600E-03,2.090800E-03,2.852300E-03,3.920900E-03,& + & 6.889100E-03,1.374500E-02,3.139400E-02,8.391700E-02,2.563500E-01,& + & 5.706700E-01,8.104000E-01,1.093400E+00,1.526200E+00,2.449200E+00,& + & 3.142700E+00,3.344900E+00,1.541100E-03,3.526200E-03,4.169600E-03,& + & 5.105000E-03,9.746000E-03,1.713000E-02,3.917400E-02,1.055800E-01,& + & 2.983400E-01,6.677900E-01,9.020400E-01,1.152700E+00,1.654500E+00,& + & 2.536600E+00,3.068300E+00,3.252300E+00,8.329300E-04,1.784600E-03,& + & 2.506700E-03,4.403200E-03,8.237500E-03,1.637600E-02,3.796200E-02,& + & 1.053400E-01,3.400500E-01,7.624300E-01,1.097700E+00,1.549500E+00,& + & 2.146700E+00,3.496700E+00,4.706700E+00,5.016900E+00,4.320800E-07,& + & 1.819700E-06,7.709200E-06,2.987800E-05,2.038900E-04,7.109500E-04,& + & 1.667100E-03,4.286300E-03,9.577300E-03,1.695400E-02,2.637700E-02,& + & 5.390500E-02,1.056400E-01,1.684600E-01,1.965200E-01,1.994500E-01,& + & 2.228600E-04,5.076800E-04,8.764900E-04,1.428300E-03,2.496600E-03,& + & 4.529500E-03,8.994500E-03,1.972200E-02,6.061000E-02,1.330300E-01,& + & 1.742000E-01,2.474000E-01,3.344800E-01,5.555400E-01,7.835500E-01,& + & 8.168800E-01,4.462700E-04,8.411000E-04,1.342600E-03,2.293400E-03,& + & 3.846500E-03,6.895600E-03,1.380300E-02,3.579100E-02,1.088200E-01,& + & 2.356400E-01,3.353400E-01,4.924200E-01,6.633300E-01,1.103900E+00,& + & 1.546300E+00,1.611800E+00,7.233000E-04,1.023800E-03,1.836000E-03,& + & 2.962100E-03,4.992900E-03,9.132900E-03,1.921100E-02,5.166000E-02,& + & 1.573000E-01,3.520000E-01,5.028400E-01,7.336700E-01,9.835400E-01,& + & 1.641700E+00,2.277500E+00,2.374100E+00,9.369400E-04,1.376500E-03,& + & 2.234500E-03,3.476300E-03,6.124500E-03,1.144100E-02,2.513000E-02,& + & 6.717000E-02,2.082700E-01,4.670200E-01,6.697800E-01,9.682300E-01,& + & 1.289700E+00,2.161100E+00,2.957200E+00,3.083600E+00,1.233700E-03,& + & 1.923900E-03,2.301800E-03,4.166500E-03,7.294000E-03,1.406900E-02,& + & 3.143400E-02,8.349300E-02,2.608900E-01,5.805400E-01,8.350800E-01,& + & 1.189200E+00,1.571900E+00,2.645600E+00,3.545000E+00,3.696600E+00,& + & 1.548200E-03,2.299700E-03,2.950000E-03,4.894800E-03,8.777600E-03,& + & 1.726000E-02,3.854100E-02,1.031400E-01,3.137400E-01,6.952300E-01,& + & 9.936200E-01,1.376700E+00,1.809700E+00,3.046300E+00,3.941900E+00,& + & 4.111600E+00,1.777300E-03,3.575600E-03,4.824700E-03,5.862000E-03,& + & 1.149900E-02,2.198400E-02,4.924400E-02,1.298000E-01,3.655900E-01,& + & 8.137200E-01,1.115200E+00,1.453400E+00,1.947400E+00,3.169500E+00,& + & 3.832000E+00,3.998000E+00,1.003800E-03,2.076700E-03,2.867800E-03,& + & 5.466100E-03,1.018200E-02,2.015900E-02,4.632500E-02,1.293600E-01,& + & 4.158400E-01,9.336700E-01,1.339500E+00,1.936400E+00,2.579400E+00,& + & 4.322200E+00,5.914400E+00,6.167300E+00,5.883400E-07,2.508400E-06,& + & 1.109600E-05,4.286700E-05,2.676900E-04,8.482400E-04,1.971400E-03,& + & 5.056700E-03,1.135500E-02,2.036900E-02,3.230100E-02,6.406900E-02,& + & 1.223200E-01,1.917400E-01,2.220000E-01,2.251000E-01,2.614300E-04,& + & 6.129000E-04,1.056900E-03,1.715200E-03,3.007900E-03,5.399400E-03,& + & 1.073800E-02,2.393900E-02,7.272300E-02,1.590600E-01,2.047000E-01,& + & 2.976200E-01,4.025100E-01,6.674900E-01,9.561700E-01,1.007000E+00/ + data absa(:, 21: 40) / & + & 5.044100E-04,1.020200E-03,1.613300E-03,2.774200E-03,4.607600E-03,& + & 8.256700E-03,1.662100E-02,4.334100E-02,1.304800E-01,2.852300E-01,& + & 4.001400E-01,5.926700E-01,7.974500E-01,1.327600E+00,1.887200E+00,& + & 1.984100E+00,7.742400E-04,1.269300E-03,2.214500E-03,3.574400E-03,& + & 5.993800E-03,1.101000E-02,2.315300E-02,6.243700E-02,1.891700E-01,& + & 4.264000E-01,5.993600E-01,8.839600E-01,1.180900E+00,1.975600E+00,& + & 2.780600E+00,2.915900E+00,1.040300E-03,1.551600E-03,2.739600E-03,& + & 4.236100E-03,7.370300E-03,1.390900E-02,3.024200E-02,8.102800E-02,& + & 2.509600E-01,5.662700E-01,7.973000E-01,1.168000E+00,1.546300E+00,& + & 2.602700E+00,3.611400E+00,3.774800E+00,1.333100E-03,2.007800E-03,& + & 3.015900E-03,5.027200E-03,8.825000E-03,1.720400E-02,3.782700E-02,& + & 1.009400E-01,3.143500E-01,7.040500E-01,9.929400E-01,1.437900E+00,& + & 1.879800E+00,3.188600E+00,4.331500E+00,4.503700E+00,1.790800E-03,& + & 2.546100E-03,3.217900E-03,5.964200E-03,1.091600E-02,2.109100E-02,& + & 4.647000E-02,1.248500E-01,3.782800E-01,8.374800E-01,1.184000E+00,& + & 1.673400E+00,2.151200E+00,3.678900E+00,4.821200E+00,4.968900E+00,& + & 2.084500E-03,3.492200E-03,5.111300E-03,7.937800E-03,1.346800E-02,& + & 2.713200E-02,6.028600E-02,1.569700E-01,4.421100E-01,9.660400E-01,& + & 1.337100E+00,1.785300E+00,2.285300E+00,3.843300E+00,4.682800E+00,& + & 4.788300E+00,1.161900E-03,2.266800E-03,3.602400E-03,6.604400E-03,& + & 1.226800E-02,2.452400E-02,5.580600E-02,1.565700E-01,5.010700E-01,& + & 1.132100E+00,1.594300E+00,2.335900E+00,3.092500E+00,5.205500E+00,& + & 7.222800E+00,7.549500E+00,7.992600E-07,3.422400E-06,1.573600E-05,& + & 5.986900E-05,3.402400E-04,9.996200E-04,2.302800E-03,5.886500E-03,& + & 1.327700E-02,2.406100E-02,3.861000E-02,7.459900E-02,1.390600E-01,& + & 2.149000E-01,2.472000E-01,2.504800E-01,3.053200E-04,7.339200E-04,& + & 1.260100E-03,2.033500E-03,3.583100E-03,6.367500E-03,1.268300E-02,& + & 2.869900E-02,8.620400E-02,1.874200E-01,2.399000E-01,3.490800E-01,& + & 4.815100E-01,7.847600E-01,1.141100E+00,1.225200E+00,5.765500E-04,& + & 1.210400E-03,1.938000E-03,3.282700E-03,5.475100E-03,9.792900E-03,& + & 1.978800E-02,5.184000E-02,1.548300E-01,3.406500E-01,4.744500E-01,& + & 6.954800E-01,9.537000E-01,1.560900E+00,2.252800E+00,2.414000E+00,& + & 8.466700E-04,1.545500E-03,2.651000E-03,4.244200E-03,7.112400E-03,& + & 1.311600E-02,2.763400E-02,7.454800E-02,2.252000E-01,5.098700E-01,& + & 7.093900E-01,1.037800E+00,1.411700E+00,2.323300E+00,3.319300E+00,& + & 3.547900E+00,1.118900E-03,1.886600E-03,3.242400E-03,5.104600E-03,& + & 8.742300E-03,1.666400E-02,3.604200E-02,9.666900E-02,2.993300E-01,& + & 6.781000E-01,9.418600E-01,1.372500E+00,1.847700E+00,3.063900E+00,& + & 4.311600E+00,4.592800E+00,1.484900E-03,2.196600E-03,3.789300E-03,& + & 5.917900E-03,1.060000E-02,2.067000E-02,4.506300E-02,1.206600E-01,& + & 3.748000E-01,8.449200E-01,1.168700E+00,1.692100E+00,2.244000E+00,& + & 3.756300E+00,5.171300E+00,5.480600E+00,1.779300E-03,2.962400E-03,& + & 3.999200E-03,7.140100E-03,1.298500E-02,2.552000E-02,5.540000E-02,& + & 1.494700E-01,4.511700E-01,1.007800E+00,1.384200E+00,1.973400E+00,& + & 2.562700E+00,4.339600E+00,5.755200E+00,6.047100E+00,2.339200E-03,& + & 3.870800E-03,5.079400E-03,9.660100E-03,1.675700E-02,3.300900E-02,& + & 7.232900E-02,1.879400E-01,5.286500E-01,1.140300E+00,1.565700E+00,& + & 2.119200E+00,2.705400E+00,4.549300E+00,5.595900E+00,5.783100E+00,& + & 1.275800E-03,2.590900E-03,4.445500E-03,7.849000E-03,1.465200E-02,& + & 2.950400E-02,6.655100E-02,1.874800E-01,5.976200E-01,1.355800E+00,& + & 1.883200E+00,2.744900E+00,3.695300E+00,6.127900E+00,8.623100E+00,& + & 9.185600E+00,1.072600E-06,4.599000E-06,2.176800E-05,8.151700E-05,& + & 4.202000E-04,1.167700E-03,2.659700E-03,6.769500E-03,1.532600E-02,& + & 2.791100E-02,4.528500E-02,8.527400E-02,1.553700E-01,2.369100E-01,& + & 2.706700E-01,2.741300E-01,3.555900E-04,8.703000E-04,1.488100E-03,& + & 2.383400E-03,4.218000E-03,7.444900E-03,1.483900E-02,3.403100E-02,& + & 1.011600E-01,2.168000E-01,2.804400E-01,4.039400E-01,5.689100E-01,& + & 9.076500E-01,1.336800E+00,1.458500E+00,6.647200E-04,1.425300E-03,& + & 2.301300E-03,3.844000E-03,6.429400E-03,1.151700E-02,2.334100E-02,& + & 6.135800E-02,1.818800E-01,4.034700E-01,5.586600E-01,8.040400E-01,& + & 1.128200E+00,1.804200E+00,2.639200E+00,2.873500E+00,9.558600E-04,& + & 1.839500E-03,3.127200E-03,4.995900E-03,8.345300E-03,1.547600E-02,& + & 3.268000E-02,8.809600E-02,2.655900E-01,6.036500E-01,8.345400E-01,& + & 1.198300E+00,1.672300E+00,2.683400E+00,3.888500E+00,4.223300E+00/ + data absa(:, 41: 60) / & + & 1.228700E-03,2.253700E-03,3.850500E-03,6.021400E-03,1.024800E-02,& + & 1.974000E-02,4.260000E-02,1.142000E-01,3.538000E-01,8.016300E-01,& + & 1.107400E+00,1.583000E+00,2.191800E+00,3.534800E+00,5.053100E+00,& + & 5.467800E+00,1.562900E-03,2.631400E-03,4.493400E-03,7.069200E-03,& + & 1.244900E-02,2.453000E-02,5.321100E-02,1.428900E-01,4.432700E-01,& + & 9.966300E-01,1.374200E+00,1.947700E+00,2.665400E+00,4.336200E+00,& + & 6.061700E+00,6.491300E+00,1.968400E-03,3.077900E-03,5.133600E-03,& + & 8.426500E-03,1.535000E-02,3.034900E-02,6.542900E-02,1.772000E-01,& + & 5.340200E-01,1.184200E+00,1.624300E+00,2.266200E+00,3.048000E+00,& + & 5.016000E+00,6.749000E+00,7.199600E+00,2.652100E-03,4.244200E-03,& + & 5.879600E-03,1.144300E-02,1.995500E-02,3.938500E-02,8.581600E-02,& + & 2.223700E-01,6.266400E-01,1.343000E+00,1.808700E+00,2.452100E+00,& + & 3.198900E+00,5.277400E+00,6.568100E+00,6.883500E+00,1.478100E-03,& + & 2.966300E-03,5.364200E-03,9.288800E-03,1.721400E-02,3.502800E-02,& + & 7.875100E-02,2.224000E-01,7.064000E-01,1.602800E+00,2.214100E+00,& + & 3.165900E+00,4.383400E+00,7.069600E+00,1.010600E+01,1.093600E+01,& + & 3.730100E-07,1.517800E-06,6.418900E-06,2.536600E-05,1.839900E-04,& + & 7.315100E-04,1.736500E-03,4.711800E-03,1.177600E-02,2.215800E-02,& + & 3.033400E-02,6.166500E-02,1.265100E-01,2.129600E-01,2.549500E-01,& + & 2.594900E-01,1.510100E-04,3.426900E-04,6.443600E-04,1.067100E-03,& + & 1.841900E-03,3.644800E-03,7.510400E-03,1.587700E-02,4.787800E-02,& + & 1.127600E-01,1.580600E-01,2.107700E-01,2.751100E-01,4.621500E-01,& + & 6.771400E-01,7.407300E-01,3.061300E-04,6.074800E-04,9.438900E-04,& + & 1.613100E-03,2.849800E-03,5.201600E-03,1.085500E-02,2.539900E-02,& + & 8.497200E-02,1.889100E-01,2.539100E-01,3.835500E-01,5.481100E-01,& + & 9.198400E-01,1.342900E+00,1.468500E+00,5.244400E-04,7.198600E-04,& + & 1.223900E-03,2.112300E-03,3.582200E-03,6.642100E-03,1.364900E-02,& + & 3.591800E-02,1.187800E-01,2.751800E-01,3.805600E-01,5.733900E-01,& + & 8.179200E-01,1.370600E+00,1.991100E+00,2.176400E+00,6.678500E-04,& + & 9.367400E-04,1.586200E-03,2.368500E-03,4.244200E-03,7.940000E-03,& + & 1.679400E-02,4.645700E-02,1.536600E-01,3.652400E-01,5.069500E-01,& + & 7.605500E-01,1.082200E+00,1.809100E+00,2.610200E+00,2.850900E+00,& + & 9.034700E-04,1.312100E-03,1.594300E-03,2.718500E-03,4.881400E-03,& + & 9.101800E-03,2.048700E-02,5.693900E-02,1.906100E-01,4.531700E-01,& + & 6.331800E-01,9.423600E-01,1.336900E+00,2.224500E+00,3.174100E+00,& + & 3.463900E+00,1.104700E-03,1.610200E-03,2.176100E-03,3.041800E-03,& + & 5.314100E-03,1.051600E-02,2.462200E-02,6.806800E-02,2.303300E-01,& + & 5.365200E-01,7.590800E-01,1.109100E+00,1.570200E+00,2.586000E+00,& + & 3.617600E+00,3.940500E+00,1.271700E-03,2.406900E-03,2.976800E-03,& + & 3.487900E-03,6.958200E-03,1.254900E-02,2.978500E-02,8.453600E-02,& + & 2.721100E-01,6.129600E-01,8.781300E-01,1.216800E+00,1.738800E+00,& + & 2.773000E+00,3.698900E+00,4.009700E+00,6.092000E-04,1.324700E-03,& + & 1.831900E-03,3.314300E-03,6.189000E-03,1.251400E-02,2.929600E-02,& + & 8.555500E-02,3.031400E-01,7.302000E-01,1.013800E+00,1.521000E+00,& + & 2.164300E+00,3.618200E+00,5.220400E+00,5.701700E+00,5.046400E-07,& + & 2.129900E-06,9.513900E-06,3.767100E-05,2.529200E-04,8.899000E-04,& + & 2.119100E-03,5.710800E-03,1.429400E-02,2.725600E-02,3.822400E-02,& + & 7.623400E-02,1.515300E-01,2.501600E-01,2.971300E-01,3.022000E-01,& + & 1.790000E-04,4.252400E-04,7.986300E-04,1.308800E-03,2.277100E-03,& + & 4.421600E-03,9.184100E-03,1.957100E-02,5.895600E-02,1.380800E-01,& + & 1.923400E-01,2.563900E-01,3.438400E-01,5.643200E-01,8.613900E-01,& + & 9.212800E-01,3.460600E-04,7.370300E-04,1.174800E-03,2.001400E-03,& + & 3.495800E-03,6.365900E-03,1.324600E-02,3.148700E-02,1.041600E-01,& + & 2.310000E-01,3.117300E-01,4.782600E-01,6.841700E-01,1.123700E+00,& + & 1.708500E+00,1.817200E+00,5.411200E-04,9.377600E-04,1.510400E-03,& + & 2.610600E-03,4.393800E-03,8.166300E-03,1.672200E-02,4.443300E-02,& + & 1.455900E-01,3.405100E-01,4.670600E-01,7.153200E-01,1.019700E+00,& + & 1.675600E+00,2.532600E+00,2.693100E+00,7.770600E-04,1.039800E-03,& + & 1.909400E-03,3.031200E-03,5.228300E-03,9.830200E-03,2.061300E-02,& + & 5.736600E-02,1.887100E-01,4.518000E-01,6.220900E-01,9.500700E-01,& + & 1.346600E+00,2.215100E+00,3.319100E+00,3.546000E+00,9.310800E-04,& + & 1.436700E-03,2.087600E-03,3.387300E-03,6.033000E-03,1.139200E-02,& + & 2.516400E-02,7.015400E-02,2.345700E-01,5.601500E-01,7.770700E-01,& + & 1.179300E+00,1.657400E+00,2.729400E+00,4.035800E+00,4.308000E+00/ + data absa(:, 61: 80) / & + & 1.290900E-03,1.735300E-03,2.217200E-03,3.901700E-03,6.835300E-03,& + & 1.332100E-02,3.031900E-02,8.405200E-02,2.835800E-01,6.616000E-01,& + & 9.333400E-01,1.394100E+00,1.931800E+00,3.186400E+00,4.597700E+00,& + & 4.900700E+00,1.467100E-03,2.406100E-03,3.369000E-03,4.521500E-03,& + & 8.023000E-03,1.628300E-02,3.731000E-02,1.047200E-01,3.354900E-01,& + & 7.497300E-01,1.085700E+00,1.545200E+00,2.093300E+00,3.460600E+00,& + & 4.690400E+00,4.987600E+00,7.363700E-04,1.524300E-03,2.207900E-03,& + & 4.114300E-03,7.697600E-03,1.546900E-02,3.600200E-02,1.057000E-01,& + & 3.729000E-01,9.031400E-01,1.243800E+00,1.900100E+00,2.693000E+00,& + & 4.430100E+00,6.638200E+00,7.091800E+00,6.910900E-07,2.961200E-06,& + & 1.392000E-05,5.454100E-05,3.354000E-04,1.071400E-03,2.533300E-03,& + & 6.786600E-03,1.706600E-02,3.274200E-02,4.704200E-02,9.189200E-02,& + & 1.771600E-01,2.869200E-01,3.379100E-01,3.434100E-01,2.121000E-04,& + & 5.175300E-04,9.773800E-04,1.579500E-03,2.771100E-03,5.288300E-03,& + & 1.103000E-02,2.374300E-02,7.134500E-02,1.664500E-01,2.279300E-01,& + & 3.037600E-01,4.232300E-01,6.737500E-01,1.063200E+00,1.129100E+00,& + & 4.030800E-04,8.862600E-04,1.433700E-03,2.430600E-03,4.225700E-03,& + & 7.656400E-03,1.592100E-02,3.840300E-02,1.256500E-01,2.757500E-01,& + & 3.777500E-01,5.776100E-01,8.416000E-01,1.342500E+00,2.108900E+00,& + & 2.236000E+00,5.967000E-04,1.150000E-03,1.842200E-03,3.172600E-03,& + & 5.310900E-03,9.845700E-03,2.020600E-02,5.406900E-02,1.758900E-01,& + & 4.100700E-01,5.657300E-01,8.644500E-01,1.253000E+00,2.003300E+00,& + & 3.127300E+00,3.308800E+00,8.357200E-04,1.289600E-03,2.290400E-03,& + & 3.713700E-03,6.335200E-03,1.190900E-02,2.496600E-02,6.965700E-02,& + & 2.285700E-01,5.442700E-01,7.527500E-01,1.148800E+00,1.652500E+00,& + & 2.651200E+00,4.099600E+00,4.325200E+00,1.053900E-03,1.526300E-03,& + & 2.666400E-03,4.120800E-03,7.345000E-03,1.394000E-02,3.043200E-02,& + & 8.499700E-02,2.847100E-01,6.755500E-01,9.385600E-01,1.428100E+00,& + & 2.028500E+00,3.274300E+00,4.986200E+00,5.238300E+00,1.289500E-03,& + & 2.087600E-03,2.665500E-03,4.773700E-03,8.356700E-03,1.640500E-02,& + & 3.670100E-02,1.021100E-01,3.440200E-01,8.005000E-01,1.122700E+00,& + & 1.692300E+00,2.352300E+00,3.838400E+00,5.682300E+00,5.936000E+00,& + & 1.628100E-03,2.638900E-03,3.332200E-03,5.737600E-03,1.014200E-02,& + & 2.016600E-02,4.555900E-02,1.276200E-01,4.065800E-01,9.101900E-01,& + & 1.303400E+00,1.891700E+00,2.505200E+00,4.214500E+00,5.794800E+00,& + & 6.031800E+00,8.391700E-04,1.696600E-03,2.797300E-03,4.990100E-03,& + & 9.371600E-03,1.884700E-02,4.360300E-02,1.283800E-01,4.527200E-01,& + & 1.087900E+00,1.504900E+00,2.297500E+00,3.304900E+00,5.302300E+00,& + & 8.199000E+00,8.650200E+00,9.444900E-07,4.089700E-06,1.981500E-05,& + & 7.705600E-05,4.292800E-04,1.278200E-03,2.982800E-03,7.943600E-03,& + & 2.008900E-02,3.859300E-02,5.679000E-02,1.083700E-01,2.030400E-01,& + & 3.232700E-01,3.775100E-01,3.832500E-01,2.497300E-04,6.259600E-04,& + & 1.174500E-03,1.885700E-03,3.326700E-03,6.263700E-03,1.305100E-02,& + & 2.846000E-02,8.520100E-02,1.980700E-01,2.666300E-01,3.527300E-01,& + & 5.091400E-01,7.964500E-01,1.277800E+00,1.387400E+00,4.686200E-04,& + & 1.059700E-03,1.725500E-03,2.900900E-03,5.059500E-03,9.099500E-03,& + & 1.893200E-02,4.623100E-02,1.497200E-01,3.247500E-01,4.551500E-01,& + & 6.810600E-01,1.012800E+00,1.586600E+00,2.534700E+00,2.748100E+00,& + & 6.766200E-04,1.384300E-03,2.215000E-03,3.783600E-03,6.359700E-03,& + & 1.173800E-02,2.414500E-02,6.499000E-02,2.102200E-01,4.855200E-01,& + & 6.810100E-01,1.019200E+00,1.508300E+00,2.366900E+00,3.759100E+00,& + & 4.066600E+00,9.029400E-04,1.585000E-03,2.763800E-03,4.436400E-03,& + & 7.571900E-03,1.424200E-02,2.991500E-02,8.359800E-02,2.738400E-01,& + & 6.453100E-01,9.048900E-01,1.354800E+00,1.989400E+00,3.132300E+00,& + & 4.927700E+00,5.315900E+00,1.138800E-03,1.809800E-03,3.195000E-03,& + & 5.023500E-03,8.775300E-03,1.676100E-02,3.645400E-02,1.018200E-01,& + & 3.417000E-01,8.034100E-01,1.124400E+00,1.685800E+00,2.442500E+00,& + & 3.867900E+00,5.994400E+00,6.436700E+00,1.423000E-03,2.126800E-03,& + & 3.514400E-03,5.642700E-03,1.013700E-02,1.987100E-02,4.391900E-02,& + & 1.226000E-01,4.127200E-01,9.578600E-01,1.336300E+00,2.001200E+00,& + & 2.827300E+00,4.542500E+00,6.834500E+00,7.279000E+00,1.878000E-03,& + & 2.865600E-03,3.660100E-03,6.936500E-03,1.248700E-02,2.460400E-02,& + & 5.467400E-02,1.535600E-01,4.870400E-01,1.099400E+00,1.535200E+00,& + & 2.248800E+00,2.994700E+00,5.010000E+00,6.983000E+00,7.305900E+00/ + data absa(:, 81:100) / & + & 9.523600E-04,1.958400E-03,3.429100E-03,5.984800E-03,1.122600E-02,& + & 2.275300E-02,5.223300E-02,1.544000E-01,5.435000E-01,1.289800E+00,& + & 1.809000E+00,2.709400E+00,3.978500E+00,6.264500E+00,9.855400E+00,& + & 1.063200E+01,1.278500E-06,5.568700E-06,2.756700E-05,1.056600E-04,& + & 5.332600E-04,1.510100E-03,3.470900E-03,9.187300E-03,2.330700E-02,& + & 4.471300E-02,6.719800E-02,1.252300E-01,2.285600E-01,3.585100E-01,& + & 4.154400E-01,4.215300E-01,2.928300E-04,7.455500E-04,1.393700E-03,& + & 2.234400E-03,3.939700E-03,7.349100E-03,1.529100E-02,3.372200E-02,& + & 1.005900E-01,2.313900E-01,3.090900E-01,4.052600E-01,5.970800E-01,& + & 9.351800E-01,1.505400E+00,1.666000E+00,5.440700E-04,1.260000E-03,& + & 2.055300E-03,3.413700E-03,5.980700E-03,1.072800E-02,2.227900E-02,& + & 5.499900E-02,1.760200E-01,3.840100E-01,5.385500E-01,7.973500E-01,& + & 1.188200E+00,1.862100E+00,2.985500E+00,3.299200E+00,7.752200E-04,& + & 1.634700E-03,2.651300E-03,4.455200E-03,7.517400E-03,1.386500E-02,& + & 2.857300E-02,7.719400E-02,2.483400E-01,5.743100E-01,8.062000E-01,& + & 1.192100E+00,1.770500E+00,2.777700E+00,4.427800E+00,4.882300E+00,& + & 1.005300E-03,1.907000E-03,3.273600E-03,5.267100E-03,8.938300E-03,& + & 1.685000E-02,3.552000E-02,9.913700E-02,3.244200E-01,7.632900E-01,& + & 1.072000E+00,1.581600E+00,2.337500E+00,3.673000E+00,5.806700E+00,& + & 6.381900E+00,1.225400E-03,2.191400E-03,3.795200E-03,5.985300E-03,& + & 1.036500E-02,1.989200E-02,4.328400E-02,1.206800E-01,4.057000E-01,& + & 9.502600E-01,1.333900E+00,1.962500E+00,2.875300E+00,4.529700E+00,& + & 7.064700E+00,7.729000E+00,1.559200E-03,2.416600E-03,4.283700E-03,& + & 6.724900E-03,1.199200E-02,2.368700E-02,5.212700E-02,1.458400E-01,& + & 4.899800E-01,1.131700E+00,1.587200E+00,2.321300E+00,3.341700E+00,& + & 5.302900E+00,8.055700E+00,8.741000E+00,1.903100E-03,3.300700E-03,& + & 4.492200E-03,8.239700E-03,1.478900E-02,2.958100E-02,6.500800E-02,& + & 1.828500E-01,5.784400E-01,1.300700E+00,1.807500E+00,2.608700E+00,& + & 3.559800E+00,5.828100E+00,8.236400E+00,8.773700E+00,1.116400E-03,& + & 2.266900E-03,4.116000E-03,7.129600E-03,1.325100E-02,2.717100E-02,& + & 6.197900E-02,1.837500E-01,6.452300E-01,1.525600E+00,2.143200E+00,& + & 3.162500E+00,4.674600E+00,7.345800E+00,1.161300E+01,1.276400E+01,& + & 5.592100E-07,2.223400E-06,9.631900E-06,3.955800E-05,2.812600E-04,& + & 1.161400E-03,2.809200E-03,7.928900E-03,2.234800E-02,4.488900E-02,& + & 5.838600E-02,1.112000E-01,2.315500E-01,4.056900E-01,4.960800E-01,& + & 5.064400E-01,1.192400E-04,2.744400E-04,5.978900E-04,1.074200E-03,& + & 1.876500E-03,3.928600E-03,8.431800E-03,1.889800E-02,5.024000E-02,& + & 1.194500E-01,1.753300E-01,2.486800E-01,3.610600E-01,4.734600E-01,& + & 6.898400E-01,7.825500E-01,2.250900E-04,5.008500E-04,9.078900E-04,& + & 1.524800E-03,2.658800E-03,5.299200E-03,1.135200E-02,2.565300E-02,& + & 8.049600E-02,1.991000E-01,2.713400E-01,3.680800E-01,5.152400E-01,& + & 9.013900E-01,1.374600E+00,1.558700E+00,3.431800E-04,6.953400E-04,& + & 1.107700E-03,1.850100E-03,3.348500E-03,6.292000E-03,1.367200E-02,& + & 3.161000E-02,1.107200E-01,2.659200E-01,3.428000E-01,5.184000E-01,& + & 7.707400E-01,1.348300E+00,2.050200E+00,2.323900E+00,5.230800E-04,& + & 7.762900E-04,1.252500E-03,2.183000E-03,3.822100E-03,7.180300E-03,& + & 1.543400E-02,3.834700E-02,1.381400E-01,3.271600E-01,4.532700E-01,& + & 6.901700E-01,1.023700E+00,1.789200E+00,2.712100E+00,3.071600E+00,& + & 6.561600E-04,8.885400E-04,1.512000E-03,2.326100E-03,4.163600E-03,& + & 7.957100E-03,1.683400E-02,4.582200E-02,1.648800E-01,4.082000E-01,& + & 5.655000E-01,8.605600E-01,1.271700E+00,2.220400E+00,3.345500E+00,& + & 3.784800E+00,8.523000E-04,1.191700E-03,1.495900E-03,2.439100E-03,& + & 4.468200E-03,8.545500E-03,1.868000E-02,5.349400E-02,1.940100E-01,& + & 4.883200E-01,6.760600E-01,1.027100E+00,1.507900E+00,2.625200E+00,& + & 3.912200E+00,4.417700E+00,1.006900E-03,1.537300E-03,2.127600E-03,& + & 2.589000E-03,4.484600E-03,9.034900E-03,2.155100E-02,6.217400E-02,& + & 2.288100E-01,5.645000E-01,7.824400E-01,1.175800E+00,1.706700E+00,& + & 2.935800E+00,4.249000E+00,4.774000E+00,4.126800E-04,9.159500E-04,& + & 1.345600E-03,2.382900E-03,4.391900E-03,9.056700E-03,2.143700E-02,& + & 6.478900E-02,2.547000E-01,6.533300E-01,9.064600E-01,1.380200E+00,& + & 2.047400E+00,3.578400E+00,5.424200E+00,6.143100E+00,7.505500E-07,& + & 3.131700E-06,1.453100E-05,5.959400E-05,3.944900E-04,1.452600E-03,& + & 3.452400E-03,9.725000E-03,2.744200E-02,5.609600E-02,7.413600E-02,& + & 1.405300E-01,2.822200E-01,4.835700E-01,5.859100E-01,5.975900E-01/ + data absa(:,101:120) / & + & 1.448300E-04,3.426300E-04,7.564000E-04,1.347600E-03,2.330600E-03,& + & 4.833800E-03,1.043600E-02,2.337800E-02,6.274800E-02,1.484700E-01,& + & 2.191200E-01,3.153600E-01,4.312200E-01,5.758500E-01,8.942200E-01,& + & 9.916900E-01,2.680500E-04,6.225700E-04,1.141200E-03,1.894000E-03,& + & 3.323100E-03,6.507600E-03,1.406000E-02,3.196000E-02,1.000800E-01,& + & 2.484500E-01,3.331100E-01,4.558300E-01,6.611400E-01,1.101600E+00,& + & 1.781200E+00,1.975100E+00,3.934500E-04,8.494100E-04,1.398900E-03,& + & 2.318200E-03,4.165000E-03,7.770400E-03,1.689100E-02,3.965000E-02,& + & 1.370200E-01,3.307100E-01,4.226600E-01,6.544200E-01,9.885400E-01,& + & 1.648200E+00,2.657900E+00,2.945000E+00,5.424500E-04,1.012700E-03,& + & 1.570300E-03,2.748600E-03,4.724100E-03,8.919700E-03,1.907100E-02,& + & 4.815700E-02,1.704700E-01,4.117100E-01,5.620300E-01,8.717300E-01,& + & 1.312000E+00,2.188800E+00,3.515100E+00,3.892600E+00,7.686300E-04,& + & 1.014300E-03,1.794400E-03,3.041000E-03,5.168400E-03,9.962900E-03,& + & 2.084700E-02,5.746300E-02,2.037900E-01,5.141800E-01,7.007500E-01,& + & 1.087900E+00,1.627800E+00,2.718500E+00,4.336000E+00,4.796600E+00,& + & 8.693100E-04,1.336200E-03,1.938600E-03,3.083900E-03,5.588400E-03,& + & 1.079900E-02,2.320600E-02,6.698700E-02,2.401500E-01,6.157800E-01,& + & 8.370700E-01,1.300300E+00,1.924800E+00,3.220500E+00,5.069400E+00,& + & 5.598600E+00,1.126600E-03,1.658300E-03,2.169600E-03,3.328700E-03,& + & 5.916700E-03,1.162500E-02,2.695500E-02,7.790500E-02,2.837100E-01,& + & 7.108100E-01,9.695900E-01,1.494700E+00,2.161600E+00,3.618400E+00,& + & 5.502000E+00,6.049300E+00,5.082900E-04,1.039300E-03,1.710900E-03,& + & 2.966200E-03,5.507400E-03,1.129800E-02,2.656500E-02,8.112500E-02,& + & 3.156300E-01,8.222400E-01,1.123600E+00,1.743300E+00,2.623800E+00,& + & 4.377700E+00,7.030300E+00,7.785200E+00,1.028200E-06,4.408000E-06,& + & 2.145700E-05,8.749500E-05,5.326900E-04,1.772500E-03,4.182700E-03,& + & 1.169000E-02,3.306600E-02,6.870200E-02,9.157300E-02,1.724900E-01,& + & 3.349000E-01,5.618400E-01,6.740900E-01,6.869600E-01,1.741800E-04,& + & 4.242200E-04,9.361000E-04,1.665100E-03,2.850000E-03,5.834300E-03,& + & 1.265300E-02,2.847700E-02,7.671100E-02,1.816100E-01,2.650900E-01,& + & 3.864300E-01,5.092500E-01,6.853900E-01,1.123100E+00,1.218600E+00,& + & 3.182300E-04,7.634700E-04,1.411500E-03,2.310800E-03,4.083500E-03,& + & 7.868000E-03,1.707200E-02,3.905000E-02,1.222900E-01,3.012400E-01,& + & 4.009600E-01,5.483000E-01,8.304900E-01,1.318200E+00,2.237700E+00,& + & 2.426500E+00,4.605200E-04,1.027900E-03,1.727200E-03,2.851500E-03,& + & 5.083400E-03,9.429800E-03,2.047700E-02,4.873500E-02,1.670000E-01,& + & 3.961700E-01,5.173000E-01,7.988500E-01,1.241700E+00,1.972600E+00,& + & 3.337900E+00,3.618600E+00,6.064600E-04,1.238700E-03,1.936900E-03,& + & 3.379800E-03,5.767700E-03,1.086600E-02,2.316000E-02,5.925100E-02,& + & 2.074000E-01,5.008900E-01,6.881200E-01,1.064500E+00,1.647600E+00,& + & 2.620600E+00,4.415300E+00,4.782500E+00,8.069900E-04,1.296700E-03,& + & 2.200300E-03,3.735900E-03,6.323500E-03,1.217900E-02,2.538900E-02,& + & 7.059000E-02,2.484900E-01,6.255400E-01,8.574700E-01,1.329200E+00,& + & 2.043000E+00,3.255500E+00,5.445200E+00,5.863000E+00,9.901000E-04,& + & 1.393200E-03,2.501200E-03,3.832700E-03,6.882900E-03,1.326400E-02,& + & 2.836100E-02,8.211800E-02,2.933900E-01,7.493300E-01,1.023700E+00,& + & 1.590500E+00,2.413300E+00,3.861600E+00,6.366600E+00,6.878600E+00,& + & 1.282200E-03,1.840800E-03,2.316700E-03,4.190500E-03,7.474500E-03,& + & 1.452500E-02,3.301600E-02,9.559600E-02,3.468500E-01,8.666200E-01,& + & 1.182300E+00,1.833800E+00,2.695400E+00,4.359700E+00,6.909700E+00,& + & 7.432800E+00,5.835300E-04,1.215200E-03,2.126500E-03,3.594900E-03,& + & 6.834700E-03,1.384700E-02,3.245100E-02,9.956200E-02,3.860400E-01,& + & 1.000300E+00,1.375300E+00,2.128800E+00,3.294900E+00,5.241100E+00,& + & 8.830700E+00,9.564900E+00,1.416500E-06,6.167000E-06,3.111200E-05,& + & 1.245000E-04,6.930400E-04,2.136800E-03,4.995800E-03,1.381900E-02,& + & 3.926900E-02,8.194900E-02,1.111500E-01,2.067600E-01,3.889800E-01,& + & 6.393700E-01,7.592600E-01,7.729100E-01,2.077600E-04,5.213000E-04,& + & 1.138800E-03,2.029300E-03,3.441800E-03,6.957600E-03,1.510300E-02,& + & 3.423000E-02,9.236600E-02,2.181300E-01,3.141000E-01,4.578000E-01,& + & 5.995100E-01,8.007400E-01,1.368800E+00,1.504400E+00,3.764000E-04,& + & 9.242500E-04,1.720000E-03,2.784900E-03,4.946500E-03,9.396700E-03,& + & 2.038000E-02,4.705300E-02,1.474900E-01,3.578800E-01,4.762600E-01,& + & 6.454900E-01,1.013200E+00,1.565900E+00,2.727100E+00,2.994200E+00/ + data absa(:,121:140) / & + & 5.389600E-04,1.241200E-03,2.090100E-03,3.450200E-03,6.126300E-03,& + & 1.129800E-02,2.451200E-02,5.893600E-02,2.010300E-01,4.667500E-01,& + & 6.244700E-01,9.543700E-01,1.515100E+00,2.342000E+00,4.069200E+00,& + & 4.462200E+00,6.973600E-04,1.484900E-03,2.359000E-03,4.076000E-03,& + & 6.966800E-03,1.303800E-02,2.779000E-02,7.176100E-02,2.492400E-01,& + & 6.011200E-01,8.311800E-01,1.271000E+00,2.011400E+00,3.110100E+00,& + & 5.381400E+00,5.891800E+00,8.710800E-04,1.602200E-03,2.686400E-03,& + & 4.500200E-03,7.636600E-03,1.463300E-02,3.062100E-02,8.539100E-02,& + & 2.994400E-01,7.498200E-01,1.036500E+00,1.586400E+00,2.496400E+00,& + & 3.861700E+00,6.641000E+00,7.247100E+00,1.094800E-03,1.641500E-03,& + & 2.976800E-03,4.743200E-03,8.313300E-03,1.601300E-02,3.427000E-02,& + & 9.914800E-02,3.544300E-01,8.972200E-01,1.238300E+00,1.897000E+00,& + & 2.953100E+00,4.573500E+00,7.770600E+00,8.430800E+00,1.303500E-03,& + & 2.093500E-03,2.911400E-03,5.070800E-03,9.101000E-03,1.777400E-02,& + & 3.987800E-02,1.154700E-01,4.195800E-01,1.036900E+00,1.428000E+00,& + & 2.189600E+00,3.304300E+00,5.159500E+00,8.445200E+00,9.032100E+00,& + & 6.842900E-04,1.420100E-03,2.584400E-03,4.355100E-03,8.283100E-03,& + & 1.680700E-02,3.915800E-02,1.205900E-01,4.666300E-01,1.199600E+00,& + & 1.661500E+00,2.541100E+00,4.022400E+00,6.220100E+00,1.076300E+01,& + & 1.178400E+01,1.934400E-06,8.526400E-06,4.373500E-05,1.740500E-04,& + & 8.713300E-04,2.553000E-03,5.880200E-03,1.612600E-02,4.593300E-02,& + & 9.575200E-02,1.324500E-01,2.421200E-01,4.429500E-01,7.154200E-01,& + & 8.420000E-01,8.565500E-01,2.474400E-04,6.350700E-04,1.363200E-03,& + & 2.431600E-03,4.117800E-03,8.221300E-03,1.777600E-02,4.061000E-02,& + & 1.097200E-01,2.579200E-01,3.672500E-01,5.287100E-01,6.922800E-01,& + & 9.329000E-01,1.628400E+00,1.830800E+00,4.426300E-04,1.107200E-03,& + & 2.066300E-03,3.318200E-03,5.908800E-03,1.111900E-02,2.405500E-02,& + & 5.593500E-02,1.756200E-01,4.186000E-01,5.568300E-01,7.548400E-01,& + & 1.194100E+00,1.859400E+00,3.244300E+00,3.644300E+00,6.298300E-04,& + & 1.484300E-03,2.503100E-03,4.114200E-03,7.302600E-03,1.338600E-02,& + & 2.903000E-02,7.035000E-02,2.386900E-01,5.474200E-01,7.433600E-01,& + & 1.126900E+00,1.786300E+00,2.780300E+00,4.840500E+00,5.430300E+00,& + & 8.025800E-04,1.774700E-03,2.835900E-03,4.838700E-03,8.312500E-03,& + & 1.546700E-02,3.299900E-02,8.575800E-02,2.959200E-01,7.166900E-01,& + & 9.898800E-01,1.500000E+00,2.371900E+00,3.690700E+00,6.404000E+00,& + & 7.169600E+00,9.750300E-04,1.936200E-03,3.212400E-03,5.367300E-03,& + & 9.099600E-03,1.739600E-02,3.651600E-02,1.019300E-01,3.567100E-01,& + & 8.925500E-01,1.235500E+00,1.870000E+00,2.944900E+00,4.581500E+00,& + & 7.903600E+00,8.819100E+00,1.165100E-03,2.023300E-03,3.564300E-03,& + & 5.671600E-03,9.911300E-03,1.910500E-02,4.097000E-02,1.181500E-01,& + & 4.235400E-01,1.064800E+00,1.478000E+00,2.233600E+00,3.487900E+00,& + & 5.422800E+00,9.246000E+00,1.026100E+01,1.449700E-03,2.157200E-03,& + & 3.813800E-03,6.003600E-03,1.088800E-02,2.140500E-02,4.765100E-02,& + & 1.379400E-01,5.020500E-01,1.223400E+00,1.713200E+00,2.564700E+00,& + & 3.917000E+00,6.099700E+00,1.005700E+01,1.099400E+01,8.146100E-04,& + & 1.661900E-03,3.076600E-03,5.255400E-03,9.853900E-03,2.019800E-02,& + & 4.678400E-02,1.442800E-01,5.576200E-01,1.429300E+00,1.978800E+00,& + & 2.998700E+00,4.743400E+00,7.381100E+00,1.280800E+01,1.433900E+01,& + & 8.573200E-07,3.283500E-06,1.433200E-05,6.099300E-05,4.294200E-04,& + & 1.839300E-03,4.558900E-03,1.321700E-02,4.210600E-02,9.277900E-02,& + & 1.164100E-01,2.009200E-01,4.243800E-01,7.761300E-01,9.721500E-01,& + & 9.966000E-01,9.646700E-05,2.211100E-04,5.048100E-04,1.086500E-03,& + & 2.120900E-03,4.271900E-03,1.007900E-02,2.347900E-02,6.436900E-02,& + & 1.364700E-01,1.977000E-01,3.056600E-01,5.077700E-01,7.248200E-01,& + & 8.506700E-01,8.718700E-01,1.742400E-04,3.919900E-04,8.388500E-04,& + & 1.506400E-03,2.661100E-03,5.610800E-03,1.233700E-02,2.953900E-02,& + & 8.455500E-02,2.037400E-01,2.943900E-01,4.332100E-01,6.151900E-01,& + & 8.821300E-01,1.353200E+00,1.605800E+00,2.510000E-04,5.478200E-04,& + & 1.038600E-03,1.795600E-03,3.095400E-03,6.423800E-03,1.399400E-02,& + & 3.375100E-02,1.054200E-01,2.688000E-01,3.752500E-01,5.277000E-01,& + & 7.059600E-01,1.290600E+00,2.024700E+00,2.402000E+00,3.306500E-04,& + & 7.147900E-04,1.152800E-03,1.949200E-03,3.509200E-03,6.886700E-03,& + & 1.524900E-02,3.672100E-02,1.269000E-01,3.247400E-01,4.372200E-01,& + & 6.016000E-01,9.343800E-01,1.717400E+00,2.689500E+00,3.190000E+00/ + data absa(:,141:160) / & + & 4.872400E-04,7.615400E-04,1.215300E-03,2.075800E-03,3.779500E-03,& + & 7.192400E-03,1.607000E-02,3.916100E-02,1.475000E-01,3.663000E-01,& + & 5.009400E-01,7.502300E-01,1.164500E+00,2.140600E+00,3.341900E+00,& + & 3.959600E+00,6.029900E-04,8.234500E-04,1.323600E-03,2.137600E-03,& + & 3.753600E-03,7.406000E-03,1.632100E-02,4.233900E-02,1.648700E-01,& + & 4.291500E-01,6.000900E-01,8.987000E-01,1.389200E+00,2.553600E+00,& + & 3.962400E+00,4.688400E+00,7.858200E-04,1.088800E-03,1.323600E-03,& + & 1.997400E-03,3.680300E-03,7.286200E-03,1.619100E-02,4.702500E-02,& + & 1.857600E-01,4.964400E-01,6.973100E-01,1.043200E+00,1.594600E+00,& + & 2.927200E+00,4.466200E+00,5.260200E+00,2.980800E-04,6.174900E-04,& + & 9.917700E-04,1.719400E-03,3.183300E-03,6.315600E-03,1.549200E-02,& + & 4.784700E-02,2.065100E-01,5.735700E-01,8.019600E-01,1.201300E+00,& + & 1.868600E+00,3.434800E+00,5.379100E+00,6.380000E+00,1.130800E-06,& + & 4.617700E-06,2.174500E-05,9.373900E-05,6.127800E-04,2.351000E-03,& + & 5.683400E-03,1.644700E-02,5.257600E-02,1.160400E-01,1.496600E-01,& + & 2.607100E-01,5.291100E-01,9.405400E-01,1.163200E+00,1.190900E+00,& + & 1.182600E-04,2.823900E-04,6.579700E-04,1.393800E-03,2.680100E-03,& + & 5.333000E-03,1.263800E-02,2.941700E-02,8.102600E-02,1.747700E-01,& + & 2.576500E-01,3.870300E-01,6.265300E-01,9.013600E-01,1.026400E+00,& + & 1.045400E+00,2.130300E-04,4.939200E-04,1.077100E-03,1.909000E-03,& + & 3.364800E-03,6.992300E-03,1.546400E-02,3.709300E-02,1.068300E-01,& + & 2.592400E-01,3.725200E-01,5.575700E-01,7.590300E-01,1.078100E+00,& + & 1.793700E+00,2.081300E+00,3.026100E-04,6.929900E-04,1.328200E-03,& + & 2.265500E-03,3.910800E-03,7.980100E-03,1.758300E-02,4.254600E-02,& + & 1.328000E-01,3.428800E-01,4.683400E-01,6.593000E-01,9.259100E-01,& + & 1.585000E+00,2.684700E+00,3.113500E+00,3.918600E-04,8.708900E-04,& + & 1.486000E-03,2.471400E-03,4.428900E-03,8.582900E-03,1.915400E-02,& + & 4.645600E-02,1.595000E-01,4.114300E-01,5.421600E-01,7.661900E-01,& + & 1.232000E+00,2.109800E+00,3.566700E+00,4.133800E+00,5.084900E-04,& + & 1.003500E-03,1.549200E-03,2.646800E-03,4.730500E-03,9.035200E-03,& + & 2.016600E-02,4.976500E-02,1.849100E-01,4.566100E-01,6.360600E-01,& + & 9.573200E-01,1.535200E+00,2.629500E+00,4.431700E+00,5.132000E+00,& + & 7.032200E-04,9.411300E-04,1.618800E-03,2.799800E-03,4.767700E-03,& + & 9.367000E-03,2.045600E-02,5.392200E-02,2.065500E-01,5.393300E-01,& + & 7.607500E-01,1.147700E+00,1.830700E+00,3.137200E+00,5.253800E+00,& + & 6.075400E+00,8.227500E-04,1.277600E-03,1.546800E-03,2.599300E-03,& + & 4.718700E-03,9.379000E-03,2.043800E-02,5.972400E-02,2.330700E-01,& + & 6.279200E-01,8.797500E-01,1.336400E+00,2.095500E+00,3.602000E+00,& + & 5.921200E+00,6.817600E+00,3.546200E-04,7.221200E-04,1.275700E-03,& + & 2.176600E-03,4.011200E-03,7.978700E-03,1.945600E-02,6.070300E-02,& + & 2.596600E-01,7.185300E-01,1.018400E+00,1.532100E+00,2.463700E+00,& + & 4.219400E+00,7.133300E+00,8.267500E+00,1.540900E-06,6.547000E-06,& + & 3.266700E-05,1.399900E-04,8.443100E-04,2.932800E-03,6.961900E-03,& + & 2.005500E-02,6.407900E-02,1.432500E-01,1.871000E-01,3.264000E-01,& + & 6.394500E-01,1.109500E+00,1.357400E+00,1.388300E+00,1.441300E-04,& + & 3.577700E-04,8.361400E-04,1.751200E-03,3.331600E-03,6.547700E-03,& + & 1.549200E-02,3.616300E-02,9.962200E-02,2.181000E-01,3.224500E-01,& + & 4.799400E-01,7.508600E-01,1.084300E+00,1.221700E+00,1.305300E+00,& + & 2.581800E-04,6.155000E-04,1.347900E-03,2.388800E-03,4.164800E-03,& + & 8.552400E-03,1.896900E-02,4.572700E-02,1.319400E-01,3.220400E-01,& + & 4.567900E-01,6.873700E-01,9.290200E-01,1.288700E+00,2.295100E+00,& + & 2.605400E+00,3.626300E-04,8.606600E-04,1.667300E-03,2.801800E-03,& + & 4.859700E-03,9.752200E-03,2.161200E-02,5.254100E-02,1.639200E-01,& + & 4.234500E-01,5.720500E-01,7.957500E-01,1.181600E+00,1.917000E+00,& + & 3.435200E+00,3.897200E+00,4.646900E-04,1.068600E-03,1.858200E-03,& + & 3.068700E-03,5.482900E-03,1.052300E-02,2.356800E-02,5.747200E-02,& + & 1.967200E-01,5.027000E-01,6.619400E-01,9.461700E-01,1.572800E+00,& + & 2.551200E+00,4.562500E+00,5.174600E+00,5.759200E-04,1.218100E-03,& + & 1.941600E-03,3.309700E-03,5.848400E-03,1.110500E-02,2.477000E-02,& + & 6.184400E-02,2.276900E-01,5.539000E-01,7.915100E-01,1.182100E+00,& + & 1.960000E+00,3.179100E+00,5.668600E+00,6.424500E+00,7.386700E-04,& + & 1.220400E-03,2.003600E-03,3.482500E-03,5.913500E-03,1.157100E-02,& + & 2.512000E-02,6.705800E-02,2.545100E-01,6.583900E-01,9.464300E-01,& + & 1.417800E+00,2.338000E+00,3.791900E+00,6.722200E+00,7.605600E+00/ + data absa(:,161:180) / & + & 8.749600E-04,1.319600E-03,2.102400E-03,3.229700E-03,5.945100E-03,& + & 1.168400E-02,2.522300E-02,7.409000E-02,2.878100E-01,7.686200E-01,& + & 1.091900E+00,1.654100E+00,2.679300E+00,4.351100E+00,7.578800E+00,& + & 8.541500E+00,4.276000E-04,8.585600E-04,1.575400E-03,2.691200E-03,& + & 4.989100E-03,9.912400E-03,2.399700E-02,7.524100E-02,3.214200E-01,& + & 8.752600E-01,1.267100E+00,1.891400E+00,3.145300E+00,5.102100E+00,& + & 9.125000E+00,1.034900E+01,2.130000E-06,9.289600E-06,4.809300E-05,& + & 2.028400E-04,1.117500E-03,3.613600E-03,8.400600E-03,2.400600E-02,& + & 7.678100E-02,1.732000E-01,2.285300E-01,3.985500E-01,7.543200E-01,& + & 1.279100E+00,1.547300E+00,1.581300E+00,1.756300E-04,4.482600E-04,& + & 1.047200E-03,2.157600E-03,4.050600E-03,7.970800E-03,1.864400E-02,& + & 4.378500E-02,1.203600E-01,2.669400E-01,3.920100E-01,5.834800E-01,& + & 8.794600E-01,1.260300E+00,1.462100E+00,1.601700E+00,3.102600E-04,& + & 7.610600E-04,1.654100E-03,2.950700E-03,5.074700E-03,1.030600E-02,& + & 2.289200E-02,5.546900E-02,1.604000E-01,3.893800E-01,5.504100E-01,& + & 8.207800E-01,1.107300E+00,1.538200E+00,2.848700E+00,3.196500E+00,& + & 4.322800E-04,1.054700E-03,2.046200E-03,3.417900E-03,5.964700E-03,& + & 1.174800E-02,2.610800E-02,6.375500E-02,1.995500E-01,5.094500E-01,& + & 6.881000E-01,9.383000E-01,1.456900E+00,2.303800E+00,4.263500E+00,& + & 4.780300E+00,5.485900E-04,1.298900E-03,2.291000E-03,3.740800E-03,& + & 6.696600E-03,1.270800E-02,2.848700E-02,6.992000E-02,2.390900E-01,& + & 6.040600E-01,7.887600E-01,1.149000E+00,1.939400E+00,3.064900E+00,& + & 5.665100E+00,6.344600E+00,6.668100E-04,1.467100E-03,2.392700E-03,& + & 4.062800E-03,7.110200E-03,1.344000E-02,2.998100E-02,7.552700E-02,& + & 2.758400E-01,6.693600E-01,9.578700E-01,1.435200E+00,2.418300E+00,& + & 3.817300E+00,7.038700E+00,7.872800E+00,7.958100E-04,1.526000E-03,& + & 2.456900E-03,4.258900E-03,7.212700E-03,1.403200E-02,3.045700E-02,& + & 8.200000E-02,3.087200E-01,8.005800E-01,1.145800E+00,1.720700E+00,& + & 2.887500E+00,4.551300E+00,8.349100E+00,9.311800E+00,9.993200E-04,& + & 1.423800E-03,2.601000E-03,4.055400E-03,7.266800E-03,1.427100E-02,& + & 3.072400E-02,9.038700E-02,3.501700E-01,9.340500E-01,1.324100E+00,& + & 2.004100E+00,3.317300E+00,5.208300E+00,9.417700E+00,1.042300E+01,& + & 5.089200E-04,1.023700E-03,1.921000E-03,3.282200E-03,6.079400E-03,& + & 1.217200E-02,2.918300E-02,9.196800E-02,3.914900E-01,1.063900E+00,& + & 1.533500E+00,2.296300E+00,3.878200E+00,6.129400E+00,1.133000E+01,& + & 1.268900E+01,2.929100E-06,1.307100E-05,6.861000E-05,2.865300E-04,& + & 1.433400E-03,4.344200E-03,1.005300E-02,2.830100E-02,9.060500E-02,& + & 2.052800E-01,2.730400E-01,4.757000E-01,8.713400E-01,1.446500E+00,& + & 1.730500E+00,1.766600E+00,2.127200E-04,5.573300E-04,1.293300E-03,& + & 2.610100E-03,4.894800E-03,9.576100E-03,2.209900E-02,5.229500E-02,& + & 1.431400E-01,3.215300E-01,4.653000E-01,6.941500E-01,1.012300E+00,& + & 1.429200E+00,1.731200E+00,1.974200E+00,3.686400E-04,9.362500E-04,& + & 1.999500E-03,3.591700E-03,6.105600E-03,1.227700E-02,2.723900E-02,& + & 6.627200E-02,1.922300E-01,4.626800E-01,6.541100E-01,9.547200E-01,& + & 1.282900E+00,1.836200E+00,3.433000E+00,3.939800E+00,5.116500E-04,& + & 1.282100E-03,2.475200E-03,4.118900E-03,7.206900E-03,1.399700E-02,& + & 3.108000E-02,7.626300E-02,2.394300E-01,6.039200E-01,8.151300E-01,& + & 1.092200E+00,1.740300E+00,2.749900E+00,5.136600E+00,5.891800E+00,& + & 6.467700E-04,1.555900E-03,2.785800E-03,4.503100E-03,8.073700E-03,& + & 1.516300E-02,3.397500E-02,8.388300E-02,2.864500E-01,7.163600E-01,& + & 9.268200E-01,1.377600E+00,2.317200E+00,3.657900E+00,6.825700E+00,& + & 7.819100E+00,7.761900E-04,1.751600E-03,2.910700E-03,4.887600E-03,& + & 8.555500E-03,1.605300E-02,3.583100E-02,9.094100E-02,3.291100E-01,& + & 8.067800E-01,1.140600E+00,1.719600E+00,2.890200E+00,4.556100E+00,& + & 8.482500E+00,9.697600E+00,8.981400E-04,1.836400E-03,2.984700E-03,& + & 5.108500E-03,8.693400E-03,1.679500E-02,3.649600E-02,9.888400E-02,& + & 3.694500E-01,9.659600E-01,1.365300E+00,2.059400E+00,3.452800E+00,& + & 5.428000E+00,1.006500E+01,1.146300E+01,1.089700E-03,1.711500E-03,& + & 3.091200E-03,4.972800E-03,8.756000E-03,1.716300E-02,3.698900E-02,& + & 1.087600E-01,4.207100E-01,1.124800E+00,1.582500E+00,2.390200E+00,& + & 3.974400E+00,6.205000E+00,1.135600E+01,1.280400E+01,6.006400E-04,& + & 1.216500E-03,2.324200E-03,3.939400E-03,7.189600E-03,1.492200E-02,& + & 3.508600E-02,1.110200E-01,4.706100E-01,1.284800E+00,1.825200E+00,& + & 2.752800E+00,4.633500E+00,7.315000E+00,1.365100E+01,1.563800E+01/ + data absa(:,181:200) / & + & 1.241500E-06,4.500200E-06,1.935700E-05,8.621300E-05,6.092600E-04,& + & 2.668800E-03,6.768900E-03,1.993200E-02,7.185000E-02,1.724100E-01,& + & 2.236100E-01,3.324700E-01,7.120700E-01,1.355300E+00,1.738800E+00,& + & 1.790500E+00,7.827700E-05,1.786900E-04,4.318800E-04,1.023500E-03,& + & 2.352900E-03,4.805200E-03,1.190300E-02,2.890900E-02,8.961700E-02,& + & 1.881500E-01,2.431800E-01,3.959400E-01,6.871100E-01,1.185900E+00,& + & 1.521500E+00,1.566800E+00,1.377800E-04,3.111200E-04,6.976000E-04,& + & 1.446300E-03,2.835500E-03,5.783200E-03,1.364800E-02,3.392900E-02,& + & 1.035800E-01,2.208800E-01,3.153900E-01,4.905600E-01,8.324100E-01,& + & 1.188900E+00,1.377200E+00,1.630600E+00,1.928400E-04,4.290600E-04,& + & 9.188100E-04,1.693200E-03,3.079700E-03,6.479700E-03,1.457100E-02,& + & 3.696300E-02,1.141700E-01,2.681000E-01,3.944300E-01,5.881300E-01,& + & 8.652900E-01,1.282000E+00,1.964100E+00,2.442400E+00,2.474000E-04,& + & 5.357000E-04,1.044400E-03,1.858600E-03,3.214900E-03,6.850200E-03,& + & 1.509100E-02,3.859900E-02,1.241000E-01,3.222000E-01,4.571600E-01,& + & 6.560700E-01,8.855000E-01,1.612600E+00,2.614000E+00,3.249900E+00,& + & 3.042200E-04,6.632100E-04,1.086100E-03,1.889900E-03,3.340000E-03,& + & 6.821800E-03,1.524900E-02,3.909000E-02,1.344500E-01,3.681000E-01,& + & 5.010900E-01,6.803500E-01,1.040600E+00,2.013300E+00,3.257300E+00,& + & 4.047800E+00,4.504600E-04,6.660600E-04,1.080800E-03,1.832500E-03,& + & 3.391000E-03,6.524200E-03,1.496300E-02,3.810000E-02,1.450000E-01,& + & 3.958500E-01,5.215400E-01,7.903200E-01,1.245100E+00,2.410000E+00,& + & 3.885300E+00,4.823700E+00,5.509700E-04,8.008800E-04,1.052800E-03,& + & 1.693100E-03,2.980100E-03,6.072200E-03,1.394100E-02,3.664700E-02,& + & 1.528900E-01,4.347600E-01,6.067900E-01,9.184000E-01,1.440700E+00,& + & 2.791700E+00,4.451500E+00,5.514100E+00,2.155700E-04,4.384500E-04,& + & 7.620200E-04,1.216700E-03,2.268100E-03,4.675300E-03,1.107200E-02,& + & 3.457000E-02,1.639300E-01,4.955900E-01,6.957100E-01,1.055700E+00,& + & 1.667000E+00,3.225100E+00,5.228000E+00,6.499800E+00,1.590900E-06,& + & 6.270900E-06,2.983300E-05,1.349700E-04,8.813100E-04,3.468800E-03,& + & 8.588900E-03,2.522100E-02,9.116000E-02,2.192800E-01,2.878100E-01,& + & 4.428200E-01,9.094400E-01,1.674600E+00,2.116900E+00,2.176300E+00,& + & 9.752100E-05,2.352600E-04,5.654800E-04,1.363900E-03,3.019600E-03,& + & 6.129700E-03,1.508000E-02,3.686700E-02,1.141100E-01,2.429700E-01,& + & 3.245100E-01,5.120300E-01,8.841800E-01,1.465300E+00,1.852100E+00,& + & 1.904100E+00,1.712500E-04,3.994600E-04,9.144000E-04,1.886700E-03,& + & 3.635300E-03,7.323000E-03,1.739000E-02,4.318400E-02,1.321800E-01,& + & 2.876200E-01,4.153600E-01,6.448600E-01,1.038400E+00,1.472200E+00,& + & 1.796200E+00,2.165800E+00,2.385200E-04,5.482200E-04,1.200500E-03,& + & 2.181300E-03,3.971800E-03,8.178200E-03,1.853000E-02,4.714700E-02,& + & 1.461000E-01,3.490700E-01,5.063000E-01,7.715200E-01,1.095700E+00,& + & 1.579000E+00,2.647000E+00,3.244000E+00,3.022100E-04,6.844600E-04,& + & 1.360400E-03,2.373100E-03,4.131600E-03,8.632200E-03,1.922200E-02,& + & 4.939400E-02,1.589000E-01,4.150600E-01,5.834400E-01,8.409000E-01,& + & 1.161000E+00,2.013200E+00,3.523000E+00,4.316600E+00,3.656300E-04,& + & 8.165000E-04,1.425600E-03,2.435200E-03,4.269400E-03,8.619500E-03,& + & 1.947300E-02,5.006000E-02,1.719400E-01,4.691900E-01,6.385500E-01,& + & 8.662800E-01,1.402900E+00,2.513300E+00,4.391500E+00,5.377100E+00,& + & 4.652500E-04,8.984100E-04,1.394500E-03,2.375700E-03,4.303700E-03,& + & 8.312600E-03,1.908400E-02,4.901600E-02,1.848700E-01,4.975600E-01,& + & 6.729700E-01,1.017900E+00,1.678800E+00,3.007100E+00,5.239600E+00,& + & 6.407100E+00,6.132000E-04,8.366100E-04,1.387200E-03,2.216900E-03,& + & 3.901200E-03,7.854000E-03,1.776400E-02,4.737900E-02,1.944000E-01,& + & 5.522200E-01,7.826600E-01,1.184100E+00,1.942900E+00,3.479500E+00,& + & 6.011700E+00,7.324700E+00,2.598700E-04,5.325000E-04,9.442100E-04,& + & 1.570700E-03,2.939200E-03,5.938500E-03,1.383300E-02,4.495900E-02,& + & 2.089900E-01,6.288400E-01,8.972600E-01,1.358900E+00,2.247200E+00,& + & 4.026200E+00,7.046000E+00,8.633200E+00,2.142300E-06,8.921500E-06,& + & 4.557800E-05,2.046900E-04,1.230300E-03,4.405800E-03,1.067900E-02,& + & 3.123200E-02,1.126600E-01,2.726500E-01,3.615900E-01,5.691200E-01,& + & 1.121700E+00,2.007100E+00,2.504100E+00,2.570200E+00,1.216300E-04,& + & 3.051500E-04,7.273000E-04,1.768400E-03,3.806600E-03,7.663000E-03,& + & 1.874500E-02,4.582400E-02,1.416300E-01,3.060700E-01,4.191500E-01,& + & 6.390000E-01,1.105100E+00,1.756300E+00,2.190900E+00,2.248800E+00/ + data absa(:,201:220) / & + & 2.088100E-04,5.100700E-04,1.176200E-03,2.397000E-03,4.578700E-03,& + & 9.101300E-03,2.159900E-02,5.377300E-02,1.645200E-01,3.648300E-01,& + & 5.270700E-01,8.224700E-01,1.255000E+00,1.764400E+00,2.311000E+00,& + & 2.767100E+00,2.912900E-04,6.905300E-04,1.526900E-03,2.767900E-03,& + & 4.963100E-03,1.014700E-02,2.303900E-02,5.891800E-02,1.821600E-01,& + & 4.437000E-01,6.297600E-01,9.672700E-01,1.367700E+00,1.892600E+00,& + & 3.455300E+00,4.144600E+00,3.662500E-04,8.573900E-04,1.732900E-03,& + & 2.981600E-03,5.197200E-03,1.066700E-02,2.392400E-02,6.182600E-02,& + & 1.985600E-01,5.176100E-01,7.267400E-01,1.036900E+00,1.477000E+00,& + & 2.470500E+00,4.598600E+00,5.514500E+00,4.390800E-04,1.009200E-03,& + & 1.816800E-03,3.054900E-03,5.364500E-03,1.068000E-02,2.426800E-02,& + & 6.262600E-02,2.150400E-01,5.769000E-01,7.974000E-01,1.069800E+00,& + & 1.815400E+00,3.082600E+00,5.730800E+00,6.869200E+00,5.252400E-04,& + & 1.099700E-03,1.775100E-03,3.009800E-03,5.380400E-03,1.035500E-02,& + & 2.380700E-02,6.139900E-02,2.309300E-01,6.053000E-01,8.498500E-01,& + & 1.270600E+00,2.173800E+00,3.688000E+00,6.840500E+00,8.186200E+00,& + & 7.142200E-04,9.511800E-04,1.693500E-03,2.879800E-03,4.926300E-03,& + & 9.854300E-03,2.209000E-02,5.964300E-02,2.425500E-01,6.786600E-01,& + & 9.893800E-01,1.478500E+00,2.518200E+00,4.263000E+00,7.847300E+00,& + & 9.358400E+00,3.185300E-04,6.412300E-04,1.165200E-03,1.980200E-03,& + & 3.698300E-03,7.382800E-03,1.733500E-02,5.635800E-02,2.617900E-01,& + & 7.729000E-01,1.132500E+00,1.695900E+00,2.907700E+00,4.940400E+00,& + & 9.197200E+00,1.102900E+01,2.953800E-06,1.281400E-05,6.791500E-05,& + & 3.011800E-04,1.661900E-03,5.511500E-03,1.305500E-02,3.791100E-02,& + & 1.364200E-01,3.328800E-01,4.441600E-01,7.093100E-01,1.346000E+00,& + & 2.346100E+00,2.891500E+00,2.965200E+00,1.507200E-04,3.918800E-04,& + & 9.222700E-04,2.241200E-03,4.736300E-03,9.436100E-03,2.282800E-02,& + & 5.589000E-02,1.724900E-01,3.761000E-01,5.245200E-01,7.806900E-01,& + & 1.342900E+00,2.053900E+00,2.530100E+00,2.594100E+00,2.541600E-04,& + & 6.441800E-04,1.483900E-03,2.995200E-03,5.666200E-03,1.116300E-02,& + & 2.630300E-02,6.583500E-02,2.007800E-01,4.516600E-01,6.501700E-01,& + & 1.015300E+00,1.488700E+00,2.062300E+00,2.913600E+00,3.429100E+00,& + & 3.525500E-04,8.612000E-04,1.896400E-03,3.451400E-03,6.125300E-03,& + & 1.238500E-02,2.813600E-02,7.231700E-02,2.229700E-01,5.466200E-01,& + & 7.688000E-01,1.172600E+00,1.656700E+00,2.262800E+00,4.364000E+00,& + & 5.137000E+00,4.406300E-04,1.061800E-03,2.154000E-03,3.705500E-03,& + & 6.422500E-03,1.298600E-02,2.923000E-02,7.582000E-02,2.439600E-01,& + & 6.295100E-01,8.865800E-01,1.242300E+00,1.820600E+00,3.010700E+00,& + & 5.810100E+00,6.834600E+00,5.215600E-04,1.243000E-03,2.258000E-03,& + & 3.767500E-03,6.656000E-03,1.301000E-02,2.968500E-02,7.676900E-02,& + & 2.643300E-01,6.986500E-01,9.627000E-01,1.304300E+00,2.260900E+00,& + & 3.756200E+00,7.241800E+00,8.511500E+00,6.063900E-04,1.332700E-03,& + & 2.228400E-03,3.735800E-03,6.605100E-03,1.266200E-02,2.917000E-02,& + & 7.540800E-02,2.834700E-01,7.297300E-01,1.039900E+00,1.560400E+00,& + & 2.708200E+00,4.491800E+00,8.644700E+00,1.014200E+01,7.482000E-04,& + & 1.236000E-03,2.076800E-03,3.568100E-03,6.084400E-03,1.209900E-02,& + & 2.704600E-02,7.361100E-02,2.975300E-01,8.284200E-01,1.212500E+00,& + & 1.814600E+00,3.142500E+00,5.185000E+00,9.918400E+00,1.159000E+01,& + & 3.868600E-04,7.683000E-04,1.418700E-03,2.452400E-03,4.548200E-03,& + & 9.080300E-03,2.137200E-02,6.949800E-02,3.221300E-01,9.457500E-01,& + & 1.384600E+00,2.082900E+00,3.619900E+00,6.020300E+00,1.162000E+01,& + & 1.366900E+01,4.080800E-06,1.837600E-05,9.823200E-05,4.317800E-04,& + & 2.168100E-03,6.786200E-03,1.575100E-02,4.522500E-02,1.623900E-01,& + & 3.991500E-01,5.339400E-01,8.594900E-01,1.579500E+00,2.683200E+00,& + & 3.265500E+00,3.344200E+00,1.849200E-04,4.986500E-04,1.161400E-03,& + & 2.769200E-03,5.827300E-03,1.148200E-02,2.727100E-02,6.720300E-02,& + & 2.066000E-01,4.519500E-01,6.363800E-01,9.382500E-01,1.588100E+00,& + & 2.356900E+00,2.857400E+00,2.926000E+00,3.079300E-04,8.064400E-04,& + & 1.841700E-03,3.669900E-03,6.880800E-03,1.356300E-02,3.154700E-02,& + & 7.932200E-02,2.411400E-01,5.470700E-01,7.840700E-01,1.210500E+00,& + & 1.751700E+00,2.357800E+00,3.566000E+00,4.222500E+00,4.215500E-04,& + & 1.067000E-03,2.316200E-03,4.250700E-03,7.438900E-03,1.494200E-02,& + & 3.383300E-02,8.705800E-02,2.689400E-01,6.610300E-01,9.219700E-01,& + & 1.382900E+00,1.932400E+00,2.726600E+00,5.343800E+00,6.323100E+00/ + data absa(:,221:240) / & + & 5.263000E-04,1.303800E-03,2.633300E-03,4.534100E-03,7.826900E-03,& + & 1.558800E-02,3.520400E-02,9.139400E-02,2.948400E-01,7.577300E-01,& + & 1.057200E+00,1.459200E+00,2.185900E+00,3.630600E+00,7.112300E+00,& + & 8.411700E+00,6.189200E-04,1.504300E-03,2.767800E-03,4.590400E-03,& + & 8.120400E-03,1.564300E-02,3.570700E-02,9.272800E-02,3.195800E-01,& + & 8.389100E-01,1.132800E+00,1.574800E+00,2.728400E+00,4.529200E+00,& + & 8.867500E+00,1.047300E+01,7.082000E-04,1.604900E-03,2.727800E-03,& + & 4.560600E-03,8.016600E-03,1.526100E-02,3.518100E-02,9.129000E-02,& + & 3.420700E-01,8.709700E-01,1.255500E+00,1.887000E+00,3.269400E+00,& + & 5.414600E+00,1.058300E+01,1.247300E+01,8.004900E-04,1.543200E-03,& + & 2.534300E-03,4.349700E-03,7.400300E-03,1.462700E-02,3.265400E-02,& + & 8.946700E-02,3.595800E-01,1.000500E+00,1.461100E+00,2.193800E+00,& + & 3.797100E+00,6.248000E+00,1.215200E+01,1.422600E+01,4.625700E-04,& + & 9.131400E-04,1.713500E-03,2.990400E-03,5.495000E-03,1.102600E-02,& + & 2.602900E-02,8.454500E-02,3.909500E-01,1.140400E+00,1.671100E+00,& + & 2.518900E+00,4.367600E+00,7.259500E+00,1.422400E+01,1.682300E+01,& + & 1.727600E-06,5.789200E-06,2.408700E-05,1.122400E-04,8.331900E-04,& + & 3.572400E-03,9.209400E-03,2.766800E-02,1.114000E-01,2.977800E-01,& + & 3.915400E-01,5.250900E-01,1.102300E+00,2.179800E+00,2.865700E+00,& + & 2.965900E+00,6.306600E-05,1.466300E-04,3.602300E-04,9.624800E-04,& + & 2.454100E-03,5.437000E-03,1.372400E-02,3.484200E-02,1.214400E-01,& + & 2.896700E-01,3.696000E-01,5.172100E-01,9.752600E-01,1.907600E+00,& + & 2.507700E+00,2.595700E+00,1.098500E-04,2.406500E-04,5.762000E-04,& + & 1.348600E-03,2.930900E-03,6.029400E-03,1.503600E-02,3.814700E-02,& + & 1.321800E-01,2.924200E-01,3.666000E-01,5.737800E-01,1.061700E+00,& + & 1.663400E+00,2.149500E+00,2.225100E+00,1.504300E-04,3.306400E-04,& + & 7.477500E-04,1.565100E-03,3.123900E-03,6.391400E-03,1.537100E-02,& + & 3.971900E-02,1.371800E-01,2.907600E-01,4.082600E-01,6.338400E-01,& + & 1.100800E+00,1.661000E+00,1.942600E+00,2.419200E+00,1.879200E-04,& + & 4.113500E-04,8.900700E-04,1.673900E-03,3.123200E-03,6.604700E-03,& + & 1.510600E-02,4.005600E-02,1.365300E-01,3.160600E-01,4.612300E-01,& + & 6.969200E-01,1.065100E+00,1.612600E+00,2.550900E+00,3.221200E+00,& + & 2.254700E-04,4.816900E-04,9.542900E-04,1.721700E-03,3.030400E-03,& + & 6.523200E-03,1.447300E-02,3.907300E-02,1.340200E-01,3.521600E-01,& + & 5.008400E-01,7.341900E-01,1.017800E+00,1.808600E+00,3.182700E+00,& + & 4.019100E+00,2.727800E-04,5.837900E-04,9.176400E-04,1.620000E-03,& + & 2.895300E-03,6.027700E-03,1.353200E-02,3.662500E-02,1.317400E-01,& + & 3.751400E-01,5.215400E-01,7.186400E-01,1.083600E+00,2.168100E+00,& + & 3.806900E+00,4.805500E+00,4.002900E-04,5.771000E-04,8.463600E-04,& + & 1.381200E-03,2.623200E-03,5.066100E-03,1.202000E-02,3.205500E-02,& + & 1.294600E-01,3.636000E-01,5.272800E-01,7.931700E-01,1.259000E+00,& + & 2.521200E+00,4.397300E+00,5.543200E+00,1.562500E-04,3.181400E-04,& + & 5.795900E-04,9.302400E-04,1.685400E-03,3.153000E-03,8.167000E-03,& + & 2.402600E-02,1.267700E-01,4.028600E-01,6.032000E-01,9.086600E-01,& + & 1.447400E+00,2.895500E+00,5.101700E+00,6.442400E+00,2.118900E-06,& + & 7.969000E-06,3.713900E-05,1.778800E-04,1.203800E-03,4.718200E-03,& + & 1.198600E-02,3.552500E-02,1.442000E-01,3.836400E-01,5.127500E-01,& + & 7.095700E-01,1.446400E+00,2.756800E+00,3.565600E+00,3.683200E+00,& + & 8.047600E-05,1.959000E-04,4.823200E-04,1.297900E-03,3.254400E-03,& + & 7.138200E-03,1.763400E-02,4.507300E-02,1.582700E-01,3.734700E-01,& + & 4.855600E-01,6.962500E-01,1.281900E+00,2.412400E+00,3.120000E+00,& + & 3.222300E+00,1.366400E-04,3.204100E-04,7.656400E-04,1.796300E-03,& + & 3.839700E-03,7.836500E-03,1.936500E-02,4.955300E-02,1.711900E-01,& + & 3.838400E-01,4.973200E-01,7.663800E-01,1.374800E+00,2.131900E+00,& + & 2.674200E+00,2.761600E+00,1.884100E-04,4.322200E-04,9.934100E-04,& + & 2.062100E-03,4.074000E-03,8.270600E-03,1.983400E-02,5.163000E-02,& + & 1.777600E-01,3.840200E-01,5.478800E-01,8.582100E-01,1.407800E+00,& + & 2.089000E+00,2.585700E+00,3.305700E+00,2.349200E-04,5.333400E-04,& + & 1.178100E-03,2.201300E-03,4.083500E-03,8.505300E-03,1.951600E-02,& + & 5.202600E-02,1.774200E-01,4.181100E-01,6.069900E-01,9.331400E-01,& + & 1.385700E+00,2.037900E+00,3.417500E+00,4.402600E+00,2.788800E-04,& + & 6.205600E-04,1.266500E-03,2.237700E-03,3.987900E-03,8.349500E-03,& + & 1.875000E-02,5.081800E-02,1.745400E-01,4.614100E-01,6.533300E-01,& + & 9.624400E-01,1.347600E+00,2.340200E+00,4.265000E+00,5.493100E+00/ + data absa(:,241:260) / & + & 3.223600E-04,7.175100E-04,1.233000E-03,2.127800E-03,3.775300E-03,& + & 7.728200E-03,1.760200E-02,4.772800E-02,1.713400E-01,4.890800E-01,& + & 6.741800E-01,9.291100E-01,1.488200E+00,2.804500E+00,5.102100E+00,& + & 6.566600E+00,4.605700E-04,6.675800E-04,1.091800E-03,1.880900E-03,& + & 3.408200E-03,6.619800E-03,1.559300E-02,4.193500E-02,1.676000E-01,& + & 4.693700E-01,6.864800E-01,1.041000E+00,1.730400E+00,3.259200E+00,& + & 5.896200E+00,7.576800E+00,1.965300E-04,3.906700E-04,7.268800E-04,& + & 1.204200E-03,2.146800E-03,4.140700E-03,1.051100E-02,3.162700E-02,& + & 1.639900E-01,5.234900E-01,7.858000E-01,1.191500E+00,1.987500E+00,& + & 3.746400E+00,6.835000E+00,8.805100E+00,2.791700E-06,1.132300E-05,& + & 5.783600E-05,2.734000E-04,1.685200E-03,6.115000E-03,1.518000E-02,& + & 4.468900E-02,1.812400E-01,4.819600E-01,6.514100E-01,9.289200E-01,& + & 1.830800E+00,3.365300E+00,4.280700E+00,4.411600E+00,1.020000E-04,& + & 2.600400E-04,6.345700E-04,1.714800E-03,4.199000E-03,9.198100E-03,& + & 2.206700E-02,5.677600E-02,2.000200E-01,4.736600E-01,6.212800E-01,& + & 9.064700E-01,1.624200E+00,2.944700E+00,3.745800E+00,3.860400E+00,& + & 1.695400E-04,4.191400E-04,9.948200E-04,2.332300E-03,4.921700E-03,& + & 9.943000E-03,2.439300E-02,6.256000E-02,2.158900E-01,4.880500E-01,& + & 6.513000E-01,9.942100E-01,1.715500E+00,2.649400E+00,3.210500E+00,& + & 3.309600E+00,2.314100E-04,5.585500E-04,1.290200E-03,2.661900E-03,& + & 5.194500E-03,1.046400E-02,2.496300E-02,6.541300E-02,2.238900E-01,& + & 4.974700E-01,7.071200E-01,1.118000E+00,1.745600E+00,2.526000E+00,& + & 3.389100E+00,4.323800E+00,2.896100E-04,6.814000E-04,1.523500E-03,& + & 2.823800E-03,5.232500E-03,1.067100E-02,2.459600E-02,6.604100E-02,& + & 2.242300E-01,5.376100E-01,7.720200E-01,1.191200E+00,1.767500E+00,& + & 2.477400E+00,4.492900E+00,5.758900E+00,3.414300E-04,7.898900E-04,& + & 1.628400E-03,2.863100E-03,5.073800E-03,1.048200E-02,2.368000E-02,& + & 6.456800E-02,2.212700E-01,5.813800E-01,8.330300E-01,1.207400E+00,& + & 1.723700E+00,2.946400E+00,5.608200E+00,7.185200E+00,3.902300E-04,& + & 8.885200E-04,1.598300E-03,2.728400E-03,4.791800E-03,9.693100E-03,& + & 2.227400E-02,6.072100E-02,2.171100E-01,6.123900E-01,8.531400E-01,& + & 1.160600E+00,1.955400E+00,3.530000E+00,6.710000E+00,8.590500E+00,& + & 4.835200E-04,8.877500E-04,1.400500E-03,2.418300E-03,4.293900E-03,& + & 8.386800E-03,1.975000E-02,5.325200E-02,2.120400E-01,5.866200E-01,& + & 8.695300E-01,1.321400E+00,2.276000E+00,4.098000E+00,7.761600E+00,& + & 9.913800E+00,2.394700E-04,4.831000E-04,8.911000E-04,1.521700E-03,& + & 2.682500E-03,5.333100E-03,1.312400E-02,4.042100E-02,2.079300E-01,& + & 6.589000E-01,9.931500E-01,1.514400E+00,2.609400E+00,4.717800E+00,& + & 8.985700E+00,1.151800E+01,3.816800E-06,1.635800E-05,8.782700E-05,& + & 4.095900E-04,2.305500E-03,7.744700E-03,1.887900E-02,5.512200E-02,& + & 2.224800E-01,5.900400E-01,8.111200E-01,1.174900E+00,2.245300E+00,& + & 3.998000E+00,5.017000E+00,5.162800E+00,1.281100E-04,3.405300E-04,& + & 8.302900E-04,2.233100E-03,5.287400E-03,1.149400E-02,2.727200E-02,& + & 7.018700E-02,2.463600E-01,5.924600E-01,7.698900E-01,1.143200E+00,& + & 1.997500E+00,3.498100E+00,4.389300E+00,4.516700E+00,2.105400E-04,& + & 5.404400E-04,1.277600E-03,2.967800E-03,6.188600E-03,1.244500E-02,& + & 3.006800E-02,7.737100E-02,2.660900E-01,6.069800E-01,8.219300E-01,& + & 1.256000E+00,2.078100E+00,3.208100E+00,3.766700E+00,3.853000E+00,& + & 2.837000E-04,7.130500E-04,1.636500E-03,3.379900E-03,6.514800E-03,& + & 1.302400E-02,3.082100E-02,8.116600E-02,2.759400E-01,6.253500E-01,& + & 8.849200E-01,1.397700E+00,2.129500E+00,2.975900E+00,4.337800E+00,& + & 5.459800E+00,3.521700E-04,8.608800E-04,1.921400E-03,3.573600E-03,& + & 6.553300E-03,1.320700E-02,3.041100E-02,8.206000E-02,2.771500E-01,& + & 6.712500E-01,9.607300E-01,1.468600E+00,2.182800E+00,2.969400E+00,& + & 5.773800E+00,7.271100E+00,4.138500E-04,9.876500E-04,2.053800E-03,& + & 3.592800E-03,6.361400E-03,1.289400E-02,2.935500E-02,8.020000E-02,& + & 2.747900E-01,7.143200E-01,1.036200E+00,1.469100E+00,2.132700E+00,& + & 3.644100E+00,7.208700E+00,9.072200E+00,4.678000E-04,1.097400E-03,& + & 2.018100E-03,3.427100E-03,5.994900E-03,1.194600E-02,2.761600E-02,& + & 7.528900E-02,2.701700E-01,7.492600E-01,1.044300E+00,1.428100E+00,& + & 2.465200E+00,4.364300E+00,8.627000E+00,1.084600E+01,5.325300E-04,& + & 1.100000E-03,1.767500E-03,3.055200E-03,5.344000E-03,1.039500E-02,& + & 2.453900E-02,6.610700E-02,2.628300E-01,7.262700E-01,1.066600E+00,& + & 1.646200E+00,2.871300E+00,5.063300E+00,9.983700E+00,1.251500E+01/ + data absa(:,261:280) / & + & 2.942100E-04,5.794800E-04,1.091200E-03,1.884300E-03,3.299000E-03,& + & 6.692100E-03,1.613700E-02,5.071100E-02,2.585600E-01,8.220200E-01,& + & 1.215900E+00,1.887600E+00,3.289300E+00,5.836400E+00,1.154800E+01,& + & 1.454200E+01,5.279900E-06,2.377500E-05,1.295100E-04,5.962000E-04,& + & 3.055000E-03,9.679600E-03,2.311800E-02,6.667400E-02,2.677400E-01,& + & 7.122500E-01,9.862800E-01,1.444200E+00,2.683600E+00,4.637100E+00,& + & 5.740300E+00,5.896800E+00,1.589300E-04,4.408900E-04,1.072500E-03,& + & 2.832800E-03,6.559200E-03,1.419000E-02,3.304900E-02,8.524700E-02,& + & 2.974800E-01,7.233600E-01,9.359600E-01,1.401600E+00,2.398600E+00,& + & 4.056900E+00,5.022600E+00,5.160200E+00,2.591000E-04,6.908200E-04,& + & 1.620600E-03,3.700800E-03,7.679500E-03,1.533000E-02,3.638200E-02,& + & 9.418400E-02,3.218300E-01,7.396900E-01,1.006500E+00,1.548000E+00,& + & 2.457700E+00,3.767600E+00,4.372500E+00,4.505400E+00,3.451700E-04,& + & 9.014800E-04,2.055400E-03,4.197200E-03,8.059100E-03,1.596700E-02,& + & 3.741900E-02,9.874100E-02,3.345000E-01,7.629900E-01,1.084000E+00,& + & 1.692200E+00,2.556700E+00,3.423100E+00,5.398400E+00,6.752700E+00,& + & 4.243400E-04,1.078300E-03,2.376800E-03,4.433000E-03,8.042600E-03,& + & 1.615800E-02,3.701900E-02,9.989100E-02,3.367500E-01,8.224800E-01,& + & 1.168700E+00,1.762100E+00,2.587700E+00,3.572400E+00,7.193600E+00,& + & 8.993500E+00,4.984200E-04,1.223600E-03,2.536900E-03,4.452500E-03,& + & 7.825600E-03,1.566100E-02,3.579000E-02,9.770200E-02,3.349900E-01,& + & 8.695100E-01,1.248900E+00,1.756400E+00,2.566300E+00,4.446500E+00,& + & 8.977400E+00,1.121800E+01,5.572800E-04,1.340900E-03,2.500400E-03,& + & 4.218500E-03,7.418500E-03,1.449200E-02,3.362800E-02,9.166000E-02,& + & 3.300600E-01,9.067900E-01,1.247400E+00,1.732100E+00,3.010400E+00,& + & 5.324500E+00,1.074700E+01,1.340900E+01,6.119500E-04,1.331700E-03,& + & 2.204700E-03,3.771100E-03,6.541200E-03,1.267400E-02,2.991500E-02,& + & 8.078400E-02,3.202000E-01,8.799100E-01,1.298300E+00,2.010500E+00,& + & 3.506400E+00,6.174700E+00,1.244000E+01,1.545700E+01,3.497800E-04,& + & 6.962700E-04,1.322200E-03,2.298800E-03,4.017000E-03,8.249800E-03,& + & 1.903200E-02,6.332100E-02,3.168000E-01,1.000300E+00,1.479600E+00,& + & 2.304800E+00,4.016100E+00,7.118600E+00,1.438700E+01,1.798700E+01,& + & 2.614100E-06,8.009100E-06,3.161000E-05,1.534400E-04,1.203000E-03,& + & 4.961600E-03,1.318000E-02,4.005600E-02,1.773200E-01,5.298300E-01,& + & 6.981100E-01,9.184900E-01,1.778800E+00,3.650000E+00,4.911300E+00,& + & 5.122000E+00,5.166200E-05,1.260500E-04,3.073600E-04,9.231600E-04,& + & 2.789500E-03,6.612100E-03,1.667200E-02,4.489800E-02,1.753400E-01,& + & 4.870900E-01,6.240400E-01,8.062400E-01,1.556500E+00,3.194000E+00,& + & 4.297400E+00,4.457800E+00,8.724900E-05,1.971600E-04,4.809900E-04,& + & 1.277300E-03,3.193200E-03,6.841600E-03,1.759200E-02,4.597100E-02,& + & 1.780300E-01,4.481300E-01,5.743100E-01,7.905000E-01,1.429600E+00,& + & 2.737700E+00,3.683500E+00,3.841200E+00,1.209900E-04,2.563500E-04,& + & 6.187500E-04,1.500000E-03,3.308500E-03,6.810100E-03,1.745800E-02,& + & 4.535200E-02,1.771400E-01,4.188300E-01,5.259600E-01,7.567500E-01,& + & 1.454100E+00,2.352100E+00,3.069700E+00,3.184700E+00,1.482000E-04,& + & 3.169700E-04,7.242500E-04,1.610200E-03,3.249700E-03,6.676800E-03,& + & 1.651300E-02,4.365900E-02,1.702200E-01,3.871000E-01,5.021900E-01,& + & 7.617800E-01,1.380900E+00,2.200500E+00,2.615300E+00,3.136700E+00,& + & 1.738600E-04,3.672700E-04,8.071400E-04,1.612700E-03,3.037300E-03,& + & 6.369600E-03,1.505800E-02,4.074700E-02,1.570200E-01,3.591000E-01,& + & 5.101100E-01,7.813300E-01,1.248200E+00,1.922600E+00,3.109100E+00,& + & 3.917000E+00,1.997300E-04,4.106400E-04,8.276500E-04,1.511500E-03,& + & 2.686000E-03,5.814100E-03,1.309500E-02,3.655400E-02,1.382100E-01,& + & 3.519800E-01,5.228900E-01,7.760800E-01,1.100900E+00,1.895100E+00,& + & 3.725100E+00,4.691500E+00,2.882300E-04,4.323400E-04,7.139700E-04,& + & 1.237700E-03,2.249100E-03,4.673300E-03,1.065000E-02,3.020500E-02,& + & 1.172600E-01,3.436400E-01,4.994600E-01,6.911600E-01,1.085200E+00,& + & 2.203200E+00,4.323900E+00,5.441700E+00,1.246200E-04,2.415000E-04,& + & 4.262700E-04,7.076400E-04,1.350700E-03,2.522700E-03,5.464200E-03,& + & 1.819600E-02,9.262400E-02,3.270800E-01,5.022800E-01,7.799100E-01,& + & 1.244200E+00,2.522400E+00,4.978300E+00,6.273400E+00,3.045100E-06,& + & 1.077600E-05,4.873400E-05,2.439800E-04,1.756100E-03,6.695400E-03,& + & 1.743400E-02,5.218500E-02,2.347700E-01,6.982000E-01,9.325700E-01,& + & 1.241300E+00,2.410000E+00,4.738000E+00,6.256200E+00,6.514600E+00/ + data absa(:,281:300) / & + & 6.690300E-05,1.703400E-04,4.235200E-04,1.280900E-03,3.736600E-03,& + & 8.818900E-03,2.212500E-02,5.863300E-02,2.331600E-01,6.418200E-01,& + & 8.343000E-01,1.091800E+00,2.108900E+00,4.146000E+00,5.474300E+00,& + & 5.700500E+00,1.109900E-04,2.658900E-04,6.547300E-04,1.747700E-03,& + & 4.198900E-03,9.177800E-03,2.317400E-02,6.048000E-02,2.366400E-01,& + & 5.977300E-01,7.675100E-01,1.076900E+00,1.924600E+00,3.553500E+00,& + & 4.692000E+00,4.885200E+00,1.507900E-04,3.471500E-04,8.390900E-04,& + & 2.034700E-03,4.378000E-03,9.128100E-03,2.283500E-02,6.008500E-02,& + & 2.340300E-01,5.619900E-01,7.136000E-01,1.042000E+00,1.936300E+00,& + & 3.074600E+00,3.910200E+00,4.072000E+00,1.877900E-04,4.206200E-04,& + & 9.803600E-04,2.152200E-03,4.327500E-03,8.893900E-03,2.161100E-02,& + & 5.787400E-02,2.249700E-01,5.158500E-01,6.835300E-01,1.060800E+00,& + & 1.818500E+00,2.856000E+00,3.433400E+00,4.422400E+00,2.174600E-04,& + & 4.858300E-04,1.091900E-03,2.131100E-03,4.045400E-03,8.419600E-03,& + & 1.972900E-02,5.408000E-02,2.077100E-01,4.819800E-01,6.881300E-01,& + & 1.072600E+00,1.663600E+00,2.486200E+00,4.181200E+00,5.523700E+00,& + & 2.453200E-04,5.375700E-04,1.119500E-03,1.995000E-03,3.582300E-03,& + & 7.647800E-03,1.718100E-02,4.854600E-02,1.828500E-01,4.753800E-01,& + & 6.935800E-01,1.040400E+00,1.481900E+00,2.532500E+00,5.009500E+00,& + & 6.615100E+00,2.879100E-04,5.955100E-04,9.562100E-04,1.666900E-03,& + & 2.996200E-03,6.122700E-03,1.411700E-02,4.007200E-02,1.552100E-01,& + & 4.559300E-01,6.601800E-01,9.131800E-01,1.512400E+00,2.949800E+00,& + & 5.816800E+00,7.674400E+00,1.568600E-04,2.972500E-04,5.500900E-04,& + & 9.177400E-04,1.742400E-03,3.212900E-03,7.137500E-03,2.406000E-02,& + & 1.231200E-01,4.283800E-01,6.720000E-01,1.035800E+00,1.732400E+00,& + & 3.379000E+00,6.695800E+00,8.844700E+00,3.882100E-06,1.518900E-05,& + & 7.577700E-05,3.805800E-04,2.469500E-03,8.902300E-03,2.256600E-02,& + & 6.643400E-02,3.005400E-01,8.916600E-01,1.198400E+00,1.644400E+00,& + & 3.131900E+00,5.909900E+00,7.660400E+00,7.964200E+00,8.623400E-05,& + & 2.295900E-04,5.718900E-04,1.747700E-03,4.864100E-03,1.158400E-02,& + & 2.827400E-02,7.512200E-02,2.994700E-01,8.201100E-01,1.075500E+00,& + & 1.450000E+00,2.740500E+00,5.171300E+00,6.703100E+00,6.967900E+00,& + & 1.415500E-04,3.547600E-04,8.698200E-04,2.344000E-03,5.489000E-03,& + & 1.198400E-02,2.951900E-02,7.754400E-02,3.037100E-01,7.752000E-01,& + & 9.966000E-01,1.420900E+00,2.500300E+00,4.432600E+00,5.745300E+00,& + & 5.971500E+00,1.881700E-04,4.596400E-04,1.108500E-03,2.682900E-03,& + & 5.704600E-03,1.189900E-02,2.909300E-02,7.721600E-02,2.998900E-01,& + & 7.219500E-01,9.400800E-01,1.392900E+00,2.463600E+00,3.903800E+00,& + & 4.788000E+00,4.977200E+00,2.307900E-04,5.542600E-04,1.294100E-03,& + & 2.803900E-03,5.626600E-03,1.144600E-02,2.759200E-02,7.458400E-02,& + & 2.879700E-01,6.697700E-01,8.976000E-01,1.420000E+00,2.311100E+00,& + & 3.534100E+00,4.484400E+00,5.935200E+00,2.714200E-04,6.304900E-04,& + & 1.433200E-03,2.755500E-03,5.245600E-03,1.083000E-02,2.517700E-02,& + & 6.985800E-02,2.659600E-01,6.290800E-01,8.990600E-01,1.399200E+00,& + & 2.165200E+00,3.082300E+00,5.506300E+00,7.411600E+00,3.036200E-04,& + & 6.932800E-04,1.459500E-03,2.587600E-03,4.675500E-03,9.722300E-03,& + & 2.203200E-02,6.270300E-02,2.347600E-01,6.172000E-01,8.963100E-01,& + & 1.332100E+00,1.911400E+00,3.293000E+00,6.597500E+00,8.877500E+00,& + & 3.342400E-04,7.390200E-04,1.266600E-03,2.176300E-03,3.869400E-03,& + & 7.793500E-03,1.818500E-02,5.178800E-02,1.994500E-01,5.835800E-01,& + & 8.401600E-01,1.174000E+00,2.008000E+00,3.833300E+00,7.662800E+00,& + & 1.029800E+01,1.930900E-04,3.680200E-04,6.893000E-04,1.158600E-03,& + & 2.197000E-03,4.007100E-03,9.308400E-03,3.050700E-02,1.592900E-01,& + & 5.487600E-01,8.624700E-01,1.338800E+00,2.298200E+00,4.394900E+00,& + & 8.817800E+00,1.187000E+01,5.216800E-06,2.200700E-05,1.175800E-04,& + & 5.773900E-04,3.403600E-03,1.138200E-02,2.865300E-02,8.323900E-02,& + & 3.745900E-01,1.104800E+00,1.506100E+00,2.112200E+00,3.936000E+00,& + & 7.140600E+00,9.101800E+00,9.445400E+00,1.099000E-04,3.065700E-04,& + & 7.663500E-04,2.334900E-03,6.257200E-03,1.488300E-02,3.532100E-02,& + & 9.408900E-02,3.749500E-01,1.015000E+00,1.355500E+00,1.866900E+00,& + & 3.444000E+00,6.248000E+00,7.964300E+00,8.265000E+00,1.787900E-04,& + & 4.669200E-04,1.142800E-03,3.069800E-03,7.024700E-03,1.534000E-02,& + & 3.678000E-02,9.731200E-02,3.793700E-01,9.749300E-01,1.270400E+00,& + & 1.804000E+00,3.159800E+00,5.356100E+00,6.826800E+00,7.084700E+00/ + data absa(:,301:320) / & + & 2.348800E-04,5.998300E-04,1.443100E-03,3.447000E-03,7.318200E-03,& + & 1.507700E-02,3.628700E-02,9.700000E-02,3.746500E-01,9.055500E-01,& + & 1.200900E+00,1.804900E+00,3.037200E+00,4.793600E+00,5.733100E+00,& + & 5.904700E+00,2.858500E-04,7.132200E-04,1.672300E-03,3.579000E-03,& + & 7.122000E-03,1.457200E-02,3.443400E-02,9.388500E-02,3.591500E-01,& + & 8.526100E-01,1.141800E+00,1.818800E+00,2.874700E+00,4.229000E+00,& + & 5.749800E+00,7.653700E+00,3.313800E-04,8.091300E-04,1.835900E-03,& + & 3.533100E-03,6.659500E-03,1.361300E-02,3.153500E-02,8.807600E-02,& + & 3.323500E-01,7.949600E-01,1.146900E+00,1.757000E+00,2.733400E+00,& + & 3.729600E+00,7.085400E+00,9.558400E+00,3.703800E-04,8.789800E-04,& + & 1.855500E-03,3.305400E-03,5.947000E-03,1.212400E-02,2.770500E-02,& + & 7.904200E-02,2.947100E-01,7.749500E-01,1.130200E+00,1.650100E+00,& + & 2.381400E+00,4.186700E+00,8.490000E+00,1.144800E+01,4.002900E-04,& + & 9.139800E-04,1.621400E-03,2.780500E-03,4.890500E-03,9.724200E-03,& + & 2.290000E-02,6.504700E-02,2.510800E-01,7.295400E-01,1.028300E+00,& + & 1.486100E+00,2.557900E+00,4.872000E+00,9.865900E+00,1.328100E+01,& + & 2.284100E-04,4.535800E-04,8.450300E-04,1.445800E-03,2.708900E-03,& + & 4.923800E-03,1.184800E-02,3.638200E-02,2.037000E-01,6.932800E-01,& + & 1.068700E+00,1.698900E+00,2.925400E+00,5.589000E+00,1.134700E+01,& + & 1.530700E+01,7.187900E-06,3.237700E-05,1.771900E-04,8.520800E-04,& + & 4.546100E-03,1.437100E-02,3.576500E-02,1.022100E-01,4.565300E-01,& + & 1.338600E+00,1.855100E+00,2.625000E+00,4.801000E+00,8.406700E+00,& + & 1.055800E+01,1.094200E+01,1.389100E-04,4.036300E-04,1.017600E-03,& + & 3.038300E-03,7.933100E-03,1.872300E-02,4.343000E-02,1.156100E-01,& + & 4.585700E-01,1.229500E+00,1.673600E+00,2.326500E+00,4.200900E+00,& + & 7.355900E+00,9.237800E+00,9.573100E+00,2.227500E-04,6.072800E-04,& + & 1.489200E-03,3.900200E-03,8.863700E-03,1.915400E-02,4.510000E-02,& + & 1.199200E-01,4.634600E-01,1.195000E+00,1.579100E+00,2.228900E+00,& + & 3.876400E+00,6.305000E+00,7.918300E+00,8.205200E+00,2.911400E-04,& + & 7.748100E-04,1.852900E-03,4.334700E-03,9.132600E-03,1.891000E-02,& + & 4.443500E-02,1.195400E-01,4.578100E-01,1.115100E+00,1.485000E+00,& + & 2.267300E+00,3.652600E+00,5.695300E+00,6.755300E+00,7.198500E+00,& + & 3.506800E-04,9.113900E-04,2.128400E-03,4.500400E-03,8.910200E-03,& + & 1.819300E-02,4.224500E-02,1.157200E-01,4.388700E-01,1.054300E+00,& + & 1.417500E+00,2.245600E+00,3.506500E+00,4.931900E+00,7.187800E+00,& + & 9.591500E+00,4.029800E-04,1.023800E-03,2.307400E-03,4.441500E-03,& + & 8.327500E-03,1.685400E-02,3.883400E-02,1.084500E-01,4.074800E-01,& + & 9.806400E-01,1.422500E+00,2.142600E+00,3.307800E+00,4.498100E+00,& + & 8.893300E+00,1.197800E+01,4.492900E-04,1.098800E-03,2.319200E-03,& + & 4.123600E-03,7.412000E-03,1.491700E-02,3.425300E-02,9.727800E-02,& + & 3.626800E-01,9.559100E-01,1.380400E+00,2.004000E+00,2.882400E+00,& + & 5.205300E+00,1.065800E+01,1.434400E+01,4.775800E-04,1.124400E-03,& + & 2.027700E-03,3.478800E-03,6.098900E-03,1.193900E-02,2.826000E-02,& + & 8.012600E-02,3.097600E-01,8.948400E-01,1.233300E+00,1.837300E+00,& + & 3.162500E+00,6.055100E+00,1.238500E+01,1.663400E+01,2.733300E-04,& + & 5.428300E-04,1.026900E-03,1.782500E-03,3.277800E-03,6.031700E-03,& + & 1.468800E-02,4.542600E-02,2.519500E-01,8.540400E-01,1.309800E+00,& + & 2.099700E+00,3.615600E+00,6.947800E+00,1.423800E+01,1.918300E+01,& + & 4.889500E-06,1.364600E-05,5.001600E-05,2.503500E-04,2.044900E-03,& + & 8.700100E-03,2.174700E-02,6.930600E-02,3.321900E-01,1.088100E+00,& + & 1.475100E+00,1.982700E+00,3.465600E+00,7.279300E+00,1.000900E+01,& + & 1.053300E+01,4.664200E-05,1.171800E-04,3.035000E-04,9.808900E-04,& + & 3.705300E-03,9.774700E-03,2.445400E-02,6.949400E-02,3.046700E-01,& + & 9.522500E-01,1.290700E+00,1.734900E+00,3.032400E+00,6.369500E+00,& + & 8.757100E+00,9.214600E+00,7.335300E-05,1.773900E-04,4.313000E-04,& + & 1.302600E-03,4.086000E-03,9.507100E-03,2.429200E-02,6.760000E-02,& + & 2.861800E-01,8.569900E-01,1.141300E+00,1.498100E+00,2.599300E+00,& + & 5.459300E+00,7.506100E+00,7.898300E+00,9.823000E-05,2.232700E-04,& + & 5.411700E-04,1.517300E-03,4.149900E-03,8.937900E-03,2.308000E-02,& + & 6.326700E-02,2.672100E-01,7.404300E-01,9.978800E-01,1.337100E+00,& + & 2.253600E+00,4.549600E+00,6.254700E+00,6.581400E+00,1.218600E-04,& + & 2.576800E-04,6.274000E-04,1.635700E-03,3.992200E-03,8.222700E-03,& + & 2.111100E-02,5.732200E-02,2.460100E-01,6.371900E-01,8.376500E-01,& + & 1.145300E+00,2.076800E+00,3.666800E+00,5.004200E+00,5.266100E+00/ + data absa(:,321:340) / & + & 1.404000E-04,2.922700E-04,6.860300E-04,1.653500E-03,3.622700E-03,& + & 7.296200E-03,1.854300E-02,5.009100E-02,2.181100E-01,5.469900E-01,& + & 7.031200E-01,9.660200E-01,1.832300E+00,3.073900E+00,3.799300E+00,& + & 3.949300E+00,1.547200E-04,3.216800E-04,7.153100E-04,1.538600E-03,& + & 3.042100E-03,6.186800E-03,1.530000E-02,4.174100E-02,1.814500E-01,& + & 4.436600E-01,5.843700E-01,8.730900E-01,1.479400E+00,2.381200E+00,& + & 3.611200E+00,4.531500E+00,1.715800E-04,3.394500E-04,6.720600E-04,& + & 1.261300E-03,2.228200E-03,4.795300E-03,1.105400E-02,3.143300E-02,& + & 1.326900E-01,3.372200E-01,5.121200E-01,7.725400E-01,1.110000E+00,& + & 1.885000E+00,4.205200E+00,5.273700E+00,1.211600E-04,2.043500E-04,& + & 3.453400E-04,5.481200E-04,1.095400E-03,2.079400E-03,4.855800E-03,& + & 1.205300E-02,6.640100E-02,2.536500E-01,4.084800E-01,6.657100E-01,& + & 1.071900E+00,2.141400E+00,4.819400E+00,6.049700E+00,5.403200E-06,& + & 1.779700E-05,7.630500E-05,3.998300E-04,3.026000E-03,1.161800E-02,& + & 3.038900E-02,9.135700E-02,4.495000E-01,1.472900E+00,2.011000E+00,& + & 2.715100E+00,4.795300E+00,9.714800E+00,1.308900E+01,1.375000E+01,& + & 6.047900E-05,1.598200E-04,4.211000E-04,1.407400E-03,5.123200E-03,& + & 1.317800E-02,3.332700E-02,9.223700E-02,4.137400E-01,1.289200E+00,& + & 1.759700E+00,2.375800E+00,4.196000E+00,8.500400E+00,1.145400E+01,& + & 1.203200E+01,9.519100E-05,2.416000E-04,6.020200E-04,1.843100E-03,& + & 5.562500E-03,1.295800E-02,3.292600E-02,8.933500E-02,3.899900E-01,& + & 1.160300E+00,1.559500E+00,2.050700E+00,3.596400E+00,7.285800E+00,& + & 9.817100E+00,1.031300E+01,1.260600E-04,3.035100E-04,7.526200E-04,& + & 2.118300E-03,5.587300E-03,1.224500E-02,3.113400E-02,8.385700E-02,& + & 3.646100E-01,1.005700E+00,1.360300E+00,1.831300E+00,3.119500E+00,& + & 6.071900E+00,8.181100E+00,8.593400E+00,1.526000E-04,3.544100E-04,& + & 8.696700E-04,2.269500E-03,5.332100E-03,1.118000E-02,2.853300E-02,& + & 7.644400E-02,3.338800E-01,8.773500E-01,1.153900E+00,1.569100E+00,& + & 2.855800E+00,4.906700E+00,6.545100E+00,6.874500E+00,1.777400E-04,& + & 3.964400E-04,9.499800E-04,2.261000E-03,4.845800E-03,9.875900E-03,& + & 2.500300E-02,6.745100E-02,2.949000E-01,7.462400E-01,9.729100E-01,& + & 1.355100E+00,2.496000E+00,4.105000E+00,5.006400E+00,5.484600E+00,& + & 1.964100E-04,4.303500E-04,9.853900E-04,2.089200E-03,4.070300E-03,& + & 8.495900E-03,2.040200E-02,5.647400E-02,2.450800E-01,6.068500E-01,& + & 7.969800E-01,1.232500E+00,2.023400E+00,3.150400E+00,4.905900E+00,& + & 6.576300E+00,2.096500E-04,4.454700E-04,9.268200E-04,1.696600E-03,& + & 3.031900E-03,6.468900E-03,1.472400E-02,4.265900E-02,1.793500E-01,& + & 4.583900E-01,7.011000E-01,1.053700E+00,1.526400E+00,2.596000E+00,& + & 5.712900E+00,7.613900E+00,1.426400E-04,2.602700E-04,4.461500E-04,& + & 7.048700E-04,1.421800E-03,2.679800E-03,6.178800E-03,1.612700E-02,& + & 9.002600E-02,3.496800E-01,5.525900E-01,8.996600E-01,1.515100E+00,& + & 2.969800E+00,6.548100E+00,8.778700E+00,6.599700E-06,2.472600E-05,& + & 1.191100E-04,6.252400E-04,4.349900E-03,1.535100E-02,4.029000E-02,& + & 1.180100E-01,5.871700E-01,1.919300E+00,2.628600E+00,3.599700E+00,& + & 6.411900E+00,1.240800E+01,1.638700E+01,1.717500E+01,7.877200E-05,& + & 2.181600E-04,5.830400E-04,1.988300E-03,6.868500E-03,1.766500E-02,& + & 4.350500E-02,1.195500E-01,5.416600E-01,1.681600E+00,2.300100E+00,& + & 3.149900E+00,5.610600E+00,1.085800E+01,1.433900E+01,1.502900E+01,& + & 1.235300E-04,3.265000E-04,8.220900E-04,2.553500E-03,7.348400E-03,& + & 1.731900E-02,4.295000E-02,1.158800E-01,5.110000E-01,1.515600E+00,& + & 2.038500E+00,2.729100E+00,4.809100E+00,9.305800E+00,1.229000E+01,& + & 1.288100E+01,1.621200E-04,4.089300E-04,1.021300E-03,2.897100E-03,& + & 7.318300E-03,1.626700E-02,4.067600E-02,1.090800E-01,4.773600E-01,& + & 1.326500E+00,1.778500E+00,2.437300E+00,4.163700E+00,7.754900E+00,& + & 1.024200E+01,1.073500E+01,1.942700E-04,4.747900E-04,1.173800E-03,& + & 3.059900E-03,6.956500E-03,1.483800E-02,3.719100E-02,9.988100E-02,& + & 4.357900E-01,1.153400E+00,1.536200E+00,2.103400E+00,3.765800E+00,& + & 6.300800E+00,8.194100E+00,8.588300E+00,2.231300E-04,5.278400E-04,& + & 1.277400E-03,3.025900E-03,6.308600E-03,1.318800E-02,3.242200E-02,& + & 8.824300E-02,3.846100E-01,9.774100E-01,1.288900E+00,1.859300E+00,& + & 3.252900E+00,5.258600E+00,6.351700E+00,7.563400E+00,2.463600E-04,& + & 5.699000E-04,1.319100E-03,2.753400E-03,5.380500E-03,1.116700E-02,& + & 2.642700E-02,7.414600E-02,3.192500E-01,7.995100E-01,1.059000E+00,& + & 1.657900E+00,2.677700E+00,3.982000E+00,6.506600E+00,9.069200E+00/ + data absa(:,341:360) / & + & 2.598600E-04,5.841400E-04,1.230700E-03,2.212800E-03,3.999100E-03,& + & 8.442500E-03,1.911100E-02,5.616500E-02,2.335800E-01,6.080900E-01,& + & 9.225000E-01,1.377300E+00,1.992100E+00,3.486500E+00,7.577800E+00,& + & 1.055500E+01,1.718800E-04,3.234200E-04,5.594800E-04,8.934700E-04,& + & 1.782700E-03,3.411300E-03,7.679900E-03,2.160000E-02,1.183300E-01,& + & 4.527500E-01,7.227500E-01,1.178900E+00,2.030600E+00,3.988600E+00,& + & 8.684000E+00,1.210700E+01,8.654800E-06,3.573900E-05,1.864900E-04,& + & 9.647500E-04,6.098800E-03,2.009200E-02,5.207200E-02,1.495000E-01,& + & 7.440600E-01,2.419600E+00,3.335000E+00,4.666500E+00,8.253200E+00,& + & 1.530100E+01,1.980900E+01,2.070700E+01,1.020500E-04,2.971900E-04,& + & 7.992300E-04,2.748900E-03,9.004800E-03,2.291100E-02,5.580900E-02,& + & 1.519700E-01,6.877800E-01,2.122000E+00,2.918200E+00,4.083200E+00,& + & 7.221100E+00,1.338800E+01,1.733300E+01,1.812000E+01,1.590300E-04,& + & 4.396700E-04,1.110200E-03,3.472500E-03,9.472800E-03,2.243100E-02,& + & 5.489500E-02,1.474900E-01,6.499600E-01,1.909700E+00,2.585000E+00,& + & 3.551900E+00,6.189800E+00,1.147600E+01,1.485600E+01,1.553200E+01,& + & 2.072000E-04,5.445900E-04,1.360200E-03,3.885600E-03,9.379800E-03,& + & 2.118100E-02,5.171400E-02,1.389400E-01,6.062200E-01,1.694200E+00,& + & 2.261700E+00,3.154400E+00,5.368800E+00,9.563200E+00,1.238100E+01,& + & 1.294400E+01,2.458100E-04,6.296100E-04,1.553000E-03,4.035500E-03,& + & 8.948700E-03,1.939300E-02,4.697800E-02,1.273600E-01,5.524100E-01,& + & 1.469300E+00,1.978000E+00,2.746800E+00,4.794800E+00,7.836400E+00,& + & 9.904700E+00,1.035600E+01,2.775900E-04,6.943500E-04,1.680500E-03,& + & 3.935700E-03,8.166900E-03,1.711900E-02,4.090700E-02,1.127100E-01,& + & 4.872800E-01,1.243900E+00,1.658000E+00,2.461700E+00,4.102500E+00,& + & 6.469600E+00,7.956900E+00,9.976600E+00,3.031400E-04,7.401600E-04,& + & 1.728800E-03,3.548400E-03,6.916200E-03,1.436900E-02,3.341100E-02,& + & 9.495300E-02,4.041900E-01,1.019400E+00,1.375800E+00,2.138800E+00,& + & 3.445800E+00,4.860100E+00,8.418900E+00,1.196300E+01,3.203700E-04,& + & 7.470300E-04,1.593200E-03,2.845000E-03,5.172700E-03,1.069500E-02,& + & 2.436200E-02,7.188000E-02,2.965700E-01,7.813900E-01,1.172900E+00,& + & 1.746400E+00,2.506200E+00,4.551300E+00,9.805200E+00,1.392100E+01,& + & 2.020300E-04,3.950800E-04,6.895100E-04,1.114100E-03,2.209000E-03,& + & 4.256700E-03,9.320800E-03,2.797200E-02,1.518900E-01,5.753600E-01,& + & 9.153200E-01,1.507900E+00,2.614300E+00,5.208100E+00,1.123500E+01,& + & 1.597000E+01,1.179200E-05,5.299300E-05,2.866400E-04,1.449200E-03,& + & 8.230100E-03,2.562500E-02,6.616000E-02,1.864600E-01,9.190700E-01,& + & 2.966200E+00,4.134600E+00,5.866900E+00,1.028300E+01,1.831900E+01,& + & 2.331000E+01,2.432000E+01,1.316800E-04,4.033300E-04,1.089100E-03,& + & 3.723400E-03,1.159200E-02,2.913600E-02,7.025800E-02,1.894200E-01,& + & 8.512500E-01,2.606400E+00,3.618100E+00,5.133500E+00,8.997100E+00,& + & 1.602900E+01,2.039600E+01,2.128200E+01,2.023600E-04,5.850000E-04,& + & 1.489400E-03,4.602300E-03,1.205800E-02,2.864000E-02,6.865400E-02,& + & 1.839200E-01,8.056900E-01,2.339000E+00,3.210600E+00,4.479200E+00,& + & 7.711800E+00,1.374000E+01,1.748200E+01,1.823800E+01,2.606600E-04,& + & 7.184500E-04,1.795600E-03,5.076100E-03,1.193600E-02,2.698000E-02,& + & 6.432000E-02,1.734600E-01,7.501200E-01,2.096600E+00,2.826400E+00,& + & 3.955900E+00,6.708700E+00,1.144900E+01,1.456900E+01,1.520000E+01,& + & 3.075900E-04,8.250500E-04,2.023800E-03,5.189800E-03,1.138600E-02,& + & 2.461200E-02,5.824000E-02,1.592400E-01,6.836900E-01,1.812200E+00,& + & 2.483500E+00,3.481700E+00,5.916300E+00,9.479800E+00,1.165400E+01,& + & 1.216100E+01,3.449700E-04,9.010800E-04,2.179500E-03,5.004100E-03,& + & 1.034500E-02,2.170300E-02,5.066700E-02,1.411300E-01,6.018500E-01,& + & 1.551700E+00,2.071400E+00,3.124100E+00,5.063000E+00,7.715000E+00,& + & 9.799800E+00,1.272300E+01,3.738900E-04,9.466500E-04,2.214400E-03,& + & 4.496200E-03,8.706900E-03,1.820200E-02,4.156100E-02,1.185600E-01,& + & 4.999500E-01,1.269800E+00,1.738500E+00,2.664900E+00,4.287700E+00,& + & 5.821500E+00,1.061300E+01,1.525400E+01,3.896800E-04,9.458700E-04,& + & 2.010500E-03,3.608200E-03,6.541500E-03,1.331000E-02,3.053100E-02,& + & 8.958000E-02,3.683200E-01,9.817500E-01,1.446800E+00,2.162900E+00,& + & 3.059700E+00,5.787700E+00,1.236200E+01,1.775200E+01,2.400800E-04,& + & 4.728000E-04,8.326200E-04,1.387600E-03,2.687900E-03,5.210100E-03,& + & 1.109700E-02,3.556600E-02,1.910100E-01,7.142000E-01,1.143000E+00,& + & 1.873200E+00,3.270200E+00,6.622600E+00,1.416200E+01,2.036400E+01/ + data absa(:,361:380) / & + & 1.768600E-05,4.525000E-05,1.529300E-04,7.771700E-04,6.434100E-03,& + & 2.841100E-02,6.987900E-02,2.209600E-01,1.148500E+00,4.069300E+00,& + & 5.768100E+00,8.038700E+00,1.303900E+01,2.709300E+01,3.813000E+01,& + & 4.036300E+01,6.292500E-05,1.468600E-04,4.671100E-04,1.607600E-03,& + & 8.493200E-03,2.780500E-02,6.638600E-02,1.993100E-01,1.008900E+00,& + & 3.560900E+00,5.046800E+00,7.034000E+00,1.140900E+01,2.370600E+01,& + & 3.336200E+01,3.531800E+01,8.519800E-05,2.023000E-04,5.942900E-04,& + & 1.932700E-03,8.631900E-03,2.543600E-02,6.141600E-02,1.812600E-01,& + & 8.788000E-01,3.052100E+00,4.326000E+00,6.029300E+00,9.778600E+00,& + & 2.032100E+01,2.859600E+01,3.027300E+01,1.021300E-04,2.482800E-04,& + & 6.714300E-04,2.095000E-03,8.310800E-03,2.267700E-02,5.486200E-02,& + & 1.610600E-01,7.576200E-01,2.547000E+00,3.605000E+00,5.024500E+00,& + & 8.148600E+00,1.693400E+01,2.383000E+01,2.522700E+01,1.154300E-04,& + & 2.803600E-04,7.027000E-04,2.172700E-03,7.701800E-03,1.951600E-02,& + & 4.728300E-02,1.383400E-01,6.362200E-01,2.094600E+00,2.910900E+00,& + & 4.019600E+00,6.519200E+00,1.354700E+01,1.906500E+01,2.018100E+01,& + & 1.278000E-04,2.980100E-04,7.257800E-04,2.150700E-03,6.776300E-03,& + & 1.586700E-02,3.911200E-02,1.128300E-01,5.137700E-01,1.623100E+00,& + & 2.267300E+00,3.095700E+00,4.900000E+00,1.016100E+01,1.429800E+01,& + & 1.513400E+01,1.399400E-04,2.992100E-04,7.203100E-04,2.023900E-03,& + & 5.511500E-03,1.195800E-02,2.984600E-02,8.479000E-02,3.906800E-01,& + & 1.134200E+00,1.577600E+00,2.177300E+00,3.552600E+00,6.773500E+00,& + & 9.532200E+00,1.009000E+01,1.416400E-04,2.881500E-04,6.702300E-04,& + & 1.661900E-03,3.776700E-03,7.596900E-03,1.902600E-02,5.346500E-02,& + & 2.532300E-01,6.934100E-01,9.130200E-01,1.235700E+00,2.208300E+00,& + & 3.894700E+00,4.925400E+00,5.421200E+00,1.030600E-04,2.457700E-04,& + & 4.685700E-04,6.528300E-04,9.547500E-04,2.061200E-03,5.028100E-03,& + & 1.312400E-02,5.405700E-02,2.325400E-01,3.385600E-01,4.205000E-01,& + & 6.124900E-01,1.790400E+00,4.521000E+00,6.199600E+00,1.862900E-05,& + & 5.659200E-05,2.274300E-04,1.225700E-03,9.675900E-03,3.881400E-02,& + & 9.707200E-02,3.011100E-01,1.591900E+00,5.652500E+00,8.051900E+00,& + & 1.128000E+01,1.819000E+01,3.735600E+01,5.135000E+01,5.423100E+01,& + & 7.914500E-05,2.011000E-04,6.543500E-04,2.421600E-03,1.221300E-02,& + & 3.790800E-02,9.219900E-02,2.726900E-01,1.398300E+00,4.945900E+00,& + & 7.046300E+00,9.870500E+00,1.591600E+01,3.268700E+01,4.493300E+01,& + & 4.744400E+01,1.083900E-04,2.818100E-04,8.326000E-04,2.820500E-03,& + & 1.226600E-02,3.486700E-02,8.554000E-02,2.473100E-01,1.219300E+00,& + & 4.239600E+00,6.039500E+00,8.460100E+00,1.364300E+01,2.801700E+01,& + & 3.851400E+01,4.066700E+01,1.317700E-04,3.440500E-04,9.222100E-04,& + & 3.070600E-03,1.172500E-02,3.094800E-02,7.685500E-02,2.182800E-01,& + & 1.053900E+00,3.536700E+00,5.033100E+00,7.050100E+00,1.136900E+01,& + & 2.334700E+01,3.209400E+01,3.389600E+01,1.500200E-04,3.816700E-04,& + & 9.847600E-04,3.155800E-03,1.074100E-02,2.664100E-02,6.649200E-02,& + & 1.861600E-01,8.875900E-01,2.914300E+00,4.058600E+00,5.640200E+00,& + & 9.095300E+00,1.867900E+01,2.567700E+01,2.711400E+01,1.648100E-04,& + & 4.086300E-04,1.020400E-03,3.089300E-03,9.385500E-03,2.166800E-02,& + & 5.470700E-02,1.520200E-01,7.182700E-01,2.253300E+00,3.176200E+00,& + & 4.333400E+00,6.833100E+00,1.400800E+01,1.925800E+01,2.033600E+01,& + & 1.757800E-04,4.151400E-04,1.023500E-03,2.863900E-03,7.565400E-03,& + & 1.634500E-02,4.154900E-02,1.145700E-01,5.460300E-01,1.586700E+00,& + & 2.207300E+00,3.049200E+00,4.954400E+00,9.339300E+00,1.283800E+01,& + & 1.355700E+01,1.833100E-04,3.911500E-04,9.495500E-04,2.321500E-03,& + & 5.151700E-03,1.042900E-02,2.636600E-02,7.243400E-02,3.523600E-01,& + & 9.656700E-01,1.296800E+00,1.746700E+00,3.091700E+00,5.367200E+00,& + & 6.624200E+00,7.487600E+00,1.369200E-04,3.244100E-04,5.670800E-04,& + & 8.132600E-04,1.193300E-03,2.590300E-03,6.374900E-03,1.689000E-02,& + & 7.356700E-02,2.970600E-01,3.970500E-01,4.683700E-01,1.317400E+00,& + & 2.556300E+00,6.322500E+00,8.563800E+00,2.165500E-05,7.701700E-05,& + & 3.560100E-04,1.925800E-03,1.427400E-02,5.153700E-02,1.327400E-01,& + & 3.954700E-01,2.120200E+00,7.533600E+00,1.074000E+01,1.520200E+01,& + & 2.471700E+01,4.901000E+01,6.586500E+01,6.937500E+01,1.025900E-04,& + & 2.802700E-04,9.485500E-04,3.578800E-03,1.711600E-02,5.034700E-02,& + & 1.263900E-01,3.581100E-01,1.862900E+00,6.592100E+00,9.397100E+00,& + & 1.330200E+01,2.162800E+01,4.288300E+01,5.763300E+01,6.070600E+01/ + data absa(:,381:400) / & + & 1.404700E-04,3.931600E-04,1.160200E-03,4.133100E-03,1.697000E-02,& + & 4.626200E-02,1.167000E-01,3.238000E-01,1.628200E+00,5.650200E+00,& + & 8.054900E+00,1.140100E+01,1.853800E+01,3.675700E+01,4.939800E+01,& + & 5.203000E+01,1.713900E-04,4.718700E-04,1.287500E-03,4.412100E-03,& + & 1.603000E-02,4.114400E-02,1.041200E-01,2.863600E-01,1.408400E+00,& + & 4.719700E+00,6.712900E+00,9.500800E+00,1.544900E+01,3.063000E+01,& + & 4.116700E+01,4.336300E+01,1.962400E-04,5.192500E-04,1.364000E-03,& + & 4.482500E-03,1.454500E-02,3.532400E-02,8.957600E-02,2.446500E-01,& + & 1.187500E+00,3.891500E+00,5.419000E+00,7.600900E+00,1.235900E+01,& + & 2.450500E+01,3.293100E+01,3.469300E+01,2.145100E-04,5.566900E-04,& + & 1.406700E-03,4.345600E-03,1.262400E-02,2.892400E-02,7.340000E-02,& + & 1.996800E-01,9.628300E-01,3.003000E+00,4.235500E+00,5.844600E+00,& + & 9.299600E+00,1.837900E+01,2.470100E+01,2.601900E+01,2.269800E-04,& + & 5.630800E-04,1.407000E-03,3.975100E-03,1.009200E-02,2.192300E-02,& + & 5.554800E-02,1.507500E-01,7.299200E-01,2.142000E+00,2.953100E+00,& + & 4.103300E+00,6.741400E+00,1.225700E+01,1.646500E+01,1.734600E+01,& + & 2.286300E-04,5.317700E-04,1.303200E-03,3.154600E-03,6.827300E-03,& + & 1.406400E-02,3.501700E-02,9.631900E-02,4.691100E-01,1.286200E+00,& + & 1.752100E+00,2.407200E+00,4.157800E+00,7.040000E+00,8.540600E+00,& + & 1.064200E+01,1.735000E-04,4.100300E-04,6.471400E-04,1.007200E-03,& + & 1.495600E-03,3.211600E-03,7.928300E-03,2.103000E-02,9.726900E-02,& + & 3.640200E-01,4.043700E-01,9.006700E-01,1.784100E+00,3.534700E+00,& + & 8.471100E+00,1.216900E+01,2.746100E-05,1.102500E-04,5.591100E-04,& + & 3.005800E-03,2.034800E-02,6.690900E-02,1.772500E-01,5.062200E-01,& + & 2.735400E+00,9.669600E+00,1.384000E+01,1.980400E+01,3.257300E+01,& + & 6.173500E+01,8.119400E+01,8.536400E+01,1.357500E-04,3.947100E-04,& + & 1.360600E-03,5.181600E-03,2.345600E-02,6.523400E-02,1.672600E-01,& + & 4.600800E-01,2.405000E+00,8.460800E+00,1.211000E+01,1.732800E+01,& + & 2.850300E+01,5.401800E+01,7.104100E+01,7.469400E+01,1.840900E-04,& + & 5.461200E-04,1.627200E-03,5.892600E-03,2.292500E-02,6.036400E-02,& + & 1.527600E-01,4.170100E-01,2.103800E+00,7.252600E+00,1.038000E+01,& + & 1.485300E+01,2.443200E+01,4.630000E+01,6.089100E+01,6.400300E+01,& + & 2.236600E-04,6.482400E-04,1.778200E-03,6.213300E-03,2.141500E-02,& + & 5.394300E-02,1.360600E-01,3.680600E-01,1.821400E+00,6.067500E+00,& + & 8.650200E+00,1.237700E+01,2.035900E+01,3.858300E+01,5.073800E+01,& + & 5.334900E+01,2.548400E-04,7.105500E-04,1.867100E-03,6.251300E-03,& + & 1.926000E-02,4.644300E-02,1.166800E-01,3.147700E-01,1.536600E+00,& + & 4.988600E+00,7.007700E+00,9.904000E+00,1.628800E+01,3.086800E+01,& + & 4.059100E+01,4.267500E+01,2.781500E-04,7.524500E-04,1.915900E-03,& + & 5.994300E-03,1.650200E-02,3.812400E-02,9.538500E-02,2.574000E-01,& + & 1.247100E+00,3.855800E+00,5.454900E+00,7.631900E+00,1.226700E+01,& + & 2.315000E+01,3.044900E+01,3.200700E+01,2.915200E-04,7.555700E-04,& + & 1.889900E-03,5.416000E-03,1.309800E-02,2.894700E-02,7.189500E-02,& + & 1.950400E-01,9.417700E-01,2.777900E+00,3.835400E+00,5.358900E+00,& + & 8.860600E+00,1.545800E+01,2.029700E+01,2.133800E+01,2.871900E-04,& + & 7.071400E-04,1.737400E-03,4.173500E-03,8.859700E-03,1.854900E-02,& + & 4.501700E-02,1.251700E-01,6.039100E-01,1.661800E+00,2.270400E+00,& + & 3.220600E+00,5.401100E+00,8.807100E+00,1.090200E+01,1.437900E+01,& + & 2.142500E-04,5.054700E-04,7.385800E-04,1.213300E-03,1.891300E-03,& + & 3.862300E-03,9.770000E-03,2.556700E-02,1.233800E-01,4.096100E-01,& + & 5.438500E-01,1.327700E+00,2.324100E+00,4.739300E+00,1.105000E+01,& + & 1.644400E+01,3.672700E-05,1.637700E-04,8.708100E-04,4.586000E-03,& + & 2.794700E-02,8.607800E-02,2.290000E-01,6.397000E-01,3.431700E+00,& + & 1.205900E+01,1.729100E+01,2.509100E+01,4.156200E+01,7.528400E+01,& + & 9.697600E+01,1.017300E+02,1.818900E-04,5.526600E-04,1.935600E-03,& + & 7.356100E-03,3.139200E-02,8.401800E-02,2.146900E-01,5.828200E-01,& + & 3.017600E+00,1.055200E+01,1.512900E+01,2.195500E+01,3.636800E+01,& + & 6.587300E+01,8.485100E+01,8.901100E+01,2.425800E-04,7.526000E-04,& + & 2.266900E-03,8.169400E-03,3.035000E-02,7.784300E-02,1.956200E-01,& + & 5.275300E-01,2.642100E+00,9.044700E+00,1.296900E+01,1.881900E+01,& + & 3.117300E+01,5.646300E+01,7.273400E+01,7.629400E+01,2.902200E-04,& + & 8.846300E-04,2.442900E-03,8.531500E-03,2.804200E-02,6.950600E-02,& + & 1.734600E-01,4.658900E-01,2.287700E+00,7.585800E+00,1.080800E+01,& + & 1.568300E+01,2.597700E+01,4.705200E+01,6.060900E+01,6.357800E+01/ + data absa(:,401:420) / & + & 3.292100E-04,9.621700E-04,2.549800E-03,8.500900E-03,2.492000E-02,& + & 5.985300E-02,1.489200E-01,3.982100E-01,1.931000E+00,6.213600E+00,& + & 8.791300E+00,1.255400E+01,2.078100E+01,3.764000E+01,4.848500E+01,& + & 5.085800E+01,3.561700E-04,1.008400E-03,2.583400E-03,8.069600E-03,& + & 2.117100E-02,4.915900E-02,1.212600E-01,3.259400E-01,1.567700E+00,& + & 4.823300E+00,6.811800E+00,9.697000E+00,1.567800E+01,2.823300E+01,& + & 3.636600E+01,3.814700E+01,3.698300E-04,1.001000E-03,2.515000E-03,& + & 7.159700E-03,1.672000E-02,3.714600E-02,9.101500E-02,2.474400E-01,& + & 1.181400E+00,3.479900E+00,4.859400E+00,6.819000E+00,1.126100E+01,& + & 1.888900E+01,2.424400E+01,2.543100E+01,3.585000E-04,9.283100E-04,& + & 2.276300E-03,5.391400E-03,1.127500E-02,2.397700E-02,5.662100E-02,& + & 1.589200E-01,7.563500E-01,2.091500E+00,2.864300E+00,4.141200E+00,& + & 6.830100E+00,1.065400E+01,1.360900E+01,1.871500E+01,2.586600E-04,& + & 5.999200E-04,8.713900E-04,1.452400E-03,2.315900E-03,4.609500E-03,& + & 1.185100E-02,3.070700E-02,1.535300E-01,3.753100E-01,9.384400E-01,& + & 1.657000E+00,2.954100E+00,6.163500E+00,1.402200E+01,2.140600E+01,& + & 7.266300E-05,1.740800E-04,5.502500E-04,2.763200E-03,2.321800E-02,& + & 1.047900E-01,2.611000E-01,7.960900E-01,4.443600E+00,1.708800E+01,& + & 2.528100E+01,3.685300E+01,5.795100E+01,1.150100E+02,1.649500E+02,& + & 1.751800E+02,1.280500E-04,2.870900E-04,9.163800E-04,3.757800E-03,& + & 2.454700E-02,9.480400E-02,2.319100E-01,6.987700E-01,3.888200E+00,& + & 1.495200E+01,2.212100E+01,3.224700E+01,5.070800E+01,1.006400E+02,& + & 1.443400E+02,1.532600E+02,1.461000E-04,3.252700E-04,1.052400E-03,& + & 3.892900E-03,2.345600E-02,8.415800E-02,2.043100E-01,6.063100E-01,& + & 3.334800E+00,1.281600E+01,1.896100E+01,2.764100E+01,4.346400E+01,& + & 8.626200E+01,1.237100E+02,1.313800E+02,1.552300E-04,3.483500E-04,& + & 1.115100E-03,3.864800E-03,2.145200E-02,7.241900E-02,1.764300E-01,& + & 5.132300E-01,2.788800E+00,1.068100E+01,1.580100E+01,2.303500E+01,& + & 3.622000E+01,7.188300E+01,1.030800E+02,1.094600E+02,1.593100E-04,& + & 3.589400E-04,1.117300E-03,3.715000E-03,1.885500E-02,5.989700E-02,& + & 1.469300E-01,4.217600E-01,2.247700E+00,8.544400E+00,1.264100E+01,& + & 1.842700E+01,2.897600E+01,5.750600E+01,8.247800E+01,8.758900E+01,& + & 1.576800E-04,3.591900E-04,1.067200E-03,3.438600E-03,1.570300E-02,& + & 4.701400E-02,1.154500E-01,3.304000E-01,1.713400E+00,6.408100E+00,& + & 9.480600E+00,1.382000E+01,2.173200E+01,4.313000E+01,6.186200E+01,& + & 6.568400E+01,1.495000E-04,3.526300E-04,9.764900E-04,2.982400E-03,& + & 1.204700E-02,3.351300E-02,8.190800E-02,2.355700E-01,1.187100E+00,& + & 4.316900E+00,6.320700E+00,9.214200E+00,1.448800E+01,2.875500E+01,& + & 4.124000E+01,4.379500E+01,1.359300E-04,3.148400E-04,7.734500E-04,& + & 2.304200E-03,7.788400E-03,1.891500E-02,4.648000E-02,1.334000E-01,& + & 6.578200E-01,2.261200E+00,3.292100E+00,4.701700E+00,7.252000E+00,& + & 1.437800E+01,2.062000E+01,2.189800E+01,1.120700E-04,2.757100E-04,& + & 6.500200E-04,1.159500E-03,1.411500E-03,2.395900E-03,5.544800E-03,& + & 1.836400E-02,7.066300E-02,1.532500E-01,2.822500E-01,5.209600E-01,& + & 5.653800E-01,5.711600E-01,1.630500E+00,6.609600E+00,7.401900E-05,& + & 2.096100E-04,7.912600E-04,4.361800E-03,3.535200E-02,1.459300E-01,& + & 3.630400E-01,1.118500E+00,6.299700E+00,2.426500E+01,3.608900E+01,& + & 5.286600E+01,8.130600E+01,1.632300E+02,2.282800E+02,2.420900E+02,& + & 1.510800E-04,3.681600E-04,1.300200E-03,5.843900E-03,3.647900E-02,& + & 1.321400E-01,3.230500E-01,9.817900E-01,5.512400E+00,2.123200E+01,& + & 3.157700E+01,4.625500E+01,7.114100E+01,1.428300E+02,1.997300E+02,& + & 2.118100E+02,1.762500E-04,4.314300E-04,1.486000E-03,6.023700E-03,& + & 3.447100E-02,1.170500E-01,2.852300E-01,8.516300E-01,4.728800E+00,& + & 1.819900E+01,2.706600E+01,3.964800E+01,6.097900E+01,1.224200E+02,& + & 1.712100E+02,1.815200E+02,1.910300E-04,4.688100E-04,1.559800E-03,& + & 5.917300E-03,3.129900E-02,1.007400E-01,2.461200E-01,7.211100E-01,& + & 3.955900E+00,1.516700E+01,2.255500E+01,3.304000E+01,5.081300E+01,& + & 1.020200E+02,1.426700E+02,1.512700E+02,1.972900E-04,4.965900E-04,& + & 1.544100E-03,5.619800E-03,2.723900E-02,8.354700E-02,2.046800E-01,& + & 5.929200E-01,3.189700E+00,1.213200E+01,1.804400E+01,2.643100E+01,& + & 4.065200E+01,8.161400E+01,1.141400E+02,1.210200E+02,1.981700E-04,& + & 5.014700E-04,1.501500E-03,5.073900E-03,2.266800E-02,6.554200E-02,& + & 1.611700E-01,4.636800E-01,2.433400E+00,9.099600E+00,1.353200E+01,& + & 1.982500E+01,3.048900E+01,6.121300E+01,8.560400E+01,9.077900E+01/ + data absa(:,421:440) / & + & 1.914400E-04,4.927200E-04,1.339900E-03,4.396600E-03,1.731800E-02,& + & 4.677200E-02,1.148900E-01,3.277700E-01,1.691500E+00,6.119400E+00,& + & 9.022600E+00,1.321700E+01,2.032600E+01,4.080700E+01,5.706200E+01,& + & 6.051000E+01,1.740800E-04,4.333900E-04,1.090900E-03,3.384600E-03,& + & 1.099000E-02,2.637500E-02,6.535000E-02,1.849400E-01,9.395400E-01,& + & 3.211500E+00,4.719700E+00,6.722300E+00,1.016300E+01,2.040500E+01,& + & 2.853600E+01,3.025800E+01,1.549900E-04,3.885900E-04,8.349900E-04,& + & 1.331000E-03,1.742800E-03,2.875600E-03,7.003200E-03,2.273100E-02,& + & 8.741800E-02,2.090700E-01,3.937500E-01,8.570500E-01,6.576100E-01,& + & 4.694400E-01,5.339300E+00,8.747700E+00,8.240300E-05,2.777600E-04,& + & 1.223700E-03,6.807600E-03,5.304100E-02,1.967800E-01,5.018500E-01,& + & 1.497700E+00,8.561900E+00,3.285900E+01,4.899700E+01,7.244000E+01,& + & 1.115800E+02,2.195000E+02,2.992500E+02,3.170200E+02,1.886300E-04,& + & 5.019200E-04,1.932100E-03,8.861600E-03,5.329000E-02,1.782500E-01,& + & 4.468800E-01,1.315200E+00,7.492500E+00,2.875200E+01,4.287300E+01,& + & 6.338200E+01,9.762500E+01,1.920600E+02,2.618400E+02,2.773900E+02,& + & 2.241400E-04,5.960300E-04,2.158700E-03,9.086700E-03,4.975300E-02,& + & 1.577300E-01,3.941700E-01,1.142200E+00,6.427900E+00,2.464600E+01,& + & 3.674900E+01,5.432600E+01,8.367900E+01,1.646200E+02,2.244400E+02,& + & 2.377700E+02,2.453600E-04,6.518100E-04,2.252600E-03,8.829700E-03,& + & 4.463400E-02,1.359000E-01,3.390900E-01,9.692700E-01,5.377100E+00,& + & 2.053700E+01,3.062300E+01,4.527200E+01,6.973000E+01,1.371800E+02,& + & 1.870300E+02,1.981000E+02,2.537300E-04,6.935700E-04,2.223500E-03,& + & 8.298000E-03,3.859300E-02,1.127700E-01,2.811700E-01,7.981500E-01,& + & 4.336500E+00,1.643000E+01,2.449800E+01,3.621800E+01,5.578600E+01,& + & 1.097500E+02,1.496300E+02,1.584900E+02,2.554900E-04,7.031200E-04,& + & 2.104000E-03,7.512000E-03,3.183000E-02,8.846200E-02,2.205600E-01,& + & 6.226900E-01,3.313600E+00,1.232300E+01,1.837300E+01,2.716400E+01,& + & 4.183900E+01,8.231100E+01,1.122200E+02,1.188800E+02,2.493900E-04,& + & 6.786400E-04,1.874400E-03,6.436600E-03,2.400400E-02,6.314400E-02,& + & 1.564800E-01,4.405400E-01,2.306000E+00,8.288500E+00,1.224900E+01,& + & 1.810800E+01,2.789300E+01,5.487500E+01,7.481500E+01,7.924900E+01,& + & 2.281100E-04,5.925300E-04,1.523800E-03,4.835700E-03,1.503200E-02,& + & 3.573300E-02,8.903700E-02,2.471900E-01,1.284300E+00,4.352800E+00,& + & 6.413000E+00,9.210300E+00,1.395300E+01,2.743800E+01,3.740800E+01,& + & 3.962300E+01,2.055100E-04,5.146700E-04,1.029800E-03,1.442700E-03,& + & 2.171100E-03,3.471900E-03,8.610500E-03,2.771400E-02,1.043600E-01,& + & 2.809300E-01,6.095000E-01,9.798400E-01,1.053000E+00,1.024500E+00,& + & 8.330800E+00,1.237700E+01,1.009300E-04,3.942400E-04,1.929500E-03,& + & 1.072700E-02,7.681900E-02,2.590100E-01,6.744800E-01,1.958800E+00,& + & 1.121900E+01,4.286900E+01,6.409000E+01,9.532700E+01,1.487700E+02,& + & 2.826400E+02,3.771900E+02,3.979100E+02,2.472300E-04,7.124300E-04,& + & 2.906800E-03,1.324700E-02,7.590500E-02,2.345100E-01,6.003800E-01,& + & 1.720900E+00,9.818000E+00,3.751200E+01,5.607900E+01,8.341400E+01,& + & 1.301800E+02,2.473000E+02,3.300300E+02,3.481700E+02,2.962600E-04,& + & 8.449800E-04,3.193900E-03,1.338600E-02,7.011800E-02,2.078700E-01,& + & 5.281700E-01,1.496300E+00,8.422800E+00,3.215300E+01,4.806800E+01,& + & 7.150100E+01,1.115800E+02,2.119700E+02,2.828700E+02,2.984100E+02,& + & 3.229600E-04,9.247300E-04,3.288400E-03,1.289500E-02,6.238600E-02,& + & 1.793100E-01,4.530500E-01,1.269900E+00,7.048600E+00,2.679500E+01,& + & 4.005900E+01,5.958200E+01,9.298400E+01,1.766600E+02,2.357300E+02,& + & 2.486900E+02,3.334800E-04,9.748400E-04,3.182800E-03,1.207900E-02,& + & 5.344800E-02,1.489100E-01,3.747900E-01,1.044000E+00,5.689800E+00,& + & 2.143500E+01,3.204800E+01,4.766700E+01,7.438800E+01,1.413200E+02,& + & 1.885900E+02,1.989600E+02,3.352200E-04,9.821600E-04,2.973900E-03,& + & 1.084100E-02,4.359500E-02,1.169300E-01,2.936700E-01,8.123100E-01,& + & 4.353200E+00,1.607700E+01,2.403600E+01,3.575000E+01,5.579100E+01,& + & 1.059900E+02,1.414400E+02,1.492300E+02,3.267700E-04,9.364400E-04,& + & 2.610000E-03,9.182600E-03,3.257200E-02,8.323000E-02,2.093300E-01,& + & 5.721500E-01,3.031900E+00,1.083300E+01,1.602900E+01,2.383400E+01,& + & 3.719400E+01,7.066400E+01,9.429400E+01,9.947200E+01,2.982600E-04,& + & 8.072400E-04,2.096700E-03,6.807400E-03,2.001000E-02,4.706700E-02,& + & 1.185200E-01,3.216500E-01,1.691600E+00,5.676400E+00,8.390200E+00,& + & 1.214600E+01,1.861900E+01,3.533000E+01,4.714600E+01,4.973600E+01/ + data absa(:,441:460) / & + & 2.637900E-04,6.563200E-04,1.238900E-03,1.562300E-03,2.640500E-03,& + & 4.312900E-03,1.021500E-02,3.354100E-02,1.259300E-01,3.463800E-01,& + & 8.322900E-01,1.177400E+00,1.046900E+00,2.856000E+00,1.095300E+01,& + & 1.710200E+01,1.320000E-04,5.840300E-04,3.042000E-03,1.657800E-02,& + & 1.074100E-01,3.348500E-01,8.877000E-01,2.494800E+00,1.429500E+01,& + & 5.409800E+01,8.097700E+01,1.214300E+02,1.925900E+02,3.510200E+02,& + & 4.595500E+02,4.834200E+02,3.336700E-04,1.022600E-03,4.356000E-03,& + & 1.964100E-02,1.044600E-01,3.028600E-01,7.896100E-01,2.193100E+00,& + & 1.251000E+01,4.733600E+01,7.085600E+01,1.062500E+02,1.685100E+02,& + & 3.071600E+02,4.021400E+02,4.229500E+02,4.001100E-04,1.201100E-03,& + & 4.691100E-03,1.951700E-02,9.578000E-02,2.680800E-01,6.942900E-01,& + & 1.906600E+00,1.073400E+01,4.057500E+01,6.073500E+01,9.106900E+01,& + & 1.444400E+02,2.632600E+02,3.446700E+02,3.625100E+02,4.333200E-04,& + & 1.308900E-03,4.725200E-03,1.862700E-02,8.467600E-02,2.313500E-01,& + & 5.950000E-01,1.619400E+00,8.981900E+00,3.381600E+01,5.061100E+01,& + & 7.588900E+01,1.203700E+02,2.193900E+02,2.872400E+02,3.021100E+02,& + & 4.449300E-04,1.368900E-03,4.524600E-03,1.718400E-02,7.211700E-02,& + & 1.923600E-01,4.915800E-01,1.330500E+00,7.253000E+00,2.705200E+01,& + & 4.048900E+01,6.071300E+01,9.629800E+01,1.755100E+02,2.297900E+02,& + & 2.416900E+02,4.426100E-04,1.368600E-03,4.166600E-03,1.522700E-02,& + & 5.840600E-02,1.508700E-01,3.840100E-01,1.036300E+00,5.551400E+00,& + & 2.029100E+01,3.036800E+01,4.553700E+01,7.222200E+01,1.316400E+02,& + & 1.723500E+02,1.812800E+02,4.261100E-04,1.284700E-03,3.629200E-03,& + & 1.271000E-02,4.333800E-02,1.067200E-01,2.729200E-01,7.318700E-01,& + & 3.864300E+00,1.370700E+01,2.026000E+01,3.035800E+01,4.814500E+01,& + & 8.775900E+01,1.149000E+02,1.208300E+02,3.858100E-04,1.091600E-03,& + & 2.860800E-03,9.314000E-03,2.614800E-02,6.049800E-02,1.536400E-01,& + & 4.125800E-01,2.156400E+00,7.195200E+00,1.059100E+01,1.551600E+01,& + & 2.411500E+01,4.387900E+01,5.744800E+01,6.042700E+01,3.291200E-04,& + & 8.074500E-04,1.467700E-03,1.826600E-03,3.015200E-03,5.241200E-03,& + & 1.214000E-02,3.946100E-02,1.500400E-01,4.893500E-01,9.645600E-01,& + & 1.341600E+00,9.033600E-01,5.592800E+00,1.397500E+01,2.275200E+01,& + & 1.039300E-04,2.509300E-04,8.012400E-04,4.339700E-03,3.526700E-02,& + & 1.572900E-01,4.053200E-01,1.178600E+00,7.005000E+00,2.931700E+01,& + & 4.540500E+01,6.934800E+01,1.072400E+02,2.051300E+02,2.934700E+02,& + & 3.138000E+02,1.584000E-04,3.566500E-04,1.160000E-03,5.263300E-03,& + & 3.541900E-02,1.405800E-01,3.582400E-01,1.032600E+00,6.129600E+00,& + & 2.565200E+01,3.973000E+01,6.068000E+01,9.383400E+01,1.794800E+02,& + & 2.567700E+02,2.745300E+02,1.720300E-04,3.870100E-04,1.257700E-03,& + & 5.231400E-03,3.301800E-02,1.239900E-01,3.123900E-01,8.919400E-01,& + & 5.254900E+00,2.198700E+01,3.405500E+01,5.201200E+01,8.042500E+01,& + & 1.538400E+02,2.201000E+02,2.352600E+02,1.764800E-04,3.963100E-04,& + & 1.291300E-03,5.001700E-03,2.965200E-02,1.059600E-01,2.673200E-01,& + & 7.504000E-01,4.386800E+00,1.832400E+01,2.837900E+01,4.334200E+01,& + & 6.702800E+01,1.282100E+02,1.834200E+02,1.960900E+02,1.745400E-04,& + & 3.937200E-04,1.275800E-03,4.631400E-03,2.566100E-02,8.695300E-02,& + & 2.202400E-01,6.110000E-01,3.524200E+00,1.465800E+01,2.270400E+01,& + & 3.467300E+01,5.362100E+01,1.025600E+02,1.467300E+02,1.568600E+02,& + & 1.666700E-04,3.814400E-04,1.194800E-03,4.130800E-03,2.108100E-02,& + & 6.744900E-02,1.712300E-01,4.731100E-01,2.666900E+00,1.099400E+01,& + & 1.702700E+01,2.600600E+01,4.021500E+01,7.692400E+01,1.100500E+02,& + & 1.176400E+02,1.530800E-04,3.537300E-04,1.060700E-03,3.462100E-03,& + & 1.581200E-02,4.738800E-02,1.196900E-01,3.310000E-01,1.824500E+00,& + & 7.331300E+00,1.135200E+01,1.733800E+01,2.680800E+01,5.128100E+01,& + & 7.336500E+01,7.845500E+01,1.293900E-04,3.142300E-04,8.246400E-04,& + & 2.559700E-03,9.820300E-03,2.609800E-02,6.609400E-02,1.818400E-01,& + & 9.816800E-01,3.787700E+00,5.762900E+00,8.670200E+00,1.340500E+01,& + & 2.564000E+01,3.668500E+01,3.921900E+01,1.099300E-04,3.010400E-04,& + & 6.857900E-04,1.258200E-03,1.503900E-03,2.492800E-03,5.421400E-03,& + & 1.991200E-02,8.574500E-02,2.255400E-01,2.297800E-01,3.046600E-01,& + & 7.594700E-01,9.448900E-01,2.503000E-01,4.170200E-05,1.062300E-04,& + & 3.056100E-04,1.167300E-03,6.693400E-03,5.408800E-02,2.195700E-01,& + & 5.660600E-01,1.657700E+00,9.955400E+00,4.154900E+01,6.451600E+01,& + & 9.935200E+01,1.513500E+02,2.891500E+02,4.084600E+02,4.345800E+02/ + data absa(:,461:480) / & + & 1.847300E-04,4.539700E-04,1.664200E-03,8.147700E-03,5.313700E-02,& + & 1.964100E-01,5.005000E-01,1.452700E+00,8.711400E+00,3.635500E+01,& + & 5.645000E+01,8.693000E+01,1.324400E+02,2.530000E+02,3.573800E+02,& + & 3.803200E+02,2.051000E-04,5.052100E-04,1.800300E-03,8.094900E-03,& + & 4.910200E-02,1.727200E-01,4.369300E-01,1.255700E+00,7.468700E+00,& + & 3.116200E+01,4.838500E+01,7.451100E+01,1.135200E+02,2.168700E+02,& + & 3.063500E+02,3.259600E+02,2.142400E-04,5.301700E-04,1.839500E-03,& + & 7.718800E-03,4.371900E-02,1.476300E-01,3.730100E-01,1.058300E+00,& + & 6.235100E+00,2.596800E+01,4.032100E+01,6.209300E+01,9.459600E+01,& + & 1.807200E+02,2.553000E+02,2.716500E+02,2.152900E-04,5.336600E-04,& + & 1.798700E-03,7.118800E-03,3.749800E-02,1.213500E-01,3.065000E-01,& + & 8.633000E-01,5.009800E+00,2.077500E+01,3.225800E+01,4.967600E+01,& + & 7.567700E+01,1.445800E+02,2.042300E+02,2.173600E+02,2.073200E-04,& + & 5.281600E-04,1.675900E-03,6.297700E-03,3.062200E-02,9.435800E-02,& + & 2.375900E-01,6.675800E-01,3.794200E+00,1.558100E+01,2.419300E+01,& + & 3.725700E+01,5.675800E+01,1.084400E+02,1.531900E+02,1.630000E+02,& + & 1.933200E-04,4.962000E-04,1.497700E-03,5.171300E-03,2.291400E-02,& + & 6.624600E-02,1.661800E-01,4.665900E-01,2.598000E+00,1.038800E+01,& + & 1.612900E+01,2.483900E+01,3.783900E+01,7.228700E+01,1.021200E+02,& + & 1.086600E+02,1.673500E-04,4.311500E-04,1.159700E-03,3.777900E-03,& + & 1.403600E-02,3.657900E-02,9.140600E-02,2.558500E-01,1.400100E+00,& + & 5.386800E+00,8.174300E+00,1.241900E+01,1.891900E+01,3.614600E+01,& + & 5.105800E+01,5.433100E+01,1.503400E-04,4.140900E-04,8.771400E-04,& + & 1.457400E-03,1.858800E-03,3.114100E-03,6.547600E-03,2.457400E-02,& + & 1.047800E-01,2.398300E-01,3.845000E-01,6.851000E-01,7.756800E-01,& + & 1.010100E+00,2.226100E+00,1.060300E+01,1.188000E-04,4.093500E-04,& + & 1.820800E-03,1.043200E-02,8.130900E-02,2.979600E-01,7.710900E-01,& + & 2.252900E+00,1.353300E+01,5.619100E+01,8.757000E+01,1.356300E+02,& + & 2.063400E+02,3.898100E+02,5.393400E+02,5.727900E+02,2.282100E-04,& + & 6.219700E-04,2.507200E-03,1.242800E-02,7.851500E-02,2.664700E-01,& + & 6.823000E-01,1.974500E+00,1.184200E+01,4.916800E+01,7.662900E+01,& + & 1.186800E+02,1.805600E+02,3.410800E+02,4.719100E+02,5.012100E+02,& + & 2.593500E-04,6.999500E-04,2.673600E-03,1.219600E-02,7.187300E-02,& + & 2.343200E-01,5.954700E-01,1.707800E+00,1.015200E+01,4.214300E+01,& + & 6.567800E+01,1.017300E+02,1.547600E+02,2.923600E+02,4.045000E+02,& + & 4.296300E+02,2.736900E-04,7.384500E-04,2.693500E-03,1.156000E-02,& + & 6.345500E-02,2.002800E-01,5.080300E-01,1.439500E+00,8.477100E+00,& + & 3.511700E+01,5.473800E+01,8.476900E+01,1.289600E+02,2.436400E+02,& + & 3.370800E+02,3.580200E+02,2.771700E-04,7.464600E-04,2.625500E-03,& + & 1.056600E-02,5.400800E-02,1.647600E-01,4.171900E-01,1.174300E+00,& + & 6.812300E+00,2.809600E+01,4.378500E+01,6.781800E+01,1.031700E+02,& + & 1.949000E+02,2.696900E+02,2.863900E+02,2.678200E-04,7.405400E-04,& + & 2.419600E-03,9.246400E-03,4.370900E-02,1.281000E-01,3.229900E-01,& + & 9.066800E-01,5.164000E+00,2.107100E+01,3.284000E+01,5.086600E+01,& + & 7.738400E+01,1.461700E+02,2.022500E+02,2.147900E+02,2.500200E-04,& + & 7.003500E-04,2.107200E-03,7.615600E-03,3.227700E-02,8.998900E-02,& + & 2.259300E-01,6.314200E-01,3.540500E+00,1.405200E+01,2.189400E+01,& + & 3.390800E+01,5.158700E+01,9.746000E+01,1.348300E+02,1.432100E+02,& + & 2.199300E-04,5.898500E-04,1.635000E-03,5.514100E-03,1.942400E-02,& + & 4.974100E-02,1.245000E-01,3.447700E-01,1.911100E+00,7.290300E+00,& + & 1.110500E+01,1.695700E+01,2.579200E+01,4.873000E+01,6.741900E+01,& + & 7.160600E+01,1.982200E-04,5.444800E-04,1.107000E-03,1.658200E-03,& + & 2.249800E-03,3.734700E-03,7.889200E-03,2.977100E-02,1.257300E-01,& + & 2.834700E-01,5.052800E-01,1.046700E+00,1.144600E+00,5.891300E-01,& + & 7.074500E+00,1.473700E+01,1.456100E-04,5.858400E-04,2.887200E-03,& + & 1.649100E-02,1.180000E-01,3.948300E-01,1.034500E+00,2.966000E+00,& + & 1.777100E+01,7.316200E+01,1.142100E+02,1.775300E+02,2.738800E+02,& + & 5.042900E+02,6.828000E+02,7.260300E+02,2.966500E-04,8.903000E-04,& + & 3.829800E-03,1.875900E-02,1.124400E-01,3.534900E-01,9.143900E-01,& + & 2.601200E+00,1.555100E+01,6.401600E+01,9.992400E+01,1.553500E+02,& + & 2.396300E+02,4.412400E+02,5.974500E+02,6.319900E+02,3.431800E-04,& + & 1.001600E-03,4.002800E-03,1.825800E-02,1.021700E-01,3.105800E-01,& + & 7.974600E-01,2.249900E+00,1.333300E+01,5.487100E+01,8.565000E+01,& + & 1.331500E+02,2.054000E+02,3.781900E+02,5.120900E+02,5.445000E+02/ + data absa(:,481:500) / & + & 3.628700E-04,1.049500E-03,4.009000E-03,1.710900E-02,8.956700E-02,& + & 2.656500E-01,6.787700E-01,1.897500E+00,1.113400E+01,4.572900E+01,& + & 7.137200E+01,1.109600E+02,1.711600E+02,3.151500E+02,4.267600E+02,& + & 4.537900E+02,3.664200E-04,1.064500E-03,3.840000E-03,1.547200E-02,& + & 7.566400E-02,2.191100E-01,5.562700E-01,1.546900E+00,8.951200E+00,& + & 3.658300E+01,5.709900E+01,8.876500E+01,1.369200E+02,2.521200E+02,& + & 3.414100E+02,3.629900E+02,3.538600E-04,1.048700E-03,3.482800E-03,& + & 1.346300E-02,6.055900E-02,1.703200E-01,4.305300E-01,1.194100E+00,& + & 6.787600E+00,2.743900E+01,4.282600E+01,6.657600E+01,1.027000E+02,& + & 1.891000E+02,2.560500E+02,2.722600E+02,3.294400E-04,9.818400E-04,& + & 2.982700E-03,1.096300E-02,4.438700E-02,1.193900E-01,3.010300E-01,& + & 8.295600E-01,4.657700E+00,1.830900E+01,2.854900E+01,4.438400E+01,& + & 6.846400E+01,1.260600E+02,1.707000E+02,1.815000E+02,2.881100E-04,& + & 8.140500E-04,2.282500E-03,7.797300E-03,2.635300E-02,6.567400E-02,& + & 1.653300E-01,4.524700E-01,2.517200E+00,9.496500E+00,1.450600E+01,& + & 2.220600E+01,3.423300E+01,6.303400E+01,8.535300E+01,9.075500E+01,& + & 2.531900E-04,6.770600E-04,1.330600E-03,1.833500E-03,2.724800E-03,& + & 4.479400E-03,9.682300E-03,3.534000E-02,1.485500E-01,3.436300E-01,& + & 6.358000E-01,1.328900E+00,1.496700E+00,1.022700E+00,1.190900E+01,& + & 2.041800E+01,1.905400E-04,8.758900E-04,4.575800E-03,2.543000E-02,& + & 1.647200E-01,5.129300E-01,1.346200E+00,3.825200E+00,2.268000E+01,& + & 9.212600E+01,1.440400E+02,2.250800E+02,3.525400E+02,6.298500E+02,& + & 8.361900E+02,8.981000E+02,3.980900E-04,1.305000E-03,5.821400E-03,& + & 2.807800E-02,1.553800E-01,4.588900E-01,1.189100E+00,3.356000E+00,& + & 1.984600E+01,8.061100E+01,1.260400E+02,1.969400E+02,3.084400E+02,& + & 5.511300E+02,7.316700E+02,7.858400E+02,4.648600E-04,1.446400E-03,& + & 5.995400E-03,2.700200E-02,1.403500E-01,4.028800E-01,1.036200E+00,& + & 2.902500E+00,1.701900E+01,6.909500E+01,1.080300E+02,1.688100E+02,& + & 2.644200E+02,4.724100E+02,6.271300E+02,6.735500E+02,4.919800E-04,& + & 1.505300E-03,5.880600E-03,2.503200E-02,1.226500E-01,3.440200E-01,& + & 8.806500E-01,2.449300E+00,1.421400E+01,5.758200E+01,9.003300E+01,& + & 1.406800E+02,2.203500E+02,3.936800E+02,5.226200E+02,5.612600E+02,& + & 4.937300E-04,1.517500E-03,5.545700E-03,2.239200E-02,1.031500E-01,& + & 2.833900E-01,7.207100E-01,1.996200E+00,1.143000E+01,4.606800E+01,& + & 7.202600E+01,1.125500E+02,1.762800E+02,3.149500E+02,4.181000E+02,& + & 4.490100E+02,4.746200E-04,1.477900E-03,4.967100E-03,1.926100E-02,& + & 8.213100E-02,2.199800E-01,5.579100E-01,1.536400E+00,8.674500E+00,& + & 3.455400E+01,5.402000E+01,8.440500E+01,1.322000E+02,2.362100E+02,& + & 3.135900E+02,3.367400E+02,4.367600E-04,1.369100E-03,4.197900E-03,& + & 1.547400E-02,5.977100E-02,1.538300E-01,3.904400E-01,1.066200E+00,& + & 5.953800E+00,2.307300E+01,3.601100E+01,5.626700E+01,8.813400E+01,& + & 1.574700E+02,2.090400E+02,2.245100E+02,3.766400E-04,1.115400E-03,& + & 3.153700E-03,1.078400E-02,3.497900E-02,8.449300E-02,2.146400E-01,& + & 5.820700E-01,3.217500E+00,1.195400E+01,1.833400E+01,2.816800E+01,& + & 4.406700E+01,7.873400E+01,1.045300E+02,1.122500E+02,3.122200E-04,& + & 8.366800E-04,1.589600E-03,2.007500E-03,3.217600E-03,5.391600E-03,& + & 1.173600E-02,4.074000E-02,1.720300E-01,4.647000E-01,7.961200E-01,& + & 1.637100E+00,1.395100E+00,3.170400E+00,1.537200E+01,2.734500E+01,& + & 1.107000E-04,2.698100E-04,8.695700E-04,4.927300E-03,3.964700E-02,& + & 1.749600E-01,4.642000E-01,1.333400E+00,8.104700E+00,3.668400E+01,& + & 5.927100E+01,9.581500E+01,1.492900E+02,2.748000E+02,3.958700E+02,& + & 4.256400E+02,1.594800E-04,3.616500E-04,1.191800E-03,5.793100E-03,& + & 3.895500E-02,1.562000E-01,4.098800E-01,1.168300E+00,7.092000E+00,& + & 3.209900E+01,5.185900E+01,8.383600E+01,1.306300E+02,2.404300E+02,& + & 3.463700E+02,3.725200E+02,1.693500E-04,3.839300E-04,1.259700E-03,& + & 5.674600E-03,3.586600E-02,1.372000E-01,3.569800E-01,1.008000E+00,& + & 6.080200E+00,2.751400E+01,4.445300E+01,7.186000E+01,1.119700E+02,& + & 2.060900E+02,2.969000E+02,3.192700E+02,1.712300E-04,3.862100E-04,& + & 1.268800E-03,5.361100E-03,3.188200E-02,1.169200E-01,3.042200E-01,& + & 8.469500E-01,5.076100E+00,2.292700E+01,3.704400E+01,5.988500E+01,& + & 9.330600E+01,1.717300E+02,2.474200E+02,2.660500E+02,1.674200E-04,& + & 3.777300E-04,1.237500E-03,4.884700E-03,2.737200E-02,9.566400E-02,& + & 2.491800E-01,6.888100E-01,4.076700E+00,1.834200E+01,2.963500E+01,& + & 4.790700E+01,7.464800E+01,1.374000E+02,1.979400E+02,2.128700E+02/ + data absa(:,501:520) / & + & 1.563600E-04,3.586300E-04,1.151300E-03,4.270900E-03,2.228300E-02,& + & 7.389600E-02,1.925200E-01,5.304300E-01,3.084100E+00,1.375700E+01,& + & 2.222600E+01,3.593100E+01,5.598400E+01,1.030500E+02,1.484400E+02,& + & 1.596200E+02,1.410800E-04,3.272300E-04,1.011000E-03,3.485500E-03,& + & 1.658100E-02,5.151700E-02,1.342300E-01,3.671500E-01,2.105800E+00,& + & 9.174300E+00,1.481800E+01,2.395300E+01,3.732200E+01,6.869600E+01,& + & 9.896400E+01,1.064300E+02,1.164100E-04,2.813600E-04,7.862000E-04,& + & 2.488900E-03,1.013700E-02,2.813100E-02,7.316000E-02,1.974900E-01,& + & 1.126600E+00,4.721700E+00,7.486100E+00,1.197700E+01,1.866100E+01,& + & 3.435000E+01,4.948400E+01,5.321200E+01,9.360900E-05,2.793700E-04,& + & 6.660700E-04,1.152600E-03,1.442800E-03,2.401100E-03,4.739600E-03,& + & 1.881000E-02,9.085200E-02,2.606800E-01,2.202400E-01,2.403500E-01,& + & 7.717900E-01,1.033100E+00,3.464200E-05,3.397400E-05,1.135000E-04,& + & 3.318900E-04,1.284100E-03,7.688400E-03,6.114700E-02,2.453500E-01,& + & 6.545000E-01,1.851000E+00,1.156700E+01,5.186800E+01,8.418500E+01,& + & 1.369400E+02,2.121300E+02,3.843400E+02,5.527200E+02,5.969600E+02,& + & 1.849900E-04,4.617200E-04,1.726200E-03,8.913200E-03,5.915400E-02,& + & 2.191100E-01,5.781100E-01,1.622100E+00,1.012100E+01,4.538700E+01,& + & 7.366500E+01,1.198200E+02,1.856200E+02,3.362900E+02,4.835900E+02,& + & 5.223200E+02,2.015600E-04,5.022400E-04,1.822700E-03,8.677700E-03,& + & 5.399100E-02,1.922200E-01,5.033300E-01,1.401500E+00,8.677500E+00,& + & 3.890100E+01,6.313800E+01,1.027000E+02,1.590900E+02,2.882400E+02,& + & 4.145500E+02,4.477400E+02,2.069000E-04,5.154600E-04,1.831000E-03,& + & 8.178200E-03,4.763300E-02,1.639400E-01,4.280400E-01,1.179500E+00,& + & 7.244100E+00,3.241900E+01,5.261500E+01,8.558800E+01,1.325800E+02,& + & 2.402000E+02,3.454300E+02,3.730700E+02,2.045800E-04,5.113400E-04,& + & 1.770200E-03,7.432700E-03,4.051500E-02,1.343900E-01,3.499600E-01,& + & 9.604500E-01,5.818100E+00,2.593400E+01,4.209400E+01,6.846800E+01,& + & 1.060600E+02,1.921700E+02,2.763600E+02,2.984700E+02,1.945000E-04,& + & 4.941900E-04,1.636400E-03,6.464800E-03,3.282100E-02,1.037900E-01,& + & 2.701900E-01,7.400200E-01,4.402700E+00,1.945200E+01,3.157000E+01,& + & 5.135200E+01,7.954600E+01,1.441200E+02,2.072500E+02,2.238500E+02,& + & 1.767800E-04,4.607800E-04,1.437900E-03,5.237200E-03,2.423100E-02,& + & 7.240900E-02,1.877800E-01,5.128100E-01,3.008000E+00,1.296700E+01,& + & 2.104600E+01,3.423400E+01,5.303300E+01,9.608200E+01,1.381800E+02,& + & 1.492400E+02,1.498500E-04,3.950300E-04,1.099000E-03,3.698100E-03,& + & 1.461100E-02,3.952800E-02,1.021200E-01,2.771700E-01,1.609100E+00,& + & 6.691600E+00,1.061500E+01,1.711800E+01,2.651700E+01,4.804100E+01,& + & 6.908600E+01,7.461900E+01,1.283900E-04,3.816500E-04,8.631400E-04,& + & 1.337300E-03,1.779500E-03,2.936700E-03,5.950600E-03,2.286500E-02,& + & 1.108100E-01,2.791600E-01,3.880200E-01,5.712600E-01,8.310200E-01,& + & 1.069700E+00,1.720700E+00,1.284100E+01,1.273300E-04,4.494500E-04,& + & 2.018300E-03,1.210700E-02,9.196200E-02,3.348900E-01,8.934800E-01,& + & 2.525200E+00,1.575600E+01,7.008100E+01,1.139900E+02,1.860700E+02,& + & 2.884800E+02,5.183500E+02,7.340800E+02,8.013000E+02,2.273500E-04,& + & 6.361400E-04,2.622900E-03,1.371100E-02,8.753700E-02,2.991600E-01,& + & 7.890000E-01,2.214000E+00,1.378700E+01,6.132200E+01,9.974900E+01,& + & 1.628200E+02,2.524200E+02,4.535700E+02,6.422600E+02,7.010900E+02,& + & 2.540200E-04,7.001500E-04,2.728600E-03,1.317700E-02,7.948600E-02,& + & 2.620400E-01,6.866600E-01,1.914000E+00,1.182000E+01,5.256100E+01,& + & 8.549600E+01,1.395600E+02,2.163500E+02,3.887600E+02,5.505200E+02,& + & 6.009500E+02,2.644200E-04,7.230900E-04,2.713500E-03,1.225000E-02,& + & 6.973900E-02,2.233700E-01,5.827200E-01,1.612800E+00,9.868400E+00,& + & 4.380100E+01,7.124500E+01,1.163000E+02,1.803000E+02,3.239800E+02,& + & 4.588400E+02,5.008200E+02,2.634800E-04,7.184000E-04,2.611200E-03,& + & 1.103600E-02,5.895700E-02,1.831100E-01,4.760300E-01,1.313700E+00,& + & 7.926300E+00,3.504300E+01,5.699700E+01,9.303800E+01,1.442500E+02,& + & 2.591700E+02,3.670400E+02,4.006400E+02,2.518900E-04,6.988200E-04,& + & 2.398700E-03,9.516000E-03,4.722200E-02,1.417100E-01,3.667700E-01,& + & 1.011500E+00,6.001400E+00,2.628200E+01,4.274900E+01,6.978100E+01,& + & 1.081800E+02,1.943800E+02,2.752900E+02,3.004900E+02,2.299200E-04,& + & 6.506200E-04,2.047200E-03,7.680100E-03,3.448800E-02,9.896700E-02,& + & 2.547300E-01,6.995700E-01,4.103000E+00,1.752600E+01,2.849900E+01,& + & 4.651800E+01,7.211600E+01,1.295900E+02,1.835200E+02,2.003000E+02/ + data absa(:,521:540) / & + & 1.965500E-04,5.469700E-04,1.549600E-03,5.415500E-03,2.042500E-02,& + & 5.406200E-02,1.378900E-01,3.777600E-01,2.196900E+00,9.053000E+00,& + & 1.438300E+01,2.325900E+01,3.605900E+01,6.479500E+01,9.175700E+01,& + & 1.001600E+02,1.692800E-04,5.028300E-04,1.068100E-03,1.519400E-03,& + & 2.154800E-03,3.511000E-03,7.317900E-03,2.742100E-02,1.325600E-01,& + & 3.314500E-01,4.934200E-01,8.881300E-01,1.276900E+00,6.615200E-01,& + & 6.455500E+00,1.760400E+01,1.562700E-04,6.494900E-04,3.221200E-03,& + & 1.886900E-02,1.337500E-01,4.464500E-01,1.175600E+00,3.372400E+00,& + & 2.073100E+01,9.095700E+01,1.484200E+02,2.426800E+02,3.797600E+02,& + & 6.729200E+02,9.377800E+02,1.042400E+03,2.945600E-04,9.245900E-04,& + & 4.050400E-03,2.081100E-02,1.259300E-01,3.988100E-01,1.037400E+00,& + & 2.958100E+00,1.814100E+01,7.959100E+01,1.298700E+02,2.123500E+02,& + & 3.322600E+02,5.887800E+02,8.204400E+02,9.120900E+02,3.354900E-04,& + & 1.009600E-03,4.147200E-03,1.983300E-02,1.136200E-01,3.494000E-01,& + & 9.017400E-01,2.556400E+00,1.555400E+01,6.822700E+01,1.113200E+02,& + & 1.820100E+02,2.848100E+02,5.046700E+02,7.033100E+02,7.818600E+02,& + & 3.514200E-04,1.040400E-03,4.070200E-03,1.832500E-02,9.898300E-02,& + & 2.976400E-01,7.653300E-01,2.153000E+00,1.298900E+01,5.685900E+01,& + & 9.277000E+01,1.516800E+02,2.373300E+02,4.205500E+02,5.860700E+02,& + & 6.515100E+02,3.505500E-04,1.030100E-03,3.858300E-03,1.636100E-02,& + & 8.293800E-02,2.443800E-01,6.250900E-01,1.752000E+00,1.043600E+01,& + & 4.548800E+01,7.421600E+01,1.213400E+02,1.898600E+02,3.364500E+02,& + & 4.688300E+02,5.212100E+02,3.347500E-04,9.970400E-04,3.474800E-03,& + & 1.398300E-02,6.596100E-02,1.889900E-01,4.818000E-01,1.347100E+00,& + & 7.904700E+00,3.411400E+01,5.566200E+01,9.101000E+01,1.424000E+02,& + & 2.523400E+02,3.516600E+02,3.909200E+02,3.047300E-04,9.206400E-04,& + & 2.926200E-03,1.116000E-02,4.784900E-02,1.316900E-01,3.351100E-01,& + & 9.294700E-01,5.407100E+00,2.276000E+01,3.710700E+01,6.067000E+01,& + & 9.493200E+01,1.682300E+02,2.344300E+02,2.605900E+02,2.589200E-04,& + & 7.572600E-04,2.191400E-03,7.683700E-03,2.797700E-02,7.174500E-02,& + & 1.818500E-01,5.011200E-01,2.896200E+00,1.175100E+01,1.876100E+01,& + & 3.033500E+01,4.746400E+01,8.411200E+01,1.172200E+02,1.303000E+02,& + & 2.165300E-04,6.371500E-04,1.260100E-03,1.746800E-03,2.582300E-03,& + & 4.274400E-03,8.952300E-03,3.239300E-02,1.569000E-01,3.605300E-01,& + & 6.819400E-01,1.123700E+00,1.681200E+00,1.139000E+00,1.088400E+01,& + & 2.440800E+01,2.044100E-04,9.794800E-04,5.151100E-03,2.906300E-02,& + & 1.861900E-01,5.844000E-01,1.529700E+00,4.379200E+00,2.648300E+01,& + & 1.147800E+02,1.869400E+02,3.064200E+02,4.850800E+02,8.427300E+02,& + & 1.162900E+03,1.310700E+03,3.946200E-04,1.369500E-03,6.219600E-03,& + & 3.113100E-02,1.738900E-01,5.213500E-01,1.349400E+00,3.842200E+00,& + & 2.317600E+01,1.004400E+02,1.635600E+02,2.681300E+02,4.244400E+02,& + & 7.373900E+02,1.017500E+03,1.146700E+03,4.546100E-04,1.475500E-03,& + & 6.259100E-03,2.946100E-02,1.561400E-01,4.560800E-01,1.172900E+00,& + & 3.321000E+00,1.987200E+01,8.608600E+01,1.402000E+02,2.298200E+02,& + & 3.638000E+02,6.320500E+02,8.721600E+02,9.829600E+02,4.763700E-04,& + & 1.509800E-03,6.040200E-03,2.699300E-02,1.356300E-01,3.880400E-01,& + & 9.940100E-01,2.798300E+00,1.659400E+01,7.174300E+01,1.168300E+02,& + & 1.915200E+02,3.031800E+02,5.266800E+02,7.268400E+02,8.191500E+02,& + & 4.745600E-04,1.482300E-03,5.630200E-03,2.383800E-02,1.135600E-01,& + & 3.178400E-01,8.105200E-01,2.275500E+00,1.333900E+01,5.739400E+01,& + & 9.347400E+01,1.532200E+02,2.425300E+02,4.213500E+02,5.814200E+02,& + & 6.553800E+02,4.507100E-04,1.417300E-03,4.994600E-03,2.019200E-02,& + & 8.990000E-02,2.455500E-01,6.238700E-01,1.746100E+00,1.011100E+01,& + & 4.304600E+01,7.010700E+01,1.149100E+02,1.819000E+02,3.160200E+02,& + & 4.360900E+02,4.914800E+02,4.080500E-04,1.291800E-03,4.164100E-03,& + & 1.592400E-02,6.474300E-02,1.708200E-01,4.329000E-01,1.205900E+00,& + & 6.915000E+00,2.873700E+01,4.673800E+01,7.660600E+01,1.212700E+02,& + & 2.106900E+02,2.907300E+02,3.276600E+02,3.404700E-04,1.047200E-03,& + & 3.058100E-03,1.073700E-02,3.743700E-02,9.283600E-02,2.343300E-01,& + & 6.475200E-01,3.709500E+00,1.481400E+01,2.368200E+01,3.831000E+01,& + & 6.063300E+01,1.053400E+02,1.453700E+02,1.638500E+02,2.677900E-04,& + & 7.812000E-04,1.493200E-03,1.988400E-03,3.041600E-03,5.054600E-03,& + & 1.084500E-02,3.707000E-02,1.818600E-01,4.514400E-01,7.505100E-01,& + & 1.530800E+00,1.683700E+00,2.240900E+00,1.687100E+01,3.285300E+01/ + data absa(:,541:560) / & + & 9.479600E-05,2.334700E-04,7.557000E-04,4.386900E-03,3.534800E-02,& + & 1.554800E-01,4.216700E-01,1.211600E+00,7.469900E+00,3.596500E+01,& + & 6.116200E+01,1.039600E+02,1.684400E+02,2.972500E+02,4.340800E+02,& + & 4.812200E+02,1.356600E-04,3.098400E-04,1.024500E-03,5.179800E-03,& + & 3.459400E-02,1.393400E-01,3.727600E-01,1.062700E+00,6.536400E+00,& + & 3.147200E+01,5.351600E+01,9.097300E+01,1.473900E+02,2.600900E+02,& + & 3.798000E+02,4.210500E+02,1.436100E-04,3.274000E-04,1.077200E-03,& + & 5.098900E-03,3.165100E-02,1.222600E-01,3.255300E-01,9.175800E-01,& + & 5.606200E+00,2.697500E+01,4.587100E+01,7.797300E+01,1.263300E+02,& + & 2.229500E+02,3.255300E+02,3.608700E+02,1.447900E-04,3.283600E-04,& + & 1.086000E-03,4.816900E-03,2.803200E-02,1.039600E-01,2.772600E-01,& + & 7.727700E-01,4.683500E+00,2.247900E+01,3.822500E+01,6.498200E+01,& + & 1.052800E+02,1.857800E+02,2.712900E+02,3.007600E+02,1.411800E-04,& + & 3.196400E-04,1.052400E-03,4.379400E-03,2.397200E-02,8.506800E-02,& + & 2.269500E-01,6.299600E-01,3.765000E+00,1.798400E+01,3.058100E+01,& + & 5.198400E+01,8.421900E+01,1.486200E+02,2.170400E+02,2.406000E+02,& + & 1.314700E-04,3.030700E-04,9.755700E-04,3.783900E-03,1.947600E-02,& + & 6.571100E-02,1.752200E-01,4.848700E-01,2.855500E+00,1.348800E+01,& + & 2.293600E+01,3.899100E+01,6.316700E+01,1.114700E+02,1.627800E+02,& + & 1.804600E+02,1.181900E-04,2.756200E-04,8.561000E-04,3.052100E-03,& + & 1.452000E-02,4.570200E-02,1.218400E-01,3.353600E-01,1.956000E+00,& + & 9.023200E+00,1.529100E+01,2.599200E+01,4.211000E+01,7.431400E+01,& + & 1.085100E+02,1.203000E+02,9.717000E-05,2.356400E-04,6.622000E-04,& + & 2.158700E-03,8.848300E-03,2.487300E-02,6.614300E-02,1.796400E-01,& + & 1.051500E+00,4.664800E+00,7.772200E+00,1.300300E+01,2.105500E+01,& + & 3.715800E+01,5.425400E+01,6.014800E+01,7.630300E-05,2.367400E-04,& + & 5.796000E-04,9.478400E-04,1.207300E-03,2.074000E-03,4.003000E-03,& + & 1.546800E-02,8.527300E-02,2.470500E-01,3.050100E-01,2.889600E-01,& + & 6.474600E-01,8.588300E-01,3.338700E-01,7.399300E+00,9.738700E-05,& + & 2.902700E-04,1.128900E-03,6.948100E-03,5.465700E-02,2.189700E-01,& + & 6.014000E-01,1.681800E+00,1.068000E+01,5.080000E+01,8.664300E+01,& + & 1.481700E+02,2.397400E+02,4.129400E+02,6.111300E+02,6.920600E+02,& + & 1.574200E-04,3.985700E-04,1.499500E-03,8.052500E-03,5.271700E-02,& + & 1.963100E-01,5.318800E-01,1.475500E+00,9.345400E+00,4.445100E+01,& + & 7.581500E+01,1.296500E+02,2.097800E+02,3.613400E+02,5.348200E+02,& + & 6.055700E+02,1.711500E-04,4.317000E-04,1.573600E-03,7.845800E-03,& + & 4.788000E-02,1.724000E-01,4.638000E-01,1.274600E+00,8.016500E+00,& + & 3.810100E+01,6.498400E+01,1.111300E+02,1.798100E+02,3.097100E+02,& + & 4.584100E+02,5.190700E+02,1.753500E-04,4.414400E-04,1.576100E-03,& + & 7.331400E-03,4.216900E-02,1.467600E-01,3.936500E-01,1.074800E+00,& + & 6.697600E+00,3.175200E+01,5.415300E+01,9.260400E+01,1.498300E+02,& + & 2.580900E+02,3.820100E+02,4.325500E+02,1.730000E-04,4.348200E-04,& + & 1.519100E-03,6.607800E-03,3.591900E-02,1.200300E-01,3.218400E-01,& + & 8.763400E-01,5.385400E+00,2.540300E+01,4.332400E+01,7.408900E+01,& + & 1.198700E+02,2.064900E+02,3.056000E+02,3.460300E+02,1.638300E-04,& + & 4.194300E-04,1.405500E-03,5.710000E-03,2.902800E-02,9.264500E-02,& + & 2.477800E-01,6.737700E-01,4.087700E+00,1.905300E+01,3.249300E+01,& + & 5.556200E+01,8.990100E+01,1.548700E+02,2.292000E+02,2.595500E+02,& + & 1.482400E-04,3.894300E-04,1.221300E-03,4.566300E-03,2.142400E-02,& + & 6.453800E-02,1.719000E-01,4.651800E-01,2.803600E+00,1.273900E+01,& + & 2.166200E+01,3.704300E+01,5.993700E+01,1.032400E+02,1.527900E+02,& + & 1.730200E+02,1.251300E-04,3.319400E-04,9.339000E-04,3.213600E-03,& + & 1.283200E-02,3.519100E-02,9.302300E-02,2.490100E-01,1.507800E+00,& + & 6.598200E+00,1.101600E+01,1.852300E+01,2.996700E+01,5.162100E+01,& + & 7.639700E+01,8.650800E+01,1.046900E-04,3.236500E-04,7.529500E-04,& + & 1.096100E-03,1.499700E-03,2.512400E-03,5.110400E-03,1.870900E-02,& + & 1.041100E-01,2.894100E-01,3.806900E-01,6.407100E-01,7.797700E-01,& + & 7.440300E-01,3.406000E+00,1.550100E+01,1.094800E-04,3.952400E-04,& + & 1.789100E-03,1.102100E-02,8.259300E-02,3.009300E-01,8.180700E-01,& + & 2.286100E+00,1.462000E+01,6.839300E+01,1.169700E+02,2.005600E+02,& + & 3.261700E+02,5.548400E+02,8.203300E+02,9.470300E+02,1.935400E-04,& + & 5.547200E-04,2.294200E-03,1.245800E-02,7.866800E-02,2.695400E-01,& + & 7.229500E-01,2.007100E+00,1.279300E+01,5.984600E+01,1.023500E+02,& + & 1.754900E+02,2.854000E+02,4.854800E+02,7.178000E+02,8.286700E+02/ + data absa(:,561:580) / & + & 2.160100E-04,6.067600E-04,2.370900E-03,1.197700E-02,7.103800E-02,& + & 2.361800E-01,6.300400E-01,1.735800E+00,1.097300E+01,5.129600E+01,& + & 8.772700E+01,1.504200E+02,2.446200E+02,4.161100E+02,6.152500E+02,& + & 7.103000E+02,2.245000E-04,6.231900E-04,2.351300E-03,1.102100E-02,& + & 6.222600E-02,2.011900E-01,5.345700E-01,1.464400E+00,9.167800E+00,& + & 4.274600E+01,7.310700E+01,1.253500E+02,2.038600E+02,3.467700E+02,& + & 5.127200E+02,5.918900E+02,2.232100E-04,6.159700E-04,2.264600E-03,& + & 9.825800E-03,5.255500E-02,1.647800E-01,4.364300E-01,1.194000E+00,& + & 7.373500E+00,3.419900E+01,5.848600E+01,1.002800E+02,1.630900E+02,& + & 2.774100E+02,4.101700E+02,4.735400E+02,2.128700E-04,5.971000E-04,& + & 2.061600E-03,8.408300E-03,4.198000E-02,1.274000E-01,3.360500E-01,& + & 9.183700E-01,5.597200E+00,2.565000E+01,4.386300E+01,7.521000E+01,& + & 1.223100E+02,2.080600E+02,3.076400E+02,3.551200E+02,1.935000E-04,& + & 5.527800E-04,1.754500E-03,6.741900E-03,3.059500E-02,8.884800E-02,& + & 2.329200E-01,6.351300E-01,3.838200E+00,1.715100E+01,2.924200E+01,& + & 5.013800E+01,8.154400E+01,1.387100E+02,2.050900E+02,2.367500E+02,& + & 1.643300E-04,4.621300E-04,1.328300E-03,4.694700E-03,1.805700E-02,& + & 4.836600E-02,1.254900E-01,3.422600E-01,2.061800E+00,8.889000E+00,& + & 1.487900E+01,2.508000E+01,4.077000E+01,6.935100E+01,1.025400E+02,& + & 1.183800E+02,1.381900E-04,4.255200E-04,9.211900E-04,1.223800E-03,& + & 1.848400E-03,3.038500E-03,6.434700E-03,2.246400E-02,1.238600E-01,& + & 3.377600E-01,4.951000E-01,7.607300E-01,1.511800E+00,6.577900E-01,& + & 7.384800E+00,2.102900E+01,1.344500E-04,5.748600E-04,2.887200E-03,& + & 1.731000E-02,1.196800E-01,4.048000E-01,1.077800E+00,3.074700E+00,& + & 1.925800E+01,8.895700E+01,1.518600E+02,2.610700E+02,4.266500E+02,& + & 7.201600E+02,1.062300E+03,1.233800E+03,2.508300E-04,8.139300E-04,& + & 3.567500E-03,1.892300E-02,1.126900E-01,3.624000E-01,9.521600E-01,& + & 2.700300E+00,1.685200E+01,7.783700E+01,1.328800E+02,2.284200E+02,& + & 3.733200E+02,6.301700E+02,9.295200E+02,1.085400E+03,2.854900E-04,& + & 8.821600E-04,3.637200E-03,1.800100E-02,1.013400E-01,3.171500E-01,& + & 8.289000E-01,2.336500E+00,1.445500E+01,6.672100E+01,1.138900E+02,& + & 1.958100E+02,3.199900E+02,5.401500E+02,7.967100E+02,9.302600E+02,& + & 2.984700E-04,9.045400E-04,3.562800E-03,1.650900E-02,8.827700E-02,& + & 2.698300E-01,7.021100E-01,1.971200E+00,1.207900E+01,5.560400E+01,& + & 9.491600E+01,1.631700E+02,2.666700E+02,4.501300E+02,6.639000E+02,& + & 7.752600E+02,2.972500E-04,8.920600E-04,3.340700E-03,1.465700E-02,& + & 7.412500E-02,2.207600E-01,5.725900E-01,1.605000E+00,9.719700E+00,& + & 4.448500E+01,7.593600E+01,1.305400E+02,2.133300E+02,3.601000E+02,& + & 5.311100E+02,6.201800E+02,2.834300E-04,8.556600E-04,3.003100E-03,& + & 1.241900E-02,5.901900E-02,1.703900E-01,4.407800E-01,1.232400E+00,& + & 7.381700E+00,3.336400E+01,5.694900E+01,9.790100E+01,1.599900E+02,& + & 2.700700E+02,3.983400E+02,4.651300E+02,2.576300E-04,7.849900E-04,& + & 2.520700E-03,9.854800E-03,4.272600E-02,1.184700E-01,3.051100E-01,& + & 8.508200E-01,5.063900E+00,2.233100E+01,3.796700E+01,6.526700E+01,& + & 1.066700E+02,1.800400E+02,2.655600E+02,3.100900E+02,2.172000E-04,& + & 6.442200E-04,1.886300E-03,6.691600E-03,2.487900E-02,6.438800E-02,& + & 1.645600E-01,4.576100E-01,2.722500E+00,1.155400E+01,1.934200E+01,& + & 3.266500E+01,5.333200E+01,9.002500E+01,1.327800E+02,1.542300E+02,& + & 1.760100E-04,5.347600E-04,1.088800E-03,1.432600E-03,2.211300E-03,& + & 3.694900E-03,7.849000E-03,2.627900E-02,1.461000E-01,3.940000E-01,& + & 5.791200E-01,1.055000E+00,1.665200E+00,1.113300E+00,1.331000E+01,& + & 2.912200E+01,1.757300E-04,8.724600E-04,4.650900E-03,2.661900E-02,& + & 1.669400E-01,5.310900E-01,1.386800E+00,4.046200E+00,2.462100E+01,& + & 1.124800E+02,1.907800E+02,3.281800E+02,5.409800E+02,9.055100E+02,& + & 1.330800E+03,1.569500E+03,3.365700E-04,1.212200E-03,5.532700E-03,& + & 2.829600E-02,1.560600E-01,4.745100E-01,1.224600E+00,3.554700E+00,& + & 2.154600E+01,9.842200E+01,1.669400E+02,2.871700E+02,4.733600E+02,& + & 7.923500E+02,1.164500E+03,1.373400E+03,3.871000E-04,1.298900E-03,& + & 5.499400E-03,2.662300E-02,1.399300E-01,4.146100E-01,1.064700E+00,& + & 3.075200E+00,1.848500E+01,8.435900E+01,1.430900E+02,2.461300E+02,& + & 4.057300E+02,6.791600E+02,9.981300E+02,1.177200E+03,4.056000E-04,& + & 1.322100E-03,5.286200E-03,2.418700E-02,1.214600E-01,3.523900E-01,& + & 9.015000E-01,2.594800E+00,1.544800E+01,7.029600E+01,1.192400E+02,& + & 2.051200E+02,3.381100E+02,5.659600E+02,8.317400E+02,9.810400E+02/ + data absa(:,581:585) / & + & 4.035700E-04,1.295500E-03,4.899300E-03,2.129400E-02,1.015800E-01,& + & 2.879000E-01,7.354700E-01,2.110700E+00,1.243200E+01,5.624000E+01,& + & 9.539400E+01,1.640900E+02,2.704800E+02,4.527600E+02,6.654200E+02,& + & 7.848400E+02,3.825700E-04,1.226000E-03,4.353400E-03,1.793900E-02,& + & 8.036800E-02,2.220200E-01,5.661500E-01,1.618800E+00,9.445400E+00,& + & 4.218200E+01,7.154600E+01,1.230700E+02,2.028600E+02,3.395800E+02,& + & 4.990700E+02,5.886000E+02,3.465300E-04,1.107100E-03,3.609200E-03,& + & 1.410300E-02,5.774200E-02,1.543500E-01,3.919100E-01,1.115900E+00,& + & 6.477100E+00,2.827400E+01,4.769700E+01,8.204000E+01,1.352500E+02,& + & 2.263800E+02,3.327100E+02,3.924000E+02,2.868500E-04,8.917400E-04,& + & 2.644700E-03,9.414100E-03,3.336100E-02,8.362800E-02,2.113500E-01,& + & 5.982500E-01,3.485300E+00,1.461400E+01,2.432700E+01,4.109300E+01,& + & 6.761900E+01,1.131900E+02,1.663500E+02,1.962000E+02,2.185500E-04,& + & 6.584900E-04,1.271500E-03,1.671200E-03,2.620900E-03,4.308700E-03,& + & 9.690300E-03,3.026100E-02,1.700700E-01,4.629400E-01,6.700000E-01,& + & 1.406900E+00,1.727400E+00,2.547400E+00,1.849900E+01,3.928900E+01/ + +! --- the array absb(NG03,1175) = kb(NG03,5,5,13:59) contains absorption +! coefs at the NG03=16 g-intervals for a range of pressure levels < +! ~100mb, temperatures, and ratios of h2o to co2. the first index in +! the array, js, runs from 1 to 5, and corresponds to different gas +! amount ratios, as expressed through the binary species parameter +! eta, defined as eta = gas1/(gas1+rat*gas2), where rat is the ratio +! of the reference mls column amount value of gas1 to that of gas2. +! the second index, jt, which runs from 1 to 5, corresponds to +! different temperatures. more specifically, jt = 1-5 means that +! the data are for the corresponding temperature of tref-30, tref-15, +! tref, tref+15, and tref+30, respectively. the third index, jp, +! runs from 13 to 59 and refers to the reference pressure level (e.g. +! jp = 13 is for a pressure of 95.5835 mb). the fourth index, ig, +! goes from 1 to NG03=16, and tells us which g-interval the absorption +! coefficients are for. + + data absb(:, 1: 20) / & + & 9.479600E-05,2.334700E-04,7.557000E-04,4.386900E-03,3.534800E-02,& + & 1.554800E-01,4.216700E-01,1.211600E+00,7.469900E+00,3.596500E+01,& + & 6.116200E+01,1.039600E+02,1.684400E+02,2.972500E+02,4.340800E+02,& + & 4.812200E+02,1.436100E-04,3.274000E-04,1.077200E-03,5.098900E-03,& + & 3.165100E-02,1.222600E-01,3.255300E-01,9.175800E-01,5.606200E+00,& + & 2.697500E+01,4.587100E+01,7.797300E+01,1.263300E+02,2.229500E+02,& + & 3.255300E+02,3.608700E+02,1.411800E-04,3.196400E-04,1.052400E-03,& + & 4.379400E-03,2.397200E-02,8.506800E-02,2.269500E-01,6.299600E-01,& + & 3.765000E+00,1.798400E+01,3.058100E+01,5.198400E+01,8.421900E+01,& + & 1.486200E+02,2.170400E+02,2.406000E+02,1.181900E-04,2.756200E-04,& + & 8.561000E-04,3.052100E-03,1.452000E-02,4.570200E-02,1.218400E-01,& + & 3.353600E-01,1.956000E+00,9.023200E+00,1.529100E+01,2.599200E+01,& + & 4.211000E+01,7.431400E+01,1.085100E+02,1.203000E+02,7.630300E-05,& + & 2.367400E-04,5.796000E-04,9.478400E-04,1.207300E-03,2.074000E-03,& + & 4.003000E-03,1.546800E-02,8.527300E-02,2.470500E-01,3.050100E-01,& + & 2.889600E-01,6.474600E-01,8.588300E-01,3.338700E-01,7.399300E+00,& + & 9.738700E-05,2.902700E-04,1.128900E-03,6.948100E-03,5.465700E-02,& + & 2.189700E-01,6.014000E-01,1.681800E+00,1.068000E+01,5.080000E+01,& + & 8.664300E+01,1.481700E+02,2.397400E+02,4.129400E+02,6.111300E+02,& + & 6.920600E+02,1.711500E-04,4.317000E-04,1.573600E-03,7.845800E-03,& + & 4.788000E-02,1.724000E-01,4.638000E-01,1.274600E+00,8.016500E+00,& + & 3.810100E+01,6.498400E+01,1.111300E+02,1.798100E+02,3.097100E+02,& + & 4.584100E+02,5.190700E+02,1.730000E-04,4.348200E-04,1.519100E-03,& + & 6.607800E-03,3.591900E-02,1.200300E-01,3.218400E-01,8.763400E-01,& + & 5.385400E+00,2.540300E+01,4.332400E+01,7.408900E+01,1.198700E+02,& + & 2.064900E+02,3.056000E+02,3.460300E+02,1.482400E-04,3.894300E-04,& + & 1.221300E-03,4.566300E-03,2.142400E-02,6.453800E-02,1.719000E-01,& + & 4.651800E-01,2.803600E+00,1.273900E+01,2.166200E+01,3.704300E+01,& + & 5.993700E+01,1.032400E+02,1.527900E+02,1.730200E+02,1.046900E-04,& + & 3.236500E-04,7.529500E-04,1.096100E-03,1.499700E-03,2.512400E-03,& + & 5.110400E-03,1.870900E-02,1.041100E-01,2.894100E-01,3.806900E-01,& + & 6.407100E-01,7.797700E-01,7.440300E-01,3.406000E+00,1.550100E+01,& + & 1.095100E-04,3.953400E-04,1.789600E-03,1.102300E-02,8.260200E-02,& + & 3.009500E-01,8.181600E-01,2.286500E+00,1.462300E+01,6.840900E+01,& + & 1.170000E+02,2.006100E+02,3.262600E+02,5.550200E+02,8.206200E+02,& + & 9.473800E+02,2.160400E-04,6.068400E-04,2.371400E-03,1.198000E-02,& + & 7.104500E-02,2.362100E-01,6.301500E-01,1.736000E+00,1.097600E+01,& + & 5.130900E+01,8.775100E+01,1.504600E+02,2.446900E+02,4.162500E+02,& + & 6.154700E+02,7.105600E+02,2.232300E-04,6.160200E-04,2.265000E-03,& + & 9.828000E-03,5.256200E-02,1.647900E-01,4.365000E-01,1.194200E+00,& + & 7.375200E+00,3.420800E+01,5.850200E+01,1.003000E+02,1.631300E+02,& + & 2.775100E+02,4.103100E+02,4.737200E+02,1.935000E-04,5.528100E-04,& + & 1.754700E-03,6.743100E-03,3.059900E-02,8.885900E-02,2.329600E-01,& + & 6.352500E-01,3.839100E+00,1.715600E+01,2.925000E+01,5.015200E+01,& + & 8.156600E+01,1.387500E+02,2.051600E+02,2.368300E+02,1.381800E-04,& + & 4.255000E-04,9.211300E-04,1.224000E-03,1.848700E-03,3.038200E-03,& + & 6.436500E-03,2.246900E-02,1.239000E-01,3.377100E-01,4.949100E-01,& + & 7.611600E-01,1.511800E+00,6.600800E-01,7.388900E+00,2.104000E+01,& + & 1.344900E-04,5.750100E-04,2.888100E-03,1.731600E-02,1.197000E-01,& + & 4.048500E-01,1.078000E+00,3.075400E+00,1.926400E+01,8.898100E+01,& + & 1.519000E+02,2.611400E+02,4.267600E+02,7.202900E+02,1.062500E+03,& + & 1.240600E+03,2.855200E-04,8.822900E-04,3.638100E-03,1.800700E-02,& + & 1.013600E-01,3.171900E-01,8.290800E-01,2.337100E+00,1.445900E+01,& + & 6.673900E+01,1.139200E+02,1.958600E+02,3.200600E+02,5.402400E+02,& + & 7.968400E+02,9.304200E+02,2.972800E-04,8.921400E-04,3.341400E-03,& + & 1.466100E-02,7.413900E-02,2.207900E-01,5.727100E-01,1.605400E+00,& + & 9.722600E+00,4.449700E+01,7.595500E+01,1.305700E+02,2.133800E+02,& + & 3.601700E+02,5.312000E+02,6.202900E+02,2.576400E-04,7.850400E-04,& + & 2.521100E-03,9.856800E-03,4.273300E-02,1.184800E-01,3.051900E-01,& + & 8.510200E-01,5.065400E+00,2.233700E+01,3.797700E+01,6.528400E+01,& + & 1.066900E+02,1.800800E+02,2.656000E+02,3.101400E+02,1.759700E-04,& + & 5.348100E-04,1.088600E-03,1.432600E-03,2.211700E-03,3.695900E-03,& + & 7.851400E-03,2.628800E-02,1.461600E-01,3.941800E-01,5.790800E-01,& + & 1.055300E+00,1.664200E+00,1.115500E+00,1.332400E+01,2.913900E+01/ + data absb(:, 21: 40) / & + & 1.757700E-04,8.727400E-04,4.652600E-03,2.662800E-02,1.669700E-01,& + & 5.311800E-01,1.387100E+00,4.047300E+00,2.462900E+01,1.125200E+02,& + & 1.908500E+02,3.283100E+02,5.411900E+02,9.059200E+02,1.331400E+03,& + & 1.570300E+03,3.871400E-04,1.299200E-03,5.501200E-03,2.663200E-02,& + & 1.399600E-01,4.146700E-01,1.065000E+00,3.076100E+00,1.849100E+01,& + & 8.438900E+01,1.431400E+02,2.462200E+02,4.058900E+02,6.794600E+02,& + & 9.986100E+02,1.177800E+03,4.035900E-04,1.295700E-03,4.900500E-03,& + & 2.130100E-02,1.016000E-01,2.879600E-01,7.356600E-01,2.111300E+00,& + & 1.243700E+01,5.626000E+01,9.542900E+01,1.641500E+02,2.705900E+02,& + & 4.529600E+02,6.657500E+02,7.852200E+02,3.465400E-04,1.107200E-03,& + & 3.609900E-03,1.410700E-02,5.775500E-02,1.543800E-01,3.920200E-01,& + & 1.116200E+00,6.479200E+00,2.828400E+01,4.771500E+01,8.207100E+01,& + & 1.353000E+02,2.264800E+02,3.328700E+02,3.925900E+02,2.185100E-04,& + & 6.584500E-04,1.271500E-03,1.671500E-03,2.621000E-03,4.310300E-03,& + & 9.693100E-03,3.027600E-02,1.701400E-01,4.634800E-01,6.697900E-01,& + & 1.406700E+00,1.731300E+00,2.546500E+00,1.851000E+01,3.930800E+01,& + & 7.900000E-05,2.001900E-04,6.562800E-04,3.885600E-03,3.141300E-02,& + & 1.373200E-01,3.842500E-01,1.107800E+00,6.893800E+00,3.477300E+01,& + & 6.201400E+01,1.113500E+02,1.904100E+02,3.243500E+02,4.892700E+02,& + & 5.757600E+02,1.211300E-04,2.799900E-04,9.236900E-04,4.561500E-03,& + & 2.797100E-02,1.082500E-01,2.980100E-01,8.405900E-01,5.178300E+00,& + & 2.607900E+01,4.651100E+01,8.351200E+01,1.428100E+02,2.432600E+02,& + & 3.669600E+02,4.318200E+02,1.192000E-04,2.724800E-04,9.024900E-04,& + & 3.890700E-03,2.108900E-02,7.539700E-02,2.068800E-01,5.794600E-01,& + & 3.487500E+00,1.738600E+01,3.100700E+01,5.567600E+01,9.520500E+01,& + & 1.621700E+02,2.446500E+02,2.878800E+02,9.966400E-05,2.356100E-04,& + & 7.314400E-04,2.692400E-03,1.278200E-02,4.049500E-02,1.105500E-01,& + & 3.061200E-01,1.826400E+00,8.785000E+00,1.550400E+01,2.783900E+01,& + & 4.760400E+01,8.109200E+01,1.223300E+02,1.439400E+02,6.364600E-05,& + & 2.089200E-04,5.216600E-04,7.676300E-04,9.983400E-04,1.753800E-03,& + & 3.466800E-03,1.206300E-02,7.671400E-02,2.351400E-01,3.559200E-01,& + & 4.105300E-01,4.859300E-01,7.809800E-01,1.463900E+00,1.400900E+01,& + & 8.187000E-05,2.525200E-04,1.000100E-03,6.225300E-03,4.900100E-02,& + & 1.946300E-01,5.438600E-01,1.533500E+00,9.852700E+00,4.875400E+01,& + & 8.723800E+01,1.569500E+02,2.694300E+02,4.489200E+02,6.924700E+02,& + & 8.324400E+02,1.452600E-04,3.744800E-04,1.368100E-03,7.052800E-03,& + & 4.266900E-02,1.534400E-01,4.209300E-01,1.166100E+00,7.400600E+00,& + & 3.656500E+01,6.543100E+01,1.177100E+02,2.020700E+02,3.366800E+02,& + & 5.193800E+02,6.243100E+02,1.470500E-04,3.754600E-04,1.319700E-03,& + & 5.896800E-03,3.189000E-02,1.067000E-01,2.917700E-01,8.049900E-01,& + & 4.985100E+00,2.437600E+01,4.362100E+01,7.847500E+01,1.347200E+02,& + & 2.244400E+02,3.462400E+02,4.161900E+02,1.255700E-04,3.347800E-04,& + & 1.046900E-03,4.041800E-03,1.890100E-02,5.741700E-02,1.554400E-01,& + & 4.262700E-01,2.610600E+00,1.231600E+01,2.181100E+01,3.924000E+01,& + & 6.736000E+01,1.122300E+02,1.731100E+02,2.080900E+02,8.637600E-05,& + & 2.857400E-04,6.614800E-04,8.605100E-04,1.274900E-03,2.172500E-03,& + & 4.542900E-03,1.471800E-02,9.207700E-02,2.903500E-01,3.921900E-01,& + & 6.237200E-01,1.052300E+00,5.460200E-01,5.016100E+00,1.913500E+01,& + & 9.297500E-05,3.459900E-04,1.603700E-03,1.000200E-02,7.364800E-02,& + & 2.689600E-01,7.399800E-01,2.088400E+00,1.346400E+01,6.553500E+01,& + & 1.171400E+02,2.112100E+02,3.632600E+02,6.009900E+02,9.369300E+02,& + & 1.139200E+03,1.845100E-04,5.324600E-04,2.085900E-03,1.075200E-02,& + & 6.316900E-02,2.117300E-01,5.713700E-01,1.588600E+00,1.011500E+01,& + & 4.915100E+01,8.785100E+01,1.584100E+02,2.724400E+02,4.507500E+02,& + & 7.026300E+02,8.543600E+02,1.906300E-04,5.378800E-04,1.973800E-03,& + & 8.858200E-03,4.655700E-02,1.473900E-01,3.949700E-01,1.094900E+00,& + & 6.818800E+00,3.276900E+01,5.857000E+01,1.056000E+02,1.816200E+02,& + & 3.004900E+02,4.683900E+02,5.695600E+02,1.648900E-04,4.775100E-04,& + & 1.515100E-03,6.006500E-03,2.714000E-02,7.925400E-02,2.099500E-01,& + & 5.805000E-01,3.570700E+00,1.656600E+01,2.928700E+01,5.280200E+01,& + & 9.081300E+01,1.502500E+02,2.342200E+02,2.848000E+02,1.134800E-04,& + & 3.697800E-04,7.935000E-04,1.006500E-03,1.554500E-03,2.681000E-03,& + & 5.617100E-03,1.785700E-02,1.092600E-01,3.540100E-01,4.429200E-01,& + & 8.030100E-01,1.465800E+00,1.032500E+00,9.213600E+00,2.579800E+01/ + data absb(:, 41: 60) / & + & 1.149900E-04,5.087300E-04,2.622500E-03,1.569900E-02,1.063300E-01,& + & 3.629400E-01,9.764200E-01,2.812000E+00,1.771700E+01,8.515200E+01,& + & 1.513900E+02,2.731300E+02,4.708200E+02,7.793700E+02,1.219800E+03,& + & 1.497000E+03,2.447800E-04,7.799200E-04,3.228400E-03,1.622900E-02,& + & 9.003500E-02,2.844600E-01,7.524600E-01,2.141300E+00,1.331100E+01,& + & 6.387100E+01,1.135400E+02,2.048500E+02,3.531200E+02,5.845300E+02,& + & 9.148400E+02,1.122600E+03,2.546000E-04,7.860700E-04,2.928100E-03,& + & 1.316300E-02,6.578800E-02,1.976100E-01,5.195200E-01,1.474500E+00,& + & 8.974900E+00,4.258300E+01,7.569900E+01,1.365700E+02,2.354200E+02,& + & 3.896900E+02,6.098900E+02,7.484400E+02,2.203100E-04,6.814500E-04,& + & 2.194100E-03,8.797000E-03,3.784200E-02,1.059100E-01,2.757700E-01,& + & 7.809800E-01,4.700000E+00,2.154300E+01,3.786400E+01,6.828300E+01,& + & 1.177100E+02,1.948500E+02,3.049500E+02,3.742300E+02,1.445100E-04,& + & 4.636900E-04,9.271600E-04,1.222700E-03,1.868000E-03,3.174800E-03,& + & 6.986700E-03,2.100700E-02,1.281500E-01,4.095200E-01,5.246000E-01,& + & 1.017000E+00,1.612000E+00,1.501600E+00,1.601500E+01,3.561200E+01,& + & 1.507700E-04,7.793700E-04,4.243700E-03,2.426900E-02,1.484700E-01,& + & 4.775200E-01,1.261000E+00,3.698900E+00,2.268100E+01,1.071400E+02,& + & 1.898200E+02,3.412400E+02,5.908600E+02,9.803400E+02,1.542400E+03,& + & 1.899900E+03,3.322800E-04,1.154400E-03,4.900200E-03,2.403000E-02,& + & 1.245200E-01,3.732300E-01,9.701700E-01,2.818900E+00,1.704100E+01,& + & 8.035400E+01,1.423500E+02,2.559200E+02,4.431200E+02,7.352700E+02,& + & 1.156800E+03,1.424900E+03,3.458000E-04,1.146400E-03,4.318700E-03,& + & 1.913700E-02,9.018000E-02,2.590500E-01,6.688800E-01,1.939600E+00,& + & 1.149200E+01,5.357000E+01,9.490800E+01,1.706200E+02,2.954200E+02,& + & 4.901800E+02,7.712200E+02,9.498500E+02,2.971600E-04,9.630000E-04,& + & 3.169100E-03,1.253600E-02,5.112300E-02,1.386400E-01,3.542700E-01,& + & 1.025700E+00,6.017800E+00,2.712700E+01,4.748400E+01,8.530800E+01,& + & 1.477100E+02,2.451000E+02,3.856000E+02,4.749800E+02,1.779800E-04,& + & 5.708400E-04,1.060900E-03,1.447400E-03,2.212400E-03,3.768400E-03,& + & 8.653500E-03,2.429500E-02,1.488500E-01,4.686100E-01,6.625700E-01,& + & 1.106400E+00,1.846200E+00,3.489400E+00,2.060700E+01,4.789700E+01,& + & 6.314600E-05,1.649600E-04,5.502100E-04,3.265900E-03,2.669100E-02,& + & 1.160900E-01,3.329900E-01,9.704200E-01,6.104700E+00,3.170800E+01,& + & 5.918600E+01,1.118600E+02,2.033100E+02,3.443000E+02,5.441900E+02,& + & 6.768600E+02,9.937300E-05,2.331300E-04,7.705800E-04,3.877000E-03,& + & 2.376700E-02,9.186400E-02,2.593300E-01,7.394700E-01,4.590800E+00,& + & 2.378000E+01,4.438800E+01,8.389700E+01,1.524900E+02,2.582300E+02,& + & 4.081500E+02,5.075800E+02,9.837300E-05,2.274500E-04,7.499700E-04,& + & 3.310100E-03,1.791800E-02,6.405600E-02,1.799100E-01,5.103400E-01,& + & 3.107400E+00,1.585400E+01,2.959200E+01,5.593500E+01,1.016500E+02,& + & 1.721500E+02,2.720900E+02,3.384500E+02,8.269100E-05,1.981500E-04,& + & 6.072100E-04,2.304800E-03,1.084600E-02,3.449600E-02,9.590500E-02,& + & 2.694900E-01,1.639200E+00,8.078000E+00,1.484100E+01,2.796600E+01,& + & 5.082800E+01,8.607100E+01,1.360500E+02,1.692200E+02,5.239700E-05,& + & 1.719100E-04,4.551300E-04,5.757300E-04,8.437600E-04,1.472400E-03,& + & 2.988600E-03,9.793800E-03,6.276800E-02,2.272500E-01,3.202100E-01,& + & 4.895200E-01,7.021100E-01,4.744200E-01,3.320500E+00,1.723200E+01,& + & 6.607800E-05,2.099500E-04,8.504600E-04,5.324100E-03,4.156300E-02,& + & 1.657500E-01,4.696200E-01,1.343600E+00,8.701900E+00,4.429900E+01,& + & 8.263800E+01,1.563800E+02,2.849100E+02,4.769400E+02,7.678500E+02,& + & 9.758500E+02,1.200600E-04,3.164200E-04,1.153300E-03,6.037200E-03,& + & 3.632800E-02,1.309900E-01,3.644800E-01,1.026200E+00,6.544200E+00,& + & 3.322700E+01,6.197900E+01,1.172900E+02,2.136900E+02,3.577000E+02,& + & 5.758800E+02,7.319300E+02,1.222800E-04,3.172500E-04,1.117300E-03,& + & 5.049400E-03,2.713000E-02,9.123400E-02,2.523400E-01,7.087400E-01,& + & 4.430100E+00,2.214900E+01,4.131900E+01,7.819400E+01,1.424600E+02,& + & 2.384600E+02,3.839200E+02,4.879000E+02,1.046900E-04,2.835200E-04,& + & 8.762600E-04,3.491600E-03,1.608200E-02,4.916100E-02,1.342100E-01,& + & 3.751700E-01,2.335600E+00,1.130100E+01,2.071300E+01,3.909700E+01,& + & 7.123200E+01,1.192400E+02,1.919800E+02,2.439500E+02,7.041100E-05,& + & 2.330000E-04,5.609300E-04,6.832100E-04,1.061100E-03,1.869500E-03,& + & 3.871800E-03,1.220300E-02,7.576800E-02,2.723700E-01,3.770800E-01,& + & 5.850700E-01,1.119300E+00,9.895700E-01,6.458500E+00,2.352100E+01/ + data absb(:, 61: 80) / & + & 7.582100E-05,2.905800E-04,1.382800E-03,8.600200E-03,6.255900E-02,& + & 2.296200E-01,6.398700E-01,1.844900E+00,1.184700E+01,5.945100E+01,& + & 1.102800E+02,2.087800E+02,3.810400E+02,6.365900E+02,1.042000E+03,& + & 1.337700E+03,1.536000E-04,4.540600E-04,1.789800E-03,9.208600E-03,& + & 5.385800E-02,1.810900E-01,4.951200E-01,1.410900E+00,8.909100E+00,& + & 4.458700E+01,8.271600E+01,1.565900E+02,2.857900E+02,4.774500E+02,& + & 7.815400E+02,1.003200E+03,1.586900E-04,4.609000E-04,1.663000E-03,& + & 7.633400E-03,3.963200E-02,1.260300E-01,3.421100E-01,9.724800E-01,& + & 6.035400E+00,2.972700E+01,5.514400E+01,1.043900E+02,1.905400E+02,& + & 3.182900E+02,5.210200E+02,6.688100E+02,1.381400E-04,4.058200E-04,& + & 1.277200E-03,5.197400E-03,2.313300E-02,6.781400E-02,1.815000E-01,& + & 5.131600E-01,3.184000E+00,1.517500E+01,2.765200E+01,5.219700E+01,& + & 9.526300E+01,1.591500E+02,2.605000E+02,3.344100E+02,9.160300E-05,& + & 3.007900E-04,6.612900E-04,8.473600E-04,1.284500E-03,2.293500E-03,& + & 4.880500E-03,1.480700E-02,9.015200E-02,3.148000E-01,4.648800E-01,& + & 6.768700E-01,1.348200E+00,1.327700E+00,1.259300E+01,3.174000E+01,& + & 9.437200E-05,4.318000E-04,2.288500E-03,1.354700E-02,9.047700E-02,& + & 3.107700E-01,8.458600E-01,2.462600E+00,1.562700E+01,7.691400E+01,& + & 1.420100E+02,2.679000E+02,4.898600E+02,8.231600E+02,1.365000E+03,& + & 1.757500E+03,2.044800E-04,6.678600E-04,2.767100E-03,1.399200E-02,& + & 7.684400E-02,2.443000E-01,6.538800E-01,1.884000E+00,1.175300E+01,& + & 5.768800E+01,1.065100E+02,2.009200E+02,3.674000E+02,6.173500E+02,& + & 1.023900E+03,1.318100E+03,2.127900E-04,6.743900E-04,2.497700E-03,& + & 1.134700E-02,5.621600E-02,1.693400E-01,4.515500E-01,1.300600E+00,& + & 7.959200E+00,3.846000E+01,7.100800E+01,1.339500E+02,2.449200E+02,& + & 4.115700E+02,6.825400E+02,8.787600E+02,1.852100E-04,5.793800E-04,& + & 1.867400E-03,7.583400E-03,3.222300E-02,9.095700E-02,2.390800E-01,& + & 6.903000E-01,4.191800E+00,1.963300E+01,3.563500E+01,6.697900E+01,& + & 1.224600E+02,2.057800E+02,3.412700E+02,4.393500E+02,1.158700E-04,& + & 3.780200E-04,7.605700E-04,1.028700E-03,1.561700E-03,2.763300E-03,& + & 6.127900E-03,1.751800E-02,1.059600E-01,3.589500E-01,5.364300E-01,& + & 7.898100E-01,1.609400E+00,2.654500E+00,1.774300E+01,4.332100E+01,& + & 1.241600E-04,6.667400E-04,3.700000E-03,2.100900E-02,1.265500E-01,& + & 4.096800E-01,1.094800E+00,3.224100E+00,2.006500E+01,9.618700E+01,& + & 1.778000E+02,3.330500E+02,6.093200E+02,1.033900E+03,1.732800E+03,& + & 2.230800E+03,2.775300E-04,9.969700E-04,4.235400E-03,2.076200E-02,& + & 1.061300E-01,3.216000E-01,8.442800E-01,2.464000E+00,1.509600E+01,& + & 7.213700E+01,1.333600E+02,2.498100E+02,4.569900E+02,7.753600E+02,& + & 1.299500E+03,1.673000E+03,2.896700E-04,9.845100E-04,3.711800E-03,& + & 1.657400E-02,7.665200E-02,2.230200E-01,5.824600E-01,1.695700E+00,& + & 1.022900E+01,4.809700E+01,8.890800E+01,1.665400E+02,3.046800E+02,& + & 5.169500E+02,8.663600E+02,1.115400E+03,2.501000E-04,8.207600E-04,& + & 2.714600E-03,1.081100E-02,4.356100E-02,1.192500E-01,3.083900E-01,& + & 8.976600E-01,5.386700E+00,2.453700E+01,4.468000E+01,8.327200E+01,& + & 1.523300E+02,2.584400E+02,4.331900E+02,5.577400E+02,1.440900E-04,& + & 4.709900E-04,8.702400E-04,1.206600E-03,1.906100E-03,3.281900E-03,& + & 7.484900E-03,2.076700E-02,1.234800E-01,4.013600E-01,6.180900E-01,& + & 9.554000E-01,1.679800E+00,4.875300E+00,2.277900E+01,5.799900E+01,& + & 4.933500E-05,1.327300E-04,4.518100E-04,2.669700E-03,2.198600E-02,& + & 9.638700E-02,2.805100E-01,8.299500E-01,5.271000E+00,2.800000E+01,& + & 5.387700E+01,1.074100E+02,2.077400E+02,3.622400E+02,5.996100E+02,& + & 7.863700E+02,8.023700E-05,1.916000E-04,6.319200E-04,3.223400E-03,& + & 1.971600E-02,7.649300E-02,2.189900E-01,6.367100E-01,3.970600E+00,& + & 2.100100E+01,4.040700E+01,8.055200E+01,1.558300E+02,2.716800E+02,& + & 4.496800E+02,5.898300E+02,8.024700E-05,1.886300E-04,6.174800E-04,& + & 2.752900E-03,1.493800E-02,5.333500E-02,1.518300E-01,4.395400E-01,& + & 2.705200E+00,1.400800E+01,2.694000E+01,5.370600E+01,1.038800E+02,& + & 1.811100E+02,2.997800E+02,3.932100E+02,6.803600E-05,1.653400E-04,& + & 4.952200E-04,1.945100E-03,9.017200E-03,2.883500E-02,8.089600E-02,& + & 2.320600E-01,1.438300E+00,7.187900E+00,1.361700E+01,2.685200E+01,& + & 5.193700E+01,9.055500E+01,1.498900E+02,1.966100E+02,4.262300E-05,& + & 1.403400E-04,3.656600E-04,4.418400E-04,6.942600E-04,1.227300E-03,& + & 2.550900E-03,8.072000E-03,5.064000E-02,1.868400E-01,3.045900E-01,& + & 4.187400E-01,8.399900E-01,8.636100E-01,4.394900E+00,2.108800E+01/ + data absb(:, 81:100) / & + & 5.217300E-05,1.702200E-04,7.083700E-04,4.418600E-03,3.444800E-02,& + & 1.376900E-01,3.950600E-01,1.157000E+00,7.484300E+00,3.898300E+01,& + & 7.473200E+01,1.489800E+02,2.888300E+02,5.015500E+02,8.404400E+02,& + & 1.133300E+03,9.783400E-05,2.627400E-04,9.644300E-04,5.034700E-03,& + & 3.020100E-02,1.091700E-01,3.078100E-01,8.883500E-01,5.638600E+00,& + & 2.923800E+01,5.605200E+01,1.117400E+02,2.166200E+02,3.761500E+02,& + & 6.303200E+02,8.499500E+02,1.002200E-04,2.659000E-04,9.202800E-04,& + & 4.252300E-03,2.256300E-02,7.607400E-02,2.130200E-01,6.126000E-01,& + & 3.843500E+00,1.950000E+01,3.736800E+01,7.448900E+01,1.444200E+02,& + & 2.507700E+02,4.201900E+02,5.666600E+02,8.672500E-05,2.377400E-04,& + & 7.244900E-04,2.948600E-03,1.340200E-02,4.111700E-02,1.132400E-01,& + & 3.236900E-01,2.042800E+00,1.000700E+01,1.889500E+01,3.724400E+01,& + & 7.220900E+01,1.253900E+02,2.101100E+02,2.833200E+02,5.721100E-05,& + & 1.865500E-04,4.422400E-04,5.582600E-04,8.652800E-04,1.560700E-03,& + & 3.310800E-03,1.009100E-02,6.069000E-02,2.311100E-01,3.638100E-01,& + & 5.040500E-01,1.026800E+00,1.309800E+00,9.120100E+00,2.869000E+01,& + & 6.046100E-05,2.379800E-04,1.171900E-03,7.154600E-03,5.194300E-02,& + & 1.913100E-01,5.387000E-01,1.578100E+00,1.020300E+01,5.209000E+01,& + & 9.930300E+01,1.972100E+02,3.830200E+02,6.668200E+02,1.143800E+03,& + & 1.549700E+03,1.260500E-04,3.789400E-04,1.507100E-03,7.728000E-03,& + & 4.483700E-02,1.512300E-01,4.185500E-01,1.212800E+00,7.686900E+00,& + & 3.907100E+01,7.447300E+01,1.478900E+02,2.872900E+02,5.001200E+02,& + & 8.577000E+02,1.162300E+03,1.306100E-04,3.874800E-04,1.391600E-03,& + & 6.404000E-03,3.311600E-02,1.052300E-01,2.893800E-01,8.372500E-01,& + & 5.238000E+00,2.606300E+01,4.964900E+01,9.859900E+01,1.915300E+02,& + & 3.334300E+02,5.719500E+02,7.749300E+02,1.147000E-04,3.403200E-04,& + & 1.070400E-03,4.400100E-03,1.927400E-02,5.673800E-02,1.535700E-01,& + & 4.435400E-01,2.780900E+00,1.338000E+01,2.512400E+01,4.930100E+01,& + & 9.577000E+01,1.667200E+02,2.859500E+02,3.874500E+02,7.432400E-05,& + & 2.399800E-04,5.187800E-04,6.888100E-04,1.058000E-03,1.963800E-03,& + & 4.201300E-03,1.234900E-02,7.201700E-02,2.716800E-01,4.232500E-01,& + & 6.190100E-01,1.205400E+00,2.081000E+00,1.470900E+01,3.894900E+01,& + & 7.569400E-05,3.581200E-04,1.934700E-03,1.140600E-02,7.519200E-02,& + & 2.589900E-01,7.152600E-01,2.103800E+00,1.347800E+01,6.696200E+01,& + & 1.276800E+02,2.514400E+02,4.885600E+02,8.598000E+02,1.499300E+03,& + & 2.033000E+03,1.682700E-04,5.638100E-04,2.341000E-03,1.181100E-02,& + & 6.404800E-02,2.039900E-01,5.544900E-01,1.617600E+00,1.015500E+01,& + & 5.022300E+01,9.575400E+01,1.885900E+02,3.664200E+02,6.448500E+02,& + & 1.124500E+03,1.524700E+03,1.757200E-04,5.680700E-04,2.105400E-03,& + & 9.585500E-03,4.676700E-02,1.416500E-01,3.828300E-01,1.117100E+00,& + & 6.917000E+00,3.351700E+01,6.383700E+01,1.257300E+02,2.442700E+02,& + & 4.299000E+02,7.496500E+02,1.016400E+03,1.540400E-04,4.859900E-04,& + & 1.575000E-03,6.424100E-03,2.682900E-02,7.620300E-02,2.026900E-01,& + & 5.921600E-01,3.668700E+00,1.721700E+01,3.232500E+01,6.287900E+01,& + & 1.221300E+02,2.149600E+02,3.748400E+02,5.082100E+02,9.368600E-05,& + & 3.061700E-04,5.938100E-04,8.329500E-04,1.313200E-03,2.361800E-03,& + & 5.190200E-03,1.475500E-02,8.524300E-02,3.109100E-01,4.728500E-01,& + & 7.494700E-01,1.263000E+00,4.011800E+00,1.951700E+01,5.250000E+01,& + & 9.995500E-05,5.554000E-04,3.126700E-03,1.778100E-02,1.049200E-01,& + & 3.421400E-01,9.272700E-01,2.738500E+00,1.736500E+01,8.357000E+01,& + & 1.592700E+02,3.105800E+02,6.047100E+02,1.076800E+03,1.902600E+03,& + & 2.578900E+03,2.286600E-04,8.447800E-04,3.593300E-03,1.757700E-02,& + & 8.810900E-02,2.693400E-01,7.178500E-01,2.102300E+00,1.308800E+01,& + & 6.268700E+01,1.194500E+02,2.329500E+02,4.535400E+02,8.075600E+02,& + & 1.427000E+03,1.934200E+03,2.395600E-04,8.310900E-04,3.144600E-03,& + & 1.400100E-02,6.382700E-02,1.867500E-01,4.954800E-01,1.449000E+00,& + & 8.912300E+00,4.185800E+01,7.963200E+01,1.552900E+02,3.023500E+02,& + & 5.383800E+02,9.513300E+02,1.289500E+03,2.082600E-04,6.877000E-04,& + & 2.301200E-03,9.164500E-03,3.631200E-02,1.001400E-01,2.620000E-01,& + & 7.689200E-01,4.718200E+00,2.153100E+01,4.035100E+01,7.768600E+01,& + & 1.511800E+02,2.691900E+02,4.756900E+02,6.447800E+02,1.154800E-04,& + & 3.797300E-04,6.879000E-04,9.709800E-04,1.600600E-03,2.828100E-03,& + & 6.406800E-03,1.766700E-02,9.904000E-02,3.627600E-01,5.097600E-01,& + & 8.749100E-01,1.561100E+00,6.015100E+00,2.499500E+01,6.950500E+01/ + data absb(:,101:120) / & + & 3.826600E-05,1.057700E-04,3.714900E-04,2.189600E-03,1.806700E-02,& + & 7.927100E-02,2.337800E-01,7.069200E-01,4.490200E+00,2.426400E+01,& + & 4.764800E+01,9.983800E+01,2.058900E+02,3.801100E+02,6.574000E+02,& + & 9.137100E+02,6.444900E-05,1.568000E-04,5.200800E-04,2.653800E-03,& + & 1.624200E-02,6.312600E-02,1.831800E-01,5.458600E-01,3.391100E+00,& + & 1.819800E+01,3.573500E+01,7.487900E+01,1.544200E+02,2.850900E+02,& + & 4.930400E+02,6.852900E+02,6.517200E-05,1.553600E-04,5.076200E-04,& + & 2.290400E-03,1.231700E-02,4.410000E-02,1.269800E-01,3.766100E-01,& + & 2.324400E+00,1.219500E+01,2.382300E+01,4.991900E+01,1.029400E+02,& + & 1.900700E+02,3.286800E+02,4.568600E+02,5.578900E-05,1.378600E-04,& + & 4.075700E-04,1.641400E-03,7.458700E-03,2.391700E-02,6.771700E-02,& + & 1.988900E-01,1.248100E+00,6.266400E+00,1.216400E+01,2.501200E+01,& + & 5.147300E+01,9.502900E+01,1.643400E+02,2.284300E+02,3.513000E-05,& + & 1.141600E-04,2.884700E-04,3.548000E-04,5.808400E-04,1.021700E-03,& + & 2.192700E-03,6.748300E-03,4.028300E-02,1.702100E-01,2.574400E-01,& + & 3.933800E-01,7.089800E-01,1.272000E+00,5.987700E+00,2.551800E+01,& + & 4.089500E-05,1.365900E-04,5.883200E-04,3.644400E-03,2.844300E-02,& + & 1.134500E-01,3.294800E-01,9.829500E-01,6.373900E+00,3.364500E+01,& + & 6.572400E+01,1.371700E+02,2.838300E+02,5.260100E+02,9.176900E+02,& + & 1.311600E+03,7.929700E-05,2.165800E-04,8.061200E-04,4.189700E-03,& + & 2.505400E-02,9.018200E-02,2.574200E-01,7.589300E-01,4.815200E+00,& + & 2.523400E+01,4.929300E+01,1.028700E+02,2.128700E+02,3.944800E+02,& + & 6.882500E+02,9.836600E+02,8.175800E-05,2.214700E-04,7.616900E-04,& + & 3.544000E-03,1.872000E-02,6.297700E-02,1.782200E-01,5.230700E-01,& + & 3.300500E+00,1.691300E+01,3.286300E+01,6.858300E+01,1.419100E+02,& + & 2.630100E+02,4.588400E+02,6.557400E+02,7.154800E-05,1.976600E-04,& + & 6.034800E-04,2.480500E-03,1.109800E-02,3.415600E-02,9.489600E-02,& + & 2.765900E-01,1.769300E+00,8.704900E+00,1.679200E+01,3.436100E+01,& + & 7.095700E+01,1.315000E+02,2.294100E+02,3.278800E+02,4.678100E-05,& + & 1.513600E-04,3.472300E-04,4.497100E-04,7.233400E-04,1.329900E-03,& + & 2.858400E-03,8.485000E-03,4.902500E-02,1.975100E-01,3.105900E-01,& + & 4.789300E-01,8.756600E-01,1.554300E+00,1.158900E+01,3.490400E+01,& + & 4.780700E-05,1.935300E-04,9.799500E-04,5.991600E-03,4.279500E-02,& + & 1.579700E-01,4.500000E-01,1.336700E+00,8.702800E+00,4.464300E+01,& + & 8.713800E+01,1.805200E+02,3.735400E+02,6.976100E+02,1.244100E+03,& + & 1.788000E+03,1.027800E-04,3.159100E-04,1.258200E-03,6.468600E-03,& + & 3.706200E-02,1.251100E-01,3.508000E-01,1.032700E+00,6.574000E+00,& + & 3.348600E+01,6.534900E+01,1.353900E+02,2.801600E+02,5.232000E+02,& + & 9.331100E+02,1.341000E+03,1.069700E-04,3.244700E-04,1.165400E-03,& + & 5.374300E-03,2.740800E-02,8.708700E-02,2.424100E-01,7.137300E-01,& + & 4.502200E+00,2.245200E+01,4.356900E+01,9.025900E+01,1.867800E+02,& + & 3.488000E+02,6.220300E+02,8.939600E+02,9.484000E-05,2.833700E-04,& + & 8.980300E-04,3.697400E-03,1.596500E-02,4.705900E-02,1.287200E-01,& + & 3.788400E-01,2.407000E+00,1.158600E+01,2.227000E+01,4.524200E+01,& + & 9.338900E+01,1.743900E+02,3.110300E+02,4.469800E+02,6.013300E-05,& + & 1.966100E-04,4.048300E-04,5.579900E-04,9.009900E-04,1.662800E-03,& + & 3.612600E-03,1.047800E-02,5.928300E-02,2.220100E-01,3.584700E-01,& + & 5.726200E-01,1.008300E+00,2.984100E+00,1.607000E+01,4.741200E+01,& + & 6.015900E-05,2.939300E-04,1.614700E-03,9.596300E-03,6.191900E-02,& + & 2.140200E-01,5.988700E-01,1.775600E+00,1.153000E+01,5.720700E+01,& + & 1.116900E+02,2.288000E+02,4.740600E+02,8.951500E+02,1.628600E+03,& + & 2.341100E+03,1.376500E-04,4.724100E-04,1.968500E-03,9.912800E-03,& + & 5.289100E-02,1.689700E-01,4.657900E-01,1.369700E+00,8.713900E+00,& + & 4.290200E+01,8.376900E+01,1.716000E+02,3.555300E+02,6.713600E+02,& + & 1.221400E+03,1.755800E+03,1.444600E-04,4.760900E-04,1.773300E-03,& + & 8.055300E-03,3.865300E-02,1.175200E-01,3.215100E-01,9.434400E-01,& + & 5.968300E+00,2.879100E+01,5.584500E+01,1.144000E+02,2.370200E+02,& + & 4.475700E+02,8.143500E+02,1.170500E+03,1.275900E-04,4.046000E-04,& + & 1.329800E-03,5.406800E-03,2.222100E-02,6.333200E-02,1.704200E-01,& + & 4.998000E-01,3.183900E+00,1.489900E+01,2.854300E+01,5.739500E+01,& + & 1.185100E+02,2.237800E+02,4.071600E+02,5.852600E+02,7.513900E-05,& + & 2.488700E-04,4.713600E-04,6.724100E-04,1.119300E-03,2.015100E-03,& + & 4.520800E-03,1.279700E-02,7.021700E-02,2.555400E-01,4.018400E-01,& + & 6.830600E-01,1.240900E+00,4.640900E+00,2.126300E+01,6.321800E+01/ + data absb(:,121:140) / & + & 7.974700E-05,4.559800E-04,2.607100E-03,1.502500E-02,8.621900E-02,& + & 2.830500E-01,7.771100E-01,2.312700E+00,1.491000E+01,7.119300E+01,& + & 1.384600E+02,2.822000E+02,5.825200E+02,1.118100E+03,2.064700E+03,& + & 2.960300E+03,1.870400E-04,7.074000E-04,3.024700E-03,1.480900E-02,& + & 7.260800E-02,2.233200E-01,6.035700E-01,1.783800E+00,1.126600E+01,& + & 5.340200E+01,1.038500E+02,2.116500E+02,4.368800E+02,8.385700E+02,& + & 1.548500E+03,2.220400E+03,1.969200E-04,6.958900E-04,2.645000E-03,& + & 1.181000E-02,5.268700E-02,1.550200E-01,4.166000E-01,1.230300E+00,& + & 7.705800E+00,3.585600E+01,6.923700E+01,1.410900E+02,2.912600E+02,& + & 5.590300E+02,1.032300E+03,1.480100E+03,1.725900E-04,5.745200E-04,& + & 1.945800E-03,7.716000E-03,2.995700E-02,8.341500E-02,2.203500E-01,& + & 6.534700E-01,4.097300E+00,1.860800E+01,3.538600E+01,7.087000E+01,& + & 1.456300E+02,2.795400E+02,5.161700E+02,7.400600E+02,9.164800E-05,& + & 3.030400E-04,5.592100E-04,7.706300E-04,1.367100E-03,2.463800E-03,& + & 5.553900E-03,1.535500E-02,8.109200E-02,2.954700E-01,4.625400E-01,& + & 7.602200E-01,1.570100E+00,6.615700E+00,2.719400E+01,8.234400E+01,& + & 2.918400E-05,8.275000E-05,3.006100E-04,1.799700E-03,1.470800E-02,& + & 6.421100E-02,1.922700E-01,5.910800E-01,3.751200E+00,2.047700E+01,& + & 4.073100E+01,8.883600E+01,1.963100E+02,3.922200E+02,7.074300E+02,& + & 1.045300E+03,5.121100E-05,1.268600E-04,4.288400E-04,2.188600E-03,& + & 1.332700E-02,5.130200E-02,1.511000E-01,4.583600E-01,2.845900E+00,& + & 1.535600E+01,3.055000E+01,6.662700E+01,1.472300E+02,2.941500E+02,& + & 5.305600E+02,7.840100E+02,5.236200E-05,1.274200E-04,4.164800E-04,& + & 1.908200E-03,1.011300E-02,3.590200E-02,1.048300E-01,3.162500E-01,& + & 1.961200E+00,1.036700E+01,2.039800E+01,4.442100E+01,9.815100E+01,& + & 1.961100E+02,3.537100E+02,5.226700E+02,4.545100E-05,1.140300E-04,& + & 3.375400E-04,1.367000E-03,6.129000E-03,1.955400E-02,5.603200E-02,& + & 1.674400E-01,1.062200E+00,5.362200E+00,1.048200E+01,2.242300E+01,& + & 4.907600E+01,9.805100E+01,1.768500E+02,2.613200E+02,2.893700E-05,& + & 9.396100E-05,2.312700E-04,2.902100E-04,4.831600E-04,8.798300E-04,& + & 1.922000E-03,5.728700E-03,3.438200E-02,1.353400E-01,2.292900E-01,& + & 3.735500E-01,6.527700E-01,1.380200E+00,7.546500E+00,3.056500E+01,& + & 3.150200E-05,1.079300E-04,4.824600E-04,3.012000E-03,2.313600E-02,& + & 9.212000E-02,2.713500E-01,8.205200E-01,5.326500E+00,2.817800E+01,& + & 5.603800E+01,1.213600E+02,2.679400E+02,5.410500E+02,9.847300E+02,& + & 1.493500E+03,6.360500E-05,1.770700E-04,6.679300E-04,3.474600E-03,& + & 2.049100E-02,7.343300E-02,2.123800E-01,6.368100E-01,4.041200E+00,& + & 2.113200E+01,4.202700E+01,9.101700E+01,2.009500E+02,4.057700E+02,& + & 7.385600E+02,1.120200E+03,6.609600E-05,1.835300E-04,6.327000E-04,& + & 2.945000E-03,1.534100E-02,5.135500E-02,1.470700E-01,4.394500E-01,& + & 2.783500E+00,1.427800E+01,2.805800E+01,6.067900E+01,1.339700E+02,& + & 2.705300E+02,4.923500E+02,7.467400E+02,5.859100E-05,1.633600E-04,& + & 5.043200E-04,2.070600E-03,9.114700E-03,2.789000E-02,7.838200E-02,& + & 2.328900E-01,1.502600E+00,7.414900E+00,1.442100E+01,3.065100E+01,& + & 6.698300E+01,1.352600E+02,2.461800E+02,3.734100E+02,3.820200E-05,& + & 1.252400E-04,2.727900E-04,3.728200E-04,6.037400E-04,1.153600E-03,& + & 2.492300E-03,7.303200E-03,4.220900E-02,1.563400E-01,2.684100E-01,& + & 4.312300E-01,7.925300E-01,2.007900E+00,1.270800E+01,4.220400E+01,& + & 3.712900E-05,1.548100E-04,8.039200E-04,4.979800E-03,3.474700E-02,& + & 1.283300E-01,3.704900E-01,1.113100E+00,7.293700E+00,3.721000E+01,& + & 7.413000E+01,1.585700E+02,3.506000E+02,7.144100E+02,1.329900E+03,& + & 2.030900E+03,8.286500E-05,2.607800E-04,1.048600E-03,5.399000E-03,& + & 3.028300E-02,1.018600E-01,2.896000E-01,8.633800E-01,5.534100E+00,& + & 2.791100E+01,5.560200E+01,1.189300E+02,2.629700E+02,5.358300E+02,& + & 9.974100E+02,1.523200E+03,8.693200E-05,2.695000E-04,9.714700E-04,& + & 4.493800E-03,2.239300E-02,7.108100E-02,2.002200E-01,5.957700E-01,& + & 3.809300E+00,1.886200E+01,3.712700E+01,7.928400E+01,1.753100E+02,& + & 3.572300E+02,6.649500E+02,1.015400E+03,7.793100E-05,2.344400E-04,& + & 7.530100E-04,3.081600E-03,1.307700E-02,3.848300E-02,1.064200E-01,& + & 3.157800E-01,2.048500E+00,9.838400E+00,1.909500E+01,4.008800E+01,& + & 8.765800E+01,1.786100E+02,3.324800E+02,5.050200E+02,4.877700E-05,& + & 1.621100E-04,3.200700E-04,4.593000E-04,7.659800E-04,1.437800E-03,& + & 3.197600E-03,9.089500E-03,5.116500E-02,1.802000E-01,3.008300E-01,& + & 5.103900E-01,9.798400E-01,3.362400E+00,1.743300E+01,5.712700E+01/ + data absb(:,141:160) / & + & 4.695300E-05,2.364100E-04,1.326000E-03,8.008100E-03,5.028800E-02,& + & 1.739000E-01,4.923100E-01,1.476500E+00,9.704400E+00,4.754600E+01,& + & 9.441400E+01,2.005000E+02,4.421400E+02,9.126500E+02,1.737900E+03,& + & 2.647900E+03,1.112800E-04,3.902400E-04,1.638600E-03,8.264400E-03,& + & 4.305700E-02,1.378700E-01,3.839800E-01,1.144400E+00,7.362500E+00,& + & 3.565900E+01,7.081100E+01,1.503600E+02,3.316100E+02,6.845000E+02,& + & 1.303400E+03,1.986200E+03,1.176300E-04,3.953600E-04,1.479200E-03,& + & 6.722300E-03,3.149000E-02,9.601200E-02,2.651500E-01,7.890900E-01,& + & 5.063700E+00,2.410000E+01,4.732300E+01,1.002500E+02,2.210700E+02,& + & 4.563200E+02,8.688700E+02,1.324100E+03,1.049600E-04,3.358600E-04,& + & 1.116400E-03,4.503200E-03,1.813000E-02,5.193000E-02,1.406900E-01,& + & 4.182700E-01,2.713600E+00,1.260000E+01,2.437100E+01,5.073500E+01,& + & 1.105400E+02,2.281600E+02,4.344700E+02,6.620200E+02,6.080600E-05,& + & 2.025500E-04,3.814400E-04,5.473400E-04,9.506900E-04,1.764100E-03,& + & 3.952900E-03,1.117900E-02,6.024700E-02,2.150700E-01,3.414200E-01,& + & 5.838800E-01,1.241400E+00,4.965000E+00,2.299600E+01,7.542900E+01,& + & 6.250200E-05,3.669900E-04,2.147300E-03,1.249200E-02,6.975600E-02,& + & 2.301100E-01,6.403500E-01,1.925000E+00,1.259700E+01,5.897300E+01,& + & 1.168700E+02,2.463100E+02,5.411700E+02,1.133600E+03,2.200900E+03,& + & 3.339900E+03,1.512900E-04,5.829900E-04,2.512600E-03,1.237300E-02,& + & 5.900500E-02,1.820600E-01,4.989200E-01,1.489800E+00,9.556100E+00,& + & 4.422900E+01,8.765500E+01,1.847300E+02,4.058600E+02,8.501500E+02,& + & 1.650600E+03,2.504900E+03,1.602500E-04,5.753100E-04,2.206700E-03,& + & 9.864400E-03,4.285000E-02,1.266800E-01,3.441800E-01,1.028400E+00,& + & 6.565300E+00,2.988000E+01,5.860400E+01,1.231600E+02,2.705800E+02,& + & 5.667900E+02,1.100400E+03,1.670000E+03,1.418400E-04,4.769400E-04,& + & 1.627600E-03,6.425500E-03,2.441200E-02,6.840400E-02,1.822000E-01,& + & 5.457600E-01,3.505200E+00,1.565000E+01,3.022800E+01,6.238800E+01,& + & 1.353000E+02,2.833800E+02,5.502000E+02,8.350000E+02,7.453600E-05,& + & 2.445900E-04,4.465300E-04,6.302000E-04,1.163300E-03,2.165400E-03,& + & 4.807400E-03,1.349800E-02,7.072100E-02,2.346700E-01,3.993200E-01,& + & 6.707800E-01,1.548700E+00,6.876100E+00,2.935800E+01,9.702100E+01,& + & 2.267200E-05,6.578900E-05,2.472400E-04,1.506400E-03,1.227100E-02,& + & 5.278800E-02,1.609700E-01,5.011400E-01,3.194900E+00,1.737300E+01,& + & 3.504300E+01,7.888600E+01,1.854600E+02,4.083900E+02,7.779700E+02,& + & 1.215700E+03,4.124200E-05,1.037700E-04,3.591000E-04,1.845100E-03,& + & 1.113000E-02,4.229900E-02,1.268100E-01,3.902800E-01,2.435800E+00,& + & 1.304000E+01,2.628100E+01,5.916700E+01,1.390900E+02,3.063000E+02,& + & 5.834700E+02,9.117900E+02,4.252700E-05,1.057300E-04,3.473400E-04,& + & 1.605600E-03,8.451100E-03,2.967300E-02,8.798300E-02,2.696800E-01,& + & 1.686200E+00,8.839000E+00,1.764500E+01,3.944500E+01,9.272800E+01,& + & 2.042000E+02,3.889800E+02,6.079000E+02,3.734200E-05,9.474700E-05,& + & 2.834900E-04,1.152200E-03,5.116800E-03,1.622700E-02,4.706700E-02,& + & 1.430300E-01,9.152300E-01,4.658800E+00,9.088000E+00,2.011900E+01,& + & 4.639600E+01,1.020900E+02,1.944900E+02,3.039400E+02,2.393400E-05,& + & 7.830900E-05,1.851100E-04,2.468200E-04,4.129300E-04,7.631000E-04,& + & 1.699800E-03,5.029900E-03,2.975500E-02,1.197200E-01,1.904100E-01,& + & 3.386600E-01,6.178900E-01,1.419800E+00,8.905800E+00,3.649700E+01,& + & 2.469900E-05,8.673900E-05,4.012500E-04,2.547400E-03,1.920500E-02,& + & 7.588900E-02,2.267400E-01,6.976800E-01,4.538200E+00,2.379300E+01,& + & 4.809500E+01,1.068900E+02,2.519100E+02,5.596800E+02,1.079500E+03,& + & 1.730800E+03,5.160000E-05,1.466700E-04,5.601700E-04,2.929400E-03,& + & 1.703600E-02,6.064800E-02,1.781200E-01,5.430800E-01,3.460100E+00,& + & 1.785700E+01,3.607200E+01,8.016700E+01,1.889300E+02,4.197700E+02,& + & 8.096400E+02,1.298100E+03,5.395300E-05,1.532100E-04,5.318900E-04,& + & 2.491500E-03,1.276300E-02,4.245700E-02,1.233700E-01,3.749300E-01,& + & 2.394000E+00,1.210900E+01,2.422400E+01,5.344400E+01,1.259600E+02,& + & 2.798500E+02,5.397400E+02,8.653900E+02,4.835000E-05,1.363000E-04,& + & 4.249300E-04,1.750700E-03,7.590200E-03,2.310800E-02,6.575800E-02,& + & 1.989600E-01,1.294500E+00,6.396300E+00,1.250000E+01,2.728900E+01,& + & 6.302000E+01,1.399200E+02,2.698800E+02,4.327000E+02,3.147300E-05,& + & 1.040000E-04,2.205500E-04,3.153800E-04,5.199300E-04,1.003500E-03,& + & 2.214800E-03,6.475200E-03,3.702600E-02,1.377400E-01,2.200500E-01,& + & 4.028300E-01,7.304900E-01,2.224100E+00,1.376000E+01,5.018600E+01/ + data absb(:,161:180) / & + & 2.933400E-05,1.257000E-04,6.692400E-04,4.218600E-03,2.878900E-02,& + & 1.057500E-01,3.094200E-01,9.455500E-01,6.234400E+00,3.133600E+01,& + & 6.328000E+01,1.392100E+02,3.275200E+02,7.363700E+02,1.450300E+03,& + & 2.342100E+03,6.754700E-05,2.169600E-04,8.834200E-04,4.579800E-03,& + & 2.510300E-02,8.419000E-02,2.423900E-01,7.353700E-01,4.753200E+00,& + & 2.352000E+01,4.746500E+01,1.044000E+02,2.456300E+02,5.522600E+02,& + & 1.087700E+03,1.756500E+03,7.129400E-05,2.249300E-04,8.206700E-04,& + & 3.806300E-03,1.857900E-02,5.885200E-02,1.676800E-01,5.073300E-01,& + & 3.285100E+00,1.596100E+01,3.188400E+01,6.960100E+01,1.637600E+02,& + & 3.681800E+02,7.251500E+02,1.171000E+03,6.446100E-05,1.958500E-04,& + & 6.386000E-04,2.598800E-03,1.086400E-02,3.199300E-02,8.924700E-02,& + & 2.686400E-01,1.769700E+00,8.439000E+00,1.650500E+01,3.555300E+01,& + & 8.196300E+01,1.841000E+02,3.625800E+02,5.855600E+02,4.002500E-05,& + & 1.335500E-04,2.626000E-04,3.867400E-04,6.556100E-04,1.264800E-03,& + & 2.817100E-03,8.132300E-03,4.504500E-02,1.609100E-01,2.519000E-01,& + & 4.500100E-01,9.141800E-01,3.565300E+00,1.873900E+01,6.796000E+01,& + & 3.728600E-05,1.925400E-04,1.106100E-03,6.801900E-03,4.147000E-02,& + & 1.432800E-01,4.112100E-01,1.251500E+00,8.334900E+00,3.986600E+01,& + & 8.045900E+01,1.754100E+02,4.110900E+02,9.350400E+02,1.890600E+03,& + & 3.043600E+03,9.083800E-05,3.249200E-04,1.379200E-03,7.006300E-03,& + & 3.554900E-02,1.139400E-01,3.215600E-01,9.720400E-01,6.352100E+00,& + & 2.993500E+01,6.035200E+01,1.315600E+02,3.083200E+02,7.012600E+02,& + & 1.417900E+03,2.282900E+03,9.662500E-05,3.297200E-04,1.246200E-03,& + & 5.698200E-03,2.604900E-02,7.953300E-02,2.222600E-01,6.709000E-01,& + & 4.382700E+00,2.033100E+01,4.056200E+01,8.771400E+01,2.055500E+02,& + & 4.675100E+02,9.452300E+02,1.521900E+03,8.686200E-05,2.811000E-04,& + & 9.437600E-04,3.803200E-03,1.500600E-02,4.315500E-02,1.180500E-01,& + & 3.557700E-01,2.351800E+00,1.075600E+01,2.105000E+01,4.479300E+01,& + & 1.029500E+02,2.337500E+02,4.726300E+02,7.609300E+02,4.986900E-05,& + & 1.647800E-04,3.122600E-04,4.612400E-04,8.139500E-04,1.571400E-03,& + & 3.485200E-03,1.000700E-02,5.353200E-02,1.795500E-01,3.034700E-01,& + & 5.084300E-01,1.166300E+00,5.103500E+00,2.464100E+01,8.894000E+01,& + & 4.982200E-05,2.995200E-04,1.796400E-03,1.059500E-02,5.747000E-02,& + & 1.894000E-01,5.366100E-01,1.632600E+00,1.085800E+01,4.949500E+01,& + & 9.940500E+01,2.152300E+02,5.006900E+02,1.156000E+03,2.386300E+03,& + & 3.825700E+03,1.235200E-04,4.840200E-04,2.112600E-03,1.048600E-02,& + & 4.874300E-02,1.502800E-01,4.189100E-01,1.267400E+00,8.268900E+00,& + & 3.717500E+01,7.455500E+01,1.614200E+02,3.755400E+02,8.669700E+02,& + & 1.789700E+03,2.869100E+03,1.315200E-04,4.801000E-04,1.858300E-03,& + & 8.352800E-03,3.538300E-02,1.048800E-01,2.889700E-01,8.747800E-01,& + & 5.697800E+00,2.525700E+01,5.014100E+01,1.076400E+02,2.503500E+02,& + & 5.780100E+02,1.193300E+03,1.912900E+03,1.171300E-04,3.989200E-04,& + & 1.372100E-03,5.424900E-03,2.017500E-02,5.681700E-02,1.530800E-01,& + & 4.636300E-01,3.049000E+00,1.333900E+01,2.607200E+01,5.499300E+01,& + & 1.255100E+02,2.890100E+02,5.965600E+02,9.563700E+02,6.121900E-05,& + & 1.983100E-04,3.674600E-04,5.332000E-04,9.959800E-04,1.914900E-03,& + & 4.270300E-03,1.214400E-02,6.233800E-02,2.066300E-01,3.381400E-01,& + & 5.960700E-01,1.468200E+00,6.904400E+00,3.148500E+01,1.132000E+02,& + & 1.800300E-05,5.358800E-05,2.093400E-04,1.310200E-03,1.060400E-02,& + & 4.452000E-02,1.381600E-01,4.361800E-01,2.798300E+00,1.503700E+01,& + & 3.069800E+01,7.032800E+01,1.766000E+02,4.297100E+02,8.787400E+02,& + & 1.449900E+03,3.380200E-05,8.663200E-05,3.070000E-04,1.598300E-03,& + & 9.586100E-03,3.575800E-02,1.089900E-01,3.407000E-01,2.143000E+00,& + & 1.132200E+01,2.302800E+01,5.275000E+01,1.324500E+02,3.222900E+02,& + & 6.590700E+02,1.087500E+03,3.504200E-05,8.924700E-05,2.972200E-04,& + & 1.385900E-03,7.265500E-03,2.512800E-02,7.556800E-02,2.354400E-01,& + & 1.490700E+00,7.684400E+00,1.555900E+01,3.520900E+01,8.830100E+01,& + & 2.148500E+02,4.393900E+02,7.250200E+02,3.106800E-05,8.006700E-05,& + & 2.426700E-04,9.929100E-04,4.382300E-03,1.375300E-02,4.038400E-02,& + & 1.251400E-01,8.078700E-01,4.112700E+00,8.074400E+00,1.808100E+01,& + & 4.434400E+01,1.074300E+02,2.196900E+02,3.625000E+02,2.007400E-05,& + & 6.577500E-05,1.492600E-04,2.122800E-04,3.561700E-04,6.657100E-04,& + & 1.508400E-03,4.491800E-03,2.663800E-02,1.048500E-01,1.685100E-01,& + & 3.123700E-01,5.862400E-01,1.539300E+00,9.755600E+00,4.345100E+01/ + data absb(:,181:200) / & + & 1.981100E-05,7.160600E-05,3.426000E-04,2.226900E-03,1.649500E-02,& + & 6.404500E-02,1.939000E-01,6.084400E-01,3.980100E+00,2.051500E+01,& + & 4.193800E+01,9.481200E+01,2.378200E+02,5.858700E+02,1.212800E+03,& + & 2.049400E+03,4.260000E-05,1.237700E-04,4.818700E-04,2.541000E-03,& + & 1.461300E-02,5.127100E-02,1.523700E-01,4.750600E-01,3.047300E+00,& + & 1.545000E+01,3.144900E+01,7.111000E+01,1.783500E+02,4.394200E+02,& + & 9.096200E+02,1.537100E+03,4.476500E-05,1.301100E-04,4.576300E-04,& + & 2.156300E-03,1.093400E-02,3.590100E-02,1.055800E-01,3.277900E-01,& + & 2.116700E+00,1.049900E+01,2.126600E+01,4.745300E+01,1.189100E+02,& + & 2.929300E+02,6.063800E+02,1.024700E+03,4.042600E-05,1.156100E-04,& + & 3.656600E-04,1.507200E-03,6.479800E-03,1.958200E-02,5.634700E-02,& + & 1.740500E-01,1.142300E+00,5.618200E+00,1.107500E+01,2.438700E+01,& + & 5.973400E+01,1.464700E+02,3.031900E+02,5.123600E+02,2.618800E-05,& + & 8.737400E-05,1.799100E-04,2.681600E-04,4.486500E-04,8.739100E-04,& + & 1.953300E-03,5.821300E-03,3.334400E-02,1.214800E-01,1.960400E-01,& + & 3.665500E-01,7.062700E-01,2.260100E+00,1.489600E+01,5.992300E+01,& + & 2.374000E-05,1.049000E-04,5.716300E-04,3.689600E-03,2.465100E-02,& + & 8.908200E-02,2.643100E-01,8.250400E-01,5.485400E+00,2.688600E+01,& + & 5.497100E+01,1.230700E+02,3.072900E+02,7.661700E+02,1.620900E+03,& + & 2.759500E+03,5.599000E-05,1.840000E-04,7.599100E-04,3.977800E-03,& + & 2.143000E-02,7.116400E-02,2.073400E-01,6.431500E-01,4.197800E+00,& + & 2.025200E+01,4.122600E+01,9.230500E+01,2.304600E+02,5.746400E+02,& + & 1.215700E+03,2.069500E+03,5.940000E-05,1.912500E-04,7.064400E-04,& + & 3.297700E-03,1.580300E-02,4.982100E-02,1.434900E-01,4.437700E-01,& + & 2.909500E+00,1.379200E+01,2.787300E+01,6.160700E+01,1.536500E+02,& + & 3.831100E+02,8.105100E+02,1.379700E+03,5.401900E-05,1.663000E-04,& + & 5.499000E-04,2.245400E-03,9.215500E-03,2.712200E-02,7.638100E-02,& + & 2.352100E-01,1.565000E+00,7.374100E+00,1.455300E+01,3.168500E+01,& + & 7.724800E+01,1.915500E+02,4.052400E+02,6.898400E+02,3.327500E-05,& + & 1.102500E-04,2.155700E-04,3.281900E-04,5.636000E-04,1.109200E-03,& + & 2.482900E-03,7.344900E-03,4.006700E-02,1.456100E-01,2.333400E-01,& + & 4.112700E-01,8.636900E-01,3.535300E+00,2.018000E+01,8.010700E+01,& + & 3.036200E-05,1.610700E-04,9.487300E-04,5.941400E-03,3.521400E-02,& + & 1.206100E-01,3.523000E-01,1.090400E+00,7.352200E+00,3.428700E+01,& + & 6.968300E+01,1.548200E+02,3.835700E+02,9.679800E+02,2.100900E+03,& + & 3.570200E+03,7.543500E-05,2.757000E-04,1.184500E-03,6.096000E-03,& + & 3.021800E-02,9.605100E-02,2.757900E-01,8.489200E-01,5.624000E+00,& + & 2.583200E+01,5.226400E+01,1.161200E+02,2.876800E+02,7.259400E+02,& + & 1.575600E+03,2.677500E+03,8.063000E-05,2.797200E-04,1.071900E-03,& + & 4.935300E-03,2.211900E-02,6.712700E-02,1.904900E-01,5.856000E-01,& + & 3.891000E+00,1.761500E+01,3.532200E+01,7.755600E+01,1.917900E+02,& + & 4.839800E+02,1.050400E+03,1.785000E+03,7.280800E-05,2.386400E-04,& + & 8.115000E-04,3.274400E-03,1.272200E-02,3.651800E-02,1.010700E-01,& + & 3.103300E-01,2.086800E+00,9.386000E+00,1.847400E+01,3.992200E+01,& + & 9.651300E+01,2.419700E+02,5.252500E+02,8.925300E+02,4.138000E-05,& + & 1.359000E-04,2.556400E-04,3.922500E-04,7.004600E-04,1.363500E-03,& + & 3.117500E-03,9.113600E-03,4.760300E-02,1.629400E-01,2.815500E-01,& + & 4.726400E-01,1.025500E+00,5.091900E+00,2.643300E+01,1.038800E+02,& + & 4.074300E-05,2.504400E-04,1.538300E-03,9.257800E-03,4.868500E-02,& + & 1.592200E-01,4.595900E-01,1.418200E+00,9.600600E+00,4.284100E+01,& + & 8.579600E+01,1.892100E+02,4.665200E+02,1.189800E+03,2.641000E+03,& + & 4.467500E+03,1.026300E-04,4.087000E-04,1.817500E-03,9.110200E-03,& + & 4.124300E-02,1.265800E-01,3.591700E-01,1.104000E+00,7.337500E+00,& + & 3.227800E+01,6.435000E+01,1.419000E+02,3.499100E+02,8.923500E+02,& + & 1.980800E+03,3.350500E+03,1.096300E-04,4.064300E-04,1.596500E-03,& + & 7.225500E-03,2.994800E-02,8.840500E-02,2.477400E-01,7.621200E-01,& + & 5.066200E+00,2.202300E+01,4.349600E+01,9.481800E+01,2.332700E+02,& + & 5.948900E+02,1.320500E+03,2.233700E+03,9.799800E-05,3.383200E-04,& + & 1.175500E-03,4.671200E-03,1.704800E-02,4.797700E-02,1.313200E-01,& + & 4.040400E-01,2.708700E+00,1.171100E+01,2.278100E+01,4.886600E+01,& + & 1.175100E+02,2.974400E+02,6.602600E+02,1.116800E+03,5.044200E-05,& + & 1.624300E-04,3.040700E-04,4.533600E-04,8.545000E-04,1.666400E-03,& + & 3.825700E-03,1.108400E-02,5.550400E-02,1.862400E-01,3.181900E-01,& + & 5.528800E-01,1.310500E+00,6.783500E+00,3.372400E+01,1.310200E+02/ + data absb(:,201:220) / & + & 1.441000E-05,4.399500E-05,1.784300E-04,1.147300E-03,9.236500E-03,& + & 3.777700E-02,1.188500E-01,3.815700E-01,2.472300E+00,1.315200E+01,& + & 2.696100E+01,6.232900E+01,1.655200E+02,4.488900E+02,9.967300E+02,& + & 1.735400E+03,2.787200E-05,7.277600E-05,2.635000E-04,1.388800E-03,& + & 8.334900E-03,3.038300E-02,9.372500E-02,2.988900E-01,1.901700E+00,& + & 9.943800E+00,2.023900E+01,4.674500E+01,1.241400E+02,3.366600E+02,& + & 7.476100E+02,1.301500E+03,2.902700E-05,7.569500E-05,2.556400E-04,& + & 1.201600E-03,6.306400E-03,2.133100E-02,6.504100E-02,2.066200E-01,& + & 1.326900E+00,6.778000E+00,1.372100E+01,3.131400E+01,8.276100E+01,& + & 2.244400E+02,4.983900E+02,8.676200E+02,2.594300E-05,6.805000E-05,& + & 2.087000E-04,8.601100E-04,3.787000E-03,1.169400E-02,3.480300E-02,& + & 1.098900E-01,7.171700E-01,3.647100E+00,7.235700E+00,1.613200E+01,& + & 4.183400E+01,1.122200E+02,2.491900E+02,4.338300E+02,1.682000E-05,& + & 5.549500E-05,1.213300E-04,1.812700E-04,3.055600E-04,5.784500E-04,& + & 1.341100E-03,4.017200E-03,2.384200E-02,9.185300E-02,1.563300E-01,& + & 2.853300E-01,5.423300E-01,1.642700E+00,1.052400E+01,5.112100E+01,& + & 1.601800E-05,5.961100E-05,2.933200E-04,1.956500E-03,1.427000E-02,& + & 5.433100E-02,1.663500E-01,5.324900E-01,3.523400E+00,1.786600E+01,& + & 3.662400E+01,8.373400E+01,2.214400E+02,6.083000E+02,1.367300E+03,& + & 2.433300E+03,3.534800E-05,1.048200E-04,4.155700E-04,2.218100E-03,& + & 1.264200E-02,4.348400E-02,1.310200E-01,4.165200E-01,2.708900E+00,& + & 1.351100E+01,2.748600E+01,6.279100E+01,1.660800E+02,4.562300E+02,& + & 1.025500E+03,1.824800E+03,3.732000E-05,1.105600E-04,3.954400E-04,& + & 1.874600E-03,9.438300E-03,3.048100E-02,9.081300E-02,2.876400E-01,& + & 1.885400E+00,9.229800E+00,1.864200E+01,4.207300E+01,1.107200E+02,& + & 3.041700E+02,6.836600E+02,1.216600E+03,3.390000E-05,9.820200E-05,& + & 3.159700E-04,1.303800E-03,5.569400E-03,1.668400E-02,4.848100E-02,& + & 1.528800E-01,1.015600E+00,4.959500E+00,9.838200E+00,2.171700E+01,& + & 5.600600E+01,1.520800E+02,3.418400E+02,6.083100E+02,2.189300E-05,& + & 7.315800E-05,1.467700E-04,2.283000E-04,3.849900E-04,7.576200E-04,& + & 1.730100E-03,5.244200E-03,2.942300E-02,1.114100E-01,1.847700E-01,& + & 3.309700E-01,6.655100E-01,2.229800E+00,1.607500E+01,7.012200E+01,& + & 1.936400E-05,8.798900E-05,4.913200E-04,3.252000E-03,2.118800E-02,& + & 7.542800E-02,2.270700E-01,7.228000E-01,4.862400E+00,2.346900E+01,& + & 4.784200E+01,1.084300E+02,2.844700E+02,7.908000E+02,1.816600E+03,& + & 3.256600E+03,4.663000E-05,1.563400E-04,6.553700E-04,3.480800E-03,& + & 1.841500E-02,6.029400E-02,1.784500E-01,5.645600E-01,3.735900E+00,& + & 1.774700E+01,3.591300E+01,8.132100E+01,2.133400E+02,5.931200E+02,& + & 1.362500E+03,2.442600E+03,4.970100E-05,1.626800E-04,6.087400E-04,& + & 2.869400E-03,1.358200E-02,4.224500E-02,1.234800E-01,3.895100E-01,& + & 2.594800E+00,1.213500E+01,2.436200E+01,5.451600E+01,1.422300E+02,& + & 3.954100E+02,9.082900E+02,1.628300E+03,4.537600E-05,1.417200E-04,& + & 4.743700E-04,1.946100E-03,7.888800E-03,2.305800E-02,6.573100E-02,& + & 2.066100E-01,1.393400E+00,6.508600E+00,1.285200E+01,2.819800E+01,& + & 7.202900E+01,1.976900E+02,4.541200E+02,8.142000E+02,2.772300E-05,& + & 9.098700E-05,1.772800E-04,2.780000E-04,4.863200E-04,9.539600E-04,& + & 2.202700E-03,6.669200E-03,3.553800E-02,1.278500E-01,2.279300E-01,& + & 3.820500E-01,7.826700E-01,3.436700E+00,2.169000E+01,9.303700E+01,& + & 2.492300E-05,1.354800E-04,8.185400E-04,5.220400E-03,3.020400E-02,& + & 1.018100E-01,3.029900E-01,9.567500E-01,6.524500E+00,3.012000E+01,& + & 6.040300E+01,1.359700E+02,3.542600E+02,9.937100E+02,2.340400E+03,& + & 4.187500E+03,6.293600E-05,2.339400E-04,1.022000E-03,5.331700E-03,& + & 2.589500E-02,8.119300E-02,2.374800E-01,7.463400E-01,5.009500E+00,& + & 2.276100E+01,4.535500E+01,1.019800E+02,2.657000E+02,7.452700E+02,& + & 1.755300E+03,3.140400E+03,6.750500E-05,2.379800E-04,9.237400E-04,& + & 4.297200E-03,1.892200E-02,5.684400E-02,1.640300E-01,5.147400E-01,& + & 3.471500E+00,1.556700E+01,3.079400E+01,6.839800E+01,1.771400E+02,& + & 4.968400E+02,1.170200E+03,2.093700E+03,6.112900E-05,2.029500E-04,& + & 6.988100E-04,2.834200E-03,1.085900E-02,3.097800E-02,8.715400E-02,& + & 2.728500E-01,1.858600E+00,8.330500E+00,1.624700E+01,3.545500E+01,& + & 8.979100E+01,2.484200E+02,5.850800E+02,1.046800E+03,3.425300E-05,& + & 1.118900E-04,2.108500E-04,3.310500E-04,6.014400E-04,1.179600E-03,& + & 2.764600E-03,8.275400E-03,4.199200E-02,1.517600E-01,2.587500E-01,& + & 4.617200E-01,9.332200E-01,4.860900E+00,2.834600E+01,1.196800E+02/ + data absb(:,221:240) / & + & 3.358100E-05,2.103200E-04,1.323300E-03,8.106900E-03,4.173800E-02,& + & 1.341900E-01,3.949100E-01,1.243000E+00,8.526900E+00,3.788400E+01,& + & 7.432800E+01,1.656600E+02,4.302800E+02,1.215500E+03,2.925800E+03,& + & 5.226900E+03,8.565700E-05,3.452500E-04,1.567400E-03,7.950800E-03,& + & 3.526600E-02,1.069300E-01,3.090900E-01,9.686200E-01,6.541900E+00,& + & 2.860900E+01,5.582700E+01,1.242400E+02,3.227100E+02,9.115900E+02,& + & 2.194200E+03,3.920100E+03,9.174000E-05,3.439900E-04,1.373700E-03,& + & 6.274700E-03,2.555300E-02,7.482500E-02,2.132300E-01,6.678200E-01,& + & 4.526400E+00,1.956000E+01,3.792100E+01,8.337000E+01,2.151300E+02,& + & 6.077100E+02,1.462900E+03,2.613300E+03,8.218300E-05,2.868300E-04,& + & 1.010500E-03,4.036000E-03,1.449100E-02,4.069300E-02,1.132000E-01,& + & 3.536400E-01,2.418000E+00,1.044800E+01,1.997800E+01,4.332000E+01,& + & 1.091500E+02,3.038700E+02,7.314000E+02,1.306600E+03,4.150200E-05,& + & 1.332600E-04,2.500000E-04,3.858500E-04,7.316700E-04,1.437600E-03,& + & 3.366300E-03,1.009000E-02,4.938000E-02,1.730900E-01,3.000300E-01,& + & 5.228900E-01,1.146900E+00,6.547900E+00,3.603300E+01,1.496300E+02,& + & 1.160600E-05,3.680300E-05,1.560000E-04,1.038200E-03,8.208400E-03,& + & 3.283200E-02,1.037100E-01,3.410100E-01,2.245300E+00,1.175700E+01,& + & 2.410600E+01,5.585300E+01,1.553600E+02,4.712700E+02,1.148300E+03,& + & 2.113600E+03,2.334500E-05,6.251800E-05,2.316500E-04,1.239600E-03,& + & 7.415400E-03,2.638700E-02,8.193600E-02,2.674900E-01,1.735300E+00,& + & 8.911800E+00,1.814500E+01,4.189600E+01,1.165200E+02,3.534300E+02,& + & 8.612500E+02,1.585300E+03,2.445800E-05,6.574600E-05,2.245500E-04,& + & 1.067800E-03,5.598600E-03,1.854300E-02,5.688600E-02,1.849100E-01,& + & 1.211000E+00,6.138200E+00,1.231800E+01,2.823900E+01,7.768100E+01,& + & 2.356300E+02,5.741500E+02,1.056900E+03,2.204400E-05,5.898900E-05,& + & 1.838000E-04,7.627300E-04,3.344700E-03,1.019000E-02,3.045200E-02,& + & 9.833900E-02,6.523400E-01,3.311500E+00,6.578800E+00,1.463000E+01,& + & 3.961100E+01,1.178200E+02,2.870700E+02,5.284400E+02,1.434100E-05,& + & 4.754700E-05,9.896500E-05,1.546600E-04,2.603000E-04,5.076400E-04,& + & 1.197300E-03,3.639800E-03,2.129500E-02,8.105700E-02,1.434600E-01,& + & 2.647900E-01,5.161700E-01,1.692500E+00,1.176800E+01,6.058100E+01,& + & 1.310800E-05,5.076100E-05,2.587900E-04,1.772000E-03,1.259300E-02,& + & 4.698700E-02,1.451500E-01,4.748000E-01,3.193300E+00,1.598000E+01,& + & 3.248900E+01,7.465900E+01,2.059600E+02,6.323900E+02,1.563000E+03,& + & 2.931600E+03,2.986000E-05,9.100300E-05,3.664700E-04,1.989300E-03,& + & 1.113200E-02,3.768400E-02,1.144300E-01,3.718400E-01,2.466400E+00,& + & 1.210900E+01,2.445500E+01,5.599300E+01,1.544600E+02,4.742800E+02,& + & 1.172300E+03,2.198700E+03,3.170300E-05,9.619300E-05,3.489100E-04,& + & 1.669500E-03,8.285500E-03,2.645800E-02,7.934500E-02,2.567400E-01,& + & 1.717600E+00,8.333600E+00,1.662000E+01,3.775800E+01,1.029800E+02,& + & 3.161800E+02,7.815200E+02,1.465900E+03,2.897300E-05,8.539300E-05,& + & 2.793400E-04,1.155600E-03,4.883000E-03,1.448000E-02,4.237700E-02,& + & 1.364300E-01,9.225200E-01,4.483200E+00,8.864500E+00,1.962100E+01,& + & 5.257200E+01,1.580900E+02,3.907600E+02,7.329200E+02,1.854400E-05,& + & 6.078500E-05,1.203800E-04,1.935600E-04,3.315000E-04,6.607600E-04,& + & 1.540800E-03,4.750600E-03,2.617400E-02,9.890600E-02,1.767300E-01,& + & 3.058700E-01,6.247400E-01,2.242700E+00,1.762400E+01,8.238500E+01,& + & 1.605800E-05,7.568000E-05,4.358300E-04,2.936900E-03,1.855800E-02,& + & 6.504600E-02,1.981500E-01,6.427300E-01,4.401200E+00,2.110800E+01,& + & 4.211100E+01,9.628700E+01,2.631200E+02,8.155300E+02,2.059300E+03,& + & 3.880200E+03,3.959800E-05,1.360100E-04,5.788800E-04,3.120000E-03,& + & 1.611800E-02,5.201800E-02,1.558400E-01,5.029500E-01,3.395800E+00,& + & 1.599100E+01,3.170400E+01,7.221500E+01,1.973300E+02,6.116400E+02,& + & 1.544500E+03,2.910100E+03,4.239900E-05,1.412400E-04,5.375300E-04,& + & 2.555700E-03,1.187900E-02,3.644800E-02,1.078800E-01,3.472200E-01,& + & 2.359500E+00,1.099200E+01,2.158500E+01,4.871000E+01,1.315700E+02,& + & 4.077500E+02,1.029600E+03,1.940100E+03,3.884300E-05,1.231600E-04,& + & 4.178200E-04,1.723700E-03,6.881800E-03,1.993200E-02,5.746100E-02,& + & 1.843500E-01,1.263800E+00,5.897100E+00,1.150200E+01,2.538800E+01,& + & 6.722000E+01,2.039000E+02,5.148400E+02,9.700700E+02,2.327200E-05,& + & 7.592900E-05,1.449200E-04,2.362400E-04,4.171800E-04,8.268900E-04,& + & 1.960900E-03,6.033300E-03,3.165700E-02,1.158600E-01,2.113500E-01,& + & 3.696100E-01,7.403300E-01,3.340900E+00,2.365400E+01,1.082300E+02/ + data absb(:,241:260) / & + & 2.087100E-05,1.171100E-04,7.239300E-04,4.699200E-03,2.642300E-02,& + & 8.744700E-02,2.635200E-01,8.510400E-01,5.883400E+00,2.728500E+01,& + & 5.309100E+01,1.200200E+02,3.267000E+02,1.018900E+03,2.628200E+03,& + & 4.954400E+03,5.359200E-05,2.030300E-04,9.032800E-04,4.763600E-03,& + & 2.260800E-02,6.981400E-02,2.069700E-01,6.653000E-01,4.535000E+00,& + & 2.065900E+01,3.997900E+01,9.002300E+01,2.450000E+02,7.641700E+02,& + & 1.971100E+03,3.715600E+03,5.766800E-05,2.062500E-04,8.145100E-04,& + & 3.817800E-03,1.649000E-02,4.889800E-02,1.431300E-01,4.590500E-01,& + & 3.146700E+00,1.417400E+01,2.724800E+01,6.073600E+01,1.633700E+02,& + & 5.094400E+02,1.314000E+03,2.477000E+03,5.230300E-05,1.759900E-04,& + & 6.136600E-04,2.506300E-03,9.424200E-03,2.667900E-02,7.612800E-02,& + & 2.434000E-01,1.682400E+00,7.586300E+00,1.447900E+01,3.175300E+01,& + & 8.353800E+01,2.548000E+02,6.570200E+02,1.238600E+03,2.859400E-05,& + & 9.200800E-05,1.740400E-04,2.785500E-04,5.183700E-04,1.018000E-03,& + & 2.433300E-03,7.488800E-03,3.764400E-02,1.350700E-01,2.454500E-01,& + & 4.427300E-01,8.856200E-01,4.669700E+00,3.077700E+01,1.378100E+02,& + & 2.828700E-05,1.810800E-04,1.164100E-03,7.228200E-03,3.642300E-02,& + & 1.150400E-01,3.422100E-01,1.107900E+00,7.650100E+00,3.467600E+01,& + & 6.553100E+01,1.459600E+02,3.953900E+02,1.237800E+03,3.262500E+03,& + & 6.151200E+03,7.291000E-05,2.976800E-04,1.380700E-03,7.054200E-03,& + & 3.071200E-02,9.187800E-02,2.682100E-01,8.652600E-01,5.891200E+00,& + & 2.624800E+01,4.934400E+01,1.094700E+02,2.965600E+02,9.283500E+02,& + & 2.446800E+03,4.613500E+03,7.827400E-05,2.968300E-04,1.206200E-03,& + & 5.548700E-03,2.221000E-02,6.428600E-02,1.853700E-01,5.962100E-01,& + & 4.082800E+00,1.796600E+01,3.366100E+01,7.387800E+01,1.977800E+02,& + & 6.189000E+02,1.631300E+03,3.057900E+03,7.019100E-05,2.476800E-04,& + & 8.853200E-04,3.549000E-03,1.255600E-02,3.497200E-02,9.864700E-02,& + & 3.154400E-01,2.180600E+00,9.581000E+00,1.784000E+01,3.869000E+01,& + & 1.012600E+02,3.096500E+02,8.156600E+02,1.537800E+03,3.449500E-05,& + & 1.099800E-04,2.054800E-04,3.263000E-04,6.275700E-04,1.241200E-03,& + & 2.939300E-03,9.126900E-03,4.426300E-02,1.585100E-01,2.818400E-01,& + & 5.056000E-01,1.077700E+00,6.276000E+00,3.887100E+01,1.712700E+02,& + & 9.397300E-06,3.100300E-05,1.367700E-04,9.413100E-04,7.296200E-03,& + & 2.862500E-02,9.063900E-02,3.042100E-01,2.057100E+00,1.048100E+01,& + & 2.158600E+01,4.998700E+01,1.437000E+02,4.871300E+02,1.316700E+03,& + & 2.561200E+03,1.963600E-05,5.382300E-05,2.043300E-04,1.109500E-03,& + & 6.576700E-03,2.301300E-02,7.173400E-02,2.389700E-01,1.596700E+00,& + & 7.968500E+00,1.631400E+01,3.750100E+01,1.077900E+02,3.653400E+02,& + & 9.875600E+02,1.920800E+03,2.070400E-05,5.706100E-05,1.978800E-04,& + & 9.514800E-04,4.957600E-03,1.618000E-02,4.982400E-02,1.651600E-01,& + & 1.111500E+00,5.549000E+00,1.111500E+01,2.541800E+01,7.194100E+01,& + & 2.435600E+02,6.583300E+02,1.280500E+03,1.879300E-05,5.127100E-05,& + & 1.623200E-04,6.766000E-04,2.951800E-03,8.895400E-03,2.669500E-02,& + & 8.792300E-02,5.960500E-01,2.999600E+00,5.969600E+00,1.332500E+01,& + & 3.697900E+01,1.219200E+02,3.291900E+02,6.403100E+02,1.220400E-05,& + & 4.028000E-05,8.007100E-05,1.324400E-04,2.214700E-04,4.455100E-04,& + & 1.061100E-03,3.263100E-03,1.882700E-02,7.430900E-02,1.311800E-01,& + & 2.488000E-01,5.088100E-01,1.659900E+00,1.311900E+01,7.079500E+01,& + & 1.078700E-05,4.349600E-05,2.285100E-04,1.603500E-03,1.111600E-02,& + & 4.074000E-02,1.268400E-01,4.220000E-01,2.905700E+00,1.442000E+01,& + & 2.887200E+01,6.651400E+01,1.891000E+02,6.477500E+02,1.776600E+03,& + & 3.507800E+03,2.532200E-05,7.910300E-05,3.239200E-04,1.784400E-03,& + & 9.787800E-03,3.271500E-02,1.001400E-01,3.311600E-01,2.253500E+00,& + & 1.095500E+01,2.182400E+01,4.990300E+01,1.418200E+02,4.858300E+02,& + & 1.332400E+03,2.630800E+03,2.702500E-05,8.363500E-05,3.077400E-04,& + & 1.489400E-03,7.282200E-03,2.297900E-02,6.942600E-02,2.288800E-01,& + & 1.568100E+00,7.587800E+00,1.490000E+01,3.382800E+01,9.467500E+01,& + & 3.238700E+02,8.883000E+02,1.753800E+03,2.483100E-05,7.436900E-05,& + & 2.462300E-04,1.026200E-03,4.273600E-03,1.258900E-02,3.710700E-02,& + & 1.216900E-01,8.399900E-01,4.080500E+00,7.988400E+00,1.776900E+01,& + & 4.874700E+01,1.621200E+02,4.441300E+02,8.768400E+02,1.565400E-05,& + & 5.062400E-05,9.805900E-05,1.644200E-04,2.845200E-04,5.708100E-04,& + & 1.371400E-03,4.252900E-03,2.333700E-02,8.625300E-02,1.679100E-01,& + & 2.908900E-01,5.956100E-01,2.193800E+00,1.926700E+01,9.534700E+01/ + data absb(:,261:280) / & + & 1.338500E-05,6.540100E-05,3.863900E-04,2.652200E-03,1.629400E-02,& + & 5.614000E-02,1.726800E-01,5.707200E-01,3.980000E+00,1.921900E+01,& + & 3.739200E+01,8.515500E+01,2.406500E+02,8.302300E+02,2.317300E+03,& + & 4.597200E+03,3.372900E-05,1.183000E-04,5.116700E-04,2.795000E-03,& + & 1.414200E-02,4.493100E-02,1.359700E-01,4.474700E-01,3.083300E+00,& + & 1.460000E+01,2.825600E+01,6.388700E+01,1.804800E+02,6.226800E+02,& + & 1.738000E+03,3.447500E+03,3.629000E-05,1.226900E-04,4.745700E-04,& + & 2.277500E-03,1.039700E-02,3.153900E-02,9.412300E-02,3.090000E-01,& + & 2.143400E+00,1.007300E+01,1.931800E+01,4.332500E+01,1.205100E+02,& + & 4.151200E+02,1.158600E+03,2.298400E+03,3.330700E-05,1.070700E-04,& + & 3.674900E-04,1.527100E-03,6.003900E-03,1.724400E-02,5.023700E-02,& + & 1.640700E-01,1.146400E+00,5.397700E+00,1.033300E+01,2.279600E+01,& + & 6.213400E+01,2.078600E+02,5.793300E+02,1.149300E+03,1.960900E-05,& + & 6.212700E-05,1.188000E-04,2.000800E-04,3.576800E-04,7.148300E-04,& + & 1.721200E-03,5.391200E-03,2.819000E-02,1.058000E-01,1.923900E-01,& + & 3.673000E-01,7.031700E-01,3.200300E+00,2.570700E+01,1.241100E+02,& + & 1.756600E-05,1.014700E-04,6.380100E-04,4.210600E-03,2.316400E-02,& + & 7.528200E-02,2.286600E-01,7.567200E-01,5.288500E+00,2.510800E+01,& + & 4.728600E+01,1.058800E+02,2.977500E+02,1.030000E+03,2.934300E+03,& + & 5.824600E+03,4.574500E-05,1.757600E-04,7.969400E-04,4.240200E-03,& + & 1.976800E-02,6.022100E-02,1.797200E-01,5.925300E-01,4.092200E+00,& + & 1.906900E+01,3.571500E+01,7.944000E+01,2.233200E+02,7.724900E+02,& + & 2.200700E+03,4.368000E+03,4.936800E-05,1.785200E-04,7.167500E-04,& + & 3.387100E-03,1.438300E-02,4.221800E-02,1.243200E-01,4.089100E-01,& + & 2.842100E+00,1.311500E+01,2.441700E+01,5.389800E+01,1.491600E+02,& + & 5.149900E+02,1.467100E+03,2.911900E+03,4.483300E-05,1.524800E-04,& + & 5.395400E-04,2.213100E-03,8.189900E-03,2.305400E-02,6.627700E-02,& + & 2.168800E-01,1.518200E+00,7.002000E+00,1.302500E+01,2.839000E+01,& + & 7.699400E+01,2.580300E+02,7.335500E+02,1.455900E+03,2.389300E-05,& + & 7.557800E-05,1.429500E-04,2.344500E-04,4.450700E-04,8.757000E-04,& + & 2.116100E-03,6.696000E-03,3.382800E-02,1.226500E-01,2.285400E-01,& + & 4.222600E-01,8.595600E-01,4.434100E+00,3.318600E+01,1.573400E+02,& + & 2.393100E-05,1.562500E-04,1.021100E-03,6.419600E-03,3.181500E-02,& + & 9.920000E-02,2.958400E-01,9.873100E-01,6.847100E+00,3.204300E+01,& + & 5.858700E+01,1.286700E+02,3.598700E+02,1.245000E+03,3.614100E+03,& + & 7.174900E+03,6.221500E-05,2.569000E-04,1.209600E-03,6.242700E-03,& + & 2.678200E-02,7.919700E-02,2.322700E-01,7.723900E-01,5.291800E+00,& + & 2.433700E+01,4.422500E+01,9.655400E+01,2.699000E+02,9.337400E+02,& + & 2.710500E+03,5.381200E+03,6.691900E-05,2.563400E-04,1.056100E-03,& + & 4.894000E-03,1.934100E-02,5.542200E-02,1.606700E-01,5.322000E-01,& + & 3.672400E+00,1.670400E+01,3.022800E+01,6.552100E+01,1.803400E+02,& + & 6.224900E+02,1.807000E+03,3.587400E+03,6.004500E-05,2.135700E-04,& + & 7.755200E-04,3.113000E-03,1.091300E-02,3.013800E-02,8.554700E-02,& + & 2.820400E-01,1.959400E+00,8.894200E+00,1.610300E+01,3.452600E+01,& + & 9.318200E+01,3.120800E+02,9.035100E+02,1.793700E+03,2.866800E-05,& + & 9.073300E-05,1.684100E-04,2.749600E-04,5.359300E-04,1.069000E-03,& + & 2.534600E-03,8.265100E-03,3.995600E-02,1.438100E-01,2.638300E-01,& + & 4.878600E-01,1.011400E+00,5.972900E+00,4.163400E+01,1.948500E+02,& + & 7.717000E-06,2.647100E-05,1.206500E-04,8.549300E-04,6.513200E-03,& + & 2.522500E-02,8.007100E-02,2.733500E-01,1.907000E+00,9.527600E+00,& + & 1.961000E+01,4.523700E+01,1.324200E+02,5.011200E+02,1.513900E+03,& + & 3.104000E+03,1.667900E-05,4.686300E-05,1.805900E-04,1.000800E-03,& + & 5.853000E-03,2.029400E-02,6.344400E-02,2.149300E-01,1.485700E+00,& + & 7.276800E+00,1.485900E+01,3.399000E+01,9.931300E+01,3.758300E+02,& + & 1.135400E+03,2.327900E+03,1.768500E-05,4.981800E-05,1.751300E-04,& + & 8.527400E-04,4.401100E-03,1.427600E-02,4.406400E-02,1.486300E-01,& + & 1.032900E+00,5.082600E+00,1.020400E+01,2.308200E+01,6.650700E+01,& + & 2.505600E+02,7.569500E+02,1.552000E+03,1.612800E-05,4.480700E-05,& + & 1.438100E-04,6.021300E-04,2.615600E-03,7.842700E-03,2.364400E-02,& + & 7.912000E-02,5.518100E-01,2.746500E+00,5.484300E+00,1.226600E+01,& + & 3.440300E+01,1.257500E+02,3.784800E+02,7.760300E+02,1.035800E-05,& + & 3.288600E-05,6.479000E-05,1.122400E-04,1.886600E-04,3.860200E-04,& + & 9.334800E-04,2.920600E-03,1.666300E-02,6.465500E-02,1.230500E-01,& + & 2.337400E-01,4.777800E-01,1.572400E+00,1.476600E+01,8.173100E+01/ + data absb(:,281:300) / & + & 9.012000E-06,3.773100E-05,2.038700E-04,1.457600E-03,9.897900E-03,& + & 3.571200E-02,1.118100E-01,3.781800E-01,2.667700E+00,1.327100E+01,& + & 2.616800E+01,5.973100E+01,1.733400E+02,6.615300E+02,2.021300E+03,& + & 4.201500E+03,2.165900E-05,6.928000E-05,2.874200E-04,1.607000E-03,& + & 8.692500E-03,2.869500E-02,8.835400E-02,2.970400E-01,2.077300E+00,& + & 1.012100E+01,1.982500E+01,4.488200E+01,1.300100E+02,4.961400E+02,& + & 1.515900E+03,3.151100E+03,2.322100E-05,7.291500E-05,2.733100E-04,& + & 1.335400E-03,6.452100E-03,2.014900E-02,6.127100E-02,2.053300E-01,& + & 1.444800E+00,7.021400E+00,1.361700E+01,3.051800E+01,8.707300E+01,& + & 3.307600E+02,1.010700E+03,2.100700E+03,2.139500E-05,6.489200E-05,& + & 2.177100E-04,9.164200E-04,3.767000E-03,1.104900E-02,3.279400E-02,& + & 1.092200E-01,7.721400E-01,3.765700E+00,7.302800E+00,1.622200E+01,& + & 4.513300E+01,1.660400E+02,5.053200E+02,1.050300E+03,1.320600E-05,& + & 4.119800E-05,7.916900E-05,1.396500E-04,2.439800E-04,4.937200E-04,& + & 1.188200E-03,3.795900E-03,2.066200E-02,7.929100E-02,1.469600E-01,& + & 2.909300E-01,5.565200E-01,2.125000E+00,2.103900E+01,1.091500E+02,& + & 1.131900E-05,5.724800E-05,3.441300E-04,2.400500E-03,1.445800E-02,& + & 4.906000E-02,1.514900E-01,5.119700E-01,3.625200E+00,1.786300E+01,& + & 3.400900E+01,7.614700E+01,2.198100E+02,8.416200E+02,2.613200E+03,& + & 5.452600E+03,2.898900E-05,1.034700E-04,4.551800E-04,2.508300E-03,& + & 1.249800E-02,3.931000E-02,1.193900E-01,4.016700E-01,2.818700E+00,& + & 1.362200E+01,2.575400E+01,5.722700E+01,1.648600E+02,6.312000E+02,& + & 1.959800E+03,4.089600E+03,3.128900E-05,1.069800E-04,4.204400E-04,& + & 2.037500E-03,9.161500E-03,2.758600E-02,8.272500E-02,2.773000E-01,& + & 1.959500E+00,9.420100E+00,1.766600E+01,3.896100E+01,1.104500E+02,& + & 4.207900E+02,1.306600E+03,2.726300E+03,2.871700E-05,9.340300E-05,& + & 3.245800E-04,1.360600E-03,5.266700E-03,1.509100E-02,4.422300E-02,& + & 1.472300E-01,1.046300E+00,5.030700E+00,9.447500E+00,2.070000E+01,& + & 5.738900E+01,2.113200E+02,6.532800E+02,1.363200E+03,1.636100E-05,& + & 5.080800E-05,9.599500E-05,1.686900E-04,3.083800E-04,6.153900E-04,& + & 1.483200E-03,4.821800E-03,2.517900E-02,9.546100E-02,1.761900E-01,& + & 3.460700E-01,6.830300E-01,3.048800E+00,2.779900E+01,1.414200E+02,& + & 1.499200E-05,8.879100E-05,5.656900E-04,3.780500E-03,2.043400E-02,& + & 6.578500E-02,1.997800E-01,6.802100E-01,4.792100E+00,2.332500E+01,& + & 4.320200E+01,9.459200E+01,2.715000E+02,1.038700E+03,3.279800E+03,& + & 6.848600E+03,3.938500E-05,1.531900E-04,7.054200E-04,3.788200E-03,& + & 1.740000E-02,5.264300E-02,1.572200E-01,5.332300E-01,3.721300E+00,& + & 1.778300E+01,3.269700E+01,7.109200E+01,2.036000E+02,7.790300E+02,& + & 2.459800E+03,5.136500E+03,4.255500E-05,1.553000E-04,6.316900E-04,& + & 3.016800E-03,1.263500E-02,3.688900E-02,1.088800E-01,3.676900E-01,& + & 2.584700E+00,1.227300E+01,2.239800E+01,4.844900E+01,1.364400E+02,& + & 5.193400E+02,1.639900E+03,3.424300E+03,3.863300E-05,1.324700E-04,& + & 4.754200E-04,1.959000E-03,7.177500E-03,2.012400E-02,5.812800E-02,& + & 1.950800E-01,1.378400E+00,6.542000E+00,1.196600E+01,2.570300E+01,& + & 7.103500E+01,2.609200E+02,8.199300E+02,1.712000E+03,1.989100E-05,& + & 6.181200E-05,1.159300E-04,1.982400E-04,3.803800E-04,7.536500E-04,& + & 1.819000E-03,6.036700E-03,3.030000E-02,1.127400E-01,2.071100E-01,& + & 4.033800E-01,8.331200E-01,4.196400E+00,3.558500E+01,1.785600E+02,& + & 2.052000E-05,1.362400E-04,8.981700E-04,5.734000E-03,2.801100E-02,& + & 8.652000E-02,2.577000E-01,8.874000E-01,6.187500E+00,2.956400E+01,& + & 5.395000E+01,1.150800E+02,3.283700E+02,1.249700E+03,4.009600E+03,& + & 8.359200E+03,5.347900E-05,2.230300E-04,1.061600E-03,5.542900E-03,& + & 2.355200E-02,6.911900E-02,2.026000E-01,6.952000E-01,4.798100E+00,& + & 2.253600E+01,4.081000E+01,8.650700E+01,2.463000E+02,9.372700E+02,& + & 3.007300E+03,6.269400E+03,5.760000E-05,2.222000E-04,9.269500E-04,& + & 4.325200E-03,1.698800E-02,4.833500E-02,1.403000E-01,4.789200E-01,& + & 3.329900E+00,1.553700E+01,2.791400E+01,5.898600E+01,1.650900E+02,& + & 6.248500E+02,2.004800E+03,4.179300E+03,5.165400E-05,1.847400E-04,& + & 6.804300E-04,2.739700E-03,9.554200E-03,2.629500E-02,7.484400E-02,& + & 2.537300E-01,1.773800E+00,8.281600E+00,1.488100E+01,3.124100E+01,& + & 8.610300E+01,3.140700E+02,1.002400E+03,2.089600E+03,2.374600E-05,& + & 7.432400E-05,1.362100E-04,2.289900E-04,4.584200E-04,9.200000E-04,& + & 2.174700E-03,7.408300E-03,3.585800E-02,1.341800E-01,2.449100E-01,& + & 4.634700E-01,9.563800E-01,5.666100E+00,4.434300E+01,2.204200E+02/ + data absb(:,301:320) / & + & 6.383800E-06,2.280800E-05,1.074000E-04,7.808300E-04,5.849600E-03,& + & 2.234400E-02,7.095100E-02,2.466700E-01,1.767900E+00,8.816000E+00,& + & 1.791300E+01,4.120700E+01,1.213700E+02,5.095700E+02,1.731100E+03,& + & 3.735300E+03,1.424800E-05,4.104800E-05,1.609200E-04,9.061300E-04,& + & 5.246300E-03,1.797600E-02,5.626900E-02,1.940800E-01,1.382300E+00,& + & 6.767300E+00,1.359900E+01,3.105400E+01,9.104200E+01,3.821700E+02,& + & 1.298300E+03,2.801100E+03,1.516800E-05,4.358900E-05,1.558800E-04,& + & 7.685500E-04,3.934700E-03,1.264500E-02,3.910800E-02,1.342400E-01,& + & 9.600500E-01,4.722000E+00,9.413700E+00,2.114500E+01,6.122400E+01,& + & 2.547900E+02,8.655500E+02,1.867500E+03,1.390600E-05,3.931600E-05,& + & 1.276300E-04,5.395500E-04,2.327100E-03,6.941200E-03,2.101600E-02,& + & 7.143600E-02,5.121500E-01,2.537900E+00,5.061600E+00,1.134400E+01,& + & 3.188600E+01,1.283600E+02,4.327900E+02,9.337900E+02,8.825100E-06,& + & 2.689100E-05,5.283500E-05,9.339700E-05,1.644500E-04,3.319500E-04,& + & 8.096400E-04,2.609800E-03,1.475600E-02,5.848900E-02,1.124400E-01,& + & 2.195900E-01,4.561100E-01,1.486500E+00,1.641000E+01,9.375200E+01,& + & 7.587800E-06,3.298500E-05,1.827700E-04,1.329300E-03,8.841700E-03,& + & 3.153100E-02,9.862300E-02,3.410700E-01,2.450600E+00,1.235700E+01,& + & 2.400200E+01,5.402900E+01,1.582300E+02,6.677100E+02,2.288000E+03,& + & 4.991500E+03,1.863500E-05,6.093600E-05,2.565300E-04,1.451600E-03,& + & 7.760400E-03,2.528100E-02,7.801300E-02,2.680900E-01,1.914900E+00,& + & 9.468500E+00,1.821800E+01,4.071700E+01,1.186700E+02,5.007800E+02,& + & 1.716000E+03,3.743800E+03,2.005000E-05,6.390700E-05,2.434600E-04,& + & 1.202100E-03,5.734700E-03,1.778400E-02,5.408800E-02,1.852700E-01,& + & 1.331000E+00,6.573500E+00,1.257700E+01,2.777400E+01,7.984100E+01,& + & 3.338500E+02,1.144000E+03,2.495900E+03,1.851300E-05,5.689800E-05,& + & 1.932500E-04,8.212500E-04,3.332100E-03,9.741500E-03,2.901500E-02,& + & 9.848000E-02,7.100900E-01,3.513000E+00,6.743300E+00,1.487800E+01,& + & 4.170700E+01,1.682400E+02,5.720400E+02,1.247900E+03,1.111900E-05,& + & 3.388800E-05,6.470800E-05,1.164400E-04,2.108100E-04,4.239300E-04,& + & 1.024700E-03,3.382000E-03,1.841300E-02,7.206400E-02,1.357400E-01,& + & 2.784300E-01,5.343000E-01,2.018400E+00,2.285200E+01,1.244700E+02,& + & 9.647500E-06,5.048100E-05,3.077500E-04,2.173000E-03,1.286800E-02,& + & 4.315300E-02,1.329500E-01,4.623700E-01,3.309200E+00,1.655700E+01,& + & 3.137300E+01,6.873500E+01,2.001700E+02,8.446600E+02,2.929300E+03,& + & 6.415900E+03,2.505200E-05,9.071300E-05,4.057700E-04,2.254600E-03,& + & 1.107700E-02,3.462100E-02,1.048800E-01,3.630800E-01,2.582100E+00,& + & 1.267800E+01,2.380800E+01,5.180200E+01,1.501200E+02,6.335100E+02,& + & 2.197000E+03,4.812000E+03,2.711000E-05,9.368700E-05,3.730100E-04,& + & 1.827600E-03,8.097800E-03,2.431200E-02,7.270900E-02,2.505700E-01,& + & 1.793000E+00,8.797600E+00,1.639000E+01,3.539100E+01,1.010200E+02,& + & 4.223300E+02,1.464600E+03,3.208100E+03,2.484600E-05,8.169300E-05,& + & 2.876600E-04,1.213600E-03,4.643300E-03,1.328800E-02,3.891900E-02,& + & 1.329800E-01,9.556600E-01,4.691700E+00,8.773200E+00,1.891900E+01,& + & 5.290300E+01,2.129000E+02,7.323400E+02,1.604000E+03,1.373400E-05,& + & 4.161500E-05,7.847900E-05,1.403900E-04,2.655900E-04,5.256500E-04,& + & 1.277600E-03,4.315700E-03,2.261300E-02,8.628100E-02,1.658700E-01,& + & 3.230200E-01,6.682600E-01,2.876000E+00,2.989700E+01,1.604100E+02,& + & 1.288900E-05,7.815100E-05,5.034800E-04,3.399400E-03,1.810000E-02,& + & 5.787500E-02,1.747000E-01,6.138500E-01,4.358100E+00,2.144400E+01,& + & 4.021200E+01,8.541600E+01,2.472700E+02,1.037900E+03,3.644100E+03,& + & 7.980300E+03,3.407500E-05,1.340600E-04,6.243400E-04,3.390100E-03,& + & 1.538200E-02,4.628500E-02,1.376400E-01,4.816800E-01,3.395600E+00,& + & 1.640800E+01,3.051000E+01,6.436800E+01,1.854500E+02,7.784300E+02,& + & 2.733100E+03,5.984900E+03,3.683400E-05,1.356300E-04,5.583800E-04,& + & 2.685400E-03,1.115600E-02,3.242600E-02,9.537300E-02,3.322400E-01,& + & 2.356100E+00,1.137600E+01,2.094900E+01,4.403000E+01,1.248100E+02,& + & 5.189500E+02,1.822000E+03,3.989900E+03,3.338500E-05,1.154700E-04,& + & 4.197200E-04,1.737400E-03,6.311500E-03,1.767600E-02,5.095800E-02,& + & 1.763200E-01,1.253900E+00,6.071700E+00,1.118200E+01,2.348500E+01,& + & 6.553000E+01,2.617100E+02,9.110100E+02,1.995100E+03,1.660900E-05,& + & 5.083400E-05,9.299900E-05,1.652900E-04,3.258300E-04,6.483200E-04,& + & 1.559200E-03,5.339900E-03,2.740700E-02,1.041600E-01,1.935300E-01,& + & 3.814000E-01,7.910600E-01,3.964600E+00,3.800300E+01,2.015700E+02/ + data absb(:,321:340) / & + & 1.770600E-05,1.194600E-04,7.923600E-04,5.117700E-03,2.469500E-02,& + & 7.613400E-02,2.249300E-01,7.990500E-01,5.614800E+00,2.707200E+01,& + & 5.050700E+01,1.043000E+02,2.986800E+02,1.245400E+03,4.420900E+03,& + & 9.653200E+03,4.618100E-05,1.945200E-04,9.339300E-04,4.929600E-03,& + & 2.072200E-02,6.079300E-02,1.770800E-01,6.268200E-01,4.368400E+00,& + & 2.070300E+01,3.831400E+01,7.857000E+01,2.240100E+02,9.341100E+02,& + & 3.315700E+03,7.240800E+03,4.975100E-05,1.933700E-04,8.148600E-04,& + & 3.830800E-03,1.492500E-02,4.252400E-02,1.227000E-01,4.318600E-01,& + & 3.029600E+00,1.434700E+01,2.625200E+01,5.376700E+01,1.508100E+02,& + & 6.227300E+02,2.210400E+03,4.827200E+03,4.454400E-05,1.603700E-04,& + & 5.971200E-04,2.413800E-03,8.382400E-03,2.310900E-02,6.550200E-02,& + & 2.291300E-01,1.610800E+00,7.655100E+00,1.399300E+01,2.861300E+01,& + & 7.936300E+01,3.140900E+02,1.105200E+03,2.413500E+03,1.973500E-05,& + & 6.034600E-05,1.109100E-04,1.929200E-04,3.910500E-04,7.838000E-04,& + & 1.865700E-03,6.491300E-03,3.273000E-02,1.257200E-01,2.268900E-01,& + & 4.333800E-01,9.277300E-01,5.343200E+00,4.703700E+01,2.475600E+02,& + & 5.339300E-06,1.993400E-05,9.754300E-05,7.241400E-04,5.322400E-03,& + & 1.999400E-02,6.345100E-02,2.240400E-01,1.655000E+00,8.243700E+00,& + & 1.661000E+01,3.787000E+01,1.116600E+02,5.154300E+02,1.975300E+03,& + & 4.473600E+03,1.228800E-05,3.634900E-05,1.451500E-04,8.299800E-04,& + & 4.744000E-03,1.610200E-02,5.035200E-02,1.764900E-01,1.297000E+00,& + & 6.364500E+00,1.264800E+01,2.864600E+01,8.375000E+01,3.865700E+02,& + & 1.481400E+03,3.355100E+03,1.313200E-05,3.856200E-05,1.407900E-04,& + & 6.999100E-04,3.545500E-03,1.132300E-02,3.499900E-02,1.221400E-01,& + & 8.991000E-01,4.444200E+00,8.789900E+00,1.959200E+01,5.664100E+01,& + & 2.577200E+02,9.876600E+02,2.236700E+03,1.209600E-05,3.480900E-05,& + & 1.146900E-04,4.896200E-04,2.085600E-03,6.221600E-03,1.881100E-02,& + & 6.502200E-02,4.785600E-01,2.379900E+00,4.718000E+00,1.056000E+01,& + & 2.976100E+01,1.304000E+02,4.938200E+02,1.118300E+03,7.526400E-06,& + & 2.236900E-05,4.320300E-05,7.925900E-05,1.427300E-04,2.862900E-04,& + & 7.069600E-04,2.338400E-03,1.323500E-02,5.304600E-02,1.041000E-01,& + & 2.106700E-01,4.374100E-01,1.431000E+00,1.801800E+01,1.073100E+02,& + & 6.460900E-06,2.929100E-05,1.663700E-04,1.225900E-03,7.988000E-03,& + & 2.807900E-02,8.764600E-02,3.101300E-01,2.272400E+00,1.148300E+01,& + & 2.239500E+01,4.948600E+01,1.450500E+02,6.705500E+02,2.584400E+03,& + & 5.902300E+03,1.618900E-05,5.405100E-05,2.321100E-04,1.325500E-03,& + & 6.977300E-03,2.258100E-02,6.932100E-02,2.440300E-01,1.780400E+00,& + & 8.843700E+00,1.704800E+01,3.742500E+01,1.088000E+02,5.029200E+02,& + & 1.938300E+03,4.426400E+03,1.746700E-05,5.666700E-05,2.190600E-04,& + & 1.091700E-03,5.140100E-03,1.586900E-02,4.812800E-02,1.687000E-01,& + & 1.234800E+00,6.160500E+00,1.180400E+01,2.564500E+01,7.358600E+01,& + & 3.352800E+02,1.292200E+03,2.951100E+03,1.613100E-05,5.030100E-05,& + & 1.733800E-04,7.417700E-04,2.975000E-03,8.687500E-03,2.582000E-02,& + & 8.974100E-02,6.570200E-01,3.288300E+00,6.325700E+00,1.379100E+01,& + & 3.877800E+01,1.696900E+02,6.460600E+02,1.475600E+03,9.433200E-06,& + & 2.789500E-05,5.350100E-05,9.758000E-05,1.826100E-04,3.631400E-04,& + & 8.910800E-04,3.017900E-03,1.663200E-02,6.527800E-02,1.281200E-01,& + & 2.527700E-01,5.362000E-01,1.977900E+00,2.455100E+01,1.415600E+02,& + & 8.320000E-06,4.504400E-05,2.789800E-04,1.984800E-03,1.156400E-02,& + & 3.841700E-02,1.175600E-01,4.204900E-01,3.050100E+00,1.526100E+01,& + & 2.949500E+01,6.299300E+01,1.833600E+02,8.439300E+02,3.275800E+03,& + & 7.504600E+03,2.185300E-05,8.041900E-05,3.649700E-04,2.046200E-03,& + & 9.921500E-03,3.083400E-02,9.280400E-02,3.306600E-01,2.386200E+00,& + & 1.173900E+01,2.245300E+01,4.762600E+01,1.375300E+02,6.329400E+02,& + & 2.456700E+03,5.627900E+03,2.368100E-05,8.281200E-05,3.342000E-04,& + & 1.650300E-03,7.234300E-03,2.163700E-02,6.433600E-02,2.283800E-01,& + & 1.654500E+00,8.169500E+00,1.549800E+01,3.266600E+01,9.304100E+01,& + & 4.219500E+02,1.637900E+03,3.752100E+03,2.165300E-05,7.200700E-05,& + & 2.571700E-04,1.089500E-03,4.133400E-03,1.180500E-02,3.446500E-02,& + & 1.213800E-01,8.794500E-01,4.359300E+00,8.285100E+00,1.751600E+01,& + & 4.916800E+01,2.136200E+02,8.189600E+02,1.876100E+03,1.159300E-05,& + & 3.461100E-05,6.439100E-05,1.162900E-04,2.290300E-04,4.522900E-04,& + & 1.106300E-03,3.803900E-03,2.060200E-02,8.019100E-02,1.532100E-01,& + & 3.007700E-01,6.572700E-01,2.714000E+00,3.209100E+01,1.812300E+02/ + data absb(:,341:360) / & + & 1.120900E-05,6.964300E-05,4.527800E-04,3.086300E-03,1.615700E-02,& + & 5.144800E-02,1.540100E-01,5.579000E-01,3.999800E+00,1.970000E+01,& + & 3.786800E+01,7.865900E+01,2.261300E+02,1.033900E+03,4.039200E+03,& + & 9.241200E+03,2.973700E-05,1.185500E-04,5.578500E-04,3.055400E-03,& + & 1.369800E-02,4.117400E-02,1.215000E-01,4.382100E-01,3.125300E+00,& + & 1.513500E+01,2.882900E+01,5.943900E+01,1.696100E+02,7.753800E+02,& + & 3.029300E+03,6.930400E+03,3.213300E-05,1.195800E-04,4.975300E-04,& + & 2.412300E-03,9.905700E-03,2.884400E-02,8.421800E-02,3.023700E-01,& + & 2.165800E+00,1.053400E+01,1.985400E+01,4.075600E+01,1.148100E+02,& + & 5.169100E+02,2.019600E+03,4.620700E+03,2.904600E-05,1.014400E-04,& + & 3.729300E-04,1.550200E-03,5.593400E-03,1.571200E-02,4.502200E-02,& + & 1.605600E-01,1.150500E+00,5.619700E+00,1.059300E+01,2.181400E+01,& + & 6.080900E+01,2.617300E+02,1.009800E+03,2.310200E+03,1.394100E-05,& + & 4.183600E-05,7.635700E-05,1.373200E-04,2.789700E-04,5.589000E-04,& + & 1.342000E-03,4.665800E-03,2.512000E-02,9.760100E-02,1.838100E-01,& + & 3.509500E-01,7.587700E-01,3.761400E+00,4.050400E+01,2.263900E+02,& + & 1.544300E-05,1.058900E-04,7.049500E-04,4.599900E-03,2.189500E-02,& + & 6.770800E-02,1.984700E-01,7.237700E-01,5.141700E+00,2.485700E+01,& + & 4.732100E+01,9.665800E+01,2.733900E+02,1.237700E+03,4.864300E+03,& + & 1.107000E+04,4.019600E-05,1.712800E-04,8.285900E-04,4.408100E-03,& + & 1.834900E-02,5.415100E-02,1.562600E-01,5.683700E-01,4.012500E+00,& + & 1.907200E+01,3.603000E+01,7.299700E+01,2.050700E+02,9.282200E+02,& + & 3.648400E+03,8.302900E+03,4.330200E-05,1.696900E-04,7.205500E-04,& + & 3.415900E-03,1.319900E-02,3.787600E-02,1.082200E-01,3.919600E-01,& + & 2.780500E+00,1.324800E+01,2.479500E+01,5.003900E+01,1.388300E+02,& + & 6.188100E+02,2.432300E+03,5.535100E+03,3.863900E-05,1.403300E-04,& + & 5.270200E-04,2.140200E-03,7.399200E-03,2.055900E-02,5.783300E-02,& + & 2.079500E-01,1.475600E+00,7.065300E+00,1.324700E+01,2.674200E+01,& + & 7.361600E+01,3.133900E+02,1.216100E+03,2.767600E+03,1.648100E-05,& + & 4.921900E-05,9.148300E-05,1.638600E-04,3.323800E-04,6.698300E-04,& + & 1.605700E-03,5.627500E-03,3.018800E-02,1.170400E-01,2.157700E-01,& + & 4.072700E-01,9.022100E-01,5.052400E+00,4.985300E+01,2.764500E+02,& + & 4.502900E-06,1.755900E-05,8.890500E-05,6.704000E-04,4.837200E-03,& + & 1.789600E-02,5.679300E-02,2.041100E-01,1.551700E+00,7.708100E+00,& + & 1.555200E+01,3.508900E+01,1.028600E+02,5.168000E+02,2.237200E+03,& + & 5.265800E+03,1.064600E-05,3.231300E-05,1.313600E-04,7.604900E-04,& + & 4.290900E-03,1.442900E-02,4.505700E-02,1.608800E-01,1.218100E+00,& + & 5.988500E+00,1.189300E+01,2.661900E+01,7.719700E+01,3.876000E+02,& + & 1.677900E+03,3.974500E+03,1.142900E-05,3.421600E-05,1.269000E-04,& + & 6.393100E-04,3.193500E-03,1.015200E-02,3.133900E-02,1.113100E-01,& + & 8.430300E-01,4.181400E+00,8.278700E+00,1.832500E+01,5.252000E+01,& + & 2.584400E+02,1.118700E+03,2.649700E+03,1.054900E-05,3.083500E-05,& + & 1.031200E-04,4.442400E-04,1.870300E-03,5.577200E-03,1.684200E-02,& + & 5.930300E-02,4.476200E-01,2.230600E+00,4.440100E+00,9.888100E+00,& + & 2.788100E+01,1.313900E+02,5.593200E+02,1.324800E+03,6.426300E-06,& + & 1.825500E-05,3.555600E-05,6.589000E-05,1.222200E-04,2.442700E-04,& + & 6.057100E-04,2.056800E-03,1.192200E-02,4.740900E-02,9.547800E-02,& + & 1.987600E-01,4.206700E-01,1.464400E+00,1.941200E+01,1.219900E+02,& + & 5.540800E-06,2.618200E-05,1.515700E-04,1.128200E-03,7.221900E-03,& + & 2.504200E-02,7.802700E-02,2.825600E-01,2.118700E+00,1.057600E+01,& + & 2.112900E+01,4.589900E+01,1.333900E+02,6.687700E+02,2.896400E+03,& + & 6.904600E+03,1.412400E-05,4.807900E-05,2.099300E-04,1.209600E-03,& + & 6.278500E-03,2.015700E-02,6.173200E-02,2.226000E-01,1.662500E+00,& + & 8.191500E+00,1.615700E+01,3.480000E+01,1.001000E+02,5.015800E+02,& + & 2.172300E+03,5.178100E+03,1.527200E-05,5.026700E-05,1.970800E-04,& + & 9.910500E-04,4.615000E-03,1.417300E-02,4.285300E-02,1.539200E-01,& + & 1.150800E+00,5.718200E+00,1.121100E+01,2.394400E+01,6.815900E+01,& + & 3.344200E+02,1.448200E+03,3.430500E+03,1.408000E-05,4.449800E-05,& + & 1.555000E-04,6.694100E-04,2.659400E-03,7.757100E-03,2.296800E-02,& + & 8.196100E-02,6.107800E-01,3.050400E+00,5.997000E+00,1.289000E+01,& + & 3.627200E+01,1.700600E+02,7.241000E+02,1.726100E+03,8.012800E-06,& + & 2.304200E-05,4.370800E-05,8.087600E-05,1.556400E-04,3.097900E-04,& + & 7.618000E-04,2.634900E-03,1.509000E-02,5.851200E-02,1.193000E-01,& + & 2.329800E-01,5.299400E-01,1.974300E+00,2.619900E+01,1.596700E+02/ + data absb(:,361:380) / & + & 7.223500E-06,4.035000E-05,2.531300E-04,1.814700E-03,1.038400E-02,& + & 3.420800E-02,1.042100E-01,3.825100E-01,2.828500E+00,1.401400E+01,& + & 2.779800E+01,5.873700E+01,1.684100E+02,8.391200E+02,3.636300E+03,& + & 8.680900E+03,1.912800E-05,7.154000E-05,3.277900E-04,1.855600E-03,& + & 8.891200E-03,2.747500E-02,8.231400E-02,3.011200E-01,2.217400E+00,& + & 1.083700E+01,2.124800E+01,4.450600E+01,1.264000E+02,6.293500E+02,& + & 2.727200E+03,6.510500E+03,2.073400E-05,7.335900E-05,2.994300E-04,& + & 1.488900E-03,6.466400E-03,1.928400E-02,5.710900E-02,2.080500E-01,& + & 1.534400E+00,7.562900E+00,1.471400E+01,3.059600E+01,8.608700E+01,& + & 4.196400E+02,1.818100E+03,4.340300E+03,1.890200E-05,6.353800E-05,& + & 2.297400E-04,9.771400E-04,3.677800E-03,1.052700E-02,3.057900E-02,& + & 1.106800E-01,8.139000E-01,4.031500E+00,7.858800E+00,1.644500E+01,& + & 4.588600E+01,2.134300E+02,9.091200E+02,2.170000E+03,9.787400E-06,& + & 2.835900E-05,5.244900E-05,9.634400E-05,1.936100E-04,3.867100E-04,& + & 9.457300E-04,3.277200E-03,1.873300E-02,7.395500E-02,1.414700E-01,& + & 2.819100E-01,6.214400E-01,2.642300E+00,3.416400E+01,2.031700E+02,& + & 9.804400E-06,6.222700E-05,4.070700E-04,2.794000E-03,1.440100E-02,& + & 4.583700E-02,1.365100E-01,5.056200E-01,3.694600E+00,1.811300E+01,& + & 3.543700E+01,7.377000E+01,2.079600E+02,1.025500E+03,4.448700E+03,& + & 1.051400E+04,2.602200E-05,1.050000E-04,4.985000E-04,2.751600E-03,& + & 1.218300E-02,3.671700E-02,1.076900E-01,3.978500E-01,2.893800E+00,& + & 1.397300E+01,2.708400E+01,5.585800E+01,1.561000E+02,7.690700E+02,& + & 3.336500E+03,7.933700E+03,2.810200E-05,1.055000E-04,4.426700E-04,& + & 2.162700E-03,8.798400E-03,2.572900E-02,7.464500E-02,2.746400E-01,& + & 2.002600E+00,9.739000E+00,1.874000E+01,3.836900E+01,1.062900E+02,& + & 5.128400E+02,2.224400E+03,5.289300E+03,2.532100E-05,8.923100E-05,& + & 3.310700E-04,1.381100E-03,4.956600E-03,1.400500E-02,3.991500E-02,& + & 1.459800E-01,1.061100E+00,5.184700E+00,1.002400E+01,2.060100E+01,& + & 5.670200E+01,2.609100E+02,1.112200E+03,2.644800E+03,1.164200E-05,& + & 3.380400E-05,6.315300E-05,1.154600E-04,2.344500E-04,4.739900E-04,& + & 1.142500E-03,4.007700E-03,2.296400E-02,9.079400E-02,1.696600E-01,& + & 3.248100E-01,7.296300E-01,3.593900E+00,4.300300E+01,2.520200E+02,& + & 1.353100E-05,9.412900E-05,6.280400E-04,4.120600E-03,1.940000E-02,& + & 6.028400E-02,1.759100E-01,6.544500E-01,4.729700E+00,2.286200E+01,& + & 4.419600E+01,9.110700E+01,2.515900E+02,1.227300E+03,5.319300E+03,& + & 1.254800E+04,3.505800E-05,1.511400E-04,7.343400E-04,3.934000E-03,& + & 1.624300E-02,4.820500E-02,1.386200E-01,5.144100E-01,3.702600E+00,& + & 1.759300E+01,3.377800E+01,6.894000E+01,1.888800E+02,9.204800E+02,& + & 3.989400E+03,9.411500E+03,3.776200E-05,1.490300E-04,6.374800E-04,& + & 3.036300E-03,1.167000E-02,3.372200E-02,9.601800E-02,3.549700E-01,& + & 2.563900E+00,1.224600E+01,2.335000E+01,4.729600E+01,1.286500E+02,& + & 6.137800E+02,2.659600E+03,6.274600E+03,3.358000E-05,1.228500E-04,& + & 4.647000E-04,1.895600E-03,6.531600E-03,1.827500E-02,5.132500E-02,& + & 1.885100E-01,1.358500E+00,6.522800E+00,1.249400E+01,2.535600E+01,& + & 6.869100E+01,3.122600E+02,1.329800E+03,3.137300E+03,1.371200E-05,& + & 4.008200E-05,7.441000E-05,1.379100E-04,2.786900E-04,5.665700E-04,& + & 1.360800E-03,4.805500E-03,2.779900E-02,1.087100E-01,2.014200E-01,& + & 3.817100E-01,8.656300E-01,4.826500E+00,5.270100E+01,3.056800E+02,& + & 3.826700E-06,1.557000E-05,8.107100E-05,6.196300E-04,4.390700E-03,& + & 1.600900E-02,5.083200E-02,1.862800E-01,1.455700E+00,7.206300E+00,& + & 1.468300E+01,3.281800E+01,9.525600E+01,5.147100E+02,2.511600E+03,& + & 6.204000E+03,9.260500E-06,2.872900E-05,1.189300E-04,6.961700E-04,& + & 3.880000E-03,1.291200E-02,4.033500E-02,1.469900E-01,1.145000E+00,& + & 5.619600E+00,1.129200E+01,2.494300E+01,7.161900E+01,3.860400E+02,& + & 1.883700E+03,4.652900E+03,9.975300E-06,3.039100E-05,1.144100E-04,& + & 5.820500E-04,2.878500E-03,9.095000E-03,2.806200E-02,1.017100E-01,& + & 7.912400E-01,3.920300E+00,7.871800E+00,1.728000E+01,4.893600E+01,& + & 2.576100E+02,1.255800E+03,3.102000E+03,9.208700E-06,2.733100E-05,& + & 9.267000E-05,4.023900E-04,1.679300E-03,4.990700E-03,1.508000E-02,& + & 5.423500E-02,4.192200E-01,2.088200E+00,4.210600E+00,9.322600E+00,& + & 2.627700E+01,1.316100E+02,6.278400E+02,1.551100E+03,5.491000E-06,& + & 1.492800E-05,2.904800E-05,5.384200E-05,1.035200E-04,2.074900E-04,& + & 5.095900E-04,1.779900E-03,1.067100E-02,4.312900E-02,8.735600E-02,& + & 1.781700E-01,4.067600E-01,1.497500E+00,2.087600E+01,1.374900E+02/ + data absb(:,381:400) / & + & 4.781300E-06,2.345400E-05,1.381800E-04,1.035400E-03,6.518000E-03,& + & 2.234400E-02,6.949100E-02,2.574900E-01,1.980700E+00,9.781700E+00,& + & 1.988600E+01,4.318400E+01,1.233700E+02,6.639000E+02,3.218900E+03,& + & 7.979900E+03,1.236100E-05,4.286800E-05,1.893700E-04,1.101300E-03,& + & 5.650000E-03,1.799300E-02,5.497300E-02,2.032200E-01,1.557200E+00,& + & 7.608500E+00,1.528100E+01,3.281100E+01,9.272600E+01,4.979300E+02,& + & 2.414200E+03,5.985400E+03,1.338100E-05,4.464700E-05,1.773000E-04,& + & 8.981500E-04,4.143100E-03,1.264600E-02,3.818700E-02,1.405300E-01,& + & 1.076200E+00,5.308400E+00,1.063800E+01,2.266800E+01,6.344300E+01,& + & 3.322700E+02,1.609600E+03,3.990100E+03,1.230100E-05,3.941600E-05,& + & 1.393200E-04,6.029800E-04,2.378100E-03,6.927300E-03,2.046600E-02,& + & 7.488100E-02,5.702400E-01,2.819600E+00,5.686100E+00,1.220800E+01,& + & 3.407200E+01,1.698400E+02,8.047600E+02,1.995200E+03,6.780900E-06,& + & 1.868500E-05,3.546700E-05,6.602200E-05,1.309000E-04,2.619600E-04,& + & 6.448800E-04,2.251500E-03,1.358500E-02,5.481200E-02,1.071400E-01,& + & 2.185700E-01,4.997800E-01,1.975500E+00,2.794900E+01,1.786900E+02,& + & 6.305200E-06,3.621800E-05,2.292500E-04,1.651600E-03,9.299500E-03,& + & 3.051600E-02,9.268400E-02,3.472800E-01,2.635300E+00,1.290400E+01,& + & 2.597300E+01,5.561600E+01,1.558300E+02,8.309900E+02,4.008500E+03,& + & 9.915700E+03,1.678400E-05,6.362700E-05,2.944900E-04,1.679700E-03,& + & 7.942800E-03,2.452100E-02,7.323000E-02,2.738000E-01,2.069400E+00,& + & 1.002900E+01,1.993700E+01,4.223500E+01,1.171200E+02,6.232800E+02,& + & 3.006000E+03,7.438500E+03,1.818400E-05,6.499500E-05,2.676200E-04,& + & 1.341200E-03,5.764100E-03,1.721600E-02,5.082300E-02,1.892000E-01,& + & 1.429700E+00,7.002500E+00,1.387100E+01,2.910500E+01,8.017400E+01,& + & 4.159000E+02,2.004200E+03,4.957800E+03,1.652000E-05,5.610600E-05,& + & 2.048400E-04,8.750700E-04,3.268400E-03,9.389700E-03,2.721600E-02,& + & 1.007500E-01,7.565200E-01,3.723600E+00,7.421000E+00,1.565600E+01,& + & 4.304600E+01,2.126600E+02,1.002100E+03,2.479300E+03,8.187200E-06,& + & 2.277000E-05,4.299400E-05,8.012300E-05,1.616300E-04,3.259400E-04,& + & 7.960600E-04,2.786300E-03,1.701200E-02,6.839500E-02,1.306100E-01,& + & 2.576200E-01,5.721800E-01,2.659200E+00,3.615600E+01,2.257300E+02,& + & 8.609200E-06,5.568600E-05,3.654400E-04,2.519700E-03,1.280600E-02,& + & 4.085600E-02,1.215500E-01,4.575500E-01,3.426800E+00,1.669600E+01,& + & 3.303200E+01,7.025900E+01,1.922300E+02,1.015900E+03,4.866000E+03,& + & 1.196100E+04,2.280000E-05,9.311300E-05,4.442700E-04,2.470900E-03,& + & 1.081600E-02,3.275500E-02,9.588600E-02,3.604400E-01,2.690000E+00,& + & 1.293500E+01,2.534500E+01,5.331900E+01,1.444700E+02,7.619700E+02,& + & 3.649500E+03,8.970600E+03,2.460300E-05,9.310000E-05,3.935600E-04,& + & 1.933800E-03,7.799200E-03,2.295800E-02,6.645500E-02,2.489400E-01,& + & 1.860000E+00,9.013500E+00,1.763000E+01,3.665900E+01,9.892600E+01,& + & 5.084200E+02,2.432900E+03,5.979900E+03,2.207800E-05,7.849700E-05,& + & 2.933800E-04,1.227400E-03,4.386300E-03,1.247500E-02,3.554800E-02,& + & 1.324300E-01,9.835700E-01,4.794300E+00,9.439900E+00,1.969300E+01,& + & 5.316400E+01,2.599400E+02,1.216500E+03,2.990000E+03,9.654100E-06,& + & 2.736300E-05,5.133500E-05,9.707400E-05,1.942200E-04,3.974800E-04,& + & 9.567800E-04,3.390300E-03,2.100500E-02,8.271600E-02,1.574400E-01,& + & 3.037100E-01,6.968300E-01,3.485400E+00,4.544800E+01,2.780600E+02,& + & 1.189100E-05,8.368600E-05,5.587300E-04,3.674400E-03,1.715500E-02,& + & 5.362700E-02,1.568800E-01,5.904500E-01,4.375400E+00,2.109600E+01,& + & 4.121000E+01,8.712300E+01,2.331500E+02,1.216800E+03,5.776400E+03,& + & 1.406000E+04,3.061300E-05,1.333900E-04,6.511300E-04,3.495800E-03,& + & 1.436100E-02,4.290000E-02,1.236300E-01,4.649400E-01,3.433700E+00,& + & 1.630900E+01,3.158200E+01,6.607900E+01,1.752100E+02,9.126200E+02,& + & 4.332200E+03,1.054500E+04,3.296400E-05,1.310400E-04,5.634600E-04,& + & 2.690000E-03,1.030500E-02,3.001400E-02,8.558300E-02,3.210100E-01,& + & 2.374500E+00,1.136800E+01,2.193300E+01,4.539600E+01,1.199200E+02,& + & 6.089800E+02,2.888300E+03,7.030000E+03,2.919900E-05,1.075500E-04,& + & 4.093300E-04,1.673100E-03,5.759900E-03,1.624700E-02,4.573200E-02,& + & 1.705200E-01,1.255000E+00,6.050600E+00,1.175900E+01,2.437900E+01,& + & 6.441800E+01,3.113800E+02,1.444200E+03,3.515100E+03,1.137100E-05,& + & 3.254100E-05,6.014400E-05,1.160300E-04,2.302000E-04,4.738700E-04,& + & 1.141500E-03,4.040400E-03,2.555600E-02,9.993500E-02,1.845600E-01,& + & 3.547800E-01,8.187800E-01,4.683700E+00,5.559100E+01,3.349900E+02/ + data absb(:,401:420) / & + & 3.255400E-06,1.384300E-05,7.420300E-05,5.725500E-04,3.973000E-03,& + & 1.426200E-02,4.529600E-02,1.689700E-01,1.357500E+00,6.727800E+00,& + & 1.379000E+01,3.085900E+01,8.853200E+01,5.081700E+02,2.778800E+03,& + & 7.134100E+03,8.064600E-06,2.562300E-05,1.078100E-04,6.371900E-04,& + & 3.503300E-03,1.152200E-02,3.592200E-02,1.335800E-01,1.070700E+00,& + & 5.263600E+00,1.066200E+01,2.351100E+01,6.669500E+01,3.811300E+02,& + & 2.084200E+03,5.350600E+03,8.711500E-06,2.706500E-05,1.034100E-04,& + & 5.300100E-04,2.590300E-03,8.111500E-03,2.499200E-02,9.250100E-02,& + & 7.389900E-01,3.671700E+00,7.445100E+00,1.636000E+01,4.575700E+01,& + & 2.547400E+02,1.389500E+03,3.567100E+03,8.044300E-06,2.429500E-05,& + & 8.345800E-05,3.641500E-04,1.504300E-03,4.453000E-03,1.342300E-02,& + & 4.942200E-02,3.916300E-01,1.943700E+00,3.976600E+00,8.828000E+00,& + & 2.481000E+01,1.309200E+02,6.947700E+02,1.783500E+03,4.659700E-06,& + & 1.213400E-05,2.367100E-05,4.378300E-05,8.613800E-05,1.740700E-04,& + & 4.274300E-04,1.507000E-03,9.518700E-03,3.926600E-02,7.802100E-02,& + & 1.667900E-01,3.849200E-01,1.486100E+00,2.256100E+01,1.539800E+02,& + & 4.126700E-06,2.100900E-05,1.260500E-04,9.489900E-04,5.850100E-03,& + & 1.988700E-02,6.169400E-02,2.329400E-01,1.844300E+00,9.051500E+00,& + & 1.850700E+01,4.086700E+01,1.146300E+02,6.538500E+02,3.529800E+03,& + & 9.057700E+03,1.082600E-05,3.824800E-05,1.711300E-04,1.000600E-03,& + & 5.058900E-03,1.602700E-02,4.883300E-02,1.840600E-01,1.453400E+00,& + & 7.071000E+00,1.428800E+01,3.112800E+01,8.632500E+01,4.903800E+02,& + & 2.647200E+03,6.793500E+03,1.173700E-05,3.973200E-05,1.593600E-04,& + & 8.134100E-04,3.698100E-03,1.127600E-02,3.392200E-02,1.273300E-01,& + & 1.002900E+00,4.935500E+00,9.975800E+00,2.158400E+01,5.930000E+01,& + & 3.276800E+02,1.764800E+03,4.529000E+03,1.075400E-05,3.497700E-05,& + & 1.248700E-04,5.424300E-04,2.116500E-03,6.168700E-03,1.819100E-02,& + & 6.794200E-02,5.308900E-01,2.613000E+00,5.336300E+00,1.163100E+01,& + & 3.208700E+01,1.685100E+02,8.824600E+02,2.264300E+03,5.716900E-06,& + & 1.504400E-05,2.912100E-05,5.393000E-05,1.086600E-04,2.185400E-04,& + & 5.390700E-04,1.897500E-03,1.220700E-02,4.983400E-02,9.582000E-02,& + & 2.045100E-01,4.464600E-01,1.980700E+00,2.993600E+01,1.986300E+02,& + & 5.499800E-06,3.248300E-05,2.070300E-04,1.497300E-03,8.275200E-03,& + & 2.714100E-02,8.227600E-02,3.130700E-01,2.444300E+00,1.191900E+01,& + & 2.409100E+01,5.291500E+01,1.443800E+02,8.186200E+02,4.359700E+03,& + & 1.112200E+04,1.472200E-05,5.667600E-05,2.639500E-04,1.514300E-03,& + & 7.054000E-03,2.182700E-02,6.505300E-02,2.470400E-01,1.924500E+00,& + & 9.297800E+00,1.857500E+01,4.029400E+01,1.086900E+02,6.139700E+02,& + & 3.269600E+03,8.342600E+03,1.594400E-05,5.756900E-05,2.391900E-04,& + & 1.204800E-03,5.112200E-03,1.532300E-02,4.514800E-02,1.708100E-01,& + & 1.329300E+00,6.477000E+00,1.297700E+01,2.784500E+01,7.477200E+01,& + & 4.101300E+02,2.179800E+03,5.561500E+03,1.444100E-05,4.959200E-05,& + & 1.824800E-04,7.808300E-04,2.893800E-03,8.351800E-03,2.417100E-02,& + & 9.104300E-02,7.024900E-01,3.441200E+00,6.939800E+00,1.498700E+01,& + & 4.046800E+01,2.109000E+02,1.089900E+03,2.780600E+03,6.832600E-06,& + & 1.840800E-05,3.505700E-05,6.680300E-05,1.320600E-04,2.711600E-04,& + & 6.593500E-04,2.337500E-03,1.529200E-02,6.207700E-02,1.189800E-01,& + & 2.367000E-01,5.395300E-01,2.608300E+00,3.846400E+01,2.490300E+02,& + & 7.545400E-06,4.971200E-05,3.274100E-04,2.257200E-03,1.132300E-02,& + & 3.624600E-02,1.079100E-01,4.112600E-01,3.171500E+00,1.538000E+01,& + & 3.065200E+01,6.702800E+01,1.785100E+02,1.001500E+03,5.252600E+03,& + & 1.328000E+04,1.995700E-05,8.257400E-05,3.959800E-04,2.204400E-03,& + & 9.554800E-03,2.909200E-02,8.519700E-02,3.243200E-01,2.495800E+00,& + & 1.197800E+01,2.359300E+01,5.103000E+01,1.343400E+02,7.511500E+02,& + & 3.939500E+03,9.960900E+03,2.153300E-05,8.223400E-05,3.495200E-04,& + & 1.719900E-03,6.880900E-03,2.038600E-02,5.906600E-02,2.241700E-01,& + & 1.723700E+00,8.349900E+00,1.647400E+01,3.519000E+01,9.241200E+01,& + & 5.016900E+02,2.626300E+03,6.640000E+03,1.925600E-05,6.902500E-05,& + & 2.596100E-04,1.086100E-03,3.863900E-03,1.106400E-02,3.159800E-02,& + & 1.193100E-01,9.103600E-01,4.436200E+00,8.825100E+00,1.894400E+01,& + & 4.995400E+01,2.579900E+02,1.313100E+03,3.319900E+03,8.067400E-06,& + & 2.225900E-05,4.144400E-05,8.098500E-05,1.577000E-04,3.287400E-04,& + & 7.935800E-04,2.819900E-03,1.885100E-02,7.679800E-02,1.437300E-01,& + & 2.799900E-01,6.410700E-01,3.436600E+00,4.812500E+01,3.045000E+02/ + data absb(:,421:440) / & + & 1.042100E-05,7.430300E-05,4.962400E-04,3.252700E-03,1.508700E-02,& + & 4.742700E-02,1.396400E-01,5.299200E-01,4.041000E+00,1.942000E+01,& + & 3.826800E+01,8.316900E+01,2.175200E+02,1.200400E+03,6.195600E+03,& + & 1.547800E+04,2.669200E-05,1.175300E-04,5.766100E-04,3.084900E-03,& + & 1.262400E-02,3.801900E-02,1.100500E-01,4.177000E-01,3.179000E+00,& + & 1.509700E+01,2.941900E+01,6.327300E+01,1.636500E+02,9.002300E+02,& + & 4.646700E+03,1.160900E+04,2.875200E-05,1.152600E-04,4.972400E-04,& + & 2.368500E-03,9.049800E-03,2.658500E-02,7.623500E-02,2.886000E-01,& + & 2.196400E+00,1.053600E+01,2.053400E+01,4.357100E+01,1.124600E+02,& + & 6.013000E+02,3.097900E+03,7.739400E+03,2.537800E-05,9.415900E-05,& + & 3.600600E-04,1.468600E-03,5.049100E-03,1.438500E-02,4.071300E-02,& + & 1.533700E-01,1.159000E+00,5.604500E+00,1.102600E+01,2.347400E+01,& + & 6.072400E+01,3.091100E+02,1.548900E+03,3.869700E+03,9.463500E-06,& + & 2.634300E-05,4.875100E-05,9.620100E-05,1.880500E-04,3.897200E-04,& + & 9.451900E-04,3.353500E-03,2.312100E-02,9.166900E-02,1.683700E-01,& + & 3.296300E-01,7.636500E-01,4.630900E+00,5.861500E+01,3.643100E+02,& + & 2.772200E-06,1.228300E-05,6.767700E-05,5.263700E-04,3.571900E-03,& + & 1.267600E-02,4.018500E-02,1.524200E-01,1.261500E+00,6.288200E+00,& + & 1.283500E+01,2.918100E+01,8.271000E+01,4.989000E+02,3.036900E+03,& + & 8.056600E+03,7.025700E-06,2.282600E-05,9.746800E-05,5.808100E-04,& + & 3.139900E-03,1.024600E-02,3.188600E-02,1.207100E-01,9.970500E-01,& + & 4.935500E+00,9.984200E+00,2.230800E+01,6.247600E+01,3.741600E+02,& + & 2.277700E+03,6.042300E+03,7.607000E-06,2.407700E-05,9.313800E-05,& + & 4.801000E-04,2.316200E-03,7.217300E-03,2.219500E-02,8.366400E-02,& + & 6.881000E-01,3.432300E+00,6.989300E+00,1.557000E+01,4.304500E+01,& + & 2.505100E+02,1.518500E+03,4.028400E+03,7.020900E-06,2.158600E-05,& + & 7.492300E-05,3.281600E-04,1.339200E-03,3.963700E-03,1.191900E-02,& + & 4.477800E-02,3.645100E-01,1.811500E+00,3.728600E+00,8.404600E+00,& + & 2.351100E+01,1.296700E+02,7.592600E+02,2.014200E+03,3.914800E-06,& + & 9.701700E-06,1.928700E-05,3.553600E-05,7.137300E-05,1.441600E-04,& + & 3.548500E-04,1.266900E-03,8.424100E-03,3.571300E-02,6.976500E-02,& + & 1.521700E-01,3.418900E-01,1.479200E+00,2.441300E+01,1.711500E+02,& + & 3.562900E-06,1.879600E-05,1.143100E-04,8.628900E-04,5.210700E-03,& + & 1.765300E-02,5.462600E-02,2.092700E-01,1.710200E+00,8.416900E+00,& + & 1.712600E+01,3.881000E+01,1.067500E+02,6.418300E+02,3.824400E+03,& + & 1.010100E+04,9.475300E-06,3.407000E-05,1.537400E-04,9.035700E-04,& + & 4.498600E-03,1.424400E-02,4.327800E-02,1.655900E-01,1.351000E+00,& + & 6.590600E+00,1.330500E+01,2.966400E+01,8.058600E+01,4.813700E+02,& + & 2.868400E+03,7.575900E+03,1.028700E-05,3.521600E-05,1.428400E-04,& + & 7.321500E-04,3.281600E-03,1.001700E-02,3.008400E-02,1.146500E-01,& + & 9.320300E-01,4.584100E+00,9.323800E+00,2.063400E+01,5.562000E+01,& + & 3.221300E+02,1.912200E+03,5.050500E+03,9.395100E-06,3.099000E-05,& + & 1.115300E-04,4.852100E-04,1.873000E-03,5.477000E-03,1.613500E-02,& + & 6.129000E-02,4.926200E-01,2.426200E+00,4.978500E+00,1.113100E+01,& + & 3.034500E+01,1.667100E+02,9.560900E+02,2.525200E+03,4.764100E-06,& + & 1.206000E-05,2.359100E-05,4.482400E-05,8.811900E-05,1.811300E-04,& + & 4.430300E-04,1.582400E-03,1.076900E-02,4.575200E-02,8.799000E-02,& + & 1.825500E-01,4.057800E-01,1.963900E+00,3.206100E+01,2.190100E+02,& + & 4.793200E-06,2.905200E-05,1.862300E-04,1.345600E-03,7.316500E-03,& + & 2.402200E-02,7.295300E-02,2.803600E-01,2.260200E+00,1.102400E+01,& + & 2.231900E+01,5.031600E+01,1.348200E+02,8.045700E+02,4.685900E+03,& + & 1.226700E+04,1.289300E-05,5.036100E-05,2.358300E-04,1.355300E-03,& + & 6.231500E-03,1.934100E-02,5.770100E-02,2.216700E-01,1.784500E+00,& + & 8.636300E+00,1.727800E+01,3.845600E+01,1.016900E+02,6.034200E+02,& + & 3.514100E+03,9.199500E+03,1.395900E-05,5.095000E-05,2.129100E-04,& + & 1.074700E-03,4.507800E-03,1.358300E-02,4.004800E-02,1.534000E-01,& + & 1.231500E+00,6.014500E+00,1.210000E+01,2.668600E+01,7.022600E+01,& + & 4.036900E+02,2.343000E+03,6.133400E+03,1.260000E-05,4.371600E-05,& + & 1.619300E-04,6.922300E-04,2.546900E-03,7.399800E-03,2.144200E-02,& + & 8.186500E-02,6.502400E-01,3.186400E+00,6.472800E+00,1.439300E+01,& + & 3.822400E+01,2.088900E+02,1.171500E+03,3.066800E+03,5.670800E-06,& + & 1.484700E-05,2.815800E-05,5.531900E-05,1.066200E-04,2.228200E-04,& + & 5.416900E-04,1.934200E-03,1.356900E-02,5.747300E-02,1.083000E-01,& + & 2.148900E-01,5.041800E-01,2.556400E+00,4.093300E+01,2.724300E+02/ + data absb(:,441:460) / & + & 6.598200E-06,4.424500E-05,2.918000E-04,2.006500E-03,9.952000E-03,& + & 3.199600E-02,9.581200E-02,3.679600E-01,2.927500E+00,1.419200E+01,& + & 2.841200E+01,6.365200E+01,1.675200E+02,9.852100E+02,5.606500E+03,& + & 1.451100E+04,1.743100E-05,7.292900E-05,3.516300E-04,1.950700E-03,& + & 8.389200E-03,2.572100E-02,7.570100E-02,2.906500E-01,2.310300E+00,& + & 1.110300E+01,2.195600E+01,4.862500E+01,1.262800E+02,7.389000E+02,& + & 4.205000E+03,1.088300E+04,1.881000E-05,7.248700E-05,3.092100E-04,& + & 1.517200E-03,6.032700E-03,1.802700E-02,5.249700E-02,2.010000E-01,& + & 1.594700E+00,7.743900E+00,1.538300E+01,3.367500E+01,8.717900E+01,& + & 4.941500E+02,2.803200E+03,7.255600E+03,1.675900E-05,6.057100E-05,& + & 2.289200E-04,9.551800E-04,3.384700E-03,9.778500E-03,2.807500E-02,& + & 1.070700E-01,8.408500E-01,4.112000E+00,8.249300E+00,1.818800E+01,& + & 4.733400E+01,2.556400E+02,1.401600E+03,3.627900E+03,6.690200E-06,& + & 1.786800E-05,3.332800E-05,6.682800E-05,1.280300E-04,2.678400E-04,& + & 6.550900E-04,2.314300E-03,1.686800E-02,7.072900E-02,1.285400E-01,& + & 2.525800E-01,5.978900E-01,3.416200E+00,5.089700E+01,3.308200E+02,& + & 9.106600E-06,6.568600E-05,4.391800E-04,2.857300E-03,1.316600E-02,& + & 4.177300E-02,1.240200E-01,4.740700E-01,3.727200E+00,1.789000E+01,& + & 3.554000E+01,7.895600E+01,2.054800E+02,1.182000E+03,6.571700E+03,& + & 1.677200E+04,2.323100E-05,1.033600E-04,5.085400E-04,2.700800E-03,& + & 1.102900E-02,3.351200E-02,9.786200E-02,3.743100E-01,2.940100E+00,& + & 1.397800E+01,2.742200E+01,6.028200E+01,1.547700E+02,8.865100E+02,& + & 4.928700E+03,1.257900E+04,2.504100E-05,1.010800E-04,4.375100E-04,& + & 2.071200E-03,7.900300E-03,2.345000E-02,6.780600E-02,2.584900E-01,& + & 2.030100E+00,9.765100E+00,1.922100E+01,4.167100E+01,1.067800E+02,& + & 5.927400E+02,3.285800E+03,8.385800E+03,2.203100E-05,8.223500E-05,& + & 3.156900E-04,1.280200E-03,4.403000E-03,1.268800E-02,3.623500E-02,& + & 1.374500E-01,1.070100E+00,5.186000E+00,1.033200E+01,2.256900E+01,& + & 5.781100E+01,3.064600E+02,1.642900E+03,4.193100E+03,7.839400E-06,& + & 2.087700E-05,3.950100E-05,7.931300E-05,1.512100E-04,3.173700E-04,& + & 7.785000E-04,2.761200E-03,2.072000E-02,8.553400E-02,1.504100E-01,& + & 2.964200E-01,7.230400E-01,4.634500E+00,6.172100E+01,3.931700E+02,& + & 2.350600E-06,1.086400E-05,6.139300E-05,4.794500E-04,3.178800E-03,& + & 1.117800E-02,3.534800E-02,1.361100E-01,1.162800E+00,5.843900E+00,& + & 1.186600E+01,2.753800E+01,7.698900E+01,4.868200E+02,3.264800E+03,& + & 8.898200E+03,6.105200E-06,2.030300E-05,8.769400E-05,5.244700E-04,& + & 2.786400E-03,9.051400E-03,2.809000E-02,1.079600E-01,9.213000E-01,& + & 4.605100E+00,9.284000E+00,2.115900E+01,5.832200E+01,3.651300E+02,& + & 2.448600E+03,6.673900E+03,6.630500E-06,2.134100E-05,8.363000E-05,& + & 4.324900E-04,2.050700E-03,6.380100E-03,1.955900E-02,7.486500E-02,& + & 6.354800E-01,3.195700E+00,6.515300E+00,1.481500E+01,4.041400E+01,& + & 2.449400E+02,1.632400E+03,4.449300E+03,6.119600E-06,1.913800E-05,& + & 6.704800E-05,2.938300E-04,1.182500E-03,3.504800E-03,1.051300E-02,& + & 4.012200E-02,3.362900E-01,1.686300E+00,3.469300E+00,8.000200E+00,& + & 2.225200E+01,1.277500E+02,8.161800E+02,2.224500E+03,3.286100E-06,& + & 7.831200E-06,1.538200E-05,2.939000E-05,5.720000E-05,1.177000E-04,& + & 2.903900E-04,1.047900E-03,7.321200E-03,3.265400E-02,6.288000E-02,& + & 1.352300E-01,3.059200E-01,1.454900E+00,2.642600E+01,1.890100E+02,& + & 3.061600E-06,1.671800E-05,1.029000E-04,7.758700E-04,4.596400E-03,& + & 1.552300E-02,4.805300E-02,1.861100E-01,1.571000E+00,7.803300E+00,& + & 1.580800E+01,3.662100E+01,9.959600E+01,6.268600E+02,4.075600E+03,& + & 1.102500E+04,8.267000E-06,3.026300E-05,1.374300E-04,8.097200E-04,& + & 3.961700E-03,1.254700E-02,3.811800E-02,1.475100E-01,1.244200E+00,& + & 6.137800E+00,1.234200E+01,2.812300E+01,7.538000E+01,4.701400E+02,& + & 3.056600E+03,8.268100E+03,8.987400E-06,3.118000E-05,1.273100E-04,& + & 6.532800E-04,2.884900E-03,8.830300E-03,2.649600E-02,1.022400E-01,& + & 8.584000E-01,4.262200E+00,8.659600E+00,1.964600E+01,5.227400E+01,& + & 3.152000E+02,2.037800E+03,5.512200E+03,8.193300E-06,2.736300E-05,& + & 9.924100E-05,4.306500E-04,1.642900E-03,4.827600E-03,1.422100E-02,& + & 5.473400E-02,4.534100E-01,2.251500E+00,4.619300E+00,1.061700E+01,& + & 2.870700E+01,1.643200E+02,1.019000E+03,2.756000E+03,3.969000E-06,& + & 9.690900E-06,1.865100E-05,3.690600E-05,7.040100E-05,1.472400E-04,& + & 3.596400E-04,1.299700E-03,9.408900E-03,4.218300E-02,7.861600E-02,& + & 1.607200E-01,3.767700E-01,1.897300E+00,3.447100E+01,2.398400E+02/ + data absb(:,461:480) / & + & 4.151800E-06,2.578400E-05,1.662600E-04,1.197400E-03,6.401400E-03,& + & 2.106000E-02,6.421200E-02,2.488200E-01,2.074100E+00,1.019600E+01,& + & 2.058700E+01,4.734700E+01,1.265300E+02,7.864000E+02,4.956300E+03,& + & 1.325000E+04,1.124500E-05,4.448500E-05,2.095600E-04,1.200400E-03,& + & 5.449500E-03,1.699200E-02,5.084500E-02,1.970600E-01,1.641800E+00,& + & 8.023500E+00,1.602200E+01,3.634100E+01,9.565600E+01,5.898100E+02,& + & 3.717300E+03,9.938700E+03,1.218000E-05,4.495900E-05,1.885100E-04,& + & 9.486800E-04,3.935000E-03,1.194300E-02,3.530900E-02,1.365000E-01,& + & 1.132600E+00,5.583600E+00,1.125000E+01,2.534100E+01,6.631300E+01,& + & 3.952400E+02,2.478200E+03,6.625800E+03,1.097300E-05,3.843600E-05,& + & 1.430100E-04,6.082700E-04,2.220800E-03,6.502500E-03,1.891900E-02,& + & 7.295400E-02,5.974300E-01,2.953300E+00,6.017100E+00,1.371800E+01,& + & 3.629300E+01,2.059100E+02,1.239200E+03,3.312700E+03,4.707700E-06,& + & 1.170300E-05,2.274800E-05,4.501600E-05,8.524700E-05,1.787500E-04,& + & 4.411700E-04,1.578900E-03,1.190800E-02,5.301100E-02,9.490800E-02,& + & 1.920400E-01,4.586400E-01,2.520300E+00,4.366600E+01,2.960900E+02,& + & 5.727800E-06,3.903500E-05,2.581900E-04,1.761700E-03,8.637500E-03,& + & 2.797600E-02,8.442900E-02,3.263100E-01,2.683800E+00,1.307200E+01,& + & 2.625100E+01,5.988100E+01,1.583900E+02,9.640600E+02,5.891100E+03,& + & 1.553500E+04,1.515400E-05,6.411300E-05,3.101600E-04,1.707400E-03,& + & 7.287800E-03,2.253100E-02,6.677200E-02,2.581900E-01,2.123600E+00,& + & 1.028600E+01,2.037800E+01,4.593600E+01,1.196000E+02,7.230500E+02,& + & 4.418100E+03,1.165200E+04,1.636600E-05,6.359300E-05,2.721100E-04,& + & 1.325500E-03,5.239300E-03,1.579900E-02,4.632200E-02,1.787200E-01,& + & 1.465000E+00,7.177800E+00,1.431800E+01,3.197700E+01,8.283500E+01,& + & 4.842300E+02,2.945500E+03,7.767800E+03,1.454900E-05,5.293000E-05,& + & 2.008100E-04,8.317200E-04,2.938500E-03,8.566700E-03,2.478700E-02,& + & 9.528600E-02,7.724600E-01,3.800500E+00,7.681800E+00,1.735000E+01,& + & 4.515200E+01,2.521700E+02,1.472700E+03,3.884100E+03,5.539800E-06,& + & 1.408300E-05,2.703900E-05,5.425200E-05,1.014600E-04,2.145000E-04,& + & 5.311600E-04,1.899000E-03,1.484100E-02,6.487500E-02,1.138400E-01,& + & 2.265800E-01,5.516800E-01,3.480000E+00,5.375000E+01,3.569900E+02,& + & 7.890600E-06,5.760000E-05,3.853500E-04,2.482500E-03,1.134700E-02,& + & 3.640500E-02,1.092800E-01,4.208800E-01,3.415800E+00,1.646300E+01,& + & 3.289300E+01,7.437500E+01,1.952500E+02,1.158600E+03,6.863700E+03,& + & 1.781300E+04,2.010900E-05,9.042700E-05,4.453500E-04,2.342300E-03,& + & 9.522900E-03,2.927100E-02,8.633900E-02,3.326400E-01,2.703600E+00,& + & 1.292400E+01,2.548700E+01,5.698700E+01,1.473300E+02,8.689400E+02,& + & 5.147700E+03,1.336100E+04,2.170800E-05,8.819000E-05,3.825400E-04,& + & 1.793300E-03,6.816900E-03,2.049000E-02,5.990100E-02,2.298600E-01,& + & 1.866200E+00,9.029200E+00,1.792800E+01,3.960200E+01,1.019900E+02,& + & 5.817100E+02,3.431900E+03,8.907500E+03,1.905300E-05,7.149100E-05,& + & 2.752200E-04,1.106100E-03,3.799700E-03,1.108800E-02,3.203200E-02,& + & 1.223100E-01,9.836000E-01,4.784900E+00,9.646700E+00,2.156300E+01,& + & 5.541800E+01,3.026000E+02,1.716000E+03,4.453500E+03,6.456600E-06,& + & 1.669600E-05,3.179000E-05,6.413800E-05,1.189100E-04,2.550300E-04,& + & 6.334800E-04,2.252300E-03,1.828000E-02,7.777200E-02,1.324100E-01,& + & 2.620500E-01,6.787800E-01,4.731100E+00,6.498000E+01,4.217200E+02,& + & 2.009700E-06,9.686100E-06,5.590800E-05,4.373800E-04,2.835900E-03,& + & 9.901300E-03,3.131100E-02,1.221000E-01,1.077000E+00,5.466400E+00,& + & 1.109500E+01,2.614700E+01,7.261700E+01,4.796000E+02,3.497200E+03,& + & 9.746800E+03,5.332300E-06,1.812900E-05,7.917800E-05,4.750900E-04,& + & 2.479200E-03,8.034300E-03,2.489600E-02,9.699400E-02,8.553000E-01,& + & 4.329100E+00,8.722400E+00,2.020000E+01,5.519800E+01,3.597000E+02,& + & 2.623000E+03,7.310000E+03,5.802100E-06,1.900900E-05,7.522700E-05,& + & 3.904100E-04,1.819800E-03,5.667400E-03,1.733600E-02,6.732600E-02,& + & 5.899800E-01,2.999900E+00,6.122600E+00,1.419200E+01,3.845400E+01,& + & 2.417600E+02,1.748700E+03,4.872900E+03,5.350200E-06,1.700500E-05,& + & 6.016600E-05,2.636900E-04,1.046200E-03,3.112900E-03,9.324700E-03,& + & 3.612300E-02,3.120500E-01,1.580800E+00,3.251900E+00,7.672000E+00,& + & 2.128500E+01,1.271300E+02,8.743400E+02,2.436600E+03,2.724100E-06,& + & 6.338900E-06,1.230100E-05,2.401900E-05,4.571200E-05,9.636100E-05,& + & 2.360800E-04,8.590400E-04,6.388600E-03,2.992300E-02,5.683900E-02,& + & 1.182900E-01,2.783100E-01,1.404900E+00,2.860700E+01,2.073600E+02/ + data absb(:,481:500) / & + & 2.650800E-06,1.495700E-05,9.302900E-05,6.993700E-04,4.062700E-03,& + & 1.370600E-02,4.257500E-02,1.665200E-01,1.452100E+00,7.287400E+00,& + & 1.475100E+01,3.461800E+01,9.449600E+01,6.178800E+02,4.330600E+03,& + & 1.194200E+04,7.238300E-06,2.692900E-05,1.233600E-04,7.259900E-04,& + & 3.496200E-03,1.110100E-02,3.380100E-02,1.321000E-01,1.152900E+00,& + & 5.771000E+00,1.156000E+01,2.672800E+01,7.172700E+01,4.633900E+02,& + & 3.248000E+03,8.956200E+03,7.877300E-06,2.769200E-05,1.137300E-04,& + & 5.835400E-04,2.541000E-03,7.812500E-03,2.351100E-02,9.167000E-02,& + & 7.946700E-01,4.006800E+00,8.122600E+00,1.876800E+01,4.992700E+01,& + & 3.112500E+02,2.165300E+03,5.970800E+03,7.164800E-06,2.420900E-05,& + & 8.841500E-05,3.824500E-04,1.443100E-03,4.274600E-03,1.261600E-02,& + & 4.910700E-02,4.194200E-01,2.112200E+00,4.332500E+00,1.017300E+01,& + & 2.753900E+01,1.634700E+02,1.082700E+03,2.985500E+03,3.275500E-06,& + & 7.768900E-06,1.523600E-05,2.989200E-05,5.602200E-05,1.190200E-04,& + & 2.945200E-04,1.062300E-03,8.247900E-03,3.826700E-02,7.085500E-02,& + & 1.444800E-01,3.461600E-01,1.861000E+00,3.694300E+01,2.609200E+02,& + & 3.618400E-06,2.298900E-05,1.490000E-04,1.066000E-03,5.607800E-03,& + & 1.854600E-02,5.693500E-02,2.222200E-01,1.914100E+00,9.504100E+00,& + & 1.920500E+01,4.473300E+01,1.209500E+02,7.756600E+02,5.228800E+03,& + & 1.421700E+04,9.834800E-06,3.943400E-05,1.867700E-04,1.063900E-03,& + & 4.771100E-03,1.499500E-02,4.512900E-02,1.762600E-01,1.518700E+00,& + & 7.523100E+00,1.501500E+01,3.448800E+01,9.166200E+01,5.817500E+02,& + & 3.921600E+03,1.066300E+04,1.065600E-05,3.974400E-05,1.674400E-04,& + & 8.377600E-04,3.444200E-03,1.053600E-02,3.135900E-02,1.222000E-01,& + & 1.047300E+00,5.237400E+00,1.055400E+01,2.418100E+01,6.373900E+01,& + & 3.904700E+02,2.614400E+03,7.108600E+03,9.573700E-06,3.383700E-05,& + & 1.265200E-04,5.349700E-04,1.941800E-03,5.732800E-03,1.680900E-02,& + & 6.535700E-02,5.522900E-01,2.766100E+00,5.642400E+00,1.314000E+01,& + & 3.503200E+01,2.047900E+02,1.307200E+03,3.554200E+03,3.877400E-06,& + & 9.373800E-06,1.854400E-05,3.643700E-05,6.726700E-05,1.437300E-04,& + & 3.609300E-04,1.293100E-03,1.046800E-02,4.733100E-02,8.572100E-02,& + & 1.729000E-01,4.122600E-01,2.573600E+00,4.634200E+01,3.197800E+02,& + & 4.995100E-06,3.460600E-05,2.293800E-04,1.549000E-03,7.504700E-03,& + & 2.455000E-02,7.484200E-02,2.916000E-01,2.477300E+00,1.217600E+01,& + & 2.450400E+01,5.664400E+01,1.522000E+02,9.523100E+02,6.175600E+03,& + & 1.652600E+04,1.320500E-05,5.654500E-05,2.744300E-04,1.496500E-03,& + & 6.340600E-03,1.981100E-02,5.925600E-02,2.309600E-01,1.966500E+00,& + & 9.615600E+00,1.911900E+01,4.362000E+01,1.152100E+02,7.142000E+02,& + & 4.631400E+03,1.239400E+04,1.427100E-05,5.592600E-05,2.400200E-04,& + & 1.158800E-03,4.558100E-03,1.388600E-02,4.115600E-02,1.599300E-01,& + & 1.356500E+00,6.706600E+00,1.346100E+01,3.054200E+01,8.004200E+01,& + & 4.790400E+02,3.087500E+03,8.262500E+03,1.265600E-05,4.635600E-05,& + & 1.764800E-04,7.249700E-04,2.554800E-03,7.531300E-03,2.203900E-02,& + & 8.534200E-02,7.149400E-01,3.544900E+00,7.221400E+00,1.665300E+01,& + & 4.383300E+01,2.508600E+02,1.543900E+03,4.131300E+03,4.519400E-06,& + & 1.125300E-05,2.201200E-05,4.369800E-05,7.954700E-05,1.733200E-04,& + & 4.343500E-04,1.546800E-03,1.307700E-02,5.862500E-02,1.013700E-01,& + & 2.020000E-01,5.153100E-01,3.572400E+00,5.674400E+01,3.830000E+02,& + & 6.865400E-06,5.071200E-05,3.393600E-04,2.160900E-03,9.779200E-03,& + & 3.185300E-02,9.693300E-02,3.761700E-01,3.153600E+00,1.532200E+01,& + & 3.072300E+01,7.066700E+01,1.883700E+02,1.146400E+03,7.154300E+03,& + & 1.881500E+04,1.744500E-05,7.930100E-05,3.911200E-04,2.035200E-03,& + & 8.221300E-03,2.566700E-02,7.674000E-02,2.976800E-01,2.504400E+00,& + & 1.208400E+01,2.391800E+01,5.433100E+01,1.424000E+02,8.597800E+02,& + & 5.365700E+03,1.411100E+04,1.886000E-05,7.705900E-05,3.353200E-04,& + & 1.555300E-03,5.886800E-03,1.796900E-02,5.327400E-02,2.058900E-01,& + & 1.727900E+00,8.448300E+00,1.688700E+01,3.794900E+01,9.883600E+01,& + & 5.762600E+02,3.576900E+03,9.407700E+03,1.651100E-05,6.228500E-05,& + & 2.404000E-04,9.566600E-04,3.284800E-03,9.724600E-03,2.847600E-02,& + & 1.097100E-01,9.101100E-01,4.470900E+00,9.092200E+00,2.075500E+01,& + & 5.399100E+01,3.012800E+02,1.788400E+03,4.703400E+03,5.259700E-06,& + & 1.327600E-05,2.588500E-05,5.153200E-05,9.276300E-05,2.062500E-04,& + & 5.153300E-04,1.839400E-03,1.619600E-02,6.934000E-02,1.210100E-01,& + & 2.302300E-01,6.489500E-01,4.852500E+00,6.838700E+01,4.496800E+02/ + data absb(:,501:520) / & + & 1.730700E-06,8.688100E-06,5.102700E-05,3.988900E-04,2.528400E-03,& + & 8.798000E-03,2.788600E-02,1.098600E-01,1.000400E+00,5.151200E+00,& + & 1.046900E+01,2.486700E+01,6.958600E+01,4.767300E+02,3.732300E+03,& + & 1.058500E+04,4.671900E-06,1.621500E-05,7.159200E-05,4.299900E-04,& + & 2.205700E-03,7.151900E-03,2.220600E-02,8.738200E-02,7.968600E-01,& + & 4.096700E+00,8.265300E+00,1.932500E+01,5.307500E+01,3.575800E+02,& + & 2.799300E+03,7.886800E+03,5.092600E-06,1.696500E-05,6.775200E-05,& + & 3.519700E-04,1.615500E-03,5.045100E-03,1.546500E-02,6.073700E-02,& + & 5.494300E-01,2.836200E+00,5.802700E+00,1.364200E+01,3.711900E+01,& + & 2.408600E+02,1.866200E+03,5.292400E+03,4.686400E-06,1.512200E-05,& + & 5.398400E-05,2.363400E-04,9.258800E-04,2.771200E-03,8.317600E-03,& + & 3.260900E-02,2.903600E-01,1.493300E+00,3.080300E+00,7.388400E+00,& + & 2.062000E+01,1.276400E+02,9.331000E+02,2.646100E+03,2.250400E-06,& + & 5.083900E-06,1.006900E-05,1.931100E-05,3.626700E-05,7.820200E-05,& + & 1.933000E-04,7.017700E-04,5.616900E-03,2.639300E-02,5.138900E-02,& + & 1.047700E-01,2.542100E-01,1.359200E+00,3.088000E+01,2.260300E+02,& + & 2.307900E-06,1.342600E-05,8.430600E-05,6.299100E-04,3.588600E-03,& + & 1.213500E-02,3.795400E-02,1.496100E-01,1.347200E+00,6.859900E+00,& + & 1.390500E+01,3.285700E+01,9.119000E+01,6.146300E+02,4.585500E+03,& + & 1.283500E+04,6.354000E-06,2.403700E-05,1.108200E-04,6.502100E-04,& + & 3.084400E-03,9.843500E-03,3.016100E-02,1.188700E-01,1.072000E+00,& + & 5.455200E+00,1.096300E+01,2.548600E+01,6.943200E+01,4.609900E+02,& + & 3.439100E+03,9.628000E+03,6.915200E-06,2.462800E-05,1.017800E-04,& + & 5.205900E-04,2.238200E-03,6.932500E-03,2.098100E-02,8.254200E-02,& + & 7.388700E-01,3.790200E+00,7.703800E+00,1.799300E+01,4.846700E+01,& + & 3.102400E+02,2.292700E+03,6.418200E+03,6.276400E-06,2.143400E-05,& + & 7.878600E-05,3.393200E-04,1.269500E-03,3.790200E-03,1.126000E-02,& + & 4.426000E-02,3.900200E-01,1.999300E+00,4.099800E+00,9.774800E+00,& + & 2.683400E+01,1.640400E+02,1.146300E+03,3.209100E+03,2.692600E-06,& + & 6.231800E-06,1.242400E-05,2.411700E-05,4.400300E-05,9.625000E-05,& + & 2.404800E-04,8.648900E-04,7.246400E-03,3.404000E-02,6.340800E-02,& + & 1.280700E-01,3.096400E-01,1.884400E+00,3.945800E+01,2.821500E+02,& + & 3.166500E-06,2.055000E-05,1.337800E-04,9.475500E-04,4.909700E-03,& + & 1.636700E-02,5.072900E-02,1.997400E-01,1.776700E+00,8.939500E+00,& + & 1.808000E+01,4.248200E+01,1.172500E+02,7.725300E+02,5.498800E+03,& + & 1.514700E+04,8.614700E-06,3.502700E-05,1.666600E-04,9.412900E-04,& + & 4.180500E-03,1.325100E-02,4.026900E-02,1.586100E-01,1.414500E+00,& + & 7.103800E+00,1.420900E+01,3.289900E+01,8.911700E+01,5.793700E+02,& + & 4.123900E+03,1.135900E+04,9.334300E-06,3.516000E-05,1.488600E-04,& + & 7.390400E-04,3.015700E-03,9.307500E-03,2.799600E-02,1.099500E-01,& + & 9.749300E-01,4.948900E+00,9.996900E+00,2.320800E+01,6.213400E+01,& + & 3.894800E+02,2.749400E+03,7.572300E+03,8.361400E-06,2.982000E-05,& + & 1.119800E-04,4.699100E-04,1.699300E-03,5.063700E-03,1.500800E-02,& + & 5.883600E-02,5.140000E-01,2.610400E+00,5.342100E+00,1.265800E+01,& + & 3.431800E+01,2.054400E+02,1.374700E+03,3.786300E+03,3.181400E-06,& + & 7.512300E-06,1.501700E-05,2.935400E-05,5.282500E-05,1.172300E-04,& + & 2.928300E-04,1.053300E-03,9.168200E-03,4.282000E-02,7.712800E-02,& + & 1.512200E-01,3.832000E-01,2.667200E+00,4.906600E+01,3.398300E+02,& + & 4.373100E-06,3.076200E-05,2.040700E-04,1.361700E-03,6.516500E-03,& + & 2.159400E-02,6.668000E-02,2.621900E-01,2.300600E+00,1.144900E+01,& + & 2.305500E+01,5.402800E+01,1.481000E+02,9.492200E+02,6.455600E+03,& + & 1.746100E+04,1.152800E-05,4.997100E-05,2.431000E-04,1.311300E-03,& + & 5.516700E-03,1.745100E-02,5.291000E-02,2.079300E-01,1.832100E+00,& + & 9.081600E+00,1.808500E+01,4.174900E+01,1.123600E+02,7.118900E+02,& + & 4.841500E+03,1.309600E+04,1.246400E-05,4.923600E-05,2.120400E-04,& + & 1.012900E-03,3.964500E-03,1.223800E-02,3.676800E-02,1.439600E-01,& + & 1.263400E+00,6.336700E+00,1.276500E+01,2.937800E+01,7.825700E+01,& + & 4.781500E+02,3.227900E+03,8.731300E+03,1.102300E-05,4.064000E-05,& + & 1.551900E-04,6.318000E-04,2.221500E-03,6.639000E-03,1.968500E-02,& + & 7.688400E-02,6.656800E-01,3.342100E+00,6.850400E+00,1.608700E+01,& + & 4.310800E+01,2.515800E+02,1.613900E+03,4.365400E+03,3.716400E-06,& + & 8.928600E-06,1.783300E-05,3.502900E-05,6.188900E-05,1.412900E-04,& + & 3.517400E-04,1.262400E-03,1.149300E-02,5.191900E-02,9.214100E-02,& + & 1.765600E-01,4.858800E-01,3.705400E+00,5.983400E+01,4.084700E+02/ + data absb(:,521:540) / & + & 5.987800E-06,4.471900E-05,2.993200E-04,1.880500E-03,8.420900E-03,& + & 2.792200E-02,8.632500E-02,3.385500E-01,2.930600E+00,1.442300E+01,& + & 2.890100E+01,6.769900E+01,1.840400E+02,1.144600E+03,7.436400E+03,& + & 1.963100E+04,1.515100E-05,6.959200E-05,3.439900E-04,1.768800E-03,& + & 7.089900E-03,2.255300E-02,6.849100E-02,2.685200E-01,2.333900E+00,& + & 1.142600E+01,2.262900E+01,5.222000E+01,1.394000E+02,8.584200E+02,& + & 5.577500E+03,1.481500E+04,1.640000E-05,6.743200E-05,2.942500E-04,& + & 1.348500E-03,5.077500E-03,1.579800E-02,4.757900E-02,1.857400E-01,& + & 1.610200E+00,7.985000E+00,1.603100E+01,3.668200E+01,9.692800E+01,& + & 5.760300E+02,3.718300E+03,9.877000E+03,1.431600E-05,5.432200E-05,& + & 2.100200E-04,8.276000E-04,2.835400E-03,8.548000E-03,2.544800E-02,& + & 9.906000E-02,8.482700E-01,4.217900E+00,8.640000E+00,2.015700E+01,& + & 5.324600E+01,3.023900E+02,1.859100E+03,4.938900E+03,4.297400E-06,& + & 1.056900E-05,2.075100E-05,4.130900E-05,7.261000E-05,1.659800E-04,& + & 4.178100E-04,1.497600E-03,1.414700E-02,6.240200E-02,1.094900E-01,& + & 2.002900E-01,6.202100E-01,5.035300E+00,7.193600E+01,4.720100E+02,& + & 1.498100E-06,7.779100E-06,4.642300E-05,3.621400E-04,2.252000E-03,& + & 7.829700E-03,2.497100E-02,9.935500E-02,9.325600E-01,4.864600E+00,& + & 9.952400E+00,2.369800E+01,6.770300E+01,4.782900E+02,3.974300E+03,& + & 1.143200E+04,4.083400E-06,1.444200E-05,6.438500E-05,3.871600E-04,& + & 1.960200E-03,6.372700E-03,1.990100E-02,7.909100E-02,7.441600E-01,& + & 3.888000E+00,7.898800E+00,1.850500E+01,5.178500E+01,3.588200E+02,& + & 2.980800E+03,8.573700E+03,4.453100E-06,1.504600E-05,6.065100E-05,& + & 3.154900E-04,1.432800E-03,4.495200E-03,1.386000E-02,5.500100E-02,& + & 5.126400E-01,2.693200E+00,5.543700E+00,1.312100E+01,3.633400E+01,& + & 2.421400E+02,1.987200E+03,5.715800E+03,4.084300E-06,1.336000E-05,& + & 4.808400E-05,2.105900E-04,8.186800E-04,2.467100E-03,7.450800E-03,& + & 2.953400E-02,2.707900E-01,1.419400E+00,2.938200E+00,7.118700E+00,& + & 2.021400E+01,1.291700E+02,9.935900E+02,2.857900E+03,1.853900E-06,& + & 4.160000E-06,8.231300E-06,1.569200E-05,2.941700E-05,6.387900E-05,& + & 1.594300E-04,5.815500E-04,4.946500E-03,2.378100E-02,4.732100E-02,& + & 9.588800E-02,2.282600E-01,1.336000E+00,3.285000E+01,2.429300E+02,& + & 2.015000E-06,1.201900E-05,7.607500E-05,5.647400E-04,3.168100E-03,& + & 1.077000E-02,3.399300E-02,1.353000E-01,1.256100E+00,6.467200E+00,& + & 1.322400E+01,3.135900E+01,8.916500E+01,6.176500E+02,4.851700E+03,& + & 1.365600E+04,5.556900E-06,2.134600E-05,9.912400E-05,5.796300E-04,& + & 2.721500E-03,8.751000E-03,2.704400E-02,1.076400E-01,1.002000E+00,& + & 5.178200E+00,1.046100E+01,2.442700E+01,6.804600E+01,4.633100E+02,& + & 3.638400E+03,1.030800E+04,6.041900E-06,2.177100E-05,9.058600E-05,& + & 4.620400E-04,1.971700E-03,6.161600E-03,1.881700E-02,7.477100E-02,& + & 6.903400E-01,3.601800E+00,7.346300E+00,1.733500E+01,4.764300E+01,& + & 3.122600E+02,2.425700E+03,6.871500E+03,5.471600E-06,1.885700E-05,& + & 6.978000E-05,2.996600E-04,1.116600E-03,3.364400E-03,1.010200E-02,& + & 4.007600E-02,3.643400E-01,1.896200E+00,3.908700E+00,9.440200E+00,& + & 2.648500E+01,1.659400E+02,1.212900E+03,3.436000E+03,2.228500E-06,& + & 5.035300E-06,1.016800E-05,1.945000E-05,3.549000E-05,7.913700E-05,& + & 1.973700E-04,7.150300E-04,6.396000E-03,3.049200E-02,5.841800E-02,& + & 1.154000E-01,2.797800E-01,1.920300E+00,4.161500E+01,3.011400E+02,& + & 2.772500E-06,1.832400E-05,1.198100E-04,8.403400E-04,4.297700E-03,& + & 1.448400E-02,4.543100E-02,1.808700E-01,1.658700E+00,8.453500E+00,& + & 1.716600E+01,4.070100E+01,1.151100E+02,7.774300E+02,5.784800E+03,& + & 1.609600E+04,7.515100E-06,3.097200E-05,1.481100E-04,8.306700E-04,& + & 3.661500E-03,1.174100E-02,3.611600E-02,1.437300E-01,1.323900E+00,& + & 6.749700E+00,1.356000E+01,3.162400E+01,8.769200E+01,5.831000E+02,& + & 4.338600E+03,1.207300E+04,8.138700E-06,3.094900E-05,1.317600E-04,& + & 6.497100E-04,2.640300E-03,8.248200E-03,2.511800E-02,9.966600E-02,& + & 9.120600E-01,4.705400E+00,9.553700E+00,2.241300E+01,6.129000E+01,& + & 3.925600E+02,2.892300E+03,8.047300E+03,7.269000E-06,2.611700E-05,& + & 9.859700E-05,4.114400E-04,1.486900E-03,4.484400E-03,1.346800E-02,& + & 5.333900E-02,4.809200E-01,2.477000E+00,5.103400E+00,1.226600E+01,& + & 3.400700E+01,2.079200E+02,1.446200E+03,4.024000E+03,2.633400E-06,& + & 6.044700E-06,1.220500E-05,2.369300E-05,4.185400E-05,9.660000E-05,& + & 2.409700E-04,8.682700E-04,8.157600E-03,3.833900E-02,7.018100E-02,& + & 1.337100E-01,3.572300E-01,2.734900E+00,5.151400E+01,3.642300E+02/ + data absb(:,541:560) / & + & 3.825600E-06,2.726100E-05,1.812300E-04,1.195700E-03,5.659700E-03,& + & 1.905000E-02,5.975100E-02,2.375000E-01,2.150100E+00,1.085600E+01,& + & 2.188700E+01,5.204100E+01,1.459800E+02,9.568600E+02,6.756600E+03,& + & 1.843500E+04,1.001900E-05,4.393200E-05,2.147200E-04,1.147500E-03,& + & 4.796700E-03,1.542700E-02,4.748500E-02,1.886700E-01,1.716700E+00,& + & 8.648400E+00,1.726400E+01,4.033800E+01,1.109600E+02,7.176200E+02,& + & 5.067300E+03,1.374400E+04,1.083600E-05,4.315700E-05,1.866200E-04,& + & 8.838900E-04,3.446200E-03,1.082000E-02,3.300700E-02,1.306300E-01,& + & 1.183700E+00,6.035000E+00,1.221100E+01,2.853000E+01,7.742200E+01,& + & 4.825600E+02,3.378300E+03,9.218100E+03,9.554900E-06,3.544200E-05,& + & 1.359000E-04,5.496200E-04,1.929800E-03,5.867800E-03,1.767300E-02,& + & 6.982200E-02,6.235100E-01,3.179300E+00,6.552600E+00,1.567600E+01,& + & 4.287700E+01,2.547500E+02,1.689100E+03,4.608800E+03,3.070900E-06,& + & 7.190500E-06,1.449200E-05,2.825300E-05,4.934800E-05,1.149500E-04,& + & 2.898300E-04,1.040900E-03,1.019400E-02,4.657000E-02,8.470600E-02,& + & 1.549000E-01,4.637700E-01,3.803100E+00,6.263200E+01,4.311100E+02,& + & 5.221700E-06,3.938500E-05,2.637600E-04,1.638000E-03,7.268100E-03,& + & 2.452400E-02,7.741600E-02,3.076200E-01,2.741300E+00,1.372300E+01,& + & 2.748700E+01,6.549100E+01,1.823800E+02,1.155000E+03,7.746700E+03,& + & 2.074300E+04,1.311600E-05,6.088800E-05,3.019000E-04,1.537300E-03,& + & 6.125300E-03,1.986700E-02,6.153000E-02,2.443200E-01,2.190500E+00,& + & 1.090900E+01,2.162200E+01,5.066300E+01,1.383600E+02,8.662900E+02,& + & 5.809900E+03,1.545800E+04,1.420700E-05,5.879500E-05,2.575300E-04,& + & 1.169500E-03,4.387300E-03,1.391900E-02,4.275100E-02,1.689700E-01,& + & 1.511500E+00,7.624600E+00,1.535000E+01,3.576800E+01,9.632700E+01,& + & 5.818900E+02,3.873400E+03,1.037100E+04,1.236800E-05,4.717900E-05,& + & 1.830100E-04,7.157600E-04,2.451400E-03,7.529200E-03,2.286300E-02,& + & 9.014000E-02,7.963500E-01,4.021400E+00,8.269800E+00,1.975500E+01,& + & 5.316800E+01,3.063100E+02,1.936700E+03,5.185700E+03,3.549200E-06,& + & 8.513300E-06,1.694600E-05,3.295700E-05,5.818600E-05,1.345300E-04,& + & 3.432800E-04,1.235700E-03,1.254200E-02,5.622600E-02,9.858800E-02,& + & 1.815700E-01,5.769000E-01,5.202100E+00,7.512900E+01,5.008600E+02,& + & 1.268300E-06,6.694900E-06,4.021500E-05,3.135900E-04,1.936600E-03,& + & 6.763000E-03,2.179600E-02,8.751900E-02,8.484000E-01,4.490200E+00,& + & 9.289600E+00,2.210800E+01,6.486100E+01,4.722600E+02,4.139200E+03,& + & 1.205200E+04,3.471700E-06,1.239000E-05,5.551600E-05,3.344600E-04,& + & 1.685400E-03,5.512600E-03,1.738700E-02,6.976900E-02,6.784600E-01,& + & 3.607900E+00,7.398800E+00,1.735900E+01,4.974600E+01,3.544300E+02,& + & 3.104400E+03,9.039100E+03,3.784300E-06,1.287300E-05,5.217800E-05,& + & 2.719300E-04,1.230400E-03,3.888400E-03,1.211100E-02,4.855200E-02,& + & 4.672500E-01,2.502700E+00,5.183600E+00,1.235400E+01,3.502600E+01,& + & 2.395700E+02,2.069700E+03,6.026100E+03,3.463900E-06,1.141000E-05,& + & 4.126500E-05,1.809100E-04,7.019900E-04,2.134000E-03,6.508400E-03,& + & 2.608500E-02,2.467800E-01,1.315600E+00,2.747800E+00,6.708500E+00,& + & 1.955100E+01,1.285100E+02,1.034800E+03,3.013000E+03,1.503300E-06,& + & 3.283700E-06,6.630000E-06,1.243700E-05,2.300800E-05,5.172100E-05,& + & 1.283500E-04,4.686800E-04,4.258100E-03,2.123800E-02,4.141700E-02,& + & 8.392500E-02,2.015600E-01,1.308600E+00,3.400500E+01,2.542500E+02,& + & 1.713000E-06,1.034200E-05,6.564600E-05,4.858300E-04,2.710200E-03,& + & 9.298500E-03,2.969800E-02,1.195300E-01,1.146600E+00,5.991800E+00,& + & 1.234600E+01,2.939000E+01,8.597600E+01,6.121400E+02,5.033800E+03,& + & 1.441000E+04,4.724200E-06,1.828900E-05,8.520700E-05,4.975200E-04,& + & 2.329600E-03,7.566200E-03,2.366600E-02,9.520400E-02,9.171300E-01,& + & 4.815400E+00,9.812000E+00,2.299900E+01,6.578500E+01,4.592300E+02,& + & 3.775600E+03,1.080800E+04,5.132100E-06,1.859900E-05,7.769100E-05,& + & 3.956600E-04,1.687200E-03,5.325200E-03,1.647900E-02,6.612900E-02,& + & 6.317900E-01,3.349700E+00,6.889500E+00,1.638800E+01,4.617500E+01,& + & 3.099800E+02,2.516900E+03,7.204600E+03,4.638600E-06,1.606800E-05,& + & 5.969400E-05,2.559300E-04,9.549000E-04,2.907000E-03,8.843300E-03,& + & 3.547000E-02,3.331900E-01,1.763900E+00,3.662100E+00,8.946400E+00,& + & 2.578200E+01,1.654600E+02,1.258500E+03,3.602600E+03,1.804500E-06,& + & 4.007200E-06,8.135100E-06,1.530500E-05,2.766400E-05,6.403200E-05,& + & 1.586300E-04,5.774000E-04,5.531700E-03,2.715300E-02,5.161400E-02,& + & 9.996200E-02,2.540100E-01,1.915400E+00,4.288900E+01,3.139200E+02/ + data absb(:,561:580) / & + & 2.359800E-06,1.572900E-05,1.029800E-04,7.187500E-04,3.657400E-03,& + & 1.248900E-02,3.976000E-02,1.603500E-01,1.518500E+00,7.869300E+00,& + & 1.603800E+01,3.843500E+01,1.116500E+02,7.728000E+02,5.982400E+03,& + & 1.679600E+04,6.379400E-06,2.644700E-05,1.269400E-04,7.090900E-04,& + & 3.120600E-03,1.014100E-02,3.167500E-02,1.275600E-01,1.215100E+00,& + & 6.309800E+00,1.273700E+01,2.996600E+01,8.524500E+01,5.797600E+02,& + & 4.486700E+03,1.259800E+04,6.904300E-06,2.638200E-05,1.126600E-04,& + & 5.535800E-04,2.249900E-03,7.124600E-03,2.203500E-02,8.846300E-02,& + & 8.372700E-01,4.396400E+00,8.985600E+00,2.132400E+01,5.971600E+01,& + & 3.907700E+02,2.991000E+03,8.398700E+03,6.155200E-06,2.219800E-05,& + & 8.405900E-05,3.499300E-04,1.266200E-03,3.874900E-03,1.181200E-02,& + & 4.736100E-02,4.413300E-01,2.312400E+00,4.799200E+00,1.169400E+01,& + & 3.327300E+01,2.077300E+02,1.495500E+03,4.199400E+03,2.131200E-06,& + & 4.811100E-06,9.810300E-06,1.863500E-05,3.308900E-05,7.697400E-05,& + & 1.939600E-04,7.011800E-04,7.062500E-03,3.357300E-02,6.217300E-02,& + & 1.180600E-01,3.284600E-01,2.735700E+00,5.298300E+01,3.783200E+02,& + & 3.253300E-06,2.332600E-05,1.550300E-04,1.017100E-03,4.796300E-03,& + & 1.640000E-02,5.240200E-02,2.112300E-01,1.973700E+00,1.015600E+01,& + & 2.050100E+01,4.941800E+01,1.425000E+02,9.539700E+02,6.965200E+03,& + & 1.916000E+04,8.486100E-06,3.742400E-05,1.833400E-04,9.751300E-04,& + & 4.069400E-03,1.331200E-02,4.173500E-02,1.680100E-01,1.581000E+00,& + & 8.119300E+00,1.624600E+01,3.843900E+01,1.085300E+02,7.155400E+02,& + & 5.223900E+03,1.437000E+04,9.177300E-06,3.669400E-05,1.590500E-04,& + & 7.502300E-04,2.922800E-03,9.338900E-03,2.902900E-02,1.163900E-01,& + & 1.089900E+00,5.665800E+00,1.150700E+01,2.732300E+01,7.583800E+01,& + & 4.816500E+02,3.482600E+03,9.579900E+03,8.077100E-06,3.005200E-05,& + & 1.155100E-04,4.656900E-04,1.637100E-03,5.065900E-03,1.553800E-02,& + & 6.223500E-02,5.742100E-01,2.981200E+00,6.171500E+00,1.506300E+01,& + & 4.216200E+01,2.550800E+02,1.741400E+03,4.790400E+03,2.479700E-06,& + & 5.750300E-06,1.163000E-05,2.220500E-05,3.937200E-05,9.114800E-05,& + & 2.329200E-04,8.422000E-04,8.857100E-03,4.129800E-02,7.434600E-02,& + & 1.363000E-01,4.267500E-01,3.828600E+00,6.432700E+01,4.463400E+02,& + & 4.431700E-06,3.358200E-05,2.247600E-04,1.387200E-03,6.135200E-03,& + & 2.104900E-02,6.805300E-02,2.748400E-01,2.526200E+00,1.286700E+01,& + & 2.586500E+01,6.254600E+01,1.791000E+02,1.154000E+03,7.964200E+03,& + & 2.148300E+04,1.108400E-05,5.173500E-05,2.569700E-04,1.301500E-03,& + & 5.179500E-03,1.709800E-02,5.417300E-02,2.186100E-01,2.025100E+00,& + & 1.027700E+01,2.042900E+01,4.853500E+01,1.360800E+02,8.655200E+02,& + & 5.973300E+03,1.611400E+04,1.200900E-05,4.985200E-05,2.188600E-04,& + & 9.891200E-04,3.711100E-03,1.198500E-02,3.766400E-02,1.512100E-01,& + & 1.397500E+00,7.186000E+00,1.451500E+01,3.444700E+01,9.489100E+01,& + & 5.818700E+02,3.982200E+03,1.074200E+04,1.043600E-05,3.992100E-05,& + & 1.551400E-04,6.044900E-04,2.074000E-03,6.485700E-03,2.014100E-02,& + & 8.071700E-02,7.362500E-01,3.787200E+00,7.813900E+00,1.909200E+01,& + & 5.258100E+01,3.070800E+02,1.991100E+03,5.371100E+03,2.846000E-06,& + & 6.831700E-06,1.359100E-05,2.604500E-05,4.627600E-05,1.068300E-04,& + & 2.759800E-04,1.003300E-03,1.089700E-02,4.961900E-02,8.698900E-02,& + & 1.658500E-01,5.225600E-01,5.263600E+00,7.708700E+01,5.170800E+02,& + & 1.044600E-06,5.511600E-06,3.299400E-05,2.580800E-04,1.603400E-03,& + & 5.649600E-03,1.843900E-02,7.484900E-02,7.516500E-01,4.031700E+00,& + & 8.464100E+00,2.012900E+01,6.076400E+01,4.569300E+02,4.214600E+03,& + & 1.241100E+04,2.859600E-06,1.019500E-05,4.566000E-05,2.759900E-04,& + & 1.397600E-03,4.611900E-03,1.473600E-02,5.973700E-02,6.022600E-01,& + & 3.257500E+00,6.768000E+00,1.589100E+01,4.673200E+01,3.430100E+02,& + & 3.160800E+03,9.307800E+03,3.114200E-06,1.058500E-05,4.293000E-05,& + & 2.244000E-04,1.020200E-03,3.253000E-03,1.026900E-02,4.159300E-02,& + & 4.146500E-01,2.259100E+00,4.738400E+00,1.134600E+01,3.305200E+01,& + & 2.322000E+02,2.107200E+03,6.205000E+03,2.848800E-06,9.381400E-06,& + & 3.396900E-05,1.493700E-04,5.818600E-04,1.785200E-03,5.518100E-03,& + & 2.235300E-02,2.189200E-01,1.186400E+00,2.508900E+00,6.164300E+00,& + & 1.851400E+01,1.252000E+02,1.053600E+03,3.102600E+03,1.184100E-06,& + & 2.555600E-06,5.154200E-06,9.663100E-06,1.766300E-05,4.031200E-05,& + & 1.005900E-04,3.666000E-04,3.551200E-03,1.832200E-02,3.537000E-02,& + & 7.216600E-02,1.722700E-01,1.253300E+00,3.422500E+01,2.588700E+02/ + data absb(:,581:600) / & + & 1.411500E-06,8.513700E-06,5.391600E-05,3.996400E-04,2.242100E-03,& + & 7.776700E-03,2.522800E-02,1.027800E-01,1.021000E+00,5.423000E+00,& + & 1.128300E+01,2.696700E+01,8.134700E+01,5.957400E+02,5.120000E+03,& + & 1.480800E+04,3.891100E-06,1.503700E-05,7.010400E-05,4.100300E-04,& + & 1.930700E-03,6.337200E-03,2.013500E-02,8.197200E-02,8.186600E-01,& + & 4.376400E+00,9.007700E+00,2.119800E+01,6.241600E+01,4.471000E+02,& + & 3.840100E+03,1.110600E+04,4.223600E-06,1.529600E-05,6.394600E-05,& + & 3.260200E-04,1.398300E-03,4.463000E-03,1.402400E-02,5.695500E-02,& + & 5.637100E-01,3.044400E+00,6.327200E+00,1.515400E+01,4.393300E+01,& + & 3.022100E+02,2.559900E+03,7.404300E+03,3.814800E-06,1.320900E-05,& + & 4.913200E-05,2.109700E-04,7.911800E-04,2.438000E-03,7.525700E-03,& + & 3.054400E-02,2.972900E-01,1.600800E+00,3.358600E+00,8.285800E+00,& + & 2.461900E+01,1.619900E+02,1.280000E+03,3.702100E+03,1.418800E-06,& + & 3.132500E-06,6.349800E-06,1.183400E-05,2.154700E-05,4.992900E-05,& + & 1.242100E-04,4.533600E-04,4.649600E-03,2.343700E-02,4.342700E-02,& + & 8.591700E-02,2.317000E-01,1.841100E+00,4.313900E+01,3.192700E+02,& + & 1.944700E-06,1.294800E-05,8.455200E-05,5.909200E-04,3.020600E-03,& + & 1.046100E-02,3.389100E-02,1.384300E-01,1.358400E+00,7.180700E+00,& + & 1.470900E+01,3.556800E+01,1.065300E+02,7.560900E+02,6.079100E+03,& + & 1.722800E+04,5.252900E-06,2.175300E-05,1.044300E-04,5.838300E-04,& + & 2.582400E-03,8.514400E-03,2.705800E-02,1.102900E-01,1.090200E+00,& + & 5.777000E+00,1.174000E+01,2.784700E+01,8.151400E+01,5.672300E+02,& + & 4.559400E+03,1.292100E+04,5.682200E-06,2.169400E-05,9.271700E-05,& + & 4.559000E-04,1.862300E-03,5.983600E-03,1.883200E-02,7.651900E-02,& + & 7.510900E-01,4.023600E+00,8.285200E+00,1.990100E+01,5.720300E+01,& + & 3.828200E+02,3.039600E+03,8.613000E+03,5.061200E-06,1.825000E-05,& + & 6.917000E-05,2.882400E-04,1.048400E-03,3.254900E-03,1.009700E-02,& + & 4.100000E-02,3.958300E-01,2.114700E+00,4.419200E+00,1.093400E+01,& + & 3.201800E+01,2.042100E+02,1.519800E+03,4.306700E+03,1.676300E-06,& + & 3.768000E-06,7.666500E-06,1.435300E-05,2.588600E-05,6.011800E-05,& + & 1.517900E-04,5.539000E-04,5.958000E-03,2.893400E-02,5.369900E-02,& + & 1.019300E-01,2.985900E-01,2.650400E+00,5.329100E+01,3.844200E+02,& + & 2.680600E-06,1.919800E-05,1.273100E-04,8.359500E-04,3.957000E-03,& + & 1.374000E-02,4.485500E-02,1.838500E-01,1.775200E+00,9.321400E+00,& + & 1.889200E+01,4.609200E+01,1.371100E+02,9.375100E+02,7.071800E+03,& + & 1.961800E+04,6.985400E-06,3.078700E-05,1.508600E-04,8.027700E-04,& + & 3.363000E-03,1.118200E-02,3.578300E-02,1.464900E-01,1.426100E+00,& + & 7.486000E+00,1.503500E+01,3.597500E+01,1.046100E+02,7.032800E+02,& + & 5.303700E+03,1.471400E+04,7.550600E-06,3.017100E-05,1.308800E-04,& + & 6.176300E-04,2.416100E-03,7.849200E-03,2.489900E-02,1.014900E-01,& + & 9.830500E-01,5.224700E+00,1.065200E+01,2.569700E+01,7.319600E+01,& + & 4.738600E+02,3.535700E+03,9.809200E+03,6.640200E-06,2.470600E-05,& + & 9.499900E-05,3.833400E-04,1.354100E-03,4.259800E-03,1.333100E-02,& + & 5.425700E-02,5.181700E-01,2.745300E+00,5.708200E+00,1.420000E+01,& + & 4.083800E+01,2.516500E+02,1.767900E+03,4.904700E+03,1.949200E-06,& + & 4.519300E-06,9.088300E-06,1.718900E-05,3.087200E-05,7.106400E-05,& + & 1.825400E-04,6.668200E-04,7.494700E-03,3.547600E-02,6.428700E-02,& + & 1.216700E-01,3.826500E-01,3.740700E+00,6.471300E+01,4.529700E+02,& + & 3.650300E-06,2.762400E-05,1.845500E-04,1.139600E-03,5.058200E-03,& + & 1.761200E-02,5.841100E-02,2.405900E-01,2.284200E+00,1.187100E+01,& + & 2.397600E+01,5.878500E+01,1.734900E+02,1.138100E+03,8.080300E+03,& + & 2.196500E+04,9.121000E-06,4.255000E-05,2.113100E-04,1.070700E-03,& + & 4.278500E-03,1.435000E-02,4.661100E-02,1.916000E-01,1.837000E+00,& + & 9.515200E+00,1.902800E+01,4.575000E+01,1.320200E+02,8.535300E+02,& + & 6.060100E+03,1.647400E+04,9.880000E-06,4.097500E-05,1.800000E-04,& + & 8.137500E-04,3.066800E-03,1.006400E-02,3.241900E-02,1.325600E-01,& + & 1.267900E+00,6.653800E+00,1.352600E+01,3.263400E+01,9.217900E+01,& + & 5.743000E+02,4.040100E+03,1.098200E+04,8.578400E-06,3.281100E-05,& + & 1.275600E-04,4.974300E-04,1.715000E-03,5.448500E-03,1.733500E-02,& + & 7.080800E-02,6.680600E-01,3.505700E+00,7.270600E+00,1.814100E+01,& + & 5.127100E+01,3.037800E+02,2.020100E+03,5.491500E+03,2.247800E-06,& + & 5.346300E-06,1.060600E-05,2.032600E-05,3.630100E-05,8.357700E-05,& + & 2.165400E-04,7.959300E-04,9.261600E-03,4.247600E-02,7.587000E-02,& + & 1.495800E-01,4.715400E-01,5.170400E+00,7.753500E+01,5.190900E+02/ + data absb(:,601:620) / & + & 8.314100E-07,4.294300E-06,2.542900E-05,2.012100E-04,1.274800E-03,& + & 4.542300E-03,1.502500E-02,6.177800E-02,6.407100E-01,3.494500E+00,& + & 7.450600E+00,1.773700E+01,5.504000E+01,4.292200E+02,4.183000E+03,& + & 1.246400E+04,2.260600E-06,7.962500E-06,3.550200E-05,2.164700E-04,& + & 1.114600E-03,3.713400E-03,1.202500E-02,4.935000E-02,5.145700E-01,& + & 2.832200E+00,5.989700E+00,1.407400E+01,4.245600E+01,3.223200E+02,& + & 3.137200E+03,9.348700E+03,2.458900E-06,8.282500E-06,3.350700E-05,& + & 1.764700E-04,8.140700E-04,2.621600E-03,8.380800E-03,3.437700E-02,& + & 3.542300E-01,1.964200E+00,4.190500E+00,1.006900E+01,3.016600E+01,& + & 2.184700E+02,2.091500E+03,6.231800E+03,2.252100E-06,7.355500E-06,& + & 2.661200E-05,1.178500E-04,4.645000E-04,1.439200E-03,4.504300E-03,& + & 1.848100E-02,1.869100E-01,1.031600E+00,2.215300E+00,5.465900E+00,& + & 1.696700E+01,1.183400E+02,1.045700E+03,3.115900E+03,9.195300E-07,& + & 1.986200E-06,3.987200E-06,7.431000E-06,1.358100E-05,3.125600E-05,& + & 7.829300E-05,2.883400E-04,2.927300E-03,1.529200E-02,2.996300E-02,& + & 6.304500E-02,1.468600E-01,1.121300E+00,3.317100E+01,2.541600E+02,& + & 1.118600E-06,6.637900E-06,4.178900E-05,3.133000E-04,1.789800E-03,& + & 6.287900E-03,2.067800E-02,8.559500E-02,8.781900E-01,4.747400E+00,& + & 1.002900E+01,2.399100E+01,7.475100E+01,5.652200E+02,5.095500E+03,& + & 1.491000E+04,3.075900E-06,1.177200E-05,5.477400E-05,3.232700E-04,& + & 1.544700E-03,5.132100E-03,1.654000E-02,6.834300E-02,7.056600E-01,& + & 3.847700E+00,8.038900E+00,1.895500E+01,5.752200E+01,4.242200E+02,& + & 3.821800E+03,1.118100E+04,3.337400E-06,1.199800E-05,5.011800E-05,& + & 2.576800E-04,1.119200E-03,3.614900E-03,1.152200E-02,4.751300E-02,& + & 4.857600E-01,2.674900E+00,5.642600E+00,1.358600E+01,4.062700E+01,& + & 2.871300E+02,2.547700E+03,7.455100E+03,3.017000E-06,1.038600E-05,& + & 3.864400E-05,1.671700E-04,6.335400E-04,1.973900E-03,6.184900E-03,& + & 2.547400E-02,2.561200E-01,1.405700E+00,2.989800E+00,7.427500E+00,& + & 2.282800E+01,1.545300E+02,1.273900E+03,3.727200E+03,1.107500E-06,& + & 2.438800E-06,4.924400E-06,9.119900E-06,1.672900E-05,3.873400E-05,& + & 9.725200E-05,3.569300E-04,3.848200E-03,1.982900E-02,3.722000E-02,& + & 7.470200E-02,1.974500E-01,1.676000E+00,4.193800E+01,3.143600E+02,& + & 1.539200E-06,1.012400E-05,6.592000E-05,4.658000E-04,2.418700E-03,& + & 8.490000E-03,2.796400E-02,1.162700E-01,1.178100E+00,6.356300E+00,& + & 1.314400E+01,3.198500E+01,9.912600E+01,7.233200E+02,6.065100E+03,& + & 1.737700E+04,4.159000E-06,1.708700E-05,8.196300E-05,4.626200E-04,& + & 2.071400E-03,6.922700E-03,2.236400E-02,9.274400E-02,9.475500E-01,& + & 5.135100E+00,1.053400E+01,2.516000E+01,7.600100E+01,5.428100E+02,& + & 4.549000E+03,1.303300E+04,4.497200E-06,1.706800E-05,7.297400E-05,& + & 3.618100E-04,1.494700E-03,4.866700E-03,1.557200E-02,6.438700E-02,& + & 6.525500E-01,3.575400E+00,7.430900E+00,1.804800E+01,5.344600E+01,& + & 3.667300E+02,3.032700E+03,8.689300E+03,4.008500E-06,1.439500E-05,& + & 5.461000E-05,2.291900E-04,8.418700E-04,2.648200E-03,8.348600E-03,& + & 3.448100E-02,3.439500E-01,1.877400E+00,3.955900E+00,9.928100E+00,& + & 3.000300E+01,1.962100E+02,1.516300E+03,4.344200E+03,1.310900E-06,& + & 2.944800E-06,5.979400E-06,1.105000E-05,2.020500E-05,4.668200E-05,& + & 1.192600E-04,4.370700E-04,4.950700E-03,2.492500E-02,4.641600E-02,& + & 8.909500E-02,2.583000E-01,2.434400E+00,5.195700E+01,3.794200E+02,& + & 2.123200E-06,1.507000E-05,9.982500E-05,6.621200E-04,3.176200E-03,& + & 1.118300E-02,3.722500E-02,1.556200E-01,1.551300E+00,8.333300E+00,& + & 1.699900E+01,4.188900E+01,1.288800E+02,9.033800E+02,7.070800E+03,& + & 1.981700E+04,5.543300E-06,2.426600E-05,1.189200E-04,6.385900E-04,& + & 2.705700E-03,9.117200E-03,2.976400E-02,1.241100E-01,1.249800E+00,& + & 6.718200E+00,1.358500E+01,3.282400E+01,9.852700E+01,6.777700E+02,& + & 5.302900E+03,1.486200E+04,5.987200E-06,2.381200E-05,1.033900E-04,& + & 4.919000E-04,1.944900E-03,6.401700E-03,2.071900E-02,8.602500E-02,& + & 8.613200E-01,4.687200E+00,9.621700E+00,2.355500E+01,6.905600E+01,& + & 4.571100E+02,3.535400E+03,9.908800E+03,5.269700E-06,1.954300E-05,& + & 7.525400E-05,3.057600E-04,1.090200E-03,3.476100E-03,1.109200E-02,& + & 4.600700E-02,4.540400E-01,2.461000E+00,5.149000E+00,1.303100E+01,& + & 3.864300E+01,2.433400E+02,1.767800E+03,4.953100E+03,1.531800E-06,& + & 3.528700E-06,7.102100E-06,1.328000E-05,2.403800E-05,5.559200E-05,& + & 1.438600E-04,5.296500E-04,6.267900E-03,3.051300E-02,5.548600E-02,& + & 1.065600E-01,3.327800E-01,3.473500E+00,6.324400E+01,4.481500E+02/ + data absb(:,621:640) / & + & 2.897100E-06,2.176700E-05,1.454300E-04,9.067200E-04,4.070100E-03,& + & 1.435200E-02,4.877900E-02,2.051400E-01,2.011700E+00,1.070500E+01,& + & 2.174100E+01,5.398800E+01,1.645300E+02,1.103400E+03,8.093700E+03,& + & 2.221200E+04,7.254900E-06,3.365300E-05,1.673100E-04,8.547200E-04,& + & 3.450400E-03,1.171900E-02,3.901300E-02,1.635700E-01,1.622700E+00,& + & 8.609400E+00,1.732700E+01,4.216200E+01,1.254100E+02,8.276400E+02,& + & 6.070800E+03,1.666000E+04,7.852000E-06,3.245000E-05,1.427300E-04,& + & 6.502700E-04,2.474100E-03,8.220900E-03,2.714300E-02,1.132400E-01,& + & 1.120100E+00,6.014300E+00,1.232200E+01,3.020500E+01,8.768500E+01,& + & 5.572500E+02,4.047000E+03,1.110700E+04,6.821600E-06,2.602400E-05,& + & 1.013500E-04,3.979600E-04,1.383600E-03,4.454900E-03,1.451300E-02,& + & 6.046100E-02,5.904200E-01,3.166400E+00,6.615200E+00,1.681500E+01,& + & 4.891800E+01,2.953400E+02,2.023500E+03,5.553100E+03,1.772000E-06,& + & 4.187900E-06,8.299300E-06,1.571900E-05,2.836500E-05,6.550300E-05,& + & 1.712700E-04,6.331500E-04,7.768800E-03,3.683400E-02,6.581600E-02,& + & 1.314900E-01,4.126000E-01,4.851000E+00,7.591400E+01,5.197000E+02,& + & 6.610000E-07,3.335700E-06,1.951000E-05,1.561000E-04,1.010200E-03,& + & 3.639200E-03,1.219400E-02,5.088100E-02,5.450700E-01,3.028800E+00,& + & 6.556600E+00,1.567100E+01,4.985900E+01,4.035500E+02,4.136700E+03,& + & 1.245500E+04,1.783400E-06,6.196300E-06,2.749900E-05,1.691300E-04,& + & 8.855900E-04,2.980100E-03,9.777200E-03,4.067800E-02,4.388500E-01,& + & 2.461900E+00,5.301400E+00,1.249100E+01,3.858600E+01,3.031400E+02,& + & 3.102300E+03,9.342100E+03,1.937100E-06,6.460300E-06,2.604800E-05,& + & 1.382300E-04,6.474100E-04,2.105000E-03,6.815400E-03,2.835600E-02,& + & 3.019700E-01,1.708400E+00,3.705700E+00,8.946200E+00,2.755000E+01,& + & 2.057800E+02,2.068300E+03,6.227700E+03,1.776300E-06,5.749900E-06,& + & 2.077400E-05,9.264500E-05,3.694700E-04,1.156200E-03,3.663000E-03,& + & 1.524700E-02,1.593400E-01,8.967400E-01,1.957900E+00,4.848900E+00,& + & 1.554700E+01,1.119500E+02,1.034200E+03,3.113900E+03,7.122500E-07,& + & 1.540200E-06,3.072600E-06,5.671600E-06,1.041200E-05,2.409000E-05,& + & 6.072100E-05,2.260300E-04,2.391500E-03,1.271500E-02,2.535600E-02,& + & 5.406700E-02,1.239600E-01,1.008800E+00,3.206100E+01,2.484300E+02,& + & 8.849900E-07,5.157800E-06,3.225200E-05,2.446700E-04,1.424900E-03,& + & 5.065800E-03,1.689200E-02,7.111500E-02,7.543500E-01,4.160800E+00,& + & 8.915100E+00,2.138700E+01,6.873800E+01,5.366000E+02,5.055200E+03,& + & 1.494400E+04,2.425500E-06,9.186300E-06,4.262300E-05,2.539800E-04,& + & 1.232700E-03,4.141600E-03,1.354000E-02,5.687300E-02,6.077200E-01,& + & 3.383400E+00,7.184100E+00,1.697400E+01,5.303200E+01,4.028600E+02,& + & 3.791300E+03,1.120800E+04,2.630700E-06,9.381900E-06,3.914600E-05,& + & 2.029500E-04,8.931900E-04,2.919400E-03,9.434900E-03,3.954800E-02,& + & 4.182600E-01,2.351500E+00,5.040000E+00,1.218400E+01,3.761200E+01,& + & 2.729600E+02,2.527500E+03,7.471500E+03,2.379300E-06,8.143400E-06,& + & 3.029100E-05,1.320600E-04,5.058400E-04,1.594600E-03,5.065500E-03,& + & 2.121100E-02,2.205300E-01,1.235300E+00,2.665600E+00,6.660400E+00,& + & 2.120000E+01,1.474200E+02,1.263800E+03,3.735600E+03,8.630200E-07,& + & 1.894500E-06,3.810200E-06,6.981100E-06,1.290100E-05,2.986800E-05,& + & 7.593100E-05,2.805400E-04,3.163800E-03,1.655500E-02,3.189100E-02,& + & 6.550900E-02,1.672000E-01,1.528100E+00,4.066800E+01,3.083700E+02,& + & 1.215500E-06,7.890100E-06,5.118700E-05,3.659100E-04,1.931800E-03,& + & 6.871100E-03,2.299300E-02,9.749000E-02,1.021100E+00,5.634600E+00,& + & 1.177800E+01,2.878500E+01,9.237300E+01,6.924500E+02,6.033100E+03,& + & 1.745800E+04,3.284800E-06,1.338000E-05,6.409700E-05,3.654100E-04,& + & 1.657900E-03,5.610700E-03,1.842700E-02,7.789600E-02,8.232300E-01,& + & 4.572100E+00,9.468900E+00,2.275600E+01,7.099900E+01,5.197300E+02,& + & 4.525000E+03,1.309300E+04,3.550300E-06,1.338900E-05,5.722300E-05,& + & 2.863300E-04,1.196700E-03,3.945400E-03,1.283400E-02,5.410300E-02,& + & 5.669500E-01,3.180700E+00,6.676800E+00,1.637300E+01,5.005300E+01,& + & 3.515200E+02,3.016800E+03,8.728900E+03,3.167500E-06,1.132100E-05,& + & 4.297000E-05,1.817500E-04,6.743400E-04,2.148100E-03,6.882500E-03,& + & 2.895900E-02,2.988300E-01,1.668800E+00,3.548800E+00,9.014600E+00,& + & 2.817000E+01,1.885800E+02,1.508300E+03,4.364600E+03,1.026700E-06,& + & 2.292000E-06,4.639000E-06,8.464500E-06,1.567200E-05,3.607200E-05,& + & 9.348000E-05,3.439900E-04,4.090300E-03,2.125300E-02,3.970900E-02,& + & 7.756800E-02,2.237000E-01,2.240700E+00,5.054200E+01,3.732600E+02/ + data absb(:,641:660) / & + & 1.677900E-06,1.179100E-05,7.800400E-05,5.230200E-04,2.543400E-03,& + & 9.073100E-03,3.080400E-02,1.315700E-01,1.355700E+00,7.463900E+00,& + & 1.533300E+01,3.811700E+01,1.213000E+02,8.711300E+02,7.050300E+03,& + & 1.994500E+04,4.388500E-06,1.906600E-05,9.343000E-05,5.067100E-04,& + & 2.171400E-03,7.412700E-03,2.468600E-02,1.050600E-01,1.095000E+00,& + & 6.037000E+00,1.230400E+01,2.999600E+01,9.291800E+01,6.536000E+02,& + & 5.287400E+03,1.495900E+04,4.736400E-06,1.873900E-05,8.142100E-05,& + & 3.907700E-04,1.561600E-03,5.206600E-03,1.719200E-02,7.284900E-02,& + & 7.547600E-01,4.209200E+00,8.712200E+00,2.160100E+01,6.527900E+01,& + & 4.411700E+02,3.525200E+03,9.972000E+03,4.172100E-06,1.541800E-05,& + & 5.943700E-05,2.433100E-04,8.756200E-04,2.828100E-03,9.206500E-03,& + & 3.894500E-02,3.979900E-01,2.209000E+00,4.654200E+00,1.196700E+01,& + & 3.662600E+01,2.353500E+02,1.762600E+03,4.986600E+03,1.204100E-06,& + & 2.752100E-06,5.509900E-06,1.016000E-05,1.879500E-05,4.314000E-05,& + & 1.131200E-04,4.186000E-04,5.207700E-03,2.621500E-02,4.736000E-02,& + & 9.407100E-02,2.870400E-01,3.232400E+00,6.167000E+01,4.419800E+02,& + & 2.293800E-06,1.710100E-05,1.142400E-04,7.195300E-04,3.268300E-03,& + & 1.166300E-02,4.062600E-02,1.748300E-01,1.773000E+00,9.672300E+00,& + & 1.976200E+01,4.966700E+01,1.562700E+02,1.070300E+03,8.088600E+03,& + & 2.239100E+04,5.757800E-06,2.653700E-05,1.320700E-04,6.807100E-04,& + & 2.776500E-03,9.541800E-03,3.256900E-02,1.396600E-01,1.434500E+00,& + & 7.805400E+00,1.581200E+01,3.892100E+01,1.193000E+02,8.029100E+02,& + & 6.066200E+03,1.679200E+04,6.225600E-06,2.562900E-05,1.128600E-04,& + & 5.184100E-04,1.992300E-03,6.695400E-03,2.267300E-02,9.675800E-02,& + & 9.901700E-01,5.449800E+00,1.124400E+01,2.799500E+01,8.354700E+01,& + & 5.409200E+02,4.044100E+03,1.119500E+04,5.412900E-06,2.059100E-05,& + & 8.030500E-05,3.177100E-04,1.114200E-03,3.631000E-03,1.212700E-02,& + & 5.164500E-02,5.220300E-01,2.866900E+00,6.031900E+00,1.561000E+01,& + & 4.673900E+01,2.871400E+02,2.022000E+03,5.597400E+03,1.394100E-06,& + & 3.278800E-06,6.458000E-06,1.208700E-05,2.214500E-05,5.113900E-05,& + & 1.348100E-04,5.036500E-04,6.500400E-03,3.167300E-02,5.665000E-02,& + & 1.146900E-01,3.618000E-01,4.552600E+00,7.417500E+01,5.134900E+02,& + & 5.262200E-07,2.592500E-06,1.495500E-05,1.209600E-04,7.994600E-04,& + & 2.911800E-03,9.886300E-03,4.187200E-02,4.635300E-01,2.634600E+00,& + & 5.781500E+00,1.390100E+01,4.530200E+01,3.804800E+02,4.083600E+03,& + & 1.240600E+04,1.407400E-06,4.822100E-06,2.128200E-05,1.319900E-04,& + & 7.029800E-04,2.388600E-03,7.938500E-03,3.354800E-02,3.740600E-01,& + & 2.150100E+00,4.698700E+00,1.113700E+01,3.517100E+01,2.859500E+02,& + & 3.062500E+03,9.307600E+03,1.526800E-06,5.037700E-06,2.023700E-05,& + & 1.081500E-04,5.141600E-04,1.688200E-03,5.533600E-03,2.339800E-02,& + & 2.575400E-01,1.489700E+00,3.283900E+00,7.984600E+00,2.523600E+01,& + & 1.943300E+02,2.041800E+03,6.203500E+03,1.401300E-06,4.492800E-06,& + & 1.620800E-05,7.273600E-05,2.936800E-04,9.275500E-04,2.975300E-03,& + & 1.257600E-02,1.358800E-01,7.817900E-01,1.733600E+00,4.319500E+00,& + & 1.428600E+01,1.061400E+02,1.020800E+03,3.102400E+03,5.482100E-07,& + & 1.189600E-06,2.341400E-06,4.313200E-06,7.972000E-06,1.839100E-05,& + & 4.682900E-05,1.761400E-04,1.934300E-03,1.049400E-02,2.136100E-02,& + & 4.618300E-02,1.056800E-01,9.124200E-01,3.097300E+01,2.423900E+02,& + & 7.006900E-07,4.008000E-06,2.486700E-05,1.908600E-04,1.133300E-03,& + & 4.075000E-03,1.378200E-02,5.909400E-02,6.481200E-01,3.662300E+00,& + & 7.940300E+00,1.915000E+01,6.339100E+01,5.106700E+02,5.006800E+03,& + & 1.493400E+04,1.913000E-06,7.165700E-06,3.314400E-05,1.993700E-04,& + & 9.829000E-04,3.338100E-03,1.106800E-02,4.731600E-02,5.236000E-01,& + & 2.986800E+00,6.430200E+00,1.527000E+01,4.904100E+01,3.834800E+02,& + & 3.754900E+03,1.120000E+04,2.073700E-06,7.333900E-06,3.054700E-05,& + & 1.597000E-04,7.125500E-04,2.354000E-03,7.713500E-03,3.292400E-02,& + & 3.603900E-01,2.074800E+00,4.510900E+00,1.097600E+01,3.492300E+01,& + & 2.601000E+02,2.503400E+03,7.467200E+03,1.876500E-06,6.382200E-06,& + & 2.372400E-05,1.042600E-04,4.035300E-04,1.286300E-03,4.142600E-03,& + & 1.766200E-02,1.900200E-01,1.090000E+00,2.384800E+00,5.990500E+00,& + & 1.975100E+01,1.408900E+02,1.251600E+03,3.733700E+03,6.683200E-07,& + & 1.463600E-06,2.929800E-06,5.318100E-06,9.922300E-06,2.280600E-05,& + & 5.890300E-05,2.195200E-04,2.584700E-03,1.380100E-02,2.690900E-02,& + & 5.609300E-02,1.424900E-01,1.402500E+00,3.942300E+01,3.019300E+02/ + data absb(:,661:680) / & + & 9.602900E-07,6.148000E-06,3.971800E-05,2.872000E-04,1.541800E-03,& + & 5.551300E-03,1.888400E-02,8.181400E-02,8.860700E-01,5.014900E+00,& + & 1.058900E+01,2.601000E+01,8.632300E+01,6.645100E+02,5.991700E+03,& + & 1.749200E+04,2.594200E-06,1.047100E-05,5.009200E-05,2.884400E-04,& + & 1.325900E-03,4.542000E-03,1.516300E-02,6.545800E-02,7.166500E-01,& + & 4.081900E+00,8.548600E+00,2.065300E+01,6.650700E+01,4.988000E+02,& + & 4.493400E+03,1.311800E+04,2.802300E-06,1.049800E-05,4.484800E-05,& + & 2.264100E-04,9.573900E-04,3.194800E-03,1.056800E-02,4.546800E-02,& + & 4.936500E-01,2.837600E+00,6.023200E+00,1.489700E+01,4.704000E+01,& + & 3.375900E+02,2.995900E+03,8.745600E+03,2.502400E-06,8.899800E-06,& + & 3.379200E-05,1.440500E-04,5.397000E-04,1.739700E-03,5.669200E-03,& + & 2.434300E-02,2.601300E-01,1.488900E+00,3.196600E+00,8.208600E+00,& + & 2.653300E+01,1.815900E+02,1.497900E+03,4.372500E+03,8.007300E-07,& + & 1.775700E-06,3.559700E-06,6.456600E-06,1.214100E-05,2.768200E-05,& + & 7.275800E-05,2.700500E-04,3.363000E-03,1.794800E-02,3.327400E-02,& + & 6.765600E-02,1.930300E-01,2.076500E+00,4.914000E+01,3.665000E+02,& + & 1.325900E-06,9.222400E-06,6.090200E-05,4.128600E-04,2.035500E-03,& + & 7.349200E-03,2.547200E-02,1.112900E-01,1.187700E+00,6.707400E+00,& + & 1.389000E+01,3.480900E+01,1.145700E+02,8.414100E+02,7.019000E+03,& + & 2.002800E+04,3.473700E-06,1.497500E-05,7.336500E-05,4.018000E-04,& + & 1.741800E-03,6.017900E-03,2.045900E-02,8.902600E-02,9.619900E-01,& + & 5.443200E+00,1.118800E+01,2.751100E+01,8.791400E+01,6.314000E+02,& + & 5.264600E+03,1.502200E+04,3.746400E-06,1.474000E-05,6.408000E-05,& + & 3.102000E-04,1.253300E-03,4.228500E-03,1.425200E-02,6.177600E-02,& + & 6.633800E-01,3.790600E+00,7.919100E+00,1.987200E+01,6.189900E+01,& + & 4.263800E+02,3.509600E+03,1.001300E+04,3.302200E-06,1.215900E-05,& + & 4.691300E-05,1.935000E-04,7.030300E-04,2.297900E-03,7.632900E-03,& + & 3.303100E-02,3.498600E-01,1.988300E+00,4.224400E+00,1.102600E+01,& + & 3.482400E+01,2.279200E+02,1.754800E+03,5.007200E+03,9.384100E-07,& + & 2.140700E-06,4.266500E-06,7.729600E-06,1.459100E-05,3.335200E-05,& + & 8.828000E-05,3.303000E-04,4.296300E-03,2.219000E-02,4.039000E-02,& + & 8.164900E-02,2.486800E-01,3.022900E+00,6.011000E+01,4.351200E+02,& + & 1.816200E-06,1.343000E-05,8.967300E-05,5.706300E-04,2.623300E-03,& + & 9.466700E-03,3.379300E-02,1.492200E-01,1.567100E+00,8.767500E+00,& + & 1.803200E+01,4.584800E+01,1.488700E+02,1.039600E+03,8.070300E+03,& + & 2.251200E+04,4.569100E-06,2.091900E-05,1.041600E-04,5.419100E-04,& + & 2.233200E-03,7.761600E-03,2.715900E-02,1.194400E-01,1.271200E+00,& + & 7.101900E+00,1.448700E+01,3.605200E+01,1.138300E+02,7.799200E+02,& + & 6.052600E+03,1.688500E+04,4.935400E-06,2.023200E-05,8.916300E-05,& + & 4.131700E-04,1.602700E-03,5.448500E-03,1.891200E-02,8.278400E-02,& + & 8.776100E-01,4.957200E+00,1.029700E+01,2.603900E+01,7.984700E+01,& + & 5.257100E+02,4.035200E+03,1.125700E+04,4.294400E-06,1.628600E-05,& + & 6.359200E-05,2.535500E-04,8.967300E-04,2.956000E-03,1.012300E-02,& + & 4.413200E-02,4.628600E-01,2.605400E+00,5.520100E+00,1.453700E+01,& + & 4.477900E+01,2.794700E+02,2.017600E+03,5.628000E+03,1.089600E-06,& + & 2.551700E-06,5.000300E-06,9.208300E-06,1.727800E-05,3.965100E-05,& + & 1.054900E-04,4.003000E-04,5.383900E-03,2.696100E-02,4.882400E-02,& + & 9.974700E-02,3.141600E-01,4.295200E+00,7.244200E+01,5.067100E+02,& + & 4.127100E-07,1.950300E-06,1.097300E-05,9.012000E-05,6.155800E-04,& + & 2.271200E-03,7.818300E-03,3.364700E-02,3.844800E-01,2.241400E+00,& + & 4.966300E+00,1.208100E+01,4.017700E+01,3.513300E+02,3.973100E+03,& + & 1.219100E+04,1.084200E-06,3.625600E-06,1.583400E-05,9.940500E-05,& + & 5.433900E-04,1.865800E-03,6.287200E-03,2.699600E-02,3.110700E-01,& + & 1.831200E+00,4.058000E+00,9.724300E+00,3.129800E+01,2.641500E+02,& + & 2.980000E+03,9.142800E+03,1.173600E-06,3.798300E-06,1.514100E-05,& + & 8.177400E-05,3.979900E-04,1.319200E-03,4.384000E-03,1.883000E-02,& + & 2.141000E-01,1.266900E+00,2.836800E+00,6.973300E+00,2.256500E+01,& + & 1.797000E+02,1.986500E+03,6.095500E+03,1.077700E-06,3.398300E-06,& + & 1.220700E-05,5.534800E-05,2.276100E-04,7.247900E-04,2.358300E-03,& + & 1.012300E-02,1.129700E-01,6.646400E-01,1.496100E+00,3.765300E+00,& + & 1.280500E+01,9.849500E+01,9.932700E+02,3.047600E+03,4.178700E-07,& + & 9.097000E-07,1.769500E-06,3.280200E-06,6.067900E-06,1.399500E-05,& + & 3.593400E-05,1.366400E-04,1.556800E-03,8.603300E-03,1.797700E-02,& + & 3.958100E-02,8.813800E-02,7.836600E-01,2.911900E+01,2.303100E+02/ + data absb(:,681:700) / & + & 5.438900E-07,3.009600E-06,1.841700E-05,1.439600E-04,8.810000E-04,& + & 3.204000E-03,1.100200E-02,4.807700E-02,5.450100E-01,3.146100E+00,& + & 6.926900E+00,1.683800E+01,5.719900E+01,4.777100E+02,4.901000E+03,& + & 1.476800E+04,1.470900E-06,5.407200E-06,2.485100E-05,1.517200E-04,& + & 7.663800E-04,2.628800E-03,8.845600E-03,3.853500E-02,4.412600E-01,& + & 2.573100E+00,5.639100E+00,1.348400E+01,4.437600E+01,3.588000E+02,& + & 3.676000E+03,1.107600E+04,1.592600E-06,5.550900E-06,2.303700E-05,& + & 1.219900E-04,5.562300E-04,1.854900E-03,6.166500E-03,2.683600E-02,& + & 3.038000E-01,1.785500E+00,3.954000E+00,9.695300E+00,3.174300E+01,& + & 2.435600E+02,2.450500E+03,7.384000E+03,1.442100E-06,4.850900E-06,& + & 1.799200E-05,8.008100E-05,3.150700E-04,1.014000E-03,3.312900E-03,& + & 1.439400E-02,1.600900E-01,9.382600E-01,2.089400E+00,5.280100E+00,& + & 1.800600E+01,1.322700E+02,1.225200E+03,3.692000E+03,5.101700E-07,& + & 1.129500E-06,2.230400E-06,4.045000E-06,7.610400E-06,1.745500E-05,& + & 4.550500E-05,1.711500E-04,2.104200E-03,1.142500E-02,2.294900E-02,& + & 4.856800E-02,1.185600E-01,1.227600E+00,3.728400E+01,2.887900E+02,& + & 7.418800E-07,4.634100E-06,2.971800E-05,2.189700E-04,1.207200E-03,& + & 4.398500E-03,1.520400E-02,6.735600E-02,7.540300E-01,4.364500E+00,& + & 9.357800E+00,2.310400E+01,7.915000E+01,6.281700E+02,5.896700E+03,& + & 1.739100E+04,1.998200E-06,7.943600E-06,3.786700E-05,2.217200E-04,& + & 1.040400E-03,3.605000E-03,1.222400E-02,5.394800E-02,6.113200E-01,& + & 3.563900E+00,7.589100E+00,1.842500E+01,6.113500E+01,4.716300E+02,& + & 4.422600E+03,1.304400E+04,2.156100E-06,7.988100E-06,3.406500E-05,& + & 1.745300E-04,7.513600E-04,2.537200E-03,8.520100E-03,3.749800E-02,& + & 4.209800E-01,2.477200E+00,5.345200E+00,1.330200E+01,4.339800E+01,& + & 3.193700E+02,2.948200E+03,8.695900E+03,1.928400E-06,6.797400E-06,& + & 2.581000E-05,1.115000E-04,4.237300E-04,1.381300E-03,4.572700E-03,& + & 2.006300E-02,2.218000E-01,1.300100E+00,2.832700E+00,7.321800E+00,& + & 2.454000E+01,1.720900E+02,1.474200E+03,4.348300E+03,6.157500E-07,& + & 1.374900E-06,2.732500E-06,4.939100E-06,9.344400E-06,2.129500E-05,& + & 5.660300E-05,2.119400E-04,2.749400E-03,1.515000E-02,2.835000E-02,& + & 5.895500E-02,1.635900E-01,1.843400E+00,4.670600E+01,3.525300E+02,& + & 1.024200E-06,6.995900E-06,4.605000E-05,3.181800E-04,1.602900E-03,& + & 5.856500E-03,2.066700E-02,9.261200E-02,1.022000E+00,5.919500E+00,& + & 1.240700E+01,3.127300E+01,1.065100E+02,8.027700E+02,6.940100E+03,& + & 2.000100E+04,2.685400E-06,1.142900E-05,5.592700E-05,3.114800E-04,& + & 1.374200E-03,4.801300E-03,1.663900E-02,7.416100E-02,8.299500E-01,& + & 4.819600E+00,1.002800E+01,2.481800E+01,8.189000E+01,6.024100E+02,& + & 5.204900E+03,1.500100E+04,2.892400E-06,1.127800E-05,4.902400E-05,& + & 2.409600E-04,9.894400E-04,3.375300E-03,1.159600E-02,5.147300E-02,& + & 5.721500E-01,3.356100E+00,7.089400E+00,1.796700E+01,5.778600E+01,& + & 4.071100E+02,3.470100E+03,1.000100E+04,2.552900E-06,9.339000E-06,& + & 3.606500E-05,1.507500E-04,5.550100E-04,1.834200E-03,6.214800E-03,& + & 2.751400E-02,3.016500E-01,1.760300E+00,3.774400E+00,9.975700E+00,& + & 3.257600E+01,2.178800E+02,1.735000E+03,5.000700E+03,7.261300E-07,& + & 1.656000E-06,3.283600E-06,5.926000E-06,1.131800E-05,2.575600E-05,& + & 6.892200E-05,2.601700E-04,3.544300E-03,1.898400E-02,3.439900E-02,& + & 7.085900E-02,2.142100E-01,2.712300E+00,5.738300E+01,4.205500E+02,& + & 1.406700E-06,1.026200E-05,6.846200E-05,4.433800E-04,2.076200E-03,& + & 7.577600E-03,2.765600E-02,1.253400E-01,1.362700E+00,7.834400E+00,& + & 1.624000E+01,4.171100E+01,1.398500E+02,9.997800E+02,8.013400E+03,& + & 2.255900E+04,3.547600E-06,1.606100E-05,8.002200E-05,4.229900E-04,& + & 1.771000E-03,6.221900E-03,2.228000E-02,1.004000E-01,1.108000E+00,& + & 6.366200E+00,1.309100E+01,3.292000E+01,1.071000E+02,7.501100E+02,& + & 6.009600E+03,1.691900E+04,3.824900E-06,1.557500E-05,6.868400E-05,& + & 3.230400E-04,1.271100E-03,4.368500E-03,1.552100E-02,6.962300E-02,& + & 7.649200E-01,4.440900E+00,9.299100E+00,2.384800E+01,7.525500E+01,& + & 5.057700E+02,4.006600E+03,1.128100E+04,3.333100E-06,1.257300E-05,& + & 4.917900E-05,1.986900E-04,7.113400E-04,2.369900E-03,8.310200E-03,& + & 3.714800E-02,4.034800E-01,2.332400E+00,4.978700E+00,1.331900E+01,& + & 4.228200E+01,2.691100E+02,2.003300E+03,5.640400E+03,8.461000E-07,& + & 1.976500E-06,3.878000E-06,7.042900E-06,1.349700E-05,3.071500E-05,& + & 8.277900E-05,3.169400E-04,4.464300E-03,2.328600E-02,4.202700E-02,& + & 8.653900E-02,2.756000E-01,3.891100E+00,6.939500E+01,4.916000E+02/ + data absb(:,701:720) / & + & 3.243200E-07,1.464500E-06,7.993600E-06,6.658600E-05,4.715000E-04,& + & 1.761200E-03,6.150000E-03,2.691900E-02,3.174500E-01,1.900900E+00,& + & 4.248500E+00,1.048500E+01,3.548300E+01,3.234200E+02,3.850300E+03,& + & 1.191800E+04,8.339200E-07,2.713100E-06,1.170200E-05,7.434400E-05,& + & 4.178600E-04,1.449200E-03,4.952400E-03,2.162500E-02,2.573300E-01,& + & 1.558100E+00,3.486200E+00,8.480000E+00,2.774500E+01,2.432400E+02,& + & 2.887700E+03,8.938100E+03,9.002500E-07,2.849100E-06,1.125000E-05,& + & 6.139100E-05,3.064100E-04,1.025000E-03,3.453800E-03,1.509100E-02,& + & 1.771300E-01,1.077200E+00,2.435200E+00,6.078700E+00,2.010400E+01,& + & 1.656700E+02,1.925200E+03,5.959000E+03,8.265900E-07,2.557100E-06,& + & 9.132600E-06,4.182600E-05,1.755900E-04,5.632500E-04,1.857900E-03,& + & 8.107300E-03,9.343600E-02,5.639000E-01,1.284900E+00,3.276900E+00,& + & 1.143500E+01,9.109400E+01,9.625800E+02,2.979400E+03,3.169900E-07,& + & 6.945100E-07,1.328900E-06,2.478900E-06,4.607700E-06,1.060400E-05,& + & 2.749400E-05,1.056900E-04,1.247200E-03,7.014500E-03,1.508800E-02,& + & 3.360600E-02,7.457800E-02,6.681800E-01,2.722400E+01,2.176600E+02,& + & 4.221500E-07,2.250200E-06,1.354100E-05,1.078600E-04,6.814700E-04,& + & 2.508000E-03,8.732600E-03,3.895900E-02,4.563800E-01,2.699700E+00,& + & 6.016600E+00,1.478600E+01,5.144300E+01,4.457300E+02,4.781500E+03,& + & 1.454600E+04,1.127700E-06,4.058600E-06,1.851000E-05,1.147100E-04,& + & 5.948600E-04,2.060800E-03,7.036100E-03,3.125800E-02,3.704200E-01,& + & 2.209400E+00,4.927100E+00,1.189400E+01,4.003300E+01,3.349300E+02,& + & 3.586200E+03,1.091000E+04,1.218600E-06,4.179900E-06,1.726100E-05,& + & 9.262700E-05,4.320900E-04,1.454600E-03,4.903500E-03,2.176900E-02,& + & 2.549100E-01,1.533400E+00,3.453700E+00,8.557600E+00,2.876600E+01,& + & 2.274700E+02,2.390800E+03,7.223900E+03,1.104900E-06,3.667400E-06,& + & 1.356300E-05,6.113400E-05,2.449800E-04,7.955200E-04,2.634900E-03,& + & 1.167400E-02,1.343600E-01,8.048800E-01,1.824300E+00,4.649300E+00,& + & 1.635800E+01,1.238200E+02,1.195300E+03,3.636400E+03,3.895900E-07,& + & 8.666000E-07,1.687600E-06,3.083100E-06,5.813500E-06,1.331000E-05,& + & 3.503600E-05,1.333500E-04,1.699300E-03,9.500500E-03,1.945300E-02,& + & 4.145700E-02,1.008000E-01,1.066200E+00,3.510100E+01,2.747300E+02,& + & 5.720300E-07,3.475000E-06,2.208500E-05,1.658800E-04,9.421300E-04,& + & 3.468100E-03,1.218200E-02,5.522700E-02,6.398200E-01,3.788500E+00,& + & 8.248500E+00,2.053000E+01,7.235300E+01,5.925200E+02,5.787200E+03,& + & 1.723700E+04,1.533500E-06,5.993100E-06,2.845000E-05,1.694300E-04,& + & 8.137200E-04,2.847700E-03,9.812100E-03,4.430400E-02,5.197200E-01,& + & 3.103500E+00,6.722100E+00,1.643700E+01,5.602400E+01,4.448800E+02,& + & 4.340100E+03,1.292700E+04,1.653000E-06,6.046500E-06,2.572800E-05,& + & 1.338300E-04,5.878000E-04,2.005100E-03,6.836400E-03,3.081000E-02,& + & 3.578400E-01,2.156700E+00,4.732100E+00,1.187100E+01,3.992800E+01,& + & 3.014500E+02,2.893500E+03,8.618700E+03,1.480800E-06,5.165400E-06,& + & 1.960600E-05,8.589900E-05,3.314500E-04,1.092300E-03,3.670400E-03,& + & 1.648500E-02,1.885100E-01,1.132000E+00,2.506000E+00,6.521800E+00,& + & 2.264400E+01,1.626900E+02,1.446700E+03,4.309200E+03,4.722900E-07,& + & 1.060200E-06,2.089600E-06,3.771200E-06,7.171500E-06,1.634900E-05,& + & 4.390000E-05,1.662000E-04,2.239300E-03,1.266500E-02,2.419800E-02,& + & 5.084200E-02,1.379800E-01,1.631000E+00,4.419700E+01,3.342100E+02,& + & 7.889200E-07,5.279200E-06,3.459900E-05,2.438300E-04,1.258200E-03,& + & 4.650100E-03,1.669800E-02,7.681900E-02,8.776300E-01,5.208300E+00,& + & 1.106600E+01,2.809300E+01,9.882100E+01,7.644700E+02,6.845800E+03,& + & 1.992500E+04,2.068200E-06,8.677400E-06,4.239300E-05,2.403700E-04,& + & 1.080900E-03,3.818800E-03,1.347000E-02,6.160900E-02,7.139700E-01,& + & 4.258700E+00,8.979100E+00,2.237400E+01,7.612400E+01,5.736900E+02,& + & 5.134100E+03,1.494200E+04,2.225100E-06,8.585000E-06,3.731000E-05,& + & 1.864500E-04,7.784400E-04,2.684500E-03,9.390100E-03,4.277000E-02,& + & 4.923200E-01,2.963200E+00,6.345900E+00,1.622300E+01,5.386200E+01,& + & 3.878700E+02,3.422500E+03,9.961300E+03,1.966300E-06,7.139600E-06,& + & 2.759100E-05,1.170000E-04,4.368500E-04,1.458800E-03,5.036000E-03,& + & 2.284300E-02,2.594800E-01,1.555200E+00,3.373400E+00,9.006800E+00,& + & 3.041400E+01,2.078000E+02,1.711500E+03,4.980800E+03,5.601900E-07,& + & 1.282000E-06,2.514200E-06,4.547800E-06,8.728500E-06,1.985500E-05,& + & 5.380900E-05,2.048400E-04,2.908600E-03,1.609600E-02,2.957000E-02,& + & 6.122900E-02,1.839500E-01,2.423100E+00,5.458300E+01,4.046800E+02/ + data absb(:,721:740) / & + & 1.086200E-06,7.802400E-06,5.197300E-05,3.430000E-04,1.638800E-03,& + & 6.049100E-03,2.254100E-02,1.050400E-01,1.182900E+00,6.989900E+00,& + & 1.463600E+01,3.792100E+01,1.312100E+02,9.600200E+02,7.939600E+03,& + & 2.256600E+04,2.744700E-06,1.227300E-05,6.116600E-05,3.288900E-04,& + & 1.401000E-03,4.974100E-03,1.820200E-02,8.429000E-02,9.642000E-01,& + & 5.695700E+00,1.183400E+01,3.003900E+01,1.006200E+02,7.202700E+02,& + & 5.954700E+03,1.692500E+04,2.953500E-06,1.193400E-05,5.264900E-05,& + & 2.516800E-04,1.005500E-03,3.494400E-03,1.268600E-02,5.843900E-02,& + & 6.656900E-01,3.971500E+00,8.399600E+00,2.181200E+01,7.081700E+01,& + & 4.858900E+02,3.969900E+03,1.128200E+04,2.577600E-06,9.665300E-06,& + & 3.785900E-05,1.551400E-04,5.626600E-04,1.895300E-03,6.797800E-03,& + & 3.117100E-02,3.511400E-01,2.085100E+00,4.488600E+00,1.219000E+01,& + & 3.985800E+01,2.586900E+02,1.984900E+03,5.640800E+03,6.559100E-07,& + & 1.528100E-06,2.998500E-06,5.391000E-06,1.046500E-05,2.379300E-05,& + & 6.478400E-05,2.503100E-04,3.694800E-03,2.000700E-02,3.612800E-02,& + & 7.528200E-02,2.397100E-01,3.511000E+00,6.625900E+01,4.754600E+02,& + & 2.558700E-07,1.103000E-06,5.813100E-06,4.899800E-05,3.600900E-04,& + & 1.361900E-03,4.821600E-03,2.147000E-02,2.614800E-01,1.607300E+00,& + & 3.634600E+00,9.107900E+00,3.131200E+01,2.974100E+02,3.721800E+03,& + & 1.161100E+04,6.425300E-07,2.029800E-06,8.628700E-06,5.541900E-05,& + & 3.203900E-04,1.122500E-03,3.887800E-03,1.728100E-02,2.124400E-01,& + & 1.321400E+00,2.994800E+00,7.399300E+00,2.458200E+01,2.237500E+02,& + & 2.791300E+03,8.708800E+03,6.916700E-07,2.135400E-06,8.339500E-06,& + & 4.594700E-05,2.354000E-04,7.939000E-04,2.712100E-03,1.205800E-02,& + & 1.462000E-01,9.141000E-01,2.089600E+00,5.302300E+00,1.789800E+01,& + & 1.525600E+02,1.858100E+03,5.805300E+03,6.342000E-07,1.922000E-06,& + & 6.818000E-06,3.151600E-05,1.351100E-04,4.365400E-04,1.458500E-03,& + & 6.478800E-03,7.710600E-02,4.786900E-01,1.101800E+00,2.853400E+00,& + & 1.020300E+01,8.413000E+01,9.304300E+02,2.902700E+03,2.395200E-07,& + & 5.276900E-07,9.932100E-07,1.866700E-06,3.481800E-06,7.989200E-06,& + & 2.093000E-05,8.123800E-05,9.924900E-04,5.665800E-03,1.259900E-02,& + & 2.807500E-02,6.331100E-02,5.709900E-01,2.539700E+01,2.050500E+02,& + & 3.286300E-07,1.683000E-06,9.928600E-06,8.048400E-05,5.259100E-04,& + & 1.958500E-03,6.915100E-03,3.149400E-02,3.815200E-01,2.316600E+00,& + & 5.224400E+00,1.300500E+01,4.625700E+01,4.154500E+02,4.655200E+03,& + & 1.428400E+04,8.649700E-07,3.042900E-06,1.375300E-05,8.648100E-05,& + & 4.607500E-04,1.610900E-03,5.579300E-03,2.531600E-02,3.103600E-01,& + & 1.901600E+00,4.297400E+00,1.051000E+01,3.610600E+01,3.122400E+02,& + & 3.491300E+03,1.063900E+04,9.326400E-07,3.143700E-06,1.290300E-05,& + & 7.010300E-05,3.350500E-04,1.137500E-03,3.888200E-03,1.763100E-02,& + & 2.136700E-01,1.317500E+00,3.011600E+00,7.561900E+00,2.605900E+01,& + & 2.121700E+02,2.327500E+03,7.141700E+03,8.464900E-07,2.768000E-06,& + & 1.020100E-05,4.654400E-05,1.900500E-04,6.224400E-04,2.090200E-03,& + & 9.452300E-03,1.125800E-01,6.910000E-01,1.591100E+00,4.101900E+00,& + & 1.485000E+01,1.157600E+02,1.163800E+03,3.570900E+03,2.977500E-07,& + & 6.599200E-07,1.273900E-06,2.335400E-06,4.417400E-06,1.011100E-05,& + & 2.686200E-05,1.034400E-04,1.366900E-03,7.808200E-03,1.632300E-02,& + & 3.544100E-02,8.598700E-02,9.262800E-01,3.298500E+01,2.606600E+02,& + & 4.416400E-07,2.603100E-06,1.636900E-05,1.253100E-04,7.337700E-04,& + & 2.728900E-03,9.731700E-03,4.522200E-02,5.421900E-01,3.293500E+00,& + & 7.264300E+00,1.827700E+01,6.613400E+01,5.585800E+02,5.667600E+03,& + & 1.703800E+04,1.176100E-06,4.514900E-06,2.132400E-05,1.292300E-04,& + & 6.353900E-04,2.243700E-03,7.853300E-03,3.633300E-02,4.415200E-01,& + & 2.704500E+00,5.949900E+00,1.469700E+01,5.132400E+01,4.194400E+02,& + & 4.251500E+03,1.277800E+04,1.266700E-06,4.568800E-06,1.938700E-05,& + & 1.023800E-04,4.592700E-04,1.580500E-03,5.474700E-03,2.526200E-02,& + & 3.041600E-01,1.877300E+00,4.187700E+00,1.061700E+01,3.671100E+01,& + & 2.843300E+02,2.834200E+03,8.519600E+03,1.136100E-06,3.919200E-06,& + & 1.486100E-05,6.604400E-05,2.590400E-04,8.612700E-04,2.938800E-03,& + & 1.352200E-02,1.601700E-01,9.857500E-01,2.217200E+00,5.819000E+00,& + & 2.087900E+01,1.536700E+02,1.416900E+03,4.259100E+03,3.612000E-07,& + & 8.146500E-07,1.586200E-06,2.870800E-06,5.479700E-06,1.250000E-05,& + & 3.389700E-05,1.297700E-04,1.822300E-03,1.048400E-02,2.061900E-02,& + & 4.308900E-02,1.169600E-01,1.442600E+00,4.177700E+01,3.222800E+02/ + data absb(:,741:760) / & + & 6.077400E-07,3.977200E-06,2.591700E-05,1.863300E-04,9.866500E-04,& + & 3.685200E-03,1.345900E-02,6.364400E-02,7.531000E-01,4.588100E+00,& + & 9.874700E+00,2.528900E+01,9.164900E+01,7.275900E+02,6.740400E+03,& + & 1.979900E+04,1.591400E-06,6.576800E-06,3.205800E-05,1.850300E-04,& + & 8.490000E-04,3.031100E-03,1.087600E-02,5.112800E-02,6.141200E-01,& + & 3.763900E+00,8.044700E+00,2.022100E+01,7.073900E+01,5.460900E+02,& + & 5.055200E+03,1.485000E+04,1.710000E-06,6.525200E-06,2.833300E-05,& + & 1.439700E-04,6.115200E-04,2.131600E-03,7.584400E-03,3.550600E-02,& + & 4.234500E-01,2.617700E+00,5.685400E+00,1.467000E+01,5.019100E+01,& + & 3.693300E+02,3.370600E+03,9.899700E+03,1.513100E-06,5.449500E-06,& + & 2.106400E-05,9.064500E-05,3.433500E-04,1.158300E-03,4.069700E-03,& + & 1.895100E-02,2.232100E-01,1.373700E+00,3.020600E+00,8.136500E+00,& + & 2.839600E+01,1.980800E+02,1.685200E+03,4.950200E+03,4.315700E-07,& + & 9.875000E-07,1.928900E-06,3.460600E-06,6.721900E-06,1.524800E-05,& + & 4.175900E-05,1.610500E-04,2.376600E-03,1.360100E-02,2.528200E-02,& + & 5.231700E-02,1.586800E-01,2.165700E+00,5.183300E+01,3.886500E+02,& + & 8.380200E-07,5.921200E-06,3.935500E-05,2.647600E-04,1.291900E-03,& + & 4.823500E-03,1.832000E-02,8.797400E-02,1.027200E+00,6.237000E+00,& + & 1.320600E+01,3.453500E+01,1.231500E+02,9.213100E+02,7.854800E+03,& + & 2.252500E+04,2.121100E-06,9.360400E-06,4.665200E-05,2.553400E-04,& + & 1.107100E-03,3.970200E-03,1.483800E-02,7.067100E-02,8.394500E-01,& + & 5.096700E+00,1.071600E+01,2.745200E+01,9.455000E+01,6.912800E+02,& + & 5.891100E+03,1.689400E+04,2.278500E-06,9.125300E-06,4.027500E-05,& + & 1.957800E-04,7.945400E-04,2.789200E-03,1.034300E-02,4.904300E-02,& + & 5.796000E-01,3.553400E+00,7.600100E+00,1.996900E+01,6.664900E+01,& + & 4.664800E+02,3.927700E+03,1.126200E+04,1.991200E-06,7.418200E-06,& + & 2.909900E-05,1.209800E-04,4.445500E-04,1.513400E-03,5.545600E-03,& + & 2.614300E-02,3.057700E-01,1.865400E+00,4.054400E+00,1.116400E+01,& + & 3.757000E+01,2.485000E+02,1.963700E+03,5.631100E+03,5.072100E-07,& + & 1.177600E-06,2.309100E-06,4.108400E-06,8.099600E-06,1.835000E-05,& + & 5.054000E-05,1.971900E-04,3.046300E-03,1.703900E-02,3.087600E-02,& + & 6.543600E-02,2.088600E-01,3.167300E+00,6.318800E+01,4.587400E+02,& + & 2.023300E-07,8.242800E-07,4.137900E-06,3.524200E-05,2.706800E-04,& + & 1.039200E-03,3.727100E-03,1.686100E-02,2.118400E-01,1.340400E+00,& + & 3.066000E+00,7.824700E+00,2.722800E+01,2.701200E+02,3.573800E+03,& + & 1.123900E+04,4.912000E-07,1.495300E-06,6.227600E-06,4.043600E-05,& + & 2.419500E-04,8.569500E-04,3.007600E-03,1.359000E-02,1.723300E-01,& + & 1.105800E+00,2.537000E+00,6.383400E+00,2.145800E+01,2.033000E+02,& + & 2.680100E+03,8.429600E+03,5.263900E-07,1.573700E-06,6.050500E-06,& + & 3.371400E-05,1.781600E-04,6.059800E-04,2.098300E-03,9.485300E-03,& + & 1.186600E-01,7.646100E-01,1.768700E+00,4.569700E+00,1.569400E+01,& + & 1.387500E+02,1.787000E+03,5.619900E+03,4.808900E-07,1.419600E-06,& + & 4.986200E-06,2.328100E-05,1.024900E-04,3.333200E-04,1.128300E-03,& + & 5.094500E-03,6.257700E-02,4.003100E-01,9.321600E-01,2.455100E+00,& + & 8.961400E+00,7.670400E+01,8.934200E+02,2.809800E+03,1.796500E-07,& + & 3.947900E-07,7.315300E-07,1.391900E-06,2.583700E-06,5.955200E-06,& + & 1.571500E-05,6.184400E-05,7.758900E-04,4.484700E-03,1.030800E-02,& + & 2.311700E-02,5.360800E-02,4.718800E-01,2.326400E+01,1.898100E+02,& + & 2.553800E-07,1.242200E-06,7.122800E-06,5.889700E-05,4.010400E-04,& + & 1.510100E-03,5.403400E-03,2.510200E-02,3.145100E-01,1.966900E+00,& + & 4.485600E+00,1.133600E+01,4.105300E+01,3.833300E+02,4.511100E+03,& + & 1.396600E+04,6.569200E-07,2.243000E-06,1.001200E-05,6.405400E-05,& + & 3.525400E-04,1.243600E-03,4.365000E-03,2.021000E-02,2.565200E-01,& + & 1.617300E+00,3.705600E+00,9.197800E+00,3.214000E+01,2.881600E+02,& + & 3.383400E+03,1.047300E+04,7.054700E-07,2.324300E-06,9.453800E-06,& + & 5.216800E-05,2.567200E-04,8.783200E-04,3.042700E-03,1.408000E-02,& + & 1.766000E-01,1.119400E+00,2.594500E+00,6.614300E+00,2.330600E+01,& + & 1.959600E+02,2.255900E+03,6.983900E+03,6.407500E-07,2.053200E-06,& + & 7.528800E-06,3.486500E-05,1.458200E-04,4.807100E-04,1.634700E-03,& + & 7.545000E-03,9.298700E-02,5.870400E-01,1.370000E+00,3.580400E+00,& + & 1.330200E+01,1.070700E+02,1.127700E+03,3.491400E+03,2.249600E-07,& + & 4.984600E-07,9.446600E-07,1.754800E-06,3.314600E-06,7.596100E-06,& + & 2.036600E-05,7.957300E-05,1.083100E-03,6.271700E-03,1.360100E-02,& + & 2.965900E-02,7.180000E-02,7.839000E-01,3.049400E+01,2.434800E+02/ + data absb(:,761:780) / & + & 3.391700E-07,1.920400E-06,1.188900E-05,9.317000E-05,5.661800E-04,& + & 2.125400E-03,7.686500E-03,3.657000E-02,4.543800E-01,2.836100E+00,& + & 6.337200E+00,1.613700E+01,5.980100E+01,5.226800E+02,5.536400E+03,& + & 1.680300E+04,8.917900E-07,3.344400E-06,1.568800E-05,9.704600E-05,& + & 4.915000E-04,1.749800E-03,6.212000E-03,2.943000E-02,3.707400E-01,& + & 2.333700E+00,5.214000E+00,1.303000E+01,4.651600E+01,3.925500E+02,& + & 4.152200E+03,1.260200E+04,9.586900E-07,3.395900E-06,1.435000E-05,& + & 7.725100E-05,3.553800E-04,1.232500E-03,4.331200E-03,2.047300E-02,& + & 2.554300E-01,1.618500E+00,3.667600E+00,9.415300E+00,3.339000E+01,& + & 2.661700E+02,2.768100E+03,8.401100E+03,8.598600E-07,2.926300E-06,& + & 1.107500E-05,5.010600E-05,2.004500E-04,6.718100E-04,2.325100E-03,& + & 1.095400E-02,1.344800E-01,8.494900E-01,1.941900E+00,5.144900E+00,& + & 1.903000E+01,1.440000E+02,1.384100E+03,4.200500E+03,2.746900E-07,& + & 6.179200E-07,1.189200E-06,2.166800E-06,4.143200E-06,9.447700E-06,& + & 2.593800E-05,1.006300E-04,1.461100E-03,8.530800E-03,1.730600E-02,& + & 3.685700E-02,9.710500E-02,1.243400E+00,3.890900E+01,3.035000E+02,& + & 4.644600E-07,2.951500E-06,1.907400E-05,1.404800E-04,7.683500E-04,& + & 2.897400E-03,1.073500E-02,5.223100E-02,6.400700E-01,4.009400E+00,& + & 8.740900E+00,2.262200E+01,8.423900E+01,6.884700E+02,6.629700E+03,& + & 1.966800E+04,1.210100E-06,4.908300E-06,2.384400E-05,1.407500E-04,& + & 6.621600E-04,2.386000E-03,8.687100E-03,4.198000E-02,5.232800E-01,& + & 3.294800E+00,7.153600E+00,1.815000E+01,6.513500E+01,5.167600E+02,& + & 4.972300E+03,1.475100E+04,1.297800E-06,4.884700E-06,2.117900E-05,& + & 1.098600E-04,4.767500E-04,1.678800E-03,6.056500E-03,2.916300E-02,& + & 3.607900E-01,2.290000E+00,5.054500E+00,1.316500E+01,4.633500E+01,& + & 3.495400E+02,3.314700E+03,9.833900E+03,1.149800E-06,4.097700E-06,& + & 1.584500E-05,6.944800E-05,2.678100E-04,9.119500E-04,3.250400E-03,& + & 1.556200E-02,1.900700E-01,1.202000E+00,2.683900E+00,7.285600E+00,& + & 2.627400E+01,1.875200E+02,1.657400E+03,4.916600E+03,3.304400E-07,& + & 7.519600E-07,1.463700E-06,2.607400E-06,5.131500E-06,1.158500E-05,& + & 3.215100E-05,1.255200E-04,1.917800E-03,1.125900E-02,2.152600E-02,& + & 4.455700E-02,1.339100E-01,1.891900E+00,4.857500E+01,3.686500E+02,& + & 6.411200E-07,4.432800E-06,2.935100E-05,2.022000E-04,1.012700E-03,& + & 3.824400E-03,1.474400E-02,7.305500E-02,8.847900E-01,5.526200E+00,& + & 1.184600E+01,3.125300E+01,1.147900E+02,8.805000E+02,7.771300E+03,& + & 2.250600E+04,1.621200E-06,7.040900E-06,3.507300E-05,1.964400E-04,& + & 8.692300E-04,3.151700E-03,1.196500E-02,5.874100E-02,7.247700E-01,& + & 4.528000E+00,9.643200E+00,2.492500E+01,8.824700E+01,6.606800E+02,& + & 5.828500E+03,1.687900E+04,1.737300E-06,6.883100E-06,3.038200E-05,& + & 1.508900E-04,6.240500E-04,2.214000E-03,8.345900E-03,4.076100E-02,& + & 5.004600E-01,3.154200E+00,6.837400E+00,1.814400E+01,6.231400E+01,& + & 4.459100E+02,3.885600E+03,1.125400E+04,1.520100E-06,5.617800E-06,& + & 2.206800E-05,9.349200E-05,3.489900E-04,1.200500E-03,4.475600E-03,& + & 2.171900E-02,2.639800E-01,1.655600E+00,3.643700E+00,1.013600E+01,& + & 3.514500E+01,2.376000E+02,1.942900E+03,5.626100E+03,3.902800E-07,& + & 9.006000E-07,1.758100E-06,3.127800E-06,6.198300E-06,1.401300E-05,& + & 3.912600E-05,1.549100E-04,2.477400E-03,1.438400E-02,2.623800E-02,& + & 5.586400E-02,1.784000E-01,2.797000E+00,5.953900E+01,4.378900E+02,& + & 1.612200E-07,6.179100E-07,2.920400E-06,2.500400E-05,2.013900E-04,& + & 7.868300E-04,2.856000E-03,1.311200E-02,1.698200E-01,1.106600E+00,& + & 2.566400E+00,6.678200E+00,2.346500E+01,2.433300E+02,3.414400E+03,& + & 1.082500E+04,3.755100E-07,1.096400E-06,4.446200E-06,2.913800E-05,& + & 1.810600E-04,6.487500E-04,2.306700E-03,1.058300E-02,1.384600E-01,& + & 9.154700E-01,2.130600E+00,5.472900E+00,1.856200E+01,1.832000E+02,& + & 2.560800E+03,8.118600E+03,3.996000E-07,1.152600E-06,4.342300E-06,& + & 2.443700E-05,1.335800E-04,4.587800E-04,1.608800E-03,7.386700E-03,& + & 9.529900E-02,6.327500E-01,1.485300E+00,3.911600E+00,1.363800E+01,& + & 1.251300E+02,1.707200E+03,5.412500E+03,3.637700E-07,1.039600E-06,& + & 3.606900E-06,1.698900E-05,7.709400E-05,2.522300E-04,8.642300E-04,& + & 3.965600E-03,5.024800E-02,3.315000E-01,7.818500E-01,2.098400E+00,& + & 7.792500E+00,6.932400E+01,8.536400E+02,2.706400E+03,1.335100E-07,& + & 2.927600E-07,5.348100E-07,1.025000E-06,1.896000E-06,4.396800E-06,& + & 1.169100E-05,4.670800E-05,5.985700E-04,3.489700E-03,8.339000E-03,& + & 1.919400E-02,4.487400E-02,3.854300E-01,2.106500E+01,1.739100E+02/ + data absb(:,781:800) / & + & 1.993800E-07,9.145800E-07,5.052700E-06,4.258500E-05,3.034500E-04,& + & 1.155900E-03,4.191400E-03,1.983800E-02,2.570600E-01,1.654200E+00,& + & 3.826500E+00,9.837000E+00,3.614600E+01,3.516000E+02,4.356900E+03,& + & 1.360300E+04,4.977300E-07,1.641000E-06,7.211000E-06,4.693800E-05,& + & 2.677400E-04,9.530500E-04,3.387800E-03,1.599500E-02,2.100500E-01,& + & 1.363500E+00,3.174800E+00,8.012700E+00,2.838200E+01,2.643900E+02,& + & 3.267400E+03,1.020200E+04,5.319500E-07,1.704400E-06,6.850800E-06,& + & 3.842200E-05,1.952500E-04,6.727700E-04,2.361700E-03,1.114400E-02,& + & 1.446200E-01,9.439900E-01,2.220400E+00,5.757600E+00,2.067200E+01,& + & 1.798300E+02,2.178400E+03,6.801400E+03,4.825800E-07,1.510300E-06,& + & 5.498200E-06,2.586500E-05,1.111200E-04,3.683000E-04,1.268000E-03,& + & 5.970300E-03,7.612600E-02,4.949400E-01,1.171700E+00,3.108700E+00,& + & 1.181400E+01,9.839100E+01,1.089300E+03,3.400600E+03,1.685700E-07,& + & 3.730500E-07,6.948100E-07,1.311200E-06,2.459500E-06,5.639400E-06,& + & 1.533600E-05,6.077600E-05,8.478500E-04,4.943000E-03,1.111100E-02,& + & 2.474100E-02,5.906300E-02,6.541000E-01,2.792900E+01,2.252600E+02,& + & 2.607500E-07,1.408100E-06,8.540200E-06,6.856300E-05,4.343900E-04,& + & 1.645400E-03,6.025700E-03,2.934500E-02,3.778600E-01,2.426600E+00,& + & 5.500600E+00,1.419400E+01,5.371400E+01,4.867200E+02,5.394400E+03,& + & 1.653000E+04,6.733400E-07,2.456700E-06,1.141900E-05,7.223200E-05,& + & 3.782200E-04,1.355800E-03,4.875300E-03,2.364900E-02,3.090400E-01,& + & 2.002000E+00,4.541800E+00,1.150600E+01,4.187300E+01,3.655900E+02,& + & 4.045800E+03,1.239800E+04,7.216200E-07,2.503500E-06,1.051500E-05,& + & 5.776100E-05,2.735500E-04,9.553400E-04,3.399100E-03,1.645800E-02,& + & 2.128600E-01,1.388700E+00,3.191500E+00,8.311900E+00,3.016500E+01,& + & 2.479400E+02,2.697100E+03,8.264900E+03,6.471900E-07,2.166700E-06,& + & 8.172400E-06,3.770000E-05,1.543300E-04,5.205500E-04,1.824800E-03,& + & 8.798400E-03,1.120400E-01,7.284700E-01,1.689200E+00,4.530800E+00,& + & 1.721200E+01,1.342200E+02,1.348600E+03,4.132700E+03,2.076800E-07,& + & 4.641400E-07,8.854300E-07,1.618600E-06,3.115800E-06,7.085900E-06,& + & 1.967400E-05,7.748700E-05,1.160500E-03,6.868200E-03,1.431200E-02,& + & 3.129100E-02,7.982800E-02,1.057400E+00,3.594300E+01,2.833700E+02,& + & 3.544000E-07,2.174200E-06,1.389400E-05,1.050100E-04,5.960000E-04,& + & 2.266900E-03,8.507400E-03,4.254200E-02,5.407100E-01,3.488600E+00,& + & 7.699000E+00,2.017200E+01,7.698100E+01,6.490700E+02,6.510500E+03,& + & 1.951100E+04,9.152800E-07,3.632300E-06,1.756200E-05,1.063000E-04,& + & 5.142500E-04,1.868600E-03,6.895300E-03,3.423700E-02,4.430300E-01,& + & 2.870800E+00,6.329500E+00,1.624600E+01,5.961400E+01,4.872100E+02,& + & 4.882800E+03,1.463400E+04,9.792600E-07,3.626700E-06,1.568200E-05,& + & 8.325300E-05,3.702500E-04,1.314800E-03,4.806700E-03,2.378200E-02,& + & 3.055500E-01,1.993100E+00,4.470700E+00,1.178100E+01,4.251900E+01,& + & 3.295900E+02,3.255400E+03,9.755700E+03,8.683100E-07,3.056000E-06,& + & 1.181400E-05,5.286000E-05,2.079500E-04,7.139900E-04,2.578300E-03,& + & 1.269600E-02,1.609000E-01,1.045900E+00,2.372800E+00,6.499700E+00,& + & 2.416000E+01,1.768300E+02,1.627600E+03,4.877800E+03,2.512800E-07,& + & 5.682500E-07,1.098400E-06,1.965100E-06,3.874600E-06,8.746200E-06,& + & 2.460100E-05,9.739100E-05,1.545300E-03,9.138100E-03,1.802200E-02,& + & 3.762200E-02,1.124800E-01,1.633800E+00,4.518200E+01,3.470300E+02,& + & 4.888200E-07,3.293900E-06,2.169200E-05,1.534300E-04,7.918400E-04,& + & 3.020100E-03,1.179800E-02,6.032700E-02,7.584100E-01,4.877300E+00,& + & 1.059000E+01,2.821900E+01,1.065100E+02,8.393500E+02,7.682900E+03,& + & 2.248200E+04,1.232100E-06,5.255300E-06,2.615000E-05,1.501900E-04,& + & 6.803800E-04,2.491700E-03,9.589300E-03,4.854400E-02,6.225800E-01,& + & 4.004600E+00,8.650800E+00,2.257000E+01,8.198300E+01,6.298100E+02,& + & 5.762200E+03,1.686100E+04,1.317100E-06,5.151600E-06,2.273800E-05,& + & 1.156700E-04,4.883900E-04,1.750900E-03,6.687600E-03,3.367700E-02,& + & 4.299600E-01,2.787300E+00,6.130800E+00,1.642800E+01,5.801300E+01,& + & 4.251200E+02,3.841400E+03,1.124100E+04,1.153600E-06,4.222800E-06,& + & 1.661900E-05,7.187200E-05,2.730300E-04,9.490400E-04,3.586600E-03,& + & 1.793400E-02,2.267500E-01,1.463000E+00,3.265600E+00,9.162800E+00,& + & 3.273400E+01,2.264600E+02,1.920800E+03,5.620300E+03,2.984300E-07,& + & 6.847000E-07,1.325800E-06,2.371000E-06,4.711300E-06,1.063900E-05,& + & 3.011000E-05,1.211500E-04,1.995900E-03,1.196000E-02,2.228400E-02,& + & 4.783100E-02,1.490100E-01,2.446000E+00,5.571500E+01,4.151200E+02/ + data absb(:,801:820) / & + & 1.298800E-07,4.681800E-07,2.065400E-06,1.764800E-05,1.492400E-04,& + & 5.936500E-04,2.179500E-03,1.014600E-02,1.354500E-01,9.073900E-01,& + & 2.144900E+00,5.677000E+00,2.018600E+01,2.182600E+02,3.250500E+03,& + & 1.039800E+04,2.887000E-07,8.072000E-07,3.170600E-06,2.089900E-05,& + & 1.347900E-04,4.895900E-04,1.762000E-03,8.198500E-03,1.106200E-01,& + & 7.542400E-01,1.785200E+00,4.679400E+00,1.602100E+01,1.643900E+02,& + & 2.437900E+03,7.798900E+03,3.053200E-07,8.451500E-07,3.110600E-06,& + & 1.762400E-05,9.973900E-05,3.460700E-04,1.228800E-03,5.722500E-03,& + & 7.615500E-02,5.212800E-01,1.243400E+00,3.342500E+00,1.180800E+01,& + & 1.124000E+02,1.625400E+03,5.199400E+03,2.758200E-07,7.609900E-07,& + & 2.602700E-06,1.233200E-05,5.775600E-05,1.902000E-04,6.597600E-04,& + & 3.071200E-03,4.015100E-02,2.727300E-01,6.545900E-01,1.790200E+00,& + & 6.751100E+00,6.238700E+01,8.127100E+02,2.599700E+03,9.868400E-08,& + & 2.164300E-07,3.884300E-07,7.477800E-07,1.382700E-06,3.222900E-06,& + & 8.635500E-06,3.506800E-05,4.571100E-04,2.709800E-03,6.537400E-03,& + & 1.580600E-02,3.757500E-02,3.136200E-01,1.898400E+01,1.587600E+02,& + & 1.568900E-07,6.772800E-07,3.578500E-06,3.064800E-05,2.288000E-04,& + & 8.821800E-04,3.238400E-03,1.560700E-02,2.091900E-01,1.385200E+00,& + & 3.258600E+00,8.532200E+00,3.173500E+01,3.215100E+02,4.197400E+03,& + & 1.320700E+04,3.784600E-07,1.201300E-06,5.180000E-06,3.422800E-05,& + & 2.027000E-04,7.280300E-04,2.619000E-03,1.260100E-02,1.712000E-01,& + & 1.146700E+00,2.712000E+00,6.976000E+00,2.499600E+01,2.417900E+02,& + & 3.148100E+03,9.905200E+03,4.023500E-07,1.249300E-06,4.949800E-06,& + & 2.814500E-05,1.480800E-04,5.139000E-04,1.825500E-03,8.780600E-03,& + & 1.179000E-01,7.930400E-01,1.896200E+00,5.007800E+00,1.828000E+01,& + & 1.645200E+02,2.098900E+03,6.603200E+03,3.640200E-07,1.109600E-06,& + & 4.002900E-06,1.910100E-05,8.439500E-05,2.811500E-04,9.800000E-04,& + & 4.701900E-03,6.207300E-02,4.157800E-01,1.000200E+00,2.699100E+00,& + & 1.045900E+01,9.013000E+01,1.049300E+03,3.301800E+03,1.256100E-07,& + & 2.784000E-07,5.055200E-07,9.715000E-07,1.808100E-06,4.170900E-06,& + & 1.147000E-05,4.614400E-05,6.579800E-04,3.854800E-03,8.966100E-03,& + & 2.041700E-02,4.952400E-02,5.422900E-01,2.549300E+01,2.076100E+02,& + & 2.016500E-07,1.034000E-06,6.115600E-06,5.024400E-05,3.322900E-04,& + & 1.270500E-03,4.709500E-03,2.345100E-02,3.131600E-01,2.071300E+00,& + & 4.767700E+00,1.249800E+01,4.811100E+01,4.520200E+02,5.246600E+03,& + & 1.622000E+04,5.092000E-07,1.803200E-06,8.289900E-06,5.352000E-05,& + & 2.903200E-04,1.048200E-03,3.813500E-03,1.893000E-02,2.566300E-01,& + & 1.715100E+00,3.951200E+00,1.016200E+01,3.759500E+01,3.395700E+02,& + & 3.935000E+03,1.216500E+04,5.434300E-07,1.843100E-06,7.682500E-06,& + & 4.300100E-05,2.101500E-04,7.383800E-04,2.658900E-03,1.317700E-02,& + & 1.767900E-01,1.189200E+00,2.772900E+00,7.336700E+00,2.718200E+01,& + & 2.303400E+02,2.623200E+03,8.109500E+03,4.873300E-07,1.601100E-06,& + & 6.011400E-06,2.824300E-05,1.185700E-04,4.022500E-04,1.426900E-03,& + & 7.043400E-03,9.299500E-02,6.242600E-01,1.466800E+00,3.989900E+00,& + & 1.552600E+01,1.247600E+02,1.311700E+03,4.054300E+03,1.562000E-07,& + & 3.480900E-07,6.489900E-07,1.207300E-06,2.326100E-06,5.281800E-06,& + & 1.481900E-05,5.945700E-05,9.116400E-04,5.460400E-03,1.172300E-02,& + & 2.609300E-02,6.770000E-02,8.943200E-01,3.311300E+01,2.636800E+02,& + & 2.712000E-07,1.600400E-06,1.009000E-05,7.819100E-05,4.615200E-04,& + & 1.769200E-03,6.718800E-03,3.451400E-02,4.556700E-01,3.032600E+00,& + & 6.775900E+00,1.799700E+01,7.018000E+01,6.109800E+02,6.383300E+03,& + & 1.931800E+04,6.921600E-07,2.683400E-06,1.289900E-05,7.999500E-05,& + & 3.989300E-04,1.459700E-03,5.453300E-03,2.782500E-02,3.741600E-01,& + & 2.500600E+00,5.590700E+00,1.454800E+01,5.443800E+01,4.586400E+02,& + & 4.787500E+03,1.439000E+04,7.388100E-07,2.687500E-06,1.158400E-05,& + & 6.288800E-05,2.872100E-04,1.026900E-03,3.802100E-03,1.932700E-02,& + & 2.581300E-01,1.734500E+00,3.945900E+00,1.055200E+01,3.892600E+01,& + & 3.102700E+02,3.191800E+03,9.658800E+03,6.553300E-07,2.274000E-06,& + & 8.784900E-06,4.015700E-05,1.612000E-04,5.576800E-04,2.039100E-03,& + & 1.031100E-02,1.359000E-01,9.098800E-01,2.094300E+00,5.801800E+00,& + & 2.215500E+01,1.664800E+02,1.595800E+03,4.829700E+03,1.900900E-07,& + & 4.276700E-07,8.118200E-07,1.483100E-06,2.908000E-06,6.556700E-06,& + & 1.869200E-05,7.543400E-05,1.228700E-03,7.388700E-03,1.489300E-02,& + & 3.235600E-02,9.216800E-02,1.409400E+00,4.193000E+01,3.257400E+02/ + data absb(:,821:840) / & + & 3.731000E-07,2.443100E-06,1.597400E-05,1.160500E-04,6.185700E-04,& + & 2.380600E-03,9.416000E-03,4.967500E-02,6.491900E-01,4.300800E+00,& + & 9.461700E+00,2.551000E+01,9.862000E+01,7.990300E+02,7.586800E+03,& + & 2.242400E+04,9.356800E-07,3.914400E-06,1.943600E-05,1.144900E-04,& + & 5.320400E-04,1.965700E-03,7.662700E-03,4.004300E-02,5.340100E-01,& + & 3.538700E+00,7.757400E+00,2.045500E+01,7.601500E+01,5.995600E+02,& + & 5.690100E+03,1.681800E+04,9.976200E-07,3.846900E-06,1.697200E-05,& + & 8.844800E-05,3.819000E-04,1.381200E-03,5.342800E-03,2.778400E-02,& + & 3.688200E-01,2.461200E+00,5.495400E+00,1.488500E+01,5.388900E+01,& + & 4.046500E+02,3.793400E+03,1.121200E+04,8.742500E-07,3.167500E-06,& + & 1.248100E-05,5.514000E-05,2.134100E-04,7.484100E-04,2.864800E-03,& + & 1.478600E-02,1.944800E-01,1.291400E+00,2.925700E+00,8.282300E+00,& + & 3.044900E+01,2.154900E+02,1.896700E+03,5.606100E+03,2.278500E-07,& + & 5.184700E-07,9.926000E-07,1.785800E-06,3.561200E-06,8.034700E-06,& + & 2.307100E-05,9.454000E-05,1.602900E-03,9.732100E-03,1.887900E-02,& + & 4.061000E-02,1.254600E-01,2.133600E+00,5.202700E+01,3.925900E+02,& + & 1.056400E-07,3.571500E-07,1.453800E-06,1.224100E-05,1.090600E-04,& + & 4.433500E-04,1.644200E-03,7.735100E-03,1.066800E-01,7.319900E-01,& + & 1.769300E+00,4.763800E+00,1.716800E+01,1.933400E+02,3.066200E+03,& + & 9.918900E+03,2.219700E-07,5.942100E-07,2.238100E-06,1.475400E-05,& + & 9.905900E-05,3.656000E-04,1.330100E-03,6.259000E-03,8.716500E-02,& + & 6.114500E-01,1.477800E+00,3.949600E+00,1.367400E+01,1.456700E+02,& + & 2.299600E+03,7.440000E+03,2.329000E-07,6.173400E-07,2.204400E-06,& + & 1.252800E-05,7.347700E-05,2.582000E-04,9.273100E-04,4.371200E-03,& + & 6.000700E-02,4.224000E-01,1.028600E+00,2.821800E+00,1.010200E+01,& + & 9.970500E+01,1.533100E+03,4.960000E+03,2.087500E-07,5.530500E-07,& + & 1.857000E-06,8.815100E-06,4.273400E-05,1.418600E-04,4.972400E-04,& + & 2.347000E-03,3.162800E-02,2.211700E-01,5.411000E-01,1.510500E+00,& + & 5.772100E+00,5.544500E+01,7.667200E+02,2.479700E+03,7.245400E-08,& + & 1.580000E-07,2.778000E-07,5.384800E-07,1.002400E-06,2.339400E-06,& + & 6.312300E-06,2.602400E-05,3.444400E-04,2.078500E-03,5.047400E-03,& + & 1.260400E-02,3.150600E-02,2.510600E-01,1.690500E+01,1.434200E+02,& + & 1.240400E-07,5.018700E-07,2.505400E-06,2.173100E-05,1.704300E-04,& + & 6.665200E-04,2.475600E-03,1.211700E-02,1.679300E-01,1.143800E+00,& + & 2.747800E+00,7.324800E+00,2.755100E+01,2.908400E+02,4.015500E+03,& + & 1.273100E+04,2.874500E-07,8.738100E-07,3.676100E-06,2.462500E-05,& + & 1.516500E-04,5.504800E-04,2.003800E-03,9.801900E-03,1.377000E-01,& + & 9.509800E-01,2.293000E+00,6.018900E+00,2.175900E+01,2.187800E+02,& + & 3.011600E+03,9.548200E+03,3.037900E-07,9.084800E-07,3.533300E-06,& + & 2.035200E-05,1.110800E-04,3.885700E-04,1.396100E-03,6.831200E-03,& + & 9.480500E-02,6.583300E-01,1.600900E+00,4.315700E+00,1.597500E+01,& + & 1.489500E+02,2.007900E+03,6.365300E+03,2.733500E-07,8.084300E-07,& + & 2.880300E-06,1.392100E-05,6.347300E-05,2.125400E-04,7.485800E-04,& + & 3.658100E-03,4.992900E-02,3.447100E-01,8.445700E-01,2.322000E+00,& + & 9.147200E+00,8.171200E+01,1.003900E+03,3.182600E+03,9.297100E-08,& + & 2.056300E-07,3.666600E-07,7.079200E-07,1.322700E-06,3.054300E-06,& + & 8.488700E-06,3.473700E-05,5.037200E-04,2.980500E-03,7.072600E-03,& + & 1.694300E-02,4.136800E-02,4.416700E-01,2.304100E+01,1.895400E+02,& + & 1.562400E-07,7.551500E-07,4.320500E-06,3.632800E-05,2.519300E-04,& + & 9.713900E-04,3.643000E-03,1.852100E-02,2.564000E-01,1.748100E+00,& + & 4.094100E+00,1.093100E+01,4.263100E+01,4.160500E+02,5.074100E+03,& + & 1.582000E+04,3.836900E-07,1.311800E-06,5.943000E-06,3.913900E-05,& + & 2.207900E-04,8.023300E-04,2.952700E-03,1.497200E-02,2.105700E-01,& + & 1.452500E+00,3.405300E+00,8.915500E+00,3.338900E+01,3.126000E+02,& + & 3.805600E+03,1.186500E+04,4.073700E-07,1.344500E-06,5.545100E-06,& + & 3.162600E-05,1.600500E-04,5.652100E-04,2.058400E-03,1.042300E-02,& + & 1.451100E-01,1.006800E+00,2.387500E+00,6.428500E+00,2.423300E+01,& + & 2.120600E+02,2.537000E+03,7.909900E+03,3.650000E-07,1.172100E-06,& + & 4.370900E-06,2.094000E-05,9.037600E-05,3.079600E-04,1.103400E-03,& + & 5.570700E-03,7.632400E-02,5.284500E-01,1.262600E+00,3.485800E+00,& + & 1.385500E+01,1.149400E+02,1.268500E+03,3.954800E+03,1.167100E-07,& + & 2.596700E-07,4.705200E-07,8.955500E-07,1.719100E-06,3.901600E-06,& + & 1.106500E-05,4.522700E-05,7.078600E-04,4.271700E-03,9.502300E-03,& + & 2.173400E-02,5.658100E-02,7.458900E-01,3.024100E+01,2.432400E+02/ + data absb(:,841:860) / & + & 2.072700E-07,1.167700E-06,7.229900E-06,5.753100E-05,3.545700E-04,& + & 1.369700E-03,5.255100E-03,2.771800E-02,3.801400E-01,2.609800E+00,& + & 5.918900E+00,1.594800E+01,6.337400E+01,5.708700E+02,6.229400E+03,& + & 1.903600E+04,5.205100E-07,1.963300E-06,9.361600E-06,5.951000E-05,& + & 3.071100E-04,1.131300E-03,4.270200E-03,2.237600E-02,3.127600E-01,& + & 2.158200E+00,4.899900E+00,1.293300E+01,4.924500E+01,4.285700E+02,& + & 4.672100E+03,1.427700E+04,5.540700E-07,1.972600E-06,8.460100E-06,& + & 4.702400E-05,2.212100E-04,7.953900E-04,2.977500E-03,1.554900E-02,& + & 2.158700E-01,1.496300E+00,3.453500E+00,9.380500E+00,3.531100E+01,& + & 2.899300E+02,3.114900E+03,9.517300E+03,4.915600E-07,1.676600E-06,& + & 6.462800E-06,3.021000E-05,1.241200E-04,4.317700E-04,1.596000E-03,& + & 8.294200E-03,1.136200E-01,7.850100E-01,1.832400E+00,5.143200E+00,& + & 2.011700E+01,1.555900E+02,1.557300E+03,4.759000E+03,1.431400E-07,& + & 3.210800E-07,5.953900E-07,1.109000E-06,2.164000E-06,4.893000E-06,& + & 1.409300E-05,5.806400E-05,9.678400E-04,5.863100E-03,1.232200E-02,& + & 2.740700E-02,7.498100E-02,1.199500E+00,3.862200E+01,3.034000E+02,& + & 2.835700E-07,1.795000E-06,1.162100E-05,8.682100E-05,4.801600E-04,& + & 1.863000E-03,7.449000E-03,4.052100E-02,5.507800E-01,3.766300E+00,& + & 8.388700E+00,2.292300E+01,9.054500E+01,7.556600E+02,7.463700E+03,& + & 2.228300E+04,7.058600E-07,2.888500E-06,1.428500E-05,8.644300E-05,& + & 4.135000E-04,1.540100E-03,6.070000E-03,3.272000E-02,4.540600E-01,& + & 3.103100E+00,6.902600E+00,1.843800E+01,6.987200E+01,5.670300E+02,& + & 5.597800E+03,1.671200E+04,7.504700E-07,2.846800E-06,1.253500E-05,& + & 6.704600E-05,2.966900E-04,1.082200E-03,4.232300E-03,2.270800E-02,& + & 3.136400E-01,2.156400E+00,4.889300E+00,1.340700E+01,4.962700E+01,& + & 3.827200E+02,3.732000E+03,1.106800E+04,6.579800E-07,2.355300E-06,& + & 9.283600E-06,4.196800E-05,1.658500E-04,5.860300E-04,2.267500E-03,& + & 1.208400E-02,1.653400E-01,1.131200E+00,2.602000E+00,7.435800E+00,& + & 2.809100E+01,2.037200E+02,1.866000E+03,5.570800E+03,1.723500E-07,& + & 3.901100E-07,7.356500E-07,1.345100E-06,2.668100E-06,6.021100E-06,& + & 1.754000E-05,7.348000E-05,1.280300E-03,7.783100E-03,1.561700E-02,& + & 3.430900E-02,1.035600E-01,1.842000E+00,4.825700E+01,3.687300E+02,& + & 8.691600E-08,2.739800E-07,1.014300E-06,8.244900E-06,7.779100E-05,& + & 3.249400E-04,1.214500E-03,5.759200E-03,8.215900E-02,5.723200E-01,& + & 1.424100E+00,3.908000E+00,1.428500E+01,1.673400E+02,2.847200E+03,& + & 9.346500E+03,1.706600E-07,4.358100E-07,1.553800E-06,1.014600E-05,& + & 7.116400E-05,2.678100E-04,9.833700E-04,4.667200E-03,6.719400E-02,& + & 4.803200E-01,1.194100E+00,3.256900E+00,1.142000E+01,1.261500E+02,& + & 2.135400E+03,7.009800E+03,1.773100E-07,4.470400E-07,1.532500E-06,& + & 8.680700E-06,5.296600E-05,1.890600E-04,6.853600E-04,3.259300E-03,& + & 4.625500E-02,3.321000E-01,8.300200E-01,2.326300E+00,8.447400E+00,& + & 8.646700E+01,1.423600E+03,4.673300E+03,1.574000E-07,3.966800E-07,& + & 1.297900E-06,6.151800E-06,3.095000E-05,1.037900E-04,3.673000E-04,& + & 1.750100E-03,2.436900E-02,1.740300E-01,4.364300E-01,1.244600E+00,& + & 4.817300E+00,4.818200E+01,7.120800E+02,2.336600E+03,5.295600E-08,& + & 1.132300E-07,1.973300E-07,3.833200E-07,7.197900E-07,1.670300E-06,& + & 4.551700E-06,1.909500E-05,2.569600E-04,1.546100E-03,3.782800E-03,& + & 1.016900E-02,2.664700E-02,1.960700E-01,1.472300E+01,1.274100E+02,& + & 9.860300E-08,3.710300E-07,1.720800E-06,1.499900E-05,1.243600E-04,& + & 4.947700E-04,1.859100E-03,9.206000E-03,1.318300E-01,9.238600E-01,& + & 2.269800E+00,6.156700E+00,2.342100E+01,2.579800E+02,3.795200E+03,& + & 1.213100E+04,2.173700E-07,6.285000E-07,2.553800E-06,1.729300E-05,& + & 1.113400E-04,4.087600E-04,1.504500E-03,7.457600E-03,1.082900E-01,& + & 7.711600E-01,1.898600E+00,5.088300E+00,1.854700E+01,1.941400E+02,& + & 2.846400E+03,9.097900E+03,2.280000E-07,6.516300E-07,2.469400E-06,& + & 1.438400E-05,8.175800E-05,2.882200E-04,1.048200E-03,5.199700E-03,& + & 7.455800E-02,5.336400E-01,1.324700E+00,3.649700E+00,1.365800E+01,& + & 1.322700E+02,1.897600E+03,6.065300E+03,2.036500E-07,5.800000E-07,& + & 2.030500E-06,9.918400E-06,4.685600E-05,1.578000E-04,5.613000E-04,& + & 2.784800E-03,3.926000E-02,2.793400E-01,6.982200E-01,1.960700E+00,& + & 7.822200E+00,7.269000E+01,9.487400E+02,3.032500E+03,6.835500E-08,& + & 1.499000E-07,2.630400E-07,5.106900E-07,9.546600E-07,2.223500E-06,& + & 6.194600E-06,2.583900E-05,3.806400E-04,2.320900E-03,5.467600E-03,& + & 1.373300E-02,3.514200E-02,3.472800E-01,2.045100E+01,1.703300E+02/ + data absb(:,861:880) / & + & 1.211400E-07,5.457700E-07,2.982800E-06,2.566300E-05,1.876700E-04,& + & 7.319000E-04,2.771400E-03,1.434600E-02,2.057900E-01,1.442900E+00,& + & 3.454700E+00,9.405300E+00,3.701400E+01,3.768200E+02,4.858100E+03,& + & 1.527900E+04,2.869300E-07,9.395600E-07,4.170200E-06,2.803100E-05,& + & 1.651800E-04,6.044100E-04,2.247000E-03,1.161400E-02,1.693200E-01,& + & 1.202400E+00,2.883600E+00,7.698200E+00,2.906400E+01,2.831900E+02,& + & 3.643600E+03,1.145900E+04,3.025700E-07,9.653100E-07,3.920200E-06,& + & 2.277600E-05,1.199500E-04,4.258100E-04,1.565400E-03,8.083500E-03,& + & 1.166400E-01,8.340600E-01,2.019600E+00,5.543200E+00,2.118200E+01,& + & 1.921600E+02,2.429000E+03,7.639500E+03,2.706000E-07,8.441500E-07,& + & 3.116700E-06,1.521400E-05,6.785500E-05,2.319600E-04,8.387500E-04,& + & 4.320800E-03,6.136500E-02,4.375700E-01,1.067800E+00,2.997800E+00,& + & 1.211900E+01,1.042500E+02,1.214500E+03,3.819900E+03,8.609800E-08,& + & 1.926200E-07,3.406500E-07,6.550700E-07,1.255300E-06,2.860000E-06,& + & 8.184200E-06,3.420300E-05,5.429900E-04,3.276300E-03,7.621300E-03,& + & 1.816200E-02,4.622300E-02,6.049600E-01,2.720300E+01,2.212100E+02,& + & 1.577000E-07,8.389500E-07,5.064400E-06,4.148300E-05,2.687700E-04,& + & 1.045000E-03,4.046800E-03,2.184500E-02,3.112700E-01,2.204700E+00,& + & 5.087100E+00,1.394100E+01,5.619600E+01,5.259600E+02,6.030300E+03,& + & 1.860900E+04,3.873500E-07,1.411600E-06,6.654100E-06,4.344200E-05,& + & 2.335000E-04,8.636200E-04,3.290300E-03,1.767800E-02,2.567300E-01,& + & 1.827300E+00,4.228800E+00,1.133700E+01,4.375400E+01,3.948900E+02,& + & 4.522700E+03,1.395600E+04,4.107500E-07,1.424100E-06,6.059300E-06,& + & 3.451400E-05,1.682300E-04,6.071100E-04,2.294100E-03,1.228400E-02,& + & 1.771300E-01,1.267500E+00,2.976600E+00,8.215000E+00,3.147700E+01,& + & 2.671800E+02,3.015100E+03,9.304200E+03,3.640100E-07,1.216900E-06,& + & 4.666000E-06,2.233900E-05,9.443800E-05,3.295400E-04,1.228300E-03,& + & 6.549300E-03,9.323400E-02,6.649500E-01,1.577800E+00,4.489700E+00,& + & 1.795100E+01,1.434300E+02,1.507500E+03,4.652200E+03,1.068100E-07,& + & 2.395100E-07,4.332600E-07,8.214000E-07,1.600100E-06,3.620300E-06,& + & 1.051400E-05,4.440700E-05,7.535400E-04,4.562800E-03,9.965800E-03,& + & 2.320700E-02,6.256100E-02,9.919000E-01,3.511200E+01,2.788800E+02,& + & 2.136600E-07,1.296400E-06,8.278200E-06,6.380700E-05,3.685500E-04,& + & 1.440300E-03,5.805300E-03,3.249600E-02,4.594400E-01,3.245600E+00,& + & 7.332100E+00,2.031400E+01,8.180400E+01,7.063700E+02,7.293100E+03,& + & 2.201100E+04,5.260700E-07,2.095600E-06,1.030000E-05,6.426300E-05,& + & 3.177400E-04,1.192000E-03,4.734900E-03,2.628000E-02,3.794700E-01,& + & 2.681200E+00,6.054200E+00,1.639600E+01,6.321500E+01,5.300600E+02,& + & 5.469800E+03,1.650800E+04,5.576600E-07,2.072900E-06,9.095600E-06,& + & 5.003400E-05,2.279700E-04,8.371500E-04,3.301800E-03,1.823400E-02,& + & 2.622000E-01,1.861400E+00,4.283700E+00,1.191500E+01,4.500000E+01,& + & 3.577600E+02,3.646700E+03,1.100600E+04,4.889900E-07,1.724700E-06,& + & 6.787900E-06,3.150400E-05,1.274200E-04,4.531100E-04,1.768500E-03,& + & 9.701800E-03,1.381800E-01,9.762300E-01,2.279000E+00,6.582500E+00,& + & 2.551200E+01,1.903900E+02,1.823300E+03,5.502500E+03,1.293600E-07,& + & 2.920800E-07,5.401700E-07,1.005700E-06,1.985500E-06,4.486400E-06,& + & 1.324400E-05,5.677300E-05,1.012300E-03,6.107000E-03,1.305500E-02,& + & 2.897400E-02,8.493600E-02,1.553900E+00,4.423900E+01,3.424400E+02,& + & 7.269000E-08,2.138700E-07,7.203000E-07,5.516100E-06,5.504400E-05,& + & 2.368000E-04,8.920900E-04,4.251100E-03,6.280500E-02,4.427000E-01,& + & 1.133700E+00,3.188700E+00,1.183900E+01,1.435900E+02,2.625300E+03,& + & 8.792500E+03,1.324300E-07,3.247100E-07,1.084500E-06,6.934500E-06,& + & 5.069300E-05,1.952700E-04,7.227300E-04,3.449800E-03,5.137200E-02,& + & 3.731300E-01,9.560600E-01,2.669000E+00,9.501300E+00,1.083100E+02,& + & 1.969100E+03,6.594500E+03,1.363500E-07,3.263100E-07,1.067600E-06,& + & 5.971100E-06,3.789100E-05,1.376400E-04,5.034800E-04,2.409300E-03,& + & 3.533700E-02,2.580900E-01,6.647900E-01,1.904900E+00,7.034200E+00,& + & 7.435000E+01,1.312700E+03,4.396600E+03,1.195900E-07,2.855900E-07,& + & 9.061100E-07,4.263000E-06,2.226700E-05,7.549700E-05,2.695800E-04,& + & 1.293600E-03,1.862700E-02,1.353500E-01,3.494100E-01,1.017700E+00,& + & 3.999100E+00,4.151500E+01,6.567900E+02,2.198100E+03,3.942200E-08,& + & 7.999500E-08,1.376100E-07,2.709000E-07,5.142000E-07,1.178900E-06,& + & 3.245000E-06,1.385900E-05,1.879900E-04,1.137400E-03,2.831900E-03,& + & 7.979500E-03,2.227600E-02,1.511200E-01,1.271500E+01,1.126200E+02/ + data absb(:,881:900) / & + & 7.963400E-08,2.787300E-07,1.187200E-06,1.027400E-05,9.021500E-05,& + & 3.663400E-04,1.387700E-03,6.934700E-03,1.028200E-01,7.374900E-01,& + & 1.866100E+00,5.142500E+00,1.982000E+01,2.273600E+02,3.569200E+03,& + & 1.152900E+04,1.655600E-07,4.556900E-07,1.773000E-06,1.206700E-05,& + & 8.117000E-05,3.023300E-04,1.124300E-03,5.625400E-03,8.444000E-02,& + & 6.193500E-01,1.565300E+00,4.275400E+00,1.573700E+01,1.711500E+02,& + & 2.676900E+03,8.646800E+03,1.723500E-07,4.690200E-07,1.722800E-06,& + & 1.010100E-05,5.977000E-05,2.131300E-04,7.826100E-04,3.922600E-03,& + & 5.815000E-02,4.290600E-01,1.090200E+00,3.065700E+00,1.162000E+01,& + & 1.167000E+02,1.784600E+03,5.764400E+03,1.527000E-07,4.158400E-07,& + & 1.427100E-06,7.007500E-06,3.441300E-05,1.166100E-04,4.186300E-04,& + & 2.101900E-03,3.062400E-02,2.245300E-01,5.743200E-01,1.647600E+00,& + & 6.646400E+00,6.424200E+01,8.923100E+02,2.882400E+03,4.988200E-08,& + & 1.085600E-07,1.870600E-07,3.646800E-07,6.907500E-07,1.596300E-06,& + & 4.486700E-06,1.911700E-05,2.849700E-04,1.737900E-03,4.175800E-03,& + & 1.106400E-02,2.914800E-02,2.722800E-01,1.803000E+01,1.523200E+02,& + & 9.500200E-08,3.981000E-07,2.056100E-06,1.799900E-05,1.390700E-04,& + & 5.489500E-04,2.099100E-03,1.101800E-02,1.639700E-01,1.183900E+00,& + & 2.904500E+00,8.049700E+00,3.199400E+01,3.395500E+02,4.637500E+03,& + & 1.470200E+04,2.157000E-07,6.742500E-07,2.916100E-06,1.996400E-05,& + & 1.229200E-04,4.537200E-04,1.702000E-03,8.939000E-03,1.351600E-01,& + & 9.892800E-01,2.432100E+00,6.622500E+00,2.517400E+01,2.552700E+02,& + & 3.478200E+03,1.102700E+04,2.259200E-07,6.928700E-07,2.760900E-06,& + & 1.629100E-05,8.944700E-05,3.194400E-04,1.185200E-03,6.224200E-03,& + & 9.314800E-02,6.861300E-01,1.701200E+00,4.764200E+00,1.841700E+01,& + & 1.732600E+02,2.318800E+03,7.351300E+03,2.010200E-07,6.074000E-07,& + & 2.213500E-06,1.098200E-05,5.071600E-05,1.740200E-04,6.341600E-04,& + & 3.328400E-03,4.899400E-02,3.600200E-01,8.987000E-01,2.572200E+00,& + & 1.054000E+01,9.406400E+01,1.159500E+03,3.675500E+03,6.314800E-08,& + & 1.407300E-07,2.454400E-07,4.759300E-07,9.030700E-07,2.088800E-06,& + & 6.005200E-06,2.564800E-05,4.129600E-04,2.503200E-03,5.961700E-03,& + & 1.474300E-02,3.829700E-02,4.858700E-01,2.436400E+01,2.000900E+02,& + & 1.210500E-07,6.044800E-07,3.532700E-06,2.974800E-05,2.028200E-04,& + & 7.954300E-04,3.103000E-03,1.711300E-02,2.535300E-01,1.851200E+00,& + & 4.357000E+00,1.218300E+01,4.957200E+01,4.825700E+02,5.824400E+03,& + & 1.813900E+04,2.890700E-07,1.014300E-06,4.710200E-06,3.150200E-05,& + & 1.768800E-04,6.571700E-04,2.524600E-03,1.387000E-02,2.094800E-01,& + & 1.539500E+00,3.635700E+00,9.934900E+00,3.867500E+01,3.623600E+02,& + & 4.368300E+03,1.360400E+04,3.048200E-07,1.026500E-06,4.322300E-06,& + & 2.517300E-05,1.275300E-04,4.618100E-04,1.759500E-03,9.643900E-03,& + & 1.445400E-01,1.067700E+00,2.556500E+00,7.183800E+00,2.792300E+01,& + & 2.452100E+02,2.912000E+03,9.070000E+03,2.697600E-07,8.809700E-07,& + & 3.354000E-06,1.642400E-05,7.159300E-05,2.506200E-04,9.416600E-04,& + & 5.140100E-03,7.603000E-02,5.607500E-01,1.354600E+00,3.912200E+00,& + & 1.593600E+01,1.316500E+02,1.456000E+03,4.535000E+03,7.924200E-08,& + & 1.771200E-07,3.123100E-07,6.051000E-07,1.166500E-06,2.662100E-06,& + & 7.806400E-06,3.373600E-05,5.797000E-04,3.523800E-03,7.984000E-03,& + & 1.921100E-02,5.230000E-02,8.159800E-01,3.179200E+01,2.552800E+02,& + & 1.618000E-07,9.354200E-07,5.870100E-06,4.662700E-05,2.825200E-04,& + & 1.109900E-03,4.501200E-03,2.591900E-02,3.815100E-01,2.786200E+00,& + & 6.392200E+00,1.798400E+01,7.360000E+01,6.584100E+02,7.114100E+03,& + & 2.169600E+04,3.922400E-07,1.516600E-06,7.394300E-06,4.751900E-05,& + & 2.438200E-04,9.189000E-04,3.675200E-03,2.100500E-02,3.157800E-01,& + & 2.306500E+00,5.298000E+00,1.455500E+01,5.696600E+01,4.940800E+02,& + & 5.335600E+03,1.627200E+04,4.143700E-07,1.505200E-06,6.572900E-06,& + & 3.715900E-05,1.749200E-04,6.452000E-04,2.562700E-03,1.457500E-02,& + & 2.182300E-01,1.600900E+00,3.743200E+00,1.057300E+01,4.063800E+01,& + & 3.335100E+02,3.557000E+03,1.084600E+04,3.632200E-07,1.258700E-06,& + & 4.943200E-06,2.355600E-05,9.770200E-05,3.491700E-04,1.371600E-03,& + & 7.753900E-03,1.149900E-01,8.398100E-01,1.990400E+00,5.822000E+00,& + & 2.306800E+01,1.774400E+02,1.778500E+03,5.423600E+03,9.693600E-08,& + & 2.175800E-07,3.936400E-07,7.469700E-07,1.464900E-06,3.322600E-06,& + & 9.918800E-06,4.361700E-05,7.906200E-04,4.739800E-03,1.051900E-02,& + & 2.421400E-02,6.965000E-02,1.304300E+00,4.042400E+01,3.166600E+02/ + data absb(:,901:920) / & + & 6.177400E-08,1.698300E-07,5.246300E-07,3.671200E-06,3.858700E-05,& + & 1.716700E-04,6.505200E-04,3.109800E-03,4.767500E-02,3.382900E-01,& + & 8.921100E-01,2.586900E+00,9.747100E+00,1.220500E+02,2.404000E+03,& + & 8.253200E+03,1.040100E-07,2.462400E-07,7.640600E-07,4.708500E-06,& + & 3.579800E-05,1.415600E-04,5.274100E-04,2.527300E-03,3.903300E-02,& + & 2.848200E-01,7.578100E-01,2.174100E+00,7.858400E+00,9.210200E+01,& + & 1.803000E+03,6.189900E+03,1.060700E-07,2.404700E-07,7.478900E-07,& + & 4.082100E-06,2.687300E-05,9.969700E-05,3.673800E-04,1.764500E-03,& + & 2.687500E-02,1.969900E-01,5.267400E-01,1.548600E+00,5.826700E+00,& + & 6.333200E+01,1.202000E+03,4.126200E+03,9.139400E-08,2.074200E-07,& + & 6.322400E-07,2.934400E-06,1.589500E-05,5.462100E-05,1.966500E-04,& + & 9.470800E-04,1.416700E-02,1.033900E-01,2.769900E-01,8.260300E-01,& + & 3.302000E+00,3.543200E+01,6.015500E+02,2.063300E+03,2.923800E-08,& + & 5.587400E-08,9.426900E-08,1.890200E-07,3.628400E-07,8.217700E-07,& + & 2.292800E-06,9.937000E-06,1.359100E-04,8.186100E-04,2.058700E-03,& + & 6.233000E-03,1.819600E-02,1.159500E-01,1.086100E+01,9.915800E+01,& + & 6.536600E-08,2.131600E-07,8.273300E-07,6.980800E-06,6.497300E-05,& + & 2.697800E-04,1.029100E-03,5.178400E-03,7.968300E-02,5.820000E-01,& + & 1.520300E+00,4.274100E+00,1.670400E+01,1.989900E+02,3.340100E+03,& + & 1.092500E+04,1.273200E-07,3.339200E-07,1.232600E-06,8.357400E-06,& + & 5.878400E-05,2.227000E-04,8.337800E-04,4.206800E-03,6.554000E-02,& + & 4.906800E-01,1.281200E+00,3.570200E+00,1.330200E+01,1.498500E+02,& + & 2.505100E+03,8.193900E+03,1.315100E-07,3.393900E-07,1.200700E-06,& + & 7.049500E-06,4.340400E-05,1.568800E-04,5.803500E-04,2.933900E-03,& + & 4.512000E-02,3.401300E-01,8.920600E-01,2.559100E+00,9.837600E+00,& + & 1.022800E+02,1.670000E+03,5.462500E+03,1.152600E-07,2.985200E-07,& + & 1.000500E-06,4.915800E-06,2.511800E-05,8.577200E-05,3.102400E-04,& + & 1.572500E-03,2.375600E-02,1.781600E-01,4.697000E-01,1.374500E+00,& + & 5.616500E+00,5.639300E+01,8.351200E+02,2.731200E+03,3.607500E-08,& + & 7.737300E-08,1.309200E-07,2.586200E-07,4.934000E-07,1.133500E-06,& + & 3.214100E-06,1.398700E-05,2.095200E-04,1.263400E-03,3.107700E-03,& + & 8.678000E-03,2.455200E-02,2.117700E-01,1.577700E+01,1.355600E+02,& + & 7.541600E-08,2.940000E-07,1.417400E-06,1.253300E-05,1.024700E-04,& + & 4.103300E-04,1.581600E-03,8.394700E-03,1.296600E-01,9.636500E-01,& + & 2.434300E+00,6.848500E+00,2.753200E+01,3.042500E+02,4.412700E+03,& + & 1.409800E+04,1.632100E-07,4.857900E-07,2.034200E-06,1.412900E-05,& + & 9.096000E-05,3.391100E-04,1.283200E-03,6.822800E-03,1.070800E-01,& + & 8.085700E-01,2.041500E+00,5.667100E+00,2.170600E+01,2.287600E+02,& + & 3.309500E+03,1.057400E+04,1.696700E-07,4.980200E-07,1.937600E-06,& + & 1.159800E-05,6.635500E-05,2.385900E-04,8.929100E-04,4.753800E-03,& + & 7.380400E-02,5.608100E-01,1.426500E+00,4.078700E+00,1.592200E+01,& + & 1.553400E+02,2.206300E+03,7.049900E+03,1.498500E-07,4.368100E-07,& + & 1.565700E-06,7.874100E-06,3.772000E-05,1.299300E-04,4.768700E-04,& + & 2.541800E-03,3.883700E-02,2.941800E-01,7.529200E-01,2.199700E+00,& + & 9.111200E+00,8.441500E+01,1.103100E+03,3.525000E+03,4.628600E-08,& + & 1.017300E-07,1.746000E-07,3.416400E-07,6.525100E-07,1.502200E-06,& + & 4.360800E-06,1.908500E-05,3.099100E-04,1.879500E-03,4.506200E-03,& + & 1.193500E-02,3.185900E-02,3.874900E-01,2.169300E+01,1.801500E+02,& + & 9.386300E-08,4.377700E-07,2.455200E-06,2.119900E-05,1.524100E-04,& + & 6.028900E-04,2.368700E-03,1.329300E-02,2.050600E-01,1.545700E+00,& + & 3.720500E+00,1.062300E+01,4.351600E+01,4.410400E+02,5.611500E+03,& + & 1.762800E+04,2.165600E-07,7.286700E-07,3.322100E-06,2.272500E-05,& + & 1.333400E-04,4.987000E-04,1.927300E-03,1.079900E-02,1.698000E-01,& + & 1.289400E+00,3.114200E+00,8.688000E+00,3.401700E+01,3.312200E+02,& + & 4.208700E+03,1.322100E+04,2.268200E-07,7.391200E-07,3.070200E-06,& + & 1.825300E-05,9.628300E-05,3.504000E-04,1.342200E-03,7.511300E-03,& + & 1.171400E-01,8.945800E-01,2.186800E+00,6.273300E+00,2.464500E+01,& + & 2.241300E+02,2.805800E+03,8.813900E+03,2.001800E-07,6.363200E-07,& + & 2.400400E-06,1.200800E-05,5.413100E-05,1.900100E-04,7.173700E-04,& + & 4.005800E-03,6.162800E-02,4.697300E-01,1.158500E+00,3.405400E+00,& + & 1.407100E+01,1.203600E+02,1.403000E+03,4.407100E+03,5.826100E-08,& + & 1.296600E-07,2.255300E-07,4.389500E-07,8.417600E-07,1.942100E-06,& + & 5.739000E-06,2.545100E-05,4.409500E-04,2.710400E-03,6.137700E-03,& + & 1.578000E-02,4.236800E-02,6.695000E-01,2.865900E+01,2.325800E+02/ + data absb(:,921:940) / & + & 1.233400E-07,6.752200E-07,4.142300E-06,3.389300E-05,2.158500E-04,& + & 8.526800E-04,3.476500E-03,2.052100E-02,3.151500E-01,2.381200E+00,& + & 5.556400E+00,1.591400E+01,6.591300E+01,6.118200E+02,6.927400E+03,& + & 2.133400E+04,2.928500E-07,1.095300E-06,5.285100E-06,3.494500E-05,& + & 1.866100E-04,7.061200E-04,2.840300E-03,1.666800E-02,2.614700E-01,& + & 1.975500E+00,4.624300E+00,1.290600E+01,5.109400E+01,4.591400E+02,& + & 5.195600E+03,1.600000E+04,3.080700E-07,1.090500E-06,4.730500E-06,& + & 2.746100E-05,1.338700E-04,4.955900E-04,1.979700E-03,1.157400E-02,& + & 1.807400E-01,1.370800E+00,3.263800E+00,9.365100E+00,3.654000E+01,& + & 3.098700E+02,3.463600E+03,1.066800E+04,2.698600E-07,9.160000E-07,& + & 3.584000E-06,1.752900E-05,7.476200E-05,2.680800E-04,1.058000E-03,& + & 6.152200E-03,9.522600E-02,7.192500E-01,1.734600E+00,5.139200E+00,& + & 2.076200E+01,1.648000E+02,1.731800E+03,5.333800E+03,7.184300E-08,& + & 1.604200E-07,2.842400E-07,5.498500E-07,1.068800E-06,2.446400E-06,& + & 7.361600E-06,3.336300E-05,6.082000E-04,3.610500E-03,8.387900E-03,& + & 2.041500E-02,5.795600E-02,1.087200E+00,3.680800E+01,2.887700E+02,& + & 5.320600E-08,1.374800E-07,3.965900E-07,2.483500E-06,2.720400E-05,& + & 1.253100E-04,4.788900E-04,2.291800E-03,3.654800E-02,2.599800E-01,& + & 6.994400E-01,2.109800E+00,8.080400E+00,1.041000E+02,2.203000E+03,& + & 7.788600E+03,8.310300E-08,1.910500E-07,5.517800E-07,3.229900E-06,& + & 2.541200E-05,1.033300E-04,3.879800E-04,1.863600E-03,2.994300E-02,& + & 2.196200E-01,5.973000E-01,1.780400E+00,6.544200E+00,7.860100E+01,& + & 1.652300E+03,5.841400E+03,8.362600E-08,1.807400E-07,5.344000E-07,& + & 2.816800E-06,1.914600E-05,7.275400E-05,2.700900E-04,1.300800E-03,& + & 2.061000E-02,1.518800E-01,4.154400E-01,1.266300E+00,4.852800E+00,& + & 5.413400E+01,1.101500E+03,3.894300E+03,7.104200E-08,1.529400E-07,& + & 4.472200E-07,2.035800E-06,1.139700E-05,3.978100E-05,1.444800E-04,& + & 6.978900E-04,1.086500E-02,7.950600E-02,2.189200E-01,6.742600E-01,& + & 2.747100E+00,3.032000E+01,5.513700E+02,1.947100E+03,2.041800E-08,& + & 4.073400E-08,6.593000E-08,1.334200E-07,2.575300E-07,5.826000E-07,& + & 1.635600E-06,7.197900E-06,9.991700E-05,6.036300E-04,1.515900E-03,& + & 4.850900E-03,1.548000E-02,8.943700E-02,9.281300E+00,8.756200E+01,& + & 5.459900E-08,1.668500E-07,5.921000E-07,4.789500E-06,4.700900E-05,& + & 2.002800E-04,7.695600E-04,3.891300E-03,6.227900E-02,4.597400E-01,& + & 1.238600E+00,3.576400E+00,1.420800E+01,1.747600E+02,3.129700E+03,& + & 1.039900E+04,9.931400E-08,2.502700E-07,8.714000E-07,5.833800E-06,& + & 4.277800E-05,1.652000E-04,6.238500E-04,3.167000E-03,5.120900E-02,& + & 3.894000E-01,1.049500E+00,2.999900E+00,1.134300E+01,1.316600E+02,& + & 2.347300E+03,7.799600E+03,1.017100E-07,2.497100E-07,8.480300E-07,& + & 4.951600E-06,3.168900E-05,1.162500E-04,4.339600E-04,2.208900E-03,& + & 3.525400E-02,2.698200E-01,7.310500E-01,2.148700E+00,8.391600E+00,& + & 8.994300E+01,1.564900E+03,5.199500E+03,8.807400E-08,2.171200E-07,& + & 7.081700E-07,3.472100E-06,1.841600E-05,6.351700E-05,2.317000E-04,& + & 1.184200E-03,1.856600E-02,1.415500E-01,3.849300E-01,1.152900E+00,& + & 4.779300E+00,4.964700E+01,7.826500E+02,2.600000E+03,2.666900E-08,& + & 5.554100E-08,9.356200E-08,1.847500E-07,3.566800E-07,8.131200E-07,& + & 2.329900E-06,1.033100E-05,1.565300E-04,9.502300E-04,2.363900E-03,& + & 6.966500E-03,2.110800E-02,1.648700E-01,1.381800E+01,1.209900E+02,& + & 6.098100E-08,2.220500E-07,9.939600E-07,8.793300E-06,7.592300E-05,& + & 3.088100E-04,1.199800E-03,6.439000E-03,1.031800E-01,7.857800E-01,& + & 2.047500E+00,5.861900E+00,2.386500E+01,2.736300E+02,4.208100E+03,& + & 1.355400E+04,1.251500E-07,3.558000E-07,1.434500E-06,1.006200E-05,& + & 6.768000E-05,2.552400E-04,9.738500E-04,5.244100E-03,8.533200E-02,& + & 6.618900E-01,1.723300E+00,4.874600E+00,1.884500E+01,2.057800E+02,& + & 3.156100E+03,1.016500E+04,1.291700E-07,3.624100E-07,1.372200E-06,& + & 8.307700E-06,4.945900E-05,1.795500E-04,6.771400E-04,3.653100E-03,& + & 5.880800E-02,4.593100E-01,1.203000E+00,3.509400E+00,1.385600E+01,& + & 1.397700E+02,2.104100E+03,6.776900E+03,1.130500E-07,3.170900E-07,& + & 1.116000E-06,5.672200E-06,2.818800E-05,9.776500E-05,3.613800E-04,& + & 1.953800E-03,3.096200E-02,2.409100E-01,6.344300E-01,1.893400E+00,& + & 7.917300E+00,7.599800E+01,1.051900E+03,3.388200E+03,3.417100E-08,& + & 7.408800E-08,1.261900E-07,2.476100E-07,4.763000E-07,1.096300E-06,& + & 3.200700E-06,1.434400E-05,2.370300E-04,1.436600E-03,3.512900E-03,& + & 9.733600E-03,2.807000E-02,3.088000E-01,1.934100E+01,1.625700E+02/ + data absb(:,941:960) / & + & 7.399200E-08,3.226500E-07,1.725800E-06,1.520200E-05,1.151600E-04,& + & 4.601500E-04,1.822200E-03,1.039700E-02,1.668800E-01,1.293000E+00,& + & 3.198700E+00,9.312800E+00,3.843900E+01,4.047000E+02,5.421400E+03,& + & 1.715800E+04,1.641600E-07,5.295300E-07,2.362400E-06,1.650300E-05,& + & 1.010700E-04,3.806100E-04,1.483300E-03,8.464900E-03,1.383900E-01,& + & 1.082900E+00,2.683800E+00,7.648800E+00,3.008400E+01,3.039800E+02,& + & 4.066000E+03,1.286900E+04,1.706600E-07,5.372300E-07,2.197300E-06,& + & 1.330500E-05,7.308900E-05,2.673100E-04,1.032000E-03,5.889200E-03,& + & 9.548700E-02,7.514700E-01,1.882800E+00,5.516300E+00,2.186100E+01,& + & 2.056900E+02,2.710700E+03,8.579100E+03,1.499500E-07,4.632300E-07,& + & 1.729200E-06,8.816800E-06,4.112900E-05,1.448800E-04,5.507000E-04,& + & 3.142300E-03,5.023600E-02,3.945000E-01,9.972100E-01,2.988100E+00,& + & 1.248400E+01,1.104500E+02,1.355300E+03,4.288900E+03,4.310000E-08,& + & 9.583000E-08,1.644400E-07,3.224000E-07,6.173600E-07,1.434000E-06,& + & 4.263200E-06,1.939700E-05,3.417100E-04,2.125000E-03,4.913100E-03,& + & 1.312400E-02,3.671600E-02,5.471100E-01,2.590200E+01,2.121500E+02,& + & 9.540100E-08,4.935500E-07,2.948000E-06,2.480000E-05,1.656800E-04,& + & 6.598800E-04,2.706400E-03,1.637100E-02,2.618500E-01,2.041800E+00,& + & 4.861300E+00,1.421000E+01,5.931100E+01,5.705900E+02,6.764100E+03,& + & 2.101100E+04,2.207400E-07,7.977700E-07,3.805200E-06,2.582800E-05,& + & 1.436400E-04,5.463600E-04,2.211300E-03,1.331700E-02,2.176700E-01,& + & 1.699000E+00,4.060400E+00,1.154300E+01,4.604000E+01,4.282300E+02,& + & 5.073100E+03,1.575800E+04,2.310600E-07,7.961700E-07,3.427000E-06,& + & 2.039700E-05,1.030700E-04,3.832000E-04,1.540500E-03,9.250400E-03,& + & 1.504500E-01,1.179000E+00,2.863800E+00,8.363500E+00,3.300700E+01,& + & 2.890000E+02,3.382100E+03,1.050500E+04,2.020000E-07,6.711100E-07,& + & 2.613100E-06,1.309300E-05,5.755600E-05,2.070900E-04,8.223400E-04,& + & 4.918500E-03,7.926300E-02,6.188000E-01,1.521600E+00,4.572700E+00,& + & 1.876500E+01,1.536300E+02,1.691000E+03,5.253100E+03,5.367900E-08,& + & 1.200000E-07,2.085500E-07,4.081400E-07,7.881100E-07,1.820200E-06,& + & 5.527300E-06,2.574100E-05,4.761700E-04,2.871600E-03,6.810200E-03,& + & 1.735200E-02,4.798200E-02,9.113500E-01,3.360200E+01,2.688500E+02,& + & 4.628200E-08,1.131000E-07,3.078000E-07,1.701100E-06,1.913200E-05,& + & 9.163300E-05,3.534400E-04,1.692800E-03,2.795200E-02,2.013200E-01,& + & 5.432400E-01,1.715300E+00,6.697400E+00,8.859100E+01,2.012800E+03,& + & 7.365300E+03,6.715100E-08,1.509500E-07,4.072400E-07,2.225600E-06,& + & 1.802200E-05,7.550900E-05,2.863500E-04,1.376700E-03,2.296900E-02,& + & 1.691000E-01,4.672500E-01,1.455100E+00,5.450600E+00,6.691800E+01,& + & 1.509600E+03,5.524000E+03,6.643600E-08,1.387300E-07,3.877200E-07,& + & 1.950400E-06,1.362000E-05,5.312800E-05,1.991200E-04,9.602300E-04,& + & 1.581100E-02,1.167400E-01,3.254600E-01,1.034100E+00,4.040100E+00,& + & 4.616100E+01,1.006400E+03,3.682700E+03,5.611700E-08,1.141600E-07,& + & 3.190900E-07,1.415400E-06,8.158500E-06,2.902000E-05,1.063600E-04,& + & 5.138200E-04,8.341700E-03,6.110700E-02,1.717200E-01,5.498100E-01,& + & 2.283500E+00,2.588100E+01,5.039000E+02,1.841200E+03,1.431000E-08,& + & 2.893000E-08,4.715200E-08,9.490000E-08,1.825100E-07,4.146400E-07,& + & 1.168000E-06,5.224600E-06,7.467100E-05,4.448500E-04,1.129700E-03,& + & 3.801100E-03,1.289700E-02,7.082500E-02,7.892700E+00,7.723100E+01,& + & 4.629300E-08,1.329700E-07,4.338900E-07,3.295300E-06,3.401500E-05,& + & 1.489100E-04,5.763100E-04,2.927200E-03,4.881700E-02,3.604100E-01,& + & 1.005400E+00,2.996900E+00,1.210500E+01,1.531500E+02,2.927600E+03,& + & 9.918900E+03,7.846400E-08,1.910400E-07,6.237600E-07,4.079000E-06,& + & 3.110400E-05,1.227000E-04,4.673800E-04,2.383900E-03,4.017100E-02,& + & 3.065600E-01,8.563200E-01,2.523100E+00,9.689400E+00,1.154200E+02,& + & 2.195700E+03,7.439200E+03,7.961100E-08,1.860300E-07,6.044200E-07,& + & 3.479400E-06,2.311200E-05,8.627900E-05,3.250200E-04,1.662800E-03,& + & 2.764100E-02,2.128200E-01,5.962300E-01,1.805400E+00,7.174200E+00,& + & 7.891400E+01,1.463800E+03,4.959400E+03,6.795200E-08,1.594400E-07,& + & 5.038700E-07,2.453700E-06,1.349300E-05,4.709900E-05,1.733200E-04,& + & 8.910300E-04,1.455500E-02,1.116100E-01,3.142600E-01,9.676500E-01,& + & 4.072900E+00,4.361100E+01,7.320600E+02,2.466000E+03,2.031300E-08,& + & 3.964900E-08,6.684800E-08,1.327300E-07,2.574200E-07,5.880700E-07,& + & 1.690200E-06,7.638800E-06,1.181400E-04,7.315700E-04,1.784400E-03,& + & 5.553900E-03,1.823400E-02,1.280800E-01,1.204600E+01,1.079800E+02/ + data absb(:,961:980) / & + & 5.008400E-08,1.708900E-07,7.057800E-07,6.174600E-06,5.625100E-05,& + & 2.329200E-04,9.114200E-04,4.942900E-03,8.250800E-02,6.358200E-01,& + & 1.718000E+00,5.026500E+00,2.072600E+01,2.459100E+02,4.009800E+03,& + & 1.304700E+04,9.703600E-08,2.638700E-07,1.018300E-06,7.168900E-06,& + & 5.035100E-05,1.924900E-04,7.398200E-04,4.031900E-03,6.821900E-02,& + & 5.386900E-01,1.452300E+00,4.197200E+00,1.639200E+01,1.849700E+02,& + & 3.007300E+03,9.785200E+03,9.928800E-08,2.660900E-07,9.766100E-07,& + & 5.954400E-06,3.686400E-05,1.352900E-04,5.142400E-04,2.808700E-03,& + & 4.698300E-02,3.742300E-01,1.013600E+00,3.020500E+00,1.207600E+01,& + & 1.256700E+02,2.004900E+03,6.523500E+03,8.602300E-08,2.314200E-07,& + & 7.977300E-07,4.083200E-06,2.108200E-05,7.364600E-05,2.741000E-04,& + & 1.502000E-03,2.470700E-02,1.965600E-01,5.345600E-01,1.629400E+00,& + & 6.885600E+00,6.839100E+01,1.002500E+03,3.261500E+03,2.513700E-08,& + & 5.411800E-08,9.167300E-08,1.801400E-07,3.485300E-07,8.037100E-07,& + & 2.354300E-06,1.078100E-05,1.809600E-04,1.122500E-03,2.728800E-03,& + & 8.031800E-03,2.429700E-02,2.463300E-01,1.720400E+01,1.465600E+02,& + & 5.907100E-08,2.412100E-07,1.220200E-06,1.091200E-05,8.711700E-05,& + & 3.523300E-04,1.404500E-03,8.136400E-03,1.358800E-01,1.080200E+00,& + & 2.756000E+00,8.164100E+00,3.401000E+01,3.712500E+02,5.239900E+03,& + & 1.670200E+04,1.255300E-07,3.878200E-07,1.685700E-06,1.199300E-05,& + & 7.668600E-05,2.912300E-04,1.143700E-03,6.638900E-03,1.128500E-01,& + & 9.077700E-01,2.317800E+00,6.734200E+00,2.664600E+01,2.788900E+02,& + & 3.929900E+03,1.252700E+04,1.294800E-07,3.926200E-07,1.576200E-06,& + & 9.704600E-06,5.552600E-05,2.043300E-04,7.954400E-04,4.618800E-03,& + & 7.785900E-02,6.303000E-01,1.624400E+00,4.859300E+00,1.940200E+01,& + & 1.887100E+02,2.620000E+03,8.351000E+03,1.130000E-07,3.386000E-07,& + & 1.248100E-06,6.475400E-06,3.129600E-05,1.107200E-04,4.239500E-04,& + & 2.465400E-03,4.097000E-02,3.307400E-01,8.601100E-01,2.628400E+00,& + & 1.107700E+01,1.013300E+02,1.310000E+03,4.175200E+03,3.203600E-08,& + & 7.092000E-08,1.208000E-07,2.377700E-07,4.561400E-07,1.061500E-06,& + & 3.172900E-06,1.482700E-05,2.675400E-04,1.653100E-03,3.914700E-03,& + & 1.098700E-02,3.144700E-02,4.464400E-01,2.338700E+01,1.932800E+02,& + & 7.464000E-08,3.639100E-07,2.105000E-06,1.817300E-05,1.274200E-04,& + & 5.116600E-04,2.113100E-03,1.306800E-02,2.177600E-01,1.749800E+00,& + & 4.263600E+00,1.273100E+01,5.341400E+01,5.323200E+02,6.610100E+03,& + & 2.069300E+04,1.674700E-07,5.837000E-07,2.746300E-06,1.909700E-05,& + & 1.107500E-04,4.236800E-04,1.726800E-03,1.065600E-02,1.813100E-01,& + & 1.460200E+00,3.572500E+00,1.036400E+01,4.150800E+01,3.995300E+02,& + & 4.957500E+03,1.552000E+04,1.742300E-07,5.833100E-07,2.487800E-06,& + & 1.514400E-05,7.949000E-05,2.969700E-04,1.202300E-03,7.402000E-03,& + & 1.253200E-01,1.013500E+00,2.517600E+00,7.496600E+00,2.982500E+01,& + & 2.695900E+02,3.305000E+03,1.034700E+04,1.517000E-07,4.930400E-07,& + & 1.907800E-06,9.786700E-06,4.438600E-05,1.603800E-04,6.409000E-04,& + & 3.937200E-03,6.599900E-02,5.321900E-01,1.337600E+00,4.084200E+00,& + & 1.696500E+01,1.432400E+02,1.652500E+03,5.173400E+03,4.021700E-08,& + & 8.964300E-08,1.548800E-07,3.033400E-07,5.832400E-07,1.362300E-06,& + & 4.162000E-06,1.992100E-05,3.785600E-04,2.317200E-03,5.460100E-03,& + & 1.478400E-02,4.165900E-02,7.609800E-01,3.065400E+01,2.476000E+02,& + & 4.062900E-08,9.443200E-08,2.446700E-07,1.177900E-06,1.334300E-05,& + & 6.674800E-05,2.593300E-04,1.239900E-03,2.119900E-02,1.554700E-01,& + & 4.165900E-01,1.382900E+00,5.513900E+00,7.483200E+01,1.827200E+03,& + & 6.956200E+03,5.487500E-08,1.210000E-07,3.067200E-07,1.538100E-06,& + & 1.268000E-05,5.495100E-05,2.102000E-04,1.009100E-03,1.745900E-02,& + & 1.305200E-01,3.601200E-01,1.179300E+00,4.509900E+00,5.655100E+01,& + & 1.370400E+03,5.217200E+03,5.334600E-08,1.083000E-07,2.854000E-07,& + & 1.349700E-06,9.620500E-06,3.863700E-05,1.460800E-04,7.035700E-04,& + & 1.202500E-02,9.006100E-02,2.510200E-01,8.369200E-01,3.345200E+00,& + & 3.907200E+01,9.137300E+02,3.477800E+03,4.494000E-08,8.617300E-08,& + & 2.292700E-07,9.815800E-07,5.793700E-06,2.107200E-05,7.795100E-05,& + & 3.765000E-04,6.345200E-03,4.707500E-02,1.327000E-01,4.448900E-01,& + & 1.885900E+00,2.192100E+01,4.576100E+02,1.738900E+03,9.909500E-09,& + & 2.045400E-08,3.376600E-08,6.630500E-08,1.275700E-07,2.942300E-07,& + & 8.275900E-07,3.752200E-06,5.510700E-05,3.316000E-04,8.377500E-04,& + & 2.911100E-03,1.083900E-02,5.856800E-02,6.642800E+00,6.776200E+01/ + data absb(:, 981:1000) / & + & 3.981000E-08,1.075400E-07,3.257700E-07,2.262300E-06,2.445700E-05,& + & 1.103400E-04,4.307000E-04,2.189900E-03,3.808800E-02,2.834700E-01,& + & 8.045100E-01,2.500100E+00,1.026500E+01,1.334000E+02,2.725600E+03,& + & 9.456300E+03,6.275300E-08,1.481600E-07,4.513900E-07,2.841200E-06,& + & 2.248900E-05,9.089800E-05,3.491700E-04,1.782900E-03,3.135400E-02,& + & 2.404900E-01,6.907400E-01,2.114000E+00,8.239200E+00,1.005600E+02,& + & 2.044200E+03,7.092200E+03,6.277900E-08,1.403100E-07,4.338200E-07,& + & 2.434200E-06,1.676200E-05,6.380400E-05,2.425700E-04,1.243000E-03,& + & 2.157100E-02,1.666600E-01,4.814800E-01,1.511000E+00,6.106600E+00,& + & 6.880400E+01,1.362700E+03,4.728400E+03,5.304500E-08,1.178400E-07,& + & 3.590600E-07,1.726600E-06,9.834200E-06,3.477300E-05,1.291900E-04,& + & 6.657900E-04,1.135300E-02,8.743300E-02,2.540400E-01,8.082400E-01,& + & 3.459400E+00,3.804800E+01,6.816700E+02,2.364200E+03,1.435500E-08,& + & 2.888400E-08,4.740900E-08,9.486500E-08,1.842700E-07,4.218500E-07,& + & 1.216500E-06,5.610000E-06,8.806900E-05,5.507800E-04,1.342400E-03,& + & 4.428500E-03,1.530700E-02,9.973700E-02,1.040900E+01,9.603400E+01,& + & 4.174900E-08,1.336500E-07,5.067200E-07,4.317000E-06,4.149000E-05,& + & 1.752500E-04,6.904800E-04,3.766500E-03,6.561900E-02,5.118400E-01,& + & 1.430300E+00,4.299300E+00,1.796900E+01,2.200000E+02,3.809800E+03,& + & 1.254400E+04,7.593500E-08,1.980300E-07,7.255500E-07,5.085400E-06,& + & 3.727200E-05,1.447200E-04,5.607900E-04,3.079500E-03,5.432100E-02,& + & 4.350100E-01,1.214600E+00,3.603800E+00,1.423100E+01,1.655300E+02,& + & 2.857300E+03,9.408100E+03,7.694500E-08,1.966400E-07,6.959500E-07,& + & 4.246800E-06,2.734700E-05,1.016100E-04,3.896200E-04,2.144700E-03,& + & 3.741600E-02,3.021100E-01,8.478300E-01,2.592000E+00,1.049200E+01,& + & 1.125100E+02,1.904900E+03,6.272100E+03,6.593200E-08,1.692500E-07,& + & 5.700100E-07,2.926000E-06,1.569700E-05,5.527700E-05,2.073300E-04,& + & 1.146400E-03,1.969200E-02,1.586800E-01,4.473000E-01,1.397200E+00,& + & 5.970200E+00,6.125100E+01,9.524000E+02,3.135800E+03,1.854700E-08,& + & 3.931400E-08,6.599100E-08,1.302600E-07,2.531100E-07,5.838600E-07,& + & 1.720800E-06,8.063200E-06,1.368000E-04,8.700800E-04,2.096100E-03,& + & 6.498800E-03,2.078200E-02,1.957300E-01,1.520500E+01,1.316300E+02,& + & 4.773400E-08,1.825600E-07,8.651600E-07,7.796900E-06,6.569800E-05,& + & 2.689600E-04,1.078500E-03,6.326100E-03,1.101800E-01,8.969700E-01,& + & 2.366100E+00,7.136200E+00,3.002200E+01,3.394400E+02,5.057500E+03,& + & 1.622800E+04,9.667200E-08,2.856500E-07,1.201800E-06,8.677200E-06,& + & 5.801900E-05,2.224600E-04,8.781500E-04,5.172900E-03,9.159300E-02,& + & 7.569000E-01,1.996800E+00,5.909300E+00,2.353900E+01,2.550300E+02,& + & 3.793100E+03,1.217100E+04,9.892700E-08,2.876700E-07,1.128900E-06,& + & 7.053100E-06,4.206700E-05,1.559800E-04,6.103900E-04,3.599400E-03,& + & 6.319100E-02,5.256100E-01,1.398500E+00,4.265400E+00,1.717300E+01,& + & 1.725600E+02,2.528800E+03,8.113900E+03,8.555900E-08,2.475700E-07,& + & 8.988400E-07,4.733300E-06,2.374100E-05,8.449700E-05,3.249100E-04,& + & 1.922400E-03,3.325400E-02,2.757600E-01,7.398400E-01,2.307600E+00,& + & 9.794200E+00,9.262100E+01,1.264300E+03,4.056300E+03,2.378800E-08,& + & 5.155200E-08,8.864600E-08,1.738400E-07,3.345400E-07,7.802900E-07,& + & 2.347400E-06,1.126500E-05,2.064100E-04,1.267200E-03,3.091200E-03,& + & 9.077700E-03,2.761500E-02,3.616700E-01,2.100800E+01,1.754400E+02,& + & 5.900200E-08,2.700600E-07,1.501100E-06,1.326100E-05,9.776900E-05,& + & 3.963800E-04,1.644900E-03,1.036300E-02,1.803900E-01,1.492700E+00,& + & 3.736400E+00,1.138800E+01,4.797600E+01,4.956300E+02,6.454400E+03,& + & 2.021400E+04,1.276300E-07,4.278200E-07,1.977700E-06,1.407500E-05,& + & 8.519900E-05,3.281400E-04,1.344800E-03,8.471000E-03,1.504400E-01,& + & 1.249300E+00,3.139300E+00,9.294900E+00,3.731100E+01,3.720100E+02,& + & 4.840800E+03,1.526600E+04,1.318600E-07,4.275000E-07,1.801200E-06,& + & 1.120300E-05,6.120000E-05,2.297800E-04,9.358500E-04,5.884200E-03,& + & 1.039800E-01,8.674100E-01,2.210100E+00,6.711300E+00,2.686800E+01,& + & 2.509900E+02,3.227200E+03,1.017700E+04,1.142300E-07,3.618700E-07,& + & 1.389000E-06,7.283700E-06,3.418400E-05,1.239700E-04,4.983000E-04,& + & 3.130200E-03,5.476200E-02,4.555100E-01,1.173800E+00,3.647500E+00,& + & 1.528400E+01,1.332600E+02,1.613500E+03,5.089700E+03,2.993200E-08,& + & 6.623900E-08,1.141100E-07,2.248500E-07,4.307400E-07,1.011400E-06,& + & 3.117700E-06,1.537000E-05,2.976600E-04,1.845800E-03,4.323000E-03,& + & 1.258400E-02,3.588300E-02,6.320900E-01,2.786300E+01,2.271400E+02/ + data absb(:,1001:1020) / & + & 3.597500E-08,7.993900E-08,1.989300E-07,8.308900E-07,9.228600E-06,& + & 4.838700E-05,1.889300E-04,9.021600E-04,1.591700E-02,1.200300E-01,& + & 3.178400E-01,1.099600E+00,4.508900E+00,6.265500E+01,1.645500E+03,& + & 6.570700E+03,4.539900E-08,9.827200E-08,2.365500E-07,1.068700E-06,& + & 8.843800E-06,3.978900E-05,1.532400E-04,7.340800E-04,1.312400E-02,& + & 1.005100E-01,2.747000E-01,9.444800E-01,3.705000E+00,4.737800E+01,& + & 1.234100E+03,4.889600E+03,4.277100E-08,8.630700E-08,2.139800E-07,& + & 9.351800E-07,6.739400E-06,2.795600E-05,1.064300E-04,5.116400E-04,& + & 9.046900E-03,6.926800E-02,1.911200E-01,6.699900E-01,2.748600E+00,& + & 3.278600E+01,8.227500E+02,3.285400E+03,3.620000E-08,6.601200E-08,& + & 1.665000E-07,6.799700E-07,4.079600E-06,1.522400E-05,5.676500E-05,& + & 2.734000E-04,4.772800E-03,3.624800E-02,1.009900E-01,3.561800E-01,& + & 1.544900E+00,1.840200E+01,4.121800E+02,1.642800E+03,6.763500E-09,& + & 1.460400E-08,2.369700E-08,4.583100E-08,8.799000E-08,2.071000E-07,& + & 5.801200E-07,2.659000E-06,4.022700E-05,2.445700E-04,6.010000E-04,& + & 2.175200E-03,8.898800E-03,5.032400E-02,5.529200E+00,5.908600E+01,& + & 3.467200E-08,8.827900E-08,2.508300E-07,1.555600E-06,1.746200E-05,& + & 8.142200E-05,3.203000E-04,1.626200E-03,2.945300E-02,2.212000E-01,& + & 6.373300E-01,2.071400E+00,8.659500E+00,1.153300E+02,2.522500E+03,& + & 9.017800E+03,5.077600E-08,1.167300E-07,3.315900E-07,1.971100E-06,& + & 1.614500E-05,6.705500E-05,2.597700E-04,1.327000E-03,2.429500E-02,& + & 1.875400E-01,5.504300E-01,1.759800E+00,6.970100E+00,8.696100E+01,& + & 1.891900E+03,6.763300E+03,4.976300E-08,1.075800E-07,3.142200E-07,& + & 1.696600E-06,1.207100E-05,4.703400E-05,1.803300E-04,9.242500E-04,& + & 1.672800E-02,1.298900E-01,3.837600E-01,1.256700E+00,5.164600E+00,& + & 5.956200E+01,1.261300E+03,4.508800E+03,4.177800E-08,8.793700E-08,& + & 2.568000E-07,1.208300E-06,7.120400E-06,2.556900E-05,9.598800E-05,& + & 4.942500E-04,8.806400E-03,6.822600E-02,2.026300E-01,6.710500E-01,& + & 2.921700E+00,3.294700E+01,6.310200E+02,2.254400E+03,1.000100E-08,& + & 2.045100E-08,3.379200E-08,6.749700E-08,1.300400E-07,3.003200E-07,& + & 8.679000E-07,4.081000E-06,6.542800E-05,4.079100E-04,1.015200E-03,& + & 3.416400E-03,1.292800E-02,7.655500E-02,8.919900E+00,8.497300E+01,& + & 3.532500E-08,1.062300E-07,3.692500E-07,3.004800E-06,3.039700E-05,& + & 1.314300E-04,5.213300E-04,2.851300E-03,5.202000E-02,4.069400E-01,& + & 1.181000E+00,3.665300E+00,1.553900E+01,1.956500E+02,3.605400E+03,& + & 1.206300E+04,6.002000E-08,1.507800E-07,5.196300E-07,3.590800E-06,& + & 2.743600E-05,1.084600E-04,4.230300E-04,2.332700E-03,4.305800E-02,& + & 3.477500E-01,1.007700E+00,3.082700E+00,1.232400E+01,1.472500E+02,& + & 2.704200E+03,9.047600E+03,6.015600E-08,1.465400E-07,4.971000E-07,& + & 3.013100E-06,2.017700E-05,7.609200E-05,2.935900E-04,1.623700E-03,& + & 2.965300E-02,2.417600E-01,7.033300E-01,2.214800E+00,9.085600E+00,& + & 1.001400E+02,1.802800E+03,6.031700E+03,5.099800E-08,1.242500E-07,& + & 4.070500E-07,2.084400E-06,1.162600E-05,4.132500E-05,1.560400E-04,& + & 8.678900E-04,1.559900E-02,1.271200E-01,3.711800E-01,1.192600E+00,& + & 5.156900E+00,5.456000E+01,9.014100E+02,3.015900E+03,1.372600E-08,& + & 2.820800E-08,4.705700E-08,9.348500E-08,1.817300E-07,4.213200E-07,& + & 1.245900E-06,5.966800E-06,1.027000E-04,6.505700E-04,1.579900E-03,& + & 5.128900E-03,1.792200E-02,1.544100E-01,1.334200E+01,1.177000E+02,& + & 3.913300E-08,1.401100E-07,6.162400E-07,5.543800E-06,4.931900E-05,& + & 2.047800E-04,8.247400E-04,4.884300E-03,8.903100E-02,7.382400E-01,& + & 2.018400E+00,6.220700E+00,2.642500E+01,3.090100E+02,4.870300E+03,& + & 1.575500E+04,7.503800E-08,2.120300E-07,8.571600E-07,6.246800E-06,& + & 4.368100E-05,1.693700E-04,6.714900E-04,4.000700E-03,7.395500E-02,& + & 6.267000E-01,1.710900E+00,5.168000E+00,2.073500E+01,2.322000E+02,& + & 3.652700E+03,1.181600E+04,7.614300E-08,2.115300E-07,8.076000E-07,& + & 5.101600E-06,3.172200E-05,1.187200E-04,4.661200E-04,2.784600E-03,& + & 5.099000E-02,4.355600E-01,1.198500E+00,3.728200E+00,1.515300E+01,& + & 1.571100E+02,2.435200E+03,7.877200E+03,6.506300E-08,1.812900E-07,& + & 6.455800E-07,3.438700E-06,1.794300E-05,6.423600E-05,2.478100E-04,& + & 1.486600E-03,2.684300E-02,2.286200E-01,6.337700E-01,2.016600E+00,& + & 8.625300E+00,8.432700E+01,1.217600E+03,3.938600E+03,1.748000E-08,& + & 3.725500E-08,6.432700E-08,1.259400E-07,2.439200E-07,5.695400E-07,& + & 1.725600E-06,8.487900E-06,1.563200E-04,9.873800E-04,2.363600E-03,& + & 7.483600E-03,2.390700E-02,2.915900E-01,1.876600E+01,1.585800E+02/ + data absb(:,1021:1040) / & + & 4.714000E-08,2.021100E-07,1.070100E-06,9.632800E-06,7.484800E-05,& + & 3.066200E-04,1.274200E-03,8.161900E-03,1.487800E-01,1.266600E+00,& + & 3.269300E+00,1.014400E+01,4.297900E+01,4.602400E+02,6.297000E+03,& + & 1.999900E+04,9.779200E-08,3.144300E-07,1.420700E-06,1.032900E-05,& + & 6.536900E-05,2.537400E-04,1.042400E-03,6.688500E-03,1.242700E-01,& + & 1.063200E+00,2.752500E+00,8.305400E+00,3.344400E+01,3.454700E+02,& + & 4.722800E+03,1.499900E+04,1.002600E-07,3.135700E-07,1.300600E-06,& + & 8.244600E-06,4.702100E-05,1.775500E-04,7.249300E-04,4.647800E-03,& + & 8.588900E-02,7.385200E-01,1.935500E+00,5.996700E+00,2.411900E+01,& + & 2.330400E+02,3.148500E+03,9.999500E+03,8.627600E-08,2.653900E-07,& + & 1.008100E-06,5.397800E-06,2.626900E-05,9.570500E-05,3.855800E-04,& + & 2.473500E-03,4.524200E-02,3.876500E-01,1.027800E+00,3.250800E+00,& + & 1.371900E+01,1.236300E+02,1.574200E+03,5.000000E+03,2.221100E-08,& + & 4.831400E-08,8.370300E-08,1.645000E-07,3.171900E-07,7.467300E-07,& + & 2.316400E-06,1.174400E-05,2.309500E-04,1.407700E-03,3.408600E-03,& + & 1.039000E-02,3.130700E-02,5.201200E-01,2.523100E+01,2.075100E+02,& + & 3.202600E-08,6.861200E-08,1.656900E-07,6.103400E-07,6.477000E-06,& + & 3.554800E-05,1.396900E-04,6.693900E-04,1.211800E-02,9.396000E-02,& + & 2.458700E-01,8.809600E-01,3.736900E+00,5.304600E+01,1.490500E+03,& + & 6.272100E+03,3.817300E-08,8.085800E-08,1.882600E-07,7.640700E-07,& + & 6.251500E-06,2.920100E-05,1.131700E-04,5.449700E-04,1.001400E-02,& + & 7.877100E-02,2.129800E-01,7.600300E-01,3.084400E+00,4.013300E+01,& + & 1.117900E+03,4.704100E+03,3.491300E-08,7.008000E-08,1.651600E-07,& + & 6.637100E-07,4.777000E-06,2.049900E-05,7.856100E-05,3.791000E-04,& + & 6.909300E-03,5.424000E-02,1.482900E-01,5.382800E-01,2.285500E+00,& + & 2.781600E+01,7.452600E+02,3.136200E+03,2.955400E-08,5.108800E-08,& + & 1.246300E-07,4.801600E-07,2.907400E-06,1.114200E-05,4.187000E-05,& + & 2.022500E-04,3.647900E-03,2.840100E-02,7.820600E-02,2.865200E-01,& + & 1.280600E+00,1.561100E+01,3.734300E+02,1.568100E+03,4.789500E-09,& + & 1.095200E-08,1.734100E-08,3.196000E-08,6.261100E-08,1.488800E-07,& + & 4.156300E-07,1.923900E-06,3.041300E-05,1.931600E-04,4.487400E-04,& + & 1.702800E-03,7.596900E-03,4.254200E-02,4.624100E+00,5.187500E+01,& + & 3.045900E-08,7.378600E-08,1.991600E-07,1.097700E-06,1.260800E-05,& + & 6.086700E-05,2.419700E-04,1.227800E-03,2.315700E-02,1.767600E-01,& + & 5.052400E-01,1.734200E+00,7.394500E+00,1.007400E+02,2.349400E+03,& + & 8.674100E+03,4.171200E-08,9.390200E-08,2.509500E-07,1.393000E-06,& + & 1.172400E-05,5.008000E-05,1.960700E-04,1.003000E-03,1.912200E-02,& + & 1.498400E-01,4.389600E-01,1.479000E+00,5.970000E+00,7.598200E+01,& + & 1.762100E+03,6.505600E+03,4.017200E-08,8.443100E-08,2.332300E-07,& + & 1.202100E-06,8.783700E-06,3.510200E-05,1.360200E-04,6.983600E-04,& + & 1.317200E-02,1.033600E-01,3.067400E-01,1.055900E+00,4.424100E+00,& + & 5.207500E+01,1.174700E+03,4.337000E+03,3.341700E-08,6.705900E-08,& + & 1.871600E-07,8.578400E-07,5.204400E-06,1.905300E-05,7.232500E-05,& + & 3.731400E-04,6.936400E-03,5.412100E-02,1.623600E-01,5.637200E-01,& + & 2.497600E+00,2.880300E+01,5.877800E+02,2.168200E+03,7.220200E-09,& + & 1.495000E-08,2.474300E-08,4.901200E-08,9.422200E-08,2.195700E-07,& + & 6.327300E-07,3.019400E-06,5.072000E-05,3.156800E-04,7.805400E-04,& + & 2.771500E-03,1.117000E-02,6.432200E-02,7.666600E+00,7.562800E+01,& + & 3.034400E-08,8.623600E-08,2.780000E-07,2.127000E-06,2.253200E-05,& + & 9.990500E-05,4.001500E-04,2.198400E-03,4.192900E-02,3.286700E-01,& + & 9.787000E-01,3.166000E+00,1.361000E+01,1.755700E+02,3.431700E+03,& + & 1.170000E+04,4.824800E-08,1.175100E-07,3.808300E-07,2.570500E-06,& + & 2.040500E-05,8.229400E-05,3.248700E-04,1.799600E-03,3.471100E-02,& + & 2.796900E-01,8.420400E-01,2.670000E+00,1.080700E+01,1.321500E+02,& + & 2.573800E+03,8.774800E+03,4.772800E-08,1.114800E-07,3.619800E-07,& + & 2.163700E-06,1.504300E-05,5.767900E-05,2.252700E-04,1.251100E-03,& + & 2.391300E-02,1.944700E-01,5.878400E-01,1.916200E+00,7.971400E+00,& + & 8.988200E+01,1.715900E+03,5.849900E+03,3.999900E-08,9.290900E-08,& + & 2.948900E-07,1.502400E-06,8.695000E-06,3.127800E-05,1.195100E-04,& + & 6.677700E-04,1.257800E-02,1.023100E-01,3.105200E-01,1.030500E+00,& + & 4.512800E+00,4.897600E+01,8.579300E+02,2.924900E+03,1.038700E-08,& + & 2.068900E-08,3.459300E-08,6.867300E-08,1.341100E-07,3.116700E-07,& + & 9.208100E-07,4.505600E-06,8.049900E-05,5.251200E-04,1.270100E-03,& + & 4.240900E-03,1.612900E-02,1.216300E-01,1.174400E+01,1.059600E+02/ + data absb(:,1041:1060) / & + & 3.265000E-08,1.101700E-07,4.495300E-07,3.996500E-06,3.739700E-05,& + & 1.578400E-04,6.407500E-04,3.833100E-03,7.318200E-02,6.096500E-01,& + & 1.736800E+00,5.491600E+00,2.356000E+01,2.838200E+02,4.717300E+03,& + & 1.540400E+04,5.916900E-08,1.606500E-07,6.221800E-07,4.551400E-06,& + & 3.321200E-05,1.304800E-04,5.216200E-04,3.145700E-03,6.082100E-02,& + & 5.198000E-01,1.478700E+00,4.573300E+00,1.849400E+01,2.132900E+02,& + & 3.538000E+03,1.155300E+04,5.945300E-08,1.582300E-07,5.863700E-07,& + & 3.732000E-06,2.414500E-05,9.137600E-05,3.621800E-04,2.188600E-03,& + & 4.191100E-02,3.616900E-01,1.035700E+00,3.296700E+00,1.353000E+01,& + & 1.443100E+02,2.358700E+03,7.702000E+03,5.024100E-08,1.345800E-07,& + & 4.694700E-07,2.522600E-06,1.368500E-05,4.939600E-05,1.921900E-04,& + & 1.168700E-03,2.205400E-02,1.900300E-01,5.477500E-01,1.783300E+00,& + & 7.683700E+00,7.741700E+01,1.179300E+03,3.851000E+03,1.320200E-08,& + & 2.783700E-08,4.765700E-08,9.358700E-08,1.824500E-07,4.256900E-07,& + & 1.292600E-06,6.496400E-06,1.245200E-04,8.097600E-04,1.934000E-03,& + & 6.361400E-03,2.183800E-02,2.354200E-01,1.683600E+01,1.440400E+02,& + & 3.829800E-08,1.546200E-07,7.765300E-07,7.083000E-06,5.787800E-05,& + & 2.399000E-04,1.001100E-03,6.543200E-03,1.243400E-01,1.082200E+00,& + & 2.893300E+00,9.131600E+00,3.894900E+01,4.307500E+02,6.181000E+03,& + & 1.975200E+04,7.604000E-08,2.349500E-07,1.034800E-06,7.665400E-06,& + & 5.064500E-05,1.984400E-04,8.197800E-04,5.370900E-03,1.039100E-01,& + & 9.122300E-01,2.441900E+00,7.496200E+00,3.031100E+01,3.233500E+02,& + & 4.635700E+03,1.481400E+04,7.730400E-08,2.332500E-07,9.510600E-07,& + & 6.132900E-06,3.644400E-05,1.387900E-04,5.699200E-04,3.730700E-03,& + & 7.180700E-02,6.337400E-01,1.716300E+00,5.412800E+00,2.188200E+01,& + & 2.180600E+02,3.090500E+03,9.875800E+03,6.597500E-08,1.969800E-07,& + & 7.396400E-07,4.035100E-06,2.038200E-05,7.472600E-05,3.027500E-04,& + & 1.985900E-03,3.781000E-02,3.326900E-01,9.108200E-01,2.932500E+00,& + & 1.243400E+01,1.155700E+02,1.545200E+03,4.937900E+03,1.681500E-08,& + & 3.638300E-08,6.291400E-08,1.238200E-07,2.387100E-07,5.643200E-07,& + & 1.753900E-06,9.110700E-06,1.870600E-04,1.175000E-03,2.844300E-03,& + & 9.099600E-03,2.823900E-02,4.292700E-01,2.295500E+01,1.903000E+02,& + & 2.867700E-08,5.973200E-08,1.404300E-07,4.638500E-07,4.585200E-06,& + & 2.625400E-05,1.037000E-04,5.011100E-04,9.266300E-03,7.390600E-02,& + & 1.941800E-01,7.008000E-01,3.114700E+00,4.501000E+01,1.350300E+03,& + & 6.023100E+03,3.244100E-08,6.740300E-08,1.534800E-07,5.592100E-07,& + & 4.439000E-06,2.155100E-05,8.406400E-05,4.075500E-04,7.678500E-03,& + & 6.210700E-02,1.669800E-01,6.094100E-01,2.577700E+00,3.407600E+01,& + & 1.012700E+03,4.517300E+03,2.874800E-08,5.777700E-08,1.305000E-07,& + & 4.801900E-07,3.401600E-06,1.510900E-05,5.832000E-05,2.832100E-04,& + & 5.303000E-03,4.286400E-02,1.158200E-01,4.313200E-01,1.905000E+00,& + & 2.365600E+01,6.751700E+02,3.011600E+03,2.415100E-08,3.991500E-08,& + & 9.579000E-08,3.433700E-07,2.076700E-06,8.201300E-06,3.103500E-05,& + & 1.508100E-04,2.796200E-03,2.244500E-02,6.092400E-02,2.299100E-01,& + & 1.063700E+00,1.327100E+01,3.383700E+02,1.505800E+03,3.545900E-09,& + & 8.503700E-09,1.302100E-08,2.239400E-08,4.496100E-08,1.077600E-07,& + & 3.012500E-07,1.402500E-06,2.333100E-05,1.559900E-04,3.520900E-04,& + & 1.349700E-03,6.536900E-03,3.850800E-02,3.849600E+00,4.558300E+01,& + & 2.698100E-08,6.257600E-08,1.619500E-07,7.898900E-07,9.136300E-06,& + & 4.575600E-05,1.838600E-04,9.350200E-04,1.830300E-02,1.436900E-01,& + & 3.979100E-01,1.455400E+00,6.343900E+00,8.826200E+01,2.192200E+03,& + & 8.382300E+03,3.472000E-08,7.669000E-08,1.945400E-07,9.964000E-07,& + & 8.546800E-06,3.759400E-05,1.489900E-04,7.636500E-04,1.516900E-02,& + & 1.205000E-01,3.489200E-01,1.247100E+00,5.134700E+00,6.658000E+01,& + & 1.644100E+03,6.286800E+03,3.239100E-08,6.786300E-08,1.766100E-07,& + & 8.598600E-07,6.413800E-06,2.633000E-05,1.033000E-04,5.311300E-04,& + & 1.045300E-02,8.313400E-02,2.439200E-01,8.893700E-01,3.805400E+00,& + & 4.565500E+01,1.096100E+03,4.191200E+03,2.697400E-08,5.193000E-08,& + & 1.384200E-07,6.131300E-07,3.813600E-06,1.426600E-05,5.488100E-05,& + & 2.833800E-04,5.503900E-03,4.356700E-02,1.292900E-01,4.746300E-01,& + & 2.145400E+00,2.523200E+01,5.485300E+02,2.095600E+03,5.356000E-09,& + & 1.105900E-08,1.831000E-08,3.597700E-08,6.920400E-08,1.622700E-07,& + & 4.662400E-07,2.249800E-06,4.006200E-05,2.533500E-04,6.318800E-04,& + & 2.328200E-03,1.002400E-02,5.712300E-02,6.570800E+00,6.736200E+01/ + data absb(:,1061:1080) / & + & 2.640900E-08,7.112600E-08,2.149800E-07,1.519200E-06,1.677000E-05,& + & 7.638700E-05,3.095400E-04,1.707700E-03,3.413100E-02,2.676000E-01,& + & 8.084500E-01,2.745800E+00,1.198500E+01,1.580500E+02,3.273900E+03,& + & 1.139800E+04,3.935500E-08,9.320000E-08,2.840000E-07,1.851600E-06,& + & 1.523800E-05,6.284000E-05,2.512300E-04,1.399300E-03,2.825800E-02,& + & 2.282700E-01,6.994600E-01,2.324300E+00,9.522900E+00,1.189700E+02,& + & 2.455400E+03,8.548800E+03,3.816700E-08,8.638200E-08,2.671400E-07,& + & 1.562400E-06,1.125100E-05,4.398300E-05,1.741300E-04,9.726100E-04,& + & 1.945400E-02,1.583500E-01,4.891200E-01,1.667100E+00,7.025800E+00,& + & 8.093000E+01,1.637000E+03,5.699200E+03,3.173900E-08,7.039500E-08,& + & 2.156100E-07,1.087800E-06,6.524500E-06,2.381300E-05,9.231200E-05,& + & 5.189100E-04,1.023000E-02,8.309600E-02,2.589400E-01,8.949300E-01,& + & 3.971300E+00,4.407300E+01,8.185300E+02,2.849600E+03,7.744800E-09,& + & 1.557300E-08,2.576900E-08,5.150000E-08,1.002000E-07,2.332200E-07,& + & 6.885000E-07,3.428900E-06,6.488700E-05,4.290900E-04,1.059100E-03,& + & 3.658500E-03,1.433000E-02,9.551900E-02,1.032000E+01,9.554200E+01,& + & 2.764900E-08,8.823000E-08,3.338400E-07,2.898000E-06,2.847500E-05,& + & 1.223300E-04,5.020300E-04,3.034200E-03,6.067200E-02,5.035100E-01,& + & 1.497000E+00,4.877800E+00,2.114500E+01,2.616100E+02,4.581800E+03,& + & 1.512400E+04,4.721500E-08,1.237800E-07,4.566300E-07,3.332100E-06,& + & 2.534300E-05,1.010500E-04,4.085500E-04,2.494100E-03,5.039800E-02,& + & 4.310500E-01,1.280400E+00,4.070400E+00,1.660000E+01,1.966200E+02,& + & 3.436400E+03,1.134300E+04,4.697000E-08,1.198400E-07,4.294600E-07,& + & 2.742600E-06,1.843900E-05,7.072900E-05,2.833000E-04,1.733800E-03,& + & 3.473300E-02,3.000600E-01,8.967800E-01,2.931800E+00,1.214800E+01,& + & 1.330200E+02,2.291000E+03,7.561700E+03,3.914400E-08,1.008500E-07,& + & 3.436700E-07,1.858100E-06,1.047400E-05,3.818400E-05,1.501900E-04,& + & 9.245400E-04,1.827000E-02,1.578200E-01,4.742400E-01,1.585100E+00,& + & 6.881400E+00,7.130100E+01,1.145500E+03,3.780800E+03,1.005600E-08,& + & 2.122500E-08,3.573100E-08,7.076200E-08,1.379600E-07,3.224200E-07,& + & 9.777200E-07,5.013100E-06,1.016900E-04,6.920200E-04,1.613800E-03,& + & 5.567300E-03,1.992900E-02,1.900000E-01,1.509400E+01,1.309900E+02,& + & 3.155300E-08,1.202600E-07,5.698000E-07,5.235600E-06,4.498800E-05,& + & 1.886600E-04,7.935400E-04,5.283400E-03,1.046800E-01,9.245800E-01,& + & 2.570000E+00,8.267000E+00,3.550500E+01,4.046600E+02,6.088800E+03,& + & 1.956800E+04,5.977600E-08,1.776500E-07,7.595600E-07,5.713600E-06,& + & 3.942300E-05,1.560400E-04,6.497600E-04,4.344700E-03,8.748800E-02,& + & 7.828800E-01,2.177400E+00,6.797100E+00,2.762800E+01,3.037800E+02,& + & 4.566600E+03,1.467600E+04,6.021900E-08,1.750000E-07,6.995400E-07,& + & 4.582600E-06,2.837300E-05,1.090700E-04,4.511300E-04,3.018200E-03,& + & 6.045000E-02,5.439600E-01,1.530400E+00,4.906300E+00,1.995600E+01,& + & 2.048000E+02,3.044400E+03,9.784100E+03,5.085100E-08,1.472100E-07,& + & 5.454400E-07,3.025300E-06,1.587200E-05,5.866000E-05,2.395400E-04,& + & 1.605300E-03,3.181000E-02,2.858200E-01,8.115000E-01,2.658100E+00,& + & 1.132300E+01,1.084100E+02,1.522200E+03,4.892000E+03,1.289700E-08,& + & 2.778300E-08,4.797800E-08,9.433800E-08,1.825800E-07,4.319000E-07,& + & 1.340900E-06,7.121000E-06,1.553700E-04,1.020700E-03,2.427700E-03,& + & 8.048100E-03,2.607000E-02,3.539600E-01,2.087600E+01,1.746400E+02,& + & 2.587100E-08,5.268700E-08,1.208600E-07,3.637100E-07,3.254300E-06,& + & 1.935200E-05,7.669300E-05,3.761600E-04,7.038300E-03,5.777700E-02,& + & 1.537000E-01,5.505000E-01,2.584100E+00,3.799900E+01,1.216400E+03,& + & 5.798900E+03,2.789600E-08,5.685700E-08,1.272300E-07,4.182200E-07,& + & 3.146900E-06,1.588600E-05,6.216200E-05,3.051900E-04,5.845200E-03,& + & 4.849600E-02,1.314500E-01,4.827700E-01,2.141200E+00,2.879100E+01,& + & 9.122700E+02,4.349200E+03,2.402500E-08,4.789500E-08,1.053900E-07,& + & 3.528100E-07,2.415800E-06,1.112400E-05,4.312000E-05,2.117000E-04,& + & 4.038100E-03,3.348900E-02,9.132100E-02,3.412800E-01,1.579200E+00,& + & 2.001400E+01,6.081800E+02,2.899500E+03,1.994100E-08,3.200100E-08,& + & 7.444600E-08,2.478600E-07,1.478700E-06,6.028400E-06,2.293300E-05,& + & 1.124700E-04,2.128800E-03,1.757900E-02,4.812400E-02,1.818100E-01,& + & 8.784700E-01,1.121400E+01,3.048700E+02,1.449700E+03,2.578900E-09,& + & 6.627500E-09,9.226100E-09,1.607200E-08,3.193200E-08,7.783200E-08,& + & 2.168400E-07,1.014000E-06,1.781100E-05,1.244200E-04,2.753100E-04,& + & 1.066600E-03,5.727200E-03,3.499400E-02,3.172400E+00,3.982800E+01/ + data absb(:,1081:1100) / & + & 2.411100E-08,5.376600E-08,1.343400E-07,5.778600E-07,6.598900E-06,& + & 3.437800E-05,1.393400E-04,7.128100E-04,1.440800E-02,1.166500E-01,& + & 3.161600E-01,1.208800E+00,5.427900E+00,7.705900E+01,2.037600E+03,& + & 8.123200E+03,2.923000E-08,6.341500E-08,1.540700E-07,7.177600E-07,& + & 6.203800E-06,2.819700E-05,1.129400E-04,5.817300E-04,1.196600E-02,& + & 9.780500E-02,2.758300E-01,1.042600E+00,4.404700E+00,5.814000E+01,& + & 1.528200E+03,6.092400E+03,2.656200E-08,5.517100E-08,1.361600E-07,& + & 6.168400E-07,4.669600E-06,1.972100E-05,7.821900E-05,4.042000E-04,& + & 8.252300E-03,6.743300E-02,1.924500E-01,7.435000E-01,3.262100E+00,& + & 3.988800E+01,1.018800E+03,4.061600E+03,2.201200E-08,4.034100E-08,& + & 1.039600E-07,4.388900E-07,2.783100E-06,1.066700E-05,4.152000E-05,& + & 2.150500E-04,4.344800E-03,3.534200E-02,1.017100E-01,3.974400E-01,& + & 1.837000E+00,2.202100E+01,5.098900E+02,2.030800E+03,3.921100E-09,& + & 8.217600E-09,1.344700E-08,2.645000E-08,5.053100E-08,1.194800E-07,& + & 3.417900E-07,1.667300E-06,3.148800E-05,2.068900E-04,5.026900E-04,& + & 1.942100E-03,9.008500E-03,5.168500E-02,5.589000E+00,5.972900E+01,& + & 2.326000E-08,5.948700E-08,1.700000E-07,1.089300E-06,1.245300E-05,& + & 5.834900E-05,2.391000E-04,1.322900E-03,2.769500E-02,2.188000E-01,& + & 6.619900E-01,2.375300E+00,1.054100E+01,1.418700E+02,3.117500E+03,& + & 1.113900E+04,3.244300E-08,7.507000E-08,2.150600E-07,1.333500E-06,& + & 1.135200E-05,4.795000E-05,1.940300E-04,1.084600E-03,2.295300E-02,& + & 1.863600E-01,5.764900E-01,2.017800E+00,8.380200E+00,1.068000E+02,& + & 2.338100E+03,8.354600E+03,3.089100E-08,6.790000E-08,1.991600E-07,& + & 1.127100E-06,8.394500E-06,3.352000E-05,1.344100E-04,7.536700E-04,& + & 1.581100E-02,1.290500E-01,4.035200E-01,1.446300E+00,6.180100E+00,& + & 7.265500E+01,1.558800E+03,5.569700E+03,2.539200E-08,5.387400E-08,& + & 1.586100E-07,7.863600E-07,4.882000E-06,1.811100E-05,7.118900E-05,& + & 4.012600E-04,8.308000E-03,6.780400E-02,2.138600E-01,7.755900E-01,& + & 3.487000E+00,3.953100E+01,7.794700E+02,2.784900E+03,5.799100E-09,& + & 1.160500E-08,1.923300E-08,3.860300E-08,7.453800E-08,1.736300E-07,& + & 5.127400E-07,2.592100E-06,5.223900E-05,3.514900E-04,8.677500E-04,& + & 3.148600E-03,1.289400E-02,7.740800E-02,9.006000E+00,8.580100E+01,& + & 2.374400E-08,7.173600E-08,2.515500E-07,2.101000E-06,2.165500E-05,& + & 9.486600E-05,3.937800E-04,2.403400E-03,5.032700E-02,4.157900E-01,& + & 1.282200E+00,4.333600E+00,1.899800E+01,2.406900E+02,4.449100E+03,& + & 1.489000E+04,3.810500E-08,9.666300E-08,3.374600E-07,2.436800E-06,& + & 1.931400E-05,7.829000E-05,3.205400E-04,1.975400E-03,4.181500E-02,& + & 3.563300E-01,1.102100E+00,3.622700E+00,1.491400E+01,1.809100E+02,& + & 3.336800E+03,1.116700E+04,3.744100E-08,9.160600E-08,3.159200E-07,& + & 2.011400E-06,1.406500E-05,5.472300E-05,2.219800E-04,1.371400E-03,& + & 2.882700E-02,2.477900E-01,7.725600E-01,2.606100E+00,1.091000E+01,& + & 1.223700E+02,2.224600E+03,7.444800E+03,3.075000E-08,7.598300E-08,& + & 2.520400E-07,1.365200E-06,8.002800E-06,2.951000E-05,1.174800E-04,& + & 7.302700E-04,1.514900E-02,1.304300E-01,4.089100E-01,1.407500E+00,& + & 6.163100E+00,6.553000E+01,1.112300E+03,3.722400E+03,7.737000E-09,& + & 1.610500E-08,2.685900E-08,5.330300E-08,1.039700E-07,2.438500E-07,& + & 7.384000E-07,3.857700E-06,8.295200E-05,5.743700E-04,1.351900E-03,& + & 4.877200E-03,1.821600E-02,1.521600E-01,1.346300E+01,1.187400E+02,& + & 2.635700E-08,9.481100E-08,4.208800E-07,3.867500E-06,3.495000E-05,& + & 1.483900E-04,6.295700E-04,4.258900E-03,8.847700E-02,7.839200E-01,& + & 2.278300E+00,7.487100E+00,3.238700E+01,3.800700E+02,6.002700E+03,& + & 1.942900E+04,4.741900E-08,1.354700E-07,5.590700E-07,4.253600E-06,& + & 3.067300E-05,1.227300E-04,5.153100E-04,3.508900E-03,7.378600E-02,& + & 6.681000E-01,1.936800E+00,6.164800E+00,2.519500E+01,2.853300E+02,& + & 4.502000E+03,1.457200E+04,4.726400E-08,1.320400E-07,5.152500E-07,& + & 3.420500E-06,2.208500E-05,8.568000E-05,3.575300E-04,2.436400E-03,& + & 5.090500E-02,4.649800E-01,1.362200E+00,4.445500E+00,1.820000E+01,& + & 1.923000E+02,3.001400E+03,9.714800E+03,3.943500E-08,1.103600E-07,& + & 4.022000E-07,2.262200E-06,1.236300E-05,4.604500E-05,1.895200E-04,& + & 1.295600E-03,2.678300E-02,2.443400E-01,7.222100E-01,2.408400E+00,& + & 1.031100E+01,1.016400E+02,1.500700E+03,4.857400E+03,9.894800E-09,& + & 2.120300E-08,3.654900E-08,7.162600E-08,1.392500E-07,3.302200E-07,& + & 1.022200E-06,5.565600E-06,1.290000E-04,8.739200E-04,2.080100E-03,& + & 7.263300E-03,2.501700E-02,2.884200E-01,1.891200E+01,1.598800E+02/ + data absb(:,1101:1120) / & + & 2.353500E-08,4.703000E-08,1.055300E-07,2.943100E-07,2.316600E-06,& + & 1.425500E-05,5.653500E-05,2.816300E-04,5.298400E-03,4.496200E-02,& + & 1.216500E-01,4.269100E-01,2.127300E+00,3.195100E+01,1.088900E+03,& + & 5.602100E+03,2.425900E-08,4.856800E-08,1.070700E-07,3.213300E-07,& + & 2.239000E-06,1.168000E-05,4.582900E-05,2.285100E-04,4.404800E-03,& + & 3.774500E-02,1.043300E-01,3.759300E-01,1.766300E+00,2.422600E+01,& + & 8.166400E+02,4.201600E+03,2.030900E-08,3.998800E-08,8.715300E-08,& + & 2.645700E-07,1.714200E-06,8.177600E-06,3.175400E-05,1.582500E-04,& + & 3.044200E-03,2.602000E-02,7.230300E-02,2.660600E-01,1.299700E+00,& + & 1.686300E+01,5.444300E+02,2.801000E+03,1.643500E-08,2.621900E-08,& + & 5.894400E-08,1.814600E-07,1.050400E-06,4.423500E-06,1.688000E-05,& + & 8.380100E-05,1.606200E-03,1.366900E-02,3.800900E-02,1.419500E-01,& + & 7.218200E-01,9.428100E+00,2.729800E+02,1.400500E+03,1.842400E-09,& + & 4.940800E-09,6.803300E-09,1.125900E-08,2.268200E-08,5.592700E-08,& + & 1.553500E-07,7.292000E-07,1.348500E-05,1.007400E-04,2.193800E-04,& + & 8.379300E-04,4.999000E-03,3.308600E-02,2.582100E+00,3.459300E+01,& + & 2.175000E-08,4.681100E-08,1.136200E-07,4.321200E-07,4.754000E-06,& + & 2.581500E-05,1.054300E-04,5.431600E-04,1.127700E-02,9.397500E-02,& + & 2.519800E-01,9.956700E-01,4.628800E+00,6.699500E+01,1.887100E+03,& + & 7.903200E+03,2.498100E-08,5.301500E-08,1.248700E-07,5.228000E-07,& + & 4.489200E-06,2.113200E-05,8.539300E-05,4.428800E-04,9.383900E-03,& + & 7.903900E-02,2.193800E-01,8.632500E-01,3.765300E+00,5.055500E+01,& + & 1.415400E+03,5.927400E+03,2.197500E-08,4.554600E-08,1.070800E-07,& + & 4.460100E-07,3.384600E-06,1.476300E-05,5.909900E-05,3.073600E-04,& + & 6.474500E-03,5.446800E-02,1.531100E-01,6.146300E-01,2.787600E+00,& + & 3.469900E+01,9.435700E+02,3.951600E+03,1.796500E-08,3.176900E-08,& + & 7.950600E-08,3.152700E-07,2.024500E-06,7.966300E-06,3.133600E-05,& + & 1.632400E-04,3.412600E-03,2.858300E-02,8.087700E-02,3.285900E-01,& + & 1.565300E+00,1.913300E+01,4.723100E+02,1.975800E+03,2.848500E-09,& + & 6.135300E-09,9.894300E-09,1.912200E-08,3.698800E-08,8.752200E-08,& + & 2.494100E-07,1.227500E-06,2.466400E-05,1.688800E-04,3.987500E-04,& + & 1.624200E-03,7.993900E-03,4.551600E-02,4.710200E+00,5.276600E+01,& + & 2.071600E-08,5.049400E-08,1.372900E-07,7.867900E-07,9.224600E-06,& + & 4.455200E-05,1.844700E-04,1.024200E-03,2.238300E-02,1.808300E-01,& + & 5.360600E-01,2.048600E+00,9.245900E+00,1.270500E+02,2.964800E+03,& + & 1.091900E+04,2.709500E-08,6.137000E-08,1.657700E-07,9.612900E-07,& + & 8.432000E-06,3.657900E-05,1.497600E-04,8.390700E-04,1.859800E-02,& + & 1.530500E-01,4.703900E-01,1.744900E+00,7.357200E+00,9.565000E+01,& + & 2.223600E+03,8.188900E+03,2.507300E-08,5.448700E-08,1.503900E-07,& + & 8.134000E-07,6.243800E-06,2.553100E-05,1.036400E-04,5.825000E-04,& + & 1.281000E-02,1.059800E-01,3.294500E-01,1.250200E+00,5.425800E+00,& + & 6.506200E+01,1.482400E+03,5.459300E+03,2.051800E-08,4.171000E-08,& + & 1.175500E-07,5.676600E-07,3.642500E-06,1.376100E-05,5.485000E-05,& + & 3.098400E-04,6.727800E-03,5.551900E-02,1.750800E-01,6.701800E-01,& + & 3.055000E+00,3.535900E+01,7.413100E+02,2.729500E+03,4.329600E-09,& + & 8.653600E-09,1.431000E-08,2.868100E-08,5.532800E-08,1.292500E-07,& + & 3.798000E-07,1.950400E-06,4.207300E-05,2.818000E-04,6.995400E-04,& + & 2.739900E-03,1.176100E-02,6.795800E-02,7.791100E+00,7.678400E+01,& + & 2.068800E-08,5.921600E-08,1.930300E-07,1.524000E-06,1.644800E-05,& + & 7.358900E-05,3.091000E-04,1.897700E-03,4.179300E-02,3.454100E-01,& + & 1.088000E+00,3.849600E+00,1.706700E+01,2.210600E+02,4.319400E+03,& + & 1.470900E+04,3.115000E-08,7.659200E-08,2.518500E-07,1.781000E-06,& + & 1.470400E-05,6.064000E-05,2.513200E-04,1.563000E-03,3.472200E-02,& + & 2.943100E-01,9.427300E-01,3.223400E+00,1.339500E+01,1.661600E+02,& + & 3.239500E+03,1.103100E+04,2.999800E-08,7.099400E-08,2.338600E-07,& + & 1.472500E-06,1.071700E-05,4.234100E-05,1.739700E-04,1.084800E-03,& + & 2.390100E-02,2.047600E-01,6.614200E-01,2.315900E+00,9.795200E+00,& + & 1.123700E+02,2.159700E+03,7.354200E+03,2.438900E-08,5.769300E-08,& + & 1.853300E-07,1.001300E-06,6.106900E-06,2.279700E-05,9.197600E-05,& + & 5.769100E-04,1.256100E-02,1.078000E-01,3.502700E-01,1.249200E+00,& + & 5.522200E+00,6.009600E+01,1.079800E+03,3.677100E+03,6.094900E-09,& + & 1.191600E-08,2.015500E-08,4.021200E-08,7.821000E-08,1.836400E-07,& + & 5.550600E-07,2.952600E-06,6.809900E-05,4.793100E-04,1.145400E-03,& + & 4.264900E-03,1.685100E-02,1.202500E-01,1.192400E+01,1.074100E+02/ + data absb(:,1121:1140) / & + & 2.233600E-08,7.590800E-08,3.137800E-07,2.854600E-06,2.714000E-05,& + & 1.168700E-04,4.999800E-04,3.429000E-03,7.487900E-02,6.621200E-01,& + & 2.013900E+00,6.786700E+00,2.957400E+01,3.568300E+02,5.925200E+03,& + & 1.934400E+04,3.795700E-08,1.045100E-07,4.131300E-07,3.161700E-06,& + & 2.384900E-05,9.656500E-05,4.088800E-04,2.829800E-03,6.244900E-02,& + & 5.658900E-01,1.719100E+00,5.592700E+00,2.299300E+01,2.678900E+02,& + & 4.443900E+03,1.450800E+04,3.741500E-08,1.003500E-07,3.802500E-07,& + & 2.549400E-06,1.718200E-05,6.734900E-05,2.834100E-04,1.963900E-03,& + & 4.307500E-02,3.939000E-01,1.209700E+00,4.028500E+00,1.660600E+01,& + & 1.804900E+02,2.962600E+03,9.671900E+03,3.078300E-08,8.309700E-08,& + & 2.965600E-07,1.687500E-06,9.623300E-06,3.614500E-05,1.499900E-04,& + & 1.043700E-03,2.264300E-02,2.072600E-01,6.410000E-01,2.182300E+00,& + & 9.391200E+00,9.524000E+01,1.481300E+03,4.835900E+03,7.564900E-09,& + & 1.623000E-08,2.761900E-08,5.448000E-08,1.061100E-07,2.519000E-07,& + & 7.793400E-07,4.320300E-06,1.070100E-04,7.597900E-04,1.790100E-03,& + & 6.509300E-03,2.285200E-02,2.346300E-01,1.705800E+01,1.458200E+02,& + & 1.042500E-08,2.052400E-08,4.518600E-08,1.192000E-07,8.159400E-07,& + & 5.128300E-06,2.033800E-05,1.029900E-04,1.942200E-03,1.706200E-02,& + & 4.691900E-02,1.635600E-01,8.474400E-01,1.312000E+01,4.729600E+02,& + & 2.646100E+03,1.183000E-08,2.337700E-08,5.089000E-08,1.419300E-07,& + & 9.001600E-07,4.816400E-06,1.891300E-05,9.589600E-05,1.856200E-03,& + & 1.642200E-02,4.626800E-02,1.648200E-01,8.114500E-01,1.142700E+01,& + & 4.072400E+02,2.278400E+03,1.134000E-08,2.210300E-08,4.783200E-08,& + & 1.338000E-07,8.066100E-07,3.953300E-06,1.537800E-05,7.784400E-05,& + & 1.507000E-03,1.330100E-02,3.758400E-02,1.363000E-01,7.019400E-01,& + & 9.342100E+00,3.186700E+02,1.782900E+03,1.098200E-08,1.729100E-08,& + & 3.747200E-08,1.078200E-07,5.954300E-07,2.584400E-06,9.885300E-06,& + & 4.978800E-05,9.617800E-04,8.467600E-03,2.391100E-02,8.791600E-02,& + & 4.717200E-01,6.304100E+00,1.934100E+02,1.063800E+03,1.344300E-09,& + & 3.630300E-09,5.169600E-09,7.952500E-09,1.626900E-08,4.041100E-08,& + & 1.118300E-07,5.262300E-07,1.024200E-05,8.214200E-05,1.798800E-04,& + & 6.587700E-04,4.463900E-03,2.929000E-02,2.105200E+00,3.008400E+01,& + & 9.564800E-09,2.002300E-08,4.740100E-08,1.618600E-07,1.672800E-06,& + & 9.466300E-06,3.891700E-05,2.030700E-04,4.296300E-03,3.704400E-02,& + & 9.962800E-02,3.965300E-01,1.930300E+00,2.837500E+01,8.495800E+02,& + & 3.754700E+03,1.200200E-08,2.500800E-08,5.761800E-08,2.169600E-07,& + & 1.819300E-06,8.882900E-06,3.614400E-05,1.901300E-04,4.112600E-03,& + & 3.579100E-02,9.883200E-02,3.977100E-01,1.804900E+00,2.458600E+01,& + & 7.315200E+02,3.232900E+03,1.204500E-08,2.483100E-08,5.635700E-08,& + & 2.147700E-07,1.612200E-06,7.275600E-06,2.933500E-05,1.545000E-04,& + & 3.337800E-03,2.893300E-02,8.074400E-02,3.321900E-01,1.564500E+00,& + & 1.981500E+01,5.724200E+02,2.529800E+03,1.171000E-08,2.027300E-08,& + & 4.895500E-08,1.816500E-07,1.168900E-06,4.739700E-06,1.880000E-05,& + & 9.903500E-05,2.127800E-03,1.834400E-02,5.143800E-02,2.152200E-01,& + & 1.059500E+00,1.320500E+01,3.468200E+02,1.530900E+03,2.084900E-09,& + & 4.707000E-09,7.424300E-09,1.381400E-08,2.716100E-08,6.461600E-08,& + & 1.830900E-07,9.061600E-07,1.947500E-05,1.397900E-04,3.248200E-04,& + & 1.356100E-03,7.171800E-03,4.178300E-02,3.964300E+00,4.670600E+01,& + & 9.014600E-09,2.107600E-08,5.501000E-08,2.808700E-07,3.332500E-06,& + & 1.660800E-05,6.947800E-05,3.883900E-04,8.832100E-03,7.362700E-02,& + & 2.109700E-01,8.597800E-01,3.959300E+00,5.546200E+01,1.371900E+03,& + & 5.218200E+03,1.274700E-08,2.835600E-08,7.288200E-08,3.907600E-07,& + & 3.507600E-06,1.562800E-05,6.468400E-05,3.651500E-04,8.431200E-03,& + & 7.117600E-02,2.135800E-01,8.438800E-01,3.618500E+00,4.793800E+01,& + & 1.181200E+03,4.493000E+03,1.351200E-08,2.898700E-08,7.579700E-08,& + & 3.876000E-07,3.049700E-06,1.279100E-05,5.251700E-05,2.969500E-04,& + & 6.826700E-03,5.764800E-02,1.757000E-01,7.095900E-01,3.131800E+00,& + & 3.826400E+01,9.243400E+02,3.515900E+03,1.320100E-08,2.584000E-08,& + & 7.013600E-08,3.267900E-07,2.158100E-06,8.323200E-06,3.362000E-05,& + & 1.907800E-04,4.343700E-03,3.653400E-02,1.131800E-01,4.600900E-01,& + & 2.130800E+00,2.512600E+01,5.594800E+02,2.127600E+03,3.265400E-09,& + & 6.504800E-09,1.068700E-08,2.139400E-08,4.146800E-08,9.691600E-08,& + & 2.833300E-07,1.473700E-06,3.434700E-05,2.307200E-04,5.819400E-04,& + & 2.423100E-03,1.075900E-02,6.249700E-02,6.735200E+00,6.885500E+01/ + data absb(:,1141:1160) / & + & 8.849300E-09,2.407200E-08,7.371800E-08,5.419100E-07,6.090800E-06,& + & 2.786900E-05,1.184300E-04,7.329400E-04,1.700600E-02,1.403600E-01,& + & 4.483700E-01,1.668500E+00,7.487800E+00,9.896200E+01,2.041000E+03,& + & 7.085200E+03,1.436900E-08,3.437700E-08,1.065300E-07,7.300900E-07,& + & 6.261500E-06,2.633100E-05,1.105200E-04,6.930300E-04,1.622000E-02,& + & 1.377600E-01,4.480200E-01,1.607100E+00,6.742300E+00,8.539700E+01,& + & 1.757400E+03,6.100600E+03,1.592900E-08,3.657700E-08,1.147000E-07,& + & 7.091600E-07,5.362100E-06,2.154900E-05,8.971300E-05,5.642600E-04,& + & 1.311200E-02,1.121900E-01,3.693600E-01,1.354600E+00,5.780700E+00,& + & 6.776400E+01,1.375200E+03,4.773800E+03,1.546600E-08,3.514400E-08,& + & 1.088400E-07,5.841300E-07,3.701800E-06,1.401000E-05,5.732800E-05,& + & 3.625500E-04,8.324500E-03,7.145900E-02,2.372700E-01,8.829500E-01,& + & 3.939000E+00,4.378400E+01,8.322100E+02,2.888900E+03,4.735600E-09,& + & 8.968900E-09,1.519800E-08,3.072400E-08,5.955600E-08,1.388400E-07,& + & 4.195100E-07,2.271000E-06,5.645300E-05,4.052100E-04,9.796200E-04,& + & 3.894400E-03,1.527000E-02,9.957900E-02,1.055000E+01,9.741100E+01,& + & 9.308600E-09,3.000400E-08,1.154700E-07,1.029900E-06,1.027400E-05,& + & 4.491600E-05,1.943400E-04,1.353200E-03,3.100100E-02,2.737500E-01,& + & 8.656800E-01,3.005700E+00,1.320100E+01,1.633000E+02,2.847200E+03,& + & 9.386700E+03,1.713800E-08,4.562600E-08,1.720300E-07,1.316700E-06,& + & 1.037500E-05,4.258200E-05,1.821800E-04,1.280600E-03,2.966400E-02,& + & 2.685700E-01,8.523000E-01,2.844500E+00,1.177400E+01,1.407500E+02,& + & 2.451500E+03,8.082200E+03,1.957300E-08,5.047400E-08,1.851700E-07,& + & 1.248800E-06,8.775400E-06,3.483000E-05,1.480600E-04,1.042600E-03,& + & 2.401300E-02,2.192500E-01,7.045600E-01,2.402200E+00,9.971700E+00,& + & 1.112600E+02,1.918400E+03,6.324400E+03,1.921400E-08,4.997600E-08,& + & 1.742200E-07,1.000800E-06,5.951900E-06,2.258600E-05,9.468500E-05,& + & 6.701700E-04,1.527400E-02,1.396500E-01,4.517800E-01,1.574100E+00,& + & 6.809800E+00,7.092300E+01,1.160900E+03,3.827300E+03,5.827800E-09,& + & 1.242800E-08,2.115300E-08,4.188500E-08,8.135100E-08,1.930500E-07,& + & 5.979600E-07,3.369800E-06,9.031500E-05,6.686800E-04,1.578900E-03,& + & 5.959600E-03,2.104600E-02,1.910600E-01,1.539500E+01,1.333500E+02,& + & 9.038000E-09,1.770000E-08,3.872000E-08,1.003900E-07,6.519900E-07,& + & 4.116600E-06,1.648600E-05,8.545000E-05,1.668000E-03,1.502600E-02,& + & 4.195500E-02,1.455100E-01,7.838900E-01,1.238400E+01,4.568000E+02,& + & 2.651900E+03,1.008000E-08,1.984300E-08,4.302700E-08,1.171400E-07,& + & 7.168200E-07,3.876300E-06,1.539400E-05,7.984800E-05,1.599500E-03,& + & 1.462000E-02,4.149600E-02,1.472500E-01,7.536100E-01,1.082100E+01,& + & 3.947700E+02,2.291800E+03,9.605900E-09,1.864300E-08,4.019000E-08,& + & 1.097400E-07,6.428500E-07,3.193200E-06,1.256500E-05,6.507300E-05,& + & 1.304900E-03,1.189100E-02,3.392400E-02,1.225100E-01,6.554500E-01,& + & 8.876000E+00,3.104600E+02,1.802300E+03,9.158400E-09,1.452000E-08,& + & 3.125200E-08,8.750400E-08,4.753300E-07,2.098400E-06,8.120400E-06,& + & 4.187500E-05,8.383600E-04,7.613900E-03,2.174800E-02,7.956100E-02,& + & 4.439000E-01,6.009200E+00,1.897600E+02,1.098500E+03,1.108100E-09,& + & 2.967900E-09,4.139700E-09,6.467400E-09,1.339800E-08,3.313800E-08,& + & 9.117800E-08,4.325300E-07,9.217900E-06,7.777200E-05,1.705400E-04,& + & 6.807400E-04,4.773100E-03,2.980200E-02,1.925600E+00,2.839900E+01,& + & 8.269100E-09,1.714900E-08,4.021300E-08,1.324100E-07,1.336100E-06,& + & 7.667900E-06,3.193700E-05,1.717000E-04,3.771200E-03,3.359800E-02,& + & 9.009600E-02,3.608000E-01,1.831600E+00,2.713500E+01,8.332700E+02,& + & 3.770900E+03,1.016500E-08,2.100800E-08,4.810300E-08,1.743500E-07,& + & 1.453100E-06,7.218300E-06,2.980000E-05,1.613300E-04,3.625800E-03,& + & 3.261800E-02,8.987200E-02,3.645100E-01,1.714400E+00,2.359200E+01,& + & 7.201200E+02,3.258900E+03,1.011500E-08,2.074700E-08,4.663800E-08,& + & 1.718900E-07,1.291300E-06,5.935600E-06,2.429200E-05,1.317000E-04,& + & 2.956100E-03,2.647500E-02,7.369600E-02,3.064900E-01,1.490600E+00,& + & 1.908500E+01,5.663200E+02,2.562900E+03,9.701400E-09,1.683000E-08,& + & 4.006200E-08,1.449600E-07,9.409900E-07,3.884900E-06,1.566500E-05,& + & 8.486600E-05,1.897900E-03,1.687300E-02,4.737800E-02,2.000300E-01,& + & 1.015400E+00,1.276700E+01,3.455500E+02,1.562000E+03,1.753300E-09,& + & 3.908100E-09,6.038000E-09,1.145800E-08,2.244500E-08,5.354200E-08,& + & 1.506500E-07,7.522300E-07,1.801700E-05,1.336300E-04,3.163800E-04,& + & 1.432400E-03,7.318200E-03,4.373500E-02,3.677900E+00,4.442900E+01/ + data absb(:,1161:1175) / & + & 7.764100E-09,1.787300E-08,4.599400E-08,2.249300E-07,2.685200E-06,& + & 1.357800E-05,5.768300E-05,3.332400E-04,7.914400E-03,6.777800E-02,& + & 1.916900E-01,8.081100E-01,3.801200E+00,5.369200E+01,1.361100E+03,& + & 5.253400E+03,1.068800E-08,2.361200E-08,5.969400E-08,3.106000E-07,& + & 2.834100E-06,1.280900E-05,5.390500E-05,3.148000E-04,7.608200E-03,& + & 6.572400E-02,1.939000E-01,7.982300E-01,3.479600E+00,4.656800E+01,& + & 1.176300E+03,4.540100E+03,1.120000E-08,2.404600E-08,6.145200E-08,& + & 3.084100E-07,2.471700E-06,1.052700E-05,4.394200E-05,2.571600E-04,& + & 6.188600E-03,5.354800E-02,1.603700E-01,6.748900E-01,3.022000E+00,& + & 3.731400E+01,9.251000E+02,3.570400E+03,1.088900E-08,2.109800E-08,& + & 5.650500E-08,2.605200E-07,1.757200E-06,6.884400E-06,2.829900E-05,& + & 1.661000E-04,3.964700E-03,3.408500E-02,1.039400E-01,4.413800E-01,& + & 2.069700E+00,2.459100E+01,5.639300E+02,2.176100E+03,2.739400E-09,& + & 5.459300E-09,8.844300E-09,1.773500E-08,3.466000E-08,8.103700E-08,& + & 2.349600E-07,1.232900E-06,3.243500E-05,2.312700E-04,5.937400E-04,& + & 2.570900E-03,1.097000E-02,6.706100E-02,6.320100E+00,6.584400E+01,& + & 7.575600E-09,2.020100E-08,6.048700E-08,4.320200E-07,4.957500E-06,& + & 2.297200E-05,9.932300E-05,6.400000E-04,1.556200E-02,1.297300E-01,& + & 4.117000E-01,1.605800E+00,7.266800E+00,9.683100E+01,2.042900E+03,& + & 7.155500E+03,1.192700E-08,2.828700E-08,8.568500E-08,5.817200E-07,& + & 5.110400E-06,2.177500E-05,9.308800E-05,6.078600E-04,1.491700E-02,& + & 1.274900E-01,4.145900E-01,1.551200E+00,6.553400E+00,8.385200E+01,& + & 1.765500E+03,6.183900E+03,1.308300E-08,2.990500E-08,9.174300E-08,& + & 5.665400E-07,4.391500E-06,1.789100E-05,7.592700E-05,4.969100E-04,& + & 1.212700E-02,1.043900E-01,3.438600E-01,1.313800E+00,5.633200E+00,& + & 6.681000E+01,1.388400E+03,4.863200E+03,1.266700E-08,2.847300E-08,& + & 8.681800E-08,4.682900E-07,3.048500E-06,1.169000E-05,4.881300E-05,& + & 3.211200E-04,7.757900E-03,6.670500E-02,2.229700E-01,8.624400E-01,& + & 3.861100E+00,4.332400E+01,8.462300E+02,2.964000E+03,3.931300E-09,& + & 7.479100E-09,1.287900E-08,2.581800E-08,4.956600E-08,1.173500E-07,& + & 3.492200E-07,1.916500E-06,5.486200E-05,3.994900E-04,1.008200E-03,& + & 4.275300E-03,1.531700E-02,1.082500E-01,9.980400E+00,9.360800E+01,& + & 7.888600E-09,2.490500E-08,9.318800E-08,8.252300E-07,8.432000E-06,& + & 3.729600E-05,1.645100E-04,1.202000E-03,2.878900E-02,2.538300E-01,& + & 8.183900E-01,2.924900E+00,1.291100E+01,1.612900E+02,2.870000E+03,& + & 9.506900E+03,1.408800E-08,3.706500E-08,1.372200E-07,1.056300E-06,& + & 8.539800E-06,3.549000E-05,1.550700E-04,1.145600E-03,2.760700E-02,& + & 2.500600E-01,8.110700E-01,2.773000E+00,1.153600E+01,1.395100E+02,& + & 2.480300E+03,8.216000E+03,1.599200E-08,4.070300E-08,1.475200E-07,& + & 1.005300E-06,7.246400E-06,2.915000E-05,1.266100E-04,9.358400E-04,& + & 2.244600E-02,2.052000E-01,6.747000E-01,2.351700E+00,9.791500E+00,& + & 1.107600E+02,1.950600E+03,6.461300E+03,1.568800E-08,4.012500E-08,& + & 1.389200E-07,8.085200E-07,4.941800E-06,1.900700E-05,8.143900E-05,& + & 6.039800E-04,1.435600E-02,1.315600E-01,4.362400E-01,1.552000E+00,& + & 6.722900E+00,7.088100E+01,1.188900E+03,3.938100E+03,4.820200E-09,& + & 1.039100E-08,1.799900E-08,3.557200E-08,6.810500E-08,1.627000E-07,& + & 5.009300E-07,2.863800E-06,8.915500E-05,6.655100E-04,1.686900E-03,& + & 6.336700E-03,2.201500E-02,1.765200E-01,1.473900E+01,1.285400E+02/ + +! --- the array ka_mxxx(NG03,9,19) contains the absorption coefficient for +! a minor species at the NG03=16 chosen g-values for a reference pressure +! level below 100~ mb. the first index in the array, js, runs from 1 +! to 9, and corresponds to different gas column amount ratios, as +! expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +! reference mls column amount value of gas1 to that of gas2. the +! second index refers to temperature in 7.2 degree increments. for +! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers to +! 195.2, etc. the third index runs over the g-channel (1 to NG03=16). + + data ka_mn2o(:,:, 1) / & + & 1.281780E-05,1.621520E-03,5.265780E-02,4.651350E-01,1.538850E+00,& + & 1.838090E+00,3.227050E+00,2.146410E+00,1.564830E+00,7.686160E-01,& + & 6.910620E-01,5.307960E-01,2.419660E-01,9.083400E-02,8.802470E-02,& + & 8.846060E-02,1.007250E-01,3.737160E-01,8.183930E-01,9.715920E-01,& + & 1.833680E+00,1.826240E+00,1.438110E+00,8.836870E-01,4.095260E-01,& + & 4.972710E-01,1.986980E-01,1.384690E-01,1.543850E-01,3.369450E-02,& + & 3.891070E-07,8.138980E-07,1.941430E-01,5.462400E-01,1.024540E+00,& + & 1.480900E+00,1.495930E+00,1.354420E+00,1.225860E+00,4.498400E-01,& + & 3.356720E-01,2.444430E-01,2.119500E-01,1.507410E-01,2.005180E-01,& + & 9.116780E-02,3.865370E-07,8.326660E-07,2.981270E-01,8.353990E-01,& + & 1.117550E+00,1.505990E+00,1.400480E+00,1.105100E+00,7.943800E-01,& + & 3.922920E-01,3.191300E-01,2.019640E-01,3.142100E-01,1.804440E-01,& + & 2.039740E-01,8.439990E-02,3.819130E-07,8.703480E-07,4.450290E-01,& + & 1.044330E+00,1.419930E+00,1.253960E+00,1.222530E+00,1.010830E+00,& + & 4.469350E-01,3.389200E-01,3.043850E-01,2.569720E-01,3.135360E-01,& + & 1.805950E-01,2.094100E-01,7.412790E-02,3.772650E-07,9.079570E-07,& + & 7.156770E-01,1.223410E+00,1.377250E+00,1.271040E+00,1.079300E+00,& + & 5.914150E-01,4.202110E-01,3.016730E-01,2.987890E-01,2.573220E-01,& + & 3.132150E-01,1.799040E-01,2.198080E-01,5.668050E-02,3.778770E-07,& + & 8.590720E-04,9.896050E-01,1.675950E+00,1.345790E+00,9.578770E-01,& + & 7.870660E-01,3.681890E-01,3.420940E-01,2.993810E-01,3.087120E-01,& + & 2.565510E-01,3.142360E-01,1.787120E-01,2.470740E-01,1.230180E-02,& + & 3.804950E-07,9.172940E-07,1.122290E+00,2.768900E+00,9.152680E-01,& + & 4.757870E-01,3.833620E-01,2.987210E-01,2.949190E-01,2.875590E-01,& + & 3.105710E-01,2.736290E-01,2.974530E-01,1.723460E-01,2.552820E-01,& + & 3.224030E-07,3.878810E-07,9.173410E-07,7.209590E-01,8.009440E-01,& + & 1.125140E+00,2.425330E+00,8.972780E-01,3.761160E-01,2.974410E-01,& + & 2.962380E-01,3.164360E-01,2.572940E-01,3.126940E-01,1.805170E-01,& + & 2.099910E-01,7.330520E-02,3.772650E-07,9.079570E-07 / + data ka_mn2o(:,:, 2) / & + & 1.554720E-05,1.816270E-03,5.590000E-02,4.696770E-01,1.535900E+00,& + & 1.840360E+00,3.219660E+00,2.125850E+00,1.557920E+00,7.632630E-01,& + & 6.841510E-01,5.504440E-01,2.505340E-01,9.504210E-02,9.017930E-02,& + & 9.059710E-02,1.044700E-01,3.724910E-01,8.206230E-01,9.744720E-01,& + & 1.835300E+00,1.815640E+00,1.423670E+00,8.831700E-01,4.103010E-01,& + & 5.100540E-01,2.011820E-01,1.409590E-01,1.540150E-01,3.451440E-02,& + & 4.537680E-07,9.491300E-07,1.973800E-01,5.429720E-01,1.032100E+00,& + & 1.482380E+00,1.492790E+00,1.341740E+00,1.216390E+00,4.526830E-01,& + & 3.389820E-01,2.470960E-01,2.135600E-01,1.508550E-01,1.949010E-01,& + & 8.857610E-02,4.507630E-07,9.710210E-07,3.000160E-01,8.367660E-01,& + & 1.123480E+00,1.505410E+00,1.392280E+00,1.094730E+00,7.927950E-01,& + & 3.935740E-01,3.230280E-01,2.028690E-01,3.131430E-01,1.799440E-01,& + & 1.982580E-01,8.200040E-02,4.453690E-07,1.014960E-06,4.452430E-01,& + & 1.048640E+00,1.423530E+00,1.252300E+00,1.212020E+00,1.002210E+00,& + & 4.497600E-01,3.411510E-01,3.071550E-01,2.568370E-01,3.124590E-01,& + & 1.800330E-01,2.035430E-01,7.201960E-02,4.399510E-07,1.058820E-06,& + & 7.145640E-01,1.228850E+00,1.380290E+00,1.264160E+00,1.069980E+00,& + & 5.904270E-01,4.217110E-01,3.047520E-01,3.009960E-01,2.571870E-01,& + & 3.121230E-01,1.792540E-01,2.136430E-01,5.506760E-02,4.406700E-07,& + & 9.197730E-04,9.851280E-01,1.682960E+00,1.345840E+00,9.497120E-01,& + & 7.827670E-01,3.700290E-01,3.435890E-01,3.024310E-01,3.104910E-01,& + & 2.564210E-01,3.131230E-01,1.778680E-01,2.401270E-01,1.195170E-02,& + & 4.437260E-07,1.069710E-06,1.115020E+00,2.769810E+00,9.127790E-01,& + & 4.772080E-01,3.844050E-01,2.999320E-01,2.974600E-01,2.891530E-01,& + & 3.122620E-01,2.734600E-01,2.964200E-01,1.708730E-01,2.481050E-01,& + & 3.759860E-07,4.523290E-07,1.069770E-06,7.228390E-01,7.955310E-01,& + & 1.135230E+00,2.413570E+00,8.928730E-01,3.772760E-01,2.992070E-01,& + & 2.975880E-01,3.182000E-01,2.571490E-01,3.116220E-01,1.799510E-01,& + & 2.041030E-01,7.121990E-02,4.399510E-07,1.058820E-06 / + data ka_mn2o(:,:, 3) / & + & 1.885780E-05,2.034430E-03,5.934190E-02,4.742640E-01,1.532970E+00,& + & 1.842640E+00,3.212300E+00,2.105490E+00,1.551050E+00,7.579480E-01,& + & 6.773090E-01,5.708180E-01,2.594060E-01,9.944520E-02,9.238680E-02,& + & 9.278520E-02,1.083550E-01,3.712710E-01,8.228600E-01,9.773600E-01,& + & 1.836920E+00,1.805100E+00,1.409380E+00,8.826540E-01,4.110780E-01,& + & 5.231650E-01,2.036980E-01,1.434930E-01,1.536460E-01,3.535420E-02,& + & 5.291730E-07,1.106830E-06,2.006700E-01,5.397240E-01,1.039720E+00,& + & 1.483850E+00,1.489650E+00,1.329180E+00,1.207000E+00,4.555430E-01,& + & 3.423260E-01,2.497780E-01,2.151840E-01,1.509690E-01,1.894420E-01,& + & 8.605800E-02,5.256620E-07,1.132370E-06,3.019160E-01,8.381350E-01,& + & 1.129440E+00,1.504830E+00,1.384130E+00,1.084460E+00,7.912130E-01,& + & 3.948610E-01,3.269730E-01,2.037770E-01,3.120800E-01,1.794450E-01,& + & 1.927030E-01,7.966920E-02,5.193690E-07,1.183600E-06,4.454580E-01,& + & 1.052970E+00,1.427130E+00,1.250650E+00,1.201600E+00,9.936560E-01,& + & 4.526020E-01,3.433970E-01,3.099490E-01,2.567020E-01,3.113860E-01,& + & 1.794740E-01,1.978410E-01,6.997120E-02,5.130530E-07,1.234750E-06,& + & 7.134520E-01,1.234310E+00,1.383340E+00,1.257310E+00,1.060750E+00,& + & 5.894410E-01,4.232160E-01,3.078630E-01,3.032200E-01,2.570520E-01,& + & 3.110340E-01,1.786070E-01,2.076510E-01,5.350060E-02,5.138970E-07,& + & 9.847640E-04,9.806710E-01,1.690000E+00,1.345890E+00,9.416170E-01,& + & 7.784900E-01,3.718770E-01,3.450910E-01,3.055120E-01,3.122810E-01,& + & 2.562910E-01,3.120140E-01,1.770270E-01,2.333750E-01,1.161160E-02,& + & 5.174650E-07,1.247460E-06,1.107790E+00,2.770720E+00,9.102980E-01,& + & 4.786330E-01,3.854520E-01,3.011490E-01,3.000220E-01,2.907560E-01,& + & 3.139610E-01,2.732910E-01,2.953910E-01,1.694130E-01,2.411300E-01,& + & 4.384750E-07,5.274860E-07,1.247520E-06,7.247230E-01,7.901550E-01,& + & 1.145410E+00,2.401880E+00,8.884900E-01,3.784390E-01,3.009840E-01,& + & 2.989450E-01,3.199740E-01,2.570040E-01,3.105540E-01,1.793860E-01,& + & 1.983800E-01,6.919390E-02,5.130530E-07,1.234750E-06 / + data ka_mn2o(:,:, 4) / & + & 2.287350E-05,2.278780E-03,6.299570E-02,4.788950E-01,1.530040E+00,& + & 1.844910E+00,3.204940E+00,2.085320E+00,1.544200E+00,7.526690E-01,& + & 6.705350E-01,5.919470E-01,2.685910E-01,1.040520E-01,9.464820E-02,& + & 9.502610E-02,1.123840E-01,3.700540E-01,8.251030E-01,9.802570E-01,& + & 1.838540E+00,1.794630E+00,1.395220E+00,8.821370E-01,4.118570E-01,& + & 5.366140E-01,2.062440E-01,1.460730E-01,1.532790E-01,3.621440E-02,& + & 6.171090E-07,1.290730E-06,2.040160E-01,5.364950E-01,1.047400E+00,& + & 1.485320E+00,1.486520E+00,1.316730E+00,1.197670E+00,4.584210E-01,& + & 3.457020E-01,2.524890E-01,2.168190E-01,1.510840E-01,1.841360E-01,& + & 8.361160E-02,6.130060E-07,1.320520E-06,3.038290E-01,8.395070E-01,& + & 1.135430E+00,1.504260E+00,1.376030E+00,1.074290E+00,7.896340E-01,& + & 3.961510E-01,3.309660E-01,2.046900E-01,3.110210E-01,1.789480E-01,& + & 1.873020E-01,7.740420E-02,6.056640E-07,1.380260E-06,4.456730E-01,& + & 1.057310E+00,1.430740E+00,1.249000E+00,1.191260E+00,9.851780E-01,& + & 4.554620E-01,3.456580E-01,3.127700E-01,2.565670E-01,3.103160E-01,& + & 1.789160E-01,1.922980E-01,6.798110E-02,5.983030E-07,1.439910E-06,& + & 7.123420E-01,1.239800E+00,1.386400E+00,1.250500E+00,1.051590E+00,& + & 5.884570E-01,4.247260E-01,3.110050E-01,3.054600E-01,2.569170E-01,& + & 3.099490E-01,1.779620E-01,2.018270E-01,5.197820E-02,5.992920E-07,& + & 1.054350E-03,9.762340E-01,1.697070E+00,1.345940E+00,9.335910E-01,& + & 7.742370E-01,3.737350E-01,3.466000E-01,3.086240E-01,3.140800E-01,& + & 2.561610E-01,3.109080E-01,1.761900E-01,2.268130E-01,1.128110E-02,& + & 6.034580E-07,1.454740E-06,1.100610E+00,2.771630E+00,9.078230E-01,& + & 4.800630E-01,3.865010E-01,3.023700E-01,3.026060E-01,2.923670E-01,& + & 3.156700E-01,2.731220E-01,2.943660E-01,1.679650E-01,2.343500E-01,& + & 5.113490E-07,6.151290E-07,1.454800E-06,7.266120E-01,7.848150E-01,& + & 1.155680E+00,2.390240E+00,8.841280E-01,3.796060E-01,3.027720E-01,& + & 3.003090E-01,3.217590E-01,2.568600E-01,3.094890E-01,1.788230E-01,& + & 1.928180E-01,6.722550E-02,5.983030E-07,1.439910E-06 / + data ka_mn2o(:,:, 5) / & + & 2.774420E-05,2.552480E-03,6.687440E-02,4.835720E-01,1.527110E+00,& + & 1.847200E+00,3.197610E+00,2.065340E+00,1.537390E+00,7.474280E-01,& + & 6.638290E-01,6.138570E-01,2.781020E-01,1.088730E-01,9.696500E-02,& + & 9.732120E-02,1.165630E-01,3.688410E-01,8.273520E-01,9.831630E-01,& + & 1.840160E+00,1.784210E+00,1.381210E+00,8.816210E-01,4.126370E-01,& + & 5.504080E-01,2.088230E-01,1.486990E-01,1.529120E-01,3.709560E-02,& + & 7.196580E-07,1.505190E-06,2.074170E-01,5.332850E-01,1.055140E+00,& + & 1.486800E+00,1.483400E+00,1.304400E+00,1.188420E+00,4.613180E-01,& + & 3.491110E-01,2.552290E-01,2.184670E-01,1.511980E-01,1.789780E-01,& + & 8.123470E-02,7.148630E-07,1.539940E-06,3.057540E-01,8.408800E-01,& + & 1.141460E+00,1.503680E+00,1.367980E+00,1.064200E+00,7.880590E-01,& + & 3.974460E-01,3.350080E-01,2.056060E-01,3.099650E-01,1.784520E-01,& + & 1.820540E-01,7.520370E-02,7.062970E-07,1.609590E-06,4.458890E-01,& + & 1.061680E+00,1.434360E+00,1.247350E+00,1.181020E+00,9.767720E-01,& + & 4.583400E-01,3.479340E-01,3.156160E-01,2.564320E-01,3.092500E-01,& + & 1.783590E-01,1.869110E-01,6.604760E-02,6.977170E-07,1.679160E-06,& + & 7.112340E-01,1.245310E+00,1.389470E+00,1.243730E+00,1.042510E+00,& + & 5.874740E-01,4.262420E-01,3.141800E-01,3.077170E-01,2.567820E-01,& + & 3.088670E-01,1.773200E-01,1.961660E-01,5.049910E-02,6.988780E-07,& + & 1.128850E-03,9.718170E-01,1.704170E+00,1.345990E+00,9.256330E-01,& + & 7.700080E-01,3.756030E-01,3.481150E-01,3.117680E-01,3.158900E-01,& + & 2.560300E-01,3.098060E-01,1.753570E-01,2.204360E-01,1.096010E-02,& + & 7.037410E-07,1.696460E-06,1.093480E+00,2.772540E+00,9.053550E-01,& + & 4.814960E-01,3.875520E-01,3.035970E-01,3.052120E-01,2.939870E-01,& + & 3.173880E-01,2.729530E-01,2.933440E-01,1.665300E-01,2.277620E-01,& + & 5.963350E-07,7.173350E-07,1.696530E-06,7.285060E-01,7.795110E-01,& + & 1.166040E+00,2.378660E+00,8.797870E-01,3.807770E-01,3.045700E-01,& + & 3.016780E-01,3.235530E-01,2.567150E-01,3.084280E-01,1.782620E-01,& + & 1.874110E-01,6.531310E-02,6.977170E-07,1.679160E-06 / + data ka_mn2o(:,:, 6) / & + & 3.365200E-05,2.859060E-03,7.099200E-02,4.882940E-01,1.524190E+00,& + & 1.849480E+00,3.190290E+00,2.045560E+00,1.530600E+00,7.422230E-01,& + & 6.571900E-01,6.365790E-01,2.879500E-01,1.139170E-01,9.933850E-02,& + & 9.967170E-02,1.208980E-01,3.676330E-01,8.296080E-01,9.860770E-01,& + & 1.841780E+00,1.773860E+00,1.367350E+00,8.811060E-01,4.134180E-01,& + & 5.645560E-01,2.114330E-01,1.513730E-01,1.525450E-01,3.799820E-02,& + & 8.392480E-07,1.755280E-06,2.108750E-01,5.300950E-01,1.062930E+00,& + & 1.488280E+00,1.480280E+00,1.292190E+00,1.179240E+00,4.642330E-01,& + & 3.525540E-01,2.579990E-01,2.201270E-01,1.513130E-01,1.739650E-01,& + & 7.892530E-02,8.336440E-07,1.795810E-06,3.076910E-01,8.422560E-01,& + & 1.147520E+00,1.503100E+00,1.359970E+00,1.054220E+00,7.864860E-01,& + & 3.987460E-01,3.391000E-01,2.065270E-01,3.089130E-01,1.779580E-01,& + & 1.769520E-01,7.306560E-02,8.236510E-07,1.877030E-06,4.461040E-01,& + & 1.066060E+00,1.437990E+00,1.245700E+00,1.170870E+00,9.684370E-01,& + & 4.612370E-01,3.502250E-01,3.184880E-01,2.562970E-01,3.081880E-01,& + & 1.778050E-01,1.816740E-01,6.416910E-02,8.136500E-07,1.958160E-06,& + & 7.101270E-01,1.250840E+00,1.392540E+00,1.237000E+00,1.033520E+00,& + & 5.864930E-01,4.277630E-01,3.173870E-01,3.099900E-01,2.566470E-01,& + & 3.077900E-01,1.766800E-01,1.906640E-01,4.906210E-02,8.150120E-07,& + & 1.208610E-03,9.674210E-01,1.711300E+00,1.346030E+00,9.177430E-01,& + & 7.658010E-01,3.774790E-01,3.496370E-01,3.149450E-01,3.177100E-01,& + & 2.559000E-01,3.087090E-01,1.745280E-01,2.142380E-01,1.064820E-02,& + & 8.206890E-07,1.978350E-06,1.086390E+00,2.773450E+00,9.028930E-01,& + & 4.829340E-01,3.886070E-01,3.048280E-01,3.078410E-01,2.956170E-01,& + & 3.191150E-01,2.727840E-01,2.923250E-01,1.651070E-01,2.213580E-01,& + & 6.954460E-07,8.365230E-07,1.978430E-06,7.304050E-01,7.742430E-01,& + & 1.176490E+00,2.367130E+00,8.754680E-01,3.819510E-01,3.063790E-01,& + & 3.030540E-01,3.253570E-01,2.565700E-01,3.073700E-01,1.777020E-01,& + & 1.821560E-01,6.345510E-02,8.136500E-07,1.958160E-06 / + data ka_mn2o(:,:, 7) / & + & 4.081790E-05,3.202450E-03,7.536310E-02,4.930630E-01,1.521280E+00,& + & 1.851770E+00,3.182990E+00,2.025960E+00,1.523840E+00,7.370540E-01,& + & 6.506170E-01,6.601420E-01,2.981460E-01,1.191940E-01,1.017700E-01,& + & 1.020790E-01,1.253940E-01,3.664280E-01,8.318690E-01,9.890000E-01,& + & 1.843400E+00,1.763560E+00,1.353620E+00,8.805900E-01,4.142010E-01,& + & 5.790690E-01,2.140770E-01,1.540940E-01,1.521800E-01,3.892280E-02,& + & 9.787100E-07,2.046930E-06,2.143900E-01,5.269230E-01,1.070770E+00,& + & 1.489760E+00,1.477170E+00,1.280100E+00,1.170140E+00,4.671660E-01,& + & 3.560310E-01,2.607990E-01,2.218000E-01,1.514270E-01,1.690920E-01,& + & 7.668170E-02,9.721620E-07,2.094200E-06,3.096400E-01,8.436350E-01,& + & 1.153600E+00,1.502520E+00,1.352010E+00,1.044330E+00,7.849170E-01,& + & 4.000490E-01,3.432410E-01,2.074520E-01,3.078640E-01,1.774650E-01,& + & 1.719930E-01,7.098840E-02,9.605030E-07,2.188900E-06,4.463190E-01,& + & 1.070460E+00,1.441630E+00,1.244050E+00,1.160800E+00,9.601740E-01,& + & 4.641520E-01,3.525310E-01,3.213860E-01,2.561620E-01,3.071290E-01,& + & 1.772520E-01,1.765850E-01,6.234400E-02,9.488460E-07,2.283520E-06,& + & 7.090220E-01,1.256400E+00,1.395620E+00,1.230300E+00,1.024590E+00,& + & 5.855140E-01,4.292900E-01,3.206260E-01,3.122810E-01,2.565120E-01,& + & 3.067160E-01,1.760420E-01,1.853170E-01,4.766590E-02,9.504440E-07,& + & 1.294010E-03,9.630440E-01,1.718460E+00,1.346080E+00,9.099200E-01,& + & 7.616170E-01,3.793650E-01,3.511650E-01,3.181530E-01,3.195410E-01,& + & 2.557700E-01,3.076150E-01,1.737030E-01,2.082150E-01,1.034520E-02,& + & 9.570720E-07,2.307080E-06,1.079350E+00,2.774360E+00,9.004380E-01,& + & 4.843770E-01,3.896650E-01,3.060640E-01,3.104920E-01,2.972550E-01,& + & 3.208520E-01,2.726150E-01,2.913110E-01,1.636960E-01,2.151350E-01,& + & 8.110280E-07,9.755150E-07,2.307160E-06,7.323090E-01,7.690110E-01,& + & 1.187040E+00,2.355660E+00,8.711700E-01,3.831290E-01,3.081990E-01,& + & 3.044360E-01,3.271720E-01,2.564260E-01,3.063160E-01,1.771440E-01,& + & 1.770480E-01,6.165000E-02,9.488460E-07,2.283520E-06 / + data ka_mn2o(:,:, 8) / & + & 4.950980E-05,3.587100E-03,8.000340E-02,4.978780E-01,1.518370E+00,& + & 1.854060E+00,3.175710E+00,2.006560E+00,1.517120E+00,7.319210E-01,& + & 6.441110E-01,6.845770E-01,3.087040E-01,1.247160E-01,1.042610E-01,& + & 1.045440E-01,1.300570E-01,3.652270E-01,8.341370E-01,9.919310E-01,& + & 1.845030E+00,1.753330E+00,1.340020E+00,8.800750E-01,4.149860E-01,& + & 5.939540E-01,2.167530E-01,1.568650E-01,1.518160E-01,3.986980E-02,& + & 1.141350E-06,2.387030E-06,2.179640E-01,5.237710E-01,1.078680E+00,& + & 1.491240E+00,1.474060E+00,1.268110E+00,1.161100E+00,4.701180E-01,& + & 3.595430E-01,2.636300E-01,2.234860E-01,1.515420E-01,1.643560E-01,& + & 7.450170E-02,1.133700E-06,2.442170E-06,3.116010E-01,8.450150E-01,& + & 1.159720E+00,1.501950E+00,1.344100E+00,1.034530E+00,7.833510E-01,& + & 4.013570E-01,3.474330E-01,2.083810E-01,3.068190E-01,1.769730E-01,& + & 1.671730E-01,6.897020E-02,1.120090E-06,2.552590E-06,4.465350E-01,& + & 1.074880E+00,1.445280E+00,1.242410E+00,1.150820E+00,9.519810E-01,& + & 4.670850E-01,3.548520E-01,3.243100E-01,2.560270E-01,3.060740E-01,& + & 1.767010E-01,1.716370E-01,6.057080E-02,1.106510E-06,2.662940E-06,& + & 7.079190E-01,1.261990E+00,1.398700E+00,1.223640E+00,1.015750E+00,& + & 5.845360E-01,4.308220E-01,3.238990E-01,3.145880E-01,2.563770E-01,& + & 3.056460E-01,1.754060E-01,1.801190E-01,4.630960E-02,1.108380E-06,& + & 1.385440E-03,9.586870E-01,1.725650E+00,1.346130E+00,9.021640E-01,& + & 7.574570E-01,3.812600E-01,3.527000E-01,3.213940E-01,3.213820E-01,& + & 2.556400E-01,3.065250E-01,1.728820E-01,2.023600E-01,1.005080E-02,& + & 1.116120E-06,2.690430E-06,1.072350E+00,2.775270E+00,8.979900E-01,& + & 4.858230E-01,3.907250E-01,3.073060E-01,3.131670E-01,2.989020E-01,& + & 3.225980E-01,2.724470E-01,2.902990E-01,1.622970E-01,2.090860E-01,& + & 9.458210E-07,1.137600E-06,2.690510E-06,7.342180E-01,7.638130E-01,& + & 1.197680E+00,2.344250E+00,8.668930E-01,3.843100E-01,3.100290E-01,& + & 3.058240E-01,3.289960E-01,2.562820E-01,3.052660E-01,1.765880E-01,& + & 1.720840E-01,5.989630E-02,1.106510E-06,2.662940E-06 / + data ka_mn2o(:,:, 9) / & + & 6.005250E-05,4.017940E-03,8.492940E-02,5.027400E-01,1.515470E+00,& + & 1.856350E+00,3.168440E+00,1.987330E+00,1.510420E+00,7.268240E-01,& + & 6.376690E-01,7.099160E-01,3.196350E-01,1.304940E-01,1.068130E-01,& + & 1.070690E-01,1.348930E-01,3.640310E-01,8.364100E-01,9.948710E-01,& + & 1.846650E+00,1.743150E+00,1.326570E+00,8.795600E-01,4.157710E-01,& + & 6.092220E-01,2.194630E-01,1.596850E-01,1.514520E-01,4.083990E-02,& + & 1.331010E-06,2.783640E-06,2.215980E-01,5.206370E-01,1.086650E+00,& + & 1.492720E+00,1.470960E+00,1.256240E+00,1.152130E+00,4.730880E-01,& + & 3.630890E-01,2.664910E-01,2.251850E-01,1.516570E-01,1.597520E-01,& + & 7.238380E-02,1.322070E-06,2.847960E-06,3.135750E-01,8.463980E-01,& + & 1.165880E+00,1.501370E+00,1.336230E+00,1.024820E+00,7.817870E-01,& + & 4.026690E-01,3.516760E-01,2.093140E-01,3.057770E-01,1.764830E-01,& + & 1.624890E-01,6.700940E-02,1.306200E-06,2.976710E-06,4.467500E-01,& + & 1.079320E+00,1.448940E+00,1.240770E+00,1.140920E+00,9.438590E-01,& + & 4.700370E-01,3.571890E-01,3.272610E-01,2.558930E-01,3.050220E-01,& + & 1.761520E-01,1.668290E-01,5.884810E-02,1.290360E-06,3.105410E-06,& + & 7.068180E-01,1.267600E+00,1.401790E+00,1.217010E+00,1.006980E+00,& + & 5.835590E-01,4.323590E-01,3.272050E-01,3.169120E-01,2.562430E-01,& + & 3.045790E-01,1.747730E-01,1.750670E-01,4.499180E-02,1.292560E-06,& + & 1.483340E-03,9.543500E-01,1.732870E+00,1.346180E+00,8.944730E-01,& + & 7.533190E-01,3.831650E-01,3.542420E-01,3.246680E-01,3.232340E-01,& + & 2.555110E-01,3.054390E-01,1.720640E-01,1.966710E-01,9.764740E-03,& + & 1.301600E-06,3.137480E-06,1.065400E+00,2.776180E+00,8.955490E-01,& + & 4.872740E-01,3.917880E-01,3.085520E-01,3.158640E-01,3.005590E-01,& + & 3.243540E-01,2.722790E-01,2.892910E-01,1.609100E-01,2.032080E-01,& + & 1.103020E-06,1.326620E-06,3.137570E-06,7.361320E-01,7.586520E-01,& + & 1.208410E+00,2.332890E+00,8.626370E-01,3.854950E-01,3.118700E-01,& + & 3.072190E-01,3.308310E-01,2.561370E-01,3.042200E-01,1.760340E-01,& + & 1.672590E-01,5.819240E-02,1.290360E-06,3.105410E-06 / + data ka_mn2o(:,:,10) / & + & 7.284010E-05,4.500530E-03,9.015860E-02,5.076490E-01,1.512570E+00,& + & 1.858640E+00,3.161190E+00,1.968300E+00,1.503760E+00,7.217620E-01,& + & 6.312920E-01,7.361940E-01,3.309530E-01,1.365400E-01,1.094280E-01,& + & 1.096550E-01,1.399090E-01,3.628380E-01,8.386900E-01,9.978200E-01,& + & 1.848280E+00,1.733040E+00,1.313250E+00,8.790460E-01,4.165590E-01,& + & 6.248830E-01,2.222070E-01,1.625560E-01,1.510890E-01,4.183360E-02,& + & 1.552200E-06,3.246150E-06,2.252920E-01,5.175230E-01,1.094670E+00,& + & 1.494200E+00,1.467870E+00,1.244480E+00,1.143230E+00,4.760780E-01,& + & 3.666700E-01,2.693830E-01,2.268960E-01,1.517720E-01,1.552780E-01,& + & 7.032610E-02,1.541750E-06,3.321170E-06,3.155620E-01,8.477830E-01,& + & 1.172060E+00,1.500790E+00,1.328410E+00,1.015200E+00,7.802270E-01,& + & 4.039850E-01,3.559710E-01,2.102510E-01,3.047390E-01,1.759940E-01,& + & 1.579350E-01,6.510440E-02,1.523230E-06,3.471300E-06,4.469660E-01,& + & 1.083770E+00,1.452610E+00,1.239130E+00,1.131110E+00,9.358050E-01,& + & 4.730070E-01,3.595410E-01,3.302390E-01,2.557580E-01,3.039740E-01,& + & 1.756040E-01,1.621550E-01,5.717430E-02,1.504770E-06,3.621390E-06,& + & 7.057180E-01,1.273230E+00,1.404890E+00,1.210430E+00,9.982910E-01,& + & 5.825850E-01,4.339020E-01,3.305450E-01,3.192530E-01,2.561080E-01,& + & 3.035170E-01,1.741420E-01,1.701570E-01,4.371150E-02,1.507350E-06,& + & 1.588150E-03,9.500320E-01,1.740120E+00,1.346230E+00,8.868490E-01,& + & 7.492030E-01,3.850790E-01,3.557910E-01,3.279760E-01,3.250970E-01,& + & 2.553810E-01,3.043570E-01,1.712510E-01,1.911410E-01,9.486850E-03,& + & 1.517900E-06,3.658800E-06,1.058500E+00,2.777090E+00,8.931140E-01,& + & 4.887300E-01,3.928550E-01,3.098040E-01,3.185840E-01,3.022250E-01,& + & 3.261200E-01,2.721100E-01,2.882870E-01,1.595350E-01,1.974950E-01,& + & 1.286340E-06,1.547040E-06,3.658900E-06,7.380510E-01,7.535250E-01,& + & 1.219250E+00,2.321580E+00,8.584020E-01,3.866840E-01,3.137230E-01,& + & 3.086200E-01,3.326750E-01,2.559930E-01,3.031770E-01,1.754810E-01,& + & 1.625690E-01,5.653700E-02,1.504770E-06,3.621390E-06 / + data ka_mn2o(:,:,11) / & + & 8.835080E-05,5.041090E-03,9.570990E-02,5.126070E-01,1.509680E+00,& + & 1.860940E+00,3.153950E+00,1.949440E+00,1.497120E+00,7.167360E-01,& + & 6.249780E-01,7.634440E-01,3.426720E-01,1.428650E-01,1.121070E-01,& + & 1.123040E-01,1.451120E-01,3.616490E-01,8.409760E-01,1.000780E+00,& + & 1.849910E+00,1.722980E+00,1.300060E+00,8.785310E-01,4.173480E-01,& + & 6.409460E-01,2.249850E-01,1.654780E-01,1.507280E-01,4.285150E-02,& + & 1.810130E-06,3.785510E-06,2.290480E-01,5.144260E-01,1.102750E+00,& + & 1.495690E+00,1.464790E+00,1.232830E+00,1.134400E+00,4.790860E-01,& + & 3.702860E-01,2.723070E-01,2.286210E-01,1.518870E-01,1.509280E-01,& + & 6.832690E-02,1.797920E-06,3.873020E-06,3.175610E-01,8.491700E-01,& + & 1.178280E+00,1.500220E+00,1.320640E+00,1.005680E+00,7.786710E-01,& + & 4.053060E-01,3.603190E-01,2.111930E-01,3.037050E-01,1.755060E-01,& + & 1.535090E-01,6.325350E-02,1.776320E-06,4.048070E-06,4.471820E-01,& + & 1.088240E+00,1.456280E+00,1.237490E+00,1.121390E+00,9.278210E-01,& + & 4.759960E-01,3.619080E-01,3.332440E-01,2.556240E-01,3.029300E-01,& + & 1.750580E-01,1.576120E-01,5.554820E-02,1.754800E-06,4.223100E-06,& + & 7.046200E-01,1.278890E+00,1.408000E+00,1.203870E+00,9.896740E-01,& + & 5.816120E-01,4.354500E-01,3.339190E-01,3.216120E-01,2.559740E-01,& + & 3.024580E-01,1.735130E-01,1.653850E-01,4.246760E-02,1.757830E-06,& + & 1.700370E-03,9.457340E-01,1.747400E+00,1.346270E+00,8.792890E-01,& + & 7.451100E-01,3.870030E-01,3.573460E-01,3.313170E-01,3.269700E-01,& + & 2.552510E-01,3.032780E-01,1.704410E-01,1.857670E-01,9.216870E-03,& + & 1.770140E-06,4.266760E-06,1.051640E+00,2.778000E+00,8.906860E-01,& + & 4.901890E-01,3.939240E-01,3.110600E-01,3.213280E-01,3.038990E-01,& + & 3.278950E-01,2.719420E-01,2.872860E-01,1.581710E-01,1.919420E-01,& + & 1.500120E-06,1.804090E-06,4.266860E-06,7.399750E-01,7.484320E-01,& + & 1.230180E+00,2.310330E+00,8.541870E-01,3.878760E-01,3.155860E-01,& + & 3.100270E-01,3.345300E-01,2.558490E-01,3.021370E-01,1.749310E-01,& + & 1.580100E-01,5.492870E-02,1.754800E-06,4.223100E-06 / + data ka_mn2o(:,:,12) / & + & 1.071640E-04,5.646570E-03,1.016030E-01,5.176130E-01,1.506790E+00,& + & 1.863240E+00,3.146730E+00,1.930770E+00,1.490510E+00,7.117440E-01,& + & 6.187280E-01,7.917020E-01,3.548060E-01,1.494840E-01,1.148510E-01,& + & 1.150160E-01,1.505080E-01,3.604640E-01,8.432690E-01,1.003740E+00,& + & 1.851540E+00,1.712980E+00,1.287010E+00,8.780170E-01,4.181380E-01,& + & 6.574220E-01,2.277980E-01,1.684540E-01,1.503670E-01,4.389420E-02,& + & 2.110940E-06,4.414490E-06,2.328670E-01,5.113490E-01,1.110890E+00,& + & 1.497170E+00,1.461710E+00,1.221290E+00,1.125640E+00,4.821130E-01,& + & 3.739380E-01,2.752620E-01,2.303580E-01,1.520020E-01,1.467010E-01,& + & 6.638450E-02,2.096660E-06,4.516560E-06,3.195720E-01,8.505590E-01,& + & 1.184530E+00,1.499640E+00,1.312910E+00,9.962380E-01,7.771170E-01,& + & 4.066300E-01,3.647190E-01,2.121390E-01,3.026740E-01,1.750200E-01,& + & 1.492070E-01,6.145520E-02,2.071470E-06,4.720670E-06,4.473980E-01,& + & 1.092740E+00,1.459970E+00,1.235860E+00,1.111740E+00,9.199040E-01,& + & 4.790040E-01,3.642910E-01,3.362760E-01,2.554890E-01,3.018890E-01,& + & 1.745140E-01,1.531960E-01,5.396830E-02,2.046380E-06,4.924800E-06,& + & 7.035240E-01,1.284580E+00,1.411110E+00,1.197350E+00,9.811310E-01,& + & 5.806400E-01,4.370040E-01,3.373280E-01,3.239880E-01,2.558390E-01,& + & 3.014030E-01,1.728870E-01,1.607460E-01,4.125920E-02,2.049930E-06,& + & 1.820520E-03,9.414550E-01,1.754710E+00,1.346320E+00,8.717940E-01,& + & 7.410400E-01,3.889370E-01,3.589080E-01,3.346930E-01,3.288540E-01,& + & 2.551210E-01,3.022040E-01,1.696360E-01,1.805440E-01,8.954580E-03,& + & 2.064300E-06,4.975740E-06,1.044820E+00,2.778910E+00,8.882640E-01,& + & 4.916530E-01,3.949960E-01,3.123220E-01,3.240960E-01,3.055840E-01,& + & 3.296790E-01,2.717740E-01,2.862890E-01,1.568190E-01,1.865460E-01,& + & 1.749440E-06,2.103840E-06,4.975840E-06,7.419040E-01,7.433740E-01,& + & 1.241210E+00,2.299140E+00,8.499940E-01,3.890720E-01,3.174600E-01,& + & 3.114410E-01,3.363960E-01,2.557050E-01,3.011010E-01,1.743820E-01,& + & 1.535800E-01,5.336610E-02,2.046380E-06,4.924800E-06 / + data ka_mn2o(:,:,13) / & + & 1.299840E-04,6.324770E-03,1.078590E-01,5.226670E-01,1.503910E+00,& + & 1.865550E+00,3.139530E+00,1.912270E+00,1.483930E+00,7.067880E-01,& + & 6.125400E-01,8.210070E-01,3.673700E-01,1.564090E-01,1.176620E-01,& + & 1.177940E-01,1.561040E-01,3.592830E-01,8.455670E-01,1.006720E+00,& + & 1.853170E+00,1.703040E+00,1.274080E+00,8.775040E-01,4.189300E-01,& + & 6.743210E-01,2.306460E-01,1.714820E-01,1.500070E-01,4.496220E-02,& + & 2.461720E-06,5.147960E-06,2.367490E-01,5.082900E-01,1.119100E+00,& + & 1.498660E+00,1.458630E+00,1.209850E+00,1.116950E+00,4.851590E-01,& + & 3.776260E-01,2.782500E-01,2.321090E-01,1.521170E-01,1.425920E-01,& + & 6.449730E-02,2.445040E-06,5.267030E-06,3.215970E-01,8.519510E-01,& + & 1.190820E+00,1.499060E+00,1.305220E+00,9.868900E-01,7.755660E-01,& + & 4.079600E-01,3.691730E-01,2.130890E-01,3.016460E-01,1.745350E-01,& + & 1.450260E-01,5.970810E-02,2.415650E-06,5.505020E-06,4.476140E-01,& + & 1.097250E+00,1.463670E+00,1.234230E+00,1.102190E+00,9.120550E-01,& + & 4.820310E-01,3.666890E-01,3.393360E-01,2.553550E-01,3.008520E-01,& + & 1.739710E-01,1.489040E-01,5.243340E-02,2.386410E-06,5.743080E-06,& + & 7.024290E-01,1.290290E+00,1.414230E+00,1.190870E+00,9.726630E-01,& + & 5.796710E-01,4.385640E-01,3.407710E-01,3.263820E-01,2.557050E-01,& + & 3.003510E-01,1.722620E-01,1.562380E-01,4.008510E-02,2.390570E-06,& + & 1.949150E-03,9.371960E-01,1.762060E+00,1.346370E+00,8.643630E-01,& + & 7.369910E-01,3.908800E-01,3.604770E-01,3.381020E-01,3.307490E-01,& + & 2.549920E-01,3.011330E-01,1.688340E-01,1.754670E-01,8.699740E-03,& + & 2.407350E-06,5.802510E-06,1.038050E+00,2.779820E+00,8.858490E-01,& + & 4.931220E-01,3.960710E-01,3.135890E-01,3.268870E-01,3.072770E-01,& + & 3.314740E-01,2.716060E-01,2.852950E-01,1.554790E-01,1.813010E-01,& + & 2.040200E-06,2.453400E-06,5.802610E-06,7.438380E-01,7.383500E-01,& + & 1.252330E+00,2.288000E+00,8.458210E-01,3.902720E-01,3.193450E-01,& + & 3.128610E-01,3.382720E-01,2.555610E-01,3.000690E-01,1.738340E-01,& + & 1.492730E-01,5.184800E-02,2.386410E-06,5.743080E-06 / + data ka_mn2o(:,:,14) / & + & 1.576630E-04,7.084440E-03,1.145000E-01,5.277710E-01,1.501040E+00,& + & 1.867850E+00,3.132350E+00,1.893950E+00,1.477380E+00,7.018660E-01,& + & 6.064140E-01,8.513960E-01,3.803790E-01,1.636550E-01,1.205420E-01,& + & 1.206390E-01,1.619090E-01,3.581060E-01,8.478720E-01,1.009700E+00,& + & 1.854800E+00,1.693160E+00,1.261290E+00,8.769900E-01,4.197230E-01,& + & 6.916550E-01,2.335290E-01,1.745650E-01,1.496470E-01,4.605620E-02,& + & 2.870800E-06,6.003310E-06,2.406960E-01,5.052490E-01,1.127360E+00,& + & 1.500150E+00,1.455570E+00,1.198530E+00,1.108320E+00,4.882250E-01,& + & 3.813500E-01,2.812690E-01,2.338730E-01,1.522330E-01,1.385980E-01,& + & 6.266380E-02,2.851310E-06,6.142190E-06,3.236340E-01,8.533450E-01,& + & 1.197140E+00,1.498490E+00,1.297580E+00,9.776290E-01,7.740190E-01,& + & 4.092930E-01,3.736820E-01,2.140430E-01,3.006220E-01,1.740510E-01,& + & 1.409620E-01,5.801060E-02,2.817010E-06,6.419700E-06,4.478300E-01,& + & 1.101780E+00,1.467370E+00,1.232600E+00,1.092710E+00,9.042730E-01,& + & 4.850780E-01,3.691040E-01,3.424240E-01,2.552200E-01,2.998190E-01,& + & 1.734300E-01,1.447330E-01,5.094210E-02,2.782940E-06,6.697330E-06,& + & 7.013360E-01,1.296020E+00,1.417360E+00,1.184420E+00,9.642670E-01,& + & 5.787030E-01,4.401290E-01,3.442490E-01,3.287930E-01,2.555700E-01,& + & 2.993030E-01,1.716400E-01,1.518560E-01,3.894440E-02,2.787820E-06,& + & 2.086880E-03,9.329560E-01,1.769430E+00,1.346420E+00,8.569950E-01,& + & 7.329650E-01,3.928330E-01,3.620530E-01,3.415470E-01,3.326550E-01,& + & 2.548620E-01,3.000660E-01,1.680360E-01,1.705340E-01,8.452160E-03,& + & 2.807410E-06,6.766670E-06,1.031320E+00,2.780740E+00,8.834410E-01,& + & 4.945950E-01,3.971490E-01,3.148600E-01,3.297030E-01,3.089800E-01,& + & 3.332780E-01,2.714380E-01,2.843040E-01,1.541500E-01,1.762040E-01,& + & 2.379280E-06,2.861050E-06,6.766770E-06,7.457770E-01,7.333600E-01,& + & 1.263560E+00,2.276910E+00,8.416680E-01,3.914750E-01,3.212420E-01,& + & 3.142880E-01,3.401580E-01,2.554170E-01,2.990400E-01,1.732890E-01,& + & 1.450870E-01,5.037300E-02,2.782940E-06,6.697330E-06 / + data ka_mn2o(:,:,15) / & + & 1.912360E-04,7.935340E-03,1.215500E-01,5.329250E-01,1.498170E+00,& + & 1.870160E+00,3.125180E+00,1.875810E+00,1.470860E+00,6.969780E-01,& + & 6.003490E-01,8.829100E-01,3.938480E-01,1.712370E-01,1.234930E-01,& + & 1.235530E-01,1.679300E-01,3.569320E-01,8.501830E-01,1.012700E+00,& + & 1.856440E+00,1.683330E+00,1.248620E+00,8.764770E-01,4.205180E-01,& + & 7.094350E-01,2.364490E-01,1.777040E-01,1.492890E-01,4.717690E-02,& + & 3.347860E-06,7.000780E-06,2.447080E-01,5.022260E-01,1.135680E+00,& + & 1.501640E+00,1.452510E+00,1.187310E+00,1.099760E+00,4.913100E-01,& + & 3.851110E-01,2.843220E-01,2.356510E-01,1.523480E-01,1.347150E-01,& + & 6.088240E-02,3.325080E-06,7.162770E-06,3.256840E-01,8.547420E-01,& + & 1.203490E+00,1.497910E+00,1.289990E+00,9.684550E-01,7.724740E-01,& + & 4.106310E-01,3.782460E-01,2.150020E-01,2.996020E-01,1.735690E-01,& + & 1.370120E-01,5.636140E-02,3.285070E-06,7.486350E-06,4.480460E-01,& + & 1.106320E+00,1.471080E+00,1.230970E+00,1.083310E+00,8.965570E-01,& + & 4.881430E-01,3.715340E-01,3.455400E-01,2.550860E-01,2.987890E-01,& + & 1.728910E-01,1.406780E-01,4.949320E-02,3.245350E-06,7.810130E-06,& + & 7.002450E-01,1.301780E+00,1.420490E+00,1.178010E+00,9.559440E-01,& + & 5.777360E-01,4.417000E-01,3.477630E-01,3.312220E-01,2.554360E-01,& + & 2.982590E-01,1.710210E-01,1.475960E-01,3.783620E-02,3.251070E-06,& + & 2.234340E-03,9.287350E-01,1.776830E+00,1.346470E+00,8.496900E-01,& + & 7.289610E-01,3.947950E-01,3.636360E-01,3.450260E-01,3.345720E-01,& + & 2.547330E-01,2.990030E-01,1.672410E-01,1.657390E-01,8.211630E-03,& + & 3.273940E-06,7.891040E-06,1.024640E+00,2.781650E+00,8.810390E-01,& + & 4.960720E-01,3.982290E-01,3.161380E-01,3.325430E-01,3.106930E-01,& + & 3.350920E-01,2.712700E-01,2.833170E-01,1.528330E-01,1.712500E-01,& + & 2.774720E-06,3.336420E-06,7.891130E-06,7.477210E-01,7.284040E-01,& + & 1.274890E+00,2.265880E+00,8.375360E-01,3.926820E-01,3.231500E-01,& + & 3.157210E-01,3.420550E-01,2.552730E-01,2.980150E-01,1.727450E-01,& + & 1.410190E-01,4.894010E-02,3.245350E-06,7.810130E-06 / + data ka_mn2o(:,:,16) / & + & 2.319580E-04,8.888450E-03,1.290340E-01,5.381300E-01,1.495300E+00,& + & 1.872470E+00,3.118030E+00,1.857840E+00,1.464370E+00,6.921240E-01,& + & 5.943450E-01,9.155910E-01,4.077940E-01,1.791700E-01,1.265160E-01,& + & 1.265370E-01,1.741750E-01,3.557630E-01,8.525010E-01,1.015700E+00,& + & 1.858070E+00,1.673560E+00,1.236090E+00,8.759650E-01,4.213150E-01,& + & 7.276710E-01,2.394050E-01,1.808990E-01,1.489320E-01,4.832480E-02,& + & 3.904200E-06,8.163980E-06,2.487880E-01,4.992210E-01,1.144070E+00,& + & 1.503130E+00,1.449460E+00,1.176190E+00,1.091270E+00,4.944140E-01,& + & 3.889090E-01,2.874080E-01,2.374420E-01,1.524630E-01,1.309420E-01,& + & 5.915160E-02,3.877580E-06,8.352940E-06,3.277480E-01,8.561400E-01,& + & 1.209880E+00,1.497340E+00,1.282440E+00,9.593670E-01,7.709330E-01,& + & 4.119730E-01,3.828650E-01,2.159640E-01,2.985840E-01,1.730880E-01,& + & 1.331720E-01,5.475900E-02,3.830900E-06,8.730230E-06,4.482620E-01,& + & 1.110890E+00,1.474810E+00,1.229340E+00,1.074000E+00,8.889070E-01,& + & 4.912280E-01,3.739800E-01,3.486840E-01,2.549520E-01,2.977620E-01,& + & 1.723540E-01,1.367360E-01,4.808550E-02,3.784600E-06,9.107840E-06,& + & 6.991560E-01,1.307570E+00,1.423630E+00,1.171630E+00,9.476920E-01,& + & 5.767710E-01,4.432760E-01,3.513130E-01,3.336690E-01,2.553020E-01,& + & 2.972190E-01,1.704030E-01,1.434570E-01,3.675950E-02,3.791310E-06,& + & 2.392220E-03,9.245330E-01,1.784260E+00,1.346510E+00,8.424470E-01,& + & 7.249790E-01,3.967680E-01,3.652250E-01,3.485410E-01,3.365000E-01,& + & 2.546030E-01,2.979440E-01,1.664510E-01,1.610790E-01,7.977940E-03,& + & 3.818010E-06,9.202230E-06,1.017990E+00,2.782560E+00,8.786440E-01,& + & 4.975530E-01,3.993130E-01,3.174200E-01,3.354070E-01,3.124140E-01,& + & 3.369150E-01,2.711020E-01,2.823340E-01,1.515270E-01,1.664350E-01,& + & 3.235870E-06,3.890780E-06,9.202310E-06,7.496700E-01,7.234820E-01,& + & 1.286320E+00,2.254900E+00,8.334240E-01,3.938930E-01,3.250690E-01,& + & 3.171610E-01,3.439620E-01,2.551290E-01,2.969930E-01,1.722020E-01,& + & 1.370650E-01,4.754790E-02,3.784600E-06,9.107840E-06 / + data ka_mn2o(:,:,17) / & + & 2.813520E-04,9.956030E-03,1.369790E-01,5.433850E-01,1.492450E+00,& + & 1.874790E+00,3.110890E+00,1.840040E+00,1.457910E+00,6.873040E-01,& + & 5.884010E-01,9.494810E-01,4.222340E-01,1.874710E-01,1.296130E-01,& + & 1.295930E-01,1.806520E-01,3.545970E-01,8.548250E-01,1.018710E+00,& + & 1.859710E+00,1.663850E+00,1.223670E+00,8.754520E-01,4.221120E-01,& + & 7.463770E-01,2.423980E-01,1.841510E-01,1.485750E-01,4.950060E-02,& + & 4.552980E-06,9.520450E-06,2.529360E-01,4.962350E-01,1.152520E+00,& + & 1.504630E+00,1.446410E+00,1.165180E+00,1.082840E+00,4.975380E-01,& + & 3.927450E-01,2.905270E-01,2.392470E-01,1.525790E-01,1.272740E-01,& + & 5.747000E-02,4.521880E-06,9.740860E-06,3.298240E-01,8.575410E-01,& + & 1.216300E+00,1.496760E+00,1.274930E+00,9.503650E-01,7.693940E-01,& + & 4.133200E-01,3.875410E-01,2.169320E-01,2.975710E-01,1.726090E-01,& + & 1.294400E-01,5.320220E-02,4.467410E-06,1.018080E-05,4.484790E-01,& + & 1.115470E+00,1.478540E+00,1.227720E+00,1.064760E+00,8.813230E-01,& + & 4.943320E-01,3.764430E-01,3.518570E-01,2.548180E-01,2.967390E-01,& + & 1.718180E-01,1.329060E-01,4.671790E-02,4.413450E-06,1.062120E-05,& + & 6.980680E-01,1.313380E+00,1.426780E+00,1.165290E+00,9.395120E-01,& + & 5.758080E-01,4.448580E-01,3.548990E-01,3.361340E-01,2.551680E-01,& + & 2.961820E-01,1.697880E-01,1.394330E-01,3.571350E-02,4.421320E-06,& + & 2.561250E-03,9.203500E-01,1.791730E+00,1.346560E+00,8.352660E-01,& + & 7.210180E-01,3.987500E-01,3.668220E-01,3.520920E-01,3.384390E-01,& + & 2.544740E-01,2.968880E-01,1.656640E-01,1.565500E-01,7.750910E-03,& + & 4.452490E-06,1.073130E-05,1.011400E+00,2.783480E+00,8.762550E-01,& + & 4.990390E-01,4.004000E-01,3.187070E-01,3.382960E-01,3.141460E-01,& + & 3.387490E-01,2.709350E-01,2.813540E-01,1.502320E-01,1.617560E-01,& + & 3.773670E-06,4.537250E-06,1.073140E-05,7.516240E-01,7.185920E-01,& + & 1.297850E+00,2.243970E+00,8.293330E-01,3.951070E-01,3.270000E-01,& + & 3.186070E-01,3.458800E-01,2.549860E-01,2.959750E-01,1.716620E-01,& + & 1.332220E-01,4.619530E-02,4.413450E-06,1.062120E-05 / + data ka_mn2o(:,:,18) / & + & 3.412630E-04,1.115180E-02,1.454130E-01,5.486910E-01,1.489590E+00,& + & 1.877110E+00,3.103770E+00,1.822420E+00,1.451470E+00,6.825170E-01,& + & 5.825170E-01,9.846260E-01,4.371860E-01,1.961560E-01,1.327850E-01,& + & 1.327230E-01,1.873690E-01,3.534350E-01,8.571550E-01,1.021730E+00,& + & 1.861350E+00,1.654190E+00,1.211390E+00,8.749400E-01,4.229120E-01,& + & 7.655630E-01,2.454290E-01,1.874620E-01,1.482190E-01,5.070510E-02,& + & 5.309580E-06,1.110230E-05,2.571520E-01,4.932660E-01,1.161030E+00,& + & 1.506120E+00,1.443370E+00,1.154270E+00,1.074470E+00,5.006820E-01,& + & 3.966180E-01,2.936800E-01,2.410650E-01,1.526950E-01,1.237090E-01,& + & 5.583630E-02,5.273230E-06,1.135940E-05,3.319130E-01,8.589440E-01,& + & 1.222750E+00,1.496190E+00,1.267470E+00,9.414470E-01,7.678590E-01,& + & 4.146710E-01,3.922740E-01,2.179030E-01,2.965610E-01,1.721310E-01,& + & 1.258130E-01,5.168970E-02,5.209690E-06,1.187240E-05,4.486950E-01,& + & 1.120080E+00,1.482280E+00,1.226100E+00,1.055610E+00,8.738030E-01,& + & 4.974560E-01,3.789210E-01,3.550590E-01,2.546840E-01,2.957200E-01,& + & 1.712840E-01,1.291820E-01,4.538910E-02,5.146790E-06,1.238590E-05,& + & 6.969820E-01,1.319220E+00,1.429930E+00,1.158980E+00,9.314020E-01,& + & 5.748460E-01,4.464450E-01,3.585210E-01,3.386180E-01,2.550340E-01,& + & 2.951480E-01,1.691750E-01,1.355230E-01,3.469720E-02,5.156020E-06,& + & 2.742230E-03,9.161870E-01,1.799220E+00,1.346610E+00,8.281470E-01,& + & 7.170790E-01,4.007420E-01,3.684260E-01,3.556790E-01,3.403900E-01,& + & 2.543450E-01,2.958360E-01,1.648810E-01,1.521480E-01,7.530330E-03,& + & 5.192410E-06,1.251440E-05,1.004840E+00,2.784390E+00,8.738730E-01,& + & 5.005300E-01,4.014890E-01,3.200000E-01,3.412100E-01,3.158870E-01,& + & 3.405930E-01,2.707670E-01,2.803770E-01,1.489480E-01,1.572080E-01,& + & 4.400850E-06,5.291120E-06,1.251450E-05,7.535840E-01,7.137360E-01,& + & 1.309480E+00,2.233100E+00,8.252610E-01,3.963260E-01,3.289420E-01,& + & 3.200600E-01,3.478090E-01,2.548420E-01,2.949600E-01,1.711230E-01,& + & 1.294860E-01,4.488110E-02,5.146790E-06,1.238590E-05 / + data ka_mn2o(:,:,19) / & + & 4.139320E-04,1.249130E-02,1.543660E-01,5.540490E-01,1.486750E+00,& + & 1.879430E+00,3.096670E+00,1.804960E+00,1.445070E+00,6.777640E-01,& + & 5.766910E-01,1.021070E+00,4.526670E-01,2.052430E-01,1.360360E-01,& + & 1.359280E-01,1.943370E-01,3.522770E-01,8.594910E-01,1.024760E+00,& + & 1.862990E+00,1.644590E+00,1.199220E+00,8.744280E-01,4.237130E-01,& + & 7.852420E-01,2.484970E-01,1.908330E-01,1.478640E-01,5.193880E-02,& + & 6.191900E-06,1.294700E-05,2.614390E-01,4.903150E-01,1.169600E+00,& + & 1.507620E+00,1.440330E+00,1.143470E+00,1.066180E+00,5.038450E-01,& + & 4.005300E-01,2.968680E-01,2.428970E-01,1.528100E-01,1.202440E-01,& + & 5.424900E-02,6.149430E-06,1.324680E-05,3.340160E-01,8.603500E-01,& + & 1.229240E+00,1.495610E+00,1.260050E+00,9.326120E-01,7.663270E-01,& + & 4.160270E-01,3.970650E-01,2.188790E-01,2.955540E-01,1.716540E-01,& + & 1.222870E-01,5.022020E-02,6.075290E-06,1.384500E-05,4.489120E-01,& + & 1.124700E+00,1.486030E+00,1.224480E+00,1.046530E+00,8.663470E-01,& + & 5.006000E-01,3.814160E-01,3.582890E-01,2.545500E-01,2.947040E-01,& + & 1.707510E-01,1.255630E-01,4.409820E-02,6.001980E-06,1.444390E-05,& + & 6.958980E-01,1.325080E+00,1.433090E+00,1.152700E+00,9.233630E-01,& + & 5.738860E-01,4.480380E-01,3.621810E-01,3.411190E-01,2.549000E-01,& + & 2.941190E-01,1.685640E-01,1.317220E-01,3.370990E-02,6.012800E-06,& + & 2.935990E-03,9.120420E-01,1.806750E+00,1.346660E+00,8.210870E-01,& + & 7.131610E-01,4.027440E-01,3.700360E-01,3.593020E-01,3.423510E-01,& + & 2.542150E-01,2.947880E-01,1.641010E-01,1.478700E-01,7.316030E-03,& + & 6.055280E-06,1.459390E-05,9.983280E-01,2.785300E+00,8.714970E-01,& + & 5.020250E-01,4.025820E-01,3.212980E-01,3.441480E-01,3.176380E-01,& + & 3.424470E-01,2.706000E-01,2.794040E-01,1.476750E-01,1.527880E-01,& + & 5.132270E-06,6.170260E-06,1.459390E-05,7.555480E-01,7.089120E-01,& + & 1.321220E+00,2.222280E+00,8.212090E-01,3.975480E-01,3.308950E-01,& + & 3.215200E-01,3.497490E-01,2.546980E-01,2.939490E-01,1.705860E-01,& + & 1.258550E-01,4.360440E-02,6.001980E-06,1.444390E-05 / + +! --- the array kb_mxxx contains the absorption coefficient for a minor +! species at the NG03=16 chosen g-values for a reference pressure +! level above 100~ mb. the first index in the array, js, runs from +! 1 to 10, and corresponds to different gas column amounts ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +! reference mls column amount value of gas1 to that of gas2. the +! second index refers to temperature in 7.2 degree increments. for +! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers +! to 195.2, etc. the third index runs over the g-channel (1 to NG03=16). + + data kb_mn2o(:,:, 1: 2) / & + & 7.720090E-08,1.945270E-04,8.747970E-03,1.186730E-01,3.977570E-01,& + & 6.986750E-01,1.829850E+00,4.468430E+00,7.928260E+00,1.052650E+00,& + & 1.742390E-01,1.602690E-01,2.018460E-01,2.878180E-02,1.522340E-02,& + & 1.082570E-02,1.299320E-05,7.496150E-04,1.439740E-02,1.321610E-01,& + & 3.994250E-01,6.988580E-01,1.832290E+00,4.443470E+00,7.892440E+00,& + & 1.052460E+00,1.741140E-01,1.604970E-01,2.017560E-01,2.885000E-02,& + & 1.522340E-02,1.082570E-02,6.445180E-05,1.391620E-03,1.830510E-02,& + & 1.443840E-01,4.005270E-01,7.081510E-01,1.849460E+00,4.431380E+00,& + & 7.797990E+00,1.052360E+00,1.741420E-01,1.604070E-01,2.018360E-01,& + & 2.880360E-02,1.520760E-02,1.082570E-02,3.234540E-04,2.423540E-03,& + & 2.812580E-02,1.580260E-01,4.114550E-01,7.222690E-01,1.883540E+00,& + & 4.474370E+00,7.537500E+00,9.308360E-01,1.740740E-01,1.604750E-01,& + & 2.018450E-01,2.877500E-02,1.524220E-02,1.082630E-02,1.459780E-04,& + & 1.399080E-03,8.829580E-03,4.048850E-02,8.655760E-02,1.758770E-01,& + & 3.351540E-01,8.828380E-01,5.063190E+00,1.657860E+01,2.319050E+01,& + & 3.257430E+01,5.341540E+01,1.118480E+02,6.947820E+01,4.534500E-08,& + & 1.158830E-07,2.386090E-04,9.668280E-03,1.229830E-01,4.010820E-01,& + & 7.009990E-01,1.836840E+00,4.497930E+00,7.831680E+00,1.039860E+00,& + & 1.778730E-01,1.628730E-01,2.031100E-01,3.178680E-02,1.692560E-02,& + & 1.151880E-02,1.782070E-05,8.827160E-04,1.561180E-02,1.365500E-01,& + & 4.020350E-01,7.014240E-01,1.839430E+00,4.472780E+00,7.795700E+00,& + & 1.039730E+00,1.777560E-01,1.630960E-01,2.030200E-01,3.184940E-02,& + & 1.692560E-02,1.151880E-02,8.109960E-05,1.598590E-03,1.968510E-02,& + & 1.488200E-01,4.028480E-01,7.107270E-01,1.857070E+00,4.460170E+00,& + & 7.700760E+00,1.039630E+00,1.777800E-01,1.630060E-01,2.031000E-01,& + & 3.181090E-02,1.690490E-02,1.151880E-02,3.821120E-04,2.736230E-03,& + & 2.978060E-02,1.626260E-01,4.130770E-01,7.249810E-01,1.891670E+00,& + & 4.503960E+00,7.437150E+00,9.210990E-01,1.777160E-01,1.630700E-01,& + & 2.031030E-01,3.177830E-02,1.694880E-02,1.151910E-02,1.756460E-04,& + & 1.591330E-03,9.538420E-03,4.160640E-02,8.836220E-02,1.785780E-01,& + & 3.432580E-01,8.922570E-01,5.085950E+00,1.665410E+01,2.330110E+01,& + & 3.279920E+01,5.319540E+01,1.094890E+02,6.734690E+01,5.751930E-08/ + data kb_mn2o(:,:, 3: 4) / & + & 1.739470E-07,2.926800E-04,1.068540E-02,1.274490E-01,4.044340E-01,& + & 7.033310E-01,1.843860E+00,4.527630E+00,7.736280E+00,1.027230E+00,& + & 1.815830E-01,1.655190E-01,2.043810E-01,3.510560E-02,1.881810E-02,& + & 1.225630E-02,2.444190E-05,1.039450E-03,1.692860E-02,1.410840E-01,& + & 4.046620E-01,7.039990E-01,1.846590E+00,4.502280E+00,7.700140E+00,& + & 1.027140E+00,1.814750E-01,1.657380E-01,2.042910E-01,3.516060E-02,& + & 1.881810E-02,1.225630E-02,1.020470E-04,1.836340E-03,2.116920E-02,& + & 1.533920E-01,4.051820E-01,7.133110E-01,1.864710E+00,4.489160E+00,& + & 7.604740E+00,1.027040E+00,1.814940E-01,1.656480E-01,2.043710E-01,& + & 3.513220E-02,1.879160E-02,1.225630E-02,4.514080E-04,3.089260E-03,& + & 3.153280E-02,1.673600E-01,4.147050E-01,7.277040E-01,1.899830E+00,& + & 4.533750E+00,7.338140E+00,9.114640E-01,1.814350E-01,1.657060E-01,& + & 2.043700E-01,3.509510E-02,1.884640E-02,1.225620E-02,2.113440E-04,& + & 1.810000E-03,1.030420E-02,4.275510E-02,9.020440E-02,1.813210E-01,& + & 3.515570E-01,9.017770E-01,5.108810E+00,1.672990E+01,2.341230E+01,& + & 3.302560E+01,5.297630E+01,1.071790E+02,6.528100E+01,7.296200E-08,& + & 2.611040E-07,3.590050E-04,1.180950E-02,1.320770E-01,4.078140E-01,& + & 7.056710E-01,1.850910E+00,4.557520E+00,7.642040E+00,1.014750E+00,& + & 1.853700E-01,1.682080E-01,2.056600E-01,3.877080E-02,2.092220E-02,& + & 1.304100E-02,3.352320E-05,1.224010E-03,1.835640E-02,1.457690E-01,& + & 4.073060E-01,7.065830E-01,1.853790E+00,4.531980E+00,7.605760E+00,& + & 1.014710E+00,1.852710E-01,1.684220E-01,2.055700E-01,3.881610E-02,& + & 2.092220E-02,1.304100E-02,1.284060E-04,2.109460E-03,2.276510E-02,& + & 1.581040E-01,4.075300E-01,7.159050E-01,1.872380E+00,4.518340E+00,& + & 7.509910E+00,1.014610E+00,1.852860E-01,1.683320E-01,2.056500E-01,& + & 3.880020E-02,2.088900E-02,1.304100E-02,5.332700E-04,3.487830E-03,& + & 3.338800E-02,1.722320E-01,4.163400E-01,7.304370E-01,1.908030E+00,& + & 4.563740E+00,7.240450E+00,9.019300E-01,1.852310E-01,1.683860E-01,& + & 2.056440E-01,3.875800E-02,2.095650E-02,1.304040E-02,2.542960E-04,& + & 2.058720E-03,1.113140E-02,4.393550E-02,9.208500E-02,1.841070E-01,& + & 3.600580E-01,9.113980E-01,5.131770E+00,1.680620E+01,2.352400E+01,& + & 3.325360E+01,5.275820E+01,1.049180E+02,6.327850E+01,9.255090E-08/ + data kb_mn2o(:,:, 5: 6) / & + & 3.919320E-07,4.403600E-04,1.305190E-02,1.368740E-01,4.112230E-01,& + & 7.080190E-01,1.857980E+00,4.587610E+00,7.548950E+00,1.002430E+00,& + & 1.892360E-01,1.709400E-01,2.069470E-01,4.281870E-02,2.326170E-02,& + & 1.387590E-02,4.597860E-05,1.441350E-03,1.990470E-02,1.506100E-01,& + & 4.099680E-01,7.091770E-01,1.861000E+00,4.561880E+00,7.512530E+00,& + & 1.002430E+00,1.891470E-01,1.711500E-01,2.068570E-01,4.285170E-02,& + & 2.326170E-02,1.387590E-02,1.615730E-04,2.423190E-03,2.448130E-02,& + & 1.629620E-01,4.098920E-01,7.185080E-01,1.880080E+00,4.547700E+00,& + & 7.416270E+00,1.002330E+00,1.891570E-01,1.710600E-01,2.069370E-01,& + & 4.285120E-02,2.322030E-02,1.387590E-02,6.299780E-04,3.937830E-03,& + & 3.535240E-02,1.772450E-01,4.179810E-01,7.331800E-01,1.916260E+00,& + & 4.593920E+00,7.144060E+00,8.924950E-01,1.891070E-01,1.711090E-01,& + & 2.069260E-01,4.280330E-02,2.330280E-02,1.387490E-02,3.059780E-04,& + & 2.341610E-03,1.202500E-02,4.514850E-02,9.400490E-02,1.869350E-01,& + & 3.687640E-01,9.211220E-01,5.154830E+00,1.688270E+01,2.363620E+01,& + & 3.348320E+01,5.254090E+01,1.027050E+02,6.133730E+01,1.173990E-07,& + & 5.883110E-07,5.401500E-04,1.442500E-02,1.418450E-01,4.146590E-01,& + & 7.103750E-01,1.865080E+00,4.617900E+00,7.456990E+00,9.902500E-01,& + & 1.931820E-01,1.737170E-01,2.082420E-01,4.728930E-02,2.586260E-02,& + & 1.476430E-02,6.306170E-05,1.697270E-03,2.158360E-02,1.556110E-01,& + & 4.126470E-01,7.117800E-01,1.868250E+00,4.591970E+00,7.420450E+00,& + & 9.903030E-01,1.931040E-01,1.739220E-01,2.081520E-01,4.730680E-02,& + & 2.586260E-02,1.476430E-02,2.033070E-04,2.783580E-03,2.632700E-02,& + & 1.679680E-01,4.122670E-01,7.211210E-01,1.887810E+00,4.577250E+00,& + & 7.323790E+00,9.902030E-01,1.931080E-01,1.738320E-01,2.082320E-01,& + & 4.732520E-02,2.581190E-02,1.476430E-02,7.442230E-04,4.445890E-03,& + & 3.743240E-02,1.824050E-01,4.196290E-01,7.359330E-01,1.924530E+00,& + & 4.624310E+00,7.048950E+00,8.831590E-01,1.930640E-01,1.738760E-01,& + & 2.082170E-01,4.727080E-02,2.591180E-02,1.476270E-02,3.681630E-04,& + & 2.663380E-03,1.299040E-02,4.639500E-02,9.596470E-02,1.898060E-01,& + & 3.776800E-01,9.309500E-01,5.178000E+00,1.695960E+01,2.374890E+01,& + & 3.371430E+01,5.232450E+01,1.005380E+02,5.945580E+01,1.489180E-07/ + data kb_mn2o(:,:, 7: 8) / & + & 8.830880E-07,6.625540E-04,1.594260E-02,1.469960E-01,4.181250E-01,& + & 7.127380E-01,1.872210E+00,4.648390E+00,7.366160E+00,9.782200E-01,& + & 1.972110E-01,1.765400E-01,2.095460E-01,5.222660E-02,2.875450E-02,& + & 1.570960E-02,8.649200E-05,1.998630E-03,2.340410E-02,1.607790E-01,& + & 4.153430E-01,7.143930E-01,1.875530E+00,4.622270E+00,7.329490E+00,& + & 9.783190E-01,1.971440E-01,1.767380E-01,2.094560E-01,5.222510E-02,& + & 2.875450E-02,1.570960E-02,2.558210E-04,3.197580E-03,2.831170E-02,& + & 1.731280E-01,4.146560E-01,7.237430E-01,1.895580E+00,4.607000E+00,& + & 7.232470E+00,9.782190E-01,1.971430E-01,1.766490E-01,2.095360E-01,& + & 5.226630E-02,2.869280E-02,1.570960E-02,8.791870E-04,5.019500E-03,& + & 3.963480E-02,1.877140E-01,4.212830E-01,7.386970E-01,1.932830E+00,& + & 4.654900E+00,6.955100E+00,8.739210E-01,1.971040E-01,1.766870E-01,& + & 2.095150E-01,5.220460E-02,2.881290E-02,1.570730E-02,4.429860E-04,& + & 3.029370E-03,1.403330E-02,4.767590E-02,9.796550E-02,1.927220E-01,& + & 3.868120E-01,9.408830E-01,5.201270E+00,1.703690E+01,2.386220E+01,& + & 3.394710E+01,5.210900E+01,9.841750E+01,5.763190E+01,1.889000E-07,& + & 1.325560E-06,8.126970E-04,1.761980E-02,1.523340E-01,4.216200E-01,& + & 7.151100E-01,1.879370E+00,4.679080E+00,7.276430E+00,9.663380E-01,& + & 2.013240E-01,1.794080E-01,2.108570E-01,5.767940E-02,3.196960E-02,& + & 1.671540E-02,1.186280E-04,2.353510E-03,2.537810E-02,1.661180E-01,& + & 4.180570E-01,7.170160E-01,1.882830E+00,4.652760E+00,7.239650E+00,& + & 9.664800E-01,2.012680E-01,1.796010E-01,2.107670E-01,5.765470E-02,& + & 3.196960E-02,1.671540E-02,3.218990E-04,3.673140E-03,3.044610E-02,& + & 1.784470E-01,4.170580E-01,7.263750E-01,1.903380E+00,4.636940E+00,& + & 7.142290E+00,9.663800E-01,2.012610E-01,1.795110E-01,2.108470E-01,& + & 5.772320E-02,3.189510E-02,1.671540E-02,1.038630E-03,5.667120E-03,& + & 4.196670E-02,1.931790E-01,4.229440E-01,7.414710E-01,1.941170E+00,& + & 4.685690E+00,6.862510E+00,8.647790E-01,2.012290E-01,1.795440E-01,& + & 2.108220E-01,5.765330E-02,3.203890E-02,1.671240E-02,5.330170E-04,& + & 3.445640E-03,1.515990E-02,4.899210E-02,1.000080E-01,1.956820E-01,& + & 3.961640E-01,9.509210E-01,5.224640E+00,1.711450E+01,2.397600E+01,& + & 3.418150E+01,5.189430E+01,9.634140E+01,5.586400E+01,2.396160E-07/ + data kb_mn2o(:,:, 9:10) / & + & 1.989750E-06,9.968640E-04,1.947350E-02,1.578660E-01,4.251440E-01,& + & 7.174890E-01,1.886550E+00,4.709970E+00,7.187790E+00,9.545990E-01,& + & 2.055230E-01,1.823220E-01,2.121770E-01,6.370150E-02,3.554430E-02,& + & 1.778570E-02,1.627030E-04,2.771390E-03,2.751870E-02,1.716340E-01,& + & 4.207890E-01,7.196480E-01,1.890160E+00,4.683450E+00,7.150910E+00,& + & 9.547840E-01,2.054790E-01,1.825100E-01,2.120870E-01,6.364880E-02,& + & 3.554430E-02,1.778570E-02,4.050450E-04,4.219440E-03,3.274140E-02,& + & 1.839290E-01,4.194750E-01,7.290170E-01,1.911200E+00,4.667080E+00,& + & 7.053230E+00,9.546840E-01,2.054660E-01,1.824200E-01,2.121670E-01,& + & 6.374990E-02,3.545490E-02,1.778570E-02,1.226980E-03,6.398290E-03,& + & 4.443580E-02,1.988020E-01,4.246110E-01,7.442560E-01,1.949550E+00,& + & 4.716680E+00,6.771150E+00,8.557330E-01,2.054390E-01,1.824480E-01,& + & 2.121360E-01,6.367070E-02,3.562600E-02,1.778180E-02,6.413440E-04,& + & 3.919120E-03,1.637690E-02,5.034480E-02,1.020930E-01,1.986880E-01,& + & 4.057430E-01,9.610670E-01,5.248130E+00,1.719250E+01,2.409040E+01,& + & 3.441740E+01,5.168060E+01,9.430910E+01,5.415030E+01,3.039480E-07,& + & 2.986720E-06,1.222760E-03,2.152210E-02,1.635990E-01,4.286970E-01,& + & 7.198760E-01,1.893760E+00,4.741060E+00,7.100230E+00,9.430030E-01,& + & 2.098090E-01,1.852840E-01,2.135050E-01,7.035230E-02,3.951870E-02,& + & 1.892440E-02,2.231550E-04,3.263470E-03,2.983970E-02,1.773340E-01,& + & 4.235390E-01,7.222890E-01,1.897530E+00,4.714350E+00,7.063250E+00,& + & 9.432300E-01,2.097780E-01,1.854660E-01,2.134150E-01,7.026610E-02,& + & 3.951870E-02,1.892440E-02,5.096670E-04,4.846980E-03,3.520970E-02,& + & 1.895800E-01,4.219060E-01,7.316680E-01,1.919070E+00,4.697410E+00,& + & 6.965280E+00,9.431300E-01,2.097590E-01,1.853760E-01,2.134950E-01,& + & 7.040580E-02,3.941200E-02,1.892440E-02,1.449490E-03,7.223790E-03,& + & 4.705020E-02,2.045890E-01,4.262850E-01,7.470510E-01,1.957960E+00,& + & 4.747880E+00,6.681010E+00,8.467810E-01,2.097380E-01,1.853980E-01,& + & 2.134590E-01,7.031620E-02,3.961480E-02,1.891960E-02,7.716870E-04,& + & 4.457660E-03,1.769170E-02,5.173470E-02,1.042210E-01,2.017400E-01,& + & 4.155530E-01,9.713210E-01,5.271710E+00,1.727080E+01,2.420530E+01,& + & 3.465500E+01,5.146770E+01,9.231960E+01,5.248920E+01,3.855510E-07/ + data kb_mn2o(:,:,11:12) / & + & 4.483240E-06,1.499860E-03,2.378630E-02,1.695410E-01,4.322800E-01,& + & 7.222710E-01,1.901000E+00,4.772360E+00,7.013740E+00,9.315480E-01,& + & 2.141850E-01,1.882950E-01,2.148410E-01,7.769760E-02,4.393740E-02,& + & 2.013600E-02,3.060670E-04,3.842930E-03,3.235660E-02,1.832230E-01,& + & 4.263070E-01,7.249410E-01,1.904920E+00,4.745440E+00,6.976680E+00,& + & 9.318150E-01,2.141660E-01,1.884690E-01,2.147510E-01,7.757140E-02,& + & 4.393740E-02,2.013600E-02,6.413130E-04,5.567860E-03,3.786420E-02,& + & 1.954040E-01,4.243510E-01,7.343290E-01,1.926960E+00,4.727930E+00,& + & 6.878430E+00,9.317150E-01,2.141410E-01,1.883800E-01,2.148310E-01,& + & 7.775670E-02,4.381070E-02,2.013600E-02,1.712350E-03,8.155810E-03,& + & 4.981850E-02,2.105440E-01,4.279660E-01,7.498560E-01,1.966410E+00,& + & 4.779280E+00,6.592060E+00,8.379230E-01,2.141270E-01,1.883960E-01,& + & 2.147900E-01,7.765530E-02,4.405010E-02,2.013020E-02,9.285220E-04,& + & 5.070210E-03,1.911200E-02,5.316300E-02,1.063940E-01,2.048390E-01,& + & 4.256010E-01,9.816850E-01,5.295400E+00,1.734950E+01,2.432080E+01,& + & 3.489430E+01,5.125580E+01,9.037220E+01,5.087910E+01,4.890640E-07,& + & 6.729600E-06,1.839740E-03,2.628870E-02,1.756980E-01,4.358930E-01,& + & 7.246740E-01,1.908270E+00,4.803870E+00,6.928310E+00,9.202320E-01,& + & 2.186520E-01,1.913540E-01,2.161860E-01,8.580970E-02,4.885030E-02,& + & 2.142520E-02,4.197840E-04,4.525280E-03,3.508570E-02,1.893070E-01,& + & 4.290920E-01,7.276020E-01,1.912330E+00,4.776750E+00,6.891160E+00,& + & 9.205390E-01,2.186470E-01,1.915220E-01,2.160960E-01,8.563620E-02,& + & 4.885030E-02,2.142520E-02,8.069640E-04,6.395950E-03,4.071870E-02,& + & 2.014070E-01,4.268090E-01,7.369990E-01,1.934890E+00,4.758660E+00,& + & 6.792660E+00,9.204390E-01,2.186150E-01,1.914330E-01,2.161760E-01,& + & 8.587510E-02,4.870030E-02,2.142520E-02,2.022890E-03,9.208070E-03,& + & 5.274960E-02,2.166730E-01,4.296530E-01,7.526720E-01,1.974890E+00,& + & 4.810890E+00,6.504300E+00,8.291580E-01,2.186070E-01,1.914420E-01,& + & 2.161290E-01,8.576040E-02,4.898210E-02,2.141830E-02,1.117230E-03,& + & 5.766930E-03,2.064630E-02,5.463080E-02,1.086120E-01,2.079860E-01,& + & 4.358920E-01,9.921590E-01,5.319200E+00,1.742850E+01,2.443680E+01,& + & 3.513520E+01,5.104460E+01,8.846580E+01,4.931830E+01,6.203690E-07/ + data kb_mn2o(:,:,13:14) / & + & 1.010150E-05,2.256650E-03,2.905440E-02,1.820780E-01,4.395360E-01,& + & 7.270850E-01,1.915560E+00,4.835590E+00,6.843910E+00,9.090540E-01,& + & 2.232120E-01,1.944620E-01,2.175390E-01,9.476880E-02,5.431240E-02,& + & 2.279700E-02,5.757530E-04,5.328780E-03,3.804510E-02,1.955940E-01,& + & 4.318960E-01,7.302730E-01,1.919780E+00,4.808260E+00,6.806690E+00,& + & 9.093990E-01,2.232210E-01,1.946240E-01,2.174490E-01,9.453950E-02,& + & 5.431240E-02,2.279700E-02,1.015400E-03,7.347200E-03,4.378840E-02,& + & 2.075940E-01,4.292830E-01,7.396790E-01,1.942850E+00,4.789580E+00,& + & 6.707970E+00,9.093000E-01,2.231820E-01,1.945350E-01,2.175290E-01,& + & 9.484100E-02,5.413570E-02,2.279700E-02,2.389740E-03,1.039610E-02,& + & 5.585310E-02,2.229800E-01,4.313460E-01,7.554990E-01,1.983410E+00,& + & 4.842710E+00,6.417710E+00,8.204850E-01,2.231810E-01,1.945380E-01,& + & 2.174770E-01,9.471140E-02,5.446620E-02,2.278880E-02,1.344290E-03,& + & 6.559380E-03,2.230380E-02,5.613910E-02,1.108770E-01,2.111810E-01,& + & 4.464310E-01,1.002740E+00,5.343110E+00,1.750790E+01,2.455330E+01,& + & 3.537780E+01,5.083440E+01,8.659960E+01,4.780550E+01,7.869250E-07,& + & 1.516290E-05,2.768030E-03,3.211100E-02,1.886910E-01,4.432090E-01,& + & 7.295040E-01,1.922880E+00,4.867510E+00,6.760540E+00,8.980110E-01,& + & 2.278670E-01,1.976220E-01,2.189000E-01,1.046630E-01,6.038540E-02,& + & 2.425650E-02,7.896710E-04,6.274950E-03,4.125400E-02,2.020890E-01,& + & 4.347190E-01,7.329540E-01,1.927260E+00,4.839980E+00,6.723260E+00,& + & 8.983940E-01,2.278900E-01,1.977760E-01,2.188100E-01,1.043680E-01,& + & 6.038540E-02,2.425650E-02,1.277680E-03,8.439920E-03,4.708960E-02,& + & 2.139720E-01,4.317700E-01,7.423690E-01,1.950840E+00,4.820710E+00,& + & 6.624320E+00,8.982950E-01,2.278450E-01,1.976870E-01,2.188900E-01,& + & 1.047430E-01,6.017770E-02,2.425650E-02,2.823110E-03,1.173740E-02,& + & 5.913930E-02,2.294710E-01,4.330470E-01,7.583360E-01,1.991970E+00,& + & 4.874740E+00,6.332270E+00,8.119020E-01,2.278520E-01,1.976840E-01,& + & 2.188330E-01,1.045970E-01,6.056430E-02,2.424700E-02,1.617500E-03,& + & 7.460730E-03,2.409440E-02,5.768900E-02,1.131880E-01,2.144250E-01,& + & 4.572250E-01,1.013440E+00,5.367120E+00,1.758770E+01,2.467050E+01,& + & 3.562200E+01,5.062500E+01,8.477280E+01,4.633900E+01,9.981990E-07/ + data kb_mn2o(:,:,15:16) / & + & 2.276040E-05,3.395300E-03,3.548910E-02,1.955430E-01,4.469130E-01,& + & 7.319310E-01,1.930230E+00,4.899650E+00,6.678190E+00,8.871020E-01,& + & 2.326200E-01,2.008320E-01,2.202700E-01,1.155910E-01,6.713730E-02,& + & 2.580960E-02,1.083070E-03,7.389110E-03,4.473360E-02,2.088000E-01,& + & 4.375590E-01,7.356440E-01,1.934760E+00,4.871910E+00,6.640850E+00,& + & 8.875220E-01,2.326580E-01,2.009790E-01,2.201810E-01,1.152190E-01,& + & 6.713730E-02,2.580960E-02,1.607700E-03,9.695160E-03,5.063960E-02,& + & 2.205460E-01,4.342720E-01,7.450680E-01,1.958860E+00,4.852040E+00,& + & 6.541720E+00,8.874230E-01,2.326050E-01,2.008910E-01,2.202600E-01,& + & 1.156790E-01,6.689400E-02,2.580960E-02,3.335080E-03,1.325170E-02,& + & 6.261870E-02,2.361510E-01,4.347540E-01,7.611840E-01,2.000560E+00,& + & 4.906980E+00,6.247970E+00,8.034090E-01,2.326190E-01,2.008810E-01,& + & 2.201980E-01,1.155140E-01,6.734520E-02,2.579860E-02,1.946230E-03,& + & 8.485940E-03,2.602870E-02,5.928170E-02,1.155480E-01,2.177190E-01,& + & 4.682800E-01,1.024260E+00,5.391240E+00,1.766780E+01,2.478810E+01,& + & 3.586790E+01,5.041650E+01,8.298450E+01,4.491750E+01,1.266190E-06,& + & 3.416460E-05,4.164720E-03,3.922270E-02,2.026450E-01,4.506490E-01,& + & 7.343660E-01,1.937610E+00,4.932000E+00,6.596840E+00,8.763260E-01,& + & 2.374710E-01,2.040950E-01,2.216490E-01,1.276590E-01,7.464430E-02,& + & 2.746200E-02,1.485480E-03,8.701110E-03,4.850670E-02,2.157340E-01,& + & 4.404190E-01,7.383450E-01,1.942300E+00,4.904050E+00,6.559450E+00,& + & 8.767820E-01,2.375250E-01,2.042340E-01,2.215590E-01,1.271980E-01,& + & 7.464430E-02,2.746200E-02,2.022960E-03,1.113710E-02,5.445730E-02,& + & 2.273210E-01,4.367880E-01,7.477780E-01,1.966920E+00,4.883570E+00,& + & 6.460150E+00,8.766830E-01,2.374640E-01,2.041460E-01,2.216390E-01,& + & 1.277570E-01,7.436000E-02,2.746200E-02,3.939890E-03,1.496150E-02,& + & 6.630300E-02,2.430250E-01,4.364680E-01,7.640430E-01,2.009200E+00,& + & 4.939440E+00,6.164790E+00,7.950050E-01,2.374870E-01,2.041290E-01,& + & 2.215710E-01,1.275700E-01,7.488530E-02,2.744940E-02,2.341770E-03,& + & 9.652020E-03,2.811830E-02,6.091840E-02,1.179570E-01,2.210630E-01,& + & 4.796030E-01,1.035180E+00,5.415470E+00,1.774830E+01,2.490640E+01,& + & 3.611560E+01,5.020890E+01,8.123390E+01,4.353960E+01,1.606140E-06/ + data kb_mn2o(:,:,17:18) / & + & 5.128310E-05,5.108490E-03,4.334910E-02,2.100040E-01,4.544150E-01,& + & 7.368090E-01,1.945020E+00,4.964560E+00,6.516480E+00,8.656810E-01,& + & 2.424240E-01,2.074110E-01,2.230360E-01,1.409880E-01,8.299060E-02,& + & 2.922030E-02,2.037400E-03,1.024610E-02,5.259800E-02,2.228980E-01,& + & 4.432960E-01,7.410550E-01,1.949860E+00,4.936400E+00,6.479040E+00,& + & 8.661710E-01,2.424940E-01,2.075420E-01,2.229460E-01,1.404220E-01,& + & 8.299060E-02,2.922030E-02,2.545490E-03,1.279350E-02,5.856280E-02,& + & 2.343050E-01,4.393190E-01,7.504970E-01,1.975010E+00,4.915310E+00,& + & 6.379600E+00,8.660730E-01,2.424250E-01,2.074540E-01,2.230260E-01,& + & 1.410950E-01,8.265930E-02,2.922030E-02,4.654390E-03,1.689180E-02,& + & 7.020390E-02,2.501000E-01,4.381880E-01,7.669120E-01,2.017870E+00,& + & 4.972110E+00,6.082720E+00,7.866890E-01,2.424560E-01,2.074300E-01,& + & 2.229520E-01,1.408850E-01,8.326960E-02,2.920580E-02,2.817700E-03,& + & 1.097830E-02,3.037570E-02,6.260030E-02,1.204170E-01,2.244590E-01,& + & 4.911990E-01,1.046230E+00,5.439810E+00,1.782910E+01,2.502520E+01,& + & 3.636490E+01,5.000210E+01,7.952030E+01,4.220400E+01,2.037360E-06,& + & 7.697870E-05,6.266130E-03,4.790950E-02,2.176310E-01,4.582130E-01,& + & 7.392610E-01,1.952450E+00,4.997330E+00,6.437100E+00,8.551650E-01,& + & 2.474790E-01,2.107800E-01,2.244320E-01,1.557080E-01,9.227010E-02,& + & 3.109110E-02,2.794390E-03,1.206530E-02,5.703440E-02,2.303000E-01,& + & 4.461930E-01,7.437750E-01,1.957460E+00,4.968960E+00,6.399630E+00,& + & 8.556900E-01,2.475670E-01,2.109030E-01,2.243420E-01,1.550210E-01,& + & 9.227010E-02,3.109110E-02,3.202980E-03,1.469620E-02,6.297770E-02,& + & 2.415030E-01,4.418650E-01,7.532260E-01,1.983130E+00,4.947250E+00,& + & 6.300050E+00,8.555910E-01,2.474900E-01,2.108160E-01,2.244220E-01,& + & 1.558270E-01,9.188470E-02,3.109110E-02,5.498450E-03,1.907120E-02,& + & 7.433440E-02,2.573800E-01,4.399160E-01,7.697920E-01,2.026570E+00,& + & 5.005000E+00,6.001740E+00,7.784600E-01,2.475290E-01,2.107840E-01,& + & 2.243430E-01,1.555890E-01,9.259270E-02,3.107460E-02,3.390350E-03,& + & 1.248690E-02,3.281420E-02,6.432860E-02,1.229270E-01,2.279070E-01,& + & 5.030750E-01,1.057390E+00,5.464260E+00,1.791030E+01,2.514460E+01,& + & 3.661590E+01,4.979610E+01,7.784280E+01,4.090940E+01,2.584350E-06/ + data kb_mn2o(:,:,19) / & + & 1.155490E-04,7.686110E-03,5.294970E-02,2.255340E-01,4.620430E-01,& + & 7.417200E-01,1.959910E+00,5.030330E+00,6.358690E+00,8.447770E-01,& + & 2.526410E-01,2.142050E-01,2.258370E-01,1.719650E-01,1.025870E-01,& + & 3.308170E-02,3.832620E-03,1.420760E-02,6.184500E-02,2.379470E-01,& + & 4.491090E-01,7.465060E-01,1.965080E+00,5.001740E+00,6.321180E+00,& + & 8.453350E-01,2.527460E-01,2.143190E-01,2.257470E-01,1.711380E-01,& + & 1.025870E-01,3.308170E-02,4.030310E-03,1.688190E-02,6.772560E-02,& + & 2.489220E-01,4.444260E-01,7.559650E-01,1.991290E+00,4.979410E+00,& + & 6.221500E+00,8.452360E-01,2.526610E-01,2.142320E-01,2.258270E-01,& + & 1.720960E-01,1.021400E-01,3.308170E-02,6.495580E-03,2.153180E-02,& + & 7.870790E-02,2.648720E-01,4.416500E-01,7.726830E-01,2.035320E+00,& + & 5.038100E+00,5.921840E+00,7.703160E-01,2.527090E-01,2.141920E-01,& + & 2.257410E-01,1.718290E-01,1.029590E-01,3.306300E-02,4.079390E-03,& + & 1.420280E-02,3.544860E-02,6.610470E-02,1.254900E-01,2.314080E-01,& + & 5.152390E-01,1.068670E+00,5.488820E+00,1.799190E+01,2.526450E+01,& + & 3.686870E+01,4.959100E+01,7.620070E+01,3.965440E+01,3.278190E-06/ + +! --- the array selfref contains the coefficient of the water vapor +! self-continuum (including the energy term). the first index +! refers to temperature in 7.2 degree increments. for instance, +! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +! etc. the second index runs over the g-channel (1 to NG03=16). + + data selfref(:, :) / & + & 5.119260E-01,5.028630E-01,4.576280E-01,4.286340E-01,4.210020E-01,& + & 3.975170E-01,3.921140E-01,3.795550E-01,3.926440E-01,4.065420E-01,& + & 4.096720E-01,3.851400E-01,4.873490E-01,5.643390E-01,5.911230E-01,& + & 5.045900E-01,4.328630E-01,4.350080E-01,3.996630E-01,3.817360E-01,& + & 3.774930E-01,3.611670E-01,3.575540E-01,3.472640E-01,3.580480E-01,& + & 3.712000E-01,3.762370E-01,3.619890E-01,4.421920E-01,5.061940E-01,& + & 5.264200E-01,4.652350E-01,3.660100E-01,3.763100E-01,3.490400E-01,& + & 3.399700E-01,3.384800E-01,3.281400E-01,3.260400E-01,3.177200E-01,& + & 3.265000E-01,3.389300E-01,3.455300E-01,3.402300E-01,4.012200E-01,& + & 4.540400E-01,4.688000E-01,4.289500E-01,3.094820E-01,3.255320E-01,& + & 3.048290E-01,3.027730E-01,3.034990E-01,2.981330E-01,2.973040E-01,& + & 2.906900E-01,2.977320E-01,3.094650E-01,3.173290E-01,3.197790E-01,& + & 3.640440E-01,4.072590E-01,4.174860E-01,3.954950E-01,2.616850E-01,& + & 2.816060E-01,2.662180E-01,2.696470E-01,2.721330E-01,2.708710E-01,& + & 2.711000E-01,2.659590E-01,2.714980E-01,2.825620E-01,2.914300E-01,& + & 3.005570E-01,3.303130E-01,3.652980E-01,3.717900E-01,3.646490E-01,& + & 2.212690E-01,2.436070E-01,2.324980E-01,2.401440E-01,2.440090E-01,& + & 2.461010E-01,2.472060E-01,2.433320E-01,2.475760E-01,2.579980E-01,& + & 2.676450E-01,2.824900E-01,2.997070E-01,3.276610E-01,3.310950E-01,& + & 3.362090E-01,1.870960E-01,2.107360E-01,2.030490E-01,2.138700E-01,& + & 2.187920E-01,2.235970E-01,2.254180E-01,2.226310E-01,2.257620E-01,& + & 2.355690E-01,2.458010E-01,2.655100E-01,2.719370E-01,2.939010E-01,& + & 2.948540E-01,3.099870E-01,1.582000E-01,1.823000E-01,1.773300E-01,& + & 1.904700E-01,1.961800E-01,2.031500E-01,2.055500E-01,2.036900E-01,& + & 2.058700E-01,2.150900E-01,2.257400E-01,2.495500E-01,2.467400E-01,& + & 2.636200E-01,2.625800E-01,2.858100E-01,1.337670E-01,1.577010E-01,& + & 1.548690E-01,1.696300E-01,1.759050E-01,1.845730E-01,1.874330E-01,& + & 1.863610E-01,1.877310E-01,1.963910E-01,2.073160E-01,2.345490E-01,& + & 2.238780E-01,2.364590E-01,2.338390E-01,2.635190E-01,1.131080E-01,& + & 1.364220E-01,1.352520E-01,1.510710E-01,1.577260E-01,1.676950E-01,& + & 1.709130E-01,1.705060E-01,1.711900E-01,1.793180E-01,1.903960E-01,& + & 2.204510E-01,2.031340E-01,2.120960E-01,2.082430E-01,2.429660E-01/ + +! --- the array forref contains the coefficient of the water vapor +! foreign-continuum (including the energy term). the first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. the second index +! runs over the g-channel (1 to NG03=16). + + data forref(:, :) / & + & 9.003900E-04,1.108100E-03,1.073200E-03,1.188100E-03,1.248800E-03,& + & 1.317000E-03,1.331700E-03,1.316800E-03,1.336900E-03,1.422800E-03,& + & 1.538500E-03,1.737600E-03,1.712200E-03,1.900200E-03,1.888100E-03,& + & 2.159500E-03,1.272600E-03,1.368000E-03,1.249400E-03,1.204900E-03,& + & 1.204800E-03,1.125600E-03,1.117000E-03,1.069700E-03,1.117700E-03,& + & 1.188300E-03,1.221900E-03,1.217900E-03,1.569200E-03,1.910300E-03,& + & 2.021900E-03,1.693700E-03,1.552700E-03,1.647700E-03,1.497300E-03,& + & 1.340000E-03,1.082000E-03,9.331500E-04,8.813200E-04,8.150800E-04,& + & 8.355900E-04,7.649200E-04,8.234300E-04,7.127400E-04,6.601100E-04,& + & 6.717900E-04,6.703900E-04,6.702100E-04,1.676300E-03,1.606600E-03,& + & 1.392700E-03,1.208700E-03,9.846300E-04,8.841400E-04,8.097600E-04,& + & 7.875800E-04,7.737600E-04,7.578500E-04,7.415200E-04,7.381400E-04,& + & 7.427800E-04,7.174500E-04,6.721600E-04,6.409700E-04 / + +! --- planck fraction mapping level: p=212.7250 mbar, t = 223.06 k + + data fracrefa(:,:) / & + & 1.625100e-01,1.557200e-01,1.455700e-01,1.320800e-01,1.158200e-01,& + & 9.689500e-02,7.872000e-02,5.846200e-02,3.963100e-02,4.300100e-03,& + & 3.555500e-03,2.810100e-03,2.054700e-03,1.310900e-03,4.940300e-04,& + & 6.951500e-05,1.600600e-01,1.557600e-01,1.460900e-01,1.327600e-01,& + & 1.159400e-01,9.733600e-02,7.903500e-02,5.869600e-02,3.972300e-02,& + & 4.300100e-03,3.555500e-03,2.810100e-03,2.054700e-03,1.310900e-03,& + & 4.940300e-04,6.951500e-05,1.595200e-01,1.556600e-01,1.459000e-01,& + & 1.329400e-01,1.159900e-01,9.751100e-02,7.912700e-02,5.888800e-02,& + & 3.987400e-02,4.300100e-03,3.555500e-03,2.810200e-03,2.054700e-03,& + & 1.310900e-03,4.940300e-04,6.951500e-05,1.590700e-01,1.554100e-01,& + & 1.458500e-01,1.331600e-01,1.159600e-01,9.764700e-02,7.924300e-02,& + & 5.902400e-02,4.002800e-02,4.311200e-03,3.555500e-03,2.810200e-03,& + & 2.054700e-03,1.310900e-03,4.940300e-04,6.951500e-05,1.586200e-01,& + & 1.551700e-01,1.458800e-01,1.332800e-01,1.158500e-01,9.784000e-02,& + & 7.936400e-02,5.917400e-02,4.016000e-02,4.340300e-03,3.590000e-03,& + & 2.810200e-03,2.054700e-03,1.310900e-03,4.940300e-04,6.951500e-05,& + & 1.583000e-01,1.549000e-01,1.458200e-01,1.333100e-01,1.156700e-01,& + & 9.807900e-02,7.951000e-02,5.936900e-02,4.032600e-02,4.334300e-03,& + & 3.590800e-03,2.852700e-03,2.065500e-03,1.310900e-03,4.940300e-04,& + & 6.951500e-05,1.578900e-01,1.543500e-01,1.459500e-01,1.330400e-01,& + & 1.156600e-01,9.842600e-02,7.970400e-02,5.961800e-02,4.052000e-02,& + & 4.381200e-03,3.614700e-03,2.839500e-03,2.130100e-03,1.314500e-03,& + & 4.940300e-04,6.951500e-05,1.570400e-01,1.539800e-01,1.456400e-01,& + & 1.322200e-01,1.158600e-01,9.923000e-02,8.001100e-02,6.014900e-02,& + & 4.079000e-02,4.425300e-03,3.653400e-03,2.919100e-03,2.137300e-03,& + & 1.355800e-03,5.163100e-04,7.879400e-05,1.527000e-01,1.512600e-01,& + & 1.426400e-01,1.310600e-01,1.174000e-01,1.013700e-01,8.305700e-02,& + & 6.228200e-02,4.230100e-02,4.648600e-03,3.815900e-03,3.047200e-03,& + & 2.287000e-03,1.481800e-03,5.677300e-04,7.879400e-05 / + +! --- planck fraction mapping level: p = 95.8 mbar, t = 215.7 k + + data fracrefb(:,:) / & + & 1.641300e-01,1.566500e-01,1.460600e-01,1.318400e-01,1.151700e-01,& + & 9.624300e-02,7.798200e-02,5.816500e-02,3.931100e-02,4.258600e-03,& + & 3.518900e-03,2.779300e-03,2.037600e-03,1.293800e-03,4.885300e-04,& + & 6.874500e-05,1.625400e-01,1.567400e-01,1.465200e-01,1.322100e-01,& + & 1.153500e-01,9.643900e-02,7.815500e-02,5.825400e-02,3.934300e-02,& + & 4.258600e-03,3.518900e-03,2.779300e-03,2.037600e-03,1.293800e-03,& + & 4.885300e-04,6.874500e-05,1.617700e-01,1.566400e-01,1.466900e-01,& + & 1.324200e-01,1.154100e-01,9.653600e-02,7.825700e-02,5.838700e-02,& + & 3.943100e-02,4.258700e-03,3.518900e-03,2.779300e-03,2.037600e-03,& + & 1.293800e-03,4.885300e-04,6.874500e-05,1.607700e-01,1.567900e-01,& + & 1.464800e-01,1.327300e-01,1.154600e-01,9.677900e-02,7.837100e-02,& + & 5.854600e-02,3.961100e-02,4.277200e-03,3.519000e-03,2.779300e-03,& + & 2.037600e-03,1.293800e-03,4.885300e-04,6.874500e-05,1.606700e-01,& + & 1.560800e-01,1.424700e-01,1.288100e-01,1.144900e-01,9.880200e-02,& + & 8.082800e-02,6.097700e-02,4.149400e-02,4.511600e-03,3.729000e-03,& + & 2.946000e-03,2.194800e-03,1.377800e-03,5.455200e-04,7.996900e-05/ + +!........................................! + end module module_radlw_kgb03 ! +!========================================! + + +!> This module sets up absorption coefficients for band 04: 630-700 +!! cm-1 (low - h2o, co2; high - co2, o3) +!========================================! + module module_radlw_kgb04 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG04 +! + implicit none +! + private +! +!> msa04=585 + integer, public :: MSA04 +!> msb04=1175 + integer, public :: MSB04 +!> msf04=10 + integer, public :: MSF04 +!> mfr04=4 + integer, public :: MFR04 +!> maf04=9 + integer, public :: MAF04 +!> mbf04=5 + integer, public :: MBF04 + parameter (MSA04=585, MSB04=1175, MSF04=10, MFR04=4) + parameter (MAF04=9, MBF04=5) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG04=14). + real (kind=kind_phys), public :: forref(NG04,MFR04) + +!> the array absa(NG04,585) = ka(NG04,9,5,13) contains absorption coefs +!! at the NG04=14 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different gas +!! column amount ratios, as expressed through the binary species +!! parameter eta, defined as eta = gas1/(gas1+(rat)*gas2), where rat is +!! the ratio of the reference mls column amount value of gas1 to that +!! of gas2. the 2nd index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 1-5 +!! means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! third index, jp, runs from 1 to 13 and refers to the reference +!! pressure level (e.g. jp = 1 is for a pressure of 1053.63 mb). the +!! fourth index, ig, goes from 1 to NG04=14, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG04,MSA04) + +!> the array absb(NG04,1175) = kb(NG04,5,5,13:59) contains absorption +!! coefs at the NG04=14 g-intervals for a range of pressure levels < +!! ~100mb, temperatures, and ratios of h2o to co2. the first index in +!! the array, js, runs from 1 to 5, and corresponds to different gas +!! amount ratios, as expressed through the binary species parameter +!! eta, defined as eta = gas1/(gas1+rat*gas2), where rat is the ratio +!! of the reference mls column amount value of gas1 to that of gas2. +!! the second index, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that +!! the data are for the corresponding temperature of tref-30, tref-15, +!! tref, tref+15, and tref+30, respectively. the third index, jp, +!! runs from 13 to 59 and refers to the reference pressure level (e.g. +!! jp = 13 is for a pressure of 95.5835 mb). the fourth index, ig, +!! goes from 1 to NG04=14, and tells us which g-interval the absorption +!! coefficients are for. + real (kind=kind_phys), public :: absb(NG04,MSB04) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG04=14). + real (kind=kind_phys), public :: selfref(NG04,MSF04) + +!> planck fraction mapping level: p=212.7250 mbar, t = 223.06 k + real (kind=kind_phys), public :: fracrefa(NG04,MAF04) + +!> planck fraction mapping level : p = 95.58350 mb, t = 215.70 k + real (kind=kind_phys), public :: fracrefb(NG04,MBF04) + + data absa(:, 1: 20) / & + & 1.069700E-02,2.450100E-02,3.756400E-02,5.205700E-02,8.290100E-02,& + & 1.366400E-01,2.641200E-01,5.202200E-01,1.037000E+00,3.027700E+00,& + & 5.028400E+00,7.284900E+00,9.244100E+00,1.070513E+01,1.015100E-02,& + & 2.254600E-02,3.349200E-02,4.619100E-02,7.392400E-02,1.214200E-01,& + & 2.320900E-01,4.563500E-01,9.085700E-01,2.649500E+00,4.399700E+00,& + & 6.374500E+00,8.089300E+00,9.368710E+00,9.254900E-03,2.020600E-02,& + & 2.938500E-02,4.079100E-02,6.465700E-02,1.060400E-01,2.013600E-01,& + & 3.925200E-01,7.802300E-01,2.271600E+00,3.771300E+00,5.464300E+00,& + & 6.933400E+00,8.029690E+00,8.264500E-03,1.758000E-02,2.506400E-02,& + & 3.526400E-02,5.559700E-02,9.067300E-02,1.704100E-01,3.301000E-01,& + & 6.519200E-01,1.893300E+00,3.143300E+00,4.553700E+00,5.778200E+00,& + & 6.691806E+00,7.206100E-03,1.473300E-02,2.067900E-02,2.938600E-02,& + & 4.647200E-02,7.530700E-02,1.398700E-01,2.682300E-01,5.245700E-01,& + & 1.515300E+00,2.514800E+00,3.643100E+00,4.622800E+00,5.353926E+00,& + & 6.066200E-03,1.175700E-02,1.615900E-02,2.331100E-02,3.679600E-02,& + & 5.995100E-02,1.099700E-01,2.056700E-01,4.002500E-01,1.137200E+00,& + & 1.886700E+00,2.732600E+00,3.467200E+00,4.015527E+00,4.981600E-03,& + & 8.587100E-03,1.150200E-02,1.693300E-02,2.670900E-02,4.404900E-02,& + & 7.997700E-02,1.445200E-01,2.782800E-01,7.595100E-01,1.258500E+00,& + & 1.822300E+00,2.311900E+00,2.677617E+00,4.886700E-03,4.971500E-03,& + & 6.536700E-03,9.974100E-03,1.594800E-02,2.703700E-02,4.829400E-02,& + & 8.486500E-02,1.580400E-01,4.243100E-01,6.303400E-01,9.119000E-01,& + & 1.156700E+00,1.339909E+00,2.026900E-04,4.135800E-04,3.979400E-04,& + & 9.474200E-04,1.780200E-03,3.420000E-03,7.140600E-03,1.839600E-02,& + & 5.889700E-02,1.165300E-01,1.332400E-01,1.609100E-01,2.285500E-01,& + & 5.348145E-01,1.167700E-02,2.539200E-02,3.691600E-02,5.179900E-02,& + & 8.337000E-02,1.347900E-01,2.611400E-01,5.217700E-01,1.049200E+00,& + & 3.087700E+00,5.042800E+00,7.153000E+00,8.862300E+00,1.017422E+01,& + & 1.113800E-02,2.350400E-02,3.315100E-02,4.637000E-02,7.461800E-02,& + & 1.204100E-01,2.304100E-01,4.578900E-01,9.196200E-01,2.702100E+00,& + & 4.412200E+00,6.258800E+00,7.755200E+00,8.903187E+00,1.021600E-02,& + & 2.106100E-02,2.916000E-02,4.142400E-02,6.569800E-02,1.058100E-01,& + & 2.008400E-01,3.947400E-01,7.901400E-01,2.316700E+00,3.782200E+00,& + & 5.364800E+00,6.647300E+00,7.631481E+00,9.190900E-03,1.828200E-02,& + & 2.501800E-02,3.594200E-02,5.701900E-02,9.111400E-02,1.714100E-01,& + & 3.334200E-01,6.610100E-01,1.931100E+00,3.152100E+00,4.470900E+00,& + & 5.539700E+00,6.359651E+00,8.055300E-03,1.534000E-02,2.075100E-02,& + & 3.015100E-02,4.781200E-02,7.666900E-02,1.425300E-01,2.711400E-01,& + & 5.353500E-01,1.545400E+00,2.522300E+00,3.577000E+00,4.432000E+00,& + & 5.088102E+00,6.822300E-03,1.223800E-02,1.638900E-02,2.409000E-02,& + & 3.797800E-02,6.185100E-02,1.137000E-01,2.103100E-01,4.121900E-01,& + & 1.159900E+00,1.892100E+00,2.683000E+00,3.324500E+00,3.816530E+00,& + & 5.540800E-03,8.892100E-03,1.190100E-02,1.782700E-02,2.785500E-02,& + & 4.600900E-02,8.442600E-02,1.510400E-01,2.906400E-01,7.948000E-01,& + & 1.262000E+00,1.789100E+00,2.216800E+00,2.544906E+00,4.685400E-03,& + & 5.111400E-03,7.267800E-03,1.113800E-02,1.714600E-02,2.915100E-02,& + & 5.229200E-02,9.217400E-02,1.738100E-01,4.615800E-01,6.604000E-01,& + & 8.954800E-01,1.109100E+00,1.273286E+00,2.382500E-04,3.896600E-04,& + & 5.468600E-04,1.164300E-03,2.393500E-03,4.424400E-03,9.233900E-03,& + & 2.377400E-02,7.641400E-02,1.513300E-01,1.716000E-01,2.242100E-01,& + & 3.233500E-01,7.312700E-01,1.260500E-02,2.602700E-02,3.639900E-02,& + & 5.177400E-02,8.423500E-02,1.331300E-01,2.574600E-01,5.224600E-01,& + & 1.061700E+00,3.144300E+00,5.045000E+00,7.015800E+00,8.483300E+00,& + & 9.647580E+00,1.209200E-02,2.422100E-02,3.290300E-02,4.687500E-02,& + & 7.573000E-02,1.195600E-01,2.284600E-01,4.586300E-01,9.310200E-01,& + & 2.751400E+00,4.414800E+00,6.138900E+00,7.423300E+00,8.442497E+00/ + data absa(:, 21: 40) / & + & 1.117900E-02,2.167300E-02,2.903100E-02,4.224000E-02,6.725700E-02,& + & 1.056100E-01,2.004300E-01,3.970800E-01,8.003200E-01,2.358900E+00,& + & 3.784100E+00,5.262400E+00,6.362500E+00,7.236163E+00,1.012100E-02,& + & 1.883000E-02,2.501200E-02,3.682500E-02,5.866700E-02,9.188700E-02,& + & 1.729400E-01,3.360400E-01,6.720000E-01,1.966500E+00,3.154000E+00,& + & 4.385300E+00,5.302600E+00,6.030346E+00,8.915900E-03,1.580700E-02,& + & 2.090000E-02,3.110500E-02,4.922900E-02,7.823700E-02,1.455800E-01,& + & 2.754100E-01,5.476100E-01,1.573800E+00,2.523400E+00,3.508900E+00,& + & 4.242300E+00,4.824746E+00,7.602700E-03,1.252500E-02,1.671800E-02,& + & 2.510100E-02,3.929800E-02,6.377100E-02,1.177400E-01,2.169200E-01,& + & 4.262000E-01,1.183900E+00,1.893000E+00,2.631700E+00,3.182500E+00,& + & 3.619038E+00,6.039200E-03,9.166800E-03,1.238900E-02,1.896700E-02,& + & 2.896600E-02,4.810900E-02,8.868600E-02,1.587600E-01,3.067400E-01,& + & 8.493600E-01,1.262900E+00,1.755100E+00,2.121900E+00,2.413347E+00,& + & 4.349800E-03,5.599700E-03,8.080100E-03,1.218900E-02,1.833400E-02,& + & 3.160400E-02,5.616100E-02,9.996100E-02,1.953800E-01,4.888300E-01,& + & 7.055300E-01,9.020400E-01,1.061800E+00,1.207797E+00,2.824500E-04,& + & 3.771100E-04,7.422000E-04,1.446700E-03,3.038200E-03,5.564400E-03,& + & 1.160700E-02,3.015600E-02,9.670100E-02,1.896300E-01,2.203300E-01,& + & 3.051300E-01,4.436700E-01,9.663896E-01,1.348400E-02,2.667300E-02,& + & 3.612600E-02,5.204900E-02,8.517600E-02,1.319500E-01,2.532900E-01,& + & 5.222200E-01,1.071500E+00,3.190200E+00,5.031400E+00,6.875200E+00,& + & 8.121500E+00,9.161989E+00,1.304600E-02,2.491900E-02,3.278200E-02,& + & 4.782200E-02,7.701900E-02,1.190400E-01,2.264100E-01,4.590400E-01,& + & 9.398000E-01,2.792100E+00,4.402700E+00,6.015800E+00,7.106500E+00,& + & 8.016419E+00,1.215300E-02,2.228200E-02,2.904700E-02,4.328600E-02,& + & 6.897200E-02,1.058300E-01,2.004600E-01,3.993600E-01,8.085000E-01,& + & 2.393500E+00,3.774100E+00,5.156800E+00,6.091700E+00,6.872440E+00,& + & 1.104100E-02,1.934900E-02,2.519800E-02,3.796200E-02,6.028700E-02,& + & 9.321200E-02,1.746500E-01,3.391800E-01,6.826400E-01,1.995200E+00,& + & 3.145400E+00,4.297500E+00,5.076100E+00,5.727119E+00,9.780600E-03,& + & 1.613900E-02,2.127900E-02,3.233600E-02,5.068000E-02,7.988900E-02,& + & 1.486800E-01,2.814500E-01,5.604300E-01,1.597100E+00,2.516600E+00,& + & 3.438600E+00,4.061400E+00,4.582042E+00,8.292100E-03,1.283500E-02,& + & 1.715200E-02,2.650500E-02,4.061200E-02,6.565200E-02,1.220200E-01,& + & 2.239600E-01,4.420500E-01,1.226800E+00,1.887900E+00,2.579200E+00,& + & 3.046800E+00,3.436844E+00,6.502300E-03,9.424700E-03,1.304500E-02,& + & 2.016300E-02,3.027100E-02,5.031800E-02,9.293300E-02,1.678900E-01,& + & 3.259200E-01,8.992700E-01,1.282800E+00,1.720000E+00,2.031600E+00,& + & 2.291823E+00,4.302300E-03,5.914300E-03,8.948200E-03,1.317600E-02,& + & 1.967900E-02,3.433400E-02,6.012900E-02,1.081500E-01,2.222900E-01,& + & 5.142600E-01,7.298100E-01,9.205600E-01,1.064100E+00,1.164160E+00,& + & 3.031800E-04,4.380700E-04,8.947800E-04,1.845700E-03,3.747800E-03,& + & 6.809700E-03,1.425800E-02,3.763400E-02,1.194300E-01,2.388500E-01,& + & 2.781900E-01,4.013000E-01,5.916700E-01,1.239462E+00,1.433000E-02,& + & 2.719300E-02,3.599600E-02,5.243500E-02,8.623000E-02,1.310000E-01,& + & 2.491400E-01,5.213000E-01,1.080100E+00,3.231100E+00,5.006100E+00,& + & 6.731200E+00,7.767200E+00,8.690802E+00,1.399700E-02,2.544700E-02,& + & 3.283300E-02,4.887700E-02,7.845000E-02,1.187100E-01,2.244900E-01,& + & 4.596700E-01,9.475100E-01,2.827500E+00,4.380800E+00,5.889700E+00,& + & 6.796400E+00,7.604279E+00,1.311400E-02,2.273300E-02,2.927000E-02,& + & 4.444900E-02,7.070500E-02,1.064500E-01,2.008000E-01,4.013500E-01,& + & 8.173300E-01,2.424200E+00,3.755000E+00,5.048600E+00,5.825800E+00,& + & 6.517967E+00,1.194300E-02,1.971200E-02,2.559300E-02,3.928800E-02,& + & 6.183200E-02,9.449100E-02,1.767000E-01,3.439300E-01,6.936800E-01,& + & 2.020600E+00,3.129800E+00,4.207500E+00,4.854500E+00,5.431738E+00/ + data absa(:, 41: 60) / & + & 1.055700E-02,1.646900E-02,2.171200E-02,3.389400E-02,5.206600E-02,& + & 8.151000E-02,1.523400E-01,2.880700E-01,5.761300E-01,1.618200E+00,& + & 2.504100E+00,3.366300E+00,3.884500E+00,4.346349E+00,8.856700E-03,& + & 1.319000E-02,1.772300E-02,2.797100E-02,4.206500E-02,6.745500E-02,& + & 1.263200E-01,2.322500E-01,4.607900E-01,1.284600E+00,1.878500E+00,& + & 2.525100E+00,2.913700E+00,3.260216E+00,6.870900E-03,9.707800E-03,& + & 1.381200E-02,2.135700E-02,3.163800E-02,5.264800E-02,9.746900E-02,& + & 1.776000E-01,3.501400E-01,9.346800E-01,1.331100E+00,1.688600E+00,& + & 1.943000E+00,2.174232E+00,4.357700E-03,6.274600E-03,9.724300E-03,& + & 1.414200E-02,2.112700E-02,3.714200E-02,6.480300E-02,1.166900E-01,& + & 2.531900E-01,5.547000E-01,7.451400E-01,9.131200E-01,1.044600E+00,& + & 1.244338E+00,3.275100E-04,5.150000E-04,1.097500E-03,2.276500E-03,& + & 4.534400E-03,8.179800E-03,1.719300E-02,4.634500E-02,1.448700E-01,& + & 2.933700E-01,3.494500E-01,5.116300E-01,7.690100E-01,1.549592E+00,& + & 1.383300E-02,3.193500E-02,4.954500E-02,6.928300E-02,1.131900E-01,& + & 1.894800E-01,3.822600E-01,8.185200E-01,1.744200E+00,4.536200E+00,& + & 7.710900E+00,1.138000E+01,1.469900E+01,1.735343E+01,1.280600E-02,& + & 2.897100E-02,4.384000E-02,6.112400E-02,1.003200E-01,1.674500E-01,& + & 3.353000E-01,7.174500E-01,1.527200E+00,3.969600E+00,6.747400E+00,& + & 9.957100E+00,1.286300E+01,1.518477E+01,1.146500E-02,2.568900E-02,& + & 3.827300E-02,5.331200E-02,8.714100E-02,1.451200E-01,2.894300E-01,& + & 6.163300E-01,1.310200E+00,3.402700E+00,5.783900E+00,8.534900E+00,& + & 1.102400E+01,1.301574E+01,1.002500E-02,2.213900E-02,3.247200E-02,& + & 4.563700E-02,7.408600E-02,1.230000E-01,2.438400E-01,5.156400E-01,& + & 1.093300E+00,2.835800E+00,4.820100E+00,7.112600E+00,9.187600E+00,& + & 1.084678E+01,8.520800E-03,1.835700E-02,2.655800E-02,3.763900E-02,& + & 6.119600E-02,1.009800E-01,1.978600E-01,4.164300E-01,8.764900E-01,& + & 2.269200E+00,3.856400E+00,5.689600E+00,7.349900E+00,8.677265E+00,& + & 6.958900E-03,1.439800E-02,2.051000E-02,2.944400E-02,4.790300E-02,& + & 7.902100E-02,1.525900E-01,3.173200E-01,6.609100E-01,1.702500E+00,& + & 2.892600E+00,4.268000E+00,5.512900E+00,6.508272E+00,5.333600E-03,& + & 1.031400E-02,1.433200E-02,2.092600E-02,3.405300E-02,5.659500E-02,& + & 1.081700E-01,2.178600E-01,4.490200E-01,1.135800E+00,1.928900E+00,& + & 2.845600E+00,3.675800E+00,4.339616E+00,4.229400E-03,5.786000E-03,& + & 7.799200E-03,1.198700E-02,1.947900E-02,3.306800E-02,6.316100E-02,& + & 1.206700E-01,2.389100E-01,5.944600E-01,9.651600E-01,1.423400E+00,& + & 1.838300E+00,2.170533E+00,1.441900E-04,2.770400E-04,3.076900E-04,& + & 6.770800E-04,1.332400E-03,2.506400E-03,5.437200E-03,1.467500E-02,& + & 5.236200E-02,1.145000E-01,1.353800E-01,1.602300E-01,2.190100E-01,& + & 5.200328E-01,1.514400E-02,3.332200E-02,4.870900E-02,6.923000E-02,& + & 1.144400E-01,1.871900E-01,3.776900E-01,8.199800E-01,1.761700E+00,& + & 4.649000E+00,7.755300E+00,1.119000E+01,1.408100E+01,1.646973E+01,& + & 1.406800E-02,3.038800E-02,4.335900E-02,6.136500E-02,1.017400E-01,& + & 1.658200E-01,3.322600E-01,7.188600E-01,1.542700E+00,4.068100E+00,& + & 6.785700E+00,9.791300E+00,1.232100E+01,1.441087E+01,1.264400E-02,& + & 2.693500E-02,3.796900E-02,5.405200E-02,8.878300E-02,1.443900E-01,& + & 2.879800E-01,6.178700E-01,1.323800E+00,3.487400E+00,5.816700E+00,& + & 8.392600E+00,1.056100E+01,1.235226E+01,1.111900E-02,2.318000E-02,& + & 3.230400E-02,4.652800E-02,7.601900E-02,1.231000E-01,2.432600E-01,& + & 5.188300E-01,1.104900E+00,2.906800E+00,4.847300E+00,6.994400E+00,& + & 8.801200E+00,1.029440E+01,9.520400E-03,1.919600E-02,2.651300E-02,& + & 3.856900E-02,6.313500E-02,1.018600E-01,1.992300E-01,4.204700E-01,& + & 8.868700E-01,2.325800E+00,3.878400E+00,5.595600E+00,7.041400E+00,& + & 8.235245E+00,7.823600E-03,1.507600E-02,2.060300E-02,3.038200E-02,& + & 4.950800E-02,8.066700E-02,1.558900E-01,3.210800E-01,6.727600E-01,& + & 1.745000E+00,2.909100E+00,4.197100E+00,5.280900E+00,6.176740E+00/ + data absa(:, 61: 80) / & + & 6.022000E-03,1.077800E-02,1.462600E-02,2.175800E-02,3.540300E-02,& + & 5.842800E-02,1.126200E-01,2.236900E-01,4.618000E-01,1.165600E+00,& + & 1.940000E+00,2.798300E+00,3.521100E+00,4.118464E+00,4.408600E-03,& + & 6.019500E-03,8.405100E-03,1.293800E-02,2.048800E-02,3.491800E-02,& + & 6.732900E-02,1.286700E-01,2.518800E-01,6.484700E-01,9.743400E-01,& + & 1.399800E+00,1.761300E+00,2.060000E+00,1.735500E-04,2.793300E-04,& + & 4.147600E-04,8.461800E-04,1.782700E-03,3.280500E-03,7.087000E-03,& + & 1.912200E-02,6.869100E-02,1.491100E-01,1.789900E-01,2.109200E-01,& + & 3.166500E-01,7.259171E-01,1.639700E-02,3.437200E-02,4.816500E-02,& + & 6.947400E-02,1.160800E-01,1.855000E-01,3.718200E-01,8.216100E-01,& + & 1.776800E+00,4.755900E+00,7.777700E+00,1.099400E+01,1.347000E+01,& + & 1.560002E+01,1.529900E-02,3.148400E-02,4.312000E-02,6.206500E-02,& + & 1.034900E-01,1.647500E-01,3.284200E-01,7.205100E-01,1.556300E+00,& + & 4.161700E+00,6.806000E+00,9.619600E+00,1.178600E+01,1.365225E+01,& + & 1.381900E-02,2.788800E-02,3.779500E-02,5.523500E-02,9.080200E-02,& + & 1.441600E-01,2.855900E-01,6.206300E-01,1.335900E+00,3.567600E+00,& + & 5.833200E+00,8.245100E+00,1.010200E+01,1.170080E+01,1.223000E-02,& + & 2.396600E-02,3.224800E-02,4.769500E-02,7.832200E-02,1.235100E-01,& + & 2.430400E-01,5.230500E-01,1.115500E+00,2.973500E+00,4.861700E+00,& + & 6.871400E+00,8.417800E+00,9.750338E+00,1.052500E-02,1.986000E-02,& + & 2.657000E-02,3.980300E-02,6.511800E-02,1.033000E-01,2.012300E-01,& + & 4.241300E-01,8.993300E-01,2.379300E+00,3.889700E+00,5.497000E+00,& + & 6.734500E+00,7.801162E+00,8.689400E-03,1.558500E-02,2.083800E-02,& + & 3.150200E-02,5.119800E-02,8.246500E-02,1.595200E-01,3.266000E-01,& + & 6.866600E-01,1.785100E+00,2.917800E+00,4.123300E+00,5.051200E+00,& + & 5.851380E+00,6.732200E-03,1.107900E-02,1.497700E-02,2.292400E-02,& + & 3.680100E-02,6.031400E-02,1.173400E-01,2.314500E-01,4.756800E-01,& + & 1.217400E+00,1.945700E+00,2.749100E+00,3.367800E+00,3.901658E+00,& + & 4.588300E-03,6.344800E-03,8.968500E-03,1.398900E-02,2.162300E-02,& + & 3.696200E-02,7.151600E-02,1.378200E-01,2.692500E-01,6.901800E-01,& + & 1.017500E+00,1.375300E+00,1.684700E+00,1.951428E+00,2.102200E-04,& + & 2.711800E-04,5.683200E-04,1.072600E-03,2.278900E-03,4.149900E-03,& + & 8.969300E-03,2.447300E-02,8.759900E-02,1.906600E-01,2.266200E-01,& + & 2.824900E-01,4.414100E-01,9.757483E-01,1.760800E-02,3.524700E-02,& + & 4.796200E-02,7.004100E-02,1.178600E-01,1.845100E-01,3.654500E-01,& + & 8.214900E-01,1.790200E+00,4.849900E+00,7.775600E+00,1.078900E+01,& + & 1.287100E+01,1.477490E+01,1.651800E-02,3.238200E-02,4.307700E-02,& + & 6.326200E-02,1.054500E-01,1.646000E-01,3.242100E-01,7.207100E-01,& + & 1.568300E+00,4.243800E+00,6.803900E+00,9.440400E+00,1.126300E+01,& + & 1.292867E+01,1.501000E-02,2.865400E-02,3.784400E-02,5.663100E-02,& + & 9.314700E-02,1.445400E-01,2.832400E-01,6.230100E-01,1.346700E+00,& + & 3.637800E+00,5.832300E+00,8.091700E+00,9.654200E+00,1.108149E+01,& + & 1.334900E-02,2.462700E-02,3.239300E-02,4.914000E-02,8.058700E-02,& + & 1.248700E-01,2.431800E-01,5.258700E-01,1.127200E+00,3.032200E+00,& + & 4.860200E+00,6.743100E+00,8.045200E+00,9.234900E+00,1.152400E-02,& + & 2.040400E-02,2.687300E-02,4.124600E-02,6.704200E-02,1.051500E-01,& + & 2.034300E-01,4.286500E-01,9.129200E-01,2.426300E+00,3.888500E+00,& + & 5.395000E+00,6.436500E+00,7.388246E+00,9.566500E-03,1.594900E-02,& + & 2.123800E-02,3.295400E-02,5.294300E-02,8.441900E-02,1.633700E-01,& + & 3.340700E-01,7.021200E-01,1.821300E+00,2.916900E+00,4.046400E+00,& + & 4.827600E+00,5.541918E+00,7.358600E-03,1.139200E-02,1.540700E-02,& + & 2.439300E-02,3.820100E-02,6.235300E-02,1.217900E-01,2.403200E-01,& + & 4.931300E-01,1.286400E+00,1.945200E+00,2.698000E+00,3.218700E+00,& + & 3.695075E+00,4.770200E-03,6.653900E-03,9.643100E-03,1.506100E-02,& + & 2.279800E-02,3.932000E-02,7.570400E-02,1.476100E-01,2.921800E-01,& + & 7.215500E-01,1.063400E+00,1.385400E+00,1.611100E+00,1.848481E+00/ + data absa(:, 81:100) / & + & 2.184500E-04,3.336000E-04,6.774500E-04,1.392600E-03,2.827200E-03,& + & 5.126500E-03,1.106200E-02,3.086900E-02,1.089200E-01,2.383800E-01,& + & 2.853100E-01,3.716700E-01,5.955800E-01,1.270402E+00,1.879500E-02,& + & 3.602200E-02,4.802500E-02,7.079800E-02,1.196900E-01,1.842300E-01,& + & 3.593400E-01,8.195700E-01,1.800700E+00,4.928300E+00,7.749500E+00,& + & 1.057400E+01,1.229800E+01,1.399857E+01,1.773900E-02,3.313200E-02,& + & 4.337800E-02,6.464800E-02,1.075700E-01,1.650100E-01,3.201800E-01,& + & 7.198600E-01,1.578100E+00,4.313000E+00,6.781700E+00,9.252800E+00,& + & 1.076100E+01,1.224855E+01,1.621100E-02,2.930400E-02,3.820200E-02,& + & 5.817400E-02,9.556700E-02,1.455300E-01,2.818400E-01,6.243600E-01,& + & 1.355800E+00,3.697200E+00,5.813100E+00,7.930600E+00,9.224200E+00,& + & 1.049969E+01,1.445800E-02,2.520000E-02,3.284700E-02,5.078100E-02,& + & 8.276300E-02,1.267200E-01,2.440400E-01,5.283800E-01,1.139000E+00,& + & 3.081500E+00,4.844600E+00,6.609500E+00,7.686900E+00,8.749698E+00,& + & 1.250400E-02,2.086100E-02,2.737400E-02,4.297600E-02,6.896100E-02,& + & 1.071500E-01,2.062800E-01,4.346200E-01,9.266800E-01,2.465700E+00,& + & 3.875800E+00,5.287700E+00,6.150200E+00,6.999778E+00,1.036700E-02,& + & 1.633100E-02,2.174200E-02,3.474400E-02,5.462600E-02,8.633800E-02,& + & 1.678100E-01,3.421000E-01,7.189500E-01,1.873700E+00,2.907500E+00,& + & 3.966200E+00,4.612700E+00,5.250361E+00,7.874600E-03,1.178500E-02,& + & 1.599900E-02,2.586400E-02,3.978500E-02,6.435300E-02,1.265400E-01,& + & 2.507000E-01,5.134500E-01,1.348000E+00,1.964300E+00,2.644600E+00,& + & 3.075600E+00,3.501130E+00,4.950500E-03,6.992700E-03,1.039100E-02,& + & 1.609200E-02,2.402000E-02,4.189300E-02,8.039100E-02,1.572600E-01,& + & 3.200900E-01,7.618000E-01,1.086300E+00,1.386200E+00,1.603500E+00,& + & 1.783844E+00,2.445200E-04,3.947700E-04,8.353900E-04,1.722300E-03,& + & 3.445400E-03,6.210200E-03,1.338200E-02,3.831100E-02,1.329000E-01,& + & 2.922400E-01,3.563400E-01,4.762800E-01,7.765200E-01,1.613789E+00,& + & 2.334900E-02,5.598100E-02,8.812000E-02,1.246800E-01,2.069000E-01,& + & 3.524900E-01,7.341900E-01,1.705000E+00,3.976900E+00,9.151200E+00,& + & 1.593200E+01,2.401900E+01,3.177900E+01,3.831297E+01,2.107300E-02,& + & 4.989500E-02,7.738600E-02,1.094800E-01,1.821500E-01,3.097600E-01,& + & 6.430200E-01,1.493200E+00,3.480500E+00,8.007700E+00,1.394100E+01,& + & 2.101500E+01,2.780700E+01,3.352289E+01,1.853400E-02,4.368000E-02,& + & 6.697700E-02,9.427700E-02,1.572500E-01,2.668300E-01,5.524900E-01,& + & 1.281400E+00,2.983900E+00,6.864700E+00,1.194900E+01,1.801200E+01,& + & 2.383400E+01,2.873551E+01,1.588600E-02,3.719000E-02,5.650000E-02,& + & 7.947100E-02,1.321900E-01,2.237800E-01,4.624900E-01,1.069500E+00,& + & 2.487500E+00,5.720200E+00,9.957800E+00,1.501100E+01,1.986300E+01,& + & 2.394835E+01,1.315400E-02,3.048500E-02,4.583800E-02,6.470300E-02,& + & 1.072500E-01,1.809800E-01,3.727900E-01,8.577500E-01,1.991200E+00,& + & 4.576400E+00,7.967100E+00,1.201000E+01,1.589000E+01,1.915757E+01,& + & 1.034600E-02,2.356200E-02,3.502700E-02,4.971300E-02,8.246700E-02,& + & 1.384600E-01,2.824400E-01,6.475100E-01,1.494800E+00,3.433000E+00,& + & 5.975400E+00,9.007000E+00,1.191800E+01,1.436828E+01,7.474900E-03,& + & 1.642500E-02,2.399500E-02,3.448300E-02,5.733000E-02,9.621900E-02,& + & 1.925400E-01,4.383300E-01,9.989200E-01,2.289300E+00,3.984000E+00,& + & 6.005100E+00,7.945400E+00,9.579636E+00,4.544000E-03,9.044900E-03,& + & 1.270400E-02,1.872900E-02,3.133800E-02,5.286200E-02,1.046100E-01,& + & 2.280600E-01,5.092800E-01,1.145600E+00,1.992600E+00,3.002900E+00,& + & 3.973300E+00,4.790696E+00,9.552200E-05,1.701500E-04,2.267600E-04,& + & 4.622000E-04,9.157300E-04,1.747600E-03,3.832000E-03,1.091000E-02,& + & 4.277700E-02,1.023800E-01,1.271400E-01,1.545800E-01,1.963800E-01,& + & 4.684201E-01,2.571800E-02,5.879900E-02,8.679900E-02,1.247300E-01,& + & 2.101300E-01,3.494500E-01,7.243800E-01,1.709300E+00,4.008400E+00,& + & 9.429500E+00,1.607600E+01,2.366800E+01,3.043100E+01,3.631342E+01/ + data absa(:,101:120) / & + & 2.327200E-02,5.263100E-02,7.641900E-02,1.097200E-01,1.853700E-01,& + & 3.072900E-01,6.353100E-01,1.497100E+00,3.508200E+00,8.251200E+00,& + & 1.406700E+01,2.071200E+01,2.662800E+01,3.177571E+01,2.050300E-02,& + & 4.609100E-02,6.641900E-02,9.493900E-02,1.602600E-01,2.650300E-01,& + & 5.469700E-01,1.284800E+00,3.008400E+00,7.072600E+00,1.205800E+01,& + & 1.775200E+01,2.282300E+01,2.723904E+01,1.762200E-02,3.922600E-02,& + & 5.611900E-02,8.050500E-02,1.351700E-01,2.230400E-01,4.591000E-01,& + & 1.072600E+00,2.508200E+00,5.894100E+00,1.004800E+01,1.479400E+01,& + & 1.902000E+01,2.269803E+01,1.464800E-02,3.213700E-02,4.562300E-02,& + & 6.592400E-02,1.101700E-01,1.813500E-01,3.705500E-01,8.621600E-01,& + & 2.008200E+00,4.716000E+00,8.038700E+00,1.183500E+01,1.521700E+01,& + & 1.815870E+01,1.159600E-02,2.483600E-02,3.491600E-02,5.089500E-02,& + & 8.525500E-02,1.397100E-01,2.823400E-01,6.528800E-01,1.508400E+00,& + & 3.537600E+00,6.029600E+00,8.876400E+00,1.141200E+01,1.361939E+01,& + & 8.453100E-03,1.730100E-02,2.402500E-02,3.557100E-02,5.944800E-02,& + & 9.814700E-02,1.955300E-01,4.426100E-01,1.012300E+00,2.359100E+00,& + & 4.019900E+00,5.918100E+00,7.608600E+00,9.080295E+00,5.165200E-03,& + & 9.510900E-03,1.300400E-02,1.954600E-02,3.268900E-02,5.470400E-02,& + & 1.095300E-01,2.343500E-01,5.218900E-01,1.189400E+00,2.010500E+00,& + & 2.959400E+00,3.804900E+00,4.540805E+00,1.195700E-04,1.830500E-04,& + & 3.016800E-04,5.878500E-04,1.250700E-03,2.308200E-03,5.060700E-03,& + & 1.437000E-02,5.704100E-02,1.368300E-01,1.705600E-01,2.054800E-01,& + & 2.773600E-01,6.726954E-01,2.802500E-02,6.099600E-02,8.600100E-02,& + & 1.255700E-01,2.138500E-01,3.478600E-01,7.130800E-01,1.712300E+00,& + & 4.034500E+00,9.692900E+00,1.616400E+01,2.329900E+01,2.910300E+01,& + & 3.437177E+01,2.542100E-02,5.481300E-02,7.600500E-02,1.107400E-01,& + & 1.890400E-01,3.061600E-01,6.264400E-01,1.500000E+00,3.531600E+00,& + & 8.481200E+00,1.414500E+01,2.038900E+01,2.546500E+01,3.007535E+01,& + & 2.245200E-02,4.800600E-02,6.618400E-02,9.644300E-02,1.637900E-01,& + & 2.647500E-01,5.406000E-01,1.287400E+00,3.028600E+00,7.270400E+00,& + & 1.212400E+01,1.747500E+01,2.182600E+01,2.578287E+01,1.935300E-02,& + & 4.082000E-02,5.600800E-02,8.233000E-02,1.386500E-01,2.236700E-01,& + & 4.543700E-01,1.076400E+00,2.525900E+00,6.059400E+00,1.010300E+01,& + & 1.456300E+01,1.818800E+01,2.148226E+01,1.616300E-02,3.341400E-02,& + & 4.559100E-02,6.761700E-02,1.137400E-01,1.825700E-01,3.682600E-01,& + & 8.671100E-01,2.023200E+00,4.847900E+00,8.082900E+00,1.165000E+01,& + & 1.455100E+01,1.718645E+01,1.287600E-02,2.578700E-02,3.499000E-02,& + & 5.254700E-02,8.813300E-02,1.417800E-01,2.833300E-01,6.579400E-01,& + & 1.522300E+00,3.636400E+00,6.062700E+00,8.737800E+00,1.091400E+01,& + & 1.289096E+01,9.444000E-03,1.798500E-02,2.426300E-02,3.693800E-02,& + & 6.160400E-02,1.004300E-01,1.991600E-01,4.484200E-01,1.027500E+00,& + & 2.425000E+00,4.042400E+00,5.825600E+00,7.276600E+00,8.594738E+00,& + & 5.815100E-03,9.818700E-03,1.342400E-02,2.066600E-02,3.407000E-02,& + & 5.663300E-02,1.144100E-01,2.436000E-01,5.350800E-01,1.258100E+00,& + & 2.021700E+00,2.913400E+00,3.638700E+00,4.298184E+00,1.463800E-04,& + & 1.890500E-04,3.967600E-04,7.746700E-04,1.618200E-03,2.955600E-03,& + & 6.478400E-03,1.859000E-02,7.378000E-02,1.775000E-01,2.213500E-01,& + & 2.651000E-01,3.955100E-01,9.259287E-01,3.027300E-02,6.270700E-02,& + & 8.569100E-02,1.267500E-01,2.177200E-01,3.480500E-01,7.009700E-01,& + & 1.712100E+00,4.058800E+00,9.928900E+00,1.621100E+01,2.289500E+01,& + & 2.781000E+01,3.248403E+01,2.754200E-02,5.648100E-02,7.599400E-02,& + & 1.123100E-01,1.927600E-01,3.069000E-01,6.169600E-01,1.499800E+00,& + & 3.553500E+00,8.688500E+00,1.418500E+01,2.003300E+01,2.433400E+01,& + & 2.842323E+01,2.440000E-02,4.938800E-02,6.627000E-02,9.860400E-02,& + & 1.675300E-01,2.662300E-01,5.335300E-01,1.288000E+00,3.048200E+00,& + & 7.447700E+00,1.215900E+01,1.717200E+01,2.085800E+01,2.436545E+01/ + data absa(:,121:140) / & + & 2.111000E-02,4.198300E-02,5.615800E-02,8.450200E-02,1.425300E-01,& + & 2.255200E-01,4.496300E-01,1.079200E+00,2.543000E+00,6.206600E+00,& + & 1.013200E+01,1.431000E+01,1.738100E+01,2.030311E+01,1.771300E-02,& + & 3.434400E-02,4.578800E-02,6.970000E-02,1.172300E-01,1.850800E-01,& + & 3.670000E-01,8.714500E-01,2.038000E+00,4.965200E+00,8.106200E+00,& + & 1.144900E+01,1.390600E+01,1.624472E+01,1.416900E-02,2.652600E-02,& + & 3.529600E-02,5.447200E-02,9.081300E-02,1.448000E-01,2.853000E-01,& + & 6.622300E-01,1.538900E+00,3.725100E+00,6.080000E+00,8.586800E+00,& + & 1.042900E+01,1.218327E+01,1.044500E-02,1.846100E-02,2.470700E-02,& + & 3.855300E-02,6.376600E-02,1.030600E-01,2.035100E-01,4.561400E-01,& + & 1.044700E+00,2.484200E+00,4.053800E+00,5.725000E+00,6.953200E+00,& + & 8.122513E+00,6.407800E-03,1.011700E-02,1.383000E-02,2.207500E-02,& + & 3.551300E-02,5.884600E-02,1.191400E-01,2.539400E-01,5.528400E-01,& + & 1.337600E+00,2.036100E+00,2.862900E+00,3.476900E+00,4.061930E+00,& + & 1.537500E-04,2.409600E-04,4.918600E-04,9.992200E-04,2.031100E-03,& + & 3.697000E-03,8.090800E-03,2.369900E-02,9.293900E-02,2.241200E-01,& + & 2.796700E-01,3.434000E-01,5.445200E-01,1.230706E+00,3.248800E-02,& + & 6.419500E-02,8.617200E-02,1.284600E-01,2.214300E-01,3.501300E-01,& + & 6.896200E-01,1.707200E+00,4.076600E+00,1.011600E+01,1.621300E+01,& + & 2.245700E+01,2.658500E+01,3.073862E+01,2.966800E-02,5.789000E-02,& + & 7.671600E-02,1.144900E-01,1.963800E-01,3.094800E-01,6.083800E-01,& + & 1.495700E+00,3.569400E+00,8.851100E+00,1.418700E+01,1.965000E+01,& + & 2.326200E+01,2.689796E+01,2.636600E-02,5.059300E-02,6.696500E-02,& + & 1.011900E-01,1.712300E-01,2.691800E-01,5.268800E-01,1.286900E+00,& + & 3.062400E+00,7.588000E+00,1.216000E+01,1.684500E+01,1.993800E+01,& + & 2.305633E+01,2.291200E-02,4.297700E-02,5.682000E-02,8.701600E-02,& + & 1.463300E-01,2.285000E-01,4.464800E-01,1.080700E+00,2.555300E+00,& + & 6.323300E+00,1.013400E+01,1.403600E+01,1.661600E+01,1.921326E+01,& + & 1.928500E-02,3.516600E-02,4.648900E-02,7.208400E-02,1.205200E-01,& + & 1.886500E-01,3.670800E-01,8.740100E-01,2.051700E+00,5.059200E+00,& + & 8.106800E+00,1.122900E+01,1.329300E+01,1.536931E+01,1.546300E-02,& + & 2.717000E-02,3.597700E-02,5.666900E-02,9.355600E-02,1.479900E-01,& + & 2.881400E-01,6.681800E-01,1.554500E+00,3.795100E+00,6.081000E+00,& + & 8.422500E+00,9.969300E+00,1.152795E+01,1.141100E-02,1.891000E-02,& + & 2.533200E-02,4.055500E-02,6.594400E-02,1.056800E-01,2.085900E-01,& + & 4.658200E-01,1.061400E+00,2.551100E+00,4.054400E+00,5.615200E+00,& + & 6.646500E+00,7.686605E+00,6.903500E-03,1.051100E-02,1.438700E-02,& + & 2.351800E-02,3.711500E-02,6.113100E-02,1.238700E-01,2.661900E-01,& + & 5.740900E-01,1.394100E+00,2.088700E+00,2.808100E+00,3.324300E+00,& + & 3.843942E+00,1.741400E-04,2.917200E-04,6.117300E-04,1.245300E-03,& + & 2.508800E-03,4.528100E-03,9.898800E-03,2.955100E-02,1.148700E-01,& + & 2.754500E-01,3.508500E-01,4.383400E-01,7.192500E-01,1.594114E+00,& + & 3.968000E-02,1.004600E-01,1.610000E-01,2.302900E-01,3.850700E-01,& + & 6.662300E-01,1.423800E+00,3.567100E+00,9.234700E+00,1.942500E+01,& + & 3.350500E+01,5.194300E+01,7.054200E+01,8.705502E+01,3.524600E-02,& + & 8.869600E-02,1.410600E-01,2.018500E-01,3.378000E-01,5.838600E-01,& + & 1.246500E+00,3.122600E+00,8.080800E+00,1.699700E+01,2.931600E+01,& + & 4.544800E+01,6.172500E+01,7.616921E+01,3.068700E-02,7.695000E-02,& + & 1.211700E-01,1.733500E-01,2.904800E-01,5.015300E-01,1.069300E+00,& + & 2.678000E+00,6.926700E+00,1.456800E+01,2.512800E+01,3.895800E+01,& + & 5.290900E+01,6.529071E+01,2.598900E-02,6.501000E-02,1.016000E-01,& + & 1.448500E-01,2.431400E-01,4.189900E-01,8.924200E-01,2.233400E+00,& + & 5.773000E+00,1.214100E+01,2.094000E+01,3.246400E+01,4.408700E+01,& + & 5.440605E+01,2.119900E-02,5.285400E-02,8.195300E-02,1.166900E-01,& + & 1.957000E-01,3.364000E-01,7.159100E-01,1.788700E+00,4.619100E+00,& + & 9.712700E+00,1.675300E+01,2.597200E+01,3.527200E+01,4.352211E+01/ + data absa(:,141:160) / & + & 1.634000E-02,4.044500E-02,6.218900E-02,8.861100E-02,1.482700E-01,& + & 2.540700E-01,5.397600E-01,1.343900E+00,3.465300E+00,7.285600E+00,& + & 1.256400E+01,1.947900E+01,2.645300E+01,3.264569E+01,1.139400E-02,& + & 2.775300E-02,4.218400E-02,6.040900E-02,1.010000E-01,1.722500E-01,& + & 3.632200E-01,9.003000E-01,2.311500E+00,4.856900E+00,8.377000E+00,& + & 1.298600E+01,1.763500E+01,2.176301E+01,6.323200E-03,1.471500E-02,& + & 2.186000E-02,3.169900E-02,5.329600E-02,9.105800E-02,1.866800E-01,& + & 4.587900E-01,1.158600E+00,2.429200E+00,4.188800E+00,6.493000E+00,& + & 8.818400E+00,1.088284E+01,6.314200E-05,1.152700E-04,1.592000E-04,& + & 3.037100E-04,6.214700E-04,1.195800E-03,2.635100E-03,7.864600E-03,& + & 3.363900E-02,8.520800E-02,1.134300E-01,1.424800E-01,1.819900E-01,& + & 4.036670E-01,4.406700E-02,1.058400E-01,1.585400E-01,2.298800E-01,& + & 3.914600E-01,6.634000E-01,1.405100E+00,3.578400E+00,9.323100E+00,& + & 1.995400E+01,3.395700E+01,5.135200E+01,6.751100E+01,8.220083E+01,& + & 3.924500E-02,9.364400E-02,1.389700E-01,2.015800E-01,3.437900E-01,& + & 5.816700E-01,1.230600E+00,3.132400E+00,8.158700E+00,1.746000E+01,& + & 2.971200E+01,4.493500E+01,5.906900E+01,7.192255E+01,3.418600E-02,& + & 8.134300E-02,1.197700E-01,1.732900E-01,2.960500E-01,4.997400E-01,& + & 1.056600E+00,2.686700E+00,6.994200E+00,1.496500E+01,2.546900E+01,& + & 3.851400E+01,5.063400E+01,6.164542E+01,2.898300E-02,6.872500E-02,& + & 1.006700E-01,1.452500E-01,2.481900E-01,4.177600E-01,8.828500E-01,& + & 2.240500E+00,5.829500E+00,1.247100E+01,2.122400E+01,3.209400E+01,& + & 4.219200E+01,5.137476E+01,2.369000E-02,5.581700E-02,8.140800E-02,& + & 1.175100E-01,2.001800E-01,3.361900E-01,7.095100E-01,1.794500E+00,& + & 4.665000E+00,9.976700E+00,1.697900E+01,2.567500E+01,3.375500E+01,& + & 4.109779E+01,1.831500E-02,4.266300E-02,6.186600E-02,8.973800E-02,& + & 1.522800E-01,2.550300E-01,5.358200E-01,1.349500E+00,3.500600E+00,& + & 7.483100E+00,1.273500E+01,1.925700E+01,2.531700E+01,3.082448E+01,& + & 1.283500E-02,2.925800E-02,4.208300E-02,6.144900E-02,1.044900E-01,& + & 1.742300E-01,3.616500E-01,9.065800E-01,2.336400E+00,4.989300E+00,& + & 8.489900E+00,1.283800E+01,1.687800E+01,2.055014E+01,7.215600E-03,& + & 1.551900E-02,2.189600E-02,3.256900E-02,5.554000E-02,9.328900E-02,& + & 1.898000E-01,4.639500E-01,1.175700E+00,2.495400E+00,4.245600E+00,& + & 6.419500E+00,8.438900E+00,1.027620E+01,8.215400E-05,1.210200E-04,& + & 2.190100E-04,4.023600E-04,8.608800E-04,1.608000E-03,3.533700E-03,& + & 1.054800E-02,4.558400E-02,1.170800E-01,1.560100E-01,1.950200E-01,& + & 2.459900E-01,5.981708E-01,4.838200E-02,1.104100E-01,1.571300E-01,& + & 2.322900E-01,3.993000E-01,6.648000E-01,1.382600E+00,3.583200E+00,& + & 9.388300E+00,2.042300E+01,3.427300E+01,5.062300E+01,6.463300E+01,& + & 7.775458E+01,4.318900E-02,9.792600E-02,1.379300E-01,2.039300E-01,& + & 3.511100E-01,5.830600E-01,1.211700E+00,3.136900E+00,8.216000E+00,& + & 1.787000E+01,2.999200E+01,4.429400E+01,5.655400E+01,6.803768E+01,& + & 3.763400E-02,8.512300E-02,1.192400E-01,1.756600E-01,3.027800E-01,& + & 5.012100E-01,1.041300E+00,2.690200E+00,7.043500E+00,1.531800E+01,& + & 2.570700E+01,3.796400E+01,4.847700E+01,5.831323E+01,3.195500E-02,& + & 7.188200E-02,1.004600E-01,1.478000E-01,2.541100E-01,4.199000E-01,& + & 8.713700E-01,2.243700E+00,5.871400E+00,1.276400E+01,2.142100E+01,& + & 3.163900E+01,4.039700E+01,4.859824E+01,2.618400E-02,5.834100E-02,& + & 8.131000E-02,1.202000E-01,2.055000E-01,3.389300E-01,7.012000E-01,& + & 1.798100E+00,4.699200E+00,1.021200E+01,1.713800E+01,2.530900E+01,& + & 3.231600E+01,3.888057E+01,2.031700E-02,4.455800E-02,6.192600E-02,& + & 9.206200E-02,1.571800E-01,2.581800E-01,5.302400E-01,1.354900E+00,& + & 3.527100E+00,7.659600E+00,1.285400E+01,1.898300E+01,2.423700E+01,& + & 2.916005E+01,1.432900E-02,3.055400E-02,4.217600E-02,6.339700E-02,& + & 1.082500E-01,1.776800E-01,3.608500E-01,9.130500E-01,2.355500E+00,& + & 5.106800E+00,8.569300E+00,1.265500E+01,1.615800E+01,1.944039E+01/ + data absa(:,161:180) / & + & 8.134300E-03,1.622400E-02,2.213400E-02,3.395700E-02,5.776800E-02,& + & 9.598700E-02,1.936700E-01,4.703600E-01,1.193000E+00,2.554400E+00,& + & 4.285200E+00,6.328000E+00,8.079900E+00,9.717680E+00,1.001500E-04,& + & 1.345000E-04,2.828100E-04,5.445400E-04,1.130800E-03,2.092900E-03,& + & 4.591200E-03,1.383400E-02,5.975900E-02,1.567300E-01,2.053600E-01,& + & 2.589800E-01,3.397000E-01,8.465578E-01,5.263100E-02,1.140300E-01,& + & 1.568000E-01,2.350700E-01,4.075000E-01,6.700300E-01,1.360900E+00,& + & 3.580200E+00,9.438300E+00,2.086400E+01,3.453700E+01,4.979900E+01,& + & 6.182800E+01,7.345464E+01,4.705100E-02,1.013600E-01,1.379500E-01,& + & 2.066500E-01,3.588300E-01,5.878900E-01,1.193700E+00,3.134300E+00,& + & 8.259900E+00,1.825700E+01,3.021600E+01,4.357600E+01,5.410300E+01,& + & 6.427502E+01,4.106900E-02,8.807800E-02,1.195600E-01,1.786800E-01,& + & 3.095700E-01,5.062700E-01,1.027100E+00,2.688200E+00,7.082100E+00,& + & 1.564900E+01,2.590100E+01,3.735200E+01,4.637000E+01,5.509123E+01,& + & 3.494500E-02,7.431900E-02,1.007100E-01,1.512100E-01,2.602600E-01,& + & 4.251800E-01,8.604900E-01,2.243000E+00,5.904200E+00,1.304200E+01,& + & 2.158500E+01,3.112400E+01,3.864300E+01,4.590997E+01,2.871600E-02,& + & 6.026600E-02,8.158800E-02,1.235000E-01,2.111200E-01,3.441700E-01,& + & 6.928000E-01,1.800600E+00,4.726100E+00,1.043300E+01,1.726900E+01,& + & 2.490100E+01,3.091500E+01,3.672915E+01,2.236100E-02,4.602800E-02,& + & 6.213600E-02,9.496400E-02,1.621500E-01,2.630600E-01,5.265000E-01,& + & 1.359600E+00,3.548200E+00,7.825000E+00,1.295100E+01,1.867600E+01,& + & 2.318600E+01,2.754605E+01,1.585600E-02,3.154900E-02,4.246900E-02,& + & 6.585400E-02,1.117500E-01,1.823000E-01,3.623100E-01,9.178500E-01,& + & 2.374200E+00,5.217300E+00,8.634600E+00,1.245100E+01,1.545800E+01,& + & 1.836549E+01,9.073500E-03,1.673000E-02,2.257400E-02,3.560400E-02,& + & 5.990500E-02,9.913400E-02,1.984800E-01,4.792700E-01,1.211000E+00,& + & 2.609800E+00,4.317800E+00,6.225700E+00,7.729900E+00,9.183329E+00,& + & 1.076300E-04,1.748300E-04,3.550900E-04,7.099800E-04,1.443500E-03,& + & 2.652700E-03,5.814200E-03,1.778700E-02,7.629400E-02,2.029300E-01,& + & 2.646200E-01,3.303500E-01,4.698700E-01,1.154933E+00,5.681200E-02,& + & 1.167500E-01,1.580700E-01,2.382500E-01,4.154000E-01,6.781500E-01,& + & 1.340900E+00,3.571400E+00,9.475000E+00,2.124800E+01,3.471300E+01,& + & 4.889800E+01,5.911200E+01,6.933518E+01,5.087900E-02,1.039100E-01,& + & 1.394000E-01,2.099000E-01,3.662400E-01,5.956600E-01,1.177300E+00,& + & 3.126700E+00,8.292600E+00,1.859200E+01,3.037000E+01,4.279100E+01,& + & 5.173000E+01,6.067781E+01,4.448600E-02,9.022600E-02,1.209300E-01,& + & 1.824000E-01,3.161800E-01,5.141600E-01,1.014000E+00,2.682700E+00,& + & 7.110600E+00,1.593800E+01,2.603200E+01,3.667700E+01,4.433700E+01,& + & 5.200473E+01,3.794900E-02,7.606200E-02,1.019100E-01,1.551500E-01,& + & 2.664100E-01,4.328100E-01,8.493200E-01,2.241700E+00,5.928300E+00,& + & 1.328100E+01,2.169600E+01,3.056600E+01,3.694600E+01,4.334062E+01,& + & 3.126600E-02,6.169900E-02,8.258000E-02,1.270400E-01,2.170900E-01,& + & 3.509800E-01,6.860600E-01,1.802200E+00,4.746300E+00,1.062400E+01,& + & 1.735600E+01,2.445200E+01,2.955800E+01,3.467219E+01,2.443900E-02,& + & 4.711900E-02,6.303600E-02,9.807500E-02,1.669900E-01,2.695200E-01,& + & 5.248600E-01,1.363500E+00,3.564800E+00,7.969200E+00,1.301800E+01,& + & 1.834000E+01,2.216900E+01,2.600358E+01,1.739700E-02,3.231500E-02,& + & 4.325200E-02,6.838400E-02,1.152100E-01,1.876400E-01,3.648200E-01,& + & 9.239200E-01,2.392600E+00,5.313100E+00,8.679100E+00,1.222600E+01,& + & 1.477900E+01,1.733777E+01,9.986500E-03,1.716000E-02,2.316900E-02,& + & 3.749400E-02,6.207900E-02,1.024900E-01,2.036900E-01,4.907600E-01,& + & 1.228300E+00,2.693100E+00,4.340000E+00,6.113400E+00,7.390300E+00,& + & 8.669778E+00,1.243300E-04,2.141500E-04,4.443700E-04,8.953600E-04,& + & 1.808100E-03,3.289600E-03,7.204800E-03,2.230600E-02,9.554200E-02,& + & 2.542100E-01,3.323000E-01,4.183500E-01,6.306200E-01,1.527971E+00/ + data absa(:,181:200) / & + & 6.165900E-02,1.644000E-01,2.729500E-01,3.894500E-01,6.603900E-01,& + & 1.155000E+00,2.520600E+00,6.741800E+00,1.958500E+01,4.014700E+01,& + & 6.481300E+01,1.037300E+02,1.443900E+02,1.822766E+02,5.436000E-02,& + & 1.444800E-01,2.389600E-01,3.410300E-01,5.784900E-01,1.011200E+00,& + & 2.206200E+00,5.900300E+00,1.713700E+01,3.513000E+01,5.671200E+01,& + & 9.075900E+01,1.263400E+02,1.595004E+02,4.700000E-02,1.246400E-01,& + & 2.049700E-01,2.925900E-01,4.965900E-01,8.677200E-01,1.891700E+00,& + & 5.058700E+00,1.468900E+01,3.011100E+01,4.860800E+01,7.779600E+01,& + & 1.083000E+02,1.367123E+02,3.957100E-02,1.047500E-01,1.710700E-01,& + & 2.441500E-01,4.146500E-01,7.239900E-01,1.577300E+00,4.217100E+00,& + & 1.224200E+01,2.509300E+01,4.050700E+01,6.482600E+01,9.024800E+01,& + & 1.139280E+02,3.204600E-02,8.470600E-02,1.374200E-01,1.957100E-01,& + & 3.326800E-01,5.801800E-01,1.263100E+00,3.375400E+00,9.794100E+00,& + & 2.007300E+01,3.240800E+01,5.185700E+01,7.219900E+01,9.114264E+01,& + & 2.443100E-02,6.445800E-02,1.037200E-01,1.475400E-01,2.506800E-01,& + & 4.362000E-01,9.492300E-01,2.533800E+00,7.346500E+00,1.505600E+01,& + & 2.430600E+01,3.889400E+01,5.415100E+01,6.835838E+01,1.673100E-02,& + & 4.388300E-02,6.989700E-02,9.956500E-02,1.687800E-01,2.924400E-01,& + & 6.358800E-01,1.692100E+00,4.898800E+00,1.003800E+01,1.620400E+01,& + & 2.593100E+01,3.609900E+01,4.557264E+01,8.900200E-03,2.282400E-02,& + & 3.575600E-02,5.135200E-02,8.690600E-02,1.497600E-01,3.219400E-01,& + & 8.517300E-01,2.451500E+00,5.018900E+00,8.101700E+00,1.296600E+01,& + & 1.805000E+01,2.278636E+01,4.413500E-05,7.521300E-05,1.134500E-04,& + & 2.040900E-04,4.139200E-04,8.106900E-04,1.803900E-03,5.526900E-03,& + & 2.610200E-02,6.835900E-02,9.635600E-02,1.288700E-01,1.657900E-01,& + & 3.508902E-01,6.917700E-02,1.741800E-01,2.690900E-01,3.898100E-01,& + & 6.713800E-01,1.156400E+00,2.486400E+00,6.765600E+00,1.978000E+01,& + & 4.092400E+01,6.616400E+01,1.027600E+02,1.383800E+02,1.718754E+02,& + & 6.107700E-02,1.533000E-01,2.356700E-01,3.414700E-01,5.884300E-01,& + & 1.012800E+00,2.176500E+00,5.921200E+00,1.730900E+01,3.581000E+01,& + & 5.789500E+01,8.990800E+01,1.210900E+02,1.503707E+02,5.288500E-02,& + & 1.324300E-01,2.022800E-01,2.930500E-01,5.053800E-01,8.689100E-01,& + & 1.866900E+00,5.076500E+00,1.483700E+01,3.069200E+01,4.962300E+01,& + & 7.706500E+01,1.037800E+02,1.289020E+02,4.454000E-02,1.114000E-01,& + & 1.692200E-01,2.446600E-01,4.223800E-01,7.253400E-01,1.557500E+00,& + & 4.231900E+00,1.236500E+01,2.557600E+01,4.135200E+01,6.422200E+01,& + & 8.648000E+01,1.074165E+02,3.608300E-02,9.010900E-02,1.361800E-01,& + & 1.965900E-01,3.394000E-01,5.814700E-01,1.248300E+00,3.387300E+00,& + & 9.893200E+00,2.046100E+01,3.308400E+01,5.138200E+01,6.918000E+01,& + & 8.593694E+01,2.755300E-02,6.851900E-02,1.030300E-01,1.487500E-01,& + & 2.563300E-01,4.378100E-01,9.395300E-01,2.542800E+00,7.421600E+00,& + & 1.534600E+01,2.481300E+01,3.853500E+01,5.189000E+01,6.444893E+01,& + & 1.892000E-02,4.657600E-02,6.959800E-02,1.008800E-01,1.733400E-01,& + & 2.947700E-01,6.305100E-01,1.699000E+00,4.950000E+00,1.023200E+01,& + & 1.654200E+01,2.569000E+01,3.459300E+01,4.296804E+01,1.013800E-02,& + & 2.420200E-02,3.574100E-02,5.238700E-02,9.001000E-02,1.528200E-01,& + & 3.208000E-01,8.585700E-01,2.478900E+00,5.116000E+00,8.270700E+00,& + & 1.284500E+01,1.729900E+01,2.148423E+01,5.727800E-05,8.051000E-05,& + & 1.588700E-04,2.733900E-04,5.903900E-04,1.115700E-03,2.459800E-03,& + & 7.573200E-03,3.585900E-02,9.692600E-02,1.365200E-01,1.802700E-01,& + & 2.298800E-01,5.219719E-01,7.656100E-02,1.825400E-01,2.665400E-01,& + & 3.949700E-01,6.843400E-01,1.166900E+00,2.450200E+00,6.774600E+00,& + & 1.993500E+01,4.153600E+01,6.722800E+01,1.014800E+02,1.325900E+02,& + & 1.622586E+02,6.772100E-02,1.608800E-01,2.334800E-01,3.461200E-01,& + & 6.001400E-01,1.022300E+00,2.145500E+00,5.928900E+00,1.744400E+01,& + & 3.634300E+01,5.882600E+01,8.879400E+01,1.160200E+02,1.419746E+02/ + data absa(:,201:220) / & + & 5.867600E-02,1.391200E-01,2.007700E-01,2.972400E-01,5.159600E-01,& + & 8.775200E-01,1.841000E+00,5.083500E+00,1.495400E+01,3.115300E+01,& + & 5.042500E+01,7.611300E+01,9.943200E+01,1.216914E+02,4.943600E-02,& + & 1.170200E-01,1.683300E-01,2.486100E-01,4.316700E-01,7.326500E-01,& + & 1.537000E+00,4.238000E+00,1.246300E+01,2.596200E+01,4.201800E+01,& + & 6.342000E+01,8.286000E+01,1.014120E+02,4.010900E-02,9.458600E-02,& + & 1.358300E-01,2.002800E-01,3.472100E-01,5.879900E-01,1.233300E+00,& + & 3.392400E+00,9.972100E+00,2.076900E+01,3.361300E+01,5.073600E+01,& + & 6.628500E+01,8.113381E+01,3.067500E-02,7.183700E-02,1.028800E-01,& + & 1.522600E-01,2.627300E-01,4.439900E-01,9.294200E-01,2.547400E+00,& + & 7.481400E+00,1.557700E+01,2.521100E+01,3.805500E+01,4.971800E+01,& + & 6.084854E+01,2.114900E-02,4.876700E-02,6.962700E-02,1.036900E-01,& + & 1.785000E-01,3.005400E-01,6.240300E-01,1.705700E+00,4.991100E+00,& + & 1.038500E+01,1.680800E+01,2.537100E+01,3.314600E+01,4.056503E+01,& + & 1.142900E-02,2.535000E-02,3.583400E-02,5.417700E-02,9.327700E-02,& + & 1.573500E-01,3.216000E-01,8.654800E-01,2.501700E+00,5.192800E+00,& + & 8.404400E+00,1.268600E+01,1.657300E+01,2.028282E+01,6.817700E-05,& + & 9.619600E-05,2.043200E-04,3.798400E-04,7.885600E-04,1.477900E-03,& + & 3.247100E-03,1.013700E-02,4.757500E-02,1.330400E-01,1.847200E-01,& + & 2.435000E-01,3.106300E-01,7.584247E-01,8.385500E-02,1.893700E-01,& + & 2.663300E-01,4.014900E-01,6.993500E-01,1.183000E+00,2.417600E+00,& + & 6.764100E+00,2.005100E+01,4.216600E+01,6.803500E+01,9.998100E+01,& + & 1.269700E+02,1.532078E+02,7.428700E-02,1.671300E-01,2.334600E-01,& + & 3.520400E-01,6.138100E-01,1.036800E+00,2.117700E+00,5.920000E+00,& + & 1.754600E+01,3.689600E+01,5.953600E+01,8.748600E+01,1.111000E+02,& + & 1.340595E+02,6.439800E-02,1.445400E-01,2.012500E-01,3.027000E-01,& + & 5.282100E-01,8.903000E-01,1.818100E+00,5.075900E+00,1.504100E+01,& + & 3.162400E+01,5.102400E+01,7.498900E+01,9.521900E+01,1.149205E+02,& + & 5.431700E-02,1.215500E-01,1.690300E-01,2.538200E-01,4.422400E-01,& + & 7.440700E-01,1.518900E+00,4.232000E+00,1.253700E+01,2.635300E+01,& + & 4.252300E+01,6.249200E+01,7.935700E+01,9.577034E+01,4.413900E-02,& + & 9.819500E-02,1.363200E-01,2.054600E-01,3.560600E-01,5.986100E-01,& + & 1.219300E+00,3.389100E+00,1.003200E+01,2.108300E+01,3.401900E+01,& + & 4.999200E+01,6.348200E+01,7.661233E+01,3.385500E-02,7.451400E-02,& + & 1.033400E-01,1.568400E-01,2.700500E-01,4.535400E-01,9.184500E-01,& + & 2.548700E+00,7.527300E+00,1.581300E+01,2.551300E+01,3.749600E+01,& + & 4.760900E+01,5.745987E+01,2.343400E-02,5.056900E-02,6.996800E-02,& + & 1.072400E-01,1.843500E-01,3.082600E-01,6.193700E-01,1.709900E+00,& + & 5.022700E+00,1.054200E+01,1.701000E+01,2.499600E+01,3.174000E+01,& + & 3.830803E+01,1.275800E-02,2.630800E-02,3.615200E-02,5.645800E-02,& + & 9.663000E-02,1.627500E-01,3.241500E-01,8.710000E-01,2.523900E+00,& + & 5.271500E+00,8.506400E+00,1.249800E+01,1.587100E+01,1.915441E+01,& + & 7.565500E-05,1.269600E-04,2.578400E-04,5.016000E-04,1.025600E-03,& + & 1.900100E-03,4.172700E-03,1.321900E-02,6.148400E-02,1.757900E-01,& + & 2.424200E-01,3.189500E-01,4.151000E-01,1.063746E+00,9.111200E-02,& + & 1.945200E-01,2.686800E-01,4.077300E-01,7.152400E-01,1.201600E+00,& + & 2.394300E+00,6.741300E+00,2.013500E+01,4.277100E+01,6.855400E+01,& + & 9.840300E+01,1.215200E+02,1.445435E+02,8.083600E-02,1.718300E-01,& + & 2.359200E-01,3.578600E-01,6.282700E-01,1.053400E+00,2.097700E+00,& + & 5.900800E+00,1.762000E+01,3.742500E+01,5.998700E+01,8.609800E+01,& + & 1.063200E+02,1.264777E+02,7.009300E-02,1.486400E-01,2.036600E-01,& + & 3.083900E-01,5.410400E-01,9.052900E-01,1.801500E+00,5.060600E+00,& + & 1.510600E+01,3.207900E+01,5.142000E+01,7.380100E+01,9.112900E+01,& + & 1.084019E+02,5.920500E-02,1.249500E-01,1.710900E-01,2.595600E-01,& + & 4.531900E-01,7.581300E-01,1.505500E+00,4.220700E+00,1.259100E+01,& + & 2.673200E+01,4.284900E+01,6.149800E+01,7.594200E+01,9.034176E+01/ + data absa(:,221:240) / & + & 4.819500E-02,1.008600E-01,1.380300E-01,2.109000E-01,3.655000E-01,& + & 6.114000E-01,1.208200E+00,3.383300E+00,1.007600E+01,2.138500E+01,& + & 3.427700E+01,4.919900E+01,6.075200E+01,7.227644E+01,3.707600E-02,& + & 7.652000E-02,1.046700E-01,1.614100E-01,2.782800E-01,4.643200E-01,& + & 9.121000E-01,2.547500E+00,7.560900E+00,1.604000E+01,2.571000E+01,& + & 3.690200E+01,4.556800E+01,5.420322E+01,2.575700E-02,5.196400E-02,& + & 7.093200E-02,1.108600E-01,1.902500E-01,3.174600E-01,6.189200E-01,& + & 1.712800E+00,5.046300E+00,1.069300E+01,1.714000E+01,2.459800E+01,& + & 3.037800E+01,3.613857E+01,1.411000E-02,2.704000E-02,3.687700E-02,& + & 5.883800E-02,9.998800E-02,1.686600E-01,3.285600E-01,8.781300E-01,& + & 2.545000E+00,5.347300E+00,8.570200E+00,1.230100E+01,1.519000E+01,& + & 1.807052E+01,8.992100E-05,1.561100E-04,3.243600E-04,6.438400E-04,& + & 1.302300E-03,2.388500E-03,5.238300E-03,1.673600E-02,7.795200E-02,& + & 2.239300E-01,3.091900E-01,4.049100E-01,5.550300E-01,1.439717E+00,& + & 8.888200E-02,2.492100E-01,4.335700E-01,6.210900E-01,1.060500E+00,& + & 1.872800E+00,4.153500E+00,1.175500E+01,3.863100E+01,8.002700E+01,& + & 1.180100E+02,1.944900E+02,2.781500E+02,3.589079E+02,7.809400E-02,& + & 2.185900E-01,3.795100E-01,5.437000E-01,9.283500E-01,1.639400E+00,& + & 3.634900E+00,1.028700E+01,3.380100E+01,7.002200E+01,1.032600E+02,& + & 1.702100E+02,2.433900E+02,3.139802E+02,6.725700E-02,1.879800E-01,& + & 3.254200E-01,4.661900E-01,7.963800E-01,1.405700E+00,3.116300E+00,& + & 8.818200E+00,2.897400E+01,6.002300E+01,8.850600E+01,1.458900E+02,& + & 2.086200E+02,2.691472E+02,5.637600E-02,1.574000E-01,2.712900E-01,& + & 3.887700E-01,6.641600E-01,1.172400E+00,2.597600E+00,7.349400E+00,& + & 2.414400E+01,5.001900E+01,7.375700E+01,1.215700E+02,1.738400E+02,& + & 2.242954E+02,4.546800E-02,1.267900E-01,2.172800E-01,3.113200E-01,& + & 5.320400E-01,9.387300E-01,2.078900E+00,5.881200E+00,1.931600E+01,& + & 4.001300E+01,5.900200E+01,9.725800E+01,1.390800E+02,1.794304E+02,& + & 3.447100E-02,9.603000E-02,1.634600E-01,2.338300E-01,3.998800E-01,& + & 7.050200E-01,1.560400E+00,4.412700E+00,1.448800E+01,3.001100E+01,& + & 4.425400E+01,7.294300E+01,1.043000E+02,1.345792E+02,2.337200E-02,& + & 6.501100E-02,1.096400E-01,1.567100E-01,2.677200E-01,4.711900E-01,& + & 1.042400E+00,2.944200E+00,9.659700E+00,2.000700E+01,2.950300E+01,& + & 4.862800E+01,6.954100E+01,8.972021E+01,1.214100E-02,3.351300E-02,& + & 5.566200E-02,7.960200E-02,1.359900E-01,2.374600E-01,5.249900E-01,& + & 1.475700E+00,4.831500E+00,1.000400E+01,1.475100E+01,2.431400E+01,& + & 3.476900E+01,4.485812E+01,3.400800E-05,4.781600E-05,8.332500E-05,& + & 1.334100E-04,2.666500E-04,5.340100E-04,1.211900E-03,3.767000E-03,& + & 1.960400E-02,5.392400E-02,7.734400E-02,1.101400E-01,1.493200E-01,& + & 3.026225E-01,1.008800E-01,2.665700E-01,4.279400E-01,6.231400E-01,& + & 1.079300E+00,1.885500E+00,4.099900E+00,1.179000E+01,3.902200E+01,& + & 8.117300E+01,1.210800E+02,1.930900E+02,2.670300E+02,3.382935E+02,& + & 8.869000E-02,2.339800E-01,3.745900E-01,5.455600E-01,9.450800E-01,& + & 1.650600E+00,3.588200E+00,1.031800E+01,3.414500E+01,7.102400E+01,& + & 1.059400E+02,1.689700E+02,2.336500E+02,2.960010E+02,7.645400E-02,& + & 2.014700E-01,3.212300E-01,4.679300E-01,8.109700E-01,1.415900E+00,& + & 3.076500E+00,8.844400E+00,2.926800E+01,6.087800E+01,9.080800E+01,& + & 1.448300E+02,2.002800E+02,2.537250E+02,6.416600E-02,1.689000E-01,& + & 2.679800E-01,3.903700E-01,6.766900E-01,1.180800E+00,2.565000E+00,& + & 7.371800E+00,2.439000E+01,5.073100E+01,7.567200E+01,1.207000E+02,& + & 1.669000E+02,2.114391E+02,5.176400E-02,1.361900E-01,2.149400E-01,& + & 3.127000E-01,5.423900E-01,9.457500E-01,2.053600E+00,5.899000E+00,& + & 1.951300E+01,4.058400E+01,6.054100E+01,9.655900E+01,1.335100E+02,& + & 1.691511E+02,3.925600E-02,1.032200E-01,1.619700E-01,2.353400E-01,& + & 4.081600E-01,7.104900E-01,1.542600E+00,4.426100E+00,1.463600E+01,& + & 3.043900E+01,4.540600E+01,7.241900E+01,1.001400E+02,1.268557E+02/ + data absa(:,241:260) / & + & 2.665100E-02,6.986600E-02,1.089400E-01,1.582700E-01,2.739600E-01,& + & 4.753400E-01,1.031900E+00,2.953500E+00,9.759500E+00,2.029300E+01,& + & 3.027100E+01,4.827900E+01,6.676400E+01,8.457087E+01,1.390600E-02,& + & 3.591500E-02,5.548800E-02,8.099200E-02,1.401100E-01,2.412200E-01,& + & 5.207600E-01,1.482400E+00,4.883100E+00,1.014700E+01,1.513400E+01,& + & 2.413900E+01,3.338100E+01,4.228656E+01,4.149600E-05,5.577100E-05,& + & 1.143300E-04,1.815200E-04,3.957800E-04,7.551000E-04,1.687800E-03,& + & 5.275600E-03,2.743500E-02,7.816500E-02,1.126300E-01,1.600400E-01,& + & 2.103800E-01,4.535172E-01,1.126800E-01,2.807800E-01,4.236200E-01,& + & 6.295700E-01,1.099600E+00,1.912700E+00,4.050100E+00,1.180200E+01,& + & 3.934800E+01,8.228000E+01,1.235400E+02,1.914000E+02,2.561000E+02,& + & 3.185481E+02,9.917000E-02,2.466700E-01,3.709000E-01,5.513600E-01,& + & 9.631200E-01,1.674700E+00,3.545200E+00,1.032800E+01,3.443100E+01,& + & 7.199600E+01,1.081000E+02,1.674700E+02,2.240900E+02,2.787207E+02,& + & 8.558400E-02,2.125800E-01,3.182200E-01,4.730800E-01,8.267400E-01,& + & 1.436700E+00,3.040000E+00,8.853800E+00,2.951400E+01,6.171000E+01,& + & 9.265200E+01,1.435600E+02,1.920700E+02,2.389140E+02,7.186700E-02,& + & 1.783100E-01,2.658500E-01,3.947500E-01,6.902600E-01,1.198500E+00,& + & 2.535400E+00,7.379600E+00,2.459600E+01,5.142500E+01,7.721300E+01,& + & 1.196300E+02,1.600700E+02,1.990841E+02,5.799700E-02,1.437600E-01,& + & 2.135900E-01,3.167600E-01,5.538500E-01,9.601700E-01,2.031000E+00,& + & 5.905500E+00,1.967900E+01,4.114100E+01,6.176900E+01,9.570900E+01,& + & 1.280500E+02,1.592737E+02,4.401900E-02,1.088700E-01,1.613300E-01,& + & 2.390600E-01,4.173400E-01,7.220200E-01,1.526900E+00,4.431200E+00,& + & 1.476100E+01,3.085500E+01,4.633000E+01,7.177700E+01,9.603900E+01,& + & 1.194541E+02,2.995100E-02,7.355300E-02,1.087000E-01,1.614700E-01,& + & 2.809300E-01,4.843800E-01,1.022600E+00,2.958000E+00,9.844200E+00,& + & 2.057000E+01,3.088600E+01,4.785300E+01,6.402500E+01,7.963374E+01,& + & 1.571400E-02,3.775200E-02,5.544400E-02,8.322500E-02,1.443700E-01,& + & 2.480700E-01,5.168100E-01,1.489200E+00,4.926700E+00,1.028500E+01,& + & 1.544300E+01,2.392600E+01,3.201600E+01,3.981820E+01,4.758700E-05,& + & 7.232400E-05,1.429400E-04,2.597000E-04,5.428100E-04,1.022800E-03,& + & 2.270300E-03,7.203100E-03,3.694900E-02,1.093400E-01,1.568200E-01,& + & 2.219000E-01,2.919300E-01,6.623699E-01,1.244300E-01,2.928100E-01,& + & 4.235600E-01,6.409100E-01,1.127000E+00,1.945800E+00,4.017200E+00,& + & 1.177100E+01,3.959400E+01,8.311500E+01,1.252600E+02,1.889900E+02,& + & 2.460200E+02,3.006987E+02,1.096100E-01,2.575200E-01,3.709200E-01,& + & 5.614700E-01,9.875800E-01,1.704100E+00,3.517000E+00,1.030100E+01,& + & 3.464600E+01,7.272200E+01,1.096000E+02,1.653700E+02,2.152700E+02,& + & 2.631262E+02,9.468600E-02,2.220200E-01,3.186000E-01,4.819600E-01,& + & 8.481400E-01,1.462200E+00,3.016300E+00,8.831000E+00,2.969800E+01,& + & 6.233600E+01,9.394300E+01,1.417400E+02,1.845100E+02,2.255334E+02,& + & 7.952400E-02,1.862200E-01,2.665600E-01,4.026500E-01,7.087700E-01,& + & 1.220200E+00,2.516300E+00,7.361200E+00,2.475100E+01,5.194700E+01,& + & 7.828400E+01,1.181000E+02,1.537600E+02,1.879401E+02,6.421600E-02,& + & 1.500800E-01,2.145700E-01,3.237000E-01,5.691000E-01,9.782600E-01,& + & 2.016600E+00,5.891700E+00,1.980300E+01,4.155800E+01,6.262900E+01,& + & 9.449300E+01,1.230000E+02,1.503464E+02,4.882500E-02,1.135600E-01,& + & 1.621700E-01,2.451500E-01,4.293700E-01,7.369400E-01,1.516800E+00,& + & 4.422400E+00,1.485500E+01,3.116700E+01,4.697500E+01,7.086700E+01,& + & 9.225300E+01,1.127644E+02,3.330700E-02,7.669300E-02,1.092800E-01,& + & 1.663800E-01,2.896800E-01,4.964400E-01,1.015300E+00,2.956800E+00,& + & 9.907900E+00,2.077800E+01,3.131600E+01,4.724600E+01,6.150300E+01,& + & 7.517672E+01,1.758600E-02,3.933900E-02,5.585800E-02,8.625500E-02,& + & 1.494800E-01,2.563400E-01,5.169500E-01,1.492700E+00,4.960300E+00,& + & 1.039000E+01,1.565700E+01,2.362200E+01,3.075200E+01,3.758979E+01/ + data absa(:,261:280) / & + & 5.473400E-05,9.183100E-05,1.848700E-04,3.513900E-04,7.169200E-04,& + & 1.341300E-03,2.963400E-03,9.539800E-03,4.844200E-02,1.459500E-01,& + & 2.120700E-01,2.957100E-01,3.873500E-01,9.502821E-01,1.360800E-01,& + & 3.022100E-01,4.273200E-01,6.538800E-01,1.154900E+00,1.981900E+00,& + & 4.004700E+00,1.171700E+01,3.977000E+01,8.381900E+01,1.266400E+02,& + & 1.856600E+02,2.369800E+02,2.836729E+02,1.200300E-01,2.659800E-01,& + & 3.744400E-01,5.730700E-01,1.012500E+00,1.736000E+00,3.505900E+00,& + & 1.025400E+01,3.480100E+01,7.334900E+01,1.108100E+02,1.624500E+02,& + & 2.073700E+02,2.482166E+02,1.037200E-01,2.292900E-01,3.221300E-01,& + & 4.922300E-01,8.702200E-01,1.489900E+00,3.008100E+00,8.791200E+00,& + & 2.983200E+01,6.286700E+01,9.497600E+01,1.392500E+02,1.777500E+02,& + & 2.127647E+02,8.715500E-02,1.923100E-01,2.699200E-01,4.119100E-01,& + & 7.276400E-01,1.244000E+00,2.509900E+00,7.329200E+00,2.486200E+01,& + & 5.239100E+01,7.914900E+01,1.160300E+02,1.481100E+02,1.772943E+02,& + & 7.046600E-02,1.549000E-01,2.174200E-01,3.320500E-01,5.847800E-01,& + & 9.988300E-01,2.012000E+00,5.867200E+00,1.989300E+01,4.191300E+01,& + & 6.332100E+01,9.283400E+01,1.184900E+02,1.418396E+02,5.366000E-02,& + & 1.171700E-01,1.643300E-01,2.523700E-01,4.417000E-01,7.544200E-01,& + & 1.512800E+00,4.408000E+00,1.492400E+01,3.143400E+01,4.749000E+01,& + & 6.962300E+01,8.886600E+01,1.063832E+02,3.671600E-02,7.907200E-02,& + & 1.108400E-01,1.717100E-01,2.990700E-01,5.098100E-01,1.014900E+00,& + & 2.950400E+00,9.954400E+00,2.095700E+01,3.165800E+01,4.641500E+01,& + & 5.924800E+01,7.092294E+01,1.949000E-02,4.061400E-02,5.675600E-02,& + & 8.944800E-02,1.547700E-01,2.652400E-01,5.219400E-01,1.494200E+00,& + & 4.987100E+00,1.047900E+01,1.583100E+01,2.320900E+01,2.962200E+01,& + & 3.546207E+01,6.453200E-05,1.167000E-04,2.336700E-04,4.553100E-04,& + & 9.273500E-04,1.713000E-03,3.774800E-03,1.226400E-02,6.216900E-02,& + & 1.880600E-01,2.772400E-01,3.827400E-01,5.056700E-01,1.318886E+00,& + & 1.339300E-01,3.947100E-01,7.220100E-01,1.045700E+00,1.790200E+00,& + & 3.195600E+00,7.145400E+00,2.120100E+01,7.923000E+01,1.699600E+02,& + & 2.324900E+02,3.841700E+02,5.653100E+02,7.436985E+02,1.174300E-01,& + & 3.457600E-01,6.318500E-01,9.151900E-01,1.566600E+00,2.796400E+00,& + & 6.252600E+00,1.855200E+01,6.932600E+01,1.487100E+02,2.034100E+02,& + & 3.361300E+02,4.946500E+02,6.507150E+02,1.009100E-01,2.968700E-01,& + & 5.416800E-01,7.846000E-01,1.343200E+00,2.397300E+00,5.359700E+00,& + & 1.590200E+01,5.942400E+01,1.274700E+02,1.743500E+02,2.881100E+02,& + & 4.239600E+02,5.577414E+02,8.436600E-02,2.479700E-01,4.514800E-01,& + & 6.540100E-01,1.119800E+00,1.998300E+00,4.466900E+00,1.325300E+01,& + & 4.952000E+01,1.062200E+02,1.452900E+02,2.400900E+02,3.533100E+02,& + & 4.647961E+02,6.779600E-02,1.990900E-01,3.613100E-01,5.234900E-01,& + & 8.963000E-01,1.599400E+00,3.574400E+00,1.060400E+01,3.961700E+01,& + & 8.497700E+01,1.162400E+02,1.920500E+02,2.826700E+02,3.718531E+02,& + & 5.119100E-02,1.501600E-01,2.712300E-01,3.929200E-01,6.729100E-01,& + & 1.200500E+00,2.681600E+00,7.954600E+00,2.971300E+01,6.373400E+01,& + & 8.717800E+01,1.440500E+02,2.119800E+02,2.788695E+02,3.448700E-02,& + & 1.011200E-01,1.813100E-01,2.623000E-01,4.493900E-01,8.014000E-01,& + & 1.789100E+00,5.304900E+00,1.981000E+01,4.249000E+01,5.811700E+01,& + & 9.603700E+01,1.413200E+02,1.859189E+02,1.764700E-02,5.171900E-02,& + & 9.134700E-02,1.322000E-01,2.259400E-01,4.020400E-01,8.972400E-01,& + & 2.655400E+00,9.906300E+00,2.124600E+01,2.905900E+01,4.802300E+01,& + & 7.066500E+01,9.296676E+01,2.625800E-05,4.528000E-05,6.105100E-05,& + & 1.003200E-04,1.778800E-04,3.473900E-04,7.500500E-04,2.516300E-03,& + & 1.433300E-02,4.258800E-02,6.030800E-02,9.033500E-02,1.323600E-01,& + & 2.624546E-01,1.538500E-01,4.266000E-01,7.129500E-01,1.050000E+00,& + & 1.825300E+00,3.231900E+00,7.066200E+00,2.125800E+01,8.005300E+01,& + & 1.724300E+02,2.379600E+02,3.825300E+02,5.447700E+02,7.007833E+02/ + data absa(:,281:300) / & + & 1.349600E-01,3.739100E-01,6.239100E-01,9.190600E-01,1.597700E+00,& + & 2.828700E+00,6.183300E+00,1.860200E+01,7.004700E+01,1.508800E+02,& + & 2.082000E+02,3.347300E+02,4.766300E+02,6.132008E+02,1.160300E-01,& + & 3.211800E-01,5.348700E-01,7.880700E-01,1.370100E+00,2.425400E+00,& + & 5.300600E+00,1.594500E+01,6.004100E+01,1.293200E+02,1.784600E+02,& + & 2.869000E+02,4.085400E+02,5.256030E+02,9.708100E-02,2.685300E-01,& + & 4.458500E-01,6.569900E-01,1.142400E+00,2.021900E+00,4.417700E+00,& + & 1.328800E+01,5.003400E+01,1.077600E+02,1.487100E+02,2.390800E+02,& + & 3.404500E+02,4.380005E+02,7.807900E-02,2.157700E-01,3.569400E-01,& + & 5.259900E-01,9.147600E-01,1.618600E+00,3.535600E+00,1.063200E+01,& + & 4.002900E+01,8.621100E+01,1.189700E+02,1.912800E+02,2.723600E+02,& + & 3.504058E+02,5.898100E-02,1.629700E-01,2.682400E-01,3.949200E-01,& + & 6.870900E-01,1.215000E+00,2.653400E+00,7.975400E+00,3.002300E+01,& + & 6.466000E+01,8.923100E+01,1.434500E+02,2.042600E+02,2.628036E+02,& + & 3.976300E-02,1.098600E-01,1.796100E-01,2.641000E-01,4.593600E-01,& + & 8.113800E-01,1.771500E+00,5.319600E+00,2.001800E+01,4.310600E+01,& + & 5.948800E+01,9.563200E+01,1.361800E+02,1.752078E+02,2.038700E-02,& + & 5.614500E-02,9.087600E-02,1.335800E-01,2.320700E-01,4.076700E-01,& + & 8.900700E-01,2.663100E+00,1.001100E+01,2.155300E+01,2.974500E+01,& + & 4.781600E+01,6.808900E+01,8.760320E+01,3.208900E-05,5.445900E-05,& + & 8.266200E-05,1.389900E-04,2.600700E-04,4.976700E-04,1.098400E-03,& + & 3.616600E-03,2.047400E-02,6.285100E-02,9.020800E-02,1.355700E-01,& + & 1.922400E-01,3.954950E-01,1.736200E-01,4.530100E-01,7.070400E-01,& + & 1.059800E+00,1.866100E+00,3.287000E+00,7.009100E+00,2.127100E+01,& + & 8.074700E+01,1.745700E+02,2.422600E+02,3.794900E+02,5.255300E+02,& + & 6.598178E+02,1.523700E-01,3.972300E-01,6.188200E-01,9.277400E-01,& + & 1.633500E+00,2.877300E+00,6.133700E+00,1.861400E+01,7.065400E+01,& + & 1.527400E+02,2.119700E+02,3.320400E+02,4.598600E+02,5.773513E+02,& + & 1.310700E-01,3.414900E-01,5.306100E-01,7.956500E-01,1.401000E+00,& + & 2.467300E+00,5.258600E+00,1.595700E+01,6.056200E+01,1.309200E+02,& + & 1.817000E+02,2.846000E+02,3.941600E+02,4.948776E+02,1.097500E-01,& + & 2.856800E-01,4.425200E-01,6.634900E-01,1.168500E+00,2.057300E+00,& + & 4.383600E+00,1.329800E+01,5.047000E+01,1.091000E+02,1.514100E+02,& + & 2.371900E+02,3.284800E+02,4.123952E+02,8.829900E-02,2.297500E-01,& + & 3.546300E-01,5.313000E-01,9.360100E-01,1.647100E+00,3.508500E+00,& + & 1.064000E+01,4.037800E+01,8.728300E+01,1.211300E+02,1.897500E+02,& + & 2.627700E+02,3.298992E+02,6.673000E-02,1.735900E-01,2.668100E-01,& + & 3.993600E-01,7.035900E-01,1.236700E+00,2.633900E+00,7.982500E+00,& + & 3.028600E+01,6.545900E+01,9.084300E+01,1.423000E+02,1.970600E+02,& + & 2.474197E+02,4.502300E-02,1.169500E-01,1.790800E-01,2.678200E-01,& + & 4.711800E-01,8.264800E-01,1.759600E+00,5.324400E+00,2.019300E+01,& + & 4.364100E+01,6.056800E+01,9.487200E+01,1.313800E+02,1.649617E+02,& + & 2.316100E-02,5.958300E-02,9.092600E-02,1.362000E-01,2.391100E-01,& + & 4.169900E-01,8.847000E-01,2.668300E+00,1.010100E+01,2.182100E+01,& + & 3.028100E+01,4.743800E+01,6.569300E+01,8.248019E+01,4.006700E-05,& + & 6.481900E-05,1.079600E-04,1.844400E-04,3.657900E-04,6.888300E-04,& + & 1.542700E-03,5.033900E-03,2.809800E-02,8.870400E-02,1.292700E-01,& + & 1.947600E-01,2.700700E-01,5.831826E-01,1.932500E-01,4.746700E-01,& + & 7.065700E-01,1.074300E+00,1.913100E+00,3.353600E+00,6.996700E+00,& + & 2.121300E+01,8.130300E+01,1.763600E+02,2.454400E+02,3.746500E+02,& + & 5.073600E+02,6.223524E+02,1.697100E-01,4.164900E-01,6.184100E-01,& + & 9.405900E-01,1.675100E+00,2.935700E+00,6.122900E+00,1.856400E+01,& + & 7.114200E+01,1.543200E+02,2.147700E+02,3.278300E+02,4.439500E+02,& + & 5.445488E+02,1.460900E-01,3.582000E-01,5.303900E-01,8.068500E-01,& + & 1.436800E+00,2.517800E+00,5.249900E+00,1.591300E+01,6.098000E+01,& + & 1.322700E+02,1.840900E+02,2.809900E+02,3.805000E+02,4.667700E+02/ + data absa(:,301:320) / & + & 1.223800E-01,2.997300E-01,4.427800E-01,6.731100E-01,1.198900E+00,& + & 2.099700E+00,4.376700E+00,1.326200E+01,5.081900E+01,1.102300E+02,& + & 1.534100E+02,2.341600E+02,3.170900E+02,3.889934E+02,9.850900E-02,& + & 2.410900E-01,3.551300E-01,5.394500E-01,9.609500E-01,1.681600E+00,& + & 3.503700E+00,1.061200E+01,4.065800E+01,8.818300E+01,1.227200E+02,& + & 1.873200E+02,2.536700E+02,3.111779E+02,7.448100E-02,1.820800E-01,& + & 2.676900E-01,4.062100E-01,7.229900E-01,1.263300E+00,2.631400E+00,& + & 7.961900E+00,3.049600E+01,6.613800E+01,9.204400E+01,1.405000E+02,& + & 1.902600E+02,2.333923E+02,5.033400E-02,1.225100E-01,1.799500E-01,& + & 2.733100E-01,4.850300E-01,8.455000E-01,1.758900E+00,5.312200E+00,& + & 2.033400E+01,4.409000E+01,6.136100E+01,9.367000E+01,1.268400E+02,& + & 1.555936E+02,2.599500E-02,6.238000E-02,9.130500E-02,1.399500E-01,& + & 2.470600E-01,4.291500E-01,8.846400E-01,2.667200E+00,1.017300E+01,& + & 2.204600E+01,3.068200E+01,4.683100E+01,6.342100E+01,7.779415E+01,& + & 4.663000E-05,7.866000E-05,1.392000E-04,2.465700E-04,4.900900E-04,& + & 9.207500E-04,2.081400E-03,6.776800E-03,3.743900E-02,1.196600E-01,& + & 1.787800E-01,2.669400E-01,3.685300E-01,8.404440E-01,2.130300E-01,& + & 4.919900E-01,7.131000E-01,1.099600E+00,1.961800E+00,3.424700E+00,& + & 7.026200E+00,2.108900E+01,8.168000E+01,1.776400E+02,2.476400E+02,& + & 3.693100E+02,4.896600E+02,5.882991E+02,1.871700E-01,4.319200E-01,& + & 6.243000E-01,9.628900E-01,1.718200E+00,2.998300E+00,6.149500E+00,& + & 1.845500E+01,7.147200E+01,1.554400E+02,2.166800E+02,3.231300E+02,& + & 4.284600E+02,5.147347E+02,1.612600E-01,3.714400E-01,5.360000E-01,& + & 8.260800E-01,1.474500E+00,2.571800E+00,5.273300E+00,1.582000E+01,& + & 6.126500E+01,1.332300E+02,1.857300E+02,2.769600E+02,3.672700E+02,& + & 4.412044E+02,1.351100E-01,3.109000E-01,4.478200E-01,6.895300E-01,& + & 1.231000E+00,2.145100E+00,4.396900E+00,1.318600E+01,5.105700E+01,& + & 1.110200E+02,1.547700E+02,2.308000E+02,3.060500E+02,3.676627E+02,& + & 1.087900E-01,2.500000E-01,3.597600E-01,5.534200E-01,9.873900E-01,& + & 1.718500E+00,3.520800E+00,1.055200E+01,4.084700E+01,8.881600E+01,& + & 1.238100E+02,1.846400E+02,2.448400E+02,2.941364E+02,8.231900E-02,& + & 1.886500E-01,2.715800E-01,4.173800E-01,7.436400E-01,1.292400E+00,& + & 2.645100E+00,7.917800E+00,3.063800E+01,6.661300E+01,9.286600E+01,& + & 1.384900E+02,1.836400E+02,2.205984E+02,5.572000E-02,1.268600E-01,& + & 1.826100E-01,2.818200E-01,4.995100E-01,8.674500E-01,1.767200E+00,& + & 5.287300E+00,2.043100E+01,4.441000E+01,6.190700E+01,9.231700E+01,& + & 1.224200E+02,1.470774E+02,2.890000E-02,6.456300E-02,9.281400E-02,& + & 1.448500E-01,2.554300E-01,4.426600E-01,8.923400E-01,2.659300E+00,& + & 1.022300E+01,2.220600E+01,3.095600E+01,4.616000E+01,6.120800E+01,& + & 7.354090E+01,5.587400E-05,9.418400E-05,1.757200E-04,3.243100E-04,& + & 6.441700E-04,1.199400E-03,2.706700E-03,8.841300E-03,4.871800E-02,& + & 1.560000E-01,2.382400E-01,3.521300E-01,4.851600E-01,1.184363E+00,& + & 2.408500E-01,7.459800E-01,1.434400E+00,2.107100E+00,3.622200E+00,& + & 6.552200E+00,1.469100E+01,4.518000E+01,1.914000E+02,4.353100E+02,& + & 5.742800E+02,9.081000E+02,1.386500E+03,1.849450E+03,2.109300E-01,& + & 6.530000E-01,1.255100E+00,1.843800E+00,3.169700E+00,5.733300E+00,& + & 1.285600E+01,3.953500E+01,1.674700E+02,3.809000E+02,5.024900E+02,& + & 7.945500E+02,1.213200E+03,1.618230E+03,1.810200E-01,5.600900E-01,& + & 1.075900E+00,1.580400E+00,2.717500E+00,4.915400E+00,1.101900E+01,& + & 3.388700E+01,1.435500E+02,3.264700E+02,4.307000E+02,6.810700E+02,& + & 1.039900E+03,1.387173E+03,1.510700E-01,4.671800E-01,8.966700E-01,& + & 1.317300E+00,2.264700E+00,4.095800E+00,9.183200E+00,2.823900E+01,& + & 1.196200E+02,2.720700E+02,3.589300E+02,5.675500E+02,8.665600E+02,& + & 1.155930E+03,1.211200E-01,3.743300E-01,7.173500E-01,1.054000E+00,& + & 1.812200E+00,3.277300E+00,7.347200E+00,2.259100E+01,9.570100E+01,& + & 2.176600E+02,2.871400E+02,4.540300E+02,6.932300E+02,9.247458E+02/ + data absa(:,321:340) / & + & 9.113700E-02,2.814200E-01,5.382100E-01,7.907100E-01,1.359500E+00,& + & 2.458600E+00,5.511200E+00,1.694400E+01,7.177500E+01,1.632500E+02,& + & 2.153600E+02,3.405300E+02,5.199500E+02,6.935749E+02,6.111200E-02,& + & 1.884800E-01,3.589900E-01,5.274900E-01,9.070300E-01,1.639900E+00,& + & 3.675200E+00,1.129800E+01,4.785000E+01,1.088300E+02,1.435700E+02,& + & 2.270100E+02,3.466300E+02,4.623736E+02,3.096400E-02,9.540300E-02,& + & 1.801100E-01,2.641600E-01,4.543600E-01,8.212800E-01,1.839200E+00,& + & 5.651700E+00,2.392700E+01,5.441200E+01,7.178600E+01,1.135200E+02,& + & 1.733200E+02,2.311765E+02,2.670400E-05,4.917600E-05,7.574800E-05,& + & 1.108500E-04,1.770000E-04,2.500000E-04,5.046600E-04,1.371500E-03,& + & 1.013700E-02,3.263400E-02,4.722700E-02,7.156400E-02,1.134200E-01,& + & 2.308007E-01,2.804000E-01,8.143400E-01,1.419100E+00,2.114200E+00,& + & 3.698900E+00,6.653400E+00,1.456100E+01,4.529000E+01,1.935300E+02,& + & 4.409800E+02,5.849900E+02,9.060500E+02,1.341800E+03,1.745568E+03,& + & 2.456300E-01,7.130100E-01,1.241900E+00,1.850100E+00,3.236700E+00,& + & 5.822400E+00,1.274100E+01,3.962700E+01,1.693400E+02,3.858500E+02,& + & 5.119000E+02,7.927500E+02,1.174000E+03,1.527429E+03,2.108200E-01,& + & 6.117300E-01,1.064500E+00,1.586100E+00,2.774700E+00,4.990900E+00,& + & 1.092200E+01,3.396900E+01,1.451500E+02,3.307400E+02,4.387800E+02,& + & 6.795600E+02,1.006300E+03,1.309138E+03,1.759800E-01,5.104400E-01,& + & 8.871300E-01,1.321900E+00,2.312900E+00,4.159800E+00,9.101800E+00,& + & 2.830800E+01,1.209600E+02,2.756200E+02,3.656400E+02,5.662800E+02,& + & 8.385800E+02,1.090980E+03,1.411400E-01,4.091700E-01,7.097900E-01,& + & 1.057800E+00,1.850900E+00,3.328400E+00,7.282400E+00,2.264700E+01,& + & 9.676900E+01,2.205000E+02,2.925200E+02,4.530200E+02,6.708400E+02,& + & 8.727866E+02,1.062700E-01,3.078800E-01,5.326800E-01,7.937900E-01,& + & 1.388800E+00,2.497500E+00,5.463100E+00,1.698700E+01,7.257700E+01,& + & 1.653600E+02,2.193900E+02,3.397800E+02,5.031200E+02,6.546210E+02,& + & 7.131300E-02,2.065300E-01,3.555700E-01,5.297100E-01,9.268900E-01,& + & 1.666700E+00,3.643400E+00,1.132700E+01,4.838500E+01,1.102500E+02,& + & 1.462600E+02,2.265200E+02,3.354400E+02,4.363888E+02,3.615900E-02,& + & 1.047700E-01,1.786700E-01,2.658500E-01,4.648700E-01,8.348600E-01,& + & 1.824700E+00,5.666000E+00,2.419500E+01,5.512300E+01,7.313000E+01,& + & 1.132500E+02,1.677100E+02,2.181960E+02,3.446300E-05,6.146800E-05,& + & 9.992100E-05,1.481000E-04,2.239600E-04,3.593300E-04,7.010800E-04,& + & 2.084500E-03,1.496000E-02,4.978800E-02,7.217100E-02,1.108600E-01,& + & 1.715300E-01,3.485839E-01,3.198600E-01,8.726800E-01,1.408600E+00,& + & 2.131800E+00,3.790000E+00,6.787100E+00,1.451700E+01,4.526100E+01,& + & 1.952800E+02,4.465000E+02,5.929100E+02,9.009300E+02,1.298200E+03,& + & 1.648497E+03,2.802400E-01,7.644000E-01,1.232700E+00,1.865600E+00,& + & 3.316800E+00,5.939600E+00,1.270200E+01,3.960500E+01,1.708600E+02,& + & 3.906900E+02,5.187900E+02,7.883200E+02,1.136000E+03,1.442507E+03,& + & 2.405800E-01,6.560400E-01,1.056600E+00,1.599500E+00,2.843400E+00,& + & 5.091900E+00,1.088900E+01,3.394800E+01,1.464600E+02,3.349000E+02,& + & 4.447000E+02,6.756900E+02,9.736200E+02,1.236319E+03,2.009100E-01,& + & 5.475900E-01,8.806500E-01,1.333300E+00,2.370200E+00,4.244300E+00,& + & 9.075100E+00,2.829000E+01,1.220500E+02,2.790600E+02,3.705800E+02,& + & 5.630600E+02,8.113800E+02,1.030403E+03,1.611900E-01,4.392000E-01,& + & 7.047800E-01,1.067100E+00,1.897200E+00,3.396800E+00,7.260900E+00,& + & 2.263300E+01,9.764200E+01,2.232500E+02,2.964500E+02,4.504600E+02,& + & 6.491200E+02,8.242587E+02,1.214300E-01,3.306500E-01,5.292000E-01,& + & 8.009400E-01,1.424000E+00,2.549200E+00,5.447400E+00,1.697700E+01,& + & 7.323100E+01,1.674400E+02,2.223500E+02,3.378300E+02,4.868300E+02,& + & 6.182067E+02,8.150400E-02,2.220000E-01,3.536400E-01,5.347500E-01,& + & 9.508500E-01,1.701200E+00,3.633800E+00,1.132000E+01,4.882400E+01,& + & 1.116200E+02,1.482200E+02,2.252100E+02,3.245600E+02,4.121351E+02/ + data absa(:,341:360) / & + & 4.137700E-02,1.126900E-01,1.781300E-01,2.691800E-01,4.779700E-01,& + & 8.528300E-01,1.821500E+00,5.663700E+00,2.441600E+01,5.581600E+01,& + & 7.411400E+01,1.126200E+02,1.622900E+02,2.060769E+02,4.288500E-05,& + & 7.590200E-05,1.223600E-04,1.950100E-04,2.741700E-04,4.938700E-04,& + & 9.513400E-04,3.205700E-03,2.088300E-02,7.209400E-02,1.053600E-01,& + & 1.646300E-01,2.464800E-01,5.181139E-01,3.591000E-01,9.202500E-01,& + & 1.408700E+00,2.155500E+00,3.890800E+00,6.931700E+00,1.459200E+01,& + & 4.512600E+01,1.967200E+02,4.510800E+02,5.981600E+02,8.936300E+02,& + & 1.255400E+03,1.557021E+03,3.146800E-01,8.061900E-01,1.232700E+00,& + & 1.886500E+00,3.405400E+00,6.066200E+00,1.276800E+01,3.948600E+01,& + & 1.721300E+02,3.947000E+02,5.234100E+02,7.819700E+02,1.098600E+03,& + & 1.362349E+03,2.702600E-01,6.920800E-01,1.056800E+00,1.617500E+00,& + & 2.919800E+00,5.200900E+00,1.094500E+01,3.384800E+01,1.475400E+02,& + & 3.383100E+02,4.486200E+02,6.702700E+02,9.415500E+02,1.167758E+03,& + & 2.257800E-01,5.779400E-01,8.810600E-01,1.348600E+00,2.434300E+00,& + & 4.335700E+00,9.122300E+00,2.820500E+01,1.229500E+02,2.819400E+02,& + & 3.738600E+02,5.585000E+02,7.847000E+02,9.729988E+02,1.812600E-01,& + & 4.636300E-01,7.055300E-01,1.079500E+00,1.948800E+00,3.470500E+00,& + & 7.299400E+00,2.256700E+01,9.836100E+01,2.255500E+02,2.990800E+02,& + & 4.468100E+02,6.277600E+02,7.784520E+02,1.365800E-01,3.492800E-01,& + & 5.299800E-01,8.105900E-01,1.463400E+00,2.604800E+00,5.477400E+00,& + & 1.692800E+01,7.377300E+01,1.691500E+02,2.243100E+02,3.351300E+02,& + & 4.708100E+02,5.838706E+02,9.173400E-02,2.345500E-01,3.546000E-01,& + & 5.420500E-01,9.780500E-01,1.738900E+00,3.655200E+00,1.128800E+01,& + & 4.918600E+01,1.127700E+02,1.495400E+02,2.234200E+02,3.138800E+02,& + & 3.892360E+02,4.664100E-02,1.187600E-01,1.791900E-01,2.738600E-01,& + & 4.929600E-01,8.733400E-01,1.833400E+00,5.649300E+00,2.459800E+01,& + & 5.638700E+01,7.477300E+01,1.117000E+02,1.569400E+02,1.946293E+02,& + & 5.150800E-05,9.246600E-05,1.541400E-04,2.422400E-04,3.487500E-04,& + & 6.475600E-04,1.292300E-03,4.585300E-03,2.826700E-02,9.890100E-02,& + & 1.483300E-01,2.314500E-01,3.445600E-01,7.527670E-01,3.988100E-01,& + & 9.589200E-01,1.421700E+00,2.206200E+00,3.985600E+00,7.093500E+00,& + & 1.478000E+01,4.486500E+01,1.976300E+02,4.544200E+02,6.014400E+02,& + & 8.817400E+02,1.217300E+03,1.474905E+03,3.495800E-01,8.402500E-01,& + & 1.244400E+00,1.931100E+00,3.488600E+00,6.208100E+00,1.293300E+01,& + & 3.925900E+01,1.729300E+02,3.976100E+02,5.262700E+02,7.714800E+02,& + & 1.065000E+03,1.290470E+03,3.003500E-01,7.213600E-01,1.067200E+00,& + & 1.656000E+00,2.991600E+00,5.323000E+00,1.108600E+01,3.365100E+01,& + & 1.482400E+02,3.408100E+02,4.510900E+02,6.612900E+02,9.128900E+02,& + & 1.106205E+03,2.510700E-01,6.024500E-01,8.902500E-01,1.380700E+00,& + & 2.494700E+00,4.438000E+00,9.240900E+00,2.804600E+01,1.235200E+02,& + & 2.840000E+02,3.759000E+02,5.511000E+02,7.606900E+02,9.217888E+02,& + & 2.016300E-01,4.834400E-01,7.132700E-01,1.105600E+00,1.997800E+00,& + & 3.552400E+00,7.395200E+00,2.243800E+01,9.882000E+01,2.272100E+02,& + & 3.007000E+02,4.408500E+02,6.086000E+02,7.374203E+02,1.519800E-01,& + & 3.642000E-01,5.362700E-01,8.308700E-01,1.501200E+00,2.667100E+00,& + & 5.549800E+00,1.683200E+01,7.412000E+01,1.704000E+02,2.255400E+02,& + & 3.306400E+02,4.564500E+02,5.530764E+02,1.021200E-01,2.443100E-01,& + & 3.596500E-01,5.562600E-01,1.004400E+00,1.781500E+00,3.704800E+00,& + & 1.122600E+01,4.941700E+01,1.136000E+02,1.503600E+02,2.204500E+02,& + & 3.042800E+02,3.686886E+02,5.203400E-02,1.235300E-01,1.820200E-01,& + & 2.821400E-01,5.075800E-01,8.976200E-01,1.857800E+00,5.623300E+00,& + & 2.471600E+01,5.679800E+01,7.518100E+01,1.102100E+02,1.521500E+02,& + & 1.843615E+02,5.987200E-05,1.118600E-04,1.911500E-04,2.855800E-04,& + & 4.593400E-04,8.219500E-04,1.735900E-03,6.224300E-03,3.732400E-02,& + & 1.303800E-01,1.998100E-01,3.142900E-01,4.632000E-01,1.069258E+00/ + data absa(:,361:380) / & + & 8.125100E-01,2.645700E+00,5.365600E+00,7.997200E+00,1.379400E+01,& + & 2.544400E+01,5.688500E+01,1.798200E+02,8.569600E+02,2.114700E+03,& + & 2.751400E+03,4.057500E+03,6.428700E+03,8.740273E+03,7.111300E-01,& + & 2.315200E+00,4.694900E+00,6.997900E+00,1.207000E+01,2.226500E+01,& + & 4.977600E+01,1.573400E+02,7.498600E+02,1.850400E+03,2.407300E+03,& + & 3.550200E+03,5.625400E+03,7.650325E+03,6.097800E-01,1.984600E+00,& + & 4.024400E+00,5.997900E+00,1.034600E+01,1.908400E+01,4.266500E+01,& + & 1.348700E+02,6.427200E+02,1.586000E+03,2.063500E+03,3.043100E+03,& + & 4.822000E+03,6.557438E+03,5.083400E-01,1.654100E+00,3.353600E+00,& + & 4.998600E+00,8.622400E+00,1.590400E+01,3.555400E+01,1.123900E+02,& + & 5.356100E+02,1.321700E+03,1.719600E+03,2.535800E+03,4.018400E+03,& + & 5.464605E+03,4.069200E-01,1.323600E+00,2.682900E+00,3.998700E+00,& + & 6.898300E+00,1.272300E+01,2.844400E+01,8.991200E+01,4.284900E+02,& + & 1.057400E+03,1.375700E+03,2.028600E+03,3.214600E+03,4.372174E+03,& + & 3.054900E-01,9.931700E-01,2.012400E+00,2.999400E+00,5.173800E+00,& + & 9.542800E+00,2.133200E+01,6.743400E+01,3.213700E+02,7.930400E+02,& + & 1.031800E+03,1.521500E+03,2.410800E+03,3.278724E+03,2.040100E-01,& + & 6.627600E-01,1.341800E+00,1.999900E+00,3.449700E+00,6.362200E+00,& + & 1.422400E+01,4.495700E+01,2.142500E+02,5.286700E+02,6.878800E+02,& + & 1.014300E+03,1.607200E+03,2.185881E+03,1.024700E-01,3.324000E-01,& + & 6.712100E-01,1.000200E+00,1.725600E+00,3.182000E+00,7.112600E+00,& + & 2.248100E+01,1.071200E+02,2.643500E+02,3.439300E+02,5.072000E+02,& + & 8.036600E+02,1.092984E+03,4.206000E-05,8.989200E-05,1.293800E-04,& + & 1.866800E-04,2.331700E-04,4.017800E-04,6.260900E-04,1.310600E-03,& + & 4.971000E-03,1.942400E-02,3.310700E-02,5.560300E-02,9.343500E-02,& + & 2.033926E-01,9.602400E-01,2.918600E+00,5.324900E+00,8.012800E+00,& + & 1.409300E+01,2.590700E+01,5.658000E+01,1.799600E+02,8.666100E+02,& + & 2.144200E+03,2.797300E+03,4.057500E+03,6.243300E+03,8.269555E+03,& + & 8.403900E-01,2.554100E+00,4.659300E+00,7.011400E+00,1.233200E+01,& + & 2.266800E+01,4.950900E+01,1.574600E+02,7.582700E+02,1.876200E+03,& + & 2.447600E+03,3.550300E+03,5.462700E+03,7.235788E+03,7.206000E-01,& + & 2.189600E+00,3.993800E+00,6.009700E+00,1.057100E+01,1.943200E+01,& + & 4.243600E+01,1.349700E+02,6.499600E+02,1.608200E+03,2.097900E+03,& + & 3.043100E+03,4.682400E+03,6.202104E+03,6.007900E-01,1.825200E+00,& + & 3.328400E+00,5.008500E+00,8.809000E+00,1.619400E+01,3.536300E+01,& + & 1.124700E+02,5.416400E+02,1.340100E+03,1.748200E+03,2.535900E+03,& + & 3.901800E+03,5.168614E+03,4.809500E-01,1.460700E+00,2.662800E+00,& + & 4.007000E+00,7.047800E+00,1.295600E+01,2.829100E+01,8.997600E+01,& + & 4.333100E+02,1.072100E+03,1.398600E+03,2.028600E+03,3.121500E+03,& + & 4.134890E+03,3.610600E-01,1.096300E+00,1.997200E+00,3.005600E+00,& + & 5.286400E+00,9.717700E+00,2.121900E+01,6.748800E+01,3.249800E+02,& + & 8.040800E+02,1.049000E+03,1.521600E+03,2.341100E+03,3.101096E+03,& + & 2.412000E-01,7.319000E-01,1.331700E+00,2.004200E+00,3.525000E+00,& + & 6.479400E+00,1.414700E+01,4.499200E+01,2.166600E+02,5.360800E+02,& + & 6.993200E+02,1.014300E+03,1.560800E+03,2.067424E+03,1.212300E-01,& + & 3.675100E-01,6.662300E-01,1.002700E+00,1.763600E+00,3.241600E+00,& + & 7.075100E+00,2.249800E+01,1.083300E+02,2.680300E+02,3.496600E+02,& + & 5.071500E+02,7.803200E+02,1.033705E+03,5.736300E-05,1.091400E-04,& + & 1.624800E-04,2.515000E-04,2.955000E-04,4.982000E-04,8.017700E-04,& + & 1.640400E-03,7.732400E-03,3.686500E-02,5.699800E-02,8.838100E-02,& + & 1.468100E-01,3.092440E-01,1.108800E+00,3.158700E+00,5.284200E+00,& + & 8.080500E+00,1.446400E+01,2.649100E+01,5.673200E+01,1.796500E+02,& + & 8.747200E+02,2.168500E+03,2.826500E+03,4.049000E+03,6.061200E+03,& + & 7.826527E+03,9.705600E-01,2.764300E+00,4.623800E+00,7.070200E+00,& + & 1.265800E+01,2.318100E+01,4.963700E+01,1.571900E+02,7.653700E+02,& + & 1.897600E+03,2.473100E+03,3.542500E+03,5.303400E+03,6.848214E+03/ + data absa(:,381:400) / & + & 8.322200E-01,2.370000E+00,3.963300E+00,6.060700E+00,1.084800E+01,& + & 1.987000E+01,4.254800E+01,1.347300E+02,6.560200E+02,1.626400E+03,& + & 2.119700E+03,3.036500E+03,4.545500E+03,5.869674E+03,6.939300E-01,& + & 1.975900E+00,3.302900E+00,5.050900E+00,9.041500E+00,1.655900E+01,& + & 3.545800E+01,1.122800E+02,5.466900E+02,1.355300E+03,1.766400E+03,& + & 2.530300E+03,3.788300E+03,4.891861E+03,5.555500E-01,1.581600E+00,& + & 2.642600E+00,4.041200E+00,7.233700E+00,1.324900E+01,2.836600E+01,& + & 8.982100E+01,4.373500E+02,1.084200E+03,1.413100E+03,2.024300E+03,& + & 3.030500E+03,3.913115E+03,4.172000E-01,1.187300E+00,1.982200E+00,& + & 3.031900E+00,5.426400E+00,9.939200E+00,2.127600E+01,6.737000E+01,& + & 3.280100E+02,8.131700E+02,1.059900E+03,1.518300E+03,2.272800E+03,& + & 2.934912E+03,2.787500E-01,7.930100E-01,1.321900E+00,2.021900E+00,& + & 3.618400E+00,6.627400E+00,1.418400E+01,4.491400E+01,2.186800E+02,& + & 5.421300E+02,7.066200E+02,1.012200E+03,1.515300E+03,1.956538E+03,& + & 1.402100E-01,3.986900E-01,6.617400E-01,1.011900E+00,1.810700E+00,& + & 3.316300E+00,7.094900E+00,2.246100E+01,1.093500E+02,2.710700E+02,& + & 3.533000E+02,5.061100E+02,7.575600E+02,9.782607E+02,7.411300E-05,& + & 1.262400E-04,2.150500E-04,3.039600E-04,3.863900E-04,5.867500E-04,& + & 1.022000E-03,2.026800E-03,1.230200E-02,5.568400E-02,8.590100E-02,& + & 1.346200E-01,2.181900E-01,4.632045E-01,1.256800E+00,3.355600E+00,& + & 5.290900E+00,8.174300E+00,1.485500E+01,2.710000E+01,5.746800E+01,& + & 1.788800E+02,8.812800E+02,2.188600E+03,2.838800E+03,4.016300E+03,& + & 5.897700E+03,7.420673E+03,1.100100E+00,2.937000E+00,4.629700E+00,& + & 7.153300E+00,1.299900E+01,2.371400E+01,5.028600E+01,1.565300E+02,& + & 7.711300E+02,1.915100E+03,2.484100E+03,3.514100E+03,5.160400E+03,& + & 6.493029E+03,9.434200E-01,2.518300E+00,3.968500E+00,6.131500E+00,& + & 1.114300E+01,2.032600E+01,4.310100E+01,1.341600E+02,6.609500E+02,& + & 1.641500E+03,2.129100E+03,3.012200E+03,4.423100E+03,5.565762E+03,& + & 7.866500E-01,2.099600E+00,3.307400E+00,5.110800E+00,9.286200E+00,& + & 1.694100E+01,3.592000E+01,1.118100E+02,5.508100E+02,1.368000E+03,& + & 1.774300E+03,2.510000E+03,3.686100E+03,4.637936E+03,6.298500E-01,& + & 1.680800E+00,2.646100E+00,4.089200E+00,7.430600E+00,1.355500E+01,& + & 2.873600E+01,8.944300E+01,4.406400E+02,1.094300E+03,1.419400E+03,& + & 2.008200E+03,2.948700E+03,3.710387E+03,4.731100E-01,1.262200E+00,& + & 1.985000E+00,3.067800E+00,5.573700E+00,1.016800E+01,2.155300E+01,& + & 6.708800E+01,3.304800E+02,8.207700E+02,1.064600E+03,1.506100E+03,& + & 2.211700E+03,2.782750E+03,3.163000E-01,8.433900E-01,1.324300E+00,& + & 2.046200E+00,3.717300E+00,6.781300E+00,1.437100E+01,4.472700E+01,& + & 2.203300E+02,5.472000E+02,7.097400E+02,1.004100E+03,1.474400E+03,& + & 1.855242E+03,1.591500E-01,4.243600E-01,6.634400E-01,1.024700E+00,& + & 1.861400E+00,3.394300E+00,7.189200E+00,2.236700E+01,1.101700E+02,& + & 2.736000E+02,3.548400E+02,5.020200E+02,7.372000E+02,9.276105E+02,& + & 9.286200E-05,1.559600E-04,2.532300E-04,3.532100E-04,5.078600E-04,& + & 7.084100E-04,1.238700E-03,2.682400E-03,1.820500E-02,7.813500E-02,& + & 1.223300E-01,1.941800E-01,3.139400E-01,6.785539E-01,1.406200E+00,& + & 3.517700E+00,5.332800E+00,8.340900E+00,1.521000E+01,2.776500E+01,& + & 5.863500E+01,1.780100E+02,8.859400E+02,2.203500E+03,2.837300E+03,& + & 3.973800E+03,5.729300E+03,7.063556E+03,1.230900E+00,3.078800E+00,& + & 4.666500E+00,7.298800E+00,1.331100E+01,2.429700E+01,5.130600E+01,& + & 1.557600E+02,7.751800E+02,1.928100E+03,2.482800E+03,3.476800E+03,& + & 5.013100E+03,6.180678E+03,1.055700E+00,2.640100E+00,4.000300E+00,& + & 6.256700E+00,1.141000E+01,2.082700E+01,4.397700E+01,1.335100E+02,& + & 6.644800E+02,1.652600E+03,2.128000E+03,2.980100E+03,4.296900E+03,& + & 5.297765E+03,8.803900E-01,2.201300E+00,3.334200E+00,5.214600E+00,& + & 9.509700E+00,1.735800E+01,3.664800E+01,1.112600E+02,5.537200E+02,& + & 1.377200E+03,1.773400E+03,2.483500E+03,3.580700E+03,4.414755E+03/ + data absa(:,401:420) / & + & 7.051300E-01,1.762500E+00,2.668200E+00,4.172800E+00,7.609100E+00,& + & 1.388900E+01,2.932100E+01,8.901400E+01,4.429800E+02,1.101800E+03,& + & 1.418700E+03,1.986800E+03,2.864600E+03,3.532011E+03,5.297700E-01,& + & 1.323400E+00,2.002100E+00,3.130600E+00,5.708700E+00,1.042000E+01,& + & 2.199200E+01,6.676200E+01,3.322300E+02,8.263400E+02,1.064000E+03,& + & 1.490000E+03,2.148400E+03,2.648869E+03,3.543200E-01,8.844500E-01,& + & 1.336100E+00,2.088500E+00,3.808700E+00,6.949900E+00,1.466500E+01,& + & 4.451200E+01,2.215000E+02,5.509300E+02,7.093300E+02,9.933800E+02,& + & 1.432300E+03,1.765913E+03,1.783900E-01,4.452800E-01,6.699800E-01,& + & 1.047100E+00,1.908700E+00,3.479400E+00,7.337800E+00,2.226100E+01,& + & 1.107600E+02,2.754600E+02,3.546700E+02,4.966800E+02,7.161700E+02,& + & 8.829978E+02,1.095400E-04,1.936900E-04,2.872400E-04,4.419800E-04,& + & 5.898200E-04,8.542400E-04,1.550100E-03,3.296100E-03,2.585300E-02,& + & 1.055800E-01,1.664200E-01,2.700100E-01,4.308300E-01,9.737057E-01,& + & 3.086800E+00,1.050100E+01,2.233800E+01,3.377100E+01,5.849600E+01,& + & 1.102300E+02,2.448700E+02,7.918600E+02,4.211000E+03,1.134000E+04,& + & 1.479600E+04,2.078200E+04,3.320000E+04,4.618280E+04,2.701000E+00,& + & 9.188400E+00,1.954500E+01,2.954800E+01,5.118000E+01,9.643200E+01,& + & 2.142400E+02,6.928500E+02,3.684700E+03,9.922500E+03,1.294700E+04,& + & 1.818400E+04,2.905000E+04,4.041044E+04,2.315400E+00,7.876300E+00,& + & 1.675300E+01,2.532800E+01,4.386700E+01,8.266400E+01,1.836400E+02,& + & 5.938700E+02,3.158200E+03,8.505300E+03,1.109700E+04,1.558600E+04,& + & 2.489900E+04,3.463382E+04,1.929600E+00,6.563700E+00,1.396100E+01,& + & 2.110500E+01,3.655600E+01,6.889800E+01,1.530400E+02,4.948500E+02,& + & 2.631900E+03,7.088200E+03,9.247600E+03,1.298900E+04,2.074900E+04,& + & 2.886365E+04,1.544000E+00,5.250900E+00,1.117000E+01,1.688600E+01,& + & 2.924700E+01,5.511400E+01,1.224300E+02,3.958700E+02,2.105500E+03,& + & 5.670000E+03,7.398200E+03,1.039100E+04,1.660000E+04,2.309228E+04,& + & 1.158300E+00,3.938700E+00,8.376700E+00,1.266500E+01,2.193500E+01,& + & 4.133900E+01,9.182500E+01,2.969200E+02,1.579200E+03,4.252400E+03,& + & 5.548900E+03,7.793100E+03,1.245000E+04,1.731871E+04,7.725700E-01,& + & 2.626000E+00,5.584900E+00,8.442700E+00,1.462300E+01,2.755500E+01,& + & 6.121400E+01,1.979500E+02,1.052700E+03,2.835000E+03,3.699200E+03,& + & 5.195600E+03,8.299800E+03,1.154518E+04,3.868200E-01,1.313700E+00,& + & 2.792500E+00,4.221600E+00,7.312300E+00,1.377800E+01,3.060600E+01,& + & 9.898000E+01,5.263700E+02,1.417500E+03,1.849600E+03,2.597700E+03,& + & 4.150100E+03,5.772500E+03,7.965000E-05,1.795100E-04,2.712300E-04,& + & 4.320000E-04,5.640300E-04,8.153700E-04,1.735400E-03,2.643400E-03,& + & 5.023500E-03,1.159100E-02,1.733500E-02,1.507600E-02,1.303500E-02,& + & 9.015104E-02,3.699200E+00,1.169400E+01,2.224700E+01,3.381000E+01,& + & 5.978600E+01,1.124700E+02,2.449000E+02,7.915600E+02,4.257800E+03,& + & 1.148300E+04,1.497500E+04,2.084700E+04,3.237900E+04,4.381314E+04,& + & 3.237100E+00,1.023300E+01,1.946700E+01,2.958700E+01,5.231700E+01,& + & 9.842700E+01,2.143100E+02,6.926000E+02,3.725600E+03,1.004800E+04,& + & 1.310300E+04,1.824200E+04,2.833100E+04,3.833909E+04,2.774900E+00,& + & 8.771400E+00,1.668600E+01,2.535800E+01,4.484000E+01,8.434600E+01,& + & 1.836900E+02,5.937000E+02,3.193400E+03,8.612700E+03,1.123100E+04,& + & 1.563600E+04,2.428600E+04,3.285937E+04,2.312600E+00,7.309500E+00,& + & 1.390500E+01,2.113100E+01,3.736900E+01,7.030000E+01,1.530900E+02,& + & 4.947600E+02,2.661300E+03,7.177100E+03,9.358500E+03,1.303000E+04,& + & 2.023600E+04,2.738122E+04,1.850400E+00,5.847700E+00,1.112400E+01,& + & 1.690500E+01,2.989500E+01,5.623600E+01,1.224700E+02,3.958000E+02,& + & 2.128900E+03,5.741900E+03,7.487100E+03,1.042400E+04,1.618900E+04,& + & 2.190723E+04,1.388300E+00,4.386300E+00,8.343100E+00,1.268000E+01,& + & 2.242300E+01,4.218000E+01,9.185100E+01,2.968500E+02,1.596700E+03,& + & 4.306600E+03,5.615500E+03,7.818000E+03,1.214200E+04,1.642933E+04/ + data absa(:,421:440) / & + & 9.259500E-01,2.924900E+00,5.562300E+00,8.453400E+00,1.494700E+01,& + & 2.811800E+01,6.123000E+01,1.978900E+02,1.064500E+03,2.870900E+03,& + & 3.743500E+03,5.212000E+03,8.094600E+03,1.095379E+04,4.636100E-01,& + & 1.463600E+00,2.781700E+00,4.227400E+00,7.474900E+00,1.406100E+01,& + & 3.061900E+01,9.895600E+01,5.322400E+02,1.435400E+03,1.871700E+03,& + & 2.606100E+03,4.047400E+03,5.476443E+03,1.131500E-04,2.188000E-04,& + & 3.307600E-04,5.439300E-04,6.968500E-04,9.931000E-04,1.774800E-03,& + & 3.668900E-03,7.395200E-03,1.258800E-02,3.122600E-02,3.928300E-02,& + & 6.401400E-02,1.842410E-01,4.323900E+00,1.277100E+01,2.207900E+01,& + & 3.414400E+01,6.136600E+01,1.151400E+02,2.475500E+02,7.889700E+02,& + & 4.297600E+03,1.161000E+04,1.507400E+04,2.077600E+04,3.156600E+04,& + & 4.171536E+04,3.783800E+00,1.117500E+01,1.931900E+01,2.987600E+01,& + & 5.369200E+01,1.007600E+02,2.166100E+02,6.903700E+02,3.760400E+03,& + & 1.015900E+04,1.318900E+04,1.817900E+04,2.762100E+04,3.650178E+04,& + & 3.243600E+00,9.578700E+00,1.656000E+01,2.560900E+01,4.602200E+01,& + & 8.635800E+01,1.856800E+02,5.917300E+02,3.223200E+03,8.707100E+03,& + & 1.130500E+04,1.558200E+04,2.367400E+04,3.128713E+04,2.703400E+00,& + & 7.983200E+00,1.380000E+01,2.134000E+01,3.835300E+01,7.197100E+01,& + & 1.547200E+02,4.930900E+02,2.686000E+03,7.255900E+03,9.421000E+03,& + & 1.298500E+04,1.973000E+04,2.607184E+04,2.163000E+00,6.386700E+00,& + & 1.104000E+01,1.707300E+01,3.068200E+01,5.757600E+01,1.237800E+02,& + & 3.945000E+02,2.148800E+03,5.804800E+03,7.537000E+03,1.038700E+04,& + & 1.578400E+04,2.085876E+04,1.622800E+00,4.791000E+00,8.280100E+00,& + & 1.280500E+01,2.301200E+01,4.318300E+01,9.283400E+01,2.958900E+02,& + & 1.611600E+03,4.353200E+03,5.652800E+03,7.790500E+03,1.183700E+04,& + & 1.564433E+04,1.082400E+00,3.195200E+00,5.520500E+00,8.537500E+00,& + & 1.534400E+01,2.878900E+01,6.188900E+01,1.972500E+02,1.074400E+03,& + & 2.902300E+03,3.768500E+03,5.193700E+03,7.891900E+03,1.042938E+04,& + & 5.420400E-01,1.599300E+00,2.760700E+00,4.269700E+00,7.672900E+00,& + & 1.439600E+01,3.094500E+01,9.863500E+01,5.372000E+02,1.451100E+03,& + & 1.884200E+03,2.596800E+03,3.946100E+03,5.214564E+03,1.441900E-04,& + & 2.550400E-04,4.223500E-04,6.472600E-04,8.666100E-04,1.183100E-03,& + & 1.960700E-03,4.121400E-03,1.025500E-02,2.553800E-02,4.322800E-02,& + & 5.367800E-02,1.089700E-01,4.040818E-01,4.948300E+00,1.366100E+01,& + & 2.213300E+01,3.457700E+01,6.300200E+01,1.180200E+02,2.529300E+02,& + & 7.851800E+02,4.327900E+03,1.170200E+04,1.510900E+04,2.063500E+04,& + & 3.072800E+04,3.986372E+04,4.330200E+00,1.195400E+01,1.936600E+01,& + & 3.025500E+01,5.512800E+01,1.032700E+02,2.213200E+02,6.870300E+02,& + & 3.786900E+03,1.023900E+04,1.322000E+04,1.805500E+04,2.688800E+04,& + & 3.488042E+04,3.712100E+00,1.024700E+01,1.660000E+01,2.593400E+01,& + & 4.725400E+01,8.851000E+01,1.897000E+02,5.888900E+02,3.246000E+03,& + & 8.776600E+03,1.133100E+04,1.547600E+04,2.304800E+04,2.989884E+04,& + & 3.093700E+00,8.540300E+00,1.383300E+01,2.161300E+01,3.937700E+01,& + & 7.376500E+01,1.580700E+02,4.907300E+02,2.704900E+03,7.313500E+03,& + & 9.442400E+03,1.289700E+04,1.920500E+04,2.491432E+04,2.475400E+00,& + & 6.833100E+00,1.106700E+01,1.729100E+01,3.150500E+01,5.901600E+01,& + & 1.264700E+02,3.925800E+02,2.164000E+03,5.851100E+03,7.554200E+03,& + & 1.031700E+04,1.536400E+04,1.993178E+04,1.857200E+00,5.126000E+00,& + & 8.300500E+00,1.296900E+01,2.363000E+01,4.426300E+01,9.485200E+01,& + & 2.944400E+02,1.623000E+03,4.388400E+03,5.665900E+03,7.737900E+03,& + & 1.152300E+04,1.494887E+04,1.238900E+00,3.419100E+00,5.534300E+00,& + & 8.647100E+00,1.575300E+01,2.951100E+01,6.323800E+01,1.963100E+02,& + & 1.082000E+03,2.925500E+03,3.777300E+03,5.158400E+03,7.682000E+03,& + & 9.965979E+03,6.206200E-01,1.712100E+00,2.768000E+00,4.325100E+00,& + & 7.878000E+00,1.475900E+01,3.162000E+01,9.814900E+01,5.409900E+02,& + & 1.462800E+03,1.888600E+03,2.579300E+03,3.840900E+03,4.982958E+03/ + data absa(:,441:460) / & + & 1.775200E-04,3.155600E-04,4.862800E-04,7.996700E-04,1.040300E-03,& + & 1.386800E-03,2.352300E-03,4.653300E-03,1.215400E-02,4.527500E-02,& + & 5.668500E-02,8.486900E-02,2.534200E-01,6.341348E-01,5.574500E+00,& + & 1.440300E+01,2.233700E+01,3.527900E+01,6.449300E+01,1.213000E+02,& + & 2.594000E+02,7.827100E+02,4.349600E+03,1.173700E+04,1.508200E+04,& + & 2.046800E+04,2.982400E+04,3.826958E+04,4.878000E+00,1.260300E+01,& + & 1.954500E+01,3.086900E+01,5.643600E+01,1.061400E+02,2.269900E+02,& + & 6.849000E+02,3.806000E+03,1.027000E+04,1.319600E+04,1.791000E+04,& + & 2.609800E+04,3.348651E+04,4.181600E+00,1.080400E+01,1.675400E+01,& + & 2.645900E+01,4.837400E+01,9.097800E+01,1.945600E+02,5.870700E+02,& + & 3.262200E+03,8.803100E+03,1.131100E+04,1.535200E+04,2.236900E+04,& + & 2.870302E+04,3.485500E+00,9.004100E+00,1.396200E+01,2.205000E+01,& + & 4.031000E+01,7.581500E+01,1.621300E+02,4.892200E+02,2.718600E+03,& + & 7.335800E+03,9.425700E+03,1.279300E+04,1.864100E+04,2.391846E+04,& + & 2.789000E+00,7.204600E+00,1.117100E+01,1.764200E+01,3.225300E+01,& + & 6.065700E+01,1.297100E+02,3.913700E+02,2.174800E+03,5.868800E+03,& + & 7.540500E+03,1.023500E+04,1.491300E+04,1.913412E+04,2.092600E+00,& + & 5.404700E+00,8.378800E+00,1.323200E+01,2.418900E+01,4.549300E+01,& + & 9.728200E+01,2.935400E+02,1.631100E+03,4.401400E+03,5.655500E+03,& + & 7.676100E+03,1.118500E+04,1.435107E+04,1.396200E+00,3.605000E+00,& + & 5.587300E+00,8.823300E+00,1.612700E+01,3.033300E+01,6.485600E+01,& + & 1.956800E+02,1.087400E+03,2.934400E+03,3.770400E+03,5.117400E+03,& + & 7.456300E+03,9.567374E+03,6.996300E-01,1.805500E+00,2.795600E+00,& + & 4.413900E+00,8.066800E+00,1.517200E+01,3.243100E+01,9.785100E+01,& + & 5.437200E+02,1.467000E+03,1.885200E+03,2.558500E+03,3.728200E+03,& + & 4.783622E+03,2.144900E-04,3.509500E-04,6.063600E-04,8.861300E-04,& + & 1.236100E-03,1.707000E-03,2.735400E-03,5.311400E-03,1.471900E-02,& + & 5.819200E-02,8.631100E-02,1.784000E-01,3.986500E-01,9.152563E-01,& + & 4.473100E+00,1.530500E+01,3.237200E+01,4.937900E+01,8.718200E+01,& + & 1.669000E+02,3.689900E+02,1.202300E+03,7.117300E+03,2.090300E+04,& + & 2.788900E+04,3.808600E+04,5.899700E+04,8.384557E+04,3.913800E+00,& + & 1.339100E+01,2.832400E+01,4.321000E+01,7.628700E+01,1.460300E+02,& + & 3.228800E+02,1.052100E+03,6.227700E+03,1.829100E+04,2.440200E+04,& + & 3.332700E+04,5.162600E+04,7.336768E+04,3.354900E+00,1.147900E+01,& + & 2.427900E+01,3.703500E+01,6.539400E+01,1.251600E+02,2.767700E+02,& + & 9.017300E+02,5.338000E+03,1.567800E+04,2.091600E+04,2.856300E+04,& + & 4.424600E+04,6.288212E+04,2.796000E+00,9.565400E+00,2.023200E+01,& + & 3.086500E+01,5.449300E+01,1.043100E+02,2.306300E+02,7.514400E+02,& + & 4.448200E+03,1.306500E+04,1.743000E+04,2.380400E+04,3.687600E+04,& + & 5.240418E+04,2.237100E+00,7.652700E+00,1.618600E+01,2.469200E+01,& + & 4.359400E+01,8.344200E+01,1.845200E+02,6.011600E+02,3.558600E+03,& + & 1.045100E+04,1.394400E+04,1.904200E+04,2.949800E+04,4.192392E+04,& + & 1.678100E+00,5.739900E+00,1.214000E+01,1.851900E+01,3.269600E+01,& + & 6.258300E+01,1.383700E+02,4.509100E+02,2.669000E+03,7.838900E+03,& + & 1.045800E+04,1.428200E+04,2.212400E+04,3.144199E+04,1.119100E+00,& + & 3.826900E+00,8.092900E+00,1.234600E+01,2.179800E+01,4.172200E+01,& + & 9.225500E+01,3.005800E+02,1.779300E+03,5.226100E+03,6.972000E+03,& + & 9.521700E+03,1.475000E+04,2.096337E+04,5.601300E-01,1.913900E+00,& + & 4.046900E+00,6.173400E+00,1.090000E+01,2.086200E+01,4.612500E+01,& + & 1.502900E+02,8.896700E+02,2.612900E+03,3.486000E+03,4.760700E+03,& + & 7.374900E+03,1.048253E+04,1.173900E-04,2.526300E-04,3.865900E-04,& + & 5.953100E-04,7.436200E-04,1.572700E-03,2.126500E-03,2.858500E-03,& + & 4.795000E-03,7.188600E-03,1.143200E-02,3.553500E-02,3.485300E-05,& + & 2.116760E-05,5.367300E+00,1.705300E+01,3.222500E+01,4.966400E+01,& + & 8.933600E+01,1.708600E+02,3.733500E+02,1.198700E+03,7.186600E+03,& + & 2.109500E+04,2.811600E+04,3.816700E+04,5.760100E+04,8.024322E+04/ + data absa(:,461:480) / & + & 4.696700E+00,1.492100E+01,2.819700E+01,4.345500E+01,7.817200E+01,& + & 1.494900E+02,3.267000E+02,1.048900E+03,6.288100E+03,1.845900E+04,& + & 2.460200E+04,3.339500E+04,5.040300E+04,7.021096E+04,4.026000E+00,& + & 1.279000E+01,2.416900E+01,3.724700E+01,6.700200E+01,1.281400E+02,& + & 2.800200E+02,8.990600E+02,5.390000E+03,1.582100E+04,2.108700E+04,& + & 2.862400E+04,4.320300E+04,6.018559E+04,3.355200E+00,1.065800E+01,& + & 2.014100E+01,3.104000E+01,5.583600E+01,1.067800E+02,2.333400E+02,& + & 7.491900E+02,4.491700E+03,1.318400E+04,1.757300E+04,2.385300E+04,& + & 3.600200E+04,5.015082E+04,2.684700E+00,8.527200E+00,1.611300E+01,& + & 2.483300E+01,4.466800E+01,8.542400E+01,1.866900E+02,5.993800E+02,& + & 3.593300E+03,1.054800E+04,1.405800E+04,1.908300E+04,2.880200E+04,& + & 4.012018E+04,2.013800E+00,6.395400E+00,1.208500E+01,1.862500E+01,& + & 3.350200E+01,6.406700E+01,1.400200E+02,4.495100E+02,2.695000E+03,& + & 7.910900E+03,1.054300E+04,1.431200E+04,2.160100E+04,3.009028E+04,& + & 1.343100E+00,4.264600E+00,8.056800E+00,1.241700E+01,2.233500E+01,& + & 4.271800E+01,9.334100E+01,2.996900E+02,1.796700E+03,5.273600E+03,& + & 7.029200E+03,9.541400E+03,1.440000E+04,2.006036E+04,6.722400E-01,& + & 2.133400E+00,4.028400E+00,6.209200E+00,1.116800E+01,2.136000E+01,& + & 4.667400E+01,1.498400E+02,8.983600E+02,2.636800E+03,3.514400E+03,& + & 4.770700E+03,7.200400E+03,1.003025E+04,1.427200E-04,3.267100E-04,& + & 4.683700E-04,7.391100E-04,9.070200E-04,1.623400E-03,3.208000E-03,& + & 4.238100E-03,1.038100E-02,6.046000E-03,1.107500E-02,2.033600E-02,& + & 3.914900E-02,7.496377E-02,6.280500E+00,1.859700E+01,3.208900E+01,& + & 5.035100E+01,9.158100E+01,1.751900E+02,3.823300E+02,1.193800E+03,& + & 7.242000E+03,2.121000E+04,2.822400E+04,3.809500E+04,5.618400E+04,& + & 7.706309E+04,5.495400E+00,1.627300E+01,2.807800E+01,4.405600E+01,& + & 8.013100E+01,1.532900E+02,3.345300E+02,1.044600E+03,6.336300E+03,& + & 1.855900E+04,2.469500E+04,3.333300E+04,4.916200E+04,6.743261E+04,& + & 4.710900E+00,1.394900E+01,2.406800E+01,3.776200E+01,6.868800E+01,& + & 1.313900E+02,2.867400E+02,8.953900E+02,5.431300E+03,1.590800E+04,& + & 2.116600E+04,2.857100E+04,4.213600E+04,5.780101E+04,3.926000E+00,& + & 1.162500E+01,2.005700E+01,3.147000E+01,5.723700E+01,1.094900E+02,& + & 2.389600E+02,7.461100E+02,4.526200E+03,1.325600E+04,1.764000E+04,& + & 2.380900E+04,3.511700E+04,4.816525E+04,3.141200E+00,9.300700E+00,& + & 1.604600E+01,2.517500E+01,4.579200E+01,8.758900E+01,1.911600E+02,& + & 5.969400E+02,3.620900E+03,1.060500E+04,1.411200E+04,1.904800E+04,& + & 2.809200E+04,3.853436E+04,2.356300E+00,6.975900E+00,1.203500E+01,& + & 1.888200E+01,3.434500E+01,6.569800E+01,1.433700E+02,4.476800E+02,& + & 2.715600E+03,7.953600E+03,1.058300E+04,1.428500E+04,2.106800E+04,& + & 2.890274E+04,1.571600E+00,4.652000E+00,8.023200E+00,1.258900E+01,& + & 2.289600E+01,4.379900E+01,9.557700E+01,2.984700E+02,1.810400E+03,& + & 5.302700E+03,7.056000E+03,9.523500E+03,1.404600E+04,1.926702E+04,& + & 7.866300E-01,2.327700E+00,4.012100E+00,6.295400E+00,1.144900E+01,& + & 2.190300E+01,4.779400E+01,1.492300E+02,9.052000E+02,2.651100E+03,& + & 3.527600E+03,4.761700E+03,7.022600E+03,9.632714E+03,1.873100E-04,& + & 3.961800E-04,5.667600E-04,9.053500E-04,1.080900E-03,1.788400E-03,& + & 3.491000E-03,6.177600E-03,1.119200E-02,2.626200E-02,4.654700E-02,& + & 7.305800E-02,4.174500E-02,2.080545E-01,7.194100E+00,1.989400E+01,& + & 3.228100E+01,5.131000E+01,9.383900E+01,1.801600E+02,3.929900E+02,& + & 1.191900E+03,7.281800E+03,2.126000E+04,2.821700E+04,3.784000E+04,& + & 5.463900E+04,7.444578E+04,6.295100E+00,1.740900E+01,2.824600E+01,& + & 4.489900E+01,8.210700E+01,1.576200E+02,3.438300E+02,1.042900E+03,& + & 6.371500E+03,1.860300E+04,2.469000E+04,3.311000E+04,4.780700E+04,& + & 6.513670E+04,5.396300E+00,1.492200E+01,2.421200E+01,3.848400E+01,& + & 7.038300E+01,1.351000E+02,2.947200E+02,8.939600E+02,5.461300E+03,& + & 1.594500E+04,2.116200E+04,2.838000E+04,4.097900E+04,5.583042E+04/ + data absa(:,481:500) / & + & 4.497300E+00,1.243600E+01,2.017600E+01,3.207100E+01,5.865800E+01,& + & 1.125900E+02,2.456100E+02,7.449800E+02,4.551100E+03,1.328700E+04,& + & 1.763600E+04,2.365100E+04,3.414900E+04,4.652685E+04,3.598400E+00,& + & 9.949700E+00,1.614100E+01,2.565700E+01,4.692100E+01,9.007600E+01,& + & 1.964800E+02,5.959700E+02,3.640900E+03,1.063000E+04,1.410800E+04,& + & 1.892100E+04,2.731900E+04,3.722148E+04,2.699300E+00,7.463200E+00,& + & 1.210600E+01,1.924400E+01,3.519300E+01,6.755700E+01,1.473600E+02,& + & 4.469800E+02,2.730700E+03,7.972600E+03,1.058100E+04,1.419100E+04,& + & 2.048900E+04,2.791709E+04,1.800500E+00,4.977100E+00,8.071600E+00,& + & 1.283100E+01,2.346200E+01,4.503900E+01,9.824200E+01,2.979700E+02,& + & 1.820500E+03,5.314900E+03,7.054000E+03,9.460300E+03,1.365900E+04,& + & 1.861097E+04,9.013800E-01,2.490700E+00,4.037000E+00,6.417100E+00,& + & 1.173200E+01,2.252400E+01,4.912000E+01,1.490000E+02,9.102500E+02,& + & 2.657500E+03,3.527200E+03,4.730200E+03,6.830300E+03,9.304823E+03,& + & 2.242900E-04,4.602900E-04,7.303100E-04,1.030000E-03,1.323500E-03,& + & 2.121500E-03,3.820800E-03,6.812400E-03,1.514500E-02,3.182400E-02,& + & 6.248800E-02,9.234200E-02,1.439700E-01,4.691556E-01,8.108400E+00,& + & 2.095700E+01,3.273600E+01,5.269100E+01,9.595800E+01,1.851800E+02,& + & 4.048300E+02,1.194300E+03,7.307800E+03,2.122100E+04,2.812600E+04,& + & 3.746600E+04,5.301700E+04,7.225993E+04,7.095200E+00,1.833700E+01,& + & 2.864600E+01,4.610500E+01,8.396700E+01,1.620300E+02,3.542300E+02,& + & 1.045000E+03,6.394400E+03,1.856900E+04,2.460900E+04,3.278200E+04,& + & 4.638900E+04,6.322884E+04,6.082200E+00,1.571800E+01,2.455300E+01,& + & 3.951900E+01,7.197000E+01,1.388800E+02,3.036300E+02,8.956700E+02,& + & 5.480800E+03,1.591500E+04,2.109300E+04,2.809800E+04,3.976300E+04,& + & 5.419715E+04,5.069200E+00,1.309900E+01,2.046200E+01,3.293300E+01,& + & 5.997300E+01,1.157300E+02,2.530100E+02,7.464600E+02,4.567500E+03,& + & 1.326300E+04,1.757800E+04,2.341600E+04,3.313700E+04,4.516299E+04,& + & 4.056000E+00,1.048000E+01,1.637000E+01,2.634800E+01,4.798200E+01,& + & 9.259100E+01,2.024200E+02,5.971600E+02,3.654000E+03,1.061100E+04,& + & 1.406300E+04,1.873200E+04,2.650900E+04,3.613179E+04,3.042800E+00,& + & 7.861100E+00,1.227800E+01,1.976300E+01,3.598700E+01,6.944900E+01,& + & 1.518200E+02,4.478600E+02,2.740400E+03,7.958000E+03,1.054700E+04,& + & 1.404900E+04,1.988100E+04,2.709802E+04,2.029700E+00,5.242700E+00,& + & 8.186400E+00,1.317600E+01,2.399400E+01,4.630200E+01,1.012100E+02,& + & 2.985700E+02,1.827000E+03,5.305300E+03,7.031100E+03,9.365900E+03,& + & 1.325500E+04,1.806652E+04,1.016300E+00,2.623800E+00,4.094900E+00,& + & 6.591800E+00,1.199800E+01,2.315700E+01,5.060900E+01,1.492900E+02,& + & 9.135100E+02,2.652500E+03,3.515500E+03,4.683100E+03,6.626900E+03,& + & 9.032605E+03,2.658800E-04,5.100000E-04,8.351600E-04,1.305600E-03,& + & 1.545800E-03,2.481300E-03,4.212300E-03,7.233000E-03,1.939100E-02,& + & 4.283100E-02,7.505100E-02,1.138700E-01,2.277200E-01,9.168453E-01,& + & 4.832400E+00,1.659500E+01,3.488200E+01,5.368200E+01,9.668000E+01,& + & 1.870700E+02,4.193700E+02,1.346800E+03,8.776800E+03,2.800500E+04,& + & 3.880800E+04,5.306800E+04,7.797100E+04,1.152439E+05,4.228500E+00,& + & 1.452100E+01,3.052200E+01,4.697100E+01,8.459700E+01,1.636800E+02,& + & 3.669500E+02,1.178400E+03,7.679700E+03,2.450600E+04,3.395800E+04,& + & 4.643400E+04,6.822600E+04,1.008442E+05,3.624400E+00,1.244600E+01,& + & 2.616200E+01,4.026000E+01,7.251600E+01,1.403000E+02,3.145200E+02,& + & 1.010100E+03,6.582600E+03,2.100300E+04,2.910600E+04,3.980100E+04,& + & 5.847500E+04,8.643783E+04,3.020500E+00,1.037200E+01,2.180200E+01,& + & 3.355200E+01,6.043000E+01,1.169200E+02,2.621100E+02,8.417000E+02,& + & 5.485300E+03,1.750400E+04,2.425500E+04,3.316700E+04,4.873200E+04,& + & 7.202664E+04,2.416700E+00,8.297500E+00,1.744100E+01,2.684200E+01,& + & 4.834700E+01,9.354100E+01,2.096900E+02,6.733400E+02,4.388400E+03,& + & 1.400300E+04,1.940300E+04,2.653300E+04,3.898500E+04,5.762147E+04/ + data absa(:,501:520) / & + & 1.813000E+00,6.223400E+00,1.308100E+01,2.013100E+01,3.625700E+01,& + & 7.015300E+01,1.572600E+02,5.050300E+02,3.291200E+03,1.050200E+04,& + & 1.455200E+04,1.990100E+04,2.923800E+04,4.321563E+04,1.209100E+00,& + & 4.149200E+00,8.720800E+00,1.342000E+01,2.417200E+01,4.676600E+01,& + & 1.048500E+02,3.366800E+02,2.194200E+03,7.001800E+03,9.702000E+03,& + & 1.326600E+04,1.949100E+04,2.881157E+04,6.050900E-01,2.074900E+00,& + & 4.360700E+00,6.710700E+00,1.208700E+01,2.338400E+01,5.242300E+01,& + & 1.683400E+02,1.097000E+03,3.500700E+03,4.851000E+03,6.633400E+03,& + & 9.745800E+03,1.440606E+04,1.222800E-04,2.872100E-04,4.185300E-04,& + & 5.961800E-04,8.879200E-04,1.977000E-03,2.278400E-03,3.218000E-03,& + & 4.562500E-03,1.928200E-02,3.087900E-04,5.363100E-05,2.621100E-05,& + & 2.159733E-05,5.800700E+00,1.848700E+01,3.474400E+01,5.420900E+01,& + & 9.903900E+01,1.918300E+02,4.295600E+02,1.341700E+03,8.850700E+03,& + & 2.817800E+04,3.896400E+04,5.291200E+04,7.635800E+04,1.114146E+05,& + & 5.076100E+00,1.617800E+01,3.040000E+01,4.743300E+01,8.666200E+01,& + & 1.678800E+02,3.758600E+02,1.174000E+03,7.744200E+03,2.465600E+04,& + & 3.409300E+04,4.629600E+04,6.681200E+04,9.748920E+04,4.351200E+00,& + & 1.386600E+01,2.605800E+01,4.065700E+01,7.428400E+01,1.438900E+02,& + & 3.221600E+02,1.006200E+03,6.637800E+03,2.113500E+04,2.922200E+04,& + & 3.968400E+04,5.726500E+04,8.355543E+04,3.626400E+00,1.155600E+01,& + & 2.171500E+01,3.387900E+01,6.190300E+01,1.199000E+02,2.684800E+02,& + & 8.385500E+02,5.531600E+03,1.761100E+04,2.435100E+04,3.306700E+04,& + & 4.772100E+04,6.963505E+04,2.901200E+00,9.244400E+00,1.737200E+01,& + & 2.710400E+01,4.952200E+01,9.593200E+01,2.147800E+02,6.708200E+02,& + & 4.425100E+03,1.409000E+04,1.948200E+04,2.645500E+04,3.818000E+04,& + & 5.570785E+04,2.176300E+00,6.933900E+00,1.302900E+01,2.032900E+01,& + & 3.714400E+01,7.194900E+01,1.610800E+02,5.031400E+02,3.318900E+03,& + & 1.056700E+04,1.461200E+04,1.984100E+04,2.863100E+04,4.177910E+04,& + & 1.451500E+00,4.623100E+00,8.686200E+00,1.355300E+01,2.476200E+01,& + & 4.796600E+01,1.073900E+02,3.354100E+02,2.212600E+03,7.044500E+03,& + & 9.741100E+03,1.322800E+04,1.908800E+04,2.785113E+04,7.265100E-01,& + & 2.312600E+00,4.343500E+00,6.777200E+00,1.238200E+01,2.398500E+01,& + & 5.369700E+01,1.677200E+02,1.106300E+03,3.522100E+03,4.870300E+03,& + & 6.613600E+03,9.544900E+03,1.392618E+04,1.618300E-04,3.521000E-04,& + & 5.163500E-04,7.664900E-04,1.034800E-03,2.104300E-03,3.593800E-03,& + & 4.684600E-03,8.787700E-03,8.638200E-03,1.384000E-02,3.304500E-02,& + & 1.665800E-02,3.312186E-02,6.795500E+00,2.015700E+01,3.469400E+01,& + & 5.519100E+01,1.015200E+02,1.971000E+02,4.422200E+02,1.340900E+03,& + & 8.902000E+03,2.820500E+04,3.893500E+04,5.274200E+04,7.459800E+04,& + & 1.081668E+05,5.946300E+00,1.763800E+01,3.035600E+01,4.829300E+01,& + & 8.883400E+01,1.724600E+02,3.869300E+02,1.173400E+03,7.789100E+03,& + & 2.468000E+04,3.406700E+04,4.615000E+04,6.527200E+04,9.464739E+04,& + & 5.097200E+00,1.511900E+01,2.602000E+01,4.139500E+01,7.615000E+01,& + & 1.478400E+02,3.316400E+02,1.005800E+03,6.676500E+03,2.115300E+04,& + & 2.919800E+04,3.955600E+04,5.594900E+04,8.112235E+04,4.248100E+00,& + & 1.260000E+01,2.168300E+01,3.449500E+01,6.345000E+01,1.232000E+02,& + & 2.763800E+02,8.381400E+02,5.563800E+03,1.762800E+04,2.433300E+04,& + & 3.296300E+04,4.662300E+04,6.760627E+04,3.398900E+00,1.008000E+01,& + & 1.734700E+01,2.759700E+01,5.076500E+01,9.855200E+01,2.210900E+02,& + & 6.704800E+02,4.451200E+03,1.410300E+04,1.946600E+04,2.637200E+04,& + & 3.730000E+04,5.408265E+04,2.549800E+00,7.560700E+00,1.301000E+01,& + & 2.069700E+01,3.807100E+01,7.391700E+01,1.658200E+02,5.028700E+02,& + & 3.338300E+03,1.057700E+04,1.460000E+04,1.977900E+04,2.797600E+04,& + & 4.056190E+04,1.700500E+00,5.041400E+00,8.673700E+00,1.379900E+01,& + & 2.538300E+01,4.927800E+01,1.105500E+02,3.352400E+02,2.225600E+03,& + & 7.051200E+03,9.733300E+03,1.318600E+04,1.865000E+04,2.703967E+04/ + data absa(:,521:540) / & + & 8.510900E-01,2.522300E+00,4.337400E+00,6.900900E+00,1.269200E+01,& + & 2.464400E+01,5.527700E+01,1.676300E+02,1.112800E+03,3.525600E+03,& + & 4.866700E+03,6.592500E+03,9.325000E+03,1.352100E+04,1.962200E-04,& + & 4.424800E-04,5.825800E-04,9.657000E-04,1.273400E-03,2.228900E-03,& + & 4.403700E-03,6.560600E-03,1.520900E-02,2.977300E-02,2.130600E-02,& + & 2.403800E-02,6.147200E-02,1.231998E-01,7.787100E+00,2.156800E+01,& + & 3.499900E+01,5.660600E+01,1.038900E+02,2.026500E+02,4.562400E+02,& + & 1.347100E+03,8.930500E+03,2.817000E+04,3.883100E+04,5.232900E+04,& + & 7.268300E+04,1.055210E+05,6.814100E+00,1.887200E+01,3.062500E+01,& + & 4.953000E+01,9.090200E+01,1.773100E+02,3.992100E+02,1.178700E+03,& + & 7.814400E+03,2.464800E+04,3.397900E+04,4.578800E+04,6.360000E+04,& + & 9.232861E+04,5.841200E+00,1.617600E+01,2.624900E+01,4.245500E+01,& + & 7.791200E+01,1.519800E+02,3.422000E+02,1.010300E+03,6.698100E+03,& + & 2.112600E+04,2.912300E+04,3.924800E+04,5.451300E+04,7.914128E+04,& + & 4.868000E+00,1.348000E+01,2.187600E+01,3.538200E+01,6.493500E+01,& + & 1.266600E+02,2.851700E+02,8.419200E+02,5.581700E+03,1.760600E+04,& + & 2.427000E+04,3.270700E+04,4.542900E+04,6.594808E+04,3.894900E+00,& + & 1.078500E+01,1.750100E+01,2.830600E+01,5.194600E+01,1.013300E+02,& + & 2.281200E+02,6.735400E+02,4.465300E+03,1.408400E+04,1.941700E+04,& + & 2.616500E+04,3.634300E+04,5.276038E+04,2.921800E+00,8.089700E+00,& + & 1.312600E+01,2.123000E+01,3.896000E+01,7.599700E+01,1.710900E+02,& + & 5.051500E+02,3.348900E+03,1.056300E+04,1.456200E+04,1.962300E+04,& + & 2.725600E+04,3.955348E+04,1.948700E+00,5.394500E+00,8.751300E+00,& + & 1.415400E+01,2.597300E+01,5.066500E+01,1.140600E+02,3.367700E+02,& + & 2.232600E+03,7.042100E+03,9.707700E+03,1.308200E+04,1.817100E+04,& + & 2.637999E+04,9.755400E-01,2.699300E+00,4.376800E+00,7.079400E+00,& + & 1.298900E+01,2.533800E+01,5.703500E+01,1.683900E+02,1.116300E+03,& + & 3.521100E+03,4.853800E+03,6.541000E+03,9.085200E+03,1.318948E+04,& + & 2.452700E-04,5.024400E-04,7.254500E-04,1.150300E-03,1.546100E-03,& + & 2.507000E-03,4.526600E-03,8.693600E-03,1.779500E-02,3.972000E-02,& + & 6.597300E-02,8.803300E-02,8.702000E-02,3.258791E-01,8.773100E+00,& + & 2.267100E+01,3.565800E+01,5.860400E+01,1.061400E+02,2.083000E+02,& + & 4.701300E+02,1.361500E+03,8.944200E+03,2.804700E+04,3.854900E+04,& + & 5.170200E+04,7.074900E+04,1.034289E+05,7.677000E+00,1.983800E+01,& + & 3.120100E+01,5.127900E+01,9.287200E+01,1.822700E+02,4.113600E+02,& + & 1.191300E+03,7.826200E+03,2.454000E+04,3.372800E+04,4.523700E+04,& + & 6.190100E+04,9.050297E+04,6.580500E+00,1.700400E+01,2.674400E+01,& + & 4.395600E+01,7.961600E+01,1.562300E+02,3.525900E+02,1.021100E+03,& + & 6.707900E+03,2.103400E+04,2.890900E+04,3.877200E+04,5.305900E+04,& + & 7.757218E+04,5.484300E+00,1.417000E+01,2.228800E+01,3.663100E+01,& + & 6.634300E+01,1.301900E+02,2.938400E+02,8.509300E+02,5.590100E+03,& + & 1.752900E+04,2.409100E+04,3.231100E+04,4.422100E+04,6.464784E+04,& + & 4.388300E+00,1.133700E+01,1.783100E+01,2.930600E+01,5.307600E+01,& + & 1.041600E+02,2.350600E+02,6.807200E+02,4.472000E+03,1.402300E+04,& + & 1.927300E+04,2.584800E+04,3.537500E+04,5.171704E+04,3.292100E+00,& + & 8.504200E+00,1.337400E+01,2.198200E+01,3.980700E+01,7.812000E+01,& + & 1.763000E+02,5.105600E+02,3.353900E+03,1.051700E+04,1.445500E+04,& + & 1.938600E+04,2.652900E+04,3.878540E+04,2.195900E+00,5.671100E+00,& + & 8.916500E+00,1.465700E+01,2.653800E+01,5.208600E+01,1.175400E+02,& + & 3.403500E+02,2.236000E+03,7.011500E+03,9.635800E+03,1.292500E+04,& + & 1.768700E+04,2.585730E+04,1.099400E+00,2.838100E+00,4.459300E+00,& + & 7.332100E+00,1.327100E+01,2.604700E+01,5.876500E+01,1.701800E+02,& + & 1.118000E+03,3.505800E+03,4.818200E+03,6.462300E+03,8.843800E+03,& + & 1.292782E+04,2.942100E-04,5.556700E-04,9.395000E-04,1.303700E-03,& + & 1.786300E-03,2.942600E-03,5.154500E-03,9.291800E-03,2.147400E-02,& + & 4.179400E-02,7.995900E-02,1.052800E-01,2.213500E-01,7.334687E-01/ + data absa(:,541:560) / & + & 4.193600E+00,1.445100E+01,3.016800E+01,4.689700E+01,8.592400E+01,& + & 1.676800E+02,3.857300E+02,1.209600E+03,8.528400E+03,2.953300E+04,& + & 4.248600E+04,5.918100E+04,8.438900E+04,1.295418E+05,3.669500E+00,& + & 1.264400E+01,2.639900E+01,4.103600E+01,7.519000E+01,1.467200E+02,& + & 3.375300E+02,1.058400E+03,7.462200E+03,2.584100E+04,3.717500E+04,& + & 5.178400E+04,7.384100E+04,1.133434E+05,3.145600E+00,1.083800E+01,& + & 2.262700E+01,3.517300E+01,6.444600E+01,1.257600E+02,2.893200E+02,& + & 9.071700E+02,6.396200E+03,2.215000E+04,3.186400E+04,4.438500E+04,& + & 6.329200E+04,9.715731E+04,2.621700E+00,9.032100E+00,1.885500E+01,& + & 2.931100E+01,5.370500E+01,1.048000E+02,2.411000E+02,7.559900E+02,& + & 5.330200E+03,1.845700E+04,2.655200E+04,3.698600E+04,5.274100E+04,& + & 8.095976E+04,2.097600E+00,7.225900E+00,1.508500E+01,2.344900E+01,& + & 4.296400E+01,8.383600E+01,1.928700E+02,6.047800E+02,4.264300E+03,& + & 1.476600E+04,2.124200E+04,2.959000E+04,4.219300E+04,6.476339E+04,& + & 1.573500E+00,5.419700E+00,1.131400E+01,1.758600E+01,3.222200E+01,& + & 6.287400E+01,1.446500E+02,4.535900E+02,3.198100E+03,1.107500E+04,& + & 1.593200E+04,2.219200E+04,3.164600E+04,4.857752E+04,1.049500E+00,& + & 3.613300E+00,7.542500E+00,1.172400E+01,2.148200E+01,4.191800E+01,& + & 9.643500E+01,3.024000E+02,2.132100E+03,7.383300E+03,1.062100E+04,& + & 1.479500E+04,2.109700E+04,3.238293E+04,5.252700E-01,1.807000E+00,& + & 3.771500E+00,5.862600E+00,1.074200E+01,2.096000E+01,4.822000E+01,& + & 1.511900E+02,1.066000E+03,3.691700E+03,5.310600E+03,7.397600E+03,& + & 1.054800E+04,1.619077E+04,1.180800E-04,2.793200E-04,4.152400E-04,& + & 5.340400E-04,9.365000E-04,1.990000E-03,2.412700E-03,3.144700E-03,& + & 6.430400E-03,1.509800E-03,2.405300E-04,6.347200E-05,3.597700E-05,& + & 2.086530E-05,5.039800E+00,1.609700E+01,3.008200E+01,4.751000E+01,& + & 8.801100E+01,1.722500E+02,3.971300E+02,1.209500E+03,8.579500E+03,& + & 2.955800E+04,4.253600E+04,5.904200E+04,8.281000E+04,1.263573E+05,& + & 4.410100E+00,1.408500E+01,2.632100E+01,4.156900E+01,7.700900E+01,& + & 1.507200E+02,3.474800E+02,1.058300E+03,7.507200E+03,2.586500E+04,& + & 3.722100E+04,5.166100E+04,7.246200E+04,1.105595E+05,3.780400E+00,& + & 1.207300E+01,2.256200E+01,3.563100E+01,6.601000E+01,1.291900E+02,& + & 2.978400E+02,9.071100E+02,6.434800E+03,2.216900E+04,3.190300E+04,& + & 4.428200E+04,6.210700E+04,9.476038E+04,3.150600E+00,1.006100E+01,& + & 1.880000E+01,2.969500E+01,5.501200E+01,1.076700E+02,2.482100E+02,& + & 7.559700E+02,5.362300E+03,1.847500E+04,2.658500E+04,3.690100E+04,& + & 5.175500E+04,7.897079E+04,2.520900E+00,8.048900E+00,1.504000E+01,& + & 2.375600E+01,4.400900E+01,8.613200E+01,1.985600E+02,6.047400E+02,& + & 4.290000E+03,1.477900E+04,2.126800E+04,2.952100E+04,4.140400E+04,& + & 6.317707E+04,1.891200E+00,6.037200E+00,1.128000E+01,1.781700E+01,& + & 3.300800E+01,6.460100E+01,1.489300E+02,4.535500E+02,3.217300E+03,& + & 1.108500E+04,1.595100E+04,2.214100E+04,3.105500E+04,4.738077E+04,& + & 1.261400E+00,4.025300E+00,7.520300E+00,1.187800E+01,2.200400E+01,& + & 4.306400E+01,9.928200E+01,3.023800E+02,2.144900E+03,7.390000E+03,& + & 1.063400E+04,1.476000E+04,2.070300E+04,3.158630E+04,6.313600E-01,& + & 2.013700E+00,3.760400E+00,5.939600E+00,1.100300E+01,2.153400E+01,& + & 4.964100E+01,1.511900E+02,1.072500E+03,3.694900E+03,5.316900E+03,& + & 7.380200E+03,1.035100E+04,1.579428E+04,1.551900E-04,3.279900E-04,& + & 5.189700E-04,7.058500E-04,1.045300E-03,2.211500E-03,3.870600E-03,& + & 4.916300E-03,8.802200E-03,1.253300E-02,2.360400E-02,8.209300E-03,& + & 2.820100E-02,1.144104E-02,5.903000E+00,1.756400E+01,3.009800E+01,& + & 4.859900E+01,9.016500E+01,1.771000E+02,4.102900E+02,1.216100E+03,& + & 8.610100E+03,2.954000E+04,4.234200E+04,5.866100E+04,8.117500E+04,& + & 1.238301E+05,5.165500E+00,1.536900E+01,2.633600E+01,4.252500E+01,& + & 7.889300E+01,1.549700E+02,3.590000E+02,1.064100E+03,7.533800E+03,& + & 2.584400E+04,3.704700E+04,5.132800E+04,7.102800E+04,1.083537E+05/ + data absa(:,561:580) / & + & 4.427800E+00,1.317300E+01,2.257400E+01,3.645000E+01,6.762300E+01,& + & 1.328300E+02,3.077100E+02,9.120800E+02,6.457500E+03,2.215500E+04,& + & 3.175700E+04,4.399700E+04,6.087800E+04,9.287449E+04,3.690300E+00,& + & 1.097800E+01,1.881200E+01,3.037500E+01,5.635000E+01,1.106900E+02,& + & 2.564400E+02,7.600600E+02,5.381300E+03,1.846300E+04,2.646700E+04,& + & 3.666300E+04,5.073300E+04,7.739524E+04,2.952700E+00,8.782600E+00,& + & 1.504900E+01,2.429900E+01,4.508000E+01,8.854900E+01,2.051400E+02,& + & 6.080400E+02,4.305000E+03,1.476900E+04,2.117200E+04,2.933100E+04,& + & 4.058500E+04,6.191586E+04,2.215200E+00,6.587600E+00,1.128700E+01,& + & 1.822600E+01,3.381100E+01,6.641300E+01,1.538600E+02,4.560300E+02,& + & 3.228800E+03,1.107700E+04,1.587900E+04,2.199800E+04,3.044000E+04,& + & 4.643573E+04,1.477400E+00,4.392500E+00,7.525300E+00,1.215200E+01,& + & 2.254200E+01,4.428100E+01,1.025700E+02,3.040100E+02,2.152500E+03,& + & 7.385100E+03,1.058500E+04,1.466500E+04,2.029300E+04,3.095930E+04,& + & 7.395000E-01,2.197500E+00,3.763400E+00,6.077400E+00,1.127300E+01,& + & 2.214400E+01,5.128800E+01,1.520100E+02,1.076300E+03,3.692400E+03,& + & 5.292500E+03,7.332400E+03,1.014700E+04,1.547888E+04,1.928300E-04,& + & 4.078000E-04,6.349000E-04,8.659900E-04,1.263200E-03,2.408700E-03,& + & 4.769500E-03,6.886500E-03,1.702500E-02,1.741000E-02,1.501800E-02,& + & 2.984300E-02,3.814000E-02,1.142958E-01,6.759800E+00,1.877100E+01,& + & 3.048800E+01,5.012200E+01,9.229400E+01,1.820100E+02,4.234400E+02,& + & 1.232800E+03,8.626700E+03,2.933800E+04,4.204800E+04,5.814500E+04,& + & 7.940900E+04,1.217975E+05,5.915100E+00,1.642600E+01,2.667700E+01,& + & 4.385600E+01,8.075900E+01,1.592600E+02,3.705000E+02,1.078700E+03,& + & 7.548100E+03,2.567000E+04,3.679200E+04,5.087400E+04,6.947600E+04,& + & 1.065747E+05,5.070600E+00,1.407900E+01,2.286700E+01,3.759100E+01,& + & 6.921800E+01,1.365100E+02,3.175600E+02,9.245800E+02,6.470100E+03,& + & 2.200400E+04,3.153700E+04,4.360800E+04,5.955400E+04,9.135255E+04,& + & 4.226000E+00,1.173300E+01,1.905600E+01,3.132800E+01,5.768300E+01,& + & 1.137600E+02,2.646300E+02,7.705000E+02,5.391600E+03,1.833600E+04,& + & 2.628100E+04,3.634200E+04,4.962600E+04,7.611850E+04,3.381500E+00,& + & 9.386800E+00,1.524500E+01,2.506300E+01,4.614600E+01,9.100700E+01,& + & 2.117000E+02,6.163700E+02,4.313200E+03,1.466900E+04,2.102400E+04,& + & 2.907200E+04,3.970000E+04,6.089966E+04,2.536800E+00,7.040900E+00,& + & 1.143400E+01,1.879800E+01,3.460900E+01,6.825700E+01,1.587800E+02,& + & 4.623000E+02,3.235100E+03,1.100200E+04,1.576700E+04,2.180400E+04,& + & 2.977700E+04,4.567310E+04,1.691900E+00,4.695400E+00,7.623300E+00,& + & 1.253400E+01,2.307500E+01,4.551200E+01,1.058600E+02,3.081900E+02,& + & 2.156700E+03,7.334600E+03,1.051200E+04,1.453600E+04,1.985000E+04,& + & 3.044945E+04,8.470600E-01,2.349500E+00,3.812200E+00,6.269700E+00,& + & 1.153900E+01,2.275800E+01,5.293200E+01,1.541000E+02,1.078300E+03,& + & 3.667100E+03,5.256000E+03,7.267800E+03,9.925400E+03,1.522396E+04,& + & 2.347900E-04,5.023000E-04,7.330400E-04,1.005300E-03,1.590100E-03,& + & 2.687200E-03,4.970600E-03,9.461300E-03,2.022300E-02,4.500900E-02,& + & 5.380700E-02,5.782100E-02,1.057300E-01,2.666732E-01,7.616000E+00,& + & 1.969400E+01,3.113900E+01,5.221500E+01,9.451500E+01,1.870300E+02,& + & 4.361500E+02,1.260100E+03,8.622900E+03,2.907300E+04,4.166200E+04,& + & 5.744700E+04,7.767000E+04,1.199791E+05,6.664500E+00,1.723200E+01,& + & 2.724700E+01,4.568900E+01,8.269900E+01,1.636600E+02,3.816500E+02,& + & 1.102600E+03,7.545100E+03,2.544000E+04,3.645700E+04,5.026600E+04,& + & 6.795900E+04,1.049819E+05,5.713000E+00,1.477100E+01,2.335500E+01,& + & 3.916400E+01,7.089100E+01,1.402900E+02,3.271300E+02,9.450500E+02,& + & 6.466900E+03,2.180600E+04,3.124800E+04,4.308600E+04,5.825100E+04,& + & 8.997914E+04,4.761500E+00,1.231000E+01,1.946300E+01,3.263800E+01,& + & 5.907500E+01,1.169000E+02,2.726000E+02,7.875500E+02,5.389200E+03,& + & 1.817100E+04,2.604000E+04,3.590500E+04,4.854500E+04,7.498823E+04/ + data absa(:,581:585) / & + & 3.810000E+00,9.848900E+00,1.557000E+01,2.611100E+01,4.726000E+01,& + & 9.352900E+01,2.180800E+02,6.300400E+02,4.311400E+03,1.453700E+04,& + & 2.083300E+04,2.872200E+04,3.883600E+04,5.999383E+04,2.858300E+00,& + & 7.387500E+00,1.167800E+01,1.958600E+01,3.544500E+01,7.014400E+01,& + & 1.635600E+02,4.725400E+02,3.233500E+03,1.090300E+04,1.562300E+04,& + & 2.154200E+04,2.912700E+04,4.499500E+04,1.906600E+00,4.926400E+00,& + & 7.785900E+00,1.306000E+01,2.363100E+01,4.676900E+01,1.090400E+02,& + & 3.150100E+02,2.155800E+03,7.268400E+03,1.041600E+04,1.436100E+04,& + & 1.941700E+04,2.999583E+04,9.547200E-01,2.465600E+00,3.894000E+00,& + & 6.533400E+00,1.181800E+01,2.339000E+01,5.452300E+01,1.575100E+02,& + & 1.077900E+03,3.634400E+03,5.208200E+03,7.180800E+03,9.708100E+03,& + & 1.499734E+04,2.903400E-04,5.510200E-04,8.657300E-04,1.231300E-03,& + & 1.928300E-03,2.943000E-03,5.661700E-03,1.028300E-02,2.384100E-02,& + & 5.072500E-02,6.831800E-02,1.151000E-01,2.232200E-01,6.194796E-01/ + + data absb(:, 1: 20) / & + & 1.928300E+01,6.652900E+01,1.388600E+02,2.158600E+02,3.954900E+02,& + & 7.718000E+02,1.775500E+03,5.567400E+03,3.925500E+04,1.359400E+05,& + & 1.955600E+05,2.724000E+05,3.884300E+05,5.962588E+05,1.453300E+01,& + & 4.998500E+01,1.042400E+02,1.619900E+02,2.967200E+02,5.789600E+02,& + & 1.331700E+03,4.175700E+03,2.944100E+04,1.019500E+05,1.466700E+05,& + & 2.043000E+05,2.913200E+05,4.471985E+05,9.776500E+00,3.344600E+01,& + & 6.961800E+01,1.081100E+02,1.979400E+02,3.861100E+02,8.879600E+02,& + & 2.783900E+03,1.962800E+04,6.796900E+04,9.778000E+04,1.362000E+05,& + & 1.942200E+05,2.981309E+05,4.998600E+00,1.692300E+01,3.499800E+01,& + & 5.424500E+01,9.916000E+01,1.932700E+02,4.442100E+02,1.392200E+03,& + & 9.814100E+03,3.398500E+04,4.889000E+04,6.810100E+04,9.710900E+04,& + & 1.490676E+05,1.256200E-02,3.591400E-02,6.890800E-02,1.210500E-01,& + & 2.110100E-01,3.628900E-01,6.597200E-01,1.182700E+00,2.165000E+00,& + & 3.362700E+00,3.829300E+00,4.416100E+00,5.411100E+00,7.238214E+00,& + & 2.318700E+01,7.409500E+01,1.384700E+02,2.186900E+02,4.051000E+02,& + & 7.928500E+02,1.827900E+03,5.567200E+03,3.949000E+04,1.360500E+05,& + & 1.957900E+05,2.717600E+05,3.811600E+05,5.815845E+05,1.746100E+01,& + & 5.566100E+01,1.039400E+02,1.641000E+02,3.039300E+02,5.947400E+02,& + & 1.371000E+03,4.175500E+03,2.961800E+04,1.020400E+05,1.468400E+05,& + & 2.038200E+05,2.858700E+05,4.361926E+05,1.173400E+01,3.722600E+01,& + & 6.942300E+01,1.095200E+02,2.027500E+02,3.966400E+02,9.141800E+02,& + & 2.783800E+03,1.974500E+04,6.802600E+04,9.789400E+04,1.358800E+05,& + & 1.905800E+05,2.907938E+05,5.986000E+00,1.880400E+01,3.490500E+01,& + & 5.494000E+01,1.015700E+02,1.985300E+02,4.573100E+02,1.392200E+03,& + & 9.873000E+03,3.401300E+04,4.894700E+04,6.794200E+04,9.529100E+04,& + & 1.454015E+05,1.462200E-02,3.995800E-02,7.358400E-02,1.261800E-01,& + & 2.180500E-01,3.729800E-01,6.617300E-01,1.178000E+00,2.132100E+00,& + & 3.252800E+00,3.647700E+00,4.284000E+00,5.102100E+00,6.980493E+00,& + & 2.716900E+01,8.084000E+01,1.385400E+02,2.237000E+02,4.150200E+02,& + & 8.151800E+02,1.888500E+03,5.597400E+03,3.963100E+04,1.359700E+05,& + & 1.948900E+05,2.700100E+05,3.736400E+05,5.699718E+05,2.044700E+01,& + & 6.072000E+01,1.040000E+02,1.678600E+02,3.113600E+02,6.114900E+02,& + & 1.416500E+03,4.198100E+03,2.972300E+04,1.019800E+05,1.461700E+05,& + & 2.025100E+05,2.802300E+05,4.274793E+05,1.372400E+01,4.059800E+01,& + & 6.946100E+01,1.120200E+02,2.077000E+02,4.078000E+02,9.444600E+02,& + & 2.798900E+03,1.981600E+04,6.798400E+04,9.744700E+04,1.350100E+05,& + & 1.868200E+05,2.849894E+05,6.989700E+00,2.048400E+01,3.492400E+01,& + & 5.619000E+01,1.040500E+02,2.041100E+02,4.724400E+02,1.399700E+03,& + & 9.908100E+03,3.399200E+04,4.872400E+04,6.750300E+04,9.341000E+04,& + & 1.424925E+05,1.675500E-02,4.388100E-02,7.813700E-02,1.311800E-01,& + & 2.240600E-01,3.812100E-01,6.657700E-01,1.171400E+00,2.080300E+00,& + & 3.181400E+00,3.624000E+00,4.117300E+00,4.897400E+00,6.466703E+00,& + & 3.111400E+01,8.639600E+01,1.403400E+02,2.307000E+02,4.248100E+02,& + & 8.377600E+02,1.949000E+03,5.674300E+03,3.970700E+04,1.350400E+05,& + & 1.935400E+05,2.676300E+05,3.655100E+05,5.605972E+05,2.340500E+01,& + & 6.488800E+01,1.053400E+02,1.731200E+02,3.187100E+02,6.284200E+02,& + & 1.461900E+03,4.255800E+03,2.978100E+04,1.012800E+05,1.451500E+05,& + & 2.007300E+05,2.741300E+05,4.204469E+05,1.569500E+01,4.337800E+01,& + & 7.035400E+01,1.155300E+02,2.126100E+02,4.190800E+02,9.747200E+02,& + & 2.837400E+03,1.985400E+04,6.752000E+04,9.677000E+04,1.338200E+05,& + & 1.827600E+05,2.803036E+05,7.980300E+00,2.186700E+01,3.536800E+01,& + & 5.794700E+01,1.065100E+02,2.097400E+02,4.875700E+02,1.418900E+03,& + & 9.927200E+03,3.376000E+04,4.838500E+04,6.690900E+04,9.137800E+04,& + & 1.401529E+05,1.893200E-02,4.756300E-02,8.283500E-02,1.363000E-01,& + & 2.293400E-01,3.873400E-01,6.709000E-01,1.161200E+00,2.058700E+00,& + & 3.051500E+00,3.425300E+00,3.933600E+00,4.493400E+00,5.940876E+00/ + data absb(:, 21: 40) / & + & 3.505600E+01,9.064200E+01,1.433300E+02,2.403400E+02,4.350400E+02,& + & 8.608700E+02,2.007500E+03,5.799900E+03,3.969000E+04,1.338200E+05,& + & 1.917600E+05,2.644200E+05,3.575000E+05,5.522459E+05,2.636000E+01,& + & 6.807300E+01,1.075900E+02,1.803400E+02,3.263800E+02,6.457500E+02,& + & 1.505800E+03,4.350000E+03,2.976800E+04,1.003700E+05,1.438200E+05,& + & 1.983100E+05,2.681300E+05,4.141815E+05,1.766400E+01,4.550300E+01,& + & 7.185300E+01,1.203500E+02,2.177200E+02,4.306300E+02,1.004000E+03,& + & 2.900200E+03,1.984500E+04,6.691000E+04,9.588200E+04,1.322100E+05,& + & 1.787500E+05,2.761244E+05,8.965900E+00,2.293100E+01,3.611600E+01,& + & 6.035200E+01,1.090700E+02,2.155100E+02,5.022000E+02,1.450300E+03,& + & 9.922900E+03,3.345600E+04,4.794200E+04,6.610500E+04,8.937700E+04,& + & 1.380644E+05,2.107100E-02,5.118800E-02,8.750000E-02,1.408000E-01,& + & 2.345300E-01,3.923000E-01,6.719300E-01,1.156600E+00,2.035100E+00,& + & 3.030300E+00,3.396500E+00,3.696100E+00,3.977300E+00,4.929203E+00,& + & 1.018000E+01,3.498700E+01,7.176500E+01,1.126300E+02,2.097900E+02,& + & 4.139500E+02,9.759400E+02,3.007200E+03,2.239100E+04,8.367200E+04,& + & 1.253200E+05,1.811300E+05,2.552500E+05,4.044888E+05,7.705200E+00,& + & 2.632700E+01,5.391800E+01,8.456700E+01,1.574300E+02,3.105600E+02,& + & 7.320600E+02,2.255500E+03,1.679300E+04,6.275400E+04,9.399000E+04,& + & 1.358500E+05,1.914300E+05,3.033643E+05,5.217500E+00,1.767800E+01,& + & 3.607300E+01,5.650200E+01,1.050800E+02,2.071800E+02,4.881900E+02,& + & 1.503800E+03,1.119600E+04,4.183600E+04,6.266000E+04,9.056500E+04,& + & 1.276200E+05,2.022396E+05,2.705900E+00,9.044400E+00,1.822800E+01,& + & 2.844400E+01,5.273600E+01,1.038000E+02,2.443200E+02,7.521100E+02,& + & 5.598100E+03,2.091800E+04,3.133000E+04,4.528300E+04,6.381100E+04,& + & 1.011223E+05,1.072500E-02,3.102500E-02,5.986700E-02,1.063800E-01,& + & 1.884200E-01,3.338100E-01,6.312100E-01,1.187300E+00,2.295800E+00,& + & 3.622000E+00,4.213200E+00,4.845400E+00,5.807100E+00,8.025787E+00,& + & 1.221600E+01,3.893400E+01,7.156700E+01,1.146500E+02,2.150200E+02,& + & 4.253900E+02,1.008700E+03,3.026000E+03,2.248300E+04,8.335500E+04,& + & 1.249000E+05,1.803000E+05,2.509600E+05,3.983428E+05,9.233200E+00,& + & 2.928800E+01,5.377100E+01,8.607200E+01,1.613600E+02,3.191500E+02,& + & 7.566100E+02,2.269600E+03,1.686200E+04,6.251600E+04,9.367500E+04,& + & 1.352300E+05,1.882200E+05,2.987573E+05,6.242000E+00,1.964800E+01,& + & 3.597700E+01,5.750000E+01,1.077000E+02,2.129000E+02,5.045500E+02,& + & 1.513200E+03,1.124100E+04,4.167700E+04,6.245000E+04,9.015000E+04,& + & 1.254800E+05,1.991675E+05,3.223500E+00,1.002300E+01,1.818300E+01,& + & 2.894100E+01,5.404600E+01,1.066600E+02,2.524900E+02,7.568300E+02,& + & 5.620900E+03,2.083900E+04,3.122500E+04,4.507500E+04,6.274000E+04,& + & 9.958385E+04,1.247200E-02,3.445900E-02,6.394700E-02,1.110800E-01,& + & 1.948600E-01,3.416900E-01,6.350200E-01,1.177800E+00,2.264600E+00,& + & 3.545400E+00,4.091400E+00,4.687300E+00,5.610200E+00,7.782940E+00,& + & 1.425800E+01,4.239900E+01,7.190200E+01,1.179600E+02,2.203000E+02,& + & 4.372300E+02,1.041500E+03,3.073900E+03,2.251700E+04,8.292400E+04,& + & 1.240000E+05,1.785600E+05,2.468500E+05,3.934487E+05,1.076400E+01,& + & 3.188800E+01,5.402100E+01,8.856000E+01,1.653200E+02,3.280300E+02,& + & 7.812400E+02,2.305500E+03,1.688800E+04,6.219300E+04,9.300300E+04,& + & 1.339200E+05,1.851400E+05,2.950900E+05,7.267300E+00,2.137600E+01,& + & 3.614100E+01,5.916100E+01,1.103400E+02,2.188200E+02,5.209600E+02,& + & 1.537100E+03,1.125900E+04,4.146200E+04,6.200100E+04,8.927900E+04,& + & 1.234300E+05,1.967230E+05,3.743400E+00,1.088100E+01,1.826600E+01,& + & 2.976800E+01,5.536500E+01,1.096200E+02,2.606900E+02,7.688000E+02,& + & 5.629600E+03,2.073100E+04,3.100100E+04,4.464000E+04,6.171300E+04,& + & 9.836265E+04,1.427100E-02,3.778600E-02,6.816000E-02,1.155000E-01,& + & 2.005000E-01,3.494700E-01,6.371000E-01,1.175900E+00,2.216400E+00,& + & 3.432800E+00,4.012600E+00,4.621000E+00,5.404800E+00,7.328372E+00/ + data absb(:, 41: 60) / & + & 1.629700E+01,4.514100E+01,7.310100E+01,1.224800E+02,2.260000E+02,& + & 4.492700E+02,1.074400E+03,3.153400E+03,2.251100E+04,8.218900E+04,& + & 1.226200E+05,1.766100E+05,2.425300E+05,3.892921E+05,1.229200E+01,& + & 3.394600E+01,5.491900E+01,9.195000E+01,1.696000E+02,3.370500E+02,& + & 8.058900E+02,2.365100E+03,1.688300E+04,6.164100E+04,9.196300E+04,& + & 1.324600E+05,1.819000E+05,2.919673E+05,8.286700E+00,2.274900E+01,& + & 3.673900E+01,6.142100E+01,1.132000E+02,2.248300E+02,5.373900E+02,& + & 1.576900E+03,1.125600E+04,4.109400E+04,6.130900E+04,8.830300E+04,& + & 1.212600E+05,1.946425E+05,4.259700E+00,1.155900E+01,1.856900E+01,& + & 3.089600E+01,5.680200E+01,1.126100E+02,2.689000E+02,7.886800E+02,& + & 5.628100E+03,2.054700E+04,3.065400E+04,4.415200E+04,6.063200E+04,& + & 9.732266E+04,1.603500E-02,4.103700E-02,7.213800E-02,1.202100E-01,& + & 2.056200E-01,3.556700E-01,6.400400E-01,1.168600E+00,2.169200E+00,& + & 3.392200E+00,3.828800E+00,4.450600E+00,5.255700E+00,6.923169E+00,& + & 1.833700E+01,4.719300E+01,7.481300E+01,1.281600E+02,2.327200E+02,& + & 4.619500E+02,1.105400E+03,3.260100E+03,2.247000E+04,8.120500E+04,& + & 1.209900E+05,1.741400E+05,2.384500E+05,3.853827E+05,1.382200E+01,& + & 3.548500E+01,5.620200E+01,9.621100E+01,1.746400E+02,3.465600E+02,& + & 8.291300E+02,2.445100E+03,1.685300E+04,6.090400E+04,9.074500E+04,& + & 1.306000E+05,1.788400E+05,2.890368E+05,9.306100E+00,2.377500E+01,& + & 3.759300E+01,6.426000E+01,1.165700E+02,2.311700E+02,5.528800E+02,& + & 1.630200E+03,1.123500E+04,4.060200E+04,6.049600E+04,8.706900E+04,& + & 1.192200E+05,1.926913E+05,4.774200E+00,1.207100E+01,1.899200E+01,& + & 3.231200E+01,5.848800E+01,1.157800E+02,2.766400E+02,8.153600E+02,& + & 5.617800E+03,2.030100E+04,3.024800E+04,4.353500E+04,5.961200E+04,& + & 9.634478E+04,1.777700E-02,4.397000E-02,7.629900E-02,1.248500E-01,& + & 2.102400E-01,3.606500E-01,6.412200E-01,1.158800E+00,2.148800E+00,& + & 3.242500E+00,3.649400E+00,4.323100E+00,4.904400E+00,6.348546E+00,& + & 5.484300E+00,1.879700E+01,3.776200E+01,5.985400E+01,1.129900E+02,& + & 2.258500E+02,5.447800E+02,1.668100E+03,1.280600E+04,5.115000E+04,& + & 8.014600E+04,1.208500E+05,1.726200E+05,2.845387E+05,4.181400E+00,& + & 1.418600E+01,2.841800E+01,4.498400E+01,8.484200E+01,1.694900E+02,& + & 4.087000E+02,1.251200E+03,9.604600E+03,3.836300E+04,6.011000E+04,& + & 9.063500E+04,1.294700E+05,2.134083E+05,2.858300E+00,9.590500E+00,& + & 1.907300E+01,3.011900E+01,5.669200E+01,1.131300E+02,2.726200E+02,& + & 8.342800E+02,6.403300E+03,2.557600E+04,4.007400E+04,6.042400E+04,& + & 8.631300E+04,1.422709E+05,1.512200E+00,4.991600E+00,9.732300E+00,& + & 1.527400E+01,2.854400E+01,5.677000E+01,1.365400E+02,4.173700E+02,& + & 3.201900E+03,1.278800E+04,2.003700E+04,3.021300E+04,4.315700E+04,& + & 7.113734E+04,9.171200E-03,2.674100E-02,5.193700E-02,9.288700E-02,& + & 1.670600E-01,3.035600E-01,5.952300E-01,1.179600E+00,2.425100E+00,& + & 3.914500E+00,4.602500E+00,5.347600E+00,6.339700E+00,8.949960E+00,& + & 6.550900E+00,2.089700E+01,3.772500E+01,6.127100E+01,1.159400E+02,& + & 2.320100E+02,5.630500E+02,1.695900E+03,1.282800E+04,5.087500E+04,& + & 7.936500E+04,1.198700E+05,1.702900E+05,2.824115E+05,4.983900E+00,& + & 1.576100E+01,2.839000E+01,4.604500E+01,8.705000E+01,1.741100E+02,& + & 4.224000E+02,1.272000E+03,9.620900E+03,3.815700E+04,5.952400E+04,& + & 8.990300E+04,1.277200E+05,2.118092E+05,3.398100E+00,1.063600E+01,& + & 1.905700E+01,3.082300E+01,5.816300E+01,1.162100E+02,2.817500E+02,& + & 8.481800E+02,6.414200E+03,2.543800E+04,3.968300E+04,5.993600E+04,& + & 8.514600E+04,1.412073E+05,1.787800E+00,5.507500E+00,9.730300E+00,& + & 1.561900E+01,2.928100E+01,5.831100E+01,1.411000E+02,4.243200E+02,& + & 3.207300E+03,1.271900E+04,1.984200E+04,2.996900E+04,4.257400E+04,& + & 7.060574E+04,1.065400E-02,2.965800E-02,5.559100E-02,9.712900E-02,& + & 1.728500E-01,3.109100E-01,6.000300E-01,1.171200E+00,2.396000E+00,& + & 3.815200E+00,4.501100E+00,5.228500E+00,6.155900E+00,8.672581E+00/ + data absb(:, 61: 80) / & + & 7.617200E+00,2.267500E+01,3.804800E+01,6.341200E+01,1.191200E+02,& + & 2.383900E+02,5.812300E+02,1.743800E+03,1.282600E+04,5.040700E+04,& + & 7.843700E+04,1.186300E+05,1.677800E+05,2.805805E+05,5.783600E+00,& + & 1.709300E+01,2.863400E+01,4.765200E+01,8.943900E+01,1.788900E+02,& + & 4.360300E+02,1.308000E+03,9.619500E+03,3.780600E+04,5.882800E+04,& + & 8.897600E+04,1.258300E+05,2.104353E+05,3.937100E+00,1.151800E+01,& + & 1.922100E+01,3.189400E+01,5.975700E+01,1.193900E+02,2.908300E+02,& + & 8.721400E+02,6.413200E+03,2.520400E+04,3.921900E+04,5.931800E+04,& + & 8.389100E+04,1.402902E+05,2.062000E+00,5.942400E+00,9.822400E+00,& + & 1.614400E+01,3.008100E+01,5.989900E+01,1.456300E+02,4.363100E+02,& + & 3.206900E+03,1.260200E+04,1.961000E+04,2.966000E+04,4.194600E+04,& + & 7.014730E+04,1.210900E-02,3.247500E-02,5.926300E-02,1.015300E-01,& + & 1.781600E-01,3.181000E-01,6.018100E-01,1.163000E+00,2.358800E+00,& + & 3.773300E+00,4.399500E+00,5.091800E+00,5.927500E+00,8.322405E+00,& + & 8.691900E+00,2.404000E+01,3.878400E+01,6.623400E+01,1.227400E+02,& + & 2.450200E+02,5.988200E+02,1.805700E+03,1.281800E+04,4.969300E+04,& + & 7.747100E+04,1.168600E+05,1.656400E+05,2.786715E+05,6.588600E+00,& + & 1.812100E+01,2.918200E+01,4.976700E+01,9.215900E+01,1.838600E+02,& + & 4.492200E+02,1.354400E+03,9.613900E+03,3.727000E+04,5.810400E+04,& + & 8.764900E+04,1.242300E+05,2.090033E+05,4.477600E+00,1.220000E+01,& + & 1.958500E+01,3.330200E+01,6.157500E+01,1.227000E+02,2.996200E+02,& + & 9.031100E+02,6.409500E+03,2.484700E+04,3.873600E+04,5.843300E+04,& + & 8.282400E+04,1.393395E+05,2.337200E+00,6.277300E+00,1.001000E+01,& + & 1.684200E+01,3.099700E+01,6.154400E+01,1.500200E+02,4.518000E+02,& + & 3.205000E+03,1.242400E+04,1.936900E+04,2.921700E+04,4.141300E+04,& + & 6.967070E+04,1.358500E-02,3.515900E-02,6.288300E-02,1.058500E-01,& + & 1.830600E-01,3.239100E-01,6.032000E-01,1.158400E+00,2.310600E+00,& + & 3.671700E+00,4.308700E+00,4.990300E+00,5.814200E+00,7.861660E+00,& + & 9.777000E+00,2.503800E+01,3.980400E+01,6.939200E+01,1.271100E+02,& + & 2.528900E+02,6.153000E+02,1.872900E+03,1.280800E+04,4.898700E+04,& + & 7.616700E+04,1.148500E+05,1.636300E+05,2.767524E+05,7.402700E+00,& + & 1.887000E+01,2.994500E+01,5.213300E+01,9.543400E+01,1.897700E+02,& + & 4.615800E+02,1.404800E+03,9.606300E+03,3.674000E+04,5.712600E+04,& + & 8.613900E+04,1.227300E+05,2.075661E+05,5.023100E+00,1.270000E+01,& + & 2.008900E+01,3.487600E+01,6.376000E+01,1.266400E+02,3.078500E+02,& + & 9.367100E+02,6.404400E+03,2.449400E+04,3.808400E+04,5.742700E+04,& + & 8.181900E+04,1.383775E+05,2.613600E+00,6.527000E+00,1.026000E+01,& + & 1.762500E+01,3.208900E+01,6.352000E+01,1.541300E+02,4.686000E+02,& + & 3.202500E+03,1.224700E+04,1.904300E+04,2.871400E+04,4.091000E+04,& + & 6.918991E+04,1.500800E-02,3.763500E-02,6.632600E-02,1.102500E-01,& + & 1.879300E-01,3.285000E-01,6.049200E-01,1.149000E+00,2.272200E+00,& + & 3.564700E+00,4.165700E+00,4.785600E+00,5.646600E+00,7.480202E+00,& + & 3.514300E+00,1.206200E+01,2.366700E+01,3.789800E+01,7.234200E+01,& + & 1.463500E+02,3.599300E+02,1.112700E+03,8.596700E+03,3.653500E+04,& + & 5.941200E+04,9.437100E+04,1.394500E+05,2.416643E+05,2.700400E+00,& + & 9.137400E+00,1.784500E+01,2.852100E+01,5.435300E+01,1.098600E+02,& + & 2.700600E+02,8.346300E+02,6.447600E+03,2.740100E+04,4.455900E+04,& + & 7.077900E+04,1.045900E+05,1.811533E+05,1.863200E+00,6.226000E+00,& + & 1.202400E+01,1.915100E+01,3.636500E+01,7.337200E+01,1.802000E+02,& + & 5.565700E+02,4.298600E+03,1.826800E+04,2.970600E+04,4.718600E+04,& + & 6.972400E+04,1.208333E+05,1.000500E+00,3.277800E+00,6.215000E+00,& + & 9.824600E+00,1.838800E+01,3.689000E+01,9.033200E+01,2.785100E+02,& + & 2.149600E+03,9.134100E+03,1.485400E+04,2.359300E+04,3.486300E+04,& + & 6.041815E+04,7.854900E-03,2.301000E-02,4.496100E-02,8.072000E-02,& + & 1.472100E-01,2.734400E-01,5.549300E-01,1.154400E+00,2.547600E+00,& + & 4.254200E+00,4.987900E+00,5.919300E+00,7.072500E+00,9.995624E+00/ + data absb(:, 81:100) / & + & 4.178200E+00,1.336800E+01,2.371000E+01,3.902400E+01,7.431000E+01,& + & 1.503100E+02,3.721500E+02,1.145200E+03,8.598700E+03,3.615100E+04,& + & 5.873700E+04,9.323700E+04,1.379900E+05,2.408642E+05,3.201000E+00,& + & 1.011400E+01,1.788100E+01,2.936100E+01,5.582700E+01,1.128300E+02,& + & 2.792200E+02,8.590200E+02,6.449200E+03,2.711400E+04,4.405300E+04,& + & 6.992800E+04,1.034900E+05,1.806502E+05,2.200800E+00,6.873100E+00,& + & 1.205300E+01,1.970600E+01,3.734800E+01,7.535600E+01,1.862900E+02,& + & 5.728400E+02,4.299600E+03,1.807600E+04,2.936900E+04,4.661900E+04,& + & 6.899600E+04,1.204358E+05,1.175400E+00,3.595500E+00,6.241300E+00,& + & 1.008800E+01,1.888300E+01,3.788100E+01,9.337200E+01,2.866500E+02,& + & 2.150100E+03,9.038300E+03,1.468500E+04,2.331000E+04,3.449900E+04,& + & 6.021795E+04,9.059600E-03,2.551500E-02,4.822700E-02,8.482100E-02,& + & 1.524100E-01,2.809200E-01,5.585100E-01,1.148900E+00,2.520400E+00,& + & 4.166600E+00,4.895200E+00,5.777800E+00,6.903900E+00,9.690014E+00,& + & 4.846100E+00,1.443200E+01,2.398300E+01,4.063000E+01,7.665100E+01,& + & 1.544400E+02,3.839400E+02,1.185900E+03,8.599900E+03,3.566600E+04,& + & 5.791300E+04,9.186800E+04,1.366700E+05,2.398944E+05,3.703600E+00,& + & 1.091100E+01,1.808500E+01,3.056500E+01,5.758800E+01,1.159200E+02,& + & 2.880600E+02,8.895800E+02,6.450000E+03,2.675000E+04,4.343500E+04,& + & 6.890100E+04,1.025000E+05,1.799234E+05,2.539500E+00,7.400500E+00,& + & 1.219300E+01,2.050500E+01,3.852800E+01,7.740700E+01,1.921800E+02,& + & 5.932100E+02,4.300200E+03,1.783300E+04,2.895700E+04,4.593500E+04,& + & 6.833600E+04,1.199505E+05,1.349900E+00,3.852300E+00,6.326300E+00,& + & 1.047200E+01,1.947800E+01,3.890000E+01,9.630800E+01,2.968500E+02,& + & 2.150400E+03,8.916900E+03,1.447900E+04,2.296800E+04,3.416900E+04,& + & 5.997526E+04,1.029100E-02,2.787300E-02,5.141800E-02,8.905600E-02,& + & 1.573900E-01,2.878100E-01,5.603500E-01,1.142300E+00,2.487800E+00,& + & 4.106300E+00,4.793100E+00,5.621400E+00,6.652600E+00,9.386062E+00,& + & 5.524100E+00,1.521000E+01,2.454100E+01,4.255900E+01,7.941700E+01,& + & 1.592200E+02,3.951800E+02,1.231400E+03,8.604300E+03,3.513300E+04,& + & 5.691200E+04,9.037200E+04,1.353200E+05,2.387935E+05,4.212500E+00,& + & 1.149800E+01,1.849900E+01,3.201100E+01,5.966500E+01,1.195100E+02,& + & 2.964900E+02,9.237000E+02,6.453400E+03,2.635000E+04,4.268400E+04,& + & 6.778000E+04,1.014900E+05,1.790903E+05,2.883300E+00,7.787800E+00,& + & 1.246800E+01,2.146700E+01,3.991400E+01,7.979700E+01,1.977900E+02,& + & 6.159600E+02,4.302400E+03,1.756700E+04,2.845600E+04,4.518700E+04,& + & 6.765900E+04,1.193967E+05,1.526600E+00,4.042700E+00,6.470800E+00,& + & 1.094300E+01,2.017400E+01,4.009100E+01,9.910600E+01,3.082200E+02,& + & 2.151500E+03,8.783800E+03,1.422900E+04,2.259400E+04,3.383000E+04,& + & 5.969941E+04,1.150000E-02,3.009600E-02,5.458700E-02,9.318600E-02,& + & 1.623700E-01,2.933200E-01,5.626700E-01,1.138000E+00,2.439700E+00,& + & 4.030900E+00,4.705800E+00,5.510300E+00,6.550600E+00,8.885744E+00,& + & 6.209500E+00,1.579500E+01,2.524700E+01,4.456400E+01,8.250900E+01,& + & 1.654800E+02,4.056400E+02,1.279300E+03,8.617600E+03,3.452600E+04,& + & 5.585800E+04,8.869900E+04,1.340100E+05,2.373299E+05,4.727000E+00,& + & 1.193800E+01,1.902600E+01,3.351300E+01,6.198400E+01,1.242000E+02,& + & 3.043300E+02,9.596300E+02,6.463400E+03,2.589400E+04,4.189400E+04,& + & 6.652500E+04,1.005100E+05,1.779956E+05,3.229700E+00,8.081000E+00,& + & 1.281500E+01,2.246500E+01,4.146200E+01,8.293000E+01,2.030200E+02,& + & 6.399100E+02,4.309100E+03,1.726300E+04,2.792900E+04,4.435000E+04,& + & 6.700800E+04,1.186684E+05,1.703500E+00,4.189700E+00,6.645700E+00,& + & 1.143200E+01,2.094700E+01,4.166100E+01,1.017100E+02,3.202000E+02,& + & 2.154800E+03,8.631800E+03,1.396500E+04,2.217600E+04,3.350500E+04,& + & 5.933359E+04,1.266900E-02,3.212300E-02,5.757800E-02,9.717100E-02,& + & 1.672900E-01,2.980800E-01,5.647600E-01,1.130700E+00,2.400800E+00,& + & 3.897800E+00,4.565400E+00,5.347200E+00,6.394600E+00,8.490191E+00/ + data absb(:,101:120) / & + & 2.331700E+00,8.034300E+00,1.541100E+01,2.492500E+01,4.791200E+01,& + & 9.814200E+01,2.459500E+02,7.766100E+02,5.928400E+03,2.641400E+04,& + & 4.473900E+04,7.473700E+04,1.172800E+05,2.141518E+05,1.808200E+00,& + & 6.120200E+00,1.165400E+01,1.879200E+01,3.603200E+01,7.370500E+01,& + & 1.845800E+02,5.825800E+02,4.446400E+03,1.981100E+04,3.355400E+04,& + & 5.605300E+04,8.796200E+04,1.606154E+05,1.260600E+00,4.205700E+00,& + & 7.902900E+00,1.267400E+01,2.415600E+01,4.926800E+01,1.232000E+02,& + & 3.885400E+02,2.964500E+03,1.320700E+04,2.237000E+04,3.736900E+04,& + & 5.864200E+04,1.070759E+05,6.845100E-01,2.241600E+00,4.129000E+00,& + & 6.628700E+00,1.231200E+01,2.484000E+01,6.183800E+01,1.945000E+02,& + & 1.482500E+03,6.603900E+03,1.118500E+04,1.868500E+04,2.932200E+04,& + & 5.353855E+04,6.663800E-03,1.972200E-02,3.876100E-02,6.997400E-02,& + & 1.286700E-01,2.442900E-01,5.090500E-01,1.116200E+00,2.654400E+00,& + & 4.645400E+00,5.425800E+00,6.529600E+00,7.974300E+00,1.122477E+01,& + & 2.762500E+00,8.855000E+00,1.548300E+01,2.581400E+01,4.939600E+01,& + & 1.007600E+02,2.541300E+02,8.041500E+02,5.932700E+03,2.606800E+04,& + & 4.404000E+04,7.367800E+04,1.163500E+05,2.138798E+05,2.133900E+00,& + & 6.733500E+00,1.171200E+01,1.945400E+01,3.714500E+01,7.566800E+01,& + & 1.907000E+02,6.032300E+02,4.449700E+03,1.955100E+04,3.303000E+04,& + & 5.525900E+04,8.726600E+04,1.604089E+05,1.481600E+00,4.611200E+00,& + & 7.948400E+00,1.310800E+01,2.489800E+01,5.057600E+01,1.272800E+02,& + & 4.023100E+02,2.966600E+03,1.303400E+04,2.202000E+04,3.684000E+04,& + & 5.817800E+04,1.069424E+05,7.999400E-01,2.439900E+00,4.165600E+00,& + & 6.832500E+00,1.268300E+01,2.549300E+01,6.386800E+01,2.013900E+02,& + & 1.483600E+03,6.517400E+03,1.101100E+04,1.842000E+04,2.909000E+04,& + & 5.347171E+04,7.683900E-03,2.183300E-02,4.156400E-02,7.390700E-02,& + & 1.334500E-01,2.518400E-01,5.118500E-01,1.113000E+00,2.630000E+00,& + & 4.563300E+00,5.331600E+00,6.389900E+00,7.787300E+00,1.089701E+01,& + & 3.198000E+00,9.502800E+00,1.571500E+01,2.698000E+01,5.121100E+01,& + & 1.037800E+02,2.618700E+02,8.355400E+02,5.941100E+03,2.568900E+04,& + & 4.327800E+04,7.246300E+04,1.153400E+05,2.134450E+05,2.463200E+00,& + & 7.217600E+00,1.188500E+01,2.033000E+01,3.850900E+01,7.792600E+01,& + & 1.965100E+02,6.267700E+02,4.456000E+03,1.926700E+04,3.245900E+04,& + & 5.434700E+04,8.650400E+04,1.600874E+05,1.704300E+00,4.929000E+00,& + & 8.071300E+00,1.368700E+01,2.581200E+01,5.207300E+01,1.311500E+02,& + & 4.180100E+02,2.970800E+03,1.284500E+04,2.163900E+04,3.623200E+04,& + & 5.767000E+04,1.067246E+05,9.167100E-01,2.591800E+00,4.245100E+00,& + & 7.110000E+00,1.313900E+01,2.623500E+01,6.579500E+01,2.092400E+02,& + & 1.485700E+03,6.422500E+03,1.082000E+04,1.811600E+04,2.883500E+04,& + & 5.336320E+04,8.713400E-03,2.377100E-02,4.436900E-02,7.782100E-02,& + & 1.383300E-01,2.582100E-01,5.147400E-01,1.109300E+00,2.599300E+00,& + & 4.482600E+00,5.225800E+00,6.223400E+00,7.544900E+00,1.057279E+01,& + & 3.643700E+00,9.968100E+00,1.610900E+01,2.828700E+01,5.324300E+01,& + & 1.076800E+02,2.692100E+02,8.678700E+02,5.963400E+03,2.520900E+04,& + & 4.248400E+04,7.117800E+04,1.143200E+05,2.126002E+05,2.799500E+00,& + & 7.566500E+00,1.217700E+01,2.130700E+01,4.003600E+01,8.084900E+01,& + & 2.020100E+02,6.510200E+02,4.472700E+03,1.890700E+04,3.186300E+04,& + & 5.338300E+04,8.573800E+04,1.594510E+05,1.931900E+00,5.159200E+00,& + & 8.266300E+00,1.433400E+01,2.683000E+01,5.402400E+01,1.348100E+02,& + & 4.341800E+02,2.982000E+03,1.260500E+04,2.124200E+04,3.558900E+04,& + & 5.715900E+04,1.063002E+05,1.034900E+00,2.705400E+00,4.353400E+00,& + & 7.417600E+00,1.364900E+01,2.721100E+01,6.761500E+01,2.173300E+02,& + & 1.491200E+03,6.302700E+03,1.062200E+04,1.779500E+04,2.858000E+04,& + & 5.315164E+04,9.701100E-03,2.558700E-02,4.710000E-02,8.156500E-02,& + & 1.434500E-01,2.633900E-01,5.186500E-01,1.105700E+00,2.555300E+00,& + & 4.388900E+00,5.130600E+00,6.126200E+00,7.389400E+00,1.007808E+01/ + data absb(:,121:140) / & + & 4.094400E+00,1.034100E+01,1.661100E+01,2.963500E+01,5.535900E+01,& + & 1.126700E+02,2.768800E+02,9.003900E+02,6.003200E+03,2.466100E+04,& + & 4.161000E+04,6.984600E+04,1.131200E+05,2.114781E+05,3.138800E+00,& + & 7.846400E+00,1.255100E+01,2.231800E+01,4.162100E+01,8.459900E+01,& + & 2.077600E+02,6.754100E+02,4.502500E+03,1.849600E+04,3.120800E+04,& + & 5.238500E+04,8.483800E+04,1.586110E+05,2.160800E+00,5.346400E+00,& + & 8.512500E+00,1.500500E+01,2.788700E+01,5.652600E+01,1.386500E+02,& + & 4.504300E+02,3.001800E+03,1.233100E+04,2.080500E+04,3.492300E+04,& + & 5.655900E+04,1.057398E+05,1.153500E+00,2.799800E+00,4.482500E+00,& + & 7.740200E+00,1.417400E+01,2.846200E+01,6.953100E+01,2.254500E+02,& + & 1.501200E+03,6.165800E+03,1.040300E+04,1.746200E+04,2.828000E+04,& + & 5.287057E+04,1.062100E-02,2.726200E-02,4.959400E-02,8.522200E-02,& + & 1.483900E-01,2.684100E-01,5.217000E-01,1.099400E+00,2.516700E+00,& + & 4.258900E+00,4.961100E+00,6.003800E+00,7.224300E+00,9.659371E+00,& + & 1.586200E+00,5.478400E+00,1.032500E+01,1.683300E+01,3.251700E+01,& + & 6.732900E+01,1.716400E+02,5.559300E+02,4.169600E+03,1.920800E+04,& + & 3.380800E+04,5.956100E+04,1.002000E+05,1.954333E+05,1.243600E+00,& + & 4.206300E+00,7.839000E+00,1.272600E+01,2.448600E+01,5.059400E+01,& + & 1.288400E+02,4.170600E+02,3.127400E+03,1.440600E+04,2.535600E+04,& + & 4.467100E+04,7.514800E+04,1.465750E+05,8.748900E-01,2.911800E+00,& + & 5.361200E+00,8.653300E+00,1.646400E+01,3.386200E+01,8.605000E+01,& + & 2.781900E+02,2.085100E+03,9.604400E+03,1.690400E+04,2.978100E+04,& + & 5.009900E+04,9.771736E+04,4.798600E-01,1.570700E+00,2.829400E+00,& + & 4.613200E+00,8.525500E+00,1.716200E+01,4.326600E+01,1.393300E+02,& + & 1.042800E+03,4.802500E+03,8.452600E+03,1.489100E+04,2.505000E+04,& + & 4.885899E+04,5.635600E-03,1.684300E-02,3.318600E-02,6.056800E-02,& + & 1.117500E-01,2.167700E-01,4.605500E-01,1.065300E+00,2.738600E+00,& + & 5.034200E+00,5.958800E+00,7.210600E+00,8.980300E+00,1.267723E+01,& + & 1.874400E+00,6.000300E+00,1.039800E+01,1.751500E+01,3.370200E+01,& + & 6.922400E+01,1.771300E+02,5.773100E+02,4.179600E+03,1.892700E+04,& + & 3.320500E+04,5.857300E+04,9.942300E+04,1.954504E+05,1.462300E+00,& + & 4.594900E+00,7.898400E+00,1.323400E+01,2.537600E+01,5.200900E+01,& + & 1.329600E+02,4.330900E+02,3.134800E+03,1.419500E+04,2.490400E+04,& + & 4.393000E+04,7.456700E+04,1.465908E+05,1.024200E+00,3.167100E+00,& + & 5.411100E+00,8.983500E+00,1.705600E+01,3.480300E+01,8.879100E+01,& + & 2.888800E+02,2.090100E+03,9.463600E+03,1.660300E+04,2.928700E+04,& + & 4.971200E+04,9.772430E+04,5.587400E-01,1.695000E+00,2.867500E+00,& + & 4.778100E+00,8.810500E+00,1.762700E+01,4.462800E+01,1.446700E+02,& + & 1.045300E+03,4.732000E+03,8.301900E+03,1.464400E+04,2.485600E+04,& + & 4.886345E+04,6.491800E-03,1.856800E-02,3.562500E-02,6.413700E-02,& + & 1.164700E-01,2.237600E-01,4.640500E-01,1.063700E+00,2.718400E+00,& + & 4.945300E+00,5.855300E+00,7.077200E+00,8.755100E+00,1.233269E+01,& + & 2.167100E+00,6.404400E+00,1.057100E+01,1.835900E+01,3.505500E+01,& + & 7.167100E+01,1.823300E+02,5.996200E+02,4.202800E+03,1.857500E+04,& + & 3.258700E+04,5.751400E+04,9.863500E+04,1.950472E+05,1.684500E+00,& + & 4.895500E+00,8.029700E+00,1.386600E+01,2.639200E+01,5.384200E+01,& + & 1.368600E+02,4.498300E+02,3.152200E+03,1.393100E+04,2.444000E+04,& + & 4.313600E+04,7.397700E+04,1.462864E+05,1.176300E+00,3.361700E+00,& + & 5.510200E+00,9.394700E+00,1.773600E+01,3.601900E+01,9.138400E+01,& + & 3.000500E+02,2.101700E+03,9.287500E+03,1.629400E+04,2.875700E+04,& + & 4.931800E+04,9.752388E+04,6.390500E-01,1.786600E+00,2.933200E+00,& + & 4.979500E+00,9.146300E+00,1.822300E+01,4.591600E+01,1.502600E+02,& + & 1.051100E+03,4.644000E+03,8.147300E+03,1.437900E+04,2.466000E+04,& + & 4.876339E+04,7.334000E-03,2.017000E-02,3.804200E-02,6.756400E-02,& + & 1.213600E-01,2.298100E-01,4.682500E-01,1.062500E+00,2.688800E+00,& + & 4.856500E+00,5.740700E+00,6.906700E+00,8.504900E+00,1.198446E+01/ + data absb(:,141:160) / & + & 2.466600E+00,6.700000E+00,1.085400E+01,1.926900E+01,3.646600E+01,& + & 7.492200E+01,1.876500E+02,6.221300E+02,4.242900E+03,1.815100E+04,& + & 3.189000E+04,5.647400E+04,9.767900E+04,1.943640E+05,1.911700E+00,& + & 5.116300E+00,8.239500E+00,1.454500E+01,2.745200E+01,5.628300E+01,& + & 1.408400E+02,4.667200E+02,3.182300E+03,1.361400E+04,2.391700E+04,& + & 4.235600E+04,7.326000E+04,1.457747E+05,1.331100E+00,3.508700E+00,& + & 5.652800E+00,9.836500E+00,1.844600E+01,3.764800E+01,9.403200E+01,& + & 3.113000E+02,2.121700E+03,9.076000E+03,1.594500E+04,2.823800E+04,& + & 4.884000E+04,9.718198E+04,7.200800E-01,1.860000E+00,3.014000E+00,& + & 5.190900E+00,9.500800E+00,1.903600E+01,4.722900E+01,1.558900E+02,& + & 1.061100E+03,4.538300E+03,7.972900E+03,1.411900E+04,2.442100E+04,& + & 4.859164E+04,8.131200E-03,2.165800E-02,4.032700E-02,7.094100E-02,& + & 1.262700E-01,2.351600E-01,4.732900E-01,1.059500E+00,2.649100E+00,& + & 4.761600E+00,5.639600E+00,6.794200E+00,8.308300E+00,1.148729E+01,& + & 2.771300E+00,6.946700E+00,1.122100E+01,2.018600E+01,3.795500E+01,& + & 7.860900E+01,1.940500E+02,6.447000E+02,4.297300E+03,1.771500E+04,& + & 3.115700E+04,5.540300E+04,9.661600E+04,1.932412E+05,2.141800E+00,& + & 5.301700E+00,8.511100E+00,1.523300E+01,2.856900E+01,5.904800E+01,& + & 1.456400E+02,4.836400E+02,3.223100E+03,1.328700E+04,2.336800E+04,& + & 4.155200E+04,7.246200E+04,1.449335E+05,1.486900E+00,3.633900E+00,& + & 5.833300E+00,1.029100E+01,1.918900E+01,3.949300E+01,9.722700E+01,& + & 3.225800E+02,2.148900E+03,8.857900E+03,1.557900E+04,2.770200E+04,& + & 4.830800E+04,9.662259E+04,8.012200E-01,1.924500E+00,3.112400E+00,& + & 5.411500E+00,9.861900E+00,1.995600E+01,4.882400E+01,1.615200E+02,& + & 1.074700E+03,4.429200E+03,7.789700E+03,1.385100E+04,2.415500E+04,& + & 4.831177E+04,8.852500E-03,2.299200E-02,4.241400E-02,7.416000E-02,& + & 1.310100E-01,2.405500E-01,4.770500E-01,1.055200E+00,2.612400E+00,& + & 4.638100E+00,5.468500E+00,6.647700E+00,8.125300E+00,1.104807E+01,& + & 1.061000E+00,3.660700E+00,6.820800E+00,1.120000E+01,2.172700E+01,& + & 4.535100E+01,1.172500E+02,3.905900E+02,2.875300E+03,1.356100E+04,& + & 2.464100E+04,4.568900E+04,8.312400E+04,1.754605E+05,8.436000E-01,& + & 2.839700E+00,5.215300E+00,8.506200E+00,1.639300E+01,3.411100E+01,& + & 8.804800E+01,2.930600E+02,2.156600E+03,1.017100E+04,1.848100E+04,& + & 3.426700E+04,6.234300E+04,1.315920E+05,5.980500E-01,1.983200E+00,& + & 3.595700E+00,5.867000E+00,1.108600E+01,2.287900E+01,5.885300E+01,& + & 1.955200E+02,1.437900E+03,6.780800E+03,1.232100E+04,2.284500E+04,& + & 4.156200E+04,8.773007E+04,3.317200E-01,1.081000E+00,1.922700E+00,& + & 3.183200E+00,5.876100E+00,1.174800E+01,2.967400E+01,9.799200E+01,& + & 7.192200E+02,3.390600E+03,6.160800E+03,1.142300E+04,2.078200E+04,& + & 4.386634E+04,4.749000E-03,1.429400E-02,2.826100E-02,5.217400E-02,& + & 9.681900E-02,1.906800E-01,4.124700E-01,1.002500E+00,2.796900E+00,& + & 5.404500E+00,6.563400E+00,7.975000E+00,1.003600E+01,1.441316E+01,& + & 1.251200E+00,3.988800E+00,6.875100E+00,1.170300E+01,2.261700E+01,& + & 4.678800E+01,1.208600E+02,4.054400E+02,2.895300E+03,1.330500E+04,& + & 2.416800E+04,4.487600E+04,8.243400E+04,1.754731E+05,9.888200E-01,& + & 3.082500E+00,5.262100E+00,8.880500E+00,1.706200E+01,3.518000E+01,& + & 9.075900E+01,3.042000E+02,2.171600E+03,9.979000E+03,1.812600E+04,& + & 3.365700E+04,6.182600E+04,1.316030E+05,6.981100E-01,2.142200E+00,& + & 3.637900E+00,6.109200E+00,1.153000E+01,2.358700E+01,6.065600E+01,& + & 2.029500E+02,1.447900E+03,6.652800E+03,1.208400E+04,2.243800E+04,& + & 4.121700E+04,8.773706E+04,3.852100E-01,1.156400E+00,1.956000E+00,& + & 3.312100E+00,6.089600E+00,1.208600E+01,3.056600E+01,1.017200E+02,& + & 7.242200E+02,3.326700E+03,6.042400E+03,1.122000E+04,2.060900E+04,& + & 4.386930E+04,5.453800E-03,1.570000E-02,3.038300E-02,5.528000E-02,& + & 1.014400E-01,1.972700E-01,4.166100E-01,1.001900E+00,2.781700E+00,& + & 5.311400E+00,6.459300E+00,7.827800E+00,9.788200E+00,1.404327E+01/ + data absb(:,161:180) / & + & 1.445100E+00,4.240300E+00,7.000600E+00,1.228900E+01,2.354300E+01,& + & 4.881900E+01,1.244000E+02,4.205600E+02,2.930200E+03,1.300100E+04,& + & 2.364600E+04,4.404000E+04,8.169200E+04,1.751367E+05,1.137000E+00,& + & 3.267800E+00,5.358800E+00,9.315300E+00,1.776000E+01,3.670400E+01,& + & 9.340300E+01,3.155400E+02,2.197800E+03,9.750700E+03,1.773500E+04,& + & 3.303000E+04,6.126900E+04,1.313511E+05,8.005600E-01,2.260400E+00,& + & 3.714500E+00,6.389700E+00,1.199800E+01,2.459600E+01,6.241300E+01,& + & 2.105200E+02,1.465400E+03,6.500600E+03,1.182300E+04,2.202100E+04,& + & 4.084700E+04,8.756954E+04,4.395900E-01,1.212900E+00,2.005400E+00,& + & 3.452000E+00,6.326000E+00,1.257100E+01,3.143800E+01,1.055000E+02,& + & 7.329500E+02,3.250600E+03,5.912000E+03,1.101100E+04,2.042400E+04,& + & 4.378467E+04,6.129100E-03,1.702600E-02,3.239400E-02,5.829800E-02,& + & 1.060500E-01,2.032200E-01,4.221300E-01,1.002500E+00,2.754800E+00,& + & 5.225000E+00,6.329200E+00,7.623700E+00,9.550500E+00,1.366435E+01,& + & 1.643700E+00,4.430400E+00,7.201600E+00,1.287900E+01,2.451200E+01,& + & 5.124300E+01,1.286400E+02,4.357600E+02,2.978200E+03,1.268700E+04,& + & 2.307700E+04,4.322700E+04,8.082100E+04,1.744126E+05,1.288300E+00,& + & 3.410500E+00,5.506900E+00,9.754900E+00,1.848800E+01,3.852300E+01,& + & 9.658700E+01,3.269300E+02,2.233800E+03,9.515500E+03,1.730800E+04,& + & 3.242000E+04,6.061600E+04,1.308047E+05,9.043700E-01,2.356200E+00,& + & 3.818000E+00,6.672700E+00,1.248300E+01,2.581000E+01,6.453200E+01,& + & 2.181100E+02,1.489400E+03,6.343800E+03,1.153900E+04,2.161400E+04,& + & 4.041100E+04,8.720562E+04,4.944400E-01,1.261100E+00,2.064900E+00,& + & 3.595100E+00,6.565300E+00,1.316500E+01,3.248900E+01,1.093000E+02,& + & 7.449400E+02,3.172200E+03,5.769700E+03,1.080700E+04,2.020600E+04,& + & 4.360316E+04,6.763500E-03,1.822300E-02,3.429300E-02,6.123000E-02,& + & 1.105500E-01,2.089500E-01,4.277900E-01,1.001200E+00,2.718900E+00,& + & 5.140700E+00,6.203400E+00,7.507000E+00,9.299500E+00,1.316453E+01,& + & 1.846700E+00,4.589200E+00,7.466200E+00,1.350900E+01,2.554800E+01,& + & 5.375900E+01,1.339600E+02,4.512600E+02,3.036000E+03,1.239400E+04,& + & 2.248900E+04,4.237400E+04,7.984400E+04,1.732079E+05,1.442500E+00,& + & 3.530500E+00,5.701800E+00,1.022800E+01,1.926500E+01,4.041100E+01,& + & 1.005700E+02,3.385600E+02,2.277100E+03,9.296000E+03,1.686700E+04,& + & 3.178100E+04,5.988300E+04,1.299958E+05,1.009900E+00,2.437600E+00,& + & 3.951800E+00,6.979700E+00,1.299800E+01,2.707100E+01,6.718100E+01,& + & 2.258600E+02,1.518300E+03,6.197500E+03,1.124500E+04,2.118700E+04,& + & 3.992200E+04,8.666332E+04,5.492900E-01,1.305200E+00,2.140300E+00,& + & 3.746100E+00,6.817000E+00,1.378400E+01,3.380700E+01,1.131700E+02,& + & 7.593900E+02,3.099100E+03,5.622600E+03,1.059400E+04,1.996200E+04,& + & 4.333246E+04,7.335300E-03,1.925000E-02,3.604700E-02,6.398700E-02,& + & 1.147800E-01,2.146800E-01,4.326000E-01,9.989900E-01,2.682900E+00,& + & 5.025100E+00,6.036900E+00,7.343000E+00,9.120400E+00,1.267393E+01,& + & 7.713300E-01,2.648400E+00,4.879400E+00,8.101700E+00,1.575600E+01,& + & 3.305000E+01,8.646800E+01,2.961700E+02,2.151700E+03,1.019500E+04,& + & 1.910600E+04,3.724600E+04,7.343400E+04,1.701204E+05,6.203200E-01,& + & 2.072500E+00,3.761600E+00,6.194000E+00,1.191600E+01,2.488500E+01,& + & 6.496400E+01,2.222400E+02,1.613900E+03,7.646600E+03,1.433000E+04,& + & 2.793500E+04,5.507600E+04,1.275961E+05,4.419700E-01,1.457600E+00,& + & 2.609900E+00,4.322300E+00,8.138300E+00,1.674100E+01,4.346700E+01,& + & 1.483100E+02,1.076100E+03,5.097900E+03,9.553300E+03,1.862300E+04,& + & 3.671700E+04,8.506308E+04,2.470700E-01,7.988700E-01,1.408200E+00,& + & 2.377300E+00,4.391400E+00,8.770000E+00,2.201700E+01,7.439200E+01,& + & 5.383300E+02,2.549200E+03,4.777000E+03,9.312200E+03,1.835900E+04,& + & 4.253129E+04,4.003200E-03,1.209500E-02,2.401000E-02,4.472500E-02,& + & 8.385300E-02,1.669500E-01,3.658200E-01,9.305900E-01,2.825100E+00,& + & 5.765200E+00,7.164600E+00,8.815300E+00,1.117300E+01,1.644298E+01/ + data absb(:,181:200) / & + & 9.074300E-01,2.872300E+00,4.922200E+00,8.481600E+00,1.643100E+01,& + & 3.434600E+01,8.902400E+01,3.071600E+02,2.181400E+03,9.963100E+03,& + & 1.868200E+04,3.655000E+04,7.278100E+04,1.700431E+05,7.250300E-01,& + & 2.237700E+00,3.800800E+00,6.473500E+00,1.242500E+01,2.585000E+01,& + & 6.687900E+01,2.304900E+02,1.636200E+03,7.472500E+03,1.401100E+04,& + & 2.741300E+04,5.458600E+04,1.275343E+05,5.146600E-01,1.563800E+00,& + & 2.647100E+00,4.509100E+00,8.472400E+00,1.737500E+01,4.473800E+01,& + & 1.538200E+02,1.091000E+03,4.981800E+03,9.341100E+03,1.827600E+04,& + & 3.639100E+04,8.502364E+04,2.862200E-01,8.485000E-01,1.436400E+00,& + & 2.477500E+00,4.562400E+00,9.066600E+00,2.263600E+01,7.715400E+01,& + & 5.457500E+02,2.491200E+03,4.670900E+03,9.138300E+03,1.819600E+04,& + & 4.251256E+04,4.571500E-03,1.325800E-02,2.579500E-02,4.740800E-02,& + & 8.810300E-02,1.732100E-01,3.713100E-01,9.321900E-01,2.812200E+00,& + & 5.680400E+00,7.040900E+00,8.653200E+00,1.091900E+01,1.602255E+01,& + & 1.047000E+00,3.043200E+00,5.024100E+00,8.897000E+00,1.712100E+01,& + & 3.603100E+01,9.194300E+01,3.181600E+02,2.224100E+03,9.729300E+03,& + & 1.822400E+04,3.584000E+04,7.207300E+04,1.695578E+05,8.326700E-01,& + & 2.362000E+00,3.881100E+00,6.779300E+00,1.294500E+01,2.711400E+01,& + & 6.906400E+01,2.387400E+02,1.668200E+03,7.297100E+03,1.366800E+04,& + & 2.688000E+04,5.405500E+04,1.271669E+05,5.891800E-01,1.643300E+00,& + & 2.710600E+00,4.707900E+00,8.817900E+00,1.821300E+01,4.618800E+01,& + & 1.593200E+02,1.112300E+03,4.864900E+03,9.112500E+03,1.792000E+04,& + & 3.603700E+04,8.477821E+04,3.260300E-01,8.874900E-01,1.475800E+00,& + & 2.579100E+00,4.742800E+00,9.466000E+00,2.334700E+01,7.990800E+01,& + & 5.564300E+02,2.432800E+03,4.556600E+03,8.960700E+03,1.801900E+04,& + & 4.238946E+04,5.112500E-03,1.432300E-02,2.748700E-02,5.002700E-02,& + & 9.225200E-02,1.792900E-01,3.776600E-01,9.337000E-01,2.789300E+00,& + & 5.609200E+00,6.886900E+00,8.439100E+00,1.067600E+01,1.559296E+01,& + & 1.190000E+00,3.176600E+00,5.182200E+00,9.325200E+00,1.784800E+01,& + & 3.786600E+01,9.573700E+01,3.295200E+02,2.275800E+03,9.522700E+03,& + & 1.773400E+04,3.514900E+04,7.122600E+04,1.687030E+05,9.422600E-01,& + & 2.462800E+00,3.998300E+00,7.095800E+00,1.349200E+01,2.849100E+01,& + & 7.190600E+01,2.472600E+02,1.706900E+03,7.142100E+03,1.330000E+04,& + & 2.636200E+04,5.341900E+04,1.265260E+05,6.648100E-01,1.711300E+00,& + & 2.794200E+00,4.913700E+00,9.177900E+00,1.913000E+01,4.808000E+01,& + & 1.650000E+02,1.138100E+03,4.761600E+03,8.867100E+03,1.757500E+04,& + & 3.561300E+04,8.435362E+04,3.660300E-01,9.223300E-01,1.525200E+00,& + & 2.685600E+00,4.926400E+00,9.904500E+00,2.428300E+01,8.274100E+01,& + & 5.693300E+02,2.381100E+03,4.433900E+03,8.787800E+03,1.780700E+04,& + & 4.217720E+04,5.614500E-03,1.525100E-02,2.907800E-02,5.253900E-02,& + & 9.622800E-02,1.851500E-01,3.841300E-01,9.343500E-01,2.757200E+00,& + & 5.528500E+00,6.755700E+00,8.299500E+00,1.040600E+01,1.504732E+01,& + & 1.336200E+00,3.289600E+00,5.393800E+00,9.805700E+00,1.860600E+01,& + & 3.971300E+01,1.003200E+02,3.415000E+02,2.333800E+03,9.362500E+03,& + & 1.724100E+04,3.440500E+04,7.032600E+04,1.674777E+05,1.053900E+00,& + & 2.549000E+00,4.154300E+00,7.454600E+00,1.406000E+01,2.987600E+01,& + & 7.534200E+01,2.562500E+02,1.750500E+03,7.022000E+03,1.293100E+04,& + & 2.580400E+04,5.274500E+04,1.256081E+05,7.413000E-01,1.771000E+00,& + & 2.903600E+00,5.145600E+00,9.552800E+00,2.005200E+01,5.036200E+01,& + & 1.709900E+02,1.167200E+03,4.681600E+03,8.621100E+03,1.720300E+04,& + & 3.516400E+04,8.373974E+04,4.058200E-01,9.555100E-01,1.587200E+00,& + & 2.802700E+00,5.113400E+00,1.035000E+01,2.541000E+01,8.574100E+01,& + & 5.838400E+02,2.341100E+03,4.310900E+03,8.601800E+03,1.758200E+04,& + & 4.187076E+04,6.069900E-03,1.604000E-02,3.045700E-02,5.491000E-02,& + & 9.999300E-02,1.906600E-01,3.904800E-01,9.347400E-01,2.724500E+00,& + & 5.399500E+00,6.602700E+00,8.116700E+00,1.020500E+01,1.448882E+01/ + data absb(:,201:220) / & + & 5.786600E-01,1.973700E+00,3.597600E+00,6.050100E+00,1.178700E+01,& + & 2.484400E+01,6.558000E+01,2.304200E+02,1.670000E+03,7.788500E+03,& + & 1.503900E+04,3.070900E+04,6.568400E+04,1.692828E+05,4.698600E-01,& + & 1.558900E+00,2.795700E+00,4.668800E+00,8.945900E+00,1.873100E+01,& + & 4.930000E+01,1.729300E+02,1.252600E+03,5.841500E+03,1.128000E+04,& + & 2.303200E+04,4.926300E+04,1.269615E+05,3.362100E-01,1.100500E+00,& + & 1.952500E+00,3.288400E+00,6.183600E+00,1.267300E+01,3.303000E+01,& + & 1.154400E+02,8.352600E+02,3.894500E+03,7.520000E+03,1.535500E+04,& + & 3.284300E+04,8.464186E+04,1.891700E-01,6.056400E-01,1.060200E+00,& + & 1.825400E+00,3.386100E+00,6.785100E+00,1.689600E+01,5.796500E+01,& + & 4.179000E+02,1.947500E+03,3.760400E+03,7.678000E+03,1.642200E+04,& + & 4.232135E+04,3.362100E-03,1.020200E-02,2.031000E-02,3.813600E-02,& + & 7.235300E-02,1.455300E-01,3.224800E-01,8.523500E-01,2.818800E+00,& + & 6.128000E+00,7.717000E+00,9.737200E+00,1.243700E+01,1.874440E+01,& + & 6.795000E-01,2.132400E+00,3.635600E+00,6.335700E+00,1.230300E+01,& + & 2.601200E+01,6.767900E+01,2.388000E+02,1.705800E+03,7.609200E+03,& + & 1.466000E+04,3.010800E+04,6.506000E+04,1.690035E+05,5.481100E-01,& + & 1.674300E+00,2.832100E+00,4.877900E+00,9.335400E+00,1.960000E+01,& + & 5.087000E+01,1.792200E+02,1.279500E+03,5.707100E+03,1.099500E+04,& + & 2.258100E+04,4.879500E+04,1.267556E+05,3.907200E-01,1.173600E+00,& + & 1.986700E+00,3.431200E+00,6.440100E+00,1.323900E+01,3.407200E+01,& + & 1.196400E+02,8.531800E+02,3.804900E+03,7.330600E+03,1.505500E+04,& + & 3.253100E+04,8.450183E+04,2.187700E-01,6.400400E-01,1.084600E+00,& + & 1.901100E+00,3.525400E+00,7.055700E+00,1.738600E+01,6.007000E+01,& + & 4.268600E+02,1.902700E+03,3.665700E+03,7.527700E+03,1.626600E+04,& + & 4.225244E+04,3.818300E-03,1.114600E-02,2.180300E-02,4.044100E-02,& + & 7.608400E-02,1.518000E-01,3.290200E-01,8.559900E-01,2.808700E+00,& + & 6.046700E+00,7.583500E+00,9.564500E+00,1.217500E+01,1.825761E+01,& + & 7.832600E-01,2.254300E+00,3.722200E+00,6.644900E+00,1.282600E+01,& + & 2.734700E+01,7.035300E+01,2.472100E+02,1.751000E+03,7.465800E+03,& + & 1.425300E+04,2.950900E+04,6.434700E+04,1.683454E+05,6.286900E-01,& + & 1.763000E+00,2.901100E+00,5.102900E+00,9.729200E+00,2.060200E+01,& + & 5.287200E+01,1.855300E+02,1.313400E+03,5.599500E+03,1.069000E+04,& + & 2.213200E+04,4.826100E+04,1.262584E+05,4.465800E-01,1.231300E+00,& + & 2.040100E+00,3.579200E+00,6.703400E+00,1.390000E+01,3.539800E+01,& + & 1.238500E+02,8.757800E+02,3.733200E+03,7.127000E+03,1.475500E+04,& + & 3.217400E+04,8.417128E+04,2.487300E-01,6.686500E-01,1.117500E+00,& + & 1.978500E+00,3.668100E+00,7.374300E+00,1.802200E+01,6.217700E+01,& + & 4.381600E+02,1.866900E+03,3.563900E+03,7.378000E+03,1.608800E+04,& + & 4.208664E+04,4.251200E-03,1.198100E-02,2.322700E-02,4.266000E-02,& + & 7.975000E-02,1.576700E-01,3.361700E-01,8.593800E-01,2.789900E+00,& + & 5.978200E+00,7.441300E+00,9.326700E+00,1.191300E+01,1.775259E+01,& + & 8.893300E-01,2.350800E+00,3.849700E+00,6.976200E+00,1.336700E+01,& + & 2.873400E+01,7.371000E+01,2.562200E+02,1.802900E+03,7.364700E+03,& + & 1.384800E+04,2.889200E+04,6.355100E+04,1.672821E+05,7.106300E-01,& + & 1.836000E+00,2.997200E+00,5.345500E+00,1.013600E+01,2.164300E+01,& + & 5.538400E+01,1.922900E+02,1.352300E+03,5.523700E+03,1.038700E+04,& + & 2.167000E+04,4.766400E+04,1.254600E+05,5.033400E-01,1.280900E+00,& + & 2.109800E+00,3.740400E+00,6.971400E+00,1.458600E+01,3.706700E+01,& + & 1.283500E+02,9.017300E+02,3.682600E+03,6.924600E+03,1.444700E+04,& + & 3.177600E+04,8.363833E+04,2.787200E-01,6.949700E-01,1.159300E+00,& + & 2.061700E+00,3.811100E+00,7.703700E+00,1.883300E+01,6.442600E+01,& + & 4.511300E+02,1.841600E+03,3.462700E+03,7.223800E+03,1.588900E+04,& + & 4.182035E+04,4.653200E-03,1.268600E-02,2.450500E-02,4.482300E-02,& + & 8.323300E-02,1.631900E-01,3.433700E-01,8.624100E-01,2.763200E+00,& + & 5.891100E+00,7.321400E+00,9.169000E+00,1.160200E+01,1.713632E+01/ + data absb(:,221:240) / & + & 9.979000E-01,2.431200E+00,4.021400E+00,7.352800E+00,1.395700E+01,& + & 3.013700E+01,7.737800E+01,2.665300E+02,1.860100E+03,7.292800E+03,& + & 1.347400E+04,2.824100E+04,6.269900E+04,1.658546E+05,7.939700E-01,& + & 1.898600E+00,3.125500E+00,5.623500E+00,1.057800E+01,2.269600E+01,& + & 5.812900E+01,2.000200E+02,1.395200E+03,5.469800E+03,1.010600E+04,& + & 2.118100E+04,4.702500E+04,1.243937E+05,5.601300E-01,1.325800E+00,& + & 2.200400E+00,3.922800E+00,7.261300E+00,1.528400E+01,3.888700E+01,& + & 1.335100E+02,9.303200E+02,3.646700E+03,6.737400E+03,1.412100E+04,& + & 3.135000E+04,8.292850E+04,3.084100E-01,7.201000E-01,1.211100E+00,& + & 2.156900E+00,3.958900E+00,8.040500E+00,1.971800E+01,6.700900E+01,& + & 4.654200E+02,1.823700E+03,3.369100E+03,7.060700E+03,1.567600E+04,& + & 4.146462E+04,5.018900E-03,1.329100E-02,2.555000E-02,4.687200E-02,& + & 8.647800E-02,1.683100E-01,3.509100E-01,8.667000E-01,2.732800E+00,& + & 5.766000E+00,7.172100E+00,8.967100E+00,1.136600E+01,1.650164E+01,& + & 4.503500E-01,1.515600E+00,2.720300E+00,4.640400E+00,9.071800E+00,& + & 1.924400E+01,5.099000E+01,1.834600E+02,1.340300E+03,6.047200E+03,& + & 1.192800E+04,2.548400E+04,5.899200E+04,1.714894E+05,3.683800E-01,& + & 1.206400E+00,2.131400E+00,3.618200E+00,6.924200E+00,1.453200E+01,& + & 3.836000E+01,1.377100E+02,1.005400E+03,4.535500E+03,8.945900E+03,& + & 1.911300E+04,4.424400E+04,1.286136E+05,2.644900E-01,8.527600E-01,& + & 1.496400E+00,2.569200E+00,4.836100E+00,9.929800E+00,2.574700E+01,& + & 9.196200E+01,6.704300E+02,3.023900E+03,5.964200E+03,1.274200E+04,& + & 2.949700E+04,8.574398E+04,1.496100E-01,4.703700E-01,8.178200E-01,& + & 1.432200E+00,2.678100E+00,5.412500E+00,1.339000E+01,4.624700E+01,& + & 3.354900E+02,1.512200E+03,2.982500E+03,6.371700E+03,1.474900E+04,& + & 4.287257E+04,2.837100E-03,8.625600E-03,1.720500E-02,3.249500E-02,& + & 6.230700E-02,1.270300E-01,2.835500E-01,7.717500E-01,2.777800E+00,& + & 6.438900E+00,8.253600E+00,1.068100E+01,1.381700E+01,2.126596E+01,& + & 5.271000E-01,1.629900E+00,2.758400E+00,4.864700E+00,9.461600E+00,& + & 2.022400E+01,5.293700E+01,1.899600E+02,1.379200E+03,5.945700E+03,& + & 1.158800E+04,2.496400E+04,5.837700E+04,1.709686E+05,4.285400E-01,& + & 1.288000E+00,2.168200E+00,3.782000E+00,7.218000E+00,1.526300E+01,& + & 3.981300E+01,1.425900E+02,1.034500E+03,4.459400E+03,8.691400E+03,& + & 1.872300E+04,4.378300E+04,1.282260E+05,3.064100E-01,9.043900E-01,& + & 1.528700E+00,2.680600E+00,5.037000E+00,1.040200E+01,2.670600E+01,& + & 9.522200E+01,6.898500E+02,2.973100E+03,5.794600E+03,1.248300E+04,& + & 2.918900E+04,8.548358E+04,1.724800E-01,4.950700E-01,8.396300E-01,& + & 1.490600E+00,2.791200E+00,5.651500E+00,1.382700E+01,4.788000E+01,& + & 3.452000E+02,1.486800E+03,2.897700E+03,6.241700E+03,1.459500E+04,& + & 4.274228E+04,3.203300E-03,9.365900E-03,1.845800E-02,3.444100E-02,& + & 6.557700E-02,1.328700E-01,2.908400E-01,7.775700E-01,2.771500E+00,& + & 6.353400E+00,8.135300E+00,1.049700E+01,1.352200E+01,2.068179E+01,& + & 6.062100E-01,1.716700E+00,2.835400E+00,5.107600E+00,9.859800E+00,& + & 2.127800E+01,5.547200E+01,1.968500E+02,1.424800E+03,5.884300E+03,& + & 1.126100E+04,2.442300E+04,5.772600E+04,1.700004E+05,4.902700E-01,& + & 1.352100E+00,2.229600E+00,3.957700E+00,7.516900E+00,1.605300E+01,& + & 4.171200E+01,1.477500E+02,1.068800E+03,4.413300E+03,8.446200E+03,& + & 1.831700E+04,4.329500E+04,1.274976E+05,3.493100E-01,9.470100E-01,& + & 1.574900E+00,2.798900E+00,5.239900E+00,1.091500E+01,2.796500E+01,& + & 9.866500E+01,7.126900E+02,2.942400E+03,5.631100E+03,1.221200E+04,& + & 2.886300E+04,8.499949E+04,1.954600E-01,5.166300E-01,8.685000E-01,& + & 1.552900E+00,2.906500E+00,5.905800E+00,1.441700E+01,4.959900E+01,& + & 3.566100E+02,1.471500E+03,2.815900E+03,6.106400E+03,1.443200E+04,& + & 4.250040E+04,3.550700E-03,1.000400E-02,1.959800E-02,3.634900E-02,& + & 6.875500E-02,1.381500E-01,2.986300E-01,7.836900E-01,2.755900E+00,& + & 6.304300E+00,8.004600E+00,1.023400E+01,1.321700E+01,2.008264E+01/ + data absb(:,241:260) / & + & 6.868700E-01,1.787600E+00,2.941500E+00,5.376700E+00,1.028500E+01,& + & 2.235900E+01,5.829500E+01,2.048100E+02,1.474900E+03,5.854300E+03,& + & 1.098100E+04,2.386900E+04,5.700300E+04,1.686559E+05,5.530200E-01,& + & 1.405900E+00,2.311100E+00,4.154700E+00,7.835500E+00,1.686400E+01,& + & 4.382200E+01,1.537300E+02,1.106300E+03,4.390900E+03,8.236200E+03,& + & 1.790200E+04,4.275300E+04,1.264964E+05,3.926800E-01,9.842100E-01,& + & 1.634600E+00,2.931600E+00,5.453100E+00,1.144300E+01,2.936200E+01,& + & 1.026500E+02,7.377000E+02,2.927400E+03,5.491100E+03,1.193500E+04,& + & 2.850200E+04,8.433153E+04,2.183600E-01,5.369000E-01,9.042600E-01,& + & 1.622600E+00,3.021300E+00,6.167600E+00,1.507900E+01,5.159100E+01,& + & 3.691100E+02,1.464000E+03,2.745900E+03,5.967800E+03,1.425200E+04,& + & 4.216543E+04,3.872100E-03,1.054100E-02,2.055900E-02,3.820000E-02,& + & 7.173200E-02,1.431500E-01,3.066800E-01,7.905200E-01,2.731600E+00,& + & 6.230900E+00,7.886800E+00,1.005900E+01,1.286400E+01,1.937180E+01,& + & 7.698600E-01,1.848200E+00,3.086700E+00,5.676300E+00,1.077400E+01,& + & 2.344800E+01,6.121500E+01,2.143800E+02,1.522300E+03,5.890600E+03,& + & 1.076700E+04,2.328600E+04,5.624200E+04,1.669355E+05,6.167600E-01,& + & 1.454000E+00,2.421200E+00,4.374700E+00,8.199400E+00,1.768300E+01,& + & 4.600500E+01,1.609100E+02,1.141800E+03,4.418100E+03,8.075600E+03,& + & 1.746500E+04,4.218200E+04,1.252034E+05,4.361900E-01,1.019000E+00,& + & 1.713400E+00,3.078900E+00,5.692400E+00,1.198000E+01,3.080700E+01,& + & 1.074500E+02,7.613800E+02,2.945600E+03,5.384000E+03,1.164300E+04,& + & 2.812100E+04,8.346827E+04,2.410500E-01,5.566700E-01,9.496000E-01,& + & 1.701200E+00,3.145400E+00,6.431600E+00,1.576600E+01,5.398900E+01,& + & 3.809400E+02,1.473200E+03,2.692400E+03,5.822100E+03,1.406100E+04,& + & 4.173482E+04,4.164400E-03,1.101200E-02,2.131100E-02,3.981400E-02,& + & 7.454400E-02,1.478000E-01,3.150100E-01,7.986500E-01,2.708800E+00,& + & 6.099300E+00,7.710300E+00,9.831500E+00,1.258100E+01,1.864904E+01,& + & 3.528800E-01,1.170100E+00,2.069500E+00,3.579500E+00,7.016200E+00,& + & 1.500300E+01,3.992800E+01,1.461900E+02,1.089100E+03,4.751200E+03,& + & 9.373800E+03,2.091800E+04,5.223400E+04,1.733540E+05,2.905900E-01,& + & 9.373500E-01,1.636900E+00,2.821100E+00,5.399800E+00,1.136100E+01,& + & 3.006400E+01,1.097600E+02,8.169800E+02,3.563500E+03,7.030500E+03,& + & 1.568800E+04,3.917600E+04,1.300137E+05,2.092900E-01,6.634400E-01,& + & 1.153200E+00,2.015300E+00,3.809800E+00,7.863100E+00,2.025100E+01,& + & 7.333300E+01,5.448400E+02,2.375800E+03,4.687300E+03,1.045900E+04,& + & 2.611800E+04,8.667577E+04,1.189600E-01,3.667200E-01,6.348500E-01,& + & 1.126300E+00,2.126200E+00,4.354400E+00,1.075300E+01,3.700900E+01,& + & 2.727000E+02,1.188200E+03,2.344100E+03,5.230200E+03,1.305900E+04,& + & 4.333858E+04,2.387800E-03,7.258500E-03,1.454400E-02,2.757100E-02,& + & 5.339700E-02,1.105300E-01,2.487500E-01,6.926900E-01,2.704100E+00,& + & 6.688800E+00,8.795700E+00,1.161400E+01,1.530100E+01,2.400513E+01,& + & 4.116500E-01,1.252600E+00,2.108000E+00,3.757700E+00,7.311800E+00,& + & 1.578800E+01,4.178300E+01,1.514600E+02,1.128300E+03,4.715100E+03,& + & 9.112000E+03,2.045100E+04,5.171900E+04,1.724991E+05,3.370300E-01,& + & 9.956000E-01,1.673000E+00,2.951300E+00,5.623100E+00,1.194600E+01,& + & 3.145000E+01,1.137100E+02,8.463700E+02,3.536500E+03,6.834200E+03,& + & 1.533900E+04,3.878900E+04,1.293753E+05,2.416900E-01,7.006600E-01,& + & 1.183300E+00,2.103500E+00,3.966500E+00,8.243400E+00,2.116000E+01,& + & 7.596900E+01,5.644300E+02,2.357800E+03,4.556400E+03,1.022600E+04,& + & 2.586000E+04,8.624945E+04,1.366800E-01,3.849700E-01,6.542300E-01,& + & 1.173200E+00,2.216100E+00,4.554100E+00,1.117300E+01,3.831200E+01,& + & 2.824900E+02,1.179200E+03,2.278600E+03,5.113500E+03,1.293100E+04,& + & 4.312605E+04,2.683000E-03,7.829800E-03,1.555700E-02,2.922200E-02,& + & 5.622100E-02,1.156400E-01,2.566200E-01,7.005800E-01,2.702700E+00,& + & 6.628900E+00,8.675000E+00,1.141700E+01,1.494300E+01,2.331847E+01/ + data absb(:,261:280) / & + & 4.721000E-01,1.315700E+00,2.174500E+00,3.953000E+00,7.625700E+00,& + & 1.660900E+01,4.395400E+01,1.575200E+02,1.170400E+03,4.715300E+03,& + & 8.911900E+03,1.996900E+04,5.114400E+04,1.712511E+05,3.844700E-01,& + & 1.042900E+00,1.726200E+00,3.093600E+00,5.858200E+00,1.256000E+01,& + & 3.307200E+01,1.182600E+02,8.779100E+02,3.536600E+03,6.684200E+03,& + & 1.497700E+04,3.835800E+04,1.284368E+05,2.747800E-01,7.324700E-01,& + & 1.223300E+00,2.201600E+00,4.130100E+00,8.638700E+00,2.222700E+01,& + & 7.900400E+01,5.854500E+02,2.357900E+03,4.456400E+03,9.984800E+03,& + & 2.557200E+04,8.562486E+04,1.543500E-01,4.015500E-01,6.794700E-01,& + & 1.225400E+00,2.309000E+00,4.760300E+00,1.167000E+01,3.981200E+01,& + & 2.930000E+02,1.179200E+03,2.228600E+03,4.992800E+03,1.278700E+04,& + & 4.281261E+04,2.961600E-03,8.320600E-03,1.641900E-02,3.087400E-02,& + & 5.890200E-02,1.203400E-01,2.650500E-01,7.099700E-01,2.690700E+00,& + & 6.588800E+00,8.566700E+00,1.112500E+01,1.458500E+01,2.261280E+01,& + & 5.341200E-01,1.368500E+00,2.264700E+00,4.170100E+00,7.974000E+00,& + & 1.744400E+01,4.623900E+01,1.649800E+02,1.211300E+03,4.775700E+03,& + & 8.769800E+03,1.948100E+04,5.053000E+04,1.695957E+05,4.329400E-01,& + & 1.083500E+00,1.797000E+00,3.252400E+00,6.118100E+00,1.318400E+01,& + & 3.477900E+01,1.238600E+02,9.086200E+02,3.582000E+03,6.577600E+03,& + & 1.461100E+04,3.789800E+04,1.271955E+05,3.081800E-01,7.611400E-01,& + & 1.275200E+00,2.309700E+00,4.306000E+00,9.042900E+00,2.335000E+01,& + & 8.274200E+01,6.059200E+02,2.388200E+03,4.385300E+03,9.740700E+03,& + & 2.526600E+04,8.479585E+04,1.720300E-01,4.171700E-01,7.108900E-01,& + & 1.283800E+00,2.403300E+00,4.969100E+00,1.219500E+01,4.166900E+01,& + & 3.032200E+02,1.194400E+03,2.193100E+03,4.870800E+03,1.263300E+04,& + & 4.239890E+04,3.219600E-03,8.738300E-03,1.712000E-02,3.233900E-02,& + & 6.150700E-02,1.247900E-01,2.735100E-01,7.208200E-01,2.673000E+00,& + & 6.510300E+00,8.443700E+00,1.094200E+01,1.417000E+01,2.178111E+01,& + & 5.975800E-01,1.414600E+00,2.382300E+00,4.412100E+00,8.385200E+00,& + & 1.831800E+01,4.855500E+01,1.738200E+02,1.250700E+03,4.878400E+03,& + & 8.706400E+03,1.899800E+04,4.985400E+04,1.675632E+05,4.816200E-01,& + & 1.120700E+00,1.887900E+00,3.431100E+00,6.421900E+00,1.384000E+01,& + & 3.650900E+01,1.304900E+02,9.381600E+02,3.659000E+03,6.530000E+03,& + & 1.424900E+04,3.739100E+04,1.256738E+05,3.414700E-01,7.881800E-01,& + & 1.341200E+00,2.431800E+00,4.508300E+00,9.468700E+00,2.448900E+01,& + & 8.717500E+01,6.256000E+02,2.439600E+03,4.353600E+03,9.499400E+03,& + & 2.492800E+04,8.378177E+04,1.892500E-01,4.330100E-01,7.490300E-01,& + & 1.349000E+00,2.510000E+00,5.186900E+00,1.272500E+01,4.388100E+01,& + & 3.130500E+02,1.220100E+03,2.177200E+03,4.750100E+03,1.246400E+04,& + & 4.189166E+04,3.451700E-03,9.103600E-03,1.767400E-02,3.349800E-02,& + & 6.398300E-02,1.289400E-01,2.819100E-01,7.324700E-01,2.659400E+00,& + & 6.375000E+00,8.249900E+00,1.069900E+01,1.382200E+01,2.094921E+01,& + & 2.755400E-01,8.994900E-01,1.569700E+00,2.749900E+00,5.394500E+00,& + & 1.164200E+01,3.119800E+01,1.154600E+02,8.858100E+02,3.766400E+03,& + & 7.281800E+03,1.682800E+04,4.523100E+04,1.728329E+05,2.284700E-01,& + & 7.246200E-01,1.253100E+00,2.192900E+00,4.195900E+00,8.864600E+00,& + & 2.351800E+01,8.671300E+01,6.645000E+02,2.824900E+03,5.461500E+03,& + & 1.262100E+04,3.392300E+04,1.296241E+05,1.650900E-01,5.135700E-01,& + & 8.863700E-01,1.571600E+00,2.988700E+00,6.218000E+00,1.596200E+01,& + & 5.797500E+01,4.431800E+02,1.883500E+03,3.641300E+03,8.414500E+03,& + & 2.261600E+04,8.641575E+04,9.430500E-02,2.847000E-01,4.913900E-01,& + & 8.820800E-01,1.676400E+00,3.489000E+00,8.666600E+00,2.948400E+01,& + & 2.218800E+02,9.419900E+02,1.821100E+03,4.207800E+03,1.130900E+04,& + & 4.320929E+04,2.005800E-03,6.078900E-03,1.225700E-02,2.332800E-02,& + & 4.556200E-02,9.564200E-02,2.181200E-01,6.173600E-01,2.602300E+00,& + & 6.893900E+00,9.304700E+00,1.252200E+01,1.682900E+01,2.695087E+01/ + data absb(:,281:300) / & + & 3.203800E-01,9.586700E-01,1.605500E+00,2.891200E+00,5.626300E+00,& + & 1.225000E+01,3.283600E+01,1.199700E+02,9.204000E+02,3.783300E+03,& + & 7.139800E+03,1.641500E+04,4.480700E+04,1.716772E+05,2.641100E-01,& + & 7.663900E-01,1.286400E+00,2.296100E+00,4.372300E+00,9.314300E+00,& + & 2.474200E+01,9.009600E+01,6.904400E+02,2.837600E+03,5.355100E+03,& + & 1.231100E+04,3.360600E+04,1.287607E+05,1.900300E-01,5.406300E-01,& + & 9.133200E-01,1.642200E+00,3.115300E+00,6.516400E+00,1.675200E+01,& + & 6.022900E+01,4.604700E+02,1.891900E+03,3.570300E+03,8.207900E+03,& + & 2.240400E+04,8.584068E+04,1.079300E-01,2.982900E-01,5.086600E-01,& + & 9.205200E-01,1.749100E+00,3.652500E+00,9.041200E+00,3.057400E+01,& + & 2.305200E+02,9.462600E+02,1.785600E+03,4.104400E+03,1.120300E+04,& + & 4.292095E+04,2.244000E-03,6.521800E-03,1.303100E-02,2.474700E-02,& + & 4.795300E-02,1.000700E-01,2.264200E-01,6.282200E-01,2.606000E+00,& + & 6.856000E+00,9.184400E+00,1.229900E+01,1.643400E+01,2.611934E+01,& + & 3.664400E-01,1.004200E+00,1.663100E+00,3.048900E+00,5.880300E+00,& + & 1.287800E+01,3.458600E+01,1.256000E+02,9.549600E+02,3.852400E+03,& + & 7.055100E+03,1.600500E+04,4.431900E+04,1.701511E+05,3.004900E-01,& + & 8.011400E-01,1.332900E+00,2.412700E+00,4.563200E+00,9.780000E+00,& + & 2.604700E+01,9.432400E+01,7.163500E+02,2.889500E+03,5.291600E+03,& + & 1.200400E+04,3.324000E+04,1.276136E+05,2.154300E-01,5.643600E-01,& + & 9.483400E-01,1.723100E+00,3.250500E+00,6.820700E+00,1.759700E+01,& + & 6.305100E+01,4.777500E+02,1.926500E+03,3.528000E+03,8.002700E+03,& + & 2.216000E+04,8.507632E+04,1.214800E-01,3.110000E-01,5.308600E-01,& + & 9.642600E-01,1.823600E+00,3.818400E+00,9.444500E+00,3.194600E+01,& + & 2.391400E+02,9.636100E+02,1.764400E+03,4.001800E+03,1.108100E+04,& + & 4.253922E+04,2.468800E-03,6.902900E-03,1.367000E-02,2.606700E-02,& + & 5.027200E-02,1.042300E-01,2.347500E-01,6.411800E-01,2.600500E+00,& + & 6.823300E+00,9.090600E+00,1.200400E+01,1.598100E+01,2.527485E+01,& + & 4.139400E-01,1.043100E+00,1.737400E+00,3.223100E+00,6.174000E+00,& + & 1.353400E+01,3.638800E+01,1.325100E+02,9.877600E+02,3.950300E+03,& + & 7.056100E+03,1.563200E+04,4.381300E+04,1.682021E+05,3.376100E-01,& + & 8.317900E-01,1.392300E+00,2.541200E+00,4.782000E+00,1.026700E+01,& + & 2.739000E+01,9.951500E+01,7.409400E+02,2.962900E+03,5.292300E+03,& + & 1.172400E+04,3.286000E+04,1.261522E+05,2.410000E-01,5.861900E-01,& + & 9.924500E-01,1.812000E+00,3.400800E+00,7.138700E+00,1.847000E+01,& + & 6.651700E+01,4.941300E+02,1.975500E+03,3.528400E+03,7.816400E+03,& + & 2.190700E+04,8.410195E+04,1.350000E-01,3.229900E-01,5.576400E-01,& + & 1.012800E+00,1.904800E+00,3.989300E+00,9.856700E+00,3.364600E+01,& + & 2.473300E+02,9.881100E+02,1.764600E+03,3.908600E+03,1.095400E+04,& + & 4.205185E+04,2.675400E-03,7.229500E-03,1.419400E-02,2.712400E-02,& + & 5.256100E-02,1.081800E-01,2.428900E-01,6.558300E-01,2.592200E+00,& + & 6.736400E+00,8.963900E+00,1.179600E+01,1.551900E+01,2.430186E+01,& + & 4.620500E-01,1.079000E+00,1.832700E+00,3.414900E+00,6.513600E+00,& + & 1.425500E+01,3.823700E+01,1.403900E+02,1.019600E+03,4.050000E+03,& + & 7.120000E+03,1.535000E+04,4.322900E+04,1.659319E+05,3.745900E-01,& + & 8.613800E-01,1.467100E+00,2.684400E+00,5.030300E+00,1.080600E+01,& + & 2.877200E+01,1.054200E+02,7.647900E+02,3.037700E+03,5.340200E+03,& + & 1.151300E+04,3.242200E+04,1.244465E+05,2.662600E-01,6.079100E-01,& + & 1.046700E+00,1.911500E+00,3.567900E+00,7.490500E+00,1.937000E+01,& + & 7.046700E+01,5.100100E+02,2.025400E+03,3.560400E+03,7.675500E+03,& + & 2.161500E+04,8.296483E+04,1.479800E-01,3.358800E-01,5.889000E-01,& + & 1.066300E+00,1.995200E+00,4.173700E+00,1.028100E+01,3.560000E+01,& + & 2.552500E+02,1.013000E+03,1.780600E+03,3.838100E+03,1.080800E+04,& + & 4.148329E+04,2.859700E-03,7.512000E-03,1.461100E-02,2.790600E-02,& + & 5.458000E-02,1.119000E-01,2.509600E-01,6.704500E-01,2.591400E+00,& + & 6.586100E+00,8.759700E+00,1.153200E+01,1.511800E+01,2.331223E+01/ + data absb(:,301:320) / & + & 2.183100E-01,7.011200E-01,1.208600E+00,2.143200E+00,4.205000E+00,& + & 9.147500E+00,2.476500E+01,9.233500E+01,7.303500E+02,3.070500E+03,& + & 5.782900E+03,1.351700E+04,3.908400E+04,1.730172E+05,1.821100E-01,& + & 5.671500E-01,9.730900E-01,1.727700E+00,3.309100E+00,7.024100E+00,& + & 1.870100E+01,6.936600E+01,5.479000E+02,2.303000E+03,4.337400E+03,& + & 1.013800E+04,2.931400E+04,1.297666E+05,1.319700E-01,4.023300E-01,& + & 6.915500E-01,1.239300E+00,2.372400E+00,4.988000E+00,1.283900E+01,& + & 4.642800E+01,3.654500E+02,1.535600E+03,2.891800E+03,6.759000E+03,& + & 1.954300E+04,8.651054E+04,7.567200E-02,2.236900E-01,3.856800E-01,& + & 6.991200E-01,1.335900E+00,2.823400E+00,7.104400E+00,2.392100E+01,& + & 1.830200E+02,7.680800E+02,1.446300E+03,3.380000E+03,9.771900E+03,& + & 4.325572E+04,1.684800E-03,5.076300E-03,1.028100E-02,1.970700E-02,& + & 3.873400E-02,8.235300E-02,1.911800E-01,5.485700E-01,2.480600E+00,& + & 7.035200E+00,9.753100E+00,1.337800E+01,1.839700E+01,3.001425E+01,& + & 2.530000E-01,7.435000E-01,1.242000E+00,2.258000E+00,4.393500E+00,& + & 9.619400E+00,2.611700E+01,9.653300E+01,7.593200E+02,3.136800E+03,& + & 5.741600E+03,1.317600E+04,3.873400E+04,1.715897E+05,2.097700E-01,& + & 5.976400E-01,1.003500E+00,1.812400E+00,3.453700E+00,7.370500E+00,& + & 1.970800E+01,7.251800E+01,5.696300E+02,2.352700E+03,4.306400E+03,& + & 9.882600E+03,2.905000E+04,1.286892E+05,1.513900E-01,4.225000E-01,& + & 7.152800E-01,1.298300E+00,2.478300E+00,5.223600E+00,1.348100E+01,& + & 4.852400E+01,3.799300E+02,1.568700E+03,2.871200E+03,6.588700E+03,& + & 1.936700E+04,8.579213E+04,8.622900E-02,2.340400E-01,4.010900E-01,& + & 7.318600E-01,1.395500E+00,2.955600E+00,7.424800E+00,2.491100E+01,& + & 1.902500E+02,7.847200E+02,1.436000E+03,3.294800E+03,9.684200E+03,& + & 4.289694E+04,1.877000E-03,5.422200E-03,1.085700E-02,2.086200E-02,& + & 4.078500E-02,8.620800E-02,1.992300E-01,5.630100E-01,2.489500E+00,& + & 7.031000E+00,9.633300E+00,1.315000E+01,1.793000E+01,2.900805E+01,& + & 2.886100E-01,7.771000E-01,1.290600E+00,2.386200E+00,4.609000E+00,& + & 1.011800E+01,2.751800E+01,1.018600E+02,7.866500E+02,3.229900E+03,& + & 5.770300E+03,1.290000E+04,3.835900E+04,1.697255E+05,2.380900E-01,& + & 6.234900E-01,1.043300E+00,1.909000E+00,3.616900E+00,7.735600E+00,& + & 2.074900E+01,7.652100E+01,5.901200E+02,2.422600E+03,4.327900E+03,& + & 9.675300E+03,2.877000E+04,1.272966E+05,1.710900E-01,4.404800E-01,& + & 7.456600E-01,1.365700E+00,2.594400E+00,5.468400E+00,1.414500E+01,& + & 5.119100E+01,3.935900E+02,1.615300E+03,2.885500E+03,6.450500E+03,& + & 1.918000E+04,8.486501E+04,9.677800E-02,2.436900E-01,4.204200E-01,& + & 7.685600E-01,1.460000E+00,3.092200E+00,7.754500E+00,2.618800E+01,& + & 1.970700E+02,8.080300E+02,1.443200E+03,3.225700E+03,9.590700E+03,& + & 4.243258E+04,2.056700E-03,5.719500E-03,1.133900E-02,2.183400E-02,& + & 4.281700E-02,8.988200E-02,2.070400E-01,5.792500E-01,2.492100E+00,& + & 7.007400E+00,9.557500E+00,1.285800E+01,1.738700E+01,2.798092E+01,& + & 3.255900E-01,8.061900E-01,1.353300E+00,2.526800E+00,4.857100E+00,& + & 1.066200E+01,2.894800E+01,1.080800E+02,8.132800E+02,3.329100E+03,& + & 5.852800E+03,1.271900E+04,3.793000E+04,1.675289E+05,2.668600E-01,& + & 6.473700E-01,1.094100E+00,2.014900E+00,3.801200E+00,8.137100E+00,& + & 2.181400E+01,8.119300E+01,6.100700E+02,2.497000E+03,4.389800E+03,& + & 9.539200E+03,2.844800E+04,1.256466E+05,1.909600E-01,4.575300E-01,& + & 7.833900E-01,1.440300E+00,2.722700E+00,5.735700E+00,1.482500E+01,& + & 5.431500E+01,4.068800E+02,1.664900E+03,2.926800E+03,6.359700E+03,& + & 1.896500E+04,8.376531E+04,1.071900E-01,2.533400E-01,4.430800E-01,& + & 8.096800E-01,1.530400E+00,3.238200E+00,8.089200E+00,2.769300E+01,& + & 2.037000E+02,8.328200E+02,1.463800E+03,3.180300E+03,9.483200E+03,& + & 4.188274E+04,2.223000E-03,5.974400E-03,1.173700E-02,2.256700E-02,& + & 4.465800E-02,9.340700E-02,2.147500E-01,5.961500E-01,2.496900E+00,& + & 6.913800E+00,9.432000E+00,1.262800E+01,1.687300E+01,2.681908E+01/ + data absb(:,321:340) / & + & 3.621700E-01,8.353100E-01,1.431500E+00,2.678200E+00,5.137900E+00,& + & 1.127900E+01,3.045900E+01,1.147500E+02,8.395600E+02,3.433400E+03,& + & 5.994600E+03,1.262300E+04,3.746700E+04,1.649730E+05,2.951100E-01,& + & 6.714700E-01,1.156300E+00,2.129000E+00,4.007100E+00,8.594700E+00,& + & 2.294300E+01,8.619500E+01,6.297900E+02,2.575300E+03,4.496100E+03,& + & 9.467200E+03,2.810000E+04,1.237305E+05,2.101300E-01,4.754500E-01,& + & 8.286800E-01,1.519600E+00,2.865800E+00,6.037700E+00,1.555100E+01,& + & 5.765200E+01,4.200100E+02,1.717100E+03,2.997700E+03,6.311700E+03,& + & 1.873400E+04,8.248801E+04,1.170700E-01,2.639100E-01,4.685500E-01,& + & 8.534400E-01,1.609100E+00,3.401500E+00,8.440900E+00,2.931800E+01,& + & 2.102500E+02,8.588900E+02,1.499300E+03,3.156200E+03,9.367500E+03,& + & 4.124329E+04,2.367800E-03,6.195100E-03,1.205400E-02,2.312000E-02,& + & 4.610600E-02,9.677000E-02,2.224000E-01,6.128900E-01,2.508500E+00,& + & 6.783600E+00,9.204800E+00,1.234200E+01,1.640000E+01,2.566566E+01,& + & 1.763900E-01,5.560500E-01,9.486700E-01,1.702100E+00,3.339300E+00,& + & 7.311200E+00,1.999700E+01,7.530900E+01,6.110000E+02,2.597300E+03,& + & 4.754700E+03,1.091700E+04,3.389000E+04,1.745835E+05,1.478600E-01,& + & 4.511800E-01,7.698700E-01,1.384400E+00,2.659000E+00,5.672500E+00,& + & 1.514500E+01,5.659900E+01,4.583800E+02,1.948100E+03,3.566200E+03,& + & 8.187700E+03,2.541800E+04,1.309421E+05,1.073500E-01,3.203900E-01,& + & 5.492900E-01,9.941000E-01,1.912600E+00,4.068900E+00,1.054100E+01,& + & 3.796300E+01,3.057700E+02,1.299000E+03,2.377700E+03,5.458800E+03,& + & 1.694600E+04,8.729517E+04,6.168000E-02,1.785500E-01,3.078800E-01,& + & 5.635800E-01,1.081200E+00,2.312300E+00,5.920300E+00,1.991100E+01,& + & 1.531900E+02,6.498600E+02,1.189200E+03,2.729900E+03,8.473400E+03,& + & 4.364732E+04,1.416700E-03,4.234600E-03,8.582700E-03,1.661000E-02,& + & 3.287200E-02,7.064000E-02,1.673400E-01,4.883200E-01,2.344200E+00,& + & 7.130100E+00,1.012700E+01,1.421300E+01,1.992000E+01,3.309137E+01,& + & 2.037300E-01,5.868300E-01,9.795700E-01,1.796700E+00,3.499800E+00,& + & 7.695000E+00,2.109800E+01,7.940200E+01,6.340600E+02,2.680900E+03,& + & 4.796900E+03,1.071100E+04,3.362100E+04,1.728587E+05,1.697200E-01,& + & 4.739200E-01,7.972100E-01,1.455800E+00,2.784000E+00,5.953500E+00,& + & 1.595800E+01,5.967200E+01,4.756800E+02,2.010900E+03,3.597900E+03,& + & 8.033200E+03,2.521600E+04,1.296409E+05,1.227100E-01,3.356600E-01,& + & 5.705000E-01,1.044600E+00,2.004200E+00,4.263400E+00,1.106000E+01,& + & 3.999500E+01,3.173000E+02,1.340800E+03,2.398900E+03,5.355700E+03,& + & 1.681100E+04,8.642927E+04,7.000800E-02,1.864700E-01,3.218900E-01,& + & 5.916300E-01,1.132200E+00,2.422700E+00,6.192900E+00,2.086300E+01,& + & 1.589300E+02,6.707800E+02,1.199900E+03,2.678300E+03,8.406000E+03,& + & 4.321446E+04,1.571200E-03,4.504200E-03,9.022500E-03,1.747800E-02,& + & 3.465500E-02,7.401000E-02,1.747100E-01,5.053100E-01,2.361800E+00,& + & 7.154600E+00,1.001400E+01,1.397900E+01,1.938200E+01,3.186726E+01,& + & 2.318900E-01,6.122900E-01,1.020900E+00,1.902900E+00,3.683900E+00,& + & 8.106600E+00,2.223800E+01,8.436500E+01,6.565800E+02,2.774800E+03,& + & 4.891600E+03,1.060200E+04,3.333200E+04,1.707162E+05,1.921800E-01,& + & 4.938000E-01,8.319800E-01,1.536600E+00,2.924400E+00,6.253800E+00,& + & 1.680200E+01,6.340300E+01,4.925500E+02,2.081300E+03,3.668900E+03,& + & 7.951400E+03,2.499900E+04,1.280361E+05,1.383000E-01,3.497200E-01,& + & 5.969900E-01,1.101500E+00,2.104400E+00,4.471900E+00,1.159400E+01,& + & 4.247200E+01,3.285400E+02,1.387800E+03,2.446200E+03,5.301200E+03,& + & 1.666700E+04,8.535819E+04,7.835100E-02,1.940400E-01,3.386200E-01,& + & 6.231400E-01,1.189200E+00,2.538700E+00,6.472700E+00,2.202900E+01,& + & 1.645500E+02,6.942600E+02,1.223500E+03,2.651000E+03,8.333800E+03,& + & 4.267873E+04,1.715500E-03,4.738200E-03,9.390800E-03,1.816800E-02,& + & 3.628900E-02,7.727100E-02,1.819600E-01,5.235700E-01,2.377000E+00,& + & 7.135900E+00,9.956700E+00,1.367700E+01,1.874000E+01,3.063213E+01/ + data absb(:,341:360) / & + & 2.609600E-01,6.348800E-01,1.074200E+00,2.016700E+00,3.897100E+00,& + & 8.579400E+00,2.340700E+01,8.975100E+01,6.791500E+02,2.865600E+03,& + & 5.033900E+03,1.060400E+04,3.300200E+04,1.682255E+05,2.147800E-01,& + & 5.128100E-01,8.756100E-01,1.624000E+00,3.083400E+00,6.601400E+00,& + & 1.766800E+01,6.744700E+01,5.094800E+02,2.149400E+03,3.775600E+03,& + & 7.953500E+03,2.475200E+04,1.261718E+05,1.538800E-01,3.634300E-01,& + & 6.295100E-01,1.163300E+00,2.216500E+00,4.708600E+00,1.214100E+01,& + & 4.516900E+01,3.398100E+02,1.433200E+03,2.517400E+03,5.302600E+03,& + & 1.650100E+04,8.411344E+04,8.643700E-02,2.020600E-01,3.577600E-01,& + & 6.575800E-01,1.251400E+00,2.668600E+00,6.759600E+00,2.330700E+01,& + & 1.701600E+02,7.169400E+02,1.259100E+03,2.651700E+03,8.251200E+03,& + & 4.205733E+04,1.848200E-03,4.937300E-03,9.695200E-03,1.869500E-02,& + & 3.761400E-02,8.045000E-02,1.892100E-01,5.416500E-01,2.396400E+00,& + & 7.038800E+00,9.843000E+00,1.341000E+01,1.817600E+01,2.926215E+01,& + & 2.892100E-01,6.588600E-01,1.141000E+00,2.138600E+00,4.126600E+00,& + & 9.109900E+00,2.469800E+01,9.543200E+01,7.024700E+02,2.955400E+03,& + & 5.188100E+03,1.073000E+04,3.265600E+04,1.653893E+05,2.365800E-01,& + & 5.329800E-01,9.290700E-01,1.716900E+00,3.254200E+00,6.990900E+00,& + & 1.862900E+01,7.170800E+01,5.269600E+02,2.216700E+03,3.891300E+03,& + & 8.047700E+03,2.449200E+04,1.240450E+05,1.686400E-01,3.784700E-01,& + & 6.683700E-01,1.228400E+00,2.337900E+00,4.973500E+00,1.274900E+01,& + & 4.800500E+01,3.514600E+02,1.478000E+03,2.594400E+03,5.365400E+03,& + & 1.632800E+04,8.269665E+04,9.401600E-02,2.109200E-01,3.790700E-01,& + & 6.940000E-01,1.319900E+00,2.815800E+00,7.065400E+00,2.465700E+01,& + & 1.759800E+02,7.393600E+02,1.297600E+03,2.683100E+03,8.164600E+03,& + & 4.134806E+04,1.962800E-03,5.111200E-03,9.934500E-03,1.909600E-02,& + & 3.853500E-02,8.338000E-02,1.964800E-01,5.601800E-01,2.422200E+00,& + & 6.930900E+00,9.587900E+00,1.309900E+01,1.762000E+01,2.792595E+01,& + & 1.481600E-01,4.576600E-01,7.755800E-01,1.405700E+00,2.758700E+00,& + & 6.074400E+00,1.675600E+01,6.403600E+01,5.284400E+02,2.304000E+03,& + & 4.143400E+03,9.174900E+03,3.016600E+04,1.815038E+05,1.244600E-01,& + & 3.719400E-01,6.332400E-01,1.150000E+00,2.218600E+00,4.760600E+00,& + & 1.274500E+01,4.814700E+01,3.964600E+02,1.728200E+03,3.107800E+03,& + & 6.881400E+03,2.262400E+04,1.361281E+05,9.038100E-02,2.641800E-01,& + & 4.527900E-01,8.266300E-01,1.597100E+00,3.436800E+00,8.978000E+00,& + & 3.240500E+01,2.644900E+02,1.152400E+03,2.072100E+03,4.587900E+03,& + & 1.508300E+04,9.075321E+04,5.188400E-02,1.472800E-01,2.546800E-01,& + & 4.700900E-01,9.046700E-01,1.953400E+00,5.090600E+00,1.731000E+01,& + & 1.325900E+02,5.765700E+02,1.036500E+03,2.294400E+03,7.542300E+03,& + & 4.537669E+04,1.190500E-03,3.526600E-03,7.141400E-03,1.392500E-02,& + & 2.786300E-02,6.040400E-02,1.459600E-01,4.358400E-01,2.203200E+00,& + & 7.180500E+00,1.043800E+01,1.500000E+01,2.137600E+01,3.608948E+01,& + & 1.705200E-01,4.811600E-01,8.037400E-01,1.487900E+00,2.901200E+00,& + & 6.401000E+00,1.768200E+01,6.809800E+01,5.478900E+02,2.393800E+03,& + & 4.244900E+03,9.115700E+03,2.999600E+04,1.793961E+05,1.424300E-01,& + & 3.897100E-01,6.579300E-01,1.213200E+00,2.331700E+00,4.999600E+00,& + & 1.342200E+01,5.119800E+01,4.110500E+02,1.795600E+03,3.183900E+03,& + & 6.837000E+03,2.249700E+04,1.345471E+05,1.029700E-01,2.762700E-01,& + & 4.721900E-01,8.712800E-01,1.679300E+00,3.606400E+00,9.416700E+00,& + & 3.440600E+01,2.742100E+02,1.197300E+03,2.122900E+03,4.558300E+03,& + & 1.499800E+04,8.969795E+04,5.870800E-02,1.535900E-01,2.674600E-01,& + & 4.947600E-01,9.514800E-01,2.049500E+00,5.332000E+00,1.825000E+01,& + & 1.374200E+02,5.990200E+02,1.061900E+03,2.279600E+03,7.499800E+03,& + & 4.484959E+04,1.315300E-03,3.738800E-03,7.483200E-03,1.455200E-02,& + & 2.931000E-02,6.339100E-02,1.526300E-01,4.542000E-01,2.233100E+00,& + & 7.226500E+00,1.037500E+01,1.470600E+01,2.076300E+01,3.462244E+01/ + data absb(:,361:380) / & + & 1.936900E-01,5.014100E-01,8.400200E-01,1.576900E+00,3.065300E+00,& + & 6.771200E+00,1.863900E+01,7.262300E+01,5.677800E+02,2.477600E+03,& + & 4.381400E+03,9.187300E+03,2.978700E+04,1.769085E+05,1.608500E-01,& + & 4.059200E-01,6.887400E-01,1.282100E+00,2.457700E+00,5.271300E+00,& + & 1.412300E+01,5.460200E+01,4.259500E+02,1.858400E+03,3.286300E+03,& + & 6.890700E+03,2.234100E+04,1.326828E+05,1.157500E-01,2.877900E-01,& + & 4.956700E-01,9.203600E-01,1.769400E+00,3.797900E+00,9.865300E+00,& + & 3.665600E+01,2.841400E+02,1.239200E+03,2.191100E+03,4.594100E+03,& + & 1.489400E+04,8.845432E+04,6.549300E-02,1.598900E-01,2.820300E-01,& + & 5.222900E-01,1.002600E+00,2.155600E+00,5.581400E+00,1.930300E+01,& + & 1.423600E+02,6.199600E+02,1.096000E+03,2.297500E+03,7.447600E+03,& + & 4.422865E+04,1.430900E-03,3.922000E-03,7.767400E-03,1.505900E-02,& + & 3.050000E-02,6.629300E-02,1.594600E-01,4.732600E-01,2.262300E+00,& + & 7.216000E+00,1.031400E+01,1.443100E+01,2.001500E+01,3.316024E+01,& + & 2.172900E-01,5.199800E-01,8.879800E-01,1.673400E+00,3.249100E+00,& + & 7.198600E+00,1.967200E+01,7.744300E+01,5.885000E+02,2.559200E+03,& + & 4.534400E+03,9.384000E+03,2.958100E+04,1.740465E+05,1.792300E-01,& + & 4.217100E-01,7.282700E-01,1.357600E+00,2.596800E+00,5.584600E+00,& + & 1.488400E+01,5.821700E+01,4.414900E+02,1.919600E+03,3.401000E+03,& + & 7.038200E+03,2.218600E+04,1.305382E+05,1.283400E-01,2.994000E-01,& + & 5.248300E-01,9.738800E-01,1.869600E+00,4.015300E+00,1.034900E+01,& + & 3.905000E+01,2.944900E+02,1.279900E+03,2.267600E+03,4.692400E+03,& + & 1.479100E+04,8.702669E+04,7.195100E-02,1.668000E-01,2.986600E-01,& + & 5.522400E-01,1.059300E+00,2.277200E+00,5.843300E+00,2.042600E+01,& + & 1.475100E+02,6.403100E+02,1.134200E+03,2.346700E+03,7.396200E+03,& + & 4.351327E+04,1.537000E-03,4.080300E-03,7.999300E-03,1.544800E-02,& + & 3.138900E-02,6.900700E-02,1.664100E-01,4.923900E-01,2.300900E+00,& + & 7.101900E+00,1.017800E+01,1.413700E+01,1.940700E+01,3.155098E+01,& + & 2.399400E-01,5.404900E-01,9.467000E-01,1.776100E+00,3.444300E+00,& + & 7.675500E+00,2.085300E+01,8.232100E+01,6.109000E+02,2.634400E+03,& + & 4.703500E+03,9.648800E+03,2.940600E+04,1.708871E+05,1.966300E-01,& + & 4.392600E-01,7.758500E-01,1.436400E+00,2.743200E+00,5.935700E+00,& + & 1.575900E+01,6.187500E+01,4.582900E+02,1.976000E+03,3.527800E+03,& + & 7.236800E+03,2.205500E+04,1.281690E+05,1.401500E-01,3.124100E-01,& + & 5.589000E-01,1.029700E+00,1.975200E+00,4.258500E+00,1.090200E+01,& + & 4.147600E+01,3.056700E+02,1.317600E+03,2.352100E+03,4.824900E+03,& + & 1.470300E+04,8.544478E+04,7.796800E-02,1.744500E-01,3.172200E-01,& + & 5.835100E-01,1.120400E+00,2.412700E+00,6.133300E+00,2.155700E+01,& + & 1.530900E+02,6.591400E+02,1.176400E+03,2.412900E+03,7.352200E+03,& + & 4.272319E+04,1.626500E-03,4.217100E-03,8.181000E-03,1.574100E-02,& + & 3.199400E-02,7.124700E-02,1.734500E-01,5.119200E-01,2.338200E+00,& + & 7.053300E+00,9.918400E+00,1.377500E+01,1.877000E+01,3.001058E+01,& + & 1.278600E-01,3.865600E-01,6.524700E-01,1.194400E+00,2.346100E+00,& + & 5.186600E+00,1.440500E+01,5.623400E+01,4.682600E+02,2.101600E+03,& + & 3.771200E+03,8.030700E+03,2.732600E+04,1.923375E+05,1.074300E-01,& + & 3.144000E-01,5.350500E-01,9.809200E-01,1.901900E+00,4.103300E+00,& + & 1.101600E+01,4.229900E+01,3.513300E+02,1.576400E+03,2.828700E+03,& + & 6.023200E+03,2.049500E+04,1.442542E+05,7.794700E-02,2.232200E-01,& + & 3.830900E-01,7.055500E-01,1.368400E+00,2.972400E+00,7.839500E+00,& + & 2.859700E+01,2.344000E+02,1.051200E+03,1.886100E+03,4.015800E+03,& + & 1.366400E+04,9.617023E+04,4.462400E-02,1.243100E-01,2.160600E-01,& + & 4.014800E-01,7.760100E-01,1.687800E+00,4.469100E+00,1.553100E+01,& + & 1.176300E+02,5.259700E+02,9.435100E+02,2.008300E+03,6.832400E+03,& + & 4.808475E+04,1.000100E-03,2.934100E-03,5.931300E-03,1.160700E-02,& + & 2.353400E-02,5.157100E-02,1.269000E-01,3.895800E-01,2.068000E+00,& + & 7.194300E+00,1.068800E+01,1.571100E+01,2.273200E+01,3.891888E+01/ + data absb(:,381:400) / & + & 1.466800E-01,4.053900E-01,6.780500E-01,1.266900E+00,2.476000E+00,& + & 5.486100E+00,1.520600E+01,6.008800E+01,4.859000E+02,2.183200E+03,& + & 3.903200E+03,8.144600E+03,2.723600E+04,1.898437E+05,1.226200E-01,& + & 3.288800E-01,5.576500E-01,1.037700E+00,2.005900E+00,4.323900E+00,& + & 1.159400E+01,4.519900E+01,3.645400E+02,1.637600E+03,2.927600E+03,& + & 6.108700E+03,2.042800E+04,1.423802E+05,8.853300E-02,2.332100E-01,& + & 4.008800E-01,7.457700E-01,1.443900E+00,3.130500E+00,8.223600E+00,& + & 3.048600E+01,2.432100E+02,1.092000E+03,1.952000E+03,4.072700E+03,& + & 1.361900E+04,9.492047E+04,5.035000E-02,1.295200E-01,2.276300E-01,& + & 4.238600E-01,8.194400E-01,1.776500E+00,4.690700E+00,1.643000E+01,& + & 1.219700E+02,5.463700E+02,9.764400E+02,2.036800E+03,6.810000E+03,& + & 4.746040E+04,1.100700E-03,3.100800E-03,6.196400E-03,1.207300E-02,& + & 2.461100E-02,5.421900E-02,1.331000E-01,4.086500E-01,2.110000E+00,& + & 7.256200E+00,1.067900E+01,1.538400E+01,2.204100E+01,3.718710E+01,& + & 1.662400E-01,4.220800E-01,7.113800E-01,1.343400E+00,2.623500E+00,& + & 5.832000E+00,1.605500E+01,6.420600E+01,5.044500E+02,2.262600E+03,& + & 4.057100E+03,8.378400E+03,2.717400E+04,1.869241E+05,1.380900E-01,& + & 3.425600E-01,5.860200E-01,1.098200E+00,2.120900E+00,4.579500E+00,& + & 1.221000E+01,4.829200E+01,3.784600E+02,1.697100E+03,3.043000E+03,& + & 6.284100E+03,2.038100E+04,1.401947E+05,9.925900E-02,2.429100E-01,& + & 4.223400E-01,7.891600E-01,1.526800E+00,3.313000E+00,8.624800E+00,& + & 3.251500E+01,2.524700E+02,1.131600E+03,2.028900E+03,4.189700E+03,& + & 1.358800E+04,9.346337E+04,5.594900E-02,1.350500E-01,2.405100E-01,& + & 4.481900E-01,8.668700E-01,1.878200E+00,4.920000E+00,1.738500E+01,& + & 1.265500E+02,5.661800E+02,1.014800E+03,2.095300E+03,6.794500E+03,& + & 4.673177E+04,1.193600E-03,3.245600E-03,6.417000E-03,1.245400E-02,& + & 2.543400E-02,5.669000E-02,1.396000E-01,4.280000E-01,2.156700E+00,& + & 7.235600E+00,1.062300E+01,1.512300E+01,2.117000E+01,3.549151E+01,& + & 1.858200E-01,4.378800E-01,7.556500E-01,1.427600E+00,2.783600E+00,& + & 6.224700E+00,1.703000E+01,6.849600E+01,5.247400E+02,2.336700E+03,& + & 4.227200E+03,8.664800E+03,2.719100E+04,1.836680E+05,1.533600E-01,& + & 3.561800E-01,6.227100E-01,1.164200E+00,2.244100E+00,4.868600E+00,& + & 1.292400E+01,5.151000E+01,3.936700E+02,1.752700E+03,3.170600E+03,& + & 6.498900E+03,2.039400E+04,1.377534E+05,1.096400E-01,2.531100E-01,& + & 4.491300E-01,8.360500E-01,1.616000E+00,3.518800E+00,9.082300E+00,& + & 3.463000E+01,2.626000E+02,1.168700E+03,2.113900E+03,4.332900E+03,& + & 1.359600E+04,9.183671E+04,6.125100E-02,1.410800E-01,2.553100E-01,& + & 4.746300E-01,9.184900E-01,1.994000E+00,5.174700E+00,1.836800E+01,& + & 1.315900E+02,5.847000E+02,1.057300E+03,2.166900E+03,6.798500E+03,& + & 4.591844E+04,1.277400E-03,3.370700E-03,6.595600E-03,1.274700E-02,& + & 2.604400E-02,5.875000E-02,1.462900E-01,4.478500E-01,2.209800E+00,& + & 7.167200E+00,1.045400E+01,1.479100E+01,2.053300E+01,3.362173E+01,& + & 2.044700E-01,4.559900E-01,8.081000E-01,1.517400E+00,2.956200E+00,& + & 6.655800E+00,1.815200E+01,7.293300E+01,5.472000E+02,2.405200E+03,& + & 4.403100E+03,9.006500E+03,2.730600E+04,1.800376E+05,1.676000E-01,& + & 3.719700E-01,6.653600E-01,1.234000E+00,2.375300E+00,5.187100E+00,& + & 1.375200E+01,5.483100E+01,4.105100E+02,1.804100E+03,3.302500E+03,& + & 6.755100E+03,2.048000E+04,1.350287E+05,1.192900E-01,2.647500E-01,& + & 4.793100E-01,8.857200E-01,1.712000E+00,3.744600E+00,9.612300E+00,& + & 3.681400E+01,2.738200E+02,1.203000E+03,2.201800E+03,4.503700E+03,& + & 1.365400E+04,9.002022E+04,6.612700E-02,1.478400E-01,2.718600E-01,& + & 5.024200E-01,9.738900E-01,2.121400E+00,5.465300E+00,1.937400E+01,& + & 1.371700E+02,6.018600E+02,1.101200E+03,2.252300E+03,6.827300E+03,& + & 4.501046E+04,1.348100E-03,3.477800E-03,6.735600E-03,1.296200E-02,& + & 2.644900E-02,6.024300E-02,1.530600E-01,4.683000E-01,2.262000E+00,& + & 7.180600E+00,1.016800E+01,1.434300E+01,1.980300E+01,3.190050E+01/ + data absb(:,401:420) / & + & 1.172300E-01,3.466300E-01,5.835900E-01,1.079600E+00,2.122900E+00,& + & 4.714200E+00,1.314900E+01,5.252200E+01,4.407200E+02,2.021300E+03,& + & 3.687900E+03,7.647100E+03,2.610700E+04,2.148846E+05,9.820300E-02,& + & 2.814700E-01,4.792200E-01,8.873800E-01,1.728100E+00,3.752400E+00,& + & 1.009900E+01,3.952400E+01,3.306700E+02,1.516200E+03,2.766100E+03,& + & 5.735600E+03,1.958000E+04,1.611622E+05,7.100600E-02,1.993500E-01,& + & 3.429900E-01,6.372900E-01,1.241100E+00,2.716200E+00,7.231200E+00,& + & 2.682500E+01,2.206300E+02,1.011000E+03,1.844400E+03,3.824000E+03,& + & 1.305400E+04,1.074417E+05,4.041300E-02,1.105300E-01,1.933000E-01,& + & 3.614000E-01,7.025800E-01,1.536500E+00,4.126900E+00,1.472100E+01,& + & 1.108200E+02,5.059200E+02,9.226000E+02,1.912400E+03,6.527600E+03,& + & 5.372171E+04,8.408200E-04,2.440700E-03,4.922200E-03,9.646900E-03,& + & 1.976700E-02,4.403900E-02,1.101600E-01,3.492400E-01,1.941900E+00,& + & 7.182600E+00,1.091400E+01,1.634100E+01,2.395200E+01,4.148452E+01,& + & 1.341000E-01,3.628800E-01,6.083600E-01,1.146200E+00,2.248300E+00,& + & 5.009000E+00,1.389200E+01,5.633000E+01,4.582100E+02,2.102500E+03,& + & 3.844000E+03,7.907100E+03,2.617800E+04,2.118226E+05,1.118100E-01,& + & 2.941600E-01,5.010500E-01,9.401200E-01,1.828600E+00,3.972300E+00,& + & 1.063300E+01,4.238700E+01,3.437800E+02,1.577100E+03,2.883200E+03,& + & 5.930600E+03,1.963400E+04,1.588672E+05,8.044400E-02,2.082500E-01,& + & 3.599200E-01,6.748100E-01,1.314200E+00,2.875400E+00,7.591600E+00,& + & 2.868300E+01,2.293600E+02,1.051600E+03,1.922400E+03,3.954000E+03,& + & 1.309000E+04,1.059115E+05,4.546200E-02,1.152500E-01,2.040200E-01,& + & 3.824100E-01,7.443800E-01,1.625800E+00,4.339100E+00,1.561800E+01,& + & 1.151100E+02,5.261800E+02,9.615700E+02,1.977500E+03,6.545300E+03,& + & 5.295610E+04,9.220100E-04,2.572600E-03,5.127900E-03,1.000600E-02,& + & 2.052600E-02,4.627700E-02,1.161400E-01,3.682200E-01,1.999800E+00,& + & 7.244900E+00,1.094500E+01,1.601300E+01,2.312800E+01,3.948797E+01,& + & 1.515900E-01,3.773800E-01,6.416900E-01,1.216600E+00,2.386700E+00,& + & 5.348000E+00,1.473500E+01,6.027100E+01,4.772900E+02,2.181700E+03,& + & 4.013400E+03,8.229200E+03,2.637300E+04,2.082939E+05,1.255600E-01,& + & 3.063600E-01,5.292900E-01,9.967600E-01,1.937600E+00,4.223600E+00,& + & 1.124200E+01,4.534300E+01,3.580800E+02,1.636500E+03,3.010200E+03,& + & 6.172100E+03,1.978000E+04,1.562241E+05,8.994300E-02,2.169600E-01,& + & 3.809600E-01,7.154900E-01,1.393200E+00,3.056500E+00,7.995800E+00,& + & 3.060600E+01,2.388900E+02,1.091200E+03,2.007000E+03,4.115100E+03,& + & 1.318700E+04,1.041496E+05,5.034200E-02,1.203400E-01,2.161300E-01,& + & 4.053400E-01,7.899000E-01,1.728600E+00,4.571800E+00,1.653100E+01,& + & 1.198000E+02,5.459600E+02,1.003800E+03,2.058000E+03,6.594100E+03,& + & 5.207491E+04,9.965200E-04,2.687600E-03,5.298900E-03,1.029100E-02,& + & 2.112100E-02,4.815600E-02,1.223700E-01,3.878400E-01,2.067100E+00,& + & 7.220000E+00,1.085300E+01,1.573200E+01,2.227600E+01,3.744912E+01,& + & 1.687800E-01,3.920800E-01,6.841800E-01,1.295000E+00,2.537000E+00,& + & 5.729200E+00,1.571700E+01,6.438900E+01,4.988200E+02,2.255600E+03,& + & 4.190900E+03,8.624000E+03,2.667400E+04,2.043685E+05,1.389200E-01,& + & 3.191100E-01,5.647900E-01,1.058000E+00,2.054400E+00,4.507400E+00,& + & 1.195700E+01,4.843100E+01,3.742200E+02,1.691900E+03,3.143300E+03,& + & 6.468200E+03,2.000600E+04,1.532757E+05,9.899100E-02,2.264800E-01,& + & 4.065900E-01,7.591300E-01,1.478200E+00,3.262200E+00,8.460900E+00,& + & 3.262300E+01,2.496400E+02,1.128200E+03,2.095700E+03,4.312500E+03,& + & 1.333800E+04,1.021834E+05,5.494500E-02,1.258900E-01,2.301000E-01,& + & 4.298900E-01,8.393600E-01,1.844200E+00,4.836600E+00,1.746800E+01,& + & 1.251200E+02,5.644700E+02,1.048100E+03,2.156700E+03,6.669300E+03,& + & 5.109277E+04,1.062400E-03,2.788100E-03,5.437600E-03,1.051200E-02,& + & 2.154000E-02,4.956000E-02,1.287800E-01,4.081400E-01,2.134100E+00,& + & 7.259100E+00,1.057800E+01,1.537200E+01,2.152600E+01,3.540818E+01/ + data absb(:,421:440) / & + & 1.850600E-01,4.088600E-01,7.338800E-01,1.379600E+00,2.700500E+00,& + & 6.132900E+00,1.685000E+01,6.866900E+01,5.233100E+02,2.324600E+03,& + & 4.372600E+03,9.059800E+03,2.707000E+04,2.000922E+05,1.513300E-01,& + & 3.338900E-01,6.048700E-01,1.124600E+00,2.180800E+00,4.805800E+00,& + & 1.279000E+01,5.163300E+01,3.925900E+02,1.743600E+03,3.279600E+03,& + & 6.795100E+03,2.030300E+04,1.500652E+05,1.073300E-01,2.374000E-01,& + & 4.348700E-01,8.067000E-01,1.570900E+00,3.477100E+00,8.999100E+00,& + & 3.471300E+01,2.618800E+02,1.162600E+03,2.186600E+03,4.530400E+03,& + & 1.353500E+04,1.000447E+05,5.913000E-02,1.322000E-01,2.455400E-01,& + & 4.563800E-01,8.925100E-01,1.968700E+00,5.136600E+00,1.842200E+01,& + & 1.312100E+02,5.816700E+02,1.093600E+03,2.265700E+03,6.768100E+03,& + & 5.002226E+04,1.118600E-03,2.869800E-03,5.545900E-03,1.067800E-02,& + & 2.182600E-02,5.048700E-02,1.350400E-01,4.295300E-01,2.197900E+00,& + & 7.291200E+00,1.040300E+01,1.476700E+01,2.070300E+01,3.351680E+01,& + & 1.101700E-01,3.185900E-01,5.355900E-01,1.000900E+00,1.973100E+00,& + & 4.403800E+00,1.231400E+01,5.033500E+01,4.255600E+02,1.989100E+03,& + & 3.719200E+03,7.632300E+03,2.556500E+04,2.445740E+05,9.191500E-02,& + & 2.580700E-01,4.398700E-01,8.225400E-01,1.609800E+00,3.521100E+00,& + & 9.494500E+00,3.789600E+01,3.193000E+02,1.492000E+03,2.789600E+03,& + & 5.724500E+03,1.917400E+04,1.834291E+05,6.615800E-02,1.822600E-01,& + & 3.144600E-01,5.893400E-01,1.153400E+00,2.544700E+00,6.824300E+00,& + & 2.581000E+01,2.130500E+02,9.948900E+02,1.860000E+03,3.816600E+03,& + & 1.278300E+04,1.222858E+05,3.738500E-02,1.005200E-01,1.768100E-01,& + & 3.327100E-01,6.509700E-01,1.433600E+00,3.890300E+00,1.427100E+01,& + & 1.071100E+02,4.978300E+02,9.303500E+02,1.908800E+03,6.392100E+03,& + & 6.114326E+04,7.071600E-04,2.028600E-03,4.081200E-03,8.005800E-03,& + & 1.649800E-02,3.752800E-02,9.572100E-02,3.134700E-01,1.830900E+00,& + & 7.169600E+00,1.114100E+01,1.683200E+01,2.501500E+01,4.373864E+01,& + & 1.257100E-01,3.330000E-01,5.609200E-01,1.063100E+00,2.095800E+00,& + & 4.699600E+00,1.305400E+01,5.410000E+01,4.440700E+02,2.070400E+03,& + & 3.894400E+03,7.985600E+03,2.592400E+04,2.407870E+05,1.043800E-01,& + & 2.696000E-01,4.619500E-01,8.725600E-01,1.708800E+00,3.744100E+00,& + & 1.002400E+01,4.071900E+01,3.331700E+02,1.553000E+03,2.921000E+03,& + & 5.989400E+03,1.944300E+04,1.805880E+05,7.479100E-02,1.903800E-01,& + & 3.312300E-01,6.253300E-01,1.225700E+00,2.706700E+00,7.188700E+00,& + & 2.763300E+01,2.222900E+02,1.035500E+03,1.947500E+03,3.993300E+03,& + & 1.296200E+04,1.203926E+05,4.193700E-02,1.049300E-01,1.869900E-01,& + & 3.530500E-01,6.920800E-01,1.525700E+00,4.105400E+00,1.516500E+01,& + & 1.116100E+02,5.181200E+02,9.741100E+02,1.997200E+03,6.481800E+03,& + & 6.019817E+04,7.722200E-04,2.134500E-03,4.241000E-03,8.280000E-03,& + & 1.705400E-02,3.926200E-02,1.014200E-01,3.323400E-01,1.910100E+00,& + & 7.199600E+00,1.113900E+01,1.659200E+01,2.402600E+01,4.148204E+01,& + & 1.416500E-01,3.460800E-01,5.946700E-01,1.130800E+00,2.228500E+00,& + & 5.039600E+00,1.392100E+01,5.797500E+01,4.650500E+02,2.148600E+03,& + & 4.075300E+03,8.425600E+03,2.642500E+04,2.364889E+05,1.168800E-01,& + & 2.807900E-01,4.906100E-01,9.271000E-01,1.813900E+00,3.998300E+00,& + & 1.065000E+01,4.362500E+01,3.489000E+02,1.611700E+03,3.056600E+03,& + & 6.319500E+03,1.981900E+04,1.773677E+05,8.336100E-02,1.984900E-01,& + & 3.523400E-01,6.642000E-01,1.302200E+00,2.892100E+00,7.609300E+00,& + & 2.951100E+01,2.327600E+02,1.074700E+03,2.037900E+03,4.213300E+03,& + & 1.321300E+04,1.182430E+05,4.629500E-02,1.096800E-01,1.988000E-01,& + & 3.748100E-01,7.364200E-01,1.630800E+00,4.351700E+00,1.606000E+01,& + & 1.167600E+02,5.377300E+02,1.019200E+03,2.107200E+03,6.607000E+03,& + & 5.912333E+04,8.320500E-04,2.226400E-03,4.375600E-03,8.496300E-03,& + & 1.748200E-02,4.057300E-02,1.073900E-01,3.521700E-01,1.991400E+00,& + & 7.256400E+00,1.097000E+01,1.626000E+01,2.323800E+01,3.910442E+01/ + data absb(:,441:460) / & + & 1.570900E-01,3.600200E-01,6.362000E-01,1.206300E+00,2.372900E+00,& + & 5.408900E+00,1.494400E+01,6.205700E+01,4.890800E+02,2.224300E+03,& + & 4.262100E+03,8.902700E+03,2.708100E+04,2.317475E+05,1.288200E-01,& + & 2.930300E-01,5.252900E-01,9.861700E-01,1.928000E+00,4.274400E+00,& + & 1.139300E+01,4.668100E+01,3.669200E+02,1.668400E+03,3.196700E+03,& + & 6.677200E+03,2.031100E+04,1.738111E+05,9.141200E-02,2.076000E-01,& + & 3.769200E-01,7.064600E-01,1.386100E+00,3.094200E+00,8.101000E+00,& + & 3.149000E+01,2.447700E+02,1.112500E+03,2.131300E+03,4.451800E+03,& + & 1.354100E+04,1.158751E+05,5.035800E-02,1.149500E-01,2.121800E-01,& + & 3.983300E-01,7.851800E-01,1.746700E+00,4.634400E+00,1.697900E+01,& + & 1.227000E+02,5.566000E+02,1.066000E+03,2.226400E+03,6.771000E+03,& + & 5.793681E+04,8.842200E-04,2.305200E-03,4.482000E-03,8.667800E-03,& + & 1.779000E-02,4.147500E-02,1.132800E-01,3.732400E-01,2.070900E+00,& + & 7.349100E+00,1.073600E+01,1.576700E+01,2.236900E+01,3.691518E+01,& + & 1.716100E-01,3.761600E-01,6.841600E-01,1.287200E+00,2.535300E+00,& + & 5.802600E+00,1.610400E+01,6.642900E+01,5.166000E+02,2.296900E+03,& + & 4.454400E+03,9.413800E+03,2.786000E+04,2.265926E+05,1.398900E-01,& + & 3.071800E-01,5.639000E-01,1.050700E+00,2.054600E+00,4.565500E+00,& + & 1.224500E+01,4.995100E+01,3.875600E+02,1.722800E+03,3.341000E+03,& + & 7.060600E+03,2.089600E+04,1.699410E+05,9.879800E-02,2.180200E-01,& + & 4.042000E-01,7.530100E-01,1.478500E+00,3.305800E+00,8.656500E+00,& + & 3.361600E+01,2.585300E+02,1.148800E+03,2.227500E+03,4.707300E+03,& + & 1.393100E+04,1.132961E+05,5.406000E-02,1.208600E-01,2.269200E-01,& + & 4.243300E-01,8.376700E-01,1.869300E+00,4.950100E+00,1.794700E+01,& + & 1.295400E+02,5.747100E+02,1.114100E+03,2.354100E+03,6.965800E+03,& + & 5.664831E+04,9.282900E-04,2.370300E-03,4.563700E-03,8.793900E-03,& + & 1.798900E-02,4.208400E-02,1.187700E-01,3.952000E-01,2.148000E+00,& + & 7.395000E+00,1.066300E+01,1.514000E+01,2.126300E+01,3.485642E+01,& + & 1.089400E-01,3.080400E-01,5.181600E-01,9.766000E-01,1.934000E+00,& + & 4.340600E+00,1.215700E+01,5.073600E+01,4.335700E+02,2.060000E+03,& + & 3.949400E+03,8.145900E+03,2.651900E+04,2.911667E+05,9.033800E-02,& + & 2.485400E-01,4.246400E-01,8.008400E-01,1.577200E+00,3.475600E+00,& + & 9.387800E+00,3.820400E+01,3.253000E+02,1.545200E+03,2.962200E+03,& + & 6.109700E+03,1.989000E+04,2.183726E+05,6.463600E-02,1.748800E-01,& + & 3.026100E-01,5.717700E-01,1.126400E+00,2.504300E+00,6.754800E+00,& + & 2.605700E+01,2.170400E+02,1.030300E+03,1.975000E+03,4.073500E+03,& + & 1.326000E+04,1.455836E+05,3.617500E-02,9.577100E-02,1.692200E-01,& + & 3.207000E-01,6.318200E-01,1.402900E+00,3.838100E+00,1.444400E+01,& + & 1.091300E+02,5.155200E+02,9.878600E+02,2.037300E+03,6.630600E+03,& + & 7.279032E+04,5.948900E-04,1.687900E-03,3.382500E-03,6.638200E-03,& + & 1.373100E-02,3.183700E-02,8.334500E-02,2.819900E-01,1.745800E+00,& + & 7.089100E+00,1.130900E+01,1.733400E+01,2.582900E+01,4.562854E+01,& + & 1.239900E-01,3.214800E-01,5.453600E-01,1.037400E+00,2.057400E+00,& + & 4.653000E+00,1.295500E+01,5.460700E+01,4.547800E+02,2.144200E+03,& + & 4.149700E+03,8.624300E+03,2.726600E+04,2.862964E+05,1.023000E-01,& + & 2.595400E-01,4.481400E-01,8.501400E-01,1.677300E+00,3.711600E+00,& + & 9.959400E+00,4.110500E+01,3.412000E+02,1.608300E+03,3.112400E+03,& + & 6.468500E+03,2.045000E+04,2.147207E+05,7.290000E-02,1.826100E-01,& + & 3.201300E-01,6.073400E-01,1.199500E+00,2.676600E+00,7.149800E+00,& + & 2.792200E+01,2.276400E+02,1.072500E+03,2.075100E+03,4.312700E+03,& + & 1.363400E+04,1.431479E+05,4.046500E-02,1.000700E-01,1.794500E-01,& + & 3.406900E-01,6.735800E-01,1.501400E+00,4.072800E+00,1.535800E+01,& + & 1.143000E+02,5.366100E+02,1.037800E+03,2.156900E+03,6.817300E+03,& + & 7.157560E+04,6.475300E-04,1.772400E-03,3.508400E-03,6.845600E-03,& + & 1.415200E-02,3.306300E-02,8.877100E-02,3.009400E-01,1.839300E+00,& + & 7.194000E+00,1.123300E+01,1.706400E+01,2.491700E+01,4.298598E+01/ + data absb(:,461:480) / & + & 1.392000E-01,3.341800E-01,5.807900E-01,1.107500E+00,2.191400E+00,& + & 5.002500E+00,1.391100E+01,5.868100E+01,4.794000E+02,2.226700E+03,& + & 4.356400E+03,9.151800E+03,2.822900E+04,2.808694E+05,1.141900E-01,& + & 2.704700E-01,4.782200E-01,9.058100E-01,1.784800E+00,3.975400E+00,& + & 1.064900E+01,4.415500E+01,3.596600E+02,1.670200E+03,3.267400E+03,& + & 6.864200E+03,2.117200E+04,2.106548E+05,8.098000E-02,1.906400E-01,& + & 3.420300E-01,6.468100E-01,1.278100E+00,2.871600E+00,7.617400E+00,& + & 2.988700E+01,2.399300E+02,1.113700E+03,2.178500E+03,4.576400E+03,& + & 1.411500E+04,1.404359E+05,4.455200E-02,1.047200E-01,1.914500E-01,& + & 3.626100E-01,7.191500E-01,1.613000E+00,4.345200E+00,1.629500E+01,& + & 1.203500E+02,5.572000E+02,1.089500E+03,2.288700E+03,7.057900E+03,& + & 7.021962E+04,6.950700E-04,1.846100E-03,3.613300E-03,7.012700E-03,& + & 1.446600E-02,3.394800E-02,9.425000E-02,3.213000E-01,1.933300E+00,& + & 7.351900E+00,1.103100E+01,1.660900E+01,2.402900E+01,4.044976E+01,& + & 1.537300E-01,3.481600E-01,6.236000E-01,1.183400E+00,2.340600E+00,& + & 5.378500E+00,1.501700E+01,6.306800E+01,5.080400E+02,2.306900E+03,& + & 4.567700E+03,9.735600E+03,2.935300E+04,2.749117E+05,1.253700E-01,& + & 2.828200E-01,5.135500E-01,9.664400E-01,1.902500E+00,4.256200E+00,& + & 1.145600E+01,4.743600E+01,3.811500E+02,1.730300E+03,3.425900E+03,& + & 7.301900E+03,2.201500E+04,2.061839E+05,8.847900E-02,1.997600E-01,& + & 3.668500E-01,6.903900E-01,1.364800E+00,3.077400E+00,8.153200E+00,& + & 3.200800E+01,2.542500E+02,1.153800E+03,2.284100E+03,4.868300E+03,& + & 1.467700E+04,1.374563E+05,4.831700E-02,1.099000E-01,2.049500E-01,& + & 3.867500E-01,7.692500E-01,1.731900E+00,4.655100E+00,1.727900E+01,& + & 1.274400E+02,5.772100E+02,1.142300E+03,2.434600E+03,7.339000E+03,& + & 6.872685E+04,7.366100E-04,1.908200E-03,3.696400E-03,7.146900E-03,& + & 1.468700E-02,3.457000E-02,9.940600E-02,3.430000E-01,2.023400E+00,& + & 7.478300E+00,1.101800E+01,1.584800E+01,2.298900E+01,3.811205E+01,& + & 1.673500E-01,3.645100E-01,6.713600E-01,1.266000E+00,2.510700E+00,& + & 5.788900E+00,1.626600E+01,6.787300E+01,5.403300E+02,2.395100E+03,& + & 4.782300E+03,1.036500E+04,3.059000E+04,2.684968E+05,1.357700E-01,& + & 2.970600E-01,5.524200E-01,1.032600E+00,2.035400E+00,4.559500E+00,& + & 1.237300E+01,5.103100E+01,4.053600E+02,1.796500E+03,3.586900E+03,& + & 7.773600E+03,2.294300E+04,2.013752E+05,9.538000E-02,2.101900E-01,& + & 3.943300E-01,7.382500E-01,1.461200E+00,3.298900E+00,8.755200E+00,& + & 3.434400E+01,2.703900E+02,1.197800E+03,2.391500E+03,5.182700E+03,& + & 1.529500E+04,1.342511E+05,5.177000E-02,1.157200E-01,2.196800E-01,& + & 4.133400E-01,8.239700E-01,1.859800E+00,5.000400E+00,1.834000E+01,& + & 1.354800E+02,5.992200E+02,1.196000E+03,2.591800E+03,7.648100E+03,& + & 6.712441E+04,7.710400E-04,1.957800E-03,3.763200E-03,7.236700E-03,& + & 1.484300E-02,3.498600E-02,1.040100E-01,3.658200E-01,2.115000E+00,& + & 7.497800E+00,1.092200E+01,1.537600E+01,2.163800E+01,3.587297E+01,& + & 1.090000E-01,3.013400E-01,5.083600E-01,9.642200E-01,1.920400E+00,& + & 4.339600E+00,1.218900E+01,5.181600E+01,4.489700E+02,2.160700E+03,& + & 4.239800E+03,8.908300E+03,2.818800E+04,3.490327E+05,8.982700E-02,& + & 2.422200E-01,4.156500E-01,7.887800E-01,1.565400E+00,3.476900E+00,& + & 9.419000E+00,3.901900E+01,3.368500E+02,1.620700E+03,3.180000E+03,& + & 6.681500E+03,2.114100E+04,2.617762E+05,6.390300E-02,1.698200E-01,& + & 2.951300E-01,5.613200E-01,1.114800E+00,2.499200E+00,6.777500E+00,& + & 2.662700E+01,2.247400E+02,1.080700E+03,2.120200E+03,4.454700E+03,& + & 1.409500E+04,1.745167E+05,3.541000E-02,9.239100E-02,1.640100E-01,& + & 3.128000E-01,6.214700E-01,1.393300E+00,3.839800E+00,1.477000E+01,& + & 1.129800E+02,5.407300E+02,1.060400E+03,2.227900E+03,7.047800E+03,& + & 8.726001E+04,5.004300E-04,1.404500E-03,2.802300E-03,5.495800E-03,& + & 1.141100E-02,2.682700E-02,7.278000E-02,2.544900E-01,1.678700E+00,& + & 7.092100E+00,1.139500E+01,1.773000E+01,2.646800E+01,4.714399E+01/ + data absb(:,481:500) / & + & 1.237300E-01,3.141300E-01,5.375500E-01,1.026800E+00,2.045500E+00,& + & 4.671400E+00,1.308400E+01,5.591400E+01,4.741900E+02,2.249900E+03,& + & 4.475900E+03,9.497900E+03,2.947900E+04,3.428043E+05,1.014400E-01,& + & 2.528800E-01,4.408100E-01,8.396400E-01,1.667200E+00,3.728600E+00,& + & 1.006200E+01,4.208800E+01,3.557600E+02,1.687600E+03,3.357100E+03,& + & 7.123700E+03,2.211000E+04,2.571099E+05,7.188000E-02,1.773200E-01,& + & 3.137300E-01,5.976700E-01,1.189500E+00,2.684400E+00,7.222900E+00,& + & 2.859700E+01,2.373400E+02,1.125300E+03,2.238200E+03,4.749500E+03,& + & 1.474000E+04,1.714063E+05,3.950600E-02,9.660000E-02,1.745800E-01,& + & 3.329500E-01,6.643100E-01,1.499700E+00,4.102000E+00,1.573500E+01,& + & 1.191500E+02,5.630200E+02,1.119400E+03,2.375300E+03,7.370500E+03,& + & 8.570184E+04,5.426900E-04,1.471900E-03,2.903100E-03,5.657400E-03,& + & 1.172300E-02,2.768500E-02,7.776100E-02,2.737900E-01,1.785900E+00,& + & 7.285300E+00,1.128200E+01,1.733100E+01,2.564100E+01,4.415534E+01,& + & 1.382900E-01,3.267700E-01,5.751800E-01,1.099300E+00,2.183900E+00,& + & 5.031200E+00,1.413900E+01,6.029200E+01,5.037900E+02,2.338900E+03,& + & 4.716100E+03,1.014700E+04,3.099800E+04,3.359362E+05,1.127800E-01,& + & 2.638600E-01,4.726000E-01,8.972900E-01,1.778500E+00,4.000200E+00,& + & 1.082700E+01,4.536100E+01,3.779600E+02,1.754300E+03,3.537200E+03,& + & 7.610800E+03,2.324900E+04,2.519529E+05,7.952800E-02,1.854500E-01,& + & 3.364700E-01,6.387000E-01,1.271100E+00,2.885500E+00,7.743700E+00,& + & 3.070000E+01,2.521300E+02,1.169800E+03,2.358300E+03,5.074200E+03,& + & 1.550000E+04,1.679692E+05,4.336700E-02,1.012300E-01,1.868500E-01,& + & 3.555600E-01,7.118000E-01,1.615600E+00,4.405600E+00,1.673600E+01,& + & 1.264400E+02,5.852300E+02,1.179500E+03,2.537600E+03,7.750300E+03,& + & 8.398513E+04,5.808000E-04,1.530900E-03,2.984100E-03,5.790800E-03,& + & 1.195300E-02,2.830300E-02,8.254100E-02,2.948000E-01,1.889900E+00,& + & 7.463700E+00,1.128600E+01,1.658900E+01,2.464600E+01,4.149324E+01,& + & 1.521300E-01,3.410400E-01,6.191700E-01,1.176900E+00,2.342400E+00,& + & 5.425600E+00,1.534700E+01,6.511000E+01,5.379500E+02,2.434500E+03,& + & 4.960300E+03,1.086700E+04,3.267700E+04,3.284443E+05,1.234000E-01,& + & 2.764600E-01,5.086300E-01,9.596000E-01,1.903800E+00,4.294600E+00,& + & 1.171000E+01,4.896500E+01,4.035700E+02,1.826100E+03,3.720400E+03,& + & 8.150700E+03,2.450800E+04,2.463388E+05,8.661100E-02,1.946600E-01,& + & 3.618800E-01,6.836500E-01,1.362900E+00,3.101000E+00,8.333300E+00,& + & 3.303000E+01,2.692100E+02,1.217600E+03,2.480500E+03,5.434100E+03,& + & 1.633900E+04,1.642246E+05,4.690800E-02,1.063700E-01,2.006000E-01,& + & 3.805600E-01,7.641900E-01,1.739900E+00,4.748100E+00,1.781200E+01,& + & 1.349200E+02,6.090800E+02,1.240600E+03,2.717500E+03,8.170000E+03,& + & 8.211417E+04,6.129700E-04,1.579600E-03,3.052300E-03,5.889200E-03,& + & 1.212500E-02,2.874800E-02,8.690500E-02,3.171700E-01,1.996800E+00,& + & 7.530000E+00,1.126700E+01,1.615600E+01,2.308300E+01,3.901510E+01,& + & 1.651300E-01,3.578200E-01,6.673700E-01,1.261800E+00,2.521600E+00,& + & 5.866500E+00,1.668700E+01,7.047700E+01,5.755600E+02,2.553400E+03,& + & 5.210300E+03,1.164600E+04,3.445600E+04,3.204643E+05,1.333400E-01,& + & 2.910500E-01,5.479900E-01,1.028300E+00,2.043500E+00,4.621200E+00,& + & 1.269200E+01,5.298100E+01,4.317900E+02,1.915200E+03,3.907900E+03,& + & 8.735000E+03,2.584200E+04,2.403464E+05,9.318800E-02,2.052900E-01,& + & 3.895400E-01,7.335100E-01,1.464300E+00,3.339300E+00,8.980900E+00,& + & 3.564000E+01,2.880200E+02,1.276900E+03,2.605500E+03,5.823600E+03,& + & 1.722800E+04,1.602335E+05,5.019100E-02,1.122200E-01,2.154300E-01,& + & 4.080800E-01,8.223200E-01,1.876700E+00,5.120600E+00,1.899900E+01,& + & 1.442900E+02,6.387200E+02,1.303100E+03,2.912200E+03,8.614600E+03,& + & 8.011674E+04,6.406700E-04,1.619900E-03,3.103200E-03,5.956300E-03,& + & 1.224000E-02,2.906400E-02,9.056400E-02,3.410100E-01,2.097700E+00,& + & 7.583600E+00,1.117700E+01,1.584800E+01,2.188800E+01,3.604490E+01/ + data absb(:,501:520) / & + & 1.110500E-01,3.000700E-01,5.090700E-01,9.704400E-01,1.942300E+00,& + & 4.433200E+00,1.250400E+01,5.392700E+01,4.761300E+02,2.314700E+03,& + & 4.640400E+03,9.997900E+03,3.103800E+04,4.242460E+05,9.091900E-02,& + & 2.403600E-01,4.151300E-01,7.917500E-01,1.582300E+00,3.548900E+00,& + & 9.658100E+00,4.060600E+01,3.572100E+02,1.736200E+03,3.480400E+03,& + & 7.498700E+03,2.327800E+04,3.181854E+05,6.430100E-02,1.678900E-01,& + & 2.936500E-01,5.614800E-01,1.123600E+00,2.545200E+00,6.942900E+00,& + & 2.769500E+01,2.383100E+02,1.157700E+03,2.320500E+03,4.999500E+03,& + & 1.551900E+04,2.121230E+05,3.527700E-02,9.074900E-02,1.620500E-01,& + & 3.107100E-01,6.228000E-01,1.412100E+00,3.922000E+00,1.534100E+01,& + & 1.197400E+02,5.792200E+02,1.160500E+03,2.500300E+03,7.760200E+03,& + & 1.060617E+05,4.205500E-04,1.169200E-03,2.323300E-03,4.547900E-03,& + & 9.466700E-03,2.249600E-02,6.364300E-02,2.309300E-01,1.631300E+00,& + & 7.142200E+00,1.143300E+01,1.798900E+01,2.720800E+01,4.804419E+01,& + & 1.256200E-01,3.125700E-01,5.409500E-01,1.037700E+00,2.072800E+00,& + & 4.782300E+00,1.352300E+01,5.839500E+01,5.072700E+02,2.411400E+03,& + & 4.920000E+03,1.074300E+04,3.299900E+04,4.156962E+05,1.023500E-01,& + & 2.509300E-01,4.424300E-01,8.460900E-01,1.688400E+00,3.814900E+00,& + & 1.039300E+01,4.394700E+01,3.805600E+02,1.808700E+03,3.690100E+03,& + & 8.057800E+03,2.474900E+04,3.121955E+05,7.209600E-02,1.754000E-01,& + & 3.136300E-01,5.998900E-01,1.201800E+00,2.742900E+00,7.453200E+00,& + & 2.983600E+01,2.538700E+02,1.206000E+03,2.460300E+03,5.372200E+03,& + & 1.650000E+04,2.081322E+05,3.924500E-02,9.497000E-02,1.731500E-01,& + & 3.316900E-01,6.677800E-01,1.526600E+00,4.221800E+00,1.638300E+01,& + & 1.273900E+02,6.033500E+02,1.230400E+03,2.686600E+03,8.250500E+03,& + & 1.040681E+05,4.547400E-04,1.223100E-03,2.401700E-03,4.677000E-03,& + & 9.699100E-03,2.311100E-02,6.803700E-02,2.507300E-01,1.748600E+00,& + & 7.379800E+00,1.146800E+01,1.736500E+01,2.614500E+01,4.502426E+01,& + & 1.398100E-01,3.255100E-01,5.809900E-01,1.112700E+00,2.222200E+00,& + & 5.164700E+00,1.470100E+01,6.325400E+01,5.436300E+02,2.514200E+03,& + & 5.207600E+03,1.156800E+04,3.522800E+04,4.074401E+05,1.133400E-01,& + & 2.622400E-01,4.761700E-01,9.061200E-01,1.807900E+00,4.102900E+00,& + & 1.125100E+01,4.757800E+01,4.078300E+02,1.885800E+03,3.905900E+03,& + & 8.676100E+03,2.642100E+04,3.055801E+05,7.947300E-02,1.837300E-01,& + & 3.374200E-01,6.430900E-01,1.289200E+00,2.954800E+00,8.037400E+00,& + & 3.217200E+01,2.720500E+02,1.257400E+03,2.604100E+03,5.784400E+03,& + & 1.761400E+04,2.037201E+05,4.294900E-02,9.963500E-02,1.859500E-01,& + & 3.555600E-01,7.181800E-01,1.648300E+00,4.563500E+00,1.748500E+01,& + & 1.363900E+02,6.290000E+02,1.302400E+03,2.892600E+03,8.807700E+03,& + & 1.018600E+05,4.846100E-04,1.270300E-03,2.467600E-03,4.778500E-03,& + & 9.880700E-03,2.357300E-02,7.205100E-02,2.722900E-01,1.869500E+00,& + & 7.499000E+00,1.154100E+01,1.690100E+01,2.454400E+01,4.223679E+01,& + & 1.532600E-01,3.404300E-01,6.264800E-01,1.194100E+00,2.392800E+00,& + & 5.591700E+00,1.603500E+01,6.873200E+01,5.842100E+02,2.643600E+03,& + & 5.498600E+03,1.246600E+04,3.760000E+04,3.979873E+05,1.236300E-01,& + & 2.753500E-01,5.132800E-01,9.720500E-01,1.943000E+00,4.420800E+00,& + & 1.222700E+01,5.167800E+01,4.382800E+02,1.982900E+03,4.124100E+03,& + & 9.349700E+03,2.820000E+04,2.984929E+05,8.630300E-02,1.932500E-01,& + & 3.637500E-01,6.906200E-01,1.388000E+00,3.188400E+00,8.687900E+00,& + & 3.482700E+01,2.923400E+02,1.322100E+03,2.749600E+03,6.233400E+03,& + & 1.880000E+04,1.989955E+05,4.636000E-02,1.048600E-01,2.000900E-01,& + & 3.819100E-01,7.744400E-01,1.783000E+00,4.941000E+00,1.870700E+01,& + & 1.464800E+02,6.612900E+02,1.375100E+03,3.117100E+03,9.400700E+03,& + & 9.949685E+04,5.101400E-04,1.310300E-03,2.519600E-03,4.853000E-03,& + & 1.001300E-02,2.390400E-02,7.552000E-02,2.956200E-01,1.983500E+00,& + & 7.601800E+00,1.151900E+01,1.659200E+01,2.315900E+01,3.911846E+01/ + data absb(:,521:540) / & + & 1.658700E-01,3.581400E-01,6.764600E-01,1.282700E+00,2.587300E+00,& + & 6.074300E+00,1.749800E+01,7.499300E+01,6.274200E+02,2.816600E+03,& + & 5.804500E+03,1.344100E+04,4.007300E+04,3.879009E+05,1.333100E-01,& + & 2.906600E-01,5.539400E-01,1.044000E+00,2.093500E+00,4.778800E+00,& + & 1.330100E+01,5.636600E+01,4.706800E+02,2.112500E+03,4.353500E+03,& + & 1.008100E+04,3.005500E+04,2.909281E+05,9.270400E-02,2.043200E-01,& + & 3.921800E-01,7.428700E-01,1.497500E+00,3.447400E+00,9.394600E+00,& + & 3.788500E+01,3.139400E+02,1.408500E+03,2.902600E+03,6.720800E+03,& + & 2.003700E+04,1.939483E+05,4.956100E-02,1.108600E-01,2.153300E-01,& + & 4.107200E-01,8.371700E-01,1.932100E+00,5.347000E+00,2.010500E+01,& + & 1.572500E+02,7.044700E+02,1.451600E+03,3.360800E+03,1.001900E+04,& + & 9.697492E+04,5.325200E-04,1.341300E-03,2.560900E-03,4.902200E-03,& + & 1.009300E-02,2.413400E-02,7.834300E-02,3.205800E-01,2.093800E+00,& + & 7.646800E+00,1.139800E+01,1.616000E+01,2.238700E+01,3.571117E+01,& + & 1.098000E-01,2.909200E-01,4.970400E-01,9.521600E-01,1.912700E+00,& + & 4.412500E+00,1.254400E+01,5.472500E+01,4.947900E+02,2.421000E+03,& + & 4.957700E+03,1.100500E+04,3.385800E+04,5.014502E+05,8.945400E-02,& + & 2.325700E-01,4.048000E-01,7.759600E-01,1.558800E+00,3.535600E+00,& + & 9.693200E+00,4.120700E+01,3.712000E+02,1.815900E+03,3.718400E+03,& + & 8.254300E+03,2.539400E+04,3.760867E+05,6.296700E-02,1.620000E-01,& + & 2.855500E-01,5.488600E-01,1.105300E+00,2.533500E+00,6.970900E+00,& + & 2.811100E+01,2.476400E+02,1.210800E+03,2.479100E+03,5.503200E+03,& + & 1.693000E+04,2.507245E+05,3.426400E-02,8.711400E-02,1.567300E-01,& + & 3.019000E-01,6.104800E-01,1.402300E+00,3.932400E+00,1.558200E+01,& + & 1.243900E+02,6.057700E+02,1.239900E+03,2.752100E+03,8.465300E+03,& + & 1.253616E+05,3.517900E-04,9.710400E-04,1.922500E-03,3.760200E-03,& + & 7.830900E-03,1.878700E-02,5.549500E-02,2.103000E-01,1.595100E+00,& + & 7.208300E+00,1.158200E+01,1.809400E+01,2.762500E+01,4.886793E+01,& + & 1.237400E-01,3.030100E-01,5.306900E-01,1.021400E+00,2.047300E+00,& + & 4.772400E+00,1.365200E+01,5.948200E+01,5.320900E+02,2.528400E+03,& + & 5.277100E+03,1.192500E+04,3.656600E+04,4.915535E+05,1.003700E-01,& + & 2.428600E-01,4.336400E-01,8.316800E-01,1.668700E+00,3.810300E+00,& + & 1.049500E+01,4.476100E+01,3.991800E+02,1.896500E+03,3.958000E+03,& + & 8.943600E+03,2.742500E+04,3.686639E+05,7.036300E-02,1.693900E-01,& + & 3.064300E-01,5.883600E-01,1.186200E+00,2.737400E+00,7.528800E+00,& + & 3.038400E+01,2.662800E+02,1.264500E+03,2.638900E+03,5.962700E+03,& + & 1.828400E+04,2.457715E+05,3.800400E-02,9.125600E-02,1.680700E-01,& + & 3.235400E-01,6.569800E-01,1.519500E+00,4.261300E+00,1.668200E+01,& + & 1.335900E+02,6.325500E+02,1.319800E+03,2.981800E+03,9.142200E+03,& + & 1.228872E+05,3.795500E-04,1.014600E-03,1.984700E-03,3.861200E-03,& + & 8.016800E-03,1.923900E-02,5.920700E-02,2.304600E-01,1.725800E+00,& + & 7.418000E+00,1.170800E+01,1.750300E+01,2.624300E+01,4.573891E+01,& + & 1.372500E-01,3.160000E-01,5.715100E-01,1.097600E+00,2.205000E+00,& + & 5.172100E+00,1.493100E+01,6.481600E+01,5.746300E+02,2.659100E+03,& + & 5.610900E+03,1.292900E+04,3.955500E+04,4.807260E+05,1.108000E-01,& + & 2.543100E-01,4.677600E-01,8.932100E-01,1.794700E+00,4.111200E+00,& + & 1.142800E+01,4.874700E+01,4.310900E+02,1.994400E+03,4.208300E+03,& + & 9.697000E+03,2.966600E+04,3.605454E+05,7.734000E-02,1.777300E-01,& + & 3.304600E-01,6.326100E-01,1.278500E+00,2.958400E+00,8.166500E+00,& + & 3.294900E+01,2.875500E+02,1.329800E+03,2.805800E+03,6.465000E+03,& + & 1.977800E+04,2.403626E+05,4.149400E-02,9.586300E-02,1.810100E-01,& + & 3.479700E-01,7.097700E-01,1.647500E+00,4.632800E+00,1.788700E+01,& + & 1.441300E+02,6.651600E+02,1.403200E+03,3.232900E+03,9.889300E+03,& + & 1.201813E+05,4.029200E-04,1.053200E-03,2.037000E-03,3.939800E-03,& + & 8.157100E-03,1.959000E-02,6.244900E-02,2.528800E-01,1.854600E+00,& + & 7.541800E+00,1.177000E+01,1.725800E+01,2.443000E+01,4.266757E+01/ + data absb(:,541:560) / & + & 1.500500E-01,3.311600E-01,6.171100E-01,1.180200E+00,2.384400E+00,& + & 5.624400E+00,1.634200E+01,7.097000E+01,6.205200E+02,2.835900E+03,& + & 5.958800E+03,1.401300E+04,4.270400E+04,4.691285E+05,1.205800E-01,& + & 2.675600E-01,5.051000E-01,9.605900E-01,1.936600E+00,4.449200E+00,& + & 1.246000E+01,5.335200E+01,4.655100E+02,2.127000E+03,4.469300E+03,& + & 1.051000E+04,3.202800E+04,3.518432E+05,8.380300E-02,1.873200E-01,& + & 3.568600E-01,6.815300E-01,1.381800E+00,3.206900E+00,8.856700E+00,& + & 3.593500E+01,3.105000E+02,1.418200E+03,2.979800E+03,7.006700E+03,& + & 2.135200E+04,2.345639E+05,4.472200E-02,1.010600E-01,1.950800E-01,& + & 3.751700E-01,7.687200E-01,1.790300E+00,5.036700E+00,1.926300E+01,& + & 1.555600E+02,7.092800E+02,1.490200E+03,3.503700E+03,1.067700E+04,& + & 1.172811E+05,4.238800E-04,1.084000E-03,2.080100E-03,3.996100E-03,& + & 8.258800E-03,1.984300E-02,6.514400E-02,2.772000E-01,1.977000E+00,& + & 7.693100E+00,1.162900E+01,1.696400E+01,2.367900E+01,3.873764E+01,& + & 1.619000E-01,3.494400E-01,6.674600E-01,1.270000E+00,2.587800E+00,& + & 6.138400E+00,1.792600E+01,7.800000E+01,6.689200E+02,3.068000E+03,& + & 6.330000E+03,1.520400E+04,4.589400E+04,4.568603E+05,1.297100E-01,& + & 2.833600E-01,5.458500E-01,1.034000E+00,2.094500E+00,4.829200E+00,& + & 1.362300E+01,5.862200E+01,5.018000E+02,2.301100E+03,4.747700E+03,& + & 1.140300E+04,3.442000E+04,3.426441E+05,8.984400E-02,1.986200E-01,& + & 3.855000E-01,7.346200E-01,1.497700E+00,3.483400E+00,9.616600E+00,& + & 3.938400E+01,3.346900E+02,1.534200E+03,3.165400E+03,7.602200E+03,& + & 2.294700E+04,2.284316E+05,4.776500E-02,1.071000E-01,2.104500E-01,& + & 4.043600E-01,8.352400E-01,1.949200E+00,5.469400E+00,2.085300E+01,& + & 1.676200E+02,7.673000E+02,1.583000E+03,3.801500E+03,1.147400E+04,& + & 1.142142E+05,4.417500E-04,1.107600E-03,2.114400E-03,4.032100E-03,& + & 8.310200E-03,2.003600E-02,6.746900E-02,3.031400E-01,2.091700E+00,& + & 7.781100E+00,1.152000E+01,1.650600E+01,2.277300E+01,3.525820E+01,& + & 1.073300E-01,2.813300E-01,4.838600E-01,9.310900E-01,1.876200E+00,& + & 4.371700E+00,1.255000E+01,5.534100E+01,5.147400E+02,2.536300E+03,& + & 5.290900E+03,1.213500E+04,3.731200E+04,5.929269E+05,8.709100E-02,& + & 2.244800E-01,3.936200E-01,7.580700E-01,1.529800E+00,3.507300E+00,& + & 9.703700E+00,4.167000E+01,3.861700E+02,1.902400E+03,3.968300E+03,& + & 9.101600E+03,2.798400E+04,4.446947E+05,6.105600E-02,1.559800E-01,& + & 2.768900E-01,5.348500E-01,1.083300E+00,2.511900E+00,6.983300E+00,& + & 2.843200E+01,2.576200E+02,1.268500E+03,2.645800E+03,6.068000E+03,& + & 1.865700E+04,2.964600E+05,3.299400E-02,8.347000E-02,1.511600E-01,& + & 2.925800E-01,5.962400E-01,1.387100E+00,3.935800E+00,1.576600E+01,& + & 1.293900E+02,6.345600E+02,1.323200E+03,3.034500E+03,9.328800E+03,& + & 1.482327E+05,2.923000E-04,8.032600E-04,1.584700E-03,3.099000E-03,& + & 6.464500E-03,1.562200E-02,4.796000E-02,1.910500E-01,1.562000E+00,& + & 7.230900E+00,1.174100E+01,1.823200E+01,2.794200E+01,4.973884E+01,& + & 1.207400E-01,2.931500E-01,5.183200E-01,1.001400E+00,2.016100E+00,& + & 4.743100E+00,1.374200E+01,6.047500E+01,5.584700E+02,2.663400E+03,& + & 5.654800E+03,1.324400E+04,4.088100E+04,5.808503E+05,9.756100E-02,& + & 2.346100E-01,4.232300E-01,8.146300E-01,1.644000E+00,3.791100E+00,& + & 1.056900E+01,4.550400E+01,4.189700E+02,1.997700E+03,4.241300E+03,& + & 9.933100E+03,3.066100E+04,4.356315E+05,6.811700E-02,1.632700E-01,& + & 2.982200E-01,5.751000E-01,1.167300E+00,2.721600E+00,7.585400E+00,& + & 3.088700E+01,2.794800E+02,1.332000E+03,2.827700E+03,6.622300E+03,& + & 2.044100E+04,2.904207E+05,3.655000E-02,8.751800E-02,1.626300E-01,& + & 3.147000E-01,6.444800E-01,1.507600E+00,4.290400E+00,1.695200E+01,& + & 1.401900E+02,6.663100E+02,1.414200E+03,3.311600E+03,1.022100E+04,& + & 1.452105E+05,3.143400E-04,8.394800E-04,1.636200E-03,3.179400E-03,& + & 6.614400E-03,1.597500E-02,5.102300E-02,2.116700E-01,1.702200E+00,& + & 7.439300E+00,1.190300E+01,1.790800E+01,2.610600E+01,4.643947E+01/ + data absb(:,561:580) / & + & 1.336900E-01,3.060600E-01,5.592900E-01,1.077900E+00,2.179600E+00,& + & 5.159600E+00,1.509300E+01,6.635100E+01,6.070900E+02,2.834500E+03,& + & 6.042000E+03,1.445700E+04,4.473800E+04,5.677494E+05,1.075500E-01,& + & 2.460200E-01,4.572100E-01,8.770300E-01,1.775000E+00,4.104700E+00,& + & 1.155500E+01,4.989500E+01,4.554400E+02,2.126000E+03,4.531700E+03,& + & 1.084300E+04,3.355400E+04,4.258089E+05,7.476800E-02,1.715200E-01,& + & 3.221900E-01,6.201700E-01,1.263200E+00,2.953500E+00,8.262100E+00,& + & 3.371100E+01,3.037900E+02,1.417500E+03,3.021400E+03,7.228800E+03,& + & 2.236900E+04,2.838667E+05,3.987300E-02,9.201800E-02,1.755000E-01,& + & 3.396500E-01,6.990900E-01,1.641900E+00,4.687800E+00,1.827700E+01,& + & 1.522600E+02,7.089700E+02,1.511000E+03,3.614800E+03,1.118500E+04,& + & 1.419351E+05,3.336300E-04,8.695300E-04,1.679500E-03,3.241400E-03,& + & 6.727600E-03,1.625200E-02,5.362400E-02,2.346100E-01,1.836500E+00,& + & 7.656900E+00,1.186600E+01,1.765900E+01,2.508000E+01,4.235772E+01,& + & 1.458800E-01,3.213500E-01,6.048200E-01,1.161100E+00,2.366800E+00,& + & 5.636500E+00,1.659100E+01,7.322200E+01,6.585200E+02,3.067400E+03,& + & 6.460100E+03,1.577600E+04,4.875400E+04,5.536806E+05,1.168900E-01,& + & 2.593700E-01,4.946300E-01,9.454200E-01,1.922700E+00,4.461200E+00,& + & 1.265000E+01,5.504000E+01,4.940100E+02,2.300700E+03,4.845300E+03,& + & 1.183300E+04,3.656600E+04,4.152585E+05,8.095000E-02,1.811200E-01,& + & 3.485200E-01,6.699300E-01,1.371000E+00,3.214100E+00,8.995000E+00,& + & 3.705700E+01,3.295000E+02,1.533900E+03,3.230400E+03,7.888600E+03,& + & 2.437700E+04,2.768386E+05,4.295800E-02,9.717400E-02,1.894900E-01,& + & 3.672300E-01,7.609000E-01,1.791800E+00,5.115100E+00,1.982800E+01,& + & 1.650600E+02,7.671600E+02,1.615600E+03,3.944700E+03,1.218900E+04,& + & 1.384193E+05,3.506200E-04,8.933000E-04,1.715600E-03,3.286600E-03,& + & 6.802200E-03,1.646100E-02,5.590000E-02,2.596400E-01,1.966300E+00,& + & 7.780100E+00,1.180300E+01,1.730500E+01,2.417900E+01,3.841954E+01,& + & 1.570700E-01,3.399600E-01,6.551200E-01,1.252400E+00,2.575700E+00,& + & 6.177400E+00,1.830400E+01,8.093600E+01,7.128200E+02,3.357300E+03,& + & 6.926800E+03,1.721800E+04,5.276200E+04,5.388803E+05,1.255200E-01,& + & 2.754800E-01,5.353400E-01,1.019900E+00,2.086300E+00,4.860900E+00,& + & 1.390700E+01,6.082400E+01,5.347300E+02,2.518100E+03,5.195300E+03,& + & 1.291400E+04,3.957200E+04,4.041652E+05,8.666800E-02,1.925600E-01,& + & 3.772900E-01,7.238800E-01,1.491500E+00,3.504800E+00,9.814800E+00,& + & 4.084800E+01,3.566400E+02,1.678800E+03,3.463700E+03,8.609400E+03,& + & 2.638100E+04,2.694409E+05,4.584700E-02,1.032400E-01,2.048700E-01,& + & 3.969900E-01,8.302900E-01,1.958900E+00,5.581200E+00,2.158300E+01,& + & 1.786000E+02,8.396300E+02,1.732200E+03,4.305100E+03,1.319100E+04,& + & 1.347196E+05,3.647900E-04,9.132600E-04,1.741000E-03,3.319000E-03,& + & 6.846800E-03,1.659900E-02,5.798800E-02,2.862900E-01,2.087600E+00,& + & 7.856100E+00,1.165200E+01,1.688900E+01,2.322400E+01,3.487006E+01,& + & 1.028900E-01,2.692700E-01,4.655300E-01,8.990700E-01,1.817700E+00,& + & 4.273600E+00,1.239700E+01,5.526000E+01,5.304000E+02,2.645100E+03,& + & 5.588400E+03,1.324700E+04,4.099900E+04,6.968193E+05,8.324100E-02,& + & 2.145000E-01,3.783600E-01,7.317000E-01,1.483300E+00,3.435400E+00,& + & 9.597600E+00,4.161000E+01,3.979200E+02,1.984000E+03,4.191500E+03,& + & 9.935600E+03,3.074900E+04,5.226188E+05,5.815900E-02,1.487100E-01,& + & 2.654800E-01,5.151600E-01,1.049200E+00,2.458500E+00,6.913800E+00,& + & 2.841500E+01,2.654500E+02,1.322900E+03,2.794500E+03,6.624000E+03,& + & 2.050000E+04,3.484104E+05,3.125300E-02,7.922800E-02,1.442100E-01,& + & 2.805300E-01,5.756700E-01,1.354800E+00,3.894900E+00,1.577900E+01,& + & 1.333200E+02,6.617500E+02,1.397600E+03,3.312500E+03,1.025000E+04,& + & 1.742073E+05,2.406900E-04,6.604400E-04,1.302400E-03,2.545400E-03,& + & 5.325400E-03,1.293600E-02,4.104800E-02,1.725500E-01,1.522900E+00,& + & 7.239500E+00,1.187800E+01,1.848800E+01,2.821300E+01,5.071007E+01/ + data absb(:,581:600) / & + & 1.157100E-01,2.807200E-01,4.995300E-01,9.690400E-01,1.960500E+00,& + & 4.649600E+00,1.365500E+01,6.068700E+01,5.800200E+02,2.797600E+03,& + & 6.001800E+03,1.456000E+04,4.549300E+04,6.823980E+05,9.325300E-02,& + & 2.243400E-01,4.077300E-01,7.881100E-01,1.600100E+00,3.723400E+00,& + & 1.051300E+01,4.566100E+01,4.351300E+02,2.098300E+03,4.501500E+03,& + & 1.092000E+04,3.412000E+04,5.117954E+05,6.489500E-02,1.557700E-01,& + & 2.865700E-01,5.554100E-01,1.134900E+00,2.672400E+00,7.555300E+00,& + & 3.100300E+01,2.902600E+02,1.399100E+03,3.001200E+03,7.280200E+03,& + & 2.274700E+04,3.411955E+05,3.464100E-02,8.311400E-02,1.555200E-01,& + & 3.026000E-01,6.247700E-01,1.478300E+00,4.270400E+00,1.703400E+01,& + & 1.455900E+02,6.998100E+02,1.501000E+03,3.640500E+03,1.137400E+04,& + & 1.705978E+05,2.586800E-04,6.901900E-04,1.344900E-03,2.611600E-03,& + & 5.446400E-03,1.322800E-02,4.357400E-02,1.934300E-01,1.669800E+00,& + & 7.481300E+00,1.204900E+01,1.827000E+01,2.651600E+01,4.688385E+01,& + & 1.281500E-01,2.932900E-01,5.398000E-01,1.045400E+00,2.126900E+00,& + & 5.076900E+00,1.505600E+01,6.709500E+01,6.342200E+02,3.012500E+03,& + & 6.451700E+03,1.601600E+04,5.030200E+04,6.667522E+05,1.028400E-01,& + & 2.354600E-01,4.410900E-01,8.507400E-01,1.734300E+00,4.046000E+00,& + & 1.153500E+01,5.045100E+01,4.757800E+02,2.259500E+03,4.838900E+03,& + & 1.201200E+04,3.772600E+04,5.000540E+05,7.127700E-02,1.637900E-01,& + & 3.101500E-01,6.007700E-01,1.233200E+00,2.911100E+00,8.257700E+00,& + & 3.408900E+01,3.173600E+02,1.506500E+03,3.226200E+03,8.008500E+03,& + & 2.515100E+04,3.333673E+05,3.782400E-02,8.744500E-02,1.681400E-01,& + & 3.278000E-01,6.806200E-01,1.616300E+00,4.686300E+00,1.848600E+01,& + & 1.590400E+02,7.534600E+02,1.613500E+03,4.004600E+03,1.257600E+04,& + & 1.666860E+05,2.744900E-04,7.147100E-04,1.381300E-03,2.663900E-03,& + & 5.540700E-03,1.346200E-02,4.576700E-02,2.166600E-01,1.811200E+00,& + & 7.730900E+00,1.195100E+01,1.806300E+01,2.569000E+01,4.241960E+01,& + & 1.397400E-01,3.084300E-01,5.846100E-01,1.127500E+00,2.318200E+00,& + & 5.570800E+00,1.662100E+01,7.459300E+01,6.915400E+02,3.297900E+03,& + & 6.951500E+03,1.760200E+04,5.525700E+04,6.500306E+05,1.117400E-01,& + & 2.487200E-01,4.779300E-01,9.187600E-01,1.884900E+00,4.415500E+00,& + & 1.267800E+01,5.607000E+01,5.187700E+02,2.473600E+03,5.213800E+03,& + & 1.320200E+04,4.144300E+04,4.875326E+05,7.716800E-02,1.732600E-01,& + & 3.360300E-01,6.504100E-01,1.343500E+00,3.181300E+00,9.022000E+00,& + & 3.775000E+01,3.460100E+02,1.649200E+03,3.476100E+03,8.801200E+03,& + & 2.762900E+04,3.250222E+05,4.076600E-02,9.249800E-02,1.818700E-01,& + & 3.553300E-01,7.441600E-01,1.771600E+00,5.130900E+00,2.019300E+01,& + & 1.733100E+02,8.247900E+02,1.738400E+03,4.401000E+03,1.381500E+04,& + & 1.625112E+05,2.884900E-04,7.350600E-04,1.410500E-03,2.701700E-03,& + & 5.601900E-03,1.363700E-02,4.777800E-02,2.421000E-01,1.947000E+00,& + & 7.873500E+00,1.193800E+01,1.755300E+01,2.481900E+01,3.841294E+01,& + & 1.503300E-01,3.268500E-01,6.340100E-01,1.218800E+00,2.529100E+00,& + & 6.133800E+00,1.845400E+01,8.291200E+01,7.525900E+02,3.647500E+03,& + & 7.528900E+03,1.932800E+04,6.017500E+04,6.324772E+05,1.199000E-01,& + & 2.647000E-01,5.180400E-01,9.933700E-01,2.051300E+00,4.831100E+00,& + & 1.402400E+01,6.230500E+01,5.645600E+02,2.735700E+03,5.646900E+03,& + & 1.449600E+04,4.513100E+04,4.743649E+05,8.257600E-02,1.845900E-01,& + & 3.644700E-01,7.044600E-01,1.466300E+00,3.482200E+00,9.903600E+00,& + & 4.183600E+01,3.765300E+02,1.823900E+03,3.764800E+03,9.664100E+03,& + & 3.008800E+04,3.162420E+05,4.349600E-02,9.847600E-02,1.970200E-01,& + & 3.852600E-01,8.150900E-01,1.944500E+00,5.629100E+00,2.209300E+01,& + & 1.885400E+02,9.121800E+02,1.882700E+03,4.832400E+03,1.504400E+04,& + & 1.581224E+05,2.998300E-04,7.512100E-04,1.432900E-03,2.729800E-03,& + & 5.640800E-03,1.375300E-02,4.968300E-02,2.693900E-01,2.078600E+00,& + & 7.902700E+00,1.189200E+01,1.704800E+01,2.383700E+01,3.470394E+01/ + data absb(:,601:620) / & + & 9.434000E-02,2.496500E-01,4.324700E-01,8.374800E-01,1.699700E+00,& + & 4.023400E+00,1.179300E+01,5.313600E+01,5.276100E+02,2.681900E+03,& + & 5.711400E+03,1.395200E+04,4.359700E+04,7.993756E+05,7.622600E-02,& + & 1.986500E-01,3.513600E-01,6.820800E-01,1.389400E+00,3.247300E+00,& + & 9.160400E+00,4.002400E+01,3.958300E+02,2.011600E+03,4.283800E+03,& + & 1.046400E+04,3.269800E+04,5.995278E+05,5.314000E-02,1.374900E-01,& + & 2.460300E-01,4.795800E-01,9.819000E-01,2.323200E+00,6.614600E+00,& + & 2.740300E+01,2.640500E+02,1.341300E+03,2.856100E+03,6.976500E+03,& + & 2.179900E+04,3.996772E+05,2.845600E-02,7.298300E-02,1.331300E-01,& + & 2.602600E-01,5.374800E-01,1.278800E+00,3.723400E+00,1.529500E+01,& + & 1.326900E+02,6.709600E+02,1.428400E+03,3.488700E+03,1.090000E+04,& + & 1.998417E+05,1.955900E-04,5.391400E-04,1.064400E-03,2.081900E-03,& + & 4.366600E-03,1.067100E-02,3.470700E-02,1.537400E-01,1.466900E+00,& + & 7.201700E+00,1.198300E+01,1.880100E+01,2.867800E+01,5.201936E+01,& + & 1.063400E-01,2.604200E-01,4.640900E-01,9.043700E-01,1.837800E+00,& + & 4.389200E+00,1.304100E+01,5.870000E+01,5.810700E+02,2.858300E+03,& + & 6.162900E+03,1.545700E+04,4.896300E+04,7.828679E+05,8.561200E-02,& + & 2.078900E-01,3.789300E-01,7.361900E-01,1.503000E+00,3.529000E+00,& + & 1.007000E+01,4.417300E+01,4.359300E+02,2.143900E+03,4.622400E+03,& + & 1.159300E+04,3.672300E+04,5.871606E+05,5.945200E-02,1.440700E-01,& + & 2.658800E-01,5.182200E-01,1.065400E+00,2.532400E+00,7.260400E+00,& + & 3.004800E+01,2.907900E+02,1.429400E+03,3.081800E+03,7.728700E+03,& + & 2.448200E+04,3.914392E+05,3.163000E-02,7.657500E-02,1.437800E-01,& + & 2.814400E-01,5.854000E-01,1.399800E+00,4.104600E+00,1.658800E+01,& + & 1.459000E+02,7.149500E+02,1.541300E+03,3.864800E+03,1.224100E+04,& + & 1.957157E+05,2.105900E-04,5.637200E-04,1.101100E-03,2.138300E-03,& + & 4.469100E-03,1.092400E-02,3.686400E-02,1.743000E-01,1.620000E+00,& + & 7.500300E+00,1.210500E+01,1.863700E+01,2.707900E+01,4.789538E+01,& + & 1.180300E-01,2.721700E-01,5.019300E-01,9.772400E-01,1.999400E+00,& + & 4.809000E+00,1.443900E+01,6.537000E+01,6.393600E+02,3.104200E+03,& + & 6.666800E+03,1.714100E+04,5.465500E+04,7.650154E+05,9.464100E-02,& + & 2.183300E-01,4.104000E-01,7.964500E-01,1.634100E+00,3.847700E+00,& + & 1.108800E+01,4.915800E+01,4.796400E+02,2.328300E+03,5.000300E+03,& + & 1.285600E+04,4.099100E+04,5.737660E+05,6.546900E-02,1.515700E-01,& + & 2.881400E-01,5.619600E-01,1.161700E+00,2.768800E+00,7.965900E+00,& + & 3.325700E+01,3.199300E+02,1.552300E+03,3.333800E+03,8.570700E+03,& + & 2.732800E+04,3.825043E+05,3.463100E-02,8.059300E-02,1.556800E-01,& + & 3.057400E-01,6.401900E-01,1.537000E+00,4.524400E+00,1.811000E+01,& + & 1.603600E+02,7.764000E+02,1.667300E+03,4.285700E+03,1.366400E+04,& + & 1.912549E+05,2.238100E-04,5.844800E-04,1.131300E-03,2.183500E-03,& + & 4.548100E-03,1.112200E-02,3.879500E-02,1.974400E-01,1.768700E+00,& + & 7.764600E+00,1.206300E+01,1.842000E+01,2.627400E+01,4.317529E+01,& + & 1.289300E-01,2.863300E-01,5.442300E-01,1.056000E+00,2.186000E+00,& + & 5.298200E+00,1.602500E+01,7.307900E+01,7.014900E+02,3.427200E+03,& + & 7.244100E+03,1.898500E+04,6.050600E+04,7.458400E+05,1.030200E-01,& + & 2.307600E-01,4.453800E-01,8.619800E-01,1.782600E+00,4.214300E+00,& + & 1.224500E+01,5.493400E+01,5.262300E+02,2.570500E+03,5.433300E+03,& + & 1.423900E+04,4.538000E+04,5.593831E+05,7.101900E-02,1.604300E-01,& + & 3.127500E-01,6.098600E-01,1.270700E+00,3.037400E+00,8.744200E+00,& + & 3.701700E+01,3.509800E+02,1.713800E+03,3.622400E+03,9.492800E+03,& + & 3.025300E+04,3.729174E+05,3.740000E-02,8.531000E-02,1.687000E-01,& + & 3.324600E-01,7.028300E-01,1.691500E+00,4.977300E+00,1.987600E+01,& + & 1.758100E+02,8.571400E+02,1.811500E+03,4.746700E+03,1.512700E+04,& + & 1.864548E+05,2.354900E-04,6.021600E-04,1.156300E-03,2.216700E-03,& + & 4.605600E-03,1.127500E-02,4.061300E-02,2.229900E-01,1.910400E+00,& + & 7.923300E+00,1.210300E+01,1.780500E+01,2.550400E+01,3.898378E+01/ + data absb(:,621:640) / & + & 1.388200E-01,3.035600E-01,5.912500E-01,1.143500E+00,2.391400E+00,& + & 5.859900E+00,1.788200E+01,8.172900E+01,7.680100E+02,3.822500E+03,& + & 7.925600E+03,2.096600E+04,6.635300E+04,7.256894E+05,1.106600E-01,& + & 2.458200E-01,4.835900E-01,9.339900E-01,1.945600E+00,4.630800E+00,& + & 1.360500E+01,6.141700E+01,5.761200E+02,2.867000E+03,5.944300E+03,& + & 1.572400E+04,4.976500E+04,5.442715E+05,7.607400E-02,1.711000E-01,& + & 3.398200E-01,6.621800E-01,1.391100E+00,3.339900E+00,9.642000E+00,& + & 4.125800E+01,3.842400E+02,1.911500E+03,3.963100E+03,1.048300E+04,& + & 3.317700E+04,3.628420E+05,3.994400E-02,9.092900E-02,1.831000E-01,& + & 3.614800E-01,7.727000E-01,1.865200E+00,5.488000E+00,2.185200E+01,& + & 1.924000E+02,9.559600E+02,1.981900E+03,5.241900E+03,1.658900E+04,& + & 1.814265E+05,2.450500E-04,6.161500E-04,1.176200E-03,2.242300E-03,& + & 4.641600E-03,1.138200E-02,4.233900E-02,2.507400E-01,2.049200E+00,& + & 7.945600E+00,1.205200E+01,1.734300E+01,2.438500E+01,3.525441E+01,& + & 8.766600E-02,2.348500E-01,4.075200E-01,7.916400E-01,1.612300E+00,& + & 3.840500E+00,1.138300E+01,5.188900E+01,5.332000E+02,2.766900E+03,& + & 5.945700E+03,1.493600E+04,4.729600E+04,9.294947E+05,7.072400E-02,& + & 1.866100E-01,3.308400E-01,6.448900E-01,1.319300E+00,3.109400E+00,& + & 8.866600E+00,3.909400E+01,4.000200E+02,2.075300E+03,4.459500E+03,& + & 1.120200E+04,3.547200E+04,6.971012E+05,4.918900E-02,1.289100E-01,& + & 2.311600E-01,4.527500E-01,9.313900E-01,2.223200E+00,6.413400E+00,& + & 2.681900E+01,2.668600E+02,1.383700E+03,2.973200E+03,7.468400E+03,& + & 2.364800E+04,4.647394E+05,2.624400E-02,6.817800E-02,1.245700E-01,& + & 2.448100E-01,5.084900E-01,1.222300E+00,3.607200E+00,1.501700E+01,& + & 1.341400E+02,6.921700E+02,1.487000E+03,3.734600E+03,1.182500E+04,& + & 2.323693E+05,1.588100E-04,4.397000E-04,8.698500E-04,1.703300E-03,& + & 3.578400E-03,8.801100E-03,2.929800E-02,1.371100E-01,1.415000E+00,& + & 7.172400E+00,1.204000E+01,1.906700E+01,2.911400E+01,5.327618E+01,& + & 9.907500E-02,2.451500E-01,4.373400E-01,8.563100E-01,1.747900E+00,& + & 4.202600E+00,1.264300E+01,5.766500E+01,5.914800E+02,2.977200E+03,& + & 6.440400E+03,1.669300E+04,5.369100E+04,9.104591E+05,7.966600E-02,& + & 1.954300E-01,3.570100E-01,6.973500E-01,1.431600E+00,3.389400E+00,& + & 9.785900E+00,4.339700E+01,4.437300E+02,2.233000E+03,4.830500E+03,& + & 1.252000E+04,4.026900E+04,6.828400E+05,5.520800E-02,1.351500E-01,& + & 2.500600E-01,4.902500E-01,1.013900E+00,2.431700E+00,7.069900E+00,& + & 2.956100E+01,2.959900E+02,1.488800E+03,3.220600E+03,8.346700E+03,& + & 2.684600E+04,4.552163E+05,2.927000E-02,7.154600E-02,1.347200E-01,& + & 2.653700E-01,5.558000E-01,1.342900E+00,3.997200E+00,1.636800E+01,& + & 1.485400E+02,7.446700E+02,1.610700E+03,4.173700E+03,1.342300E+04,& + & 2.276076E+05,1.713500E-04,4.605200E-04,9.001100E-04,1.752000E-03,& + & 3.667000E-03,9.020400E-03,3.114800E-02,1.573400E-01,1.573800E+00,& + & 7.538200E+00,1.213500E+01,1.896800E+01,2.773000E+01,4.865706E+01,& + & 1.102200E-01,2.562900E-01,4.734200E-01,9.268100E-01,1.907400E+00,& + & 4.622300E+00,1.405600E+01,6.466800E+01,6.550500E+02,3.263000E+03,& + & 7.010300E+03,1.866700E+04,6.044800E+04,8.896968E+05,8.829400E-02,& + & 2.053300E-01,3.871700E-01,7.560500E-01,1.561500E+00,3.709400E+00,& + & 1.081400E+01,4.863100E+01,4.914100E+02,2.447300E+03,5.257900E+03,& + & 1.400000E+04,4.533600E+04,6.672784E+05,6.096100E-02,1.422500E-01,& + & 2.713700E-01,5.329400E-01,1.109200E+00,2.668800E+00,7.786200E+00,& + & 3.293300E+01,3.277800E+02,1.631700E+03,3.505500E+03,9.333700E+03,& + & 3.022400E+04,4.448404E+05,3.214000E-02,7.533000E-02,1.461100E-01,& + & 2.891100E-01,6.101500E-01,1.480500E+00,4.422900E+00,1.798100E+01,& + & 1.643000E+02,8.160900E+02,1.753100E+03,4.667200E+03,1.511300E+04,& + & 2.224241E+05,1.824800E-04,4.781100E-04,9.269900E-04,1.789300E-03,& + & 3.737100E-03,9.188900E-03,3.286700E-02,1.802800E-01,1.728900E+00,& + & 7.785700E+00,1.220100E+01,1.866700E+01,2.699500E+01,4.373266E+01/ + data absb(:,641:660) / & + & 1.206300E-01,2.697100E-01,5.139800E-01,1.003200E+00,2.091100E+00,& + & 5.113500E+00,1.568600E+01,7.278500E+01,7.234500E+02,3.629200E+03,& + & 7.688300E+03,2.083800E+04,6.740800E+04,8.674770E+05,9.631000E-02,& + & 2.171500E-01,4.208000E-01,8.198600E-01,1.708900E+00,4.078600E+00,& + & 1.200200E+01,5.471300E+01,5.427000E+02,2.722000E+03,5.766400E+03,& + & 1.562800E+04,5.055600E+04,6.505937E+05,6.627000E-02,1.506500E-01,& + & 2.950700E-01,5.795900E-01,1.217600E+00,2.940000E+00,8.591500E+00,& + & 3.688700E+01,3.619700E+02,1.814900E+03,3.844400E+03,1.041900E+04,& + & 3.370400E+04,4.337412E+05,3.478600E-02,7.978800E-02,1.586200E-01,& + & 3.152100E-01,6.725600E-01,1.636600E+00,4.893500E+00,1.984600E+01,& + & 1.813100E+02,9.076900E+02,1.922500E+03,5.209800E+03,1.685200E+04,& + & 2.168685E+05,1.922800E-04,4.933000E-04,9.479500E-04,1.819700E-03,& + & 3.786900E-03,9.326600E-03,3.451700E-02,2.060100E-01,1.875900E+00,& + & 7.964900E+00,1.226400E+01,1.809000E+01,2.616400E+01,3.937976E+01,& + & 1.300200E-01,2.860500E-01,5.592600E-01,1.088500E+00,2.294800E+00,& + & 5.681200E+00,1.759500E+01,8.184600E+01,7.974000E+02,4.074300E+03,& + & 8.500300E+03,2.315200E+04,7.436100E+04,8.440839E+05,1.035500E-01,& + & 2.315100E-01,4.576900E-01,8.904700E-01,1.871200E+00,4.499700E+00,& + & 1.340000E+01,6.150400E+01,5.981600E+02,3.055900E+03,6.375400E+03,& + & 1.736400E+04,5.577100E+04,6.330593E+05,7.105800E-02,1.608300E-01,& + & 3.212300E-01,6.310200E-01,1.337900E+00,3.245700E+00,9.517900E+00,& + & 4.132800E+01,3.989400E+02,2.037400E+03,4.250400E+03,1.157600E+04,& + & 3.718100E+04,4.220384E+05,3.718800E-02,8.513300E-02,1.725200E-01,& + & 3.437900E-01,7.423600E-01,1.812500E+00,5.420800E+00,2.192100E+01,& + & 1.997500E+02,1.019000E+03,2.125500E+03,5.788300E+03,1.859100E+04,& + & 2.110223E+05,2.002800E-04,5.054700E-04,9.653900E-04,1.843200E-03,& + & 3.818000E-03,9.432700E-03,3.606700E-02,2.341500E-01,2.022100E+00,& + & 7.977100E+00,1.221400E+01,1.763400E+01,2.502500E+01,3.554525E+01,& + & 8.331900E-02,2.260200E-01,3.928600E-01,7.656100E-01,1.565300E+00,& + & 3.751300E+00,1.125400E+01,5.194600E+01,5.526800E+02,2.926800E+03,& + & 6.357400E+03,1.641100E+04,5.278700E+04,1.104282E+06,6.708300E-02,& + & 1.792700E-01,3.185300E-01,6.233700E-01,1.280900E+00,3.042900E+00,& + & 8.778500E+00,3.914100E+01,4.146300E+02,2.195300E+03,4.768300E+03,& + & 1.230900E+04,3.959100E+04,8.282233E+05,4.654000E-02,1.235800E-01,& + & 2.220400E-01,4.368500E-01,9.030600E-01,2.173500E+00,6.353200E+00,& + & 2.687400E+01,2.766000E+02,1.463700E+03,3.179200E+03,8.206200E+03,& + & 2.639400E+04,5.521541E+05,2.473200E-02,6.510300E-02,1.191000E-01,& + & 2.353100E-01,4.915200E-01,1.192700E+00,3.569800E+00,1.505600E+01,& + & 1.390500E+02,7.321300E+02,1.590000E+03,4.103500E+03,1.319800E+04,& + & 2.760771E+05,1.290300E-04,3.589300E-04,7.102700E-04,1.395100E-03,& + & 2.933900E-03,7.268100E-03,2.470300E-02,1.225400E-01,1.368300E+00,& + & 7.169100E+00,1.205800E+01,1.936200E+01,2.954300E+01,5.426368E+01,& + & 9.440900E-02,2.361100E-01,4.216800E-01,8.295900E-01,1.701100E+00,& + & 4.118500E+00,1.254600E+01,5.811500E+01,6.173700E+02,3.183200E+03,& + & 6.917200E+03,1.852000E+04,6.048100E+04,1.081833E+06,7.578800E-02,& + & 1.878900E-01,3.439200E-01,6.754400E-01,1.393900E+00,3.327200E+00,& + & 9.723800E+00,4.373500E+01,4.631600E+02,2.387500E+03,5.188200E+03,& + & 1.389000E+04,4.536200E+04,8.113840E+05,5.240100E-02,1.296500E-01,& + & 2.404000E-01,4.741100E-01,9.860500E-01,2.385300E+00,7.031900E+00,& + & 2.980300E+01,3.089500E+02,1.591900E+03,3.459100E+03,9.260300E+03,& + & 3.024200E+04,5.409316E+05,2.767900E-02,6.834700E-02,1.289900E-01,& + & 2.557200E-01,5.390300E-01,1.315600E+00,3.972500E+00,1.650700E+01,& + & 1.550400E+02,7.961900E+02,1.729900E+03,4.630500E+03,1.512100E+04,& + & 2.704640E+05,1.395800E-04,3.762600E-04,7.360600E-04,1.436200E-03,& + & 3.011000E-03,7.451700E-03,2.632800E-02,1.424100E-01,1.532000E+00,& + & 7.553600E+00,1.222100E+01,1.925600E+01,2.839800E+01,4.917822E+01/ + data absb(:,661:680) / & + & 1.053000E-01,2.469300E-01,4.568500E-01,8.995500E-01,1.862500E+00,& + & 4.548000E+00,1.401000E+01,6.563800E+01,6.882100E+02,3.525100E+03,& + & 7.576800E+03,2.087800E+04,6.864400E+04,1.057272E+06,8.422500E-02,& + & 1.975100E-01,3.734400E-01,7.338600E-01,1.525700E+00,3.655400E+00,& + & 1.078900E+01,4.936100E+01,5.162800E+02,2.644000E+03,5.682800E+03,& + & 1.565900E+04,5.148300E+04,7.929744E+05,5.802700E-02,1.365300E-01,& + & 2.612900E-01,5.166400E-01,1.082700E+00,2.628500E+00,7.776400E+00,& + & 3.343200E+01,3.443600E+02,1.762800E+03,3.788800E+03,1.043900E+04,& + & 3.432300E+04,5.286484E+05,3.048600E-02,7.199400E-02,1.401400E-01,& + & 2.794100E-01,5.941600E-01,1.456400E+00,4.415200E+00,1.825200E+01,& + & 1.726000E+02,8.816800E+02,1.894800E+03,5.220000E+03,1.716200E+04,& + & 2.643207E+05,1.489400E-04,3.911200E-04,7.595600E-04,1.468100E-03,& + & 3.072000E-03,7.601300E-03,2.785400E-02,1.653500E-01,1.692000E+00,& + & 7.808900E+00,1.238500E+01,1.884200E+01,2.768600E+01,4.412788E+01,& + & 1.154400E-01,2.599800E-01,4.966700E-01,9.753300E-01,2.048000E+00,& + & 5.052200E+00,1.571400E+01,7.428100E+01,7.655500E+02,3.950400E+03,& + & 8.385200E+03,2.348100E+04,7.702400E+04,1.031081E+06,9.206100E-02,& + & 2.090300E-01,4.065200E-01,7.974500E-01,1.674900E+00,4.035100E+00,& + & 1.203100E+01,5.583500E+01,5.742900E+02,2.962900E+03,6.289100E+03,& + & 1.761100E+04,5.776800E+04,7.733087E+05,6.322600E-02,1.447000E-01,& + & 2.846200E-01,5.631900E-01,1.192700E+00,2.907400E+00,8.619000E+00,& + & 3.764400E+01,3.830200E+02,1.975500E+03,4.193000E+03,1.174100E+04,& + & 3.851300E+04,5.155491E+05,3.307100E-02,7.631600E-02,1.524500E-01,& + & 3.054700E-01,6.576300E-01,1.616700E+00,4.907000E+00,2.024600E+01,& + & 1.918400E+02,9.880400E+02,2.096800E+03,5.870900E+03,1.925700E+04,& + & 2.577745E+05,1.571300E-04,4.043100E-04,7.777000E-04,1.495200E-03,& + & 3.117600E-03,7.718500E-03,2.932500E-02,1.911400E-01,1.846800E+00,& + & 7.978600E+00,1.241700E+01,1.842700E+01,2.662700E+01,3.973342E+01,& + & 1.245700E-01,2.757700E-01,5.413300E-01,1.060600E+00,2.254500E+00,& + & 5.641100E+00,1.775200E+01,8.411700E+01,8.496500E+02,4.459800E+03,& + & 9.374400E+03,2.625800E+04,8.540400E+04,1.003376E+06,9.910200E-02,& + & 2.229700E-01,4.429600E-01,8.682900E-01,1.840300E+00,4.472100E+00,& + & 1.352500E+01,6.320500E+01,6.373600E+02,3.345000E+03,7.031000E+03,& + & 1.969300E+04,6.405300E+04,7.525372E+05,6.787900E-02,1.545800E-01,& + & 3.104500E-01,6.148700E-01,1.315000E+00,3.225000E+00,9.612400E+00,& + & 4.246500E+01,4.250800E+02,2.230200E+03,4.687500E+03,1.312900E+04,& + & 4.270300E+04,5.009958E+05,3.540000E-02,8.150000E-02,1.661900E-01,& + & 3.342400E-01,7.285400E-01,1.799200E+00,5.471800E+00,2.250700E+01,& + & 2.128200E+02,1.115400E+03,2.344100E+03,6.564900E+03,2.135200E+04,& + & 2.508512E+05,1.637200E-04,4.152000E-04,7.933400E-04,1.516300E-03,& + & 3.142400E-03,7.824500E-03,3.078800E-02,2.195400E-01,1.996900E+00,& + & 8.007300E+00,1.240000E+01,1.800500E+01,2.549900E+01,3.567608E+01,& + & 7.338200E-02,2.034700E-01,3.535500E-01,6.904200E-01,1.416100E+00,& + & 3.410000E+00,1.034300E+01,4.837200E+01,5.331100E+02,2.887400E+03,& + & 6.354400E+03,1.677900E+04,5.478700E+04,1.233797E+06,5.909100E-02,& + & 1.612800E-01,2.866900E-01,5.631400E-01,1.161800E+00,2.780600E+00,& + & 8.114900E+00,3.647600E+01,3.999600E+02,2.165700E+03,4.766000E+03,& + & 1.258400E+04,4.109000E+04,9.253331E+05,4.094900E-02,1.110700E-01,& + & 1.995600E-01,3.943900E-01,8.188300E-01,1.985600E+00,5.888000E+00,& + & 2.516700E+01,2.668200E+02,1.443900E+03,3.177600E+03,8.389800E+03,& + & 2.739400E+04,6.168986E+05,2.172000E-02,5.837300E-02,1.067300E-01,& + & 2.120200E-01,4.450600E-01,1.089600E+00,3.307700E+00,1.420000E+01,& + & 1.342800E+02,7.222100E+02,1.589300E+03,4.195200E+03,1.369700E+04,& + & 3.084413E+05,1.036900E-04,2.908800E-04,5.772100E-04,1.136700E-03,& + & 2.396100E-03,5.976800E-03,2.066200E-02,1.078600E-01,1.306900E+00,& + & 7.074600E+00,1.203400E+01,1.957300E+01,3.018300E+01,5.580120E+01/ + data absb(:,681:700) / & + & 8.349200E-02,2.127500E-01,3.790700E-01,7.488800E-01,1.542200E+00,& + & 3.754100E+00,1.158100E+01,5.443500E+01,5.997900E+02,3.172400E+03,& + & 6.954700E+03,1.911800E+04,6.332300E+04,1.209233E+06,6.705400E-02,& + & 1.692100E-01,3.094400E-01,6.110800E-01,1.267500E+00,3.050500E+00,& + & 9.021500E+00,4.098500E+01,4.499700E+02,2.379400E+03,5.216200E+03,& + & 1.433900E+04,4.749200E+04,9.069151E+05,4.631700E-02,1.165900E-01,& + & 2.160800E-01,4.287800E-01,8.966100E-01,2.186800E+00,6.547700E+00,& + & 2.803500E+01,3.001600E+02,1.586400E+03,3.477700E+03,9.559300E+03,& + & 3.166200E+04,6.046112E+05,2.442200E-02,6.129600E-02,1.156900E-01,& + & 2.308500E-01,4.896100E-01,1.206700E+00,3.700800E+00,1.564400E+01,& + & 1.507200E+02,7.934600E+02,1.739300E+03,4.780000E+03,1.583100E+04,& + & 3.023003E+05,1.125800E-04,3.055000E-04,5.993300E-04,1.172100E-03,& + & 2.463400E-03,6.134800E-03,2.208400E-02,1.271300E-01,1.475300E+00,& + & 7.483100E+00,1.225200E+01,1.949600E+01,2.896100E+01,5.057620E+01,& + & 9.350200E-02,2.224800E-01,4.107500E-01,8.136200E-01,1.692900E+00,& + & 4.160000E+00,1.298600E+01,6.181400E+01,6.734300E+02,3.546500E+03,& + & 7.653800E+03,2.174700E+04,7.246300E+04,1.182375E+06,7.484500E-02,& + & 1.778700E-01,3.363500E-01,6.653900E-01,1.391400E+00,3.363600E+00,& + & 1.004400E+01,4.649800E+01,5.051900E+02,2.660000E+03,5.740500E+03,& + & 1.631000E+04,5.434800E+04,8.867806E+05,5.151400E-02,1.227900E-01,& + & 2.351400E-01,4.683200E-01,9.876200E-01,2.419400E+00,7.271000E+00,& + & 3.158200E+01,3.369700E+02,1.773500E+03,3.827200E+03,1.087400E+04,& + & 3.623200E+04,5.911823E+05,2.702100E-02,6.456200E-02,1.258700E-01,& + & 2.528700E-01,5.417800E-01,1.341500E+00,4.132200E+00,1.737100E+01,& + & 1.689600E+02,8.870300E+02,1.914000E+03,5.437200E+03,1.811600E+04,& + & 2.955920E+05,1.204900E-04,3.183000E-04,6.194300E-04,1.199800E-03,& + & 2.518200E-03,6.267600E-03,2.343100E-02,1.495700E-01,1.640600E+00,& + & 7.769200E+00,1.246100E+01,1.907800E+01,2.829500E+01,4.529510E+01,& + & 1.028900E-01,2.341900E-01,4.470700E-01,8.837300E-01,1.867100E+00,& + & 4.640400E+00,1.463800E+01,7.045500E+01,7.547200E+02,4.004400E+03,& + & 8.537300E+03,2.464100E+04,8.186700E+04,1.153467E+06,8.211500E-02,& + & 1.882400E-01,3.666800E-01,7.247900E-01,1.532700E+00,3.727800E+00,& + & 1.124700E+01,5.296600E+01,5.661500E+02,3.003500E+03,6.403100E+03,& + & 1.848100E+04,6.140000E+04,8.651133E+05,5.633900E-02,1.301300E-01,& + & 2.565800E-01,5.118800E-01,1.091800E+00,2.688000E+00,8.099300E+00,& + & 3.577700E+01,3.776000E+02,2.002500E+03,4.268900E+03,1.232100E+04,& + & 4.093300E+04,5.767298E+05,2.941900E-02,6.843400E-02,1.371700E-01,& + & 2.773000E-01,6.019600E-01,1.496300E+00,4.619600E+00,1.937300E+01,& + & 1.891600E+02,1.001600E+03,2.134800E+03,6.160500E+03,2.046700E+04,& + & 2.883666E+05,1.274400E-04,3.297500E-04,6.352600E-04,1.224200E-03,& + & 2.559500E-03,6.371300E-03,2.477600E-02,1.750700E-01,1.799900E+00,& + & 7.963200E+00,1.253300E+01,1.868000E+01,2.718400E+01,4.076718E+01,& + & 1.113200E-01,2.482400E-01,4.880300E-01,9.625400E-01,2.061000E+00,& + & 5.203500E+00,1.662500E+01,8.031400E+01,8.437900E+02,4.545400E+03,& + & 9.638800E+03,2.774100E+04,9.132500E+04,1.122900E+06,8.860400E-02,& + & 2.008100E-01,4.002500E-01,7.907000E-01,1.690000E+00,4.147600E+00,& + & 1.270000E+01,6.035200E+01,6.329600E+02,3.409200E+03,7.229200E+03,& + & 2.080600E+04,6.849400E+04,8.421782E+05,6.062900E-02,1.390300E-01,& + & 2.803900E-01,5.601500E-01,1.208400E+00,2.994800E+00,9.074000E+00,& + & 4.059800E+01,4.221400E+02,2.273000E+03,4.819600E+03,1.387100E+04,& + & 4.566300E+04,5.614498E+05,3.155900E-02,7.309800E-02,1.498100E-01,& + & 3.043000E-01,6.696100E-01,1.673000E+00,5.178700E+00,2.164300E+01,& + & 2.113600E+02,1.136800E+03,2.410100E+03,6.935600E+03,2.283200E+04,& + & 2.807214E+05,1.331700E-04,3.391300E-04,6.490500E-04,1.243400E-03,& + & 2.583100E-03,6.466700E-03,2.610300E-02,2.033900E-01,1.955800E+00,& + & 8.008100E+00,1.252600E+01,1.830500E+01,2.598800E+01,3.659318E+01/ + data absb(:,701:720) / & + & 6.428900E-02,1.825800E-01,3.172200E-01,6.203200E-01,1.276500E+00,& + & 3.089100E+00,9.468300E+00,4.486300E+01,5.126000E+02,2.840600E+03,& + & 6.352100E+03,1.710800E+04,5.676400E+04,1.374655E+06,5.178300E-02,& + & 1.447000E-01,2.572100E-01,5.068800E-01,1.050000E+00,2.532300E+00,& + & 7.475700E+00,3.386500E+01,3.845800E+02,2.130600E+03,4.764300E+03,& + & 1.283100E+04,4.257300E+04,1.030995E+06,3.585100E-02,9.953500E-02,& + & 1.787800E-01,3.548200E-01,7.397700E-01,1.807600E+00,5.437800E+00,& + & 2.349400E+01,2.565800E+02,1.420500E+03,3.176500E+03,8.554300E+03,& + & 2.838300E+04,6.873292E+05,1.898300E-02,5.220200E-02,9.535200E-02,& + & 1.904000E-01,4.015800E-01,9.919900E-01,3.054000E+00,1.334700E+01,& + & 1.292800E+02,7.105000E+02,1.588700E+03,4.277500E+03,1.419200E+04,& + & 3.436689E+05,8.320500E-05,2.353500E-04,4.683000E-04,9.254600E-04,& + & 1.955800E-03,4.910600E-03,1.724300E-02,9.462200E-02,1.245900E+00,& + & 6.960000E+00,1.199500E+01,1.975200E+01,3.079100E+01,5.738682E+01,& + & 7.348600E-02,1.911300E-01,3.398400E-01,6.739300E-01,1.393400E+00,& + & 3.410000E+00,1.064500E+01,5.083800E+01,5.813100E+02,3.148400E+03,& + & 6.992000E+03,1.969600E+04,6.613000E+04,1.347929E+06,5.904700E-02,& + & 1.519700E-01,2.776200E-01,5.511800E-01,1.148600E+00,2.786600E+00,& + & 8.340000E+00,3.830100E+01,4.361100E+02,2.361400E+03,5.244200E+03,& + & 1.477200E+04,4.959800E+04,1.010941E+06,4.075600E-02,1.045800E-01,& + & 1.936600E-01,3.866000E-01,8.125200E-01,1.997200E+00,6.074300E+00,& + & 2.631400E+01,2.909300E+02,1.574400E+03,3.496400E+03,9.848300E+03,& + & 3.306600E+04,6.739830E+05,2.145600E-02,5.484400E-02,1.034900E-01,& + & 2.077900E-01,4.432000E-01,1.102700E+00,3.433400E+00,1.479300E+01,& + & 1.462100E+02,7.874700E+02,1.748600E+03,4.924500E+03,1.653300E+04,& + & 3.369897E+05,9.060100E-05,2.477300E-04,4.876300E-04,9.554900E-04,& + & 2.015900E-03,5.045900E-03,1.848700E-02,1.132000E-01,1.417900E+00,& + & 7.395400E+00,1.228000E+01,1.966500E+01,2.953800E+01,5.204388E+01,& + & 8.265700E-02,1.999500E-01,3.680100E-01,7.332900E-01,1.532900E+00,& + & 3.791300E+00,1.199600E+01,5.806100E+01,6.574100E+02,3.557600E+03,& + & 7.737500E+03,2.260300E+04,7.624300E+04,1.318632E+06,6.621100E-02,& + & 1.597700E-01,3.019500E-01,6.011400E-01,1.264400E+00,3.083300E+00,& + & 9.325000E+00,4.369200E+01,4.931800E+02,2.668400E+03,5.803300E+03,& + & 1.695300E+04,5.718300E+04,9.889807E+05,4.553900E-02,1.101500E-01,& + & 2.109200E-01,4.230200E-01,8.977400E-01,2.218500E+00,6.779400E+00,& + & 2.977400E+01,3.289600E+02,1.779100E+03,3.869100E+03,1.130200E+04,& + & 3.812200E+04,6.593327E+05,2.385000E-02,5.776600E-02,1.126800E-01,& + & 2.281000E-01,4.922000E-01,1.231100E+00,3.854600E+00,1.650000E+01,& + & 1.650300E+02,8.898700E+02,1.934900E+03,5.651400E+03,1.906200E+04,& + & 3.296629E+05,9.730900E-05,2.586600E-04,5.046100E-04,9.800500E-04,& + & 2.064400E-03,5.162200E-03,1.968400E-02,1.350400E-01,1.587100E+00,& + & 7.717900E+00,1.249900E+01,1.934700E+01,2.877400E+01,4.661828E+01,& + & 9.132500E-02,2.103500E-01,4.010100E-01,7.978800E-01,1.695700E+00,& + & 4.243900E+00,1.358700E+01,6.660300E+01,7.422700E+02,4.052700E+03,& + & 8.690000E+03,2.579700E+04,8.673800E+04,1.286972E+06,7.295600E-02,& + & 1.690600E-01,3.296400E-01,6.563600E-01,1.397700E+00,3.430400E+00,& + & 1.048000E+01,5.008100E+01,5.568300E+02,3.039700E+03,6.517700E+03,& + & 1.934800E+04,6.505400E+04,9.652443E+05,5.001300E-02,1.167200E-01,& + & 2.305300E-01,4.635600E-01,9.960500E-01,2.475400E+00,7.584300E+00,& + & 3.390800E+01,3.713900E+02,2.026700E+03,4.345300E+03,1.289900E+04,& + & 4.337000E+04,6.434862E+05,2.607500E-02,6.121500E-02,1.230300E-01,& + & 2.508400E-01,5.491600E-01,1.379500E+00,4.332200E+00,1.849400E+01,& + & 1.860900E+02,1.013700E+03,2.173000E+03,6.449700E+03,2.168500E+04,& + & 3.217502E+05,1.032000E-04,2.686600E-04,5.186600E-04,1.001600E-03,& + & 2.099800E-03,5.259400E-03,2.090900E-02,1.601900E-01,1.749800E+00,& + & 7.944400E+00,1.262800E+01,1.892500E+01,2.777100E+01,4.182527E+01/ + data absb(:,721:740) / & + & 9.914900E-02,2.228100E-01,4.385400E-01,8.708200E-01,1.877800E+00,& + & 4.780700E+00,1.551300E+01,7.644800E+01,8.362300E+02,4.627000E+03,& + & 9.900800E+03,2.923700E+04,9.733800E+04,1.253468E+06,7.896900E-02,& + & 1.803100E-01,3.605700E-01,7.178900E-01,1.546600E+00,3.833700E+00,& + & 1.188600E+01,5.745400E+01,6.273000E+02,3.470400E+03,7.425700E+03,& + & 2.192800E+04,7.300400E+04,9.400910E+05,5.399100E-02,1.246900E-01,& + & 2.524900E-01,5.087100E-01,1.106700E+00,2.771500E+00,8.539600E+00,& + & 3.870600E+01,4.183700E+02,2.313800E+03,4.950700E+03,1.461900E+04,& + & 4.867000E+04,6.267208E+05,2.805700E-02,6.539300E-02,1.346700E-01,& + & 2.761500E-01,6.134600E-01,1.550700E+00,4.886400E+00,2.076500E+01,& + & 2.095000E+02,1.157200E+03,2.475600E+03,7.309800E+03,2.433500E+04,& + & 3.133718E+05,1.082500E-04,2.767500E-04,5.306000E-04,1.018800E-03,& + & 2.122400E-03,5.343600E-03,2.211300E-02,1.882800E-01,1.912200E+00,& + & 8.010800E+00,1.262200E+01,1.858700E+01,2.648100E+01,3.756688E+01,& + & 5.689900E-02,1.655500E-01,2.878000E-01,5.632700E-01,1.162700E+00,& + & 2.827800E+00,8.759600E+00,4.214300E+01,4.983100E+02,2.825800E+03,& + & 6.437700E+03,1.765000E+04,5.957400E+04,1.547142E+06,4.581200E-02,& + & 1.311800E-01,2.332000E-01,4.609300E-01,9.584100E-01,2.328300E+00,& + & 6.957500E+00,3.184600E+01,3.738600E+02,2.119400E+03,4.828500E+03,& + & 1.323800E+04,4.468000E+04,1.160354E+06,3.168600E-02,9.012500E-02,& + & 1.618200E-01,3.224100E-01,6.749400E-01,1.661100E+00,5.069500E+00,& + & 2.220400E+01,2.494400E+02,1.413100E+03,3.219300E+03,8.825300E+03,& + & 2.978700E+04,7.735580E+05,1.674700E-02,4.717200E-02,8.605000E-02,& + & 1.726600E-01,3.658300E-01,9.114200E-01,2.844200E+00,1.268000E+01,& + & 1.258400E+02,7.067800E+02,1.610100E+03,4.413000E+03,1.489400E+04,& + & 3.867808E+05,6.671900E-05,1.903500E-04,3.798700E-04,7.532800E-04,& + & 1.597500E-03,4.033100E-03,1.437500E-02,8.292800E-02,1.186500E+00,& + & 6.851700E+00,1.194300E+01,1.991300E+01,3.133800E+01,5.892985E+01,& + & 6.531600E-02,1.735100E-01,3.080600E-01,6.129500E-01,1.272300E+00,& + & 3.129500E+00,9.891800E+00,4.797300E+01,5.698000E+02,3.158100E+03,& + & 7.128400E+03,2.055200E+04,6.987400E+04,1.517843E+06,5.249400E-02,& + & 1.379100E-01,2.517100E-01,5.023200E-01,1.051300E+00,2.570200E+00,& + & 7.792100E+00,3.616700E+01,4.274800E+02,2.368700E+03,5.346500E+03,& + & 1.541400E+04,5.240500E+04,1.138381E+06,3.619800E-02,9.479700E-02,& + & 1.753500E-01,3.521200E-01,7.433900E-01,1.841700E+00,5.689500E+00,& + & 2.495300E+01,2.851700E+02,1.579300E+03,3.564600E+03,1.027600E+04,& + & 3.493700E+04,7.589216E+05,1.902600E-02,4.958600E-02,9.349400E-02,& + & 1.889000E-01,4.049600E-01,1.016900E+00,3.214500E+00,1.411700E+01,& + & 1.434200E+02,7.899000E+02,1.782700E+03,5.138500E+03,1.746900E+04,& + & 3.794554E+05,7.286200E-05,2.008600E-04,3.964900E-04,7.787700E-04,& + & 1.649800E-03,4.150700E-03,1.546900E-02,1.007200E-01,1.362200E+00,& + & 7.304900E+00,1.231100E+01,1.981700E+01,3.006600E+01,5.344755E+01,& + & 7.377900E-02,1.816700E-01,3.332600E-01,6.677700E-01,1.402900E+00,& + & 3.491000E+00,1.119600E+01,5.518300E+01,6.495500E+02,3.605900E+03,& + & 7.947200E+03,2.378000E+04,8.111800E+04,1.485665E+06,5.913600E-02,& + & 1.450400E-01,2.738300E-01,5.486100E-01,1.160400E+00,2.854400E+00,& + & 8.745000E+00,4.154200E+01,4.872800E+02,2.704600E+03,5.960600E+03,& + & 1.783500E+04,6.083900E+04,1.114240E+06,4.063900E-02,9.984300E-02,& + & 1.911100E-01,3.859000E-01,8.239700E-01,2.053600E+00,6.380800E+00,& + & 2.839500E+01,3.250300E+02,1.803200E+03,3.973900E+03,1.189000E+04,& + & 4.055900E+04,7.428191E+05,2.124900E-02,5.222900E-02,1.018800E-01,& + & 2.077600E-01,4.513600E-01,1.140100E+00,3.629000E+00,1.583500E+01,& + & 1.631300E+02,9.019300E+02,1.987300E+03,5.945500E+03,2.028000E+04,& + & 3.714068E+05,7.855700E-05,2.101600E-04,4.110300E-04,8.004300E-04,& + & 1.692100E-03,4.252500E-03,1.654200E-02,1.219500E-01,1.536100E+00,& + & 7.652400E+00,1.258000E+01,1.948700E+01,2.933000E+01,4.784511E+01/ + data absb(:,741:760) / & + & 8.187700E-02,1.910100E-01,3.635200E-01,7.279700E-01,1.556400E+00,& + & 3.923500E+00,1.275000E+01,6.370900E+01,7.390000E+02,4.149900E+03,& + & 8.976700E+03,2.733100E+04,9.291500E+04,1.450683E+06,6.544800E-02,& + & 1.534600E-01,2.993100E-01,6.003900E-01,1.287300E+00,3.188300E+00,& + & 9.874100E+00,4.791400E+01,5.543700E+02,3.112600E+03,6.732600E+03,& + & 2.049800E+04,6.968600E+04,1.088010E+06,4.482600E-02,1.058100E-01,& + & 2.092100E-01,4.239700E-01,9.177000E-01,2.301600E+00,7.175700E+00,& + & 3.251000E+01,3.697500E+02,2.075300E+03,4.488600E+03,1.366600E+04,& + & 4.645700E+04,7.253364E+05,2.333400E-02,5.533300E-02,1.114500E-01,& + & 2.291200E-01,5.057400E-01,1.283700E+00,4.101800E+00,1.783600E+01,& + & 1.853100E+02,1.038000E+03,2.244600E+03,6.833100E+03,2.322900E+04,& + & 3.626683E+05,8.357500E-05,2.187500E-04,4.232900E-04,8.193600E-04,& + & 1.722900E-03,4.340800E-03,1.764300E-02,1.466300E-01,1.702600E+00,& + & 7.911100E+00,1.271000E+01,1.914100E+01,2.828100E+01,4.290311E+01,& + & 8.920700E-02,2.022000E-01,3.981400E-01,7.962100E-01,1.729200E+00,& + & 4.438000E+00,1.463100E+01,7.362100E+01,8.390000E+02,4.776300E+03,& + & 1.030200E+04,3.117400E+04,1.048500E+05,1.413416E+06,7.109400E-02,& + & 1.636200E-01,3.280500E-01,6.583900E-01,1.429500E+00,3.578400E+00,& + & 1.124400E+01,5.533400E+01,6.293700E+02,3.582400E+03,7.726600E+03,& + & 2.338000E+04,7.863600E+04,1.060053E+06,4.856200E-02,1.129900E-01,& + & 2.296200E-01,4.665600E-01,1.023500E+00,2.589600E+00,8.114600E+00,& + & 3.733000E+01,4.197500E+02,2.388500E+03,5.151200E+03,1.558700E+04,& + & 5.242400E+04,7.066897E+05,2.519500E-02,5.910300E-02,1.222300E-01,& + & 2.530300E-01,5.673200E-01,1.450600E+00,4.649400E+00,2.013400E+01,& + & 2.102100E+02,1.194500E+03,2.575800E+03,7.793800E+03,2.621200E+04,& + & 3.533458E+05,8.791200E-05,2.258700E-04,4.338600E-04,8.348300E-04,& + & 1.743900E-03,4.417000E-03,1.873600E-02,1.744700E-01,1.868800E+00,& + & 8.002600E+00,1.273400E+01,1.884200E+01,2.695600E+01,3.849367E+01,& + & 5.033400E-02,1.509300E-01,2.626500E-01,5.136200E-01,1.063000E+00,& + & 2.597100E+00,8.112900E+00,3.959400E+01,4.852200E+02,2.819400E+03,& + & 6.568400E+03,1.822600E+04,6.256500E+04,1.757317E+06,4.049500E-02,& + & 1.196100E-01,2.124500E-01,4.206800E-01,8.776700E-01,2.146000E+00,& + & 6.482800E+00,2.996200E+01,3.640500E+02,2.114700E+03,4.926600E+03,& + & 1.367000E+04,4.692400E+04,1.318001E+06,2.797900E-02,8.207500E-02,& + & 1.471400E-01,2.939100E-01,6.176300E-01,1.529800E+00,4.728200E+00,& + & 2.100300E+01,2.429200E+02,1.410000E+03,3.284700E+03,9.113500E+03,& + & 3.128300E+04,8.786805E+05,1.476400E-02,4.287400E-02,7.796900E-02,& + & 1.570400E-01,3.341000E-01,8.385400E-01,2.650200E+00,1.204800E+01,& + & 1.227100E+02,7.052200E+02,1.642800E+03,4.557100E+03,1.564200E+04,& + & 4.393350E+05,5.310400E-05,1.532600E-04,3.071400E-04,6.113100E-04,& + & 1.302000E-03,3.304900E-03,1.192000E-02,7.169300E-02,1.118800E+00,& + & 6.703200E+00,1.183900E+01,2.010700E+01,3.194700E+01,6.071683E+01,& + & 5.806300E-02,1.585300E-01,2.806800E-01,5.595600E-01,1.165400E+00,& + & 2.879900E+00,9.204000E+00,4.533000E+01,5.593600E+02,3.174700E+03,& + & 7.310000E+03,2.146600E+04,7.388100E+04,1.725468E+06,4.667900E-02,& + & 1.258900E-01,2.291800E-01,4.593200E-01,9.647400E-01,2.375900E+00,& + & 7.291900E+00,3.420300E+01,4.196500E+02,2.381200E+03,5.482700E+03,& + & 1.610000E+04,5.541100E+04,1.294102E+06,3.215900E-02,8.642800E-02,& + & 1.594000E-01,3.217100E-01,6.817800E-01,1.701300E+00,5.333200E+00,& + & 2.370600E+01,2.799600E+02,1.587600E+03,3.655400E+03,1.073400E+04,& + & 3.694100E+04,8.627406E+05,1.688000E-02,4.511000E-02,8.475000E-02,& + & 1.722300E-01,3.707800E-01,9.388000E-01,3.011000E+00,1.348500E+01,& + & 1.409200E+02,7.940800E+02,1.828100E+03,5.367200E+03,1.847100E+04,& + & 4.313748E+05,5.829800E-05,1.622700E-04,3.215100E-04,6.335900E-04,& + & 1.347200E-03,3.409200E-03,1.288400E-02,8.850200E-02,1.297900E+00,& + & 7.173500E+00,1.229800E+01,1.996900E+01,3.071000E+01,5.509370E+01/ + data absb(:,761:780) / & + & 6.596100E-02,1.660900E-01,3.031400E-01,6.105300E-01,1.287900E+00,& + & 3.220200E+00,1.046700E+01,5.249300E+01,6.433000E+02,3.654900E+03,& + & 8.206900E+03,2.506700E+04,8.637600E+04,1.689919E+06,5.290500E-02,& + & 1.324400E-01,2.493200E-01,5.024100E-01,1.067600E+00,2.646100E+00,& + & 8.217600E+00,3.953700E+01,4.826000E+02,2.741300E+03,6.155300E+03,& + & 1.880000E+04,6.478300E+04,1.267443E+06,3.632700E-02,9.103400E-02,& + & 1.738400E-01,3.531500E-01,7.577500E-01,1.903500E+00,6.012300E+00,& + & 2.711800E+01,3.219100E+02,1.827800E+03,4.103800E+03,1.253400E+04,& + & 4.318900E+04,8.449781E+05,1.896800E-02,4.750400E-02,9.246600E-02,& + & 1.897700E-01,4.145600E-01,1.056600E+00,3.419500E+00,1.521300E+01,& + & 1.616400E+02,9.142000E+02,2.052300E+03,6.267200E+03,2.159500E+04,& + & 4.224864E+05,6.312300E-05,1.702900E-04,3.341500E-04,6.523700E-04,& + & 1.384300E-03,3.500300E-03,1.383900E-02,1.088700E-01,1.473600E+00,& + & 7.584400E+00,1.258500E+01,1.971500E+01,2.982300E+01,4.942593E+01,& + & 7.358500E-02,1.745200E-01,3.308000E-01,6.666400E-01,1.432300E+00,& + & 3.632900E+00,1.197500E+01,6.101200E+01,7.377300E+02,4.252200E+03,& + & 9.321500E+03,2.902200E+04,9.963300E+04,1.651217E+06,5.886200E-02,& + & 1.400800E-01,2.726900E-01,5.508400E-01,1.188300E+00,2.967800E+00,& + & 9.313900E+00,4.589600E+01,5.534200E+02,3.189300E+03,6.991300E+03,& + & 2.176700E+04,7.472500E+04,1.238414E+06,4.029100E-02,9.642800E-02,& + & 1.904500E-01,3.888100E-01,8.470200E-01,2.142600E+00,6.791100E+00,& + & 3.122100E+01,3.691200E+02,2.126400E+03,4.661100E+03,1.451200E+04,& + & 4.981700E+04,8.256118E+05,2.094500E-02,5.029600E-02,1.012700E-01,& + & 2.098100E-01,4.662800E-01,1.194900E+00,3.883700E+00,1.723000E+01,& + & 1.850500E+02,1.063500E+03,2.330800E+03,7.256100E+03,2.490900E+04,& + & 4.128051E+05,6.742500E-05,1.777300E-04,3.447000E-04,6.692100E-04,& + & 1.412200E-03,3.577300E-03,1.482400E-02,1.328300E-01,1.646300E+00,& + & 7.842000E+00,1.279600E+01,1.933100E+01,2.891600E+01,4.419967E+01,& + & 8.056000E-02,1.845600E-01,3.627200E-01,7.304700E-01,1.596100E+00,& + & 4.127500E+00,1.382100E+01,7.101100E+01,8.441900E+02,4.942100E+03,& + & 1.075600E+04,3.331400E+04,1.131700E+05,1.609688E+06,6.425700E-02,& + & 1.492100E-01,2.994200E-01,6.054400E-01,1.324100E+00,3.345500E+00,& + & 1.065800E+01,5.337900E+01,6.332700E+02,3.706700E+03,8.067100E+03,& + & 2.498600E+04,8.487900E+04,1.207257E+06,4.385900E-02,1.029000E-01,& + & 2.094200E-01,4.289400E-01,9.481300E-01,2.421600E+00,7.724700E+00,& + & 3.607000E+01,4.223500E+02,2.471400E+03,5.378200E+03,1.665800E+04,& + & 5.658600E+04,8.048457E+05,2.272000E-02,5.368400E-02,1.112900E-01,& + & 2.323200E-01,5.252500E-01,1.357200E+00,4.429400E+00,1.955900E+01,& + & 2.115400E+02,1.236000E+03,2.689400E+03,8.329100E+03,2.829400E+04,& + & 4.024245E+05,7.117700E-05,1.839800E-04,3.540700E-04,6.830000E-04,& + & 1.431600E-03,3.648000E-03,1.581600E-02,1.601100E-01,1.816800E+00,& + & 7.977700E+00,1.280200E+01,1.915800E+01,2.743300E+01,3.969402E+01,& + & 4.489900E-02,1.392100E-01,2.428100E-01,4.736900E-01,9.826500E-01,& + & 2.410900E+00,7.581300E+00,3.761600E+01,4.766200E+02,2.846900E+03,& + & 6.777000E+03,1.900500E+04,6.637700E+04,2.023627E+06,3.607400E-02,& + & 1.103000E-01,1.959400E-01,3.880300E-01,8.118900E-01,1.998300E+00,& + & 6.088900E+00,2.850700E+01,3.575900E+02,2.135300E+03,5.082900E+03,& + & 1.425400E+04,4.978300E+04,1.517723E+06,2.489100E-02,7.562000E-02,& + & 1.354000E-01,2.706900E-01,5.707800E-01,1.422500E+00,4.443800E+00,& + & 2.007800E+01,2.386300E+02,1.423700E+03,3.388900E+03,9.502900E+03,& + & 3.318800E+04,1.011793E+06,1.311500E-02,3.942000E-02,7.146700E-02,& + & 1.442600E-01,3.080500E-01,7.781200E-01,2.488600E+00,1.155300E+01,& + & 1.206900E+02,7.120600E+02,1.694900E+03,4.751800E+03,1.659500E+04,& + & 5.058930E+05,4.202900E-05,1.231600E-04,2.478900E-04,4.954000E-04,& + & 1.059500E-03,2.705400E-03,9.850400E-03,6.140100E-02,1.048000E+00,& + & 6.538000E+00,1.169600E+01,2.027100E+01,3.253700E+01,6.267015E+01/ + data absb(:,781:800) / & + & 5.206500E-02,1.466100E-01,2.588400E-01,5.162900E-01,1.079000E+00,& + & 2.677600E+00,8.643300E+00,4.327400E+01,5.545300E+02,3.220300E+03,& + & 7.601400E+03,2.262700E+04,7.887500E+04,1.988349E+06,4.185000E-02,& + & 1.162800E-01,2.110300E-01,4.242600E-01,8.940200E-01,2.217000E+00,& + & 6.883800E+00,3.268100E+01,4.160300E+02,2.415300E+03,5.701200E+03,& + & 1.697000E+04,5.915600E+04,1.491255E+06,2.880900E-02,7.972300E-02,& + & 1.464800E-01,2.968800E-01,6.310500E-01,1.586200E+00,5.038800E+00,& + & 2.274700E+01,2.775500E+02,1.610400E+03,3.801100E+03,1.131400E+04,& + & 3.943700E+04,9.941578E+05,1.509700E-02,4.152100E-02,7.762600E-02,& + & 1.585600E-01,3.424800E-01,8.740300E-01,2.841600E+00,1.299200E+01,& + & 1.398200E+02,8.054800E+02,1.900900E+03,5.657000E+03,1.971900E+04,& + & 4.970823E+05,4.647900E-05,1.308400E-04,2.601400E-04,5.147500E-04,& + & 1.098400E-03,2.797100E-03,1.069500E-02,7.709900E-02,1.229700E+00,& + & 7.039300E+00,1.223500E+01,2.004500E+01,3.146300E+01,5.684963E+01,& + & 5.948500E-02,1.537700E-01,2.789700E-01,5.643000E-01,1.194400E+00,& + & 3.002200E+00,9.881500E+00,5.038500E+01,6.434800E+02,3.736000E+03,& + & 8.590500E+03,2.668900E+04,9.282600E+04,1.948918E+06,4.774000E-02,& + & 1.224200E-01,2.293900E-01,4.648400E-01,9.916900E-01,2.476900E+00,& + & 7.793700E+00,3.797100E+01,4.827300E+02,2.802100E+03,6.443000E+03,& + & 2.001700E+04,6.961900E+04,1.461671E+06,3.275800E-02,8.400400E-02,& + & 1.597800E-01,3.264000E-01,7.031200E-01,1.780600E+00,5.711900E+00,& + & 2.613300E+01,3.220000E+02,1.868300E+03,4.295500E+03,1.334500E+04,& + & 4.641300E+04,9.744570E+05,1.707700E-02,4.372700E-02,8.479400E-02,& + & 1.749900E-01,3.839600E-01,9.874000E-01,3.245200E+00,1.473200E+01,& + & 1.617600E+02,9.344800E+02,2.148100E+03,6.672500E+03,2.320700E+04,& + & 4.872179E+05,5.059900E-05,1.376400E-04,2.711700E-04,5.313100E-04,& + & 1.131800E-03,2.877300E-03,1.154900E-02,9.647900E-02,1.408500E+00,& + & 7.477800E+00,1.259800E+01,1.990900E+01,3.033900E+01,5.111470E+01,& + & 6.678100E-02,1.614800E-01,3.044800E-01,6.171700E-01,1.331800E+00,& + & 3.396500E+00,1.135400E+01,5.897600E+01,7.444700E+02,4.391000E+03,& + & 9.816700E+03,3.113200E+04,1.078200E+05,1.905639E+06,5.345400E-02,& + & 1.294100E-01,2.511500E-01,5.104900E-01,1.107700E+00,2.787100E+00,& + & 8.866400E+00,4.437900E+01,5.584800E+02,3.293400E+03,7.362600E+03,& + & 2.334900E+04,8.086400E+04,1.429233E+06,3.656600E-02,8.893300E-02,& + & 1.752200E-01,3.600600E-01,7.889900E-01,2.011500E+00,6.482700E+00,& + & 3.025900E+01,3.724900E+02,2.195800E+03,4.908600E+03,1.556600E+04,& + & 5.390900E+04,9.528011E+05,1.898200E-02,4.626900E-02,9.298900E-02,& + & 1.939300E-01,4.335600E-01,1.121300E+00,3.704700E+00,1.678500E+01,& + & 1.867800E+02,1.098200E+03,2.454600E+03,7.783200E+03,2.695500E+04,& + & 4.763978E+05,5.426300E-05,1.441600E-04,2.804900E-04,5.464200E-04,& + & 1.156600E-03,2.947800E-03,1.243000E-02,1.195200E-01,1.584700E+00,& + & 7.771600E+00,1.284300E+01,1.959600E+01,2.951900E+01,4.557131E+01,& + & 7.352200E-02,1.706000E-01,3.340800E-01,6.774600E-01,1.488700E+00,& + & 3.874700E+00,1.316200E+01,6.917200E+01,8.585500E+02,5.162000E+03,& + & 1.137000E+04,3.595500E+04,1.233500E+05,1.858931E+06,5.869000E-02,& + & 1.377200E-01,2.761200E-01,5.624100E-01,1.238300E+00,3.155500E+00,& + & 1.018300E+01,5.200300E+01,6.440300E+02,3.871600E+03,8.527400E+03,& + & 2.696600E+04,9.250800E+04,1.394170E+06,4.003100E-02,9.481500E-02,& + & 1.929700E-01,3.982000E-01,8.864400E-01,2.283600E+00,7.406000E+00,& + & 3.519500E+01,4.295300E+02,2.581300E+03,5.685000E+03,1.797800E+04,& + & 6.167200E+04,9.294470E+05,2.070200E-02,4.934300E-02,1.023600E-01,& + & 2.153700E-01,4.905300E-01,1.279100E+00,4.247300E+00,1.917000E+01,& + & 2.151500E+02,1.290900E+03,2.842700E+03,8.989000E+03,3.083600E+04,& + & 4.647235E+05,5.753000E-05,1.496400E-04,2.886100E-04,5.587000E-04,& + & 1.175200E-03,3.010100E-03,1.333500E-02,1.460600E-01,1.758700E+00,& + & 7.956800E+00,1.286200E+01,1.945400E+01,2.788600E+01,4.107106E+01/ + data absb(:,801:820) / & + & 4.079200E-02,1.308600E-01,2.292400E-01,4.455200E-01,9.267600E-01,& + & 2.281500E+00,7.218600E+00,3.641700E+01,4.769400E+02,2.937000E+03,& + & 7.133700E+03,2.023000E+04,7.187400E+04,2.376203E+06,3.272500E-02,& + & 1.036400E-01,1.844700E-01,3.646900E-01,7.654300E-01,1.894400E+00,& + & 5.819900E+00,2.763400E+01,3.578400E+02,2.202900E+03,5.350500E+03,& + & 1.517300E+04,5.390500E+04,1.782178E+06,2.254300E-02,7.098000E-02,& + & 1.271600E-01,2.539800E-01,5.373100E-01,1.346400E+00,4.246100E+00,& + & 1.953400E+01,2.388100E+02,1.468700E+03,3.567300E+03,1.011500E+04,& + & 3.593700E+04,1.188112E+06,1.185000E-02,3.693500E-02,6.683200E-02,& + & 1.349700E-01,2.891700E-01,7.346700E-01,2.374700E+00,1.125200E+01,& + & 1.208800E+02,7.346100E+02,1.784100E+03,5.058000E+03,1.796900E+04,& + & 5.940658E+05,3.324400E-05,9.877100E-05,2.000400E-04,4.011900E-04,& + & 8.620700E-04,2.213000E-03,8.131400E-03,5.239100E-02,9.802500E-01,& + & 6.359600E+00,1.155300E+01,2.036000E+01,3.314600E+01,6.452827E+01,& + & 4.755200E-02,1.383200E-01,2.437300E-01,4.859300E-01,1.018800E+00,& + & 2.540100E+00,8.269800E+00,4.208300E+01,5.604900E+02,3.332300E+03,& + & 8.081300E+03,2.431500E+04,8.588700E+04,2.336845E+06,3.819500E-02,& + & 1.095700E-01,1.982000E-01,3.994000E-01,8.442000E-01,2.108100E+00,& + & 6.611400E+00,3.180800E+01,4.205000E+02,2.499400E+03,6.061200E+03,& + & 1.823700E+04,6.441500E+04,1.752627E+06,2.626700E-02,7.501000E-02,& + & 1.372800E-01,2.791100E-01,5.950300E-01,1.506500E+00,4.838500E+00,& + & 2.220900E+01,2.805400E+02,1.666400E+03,4.041100E+03,1.215800E+04,& + & 4.294400E+04,1.168402E+06,1.373900E-02,3.898600E-02,7.248400E-02,& + & 1.487100E-01,3.221100E-01,8.281600E-01,2.725100E+00,1.271600E+01,& + & 1.413900E+02,8.335100E+02,2.020900E+03,6.079300E+03,2.147200E+04,& + & 5.842141E+05,3.701100E-05,1.053300E-04,2.106500E-04,4.180300E-04,& + & 8.958900E-04,2.294800E-03,8.875000E-03,6.690900E-02,1.162300E+00,& + & 6.895600E+00,1.221300E+01,2.006100E+01,3.212300E+01,5.864025E+01,& + & 5.465600E-02,1.452000E-01,2.622800E-01,5.321000E-01,1.129500E+00,& + & 2.853300E+00,9.503100E+00,4.931800E+01,6.563200E+02,3.892100E+03,& + & 9.191500E+03,2.898500E+04,1.016800E+05,2.292228E+06,4.385800E-02,& + & 1.154300E-01,2.153600E-01,4.383700E-01,9.384000E-01,2.360200E+00,& + & 7.524600E+00,3.718100E+01,4.923700E+02,2.919300E+03,6.893800E+03,& + & 2.173900E+04,7.626200E+04,1.719163E+06,3.007600E-02,7.907200E-02,& + & 1.497800E-01,3.074200E-01,6.644900E-01,1.694800E+00,5.517400E+00,& + & 2.565300E+01,3.284200E+02,1.946400E+03,4.596100E+03,1.449300E+04,& + & 5.084100E+04,1.146120E+06,1.565300E-02,4.105600E-02,7.929700E-02,& + & 1.643600E-01,3.620700E-01,9.382600E-01,3.130600E+00,1.449900E+01,& + & 1.650300E+02,9.735400E+02,2.298400E+03,7.246700E+03,2.542100E+04,& + & 5.730433E+05,4.047500E-05,1.112700E-04,2.199600E-04,4.328100E-04,& + & 9.249100E-04,2.365600E-03,9.629700E-03,8.522300E-02,1.343900E+00,& + & 7.374800E+00,1.257700E+01,2.012300E+01,3.072700E+01,5.287436E+01,& + & 6.172500E-02,1.524900E-01,2.857800E-01,5.826600E-01,1.262400E+00,& + & 3.238200E+00,1.097400E+01,5.810900E+01,7.663500E+02,4.619600E+03,& + & 1.057200E+04,3.406900E+04,1.189100E+05,2.242978E+06,4.941300E-02,& + & 1.219500E-01,2.357300E-01,4.820200E-01,1.051200E+00,2.665500E+00,& + & 8.597200E+00,4.373500E+01,5.748800E+02,3.464800E+03,7.929000E+03,& + & 2.555200E+04,8.918100E+04,1.682211E+06,3.378200E-02,8.367400E-02,& + & 1.642700E-01,3.396100E-01,7.479700E-01,1.921800E+00,6.294400E+00,& + & 2.987300E+01,3.834300E+02,2.310100E+03,5.286200E+03,1.703500E+04,& + & 5.945400E+04,1.121469E+06,1.750500E-02,4.342500E-02,8.697600E-02,& + & 1.825400E-01,4.101100E-01,1.070000E+00,3.593600E+00,1.662000E+01,& + & 1.922800E+02,1.155400E+03,2.643400E+03,8.517600E+03,2.972700E+04,& + & 5.607423E+05,4.366200E-05,1.169000E-04,2.279500E-04,4.458600E-04,& + & 9.472400E-04,2.429100E-03,1.041700E-02,1.073100E-01,1.523600E+00,& + & 7.709400E+00,1.286200E+01,1.982500E+01,3.005200E+01,4.701727E+01/ + data absb(:,821:840) / & + & 6.836200E-02,1.609400E-01,3.138700E-01,6.406100E-01,1.415900E+00,& + & 3.707600E+00,1.279100E+01,6.867500E+01,8.912300E+02,5.497500E+03,& + & 1.229400E+04,3.958300E+04,1.369500E+05,2.189684E+06,5.459900E-02,& + & 1.296700E-01,2.595400E-01,5.321500E-01,1.179400E+00,3.029800E+00,& + & 9.919400E+00,5.163500E+01,6.685400E+02,4.123300E+03,9.220300E+03,& + & 2.968700E+04,1.027200E+05,1.642250E+06,3.721600E-02,8.912400E-02,& + & 1.812300E-01,3.764300E-01,8.435900E-01,2.191200E+00,7.228600E+00,& + & 3.498400E+01,4.458700E+02,2.749000E+03,6.147000E+03,1.979200E+04,& + & 6.847700E+04,1.094826E+06,1.921500E-02,4.625600E-02,9.594000E-02,& + & 2.032700E-01,4.659800E-01,1.225900E+00,4.145600E+00,1.910300E+01,& + & 2.233400E+02,1.374800E+03,3.073800E+03,9.896100E+03,3.423900E+04,& + & 5.474245E+05,4.642600E-05,1.217600E-04,2.350100E-04,4.568700E-04,& + & 9.643100E-04,2.485200E-03,1.123400E-02,1.330200E-01,1.700700E+00,& + & 7.939400E+00,1.290500E+01,1.981900E+01,2.842300E+01,4.219174E+01,& + & 3.721000E-02,1.239500E-01,2.186400E-01,4.224900E-01,8.811500E-01,& + & 2.175200E+00,6.914100E+00,3.539700E+01,4.792400E+02,3.054300E+03,& + & 7.557400E+03,2.169200E+04,7.832800E+04,2.819009E+06,2.981300E-02,& + & 9.813300E-02,1.753700E-01,3.453600E-01,7.271200E-01,1.807500E+00,& + & 5.594000E+00,2.689500E+01,3.595700E+02,2.290800E+03,5.668300E+03,& + & 1.626900E+04,5.874700E+04,2.114239E+06,2.050500E-02,6.713500E-02,& + & 1.205900E-01,2.400700E-01,5.094600E-01,1.282400E+00,4.077600E+00,& + & 1.907000E+01,2.399900E+02,1.527400E+03,3.779200E+03,1.084600E+04,& + & 3.916500E+04,1.409494E+06,1.075300E-02,3.487600E-02,6.311400E-02,& + & 1.271900E-01,2.733300E-01,6.975800E-01,2.275800E+00,1.098900E+01,& + & 1.215700E+02,7.639300E+02,1.890100E+03,5.423300E+03,1.958300E+04,& + & 7.047450E+05,2.619200E-05,7.897200E-05,1.610600E-04,3.244400E-04,& + & 7.004400E-04,1.808300E-03,6.687600E-03,4.422800E-02,9.098300E-01,& + & 6.166500E+00,1.137200E+01,2.039700E+01,3.380000E+01,6.661291E+01,& + & 4.366600E-02,1.315400E-01,2.316400E-01,4.608500E-01,9.687300E-01,& + & 2.426200E+00,7.950300E+00,4.115000E+01,5.692200E+02,3.475700E+03,& + & 8.656600E+03,2.627500E+04,9.408200E+04,2.774579E+06,3.502300E-02,& + & 1.041300E-01,1.877300E-01,3.785800E-01,8.025200E-01,2.016800E+00,& + & 6.378800E+00,3.112700E+01,4.270500E+02,2.606900E+03,6.492700E+03,& + & 1.970600E+04,7.056200E+04,2.080914E+06,2.406200E-02,7.118600E-02,& + & 1.297100E-01,2.641600E-01,5.647700E-01,1.439100E+00,4.667000E+00,& + & 2.179500E+01,2.849100E+02,1.738200E+03,4.328700E+03,1.313800E+04,& + & 4.704100E+04,1.387290E+06,1.256400E-02,3.692300E-02,6.823400E-02,& + & 1.403700E-01,3.048600E-01,7.891600E-01,2.622600E+00,1.249700E+01,& + & 1.436600E+02,8.694000E+02,2.164800E+03,6.569100E+03,2.352100E+04,& + & 6.936317E+05,2.933800E-05,8.458000E-05,1.700800E-04,3.391100E-04,& + & 7.294000E-04,1.880300E-03,7.339900E-03,5.748700E-02,1.092200E+00,& + & 6.752400E+00,1.209800E+01,2.014000E+01,3.275100E+01,6.054144E+01,& + & 5.048400E-02,1.383500E-01,2.487800E-01,5.055800E-01,1.075900E+00,& + & 2.730600E+00,9.186400E+00,4.849400E+01,6.735200E+02,4.075800E+03,& + & 9.931100E+03,3.162900E+04,1.120500E+05,2.723786E+06,4.048700E-02,& + & 1.098100E-01,2.038000E-01,4.164100E-01,8.939300E-01,2.263600E+00,& + & 7.299100E+00,3.657400E+01,5.052700E+02,3.057000E+03,7.448500E+03,& + & 2.372200E+04,8.404100E+04,2.042838E+06,2.774600E-02,7.511100E-02,& + & 1.414800E-01,2.915800E-01,6.321000E-01,1.622900E+00,5.356000E+00,& + & 2.528700E+01,3.370300E+02,2.038200E+03,4.965900E+03,1.581500E+04,& + & 5.602800E+04,1.361899E+06,1.441800E-02,3.891300E-02,7.469000E-02,& + & 1.555000E-01,3.434400E-01,8.964900E-01,3.033500E+00,1.432400E+01,& + & 1.693900E+02,1.019500E+03,2.483300E+03,7.907600E+03,2.801400E+04,& + & 6.809396E+05,3.226900E-05,8.970700E-05,1.781700E-04,3.521000E-04,& + & 7.545600E-04,1.945300E-03,8.003800E-03,7.457700E-02,1.275700E+00,& + & 7.268800E+00,1.250800E+01,2.030800E+01,3.121000E+01,5.469783E+01/ + data absb(:,841:860) / & + & 5.738900E-02,1.453900E-01,2.704100E-01,5.544600E-01,1.205100E+00,& + & 3.107900E+00,1.066700E+01,5.759800E+01,7.936700E+02,4.883200E+03,& + & 1.148300E+04,3.751800E+04,1.318800E+05,2.667762E+06,4.594800E-02,& + & 1.159800E-01,2.229800E-01,4.585200E-01,1.003800E+00,2.565100E+00,& + & 8.380300E+00,4.335900E+01,5.953800E+02,3.662600E+03,8.612100E+03,& + & 2.813900E+04,9.891000E+04,2.000806E+06,3.139300E-02,7.945400E-02,& + & 1.551800E-01,3.226100E-01,7.132300E-01,1.847300E+00,6.144000E+00,& + & 2.965700E+01,3.970900E+02,2.441900E+03,5.741600E+03,1.875900E+04,& + & 6.594000E+04,1.333865E+06,1.624300E-02,4.114000E-02,8.198600E-02,& + & 1.729600E-01,3.901700E-01,1.026300E+00,3.503000E+00,1.653500E+01,& + & 1.991500E+02,1.221300E+03,2.871100E+03,9.379900E+03,3.297100E+04,& + & 6.669419E+05,3.504700E-05,9.457000E-05,1.851400E-04,3.632300E-04,& + & 7.754300E-04,2.002300E-03,8.704000E-03,9.557500E-02,1.457900E+00,& + & 7.629900E+00,1.288900E+01,2.004500E+01,3.067000E+01,4.846989E+01,& + & 6.398300E-02,1.532800E-01,2.971700E-01,6.103400E-01,1.355900E+00,& + & 3.571500E+00,1.248800E+01,6.855900E+01,9.318900E+02,5.879900E+03,& + & 1.341700E+04,4.385600E+04,1.529600E+05,2.606321E+06,5.111600E-02,& + & 1.232200E-01,2.457300E-01,5.069500E-01,1.130600E+00,2.926200E+00,& + & 9.709100E+00,5.154900E+01,6.990400E+02,4.410100E+03,1.006300E+04,& + & 3.289200E+04,1.147200E+05,1.954740E+06,3.482800E-02,8.455200E-02,& + & 1.714300E-01,3.581700E-01,8.076100E-01,2.114400E+00,7.085700E+00,& + & 3.496100E+01,4.662000E+02,2.940200E+03,6.708800E+03,2.192800E+04,& + & 7.647800E+04,1.303147E+06,1.795500E-02,4.376800E-02,9.058500E-02,& + & 1.930500E-01,4.451300E-01,1.180800E+00,4.059500E+00,1.912800E+01,& + & 2.335200E+02,1.470400E+03,3.354600E+03,1.096400E+04,3.823900E+04,& + & 6.515702E+05,3.741200E-05,9.895200E-05,1.911200E-04,3.733000E-04,& + & 7.912300E-04,2.054700E-03,9.440000E-03,1.202800E-01,1.638200E+00,& + & 7.903900E+00,1.296200E+01,2.010200E+01,2.902000E+01,4.345889E+01,& + & 3.330700E-02,1.156100E-01,2.066600E-01,3.955400E-01,8.270800E-01,& + & 2.043900E+00,6.515800E+00,3.389200E+01,4.721500E+02,3.132100E+03,& + & 7.872700E+03,2.288600E+04,8.381000E+04,3.315088E+06,2.664700E-02,& + & 9.162100E-02,1.651500E-01,3.229100E-01,6.817900E-01,1.699800E+00,& + & 5.295200E+00,2.579900E+01,3.542500E+02,2.349200E+03,5.904800E+03,& + & 1.716500E+04,6.285800E+04,2.486300E+06,1.830700E-02,6.264600E-02,& + & 1.132900E-01,2.240100E-01,4.767000E-01,1.203900E+00,3.855300E+00,& + & 1.836900E+01,2.364800E+02,1.566300E+03,3.936800E+03,1.144300E+04,& + & 4.190600E+04,1.657547E+06,9.585100E-03,3.250400E-02,5.905600E-02,& + & 1.183300E-01,2.549600E-01,6.528400E-01,2.146100E+00,1.059200E+01,& + & 1.199500E+02,7.834100E+02,1.968900E+03,5.722000E+03,2.095300E+04,& + & 8.287636E+05,2.044600E-05,6.283600E-05,1.290100E-04,2.616000E-04,& + & 5.672300E-04,1.472800E-03,5.457800E-03,3.665800E-02,8.331900E-01,& + & 5.925800E+00,1.112000E+01,2.037600E+01,3.445600E+01,6.904124E+01,& + & 3.939500E-02,1.235900E-01,2.177900E-01,4.314600E-01,9.084100E-01,& + & 2.284900E+00,7.512500E+00,3.955800E+01,5.671000E+02,3.570300E+03,& + & 9.135600E+03,2.788900E+04,1.012900E+05,3.266219E+06,3.155200E-02,& + & 9.779900E-02,1.758900E-01,3.541200E-01,7.525400E-01,1.902600E+00,& + & 6.054200E+00,2.996100E+01,4.254600E+02,2.677900E+03,6.851900E+03,& + & 2.091700E+04,7.596800E+04,2.449650E+06,2.165400E-02,6.680300E-02,& + & 1.212200E-01,2.466800E-01,5.287700E-01,1.355200E+00,4.428200E+00,& + & 2.106500E+01,2.838700E+02,1.785500E+03,4.568200E+03,1.394500E+04,& + & 5.064600E+04,1.633103E+06,1.129300E-02,3.458600E-02,6.351500E-02,& + & 1.307800E-01,2.845900E-01,7.412400E-01,2.482300E+00,1.210400E+01,& + & 1.432500E+02,8.930600E+02,2.284500E+03,6.972700E+03,2.532300E+04,& + & 8.165662E+05,2.312400E-05,6.761200E-05,1.368000E-04,2.743300E-04,& + & 5.923700E-04,1.537800E-03,6.028700E-03,4.851200E-02,1.014200E+00,& + & 6.556400E+00,1.191800E+01,2.017100E+01,3.332600E+01,6.293883E+01/ + data absb(:,861:880) / & + & 4.583200E-02,1.303600E-01,2.332000E-01,4.736900E-01,1.010200E+00,& + & 2.573900E+00,8.727700E+00,4.682100E+01,6.788100E+02,4.198100E+03,& + & 1.058200E+04,3.386700E+04,1.213300E+05,3.209735E+06,3.675200E-02,& + & 1.033000E-01,1.905300E-01,3.902200E-01,8.393800E-01,2.139600E+00,& + & 6.965400E+00,3.533800E+01,5.092400E+02,3.148800E+03,7.936800E+03,& + & 2.540100E+04,9.099800E+04,2.407312E+06,2.517200E-02,7.056700E-02,& + & 1.319800E-01,2.728400E-01,5.926400E-01,1.531700E+00,5.113000E+00,& + & 2.451400E+01,3.396800E+02,2.099400E+03,5.291400E+03,1.693400E+04,& + & 6.066600E+04,1.604906E+06,1.306500E-02,3.649700E-02,6.946600E-02,& + & 1.451500E-01,3.210800E-01,8.443400E-01,2.890500E+00,1.393300E+01,& + & 1.708100E+02,1.050100E+03,2.646100E+03,8.467300E+03,3.033300E+04,& + & 8.024509E+05,2.560100E-05,7.204000E-05,1.438400E-04,2.855400E-04,& + & 6.146100E-04,1.597100E-03,6.612300E-03,6.419900E-02,1.198800E+00,& + & 7.126700E+00,1.240600E+01,2.040900E+01,3.189700E+01,5.673508E+01,& + & 5.249100E-02,1.371000E-01,2.527400E-01,5.205500E-01,1.133600E+00,& + & 2.935500E+00,1.018000E+01,5.603800E+01,8.079600E+02,5.065200E+03,& + & 1.230100E+04,4.059700E+04,1.437400E+05,3.146438E+06,4.205200E-02,& + & 1.091200E-01,2.082800E-01,4.304400E-01,9.443300E-01,2.430800E+00,& + & 8.033000E+00,4.220000E+01,6.060900E+02,3.799100E+03,9.226000E+03,& + & 3.044800E+04,1.078100E+05,2.359866E+06,2.872200E-02,7.463200E-02,& + & 1.447800E-01,3.023200E-01,6.700500E-01,1.748400E+00,5.897700E+00,& + & 2.893400E+01,4.042400E+02,2.532900E+03,6.150900E+03,2.029900E+04,& + & 7.187100E+04,1.573236E+06,1.484300E-02,3.856700E-02,7.635100E-02,& + & 1.616700E-01,3.656400E-01,9.693900E-01,3.359900E+00,1.619200E+01,& + & 2.027800E+02,1.266800E+03,3.075700E+03,1.015000E+04,3.593600E+04,& + & 7.866368E+05,2.794000E-05,7.619600E-05,1.499900E-04,2.952700E-04,& + & 6.336700E-04,1.647800E-03,7.230400E-03,8.384900E-02,1.383500E+00,& + & 7.545500E+00,1.281600E+01,2.029100E+01,3.116500E+01,5.040516E+01,& + & 5.895800E-02,1.444000E-01,2.776100E-01,5.733600E-01,1.278900E+00,& + & 3.383700E+00,1.198500E+01,6.723900E+01,9.579400E+02,6.168900E+03,& + & 1.443300E+04,4.782200E+04,1.679000E+05,3.076681E+06,4.713700E-02,& + & 1.158000E-01,2.295400E-01,4.763500E-01,1.067500E+00,2.782400E+00,& + & 9.349800E+00,5.056800E+01,7.185800E+02,4.626800E+03,1.082500E+04,& + & 3.586600E+04,1.259300E+05,2.307541E+06,3.210800E-02,7.933400E-02,& + & 1.599500E-01,3.362000E-01,7.614700E-01,2.008800E+00,6.839300E+00,& + & 3.435000E+01,4.792300E+02,3.084700E+03,7.216700E+03,2.391100E+04,& + & 8.395200E+04,1.538340E+06,1.653600E-02,4.098100E-02,8.438500E-02,& + & 1.808400E-01,4.187300E-01,1.119800E+00,3.916200E+00,1.885900E+01,& + & 2.400700E+02,1.542600E+03,3.608600E+03,1.195600E+04,4.197600E+04,& + & 7.691869E+05,3.000700E-05,8.008000E-05,1.551400E-04,3.042800E-04,& + & 6.482600E-04,1.694500E-03,7.887500E-03,1.073100E-01,1.566800E+00,& + & 7.847000E+00,1.298300E+01,2.038400E+01,2.965300E+01,4.501640E+01,& + & 3.057700E-02,1.103500E-01,2.015900E-01,3.809000E-01,7.988200E-01,& + & 1.972900E+00,6.310400E+00,3.336300E+01,4.766700E+02,3.304700E+03,& + & 8.403500E+03,2.486700E+04,9.200900E+04,4.008966E+06,2.441100E-02,& + & 8.758100E-02,1.603200E-01,3.103600E-01,6.567000E-01,1.639600E+00,& + & 5.139800E+00,2.543000E+01,3.576400E+02,2.478700E+03,6.302900E+03,& + & 1.865100E+04,6.900700E+04,3.006716E+06,1.674500E-02,5.986800E-02,& + & 1.097000E-01,2.148200E-01,4.580100E-01,1.158500E+00,3.734300E+00,& + & 1.814400E+01,2.387600E+02,1.652600E+03,4.202200E+03,1.243400E+04,& + & 4.600500E+04,2.004475E+06,8.749500E-03,3.103200E-02,5.694500E-02,& + & 1.131000E-01,2.440400E-01,6.258500E-01,2.071200E+00,1.044600E+01,& + & 1.211900E+02,8.265700E+02,2.101600E+03,6.217300E+03,2.300300E+04,& + & 1.002236E+06,1.592200E-05,4.988400E-05,1.033000E-04,2.108500E-04,& + & 4.591000E-04,1.199800E-03,4.443800E-03,3.017700E-02,7.582300E-01,& + & 5.669400E+00,1.089700E+01,2.029500E+01,3.500400E+01,7.151528E+01/ + data absb(:,881:900) / & + & 3.646400E-02,1.192800E-01,2.109400E-01,4.153300E-01,8.760200E-01,& + & 2.211400E+00,7.286500E+00,3.905500E+01,5.786500E+02,3.774700E+03,& + & 9.893100E+03,3.043200E+04,1.120700E+05,3.953321E+06,2.914700E-02,& + & 9.431000E-02,1.696600E-01,3.401900E-01,7.246900E-01,1.841500E+00,& + & 5.886500E+00,2.960700E+01,4.341300E+02,2.831200E+03,7.420000E+03,& + & 2.282400E+04,8.405100E+04,2.964996E+06,1.997500E-02,6.435300E-02,& + & 1.166100E-01,2.365100E-01,5.081400E-01,1.308800E+00,4.299900E+00,& + & 2.086100E+01,2.896500E+02,1.887700E+03,4.947000E+03,1.521600E+04,& + & 5.603400E+04,1.976661E+06,1.039700E-02,3.326700E-02,6.083400E-02,& + & 1.250100E-01,2.725900E-01,7.132800E-01,2.403800E+00,1.198200E+01,& + & 1.462300E+02,9.441800E+02,2.473900E+03,7.608500E+03,2.801800E+04,& + & 9.883400E+05,1.814800E-05,5.401900E-05,1.099700E-04,2.218000E-04,& + & 4.808200E-04,1.257500E-03,4.941200E-03,4.064000E-02,9.379900E-01,& + & 6.358900E+00,1.170600E+01,2.027000E+01,3.391800E+01,6.515031E+01,& + & 4.269100E-02,1.262800E-01,2.250500E-01,4.561400E-01,9.748500E-01,& + & 2.493700E+00,8.507100E+00,4.643000E+01,7.014500E+02,4.448300E+03,& + & 1.158900E+04,3.723500E+04,1.349400E+05,3.888879E+06,3.419700E-02,& + & 9.989800E-02,1.831300E-01,3.753700E-01,8.090600E-01,2.074700E+00,& + & 6.807900E+00,3.505700E+01,5.262200E+02,3.336400E+03,8.692200E+03,& + & 2.792600E+04,1.012100E+05,2.916691E+06,2.340600E-02,6.815600E-02,& + & 1.265600E-01,2.619700E-01,5.699800E-01,1.482500E+00,4.992000E+00,& + & 2.436700E+01,3.510100E+02,2.224500E+03,5.795000E+03,1.861800E+04,& + & 6.747100E+04,1.944461E+06,1.213200E-02,3.518700E-02,6.636500E-02,& + & 1.389800E-01,3.078300E-01,8.143900E-01,2.815300E+00,1.385900E+01,& + & 1.765300E+02,1.112600E+03,2.897900E+03,9.309100E+03,3.373600E+04,& + & 9.722192E+05,2.029000E-05,5.777700E-05,1.160600E-04,2.314300E-04,& + & 5.005900E-04,1.309600E-03,5.452100E-03,5.487300E-02,1.122900E+00,& + & 6.956900E+00,1.231300E+01,2.048400E+01,3.242500E+01,5.892013E+01,& + & 4.924300E-02,1.329400E-01,2.432100E-01,5.024600E-01,1.095100E+00,& + & 2.848600E+00,9.972800E+00,5.593900E+01,8.442700E+02,5.394000E+03,& + & 1.356700E+04,4.506300E+04,1.608300E+05,3.816014E+06,3.943800E-02,& + & 1.055700E-01,1.999300E-01,4.149200E-01,9.113600E-01,2.361600E+00,& + & 7.890500E+00,4.213400E+01,6.333300E+02,4.045700E+03,1.017500E+04,& + & 3.379700E+04,1.206300E+05,2.862027E+06,2.693200E-02,7.208000E-02,& + & 1.387700E-01,2.908100E-01,6.453300E-01,1.696000E+00,5.792800E+00,& + & 2.892600E+01,4.224000E+02,2.697300E+03,6.783900E+03,2.253200E+04,& + & 8.041800E+04,1.908017E+06,1.390300E-02,3.716800E-02,7.302700E-02,& + & 1.550500E-01,3.510500E-01,9.376400E-01,3.294200E+00,1.620500E+01,& + & 2.119000E+02,1.349000E+03,3.392200E+03,1.126600E+04,4.021000E+04,& + & 9.540068E+05,2.224400E-05,6.139300E-05,1.214300E-04,2.399800E-04,& + & 5.176900E-04,1.355600E-03,5.994500E-03,7.313000E-02,1.308900E+00,& + & 7.439500E+00,1.274100E+01,2.058000E+01,3.165200E+01,5.225650E+01,& + & 5.575100E-02,1.399600E-01,2.666900E-01,5.536500E-01,1.238900E+00,& + & 3.293600E+00,1.179900E+01,6.767500E+01,1.010900E+03,6.639800E+03,& + & 1.597700E+04,5.353000E+04,1.892000E+05,3.734763E+06,4.457100E-02,& + & 1.119100E-01,2.202300E-01,4.594500E-01,1.033500E+00,2.713100E+00,& + & 9.225900E+00,5.089600E+01,7.583200E+02,4.980000E+03,1.198300E+04,& + & 4.014800E+04,1.419000E+05,2.801059E+06,3.035500E-02,7.655300E-02,& + & 1.532300E-01,3.237200E-01,7.356300E-01,1.956100E+00,6.753700E+00,& + & 3.459800E+01,5.057300E+02,3.320100E+03,7.988800E+03,2.676500E+04,& + & 9.459900E+04,1.867389E+06,1.561000E-02,3.946500E-02,8.070900E-02,& + & 1.736600E-01,4.033100E-01,1.087400E+00,3.863900E+00,1.901000E+01,& + & 2.533400E+02,1.660300E+03,3.994700E+03,1.338300E+04,4.730000E+04,& + & 9.337076E+05,2.404400E-05,6.481500E-05,1.258200E-04,2.479900E-04,& + & 5.308700E-04,1.397900E-03,6.574800E-03,9.535200E-02,1.495100E+00,& + & 7.775100E+00,1.299400E+01,2.062100E+01,3.039600E+01,4.649275E+01/ + data absb(:,901:920) / & + & 2.913900E-02,1.091400E-01,2.055000E-01,3.822300E-01,8.040200E-01,& + & 1.981700E+00,6.363700E+00,3.408700E+01,4.995700E+02,3.625600E+03,& + & 9.322200E+03,2.809500E+04,1.051500E+05,5.050469E+06,2.320200E-02,& + & 8.668400E-02,1.625500E-01,3.105200E-01,6.582300E-01,1.642100E+00,& + & 5.179300E+00,2.598900E+01,3.748100E+02,2.719400E+03,6.991900E+03,& + & 2.107100E+04,7.886600E+04,3.787848E+06,1.588700E-02,5.923600E-02,& + & 1.109000E-01,2.144400E-01,4.576100E-01,1.157000E+00,3.751600E+00,& + & 1.853000E+01,2.502200E+02,1.813100E+03,4.661500E+03,1.404800E+04,& + & 5.257700E+04,2.525208E+06,8.278800E-03,3.067900E-02,5.732200E-02,& + & 1.124600E-01,2.427600E-01,6.221000E-01,2.072300E+00,1.062800E+01,& + & 1.269700E+02,9.068200E+02,2.331200E+03,7.024200E+03,2.628900E+04,& + & 1.262608E+06,1.237900E-05,3.952100E-05,8.262400E-05,1.698700E-04,& + & 3.713700E-04,9.760200E-04,3.608500E-03,2.464200E-02,6.863100E-01,& + & 5.414700E+00,1.063300E+01,2.019700E+01,3.559800E+01,7.387763E+01,& + & 3.504900E-02,1.196200E-01,2.133000E-01,4.165900E-01,8.803100E-01,& + & 2.227200E+00,7.347400E+00,4.014300E+01,6.122400E+02,4.164300E+03,& + & 1.112300E+04,3.461800E+04,1.289900E+05,4.984831E+06,2.795400E-02,& + & 9.448500E-02,1.706800E-01,3.400100E-01,7.257700E-01,1.850600E+00,& + & 5.933200E+00,3.043600E+01,4.593100E+02,3.123400E+03,8.342400E+03,& + & 2.596300E+04,9.674500E+04,3.738548E+06,1.912400E-02,6.440600E-02,& + & 1.169800E-01,2.357600E-01,5.075100E-01,1.311800E+00,4.323300E+00,& + & 2.143300E+01,3.064500E+02,2.082500E+03,5.561900E+03,1.730900E+04,& + & 6.449700E+04,2.492388E+06,9.930200E-03,3.323300E-02,6.075100E-02,& + & 1.241900E-01,2.712300E-01,7.114700E-01,2.408700E+00,1.226400E+01,& + & 1.546600E+02,1.041600E+03,2.781300E+03,8.654700E+03,3.224900E+04,& + & 1.246166E+06,1.421400E-05,4.307700E-05,8.837800E-05,1.791900E-04,& + & 3.901700E-04,1.027900E-03,4.040600E-03,3.377100E-02,8.635300E-01,& + & 6.145300E+00,1.147800E+01,2.031900E+01,3.454100E+01,6.733336E+01,& + & 4.134200E-02,1.273200E-01,2.265100E-01,4.573400E-01,9.794600E-01,& + & 2.515000E+00,8.622100E+00,4.785900E+01,7.519700E+02,4.909400E+03,& + & 1.321200E+04,4.259100E+04,1.561800E+05,4.908456E+06,3.303400E-02,& + & 1.005800E-01,1.833000E-01,3.752500E-01,8.106500E-01,2.089600E+00,& + & 6.897800E+00,3.613700E+01,5.641100E+02,3.682200E+03,9.908900E+03,& + & 3.194300E+04,1.171400E+05,3.681317E+06,2.258800E-02,6.852300E-02,& + & 1.263000E-01,2.613300E-01,5.694100E-01,1.489800E+00,5.045800E+00,& + & 2.510600E+01,3.762700E+02,2.455000E+03,6.606100E+03,2.129600E+04,& + & 7.809200E+04,2.454247E+06,1.168600E-02,3.530800E-02,6.597200E-02,& + & 1.382100E-01,3.062800E-01,8.145400E-01,2.835700E+00,1.424300E+01,& + & 1.891700E+02,1.227900E+03,3.303400E+03,1.064800E+04,3.904600E+04,& + & 1.227109E+06,1.604400E-05,4.631800E-05,9.361500E-05,1.874300E-04,& + & 4.077700E-04,1.074500E-03,4.487600E-03,4.657000E-02,1.048000E+00,& + & 6.787200E+00,1.219000E+01,2.055900E+01,3.316600E+01,6.081710E+01,& + & 4.801100E-02,1.342900E-01,2.440900E-01,5.048700E-01,1.101100E+00,& + & 2.876900E+00,1.015500E+01,5.804200E+01,9.164300E+02,5.984700E+03,& + & 1.560300E+04,5.194500E+04,1.872100E+05,4.821140E+06,3.840200E-02,& + & 1.063600E-01,1.997500E-01,4.157400E-01,9.141000E-01,2.381300E+00,& + & 8.034000E+00,4.371500E+01,6.874500E+02,4.488600E+03,1.170200E+04,& + & 3.895900E+04,1.404100E+05,3.615854E+06,2.620800E-02,7.250400E-02,& + & 1.383500E-01,2.907200E-01,6.452100E-01,1.706700E+00,5.886600E+00,& + & 2.999700E+01,4.584800E+02,2.992600E+03,7.801700E+03,2.597300E+04,& + & 9.360600E+04,2.410503E+06,1.350800E-02,3.732000E-02,7.259100E-02,& + & 1.544800E-01,3.496100E-01,9.396500E-01,3.337900E+00,1.675900E+01,& + & 2.299400E+02,1.496600E+03,3.901100E+03,1.298700E+04,4.680300E+04,& + & 1.205273E+06,1.773300E-05,4.945100E-05,9.824600E-05,1.950800E-04,& + & 4.227200E-04,1.116000E-03,4.964100E-03,6.340600E-02,1.234100E+00,& + & 7.316800E+00,1.269700E+01,2.085300E+01,3.212700E+01,5.404525E+01/ + data absb(:,921:940) / & + & 5.479000E-02,1.414700E-01,2.668500E-01,5.569500E-01,1.248400E+00,& + & 3.335300E+00,1.207100E+01,7.077400E+01,1.109400E+03,7.425800E+03,& + & 1.844200E+04,6.232500E+04,2.216600E+05,4.723018E+06,4.377100E-02,& + & 1.126800E-01,2.198000E-01,4.607900E-01,1.038900E+00,2.744600E+00,& + & 9.437100E+00,5.322000E+01,8.321900E+02,5.569500E+03,1.383200E+04,& + & 4.674400E+04,1.662400E+05,3.542201E+06,2.979900E-02,7.695100E-02,& + & 1.526900E-01,3.238500E-01,7.373000E-01,1.974700E+00,6.898600E+00,& + & 3.615600E+01,5.549700E+02,3.713100E+03,9.221500E+03,3.116300E+04,& + & 1.108300E+05,2.361466E+06,1.530200E-02,3.959100E-02,8.025800E-02,& + & 1.731700E-01,4.027700E-01,1.093300E+00,3.936100E+00,1.981300E+01,& + & 2.779500E+02,1.856800E+03,4.611000E+03,1.558100E+04,5.541400E+04,& + & 1.180738E+06,1.928200E-05,5.240500E-05,1.020100E-04,2.022400E-04,& + & 4.347900E-04,1.154500E-03,5.478000E-03,8.431700E-02,1.423400E+00,& + & 7.686900E+00,1.302700E+01,2.089000E+01,3.111400E+01,4.787283E+01,& + & 2.646400E-02,1.026700E-01,2.000100E-01,3.663100E-01,7.725400E-01,& + & 1.897800E+00,6.128700E+00,3.327100E+01,4.992700E+02,3.791300E+03,& + & 9.872900E+03,3.035400E+04,1.149200E+05,6.057349E+06,2.105700E-02,& + & 8.158200E-02,1.576300E-01,2.971200E-01,6.310400E-01,1.572000E+00,& + & 4.998200E+00,2.540700E+01,3.745900E+02,2.843600E+03,7.404900E+03,& + & 2.276600E+04,8.619000E+04,4.542968E+06,1.440000E-02,5.573500E-02,& + & 1.073500E-01,2.048100E-01,4.376500E-01,1.105500E+00,3.613000E+00,& + & 1.815500E+01,2.501100E+02,1.895900E+03,4.936900E+03,1.517800E+04,& + & 5.746000E+04,3.028613E+06,7.491800E-03,2.885000E-02,5.531300E-02,& + & 1.071200E-01,2.313700E-01,5.924500E-01,1.989800E+00,1.039400E+01,& + & 1.270200E+02,9.482500E+02,2.468800E+03,7.589100E+03,2.873000E+04,& + & 1.514330E+06,9.616000E-06,3.126800E-05,6.605200E-05,1.367200E-04,& + & 3.001700E-04,7.930800E-04,2.926300E-03,2.010500E-02,6.208200E-01,& + & 5.133800E+00,1.034600E+01,2.006200E+01,3.592000E+01,7.645537E+01,& + & 3.213800E-02,1.140200E-01,2.062200E-01,3.987900E-01,8.447800E-01,& + & 2.139900E+00,7.079300E+00,3.933700E+01,6.174500E+02,4.392000E+03,& + & 1.192700E+04,3.773400E+04,1.417700E+05,5.983266E+06,2.558900E-02,& + & 9.016500E-02,1.643300E-01,3.248600E-01,6.954100E-01,1.777900E+00,& + & 5.731500E+00,2.985900E+01,4.632200E+02,3.294200E+03,8.945200E+03,& + & 2.830000E+04,1.063300E+05,4.487440E+06,1.748900E-02,6.143700E-02,& + & 1.123900E-01,2.248300E-01,4.852900E-01,1.258000E+00,4.169000E+00,& + & 2.108000E+01,3.090700E+02,2.196300E+03,5.963700E+03,1.886700E+04,& + & 7.088400E+04,2.991651E+06,9.067400E-03,3.167100E-02,5.816600E-02,& + & 1.181100E-01,2.586200E-01,6.800700E-01,2.316600E+00,1.206200E+01,& + & 1.560600E+02,1.098500E+03,2.982200E+03,9.433800E+03,3.544200E+04,& + & 1.495825E+06,1.111700E-05,3.431900E-05,7.096400E-05,1.445800E-04,& + & 3.161700E-04,8.388800E-04,3.302200E-03,2.804500E-02,7.933700E-01,& + & 5.920300E+00,1.121300E+01,2.036300E+01,3.500900E+01,6.959569E+01,& + & 3.820100E-02,1.223400E-01,2.178200E-01,4.376100E-01,9.392500E-01,& + & 2.421800E+00,8.338500E+00,4.712400E+01,7.685000E+02,5.185100E+03,& + & 1.437600E+04,4.658900E+04,1.728400E+05,5.897215E+06,3.047200E-02,& + & 9.660200E-02,1.756000E-01,3.585800E-01,7.767900E-01,2.013800E+00,& + & 6.689200E+00,3.560600E+01,5.765100E+02,3.889000E+03,1.078200E+04,& + & 3.494200E+04,1.296300E+05,4.422889E+06,2.081600E-02,6.576600E-02,& + & 1.207000E-01,2.493400E-01,5.446500E-01,1.433300E+00,4.887200E+00,& + & 2.479300E+01,3.845400E+02,2.592900E+03,7.188400E+03,2.329500E+04,& + & 8.642200E+04,2.948573E+06,1.075800E-02,3.384000E-02,6.282100E-02,& + & 1.316000E-01,2.921300E-01,7.815000E-01,2.738800E+00,1.408200E+01,& + & 1.933800E+02,1.296800E+03,3.594500E+03,1.164800E+04,4.321200E+04,& + & 1.474299E+06,1.265000E-05,3.707600E-05,7.546000E-05,1.516600E-04,& + & 3.316000E-04,8.799600E-04,3.689400E-03,3.952200E-02,9.770200E-01,& + & 6.580200E+00,1.204200E+01,2.054300E+01,3.384000E+01,6.285987E+01/ + data absb(:,941:960) / & + & 4.462700E-02,1.293900E-01,2.339300E-01,4.839800E-01,1.056700E+00,& + & 2.774200E+00,9.870500E+00,5.752500E+01,9.490900E+02,6.348900E+03,& + & 1.715600E+04,5.721400E+04,2.081600E+05,5.797196E+06,3.568400E-02,& + & 1.023000E-01,1.909000E-01,3.982100E-01,8.767800E-01,2.299500E+00,& + & 7.831000E+00,4.334000E+01,7.119500E+02,4.761800E+03,1.286700E+04,& + & 4.291000E+04,1.561200E+05,4.347937E+06,2.434400E-02,6.966800E-02,& + & 1.319600E-01,2.779900E-01,6.178800E-01,1.645500E+00,5.736400E+00,& + & 2.978800E+01,4.748200E+02,3.174800E+03,8.578200E+03,2.860700E+04,& + & 1.040800E+05,2.898589E+06,1.253300E-02,3.581300E-02,6.905600E-02,& + & 1.473700E-01,3.339500E-01,9.038100E-01,3.246000E+00,1.666800E+01,& + & 2.381600E+02,1.587700E+03,4.289400E+03,1.430400E+04,5.204200E+04,& + & 1.449309E+06,1.409400E-05,3.973700E-05,7.940200E-05,1.583000E-04,& + & 3.448700E-04,9.169800E-04,4.106100E-03,5.497400E-02,1.163700E+00,& + & 7.170500E+00,1.259200E+01,2.099300E+01,3.261400E+01,5.598105E+01,& + & 5.130400E-02,1.363900E-01,2.552000E-01,5.349900E-01,1.200800E+00,& + & 3.225500E+00,1.179200E+01,7.069400E+01,1.162800E+03,7.937700E+03,& + & 2.038700E+04,6.923800E+04,2.478900E+05,5.685123E+06,4.100900E-02,& + & 1.083700E-01,2.099800E-01,4.421200E-01,9.992400E-01,2.659000E+00,& + & 9.242800E+00,5.316500E+01,8.722700E+02,5.953400E+03,1.529000E+04,& + & 5.192900E+04,1.859100E+05,4.263808E+06,2.791700E-02,7.390300E-02,& + & 1.457100E-01,3.102200E-01,7.079800E-01,1.910700E+00,6.761100E+00,& + & 3.615500E+01,5.816900E+02,3.969100E+03,1.019400E+04,3.461900E+04,& + & 1.239400E+05,2.842535E+06,1.432200E-02,3.796700E-02,7.646400E-02,& + & 1.654900E-01,3.857700E-01,1.055500E+00,3.853400E+00,1.984200E+01,& + & 2.913300E+02,1.984800E+03,5.097000E+03,1.731000E+04,6.197200E+04,& + & 1.421258E+06,1.545200E-05,4.223200E-05,8.269200E-05,1.646500E-04,& + & 3.557700E-04,9.516400E-04,4.563100E-03,7.456900E-02,1.352700E+00,& + & 7.592200E+00,1.303500E+01,2.103500E+01,3.178700E+01,4.940652E+01,& + & 2.347100E-02,9.428400E-02,1.906500E-01,3.440600E-01,7.266900E-01,& + & 1.778700E+00,5.776800E+00,3.179900E+01,4.875800E+02,3.866900E+03,& + & 1.024600E+04,3.211500E+04,1.231600E+05,7.105062E+06,1.867000E-02,& + & 7.495300E-02,1.498500E-01,2.786100E-01,5.928400E-01,1.474100E+00,& + & 4.727300E+00,2.433900E+01,3.658300E+02,2.900300E+03,7.684600E+03,& + & 2.408600E+04,9.237200E+04,5.328779E+06,1.276000E-02,5.118600E-02,& + & 1.018800E-01,1.917900E-01,4.103000E-01,1.035100E+00,3.412100E+00,& + & 1.744800E+01,2.443200E+02,1.933800E+03,5.123400E+03,1.605800E+04,& + & 6.158200E+04,3.552470E+06,6.630300E-03,2.648200E-02,5.237200E-02,& + & 1.000600E-01,2.162700E-01,5.532100E-01,1.874300E+00,9.978800E+00,& + & 1.242600E+02,9.671900E+02,2.562100E+03,8.029200E+03,3.079100E+04,& + & 1.776266E+06,7.460000E-06,2.465900E-05,5.279600E-05,1.099800E-04,& + & 2.424600E-04,6.432200E-04,2.369300E-03,1.632200E-02,5.588800E-01,& + & 4.830200E+00,1.008000E+01,1.980900E+01,3.624800E+01,7.906899E+01,& + & 2.880900E-02,1.059300E-01,1.956400E-01,3.737200E-01,7.941000E-01,& + & 2.012100E+00,6.676300E+00,3.772900E+01,6.085100E+02,4.531800E+03,& + & 1.250400E+04,4.027700E+04,1.525700E+05,7.024156E+06,2.291100E-02,& + & 8.394800E-02,1.553500E-01,3.042000E-01,6.530000E-01,1.673100E+00,& + & 5.427200E+00,2.868600E+01,4.565200E+02,3.399100E+03,9.378100E+03,& + & 3.020800E+04,1.144300E+05,5.268222E+06,1.564200E-02,5.720900E-02,& + & 1.060400E-01,2.101800E-01,4.549700E-01,1.181900E+00,3.942600E+00,& + & 2.033100E+01,3.046300E+02,2.266300E+03,6.252300E+03,2.013900E+04,& + & 7.628400E+04,3.512088E+06,8.098800E-03,2.948600E-02,5.471700E-02,& + & 1.101500E-01,2.418400E-01,6.373600E-01,2.184900E+00,1.164600E+01,& + & 1.539600E+02,1.133500E+03,3.126500E+03,1.007000E+04,3.814200E+04,& + & 1.756067E+06,8.687000E-06,2.729800E-05,5.690900E-05,1.165200E-04,& + & 2.560200E-04,6.839600E-04,2.693100E-03,2.318700E-02,7.270200E-01,& + & 5.665300E+00,1.095900E+01,2.031300E+01,3.546400E+01,7.189427E+01/ + data absb(:,961:980) / & + & 3.451500E-02,1.149200E-01,2.053100E-01,4.099800E-01,8.816700E-01,& + & 2.282500E+00,7.893100E+00,4.542800E+01,7.670600E+02,5.377300E+03,& + & 1.529400E+04,4.995800E+04,1.873500E+05,6.928168E+06,2.750200E-02,& + & 9.072700E-02,1.650000E-01,3.357000E-01,7.291600E-01,1.901200E+00,& + & 6.357600E+00,3.436100E+01,5.754300E+02,4.033100E+03,1.147100E+04,& + & 3.746900E+04,1.405100E+05,5.196258E+06,1.877100E-02,6.173300E-02,& + & 1.131900E-01,2.331000E-01,5.105600E-01,1.351400E+00,4.639800E+00,& + & 2.401400E+01,3.838300E+02,2.689000E+03,7.647600E+03,2.497900E+04,& + & 9.367700E+04,3.464137E+06,9.688500E-03,3.174000E-02,5.872600E-02,& + & 1.228100E-01,2.732700E-01,7.351400E-01,2.593900E+00,1.367500E+01,& + & 1.931200E+02,1.344800E+03,3.824100E+03,1.249000E+04,4.683900E+04,& + & 1.732072E+06,9.950200E-06,2.965700E-05,6.073600E-05,1.226300E-04,& + & 2.693300E-04,7.197700E-04,3.029800E-03,3.339500E-02,9.080400E-01,& + & 6.373600E+00,1.191300E+01,2.045500E+01,3.443100E+01,6.494059E+01,& + & 4.056400E-02,1.219700E-01,2.197400E-01,4.539700E-01,9.926500E-01,& + & 2.618400E+00,9.390500E+00,5.576400E+01,9.604200E+02,6.601500E+03,& + & 1.848300E+04,6.168100E+04,2.266300E+05,6.817644E+06,3.242600E-02,& + & 9.637100E-02,1.788600E-01,3.734700E-01,8.241000E-01,2.176000E+00,& + & 7.481800E+00,4.203600E+01,7.204500E+02,4.951300E+03,1.386300E+04,& + & 4.626100E+04,1.699700E+05,5.113045E+06,2.211600E-02,6.557300E-02,& + & 1.234200E-01,2.604100E-01,5.801100E-01,1.555000E+00,5.482500E+00,& + & 2.897100E+01,4.804900E+02,3.301000E+03,9.242000E+03,3.084100E+04,& + & 1.133200E+05,3.408788E+06,1.137800E-02,3.367300E-02,6.442400E-02,& + & 1.378000E-01,3.128600E-01,8.526300E-01,3.096600E+00,1.625900E+01,& + & 2.410700E+02,1.650800E+03,4.621300E+03,1.542100E+04,5.665900E+04,& + & 1.704396E+06,1.117200E-05,3.188200E-05,6.417200E-05,1.282900E-04,& + & 2.809900E-04,7.527600E-04,3.390900E-03,4.747400E-02,1.094600E+00,& + & 7.002800E+00,1.252300E+01,2.096400E+01,3.297100E+01,5.817910E+01,& + & 4.695200E-02,1.287000E-01,2.390900E-01,5.029300E-01,1.130300E+00,& + & 3.052600E+00,1.127000E+01,6.908600E+01,1.192000E+03,8.320800E+03,& + & 2.210300E+04,7.520600E+04,2.712800E+05,6.690823E+06,3.754600E-02,& + & 1.021200E-01,1.965200E-01,4.156000E-01,9.411700E-01,2.524800E+00,& + & 8.866300E+00,5.196900E+01,8.941500E+02,6.240700E+03,1.657700E+04,& + & 5.640500E+04,2.034600E+05,5.018232E+06,2.556000E-02,6.956900E-02,& + & 1.362200E-01,2.912400E-01,6.660300E-01,1.812600E+00,6.495300E+00,& + & 3.540500E+01,5.962900E+02,4.160600E+03,1.105200E+04,3.760300E+04,& + & 1.356400E+05,3.345509E+06,1.310700E-02,3.569400E-02,7.139300E-02,& + & 1.550300E-01,3.622200E-01,9.996600E-01,3.698600E+00,1.949600E+01,& + & 2.986700E+02,2.080500E+03,5.526100E+03,1.880200E+04,6.782000E+04,& + & 1.672734E+06,1.231700E-05,3.403000E-05,6.697100E-05,1.338600E-04,& + & 2.907500E-04,7.832200E-04,3.791100E-03,6.572000E-02,1.284400E+00,& + & 7.472900E+00,1.300800E+01,2.106000E+01,3.247700E+01,5.109343E+01,& + & 2.133000E-02,8.874300E-02,1.868700E-01,3.330500E-01,7.029300E-01,& + & 1.713800E+00,5.598200E+00,3.112500E+01,4.886000E+02,4.034100E+03,& + & 1.091900E+04,3.491200E+04,1.356400E+05,8.571059E+06,1.694500E-02,& + & 7.054200E-02,1.465200E-01,2.688700E-01,5.722400E-01,1.419000E+00,& + & 4.587500E+00,2.386100E+01,3.666000E+02,3.025800E+03,8.189800E+03,& + & 2.618400E+04,1.017300E+05,6.428374E+06,1.156900E-02,4.814800E-02,& + & 9.946300E-02,1.847000E-01,3.952600E-01,9.945000E-01,3.304500E+00,& + & 1.713000E+01,2.448800E+02,2.017400E+03,5.460100E+03,1.745600E+04,& + & 6.782200E+04,4.285583E+06,6.004300E-03,2.488500E-02,5.101200E-02,& + & 9.611600E-02,2.076100E-01,5.298700E-01,1.809300E+00,9.776200E+00,& + & 1.246400E+02,1.009000E+03,2.730400E+03,8.728500E+03,3.391100E+04,& + & 2.142784E+06,5.774000E-06,1.941500E-05,4.217400E-05,8.841400E-05,& + & 1.956600E-04,5.215400E-04,1.913300E-03,1.316500E-02,4.996200E-01,& + & 4.550500E+00,9.736500E+00,1.958200E+01,3.651100E+01,8.165837E+01/ + data absb(:, 981:1000) / & + & 2.648600E-02,1.007800E-01,1.914100E-01,3.603000E-01,7.681400E-01,& + & 1.943400E+00,6.466900E+00,3.720600E+01,6.145100E+02,4.798200E+03,& + & 1.347400E+04,4.414600E+04,1.687300E+05,8.480564E+06,2.103300E-02,& + & 7.997600E-02,1.513700E-01,2.928500E-01,6.302100E-01,1.615000E+00,& + & 5.267600E+00,2.832000E+01,4.610200E+02,3.598900E+03,1.010600E+04,& + & 3.311000E+04,1.265500E+05,6.360325E+06,1.434400E-02,5.450300E-02,& + & 1.031200E-01,2.020100E-01,4.380600E-01,1.138700E+00,3.818900E+00,& + & 2.011000E+01,3.076500E+02,2.399500E+03,6.737500E+03,2.207300E+04,& + & 8.436700E+04,4.240317E+06,7.415800E-03,2.808500E-02,5.305300E-02,& + & 1.055900E-01,2.321500E-01,6.120400E-01,2.110500E+00,1.150700E+01,& + & 1.555500E+02,1.200100E+03,3.369100E+03,1.103700E+04,4.218400E+04,& + & 2.120170E+06,6.773900E-06,2.168900E-05,4.559400E-05,9.394100E-05,& + & 2.071700E-04,5.574900E-04,2.192900E-03,1.902000E-02,6.632000E-01,& + & 5.400400E+00,1.071500E+01,2.016300E+01,3.595500E+01,7.417676E+01,& + & 3.198400E-02,1.107800E-01,1.994000E-01,3.950100E-01,8.509900E-01,& + & 2.211500E+00,7.669200E+00,4.496600E+01,7.841800E+02,5.735600E+03,& + & 1.669200E+04,5.514700E+04,2.084100E+05,8.371205E+06,2.545900E-02,& + & 8.745400E-02,1.596200E-01,3.228800E-01,7.028200E-01,1.842200E+00,& + & 6.190400E+00,3.403700E+01,5.882700E+02,4.301900E+03,1.251900E+04,& + & 4.136100E+04,1.563100E+05,6.278629E+06,1.735800E-02,5.947600E-02,& + & 1.092700E-01,2.238200E-01,4.913300E-01,1.306900E+00,4.511400E+00,& + & 2.383200E+01,3.924000E+02,2.868200E+03,8.346500E+03,2.757400E+04,& + & 1.042100E+05,4.185700E+06,8.948300E-03,3.055100E-02,5.651600E-02,& + & 1.176500E-01,2.623100E-01,7.086300E-01,2.513300E+00,1.357600E+01,& + & 1.974700E+02,1.434400E+03,4.173600E+03,1.378700E+04,5.210400E+04,& + & 2.092857E+06,7.816300E-06,2.370300E-05,4.884800E-05,9.914200E-05,& + & 2.187400E-04,5.886400E-04,2.483300E-03,2.800700E-02,8.412800E-01,& + & 6.155600E+00,1.171400E+01,2.038600E+01,3.498800E+01,6.706406E+01,& + & 3.785900E-02,1.181700E-01,2.125200E-01,4.375300E-01,9.585700E-01,& + & 2.539800E+00,9.176000E+00,5.547500E+01,9.960200E+02,7.067200E+03,& + & 2.044500E+04,6.832600E+04,2.535600E+05,8.244906E+06,3.022000E-02,& + & 9.332500E-02,1.722800E-01,3.595400E-01,7.951700E-01,2.112500E+00,& + & 7.326100E+00,4.183400E+01,7.471500E+02,5.300500E+03,1.533400E+04,& + & 5.124500E+04,1.901700E+05,6.183736E+06,2.060200E-02,6.344800E-02,& + & 1.186500E-01,2.503100E-01,5.587600E-01,1.507100E+00,5.362300E+00,& + & 2.887500E+01,4.982900E+02,3.533900E+03,1.022300E+04,3.416300E+04,& + & 1.267800E+05,4.122445E+06,1.058900E-02,3.254500E-02,6.176800E-02,& + & 1.321700E-01,3.006100E-01,8.239300E-01,3.020300E+00,1.622200E+01,& + & 2.500100E+02,1.767200E+03,5.111700E+03,1.708200E+04,6.339000E+04,& + & 2.061226E+06,8.837900E-06,2.559600E-05,5.177100E-05,1.040400E-04,& + & 2.289300E-04,6.177500E-04,2.795300E-03,4.075200E-02,1.026800E+00,& + & 6.820800E+00,1.241500E+01,2.099900E+01,3.341200E+01,6.020293E+01,& + & 4.409500E-02,1.249000E-01,2.305100E-01,4.859200E-01,1.092800E+00,& + & 2.967200E+00,1.105900E+01,6.928600E+01,1.253400E+03,8.965700E+03,& + & 2.464200E+04,8.385300E+04,3.050100E+05,8.099621E+06,3.525500E-02,& + & 9.894000E-02,1.889600E-01,4.011300E-01,9.092300E-01,2.458100E+00,& + & 8.718100E+00,5.212700E+01,9.401800E+02,6.724400E+03,1.848100E+04,& + & 6.289000E+04,2.287600E+05,6.074695E+06,2.399400E-02,6.734000E-02,& + & 1.307900E-01,2.806200E-01,6.423000E-01,1.762300E+00,6.385100E+00,& + & 3.554700E+01,6.269800E+02,4.483100E+03,1.232100E+04,4.192700E+04,& + & 1.525000E+05,4.049917E+06,1.229500E-02,3.451400E-02,6.843100E-02,& + & 1.490200E-01,3.485000E-01,9.695200E-01,3.629100E+00,1.959300E+01,& + & 3.140300E+02,2.241800E+03,6.160800E+03,2.096400E+04,7.625300E+04,& + & 2.024954E+06,9.810200E-06,2.742200E-05,5.423400E-05,1.088700E-04,& + & 2.375100E-04,6.449300E-04,3.145200E-03,5.761600E-02,1.216500E+00,& + & 7.343200E+00,1.296400E+01,2.118300E+01,3.310800E+01,5.267751E+01/ + data absb(:,1001:1020) / & + & 2.010400E-02,8.666200E-02,1.904900E-01,3.367300E-01,7.079900E-01,& + & 1.719800E+00,5.649800E+00,3.162800E+01,5.088100E+02,4.358100E+03,& + & 1.209600E+04,3.940200E+04,1.555200E+05,1.077251E+07,1.593700E-02,& + & 6.886400E-02,1.490700E-01,2.706200E-01,5.745100E-01,1.420300E+00,& + & 4.622200E+00,2.425300E+01,3.817500E+02,3.268700E+03,9.072000E+03,& + & 2.955200E+04,1.166400E+05,8.079634E+06,1.086700E-02,4.696200E-02,& + & 1.010700E-01,1.854100E-01,3.958900E-01,9.932400E-01,3.320300E+00,& + & 1.739100E+01,2.550000E+02,2.179400E+03,6.048300E+03,1.970200E+04,& + & 7.776200E+04,5.386387E+06,5.629500E-03,2.423600E-02,5.172700E-02,& + & 9.612600E-02,2.072500E-01,5.271500E-01,1.811500E+00,9.884400E+00,& + & 1.297500E+02,1.090000E+03,3.024500E+03,9.851300E+03,3.888200E+04,& + & 2.693226E+06,4.453200E-06,1.526300E-05,3.367500E-05,7.104300E-05,& + & 1.577500E-04,4.226200E-04,1.540800E-03,1.054300E-02,4.441800E-01,& + & 4.269600E+00,9.380700E+00,1.926700E+01,3.685600E+01,8.416115E+01,& + & 2.526700E-02,9.951500E-02,1.953700E-01,3.621100E-01,7.742100E-01,& + & 1.952900E+00,6.519700E+00,3.805800E+01,6.442600E+02,5.268800E+03,& + & 1.511500E+04,5.030800E+04,1.942500E+05,1.066695E+07,2.003900E-02,& + & 7.895200E-02,1.538700E-01,2.935500E-01,6.328400E-01,1.618500E+00,& + & 5.305400E+00,2.897500E+01,4.833400E+02,3.951800E+03,1.133700E+04,& + & 3.773200E+04,1.456900E+05,8.000209E+06,1.364700E-02,5.378700E-02,& + & 1.046200E-01,2.020900E-01,4.387000E-01,1.138400E+00,3.836500E+00,& + & 2.056000E+01,3.225300E+02,2.634800E+03,7.558200E+03,2.515500E+04,& + & 9.712800E+04,5.333473E+06,7.042900E-03,2.769200E-02,5.367500E-02,& + & 1.053500E-01,2.316000E-01,6.092500E-01,2.112900E+00,1.173100E+01,& + & 1.630200E+02,1.317800E+03,3.779400E+03,1.257800E+04,4.856500E+04,& + & 2.666770E+06,5.272700E-06,1.720000E-05,3.649800E-05,7.571500E-05,& + & 1.677100E-04,4.539900E-04,1.782100E-03,1.547200E-02,6.013800E-01,& + & 5.142200E+00,1.046700E+01,1.990800E+01,3.643200E+01,7.649846E+01,& + & 3.080000E-02,1.108500E-01,2.022100E-01,3.965900E-01,8.555100E-01,& + & 2.229300E+00,7.746400E+00,4.630500E+01,8.315800E+02,6.365300E+03,& + & 1.893100E+04,6.338300E+04,2.410300E+05,1.053852E+07,2.446400E-02,& + & 8.755400E-02,1.610900E-01,3.230800E-01,7.045600E-01,1.853000E+00,& + & 6.247800E+00,3.505400E+01,6.238200E+02,4.774200E+03,1.419900E+04,& + & 4.753800E+04,1.807700E+05,7.903738E+06,1.666100E-02,5.952000E-02,& + & 1.100200E-01,2.234700E-01,4.913600E-01,1.311600E+00,4.541400E+00,& + & 2.452900E+01,4.161100E+02,3.183000E+03,9.466100E+03,3.169200E+04,& + & 1.205100E+05,5.269148E+06,8.576300E-03,3.054200E-02,5.671500E-02,& + & 1.171500E-01,2.615200E-01,7.080500E-01,2.522200E+00,1.393300E+01,& + & 2.093300E+02,1.591900E+03,4.733400E+03,1.584600E+04,6.025800E+04,& + & 2.634622E+06,6.135200E-06,1.892000E-05,3.928600E-05,8.013400E-05,& + & 1.776100E-04,4.812800E-04,2.031900E-03,2.327600E-02,7.757000E-01,& + & 5.928800E+00,1.152000E+01,2.027900E+01,3.553500E+01,6.917395E+01,& + & 3.673900E-02,1.191800E-01,2.143800E-01,4.389500E-01,9.636200E-01,& + & 2.563600E+00,9.320400E+00,5.732800E+01,1.071500E+03,7.887000E+03,& + & 2.349100E+04,7.877800E+04,2.953200E+05,1.038792E+07,2.925500E-02,& + & 9.402200E-02,1.729200E-01,3.597600E-01,7.973700E-01,2.129400E+00,& + & 7.437600E+00,4.322900E+01,8.037500E+02,5.915400E+03,1.761800E+04,& + & 5.908400E+04,2.214900E+05,7.790847E+06,1.992500E-02,6.388500E-02,& + & 1.187800E-01,2.500000E-01,5.589100E-01,1.516000E+00,5.430800E+00,& + & 2.982400E+01,5.360300E+02,3.943800E+03,1.174600E+04,3.938900E+04,& + & 1.476600E+05,5.194075E+06,1.023200E-02,3.272600E-02,6.164500E-02,& + & 1.317000E-01,2.997400E-01,8.253500E-01,3.047600E+00,1.671700E+01,& + & 2.688800E+02,1.972200E+03,5.873200E+03,1.969500E+04,7.383200E+04,& + & 2.597020E+06,6.984300E-06,2.058200E-05,4.174500E-05,8.435400E-05,& + & 1.864700E-04,5.071300E-04,2.302900E-03,3.469500E-02,9.594000E-01,& + & 6.634500E+00,1.229200E+01,2.103900E+01,3.387800E+01,6.214937E+01/ + data absb(:,1021:1040) / & + & 4.304500E-02,1.262800E-01,2.316400E-01,4.887500E-01,1.099300E+00,& + & 3.000400E+00,1.129400E+01,7.222800E+01,1.368000E+03,1.005100E+04,& + & 2.860200E+04,9.722900E+04,3.567300E+05,1.021421E+07,3.437900E-02,& + & 9.981800E-02,1.891300E-01,4.023000E-01,9.124600E-01,2.482700E+00,& + & 8.901300E+00,5.433500E+01,1.026200E+03,7.538300E+03,2.145200E+04,& + & 7.292300E+04,2.675500E+05,7.660644E+06,2.339200E-02,6.786200E-02,& + & 1.306500E-01,2.808600E-01,6.429600E-01,1.777000E+00,6.504200E+00,& + & 3.703400E+01,6.843000E+02,5.025700E+03,1.430100E+04,4.861500E+04,& + & 1.783700E+05,5.107107E+06,1.197500E-02,3.474700E-02,6.819800E-02,& + & 1.487500E-01,3.477100E-01,9.738300E-01,3.684800E+00,2.036000E+01,& + & 3.426900E+02,2.513100E+03,7.151000E+03,2.430800E+04,8.918400E+04,& + & 2.553633E+06,7.809500E-06,2.212800E-05,4.390300E-05,8.843100E-05,& + & 1.942500E-04,5.311100E-04,2.608900E-03,5.021000E-02,1.148700E+00,& + & 7.205400E+00,1.291300E+01,2.129300E+01,3.383000E+01,5.415188E+01,& + & 1.644100E-02,7.319500E-02,1.675000E-01,2.956500E-01,6.178100E-01,& + & 1.496900E+00,4.941000E+00,2.786600E+01,4.601900E+02,4.066400E+03,& + & 1.162800E+04,3.862400E+04,1.551900E+05,1.169790E+07,1.303000E-02,& + & 5.828600E-02,1.311700E-01,2.371800E-01,5.017400E-01,1.240100E+00,& + & 4.070100E+00,2.149500E+01,3.452900E+02,3.050000E+03,8.721500E+03,& + & 2.896800E+04,1.163900E+05,8.773486E+06,8.884700E-03,3.975500E-02,& + & 8.891400E-02,1.622500E-01,3.455100E-01,8.661300E-01,2.922000E+00,& + & 1.551900E+01,2.308200E+02,2.033600E+03,5.814600E+03,1.931200E+04,& + & 7.759500E+04,5.848968E+06,4.602200E-03,2.052000E-02,4.548200E-02,& + & 8.392900E-02,1.806200E-01,4.590400E-01,1.592000E+00,8.834600E+00,& + & 1.178800E+02,1.017100E+03,2.907700E+03,9.656600E+03,3.879800E+04,& + & 2.924491E+06,3.423000E-06,1.196700E-05,2.683400E-05,5.706200E-05,& + & 1.269800E-04,3.413500E-04,1.239300E-03,8.458000E-03,3.942200E-01,& + & 3.991200E+00,8.965300E+00,1.894600E+01,3.713700E+01,8.666998E+01,& + & 2.088800E-02,8.497200E-02,1.726000E-01,3.156600E-01,6.761700E-01,& + & 1.700400E+00,5.701100E+00,3.376300E+01,5.863300E+02,5.007000E+03,& + & 1.472100E+04,4.986900E+04,1.945500E+05,1.159121E+07,1.658200E-02,& + & 6.754400E-02,1.357700E-01,2.561000E-01,5.533200E-01,1.414600E+00,& + & 4.677900E+00,2.581500E+01,4.398800E+02,3.755500E+03,1.104100E+04,& + & 3.740200E+04,1.459100E+05,8.693567E+06,1.129300E-02,4.602300E-02,& + & 9.222500E-02,1.762100E-01,3.832400E-01,9.940000E-01,3.381800E+00,& + & 1.847300E+01,2.936400E+02,2.503900E+03,7.360800E+03,2.493500E+04,& + & 9.727700E+04,5.795625E+06,5.827800E-03,2.370200E-02,4.725700E-02,& + & 9.172600E-02,2.020400E-01,5.313900E-01,1.859900E+00,1.058800E+01,& + & 1.487900E+02,1.252300E+03,3.680800E+03,1.246800E+04,4.863900E+04,& + & 2.897846E+06,4.095600E-06,1.358500E-05,2.915200E-05,6.093000E-05,& + & 1.354800E-04,3.683500E-04,1.446500E-03,1.260200E-02,5.442200E-01,& + & 4.867300E+00,1.013000E+01,1.972400E+01,3.671900E+01,7.896686E+01,& + & 2.572100E-02,9.570900E-02,1.779000E-01,3.450100E-01,7.460900E-01,& + & 1.947500E+00,6.785100E+00,4.136100E+01,7.647700E+02,6.132900E+03,& + & 1.863800E+04,6.326700E+04,2.422300E+05,1.146052E+07,2.043300E-02,& + & 7.585500E-02,1.414400E-01,2.814500E-01,6.156800E-01,1.626900E+00,& + & 5.521400E+00,3.140100E+01,5.737200E+02,4.599800E+03,1.397900E+04,& + & 4.745000E+04,1.816700E+05,8.595477E+06,1.391000E-02,5.159500E-02,& + & 9.647300E-02,1.945300E-01,4.292700E-01,1.150600E+00,4.016700E+00,& + & 2.215500E+01,3.827300E+02,3.066800E+03,9.319300E+03,3.163400E+04,& + & 1.211100E+05,5.730394E+06,7.157500E-03,2.648900E-02,4.963200E-02,& + & 1.018400E-01,2.283100E-01,6.208100E-01,2.228800E+00,1.266800E+01,& + & 1.928500E+02,1.533700E+03,4.660000E+03,1.581700E+04,6.055800E+04,& + & 2.865189E+06,4.787600E-06,1.505100E-05,3.148700E-05,6.463000E-05,& + & 1.436000E-04,3.923200E-04,1.660200E-03,1.936600E-02,7.141900E-01,& + & 5.672700E+00,1.119500E+01,2.022100E+01,3.573700E+01,7.173265E+01/ + data absb(:,1041:1060) / & + & 3.090400E-02,1.039400E-01,1.875000E-01,3.816600E-01,8.397500E-01,& + & 2.244100E+00,8.213300E+00,5.150700E+01,9.997500E+02,7.657000E+03,& + & 2.341700E+04,7.900500E+04,2.986300E+05,1.130458E+07,2.461800E-02,& + & 8.209600E-02,1.510700E-01,3.134200E-01,6.970300E-01,1.875800E+00,& + & 6.613300E+00,3.890600E+01,7.499500E+02,5.742900E+03,1.756300E+04,& + & 5.925400E+04,2.239800E+05,8.478389E+06,1.675900E-02,5.577900E-02,& + & 1.036200E-01,2.177200E-01,4.886800E-01,1.335000E+00,4.837200E+00,& + & 2.702700E+01,5.001700E+02,3.828800E+03,1.170900E+04,3.950300E+04,& + & 1.493200E+05,5.652424E+06,8.603200E-03,2.857500E-02,5.366300E-02,& + & 1.145800E-01,2.619100E-01,7.269900E-01,2.712900E+00,1.528400E+01,& + & 2.511200E+02,1.914700E+03,5.854700E+03,1.975200E+04,7.466000E+04,& + & 2.826213E+06,5.498200E-06,1.640600E-05,3.361000E-05,6.812200E-05,& + & 1.513400E-04,4.144100E-04,1.891800E-03,2.958900E-02,8.960300E-01,& + & 6.411200E+00,1.206000E+01,2.089100E+01,3.418200E+01,6.467310E+01,& + & 3.641200E-02,1.105100E-01,2.018500E-01,4.258000E-01,9.585100E-01,& + & 2.632200E+00,1.000900E+01,6.537800E+01,1.295200E+03,9.807300E+03,& + & 2.882800E+04,9.789900E+04,3.622500E+05,1.112514E+07,2.912000E-02,& + & 8.739100E-02,1.648400E-01,3.513900E-01,7.987500E-01,2.193100E+00,& + & 7.957000E+00,4.922500E+01,9.715300E+02,7.355600E+03,2.162100E+04,& + & 7.342500E+04,2.716900E+05,8.343850E+06,1.981400E-02,5.939400E-02,& + & 1.137600E-01,2.452400E-01,5.631000E-01,1.569500E+00,5.835800E+00,& + & 3.371800E+01,6.478800E+02,4.903900E+03,1.441400E+04,4.895000E+04,& + & 1.811300E+05,5.562626E+06,1.014300E-02,3.039300E-02,5.929200E-02,& + & 1.297800E-01,3.044000E-01,8.609400E-01,3.304500E+00,1.872400E+01,& + & 3.245800E+02,2.452200E+03,7.207500E+03,2.447500E+04,9.056400E+04,& + & 2.781331E+06,6.175000E-06,1.774500E-05,3.541600E-05,7.155600E-05,& + & 1.580300E-04,4.350100E-04,2.156100E-03,4.379700E-02,1.083000E+00,& + & 7.043100E+00,1.273900E+01,2.123500E+01,3.409000E+01,5.653254E+01,& + & 1.225800E-02,5.627700E-02,1.339900E-01,2.376300E-01,4.921800E-01,& + & 1.190200E+00,3.944800E+00,2.240400E+01,3.802000E+02,3.448700E+03,& + & 1.020900E+04,3.450400E+04,1.417900E+05,1.158418E+07,9.726800E-03,& + & 4.494700E-02,1.052200E-01,1.905400E-01,4.009700E-01,9.920300E-01,& + & 3.289400E+00,1.748400E+01,2.853100E+02,2.586800E+03,7.656700E+03,& + & 2.587800E+04,1.063400E+05,8.688282E+06,6.636600E-03,3.067200E-02,& + & 7.134300E-02,1.302300E-01,2.761400E-01,6.926100E-01,2.361700E+00,& + & 1.275400E+01,1.910700E+02,1.724700E+03,5.104700E+03,1.725300E+04,& + & 7.089500E+04,5.792088E+06,3.442800E-03,1.585000E-02,3.650300E-02,& + & 6.727000E-02,1.443000E-01,3.669600E-01,1.286300E+00,7.291700E+00,& + & 9.830700E+01,8.627500E+02,2.552700E+03,8.626700E+03,3.544800E+04,& + & 2.896115E+06,2.621300E-06,9.358500E-06,2.136400E-05,4.573400E-05,& + & 1.019700E-04,2.753900E-04,9.947900E-04,6.762000E-03,3.473900E-01,& + & 3.702300E+00,8.532300E+00,1.856100E+01,3.750000E+01,8.911739E+01,& + & 1.574800E-02,6.610200E-02,1.391400E-01,2.516000E-01,5.391100E-01,& + & 1.351400E+00,4.551000E+00,2.730900E+01,4.873500E+02,4.327700E+03,& + & 1.309500E+04,4.515400E+04,1.780500E+05,1.148665E+07,1.252700E-02,& + & 5.272900E-02,1.095100E-01,2.045700E-01,4.429300E-01,1.132700E+00,& + & 3.786800E+00,2.106900E+01,3.656500E+02,3.246000E+03,9.821100E+03,& + & 3.386600E+04,1.335400E+05,8.615123E+06,8.536500E-03,3.594900E-02,& + & 7.435700E-02,1.407600E-01,3.068600E-01,7.957900E-01,2.740600E+00,& + & 1.529300E+01,2.443000E+02,2.164200E+03,6.547700E+03,2.257800E+04,& + & 8.902500E+04,5.743362E+06,4.411500E-03,1.853100E-02,3.808000E-02,& + & 7.323300E-02,1.616800E-01,4.257800E-01,1.507600E+00,8.829900E+00,& + & 1.244500E+02,1.082500E+03,3.274200E+03,1.128900E+04,4.451300E+04,& + & 2.871745E+06,3.171700E-06,1.068400E-05,2.327500E-05,4.893600E-05,& + & 1.093000E-04,2.980500E-04,1.169800E-03,1.022000E-02,4.907800E-01,& + & 4.532400E+00,9.766700E+00,1.951400E+01,3.667300E+01,8.188391E+01/ + data absb(:,1061:1080) / & + & 1.959400E-02,7.519300E-02,1.430900E-01,2.740800E-01,5.944600E-01,& + & 1.552800E+00,5.427200E+00,3.368300E+01,6.416300E+02,5.389200E+03,& + & 1.678000E+04,5.770000E+04,2.225000E+05,1.136477E+07,1.559500E-02,& + & 5.987700E-02,1.137400E-01,2.245200E-01,4.929100E-01,1.309000E+00,& + & 4.484900E+00,2.573300E+01,4.813600E+02,4.042100E+03,1.258500E+04,& + & 4.327500E+04,1.668800E+05,8.523475E+06,1.061900E-02,4.076500E-02,& + & 7.751900E-02,1.552000E-01,3.440100E-01,9.258500E-01,3.268100E+00,& + & 1.843100E+01,3.212400E+02,2.695000E+03,8.390100E+03,2.885000E+04,& + & 1.112500E+05,5.682516E+06,5.466600E-03,2.095900E-02,3.983700E-02,& + & 8.119300E-02,1.830200E-01,5.004800E-01,1.814200E+00,1.066000E+01,& + & 1.624300E+02,1.347900E+03,4.195400E+03,1.442500E+04,5.562600E+04,& + & 2.841232E+06,3.723700E-06,1.193800E-05,2.515500E-05,5.204000E-05,& + & 1.159200E-04,3.188300E-04,1.351000E-03,1.605400E-02,6.548400E-01,& + & 5.403500E+00,1.076000E+01,2.014300E+01,3.600200E+01,7.438739E+01,& + & 2.371000E-02,8.262000E-02,1.499000E-01,3.030200E-01,6.681600E-01,& + & 1.794500E+00,6.605000E+00,4.219400E+01,8.508200E+02,6.796300E+03,& + & 2.130800E+04,7.251300E+04,2.756500E+05,1.121820E+07,1.893100E-02,& + & 6.545800E-02,1.208700E-01,2.499900E-01,5.582600E-01,1.516100E+00,& + & 5.403100E+00,3.199900E+01,6.382500E+02,5.097300E+03,1.598100E+04,& + & 5.438500E+04,2.067400E+05,8.413688E+06,1.288900E-02,4.448800E-02,& + & 8.284100E-02,1.737400E-01,3.920500E-01,1.079700E+00,3.965100E+00,& + & 2.252900E+01,4.257300E+02,3.398400E+03,1.065400E+04,3.625700E+04,& + & 1.378300E+05,5.609136E+06,6.618600E-03,2.279800E-02,4.284800E-02,& + & 9.140900E-02,2.103000E-01,5.895800E-01,2.225900E+00,1.293100E+01,& + & 2.141900E+02,1.699500E+03,5.327500E+03,1.812900E+04,6.891300E+04,& + & 2.804552E+06,4.303100E-06,1.305000E-05,2.695500E-05,5.491400E-05,& + & 1.224900E-04,3.375800E-04,1.549400E-03,2.515000E-02,8.337100E-01,& + & 6.154600E+00,1.178700E+01,2.052600E+01,3.496700E+01,6.706113E+01,& + & 2.811200E-02,8.821600E-02,1.607600E-01,3.385100E-01,7.630000E-01,& + & 2.109100E+00,8.099200E+00,5.401100E+01,1.118800E+03,8.762700E+03,& + & 2.652600E+04,9.009700E+04,3.361300E+05,1.104874E+07,2.253700E-02,& + & 6.993600E-02,1.315500E-01,2.810500E-01,6.407600E-01,1.778600E+00,& + & 6.542000E+00,4.075400E+01,8.392700E+02,6.572200E+03,1.989500E+04,& + & 6.757300E+04,2.521000E+05,8.286451E+06,1.533600E-02,4.753000E-02,& + & 9.075500E-02,1.962900E-01,4.527300E-01,1.274300E+00,4.824900E+00,& + & 2.820800E+01,5.597000E+02,4.381600E+03,1.326400E+04,4.504900E+04,& + & 1.680700E+05,5.524390E+06,7.853700E-03,2.431600E-02,4.725900E-02,& + & 1.038600E-01,2.451000E-01,7.016100E-01,2.737300E+00,1.593500E+01,& + & 2.807200E+02,2.191000E+03,6.632100E+03,2.252500E+04,8.403400E+04,& + & 2.762230E+06,4.864800E-06,1.415400E-05,2.851200E-05,5.771700E-05,& + & 1.281500E-04,3.549700E-04,1.773100E-03,3.807700E-02,1.019800E+00,& + & 6.826700E+00,1.249000E+01,2.114500E+01,3.360500E+01,5.992297E+01,& + & 9.105500E-03,4.303900E-02,1.067400E-01,1.916000E-01,3.921300E-01,& + & 9.456400E-01,3.145600E+00,1.796300E+01,3.136800E+02,2.907200E+03,& + & 8.924200E+03,3.067000E+04,1.295500E+05,1.147225E+07,7.236300E-03,& + & 3.445300E-02,8.415000E-02,1.534000E-01,3.204000E-01,7.925600E-01,& + & 2.653900E+00,1.422200E+01,2.354500E+02,2.180600E+03,6.693300E+03,& + & 2.300300E+04,9.716000E+04,8.604270E+06,4.940100E-03,2.352400E-02,& + & 5.708800E-02,1.047200E-01,2.206200E-01,5.533200E-01,1.905100E+00,& + & 1.046000E+01,1.580900E+02,1.454000E+03,4.462400E+03,1.533500E+04,& + & 6.477300E+04,5.736257E+06,2.566400E-03,1.217000E-02,2.923000E-02,& + & 5.400700E-02,1.151900E-01,2.931700E-01,1.037000E+00,5.996800E+00,& + & 8.208600E+01,7.273400E+02,2.231500E+03,7.668100E+03,3.238700E+04,& + & 2.868057E+06,1.999700E-06,7.288000E-06,1.701800E-05,3.662500E-05,& + & 8.188600E-05,2.218900E-04,7.961800E-04,5.369600E-03,3.041000E-01,& + & 3.411500E+00,8.119200E+00,1.820800E+01,3.759200E+01,9.165524E+01/ + data absb(:,1081:1100) / & + & 1.183400E-02,5.125800E-02,1.120200E-01,2.009500E-01,4.297000E-01,& + & 1.072700E+00,3.628700E+00,2.201100E+01,4.041600E+02,3.719800E+03,& + & 1.162300E+04,4.077500E+04,1.629100E+05,1.138169E+07,9.430300E-03,& + & 4.103800E-02,8.828400E-02,1.635700E-01,3.543300E-01,9.055600E-01,& + & 3.061800E+00,1.718500E+01,3.032600E+02,2.790100E+03,8.717000E+03,& + & 3.058100E+04,1.221800E+05,8.536172E+06,6.431000E-03,2.799400E-02,& + & 5.992400E-02,1.124700E-01,2.455500E-01,6.362200E-01,2.216900E+00,& + & 1.263200E+01,2.029200E+02,1.860300E+03,5.811500E+03,2.038800E+04,& + & 8.145200E+04,5.690658E+06,3.327800E-03,1.444600E-02,3.067500E-02,& + & 5.846700E-02,1.292800E-01,3.406300E-01,1.219900E+00,7.335900E+00,& + & 1.040700E+02,9.305600E+02,2.906100E+03,1.019400E+04,4.072600E+04,& + & 2.845317E+06,2.447900E-06,8.396100E-06,1.855200E-05,3.932000E-05,& + & 8.802900E-05,2.409000E-04,9.443700E-04,8.223800E-03,4.398500E-01,& + & 4.257100E+00,9.334600E+00,1.934500E+01,3.689200E+01,8.433525E+01,& + & 1.488200E-02,5.890600E-02,1.152200E-01,2.178100E-01,4.737200E-01,& + & 1.236800E+00,4.331500E+00,2.734100E+01,5.365800E+02,4.720300E+03,& + & 1.509600E+04,5.253400E+04,2.043000E+05,1.126852E+07,1.187000E-02,& + & 4.709800E-02,9.160300E-02,1.790800E-01,3.945800E-01,1.051400E+00,& + & 3.636300E+00,2.107000E+01,4.025700E+02,3.540300E+03,1.132200E+04,& + & 3.940100E+04,1.532200E+05,8.451243E+06,8.084800E-03,3.208900E-02,& + & 6.238000E-02,1.237900E-01,2.755700E-01,7.440200E-01,2.652600E+00,& + & 1.532900E+01,2.688300E+02,2.360500E+03,7.548200E+03,2.626700E+04,& + & 1.021500E+05,5.634226E+06,4.165100E-03,1.651900E-02,3.202800E-02,& + & 6.470800E-02,1.465700E-01,4.028000E-01,1.473700E+00,8.949200E+00,& + & 1.365500E+02,1.180600E+03,3.774400E+03,1.313400E+04,5.107400E+04,& + & 2.817087E+06,2.896300E-06,9.448800E-06,2.007900E-05,4.187200E-05,& + & 9.359200E-05,2.585900E-04,1.097800E-03,1.320000E-02,5.976600E-01,& + & 5.115100E+00,1.040800E+01,1.998600E+01,3.640100E+01,7.679414E+01,& + & 1.815500E-02,6.550600E-02,1.200200E-01,2.404700E-01,5.313600E-01,& + & 1.433500E+00,5.300300E+00,3.449000E+01,7.212900E+02,6.027900E+03,& + & 1.935400E+04,6.649000E+04,2.540700E+05,1.113206E+07,1.452600E-02,& + & 5.209400E-02,9.680100E-02,1.992900E-01,4.468200E-01,1.223800E+00,& + & 4.409200E+00,2.630600E+01,5.411000E+02,4.521100E+03,1.451500E+04,& + & 4.986800E+04,1.905500E+05,8.348914E+06,9.891700E-03,3.542100E-02,& + & 6.627300E-02,1.385600E-01,3.142500E-01,8.721200E-01,3.242500E+00,& + & 1.880900E+01,3.610200E+02,3.014200E+03,9.677100E+03,3.324500E+04,& + & 1.270400E+05,5.566031E+06,5.080900E-03,1.816100E-02,3.424000E-02,& + & 7.286400E-02,1.686700E-01,4.774800E-01,1.821000E+00,1.094300E+01,& + & 1.821400E+02,1.507400E+03,4.838800E+03,1.662300E+04,6.351800E+04,& + & 2.782963E+06,3.361600E-06,1.038200E-05,2.158200E-05,4.429700E-05,& + & 9.892400E-05,2.747800E-04,1.265400E-03,2.121400E-02,7.725600E-01,& + & 5.898400E+00,1.139600E+01,2.030000E+01,3.541600E+01,6.974995E+01,& + & 2.167100E-02,7.036000E-02,1.281300E-01,2.688600E-01,6.068000E-01,& + & 1.687600E+00,6.541200E+00,4.453500E+01,9.633900E+02,7.836600E+03,& + & 2.433800E+04,8.286300E+04,3.117300E+05,1.097139E+07,1.740500E-02,& + & 5.594000E-02,1.049900E-01,2.246300E-01,5.135600E-01,1.440400E+00,& + & 5.374900E+00,3.371500E+01,7.226800E+02,5.877500E+03,1.825300E+04,& + & 6.214700E+04,2.338000E+05,8.228509E+06,1.184500E-02,3.801800E-02,& + & 7.238200E-02,1.569500E-01,3.637700E-01,1.033100E+00,3.981300E+00,& + & 2.363000E+01,4.820000E+02,3.918500E+03,1.216900E+04,4.143100E+04,& + & 1.558600E+05,5.485561E+06,6.069100E-03,1.944500E-02,3.766000E-02,& + & 8.300300E-02,1.971400E-01,5.709200E-01,2.262200E+00,1.355900E+01,& + & 2.421400E+02,1.959400E+03,6.084700E+03,2.071600E+04,7.793200E+04,& + & 2.742798E+06,3.829300E-06,1.124800E-05,2.297200E-05,4.649600E-05,& + & 1.038800E-04,2.896400E-04,1.454600E-03,3.291500E-02,9.568900E-01,& + & 6.600300E+00,1.221200E+01,2.092900E+01,3.372500E+01,6.286226E+01/ + data absb(:,1101:1120) / & + & 6.728600E-03,3.267400E-02,8.465700E-02,1.548800E-01,3.125600E-01,& + & 7.515100E-01,2.505000E+00,1.436800E+01,2.581900E+02,2.436700E+03,& + & 7.762200E+03,2.713400E+04,1.184400E+05,1.135900E+07,5.359100E-03,& + & 2.623700E-02,6.699600E-02,1.238200E-01,2.560300E-01,6.331500E-01,& + & 2.137200E+00,1.156400E+01,1.939000E+02,1.827700E+03,5.821800E+03,& + & 2.035100E+04,8.883000E+04,8.519164E+06,3.661800E-03,1.792200E-02,& + & 4.548800E-02,8.440700E-02,1.762700E-01,4.419600E-01,1.533300E+00,& + & 8.555000E+00,1.306600E+02,1.218700E+03,3.881400E+03,1.356700E+04,& + & 5.922000E+04,5.679331E+06,1.904800E-03,9.280500E-03,2.332000E-02,& + & 4.345900E-02,9.192600E-02,2.341400E-01,8.340900E-01,4.911800E+00,& + & 6.860200E+01,6.097000E+02,1.941000E+03,6.784100E+03,2.961000E+04,& + & 2.839699E+06,1.517900E-06,5.671500E-06,1.352400E-05,2.930700E-05,& + & 6.568600E-05,1.783400E-04,6.352400E-04,4.240200E-03,2.646300E-01,& + & 3.109800E+00,7.710600E+00,1.776600E+01,3.759000E+01,9.429903E+01,& + & 8.862000E-03,3.960900E-02,8.996100E-02,1.608200E-01,3.423000E-01,& + & 8.509100E-01,2.889700E+00,1.771800E+01,3.345700E+02,3.176600E+03,& + & 1.029000E+04,3.673000E+04,1.490200E+05,1.127618E+07,7.073300E-03,& + & 3.183500E-02,7.103500E-02,1.309300E-01,2.832200E-01,7.230600E-01,& + & 2.471700E+00,1.404300E+01,2.511000E+02,2.382600E+03,7.717800E+03,& + & 2.754700E+04,1.117600E+05,8.456895E+06,4.826400E-03,2.173000E-02,& + & 4.821900E-02,8.992500E-02,1.963000E-01,5.080400E-01,1.790000E+00,& + & 1.043300E+01,1.683800E+02,1.588700E+03,5.145400E+03,1.836500E+04,& + & 7.450800E+04,5.637941E+06,2.501300E-03,1.122300E-02,2.468600E-02,& + & 4.668100E-02,1.032500E-01,2.721400E-01,9.848900E-01,6.083800E+00,& + & 8.707600E+01,7.947500E+02,2.573000E+03,9.182700E+03,3.725400E+04,& + & 2.818982E+06,1.880700E-06,6.590400E-06,1.478700E-05,3.155900E-05,& + & 7.081000E-05,1.947100E-04,7.595900E-04,6.567200E-03,3.913300E-01,& + & 3.970400E+00,8.936300E+00,1.898300E+01,3.734000E+01,8.667406E+01,& + & 1.126500E-02,4.600600E-02,9.282800E-02,1.731200E-01,3.774800E-01,& + & 9.835300E-01,3.450200E+00,2.211900E+01,4.472600E+02,4.113600E+03,& + & 1.355200E+04,4.779800E+04,1.874700E+05,1.117082E+07,9.008800E-03,& + & 3.692200E-02,7.380800E-02,1.428400E-01,3.157400E-01,8.428100E-01,& + & 2.941200E+00,1.725000E+01,3.355800E+02,3.085400E+03,1.016400E+04,& + & 3.584800E+04,1.406000E+05,8.378158E+06,6.138200E-03,2.517200E-02,& + & 5.023000E-02,9.871900E-02,2.205800E-01,5.965600E-01,2.148100E+00,& + & 1.273600E+01,2.243500E+02,2.057200E+03,6.776000E+03,2.389900E+04,& + & 9.373600E+04,5.572803E+06,3.165000E-03,1.297300E-02,2.577200E-02,& + & 5.155800E-02,1.172300E-01,3.233700E-01,1.194300E+00,7.491400E+00,& + & 1.146200E+02,1.029000E+03,3.388200E+03,1.195000E+04,4.686800E+04,& + & 2.792703E+06,2.248300E-06,7.454200E-06,1.603000E-05,3.368100E-05,& + & 7.553300E-05,2.096100E-04,8.894800E-04,1.075000E-02,5.423100E-01,& + & 4.803800E+00,1.005100E+01,1.983700E+01,3.643700E+01,7.955020E+01,& + & 1.387300E-02,5.174000E-02,9.627100E-02,1.908400E-01,4.222900E-01,& + & 1.143300E+00,4.241100E+00,2.811100E+01,6.089700E+02,5.334500E+03,& + & 1.754300E+04,6.085800E+04,2.339500E+05,1.104315E+07,1.111600E-02,& + & 4.135200E-02,7.762000E-02,1.588300E-01,3.572500E-01,9.860900E-01,& + & 3.589200E+00,2.161400E+01,4.568700E+02,4.001000E+03,1.315700E+04,& + & 4.564400E+04,1.754600E+05,8.282346E+06,7.570900E-03,2.813700E-02,& + & 5.306800E-02,1.104300E-01,2.516200E-01,7.032500E-01,2.643400E+00,& + & 1.571000E+01,3.049600E+02,2.667500E+03,8.771500E+03,3.042900E+04,& + & 1.169700E+05,5.521505E+06,3.891100E-03,1.443600E-02,2.738500E-02,& + & 5.803100E-02,1.350600E-01,3.859400E-01,1.485800E+00,9.246600E+00,& + & 1.544300E+02,1.334000E+03,4.386000E+03,1.521500E+04,5.848700E+04,& + & 2.760759E+06,2.618400E-06,8.253700E-06,1.727900E-05,3.568000E-05,& + & 7.990700E-05,2.232700E-04,1.031100E-03,1.772900E-02,7.119800E-01,& + & 5.642800E+00,1.099000E+01,2.028800E+01,3.559800E+01,7.237742E+01/ + data absb(:,1121:1140) / & + & 1.667600E-02,5.605400E-02,1.022100E-01,2.133600E-01,4.820900E-01,& + & 1.348400E+00,5.271200E+00,3.658100E+01,8.262800E+02,7.001700E+03,& + & 2.228400E+04,7.617000E+04,2.887000E+05,1.089221E+07,1.341500E-02,& + & 4.468600E-02,8.383500E-02,1.793100E-01,4.112700E-01,1.165000E+00,& + & 4.410500E+00,2.783200E+01,6.198500E+02,5.251300E+03,1.671300E+04,& + & 5.712700E+04,2.165300E+05,8.169102E+06,9.129600E-03,3.038200E-02,& + & 5.772500E-02,1.253400E-01,2.918800E-01,8.365700E-01,3.277600E+00,& + & 1.980000E+01,4.134700E+02,3.501000E+03,1.114200E+04,3.808500E+04,& + & 1.443500E+05,5.446034E+06,4.680300E-03,1.554100E-02,3.000400E-02,& + & 6.623600E-02,1.583300E-01,4.639300E-01,1.864700E+00,1.152500E+01,& + & 2.081800E+02,1.750700E+03,5.571400E+03,1.904300E+04,7.217500E+04,& + & 2.722946E+06,3.002000E-06,8.967500E-06,1.844200E-05,3.752400E-05,& + & 8.409600E-05,2.360400E-04,1.191300E-03,2.824700E-02,8.945100E-01,& + & 6.356400E+00,1.193400E+01,2.053900E+01,3.456200E+01,6.524947E+01,& + & 1.311200E-03,6.516300E-03,1.765600E-02,3.308700E-02,6.583400E-02,& + & 1.579300E-01,5.263900E-01,3.033400E+00,5.614400E+01,5.379700E+02,& + & 1.776700E+03,6.346800E+03,2.865400E+04,2.965700E+06,1.281100E-03,& + & 6.421500E-03,1.715000E-02,3.232200E-02,6.613200E-02,1.635600E-01,& + & 5.562800E-01,3.045800E+00,5.159800E+01,4.933000E+02,1.629000E+03,& + & 5.819100E+03,2.627200E+04,2.719107E+06,1.127400E-03,5.647000E-03,& + & 1.498800E-02,2.831000E-02,5.854800E-02,1.468300E-01,5.131000E-01,& + & 2.911800E+00,4.495200E+01,4.230600E+02,1.396800E+03,4.989500E+03,& + & 2.252600E+04,2.331387E+06,8.234000E-04,4.103200E-03,1.077900E-02,& + & 2.039500E-02,4.273400E-02,1.089600E-01,3.909100E-01,2.344900E+00,& + & 3.357500E+01,2.965300E+02,9.785500E+02,3.494900E+03,1.577700E+04,& + & 1.632861E+06,1.151900E-06,4.412700E-06,1.074700E-05,2.345500E-05,& + & 5.266700E-05,1.432600E-04,5.064100E-04,3.348000E-03,2.294500E-01,& + & 2.840200E+00,7.285800E+00,1.735100E+01,3.728600E+01,9.707085E+01,& + & 1.751800E-03,8.061700E-03,1.901500E-02,3.405300E-02,7.196800E-02,& + & 1.783400E-01,6.077200E-01,3.759500E+00,7.324800E+01,7.143800E+02,& + & 2.406800E+03,8.723800E+03,3.609000E+04,2.945362E+06,1.712600E-03,& + & 7.950800E-03,1.841100E-02,3.390700E-02,7.310900E-02,1.866500E-01,& + & 6.455300E-01,3.716500E+00,6.723000E+01,6.550500E+02,2.206700E+03,& + & 7.998400E+03,3.308900E+04,2.700441E+06,1.504500E-03,6.985300E-03,& + & 1.607700E-02,2.992100E-02,6.519700E-02,1.687200E-01,6.013500E-01,& + & 3.585700E+00,5.818500E+01,5.617700E+02,1.892200E+03,6.858000E+03,& + & 2.837100E+04,2.315381E+06,1.094100E-03,5.061900E-03,1.153600E-02,& + & 2.172900E-02,4.800200E-02,1.267500E-01,4.637200E-01,2.941000E+00,& + & 4.264200E+01,3.937200E+02,1.325400E+03,4.803500E+03,1.987100E+04,& + & 1.621696E+06,1.446700E-06,5.155000E-06,1.180500E-05,2.533600E-05,& + & 5.698400E-05,1.573100E-04,6.103500E-04,5.234500E-03,3.468000E-01,& + & 3.695400E+00,8.560900E+00,1.867300E+01,3.754700E+01,8.899966E+01,& + & 2.249800E-03,9.468500E-03,1.973600E-02,3.637600E-02,7.943700E-02,& + & 2.065000E-01,7.253900E-01,4.730900E+00,9.856600E+01,9.450800E+02,& + & 3.212200E+03,1.149300E+04,4.549200E+04,2.919865E+06,2.205300E-03,& + & 9.329700E-03,1.919900E-02,3.683900E-02,8.165600E-02,2.182800E-01,& + & 7.701600E-01,4.586600E+00,9.042100E+01,8.665600E+02,2.945200E+03,& + & 1.053700E+04,4.171000E+04,2.677045E+06,1.934500E-03,8.187200E-03,& + & 1.679400E-02,3.273600E-02,7.342800E-02,1.988700E-01,7.240300E-01,& + & 4.420400E+00,7.790300E+01,7.431100E+02,2.525300E+03,9.034900E+03,& + & 3.576200E+04,2.295343E+06,1.399400E-03,5.918700E-03,1.206700E-02,& + & 2.393500E-02,5.463100E-02,1.512900E-01,5.646300E-01,3.668500E+00,& + & 5.621500E+01,5.207200E+02,1.768800E+03,6.328100E+03,2.504800E+04,& + & 1.607618E+06,1.744500E-06,5.880900E-06,1.280800E-05,2.709500E-05,& + & 6.087400E-05,1.698600E-04,7.205600E-04,8.746600E-03,4.912700E-01,& + & 4.529900E+00,9.659700E+00,1.970800E+01,3.665000E+01,8.192180E+01/ + data absb(:,1141:1160) / & + & 2.798000E-03,1.075300E-02,2.041900E-02,4.000900E-02,8.866200E-02,& + & 2.408400E-01,8.955800E-01,6.054300E+00,1.357700E+02,1.247300E+03,& + & 4.202700E+03,1.472900E+04,5.695300E+04,2.888350E+06,2.746700E-03,& + & 1.056800E-02,2.012700E-02,4.091400E-02,9.238300E-02,2.568800E-01,& + & 9.450700E-01,5.762000E+00,1.245200E+02,1.143600E+03,3.853300E+03,& + & 1.350400E+04,5.221700E+04,2.648192E+06,2.406400E-03,9.258500E-03,& + & 1.767800E-02,3.658600E-02,8.380900E-02,2.360200E-01,8.968200E-01,& + & 5.486900E+00,1.070000E+02,9.806100E+02,3.303900E+03,1.157900E+04,& + & 4.477200E+04,2.270576E+06,1.733700E-03,6.662900E-03,1.276600E-02,& + & 2.691800E-02,6.303500E-02,1.819700E-01,7.073900E-01,4.572300E+00,& + & 7.631600E+01,6.869900E+02,2.314200E+03,8.109900E+03,3.135800E+04,& + & 1.590310E+06,2.042700E-06,6.557100E-06,1.380700E-05,2.873700E-05,& + & 6.461900E-05,1.812700E-04,8.391800E-04,1.481000E-02,6.558000E-01,& + & 5.359500E+00,1.063700E+01,2.021000E+01,3.600500E+01,7.466508E+01,& + & 3.386800E-03,1.177300E-02,2.154700E-02,4.470600E-02,1.011800E-01,& + & 2.845300E-01,1.121500E+00,7.933600E+00,1.871600E+02,1.655900E+03,& + & 5.388200E+03,1.853100E+04,7.061700E+04,2.850770E+06,3.339400E-03,& + & 1.151400E-02,2.164000E-02,4.623600E-02,1.065300E-01,3.046600E-01,& + & 1.172800E+00,7.437200E+00,1.716400E+02,1.518200E+03,4.940200E+03,& + & 1.699000E+04,6.474500E+04,2.613716E+06,2.922400E-03,1.007300E-02,& + & 1.914300E-02,4.158500E-02,9.745800E-02,2.820900E-01,1.124000E+00,& + & 6.932500E+00,1.473100E+02,1.301800E+03,4.235900E+03,1.456800E+04,& + & 5.551300E+04,2.241041E+06,2.099800E-03,7.219800E-03,1.392500E-02,& + & 3.077800E-02,7.411000E-02,2.201300E-01,8.976900E-01,5.736700E+00,& + & 1.042400E+02,9.119100E+02,2.966900E+03,1.020300E+04,3.888100E+04,& + & 1.569610E+06,2.354200E-06,7.147800E-06,1.476600E-05,3.032400E-05,& + & 6.798800E-05,1.922200E-04,9.749800E-04,2.421500E-02,8.348100E-01,& + & 6.105400E+00,1.154200E+01,2.034600E+01,3.498300E+01,6.791127E+01,& + & 1.209400E-03,6.067800E-03,1.676800E-02,3.177400E-02,6.305500E-02,& + & 1.515900E-01,5.077400E-01,2.976500E+00,5.724600E+01,5.595300E+02,& + & 1.923300E+03,7.059300E+03,3.242500E+04,3.465578E+06,1.135100E-03,& + & 5.748400E-03,1.563500E-02,2.977900E-02,6.106900E-02,1.522900E-01,& + & 5.272500E-01,2.976500E+00,5.029900E+01,4.886600E+02,1.679400E+03,& + & 6.164000E+03,2.831200E+04,3.026012E+06,9.334000E-04,4.718100E-03,& + & 1.273800E-02,2.430200E-02,5.045100E-02,1.276400E-01,4.540000E-01,& + & 2.684500E+00,4.134700E+01,3.899300E+02,1.339700E+03,4.917000E+03,& + & 2.258300E+04,2.413704E+06,6.096400E-04,3.062500E-03,8.168600E-03,& + & 1.559500E-02,3.282500E-02,8.463100E-02,3.092500E-01,1.942700E+00,& + & 2.854200E+01,2.431100E+02,8.339300E+02,3.060000E+03,1.405300E+04,& + & 1.501979E+06,9.065400E-07,3.529200E-06,8.670600E-06,1.901000E-05,& + & 4.279600E-05,1.168000E-04,4.159800E-04,2.832000E-03,2.139000E-01,& + & 2.708100E+00,7.127500E+00,1.714700E+01,3.733700E+01,9.809717E+01,& + & 1.625700E-03,7.577500E-03,1.815100E-02,3.264400E-02,6.899500E-02,& + & 1.716600E-01,5.890600E-01,3.719300E+00,7.556900E+01,7.560000E+02,& + & 2.658500E+03,9.779900E+03,4.087400E+04,3.443040E+06,1.525400E-03,& + & 7.184300E-03,1.686800E-02,3.126700E-02,6.778200E-02,1.748100E-01,& + & 6.177200E-01,3.669700E+00,6.618100E+01,6.602200E+02,2.321400E+03,& + & 8.539600E+03,3.568900E+04,3.006326E+06,1.250900E-03,5.887100E-03,& + & 1.372400E-02,2.571800E-02,5.646200E-02,1.478100E-01,5.377700E-01,& + & 3.357600E+00,5.381800E+01,5.268000E+02,1.851800E+03,6.811800E+03,& + & 2.846800E+04,2.398023E+06,8.126000E-04,3.807600E-03,8.774900E-03,& + & 1.663600E-02,3.705900E-02,9.947900E-02,3.715100E-01,2.479200E+00,& + & 3.613800E+01,3.281700E+02,1.152500E+03,4.239000E+03,1.771500E+04,& + & 1.488386E+06,1.144000E-06,4.124400E-06,9.536000E-06,2.053600E-05,& + & 4.628900E-05,1.284000E-04,5.034200E-04,4.526100E-03,3.268700E-01,& + & 3.528000E+00,8.430200E+00,1.858400E+01,3.735400E+01,9.031617E+01/ + data absb(:,1161:1175) / & + & 2.098100E-03,8.950400E-03,1.890000E-02,3.480000E-02,7.628000E-02,& + & 1.995300E-01,7.079600E-01,4.724500E+00,1.029700E+02,1.021300E+03,& + & 3.589800E+03,1.296400E+04,5.156900E+04,3.414049E+06,1.974100E-03,& + & 8.479300E-03,1.764100E-02,3.404100E-02,7.611100E-02,2.059500E-01,& + & 7.449000E-01,4.554200E+00,9.003100E+01,8.918500E+02,3.134500E+03,& + & 1.132000E+04,4.502900E+04,2.980994E+06,1.615100E-03,6.938500E-03,& + & 1.437200E-02,2.820700E-02,6.400900E-02,1.758700E-01,6.552500E-01,& + & 4.191600E+00,7.262000E+01,7.115500E+02,2.500400E+03,9.029300E+03,& + & 3.591700E+04,2.377789E+06,1.042600E-03,4.470600E-03,9.201500E-03,& + & 1.836800E-02,4.246400E-02,1.201300E-01,4.585100E-01,3.142800E+00,& + & 4.760600E+01,4.430900E+02,1.556100E+03,5.618800E+03,2.235000E+04,& + & 1.479604E+06,1.385200E-06,4.705600E-06,1.035600E-05,2.195700E-05,& + & 4.945900E-05,1.387100E-04,5.960900E-04,7.766900E-03,4.658200E-01,& + & 4.351100E+00,9.536000E+00,1.943400E+01,3.714600E+01,8.295130E+01,& + & 2.620300E-03,1.020200E-02,1.956400E-02,3.829500E-02,8.528400E-02,& + & 2.337700E-01,8.813000E-01,6.112000E+00,1.436900E+02,1.374700E+03,& + & 4.729200E+03,1.667100E+04,6.465900E+04,3.378032E+06,2.469100E-03,& + & 9.640000E-03,1.852900E-02,3.794600E-02,8.660600E-02,2.443900E-01,& + & 9.251700E-01,5.734200E+00,1.255500E+02,1.200400E+03,4.129400E+03,& + & 1.455600E+04,5.645800E+04,2.949624E+06,2.015000E-03,7.873200E-03,& + & 1.515900E-02,3.164700E-02,7.358300E-02,2.109700E-01,8.225100E-01,& + & 5.252000E+00,1.007200E+02,9.576500E+02,3.294000E+03,1.161100E+04,& + & 4.503400E+04,2.352779E+06,1.294300E-03,5.041600E-03,9.748800E-03,& + & 2.074600E-02,4.938400E-02,1.463100E-01,5.830800E-01,3.968800E+00,& + & 6.480700E+01,5.961500E+02,2.049900E+03,7.225300E+03,2.802300E+04,& + & 1.464047E+06,1.627000E-06,5.254600E-06,1.114900E-05,2.328800E-05,& + & 5.244200E-05,1.480400E-04,6.966100E-04,1.346100E-02,6.271200E-01,& + & 5.121500E+00,1.047200E+01,2.017500E+01,3.579400E+01,7.646090E+01,& + & 3.181400E-03,1.122100E-02,2.062000E-02,4.285700E-02,9.758500E-02,& + & 2.776900E-01,1.113000E+00,8.108600E+00,2.010500E+02,1.847400E+03,& + & 6.090200E+03,2.103500E+04,8.031200E+04,3.334912E+06,3.012200E-03,& + & 1.053900E-02,1.996200E-02,4.306900E-02,1.005000E-01,2.924300E-01,& + & 1.161900E+00,7.415100E+00,1.756200E+02,1.613100E+03,5.317800E+03,& + & 1.836700E+04,7.012500E+04,2.911852E+06,2.454000E-03,8.585300E-03,& + & 1.645800E-02,3.613500E-02,8.623000E-02,2.548400E-01,1.044900E+00,& + & 6.676900E+00,1.404600E+02,1.286800E+03,4.241900E+03,1.465100E+04,& + & 5.593600E+04,2.322695E+06,1.570900E-03,5.471100E-03,1.064700E-02,& + & 2.384200E-02,5.857400E-02,1.792000E-01,7.511800E-01,5.032700E+00,& + & 8.919900E+01,8.009100E+02,2.639800E+03,9.116800E+03,3.480700E+04,& + & 1.445337E+06,1.868700E-06,5.759100E-06,1.190500E-05,2.452800E-05,& + & 5.519800E-05,1.567800E-04,8.122600E-04,2.236300E-02,8.029200E-01,& + & 5.917900E+00,1.115000E+01,2.051600E+01,3.485800E+01,6.974457E+01/ + + + data selfref(:, :) / & + & 2.629220E-01,2.454480E-01,2.415950E-01,2.448180E-01,2.434580E-01,& + & 2.401860E-01,2.427520E-01,2.396200E-01,2.388560E-01,2.298210E-01,& + & 2.399450E-01,2.402710E-01,2.405030E-01,2.406829E-01,2.291060E-01,& + & 2.132120E-01,2.096970E-01,2.121720E-01,2.109830E-01,2.087450E-01,& + & 2.105790E-01,2.081660E-01,2.071660E-01,2.005860E-01,2.081860E-01,& + & 2.084650E-01,2.086700E-01,2.088220E-01,1.996400E-01,1.852100E-01,& + & 1.820100E-01,1.838800E-01,1.828400E-01,1.814200E-01,1.826700E-01,& + & 1.808400E-01,1.796800E-01,1.750700E-01,1.806300E-01,1.808700E-01,& + & 1.810500E-01,1.811794E-01,1.739640E-01,1.608860E-01,1.579790E-01,& + & 1.593600E-01,1.584510E-01,1.576720E-01,1.584600E-01,1.571010E-01,& + & 1.558410E-01,1.528000E-01,1.567220E-01,1.569270E-01,1.570860E-01,& + & 1.571958E-01,1.515890E-01,1.397560E-01,1.371210E-01,1.381100E-01,& + & 1.373150E-01,1.370320E-01,1.374590E-01,1.364790E-01,1.351650E-01,& + & 1.333630E-01,1.359780E-01,1.361540E-01,1.362940E-01,1.363868E-01,& + & 1.320930E-01,1.214010E-01,1.190160E-01,1.196940E-01,1.189980E-01,& + & 1.190950E-01,1.192400E-01,1.185630E-01,1.172320E-01,1.163980E-01,& + & 1.179800E-01,1.181310E-01,1.182540E-01,1.183329E-01,1.151040E-01,& + & 1.054570E-01,1.033020E-01,1.037330E-01,1.031250E-01,1.035050E-01,& + & 1.034370E-01,1.030000E-01,1.016780E-01,1.015910E-01,1.023640E-01,& + & 1.024940E-01,1.026020E-01,1.026679E-01,1.003000E-01,9.160700E-02,& + & 8.966300E-02,8.990100E-02,8.936900E-02,8.995600E-02,8.972800E-02,& + & 8.947900E-02,8.818800E-02,8.866800E-02,8.881500E-02,8.892600E-02,& + & 8.902100E-02,8.907728E-02,8.740000E-02,7.957590E-02,7.782460E-02,& + & 7.791310E-02,7.744800E-02,7.818060E-02,7.783590E-02,7.773320E-02,& + & 7.648770E-02,7.738870E-02,7.705940E-02,7.715450E-02,7.723800E-02,& + & 7.728556E-02,7.615920E-02,6.912490E-02,6.754920E-02,6.752380E-02,& + & 6.711710E-02,6.794670E-02,6.752000E-02,6.752920E-02,6.633970E-02,& + & 6.754430E-02,6.685980E-02,6.694120E-02,6.701470E-02,6.705485E-02/ + +! --- the array forref contains the coefficient of the water vapor +! foreign-continuum (including the energy term). the first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. the second index +! runs over the g-channel (1 to NG04=14). + + data forref(:, :) / & + & 3.383900E-04,2.473900E-04,2.284600E-04,2.337600E-04,2.262200E-04,& + & 2.318800E-04,2.299000E-04,2.253200E-04,2.123300E-04,2.059300E-04,& + & 2.071600E-04,2.080900E-04,2.088900E-04,2.093565E-04,3.439100E-04,& + & 2.602200E-04,2.344900E-04,2.454400E-04,2.383100E-04,2.301400E-04,& + & 2.372900E-04,2.272600E-04,2.189200E-04,1.922300E-04,2.129100E-04,& + & 2.140600E-04,2.149100E-04,2.155240E-04,3.421900E-04,2.733400E-04,& + & 2.372700E-04,2.451500E-04,2.527200E-04,2.421200E-04,2.382400E-04,& + & 2.361500E-04,2.272400E-04,2.238100E-04,1.963400E-04,2.162500E-04,& + & 2.196300E-04,2.203955E-04,3.168400E-04,2.482300E-04,2.489000E-04,& + & 2.457700E-04,2.410600E-04,2.435300E-04,2.403800E-04,2.393200E-04,& + & 2.360400E-04,2.377300E-04,2.424300E-04,2.259700E-04,2.287900E-04,& + & 2.205148E-04 / + + data fracrefa(:,:) / & + & 1.557200e-01,1.492500e-01,1.410700e-01,1.312600e-01,1.179100e-01,& + & 1.017300e-01,8.294900e-02,6.239300e-02,4.214600e-02,4.590700e-03,& + & 3.796500e-03,2.974400e-03,2.207400e-03,2.011015e-03,1.557200e-01,& + & 1.492500e-01,1.410700e-01,1.312600e-01,1.179100e-01,1.017300e-01,& + & 8.294900e-02,6.239200e-02,4.214600e-02,4.590600e-03,3.796500e-03,& + & 2.974500e-03,2.207400e-03,2.011015e-03,1.557200e-01,1.492500e-01,& + & 1.410700e-01,1.312600e-01,1.179100e-01,1.017300e-01,8.294900e-02,& + & 6.239300e-02,4.214600e-02,4.590700e-03,3.796500e-03,2.974500e-03,& + & 2.207400e-03,2.011015e-03,1.557200e-01,1.492500e-01,1.410700e-01,& + & 1.312600e-01,1.179100e-01,1.017300e-01,8.294900e-02,6.239300e-02,& + & 4.214600e-02,4.590700e-03,3.796400e-03,2.974400e-03,2.207400e-03,& + & 2.011015e-03,1.557200e-01,1.492500e-01,1.410700e-01,1.312600e-01,& + & 1.179100e-01,1.017300e-01,8.294900e-02,6.239300e-02,4.214600e-02,& + & 4.590700e-03,3.796500e-03,2.974400e-03,2.207400e-03,2.011015e-03,& + & 1.557200e-01,1.492500e-01,1.410700e-01,1.312600e-01,1.179100e-01,& + & 1.017300e-01,8.294900e-02,6.239300e-02,4.214600e-02,4.590700e-03,& + & 3.796500e-03,2.974400e-03,2.207400e-03,2.011015e-03,1.557200e-01,& + & 1.492600e-01,1.410700e-01,1.312600e-01,1.179100e-01,1.017300e-01,& + & 8.294900e-02,6.239300e-02,4.214600e-02,4.590800e-03,3.796400e-03,& + & 2.974500e-03,2.207400e-03,2.011015e-03,1.557100e-01,1.492600e-01,& + & 1.410700e-01,1.312500e-01,1.179100e-01,1.017300e-01,8.294900e-02,& + & 6.239300e-02,4.214600e-02,4.590700e-03,3.796400e-03,2.974400e-03,& + & 2.207400e-03,2.011015e-03,1.595200e-01,1.515500e-01,1.421700e-01,& + & 1.307700e-01,1.166700e-01,1.004800e-01,8.151100e-02,6.107600e-02,& + & 4.111100e-02,4.443200e-03,3.691000e-03,2.907600e-03,2.132900e-03,& + & 1.958885e-03 / + + data fracrefb(:,:) / & + & 1.555800e-01,1.493100e-01,1.410400e-01,1.312400e-01,1.179300e-01,& + & 1.016000e-01,8.314200e-02,6.240300e-02,4.217000e-02,4.593500e-03,& + & 3.797600e-03,2.998600e-03,2.189000e-03,2.010737e-03,1.555800e-01,& + & 1.493200e-01,1.410400e-01,1.312400e-01,1.179200e-01,1.015900e-01,& + & 8.314200e-02,6.240300e-02,4.217000e-02,4.593500e-03,3.797600e-03,& + & 2.998600e-03,2.189000e-03,2.010737e-03,1.555800e-01,1.493300e-01,& + & 1.410300e-01,1.312400e-01,1.179200e-01,1.015900e-01,8.314200e-02,& + & 6.240300e-02,4.217000e-02,4.593500e-03,3.797600e-03,2.998600e-03,& + & 2.189000e-03,2.010737e-03,1.556900e-01,1.492600e-01,1.410200e-01,& + & 1.312200e-01,1.179100e-01,1.015900e-01,8.314100e-02,6.240300e-02,& + & 4.217000e-02,4.593500e-03,3.797600e-03,2.998600e-03,2.189000e-03,& + & 2.010737e-03,1.594700e-01,1.513200e-01,1.419500e-01,1.306100e-01,& + & 1.168000e-01,1.005400e-01,8.178500e-02,6.121200e-02,4.127600e-02,& + & 4.442400e-03,3.662800e-03,2.894300e-03,2.113400e-03,1.929938e-03/ + +!........................................! + end module module_radlw_kgb04 ! +!========================================! + + +!> This module sets up absorption coefficients for band 05: 700-820 +!! cm-1 (low - h2o, co2; high - co2, o3) +!========================================! + module module_radlw_kgb05 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG05 +! + implicit none +! + private +! +!> msa05=585 + integer, public :: MSA05 +!> msb05=1175 + integer, public :: MSB05 +!> msf05=10 + integer, public :: MSF05 +!> mfr05=4 + integer, public :: MFR05 +!> maf05=9 + integer, public :: MAF05 +!> mbf05=5 + integer, public :: MBF05 +!> mmo05=19 + integer, public :: MMO05 + parameter (MSA05=585, MSB05=1175, MSF05=10, MFR05=4) + parameter (MAF05=9, MBF05=5, MMO05=19) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG05=16). + real (kind=kind_phys), public :: forref(NG05,MFR05) + +!> the array absa(NG05,585) = ka(NG05,9,5,13) contains absorption coefs +!! at the NG05=16 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different water +!! vapor to co2 ratios, as expressed through the binary species +!! parameter eta, defined as eta = gas1/(gas1+(rat)*gas2), where rat is +!! the ratio of the reference mls column amount value of gas1 to that +!! of gas2. the 2nd index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 1-5 +!! means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! third index, jp, runs from 1 to 13 and refers to the reference +!! pressure level (e.g. jp = 1 is for a pressure of 1053.63 mb). the +!! fourth index, ig, goes from 1 to NG05=16, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG05,MSA05) + +!> the array absb(NG05,1175) = kb(NG05,5,5,13:59) contains absorption +!! coefs at the NG05=16 g-intervals for a range of pressure levels < +!! ~100mb, temperatures, and ratios of h2o to co2. the first index in +!! the array, js, runs from 1 to 5, and corresponds to different gas +!! amount ratios, as expressed through the binary species parameter +!! eta, defined as eta = gas1/(gas1+rat*gas2), where rat is the ratio +!! of the reference mls column amount value of gas1 to that of gas2. +!! the second index, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that +!! the data are for the corresponding temperature of tref-30, tref-15, +!! tref, tref+15, and tref+30, respectively. the third index, jp, +!! runs from 13 to 59 and refers to the reference pressure level (e.g. +!! jp = 13 is for a pressure of 95.5835 mb). the fourth index, ig, +!! goes from 1 to NG05=16, and tells us which g-interval the absorption +!! coefficients are for. + real (kind=kind_phys), public :: absb(NG05,MSB05) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG05=16). + real (kind=kind_phys), public :: selfref(NG05,MSF05) + +!> planck fraction mapping level : p = 473.42 mb, t = 259.83 k + real (kind=kind_phys), public :: fracrefa(NG05,MAF05) + +!> planck fraction mapping level : p = 0.2369280 mbar, t = 253.60 k + real (kind=kind_phys), public :: fracrefb(NG05,MBF05) + + real (kind=kind_phys), public :: ka_mo3(NG05,MAF05,MMO05) + +!> minor gas (o3, ccl4) mapping level : p = 317.34 mbar, t = 240.77 k + real (kind=kind_phys), public :: ccl4(NG05) + + + data absa(:, 1: 20) / & + & 2.062700E-06,6.230000E-06,2.196700E-05,1.276700E-04,5.289700E-04,& + & 1.302800E-03,3.505400E-03,7.553000E-03,1.755700E-02,4.831200E-02,& + & 6.900100E-02,9.631800E-02,1.249000E-01,1.454600E-01,1.905100E-01,& + & 2.058400E-01,7.661900E-06,2.312400E-05,7.084700E-05,2.643600E-04,& + & 6.386300E-04,1.479200E-03,3.505500E-03,7.194600E-03,1.609800E-02,& + & 4.239500E-02,6.052900E-02,8.430600E-02,1.093200E-01,1.272900E-01,& + & 1.667400E-01,1.801400E-01,1.282100E-05,2.969800E-05,9.805600E-05,& + & 3.051200E-04,6.771600E-04,1.564000E-03,3.512000E-03,6.930900E-03,& + & 1.525200E-02,3.702900E-02,5.206400E-02,7.232000E-02,9.372000E-02,& + & 1.091300E-01,1.429200E-01,1.544400E-01,1.854700E-05,3.959100E-05,& + & 1.168300E-04,3.179900E-04,6.859200E-04,1.578300E-03,3.381000E-03,& + & 6.647600E-03,1.459100E-02,3.426800E-02,4.559000E-02,6.034700E-02,& + & 7.812100E-02,9.096900E-02,1.191800E-01,1.287400E-01,2.569400E-05,& + & 5.838000E-05,1.267200E-04,3.195800E-04,6.678100E-04,1.533800E-03,& + & 3.173000E-03,6.128600E-03,1.419400E-02,3.163100E-02,4.062800E-02,& + & 5.207900E-02,6.379400E-02,7.281600E-02,9.539600E-02,1.030400E-01,& + & 3.683300E-05,9.512500E-05,1.338600E-04,3.319100E-04,6.093700E-04,& + & 1.426300E-03,2.881100E-03,5.518800E-03,1.384100E-02,2.801200E-02,& + & 3.594500E-02,4.423500E-02,5.160000E-02,6.378300E-02,7.561300E-02,& + & 7.734500E-02,6.067500E-05,1.353700E-04,1.733500E-04,3.910400E-04,& + & 5.206900E-04,1.242600E-03,2.485000E-03,4.878400E-03,1.321300E-02,& + & 2.422700E-02,2.938900E-02,3.529600E-02,4.468000E-02,5.773200E-02,& + & 8.045700E-02,8.427300E-02,1.069100E-04,2.828800E-04,3.088900E-04,& + & 5.071000E-04,5.502200E-04,1.027000E-03,1.747900E-03,4.036900E-03,& + & 1.176000E-02,1.934000E-02,2.314400E-02,3.017200E-02,4.263500E-02,& + & 5.871000E-02,7.889000E-02,8.156100E-02,4.518600E-05,9.754300E-05,& + & 1.410400E-04,1.785500E-04,1.816000E-04,3.876900E-04,1.165200E-03,& + & 3.232900E-03,1.094100E-02,2.381900E-02,2.917600E-02,3.837200E-02,& + & 5.563400E-02,8.030100E-02,1.169400E-01,1.239700E-01,2.770200E-06,& + & 9.024600E-06,3.280500E-05,1.773800E-04,6.537100E-04,1.594100E-03,& + & 4.305000E-03,9.186800E-03,2.132200E-02,5.797800E-02,8.210300E-02,& + & 1.133300E-01,1.454800E-01,1.692700E-01,2.216800E-01,2.410300E-01,& + & 1.026000E-05,3.322900E-05,1.002100E-04,3.505300E-04,8.083700E-04,& + & 1.853900E-03,4.358300E-03,8.828500E-03,1.972700E-02,5.088000E-02,& + & 7.202000E-02,9.926800E-02,1.273300E-01,1.481400E-01,1.940000E-01,& + & 2.109300E-01,1.606700E-05,4.216000E-05,1.371900E-04,3.983900E-04,& + & 8.636900E-04,1.992400E-03,4.391000E-03,8.601100E-03,1.893200E-02,& + & 4.525900E-02,6.193700E-02,8.521400E-02,1.091800E-01,1.270200E-01,& + & 1.663400E-01,1.808500E-01,2.299000E-05,4.947800E-05,1.646900E-04,& + & 4.122900E-04,8.829500E-04,2.020500E-03,4.264400E-03,8.306000E-03,& + & 1.831500E-02,4.268400E-02,5.569400E-02,7.201400E-02,9.102100E-02,& + & 1.058900E-01,1.386500E-01,1.507500E-01,3.080800E-05,6.077900E-05,& + & 1.875500E-04,4.049200E-04,8.723000E-04,1.978200E-03,4.030600E-03,& + & 7.722700E-03,1.804800E-02,3.923300E-02,5.050800E-02,6.358800E-02,& + & 7.662000E-02,8.671000E-02,1.110000E-01,1.206700E-01,4.124400E-05,& + & 8.553300E-05,2.027500E-04,3.898300E-04,8.306700E-04,1.870300E-03,& + & 3.688000E-03,7.081500E-03,1.775700E-02,3.518200E-02,4.451500E-02,& + & 5.432300E-02,6.350000E-02,8.109100E-02,1.000900E-01,1.058300E-01,& + & 5.941100E-05,1.526700E-04,1.971500E-04,4.150000E-04,7.445300E-04,& + & 1.667200E-03,3.252800E-03,6.473800E-03,1.710500E-02,3.064300E-02,& + & 3.655300E-02,4.430600E-02,5.758100E-02,8.136900E-02,1.111300E-01,& + & 1.167000E-01,1.106600E-04,2.390400E-04,2.959000E-04,5.961400E-04,& + & 6.647700E-04,1.306300E-03,2.589200E-03,5.869400E-03,1.537700E-02,& + & 2.581000E-02,3.075700E-02,4.172700E-02,5.752400E-02,8.270600E-02,& + & 1.091300E-01,1.130300E-01,5.262800E-05,8.042200E-05,1.643000E-04,& + & 1.603600E-04,2.904400E-04,5.890600E-04,1.675200E-03,4.459900E-03,& + & 1.489700E-02,3.129500E-02,3.969500E-02,5.129200E-02,7.479300E-02,& + & 1.164900E-01,1.616600E-01,1.719000E-01,3.686300E-06,1.280700E-05,& + & 4.733000E-05,2.368600E-04,7.930900E-04,1.917000E-03,5.173500E-03,& + & 1.099300E-02,2.536400E-02,6.809100E-02,9.563000E-02,1.306500E-01,& + & 1.660000E-01,1.929400E-01,2.528400E-01,2.766400E-01,1.368900E-05,& + & 4.636200E-05,1.374900E-04,4.496500E-04,1.004100E-03,2.289200E-03,& + & 5.297600E-03,1.066100E-02,2.373000E-02,5.977300E-02,8.387800E-02,& + & 1.144800E-01,1.452900E-01,1.688900E-01,2.213000E-01,2.421300E-01/ + data absa(:, 21: 40) / & + & 2.006800E-05,5.907400E-05,1.857500E-04,5.054400E-04,1.080600E-03,& + & 2.487400E-03,5.380300E-03,1.048700E-02,2.305800E-02,5.473500E-02,& + & 7.248100E-02,9.832400E-02,1.246000E-01,1.447900E-01,1.897500E-01,& + & 2.075900E-01,2.813300E-05,6.725300E-05,2.230900E-04,5.187700E-04,& + & 1.113100E-03,2.535200E-03,5.276100E-03,1.017800E-02,2.256900E-02,& + & 5.151700E-02,6.796500E-02,8.535800E-02,1.039200E-01,1.207200E-01,& + & 1.581600E-01,1.730500E-01,3.735900E-05,7.513100E-05,2.525700E-04,& + & 5.060000E-04,1.113500E-03,2.491000E-03,5.013700E-03,9.575000E-03,& + & 2.248300E-02,4.781000E-02,6.068000E-02,7.714100E-02,9.037900E-02,& + & 1.064700E-01,1.277800E-01,1.385200E-01,4.875600E-05,8.988900E-05,& + & 2.770100E-04,4.774000E-04,1.081000E-03,2.378500E-03,4.618300E-03,& + & 8.914300E-03,2.233700E-02,4.296000E-02,5.418000E-02,6.427700E-02,& + & 7.869400E-02,1.062500E-01,1.331900E-01,1.412700E-01,6.566000E-05,& + & 1.249400E-04,3.029300E-04,4.505200E-04,1.006000E-03,2.167800E-03,& + & 4.135300E-03,8.335900E-03,2.164700E-02,3.831000E-02,4.414300E-02,& + & 5.575000E-02,7.438400E-02,1.152100E-01,1.480500E-01,1.558800E-01,& + & 1.075000E-04,2.641800E-04,3.227700E-04,5.723600E-04,8.636300E-04,& + & 1.798200E-03,3.506800E-03,7.901900E-03,1.965900E-02,3.367800E-02,& + & 4.042200E-02,5.541500E-02,7.823200E-02,1.149000E-01,1.455900E-01,& + & 1.510500E-01,6.314700E-05,7.914500E-05,1.583300E-04,1.878700E-04,& + & 4.350700E-04,8.422800E-04,2.249500E-03,5.968200E-03,1.974000E-02,& + & 4.083200E-02,5.196800E-02,6.793300E-02,9.977500E-02,1.662000E-01,& + & 2.162500E-01,2.298000E-01,4.820900E-06,1.778600E-05,6.618400E-05,& + & 3.065000E-04,9.551500E-04,2.274500E-03,6.105700E-03,1.292900E-02,& + & 2.965100E-02,7.844400E-02,1.092800E-01,1.479500E-01,1.863600E-01,& + & 2.163900E-01,2.834300E-01,3.121700E-01,1.818400E-05,6.303100E-05,& + & 1.835800E-04,5.656900E-04,1.233000E-03,2.785700E-03,6.311500E-03,& + & 1.269200E-02,2.809100E-02,6.887000E-02,9.588000E-02,1.296900E-01,& + & 1.631400E-01,1.894000E-01,2.480700E-01,2.732100E-01,2.581100E-05,& + & 8.022500E-05,2.450500E-04,6.316500E-04,1.332000E-03,3.049600E-03,& + & 6.478600E-03,1.258000E-02,2.756700E-02,6.547400E-02,8.438200E-02,& + & 1.114600E-01,1.399400E-01,1.624000E-01,2.127000E-01,2.342600E-01,& + & 3.267000E-05,9.352100E-05,2.911500E-04,6.453000E-04,1.379800E-03,& + & 3.119500E-03,6.403800E-03,1.228500E-02,2.737300E-02,6.076400E-02,& + & 8.046900E-02,1.018500E-01,1.186300E-01,1.354100E-01,1.773100E-01,& + & 1.952900E-01,4.239300E-05,1.030100E-04,3.227500E-04,6.351200E-04,& + & 1.386600E-03,3.078400E-03,6.121000E-03,1.169300E-02,2.754400E-02,& + & 5.686100E-02,7.179800E-02,9.004500E-02,1.066100E-01,1.344700E-01,& + & 1.521300E-01,1.563500E-01,5.750900E-05,1.098700E-04,3.397000E-04,& + & 6.123700E-04,1.359900E-03,2.948700E-03,5.690900E-03,1.103500E-02,& + & 2.757200E-02,5.202000E-02,6.410800E-02,7.517800E-02,9.711000E-02,& + & 1.423900E-01,1.748000E-01,1.828500E-01,7.767200E-05,1.289900E-04,& + & 3.632700E-04,5.665600E-04,1.297800E-03,2.712300E-03,5.127800E-03,& + & 1.054800E-02,2.688500E-02,4.652500E-02,5.360800E-02,6.888500E-02,& + & 9.801200E-02,1.592000E-01,1.931400E-01,2.018700E-01,1.173900E-04,& + & 2.049900E-04,4.703200E-04,5.289100E-04,1.170300E-03,2.372900E-03,& + & 4.561500E-03,1.022500E-02,2.469800E-02,4.301900E-02,5.240900E-02,& + & 7.070000E-02,1.065400E-01,1.580800E-01,1.883000E-01,1.957100E-01,& + & 6.061400E-05,1.083000E-04,1.529600E-04,2.746900E-04,5.482300E-04,& + & 1.159900E-03,2.906300E-03,7.821000E-03,2.550600E-02,5.302500E-02,& + & 6.687000E-02,8.813800E-02,1.326500E-01,2.291900E-01,2.869100E-01,& + & 2.978100E-01,6.201100E-06,2.411600E-05,8.995300E-05,3.851200E-04,& + & 1.137000E-03,2.666400E-03,7.095900E-03,1.499200E-02,3.414700E-02,& + & 8.895500E-02,1.229900E-01,1.649100E-01,2.060600E-01,2.388200E-01,& + & 3.135000E-01,3.470400E-01,2.367900E-05,8.378300E-05,2.384500E-04,& + & 6.975200E-04,1.492200E-03,3.339600E-03,7.404900E-03,1.492400E-02,& + & 3.280100E-02,7.819000E-02,1.079000E-01,1.446100E-01,1.804000E-01,& + & 2.090500E-01,2.743900E-01,3.037400E-01,3.318500E-05,1.064600E-04,& + & 3.156800E-04,7.752500E-04,1.616800E-03,3.679600E-03,7.677800E-03,& + & 1.488800E-02,3.250900E-02,7.622700E-02,9.888800E-02,1.247200E-01,& + & 1.547600E-01,1.792900E-01,2.352700E-01,2.604400E-01,4.109800E-05,& + & 1.243100E-04,3.702100E-04,7.924500E-04,1.680900E-03,3.774200E-03,& + & 7.647000E-03,1.465900E-02,3.269600E-02,7.087700E-02,9.280800E-02,& + & 1.176100E-01,1.366900E-01,1.567300E-01,1.962200E-01,2.171200E-01/ + data absa(:, 41: 60) / & + & 4.887200E-05,1.394400E-04,4.011100E-04,7.888300E-04,1.696900E-03,& + & 3.733900E-03,7.370600E-03,1.406800E-02,3.324200E-02,6.677100E-02,& + & 8.400900E-02,1.026800E-01,1.240500E-01,1.673000E-01,1.959400E-01,& + & 2.070400E-01,6.019900E-05,1.527700E-04,4.125000E-04,7.708500E-04,& + & 1.674100E-03,3.573500E-03,6.896500E-03,1.347400E-02,3.346600E-02,& + & 6.221400E-02,7.506900E-02,8.780200E-02,1.187300E-01,1.885300E-01,& + & 2.313500E-01,2.417900E-01,8.683000E-05,1.588100E-04,4.171200E-04,& + & 7.406000E-04,1.614200E-03,3.312400E-03,6.241800E-03,1.310700E-02,& + & 3.276300E-02,5.568000E-02,6.600400E-02,8.505700E-02,1.286900E-01,& + & 2.122700E-01,2.530700E-01,2.624900E-01,1.332000E-04,2.093300E-04,& + & 4.901300E-04,6.771900E-04,1.530600E-03,2.954000E-03,5.751100E-03,& + & 1.286700E-02,3.053000E-02,5.485700E-02,6.690000E-02,9.020800E-02,& + & 1.407000E-01,2.124900E-01,2.415600E-01,2.468800E-01,5.795900E-05,& + & 1.434400E-04,1.711600E-04,3.628200E-04,7.123300E-04,1.504900E-03,& + & 3.672000E-03,1.002000E-02,3.241400E-02,6.696500E-02,8.445500E-02,& + & 1.128400E-01,1.752900E-01,3.035900E-01,3.808200E-01,4.074400E-01,& + & 2.353800E-06,7.142100E-06,2.648000E-05,1.539000E-04,6.453000E-04,& + & 1.610500E-03,4.452200E-03,1.020700E-02,2.491200E-02,6.849400E-02,& + & 1.003100E-01,1.431600E-01,1.889500E-01,2.293900E-01,3.211100E-01,& + & 3.577500E-01,6.735900E-06,2.213200E-05,6.779500E-05,2.749400E-04,& + & 7.267300E-04,1.711200E-03,4.282700E-03,9.479700E-03,2.233100E-02,& + & 6.001900E-02,8.785700E-02,1.253400E-01,1.653500E-01,2.007300E-01,& + & 2.810200E-01,3.130200E-01,1.028000E-05,2.759000E-05,8.827300E-05,& + & 3.126100E-04,7.334800E-04,1.744000E-03,4.171200E-03,8.808500E-03,& + & 2.028800E-02,5.153500E-02,7.540700E-02,1.075200E-01,1.417500E-01,& + & 1.720600E-01,2.409000E-01,2.683200E-01,1.433100E-05,3.337600E-05,& + & 1.023900E-04,3.202300E-04,7.146300E-04,1.710400E-03,3.905800E-03,& + & 8.230900E-03,1.844600E-02,4.575300E-02,6.306000E-02,8.970100E-02,& + & 1.181400E-01,1.433900E-01,2.007900E-01,2.236300E-01,1.930400E-05,& + & 4.348200E-05,1.108700E-04,3.115100E-04,6.756400E-04,1.615900E-03,& + & 3.573000E-03,7.434800E-03,1.684000E-02,4.071700E-02,5.449900E-02,& + & 7.257700E-02,9.455100E-02,1.147500E-01,1.606900E-01,1.789400E-01,& + & 2.596300E-05,6.612800E-05,1.125200E-04,2.954700E-04,6.111000E-04,& + & 1.465000E-03,3.158100E-03,6.467900E-03,1.543700E-02,3.463600E-02,& + & 4.650400E-02,5.960800E-02,7.380900E-02,8.695100E-02,1.205400E-01,& + & 1.342300E-01,4.084200E-05,9.252100E-05,1.262600E-04,3.149700E-04,& + & 5.012300E-04,1.234700E-03,2.643400E-03,5.328200E-03,1.405000E-02,& + & 2.873500E-02,3.677000E-02,4.662800E-02,5.561500E-02,7.218400E-02,& + & 9.003400E-02,9.419900E-02,7.029700E-05,1.816600E-04,1.776500E-04,& + & 3.903900E-04,4.422200E-04,8.837100E-04,1.918200E-03,4.005600E-03,& + & 1.210500E-02,2.235900E-02,2.638000E-02,3.223300E-02,4.463700E-02,& + & 6.315500E-02,8.983100E-02,9.515200E-02,3.078600E-05,6.311900E-05,& + & 1.023500E-04,1.098900E-04,1.396200E-04,2.833500E-04,8.648500E-04,& + & 2.522900E-03,9.297900E-03,2.239600E-02,2.841300E-02,3.692200E-02,& + & 5.303000E-02,8.046300E-02,1.224300E-01,1.334700E-01,3.180000E-06,& + & 1.048000E-05,4.022900E-05,2.171400E-04,8.095700E-04,1.995300E-03,& + & 5.518300E-03,1.255800E-02,3.056400E-02,8.305700E-02,1.205300E-01,& + & 1.702300E-01,2.225000E-01,2.693100E-01,3.763600E-01,4.227200E-01,& + & 9.277600E-06,3.227300E-05,9.811500E-05,3.745300E-04,9.260700E-04,& + & 2.157500E-03,5.355100E-03,1.174800E-02,2.751500E-02,7.278600E-02,& + & 1.055900E-01,1.490700E-01,1.947000E-01,2.356900E-01,3.292600E-01,& + & 3.699300E-01,1.340100E-05,3.980400E-05,1.263900E-04,4.163800E-04,& + & 9.441400E-04,2.229300E-03,5.239300E-03,1.100200E-02,2.526100E-02,& + & 6.270300E-02,9.062700E-02,1.279000E-01,1.669200E-01,2.020000E-01,& + & 2.822600E-01,3.171000E-01,1.801400E-05,4.448400E-05,1.469300E-04,& + & 4.241300E-04,9.248000E-04,2.198100E-03,4.943600E-03,1.033800E-02,& + & 2.321900E-02,5.635300E-02,7.682900E-02,1.067400E-01,1.391400E-01,& + & 1.684000E-01,2.353400E-01,2.643100E-01,2.350100E-05,4.976600E-05,& + & 1.617100E-04,4.100700E-04,8.843300E-04,2.089300E-03,4.552900E-03,& + & 9.399700E-03,2.140000E-02,5.099000E-02,6.703300E-02,8.873800E-02,& + & 1.113600E-01,1.347500E-01,1.883100E-01,2.114600E-01,3.046800E-05,& + & 6.222400E-05,1.714900E-04,3.785700E-04,8.149700E-04,1.913100E-03,& + & 4.046900E-03,8.264800E-03,1.982800E-02,4.373300E-02,5.810400E-02,& + & 7.325000E-02,8.826200E-02,1.088000E-01,1.412600E-01,1.586600E-01/ + data absa(:, 61: 80) / & + & 4.103000E-05,1.018100E-04,1.607800E-04,3.535400E-04,7.069700E-04,& + & 1.664900E-03,3.430900E-03,6.931700E-03,1.828200E-02,3.630900E-02,& + & 4.650900E-02,5.735300E-02,7.002200E-02,9.272900E-02,1.228100E-01,& + & 1.326800E-01,7.275800E-05,1.606200E-04,2.029600E-04,4.240100E-04,& + & 5.241400E-04,1.281700E-03,2.647900E-03,5.557000E-03,1.593800E-02,& + & 2.866000E-02,3.363800E-02,4.325400E-02,6.036300E-02,8.672000E-02,& + & 1.262000E-01,1.341200E-01,3.680700E-05,5.511200E-05,1.051300E-04,& + & 1.176300E-04,2.188900E-04,4.374000E-04,1.237000E-03,3.502900E-03,& + & 1.284700E-02,2.986300E-02,3.831000E-02,4.965900E-02,7.347200E-02,& + & 1.135100E-01,1.718700E-01,1.882300E-01,4.264400E-06,1.506900E-05,& + & 5.901900E-05,2.935200E-04,9.955800E-04,2.428400E-03,6.685800E-03,& + & 1.516700E-02,3.671600E-02,9.844500E-02,1.415500E-01,1.979200E-01,& + & 2.556700E-01,3.095800E-01,4.327500E-01,4.891100E-01,1.258900E-05,& + & 4.580500E-05,1.375100E-04,4.893800E-04,1.159600E-03,2.672800E-03,& + & 6.555500E-03,1.427700E-02,3.325000E-02,8.626800E-02,1.239800E-01,& + & 1.733200E-01,2.237600E-01,2.710000E-01,3.786000E-01,4.279800E-01,& + & 1.741400E-05,5.645400E-05,1.746800E-04,5.378400E-04,1.189200E-03,& + & 2.796000E-03,6.435100E-03,1.350900E-02,3.081300E-02,7.517200E-02,& + & 1.064400E-01,1.487500E-01,1.918500E-01,2.323600E-01,3.246300E-01,& + & 3.668700E-01,2.236500E-05,6.273000E-05,2.016600E-04,5.443100E-04,& + & 1.173100E-03,2.764200E-03,6.135300E-03,1.272700E-02,2.857600E-02,& + & 6.910100E-02,9.224800E-02,1.241800E-01,1.599100E-01,1.937000E-01,& + & 2.705500E-01,3.057700E-01,2.892400E-05,6.626200E-05,2.222300E-04,& + & 5.225700E-04,1.129500E-03,2.639400E-03,5.684900E-03,1.165300E-02,& + & 2.665200E-02,6.186100E-02,8.198300E-02,1.065100E-01,1.300500E-01,& + & 1.550600E-01,2.165000E-01,2.446600E-01,3.699600E-05,7.165500E-05,& + & 2.373000E-04,4.774900E-04,1.055000E-03,2.436100E-03,5.073700E-03,& + & 1.035200E-02,2.496900E-02,5.360800E-02,7.044100E-02,8.860100E-02,& + & 1.059900E-01,1.354700E-01,1.670600E-01,1.836000E-01,4.745900E-05,& + & 8.855400E-05,2.464700E-04,4.235500E-04,9.377600E-04,2.152200E-03,& + & 4.336500E-03,8.820500E-03,2.324200E-02,4.546200E-02,5.659000E-02,& + & 6.903800E-02,8.765500E-02,1.235500E-01,1.657800E-01,1.797800E-01,& + & 7.145800E-05,1.760800E-04,2.356900E-04,4.221100E-04,7.636600E-04,& + & 1.693000E-03,3.445700E-03,7.403700E-03,2.043400E-02,3.562800E-02,& + & 4.382100E-02,5.557400E-02,7.972600E-02,1.239400E-01,1.706000E-01,& + & 1.818500E-01,4.445300E-05,5.483300E-05,1.063900E-04,1.415700E-04,& + & 3.177900E-04,6.349900E-04,1.666300E-03,4.714000E-03,1.725500E-02,& + & 3.958400E-02,5.013000E-02,6.606200E-02,9.699400E-02,1.633000E-01,& + & 2.338400E-01,2.552900E-01,5.633400E-06,2.115800E-05,8.374100E-05,& + & 3.834800E-04,1.209300E-03,2.910700E-03,7.956600E-03,1.798600E-02,& + & 4.327400E-02,1.146500E-01,1.630500E-01,2.256700E-01,2.874700E-01,& + & 3.507300E-01,4.895200E-01,5.555900E-01,1.684300E-05,6.320500E-05,& + & 1.868200E-04,6.221400E-04,1.433600E-03,3.265700E-03,7.860600E-03,& + & 1.707300E-02,3.947000E-02,1.004700E-01,1.428200E-01,1.976800E-01,& + & 2.515700E-01,3.069400E-01,4.282400E-01,4.862300E-01,2.293700E-05,& + & 7.753400E-05,2.341900E-04,6.800300E-04,1.475100E-03,3.437900E-03,& + & 7.769700E-03,1.628700E-02,3.694500E-02,8.932200E-02,1.226200E-01,& + & 1.697100E-01,2.156900E-01,2.631900E-01,3.672500E-01,4.167900E-01,& + & 2.808300E-05,8.666900E-05,2.691000E-04,6.842100E-04,1.463100E-03,& + & 3.408400E-03,7.470200E-03,1.541700E-02,3.454600E-02,8.239900E-02,& + & 1.104900E-01,1.427800E-01,1.798000E-01,2.194300E-01,3.059700E-01,& + & 3.473500E-01,3.360900E-05,9.274300E-05,2.930900E-04,6.559000E-04,& + & 1.414900E-03,3.263800E-03,6.963400E-03,1.423400E-02,3.256700E-02,& + & 7.384700E-02,9.706200E-02,1.269600E-01,1.508300E-01,1.792800E-01,& + & 2.448800E-01,2.779600E-01,4.364200E-05,9.371000E-05,3.062900E-04,& + & 6.060500E-04,1.328100E-03,3.033600E-03,6.257100E-03,1.272200E-02,& + & 3.090200E-02,6.445900E-02,8.384800E-02,1.036600E-01,1.269900E-01,& + & 1.712600E-01,2.030000E-01,2.093200E-01,5.679400E-05,9.836800E-05,& + & 3.125600E-04,5.346700E-04,1.203900E-03,2.691900E-03,5.384900E-03,& + & 1.102900E-02,2.899000E-02,5.572900E-02,6.797500E-02,8.194800E-02,& + & 1.091700E-01,1.664300E-01,2.201200E-01,2.357000E-01,7.954000E-05,& + & 1.417500E-04,3.451600E-04,4.506400E-04,1.026400E-03,2.192000E-03,& + & 4.337500E-03,9.545000E-03,2.560800E-02,4.525900E-02,5.552900E-02,& + & 7.119100E-02,1.049300E-01,1.736000E-01,2.239600E-01,2.385300E-01/ + data absa(:, 81:100) / & + & 3.776900E-05,8.398900E-05,1.058400E-04,2.061200E-04,4.074300E-04,& + & 8.667700E-04,2.173900E-03,6.194100E-03,2.262200E-02,5.101100E-02,& + & 6.537800E-02,8.612700E-02,1.270300E-01,2.278300E-01,3.137500E-01,& + & 3.349300E-01,7.316500E-06,2.901800E-05,1.153400E-04,4.870400E-04,& + & 1.454800E-03,3.445700E-03,9.310700E-03,2.101600E-02,5.015100E-02,& + & 1.312100E-01,1.850700E-01,2.531400E-01,3.178100E-01,3.913400E-01,& + & 5.458100E-01,6.213000E-01,2.220800E-05,8.501400E-05,2.468200E-04,& + & 7.761800E-04,1.750100E-03,3.931500E-03,9.274900E-03,2.010400E-02,& + & 4.615400E-02,1.149900E-01,1.621200E-01,2.217500E-01,2.781700E-01,& + & 3.424800E-01,4.774800E-01,5.437400E-01,2.998700E-05,1.038700E-04,& + & 3.059800E-04,8.454000E-04,1.804100E-03,4.160200E-03,9.250600E-03,& + & 1.931700E-02,4.354800E-02,1.054700E-01,1.396200E-01,1.903200E-01,& + & 2.385700E-01,2.936800E-01,4.094300E-01,4.660900E-01,3.583400E-05,& + & 1.163800E-04,3.490300E-04,8.478400E-04,1.797700E-03,4.131100E-03,& + & 8.945900E-03,1.841500E-02,4.114700E-02,9.594200E-02,1.293500E-01,& + & 1.656500E-01,1.989800E-01,2.449600E-01,3.411900E-01,3.884500E-01,& + & 4.111700E-05,1.253500E-04,3.755900E-04,8.148400E-04,1.741600E-03,& + & 3.967400E-03,8.389600E-03,1.712500E-02,3.920800E-02,8.670000E-02,& + & 1.128100E-01,1.460600E-01,1.741100E-01,2.159300E-01,2.731200E-01,& + & 3.109000E-01,4.723600E-05,1.316000E-04,3.816900E-04,7.624500E-04,& + & 1.642400E-03,3.698200E-03,7.584000E-03,1.539700E-02,3.761700E-02,& + & 7.691200E-02,9.772600E-02,1.197000E-01,1.501600E-01,2.136700E-01,& + & 2.600500E-01,2.699800E-01,6.450700E-05,1.295200E-04,3.722100E-04,& + & 6.889400E-04,1.503700E-03,3.290500E-03,6.560500E-03,1.357300E-02,& + & 3.547600E-02,6.768300E-02,8.011700E-02,9.816500E-02,1.345400E-01,& + & 2.225300E-01,2.916600E-01,3.023000E-01,9.178400E-05,1.471500E-04,& + & 3.836500E-04,5.845300E-04,1.324400E-03,2.741600E-03,5.340800E-03,& + & 1.202900E-02,3.150600E-02,5.708700E-02,6.995400E-02,9.052600E-02,& + & 1.370700E-01,2.353700E-01,2.921200E-01,3.041200E-01,4.035600E-05,& + & 1.016800E-04,1.278600E-04,2.719000E-04,5.315500E-04,1.127700E-03,& + & 2.774700E-03,7.967400E-03,2.907000E-02,6.433100E-02,8.337100E-02,& + & 1.106100E-01,1.665600E-01,3.054400E-01,4.186600E-01,4.478700E-01,& + & 3.414900E-06,1.013400E-05,3.857400E-05,2.307100E-04,1.007300E-03,& + & 2.536200E-03,7.166300E-03,1.749500E-02,4.582400E-02,1.239600E-01,& + & 1.866700E-01,2.738500E-01,3.697800E-01,4.701000E-01,6.997900E-01,& + & 8.075900E-01,6.842600E-06,2.369800E-05,7.515700E-05,3.349900E-04,& + & 1.030500E-03,2.473400E-03,6.538500E-03,1.579300E-02,4.042800E-02,& + & 1.085100E-01,1.633800E-01,2.397100E-01,3.235700E-01,4.113500E-01,& + & 6.121300E-01,7.065500E-01,8.916100E-06,2.809800E-05,8.938200E-05,& + & 3.684500E-04,9.917000E-04,2.374000E-03,6.083200E-03,1.403900E-02,& + & 3.536000E-02,9.307800E-02,1.401000E-01,2.055200E-01,2.773700E-01,& + & 3.526100E-01,5.248300E-01,6.056400E-01,1.129200E-05,3.083200E-05,& + & 9.825400E-05,3.727000E-04,9.168500E-04,2.229900E-03,5.517600E-03,& + & 1.246500E-02,3.053100E-02,7.793600E-02,1.168200E-01,1.713600E-01,& + & 2.311600E-01,2.938700E-01,4.371900E-01,5.047300E-01,1.398700E-05,& + & 3.455900E-05,1.023300E-04,3.554700E-04,8.233400E-04,2.029800E-03,& + & 4.842200E-03,1.090700E-02,2.587300E-02,6.543000E-02,9.355700E-02,& + & 1.371600E-01,1.849400E-01,2.351200E-01,3.498400E-01,4.038200E-01,& + & 1.768900E-05,4.273900E-05,1.006300E-04,3.220300E-04,7.127900E-04,& + & 1.766100E-03,4.101200E-03,9.107200E-03,2.151500E-02,5.355500E-02,& + & 7.432500E-02,1.030000E-01,1.387200E-01,1.763800E-01,2.624300E-01,& + & 3.029100E-01,2.462300E-05,5.841300E-05,1.005600E-04,2.765600E-04,& + & 5.736500E-04,1.431600E-03,3.255700E-03,7.105800E-03,1.743700E-02,& + & 4.014900E-02,5.598400E-02,7.517800E-02,9.443200E-02,1.176400E-01,& + & 1.750100E-01,2.019500E-01,4.056000E-05,1.008600E-04,1.087000E-04,& + & 2.650600E-04,3.941200E-04,9.776500E-04,2.224400E-03,4.834300E-03,& + & 1.318200E-02,2.816500E-02,3.587800E-02,4.569100E-02,5.746500E-02,& + & 7.861600E-02,9.967600E-02,1.045700E-01,1.874100E-05,3.254600E-05,& + & 6.844600E-05,6.277900E-05,1.002500E-04,1.971800E-04,5.981500E-04,& + & 1.783200E-03,7.213500E-03,1.910300E-02,2.553100E-02,3.353300E-02,& + & 4.702600E-02,7.624100E-02,1.168800E-01,1.324000E-01,4.629500E-06,& + & 1.506700E-05,6.014200E-05,3.336800E-04,1.288000E-03,3.197900E-03,& + & 9.011800E-03,2.189300E-02,5.712200E-02,1.530800E-01,2.279500E-01,& + & 3.309000E-01,4.390300E-01,5.624700E-01,8.338700E-01,9.683300E-01/ + data absa(:,101:120) / & + & 9.591000E-06,3.547800E-05,1.126400E-04,4.730200E-04,1.331600E-03,& + & 3.144800E-03,8.269400E-03,1.984100E-02,5.044100E-02,1.340100E-01,& + & 1.995400E-01,2.896100E-01,3.841500E-01,4.922100E-01,7.295900E-01,& + & 8.473700E-01,1.221800E-05,4.178200E-05,1.324400E-04,5.113100E-04,& + & 1.286700E-03,3.050200E-03,7.730100E-03,1.770900E-02,4.429600E-02,& + & 1.149500E-01,1.711300E-01,2.483600E-01,3.292900E-01,4.219500E-01,& + & 6.254500E-01,7.263600E-01,1.477300E-05,4.492700E-05,1.450400E-04,& + & 5.092300E-04,1.196700E-03,2.889300E-03,7.032800E-03,1.580100E-02,& + & 3.853500E-02,9.631700E-02,1.427000E-01,2.070700E-01,2.744500E-01,& + & 3.516500E-01,5.211200E-01,6.052700E-01,1.790600E-05,4.630400E-05,& + & 1.524200E-04,4.810100E-04,1.080900E-03,2.641200E-03,6.205300E-03,& + & 1.389400E-02,3.288700E-02,8.206100E-02,1.148000E-01,1.658100E-01,& + & 2.195600E-01,2.813600E-01,4.169400E-01,4.842100E-01,2.162700E-05,& + & 4.933800E-05,1.525900E-04,4.342000E-04,9.444300E-04,2.312000E-03,& + & 5.286900E-03,1.166200E-02,2.762600E-02,6.772000E-02,9.250900E-02,& + & 1.259700E-01,1.647000E-01,2.111100E-01,3.127800E-01,3.632100E-01,& + & 2.717500E-05,6.095200E-05,1.480600E-04,3.619200E-04,7.817900E-04,& + & 1.893400E-03,4.223500E-03,9.203800E-03,2.263700E-02,5.156300E-02,& + & 7.062300E-02,9.254200E-02,1.148200E-01,1.448000E-01,2.086200E-01,& + & 2.422000E-01,4.190200E-05,9.712600E-05,1.373000E-04,3.196300E-04,& + & 5.370000E-04,1.356600E-03,2.965200E-03,6.381700E-03,1.747000E-02,& + & 3.634600E-02,4.617800E-02,5.716800E-02,7.439400E-02,1.003900E-01,& + & 1.366000E-01,1.513800E-01,2.333800E-05,3.227100E-05,6.434700E-05,& + & 7.802200E-05,1.538400E-04,3.094300E-04,8.532200E-04,2.512800E-03,& + & 1.015600E-02,2.614700E-02,3.491700E-02,4.564700E-02,6.613800E-02,& + & 1.052300E-01,1.682700E-01,1.918400E-01,6.262000E-06,2.202000E-05,& + & 9.038100E-05,4.616700E-04,1.610700E-03,3.956400E-03,1.107300E-02,& + & 2.679000E-02,6.951400E-02,1.843800E-01,2.721100E-01,3.896000E-01,& + & 5.085500E-01,6.574900E-01,9.726600E-01,1.134200E+00,1.326500E-05,& + & 5.152600E-05,1.624700E-04,6.381700E-04,1.690300E-03,3.924500E-03,& + & 1.021500E-02,2.437200E-02,6.148400E-02,1.614300E-01,2.381600E-01,& + & 3.409800E-01,4.450600E-01,5.753700E-01,8.509800E-01,9.924500E-01,& + & 1.674000E-05,6.041500E-05,1.892600E-04,6.786300E-04,1.639000E-03,& + & 3.846400E-03,9.583200E-03,2.187100E-02,5.426700E-02,1.384600E-01,& + & 2.042300E-01,2.923900E-01,3.815400E-01,4.931900E-01,7.295800E-01,& + & 8.507200E-01,1.951700E-05,6.478500E-05,2.053800E-04,6.714800E-04,& + & 1.530000E-03,3.662500E-03,8.749800E-03,1.963500E-02,4.752000E-02,& + & 1.168500E-01,1.703200E-01,2.437900E-01,3.180500E-01,4.110500E-01,& + & 6.080200E-01,7.090300E-01,2.285100E-05,6.581500E-05,2.140700E-04,& + & 6.320200E-04,1.388600E-03,3.354200E-03,7.784400E-03,1.731100E-02,& + & 4.089300E-02,1.006500E-01,1.386600E-01,1.951700E-01,2.545100E-01,& + & 3.289500E-01,4.865500E-01,5.672700E-01,2.679100E-05,6.497000E-05,& + & 2.160900E-04,5.661000E-04,1.224200E-03,2.945200E-03,6.673300E-03,& + & 1.462400E-02,3.464700E-02,8.357300E-02,1.133800E-01,1.518100E-01,& + & 1.910200E-01,2.468400E-01,3.649200E-01,4.254800E-01,3.231100E-05,& + & 6.640100E-05,2.111300E-04,4.720800E-04,1.023500E-03,2.436200E-03,& + & 5.358800E-03,1.165800E-02,2.873100E-02,6.416900E-02,8.687700E-02,& + & 1.130800E-01,1.367000E-01,1.788900E-01,2.433500E-01,2.837300E-01,& + & 4.309200E-05,9.857700E-05,1.933200E-04,3.584100E-04,7.542500E-04,& + & 1.802500E-03,3.810400E-03,8.210900E-03,2.257600E-02,4.627300E-02,& + & 5.719100E-02,7.021200E-02,9.482500E-02,1.315700E-01,1.879000E-01,& + & 2.099300E-01,2.730300E-05,3.737700E-05,6.773900E-05,1.003200E-04,& + & 2.164000E-04,4.510500E-04,1.159700E-03,3.434800E-03,1.387800E-02,& + & 3.524900E-02,4.605400E-02,6.161000E-02,8.940600E-02,1.475200E-01,& + & 2.345000E-01,2.662100E-01,8.382500E-06,3.140200E-05,1.310600E-04,& + & 6.142100E-04,1.979700E-03,4.809900E-03,1.333600E-02,3.214200E-02,& + & 8.291900E-02,2.173000E-01,3.177000E-01,4.488800E-01,5.781700E-01,& + & 7.529200E-01,1.113400E+00,1.302400E+00,1.802500E-05,7.260600E-05,& + & 2.271200E-04,8.272800E-04,2.110700E-03,4.814200E-03,1.237300E-02,& + & 2.935800E-02,7.351200E-02,1.902400E-01,2.780900E-01,3.928500E-01,& + & 5.059900E-01,6.589500E-01,9.742100E-01,1.139500E+00,2.263300E-05,& + & 8.475000E-05,2.618000E-04,8.709200E-04,2.052900E-03,4.766900E-03,& + & 1.164200E-02,2.649000E-02,6.527300E-02,1.631700E-01,2.384900E-01,& + & 3.368600E-01,4.338100E-01,5.647600E-01,8.353000E-01,9.768500E-01/ + data absa(:,121:140) / & + & 2.598800E-05,9.068000E-05,2.809900E-04,8.601200E-04,1.920900E-03,& + & 4.549900E-03,1.069600E-02,2.392100E-02,5.752400E-02,1.393700E-01,& + & 1.988700E-01,2.808500E-01,3.616600E-01,4.708100E-01,6.960600E-01,& + & 8.140900E-01,2.875600E-05,9.287900E-05,2.909200E-04,8.066600E-04,& + & 1.752700E-03,4.170500E-03,9.580700E-03,2.118200E-02,4.978300E-02,& + & 1.218200E-01,1.654800E-01,2.248700E-01,2.894800E-01,3.767800E-01,& + & 5.569700E-01,6.512600E-01,3.240200E-05,9.112700E-05,2.929200E-04,& + & 7.181800E-04,1.554100E-03,3.672300E-03,8.248200E-03,1.802600E-02,& + & 4.260300E-02,1.007600E-01,1.361400E-01,1.807400E-01,2.204200E-01,& + & 2.827200E-01,4.177900E-01,4.885500E-01,3.908400E-05,8.566600E-05,& + & 2.837500E-04,5.993700E-04,1.309400E-03,3.058600E-03,6.672600E-03,& + & 1.448700E-02,3.578400E-02,7.780200E-02,1.046400E-01,1.336700E-01,& + & 1.642000E-01,2.220600E-01,2.825100E-01,3.257500E-01,5.018200E-05,& + & 9.237200E-05,2.709200E-04,4.381100E-04,9.928800E-04,2.294400E-03,& + & 4.789100E-03,1.037300E-02,2.856300E-02,5.745800E-02,7.003900E-02,& + & 8.479500E-02,1.182700E-01,1.775600E-01,2.537800E-01,2.807200E-01,& + & 2.311900E-05,5.988100E-05,6.886600E-05,1.446600E-04,2.880300E-04,& + & 6.121900E-04,1.531700E-03,4.564600E-03,1.850200E-02,4.610600E-02,& + & 6.021700E-02,8.080300E-02,1.173000E-01,2.076900E-01,3.201100E-01,& + & 3.560500E-01,1.103000E-05,4.379800E-05,1.840300E-04,7.931800E-04,& + & 2.411300E-03,5.769200E-03,1.576600E-02,3.793300E-02,9.717000E-02,& + & 2.511400E-01,3.640300E-01,5.077700E-01,6.471500E-01,8.472100E-01,& + & 1.254100E+00,1.469800E+00,2.418400E-05,9.937500E-05,3.088400E-04,& + & 1.049900E-03,2.602100E-03,5.828600E-03,1.472700E-02,3.474900E-02,& + & 8.643100E-02,2.198900E-01,3.186300E-01,4.444400E-01,5.663800E-01,& + & 7.414700E-01,1.097400E+00,1.286000E+00,3.021800E-05,1.157700E-04,& + & 3.510000E-04,1.100100E-03,2.536600E-03,5.807500E-03,1.391700E-02,& + & 3.154100E-02,7.726100E-02,1.886200E-01,2.732800E-01,3.810400E-01,& + & 4.856600E-01,6.357000E-01,9.408400E-01,1.102400E+00,3.442800E-05,& + & 1.236100E-04,3.738000E-04,1.082500E-03,2.381500E-03,5.546800E-03,& + & 1.287600E-02,2.862800E-02,6.834600E-02,1.655800E-01,2.279500E-01,& + & 3.177300E-01,4.049400E-01,5.298900E-01,7.839600E-01,9.188000E-01,& + & 3.737900E-05,1.264500E-04,3.851000E-04,1.011100E-03,2.182200E-03,& + & 5.093000E-03,1.158500E-02,2.550100E-02,5.958400E-02,1.433000E-01,& + & 1.964100E-01,2.563100E-01,3.241900E-01,4.240200E-01,6.273800E-01,& + & 7.350500E-01,3.966700E-05,1.254300E-04,3.836200E-04,9.015700E-04,& + & 1.938500E-03,4.496600E-03,1.001600E-02,2.186400E-02,5.151400E-02,& + & 1.193600E-01,1.590800E-01,2.114600E-01,2.544600E-01,3.241400E-01,& + & 4.706100E-01,5.513200E-01,4.397500E-05,1.195400E-04,3.628900E-04,& + & 7.596400E-04,1.637500E-03,3.764400E-03,8.153500E-03,1.770900E-02,& + & 4.376800E-02,9.359400E-02,1.231200E-01,1.550200E-01,1.936700E-01,& + & 2.783100E-01,3.381200E-01,3.676700E-01,5.839100E-05,1.079900E-04,& + & 3.230000E-04,5.751200E-04,1.268900E-03,2.840800E-03,5.898200E-03,& + & 1.288300E-02,3.537900E-02,7.043800E-02,8.352900E-02,1.044900E-01,& + & 1.461200E-01,2.378400E-01,3.380500E-01,3.638200E-01,2.620600E-05,& + & 6.621600E-05,9.275800E-05,1.943200E-04,3.764100E-04,8.033100E-04,& + & 1.978500E-03,5.913100E-03,2.414100E-02,5.904800E-02,7.757200E-02,& + & 1.041000E-01,1.521900E-01,2.840600E-01,4.334100E-01,4.625600E-01,& + & 5.017100E-06,1.439500E-05,5.470500E-05,3.420000E-04,1.585100E-03,& + & 3.983200E-03,1.144300E-02,2.955000E-02,8.502800E-02,2.230700E-01,& + & 3.458800E-01,5.223300E-01,7.185700E-01,9.717100E-01,1.533800E+00,& + & 1.835400E+00,7.688000E-06,2.611300E-05,8.607200E-05,4.199000E-04,& + & 1.518100E-03,3.674100E-03,1.019400E-02,2.622700E-02,7.467500E-02,& + & 1.952000E-01,3.026800E-01,4.570800E-01,6.287700E-01,8.502000E-01,& + & 1.342200E+00,1.605900E+00,8.779100E-06,2.924200E-05,9.620900E-05,& + & 4.425900E-04,1.403200E-03,3.386500E-03,9.084700E-03,2.291000E-02,& + & 6.440800E-02,1.673700E-01,2.594800E-01,3.918200E-01,5.389400E-01,& + & 7.287700E-01,1.150300E+00,1.376600E+00,9.812100E-06,3.050100E-05,& + & 1.003400E-04,4.366100E-04,1.260600E-03,3.040300E-03,8.022900E-03,& + & 1.960400E-02,5.434900E-02,1.396000E-01,2.162900E-01,3.265400E-01,& + & 4.491900E-01,6.073400E-01,9.587000E-01,1.147100E+00,1.121200E-05,& + & 3.082500E-05,9.995300E-05,4.116300E-04,1.088300E-03,2.668400E-03,& + & 6.844300E-03,1.646900E-02,4.438500E-02,1.128100E-01,1.730700E-01,& + & 2.613100E-01,3.593500E-01,4.859000E-01,7.668600E-01,9.177000E-01/ + data absa(:,141:160) / & + & 1.283800E-05,3.233500E-05,9.518900E-05,3.676000E-04,8.973900E-04,& + & 2.242900E-03,5.570200E-03,1.333900E-02,3.466700E-02,8.766200E-02,& + & 1.299000E-01,1.960400E-01,2.695700E-01,3.644500E-01,5.752700E-01,& + & 6.882500E-01,1.606600E-05,3.982400E-05,8.316100E-05,3.037100E-04,& + & 6.856000E-04,1.741900E-03,4.218300E-03,9.941500E-03,2.529800E-02,& + & 6.335500E-02,9.121700E-02,1.307900E-01,1.797600E-01,2.430100E-01,& + & 3.835100E-01,4.588700E-01,2.437700E-05,5.577000E-05,7.920700E-05,& + & 2.314900E-04,4.285400E-04,1.129100E-03,2.681300E-03,6.226200E-03,& + & 1.634700E-02,3.744000E-02,5.313500E-02,7.464000E-02,9.399800E-02,& + & 1.221300E-01,1.918000E-01,2.294800E-01,1.168900E-05,1.898700E-05,& + & 3.942300E-05,4.630700E-05,6.639100E-05,1.301500E-04,4.003000E-04,& + & 1.213500E-03,5.372300E-03,1.514300E-02,2.176700E-02,2.949800E-02,& + & 4.118700E-02,6.972400E-02,1.072300E-01,1.251200E-01,6.794600E-06,& + & 2.144800E-05,8.775100E-05,5.092000E-04,2.050100E-03,5.117100E-03,& + & 1.465900E-02,3.768700E-02,1.079900E-01,2.812100E-01,4.314500E-01,& + & 6.421700E-01,8.683500E-01,1.181900E+00,1.863100E+00,2.239100E+00,& + & 1.078900E-05,3.963900E-05,1.334700E-04,6.153900E-04,1.975400E-03,& + & 4.740800E-03,1.309500E-02,3.352800E-02,9.483200E-02,2.461000E-01,& + & 3.775500E-01,5.620000E-01,7.598600E-01,1.034200E+00,1.630200E+00,& + & 1.959300E+00,1.229700E-05,4.456000E-05,1.476900E-04,6.372100E-04,& + & 1.838700E-03,4.391900E-03,1.171400E-02,2.934300E-02,8.188700E-02,& + & 2.110100E-01,3.236600E-01,4.817400E-01,6.513100E-01,8.864700E-01,& + & 1.397400E+00,1.679600E+00,1.345400E-05,4.639100E-05,1.527100E-04,& + & 6.199400E-04,1.656500E-03,3.971800E-03,1.037500E-02,2.518600E-02,& + & 6.926500E-02,1.760100E-01,2.697700E-01,4.015100E-01,5.428300E-01,& + & 7.386300E-01,1.164400E+00,1.399800E+00,1.473800E-05,4.597000E-05,& + & 1.523000E-04,5.760300E-04,1.438600E-03,3.506900E-03,8.866400E-03,& + & 2.124900E-02,5.684900E-02,1.421900E-01,2.158900E-01,3.213100E-01,& + & 4.343500E-01,5.910100E-01,9.318000E-01,1.119700E+00,1.638800E-05,& + & 4.453700E-05,1.465200E-04,5.082700E-04,1.191400E-03,2.965400E-03,& + & 7.248300E-03,1.729200E-02,4.464900E-02,1.118000E-01,1.620100E-01,& + & 2.410400E-01,3.258300E-01,4.433800E-01,6.987200E-01,8.398200E-01,& + & 1.897800E-05,4.544000E-05,1.331600E-04,4.140200E-04,9.235900E-04,& + & 2.316800E-03,5.525300E-03,1.295900E-02,3.296300E-02,8.096100E-02,& + & 1.157200E-01,1.612400E-01,2.173100E-01,2.956000E-01,4.658900E-01,& + & 5.598800E-01,2.509800E-05,6.341600E-05,1.079600E-04,2.906500E-04,& + & 6.131900E-04,1.530600E-03,3.556800E-03,8.230700E-03,2.161300E-02,& + & 4.934800E-02,6.820800E-02,9.327900E-02,1.152200E-01,1.552200E-01,& + & 2.330100E-01,2.799700E-01,1.512300E-05,1.976400E-05,4.248200E-05,& + & 5.190700E-05,1.038100E-04,2.097400E-04,5.775400E-04,1.737400E-03,& + & 7.723500E-03,2.124800E-02,3.040900E-02,4.107600E-02,5.830200E-02,& + & 9.610300E-02,1.561000E-01,1.872400E-01,9.234600E-06,3.183400E-05,& + & 1.353600E-04,7.242400E-04,2.613700E-03,6.444900E-03,1.830600E-02,& + & 4.681700E-02,1.335000E-01,3.442600E-01,5.231100E-01,7.681800E-01,& + & 1.024300E+00,1.399700E+00,2.207700E+00,2.661600E+00,1.512200E-05,& + & 5.868000E-05,1.994900E-04,8.606300E-04,2.538400E-03,5.998000E-03,& + & 1.640100E-02,4.177000E-02,1.172300E-01,3.012800E-01,4.577600E-01,& + & 6.721600E-01,8.962600E-01,1.224900E+00,1.931500E+00,2.329000E+00,& + & 1.721700E-05,6.614900E-05,2.178000E-04,8.769900E-04,2.376300E-03,& + & 5.585800E-03,1.471900E-02,3.663400E-02,1.014100E-01,2.583100E-01,& + & 3.924400E-01,5.762800E-01,7.683600E-01,1.050000E+00,1.655700E+00,& + & 1.996300E+00,1.871500E-05,6.852800E-05,2.240000E-04,8.426600E-04,& + & 2.148900E-03,5.084200E-03,1.305800E-02,3.155800E-02,8.605300E-02,& + & 2.154500E-01,3.270700E-01,4.802600E-01,6.403500E-01,8.751500E-01,& + & 1.380300E+00,1.663500E+00,1.987000E-05,6.766800E-05,2.219400E-04,& + & 7.772100E-04,1.870600E-03,4.507400E-03,1.119000E-02,2.675900E-02,& + & 7.100600E-02,1.740700E-01,2.617600E-01,3.843100E-01,5.124000E-01,& + & 7.000400E-01,1.103900E+00,1.331000E+00,2.128400E-05,6.393700E-05,& + & 2.125400E-04,6.830400E-04,1.555700E-03,3.819600E-03,9.206300E-03,& + & 2.186100E-02,5.611300E-02,1.385000E-01,1.971800E-01,2.883400E-01,& + & 3.843800E-01,5.250200E-01,8.280100E-01,9.983500E-01,2.354100E-05,& + & 5.828500E-05,1.947500E-04,5.549500E-04,1.216000E-03,2.991100E-03,& + & 7.062600E-03,1.649200E-02,4.179200E-02,1.017000E-01,1.422500E-01,& + & 1.958400E-01,2.564300E-01,3.502200E-01,5.519100E-01,6.655100E-01/ + data absa(:,161:180) / & + & 2.847500E-05,6.223200E-05,1.633200E-04,3.832600E-04,8.239200E-04,& + & 2.005600E-03,4.594200E-03,1.060700E-02,2.786800E-02,6.245000E-02,& + & 8.564900E-02,1.149900E-01,1.394900E-01,1.954300E-01,2.761200E-01,& + & 3.328200E-01,1.581700E-05,2.730600E-05,4.513800E-05,6.916000E-05,& + & 1.461100E-04,3.100600E-04,7.982400E-04,2.411800E-03,1.074700E-02,& + & 2.948600E-02,4.090600E-02,5.576400E-02,7.987800E-02,1.330200E-01,& + & 2.237700E-01,2.669500E-01,1.248500E-05,4.627100E-05,2.011600E-04,& + & 9.877600E-04,3.266500E-03,7.964800E-03,2.236300E-02,5.696300E-02,& + & 1.614200E-01,4.116200E-01,6.194900E-01,8.971400E-01,1.180000E+00,& + & 1.622300E+00,2.560900E+00,3.094200E+00,2.088300E-05,8.443800E-05,& + & 2.878300E-04,1.151600E-03,3.207400E-03,7.443400E-03,2.010100E-02,& + & 5.093400E-02,1.418000E-01,3.602100E-01,5.421400E-01,7.851000E-01,& + & 1.032600E+00,1.419700E+00,2.240700E+00,2.707700E+00,2.376400E-05,& + & 9.518100E-05,3.104100E-04,1.158200E-03,3.013400E-03,6.973100E-03,& + & 1.810700E-02,4.473900E-02,1.229700E-01,3.088500E-01,4.647600E-01,& + & 6.730400E-01,8.851200E-01,1.216700E+00,1.920900E+00,2.321200E+00,& + & 2.568700E-05,9.820600E-05,3.173500E-04,1.104400E-03,2.731600E-03,& + & 6.387800E-03,1.608700E-02,3.869200E-02,1.047600E-01,2.575500E-01,& + & 3.873700E-01,5.609500E-01,7.376700E-01,1.014100E+00,1.600500E+00,& + & 1.934100E+00,2.683400E-05,9.687300E-05,3.119600E-04,1.013800E-03,& + & 2.386600E-03,5.667600E-03,1.385000E-02,3.297900E-02,8.681000E-02,& + & 2.093800E-01,3.100100E-01,4.488200E-01,5.902000E-01,8.114800E-01,& + & 1.280400E+00,1.547400E+00,2.752400E-05,9.174700E-05,2.957200E-04,& + & 8.882100E-04,1.993900E-03,4.806200E-03,1.147000E-02,2.705800E-02,& + & 6.895600E-02,1.687300E-01,2.360600E-01,3.367700E-01,4.428200E-01,& + & 6.089300E-01,9.605000E-01,1.160500E+00,2.951100E-05,8.168100E-05,& + & 2.705200E-04,7.175300E-04,1.568200E-03,3.773700E-03,8.833400E-03,& + & 2.056600E-02,5.184100E-02,1.242800E-01,1.731000E-01,2.339800E-01,& + & 2.960900E-01,4.062000E-01,6.403900E-01,7.737300E-01,3.449500E-05,& + & 6.983400E-05,2.321100E-04,4.916900E-04,1.078100E-03,2.554900E-03,& + & 5.799700E-03,1.338700E-02,3.514300E-02,7.763700E-02,1.045900E-01,& + & 1.373200E-01,1.699700E-01,2.448400E-01,3.261500E-01,3.869800E-01,& + & 1.546100E-05,3.961500E-05,5.085100E-05,9.823300E-05,1.982100E-04,& + & 4.256800E-04,1.068800E-03,3.252500E-03,1.456400E-02,3.962300E-02,& + & 5.438200E-02,7.369500E-02,1.065100E-01,1.847200E-01,3.119500E-01,& + & 3.653400E-01,1.668800E-05,6.567100E-05,2.889500E-04,1.297500E-03,& + & 4.013700E-03,9.709200E-03,2.674100E-02,6.813700E-02,1.912600E-01,& + & 4.840000E-01,7.194100E-01,1.026700E+00,1.327700E+00,1.852600E+00,& + & 2.915400E+00,3.529900E+00,2.837700E-05,1.180900E-04,4.018800E-04,& + & 1.491800E-03,3.987300E-03,9.102600E-03,2.413600E-02,6.098700E-02,& + & 1.682200E-01,4.235700E-01,6.295000E-01,8.983800E-01,1.161900E+00,& + & 1.621300E+00,2.551400E+00,3.088600E+00,3.228200E-05,1.327400E-04,& + & 4.292400E-04,1.486900E-03,3.762900E-03,8.570300E-03,2.183100E-02,& + & 5.366000E-02,1.462900E-01,3.631800E-01,5.397500E-01,7.701800E-01,& + & 9.959800E-01,1.389900E+00,2.186700E+00,2.647500E+00,3.476100E-05,& + & 1.367300E-04,4.350000E-04,1.411400E-03,3.415800E-03,7.873400E-03,& + & 1.947300E-02,4.658900E-02,1.251500E-01,3.027500E-01,4.498500E-01,& + & 6.419300E-01,8.300900E-01,1.158500E+00,1.822300E+00,2.206500E+00,& + & 3.607500E-05,1.345700E-04,4.241200E-04,1.293000E-03,2.992100E-03,& + & 6.986700E-03,1.686700E-02,3.986400E-02,1.042200E-01,2.483700E-01,& + & 3.600200E-01,5.136800E-01,6.641000E-01,9.271100E-01,1.458100E+00,& + & 1.765000E+00,3.621200E-05,1.274400E-04,3.995900E-04,1.127700E-03,& + & 2.512800E-03,5.926100E-03,1.402900E-02,3.287200E-02,8.317600E-02,& + & 2.017500E-01,2.801300E-01,3.854500E-01,4.982300E-01,6.956300E-01,& + & 1.093700E+00,1.323900E+00,3.583200E-05,1.152300E-04,3.622700E-04,& + & 9.084000E-04,1.987000E-03,4.665100E-03,1.084600E-02,2.521800E-02,& + & 6.308900E-02,1.490400E-01,2.049200E-01,2.768700E-01,3.391700E-01,& + & 4.646200E-01,7.291300E-01,8.826000E-01,4.081200E-05,9.325500E-05,& + & 3.007200E-04,6.319700E-04,1.373300E-03,3.184400E-03,7.161400E-03,& + & 1.659600E-02,4.350000E-02,9.512300E-02,1.246700E-01,1.607300E-01,& + & 2.039200E-01,3.071900E-01,3.960700E-01,4.414100E-01,1.747500E-05,& + & 4.594600E-05,6.676000E-05,1.345000E-04,2.637000E-04,5.640600E-04,& + & 1.398800E-03,4.277700E-03,1.926700E-02,5.203200E-02,7.040000E-02,& + & 9.604600E-02,1.392300E-01,2.530400E-01,4.284600E-01,4.830000E-01/ + data absa(:,181:200) / & + & 6.884900E-06,1.893200E-05,7.013700E-05,4.607600E-04,2.269200E-03,& + & 5.702700E-03,1.660000E-02,4.495800E-02,1.448800E-01,3.624000E-01,& + & 5.804800E-01,9.055100E-01,1.276900E+00,1.819200E+00,3.073600E+00,& + & 3.822600E+00,8.900100E-06,2.817400E-05,9.475500E-05,5.047400E-04,& + & 2.100600E-03,5.121000E-03,1.466800E-02,3.960200E-02,1.270200E-01,& + & 3.171300E-01,5.079600E-01,7.923500E-01,1.117300E+00,1.591600E+00,& + & 2.689600E+00,3.344600E+00,9.303200E-06,3.012700E-05,1.006300E-04,& + & 5.114400E-04,1.886900E-03,4.607700E-03,1.277800E-02,3.429800E-02,& + & 1.091700E-01,2.718900E-01,4.354200E-01,6.791800E-01,9.577300E-01,& + & 1.364500E+00,2.305700E+00,2.850900E+00,9.460600E-06,3.018900E-05,& + & 1.012700E-04,4.914000E-04,1.657900E-03,4.027500E-03,1.102900E-02,& + & 2.895700E-02,9.135200E-02,2.271500E-01,3.628600E-01,5.660100E-01,& + & 7.980800E-01,1.136900E+00,1.921200E+00,2.389200E+00,9.674600E-06,& + & 2.930300E-05,9.806100E-05,4.523200E-04,1.407000E-03,3.417900E-03,& + & 9.236100E-03,2.369100E-02,7.367200E-02,1.828700E-01,2.903200E-01,& + & 4.528600E-01,6.385400E-01,9.096500E-01,1.537000E+00,1.911400E+00,& + & 1.025200E-05,2.771000E-05,9.069800E-05,3.977900E-04,1.128000E-03,& + & 2.781200E-03,7.333300E-03,1.860100E-02,5.608200E-02,1.391500E-01,& + & 2.178000E-01,3.396700E-01,4.789200E-01,6.822200E-01,1.152700E+00,& + & 1.433500E+00,1.142200E-05,2.872400E-05,7.743900E-05,3.232100E-04,& + & 8.278600E-04,2.086300E-03,5.344400E-03,1.344100E-02,3.886700E-02,& + & 9.603800E-02,1.464200E-01,2.264900E-01,3.193200E-01,4.547800E-01,& + & 7.685400E-01,9.556500E-01,1.531500E-05,3.698100E-05,5.913800E-05,& + & 2.233600E-04,4.933200E-04,1.286200E-03,3.212400E-03,7.906800E-03,& + & 2.221200E-02,5.315100E-02,8.068800E-02,1.154300E-01,1.597400E-01,& + & 2.274300E-01,3.843100E-01,4.778700E-01,7.455000E-06,1.287100E-05,& + & 2.668300E-05,3.420100E-05,4.730000E-05,7.838300E-05,2.604000E-04,& + & 8.151700E-04,3.935700E-03,1.146900E-02,1.762400E-02,2.557500E-02,& + & 3.636600E-02,6.138500E-02,1.014700E-01,1.156000E-01,9.282900E-06,& + & 2.819300E-05,1.153300E-04,7.098900E-04,2.995100E-03,7.479100E-03,& + & 2.170900E-02,5.847600E-02,1.876700E-01,4.668400E-01,7.407800E-01,& + & 1.136900E+00,1.575400E+00,2.249100E+00,3.807500E+00,4.752900E+00,& + & 1.235500E-05,4.310300E-05,1.519400E-04,7.699900E-04,2.779500E-03,& + & 6.733500E-03,1.920000E-02,5.157800E-02,1.645300E-01,4.085300E-01,& + & 6.481700E-01,9.949000E-01,1.378300E+00,1.967700E+00,3.331400E+00,& + & 4.158900E+00,1.300600E-05,4.648300E-05,1.599700E-04,7.696300E-04,& + & 2.509700E-03,6.072900E-03,1.677700E-02,4.474300E-02,1.414000E-01,& + & 3.502900E-01,5.556200E-01,8.527300E-01,1.181500E+00,1.686900E+00,& + & 2.855500E+00,3.564400E+00,1.322300E-05,4.671600E-05,1.597900E-04,& + & 7.295200E-04,2.215100E-03,5.325600E-03,1.451100E-02,3.781500E-02,& + & 1.184600E-01,2.926000E-01,4.630500E-01,7.106500E-01,9.845700E-01,& + & 1.405600E+00,2.379700E+00,2.970600E+00,1.329400E-05,4.518400E-05,& + & 1.534000E-04,6.633600E-04,1.883900E-03,4.545700E-03,1.217200E-02,& + & 3.104500E-02,9.567200E-02,2.354300E-01,3.704700E-01,5.685500E-01,& + & 7.876900E-01,1.124600E+00,1.903700E+00,2.376300E+00,1.345400E-05,& + & 4.197200E-05,1.420800E-04,5.741300E-04,1.517800E-03,3.722800E-03,& + & 9.674400E-03,2.448200E-02,7.310700E-02,1.789200E-01,2.779300E-01,& + & 4.264700E-01,5.908100E-01,8.433200E-01,1.427900E+00,1.782300E+00,& + & 1.438300E-05,3.779600E-05,1.248600E-04,4.593000E-04,1.120900E-03,& + & 2.811500E-03,7.076600E-03,1.777000E-02,5.096100E-02,1.250100E-01,& + & 1.866700E-01,2.844100E-01,3.940000E-01,5.623300E-01,9.519200E-01,& + & 1.188300E+00,1.650500E-05,4.211300E-05,9.324100E-05,3.084300E-04,& + & 6.874300E-04,1.750600E-03,4.298700E-03,1.054100E-02,2.955900E-02,& + & 6.971000E-02,1.039300E-01,1.470600E-01,1.971100E-01,2.811900E-01,& + & 4.759900E-01,5.941300E-01,9.672500E-06,1.500200E-05,2.959200E-05,& + & 4.229200E-05,6.444100E-05,1.356100E-04,3.862000E-04,1.188500E-03,& + & 5.768600E-03,1.659000E-02,2.532100E-02,3.647200E-02,5.206800E-02,& + & 8.600600E-02,1.447100E-01,1.792200E-01,1.262800E-05,4.217100E-05,& + & 1.827600E-04,1.038600E-03,3.878300E-03,9.594000E-03,2.758900E-02,& + & 7.390600E-02,2.360400E-01,5.830500E-01,9.156200E-01,1.383500E+00,& + & 1.881800E+00,2.710200E+00,4.584900E+00,5.738500E+00,1.735400E-05,& + & 6.489000E-05,2.350300E-04,1.113300E-03,3.615000E-03,8.657300E-03,& + & 2.443000E-02,6.526800E-02,2.069300E-01,5.101700E-01,8.012100E-01,& + & 1.210600E+00,1.646600E+00,2.372200E+00,4.011700E+00,5.021300E+00/ + data absa(:,201:220) / & + & 1.834100E-05,7.013800E-05,2.443200E-04,1.098500E-03,3.282100E-03,& + & 7.829400E-03,2.140500E-02,5.667900E-02,1.779100E-01,4.374600E-01,& + & 6.868000E-01,1.037600E+00,1.411400E+00,2.032800E+00,3.437000E+00,& + & 4.304000E+00,1.864600E-05,7.075400E-05,2.418900E-04,1.027600E-03,& + & 2.904100E-03,6.896200E-03,1.855000E-02,4.801300E-02,1.492200E-01,& + & 3.654000E-01,5.724100E-01,8.646800E-01,1.176100E+00,1.693900E+00,& + & 2.865200E+00,3.586900E+00,1.856000E-05,6.819700E-05,2.310900E-04,& + & 9.227000E-04,2.478900E-03,5.915200E-03,1.557900E-02,3.953700E-02,& + & 1.207900E-01,2.938500E-01,4.579800E-01,6.918100E-01,9.409600E-01,& + & 1.355300E+00,2.291900E+00,2.869700E+00,1.826900E-05,6.287500E-05,& + & 2.129600E-04,7.907800E-04,2.005000E-03,4.860400E-03,1.241400E-02,& + & 3.131800E-02,9.271300E-02,2.231400E-01,3.435400E-01,5.189600E-01,& + & 7.057700E-01,1.016500E+00,1.719000E+00,2.152200E+00,1.838100E-05,& + & 5.454500E-05,1.869300E-04,6.282500E-04,1.489400E-03,3.680100E-03,& + & 9.136100E-03,2.285200E-02,6.498700E-02,1.577000E-01,2.314500E-01,& + & 3.460700E-01,4.705700E-01,6.779100E-01,1.146200E+00,1.434700E+00,& + & 1.984700E-05,4.787100E-05,1.453800E-04,4.189800E-04,9.269800E-04,& + & 2.299100E-03,5.594100E-03,1.369700E-02,3.815400E-02,8.955200E-02,& + & 1.305100E-01,1.825000E-01,2.365900E-01,3.391900E-01,5.731500E-01,& + & 7.174200E-01,1.074600E-05,1.997100E-05,3.279000E-05,5.358600E-05,& + & 9.400800E-05,2.056500E-04,5.472600E-04,1.674600E-03,8.172500E-03,& + & 2.368200E-02,3.500800E-02,5.020100E-02,7.142800E-02,1.206200E-01,& + & 2.074900E-01,2.631100E-01,1.717800E-05,6.220600E-05,2.790300E-04,& + & 1.454100E-03,4.925800E-03,1.207900E-02,3.418300E-02,9.129600E-02,& + & 2.892100E-01,7.103900E-01,1.104100E+00,1.640000E+00,2.186200E+00,& + & 3.197600E+00,5.387200E+00,6.761500E+00,2.417800E-05,9.546300E-05,& + & 3.503000E-04,1.540400E-03,4.618600E-03,1.092200E-02,3.032400E-02,& + & 8.073900E-02,2.535500E-01,6.216400E-01,9.660700E-01,1.435000E+00,& + & 1.913000E+00,2.798200E+00,4.714300E+00,5.916400E+00,2.569900E-05,& + & 1.028400E-04,3.595300E-04,1.498800E-03,4.222000E-03,9.898400E-03,& + & 2.664100E-02,7.017500E-02,2.181800E-01,5.328500E-01,8.281000E-01,& + & 1.230200E+00,1.639700E+00,2.398400E+00,4.041800E+00,5.071300E+00,& + & 2.609300E-05,1.039300E-04,3.530300E-04,1.387700E-03,3.744600E-03,& + & 8.754300E-03,2.315300E-02,5.953300E-02,1.833000E-01,4.448600E-01,& + & 6.901800E-01,1.025200E+00,1.366600E+00,1.998800E+00,3.367200E+00,& + & 4.226100E+00,2.585700E-05,9.986900E-05,3.354200E-04,1.237500E-03,& + & 3.201500E-03,7.538900E-03,1.948000E-02,4.916800E-02,1.488200E-01,& + & 3.575900E-01,5.522000E-01,8.202100E-01,1.093300E+00,1.599600E+00,& + & 2.693900E+00,3.380600E+00,2.504700E-05,9.190400E-05,3.070200E-04,& + & 1.054400E-03,2.596800E-03,6.196700E-03,1.560100E-02,3.910000E-02,& + & 1.146900E-01,2.724200E-01,4.142200E-01,6.152600E-01,8.200000E-01,& + & 1.199700E+00,2.020500E+00,2.535700E+00,2.403900E-05,7.959200E-05,& + & 2.660600E-04,8.346900E-04,1.939500E-03,4.699500E-03,1.154200E-02,& + & 2.867600E-02,8.089300E-02,1.945200E-01,2.813700E-01,4.102800E-01,& + & 5.467200E-01,8.000300E-01,1.346900E+00,1.690500E+00,2.451700E-05,& + & 6.177200E-05,2.093000E-04,5.517900E-04,1.221700E-03,2.946900E-03,& + & 7.109800E-03,1.739700E-02,4.806100E-02,1.117600E-01,1.610600E-01,& + & 2.203400E-01,2.801900E-01,4.018000E-01,6.736100E-01,8.452400E-01,& + & 1.123900E-05,2.767600E-05,3.955100E-05,6.839500E-05,1.318500E-04,& + & 2.926700E-04,7.465200E-04,2.290900E-03,1.125700E-02,3.261600E-02,& + & 4.750400E-02,6.683900E-02,9.628200E-02,1.664900E-01,2.961400E-01,& + & 3.691400E-01,2.323200E-05,8.989700E-05,4.107000E-04,1.952800E-03,& + & 6.114900E-03,1.499400E-02,4.142100E-02,1.106900E-01,3.467900E-01,& + & 8.458500E-01,1.300000E+00,1.901000E+00,2.491800E+00,3.697300E+00,& + & 6.202800E+00,7.802000E+00,3.320700E-05,1.364300E-04,5.035700E-04,& + & 2.046300E-03,5.776100E-03,1.359000E-02,3.682300E-02,9.798600E-02,& + & 3.040900E-01,7.401600E-01,1.137400E+00,1.663500E+00,2.180600E+00,& + & 3.234900E+00,5.426300E+00,6.826900E+00,3.541700E-05,1.463500E-04,& + & 5.120800E-04,1.971900E-03,5.314700E-03,1.233000E-02,3.244700E-02,& + & 8.520200E-02,2.620400E-01,6.345400E-01,9.749800E-01,1.425900E+00,& + & 1.869100E+00,2.773000E+00,4.651700E+00,5.850700E+00,3.593300E-05,& + & 1.477300E-04,4.986100E-04,1.814500E-03,4.731200E-03,1.093300E-02,& + & 2.827500E-02,7.238800E-02,2.205700E-01,5.296500E-01,8.125500E-01,& + & 1.188400E+00,1.557600E+00,2.311000E+00,3.876600E+00,4.876500E+00/ + data absa(:,221:240) / & + & 3.552100E-05,1.419100E-04,4.700800E-04,1.610200E-03,4.056700E-03,& + & 9.420600E-03,2.387300E-02,5.997500E-02,1.796300E-01,4.255800E-01,& + & 6.501300E-01,9.507600E-01,1.246000E+00,1.848900E+00,3.101400E+00,& + & 3.900800E+00,3.417900E-05,1.301800E-04,4.268300E-04,1.367700E-03,& + & 3.301200E-03,7.740200E-03,1.923200E-02,4.786400E-02,1.389900E-01,& + & 3.265100E-01,4.876700E-01,7.132300E-01,9.347400E-01,1.387300E+00,& + & 2.326000E+00,2.926100E+00,3.163900E-05,1.130300E-04,3.670100E-04,& + & 1.077600E-03,2.477500E-03,5.867800E-03,1.429700E-02,3.529100E-02,& + & 9.855800E-02,2.360100E-01,3.362200E-01,4.756300E-01,6.232200E-01,& + & 9.250600E-01,1.550700E+00,1.950700E+00,3.010700E-05,8.682700E-05,& + & 2.859200E-04,7.087700E-04,1.574700E-03,3.693600E-03,8.847200E-03,& + & 2.166800E-02,5.936400E-02,1.357700E-01,1.935000E-01,2.620100E-01,& + & 3.277500E-01,4.732600E-01,7.752700E-01,9.753400E-01,1.341300E-05,& + & 3.340900E-05,5.114600E-05,9.044400E-05,1.818600E-04,3.943300E-04,& + & 9.917700E-04,3.053000E-03,1.511300E-02,4.372100E-02,6.278200E-02,& + & 8.756800E-02,1.275800E-01,2.265400E-01,4.144700E-01,4.983200E-01,& + & 8.976300E-06,2.368800E-05,8.136800E-05,5.649200E-04,2.977700E-03,& + & 7.511000E-03,2.204100E-02,6.212400E-02,2.268700E-01,5.456500E-01,& + & 8.915800E-01,1.439900E+00,2.087300E+00,3.101900E+00,5.666600E+00,& + & 7.357100E+00,1.031000E-05,3.048100E-05,9.843100E-05,5.756500E-04,& + & 2.702000E-03,6.660200E-03,1.939400E-02,5.454400E-02,1.987000E-01,& + & 4.777400E-01,7.801400E-01,1.259900E+00,1.826500E+00,2.714000E+00,& + & 4.958300E+00,6.436900E+00,1.015200E-05,3.106000E-05,1.000700E-04,& + & 5.593100E-04,2.392600E-03,5.888900E-03,1.675700E-02,4.699900E-02,& + & 1.705300E-01,4.099800E-01,6.687000E-01,1.080000E+00,1.565400E+00,& + & 2.326500E+00,4.249600E+00,5.517200E+00,9.711200E-06,3.005400E-05,& + & 9.754200E-05,5.243400E-04,2.065300E-03,5.076100E-03,1.421500E-02,& + & 3.947000E-02,1.423500E-01,3.424200E-01,5.572400E-01,9.000100E-01,& + & 1.304600E+00,1.938700E+00,3.541700E+00,4.598500E+00,9.157300E-06,& + & 2.796100E-05,9.201700E-05,4.732000E-04,1.724000E-03,4.222900E-03,& + & 1.173600E-02,3.192300E-02,1.142400E-01,2.750300E-01,4.458200E-01,& + & 7.200000E-01,1.043700E+00,1.551000E+00,2.833200E+00,3.678300E+00,& + & 8.728600E-06,2.536700E-05,8.316900E-05,4.077700E-04,1.362800E-03,& + & 3.343800E-03,9.174900E-03,2.449700E-02,8.626100E-02,2.080200E-01,& + & 3.344100E-01,5.400300E-01,7.827600E-01,1.163300E+00,2.124600E+00,& + & 2.758900E+00,8.710000E-06,2.299900E-05,7.009000E-05,3.251200E-04,& + & 9.758500E-04,2.426500E-03,6.514100E-03,1.723400E-02,5.840700E-02,& + & 1.409200E-01,2.237200E-01,3.600800E-01,5.218700E-01,7.755200E-01,& + & 1.416500E+00,1.829100E+00,1.015100E-05,2.662900E-05,4.891900E-05,& + & 2.164100E-04,5.576900E-04,1.429000E-03,3.731000E-03,9.706200E-03,& + & 3.119800E-02,7.429400E-02,1.161500E-01,1.802600E-01,2.610000E-01,& + & 3.877700E-01,7.083700E-01,9.196500E-01,5.046800E-06,1.027500E-05,& + & 2.115600E-05,2.696600E-05,3.701800E-05,6.080000E-05,1.440400E-04,& + & 5.126600E-04,2.771900E-03,8.599400E-03,1.345200E-02,2.129300E-02,& + & 3.102200E-02,5.292800E-02,9.568900E-02,1.064500E-01,1.194400E-05,& + & 3.458200E-05,1.370600E-04,9.044100E-04,4.040500E-03,1.008100E-02,& + & 2.949800E-02,8.263900E-02,3.004900E-01,7.228100E-01,1.167800E+00,& + & 1.851300E+00,2.623000E+00,3.930200E+00,7.170200E+00,9.346800E+00,& + & 1.409400E-05,4.598300E-05,1.630000E-04,9.144700E-04,3.669800E-03,& + & 8.957300E-03,2.596100E-02,7.260400E-02,2.631800E-01,6.328500E-01,& + & 1.021800E+00,1.619800E+00,2.295300E+00,3.438600E+00,6.273500E+00,& + & 8.177800E+00,1.409800E-05,4.713300E-05,1.650300E-04,8.834900E-04,& + & 3.252700E-03,7.934000E-03,2.245900E-02,6.261100E-02,2.258600E-01,& + & 5.431200E-01,8.758600E-01,1.388600E+00,1.967300E+00,2.947300E+00,& + & 5.378800E+00,7.009500E+00,1.357000E-05,4.600200E-05,1.599000E-04,& + & 8.217000E-04,2.815000E-03,6.846600E-03,1.910400E-02,5.262600E-02,& + & 1.885600E-01,4.535300E-01,7.299100E-01,1.157000E+00,1.639400E+00,& + & 2.456100E+00,4.481000E+00,5.841400E+00,1.277100E-05,4.314100E-05,& + & 1.499200E-04,7.320800E-04,2.358200E-03,5.710800E-03,1.579600E-02,& + & 4.261300E-02,1.514700E-01,3.642300E-01,5.839300E-01,9.257500E-01,& + & 1.311600E+00,1.965200E+00,3.585900E+00,4.673200E+00,1.193400E-05,& + & 3.885400E-05,1.347200E-04,6.219000E-04,1.868900E-03,4.545300E-03,& + & 1.235900E-02,3.283300E-02,1.145000E-01,2.752600E-01,4.379900E-01,& + & 6.942900E-01,9.838000E-01,1.473800E+00,2.688800E+00,3.505100E+00/ + data absa(:,241:260) / & + & 1.128800E-05,3.330300E-05,1.139900E-04,4.876800E-04,1.345900E-03,& + & 3.319700E-03,8.785700E-03,2.321300E-02,7.781800E-02,1.860700E-01,& + & 2.930500E-01,4.629400E-01,6.558700E-01,9.826700E-01,1.792500E+00,& + & 2.336600E+00,1.180400E-05,2.989700E-05,8.361900E-05,3.181700E-04,& + & 7.782500E-04,1.972300E-03,5.067300E-03,1.314400E-02,4.195200E-02,& + & 9.899000E-02,1.529600E-01,2.318200E-01,3.279600E-01,4.914800E-01,& + & 8.963400E-01,1.168200E+00,6.454200E-06,1.222400E-05,2.505800E-05,& + & 3.498200E-05,5.093100E-05,8.372100E-05,2.346600E-04,7.842900E-04,& + & 4.165900E-03,1.262000E-02,1.987200E-02,3.112800E-02,4.556400E-02,& + & 7.505800E-02,1.358200E-01,1.661700E-01,1.626400E-05,5.169900E-05,& + & 2.233800E-04,1.366400E-03,5.298500E-03,1.319800E-02,3.826000E-02,& + & 1.065700E-01,3.849400E-01,9.229300E-01,1.477700E+00,2.300200E+00,& + & 3.178900E+00,4.834300E+00,8.785000E+00,1.149100E+01,1.962100E-05,& + & 6.935600E-05,2.614700E-04,1.368800E-03,4.825900E-03,1.174700E-02,& + & 3.368300E-02,9.370000E-02,3.371400E-01,8.081200E-01,1.293000E+00,& + & 2.012800E+00,2.781600E+00,4.229800E+00,7.687300E+00,1.005500E+01,& + & 1.977800E-05,7.168400E-05,2.614600E-04,1.307400E-03,4.298000E-03,& + & 1.041700E-02,2.919600E-02,8.087900E-02,2.893400E-01,6.934700E-01,& + & 1.108300E+00,1.725300E+00,2.384300E+00,3.625800E+00,6.588000E+00,& + & 8.617500E+00,1.911000E-05,7.050500E-05,2.511800E-04,1.201500E-03,& + & 3.735100E-03,9.006700E-03,2.488700E-02,6.801300E-02,2.417000E-01,& + & 5.789700E-01,9.235900E-01,1.437700E+00,1.987000E+00,3.021700E+00,& + & 5.490200E+00,7.182000E+00,1.799500E-05,6.640500E-05,2.333900E-04,& + & 1.058400E-03,3.135400E-03,7.537500E-03,2.060800E-02,5.519500E-02,& + & 1.943100E-01,4.647900E-01,7.388800E-01,1.150200E+00,1.589400E+00,& + & 2.417400E+00,4.392300E+00,5.712700E+00,1.661900E-05,5.981900E-05,& + & 2.083100E-04,8.860100E-04,2.495600E-03,6.025500E-03,1.614200E-02,& + & 4.266500E-02,1.471400E-01,3.510300E-01,5.542700E-01,8.627100E-01,& + & 1.192100E+00,1.813300E+00,3.294300E+00,4.309000E+00,1.521000E-05,& + & 5.054100E-05,1.756800E-04,6.853200E-04,1.804600E-03,4.419400E-03,& + & 1.150300E-02,3.030600E-02,1.004800E-01,2.372800E-01,3.705900E-01,& + & 5.752200E-01,7.948100E-01,1.209000E+00,2.196000E+00,2.872400E+00,& + & 1.476200E-05,3.907400E-05,1.313500E-04,4.419000E-04,1.057000E-03,& + & 2.633500E-03,6.677500E-03,1.729000E-02,5.466700E-02,1.274700E-01,& + & 1.956600E-01,2.878600E-01,3.974800E-01,6.046700E-01,1.098100E+00,& + & 1.428200E+00,7.786700E-06,1.617900E-05,2.838700E-05,4.583100E-05,& + & 6.816500E-05,1.242200E-04,3.487900E-04,1.138800E-03,6.024900E-03,& + & 1.840700E-02,2.822700E-02,4.367300E-02,6.408100E-02,1.069800E-01,& + & 1.901400E-01,2.523300E-01,2.212700E-05,7.736800E-05,3.512700E-04,& + & 1.970800E-03,6.833000E-03,1.698400E-02,4.819600E-02,1.339800E-01,& + & 4.788800E-01,1.144800E+00,1.811900E+00,2.772400E+00,3.766500E+00,& + & 5.791200E+00,1.047100E+01,1.374400E+01,2.739400E-05,1.034200E-04,& + & 4.038900E-04,1.957000E-03,6.245800E-03,1.513500E-02,4.246800E-02,& + & 1.178900E-01,4.194100E-01,1.002300E+00,1.585500E+00,2.425900E+00,& + & 3.295200E+00,5.067700E+00,9.162300E+00,1.202500E+01,2.777400E-05,& + & 1.071400E-04,3.990500E-04,1.852900E-03,5.592200E-03,1.342600E-02,& + & 3.688400E-02,1.018300E-01,3.600000E-01,8.600300E-01,1.359200E+00,& + & 2.079200E+00,2.824700E+00,4.343300E+00,7.853700E+00,1.030800E+01,& + & 2.689700E-05,1.054100E-04,3.791800E-04,1.685900E-03,4.880000E-03,& + & 1.162800E-02,3.150200E-02,8.569400E-02,3.009700E-01,7.179500E-01,& + & 1.132500E+00,1.732700E+00,2.353800E+00,3.619500E+00,6.544300E+00,& + & 8.589800E+00,2.533300E-05,9.959500E-05,3.497100E-04,1.469200E-03,& + & 4.111700E-03,9.756000E-03,2.613700E-02,6.966500E-02,2.422200E-01,& + & 5.761900E-01,9.061400E-01,1.386200E+00,1.883200E+00,2.896100E+00,& + & 5.236200E+00,6.872500E+00,2.336600E-05,8.960300E-05,3.103500E-04,& + & 1.219900E-03,3.279900E-03,7.811900E-03,2.052000E-02,5.399500E-02,& + & 1.839000E-01,4.349300E-01,6.796400E-01,1.039800E+00,1.412400E+00,& + & 2.172300E+00,3.926500E+00,5.154600E+00,2.085500E-05,7.545900E-05,& + & 2.598400E-04,9.358300E-04,2.379800E-03,5.733300E-03,1.470400E-02,& + & 3.848600E-02,1.261200E-01,2.951900E-01,4.543000E-01,6.932100E-01,& + & 9.416500E-01,1.448300E+00,2.617300E+00,3.436100E+00,1.880500E-05,& + & 5.538400E-05,1.926600E-04,6.002000E-04,1.405900E-03,3.418800E-03,& + & 8.584700E-03,2.214500E-02,6.924500E-02,1.608300E-01,2.426900E-01,& + & 3.483200E-01,4.709500E-01,7.244000E-01,1.309100E+00,1.718000E+00/ + data absa(:,261:280) / & + & 9.152700E-06,2.120600E-05,3.279900E-05,5.807200E-05,8.940100E-05,& + & 1.844300E-04,4.999000E-04,1.582900E-03,8.441200E-03,2.591800E-02,& + & 3.934200E-02,5.946500E-02,8.700300E-02,1.490100E-01,2.708400E-01,& + & 3.641000E-01,3.003100E-05,1.134700E-04,5.312900E-04,2.715800E-03,& + & 8.600300E-03,2.148800E-02,5.928200E-02,1.649000E-01,5.818100E-01,& + & 1.387000E+00,2.165700E+00,3.257500E+00,4.363200E+00,6.781100E+00,& + & 1.219500E+01,1.606300E+01,3.797600E-05,1.506400E-04,6.000100E-04,& + & 2.678900E-03,7.890500E-03,1.917100E-02,5.228500E-02,1.452000E-01,& + & 5.096000E-01,1.214400E+00,1.895100E+00,2.850400E+00,3.818000E+00,& + & 5.933800E+00,1.067000E+01,1.405600E+01,3.853800E-05,1.563700E-04,& + & 5.862200E-04,2.513200E-03,7.110300E-03,1.701300E-02,4.551300E-02,& + & 1.254400E-01,4.376500E-01,1.041900E+00,1.624200E+00,2.443200E+00,& + & 3.272600E+00,5.086400E+00,9.146500E+00,1.204800E+01,3.748300E-05,& + & 1.531600E-04,5.530900E-04,2.268400E-03,6.222900E-03,1.475500E-02,& + & 3.896500E-02,1.056800E-01,3.661400E-01,8.697700E-01,1.353600E+00,& + & 2.035900E+00,2.727300E+00,4.238800E+00,7.621900E+00,1.004000E+01,& + & 3.539000E-05,1.444900E-04,5.057700E-04,1.966300E-03,5.257500E-03,& + & 1.240600E-02,3.239300E-02,8.602500E-02,2.951300E-01,6.978900E-01,& + & 1.083000E+00,1.628800E+00,2.181900E+00,3.391000E+00,6.097600E+00,& + & 8.032500E+00,3.253000E-05,1.298500E-04,4.456900E-04,1.623200E-03,& + & 4.207600E-03,9.929000E-03,2.552600E-02,6.686100E-02,2.246700E-01,& + & 5.265100E-01,8.123300E-01,1.221600E+00,1.636300E+00,2.543000E+00,& + & 4.572900E+00,6.023800E+00,2.872900E-05,1.091000E-04,3.695500E-04,& + & 1.239300E-03,3.068700E-03,7.281100E-03,1.840100E-02,4.781800E-02,& + & 1.547800E-01,3.598700E-01,5.430300E-01,8.145700E-01,1.091000E+00,& + & 1.695700E+00,3.048300E+00,4.016200E+00,2.413700E-05,8.032400E-05,& + & 2.708000E-04,7.881500E-04,1.830600E-03,4.336700E-03,1.079400E-02,& + & 2.775800E-02,8.567700E-02,1.979500E-01,2.952000E-01,4.143100E-01,& + & 5.456000E-01,8.483100E-01,1.524700E+00,2.008100E+00,1.078700E-05,& + & 2.686200E-05,4.149600E-05,7.145300E-05,1.202800E-04,2.590600E-04,& + & 6.867400E-04,2.140800E-03,1.150000E-02,3.551600E-02,5.341500E-02,& + & 7.885200E-02,1.160900E-01,2.016100E-01,3.878800E-01,5.034000E-01,& + & 1.266100E-05,3.235500E-05,1.000700E-04,7.161200E-04,4.042700E-03,& + & 1.031700E-02,3.034000E-02,8.847400E-02,3.639900E-01,9.056300E-01,& + & 1.414200E+00,2.370600E+00,3.523700E+00,5.463800E+00,1.082100E+01,& + & 1.476600E+01,1.325500E-05,3.661200E-05,1.096900E-04,6.908000E-04,& + & 3.617100E-03,9.082200E-03,2.663200E-02,7.753900E-02,3.186400E-01,& + & 7.929400E-01,1.237400E+00,2.074100E+00,3.083400E+00,4.779900E+00,& + & 9.469400E+00,1.292300E+01,1.247600E-05,3.564200E-05,1.069600E-04,& + & 6.455700E-04,3.173200E-03,7.916000E-03,2.291100E-02,6.662700E-02,& + & 2.733000E-01,6.803300E-01,1.060600E+00,1.777800E+00,2.642800E+00,& + & 4.097200E+00,8.115900E+00,1.107500E+01,1.136000E-05,3.358100E-05,& + & 1.001200E-04,5.874100E-04,2.708500E-03,6.751500E-03,1.923800E-02,& + & 5.573100E-02,2.279600E-01,5.677500E-01,8.839600E-01,1.481600E+00,& + & 2.202300E+00,3.414700E+00,6.764100E+00,9.229400E+00,1.012600E-05,& + & 3.039300E-05,9.086000E-05,5.169000E-04,2.230500E-03,5.544000E-03,& + & 1.565100E-02,4.484200E-02,1.826100E-01,4.552600E-01,7.071000E-01,& + & 1.185200E+00,1.761900E+00,2.731400E+00,5.410900E+00,7.383600E+00,& + & 8.816700E-06,2.608800E-05,7.959100E-05,4.348400E-04,1.737400E-03,& + & 4.307400E-03,1.207800E-02,3.399000E-02,1.373100E-01,3.428800E-01,& + & 5.304100E-01,8.889200E-01,1.321400E+00,2.048800E+00,4.057800E+00,& + & 5.537800E+00,7.681100E-06,2.141500E-05,6.527200E-05,3.381100E-04,& + & 1.224500E-03,3.034000E-03,8.411600E-03,2.327600E-02,9.216100E-02,& + & 2.299300E-01,3.548400E-01,5.926100E-01,8.810200E-01,1.365900E+00,& + & 2.704900E+00,3.691500E+00,7.281900E-06,1.936800E-05,4.440400E-05,& + & 2.195800E-04,6.763100E-04,1.703500E-03,4.622500E-03,1.262000E-02,& + & 4.738600E-02,1.163600E-01,1.810100E-01,2.963600E-01,4.404700E-01,& + & 6.829400E-01,1.352700E+00,1.846000E+00,3.470100E-06,9.531400E-06,& + & 1.802300E-05,2.538500E-05,3.701600E-05,6.042600E-05,1.104400E-04,& + & 2.593700E-04,1.833500E-03,6.328100E-03,1.009200E-02,1.681400E-02,& + & 2.589800E-02,4.567300E-02,8.809000E-02,1.098800E-01,1.650700E-05,& + & 4.602200E-05,1.686400E-04,1.194000E-03,5.655600E-03,1.419100E-02,& + & 4.163000E-02,1.205700E-01,4.940400E-01,1.230400E+00,1.906800E+00,& + & 3.131500E+00,4.533100E+00,7.106300E+00,1.400500E+01,1.921000E+01/ + data absa(:,281:300) / & + & 1.772000E-05,5.381600E-05,1.841400E-04,1.144900E-03,5.062200E-03,& + & 1.250500E-02,3.654100E-02,1.057100E-01,4.324900E-01,1.077400E+00,& + & 1.668600E+00,2.739800E+00,3.966500E+00,6.217700E+00,1.225600E+01,& + & 1.680900E+01,1.688000E-05,5.284300E-05,1.790300E-04,1.066800E-03,& + & 4.439100E-03,1.091900E-02,3.144800E-02,9.087600E-02,3.709400E-01,& + & 9.243500E-01,1.430300E+00,2.348400E+00,3.399900E+00,5.329200E+00,& + & 1.050500E+01,1.440600E+01,1.558500E-05,4.996300E-05,1.675900E-04,& + & 9.666900E-04,3.791500E-03,9.320100E-03,2.644100E-02,7.606100E-02,& + & 3.093700E-01,7.712900E-01,1.191900E+00,1.957200E+00,2.833300E+00,& + & 4.441000E+00,8.754400E+00,1.200400E+01,1.398600E-05,4.549300E-05,& + & 1.521200E-04,8.458800E-04,3.126200E-03,7.659700E-03,2.156500E-02,& + & 6.125300E-02,2.478400E-01,6.184600E-01,9.535300E-01,1.565700E+00,& + & 2.266700E+00,3.553000E+00,7.003900E+00,9.604900E+00,1.215100E-05,& + & 3.958100E-05,1.329400E-04,7.052800E-04,2.438100E-03,5.964900E-03,& + & 1.666200E-02,4.646600E-02,1.865100E-01,4.657400E-01,7.151900E-01,& + & 1.174200E+00,1.699900E+00,2.664700E+00,5.252700E+00,7.204000E+00,& + & 1.025900E-05,3.226200E-05,1.093200E-04,5.396200E-04,1.721500E-03,& + & 4.226300E-03,1.160800E-02,3.196300E-02,1.253100E-01,3.123000E-01,& + & 4.781300E-01,7.829700E-01,1.133400E+00,1.776500E+00,3.501900E+00,& + & 4.802300E+00,8.967000E-06,2.429400E-05,7.711000E-05,3.419600E-04,& + & 9.589400E-04,2.391900E-03,6.397900E-03,1.744100E-02,6.481400E-02,& + & 1.580200E-01,2.433700E-01,3.915000E-01,5.667100E-01,8.883500E-01,& + & 1.751000E+00,2.401000E+00,4.621400E-06,1.177200E-05,2.316100E-05,& + & 3.265000E-05,4.886200E-05,8.060800E-05,1.510300E-04,4.273100E-04,& + & 2.904000E-03,9.634500E-03,1.504100E-02,2.542500E-02,3.906600E-02,& + & 6.560800E-02,1.283600E-01,1.511900E-01,2.231100E-05,6.768500E-05,& + & 2.823800E-04,1.874300E-03,7.582300E-03,1.902800E-02,5.514100E-02,& + & 1.588000E-01,6.456000E-01,1.606700E+00,2.467200E+00,3.969800E+00,& + & 5.637800E+00,8.916500E+00,1.747200E+01,2.408000E+01,2.443100E-05,& + & 8.040500E-05,3.043900E-04,1.786800E-03,6.794500E-03,1.678900E-02,& + & 4.840400E-02,1.392700E-01,5.651800E-01,1.406800E+00,2.158700E+00,& + & 3.473400E+00,4.932600E+00,7.800800E+00,1.528800E+01,2.107100E+01,& + & 2.345900E-05,7.993500E-05,2.935200E-04,1.656200E-03,5.970600E-03,& + & 1.466400E-02,4.169700E-02,1.198000E-01,4.847200E-01,1.206800E+00,& + & 1.850500E+00,2.977200E+00,4.228000E+00,6.686700E+00,1.310400E+01,& + & 1.806000E+01,2.182200E-05,7.564900E-05,2.733000E-04,1.490600E-03,& + & 5.110800E-03,1.252500E-02,3.512000E-02,1.003400E-01,4.043000E-01,& + & 1.006900E+00,1.542100E+00,2.481100E+00,3.523400E+00,5.572700E+00,& + & 1.092000E+01,1.505000E+01,1.966200E-05,6.921800E-05,2.470600E-04,& + & 1.290600E-03,4.226300E-03,1.030600E-02,2.869600E-02,8.080800E-02,& + & 3.240300E-01,8.071700E-01,1.233600E+00,1.985000E+00,2.818900E+00,& + & 4.458200E+00,8.737000E+00,1.204200E+01,1.708500E-05,6.052700E-05,& + & 2.145900E-04,1.061200E-03,3.305500E-03,8.045800E-03,2.220400E-02,& + & 6.142300E-02,2.440200E-01,6.075900E-01,9.254800E-01,1.488700E+00,& + & 2.114200E+00,3.343500E+00,6.552600E+00,9.030500E+00,1.427200E-05,& + & 4.934200E-05,1.745100E-04,7.991200E-04,2.343700E-03,5.726100E-03,& + & 1.548200E-02,4.242700E-02,1.642100E-01,4.070700E-01,6.187200E-01,& + & 9.924500E-01,1.409400E+00,2.229300E+00,4.368200E+00,6.019900E+00,& + & 1.164100E-05,3.515500E-05,1.235100E-04,4.952300E-04,1.316900E-03,& + & 3.253500E-03,8.569000E-03,2.327900E-02,8.545200E-02,2.069800E-01,& + & 3.144800E-01,4.962800E-01,7.047500E-01,1.114700E+00,2.184200E+00,& + & 2.993400E+00,5.907700E-06,1.446300E-05,2.885500E-05,4.329800E-05,& + & 6.146600E-05,1.067100E-04,2.048000E-04,6.841300E-04,4.336500E-03,& + & 1.423000E-02,2.190000E-02,3.669800E-02,5.667900E-02,9.355800E-02,& + & 1.791200E-01,2.382200E-01,3.047000E-05,1.012000E-04,4.565900E-04,& + & 2.776000E-03,9.870100E-03,2.501800E-02,7.079700E-02,2.034500E-01,& + & 8.169000E-01,2.037900E+00,3.080900E+00,4.872900E+00,6.804400E+00,& + & 1.085800E+01,2.113300E+01,2.927800E+01,3.390700E-05,1.203600E-04,& + & 4.871600E-04,2.627400E-03,8.858900E-03,2.210700E-02,6.214400E-02,& + & 1.785300E-01,7.151300E-01,1.784200E+00,2.695900E+00,4.263900E+00,& + & 5.954100E+00,9.501500E+00,1.849100E+01,2.561900E+01,3.273500E-05,& + & 1.203400E-04,4.653900E-04,2.419700E-03,7.811300E-03,1.930900E-02,& + & 5.359600E-02,1.536300E-01,6.133600E-01,1.530500E+00,2.310900E+00,& + & 3.654800E+00,5.103300E+00,8.144100E+00,1.585000E+01,2.195700E+01/ + data absa(:,301:320) / & + & 3.055000E-05,1.141800E-04,4.299600E-04,2.160900E-03,6.713100E-03,& + & 1.649800E-02,4.521200E-02,1.287100E-01,5.117100E-01,1.277000E+00,& + & 1.925800E+00,3.045700E+00,4.252500E+00,6.786800E+00,1.320900E+01,& + & 1.830000E+01,2.773600E-05,1.043400E-04,3.850600E-04,1.857000E-03,& + & 5.568100E-03,1.359200E-02,3.699500E-02,1.037200E-01,4.103800E-01,& + & 1.023500E+00,1.540500E+00,2.436600E+00,3.402100E+00,5.429100E+00,& + & 1.056800E+01,1.464000E+01,2.415900E-05,9.177400E-05,3.311200E-04,& + & 1.509800E-03,4.373600E-03,1.063300E-02,2.866400E-02,7.901100E-02,& + & 3.092800E-01,7.699200E-01,1.155900E+00,1.827500E+00,2.551800E+00,& + & 4.072900E+00,7.926500E+00,1.098000E+01,2.009300E-05,7.525700E-05,& + & 2.667100E-04,1.122900E-03,3.115000E-03,7.573600E-03,2.003900E-02,& + & 5.474300E-02,2.086300E-01,5.153900E-01,7.729000E-01,1.218400E+00,& + & 1.701200E+00,2.715000E+00,5.283500E+00,7.320800E+00,1.571100E-05,& + & 5.279300E-05,1.872500E-04,6.865400E-04,1.764000E-03,4.304100E-03,& + & 1.116300E-02,3.017000E-02,1.093200E-01,2.635900E-01,3.930200E-01,& + & 6.092700E-01,8.506200E-01,1.357700E+00,2.641600E+00,3.659600E+00,& + & 7.615200E-06,1.837500E-05,3.492300E-05,5.426800E-05,7.978400E-05,& + & 1.366700E-04,2.986600E-04,1.021400E-03,6.193400E-03,2.036200E-02,& + & 3.141000E-02,5.109800E-02,7.821400E-02,1.331000E-01,2.496800E-01,& + & 3.544400E-01,4.158100E-05,1.507100E-04,7.102700E-04,3.921000E-03,& + & 1.262700E-02,3.227800E-02,8.845900E-02,2.546100E-01,1.006800E+00,& + & 2.504200E+00,3.747400E+00,5.830200E+00,7.974800E+00,1.293000E+01,& + & 2.494600E+01,3.469000E+01,4.677800E-05,1.782200E-04,7.480000E-04,& + & 3.698000E-03,1.134900E-02,2.855000E-02,7.767400E-02,2.234600E-01,& + & 8.814700E-01,2.192500E+00,3.278700E+00,5.101500E+00,6.978500E+00,& + & 1.131700E+01,2.182900E+01,3.035200E+01,4.563400E-05,1.773300E-04,& + & 7.102100E-04,3.385400E-03,1.004400E-02,2.493200E-02,6.708800E-02,& + & 1.923400E-01,7.561600E-01,1.880600E+00,2.810300E+00,4.372600E+00,& + & 5.981400E+00,9.698300E+00,1.871200E+01,2.601700E+01,4.282700E-05,& + & 1.684000E-04,6.507800E-04,3.003700E-03,8.663300E-03,2.130900E-02,& + & 5.667700E-02,1.611700E-01,6.310600E-01,1.569000E+00,2.341900E+00,& + & 3.643800E+00,4.984100E+00,8.081900E+00,1.559400E+01,2.168300E+01,& + & 3.900000E-05,1.541000E-04,5.777700E-04,2.562700E-03,7.203300E-03,& + & 1.757600E-02,4.647000E-02,1.300200E-01,5.063500E-01,1.257400E+00,& + & 1.873700E+00,2.915400E+00,3.987200E+00,6.466700E+00,1.247500E+01,& + & 1.734900E+01,3.401000E-05,1.358400E-04,4.919400E-04,2.071000E-03,& + & 5.673500E-03,1.376400E-02,3.608700E-02,9.918400E-02,3.820500E-01,& + & 9.455800E-01,1.406000E+00,2.186500E+00,2.990600E+00,4.849600E+00,& + & 9.356300E+00,1.300900E+01,2.818500E-05,1.114100E-04,3.929700E-04,& + & 1.529500E-03,4.051900E-03,9.797900E-03,2.533200E-02,6.890100E-02,& + & 2.584300E-01,6.328100E-01,9.399100E-01,1.457800E+00,1.993900E+00,& + & 3.233300E+00,6.236900E+00,8.673400E+00,2.141400E-05,7.808000E-05,& + & 2.715500E-04,9.284000E-04,2.309300E-03,5.567400E-03,1.419500E-02,& + & 3.818100E-02,1.363400E-01,3.256900E-01,4.798100E-01,7.289600E-01,& + & 9.969500E-01,1.616800E+00,3.118300E+00,4.336600E+00,9.515100E-06,& + & 2.386800E-05,4.149500E-05,6.794000E-05,9.933800E-05,1.756900E-04,& + & 4.237200E-04,1.455200E-03,8.558800E-03,2.853700E-02,4.369300E-02,& + & 6.920100E-02,1.057300E-01,1.823600E-01,3.541800E-01,5.028100E-01,& + & 2.211000E-05,5.522600E-05,1.594600E-04,1.067000E-03,6.516200E-03,& + & 1.690800E-02,4.960100E-02,1.486800E-01,6.838400E-01,1.855100E+00,& + & 2.668300E+00,4.608300E+00,7.053900E+00,1.134600E+01,2.440200E+01,& + & 3.530500E+01,2.151600E-05,5.610600E-05,1.584200E-04,9.869200E-04,& + & 5.761000E-03,1.482700E-02,4.347200E-02,1.301700E-01,5.984800E-01,& + & 1.623900E+00,2.334900E+00,4.032800E+00,6.172600E+00,9.928300E+00,& + & 2.136200E+01,3.089800E+01,1.952000E-05,5.227500E-05,1.474600E-04,& + & 8.913400E-04,5.010000E-03,1.278100E-02,3.732100E-02,1.116700E-01,& + & 5.131000E-01,1.392600E+00,2.001200E+00,3.456600E+00,5.290600E+00,& + & 8.508400E+00,1.830200E+01,2.647900E+01,1.719700E-05,4.740000E-05,& + & 1.321100E-04,7.859300E-04,4.238200E-03,1.077500E-02,3.117700E-02,& + & 9.320100E-02,4.277500E-01,1.161300E+00,1.667700E+00,2.880400E+00,& + & 4.408800E+00,7.091200E+00,1.525300E+01,2.206600E+01,1.461000E-05,& + & 4.129900E-05,1.154600E-04,6.707300E-04,3.449700E-03,8.765300E-03,& + & 2.507200E-02,7.473900E-02,3.424200E-01,9.299500E-01,1.334400E+00,& + & 2.304600E+00,3.526700E+00,5.673200E+00,1.220300E+01,1.765300E+01/ + data absa(:,321:340) / & + & 1.183400E-05,3.444900E-05,9.616800E-05,5.446700E-04,2.652000E-03,& + & 6.715600E-03,1.904500E-02,5.627800E-02,2.570500E-01,6.984800E-01,& + & 1.001400E+00,1.728300E+00,2.645300E+00,4.254400E+00,9.148800E+00,& + & 1.323700E+01,8.977600E-06,2.659300E-05,7.432400E-05,4.075600E-04,& + & 1.835700E-03,4.626300E-03,1.303500E-02,3.790500E-02,1.717100E-01,& + & 4.666700E-01,6.687400E-01,1.152300E+00,1.763400E+00,2.836200E+00,& + & 6.101200E+00,8.826700E+00,6.403800E-06,1.783800E-05,4.839500E-05,& + & 2.521000E-04,9.884100E-04,2.479600E-03,6.912000E-03,1.969300E-02,& + & 8.660700E-02,2.346100E-01,3.370100E-01,5.761500E-01,8.817900E-01,& + & 1.418100E+00,3.050300E+00,4.413600E+00,2.929400E-06,1.022400E-05,& + & 1.798900E-05,2.835900E-05,5.089300E-05,7.209500E-05,1.255400E-04,& + & 2.280400E-04,8.976100E-04,3.728200E-03,7.464800E-03,1.289600E-02,& + & 2.124900E-02,3.915700E-02,8.017200E-02,1.122500E-01,2.811900E-05,& + & 7.668200E-05,2.577000E-04,1.858200E-03,9.389400E-03,2.389500E-02,& + & 6.987300E-02,2.079800E-01,9.527200E-01,2.588700E+00,3.706000E+00,& + & 6.256800E+00,9.370200E+00,1.515000E+01,3.233800E+01,4.710500E+01,& + & 2.783300E-05,7.950100E-05,2.570400E-04,1.710200E-03,8.304700E-03,& + & 2.096400E-02,6.122900E-02,1.821300E-01,8.338200E-01,2.265900E+00,& + & 3.243000E+00,5.473900E+00,8.198500E+00,1.325700E+01,2.829900E+01,& + & 4.121700E+01,2.559100E-05,7.495000E-05,2.394100E-04,1.541400E-03,& + & 7.223300E-03,1.808500E-02,5.257700E-02,1.563000E-01,7.149000E-01,& + & 1.943000E+00,2.779700E+00,4.692200E+00,7.027300E+00,1.136300E+01,& + & 2.425400E+01,3.532700E+01,2.281500E-05,6.827000E-05,2.155100E-04,& + & 1.355700E-03,6.109700E-03,1.526700E-02,4.392600E-02,1.304800E-01,& + & 5.959700E-01,1.620100E+00,2.316800E+00,3.909900E+00,5.856000E+00,& + & 9.469200E+00,2.021100E+01,2.944300E+01,1.954800E-05,5.983800E-05,& + & 1.883700E-04,1.154500E-03,4.976700E-03,1.242400E-02,3.535200E-02,& + & 1.046800E-01,4.770200E-01,1.296900E+00,1.853900E+00,3.128100E+00,& + & 4.684900E+00,7.575300E+00,1.616800E+01,2.355100E+01,1.603500E-05,& + & 5.036000E-05,1.571300E-04,9.350100E-04,3.826700E-03,9.517000E-03,& + & 2.691100E-02,7.889100E-02,3.581100E-01,9.738300E-01,1.391400E+00,& + & 2.346100E+00,3.513700E+00,5.681600E+00,1.212700E+01,1.766400E+01,& + & 1.229100E-05,3.921100E-05,1.221400E-04,6.950200E-04,2.650000E-03,& + & 6.571000E-03,1.846000E-02,5.315200E-02,2.393500E-01,6.505100E-01,& + & 9.291200E-01,1.564100E+00,2.342400E+00,3.787800E+00,8.085000E+00,& + & 1.177600E+01,8.463300E-06,2.564400E-05,8.136800E-05,4.232000E-04,& + & 1.427800E-03,3.544100E-03,9.792700E-03,2.777800E-02,1.208800E-01,& + & 3.268400E-01,4.680000E-01,7.820900E-01,1.171300E+00,1.894000E+00,& + & 4.042300E+00,5.888000E+00,3.746900E-06,1.367900E-05,2.396800E-05,& + & 3.723300E-05,6.636000E-05,9.680600E-05,1.514300E-04,2.973900E-04,& + & 1.576800E-03,7.168500E-03,1.143500E-02,1.988000E-02,3.309500E-02,& + & 5.730200E-02,1.191700E-01,1.490900E-01,3.751900E-05,1.116200E-04,& + & 4.247200E-04,3.039200E-03,1.288600E-02,3.285500E-02,9.464500E-02,& + & 2.801700E-01,1.271600E+00,3.460100E+00,4.913000E+00,8.135800E+00,& + & 1.194300E+01,1.941500E+01,4.111700E+01,6.028900E+01,3.757500E-05,& + & 1.174400E-04,4.244300E-04,2.781500E-03,1.140200E-02,2.884100E-02,& + & 8.293100E-02,2.453900E-01,1.112800E+00,3.028200E+00,4.299300E+00,& + & 7.118700E+00,1.045000E+01,1.698900E+01,3.597700E+01,5.276000E+01,& + & 3.496300E-05,1.110500E-04,3.971300E-04,2.498700E-03,9.922700E-03,& + & 2.490000E-02,7.121700E-02,2.106500E-01,9.540900E-01,2.596400E+00,& + & 3.685400E+00,6.101500E+00,8.956900E+00,1.456200E+01,3.083700E+01,& + & 4.522200E+01,3.132900E-05,1.016600E-04,3.576300E-04,2.191000E-03,& + & 8.398600E-03,2.103200E-02,5.953000E-02,1.759000E-01,7.953800E-01,& + & 2.164500E+00,3.071800E+00,5.084900E+00,7.464600E+00,1.213400E+01,& + & 2.570300E+01,3.768000E+01,2.698900E-05,8.954400E-05,3.112200E-04,& + & 1.859200E-03,6.847600E-03,1.711400E-02,4.797900E-02,1.411900E-01,& + & 6.366600E-01,1.732700E+00,2.458300E+00,4.067900E+00,5.971400E+00,& + & 9.706900E+00,2.056300E+01,3.014100E+01,2.237900E-05,7.544600E-05,& + & 2.590100E-04,1.497400E-03,5.271500E-03,1.312000E-02,3.659700E-02,& + & 1.064400E-01,4.780400E-01,1.300700E+00,1.845100E+00,3.050900E+00,& + & 4.478500E+00,7.280600E+00,1.541800E+01,2.260900E+01,1.720900E-05,& + & 5.910500E-05,2.004300E-04,1.101600E-03,3.656300E-03,9.078000E-03,& + & 2.513500E-02,7.177900E-02,3.197500E-01,8.686900E-01,1.232200E+00,& + & 2.033800E+00,2.985800E+00,4.853900E+00,1.028000E+01,1.507500E+01/ + data absa(:,341:360) / & + & 1.165800E-05,3.891200E-05,1.333100E-04,6.535400E-04,1.979700E-03,& + & 4.923100E-03,1.335000E-02,3.772500E-02,1.617900E-01,4.361800E-01,& + & 6.202800E-01,1.017000E+00,1.492900E+00,2.427000E+00,5.139700E+00,& + & 7.536400E+00,5.134300E-06,1.692400E-05,3.211800E-05,4.692600E-05,& + & 8.196400E-05,1.276800E-04,1.898200E-04,3.894600E-04,2.688900E-03,& + & 1.086900E-02,1.688500E-02,2.949700E-02,4.946500E-02,8.233300E-02,& + & 1.693700E-01,2.223500E-01,5.123300E-05,1.642600E-04,7.059700E-04,& + & 4.635100E-03,1.702900E-02,4.412700E-02,1.239800E-01,3.660400E-01,& + & 1.638100E+00,4.463500E+00,6.279700E+00,1.020400E+01,1.464600E+01,& + & 2.409200E+01,5.070500E+01,7.457200E+01,5.190000E-05,1.741300E-04,& + & 6.999800E-04,4.225100E-03,1.507500E-02,3.876300E-02,1.086300E-01,& + & 3.206800E-01,1.433700E+00,3.906200E+00,5.495000E+00,8.928400E+00,& + & 1.281500E+01,2.107900E+01,4.436800E+01,6.488200E+01,4.853400E-05,& + & 1.653600E-04,6.491100E-04,3.789300E-03,1.313200E-02,3.349200E-02,& + & 9.329500E-02,2.753200E-01,1.229100E+00,3.349200E+00,4.710800E+00,& + & 7.653100E+00,1.098400E+01,1.807000E+01,3.802600E+01,5.593000E+01,& + & 4.366100E-05,1.520600E-04,5.803700E-04,3.310100E-03,1.113600E-02,& + & 2.828200E-02,7.804900E-02,2.299900E-01,1.024700E+00,2.792300E+00,& + & 3.926500E+00,6.377300E+00,9.153600E+00,1.505900E+01,3.169800E+01,& + & 4.661400E+01,3.785200E-05,1.348000E-04,5.014700E-04,2.792800E-03,& + & 9.103000E-03,2.302300E-02,6.298300E-02,1.846400E-01,8.203100E-01,& + & 2.235000E+00,3.142000E+00,5.102000E+00,7.322800E+00,1.204600E+01,& + & 2.535000E+01,3.728700E+01,3.145500E-05,1.139800E-04,4.157000E-04,& + & 2.231100E-03,7.026900E-03,1.766800E-02,4.809900E-02,1.391900E-01,& + & 6.162200E-01,1.677800E+00,2.358200E+00,3.826900E+00,5.492500E+00,& + & 9.035500E+00,1.901400E+01,2.796500E+01,2.438000E-05,8.943400E-05,& + & 3.199000E-04,1.618900E-03,4.894800E-03,1.224500E-02,3.307200E-02,& + & 9.409500E-02,4.123900E-01,1.120200E+00,1.574600E+00,2.551000E+00,& + & 3.661600E+00,6.023900E+00,1.267300E+01,1.864200E+01,1.630300E-05,& + & 5.912500E-05,2.097400E-04,9.408400E-04,2.669400E-03,6.650200E-03,& + & 1.762400E-02,4.965900E-02,2.092900E-01,5.624100E-01,7.922200E-01,& + & 1.275500E+00,1.830700E+00,3.011700E+00,6.338400E+00,9.320900E+00,& + & 6.867700E-06,2.143900E-05,3.960800E-05,6.128500E-05,1.008300E-04,& + & 1.609100E-04,2.433800E-04,5.619400E-04,4.135300E-03,1.585500E-02,& + & 2.468800E-02,4.211500E-02,7.009900E-02,1.178700E-01,2.347000E-01,& + & 3.418200E-01,7.027500E-05,2.431700E-04,1.126400E-03,6.705300E-03,& + & 2.213100E-02,5.799200E-02,1.575600E-01,4.663400E-01,2.049700E+00,& + & 5.561400E+00,7.763800E+00,1.243400E+01,1.748900E+01,2.906200E+01,& + & 6.090000E+01,8.964500E+01,7.161000E-05,2.586800E-04,1.105700E-03,& + & 6.101100E-03,1.959500E-02,5.097700E-02,1.380800E-01,4.085800E-01,& + & 1.794000E+00,4.867000E+00,6.794300E+00,1.088000E+01,1.530300E+01,& + & 2.542900E+01,5.328200E+01,7.844400E+01,6.712900E-05,2.452400E-04,& + & 1.023600E-03,5.449000E-03,1.710100E-02,4.404700E-02,1.186300E-01,& + & 3.508300E-01,1.538100E+00,4.173000E+00,5.824300E+00,9.326000E+00,& + & 1.311700E+01,2.179600E+01,4.567300E+01,6.722700E+01,6.080900E-05,& + & 2.253300E-04,9.129900E-04,4.736700E-03,1.453700E-02,3.718900E-02,& + & 9.935400E-02,2.931000E-01,1.282400E+00,3.478800E+00,4.854600E+00,& + & 7.770800E+00,1.093000E+01,1.816400E+01,3.806400E+01,5.602100E+01,& + & 5.288500E-05,2.004800E-04,7.847500E-04,3.974300E-03,1.191800E-02,& + & 3.027500E-02,8.026500E-02,2.353600E-01,1.026800E+00,2.784500E+00,& + & 3.885000E+00,6.216900E+00,8.744600E+00,1.453100E+01,3.044900E+01,& + & 4.481500E+01,4.417700E-05,1.694300E-04,6.451600E-04,3.153100E-03,& + & 9.224900E-03,2.324800E-02,6.139000E-02,1.775600E-01,7.715600E-01,& + & 2.089900E+00,2.915400E+00,4.663200E+00,6.558900E+00,1.089900E+01,& + & 2.283500E+01,3.361200E+01,3.443500E-05,1.329700E-04,4.915500E-04,& + & 2.272600E-03,6.438900E-03,1.613600E-02,4.229700E-02,1.202400E-01,& + & 5.167600E-01,1.395400E+00,1.946600E+00,3.108800E+00,4.372400E+00,& + & 7.266300E+00,1.522400E+01,2.240800E+01,2.298100E-05,8.828000E-05,& + & 3.171500E-04,1.307200E-03,3.523700E-03,8.768300E-03,2.265500E-02,& + & 6.366700E-02,2.631900E-01,7.004200E-01,9.789600E-01,1.554300E+00,& + & 2.186300E+00,3.632900E+00,7.612600E+00,1.120500E+01,8.872400E-06,& + & 2.639500E-05,4.854100E-05,7.448600E-05,1.264400E-04,1.942800E-04,& + & 3.093400E-04,8.069800E-04,6.032700E-03,2.236900E-02,3.510100E-02,& + & 5.866500E-02,9.598100E-02,1.648200E-01,3.270400E-01,4.982400E-01/ + data absa(:,361:380) / & + & 7.530700E-05,1.848000E-04,5.022700E-04,3.007900E-03,1.957400E-02,& + & 5.170900E-02,1.511200E-01,4.626900E-01,2.356200E+00,7.005700E+00,& + & 9.713500E+00,1.657300E+01,2.637100E+01,4.355600E+01,1.017000E+02,& + & 1.575900E+02,6.898200E-05,1.710600E-04,4.599800E-04,2.667100E-03,& + & 1.717100E-02,4.526300E-02,1.322700E-01,4.049300E-01,2.061800E+00,& + & 6.130600E+00,8.499800E+00,1.450200E+01,2.307800E+01,3.812000E+01,& + & 8.899600E+01,1.378800E+02,6.056400E-05,1.519200E-04,4.091500E-04,& + & 2.336200E-03,1.476700E-02,3.882500E-02,1.134400E-01,3.471500E-01,& + & 1.767500E+00,5.255500E+00,7.286000E+00,1.243000E+01,1.978000E+01,& + & 3.267400E+01,7.628600E+01,1.181700E+02,5.164900E-05,1.308600E-04,& + & 3.542900E-04,1.992100E-03,1.237300E-02,3.240400E-02,9.459600E-02,& + & 2.893500E-01,1.473000E+00,4.380200E+00,6.072300E+00,1.035800E+01,& + & 1.648400E+01,2.722400E+01,6.356900E+01,9.847500E+01,4.233500E-05,& + & 1.090500E-04,2.954100E-04,1.637500E-03,9.978400E-03,2.600100E-02,& + & 7.574800E-02,2.315700E-01,1.178600E+00,3.504700E+00,4.858300E+00,& + & 8.286500E+00,1.318700E+01,2.178300E+01,5.085400E+01,7.879600E+01,& + & 3.278900E-05,8.615800E-05,2.326400E-04,1.273900E-03,7.569800E-03,& + & 1.963000E-02,5.689200E-02,1.738200E-01,8.840900E-01,2.629100E+00,& + & 3.644800E+00,6.214900E+00,9.890000E+00,1.633400E+01,3.814500E+01,& + & 5.908300E+01,2.300400E-05,6.234000E-05,1.658800E-04,8.994700E-04,& + & 5.132300E-03,1.327000E-02,3.808000E-02,1.160900E-01,5.896800E-01,& + & 1.753700E+00,2.430400E+00,4.142900E+00,6.593000E+00,1.088800E+01,& + & 2.542900E+01,3.939000E+01,1.276600E-05,3.617700E-05,9.616500E-05,& + & 5.047800E-04,2.662400E-03,6.843300E-03,1.940100E-02,5.838200E-02,& + & 2.952300E-01,8.782100E-01,1.217100E+00,2.071700E+00,3.296700E+00,& + & 5.444000E+00,1.271300E+01,1.969900E+01,4.197600E-06,1.490300E-05,& + & 2.616500E-05,4.831000E-05,7.978700E-05,1.681900E-04,2.516900E-04,& + & 3.962300E-04,7.882000E-04,2.665100E-03,3.523300E-03,3.250600E-03,& + & 6.894300E-03,2.265200E-02,7.135900E-02,1.130400E-01,9.330600E-05,& + & 2.464100E-04,7.867600E-04,5.360400E-03,2.906300E-02,7.537700E-02,& + & 2.190400E-01,6.662800E-01,3.378000E+00,1.007100E+01,1.392900E+01,& + & 2.324100E+01,3.621100E+01,5.982600E+01,1.384500E+02,2.161600E+02,& + & 8.632200E-05,2.313500E-04,7.220200E-04,4.746200E-03,2.549400E-02,& + & 6.599400E-02,1.917300E-01,5.830900E-01,2.955800E+00,8.812000E+00,& + & 1.218900E+01,2.033600E+01,3.168400E+01,5.235000E+01,1.211400E+02,& + & 1.891400E+02,7.606500E-05,2.075900E-04,6.442300E-04,4.149200E-03,& + & 2.193100E-02,5.661400E-02,1.644200E-01,4.999100E-01,2.533700E+00,& + & 7.553900E+00,1.044900E+01,1.743200E+01,2.715800E+01,4.487000E+01,& + & 1.038400E+02,1.621200E+02,6.516700E-05,1.801700E-04,5.586800E-04,& + & 3.534100E-03,1.838400E-02,4.725000E-02,1.371000E-01,4.167300E-01,& + & 2.111700E+00,6.295500E+00,8.707800E+00,1.452500E+01,2.263100E+01,& + & 3.739400E+01,8.653200E+01,1.351000E+02,5.378600E-05,1.512200E-04,& + & 4.662400E-04,2.905400E-03,1.482700E-02,3.792700E-02,1.097800E-01,& + & 3.335800E-01,1.689600E+00,5.036800E+00,6.967300E+00,1.162200E+01,& + & 1.810500E+01,2.991600E+01,6.922400E+01,1.080800E+02,4.209500E-05,& + & 1.205400E-04,3.684000E-04,2.258300E-03,1.124100E-02,2.866700E-02,& + & 8.245700E-02,2.504300E-01,1.267500E+00,3.778600E+00,5.226300E+00,& + & 8.716200E+00,1.357900E+01,2.243600E+01,5.192100E+01,8.106800E+01,& + & 2.996000E-05,8.811100E-05,2.638700E-04,1.594300E-03,7.617100E-03,& + & 1.940500E-02,5.521300E-02,1.673000E-01,8.453700E-01,2.520400E+00,& + & 3.485600E+00,5.810600E+00,9.053000E+00,1.495700E+01,3.461100E+01,& + & 5.404300E+01,1.689200E-05,5.221100E-05,1.540900E-04,8.907800E-04,& + & 3.952000E-03,1.000700E-02,2.822000E-02,8.424300E-02,4.232200E-01,& + & 1.261800E+00,1.745300E+00,2.905100E+00,4.526200E+00,7.478500E+00,& + & 1.730700E+01,2.702100E+01,6.095000E-06,2.042500E-05,3.544600E-05,& + & 6.184300E-05,1.048900E-04,2.015000E-04,3.220700E-04,5.203300E-04,& + & 1.102500E-03,3.618700E-03,4.130800E-03,8.005400E-03,1.748500E-02,& + & 4.689300E-02,1.076700E-01,1.544500E-01,1.220200E-04,3.529400E-04,& + & 1.278900E-03,9.032400E-03,4.097300E-02,1.063700E-01,3.040900E-01,& + & 9.198100E-01,4.613800E+00,1.379300E+01,1.898900E+01,3.103500E+01,& + & 4.728100E+01,7.838100E+01,1.807300E+02,2.825800E+02,1.139200E-04,& + & 3.340600E-04,1.171200E-03,7.988200E-03,3.594300E-02,9.314200E-02,& + & 2.661800E-01,8.050100E-01,4.037300E+00,1.206900E+01,1.661500E+01,& + & 2.715600E+01,4.137400E+01,6.858500E+01,1.581000E+02,2.476000E+02/ + data absa(:,381:400) / & + & 1.006800E-04,3.004700E-04,1.046200E-03,6.971400E-03,3.092300E-02,& + & 7.991300E-02,2.282500E-01,6.902400E-01,3.460700E+00,1.034500E+01,& + & 1.424300E+01,2.327700E+01,3.546200E+01,5.878900E+01,1.355100E+02,& + & 2.122300E+02,8.669600E-05,2.619300E-04,9.071100E-04,5.932000E-03,& + & 2.593000E-02,6.671300E-02,1.903300E-01,5.754300E-01,2.884000E+00,& + & 8.621500E+00,1.186900E+01,1.939600E+01,2.954900E+01,4.899300E+01,& + & 1.129300E+02,1.768600E+02,7.208000E-05,2.210000E-04,7.590000E-04,& + & 4.870000E-03,2.091100E-02,5.357900E-02,1.524000E-01,4.606700E-01,& + & 2.307600E+00,6.897900E+00,9.496600E+00,1.551600E+01,2.364200E+01,& + & 3.919400E+01,9.034500E+01,1.414900E+02,5.673900E-05,1.772700E-04,& + & 5.993000E-04,3.786400E-03,1.584600E-02,4.052500E-02,1.144800E-01,& + & 3.459400E-01,1.731100E+00,5.174700E+00,7.124400E+00,1.163800E+01,& + & 1.773100E+01,2.939600E+01,6.775500E+01,1.061100E+02,4.082000E-05,& + & 1.300000E-04,4.304300E-04,2.669300E-03,1.073900E-02,2.743800E-02,& + & 7.672400E-02,2.312000E-01,1.154600E+00,3.451200E+00,4.751600E+00,& + & 7.758900E+00,1.182000E+01,1.959700E+01,4.517600E+01,7.074400E+01,& + & 2.329200E-05,7.738600E-05,2.500800E-04,1.487200E-03,5.578900E-03,& + & 1.415900E-02,3.932600E-02,1.164600E-01,5.781700E-01,1.727400E+00,& + & 2.379200E+00,3.879500E+00,5.910300E+00,9.799000E+00,2.258300E+01,& + & 3.537300E+01,8.320000E-06,2.595600E-05,4.635800E-05,8.436900E-05,& + & 1.233000E-04,2.539500E-04,3.904300E-04,6.184800E-04,1.664300E-03,& + & 5.088600E-03,6.631900E-03,1.247800E-02,4.001100E-02,7.221000E-02,& + & 1.584900E-01,2.044100E-01,1.658000E-04,5.203300E-04,2.084000E-03,& + & 1.432900E-02,5.533300E-02,1.460100E-01,4.069100E-01,1.227500E+00,& + & 6.060800E+00,1.809500E+01,2.478500E+01,3.979400E+01,5.938100E+01,& + & 9.904800E+01,2.274500E+02,3.565300E+02,1.557000E-04,4.950400E-04,& + & 1.901600E-03,1.265800E-02,4.854600E-02,1.278700E-01,3.561800E-01,& + & 1.074300E+00,5.303200E+00,1.583400E+01,2.168800E+01,3.482000E+01,& + & 5.195700E+01,8.667600E+01,1.990300E+02,3.119200E+02,1.376900E-04,& + & 4.464000E-04,1.692400E-03,1.103200E-02,4.177600E-02,1.097300E-01,& + & 3.054400E-01,9.211700E-01,4.546200E+00,1.357400E+01,1.859100E+01,& + & 2.984600E+01,4.453700E+01,7.429400E+01,1.706100E+02,2.673500E+02,& + & 1.186900E-04,3.903400E-04,1.464800E-03,9.374800E-03,3.503400E-02,& + & 9.164000E-02,2.546700E-01,7.679800E-01,3.788600E+00,1.131100E+01,& + & 1.549300E+01,2.487100E+01,3.711400E+01,6.191500E+01,1.421700E+02,& + & 2.228000E+02,9.911900E-05,3.297800E-04,1.221500E-03,7.688000E-03,& + & 2.825900E-02,7.364300E-02,2.039300E-01,6.148900E-01,3.031300E+00,& + & 9.050500E+00,1.239600E+01,1.989700E+01,2.969000E+01,4.952600E+01,& + & 1.137300E+02,1.782500E+02,7.873500E-05,2.640900E-04,9.636600E-04,& + & 5.962400E-03,2.143500E-02,5.570700E-02,1.532600E-01,4.618000E-01,& + & 2.274000E+00,6.789300E+00,9.299100E+00,1.492300E+01,2.226700E+01,& + & 3.714700E+01,8.530100E+01,1.336900E+02,5.675900E-05,1.943400E-04,& + & 6.908400E-04,4.184600E-03,1.455000E-02,3.772100E-02,1.028100E-01,& + & 3.086900E-01,1.516800E+00,4.527700E+00,6.201900E+00,9.948500E+00,& + & 1.484600E+01,2.476700E+01,5.687500E+01,8.912300E+01,3.286000E-05,& + & 1.158700E-04,4.007200E-04,2.307500E-03,7.575100E-03,1.949300E-02,& + & 5.279600E-02,1.555400E-01,7.600000E-01,2.265900E+00,3.105100E+00,& + & 4.974500E+00,7.422900E+00,1.238300E+01,2.843300E+01,4.456500E+01,& + & 1.053800E-05,3.410100E-05,6.100100E-05,1.024700E-04,1.509700E-04,& + & 2.911400E-04,4.719100E-04,7.643200E-04,2.397400E-03,6.644500E-03,& + & 1.149000E-02,2.793400E-02,6.130000E-02,1.045200E-01,2.203000E-01,& + & 3.250300E-01,2.284500E-04,7.649500E-04,3.336700E-03,2.126100E-02,& + & 7.279500E-02,1.954000E-01,5.269400E-01,1.593100E+00,7.708500E+00,& + & 2.290900E+01,3.128300E+01,4.925900E+01,7.247400E+01,1.213000E+02,& + & 2.777300E+02,4.351300E+02,2.140300E-04,7.308300E-04,3.044100E-03,& + & 1.875500E-02,6.388000E-02,1.711400E-01,4.612300E-01,1.394400E+00,& + & 6.745400E+00,2.004600E+01,2.737300E+01,4.309900E+01,6.341900E+01,& + & 1.061400E+02,2.429800E+02,3.807500E+02,1.899500E-04,6.585400E-04,& + & 2.710500E-03,1.632500E-02,5.497600E-02,1.468900E-01,3.955600E-01,& + & 1.195600E+00,5.782300E+00,1.718300E+01,2.346500E+01,3.694300E+01,& + & 5.435600E+01,9.098000E+01,2.082900E+02,3.263200E+02,1.642800E-04,& + & 5.761700E-04,2.346200E-03,1.385800E-02,4.611400E-02,1.227000E-01,& + & 3.298500E-01,9.969900E-01,4.818900E+00,1.432000E+01,1.955600E+01,& + & 3.078500E+01,4.529600E+01,7.581800E+01,1.735800E+02,2.719700E+02/ + data absa(:,401:420) / & + & 1.374700E-04,4.871300E-04,1.955800E-03,1.133900E-02,3.723500E-02,& + & 9.861100E-02,2.641700E-01,7.982500E-01,3.855800E+00,1.145800E+01,& + & 1.564600E+01,2.462800E+01,3.623900E+01,6.065600E+01,1.388600E+02,& + & 2.175400E+02,1.094300E-04,3.908000E-04,1.543500E-03,8.766900E-03,& + & 2.827600E-02,7.457600E-02,1.986500E-01,5.995800E-01,2.892500E+00,& + & 8.594100E+00,1.173700E+01,1.847200E+01,2.717800E+01,4.549300E+01,& + & 1.041400E+02,1.631600E+02,7.947800E-05,2.881100E-04,1.105600E-03,& + & 6.114200E-03,1.924700E-02,5.050600E-02,1.334200E-01,4.009500E-01,& + & 1.929500E+00,5.731500E+00,7.827900E+00,1.231500E+01,1.811900E+01,& + & 3.032700E+01,6.943000E+01,1.087700E+02,4.633300E-05,1.725100E-04,& + & 6.355200E-04,3.332000E-03,1.006000E-02,2.613100E-02,6.862900E-02,& + & 2.022700E-01,9.671800E-01,2.868400E+00,3.918800E+00,6.157600E+00,& + & 9.059500E+00,1.516300E+01,3.471500E+01,5.439000E+01,1.264500E-05,& + & 4.368600E-05,7.903500E-05,1.216300E-04,1.944400E-04,3.250200E-04,& + & 5.396600E-04,9.367800E-04,3.253500E-03,1.071500E-02,2.101900E-02,& + & 4.766100E-02,8.568200E-02,1.479800E-01,3.057500E-01,4.878500E-01,& + & 2.974200E-04,7.195100E-04,1.938500E-03,1.091100E-02,6.787600E-02,& + & 1.790800E-01,5.240000E-01,1.630600E+00,9.105500E+00,2.963700E+01,& + & 4.166600E+01,6.716000E+01,1.118400E+02,1.882100E+02,4.767400E+02,& + & 7.982800E+02,2.651500E-04,6.417000E-04,1.715700E-03,9.563500E-03,& + & 5.942600E-02,1.567200E-01,4.585300E-01,1.426700E+00,7.967500E+00,& + & 2.593200E+01,3.645800E+01,5.876500E+01,9.784900E+01,1.646900E+02,& + & 4.171500E+02,6.985900E+02,2.297200E-04,5.584800E-04,1.486300E-03,& + & 8.233000E-03,5.097500E-02,1.343400E-01,3.930600E-01,1.223000E+00,& + & 6.829200E+00,2.222700E+01,3.125100E+01,5.036900E+01,8.387500E+01,& + & 1.411600E+02,3.575300E+02,5.987100E+02,1.931500E-04,4.725400E-04,& + & 1.253400E-03,6.909200E-03,4.252400E-02,1.119700E-01,3.276000E-01,& + & 1.019200E+00,5.691300E+00,1.852400E+01,2.604300E+01,4.197400E+01,& + & 6.989400E+01,1.176300E+02,2.979400E+02,4.989900E+02,1.561000E-04,& + & 3.854300E-04,1.019300E-03,5.580200E-03,3.408500E-02,8.959200E-02,& + & 2.621600E-01,8.154700E-01,4.553100E+00,1.481800E+01,2.083500E+01,& + & 3.358100E+01,5.591500E+01,9.410500E+01,2.383500E+02,3.991400E+02,& + & 1.188000E-04,2.961600E-04,7.790500E-04,4.239600E-03,2.564300E-02,& + & 6.724300E-02,1.966900E-01,6.116400E-01,3.414900E+00,1.111500E+01,& + & 1.562800E+01,2.518600E+01,4.193600E+01,7.058000E+01,1.787800E+02,& + & 2.993500E+02,8.111700E-05,2.044200E-04,5.357000E-04,2.881900E-03,& + & 1.721900E-02,4.490300E-02,1.312300E-01,4.078700E-01,2.276900E+00,& + & 7.410500E+00,1.041900E+01,1.679000E+01,2.795700E+01,4.705400E+01,& + & 1.191800E+02,1.995700E+02,4.231900E-05,1.091400E-04,2.862100E-04,& + & 1.506900E-03,8.744100E-03,2.265000E-02,6.575200E-02,2.041300E-01,& + & 1.138800E+00,3.706200E+00,5.211900E+00,8.395300E+00,1.397900E+01,& + & 2.352700E+01,5.959200E+01,9.978600E+01,6.394400E-06,2.868300E-05,& + & 4.861400E-05,1.016400E-04,2.137900E-04,3.540700E-04,5.034300E-04,& + & 4.585300E-04,5.880900E-04,1.766300E-03,1.649400E-03,3.706100E-05,& + & 1.809300E-05,9.828400E-06,7.988800E-06,1.411200E-06,3.618000E-04,& + & 9.507700E-04,2.939500E-03,1.857900E-02,1.036300E-01,2.680900E-01,& + & 7.816100E-01,2.412600E+00,1.340400E+01,4.373400E+01,6.169400E+01,& + & 9.711600E+01,1.581600E+02,2.647600E+02,6.685600E+02,1.123500E+03,& + & 3.244400E-04,8.514100E-04,2.600800E-03,1.628900E-02,9.072600E-02,& + & 2.346100E-01,6.840000E-01,2.111100E+00,1.172900E+01,3.826600E+01,& + & 5.398700E+01,8.497900E+01,1.383900E+02,2.316600E+02,5.852100E+02,& + & 9.832900E+02,2.821400E-04,7.432700E-04,2.256600E-03,1.402100E-02,& + & 7.782400E-02,2.011100E-01,5.863400E-01,1.809600E+00,1.005300E+01,& + & 3.280100E+01,4.627100E+01,7.282600E+01,1.186200E+02,1.985800E+02,& + & 5.016400E+02,8.428200E+02,2.380900E-04,6.305300E-04,1.907300E-03,& + & 1.175700E-02,6.492500E-02,1.676300E-01,4.886700E-01,1.508100E+00,& + & 8.378000E+00,2.733400E+01,3.856100E+01,6.069300E+01,9.884600E+01,& + & 1.654800E+02,4.178600E+02,7.023600E+02,1.928100E-04,5.162600E-04,& + & 1.553400E-03,9.495800E-03,5.203200E-02,1.341600E-01,3.910300E-01,& + & 1.206600E+00,6.702400E+00,2.186700E+01,3.085000E+01,4.855900E+01,& + & 7.908100E+01,1.323900E+02,3.343500E+02,5.618800E+02,1.471400E-04,& + & 3.982800E-04,1.193800E-03,7.211500E-03,3.915300E-02,1.007000E-01,& + & 2.933700E-01,9.051300E-01,5.027100E+00,1.640200E+01,2.313900E+01,& + & 3.641600E+01,5.931100E+01,9.929400E+01,2.507100E+02,4.213100E+02/ + data absa(:,421:440) / & + & 1.009900E-04,2.761300E-04,8.233200E-04,4.903400E-03,2.628800E-02,& + & 6.728900E-02,1.957000E-01,6.036400E-01,3.351700E+00,1.093600E+01,& + & 1.542800E+01,2.427700E+01,3.953800E+01,6.618900E+01,1.671900E+02,& + & 2.809400E+02,5.308200E-05,1.491300E-04,4.416900E-04,2.569200E-03,& + & 1.333600E-02,3.400100E-02,9.805900E-02,3.021700E-01,1.676300E+00,& + & 5.469100E+00,7.716100E+00,1.213900E+01,1.976900E+01,3.309400E+01,& + & 8.359700E+01,1.404700E+02,9.779100E-06,3.819900E-05,7.129100E-05,& + & 1.276500E-04,2.753000E-04,4.226700E-04,7.721200E-04,8.320100E-04,& + & 9.056300E-04,2.081700E-03,4.832000E-03,5.389000E-03,2.036800E-03,& + & 1.296700E-05,1.057200E-05,1.881200E-06,4.675200E-04,1.335500E-03,& + & 4.696200E-03,3.101800E-02,1.486800E-01,3.896200E-01,1.110800E+00,& + & 3.409300E+00,1.869600E+01,6.123200E+01,8.610900E+01,1.327400E+02,& + & 2.117600E+02,3.549600E+02,8.928100E+02,1.501400E+03,4.213700E-04,& + & 1.200100E-03,4.150900E-03,2.719300E-02,1.301700E-01,3.409400E-01,& + & 9.720800E-01,2.983300E+00,1.635900E+01,5.357600E+01,7.534700E+01,& + & 1.161400E+02,1.853000E+02,3.105900E+02,7.811800E+02,1.313800E+03,& + & 3.670300E-04,1.050400E-03,3.603700E-03,2.338500E-02,1.116700E-01,& + & 2.922800E-01,8.333500E-01,2.557300E+00,1.402200E+01,4.592100E+01,& + & 6.458100E+01,9.955200E+01,1.588200E+02,2.662100E+02,6.695600E+02,& + & 1.126100E+03,3.103100E-04,8.936000E-04,3.046100E-03,1.960100E-02,& + & 9.316100E-02,2.436500E-01,6.945300E-01,2.131300E+00,1.168500E+01,& + & 3.827200E+01,5.382100E+01,8.295900E+01,1.323600E+02,2.218500E+02,& + & 5.579700E+02,9.384000E+02,2.519400E-04,7.332400E-04,2.481700E-03,& + & 1.582300E-02,7.466700E-02,1.950100E-01,5.557500E-01,1.705300E+00,& + & 9.348400E+00,3.061600E+01,4.305600E+01,6.637000E+01,1.058800E+02,& + & 1.774800E+02,4.463900E+02,7.507200E+02,1.927800E-04,5.671500E-04,& + & 1.906400E-03,1.203200E-02,5.618000E-02,1.463900E-01,4.169300E-01,& + & 1.279200E+00,7.011700E+00,2.296300E+01,3.229400E+01,4.977500E+01,& + & 7.941200E+01,1.331000E+02,3.347900E+02,5.631100E+02,1.327400E-04,& + & 3.942500E-04,1.319000E-03,8.195600E-03,3.770600E-02,9.785200E-02,& + & 2.781400E-01,8.532000E-01,4.674700E+00,1.531000E+01,2.153300E+01,& + & 3.318300E+01,5.294000E+01,8.873600E+01,2.231800E+02,3.753600E+02,& + & 7.069200E-05,2.148000E-04,7.087200E-04,4.304500E-03,1.912500E-02,& + & 4.949600E-02,1.393500E-01,4.272400E-01,2.338100E+00,7.657600E+00,& + & 1.077000E+01,1.659200E+01,2.647000E+01,4.437000E+01,1.116000E+02,& + & 1.877100E+02,1.373100E-05,4.713400E-05,9.582500E-05,1.785600E-04,& + & 3.119800E-04,5.521700E-04,8.330300E-04,1.597400E-03,1.788100E-03,& + & 1.750400E-03,3.281800E-03,5.599500E-03,1.037900E-02,2.434400E-02,& + & 1.323500E-05,2.547200E-06,6.302400E-04,1.955300E-03,7.585200E-03,& + & 5.011100E-02,2.044100E-01,5.470900E-01,1.515900E+00,4.643300E+00,& + & 2.499500E+01,8.167400E+01,1.145800E+02,1.734200E+02,2.723400E+02,& + & 4.570600E+02,1.143900E+03,1.923300E+03,5.697600E-04,1.764300E-03,& + & 6.699400E-03,4.391900E-02,1.789700E-01,4.788000E-01,1.326500E+00,& + & 4.063000E+00,2.186900E+01,7.145900E+01,1.002500E+02,1.517400E+02,& + & 2.382900E+02,3.999200E+02,1.000900E+03,1.683200E+03,4.970600E-04,& + & 1.547000E-03,5.818600E-03,3.775600E-02,1.535300E-01,4.104700E-01,& + & 1.137200E+00,3.482600E+00,1.874700E+01,6.125600E+01,8.594600E+01,& + & 1.300800E+02,2.042500E+02,3.428000E+02,8.579300E+02,1.442700E+03,& + & 4.212800E-04,1.317300E-03,4.919500E-03,3.162800E-02,1.280900E-01,& + & 3.422100E-01,9.478100E-01,2.902500E+00,1.562200E+01,5.104800E+01,& + & 7.162000E+01,1.083900E+02,1.702100E+02,2.856600E+02,7.149700E+02,& + & 1.202000E+03,3.422900E-04,1.080300E-03,4.008700E-03,2.551600E-02,& + & 1.026700E-01,2.739000E-01,7.584000E-01,2.322600E+00,1.249800E+01,& + & 4.083900E+01,5.729800E+01,8.671600E+01,1.361600E+02,2.285200E+02,& + & 5.719200E+02,9.616000E+02,2.625000E-04,8.344600E-04,3.081200E-03,& + & 1.937400E-02,7.728500E-02,2.056200E-01,5.690000E-01,1.742300E+00,& + & 9.374100E+00,3.063100E+01,4.297500E+01,6.503600E+01,1.021300E+02,& + & 1.713700E+02,4.288500E+02,7.213500E+02,1.810300E-04,5.816600E-04,& + & 2.124700E-03,1.319400E-02,5.187700E-02,1.374800E-01,3.796000E-01,& + & 1.162100E+00,6.250000E+00,2.042100E+01,2.865100E+01,4.335400E+01,& + & 6.808200E+01,1.142700E+02,2.859600E+02,4.808100E+02,9.747800E-05,& + & 3.187100E-04,1.136800E-03,6.921900E-03,2.632700E-02,6.956600E-02,& + & 1.902500E-01,5.820100E-01,3.125900E+00,1.021100E+01,1.433000E+01,& + & 2.167800E+01,3.404200E+01,5.713600E+01,1.429900E+02,2.403900E+02/ + data absa(:,441:460) / & + & 1.887300E-05,5.821200E-05,1.180100E-04,2.272400E-04,3.736100E-04,& + & 6.780000E-04,1.051600E-03,1.596200E-03,3.181300E-03,7.555100E-03,& + & 1.092300E-02,7.356800E-03,8.355000E-03,2.286400E-02,7.992800E-02,& + & 3.159200E-01,8.681600E-04,2.878300E-03,1.200000E-02,7.637600E-02,& + & 2.724800E-01,7.438300E-01,2.000800E+00,6.127700E+00,3.227300E+01,& + & 1.048400E+02,1.468900E+02,2.186900E+02,3.383800E+02,5.691800E+02,& + & 1.416000E+03,2.379300E+03,7.851000E-04,2.595300E-03,1.060100E-02,& + & 6.692400E-02,2.385700E-01,6.509700E-01,1.750900E+00,5.361900E+00,& + & 2.823900E+01,9.172600E+01,1.285300E+02,1.913700E+02,2.960800E+02,& + & 4.980100E+02,1.239000E+03,2.082400E+03,6.860200E-04,2.277000E-03,& + & 9.208900E-03,5.750700E-02,2.046700E-01,5.581300E-01,1.500900E+00,& + & 4.596400E+00,2.420600E+01,7.861800E+01,1.101700E+02,1.640200E+02,& + & 2.537800E+02,4.268700E+02,1.062000E+03,1.784900E+03,5.822400E-04,& + & 1.940700E-03,7.780700E-03,4.815100E-02,1.707800E-01,4.652800E-01,& + & 1.251000E+00,3.830800E+00,2.017200E+01,6.552200E+01,9.180800E+01,& + & 1.366900E+02,2.114800E+02,3.557300E+02,8.849200E+02,1.487600E+03,& + & 4.746800E-04,1.590900E-03,6.340800E-03,3.881600E-02,1.368900E-01,& + & 3.724600E-01,1.001000E+00,3.065100E+00,1.613800E+01,5.241400E+01,& + & 7.345200E+01,1.093400E+02,1.691900E+02,2.845900E+02,7.079800E+02,& + & 1.190000E+03,3.639400E-04,1.231600E-03,4.869200E-03,2.943900E-02,& + & 1.030700E-01,2.796600E-01,7.510600E-01,2.299400E+00,1.210400E+01,& + & 3.931500E+01,5.508800E+01,8.201000E+01,1.268800E+02,2.134600E+02,& + & 5.309800E+02,8.924300E+02,2.518500E-04,8.600300E-04,3.360700E-03,& + & 2.000300E-02,6.923600E-02,1.870200E-01,5.010500E-01,1.533800E+00,& + & 8.070100E+00,2.621000E+01,3.673100E+01,5.467400E+01,8.458800E+01,& + & 1.423100E+02,3.539700E+02,5.950300E+02,1.359000E-04,4.730700E-04,& + & 1.800100E-03,1.043300E-02,3.521500E-02,9.463300E-02,2.513200E-01,& + & 7.684300E-01,4.036400E+00,1.310800E+01,1.837100E+01,2.733900E+01,& + & 4.229600E+01,7.114800E+01,1.769900E+02,2.974700E+02,2.486400E-05,& + & 7.113600E-05,1.530100E-04,2.608500E-04,4.489000E-04,7.993000E-04,& + & 1.279500E-03,2.026000E-03,3.734500E-03,1.209200E-02,1.742100E-02,& + & 1.917100E-02,2.423700E-02,3.103700E-02,2.055700E-01,4.870300E-01,& + & 4.421500E-04,1.113900E-03,3.161400E-03,1.897100E-02,1.025900E-01,& + & 2.640500E-01,7.693400E-01,2.416200E+00,1.461000E+01,5.203500E+01,& + & 7.640200E+01,1.151200E+02,1.960700E+02,3.328500E+02,9.177700E+02,& + & 1.669500E+03,3.927300E-04,9.877400E-04,2.788300E-03,1.661100E-02,& + & 8.979600E-02,2.310700E-01,6.732200E-01,2.114300E+00,1.278400E+01,& + & 4.553300E+01,6.685500E+01,1.007300E+02,1.715600E+02,2.912300E+02,& + & 8.029600E+02,1.460800E+03,3.397200E-04,8.558000E-04,2.415000E-03,& + & 1.426200E-02,7.700400E-02,1.980700E-01,5.771100E-01,1.812400E+00,& + & 1.095800E+01,3.902600E+01,5.730000E+01,8.633500E+01,1.470600E+02,& + & 2.496200E+02,6.883500E+02,1.252100E+03,2.857600E-04,7.209100E-04,& + & 2.035900E-03,1.192300E-02,6.421700E-02,1.650800E-01,4.809500E-01,& + & 1.510300E+00,9.131800E+00,3.252200E+01,4.775300E+01,7.194000E+01,& + & 1.225400E+02,2.080300E+02,5.735400E+02,1.043400E+03,2.307900E-04,& + & 5.841600E-04,1.645100E-03,9.599200E-03,5.142500E-02,1.320900E-01,& + & 3.848300E-01,1.208300E+00,7.305300E+00,2.601900E+01,3.820400E+01,& + & 5.755900E+01,9.803500E+01,1.664300E+02,4.588200E+02,8.347200E+02,& + & 1.747500E-04,4.468800E-04,1.252600E-03,7.268000E-03,3.864900E-02,& + & 9.908700E-02,2.886800E-01,9.063100E-01,5.479200E+00,1.951400E+01,& + & 2.865500E+01,4.316400E+01,7.352800E+01,1.248200E+02,3.441400E+02,& + & 6.260500E+02,1.185800E-04,3.067800E-04,8.541600E-04,4.911300E-03,& + & 2.588200E-02,6.614000E-02,1.925400E-01,6.042900E-01,3.652900E+00,& + & 1.301000E+01,1.910500E+01,2.877600E+01,4.901900E+01,8.320900E+01,& + & 2.294100E+02,4.173700E+02,6.157600E-05,1.622200E-04,4.479700E-04,& + & 2.525700E-03,1.310600E-02,3.323900E-02,9.638300E-02,3.023300E-01,& + & 1.826900E+00,6.506000E+00,9.553800E+00,1.439000E+01,2.451000E+01,& + & 4.160500E+01,1.147200E+02,2.086700E+02,6.997000E-06,3.916100E-05,& + & 5.806400E-05,1.671500E-04,2.932500E-04,4.666100E-04,4.121300E-04,& + & 6.160700E-04,9.367300E-05,2.337700E-05,4.107500E-05,3.390500E-05,& + & 1.956300E-05,7.678700E-06,9.007900E-06,1.152900E-06,5.452400E-04,& + & 1.508300E-03,4.773000E-03,3.095000E-02,1.540000E-01,3.988500E-01,& + & 1.153100E+00,3.595100E+00,2.148200E+01,7.687800E+01,1.125300E+02,& + & 1.669700E+02,2.778300E+02,4.709100E+02,1.289700E+03,2.347600E+03/ + data absa(:,461:480) / & + & 4.862400E-04,1.342300E-03,4.209700E-03,2.710300E-02,1.348000E-01,& + & 3.489800E-01,1.009000E+00,3.145800E+00,1.879700E+01,6.727000E+01,& + & 9.846300E+01,1.460900E+02,2.430800E+02,4.120700E+02,1.128400E+03,& + & 2.054000E+03,4.215800E-04,1.164900E-03,3.649800E-03,2.327100E-02,& + & 1.155900E-01,2.991700E-01,8.649200E-01,2.696300E+00,1.611200E+01,& + & 5.766000E+01,8.439900E+01,1.252300E+02,2.083600E+02,3.532000E+02,& + & 9.671800E+02,1.760800E+03,3.550700E-04,9.845500E-04,3.067100E-03,& + & 1.946300E-02,9.640300E-02,2.493500E-01,7.208600E-01,2.247000E+00,& + & 1.342700E+01,4.805100E+01,7.033100E+01,1.043600E+02,1.736300E+02,& + & 2.943400E+02,8.060500E+02,1.467300E+03,2.872800E-04,8.004700E-04,& + & 2.480900E-03,1.566400E-02,7.720000E-02,1.995200E-01,5.768000E-01,& + & 1.797800E+00,1.074200E+01,3.844400E+01,5.626900E+01,8.348200E+01,& + & 1.389100E+02,2.354900E+02,6.448400E+02,1.173900E+03,2.179700E-04,& + & 6.139700E-04,1.894800E-03,1.184700E-02,5.803600E-02,1.497000E-01,& + & 4.326800E-01,1.348400E+00,8.056400E+00,2.883200E+01,4.220200E+01,& + & 6.261200E+01,1.041800E+02,1.766000E+02,4.836800E+02,8.802900E+02,& + & 1.484900E-04,4.229100E-04,1.297700E-03,7.998100E-03,3.887800E-02,& + & 9.993800E-02,2.885700E-01,8.991700E-01,5.371100E+00,1.922100E+01,& + & 2.813600E+01,4.174400E+01,6.945100E+01,1.177400E+02,3.224200E+02,& + & 5.869100E+02,7.771000E-05,2.248200E-04,6.868600E-04,4.119900E-03,& + & 1.966700E-02,5.028700E-02,1.444500E-01,4.499300E-01,2.686000E+00,& + & 9.612900E+00,1.407000E+01,2.087300E+01,3.472700E+01,5.887100E+01,& + & 1.612000E+02,2.934900E+02,1.079600E-05,5.470100E-05,8.375400E-05,& + & 2.148900E-04,3.532700E-04,6.683100E-04,7.864300E-04,6.517600E-04,& + & 1.084800E-03,3.413100E-05,5.763500E-05,5.959000E-05,2.173700E-05,& + & 1.205300E-05,1.053400E-05,1.538200E-06,7.121200E-04,2.155900E-03,& + & 7.661400E-03,4.968500E-02,2.211800E-01,5.817800E-01,1.647900E+00,& + & 5.106000E+00,2.998200E+01,1.069500E+02,1.563600E+02,2.293000E+02,& + & 3.739200E+02,6.343400E+02,1.721700E+03,3.132600E+03,6.387400E-04,& + & 1.918100E-03,6.752100E-03,4.351700E-02,1.936100E-01,5.091000E-01,& + & 1.442000E+00,4.467800E+00,2.623400E+01,9.358400E+01,1.368000E+02,& + & 2.006400E+02,3.272000E+02,5.550500E+02,1.506400E+03,2.741600E+03,& + & 5.549100E-04,1.668600E-03,5.843500E-03,3.736900E-02,1.660300E-01,& + & 4.364400E-01,1.236100E+00,3.829700E+00,2.248700E+01,8.022100E+01,& + & 1.172500E+02,1.719600E+02,2.804700E+02,4.757900E+02,1.291200E+03,& + & 2.350000E+03,4.679100E-04,1.411200E-03,4.909300E-03,3.125600E-02,& + & 1.384600E-01,3.637900E-01,1.030200E+00,3.191500E+00,1.873900E+01,& + & 6.685100E+01,9.772400E+01,1.433100E+02,2.337100E+02,3.964800E+02,& + & 1.076100E+03,1.957900E+03,3.796800E-04,1.148400E-03,3.975800E-03,& + & 2.514400E-02,1.109000E-01,2.911000E-01,8.242700E-01,2.553500E+00,& + & 1.499200E+01,5.348000E+01,7.817300E+01,1.146600E+02,1.869700E+02,& + & 3.171900E+02,8.607200E+02,1.566400E+03,2.894600E-04,8.795700E-04,& + & 3.035100E-03,1.902100E-02,8.336800E-02,2.184300E-01,6.183600E-01,& + & 1.915300E+00,1.124400E+01,4.010900E+01,5.863200E+01,8.599400E+01,& + & 1.402300E+02,2.378700E+02,6.456400E+02,1.174900E+03,1.975100E-04,& + & 6.058400E-04,2.080700E-03,1.285300E-02,5.586100E-02,1.458200E-01,& + & 4.124300E-01,1.277200E+00,7.496500E+00,2.674200E+01,3.909000E+01,& + & 5.732700E+01,9.348500E+01,1.585900E+02,4.304200E+02,7.833400E+02,& + & 1.040500E-04,3.234600E-04,1.094800E-03,6.639600E-03,2.824200E-02,& + & 7.344000E-02,2.064600E-01,6.392000E-01,3.748900E+00,1.337200E+01,& + & 1.954800E+01,2.866800E+01,4.674400E+01,7.929800E+01,2.152000E+02,& + & 3.916200E+02,1.615600E-05,6.656400E-05,1.225300E-04,2.599000E-04,& + & 4.620200E-04,7.305800E-04,1.342400E-03,1.293000E-03,1.459300E-03,& + & 6.553200E-03,8.070600E-05,8.983300E-05,2.809800E-05,1.797900E-05,& + & 1.289000E-05,2.082300E-06,9.711200E-04,3.147200E-03,1.224600E-02,& + & 7.737400E-02,3.035300E-01,8.208100E-01,2.262400E+00,6.982800E+00,& + & 4.010200E+01,1.420400E+02,2.077400E+02,3.013200E+02,4.825800E+02,& + & 8.208000E+02,2.203000E+03,4.008700E+03,8.719800E-04,2.808500E-03,& + & 1.078500E-02,6.775000E-02,2.657100E-01,7.183200E-01,1.979600E+00,& + & 6.109800E+00,3.509000E+01,1.242800E+02,1.817700E+02,2.636400E+02,& + & 4.222300E+02,7.181900E+02,1.927600E+03,3.507600E+03,7.571700E-04,& + & 2.447400E-03,9.330100E-03,5.816300E-02,2.279000E-01,6.157700E-01,& + & 1.697000E+00,5.237300E+00,3.007900E+01,1.065300E+02,1.558000E+02,& + & 2.259800E+02,3.619400E+02,6.156200E+02,1.652200E+03,3.006500E+03/ + data absa(:,481:500) / & + & 6.391800E-04,2.074000E-03,7.848200E-03,4.860800E-02,1.900800E-01,& + & 5.133000E-01,1.414300E+00,4.364500E+00,2.506500E+01,8.877900E+01,& + & 1.298400E+02,1.883500E+02,3.016200E+02,5.130000E+02,1.376900E+03,& + & 2.505400E+03,5.191900E-04,1.688300E-03,6.356200E-03,3.906700E-02,& + & 1.522700E-01,4.107700E-01,1.131600E+00,3.492300E+00,2.005300E+01,& + & 7.102500E+01,1.038700E+02,1.506600E+02,2.412800E+02,4.103900E+02,& + & 1.101500E+03,2.004300E+03,3.965000E-04,1.295300E-03,4.853600E-03,& + & 2.954200E-02,1.144700E-01,3.082600E-01,8.489200E-01,2.619500E+00,& + & 1.503900E+01,5.326700E+01,7.790800E+01,1.130000E+02,1.809600E+02,& + & 3.078100E+02,8.261400E+02,1.503300E+03,2.705500E-04,8.934500E-04,& + & 3.326000E-03,1.996200E-02,7.670800E-02,2.058300E-01,5.661900E-01,& + & 1.746900E+00,1.002700E+01,3.551300E+01,5.193700E+01,7.533400E+01,& + & 1.206400E+02,2.051800E+02,5.507500E+02,1.002200E+03,1.427200E-04,& + & 4.789000E-04,1.748100E-03,1.031100E-02,3.876400E-02,1.037400E-01,& + & 2.834800E-01,8.743900E-01,5.014400E+00,1.776000E+01,2.597200E+01,& + & 3.767100E+01,6.032500E+01,1.026100E+02,2.753700E+02,5.011000E+02,& + & 2.276100E-05,8.311800E-05,1.574100E-04,3.211600E-04,5.633500E-04,& + & 9.080100E-04,1.404400E-03,2.645100E-03,2.058200E-03,3.623000E-03,& + & 1.125600E-02,8.416700E-03,6.282300E-03,2.604300E-05,1.877300E-05,& + & 2.400800E-06,1.343100E-03,4.636200E-03,1.902100E-02,1.150100E-01,& + & 4.055200E-01,1.119600E+00,3.007400E+00,9.237200E+00,5.187300E+01,& + & 1.814600E+02,2.650400E+02,3.816200E+02,6.014900E+02,1.027900E+03,& + & 2.728800E+03,4.954000E+03,1.207600E-03,4.138800E-03,1.675000E-02,& + & 1.007200E-01,3.549500E-01,9.797600E-01,2.631500E+00,8.082500E+00,& + & 4.538700E+01,1.587700E+02,2.319200E+02,3.339200E+02,5.262600E+02,& + & 8.993600E+02,2.387700E+03,4.334600E+03,1.048400E-03,3.607200E-03,& + & 1.450000E-02,8.643100E-02,3.044600E-01,8.399100E-01,2.255800E+00,& + & 6.928400E+00,3.890500E+01,1.360800E+02,1.988000E+02,2.862200E+02,& + & 4.511100E+02,7.708900E+02,2.046800E+03,3.715100E+03,8.850300E-04,& + & 3.060100E-03,1.220600E-02,7.221700E-02,2.539100E-01,7.001300E-01,& + & 1.880000E+00,5.774500E+00,3.242100E+01,1.134100E+02,1.656600E+02,& + & 2.385300E+02,3.759100E+02,6.424300E+02,1.705600E+03,3.096300E+03,& + & 7.186800E-04,2.493800E-03,9.892100E-03,5.805600E-02,2.033800E-01,& + & 5.603400E-01,1.504200E+00,4.620200E+00,2.593700E+01,9.072300E+01,& + & 1.325400E+02,1.908300E+02,3.007600E+02,5.139900E+02,1.364500E+03,& + & 2.476600E+03,5.499200E-04,1.912900E-03,7.556700E-03,4.389800E-02,& + & 1.528700E-01,4.205800E-01,1.128500E+00,3.465500E+00,1.945300E+01,& + & 6.804100E+01,9.940200E+01,1.431200E+02,2.255400E+02,3.854500E+02,& + & 1.023200E+03,1.857700E+03,3.760900E-04,1.318200E-03,5.176700E-03,& + & 2.964700E-02,1.024600E-01,2.808700E-01,7.526600E-01,2.311300E+00,& + & 1.297000E+01,4.536400E+01,6.626900E+01,9.541000E+01,1.503700E+02,& + & 2.570000E+02,6.821800E+02,1.238500E+03,1.995400E-04,7.036600E-04,& + & 2.725100E-03,1.526400E-02,5.187600E-02,1.415600E-01,3.769500E-01,& + & 1.157100E+00,6.486200E+00,2.268500E+01,3.313800E+01,4.770900E+01,& + & 7.518400E+01,1.284900E+02,3.410900E+02,6.191700E+02,2.994000E-05,& + & 1.005300E-04,2.005200E-04,3.748500E-04,6.923300E-04,1.108300E-03,& + & 1.694700E-03,3.209100E-03,4.470300E-03,5.306000E-03,8.331700E-03,& + & 1.816100E-02,1.440900E-02,3.681100E-02,2.819200E-05,1.330200E-05,& + & 4.844300E-04,1.274600E-03,3.882600E-03,2.340100E-02,1.180500E-01,& + & 2.966700E-01,8.447800E-01,2.655100E+00,1.718900E+01,6.670900E+01,& + & 1.020900E+02,1.512900E+02,2.547500E+02,4.407200E+02,1.304900E+03,& + & 2.594000E+03,4.296800E-04,1.129300E-03,3.418500E-03,2.048600E-02,& + & 1.033400E-01,2.596000E-01,7.392600E-01,2.323100E+00,1.504100E+01,& + & 5.837200E+01,8.932300E+01,1.323800E+02,2.228900E+02,3.856500E+02,& + & 1.141800E+03,2.268900E+03,3.710900E-04,9.774400E-04,2.957400E-03,& + & 1.758200E-02,8.861700E-02,2.225100E-01,6.337100E-01,1.991300E+00,& + & 1.289200E+01,5.003300E+01,7.656400E+01,1.134700E+02,1.910600E+02,& + & 3.305600E+02,9.785500E+02,1.945500E+03,3.117100E-04,8.228000E-04,& + & 2.490000E-03,1.468600E-02,7.388900E-02,1.854500E-01,5.281300E-01,& + & 1.659500E+00,1.074400E+01,4.169500E+01,6.380000E+01,9.455800E+01,& + & 1.592300E+02,2.754600E+02,8.154600E+02,1.621000E+03,2.515700E-04,& + & 6.650900E-04,2.012300E-03,1.180600E-02,5.917000E-02,1.483700E-01,& + & 4.225500E-01,1.327600E+00,8.594900E+00,3.335700E+01,5.104200E+01,& + & 7.564500E+01,1.273700E+02,2.203600E+02,6.524900E+02,1.297000E+03/ + data absa(:,501:520) / & + & 1.904500E-04,5.069400E-04,1.529800E-03,8.925800E-03,4.443100E-02,& + & 1.113500E-01,3.169600E-01,9.957000E-01,6.446200E+00,2.501800E+01,& + & 3.828500E+01,5.673300E+01,9.552600E+01,1.652700E+02,4.893400E+02,& + & 9.727100E+02,1.286800E-04,3.467100E-04,1.036800E-03,6.029700E-03,& + & 2.972200E-02,7.430000E-02,2.114100E-01,6.639600E-01,4.297600E+00,& + & 1.667900E+01,2.552200E+01,3.782300E+01,6.368400E+01,1.101800E+02,& + & 3.262500E+02,6.484900E+02,6.660600E-05,1.825500E-04,5.390400E-04,& + & 3.093600E-03,1.500700E-02,3.734400E-02,1.057800E-01,3.321500E-01,& + & 2.149100E+00,8.340900E+00,1.276300E+01,1.891500E+01,3.184300E+01,& + & 5.510000E+01,1.631100E+02,3.241800E+02,6.829400E-06,4.043700E-05,& + & 6.368800E-05,1.869300E-04,3.371200E-04,4.316600E-04,4.089700E-04,& + & 5.759500E-04,3.926600E-05,1.689600E-05,2.562800E-05,3.677000E-05,& + & 2.064200E-05,6.383600E-06,7.420100E-06,9.439700E-07,6.026900E-04,& + & 1.755600E-03,5.836200E-03,3.813300E-02,1.726100E-01,4.454400E-01,& + & 1.268700E+00,3.987500E+00,2.528200E+01,9.802100E+01,1.495200E+02,& + & 2.205300E+02,3.623300E+02,6.280400E+02,1.831400E+03,3.640100E+03,& + & 5.363000E-04,1.558900E-03,5.138100E-03,3.338700E-02,1.510800E-01,& + & 3.898000E-01,1.110100E+00,3.489200E+00,2.212100E+01,8.576700E+01,& + & 1.308300E+02,1.929700E+02,3.170400E+02,5.494900E+02,1.602400E+03,& + & 3.185000E+03,4.645300E-04,1.350800E-03,4.445700E-03,2.865700E-02,& + & 1.295400E-01,3.341400E-01,9.516100E-01,2.990600E+00,1.896200E+01,& + & 7.351000E+01,1.121400E+02,1.654100E+02,2.717500E+02,4.710300E+02,& + & 1.373500E+03,2.730100E+03,3.909200E-04,1.139000E-03,3.737200E-03,& + & 2.394400E-02,1.080400E-01,2.784900E-01,7.930700E-01,2.492200E+00,& + & 1.580100E+01,6.126300E+01,9.344700E+01,1.378400E+02,2.264700E+02,& + & 3.925200E+02,1.144600E+03,2.275100E+03,3.160500E-04,9.238900E-04,& + & 3.020600E-03,1.925000E-02,8.650800E-02,2.228300E-01,6.344900E-01,& + & 1.994000E+00,1.264100E+01,4.900600E+01,7.476000E+01,1.102600E+02,& + & 1.811700E+02,3.140000E+02,9.156900E+02,1.820000E+03,2.400000E-04,& + & 7.064000E-04,2.294700E-03,1.454400E-02,6.501300E-02,1.671900E-01,& + & 4.759600E-01,1.495600E+00,9.481100E+00,3.675800E+01,5.606800E+01,& + & 8.270200E+01,1.358700E+02,2.355000E+02,6.867700E+02,1.365000E+03,& + & 1.625900E-04,4.847700E-04,1.568100E-03,9.802100E-03,4.352900E-02,& + & 1.115800E-01,3.174200E-01,9.972700E-01,6.321000E+00,2.450600E+01,& + & 3.738100E+01,5.513700E+01,9.058400E+01,1.570000E+02,4.578900E+02,& + & 9.100100E+02,8.475100E-05,2.561100E-04,8.229800E-04,5.023500E-03,& + & 2.198400E-02,5.612200E-02,1.588400E-01,4.989700E-01,3.160900E+00,& + & 1.225400E+01,1.869200E+01,2.757300E+01,4.529200E+01,7.850100E+01,& + & 2.289300E+02,4.549700E+02,1.018200E-05,5.833800E-05,8.929000E-05,& + & 2.453000E-04,3.877100E-04,7.568200E-04,7.357200E-04,7.277300E-04,& + & 6.444400E-04,2.444300E-05,3.772700E-05,5.238900E-05,3.198300E-05,& + & 1.035400E-05,9.071200E-06,1.259400E-06,7.970600E-04,2.520800E-03,& + & 9.225100E-03,6.011000E-02,2.451900E-01,6.487700E-01,1.824700E+00,& + & 5.695100E+00,3.528900E+01,1.357500E+02,2.070900E+02,3.046400E+02,& + & 4.891600E+02,8.496400E+02,2.444700E+03,4.848200E+03,7.125000E-04,& + & 2.239000E-03,8.121000E-03,5.262000E-02,2.146200E-01,5.677000E-01,& + & 1.596600E+00,4.983200E+00,3.087900E+01,1.188000E+02,1.812100E+02,& + & 2.665700E+02,4.280300E+02,7.434600E+02,2.139000E+03,4.243600E+03,& + & 6.180500E-04,1.942700E-03,7.023700E-03,4.514900E-02,1.840600E-01,& + & 4.866900E-01,1.368600E+00,4.271400E+00,2.646800E+01,1.018300E+02,& + & 1.553300E+02,2.284900E+02,3.668400E+02,6.372600E+02,1.833500E+03,& + & 3.636800E+03,5.208700E-04,1.640700E-03,5.896700E-03,3.771000E-02,& + & 1.535000E-01,4.056400E-01,1.140600E+00,3.559800E+00,2.205600E+01,& + & 8.485500E+01,1.294400E+02,1.904000E+02,3.057100E+02,5.310600E+02,& + & 1.527900E+03,3.030100E+03,4.219200E-04,1.332500E-03,4.768800E-03,& + & 3.026800E-02,1.229700E-01,3.246100E-01,9.126100E-01,2.848000E+00,& + & 1.764600E+01,6.788300E+01,1.035500E+02,1.523300E+02,2.445600E+02,& + & 4.248400E+02,1.222200E+03,2.425000E+03,3.212500E-04,1.017700E-03,& + & 3.632200E-03,2.285200E-02,9.242200E-02,2.435500E-01,6.845900E-01,& + & 2.136200E+00,1.323500E+01,5.090700E+01,7.765600E+01,1.142400E+02,& + & 1.834300E+02,3.186200E+02,9.167400E+02,1.818700E+03,2.183400E-04,& + & 6.995200E-04,2.480700E-03,1.539000E-02,6.190500E-02,1.625700E-01,& + & 4.565600E-01,1.424500E+00,8.823100E+00,3.394200E+01,5.177700E+01,& + & 7.615900E+01,1.222800E+02,2.124100E+02,6.112100E+02,1.212000E+03/ + data absa(:,521:540) / & + & 1.144500E-04,3.699000E-04,1.303200E-03,7.894500E-03,3.124100E-02,& + & 8.185000E-02,2.285200E-01,7.128200E-01,4.412400E+00,1.697200E+01,& + & 2.588700E+01,3.809000E+01,6.114300E+01,1.062100E+02,3.055700E+02,& + & 6.060600E+02,1.514000E-05,7.297700E-05,1.341600E-04,2.886400E-04,& + & 5.142700E-04,7.916700E-04,1.387600E-03,1.173200E-03,1.822800E-03,& + & 3.904100E-05,4.719800E-05,7.130600E-05,4.982100E-05,1.667300E-05,& + & 9.293200E-06,1.251300E-05,1.091000E-03,3.719900E-03,1.470900E-02,& + & 9.089000E-02,3.355000E-01,9.119800E-01,2.529400E+00,7.807800E+00,& + & 4.729100E+01,1.793000E+02,2.738000E+02,4.014400E+02,6.331400E+02,& + & 1.103300E+03,3.139500E+03,6.191400E+03,9.765600E-04,3.306500E-03,& + & 1.294600E-02,7.957100E-02,2.936900E-01,7.980900E-01,2.213400E+00,& + & 6.832200E+00,4.138100E+01,1.568900E+02,2.396100E+02,3.512800E+02,& + & 5.539700E+02,9.653200E+02,2.747000E+03,5.418700E+03,8.471100E-04,& + & 2.873600E-03,1.119100E-02,6.830300E-02,2.518300E-01,6.841600E-01,& + & 1.897300E+00,5.856200E+00,3.546800E+01,1.344700E+02,2.053600E+02,& + & 3.011000E+02,4.748700E+02,8.274500E+02,2.354500E+03,4.643500E+03,& + & 7.144200E-04,2.428600E-03,9.404500E-03,5.704900E-02,2.100300E-01,& + & 5.702500E-01,1.581200E+00,4.880400E+00,2.955800E+01,1.120600E+02,& + & 1.711400E+02,2.509200E+02,3.957100E+02,6.895300E+02,1.962200E+03,& + & 3.869600E+03,5.789100E-04,1.971500E-03,7.595600E-03,4.584200E-02,& + & 1.682100E-01,4.563500E-01,1.265200E+00,3.904800E+00,2.364700E+01,& + & 8.965100E+01,1.369100E+02,2.007200E+02,3.165400E+02,5.516200E+02,& + & 1.569700E+03,3.096400E+03,4.422100E-04,1.504300E-03,5.787000E-03,& + & 3.459400E-02,1.264500E-01,3.424500E-01,9.490600E-01,2.928900E+00,& + & 1.773500E+01,6.723600E+01,1.026800E+02,1.505500E+02,2.374200E+02,& + & 4.137600E+02,1.177400E+03,2.322000E+03,3.018100E-04,1.030800E-03,& + & 3.957500E-03,2.328900E-02,8.471400E-02,2.286300E-01,6.329400E-01,& + & 1.953200E+00,1.182500E+01,4.483100E+01,6.846100E+01,1.003700E+02,& + & 1.582800E+02,2.758200E+02,7.848800E+02,1.547900E+03,1.585500E-04,& + & 5.461300E-04,2.072700E-03,1.192300E-02,4.280300E-02,1.151500E-01,& + & 3.168500E-01,9.775800E-01,5.913000E+00,2.241400E+01,3.423000E+01,& + & 5.019000E+01,7.913900E+01,1.379000E+02,3.924100E+02,7.740300E+02,& + & 2.138800E-05,9.059600E-05,1.800100E-04,3.622800E-04,6.281800E-04,& + & 9.990600E-04,1.677400E-03,2.562900E-03,2.375700E-03,2.540600E-03,& + & 7.707400E-03,9.476600E-05,7.015600E-05,2.550000E-05,1.265100E-05,& + & 2.084500E-05,1.513400E-03,5.489200E-03,2.261900E-02,1.310000E-01,& + & 4.490000E-01,1.246700E+00,3.384000E+00,1.036200E+01,6.129700E+01,& + & 2.275200E+02,3.489500E+02,5.104100E+02,7.912800E+02,1.384700E+03,& + & 3.898800E+03,7.636600E+03,1.355100E-03,4.884700E-03,1.990800E-02,& + & 1.146200E-01,3.930900E-01,1.091000E+00,2.961100E+00,9.067100E+00,& + & 5.363600E+01,1.990900E+02,3.053300E+02,4.466000E+02,6.923100E+02,& + & 1.211700E+03,3.411500E+03,6.641900E+03,1.175200E-03,4.244100E-03,& + & 1.721600E-02,9.832200E-02,3.371400E-01,9.352900E-01,2.538300E+00,& + & 7.772400E+00,4.597200E+01,1.706700E+02,2.617200E+02,3.828100E+02,& + & 5.934700E+02,1.038600E+03,2.924300E+03,5.725700E+03,9.909300E-04,& + & 3.588800E-03,1.447500E-02,8.208800E-02,2.812000E-01,7.795900E-01,& + & 2.115400E+00,6.477500E+00,3.831100E+01,1.422000E+02,2.181100E+02,& + & 3.190000E+02,4.945600E+02,8.654400E+02,2.436700E+03,4.772800E+03,& + & 8.038800E-04,2.911900E-03,1.170300E-02,6.595900E-02,2.252200E-01,& + & 6.239100E-01,1.692600E+00,5.182300E+00,3.064900E+01,1.137600E+02,& + & 1.744900E+02,2.552100E+02,3.956500E+02,6.924100E+02,1.949500E+03,& + & 3.818800E+03,6.144400E-04,2.222100E-03,8.915700E-03,4.978000E-02,& + & 1.692700E-01,4.682700E-01,1.269700E+00,3.887300E+00,2.298800E+01,& + & 8.532500E+01,1.308600E+02,1.914000E+02,2.967500E+02,5.192500E+02,& + & 1.462100E+03,2.863700E+03,4.202000E-04,1.524900E-03,6.079200E-03,& + & 3.353400E-02,1.134100E-01,3.127100E-01,8.467900E-01,2.592600E+00,& + & 1.532600E+01,5.688900E+01,8.724100E+01,1.276100E+02,1.978200E+02,& + & 3.462000E+02,9.746400E+02,1.909200E+03,2.211700E-04,8.070400E-04,& + & 3.175400E-03,1.718400E-02,5.732600E-02,1.575300E-01,4.240300E-01,& + & 1.297700E+00,7.664200E+00,2.844800E+01,4.362600E+01,6.380900E+01,& + & 9.891100E+01,1.731000E+02,4.873700E+02,9.496200E+02,2.905900E-05,& + & 1.120500E-04,2.208600E-04,4.315800E-04,7.669200E-04,1.200300E-03,& + & 1.922700E-03,3.810500E-03,3.934100E-03,5.491300E-03,8.756500E-03,& + & 8.954900E-03,2.044000E-02,3.857900E-05,2.043100E-05,2.146300E-05/ + data absa(:,541:560) / & + & 4.262500E-04,1.167000E-03,3.830900E-03,2.430300E-02,1.092100E-01,& + & 2.769000E-01,7.499200E-01,2.325800E+00,1.600000E+01,6.710300E+01,& + & 1.067500E+02,1.640600E+02,2.642300E+02,4.731000E+02,1.470300E+03,& + & 3.219200E+03,3.781200E-04,1.034300E-03,3.373100E-03,2.126200E-02,& + & 9.561300E-02,2.422800E-01,6.562600E-01,2.035000E+00,1.400000E+01,& + & 5.872000E+01,9.341100E+01,1.435600E+02,2.312000E+02,4.139700E+02,& + & 1.286700E+03,2.816000E+03,3.271100E-04,8.940300E-04,2.918700E-03,& + & 1.823000E-02,8.201600E-02,2.076900E-01,5.625200E-01,1.744400E+00,& + & 1.200000E+01,5.032900E+01,8.006700E+01,1.230600E+02,1.981700E+02,& + & 3.548300E+02,1.102800E+03,2.414100E+03,2.746500E-04,7.520600E-04,& + & 2.454200E-03,1.521100E-02,6.842300E-02,1.730800E-01,4.688200E-01,& + & 1.453700E+00,9.999800E+00,4.194300E+01,6.672500E+01,1.025500E+02,& + & 1.651400E+02,2.956900E+02,9.190400E+02,2.011700E+03,2.217700E-04,& + & 6.081500E-04,1.984400E-03,1.221300E-02,5.481400E-02,1.384800E-01,& + & 3.751200E-01,1.163000E+00,8.000200E+00,3.355500E+01,5.337900E+01,& + & 8.203700E+01,1.321100E+02,2.365500E+02,7.353200E+02,1.609100E+03,& + & 1.680000E-04,4.636100E-04,1.510700E-03,9.215500E-03,4.120700E-02,& + & 1.038900E-01,2.814000E-01,8.722600E-01,6.000200E+00,2.516500E+01,& + & 4.003200E+01,6.153400E+01,9.907700E+01,1.774100E+02,5.515000E+02,& + & 1.207000E+03,1.134200E-04,3.168400E-04,1.027900E-03,6.204600E-03,& + & 2.758900E-02,6.934000E-02,1.876800E-01,5.816100E-01,4.000300E+00,& + & 1.677700E+01,2.668800E+01,4.102300E+01,6.605500E+01,1.182700E+02,& + & 3.675900E+02,8.046000E+02,5.867800E-05,1.666500E-04,5.364200E-04,& + & 3.171400E-03,1.391500E-02,3.488800E-02,9.393800E-02,2.909800E-01,& + & 2.000500E+00,8.390200E+00,1.334700E+01,2.051300E+01,3.302600E+01,& + & 5.913500E+01,1.838000E+02,4.023500E+02,7.119300E-06,3.829700E-05,& + & 6.494200E-05,1.923300E-04,3.099600E-04,4.305000E-04,4.255600E-04,& + & 5.990800E-04,3.848600E-05,1.551100E-05,1.623000E-05,2.910500E-05,& + & 2.031600E-05,7.306200E-06,5.145800E-06,2.586600E-06,5.375900E-04,& + & 1.626300E-03,5.834700E-03,3.829600E-02,1.590800E-01,4.022600E-01,& + & 1.130400E+00,3.536000E+00,2.355100E+01,9.778700E+01,1.560800E+02,& + & 2.396600E+02,3.776200E+02,6.756900E+02,2.070400E+03,4.505900E+03,& + & 4.783200E-04,1.444800E-03,5.137600E-03,3.352100E-02,1.392700E-01,& + & 3.519800E-01,9.891300E-01,3.093800E+00,2.060700E+01,8.556400E+01,& + & 1.365700E+02,2.097100E+02,3.304100E+02,5.913000E+02,1.811500E+03,& + & 3.942800E+03,4.143300E-04,1.251800E-03,4.446100E-03,2.876200E-02,& + & 1.194500E-01,3.017200E-01,8.479300E-01,2.652000E+00,1.766300E+01,& + & 7.334400E+01,1.170600E+02,1.797600E+02,2.832200E+02,5.067900E+02,& + & 1.552800E+03,3.379100E+03,3.484400E-04,1.054800E-03,3.735200E-03,& + & 2.403100E-02,9.963300E-02,2.514500E-01,7.067100E-01,2.210100E+00,& + & 1.471900E+01,6.112500E+01,9.755200E+01,1.497800E+02,2.360000E+02,& + & 4.223200E+02,1.293900E+03,2.816000E+03,2.818800E-04,8.553700E-04,& + & 3.019700E-03,1.931000E-02,7.978600E-02,2.012300E-01,5.654100E-01,& + & 1.768100E+00,1.177600E+01,4.889600E+01,7.804600E+01,1.198300E+02,& + & 1.888200E+02,3.378600E+02,1.035100E+03,2.253100E+03,2.142300E-04,& + & 6.530800E-04,2.295000E-03,1.456800E-02,5.997300E-02,1.510100E-01,& + & 4.241700E-01,1.326200E+00,8.832500E+00,3.667200E+01,5.853100E+01,& + & 8.987900E+01,1.416100E+02,2.534000E+02,7.763800E+02,1.689700E+03,& + & 1.451900E-04,4.473400E-04,1.558800E-03,9.807200E-03,4.017600E-02,& + & 1.008100E-01,2.828800E-01,8.843500E-01,5.888300E+00,2.445100E+01,& + & 3.902400E+01,5.992000E+01,9.440500E+01,1.689200E+02,5.176500E+02,& + & 1.126400E+03,7.558800E-05,2.363400E-04,8.162900E-04,5.004700E-03,& + & 2.027600E-02,5.078300E-02,1.415900E-01,4.425000E-01,2.944700E+00,& + & 1.222600E+01,1.951300E+01,2.996600E+01,4.719900E+01,8.446500E+01,& + & 2.587500E+02,5.632800E+02,1.031700E-05,5.401200E-05,9.276700E-05,& + & 2.484200E-04,3.741400E-04,7.164900E-04,7.898600E-04,8.155500E-04,& + & 5.394500E-04,2.197700E-05,2.246600E-05,3.673600E-05,3.922000E-05,& + & 8.674000E-06,6.186700E-06,9.471900E-06,7.201800E-04,2.357600E-03,& + & 9.219400E-03,5.837900E-02,2.208600E-01,5.786300E-01,1.634300E+00,& + & 5.089600E+00,3.295000E+01,1.346300E+02,2.154900E+02,3.304000E+02,& + & 5.122100E+02,9.178800E+02,2.773900E+03,5.988100E+03,6.430900E-04,& + & 2.097500E-03,8.116200E-03,5.106500E-02,1.933900E-01,5.063400E-01,& + & 1.430000E+00,4.453600E+00,2.883000E+01,1.178000E+02,1.885500E+02,& + & 2.890900E+02,4.481700E+02,8.031500E+02,2.427200E+03,5.238800E+03/ + data absa(:,561:580) / & + & 5.576400E-04,1.820100E-03,7.017300E-03,4.383200E-02,1.658200E-01,& + & 4.341000E-01,1.225900E+00,3.817500E+00,2.471100E+01,1.009700E+02,& + & 1.616200E+02,2.478100E+02,3.841400E+02,6.884100E+02,2.080500E+03,& + & 4.490700E+03,4.694800E-04,1.536800E-03,5.893000E-03,3.663100E-02,& + & 1.382900E-01,3.618200E-01,1.021700E+00,3.181400E+00,2.059400E+01,& + & 8.414500E+01,1.346800E+02,2.065100E+02,3.201400E+02,5.736900E+02,& + & 1.733600E+03,3.742300E+03,3.803000E-04,1.247900E-03,4.759800E-03,& + & 2.943400E-02,1.107700E-01,2.895600E-01,8.174500E-01,2.545200E+00,& + & 1.647500E+01,6.731300E+01,1.077400E+02,1.652100E+02,2.561100E+02,& + & 4.589300E+02,1.386900E+03,2.993500E+03,2.893800E-04,9.529500E-04,& + & 3.617500E-03,2.220500E-02,8.330600E-02,2.172800E-01,6.132100E-01,& + & 1.909100E+00,1.235600E+01,5.048600E+01,8.080300E+01,1.239000E+02,& + & 1.920800E+02,3.442400E+02,1.040300E+03,2.245000E+03,1.967800E-04,& + & 6.530300E-04,2.459100E-03,1.494000E-02,5.582300E-02,1.451200E-01,& + & 4.089700E-01,1.273200E+00,8.238200E+00,3.365800E+01,5.387400E+01,& + & 8.260800E+01,1.280600E+02,2.294600E+02,6.935600E+02,1.496800E+03,& + & 1.028500E-04,3.453200E-04,1.285700E-03,7.638400E-03,2.817600E-02,& + & 7.314800E-02,2.047500E-01,6.371200E-01,4.119700E+00,1.683200E+01,& + & 2.693900E+01,4.130700E+01,6.402700E+01,1.147400E+02,3.467400E+02,& + & 7.484100E+02,1.404100E-05,6.885800E-05,1.328800E-04,2.873400E-04,& + & 4.999200E-04,7.748200E-04,1.401900E-03,1.264000E-03,1.772200E-03,& + & 3.234200E-05,3.054200E-05,4.713900E-05,5.961100E-05,1.366300E-05,& + & 7.706100E-06,1.656100E-05,9.895300E-04,3.515800E-03,1.438600E-02,& + & 8.555800E-02,3.019500E-01,8.132400E-01,2.266700E+00,7.021000E+00,& + & 4.426300E+01,1.768800E+02,2.837100E+02,4.360800E+02,6.661500E+02,& + & 1.197500E+03,3.565800E+03,7.626500E+03,8.854600E-04,3.127700E-03,& + & 1.266600E-02,7.484100E-02,2.643900E-01,7.116500E-01,1.983400E+00,& + & 6.143500E+00,3.873000E+01,1.547700E+02,2.482600E+02,3.816000E+02,& + & 5.829000E+02,1.047900E+03,3.119800E+03,6.672900E+03,7.680000E-04,& + & 2.715800E-03,1.094900E-02,6.422700E-02,2.267600E-01,6.101300E-01,& + & 1.700200E+00,5.266000E+00,3.319800E+01,1.326700E+02,2.128000E+02,& + & 3.270800E+02,4.996100E+02,8.981600E+02,2.674000E+03,5.720000E+03,& + & 6.471100E-04,2.293900E-03,9.197900E-03,5.363800E-02,1.891700E-01,& + & 5.085100E-01,1.417000E+00,4.388600E+00,2.766600E+01,1.105600E+02,& + & 1.773300E+02,2.725600E+02,4.163600E+02,7.484300E+02,2.228700E+03,& + & 4.767100E+03,5.245000E-04,1.861700E-03,7.429400E-03,4.308200E-02,& + & 1.515600E-01,4.069600E-01,1.133700E+00,3.511200E+00,2.213200E+01,& + & 8.843800E+01,1.418600E+02,2.180400E+02,3.330900E+02,5.987400E+02,& + & 1.783000E+03,3.813300E+03,3.995600E-04,1.421000E-03,5.646000E-03,& + & 3.249900E-02,1.140100E-01,3.054100E-01,8.504700E-01,2.633800E+00,& + & 1.660000E+01,6.633400E+01,1.064000E+02,1.635400E+02,2.498200E+02,& + & 4.490500E+02,1.337100E+03,2.860000E+03,2.731200E-04,9.723700E-04,& + & 3.849300E-03,2.186300E-02,7.639500E-02,2.040400E-01,5.672200E-01,& + & 1.756500E+00,1.106700E+01,4.422000E+01,7.093500E+01,1.090300E+02,& + & 1.665500E+02,2.993800E+02,8.914200E+02,1.906600E+03,1.434900E-04,& + & 5.130200E-04,2.007500E-03,1.118900E-02,3.858700E-02,1.028700E-01,& + & 2.840800E-01,8.791900E-01,5.534500E+00,2.211300E+01,3.547000E+01,& + & 5.451700E+01,8.327500E+01,1.496900E+02,4.457200E+02,9.475700E+02,& + & 1.995400E-05,8.628400E-05,1.745800E-04,3.616700E-04,6.229300E-04,& + & 9.939200E-04,1.685700E-03,2.670100E-03,2.508100E-03,5.618900E-03,& + & 1.375800E-03,5.995300E-05,8.360000E-05,2.141200E-05,1.157300E-05,& + & 2.153700E-05,1.379000E-03,5.186800E-03,2.188700E-02,1.210500E-01,& + & 4.030500E-01,1.110400E+00,3.045000E+00,9.367100E+00,5.746100E+01,& + & 2.247600E+02,3.596200E+02,5.540100E+02,8.384700E+02,1.510100E+03,& + & 4.427000E+03,9.382700E+03,1.236600E-03,4.612600E-03,1.927100E-02,& + & 1.060100E-01,3.527600E-01,9.717900E-01,2.664600E+00,8.196300E+00,& + & 5.027700E+01,1.966700E+02,3.146700E+02,4.847800E+02,7.336700E+02,& + & 1.321400E+03,3.873800E+03,8.208600E+03,1.073100E-03,4.004300E-03,& + & 1.666400E-02,9.094300E-02,3.025900E-01,8.331500E-01,2.284100E+00,& + & 7.026000E+00,4.309600E+01,1.685700E+02,2.697300E+02,4.155300E+02,& + & 6.288400E+02,1.132600E+03,3.320500E+03,7.036600E+03,9.047700E-04,& + & 3.379600E-03,1.400700E-02,7.594500E-02,2.524100E-01,6.945000E-01,& + & 1.903600E+00,5.855400E+00,3.591300E+01,1.404700E+02,2.247800E+02,& + & 3.462700E+02,5.240500E+02,9.437600E+02,2.767000E+03,5.863900E+03/ + data absa(:,581:585) / & + & 7.337700E-04,2.740700E-03,1.133200E-02,6.099500E-02,2.022100E-01,& + & 5.558600E-01,1.523100E+00,4.684900E+00,2.873100E+01,1.123800E+02,& + & 1.798100E+02,2.770100E+02,4.192500E+02,7.550400E+02,2.213500E+03,& + & 4.691700E+03,5.603700E-04,2.092100E-03,8.613200E-03,4.599000E-02,& + & 1.520900E-01,4.172800E-01,1.142600E+00,3.514200E+00,2.154900E+01,& + & 8.428900E+01,1.348700E+02,2.077600E+02,3.144100E+02,5.662600E+02,& + & 1.660200E+03,3.518100E+03,3.836500E-04,1.430200E-03,5.854300E-03,& + & 3.095300E-02,1.019000E-01,2.788900E-01,7.620400E-01,2.343700E+00,& + & 1.436600E+01,5.619500E+01,8.991000E+01,1.385100E+02,2.096200E+02,& + & 3.775200E+02,1.106800E+03,2.345600E+03,2.014700E-04,7.555400E-04,& + & 3.039900E-03,1.585800E-02,5.147700E-02,1.406800E-01,3.817900E-01,& + & 1.173400E+00,7.184300E+00,2.810000E+01,4.496000E+01,6.926100E+01,& + & 1.048100E+02,1.887600E+02,5.533700E+02,1.172900E+03,2.687100E-05,& + & 1.070300E-04,2.186600E-04,4.301400E-04,7.683500E-04,1.181600E-03,& + & 1.957800E-03,3.960600E-03,4.360200E-03,6.045900E-03,3.990300E-03,& + & 1.382600E-02,8.681400E-03,3.361500E-05,1.891900E-05,2.128300E-05/ + + + data absb(:, 1: 20) / & + & 1.573100E-03,3.627900E-03,9.154000E-03,6.704900E-02,4.323600E-01,& + & 1.209100E+00,3.500200E+00,1.098400E+01,7.366600E+01,3.088700E+02,& + & 4.913700E+02,7.551600E+02,1.216200E+03,2.177600E+03,6.767600E+03,& + & 1.481800E+04,1.869600E-03,6.176000E-03,2.098300E-02,1.057800E-01,& + & 4.321300E-01,1.092500E+00,2.842600E+00,8.364400E+00,5.539600E+01,& + & 2.318200E+02,3.686600E+02,5.665100E+02,9.122800E+02,1.633300E+03,& + & 5.075800E+03,1.111300E+04,1.848600E-03,7.413700E-03,2.740900E-02,& + & 1.204900E-01,3.970100E-01,9.713200E-01,2.222900E+00,5.832300E+00,& + & 3.712900E+01,1.547700E+02,2.459500E+02,3.778600E+02,6.083500E+02,& + & 1.089100E+03,3.384000E+03,7.408900E+03,1.718600E-03,8.175600E-03,& + & 3.045000E-02,1.144700E-01,3.254600E-01,7.683200E-01,1.594000E+00,& + & 3.520700E+00,1.892800E+01,7.773400E+01,1.232500E+02,1.892100E+02,& + & 3.044200E+02,5.447800E+02,1.692200E+03,3.704500E+03,1.389800E-03,& + & 7.667800E-03,2.314400E-02,5.399600E-02,1.119700E-01,2.242900E-01,& + & 4.628400E-01,9.557300E-01,2.024000E+00,3.234000E+00,3.715400E+00,& + & 4.605700E+00,5.760900E+00,7.326200E+00,9.091000E+00,1.137100E+01,& + & 1.862300E-03,4.727500E-03,1.515000E-02,1.237800E-01,6.637200E-01,& + & 1.846400E+00,5.276400E+00,1.645700E+01,1.084000E+02,4.501000E+02,& + & 7.184200E+02,1.103100E+03,1.738100E+03,3.110100E+03,9.530000E+03,& + & 2.073900E+04,2.396300E-03,8.309900E-03,2.983600E-02,1.583900E-01,& + & 6.137900E-01,1.564000E+00,4.153200E+00,1.246000E+01,8.144700E+01,& + & 3.377300E+02,5.389400E+02,8.274600E+02,1.303700E+03,2.332700E+03,& + & 7.147500E+03,1.555500E+04,2.436200E-03,9.877900E-03,3.708800E-02,& + & 1.671600E-01,5.357800E-01,1.297700E+00,3.077400E+00,8.502400E+00,& + & 5.449000E+01,2.253700E+02,3.594600E+02,5.518300E+02,8.693100E+02,& + & 1.555300E+03,4.765100E+03,1.037000E+04,2.299000E-03,1.059000E-02,& + & 3.956200E-02,1.496700E-01,4.137800E-01,9.673800E-01,2.024500E+00,& + & 4.754300E+00,2.755600E+01,1.130100E+02,1.799800E+02,2.762000E+02,& + & 4.349000E+02,7.778800E+02,2.382700E+03,5.185100E+03,1.822300E-03,& + & 9.219000E-03,2.615700E-02,5.872400E-02,1.174900E-01,2.294500E-01,& + & 4.644900E-01,9.489800E-01,1.992900E+00,3.167900E+00,3.625500E+00,& + & 4.475200E+00,5.643200E+00,7.312400E+00,8.959300E+00,1.098500E+01,& + & 2.371800E-03,6.781700E-03,2.670500E-02,2.150800E-01,9.601200E-01,& + & 2.700600E+00,7.609600E+00,2.351400E+01,1.516700E+02,6.197000E+02,& + & 9.918600E+02,1.520800E+03,2.357600E+03,4.224900E+03,1.276800E+04,& + & 2.756200E+04,3.187800E-03,1.154600E-02,4.349500E-02,2.335700E-01,& + & 8.454300E-01,2.193300E+00,5.884600E+00,1.774900E+01,1.138900E+02,& + & 4.649200E+02,7.440200E+02,1.140700E+03,1.768300E+03,3.168700E+03,& + & 9.576100E+03,2.067200E+04,3.254000E-03,1.332400E-02,5.048900E-02,& + & 2.280700E-01,7.069000E-01,1.717400E+00,4.204800E+00,1.199800E+01,& + & 7.611300E+01,3.101400E+02,4.961800E+02,7.606700E+02,1.179100E+03,& + & 2.112600E+03,6.384200E+03,1.378100E+04,3.043000E-03,1.374800E-02,& + & 5.086800E-02,1.925600E-01,5.203900E-01,1.208900E+00,2.566400E+00,& + & 6.412500E+00,3.834300E+01,1.553600E+02,2.483300E+02,3.806200E+02,& + & 5.897700E+02,1.056500E+03,3.192300E+03,6.890600E+03,2.291500E-03,& + & 1.077800E-02,2.916900E-02,6.346800E-02,1.222900E-01,2.358600E-01,& + & 4.656400E-01,9.395500E-01,1.960100E+00,3.111800E+00,3.545200E+00,& + & 4.335700E+00,5.525500E+00,7.248000E+00,8.886000E+00,1.072000E+01,& + & 3.192100E-03,1.039100E-02,4.650100E-02,3.465800E-01,1.334000E+00,& + & 3.804100E+00,1.054500E+01,3.233300E+01,2.037400E+02,8.141300E+02,& + & 1.305900E+03,2.007200E+03,3.066200E+03,5.511800E+03,1.641300E+04,& + & 3.510400E+04,4.310400E-03,1.629000E-02,6.352500E-02,3.354700E-01,& + & 1.134300E+00,3.009800E+00,8.071800E+00,2.435900E+01,1.529400E+02,& + & 6.107400E+02,9.795400E+02,1.505600E+03,2.299800E+03,4.133900E+03,& + & 1.231000E+04,2.632800E+04,4.359000E-03,1.804800E-02,6.893000E-02,& + & 3.053200E-01,9.149100E-01,2.253400E+00,5.635300E+00,1.638900E+01,& + & 1.021400E+02,4.073400E+02,6.531900E+02,1.003900E+03,1.533400E+03,& + & 2.756100E+03,8.206700E+03,1.755200E+04,3.982100E-03,1.778600E-02,& + & 6.521300E-02,2.436800E-01,6.465100E-01,1.496600E+00,3.257300E+00,& + & 8.525300E+00,5.134900E+01,2.039500E+02,3.268300E+02,5.022100E+02,& + & 7.669400E+02,1.378300E+03,4.103500E+03,8.776000E+03,2.770900E-03,& + & 1.229900E-02,3.220700E-02,6.789500E-02,1.271700E-01,2.414800E-01,& + & 4.680500E-01,9.268900E-01,1.930100E+00,3.035100E+00,3.473600E+00,& + & 4.196000E+00,5.404400E+00,7.156800E+00,8.809400E+00,1.059400E+01/ + data absb(:, 21: 40) / & + & 4.431300E-03,1.623100E-02,7.788300E-02,5.191800E-01,1.805900E+00,& + & 5.187400E+00,1.410100E+01,4.312400E+01,2.644900E+02,1.034500E+03,& + & 1.655300E+03,2.550000E+03,3.859400E+03,6.950600E+03,2.037700E+04,& + & 4.318700E+04,5.869100E-03,2.297300E-02,9.195700E-02,4.654200E-01,& + & 1.494500E+00,4.040400E+00,1.072600E+01,3.244800E+01,1.985000E+02,& + & 7.760400E+02,1.241600E+03,1.912600E+03,2.894700E+03,5.213100E+03,& + & 1.528300E+04,3.239000E+04,5.811800E-03,2.436900E-02,9.347100E-02,& + & 4.007100E-01,1.168700E+00,2.927700E+00,7.377600E+00,2.177500E+01,& + & 1.325100E+02,5.175300E+02,8.278700E+02,1.275300E+03,1.929900E+03,& + & 3.475500E+03,1.018900E+04,2.159400E+04,5.152800E-03,2.286600E-02,& + & 8.339400E-02,3.035100E-01,7.950100E-01,1.838400E+00,4.107100E+00,& + & 1.115200E+01,6.652500E+01,2.590300E+02,4.141700E+02,6.379000E+02,& + & 9.652300E+02,1.738000E+03,5.094600E+03,1.079700E+04,3.242600E-03,& + & 1.377500E-02,3.520500E-02,7.218000E-02,1.320000E-01,2.471700E-01,& + & 4.695900E-01,9.177900E-01,1.894500E+00,2.984700E+00,3.415800E+00,& + & 4.022300E+00,5.235500E+00,7.036700E+00,8.701000E+00,1.067600E+01,& + & 8.149600E-04,1.906900E-03,4.976900E-03,3.759100E-02,2.357600E-01,& + & 6.667200E-01,1.933200E+00,6.100000E+00,4.202100E+01,1.872200E+02,& + & 3.124200E+02,5.031300E+02,7.936200E+02,1.449600E+03,4.685500E+03,& + & 1.126500E+04,1.144900E-03,4.218500E-03,1.554200E-02,7.593500E-02,& + & 2.736000E-01,6.885500E-01,1.683300E+00,4.720700E+00,3.166400E+01,& + & 1.405700E+02,2.344300E+02,3.774900E+02,5.953300E+02,1.087300E+03,& + & 3.514200E+03,8.448800E+03,1.252100E-03,5.557300E-03,2.140400E-02,& + & 8.983400E-02,2.714100E-01,6.635300E-01,1.458400E+00,3.510400E+00,& + & 2.132700E+01,9.393200E+01,1.564400E+02,2.518500E+02,3.970500E+02,& + & 7.250100E+02,2.342900E+03,5.632500E+03,1.286400E-03,6.571200E-03,& + & 2.488800E-02,8.815400E-02,2.403900E-01,5.560800E-01,1.141900E+00,& + & 2.471800E+00,1.125000E+01,4.730800E+01,7.845400E+01,1.262100E+02,& + & 1.987700E+02,3.627200E+02,1.171600E+03,2.816300E+03,1.183000E-03,& + & 6.623400E-03,2.010200E-02,4.737000E-02,9.879200E-02,2.009200E-01,& + & 4.254900E-01,9.173400E-01,2.100100E+00,3.550200E+00,4.095600E+00,& + & 5.004600E+00,6.370900E+00,8.333900E+00,1.035100E+01,1.300400E+01,& + & 9.729100E-04,2.518000E-03,8.389100E-03,6.928200E-02,3.590300E-01,& + & 1.016000E+00,2.920800E+00,9.125300E+00,6.166200E+01,2.700700E+02,& + & 4.514900E+02,7.289700E+02,1.134500E+03,2.073400E+03,6.577700E+03,& + & 1.563800E+04,1.499000E-03,5.710800E-03,2.181100E-02,1.093900E-01,& + & 3.774300E-01,9.496300E-01,2.402800E+00,6.968100E+00,4.639000E+01,& + & 2.026900E+02,3.387300E+02,5.468700E+02,8.510200E+02,1.555100E+03,& + & 4.933300E+03,1.172900E+04,1.670000E-03,7.368200E-03,2.851300E-02,& + & 1.208200E-01,3.563800E-01,8.639200E-01,1.926400E+00,4.937800E+00,& + & 3.112300E+01,1.353300E+02,2.259700E+02,3.647600E+02,5.675100E+02,& + & 1.036900E+03,3.289000E+03,7.819100E+03,1.721500E-03,8.431100E-03,& + & 3.189800E-02,1.126400E-01,2.975400E-01,6.859000E-01,1.414800E+00,& + & 3.134000E+00,1.599100E+01,6.797000E+01,1.132200E+02,1.826600E+02,& + & 2.840000E+02,5.186300E+02,1.644700E+03,3.909600E+03,1.543400E-03,& + & 7.935200E-03,2.268900E-02,5.159700E-02,1.035900E-01,2.062100E-01,& + & 4.284500E-01,9.118100E-01,2.072100E+00,3.487400E+00,4.008900E+00,& + & 4.859000E+00,6.238800E+00,8.270500E+00,1.024500E+01,1.274500E+01,& + & 1.248700E-03,3.661400E-03,1.485700E-02,1.197300E-01,5.176100E-01,& + & 1.483600E+00,4.211100E+00,1.303500E+01,8.612500E+01,3.688900E+02,& + & 6.167200E+02,9.989300E+02,1.543600E+03,2.823800E+03,8.778000E+03,& + & 2.063200E+04,2.008900E-03,7.893800E-03,3.097500E-02,1.545600E-01,& + & 5.074600E-01,1.293700E+00,3.349100E+00,9.890000E+00,6.473300E+01,& + & 2.768100E+02,4.626500E+02,7.493300E+02,1.157800E+03,2.117900E+03,& + & 6.583500E+03,1.547400E+04,2.229600E-03,9.821600E-03,3.804600E-02,& + & 1.597300E-01,4.598100E-01,1.111200E+00,2.540100E+00,6.820800E+00,& + & 4.334500E+01,1.847300E+02,3.085800E+02,4.997200E+02,7.720300E+02,& + & 1.412100E+03,4.389100E+03,1.031600E+04,2.262400E-03,1.079200E-02,& + & 4.028800E-02,1.417900E-01,3.657500E-01,8.393400E-01,1.744700E+00,& + & 3.995700E+00,2.200400E+01,9.265400E+01,1.545200E+02,2.501300E+02,& + & 3.862700E+02,7.062300E+02,2.194700E+03,5.158000E+03,1.928900E-03,& + & 9.248000E-03,2.528900E-02,5.569800E-02,1.081600E-01,2.122800E-01,& + & 4.299700E-01,9.054600E-01,2.041900E+00,3.432300E+00,3.935000E+00,& + & 4.709500E+00,6.098600E+00,8.170300E+00,1.018900E+01,1.251100E+01/ + data absb(:, 41: 60) / & + & 1.688100E-03,5.653000E-03,2.587400E-02,1.914100E-01,7.196300E-01,& + & 2.085600E+00,5.821900E+00,1.796900E+01,1.155000E+02,4.838000E+02,& + & 8.057400E+02,1.310200E+03,2.013900E+03,3.684100E+03,1.125700E+04,& + & 2.615800E+04,2.716600E-03,1.100200E-02,4.388400E-02,2.131900E-01,& + & 6.699700E-01,1.736600E+00,4.536900E+00,1.358400E+01,8.675800E+01,& + & 3.629800E+02,6.044200E+02,9.827600E+02,1.510500E+03,2.763200E+03,& + & 8.442800E+03,1.961900E+04,2.963900E-03,1.307200E-02,5.068100E-02,& + & 2.075700E-01,5.843400E-01,1.414200E+00,3.313700E+00,9.232800E+00,& + & 5.802400E+01,2.421700E+02,4.030900E+02,6.553300E+02,1.007200E+03,& + & 1.842200E+03,5.628600E+03,1.307900E+04,2.924800E-03,1.374000E-02,& + & 5.052900E-02,1.756700E-01,4.455500E-01,1.018600E+00,2.137400E+00,& + & 5.103200E+00,2.930400E+01,1.213600E+02,2.017700E+02,3.279100E+02,& + & 5.038400E+02,9.213100E+02,2.814500E+03,6.539500E+03,2.320700E-03,& + & 1.051700E-02,2.796500E-02,5.950300E-02,1.127200E-01,2.179100E-01,& + & 4.323300E-01,8.976000E-01,2.009400E+00,3.376600E+00,3.866500E+00,& + & 4.576900E+00,5.946500E+00,8.038700E+00,1.010500E+01,1.251400E+01,& + & 2.352400E-03,8.861900E-03,4.325800E-02,2.841900E-01,9.767300E-01,& + & 2.840200E+00,7.780500E+00,2.402100E+01,1.497100E+02,6.138400E+02,& + & 1.014500E+03,1.655100E+03,2.541300E+03,4.645700E+03,1.396400E+04,& + & 3.216100E+04,3.680200E-03,1.529200E-02,6.160400E-02,2.868900E-01,& + & 8.708400E-01,2.292800E+00,5.989000E+00,1.811900E+01,1.124200E+02,& + & 4.605100E+02,7.609900E+02,1.241400E+03,1.906100E+03,3.484300E+03,& + & 1.047300E+04,2.412000E+04,3.908200E-03,1.733800E-02,6.680000E-02,& + & 2.653700E-01,7.335600E-01,1.781400E+00,4.258800E+00,1.222900E+01,& + & 7.512500E+01,3.071700E+02,5.074800E+02,8.277500E+02,1.270900E+03,& + & 2.323000E+03,6.982100E+03,1.608000E+04,3.726200E-03,1.734300E-02,& + & 6.322800E-02,2.142600E-01,5.388100E-01,1.227500E+00,2.595500E+00,& + & 6.513300E+00,3.783800E+01,1.538500E+02,2.539700E+02,4.141100E+02,& + & 6.356900E+02,1.161700E+03,3.491200E+03,8.040000E+03,2.700800E-03,& + & 1.173100E-02,3.056400E-02,6.316700E-02,1.173200E-01,2.233800E-01,& + & 4.347500E-01,8.892000E-01,1.978000E+00,3.302200E+00,3.775500E+00,& + & 4.463100E+00,5.789800E+00,7.889600E+00,9.992600E+00,1.257400E+01,& + & 4.317700E-04,1.026900E-03,2.778000E-03,2.156200E-02,1.311000E-01,& + & 3.753400E-01,1.095800E+00,3.474300E+00,2.432500E+01,1.132700E+02,& + & 1.975900E+02,3.363900E+02,5.394300E+02,9.977200E+02,3.285400E+03,& + & 8.662600E+03,7.425800E-04,3.031300E-03,1.182800E-02,5.538300E-02,& + & 1.810300E-01,4.573200E-01,1.067400E+00,2.806700E+00,1.839400E+01,& + & 8.510000E+01,1.483000E+02,2.524300E+02,4.047000E+02,7.483900E+02,& + & 2.464200E+03,6.497000E+03,8.965100E-04,4.325800E-03,1.707300E-02,& + & 6.768300E-02,1.928100E-01,4.675000E-01,1.013000E+00,2.343700E+00,& + & 1.257200E+01,5.694200E+01,9.901800E+01,1.684700E+02,2.699700E+02,& + & 4.990600E+02,1.642900E+03,4.331400E+03,1.001300E-03,5.382700E-03,& + & 2.049000E-02,6.858300E-02,1.826400E-01,4.091700E-01,8.496100E-01,& + & 1.899600E+00,7.197100E+00,2.882700E+01,4.973900E+01,8.450700E+01,& + & 1.352400E+02,2.497200E+02,8.216900E+02,2.165700E+03,1.009800E-03,& + & 5.708900E-03,1.737700E-02,4.140300E-02,8.658200E-02,1.787400E-01,& + & 3.873000E-01,8.715600E-01,2.155800E+00,3.872200E+00,4.571200E+00,& + & 5.452300E+00,7.050300E+00,9.424200E+00,1.190700E+01,1.504700E+01,& + & 5.202800E-04,1.376500E-03,4.759100E-03,3.972000E-02,1.981700E-01,& + & 5.702900E-01,1.653600E+00,5.188400E+00,3.558200E+01,1.619400E+02,& + & 2.823000E+02,4.828000E+02,7.727000E+02,1.427100E+03,4.588900E+03,& + & 1.194400E+04,9.864300E-04,4.104500E-03,1.636700E-02,7.697700E-02,& + & 2.441300E-01,6.139000E-01,1.469000E+00,4.050000E+00,2.683100E+01,& + & 1.216000E+02,2.118400E+02,3.622300E+02,5.796500E+02,1.070400E+03,& + & 3.441800E+03,8.899500E+03,1.201300E-03,5.687600E-03,2.238200E-02,& + & 8.882700E-02,2.468400E-01,5.954000E-01,1.304100E+00,3.112500E+00,& + & 1.811700E+01,8.126200E+01,1.413700E+02,2.416600E+02,3.866000E+02,& + & 7.137400E+02,2.294700E+03,5.972000E+03,1.335100E-03,6.851500E-03,& + & 2.590000E-02,8.580400E-02,2.217200E-01,4.973400E-01,1.029200E+00,& + & 2.297700E+00,9.757500E+00,4.094800E+01,7.090700E+01,1.210900E+02,& + & 1.935500E+02,3.570700E+02,1.147500E+03,2.986000E+03,1.308700E-03,& + & 6.808700E-03,1.961000E-02,4.510700E-02,9.092500E-02,1.840700E-01,& + & 3.910100E-01,8.678600E-01,2.130500E+00,3.815100E+00,4.481000E+00,& + & 5.313300E+00,6.877100E+00,9.312400E+00,1.184700E+01,1.480400E+01/ + data absb(:, 61: 80) / & + & 6.728900E-04,2.027300E-03,8.470700E-03,6.804900E-02,2.851900E-01,& + & 8.299400E-01,2.374500E+00,7.426300E+00,4.956700E+01,2.204700E+02,& + & 3.821900E+02,6.571900E+02,1.052000E+03,1.936400E+03,6.105600E+03,& + & 1.573000E+04,1.325800E-03,5.622700E-03,2.271500E-02,1.052200E-01,& + & 3.219800E-01,8.125800E-01,1.991400E+00,5.696400E+00,3.731800E+01,& + & 1.654900E+02,2.867500E+02,4.930200E+02,7.891300E+02,1.452400E+03,& + & 4.579300E+03,1.179800E+04,1.597800E-03,7.475900E-03,2.922600E-02,& + & 1.145800E-01,3.117800E-01,7.503800E-01,1.660300E+00,4.133000E+00,& + & 2.507800E+01,1.105100E+02,1.913200E+02,3.288400E+02,5.262600E+02,& + & 9.684100E+02,3.053000E+03,7.865100E+03,1.737500E-03,8.644900E-03,& + & 3.228700E-02,1.059200E-01,2.674200E-01,5.987000E-01,1.245200E+00,& + & 2.779500E+00,1.307100E+01,5.555200E+01,9.588100E+01,1.646600E+02,& + & 2.633800E+02,4.844000E+02,1.526700E+03,3.932600E+03,1.623300E-03,& + & 7.905100E-03,2.184900E-02,4.863600E-02,9.523100E-02,1.898200E-01,& + & 3.934400E-01,8.639400E-01,2.102900E+00,3.759700E+00,4.397300E+00,& + & 5.183400E+00,6.699700E+00,9.159000E+00,1.179600E+01,1.462100E+01,& + & 9.138900E-04,3.155300E-03,1.472600E-02,1.077900E-01,3.969300E-01,& + & 1.163500E+00,3.275000E+00,1.026100E+01,6.632700E+01,2.885300E+02,& + & 4.958600E+02,8.555000E+02,1.374300E+03,2.526800E+03,7.801100E+03,& + & 1.995300E+04,1.786300E-03,7.721400E-03,3.129400E-02,1.409600E-01,& + & 4.179700E-01,1.059300E+00,2.646800E+00,7.805900E+00,4.988500E+01,& + & 2.165300E+02,3.720100E+02,6.417500E+02,1.030800E+03,1.895200E+03,& + & 5.851000E+03,1.496500E+04,2.101300E-03,9.781000E-03,3.807400E-02,& + & 1.453200E-01,3.898700E-01,9.352900E-01,2.088700E+00,5.469900E+00,& + & 3.344500E+01,1.445300E+02,2.481600E+02,4.279900E+02,6.873800E+02,& + & 1.263600E+03,3.900800E+03,9.976800E+03,2.213800E-03,1.082800E-02,& + & 3.987000E-02,1.290600E-01,3.198200E-01,7.151200E-01,1.495100E+00,& + & 3.385800E+00,1.713500E+01,7.253800E+01,1.243000E+02,2.142300E+02,& + & 3.439400E+02,6.319800E+02,1.950600E+03,4.988500E+03,1.940200E-03,& + & 8.958300E-03,2.412700E-02,5.197200E-02,9.947000E-02,1.953800E-01,& + & 3.961300E-01,8.590800E-01,2.073300E+00,3.696700E+00,4.320700E+00,& + & 5.066000E+00,6.520100E+00,8.983700E+00,1.168200E+01,1.470400E+01,& + & 1.278300E-03,4.967800E-03,2.458200E-02,1.586500E-01,5.397900E-01,& + & 1.583400E+00,4.374900E+00,1.373600E+01,8.590900E+01,3.653100E+02,& + & 6.230100E+02,1.072800E+03,1.737100E+03,3.188800E+03,9.635200E+03,& + & 2.451000E+04,2.400500E-03,1.055700E-02,4.270000E-02,1.849700E-01,& + & 5.354600E-01,1.364900E+00,3.452600E+00,1.040500E+01,6.456900E+01,& + & 2.741100E+02,4.673800E+02,8.047200E+02,1.303000E+03,2.391700E+03,& + & 7.226500E+03,1.838200E+04,2.732200E-03,1.272500E-02,4.908700E-02,& + & 1.817500E-01,4.828300E-01,1.153700E+00,2.609200E+00,7.145900E+00,& + & 4.323100E+01,1.829100E+02,3.117400E+02,5.366300E+02,8.688100E+02,& + & 1.594600E+03,4.817800E+03,1.225500E+04,2.772200E-03,1.344700E-02,& + & 4.896200E-02,1.550100E-01,3.805800E-01,8.476300E-01,1.778000E+00,& + & 4.147500E+00,2.194900E+01,9.170800E+01,1.561000E+02,2.685400E+02,& + & 4.346400E+02,7.974800E+02,2.409100E+03,6.127600E+03,2.242200E-03,& + & 9.949900E-03,2.635700E-02,5.510200E-02,1.036700E-01,2.009200E-01,& + & 3.990000E-01,8.533700E-01,2.041500E+00,3.631300E+00,4.241900E+00,& + & 4.962300E+00,6.341000E+00,8.791300E+00,1.154800E+01,1.473800E+01,& + & 2.731500E-04,6.611000E-04,1.857500E-03,1.477200E-02,8.678000E-02,& + & 2.513900E-01,7.416500E-01,2.366800E+00,1.670200E+01,8.006500E+01,& + & 1.453400E+02,2.622900E+02,4.444900E+02,8.253500E+02,2.715600E+03,& + & 7.917700E+03,5.483000E-04,2.392500E-03,9.642800E-03,4.393200E-02,& + & 1.364100E-01,3.464000E-01,8.040500E-01,2.034800E+00,1.268800E+01,& + & 6.018900E+01,1.091200E+02,1.968400E+02,3.334900E+02,6.191000E+02,& + & 2.036800E+03,5.938300E+03,7.021800E-04,3.560700E-03,1.425800E-02,& + & 5.451300E-02,1.518600E-01,3.656000E-01,7.928300E-01,1.871600E+00,& + & 8.915600E+00,4.032800E+01,7.289900E+01,1.313900E+02,2.224900E+02,& + & 4.128600E+02,1.358000E+03,3.958900E+03,8.199700E-04,4.527200E-03,& + & 1.730800E-02,5.639100E-02,1.481800E-01,3.272300E-01,6.911400E-01,& + & 1.613500E+00,5.674500E+00,2.055200E+01,3.668700E+01,6.593500E+01,& + & 1.115000E+02,2.066200E+02,6.791800E+02,1.979500E+03,8.624000E-04,& + & 4.902500E-03,1.496700E-02,3.600900E-02,7.551400E-02,1.579600E-01,& + & 3.491100E-01,8.189400E-01,2.188400E+00,4.210900E+00,5.059900E+00,& + & 6.051200E+00,7.744800E+00,1.061700E+01,1.383300E+01,1.737900E+01/ + data absb(:, 81: 100) / & + & 3.324000E-04,8.991200E-04,3.229500E-03,2.713200E-02,1.304700E-01,& + & 3.803300E-01,1.113600E+00,3.537500E+00,2.434100E+01,1.140100E+02,& + & 2.054800E+02,3.730300E+02,6.351200E+02,1.176500E+03,3.773000E+03,& + & 1.090500E+04,7.335100E-04,3.239100E-03,1.322200E-02,5.997200E-02,& + & 1.811300E-01,4.584400E-01,1.078600E+00,2.856600E+00,1.840500E+01,& + & 8.563900E+01,1.542300E+02,2.798900E+02,4.764600E+02,8.825000E+02,& + & 2.829800E+03,8.179000E+03,9.411200E-04,4.653400E-03,1.853400E-02,& + & 7.055000E-02,1.913500E-01,4.596200E-01,1.009100E+00,2.391800E+00,& + & 1.260200E+01,5.727900E+01,1.029700E+02,1.867400E+02,3.178000E+02,& + & 5.884500E+02,1.886700E+03,5.452700E+03,1.087200E-03,5.737700E-03,& + & 2.171600E-02,6.970900E-02,1.783500E-01,3.934500E-01,8.286200E-01,& + & 1.917900E+00,7.294300E+00,2.897100E+01,5.171500E+01,9.360400E+01,& + & 1.591500E+02,2.944100E+02,9.435000E+02,2.726400E+03,1.109800E-03,& + & 5.826200E-03,1.689400E-02,3.916900E-02,7.953300E-02,1.632200E-01,& + & 3.531400E-01,8.179300E-01,2.165800E+00,4.150700E+00,4.973600E+00,& + & 5.912000E+00,7.548100E+00,1.044100E+01,1.378600E+01,1.708700E+01,& + & 4.331400E-04,1.341900E-03,5.762200E-03,4.604900E-02,1.875300E-01,& + & 5.513500E-01,1.592300E+00,5.073800E+00,3.381200E+01,1.547200E+02,& + & 2.763700E+02,5.029700E+02,8.625700E+02,1.598800E+03,4.994200E+03,& + & 1.433600E+04,9.858400E-04,4.409100E-03,1.813400E-02,8.044400E-02,& + & 2.363900E-01,5.973100E-01,1.424200E+00,3.964100E+00,2.550400E+01,& + & 1.161700E+02,2.073900E+02,3.773300E+02,6.470500E+02,1.199200E+03,& + & 3.745700E+03,1.075200E+04,1.245700E-03,6.065100E-03,2.395200E-02,& + & 8.976900E-02,2.387500E-01,5.723400E-01,1.268100E+00,3.073800E+00,& + & 1.725300E+01,7.761900E+01,1.384100E+02,2.517000E+02,4.315200E+02,& + & 7.995600E+02,2.497300E+03,7.168000E+03,1.403400E-03,7.182100E-03,& + & 2.689500E-02,8.512500E-02,2.130400E-01,4.689600E-01,9.914300E-01,& + & 2.279900E+00,9.414300E+00,3.909900E+01,6.943900E+01,1.260700E+02,& + & 2.160000E+02,3.999500E+02,1.248800E+03,3.584000E+03,1.366400E-03,& + & 6.730800E-03,1.884400E-02,4.220900E-02,8.348100E-02,1.689000E-01,& + & 3.563600E-01,8.157400E-01,2.141800E+00,4.090600E+00,4.888200E+00,& + & 5.787200E+00,7.345700E+00,1.024000E+01,1.368200E+01,1.707900E+01,& + & 5.909200E-04,2.106500E-03,1.001400E-02,7.221300E-02,2.614000E-01,& + & 7.717800E-01,2.192600E+00,7.014700E+00,4.518500E+01,2.019700E+02,& + & 3.578900E+02,6.491100E+02,1.124900E+03,2.085300E+03,6.360700E+03,& + & 1.813400E+04,1.322900E-03,5.997000E-03,2.462800E-02,1.058800E-01,& + & 3.042800E-01,7.669900E-01,1.856600E+00,5.388800E+00,3.403100E+01,& + & 1.516000E+02,2.685400E+02,4.869400E+02,8.437600E+02,1.564000E+03,& + & 4.770600E+03,1.360000E+04,1.622300E-03,7.856600E-03,3.079000E-02,& + & 1.124500E-01,2.955100E-01,7.050400E-01,1.571200E+00,3.956400E+00,& + & 2.289400E+01,1.012300E+02,1.791800E+02,3.247700E+02,5.626500E+02,& + & 1.042800E+03,3.180500E+03,9.067000E+03,1.768400E-03,8.913800E-03,& + & 3.297500E-02,1.027100E-01,2.525600E-01,5.555700E-01,1.177100E+00,& + & 2.711500E+00,1.206300E+01,5.087800E+01,8.982700E+01,1.626000E+02,& + & 2.815500E+02,5.216000E+02,1.590400E+03,4.533500E+03,1.621100E-03,& + & 7.593600E-03,2.079200E-02,4.509700E-02,8.729300E-02,1.744600E-01,& + & 3.601300E-01,8.129100E-01,2.114900E+00,4.025200E+00,4.805200E+00,& + & 5.667900E+00,7.147200E+00,1.002200E+01,1.353300E+01,1.716200E+01,& + & 8.287800E-04,3.325400E-03,1.665100E-02,1.053400E-01,3.557400E-01,& + & 1.050500E+00,2.928500E+00,9.382900E+00,5.850200E+01,2.549200E+02,& + & 4.490700E+02,8.098600E+02,1.418500E+03,2.626000E+03,7.851400E+03,& + & 2.220600E+04,1.764200E-03,8.114500E-03,3.307200E-02,1.369300E-01,& + & 3.865200E-01,9.733200E-01,2.390100E+00,7.145800E+00,4.401600E+01,& + & 1.913000E+02,3.369200E+02,6.075000E+02,1.064000E+03,1.969600E+03,& + & 5.888600E+03,1.665500E+04,2.087800E-03,1.011100E-02,3.920200E-02,& + & 1.391000E-01,3.626700E-01,8.603500E-01,1.927900E+00,5.057100E+00,& + & 2.953600E+01,1.276900E+02,2.247700E+02,4.051500E+02,7.094600E+02,& + & 1.313200E+03,3.925900E+03,1.110300E+04,2.189000E-03,1.096300E-02,& + & 4.010000E-02,1.223900E-01,2.979300E-01,6.529600E-01,1.385900E+00,& + & 3.225800E+00,1.525300E+01,6.409500E+01,1.126200E+02,2.027900E+02,& + & 3.549400E+02,6.567900E+02,1.963100E+03,5.551700E+03,1.864700E-03,& + & 8.402100E-03,2.265100E-02,4.783300E-02,9.109400E-02,1.799800E-01,& + & 3.639900E-01,8.094300E-01,2.086300E+00,3.953200E+00,4.715300E+00,& + & 5.554700E+00,6.962200E+00,9.785300E+00,1.337700E+01,1.719300E+01/ + data absb(:, 101: 120) / & + & 1.796500E-04,4.424200E-04,1.291300E-03,1.050500E-02,5.940000E-02,& + & 1.739100E-01,5.188700E-01,1.673800E+00,1.182400E+01,5.796800E+01,& + & 1.082300E+02,2.070500E+02,3.772500E+02,7.144600E+02,2.307500E+03,& + & 7.517800E+03,4.180100E-04,1.927300E-03,7.946900E-03,3.519500E-02,& + & 1.054400E-01,2.683000E-01,6.247600E-01,1.570900E+00,9.072900E+00,& + & 4.360900E+01,8.128800E+01,1.554000E+02,2.830500E+02,5.359300E+02,& + & 1.730700E+03,5.638400E+03,5.615500E-04,2.958400E-03,1.192700E-02,& + & 4.427800E-02,1.217500E-01,2.893500E-01,6.372400E-01,1.551200E+00,& + & 6.696800E+00,2.927700E+01,5.434400E+01,1.037500E+02,1.888600E+02,& + & 3.574000E+02,1.153900E+03,3.758900E+03,6.775600E-04,3.816900E-03,& + & 1.461200E-02,4.667700E-02,1.214000E-01,2.653500E-01,5.708300E-01,& + & 1.391500E+00,4.830400E+00,1.522300E+01,2.741200E+01,5.210600E+01,& + & 9.466700E+01,1.788800E+02,5.771100E+02,1.879500E+03,7.336200E-04,& + & 4.191000E-03,1.283200E-02,3.109100E-02,6.557100E-02,1.387100E-01,& + & 3.116700E-01,7.616300E-01,2.196800E+00,4.528700E+00,5.564500E+00,& + & 6.773000E+00,8.515300E+00,1.190200E+01,1.612600E+01,1.994800E+01,& + & 2.205800E-04,6.099300E-04,2.274100E-03,1.916600E-02,8.898200E-02,& + & 2.619600E-01,7.748600E-01,2.507100E+00,1.717200E+01,8.219000E+01,& + & 1.520000E+02,2.913500E+02,5.357900E+02,1.017000E+03,3.195600E+03,& + & 1.031100E+04,5.612100E-04,2.601900E-03,1.081600E-02,4.733500E-02,& + & 1.382400E-01,3.509100E-01,8.269300E-01,2.142300E+00,1.304500E+01,& + & 6.176500E+01,1.141200E+02,2.186200E+02,4.019500E+02,7.628100E+02,& + & 2.396700E+03,7.733500E+03,7.506400E-04,3.841500E-03,1.542400E-02,& + & 5.663200E-02,1.517500E-01,3.608900E-01,8.014300E-01,1.946600E+00,& + & 9.182800E+00,4.135400E+01,7.623300E+01,1.458900E+02,2.681200E+02,& + & 5.086600E+02,1.597900E+03,5.155700E+03,8.925400E-04,4.811200E-03,& + & 1.821100E-02,5.716200E-02,1.449100E-01,3.164700E-01,6.785400E-01,& + & 1.633100E+00,5.893800E+00,2.104900E+01,3.835500E+01,7.316300E+01,& + & 1.342800E+02,2.545000E+02,7.991100E+02,2.577900E+03,9.368100E-04,& + & 4.957900E-03,1.448400E-02,3.380200E-02,6.919700E-02,1.438800E-01,& + & 3.162100E-01,7.619400E-01,2.178400E+00,4.471300E+00,5.474800E+00,& + & 6.633300E+00,8.295900E+00,1.167800E+01,1.602900E+01,1.979600E+01,& + & 2.893900E-04,9.222100E-04,4.065900E-03,3.224200E-02,1.278800E-01,& + & 3.788800E-01,1.104500E+00,3.597300E+00,2.381500E+01,1.111600E+02,& + & 2.040300E+02,3.891600E+02,7.243200E+02,1.378200E+03,4.224100E+03,& + & 1.349800E+04,7.525700E-04,3.518400E-03,1.466100E-02,6.259400E-02,& + & 1.789000E-01,4.518800E-01,1.074600E+00,2.904400E+00,1.801300E+01,& + & 8.348100E+01,1.531400E+02,2.919700E+02,5.433400E+02,1.033800E+03,& + & 3.168100E+03,1.012400E+04,9.859700E-04,4.966900E-03,1.979900E-02,& + & 7.131900E-02,1.875500E-01,4.452200E-01,9.964900E-01,2.437600E+00,& + & 1.237000E+01,5.581600E+01,1.022500E+02,1.947900E+02,3.623700E+02,& + & 6.892900E+02,2.112200E+03,6.748800E+03,1.141900E-03,5.981100E-03,& + & 2.244100E-02,6.920800E-02,1.718500E-01,3.742000E-01,8.044900E-01,& + & 1.920000E+00,7.283000E+00,2.821600E+01,5.136400E+01,9.760300E+01,& + & 1.814000E+02,3.448200E+02,1.056200E+03,3.374600E+03,1.145200E-03,& + & 5.698100E-03,1.615800E-02,3.640700E-02,7.270800E-02,1.495000E-01,& + & 3.201400E-01,7.617600E-01,2.158000E+00,4.407900E+00,5.385900E+00,& + & 6.498900E+00,8.079000E+00,1.143400E+01,1.586300E+01,1.985800E+01,& + & 3.963900E-04,1.457200E-03,7.057500E-03,4.996100E-02,1.783500E-01,& + & 5.304100E-01,1.518000E+00,4.965300E+00,3.182900E+01,1.444700E+02,& + & 2.636100E+02,4.997600E+02,9.409500E+02,1.791300E+03,5.382100E+03,& + & 1.699600E+04,1.003700E-03,4.746100E-03,1.966800E-02,8.134100E-02,& + & 2.285600E-01,5.747000E-01,1.374200E+00,3.887100E+00,2.401800E+01,& + & 1.084600E+02,1.978200E+02,3.749200E+02,7.058200E+02,1.343600E+03,& + & 4.036600E+03,1.274700E+04,1.271800E-03,6.375100E-03,2.520500E-02,& + & 8.847000E-02,2.302400E-01,5.437900E-01,1.223100E+00,3.049900E+00,& + & 1.628700E+01,7.245900E+01,1.320400E+02,2.500900E+02,4.706800E+02,& + & 8.958500E+02,2.691200E+03,8.497800E+03,1.425600E-03,7.358100E-03,& + & 2.737200E-02,8.281000E-02,2.024100E-01,4.394900E-01,9.468600E-01,& + & 2.259100E+00,9.040000E+00,3.649500E+01,6.625500E+01,1.252500E+02,& + & 2.355500E+02,4.481000E+02,1.345700E+03,4.248900E+03,1.351400E-03,& + & 6.396300E-03,1.778400E-02,3.889300E-02,7.616100E-02,1.549700E-01,& + & 3.246100E-01,7.611200E-01,2.135200E+00,4.333900E+00,5.293100E+00,& + & 6.368700E+00,7.878200E+00,1.116000E+01,1.568500E+01,1.994400E+01/ + data absb(:, 121: 140) / & + & 5.567800E-04,2.303600E-03,1.170100E-02,7.240400E-02,2.429700E-01,& + & 7.225400E-01,2.025700E+00,6.620000E+00,4.129800E+01,1.816800E+02,& + & 3.300900E+02,6.223000E+02,1.180000E+03,2.253100E+03,6.646500E+03,& + & 2.072600E+04,1.326300E-03,6.358100E-03,2.612400E-02,1.040000E-01,& + & 2.883400E-01,7.234400E-01,1.738600E+00,5.097200E+00,3.111700E+01,& + & 1.363700E+02,2.476800E+02,4.668300E+02,8.851000E+02,1.689900E+03,& + & 4.985000E+03,1.554400E+04,1.620900E-03,8.128100E-03,3.175500E-02,& + & 1.086200E-01,2.804300E-01,6.584900E-01,1.485800E+00,3.796100E+00,& + & 2.097000E+01,9.106000E+01,1.652800E+02,3.113600E+02,5.902000E+02,& + & 1.126700E+03,3.323400E+03,1.036300E+04,1.748000E-03,8.973700E-03,& + & 3.302500E-02,9.808400E-02,2.372200E-01,5.128500E-01,1.106900E+00,& + & 2.651100E+00,1.119300E+01,4.578100E+01,8.286700E+01,1.558900E+02,& + & 2.953100E+02,5.635400E+02,1.661800E+03,5.181500E+03,1.547900E-03,& + & 7.037800E-03,1.931200E-02,4.127300E-02,7.960300E-02,1.601800E-01,& + & 3.295500E-01,7.600100E-01,2.110000E+00,4.259200E+00,5.196100E+00,& + & 6.235800E+00,7.688900E+00,1.087200E+01,1.549600E+01,1.995600E+01,& + & 1.214400E-04,3.038800E-04,9.249000E-04,7.656200E-03,4.165100E-02,& + & 1.231000E-01,3.709700E-01,1.215900E+00,8.558200E+00,4.261200E+01,& + & 8.123200E+01,1.633300E+02,3.227700E+02,6.362700E+02,2.011900E+03,& + & 7.288900E+03,3.255600E-04,1.570700E-03,6.592400E-03,2.833300E-02,& + & 8.291100E-02,2.105300E-01,4.943200E-01,1.268200E+00,6.696000E+00,& + & 3.208100E+01,6.103600E+01,1.226100E+02,2.421800E+02,4.772800E+02,& + & 1.509000E+03,5.466700E+03,4.546500E-04,2.465600E-03,1.000000E-02,& + & 3.612100E-02,9.845500E-02,2.315200E-01,5.184000E-01,1.305500E+00,& + & 5.323200E+00,2.161200E+01,4.084300E+01,8.188800E+01,1.615900E+02,& + & 3.183000E+02,1.006100E+03,3.644500E+03,5.622400E-04,3.215800E-03,& + & 1.232700E-02,3.883500E-02,9.959300E-02,2.171300E-01,4.750400E-01,& + & 1.211400E+00,4.287000E+00,1.227100E+01,2.076800E+01,4.117800E+01,& + & 8.100200E+01,1.593200E+02,5.031800E+02,1.822300E+03,6.215700E-04,& + & 3.565200E-03,1.095400E-02,2.668600E-02,5.666200E-02,1.211200E-01,& + & 2.761400E-01,6.997200E-01,2.181900E+00,4.807100E+00,6.068800E+00,& + & 7.542400E+00,9.461100E+00,1.330600E+01,1.866800E+01,2.325900E+01,& + & 1.503600E-04,4.251300E-04,1.645000E-03,1.386700E-02,6.225100E-02,& + & 1.849700E-01,5.511500E-01,1.821500E+00,1.240200E+01,6.014700E+01,& + & 1.138000E+02,2.275900E+02,4.553500E+02,9.027900E+02,2.781500E+03,& + & 9.935300E+03,4.371000E-04,2.110900E-03,8.902400E-03,3.767600E-02,& + & 1.076500E-01,2.723200E-01,6.471200E-01,1.684600E+00,9.512500E+00,& + & 4.522300E+01,8.546600E+01,1.708000E+02,3.416100E+02,6.771800E+02,& + & 2.086200E+03,7.451500E+03,6.049900E-04,3.184000E-03,1.287600E-02,& + & 4.576500E-02,1.217300E-01,2.864800E-01,6.451400E-01,1.620700E+00,& + & 7.029000E+00,3.032900E+01,5.712900E+01,1.140100E+02,2.278700E+02,& + & 4.515700E+02,1.390900E+03,4.967700E+03,7.353000E-04,4.030200E-03,& + & 1.527900E-02,4.714700E-02,1.184300E-01,2.568400E-01,5.607200E-01,& + & 1.407400E+00,5.051900E+00,1.593400E+01,2.880200E+01,5.722600E+01,& + & 1.141300E+02,2.259600E+02,6.955700E+02,2.483900E+03,7.876300E-04,& + & 4.195000E-03,1.236200E-02,2.901300E-02,5.983100E-02,1.263500E-01,& + & 2.808400E-01,7.017200E-01,2.168000E+00,4.749900E+00,5.971900E+00,& + & 7.408400E+00,9.218700E+00,1.302100E+01,1.850500E+01,2.321400E+01,& + & 1.985500E-04,6.499300E-04,2.947600E-03,2.308600E-02,8.941900E-02,& + & 2.672700E-01,7.829600E-01,2.606300E+00,1.720000E+01,8.094100E+01,& + & 1.522500E+02,3.024400E+02,6.124800E+02,1.217600E+03,3.679400E+03,& + & 1.292800E+04,5.836500E-04,2.837200E-03,1.193800E-02,4.927400E-02,& + & 1.382800E-01,3.479800E-01,8.322500E-01,2.225000E+00,1.307100E+01,& + & 6.081200E+01,1.143000E+02,2.269300E+02,4.594500E+02,9.132600E+02,& + & 2.759600E+03,9.695600E+03,7.879100E-04,4.081500E-03,1.643200E-02,& + & 5.714300E-02,1.494400E-01,3.504500E-01,7.944700E-01,2.005900E+00,& + & 9.238900E+00,4.070200E+01,7.634900E+01,1.514300E+02,3.064300E+02,& + & 6.089600E+02,1.839800E+03,6.463800E+03,9.332500E-04,4.977200E-03,& + & 1.872700E-02,5.666100E-02,1.397000E-01,3.015400E-01,6.595400E-01,& + & 1.640700E+00,6.010100E+00,2.076100E+01,3.840400E+01,7.593100E+01,& + & 1.534000E+02,3.046600E+02,9.200500E+02,3.231900E+03,9.574500E-04,& + & 4.796000E-03,1.377100E-02,3.123100E-02,6.292300E-02,1.316700E-01,& + & 2.857100E-01,7.034900E-01,2.151700E+00,4.679700E+00,5.878000E+00,& + & 7.266900E+00,8.992500E+00,1.270500E+01,1.834300E+01,2.311600E+01/ + data absb(:, 141: 160) / & + & 2.728800E-04,1.031500E-03,5.105000E-03,3.535000E-02,1.247000E-01,& + & 3.744200E-01,1.073800E+00,3.586400E+00,2.303200E+01,1.047300E+02,& + & 1.962400E+02,3.875800E+02,7.903900E+02,1.579300E+03,4.688400E+03,& + & 1.618900E+04,7.725300E-04,3.795300E-03,1.585200E-02,6.341200E-02,& + & 1.754100E-01,4.395800E-01,1.053500E+00,2.908300E+00,1.742800E+01,& + & 7.865200E+01,1.472900E+02,2.907900E+02,5.928800E+02,1.184600E+03,& + & 3.516400E+03,1.214200E+04,1.007900E-03,5.194900E-03,2.074700E-02,& + & 7.037900E-02,1.821600E-01,4.252200E-01,9.677900E-01,2.460300E+00,& + & 1.201400E+01,5.258600E+01,9.834000E+01,1.940000E+02,3.953800E+02,& + & 7.898300E+02,2.344300E+03,8.094400E+03,1.156300E-03,6.077800E-03,& + & 2.270200E-02,6.736300E-02,1.637200E-01,3.518500E-01,7.708800E-01,& + & 1.913700E+00,7.208600E+00,2.660000E+01,4.939400E+01,9.721600E+01,& + & 1.978700E+02,3.950900E+02,1.172300E+03,4.047200E+03,1.124700E-03,& + & 5.351800E-03,1.510800E-02,3.336700E-02,6.607700E-02,1.367000E-01,& + & 2.911200E-01,7.044000E-01,2.133400E+00,4.608000E+00,5.778700E+00,& + & 7.120800E+00,8.782400E+00,1.237400E+01,1.814000E+01,2.310600E+01,& + & 3.834800E-04,1.633100E-03,8.440700E-03,5.097400E-02,1.699200E-01,& + & 5.099400E-01,1.433500E+00,4.770100E+00,2.995900E+01,1.314300E+02,& + & 2.449300E+02,4.826900E+02,9.866400E+02,1.982100E+03,5.790800E+03,& + & 1.964000E+04,1.012800E-03,5.037100E-03,2.087700E-02,8.025300E-02,& + & 2.198600E-01,5.498900E-01,1.317000E+00,3.750300E+00,2.261800E+01,& + & 9.867700E+01,1.838100E+02,3.621200E+02,7.400700E+02,1.486700E+03,& + & 4.343200E+03,1.473000E+04,1.272400E-03,6.570700E-03,2.590500E-02,& + & 8.577500E-02,2.204700E-01,5.117400E-01,1.166400E+00,2.993600E+00,& + & 1.538500E+01,6.593000E+01,1.226800E+02,2.415500E+02,4.935100E+02,& + & 9.912500E+02,2.895500E+03,9.820100E+03,1.406800E-03,7.346500E-03,& + & 2.722000E-02,7.928400E-02,1.909500E-01,4.083200E-01,8.959500E-01,& + & 2.222600E+00,8.696500E+00,3.323200E+01,6.156100E+01,1.209800E+02,& + & 2.469400E+02,4.958000E+02,1.447900E+03,4.910100E+03,1.283800E-03,& + & 5.858600E-03,1.635300E-02,3.538000E-02,6.921200E-02,1.412500E-01,& + & 2.970300E-01,7.055900E-01,2.112200E+00,4.535300E+00,5.670900E+00,& + & 6.972000E+00,8.583200E+00,1.203800E+01,1.790100E+01,2.304500E+01,& + & 8.090800E-05,2.054700E-04,6.530600E-04,5.480300E-03,2.871700E-02,& + & 8.553200E-02,2.598500E-01,8.689600E-01,6.087600E+00,3.044800E+01,& + & 5.930100E+01,1.238200E+02,2.661700E+02,5.570100E+02,1.728100E+03,& + & 6.889200E+03,2.535500E-04,1.276300E-03,5.427600E-03,2.251400E-02,& + & 6.474200E-02,1.631400E-01,3.865100E-01,1.021800E+00,4.958900E+00,& + & 2.295100E+01,4.458500E+01,9.297700E+01,1.997200E+02,4.178400E+02,& + & 1.296200E+03,5.166900E+03,3.678000E-04,2.045800E-03,8.322800E-03,& + & 2.920800E-02,7.881900E-02,1.836700E-01,4.160200E-01,1.091700E+00,& + & 4.361700E+00,1.562000E+01,2.987500E+01,6.213600E+01,1.332600E+02,& + & 2.786800E+02,8.641800E+02,3.444600E+03,4.653400E-04,2.695900E-03,& + & 1.032100E-02,3.209900E-02,8.089500E-02,1.763600E-01,3.930800E-01,& + & 1.043100E+00,3.853700E+00,1.016800E+01,1.623800E+01,3.132500E+01,& + & 6.681200E+01,1.395100E+02,4.322200E+02,1.722300E+03,5.242000E-04,& + & 3.017600E-03,9.306400E-03,2.278900E-02,4.866400E-02,1.053200E-01,& + & 2.430700E-01,6.357100E-01,2.142600E+00,5.035000E+00,6.538500E+00,& + & 8.359700E+00,1.058100E+01,1.483500E+01,2.149600E+01,2.731200E+01,& + & 1.009700E-04,2.916900E-04,1.172000E-03,9.831700E-03,4.284900E-02,& + & 1.282800E-01,3.842200E-01,1.297100E+00,8.817800E+00,4.274100E+01,& + & 8.271700E+01,1.715400E+02,3.731600E+02,7.855500E+02,2.390300E+03,& + & 9.321000E+03,3.396300E-04,1.704400E-03,7.265900E-03,2.961400E-02,& + & 8.324400E-02,2.089300E-01,5.006700E-01,1.334800E+00,6.901900E+00,& + & 3.216200E+01,6.214500E+01,1.287700E+02,2.799600E+02,5.892400E+02,& + & 1.792800E+03,6.990800E+03,4.863700E-04,2.623100E-03,1.065900E-02,& + & 3.665000E-02,9.681500E-02,2.248400E-01,5.127500E-01,1.339000E+00,& + & 5.512000E+00,2.165800E+01,4.157500E+01,8.599400E+01,1.867500E+02,& + & 3.929400E+02,1.195300E+03,4.660500E+03,6.040800E-04,3.355000E-03,& + & 1.271900E-02,3.863200E-02,9.575100E-02,2.070500E-01,4.596800E-01,& + & 1.202200E+00,4.414800E+00,1.257600E+01,2.133500E+01,4.323300E+01,& + & 9.354900E+01,1.966500E+02,5.977700E+02,2.330300E+03,6.599700E-04,& + & 3.531300E-03,1.049000E-02,2.475700E-02,5.143300E-02,1.103200E-01,& + & 2.480900E-01,6.391500E-01,2.134100E+00,4.971200E+00,6.450900E+00,& + & 8.206100E+00,1.033400E+01,1.447100E+01,2.131100E+01,2.719900E+01/ + data absb(:, 161: 180) / & + & 1.340300E-04,4.498700E-04,2.101000E-03,1.618400E-02,6.145400E-02,& + & 1.854300E-01,5.442000E-01,1.850000E+00,1.224700E+01,5.723900E+01,& + & 1.103100E+02,2.274800E+02,4.981100E+02,1.056500E+03,3.161500E+03,& + & 1.205000E+04,4.506400E-04,2.272100E-03,9.645200E-03,3.831200E-02,& + & 1.060500E-01,2.647400E-01,6.376400E-01,1.719000E+00,9.406500E+00,& + & 4.302900E+01,8.283700E+01,1.707200E+02,3.736600E+02,7.924600E+02,& + & 2.371200E+03,9.037500E+03,6.280600E-04,3.332200E-03,1.350100E-02,& + & 4.536500E-02,1.180100E-01,2.726800E-01,6.261700E-01,1.636700E+00,& + & 7.019400E+00,2.885700E+01,5.536600E+01,1.139600E+02,2.492200E+02,& + & 5.284200E+02,1.580900E+03,6.025000E+03,7.612600E-04,4.111300E-03,& + & 1.548500E-02,4.608100E-02,1.124800E-01,2.414800E-01,5.358600E-01,& + & 1.390400E+00,5.097700E+00,1.556100E+01,2.794800E+01,5.720600E+01,& + & 1.247800E+02,2.643800E+02,7.905500E+02,3.012500E+03,7.985400E-04,& + & 4.012100E-03,1.165600E-02,2.663400E-02,5.421500E-02,1.151200E-01,& + & 2.535800E-01,6.426500E-01,2.122600E+00,4.906000E+00,6.352200E+00,& + & 8.051300E+00,1.009700E+01,1.408800E+01,2.110600E+01,2.698000E+01,& + & 1.847100E-04,7.165300E-04,3.629800E-03,2.452900E-02,8.569900E-02,& + & 2.598400E-01,7.460300E-01,2.537700E+00,1.643500E+01,7.399000E+01,& + & 1.416700E+02,2.913800E+02,6.394100E+02,1.366600E+03,4.022200E+03,& + & 1.504600E+04,5.918800E-04,3.009000E-03,1.268200E-02,4.877600E-02,& + & 1.335600E-01,3.323800E-01,7.998100E-01,2.191800E+00,1.250800E+01,& + & 5.559500E+01,1.063500E+02,2.186400E+02,4.796400E+02,1.025100E+03,& + & 3.016700E+03,1.128400E+04,7.963700E-04,4.201300E-03,1.689000E-02,& + & 5.544000E-02,1.429200E-01,3.285200E-01,7.567100E-01,1.984500E+00,& + & 8.928500E+00,3.722700E+01,7.104100E+01,1.459000E+02,3.198700E+02,& + & 6.834800E+02,2.011200E+03,7.522800E+03,9.358700E-04,4.975000E-03,& + & 1.863000E-02,5.445100E-02,1.311500E-01,2.800100E-01,6.219800E-01,& + & 1.606700E+00,5.934600E+00,1.926300E+01,3.573700E+01,7.316700E+01,& + & 1.601100E+02,3.419100E+02,1.005700E+03,3.761400E+03,9.343600E-04,& + & 4.453200E-03,1.274400E-02,2.843400E-02,5.703100E-02,1.195200E-01,& + & 2.599800E-01,6.452300E-01,2.108400E+00,4.846200E+00,6.239200E+00,& + & 7.899400E+00,9.865700E+00,1.370000E+01,2.084900E+01,2.678600E+01,& + & 2.597000E-04,1.135800E-03,5.973300E-03,3.523300E-02,1.168100E-01,& + & 3.532000E-01,9.970800E-01,3.369400E+00,2.139500E+01,9.328300E+01,& + & 1.763000E+02,3.625300E+02,7.955400E+02,1.709700E+03,4.962100E+03,& + & 1.824100E+04,7.693500E-04,3.952000E-03,1.653300E-02,6.123100E-02,& + & 1.662200E-01,4.129500E-01,9.923600E-01,2.769500E+00,1.620600E+01,& + & 7.006200E+01,1.323200E+02,2.720000E+02,5.967400E+02,1.282400E+03,& + & 3.721600E+03,1.368100E+04,9.960500E-04,5.256700E-03,2.089400E-02,& + & 6.710700E-02,1.718200E-01,3.931700E-01,9.061700E-01,2.384800E+00,& + & 1.126000E+01,4.685900E+01,8.834900E+01,1.814700E+02,3.979400E+02,& + & 8.550400E+02,2.481100E+03,9.120500E+03,1.130100E-03,5.954200E-03,& + & 2.216000E-02,6.377900E-02,1.520400E-01,3.233300E-01,7.182900E-01,& + & 1.847800E+00,6.950700E+00,2.382000E+01,4.437800E+01,9.093900E+01,& + & 1.991500E+02,4.276900E+02,1.240700E+03,4.560300E+03,1.063100E-03,& + & 4.857200E-03,1.372500E-02,3.010500E-02,5.979000E-02,1.236600E-01,& + & 2.661500E-01,6.496200E-01,2.090600E+00,4.782600E+00,6.119100E+00,& + & 7.745200E+00,9.631900E+00,1.333000E+01,2.053100E+01,2.659500E+01,& + & 5.865100E-05,1.517400E-04,5.052500E-04,4.282800E-03,2.163200E-02,& + & 6.479600E-02,1.976000E-01,6.759300E-01,4.733800E+00,2.349400E+01,& + & 4.667500E+01,1.004200E+02,2.344600E+02,5.290200E+02,1.623500E+03,& + & 7.009400E+03,2.053300E-04,1.064200E-03,4.578600E-03,1.855500E-02,& + & 5.294300E-02,1.325400E-01,3.183600E-01,8.705200E-01,4.061800E+00,& + & 1.774200E+01,3.511100E+01,7.543000E+01,1.759200E+02,3.968500E+02,& + & 1.217700E+03,5.257000E+03,3.046800E-04,1.720000E-03,7.041600E-03,& + & 2.427700E-02,6.523500E-02,1.512000E-01,3.477000E-01,9.506600E-01,& + & 3.867300E+00,1.264500E+01,2.357500E+01,5.044400E+01,1.173800E+02,& + & 2.646800E+02,8.118800E+02,3.504700E+03,3.899100E-04,2.276100E-03,& + & 8.729000E-03,2.699500E-02,6.736300E-02,1.473000E-01,3.347700E-01,& + & 9.195000E-01,3.584700E+00,9.365700E+00,1.426600E+01,2.589100E+01,& + & 5.884900E+01,1.325100E+02,4.060600E+02,1.752400E+03,4.429900E-04,& + & 2.551400E-03,7.888500E-03,1.940600E-02,4.161000E-02,9.134100E-02,& + & 2.127700E-01,5.715400E-01,2.081200E+00,5.197400E+00,6.962000E+00,& + & 9.167500E+00,1.188200E+01,1.646100E+01,2.473500E+01,3.200900E+01/ + data absb(:, 181: 200) / & + & 7.385800E-05,2.184600E-04,9.139100E-04,7.593100E-03,3.216300E-02,& + & 9.699000E-02,2.909500E-01,1.003700E+00,6.857100E+00,3.276700E+01,& + & 6.478700E+01,1.386100E+02,3.256500E+02,7.422100E+02,2.238700E+03,& + & 9.436400E+03,2.742500E-04,1.415300E-03,6.101800E-03,2.423600E-02,& + & 6.769600E-02,1.688500E-01,4.092500E-01,1.126500E+00,5.533400E+00,& + & 2.467900E+01,4.869200E+01,1.040700E+02,2.443100E+02,5.567400E+02,& + & 1.679100E+03,7.077300E+03,4.005600E-04,2.194200E-03,8.980400E-03,& + & 3.029000E-02,7.985200E-02,1.840000E-01,4.259200E-01,1.158800E+00,& + & 4.758200E+00,1.683600E+01,3.260300E+01,6.953200E+01,1.629800E+02,& + & 3.712800E+02,1.119500E+03,4.718200E+03,5.032500E-04,2.816500E-03,& + & 1.071700E-02,3.234700E-02,7.944700E-02,1.723900E-01,3.893700E-01,& + & 1.057200E+00,4.068500E+00,1.093000E+01,1.783300E+01,3.503100E+01,& + & 8.164000E+01,1.858100E+02,5.598400E+02,2.359100E+03,5.543900E-04,& + & 2.965000E-03,8.876800E-03,2.105000E-02,4.406200E-02,9.579600E-02,& + & 2.182700E-01,5.767000E-01,2.076500E+00,5.146800E+00,6.873800E+00,& + & 9.003000E+00,1.161900E+01,1.602800E+01,2.447500E+01,3.178800E+01,& + & 9.855800E-05,3.398200E-04,1.637100E-03,1.233000E-02,4.605700E-02,& + & 1.401700E-01,4.112700E-01,1.425600E+00,9.533600E+00,4.380500E+01,& + & 8.596500E+01,1.835100E+02,4.316200E+02,9.941300E+02,2.948800E+03,& + & 1.217300E+04,3.620100E-04,1.874500E-03,8.052500E-03,3.112300E-02,& + & 8.581500E-02,2.131500E-01,5.176800E-01,1.435700E+00,7.444700E+00,& + & 3.295500E+01,6.457400E+01,1.377400E+02,3.238000E+02,7.456800E+02,& + & 2.211600E+03,9.129700E+03,5.138900E-04,2.770500E-03,1.131000E-02,& + & 3.728800E-02,9.698000E-02,2.221200E-01,5.173900E-01,1.405200E+00,& + & 5.901200E+00,2.218600E+01,4.318500E+01,9.197500E+01,2.159700E+02,& + & 4.972300E+02,1.474500E+03,6.086500E+03,6.304300E-04,3.427700E-03,& + & 1.297600E-02,3.841400E-02,9.304900E-02,2.005800E-01,4.514000E-01,& + & 1.218600E+00,4.625000E+00,1.302900E+01,2.238100E+01,4.621100E+01,& + & 1.081400E+02,2.487900E+02,7.373700E+02,3.043300E+03,6.674500E-04,& + & 3.348200E-03,9.825900E-03,2.262100E-02,4.655300E-02,9.992900E-02,& + & 2.245800E-01,5.815000E-01,2.069400E+00,5.095100E+00,6.771000E+00,& + & 8.839000E+00,1.136000E+01,1.558800E+01,2.417800E+01,3.145000E+01,& + & 1.362400E-04,5.431300E-04,2.815000E-03,1.851000E-02,6.413600E-02,& + & 1.960000E-01,5.642700E-01,1.948800E+00,1.279100E+01,5.690000E+01,& + & 1.099300E+02,2.346300E+02,5.516300E+02,1.280200E+03,3.745900E+03,& + & 1.515500E+04,4.728900E-04,2.464900E-03,1.052200E-02,3.935800E-02,& + & 1.075400E-01,2.664900E-01,6.462500E-01,1.804100E+00,9.821900E+00,& + & 4.277100E+01,8.254500E+01,1.760700E+02,4.138000E+02,9.602200E+02,& + & 2.809500E+03,1.136700E+04,6.473200E-04,3.467600E-03,1.405700E-02,& + & 4.537400E-02,1.169400E-01,2.665800E-01,6.224700E-01,1.691100E+00,& + & 7.335800E+00,2.868600E+01,5.516400E+01,1.175200E+02,2.759800E+02,& + & 6.402600E+02,1.873100E+03,7.577800E+03,7.704400E-04,4.118300E-03,& + & 1.551700E-02,4.522400E-02,1.082000E-01,2.320600E-01,5.217400E-01,& + & 1.400600E+00,5.285400E+00,1.571200E+01,2.796800E+01,5.897100E+01,& + & 1.381500E+02,3.203000E+02,9.366500E+02,3.788900E+03,7.777000E-04,& + & 3.700800E-03,1.069200E-02,2.410700E-02,4.901300E-02,1.038600E-01,& + & 2.310100E-01,5.870300E-01,2.059800E+00,5.036000E+00,6.659800E+00,& + & 8.673500E+00,1.109200E+01,1.517000E+01,2.381800E+01,3.105900E+01,& + & 1.916800E-04,8.606100E-04,4.606600E-03,2.654600E-02,8.737900E-02,& + & 2.655900E-01,7.552600E-01,2.583500E+00,1.665000E+01,7.200900E+01,& + & 1.366600E+02,2.912800E+02,6.843300E+02,1.595900E+03,4.616100E+03,& + & 1.830700E+04,6.111100E-04,3.212700E-03,1.364600E-02,4.914900E-02,& + & 1.332200E-01,3.296300E-01,7.983600E-01,2.244000E+00,1.267700E+01,& + & 5.409800E+01,1.025900E+02,2.185600E+02,5.133300E+02,1.197000E+03,& + & 3.462100E+03,1.373000E+04,8.044300E-04,4.306200E-03,1.729600E-02,& + & 5.472000E-02,1.399500E-01,3.180200E-01,7.430400E-01,2.019300E+00,& + & 9.089900E+00,3.622000E+01,6.853100E+01,1.458300E+02,3.423400E+02,& + & 7.981400E+02,2.308100E+03,9.153400E+03,9.255000E-04,4.901400E-03,& + & 1.835900E-02,5.278900E-02,1.250200E-01,2.672600E-01,6.002700E-01,& + & 1.603400E+00,6.067800E+00,1.901200E+01,3.449900E+01,7.311700E+01,& + & 1.713400E+02,3.992400E+02,1.154200E+03,4.576700E+03,8.821300E-04,& + & 4.025200E-03,1.144800E-02,2.544300E-02,5.145500E-02,1.076200E-01,& + & 2.371100E-01,5.939900E-01,2.047500E+00,4.971600E+00,6.545500E+00,& + & 8.501600E+00,1.081700E+01,1.476600E+01,2.340100E+01,3.067400E+01/ + data absb(:, 201: 220) / & + & 4.396900E-05,1.159200E-04,4.042500E-04,3.444600E-03,1.682300E-02,& + & 5.064900E-02,1.548400E-01,5.403600E-01,3.817200E+00,1.857400E+01,& + & 3.750100E+01,8.305700E+01,2.079100E+02,5.164300E+02,1.570500E+03,& + & 7.330600E+03,1.683900E-04,8.929700E-04,3.882900E-03,1.545400E-02,& + & 4.387700E-02,1.092800E-01,2.658200E-01,7.542000E-01,3.490600E+00,& + & 1.406700E+01,2.822700E+01,6.240700E+01,1.560000E+02,3.874000E+02,& + & 1.177900E+03,5.498000E+03,2.540400E-04,1.449300E-03,5.969300E-03,& + & 2.032200E-02,5.452700E-02,1.258300E-01,2.938200E-01,8.357200E-01,& + & 3.531400E+00,1.079800E+01,1.928100E+01,4.176200E+01,1.041000E+02,& + & 2.583800E+02,7.853600E+02,3.665400E+03,3.275000E-04,1.920200E-03,& + & 7.386300E-03,2.276600E-02,5.640200E-02,1.240500E-01,2.870800E-01,& + & 8.119900E-01,3.339300E+00,9.114400E+00,1.311500E+01,2.268300E+01,& + & 5.219600E+01,1.293500E+02,3.927900E+02,1.832700E+03,3.738600E-04,& + & 2.148200E-03,6.665100E-03,1.644500E-02,3.545500E-02,7.877900E-02,& + & 1.855000E-01,5.098700E-01,1.998700E+00,5.298900E+00,7.310400E+00,& + & 9.955000E+00,1.329900E+01,1.826600E+01,2.836800E+01,3.735500E+01,& + & 5.580700E-05,1.691800E-04,7.348400E-04,6.028400E-03,2.493600E-02,& + & 7.573800E-02,2.272200E-01,7.984500E-01,5.529300E+00,2.583300E+01,& + & 5.174300E+01,1.143500E+02,2.863900E+02,7.207900E+02,2.155500E+03,& + & 9.823800E+03,2.242500E-04,1.182500E-03,5.154700E-03,2.006300E-02,& + & 5.595300E-02,1.387500E-01,3.396300E-01,9.680900E-01,4.650500E+00,& + & 1.948800E+01,3.890500E+01,8.586800E+01,2.148700E+02,5.406700E+02,& + & 1.616600E+03,7.367900E+03,3.321400E-04,1.838900E-03,7.578700E-03,& + & 2.525800E-02,6.651100E-02,1.526400E-01,3.583200E-01,1.014100E+00,& + & 4.263600E+00,1.388200E+01,2.610800E+01,5.739400E+01,1.433500E+02,& + & 3.605600E+02,1.077800E+03,4.911900E+03,4.206500E-04,2.361400E-03,& + & 9.029200E-03,2.719100E-02,6.630700E-02,1.448900E-01,3.325700E-01,& + & 9.345600E-01,3.776400E+00,1.025000E+01,1.568400E+01,2.947400E+01,& + & 7.182500E+01,1.804500E+02,5.390300E+02,2.456000E+03,4.651900E-04,& + & 2.479400E-03,7.478700E-03,1.781900E-02,3.760200E-02,8.260900E-02,& + & 1.914100E-01,5.162700E-01,1.998800E+00,5.260200E+00,7.225100E+00,& + & 9.786300E+00,1.301900E+01,1.776300E+01,2.797200E+01,3.699800E+01,& + & 7.487100E-05,2.652200E-04,1.315300E-03,9.669800E-03,3.563400E-02,& + & 1.092500E-01,3.210800E-01,1.128900E+00,7.678900E+00,3.470600E+01,& + & 6.834900E+01,1.509600E+02,3.780800E+02,9.596500E+02,2.834000E+03,& + & 1.260900E+04,2.947000E-04,1.557000E-03,6.770500E-03,2.563300E-02,& + & 7.064200E-02,1.746400E-01,4.278200E-01,1.225200E+00,6.152300E+00,& + & 2.612800E+01,5.136100E+01,1.133200E+02,2.836400E+02,7.198200E+02,& + & 2.125600E+03,9.457100E+03,4.237500E-04,2.308800E-03,9.493400E-03,& + & 3.099300E-02,8.051300E-02,1.839900E-01,4.333300E-01,1.222500E+00,& + & 5.183100E+00,1.787200E+01,3.437500E+01,7.568600E+01,1.892000E+02,& + & 4.799900E+02,1.417100E+03,6.304700E+03,5.240000E-04,2.857400E-03,& + & 1.087700E-02,3.220200E-02,7.745400E-02,1.683200E-01,3.843500E-01,& + & 1.075100E+00,4.277000E+00,1.162700E+01,1.901900E+01,3.812800E+01,& + & 9.476200E+01,2.401700E+02,7.086600E+02,3.152400E+03,5.574400E-04,& + & 2.786800E-03,8.236800E-03,1.911600E-02,3.978600E-02,8.625800E-02,& + & 1.978200E-01,5.229200E-01,1.996400E+00,5.216600E+00,7.133400E+00,& + & 9.610800E+00,1.272500E+01,1.727200E+01,2.754300E+01,3.649300E+01,& + & 1.038100E-04,4.246100E-04,2.250300E-03,1.441600E-02,4.953100E-02,& + & 1.521600E-01,4.409800E-01,1.539400E+00,1.030100E+01,4.518300E+01,& + & 8.736100E+01,1.924400E+02,4.818800E+02,1.230200E+03,3.594900E+03,& + & 1.561700E+04,3.833000E-04,2.033200E-03,8.814200E-03,3.223000E-02,& + & 8.817700E-02,2.176500E-01,5.330400E-01,1.529300E+00,8.028200E+00,& + & 3.397900E+01,6.562000E+01,1.444300E+02,3.615000E+02,9.227400E+02,& + & 2.696200E+03,1.171300E+04,5.308900E-04,2.874400E-03,1.173900E-02,& + & 3.757300E-02,9.674500E-02,2.203500E-01,5.199700E-01,1.463500E+00,& + & 6.317900E+00,2.289500E+01,4.388200E+01,9.641500E+01,2.411100E+02,& + & 6.152700E+02,1.797500E+03,7.808400E+03,6.375000E-04,3.417000E-03,& + & 1.293900E-02,3.778900E-02,8.993500E-02,1.945100E-01,4.427500E-01,& + & 1.232100E+00,4.845400E+00,1.351400E+01,2.303400E+01,4.841000E+01,& + & 1.207200E+02,3.078100E+02,8.988800E+02,3.904200E+03,6.472700E-04,& + & 3.070200E-03,8.911400E-03,2.030500E-02,4.192000E-02,8.982100E-02,& + & 2.037900E-01,5.312100E-01,1.991600E+00,5.165800E+00,7.034600E+00,& + & 9.431100E+00,1.241400E+01,1.680300E+01,2.704700E+01,3.596200E+01/ + data absb(:, 221: 240) / & + & 1.461100E-04,6.717700E-04,3.657500E-03,2.065300E-02,6.745500E-02,& + & 2.055000E-01,5.903000E-01,2.038800E+00,1.341300E+01,5.716200E+01,& + & 1.090400E+02,2.384000E+02,5.975100E+02,1.528000E+03,4.424900E+03,& + & 1.877300E+04,4.924300E-04,2.632200E-03,1.138000E-02,4.010400E-02,& + & 1.088400E-01,2.682200E-01,6.570900E-01,1.885800E+00,1.029600E+01,& + & 4.295800E+01,8.188000E+01,1.788900E+02,4.482100E+02,1.146100E+03,& + & 3.318700E+03,1.407900E+04,6.563700E-04,3.549400E-03,1.437700E-02,& + & 4.515300E-02,1.153900E-01,2.623000E-01,6.197000E-01,1.739500E+00,& + & 7.692200E+00,2.881600E+01,5.472400E+01,1.193900E+02,2.989200E+02,& + & 7.641600E+02,2.212600E+03,9.386300E+03,7.621800E-04,4.051900E-03,& + & 1.523100E-02,4.395600E-02,1.037500E-01,2.235400E-01,5.086400E-01,& + & 1.406600E+00,5.490900E+00,1.594600E+01,2.796400E+01,5.988500E+01,& + & 1.496300E+02,3.822500E+02,1.106400E+03,4.693200E+03,7.319900E-04,& + & 3.330900E-03,9.502500E-03,2.132200E-02,4.403000E-02,9.316000E-02,& + & 2.095600E-01,5.407400E-01,1.984900E+00,5.107800E+00,6.928600E+00,& + & 9.241700E+00,1.209800E+01,1.634800E+01,2.650800E+01,3.534600E+01,& + & 3.433700E-05,9.305500E-05,3.452300E-04,2.941700E-03,1.378900E-02,& + & 4.176700E-02,1.275300E-01,4.534700E-01,3.253800E+00,1.538500E+01,& + & 3.128900E+01,7.125000E+01,1.890500E+02,5.262300E+02,1.586900E+03,& + & 7.966800E+03,1.420300E-04,7.660600E-04,3.363500E-03,1.319100E-02,& + & 3.733100E-02,9.260800E-02,2.278100E-01,6.708800E-01,3.163600E+00,& + & 1.176000E+01,2.356600E+01,5.354900E+01,1.418600E+02,3.947500E+02,& + & 1.190200E+03,5.975100E+03,2.165800E-04,1.240900E-03,5.142900E-03,& + & 1.736400E-02,4.641300E-02,1.069900E-01,2.536000E-01,7.470500E-01,& + & 3.308300E+00,9.807200E+00,1.682500E+01,3.585300E+01,9.466900E+01,& + & 2.632700E+02,7.935600E+02,3.983400E+03,2.804000E-04,1.639800E-03,& + & 6.329400E-03,1.945100E-02,4.787800E-02,1.061100E-01,2.496200E-01,& + & 7.246300E-01,3.133600E+00,8.971500E+00,1.282800E+01,2.112600E+01,& + & 4.765800E+01,1.317900E+02,3.968800E+02,1.991700E+03,3.200500E-04,& + & 1.819700E-03,5.653500E-03,1.396000E-02,3.022000E-02,6.776600E-02,& + & 1.616400E-01,4.523300E-01,1.899400E+00,5.331600E+00,7.576000E+00,& + & 1.068500E+01,1.476000E+01,2.024300E+01,3.231800E+01,4.332500E+01,& + & 4.409500E-05,1.384100E-04,6.299300E-04,5.061400E-03,2.029400E-02,& + & 6.219200E-02,1.863700E-01,6.642000E-01,4.690400E+00,2.142100E+01,& + & 4.282500E+01,9.741400E+01,2.584600E+02,7.264400E+02,2.167300E+03,& + & 1.057100E+04,1.884500E-04,1.009200E-03,4.449200E-03,1.703100E-02,& + & 4.745900E-02,1.172600E-01,2.897000E-01,8.546600E-01,4.127500E+00,& + & 1.618700E+01,3.221600E+01,7.316400E+01,1.939200E+02,5.449100E+02,& + & 1.625500E+03,7.928600E+03,2.813200E-04,1.566000E-03,6.492300E-03,& + & 2.149600E-02,5.644400E-02,1.295900E-01,3.078900E-01,9.035200E-01,& + & 3.960100E+00,1.215400E+01,2.197100E+01,4.891800E+01,1.293900E+02,& + & 3.633900E+02,1.083800E+03,5.285800E+03,3.577400E-04,2.003800E-03,& + & 7.695700E-03,2.316300E-02,5.621200E-02,1.236300E-01,2.885400E-01,& + & 8.353200E-01,3.539200E+00,1.001900E+01,1.458800E+01,2.630700E+01,& + & 6.485200E+01,1.818600E+02,5.419800E+02,2.642900E+03,3.951400E-04,& + & 2.084300E-03,6.310700E-03,1.508400E-02,3.209100E-02,7.109600E-02,& + & 1.676100E-01,4.602000E-01,1.903800E+00,5.306500E+00,7.507900E+00,& + & 1.051200E+01,1.444400E+01,1.966400E+01,3.176700E+01,4.279300E+01,& + & 5.962700E-05,2.189900E-04,1.120600E-03,7.985700E-03,2.888700E-02,& + & 8.913600E-02,2.629900E-01,9.331200E-01,6.493600E+00,2.876300E+01,& + & 5.640300E+01,1.278000E+02,3.393600E+02,9.592500E+02,2.837800E+03,& + & 1.344900E+04,2.465900E-04,1.320600E-03,5.819200E-03,2.164300E-02,& + & 5.968500E-02,1.471100E-01,3.640400E-01,1.075100E+00,5.364700E+00,& + & 2.167500E+01,4.240100E+01,9.594500E+01,2.546000E+02,7.195200E+02,& + & 2.128400E+03,1.008700E+04,3.566100E-04,1.956600E-03,8.087100E-03,& + & 2.626900E-02,6.814200E-02,1.560500E-01,3.711400E-01,1.085400E+00,& + & 4.741500E+00,1.536300E+01,2.846200E+01,6.409700E+01,1.698400E+02,& + & 4.797900E+02,1.419000E+03,6.724400E+03,4.426600E-04,2.412500E-03,& + & 9.216600E-03,2.734900E-02,6.552200E-02,1.434300E-01,3.328000E-01,& + & 9.599500E-01,4.003300E+00,1.115800E+01,1.698400E+01,3.296700E+01,& + & 8.508600E+01,2.400600E+02,7.096100E+02,3.362200E+03,4.704900E-04,& + & 2.331100E-03,6.901800E-03,1.612800E-02,3.394900E-02,7.436300E-02,& + & 1.733300E-01,4.694200E-01,1.906200E+00,5.276700E+00,7.427000E+00,& + & 1.033500E+01,1.410400E+01,1.911600E+01,3.112600E+01,4.222100E+01/ + data absb(:, 241: 260) / & + & 8.300100E-05,3.507100E-04,1.899000E-03,1.181500E-02,4.002400E-02,& + & 1.234600E-01,3.605900E-01,1.267400E+00,8.685800E+00,3.737800E+01,& + & 7.229400E+01,1.621800E+02,4.313700E+02,1.221100E+03,3.587700E+03,& + & 1.652400E+04,3.190500E-04,1.714500E-03,7.545800E-03,2.709600E-02,& + & 7.419300E-02,1.828300E-01,4.526700E-01,1.335700E+00,6.904900E+00,& + & 2.812300E+01,5.432000E+01,1.217300E+02,3.236100E+02,9.159000E+02,& + & 2.690800E+03,1.239300E+04,4.443000E-04,2.424000E-03,9.951700E-03,& + & 3.171600E-02,8.162100E-02,1.867200E-01,4.447200E-01,1.294400E+00,& + & 5.691900E+00,1.926200E+01,3.635300E+01,8.128100E+01,2.158500E+02,& + & 6.107100E+02,1.794000E+03,8.261900E+03,5.353700E-04,2.874400E-03,& + & 1.090000E-02,3.197400E-02,7.594000E-02,1.655800E-01,3.828500E-01,& + & 1.098800E+00,4.527300E+00,1.247400E+01,2.016500E+01,4.103800E+01,& + & 1.080900E+02,3.055300E+02,8.970900E+02,4.131000E+03,5.430600E-04,& + & 2.558600E-03,7.431600E-03,1.703500E-02,3.579300E-02,7.749400E-02,& + & 1.788300E-01,4.801500E-01,1.906800E+00,5.239300E+00,7.338000E+00,& + & 1.014500E+01,1.374600E+01,1.859300E+01,3.042400E+01,4.160700E+01,& + & 1.168800E-04,5.521600E-04,3.058300E-03,1.687400E-02,5.448700E-02,& + & 1.659500E-01,4.810400E-01,1.676900E+00,1.128700E+01,4.733500E+01,& + & 9.039100E+01,2.004100E+02,5.338800E+02,1.507800E+03,4.400500E+03,& + & 1.975400E+04,4.073200E-04,2.206700E-03,9.705100E-03,3.363000E-02,& + & 9.129800E-02,2.242800E-01,5.570200E-01,1.640800E+00,8.770500E+00,& + & 3.558300E+01,6.789000E+01,1.504000E+02,4.004900E+02,1.131000E+03,& + & 3.300400E+03,1.481600E+04,5.466900E-04,2.979200E-03,1.213900E-02,& + & 3.802300E-02,9.707900E-02,2.218400E-01,5.292300E-01,1.533800E+00,& + & 6.830500E+00,2.399600E+01,4.539800E+01,1.003900E+02,2.671000E+02,& + & 7.540900E+02,2.200400E+03,9.877100E+03,6.370300E-04,3.395200E-03,& + & 1.276600E-02,3.706600E-02,8.744600E-02,1.900800E-01,4.397600E-01,& + & 1.252700E+00,5.108900E+00,1.418300E+01,2.403700E+01,5.039800E+01,& + & 1.337200E+02,3.772200E+02,1.100300E+03,4.938600E+03,6.116200E-04,& + & 2.768000E-03,7.894100E-03,1.778000E-02,3.751500E-02,8.047800E-02,& + & 1.842800E-01,4.918200E-01,1.907000E+00,5.184800E+00,7.239800E+00,& + & 9.945400E+00,1.337800E+01,1.808000E+01,2.969400E+01,4.088800E+01,& + & 2.708800E-05,7.565900E-05,2.978300E-04,2.527000E-03,1.137300E-02,& + & 3.473900E-02,1.058900E-01,3.819200E-01,2.799000E+00,1.295800E+01,& + & 2.611300E+01,6.094200E+01,1.701200E+02,5.315800E+02,1.623200E+03,& + & 8.621000E+03,1.202400E-04,6.566800E-04,2.910800E-03,1.126600E-02,& + & 3.179700E-02,7.866400E-02,1.952900E-01,5.955100E-01,2.900400E+00,& + & 1.014800E+01,1.969400E+01,4.581300E+01,1.276600E+02,3.987600E+02,& + & 1.217400E+03,6.465800E+03,1.848600E-04,1.060500E-03,4.417700E-03,& + & 1.484000E-02,3.944500E-02,9.113600E-02,2.187600E-01,6.652600E-01,& + & 3.088800E+00,9.302600E+00,1.498400E+01,3.093400E+01,8.520900E+01,& + & 2.659500E+02,8.116900E+02,4.310500E+03,2.402800E-04,1.397000E-03,& + & 5.405600E-03,1.658900E-02,4.063100E-02,9.061000E-02,2.167900E-01,& + & 6.448900E-01,2.922100E+00,8.764600E+00,1.280700E+01,2.001200E+01,& + & 4.373600E+01,1.331300E+02,4.059400E+02,2.155300E+03,2.738100E-04,& + & 1.536500E-03,4.780700E-03,1.180400E-02,2.567600E-02,5.806500E-02,& + & 1.403700E-01,3.999700E-01,1.786600E+00,5.317400E+00,7.766200E+00,& + & 1.134000E+01,1.621100E+01,2.244600E+01,3.642600E+01,5.042800E+01,& + & 3.518200E-05,1.144900E-04,5.438700E-04,4.272900E-03,1.663000E-02,& + & 5.137900E-02,1.542000E-01,5.548400E-01,4.016400E+00,1.801600E+01,& + & 3.561100E+01,8.264000E+01,2.310700E+02,7.266700E+02,2.204500E+03,& + & 1.131600E+04,1.588500E-04,8.601800E-04,3.832000E-03,1.446400E-02,& + & 4.027600E-02,9.937600E-02,2.475800E-01,7.543300E-01,3.719300E+00,& + & 1.371200E+01,2.680500E+01,6.208100E+01,1.733800E+02,5.450800E+02,& + & 1.653400E+03,8.486600E+03,2.384900E-04,1.332700E-03,5.543500E-03,& + & 1.829300E-02,4.787400E-02,1.103200E-01,2.646100E-01,8.022700E-01,& + & 3.688400E+00,1.102700E+01,1.899600E+01,4.152700E+01,1.156900E+02,& + & 3.634900E+02,1.102300E+03,5.657800E+03,3.042300E-04,1.697800E-03,& + & 6.534500E-03,1.968800E-02,4.762100E-02,1.053700E-01,2.504200E-01,& + & 7.437000E-01,3.300900E+00,9.738800E+00,1.414500E+01,2.405300E+01,& + & 5.814800E+01,1.819100E+02,5.512700E+02,2.828900E+03,3.354700E-04,& + & 1.749400E-03,5.297400E-03,1.271300E-02,2.727600E-02,6.098000E-02,& + & 1.457900E-01,4.095600E-01,1.796300E+00,5.306500E+00,7.714100E+00,& + & 1.118000E+01,1.584700E+01,2.178900E+01,3.563200E+01,4.976400E+01/ + data absb(:, 261: 280) / & + & 4.791000E-05,1.823700E-04,9.595200E-04,6.652400E-03,2.357200E-02,& + & 7.315400E-02,2.170200E-01,7.751700E-01,5.538500E+00,2.411600E+01,& + & 4.700700E+01,1.078500E+02,3.024100E+02,9.515900E+02,2.869700E+03,& + & 1.429100E+04,2.068700E-04,1.119500E-03,4.995000E-03,1.829400E-02,& + & 5.044500E-02,1.244100E-01,3.106800E-01,9.434700E-01,4.753000E+00,& + & 1.820300E+01,3.535300E+01,8.098300E+01,2.268900E+02,7.137800E+02,& + & 2.152300E+03,1.071800E+04,3.004300E-04,1.658100E-03,6.865500E-03,& + & 2.225400E-02,5.763200E-02,1.326100E-01,3.185400E-01,9.612500E-01,& + & 4.383500E+00,1.345800E+01,2.411200E+01,5.412400E+01,1.513700E+02,& + & 4.759600E+02,1.435000E+03,7.145400E+03,3.739900E-04,2.036700E-03,& + & 7.775700E-03,2.316200E-02,5.540500E-02,1.221800E-01,2.885200E-01,& + & 8.543100E-01,3.733600E+00,1.080000E+01,1.580300E+01,2.911000E+01,& + & 7.585100E+01,2.381400E+02,7.176000E+02,3.572700E+03,3.968600E-04,& + & 1.947600E-03,5.763000E-03,1.352000E-02,2.885700E-02,6.386600E-02,& + & 1.509400E-01,4.206400E-01,1.804600E+00,5.286300E+00,7.652900E+00,& + & 1.100100E+01,1.546700E+01,2.115600E+01,3.476600E+01,4.904900E+01,& + & 6.697500E-05,2.915700E-04,1.609200E-03,9.763100E-03,3.259000E-02,& + & 1.007500E-01,2.966100E-01,1.050400E+00,7.387400E+00,3.133100E+01,& + & 6.026000E+01,1.365200E+02,3.834900E+02,1.204200E+03,3.607200E+03,& + & 1.746900E+04,2.661300E-04,1.445500E-03,6.449600E-03,2.282000E-02,& + & 6.250600E-02,1.539200E-01,3.856400E-01,1.167800E+00,6.032300E+00,& + & 2.358900E+01,4.529600E+01,1.024900E+02,2.877000E+02,9.032300E+02,& + & 2.705400E+03,1.310200E+04,3.725900E-04,2.044100E-03,8.409500E-03,& + & 2.675900E-02,6.888300E-02,1.584500E-01,3.812800E-01,1.143700E+00,& + & 5.195700E+00,1.662500E+01,3.044600E+01,6.845400E+01,1.919100E+02,& + & 6.022700E+02,1.803700E+03,8.734400E+03,4.499400E-04,2.418700E-03,& + & 9.144000E-03,2.697200E-02,6.410500E-02,1.408700E-01,3.319500E-01,& + & 9.772800E-01,4.218700E+00,1.191800E+01,1.811900E+01,3.534300E+01,& + & 9.612500E+01,3.013100E+02,9.019700E+02,4.367200E+03,4.557000E-04,& + & 2.130500E-03,6.181700E-03,1.419000E-02,3.036000E-02,6.661000E-02,& + & 1.561400E-01,4.331900E-01,1.811100E+00,5.260500E+00,7.577900E+00,& + & 1.081200E+01,1.506600E+01,2.054100E+01,3.386700E+01,4.814600E+01,& + & 9.430500E-05,4.563800E-04,2.568400E-03,1.388000E-02,4.438300E-02,& + & 1.348100E-01,3.939700E-01,1.389100E+00,9.569700E+00,3.975100E+01,& + & 7.540200E+01,1.689400E+02,4.736900E+02,1.479100E+03,4.407000E+03,& + & 2.077400E+04,3.377000E-04,1.850600E-03,8.249400E-03,2.829600E-02,& + & 7.671600E-02,1.881700E-01,4.735500E-01,1.431400E+00,7.570700E+00,& + & 2.990100E+01,5.664200E+01,1.268000E+02,3.553500E+02,1.109400E+03,& + & 3.305300E+03,1.558000E+04,4.559600E-04,2.499400E-03,1.021500E-02,& + & 3.201500E-02,8.170300E-02,1.878400E-01,4.534100E-01,1.353300E+00,& + & 6.148600E+00,2.047300E+01,3.791700E+01,8.466300E+01,2.370100E+02,& + & 7.397200E+02,2.203600E+03,1.038700E+04,5.329200E-04,2.845900E-03,& + & 1.066800E-02,3.113800E-02,7.364600E-02,1.617200E-01,3.812100E-01,& + & 1.114200E+00,4.753600E+00,1.318000E+01,2.111800E+01,4.288000E+01,& + & 1.186700E+02,3.700400E+02,1.101900E+03,5.193500E+03,5.109700E-04,& + & 2.298600E-03,6.544700E-03,1.475600E-02,3.163200E-02,6.926900E-02,& + & 1.613200E-01,4.459900E-01,1.819100E+00,5.216400E+00,7.488900E+00,& + & 1.060900E+01,1.465100E+01,1.993600E+01,3.294200E+01,4.711300E+01,& + & 2.138200E-05,6.168600E-05,2.571500E-04,2.164900E-03,9.352100E-03,& + & 2.881800E-02,8.778800E-02,3.198000E-01,2.409300E+00,1.096500E+01,& + & 2.174400E+01,5.140600E+01,1.505700E+02,5.267400E+02,1.663800E+03,& + & 9.201500E+03,1.019100E-04,5.613300E-04,2.509500E-03,9.589300E-03,& + & 2.698800E-02,6.668200E-02,1.666800E-01,5.248500E-01,2.666600E+00,& + & 8.917800E+00,1.653100E+01,3.865900E+01,1.130000E+02,3.951300E+02,& + & 1.247900E+03,6.901100E+03,1.577800E-04,9.053000E-04,3.777700E-03,& + & 1.264100E-02,3.340500E-02,7.747100E-02,1.879900E-01,5.881600E-01,& + & 2.861300E+00,8.896800E+00,1.366700E+01,2.683500E+01,7.543600E+01,& + & 2.635100E+02,8.320400E+02,4.600800E+03,2.058300E-04,1.188700E-03,& + & 4.599700E-03,1.409300E-02,3.438200E-02,7.705700E-02,1.878000E-01,& + & 5.712100E-01,2.703100E+00,8.475600E+00,1.270500E+01,1.936800E+01,& + & 4.024600E+01,1.318900E+02,4.161500E+02,2.300400E+03,2.342400E-04,& + & 1.295900E-03,4.026000E-03,9.943700E-03,2.175800E-02,4.957400E-02,& + & 1.214000E-01,3.530300E-01,1.666200E+00,5.260900E+00,7.873400E+00,& + & 1.191700E+01,1.760900E+01,2.486100E+01,4.055500E+01,5.852700E+01/ + data absb(:, 281: 300) / & + & 2.808500E-05,9.486800E-05,4.682700E-04,3.598400E-03,1.359200E-02,& + & 4.231300E-02,1.273400E-01,4.613600E-01,3.438800E+00,1.518000E+01,& + & 2.966500E+01,6.926600E+01,2.036700E+02,7.132000E+02,2.239900E+03,& + & 1.198500E+04,1.339100E-04,7.315600E-04,3.288800E-03,1.223800E-02,& + & 3.404000E-02,8.406200E-02,2.108300E-01,6.615500E-01,3.367200E+00,& + & 1.178700E+01,2.235300E+01,5.205200E+01,1.528300E+02,5.349700E+02,& + & 1.680000E+03,8.923200E+03,2.021400E-04,1.132700E-03,4.710700E-03,& + & 1.549700E-02,4.045200E-02,9.358200E-02,2.270300E-01,7.075700E-01,& + & 3.409700E+00,1.035400E+01,1.671000E+01,3.511800E+01,1.019900E+02,& + & 3.567500E+02,1.120100E+03,5.992800E+03,2.586300E-04,1.437900E-03,& + & 5.520700E-03,1.666000E-02,4.021700E-02,8.953700E-02,2.165200E-01,& + & 6.587300E-01,3.056700E+00,9.384500E+00,1.391800E+01,2.228300E+01,& + & 5.208300E+01,1.785200E+02,5.601700E+02,2.996400E+03,2.848400E-04,& + & 1.467200E-03,4.432500E-03,1.066000E-02,2.310600E-02,5.214600E-02,& + & 1.261800E-01,3.642700E-01,1.681200E+00,5.262200E+00,7.846600E+00,& + & 1.177000E+01,1.720300E+01,2.410500E+01,3.951200E+01,5.748900E+01,& + & 3.850500E-05,1.517000E-04,8.182800E-04,5.534300E-03,1.919000E-02,& + & 5.984300E-02,1.785700E-01,6.422300E-01,4.719600E+00,2.030400E+01,& + & 3.914300E+01,9.012700E+01,2.655800E+02,9.279900E+02,2.895000E+03,& + & 1.502600E+04,1.734300E-04,9.469400E-04,4.267700E-03,1.540700E-02,& + & 4.248600E-02,1.048500E-01,2.641300E-01,8.237100E-01,4.238400E+00,& + & 1.541800E+01,2.945900E+01,6.769300E+01,1.992700E+02,6.960800E+02,& + & 2.171300E+03,1.126900E+04,2.531300E-04,1.402300E-03,5.800000E-03,& + & 1.876100E-02,4.857000E-02,1.123200E-01,2.730300E-01,8.456100E-01,& + & 4.041800E+00,1.213100E+01,2.078700E+01,4.528200E+01,1.329500E+02,& + & 4.641600E+02,1.447600E+03,7.512900E+03,3.159200E-04,1.718600E-03,& + & 6.528500E-03,1.950600E-02,4.670100E-02,1.037200E-01,2.493600E-01,& + & 7.564900E-01,3.457700E+00,1.037100E+01,1.522600E+01,2.610400E+01,& + & 6.683500E+01,2.322400E+02,7.239200E+02,3.756500E+03,3.347700E-04,& + & 1.626500E-03,4.802800E-03,1.126500E-02,2.439900E-02,5.464500E-02,& + & 1.309800E-01,3.767400E-01,1.695600E+00,5.255200E+00,7.806500E+00,& + & 1.160700E+01,1.677000E+01,2.335700E+01,3.843000E+01,5.633300E+01,& + & 5.399700E-05,2.418400E-04,1.358100E-03,8.063000E-03,2.652700E-02,& + & 8.195200E-02,2.429600E-01,8.693900E-01,6.261000E+00,2.645300E+01,& + & 5.022200E+01,1.142400E+02,3.359400E+02,1.167600E+03,3.621400E+03,& + & 1.823800E+04,2.217100E-04,1.216000E-03,5.477600E-03,1.917800E-02,& + & 5.245400E-02,1.292400E-01,3.272100E-01,1.017200E+00,5.292300E+00,& + & 1.995500E+01,3.776100E+01,8.578000E+01,2.520300E+02,8.758100E+02,& + & 2.716100E+03,1.367900E+04,3.122800E-04,1.720200E-03,7.069600E-03,& + & 2.249300E-02,5.788600E-02,1.338800E-01,3.266100E-01,1.004700E+00,& + & 4.754200E+00,1.458600E+01,2.577300E+01,5.732800E+01,1.681300E+02,& + & 5.839900E+02,1.810800E+03,9.119100E+03,3.780400E-04,2.032400E-03,& + & 7.644100E-03,2.259600E-02,5.387800E-02,1.195400E-01,2.869800E-01,& + & 8.655800E-01,3.905300E+00,1.141200E+01,1.682400E+01,3.093700E+01,& + & 8.422600E+01,2.921800E+02,9.055200E+02,4.559600E+03,3.823100E-04,& + & 1.773200E-03,5.133800E-03,1.177500E-02,2.552800E-02,5.705100E-02,& + & 1.358600E-01,3.898100E-01,1.710300E+00,5.242800E+00,7.751100E+00,& + & 1.142100E+01,1.632500E+01,2.261700E+01,3.731200E+01,5.503000E+01,& + & 7.595300E-05,3.758400E-04,2.149400E-03,1.138400E-02,3.612700E-02,& + & 1.092500E-01,3.209800E-01,1.148400E+00,8.072500E+00,3.372700E+01,& + & 6.292800E+01,1.418200E+02,4.137900E+02,1.429800E+03,4.404800E+03,& + & 2.153900E+04,2.796600E-04,1.547900E-03,6.955000E-03,2.374600E-02,& + & 6.424000E-02,1.575600E-01,4.005500E-01,1.244900E+00,6.545900E+00,& + & 2.540900E+01,4.728200E+01,1.064600E+02,3.104200E+02,1.072400E+03,& + & 3.303600E+03,1.615400E+04,3.797800E-04,2.092400E-03,8.550000E-03,& + & 2.683100E-02,6.848000E-02,1.583700E-01,3.878500E-01,1.188000E+00,& + & 5.552800E+00,1.780700E+01,3.182400E+01,7.110900E+01,2.070500E+02,& + & 7.150800E+02,2.202500E+03,1.076900E+04,4.456800E-04,2.382200E-03,& + & 8.891000E-03,2.596500E-02,6.174000E-02,1.371000E-01,3.293600E-01,& + & 9.871700E-01,4.394300E+00,1.253700E+01,1.895800E+01,3.689400E+01,& + & 1.036900E+02,3.577400E+02,1.101400E+03,5.384800E+03,4.268100E-04,& + & 1.907600E-03,5.419300E-03,1.221100E-02,2.641800E-02,5.932800E-02,& + & 1.407500E-01,4.025500E-01,1.728000E+00,5.208000E+00,7.681600E+00,& + & 1.121800E+01,1.586400E+01,2.188800E+01,3.617200E+01,5.359900E+01/ + data absb(:, 301: 320) / & + & 1.721700E-05,5.142000E-05,2.263200E-04,1.885200E-03,7.814300E-03,& + & 2.428900E-02,7.411400E-02,2.715600E-01,2.109300E+00,9.480200E+00,& + & 1.855600E+01,4.376200E+01,1.342000E+02,5.218500E+02,1.733200E+03,& + & 9.903300E+03,8.693500E-05,4.815100E-04,2.169600E-03,8.197800E-03,& + & 2.304600E-02,5.701800E-02,1.435700E-01,4.645700E-01,2.477700E+00,& + & 8.067800E+00,1.439100E+01,3.292800E+01,1.007300E+02,3.914500E+02,& + & 1.299900E+03,7.427500E+03,1.352000E-04,7.748000E-04,3.233000E-03,& + & 1.079300E-02,2.842300E-02,6.618200E-02,1.626800E-01,5.212700E-01,& + & 2.657600E+00,8.534600E+00,1.298600E+01,2.397400E+01,6.725500E+01,& + & 2.610500E+02,8.667300E+02,4.951700E+03,1.766700E-04,1.012700E-03,& + & 3.911300E-03,1.198300E-02,2.918000E-02,6.574300E-02,1.629900E-01,& + & 5.071400E-01,2.502500E+00,8.168900E+00,1.254200E+01,1.929700E+01,& + & 3.794100E+01,1.306600E+02,4.335200E+02,2.475900E+03,2.005100E-04,& + & 1.092500E-03,3.380100E-03,8.350000E-03,1.839100E-02,4.222400E-02,& + & 1.045400E-01,3.117600E-01,1.542800E+00,5.160200E+00,7.922300E+00,& + & 1.240600E+01,1.892200E+01,2.739600E+01,4.471900E+01,6.709100E+01,& + & 2.286000E-05,8.020500E-05,4.093600E-04,3.082200E-03,1.129200E-02,& + & 3.537100E-02,1.069600E-01,3.896200E-01,2.990200E+00,1.309100E+01,& + & 2.528800E+01,5.872600E+01,1.806100E+02,7.014000E+02,2.313100E+03,& + & 1.276800E+04,1.136100E-04,6.247200E-04,2.832000E-03,1.041000E-02,& + & 2.896500E-02,7.168500E-02,1.814800E-01,5.832600E-01,3.096400E+00,& + & 1.041200E+01,1.916600E+01,4.414700E+01,1.355400E+02,5.261200E+02,& + & 1.734900E+03,9.576200E+03,1.720100E-04,9.653700E-04,4.005200E-03,& + & 1.316100E-02,3.435000E-02,7.986000E-02,1.963900E-01,6.260500E-01,& + & 3.165300E+00,9.880400E+00,1.527200E+01,3.045300E+01,9.046400E+01,& + & 3.508400E+02,1.156700E+03,6.384100E+03,2.202800E-04,1.220600E-03,& + & 4.661500E-03,1.410500E-02,3.405900E-02,7.640000E-02,1.878100E-01,& + & 5.852100E-01,2.834700E+00,9.042000E+00,1.369600E+01,2.137900E+01,& + & 4.760300E+01,1.755600E+02,5.785100E+02,3.192100E+03,2.419800E-04,& + & 1.230500E-03,3.703500E-03,8.893000E-03,1.949800E-02,4.445100E-02,& + & 1.089000E-01,3.237600E-01,1.564300E+00,5.179800E+00,7.920700E+00,& + & 1.228400E+01,1.847100E+01,2.650900E+01,4.338100E+01,6.554200E+01,& + & 3.154000E-05,1.285200E-04,7.083600E-04,4.678800E-03,1.590600E-02,& + & 4.969500E-02,1.492100E-01,5.414000E-01,4.076800E+00,1.755600E+01,& + & 3.332800E+01,7.646300E+01,2.346400E+02,9.071300E+02,2.971100E+03,& + & 1.587100E+04,1.463200E-04,8.048100E-04,3.654700E-03,1.306000E-02,& + & 3.603300E-02,8.909100E-02,2.268600E-01,7.257300E-01,3.839400E+00,& + & 1.350200E+01,2.510100E+01,5.745300E+01,1.760600E+02,6.804300E+02,& + & 2.228400E+03,1.190300E+04,2.142600E-04,1.189500E-03,4.909600E-03,& + & 1.586600E-02,4.115800E-02,9.570400E-02,2.362700E-01,7.472100E-01,& + & 3.746300E+00,1.139000E+01,1.844800E+01,3.873500E+01,1.174700E+02,& + & 4.537300E+02,1.485700E+03,7.935500E+03,2.674500E-04,1.453500E-03,& + & 5.488500E-03,1.642300E-02,3.946000E-02,8.845200E-02,2.164800E-01,& + & 6.726700E-01,3.210600E+00,9.974000E+00,1.491300E+01,2.418700E+01,& + & 5.984000E+01,2.270300E+02,7.430200E+02,3.967800E+03,2.824700E-04,& + & 1.358300E-03,3.998900E-03,9.355500E-03,2.048400E-02,4.660300E-02,& + & 1.133700E-01,3.365400E-01,1.586500E+00,5.191900E+00,7.903900E+00,& + & 1.213400E+01,1.799800E+01,2.561800E+01,4.203200E+01,6.383100E+01,& + & 4.433000E-05,2.038400E-04,1.164200E-03,6.767200E-03,2.201500E-02,& + & 6.768700E-02,2.016900E-01,7.315800E-01,5.378500E+00,2.293700E+01,& + & 4.279900E+01,9.722200E+01,2.958000E+02,1.137100E+03,3.695400E+03,& + & 1.911000E+04,1.859400E-04,1.028400E-03,4.661300E-03,1.624600E-02,& + & 4.438700E-02,1.095300E-01,2.803000E-01,8.951400E-01,4.723700E+00,& + & 1.738900E+01,3.218700E+01,7.302100E+01,2.219300E+02,8.528800E+02,& + & 2.771600E+03,1.433300E+04,2.627200E-04,1.452300E-03,5.964200E-03,& + & 1.896500E-02,4.891500E-02,1.138500E-01,2.823300E-01,8.880000E-01,& + & 4.388100E+00,1.331800E+01,2.255700E+01,4.885900E+01,1.480600E+02,& + & 5.687000E+02,1.847800E+03,9.555100E+03,3.184600E-04,1.712800E-03,& + & 6.409400E-03,1.891900E-02,4.542500E-02,1.018800E-01,2.491300E-01,& + & 7.703300E-01,3.628100E+00,1.095600E+01,1.621600E+01,2.798700E+01,& + & 7.444600E+01,2.845300E+02,9.240700E+02,4.777600E+03,3.208900E-04,& + & 1.476200E-03,4.260000E-03,9.750800E-03,2.129100E-02,4.865500E-02,& + & 1.179300E-01,3.491600E-01,1.611500E+00,5.185500E+00,7.872500E+00,& + & 1.196100E+01,1.750600E+01,2.473000E+01,4.066800E+01,6.202900E+01/ + data absb(:, 321: 340) / & + & 6.226000E-05,3.144600E-04,1.824300E-03,9.470300E-03,2.992900E-02,& + & 9.008000E-02,2.651100E-01,9.655700E-01,6.912800E+00,2.916200E+01,& + & 5.384400E+01,1.209800E+02,3.642200E+02,1.389100E+03,4.471100E+03,& + & 2.241700E+04,2.332700E-04,1.302200E-03,5.876400E-03,2.006900E-02,& + & 5.429200E-02,1.332400E-01,3.424000E-01,1.094000E+00,5.772700E+00,& + & 2.200700E+01,4.047300E+01,9.082800E+01,2.732500E+02,1.041900E+03,& + & 3.353400E+03,1.681300E+04,3.177000E-04,1.758700E-03,7.183000E-03,& + & 2.256000E-02,5.774800E-02,1.344800E-01,3.349400E-01,1.051000E+00,& + & 5.086300E+00,1.591000E+01,2.758500E+01,6.069400E+01,1.822800E+02,& + & 6.947400E+02,2.235700E+03,1.120800E+04,3.737300E-04,1.999600E-03,& + & 7.436900E-03,2.166000E-02,5.189200E-02,1.167900E-01,2.859800E-01,& + & 8.799100E-01,4.078800E+00,1.204300E+01,1.777700E+01,3.276500E+01,& + & 9.130900E+01,3.475700E+02,1.118000E+03,5.604300E+03,3.566600E-04,& + & 1.583900E-03,4.484400E-03,1.008700E-02,2.193900E-02,5.036600E-02,& + & 1.226100E-01,3.618800E-01,1.637600E+00,5.175300E+00,7.821600E+00,& + & 1.175900E+01,1.699700E+01,2.386000E+01,3.931200E+01,6.013600E+01,& + & 1.422200E-05,4.417300E-05,2.047100E-04,1.683800E-03,6.684100E-03,& + & 2.094000E-02,6.410200E-02,2.360300E-01,1.885600E+00,8.488300E+00,& + & 1.632100E+01,3.802200E+01,1.211400E+02,5.225100E+02,1.845700E+03,& + & 1.077700E+04,7.485300E-05,4.160500E-04,1.889300E-03,7.069100E-03,& + & 1.988200E-02,4.934000E-02,1.256200E-01,4.151400E-01,2.326200E+00,& + & 7.602900E+00,1.301200E+01,2.865900E+01,9.093400E+01,3.919500E+02,& + & 1.384300E+03,8.082500E+03,1.165900E-04,6.665300E-04,2.776800E-03,& + & 9.264900E-03,2.438600E-02,5.702900E-02,1.422000E-01,4.657000E-01,& + & 2.487500E+00,8.230500E+00,1.267100E+01,2.210500E+01,6.094600E+01,& + & 2.613800E+02,9.230000E+02,5.388400E+03,1.522900E-04,8.665100E-04,& + & 3.331500E-03,1.022200E-02,2.490200E-02,5.646700E-02,1.420900E-01,& + & 4.531700E-01,2.328700E+00,7.878100E+00,1.238900E+01,1.951600E+01,& + & 3.669900E+01,1.308500E+02,4.616600E+02,2.694200E+03,1.720500E-04,& + & 9.218600E-04,2.836100E-03,6.985600E-03,1.550700E-02,3.591000E-02,& + & 8.983600E-02,2.752800E-01,1.422400E+00,5.030000E+00,7.929300E+00,& + & 1.280500E+01,2.012900E+01,2.992700E+01,4.879800E+01,7.580700E+01,& + & 1.909700E-05,6.970600E-05,3.670900E-04,2.702100E-03,9.618700E-03,& + & 3.022900E-02,9.190300E-02,3.372900E-01,2.649300E+00,1.173200E+01,& + & 2.217600E+01,5.099400E+01,1.622400E+02,6.973000E+02,2.442100E+03,& + & 1.374900E+04,9.729000E-05,5.377900E-04,2.454300E-03,8.943200E-03,& + & 2.491700E-02,6.184800E-02,1.585300E-01,5.206200E-01,2.889000E+00,& + & 9.561100E+00,1.701300E+01,3.835600E+01,1.217500E+02,5.230500E+02,& + & 1.831700E+03,1.031200E+04,1.473300E-04,8.270100E-04,3.425800E-03,& + & 1.124000E-02,2.940400E-02,6.878600E-02,1.717900E-01,5.590400E-01,& + & 2.964100E+00,9.492900E+00,1.454100E+01,2.736200E+01,8.126800E+01,& + & 3.488000E+02,1.221200E+03,6.874600E+03,1.884000E-04,1.040800E-03,& + & 3.951600E-03,1.197000E-02,2.899800E-02,6.564400E-02,1.639100E-01,& + & 5.235600E-01,2.645800E+00,8.734000E+00,1.349200E+01,2.113100E+01,& + & 4.454000E+01,1.745500E+02,6.107800E+02,3.437300E+03,2.059500E-04,& + & 1.032900E-03,3.093900E-03,7.401300E-03,1.636800E-02,3.781600E-02,& + & 9.383000E-02,2.872200E-01,1.451500E+00,5.070300E+00,7.954900E+00,& + & 1.270900E+01,1.964500E+01,2.887700E+01,4.715000E+01,7.358600E+01,& + & 2.649800E-05,1.116400E-04,6.278900E-04,4.045200E-03,1.354100E-02,& + & 4.217300E-02,1.273200E-01,4.676200E-01,3.587100E+00,1.571000E+01,& + & 2.923600E+01,6.653800E+01,2.099300E+02,8.973500E+02,3.112700E+03,& + & 1.692100E+04,1.246200E-04,6.898200E-04,3.150400E-03,1.119500E-02,& + & 3.091600E-02,7.666600E-02,1.978200E-01,6.481200E-01,3.536800E+00,& + & 1.227400E+01,2.209200E+01,5.001400E+01,1.575300E+02,6.730900E+02,& + & 2.334600E+03,1.269000E+04,1.824700E-04,1.014700E-03,4.184900E-03,& + & 1.349700E-02,3.514700E-02,8.232700E-02,2.067000E-01,6.679100E-01,& + & 3.501300E+00,1.094100E+01,1.701400E+01,3.425800E+01,1.051200E+02,& + & 4.488400E+02,1.556500E+03,8.460300E+03,2.274000E-04,1.234800E-03,& + & 4.638700E-03,1.385100E-02,3.352200E-02,7.601500E-02,1.891700E-01,& + & 6.028900E-01,3.002100E+00,9.648300E+00,1.464700E+01,2.325000E+01,& + & 5.476800E+01,2.245900E+02,7.784300E+02,4.230200E+03,2.387100E-04,& + & 1.135300E-03,3.328600E-03,7.758800E-03,1.708800E-02,3.962900E-02,& + & 9.800200E-02,2.996300E-01,1.482400E+00,5.100800E+00,7.962800E+00,& + & 1.258200E+01,1.913400E+01,2.782000E+01,4.550700E+01,7.124600E+01/ + data absb(:, 341: 360) / & + & 3.730400E-05,1.759000E-04,1.021300E-03,5.801700E-03,1.873400E-02,& + & 5.723800E-02,1.709500E-01,6.304300E-01,4.714000E+00,2.037700E+01,& + & 3.770300E+01,8.470200E+01,2.645700E+02,1.121300E+03,3.843200E+03,& + & 2.022700E+04,1.574900E-04,8.778600E-04,3.995000E-03,1.391200E-02,& + & 3.804500E-02,9.407200E-02,2.438800E-01,7.994900E-01,4.302400E+00,& + & 1.557700E+01,2.837800E+01,6.363100E+01,1.985000E+02,8.410500E+02,& + & 2.882500E+03,1.517000E+04,2.224400E-04,1.233700E-03,5.068700E-03,& + & 1.609400E-02,4.167600E-02,9.785400E-02,2.469100E-01,7.954000E-01,& + & 4.086200E+00,1.262600E+01,2.043900E+01,4.283300E+01,1.324400E+02,& + & 5.608100E+02,1.921700E+03,1.011400E+04,2.695000E-04,1.449900E-03,& + & 5.408800E-03,1.590600E-02,3.846100E-02,8.754800E-02,2.180100E-01,& + & 6.920700E-01,3.395000E+00,1.061700E+01,1.586800E+01,2.616900E+01,& + & 6.728000E+01,2.805800E+02,9.610400E+02,5.056800E+03,2.696600E-04,& + & 1.229400E-03,3.534600E-03,8.066900E-03,1.767900E-02,4.117300E-02,& + & 1.023400E-01,3.119700E-01,1.516600E+00,5.114300E+00,7.953700E+00,& + & 1.241800E+01,1.859900E+01,2.677200E+01,4.388400E+01,6.887000E+01,& + & 5.226300E-05,2.694200E-04,1.581500E-03,8.044800E-03,2.538200E-02,& + & 7.605800E-02,2.237600E-01,8.289400E-01,6.044600E+00,2.576200E+01,& + & 4.762300E+01,1.056500E+02,3.261700E+02,1.366500E+03,4.619700E+03,& + & 2.358500E+04,1.966900E-04,1.105400E-03,5.007400E-03,1.714000E-02,& + & 4.653400E-02,1.143600E-01,2.973100E-01,9.760400E-01,5.204500E+00,& + & 1.949700E+01,3.582600E+01,7.932700E+01,2.447100E+02,1.025000E+03,& + & 3.464800E+03,1.768800E+04,2.676400E-04,1.488500E-03,6.078700E-03,& + & 1.909500E-02,4.918300E-02,1.154500E-01,2.927700E-01,9.422200E-01,& + & 4.723800E+00,1.464600E+01,2.485700E+01,5.306200E+01,1.632600E+02,& + & 6.834600E+02,2.310000E+03,1.179200E+04,3.147200E-04,1.686300E-03,& + & 6.259300E-03,1.817500E-02,4.379500E-02,1.003400E-01,2.504400E-01,& + & 7.927500E-01,3.814500E+00,1.169100E+01,1.718800E+01,3.002800E+01,& + & 8.206400E+01,3.419200E+02,1.155200E+03,5.896200E+03,2.984800E-04,& + & 1.316100E-03,3.710700E-03,8.326300E-03,1.816400E-02,4.230000E-02,& + & 1.067400E-01,3.246000E-01,1.551800E+00,5.133700E+00,7.917700E+00,& + & 1.221600E+01,1.804300E+01,2.574100E+01,4.229600E+01,6.642400E+01,& + & 1.226300E-05,3.967500E-05,1.925100E-04,1.560700E-03,5.946400E-03,& + & 1.873000E-02,5.762200E-02,2.132900E-01,1.745500E+00,7.983100E+00,& + & 1.502800E+01,3.448900E+01,1.128800E+02,5.383400E+02,2.040100E+03,& + & 1.205200E+04,6.514400E-05,3.627500E-04,1.661700E-03,6.189000E-03,& + & 1.746100E-02,4.357200E-02,1.124900E-01,3.788600E-01,2.227900E+00,& + & 7.465700E+00,1.226400E+01,2.613200E+01,8.473100E+01,4.038300E+02,& + & 1.530200E+03,9.038800E+03,1.010800E-04,5.765800E-04,2.402900E-03,& + & 8.025800E-03,2.120700E-02,4.993700E-02,1.263600E-01,4.229500E-01,& + & 2.369100E+00,8.038600E+00,1.258200E+01,2.123500E+01,5.725800E+01,& + & 2.693100E+02,1.020200E+03,6.025900E+03,1.315600E-04,7.442300E-04,& + & 2.851400E-03,8.768300E-03,2.145700E-02,4.906400E-02,1.251100E-01,& + & 4.098200E-01,2.193800E+00,7.671200E+00,1.231300E+01,1.987800E+01,& + & 3.659100E+01,1.351000E+02,5.103000E+02,3.013000E+03,1.474400E-04,& + & 7.772700E-04,2.376200E-03,5.822800E-03,1.301900E-02,3.047400E-02,& + & 7.705500E-02,2.426200E-01,1.309300E+00,4.876200E+00,7.911600E+00,& + & 1.312200E+01,2.123500E+01,3.235700E+01,5.274800E+01,8.431600E+01,& + & 1.664400E-05,6.307900E-05,3.418500E-04,2.456100E-03,8.541100E-03,& + & 2.683100E-02,8.198300E-02,3.040500E-01,2.433100E+00,1.100700E+01,& + & 2.039300E+01,4.630500E+01,1.504000E+02,7.143900E+02,2.672700E+03,& + & 1.522200E+04,8.429000E-05,4.676900E-04,2.152500E-03,7.818300E-03,& + & 2.185500E-02,5.454100E-02,1.419600E-01,4.760900E-01,2.754400E+00,& + & 9.225800E+00,1.585500E+01,3.484400E+01,1.128800E+02,5.358700E+02,& + & 2.004600E+03,1.141700E+04,1.269600E-04,7.130400E-04,2.960000E-03,& + & 9.701000E-03,2.553400E-02,6.025900E-02,1.531200E-01,5.088100E-01,& + & 2.827000E+00,9.292800E+00,1.433900E+01,2.571400E+01,7.544700E+01,& + & 3.573500E+02,1.336500E+03,7.611100E+03,1.616300E-04,8.912800E-04,& + & 3.373000E-03,1.021700E-02,2.494500E-02,5.713400E-02,1.448500E-01,& + & 4.749000E-01,2.504300E+00,8.539600E+00,1.340700E+01,2.134200E+01,& + & 4.314600E+01,1.788300E+02,6.684500E+02,3.805600E+03,1.750900E-04,& + & 8.662200E-04,2.582500E-03,6.145900E-03,1.365800E-02,3.206400E-02,& + & 8.079100E-02,2.543400E-01,1.345900E+00,4.940200E+00,7.962000E+00,& + & 1.306200E+01,2.072200E+01,3.111600E+01,5.076300E+01,8.138600E+01/ + data absb(:, 361: 380) / & + & 2.320200E-05,1.008000E-04,5.777800E-04,3.625300E-03,1.201200E-02,& + & 3.721600E-02,1.127500E-01,4.204700E-01,3.276600E+00,1.462100E+01,& + & 2.699800E+01,6.044100E+01,1.944700E+02,9.162600E+02,3.376500E+03,& + & 1.859000E+04,1.075500E-04,5.985700E-04,2.751200E-03,9.780600E-03,& + & 2.709800E-02,6.757800E-02,1.769700E-01,5.940400E-01,3.351600E+00,& + & 1.159400E+01,2.050300E+01,4.544300E+01,1.459300E+02,6.872800E+02,& + & 2.532500E+03,1.394200E+04,1.565100E-04,8.722600E-04,3.609200E-03,& + & 1.162500E-02,3.047200E-02,7.215100E-02,1.843700E-01,6.102700E-01,& + & 3.333300E+00,1.075700E+01,1.644100E+01,3.173400E+01,9.739700E+01,& + & 4.583000E+02,1.688500E+03,9.294800E+03,1.941900E-04,1.054600E-03,& + & 3.956300E-03,1.178700E-02,2.877300E-02,6.619700E-02,1.678100E-01,& + & 5.487000E-01,2.852000E+00,9.465200E+00,1.455000E+01,2.308500E+01,& + & 5.201900E+01,2.293200E+02,8.444100E+02,4.647400E+03,2.015900E-04,& + & 9.487300E-04,2.768400E-03,6.427000E-03,1.419200E-02,3.345800E-02,& + & 8.471300E-02,2.661100E-01,1.386200E+00,4.991500E+00,7.995800E+00,& + & 1.295500E+01,2.017500E+01,2.988100E+01,4.881500E+01,7.834800E+01,& + & 3.266900E-05,1.578400E-04,9.285400E-04,5.157800E-03,1.658000E-02,& + & 5.041700E-02,1.505500E-01,5.649300E-01,4.292300E+00,1.884700E+01,& + & 3.494800E+01,7.710900E+01,2.452200E+02,1.142400E+03,4.137300E+03,& + & 2.205800E+04,1.354000E-04,7.591400E-04,3.475300E-03,1.214600E-02,& + & 3.338200E-02,8.288900E-02,2.179400E-01,7.333800E-01,4.043200E+00,& + & 1.454700E+01,2.634200E+01,5.793100E+01,1.840000E+02,8.569200E+02,& + & 3.103100E+03,1.654300E+04,1.900300E-04,1.058200E-03,4.362100E-03,& + & 1.385600E-02,3.614600E-02,8.576200E-02,2.203900E-01,7.290400E-01,& + & 3.885200E+00,1.232600E+01,1.946000E+01,3.934700E+01,1.227900E+02,& + & 5.714000E+02,2.068800E+03,1.102900E+04,2.291700E-04,1.234600E-03,& + & 4.609100E-03,1.352500E-02,3.290400E-02,7.629900E-02,1.939000E-01,& + & 6.325100E-01,3.230300E+00,1.047500E+01,1.575700E+01,2.540900E+01,& + & 6.325000E+01,2.858700E+02,1.034600E+03,5.514500E+03,2.265700E-04,& + & 1.024300E-03,2.930800E-03,6.667000E-03,1.463800E-02,3.450700E-02,& + & 8.873100E-02,2.783100E-01,1.428900E+00,5.030400E+00,8.011900E+00,& + & 1.280000E+01,1.959600E+01,2.866600E+01,4.691200E+01,7.534000E+01,& + & 4.563600E-05,2.398800E-04,1.419900E-03,7.091700E-03,2.239200E-02,& + & 6.688400E-02,1.963800E-01,7.396100E-01,5.494200E+00,2.374400E+01,& + & 4.416400E+01,9.657800E+01,3.030500E+02,1.390100E+03,4.942600E+03,& + & 2.555000E+04,1.684900E-04,9.519900E-04,4.343600E-03,1.492900E-02,& + & 4.089000E-02,1.008800E-01,2.655500E-01,8.945200E-01,4.856500E+00,& + & 1.804500E+01,3.325000E+01,7.252100E+01,2.273800E+02,1.042700E+03,& + & 3.707100E+03,1.916200E+04,2.277800E-04,1.272700E-03,5.215600E-03,& + & 1.641900E-02,4.267100E-02,1.012900E-01,2.613200E-01,8.649000E-01,& + & 4.487800E+00,1.405600E+01,2.346400E+01,4.866200E+01,1.517200E+02,& + & 6.952500E+02,2.471500E+03,1.277500E+04,2.664800E-04,1.432600E-03,& + & 5.325800E-03,1.545200E-02,3.739900E-02,8.754200E-02,2.231200E-01,& + & 7.273500E-01,3.632000E+00,1.154500E+01,1.706800E+01,2.865400E+01,& + & 7.675100E+01,3.478100E+02,1.235900E+03,6.387500E+03,2.496600E-04,& + & 1.093500E-03,3.069100E-03,6.867600E-03,1.500500E-02,3.524700E-02,& + & 9.265500E-02,2.910100E-01,1.472600E+00,5.080800E+00,7.987200E+00,& + & 1.260200E+01,1.899700E+01,2.746700E+01,4.508400E+01,7.232900E+01,& + & 1.090700E-05,3.678700E-05,1.856800E-04,1.479000E-03,5.448900E-03,& + & 1.719000E-02,5.314000E-02,1.985700E-01,1.655700E+00,7.723700E+00,& + & 1.434300E+01,3.242700E+01,1.074600E+02,5.659200E+02,2.306200E+03,& + & 1.372400E+04,5.711800E-05,3.182700E-04,1.473100E-03,5.482300E-03,& + & 1.553100E-02,3.905100E-02,1.024100E-01,3.515200E-01,2.162300E+00,& + & 7.471300E+00,1.193500E+01,2.473700E+01,8.066700E+01,4.245100E+02,& + & 1.729700E+03,1.029300E+04,8.794600E-05,5.005400E-04,2.094300E-03,& + & 6.997600E-03,1.861400E-02,4.426300E-02,1.137900E-01,3.889700E-01,& + & 2.285700E+00,7.948600E+00,1.260600E+01,2.094800E+01,5.508100E+01,& + & 2.831000E+02,1.153300E+03,6.862000E+03,1.137800E-04,6.407000E-04,& + & 2.450200E-03,7.547800E-03,1.861300E-02,4.300500E-02,1.111200E-01,& + & 3.742100E-01,2.089200E+00,7.534900E+00,1.228600E+01,2.028000E+01,& + & 3.703500E+01,1.423700E+02,5.768400E+02,3.431000E+03,1.262200E-04,& + & 6.543600E-04,1.988300E-03,4.844400E-03,1.087300E-02,2.579600E-02,& + & 6.605900E-02,2.136600E-01,1.205800E+00,4.717200E+00,7.870800E+00,& + & 1.338600E+01,2.222900E+01,3.458300E+01,5.649400E+01,9.235100E+01/ + data absb(:, 381: 400) / & + & 1.492500E-05,5.874400E-05,3.263900E-04,2.284100E-03,7.814800E-03,& + & 2.445200E-02,7.504500E-02,2.819900E-01,2.292400E+00,1.056400E+01,& + & 1.953400E+01,4.350100E+01,1.429800E+02,7.478500E+02,2.991100E+03,& + & 1.717100E+04,7.366100E-05,4.099900E-04,1.903800E-03,6.926200E-03,& + & 1.944000E-02,4.889700E-02,1.292800E-01,4.435000E-01,2.665100E+00,& + & 9.111300E+00,1.533800E+01,3.278700E+01,1.073100E+02,5.609600E+02,& + & 2.243400E+03,1.287800E+04,1.099600E-04,6.176900E-04,2.578300E-03,& + & 8.441800E-03,2.240100E-02,5.347700E-02,1.381700E-01,4.702900E-01,& + & 2.729000E+00,9.260200E+00,1.433300E+01,2.491900E+01,7.196500E+01,& + & 3.740800E+02,1.495700E+03,8.585500E+03,1.390700E-04,7.655300E-04,& + & 2.897800E-03,8.767000E-03,2.160400E-02,5.016900E-02,1.293500E-01,& + & 4.355200E-01,2.399600E+00,8.418200E+00,1.340500E+01,2.171400E+01,& + & 4.278400E+01,1.872000E+02,7.480600E+02,4.292800E+03,1.487200E-04,& + & 7.260800E-04,2.153500E-03,5.098900E-03,1.134900E-02,2.704400E-02,& + & 6.952900E-02,2.247500E-01,1.250600E+00,4.806600E+00,7.954600E+00,& + & 1.335200E+01,2.169100E+01,3.314000E+01,5.416400E+01,8.867000E+01,& + & 2.090900E-05,9.349600E-05,5.448700E-04,3.328000E-03,1.096900E-02,& + & 3.380700E-02,1.025200E-01,3.882800E-01,3.074900E+00,1.395000E+01,& + & 2.590900E+01,5.689100E+01,1.849300E+02,9.569000E+02,3.746700E+03,& + & 2.078800E+04,9.367100E-05,5.240400E-04,2.425700E-03,8.659400E-03,& + & 2.413800E-02,6.059600E-02,1.611900E-01,5.546500E-01,3.233200E+00,& + & 1.122500E+01,1.979200E+01,4.277600E+01,1.387800E+02,7.177600E+02,& + & 2.810100E+03,1.559100E+04,1.349700E-04,7.543400E-04,3.139800E-03,& + & 1.011700E-02,2.672900E-02,6.411100E-02,1.667200E-01,5.669700E-01,& + & 3.216700E+00,1.071500E+01,1.635400E+01,3.041600E+01,9.264900E+01,& + & 4.786200E+02,1.873600E+03,1.039400E+04,1.662900E-04,9.036400E-04,& + & 3.399100E-03,1.010800E-02,2.484800E-02,5.819500E-02,1.505000E-01,& + & 5.055800E-01,2.743600E+00,9.379500E+00,1.457500E+01,2.325200E+01,& + & 5.072500E+01,2.394700E+02,9.369800E+02,5.197000E+03,1.701400E-04,& + & 7.923400E-04,2.301000E-03,5.317400E-03,1.175700E-02,2.801500E-02,& + & 7.314200E-02,2.363600E-01,1.299600E+00,4.877300E+00,8.016400E+00,& + & 1.326200E+01,2.110500E+01,3.172400E+01,5.191400E+01,8.492800E+01,& + & 2.942500E-05,1.453900E-04,8.649700E-04,4.700200E-03,1.508700E-02,& + & 4.572200E-02,1.362500E-01,5.194400E-01,4.018600E+00,1.793800E+01,& + & 3.345000E+01,7.292200E+01,2.337800E+02,1.191500E+03,4.558100E+03,& + & 2.448700E+04,1.176100E-04,6.629100E-04,3.058000E-03,1.074700E-02,& + & 2.981500E-02,7.440800E-02,1.986200E-01,6.855400E-01,3.881600E+00,& + & 1.395700E+01,2.527100E+01,5.478900E+01,1.754300E+02,8.937100E+02,& + & 3.418700E+03,1.836500E+04,1.633000E-04,9.141200E-04,3.786500E-03,& + & 1.206500E-02,3.172800E-02,7.631400E-02,1.995300E-01,6.795000E-01,& + & 3.750500E+00,1.222700E+01,1.910400E+01,3.753100E+01,1.170800E+02,& + & 5.959200E+02,2.279200E+03,1.224400E+04,1.954000E-04,1.056000E-03,& + & 3.956400E-03,1.161000E-02,2.836800E-02,6.719700E-02,1.744400E-01,& + & 5.859900E-01,3.113100E+00,1.043700E+01,1.581000E+01,2.527300E+01,& + & 6.116600E+01,2.981400E+02,1.139800E+03,6.121800E+03,1.902200E-04,& + & 8.529400E-04,2.429000E-03,5.505300E-03,1.210100E-02,2.872200E-02,& + & 7.674600E-02,2.484300E-01,1.350300E+00,4.955700E+00,8.039400E+00,& + & 1.311800E+01,2.048600E+01,3.034000E+01,4.973400E+01,8.125500E+01,& + & 4.096600E-05,2.193100E-04,1.303900E-03,6.421600E-03,2.029900E-02,& + & 6.050300E-02,1.775200E-01,6.780400E-01,5.143300E+00,2.252000E+01,& + & 4.220100E+01,9.187200E+01,2.900200E+02,1.448000E+03,5.412100E+03,& + & 2.817300E+04,1.460400E-04,8.282800E-04,3.818600E-03,1.318100E-02,& + & 3.655500E-02,9.088100E-02,2.421400E-01,8.358300E-01,4.644200E+00,& + & 1.720100E+01,3.178900E+01,6.899200E+01,2.176100E+02,1.086100E+03,& + & 4.059200E+03,2.113000E+04,1.953500E-04,1.096700E-03,4.521100E-03,& + & 1.429400E-02,3.750200E-02,9.035100E-02,2.371400E-01,8.078900E-01,& + & 4.334600E+00,1.382700E+01,2.277600E+01,4.645700E+01,1.452100E+02,& + & 7.242100E+02,2.706300E+03,1.408700E+04,2.265400E-04,1.223600E-03,& + & 4.565500E-03,1.327200E-02,3.228000E-02,7.712700E-02,2.013300E-01,& + & 6.768600E-01,3.508700E+00,1.149500E+01,1.719100E+01,2.816600E+01,& + & 7.397300E+01,3.622900E+02,1.353300E+03,7.043300E+03,2.087700E-04,& + & 9.084000E-04,2.538200E-03,5.659700E-03,1.237800E-02,2.924300E-02,& + & 7.994100E-02,2.613200E-01,1.402300E+00,5.025600E+00,8.038400E+00,& + & 1.292600E+01,1.984100E+01,2.898800E+01,4.763900E+01,7.766600E+01/ + data absb(:, 401: 420) / & + & 1.036300E-05,3.644800E-05,1.906200E-04,1.484600E-03,5.327000E-03,& + & 1.677800E-02,5.209900E-02,1.969900E-01,1.668200E+00,7.925200E+00,& + & 1.479900E+01,3.266700E+01,1.086200E+02,6.303100E+02,2.758700E+03,& + & 1.646900E+04,5.112800E-05,2.847000E-04,1.336400E-03,5.011500E-03,& + & 1.428500E-02,3.630900E-02,9.694100E-02,3.400100E-01,2.178600E+00,& + & 7.757500E+00,1.233400E+01,2.501800E+01,8.153700E+01,4.728000E+02,& + & 2.069100E+03,1.235200E+04,7.745700E-05,4.401700E-04,1.860300E-03,& + & 6.233000E-03,1.677500E-02,4.042100E-02,1.056300E-01,3.694800E-01,& + & 2.278600E+00,8.149200E+00,1.295100E+01,2.149800E+01,5.600800E+01,& + & 3.152900E+02,1.379600E+03,8.234400E+03,9.909900E-05,5.563000E-04,& + & 2.135400E-03,6.596900E-03,1.645300E-02,3.854000E-02,1.009700E-01,& + & 3.498500E-01,2.044700E+00,7.579100E+00,1.247000E+01,2.095500E+01,& + & 3.852500E+01,1.586700E+02,6.899800E+02,4.117200E+03,1.080700E-04,& + & 5.509700E-04,1.664300E-03,4.027100E-03,9.047400E-03,2.175700E-02,& + & 5.666800E-02,1.881200E-01,1.114400E+00,4.560800E+00,7.824800E+00,& + & 1.360300E+01,2.310800E+01,3.654600E+01,5.988300E+01,9.967500E+01,& + & 1.428700E-05,5.827800E-05,3.312100E-04,2.253000E-03,7.627600E-03,& + & 2.373200E-02,7.300900E-02,2.784600E-01,2.298100E+00,1.075600E+01,& + & 2.013400E+01,4.391200E+01,1.445100E+02,8.305600E+02,3.542700E+03,& + & 2.040200E+04,6.581000E-05,3.672700E-04,1.726700E-03,6.344900E-03,& + & 1.792700E-02,4.556700E-02,1.226600E-01,4.315500E-01,2.682300E+00,& + & 9.387100E+00,1.584500E+01,3.312300E+01,1.084700E+02,6.230000E+02,& + & 2.657100E+03,1.530200E+04,9.648500E-05,5.428500E-04,2.292700E-03,& + & 7.536200E-03,2.020700E-02,4.898700E-02,1.289000E-01,4.504100E-01,& + & 2.723900E+00,9.561200E+00,1.477800E+01,2.543100E+01,7.292700E+01,& + & 4.154300E+02,1.771600E+03,1.020100E+04,1.205600E-04,6.638000E-04,& + & 2.530000E-03,7.664800E-03,1.908300E-02,4.507600E-02,1.185000E-01,& + & 4.098700E-01,2.367300E+00,8.508300E+00,1.368200E+01,2.242200E+01,& + & 4.412100E+01,2.078800E+02,8.859800E+02,5.100600E+03,1.263100E-04,& + & 6.086400E-04,1.796000E-03,4.226700E-03,9.413200E-03,2.265400E-02,& + & 5.985900E-02,1.989100E-01,1.167500E+00,4.672100E+00,7.939000E+00,& + & 1.359100E+01,2.254100E+01,3.491200E+01,5.721400E+01,9.518200E+01,& + & 2.007800E-05,9.235800E-05,5.457000E-04,3.251000E-03,1.067300E-02,& + & 3.275400E-02,9.911000E-02,3.814000E-01,3.073800E+00,1.415100E+01,& + & 2.656300E+01,5.770100E+01,1.874200E+02,1.060800E+03,4.399700E+03,& + & 2.449900E+04,8.362200E-05,4.696200E-04,2.201100E-03,7.945800E-03,& + & 2.237300E-02,5.662100E-02,1.532200E-01,5.416800E-01,3.253600E+00,& + & 1.145500E+01,2.033600E+01,4.338500E+01,1.406600E+02,7.956600E+02,& + & 3.299800E+03,1.837400E+04,1.182200E-04,6.636800E-04,2.793100E-03,& + & 9.060300E-03,2.417200E-02,5.890000E-02,1.560800E-01,5.465800E-01,& + & 3.217000E+00,1.102600E+01,1.692600E+01,3.100800E+01,9.393900E+01,& + & 5.305500E+02,2.200000E+03,1.224900E+04,1.436400E-04,7.829500E-04,& + & 2.972300E-03,8.862900E-03,2.194000E-02,5.246500E-02,1.386000E-01,& + & 4.796800E-01,2.718500E+00,9.561500E+00,1.493300E+01,2.397400E+01,& + & 5.200300E+01,2.654400E+02,1.100200E+03,6.124600E+03,1.436600E-04,& + & 6.620100E-04,1.912900E-03,4.398900E-03,9.728400E-03,2.332500E-02,& + & 6.308900E-02,2.102700E-01,1.224400E+00,4.774200E+00,8.019400E+00,& + & 1.351700E+01,2.191700E+01,3.332000E+01,5.465800E+01,9.075900E+01,& + & 2.821300E-05,1.425300E-04,8.543500E-04,4.551600E-03,1.461400E-02,& + & 4.419700E-02,1.313600E-01,5.081700E-01,4.011900E+00,1.813500E+01,& + & 3.414300E+01,7.427500E+01,2.381400E+02,1.318500E+03,5.315800E+03,& + & 2.863200E+04,1.049500E-04,5.935400E-04,2.779400E-03,9.856900E-03,& + & 2.773000E-02,6.986100E-02,1.891800E-01,6.702800E-01,3.904100E+00,& + & 1.415300E+01,2.581800E+01,5.580600E+01,1.787000E+02,9.889900E+02,& + & 3.986900E+03,2.147400E+04,1.428800E-04,8.040500E-04,3.367800E-03,& + & 1.082800E-02,2.879500E-02,7.037900E-02,1.875000E-01,6.579500E-01,& + & 3.759500E+00,1.255700E+01,1.964800E+01,3.831300E+01,1.192700E+02,& + & 6.594500E+02,2.658100E+03,1.431600E+04,1.683900E-04,9.151800E-04,& + & 3.460700E-03,1.020600E-02,2.511600E-02,6.069800E-02,1.614600E-01,& + & 5.598200E-01,3.096200E+00,1.066500E+01,1.630700E+01,2.600500E+01,& + & 6.262600E+01,3.299000E+02,1.329200E+03,7.157900E+03,1.598200E-04,& + & 7.106000E-04,2.013900E-03,4.546700E-03,9.992600E-03,2.382600E-02,& + & 6.600000E-02,2.226700E-01,1.282400E+00,4.885100E+00,8.059000E+00,& + & 1.338300E+01,2.125400E+01,3.176900E+01,5.221500E+01,8.644400E+01/ + data absb(:, 421: 440) / & + & 3.915000E-05,2.132900E-04,1.270100E-03,6.180500E-03,1.957900E-02,& + & 5.824300E-02,1.713300E-01,6.609200E-01,5.134000E+00,2.275700E+01,& + & 4.296900E+01,9.387100E+01,2.971200E+02,1.602000E+03,6.271000E+03,& + & 3.272300E+04,1.302500E-04,7.412400E-04,3.471500E-03,1.209100E-02,& + & 3.408100E-02,8.569900E-02,2.312000E-01,8.181100E-01,4.667800E+00,& + & 1.740900E+01,3.236800E+01,7.050000E+01,2.229400E+02,1.201600E+03,& + & 4.703300E+03,2.454200E+04,1.708600E-04,9.634100E-04,4.027900E-03,& + & 1.283900E-02,3.411000E-02,8.380600E-02,2.237500E-01,7.846600E-01,& + & 4.355000E+00,1.416100E+01,2.328200E+01,4.752100E+01,1.487700E+02,& + & 8.011600E+02,3.135700E+03,1.636100E+04,1.949100E-04,1.059900E-03,& + & 3.993700E-03,1.168800E-02,2.868400E-02,6.987500E-02,1.872100E-01,& + & 6.500300E-01,3.503800E+00,1.173000E+01,1.779400E+01,2.893000E+01,& + & 7.595500E+01,4.007600E+02,1.568000E+03,8.180700E+03,1.746800E-04,& + & 7.549900E-04,2.100000E-03,4.664900E-03,1.020700E-02,2.418800E-02,& + & 6.838400E-02,2.356900E-01,1.342500E+00,4.973800E+00,8.093100E+00,& + & 1.317800E+01,2.055900E+01,3.027400E+01,4.987200E+01,8.228700E+01,& + & 1.013000E-05,3.709100E-05,2.004300E-04,1.519900E-03,5.353500E-03,& + & 1.678800E-02,5.229800E-02,2.003800E-01,1.722100E+00,8.326000E+00,& + & 1.577200E+01,3.415600E+01,1.126300E+02,7.187800E+02,3.364500E+03,& + & 2.007800E+04,4.618300E-05,2.571100E-04,1.225800E-03,4.653600E-03,& + & 1.335300E-02,3.435900E-02,9.347700E-02,3.355800E-01,2.229700E+00,& + & 8.144500E+00,1.309700E+01,2.615300E+01,8.455900E+01,5.391600E+02,& + & 2.523500E+03,1.505800E+04,6.854700E-05,3.892200E-04,1.668900E-03,& + & 5.618400E-03,1.530000E-02,3.744700E-02,9.963100E-02,3.574400E-01,& + & 2.303800E+00,8.511500E+00,1.346400E+01,2.242900E+01,5.824000E+01,& + & 3.595300E+02,1.682500E+03,1.003900E+04,8.651600E-05,4.846900E-04,& + & 1.876600E-03,5.811100E-03,1.466600E-02,3.489800E-02,9.304100E-02,& + & 3.311100E-01,2.034200E+00,7.707500E+00,1.278300E+01,2.171300E+01,& + & 4.036300E+01,1.808200E+02,8.414500E+02,5.019500E+03,9.236000E-05,& + & 4.635900E-04,1.391600E-03,3.344600E-03,7.512900E-03,1.824100E-02,& + & 4.865300E-02,1.658600E-01,1.036400E+00,4.411200E+00,7.781200E+00,& + & 1.378800E+01,2.386700E+01,3.823100E+01,6.284700E+01,1.060900E+02,& + & 1.406000E-05,5.931000E-05,3.435000E-04,2.269100E-03,7.638000E-03,& + & 2.367400E-02,7.274400E-02,2.817000E-01,2.363200E+00,1.123900E+01,& + & 2.134400E+01,4.602700E+01,1.503100E+02,9.450200E+02,4.278200E+03,& + & 2.463800E+04,5.944500E-05,3.323900E-04,1.585000E-03,5.902700E-03,& + & 1.685300E-02,4.326000E-02,1.185400E-01,4.284900E-01,2.746200E+00,& + & 9.805900E+00,1.678500E+01,3.471100E+01,1.128300E+02,7.088400E+02,& + & 3.208800E+03,1.847900E+04,8.524100E-05,4.807000E-04,2.058600E-03,& + & 6.823900E-03,1.847300E-02,4.555400E-02,1.222400E-01,4.394500E-01,& + & 2.761100E+00,9.979600E+00,1.550500E+01,2.656000E+01,7.590800E+01,& + & 4.726600E+02,2.139300E+03,1.231900E+04,1.048100E-04,5.782000E-04,& + & 2.228800E-03,6.773300E-03,1.701000E-02,4.097000E-02,1.099600E-01,& + & 3.915900E-01,2.370300E+00,8.736900E+00,1.410800E+01,2.323400E+01,& + & 4.613500E+01,2.365000E+02,1.069900E+03,6.159500E+03,1.071900E-04,& + & 5.100200E-04,1.496700E-03,3.501800E-03,7.796800E-03,1.887400E-02,& + & 5.150700E-02,1.764500E-01,1.096700E+00,4.550600E+00,7.923200E+00,& + & 1.379500E+01,2.326300E+01,3.642100E+01,5.985000E+01,1.008400E+02,& + & 1.978900E-05,9.345300E-05,5.586800E-04,3.248800E-03,1.064700E-02,& + & 3.261100E-02,9.830700E-02,3.838600E-01,3.154500E+00,1.473100E+01,& + & 2.799900E+01,6.062200E+01,1.960600E+02,1.204800E+03,5.270600E+03,& + & 2.932900E+04,7.554200E-05,4.255600E-04,2.025300E-03,7.407200E-03,& + & 2.113200E-02,5.399100E-02,1.485400E-01,5.393900E-01,3.333200E+00,& + & 1.191600E+01,2.142900E+01,4.558200E+01,1.471500E+02,9.037000E+02,& + & 3.953100E+03,2.199700E+04,1.043300E-04,5.885100E-04,2.509600E-03,& + & 8.232100E-03,2.220200E-02,5.499500E-02,1.486600E-01,5.366300E-01,& + & 3.269700E+00,1.149500E+01,1.775900E+01,3.248800E+01,9.828000E+01,& + & 6.025800E+02,2.635500E+03,1.466400E+04,1.245400E-04,6.823800E-04,& + & 2.621100E-03,7.863200E-03,1.961200E-02,4.781900E-02,1.294300E-01,& + & 4.624000E-01,2.733800E+00,9.874800E+00,1.549200E+01,2.492100E+01,& + & 5.441900E+01,3.014500E+02,1.318000E+03,7.332200E+03,1.211700E-04,& + & 5.529300E-04,1.589300E-03,3.637600E-03,8.043400E-03,1.935200E-02,& + & 5.414100E-02,1.879700E-01,1.159700E+00,4.701100E+00,8.011400E+00,& + & 1.373400E+01,2.259800E+01,3.466000E+01,5.701200E+01,9.574000E+01/ + data absb(:, 441: 460) / & + & 2.773700E-05,1.431900E-04,8.617300E-04,4.511900E-03,1.451000E-02,& + & 4.382300E-02,1.303000E-01,5.094400E-01,4.117600E+00,1.885600E+01,& + & 3.584800E+01,7.832100E+01,2.506500E+02,1.496600E+03,6.323600E+03,& + & 3.403400E+04,9.487100E-05,5.379200E-04,2.563600E-03,9.188600E-03,& + & 2.628900E-02,6.700000E-02,1.839300E-01,6.690400E-01,4.003100E+00,& + & 1.471000E+01,2.709600E+01,5.885700E+01,1.880900E+02,1.122500E+03,& + & 4.742800E+03,2.552500E+04,1.261300E-04,7.134100E-04,3.032000E-03,& + & 9.859500E-03,2.655000E-02,6.612300E-02,1.794600E-01,6.490900E-01,& + & 3.832700E+00,1.306400E+01,2.056200E+01,4.036800E+01,1.255300E+02,& + & 7.484600E+02,3.162000E+03,1.701700E+04,1.457800E-04,7.980700E-04,& + & 3.053200E-03,9.082300E-03,2.255300E-02,5.549500E-02,1.516700E-01,& + & 5.434200E-01,3.128200E+00,1.100800E+01,1.703100E+01,2.708000E+01,& + & 6.587500E+01,3.744000E+02,1.581200E+03,8.508500E+03,1.342100E-04,& + & 5.920400E-04,1.669200E-03,3.753000E-03,8.245000E-03,1.971700E-02,& + & 5.631600E-02,2.003200E-01,1.225000E+00,4.832800E+00,8.083600E+00,& + & 1.359900E+01,2.188900E+01,3.296400E+01,5.432200E+01,9.084900E+01,& + & 3.834500E-05,2.125100E-04,1.264800E-03,6.086200E-03,1.936700E-02,& + & 5.749600E-02,1.701700E-01,6.611000E-01,5.271000E+00,2.370500E+01,& + & 4.500400E+01,9.930100E+01,3.149700E+02,1.818000E+03,7.412200E+03,& + & 3.865700E+04,1.177800E-04,6.725400E-04,3.200600E-03,1.129500E-02,& + & 3.237100E-02,8.256200E-02,2.258300E-01,8.171900E-01,4.791000E+00,& + & 1.812400E+01,3.388900E+01,7.459200E+01,2.363300E+02,1.363600E+03,& + & 5.559200E+03,2.899300E+04,1.508800E-04,8.544600E-04,3.632900E-03,& + & 1.170900E-02,3.154600E-02,7.921600E-02,2.151600E-01,7.764500E-01,& + & 4.453800E+00,1.471600E+01,2.434700E+01,5.025600E+01,1.576900E+02,& + & 9.091800E+02,3.706300E+03,1.932900E+04,1.686900E-04,9.242400E-04,& + & 3.528900E-03,1.042100E-02,2.586800E-02,6.420500E-02,1.769000E-01,& + & 6.346400E-01,3.554800E+00,1.211900E+01,1.858900E+01,3.028600E+01,& + & 8.046200E+01,4.547700E+02,1.853400E+03,9.664300E+03,1.461200E-04,& + & 6.278500E-04,1.737300E-03,3.843700E-03,8.408200E-03,1.997400E-02,& + & 5.800300E-02,2.134300E-01,1.294200E+00,4.925700E+00,8.142900E+00,& + & 1.338400E+01,2.114900E+01,3.133800E+01,5.175400E+01,8.616900E+01,& + & 1.046800E-05,3.986400E-05,2.217200E-04,1.631100E-03,5.674600E-03,& + & 1.772900E-02,5.523700E-02,2.145700E-01,1.873300E+00,9.219600E+00,& + & 1.771600E+01,3.807600E+01,1.237800E+02,8.635200E+02,4.297100E+03,& + & 2.554800E+04,4.267900E-05,2.371200E-04,1.151700E-03,4.464800E-03,& + & 1.293600E-02,3.372600E-02,9.353000E-02,3.449100E-01,2.364300E+00,& + & 8.811600E+00,1.451100E+01,2.900500E+01,9.293000E+01,6.477000E+02,& + & 3.223000E+03,1.916100E+04,6.153300E-05,3.491100E-04,1.527300E-03,& + & 5.202700E-03,1.434300E-02,3.575600E-02,9.708000E-02,3.579900E-01,& + & 2.403700E+00,9.146500E+00,1.447800E+01,2.415900E+01,6.368000E+01,& + & 4.318900E+02,2.148800E+03,1.277400E+04,7.610100E-05,4.265400E-04,& + & 1.676400E-03,5.222200E-03,1.334300E-02,3.235100E-02,8.788500E-02,& + & 3.219900E-01,2.083100E+00,8.062200E+00,1.339600E+01,2.277200E+01,& + & 4.320900E+01,2.168100E+02,1.074600E+03,6.387000E+03,7.893600E-05,& + & 3.899800E-04,1.163700E-03,2.776800E-03,6.230300E-03,1.521700E-02,& + & 4.180100E-02,1.467700E-01,9.707100E-01,4.287300E+00,7.747800E+00,& + & 1.395000E+01,2.449400E+01,3.962600E+01,6.533100E+01,1.114600E+02,& + & 1.460200E-05,6.359200E-05,3.747800E-04,2.398800E-03,8.057700E-03,& + & 2.494800E-02,7.634200E-02,3.002500E-01,2.562100E+00,1.239200E+01,& + & 2.385300E+01,5.138600E+01,1.659800E+02,1.133800E+03,5.412100E+03,& + & 3.105200E+04,5.501500E-05,3.079700E-04,1.494900E-03,5.677600E-03,& + & 1.644700E-02,4.268600E-02,1.191700E-01,4.429500E-01,2.916300E+00,& + & 1.060700E+01,1.863200E+01,3.869600E+01,1.245800E+02,8.503900E+02,& + & 4.059200E+03,2.328900E+04,7.647200E-05,4.328300E-04,1.887500E-03,& + & 6.354500E-03,1.742500E-02,4.373400E-02,1.198700E-01,4.444000E-01,& + & 2.891700E+00,1.070400E+01,1.676600E+01,2.895300E+01,8.365000E+01,& + & 5.670200E+02,2.706300E+03,1.552600E+04,9.191200E-05,5.092600E-04,& + & 1.996000E-03,6.121700E-03,1.553200E-02,3.816200E-02,1.048500E-01,& + & 3.852800E-01,2.441300E+00,9.236700E+00,1.487400E+01,2.450500E+01,& + & 4.978900E+01,2.836600E+02,1.353400E+03,7.763000E+03,9.092500E-05,& + & 4.274100E-04,1.247400E-03,2.901100E-03,6.455600E-03,1.567000E-02,& + & 4.416200E-02,1.573300E-01,1.037100E+00,4.473300E+00,7.897400E+00,& + & 1.397300E+01,2.385700E+01,3.764900E+01,6.203400E+01,1.055500E+02/ + data absb(:, 461: 480) / & + & 2.056500E-05,9.960300E-05,6.001900E-04,3.414500E-03,1.117400E-02,& + & 3.422500E-02,1.029700E-01,4.070600E-01,3.418500E+00,1.621100E+01,& + & 3.118200E+01,6.784300E+01,2.178800E+02,1.443600E+03,6.614100E+03,& + & 3.667400E+04,7.004500E-05,3.950600E-04,1.922800E-03,7.141400E-03,& + & 2.073900E-02,5.367600E-02,1.498700E-01,5.590900E-01,3.545800E+00,& + & 1.298300E+01,2.376800E+01,5.100900E+01,1.635100E+02,1.082700E+03,& + & 4.960700E+03,2.750500E+04,9.375400E-05,5.313700E-04,2.309400E-03,& + & 7.703000E-03,2.107800E-02,5.319400E-02,1.466500E-01,5.463500E-01,& + & 3.439200E+00,1.230900E+01,1.922300E+01,3.591800E+01,1.091600E+02,& + & 7.219300E+02,3.307300E+03,1.817200E+04,1.091400E-04,6.025800E-04,& + & 2.352300E-03,7.144400E-03,1.802000E-02,4.473500E-02,1.243500E-01,& + & 4.593200E-01,2.832100E+00,1.044900E+01,1.649900E+01,2.643300E+01,& + & 5.954800E+01,3.611200E+02,1.653900E+03,9.168400E+03,1.022600E-04,& + & 4.619500E-04,1.321000E-03,3.009300E-03,6.644100E-03,1.603100E-02,& + & 4.613900E-02,1.688800E-01,1.106800E+00,4.651100E+00,8.005500E+00,& + & 1.392000E+01,2.315200E+01,3.573800E+01,5.894700E+01,9.983300E+01,& + & 2.874100E-05,1.514200E-04,9.118600E-04,4.703300E-03,1.516500E-02,& + & 4.578400E-02,1.365700E-01,5.386500E-01,4.463000E+00,2.076200E+01,& + & 3.983400E+01,8.781200E+01,2.805600E+02,1.791900E+03,7.875800E+03,& + & 4.227800E+04,8.817700E-05,5.007100E-04,2.439800E-03,8.885200E-03,& + & 2.591600E-02,6.703800E-02,1.865400E-01,6.945800E-01,4.272500E+00,& + & 1.610000E+01,3.005400E+01,6.599000E+01,2.105100E+02,1.344000E+03,& + & 5.906900E+03,3.170800E+04,1.136100E-04,6.451800E-04,2.801600E-03,& + & 9.252600E-03,2.534600E-02,6.446800E-02,1.781000E-01,6.640000E-01,& + & 4.047200E+00,1.399600E+01,2.240400E+01,4.499500E+01,1.404800E+02,& + & 8.961100E+02,3.938100E+03,2.113900E+04,1.278300E-04,7.055400E-04,& + & 2.747100E-03,8.285500E-03,2.086100E-02,5.225600E-02,1.468000E-01,& + & 5.439400E-01,3.258300E+00,1.165900E+01,1.816500E+01,2.907100E+01,& + & 7.306900E+01,4.482300E+02,1.969300E+03,1.056900E+04,1.127700E-04,& + & 4.939500E-04,1.384300E-03,3.097700E-03,6.803400E-03,1.629500E-02,& + & 4.770400E-02,1.812900E-01,1.181300E+00,4.787800E+00,8.113800E+00,& + & 1.375300E+01,2.240000E+01,3.391100E+01,5.602700E+01,9.441300E+01,& + & 3.955100E-05,2.229700E-04,1.323100E-03,6.290700E-03,2.018800E-02,& + & 5.981700E-02,1.784200E-01,6.983600E-01,5.720100E+00,2.615000E+01,& + & 4.993800E+01,1.116000E+02,3.548500E+02,2.176600E+03,9.171700E+03,& + & 4.772500E+04,1.096500E-04,6.283000E-04,3.046200E-03,1.096400E-02,& + & 3.199900E-02,8.295200E-02,2.305700E-01,8.497900E-01,5.133900E+00,& + & 1.990800E+01,3.758800E+01,8.382400E+01,2.662400E+02,1.632500E+03,& + & 6.878800E+03,3.579400E+04,1.362500E-04,7.744200E-04,3.361300E-03,& + & 1.103400E-02,3.025900E-02,7.773700E-02,2.150900E-01,7.975400E-01,& + & 4.720600E+00,1.581900E+01,2.669000E+01,5.634000E+01,1.776300E+02,& + & 1.088500E+03,4.586000E+03,2.386300E+04,1.481600E-04,8.172400E-04,& + & 3.185500E-03,9.538100E-03,2.405500E-02,6.091800E-02,1.725300E-01,& + & 6.395600E-01,3.721700E+00,1.285900E+01,1.978800E+01,3.305000E+01,& + & 9.017200E+01,5.444200E+02,2.293200E+03,1.193100E+04,1.224000E-04,& + & 5.226000E-04,1.437300E-03,3.169800E-03,6.926800E-03,1.648500E-02,& + & 4.894700E-02,1.942400E-01,1.257200E+00,4.919800E+00,8.148100E+00,& + & 1.357300E+01,2.158800E+01,3.216800E+01,5.326600E+01,8.928900E+01,& + & 1.098000E-05,4.343000E-05,2.476800E-04,1.764600E-03,6.089500E-03,& + & 1.900300E-02,5.902700E-02,2.330100E-01,2.065300E+00,1.035900E+01,& + & 2.015100E+01,4.342200E+01,1.390600E+02,1.053400E+03,5.522900E+03,& + & 3.264800E+04,3.986000E-05,2.211100E-04,1.093700E-03,4.339200E-03,& + & 1.273200E-02,3.358300E-02,9.496900E-02,3.600200E-01,2.533700E+00,& + & 9.613700E+00,1.625000E+01,3.290900E+01,1.043900E+02,7.900900E+02,& + & 4.142300E+03,2.448600E+04,5.559600E-05,3.157300E-04,1.408900E-03,& + & 4.885700E-03,1.362200E-02,3.458300E-02,9.594300E-02,3.644700E-01,& + & 2.538600E+00,9.875200E+00,1.578600E+01,2.635400E+01,7.103900E+01,& + & 5.268200E+02,2.761700E+03,1.632400E+04,6.715400E-05,3.771400E-04,& + & 1.509100E-03,4.744600E-03,1.225800E-02,3.030600E-02,8.419400E-02,& + & 3.180600E-01,2.160000E+00,8.583000E+00,1.415300E+01,2.401100E+01,& + & 4.659500E+01,2.639700E+02,1.381100E+03,8.162000E+03,6.739600E-05,& + & 3.279500E-04,9.725600E-04,2.305400E-03,5.165600E-03,1.265400E-02,& + & 3.581200E-02,1.306100E-01,9.168000E-01,4.217400E+00,7.702400E+00,& + & 1.410100E+01,2.500400E+01,4.072500E+01,6.731100E+01,1.157900E+02/ + data absb(:, 481: 500) / & + & 1.537800E-05,6.908300E-05,4.124800E-04,2.565100E-03,8.599600E-03,& + & 2.666300E-02,8.120100E-02,3.239100E-01,2.821600E+00,1.387700E+01,& + & 2.702200E+01,5.874900E+01,1.876000E+02,1.380200E+03,6.890900E+03,& + & 3.933300E+04,5.148100E-05,2.881600E-04,1.429200E-03,5.529500E-03,& + & 1.629800E-02,4.283700E-02,1.215100E-01,4.637800E-01,3.130600E+00,& + & 1.163100E+01,2.093000E+01,4.420200E+01,1.408000E+02,1.035200E+03,& + & 5.168300E+03,2.950000E+04,6.920700E-05,3.927600E-04,1.747700E-03,& + & 5.992900E-03,1.668100E-02,4.259600E-02,1.192200E-01,4.562800E-01,& + & 3.066900E+00,1.153800E+01,1.824300E+01,3.226800E+01,9.431100E+01,& + & 6.902400E+02,3.445700E+03,1.966600E+04,8.102400E-05,4.516000E-04,& + & 1.800600E-03,5.595100E-03,1.436600E-02,3.591500E-02,1.013000E-01,& + & 3.849400E-01,2.546300E+00,9.857600E+00,1.587400E+01,2.600800E+01,& + & 5.449600E+01,3.452700E+02,1.723100E+03,9.833300E+03,7.710500E-05,& + & 3.581300E-04,1.039400E-03,2.403600E-03,5.339200E-03,1.299800E-02,& + & 3.761700E-02,1.411600E-01,9.893600E-01,4.428500E+00,7.876600E+00,& + & 1.412900E+01,2.432700E+01,3.860300E+01,6.375900E+01,1.092800E+02,& + & 2.164100E-05,1.074000E-04,6.504700E-04,3.626000E-03,1.187100E-02,& + & 3.638500E-02,1.095500E-01,4.376200E-01,3.764800E+00,1.814000E+01,& + & 3.529200E+01,7.768200E+01,2.477400E+02,1.755700E+03,8.353000E+03,& + & 4.611400E+04,6.572300E-05,3.707500E-04,1.846700E-03,6.975900E-03,& + & 2.066600E-02,5.425600E-02,1.535800E-01,5.871600E-01,3.815100E+00,& + & 1.438000E+01,2.677600E+01,5.839800E+01,1.859000E+02,1.316900E+03,& + & 6.264900E+03,3.458600E+04,8.500500E-05,4.837200E-04,2.148400E-03,& + & 7.290300E-03,2.030200E-02,5.226900E-02,1.468100E-01,5.642000E-01,& + & 3.661900E+00,1.326900E+01,2.104500E+01,4.056900E+01,1.240800E+02,& + & 8.780200E+02,4.176800E+03,2.305700E+04,9.617200E-05,5.351300E-04,& + & 2.127500E-03,6.564600E-03,1.678700E-02,4.238200E-02,1.211700E-01,& + & 4.630000E-01,2.970200E+00,1.116000E+01,1.766600E+01,2.835500E+01,& + & 6.646700E+01,4.391800E+02,2.088600E+03,1.152900E+04,8.625800E-05,& + & 3.862000E-04,1.097900E-03,2.487600E-03,5.489900E-03,1.326000E-02,& + & 3.905800E-02,1.526600E-01,1.068500E+00,4.597000E+00,8.037000E+00,& + & 1.403700E+01,2.358400E+01,3.656500E+01,6.045200E+01,1.030500E+02,& + & 3.013100E-05,1.619600E-04,9.745700E-04,4.951500E-03,1.605900E-02,& + & 4.842500E-02,1.454000E-01,5.784400E-01,4.920100E+00,2.326400E+01,& + & 4.505000E+01,1.005300E+02,3.210900E+02,2.178900E+03,9.874600E+03,& + & 5.280900E+04,8.289100E-05,4.719300E-04,2.347300E-03,8.715100E-03,& + & 2.590100E-02,6.808400E-02,1.925600E-01,7.305800E-01,4.618000E+00,& + & 1.792700E+01,3.394000E+01,7.553400E+01,2.409100E+02,1.634200E+03,& + & 7.406100E+03,3.960700E+04,1.032900E-04,5.884300E-04,2.614000E-03,& + & 8.792700E-03,2.454700E-02,6.383700E-02,1.796600E-01,6.889400E-01,& + & 4.325900E+00,1.511800E+01,2.481100E+01,5.115800E+01,1.607400E+02,& + & 1.089600E+03,4.937500E+03,2.640400E+04,1.128300E-04,6.274500E-04,& + & 2.494700E-03,7.638500E-03,1.954700E-02,4.993400E-02,1.442100E-01,& + & 5.524900E-01,3.435800E+00,1.246100E+01,1.943400E+01,3.176800E+01,& + & 8.269800E+01,5.449900E+02,2.469000E+03,1.320200E+04,9.476700E-05,& + & 4.119500E-04,1.148200E-03,2.557400E-03,5.611900E-03,1.345500E-02,& + & 4.023600E-02,1.648900E-01,1.150200E+00,4.749300E+00,8.131200E+00,& + & 1.390900E+01,2.276800E+01,3.462500E+01,5.734000E+01,9.718400E+01,& + & 4.127600E-05,2.364700E-04,1.399000E-03,6.559800E-03,2.131300E-02,& + & 6.302300E-02,1.898200E-01,7.501200E-01,6.308800E+00,2.941800E+01,& + & 5.649700E+01,1.278000E+02,4.087200E+02,2.644600E+03,1.142900E+04,& + & 5.928400E+04,1.032600E-04,5.947900E-04,2.932400E-03,1.078200E-02,& + & 3.208200E-02,8.460800E-02,2.393800E-01,8.952100E-01,5.573900E+00,& + & 2.230300E+01,4.250600E+01,9.598800E+01,3.066400E+02,1.983600E+03,& + & 8.571700E+03,4.446300E+04,1.242700E-04,7.086600E-04,3.139900E-03,& + & 1.054000E-02,2.945400E-02,7.739900E-02,2.188900E-01,8.305600E-01,& + & 5.061900E+00,1.722700E+01,2.979000E+01,6.434400E+01,2.045600E+02,& + & 1.322500E+03,5.714600E+03,2.931100E+04,1.310400E-04,7.279400E-04,& + & 2.898400E-03,8.833200E-03,2.266400E-02,5.869400E-02,1.708400E-01,& + & 6.536900E-01,3.944400E+00,1.374600E+01,2.118800E+01,3.670500E+01,& + & 1.032700E+02,6.614500E+02,2.857500E+03,1.482100E+04,1.024100E-04,& + & 4.350600E-04,1.189800E-03,2.614200E-03,5.707000E-03,1.358900E-02,& + & 4.118100E-02,1.775800E-01,1.233300E+00,4.908700E+00,8.140900E+00,& + & 1.375700E+01,2.187900E+01,3.278400E+01,5.442000E+01,9.168700E+01/ + data absb(:, 501: 520) / & + & 1.174800E-05,4.822000E-05,2.807800E-04,1.937400E-03,6.651500E-03,& + & 2.079400E-02,6.421900E-02,2.579000E-01,2.327200E+00,1.185900E+01,& + & 2.340100E+01,5.097200E+01,1.610400E+02,1.312400E+03,7.186800E+03,& + & 4.221200E+04,3.774900E-05,2.090600E-04,1.055200E-03,4.287400E-03,& + & 1.279600E-02,3.416400E-02,9.825500E-02,3.831200E-01,2.758300E+00,& + & 1.064000E+01,1.853300E+01,3.847400E+01,1.208700E+02,9.843600E+02,& + & 5.390200E+03,3.165900E+04,5.077700E-05,2.883200E-04,1.315600E-03,& + & 4.659100E-03,1.318800E-02,3.404900E-02,9.662500E-02,3.788300E-01,& + & 2.725400E+00,1.077300E+01,1.737100E+01,2.950900E+01,8.164100E+01,& + & 6.563300E+02,3.593600E+03,2.110600E+04,5.961600E-05,3.359600E-04,& + & 1.371000E-03,4.371700E-03,1.144200E-02,2.878900E-02,8.209900E-02,& + & 3.207100E-01,2.276000E+00,9.256000E+00,1.519300E+01,2.560800E+01,& + & 5.100200E+01,3.284300E+02,1.797100E+03,1.055300E+04,5.744600E-05,& + & 2.757000E-04,8.128000E-04,1.913000E-03,4.278100E-03,1.050600E-02,& + & 3.051900E-02,1.169100E-01,8.751400E-01,4.165100E+00,7.683900E+00,& + & 1.423600E+01,2.540200E+01,4.154800E+01,6.881000E+01,1.191300E+02,& + & 1.650100E-05,7.636800E-05,4.602700E-04,2.794900E-03,9.338400E-03,& + & 2.902000E-02,8.824600E-02,3.566900E-01,3.177900E+00,1.588400E+01,& + & 3.130800E+01,6.897800E+01,2.184500E+02,1.717700E+03,8.885300E+03,& + & 5.042700E+04,4.891500E-05,2.732900E-04,1.389100E-03,5.480300E-03,& + & 1.648500E-02,4.393400E-02,1.263300E-01,4.952400E-01,3.416100E+00,& + & 1.301100E+01,2.400900E+01,5.187300E+01,1.639400E+02,1.288300E+03,& + & 6.664100E+03,3.782000E+04,6.336300E-05,3.602300E-04,1.640500E-03,& + & 5.740800E-03,1.626600E-02,4.235800E-02,1.208800E-01,4.774600E-01,& + & 3.306600E+00,1.257200E+01,2.009400E+01,3.698300E+01,1.095400E+02,& + & 8.590000E+02,4.442900E+03,2.521400E+04,7.190100E-05,4.033000E-04,& + & 1.640400E-03,5.190200E-03,1.351700E-02,3.436100E-02,9.970500E-02,& + & 3.923600E-01,2.698200E+00,1.063500E+01,1.715500E+01,2.794000E+01,& + & 6.114600E+01,4.296600E+02,2.221700E+03,1.260700E+04,6.535300E-05,& + & 3.001900E-04,8.660500E-04,1.990400E-03,4.416700E-03,1.076100E-02,& + & 3.185500E-02,1.274400E-01,9.563900E-01,4.371500E+00,7.905900E+00,& + & 1.422500E+01,2.468800E+01,3.930300E+01,6.505300E+01,1.121000E+02,& + & 2.318800E-05,1.178000E-04,7.152700E-04,3.910300E-03,1.284600E-02,& + & 3.940900E-02,1.191200E-01,4.806800E-01,4.241100E+00,2.078200E+01,& + & 4.082900E+01,9.119600E+01,2.903900E+02,2.183200E+03,1.068400E+04,& + & 5.868400E+04,6.262400E-05,3.533200E-04,1.801500E-03,6.941100E-03,& + & 2.099900E-02,5.598100E-02,1.608300E-01,6.277700E-01,4.178600E+00,& + & 1.626000E+01,3.085600E+01,6.853600E+01,2.178900E+02,1.637500E+03,& + & 8.012800E+03,4.401300E+04,7.807000E-05,4.450600E-04,2.026400E-03,& + & 7.012200E-03,1.994300E-02,5.244900E-02,1.500100E-01,5.935900E-01,& + & 3.962600E+00,1.450200E+01,2.345500E+01,4.696400E+01,1.453900E+02,& + & 1.091800E+03,5.342000E+03,2.934200E+04,8.548100E-05,4.790000E-04,& + & 1.947300E-03,6.113400E-03,1.591000E-02,4.093100E-02,1.202800E-01,& + & 4.760100E-01,3.165100E+00,1.204700E+01,1.907600E+01,3.104500E+01,& + & 7.623300E+01,5.460500E+02,2.671300E+03,1.467100E+04,7.277600E-05,& + & 3.229500E-04,9.125700E-04,2.057000E-03,4.534100E-03,1.095400E-02,& + & 3.295300E-02,1.387400E-01,1.043100E+00,4.544900E+00,8.058700E+00,& + & 1.415600E+01,2.389700E+01,3.716000E+01,6.155900E+01,1.054600E+02,& + & 3.215600E-05,1.761300E-04,1.057900E-03,5.289800E-03,1.732700E-02,& + & 5.218400E-02,1.580200E-01,6.346500E-01,5.546200E+00,2.673100E+01,& + & 5.218900E+01,1.180600E+02,3.788500E+02,2.706300E+03,1.254500E+04,& + & 6.679300E+04,7.917900E-05,4.519800E-04,2.293600E-03,8.707200E-03,& + & 2.639900E-02,7.059500E-02,2.030000E-01,7.824400E-01,5.083600E+00,& + & 2.043600E+01,3.927200E+01,8.868400E+01,2.842400E+02,2.029800E+03,& + & 9.408700E+03,5.009500E+04,9.519400E-05,5.434900E-04,2.471100E-03,& + & 8.506400E-03,2.424700E-02,6.445600E-02,1.852800E-01,7.278400E-01,& + & 4.697800E+00,1.658500E+01,2.809900E+01,5.968800E+01,1.896300E+02,& + & 1.353300E+03,6.272600E+03,3.339600E+04,1.005200E-04,5.628400E-04,& + & 2.290400E-03,7.143800E-03,1.865100E-02,4.867400E-02,1.444200E-01,& + & 5.721500E-01,3.680500E+00,1.345400E+01,2.100800E+01,3.547900E+01,& + & 9.648100E+01,6.768600E+02,3.136500E+03,1.669800E+04,7.957100E-05,& + & 3.435700E-04,9.524900E-04,2.111500E-03,4.630300E-03,1.110000E-02,& + & 3.385000E-02,1.506500E-01,1.130900E+00,4.744500E+00,8.127400E+00,& + & 1.405300E+01,2.298700E+01,3.513000E+01,5.829500E+01,9.921000E+01/ + data absb(:, 521: 540) / & + & 4.381500E-05,2.551500E-04,1.503700E-03,6.952700E-03,2.289500E-02,& + & 6.772300E-02,2.059600E-01,8.246300E-01,7.117400E+00,3.398300E+01,& + & 6.558600E+01,1.502600E+02,4.853900E+02,3.280600E+03,1.443700E+04,& + & 7.457500E+04,9.878600E-05,5.725900E-04,2.871700E-03,1.078800E-02,& + & 3.282900E-02,8.806600E-02,2.539200E-01,9.615800E-01,6.167500E+00,& + & 2.565900E+01,4.932000E+01,1.128300E+02,3.641400E+02,2.460600E+03,& + & 1.082800E+04,5.593200E+04,1.149300E-04,6.577300E-04,2.973400E-03,& + & 1.023900E-02,2.926700E-02,7.861400E-02,2.279100E-01,8.809400E-01,& + & 5.512400E+00,1.918600E+01,3.407500E+01,7.547600E+01,2.429000E+02,& + & 1.640500E+03,7.218700E+03,3.728800E+04,1.171300E-04,6.547300E-04,& + & 2.664600E-03,8.306900E-03,2.175000E-02,5.767200E-02,1.730300E-01,& + & 6.811200E-01,4.245500E+00,1.488000E+01,2.299300E+01,4.172200E+01,& + & 1.220600E+02,8.204600E+02,3.609600E+03,1.864400E+04,8.569200E-05,& + & 3.619700E-04,9.855700E-04,2.156800E-03,4.701900E-03,1.120100E-02,& + & 3.458500E-02,1.629000E-01,1.221600E+00,4.894700E+00,8.202700E+00,& + & 1.379700E+01,2.218300E+01,3.306300E+01,5.524300E+01,9.341200E+01,& + & 1.212200E-05,5.132600E-05,3.035900E-04,2.040600E-03,6.986200E-03,& + & 2.193500E-02,6.748500E-02,2.750100E-01,2.537700E+00,1.313900E+01,& + & 2.631300E+01,5.819600E+01,1.818900E+02,1.586000E+03,8.994600E+03,& + & 5.254000E+04,3.525000E-05,1.948400E-04,1.003800E-03,4.154000E-03,& + & 1.263100E-02,3.416500E-02,9.962000E-02,3.992800E-01,2.938900E+00,& + & 1.151300E+01,2.060700E+01,4.384200E+01,1.365100E+02,1.189600E+03,& + & 6.746100E+03,3.940500E+04,4.590600E-05,2.608300E-04,1.214000E-03,& + & 4.382600E-03,1.260000E-02,3.310500E-02,9.586800E-02,3.878900E-01,& + & 2.878200E+00,1.153700E+01,1.874600E+01,3.269600E+01,9.176800E+01,& + & 7.931500E+02,4.497500E+03,2.627000E+04,5.248000E-05,2.970500E-04,& + & 1.233400E-03,3.994600E-03,1.059100E-02,2.705700E-02,7.933200E-02,& + & 3.209300E-01,2.373000E+00,9.837500E+00,1.620100E+01,2.707500E+01,& + & 5.520700E+01,3.967200E+02,2.249000E+03,1.313500E+04,4.865800E-05,& + & 2.308500E-04,6.769500E-04,1.584500E-03,3.537600E-03,8.701400E-03,& + & 2.583000E-02,1.049500E-01,8.436400E-01,4.107700E+00,7.702100E+00,& + & 1.432200E+01,2.572900E+01,4.220200E+01,7.002200E+01,1.218000E+02,& + & 1.705800E-05,8.091300E-05,4.909000E-04,2.926100E-03,9.772600E-03,& + & 3.047700E-02,9.281500E-02,3.795500E-01,3.468100E+00,1.763600E+01,& + & 3.515500E+01,7.871700E+01,2.486800E+02,2.074500E+03,1.103600E+04,& + & 6.233000E+04,4.580000E-05,2.555900E-04,1.327500E-03,5.330000E-03,& + & 1.635300E-02,4.422600E-02,1.289000E-01,5.172200E-01,3.649500E+00,& + & 1.422500E+01,2.680500E+01,5.918000E+01,1.866000E+02,1.555900E+03,& + & 8.277200E+03,4.674800E+04,5.739500E-05,3.268800E-04,1.521600E-03,& + & 5.419400E-03,1.565300E-02,4.156200E-02,1.207500E-01,4.920200E-01,& + & 3.504100E+00,1.348900E+01,2.175800E+01,4.150500E+01,1.245600E+02,& + & 1.037400E+03,5.518300E+03,3.116500E+04,6.332600E-05,3.573800E-04,& + & 1.481400E-03,4.763200E-03,1.260000E-02,3.256000E-02,9.721300E-02,& + & 3.963300E-01,2.827800E+00,1.131100E+01,1.828300E+01,2.989900E+01,& + & 6.774500E+01,5.188600E+02,2.759400E+03,1.558200E+04,5.510100E-05,& + & 2.507900E-04,7.195700E-04,1.646100E-03,3.647300E-03,8.892500E-03,& + & 2.684800E-02,1.152400E-01,9.321100E-01,4.316000E+00,7.939700E+00,& + & 1.430400E+01,2.498400E+01,3.985300E+01,6.608700E+01,1.143600E+02,& + & 2.391800E-05,1.239000E-04,7.535800E-04,4.054600E-03,1.340900E-02,& + & 4.119900E-02,1.253700E-01,5.107400E-01,4.635500E+00,2.314100E+01,& + & 4.592700E+01,1.040800E+02,3.329800E+02,2.635500E+03,1.318400E+04,& + & 7.209300E+04,5.876200E-05,3.319000E-04,1.724000E-03,6.777300E-03,& + & 2.088700E-02,5.662000E-02,1.652900E-01,6.567100E-01,4.479100E+00,& + & 1.796200E+01,3.463200E+01,7.820300E+01,2.498300E+02,1.976700E+03,& + & 9.887700E+03,5.407000E+04,7.094600E-05,4.049700E-04,1.884600E-03,& + & 6.651300E-03,1.929500E-02,5.180900E-02,1.512200E-01,6.141600E-01,& + & 4.214100E+00,1.559400E+01,2.570500E+01,5.315000E+01,1.666900E+02,& + & 1.317900E+03,6.592000E+03,3.604600E+04,7.546000E-05,4.250800E-04,& + & 1.765100E-03,5.628700E-03,1.492900E-02,3.915300E-02,1.182200E-01,& + & 4.847300E-01,3.333200E+00,1.281000E+01,2.035300E+01,3.367600E+01,& + & 8.617400E+01,6.591300E+02,3.296200E+03,1.802300E+04,6.110100E-05,& + & 2.690200E-04,7.571200E-04,1.698300E-03,3.740600E-03,9.042400E-03,& + & 2.769900E-02,1.262300E-01,1.024000E+00,4.544300E+00,8.060500E+00,& + & 1.427900E+01,2.408300E+01,3.762300E+01,6.244300E+01,1.073400E+02/ + data absb(:, 541: 560) / & + & 3.305400E-05,1.838600E-04,1.103300E-03,5.434800E-03,1.803700E-02,& + & 5.437200E-02,1.661700E-01,6.754500E-01,6.067800E+00,2.996000E+01,& + & 5.883500E+01,1.349700E+02,4.375100E+02,3.264400E+03,1.539400E+04,& + & 8.159300E+04,7.443100E-05,4.264800E-04,2.197500E-03,8.514300E-03,& + & 2.634600E-02,7.170900E-02,2.098900E-01,8.206500E-01,5.472700E+00,& + & 2.277800E+01,4.425200E+01,1.013700E+02,3.282300E+02,2.448400E+03,& + & 1.154600E+04,6.119400E+04,8.680300E-05,4.966200E-04,2.299900E-03,& + & 8.104000E-03,2.358100E-02,6.403900E-02,1.886000E-01,7.559200E-01,& + & 5.012800E+00,1.792400E+01,3.119700E+01,6.800400E+01,2.189500E+02,& + & 1.632400E+03,7.697200E+03,4.079600E+04,8.895700E-05,5.006100E-04,& + & 2.078500E-03,6.610700E-03,1.759100E-02,4.691500E-02,1.434600E-01,& + & 5.863100E-01,3.893000E+00,1.433500E+01,2.245800E+01,3.914200E+01,& + & 1.106400E+02,8.163700E+02,3.848800E+03,2.039800E+04,6.654000E-05,& + & 2.857100E-04,7.888700E-04,1.742100E-03,3.814800E-03,9.155700E-03,& + & 2.841100E-02,1.377200E-01,1.119300E+00,4.739700E+00,8.131100E+00,& + & 1.413000E+01,2.325300E+01,3.540500E+01,5.905200E+01,1.008000E+02,& + & 4.482700E-05,2.646700E-04,1.554200E-03,7.106000E-03,2.370400E-02,& + & 7.047600E-02,2.164100E-01,8.801000E-01,7.805600E+00,3.826100E+01,& + & 7.425000E+01,1.721500E+02,5.641600E+02,3.952000E+03,1.763200E+04,& + & 9.069700E+04,9.290700E-05,5.424900E-04,2.759200E-03,1.054400E-02,& + & 3.288500E-02,8.971000E-02,2.633800E-01,1.011500E+00,6.674400E+00,& + & 2.882500E+01,5.581500E+01,1.292600E+02,4.232200E+02,2.964100E+03,& + & 1.322400E+04,6.802300E+04,1.051000E-04,6.036100E-04,2.774900E-03,& + & 9.769900E-03,2.861600E-02,7.854200E-02,2.336500E-01,9.189300E-01,& + & 5.892500E+00,2.107900E+01,3.818400E+01,8.640000E+01,2.822700E+02,& + & 1.976200E+03,8.816100E+03,4.534900E+04,1.039300E-04,5.839800E-04,& + & 2.419400E-03,7.721200E-03,2.063800E-02,5.597900E-02,1.736700E-01,& + & 7.017600E-01,4.507400E+00,1.592100E+01,2.470100E+01,4.669600E+01,& + & 1.415100E+02,9.883200E+02,4.408300E+03,2.267400E+04,7.147000E-05,& + & 3.005900E-04,8.154100E-04,1.778000E-03,3.870700E-03,9.231800E-03,& + & 2.900600E-02,1.496700E-01,1.215400E+00,4.914900E+00,8.215000E+00,& + & 1.381700E+01,2.243200E+01,3.327600E+01,5.588400E+01,9.475300E+01,& + & 1.213600E-05,5.228100E-05,3.121000E-04,2.072800E-03,7.097700E-03,& + & 2.243200E-02,6.900200E-02,2.849100E-01,2.697300E+00,1.420100E+01,& + & 2.887600E+01,6.495300E+01,2.019200E+02,1.875600E+03,1.099300E+04,& + & 6.405100E+04,3.227400E-05,1.775400E-04,9.339400E-04,3.948500E-03,& + & 1.223500E-02,3.357500E-02,9.916800E-02,4.079200E-01,3.077500E+00,& + & 1.226100E+01,2.245500E+01,4.888500E+01,1.515300E+02,1.406800E+03,& + & 8.244600E+03,4.803800E+04,4.078400E-05,2.317100E-04,1.101400E-03,& + & 4.057400E-03,1.187800E-02,3.177000E-02,9.361100E-02,3.912400E-01,& + & 2.995300E+00,1.221300E+01,1.994600E+01,3.577700E+01,1.015800E+02,& + & 9.379700E+02,5.496600E+03,3.202600E+04,4.549300E-05,2.585900E-04,& + & 1.094200E-03,3.608100E-03,9.712200E-03,2.515900E-02,7.584600E-02,& + & 3.176800E-01,2.448300E+00,1.033000E+01,1.712400E+01,2.851300E+01,& + & 5.934600E+01,4.691400E+02,2.748500E+03,1.601300E+04,4.067100E-05,& + & 1.916800E-04,5.601600E-04,1.306800E-03,2.915600E-03,7.182500E-03,& + & 2.170400E-02,9.381500E-02,8.138100E-01,4.039900E+00,7.722400E+00,& + & 1.437600E+01,2.604400E+01,4.287800E+01,7.127200E+01,1.244600E+02,& + & 1.708500E-05,8.215700E-05,5.005800E-04,2.960200E-03,9.924900E-03,& + & 3.110100E-02,9.517700E-02,3.930400E-01,3.699100E+00,1.913500E+01,& + & 3.871500E+01,8.797300E+01,2.788000E+02,2.457800E+03,1.342800E+04,& + & 7.564400E+04,4.208200E-05,2.343500E-04,1.241200E-03,5.093200E-03,& + & 1.591500E-02,4.374300E-02,1.293500E-01,5.300800E-01,3.836000E+00,& + & 1.530500E+01,2.940500E+01,6.612800E+01,2.091900E+02,1.843400E+03,& + & 1.007100E+04,5.673300E+04,5.119800E-05,2.917400E-04,1.387900E-03,& + & 5.043800E-03,1.486200E-02,4.023100E-02,1.190300E-01,4.991700E-01,& + & 3.663600E+00,1.432300E+01,2.328400E+01,4.587600E+01,1.396000E+02,& + & 1.229000E+03,6.714100E+03,3.782200E+04,5.505600E-05,3.120800E-04,& + & 1.321200E-03,4.319200E-03,1.164200E-02,3.058800E-02,9.369000E-02,& + & 3.961200E-01,2.934500E+00,1.189500E+01,1.932600E+01,3.184400E+01,& + & 7.452700E+01,6.146900E+02,3.357300E+03,1.891100E+04,4.591800E-05,& + & 2.078100E-04,5.952900E-04,1.356500E-03,3.004200E-03,7.337200E-03,& + & 2.251700E-02,1.037200E-01,9.076000E-01,4.289400E+00,7.925200E+00,& + & 1.442300E+01,2.520400E+01,4.044000E+01,6.716500E+01,1.166200E+02/ + data absb(:, 561: 580) / & + & 2.391600E-05,1.252800E-04,7.629900E-04,4.076900E-03,1.361500E-02,& + & 4.195900E-02,1.287200E-01,5.305900E-01,4.960100E+00,2.531800E+01,& + & 5.077800E+01,1.165900E+02,3.768300E+02,3.126800E+03,1.597700E+04,& + & 8.717200E+04,5.418300E-05,3.060200E-04,1.618200E-03,6.501600E-03,& + & 2.041300E-02,5.632300E-02,1.671300E-01,6.756900E-01,4.730000E+00,& + & 1.954500E+01,3.823700E+01,8.758800E+01,2.827100E+02,2.345200E+03,& + & 1.198300E+04,6.537900E+04,6.355300E-05,3.630000E-04,1.724800E-03,& + & 6.227000E-03,1.842500E-02,5.049100E-02,1.506600E-01,6.266500E-01,& + & 4.427800E+00,1.658900E+01,2.790200E+01,5.921300E+01,1.886000E+02,& + & 1.563600E+03,7.988900E+03,4.358600E+04,6.579500E-05,3.725900E-04,& + & 1.579100E-03,5.130700E-03,1.388200E-02,3.711400E-02,1.151800E-01,& + & 4.882400E-01,3.477700E+00,1.350800E+01,2.157700E+01,3.634400E+01,& + & 9.653200E+01,7.819700E+02,3.994900E+03,2.179200E+04,5.079400E-05,& + & 2.227000E-04,6.255600E-04,1.399000E-03,3.079100E-03,7.457100E-03,& + & 2.320200E-02,1.143100E-01,1.005100E+00,4.539700E+00,8.025800E+00,& + & 1.438000E+01,2.431500E+01,3.812900E+01,6.337600E+01,1.092900E+02,& + & 3.298300E-05,1.851600E-04,1.111000E-03,5.435400E-03,1.827100E-02,& + & 5.536100E-02,1.707600E-01,7.046300E-01,6.518600E+00,3.302100E+01,& + & 6.535500E+01,1.517700E+02,4.990600E+02,3.875100E+03,1.859500E+04,& + & 9.838000E+04,6.878400E-05,3.953400E-04,2.069600E-03,8.176400E-03,& + & 2.588100E-02,7.166400E-02,2.134700E-01,8.474400E-01,5.812700E+00,& + & 2.502500E+01,4.914000E+01,1.139700E+02,3.743900E+02,2.906400E+03,& + & 1.394600E+04,7.378600E+04,7.806100E-05,4.475900E-04,2.110700E-03,& + & 7.613700E-03,2.265500E-02,6.282700E-02,1.896400E-01,7.751700E-01,& + & 5.283200E+00,1.928500E+01,3.425900E+01,7.631600E+01,2.497200E+02,& + & 1.937800E+03,9.297500E+03,4.919100E+04,7.784800E-05,4.403800E-04,& + & 1.862400E-03,6.059700E-03,1.646100E-02,4.482900E-02,1.413500E-01,& + & 5.948300E-01,4.081400E+00,1.517000E+01,2.386000E+01,4.289100E+01,& + & 1.256600E+02,9.690900E+02,4.649000E+03,2.459500E+04,5.521500E-05,& + & 2.363000E-04,6.515500E-04,1.434300E-03,3.138700E-03,7.545700E-03,& + & 2.378500E-02,1.254700E-01,1.104800E+00,4.756500E+00,8.154300E+00,& + & 1.414200E+01,2.354900E+01,3.571500E+01,5.986900E+01,1.024900E+02,& + & 4.460800E-05,2.655200E-04,1.557900E-03,7.082100E-03,2.390000E-02,& + & 7.184100E-02,2.226400E-01,9.228900E-01,8.412600E+00,4.246100E+01,& + & 8.300300E+01,1.943800E+02,6.481700E+02,4.693600E+03,2.123100E+04,& + & 1.090300E+05,8.596200E-05,5.055400E-04,2.606400E-03,1.013400E-02,& + & 3.241400E-02,8.999500E-02,2.690800E-01,1.049000E+00,7.125900E+00,& + & 3.195400E+01,6.237200E+01,1.459300E+02,4.862200E+02,3.520300E+03,& + & 1.592300E+04,8.177600E+04,9.479900E-05,5.470300E-04,2.556200E-03,& + & 9.190500E-03,2.765100E-02,7.753800E-02,2.366500E-01,9.477300E-01,& + & 6.227300E+00,2.301200E+01,4.236500E+01,9.752100E+01,3.242700E+02,& + & 2.347100E+03,1.061600E+04,5.451700E+04,9.131600E-05,5.160500E-04,& + & 2.172500E-03,7.101100E-03,1.945000E-02,5.389800E-02,1.729800E-01,& + & 7.163800E-01,4.742300E+00,1.695800E+01,2.646300E+01,5.179300E+01,& + & 1.624200E+02,1.173800E+03,5.308100E+03,2.725900E+04,5.918500E-05,& + & 2.484000E-04,6.727600E-04,1.463000E-03,3.183700E-03,7.609800E-03,& + & 2.425200E-02,1.372900E-01,1.206600E+00,4.933200E+00,8.193800E+00,& + & 1.395100E+01,2.255600E+01,3.379700E+01,5.602500E+01,9.619700E+01,& + & 1.163900E-05,5.033100E-05,3.015600E-04,2.010300E-03,6.906000E-03,& + & 2.197100E-02,6.786500E-02,2.833500E-01,2.759800E+00,1.479800E+01,& + & 3.060300E+01,7.002800E+01,2.171800E+02,2.145300E+03,1.300600E+04,& + & 7.587800E+04,2.871000E-05,1.571000E-04,8.418500E-04,3.647900E-03,& + & 1.149800E-02,3.205200E-02,9.587900E-02,4.044400E-01,3.138900E+00,& + & 1.271700E+01,2.373100E+01,5.269200E+01,1.629800E+02,1.609000E+03,& + & 9.754700E+03,5.690800E+04,3.538900E-05,2.009300E-04,9.748400E-04,& + & 3.669100E-03,1.093200E-02,2.977300E-02,8.921100E-02,3.844400E-01,& + & 3.046400E+00,1.267000E+01,2.081700E+01,3.819600E+01,1.091100E+02,& + & 1.072800E+03,6.503300E+03,3.793900E+04,3.864700E-05,2.205800E-04,& + & 9.519400E-04,3.195200E-03,8.749300E-03,2.298000E-02,7.098100E-02,& + & 3.078500E-01,2.479400E+00,1.065700E+01,1.781600E+01,2.976400E+01,& + & 6.268200E+01,5.365500E+02,3.251900E+03,1.896900E+04,3.349600E-05,& + & 1.575900E-04,4.604500E-04,1.072900E-03,2.395200E-03,5.916900E-03,& + & 1.813300E-02,8.318100E-02,7.818500E-01,3.972400E+00,7.687600E+00,& + & 1.442900E+01,2.637200E+01,4.366400E+01,7.270500E+01,1.274200E+02/ + data absb(:, 581: 600) / & + & 1.638700E-05,7.904300E-05,4.831300E-04,2.866200E-03,9.673500E-03,& + & 3.049600E-02,9.400700E-02,3.923100E-01,3.809600E+00,2.009200E+01,& + & 4.130400E+01,9.523000E+01,3.035300E+02,2.824500E+03,1.587400E+04,& + & 8.947100E+04,3.761100E-05,2.087400E-04,1.125800E-03,4.733800E-03,& + & 1.504200E-02,4.206800E-02,1.262500E-01,5.283700E-01,3.934100E+00,& + & 1.601600E+01,3.131300E+01,7.158000E+01,2.277300E+02,2.118400E+03,& + & 1.190500E+04,6.710300E+04,4.466000E-05,2.543500E-04,1.235700E-03,& + & 4.590400E-03,1.377900E-02,3.801200E-02,1.146600E-01,4.942500E-01,& + & 3.750300E+00,1.489900E+01,2.446200E+01,4.938800E+01,1.519600E+02,& + & 1.412400E+03,7.937000E+03,4.473500E+04,4.698200E-05,2.673900E-04,& + & 1.155900E-03,3.844800E-03,1.057300E-02,2.822800E-02,8.857300E-02,& + & 3.878700E-01,2.990900E+00,1.231600E+01,2.017200E+01,3.349100E+01,& + & 8.025500E+01,7.063600E+02,3.968700E+03,2.236800E+04,3.781900E-05,& + & 1.707700E-04,4.895300E-04,1.113200E-03,2.467200E-03,6.041700E-03,& + & 1.879700E-02,9.267400E-02,8.789600E-01,4.268100E+00,7.871500E+00,& + & 1.451500E+01,2.548400E+01,4.113800E+01,6.841300E+01,1.192000E+02,& + & 2.293100E-05,1.204500E-04,7.350500E-04,3.936800E-03,1.329100E-02,& + & 4.119500E-02,1.275100E-01,5.327700E-01,5.137900E+00,2.685200E+01,& + & 5.453300E+01,1.267900E+02,4.148700E+02,3.606300E+03,1.886100E+04,& + & 1.030200E+05,4.861300E-05,2.744000E-04,1.475600E-03,6.066300E-03,& + & 1.941500E-02,5.453200E-02,1.645000E-01,6.771600E-01,4.876600E+00,& + & 2.067700E+01,4.103500E+01,9.525100E+01,3.112400E+02,2.704800E+03,& + & 1.414600E+04,7.726300E+04,5.572700E-05,3.183400E-04,1.542200E-03,& + & 5.700800E-03,1.720500E-02,4.806800E-02,1.466900E-01,6.248500E-01,& + & 4.554900E+00,1.735800E+01,2.966200E+01,6.421900E+01,2.076200E+02,& + & 1.803300E+03,9.430500E+03,5.150900E+04,5.640500E-05,3.208500E-04,& + & 1.386400E-03,4.597300E-03,1.269100E-02,3.454200E-02,1.102300E-01,& + & 4.825700E-01,3.565200E+00,1.405200E+01,2.257600E+01,3.865400E+01,& + & 1.056500E+02,9.018600E+02,4.715500E+03,2.543600E+04,4.179300E-05,& + & 1.831000E-04,5.145000E-04,1.148700E-03,2.529000E-03,6.140300E-03,& + & 1.936400E-02,1.028400E-01,9.810700E-01,4.536800E+00,7.987800E+00,& + & 1.444700E+01,2.469000E+01,3.858900E+01,6.447900E+01,1.115400E+02,& + & 3.161400E-05,1.778600E-04,1.069200E-03,5.241000E-03,1.782000E-02,& + & 5.447100E-02,1.696900E-01,7.116400E-01,6.793700E+00,3.536200E+01,& + & 7.073600E+01,1.660400E+02,5.546500E+02,4.482100E+03,2.192700E+04,& + & 1.161400E+05,6.193700E-05,3.568700E-04,1.898300E-03,7.644400E-03,& + & 2.475300E-02,6.975900E-02,2.112900E-01,8.540000E-01,6.030200E+00,& + & 2.674700E+01,5.317500E+01,1.246800E+02,4.160700E+02,3.361600E+03,& + & 1.644500E+04,8.710800E+04,6.874500E-05,3.949400E-04,1.897000E-03,& + & 6.991900E-03,2.129900E-02,6.025400E-02,1.863400E-01,7.782500E-01,& + & 5.457800E+00,2.039100E+01,3.683200E+01,8.340800E+01,2.775000E+02,& + & 2.241200E+03,1.096400E+04,5.807200E+04,6.705400E-05,3.811300E-04,& + & 1.640300E-03,5.458500E-03,1.515100E-02,4.207200E-02,1.368400E-01,& + & 5.923900E-01,4.206900E+00,1.586400E+01,2.505200E+01,4.619900E+01,& + & 1.393400E+02,1.120800E+03,5.482100E+03,2.903600E+04,4.541600E-05,& + & 1.943100E-04,5.359400E-04,1.177900E-03,2.579100E-03,6.214800E-03,& + & 1.984800E-02,1.137000E-01,1.085200E+00,4.752800E+00,8.140400E+00,& + & 1.422600E+01,2.381500E+01,3.619500E+01,6.084300E+01,1.044500E+02,& + & 4.273600E-05,2.549000E-04,1.498300E-03,6.820400E-03,2.325300E-02,& + & 7.091100E-02,2.219900E-01,9.384100E-01,8.814100E+00,4.586900E+01,& + & 9.053500E+01,2.140600E+02,7.260800E+02,5.441800E+03,2.501400E+04,& + & 1.286200E+05,7.766700E-05,4.588000E-04,2.402500E-03,9.500500E-03,& + & 3.111300E-02,8.808800E-02,2.677600E-01,1.063400E+00,7.432600E+00,& + & 3.450300E+01,6.801700E+01,1.607000E+02,5.446500E+02,4.081400E+03,& + & 1.876000E+04,9.646500E+04,8.383400E-05,4.857000E-04,2.307900E-03,& + & 8.461000E-03,2.614100E-02,7.491200E-02,2.341600E-01,9.573300E-01,& + & 6.458900E+00,2.464400E+01,4.600700E+01,1.073700E+02,3.632200E+02,& + & 2.721100E+03,1.250700E+04,6.431000E+04,7.900200E-05,4.488900E-04,& + & 1.921000E-03,6.416400E-03,1.803000E-02,5.099200E-02,1.692000E-01,& + & 7.188100E-01,4.908300E+00,1.785900E+01,2.804400E+01,5.640100E+01,& + & 1.818900E+02,1.360800E+03,6.253700E+03,3.215500E+04,4.870000E-05,& + & 2.041600E-04,5.537300E-04,1.202200E-03,2.617500E-03,6.266200E-03,& + & 2.025300E-02,1.252100E-01,1.191200E+00,4.948000E+00,8.215200E+00,& + & 1.407900E+01,2.265400E+01,3.436700E+01,5.654400E+01,9.792200E+01/ + data absb(:, 601: 620) / & + & 1.033400E-05,4.402900E-05,2.633600E-04,1.795900E-03,6.213900E-03,& + & 1.992200E-02,6.191000E-02,2.609900E-01,2.623000E+00,1.436900E+01,& + & 3.025500E+01,7.033600E+01,2.178800E+02,2.294000E+03,1.448900E+04,& + & 8.508300E+04,2.422800E-05,1.316800E-04,7.161800E-04,3.186400E-03,& + & 1.019200E-02,2.885200E-02,8.739200E-02,3.779400E-01,3.040800E+00,& + & 1.254900E+01,2.355900E+01,5.294400E+01,1.634900E+02,1.720500E+03,& + & 1.086700E+04,6.381200E+04,2.941200E-05,1.666800E-04,8.230600E-04,& + & 3.166300E-03,9.580200E-03,2.649300E-02,8.072200E-02,3.583900E-01,& + & 2.959600E+00,1.261500E+01,2.092500E+01,3.860500E+01,1.095000E+02,& + & 1.147100E+03,7.244700E+03,4.254100E+04,3.171900E-05,1.816400E-04,& + & 7.977800E-04,2.723900E-03,7.579800E-03,2.013500E-02,6.350300E-02,& + & 2.851000E-01,2.412400E+00,1.062900E+01,1.796900E+01,3.026200E+01,& + & 6.328900E+01,5.737200E+02,3.622600E+03,2.127100E+04,2.701800E-05,& + & 1.277600E-04,3.747400E-04,8.746900E-04,1.956700E-03,4.854600E-03,& + & 1.505000E-02,7.260800E-02,7.396200E-01,3.887500E+00,7.609300E+00,& + & 1.449200E+01,2.671900E+01,4.472400E+01,7.461700E+01,1.312500E+02,& + & 1.454500E-05,6.936900E-05,4.245300E-04,2.569700E-03,8.745600E-03,& + & 2.780200E-02,8.640200E-02,3.645300E-01,3.658000E+00,1.975700E+01,& + & 4.124600E+01,9.646500E+01,3.091200E+02,3.047600E+03,1.774400E+04,& + & 1.005800E+05,3.190700E-05,1.762200E-04,9.647100E-04,4.161700E-03,& + & 1.342800E-02,3.820200E-02,1.163400E-01,4.980300E-01,3.839300E+00,& + & 1.584000E+01,3.131900E+01,7.251400E+01,2.319300E+02,2.285800E+03,& + & 1.330800E+04,7.543600E+04,3.732900E-05,2.124100E-04,1.050500E-03,& + & 3.987600E-03,1.216400E-02,3.413300E-02,1.049600E-01,4.654400E-01,& + & 3.670200E+00,1.492200E+01,2.467200E+01,5.013100E+01,1.547600E+02,& + & 1.524000E+03,8.872000E+03,5.029100E+04,3.876000E-05,2.214000E-04,& + & 9.742800E-04,3.296600E-03,9.224400E-03,2.496900E-02,8.017200E-02,& + & 3.635400E-01,2.933100E+00,1.235900E+01,2.044200E+01,3.416400E+01,& + & 8.179700E+01,7.621700E+02,4.436200E+03,2.514500E+04,3.058600E-05,& + & 1.387400E-04,3.989300E-04,9.093100E-04,2.018100E-03,4.959700E-03,& + & 1.560500E-02,8.159900E-02,8.399200E-01,4.208600E+00,7.800000E+00,& + & 1.458500E+01,2.586000E+01,4.210300E+01,7.010400E+01,1.218500E+02,& + & 2.038500E-05,1.061200E-04,6.500200E-04,3.539100E-03,1.206800E-02,& + & 3.775000E-02,1.179200E-01,4.992500E-01,4.982400E+00,2.670400E+01,& + & 5.500800E+01,1.295500E+02,4.284600E+02,3.921600E+03,2.114200E+04,& + & 1.161000E+05,4.146200E-05,2.333200E-04,1.274300E-03,5.361000E-03,& + & 1.745600E-02,4.993000E-02,1.530100E-01,6.431300E-01,4.786600E+00,& + & 2.060500E+01,4.140400E+01,9.732400E+01,3.214200E+02,2.941300E+03,& + & 1.585700E+04,8.707300E+04,4.684900E-05,2.677000E-04,1.318900E-03,& + & 4.981800E-03,1.530200E-02,4.353200E-02,1.357500E-01,5.937600E-01,& + & 4.487800E+00,1.749300E+01,3.002900E+01,6.564200E+01,2.144000E+02,& + & 1.961000E+03,1.057100E+04,5.804900E+04,4.680600E-05,2.672300E-04,& + & 1.174100E-03,3.967600E-03,1.114700E-02,3.081600E-02,1.010200E-01,& + & 4.569200E-01,3.521000E+00,1.418500E+01,2.296500E+01,3.957400E+01,& + & 1.090600E+02,9.807000E+02,5.285800E+03,2.902400E+04,3.389100E-05,& + & 1.489800E-04,4.201100E-04,9.389700E-04,2.070600E-03,5.044100E-03,& + & 1.608900E-02,9.132400E-02,9.449100E-01,4.486400E+00,7.965200E+00,& + & 1.453700E+01,2.505400E+01,3.941500E+01,6.598500E+01,1.145700E+02,& + & 2.816700E-05,1.573100E-04,9.504100E-04,4.724000E-03,1.622900E-02,& + & 5.018400E-02,1.578600E-01,6.731800E-01,6.645400E+00,3.558800E+01,& + & 7.210000E+01,1.711400E+02,5.798200E+02,4.905000E+03,2.463300E+04,& + & 1.311700E+05,5.307500E-05,3.054900E-04,1.651500E-03,6.784700E-03,& + & 2.241100E-02,6.434600E-02,1.981100E-01,8.173500E-01,5.948400E+00,& + & 2.693500E+01,5.419800E+01,1.285100E+02,4.349500E+02,3.678900E+03,& + & 1.847500E+04,9.837400E+04,5.812200E-05,3.341800E-04,1.632300E-03,& + & 6.136400E-03,1.908900E-02,5.501200E-02,1.741600E-01,7.457900E-01,& + & 5.411000E+00,2.065000E+01,3.756400E+01,8.597100E+01,2.900800E+02,& + & 2.452700E+03,1.231700E+04,6.558200E+04,5.596200E-05,3.191800E-04,& + & 1.395700E-03,4.735800E-03,1.340800E-02,3.785500E-02,1.268800E-01,& + & 5.661600E-01,4.181200E+00,1.610900E+01,2.560200E+01,4.757000E+01,& + & 1.456100E+02,1.226600E+03,6.158600E+03,3.279100E+04,3.691500E-05,& + & 1.583600E-04,4.382200E-04,9.639900E-04,2.113400E-03,5.108200E-03,& + & 1.650400E-02,1.017700E-01,1.053800E+00,4.727400E+00,8.117400E+00,& + & 1.431200E+01,2.415800E+01,3.713600E+01,6.172300E+01,1.071500E+02/ + data absb(:, 621: 640) / & + & 3.818800E-05,2.263100E-04,1.337900E-03,6.158600E-03,2.120800E-02,& + & 6.565000E-02,2.077600E-01,8.949700E-01,8.693400E+00,4.665900E+01,& + & 9.325200E+01,2.225700E+02,7.671700E+02,5.987600E+03,2.815200E+04,& + & 1.455100E+05,6.690300E-05,3.953700E-04,2.102900E-03,8.465500E-03,& + & 2.831400E-02,8.181900E-02,2.528300E-01,1.025800E+00,7.370400E+00,& + & 3.509900E+01,7.005200E+01,1.670800E+02,5.754600E+02,4.490800E+03,& + & 2.111400E+04,1.091300E+05,7.125000E-05,4.135000E-04,1.996700E-03,& + & 7.456400E-03,2.356000E-02,6.897000E-02,2.207300E-01,9.240200E-01,& + & 6.437900E+00,2.511500E+01,4.736300E+01,1.116200E+02,3.837700E+02,& + & 2.994000E+03,1.407600E+04,7.275700E+04,6.627400E-05,3.779200E-04,& + & 1.642400E-03,5.587500E-03,1.606300E-02,4.626200E-02,1.585600E-01,& + & 6.930300E-01,4.906700E+00,1.823200E+01,2.881300E+01,5.852300E+01,& + & 1.921700E+02,1.497200E+03,7.038300E+03,3.637800E+04,3.967900E-05,& + & 1.666300E-04,4.533000E-04,9.853300E-04,2.146700E-03,5.154600E-03,& + & 1.686100E-02,1.130000E-01,1.162500E+00,4.939600E+00,8.237900E+00,& + & 1.415700E+01,2.294800E+01,3.512100E+01,5.761600E+01,1.003400E+02,& + & 9.287300E-06,3.892200E-05,2.321600E-04,1.622100E-03,5.654600E-03,& + & 1.826100E-02,5.718000E-02,2.433100E-01,2.525100E+00,1.414400E+01,& + & 3.031900E+01,7.165300E+01,2.225400E+02,2.485500E+03,1.631400E+04,& + & 9.507700E+04,2.058700E-05,1.109400E-04,6.124100E-04,2.808100E-03,& + & 9.108100E-03,2.622000E-02,8.043400E-02,3.565100E-01,2.972100E+00,& + & 1.251600E+01,2.367600E+01,5.393500E+01,1.669900E+02,1.864200E+03,& + & 1.223600E+04,7.233300E+04,2.454500E-05,1.387800E-04,6.980400E-04,& + & 2.752200E-03,8.459700E-03,2.378300E-02,7.364100E-02,3.370500E-01,& + & 2.897500E+00,1.264600E+01,2.120300E+01,3.944300E+01,1.118400E+02,& + & 1.242900E+03,8.157200E+03,4.822200E+04,2.608000E-05,1.498400E-04,& + & 6.709000E-04,2.334700E-03,6.610100E-03,1.778900E-02,5.722800E-02,& + & 2.661100E-01,2.363000E+00,1.067400E+01,1.822300E+01,3.095600E+01,& + & 6.463300E+01,6.216100E+02,4.078800E+03,2.411100E+04,2.175900E-05,& + & 1.034800E-04,3.047900E-04,7.131400E-04,1.599500E-03,3.981700E-03,& + & 1.247900E-02,6.336400E-02,7.009300E-01,3.812100E+00,7.519800E+00,& + & 1.453700E+01,2.703000E+01,4.572100E+01,7.641300E+01,1.348600E+02,& + & 1.306200E-05,6.150700E-05,3.769200E-04,2.329100E-03,7.996600E-03,& + & 2.563400E-02,8.036100E-02,3.431500E-01,3.560000E+00,1.969200E+01,& + & 4.178400E+01,9.937100E+01,3.203100E+02,3.331800E+03,2.005500E+04,& + & 1.143900E+05,2.726200E-05,1.496400E-04,8.321500E-04,3.692900E-03,& + & 1.209300E-02,3.504700E-02,1.082800E-01,4.740100E-01,3.782600E+00,& + & 1.586900E+01,3.174100E+01,7.469700E+01,2.403100E+02,2.498900E+03,& + & 1.504100E+04,8.579300E+04,3.135900E-05,1.781400E-04,8.980700E-04,& + & 3.489900E-03,1.083200E-02,3.094100E-02,9.695500E-02,4.424000E-01,& + & 3.621900E+00,1.505500E+01,2.512500E+01,5.164600E+01,1.603500E+02,& + & 1.666100E+03,1.002800E+04,5.719500E+04,3.208500E-05,1.837800E-04,& + & 8.246500E-04,2.844600E-03,8.108500E-03,2.228000E-02,7.320000E-02,& + & 3.434900E-01,2.896700E+00,1.249000E+01,2.083700E+01,3.511700E+01,& + & 8.461000E+01,8.332200E+02,5.014000E+03,2.859800E+04,2.471400E-05,& + & 1.126400E-04,3.250600E-04,7.424900E-04,1.650600E-03,4.072900E-03,& + & 1.294700E-02,7.184100E-02,8.038300E-01,4.152600E+00,7.724300E+00,& + & 1.467000E+01,2.615400E+01,4.301000E+01,7.169600E+01,1.258000E+02,& + & 1.834000E-05,9.451000E-05,5.810900E-04,3.219000E-03,1.108400E-02,& + & 3.500700E-02,1.104300E-01,4.741500E-01,4.900400E+00,2.692800E+01,& + & 5.631600E+01,1.346700E+02,4.500000E+02,4.321300E+03,2.397300E+04,& + & 1.323100E+05,3.562800E-05,1.997000E-04,1.109000E-03,4.784600E-03,& + & 1.585100E-02,4.618800E-02,1.437900E-01,6.171000E-01,4.748900E+00,& + & 2.080000E+01,4.238500E+01,1.011600E+02,3.375800E+02,3.241000E+03,& + & 1.798000E+04,9.923600E+04,3.961700E-05,2.261900E-04,1.135000E-03,& + & 4.389200E-03,1.374000E-02,3.982600E-02,1.268800E-01,5.695900E-01,& + & 4.461100E+00,1.776600E+01,3.077500E+01,6.819900E+01,2.251700E+02,& + & 2.160800E+03,1.198700E+04,6.615700E+04,3.899200E-05,2.232500E-04,& + & 9.993600E-04,3.448000E-03,9.876700E-03,2.776100E-02,9.337500E-02,& + & 4.364500E-01,3.503200E+00,1.442800E+01,2.351700E+01,4.093800E+01,& + & 1.143900E+02,1.080600E+03,5.993600E+03,3.307800E+04,2.746500E-05,& + & 1.211700E-04,3.428900E-04,7.676500E-04,1.694800E-03,4.144700E-03,& + & 1.336500E-02,8.112200E-02,9.117600E-01,4.446100E+00,7.936300E+00,& + & 1.459500E+01,2.537700E+01,4.019500E+01,6.740600E+01,1.174300E+02/ + data absb(:, 641: 660) / & + & 2.539400E-05,1.407200E-04,8.543500E-04,4.310000E-03,1.494400E-02,& + & 4.681800E-02,1.488300E-01,6.453500E-01,6.593900E+00,3.636400E+01,& + & 7.458200E+01,1.794400E+02,6.162600E+02,5.440300E+03,2.800100E+04,& + & 1.498900E+05,4.587500E-05,2.635600E-04,1.449300E-03,6.084300E-03,& + & 2.049400E-02,5.998500E-02,1.878600E-01,7.908400E-01,5.934300E+00,& + & 2.752800E+01,5.605300E+01,1.347400E+02,4.622800E+02,4.080300E+03,& + & 2.100100E+04,1.124200E+05,4.946100E-05,2.844700E-04,1.414800E-03,& + & 5.432200E-03,1.727200E-02,5.078200E-02,1.645000E-01,7.213600E-01,& + & 5.414900E+00,2.112200E+01,3.882300E+01,9.011000E+01,3.083100E+02,& + & 2.720300E+03,1.400100E+04,7.494500E+04,4.688400E-05,2.684900E-04,& + & 1.194400E-03,4.137900E-03,1.197500E-02,3.441200E-02,1.187900E-01,& + & 5.461200E-01,4.189300E+00,1.647000E+01,2.636100E+01,4.961400E+01,& + & 1.546600E+02,1.360400E+03,7.000600E+03,3.747200E+04,2.999800E-05,& + & 1.289700E-04,3.582500E-04,7.897000E-04,1.732200E-03,4.199600E-03,& + & 1.373200E-02,9.125500E-02,1.024500E+00,4.693100E+00,8.124200E+00,& + & 1.436700E+01,2.444900E+01,3.793900E+01,6.276800E+01,1.096900E+02,& + & 3.452800E-05,2.031900E-04,1.208300E-03,5.629500E-03,1.957100E-02,& + & 6.154900E-02,1.970700E-01,8.657500E-01,8.706700E+00,4.819000E+01,& + & 9.751000E+01,2.353700E+02,8.239100E+02,6.675400E+03,3.207100E+04,& + & 1.666400E+05,5.813100E-05,3.435000E-04,1.859000E-03,7.622700E-03,& + & 2.603100E-02,7.685100E-02,2.412900E-01,1.000500E+00,7.403000E+00,& + & 3.624800E+01,7.324300E+01,1.766800E+02,6.180200E+02,5.006600E+03,& + & 2.405300E+04,1.249800E+05,6.096700E-05,3.544100E-04,1.742100E-03,& + & 6.632500E-03,2.144500E-02,6.424000E-02,2.101300E-01,9.014700E-01,& + & 6.479800E+00,2.589400E+01,4.949800E+01,1.180200E+02,4.121500E+02,& + & 3.337900E+03,1.603600E+04,8.332100E+04,5.586100E-05,3.198100E-04,& + & 1.413200E-03,4.902400E-03,1.444700E-02,4.244200E-02,1.499800E-01,& + & 6.746100E-01,4.944900E+00,1.877400E+01,2.988900E+01,6.160800E+01,& + & 2.063500E+02,1.669200E+03,8.018000E+03,4.166000E+04,3.233400E-05,& + & 1.358800E-04,3.710500E-04,8.076200E-04,1.761400E-03,4.240900E-03,& + & 1.404900E-02,1.021600E-01,1.135800E+00,4.928100E+00,8.255900E+00,& + & 1.421300E+01,2.322800E+01,3.582400E+01,5.860200E+01,1.026100E+02,& + & 8.545300E-06,3.519700E-05,2.093100E-04,1.498500E-03,5.260600E-03,& + & 1.712000E-02,5.404400E-02,2.320500E-01,2.490400E+00,1.426500E+01,& + & 3.111100E+01,7.495300E+01,2.340100E+02,2.757900E+03,1.875900E+04,& + & 1.115800E+05,1.776100E-05,9.464500E-05,5.307000E-04,2.518100E-03,& + & 8.286100E-03,2.426800E-02,7.546900E-02,3.421700E-01,2.953700E+00,& + & 1.269900E+01,2.429300E+01,5.640400E+01,1.756000E+02,2.068500E+03,& + & 1.406900E+04,8.368500E+04,2.071300E-05,1.165800E-04,5.984500E-04,& + & 2.427200E-03,7.591800E-03,2.172300E-02,6.832400E-02,3.221900E-01,& + & 2.879300E+00,1.284000E+01,2.178600E+01,4.110800E+01,1.175400E+02,& + & 1.379100E+03,9.379700E+03,5.579000E+04,2.159800E-05,1.243900E-04,& + & 5.690300E-04,2.024700E-03,5.844800E-03,1.596700E-02,5.231500E-02,& + & 2.520400E-01,2.344300E+00,1.084800E+01,1.866600E+01,3.204800E+01,& + & 6.725900E+01,6.897300E+02,4.690100E+03,2.789500E+04,1.752700E-05,& + & 8.385200E-05,2.479100E-04,5.818800E-04,1.307700E-03,3.268300E-03,& + & 1.034200E-02,5.536600E-02,6.667300E-01,3.741300E+00,7.423900E+00,& + & 1.459300E+01,2.726500E+01,4.663600E+01,7.808600E+01,1.382000E+02,& + & 1.200800E-05,5.577300E-05,3.422000E-04,2.158000E-03,7.475800E-03,& + & 2.417200E-02,7.652500E-02,3.305100E-01,3.550900E+00,2.011700E+01,& + & 4.340800E+01,1.050800E+02,3.414100E+02,3.731100E+03,2.315300E+04,& + & 1.328000E+05,2.365500E-05,1.288200E-04,7.281000E-04,3.335300E-03,& + & 1.109800E-02,3.275300E-02,1.027900E-01,4.592300E-01,3.791700E+00,& + & 1.621800E+01,3.296200E+01,7.898200E+01,2.561300E+02,2.798400E+03,& + & 1.736500E+04,9.960200E+04,2.665500E-05,1.509100E-04,7.765100E-04,& + & 3.102500E-03,9.810800E-03,2.856700E-02,9.115400E-02,4.275200E-01,& + & 3.629800E+00,1.538700E+01,2.601600E+01,5.446300E+01,1.708900E+02,& + & 1.865700E+03,1.157700E+04,6.640100E+04,2.676500E-05,1.536900E-04,& + & 7.043800E-04,2.486300E-03,7.234300E-03,2.021500E-02,6.783200E-02,& + & 3.295600E-01,2.898100E+00,1.278300E+01,2.146100E+01,3.660600E+01,& + & 8.963800E+01,9.330800E+02,5.788600E+03,3.320100E+04,1.998300E-05,& + & 9.147700E-05,2.648800E-04,6.064700E-04,1.350500E-03,3.345400E-03,& + & 1.074700E-02,6.332500E-02,7.718100E-01,4.106000E+00,7.634500E+00,& + & 1.473700E+01,2.646400E+01,4.376400E+01,7.316200E+01,1.287500E+02/ + data absb(:, 661: 680) / & + & 1.688100E-05,8.607900E-05,5.311500E-04,2.994600E-03,1.040700E-02,& + & 3.320600E-02,1.059100E-01,4.612600E-01,4.939200E+00,2.785200E+01,& + & 5.915000E+01,1.438700E+02,4.857900E+02,4.874000E+03,2.777000E+04,& + & 1.540800E+05,3.110000E-05,1.735000E-04,9.808800E-04,4.349100E-03,& + & 1.466800E-02,4.355200E-02,1.378300E-01,6.031000E-01,4.797300E+00,& + & 2.149400E+01,4.450600E+01,1.080700E+02,3.644200E+02,3.655600E+03,& + & 2.082800E+04,1.155600E+05,3.390900E-05,1.933100E-04,9.904400E-04,& + & 3.929800E-03,1.255300E-02,3.713500E-02,1.208000E-01,5.556400E-01,& + & 4.505500E+00,1.832000E+01,3.217200E+01,7.274500E+01,2.430800E+02,& + & 2.437200E+03,1.388600E+04,7.704000E+04,3.274500E-05,1.881400E-04,& + & 8.596900E-04,3.035700E-03,8.888000E-03,2.545500E-02,8.777500E-02,& + & 4.233800E-01,3.533700E+00,1.485100E+01,2.435700E+01,4.312300E+01,& + & 1.231500E+02,1.218800E+03,6.943100E+03,3.852000E+04,2.227600E-05,& + & 9.854500E-05,2.799500E-04,6.281700E-04,1.388800E-03,3.406200E-03,& + & 1.111600E-02,7.216600E-02,8.820900E-01,4.414900E+00,7.919200E+00,& + & 1.459300E+01,2.568700E+01,4.090100E+01,6.871900E+01,1.200700E+02,& + & 2.342100E-05,1.287800E-04,7.853900E-04,4.021100E-03,1.407200E-02,& + & 4.465200E-02,1.436900E-01,6.340500E-01,6.711900E+00,3.804700E+01,& + & 7.924500E+01,1.933600E+02,6.729700E+02,6.175500E+03,3.251700E+04,& + & 1.749500E+05,4.027800E-05,2.309300E-04,1.294600E-03,5.559000E-03,& + & 1.910200E-02,5.702100E-02,1.814800E-01,7.797600E-01,6.040600E+00,& + & 2.878200E+01,5.954900E+01,1.451800E+02,5.048200E+02,4.631800E+03,& + & 2.438800E+04,1.312100E+05,4.262000E-05,2.450900E-04,1.245100E-03,& + & 4.891800E-03,1.591100E-02,4.780200E-02,1.580900E-01,7.098500E-01,& + & 5.507900E+00,2.198100E+01,4.108500E+01,9.704600E+01,3.366800E+02,& + & 3.088000E+03,1.625900E+04,8.747600E+04,3.965700E-05,2.278400E-04,& + & 1.034200E-03,3.664900E-03,1.087200E-02,3.186300E-02,1.130900E-01,& + & 5.350100E-01,4.255100E+00,1.708400E+01,2.749400E+01,5.288200E+01,& + & 1.687500E+02,1.544200E+03,8.129900E+03,4.373800E+04,2.442200E-05,& + & 1.050500E-04,2.929900E-04,6.466800E-04,1.421100E-03,3.454200E-03,& + & 1.143800E-02,8.200800E-02,9.982800E-01,4.658400E+00,8.149600E+00,& + & 1.442200E+01,2.465400E+01,3.869200E+01,6.366100E+01,1.120400E+02,& + & 3.193500E-05,1.867200E-04,1.116400E-03,5.264200E-03,1.847200E-02,& + & 5.898900E-02,1.914400E-01,8.590300E-01,8.944700E+00,5.103600E+01,& + & 1.046700E+02,2.557900E+02,9.088400E+02,7.616800E+03,3.732300E+04,& + & 1.948800E+05,5.136400E-05,3.034300E-04,1.673800E-03,6.999500E-03,& + & 2.439100E-02,7.362800E-02,2.350100E-01,9.948800E-01,7.595700E+00,& + & 3.837800E+01,7.861000E+01,1.920000E+02,6.817300E+02,5.712800E+03,& + & 2.799200E+04,1.461600E+05,5.288900E-05,3.078100E-04,1.545300E-03,& + & 6.004000E-03,1.988300E-02,6.104500E-02,2.039300E-01,8.945800E-01,& + & 6.632100E+00,2.731100E+01,5.299000E+01,1.282300E+02,4.546200E+02,& + & 3.808700E+03,1.866200E+04,9.744300E+04,4.756900E-05,2.734700E-04,& + & 1.231500E-03,4.366100E-03,1.321100E-02,3.970100E-02,1.444500E-01,& + & 6.672600E-01,5.054400E+00,1.959900E+01,3.152300E+01,6.647800E+01,& + & 2.275800E+02,1.904600E+03,9.331200E+03,4.872200E+04,2.637300E-05,& + & 1.108400E-04,3.038800E-04,6.623900E-04,1.447000E-03,3.492700E-03,& + & 1.171600E-02,9.270400E-02,1.112100E+00,4.920900E+00,8.278900E+00,& + & 1.424100E+01,2.362000E+01,3.624400E+01,5.946800E+01,1.047200E+02,& + & 7.146100E-06,2.848200E-05,1.677500E-04,1.248000E-03,4.423900E-03,& + & 1.450800E-02,4.621700E-02,2.002400E-01,2.220900E+00,1.304500E+01,& + & 2.891700E+01,7.112500E+01,2.231000E+02,2.780600E+03,1.975000E+04,& + & 1.187600E+05,1.436100E-05,7.572100E-05,4.285300E-04,2.095300E-03,& + & 6.968300E-03,2.072900E-02,6.537000E-02,3.041600E-01,2.736400E+00,& + & 1.207200E+01,2.284900E+01,5.357600E+01,1.674200E+02,2.085500E+03,& + & 1.481200E+04,8.907100E+04,1.660400E-05,9.310000E-05,4.842100E-04,& + & 2.010200E-03,6.361900E-03,1.846600E-02,5.901200E-02,2.872000E-01,& + & 2.688500E+00,1.233200E+01,2.121200E+01,3.974400E+01,1.122400E+02,& + & 1.390500E+03,9.875100E+03,5.938000E+04,1.720700E-05,9.928800E-05,& + & 4.609400E-04,1.669000E-03,4.882500E-03,1.348100E-02,4.498900E-02,& + & 2.244800E-01,2.203800E+00,1.051500E+01,1.830300E+01,3.184500E+01,& + & 6.562500E+01,6.954100E+02,4.937800E+03,2.969000E+04,1.388000E-05,& + & 6.718400E-05,1.997600E-04,4.721000E-04,1.064300E-03,2.673500E-03,& + & 8.535800E-03,4.764600E-02,6.242800E-01,3.634900E+00,7.308200E+00,& + & 1.458400E+01,2.758900E+01,4.778100E+01,8.019200E+01,1.423500E+02/ + data absb(:, 681: 700) / & + & 1.000900E-05,4.532200E-05,2.776200E-04,1.811500E-03,6.328900E-03,& + & 2.067500E-02,6.611400E-02,2.884600E-01,3.213500E+00,1.866900E+01,& + & 4.099500E+01,1.012300E+02,3.305100E+02,3.810500E+03,2.456200E+04,& + & 1.422100E+05,1.922800E-05,1.037900E-04,5.934800E-04,2.793600E-03,& + & 9.414300E-03,2.826400E-02,9.017300E-02,4.125600E-01,3.546900E+00,& + & 1.534200E+01,3.127000E+01,7.609300E+01,2.479600E+02,2.858000E+03,& + & 1.842200E+04,1.066600E+05,2.149600E-05,1.213600E-04,6.334300E-04,& + & 2.586100E-03,8.287000E-03,2.452600E-02,7.977700E-02,3.857200E-01,& + & 3.420600E+00,1.489200E+01,2.537500E+01,5.281300E+01,1.654600E+02,& + & 1.905400E+03,1.228100E+04,7.110600E+04,2.146200E-05,1.234200E-04,& + & 5.745100E-04,2.062500E-03,6.088200E-03,1.723000E-02,5.904500E-02,& + & 2.975900E-01,2.750100E+00,1.247400E+01,2.119300E+01,3.646400E+01,& + & 8.743600E+01,9.529100E+02,6.140900E+03,3.555300E+04,1.592300E-05,& + & 7.355200E-05,2.141600E-04,4.929600E-04,1.100700E-03,2.739400E-03,& + & 8.890100E-03,5.502100E-02,7.302500E-01,4.012400E+00,7.558200E+00,& + & 1.475300E+01,2.681600E+01,4.482000E+01,7.503200E+01,1.324400E+02,& + & 1.408900E-05,7.046600E-05,4.362100E-04,2.533200E-03,8.872300E-03,& + & 2.864000E-02,9.233900E-02,4.074000E-01,4.530200E+00,2.624400E+01,& + & 5.667300E+01,1.404700E+02,4.770500E+02,5.031700E+03,2.964600E+04,& + & 1.658700E+05,2.542000E-05,1.408300E-04,8.066700E-04,3.669300E-03,& + & 1.255000E-02,3.795200E-02,1.222200E-01,5.472600E-01,4.521000E+00,& + & 2.039000E+01,4.268400E+01,1.055100E+02,3.578700E+02,3.773900E+03,& + & 2.223500E+04,1.244000E+05,2.752100E-05,1.565000E-04,8.143700E-04,& + & 3.297700E-03,1.068900E-02,3.218600E-02,1.069900E-01,5.069400E-01,& + & 4.283200E+00,1.784100E+01,3.129800E+01,7.118900E+01,2.387100E+02,& + & 2.516000E+03,1.482300E+04,8.293400E+04,2.642400E-05,1.520700E-04,& + & 7.055100E-04,2.533700E-03,7.534400E-03,2.189600E-02,7.737800E-02,& + & 3.869800E-01,3.381000E+00,1.458900E+01,2.418300E+01,4.287600E+01,& + & 1.212700E+02,1.258200E+03,7.411800E+03,4.146700E+04,1.784500E-05,& + & 7.946300E-05,2.270100E-04,5.114200E-04,1.134000E-03,2.793000E-03,& + & 9.208400E-03,6.337300E-02,8.422200E-01,4.333700E+00,7.869500E+00,& + & 1.463500E+01,2.605200E+01,4.187000E+01,7.039300E+01,1.234100E+02,& + & 1.962000E-05,1.062400E-04,6.521500E-04,3.422600E-03,1.207500E-02,& + & 3.881000E-02,1.263900E-01,5.667900E-01,6.233500E+00,3.629100E+01,& + & 7.694600E+01,1.907500E+02,6.703300E+02,6.434800E+03,3.489000E+04,& + & 1.892000E+05,3.311900E-05,1.888300E-04,1.075100E-03,4.717500E-03,& + & 1.646900E-02,5.016600E-02,1.625600E-01,7.145400E-01,5.721400E+00,& + & 2.752800E+01,5.782600E+01,1.432200E+02,5.028400E+02,4.826200E+03,& + & 2.616700E+04,1.419000E+05,3.480000E-05,1.997500E-04,1.031700E-03,& + & 4.129700E-03,1.365500E-02,4.182600E-02,1.416400E-01,6.540700E-01,& + & 5.276900E+00,2.145300E+01,4.012500E+01,9.575900E+01,3.353600E+02,& + & 3.217600E+03,1.744500E+04,9.460100E+04,3.219300E-05,1.853300E-04,& + & 8.540100E-04,3.075800E-03,9.284200E-03,2.766000E-02,1.010100E-01,& + & 4.945700E-01,4.101400E+00,1.689600E+01,2.742600E+01,5.259200E+01,& + & 1.681600E+02,1.609000E+03,8.722700E+03,4.730000E+04,1.964500E-05,& + & 8.495700E-05,2.382100E-04,5.271900E-04,1.162000E-03,2.835600E-03,& + & 9.493000E-03,7.280400E-02,9.600000E-01,4.593600E+00,8.131200E+00,& + & 1.446100E+01,2.503800E+01,3.959700E+01,6.515100E+01,1.150600E+02,& + & 2.688500E-05,1.552000E-04,9.350400E-04,4.498800E-03,1.593300E-02,& + & 5.162400E-02,1.698600E-01,7.770300E-01,8.403700E+00,4.935000E+01,& + & 1.029300E+02,2.548700E+02,9.161600E+02,7.996500E+03,4.021800E+04,& + & 2.116500E+05,4.249900E-05,2.498300E-04,1.400400E-03,5.968600E-03,& + & 2.117400E-02,6.532700E-02,2.125500E-01,9.206600E-01,7.234900E+00,& + & 3.712300E+01,7.730500E+01,1.913100E+02,6.872200E+02,5.997500E+03,& + & 3.016400E+04,1.587400E+05,4.344400E-05,2.525000E-04,1.288600E-03,& + & 5.092900E-03,1.718000E-02,5.392500E-02,1.846700E-01,8.323900E-01,& + & 6.398500E+00,2.668000E+01,5.220500E+01,1.277700E+02,4.582800E+02,& + & 3.998500E+03,2.010900E+04,1.058300E+05,3.883600E-05,2.236900E-04,& + & 1.022200E-03,3.682700E-03,1.135400E-02,3.478100E-02,1.305500E-01,& + & 6.226600E-01,4.907000E+00,1.949500E+01,3.149600E+01,6.644300E+01,& + & 2.294100E+02,1.999500E+03,1.005500E+04,5.291300E+04,2.126900E-05,& + & 8.987900E-05,2.475900E-04,5.410800E-04,1.184800E-03,2.870800E-03,& + & 9.746700E-03,8.321000E-02,1.076600E+00,4.866700E+00,8.268900E+00,& + & 1.431100E+01,2.400700E+01,3.706100E+01,6.080900E+01,1.074300E+02/ + data absb(:, 701: 720) / & + & 5.944200E-06,2.285200E-05,1.328000E-04,1.027900E-03,3.686700E-03,& + & 1.217300E-02,3.915500E-02,1.711300E-01,1.964700E+00,1.180300E+01,& + & 2.663400E+01,6.699900E+01,2.116500E+02,2.778700E+03,2.062000E+04,& + & 1.254600E+05,1.154900E-05,6.019100E-05,3.431900E-04,1.730300E-03,& + & 5.812800E-03,1.755800E-02,5.618300E-02,2.682600E-01,2.520100E+00,& + & 1.143900E+01,2.138500E+01,5.055300E+01,1.588400E+02,2.084100E+03,& + & 1.546500E+04,9.409900E+04,1.324200E-05,7.391100E-05,3.888800E-04,& + & 1.654600E-03,5.294900E-03,1.557700E-02,5.059600E-02,2.541700E-01,& + & 2.497400E+00,1.178600E+01,2.056100E+01,3.832800E+01,1.067400E+02,& + & 1.389500E+03,1.031000E+04,6.273300E+04,1.364100E-05,7.884700E-05,& + & 3.713100E-04,1.368400E-03,4.055300E-03,1.131700E-02,3.842400E-02,& + & 1.986700E-01,2.061400E+00,1.014900E+01,1.788500E+01,3.154000E+01,& + & 6.401700E+01,6.950000E+02,5.155500E+03,3.136700E+04,1.095100E-05,& + & 5.370700E-05,1.606700E-04,3.825900E-04,8.656100E-04,2.186000E-03,& + & 7.038300E-03,4.087600E-02,5.832500E-01,3.517100E+00,7.190100E+00,& + & 1.455700E+01,2.788800E+01,4.892500E+01,8.233300E+01,1.465700E+02,& + & 8.289000E-06,3.647700E-05,2.227400E-04,1.510000E-03,5.314300E-03,& + & 1.752100E-02,5.665900E-02,2.497800E-01,2.885200E+00,1.719400E+01,& + & 3.837500E+01,9.698900E+01,3.181900E+02,3.861400E+03,2.586200E+04,& + & 1.512500E+05,1.553800E-05,8.307400E-05,4.801600E-04,2.326000E-03,& + & 7.927100E-03,2.420400E-02,7.850300E-02,3.683100E-01,3.299900E+00,& + & 1.449500E+01,2.945100E+01,7.290400E+01,2.387300E+02,2.896100E+03,& + & 1.939600E+04,1.134400E+05,1.724500E-05,9.703000E-05,5.134100E-04,& + & 2.144200E-03,6.955100E-03,2.090500E-02,6.934000E-02,3.459900E-01,& + & 3.208100E+00,1.434400E+01,2.468200E+01,5.103800E+01,1.593200E+02,& + & 1.930900E+03,1.293100E+04,7.562500E+04,1.712900E-05,9.864000E-05,& + & 4.664000E-04,1.702500E-03,5.094700E-03,1.460600E-02,5.108500E-02,& + & 2.672300E-01,2.597800E+00,1.212700E+01,2.086700E+01,3.623900E+01,& + & 8.500300E+01,9.656600E+02,6.465900E+03,3.781200E+04,1.264700E-05,& + & 5.901900E-05,1.729100E-04,4.002900E-04,8.971000E-04,2.243100E-03,& + & 7.347000E-03,4.768000E-02,6.895900E-01,3.911300E+00,7.474000E+00,& + & 1.475400E+01,2.711800E+01,4.592200E+01,7.693000E+01,1.353100E+02,& + & 1.167500E-05,5.711700E-05,3.545600E-04,2.125700E-03,7.504400E-03,& + & 2.449400E-02,7.992800E-02,3.570500E-01,4.124300E+00,2.453900E+01,& + & 5.392800E+01,1.364500E+02,4.659100E+02,5.157400E+03,3.142900E+04,& + & 1.774400E+05,2.065800E-05,1.135300E-04,6.586600E-04,3.075900E-03,& + & 1.065800E-02,3.284000E-02,1.076600E-01,4.939500E-01,4.242100E+00,& + & 1.924300E+01,4.067100E+01,1.025000E+02,3.495100E+02,3.868100E+03,& + & 2.357100E+04,1.330800E+05,2.222000E-05,1.259800E-04,6.654500E-04,& + & 2.751400E-03,9.044900E-03,2.771000E-02,9.422500E-02,4.599100E-01,& + & 4.054000E+00,1.730700E+01,3.035600E+01,6.935400E+01,2.331400E+02,& + & 2.578900E+03,1.571400E+04,8.872300E+04,2.122600E-05,1.223000E-04,& + & 5.762800E-04,2.104400E-03,6.352200E-03,1.873800E-02,6.785800E-02,& + & 3.518500E-01,3.222100E+00,1.427500E+01,2.395500E+01,4.255900E+01,& + & 1.188000E+02,1.289700E+03,7.857500E+03,4.436200E+04,1.426700E-05,& + & 6.395400E-05,1.838300E-04,4.159800E-04,9.251700E-04,2.289700E-03,& + & 7.623000E-03,5.552800E-02,8.026300E-01,4.245400E+00,7.818200E+00,& + & 1.466000E+01,2.639600E+01,4.285300E+01,7.208000E+01,1.267600E+02,& + & 1.631700E-05,8.679700E-05,5.362900E-04,2.892000E-03,1.028100E-02,& + & 3.346500E-02,1.104200E-01,5.032600E-01,5.751700E+00,3.438100E+01,& + & 7.431000E+01,1.875000E+02,6.634900E+02,6.658700E+03,3.720700E+04,& + & 2.034100E+05,2.708300E-05,1.533800E-04,8.858800E-04,3.979900E-03,& + & 1.409900E-02,4.383800E-02,1.447500E-01,6.516000E-01,5.397800E+00,& + & 2.617500E+01,5.585000E+01,1.407800E+02,4.977100E+02,4.994100E+03,& + & 2.790500E+04,1.525600E+05,2.827600E-05,1.619300E-04,8.497000E-04,& + & 3.467000E-03,1.164300E-02,3.635900E-02,1.262600E-01,5.999300E-01,& + & 5.036400E+00,2.087100E+01,3.903300E+01,9.417800E+01,3.319500E+02,& + & 3.329600E+03,1.860400E+04,1.017100E+05,2.601300E-05,1.500500E-04,& + & 7.018100E-04,2.569300E-03,7.885600E-03,2.389000E-02,8.978100E-02,& + & 4.549900E-01,3.939200E+00,1.664600E+01,2.730900E+01,5.219600E+01,& + & 1.665600E+02,1.665000E+03,9.302200E+03,5.085400E+04,1.575100E-05,& + & 6.858000E-05,1.933800E-04,4.298000E-04,9.493800E-04,2.327300E-03,& + & 7.876200E-03,6.453500E-02,9.218100E-01,4.523600E+00,8.095000E+00,& + & 1.449100E+01,2.546500E+01,4.042800E+01,6.668900E+01,1.181000E+02/ + data absb(:, 721: 740) / & + & 2.246200E-05,1.278400E-04,7.768300E-04,3.824500E-03,1.364900E-02,& + & 4.481500E-02,1.497500E-01,6.977800E-01,7.852300E+00,4.738700E+01,& + & 1.006700E+02,2.529700E+02,9.184700E+02,8.343900E+03,4.309000E+04,& + & 2.285800E+05,3.496600E-05,2.044100E-04,1.165400E-03,5.064500E-03,& + & 1.824800E-02,5.761400E-02,1.911100E-01,8.475200E-01,6.865700E+00,& + & 3.567400E+01,7.561000E+01,1.898800E+02,6.889500E+02,6.258100E+03,& + & 3.231800E+04,1.714400E+05,3.551900E-05,2.060400E-04,1.069300E-03,& + & 4.300900E-03,1.474800E-02,4.733700E-02,1.663700E-01,7.708800E-01,& + & 6.152100E+00,2.593800E+01,5.120600E+01,1.268200E+02,4.594400E+02,& + & 4.172300E+03,2.154500E+04,1.142900E+05,3.156600E-05,1.821900E-04,& + & 8.454700E-04,3.093500E-03,9.705700E-03,3.031900E-02,1.173900E-01,& + & 5.786100E-01,4.748000E+00,1.931400E+01,3.141400E+01,6.618400E+01,& + & 2.300000E+02,2.086400E+03,1.077300E+04,5.714600E+04,1.711800E-05,& + & 7.275700E-05,2.015100E-04,4.415400E-04,9.696300E-04,2.359300E-03,& + & 8.103900E-03,7.465900E-02,1.040500E+00,4.802100E+00,8.264400E+00,& + & 1.438900E+01,2.433700E+01,3.790000E+01,6.219400E+01,1.101500E+02,& + & 5.003900E-06,1.853200E-05,1.059300E-04,8.524800E-04,3.098500E-03,& + & 1.029500E-02,3.344200E-02,1.473600E-01,1.751200E+00,1.077500E+01,& + & 2.473800E+01,6.369800E+01,2.033500E+02,2.799800E+03,2.169100E+04,& + & 1.335600E+05,9.348700E-06,4.802100E-05,2.758800E-04,1.436600E-03,& + & 4.878100E-03,1.495500E-02,4.857400E-02,2.378200E-01,2.334900E+00,& + & 1.090300E+01,2.023300E+01,4.817300E+01,1.526000E+02,2.099900E+03,& + & 1.626800E+04,1.001700E+05,1.060100E-05,5.880900E-05,3.129900E-04,& + & 1.368100E-03,4.429900E-03,1.320400E-02,4.361300E-02,2.259400E-01,& + & 2.331800E+00,1.132600E+01,2.002000E+01,3.731400E+01,1.028200E+02,& + & 1.400100E+03,1.084600E+04,6.677700E+04,1.083100E-05,6.267700E-05,& + & 2.994800E-04,1.125900E-03,3.382000E-03,9.546300E-03,3.293000E-02,& + & 1.765000E-01,1.936600E+00,9.829100E+00,1.754700E+01,3.135600E+01,& + & 6.302300E+01,7.004100E+02,5.423100E+03,3.338900E+04,8.623400E-06,& + & 4.288900E-05,1.291600E-04,3.098600E-04,7.040000E-04,1.786900E-03,& + & 5.805000E-03,3.499200E-02,5.446300E-01,3.402700E+00,7.061900E+00,& + & 1.451500E+01,2.815300E+01,5.003100E+01,8.444800E+01,1.507700E+02,& + & 6.941900E-06,2.963900E-05,1.800500E-04,1.269300E-03,4.500900E-03,& + & 1.496900E-02,4.896500E-02,2.181700E-01,2.614400E+00,1.596600E+01,& + & 3.623400E+01,9.392100E+01,3.100300E+02,3.946000E+03,2.744400E+04,& + & 1.622100E+05,1.263100E-05,6.677200E-05,3.900200E-04,1.949600E-03,& + & 6.716500E-03,2.085400E-02,6.879200E-02,3.308700E-01,3.090500E+00,& + & 1.384700E+01,2.798200E+01,7.060000E+01,2.326000E+02,2.959600E+03,& + & 2.058300E+04,1.216600E+05,1.388800E-05,7.778100E-05,4.174200E-04,& + & 1.787900E-03,5.869800E-03,1.792300E-02,6.062000E-02,3.119800E-01,& + & 3.025800E+00,1.390000E+01,2.417500E+01,4.984200E+01,1.552400E+02,& + & 1.973200E+03,1.372200E+04,8.110500E+04,1.369800E-05,7.894500E-05,& + & 3.794400E-04,1.411600E-03,4.282900E-03,1.244900E-02,4.440800E-02,& + & 2.410500E-01,2.466300E+00,1.182900E+01,2.063700E+01,3.621600E+01,& + & 8.353900E+01,9.868000E+02,6.862300E+03,4.054500E+04,1.003400E-05,& + & 4.731900E-05,1.394900E-04,3.249400E-04,7.307100E-04,1.836800E-03,& + & 6.068200E-03,4.126300E-02,6.510600E-01,3.806800E+00,7.402500E+00,& + & 1.471600E+01,2.739500E+01,4.699800E+01,7.879100E+01,1.398600E+02,& + & 9.773900E-06,4.669900E-05,2.903400E-04,1.799200E-03,6.400100E-03,& + & 2.112000E-02,6.980300E-02,3.159000E-01,3.792000E+00,2.316300E+01,& + & 5.177900E+01,1.340700E+02,4.602400E+02,5.332300E+03,3.360300E+04,& + & 1.914600E+05,1.689000E-05,9.197000E-05,5.405600E-04,2.596200E-03,& + & 9.110300E-03,2.859700E-02,9.553300E-02,4.489300E-01,4.011700E+00,& + & 1.835000E+01,3.911500E+01,1.007200E+02,3.452600E+02,3.999300E+03,& + & 2.520200E+04,1.435900E+05,1.801500E-05,1.017300E-04,5.459900E-04,& + & 2.309300E-03,7.700700E-03,2.400400E-02,8.353200E-02,4.198700E-01,& + & 3.860500E+00,1.688800E+01,2.971400E+01,6.831300E+01,2.303100E+02,& + & 2.666300E+03,1.680200E+04,9.572900E+04,1.709600E-05,9.851600E-05,& + & 4.720800E-04,1.756100E-03,5.384300E-03,1.613000E-02,5.982600E-02,& + & 3.218300E-01,3.085900E+00,1.403300E+01,2.385300E+01,4.255800E+01,& + & 1.176500E+02,1.333400E+03,8.401000E+03,4.786400E+04,1.138300E-05,& + & 5.144700E-05,1.487900E-04,3.382600E-04,7.547900E-04,1.876600E-03,& + & 6.311600E-03,4.863100E-02,7.648900E-01,4.152400E+00,7.756800E+00,& + & 1.467300E+01,2.671800E+01,4.381900E+01,7.373700E+01,1.300500E+02/ + data absb(:, 741: 760) / & + & 1.370200E-05,7.153600E-05,4.447600E-04,2.465700E-03,8.832400E-03,& + & 2.909700E-02,9.736000E-02,4.506300E-01,5.360300E+00,3.290500E+01,& + & 7.252700E+01,1.866300E+02,6.638100E+02,6.953100E+03,4.002400E+04,& + & 2.178100E+05,2.228400E-05,1.252700E-04,7.342700E-04,3.382900E-03,& + & 1.215400E-02,3.856500E-02,1.298800E-01,5.983600E-01,5.136800E+00,& + & 2.514600E+01,5.451100E+01,1.401300E+02,4.979500E+02,5.214900E+03,& + & 3.001800E+04,1.654600E+05,2.307800E-05,1.317400E-04,7.034100E-04,& + & 2.930200E-03,9.994100E-03,3.182200E-02,1.132800E-01,5.534300E-01,& + & 4.839200E+00,2.046200E+01,3.835700E+01,9.378200E+01,3.321000E+02,& + & 3.476700E+03,2.001200E+04,1.103100E+05,2.108400E-05,1.217400E-04,& + & 5.790000E-04,2.157700E-03,6.736200E-03,2.076400E-02,8.024000E-02,& + & 4.209200E-01,3.803900E+00,1.647400E+01,2.735700E+01,5.233800E+01,& + & 1.667300E+02,1.738600E+03,1.000600E+04,5.515300E+04,1.261700E-05,& + & 5.534100E-05,1.568600E-04,3.503300E-04,7.757200E-04,1.910500E-03,& + & 6.533000E-03,5.722600E-02,8.847100E-01,4.450700E+00,8.059300E+00,& + & 1.452100E+01,2.584600E+01,4.125300E+01,6.816700E+01,1.210900E+02,& + & 1.894600E-05,1.062200E-04,6.505800E-04,3.283500E-03,1.179900E-02,& + & 3.925000E-02,1.333300E-01,6.326400E-01,7.414300E+00,4.595900E+01,& + & 9.960200E+01,2.542400E+02,9.304100E+02,8.787300E+03,4.658800E+04,& + & 2.491200E+05,2.895800E-05,1.682900E-04,9.758000E-04,4.331400E-03,& + & 1.585000E-02,5.117900E-02,1.732100E-01,7.862100E-01,6.575800E+00,& + & 3.463200E+01,7.480700E+01,1.908400E+02,6.979000E+02,6.590600E+03,& + & 3.494100E+04,1.868400E+05,2.918800E-05,1.688800E-04,8.920700E-04,& + & 3.658100E-03,1.275000E-02,4.185100E-02,1.510200E-01,7.183700E-01,& + & 5.958200E+00,2.545800E+01,5.077400E+01,1.274500E+02,4.654000E+02,& + & 4.393900E+03,2.329400E+04,1.245600E+05,2.574600E-05,1.488200E-04,& + & 7.023600E-04,2.612800E-03,8.348700E-03,2.662000E-02,1.062800E-01,& + & 5.408500E-01,4.620800E+00,1.923300E+01,3.157900E+01,6.666700E+01,& + & 2.329800E+02,2.197200E+03,1.164700E+04,6.227900E+04,1.376700E-05,& + & 5.885700E-05,1.639000E-04,3.605100E-04,7.931500E-04,1.939000E-03,& + & 6.734500E-03,6.707400E-02,1.005400E+00,4.737200E+00,8.261800E+00,& + & 1.444400E+01,2.464700E+01,3.874500E+01,6.348800E+01,1.128400E+02,& + & 4.187300E-06,1.478400E-05,8.222700E-05,6.929900E-04,2.562900E-03,& + & 8.560000E-03,2.807400E-02,1.247100E-01,1.531000E+00,9.678500E+00,& + & 2.259800E+01,5.955600E+01,1.924400E+02,2.778400E+03,2.260300E+04,& + & 1.412600E+05,7.479500E-06,3.771500E-05,2.177900E-04,1.175600E-03,& + & 4.032900E-03,1.253700E-02,4.129300E-02,2.076700E-01,2.136000E+00,& + & 1.029300E+01,1.897900E+01,4.522100E+01,1.444300E+02,2.083900E+03,& + & 1.695200E+04,1.059400E+05,8.383000E-06,4.610500E-05,2.479700E-04,& + & 1.117200E-03,3.658800E-03,1.103200E-02,3.700000E-02,1.976500E-01,& + & 2.150800E+00,1.078800E+01,1.933900E+01,3.603900E+01,9.774400E+01,& + & 1.389400E+03,1.130200E+04,7.063000E+04,8.490600E-06,4.916200E-05,& + & 2.383800E-04,9.166600E-04,2.790100E-03,7.954100E-03,2.781200E-02,& + & 1.543300E-01,1.797800E+00,9.438000E+00,1.709200E+01,3.098500E+01,& + & 6.168200E+01,6.954400E+02,5.651100E+03,3.531500E+04,6.709600E-06,& + & 3.398900E-05,1.032100E-04,2.500800E-04,5.711400E-04,1.458100E-03,& + & 4.771200E-03,2.961700E-02,5.026500E-01,3.265100E+00,6.906300E+00,& + & 1.442400E+01,2.843100E+01,5.129200E+01,8.689600E+01,1.556700E+02,& + & 5.760900E-06,2.363500E-05,1.421100E-04,1.050400E-03,3.757800E-03,& + & 1.260400E-02,4.166100E-02,1.873600E-01,2.333500E+00,1.457800E+01,& + & 3.372100E+01,8.971500E+01,2.978500E+02,3.983000E+03,2.893500E+04,& + & 1.732200E+05,1.014400E-05,5.284300E-05,3.115900E-04,1.614700E-03,& + & 5.614200E-03,1.771000E-02,5.938000E-02,2.930900E-01,2.863600E+00,& + & 1.313300E+01,2.628900E+01,6.744800E+01,2.234700E+02,2.987400E+03,& + & 2.170200E+04,1.299200E+05,1.105100E-05,6.148800E-05,3.346000E-04,& + & 1.474600E-03,4.897700E-03,1.516300E-02,5.220500E-02,2.773600E-01,& + & 2.824000E+00,1.338000E+01,2.354100E+01,4.819600E+01,1.492000E+02,& + & 1.991700E+03,1.446800E+04,8.661200E+04,1.082600E-05,6.240200E-05,& + & 3.049800E-04,1.159100E-03,3.566200E-03,1.049000E-02,3.804500E-02,& + & 2.143800E-01,2.317200E+00,1.146000E+01,2.030000E+01,3.605300E+01,& + & 8.127600E+01,9.960600E+02,7.234300E+03,4.330600E+04,7.887200E-06,& + & 3.769600E-05,1.119600E-04,2.629600E-04,5.937900E-04,1.500800E-03,& + & 4.998500E-03,3.533300E-02,6.079100E-01,3.682000E+00,7.292200E+00,& + & 1.467200E+01,2.771100E+01,4.817700E+01,8.096900E+01,1.440800E+02/ + data absb(:, 761: 780) / & + & 8.094700E-06,3.748200E-05,2.328400E-04,1.504200E-03,5.388100E-03,& + & 1.798600E-02,6.015600E-02,2.756100E-01,3.439800E+00,2.156800E+01,& + & 4.905900E+01,1.304100E+02,4.487200E+02,5.460300E+03,3.576600E+04,& + & 2.061100E+05,1.365700E-05,7.343400E-05,4.369000E-04,2.168300E-03,& + & 7.691500E-03,2.457800E-02,8.367000E-02,4.030700E-01,3.760000E+00,& + & 1.734300E+01,3.716800E+01,9.795800E+01,3.366300E+02,4.095300E+03,& + & 2.682500E+04,1.545800E+05,1.444100E-05,8.112100E-05,4.425200E-04,& + & 1.919000E-03,6.484400E-03,2.055200E-02,7.306000E-02,3.785400E-01,& + & 3.642800E+00,1.636700E+01,2.892000E+01,6.668200E+01,2.245800E+02,& + & 2.730400E+03,1.788300E+04,1.020000E+05,1.361700E-05,7.849100E-05,& + & 3.828700E-04,1.452400E-03,4.522900E-03,1.373800E-02,5.207500E-02,& + & 2.905700E-01,2.930100E+00,1.370400E+01,2.366500E+01,4.235600E+01,& + & 1.151700E+02,1.365400E+03,8.941900E+03,5.152800E+04,9.000700E-06,& + & 4.116700E-05,1.198900E-04,2.743900E-04,6.145500E-04,1.535700E-03,& + & 5.211900E-03,4.214200E-02,7.217000E-01,4.043200E+00,7.659900E+00,& + & 1.468500E+01,2.707300E+01,4.492500E+01,7.566600E+01,1.338500E+02,& + & 1.137900E-05,5.795700E-05,3.623300E-04,2.081900E-03,7.509100E-03,& + & 2.501600E-02,8.483800E-02,3.983400E-01,4.939200E+00,3.116000E+01,& + & 6.994700E+01,1.841300E+02,6.564600E+02,7.206500E+03,4.294000E+04,& + & 2.391900E+05,1.814300E-05,1.009400E-04,6.008100E-04,2.851000E-03,& + & 1.036700E-02,3.353200E-02,1.152000E-01,5.435600E-01,4.853500E+00,& + & 2.394100E+01,5.258200E+01,1.382500E+02,4.924300E+02,5.405000E+03,& + & 3.220500E+04,1.794000E+05,1.864500E-05,1.059600E-04,5.760100E-04,& + & 2.456600E-03,8.499000E-03,2.755000E-02,1.004300E-01,5.052100E-01,& + & 4.614200E+00,1.996100E+01,3.740100E+01,9.259200E+01,3.284200E+02,& + & 3.603500E+03,2.147100E+04,1.196000E+05,1.692800E-05,9.773600E-05,& + & 4.737300E-04,1.799000E-03,5.708600E-03,1.787800E-02,7.082900E-02,& + & 3.850700E-01,3.645800E+00,1.621500E+01,2.732400E+01,5.220400E+01,& + & 1.650000E+02,1.802000E+03,1.073600E+04,5.979900E+04,1.004100E-05,& + & 4.445000E-05,1.268200E-04,2.848200E-04,6.325900E-04,1.567100E-03,& + & 5.406800E-03,5.024600E-02,8.421800E-01,4.354000E+00,7.995300E+00,& + & 1.453000E+01,2.629000E+01,4.224200E+01,6.987000E+01,1.245400E+02,& + & 1.581300E-05,8.691800E-05,5.370200E-04,2.795900E-03,1.011000E-02,& + & 3.403100E-02,1.174800E-01,5.668900E-01,6.933800E+00,4.411200E+01,& + & 9.763700E+01,2.537200E+02,9.326800E+02,9.202500E+03,5.030700E+04,& + & 2.716000E+05,2.374900E-05,1.368800E-04,8.086400E-04,3.677300E-03,& + & 1.364500E-02,4.497800E-02,1.554700E-01,7.223700E-01,6.255700E+00,& + & 3.329500E+01,7.333400E+01,1.904400E+02,6.996100E+02,6.902000E+03,& + & 3.773100E+04,2.037000E+05,2.376000E-05,1.369500E-04,7.379700E-04,& + & 3.089900E-03,1.093700E-02,3.662400E-02,1.356800E-01,6.628900E-01,& + & 5.735800E+00,2.483400E+01,4.995400E+01,1.271900E+02,4.665400E+02,& + & 4.601500E+03,2.515400E+04,1.358000E+05,2.082000E-05,1.204100E-04,& + & 5.793100E-04,2.193600E-03,7.131400E-03,2.316400E-02,9.520900E-02,& + & 5.006500E-01,4.468700E+00,1.906300E+01,3.163400E+01,6.679300E+01,& + & 2.335500E+02,2.301000E+03,1.257700E+04,6.790000E+04,1.101000E-05,& + & 4.744400E-05,1.329400E-04,2.937600E-04,6.480900E-04,1.592800E-03,& + & 5.590700E-03,5.972500E-02,9.636600E-01,4.648700E+00,8.244900E+00,& + & 1.453100E+01,2.500000E+01,3.964900E+01,6.509500E+01,1.159600E+02,& + & 3.543500E-06,1.185100E-05,6.338400E-05,5.609200E-04,2.119500E-03,& + & 7.110200E-03,2.351700E-02,1.053500E-01,1.335100E+00,8.670300E+00,& + & 2.059800E+01,5.561700E+01,1.819500E+02,2.754200E+03,2.360600E+04,& + & 1.500000E+05,5.997100E-06,2.952600E-05,1.709400E-04,9.598100E-04,& + & 3.326300E-03,1.048200E-02,3.498400E-02,1.805700E-01,1.950300E+00,& + & 9.710300E+00,1.787700E+01,4.246200E+01,1.365600E+02,2.065700E+03,& + & 1.770500E+04,1.125000E+05,6.615100E-06,3.598500E-05,1.952500E-04,& + & 9.103800E-04,3.015300E-03,9.192300E-03,3.126100E-02,1.719800E-01,& + & 1.978900E+00,1.026300E+01,1.867000E+01,3.492600E+01,9.295500E+01,& + & 1.377200E+03,1.180300E+04,7.500100E+04,6.625700E-06,3.835300E-05,& + & 1.887900E-04,7.443400E-04,2.297400E-03,6.612300E-03,2.339700E-02,& + & 1.341800E-01,1.663200E+00,9.042800E+00,1.663400E+01,3.061600E+01,& + & 6.055900E+01,6.897700E+02,5.901800E+03,3.750000E+04,5.181300E-06,& + & 2.680200E-05,8.220100E-05,2.013800E-04,4.625900E-04,1.188300E-03,& + & 3.913300E-03,2.487400E-02,4.602300E-01,3.116700E+00,6.734900E+00,& + & 1.430100E+01,2.868300E+01,5.261700E+01,8.954000E+01,1.609400E+02/ + data absb(:, 781: 800) / & + & 4.818400E-06,1.886500E-05,1.116000E-04,8.686900E-04,3.140500E-03,& + & 1.061800E-02,3.544000E-02,1.610100E-01,2.077200E+00,1.332300E+01,& + & 3.138500E+01,8.571100E+01,2.867300E+02,4.023000E+03,3.062700E+04,& + & 1.860200E+05,8.156500E-06,4.167600E-05,2.479700E-04,1.336500E-03,& + & 4.689000E-03,1.501400E-02,5.114500E-02,2.591200E-01,2.650700E+00,& + & 1.250700E+01,2.475500E+01,6.446700E+01,2.151400E+02,3.017300E+03,& + & 2.297000E+04,1.395200E+05,8.780200E-06,4.840200E-05,2.671300E-04,& + & 1.215300E-03,4.083400E-03,1.280900E-02,4.483800E-02,2.457900E-01,& + & 2.632100E+00,1.287200E+01,2.297300E+01,4.672600E+01,1.437100E+02,& + & 2.011700E+03,1.531400E+04,9.301100E+04,8.523100E-06,4.910100E-05,& + & 2.442500E-04,9.508500E-04,2.967100E-03,8.828400E-03,3.250800E-02,& + & 1.899400E-01,2.172400E+00,1.109900E+01,1.997300E+01,3.594800E+01,& + & 7.934300E+01,1.006000E+03,7.657000E+03,4.650500E+04,6.155400E-06,& + & 2.991700E-05,8.956600E-05,2.124000E-04,4.821100E-04,1.225400E-03,& + & 4.111300E-03,3.001800E-02,5.638100E-01,3.542900E+00,7.164600E+00,& + & 1.460200E+01,2.802200E+01,4.942700E+01,8.330000E+01,1.486600E+02,& + & 6.738100E-06,3.008000E-05,1.860800E-04,1.260500E-03,4.544900E-03,& + & 1.533600E-02,5.185600E-02,2.403800E-01,3.124800E+00,2.005500E+01,& + & 4.653300E+01,1.271300E+02,4.384500E+02,5.605000E+03,3.827200E+04,& + & 2.234200E+05,1.104400E-05,5.847100E-05,3.521100E-04,1.813300E-03,& + & 6.495600E-03,2.110900E-02,7.321800E-02,3.614300E-01,3.526900E+00,& + & 1.645100E+01,3.538100E+01,9.549900E+01,3.289300E+02,4.203800E+03,& + & 2.870400E+04,1.675600E+05,1.156000E-05,6.446200E-05,3.575000E-04,& + & 1.596800E-03,5.462500E-03,1.758700E-02,6.374800E-02,3.406400E-01,& + & 3.436600E+00,1.590000E+01,2.823100E+01,6.528300E+01,2.194400E+02,& + & 2.802700E+03,1.913600E+04,1.117100E+05,1.081400E-05,6.228400E-05,& + & 3.097900E-04,1.201700E-03,3.801500E-03,1.170000E-02,4.518700E-02,& + & 2.616600E-01,2.779700E+00,1.338100E+01,2.351800E+01,4.229400E+01,& + & 1.129900E+02,1.401500E+03,9.568200E+03,5.585400E+04,7.081500E-06,& + & 3.283400E-05,9.637400E-05,2.222000E-04,4.998600E-04,1.256600E-03,& + & 4.298000E-03,3.627500E-02,6.769300E-01,3.921300E+00,7.553400E+00,& + & 1.467400E+01,2.743000E+01,4.607700E+01,7.774200E+01,1.379200E+02,& + & 9.491000E-06,4.694500E-05,2.946700E-04,1.763900E-03,6.400100E-03,& + & 2.155800E-02,7.406800E-02,3.530200E-01,4.561100E+00,2.953500E+01,& + & 6.757200E+01,1.823800E+02,6.508200E+02,7.495900E+03,4.636900E+04,& + & 2.612200E+05,1.478400E-05,8.118000E-05,4.908500E-04,2.408600E-03,& + & 8.850200E-03,2.915900E-02,1.022500E-01,4.939100E-01,4.598900E+00,& + & 2.283500E+01,5.081800E+01,1.369400E+02,4.882000E+02,5.622000E+03,& + & 3.477700E+04,1.959200E+05,1.505000E-05,8.502100E-05,4.712200E-04,& + & 2.063000E-03,7.232100E-03,2.386200E-02,8.905800E-02,4.607900E-01,& + & 4.403300E+00,1.953000E+01,3.658200E+01,9.178300E+01,3.256000E+02,& + & 3.748100E+03,2.318500E+04,1.306100E+05,1.355500E-05,7.827800E-05,& + & 3.872400E-04,1.501100E-03,4.842100E-03,1.540400E-02,6.249600E-02,& + & 3.517000E-01,3.494900E+00,1.597000E+01,2.736100E+01,5.224600E+01,& + & 1.637100E+02,1.874300E+03,1.159300E+04,6.530400E+04,7.953200E-06,& + & 3.559800E-05,1.022900E-04,2.313000E-04,5.155100E-04,1.284900E-03,& + & 4.468200E-03,4.385800E-02,7.973700E-01,4.248100E+00,7.918400E+00,& + & 1.452800E+01,2.672400E+01,4.327600E+01,7.178700E+01,1.282300E+02,& + & 1.324800E-05,7.116800E-05,4.433100E-04,2.389200E-03,8.697700E-03,& + & 2.960100E-02,1.037800E-01,5.091500E-01,6.504200E+00,4.244900E+01,& + & 9.611600E+01,2.546600E+02,9.373900E+02,9.687500E+03,5.474600E+04,& + & 2.987400E+05,1.950600E-05,1.112100E-04,6.690900E-04,3.132500E-03,& + & 1.177900E-02,3.957200E-02,1.396500E-01,6.644600E-01,5.971900E+00,& + & 3.209900E+01,7.219500E+01,1.911500E+02,7.031300E+02,7.265700E+03,& + & 4.106000E+04,2.240600E+05,1.934400E-05,1.109300E-04,6.103700E-04,& + & 2.617200E-03,9.406400E-03,3.209200E-02,1.218700E-01,6.119300E-01,& + & 5.531700E+00,2.432900E+01,4.936700E+01,1.276600E+02,4.688900E+02,& + & 4.843900E+03,2.737300E+04,1.493700E+05,1.681500E-05,9.723500E-05,& + & 4.775300E-04,1.845700E-03,6.106200E-03,2.018800E-02,8.521800E-02,& + & 4.631600E-01,4.325400E+00,1.892600E+01,3.181900E+01,6.729400E+01,& + & 2.347200E+02,2.422200E+03,1.368700E+04,7.468500E+04,8.772300E-06,& + & 3.814900E-05,1.075900E-04,2.390400E-04,5.291000E-04,1.308100E-03,& + & 4.631900E-03,5.291100E-02,9.193700E-01,4.557100E+00,8.210700E+00,& + & 1.457000E+01,2.540900E+01,4.064700E+01,6.674300E+01,1.193200E+02/ + data absb(:, 801: 820) / & + & 3.078100E-06,9.742600E-06,4.966100E-05,4.595600E-04,1.781400E-03,& + & 5.995900E-03,1.998700E-02,9.031600E-02,1.179400E+00,7.881800E+00,& + & 1.910300E+01,5.268500E+01,1.749000E+02,2.768000E+03,2.502000E+04,& + & 1.617100E+05,4.886400E-06,2.333300E-05,1.350600E-04,7.916100E-04,& + & 2.775900E-03,8.856400E-03,2.994800E-02,1.584600E-01,1.796900E+00,& + & 9.245400E+00,1.711600E+01,4.048600E+01,1.312800E+02,2.076100E+03,& + & 1.876500E+04,1.212800E+05,5.273000E-06,2.823000E-05,1.543800E-04,& + & 7.484000E-04,2.509200E-03,7.736300E-03,2.663800E-02,1.508100E-01,& + & 1.834300E+00,9.840300E+00,1.816300E+01,3.426400E+01,8.988900E+01,& + & 1.384200E+03,1.251000E+04,8.085400E+04,5.191000E-06,2.998800E-05,& + & 1.499300E-04,6.085900E-04,1.906800E-03,5.545300E-03,1.981500E-02,& + & 1.173600E-01,1.547600E+00,8.713000E+00,1.628300E+01,3.042700E+01,& + & 6.008700E+01,6.937100E+02,6.255400E+03,4.042700E+04,3.988500E-06,& + & 2.108600E-05,6.536900E-05,1.620300E-04,3.747500E-04,9.682500E-04,& + & 3.207600E-03,2.081500E-02,4.200700E-01,2.963800E+00,6.560500E+00,& + & 1.415100E+01,2.889200E+01,5.392700E+01,9.224900E+01,1.663500E+02,& + & 4.128100E-06,1.536100E-05,8.892700E-05,7.282200E-04,2.667800E-03,& + & 9.079800E-03,3.059500E-02,1.402200E-01,1.876200E+00,1.235500E+01,& + & 2.965800E+01,8.317900E+01,2.811500E+02,4.124700E+03,3.292100E+04,& + & 2.030400E+05,6.647000E-06,3.317300E-05,1.988300E-04,1.118700E-03,& + & 3.963500E-03,1.287800E-02,4.451400E-02,2.312800E-01,2.479500E+00,& + & 1.203500E+01,2.368200E+01,6.260500E+01,2.109600E+02,3.093600E+03,& + & 2.469100E+04,1.522800E+05,7.038200E-06,3.831700E-05,2.143200E-04,& + & 1.011700E-03,3.440700E-03,1.093600E-02,3.885900E-02,2.195200E-01,& + & 2.474200E+00,1.248200E+01,2.261800E+01,4.596500E+01,1.410100E+02,& + & 2.062500E+03,1.646100E+04,1.015200E+05,6.740100E-06,3.874800E-05,& + & 1.964200E-04,7.859200E-04,2.490600E-03,7.503900E-03,2.797800E-02,& + & 1.693500E-01,2.050100E+00,1.082200E+01,1.978900E+01,3.607200E+01,& + & 7.869700E+01,1.031400E+03,8.230500E+03,5.076000E+04,4.788800E-06,& + & 2.370000E-05,7.159300E-05,1.714200E-04,3.912000E-04,1.000300E-03,& + & 3.379800E-03,2.541900E-02,5.216300E-01,3.403800E+00,7.023900E+00,& + & 1.450700E+01,2.829700E+01,5.067200E+01,8.568700E+01,1.533600E+02,& + & 5.727200E-06,2.457300E-05,1.509700E-04,1.076700E-03,3.899900E-03,& + & 1.329000E-02,4.540300E-02,2.129000E-01,2.880900E+00,1.894800E+01,& + & 4.485300E+01,1.260100E+02,4.361200E+02,5.844800E+03,4.163000E+04,& + & 2.463000E+05,9.041900E-06,4.701100E-05,2.865700E-04,1.538900E-03,& + & 5.559500E-03,1.834600E-02,6.481100E-02,3.275600E-01,3.344200E+00,& + & 1.584200E+01,3.422700E+01,9.465200E+01,3.271800E+02,4.383700E+03,& + & 3.122200E+04,1.847300E+05,9.337300E-06,5.156100E-05,2.909500E-04,& + & 1.345800E-03,4.655800E-03,1.522700E-02,5.619400E-02,3.092300E-01,& + & 3.272100E+00,1.558700E+01,2.790900E+01,6.492300E+01,2.182800E+02,& + & 2.922600E+03,2.081500E+04,1.231500E+05,8.633100E-06,4.962200E-05,& + & 2.522600E-04,1.003800E-03,3.226700E-03,1.007400E-02,3.955700E-02,& + & 2.373600E-01,2.656600E+00,1.316200E+01,2.355500E+01,4.266900E+01,& + & 1.126600E+02,1.461500E+03,1.040800E+04,6.157600E+04,5.557500E-06,& + & 2.615800E-05,7.736900E-05,1.798600E-04,4.064000E-04,1.028400E-03,& + & 3.540600E-03,3.112900E-02,6.340900E-01,3.791900E+00,7.438300E+00,& + & 1.464300E+01,2.780600E+01,4.715000E+01,7.985400E+01,1.420400E+02,& + & 8.067500E-06,3.867400E-05,2.432400E-04,1.519500E-03,5.547500E-03,& + & 1.888400E-02,6.569600E-02,3.176700E-01,4.282500E+00,2.844300E+01,& + & 6.639000E+01,1.840100E+02,6.566800E+02,7.928400E+03,5.093400E+04,& + & 2.904100E+05,1.219500E-05,6.595800E-05,4.050500E-04,2.063400E-03,& + & 7.664600E-03,2.567800E-02,9.186600E-02,4.538600E-01,4.413100E+00,& + & 2.212200E+01,4.995400E+01,1.381600E+02,4.926000E+02,5.946300E+03,& + & 3.820000E+04,2.178100E+05,1.226900E-05,6.872400E-05,3.885500E-04,& + & 1.754400E-03,6.233100E-03,2.092700E-02,7.979700E-02,4.244300E-01,& + & 4.244300E+00,1.932200E+01,3.631400E+01,9.263400E+01,3.285400E+02,& + & 3.964400E+03,2.546700E+04,1.452000E+05,1.092400E-05,6.298900E-05,& + & 3.186600E-04,1.265100E-03,4.153600E-03,1.342700E-02,5.564500E-02,& + & 3.239900E-01,3.378800E+00,1.584600E+01,2.764000E+01,5.300500E+01,& + & 1.652600E+02,1.982400E+03,1.273400E+04,7.260200E+04,6.288800E-06,& + & 2.848800E-05,8.247300E-05,1.877300E-04,4.198800E-04,1.053500E-03,& + & 3.691200E-03,3.818700E-02,7.535400E-01,4.140500E+00,7.858000E+00,& + & 1.450300E+01,2.709700E+01,4.432900E+01,7.368800E+01,1.319300E+02/ + data absb(:, 821: 840) / & + & 1.130400E-05,5.926900E-05,3.718900E-04,2.079000E-03,7.614600E-03,& + & 2.618500E-02,9.319400E-02,4.651400E-01,6.207700E+00,4.155800E+01,& + & 9.623000E+01,2.605000E+02,9.587600E+02,1.036900E+04,6.062300E+04,& + & 3.343300E+05,1.623000E-05,9.139200E-05,5.603000E-04,2.710200E-03,& + & 1.031400E-02,3.527000E-02,1.271000E-01,6.184000E-01,5.783000E+00,& + & 3.147500E+01,7.228200E+01,1.955300E+02,7.191700E+02,7.776800E+03,& + & 4.546700E+04,2.507400E+05,1.591100E-05,9.063800E-05,5.102200E-04,& + & 2.247300E-03,8.196700E-03,2.848500E-02,1.107800E-01,5.708100E-01,& + & 5.393400E+00,2.416300E+01,4.957300E+01,1.305800E+02,4.795800E+02,& + & 5.184700E+03,3.031200E+04,1.671600E+05,1.367000E-05,7.904100E-05,& + & 3.974000E-04,1.570000E-03,5.291000E-03,1.781200E-02,7.709700E-02,& + & 4.323300E-01,4.224900E+00,1.894900E+01,3.234900E+01,6.890500E+01,& + & 2.400600E+02,2.592600E+03,1.515600E+04,8.358100E+04,6.980900E-06,& + & 3.064800E-05,8.703800E-05,1.945100E-04,4.318900E-04,1.074600E-03,& + & 3.838700E-03,4.678200E-02,8.765100E-01,4.465000E+00,8.150500E+00,& + & 1.461800E+01,2.577600E+01,4.163400E+01,6.845000E+01,1.227100E+02,& + & 2.703100E-06,8.081300E-06,3.862800E-05,3.729200E-04,1.491300E-03,& + & 5.029900E-03,1.688300E-02,7.697000E-02,1.032700E+00,7.108900E+00,& + & 1.760300E+01,4.955000E+01,1.672800E+02,2.764200E+03,2.646200E+04,& + & 1.743200E+05,4.005100E-06,1.839400E-05,1.058600E-04,6.491100E-04,& + & 2.304900E-03,7.435000E-03,2.545500E-02,1.378900E-01,1.645300E+00,& + & 8.773300E+00,1.640800E+01,3.836600E+01,1.255600E+02,2.073200E+03,& + & 1.984700E+04,1.307400E+05,4.205200E-06,2.204800E-05,1.211200E-04,& + & 6.120900E-04,2.078100E-03,6.474900E-03,2.254000E-02,1.311400E-01,& + & 1.690000E+00,9.394100E+00,1.760100E+01,3.360500E+01,8.659200E+01,& + & 1.382200E+03,1.323100E+04,8.716200E+04,4.051300E-06,2.330200E-05,& + & 1.181400E-04,4.954500E-04,1.575200E-03,4.627700E-03,1.667700E-02,& + & 1.016600E-01,1.430700E+00,8.354700E+00,1.587700E+01,3.015500E+01,& + & 5.956800E+01,6.934400E+02,6.615900E+03,4.358100E+04,3.039100E-06,& + & 1.649900E-05,5.179200E-05,1.300800E-04,3.030300E-04,7.877600E-04,& + & 2.623400E-03,1.726400E-02,3.800100E-01,2.805400E+00,6.354900E+00,& + & 1.396300E+01,2.908200E+01,5.529900E+01,9.517300E+01,1.722700E+02,& + & 3.562900E-06,1.253300E-05,7.030200E-05,6.067300E-04,2.261900E-03,& + & 7.740000E-03,2.629700E-02,1.217600E-01,1.684000E+00,1.140100E+01,& + & 2.789000E+01,8.033700E+01,2.745700E+02,4.212700E+03,3.538800E+04,& + & 2.218600E+05,5.429100E-06,2.630900E-05,1.584000E-04,9.328700E-04,& + & 3.339400E-03,1.099200E-02,3.853400E-02,2.053400E-01,2.307100E+00,& + & 1.156200E+01,2.264500E+01,6.053800E+01,2.060200E+02,3.159600E+03,& + & 2.654100E+04,1.664000E+05,5.638400E-06,3.017900E-05,1.708100E-04,& + & 8.397600E-04,2.889600E-03,9.291800E-03,3.348600E-02,1.948200E-01,& + & 2.315400E+00,1.206700E+01,2.221700E+01,4.515600E+01,1.378400E+02,& + & 2.106500E+03,1.769400E+04,1.109300E+05,5.310900E-06,3.040800E-05,& + & 1.570100E-04,6.480200E-04,2.083900E-03,6.353600E-03,2.395400E-02,& + & 1.499400E-01,1.925100E+00,1.052000E+01,1.954600E+01,3.614200E+01,& + & 7.796700E+01,1.053400E+03,8.847400E+03,5.546500E+04,3.695700E-06,& + & 1.869600E-05,5.703200E-05,1.381100E-04,3.170500E-04,8.160900E-04,& + & 2.772500E-03,2.134600E-02,4.789200E-01,3.253600E+00,6.853500E+00,& + & 1.440000E+01,2.854500E+01,5.198900E+01,8.825600E+01,1.584900E+02,& + & 4.891700E-06,2.004400E-05,1.216400E-04,9.163500E-04,3.342400E-03,& + & 1.148200E-02,3.963600E-02,1.879000E-01,2.644900E+00,1.783400E+01,& + & 4.309500E+01,1.245300E+02,4.331300E+02,6.081700E+03,4.534300E+04,& + & 2.722100E+05,7.405200E-06,3.766000E-05,2.320000E-04,1.303300E-03,& + & 4.745500E-03,1.588700E-02,5.712000E-02,2.956600E-01,3.162300E+00,& + & 1.524800E+01,3.303500E+01,9.354500E+01,3.249400E+02,4.561400E+03,& + & 3.400800E+04,2.041600E+05,7.531800E-06,4.105600E-05,2.355900E-04,& + & 1.132300E-03,3.959200E-03,1.313600E-02,4.927800E-02,2.794100E-01,& + & 3.105400E+00,1.524700E+01,2.759700E+01,6.442900E+01,2.167800E+02,& + & 3.041100E+03,2.267200E+04,1.361100E+05,6.868600E-06,3.935000E-05,& + & 2.045600E-04,8.371800E-04,2.732400E-03,8.649300E-03,3.445400E-02,& + & 2.141500E-01,2.529400E+00,1.292700E+01,2.355600E+01,4.302300E+01,& + & 1.122200E+02,1.520700E+03,1.133600E+04,6.805300E+04,4.336800E-06,& + & 2.076800E-05,6.193900E-05,1.454100E-04,3.299700E-04,8.411400E-04,& + & 2.913300E-03,2.649000E-02,5.896800E-01,3.652800E+00,7.298500E+00,& + & 1.459400E+01,2.813900E+01,4.836200E+01,8.214300E+01,1.464800E+02/ + data absb(:, 841: 860) / & + & 6.873500E-06,3.177000E-05,1.996300E-04,1.308300E-03,4.804100E-03,& + & 1.652100E-02,5.815800E-02,2.851100E-01,4.014900E+00,2.724900E+01,& + & 6.508000E+01,1.855000E+02,6.616300E+02,8.383500E+03,5.609400E+04,& + & 3.241100E+05,1.005600E-05,5.341000E-05,3.327100E-04,1.765900E-03,& + & 6.627100E-03,2.254700E-02,8.225900E-02,4.157400E-01,4.229900E+00,& + & 2.137500E+01,4.900100E+01,1.392700E+02,4.963200E+02,6.287700E+03,& + & 4.207100E+04,2.430800E+05,9.986300E-06,5.531900E-05,3.189100E-04,& + & 1.491600E-03,5.366700E-03,1.830600E-02,7.123000E-02,3.893600E-01,& + & 4.082800E+00,1.909300E+01,3.601100E+01,9.343800E+01,3.310300E+02,& + & 4.192000E+03,2.804700E+04,1.620500E+05,8.779500E-06,5.047800E-05,& + & 2.614600E-04,1.065900E-03,3.557900E-03,1.168000E-02,4.935100E-02,& + & 2.970700E-01,3.257700E+00,1.570500E+01,2.791100E+01,5.378400E+01,& + & 1.665800E+02,2.096200E+03,1.402400E+04,8.102600E+04,4.948600E-06,& + & 2.272800E-05,6.632700E-05,1.521400E-04,3.417400E-04,8.634300E-04,& + & 3.048300E-03,3.300700E-02,7.080500E-01,4.019200E+00,7.766800E+00,& + & 1.449800E+01,2.744900E+01,4.545100E+01,7.572800E+01,1.359300E+02,& + & 9.660100E-06,4.921500E-05,3.107600E-04,1.809900E-03,6.670000E-03,& + & 2.316000E-02,8.356100E-02,4.241800E-01,5.921100E+00,4.065100E+01,& + & 9.611100E+01,2.666600E+02,9.800400E+02,1.110900E+04,6.738900E+04,& + & 3.761000E+05,1.349300E-05,7.489800E-05,4.674900E-04,2.345800E-03,& + & 9.030600E-03,3.136500E-02,1.154300E-01,5.742700E-01,5.598400E+00,& + & 3.086600E+01,7.219400E+01,2.001500E+02,7.351200E+02,8.331500E+03,& + & 5.054200E+04,2.820800E+05,1.307300E-05,7.380000E-05,4.249200E-04,& + & 1.930900E-03,7.146800E-03,2.523200E-02,1.004200E-01,5.309500E-01,& + & 5.252800E+00,2.401500E+01,4.970200E+01,1.336600E+02,4.902100E+02,& + & 5.554500E+03,3.369500E+04,1.880500E+05,1.109000E-05,6.401900E-05,& + & 3.299700E-04,1.336500E-03,4.584700E-03,1.569400E-02,6.954500E-02,& + & 4.021900E-01,4.122300E+00,1.894300E+01,3.289500E+01,7.057900E+01,& + & 2.453900E+02,2.777500E+03,1.684800E+04,9.402500E+04,5.532800E-06,& + & 2.455200E-05,7.024800E-05,1.581000E-04,3.522000E-04,8.822200E-04,& + & 3.179400E-03,4.108000E-02,8.311000E-01,4.357400E+00,8.088700E+00,& + & 1.467600E+01,2.612200E+01,4.271000E+01,7.019600E+01,1.263400E+02,& + & 2.351300E-06,6.619200E-06,2.888600E-05,2.895000E-04,1.208900E-03,& + & 4.073500E-03,1.375000E-02,6.321000E-02,8.679100E-01,6.164900E+00,& + & 1.558200E+01,4.476100E+01,1.543100E+02,2.657900E+03,2.715600E+04,& + & 1.828900E+05,3.245900E-06,1.423800E-05,8.065600E-05,5.167700E-04,& + & 1.859500E-03,6.048100E-03,2.093100E-02,1.162200E-01,1.465000E+00,& + & 8.140300E+00,1.541600E+01,3.514400E+01,1.158500E+02,1.993500E+03,& + & 2.036700E+04,1.371700E+05,3.310900E-06,1.690700E-05,9.276000E-05,& + & 4.880200E-04,1.677400E-03,5.266400E-03,1.848900E-02,1.104300E-01,& + & 1.517500E+00,8.779800E+00,1.671200E+01,3.238500E+01,8.093100E+01,& + & 1.329100E+03,1.357800E+04,9.144700E+04,3.112600E-06,1.780600E-05,& + & 9.112100E-05,3.950200E-04,1.273300E-03,3.767000E-03,1.365200E-02,& + & 8.538000E-02,1.290900E+00,7.856200E+00,1.520200E+01,2.940800E+01,& + & 5.823200E+01,6.681000E+02,6.789400E+03,4.572300E+04,2.280900E-06,& + & 1.277800E-05,4.076600E-05,1.039800E-04,2.443500E-04,6.396600E-04,& + & 2.136900E-03,1.411900E-02,3.382900E-01,2.625300E+00,6.105800E+00,& + & 1.371400E+01,2.926200E+01,5.680500E+01,9.856400E+01,1.790900E+02,& + & 3.028500E-06,9.978800E-06,5.334200E-05,4.867000E-04,1.858900E-03,& + & 6.381900E-03,2.183800E-02,1.021500E-01,1.454800E+00,1.013800E+01,& + & 2.537100E+01,7.483600E+01,2.588500E+02,4.161800E+03,3.702800E+04,& + & 2.367900E+05,4.363200E-06,2.041900E-05,1.226300E-04,7.566000E-04,& + & 2.735900E-03,9.104800E-03,3.230500E-02,1.770500E-01,2.091900E+00,& + & 1.087400E+01,2.114400E+01,5.656900E+01,1.942300E+02,3.121400E+03,& + & 2.777100E+04,1.775900E+05,4.443500E-06,2.330100E-05,1.327600E-04,& + & 6.804900E-04,2.366900E-03,7.680400E-03,2.798900E-02,1.680800E-01,& + & 2.115500E+00,1.143700E+01,2.143800E+01,4.333700E+01,1.302600E+02,& + & 2.081100E+03,1.851400E+04,1.183900E+05,4.116900E-06,2.345600E-05,& + & 1.228300E-04,5.237800E-04,1.706400E-03,5.248500E-03,1.995700E-02,& + & 1.290800E-01,1.768400E+00,1.005500E+01,1.898400E+01,3.567100E+01,& + & 7.564300E+01,1.040700E+03,9.257400E+03,5.919800E+04,2.816000E-06,& + & 1.463000E-05,4.514400E-05,1.108500E-04,2.562200E-04,6.645900E-04,& + & 2.267800E-03,1.766200E-02,4.337400E-01,3.076800E+00,6.652900E+00,& + & 1.424100E+01,2.879800E+01,5.344700E+01,9.121000E+01,1.643600E+02/ + data absb(:, 861: 880) / & + & 4.096300E-06,1.586400E-05,9.430100E-05,7.552500E-04,2.780500E-03,& + & 9.618000E-03,3.349700E-02,1.605300E-01,2.343700E+00,1.622000E+01,& + & 4.005800E+01,1.190400E+02,4.168200E+02,6.140200E+03,4.822500E+04,& + & 2.944700E+05,5.951900E-06,2.943900E-05,1.826600E-04,1.076200E-03,& + & 3.941700E-03,1.337600E-02,4.883500E-02,2.596800E-01,2.917100E+00,& + & 1.438900E+01,3.095700E+01,8.942700E+01,3.127100E+02,4.605300E+03,& + & 3.616900E+04,2.208500E+05,5.967500E-06,3.201100E-05,1.861700E-04,& + & 9.312300E-04,3.286700E-03,1.103000E-02,4.198500E-02,2.457900E-01,& + & 2.882000E+00,1.463100E+01,2.683400E+01,6.212400E+01,2.086200E+02,& + & 3.070300E+03,2.411300E+04,1.472400E+05,5.377400E-06,3.065900E-05,& + & 1.625800E-04,6.849600E-04,2.264900E-03,7.248100E-03,2.921400E-02,& + & 1.882800E-01,2.359200E+00,1.250200E+01,2.318900E+01,4.272000E+01,& + & 1.087700E+02,1.535400E+03,1.205700E+04,7.361800E+04,3.349400E-06,& + & 1.637500E-05,4.929800E-05,1.171500E-04,2.673100E-04,6.864600E-04,& + & 2.389900E-03,2.222200E-02,5.414600E-01,3.492700E+00,7.134500E+00,& + & 1.451300E+01,2.844600E+01,4.976100E+01,8.475300E+01,1.515900E+02,& + & 5.720000E-06,2.529800E-05,1.580000E-04,1.096900E-03,4.046800E-03,& + & 1.403800E-02,4.992900E-02,2.477400E-01,3.641000E+00,2.529200E+01,& + & 6.180700E+01,1.813500E+02,6.468400E+02,8.626200E+03,6.045300E+04,& + & 3.545400E+05,8.125000E-06,4.220900E-05,2.661600E-04,1.477700E-03,& + & 5.581000E-03,1.926600E-02,7.162400E-02,3.711100E-01,3.965800E+00,& + & 2.008300E+01,4.661500E+01,1.361500E+02,4.852300E+02,6.469700E+03,& + & 4.534000E+04,2.659000E+05,7.978900E-06,4.361700E-05,2.557900E-04,& + & 1.242600E-03,4.508600E-03,1.560000E-02,6.183600E-02,3.485100E-01,& + & 3.845500E+00,1.850600E+01,3.493300E+01,9.152900E+01,3.236300E+02,& + & 4.313300E+03,3.022700E+04,1.772700E+05,6.942500E-06,3.975500E-05,& + & 2.106100E-04,8.822300E-04,2.982300E-03,9.920900E-03,4.260500E-02,& + & 2.660400E-01,3.080700E+00,1.533400E+01,2.775800E+01,5.351800E+01,& + & 1.630800E+02,2.156900E+03,1.511400E+04,8.863500E+04,3.861100E-06,& + & 1.802700E-05,5.306800E-05,1.229500E-04,2.774000E-04,7.063200E-04,& + & 2.509400E-03,2.812600E-02,6.580800E-01,3.871300E+00,7.639700E+00,& + & 1.449100E+01,2.781400E+01,4.669500E+01,7.816800E+01,1.404500E+02,& + & 8.054800E-06,3.960200E-05,2.510900E-04,1.535400E-03,5.689000E-03,& + & 1.992300E-02,7.275700E-02,3.752500E-01,5.475700E+00,3.857900E+01,& + & 9.312700E+01,2.655700E+02,9.727900E+02,1.160900E+04,7.344100E+04,& + & 4.154800E+05,1.099000E-05,5.988700E-05,3.798100E-04,1.985200E-03,& + & 7.711600E-03,2.716800E-02,1.021700E-01,5.202200E-01,5.298200E+00,& + & 2.941900E+01,6.996200E+01,1.993300E+02,7.296800E+02,8.707100E+03,& + & 5.508100E+04,3.116100E+05,1.054500E-05,5.884000E-05,3.458200E-04,& + & 1.625600E-03,6.086200E-03,2.178600E-02,8.873800E-02,4.824100E-01,& + & 5.016800E+00,2.343100E+01,4.849900E+01,1.331100E+02,4.865900E+02,& + & 5.804900E+03,3.672100E+04,2.077400E+05,8.857000E-06,5.096200E-05,& + & 2.688700E-04,1.117800E-03,3.891400E-03,1.350000E-02,6.118000E-02,& + & 3.658200E-01,3.948800E+00,1.865900E+01,3.295200E+01,7.067100E+01,& + & 2.435900E+02,2.902700E+03,1.836100E+04,1.038700E+05,4.352200E-06,& + & 1.957000E-05,5.645800E-05,1.280500E-04,2.866300E-04,7.229400E-04,& + & 2.624700E-03,3.558900E-02,7.804200E-01,4.229500E+00,7.985100E+00,& + & 1.470800E+01,2.654800E+01,4.402600E+01,7.196400E+01,1.304600E+02,& + & 2.127700E-06,5.678600E-06,2.222700E-05,2.273200E-04,1.001000E-03,& + & 3.365400E-03,1.141400E-02,5.285600E-02,7.419700E-01,5.421600E+00,& + & 1.403400E+01,4.106900E+01,1.453800E+02,2.598300E+03,2.840800E+04,& + & 1.957900E+05,2.711500E-06,1.125400E-05,6.202300E-05,4.162800E-04,& + & 1.521900E-03,4.991100E-03,1.743700E-02,9.894100E-02,1.317500E+00,& + & 7.628400E+00,1.468100E+01,3.280100E+01,1.091500E+02,1.948800E+03,& + & 2.130600E+04,1.468400E+05,2.662700E-06,1.311200E-05,7.145800E-05,& + & 3.931600E-04,1.370500E-03,4.339300E-03,1.533400E-02,9.370000E-02,& + & 1.372700E+00,8.278100E+00,1.598900E+01,3.158600E+01,7.728900E+01,& + & 1.299300E+03,1.420400E+04,9.789600E+04,2.416500E-06,1.366400E-05,& + & 7.046200E-05,3.173700E-04,1.039900E-03,3.100100E-03,1.127200E-02,& + & 7.213800E-02,1.171000E+00,7.428200E+00,1.462900E+01,2.886500E+01,& + & 5.766200E+01,6.545100E+02,7.102400E+03,4.894800E+04,1.702100E-06,& + & 9.855900E-06,3.199600E-05,8.296900E-05,1.969000E-04,5.189400E-04,& + & 1.738600E-03,1.148100E-02,2.991200E-01,2.444800E+00,5.842100E+00,& + & 1.345700E+01,2.935100E+01,5.831600E+01,1.021000E+02,1.862300E+02/ + data absb(:, 881: 900) / & + & 2.670300E-06,8.241500E-06,4.134600E-05,3.969600E-04,1.562300E-03,& + & 5.373800E-03,1.849500E-02,8.738000E-02,1.279500E+00,9.167400E+00,& + & 2.355800E+01,7.097500E+01,2.493100E+02,4.189000E+03,3.956100E+04,& + & 2.582400E+05,3.598200E-06,1.610900E-05,9.590800E-05,6.225100E-04,& + & 2.278100E-03,7.658300E-03,2.745800E-02,1.543900E-01,1.917500E+00,& + & 1.035300E+01,2.018600E+01,5.381900E+01,1.870800E+02,3.141800E+03,& + & 2.967100E+04,1.936800E+05,3.564100E-06,1.817600E-05,1.039100E-04,& + & 5.585200E-04,1.966100E-03,6.441300E-03,2.369400E-02,1.463100E-01,& + & 1.950400E+00,1.095500E+01,2.089000E+01,4.230200E+01,1.257700E+02,& + & 2.094700E+03,1.978100E+04,1.291200E+05,3.221800E-06,1.817200E-05,& + & 9.641500E-05,4.277700E-04,1.413900E-03,4.389600E-03,1.679800E-02,& + & 1.119200E-01,1.635900E+00,9.679400E+00,1.856400E+01,3.547800E+01,& + & 7.469100E+01,1.047600E+03,9.890700E+03,6.455900E+04,2.134700E-06,& + & 1.140600E-05,3.566000E-05,8.890800E-05,2.069000E-04,5.405500E-04,& + & 1.852600E-03,1.453200E-02,3.908800E-01,2.894100E+00,6.441200E+00,& + & 1.405600E+01,2.899800E+01,5.490600E+01,9.428200E+01,1.705500E+02,& + & 3.547600E-06,1.292000E-05,7.457400E-05,6.346200E-04,2.366300E-03,& + & 8.234800E-03,2.889600E-02,1.400800E-01,2.116300E+00,1.504300E+01,& + & 3.800400E+01,1.161400E+02,4.101400E+02,6.328000E+03,5.243300E+04,& + & 3.260800E+05,4.890400E-06,2.335900E-05,1.455700E-04,9.030500E-04,& + & 3.332800E-03,1.145200E-02,4.235500E-02,2.311100E-01,2.724300E+00,& + & 1.383900E+01,2.960900E+01,8.725400E+01,3.077000E+02,4.746100E+03,& + & 3.932500E+04,2.445600E+05,4.803000E-06,2.520900E-05,1.483000E-04,& + & 7.772900E-04,2.772400E-03,9.409000E-03,3.625300E-02,2.186200E-01,& + & 2.702600E+00,1.420300E+01,2.647200E+01,6.107800E+01,2.052800E+02,& + & 3.164200E+03,2.621700E+04,1.630400E+05,4.248200E-06,2.402000E-05,& + & 1.299000E-04,5.673200E-04,1.902700E-03,6.159400E-03,2.506100E-02,& + & 1.670100E-01,2.219100E+00,1.219700E+01,2.301000E+01,4.290800E+01,& + & 1.076600E+02,1.582300E+03,1.310900E+04,8.031500E+04,2.574600E-06,& + & 1.288200E-05,3.915800E-05,9.430800E-05,2.164300E-04,5.598200E-04,& + & 1.959200E-03,1.853800E-02,4.953500E-01,3.324500E+00,6.960500E+00,& + & 1.439900E+01,2.872600E+01,5.115300E+01,8.745400E+01,1.569600E+02,& + & 4.904500E-06,2.066800E-05,1.276800E-04,9.420400E-04,3.489500E-03,& + & 1.219400E-02,4.378000E-02,2.200000E-01,3.368500E+00,2.397400E+01,& + & 5.994900E+01,1.811300E+02,6.475600E+02,9.066600E+03,6.668500E+04,& + & 3.973400E+05,6.695200E-06,3.387100E-05,2.160500E-04,1.262200E-03,& + & 4.787600E-03,1.675100E-02,6.332000E-02,3.360000E-01,3.769200E+00,& + & 1.928800E+01,4.529600E+01,1.359900E+02,4.857700E+02,6.800100E+03,& + & 5.001400E+04,2.980100E+05,6.468700E-06,3.476200E-05,2.075300E-04,& + & 1.053900E-03,3.854300E-03,1.351800E-02,5.443900E-02,3.157300E-01,& + & 3.664800E+00,1.816700E+01,3.451800E+01,9.156000E+01,3.239900E+02,& + & 4.533500E+03,3.334300E+04,1.986700E+05,5.541200E-06,3.151400E-05,& + & 1.711000E-04,7.409300E-04,2.538800E-03,8.558500E-03,3.725500E-02,& + & 2.406500E-01,2.941500E+00,1.512500E+01,2.788500E+01,5.409900E+01,& + & 1.633800E+02,2.267000E+03,1.667200E+04,9.933600E+04,3.004400E-06,& + & 1.426800E-05,4.239100E-05,9.923600E-05,2.251300E-04,5.775900E-04,& + & 2.062800E-03,2.382900E-02,6.099100E-01,3.716500E+00,7.500000E+00,& + & 1.448200E+01,2.811500E+01,4.796100E+01,8.064800E+01,1.451200E+02,& + & 6.903200E-06,3.262900E-05,2.072700E-04,1.333100E-03,4.971600E-03,& + & 1.753500E-02,6.473600E-02,3.393900E-01,5.178400E+00,3.730500E+01,& + & 9.227700E+01,2.707800E+02,9.883100E+02,1.241300E+04,8.196900E+04,& + & 4.703900E+05,9.123300E-06,4.866600E-05,3.133600E-04,1.714300E-03,& + & 6.716000E-03,2.396900E-02,9.188900E-02,4.786000E-01,5.104300E+00,& + & 2.855400E+01,6.932200E+01,2.032300E+02,7.413300E+02,9.309600E+03,& + & 6.147700E+04,3.527900E+05,8.634500E-06,4.749500E-05,2.849800E-04,& + & 1.393800E-03,5.279700E-03,1.915300E-02,7.960900E-02,4.440300E-01,& + & 4.855300E+00,2.321700E+01,4.828800E+01,1.357000E+02,4.943600E+02,& + & 6.206600E+03,4.098500E+04,2.351900E+05,7.146800E-06,4.090600E-05,& + & 2.214500E-04,9.493500E-04,3.357800E-03,1.180900E-02,5.456300E-02,& + & 3.364100E-01,3.822700E+00,1.859400E+01,3.340200E+01,7.222200E+01,& + & 2.474800E+02,3.103500E+03,2.049300E+04,1.176000E+05,3.416200E-06,& + & 1.557800E-05,4.530500E-05,1.036800E-04,2.332000E-04,5.922300E-04,& + & 2.164400E-03,3.067900E-02,7.313100E-01,4.093200E+00,7.887400E+00,& + & 1.470400E+01,2.694400E+01,4.534800E+01,7.377300E+01,1.346700E+02/ + data absb(:, 901: 920) / & + & 2.032800E-06,5.174800E-06,1.795800E-05,1.830000E-04,8.576500E-04,& + & 2.871400E-03,9.779200E-03,4.559400E-02,6.522900E-01,4.893900E+00,& + & 1.302000E+01,3.873100E+01,1.412000E+02,2.614600E+03,3.066500E+04,& + & 2.165000E+05,2.371800E-06,9.202100E-06,4.853500E-05,3.421700E-04,& + & 1.276500E-03,4.219200E-03,1.486200E-02,8.578700E-02,1.205100E+00,& + & 7.254800E+00,1.422300E+01,3.148600E+01,1.060400E+02,1.961000E+03,& + & 2.299900E+04,1.623800E+05,2.219900E-06,1.037900E-05,5.572300E-05,& + & 3.226400E-04,1.143400E-03,3.653300E-03,1.297500E-02,8.073300E-02,& + & 1.259100E+00,7.908000E+00,1.550800E+01,3.126500E+01,7.594100E+01,& + & 1.307400E+03,1.533300E+04,1.082500E+05,1.915700E-06,1.058500E-05,& + & 5.485100E-05,2.587700E-04,8.636200E-04,2.600300E-03,9.460800E-03,& + & 6.166800E-02,1.073800E+00,7.090600E+00,1.422200E+01,2.862800E+01,& + & 5.806500E+01,6.595200E+02,7.666500E+03,5.412500E+04,1.261000E-06,& + & 7.566500E-06,2.505500E-05,6.611800E-05,1.585700E-04,4.206600E-04,& + & 1.412100E-03,9.283200E-03,2.626900E-01,2.266000E+00,5.562900E+00,& + & 1.315900E+01,2.938000E+01,5.982300E+01,1.057900E+02,1.938100E+02,& + & 2.476700E-06,7.186700E-06,3.322400E-05,3.331200E-04,1.360200E-03,& + & 4.679600E-03,1.617500E-02,7.723600E-02,1.159100E+00,8.541500E+00,& + & 2.253100E+01,6.939700E+01,2.486200E+02,4.347900E+03,4.370100E+04,& + & 2.914900E+05,3.088700E-06,1.306200E-05,7.639600E-05,5.248300E-04,& + & 1.948800E-03,6.609600E-03,2.389800E-02,1.375500E-01,1.790800E+00,& + & 1.003900E+01,1.976500E+01,5.275900E+01,1.865700E+02,3.261000E+03,& + & 3.277600E+04,2.186100E+05,2.945900E-06,1.442700E-05,8.245000E-05,& + & 4.682900E-04,1.672300E-03,5.533200E-03,2.048800E-02,1.296400E-01,& + & 1.826900E+00,1.066200E+01,2.067400E+01,4.222300E+01,1.256400E+02,& + & 2.174100E+03,2.185100E+04,1.457400E+05,2.564600E-06,1.421500E-05,& + & 7.632300E-05,3.555200E-04,1.195600E-03,3.748200E-03,1.440600E-02,& + & 9.850000E-02,1.532900E+00,9.430800E+00,1.836000E+01,3.575900E+01,& + & 7.551900E+01,1.087400E+03,1.092600E+04,7.287100E+04,1.609100E-06,& + & 8.862700E-06,2.811400E-05,7.119400E-05,1.671200E-04,4.394800E-04,& + & 1.511700E-03,1.188500E-02,3.503200E-01,2.716600E+00,6.203300E+00,& + & 1.384100E+01,2.923300E+01,5.622900E+01,9.751200E+01,1.770400E+02,& + & 3.224500E-06,1.100100E-05,6.093400E-05,5.497300E-04,2.087300E-03,& + & 7.300200E-03,2.576300E-02,1.264600E-01,1.971900E+00,1.436600E+01,& + & 3.732600E+01,1.170900E+02,4.175800E+02,6.740100E+03,5.901300E+04,& + & 3.740200E+05,4.159400E-06,1.901200E-05,1.183700E-04,7.783900E-04,& + & 2.899600E-03,1.008000E-02,3.762000E-02,2.103300E-01,2.595900E+00,& + & 1.361800E+01,2.925500E+01,8.796600E+01,3.132800E+02,5.055200E+03,& + & 4.426000E+04,2.805200E+05,3.968700E-06,2.020600E-05,1.199900E-04,& + & 6.647300E-04,2.400000E-03,8.234700E-03,3.199500E-02,1.983100E-01,& + & 2.578400E+00,1.404100E+01,2.662200E+01,6.185100E+01,2.090000E+02,& + & 3.370200E+03,2.950600E+04,1.870100E+05,3.410900E-06,1.901700E-05,& + & 1.048300E-04,4.794000E-04,1.635000E-03,5.359600E-03,2.193600E-02,& + & 1.505900E-01,2.117700E+00,1.207400E+01,2.313300E+01,4.383600E+01,& + & 1.098600E+02,1.685300E+03,1.475300E+04,9.350500E+04,1.968800E-06,& + & 1.011200E-05,3.105200E-05,7.581300E-05,1.751500E-04,4.565200E-04,& + & 1.603900E-03,1.536700E-02,4.512700E-01,3.153900E+00,6.769600E+00,& + & 1.425400E+01,2.898900E+01,5.252200E+01,9.027300E+01,1.625800E+02,& + & 4.395000E-06,1.755700E-05,1.066000E-04,8.366300E-04,3.119500E-03,& + & 1.097100E-02,3.971400E-02,2.022300E-01,3.217600E+00,2.351900E+01,& + & 6.014100E+01,1.871400E+02,6.720300E+02,9.860200E+03,7.623500E+04,& + & 4.619200E+05,5.696400E-06,2.786500E-05,1.794300E-04,1.110500E-03,& + & 4.230900E-03,1.498100E-02,5.741100E-02,3.115000E-01,3.661700E+00,& + & 1.909700E+01,4.550700E+01,1.404900E+02,5.041200E+02,7.395300E+03,& + & 5.717700E+04,3.464400E+05,5.376600E-06,2.822400E-05,1.713300E-04,& + & 9.180000E-04,3.388000E-03,1.204600E-02,4.904100E-02,2.919400E-01,& + & 3.559200E+00,1.819400E+01,3.500900E+01,9.462300E+01,3.362200E+02,& + & 4.930300E+03,3.811800E+04,2.309600E+05,4.496300E-06,2.529800E-05,& + & 1.408300E-04,6.365800E-04,2.214600E-03,7.573900E-03,3.329900E-02,& + & 2.214600E-01,2.853800E+00,1.516100E+01,2.843800E+01,5.597300E+01,& + & 1.695000E+02,2.465300E+03,1.905900E+04,1.154800E+05,2.327000E-06,& + & 1.127900E-05,3.380600E-05,8.010000E-05,1.826900E-04,4.723400E-04,& + & 1.694600E-03,2.007600E-02,5.630900E-01,3.562500E+00,7.348400E+00,& + & 1.447200E+01,2.833300E+01,4.932600E+01,8.301200E+01,1.499900E+02/ + data absb(:, 921: 940) / & + & 6.162800E-06,2.789900E-05,1.768300E-04,1.200400E-03,4.504200E-03,& + & 1.599500E-02,5.963800E-02,3.177300E-01,5.066000E+00,3.735400E+01,& + & 9.466900E+01,2.858100E+02,1.041500E+03,1.374500E+04,9.492800E+04,& + & 5.528900E+05,7.808800E-06,4.058200E-05,2.655500E-04,1.528100E-03,& + & 6.031700E-03,2.176700E-02,8.479300E-02,4.511600E-01,5.044400E+00,& + & 2.863700E+01,7.112500E+01,2.145000E+02,7.812400E+02,1.030900E+04,& + & 7.119600E+04,4.146700E+05,7.246700E-06,3.913000E-05,2.400400E-04,& + & 1.230700E-03,4.714300E-03,1.733000E-02,7.308000E-02,4.175700E-01,& + & 4.796400E+00,2.354000E+01,4.961300E+01,1.432100E+02,5.209600E+02,& + & 6.872700E+03,4.746400E+04,2.764400E+05,5.870400E-06,3.330600E-05,& + & 1.856200E-04,8.265300E-04,2.974200E-03,1.061400E-02,4.974900E-02,& + & 3.152700E-01,3.766900E+00,1.886200E+01,3.445100E+01,7.601300E+01,& + & 2.607700E+02,3.436600E+03,2.373200E+04,1.382200E+05,2.672200E-06,& + & 1.238900E-05,3.633300E-05,8.393500E-05,1.897100E-04,4.856800E-04,& + & 1.785200E-03,2.630200E-02,6.829800E-01,3.965500E+00,7.767600E+00,& + & 1.471300E+01,2.725600E+01,4.670200E+01,7.564300E+01,1.390100E+02,& + & 1.880000E-06,4.602000E-06,1.422100E-05,1.403900E-04,7.032700E-04,& + & 2.343400E-03,8.013100E-03,3.755200E-02,5.471800E-01,4.208900E+00,& + & 1.152800E+01,3.484500E+01,1.311500E+02,2.509900E+03,3.151200E+04,& + & 2.279100E+05,2.046800E-06,7.463800E-06,3.728900E-05,2.715100E-04,& + & 1.035700E-03,3.441000E-03,1.221600E-02,7.189500E-02,1.070000E+00,& + & 6.705000E+00,1.338500E+01,2.922200E+01,9.860500E+01,1.882500E+03,& + & 2.363400E+04,1.709300E+05,1.838400E-06,8.164500E-06,4.277200E-05,& + & 2.571300E-04,9.261700E-04,2.978600E-03,1.063100E-02,6.742400E-02,& + & 1.124200E+00,7.378700E+00,1.467600E+01,3.021900E+01,7.217200E+01,& + & 1.255100E+03,1.575600E+04,1.139500E+05,1.514200E-06,8.155900E-06,& + & 4.211200E-05,2.062800E-04,6.991300E-04,2.120500E-03,7.724100E-03,& + & 5.130200E-02,9.626900E-01,6.633400E+00,1.355300E+01,2.784100E+01,& + & 5.750300E+01,6.347600E+02,7.878300E+03,5.697700E+04,9.312300E-07,& + & 5.798000E-06,1.962200E-05,5.264800E-05,1.276800E-04,3.406900E-04,& + & 1.146700E-03,7.500900E-03,2.304100E-01,2.095100E+00,5.288600E+00,& + & 1.284800E+01,2.936300E+01,6.123000E+01,1.094400E+02,2.013400E+02,& + & 2.226100E-06,6.119100E-06,2.577000E-05,2.661000E-04,1.134100E-03,& + & 3.897100E-03,1.352200E-02,6.520700E-02,1.002900E+00,7.578100E+00,& + & 2.059000E+01,6.478000E+01,2.379000E+02,4.305400E+03,4.598900E+04,& + & 3.132500E+05,2.606800E-06,1.043600E-05,5.930300E-05,4.268900E-04,& + & 1.608800E-03,5.499200E-03,2.006900E-02,1.184000E-01,1.623000E+00,& + & 9.447700E+00,1.877900E+01,4.951700E+01,1.785400E+02,3.229100E+03,& + & 3.449200E+04,2.349400E+05,2.406200E-06,1.132000E-05,6.407400E-05,& + & 3.809100E-04,1.377300E-03,4.594000E-03,1.714100E-02,1.113900E-01,& + & 1.666000E+00,1.013200E+01,1.995400E+01,4.090900E+01,1.207000E+02,& + & 2.152800E+03,2.299500E+04,1.566200E+05,2.025000E-06,1.102000E-05,& + & 5.941100E-05,2.883100E-04,9.836200E-04,3.103600E-03,1.200800E-02,& + & 8.433500E-02,1.404800E+00,8.997700E+00,1.778500E+01,3.530600E+01,& + & 7.440700E+01,1.077200E+03,1.149800E+04,7.831200E+04,1.210000E-06,& + & 6.881400E-06,2.215500E-05,5.696100E-05,1.348800E-04,3.571400E-04,& + & 1.232700E-03,9.720500E-03,3.135000E-01,2.546700E+00,5.968300E+00,& + & 1.360500E+01,2.936400E+01,5.758400E+01,1.006900E+02,1.834500E+02,& + & 2.832300E-06,9.082000E-06,4.776000E-05,4.542700E-04,1.763300E-03,& + & 6.190000E-03,2.196100E-02,1.090800E-01,1.755700E+00,1.309800E+01,& + & 3.511200E+01,1.128000E+02,4.074400E+02,6.850300E+03,6.328800E+04,& + & 4.087800E+05,3.465900E-06,1.514900E-05,9.356000E-05,6.462400E-04,& + & 2.433400E-03,8.546000E-03,3.223900E-02,1.852900E-01,2.397700E+00,& + & 1.300200E+01,2.787800E+01,8.475900E+01,3.056800E+02,5.137800E+03,& + & 4.746600E+04,3.065900E+05,3.226400E-06,1.592600E-05,9.485100E-05,& + & 5.502500E-04,2.008700E-03,6.955300E-03,2.731400E-02,1.746400E-01,& + & 2.395200E+00,1.352100E+01,2.612800E+01,6.028600E+01,2.039400E+02,& + & 3.425300E+03,3.164400E+04,2.043900E+05,2.707100E-06,1.487000E-05,& + & 8.293300E-05,3.947900E-04,1.364700E-03,4.515200E-03,1.864000E-02,& + & 1.323000E-01,1.975400E+00,1.170800E+01,2.275000E+01,4.380500E+01,& + & 1.080400E+02,1.712800E+03,1.582200E+04,1.022000E+05,1.503500E-06,& + & 7.927400E-06,2.461900E-05,6.090700E-05,1.417400E-04,3.721200E-04,& + & 1.312400E-03,1.274100E-02,4.105200E-01,2.988800E+00,6.581200E+00,& + & 1.411400E+01,2.914900E+01,5.387600E+01,9.305000E+01,1.681100E+02/ + data absb(:, 941: 960) / & + & 3.799900E-06,1.436700E-05,8.523900E-05,7.095000E-04,2.668600E-03,& + & 9.445100E-03,3.444000E-02,1.779500E-01,2.939800E+00,2.202100E+01,& + & 5.782100E+01,1.849100E+02,6.687200E+02,1.023500E+04,8.306100E+04,& + & 5.115200E+05,4.724900E-06,2.233100E-05,1.444000E-04,9.407000E-04,& + & 3.601100E-03,1.290900E-02,5.020900E-02,2.796900E-01,3.446700E+00,& + & 1.824600E+01,4.387100E+01,1.388200E+02,5.016300E+02,7.676000E+03,& + & 6.229600E+04,3.836400E+05,4.378800E-06,2.244800E-05,1.376900E-04,& + & 7.736100E-04,2.876000E-03,1.034900E-02,4.273700E-02,2.622400E-01,& + & 3.360800E+00,1.775500E+01,3.442800E+01,9.372300E+01,3.345600E+02,& + & 5.117500E+03,4.153100E+04,2.557600E+05,3.595300E-06,1.999000E-05,& + & 1.132900E-04,5.321700E-04,1.873100E-03,6.485400E-03,2.888500E-02,& + & 1.986600E-01,2.705300E+00,1.486900E+01,2.835800E+01,5.617900E+01,& + & 1.688900E+02,2.558900E+03,2.076600E+04,1.278800E+05,1.799700E-06,& + & 8.909100E-06,2.694300E-05,6.457100E-05,1.481900E-04,3.858200E-04,& + & 1.392000E-03,1.691200E-02,5.191600E-01,3.416000E+00,7.180000E+00,& + & 1.440400E+01,2.859900E+01,5.060900E+01,8.537900E+01,1.548200E+02,& + & 5.288400E-06,2.293000E-05,1.442700E-04,1.037400E-03,3.904200E-03,& + & 1.395400E-02,5.249500E-02,2.848000E-01,4.737400E+00,3.580200E+01,& + & 9.292000E+01,2.884900E+02,1.051900E+03,1.452700E+04,1.047700E+05,& + & 6.191300E+05,6.494300E-06,3.287000E-05,2.175300E-04,1.314900E-03,& + & 5.211000E-03,1.904200E-02,7.552100E-02,4.118200E-01,4.821700E+00,& + & 2.758600E+01,6.981700E+01,2.165000E+02,7.890500E+02,1.089500E+04,& + & 7.857900E+04,4.643400E+05,5.939300E-06,3.148500E-05,1.962600E-04,& + & 1.053000E-03,4.058200E-03,1.511900E-02,6.494700E-02,3.815600E-01,& + & 4.603300E+00,2.321400E+01,4.904100E+01,1.445500E+02,5.261800E+02,& + & 7.263600E+03,5.238600E+04,3.095600E+05,4.736700E-06,2.663400E-05,& + & 1.517800E-04,7.003800E-04,2.549900E-03,9.217100E-03,4.403000E-02,& + & 2.878600E-01,3.622800E+00,1.870200E+01,3.469100E+01,7.701800E+01,& + & 2.633700E+02,3.632000E+03,2.619300E+04,1.547800E+05,2.088200E-06,& + & 9.842800E-06,2.909800E-05,6.789000E-05,1.541700E-04,3.978800E-04,& + & 1.473300E-03,2.255700E-02,6.375500E-01,3.832100E+00,7.634600E+00,& + & 1.467300E+01,2.760600E+01,4.790400E+01,7.774500E+01,1.432300E+02,& + & 1.721000E-06,4.073800E-06,1.131700E-05,1.048900E-04,5.628300E-04,& + & 1.867000E-03,6.403600E-03,3.011900E-02,4.465900E-01,3.524600E+00,& + & 9.908700E+00,3.051900E+01,1.186500E+02,2.342100E+03,3.151200E+04,& + & 2.335100E+05,1.767800E-06,6.076700E-06,2.845400E-05,2.110900E-04,& + & 8.247900E-04,2.749200E-03,9.829000E-03,5.903800E-02,9.330500E-01,& + & 6.095200E+00,1.238900E+01,2.675400E+01,8.944500E+01,1.756600E+03,& + & 2.363400E+04,1.751300E+05,1.527700E-06,6.432200E-06,3.258900E-05,& + & 2.014100E-04,7.377700E-04,2.384100E-03,8.540600E-03,5.522700E-02,& + & 9.871300E-01,6.783600E+00,1.370200E+01,2.881400E+01,6.768000E+01,& + & 1.171200E+03,1.575600E+04,1.167500E+05,1.200300E-06,6.277500E-06,& + & 3.209200E-05,1.621800E-04,5.577200E-04,1.702100E-03,6.203200E-03,& + & 4.190900E-02,8.504200E-01,6.122100E+00,1.277100E+01,2.677500E+01,& + & 5.658700E+01,5.945600E+02,7.878300E+03,5.837700E+04,6.844000E-07,& + & 4.426500E-06,1.535300E-05,4.187800E-05,1.028000E-04,2.757800E-04,& + & 9.304300E-04,6.043600E-03,2.013100E-01,1.928500E+00,5.011000E+00,& + & 1.251600E+01,2.929000E+01,6.258800E+01,1.131700E+02,2.090900E+02,& + & 1.981800E-06,5.202800E-06,1.974200E-05,2.063300E-04,9.249000E-04,& + & 3.167800E-03,1.102600E-02,5.372300E-02,8.450300E-01,6.539200E+00,& + & 1.834700E+01,5.889500E+01,2.221600E+02,4.151700E+03,4.716200E+04,& + & 3.281100E+05,2.193900E-06,8.318200E-06,4.545700E-05,3.401600E-04,& + & 1.303000E-03,4.482600E-03,1.650100E-02,1.001200E-01,1.445800E+00,& + & 8.757900E+00,1.762500E+01,4.541100E+01,1.667400E+02,3.113800E+03,& + & 3.537300E+04,2.460800E+05,1.963800E-06,8.851900E-06,4.922900E-05,& + & 3.044400E-04,1.114900E-03,3.740800E-03,1.406400E-02,9.408300E-02,& + & 1.496200E+00,9.500700E+00,1.899100E+01,3.910600E+01,1.134600E+02,& + & 2.076000E+03,2.358100E+04,1.640600E+05,1.596300E-06,8.504000E-06,& + & 4.579100E-05,2.305400E-04,7.967300E-04,2.526700E-03,9.839700E-03,& + & 7.101100E-02,1.269800E+00,8.489900E+00,1.701800E+01,3.446200E+01,& + & 7.241500E+01,1.039300E+03,1.179100E+04,8.202900E+04,9.069800E-07,& + & 5.326800E-06,1.743200E-05,4.553800E-05,1.088200E-04,2.900500E-04,& + & 1.004500E-03,7.924400E-03,2.795000E-01,2.379000E+00,5.732100E+00,& + & 1.334400E+01,2.943500E+01,5.892700E+01,1.039100E+02,1.900100E+02/ + data absb(:, 961: 980) / & + & 2.458800E-06,7.438600E-06,3.671100E-05,3.653600E-04,1.456900E-03,& + & 5.126000E-03,1.827300E-02,9.181600E-02,1.522700E+00,1.166200E+01,& + & 3.221000E+01,1.059400E+02,3.889500E+02,6.786100E+03,6.620900E+04,& + & 4.357900E+05,2.871800E-06,1.196900E-05,7.271400E-05,5.258000E-04,& + & 2.002600E-03,7.098500E-03,2.705600E-02,1.602600E-01,2.177600E+00,& + & 1.220700E+01,2.611900E+01,7.967300E+01,2.918200E+02,5.089700E+03,& + & 4.965700E+04,3.268400E+05,2.610400E-06,1.245400E-05,7.396300E-05,& + & 4.474600E-04,1.650800E-03,5.765600E-03,2.286400E-02,1.511300E-01,& + & 2.190800E+00,1.285400E+01,2.530800E+01,5.766800E+01,1.947200E+02,& + & 3.393200E+03,3.310500E+04,2.179000E+05,2.137000E-06,1.154900E-05,& + & 6.484100E-05,3.205100E-04,1.121300E-03,3.738300E-03,1.556500E-02,& + & 1.143800E-01,1.818500E+00,1.122900E+01,2.210500E+01,4.329700E+01,& + & 1.043900E+02,1.696800E+03,1.655300E+04,1.089500E+05,1.144100E-06,& + & 6.201500E-06,1.949600E-05,4.887400E-05,1.146300E-04,3.030000E-04,& + & 1.074200E-03,1.053000E-02,3.721100E-01,2.828900E+00,6.382400E+00,& + & 1.394000E+01,2.920700E+01,5.533100E+01,9.585200E+01,1.737700E+02,& + & 3.242800E-06,1.158000E-05,6.663900E-05,5.869600E-04,2.232200E-03,& + & 7.943900E-03,2.916300E-02,1.528900E-01,2.619700E+00,2.009400E+01,& + & 5.437400E+01,1.784600E+02,6.504800E+02,1.036600E+04,8.831600E+04,& + & 5.531400E+05,3.881700E-06,1.767600E-05,1.141600E-04,7.808500E-04,& + & 3.004300E-03,1.090400E-02,4.302800E-02,2.466500E-01,3.187800E+00,& + & 1.714600E+01,4.143800E+01,1.339900E+02,4.879500E+02,7.774600E+03,& + & 6.623800E+04,4.148600E+05,3.535800E-06,1.766600E-05,1.090100E-04,& + & 6.402300E-04,2.396700E-03,8.719600E-03,3.652300E-02,2.316900E-01,& + & 3.127100E+00,1.707700E+01,3.339700E+01,9.080000E+01,3.254400E+02,& + & 5.183200E+03,4.416400E+04,2.765300E+05,2.854100E-06,1.565900E-05,& + & 8.997700E-05,4.382900E-04,1.558000E-03,5.453900E-03,2.460100E-02,& + & 1.754900E-01,2.530500E+00,1.441900E+01,2.794400E+01,5.554600E+01,& + & 1.647300E+02,2.591800E+03,2.208000E+04,1.382900E+05,1.387800E-06,& + & 7.024900E-06,2.143900E-05,5.199700E-05,1.201000E-04,3.148700E-04,& + & 1.143700E-03,1.419800E-02,4.777500E-01,3.263700E+00,7.003800E+00,& + & 1.431600E+01,2.881900E+01,5.172800E+01,8.823200E+01,1.597000E+02,& + & 4.464500E-06,1.850000E-05,1.150100E-04,8.755600E-04,3.309000E-03,& + & 1.190000E-02,4.514500E-02,2.492300E-01,4.324600E+00,3.354400E+01,& + & 8.911800E+01,2.845200E+02,1.040100E+03,1.498300E+04,1.129200E+05,& + & 6.771700E+05,5.333500E-06,2.623100E-05,1.749600E-04,1.109100E-03,& + & 4.413300E-03,1.632600E-02,6.595800E-02,3.694100E-01,4.533300E+00,& + & 2.603100E+01,6.698400E+01,2.135300E+02,7.802000E+02,1.123800E+04,& + & 8.469300E+04,5.078800E+05,4.814000E-06,2.501800E-05,1.578000E-04,& + & 8.846000E-04,3.428100E-03,1.292900E-02,5.662800E-02,3.430900E-01,& + & 4.350400E+00,2.258600E+01,4.757000E+01,1.426000E+02,5.202700E+02,& + & 7.491900E+03,5.646200E+04,3.385900E+05,3.788500E-06,2.108200E-05,& + & 1.223200E-04,5.847300E-04,2.147700E-03,7.859700E-03,3.826400E-02,& + & 2.590700E-01,3.439200E+00,1.831100E+01,3.454000E+01,7.655200E+01,& + & 2.604200E+02,3.746200E+03,2.823100E+04,1.692900E+05,1.627500E-06,& + & 7.808800E-06,2.326600E-05,5.485800E-05,1.251600E-04,3.257800E-04,& + & 1.214000E-03,1.928500E-02,5.933100E-01,3.695500E+00,7.494100E+00,& + & 1.460300E+01,2.794300E+01,4.907100E+01,8.000300E+01,1.475000E+02,& + & 1.636700E-06,3.760200E-06,9.519300E-06,7.979300E-05,4.596400E-04,& + & 1.518100E-03,5.219000E-03,2.457500E-02,3.700000E-01,2.997200E+00,& + & 8.616700E+00,2.717200E+01,1.090000E+02,2.219200E+03,3.207600E+04,& + & 2.439500E+05,1.588200E-06,5.125100E-06,2.215100E-05,1.660100E-04,& + & 6.670600E-04,2.229800E-03,8.008800E-03,4.886200E-02,8.208800E-01,& + & 5.580900E+00,1.157600E+01,2.493800E+01,8.251700E+01,1.664500E+03,& + & 2.405700E+04,1.829600E+05,1.317800E-06,5.195400E-06,2.512400E-05,& + & 1.591800E-04,5.957000E-04,1.933700E-03,6.936700E-03,4.551600E-02,& + & 8.723200E-01,6.267000E+00,1.289900E+01,2.763800E+01,6.468300E+01,& + & 1.109800E+03,1.603800E+04,1.219700E+05,9.779100E-07,4.892200E-06,& + & 2.460300E-05,1.285300E-04,4.496900E-04,1.382100E-03,5.024500E-03,& + & 3.438800E-02,7.539800E-01,5.672900E+00,1.208900E+01,2.591100E+01,& + & 5.618400E+01,5.655000E+02,8.019800E+03,6.098400E+04,4.992000E-07,& + & 3.363700E-06,1.198000E-05,3.327600E-05,8.269500E-05,2.229400E-04,& + & 7.543400E-04,4.844800E-03,1.747300E-01,1.763700E+00,4.724500E+00,& + & 1.215400E+01,2.915900E+01,6.392900E+01,1.170600E+02,2.173900E+02/ + data absb(:, 981:1000) / & + & 1.835500E-06,4.621900E-06,1.569200E-05,1.624700E-04,7.711300E-04,& + & 2.632300E-03,9.169400E-03,4.507300E-02,7.241100E-01,5.740100E+00,& + & 1.665100E+01,5.444300E+01,2.115400E+02,4.077400E+03,4.934200E+04,& + & 3.510400E+05,1.914300E-06,6.826900E-06,3.536200E-05,2.746800E-04,& + & 1.073900E-03,3.711300E-03,1.376400E-02,8.552000E-02,1.301300E+00,& + & 8.202500E+00,1.681800E+01,4.240400E+01,1.587900E+02,3.058100E+03,& + & 3.700600E+04,2.632800E+05,1.652700E-06,7.058100E-06,3.819700E-05,& + & 2.463100E-04,9.164600E-04,3.090400E-03,1.168400E-02,8.010500E-02,& + & 1.354800E+00,8.983400E+00,1.823100E+01,3.793000E+01,1.087600E+02,& + & 2.038800E+03,2.467100E+04,1.755200E+05,1.285300E-06,6.628000E-06,& + & 3.551000E-05,1.861700E-04,6.536200E-04,2.084400E-03,8.148600E-03,& + & 6.014900E-02,1.154500E+00,8.059700E+00,1.639500E+01,3.386700E+01,& + & 7.145300E+01,1.021500E+03,1.233600E+04,8.776100E+04,6.753700E-07,& + & 4.107400E-06,1.370100E-05,3.635700E-05,8.777400E-05,2.353500E-04,& + & 8.183400E-04,6.423700E-03,2.477500E-01,2.211500E+00,5.484200E+00,& + & 1.304700E+01,2.946600E+01,6.026600E+01,1.072700E+02,1.969300E+02,& + & 2.216200E-06,6.341600E-06,2.893300E-05,2.990500E-04,1.232900E-03,& + & 4.338900E-03,1.552400E-02,7.895100E-02,1.345500E+00,1.055300E+01,& + & 3.013800E+01,1.014000E+02,3.801400E+02,6.857400E+03,7.077700E+04,& + & 4.752300E+05,2.454000E-06,9.682300E-06,5.728200E-05,4.347400E-04,& + & 1.679100E-03,5.994300E-03,2.304900E-02,1.404900E-01,2.000100E+00,& + & 1.161800E+01,2.495700E+01,7.633500E+01,2.852200E+02,5.143200E+03,& + & 5.308300E+04,3.564300E+05,2.167600E-06,9.893400E-06,5.827300E-05,& + & 3.692400E-04,1.379600E-03,4.857400E-03,1.939400E-02,1.322000E-01,& + & 2.023600E+00,1.235700E+01,2.476200E+01,5.614000E+01,1.903800E+02,& + & 3.428900E+03,3.538900E+04,2.376200E+05,1.715600E-06,9.048500E-06,& + & 5.101900E-05,2.635300E-04,9.346000E-04,3.138200E-03,1.315100E-02,& + & 9.973200E-02,1.687100E+00,1.086100E+01,2.164600E+01,4.319100E+01,& + & 1.030600E+02,1.714600E+03,1.769500E+04,1.188100E+05,8.664200E-07,& + & 4.836300E-06,1.541500E-05,3.919600E-05,9.267500E-05,2.465500E-04,& + & 8.791300E-04,8.648000E-03,3.355500E-01,2.671000E+00,6.167900E+00,& + & 1.374400E+01,2.932000E+01,5.663000E+01,9.879300E+01,1.796800E+02,& + & 2.865100E-06,9.636000E-06,5.324800E-05,4.953000E-04,1.912400E-03,& + & 6.836300E-03,2.523200E-02,1.341600E-01,2.381500E+00,1.866600E+01,& + & 5.227300E+01,1.759700E+02,6.472300E+02,1.072800E+04,9.607200E+04,& + & 6.124700E+05,3.277400E-06,1.427100E-05,9.160400E-05,6.597600E-04,& + & 2.556900E-03,9.377000E-03,3.744200E-02,2.206700E-01,2.988600E+00,& + & 1.639200E+01,4.001100E+01,1.321200E+02,4.855200E+02,8.045900E+03,& + & 7.205400E+04,4.593600E+05,2.918800E-06,1.410800E-05,8.735000E-05,& + & 5.384700E-04,2.034500E-03,7.473600E-03,3.164700E-02,2.072000E-01,& + & 2.940800E+00,1.664500E+01,3.295200E+01,8.979100E+01,3.238100E+02,& + & 5.364100E+03,4.803700E+04,3.062400E+05,2.299600E-06,1.237400E-05,& + & 7.201700E-05,3.661800E-04,1.317200E-03,4.659900E-03,2.121500E-02,& + & 1.565700E-01,2.388800E+00,1.412600E+01,2.778900E+01,5.574400E+01,& + & 1.642500E+02,2.682200E+03,2.401900E+04,1.531200E+05,1.066000E-06,& + & 5.526400E-06,1.704800E-05,4.183900E-05,9.731400E-05,2.571100E-04,& + & 9.390200E-04,1.185200E-02,4.379800E-01,3.109100E+00,6.819900E+00,& + & 1.420400E+01,2.899300E+01,5.305400E+01,9.066200E+01,1.648100E+02,& + & 3.890300E-06,1.533700E-05,9.364600E-05,7.554600E-04,2.874400E-03,& + & 1.038900E-02,3.969800E-02,2.231900E-01,4.031500E+00,3.205800E+01,& + & 8.748100E+01,2.869000E+02,1.053700E+03,1.580600E+04,1.246400E+05,& + & 7.589800E+05,4.487100E-06,2.132000E-05,1.430400E-04,9.547500E-04,& + & 3.813900E-03,1.425600E-02,5.852900E-02,3.366100E-01,4.326400E+00,& + & 2.506900E+01,6.578100E+01,2.153100E+02,7.904100E+02,1.185500E+04,& + & 9.348400E+04,5.692400E+05,3.980300E-06,2.016500E-05,1.286500E-04,& + & 7.572100E-04,2.952600E-03,1.126300E-02,5.010100E-02,3.125300E-01,& + & 4.165400E+00,2.225900E+01,4.711100E+01,1.438200E+02,5.270800E+02,& + & 7.903500E+03,6.232300E+04,3.794900E+05,3.072800E-06,1.684600E-05,& + & 9.957600E-05,4.962700E-04,1.840400E-03,6.824200E-03,3.371400E-02,& + & 2.357400E-01,3.299000E+00,1.812800E+01,3.477000E+01,7.756400E+01,& + & 2.638200E+02,3.952000E+03,3.116200E+04,1.897500E+05,1.264900E-06,& + & 6.186500E-06,1.858300E-05,4.431700E-05,1.015700E-04,2.666500E-04,& + & 1.001000E-03,1.641200E-02,5.507900E-01,3.557800E+00,7.341500E+00,& + & 1.453900E+01,2.820800E+01,5.032100E+01,8.213800E+01,1.519200E+02/ + data absb(:,1001:1020) / & + & 1.635900E-06,3.670200E-06,8.601300E-06,6.272900E-05,3.873000E-04,& + & 1.275200E-03,4.388200E-03,2.061200E-02,3.152200E-01,2.607900E+00,& + & 7.670200E+00,2.485200E+01,1.028300E+02,2.158800E+03,3.360800E+04,& + & 2.628400E+05,1.506500E-06,4.539000E-06,1.780600E-05,1.330700E-04,& + & 5.528200E-04,1.853100E-03,6.671700E-03,4.113800E-02,7.323600E-01,& + & 5.173400E+00,1.097900E+01,2.378300E+01,7.822400E+01,1.619200E+03,& + & 2.520700E+04,1.971300E+05,1.197100E-06,4.365900E-06,1.975600E-05,& + & 1.279200E-04,4.910800E-04,1.602400E-03,5.745400E-03,3.806800E-02,& + & 7.793500E-01,5.844900E+00,1.228900E+01,2.679700E+01,6.327200E+01,& + & 1.079700E+03,1.680500E+04,1.314200E+05,8.321500E-07,3.900200E-06,& + & 1.908000E-05,1.032100E-04,3.687400E-04,1.142800E-03,4.134300E-03,& + & 2.854700E-02,6.736900E-01,5.298700E+00,1.153000E+01,2.530600E+01,& + & 5.642500E+01,5.517500E+02,8.402500E+03,6.571200E+04,3.610800E-07,& + & 2.542300E-06,9.322200E-06,2.640100E-05,6.648000E-05,1.801400E-04,& + & 6.105500E-04,3.866200E-03,1.503400E-01,1.602600E+00,4.429500E+00,& + & 1.175300E+01,2.896600E+01,6.525900E+01,1.211400E+02,2.262500E+02,& + & 1.788400E-06,4.343700E-06,1.317400E-05,1.313800E-04,6.652900E-04,& + & 2.259400E-03,7.876200E-03,3.900800E-02,6.378700E-01,5.186200E+00,& + & 1.550800E+01,5.180600E+01,2.076000E+02,4.122500E+03,5.329000E+04,& + & 3.881000E+05,1.757000E-06,5.853300E-06,2.817900E-05,2.265800E-04,& + & 9.091300E-04,3.150800E-03,1.176200E-02,7.444100E-02,1.190800E+00,& + & 7.803000E+00,1.636600E+01,4.072100E+01,1.558400E+02,3.091900E+03,& + & 3.996800E+04,2.910800E+05,1.455200E-06,5.807200E-06,3.014400E-05,& + & 2.032400E-04,7.713000E-04,2.614000E-03,9.916300E-03,6.929900E-02,& + & 1.243300E+00,8.605500E+00,1.777100E+01,3.744700E+01,1.072800E+02,& + & 2.061400E+03,2.664500E+04,1.940500E+05,1.070400E-06,5.258800E-06,& + & 2.785000E-05,1.528900E-04,5.466000E-04,1.756100E-03,6.866000E-03,& + & 5.163500E-02,1.061000E+00,7.724600E+00,1.597000E+01,3.365600E+01,& + & 7.185800E+01,1.033200E+03,1.332300E+04,9.702700E+04,4.995400E-07,& + & 3.153700E-06,1.074300E-05,2.900600E-05,7.074300E-05,1.908500E-04,& + & 6.661100E-04,5.178600E-03,2.183500E-01,2.045600E+00,5.225300E+00,& + & 1.272000E+01,2.946700E+01,6.154600E+01,1.108100E+02,2.042400E+02,& + & 2.101000E-06,5.712700E-06,2.371100E-05,2.516000E-04,1.081100E-03,& + & 3.799000E-03,1.362100E-02,7.007800E-02,1.225000E+00,9.825400E+00,& + & 2.908600E+01,1.000200E+02,3.842900E+02,7.149200E+03,7.826900E+04,& + & 5.364100E+05,2.192600E-06,8.121900E-06,4.616200E-05,3.687700E-04,& + & 1.448300E-03,5.201300E-03,2.011500E-02,1.257500E-01,1.871700E+00,& + & 1.126700E+01,2.449000E+01,7.536900E+01,2.883400E+02,5.362000E+03,& + & 5.870200E+04,4.023100E+05,1.870600E-06,8.067400E-06,4.670000E-05,& + & 3.120500E-04,1.183200E-03,4.198200E-03,1.682500E-02,1.177500E-01,& + & 1.898500E+00,1.206500E+01,2.463300E+01,5.601900E+01,1.925100E+02,& + & 3.574700E+03,3.913500E+04,2.682100E+05,1.415600E-06,7.200600E-06,& + & 4.062900E-05,2.209400E-04,7.966100E-04,2.696100E-03,1.133000E-02,& + & 8.826900E-02,1.585200E+00,1.063300E+01,2.148400E+01,4.366700E+01,& + & 1.047000E+02,1.787500E+03,1.956800E+04,1.341000E+05,6.525700E-07,& + & 3.761300E-06,1.216100E-05,3.141000E-05,7.490200E-05,2.006700E-04,& + & 7.187400E-04,7.062300E-03,3.012400E-01,2.507500E+00,5.948500E+00,& + & 1.352500E+01,2.938100E+01,5.791800E+01,1.018500E+02,1.858900E+02,& + & 2.654300E-06,8.406800E-06,4.400600E-05,4.312800E-04,1.697700E-03,& + & 6.092200E-03,2.257700E-02,1.216400E-01,2.232800E+00,1.790200E+01,& + & 5.188100E+01,1.791600E+02,6.669700E+02,1.147500E+04,1.082400E+05,& + & 7.028300E+05,2.882100E-06,1.188600E-05,7.521800E-05,5.732600E-04,& + & 2.242500E-03,8.295900E-03,3.338600E-02,2.019200E-01,2.859300E+00,& + & 1.606900E+01,3.985200E+01,1.345100E+02,5.003300E+02,8.606300E+03,& + & 8.118300E+04,5.271300E+05,2.493500E-06,1.152800E-05,7.136600E-05,& + & 4.647900E-04,1.775000E-03,6.581600E-03,2.804900E-02,1.889400E-01,& + & 2.814900E+00,1.650600E+01,3.323500E+01,9.151700E+01,3.336900E+02,& + & 5.737600E+03,5.412300E+04,3.514200E+05,1.897500E-06,9.929800E-06,& + & 5.842600E-05,3.129000E-04,1.141900E-03,4.083500E-03,1.866800E-02,& + & 1.420900E-01,2.287600E+00,1.405300E+01,2.805500E+01,5.713400E+01,& + & 1.692600E+02,2.869000E+03,2.706200E+04,1.757100E+05,8.151900E-07,& + & 4.339900E-06,1.352800E-05,3.366300E-05,7.880100E-05,2.098200E-04,& + & 7.708700E-04,9.828500E-03,3.999300E-01,2.952800E+00,6.623800E+00,& + & 1.406700E+01,2.914400E+01,5.440900E+01,9.309300E+01,1.701800E+02/ + data absb(:,1021:1040) / & + & 3.546200E-06,1.324200E-05,7.888500E-05,6.743600E-04,2.587500E-03,& + & 9.394700E-03,3.613500E-02,2.065700E-01,3.880600E+00,3.162600E+01,& + & 8.898800E+01,2.993100E+02,1.106100E+03,1.726200E+04,1.426600E+05,& + & 8.826000E+05,3.914300E-06,1.784600E-05,1.199400E-04,8.474300E-04,& + & 3.397800E-03,1.280900E-02,5.326100E-02,3.141400E-01,4.225500E+00,& + & 2.484200E+01,6.693000E+01,2.246200E+02,8.297100E+02,1.294600E+04,& + & 1.070000E+05,6.619500E+05,3.394500E-06,1.663200E-05,1.071900E-04,& + & 6.668800E-04,2.618000E-03,1.009500E-02,4.534100E-02,2.907700E-01,& + & 4.065400E+00,2.238200E+01,4.808200E+01,1.500400E+02,5.532800E+02,& + & 8.631100E+03,7.133300E+04,4.413000E+05,2.550300E-06,1.368000E-05,& + & 8.238900E-05,4.320000E-04,1.618900E-03,6.087500E-03,3.033700E-02,& + & 2.183900E-01,3.216400E+00,1.827200E+01,3.558900E+01,8.082500E+01,& + & 2.769100E+02,4.315800E+03,3.566700E+04,2.206500E+05,9.801100E-07,& + & 4.897000E-06,1.481900E-05,3.579000E-05,8.243400E-05,2.181900E-04,& + & 8.249300E-04,1.388900E-02,5.096500E-01,3.416600E+00,7.184900E+00,& + & 1.447900E+01,2.840200E+01,5.157100E+01,8.435600E+01,1.565800E+02,& + & 1.430000E-06,3.140300E-06,6.978900E-06,4.353600E-05,2.843800E-04,& + & 9.366300E-04,3.217100E-03,1.506500E-02,2.342200E-01,1.969200E+00,& + & 5.945000E+00,1.981400E+01,8.461200E+01,1.828200E+03,3.055400E+04,& + & 2.453200E+05,1.280200E-06,3.692400E-06,1.343700E-05,9.699300E-05,& + & 4.124000E-04,1.382000E-03,4.979100E-03,3.128000E-02,6.007600E-01,& + & 4.449200E+00,9.617700E+00,2.104600E+01,6.533700E+01,1.371300E+03,& + & 2.291600E+04,1.839900E+05,9.925700E-07,3.455700E-06,1.477100E-05,& + & 9.465000E-05,3.692300E-04,1.204000E-03,4.315200E-03,2.902100E-02,& + & 6.467100E-01,5.097100E+00,1.097200E+01,2.439200E+01,5.722300E+01,& + & 9.152000E+02,1.527700E+04,1.226600E+05,6.649700E-07,2.999600E-06,& + & 1.423800E-05,7.746500E-05,2.803200E-04,8.680700E-04,3.132700E-03,& + & 2.186500E-02,5.650300E-01,4.673000E+00,1.043100E+01,2.347700E+01,& + & 5.425900E+01,4.729000E+02,7.638900E+03,6.133200E+04,2.612900E-07,& + & 1.917700E-06,7.254600E-06,2.092100E-05,5.339100E-05,1.454400E-04,& + & 4.937500E-04,3.088100E-03,1.292800E-01,1.456000E+00,4.145500E+00,& + & 1.136700E+01,2.874400E+01,6.644800E+01,1.251000E+02,2.348900E+02,& + & 1.526200E-06,3.598600E-06,9.911900E-06,9.275200E-05,5.003800E-04,& + & 1.691400E-03,5.900600E-03,2.941500E-02,4.900500E-01,4.077700E+00,& + & 1.255600E+01,4.302800E+01,1.775500E+02,3.627900E+03,4.993600E+04,& + & 3.721200E+05,1.450800E-06,4.630100E-06,2.081100E-05,1.681400E-04,& + & 6.888100E-04,2.388700E-03,8.989100E-03,5.867800E-02,1.001000E+00,& + & 6.848300E+00,1.466800E+01,3.501900E+01,1.332900E+02,2.721000E+03,& + & 3.745200E+04,2.790900E+05,1.176800E-06,4.498600E-06,2.237100E-05,& + & 1.526800E-04,5.876400E-04,1.991100E-03,7.602700E-03,5.474000E-02,& + & 1.058700E+00,7.694200E+00,1.612600E+01,3.454500E+01,9.374000E+01,& + & 1.814100E+03,2.496800E+04,1.860600E+05,8.395800E-07,4.011500E-06,& + & 2.082400E-05,1.162600E-04,4.195700E-04,1.348200E-03,5.293100E-03,& + & 4.084100E-02,9.146000E-01,6.974800E+00,1.470800E+01,3.150400E+01,& + & 6.748700E+01,9.113500E+02,1.248400E+04,9.303100E+04,3.695800E-07,& + & 2.415500E-06,8.418500E-06,2.310300E-05,5.698600E-05,1.546000E-04,& + & 5.412600E-04,4.180300E-03,1.921700E-01,1.891800E+00,4.952400E+00,& + & 1.241900E+01,2.937600E+01,6.284400E+01,1.142300E+02,2.113900E+02,& + & 1.748400E-06,4.561700E-06,1.716700E-05,1.837800E-04,8.271000E-04,& + & 2.899700E-03,1.041100E-02,5.418600E-02,9.716600E-01,7.963600E+00,& + & 2.449100E+01,8.598800E+01,3.388600E+02,6.484100E+03,7.507900E+04,& + & 5.186000E+05,1.768500E-06,6.266900E-06,3.406500E-05,2.791900E-04,& + & 1.113000E-03,4.020100E-03,1.569900E-02,1.019500E-01,1.601400E+00,& + & 1.004400E+01,2.177000E+01,6.512600E+01,2.542700E+02,4.863100E+03,& + & 5.630900E+04,3.935100E+05,1.482700E-06,6.168600E-06,3.480000E-05,& + & 2.383500E-04,9.132300E-04,3.249400E-03,1.315300E-02,9.587300E-02,& + & 1.647300E+00,1.096000E+01,2.278000E+01,5.058800E+01,1.701700E+02,& + & 3.242200E+03,3.754000E+04,2.623400E+05,1.099200E-06,5.474100E-06,& + & 3.057400E-05,1.701600E-04,6.189600E-04,2.095300E-03,8.889300E-03,& + & 7.199100E-02,1.394300E+00,9.797800E+00,2.003100E+01,4.140300E+01,& + & 9.588600E+01,1.621200E+03,1.877000E+04,1.311700E+05,4.916900E-07,& + & 2.917500E-06,9.580800E-06,2.512100E-05,6.046400E-05,1.629700E-04,& + & 5.863500E-04,5.770000E-03,2.706800E-01,2.348600E+00,5.713400E+00,& + & 1.328200E+01,2.946300E+01,5.915500E+01,1.048000E+02,1.918800E+02/ + data absb(:,1041:1060) / & + & 2.156900E-06,6.478300E-06,3.190900E-05,3.264500E-04,1.314000E-03,& + & 4.730600E-03,1.759900E-02,9.621500E-02,1.823700E+00,1.498200E+01,& + & 4.495400E+01,1.587800E+02,6.006700E+02,1.067000E+04,1.057800E+05,& + & 6.990300E+05,2.288300E-06,9.043300E-06,5.595600E-05,4.425600E-04,& + & 1.746700E-03,6.527300E-03,2.663600E-02,1.674700E-01,2.490900E+00,& + & 1.443400E+01,3.503100E+01,1.192300E+02,4.506000E+02,8.002500E+03,& + & 7.933300E+04,5.242700E+05,1.953900E-06,8.762600E-06,5.370800E-05,& + & 3.603300E-04,1.386300E-03,5.175800E-03,2.239700E-02,1.576300E-01,& + & 2.482800E+00,1.516400E+01,3.090800E+01,8.204400E+01,3.005500E+02,& + & 5.335100E+03,5.288900E+04,3.495200E+05,1.467900E-06,7.556200E-06,& + & 4.443600E-05,2.438200E-04,8.967400E-04,3.218900E-03,1.492300E-02,& + & 1.190200E-01,2.044300E+00,1.312500E+01,2.651500E+01,5.385600E+01,& + & 1.536900E+02,2.667700E+03,2.644500E+04,1.747600E+05,6.224400E-07,& + & 3.400700E-06,1.072100E-05,2.701200E-05,6.369800E-05,1.707500E-04,& + & 6.310800E-04,8.164100E-03,3.643800E-01,2.802800E+00,6.412200E+00,& + & 1.388900E+01,2.931500E+01,5.555200E+01,9.598100E+01,1.753600E+02,& + & 2.835400E-06,1.004200E-05,5.808100E-05,5.234900E-04,2.028900E-03,& + & 7.398400E-03,2.864800E-02,1.667100E-01,3.257500E+00,2.715800E+01,& + & 7.902700E+01,2.722500E+02,1.012700E+03,1.638400E+04,1.415100E+05,& + & 8.894600E+05,3.076400E-06,1.353300E-05,9.042200E-05,6.657100E-04,& + & 2.679100E-03,1.023800E-02,4.342800E-02,2.651800E-01,3.745600E+00,& + & 2.190200E+01,5.956900E+01,2.043300E+02,7.596200E+02,1.228800E+04,& + & 1.061300E+05,6.641600E+05,2.645500E-06,1.265500E-05,8.154400E-05,& + & 5.249700E-04,2.067700E-03,8.053900E-03,3.701600E-02,2.473300E-01,& + & 3.641900E+00,2.073300E+01,4.406500E+01,1.366900E+02,5.065500E+02,& + & 8.192200E+03,7.075600E+04,4.447400E+05,1.974800E-06,1.045500E-05,& + & 6.330700E-05,3.410400E-04,1.282600E-03,4.862200E-03,2.476600E-02,& + & 1.866300E-01,2.914800E+00,1.721100E+01,3.400100E+01,7.546000E+01,& + & 2.536800E+02,4.096300E+03,3.537800E+04,2.223700E+05,7.577300E-07,& + & 3.863900E-06,1.179900E-05,2.878800E-05,6.675400E-05,1.779700E-04,& + & 6.774700E-04,1.176000E-02,4.711200E-01,3.254300E+00,7.009000E+00,& + & 1.435700E+01,2.870500E+01,5.263600E+01,8.695800E+01,1.610600E+02,& + & 1.149600E-06,2.473900E-06,5.312800E-06,2.796800E-05,1.903200E-04,& + & 6.293500E-04,2.150100E-03,1.002500E-02,1.583800E-01,1.350700E+00,& + & 4.171000E+00,1.438800E+01,6.338700E+01,1.406700E+03,2.524200E+04,& + & 2.081500E+05,1.010700E-06,2.834300E-06,9.739000E-06,6.661900E-05,& + & 2.871400E-04,9.596900E-04,3.451600E-03,2.218300E-02,4.663900E-01,& + & 3.643300E+00,8.022500E+00,1.795000E+01,5.093500E+01,1.055100E+03,& + & 1.893200E+04,1.561200E+05,7.730000E-07,2.616500E-06,1.068800E-05,& + & 6.650600E-05,2.616400E-04,8.490000E-04,3.036000E-03,2.077600E-02,& + & 5.104900E-01,4.256600E+00,9.397800E+00,2.137200E+01,5.016800E+01,& + & 7.063800E+02,1.262100E+04,1.040800E+05,5.063900E-07,2.242000E-06,& + & 1.035800E-05,5.571200E-05,2.031200E-04,6.246500E-04,2.247500E-03,& + & 1.584300E-02,4.541100E-01,3.966100E+00,9.122600E+00,2.116800E+01,& + & 5.099600E+01,3.735400E+02,6.310800E+03,5.203900E+04,1.879000E-07,& + & 1.442700E-06,5.636700E-06,1.655000E-05,4.285700E-05,1.173800E-04,& + & 3.987200E-04,2.460600E-03,1.108300E-01,1.313000E+00,3.868200E+00,& + & 1.097400E+01,2.848700E+01,6.755800E+01,1.291000E+02,2.437000E+02,& + & 1.199500E-06,2.755300E-06,6.998700E-06,5.985800E-05,3.435400E-04,& + & 1.155800E-03,4.034400E-03,2.021600E-02,3.430600E-01,2.915400E+00,& + & 9.229300E+00,3.259600E+01,1.383100E+02,2.904100E+03,4.256100E+04,& + & 3.244000E+05,1.118700E-06,3.467200E-06,1.467200E-05,1.165100E-04,& + & 4.851400E-04,1.679900E-03,6.371300E-03,4.324800E-02,7.959000E-01,& + & 5.721500E+00,1.248600E+01,2.857000E+01,1.041000E+02,2.178100E+03,& + & 3.192100E+04,2.433000E+05,8.971900E-07,3.343500E-06,1.598400E-05,& + & 1.080300E-04,4.194000E-04,1.416100E-03,5.443100E-03,4.060500E-02,& + & 8.587800E-01,6.583000E+00,1.400100E+01,3.063000E+01,7.701100E+01,& + & 1.452200E+03,2.128100E+04,1.622000E+05,6.300900E-07,2.975800E-06,& + & 1.511300E-05,8.412600E-05,3.048700E-04,9.747200E-04,3.845400E-03,& + & 3.050200E-02,7.558900E-01,6.053600E+00,1.307000E+01,2.842900E+01,& + & 6.166700E+01,7.335300E+02,1.064100E+04,8.110000E+04,2.726900E-07,& + & 1.844200E-06,6.587600E-06,1.836300E-05,4.587200E-05,1.250800E-04,& + & 4.391000E-04,3.365000E-03,1.685600E-01,1.742400E+00,4.696900E+00,& + & 1.211200E+01,2.916900E+01,6.414800E+01,1.176300E+02,2.186500E+02/ + data absb(:,1061:1080) / & + & 1.342200E-06,3.378200E-06,1.152200E-05,1.221600E-04,5.779800E-04,& + & 2.020900E-03,7.261000E-03,3.822500E-02,7.026600E-01,5.878900E+00,& + & 1.877800E+01,6.742600E+01,2.728200E+02,5.359300E+03,6.557900E+04,& + & 4.674100E+05,1.334600E-06,4.581700E-06,2.378500E-05,1.962000E-04,& + & 7.931400E-04,2.874900E-03,1.136600E-02,7.745200E-02,1.294900E+00,& + & 8.510500E+00,1.845600E+01,5.174700E+01,2.047500E+02,4.019500E+03,& + & 4.918400E+04,3.505600E+05,1.109600E-06,4.518600E-06,2.475700E-05,& + & 1.704700E-04,6.578900E-04,2.337800E-03,9.588300E-03,7.345400E-02,& + & 1.360500E+00,9.533900E+00,2.008400E+01,4.344600E+01,1.382200E+02,& + & 2.679700E+03,3.279000E+04,2.337100E+05,8.174000E-07,4.037100E-06,& + & 2.220300E-05,1.240700E-04,4.528900E-04,1.524400E-03,6.551800E-03,& + & 5.548800E-02,1.176000E+00,8.674900E+00,1.797100E+01,3.770500E+01,& + & 8.354100E+01,1.340400E+03,1.639500E+04,1.168500E+05,3.693300E-07,& + & 2.254400E-06,7.536600E-06,2.005700E-05,4.873700E-05,1.321100E-04,& + & 4.776800E-04,4.701000E-03,2.423300E-01,2.195100E+00,5.465800E+00,& + & 1.301600E+01,2.952100E+01,6.039000E+01,1.077500E+02,1.979500E+02,& + & 1.616900E-06,4.624600E-06,2.123100E-05,2.249000E-04,9.297700E-04,& + & 3.352200E-03,1.251700E-02,6.940500E-02,1.359300E+00,1.140000E+01,& + & 3.557400E+01,1.283900E+02,4.950900E+02,9.043900E+03,9.419000E+04,& + & 6.333800E+05,1.697300E-06,6.492700E-06,3.909900E-05,3.158100E-04,& + & 1.258200E-03,4.748200E-03,1.971400E-02,1.301900E-01,2.043900E+00,& + & 1.231800E+01,2.877700E+01,9.645200E+01,3.714300E+02,6.783000E+03,& + & 7.064300E+04,4.750400E+05,1.445400E-06,6.352900E-06,3.835500E-05,& + & 2.603200E-04,1.007200E-03,3.773600E-03,1.665700E-02,1.238600E-01,& + & 2.079000E+00,1.331100E+01,2.756800E+01,6.821800E+01,2.477900E+02,& + & 4.522100E+03,4.709500E+04,3.166900E+05,1.086600E-06,5.554800E-06,& + & 3.240400E-05,1.789200E-04,6.601900E-04,2.365400E-03,1.117100E-02,& + & 9.437000E-02,1.749000E+00,1.178800E+01,2.402100E+01,4.873200E+01,& + & 1.292500E+02,2.261200E+03,2.354800E+04,1.583500E+05,4.742900E-07,& + & 2.655800E-06,8.480100E-06,2.163400E-05,5.142500E-05,1.387000E-04,& + & 5.153500E-04,6.760400E-03,3.310800E-01,2.653000E+00,6.161700E+00,& + & 1.374800E+01,2.935500E+01,5.670200E+01,9.919600E+01,1.805300E+02,& + & 2.087100E-06,7.012500E-06,3.911500E-05,3.703200E-04,1.453300E-03,& + & 5.318700E-03,2.072700E-02,1.227500E-01,2.495900E+00,2.125800E+01,& + & 6.411400E+01,2.261200E+02,8.476400E+02,1.418400E+04,1.279800E+05,& + & 8.169600E+05,2.258700E-06,9.631900E-06,6.359400E-05,4.826600E-04,& + & 1.948400E-03,7.568600E-03,3.290500E-02,2.097600E-01,3.122100E+00,& + & 1.815500E+01,4.867400E+01,1.697300E+02,6.358300E+02,1.063800E+04,& + & 9.598300E+04,6.127200E+05,1.943200E-06,9.139300E-06,5.850400E-05,& + & 3.839800E-04,1.513500E-03,5.948000E-03,2.818100E-02,1.983600E-01,& + & 3.089400E+00,1.829400E+01,3.811300E+01,1.141500E+02,4.240200E+02,& + & 7.092000E+03,6.398900E+04,4.084800E+05,1.459200E-06,7.681300E-06,& + & 4.639800E-05,2.525100E-04,9.492700E-04,3.610600E-03,1.890800E-02,& + & 1.511800E-01,2.523500E+00,1.553200E+01,3.111500E+01,6.629600E+01,& + & 2.129900E+02,3.546200E+03,3.199500E+04,2.042400E+05,5.840600E-07,& + & 3.037200E-06,9.377800E-06,2.310800E-05,5.396500E-05,1.447800E-04,& + & 5.548600E-04,9.923700E-03,4.336700E-01,3.099000E+00,6.823600E+00,& + & 1.420000E+01,2.901300E+01,5.331900E+01,9.057000E+01,1.655400E+02,& + & 9.309800E-07,1.960400E-06,4.125500E-06,1.818700E-05,1.262400E-04,& + & 4.210100E-04,1.424500E-03,6.595300E-03,1.056400E-01,9.141700E-01,& + & 2.872800E+00,1.028900E+01,4.691400E+01,1.067600E+03,2.061100E+04,& + & 1.748500E+05,8.037400E-07,2.192900E-06,7.136400E-06,4.578000E-05,& + & 1.994500E-04,6.633200E-04,2.374900E-03,1.553200E-02,3.596800E-01,& + & 2.967600E+00,6.688900E+00,1.529600E+01,4.078200E+01,8.007800E+02,& + & 1.545900E+04,1.311400E+05,6.066200E-07,1.992000E-06,7.780800E-06,& + & 4.670000E-05,1.852600E-04,5.967200E-04,2.123600E-03,1.469700E-02,& + & 4.006200E-01,3.531000E+00,8.032800E+00,1.872900E+01,4.501500E+01,& + & 5.396100E+02,1.030600E+04,8.742400E+04,3.878000E-07,1.679700E-06,& + & 7.548200E-06,4.003500E-05,1.471300E-04,4.486000E-04,1.604900E-03,& + & 1.136900E-02,3.625000E-01,3.343700E+00,7.955700E+00,1.918200E+01,& + & 4.795200E+01,2.956600E+02,5.153000E+03,4.371200E+04,1.339500E-07,& + & 1.079700E-06,4.368100E-06,1.307300E-05,3.436700E-05,9.458700E-05,& + & 3.213000E-04,1.952300E-03,9.409300E-02,1.179700E+00,3.598900E+00,& + & 1.052800E+01,2.818600E+01,6.863000E+01,1.332700E+02,2.529600E+02/ + data absb(:,1081:1100) / & + & 9.485300E-07,2.135100E-06,5.060300E-06,3.839100E-05,2.342500E-04,& + & 7.846600E-04,2.738100E-03,1.375800E-02,2.377800E-01,2.054100E+00,& + & 6.687400E+00,2.444000E+01,1.066100E+02,2.300900E+03,3.596100E+04,& + & 2.808400E+05,8.697900E-07,2.617000E-06,1.041900E-05,8.047200E-05,& + & 3.403400E-04,1.175200E-03,4.479900E-03,3.149900E-02,6.307600E-01,& + & 4.774400E+00,1.060500E+01,2.376100E+01,8.102700E+01,1.725800E+03,& + & 2.697000E+04,2.106300E+05,6.882400E-07,2.499800E-06,1.146200E-05,& + & 7.624300E-05,2.985500E-04,1.002900E-03,3.871800E-03,2.977000E-02,& + & 6.935300E-01,5.613000E+00,1.215600E+01,2.708300E+01,6.493400E+01,& + & 1.150700E+03,1.798000E+04,1.404200E+05,4.749300E-07,2.213700E-06,& + & 1.097400E-05,6.075700E-05,2.210800E-04,7.031800E-04,2.779800E-03,& + & 2.252500E-02,6.219200E-01,5.230300E+00,1.159700E+01,2.566800E+01,& + & 5.731300E+01,5.865500E+02,8.990200E+03,7.020800E+04,1.997800E-07,& + & 1.402200E-06,5.146400E-06,1.458200E-05,3.688500E-05,1.011200E-04,& + & 3.558700E-04,2.693100E-03,1.469100E-01,1.599700E+00,4.424700E+00,& + & 1.178600E+01,2.900800E+01,6.529400E+01,1.211800E+02,2.263400E+02,& + & 1.038300E-06,2.531700E-06,7.819400E-06,8.042400E-05,4.020100E-04,& + & 1.399900E-03,5.025900E-03,2.673300E-02,5.028900E-01,4.298800E+00,& + & 1.422600E+01,5.239700E+01,2.179000E+02,4.391300E+03,5.690200E+04,& + & 4.139400E+05,1.013600E-06,3.375400E-06,1.663100E-05,1.372800E-04,& + & 5.631200E-04,2.043200E-03,8.167400E-03,5.840000E-02,1.044000E+00,& + & 7.223600E+00,1.590800E+01,4.123800E+01,1.635600E+02,3.293500E+03,& + & 4.267600E+04,3.104600E+05,8.352700E-07,3.323600E-06,1.761900E-05,& + & 1.215400E-04,4.725700E-04,1.673900E-03,6.945000E-03,5.579400E-02,& + & 1.121200E+00,8.299400E+00,1.766700E+01,3.797900E+01,1.122300E+02,& + & 2.195800E+03,2.845100E+04,2.069700E+05,6.094900E-07,2.984000E-06,& + & 1.611200E-05,9.028400E-05,3.306900E-04,1.105300E-03,4.800400E-03,& + & 4.237800E-02,9.895700E-01,7.657400E+00,1.610400E+01,3.425400E+01,& + & 7.395100E+01,1.100000E+03,1.422700E+04,1.034700E+05,2.759200E-07,& + & 1.737200E-06,5.917400E-06,1.600600E-05,3.925300E-05,1.070900E-04,& + & 3.886200E-04,3.807700E-03,2.156400E-01,2.043500E+00,5.204200E+00,& + & 1.275300E+01,2.946000E+01,6.170000E+01,1.108300E+02,2.043100E+02,& + & 1.221000E-06,3.338700E-06,1.411900E-05,1.535000E-04,6.554500E-04,& + & 2.363500E-03,8.843200E-03,4.967600E-02,1.004700E+00,8.590300E+00,& + & 2.794500E+01,1.029900E+02,4.058500E+02,7.610800E+03,8.342600E+04,& + & 5.711800E+05,1.265200E-06,4.686200E-06,2.730800E-05,2.243300E-04,& + & 9.028000E-04,3.432900E-03,1.448900E-02,1.008100E-01,1.673100E+00,& + & 1.053900E+01,2.398900E+01,7.759800E+01,3.045100E+02,5.708100E+03,& + & 6.256900E+04,4.283800E+05,1.073000E-06,4.620200E-06,2.737500E-05,& + & 1.875000E-04,7.295500E-04,2.737200E-03,1.230700E-02,9.678300E-02,& + & 1.738800E+00,1.168700E+01,2.462600E+01,5.746800E+01,2.032500E+02,& + & 3.805500E+03,4.171300E+04,2.855900E+05,8.051900E-07,4.088200E-06,& + & 2.360800E-05,1.310900E-04,4.851100E-04,1.731800E-03,8.307100E-03,& + & 7.432700E-02,1.494800E+00,1.057200E+01,2.173500E+01,4.451900E+01,& + & 1.095300E+02,1.902800E+03,2.085600E+04,1.427900E+05,3.600100E-07,& + & 2.067900E-06,6.694600E-06,1.730500E-05,4.152100E-05,1.125800E-04,& + & 4.206400E-04,5.558700E-03,2.994700E-01,2.500500E+00,5.939300E+00,& + & 1.352600E+01,2.945500E+01,5.798200E+01,1.018700E+02,1.859200E+02,& + & 1.544300E-06,4.923400E-06,2.620800E-05,2.603100E-04,1.037200E-03,& + & 3.806900E-03,1.491000E-02,8.971100E-02,1.897600E+00,1.650600E+01,& + & 5.170700E+01,1.865000E+02,7.065900E+02,1.220700E+04,1.152300E+05,& + & 7.475900E+05,1.663000E-06,6.872400E-06,4.463700E-05,3.485300E-04,& + & 1.412000E-03,5.563700E-03,2.477900E-02,1.654400E-01,2.596900E+00,& + & 1.533100E+01,3.977500E+01,1.400200E+02,5.300400E+02,9.155400E+03,& + & 8.642400E+04,5.606900E+05,1.430200E-06,6.610800E-06,4.192300E-05,& + & 2.799400E-04,1.105100E-03,4.369600E-03,2.131000E-02,1.584400E-01,& + & 2.617900E+00,1.617400E+01,3.343100E+01,9.511300E+01,3.534900E+02,& + & 6.103700E+03,5.761600E+04,3.737900E+05,1.078900E-06,5.645900E-06,& + & 3.398500E-05,1.865300E-04,7.013500E-04,2.670200E-03,1.433700E-02,& + & 1.219500E-01,2.183200E+00,1.403000E+01,2.844200E+01,5.881800E+01,& + & 1.788300E+02,3.052000E+03,2.880800E+04,1.869000E+05,4.487700E-07,& + & 2.385400E-06,7.442900E-06,1.852600E-05,4.363100E-05,1.177300E-04,& + & 4.536000E-04,8.318500E-03,3.980300E-01,2.953100E+00,6.597900E+00,& + & 1.406200E+01,2.921300E+01,5.426900E+01,9.377100E+01,1.702000E+02/ + data absb(:,1101:1120) / & + & 7.586900E-07,1.564900E-06,3.249300E-06,1.206900E-05,8.282500E-05,& + & 2.807600E-04,9.347100E-04,4.282000E-03,6.940400E-02,6.088700E-01,& + & 1.942900E+00,7.229600E+00,3.423000E+01,7.977300E+02,1.661000E+04,& + & 1.452200E+05,6.443300E-07,1.704700E-06,5.297100E-06,3.151100E-05,& + & 1.382600E-04,4.564100E-04,1.620900E-03,1.072200E-02,2.749000E-01,& + & 2.403000E+00,5.568600E+00,1.301800E+01,3.375800E+01,5.986100E+02,& + & 1.245700E+04,1.089100E+05,4.791300E-07,1.525000E-06,5.699300E-06,& + & 3.281500E-05,1.310500E-04,4.181500E-04,1.475100E-03,1.025800E-02,& + & 3.119000E-01,2.906500E+00,6.840500E+00,1.642600E+01,4.116400E+01,& + & 4.082600E+02,8.304900E+03,7.260700E+04,2.990800E-07,1.261300E-06,& + & 5.511700E-06,2.878300E-05,1.064800E-04,3.214200E-04,1.141100E-03,& + & 8.079600E-03,2.869300E-01,2.797100E+00,6.915100E+00,1.743400E+01,& + & 4.506800E+01,2.357400E+02,4.152600E+03,3.630300E+04,9.455900E-08,& + & 8.029400E-07,3.372400E-06,1.031000E-05,2.754100E-05,7.611500E-05,& + & 2.583800E-04,1.542800E-03,7.917400E-02,1.049500E+00,3.322600E+00,& + & 1.006000E+01,2.782900E+01,6.965600E+01,1.376900E+02,2.628000E+02,& + & 7.568000E-07,1.668500E-06,3.748800E-06,2.455100E-05,1.584800E-04,& + & 5.289500E-04,1.843600E-03,9.254400E-03,1.627500E-01,1.428100E+00,& + & 4.772400E+00,1.807900E+01,8.124900E+01,1.800500E+03,3.008900E+04,& + & 2.409800E+05,6.815400E-07,1.990800E-06,7.457100E-06,5.541600E-05,& + & 2.376500E-04,8.177800E-04,3.123300E-03,2.270400E-02,4.971400E-01,& + & 3.978200E+00,8.979100E+00,2.022200E+01,6.300700E+01,1.350500E+03,& + & 2.256700E+04,1.807300E+05,5.314000E-07,1.880100E-06,8.248000E-06,& + & 5.368800E-05,2.118000E-04,7.077100E-04,2.734400E-03,2.159800E-02,& + & 5.571700E-01,4.765600E+00,1.054500E+01,2.385600E+01,5.606100E+01,& + & 9.014600E+02,1.504400E+04,1.204900E+05,3.595500E-07,1.650200E-06,& + & 7.973700E-06,4.379500E-05,1.600600E-04,5.061600E-04,1.998600E-03,& + & 1.646800E-02,5.087500E-01,4.496500E+00,1.024000E+01,2.317900E+01,& + & 5.376100E+01,4.663800E+02,7.522600E+03,6.024200E+04,1.450400E-07,& + & 1.061300E-06,4.010500E-06,1.156300E-05,2.964600E-05,8.171600E-05,& + & 2.878000E-04,2.144100E-03,1.271300E-01,1.456100E+00,4.152700E+00,& + & 1.142200E+01,2.881100E+01,6.642000E+01,1.249000E+02,2.345000E+02,& + & 8.095800E-07,1.917800E-06,5.391400E-06,5.237200E-05,2.780200E-04,& + & 9.633400E-04,3.450200E-03,1.852100E-02,3.562000E-01,3.105400E+00,& + & 1.064100E+01,4.032800E+01,1.722300E+02,3.562900E+03,4.897900E+04,& + & 3.641400E+05,7.751200E-07,2.506600E-06,1.165800E-05,9.563400E-05,& + & 3.980200E-04,1.442200E-03,5.821300E-03,4.368600E-02,8.399800E-01,& + & 6.123800E+00,1.373500E+01,3.338900E+01,1.293100E+02,2.672200E+03,& + & 3.673400E+04,2.731100E+05,6.325200E-07,2.455600E-06,1.255500E-05,& + & 8.637900E-05,3.381500E-04,1.191700E-03,4.993400E-03,4.198300E-02,& + & 9.211500E-01,7.212200E+00,1.550400E+01,3.371900E+01,9.141100E+01,& + & 1.781600E+03,2.448900E+04,1.820700E+05,4.556700E-07,2.210100E-06,& + & 1.168500E-05,6.554700E-05,2.408500E-04,7.983400E-04,3.495700E-03,& + & 3.204400E-02,8.299000E-01,6.720900E+00,1.442000E+01,3.104200E+01,& + & 6.660600E+01,8.953400E+02,1.224500E+04,9.103400E+04,2.050100E-07,& + & 1.332900E-06,4.642900E-06,1.274800E-05,3.160400E-05,8.675700E-05,& + & 3.156500E-04,3.066400E-03,1.906300E-01,1.893400E+00,4.965700E+00,& + & 1.246900E+01,2.933500E+01,6.294800E+01,1.140500E+02,2.110300E+02,& + & 9.295300E-07,2.440700E-06,9.402800E-06,1.035500E-04,4.601400E-04,& + & 1.657100E-03,6.202000E-03,3.525000E-02,7.351500E-01,6.405600E+00,& + & 2.177600E+01,8.186100E+01,3.302600E+02,6.355300E+03,7.346200E+04,& + & 5.123100E+05,9.481500E-07,3.402500E-06,1.906700E-05,1.585100E-04,& + & 6.452100E-04,2.465100E-03,1.056200E-02,7.758600E-02,1.365600E+00,& + & 9.032500E+00,2.032000E+01,6.216100E+01,2.478300E+02,4.766500E+03,& + & 5.509600E+04,3.842300E+05,7.993200E-07,3.372200E-06,1.951600E-05,& + & 1.345800E-04,5.269600E-04,1.974600E-03,9.021200E-03,7.514300E-02,& + & 1.451500E+00,1.029400E+01,2.192900E+01,4.903100E+01,1.659800E+02,& + & 3.177700E+03,3.673100E+04,2.561500E+05,5.975900E-07,3.012700E-06,& + & 1.717500E-05,9.585500E-05,3.555600E-04,1.262200E-03,6.132600E-03,& + & 5.807000E-02,1.275000E+00,9.459600E+00,1.961500E+01,4.072700E+01,& + & 9.419300E+01,1.589000E+03,1.836500E+04,1.280700E+05,2.720800E-07,& + & 1.604500E-06,5.274900E-06,1.383800E-05,3.350200E-05,9.133200E-05,& + & 3.428300E-04,4.537100E-03,2.698100E-01,2.352300E+00,5.696600E+00,& + & 1.331300E+01,2.950000E+01,5.922800E+01,1.046500E+02,1.916000E+02/ + data absb(:,1121:1140) / & + & 1.149100E-06,3.480200E-06,1.749100E-05,1.815600E-04,7.367600E-04,& + & 2.711900E-03,1.065600E-02,6.508400E-02,1.430500E+00,1.271900E+01,& + & 4.138300E+01,1.526900E+02,5.863600E+02,1.043700E+04,1.032600E+05,& + & 6.810600E+05,1.228800E-06,4.917500E-06,3.126600E-05,2.504000E-04,& + & 1.019200E-03,4.062800E-03,1.852500E-02,1.300400E-01,2.154700E+00,& + & 1.316700E+01,3.261700E+01,1.146600E+02,4.398700E+02,7.828100E+03,& + & 7.744300E+04,5.107900E+05,1.055200E-06,4.787000E-06,3.000200E-05,& + & 2.033000E-04,8.041800E-04,3.192600E-03,1.599500E-02,1.259400E-01,& + & 2.215200E+00,1.431200E+01,2.977100E+01,7.920000E+01,2.934000E+02,& + & 5.218800E+03,5.162800E+04,3.405300E+05,7.984400E-07,4.151400E-06,& + & 2.485600E-05,1.374000E-04,5.169000E-04,1.966100E-03,1.078800E-02,& + & 9.790200E-02,1.886900E+00,1.268200E+01,2.593200E+01,5.280600E+01,& + & 1.503100E+02,2.609500E+03,2.581400E+04,1.702600E+05,3.435500E-07,& + & 1.868800E-06,5.896500E-06,1.485400E-05,3.524800E-05,9.568400E-05,& + & 3.704300E-04,6.932900E-03,3.636100E-01,2.802900E+00,6.359700E+00,& + & 1.392300E+01,2.933500E+01,5.550200E+01,9.648000E+01,1.750900E+02,& + & 1.638800E-07,3.318800E-07,6.821000E-07,2.192300E-06,1.441300E-05,& + & 4.972000E-05,1.622400E-04,7.336000E-04,1.201800E-02,1.070700E-01,& + & 3.449800E-01,1.337800E+00,6.593300E+00,1.569100E+02,3.520100E+03,& + & 3.173000E+04,1.680400E-07,4.331300E-07,1.300600E-06,7.166700E-06,& + & 3.141500E-05,1.026900E-04,3.608000E-04,2.410100E-03,6.881900E-02,& + & 6.395300E-01,1.526700E+00,3.652400E+00,9.489300E+00,1.443000E+02,& + & 3.227400E+03,2.909200E+04,1.588100E-07,4.929400E-07,1.780100E-06,& + & 9.799000E-06,3.920600E-05,1.236600E-04,4.316600E-04,3.010700E-03,& + & 1.025300E-01,1.012700E+00,2.469000E+00,6.166100E+00,1.608900E+01,& + & 1.294500E+02,2.767200E+03,2.494400E+04,1.362700E-07,5.629100E-07,& + & 2.408800E-06,1.233400E-05,4.579300E-05,1.366300E-04,4.812300E-04,& + & 3.398200E-03,1.345400E-01,1.389600E+00,3.584900E+00,9.477700E+00,& + & 2.530000E+01,1.129600E+02,1.938200E+03,1.747000E+04,6.647900E-08,& + & 5.961500E-07,2.601100E-06,8.133100E-06,2.207000E-05,6.127300E-05,& + & 2.076700E-04,1.219300E-03,6.640900E-02,9.311400E-01,3.071300E+00,& + & 9.588000E+00,2.742500E+01,7.058300E+01,1.421100E+02,2.726900E+02,& + & 1.604200E-07,3.467000E-07,7.523300E-07,4.201400E-06,2.831900E-05,& + & 9.447300E-05,3.283500E-04,1.643400E-03,2.937600E-02,2.619500E-01,& + & 8.964700E-01,3.525700E+00,1.636000E+01,3.714600E+02,6.631500E+03,& + & 5.445300E+04,1.740900E-07,4.969600E-07,1.769500E-06,1.251400E-05,& + & 5.416600E-05,1.855300E-04,7.085100E-04,5.311000E-03,1.286900E-01,& + & 1.090200E+00,2.501800E+00,5.740800E+00,1.622400E+01,3.406100E+02,& + & 6.080100E+03,4.992500E+04,1.727400E-07,5.993000E-07,2.529300E-06,& + & 1.598000E-05,6.329500E-05,2.100700E-04,8.116000E-04,6.556900E-03,& + & 1.893200E-01,1.710000E+00,3.879000E+00,8.922100E+00,2.095700E+01,& + & 2.934300E+02,5.213200E+03,4.280600E+04,1.610600E-07,7.331400E-07,& + & 3.461200E-06,1.873500E-05,6.868000E-05,2.154800E-04,8.489300E-04,& + & 7.085700E-03,2.468800E-01,2.294900E+00,5.369700E+00,1.250300E+01,& + & 3.018200E+01,2.180100E+02,3.651400E+03,2.998100E+04,1.051100E-07,& + & 8.025300E-07,3.126000E-06,9.166100E-06,2.382300E-05,6.599200E-05,& + & 2.326000E-04,1.704900E-03,1.098800E-01,1.324100E+00,3.902400E+00,& + & 1.103000E+01,2.858300E+01,6.746000E+01,1.286300E+02,2.426800E+02,& + & 1.679200E-07,3.880600E-07,1.007700E-06,9.034900E-06,5.085100E-05,& + & 1.753000E-04,6.265000E-04,3.388700E-03,6.667800E-02,5.914700E-01,& + & 2.096300E+00,8.210100E+00,3.595700E+01,7.628200E+02,1.111700E+04,& + & 8.444700E+04,1.937700E-07,6.123700E-07,2.698100E-06,2.175100E-05,& + & 9.164300E-05,3.310300E-04,1.349300E-03,1.064300E-02,2.220000E-01,& + & 1.710900E+00,3.896600E+00,9.036800E+00,3.312300E+01,6.994200E+02,& + & 1.019300E+04,7.742500E+04,2.019300E-07,7.701900E-07,3.804000E-06,& + & 2.584700E-05,1.017200E-04,3.557500E-04,1.505700E-03,1.324400E-02,& + & 3.207100E-01,2.650300E+00,5.762800E+00,1.273300E+01,3.185300E+01,& + & 5.997400E+02,8.739500E+03,6.638500E+04,2.019300E-07,9.765400E-07,& + & 5.054500E-06,2.816200E-05,1.035800E-04,3.401000E-04,1.499900E-03,& + & 1.426300E-02,4.133200E-01,3.501000E+00,7.664700E+00,1.672300E+01,& + & 3.629100E+01,4.247800E+02,6.121200E+03,4.649500E+04,1.519100E-07,& + & 1.021600E-06,3.642700E-06,1.015400E-05,2.545000E-05,7.023900E-05,& + & 2.561700E-04,2.467000E-03,1.685200E-01,1.754400E+00,4.713700E+00,& + & 1.219700E+01,2.923300E+01,6.403000E+01,1.172200E+02,2.178100E+02/ + data absb(:,1141:1160) / & + & 1.886100E-07,4.783100E-07,1.678900E-06,1.840800E-05,8.553600E-05,& + & 3.072000E-04,1.150000E-03,6.611600E-03,1.421800E-01,1.260600E+00,& + & 4.477400E+00,1.721000E+01,7.107600E+01,1.401400E+03,1.705700E+04,& + & 1.211600E+05,2.323500E-07,8.133300E-07,4.376700E-06,3.646100E-05,& + & 1.499900E-04,5.746900E-04,2.503800E-03,1.949200E-02,3.662900E-01,& + & 2.552300E+00,5.749700E+00,1.623300E+01,6.521200E+01,1.284900E+03,& + & 1.563800E+04,1.110800E+05,2.511700E-07,1.044200E-06,5.892800E-06,& + & 4.057500E-05,1.596700E-04,5.960000E-04,2.771500E-03,2.451900E-02,& + & 5.130900E-01,3.843300E+00,8.249500E+00,1.791300E+01,5.674600E+01,& + & 1.101700E+03,1.340900E+04,9.524200E+04,2.630600E-07,1.324000E-06,& + & 7.432900E-06,4.137600E-05,1.536700E-04,5.408200E-04,2.663500E-03,& + & 2.673000E-02,6.469100E-01,5.013800E+00,1.050400E+01,2.210100E+01,& + & 4.869900E+01,7.720600E+02,9.391400E+03,6.670700E+04,2.053700E-07,& + & 1.244900E-06,4.154100E-06,1.106900E-05,2.701600E-05,7.414100E-05,& + & 2.792100E-04,3.703200E-03,2.430000E-01,2.201800E+00,5.471800E+00,& + & 1.307200E+01,2.947200E+01,6.050700E+01,1.074000E+02,1.972300E+02,& + & 2.279300E-07,6.589800E-07,3.103500E-06,3.339800E-05,1.384500E-04,& + & 5.110300E-04,2.012800E-03,1.247500E-02,2.850600E-01,2.587400E+00,& + & 8.767300E+00,3.303500E+01,1.289700E+02,2.356400E+03,2.441000E+04,& + & 1.636500E+05,2.968400E-07,1.155800E-06,7.170700E-06,5.842100E-05,& + & 2.389500E-04,9.624200E-04,4.500800E-03,3.343200E-02,5.855100E-01,& + & 3.737200E+00,8.866300E+00,3.035300E+01,1.182800E+02,2.160500E+03,& + & 2.238000E+04,1.500400E+05,3.282400E-07,1.468200E-06,9.073300E-06,& + & 6.187100E-05,2.450900E-04,9.748700E-04,5.024000E-03,4.213500E-02,& + & 7.922900E-01,5.368900E+00,1.131800E+01,2.785000E+01,1.014900E+02,& + & 1.852500E+03,1.918900E+04,1.286500E+05,3.501800E-07,1.817600E-06,& + & 1.078900E-05,5.962900E-05,2.241800E-04,8.497300E-04,4.764300E-03,& + & 4.639600E-02,9.681600E-01,6.813700E+00,1.399600E+01,2.845200E+01,& + & 7.451900E+01,1.297500E+03,1.344000E+04,9.010300E+04,2.629200E-07,& + & 1.461500E-06,4.667500E-06,1.191000E-05,2.848800E-05,7.774700E-05,& + & 3.024900E-04,5.774200E-03,3.319800E-01,2.661200E+00,6.153800E+00,& + & 1.376300E+01,2.940000E+01,5.676000E+01,9.888400E+01,1.799100E+02,& + & 1.576500E-07,3.171200E-07,6.500700E-07,1.989500E-06,1.276600E-05,& + & 4.431400E-05,1.437400E-04,6.532200E-04,1.097400E-02,9.929800E-02,& + & 3.268500E-01,1.326000E+00,6.745800E+00,1.626900E+02,3.769900E+03,& + & 3.442100E+04,1.561800E-07,4.153800E-07,1.293400E-06,7.014600E-06,& + & 2.993000E-05,9.697200E-05,3.416700E-04,2.389200E-03,7.767400E-02,& + & 7.666700E-01,1.875200E+00,4.599800E+00,1.202100E+01,1.437200E+02,& + & 3.291800E+03,3.005500E+04,1.395800E-07,4.587300E-07,1.726600E-06,& + & 9.266600E-06,3.634200E-05,1.129300E-04,3.974300E-04,2.872900E-03,& + & 1.117400E-01,1.164500E+00,2.923200E+00,7.588900E+00,2.017800E+01,& + & 1.260100E+02,2.625700E+03,2.397300E+04,1.100700E-07,4.947800E-07,& + & 2.183500E-06,1.081900E-05,3.954600E-05,1.158200E-04,4.147400E-04,& + & 2.991600E-03,1.348400E-01,1.461200E+00,3.932800E+00,1.071700E+01,& + & 2.939100E+01,1.104000E+02,1.634000E+03,1.491800E+04,5.073900E-08,& + & 4.673700E-07,2.073800E-06,6.553000E-06,1.792400E-05,4.994900E-05,& + & 1.701600E-04,1.015400E-03,6.087700E-02,8.854700E-01,2.967200E+00,& + & 9.403300E+00,2.723700E+01,7.095200E+01,1.439800E+02,2.769400E+02,& + & 1.532500E-07,3.286300E-07,7.064000E-07,3.710300E-06,2.530800E-05,& + & 8.470000E-05,2.946000E-04,1.492500E-03,2.757200E-02,2.496800E-01,& + & 8.801800E-01,3.609700E+00,1.710900E+01,3.933800E+02,7.221500E+03,& + & 5.993000E+04,1.621900E-07,4.797700E-07,1.764900E-06,1.198500E-05,& + & 5.088600E-05,1.735800E-04,6.732000E-04,5.394400E-03,1.472600E-01,& + & 1.322400E+00,3.063500E+00,7.091900E+00,1.818300E+01,3.435400E+02,& + & 6.305500E+03,5.232800E+04,1.534800E-07,5.661100E-07,2.459300E-06,& + & 1.479800E-05,5.755900E-05,1.888100E-04,7.444900E-04,6.352800E-03,& + & 2.094700E-01,1.980700E+00,4.580900E+00,1.065900E+01,2.527400E+01,& + & 2.783300E+02,5.029700E+03,4.174000E+04,1.330800E-07,6.549800E-07,& + & 3.122700E-06,1.611900E-05,5.813700E-05,1.791700E-04,7.218400E-04,& + & 6.270900E-03,2.511700E-01,2.424800E+00,5.803400E+00,1.389800E+01,& + & 3.444000E+01,1.940100E+02,3.129900E+03,2.597300E+04,8.107700E-08,& + & 6.339700E-07,2.502700E-06,7.392200E-06,1.935100E-05,5.385900E-05,& + & 1.907200E-04,1.437600E-03,1.023700E-01,1.265500E+00,3.804900E+00,& + & 1.084900E+01,2.851900E+01,6.787800E+01,1.301900E+02,2.461400E+02/ + data absb(:,1161:1175) / & + & 1.590000E-07,3.641800E-07,9.207700E-07,7.979500E-06,4.588600E-05,& + & 1.585600E-04,5.693600E-04,3.135200E-03,6.421800E-02,5.789700E-01,& + & 2.127800E+00,8.598700E+00,3.823300E+01,8.207300E+02,1.225800E+04,& + & 9.393400E+04,1.809900E-07,5.931800E-07,2.661200E-06,2.048100E-05,& + & 8.537100E-05,3.084800E-04,1.296200E-03,1.109500E-02,2.554200E-01,& + & 2.092100E+00,4.740100E+00,1.060700E+01,3.415800E+01,7.166800E+02,& + & 1.070300E+04,8.201900E+04,1.812100E-07,7.319100E-07,3.662500E-06,& + & 2.350400E-05,9.131400E-05,3.156200E-04,1.385900E-03,1.313600E-02,& + & 3.578900E-01,3.094100E+00,6.759100E+00,1.500600E+01,3.461900E+01,& + & 5.720800E+02,8.537700E+03,6.542300E+04,1.697900E-07,8.764800E-07,& + & 4.510300E-06,2.380800E-05,8.612900E-05,2.781500E-04,1.265900E-03,& + & 1.288400E-02,4.248700E-01,3.707300E+00,8.257300E+00,1.810200E+01,& + & 4.020400E+01,3.661600E+02,5.312800E+03,4.071100E+04,1.183100E-07,& + & 8.111900E-07,2.923100E-06,8.193100E-06,2.068100E-05,5.731000E-05,& + & 2.104400E-04,2.113200E-03,1.588500E-01,1.687800E+00,4.607600E+00,& + & 1.207000E+01,2.924000E+01,6.447300E+01,1.185600E+02,2.206600E+02,& + & 1.770100E-07,4.434700E-07,1.501300E-06,1.644600E-05,7.778300E-05,& + & 2.803200E-04,1.057900E-03,6.226500E-03,1.399800E-01,1.266000E+00,& + & 4.671200E+00,1.831200E+01,7.664700E+01,1.526700E+03,1.898600E+04,& + & 1.359500E+05,2.171400E-07,7.866400E-07,4.254100E-06,3.389100E-05,& + & 1.389700E-04,5.361500E-04,2.446700E-03,2.074800E-02,4.215900E-01,& + & 3.109400E+00,6.975600E+00,1.736800E+01,6.699800E+01,1.333100E+03,& + & 1.657800E+04,1.187100E+05,2.269300E-07,9.898900E-07,5.581600E-06,& + & 3.632900E-05,1.419200E-04,5.258700E-04,2.576100E-03,2.488500E-02,& + & 5.738200E-01,4.505100E+00,9.607900E+00,2.049200E+01,5.607300E+01,& + & 1.063400E+03,1.322400E+04,9.468700E+04,2.233500E-07,1.182700E-06,& + & 6.537300E-06,3.442600E-05,1.260800E-04,4.368800E-04,2.245600E-03,& + & 2.467000E-02,6.684600E-01,5.330800E+00,1.122400E+01,2.359300E+01,& + & 4.948900E+01,6.645600E+02,8.228800E+03,5.892000E+04,1.613700E-07,& + & 9.921800E-07,3.336500E-06,8.945300E-06,2.193700E-05,6.050700E-05,& + & 2.295900E-04,3.243500E-03,2.306900E-01,2.131600E+00,5.373300E+00,& + & 1.300900E+01,2.950900E+01,6.095300E+01,1.085500E+02,1.996200E+02,& + & 2.119800E-07,6.021500E-07,2.762900E-06,3.020200E-05,1.267100E-04,& + & 4.700800E-04,1.873300E-03,1.197100E-02,2.865300E-01,2.666500E+00,& + & 9.327100E+00,3.563400E+01,1.404300E+02,2.592400E+03,2.737900E+04,& + & 1.847900E+05,2.774900E-07,1.109000E-06,6.855100E-06,5.387400E-05,& + & 2.206000E-04,9.026100E-04,4.495900E-03,3.614000E-02,6.735000E-01,& + & 4.510100E+00,1.005600E+01,3.144900E+01,1.226800E+02,2.263700E+03,& + & 2.390600E+04,1.613500E+05,2.970300E-07,1.381300E-06,8.456800E-06,& + & 5.479900E-05,2.158600E-04,8.590800E-04,4.752300E-03,4.352300E-02,& + & 8.850700E-01,6.252000E+00,1.315500E+01,2.930500E+01,9.823000E+01,& + & 1.805700E+03,1.906900E+04,1.265000E+05,2.980300E-07,1.606400E-06,& + & 9.358300E-06,4.896000E-05,1.816000E-04,6.816700E-04,4.046300E-03,& + & 4.376500E-02,9.997400E-01,7.262700E+00,1.484000E+01,3.012200E+01,& + & 6.888900E+01,1.123700E+03,1.186600E+04,8.008900E+04,2.084000E-07,& + & 1.168400E-06,3.748300E-06,9.637400E-06,2.312200E-05,6.344700E-05,& + & 2.488900E-04,5.168500E-03,3.170100E-01,2.582400E+00,6.050300E+00,& + & 1.372300E+01,2.940200E+01,5.743400E+01,9.988400E+01,1.819500E+02/ + + data ka_mo3(:,:, 1) / & + & 9.310400E-03,4.282380E-02,1.126070E-01,2.355970E-01,5.307850E-01,& + & 6.148180E-01,7.413100E-01,4.873560E-01,5.561940E-01,8.341070E-01,& + & 8.313080E-01,4.132010E-01,4.668260E-01,5.676080E-01,1.512810E-01,& + & 1.029340E-01,1.112000E-02,4.836720E-02,1.145310E-01,2.279650E-01,& + & 5.334060E-01,6.101990E-01,7.387800E-01,4.867760E-01,5.561740E-01,& + & 8.328380E-01,8.315770E-01,4.128350E-01,4.665790E-01,5.677660E-01,& + & 1.514310E-01,1.029340E-01,1.216300E-02,5.243150E-02,1.139860E-01,& + & 2.259560E-01,5.398140E-01,6.029490E-01,7.338460E-01,4.861110E-01,& + & 5.559960E-01,8.311670E-01,8.315780E-01,4.130230E-01,4.669560E-01,& + & 5.674600E-01,1.512990E-01,1.029340E-01,1.262310E-02,5.651910E-02,& + & 1.137130E-01,2.283710E-01,5.390540E-01,6.050470E-01,7.212180E-01,& + & 4.855010E-01,5.558590E-01,8.290260E-01,8.312610E-01,4.133970E-01,& + & 4.664560E-01,5.679250E-01,1.512810E-01,1.029340E-01,1.333450E-02,& + & 6.031710E-02,1.123210E-01,2.425630E-01,5.292400E-01,6.035930E-01,& + & 7.105880E-01,4.836790E-01,5.545500E-01,8.262260E-01,8.315650E-01,& + & 4.130430E-01,4.668530E-01,5.675200E-01,1.512810E-01,1.029340E-01,& + & 1.432940E-02,6.510920E-02,1.141580E-01,2.540520E-01,5.217460E-01,& + & 6.039400E-01,6.981660E-01,4.721200E-01,5.535140E-01,8.332460E-01,& + & 8.176360E-01,4.131510E-01,4.668320E-01,5.675490E-01,1.512990E-01,& + & 1.029340E-01,1.482980E-02,7.096530E-02,1.210150E-01,2.540610E-01,& + & 5.267520E-01,6.062420E-01,6.769740E-01,4.586830E-01,5.498650E-01,& + & 8.456930E-01,7.952470E-01,4.130520E-01,4.666790E-01,5.677270E-01,& + & 1.512990E-01,1.029340E-01,1.417920E-02,7.691930E-02,1.339520E-01,& + & 2.724820E-01,5.235810E-01,6.119290E-01,6.300610E-01,4.560910E-01,& + & 5.254350E-01,8.321390E-01,7.630690E-01,4.131520E-01,4.669820E-01,& + & 5.677950E-01,1.512810E-01,1.029340E-01,8.827840E-03,4.579620E-02,& + & 1.010030E-01,1.934140E-01,3.803930E-01,6.211890E-01,8.976330E-01,& + & 9.112130E-01,3.482280E-01,2.342580E-01,2.032550E-01,1.310080E-01,& + & 1.137090E-01,1.329570E-01,2.441800E-01,3.915310E-01 / + data ka_mo3(:,:, 2) / 1.012860E-02,& + & 4.510150E-02,1.160470E-01,2.379750E-01,5.304770E-01,6.106640E-01,& + & 7.301080E-01,4.807430E-01,5.485950E-01,8.272760E-01,8.221530E-01,& + & 4.052580E-01,4.714370E-01,5.557960E-01,1.534390E-01,1.043690E-01,& + & 1.204610E-02,5.072190E-02,1.178500E-01,2.303340E-01,5.329970E-01,& + & 6.061430E-01,7.276310E-01,4.801570E-01,5.485750E-01,8.260220E-01,& + & 8.224000E-01,4.048970E-01,4.711990E-01,5.559480E-01,1.535890E-01,& + & 1.043690E-01,1.314010E-02,5.486500E-02,1.172220E-01,2.282770E-01,& + & 5.392340E-01,5.990570E-01,7.227990E-01,4.794960E-01,5.484030E-01,& + & 8.243610E-01,8.224220E-01,4.050790E-01,4.715670E-01,5.556470E-01,& + & 1.534610E-01,1.043690E-01,1.362430E-02,5.903830E-02,1.168920E-01,& + & 2.305950E-01,5.383480E-01,6.011550E-01,7.104920E-01,4.788800E-01,& + & 5.482710E-01,8.222460E-01,8.221110E-01,4.054370E-01,4.710800E-01,& + & 5.561070E-01,1.534390E-01,1.043690E-01,1.437360E-02,6.291140E-02,& + & 1.154130E-01,2.446200E-01,5.284750E-01,5.998670E-01,7.000140E-01,& + & 4.771400E-01,5.469210E-01,8.194710E-01,8.224040E-01,4.051060E-01,& + & 4.714560E-01,5.557330E-01,1.534390E-01,1.043690E-01,1.541330E-02,& + & 6.778270E-02,1.172180E-01,2.560170E-01,5.208150E-01,6.002240E-01,& + & 6.877060E-01,4.658340E-01,5.458830E-01,8.265100E-01,8.084970E-01,& + & 4.052020E-01,4.714480E-01,5.557490E-01,1.534610E-01,1.043690E-01,& + & 1.595030E-02,7.373780E-02,1.239890E-01,2.559820E-01,5.255500E-01,& + & 6.022570E-01,6.670340E-01,4.527580E-01,5.423030E-01,8.389670E-01,& + & 7.861400E-01,4.051090E-01,4.712990E-01,5.559090E-01,1.534610E-01,& + & 1.043690E-01,1.531410E-02,7.979260E-02,1.369390E-01,2.739160E-01,& + & 5.225130E-01,6.071730E-01,6.210170E-01,4.504810E-01,5.184370E-01,& + & 8.255650E-01,7.540060E-01,4.052090E-01,4.715980E-01,5.559650E-01,& + & 1.534390E-01,1.043690E-01,9.483210E-03,4.760270E-02,1.037130E-01,& + & 1.954980E-01,3.806800E-01,6.173380E-01,8.873070E-01,9.032700E-01,& + & 3.459490E-01,2.352470E-01,2.030040E-01,1.306070E-01,1.131410E-01,& + & 1.317370E-01,2.356860E-01,3.789780E-01 / + data ka_mo3(:,:, 3) / 1.101860E-02,4.750030E-02,& + & 1.195910E-01,2.403760E-01,5.301690E-01,6.065390E-01,7.190750E-01,& + & 4.742200E-01,5.411000E-01,8.205010E-01,8.130980E-01,3.974680E-01,& + & 4.760940E-01,5.442300E-01,1.556280E-01,1.058250E-01,1.304930E-02,& + & 5.319110E-02,1.212660E-01,2.327280E-01,5.325870E-01,6.021140E-01,& + & 7.166510E-01,4.736270E-01,5.410790E-01,8.192630E-01,8.133240E-01,& + & 3.971120E-01,4.758650E-01,5.443760E-01,1.557780E-01,1.058250E-01,& + & 1.419560E-02,5.741150E-02,1.205510E-01,2.306220E-01,5.386550E-01,& + & 5.951900E-01,7.119190E-01,4.729720E-01,5.409130E-01,8.176110E-01,& + & 8.133680E-01,3.972890E-01,4.762240E-01,5.440800E-01,1.556540E-01,& + & 1.058250E-01,1.470490E-02,6.166990E-02,1.201600E-01,2.328400E-01,& + & 5.376430E-01,5.972890E-01,6.999260E-01,4.723500E-01,5.407860E-01,& + & 8.155210E-01,8.130620E-01,3.976300E-01,4.757500E-01,5.445360E-01,& + & 1.556280E-01,1.058250E-01,1.549380E-02,6.561720E-02,1.185910E-01,& + & 2.466950E-01,5.277110E-01,5.961640E-01,6.895960E-01,4.706910E-01,& + & 5.393970E-01,8.127710E-01,8.133440E-01,3.973210E-01,4.761040E-01,& + & 5.441900E-01,1.556280E-01,1.058250E-01,1.657910E-02,7.056600E-02,& + & 1.203600E-01,2.579970E-01,5.198860E-01,5.965310E-01,6.774020E-01,& + & 4.596300E-01,5.383580E-01,8.198280E-01,7.994610E-01,3.974060E-01,& + & 4.761100E-01,5.441950E-01,1.556540E-01,1.058250E-01,1.715540E-02,& + & 7.661870E-02,1.270360E-01,2.579170E-01,5.243520E-01,5.982990E-01,& + & 6.572400E-01,4.469090E-01,5.348460E-01,8.322950E-01,7.771370E-01,& + & 3.973190E-01,4.759650E-01,5.443370E-01,1.556540E-01,1.058250E-01,& + & 1.653980E-02,8.277330E-02,1.399920E-01,2.753580E-01,5.214460E-01,& + & 6.024540E-01,6.121020E-01,4.449400E-01,5.115330E-01,8.190440E-01,& + & 7.450510E-01,3.974180E-01,4.762600E-01,5.443810E-01,1.556280E-01,& + & 1.058250E-01,1.018720E-02,4.948050E-02,1.064950E-01,1.976050E-01,& + & 3.809670E-01,6.135110E-01,8.771000E-01,8.953960E-01,3.436860E-01,& + & 2.362390E-01,2.027530E-01,1.302080E-01,1.125760E-01,1.305280E-01,& + & 2.274870E-01,3.668270E-01 / + data ka_mo3(:,:, 4) / 1.198690E-02,5.002660E-02,1.232440E-01,& + & 2.428020E-01,5.298610E-01,6.024410E-01,7.082090E-01,4.677850E-01,& + & 5.337070E-01,8.137810E-01,8.041430E-01,3.898280E-01,4.807980E-01,& + & 5.329040E-01,1.578480E-01,1.073000E-01,1.413600E-02,5.578060E-02,& + & 1.247810E-01,2.351460E-01,5.321780E-01,5.981120E-01,7.058360E-01,& + & 4.671870E-01,5.336870E-01,8.125580E-01,8.043490E-01,3.894770E-01,& + & 4.805770E-01,5.330450E-01,1.579980E-01,1.073000E-01,1.533590E-02,& + & 6.007620E-02,1.239740E-01,2.329910E-01,5.380770E-01,5.913480E-01,& + & 7.012030E-01,4.665360E-01,5.335260E-01,8.109160E-01,8.044130E-01,& + & 3.896480E-01,4.809270E-01,5.327540E-01,1.578780E-01,1.073000E-01,& + & 1.587130E-02,6.441870E-02,1.235190E-01,2.351070E-01,5.369380E-01,& + & 5.934480E-01,6.895170E-01,4.659080E-01,5.334040E-01,8.088510E-01,& + & 8.041120E-01,3.899730E-01,4.804670E-01,5.332050E-01,1.578480E-01,& + & 1.073000E-01,1.670120E-02,6.843940E-02,1.218560E-01,2.487870E-01,& + & 5.269490E-01,5.924830E-01,6.793340E-01,4.643280E-01,5.319760E-01,& + & 8.061260E-01,8.043840E-01,3.896860E-01,4.807980E-01,5.328870E-01,& + & 1.578480E-01,1.073000E-01,1.783310E-02,7.346350E-02,1.235860E-01,& + & 2.599920E-01,5.189580E-01,5.928610E-01,6.672530E-01,4.535100E-01,& + & 5.309370E-01,8.132000E-01,7.905250E-01,3.897600E-01,4.808170E-01,& + & 5.328800E-01,1.578780E-01,1.073000E-01,1.845170E-02,7.961210E-02,& + & 1.301570E-01,2.598670E-01,5.231560E-01,5.943670E-01,6.475900E-01,& + & 4.411350E-01,5.274910E-01,8.256750E-01,7.682380E-01,3.896780E-01,& + & 4.806770E-01,5.330050E-01,1.578780E-01,1.073000E-01,1.786370E-02,& + & 8.586530E-02,1.431140E-01,2.768070E-01,5.203820E-01,5.977730E-01,& + & 6.033160E-01,4.394670E-01,5.047210E-01,8.125740E-01,7.362020E-01,& + & 3.897780E-01,4.809670E-01,5.330390E-01,1.578480E-01,1.073000E-01,& + & 1.094350E-02,5.143230E-02,1.093520E-01,1.997340E-01,3.812540E-01,& + & 6.097070E-01,8.670100E-01,8.875910E-01,3.414370E-01,2.372360E-01,& + & 2.025020E-01,1.298100E-01,1.120130E-01,1.293300E-01,2.195740E-01,& + & 3.550670E-01 / + data ka_mo3(:,:, 5) / & + & 1.304030E-02,5.268730E-02,1.270090E-01,2.452530E-01,& + & 5.295530E-01,5.983720E-01,6.975070E-01,4.614370E-01,5.264150E-01,& + & 8.071170E-01,7.952870E-01,3.823340E-01,4.855470E-01,5.218140E-01,& + & 1.601000E-01,1.087970E-01,1.531330E-02,5.849620E-02,1.283970E-01,& + & 2.375900E-01,5.317690E-01,5.941360E-01,6.951850E-01,4.608340E-01,& + & 5.263950E-01,8.059080E-01,7.954720E-01,3.819880E-01,4.853360E-01,& + & 5.219500E-01,1.602500E-01,1.087970E-01,1.656790E-02,6.286450E-02,& + & 1.274940E-01,2.353840E-01,5.374990E-01,5.875310E-01,6.906480E-01,& + & 4.601880E-01,5.262390E-01,8.042760E-01,7.955570E-01,3.821550E-01,& + & 4.856770E-01,5.216640E-01,1.601340E-01,1.087970E-01,1.713010E-02,& + & 6.729010E-02,1.269720E-01,2.373970E-01,5.362350E-01,5.896310E-01,& + & 6.792620E-01,4.595540E-01,5.261230E-01,8.022360E-01,7.952610E-01,& + & 3.824630E-01,4.852300E-01,5.221100E-01,1.601000E-01,1.087970E-01,& + & 1.800270E-02,7.138300E-02,1.252110E-01,2.508970E-01,5.261870E-01,& + & 5.888250E-01,6.692250E-01,4.580510E-01,5.246570E-01,7.995360E-01,& + & 7.955230E-01,3.821980E-01,4.855390E-01,5.218180E-01,1.601000E-01,& + & 1.087970E-01,1.918190E-02,7.648010E-02,1.268990E-01,2.620030E-01,& + & 5.180320E-01,5.892130E-01,6.572560E-01,4.474710E-01,5.236180E-01,& + & 8.066260E-01,7.816900E-01,3.822610E-01,4.855710E-01,5.218010E-01,& + & 1.601340E-01,1.087970E-01,1.984580E-02,8.272250E-02,1.333550E-01,& + & 2.618320E-01,5.219630E-01,5.904610E-01,6.380810E-01,4.354370E-01,& + & 5.202370E-01,8.191080E-01,7.594400E-01,3.821850E-01,4.854360E-01,& + & 5.219100E-01,1.601340E-01,1.087970E-01,1.929350E-02,8.907280E-02,& + & 1.463050E-01,2.782640E-01,5.193200E-01,5.931270E-01,5.946560E-01,& + & 4.340620E-01,4.979990E-01,8.061560E-01,7.274580E-01,3.822840E-01,& + & 4.857210E-01,5.219330E-01,1.601000E-01,1.087970E-01,1.175600E-02,& + & 5.346110E-02,1.122850E-01,2.018860E-01,3.815420E-01,6.059270E-01,& + & 8.570360E-01,8.798550E-01,3.392030E-01,2.382370E-01,2.022520E-01,& + & 1.294130E-01,1.114530E-01,1.281430E-01,2.119350E-01,3.436830E-01/ + data ka_mo3(:,:, 6) / & + & 1.418620E-02,5.548960E-02,1.308880E-01,2.477280E-01,5.292460E-01,& + & 5.943300E-01,6.869670E-01,4.551760E-01,5.192230E-01,8.005070E-01,& + & 7.865280E-01,3.749850E-01,4.903440E-01,5.109550E-01,1.623840E-01,& + & 1.103140E-01,1.658860E-02,6.134400E-02,1.321190E-01,2.400590E-01,& + & 5.313600E-01,5.901870E-01,6.846950E-01,4.545670E-01,5.192030E-01,& + & 7.993130E-01,7.866930E-01,3.746440E-01,4.901410E-01,5.110860E-01,& + & 1.625340E-01,1.103140E-01,1.789880E-02,6.578220E-02,1.311140E-01,& + & 2.378020E-01,5.369220E-01,5.837390E-01,6.802520E-01,4.539260E-01,& + & 5.190520E-01,7.976910E-01,7.867980E-01,3.748050E-01,4.904740E-01,& + & 5.108050E-01,1.624220E-01,1.103140E-01,1.848880E-02,7.028940E-02,& + & 1.305220E-01,2.397080E-01,5.355320E-01,5.858380E-01,6.691600E-01,& + & 4.532880E-01,5.189410E-01,7.956750E-01,7.865070E-01,3.750990E-01,& + & 4.900400E-01,5.112460E-01,1.623840E-01,1.103140E-01,1.940570E-02,& + & 7.445320E-02,1.286580E-01,2.530240E-01,5.254270E-01,5.851900E-01,& + & 6.592660E-01,4.518590E-01,5.174390E-01,7.929990E-01,7.867600E-01,& + & 3.748540E-01,4.903260E-01,5.109800E-01,1.623840E-01,1.103140E-01,& + & 2.063280E-02,7.962040E-02,1.303000E-01,2.640290E-01,5.171070E-01,& + & 5.855880E-01,6.474080E-01,4.415130E-01,5.163990E-01,8.001050E-01,& + & 7.729530E-01,3.749060E-01,4.903720E-01,5.109520E-01,1.624220E-01,& + & 1.103140E-01,2.134530E-02,8.595430E-02,1.366320E-01,2.638110E-01,& + & 5.207720E-01,5.865800E-01,6.287120E-01,4.298120E-01,5.130840E-01,& + & 8.125940E-01,7.507430E-01,3.748350E-01,4.902410E-01,5.110460E-01,& + & 1.624220E-01,1.103140E-01,2.083780E-02,9.240020E-02,1.495670E-01,& + & 2.797290E-01,5.182600E-01,5.885180E-01,5.861200E-01,4.287220E-01,& + & 4.913670E-01,7.997880E-01,7.188180E-01,3.749350E-01,4.905220E-01,& + & 5.110580E-01,1.623840E-01,1.103140E-01,1.262870E-02,5.557000E-02,& + & 1.152970E-01,2.040620E-01,3.818290E-01,6.021700E-01,8.471760E-01,& + & 8.721850E-01,3.369830E-01,2.392420E-01,2.020010E-01,1.290170E-01,& + & 1.108970E-01,1.269670E-01,2.045630E-01,3.326640E-01 / + data ka_mo3(:,:, 7) / 1.543280E-02,& + & 5.844090E-02,1.348860E-01,2.502280E-01,5.289380E-01,5.903150E-01,& + & 6.765860E-01,4.490000E-01,5.121290E-01,7.939510E-01,7.778660E-01,& + & 3.677770E-01,4.951870E-01,5.003220E-01,1.647000E-01,1.118520E-01,& + & 1.797010E-02,6.433030E-02,1.359480E-01,2.425540E-01,5.309520E-01,& + & 5.862640E-01,6.743620E-01,4.483860E-01,5.121090E-01,7.927720E-01,& + & 7.780110E-01,3.674400E-01,4.949950E-01,5.004480E-01,1.648500E-01,& + & 1.118520E-01,1.933660E-02,6.883540E-02,1.348370E-01,2.402440E-01,& + & 5.363450E-01,5.799710E-01,6.700120E-01,4.477500E-01,5.119630E-01,& + & 7.911590E-01,7.781360E-01,3.675970E-01,4.953180E-01,5.001720E-01,& + & 1.647440E-01,1.118520E-01,1.995530E-02,7.342240E-02,1.341710E-01,& + & 2.420420E-01,5.348310E-01,5.820710E-01,6.592090E-01,4.471060E-01,& + & 5.118560E-01,7.891670E-01,7.778500E-01,3.678760E-01,4.948980E-01,& + & 5.006080E-01,1.647000E-01,1.118520E-01,2.091800E-02,7.765550E-02,& + & 1.322000E-01,2.551700E-01,5.246680E-01,5.815770E-01,6.494550E-01,& + & 4.457510E-01,5.103200E-01,7.865150E-01,7.780920E-01,3.676510E-01,& + & 4.951600E-01,5.003660E-01,1.647000E-01,1.118520E-01,2.219350E-02,& + & 8.288980E-02,1.337930E-01,2.660710E-01,5.161840E-01,5.819850E-01,& + & 6.377080E-01,4.356330E-01,5.092800E-01,7.936370E-01,7.643140E-01,& + & 3.676930E-01,4.952210E-01,5.003290E-01,1.647440E-01,1.118520E-01,& + & 2.295810E-02,8.931250E-02,1.399900E-01,2.658060E-01,5.195840E-01,& + & 5.827250E-01,6.194810E-01,4.242590E-01,5.060280E-01,8.061310E-01,& + & 7.421450E-01,3.676270E-01,4.950950E-01,5.004080E-01,1.647440E-01,& + & 1.118520E-01,2.250570E-02,9.585180E-02,1.529020E-01,2.812010E-01,& + & 5.172030E-01,5.839440E-01,5.777060E-01,4.234490E-01,4.848230E-01,& + & 7.934700E-01,7.102810E-01,3.677270E-01,4.953710E-01,5.004100E-01,& + & 1.647000E-01,1.118520E-01,1.356620E-02,5.776200E-02,1.183900E-01,& + & 2.062610E-01,3.821170E-01,5.984370E-01,8.374310E-01,8.645830E-01,& + & 3.347780E-01,2.402520E-01,2.017520E-01,1.286230E-01,1.103420E-01,& + & 1.258020E-01,1.974470E-01,3.219990E-01 / + data ka_mo3(:,:, 8) / 1.678900E-02,6.154910E-02,& + & 1.390060E-01,2.527530E-01,5.286310E-01,5.863270E-01,6.663620E-01,& + & 4.429070E-01,5.051320E-01,7.874490E-01,7.692990E-01,3.607070E-01,& + & 5.000790E-01,4.899100E-01,1.670490E-01,1.134120E-01,1.946660E-02,& + & 6.746210E-02,1.398880E-01,2.450750E-01,5.305440E-01,5.823670E-01,& + & 6.641860E-01,4.422890E-01,5.051120E-01,7.862840E-01,7.694250E-01,& + & 3.603760E-01,4.998960E-01,4.900310E-01,1.671990E-01,1.134120E-01,& + & 2.088990E-02,7.203020E-02,1.386660E-01,2.427120E-01,5.357690E-01,& + & 5.762270E-01,6.599270E-01,4.416570E-01,5.049710E-01,7.846810E-01,& + & 7.695690E-01,3.605270E-01,5.002090E-01,4.897600E-01,1.670980E-01,& + & 1.134120E-01,2.153800E-02,7.669510E-02,1.379220E-01,2.443990E-01,& + & 5.341300E-01,5.783270E-01,6.494050E-01,4.410090E-01,5.048690E-01,& + & 7.827130E-01,7.692880E-01,3.607920E-01,4.998040E-01,4.901910E-01,& + & 1.670490E-01,1.134120E-01,2.254810E-02,8.099550E-02,1.358400E-01,& + & 2.573340E-01,5.239090E-01,5.779870E-01,6.397900E-01,4.397260E-01,& + & 5.033000E-01,7.800850E-01,7.695210E-01,3.605860E-01,5.000420E-01,& + & 4.899740E-01,1.670490E-01,1.134120E-01,2.387210E-02,8.629340E-02,& + & 1.373790E-01,2.681290E-01,5.152630E-01,5.784040E-01,6.281540E-01,& + & 4.298330E-01,5.022600E-01,7.872210E-01,7.557710E-01,3.606190E-01,& + & 5.001180E-01,4.899270E-01,1.670980E-01,1.134120E-01,2.469280E-02,& + & 9.280180E-02,1.434290E-01,2.678150E-01,5.183990E-01,5.788950E-01,& + & 6.103850E-01,4.187790E-01,4.990700E-01,7.997190E-01,7.336460E-01,& + & 3.605570E-01,4.999960E-01,4.899910E-01,1.670980E-01,1.134120E-01,& + & 2.430710E-02,9.943240E-02,1.563110E-01,2.826810E-01,5.161470E-01,& + & 5.794060E-01,5.694140E-01,4.182400E-01,4.783660E-01,7.872020E-01,& + & 7.018450E-01,3.606570E-01,5.002680E-01,4.899840E-01,1.670490E-01,& + & 1.134120E-01,1.457340E-02,6.004050E-02,1.215660E-01,2.084830E-01,& + & 3.824050E-01,5.947260E-01,8.277970E-01,8.570460E-01,3.325880E-01,& + & 2.412650E-01,2.015020E-01,1.282290E-01,1.097910E-01,1.246480E-01,& + & 1.905780E-01,3.116750E-01 / + data ka_mo3(:,:, 9) / 1.826440E-02,6.482270E-02,1.432520E-01,& + & 2.553040E-01,5.283240E-01,5.823660E-01,6.562920E-01,4.368970E-01,& + & 4.982310E-01,7.810000E-01,7.608270E-01,3.537740E-01,5.050190E-01,& + & 4.797140E-01,1.694320E-01,1.149930E-01,2.108780E-02,7.074640E-02,& + & 1.439430E-01,2.476210E-01,5.301370E-01,5.784960E-01,6.541630E-01,& + & 4.362740E-01,4.982110E-01,7.798490E-01,7.609340E-01,3.534470E-01,& + & 5.048460E-01,4.798310E-01,1.695820E-01,1.149930E-01,2.256800E-02,& + & 7.537340E-02,1.426040E-01,2.452050E-01,5.351940E-01,5.725080E-01,& + & 6.499930E-01,4.356480E-01,4.980740E-01,7.782560E-01,7.610970E-01,& + & 3.535940E-01,5.051490E-01,4.795640E-01,1.694860E-01,1.149930E-01,& + & 2.324630E-02,8.011370E-02,1.417780E-01,2.467790E-01,5.334310E-01,& + & 5.746070E-01,6.397470E-01,4.349950E-01,4.979770E-01,7.763120E-01,& + & 7.608200E-01,3.538440E-01,5.047590E-01,4.799910E-01,1.694320E-01,& + & 1.149930E-01,2.430530E-02,8.447910E-02,1.395800E-01,2.595160E-01,& + & 5.231520E-01,5.744190E-01,6.302690E-01,4.337810E-01,4.963760E-01,& + & 7.737070E-01,7.610440E-01,3.536570E-01,5.049730E-01,4.797970E-01,& + & 1.694320E-01,1.149930E-01,2.567780E-02,8.983670E-02,1.410610E-01,& + & 2.702030E-01,5.143430E-01,5.748450E-01,6.187420E-01,4.241090E-01,& + & 4.953360E-01,7.808560E-01,7.473240E-01,3.536800E-01,5.050630E-01,& + & 4.797400E-01,1.694860E-01,1.149930E-01,2.655850E-02,9.642750E-02,& + & 1.469540E-01,2.698400E-01,5.172170E-01,5.750900E-01,6.014220E-01,& + & 4.133690E-01,4.922070E-01,7.933590E-01,7.252450E-01,3.536240E-01,& + & 5.049460E-01,4.797910E-01,1.694860E-01,1.149930E-01,2.625260E-02,& + & 1.031470E-01,1.597970E-01,2.841690E-01,5.150940E-01,5.749030E-01,& + & 5.612400E-01,4.130960E-01,4.719960E-01,7.809840E-01,6.935090E-01,& + & 3.537230E-01,5.052130E-01,4.797750E-01,1.694320E-01,1.149930E-01,& + & 1.565530E-02,6.240890E-02,1.248270E-01,2.107300E-01,3.826930E-01,& + & 5.910390E-01,8.182740E-01,8.495760E-01,3.304120E-01,2.422830E-01,& + & 2.012530E-01,1.278370E-01,1.092420E-01,1.235040E-01,1.839490E-01,& + & 3.016830E-01 / + data ka_mo3(:,:,10) / & + & 1.986940E-02,6.827040E-02,1.476280E-01,2.578810E-01,& + & 5.280170E-01,5.784320E-01,6.463740E-01,4.309690E-01,4.914240E-01,& + & 7.746040E-01,7.524480E-01,3.469730E-01,5.100080E-01,4.697310E-01,& + & 1.718490E-01,1.165970E-01,2.284400E-02,7.419050E-02,1.481150E-01,& + & 2.501950E-01,5.297290E-01,5.746510E-01,6.442920E-01,4.303420E-01,& + & 4.914040E-01,7.734670E-01,7.525370E-01,3.466510E-01,5.098450E-01,& + & 4.698440E-01,1.719990E-01,1.165970E-01,2.438080E-02,7.887170E-02,& + & 1.466530E-01,2.477240E-01,5.346200E-01,5.688120E-01,6.402090E-01,& + & 4.297200E-01,4.912720E-01,7.718830E-01,7.527170E-01,3.467930E-01,& + & 5.101380E-01,4.695820E-01,1.719080E-01,1.165970E-01,2.509010E-02,& + & 8.368460E-02,1.457420E-01,2.491820E-01,5.327320E-01,5.709120E-01,& + & 6.302330E-01,4.290630E-01,4.911790E-01,7.699620E-01,7.524450E-01,& + & 3.470310E-01,5.097630E-01,4.700040E-01,1.718490E-01,1.165970E-01,& + & 2.619940E-02,8.811250E-02,1.434230E-01,2.617170E-01,5.223960E-01,& + & 5.708720E-01,6.208890E-01,4.279180E-01,4.895470E-01,7.673820E-01,& + & 7.526600E-01,3.468610E-01,5.099520E-01,4.698310E-01,1.718490E-01,& + & 1.165970E-01,2.762000E-02,9.352550E-02,1.448420E-01,2.722930E-01,& + & 5.134250E-01,5.713080E-01,6.094720E-01,4.184610E-01,4.885070E-01,& + & 7.745440E-01,7.389710E-01,3.468760E-01,5.100560E-01,4.697660E-01,& + & 1.719080E-01,1.165970E-01,2.856520E-02,1.001950E-01,1.505650E-01,& + & 2.718800E-01,5.160380E-01,5.713110E-01,5.925920E-01,4.080290E-01,& + & 4.854380E-01,7.870490E-01,7.169390E-01,3.468230E-01,5.099450E-01,& + & 4.698040E-01,1.719080E-01,1.165970E-01,2.835390E-02,1.070000E-01,& + & 1.633600E-01,2.856650E-01,5.140420E-01,5.704360E-01,5.531840E-01,& + & 4.080150E-01,4.657100E-01,7.748150E-01,6.852720E-01,3.469230E-01,& + & 5.102060E-01,4.697790E-01,1.718490E-01,1.165970E-01,1.681750E-02,& + & 6.487070E-02,1.281760E-01,2.130010E-01,3.829820E-01,5.873750E-01,& + & 8.088610E-01,8.421700E-01,3.282500E-01,2.433060E-01,2.010040E-01,& + & 1.274460E-01,1.086960E-01,1.223700E-01,1.775500E-01,2.920110E-01/ + data ka_mo3(:,:,11) / & + & 2.161540E-02,7.190140E-02,1.521370E-01,2.604830E-01,5.277110E-01,& + & 5.745240E-01,6.366070E-01,4.251210E-01,4.847100E-01,7.682600E-01,& + & 7.441610E-01,3.403030E-01,5.150460E-01,4.599560E-01,1.743010E-01,& + & 1.182230E-01,2.474650E-02,7.780230E-02,1.524070E-01,2.527950E-01,& + & 5.293220E-01,5.708310E-01,6.345690E-01,4.244900E-01,4.846900E-01,& + & 7.671370E-01,7.442320E-01,3.399860E-01,5.148930E-01,4.600640E-01,& + & 1.744500E-01,1.182230E-01,2.633940E-02,8.253240E-02,1.508170E-01,& + & 2.502680E-01,5.340450E-01,5.651400E-01,6.305720E-01,4.238730E-01,& + & 4.845620E-01,7.655630E-01,7.444300E-01,3.401240E-01,5.151760E-01,& + & 4.598060E-01,1.743640E-01,1.182230E-01,2.708010E-02,8.741470E-02,& + & 1.498170E-01,2.516080E-01,5.320340E-01,5.672400E-01,6.208600E-01,& + & 4.232110E-01,4.844740E-01,7.636650E-01,7.441630E-01,3.403480E-01,& + & 5.148170E-01,4.602240E-01,1.743010E-01,1.182230E-01,2.824110E-02,& + & 9.190230E-02,1.473720E-01,2.639360E-01,5.216410E-01,5.673480E-01,& + & 6.116500E-01,4.221330E-01,4.828120E-01,7.611080E-01,7.443680E-01,& + & 3.401950E-01,5.149790E-01,4.600720E-01,1.743010E-01,1.182230E-01,& + & 2.970910E-02,9.736580E-02,1.487240E-01,2.743980E-01,5.125090E-01,& + & 5.677930E-01,6.003400E-01,4.128890E-01,4.817730E-01,7.682820E-01,& + & 7.307120E-01,3.402020E-01,5.151000E-01,4.599990E-01,1.743640E-01,& + & 1.182230E-01,3.072350E-02,1.041090E-01,1.542640E-01,2.739360E-01,& + & 5.148610E-01,5.675560E-01,5.838910E-01,4.027580E-01,4.787630E-01,& + & 7.807890E-01,7.087290E-01,3.401540E-01,5.149930E-01,4.600240E-01,& + & 1.743640E-01,1.182230E-01,3.062340E-02,1.109970E-01,1.670020E-01,& + & 2.871680E-01,5.129930E-01,5.660020E-01,5.452430E-01,4.029960E-01,& + & 4.595080E-01,7.686940E-01,6.771330E-01,3.402530E-01,5.152500E-01,& + & 4.599910E-01,1.743010E-01,1.182230E-01,1.806600E-02,6.742960E-02,& + & 1.316140E-01,2.152960E-01,3.832710E-01,5.837330E-01,7.995550E-01,& + & 8.348290E-01,3.261020E-01,2.443320E-01,2.007550E-01,1.270560E-01,& + & 1.081530E-01,1.212470E-01,1.713730E-01,2.826480E-01 / + data ka_mo3(:,:,12) / 2.351490E-02,& + & 7.572560E-02,1.567850E-01,2.631120E-01,5.274040E-01,5.706430E-01,& + & 6.269870E-01,4.193530E-01,4.780870E-01,7.619680E-01,7.359650E-01,& + & 3.337620E-01,5.201340E-01,4.503840E-01,1.767870E-01,1.198710E-01,& + & 2.680740E-02,8.158990E-02,1.568250E-01,2.554220E-01,5.289160E-01,& + & 5.670370E-01,6.249930E-01,4.187180E-01,4.780680E-01,7.608590E-01,& + & 7.360190E-01,3.334490E-01,5.199920E-01,4.504880E-01,1.769370E-01,& + & 1.198710E-01,2.845520E-02,8.636300E-02,1.550990E-01,2.528390E-01,& + & 5.334720E-01,5.614930E-01,6.210800E-01,4.181050E-01,4.779440E-01,& + & 7.592940E-01,7.362350E-01,3.335830E-01,5.202640E-01,4.502350E-01,& + & 1.768560E-01,1.198710E-01,2.922800E-02,9.131110E-02,1.540050E-01,& + & 2.540580E-01,5.313370E-01,5.635920E-01,6.116270E-01,4.174400E-01,& + & 4.778610E-01,7.574190E-01,7.359710E-01,3.337940E-01,5.199200E-01,& + & 4.506470E-01,1.767870E-01,1.198710E-01,3.044190E-02,9.585500E-02,& + & 1.514290E-01,2.661740E-01,5.208880E-01,5.638460E-01,6.025470E-01,& + & 4.164270E-01,4.761700E-01,7.548850E-01,7.361680E-01,3.336580E-01,& + & 5.200570E-01,4.505160E-01,1.767870E-01,1.198710E-01,3.195620E-02,& + & 1.013640E-01,1.527110E-01,2.765210E-01,5.115940E-01,5.642990E-01,& + & 5.913460E-01,4.073910E-01,4.751320E-01,7.620710E-01,7.225450E-01,& + & 3.336560E-01,5.201930E-01,4.504350E-01,1.768560E-01,1.198710E-01,& + & 3.304490E-02,1.081770E-01,1.580550E-01,2.760070E-01,5.136860E-01,& + & 5.638260E-01,5.753170E-01,3.975550E-01,4.721790E-01,7.745790E-01,& + & 7.006120E-01,3.336120E-01,5.200920E-01,4.504480E-01,1.768560E-01,& + & 1.198710E-01,3.307450E-02,1.151430E-01,1.707260E-01,2.886800E-01,& + & 5.119460E-01,5.616040E-01,5.374160E-01,3.980390E-01,4.533880E-01,& + & 7.626220E-01,6.690910E-01,3.337120E-01,5.203430E-01,4.504070E-01,& + & 1.767870E-01,1.198710E-01,1.940720E-02,7.008950E-02,1.351450E-01,& + & 2.176160E-01,3.835590E-01,5.801140E-01,7.903570E-01,8.275520E-01,& + & 3.239680E-01,2.453630E-01,2.005070E-01,1.266680E-01,1.076130E-01,& + & 1.201350E-01,1.654120E-01,2.735860E-01 / + data ka_mo3(:,:,13) / 2.558130E-02,7.975320E-02,& + & 1.615740E-01,2.657670E-01,5.270980E-01,5.667880E-01,6.175120E-01,& + & 4.136630E-01,4.715560E-01,7.557280E-01,7.278600E-01,3.273460E-01,& + & 5.252720E-01,4.410110E-01,1.793090E-01,1.215430E-01,2.903990E-02,& + & 8.556190E-02,1.613700E-01,2.580770E-01,5.285090E-01,5.632680E-01,& + & 6.155620E-01,4.130240E-01,4.715360E-01,7.546330E-01,7.278960E-01,& + & 3.270380E-01,5.251410E-01,4.411110E-01,1.794580E-01,1.215430E-01,& + & 3.074100E-02,9.037140E-02,1.595030E-01,2.554360E-01,5.328990E-01,& + & 5.578680E-01,6.117310E-01,4.124160E-01,4.714170E-01,7.530770E-01,& + & 7.281290E-01,3.271670E-01,5.254020E-01,4.408620E-01,1.793830E-01,& + & 1.215430E-01,3.154630E-02,9.538120E-02,1.583110E-01,2.565320E-01,& + & 5.306410E-01,5.599670E-01,6.025310E-01,4.117470E-01,4.713370E-01,& + & 7.512250E-01,7.278700E-01,3.273670E-01,5.250750E-01,4.412700E-01,& + & 1.793090E-01,1.215430E-01,3.281420E-02,9.997780E-02,1.555990E-01,& + & 2.684310E-01,5.201350E-01,5.603650E-01,5.935810E-01,4.107980E-01,& + & 4.696190E-01,7.487140E-01,7.280580E-01,3.272460E-01,5.251850E-01,& + & 4.411590E-01,1.793090E-01,1.215430E-01,3.437330E-02,1.055260E-01,& + & 1.568040E-01,2.786590E-01,5.106810E-01,5.608270E-01,5.824860E-01,& + & 4.019660E-01,4.685820E-01,7.559100E-01,7.144690E-01,3.272370E-01,& + & 5.253360E-01,4.410700E-01,1.793830E-01,1.215430E-01,3.554170E-02,& + & 1.124030E-01,1.619390E-01,2.780930E-01,5.125150E-01,5.601200E-01,& + & 5.668700E-01,3.924190E-01,4.656860E-01,7.684190E-01,6.925890E-01,& + & 3.271970E-01,5.252400E-01,4.410710E-01,1.793830E-01,1.215430E-01,& + & 3.572180E-02,1.194440E-01,1.745330E-01,2.901990E-01,5.109010E-01,& + & 5.572390E-01,5.297020E-01,3.931430E-01,4.473500E-01,7.565980E-01,& + & 6.611440E-01,3.272960E-01,5.254860E-01,4.410230E-01,1.793090E-01,& + & 1.215430E-01,2.084800E-02,7.285420E-02,1.387700E-01,2.199610E-01,& + & 3.838490E-01,5.765170E-01,7.812650E-01,8.203390E-01,3.218480E-01,& + & 2.463980E-01,2.002590E-01,1.262800E-01,1.070750E-01,1.190320E-01,& + & 1.596580E-01,2.648150E-01 / + data ka_mo3(:,:,14) / 2.782930E-02,8.399490E-02,1.665090E-01,& + & 2.684500E-01,5.267920E-01,5.629590E-01,6.081810E-01,4.080490E-01,& + & 4.651130E-01,7.495390E-01,7.198440E-01,3.210540E-01,5.304610E-01,& + & 4.318340E-01,1.818660E-01,1.232380E-01,3.145830E-02,8.972730E-02,& + & 1.660470E-01,2.607590E-01,5.281030E-01,5.595240E-01,6.062730E-01,& + & 4.074070E-01,4.650930E-01,7.484570E-01,7.198630E-01,3.207500E-01,& + & 5.303400E-01,4.319300E-01,1.820160E-01,1.232380E-01,3.321040E-02,& + & 9.456580E-02,1.640320E-01,2.580600E-01,5.323270E-01,5.542670E-01,& + & 6.025230E-01,4.068040E-01,4.649780E-01,7.469100E-01,7.201130E-01,& + & 3.208750E-01,5.305910E-01,4.316850E-01,1.819470E-01,1.232380E-01,& + & 3.404840E-02,9.963260E-02,1.627370E-01,2.590300E-01,5.299460E-01,& + & 5.563650E-01,5.935700E-01,4.061320E-01,4.649030E-01,7.450810E-01,& + & 7.198580E-01,3.210630E-01,5.302800E-01,4.320880E-01,1.818660E-01,& + & 1.232380E-01,3.537140E-02,1.042780E-01,1.598830E-01,2.707080E-01,& + & 5.193830E-01,5.569050E-01,5.847470E-01,4.052450E-01,4.631580E-01,& + & 7.425920E-01,7.200380E-01,3.209580E-01,5.303630E-01,4.319960E-01,& + & 1.818660E-01,1.232380E-01,3.697320E-02,1.098590E-01,1.610070E-01,& + & 2.808140E-01,5.097700E-01,5.573770E-01,5.737580E-01,3.966140E-01,& + & 4.621220E-01,7.497990E-01,7.064830E-01,3.209410E-01,5.305310E-01,& + & 4.319000E-01,1.819470E-01,1.232380E-01,3.822720E-02,1.167950E-01,& + & 1.659180E-01,2.801960E-01,5.113460E-01,5.564390E-01,5.585470E-01,& + & 3.873500E-01,4.592820E-01,7.623070E-01,6.846580E-01,3.209050E-01,& + & 5.304400E-01,4.318900E-01,1.819470E-01,1.232380E-01,3.858100E-02,& + & 1.239060E-01,1.784240E-01,2.917260E-01,5.098590E-01,5.529090E-01,& + & 5.220980E-01,3.883070E-01,4.413930E-01,7.506220E-01,6.532920E-01,& + & 3.210040E-01,5.306800E-01,4.318340E-01,1.818660E-01,1.232380E-01,& + & 2.239580E-02,7.572810E-02,1.424930E-01,2.223310E-01,3.841380E-01,& + & 5.729430E-01,7.722780E-01,8.131880E-01,3.197420E-01,2.474380E-01,& + & 2.000110E-01,1.258940E-01,1.065400E-01,1.179400E-01,1.541040E-01,& + & 2.563250E-01 / + data ka_mo3(:,:,15) / & + & 3.027490E-02,8.846230E-02,1.715950E-01,2.711590E-01,& + & 5.264860E-01,5.591560E-01,5.989900E-01,4.025130E-01,4.587580E-01,& + & 7.434000E-01,7.119160E-01,3.148820E-01,5.357010E-01,4.228470E-01,& + & 1.844610E-01,1.249560E-01,3.407820E-02,9.409550E-02,1.708600E-01,& + & 2.634680E-01,5.276970E-01,5.558050E-01,5.971240E-01,4.018670E-01,& + & 4.587390E-01,7.423320E-01,7.119190E-01,3.145820E-01,5.355920E-01,& + & 4.229390E-01,1.846100E-01,1.249560E-01,3.587820E-02,9.895490E-02,& + & 1.686900E-01,2.607110E-01,5.317560E-01,5.506900E-01,5.934530E-01,& + & 4.012690E-01,4.586280E-01,7.407950E-01,7.121850E-01,3.147040E-01,& + & 5.358310E-01,4.226990E-01,1.845470E-01,1.249560E-01,3.674890E-02,& + & 1.040740E-01,1.672870E-01,2.615520E-01,5.292520E-01,5.527870E-01,& + & 5.847430E-01,4.005940E-01,4.585570E-01,7.389870E-01,7.119350E-01,& + & 3.148800E-01,5.355370E-01,4.230970E-01,1.844610E-01,1.249560E-01,& + & 3.812790E-02,1.087630E-01,1.642840E-01,2.730030E-01,5.186330E-01,& + & 5.534670E-01,5.760450E-01,3.997670E-01,4.567860E-01,7.365210E-01,& + & 7.121060E-01,3.147900E-01,5.355920E-01,4.230230E-01,1.844610E-01,& + & 1.249560E-01,3.976980E-02,1.143700E-01,1.653220E-01,2.829860E-01,& + & 5.088600E-01,5.539470E-01,5.651620E-01,3.913320E-01,4.557520E-01,& + & 7.437370E-01,6.985870E-01,3.147660E-01,5.357760E-01,4.229200E-01,& + & 1.845470E-01,1.249560E-01,4.111550E-02,1.213580E-01,1.699950E-01,& + & 2.823140E-01,5.101800E-01,5.527820E-01,5.503450E-01,3.823460E-01,& + & 4.529670E-01,7.562440E-01,6.768170E-01,3.147340E-01,5.356920E-01,& + & 4.229000E-01,1.845470E-01,1.249560E-01,4.166900E-02,1.285350E-01,& + & 1.824030E-01,2.932620E-01,5.088180E-01,5.486120E-01,5.146040E-01,& + & 3.835310E-01,4.355150E-01,7.446920E-01,6.455330E-01,3.148330E-01,& + & 5.359260E-01,4.228360E-01,1.844610E-01,1.249560E-01,2.405840E-02,& + & 7.871530E-02,1.463150E-01,2.247270E-01,3.844280E-01,5.693900E-01,& + & 7.633930E-01,8.061000E-01,3.176500E-01,2.484820E-01,1.997640E-01,& + & 1.255090E-01,1.060070E-01,1.168570E-01,1.487430E-01,2.481070E-01/ + data ka_mo3(:,:,16) / & + & 3.293530E-02,9.316730E-02,1.768360E-01,2.738950E-01,5.261800E-01,& + & 5.553790E-01,5.899390E-01,3.970510E-01,4.524910E-01,7.373120E-01,& + & 7.040750E-01,3.088290E-01,5.409930E-01,4.140480E-01,1.870920E-01,& + & 1.266990E-01,3.691620E-02,9.867630E-02,1.758120E-01,2.662060E-01,& + & 5.272920E-01,5.521100E-01,5.881130E-01,3.964030E-01,4.524710E-01,& + & 7.362570E-01,7.040620E-01,3.085340E-01,5.408950E-01,4.141360E-01,& + & 1.872410E-01,1.266990E-01,3.876030E-02,1.035480E-01,1.734800E-01,& + & 2.633890E-01,5.311850E-01,5.471350E-01,5.845200E-01,3.958090E-01,& + & 4.523640E-01,7.347290E-01,7.043440E-01,3.086520E-01,5.411230E-01,& + & 4.139000E-01,1.871840E-01,1.266990E-01,3.966370E-02,1.087120E-01,& + & 1.719640E-01,2.640990E-01,5.285590E-01,5.492320E-01,5.760470E-01,& + & 3.951310E-01,4.522970E-01,7.329430E-01,7.040980E-01,3.088170E-01,& + & 5.408460E-01,4.142930E-01,1.870920E-01,1.266990E-01,4.109920E-02,& + & 1.134410E-01,1.688080E-01,2.753180E-01,5.178830E-01,5.500500E-01,& + & 5.674730E-01,3.943630E-01,4.505020E-01,7.305000E-01,7.042610E-01,& + & 3.087410E-01,5.408730E-01,4.142360E-01,1.870920E-01,1.266990E-01,& + & 4.277790E-02,1.190660E-01,1.697540E-01,2.851750E-01,5.079520E-01,& + & 5.505390E-01,5.566940E-01,3.861220E-01,4.494690E-01,7.377250E-01,& + & 6.907790E-01,3.087100E-01,5.410740E-01,4.141270E-01,1.871840E-01,& + & 1.266990E-01,4.422210E-02,1.260990E-01,1.741720E-01,2.844490E-01,& + & 5.090160E-01,5.491490E-01,5.422650E-01,3.774060E-01,4.467380E-01,& + & 7.502300E-01,6.690660E-01,3.086810E-01,5.409950E-01,4.140960E-01,& + & 1.871840E-01,1.266990E-01,4.500420E-02,1.333360E-01,1.864700E-01,& + & 2.948050E-01,5.077800E-01,5.443490E-01,5.072170E-01,3.788130E-01,& + & 4.297150E-01,7.388100E-01,6.378660E-01,3.087800E-01,5.412230E-01,& + & 4.140260E-01,1.870920E-01,1.266990E-01,2.584450E-02,8.182030E-02,& + & 1.502400E-01,2.271480E-01,3.847170E-01,5.658600E-01,7.546110E-01,& + & 7.990730E-01,3.155720E-01,2.495310E-01,1.995170E-01,1.251250E-01,& + & 1.054780E-01,1.157850E-01,1.435690E-01,2.401520E-01 / + data ka_mo3(:,:,17) / 3.582950E-02,& + & 9.812250E-02,1.822380E-01,2.766600E-01,5.258750E-01,5.516270E-01,& + & 5.810240E-01,3.916630E-01,4.463090E-01,7.312740E-01,6.963210E-01,& + & 3.028930E-01,5.463380E-01,4.054310E-01,1.897610E-01,1.284660E-01,& + & 3.999070E-02,1.034800E-01,1.809070E-01,2.689730E-01,5.268870E-01,& + & 5.484400E-01,5.792380E-01,3.910120E-01,4.462890E-01,7.302320E-01,& + & 6.962920E-01,3.026020E-01,5.462510E-01,4.055160E-01,1.899090E-01,& + & 1.284660E-01,4.187390E-02,1.083540E-01,1.784060E-01,2.660940E-01,& + & 5.306140E-01,5.436030E-01,5.757210E-01,3.904230E-01,4.461860E-01,& + & 7.287130E-01,6.965890E-01,3.027160E-01,5.464670E-01,4.052840E-01,& + & 1.898590E-01,1.284660E-01,4.280970E-02,1.135580E-01,1.767710E-01,& + & 2.666710E-01,5.278660E-01,5.456990E-01,5.674800E-01,3.897430E-01,& + & 4.461230E-01,7.269490E-01,6.963480E-01,3.028700E-01,5.462080E-01,& + & 4.056730E-01,1.897610E-01,1.284660E-01,4.430210E-02,1.183200E-01,& + & 1.734550E-01,2.776530E-01,5.171350E-01,5.466540E-01,5.590280E-01,& + & 3.890320E-01,4.443040E-01,7.245270E-01,6.965030E-01,3.028080E-01,& + & 5.462050E-01,4.056330E-01,1.897610E-01,1.284660E-01,4.601360E-02,& + & 1.239550E-01,1.743040E-01,2.873800E-01,5.070450E-01,5.471510E-01,& + & 5.483530E-01,3.809800E-01,4.432730E-01,7.317600E-01,6.830580E-01,& + & 3.027700E-01,5.464240E-01,4.055170E-01,1.898590E-01,1.284660E-01,& + & 4.756340E-02,1.310260E-01,1.784520E-01,2.865990E-01,5.078550E-01,& + & 5.455400E-01,5.343030E-01,3.725310E-01,4.405950E-01,7.442630E-01,& + & 6.614040E-01,3.027450E-01,5.463510E-01,4.054760E-01,1.898590E-01,& + & 1.284660E-01,4.860640E-02,1.383170E-01,1.906270E-01,2.963570E-01,& + & 5.067430E-01,5.401180E-01,4.999360E-01,3.741540E-01,4.239920E-01,& + & 7.329740E-01,6.302900E-01,3.028440E-01,5.465730E-01,4.054000E-01,& + & 1.897610E-01,1.284660E-01,2.776310E-02,8.504780E-02,1.542710E-01,& + & 2.295960E-01,3.850070E-01,5.623520E-01,7.459300E-01,7.921080E-01,& + & 3.135070E-01,2.505830E-01,1.992700E-01,1.247430E-01,1.049510E-01,& + & 1.147220E-01,1.385740E-01,2.324530E-01 / + data ka_mo3(:,:,18) / 3.897810E-02,1.033410E-01,& + & 1.878040E-01,2.794520E-01,5.255690E-01,5.479010E-01,5.722440E-01,& + & 3.863490E-01,4.402110E-01,7.252850E-01,6.886520E-01,2.970710E-01,& + & 5.517350E-01,3.969940E-01,1.924680E-01,1.302570E-01,4.332110E-02,& + & 1.085180E-01,1.861500E-01,2.717680E-01,5.264820E-01,5.447950E-01,& + & 5.704980E-01,3.856950E-01,4.401910E-01,7.242560E-01,6.886080E-01,& + & 2.967840E-01,5.516600E-01,3.970750E-01,1.926160E-01,1.302570E-01,& + & 4.523770E-02,1.133830E-01,1.834720E-01,2.688270E-01,5.300450E-01,& + & 5.400940E-01,5.670550E-01,3.851110E-01,4.400920E-01,7.227460E-01,& + & 6.889200E-01,2.968940E-01,5.518640E-01,3.968470E-01,1.925720E-01,& + & 1.302570E-01,4.620510E-02,1.186200E-01,1.817140E-01,2.692670E-01,& + & 5.271750E-01,5.421900E-01,5.590400E-01,3.844280E-01,4.400330E-01,& + & 7.210030E-01,6.886830E-01,2.970380E-01,5.516220E-01,3.972310E-01,& + & 1.924680E-01,1.302570E-01,4.775450E-02,1.234090E-01,1.782310E-01,& + & 2.800080E-01,5.163880E-01,5.432790E-01,5.507090E-01,3.837730E-01,& + & 4.381920E-01,7.186040E-01,6.888300E-01,2.969900E-01,5.515910E-01,& + & 3.972070E-01,1.924680E-01,1.302570E-01,4.949390E-02,1.290450E-01,& + & 1.789760E-01,2.896030E-01,5.061400E-01,5.437850E-01,5.401380E-01,& + & 3.759070E-01,4.371620E-01,7.258450E-01,6.754240E-01,2.969450E-01,& + & 5.518260E-01,3.970860E-01,1.925720E-01,1.302570E-01,5.115720E-02,& + & 1.361450E-01,1.828360E-01,2.887660E-01,5.066970E-01,5.419540E-01,& + & 5.264570E-01,3.677190E-01,4.345360E-01,7.383430E-01,6.538300E-01,& + & 2.969230E-01,5.517590E-01,3.970360E-01,1.925720E-01,1.302570E-01,& + & 5.249690E-02,1.434840E-01,1.948780E-01,2.979170E-01,5.057090E-01,& + & 5.359210E-01,4.927600E-01,3.695520E-01,4.183450E-01,7.271840E-01,& + & 6.228040E-01,2.970210E-01,5.519760E-01,3.969530E-01,1.924680E-01,& + & 1.302570E-01,2.982420E-02,8.840270E-02,1.584090E-01,2.320700E-01,& + & 3.852980E-01,5.588650E-01,7.373490E-01,7.852040E-01,3.114560E-01,& + & 2.516410E-01,1.990240E-01,1.243610E-01,1.044260E-01,1.136690E-01,& + & 1.337540E-01,2.250000E-01 / + data ka_mo3(:,:,19) / 4.240340E-02,1.088380E-01,1.935410E-01,& + & 2.822720E-01,5.252640E-01,5.441990E-01,5.635970E-01,3.811060E-01,& + & 4.341970E-01,7.193450E-01,6.810680E-01,2.913600E-01,5.571850E-01,& + & 3.887320E-01,1.952130E-01,1.320730E-01,4.692890E-02,1.138010E-01,& + & 1.915460E-01,2.745930E-01,5.260770E-01,5.411740E-01,5.618890E-01,& + & 3.804500E-01,4.341770E-01,7.183290E-01,6.810090E-01,2.910770E-01,& + & 5.571220E-01,3.888100E-01,1.953610E-01,1.320730E-01,4.887160E-02,& + & 1.186450E-01,1.886820E-01,2.715890E-01,5.294750E-01,5.366080E-01,& + & 5.585190E-01,3.798710E-01,4.340810E-01,7.168280E-01,6.813360E-01,& + & 2.911840E-01,5.573140E-01,3.885860E-01,1.953240E-01,1.320730E-01,& + & 4.986990E-02,1.239070E-01,1.867940E-01,2.718890E-01,5.264840E-01,& + & 5.387030E-01,5.507260E-01,3.791850E-01,4.340260E-01,7.151070E-01,& + & 6.811020E-01,2.913180E-01,5.570910E-01,3.889660E-01,1.952130E-01,& + & 1.320730E-01,5.147600E-02,1.287170E-01,1.831380E-01,2.823820E-01,& + & 5.156420E-01,5.399260E-01,5.425130E-01,3.785850E-01,4.321630E-01,& + & 7.127290E-01,6.812420E-01,2.912830E-01,5.570290E-01,3.889570E-01,& + & 1.952130E-01,1.320730E-01,5.323750E-02,1.343440E-01,1.837730E-01,& + & 2.918420E-01,5.052370E-01,5.404390E-01,5.320450E-01,3.709010E-01,& + & 4.311360E-01,7.199770E-01,6.678750E-01,2.912320E-01,5.572830E-01,& + & 3.888300E-01,1.953240E-01,1.320730E-01,5.502250E-02,1.414640E-01,& + & 1.873290E-01,2.909490E-01,5.055410E-01,5.383930E-01,5.187270E-01,& + & 3.629680E-01,4.285610E-01,7.324710E-01,6.463420E-01,2.912130E-01,& + & 5.572220E-01,3.887710E-01,1.953240E-01,1.320730E-01,5.669880E-02,& + & 1.488440E-01,1.992230E-01,2.994850E-01,5.046770E-01,5.317560E-01,& + & 4.856870E-01,3.650060E-01,4.127740E-01,7.214400E-01,6.154070E-01,& + & 2.913110E-01,5.574320E-01,3.886830E-01,1.952130E-01,1.320730E-01,& + & 3.203830E-02,9.188980E-02,1.626590E-01,2.345710E-01,3.855880E-01,& + & 5.554000E-01,7.288670E-01,7.783590E-01,3.094180E-01,2.527020E-01,& + & 1.987770E-01,1.239810E-01,1.039040E-01,1.126260E-01,1.291010E-01,& + & 2.177870E-01 / + + + data selfref(:,:) / & + & 1.276860E-01,1.400510E-01,1.423220E-01,1.532440E-01,1.710110E-01,& + & 1.760120E-01,1.856000E-01,1.889310E-01,1.911220E-01,1.913340E-01,& + & 1.898580E-01,1.897830E-01,1.875340E-01,1.991280E-01,1.994600E-01,& + & 1.999060E-01,1.093470E-01,1.207850E-01,1.228720E-01,1.330570E-01,& + & 1.466800E-01,1.510100E-01,1.590510E-01,1.617270E-01,1.634070E-01,& + & 1.648720E-01,1.639340E-01,1.637570E-01,1.620160E-01,1.714100E-01,& + & 1.723420E-01,1.727370E-01,9.364100E-02,1.041700E-01,1.060800E-01,& + & 1.155300E-01,1.258100E-01,1.295600E-01,1.363000E-01,1.384400E-01,& + & 1.397100E-01,1.420700E-01,1.415500E-01,1.413000E-01,1.399700E-01,& + & 1.475500E-01,1.489100E-01,1.492600E-01,8.019120E-02,8.984020E-02,& + & 9.158290E-02,1.003110E-01,1.079100E-01,1.111570E-01,1.168030E-01,& + & 1.185060E-01,1.194500E-01,1.224210E-01,1.222220E-01,1.219230E-01,& + & 1.209240E-01,1.270110E-01,1.286640E-01,1.289740E-01,6.867320E-02,& + & 7.748160E-02,7.906710E-02,8.709770E-02,9.255630E-02,9.536720E-02,& + & 1.000950E-01,1.014420E-01,1.021280E-01,1.054900E-01,1.055340E-01,& + & 1.052030E-01,1.044700E-01,1.093320E-01,1.111710E-01,1.114450E-01,& + & 5.880960E-02,6.682310E-02,6.826160E-02,7.562440E-02,7.938740E-02,& + & 8.182070E-02,8.577760E-02,8.683560E-02,8.731760E-02,9.090080E-02,& + & 9.112370E-02,9.077600E-02,9.025410E-02,9.411310E-02,9.605600E-02,& + & 9.629820E-02,5.036270E-02,5.763080E-02,5.893290E-02,6.566260E-02,& + & 6.809220E-02,7.019840E-02,7.350770E-02,7.433210E-02,7.465520E-02,& + & 7.832910E-02,7.868140E-02,7.832740E-02,7.797300E-02,8.101280E-02,& + & 8.299620E-02,8.321020E-02,4.312900E-02,4.970300E-02,5.087900E-02,& + & 5.701300E-02,5.840400E-02,6.022700E-02,6.299300E-02,6.362900E-02,& + & 6.382900E-02,6.749600E-02,6.793800E-02,6.758600E-02,6.736300E-02,& + & 6.973600E-02,7.171200E-02,7.190100E-02,3.693430E-02,4.286580E-02,& + & 4.392580E-02,4.950280E-02,5.009430E-02,5.167200E-02,5.398230E-02,& + & 5.446700E-02,5.457280E-02,5.816120E-02,5.866150E-02,5.831760E-02,& + & 5.819670E-02,6.002890E-02,6.196200E-02,6.212880E-02,3.162940E-02,& + & 3.696910E-02,3.792280E-02,4.298190E-02,4.296690E-02,4.433220E-02,& + & 4.626060E-02,4.662430E-02,4.665890E-02,5.011740E-02,5.065170E-02,& + & 5.032020E-02,5.027780E-02,5.167310E-02,5.353760E-02,5.368480E-02/ + + + data forref(:,:) / & + & 1.068900E-05,1.698700E-05,1.899300E-05,3.447000E-05,4.087300E-05,& + & 4.827500E-05,6.117800E-05,6.403500E-05,6.625300E-05,7.891400E-05,& + & 8.164000E-05,7.973800E-05,7.849200E-05,9.156500E-05,1.026200E-04,& + & 1.036800E-04,1.119400E-05,1.612800E-05,1.721300E-05,2.684500E-05,& + & 4.136100E-05,5.150800E-05,6.824500E-05,7.406300E-05,7.627300E-05,& + & 8.406100E-05,8.249200E-05,8.172000E-05,7.762600E-05,1.009600E-04,& + & 1.051900E-04,1.063100E-04,1.089100E-05,1.493300E-05,1.796400E-05,& + & 2.257700E-05,4.429000E-05,5.467500E-05,7.249400E-05,7.841000E-05,& + & 7.694800E-05,7.574200E-05,7.765400E-05,8.276000E-05,7.844300E-05,& + & 9.838400E-05,1.063400E-04,1.083800E-04,1.131600E-05,1.547000E-05,& + & 2.124600E-05,3.334900E-05,4.870400E-05,5.642400E-05,5.856900E-05,& + & 5.878000E-05,6.035800E-05,6.158600E-05,6.428100E-05,6.933300E-05,& + & 7.276300E-05,7.267500E-05,7.375400E-05,1.013100E-04 / + + + data fracrefa(:,:) / & + & 1.411100e-01,1.422200e-01,1.380200e-01,1.310100e-01,1.224400e-01,& + & 1.069100e-01,8.870300e-02,6.713000e-02,4.550900e-02,4.986600e-03,& + & 4.121400e-03,3.255700e-03,2.380500e-03,1.545000e-03,5.842300e-04,& + & 8.227500e-05,1.415200e-01,1.427100e-01,1.378400e-01,1.307500e-01,& + & 1.221500e-01,1.067400e-01,8.868600e-02,6.713500e-02,4.550800e-02,& + & 4.986600e-03,4.121400e-03,3.255800e-03,2.380500e-03,1.545000e-03,& + & 5.842300e-04,8.227500e-05,1.415900e-01,1.430000e-01,1.378100e-01,& + & 1.309400e-01,1.219200e-01,1.066100e-01,8.852900e-02,6.712700e-02,& + & 4.551100e-02,4.987700e-03,4.121400e-03,3.255800e-03,2.380500e-03,& + & 1.545000e-03,5.842300e-04,8.227500e-05,1.416200e-01,1.433700e-01,& + & 1.377400e-01,1.312200e-01,1.217200e-01,1.064100e-01,8.838400e-02,& + & 6.705600e-02,4.551400e-02,4.988000e-03,4.121400e-03,3.255700e-03,& + & 2.380500e-03,1.545000e-03,5.842300e-04,8.227500e-05,1.416100e-01,& + & 1.437000e-01,1.377000e-01,1.314300e-01,1.217300e-01,1.061300e-01,& + & 8.835700e-02,6.687400e-02,4.550900e-02,4.988300e-03,4.121400e-03,& + & 3.255800e-03,2.380400e-03,1.545000e-03,5.842300e-04,8.227500e-05,& + & 1.415400e-01,1.440500e-01,1.377100e-01,1.316900e-01,1.216600e-01,& + & 1.060300e-01,8.819300e-02,6.670500e-02,4.546900e-02,4.990200e-03,& + & 4.121400e-03,3.255800e-03,2.380400e-03,1.545000e-03,5.842300e-04,& + & 8.227500e-05,1.412600e-01,1.444000e-01,1.379000e-01,1.321400e-01,& + & 1.215300e-01,1.060300e-01,8.790800e-02,6.661200e-02,4.526900e-02,& + & 4.990000e-03,4.125600e-03,3.255800e-03,2.380400e-03,1.545100e-03,& + & 5.842300e-04,8.227500e-05,1.407600e-01,1.441500e-01,1.388500e-01,& + & 1.328600e-01,1.214700e-01,1.061200e-01,8.757900e-02,6.628000e-02,& + & 4.497700e-02,4.978200e-03,4.120000e-03,3.262000e-03,2.382000e-03,& + & 1.545200e-03,5.842300e-04,8.227500e-05,1.420500e-01,1.449600e-01,& + & 1.433700e-01,1.350400e-01,1.226000e-01,1.042800e-01,8.494600e-02,& + & 6.362500e-02,4.295100e-02,4.731300e-03,3.915700e-03,3.087900e-03,& + & 2.266600e-03,1.519300e-03,5.746900e-04,8.167400e-05 / + + + data fracrefb(:,:) / & + & 1.407500e-01,1.419600e-01,1.383300e-01,1.334500e-01,1.223400e-01,& + & 1.071800e-01,8.800400e-02,6.630800e-02,4.502800e-02,4.902900e-03,& + & 4.037700e-03,3.187000e-03,2.350300e-03,1.514600e-03,5.716500e-04,& + & 8.237100e-05,1.408100e-01,1.422500e-01,1.389000e-01,1.341000e-01,& + & 1.225400e-01,1.068000e-01,8.739100e-02,6.581900e-02,4.472500e-02,& + & 4.912100e-03,4.042000e-03,3.186900e-03,2.350400e-03,1.514600e-03,& + & 5.716500e-04,8.237100e-05,1.408700e-01,1.422700e-01,1.392000e-01,& + & 1.339500e-01,1.227000e-01,1.069400e-01,8.722900e-02,6.565300e-02,& + & 4.455400e-02,4.879700e-03,4.046000e-03,3.193900e-03,2.350500e-03,& + & 1.514600e-03,5.716500e-04,8.191000e-05,1.408900e-01,1.423800e-01,& + & 1.395600e-01,1.337900e-01,1.228400e-01,1.068800e-01,8.719200e-02,& + & 6.549000e-02,4.439000e-02,4.839500e-03,4.017300e-03,3.207000e-03,& + & 2.355900e-03,1.514600e-03,5.716500e-04,8.237100e-05,1.409100e-01,& + & 1.441700e-01,1.419400e-01,1.345700e-01,1.216700e-01,1.055100e-01,& + & 8.645000e-02,6.488900e-02,4.358400e-02,4.755100e-03,3.950900e-03,& + & 3.137400e-03,2.322600e-03,1.494200e-03,5.754500e-04,8.088700e-05/ + + + data ccl4(:) / 2.614070e+01,5.397760e+01,& + & 6.380850e+01,3.617010e+01,1.540990e+01,1.023116e+01,4.829480e+00,& + & 5.038360e+00,1.755580e+00,0.000000e+00,0.000000e+00,0.000000e+00,& + & 0.000000e+00,0.000000e+00,0.000000e+00,0.000000e+00 / + +!........................................! + end module module_radlw_kgb05 ! +!========================================! + + +!> This module sets up absorption coefficients for band 06: 820-980 +!! cm-1 (low - h2o; high - /) +!========================================! + module module_radlw_kgb06 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG06 +! + implicit none +! + private +! +!> msa06=65 + integer, public :: MSA06 +!> msf06=10 + integer, public :: MSF06 +!> mfr06=4 + integer, public :: MFR06 +!> mmc06=19 + integer, public :: MMC06 + parameter (MSA06=65, MSF06=10, MFR06=4, MMC06=19) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG06=8). + real (kind=kind_phys), public :: forref(NG06,MFR06) + +!> the array absa(NG06,65) = ka(NG06,5,13) contains absorption coefs +!! at the NG06=8 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 1-5 means that the data are +!! for the corresponding temperature of tref-30, tref-15, tref, tref+15, +!! and tref+30, respectively. the second index, jp, runs from 1 to 13 +!! and refers to the corresponding pressure level in pref (e.g. jp = 1 +!! is for a pressure of 1053.63 mb). the third index, ig, goes from 1 +!! to NG06=8, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG06,MSA06) + +!> planck fraction mapping level : p = 473.4280 mb, t = 259.83 k + real (kind=kind_phys), public :: fracrefa(NG06) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG06=8). + real (kind=kind_phys), public :: selfref(NG06,MSF06) + +!> the array kao_mxx contains the absorption coefficient for +!! a minor species at the NG06=8 chosen g-values for a reference pressure +!! level below 100~ mb. the first index refers to temperature +!! in 7.2 degree increments. for instance, jt = 1 refers to a +!! temperature of 188.0, jt = 2 refers to 195.2, etc. the second index +!! runs over the g-channel (1 to NG06=8). + real (kind=kind_phys), public :: ka_mco2(NG06,MMC06) + +!> \name minor gas mapping level: + +!> lower - co2, p = 706.2720 mb, t = 294.2 k +!! upper - cfc11, cfc12 +!! original cfc11 is multiplied by 1.385 to account for the 1060-1107 \f$cm^{-1}\f$ band. + + real (kind=kind_phys), public :: cfc11adj(NG06) + real (kind=kind_phys), public :: cfc12(NG06) + + data absa(:, 1:30) / & + & 1.816778E-05,3.331369E-05,4.862866E-05,7.508101E-05,9.079919E-04,& + & 3.074720E-03,4.938645E-03,8.147995E-03,1.960096E-05,3.191632E-05,& + & 5.515207E-05,1.584024E-04,1.334289E-03,4.351895E-03,7.190164E-03,& + & 1.171354E-02,1.886836E-05,3.391404E-05,6.154182E-05,2.813256E-04,& + & 1.873246E-03,5.979790E-03,1.018998E-02,1.714935E-02,1.807910E-05,& + & 3.939037E-05,6.625004E-05,4.430787E-04,2.573255E-03,8.071066E-03,& + & 1.407840E-02,2.505653E-02,1.828969E-05,4.386289E-05,1.017438E-04,& + & 6.086306E-04,3.465943E-03,1.077741E-02,1.899586E-02,3.617463E-02,& + & 1.251411E-05,2.066073E-05,3.443010E-05,6.445765E-05,7.780029E-04,& + & 2.841471E-03,4.941332E-03,8.225843E-03,1.245365E-05,2.220642E-05,& + & 3.545047E-05,1.332637E-04,1.144768E-03,4.070917E-03,7.169576E-03,& + & 1.183492E-02,1.243114E-05,2.311619E-05,4.026072E-05,2.291431E-04,& + & 1.618078E-03,5.674612E-03,1.015243E-02,1.722409E-02,1.184652E-05,& + & 2.761128E-05,5.465259E-05,3.403420E-04,2.239250E-03,7.716210E-03,& + & 1.407042E-02,2.499323E-02,1.318941E-05,3.058466E-05,8.514107E-05,& + & 4.661045E-04,3.046456E-03,1.030017E-02,1.913373E-02,3.590661E-02,& + & 7.069995E-06,1.151501E-05,2.017053E-05,5.079725E-05,6.085891E-04,& + & 2.435205E-03,4.554366E-03,7.667926E-03,7.130966E-06,1.269381E-05,& + & 2.270268E-05,9.926966E-05,8.977246E-04,3.507129E-03,6.669421E-03,& + & 1.106688E-02,6.534342E-06,1.607840E-05,2.769847E-05,1.646037E-04,& + & 1.280469E-03,4.956553E-03,9.489471E-03,1.603283E-02,7.334086E-06,& + & 1.683274E-05,4.692548E-05,2.385844E-04,1.785776E-03,6.837181E-03,& + & 1.324715E-02,2.314943E-02,8.127093E-06,2.040950E-05,7.112489E-05,& + & 3.311738E-04,2.451957E-03,9.221366E-03,1.819459E-02,3.312357E-02,& + & 3.691448E-06,6.892982E-06,1.151986E-05,4.554795E-05,4.238287E-04,& + & 2.000930E-03,4.015226E-03,6.971000E-03,3.475303E-06,7.968458E-06,& + & 1.466355E-05,8.742066E-05,6.163547E-04,2.920968E-03,5.940071E-03,& + & 1.021822E-02,3.877320E-06,9.375919E-06,2.364147E-05,1.361313E-04,& + & 8.880364E-04,4.168452E-03,8.578366E-03,1.470186E-02,4.507705E-06,& + & 1.111077E-05,3.880750E-05,1.967550E-04,1.260207E-03,5.811380E-03,& + & 1.210107E-02,2.121880E-02,6.102484E-06,1.555228E-05,5.529495E-05,& + & 2.757011E-04,1.756930E-03,7.948719E-03,1.676546E-02,3.026917E-02,& + & 1.851860E-06,4.281922E-06,7.587298E-06,3.955277E-05,2.799356E-04,& + & 1.581760E-03,3.488755E-03,6.498658E-03,1.902420E-06,5.129255E-06,& + & 1.109620E-05,7.085752E-05,4.122316E-04,2.386260E-03,5.208449E-03,& + & 9.426862E-03,2.394844E-06,6.213869E-06,1.954280E-05,1.085746E-04,& + & 6.020064E-04,3.458007E-03,7.617712E-03,1.371301E-02,3.528177E-06,& + & 8.557033E-06,3.004548E-05,1.581442E-04,8.694991E-04,4.887948E-03,& + & 1.088713E-02,1.977459E-02,4.938211E-06,1.309928E-05,4.239703E-05,& + & 2.242352E-04,1.239667E-03,6.714328E-03,1.525422E-02,2.821438E-02,& + & 9.158322E-07,2.681414E-06,5.352967E-06,3.088400E-05,2.044575E-04,& + & 1.015781E-03,2.959679E-03,5.998968E-03,1.230601E-06,3.304463E-06,& + & 8.661776E-06,5.393626E-05,3.325263E-04,1.419953E-03,4.436616E-03,& + & 8.740404E-03,1.777639E-06,4.668036E-06,1.496163E-05,8.401406E-05,& + & 5.101641E-04,2.024311E-03,6.486706E-03,1.266526E-02,2.668150E-06,& + & 7.422722E-06,2.322281E-05,1.235242E-04,7.746651E-04,2.727379E-03,& + & 9.343553E-03,1.837121E-02,3.971880E-06,1.122588E-05,3.420714E-05,& + & 1.773073E-04,1.137322E-03,3.628774E-03,1.323726E-02,2.634547E-02/ + data absa(:, 31:65) / & + & 5.557839E-07,1.735587E-06,3.708737E-06,2.370072E-05,1.792435E-04,& + & 5.198696E-04,2.236470E-03,5.476447E-03,8.529900E-07,2.393092E-06,& + & 7.220648E-06,4.030765E-05,3.004444E-04,8.701364E-04,3.016065E-03,& + & 8.120305E-03,1.425062E-06,3.873323E-06,1.255174E-05,6.332619E-05,& + & 4.716749E-04,1.467584E-03,3.995482E-03,1.182726E-02,2.114982E-06,& + & 6.500113E-06,1.941624E-05,9.648294E-05,7.222065E-04,2.372202E-03,& + & 5.108677E-03,1.700206E-02,3.262050E-06,9.931559E-06,2.901143E-05,& + & 1.408344E-04,1.083728E-03,3.321896E-03,6.931609E-03,2.462407E-02,& + & 4.462237E-07,1.286404E-06,3.322160E-06,1.817457E-05,1.632759E-04,& + & 4.916189E-04,9.457949E-04,4.966174E-03,7.107120E-07,2.158952E-06,& + & 6.629041E-06,3.106559E-05,2.816801E-04,9.301316E-04,1.185185E-03,& + & 5.507822E-03,1.202446E-06,3.681355E-06,1.144277E-05,5.101951E-05,& + & 4.583132E-04,1.555337E-03,1.799428E-03,4.245417E-03,1.842987E-06,& + & 6.140897E-06,1.822699E-05,8.091567E-05,7.187322E-04,2.410128E-03,& + & 2.380100E-03,3.574002E-03,2.949710E-06,9.589462E-06,2.783844E-05,& + & 1.221026E-04,1.080340E-03,3.741937E-03,3.077095E-03,1.772172E-03,& + & 4.741583E-07,1.458578E-06,3.916172E-06,1.802483E-05,1.723747E-04,& + & 4.672251E-04,1.904583E-04,6.829602E-07,7.484006E-07,2.703070E-06,& + & 7.766722E-06,3.159417E-05,3.146827E-04,5.644874E-04,3.314210E-05,& + & 1.439152E-06,1.350494E-06,4.723726E-06,1.366861E-05,5.352258E-05,& + & 5.145142E-04,5.939313E-04,6.280410E-05,2.854607E-06,2.198579E-06,& + & 8.031761E-06,2.297208E-05,8.603757E-05,8.142341E-04,5.084183E-04,& + & 9.324542E-05,9.617154E-05,3.569312E-06,1.282394E-05,3.697173E-05,& + & 1.356613E-04,1.200585E-03,5.223248E-04,1.408267E-04,2.145106E-04,& + & 6.156133E-07,1.790516E-06,5.218227E-06,2.695913E-05,1.417194E-04,& + & 5.299783E-06,1.001140E-05,3.583143E-07,1.060983E-06,3.519301E-06,& + & 1.049661E-05,4.767676E-05,2.121860E-04,1.158024E-05,2.245086E-05,& + & 8.268280E-07,1.807103E-06,6.688534E-06,1.922137E-05,7.988516E-05,& + & 3.079029E-04,2.244912E-05,4.499975E-05,1.704136E-06,3.224088E-06,& + & 1.150745E-05,3.410696E-05,1.250226E-04,4.414633E-04,4.046536E-05,& + & 7.184409E-05,5.660537E-05,5.252250E-06,1.890764E-05,5.707866E-05,& + & 1.947916E-04,6.047354E-04,6.748857E-05,1.124572E-04,1.357924E-04,& + & 6.878369E-07,1.972433E-06,6.203737E-06,3.198288E-05,1.192729E-04,& + & 5.797855E-06,9.942319E-06,2.843082E-07,1.147267E-06,3.953441E-06,& + & 1.233898E-05,5.628999E-05,1.726112E-04,1.268845E-05,2.241833E-05,& + & 6.662957E-07,1.935868E-06,7.642144E-06,2.330580E-05,9.223730E-05,& + & 2.422810E-04,2.480698E-05,4.149232E-05,2.003088E-05,3.493230E-06,& + & 1.294959E-05,4.129752E-05,1.511402E-04,3.140142E-04,4.462850E-05,& + & 6.872919E-05,6.948841E-05,5.809133E-06,2.119115E-05,6.885196E-05,& + & 2.250770E-04,4.302827E-04,1.061556E-04,1.100734E-04,1.423929E-04,& + & 6.457132E-07,1.916200E-06,6.400339E-06,3.414423E-05,1.122301E-04,& + & 6.258637E-06,9.959783E-06,2.512368E-07,1.058326E-06,3.885151E-06,& + & 1.291401E-05,5.851444E-05,1.638931E-04,1.373022E-05,2.239018E-05,& + & 5.554137E-07,1.821070E-06,7.384476E-06,2.425841E-05,9.557316E-05,& + & 2.295191E-04,2.706292E-05,3.966587E-05,2.798005E-05,3.315689E-06,& + & 1.257999E-05,4.302052E-05,1.568524E-04,2.877782E-04,7.198946E-05,& + & 6.746985E-05,7.057284E-05,5.528732E-06,2.046042E-05,7.215609E-05,& + & 2.364461E-04,3.816829E-04,1.359414E-04,1.096902E-04,1.291599E-04,& + & 5.480623E-07,1.699494E-06,6.021938E-06,3.295920E-05,1.195540E-04,& + & 6.605462E-06,9.646416E-06,2.228942E-07,8.897597E-07,3.442763E-06,& + & 1.235030E-05,5.712742E-05,1.743961E-04,1.499445E-05,1.976973E-05,& + & 1.066044E-05,1.573003E-06,6.423797E-06,2.309463E-05,9.368256E-05,& + & 2.462965E-04,4.019895E-05,3.728901E-05,3.077505E-05,2.836312E-06,& + & 1.093668E-05,4.029849E-05,1.551540E-04,3.163940E-04,8.770277E-05,& + & 6.558903E-05,6.274919E-05,4.720687E-06,1.782078E-05,6.727193E-05,& + & 2.288666E-04,4.469429E-04,1.511657E-04,1.056325E-04,1.110326E-04/ + + + data ka_mco2(:, :) / & + & 1.229200E-05,1.088199E-05,1.350453E-05,8.226484E-05,3.148824E-05,& + & 3.760573E-06,2.175457E-06,1.607842E-06,1.475920E-05,1.318776E-05,& + & 1.629535E-05,9.973903E-05,3.815820E-05,4.778965E-06,2.717886E-06,& + & 2.094580E-06,1.772380E-05,1.598246E-05,1.966284E-05,1.209255E-04,& + & 4.624260E-05,6.075918E-06,3.395643E-06,2.728699E-06,2.128633E-05,& + & 1.936987E-05,2.372631E-05,1.466127E-04,5.604178E-05,7.728301E-06,& + & 4.242497E-06,3.554839E-06,2.556801E-05,2.347554E-05,2.862961E-05,& + & 1.777563E-04,6.791988E-05,9.834330E-06,5.300672E-06,4.631149E-06,& + & 3.071471E-05,2.845207E-05,3.454625E-05,2.155162E-04,8.231863E-05,& + & 1.251963E-05,6.622915E-06,6.033405E-06,3.690177E-05,3.448423E-05,& + & 4.168567E-05,2.612980E-04,9.977329E-05,1.594479E-05,8.275196E-06,& + & 7.860327E-06,4.434062E-05,4.179607E-05,5.030061E-05,3.168054E-04,& + & 1.209338E-04,2.031518E-05,1.033985E-05,1.024057E-05,5.328547E-05,& + & 5.065934E-05,6.069605E-05,3.841045E-04,1.465872E-04,2.589373E-05,& + & 1.291988E-05,1.334170E-05,6.404255E-05,6.140325E-05,7.323994E-05,& + & 4.657009E-04,1.776895E-04,3.301683E-05,1.614410E-05,1.738218E-05,& + & 7.698068E-05,7.442739E-05,8.837640E-05,5.646329E-04,2.153990E-04,& + & 4.211523E-05,2.017329E-05,2.264650E-05,9.254401E-05,9.021567E-05,& + & 1.066412E-04,6.845814E-04,2.611214E-04,5.374025E-05,2.520869E-05,& + & 2.950552E-05,1.112670E-04,1.093550E-04,1.286808E-04,8.300161E-04,& + & 3.165617E-04,6.859802E-05,3.150147E-05,3.844225E-05,1.337955E-04,& + & 1.325582E-04,1.552762E-04,1.006346E-03,3.837885E-04,8.759440E-05,& + & 3.936602E-05,5.008642E-05,1.609044E-04,1.606868E-04,1.873679E-04,& + & 1.220140E-03,4.653089E-04,1.118872E-04,4.919487E-05,6.525828E-05,& + & 1.935297E-04,1.947886E-04,2.260927E-04,1.479352E-03,5.641688E-04,& + & 1.429639E-04,6.147905E-05,8.502671E-05,2.327988E-04,2.361320E-04,& + & 2.728210E-04,1.793643E-03,6.840605E-04,1.827285E-04,7.683224E-05,& + & 1.107850E-04,2.800712E-04,2.862566E-04,3.292076E-04,2.174701E-03,& + & 8.294638E-04,2.336244E-04,9.602098E-05,1.443469E-04,3.369834E-04,& + & 3.470270E-04,3.972484E-04,2.636725E-03,1.005814E-03,2.987825E-04,& + & 1.200051E-04,1.880790E-04 / + + + data selfref(:, :) / & + & 8.104007E-02,9.051144E-02,8.488708E-02,7.523175E-02,7.285671E-02,& + & 9.040726E-02,9.108606E-02,9.448533E-02,6.775328E-02,7.666656E-02,& + & 7.418480E-02,6.664536E-02,6.447805E-02,7.786369E-02,7.875249E-02,& + & 8.167191E-02,5.664527E-02,6.494079E-02,6.485676E-02,5.904314E-02,& + & 5.706303E-02,6.706056E-02,6.808981E-02,7.059688E-02,4.735876E-02,& + & 5.500955E-02,5.672356E-02,5.231175E-02,5.050074E-02,5.775632E-02,& + & 5.887164E-02,6.102428E-02,3.959499E-02,4.659811E-02,4.962958E-02,& + & 4.635101E-02,4.469309E-02,4.974308E-02,5.090216E-02,5.275031E-02,& + & 3.310417E-02,3.947360E-02,4.343961E-02,4.107239E-02,3.955333E-02,& + & 4.284165E-02,4.401206E-02,4.559862E-02,2.767768E-02,3.343918E-02,& + & 3.803661E-02,3.639743E-02,3.500465E-02,3.689775E-02,3.805522E-02,& + & 3.941698E-02,2.314081E-02,2.832776E-02,3.331862E-02,3.225683E-02,& + & 3.097913E-02,3.177853E-02,3.290500E-02,3.407371E-02,1.934779E-02,& + & 2.399820E-02,2.919727E-02,2.858925E-02,2.741653E-02,2.736956E-02,& + & 2.845217E-02,2.945506E-02,1.617660E-02,2.033082E-02,2.559575E-02,& + & 2.534039E-02,2.426361E-02,2.357239E-02,2.460231E-02,2.546275E-02/ + + + data forref(:, :) / & + & 4.229942E-07,1.253070E-06,3.301641E-06,3.223462E-06,2.413032E-06,& + & 2.555740E-06,2.737261E-06,2.968633E-06,9.286954E-07,2.199977E-06,& + & 2.699385E-06,1.788712E-06,1.472729E-06,2.636157E-06,2.445935E-06,& + & 2.595090E-06,1.672147E-06,2.677944E-06,1.835306E-06,1.055155E-06,& + & 1.111783E-06,5.010556E-07,3.236474E-07,3.077813E-07,1.723301E-06,& + & 2.098087E-06,2.267954E-06,1.321898E-06,8.660148E-07,7.939696E-07,& + & 7.133265E-07,3.134393E-07 / + + + data fracrefa(:) / 2.912700e-01,2.825200e-01,2.259000e-01,& + & 1.431360e-01,4.549370e-02,7.179200e-03,3.848300e-03,6.571200e-04/ + +! --- minor gas mapping level: +! lower - co2, p = 706.2720 mb, t = 294.2 k +! upper - cfc11, cfc12 +! original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band. + + data cfc11adj(:) / 0.000000e+00,9.159319e+01,7.840117e+01,& + & 5.366472e+01,5.799243e+01,1.005060e+02,1.678709e+02,2.365097e+02/ + + data cfc12(:) / 5.316576e+01,2.458745e+01,2.874905e+01,& + & 2.494402e+01,1.796895e+01,2.334803e+01,2.859035e+01,2.096531e+01/ + + +!........................................! + end module module_radlw_kgb06 ! +!========================================! + + +!> This module sets up absorption coefficients for band 07: 980-1080 +!! cm-1 (low - h2o, o3; high - o3) +!========================================! + module module_radlw_kgb07 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG07 +! + implicit none +! + private +! +!> msa07=585 + integer, public :: MSA07 +!> msb07=235 + integer, public :: MSB07 +!> msf07=10 + integer, public :: MSF07 +!> mfr07=4 + integer, public :: MFR07 +!> maf07=9 + integer, public :: MAF07 +!> mmc07=19 + integer, public :: MMC07 + parameter (MSA07=585, MSB07=235, MSF07=10, MFR07=4) + parameter (MAF07=9, MMC07=19) + + real (kind=kind_phys), public :: forref(NG07,MFR07) + +!> the array absa(NG07,585) = ka(NG07,9,5,13) contains absorption coefs +!! at the NG07=12 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different column +!! amount ratios, as expressed through the binary species parameter eta, +!! defined as eta = gas1/(gas1+(rat)*gas2), where rat is the ratio of +!! the reference mls column amount value of gas1 to that of gas2. the +!! 2nd index in the array, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that the +!! data are for the corresponding temperature of tref-30, tref-15, tref, +!! tref+15, and tref+30, respectively. the third index, jp, runs from +!! 1 to 13 and refers to the reference pressure level (e.g. jp = 1 is +!! for a pressure of 1053.63 mb). the fourth index, ig, goes from 1 to +!! NG07=12, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG07,MSA07) + +!> the array absb(NG07,235) = kb(NG07,5,13:59) contains absorption coefs +!! at the NG07=12 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG07=12, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG07,MSB07) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG07=12). + real (kind=kind_phys), public :: selfref(NG07,MSF07) + +!> planck fraction mapping level : p = 706.27 mb, t = 278.94 k + real (kind=kind_phys), public :: fracrefa(NG07,MAF07) + +!> planck data fraction mapping level : p=95.58 mbar, t= 215.70 k + real (kind=kind_phys), public :: fracrefb(NG07) + +!> the array ka_mxxx contains the absorption coefficient for a minor +!! species at the NG07=12 chosen g-values for a reference pressure +!! level below 100~ mb. the first index in the array, js, runs from +!! 1 to 9, and corresponds to different gas column amount ratios, as +!! expressed through the binary species parameter eta, defined as +!! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +!! reference mls column amount value of gas1 to that of gas2. the +!! second index refers to temperature in 7.2 degree increments. for +!! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers +!! to 195.2, etc. the third index runs over the g-channel (1 to NG07=12). + real (kind=kind_phys), public :: ka_mco2(NG07,MAF07,MMC07) + +!> the array kb_mxxx contains absorption coefficient for a minor +!! species at the NG07=12 chosen g-values for a reference pressure +!! level above 100~ mb. the first index refers to temperature +!! in 7.2 degree increments. for instance, jt = 1 refers to a +!! temperature of 188.0, jt = 2 refers to 195.2, etc. the second index +!! runs over the g-channel (1 to NG07=12). + real (kind=kind_phys), public :: kb_mco2(NG07,MMC07) + + data absa( : , 1: 25) / & + & 3.094127E-06,1.554128E-05,3.189000E-05,4.060800E-05,4.935100E-05,& + & 5.644000E-05,6.291700E-05,5.659200E-05,4.709800E-05,6.490000E-05,& + & 7.687083E-05,9.017125E-05,3.876058E-06,1.865920E-05,3.342800E-05,& + & 4.218500E-05,5.163400E-05,6.381500E-05,8.455800E-05,1.338000E-04,& + & 1.803600E-04,2.871900E-04,6.806856E-04,1.777857E-03,5.351816E-06,& + & 1.812292E-05,3.133900E-05,3.973000E-05,5.055000E-05,6.704000E-05,& + & 1.368600E-04,2.825900E-04,3.481900E-04,5.630700E-04,1.344329E-03,& + & 3.506182E-03,1.637042E-05,1.678024E-05,1.906200E-05,2.663000E-05,& + & 4.143600E-05,7.265600E-05,1.974000E-04,4.072500E-04,5.063800E-04,& + & 8.435100E-04,1.998442E-03,5.173975E-03,1.911639E-05,2.887446E-05,& + & 2.135900E-05,1.587000E-05,1.637600E-05,5.707500E-05,2.496700E-04,& + & 5.272200E-04,6.618100E-04,1.129100E-03,2.637161E-03,6.738118E-03,& + & 2.123532E-05,3.183524E-05,2.619000E-05,2.172000E-05,2.106500E-05,& + & 3.549700E-05,2.751500E-04,6.377100E-04,8.106500E-04,1.421100E-03,& + & 3.246200E-03,8.117529E-03,2.352714E-05,3.785873E-05,4.236400E-05,& + & 4.018300E-05,3.562700E-05,4.719700E-05,1.633800E-04,7.361800E-04,& + & 9.390200E-04,1.720100E-03,3.784674E-03,9.106720E-03,3.351108E-05,& + & 5.743351E-05,7.228100E-05,5.793300E-05,5.130100E-05,3.906400E-05,& + & 4.822300E-05,6.880900E-05,7.716700E-04,1.985200E-03,4.077927E-03,& + & 9.006545E-03,1.365068E-05,2.187865E-05,2.880100E-05,1.923000E-05,& + & 2.419200E-05,8.470500E-05,4.672800E-04,1.023000E-03,1.302200E-03,& + & 2.246900E-03,5.263201E-03,1.346739E-02,3.933113E-06,1.694056E-05,& + & 3.224100E-05,4.056000E-05,4.847400E-05,5.695600E-05,5.308900E-05,& + & 3.400000E-05,3.003300E-05,3.463500E-05,6.827642E-05,8.549327E-05,& + & 5.055579E-06,2.098743E-05,3.503400E-05,4.392400E-05,5.554000E-05,& + & 6.944000E-05,9.042000E-05,1.776200E-04,2.652300E-04,4.054200E-04,& + & 9.710838E-04,2.558060E-03,5.560687E-06,2.165385E-05,3.431100E-05,& + & 4.284300E-05,5.634300E-05,7.500200E-05,1.825100E-04,3.928200E-04,& + & 5.079500E-04,7.973100E-04,1.921734E-03,5.048661E-03,1.160709E-05,& + & 1.745914E-05,2.933700E-05,4.058700E-05,5.422100E-05,9.172400E-05,& + & 2.767000E-04,5.718900E-04,7.480300E-04,1.192900E-03,2.858520E-03,& + & 7.451192E-03,2.000366E-05,2.422996E-05,1.695600E-05,1.959900E-05,& + & 4.217000E-05,1.178600E-04,3.588600E-04,7.474400E-04,9.832100E-04,& + & 1.596800E-03,3.773151E-03,9.706619E-03,2.132727E-05,3.101518E-05,& + & 2.715300E-05,1.943400E-05,2.482300E-05,1.158100E-04,4.383400E-04,& + & 9.157800E-04,1.208000E-03,2.014800E-03,4.645001E-03,1.169877E-02,& + & 2.501562E-05,3.804454E-05,4.159500E-05,2.918700E-05,3.173100E-05,& + & 7.212400E-05,4.947700E-04,1.073900E-03,1.417400E-03,2.451800E-03,& + & 5.419593E-03,1.312857E-02,3.329270E-05,5.861753E-05,7.580700E-05,& + & 8.172900E-05,5.920100E-05,6.386200E-05,2.392900E-04,1.153000E-03,& + & 1.617600E-03,2.875000E-03,5.882281E-03,1.299049E-02,1.455198E-05,& + & 2.274940E-05,2.164200E-05,2.418000E-05,4.873300E-05,2.033200E-04,& + & 6.873000E-04,1.465200E-03,1.942800E-03,3.181700E-03,7.533603E-03,& + & 1.940271E-02,4.842903E-06,1.819642E-05,3.268500E-05,4.059600E-05,& + & 4.749200E-05,5.485600E-05,4.303900E-05,3.182200E-05,3.054400E-05,& + & 3.038600E-05,4.207247E-05,7.635387E-05,6.411320E-06,2.334008E-05,& + & 3.710400E-05,4.522300E-05,6.019900E-05,7.483500E-05,1.094600E-04,& + & 2.431300E-04,3.712800E-04,5.554400E-04,1.333059E-03,3.534718E-03,& + & 6.850488E-06,2.446877E-05,3.723900E-05,4.723300E-05,6.303200E-05,& + & 8.938100E-05,2.442900E-04,5.273800E-04,7.205800E-04,1.094700E-03,& + & 2.641417E-03,6.978015E-03,8.867059E-06,2.301692E-05,3.544000E-05,& + & 4.820600E-05,6.631700E-05,1.168800E-04,3.796100E-04,7.759500E-04,& + & 1.067100E-03,1.636100E-03,3.931397E-03,1.030143E-02,1.935026E-05,& + & 1.811812E-05,2.468300E-05,4.181500E-05,6.864700E-05,1.648000E-04,& + & 4.968900E-04,1.023100E-03,1.408400E-03,2.183500E-03,5.191031E-03,& + & 1.342519E-02,2.236355E-05,2.853869E-05,2.058400E-05,2.428200E-05,& + & 6.454100E-05,2.040300E-04,6.128800E-04,1.264000E-03,1.739100E-03,& + & 2.744400E-03,6.391890E-03,1.618297E-02,2.507779E-05,3.816578E-05,& + & 3.946700E-05,2.753500E-05,4.030800E-05,2.172300E-04,7.227400E-04,& + & 1.500000E-03,2.037900E-03,3.345600E-03,7.457167E-03,1.816789E-02/ + data absa( : , 26: 50) / & + & 3.584406E-05,5.901743E-05,7.049800E-05,5.302500E-05,5.542100E-05,& + & 1.206800E-04,7.724000E-04,1.696700E-03,2.303200E-03,3.957200E-03,& + & 8.098625E-03,1.799816E-02,1.330096E-05,2.294611E-05,2.543300E-05,& + & 4.576900E-05,1.038500E-04,2.998200E-04,9.643100E-04,2.018100E-03,& + & 2.793800E-03,4.350900E-03,1.036816E-02,2.683838E-02,5.883589E-06,& + & 1.927198E-05,3.310800E-05,4.042400E-05,4.573100E-05,5.274900E-05,& + & 3.406900E-05,3.188700E-05,3.047200E-05,2.189600E-05,2.977770E-05,& + & 6.808475E-05,7.989408E-06,2.574719E-05,3.923300E-05,4.752700E-05,& + & 6.448000E-05,8.484900E-05,1.383000E-04,3.173000E-04,4.975700E-04,& + & 7.474600E-04,1.770771E-03,4.718274E-03,8.636030E-06,2.735979E-05,& + & 3.984300E-05,5.379800E-05,7.065600E-05,1.120500E-04,3.217700E-04,& + & 7.014200E-04,9.816800E-04,1.474100E-03,3.512333E-03,9.319162E-03,& + & 9.388291E-06,2.702416E-05,4.063200E-05,5.711900E-05,8.092700E-05,& + & 1.506400E-04,5.087800E-04,1.037600E-03,1.460600E-03,2.199200E-03,& + & 5.229333E-03,1.376056E-02,1.343692E-05,2.373414E-05,3.935100E-05,& + & 5.765800E-05,9.120900E-05,2.174100E-04,6.699400E-04,1.371600E-03,& + & 1.937400E-03,2.923800E-03,6.905458E-03,1.793414E-02,2.223945E-05,& + & 2.292651E-05,2.749200E-05,5.226800E-05,1.081200E-04,2.817800E-04,& + & 8.294500E-04,1.703200E-03,2.405700E-03,3.652700E-03,8.503647E-03,& + & 2.162182E-02,2.550760E-05,3.816073E-05,2.737200E-05,3.635500E-05,& + & 1.117700E-04,3.395800E-04,9.841300E-04,2.025600E-03,2.844900E-03,& + & 4.409300E-03,9.922397E-03,2.428678E-02,3.546374E-05,6.077446E-05,& + & 6.613600E-05,4.494100E-05,6.757800E-05,3.647500E-04,1.112500E-03,& + & 2.335500E-03,3.163600E-03,5.245400E-03,1.077264E-02,2.407867E-02,& + & 1.489513E-05,2.063867E-05,4.294000E-05,8.691000E-05,1.505300E-04,& + & 4.057200E-04,1.310900E-03,2.715900E-03,3.851700E-03,5.828800E-03,& + & 1.379605E-02,3.585616E-02,7.078622E-06,2.010448E-05,3.310200E-05,& + & 4.023400E-05,4.553600E-05,4.564500E-05,3.039900E-05,3.297400E-05,& + & 2.409100E-05,2.297800E-05,2.563829E-05,3.469057E-05,9.789400E-06,& + & 2.812303E-05,4.112600E-05,5.168500E-05,6.879100E-05,1.008500E-04,& + & 1.754800E-04,4.050000E-04,6.544400E-04,9.872800E-04,2.285266E-03,& + & 6.115002E-03,1.066494E-05,3.033487E-05,4.370600E-05,6.070300E-05,& + & 8.436100E-05,1.395400E-04,4.176000E-04,9.209600E-04,1.293400E-03,& + & 1.948400E-03,4.536088E-03,1.207928E-02,1.111451E-05,3.060633E-05,& + & 4.760000E-05,6.717300E-05,1.000800E-04,1.941100E-04,6.673100E-04,& + & 1.370100E-03,1.929500E-03,2.903400E-03,6.756768E-03,1.783600E-02,& + & 1.210071E-05,2.981238E-05,5.051400E-05,7.347300E-05,1.155800E-04,& + & 2.839300E-04,8.816700E-04,1.816200E-03,2.567600E-03,3.849400E-03,& + & 8.923866E-03,2.325729E-02,1.935208E-05,2.411221E-05,4.946300E-05,& + & 7.826400E-05,1.431000E-04,3.728900E-04,1.094100E-03,2.259400E-03,& + & 3.200300E-03,4.785900E-03,1.098910E-02,2.804509E-02,2.488873E-05,& + & 3.232400E-05,3.648200E-05,7.754200E-05,1.813800E-04,4.578400E-04,& + & 1.301500E-03,2.686700E-03,3.814400E-03,5.721600E-03,1.282605E-02,& + & 3.152284E-02,3.591642E-05,6.139637E-05,4.914700E-05,6.156100E-05,& + & 1.786000E-04,5.574400E-04,1.485400E-03,3.097300E-03,4.243900E-03,& + & 6.741400E-03,1.392184E-02,3.126931E-02,1.311403E-05,2.995485E-05,& + & 6.697000E-05,1.187800E-04,2.033900E-04,5.392800E-04,1.734800E-03,& + & 3.604300E-03,5.112300E-03,7.677700E-03,1.783240E-02,4.650046E-02,& + & 4.408229E-06,2.541962E-05,5.393600E-05,7.174300E-05,8.785300E-05,& + & 1.054000E-04,1.190000E-04,1.284600E-04,1.381600E-04,1.574900E-04,& + & 1.436688E-04,1.610242E-04,5.037821E-06,2.733839E-05,5.370500E-05,& + & 6.977600E-05,8.597500E-05,1.051300E-04,1.283600E-04,1.552200E-04,& + & 1.615300E-04,2.086600E-04,6.177252E-04,1.793308E-03,5.197486E-06,& + & 2.643376E-05,4.953400E-05,6.406900E-05,8.021700E-05,1.004200E-04,& + & 1.423100E-04,2.765500E-04,3.384900E-04,4.678700E-04,1.212844E-03,& + & 3.546360E-03,8.296724E-06,2.210625E-05,4.348300E-05,5.625300E-05,& + & 7.215800E-05,9.625800E-05,1.801400E-04,3.837900E-04,4.769500E-04,& + & 6.874200E-04,1.803849E-03,5.259721E-03,2.114717E-05,2.209387E-05,& + & 2.446800E-05,3.249200E-05,5.192300E-05,8.897000E-05,2.252600E-04,& + & 4.907900E-04,6.125000E-04,9.107100E-04,2.387483E-03,6.907865E-03/ + data absa( : , 51: 75) / & + & 2.234217E-05,3.774977E-05,2.731400E-05,1.529900E-05,1.771400E-05,& + & 4.318400E-05,2.632900E-04,5.952900E-04,7.420700E-04,1.138200E-03,& + & 2.956199E-03,8.429678E-03,2.270484E-05,3.645538E-05,3.087400E-05,& + & 2.597900E-05,2.355100E-05,2.969200E-05,2.298100E-04,6.914100E-04,& + & 8.576800E-04,1.378000E-03,3.489905E-03,9.673460E-03,2.582105E-05,& + & 4.061385E-05,5.561400E-05,5.842200E-05,3.400100E-05,3.391300E-05,& + & 4.744700E-05,5.679600E-04,9.186100E-04,1.623600E-03,3.886058E-03,& + & 1.003101E-02,9.156225E-06,1.462327E-05,1.665800E-05,1.326500E-05,& + & 1.884300E-05,8.028400E-05,3.992300E-04,9.276700E-04,1.170800E-03,& + & 1.797100E-03,4.755036E-03,1.380036E-02,5.654620E-06,2.768213E-05,& + & 5.486000E-05,7.106100E-05,8.740600E-05,1.055900E-04,1.138400E-04,& + & 6.599000E-05,6.106600E-05,6.461300E-05,1.279414E-04,1.491940E-04,& + & 6.578055E-06,3.044425E-05,5.584500E-05,7.209700E-05,8.895000E-05,& + & 1.094000E-04,1.270300E-04,1.655200E-04,1.797400E-04,2.951600E-04,& + & 8.940259E-04,2.623730E-03,6.601686E-06,3.005278E-05,5.228000E-05,& + & 6.727400E-05,8.597600E-05,1.077000E-04,1.617000E-04,3.741900E-04,& + & 4.765100E-04,6.783200E-04,1.762431E-03,5.192799E-03,7.251694E-06,& + & 2.791828E-05,4.757200E-05,6.073400E-05,7.924700E-05,1.038100E-04,& + & 2.394700E-04,5.364800E-04,6.852000E-04,1.003300E-03,2.624651E-03,& + & 7.705871E-03,1.554853E-05,2.062256E-05,3.645900E-05,5.128000E-05,& + & 6.953200E-05,1.066400E-04,3.194500E-04,6.968900E-04,8.913900E-04,& + & 1.331000E-03,3.475723E-03,1.012119E-02,2.335059E-05,3.198895E-05,& + & 1.994600E-05,2.152000E-05,3.639500E-05,1.150200E-04,3.888800E-04,& + & 8.537500E-04,1.093000E-03,1.663000E-03,4.307210E-03,1.235674E-02,& + & 2.383653E-05,3.545533E-05,3.164300E-05,1.991100E-05,2.270600E-05,& + & 8.178500E-05,4.493600E-04,1.003100E-03,1.284800E-03,2.007100E-03,& + & 5.086452E-03,1.418553E-02,2.636268E-05,4.279898E-05,4.899100E-05,& + & 4.452900E-05,4.103300E-05,5.352500E-05,3.606300E-04,1.109500E-03,& + & 1.427800E-03,2.402800E-03,5.679672E-03,1.472714E-02,8.767430E-06,& + & 1.677040E-05,1.349000E-05,1.952300E-05,5.554400E-05,1.420200E-04,& + & 5.902000E-04,1.339300E-03,1.734600E-03,2.632700E-03,6.929219E-03,& + & 2.022539E-02,7.035704E-06,2.978788E-05,5.570900E-05,7.084100E-05,& + & 8.736800E-05,1.021800E-04,9.634400E-05,5.643500E-05,5.783100E-05,& + & 5.707800E-05,7.877226E-05,1.418893E-04,8.380512E-06,3.355742E-05,& + & 5.801400E-05,7.437000E-05,9.302000E-05,1.156800E-04,1.354000E-04,& + & 1.553400E-04,2.002800E-04,4.593300E-04,1.242717E-03,3.677358E-03,& + & 8.475790E-06,3.354391E-05,5.530600E-05,7.076000E-05,9.144200E-05,& + & 1.177300E-04,2.020200E-04,5.036300E-04,6.561200E-04,9.611800E-04,& + & 2.457203E-03,7.282465E-03,8.444722E-06,3.205324E-05,5.140400E-05,& + & 6.565500E-05,8.807300E-05,1.201600E-04,3.206300E-04,7.303400E-04,& + & 9.585900E-04,1.423600E-03,3.662523E-03,1.081036E-02,1.133493E-05,& + & 2.708842E-05,4.552000E-05,6.030600E-05,8.229500E-05,1.303900E-04,& + & 4.436700E-04,9.536900E-04,1.260500E-03,1.885700E-03,4.852539E-03,& + & 1.420471E-02,2.364189E-05,2.178565E-05,2.792000E-05,4.102000E-05,& + & 7.290100E-05,1.651200E-04,5.456600E-04,1.171100E-03,1.562500E-03,& + & 2.348600E-03,6.014620E-03,1.734873E-02,2.459962E-05,3.315046E-05,& + & 2.469700E-05,2.446600E-05,4.335400E-05,1.888400E-04,6.448900E-04,& + & 1.382700E-03,1.855400E-03,2.816800E-03,7.106324E-03,1.992021E-02,& + & 2.808685E-05,4.340365E-05,4.829800E-05,3.098100E-05,4.661800E-05,& + & 1.203100E-04,7.255000E-04,1.560800E-03,2.098800E-03,3.347200E-03,& + & 7.936392E-03,2.069416E-02,9.676872E-06,1.342469E-05,2.244200E-05,& + & 4.736800E-05,9.474800E-05,2.036300E-04,8.358000E-04,1.846100E-03,& + & 2.479800E-03,3.737700E-03,9.680867E-03,2.838943E-02,8.534822E-06,& + & 3.164552E-05,5.659400E-05,7.099500E-05,8.643900E-05,9.848700E-05,& + & 7.783500E-05,5.417400E-05,5.451600E-05,4.926200E-05,5.392570E-05,& + & 1.221699E-04,1.053045E-05,3.656560E-05,6.042100E-05,7.635800E-05,& + & 9.804100E-05,1.192200E-04,1.609900E-04,1.781000E-04,2.306400E-04,& + & 6.587700E-04,1.668435E-03,4.967103E-03,1.069471E-05,3.716705E-05,& + & 5.871000E-05,7.408500E-05,9.937300E-05,1.328100E-04,2.599400E-04,& + & 6.690500E-04,8.806200E-04,1.330100E-03,3.305476E-03,9.842937E-03/ + data absa( : , 76:100) / & + & 1.050501E-05,3.587798E-05,5.555300E-05,7.226300E-05,9.864300E-05,& + & 1.460600E-04,4.261000E-04,9.768600E-04,1.301700E-03,1.972600E-03,& + & 4.930780E-03,1.461435E-02,1.084605E-05,3.314149E-05,5.053300E-05,& + & 6.962700E-05,9.744700E-05,1.654900E-04,6.018900E-04,1.278300E-03,& + & 1.722300E-03,2.611100E-03,6.534888E-03,1.920692E-02,1.696966E-05,& + & 2.565262E-05,4.184900E-05,6.341200E-05,9.746200E-05,2.178400E-04,& + & 7.441400E-04,1.573700E-03,2.143600E-03,3.243600E-03,8.103659E-03,& + & 2.345810E-02,2.472563E-05,2.906333E-05,2.392600E-05,3.901000E-05,& + & 9.890500E-05,2.742700E-04,8.853100E-04,1.861100E-03,2.564500E-03,& + & 3.866200E-03,9.576392E-03,2.695339E-02,2.778838E-05,4.301349E-05,& + & 4.433200E-05,3.322000E-05,6.137200E-05,3.059500E-04,1.021000E-03,& + & 2.117800E-03,2.956500E-03,4.505200E-03,1.070411E-02,2.803967E-02,& + & 9.497689E-06,1.617148E-05,3.807700E-05,7.394100E-05,1.347300E-04,& + & 2.802900E-04,1.148100E-03,2.494200E-03,3.403800E-03,5.184700E-03,& + & 1.304359E-02,3.839096E-02,1.014683E-05,3.336300E-05,5.698900E-05,& + & 7.141800E-05,8.414900E-05,9.498700E-05,6.095900E-05,5.237000E-05,& + & 5.530900E-05,4.013200E-05,4.624183E-05,6.846308E-05,1.285580E-05,& + & 3.967857E-05,6.330100E-05,7.872000E-05,1.026900E-04,1.284600E-04,& + & 1.962500E-04,1.959700E-04,3.044800E-04,8.968200E-04,2.173707E-03,& + & 6.502217E-03,1.324284E-05,4.071163E-05,6.270200E-05,7.935000E-05,& + & 1.085100E-04,1.559100E-04,3.351500E-04,8.604400E-04,1.170500E-03,& + & 1.799300E-03,4.312892E-03,1.288941E-02,1.304985E-05,4.004610E-05,& + & 5.955600E-05,8.048700E-05,1.123200E-04,1.826800E-04,5.602900E-04,& + & 1.270600E-03,1.734000E-03,2.670500E-03,6.437332E-03,1.914058E-02,& + & 1.265458E-05,3.769564E-05,5.707500E-05,8.063500E-05,1.169400E-04,& + & 2.144200E-04,7.961800E-04,1.672900E-03,2.296600E-03,3.533400E-03,& + & 8.536656E-03,2.515967E-02,1.378811E-05,3.299963E-05,5.432800E-05,& + & 7.896700E-05,1.238400E-04,2.854700E-04,9.909200E-04,2.070300E-03,& + & 2.860100E-03,4.380600E-03,1.058513E-02,3.074197E-02,2.414001E-05,& + & 2.368160E-05,4.210600E-05,7.407000E-05,1.361500E-04,3.687700E-04,& + & 1.182200E-03,2.460300E-03,3.428000E-03,5.196000E-03,1.251385E-02,& + & 3.533705E-02,2.782695E-05,4.427095E-05,3.043500E-05,4.750900E-05,& + & 1.525400E-04,4.465700E-04,1.366100E-03,2.834200E-03,3.990000E-03,& + & 5.959200E-03,1.399175E-02,3.678883E-02,8.580763E-06,2.509767E-05,& + & 5.530400E-05,9.945100E-05,1.818800E-04,3.774600E-04,1.539300E-03,& + & 3.291800E-03,4.545800E-03,7.026200E-03,1.704483E-02,5.029509E-02,& + & 8.630405E-06,5.799442E-05,1.305400E-04,1.780400E-04,2.241700E-04,& + & 2.764700E-04,3.438400E-04,4.446900E-04,4.552500E-04,4.453600E-04,& + & 4.873494E-04,4.393502E-04,8.723386E-06,5.646754E-05,1.224300E-04,& + & 1.630900E-04,2.040400E-04,2.524600E-04,3.190100E-04,4.034600E-04,& + & 4.165900E-04,4.214000E-04,5.444990E-04,1.649233E-03,8.237409E-06,& + & 5.195799E-05,1.096000E-04,1.460300E-04,1.823500E-04,2.277000E-04,& + & 2.965600E-04,3.712400E-04,4.004100E-04,4.132600E-04,9.941627E-04,& + & 3.253078E-03,7.697394E-06,4.623963E-05,9.539600E-05,1.264000E-04,& + & 1.597400E-04,2.004100E-04,2.716100E-04,3.907200E-04,4.359400E-04,& + & 5.878400E-04,1.479696E-03,4.839938E-03,9.039786E-06,3.775260E-05,& + & 7.946600E-05,1.053200E-04,1.353600E-04,1.747200E-04,2.495600E-04,& + & 4.626500E-04,5.684100E-04,7.337600E-04,1.953802E-03,6.399287E-03,& + & 1.919811E-05,2.657003E-05,5.129300E-05,7.785100E-05,1.073300E-04,& + & 1.468100E-04,2.457500E-04,5.351800E-04,6.682400E-04,8.841000E-04,& + & 2.423106E-03,7.904363E-03,2.802230E-05,4.858866E-05,3.975500E-05,& + & 3.040100E-05,2.888900E-05,4.567700E-05,2.489200E-04,6.067000E-04,& + & 7.655900E-04,1.035300E-03,2.882623E-03,9.276427E-03,2.435896E-05,& + & 4.308016E-05,3.447500E-05,3.280800E-05,2.329200E-05,2.918500E-05,& + & 1.287400E-04,6.572300E-04,8.327500E-04,1.186800E-03,3.299156E-03,& + & 1.018548E-02,5.114661E-06,8.649399E-06,8.069800E-06,1.027800E-05,& + & 2.761000E-05,7.970400E-05,2.550000E-04,7.690100E-04,9.867300E-04,& + & 1.350600E-03,3.857475E-03,1.276320E-02,1.105514E-05,6.315881E-05,& + & 1.325400E-04,1.780700E-04,2.250700E-04,2.784600E-04,3.265100E-04,& + & 2.782100E-04,2.756400E-04,3.636000E-04,3.647010E-04,3.867809E-04/ + data absa( : ,101:125) / & + & 1.138210E-05,6.243557E-05,1.263100E-04,1.665600E-04,2.090500E-04,& + & 2.606000E-04,2.998700E-04,2.876900E-04,3.114300E-04,3.566700E-04,& + & 7.026333E-04,2.475491E-03,1.080253E-05,5.793036E-05,1.142200E-04,& + & 1.505900E-04,1.894500E-04,2.362200E-04,2.840700E-04,3.463600E-04,& + & 4.013300E-04,4.910100E-04,1.491114E-03,4.894278E-03,9.964412E-06,& + & 5.205683E-05,1.001700E-04,1.315900E-04,1.688900E-04,2.096800E-04,& + & 2.682200E-04,4.577200E-04,6.453900E-04,8.421000E-04,2.207306E-03,& + & 7.288136E-03,9.475443E-06,4.491894E-05,8.472400E-05,1.102400E-04,& + & 1.444200E-04,1.832200E-04,2.838200E-04,6.373300E-04,8.101000E-04,& + & 1.079100E-03,2.920457E-03,9.640875E-03,1.367069E-05,3.305968E-05,& + & 6.697000E-05,8.696600E-05,1.161900E-04,1.541400E-04,3.269800E-04,& + & 7.557500E-04,9.748300E-04,1.318100E-03,3.627166E-03,1.191309E-02,& + & 2.937372E-05,3.405577E-05,3.198500E-05,3.839000E-05,5.949600E-05,& + & 1.234800E-04,3.769000E-04,8.729000E-04,1.132600E-03,1.559000E-03,& + & 4.318846E-03,1.398543E-02,2.654671E-05,4.087681E-05,3.174800E-05,& + & 2.717800E-05,2.452400E-05,3.896100E-05,3.898400E-04,9.777900E-04,& + & 1.260600E-03,1.808500E-03,4.950553E-03,1.536936E-02,5.198429E-06,& + & 8.128092E-06,1.166800E-05,2.371200E-05,5.664100E-05,1.233600E-04,& + & 3.809700E-04,1.124800E-03,1.478300E-03,2.051600E-03,5.785128E-03,& + & 1.924021E-02,1.382723E-05,6.816067E-05,1.345100E-04,1.783800E-04,& + & 2.233800E-04,2.776300E-04,3.113300E-04,1.671200E-04,1.575500E-04,& + & 1.507700E-04,2.601100E-04,3.689797E-04,1.445742E-05,6.829892E-05,& + & 1.306900E-04,1.697200E-04,2.129800E-04,2.642700E-04,2.982500E-04,& + & 2.013500E-04,2.026200E-04,2.929700E-04,9.585867E-04,3.546109E-03,& + & 1.390276E-05,6.374000E-05,1.184900E-04,1.561600E-04,1.958800E-04,& + & 2.455300E-04,2.889200E-04,3.166400E-04,4.423300E-04,7.291700E-04,& + & 2.118957E-03,7.020481E-03,1.281669E-05,5.788919E-05,1.044900E-04,& + & 1.374700E-04,1.764700E-04,2.240600E-04,2.898300E-04,6.025900E-04,& + & 8.805800E-04,1.208100E-03,3.146251E-03,1.046208E-02,1.168908E-05,& + & 5.086110E-05,8.944100E-05,1.172800E-04,1.532100E-04,1.985600E-04,& + & 3.485700E-04,8.617700E-04,1.124000E-03,1.572300E-03,4.168409E-03,& + & 1.383682E-02,1.167571E-05,4.179950E-05,7.306600E-05,9.507000E-05,& + & 1.270600E-04,1.710100E-04,4.415100E-04,1.037300E-03,1.365500E-03,& + & 1.933900E-03,5.183307E-03,1.711020E-02,2.564311E-05,2.584699E-05,& + & 4.043300E-05,6.756300E-05,9.476500E-05,1.571400E-04,5.359600E-04,& + & 1.210600E-03,1.602300E-03,2.290200E-03,6.176953E-03,2.009821E-02,& + & 2.670820E-05,3.988886E-05,3.206900E-05,2.239600E-05,2.760100E-05,& + & 1.364500E-04,6.066200E-04,1.375200E-03,1.818300E-03,2.637700E-03,& + & 7.085932E-03,2.210334E-02,5.499576E-06,8.946938E-06,2.111900E-05,& + & 4.245900E-05,8.445800E-05,1.776400E-04,5.542200E-04,1.572300E-03,& + & 2.106000E-03,3.040000E-03,8.276002E-03,2.762615E-02,1.698841E-05,& + & 7.279444E-05,1.362000E-04,1.785700E-04,2.234200E-04,2.707300E-04,& + & 2.665000E-04,1.530300E-04,1.522500E-04,1.416300E-04,1.568469E-04,& + & 3.400944E-04,1.802847E-05,7.406355E-05,1.341800E-04,1.747500E-04,& + & 2.172800E-04,2.668400E-04,2.903200E-04,2.345200E-04,2.136000E-04,& + & 2.242600E-04,1.284655E-03,4.878351E-03,1.749444E-05,6.965861E-05,& + & 1.228700E-04,1.610000E-04,2.041300E-04,2.548200E-04,3.162600E-04,& + & 3.662900E-04,4.575000E-04,1.055700E-03,2.905242E-03,9.673130E-03,& + & 1.630605E-05,6.380301E-05,1.095800E-04,1.431100E-04,1.862000E-04,& + & 2.376300E-04,3.452100E-04,7.927000E-04,1.172200E-03,1.708400E-03,& + & 4.318042E-03,1.442010E-02,1.468082E-05,5.671866E-05,9.502000E-05,& + & 1.241100E-04,1.634900E-04,2.187600E-04,4.544900E-04,1.153500E-03,& + & 1.512900E-03,2.238200E-03,5.725565E-03,1.908652E-02,1.321600E-05,& + & 4.795032E-05,7.930000E-05,1.032100E-04,1.411300E-04,2.015800E-04,& + & 5.938600E-04,1.403600E-03,1.852500E-03,2.762100E-03,7.122514E-03,& + & 2.359386E-02,1.703948E-05,3.402179E-05,5.851900E-05,8.106100E-05,& + & 1.146700E-04,1.998100E-04,7.405200E-04,1.649800E-03,2.188500E-03,& + & 3.270800E-03,8.490637E-03,2.772835E-02,2.746037E-05,3.732854E-05,& + & 2.524000E-05,2.708400E-05,6.700600E-05,2.417300E-04,8.510400E-04,& + & 1.882000E-03,2.514100E-03,3.745700E-03,9.744138E-03,3.048545E-02/ + data absa( : ,126:150) / & + & 5.201791E-06,1.440812E-05,3.209500E-05,5.992200E-05,1.184400E-04,& + & 2.473500E-04,7.826500E-04,2.159600E-03,2.884800E-03,4.368700E-03,& + & 1.138234E-02,3.811942E-02,2.046267E-05,7.684972E-05,1.380500E-04,& + & 1.791300E-04,2.223800E-04,2.602700E-04,2.241200E-04,1.454600E-04,& + & 1.415700E-04,1.301900E-04,1.097934E-04,2.776312E-04,2.210151E-05,& + & 7.928970E-05,1.388800E-04,1.793200E-04,2.219200E-04,2.733600E-04,& + & 2.903900E-04,2.951500E-04,2.582900E-04,2.333800E-04,1.642561E-03,& + & 6.486864E-03,2.153642E-05,7.560272E-05,1.276000E-04,1.666300E-04,& + & 2.122700E-04,2.656000E-04,3.728300E-04,4.492700E-04,4.658900E-04,& + & 1.492000E-03,3.862975E-03,1.287198E-02,2.023155E-05,7.000975E-05,& + & 1.148100E-04,1.490500E-04,1.964700E-04,2.575500E-04,4.322300E-04,& + & 1.057900E-03,1.542900E-03,2.338800E-03,5.749111E-03,1.919619E-02,& + & 1.827992E-05,6.260194E-05,1.015700E-04,1.307900E-04,1.777900E-04,& + & 2.523600E-04,5.936400E-04,1.516300E-03,2.008500E-03,3.080000E-03,& + & 7.622952E-03,2.541578E-02,1.602220E-05,5.382037E-05,8.625600E-05,& + & 1.123400E-04,1.580200E-04,2.481100E-04,7.904100E-04,1.861200E-03,& + & 2.473700E-03,3.815500E-03,9.478483E-03,3.142762E-02,1.494893E-05,& + & 4.267483E-05,6.741700E-05,9.417600E-05,1.365800E-04,2.590000E-04,& + & 9.969600E-04,2.198500E-03,2.934400E-03,4.535200E-03,1.129034E-02,& + & 3.694174E-02,2.775981E-05,2.931808E-05,3.066000E-05,5.930400E-05,& + & 1.194600E-04,3.315300E-04,1.155300E-03,2.514000E-03,3.388300E-03,& + & 5.181500E-03,1.295390E-02,4.067882E-02,6.439050E-06,2.067503E-05,& + & 4.514700E-05,8.070300E-05,1.604800E-04,3.371700E-04,1.070500E-03,& + & 2.901600E-03,3.875600E-03,6.053600E-03,1.516695E-02,5.077095E-02,& + & 1.759332E-05,1.362536E-04,3.237900E-04,4.584900E-04,5.940600E-04,& + & 7.913000E-04,1.010500E-03,1.213800E-03,1.296800E-03,1.409900E-03,& + & 1.520435E-03,1.829615E-03,1.661358E-05,1.256414E-04,2.903600E-04,& + & 4.071900E-04,5.273500E-04,7.006300E-04,8.919800E-04,1.064300E-03,& + & 1.162700E-03,1.251900E-03,1.363708E-03,1.642918E-03,1.496794E-05,& + & 1.118739E-04,2.546100E-04,3.563000E-04,4.585400E-04,6.129800E-04,& + & 7.773200E-04,9.407000E-04,1.029500E-03,1.099200E-03,1.242527E-03,& + & 2.848959E-03,1.311714E-05,9.683219E-05,2.182900E-04,3.021200E-04,& + & 3.914600E-04,5.198700E-04,6.656700E-04,8.150400E-04,8.885200E-04,& + & 9.615700E-04,1.335263E-03,4.223814E-03,1.123768E-05,8.074957E-05,& + & 1.805500E-04,2.472300E-04,3.217300E-04,4.275500E-04,5.545200E-04,& + & 7.035800E-04,7.510000E-04,8.506000E-04,1.574036E-03,5.586805E-03,& + & 1.030147E-05,6.263718E-05,1.406400E-04,1.920800E-04,2.511500E-04,& + & 3.332600E-04,4.408600E-04,5.931600E-04,6.887800E-04,8.213500E-04,& + & 1.903060E-03,6.929586E-03,1.809051E-05,3.589354E-05,9.619900E-05,& + & 1.322400E-04,1.820400E-04,2.336300E-04,3.286900E-04,5.510400E-04,& + & 7.021700E-04,8.857400E-04,2.240817E-03,8.220937E-03,3.170954E-05,& + & 6.336719E-05,5.260000E-05,4.067000E-05,3.338000E-05,3.705100E-05,& + & 1.941800E-04,5.643800E-04,7.285500E-04,9.494300E-04,2.577418E-03,& + & 9.314331E-03,2.550984E-06,4.677185E-06,5.333800E-06,1.078600E-05,& + & 2.985700E-05,7.419900E-05,1.721200E-04,3.207800E-04,6.690900E-04,& + & 1.057100E-03,2.945307E-03,1.108882E-02,2.249763E-05,1.488430E-04,& + & 3.297900E-04,4.632600E-04,6.010500E-04,7.598000E-04,9.216900E-04,& + & 1.151400E-03,1.290100E-03,1.216000E-03,1.373858E-03,1.263789E-03,& + & 2.148881E-05,1.381448E-04,2.999900E-04,4.150100E-04,5.353100E-04,& + & 6.784500E-04,8.242100E-04,1.012500E-03,1.161800E-03,1.063300E-03,& + & 1.232198E-03,2.126461E-03,1.954058E-05,1.236243E-04,2.656600E-04,& + & 3.637100E-04,4.697800E-04,5.944500E-04,7.292400E-04,9.407100E-04,& + & 9.927800E-04,1.030800E-03,1.319089E-03,4.418356E-03,1.729563E-05,& + & 1.076642E-04,2.292400E-04,3.104600E-04,4.002200E-04,5.109500E-04,& + & 6.385700E-04,8.360000E-04,8.668600E-04,9.580700E-04,1.749911E-03,& + & 6.564732E-03,1.480406E-05,9.040236E-05,1.901800E-04,2.572600E-04,& + & 3.309700E-04,4.198100E-04,5.476300E-04,7.422000E-04,8.271000E-04,& + & 9.280800E-04,2.373826E-03,8.694908E-03,1.235660E-05,7.184011E-05,& + & 1.483100E-04,2.014500E-04,2.622100E-04,3.292300E-04,4.519800E-04,& + & 6.590700E-04,9.162800E-04,1.177200E-03,2.914958E-03,1.079225E-02/ + data absa( : ,151:175) / & + & 1.355959E-05,4.866621E-05,1.042900E-04,1.403200E-04,1.877300E-04,& + & 2.416800E-04,3.724400E-04,7.714300E-04,1.005300E-03,1.321800E-03,& + & 3.460844E-03,1.281180E-02,3.268914E-05,4.673102E-05,3.720800E-05,& + & 4.266100E-05,5.609200E-05,1.313500E-04,3.377900E-04,8.326700E-04,& + & 1.092100E-03,1.454500E-03,3.996074E-03,1.452711E-02,2.825533E-06,& + & 4.706930E-06,1.138200E-05,2.272400E-05,4.764200E-05,1.147100E-04,& + & 2.736500E-04,4.789100E-04,9.371900E-04,1.642000E-03,4.572828E-03,& + & 1.728713E-02,2.839839E-05,1.607975E-04,3.364700E-04,4.599900E-04,& + & 5.992000E-04,7.664400E-04,9.134000E-04,8.327600E-04,8.469600E-04,& + & 7.763100E-04,9.063849E-04,1.025174E-03,2.733522E-05,1.509112E-04,& + & 3.077300E-04,4.180500E-04,5.395400E-04,6.898400E-04,8.183100E-04,& + & 7.037600E-04,8.099200E-04,7.415300E-04,9.333796E-04,3.302682E-03,& + & 2.494225E-05,1.356945E-04,2.753700E-04,3.689200E-04,4.763500E-04,& + & 6.094800E-04,7.288200E-04,7.120800E-04,6.683500E-04,7.588200E-04,& + & 1.609761E-03,6.502803E-03,2.214373E-05,1.184654E-04,2.384100E-04,& + & 3.197500E-04,4.112200E-04,5.239100E-04,6.352300E-04,6.805200E-04,& + & 7.579700E-04,8.723600E-04,2.535249E-03,9.677228E-03,1.904471E-05,& + & 1.000265E-04,1.981800E-04,2.667300E-04,3.449700E-04,4.368200E-04,& + & 5.308800E-04,7.619400E-04,8.817000E-04,1.377100E-03,3.467742E-03,& + & 1.282757E-02,1.577003E-05,8.032842E-05,1.553400E-04,2.094700E-04,& + & 2.752500E-04,3.505600E-04,4.565800E-04,8.901900E-04,1.253800E-03,& + & 1.677000E-03,4.283951E-03,1.592880E-02,1.332013E-05,5.821568E-05,& + & 1.110700E-04,1.492400E-04,1.987800E-04,2.575600E-04,4.448900E-04,& + & 1.068200E-03,1.419400E-03,1.930000E-03,5.094659E-03,1.891908E-02,& + & 3.006115E-05,3.128885E-05,4.294000E-05,6.895400E-05,1.092000E-04,& + & 1.643300E-04,4.857700E-04,1.177800E-03,1.577700E-03,2.167000E-03,& + & 5.881392E-03,2.146007E-02,2.951886E-06,7.789697E-06,1.877400E-05,& + & 3.378700E-05,7.135100E-05,1.668700E-04,4.230200E-04,6.182500E-04,& + & 1.293000E-03,2.467600E-03,6.751022E-03,2.553491E-02,3.503226E-05,& + & 1.721587E-04,3.422200E-04,4.600300E-04,5.959500E-04,7.559500E-04,& + & 8.925100E-04,6.267800E-04,4.094600E-04,4.522800E-04,5.347158E-04,& + & 9.719629E-04,3.400034E-05,1.631180E-04,3.179000E-04,4.197200E-04,& + & 5.445900E-04,6.917800E-04,8.026900E-04,5.317800E-04,5.357500E-04,& + & 5.176400E-04,7.743391E-04,4.653267E-03,3.115884E-05,1.474767E-04,& + & 2.851500E-04,3.775300E-04,4.820400E-04,6.162900E-04,7.347100E-04,& + & 5.171200E-04,5.315600E-04,4.982500E-04,2.154448E-03,9.156277E-03,& + & 2.794513E-05,1.292335E-04,2.467200E-04,3.303200E-04,4.219000E-04,& + & 5.360100E-04,6.440200E-04,6.209000E-04,6.560700E-04,1.041000E-03,& + & 3.627086E-03,1.363524E-02,2.421004E-05,1.096441E-04,2.054400E-04,& + & 2.777900E-04,3.565600E-04,4.543400E-04,5.590500E-04,7.569000E-04,& + & 1.092400E-03,1.964200E-03,4.882554E-03,1.808487E-02,2.009490E-05,& + & 8.865766E-05,1.626700E-04,2.190900E-04,2.869100E-04,3.721500E-04,& + & 5.138600E-04,1.187200E-03,1.688600E-03,2.360200E-03,6.046190E-03,& + & 2.247587E-02,1.581893E-05,6.590127E-05,1.180600E-04,1.578500E-04,& + & 2.119400E-04,2.823100E-04,5.657700E-04,1.456300E-03,1.941000E-03,& + & 2.757200E-03,7.197993E-03,2.670774E-02,2.271548E-05,3.187112E-05,& + & 6.582300E-05,9.157300E-05,1.283400E-04,1.956600E-04,6.808600E-04,& + & 1.630200E-03,2.179900E-03,3.144400E-03,8.307070E-03,3.031724E-02,& + & 3.959630E-06,1.185892E-05,2.756900E-05,4.734300E-05,1.024700E-04,& + & 2.339500E-04,6.234400E-04,8.553700E-04,1.679500E-03,3.578400E-03,& + & 9.560980E-03,3.603102E-02,4.216673E-05,1.831429E-04,3.459800E-04,& + & 4.625300E-04,5.968200E-04,7.406700E-04,7.947500E-04,4.298700E-04,& + & 4.116100E-04,3.716200E-04,3.507009E-04,8.222971E-04,4.149966E-05,& + & 1.750946E-04,3.252600E-04,4.285400E-04,5.484500E-04,6.882500E-04,& + & 7.379700E-04,5.203300E-04,5.710200E-04,5.451700E-04,7.313338E-04,& + & 6.292732E-03,3.841605E-05,1.585530E-04,2.929700E-04,3.891700E-04,& + & 4.954200E-04,6.166400E-04,7.136200E-04,6.375600E-04,5.884100E-04,& + & 4.765300E-04,2.746252E-03,1.241327E-02,3.460982E-05,1.395922E-04,& + & 2.551400E-04,3.400700E-04,4.350700E-04,5.530100E-04,6.700100E-04,& + & 7.656400E-04,6.912200E-04,1.080400E-03,5.052825E-03,1.850811E-02/ + data absa( : ,176:200) / & + & 3.020459E-05,1.192442E-04,2.138400E-04,2.859900E-04,3.708400E-04,& + & 4.744200E-04,6.395700E-04,7.821800E-04,1.403600E-03,2.651600E-03,& + & 6.659848E-03,2.455902E-02,2.515062E-05,9.729619E-05,1.709300E-04,& + & 2.276000E-04,3.025600E-04,3.962100E-04,6.173000E-04,1.622400E-03,& + & 2.246700E-03,3.234700E-03,8.257646E-03,3.051883E-02,1.949991E-05,& + & 7.342427E-05,1.262000E-04,1.671300E-04,2.262900E-04,3.151200E-04,& + & 7.458700E-04,1.948200E-03,2.602500E-03,3.822300E-03,9.834249E-03,& + & 3.626899E-02,1.680038E-05,4.378126E-05,7.615600E-05,1.039200E-04,& + & 1.467300E-04,2.457200E-04,9.282600E-04,2.205600E-03,2.941900E-03,& + & 4.407600E-03,1.133627E-02,4.119866E-02,5.589324E-06,1.697585E-05,& + & 3.882900E-05,6.450700E-05,1.406100E-04,3.221000E-04,8.775600E-04,& + & 1.245500E-03,2.166800E-03,4.924800E-03,1.309634E-02,4.896018E-02,& + & 3.404891E-05,3.011826E-04,7.485300E-04,1.104600E-03,1.563600E-03,& + & 2.070300E-03,2.693500E-03,3.342000E-03,3.524900E-03,3.899000E-03,& + & 4.446504E-03,5.173391E-03,3.100569E-05,2.696733E-04,6.598900E-04,& + & 9.721000E-04,1.373800E-03,1.813900E-03,2.359300E-03,2.924700E-03,& + & 3.087700E-03,3.414600E-03,3.894759E-03,4.525794E-03,2.735105E-05,& + & 2.357727E-04,5.723700E-04,8.381800E-04,1.185400E-03,1.562100E-03,& + & 2.032300E-03,2.512600E-03,2.670700E-03,2.941800E-03,3.345046E-03,& + & 3.880127E-03,2.348769E-05,2.004071E-04,4.833900E-04,7.047400E-04,& + & 9.962700E-04,1.310600E-03,1.704700E-03,2.094600E-03,2.256200E-03,& + & 2.479200E-03,2.871822E-03,3.839071E-03,1.941032E-05,1.643386E-04,& + & 3.925800E-04,5.718200E-04,8.035800E-04,1.060000E-03,1.379800E-03,& + & 1.692400E-03,1.857400E-03,1.989400E-03,2.377659E-03,4.746292E-03,& + & 1.527003E-05,1.271050E-04,3.011200E-04,4.373100E-04,6.113400E-04,& + & 8.065200E-04,1.052200E-03,1.303000E-03,1.444000E-03,1.591700E-03,& + & 1.995300E-03,5.874373E-03,1.199662E-05,8.760419E-05,2.077500E-04,& + & 3.007800E-04,4.179400E-04,5.513300E-04,7.278000E-04,9.341000E-04,& + & 1.013500E-03,1.181300E-03,1.858257E-03,6.979473E-03,2.526621E-05,& + & 3.292143E-05,1.051100E-04,1.584900E-04,2.194000E-04,2.906900E-04,& + & 3.995400E-04,5.898600E-04,7.009000E-04,8.680100E-04,1.985562E-03,& + & 8.004217E-03,1.478496E-06,2.412140E-06,4.904600E-06,1.066900E-05,& + & 2.430200E-05,6.367000E-05,1.665300E-04,3.196900E-04,2.487900E-04,& + & 2.102800E-04,1.969346E-03,9.298767E-03,4.396726E-05,3.289977E-04,& + & 7.729600E-04,1.118400E-03,1.504600E-03,1.981800E-03,2.619100E-03,& + & 3.139800E-03,3.498700E-03,3.619900E-03,4.124529E-03,4.980688E-03,& + & 4.029828E-05,2.961606E-04,6.852600E-04,9.852200E-04,1.326600E-03,& + & 1.744100E-03,2.298300E-03,2.748800E-03,3.066000E-03,3.168000E-03,& + & 3.617345E-03,4.359059E-03,3.576480E-05,2.593808E-04,5.986000E-04,& + & 8.505200E-04,1.147200E-03,1.508200E-03,1.987100E-03,2.381800E-03,& + & 2.658500E-03,2.693800E-03,3.250340E-03,4.259589E-03,3.084653E-05,& + & 2.215190E-04,5.062900E-04,7.195600E-04,9.632000E-04,1.272800E-03,& + & 1.678000E-03,2.025900E-03,2.261600E-03,2.309000E-03,2.775290E-03,& + & 5.797056E-03,2.561901E-05,1.824452E-04,4.133400E-04,5.844800E-04,& + & 7.824800E-04,1.032600E-03,1.363600E-03,1.696200E-03,1.823000E-03,& + & 1.995600E-03,2.520629E-03,7.640395E-03,2.022538E-05,1.420162E-04,& + & 3.191300E-04,4.470800E-04,5.983300E-04,7.943400E-04,1.053500E-03,& + & 1.352400E-03,1.394700E-03,1.646300E-03,2.523329E-03,9.469802E-03,& + & 1.484149E-05,9.939225E-05,2.228800E-04,3.094300E-04,4.121100E-04,& + & 5.491800E-04,7.434600E-04,9.721700E-04,1.133800E-03,1.299700E-03,& + & 2.803711E-03,1.126906E-02,1.833135E-05,4.653893E-05,1.166200E-04,& + & 1.658200E-04,2.259500E-04,2.997800E-04,4.303800E-04,7.289400E-04,& + & 9.887500E-04,1.300600E-03,3.151417E-03,1.294124E-02,1.579553E-06,& + & 3.888863E-06,9.742600E-06,1.785600E-05,3.846300E-05,1.014700E-04,& + & 2.668200E-04,5.232000E-04,4.403500E-04,2.449400E-04,3.141968E-03,& + & 1.504218E-02,5.533305E-05,3.568522E-04,7.851200E-04,1.121400E-03,& + & 1.516800E-03,1.977600E-03,2.365000E-03,3.033000E-03,3.233800E-03,& + & 3.441500E-03,3.573773E-03,3.543068E-03,5.106581E-05,3.229390E-04,& + & 7.019100E-04,9.895200E-04,1.343100E-03,1.743800E-03,2.086600E-03,& + & 2.675900E-03,2.864000E-03,3.022000E-03,3.174323E-03,3.099834E-03/ + data absa( : ,201:225) / & + & 4.556948E-05,2.839446E-04,6.132800E-04,8.629800E-04,1.161500E-03,& + & 1.514900E-03,1.813200E-03,2.337000E-03,2.512800E-03,2.576100E-03,& + & 2.799077E-03,5.662852E-03,3.946430E-05,2.435308E-04,5.215600E-04,& + & 7.305800E-04,9.841200E-04,1.274300E-03,1.544300E-03,2.001400E-03,& + & 2.222400E-03,2.203600E-03,2.677373E-03,8.774417E-03,3.295799E-05,& + & 2.012963E-04,4.291700E-04,5.952600E-04,8.021000E-04,1.038000E-03,& + & 1.281000E-03,1.649000E-03,1.836900E-03,1.868900E-03,2.935953E-03,& + & 1.159081E-02,2.617678E-05,1.569590E-04,3.343200E-04,4.596700E-04,& + & 6.168400E-04,7.965600E-04,1.009300E-03,1.403200E-03,1.459000E-03,& + & 1.585900E-03,3.542290E-03,1.438758E-02,1.900860E-05,1.110926E-04,& + & 2.323200E-04,3.234300E-04,4.293500E-04,5.567000E-04,7.260600E-04,& + & 1.059300E-03,1.305400E-03,1.789800E-03,4.195448E-03,1.713607E-02,& + & 1.442804E-05,5.995779E-05,1.253500E-04,1.750400E-04,2.383200E-04,& + & 3.063300E-04,4.837800E-04,1.006700E-03,1.404000E-03,1.907400E-03,& + & 4.782439E-03,1.969769E-02,2.169199E-06,6.548929E-06,1.490800E-05,& + & 2.738400E-05,5.795800E-05,1.521200E-04,4.128200E-04,7.541800E-04,& + & 6.076400E-04,5.067900E-04,4.721595E-03,2.289531E-02,6.864915E-05,& + & 3.824833E-04,8.006500E-04,1.121400E-03,1.502600E-03,1.976500E-03,& + & 2.401400E-03,2.577500E-03,2.195900E-03,2.171600E-03,2.182586E-03,& + & 2.594129E-03,6.369097E-05,3.483191E-04,7.177900E-04,9.988700E-04,& + & 1.333600E-03,1.756100E-03,2.116800E-03,2.316700E-03,1.931200E-03,& + & 1.907900E-03,2.083088E-03,3.159512E-03,5.686272E-05,3.084286E-04,& + & 6.281400E-04,8.723300E-04,1.164900E-03,1.528700E-03,1.840100E-03,& + & 2.047700E-03,1.765000E-03,1.613300E-03,2.075029E-03,8.428338E-03,& + & 4.933543E-05,2.655627E-04,5.380800E-04,7.405800E-04,9.905000E-04,& + & 1.297300E-03,1.579300E-03,1.691600E-03,1.518100E-03,1.335600E-03,& + & 2.876289E-03,1.265106E-02,4.142090E-05,2.198646E-04,4.447100E-04,& + & 6.107400E-04,8.089000E-04,1.061600E-03,1.315700E-03,1.366300E-03,& + & 1.331900E-03,1.505000E-03,3.798465E-03,1.673478E-02,3.310149E-05,& + & 1.720311E-04,3.460100E-04,4.770600E-04,6.293600E-04,8.215400E-04,& + & 1.019000E-03,1.159900E-03,1.321800E-03,1.814500E-03,5.160841E-03,& + & 2.079569E-02,2.424373E-05,1.223441E-04,2.424100E-04,3.362700E-04,& + & 4.448000E-04,5.816700E-04,7.380900E-04,1.084100E-03,1.758700E-03,& + & 2.488000E-03,6.066308E-03,2.478976E-02,1.561799E-05,6.907647E-05,& + & 1.332600E-04,1.850000E-04,2.505300E-04,3.311500E-04,5.708500E-04,& + & 1.395700E-03,1.939400E-03,2.722300E-03,6.959532E-03,2.850828E-02,& + & 3.296910E-06,9.917750E-06,2.185200E-05,4.007100E-05,8.419500E-05,& + & 2.151000E-04,6.150200E-04,9.652000E-04,9.477700E-04,8.863700E-04,& + & 6.822544E-03,3.313413E-02,8.355814E-05,4.068660E-04,8.136800E-04,& + & 1.123900E-03,1.498200E-03,1.952600E-03,2.368900E-03,2.186600E-03,& + & 1.246800E-03,1.307700E-03,1.056347E-03,2.276483E-03,7.810043E-05,& + & 3.734634E-04,7.321100E-04,1.005800E-03,1.341800E-03,1.739100E-03,& + & 2.102700E-03,2.001700E-03,1.086100E-03,1.244000E-03,1.208579E-03,& + & 4.250108E-03,6.995112E-05,3.322508E-04,6.445800E-04,8.804700E-04,& + & 1.175200E-03,1.527000E-03,1.852400E-03,1.550700E-03,1.160900E-03,& + & 1.115800E-03,1.803124E-03,1.180087E-02,6.085802E-05,2.859079E-04,& + & 5.566200E-04,7.560200E-04,9.979100E-04,1.303100E-03,1.621800E-03,& + & 1.242500E-03,1.151500E-03,9.002000E-04,3.361475E-03,1.749878E-02,& + & 5.126246E-05,2.372531E-04,4.614900E-04,6.266700E-04,8.240300E-04,& + & 1.080400E-03,1.326200E-03,1.224800E-03,1.247000E-03,1.271300E-03,& + & 5.201910E-03,2.317773E-02,4.111297E-05,1.864195E-04,3.602200E-04,& + & 4.919300E-04,6.448000E-04,8.475500E-04,1.053100E-03,1.108600E-03,& + & 1.322000E-03,2.369800E-03,7.186280E-03,2.881013E-02,3.029681E-05,& + & 1.336403E-04,2.532300E-04,3.486400E-04,4.630900E-04,6.018900E-04,& + & 8.090400E-04,1.248300E-03,2.365900E-03,3.364600E-03,8.491345E-03,& + & 3.436227E-02,1.878741E-05,7.732746E-05,1.414200E-04,1.952600E-04,& + & 2.657500E-04,3.610200E-04,7.168400E-04,1.917300E-03,2.630800E-03,& + & 3.756000E-03,9.768062E-03,3.954927E-02,4.829956E-06,1.435521E-05,& + & 3.153200E-05,5.626200E-05,1.185500E-04,2.924100E-04,8.898500E-04,& + & 1.178800E-03,1.235600E-03,1.337500E-03,9.740400E-03,4.597142E-02/ + data absa( : ,226:250) / & + & 6.305551E-05,6.351564E-04,1.652800E-03,2.658500E-03,3.802200E-03,& + & 5.219300E-03,6.930800E-03,8.883800E-03,9.522300E-03,1.019600E-02,& + & 1.202423E-02,1.388430E-02,5.637142E-05,5.606802E-04,1.449700E-03,& + & 2.328900E-03,3.329700E-03,4.568400E-03,6.066500E-03,7.774500E-03,& + & 8.333500E-03,8.924400E-03,1.052364E-02,1.214784E-02,4.916176E-05,& + & 4.849159E-04,1.247700E-03,2.001700E-03,2.858700E-03,3.917600E-03,& + & 5.202200E-03,6.664600E-03,7.144200E-03,7.653100E-03,9.022938E-03,& + & 1.041326E-02,4.163457E-05,4.082205E-04,1.045900E-03,1.672500E-03,& + & 2.390900E-03,3.270500E-03,4.339000E-03,5.555500E-03,5.954400E-03,& + & 6.381800E-03,7.522941E-03,8.677823E-03,3.399078E-05,3.308148E-04,& + & 8.429600E-04,1.343600E-03,1.920600E-03,2.623200E-03,3.484500E-03,& + & 4.461400E-03,4.777900E-03,5.126700E-03,6.022828E-03,6.943604E-03,& + & 2.617338E-05,2.521907E-04,6.401300E-04,1.013400E-03,1.450800E-03,& + & 1.976600E-03,2.625500E-03,3.362300E-03,3.598400E-03,3.908100E-03,& + & 4.601204E-03,5.651275E-03,1.824018E-05,1.725201E-04,4.354100E-04,& + & 6.834800E-04,9.768600E-04,1.330900E-03,1.770500E-03,2.279600E-03,& + & 2.424700E-03,2.653700E-03,3.131603E-03,5.672569E-03,1.425810E-05,& + & 8.627701E-05,2.288200E-04,3.511600E-04,5.010300E-04,6.821200E-04,& + & 9.129700E-04,1.179900E-03,1.273700E-03,1.466100E-03,1.898443E-03,& + & 6.468481E-03,8.559721E-07,1.674665E-06,4.102500E-06,8.281000E-06,& + & 1.837400E-05,5.139800E-05,1.450700E-04,1.782700E-04,1.469200E-04,& + & 1.688900E-04,9.249388E-04,7.401221E-03,8.253639E-05,6.972441E-04,& + & 1.716700E-03,2.586300E-03,3.718800E-03,5.080800E-03,6.770700E-03,& + & 8.657200E-03,9.248500E-03,1.011100E-02,1.144281E-02,1.351202E-02,& + & 7.421025E-05,6.178157E-04,1.507000E-03,2.268300E-03,3.260600E-03,& + & 4.448600E-03,5.927100E-03,7.577000E-03,8.094300E-03,8.853200E-03,& + & 1.001491E-02,1.182308E-02,6.470272E-05,5.363967E-04,1.298000E-03,& + & 1.950100E-03,2.807800E-03,3.821700E-03,5.084900E-03,6.495500E-03,& + & 6.940600E-03,7.594100E-03,8.586588E-03,1.013489E-02,5.495223E-05,& + & 4.527781E-04,1.090100E-03,1.631600E-03,2.350900E-03,3.197000E-03,& + & 4.254200E-03,5.432100E-03,5.816100E-03,6.359300E-03,7.167955E-03,& + & 8.446701E-03,4.494371E-05,3.675508E-04,8.825600E-04,1.311000E-03,& + & 1.894100E-03,2.572000E-03,3.420200E-03,4.360500E-03,4.685100E-03,& + & 5.115400E-03,5.870543E-03,7.537426E-03,3.471226E-05,2.814909E-04,& + & 6.719600E-04,9.917400E-04,1.431700E-03,1.948500E-03,2.589900E-03,& + & 3.310400E-03,3.567700E-03,3.857700E-03,4.500402E-03,8.090569E-03,& + & 2.416758E-05,1.940608E-04,4.578500E-04,6.727400E-04,9.694900E-04,& + & 1.318700E-03,1.756300E-03,2.242700E-03,2.474800E-03,2.662700E-03,& + & 3.315983E-03,9.471289E-03,1.439075E-05,1.022861E-04,2.415800E-04,& + & 3.511100E-04,5.017000E-04,6.833500E-04,9.272200E-04,1.238200E-03,& + & 1.346900E-03,1.527300E-03,2.610147E-03,1.089596E-02,1.042079E-06,& + & 3.215999E-06,7.157500E-06,1.403900E-05,2.978100E-05,8.526700E-05,& + & 2.419700E-04,2.580000E-04,2.517800E-04,2.678600E-04,1.553941E-03,& + & 1.248951E-02,1.052046E-04,7.565306E-04,1.754200E-03,2.617600E-03,& + & 3.656800E-03,4.822800E-03,6.611100E-03,8.333500E-03,8.778900E-03,& + & 9.557400E-03,1.083949E-02,1.312127E-02,9.467798E-05,6.724274E-04,& + & 1.544300E-03,2.299100E-03,3.212400E-03,4.228400E-03,5.787700E-03,& + & 7.293100E-03,7.682700E-03,8.374500E-03,9.487900E-03,1.148022E-02,& + & 8.285883E-05,5.845777E-04,1.337400E-03,1.977100E-03,2.766000E-03,& + & 3.643000E-03,4.982100E-03,6.275900E-03,6.615000E-03,7.209600E-03,& + & 8.134803E-03,9.842069E-03,7.062128E-05,4.940422E-04,1.130500E-03,& + & 1.653700E-03,2.318100E-03,3.057800E-03,4.173400E-03,5.247500E-03,& + & 5.543700E-03,6.096700E-03,6.941784E-03,9.101432E-03,5.802615E-05,& + & 4.023370E-04,9.158900E-04,1.336700E-03,1.866700E-03,2.471100E-03,& + & 3.366400E-03,4.233900E-03,4.467300E-03,4.992700E-03,5.682128E-03,& + & 1.034122E-02,4.495254E-05,3.096820E-04,6.983900E-04,1.017900E-03,& + & 1.414800E-03,1.874200E-03,2.564100E-03,3.205900E-03,3.478700E-03,& + & 3.875300E-03,4.581135E-03,1.253474E-02,3.150425E-05,2.143970E-04,& + & 4.807000E-04,6.935200E-04,9.612100E-04,1.277400E-03,1.762600E-03,& + & 2.204700E-03,2.452800E-03,2.694000E-03,3.934563E-03,1.488305E-02/ + data absa( : ,251:275) / & + & 1.777496E-05,1.148320E-04,2.557600E-04,3.669300E-04,5.047300E-04,& + & 6.726400E-04,9.419800E-04,1.324000E-03,1.484700E-03,1.792900E-03,& + & 3.925534E-03,1.715209E-02,1.682651E-06,5.322449E-06,1.117000E-05,& + & 2.268300E-05,4.544200E-05,1.324500E-04,3.802600E-04,4.215600E-04,& + & 3.792000E-04,4.472100E-04,2.417494E-03,1.968782E-02,1.312080E-04,& + & 8.138590E-04,1.783500E-03,2.621700E-03,3.665500E-03,4.894300E-03,& + & 6.043800E-03,7.554900E-03,8.216400E-03,9.144800E-03,9.445115E-03,& + & 9.974598E-03,1.186127E-04,7.262926E-04,1.574500E-03,2.304600E-03,& + & 3.227400E-03,4.300300E-03,5.300300E-03,6.606000E-03,7.201800E-03,& + & 8.006500E-03,8.266959E-03,8.729430E-03,1.040512E-04,6.326784E-04,& + & 1.368600E-03,1.987100E-03,2.783000E-03,3.708000E-03,4.574500E-03,& + & 5.736900E-03,6.246500E-03,6.818000E-03,7.326819E-03,7.953844E-03,& + & 8.882189E-05,5.364146E-04,1.155200E-03,1.675700E-03,2.331800E-03,& + & 3.119900E-03,3.844100E-03,4.838000E-03,5.337500E-03,5.645400E-03,& + & 6.240689E-03,1.068602E-02,7.309603E-05,4.385850E-04,9.389800E-04,& + & 1.356700E-03,1.885900E-03,2.521300E-03,3.111100E-03,4.009600E-03,& + & 4.369100E-03,4.588800E-03,5.309140E-03,1.506174E-02,5.686349E-05,& + & 3.385083E-04,7.210000E-04,1.034700E-03,1.438000E-03,1.915400E-03,& + & 2.392200E-03,3.120400E-03,3.406400E-03,3.504700E-03,4.974148E-03,& + & 1.860052E-02,4.015622E-05,2.346783E-04,4.997400E-04,7.119500E-04,& + & 9.823900E-04,1.306200E-03,1.667200E-03,2.300100E-03,2.415100E-03,& + & 2.633400E-03,5.158198E-03,2.212177E-02,2.248446E-05,1.270601E-04,& + & 2.675600E-04,3.817600E-04,5.226000E-04,6.905500E-04,9.343000E-04,& + & 1.360300E-03,1.754400E-03,2.484200E-03,5.793744E-03,2.553178E-02,& + & 2.675308E-06,8.246817E-06,1.677800E-05,3.474800E-05,6.778000E-05,& + & 1.966100E-04,5.569200E-04,7.817800E-04,5.743800E-04,6.584600E-04,& + & 3.577303E-03,2.932529E-02,1.600632E-04,8.684138E-04,1.817300E-03,& + & 2.632900E-03,3.623600E-03,4.882400E-03,6.133500E-03,6.868400E-03,& + & 6.857600E-03,5.707500E-03,5.781046E-03,6.254795E-03,1.451487E-04,& + & 7.777508E-04,1.610900E-03,2.319500E-03,3.196500E-03,4.302500E-03,& + & 5.387900E-03,6.088600E-03,6.035600E-03,5.004900E-03,5.053295E-03,& + & 5.468634E-03,1.275453E-04,6.798639E-04,1.399700E-03,2.009400E-03,& + & 2.764300E-03,3.723200E-03,4.650100E-03,5.198900E-03,5.175500E-03,& + & 4.527100E-03,4.386506E-03,9.378496E-03,1.090652E-04,5.787930E-04,& + & 1.183600E-03,1.696000E-03,2.332800E-03,3.133300E-03,3.914100E-03,& + & 4.406700E-03,4.255300E-03,4.036500E-03,4.067619E-03,1.513109E-02,& + & 8.995317E-05,4.751561E-04,9.653300E-04,1.376800E-03,1.892800E-03,& + & 2.542900E-03,3.188300E-03,3.668100E-03,3.289000E-03,3.061200E-03,& + & 4.622847E-03,2.132921E-02,7.032076E-05,3.668917E-04,7.447700E-04,& + & 1.058900E-03,1.444400E-03,1.951200E-03,2.460200E-03,2.809900E-03,& + & 2.604300E-03,2.510600E-03,5.545862E-03,2.636262E-02,4.988662E-05,& + & 2.550942E-04,5.186900E-04,7.323000E-04,9.987000E-04,1.341500E-03,& + & 1.714300E-03,1.897000E-03,1.958500E-03,2.523800E-03,7.244298E-03,& + & 3.137833E-02,2.834596E-05,1.389053E-04,2.788900E-04,3.978300E-04,& + & 5.391000E-04,7.225100E-04,9.608000E-04,1.420400E-03,2.332800E-03,& + & 3.379200E-03,8.292826E-03,3.625799E-02,4.043606E-06,1.221498E-05,& + & 2.433900E-05,4.969500E-05,9.829300E-05,2.780200E-04,7.926000E-04,& + & 1.348000E-03,8.085900E-04,9.823900E-04,5.044478E-03,4.166254E-02,& + & 1.248975E-04,1.401398E-03,3.972600E-03,6.503600E-03,9.775600E-03,& + & 1.387500E-02,1.904700E-02,2.458600E-02,2.663400E-02,2.917900E-02,& + & 3.387541E-02,3.990244E-02,1.103198E-04,1.229945E-03,3.477200E-03,& + & 5.692700E-03,8.555700E-03,1.214100E-02,1.666800E-02,2.151300E-02,& + & 2.330600E-02,2.553400E-02,2.964352E-02,3.491306E-02,9.531764E-05,& + & 1.058418E-03,2.983200E-03,4.881700E-03,7.335700E-03,1.040800E-02,& + & 1.428800E-02,1.844000E-02,1.997900E-02,2.188900E-02,2.540985E-02,& + & 2.992567E-02,8.013197E-05,8.858198E-04,2.491200E-03,4.071500E-03,& + & 6.116000E-03,8.674900E-03,1.190900E-02,1.536900E-02,1.665100E-02,& + & 1.824500E-02,2.117679E-02,2.493866E-02,6.481252E-05,7.126783E-04,& + & 1.997800E-03,3.263600E-03,4.897800E-03,6.941800E-03,9.529900E-03,& + & 1.229600E-02,1.332100E-02,1.459900E-02,1.694373E-02,1.995178E-02/ + data absa( : ,276:300) / & + & 4.940475E-05,5.386852E-04,1.504800E-03,2.453100E-03,3.682600E-03,& + & 5.211800E-03,7.150700E-03,9.223000E-03,9.992400E-03,1.095500E-02,& + & 1.271145E-02,1.496414E-02,3.370386E-05,3.636989E-04,1.011400E-03,& + & 1.642600E-03,2.464200E-03,3.483900E-03,4.782500E-03,6.163300E-03,& + & 6.668400E-03,7.310100E-03,8.478960E-03,9.976117E-03,1.791549E-05,& + & 1.869335E-04,5.160600E-04,8.291600E-04,1.246600E-03,1.756000E-03,& + & 2.409700E-03,3.113700E-03,3.370900E-03,3.718900E-03,4.344074E-03,& + & 5.842717E-03,4.981028E-07,1.391178E-06,3.081500E-06,6.293600E-06,& + & 1.426300E-05,4.053700E-05,1.133000E-04,1.393300E-04,1.892000E-04,& + & 1.662900E-04,2.341974E-04,5.205887E-03,1.651293E-04,1.556542E-03,& + & 3.988500E-03,6.446200E-03,9.596600E-03,1.363300E-02,1.861400E-02,& + & 2.417000E-02,2.593800E-02,2.833100E-02,3.292968E-02,3.910204E-02,& + & 1.462032E-04,1.368302E-03,3.492400E-03,5.643800E-03,8.400500E-03,& + & 1.193100E-02,1.629000E-02,2.115000E-02,2.269600E-02,2.479500E-02,& + & 2.881534E-02,3.421569E-02,1.265187E-04,1.179057E-03,2.999200E-03,& + & 4.842700E-03,7.205000E-03,1.022900E-02,1.396500E-02,1.812900E-02,& + & 1.945600E-02,2.125800E-02,2.470001E-02,2.932683E-02,1.065840E-04,& + & 9.886314E-04,2.504700E-03,4.044300E-03,6.012800E-03,8.527900E-03,& + & 1.164100E-02,1.510900E-02,1.621500E-02,1.772200E-02,2.058529E-02,& + & 2.444112E-02,8.659378E-05,7.965270E-04,2.011700E-03,3.242500E-03,& + & 4.821600E-03,6.834600E-03,9.317100E-03,1.208800E-02,1.297400E-02,& + & 1.418400E-02,1.647073E-02,1.955289E-02,6.600195E-05,6.040349E-04,& + & 1.516800E-03,2.440900E-03,3.627400E-03,5.140000E-03,7.008600E-03,& + & 9.088600E-03,9.748800E-03,1.064700E-02,1.235600E-02,1.466479E-02,& + & 4.513273E-05,4.095462E-04,1.022500E-03,1.636400E-03,2.434500E-03,& + & 3.444400E-03,4.693200E-03,6.087800E-03,6.543700E-03,7.174600E-03,& + & 8.388012E-03,1.030065E-02,2.384298E-05,2.123440E-04,5.247100E-04,& + & 8.328800E-04,1.233700E-03,1.747700E-03,2.382700E-03,3.111400E-03,& + & 3.357400E-03,3.688200E-03,4.337585E-03,8.979595E-03,7.737813E-07,& + & 2.651914E-06,5.422400E-06,1.113600E-05,2.409400E-05,6.868700E-05,& + & 1.927500E-04,2.319000E-04,3.752000E-04,3.275900E-04,3.993790E-04,& + & 9.031470E-03,2.124521E-04,1.693847E-03,4.113300E-03,6.410300E-03,& + & 9.293900E-03,1.332800E-02,1.819100E-02,2.366200E-02,2.545300E-02,& + & 2.758400E-02,3.158846E-02,3.826444E-02,1.885346E-04,1.491529E-03,& + & 3.605300E-03,5.614100E-03,8.138800E-03,1.166600E-02,1.592100E-02,& + & 2.070500E-02,2.227400E-02,2.414100E-02,2.764067E-02,3.348499E-02,& + & 1.636076E-04,1.287286E-03,3.096500E-03,4.823300E-03,6.986900E-03,& + & 1.000700E-02,1.365000E-02,1.774800E-02,1.909600E-02,2.069900E-02,& + & 2.369404E-02,2.870052E-02,1.380964E-04,1.081051E-03,2.589600E-03,& + & 4.026800E-03,5.837500E-03,8.358700E-03,1.138200E-02,1.479100E-02,& + & 1.591800E-02,1.725100E-02,1.975069E-02,2.391681E-02,1.120410E-04,& + & 8.732168E-04,2.082300E-03,3.231700E-03,4.684300E-03,6.707400E-03,& + & 9.132200E-03,1.186100E-02,1.277700E-02,1.381700E-02,1.580123E-02,& + & 1.913497E-02,8.559432E-05,6.631807E-04,1.575800E-03,2.433600E-03,& + & 3.532100E-03,5.053300E-03,6.876900E-03,8.927100E-03,9.645500E-03,& + & 1.041900E-02,1.207562E-02,1.487305E-02,5.872954E-05,4.509677E-04,& + & 1.068000E-03,1.635500E-03,2.372000E-03,3.401400E-03,4.624600E-03,& + & 6.021500E-03,6.508100E-03,6.988300E-03,8.203223E-03,1.351941E-02,& + & 3.115814E-05,2.358903E-04,5.515900E-04,8.367500E-04,1.211300E-03,& + & 1.737200E-03,2.370400E-03,3.084400E-03,3.380200E-03,3.633100E-03,& + & 4.721952E-03,1.455669E-02,1.345131E-06,4.410145E-06,9.093100E-06,& + & 1.799100E-05,3.851800E-05,1.118900E-04,3.088100E-04,3.629800E-04,& + & 5.315800E-04,7.569300E-04,6.360521E-04,1.452133E-02,2.672710E-04,& + & 1.828131E-03,4.185800E-03,6.480100E-03,9.318500E-03,1.263600E-02,& + & 1.765700E-02,2.246900E-02,2.427100E-02,2.709200E-02,2.995310E-02,& + & 3.734176E-02,2.380157E-04,1.612370E-03,3.672300E-03,5.679700E-03,& + & 8.165000E-03,1.106600E-02,1.545500E-02,1.966000E-02,2.124100E-02,& + & 2.371000E-02,2.621247E-02,3.270598E-02,2.068550E-04,1.393976E-03,& + & 3.158200E-03,4.878400E-03,7.020000E-03,9.508100E-03,1.325200E-02,& + & 1.685300E-02,1.821400E-02,2.033200E-02,2.246784E-02,2.803378E-02/ + data absa( : ,301:325) / & + & 1.746873E-04,1.173149E-03,2.644900E-03,4.077200E-03,5.868000E-03,& + & 7.948600E-03,1.107800E-02,1.408600E-02,1.523300E-02,1.695000E-02,& + & 1.872782E-02,2.336144E-02,1.418524E-04,9.485879E-04,2.134300E-03,& + & 3.273400E-03,4.718000E-03,6.385000E-03,8.896100E-03,1.130600E-02,& + & 1.229000E-02,1.366900E-02,1.522069E-02,1.920216E-02,1.086199E-04,& + & 7.218745E-04,1.621700E-03,2.469900E-03,3.557900E-03,4.825800E-03,& + & 6.716900E-03,8.542000E-03,9.359900E-03,1.033100E-02,1.158070E-02,& + & 1.822291E-02,7.472863E-05,4.933824E-04,1.100500E-03,1.670500E-03,& + & 2.393300E-03,3.256400E-03,4.533000E-03,5.763100E-03,6.491200E-03,& + & 6.997800E-03,8.175791E-03,1.960841E-02,3.988824E-05,2.590921E-04,& + & 5.751300E-04,8.623400E-04,1.226000E-03,1.675000E-03,2.367600E-03,& + & 3.062600E-03,3.438700E-03,3.688600E-03,5.566971E-03,2.236290E-02,& + & 2.211567E-06,6.951697E-06,1.397300E-05,2.812400E-05,6.006500E-05,& + & 1.714300E-04,4.725600E-04,5.402900E-04,8.066700E-04,1.327200E-03,& + & 9.673794E-04,2.193959E-02,3.294919E-04,1.954294E-03,4.267300E-03,& + & 6.489900E-03,9.294200E-03,1.275200E-02,1.660500E-02,1.980900E-02,& + & 2.242200E-02,2.466800E-02,2.773931E-02,3.020808E-02,2.945957E-04,& + & 1.726346E-03,3.747100E-03,5.695400E-03,8.154400E-03,1.117400E-02,& + & 1.453700E-02,1.734900E-02,1.961300E-02,2.157800E-02,2.427788E-02,& + & 2.643477E-02,2.560360E-04,1.496163E-03,3.225600E-03,4.899900E-03,& + & 7.010500E-03,9.613500E-03,1.249500E-02,1.488600E-02,1.680600E-02,& + & 1.850900E-02,2.081006E-02,2.265497E-02,2.162516E-04,1.260283E-03,& + & 2.708200E-03,4.101900E-03,5.868900E-03,8.039900E-03,1.044800E-02,& + & 1.246000E-02,1.414500E-02,1.569100E-02,1.755093E-02,1.936569E-02,& + & 1.759397E-04,1.021249E-03,2.190800E-03,3.300700E-03,4.718600E-03,& + & 6.475900E-03,8.394900E-03,1.009200E-02,1.149300E-02,1.268000E-02,& + & 1.418237E-02,2.003245E-02,1.349347E-04,7.799871E-04,1.665200E-03,& + & 2.502200E-03,3.564600E-03,4.902800E-03,6.334800E-03,7.852200E-03,& + & 8.810800E-03,9.714100E-03,1.095053E-02,2.329901E-02,9.319207E-05,& + & 5.348102E-04,1.134900E-03,1.696300E-03,2.411300E-03,3.318300E-03,& + & 4.311200E-03,5.337800E-03,6.069200E-03,6.702200E-03,8.306099E-03,& + & 2.855605E-02,5.009153E-05,2.820706E-04,5.968600E-04,8.856800E-04,& + & 1.250500E-03,1.715300E-03,2.262300E-03,3.099900E-03,3.404800E-03,& + & 3.714100E-03,7.253229E-03,3.266810E-02,3.485095E-06,1.068547E-05,& + & 1.990700E-05,4.229400E-05,8.811400E-05,2.515800E-04,7.006100E-04,& + & 7.742300E-04,1.136700E-03,1.777800E-03,1.729776E-03,3.143308E-02,& + & 3.151067E-04,3.925630E-03,1.178900E-02,1.993800E-02,3.142800E-02,& + & 4.654700E-02,6.652200E-02,8.650800E-02,9.509700E-02,1.036100E-01,& + & 1.216860E-01,1.468115E-01,2.764807E-04,3.437493E-03,1.031600E-02,& + & 1.744700E-02,2.750100E-02,4.073000E-02,5.820800E-02,7.569600E-02,& + & 8.320600E-02,9.066700E-02,1.064794E-01,1.284632E-01,2.378479E-04,& + & 2.949433E-03,8.843200E-03,1.495600E-02,2.357400E-02,3.491300E-02,& + & 4.989400E-02,6.488200E-02,7.132200E-02,7.771300E-02,9.126720E-02,& + & 1.101211E-01,1.989284E-04,2.461569E-03,7.370100E-03,1.246500E-02,& + & 1.964600E-02,2.909500E-02,4.158000E-02,5.406800E-02,5.943700E-02,& + & 6.476500E-02,7.605823E-02,9.175847E-02,1.598216E-04,1.973612E-03,& + & 5.898200E-03,9.974600E-03,1.571900E-02,2.327700E-02,3.326600E-02,& + & 4.325500E-02,4.755000E-02,5.181500E-02,6.084632E-02,7.341514E-02,& + & 1.205886E-04,1.484732E-03,4.428400E-03,7.483600E-03,1.179200E-02,& + & 1.746000E-02,2.495200E-02,3.244300E-02,3.566400E-02,3.886400E-02,& + & 4.563646E-02,5.505567E-02,8.118071E-05,9.951891E-04,2.957500E-03,& + & 4.996300E-03,7.865200E-03,1.164200E-02,1.663800E-02,2.163000E-02,& + & 2.377700E-02,2.591400E-02,3.042699E-02,3.670688E-02,4.161946E-05,& + & 5.038036E-04,1.486800E-03,2.506700E-03,3.944500E-03,5.828200E-03,& + & 8.323700E-03,1.081700E-02,1.189100E-02,1.296500E-02,1.521630E-02,& + & 1.835432E-02,3.209167E-07,1.223734E-06,2.636200E-06,5.116100E-06,& + & 1.117900E-05,3.278400E-05,8.855600E-05,1.619100E-04,8.889500E-05,& + & 1.167700E-04,1.936617E-04,1.519526E-03,4.195573E-04,4.347568E-03,& + & 1.181500E-02,2.002800E-02,3.093300E-02,4.572100E-02,6.533100E-02,& + & 8.452800E-02,9.265700E-02,1.011500E-01,1.184270E-01,1.445079E-01/ + data absa( : ,326:350) / & + & 3.684936E-04,3.808828E-03,1.033900E-02,1.752700E-02,2.706800E-02,& + & 4.000800E-02,5.716600E-02,7.396000E-02,8.107800E-02,8.850700E-02,& + & 1.036205E-01,1.264446E-01,3.172775E-04,3.270158E-03,8.863300E-03,& + & 1.502600E-02,2.320400E-02,3.429400E-02,4.900200E-02,6.339700E-02,& + & 6.949800E-02,7.586400E-02,8.881990E-02,1.083765E-01,2.655262E-04,& + & 2.730692E-03,7.391100E-03,1.252500E-02,1.934100E-02,2.858100E-02,& + & 4.083700E-02,5.283200E-02,5.791500E-02,6.322500E-02,7.401900E-02,& + & 9.032031E-02,2.135537E-04,2.190643E-03,5.919800E-03,1.002500E-02,& + & 1.547700E-02,2.286800E-02,3.267200E-02,4.226600E-02,4.633300E-02,& + & 5.058400E-02,5.921566E-02,7.225255E-02,1.613733E-04,1.650165E-03,& + & 4.445400E-03,7.529500E-03,1.161400E-02,1.715400E-02,2.450800E-02,& + & 3.170100E-02,3.475400E-02,3.794300E-02,4.441314E-02,5.419164E-02,& + & 1.089674E-04,1.107944E-03,2.972200E-03,5.029800E-03,7.757900E-03,& + & 1.144500E-02,1.634400E-02,2.113600E-02,2.317200E-02,2.530200E-02,& + & 2.961202E-02,3.612884E-02,5.609221E-05,5.628039E-04,1.499300E-03,& + & 2.528200E-03,3.896100E-03,5.744800E-03,8.197500E-03,1.059700E-02,& + & 1.161100E-02,1.266200E-02,1.480890E-02,1.806529E-02,6.151221E-07,& + & 2.333506E-06,4.739100E-06,9.085000E-06,2.076100E-05,5.696000E-05,& + & 1.598800E-04,3.022100E-04,1.609300E-04,2.262400E-04,3.477291E-04,& + & 2.818155E-03,5.436841E-04,4.769304E-03,1.206300E-02,1.980000E-02,& + & 3.036700E-02,4.486600E-02,6.411300E-02,8.299900E-02,8.955300E-02,& + & 9.878400E-02,1.153751E-01,1.419562E-01,4.781178E-04,4.181138E-03,& + & 1.055600E-02,1.733000E-02,2.657500E-02,3.926100E-02,5.610200E-02,& + & 7.262700E-02,7.836000E-02,8.643800E-02,1.009555E-01,1.242156E-01,& + & 4.118581E-04,3.591691E-03,9.054700E-03,1.485900E-02,2.278400E-02,& + & 3.365700E-02,4.809000E-02,6.225300E-02,6.716500E-02,7.409400E-02,& + & 8.653328E-02,1.064650E-01,3.450032E-04,3.001480E-03,7.553300E-03,& + & 1.239100E-02,1.899200E-02,2.805300E-02,4.007800E-02,5.187800E-02,& + & 5.597400E-02,6.174900E-02,7.211451E-02,8.872151E-02,2.777835E-04,& + & 2.410763E-03,6.048500E-03,9.927500E-03,1.520300E-02,2.244900E-02,& + & 3.206700E-02,4.150600E-02,4.478200E-02,4.940300E-02,5.769335E-02,& + & 7.097686E-02,2.102693E-04,1.818763E-03,4.544100E-03,7.458100E-03,& + & 1.142100E-02,1.685000E-02,2.405600E-02,3.113200E-02,3.359200E-02,& + & 3.705900E-02,4.327197E-02,5.323162E-02,1.424631E-04,1.223614E-03,& + & 3.041900E-03,4.986800E-03,7.633700E-03,1.126300E-02,1.606200E-02,& + & 2.075700E-02,2.239900E-02,2.471500E-02,2.885265E-02,3.549150E-02,& + & 7.370968E-05,6.243819E-04,1.539500E-03,2.510500E-03,3.847500E-03,& + & 5.665900E-03,8.073500E-03,1.044400E-02,1.129700E-02,1.246100E-02,& + & 1.467919E-02,1.837884E-02,1.144533E-06,4.029386E-06,7.968600E-06,& + & 1.535200E-05,3.610700E-05,9.396900E-05,2.639300E-04,5.539100E-04,& + & 2.755900E-04,3.781000E-04,6.081928E-04,4.688359E-03,6.904904E-04,& + & 5.157394E-03,1.237400E-02,1.994300E-02,2.936500E-02,4.394900E-02,& + & 6.267500E-02,8.148600E-02,8.745000E-02,9.577900E-02,1.117758E-01,& + & 1.391751E-01,6.081326E-04,4.523200E-03,1.083500E-02,1.745600E-02,& + & 2.570200E-02,3.846200E-02,5.484400E-02,7.130100E-02,7.652700E-02,& + & 8.380200E-02,9.780647E-02,1.217757E-01,5.243257E-04,3.887531E-03,& + & 9.298500E-03,1.497300E-02,2.203900E-02,3.297500E-02,4.701400E-02,& + & 6.112000E-02,6.559300E-02,7.183700E-02,8.383647E-02,1.043788E-01,& + & 4.396782E-04,3.251427E-03,7.757100E-03,1.249500E-02,1.838100E-02,& + & 2.748900E-02,3.918400E-02,5.092800E-02,5.466700E-02,5.986600E-02,& + & 6.986763E-02,8.698782E-02,3.544969E-04,2.614589E-03,6.215000E-03,& + & 1.000800E-02,1.473100E-02,2.201300E-02,3.135300E-02,4.074600E-02,& + & 4.373900E-02,4.789900E-02,5.589552E-02,6.958729E-02,2.692121E-04,& + & 1.974455E-03,4.675100E-03,7.521300E-03,1.107200E-02,1.654800E-02,& + & 2.354200E-02,3.056400E-02,3.280800E-02,3.593500E-02,4.192584E-02,& + & 5.218917E-02,1.826335E-04,1.331345E-03,3.134900E-03,5.032700E-03,& + & 7.416300E-03,1.106500E-02,1.574700E-02,2.045200E-02,2.198300E-02,& + & 2.406800E-02,2.808915E-02,3.479477E-02,9.439959E-05,6.817277E-04,& + & 1.598100E-03,2.539600E-03,3.744700E-03,5.587400E-03,7.949300E-03,& + & 1.034600E-02,1.112100E-02,1.215800E-02,1.443657E-02,2.242969E-02/ + data absa( : ,351:375) / & + & 1.978755E-06,6.532251E-06,1.290700E-05,2.440800E-05,5.666600E-05,& + & 1.490700E-04,4.057800E-04,1.015200E-03,4.367800E-04,6.140600E-04,& + & 9.785326E-04,7.211637E-03,8.564374E-04,5.540635E-03,1.258600E-02,& + & 2.010000E-02,2.962100E-02,4.186000E-02,6.082900E-02,7.712900E-02,& + & 8.606800E-02,9.350000E-02,1.067523E-01,1.361668E-01,7.552093E-04,& + & 4.861263E-03,1.102800E-02,1.759700E-02,2.593000E-02,3.664100E-02,& + & 5.322900E-02,6.749000E-02,7.531500E-02,8.181600E-02,9.341231E-02,& + & 1.191498E-01,6.516905E-04,4.181471E-03,9.464800E-03,1.510500E-02,& + & 2.224300E-02,3.142000E-02,4.563200E-02,5.785500E-02,6.456500E-02,& + & 7.012100E-02,8.007145E-02,1.021341E-01,5.471739E-04,3.500698E-03,& + & 7.899800E-03,1.260400E-02,1.856900E-02,2.621100E-02,3.803300E-02,& + & 4.821400E-02,5.381100E-02,5.844800E-02,6.672737E-02,8.510896E-02,& + & 4.420736E-04,2.817480E-03,6.336200E-03,1.009900E-02,1.488400E-02,& + & 2.101100E-02,3.046400E-02,3.858100E-02,4.305300E-02,4.675600E-02,& + & 5.338500E-02,6.808987E-02,3.355352E-04,2.131325E-03,4.771400E-03,& + & 7.596300E-03,1.119900E-02,1.578800E-02,2.292500E-02,2.901400E-02,& + & 3.246300E-02,3.515200E-02,4.010245E-02,5.106506E-02,2.277563E-04,& + & 1.439816E-03,3.210500E-03,5.087100E-03,7.506100E-03,1.058400E-02,& + & 1.535400E-02,1.944300E-02,2.181400E-02,2.351500E-02,2.729838E-02,& + & 3.651828E-02,1.180820E-04,7.406912E-04,1.643700E-03,2.580400E-03,& + & 3.795700E-03,5.372600E-03,7.773900E-03,9.951500E-03,1.120300E-02,& + & 1.200300E-02,1.435178E-02,3.020314E-02,3.206422E-06,1.010191E-05,& + & 1.963300E-05,3.706700E-05,8.470200E-05,2.269700E-04,6.058200E-04,& + & 1.512100E-03,7.884600E-04,9.122300E-04,1.559458E-03,1.016525E-02,& + & 1.538349E-03,2.096142E-02,6.544300E-02,1.157900E-01,1.903100E-01,& + & 2.968200E-01,4.456200E-01,5.867400E-01,6.427900E-01,7.061600E-01,& + & 8.393467E-01,1.043383E+00,1.346594E-03,1.834292E-02,5.726400E-02,& + & 1.013200E-01,1.665200E-01,2.597100E-01,3.899200E-01,5.134000E-01,& + & 5.624500E-01,6.179100E-01,7.344290E-01,9.129089E-01,1.154788E-03,& + & 1.572463E-02,4.908400E-02,8.684300E-02,1.427300E-01,2.226200E-01,& + & 3.342200E-01,4.400700E-01,4.820700E-01,5.296500E-01,6.294947E-01,& + & 7.825249E-01,9.630397E-04,1.310571E-02,4.090400E-02,7.237200E-02,& + & 1.189400E-01,1.855100E-01,2.785200E-01,3.667100E-01,4.017300E-01,& + & 4.413600E-01,5.245699E-01,6.520786E-01,7.712666E-04,1.048774E-02,& + & 3.272300E-02,5.789900E-02,9.515900E-02,1.484100E-01,2.228100E-01,& + & 2.933700E-01,3.213800E-01,3.530900E-01,4.196683E-01,5.216486E-01,& + & 5.794680E-04,7.869089E-03,2.454300E-02,4.342600E-02,7.137000E-02,& + & 1.113100E-01,1.671100E-01,2.200300E-01,2.410500E-01,2.648300E-01,& + & 3.147607E-01,3.912500E-01,3.874362E-04,5.251118E-03,1.636400E-02,& + & 2.895400E-02,4.758300E-02,7.420800E-02,1.114100E-01,1.466900E-01,& + & 1.607000E-01,1.765500E-01,2.098431E-01,2.608300E-01,1.948075E-04,& + & 2.633128E-03,8.184800E-03,1.448100E-02,2.379400E-02,3.710700E-02,& + & 5.570800E-02,7.334700E-02,8.035000E-02,8.828200E-02,1.049197E-01,& + & 1.304100E-01,3.022358E-07,1.415735E-06,3.143200E-06,4.875800E-06,& + & 1.182500E-05,2.871300E-05,6.470800E-05,1.395400E-04,1.486100E-06,& + & 1.529000E-06,2.008503E-06,2.507582E-06,2.057281E-03,2.300492E-02,& + & 6.688000E-02,1.166100E-01,1.879000E-01,2.917300E-01,4.384000E-01,& + & 5.735000E-01,6.266300E-01,6.915100E-01,8.177963E-01,1.026744E+00,& + & 1.801060E-03,2.013347E-02,5.852100E-02,1.020300E-01,1.644200E-01,& + & 2.552600E-01,3.836000E-01,5.018400E-01,5.482800E-01,6.050700E-01,& + & 7.155581E-01,8.983979E-01,1.544919E-03,1.726096E-02,5.016200E-02,& + & 8.746000E-02,1.409300E-01,2.188100E-01,3.288100E-01,4.301500E-01,& + & 4.699700E-01,5.186100E-01,6.133544E-01,7.700608E-01,1.288746E-03,& + & 1.438851E-02,4.180200E-02,7.288600E-02,1.174400E-01,1.823400E-01,& + & 2.740100E-01,3.584500E-01,3.916400E-01,4.321800E-01,5.111241E-01,& + & 6.417288E-01,1.032661E-03,1.151605E-02,3.344300E-02,5.831100E-02,& + & 9.395800E-02,1.458700E-01,2.192100E-01,2.867600E-01,3.133100E-01,& + & 3.457600E-01,4.088981E-01,5.133981E-01,7.762731E-04,8.644030E-03,& + & 2.508300E-02,4.373700E-02,7.047100E-02,1.094100E-01,1.644100E-01,& + & 2.150700E-01,2.349800E-01,2.593000E-01,3.066722E-01,3.850323E-01/ + data absa( : ,376:400) / & + & 5.192564E-04,5.771225E-03,1.672800E-02,2.916300E-02,4.698500E-02,& + & 7.294100E-02,1.096100E-01,1.433900E-01,1.566600E-01,1.728800E-01,& + & 2.044541E-01,2.566866E-01,2.615990E-04,2.896433E-03,8.376300E-03,& + & 1.459100E-02,2.350000E-02,3.647700E-02,5.481100E-02,7.169400E-02,& + & 7.833100E-02,8.644500E-02,1.022296E-01,1.283495E-01,6.310343E-07,& + & 2.712471E-06,5.729700E-06,1.030700E-05,2.087300E-05,5.302600E-05,& + & 1.224600E-04,3.004400E-04,2.700200E-06,2.671700E-06,3.325059E-06,& + & 4.535857E-06,2.681610E-03,2.547084E-02,6.696500E-02,1.170900E-01,& + & 1.854900E-01,2.864700E-01,4.310100E-01,5.602100E-01,6.115100E-01,& + & 6.765000E-01,7.973622E-01,1.010563E+00,2.348246E-03,2.229263E-02,& + & 5.859600E-02,1.024600E-01,1.623100E-01,2.506600E-01,3.771400E-01,& + & 4.901700E-01,5.350500E-01,5.919400E-01,6.976775E-01,8.842967E-01,& + & 2.014763E-03,1.911490E-02,5.022700E-02,8.782500E-02,1.391200E-01,& + & 2.148600E-01,3.232600E-01,4.201400E-01,4.586100E-01,5.074000E-01,& + & 5.980450E-01,7.580102E-01,1.681506E-03,1.593659E-02,4.185700E-02,& + & 7.319200E-02,1.159400E-01,1.790500E-01,2.693900E-01,3.501200E-01,& + & 3.822000E-01,4.228400E-01,4.983525E-01,6.316591E-01,1.347910E-03,& + & 1.275764E-02,3.349100E-02,5.855900E-02,9.275700E-02,1.432500E-01,& + & 2.155100E-01,2.801000E-01,3.057500E-01,3.382700E-01,3.986994E-01,& + & 5.053288E-01,1.013556E-03,9.577815E-03,2.512800E-02,4.392500E-02,& + & 6.957400E-02,1.074400E-01,1.616400E-01,2.100800E-01,2.293100E-01,& + & 2.537100E-01,2.990086E-01,3.789889E-01,6.784286E-04,6.397587E-03,& + & 1.676700E-02,2.929300E-02,4.639100E-02,7.163400E-02,1.077700E-01,& + & 1.400500E-01,1.528800E-01,1.691400E-01,1.993455E-01,2.526825E-01,& + & 3.424082E-04,3.216301E-03,8.395400E-03,1.467400E-02,2.321300E-02,& + & 3.582900E-02,5.389200E-02,7.003100E-02,7.644300E-02,8.457900E-02,& + & 9.967900E-02,1.263363E-01,1.228766E-06,4.723434E-06,1.013200E-05,& + & 1.895500E-05,3.555400E-05,9.127300E-05,2.140400E-04,5.563600E-04,& + & 4.449100E-06,4.492200E-06,5.104044E-06,7.539558E-06,3.420323E-03,& + & 2.769268E-02,6.909500E-02,1.156600E-01,1.825500E-01,2.810000E-01,& + & 4.234100E-01,5.480200E-01,5.967500E-01,6.588800E-01,7.785142E-01,& + & 9.930578E-01,2.995856E-03,2.424023E-02,6.045900E-02,1.012100E-01,& + & 1.597400E-01,2.458800E-01,3.704800E-01,4.795300E-01,5.221400E-01,& + & 5.765400E-01,6.812174E-01,8.688715E-01,2.571473E-03,2.078629E-02,& + & 5.182700E-02,8.675700E-02,1.369300E-01,2.107600E-01,3.175600E-01,& + & 4.110500E-01,4.475300E-01,4.941700E-01,5.838945E-01,7.448038E-01,& + & 2.146956E-03,1.733143E-02,4.320100E-02,7.230400E-02,1.141100E-01,& + & 1.756400E-01,2.646400E-01,3.425100E-01,3.729600E-01,4.118300E-01,& + & 4.865855E-01,6.206538E-01,1.721625E-03,1.387620E-02,3.457500E-02,& + & 5.785200E-02,9.129800E-02,1.405200E-01,2.117100E-01,2.740300E-01,& + & 2.983700E-01,3.294600E-01,3.892682E-01,4.965200E-01,1.295224E-03,& + & 1.042162E-02,2.594800E-02,4.340200E-02,6.848600E-02,1.054000E-01,& + & 1.587900E-01,2.055200E-01,2.237900E-01,2.471000E-01,2.919592E-01,& + & 3.724137E-01,8.678091E-04,6.966143E-03,1.731100E-02,2.896700E-02,& + & 4.567200E-02,7.028200E-02,1.058700E-01,1.370200E-01,1.492000E-01,& + & 1.647300E-01,1.946441E-01,2.482887E-01,4.390983E-04,3.508110E-03,& + & 8.674900E-03,1.451200E-02,2.288600E-02,3.517700E-02,5.295000E-02,& + & 6.851200E-02,7.461200E-02,8.237100E-02,9.732144E-02,1.241387E-01,& + & 2.222386E-06,7.719264E-06,1.659200E-05,3.111400E-05,5.867100E-05,& + & 1.493700E-04,3.491900E-04,9.356100E-04,6.819200E-06,7.388700E-06,& + & 7.494141E-06,1.188358E-05,4.275854E-03,2.981264E-02,7.072300E-02,& + & 1.172000E-01,1.778500E-01,2.738500E-01,4.149000E-01,5.370900E-01,& + & 5.847400E-01,6.404000E-01,7.569410E-01,9.734572E-01,3.746186E-03,& + & 2.609687E-02,6.189400E-02,1.025500E-01,1.556300E-01,2.396300E-01,& + & 3.630500E-01,4.699100E-01,5.116700E-01,5.603400E-01,6.623409E-01,& + & 8.517975E-01,3.216593E-03,2.238013E-02,5.307000E-02,8.790900E-02,& + & 1.334100E-01,2.054000E-01,3.111900E-01,4.028000E-01,4.385500E-01,& + & 4.803100E-01,5.677308E-01,7.301097E-01,2.686597E-03,1.866288E-02,& + & 4.424700E-02,7.326600E-02,1.111800E-01,1.711800E-01,2.593300E-01,& + & 3.356800E-01,3.654700E-01,4.002800E-01,4.730884E-01,6.084366E-01/ + data absa( : ,401:425) / & + & 2.154673E-03,1.494633E-02,3.541700E-02,5.863400E-02,8.896000E-02,& + & 1.369600E-01,2.074800E-01,2.685200E-01,2.923900E-01,3.201900E-01,& + & 3.784966E-01,4.867600E-01,1.621540E-03,1.123055E-02,2.658000E-02,& + & 4.401100E-02,6.673700E-02,1.027400E-01,1.556100E-01,2.014200E-01,& + & 2.193000E-01,2.401600E-01,2.838643E-01,3.650522E-01,1.087476E-03,& + & 7.513719E-03,1.773900E-02,2.937200E-02,4.454700E-02,6.851600E-02,& + & 1.037600E-01,1.342800E-01,1.462100E-01,1.601000E-01,1.892464E-01,& + & 2.433757E-01,5.517120E-04,3.789485E-03,8.903000E-03,1.472000E-02,& + & 2.233600E-02,3.435000E-02,5.193300E-02,6.714300E-02,7.311700E-02,& + & 8.005700E-02,9.463585E-02,1.216865E-01,3.748362E-06,1.215822E-05,& + & 2.510900E-05,4.773100E-05,9.523400E-05,2.301100E-04,5.397800E-04,& + & 1.448500E-03,1.015200E-05,1.159700E-05,1.060643E-05,1.701907E-05,& + & 9.265659E-03,1.336862E-01,4.311700E-01,7.970400E-01,1.360700E+00,& + & 2.246100E+00,3.573900E+00,4.786100E+00,5.242700E+00,5.773400E+00,& + & 6.935344E+00,8.958370E+00,8.107784E-03,1.169776E-01,3.772700E-01,& + & 6.974100E-01,1.190500E+00,1.965400E+00,3.127200E+00,4.187800E+00,& + & 4.587500E+00,5.051800E+00,6.068465E+00,7.838360E+00,6.950302E-03,& + & 1.002695E-01,3.233800E-01,5.977800E-01,1.020500E+00,1.684600E+00,& + & 2.680400E+00,3.589600E+00,3.932000E+00,4.330100E+00,5.201646E+00,& + & 6.719089E+00,5.792178E-03,8.355616E-02,2.694800E-01,4.981500E-01,& + & 8.504000E-01,1.403800E+00,2.233700E+00,2.991300E+00,3.276700E+00,& + & 3.608500E+00,4.334660E+00,5.598681E+00,4.634450E-03,6.684810E-02,& + & 2.155900E-01,3.985200E-01,6.803100E-01,1.123100E+00,1.787000E+00,& + & 2.393000E+00,2.621400E+00,2.886600E+00,3.467603E+00,4.479134E+00,& + & 3.476571E-03,5.013951E-02,1.616900E-01,2.988900E-01,5.102400E-01,& + & 8.423000E-01,1.340200E+00,1.794800E+00,1.966000E+00,2.165100E+00,& + & 2.600740E+00,3.356289E+00,2.318812E-03,3.342901E-02,1.077900E-01,& + & 1.992600E-01,3.401600E-01,5.615400E-01,8.934900E-01,1.196500E+00,& + & 1.310700E+00,1.443400E+00,1.733760E+00,2.239367E+00,1.160951E-03,& + & 1.671962E-02,5.389800E-02,9.963500E-02,1.700800E-01,2.807700E-01,& + & 4.467500E-01,5.982700E-01,6.553800E-01,7.216700E-01,8.669260E-01,& + & 1.119746E+00,3.086326E-07,1.722366E-06,3.832100E-06,6.088100E-06,& + & 8.475900E-06,2.224000E-05,3.692300E-05,3.270400E-06,3.240500E-06,& + & 9.174800E-07,1.264164E-06,1.319598E-06,1.238150E-02,1.477507E-01,& + & 4.427500E-01,8.052400E-01,1.348200E+00,2.210600E+00,3.517300E+00,& + & 4.690300E+00,5.130800E+00,5.655000E+00,6.771044E+00,8.810270E+00,& + & 1.083492E-02,1.292823E-01,3.874000E-01,7.045800E-01,1.179600E+00,& + & 1.934300E+00,3.077700E+00,4.104000E+00,4.489400E+00,4.948100E+00,& + & 5.924642E+00,7.708133E+00,9.288283E-03,1.108183E-01,3.320600E-01,& + & 6.039300E-01,1.011100E+00,1.657900E+00,2.638100E+00,3.517800E+00,& + & 3.848000E+00,4.241400E+00,5.078256E+00,6.606883E+00,7.741103E-03,& + & 9.234997E-02,2.767200E-01,5.032800E-01,8.426000E-01,1.381600E+00,& + & 2.198300E+00,2.931500E+00,3.206700E+00,3.534400E+00,4.231927E+00,& + & 5.506072E+00,6.194316E-03,7.388592E-02,2.213800E-01,4.026300E-01,& + & 6.740800E-01,1.105300E+00,1.758700E+00,2.345200E+00,2.565400E+00,& + & 2.827500E+00,3.385502E+00,4.404823E+00,4.647330E-03,5.541755E-02,& + & 1.660300E-01,3.019700E-01,5.055600E-01,8.289700E-01,1.319000E+00,& + & 1.758900E+00,1.924100E+00,2.120600E+00,2.539217E+00,3.303611E+00,& + & 3.100489E-03,3.695263E-02,1.106900E-01,2.013200E-01,3.370500E-01,& + & 5.526500E-01,8.793600E-01,1.172600E+00,1.282700E+00,1.413800E+00,& + & 1.692810E+00,2.202373E+00,1.553596E-03,1.848554E-02,5.534700E-02,& + & 1.006700E-01,1.685300E-01,2.763300E-01,4.396800E-01,5.863200E-01,& + & 6.413600E-01,7.068800E-01,8.463898E-01,1.101187E+00,6.881044E-07,& + & 3.411283E-06,7.918900E-06,9.959200E-06,1.793800E-05,4.457500E-05,& + & 7.473400E-05,5.918500E-06,6.020700E-06,1.672800E-06,2.227645E-06,& + & 2.479403E-06,1.625114E-02,1.624971E-01,4.503800E-01,8.094400E-01,& + & 1.336000E+00,2.173700E+00,3.460100E+00,4.598400E+00,5.027800E+00,& + & 5.529300E+00,6.616709E+00,8.666170E+00,1.422132E-02,1.421926E-01,& + & 3.940900E-01,7.082700E-01,1.169000E+00,1.902000E+00,3.027600E+00,& + & 4.023700E+00,4.399300E+00,4.837900E+00,5.789658E+00,7.582395E+00/ + data absa( : ,426:450) / & + & 1.219100E-02,1.218849E-01,3.377900E-01,6.070800E-01,1.002000E+00,& + & 1.630300E+00,2.595100E+00,3.448700E+00,3.770800E+00,4.147000E+00,& + & 4.962290E+00,6.499446E+00,1.016152E-02,1.015751E-01,2.814900E-01,& + & 5.059100E-01,8.349800E-01,1.358600E+00,2.162600E+00,2.874000E+00,& + & 3.142400E+00,3.455800E+00,4.135422E+00,5.415861E+00,8.131787E-03,& + & 8.127110E-02,2.251900E-01,4.047300E-01,6.679800E-01,1.086900E+00,& + & 1.730100E+00,2.299200E+00,2.513900E+00,2.764600E+00,3.308177E+00,& + & 4.332847E+00,6.101604E-03,6.095996E-02,1.689000E-01,3.035600E-01,& + & 5.009900E-01,8.151600E-01,1.297600E+00,1.724400E+00,1.885400E+00,& + & 2.073500E+00,2.481348E+00,3.249612E+00,4.071266E-03,4.065162E-02,& + & 1.126000E-01,2.023800E-01,3.340000E-01,5.434500E-01,8.650600E-01,& + & 1.149600E+00,1.256900E+00,1.382300E+00,1.654097E+00,2.166411E+00,& + & 2.040970E-03,2.034044E-02,5.631300E-02,1.012000E-01,1.670100E-01,& + & 2.717300E-01,4.325300E-01,5.747900E-01,6.284700E-01,6.911300E-01,& + & 8.270284E-01,1.083224E+00,1.433062E-06,6.301266E-06,1.389000E-05,& + & 1.709700E-05,3.330200E-05,8.858700E-05,1.264500E-04,9.925200E-06,& + & 1.018100E-05,2.952600E-06,3.586903E-06,4.348908E-06,2.085897E-02,& + & 1.778696E-01,4.573100E-01,8.078200E-01,1.324300E+00,2.134800E+00,& + & 3.401300E+00,4.506700E+00,4.927600E+00,5.405400E+00,6.470112E+00,& + & 8.510069E+00,1.825387E-02,1.556480E-01,4.001500E-01,7.068500E-01,& + & 1.158800E+00,1.868000E+00,2.976200E+00,3.943400E+00,4.311700E+00,& + & 4.729700E+00,5.661302E+00,7.446452E+00,1.564911E-02,1.334199E-01,& + & 3.429900E-01,6.058900E-01,9.932500E-01,1.601100E+00,2.551000E+00,& + & 3.380200E+00,3.695600E+00,4.054000E+00,4.852524E+00,6.383022E+00,& + & 1.304399E-02,1.111871E-01,2.858300E-01,5.049100E-01,8.277100E-01,& + & 1.334200E+00,2.125800E+00,2.816800E+00,3.079800E+00,3.378300E+00,& + & 4.043769E+00,5.319028E+00,1.043891E-02,8.895910E-02,2.286800E-01,& + & 4.039300E-01,6.621700E-01,1.067400E+00,1.700700E+00,2.253500E+00,& + & 2.463800E+00,2.702700E+00,3.234876E+00,4.255261E+00,7.833923E-03,& + & 6.673204E-02,1.715200E-01,3.029500E-01,4.966400E-01,8.005600E-01,& + & 1.275500E+00,1.690100E+00,1.847800E+00,2.027000E+00,2.426243E+00,& + & 3.191403E+00,5.228879E-03,4.450306E-02,1.143600E-01,2.019800E-01,& + & 3.311100E-01,5.337300E-01,8.503400E-01,1.126700E+00,1.231900E+00,& + & 1.351400E+00,1.617588E+00,2.127686E+00,2.622592E-03,2.227271E-02,& + & 5.721200E-02,1.010000E-01,1.655700E-01,2.668800E-01,4.251800E-01,& + & 5.633700E-01,6.159600E-01,6.756800E-01,8.087611E-01,1.063881E+00,& + & 2.771430E-06,1.081105E-05,2.204200E-05,2.986200E-05,5.509700E-05,& + & 1.580000E-04,2.043400E-04,1.563900E-05,1.569000E-05,4.876700E-06,& + & 5.477383E-06,7.066436E-06,2.618808E-02,1.919642E-01,4.719200E-01,& + & 8.029300E-01,1.304700E+00,2.095200E+00,3.340800E+00,4.432000E+00,& + & 4.817500E+00,5.273300E+00,6.329917E+00,8.341716E+00,2.291895E-02,& + & 1.679806E-01,4.129400E-01,7.025500E-01,1.141600E+00,1.833300E+00,& + & 2.923100E+00,3.878000E+00,4.215400E+00,4.614500E+00,5.538586E+00,& + & 7.298516E+00,1.964932E-02,1.439967E-01,3.539600E-01,6.022000E-01,& + & 9.785100E-01,1.571400E+00,2.505600E+00,3.323900E+00,3.612900E+00,& + & 3.955000E+00,4.747476E+00,6.255832E+00,1.637967E-02,1.200047E-01,& + & 2.949900E-01,5.018400E-01,8.154300E-01,1.309500E+00,2.088000E+00,& + & 2.769900E+00,3.010900E+00,3.295900E+00,3.956284E+00,5.213386E+00,& + & 1.310996E-02,9.601692E-02,2.360000E-01,4.014900E-01,6.523600E-01,& + & 1.047600E+00,1.670400E+00,2.216000E+00,2.408800E+00,2.636600E+00,& + & 3.164958E+00,4.170565E+00,9.840338E-03,7.202778E-02,1.770300E-01,& + & 3.011200E-01,4.892900E-01,7.857200E-01,1.252800E+00,1.662000E+00,& + & 1.806600E+00,1.977500E+00,2.373649E+00,3.127992E+00,6.570462E-03,& + & 4.803712E-02,1.180500E-01,2.007700E-01,3.262100E-01,5.238300E-01,& + & 8.352100E-01,1.108000E+00,1.204400E+00,1.318400E+00,1.582479E+00,& + & 2.085307E+00,3.296474E-03,2.405058E-02,5.906300E-02,1.004300E-01,& + & 1.631400E-01,2.619400E-01,4.176300E-01,5.540100E-01,6.022600E-01,& + & 6.591900E-01,7.912452E-01,1.042710E+00,5.038214E-06,1.632587E-05,& + & 3.581900E-05,4.867400E-05,9.039300E-05,2.585400E-04,3.093000E-04,& + & 2.326000E-05,2.285100E-05,7.765500E-06,8.036575E-06,1.054381E-05/ + data absa( : ,451:475) / & + & 2.167454E-02,2.993438E-01,9.608200E-01,1.832000E+00,3.227600E+00,& + & 5.626300E+00,9.542300E+00,1.311800E+01,1.444400E+01,1.578500E+01,& + & 1.921419E+01,2.570058E+01,1.896576E-02,2.619293E-01,8.407300E-01,& + & 1.603100E+00,2.824200E+00,4.923000E+00,8.349500E+00,1.147800E+01,& + & 1.263900E+01,1.381200E+01,1.681236E+01,2.249028E+01,1.625659E-02,& + & 2.245101E-01,7.206200E-01,1.374000E+00,2.420800E+00,4.219700E+00,& + & 7.156700E+00,9.838100E+00,1.083300E+01,1.183900E+01,1.441053E+01,& + & 1.927810E+01,1.354786E-02,1.870935E-01,6.005200E-01,1.145000E+00,& + & 2.017300E+00,3.516400E+00,5.963900E+00,8.198300E+00,9.027700E+00,& + & 9.865900E+00,1.200892E+01,1.606404E+01,1.083919E-02,1.496753E-01,& + & 4.804200E-01,9.160200E-01,1.613800E+00,2.813200E+00,4.771200E+00,& + & 6.558800E+00,7.222300E+00,7.892500E+00,9.606850E+00,1.285173E+01,& + & 8.129916E-03,1.122625E-01,3.603200E-01,6.870300E-01,1.210400E+00,& + & 2.109900E+00,3.578400E+00,4.919200E+00,5.416700E+00,5.919400E+00,& + & 7.205271E+00,9.638600E+00,5.421039E-03,7.484429E-02,2.402100E-01,& + & 4.580200E-01,8.069300E-01,1.406600E+00,2.385600E+00,3.279400E+00,& + & 3.611100E+00,3.946300E+00,4.803547E+00,6.425990E+00,2.712110E-03,& + & 3.742711E-02,1.201100E-01,2.290100E-01,4.034600E-01,7.033000E-01,& + & 1.192800E+00,1.639700E+00,1.805600E+00,1.973200E+00,2.401763E+00,& + & 3.212933E+00,3.252307E-07,1.795226E-06,4.125200E-06,6.479400E-06,& + & 7.368100E-06,2.421500E-05,3.349400E-05,2.273400E-06,3.392800E-06,& + & 7.454900E-07,1.057965E-06,9.613008E-07,2.879567E-02,3.313570E-01,& + & 9.888300E-01,1.851000E+00,3.211700E+00,5.544200E+00,9.392900E+00,& + & 1.287800E+01,1.419100E+01,1.547900E+01,1.877896E+01,2.529995E+01,& + & 2.519722E-02,2.899457E-01,8.652400E-01,1.619600E+00,2.810300E+00,& + & 4.851200E+00,8.218800E+00,1.126800E+01,1.241700E+01,1.354400E+01,& + & 1.643191E+01,2.213690E+01,2.159851E-02,2.485252E-01,7.416400E-01,& + & 1.388300E+00,2.408800E+00,4.158200E+00,7.044700E+00,9.658700E+00,& + & 1.064300E+01,1.160900E+01,1.408403E+01,1.897497E+01,1.799985E-02,& + & 2.071092E-01,6.180200E-01,1.156900E+00,2.007300E+00,3.465200E+00,& + & 5.870600E+00,8.048800E+00,8.869500E+00,9.673800E+00,1.173675E+01,& + & 1.581228E+01,1.440114E-02,1.656941E-01,4.944200E-01,9.255300E-01,& + & 1.605900E+00,2.772100E+00,4.696500E+00,6.439100E+00,7.095600E+00,& + & 7.739300E+00,9.389724E+00,1.264935E+01,1.080218E-02,1.242759E-01,& + & 3.708200E-01,6.941500E-01,1.204400E+00,2.079100E+00,3.522400E+00,& + & 4.829300E+00,5.321700E+00,5.804500E+00,7.042246E+00,9.486834E+00,& + & 7.203659E-03,8.285604E-02,2.472200E-01,4.627700E-01,8.029400E-01,& + & 1.386100E+00,2.348300E+00,3.219600E+00,3.547600E+00,3.869500E+00,& + & 4.694923E+00,6.324801E+00,3.605085E-03,4.143761E-02,1.236100E-01,& + & 2.313900E-01,4.014700E-01,6.930400E-01,1.174100E+00,1.609800E+00,& + & 1.773900E+00,1.934800E+00,2.347412E+00,3.162394E+00,7.230914E-07,& + & 3.591421E-06,8.289000E-06,1.121800E-05,1.528100E-05,5.067300E-05,& + & 6.487500E-05,4.246000E-06,6.316300E-06,1.408300E-06,1.870135E-06,& + & 1.821353E-06,3.754659E-02,3.638273E-01,1.009900E+00,1.863100E+00,& + & 3.194900E+00,5.457300E+00,9.240400E+00,1.267700E+01,1.391900E+01,& + & 1.518000E+01,1.837537E+01,2.486602E+01,3.285508E-02,3.183429E-01,& + & 8.837100E-01,1.630300E+00,2.795500E+00,4.775200E+00,8.085300E+00,& + & 1.109200E+01,1.217900E+01,1.328300E+01,1.607827E+01,2.175816E+01,& + & 2.816258E-02,2.728781E-01,7.574500E-01,1.397400E+00,2.396200E+00,& + & 4.093000E+00,6.930300E+00,9.507600E+00,1.043900E+01,1.138500E+01,& + & 1.378117E+01,1.865054E+01,2.347107E-02,2.273985E-01,6.312200E-01,& + & 1.164500E+00,1.996800E+00,3.410800E+00,5.775200E+00,7.923000E+00,& + & 8.699400E+00,9.488100E+00,1.148406E+01,1.554068E+01,1.877941E-02,& + & 1.819285E-01,5.049800E-01,9.316000E-01,1.597500E+00,2.728600E+00,& + & 4.620200E+00,6.338300E+00,6.959400E+00,7.590200E+00,9.187573E+00,& + & 1.243382E+01,1.408789E-02,1.364552E-01,3.787400E-01,6.987100E-01,& + & 1.198100E+00,2.046500E+00,3.465100E+00,4.753900E+00,5.219700E+00,& + & 5.692700E+00,6.890644E+00,9.325235E+00,9.395516E-03,9.097664E-02,& + & 2.525100E-01,4.658000E-01,7.987400E-01,1.364300E+00,2.310100E+00,& + & 3.169200E+00,3.479700E+00,3.795100E+00,4.593670E+00,6.216648E+00/ + data absa( : ,476:500) / & + & 4.703722E-03,4.550143E-02,1.262700E-01,2.329100E-01,3.993800E-01,& + & 6.821800E-01,1.155100E+00,1.584600E+00,1.739900E+00,1.897500E+00,& + & 2.296935E+00,3.108274E+00,1.511769E-06,6.806578E-06,1.375200E-05,& + & 1.922800E-05,2.916600E-05,9.623100E-05,1.137800E-04,7.150900E-06,& + & 1.060300E-05,2.449200E-06,3.069126E-06,3.210804E-06,4.797143E-02,& + & 3.979444E-01,1.027500E+00,1.864000E+00,3.173900E+00,5.371900E+00,& + & 9.086300E+00,1.245200E+01,1.365200E+01,1.487500E+01,1.799210E+01,& + & 2.439079E+01,4.197727E-02,3.482163E-01,8.990400E-01,1.631000E+00,& + & 2.777100E+00,4.700400E+00,7.950600E+00,1.089600E+01,1.194600E+01,& + & 1.301600E+01,1.574328E+01,2.134272E+01,3.598409E-02,2.984734E-01,& + & 7.706300E-01,1.398000E+00,2.380400E+00,4.029000E+00,6.814800E+00,& + & 9.339500E+00,1.023900E+01,1.115700E+01,1.349446E+01,1.829365E+01,& + & 2.998992E-02,2.487349E-01,6.422000E-01,1.165000E+00,1.983700E+00,& + & 3.357500E+00,5.679000E+00,7.783100E+00,8.532600E+00,9.297200E+00,& + & 1.124525E+01,1.524546E+01,2.399624E-02,1.989968E-01,5.137700E-01,& + & 9.320100E-01,1.587000E+00,2.686000E+00,4.543200E+00,6.226300E+00,& + & 6.825900E+00,7.437800E+00,8.996315E+00,1.219564E+01,1.800238E-02,& + & 1.492555E-01,3.853400E-01,6.990400E-01,1.190200E+00,2.014500E+00,& + & 3.407400E+00,4.669900E+00,5.119300E+00,5.578400E+00,6.747153E+00,& + & 9.147713E+00,1.200822E-02,9.951685E-02,2.569100E-01,4.660300E-01,& + & 7.935000E-01,1.343000E+00,2.271600E+00,3.113300E+00,3.412900E+00,& + & 3.718900E+00,4.498041E+00,6.098209E+00,6.014249E-03,4.977627E-02,& + & 1.284900E-01,2.330400E-01,3.967700E-01,6.715300E-01,1.135800E+00,& + & 1.556600E+00,1.706500E+00,1.859400E+00,2.249051E+00,3.048717E+00,& + & 2.942490E-06,1.161135E-05,2.187800E-05,3.363300E-05,4.902600E-05,& + & 1.700700E-04,1.819500E-04,1.224400E-05,1.665900E-05,4.048100E-06,& + & 4.784644E-06,5.105331E-06,6.010568E-02,4.295913E-01,1.061900E+00,& + & 1.848000E+00,3.146600E+00,5.280400E+00,8.933400E+00,1.224100E+01,& + & 1.334800E+01,1.458400E+01,1.761628E+01,2.389060E+01,5.259790E-02,& + & 3.758959E-01,9.292100E-01,1.617000E+00,2.753200E+00,4.620400E+00,& + & 7.816700E+00,1.071100E+01,1.168000E+01,1.276100E+01,1.541425E+01,& + & 2.090476E+01,4.508914E-02,3.222108E-01,7.965100E-01,1.386000E+00,& + & 2.359900E+00,3.960300E+00,6.700100E+00,9.181000E+00,1.001100E+01,& + & 1.093800E+01,1.321221E+01,1.791929E+01,3.758037E-02,2.685157E-01,& + & 6.637400E-01,1.155000E+00,1.966600E+00,3.300200E+00,5.583400E+00,& + & 7.650900E+00,8.342400E+00,9.115000E+00,1.101018E+01,1.493158E+01,& + & 3.007061E-02,2.148255E-01,5.310300E-01,9.240200E-01,1.573300E+00,& + & 2.640200E+00,4.466800E+00,6.120700E+00,6.674200E+00,7.292100E+00,& + & 8.808147E+00,1.194499E+01,2.256144E-02,1.611304E-01,3.982900E-01,& + & 6.930500E-01,1.180000E+00,1.980200E+00,3.350100E+00,4.590300E+00,& + & 5.005600E+00,5.468900E+00,6.605967E+00,8.959209E+00,1.505147E-02,& + & 1.074391E-01,2.655600E-01,4.620600E-01,7.866800E-01,1.320100E+00,& + & 2.233400E+00,3.060400E+00,3.337100E+00,3.646000E+00,4.404032E+00,& + & 5.972905E+00,7.541920E-03,5.374407E-02,1.328200E-01,2.310800E-01,& + & 3.933800E-01,6.600900E-01,1.116700E+00,1.530200E+00,1.668500E+00,& + & 1.823000E+00,2.202057E+00,2.986403E+00,5.340987E-06,1.809593E-05,& + & 3.379800E-05,5.608600E-05,8.312800E-05,2.766500E-04,2.687400E-04,& + & 2.096700E-05,2.450000E-05,6.132400E-06,7.215857E-06,7.916190E-06,& + & 3.201720E-02,4.219472E-01,1.344800E+00,2.627600E+00,4.807100E+00,& + & 8.834300E+00,1.601800E+01,2.286400E+01,2.528500E+01,2.785100E+01,& + & 3.387950E+01,4.659111E+01,2.801450E-02,3.692077E-01,1.176700E+00,& + & 2.299100E+00,4.206200E+00,7.730000E+00,1.401600E+01,2.000500E+01,& + & 2.212500E+01,2.436900E+01,2.964409E+01,4.076627E+01,2.401268E-02,& + & 3.164629E-01,1.008600E+00,1.970700E+00,3.605300E+00,6.625600E+00,& + & 1.201300E+01,1.714800E+01,1.896400E+01,2.088800E+01,2.540967E+01,& + & 3.494243E+01,2.001151E-02,2.637182E-01,8.404900E-01,1.642200E+00,& + & 3.004400E+00,5.521400E+00,1.001100E+01,1.429000E+01,1.580300E+01,& + & 1.740700E+01,2.117425E+01,2.912133E+01,1.600926E-02,2.109786E-01,& + & 6.724000E-01,1.313800E+00,2.403500E+00,4.417100E+00,8.008900E+00,& + & 1.143200E+01,1.264200E+01,1.392500E+01,1.693945E+01,2.329512E+01/ + data absa( : ,501:525) / & + & 1.200799E-02,1.582349E-01,5.042900E-01,9.853600E-01,1.802700E+00,& + & 3.312800E+00,6.006500E+00,8.573800E+00,9.481900E+00,1.044400E+01,& + & 1.270442E+01,1.747177E+01,8.006768E-03,1.054927E-01,3.362000E-01,& + & 6.569000E-01,1.201800E+00,2.208500E+00,4.004300E+00,5.715700E+00,& + & 6.321000E+00,6.962500E+00,8.469584E+00,1.164756E+01,4.004802E-03,& + & 5.275104E-02,1.681000E-01,3.284500E-01,6.008900E-01,1.104300E+00,& + & 2.002200E+00,2.858000E+00,3.160500E+00,3.481300E+00,4.234773E+00,& + & 5.823929E+00,3.042456E-07,1.698164E-06,3.844400E-06,6.196900E-06,& + & 7.831100E-06,2.537200E-05,3.322700E-05,1.818400E-06,2.116700E-06,& + & 1.796700E-06,8.930240E-07,7.096812E-07,4.240860E-02,4.672521E-01,& + & 1.387000E+00,2.658700E+00,4.798200E+00,8.717400E+00,1.577800E+01,& + & 2.248700E+01,2.488000E+01,2.738100E+01,3.314929E+01,4.582783E+01,& + & 3.710790E-02,4.088412E-01,1.213600E+00,2.326400E+00,4.198500E+00,& + & 7.627800E+00,1.380600E+01,1.967600E+01,2.176900E+01,2.395800E+01,& + & 2.900599E+01,4.009772E+01,3.180721E-02,3.504402E-01,1.040300E+00,& + & 1.994000E+00,3.598700E+00,6.538100E+00,1.183400E+01,1.686400E+01,& + & 1.865900E+01,2.053600E+01,2.486191E+01,3.437162E+01,2.650701E-02,& + & 2.920344E-01,8.668900E-01,1.661700E+00,2.998900E+00,5.448400E+00,& + & 9.861400E+00,1.405400E+01,1.555000E+01,1.711300E+01,2.071861E+01,& + & 2.864277E+01,2.120715E-02,2.336335E-01,6.935100E-01,1.329300E+00,& + & 2.399100E+00,4.358700E+00,7.889200E+00,1.124300E+01,1.244000E+01,& + & 1.369100E+01,1.657454E+01,2.291429E+01,1.590715E-02,1.752246E-01,& + & 5.201400E-01,9.970100E-01,1.799300E+00,3.269000E+00,5.916900E+00,& + & 8.432100E+00,9.329900E+00,1.026800E+01,1.243046E+01,1.718493E+01,& + & 1.060684E-02,1.168231E-01,3.467500E-01,6.646800E-01,1.199600E+00,& + & 2.179400E+00,3.944600E+00,5.621500E+00,6.219800E+00,6.845300E+00,& + & 8.287390E+00,1.145708E+01,5.306529E-03,5.841921E-02,1.733800E-01,& + & 3.323400E-01,5.997800E-01,1.089700E+00,1.972300E+00,2.810700E+00,& + & 3.109900E+00,3.422600E+00,4.143506E+00,5.728591E+00,6.823766E-07,& + & 3.393304E-06,8.165600E-06,9.919100E-06,1.650000E-05,5.264200E-05,& + & 6.484300E-05,3.385200E-06,3.889700E-06,3.355100E-06,1.604738E-06,& + & 1.377587E-06,5.512540E-02,5.144061E-01,1.419900E+00,2.677100E+00,& + & 4.785300E+00,8.596200E+00,1.553600E+01,2.212600E+01,2.443300E+01,& + & 2.689800E+01,3.247848E+01,4.499857E+01,4.823585E-02,4.501002E-01,& + & 1.242400E+00,2.342500E+00,4.187200E+00,7.521600E+00,1.359400E+01,& + & 1.936000E+01,2.137900E+01,2.353500E+01,2.841841E+01,3.937375E+01,& + & 4.134631E-02,3.858047E-01,1.064900E+00,2.007800E+00,3.589000E+00,& + & 6.447100E+00,1.165200E+01,1.659400E+01,1.832500E+01,2.017300E+01,& + & 2.435896E+01,3.374980E+01,3.445776E-02,3.215039E-01,8.874700E-01,& + & 1.673200E+00,2.990900E+00,5.372600E+00,9.710000E+00,1.382900E+01,& + & 1.527100E+01,1.681100E+01,2.029850E+01,2.812411E+01,2.756871E-02,& + & 2.572080E-01,7.099800E-01,1.338600E+00,2.392700E+00,4.298100E+00,& + & 7.767900E+00,1.106300E+01,1.221700E+01,1.344900E+01,1.623843E+01,& + & 2.249854E+01,2.067951E-02,1.929121E-01,5.324900E-01,1.003900E+00,& + & 1.794500E+00,3.223600E+00,5.826000E+00,8.296900E+00,9.162200E+00,& + & 1.008600E+01,1.217898E+01,1.687384E+01,1.379014E-02,1.286135E-01,& + & 3.550000E-01,6.692900E-01,1.196300E+00,2.149000E+00,3.884000E+00,& + & 5.531500E+00,6.108100E+00,6.724300E+00,8.119323E+00,1.124927E+01,& + & 6.901257E-03,6.431860E-02,1.775200E-01,3.346500E-01,5.981800E-01,& + & 1.074500E+00,1.942000E+00,2.765700E+00,3.054100E+00,3.362100E+00,& + & 4.059761E+00,5.624834E+00,1.422504E-06,6.368581E-06,1.351800E-05,& + & 1.732600E-05,3.139800E-05,9.993400E-05,1.129000E-04,6.408600E-06,& + & 6.678600E-06,5.799900E-06,2.689830E-06,2.376514E-06,7.019735E-02,& + & 5.621355E-01,1.455300E+00,2.678600E+00,4.763600E+00,8.473000E+00,& + & 1.529200E+01,2.177200E+01,2.394800E+01,2.642200E+01,3.181916E+01,& + & 4.416469E+01,6.142506E-02,4.918740E-01,1.273400E+00,2.343800E+00,& + & 4.168200E+00,7.413900E+00,1.338000E+01,1.905000E+01,2.095500E+01,& + & 2.312000E+01,2.784188E+01,3.864527E+01,5.265179E-02,4.216129E-01,& + & 1.091500E+00,2.009000E+00,3.572700E+00,6.354700E+00,1.146900E+01,& + & 1.632800E+01,1.796000E+01,1.981600E+01,2.386383E+01,3.312296E+01/ + data absa( : ,526:550) / & + & 4.388150E-02,3.513466E-01,9.095800E-01,1.674200E+00,2.977300E+00,& + & 5.295600E+00,9.557500E+00,1.360700E+01,1.496700E+01,1.651300E+01,& + & 1.988694E+01,2.760378E+01,3.510872E-02,2.810803E-01,7.276900E-01,& + & 1.339300E+00,2.381800E+00,4.236500E+00,7.646000E+00,1.088600E+01,& + & 1.197400E+01,1.321100E+01,1.590927E+01,2.208147E+01,2.633640E-02,& + & 2.108189E-01,5.457800E-01,1.004500E+00,1.786400E+00,3.177400E+00,& + & 5.734400E+00,8.164400E+00,8.980300E+00,9.908300E+00,1.193222E+01,& + & 1.656229E+01,1.756462E-02,1.405546E-01,3.638600E-01,6.696800E-01,& + & 1.190900E+00,2.118300E+00,3.823000E+00,5.442900E+00,5.987000E+00,& + & 6.605500E+00,7.954882E+00,1.104149E+01,8.792566E-03,7.029417E-02,& + & 1.819600E-01,3.348700E-01,5.954800E-01,1.059100E+00,1.911500E+00,& + & 2.721500E+00,2.993400E+00,3.302700E+00,3.977388E+00,5.520669E+00,& + & 2.756719E-06,1.108192E-05,2.067400E-05,3.060000E-05,5.631500E-05,& + & 1.748600E-04,1.763600E-04,1.140200E-05,1.064900E-05,8.864800E-06,& + & 4.285928E-06,3.808024E-06,8.760221E-02,6.072237E-01,1.504900E+00,& + & 2.673800E+00,4.723400E+00,8.342700E+00,1.504400E+01,2.141600E+01,& + & 2.347400E+01,2.589300E+01,3.117425E+01,4.331781E+01,7.665367E-02,& + & 5.313293E-01,1.316800E+00,2.339600E+00,4.133000E+00,7.299900E+00,& + & 1.316300E+01,1.874000E+01,2.054000E+01,2.265700E+01,2.727670E+01,& + & 3.790178E+01,6.570957E-02,4.554301E-01,1.128700E+00,2.005400E+00,& + & 3.542600E+00,6.257100E+00,1.128300E+01,1.606300E+01,1.760600E+01,& + & 1.942000E+01,2.338049E+01,3.248787E+01,5.476447E-02,3.795309E-01,& + & 9.405800E-01,1.671100E+00,2.952100E+00,5.214200E+00,9.402200E+00,& + & 1.338600E+01,1.467100E+01,1.618300E+01,1.948411E+01,2.707195E+01,& + & 4.381740E-02,3.036320E-01,7.524900E-01,1.336900E+00,2.361800E+00,& + & 4.171400E+00,7.521800E+00,1.070800E+01,1.173700E+01,1.294600E+01,& + & 1.558712E+01,2.165804E+01,3.287226E-02,2.277324E-01,5.643900E-01,& + & 1.002700E+00,1.771300E+00,3.128500E+00,5.641400E+00,8.031300E+00,& + & 8.802900E+00,9.709800E+00,1.169036E+01,1.624475E+01,2.192661E-02,& + & 1.518384E-01,3.762800E-01,6.685200E-01,1.180900E+00,2.085700E+00,& + & 3.760900E+00,5.354000E+00,5.868500E+00,6.473200E+00,7.793322E+00,& + & 1.082871E+01,1.097965E-02,7.594025E-02,1.881700E-01,3.343200E-01,& + & 5.904700E-01,1.042900E+00,1.880500E+00,2.677100E+00,2.934200E+00,& + & 3.236600E+00,3.896583E+00,5.414603E+00,4.996320E-06,1.688953E-05,& + & 3.322100E-05,4.957400E-05,9.410400E-05,2.822500E-04,2.672300E-04,& + & 1.664500E-05,1.744400E-05,1.303000E-05,6.496915E-06,5.887418E-06,& + & 3.796201E-02,4.782320E-01,1.511200E+00,3.014100E+00,5.732000E+00,& + & 1.108800E+01,2.159700E+01,3.227200E+01,3.600400E+01,4.005600E+01,& + & 4.883023E+01,6.790023E+01,3.321750E-02,4.184490E-01,1.322300E+00,& + & 2.637300E+00,5.015500E+00,9.701900E+00,1.889700E+01,2.823700E+01,& + & 3.150500E+01,3.504900E+01,4.272575E+01,5.941128E+01,2.847300E-02,& + & 3.586712E-01,1.133400E+00,2.260600E+00,4.298900E+00,8.315900E+00,& + & 1.619700E+01,2.420300E+01,2.700300E+01,3.004200E+01,3.662126E+01,& + & 5.092594E+01,2.372761E-02,2.988986E-01,9.445200E-01,1.883800E+00,& + & 3.582400E+00,6.929900E+00,1.349800E+01,2.017000E+01,2.250300E+01,& + & 2.503500E+01,3.051899E+01,4.243872E+01,1.898280E-02,2.391208E-01,& + & 7.556100E-01,1.507000E+00,2.866000E+00,5.543900E+00,1.079800E+01,& + & 1.613600E+01,1.800300E+01,2.002800E+01,2.441451E+01,3.395012E+01,& + & 1.423795E-02,1.793420E-01,5.667000E-01,1.130300E+00,2.149500E+00,& + & 4.157900E+00,8.098600E+00,1.210100E+01,1.350200E+01,1.502100E+01,& + & 1.831024E+01,2.546378E+01,9.492998E-03,1.195657E-01,3.778100E-01,& + & 7.535300E-01,1.433000E+00,2.772000E+00,5.399100E+00,8.067700E+00,& + & 9.000900E+00,1.001400E+01,1.220736E+01,1.697444E+01,4.748041E-03,& + & 5.978561E-02,1.889100E-01,3.767600E-01,7.164900E-01,1.386000E+00,& + & 2.699500E+00,4.033800E+00,4.500400E+00,5.006800E+00,6.103699E+00,& + & 8.488117E+00,2.615101E-07,1.394073E-06,3.413600E-06,5.467600E-06,& + & 9.554200E-06,2.284300E-05,3.890400E-05,1.431700E-06,1.491800E-06,& + & 1.933900E-06,7.337447E-07,7.500887E-07,5.017533E-02,5.300650E-01,& + & 1.563000E+00,3.053300E+00,5.735300E+00,1.096300E+01,2.129500E+01,& + & 3.178300E+01,3.538900E+01,3.954300E+01,4.778659E+01,6.678882E+01/ + data absa( : ,551:575) / & + & 4.390405E-02,4.638095E-01,1.367700E+00,2.671600E+00,5.018400E+00,& + & 9.592400E+00,1.863300E+01,2.781000E+01,3.096500E+01,3.459900E+01,& + & 4.181294E+01,5.843760E+01,3.763275E-02,3.975488E-01,1.172300E+00,& + & 2.290000E+00,4.301500E+00,8.222000E+00,1.597100E+01,2.383700E+01,& + & 2.654100E+01,2.965700E+01,3.583969E+01,5.009062E+01,3.136196E-02,& + & 3.312932E-01,9.769000E-01,1.908300E+00,3.584500E+00,6.851800E+00,& + & 1.330900E+01,1.986400E+01,2.211800E+01,2.471300E+01,2.986644E+01,& + & 4.174089E+01,2.509112E-02,2.650425E-01,7.815300E-01,1.526600E+00,& + & 2.867600E+00,5.481400E+00,1.064700E+01,1.589100E+01,1.769400E+01,& + & 1.977100E+01,2.389279E+01,3.339278E+01,1.881964E-02,1.987818E-01,& + & 5.861400E-01,1.145000E+00,2.150700E+00,4.111000E+00,7.985500E+00,& + & 1.191900E+01,1.327100E+01,1.482800E+01,1.792054E+01,2.504531E+01,& + & 1.254863E-02,1.325242E-01,3.907700E-01,7.633200E-01,1.433800E+00,& + & 2.740700E+00,5.323700E+00,7.945500E+00,8.846900E+00,9.885400E+00,& + & 1.194590E+01,1.669683E+01,6.277374E-03,6.626901E-02,1.953900E-01,& + & 3.816600E-01,7.169100E-01,1.370300E+00,2.661800E+00,3.972800E+00,& + & 4.423500E+00,4.942800E+00,5.973304E+00,8.348654E+00,5.883982E-07,& + & 2.841547E-06,7.231400E-06,9.004900E-06,1.910900E-05,4.791200E-05,& + & 7.585700E-05,3.004600E-06,2.853500E-06,3.642400E-06,1.367818E-06,& + & 1.300199E-06,6.501733E-02,5.851413E-01,1.602900E+00,3.079700E+00,& + & 5.727800E+00,1.083600E+01,2.098900E+01,3.126700E+01,3.477900E+01,& + & 3.893200E+01,4.679358E+01,6.571158E+01,5.689415E-02,5.120025E-01,& + & 1.402500E+00,2.694700E+00,5.011900E+00,9.481500E+00,1.836600E+01,& + & 2.735900E+01,3.043200E+01,3.406500E+01,4.094507E+01,5.749967E+01,& + & 4.876798E-02,4.388537E-01,1.202200E+00,2.309700E+00,4.295900E+00,& + & 8.126900E+00,1.574200E+01,2.345000E+01,2.608400E+01,2.919800E+01,& + & 3.509556E+01,4.928115E+01,4.064183E-02,3.657197E-01,1.001800E+00,& + & 1.924800E+00,3.579900E+00,6.772500E+00,1.311800E+01,1.954200E+01,& + & 2.173700E+01,2.433300E+01,2.924583E+01,4.107013E+01,3.251616E-02,& + & 2.925757E-01,8.014600E-01,1.539800E+00,2.863900E+00,5.417900E+00,& + & 1.049400E+01,1.563300E+01,1.738900E+01,1.946500E+01,2.339610E+01,& + & 3.285661E+01,2.439005E-02,2.194368E-01,6.011000E-01,1.154900E+00,& + & 2.147900E+00,4.063500E+00,7.871000E+00,1.172500E+01,1.304200E+01,& + & 1.459900E+01,1.754798E+01,2.464145E+01,1.626387E-02,1.462987E-01,& + & 4.007400E-01,7.699300E-01,1.432000E+00,2.709000E+00,5.247200E+00,& + & 7.816900E+00,8.694800E+00,9.733000E+00,1.169824E+01,1.642793E+01,& + & 8.138215E-03,7.315778E-02,2.003900E-01,3.849900E-01,7.159900E-01,& + & 1.354500E+00,2.623600E+00,3.908300E+00,4.347400E+00,4.866300E+00,& + & 5.849044E+00,8.213801E+00,1.227003E-06,5.204614E-06,1.293300E-05,& + & 1.549300E-05,3.643600E-05,9.185000E-05,1.301500E-04,5.747300E-06,& + & 4.879300E-06,6.095700E-06,2.412657E-06,1.783732E-06,8.257603E-02,& + & 6.390986E-01,1.654800E+00,3.084100E+00,5.710800E+00,1.070500E+01,& + & 2.066800E+01,3.080500E+01,3.413900E+01,3.827800E+01,4.583564E+01,& + & 6.454914E+01,7.225684E-02,5.591990E-01,1.448000E+00,2.698600E+00,& + & 4.996900E+00,9.366600E+00,1.808500E+01,2.695500E+01,2.987200E+01,& + & 3.349300E+01,4.010471E+01,5.647920E+01,6.193716E-02,4.793242E-01,& + & 1.241100E+00,2.313100E+00,4.283000E+00,8.028400E+00,1.550100E+01,& + & 2.310300E+01,2.560500E+01,2.870800E+01,3.437577E+01,4.841314E+01,& + & 5.161847E-02,3.994342E-01,1.034300E+00,1.927600E+00,3.569200E+00,& + & 6.690400E+00,1.291800E+01,1.925300E+01,2.133700E+01,2.392300E+01,& + & 2.864706E+01,4.034308E+01,4.129780E-02,3.195547E-01,8.274200E-01,& + & 1.542100E+00,2.855400E+00,5.352300E+00,1.033400E+01,1.540200E+01,& + & 1.707000E+01,1.913900E+01,2.291713E+01,3.227338E+01,3.097910E-02,& + & 2.396695E-01,6.205900E-01,1.156600E+00,2.141500E+00,4.014200E+00,& + & 7.750600E+00,1.155200E+01,1.280200E+01,1.435400E+01,1.718758E+01,& + & 2.420457E+01,2.065931E-02,1.597895E-01,4.137400E-01,7.710700E-01,& + & 1.427700E+00,2.676100E+00,5.167000E+00,7.701400E+00,8.534800E+00,& + & 9.569300E+00,1.145826E+01,1.613688E+01,1.034031E-02,7.990789E-02,& + & 2.068900E-01,3.855700E-01,7.138600E-01,1.338100E+00,2.583500E+00,& + & 3.850600E+00,4.267500E+00,4.784700E+00,5.729251E+00,8.068527E+00/ + data absa( : ,576:585) / & + & 2.354793E-06,8.799465E-06,2.142000E-05,2.549400E-05,6.476300E-05,& + & 1.652200E-04,2.022800E-04,8.590100E-06,8.860700E-06,9.585300E-06,& + & 3.852853E-06,2.910344E-06,1.027512E-01,6.916618E-01,1.712900E+00,& + & 3.096800E+00,5.663500E+00,1.056800E+01,2.033300E+01,3.034700E+01,& + & 3.356300E+01,3.750200E+01,4.489980E+01,6.326810E+01,8.991168E-02,& + & 6.052102E-01,1.498800E+00,2.709700E+00,4.955600E+00,9.247500E+00,& + & 1.779100E+01,2.655400E+01,2.936800E+01,3.281500E+01,3.928688E+01,& + & 5.536028E+01,7.707267E-02,5.187637E-01,1.284600E+00,2.322600E+00,& + & 4.247600E+00,7.926300E+00,1.524900E+01,2.276000E+01,2.517100E+01,& + & 2.812700E+01,3.367457E+01,4.745059E+01,6.423315E-02,4.323073E-01,& + & 1.070600E+00,1.935500E+00,3.539700E+00,6.605300E+00,1.270800E+01,& + & 1.896700E+01,2.097600E+01,2.343800E+01,2.806210E+01,3.954125E+01,& + & 5.139215E-02,3.458461E-01,8.564500E-01,1.548400E+00,2.831700E+00,& + & 5.284200E+00,1.016600E+01,1.517400E+01,1.678100E+01,1.875100E+01,& + & 2.244879E+01,3.163393E+01,3.855209E-02,2.593997E-01,6.423500E-01,& + & 1.161300E+00,2.123800E+00,3.963200E+00,7.624700E+00,1.138000E+01,& + & 1.258600E+01,1.406300E+01,1.683709E+01,2.372510E+01,2.571299E-02,& + & 1.729432E-01,4.282700E-01,7.742800E-01,1.415900E+00,2.642100E+00,& + & 5.083100E+00,7.586700E+00,8.390600E+00,9.375100E+00,1.122439E+01,& + & 1.581603E+01,1.287278E-02,8.649265E-02,2.141500E-01,3.872300E-01,& + & 7.079600E-01,1.321100E+00,2.541600E+00,3.793300E+00,4.195300E+00,& + & 4.687700E+00,5.612203E+00,7.908088E+00,4.146353E-06,1.431445E-05,& + & 3.148200E-05,4.204300E-05,1.015300E-04,2.826900E-04,2.984000E-04,& + & 1.236700E-05,1.442000E-05,1.412400E-05,5.905551E-06,4.372274E-06/ + + + data absb( : , 1: 25) / & + & 1.747345E-01,2.201218E+00,6.955900E+00,1.387400E+01,2.638300E+01,& + & 5.103600E+01,9.940600E+01,1.485400E+02,1.657200E+02,1.843700E+02,& + & 2.247575E+02,3.125321E+02,2.309526E-01,2.439793E+00,7.194400E+00,& + & 1.405400E+01,2.639900E+01,5.046000E+01,9.801700E+01,1.462900E+02,& + & 1.628900E+02,1.820100E+02,2.199505E+02,3.074175E+02,2.992766E-01,& + & 2.693281E+00,7.377800E+00,1.417500E+01,2.636400E+01,4.987600E+01,& + & 9.661000E+01,1.439200E+02,1.600800E+02,1.792000E+02,2.153841E+02,& + & 3.024577E+02,3.800837E-01,2.941663E+00,7.616800E+00,1.419600E+01,& + & 2.628600E+01,4.927200E+01,9.513300E+01,1.417900E+02,1.571400E+02,& + & 1.761900E+02,2.109712E+02,2.971091E+02,4.729436E-01,3.183658E+00,& + & 7.884000E+00,1.425400E+01,2.606800E+01,4.864500E+01,9.358900E+01,& + & 1.396800E+02,1.544800E+02,1.726200E+02,2.066695E+02,2.912174E+02,& + & 1.650541E-01,1.970934E+00,6.119700E+00,1.238700E+01,2.439100E+01,& + & 4.965900E+01,1.042600E+02,1.644900E+02,1.854000E+02,2.092000E+02,& + & 2.557722E+02,3.555540E+02,2.174508E-01,2.184987E+00,6.341900E+00,& + & 1.256400E+01,2.443500E+01,4.924000E+01,1.028900E+02,1.620100E+02,& + & 1.826600E+02,2.065500E+02,2.501365E+02,3.507568E+02,2.804902E-01,& + & 2.407823E+00,6.535700E+00,1.269800E+01,2.444500E+01,4.878900E+01,& + & 1.014500E+02,1.596600E+02,1.796700E+02,2.036800E+02,2.447367E+02,& + & 3.453371E+02,3.538649E-01,2.633114E+00,6.753500E+00,1.276200E+01,& + & 2.441100E+01,4.831700E+01,9.995500E+01,1.574000E+02,1.766500E+02,& + & 2.003900E+02,2.393805E+02,3.396033E+02,4.374772E-01,2.855067E+00,& + & 7.005300E+00,1.278100E+01,2.434400E+01,4.781300E+01,9.841800E+01,& + & 1.547500E+02,1.738700E+02,1.966000E+02,2.342184E+02,3.331844E+02,& + & 1.553785E-01,1.762948E+00,5.357900E+00,1.097300E+01,2.226700E+01,& + & 4.783600E+01,1.083100E+02,1.811300E+02,2.081400E+02,2.380700E+02,& + & 2.919318E+02,4.048350E+02,2.038840E-01,1.954335E+00,5.574400E+00,& + & 1.114500E+01,2.234300E+01,4.753300E+01,1.070000E+02,1.788300E+02,& + & 2.051800E+02,2.348300E+02,2.854343E+02,4.003300E+02,2.616618E-01,& + & 2.153812E+00,5.776600E+00,1.127400E+01,2.239100E+01,4.717900E+01,& + & 1.056500E+02,1.763300E+02,2.021000E+02,2.312600E+02,2.790780E+02,& + & 3.947488E+02,3.283353E-01,2.358667E+00,5.976700E+00,1.136500E+01,& + & 2.242000E+01,4.680700E+01,1.042200E+02,1.735600E+02,1.989800E+02,& + & 2.272300E+02,2.730692E+02,3.880779E+02,4.034584E-01,2.560606E+00,& + & 6.216700E+00,1.142400E+01,2.240600E+01,4.640800E+01,1.027100E+02,& + & 1.708200E+02,1.956900E+02,2.226100E+02,2.673110E+02,3.805201E+02,& + & 1.454100E-01,1.574735E+00,4.681600E+00,9.652100E+00,2.010100E+01,& + & 4.552300E+01,1.114400E+02,1.986900E+02,2.328200E+02,2.705000E+02,& + & 3.337291E+02,4.635016E+02,1.902776E-01,1.746813E+00,4.893600E+00,& + & 9.805300E+00,2.022200E+01,4.530700E+01,1.102700E+02,1.961700E+02,& + & 2.297800E+02,2.662200E+02,3.265316E+02,4.578734E+02,2.428883E-01,& + & 1.929108E+00,5.086200E+00,9.937000E+00,2.031100E+01,4.507400E+01,& + & 1.089900E+02,1.933700E+02,2.264300E+02,2.614800E+02,3.197520E+02,& + & 4.511871E+02,3.032232E-01,2.112553E+00,5.296700E+00,1.004700E+01,& + & 2.037000E+01,4.479800E+01,1.076600E+02,1.905700E+02,2.224300E+02,& + & 2.566800E+02,3.130976E+02,4.433000E+02,3.704687E-01,2.296025E+00,& + & 5.532700E+00,1.015000E+01,2.037300E+01,4.449700E+01,1.062600E+02,& + & 1.876700E+02,2.180000E+02,2.520300E+02,3.062821E+02,4.348693E+02,& + & 1.348892E-01,1.405001E+00,4.089900E+00,8.422200E+00,1.798700E+01,& + & 4.275100E+01,1.135700E+02,2.157900E+02,2.585600E+02,3.055000E+02,& + & 3.826386E+02,5.330801E+02,1.758537E-01,1.559993E+00,4.291700E+00,& + & 8.571900E+00,1.813000E+01,4.265900E+01,1.125200E+02,2.131000E+02,& + & 2.550100E+02,3.004700E+02,3.746817E+02,5.257778E+02,2.235409E-01,& + & 1.723511E+00,4.481200E+00,8.719500E+00,1.824200E+01,4.252300E+01,& + & 1.114000E+02,2.100900E+02,2.508500E+02,2.952800E+02,3.669605E+02,& + & 5.169893E+02,2.776412E-01,1.887344E+00,4.702500E+00,8.848800E+00,& + & 1.831600E+01,4.235100E+01,1.102200E+02,2.067800E+02,2.463200E+02,& + & 2.898400E+02,3.593594E+02,5.069804E+02,3.375196E-01,2.053653E+00,& + & 4.920100E+00,9.015900E+00,1.833800E+01,4.212800E+01,1.089700E+02,& + & 2.034400E+02,2.416600E+02,2.841400E+02,3.515918E+02,4.965100E+02/ + data absb( : , 26: 50) / & + & 1.240277E-01,1.251058E+00,3.577100E+00,7.309000E+00,1.595600E+01,& + & 3.967500E+01,1.145100E+02,2.317500E+02,2.842200E+02,3.430800E+02,& + & 4.388645E+02,6.158166E+02,1.609958E-01,1.390297E+00,3.767800E+00,& + & 7.466800E+00,1.611400E+01,3.967800E+01,1.136600E+02,2.286200E+02,& + & 2.803100E+02,3.371800E+02,4.301314E+02,6.056469E+02,2.038186E-01,& + & 1.534744E+00,3.959300E+00,7.632200E+00,1.623800E+01,3.961300E+01,& + & 1.127500E+02,2.254300E+02,2.757700E+02,3.310400E+02,4.214544E+02,& + & 5.939189E+02,2.521104E-01,1.681489E+00,4.171500E+00,7.793200E+00,& + & 1.633700E+01,3.951200E+01,1.117200E+02,2.223200E+02,2.708600E+02,& + & 3.245800E+02,4.126244E+02,5.808849E+02,3.047059E-01,1.831661E+00,& + & 4.372200E+00,8.008600E+00,1.640000E+01,3.937700E+01,1.105900E+02,& + & 2.191600E+02,2.656400E+02,3.178700E+02,4.035749E+02,5.672517E+02,& + & 1.128789E-01,1.110387E+00,3.136400E+00,6.327900E+00,1.405000E+01,& + & 3.638500E+01,1.141900E+02,2.459500E+02,3.091900E+02,3.817700E+02,& + & 5.033144E+02,7.123260E+02,1.459522E-01,1.234078E+00,3.317600E+00,& + & 6.498500E+00,1.421000E+01,3.644200E+01,1.135800E+02,2.432500E+02,& + & 3.046700E+02,3.753200E+02,4.931733E+02,6.981522E+02,1.840538E-01,& + & 1.362326E+00,3.501300E+00,6.681300E+00,1.435400E+01,3.646700E+01,& + & 1.128300E+02,2.404000E+02,2.996000E+02,3.685700E+02,4.828863E+02,& + & 6.824623E+02,2.265762E-01,1.493568E+00,3.693500E+00,6.875600E+00,& + & 1.449500E+01,3.645300E+01,1.119900E+02,2.373000E+02,2.943200E+02,& + & 3.612700E+02,4.723917E+02,6.652490E+02,2.721757E-01,1.627359E+00,& + & 3.883000E+00,7.117600E+00,1.462300E+01,3.638500E+01,1.110800E+02,& + & 2.338400E+02,2.889700E+02,3.536300E+02,4.614876E+02,6.474815E+02,& + & 1.023773E-01,9.835427E-01,2.759300E+00,5.486200E+00,1.228700E+01,& + & 3.298800E+01,1.125300E+02,2.591700E+02,3.320700E+02,4.218600E+02,& + & 5.747195E+02,8.228962E+02,1.317702E-01,1.094245E+00,2.923000E+00,& + & 5.671900E+00,1.246200E+01,3.311900E+01,1.121700E+02,2.564600E+02,& + & 3.274100E+02,4.150600E+02,5.624249E+02,8.035610E+02,1.653394E-01,& + & 1.208269E+00,3.093300E+00,5.868200E+00,1.264400E+01,3.320700E+01,& + & 1.117000E+02,2.534700E+02,3.224500E+02,4.072800E+02,5.500094E+02,& + & 7.822822E+02,2.022740E-01,1.325134E+00,3.268700E+00,6.085000E+00,& + & 1.283700E+01,3.325300E+01,1.111300E+02,2.502600E+02,3.172800E+02,& + & 3.990500E+02,5.371051E+02,7.597366E+02,2.417234E-01,1.442696E+00,& + & 3.449900E+00,6.333700E+00,1.303600E+01,3.326600E+01,1.104300E+02,& + & 2.469700E+02,3.118100E+02,3.905200E+02,5.236993E+02,7.371645E+02,& + & 9.207215E-02,8.688723E-01,2.425600E+00,4.775300E+00,1.069700E+01,& + & 2.962900E+01,1.096400E+02,2.700200E+02,3.536000E+02,4.624600E+02,& + & 6.514880E+02,9.472011E+02,1.180028E-01,9.671234E-01,2.572400E+00,& + & 4.968200E+00,1.090400E+01,2.980700E+01,1.095900E+02,2.675100E+02,& + & 3.492900E+02,4.545400E+02,6.367918E+02,9.207983E+02,1.472370E-01,& + & 1.068218E+00,2.729800E+00,5.166500E+00,1.113600E+01,2.995000E+01,& + & 1.094100E+02,2.647200E+02,3.445700E+02,4.460600E+02,6.214837E+02,& + & 8.928127E+02,1.791720E-01,1.171266E+00,2.892800E+00,5.394300E+00,& + & 1.137600E+01,3.007400E+01,1.091100E+02,2.618400E+02,3.393600E+02,& + & 4.370400E+02,6.056269E+02,8.639680E+02,2.130208E-01,1.273760E+00,& + & 3.063800E+00,5.640600E+00,1.164700E+01,3.019500E+01,1.086800E+02,& + & 2.588100E+02,3.336800E+02,4.274700E+02,5.891763E+02,8.352935E+02,& + & 8.355391E-02,7.709068E-01,2.136800E+00,4.185400E+00,9.321600E+00,& + & 2.638900E+01,1.057600E+02,2.778800E+02,3.736600E+02,5.013500E+02,& + & 7.313839E+02,1.081344E+03,1.063699E-01,8.578981E-01,2.272900E+00,& + & 4.370300E+00,9.570400E+00,2.661500E+01,1.060100E+02,2.761700E+02,& + & 3.693800E+02,4.929200E+02,7.132296E+02,1.046431E+03,1.318632E-01,& + & 9.469974E-01,2.418300E+00,4.571300E+00,9.841800E+00,2.683300E+01,& + & 1.061400E+02,2.741100E+02,3.645700E+02,4.836300E+02,6.944811E+02,& + & 1.010147E+03,1.594386E-01,1.036938E+00,2.568900E+00,4.799000E+00,& + & 1.013400E+01,2.705400E+01,1.061600E+02,2.716600E+02,3.592400E+02,& + & 4.736900E+02,6.750966E+02,9.736618E+02,1.884673E-01,1.126374E+00,& + & 2.725200E+00,5.043900E+00,1.046400E+01,2.728100E+01,1.060600E+02,& + & 2.686900E+02,3.534700E+02,4.633800E+02,6.550489E+02,9.374895E+02/ + data absb( : , 51: 75) / & + & 7.529317E-02,6.819373E-01,1.881700E+00,3.676700E+00,8.155200E+00,& + & 2.335500E+01,1.011300E+02,2.831000E+02,3.915100E+02,5.386100E+02,& + & 8.130187E+02,1.223979E+03,9.526332E-02,7.583913E-01,2.009200E+00,& + & 3.850800E+00,8.438100E+00,2.364400E+01,1.017200E+02,2.823400E+02,& + & 3.874500E+02,5.296100E+02,7.909738E+02,1.178164E+03,1.173610E-01,& + & 8.367900E-01,2.141000E+00,4.054200E+00,8.735800E+00,2.394800E+01,& + & 1.022000E+02,2.811400E+02,3.828200E+02,5.196200E+02,7.680885E+02,& + & 1.132059E+03,1.410661E-01,9.151506E-01,2.278600E+00,4.277600E+00,& + & 9.054600E+00,2.429600E+01,1.025700E+02,2.792900E+02,3.776000E+02,& + & 5.089400E+02,7.444280E+02,1.086442E+03,1.659431E-01,9.924473E-01,& + & 2.421700E+00,4.519100E+00,9.427400E+00,2.466000E+01,1.028000E+02,& + & 2.768700E+02,3.718800E+02,4.976700E+02,7.202503E+02,1.041645E+03,& + & 6.752188E-02,6.010785E-01,1.658800E+00,3.235500E+00,7.174200E+00,& + & 2.059500E+01,9.600500E+01,2.863500E+02,4.069900E+02,5.733800E+02,& + & 8.941676E+02,1.370003E+03,8.493969E-02,6.684490E-01,1.774900E+00,& + & 3.407700E+00,7.471400E+00,2.096300E+01,9.697600E+01,2.865200E+02,& + & 4.035500E+02,5.638900E+02,8.674946E+02,1.311677E+03,1.040018E-01,& + & 7.368167E-01,1.894700E+00,3.607200E+00,7.780000E+00,2.139100E+01,& + & 9.782600E+01,2.861500E+02,3.993000E+02,5.533800E+02,8.398454E+02,& + & 1.254359E+03,1.242844E-01,8.048382E-01,2.020800E+00,3.824500E+00,& + & 8.129300E+00,2.186100E+01,9.856100E+01,2.851100E+02,3.942800E+02,& + & 5.418900E+02,8.114992E+02,1.198460E+03,1.455561E-01,8.712821E-01,& + & 2.152700E+00,4.053400E+00,8.522700E+00,2.238000E+01,9.918200E+01,& + & 2.834500E+02,3.885900E+02,5.293200E+02,7.829208E+02,1.143883E+03,& + & 6.036227E-02,5.287082E-01,1.461600E+00,2.858000E+00,6.345300E+00,& + & 1.815900E+01,9.065800E+01,2.881900E+02,4.201000E+02,6.053900E+02,& + & 9.723107E+02,1.513994E+03,7.545002E-02,5.876668E-01,1.566800E+00,& + & 3.030300E+00,6.637100E+00,1.863700E+01,9.202600E+01,2.893500E+02,& + & 4.176200E+02,5.952800E+02,9.404196E+02,1.442135E+03,9.184023E-02,& + & 6.469002E-01,1.677700E+00,3.222000E+00,6.957200E+00,1.918300E+01,& + & 9.330200E+01,2.897600E+02,4.138200E+02,5.840400E+02,9.077218E+02,& + & 1.372381E+03,1.092102E-01,7.053768E-01,1.794400E+00,3.425700E+00,& + & 7.330000E+00,1.977800E+01,9.446200E+01,2.895400E+02,4.090000E+02,& + & 5.715800E+02,8.745025E+02,1.305055E+03,1.272283E-01,7.633909E-01,& + & 1.912800E+00,3.644400E+00,7.737100E+00,2.043900E+01,9.550400E+01,& + & 2.885700E+02,4.033300E+02,5.579800E+02,8.412067E+02,1.240581E+03,& + & 5.393047E-02,4.646356E-01,1.287500E+00,2.540500E+00,5.632500E+00,& + & 1.608900E+01,8.539800E+01,2.889400E+02,4.309700E+02,6.340300E+02,& + & 1.044776E+03,1.651385E+03,6.697254E-02,5.156995E-01,1.385000E+00,& + & 2.707800E+00,5.921300E+00,1.667700E+01,8.718800E+01,2.910900E+02,& + & 4.294900E+02,6.233400E+02,1.007404E+03,1.564587E+03,8.101477E-02,& + & 5.667831E-01,1.488100E+00,2.887200E+00,6.261900E+00,1.731900E+01,& + & 8.889500E+01,2.925000E+02,4.263400E+02,6.111200E+02,9.695404E+02,& + & 1.481676E+03,9.587032E-02,6.174649E-01,1.594300E+00,3.081600E+00,& + & 6.643600E+00,1.803200E+01,9.050600E+01,2.930700E+02,4.217700E+02,& + & 5.977000E+02,9.313608E+02,1.402765E+03,1.110709E-01,6.688378E-01,& + & 1.700500E+00,3.288000E+00,7.062200E+00,1.881400E+01,9.199400E+01,& + & 2.927200E+02,4.161000E+02,5.831000E+02,8.934275E+02,1.327982E+03,& + & 4.801144E-02,4.072752E-01,1.134200E+00,2.267700E+00,5.017700E+00,& + & 1.436300E+01,8.042500E+01,2.889500E+02,4.402000E+02,6.593600E+02,& + & 1.110337E+03,1.777952E+03,5.924408E-02,4.513775E-01,1.225000E+00,& + & 2.425800E+00,5.318000E+00,1.502800E+01,8.264800E+01,2.923900E+02,& + & 4.395800E+02,6.479500E+02,1.067423E+03,1.676471E+03,7.129486E-02,& + & 4.954989E-01,1.319500E+00,2.597300E+00,5.668500E+00,1.575700E+01,& + & 8.481700E+01,2.947300E+02,4.370400E+02,6.348300E+02,1.024233E+03,& + & 1.580891E+03,8.387136E-02,5.402460E-01,1.415500E+00,2.781800E+00,& + & 6.055600E+00,1.656400E+01,8.690000E+01,2.959500E+02,4.327700E+02,& + & 6.203600E+02,9.812604E+02,1.491025E+03,9.653999E-02,5.859158E-01,& + & 1.512100E+00,2.976600E+00,6.479100E+00,1.744300E+01,8.886100E+01,& + & 2.961600E+02,4.271800E+02,6.045500E+02,9.388614E+02,1.406537E+03/ + data absb( : , 76:100) / & + & 4.261792E-02,3.562116E-01,1.000000E+00,2.027300E+00,4.500600E+00,& + & 1.292600E+01,7.590200E+01,2.889300E+02,4.481800E+02,6.812500E+02,& + & 1.167690E+03,1.890732E+03,5.227631E-02,3.942997E-01,1.083400E+00,& + & 2.180300E+00,4.811400E+00,1.364800E+01,7.859700E+01,2.934700E+02,& + & 4.482100E+02,6.691900E+02,1.119311E+03,1.775357E+03,6.255774E-02,& + & 4.328990E-01,1.169400E+00,2.346200E+00,5.163000E+00,1.444600E+01,& + & 8.125000E+01,2.966000E+02,4.461100E+02,6.551300E+02,1.071113E+03,& + & 1.667910E+03,7.308031E-02,4.727169E-01,1.256900E+00,2.521100E+00,& + & 5.551200E+00,1.532300E+01,8.381700E+01,2.984500E+02,4.421200E+02,& + & 6.395100E+02,1.023675E+03,1.567513E+03,8.351882E-02,5.134990E-01,& + & 1.346700E+00,2.704000E+00,5.972500E+00,1.632600E+01,8.618900E+01,& + & 2.990800E+02,4.365200E+02,6.226000E+02,9.771045E+02,1.473781E+03,& + & 3.780694E-02,3.112706E-01,8.827200E-01,1.819000E+00,4.076300E+00,& + & 1.172300E+01,7.202100E+01,2.889600E+02,4.550400E+02,6.999800E+02,& + & 1.215763E+03,1.986278E+03,4.607880E-02,3.444208E-01,9.587800E-01,& + & 1.968900E+00,4.386900E+00,1.249300E+01,7.519300E+01,2.944900E+02,& + & 4.554800E+02,6.871200E+02,1.162426E+03,1.858325E+03,5.473642E-02,& + & 3.787365E-01,1.037500E+00,2.127900E+00,4.735700E+00,1.334900E+01,& + & 7.832300E+01,2.983000E+02,4.537600E+02,6.720700E+02,1.109675E+03,& + & 1.739873E+03,6.348727E-02,4.142639E-01,1.118900E+00,2.294100E+00,& + & 5.121500E+00,1.433600E+01,8.128400E+01,3.006700E+02,4.498400E+02,& + & 6.553000E+02,1.058181E+03,1.629794E+03,7.197236E-02,4.509136E-01,& + & 1.203900E+00,2.466200E+00,5.541500E+00,1.541900E+01,8.407900E+01,& + & 3.016700E+02,4.441500E+02,6.373400E+02,1.007896E+03,1.528278E+03,& + & 3.345525E-02,2.718138E-01,7.802800E-01,1.639700E+00,3.719700E+00,& + & 1.072000E+01,6.884600E+01,2.892800E+02,4.609100E+02,7.158300E+02,& + & 1.254973E+03,2.063833E+03,4.048203E-02,3.011439E-01,8.498600E-01,& + & 1.784400E+00,4.027900E+00,1.153500E+01,7.247600E+01,2.956200E+02,& + & 4.616200E+02,7.020900E+02,1.197019E+03,1.924813E+03,4.770162E-02,& + & 3.318446E-01,9.225300E-01,1.937100E+00,4.373400E+00,1.248500E+01,& + & 7.598600E+01,2.999500E+02,4.601000E+02,6.859000E+02,1.140370E+03,& + & 1.796777E+03,5.488102E-02,3.637133E-01,9.992700E-01,2.095800E+00,& + & 4.756000E+00,1.354300E+01,7.935200E+01,3.026800E+02,4.561600E+02,& + & 6.680500E+02,1.085234E+03,1.678653E+03,6.171257E-02,3.965764E-01,& + & 1.080900E+00,2.259000E+00,5.175800E+00,1.469600E+01,8.251700E+01,& + & 3.039500E+02,4.502500E+02,6.490400E+02,1.031758E+03,1.570403E+03,& + & 2.954815E-02,2.376866E-01,6.911500E-01,1.485200E+00,3.421700E+00,& + & 9.895300E+00,6.639100E+01,2.900900E+02,4.659800E+02,7.287600E+02,& + & 1.285226E+03,2.122670E+03,3.545417E-02,2.639153E-01,7.553600E-01,& + & 1.624900E+00,3.727600E+00,1.079400E+01,7.038900E+01,2.969100E+02,& + & 4.668000E+02,7.140400E+02,1.223361E+03,1.974456E+03,4.143289E-02,& + & 2.914356E-01,8.238800E-01,1.771400E+00,4.070000E+00,1.180700E+01,& + & 7.428000E+01,3.016300E+02,4.652800E+02,6.967700E+02,1.163324E+03,& + & 1.838537E+03,4.724289E-02,3.201570E-01,8.978700E-01,1.922600E+00,& + & 4.451300E+00,1.292800E+01,7.799400E+01,3.045600E+02,4.611800E+02,& + & 6.779000E+02,1.105206E+03,1.714167E+03,5.277640E-02,3.496043E-01,& + & 9.759000E-01,2.081300E+00,4.870900E+00,1.415100E+01,8.146200E+01,& + & 3.060200E+02,4.549800E+02,6.579300E+02,1.049093E+03,1.600455E+03,& + & 2.601727E-02,2.082921E-01,6.141200E-01,1.351700E+00,3.172500E+00,& + & 9.263000E+00,6.457700E+01,2.913100E+02,4.704000E+02,7.390000E+02,& + & 1.307351E+03,2.164239E+03,3.093545E-02,2.318571E-01,6.744600E-01,& + & 1.486200E+00,3.476000E+00,1.021300E+01,6.894200E+01,2.984200E+02,& + & 4.712000E+02,7.232400E+02,1.242251E+03,2.008717E+03,3.583369E-02,& + & 2.566613E-01,7.404800E-01,1.626400E+00,3.817900E+00,1.128100E+01,& + & 7.316600E+01,3.033100E+02,4.694400E+02,7.049300E+02,1.179414E+03,& + & 1.866802E+03,4.054791E-02,2.825372E-01,8.109500E-01,1.774500E+00,& + & 4.199900E+00,1.246800E+01,7.715700E+01,3.063900E+02,4.650900E+02,& + & 6.851300E+02,1.118840E+03,1.737610E+03,4.504005E-02,3.085874E-01,& + & 8.867000E-01,1.933500E+00,4.616900E+00,1.378300E+01,8.082900E+01,& + & 3.078500E+02,4.586200E+02,6.642700E+02,1.060566E+03,1.619836E+03/ + data absb( : ,101:125) / & + & 2.283197E-02,1.830627E-01,5.481000E-01,1.236400E+00,2.964000E+00,& + & 8.769300E+00,6.339200E+01,2.928500E+02,4.743000E+02,7.468100E+02,& + & 1.322224E+03,2.190240E+03,2.689958E-02,2.042302E-01,6.063600E-01,& + & 1.365100E+00,3.268200E+00,9.768200E+00,6.807100E+01,3.000600E+02,& + & 4.749300E+02,7.299100E+02,1.254541E+03,2.029308E+03,3.090637E-02,& + & 2.266607E-01,6.691100E-01,1.502700E+00,3.611800E+00,1.090000E+01,& + & 7.254800E+01,3.050000E+02,4.728300E+02,7.107200E+02,1.189476E+03,& + & 1.883071E+03,3.472924E-02,2.497449E-01,7.373400E-01,1.651300E+00,& + & 3.991200E+00,1.217100E+01,7.673000E+01,3.080800E+02,4.681000E+02,& + & 6.900100E+02,1.126937E+03,1.750580E+03,3.840769E-02,2.728769E-01,& + & 8.109100E-01,1.809800E+00,4.411000E+00,1.356400E+01,8.056900E+01,& + & 3.094200E+02,4.612200E+02,6.684700E+02,1.067078E+03,1.630020E+03,& + & 1.983551E-02,1.605862E-01,4.907100E-01,1.131700E+00,2.781500E+00,& + & 8.355000E+00,6.259100E+01,2.943000E+02,4.777000E+02,7.529100E+02,& + & 1.333397E+03,2.208930E+03,2.319807E-02,1.797595E-01,5.460100E-01,& + & 1.257100E+00,3.088100E+00,9.405700E+00,6.751700E+01,3.015600E+02,& + & 4.780200E+02,7.352200E+02,1.263570E+03,2.043901E+03,2.644333E-02,& + & 1.998896E-01,6.064800E-01,1.394700E+00,3.428600E+00,1.061200E+01,& + & 7.218200E+01,3.065000E+02,4.755700E+02,7.151900E+02,1.196671E+03,& + & 1.894404E+03,2.958975E-02,2.203868E-01,6.727100E-01,1.542600E+00,& + & 3.809000E+00,1.195400E+01,7.652300E+01,3.095400E+02,4.704400E+02,& + & 6.937400E+02,1.132639E+03,1.759339E+03,3.263843E-02,2.410112E-01,& + & 7.444100E-01,1.700100E+00,4.236600E+00,1.341600E+01,8.047900E+01,& + & 3.108100E+02,4.631900E+02,6.715800E+02,1.071531E+03,1.636654E+03,& + & 1.691732E-02,1.397025E-01,4.369300E-01,1.030500E+00,2.602700E+00,& + & 7.950300E+00,6.172700E+01,2.950600E+02,4.804100E+02,7.588800E+02,& + & 1.346465E+03,2.233883E+03,1.968105E-02,1.569299E-01,4.894300E-01,& + & 1.154000E+00,2.907300E+00,9.050600E+00,6.685400E+01,3.025100E+02,& + & 4.806400E+02,7.406000E+02,1.274732E+03,2.064456E+03,2.235601E-02,& + & 1.748268E-01,5.476900E-01,1.290200E+00,3.244500E+00,1.031100E+01,& + & 7.169200E+01,3.075600E+02,4.780400E+02,7.199500E+02,1.206166E+03,& + & 1.911486E+03,2.496597E-02,1.931090E-01,6.114900E-01,1.436800E+00,& + & 3.626900E+00,1.171100E+01,7.617500E+01,3.106400E+02,4.727500E+02,& + & 6.980400E+02,1.140759E+03,1.773572E+03,2.747154E-02,2.115253E-01,& + & 6.819800E-01,1.593700E+00,4.062700E+00,1.323000E+01,8.023200E+01,& + & 3.118900E+02,4.653100E+02,6.753400E+02,1.078361E+03,1.648438E+03,& + & 1.416360E-02,1.201938E-01,3.855100E-01,9.313700E-01,2.419500E+00,& + & 7.526000E+00,6.059400E+01,2.949500E+02,4.825300E+02,7.653000E+02,& + & 1.363595E+03,2.270045E+03,1.643772E-02,1.355144E-01,4.354700E-01,& + & 1.052600E+00,2.719500E+00,8.651300E+00,6.591400E+01,3.027800E+02,& + & 4.829600E+02,7.467400E+02,1.290039E+03,2.095684E+03,1.865329E-02,& + & 1.514022E-01,4.912100E-01,1.185600E+00,3.053500E+00,9.950000E+00,& + & 7.091900E+01,3.081100E+02,4.804700E+02,7.257800E+02,1.219868E+03,& + & 1.938203E+03,2.081732E-02,1.677340E-01,5.530100E-01,1.329900E+00,& + & 3.436200E+00,1.139300E+01,7.553600E+01,3.113600E+02,4.752100E+02,& + & 7.034800E+02,1.152937E+03,1.796678E+03,2.290289E-02,1.842244E-01,& + & 6.210900E-01,1.486000E+00,3.876600E+00,1.295400E+01,7.971400E+01,& + & 3.127300E+02,4.677800E+02,6.804700E+02,1.089315E+03,1.668545E+03,& + & 1.155724E-02,1.015606E-01,3.348000E-01,8.293100E-01,2.215500E+00,& + & 7.016600E+00,5.884600E+01,2.934000E+02,4.839300E+02,7.732400E+02,& + & 1.389366E+03,2.328801E+03,1.343915E-02,1.150354E-01,3.815000E-01,& + & 9.456400E-01,2.509900E+00,8.140800E+00,6.436400E+01,3.019400E+02,& + & 4.850200E+02,7.547700E+02,1.313737E+03,2.146944E+03,1.528381E-02,& + & 1.291234E-01,4.340800E-01,1.073900E+00,2.837300E+00,9.447600E+00,& + & 6.955800E+01,3.078700E+02,4.830100E+02,7.338500E+02,1.241671E+03,& + & 1.983390E+03,1.708116E-02,1.436771E-01,4.927800E-01,1.215200E+00,& + & 3.215000E+00,1.090700E+01,7.434900E+01,3.115900E+02,4.782100E+02,& + & 7.114200E+02,1.172978E+03,1.836417E+03,1.882835E-02,1.585254E-01,& + & 5.580800E-01,1.368200E+00,3.650400E+00,1.248900E+01,7.871300E+01,& + & 3.131400E+02,4.710200E+02,6.882100E+02,1.107760E+03,1.703799E+03/ + data absb( : ,126:150) / & + & 9.417892E-03,8.571948E-02,2.908100E-01,7.390600E-01,2.031700E+00,& + & 6.563100E+00,5.719400E+01,2.916700E+02,4.848600E+02,7.803100E+02,& + & 1.413664E+03,2.385232E+03,1.098291E-02,9.755706E-02,3.345000E-01,& + & 8.503400E-01,2.321400E+00,7.681500E+00,6.288700E+01,3.009000E+02,& + & 4.866300E+02,7.620900E+02,1.336079E+03,2.196315E+03,1.251484E-02,& + & 1.100803E-01,3.839800E-01,9.747800E-01,2.645700E+00,8.989500E+00,& + & 6.824700E+01,3.074300E+02,4.851400E+02,7.412600E+02,1.262257E+03,& + & 2.026864E+03,1.401306E-02,1.230885E-01,4.398700E-01,1.112500E+00,& + & 3.018700E+00,1.046100E+01,7.319500E+01,3.115700E+02,4.808200E+02,& + & 7.187400E+02,1.192042E+03,1.874882E+03,1.548817E-02,1.363800E-01,& + & 5.024800E-01,1.262700E+00,3.449700E+00,1.206400E+01,7.804900E+01,& + & 3.103500E+02,4.739400E+02,6.954000E+02,1.125303E+03,1.737840E+03,& + & 7.680426E-03,7.236305E-02,2.530500E-01,6.600600E-01,1.867500E+00,& + & 6.167800E+00,5.566500E+01,2.898400E+02,4.854100E+02,7.864800E+02,& + & 1.436028E+03,2.438401E+03,8.977599E-03,8.278838E-02,2.938000E-01,& + & 7.666300E-01,2.153500E+00,7.280500E+00,6.150700E+01,2.997500E+02,& + & 4.878500E+02,7.685700E+02,1.356910E+03,2.242750E+03,1.025464E-02,& + & 9.389238E-02,3.405000E-01,8.873200E-01,2.477500E+00,8.586100E+00,& + & 6.700800E+01,3.068300E+02,4.869100E+02,7.479600E+02,1.281409E+03,& + & 2.067877E+03,1.150564E-02,1.055470E-01,3.939000E-01,1.021400E+00,& + & 2.846700E+00,1.006500E+01,7.214700E+01,3.109600E+02,4.830200E+02,& + & 7.254200E+02,1.209733E+03,1.910885E+03,1.274090E-02,1.175292E-01,& + & 4.536400E-01,1.170400E+00,3.273200E+00,1.167600E+01,7.754700E+01,& + & 3.063800E+02,4.764700E+02,7.019800E+02,1.141688E+03,1.769945E+03,& + & 6.144026E-03,6.016609E-02,2.167100E-01,5.807400E-01,1.693300E+00,& + & 5.715500E+00,5.362100E+01,2.866700E+02,4.851000E+02,7.935300E+02,& + & 1.465428E+03,2.510925E+03,7.221928E-03,6.925221E-02,2.541800E-01,& + & 6.815100E-01,1.972600E+00,6.798700E+00,5.961700E+01,2.975100E+02,& + & 4.886400E+02,7.763700E+02,1.384319E+03,2.306505E+03,8.284027E-03,& + & 7.902230E-02,2.976300E-01,7.969800E-01,2.291700E+00,8.077500E+00,& + & 6.528600E+01,3.054600E+02,4.885400E+02,7.561700E+02,1.307007E+03,& + & 2.124423E+03,9.325773E-03,8.941848E-02,3.477900E-01,9.267300E-01,& + & 2.652700E+00,9.539200E+00,7.069500E+01,3.093700E+02,4.854000E+02,& + & 7.339100E+02,1.233597E+03,1.960958E+03,1.035589E-02,1.001434E-01,& + & 4.045800E-01,1.071900E+00,3.069000E+00,1.114200E+01,7.634000E+01,& + & 3.047300E+02,4.794500E+02,7.104500E+02,1.163938E+03,1.814571E+03,& + & 4.897958E-03,4.985731E-02,1.849300E-01,5.097000E-01,1.532100E+00,& + & 5.294900E+00,5.155400E+01,2.830800E+02,4.841800E+02,7.998900E+02,& + & 1.494894E+03,2.585911E+03,5.789777E-03,5.776246E-02,2.192600E-01,& + & 6.046700E-01,1.804500E+00,6.347000E+00,5.768500E+01,2.948900E+02,& + & 4.889100E+02,7.837700E+02,1.411963E+03,2.372308E+03,6.670615E-03,& + & 6.632532E-02,2.595400E-01,7.146900E-01,2.118400E+00,7.591400E+00,& + & 6.351000E+01,3.037300E+02,4.897500E+02,7.641000E+02,1.332878E+03,& + & 2.182643E+03,7.541615E-03,7.555682E-02,3.066200E-01,8.396200E-01,& + & 2.473100E+00,9.025800E+00,6.920100E+01,3.073600E+02,4.874000E+02,& + & 7.421400E+02,1.257794E+03,2.012630E+03,8.401075E-03,8.518382E-02,& + & 3.603700E-01,9.809700E-01,2.878800E+00,1.061400E+01,7.498200E+01,& + & 3.036300E+02,4.821900E+02,7.187900E+02,1.186596E+03,1.860672E+03,& + & 3.900211E-03,4.125158E-02,1.575200E-01,4.469100E-01,1.385800E+00,& + & 4.913900E+00,4.952800E+01,2.792100E+02,4.827900E+02,8.055800E+02,& + & 1.523638E+03,2.660985E+03,4.637034E-03,4.811296E-02,1.888800E-01,& + & 5.365300E-01,1.651200E+00,5.932200E+00,5.577600E+01,2.920000E+02,& + & 4.887300E+02,7.904800E+02,1.439023E+03,2.438161E+03,5.370734E-03,& + & 5.563279E-02,2.262500E-01,6.411200E-01,1.959800E+00,7.140300E+00,& + & 6.174300E+01,3.017400E+02,4.905700E+02,7.715200E+02,1.358248E+03,& + & 2.240712E+03,6.096840E-03,6.381778E-02,2.703100E-01,7.613600E-01,& + & 2.309600E+00,8.540700E+00,6.774000E+01,3.047900E+02,4.890400E+02,& + & 7.499400E+02,1.281609E+03,2.064365E+03,6.811579E-03,7.242691E-02,& + & 3.212400E-01,8.984600E-01,2.706100E+00,1.011000E+01,7.365900E+01,& + & 3.018700E+02,4.845800E+02,7.267700E+02,1.208893E+03,1.906572E+03/ + data absb( : ,151:175) / & + & 3.068613E-03,3.376916E-02,1.325500E-01,3.872000E-01,1.239500E+00,& + & 4.519400E+00,4.717800E+01,2.742000E+02,4.804100E+02,8.111600E+02,& + & 1.556744E+03,2.750577E+03,3.675541E-03,3.967658E-02,1.607800E-01,& + & 4.706700E-01,1.495300E+00,5.490200E+00,5.354000E+01,2.882000E+02,& + & 4.878200E+02,7.974700E+02,1.470439E+03,2.516809E+03,4.285800E-03,& + & 4.622283E-02,1.949100E-01,5.692100E-01,1.795900E+00,6.649800E+00,& + & 5.964700E+01,2.989900E+02,4.910000E+02,7.795500E+02,1.387797E+03,& + & 2.307054E+03,4.889908E-03,5.343806E-02,2.357600E-01,6.834600E-01,& + & 2.138900E+00,8.003300E+00,6.588600E+01,3.023000E+02,4.904900E+02,& + & 7.586200E+02,1.309330E+03,2.126209E+03,5.486817E-03,6.110362E-02,& + & 2.835000E-01,8.154100E-01,2.525000E+00,9.535100E+00,7.201500E+01,& + & 2.999900E+02,4.868200E+02,7.357400E+02,1.235002E+03,1.961507E+03,& + & 2.396567E-03,2.745535E-02,1.106100E-01,3.327000E-01,1.100600E+00,& + & 4.139900E+00,4.468800E+01,2.684000E+02,4.771400E+02,8.160700E+02,& + & 1.591779E+03,2.848864E+03,2.897217E-03,3.251146E-02,1.357800E-01,& + & 4.098400E-01,1.345600E+00,5.057600E+00,5.114500E+01,2.836800E+02,& + & 4.861800E+02,8.041000E+02,1.503706E+03,2.602866E+03,3.404220E-03,& + & 3.819251E-02,1.666600E-01,5.020900E-01,1.636500E+00,6.163300E+00,& + & 5.738700E+01,2.956200E+02,4.908100E+02,7.874400E+02,1.419325E+03,& + & 2.385928E+03,3.905861E-03,4.452078E-02,2.042500E-01,6.101700E-01,& + & 1.971200E+00,7.461400E+00,6.389100E+01,2.990400E+02,4.915000E+02,& + & 7.673100E+02,1.338928E+03,2.193651E+03,4.406234E-03,5.133861E-02,& + & 2.486500E-01,7.363700E-01,2.347900E+00,8.944700E+00,7.020300E+01,& + & 2.987200E+02,4.875600E+02,7.449700E+02,1.262812E+03,2.021464E+03,& + & 1.867680E-03,2.226603E-02,9.195100E-02,2.847500E-01,9.741100E-01,& + & 3.794700E+00,4.222100E+01,2.621800E+02,4.730800E+02,8.199400E+02,& + & 1.626619E+03,2.950450E+03,2.279110E-03,2.658651E-02,1.142400E-01,& + & 3.559500E-01,1.207800E+00,4.659600E+00,4.875400E+01,2.787000E+02,& + & 4.839500E+02,8.099700E+02,1.536940E+03,2.691510E+03,2.699652E-03,& + & 3.149684E-02,1.420200E-01,4.419000E-01,1.489200E+00,5.709500E+00,& + & 5.510800E+01,2.918500E+02,4.900700E+02,7.947700E+02,1.450763E+03,& + & 2.463814E+03,3.117715E-03,3.703732E-02,1.763900E-01,5.437800E-01,& + & 1.815000E+00,6.950100E+00,6.190800E+01,2.950300E+02,4.920400E+02,& + & 7.756100E+02,1.368722E+03,2.262655E+03,3.533978E-03,4.309905E-02,& + & 2.175700E-01,6.641000E-01,2.183200E+00,8.380400E+00,6.836100E+01,& + & 2.979800E+02,4.867100E+02,7.538500E+02,1.290793E+03,2.082921E+03,& + & 1.444840E-03,1.792693E-02,7.578100E-02,2.413700E-01,8.548900E-01,& + & 3.464500E+00,3.963700E+01,2.550500E+02,4.678300E+02,8.229200E+02,& + & 1.663544E+03,3.062154E+03,1.781994E-03,2.159339E-02,9.522100E-02,& + & 3.064000E-01,1.075900E+00,4.273100E+00,4.622000E+01,2.729800E+02,& + & 4.808600E+02,8.152700E+02,1.572158E+03,2.788636E+03,2.129696E-03,& + & 2.581415E-02,1.199300E-01,3.858100E-01,1.345600E+00,5.263100E+00,& + & 5.269300E+01,2.872700E+02,4.886200E+02,8.016800E+02,1.484213E+03,& + & 2.549197E+03,2.477398E-03,3.063838E-02,1.509900E-01,4.813000E-01,& + & 1.661200E+00,6.440800E+00,5.970800E+01,2.909000E+02,4.920500E+02,& + & 7.838400E+02,1.400410E+03,2.337893E+03,2.824748E-03,3.599200E-02,& + & 1.890100E-01,5.950700E-01,2.019700E+00,7.810700E+00,6.636300E+01,& + & 2.972000E+02,4.848000E+02,7.628500E+02,1.320675E+03,2.150201E+03,& + & 1.101044E-03,1.426078E-02,6.148700E-02,2.012100E-01,7.393000E-01,& + & 3.133300E+00,3.680300E+01,2.465400E+02,4.608000E+02,8.248000E+02,& + & 1.704403E+03,3.192224E+03,1.376554E-03,1.733754E-02,7.816400E-02,& + & 2.595200E-01,9.449400E-01,3.881700E+00,4.340900E+01,2.660300E+02,& + & 4.764400E+02,8.199300E+02,1.611360E+03,2.900956E+03,1.662993E-03,& + & 2.091775E-02,9.973100E-02,3.319900E-01,1.200000E+00,4.803200E+00,& + & 4.998700E+01,2.816000E+02,4.862300E+02,8.085800E+02,1.521737E+03,& + & 2.647725E+03,1.952810E-03,2.506510E-02,1.273700E-01,4.203800E-01,& + & 1.502600E+00,5.910900E+00,5.715300E+01,2.864500E+02,4.913900E+02,& + & 7.922900E+02,1.435938E+03,2.424802E+03,2.241254E-03,2.977392E-02,& + & 1.617900E-01,5.270200E-01,1.849600E+00,7.207700E+00,6.398700E+01,& + & 2.946900E+02,4.846900E+02,7.723500E+02,1.354242E+03,2.227465E+03/ + data absb( : ,176:200) / & + & 8.353208E-04,1.129667E-02,4.958000E-02,1.664400E-01,6.354700E-01,& + & 2.827200E+00,3.401500E+01,2.374000E+02,4.525900E+02,8.252200E+02,& + & 1.745452E+03,3.328624E+03,1.059399E-03,1.386331E-02,6.377000E-02,& + & 2.183600E-01,8.253500E-01,3.525200E+00,4.060300E+01,2.584700E+02,& + & 4.710200E+02,8.234500E+02,1.650880E+03,3.019271E+03,1.295199E-03,& + & 1.689023E-02,8.243400E-02,2.841200E-01,1.065300E+00,4.379000E+00,& + & 4.727600E+01,2.751900E+02,4.830600E+02,8.145500E+02,1.559516E+03,& + & 2.750737E+03,1.536058E-03,2.045658E-02,1.068400E-01,3.655800E-01,& + & 1.354400E+00,5.416100E+00,5.459400E+01,2.810600E+02,4.900300E+02,& + & 8.000200E+02,1.471872E+03,2.515446E+03,1.776179E-03,2.456007E-02,& + & 1.378600E-01,4.652000E-01,1.688900E+00,6.640300E+00,6.160800E+01,& + & 2.924800E+02,4.823000E+02,7.813500E+02,1.388275E+03,2.307740E+03,& + & 6.301589E-04,8.914412E-03,3.973800E-02,1.366400E-01,5.424100E-01,& + & 2.541900E+00,3.128800E+01,2.276300E+02,4.432000E+02,8.240400E+02,& + & 1.786545E+03,3.472739E+03,8.132142E-04,1.104627E-02,5.170900E-02,& + & 1.824700E-01,7.167400E-01,3.200000E+00,3.781200E+01,2.502500E+02,& + & 4.644500E+02,8.255800E+02,1.690716E+03,3.143982E+03,1.006728E-03,& + & 1.359446E-02,6.773300E-02,2.416600E-01,9.413900E-01,3.989400E+00,& + & 4.463600E+01,2.674300E+02,4.790100E+02,8.194100E+02,1.597713E+03,& + & 2.858759E+03,1.206768E-03,1.664663E-02,8.907300E-02,3.163700E-01,& + & 1.216000E+00,4.955000E+00,5.206500E+01,2.745600E+02,4.878600E+02,& + & 8.069700E+02,1.508367E+03,2.610350E+03,1.407278E-03,2.020130E-02,& + & 1.168600E-01,4.091200E-01,1.537500E+00,6.107700E+00,5.920100E+01,& + & 2.904900E+02,4.780700E+02,7.898200E+02,1.422853E+03,2.391437E+03,& + & 4.747070E-04,7.040368E-03,3.186200E-02,1.120300E-01,4.630400E-01,& + & 2.287600E+00,2.879500E+01,2.179100E+02,4.332100E+02,8.213100E+02,& + & 1.825322E+03,3.615387E+03,6.238494E-04,8.802335E-03,4.194300E-02,& + & 1.522800E-01,6.230000E-01,2.915100E+00,3.522000E+01,2.420200E+02,& + & 4.572800E+02,8.264700E+02,1.728336E+03,3.267302E+03,7.822435E-04,& + & 1.093799E-02,5.563700E-02,2.055100E-01,8.321700E-01,3.650700E+00,& + & 4.206100E+01,2.604800E+02,4.743500E+02,8.230100E+02,1.633953E+03,& + & 2.965505E+03,9.479007E-04,1.353205E-02,7.427000E-02,2.739900E-01,& + & 1.092500E+00,4.551300E+00,4.955200E+01,2.689800E+02,4.851800E+02,& + & 8.127700E+02,1.543024E+03,2.703629E+03,1.115373E-03,1.659458E-02,& + & 9.903100E-02,3.602300E-01,1.401200E+00,5.635800E+00,5.681300E+01,& + & 2.873100E+02,4.755000E+02,7.972200E+02,1.455836E+03,2.473548E+03,& + & 3.559046E-04,5.550233E-03,2.546900E-02,9.142400E-02,3.937100E-01,& + & 2.053900E+00,2.645000E+01,2.079700E+02,4.224800E+02,8.169900E+02,& + & 1.862828E+03,3.761680E+03,4.771902E-04,6.999223E-03,3.391100E-02,& + & 1.265200E-01,5.399500E-01,2.653700E+00,3.274800E+01,2.335000E+02,& + & 4.493100E+02,8.260400E+02,1.765062E+03,3.392892E+03,6.066670E-04,& + & 8.778035E-03,4.556100E-02,1.741300E-01,7.337300E-01,3.348000E+00,& + & 3.952800E+01,2.535500E+02,4.689100E+02,8.255000E+02,1.669467E+03,& + & 3.074300E+03,7.428748E-04,1.097103E-02,6.172500E-02,2.364800E-01,& + & 9.798000E-01,4.186000E+00,4.706500E+01,2.633400E+02,4.819300E+02,& + & 8.175900E+02,1.577030E+03,2.797994E+03,8.826974E-04,1.359662E-02,& + & 8.369200E-02,3.164200E-01,1.274800E+00,5.204200E+00,5.442400E+01,& + & 2.831000E+02,4.736600E+02,8.038000E+02,1.488375E+03,2.556681E+03,& + & 2.653541E-04,4.359543E-03,2.025400E-02,7.403300E-02,3.322000E-01,& + & 1.835900E+00,2.418200E+01,1.975700E+02,4.106500E+02,8.111800E+02,& + & 1.900000E+03,3.915875E+03,3.636470E-04,5.544970E-03,2.726600E-02,& + & 1.043300E-01,4.649300E-01,2.407500E+00,3.032900E+01,2.244900E+02,& + & 4.403400E+02,8.242700E+02,1.802038E+03,3.524599E+03,4.690673E-04,& + & 7.021462E-03,3.709700E-02,1.465300E-01,6.439600E-01,3.067600E+00,& + & 3.705200E+01,2.457600E+02,4.625700E+02,8.269100E+02,1.705203E+03,& + & 3.188411E+03,5.808611E-04,8.863314E-03,5.101800E-02,2.028900E-01,& + & 8.750800E-01,3.848200E+00,4.458400E+01,2.571500E+02,4.779300E+02,& + & 8.215100E+02,1.611321E+03,2.896906E+03,6.970300E-04,1.110829E-02,& + & 7.033200E-02,2.767000E-01,1.155800E+00,4.800500E+00,5.204100E+01,& + & 2.791500E+02,4.700400E+02,8.096900E+02,1.521175E+03,2.643363E+03/ + data absb( : ,201:225) / & + & 1.964769E-04,3.411052E-03,1.600800E-02,5.946800E-02,2.777800E-01,& + & 1.631500E+00,2.199600E+01,1.866900E+02,3.976500E+02,8.036900E+02,& + & 1.936756E+03,4.079808E+03,2.756708E-04,4.376153E-03,2.177900E-02,& + & 8.539700E-02,3.974100E-01,2.174400E+00,2.796500E+01,2.149500E+02,& + & 4.303700E+02,8.209900E+02,1.838909E+03,3.663786E+03,3.615206E-04,& + & 5.597604E-03,3.001200E-02,1.223700E-01,5.618100E-01,2.804300E+00,& + & 3.463600E+01,2.371400E+02,4.552600E+02,8.272500E+02,1.741272E+03,& + & 3.308445E+03,4.531550E-04,7.137167E-03,4.190700E-02,1.730100E-01,& + & 7.778500E-01,3.534200E+00,4.215500E+01,2.506700E+02,4.721300E+02,& + & 8.245500E+02,1.646150E+03,3.000903E+03,5.494737E-04,9.048543E-03,& + & 5.877900E-02,2.405900E-01,1.043400E+00,4.424200E+00,4.965900E+01,& + & 2.749600E+02,4.651000E+02,8.149300E+02,1.554498E+03,2.734193E+03,& + & 1.456751E-04,2.674386E-03,1.268400E-02,4.783100E-02,2.327400E-01,& + & 1.453600E+00,2.006900E+01,1.763800E+02,3.846700E+02,7.951900E+02,& + & 1.969990E+03,4.239085E+03,2.083916E-04,3.460276E-03,1.742200E-02,& + & 6.993200E-02,3.405000E-01,1.968900E+00,2.585800E+01,2.057700E+02,& + & 4.202700E+02,8.166200E+02,1.872836E+03,3.798359E+03,2.780854E-04,& + & 4.462904E-03,2.431300E-02,1.022200E-01,4.909000E-01,2.573400E+00,& + & 3.225100E+01,2.306800E+02,4.477700E+02,8.264700E+02,1.774631E+03,& + & 3.423851E+03,3.528742E-04,5.744066E-03,3.441700E-02,1.475900E-01,& + & 6.926100E-01,3.265100E+00,3.970000E+01,2.449100E+02,4.679000E+02,& + & 8.264900E+02,1.678435E+03,3.100887E+03,4.320505E-04,7.356859E-03,& + & 4.906200E-02,2.095400E-01,9.438700E-01,4.097700E+00,4.724500E+01,& + & 2.687400E+02,4.648400E+02,8.190400E+02,1.585471E+03,2.821023E+03,& + & 1.077034E-04,2.094798E-03,1.003800E-02,3.837500E-02,1.943500E-01,& + & 1.292400E+00,1.830200E+01,1.662100E+02,3.713200E+02,7.852500E+02,& + & 2.001663E+03,4.400347E+03,1.568571E-04,2.731165E-03,1.391600E-02,& + & 5.703200E-02,2.910500E-01,1.781800E+00,2.389800E+01,1.965900E+02,& + & 4.097400E+02,8.112200E+02,1.905096E+03,3.934077E+03,2.132067E-04,& + & 3.550239E-03,1.964400E-02,8.506200E-02,4.280500E-01,2.361600E+00,& + & 3.004500E+01,2.236900E+02,4.397300E+02,8.246600E+02,1.806745E+03,& + & 3.539866E+03,2.738635E-04,4.607943E-03,2.816400E-02,1.254600E-01,& + & 6.156200E-01,3.023400E+00,3.723000E+01,2.409500E+02,4.622000E+02,& + & 8.275300E+02,1.709698E+03,3.201331E+03,3.384435E-04,5.961794E-03,& + & 4.079500E-02,1.820400E-01,8.523500E-01,3.804000E+00,4.478100E+01,& + & 2.603100E+02,4.682000E+02,8.223100E+02,1.615422E+03,2.907927E+03,& + & 7.925828E-05,1.633653E-03,7.907900E-03,3.060000E-02,1.608300E-01,& + & 1.142800E+00,1.661800E+01,1.558100E+02,3.571000E+02,7.734800E+02,& + & 2.032742E+03,4.570344E+03,1.174531E-04,2.147907E-03,1.105300E-02,& + & 4.615000E-02,2.469300E-01,1.604200E+00,2.200600E+01,1.870900E+02,& + & 3.983700E+02,8.046000E+02,1.936989E+03,4.077099E+03,1.629058E-04,& + & 2.814354E-03,1.578100E-02,7.026200E-02,3.715800E-01,2.158400E+00,& + & 2.799700E+01,2.153300E+02,4.309700E+02,8.216300E+02,1.838720E+03,& + & 3.660975E+03,2.117941E-04,3.684644E-03,2.292500E-02,1.059400E-01,& + & 5.441500E-01,2.795000E+00,3.478700E+01,2.365800E+02,4.558000E+02,& + & 8.277600E+02,1.740922E+03,3.305846E+03,2.646792E-04,4.814108E-03,& + & 3.375000E-02,1.570700E-01,7.666900E-01,3.530300E+00,4.231900E+01,& + & 2.518700E+02,4.703800E+02,8.248700E+02,1.645700E+03,2.998353E+03,& + & 5.794970E-05,1.268848E-03,6.201000E-03,2.422100E-02,1.318300E-01,& + & 1.003400E+00,1.501700E+01,1.452300E+02,3.420900E+02,7.599100E+02,& + & 2.063105E+03,4.749964E+03,8.746969E-05,1.683224E-03,8.729500E-03,& + & 3.704300E-02,2.077000E-01,1.437600E+00,2.018000E+01,1.772800E+02,& + & 3.860200E+02,7.965200E+02,1.968495E+03,4.227732E+03,1.238524E-04,& + & 2.223389E-03,1.259800E-02,5.756900E-02,3.203400E-01,1.964500E+00,& + & 2.599700E+01,2.066200E+02,4.213900E+02,8.175200E+02,1.870974E+03,& + & 3.788477E+03,1.633251E-04,2.934575E-03,1.855200E-02,8.878600E-02,& + & 4.781800E-01,2.576600E+00,3.240100E+01,2.315700E+02,4.486600E+02,& + & 8.270100E+02,1.772524E+03,3.415018E+03,2.063347E-04,3.871232E-03,& + & 2.774200E-02,1.346500E-01,6.864900E-01,3.274600E+00,3.985500E+01,& + & 2.458100E+02,4.686000E+02,8.267500E+02,1.676324E+03,3.093089E+03/ + data absb( : ,226:235) / & + & 4.239571E-05,9.860233E-04,4.864600E-03,1.917000E-02,1.078600E-01,& + & 8.798900E-01,1.358100E+01,1.350800E+02,3.270200E+02,7.451100E+02,& + & 2.091152E+03,4.930702E+03,6.518854E-05,1.320089E-03,6.896600E-03,& + & 2.971300E-02,1.744500E-01,1.288200E+00,1.851400E+01,1.677400E+02,& + & 3.735400E+02,7.873000E+02,1.998206E+03,4.378379E+03,9.409052E-05,& + & 1.757530E-03,1.005800E-02,4.710100E-02,2.761800E-01,1.789500E+00,& + & 2.415100E+01,1.980200E+02,4.115300E+02,8.125100E+02,1.901228E+03,& + & 3.915213E+03,1.259086E-04,2.337212E-03,1.500500E-02,7.430200E-02,& + & 4.205800E-01,2.377500E+00,3.033200E+01,2.249700E+02,4.411500E+02,& + & 8.253600E+02,1.802627E+03,3.523437E+03,1.606735E-04,3.112324E-03,& + & 2.277400E-02,1.153400E-01,6.148100E-01,3.047000E+00,3.748700E+01,& + & 2.425200E+02,4.632700E+02,8.277600E+02,1.705630E+03,3.186974E+03,& + & 3.346846E-05,8.048377E-04,4.033100E-03,1.631400E-02,9.577800E-02,& + & 8.260700E-01,1.302200E+01,1.309400E+02,3.207400E+02,7.386600E+02,& + & 2.102357E+03,5.007031E+03,5.176879E-05,1.085165E-03,5.787200E-03,& + & 2.576000E-02,1.587900E-01,1.225300E+00,1.785900E+01,1.638200E+02,& + & 3.682700E+02,7.832000E+02,2.010116E+03,4.441664E+03,7.509134E-05,& + & 1.454142E-03,8.554200E-03,4.152800E-02,2.569900E-01,1.714500E+00,& + & 2.342500E+01,1.944600E+02,4.073500E+02,8.102600E+02,1.913531E+03,& + & 3.968531E+03,1.008511E-04,1.944293E-03,1.297500E-02,6.691200E-02,& + & 3.968400E-01,2.292900E+00,2.955100E+01,2.218500E+02,4.379700E+02,& + & 8.244900E+02,1.814941E+03,3.568826E+03,1.289212E-04,2.608946E-03,& + & 2.001400E-02,1.059600E-01,5.828300E-01,2.954600E+00,3.609200E+01,& + & 2.452500E+02,4.609900E+02,8.280000E+02,1.717511E+03,3.225982E+03/ + + + data ka_mco2(:,:, 1) / 1.370502E-05,2.621626E-05,3.432130E-05,& + & 4.146590E-05,6.845440E-05,1.181540E-04,3.306140E-04,9.104180E-04,& + & 1.012750E-03,1.184690E-03,1.237325E-03,1.381582E-03,1.386827E-05,& + & 2.618389E-05,3.147920E-05,4.259400E-05,6.883320E-05,1.408740E-04,& + & 3.784530E-04,9.066800E-04,1.068560E-03,1.090920E-03,5.673583E-04,& + & 1.673414E-04,1.416761E-05,2.691017E-05,3.216550E-05,4.449400E-05,& + & 7.498990E-05,1.550920E-04,4.575760E-04,8.179760E-04,7.348960E-04,& + & 3.975210E-04,1.386595E-04,1.671119E-04,1.518502E-05,2.729657E-05,& + & 3.228700E-05,4.834020E-05,8.268010E-05,1.806660E-04,5.182770E-04,& + & 3.703140E-04,5.894910E-05,7.185570E-05,1.356440E-04,1.669007E-04,& + & 1.736552E-05,2.678143E-05,3.311900E-05,5.147970E-05,9.295610E-05,& + & 2.215540E-04,4.453650E-04,1.008590E-04,5.324000E-05,7.330260E-05,& + & 1.342200E-04,1.669620E-04,2.384534E-05,2.431259E-05,3.312870E-05,& + & 5.714810E-05,1.097000E-04,2.789970E-04,2.873010E-04,9.244770E-05,& + & 5.314080E-05,7.440530E-05,1.334673E-04,1.668244E-04,4.873068E-05,& + & 1.350878E-05,3.352350E-05,5.695130E-05,1.434570E-04,2.849390E-04,& + & 1.107430E-04,8.429430E-05,5.245170E-05,7.687620E-05,1.331493E-04,& + & 1.669007E-04,9.174102E-05,8.254040E-05,3.576660E-05,4.393610E-06,& + & 1.521520E-05,5.307640E-05,8.631770E-05,6.864640E-05,5.017680E-05,& + & 8.459960E-05,1.337666E-04,1.668076E-04,1.147584E-05,1.173898E-05,& + & 2.963490E-05,5.755150E-05,1.156830E-04,2.768060E-04,4.527150E-04,& + & 1.030950E-04,5.463910E-05,7.735830E-05,1.350710E-04,1.669620E-04/ + data ka_mco2(:,:, 2) / 1.642307E-05,3.128890E-05,4.113010E-05,& + & 4.986930E-05,8.164610E-05,1.405160E-04,3.932890E-04,1.086310E-03,& + & 1.214330E-03,1.417550E-03,1.477861E-03,1.647450E-03,1.663530E-05,& + & 3.126718E-05,3.790750E-05,5.111620E-05,8.217190E-05,1.670090E-04,& + & 4.507350E-04,1.086220E-03,1.278850E-03,1.302880E-03,6.750834E-04,& + & 1.930938E-04,1.700283E-05,3.213854E-05,3.879900E-05,5.329220E-05,& + & 8.946060E-05,1.841320E-04,5.455120E-04,9.794580E-04,8.778630E-04,& + & 4.741030E-04,1.629903E-04,1.928193E-04,1.820617E-05,3.261244E-05,& + & 3.898640E-05,5.780650E-05,9.858020E-05,2.145210E-04,6.187640E-04,& + & 4.414400E-04,7.125600E-05,8.562300E-05,1.593788E-04,1.925738E-04,& + & 2.074406E-05,3.206050E-05,3.995280E-05,6.153280E-05,1.108450E-04,& + & 2.632650E-04,5.321060E-04,1.196920E-04,6.454650E-05,8.690770E-05,& + & 1.576736E-04,1.926499E-04,2.819986E-05,2.922535E-05,3.997720E-05,& + & 6.831560E-05,1.308790E-04,3.325480E-04,3.430090E-04,1.096590E-04,& + & 6.424090E-05,8.821670E-05,1.567719E-04,1.924835E-04,5.728409E-05,& + & 1.644420E-05,4.028320E-05,6.844200E-05,1.715540E-04,3.406060E-04,& + & 1.322860E-04,1.000440E-04,6.324850E-05,9.113050E-05,1.563917E-04,& + & 1.925738E-04,1.079696E-04,9.904283E-05,4.275110E-05,5.500760E-06,& + & 1.894210E-05,6.478120E-05,1.030670E-04,8.181630E-05,6.022170E-05,& + & 1.002140E-04,1.571212E-04,1.924648E-04,1.371402E-05,1.419687E-05,& + & 3.552020E-05,6.868500E-05,1.375440E-04,3.296390E-04,5.415400E-04,& + & 1.219850E-04,6.587650E-05,9.167670E-05,1.586488E-04,1.926499E-04/ + data ka_mco2(:,:, 3) / 1.968156E-05,3.734321E-05,4.928960E-05,& + & 5.997570E-05,9.737990E-05,1.671110E-04,4.678440E-04,1.296190E-03,& + & 1.456050E-03,1.696190E-03,1.765155E-03,1.964471E-03,1.995644E-05,& + & 3.733739E-05,4.564850E-05,6.134340E-05,9.809550E-05,1.979930E-04,& + & 5.368240E-04,1.301300E-03,1.530520E-03,1.556020E-03,8.032887E-04,& + & 2.228096E-04,2.040687E-05,3.838276E-05,4.680060E-05,6.383030E-05,& + & 1.067240E-04,2.186090E-04,6.503480E-04,1.172820E-03,1.048640E-03,& + & 5.654380E-04,1.915948E-04,2.224802E-04,2.182902E-05,3.896353E-05,& + & 4.707590E-05,6.912650E-05,1.175380E-04,2.547210E-04,7.387350E-04,& + & 5.262260E-04,8.613220E-05,1.020280E-04,1.872700E-04,2.221971E-04,& + & 2.478000E-05,3.838022E-05,4.819670E-05,7.354910E-05,1.321760E-04,& + & 3.128290E-04,6.357420E-04,1.420410E-04,7.825420E-05,1.030380E-04,& + & 1.852302E-04,2.222911E-04,3.335427E-05,3.513089E-05,4.824130E-05,& + & 8.166520E-05,1.561480E-04,3.963780E-04,4.095190E-04,1.300740E-04,& + & 7.765970E-05,1.045920E-04,1.841499E-04,2.220884E-04,6.734154E-05,& + & 2.001792E-05,4.840610E-05,8.225120E-05,2.051530E-04,4.071490E-04,& + & 1.580200E-04,1.187350E-04,7.626760E-05,1.080280E-04,1.836948E-04,& + & 2.221971E-04,1.270718E-04,1.188466E-04,5.109950E-05,6.886900E-06,& + & 2.358190E-05,7.906730E-05,1.230660E-04,9.751290E-05,7.227740E-05,& + & 1.187110E-04,1.845593E-04,2.220695E-04,1.638877E-05,1.716939E-05,& + & 4.257430E-05,8.197220E-05,1.635350E-04,3.925560E-04,6.477920E-04,& + & 1.443350E-04,7.942520E-05,1.086450E-04,1.863474E-04,2.222911E-04/ + data ka_mco2(:,:, 4) / 2.358835E-05,4.456897E-05,5.906790E-05,& + & 7.213020E-05,1.161460E-04,1.987390E-04,5.565340E-04,1.546620E-03,& + & 1.745870E-03,2.029590E-03,2.108308E-03,2.342515E-03,2.394306E-05,& + & 4.458604E-05,5.497030E-05,7.361680E-05,1.171050E-04,2.347260E-04,& + & 6.393550E-04,1.558980E-03,1.831710E-03,1.858340E-03,9.558705E-04,& + & 2.570986E-04,2.449402E-05,4.584018E-05,5.645230E-05,7.645220E-05,& + & 1.273180E-04,2.595420E-04,7.753300E-04,1.404350E-03,1.252650E-03,& + & 6.743690E-04,2.252230E-04,2.567044E-04,2.617372E-05,4.655146E-05,& + & 5.684390E-05,8.266330E-05,1.401410E-04,3.024540E-04,8.819670E-04,& + & 6.272980E-04,1.041140E-04,1.215760E-04,2.200473E-04,2.563774E-04,& + & 2.960134E-05,4.594570E-05,5.814170E-05,8.791200E-05,1.576120E-04,& + & 3.717240E-04,7.595630E-04,1.685630E-04,9.487310E-05,1.221620E-04,& + & 2.176067E-04,2.564927E-04,3.945665E-05,4.222992E-05,5.821390E-05,& + & 9.762370E-05,1.862940E-04,4.724600E-04,4.889260E-04,1.542900E-04,& + & 9.388140E-05,1.240070E-04,2.163141E-04,2.562468E-04,7.916819E-05,& + & 2.436869E-05,5.816680E-05,9.884660E-05,2.453320E-04,4.866910E-04,& + & 1.887600E-04,1.409190E-04,9.196670E-05,1.280580E-04,2.157711E-04,& + & 2.563774E-04,1.495574E-04,1.426132E-04,6.107830E-05,8.622350E-06,& + & 2.935820E-05,9.650390E-05,1.469460E-04,1.162210E-04,8.674660E-05,& + & 1.406220E-04,2.167955E-04,2.562280E-04,1.958518E-05,2.076435E-05,& + & 5.102920E-05,9.782980E-05,1.944380E-04,4.674810E-04,7.748920E-04,& + & 1.707810E-04,9.576030E-05,1.287550E-04,2.188864E-04,2.564927E-04/ + data ka_mco2(:,:, 5) / 2.827272E-05,5.319301E-05,7.078600E-05,& + & 8.674790E-05,1.385280E-04,2.363530E-04,6.620360E-04,1.845430E-03,& + & 2.093390E-03,2.428540E-03,2.518164E-03,2.793298E-03,2.872902E-05,& + & 5.324203E-05,6.619560E-05,8.834590E-05,1.397980E-04,2.782730E-04,& + & 7.614690E-04,1.867680E-03,2.192180E-03,2.219400E-03,1.137465E-03,& + & 2.966639E-04,2.940179E-05,5.474648E-05,6.809450E-05,9.157000E-05,& + & 1.518870E-04,3.081400E-04,9.243320E-04,1.681600E-03,1.496340E-03,& + & 8.042850E-04,2.647596E-04,2.961931E-04,3.138407E-05,5.561705E-05,& + & 6.863880E-05,9.885100E-05,1.670920E-04,3.591310E-04,1.052970E-03,& + & 7.477820E-04,1.258500E-04,1.448700E-04,2.585660E-04,2.958162E-04,& + & 3.536095E-05,5.500254E-05,7.013870E-05,1.050800E-04,1.879440E-04,& + & 4.417070E-04,9.075000E-04,2.000380E-04,1.150210E-04,1.448360E-04,& + & 2.556483E-04,2.959555E-04,4.668238E-05,5.076361E-05,7.024800E-05,& + & 1.167010E-04,2.222610E-04,5.631460E-04,5.837300E-04,1.830150E-04,& + & 1.134910E-04,1.470250E-04,2.541009E-04,2.956601E-04,9.307532E-05,& + & 2.966561E-05,6.989580E-05,1.187900E-04,2.933810E-04,5.817740E-04,& + & 2.254800E-04,1.672480E-04,1.108970E-04,1.518020E-04,2.534540E-04,& + & 2.958162E-04,1.760265E-04,1.711358E-04,7.300570E-05,1.079510E-05,& + & 3.654940E-05,1.177860E-04,1.754590E-04,1.385180E-04,1.041120E-04,& + & 1.665770E-04,2.546696E-04,2.956405E-04,2.340501E-05,2.511200E-05,& + & 6.116330E-05,1.167550E-04,2.311800E-04,5.567080E-04,9.269290E-04,& + & 2.020720E-04,1.154550E-04,1.525860E-04,2.571127E-04,2.959555E-04/ + data ka_mco2(:,:, 6) / 3.388984E-05,6.348576E-05,8.482880E-05,& + & 1.043280E-04,1.652230E-04,2.810860E-04,7.875390E-04,2.201980E-03,& + & 2.510070E-03,2.905890E-03,3.007697E-03,3.330824E-03,3.447519E-05,& + & 6.357848E-05,7.971330E-05,1.060220E-04,1.668880E-04,3.298990E-04,& + & 9.069060E-04,2.237500E-03,2.623590E-03,2.650610E-03,1.353590E-03,& + & 3.423186E-04,3.529533E-05,6.538328E-05,8.213770E-05,1.096770E-04,& + & 1.811960E-04,3.658370E-04,1.101970E-03,2.013570E-03,1.787440E-03,& + & 9.592280E-04,3.112429E-04,3.417575E-04,3.763287E-05,6.644813E-05,& + & 8.288100E-05,1.182090E-04,1.992250E-04,4.264290E-04,1.257130E-03,& + & 8.914070E-04,1.521240E-04,1.726260E-04,3.038337E-04,3.413209E-04,& + & 4.224142E-05,6.584457E-05,8.461110E-05,1.256000E-04,2.241120E-04,& + & 5.248650E-04,1.084250E-03,2.373890E-04,1.394480E-04,1.717170E-04,& + & 3.003456E-04,3.414910E-04,5.523961E-05,6.102191E-05,8.476980E-05,& + & 1.395050E-04,2.651720E-04,6.712380E-04,6.969160E-04,2.170870E-04,& + & 1.371980E-04,1.743170E-04,2.984958E-04,3.411342E-04,1.094302E-04,& + & 3.611455E-05,8.398980E-05,1.427580E-04,3.508400E-04,6.954320E-04,& + & 2.693420E-04,1.984960E-04,1.337250E-04,1.799490E-04,2.977249E-04,& + & 3.413209E-04,2.071856E-04,2.053663E-04,8.726220E-05,1.351540E-05,& + & 4.550210E-05,1.437610E-04,2.095050E-04,1.650930E-04,1.249550E-04,& + & 1.973230E-04,2.991695E-04,3.411155E-04,2.796988E-05,3.036994E-05,& + & 7.330990E-05,1.393420E-04,2.748660E-04,6.629640E-04,1.108800E-03,& + & 2.390960E-04,1.392000E-04,1.808290E-04,3.020221E-04,3.414910E-04/ + data ka_mco2(:,:, 7) / 4.062601E-05,7.577034E-05,1.016570E-04,& + & 1.254710E-04,1.970630E-04,3.342850E-04,9.368330E-04,2.627410E-03,& + & 3.009700E-03,3.477080E-03,3.592397E-03,3.971803E-03,4.137507E-05,& + & 7.592177E-05,9.599140E-05,1.272350E-04,1.992290E-04,3.911020E-04,& + & 1.080120E-03,2.680560E-03,3.139900E-03,3.165600E-03,1.610824E-03,& + & 3.949994E-04,4.237331E-05,7.808668E-05,9.907700E-05,1.313650E-04,& + & 2.161610E-04,4.343370E-04,1.313740E-03,2.411080E-03,2.135160E-03,& + & 1.144020E-03,3.658944E-04,3.943299E-04,4.512732E-05,7.938847E-05,& + & 1.000780E-04,1.413570E-04,2.375370E-04,5.063390E-04,1.500870E-03,& + & 1.062620E-03,1.838830E-04,2.057010E-04,3.570340E-04,3.938258E-04,& + & 5.046100E-05,7.882395E-05,1.020700E-04,1.501280E-04,2.672410E-04,& + & 6.236790E-04,1.295420E-03,2.817150E-04,1.690630E-04,2.035880E-04,& + & 3.528656E-04,3.940331E-04,6.537533E-05,7.335332E-05,1.022940E-04,& + & 1.667660E-04,3.163670E-04,8.000770E-04,8.320500E-04,2.575030E-04,& + & 1.658560E-04,2.066740E-04,3.506552E-04,3.936031E-04,1.286642E-04,& + & 4.396617E-05,1.009260E-04,1.715620E-04,4.195520E-04,8.312950E-04,& + & 3.217380E-04,2.355820E-04,1.612510E-04,2.133150E-04,3.497366E-04,& + & 3.938258E-04,2.438658E-04,2.464487E-04,1.043030E-04,1.692120E-05,& + & 5.664760E-05,1.754640E-04,2.501580E-04,1.967670E-04,1.499690E-04,& + & 2.337430E-04,3.514552E-04,3.935852E-04,3.342510E-05,3.672882E-05,& + & 8.786870E-05,1.662970E-04,3.268070E-04,7.895010E-04,1.326350E-03,& + & 2.829040E-04,1.678290E-04,2.142990E-04,3.547835E-04,3.940331E-04/ + data ka_mco2(:,:, 8) / 4.870476E-05,9.043200E-05,1.218250E-04,& + & 1.508990E-04,2.350390E-04,3.975530E-04,1.114430E-03,3.135030E-03,& + & 3.608780E-03,4.160550E-03,4.290766E-03,4.736131E-03,4.966116E-05,& + & 9.066145E-05,1.155940E-04,1.526910E-04,2.378360E-04,4.636610E-04,& + & 1.286420E-03,3.211350E-03,3.757810E-03,3.780640E-03,1.916992E-03,& + & 4.557872E-04,5.087412E-05,9.325831E-05,1.195100E-04,1.573410E-04,& + & 2.578730E-04,5.156640E-04,1.566210E-03,2.887070E-03,2.550540E-03,& + & 1.364420E-03,4.301507E-04,4.549902E-04,5.411597E-05,9.484905E-05,& + & 1.208440E-04,1.690380E-04,2.832170E-04,6.012230E-04,1.791870E-03,& + & 1.266710E-03,2.222720E-04,2.451120E-04,4.195580E-04,4.544072E-04,& + & 6.028017E-05,9.436178E-05,1.231310E-04,1.794450E-04,3.186690E-04,& + & 7.410960E-04,1.547730E-03,3.343180E-04,2.049660E-04,2.413750E-04,& + & 4.145789E-04,4.546581E-04,7.738289E-05,8.817676E-05,1.234400E-04,& + & 1.993540E-04,3.774460E-04,9.536470E-04,9.933860E-04,3.054420E-04,& + & 2.005000E-04,2.450380E-04,4.119376E-04,4.541425E-04,1.512849E-04,& + & 5.352579E-05,1.212770E-04,2.061770E-04,5.017220E-04,9.937000E-04,& + & 3.843260E-04,2.795970E-04,1.944430E-04,2.528680E-04,4.108448E-04,& + & 4.544072E-04,2.870480E-04,2.957552E-04,1.246710E-04,2.118510E-05,& + & 7.052330E-05,2.141590E-04,2.986980E-04,2.345170E-04,1.799910E-04,& + & 2.768850E-04,4.128917E-04,4.541259E-04,3.994433E-05,4.441924E-05,& + & 1.053190E-04,1.984680E-04,3.885630E-04,9.401900E-04,1.586580E-03,& + & 3.347390E-04,2.023460E-04,2.539640E-04,4.167708E-04,4.546581E-04/ + data ka_mco2(:,:, 9) / 5.839452E-05,1.079313E-04,1.459930E-04,& + & 1.814790E-04,2.803330E-04,4.727960E-04,1.325690E-03,3.740730E-03,& + & 4.327110E-03,4.978360E-03,5.124892E-03,5.647556E-03,5.961310E-05,& + & 1.082631E-04,1.391990E-04,1.832410E-04,2.839250E-04,5.496800E-04,& + & 1.532120E-03,3.847240E-03,4.497320E-03,4.515190E-03,2.281412E-03,& + & 5.259301E-04,6.108480E-05,1.113781E-04,1.441560E-04,1.884540E-04,& + & 3.076350E-04,6.122190E-04,1.867210E-03,3.457030E-03,3.046720E-03,& + & 1.627270E-03,5.057017E-04,5.249822E-04,6.489714E-05,1.133199E-04,& + & 1.459190E-04,2.021400E-04,3.376820E-04,7.138870E-04,2.139290E-03,& + & 1.510010E-03,2.686760E-04,2.920750E-04,4.930418E-04,5.243089E-04,& + & 7.201050E-05,1.129627E-04,1.485380E-04,2.144870E-04,3.799950E-04,& + & 8.806190E-04,1.849170E-03,3.967420E-04,2.484950E-04,2.861750E-04,& + & 4.870949E-04,5.246122E-04,9.160948E-05,1.059962E-04,1.489580E-04,& + & 2.383110E-04,4.503170E-04,1.136690E-03,1.186010E-03,3.623070E-04,& + & 2.423810E-04,2.905230E-04,4.839403E-04,5.239934E-04,1.778901E-04,& + & 6.516515E-05,1.457310E-04,2.477760E-04,5.999850E-04,1.187830E-03,& + & 4.590900E-04,3.318360E-04,2.344670E-04,2.997540E-04,4.826425E-04,& + & 5.243089E-04,3.378848E-04,3.549338E-04,1.490170E-04,2.652360E-05,& + & 8.779780E-05,2.613870E-04,3.566580E-04,2.795090E-04,2.160240E-04,& + & 3.279910E-04,4.850825E-04,5.239790E-04,4.773511E-05,5.371992E-05,& + & 1.262340E-04,2.368620E-04,4.619890E-04,1.119640E-03,1.897870E-03,& + & 3.960700E-04,2.439620E-04,3.009700E-04,4.895996E-04,5.246122E-04/ + data ka_mco2(:,:,10) / 7.001733E-05,1.288159E-04,1.749550E-04,& + & 2.182570E-04,3.343550E-04,5.622780E-04,1.577000E-03,4.463440E-03,& + & 5.188420E-03,5.956910E-03,6.121179E-03,6.734361E-03,7.156686E-05,& + & 1.292812E-04,1.676240E-04,2.199040E-04,3.389440E-04,6.516590E-04,& + & 1.824750E-03,4.609050E-03,5.382360E-03,5.392450E-03,2.715177E-03,& + & 6.068676E-04,7.334984E-05,1.330176E-04,1.738860E-04,2.257190E-04,& + & 3.669990E-04,7.268530E-04,2.226040E-03,4.139500E-03,3.639430E-03,& + & 1.940760E-03,5.945331E-04,6.057407E-04,7.782865E-05,1.353887E-04,& + & 1.761960E-04,2.417250E-04,4.026210E-04,8.476630E-04,2.554070E-03,& + & 1.800030E-03,3.247680E-04,3.480350E-04,5.794071E-04,6.049631E-04,& + & 8.602388E-05,1.352300E-04,1.791870E-04,2.563730E-04,4.531210E-04,& + & 1.046410E-03,2.209330E-03,4.708230E-04,3.012680E-04,3.392890E-04,& + & 5.723069E-04,6.053283E-04,1.084690E-04,1.274168E-04,1.797500E-04,& + & 2.848790E-04,5.372570E-04,1.354870E-03,1.415970E-03,4.297590E-04,& + & 2.930100E-04,3.444510E-04,5.685405E-04,6.045870E-04,2.091832E-04,& + & 7.933689E-05,1.751170E-04,2.977680E-04,7.174920E-04,1.419890E-03,& + & 5.483970E-04,3.938350E-04,2.827300E-04,3.553340E-04,5.670002E-04,& + & 6.049631E-04,3.977343E-04,4.259605E-04,1.781170E-04,3.320740E-05,& + & 1.093040E-04,3.190300E-04,4.258640E-04,3.331330E-04,2.592700E-04,& + & 3.885290E-04,5.699115E-04,6.045769E-04,5.704545E-05,6.496800E-05,& + & 1.513040E-04,2.826830E-04,5.492890E-04,1.333340E-03,2.270240E-03,& + & 4.686390E-04,2.941370E-04,3.566780E-04,5.751672E-04,6.053283E-04/ + data ka_mco2(:,:,11) / 8.396036E-05,1.537426E-04,2.096630E-04,& + & 2.624890E-04,3.987880E-04,6.686970E-04,1.875960E-03,5.325800E-03,& + & 6.221170E-03,7.127820E-03,7.311151E-03,8.030334E-03,8.592756E-05,& + & 1.543812E-04,2.018540E-04,2.639020E-04,4.046270E-04,7.725560E-04,& + & 2.173260E-03,5.521710E-03,6.441580E-03,6.440160E-03,3.231499E-03,& + & 7.002611E-04,8.808419E-05,1.588621E-04,2.097460E-04,2.703530E-04,& + & 4.378180E-04,8.629520E-04,2.653840E-03,4.956710E-03,4.347450E-03,& + & 2.314640E-03,6.989839E-04,6.989234E-04,9.334018E-05,1.617546E-04,& + & 2.127560E-04,2.890610E-04,4.800480E-04,1.006510E-03,3.049280E-03,& + & 2.145760E-03,3.925710E-04,4.147180E-04,6.809147E-04,6.980248E-04,& + & 1.027648E-04,1.618869E-04,2.161610E-04,3.064380E-04,5.403210E-04,& + & 1.243410E-03,2.639630E-03,5.587360E-04,3.652480E-04,4.022620E-04,& + & 6.724398E-04,6.984643E-04,1.284519E-04,1.531674E-04,2.169090E-04,& + & 3.405480E-04,6.409830E-04,1.614930E-03,1.690530E-03,5.097680E-04,& + & 3.542140E-04,4.083890E-04,6.679452E-04,6.975778E-04,2.459917E-04,& + & 9.659226E-05,2.104280E-04,3.578480E-04,8.580140E-04,1.697290E-03,& + & 6.550780E-04,4.674180E-04,3.409280E-04,4.212200E-04,6.661177E-04,& + & 6.980248E-04,4.681977E-04,5.112116E-04,2.129000E-04,4.157540E-05,& + & 1.360770E-04,3.893850E-04,5.084980E-04,3.970460E-04,3.111730E-04,& + & 4.602410E-04,6.695953E-04,6.975735E-04,6.817172E-05,7.857153E-05,& + & 1.813520E-04,3.373690E-04,6.530880E-04,1.587830E-03,2.715680E-03,& + & 5.545050E-04,3.546320E-04,4.226960E-04,6.757046E-04,6.984643E-04/ + data ka_mco2(:,:,12) / 1.006871E-04,1.834932E-04,2.512570E-04,& + & 3.156850E-04,4.756370E-04,7.952570E-04,2.231580E-03,6.354760E-03,& + & 7.459500E-03,8.528890E-03,8.732456E-03,9.575698E-03,1.031811E-04,& + & 1.843534E-04,2.430750E-04,3.167030E-04,4.830370E-04,9.158840E-04,& + & 2.588350E-03,6.615080E-03,7.709240E-03,7.691430E-03,3.846093E-03,& + & 8.080284E-04,1.057861E-04,1.897278E-04,2.530020E-04,3.238130E-04,& + & 5.223040E-04,1.024530E-03,3.163850E-03,5.935250E-03,5.193210E-03,& + & 2.760550E-03,8.218013E-04,8.064410E-04,1.119464E-04,1.932558E-04,& + & 2.569020E-04,3.456670E-04,5.723650E-04,1.195120E-03,3.640500E-03,& + & 2.557890E-03,4.745280E-04,4.941760E-04,8.002223E-04,8.054021E-04,& + & 1.227645E-04,1.937994E-04,2.607640E-04,3.662810E-04,6.443020E-04,& + & 1.477500E-03,3.153740E-03,6.630650E-04,4.428160E-04,4.769230E-04,& + & 7.901091E-04,8.059305E-04,1.521406E-04,1.841220E-04,2.617490E-04,& + & 4.070960E-04,7.647340E-04,1.924910E-03,2.018330E-03,6.046720E-04,& + & 4.282030E-04,4.841960E-04,7.847472E-04,8.048709E-04,2.892891E-04,& + & 1.176030E-04,2.528600E-04,4.300490E-04,1.026060E-03,2.028880E-03,& + & 7.825110E-04,5.547480E-04,4.111060E-04,4.993220E-04,7.825808E-04,& + & 8.054021E-04,5.511582E-04,6.135367E-04,2.544750E-04,5.205200E-05,& + & 1.694090E-04,4.752550E-04,6.071680E-04,4.732200E-04,3.734670E-04,& + & 5.451890E-04,7.867383E-04,8.048738E-04,8.146820E-05,9.502339E-05,& + & 2.173670E-04,4.026330E-04,7.765010E-04,1.890890E-03,3.248500E-03,& + & 6.561030E-04,4.275680E-04,5.009340E-04,7.938334E-04,8.059305E-04/ + data ka_mco2(:,:,13) / 1.207562E-04,2.190005E-04,3.011030E-04,& + & 3.796600E-04,5.672960E-04,9.457700E-04,2.654630E-03,7.582510E-03,& + & 8.944300E-03,1.020530E-02,1.043010E-02,1.141848E-02,1.239124E-04,& + & 2.201454E-04,2.927120E-04,3.800680E-04,5.766410E-04,1.085800E-03,& + & 3.082710E-03,7.924960E-03,9.226370E-03,9.185800E-03,4.577684E-03,& + & 9.323797E-04,1.270543E-04,2.265906E-04,3.051790E-04,3.878440E-04,& + & 6.230920E-04,1.216370E-03,3.771870E-03,7.106960E-03,6.203490E-03,& + & 3.292370E-03,9.662162E-04,9.304976E-04,1.342660E-04,2.308907E-04,& + & 3.102070E-04,4.133570E-04,6.824350E-04,1.419080E-03,4.346350E-03,& + & 3.049180E-03,5.735950E-04,5.888580E-04,9.404509E-04,9.292966E-04,& + & 1.466568E-04,2.320017E-04,3.145700E-04,4.378090E-04,7.682930E-04,& + & 1.755670E-03,3.767970E-03,7.868740E-04,5.368560E-04,5.654400E-04,& + & 9.283873E-04,9.299316E-04,1.802269E-04,2.213325E-04,3.158580E-04,& + & 4.866470E-04,9.123760E-04,2.294380E-03,2.409690E-03,7.172450E-04,& + & 5.176470E-04,5.740740E-04,9.219936E-04,9.286672E-04,3.402212E-04,& + & 1.431869E-04,3.038470E-04,5.168170E-04,1.227010E-03,2.425260E-03,& + & 9.347340E-04,6.583950E-04,4.957280E-04,5.919050E-04,9.194276E-04,& + & 9.292966E-04,6.488348E-04,7.363570E-04,3.041690E-04,6.516870E-05,& + & 2.109050E-04,5.800620E-04,7.249820E-04,5.640080E-04,4.482310E-04,& + & 6.458160E-04,9.244015E-04,9.286796E-04,9.735805E-05,1.149198E-04,& + & 2.605340E-04,4.805230E-04,9.232340E-04,2.251800E-03,3.885870E-03,& + & 7.763160E-04,5.155040E-04,5.936520E-04,9.326324E-04,9.299316E-04/ + data ka_mco2(:,:,14) / 1.448370E-04,2.613795E-04,3.608370E-04,& + & 4.566010E-04,6.766180E-04,1.124770E-03,3.157870E-03,9.047480E-03,& + & 1.072470E-02,1.221130E-02,1.245768E-02,1.361590E-02,1.488263E-04,& + & 2.628864E-04,3.524870E-04,4.561110E-04,6.883850E-04,1.287240E-03,& + & 3.671490E-03,9.494210E-03,1.104210E-02,1.097050E-02,5.448568E-03,& + & 1.075871E-03,1.526096E-04,2.706160E-04,3.681170E-04,4.645370E-04,& + & 7.433300E-04,1.444130E-03,4.496750E-03,8.510000E-03,7.410320E-03,& + & 3.926630E-03,1.136035E-03,1.073639E-03,1.610416E-04,2.758556E-04,& + & 3.745740E-04,4.943030E-04,8.136730E-04,1.685000E-03,5.189050E-03,& + & 3.634830E-03,6.933460E-04,7.016820E-04,1.105280E-03,1.072254E-03,& + & 1.752001E-04,2.777350E-04,3.794790E-04,5.233050E-04,9.161460E-04,& + & 2.086200E-03,4.501840E-03,9.338010E-04,6.508680E-04,6.703870E-04,& + & 1.090885E-03,1.073013E-03,2.135331E-04,2.660644E-04,3.811530E-04,& + & 5.817440E-04,1.088520E-03,2.734770E-03,2.876930E-03,8.507760E-04,& + & 6.257740E-04,6.806370E-04,1.083264E-03,1.071500E-03,4.001381E-04,& + & 1.743382E-04,3.651160E-04,6.210930E-04,1.467320E-03,2.899070E-03,& + & 1.116570E-03,7.814070E-04,5.977700E-04,7.016560E-04,1.080227E-03,& + & 1.072254E-03,7.638417E-04,8.837827E-04,3.635670E-04,8.159070E-05,& + & 2.625650E-04,7.079820E-04,8.656580E-04,6.722140E-04,5.379620E-04,& + & 7.650160E-04,1.086183E-03,1.071529E-03,1.163476E-04,1.389824E-04,& + & 3.122750E-04,5.734810E-04,1.097700E-03,2.681590E-03,4.648300E-03,& + & 9.185560E-04,6.215260E-04,7.035330E-04,1.095724E-03,1.073013E-03/ + data ka_mco2(:,:,15) / 1.737337E-04,3.119591E-04,4.324210E-04,& + & 5.491350E-04,8.070080E-04,1.337650E-03,3.756500E-03,1.079550E-02,& + & 1.285940E-02,1.461160E-02,1.487949E-02,1.623611E-02,1.787693E-04,& + & 3.139253E-04,4.244670E-04,5.473680E-04,8.217820E-04,1.526050E-03,& + & 4.372730E-03,1.137420E-02,1.321510E-02,1.310200E-02,6.485282E-03,& + & 1.241443E-03,1.833192E-04,3.231951E-04,4.440330E-04,5.563950E-04,& + & 8.867690E-04,1.714530E-03,5.360920E-03,1.019000E-02,8.851920E-03,& + & 4.683090E-03,1.335723E-03,1.238795E-03,1.931626E-04,3.295766E-04,& + & 4.522960E-04,5.911010E-04,9.701480E-04,2.000760E-03,6.195140E-03,& + & 4.332970E-03,8.380960E-04,8.361210E-04,1.299022E-03,1.237199E-03,& + & 2.092999E-04,3.324837E-04,4.577810E-04,6.254980E-04,1.092450E-03,& + & 2.478960E-03,5.378650E-03,1.108160E-03,7.890920E-04,7.948120E-04,& + & 1.281857E-03,1.238104E-03,2.530362E-04,3.198368E-04,4.599450E-04,& + & 6.954240E-04,1.298680E-03,3.259690E-03,3.434780E-03,1.009170E-03,& + & 7.564860E-04,8.069790E-04,1.272774E-03,1.236314E-03,4.706267E-04,& + & 2.122716E-04,4.387390E-04,7.464070E-04,1.754700E-03,3.465440E-03,& + & 1.333780E-03,9.274020E-04,7.208160E-04,8.317560E-04,1.269188E-03,& + & 1.237199E-03,8.992551E-04,1.060744E-03,4.345650E-04,1.021510E-04,& + & 3.268800E-04,8.641110E-04,1.033630E-03,8.011790E-04,6.456560E-04,& + & 9.062160E-04,1.276322E-03,1.236352E-03,1.390399E-04,1.680836E-04,& + & 3.742900E-04,6.844220E-04,1.305120E-03,3.193410E-03,5.560310E-03,& + & 1.086860E-03,7.493530E-04,8.337510E-04,1.287369E-03,1.238104E-03/ + data ka_mco2(:,:,16) / 2.084117E-04,3.723273E-04,5.182060E-04,& + & 6.604220E-04,9.625250E-04,1.590810E-03,4.468620E-03,1.288120E-02,& + & 1.541910E-02,1.748370E-02,1.777214E-02,1.936072E-02,2.147612E-04,& + & 3.748745E-04,5.111470E-04,6.568850E-04,9.810310E-04,1.809170E-03,& + & 5.207900E-03,1.362650E-02,1.581570E-02,1.564760E-02,7.719441E-03,& + & 1.432493E-03,2.202239E-04,3.859900E-04,5.356070E-04,6.664180E-04,& + & 1.057890E-03,2.035570E-03,6.391170E-03,1.220170E-02,1.057400E-02,& + & 5.585280E-03,1.570541E-03,1.429365E-03,2.316978E-04,3.937597E-04,& + & 5.461460E-04,7.068540E-04,1.156710E-03,2.375680E-03,7.396310E-03,& + & 5.165200E-03,1.013070E-03,9.963190E-04,1.526752E-03,1.427515E-03,& + & 2.500373E-04,3.980249E-04,5.522400E-04,7.476470E-04,1.302680E-03,& + & 2.945660E-03,6.426220E-03,1.315080E-03,9.566720E-04,9.423310E-04,& + & 1.506289E-03,1.428605E-03,2.998977E-04,3.844783E-04,5.550260E-04,& + & 8.313180E-04,1.549410E-03,3.885370E-03,4.100790E-03,1.197040E-03,& + & 9.145030E-04,9.567740E-04,1.495468E-03,1.426463E-03,5.535576E-04,& + & 2.584634E-04,5.272080E-04,8.970060E-04,2.098360E-03,4.142460E-03,& + & 1.593240E-03,1.100670E-03,8.691900E-04,9.859790E-04,1.491226E-03,& + & 1.427515E-03,1.058702E-03,1.273157E-03,5.194270E-04,1.278920E-04,& + & 4.069480E-04,1.054670E-03,1.234200E-03,9.548870E-04,7.749100E-04,& + & 1.073480E-03,1.499786E-03,1.426524E-03,1.661599E-04,2.032788E-04,& + & 4.486220E-04,8.168240E-04,1.551750E-03,3.802930E-03,6.651270E-03,& + & 1.285990E-03,9.034710E-04,9.880720E-04,1.512556E-03,1.428605E-03/ + data ka_mco2(:,:,17) / 2.500320E-04,4.443780E-04,6.210100E-04,& + & 7.942610E-04,1.148010E-03,1.891900E-03,5.315750E-03,1.536990E-02,& + & 1.848820E-02,2.092040E-02,2.122705E-02,2.308657E-02,2.580289E-04,& + & 4.476566E-04,6.155270E-04,7.883130E-04,1.171140E-03,2.144820E-03,& + & 6.202590E-03,1.632470E-02,1.892810E-02,1.868780E-02,9.188681E-03,& + & 1.652946E-03,2.645788E-04,4.609862E-04,6.460660E-04,7.981960E-04,& + & 1.262030E-03,2.416710E-03,7.619420E-03,1.461050E-02,1.263110E-02,& + & 6.661280E-03,1.846679E-03,1.649256E-03,2.779307E-04,4.704424E-04,& + & 6.594680E-04,8.452750E-04,1.379160E-03,2.820870E-03,8.830360E-03,& + & 6.157270E-03,1.224570E-03,1.187210E-03,1.794445E-03,1.647108E-03,& + & 2.987064E-04,4.764861E-04,6.661900E-04,8.936500E-04,1.553380E-03,& + & 3.500230E-03,7.677830E-03,1.560640E-03,1.159840E-03,1.117230E-03,& + & 1.770053E-03,1.648409E-03,3.554972E-04,4.621855E-04,6.697620E-04,& + & 9.937690E-04,1.848540E-03,4.631140E-03,4.895940E-03,1.419900E-03,& + & 1.105530E-03,1.134370E-03,1.757169E-03,1.645872E-03,6.511294E-04,& + & 3.147124E-04,6.335160E-04,1.077990E-03,2.509330E-03,4.951760E-03,& + & 1.903180E-03,1.306320E-03,1.048110E-03,1.168800E-03,1.752155E-03,& + & 1.647108E-03,1.246452E-03,1.528148E-03,6.208610E-04,1.601200E-04,& + & 5.066290E-04,1.287260E-03,1.473680E-03,1.138080E-03,9.300390E-04,& + & 1.271610E-03,1.762426E-03,1.645960E-03,1.985687E-04,2.458436E-04,& + & 5.377150E-04,9.748410E-04,1.844980E-03,4.528780E-03,7.956270E-03,& + & 1.521620E-03,1.089290E-03,1.170960E-03,1.777181E-03,1.648409E-03/ + data ka_mco2(:,:,18) / & + & 2.999887E-04,5.303717E-04,7.442080E-04,9.552240E-04,& + & 1.369240E-03,2.249960E-03,6.323450E-03,1.833940E-02,2.216830E-02,& + & 2.503250E-02,2.535363E-02,2.752944E-02,3.100498E-04,5.345699E-04,& + & 7.412220E-04,9.460360E-04,1.398090E-03,2.542730E-03,7.387250E-03,& + & 1.955720E-02,2.265310E-02,2.231870E-02,1.093775E-02,1.907335E-03,& + & 3.178908E-04,5.505537E-04,7.793040E-04,9.560320E-04,1.505560E-03,& + & 2.869230E-03,9.083700E-03,1.749490E-02,1.508830E-02,7.944560E-03,& + & 2.171409E-03,1.902959E-03,3.333993E-04,5.620580E-04,7.963040E-04,& + & 1.010800E-03,1.644380E-03,3.349470E-03,1.054250E-02,7.339880E-03,& + & 1.480220E-03,1.414670E-03,2.109116E-03,1.900487E-03,3.568494E-04,& + & 5.704151E-04,8.036520E-04,1.068160E-03,1.852310E-03,4.159200E-03,& + & 9.173200E-03,1.852040E-03,1.406150E-03,1.324590E-03,2.080047E-03,& + & 1.902038E-03,4.214760E-04,5.555993E-04,8.082160E-04,1.187960E-03,& + & 2.205430E-03,5.520050E-03,5.845270E-03,1.684250E-03,1.336450E-03,& + & 1.344940E-03,2.064709E-03,1.899023E-03,7.659322E-04,3.832093E-04,& + & 7.612600E-04,1.295490E-03,3.000780E-03,5.919150E-03,2.273400E-03,& + & 1.550390E-03,1.263850E-03,1.385510E-03,2.058788E-03,1.900487E-03,& + & 1.467533E-03,1.834240E-03,7.421030E-04,2.004690E-04,6.307260E-04,& + & 1.571130E-03,1.759630E-03,1.356430E-03,1.116220E-03,1.506320E-03,& + & 2.071116E-03,1.899142E-03,2.372988E-04,2.973207E-04,6.445020E-04,& + & 1.163420E-03,2.193620E-03,5.393160E-03,9.517320E-03,1.800410E-03,& + & 1.313310E-03,1.387690E-03,2.088136E-03,1.902038E-03 / + data ka_mco2(:,:,19) / 3.599558E-04,& + & 6.330069E-04,8.918460E-04,1.148810E-03,1.633100E-03,2.675800E-03,& + & 7.522190E-03,2.188260E-02,2.658090E-02,2.995300E-02,3.028247E-02,& + & 3.282737E-02,3.726018E-04,6.383580E-04,8.925850E-04,1.135320E-03,& + & 1.669010E-03,3.014460E-03,8.798180E-03,2.342980E-02,2.711100E-02,& + & 2.665500E-02,1.302006E-02,2.200865E-03,3.819734E-04,6.575236E-04,& + & 9.400200E-04,1.145080E-03,1.796080E-03,3.406470E-03,1.082940E-02,& + & 2.094860E-02,1.802360E-02,9.475050E-03,2.553286E-03,2.195702E-03,& + & 3.999519E-04,6.715154E-04,9.615330E-04,1.208740E-03,1.960610E-03,& + & 3.977140E-03,1.258650E-02,8.749630E-03,1.789240E-03,1.685720E-03,& + & 2.479007E-03,2.192844E-03,4.263123E-04,6.828597E-04,9.694770E-04,& + & 1.276760E-03,2.208770E-03,4.942240E-03,1.095980E-02,2.197860E-03,& + & 1.704780E-03,1.570440E-03,2.444379E-03,2.194686E-03,4.997856E-04,& + & 6.678941E-04,9.752920E-04,1.420100E-03,2.631220E-03,6.579580E-03,& + & 6.978670E-03,1.997800E-03,1.615610E-03,1.594590E-03,2.426117E-03,& + & 2.191108E-03,9.010139E-04,4.666229E-04,9.147620E-04,1.556870E-03,& + & 3.588490E-03,7.075540E-03,2.715650E-03,1.840050E-03,1.524000E-03,& + & 1.642410E-03,2.419135E-03,2.192844E-03,1.727872E-03,2.201684E-03,& + & 8.870200E-04,2.509850E-04,7.852190E-04,1.917610E-03,2.101070E-03,& + & 1.616660E-03,1.339680E-03,1.784340E-03,2.433951E-03,2.191269E-03,& + & 2.835844E-04,3.595770E-04,7.724950E-04,1.388490E-03,2.608150E-03,& + & 6.422530E-03,1.138470E-02,2.130290E-03,1.583420E-03,1.644540E-03,& + & 2.453564E-03,2.194686E-03 / + + + data kb_mco2(:, :) / & + & 5.905905E-06,1.415094E-05,3.721420E-05,7.741310E-05,1.322940E-04,& + & 3.598680E-05,5.095430E-05,2.082530E-05,2.089530E-05,2.652950E-05,& + & 3.665110E-05,7.826412E-06,7.676582E-06,1.832788E-05,4.786030E-05,& + & 9.988760E-05,1.709770E-04,4.636110E-05,6.605100E-05,2.649000E-05,& + & 2.655430E-05,3.363180E-05,4.661594E-05,1.123519E-05,9.978265E-06,& + & 2.373788E-05,6.155200E-05,1.288870E-04,2.209730E-04,5.972610E-05,& + & 8.562050E-05,3.369540E-05,3.374590E-05,4.263560E-05,5.929274E-05,& + & 1.614231E-05,1.297007E-05,3.074499E-05,7.916050E-05,1.663050E-04,& + & 2.855870E-04,7.694390E-05,1.109880E-04,4.286090E-05,4.288520E-05,& + & 5.404980E-05,7.542022E-05,2.320954E-05,1.685899E-05,3.982073E-05,& + & 1.018060E-04,2.145870E-04,3.690950E-04,9.912530E-05,1.438720E-04,& + & 5.451940E-05,5.449960E-05,6.851980E-05,9.593848E-05,3.339222E-05,& + & 2.191420E-05,5.157579E-05,1.309310E-04,2.768860E-04,4.770220E-04,& + & 1.277010E-04,1.864980E-04,6.934910E-05,6.925950E-05,8.686360E-05,& + & 1.220448E-04,4.806897E-05,2.848534E-05,6.680139E-05,1.683870E-04,& + & 3.572720E-04,6.165070E-04,1.645150E-04,2.417530E-04,8.821250E-05,& + & 8.801690E-05,1.101180E-04,1.552611E-04,6.922983E-05,3.702711E-05,& + & 8.652199E-05,2.165580E-04,4.609940E-04,7.967790E-04,2.119410E-04,& + & 3.133800E-04,1.122070E-04,1.118540E-04,1.395990E-04,1.975274E-04,& + & 9.974769E-05,4.813063E-05,1.120656E-04,2.785100E-04,5.948310E-04,& + & 1.029760E-03,2.730400E-04,4.062280E-04,1.427280E-04,1.421470E-04,& + & 1.769720E-04,2.513102E-04,1.437714E-04,6.256410E-05,1.451508E-04,& + & 3.581850E-04,7.675210E-04,1.330880E-03,3.517520E-04,5.265850E-04,& + & 1.815510E-04,1.806440E-04,2.243500E-04,3.197520E-04,2.072893E-04,& + & 8.132615E-05,1.880046E-04,4.606530E-04,9.903480E-04,1.720040E-03,& + & 4.531550E-04,6.826010E-04,2.309350E-04,2.295680E-04,2.844120E-04,& + & 4.068512E-04,2.989520E-04,1.057162E-04,2.435126E-04,5.924350E-04,& + & 1.277870E-03,2.222990E-03,5.837900E-04,8.848420E-04,2.937510E-04,& + & 2.917410E-04,3.605530E-04,5.176998E-04,4.312490E-04,1.374206E-04,& + & 3.154102E-04,7.619150E-04,1.648860E-03,2.873010E-03,7.520850E-04,& + & 1.147000E-03,3.736530E-04,3.707520E-04,4.570790E-04,6.587784E-04,& + & 6.222181E-04,1.786348E-04,4.085384E-04,9.798810E-04,2.127550E-03,& + & 3.713100E-03,9.688970E-04,1.486840E-03,4.752900E-04,4.711610E-04,& + & 5.794460E-04,8.383400E-04,8.979167E-04,2.322113E-04,5.291663E-04,& + & 1.260200E-03,2.745220E-03,4.798840E-03,1.248210E-03,1.927350E-03,& + & 6.045720E-04,5.987640E-04,7.345720E-04,1.066894E-03,1.295961E-03,& + & 3.018586E-04,6.854163E-04,1.620710E-03,3.542210E-03,6.202070E-03,& + & 1.608040E-03,2.498390E-03,7.690210E-04,7.609250E-04,9.312300E-04,& + & 1.357821E-03,1.870718E-03,3.923973E-04,8.878112E-04,2.084360E-03,& + & 4.570590E-03,8.015610E-03,2.071610E-03,3.238610E-03,9.782010E-04,& + & 9.670050E-04,1.180530E-03,1.728152E-03,2.700692E-03,5.100937E-04,& + & 1.149969E-03,2.680640E-03,5.897520E-03,1.035940E-02,2.668820E-03,& + & 4.198140E-03,1.244280E-03,1.228890E-03,1.496580E-03,2.199588E-03,& + & 3.899263E-03,6.630970E-04,1.489553E-03,3.447510E-03,7.609680E-03,& + & 1.338860E-02,3.438180E-03,5.441960E-03,1.582730E-03,1.561710E-03,& + & 1.897240E-03,2.799757E-03,5.630248E-03 / + + + data selfref(:, :) / & + & 4.779220E-02,4.154768E-02,3.945120E-02,3.905670E-02,3.853970E-02,& + & 3.796920E-02,3.688190E-02,3.651570E-02,3.599170E-02,3.669630E-02,& + & 3.721956E-02,3.512640E-02,4.038328E-02,3.633484E-02,3.462320E-02,& + & 3.406940E-02,3.364620E-02,3.313600E-02,3.228270E-02,3.201210E-02,& + & 3.167270E-02,3.204830E-02,3.230322E-02,3.050810E-02,3.414333E-02,& + & 3.177666E-02,3.038600E-02,2.971900E-02,2.937400E-02,2.891800E-02,& + & 2.825700E-02,2.806400E-02,2.787200E-02,2.798900E-02,2.803670E-02,& + & 2.649700E-02,2.888489E-02,2.779086E-02,2.666740E-02,2.592410E-02,& + & 2.564430E-02,2.523690E-02,2.473330E-02,2.460280E-02,2.452740E-02,& + & 2.444390E-02,2.433406E-02,2.301330E-02,2.445097E-02,2.430544E-02,& + & 2.340380E-02,2.261380E-02,2.238810E-02,2.202450E-02,2.164900E-02,& + & 2.156850E-02,2.158410E-02,2.134780E-02,2.112070E-02,1.998760E-02,& + & 2.071010E-02,2.125757E-02,2.053970E-02,1.972610E-02,1.954540E-02,& + & 1.922090E-02,1.894940E-02,1.890840E-02,1.899400E-02,1.864380E-02,& + & 1.833201E-02,1.735970E-02,1.755209E-02,1.859229E-02,1.802600E-02,& + & 1.720720E-02,1.706360E-02,1.677420E-02,1.658630E-02,1.657640E-02,& + & 1.671480E-02,1.628240E-02,1.591175E-02,1.507730E-02,1.488458E-02,& + & 1.626147E-02,1.582000E-02,1.501000E-02,1.489700E-02,1.463900E-02,& + & 1.451800E-02,1.453200E-02,1.470900E-02,1.422000E-02,1.381117E-02,& + & 1.309500E-02,1.262999E-02,1.422313E-02,1.388390E-02,1.309330E-02,& + & 1.300550E-02,1.277560E-02,1.270760E-02,1.273970E-02,1.294390E-02,& + & 1.241890E-02,1.198813E-02,1.137330E-02,1.072332E-02,1.244052E-02,& + & 1.218480E-02,1.142140E-02,1.135410E-02,1.114930E-02,1.112290E-02,& + & 1.116850E-02,1.139070E-02,1.084590E-02,1.040582E-02,9.878000E-03/ + +! --- the array forref contains the coefficient of the water vapor +! foreign-continuum (including the energy term). the first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. the second index +! runs over the g-channel (1 to NG07=12). + + data forref(:, :) / & + & 2.052186E-07,2.056568E-07,2.026700E-07,2.015400E-07,2.019000E-07,& + & 2.010300E-07,1.986900E-07,1.966300E-07,1.970100E-07,2.010300E-07,& + & 2.040210E-07,2.036400E-07,2.196356E-07,2.009562E-07,1.965000E-07,& + & 1.973800E-07,1.976700E-07,1.976900E-07,1.994000E-07,1.984600E-07,& + & 1.989800E-07,1.985300E-07,2.020117E-07,2.048200E-07,2.219473E-07,& + & 2.017466E-07,1.970600E-07,1.969800E-07,1.978100E-07,1.977400E-07,& + & 1.972400E-07,1.971400E-07,1.975100E-07,1.975800E-07,1.988981E-07,& + & 1.992471E-07,2.155266E-07,2.018612E-07,2.003400E-07,2.002100E-07,& + & 1.998700E-07,1.997800E-07,1.990200E-07,1.974200E-07,1.967200E-07,& + & 1.961500E-07,1.956199E-07,1.958825E-07 / + + + data fracrefa(:,:) / & + & 3.126100e-01,2.746600e-01,1.168400e-01,9.990000e-02,8.091200e-02,& + & 6.020300e-02,4.014900e-02,4.336500e-03,3.584400e-03,2.801900e-03,& + & 3.420500e-03,5.761140e-04,3.131800e-01,2.742900e-01,1.169100e-01,& + & 9.975400e-02,8.095600e-02,5.991200e-02,4.027100e-02,4.329800e-03,& + & 3.562600e-03,2.842100e-03,3.439100e-03,5.585500e-04,3.131700e-01,& + & 2.742400e-01,1.168400e-01,9.970100e-02,8.095600e-02,5.988400e-02,& + & 4.024500e-02,4.383700e-03,3.668300e-03,2.925000e-03,3.428900e-03,& + & 5.585500e-04,3.127900e-01,2.743500e-01,1.168700e-01,9.961900e-02,& + & 8.094700e-02,5.989900e-02,4.041600e-02,4.438900e-03,3.728000e-03,& + & 2.954800e-03,3.428200e-03,5.585500e-04,3.113900e-01,2.751100e-01,& + & 1.169500e-01,9.982300e-02,8.075000e-02,6.010000e-02,4.074100e-02,& + & 4.459800e-03,3.736600e-03,2.952100e-03,3.427700e-03,5.585500e-04,& + & 3.073200e-01,2.774800e-01,1.172900e-01,1.003100e-01,8.090800e-02,& + & 6.046000e-02,4.110000e-02,4.457800e-03,3.738800e-03,2.950800e-03,& + & 3.427400e-03,5.585500e-04,2.895500e-01,2.856600e-01,1.221800e-01,& + & 1.022800e-01,8.213000e-02,6.154600e-02,4.152200e-02,4.457700e-03,& + & 3.742800e-03,2.947500e-03,3.427400e-03,5.585500e-04,2.822500e-01,& + & 2.725100e-01,1.232500e-01,1.091500e-01,9.028000e-02,6.555400e-02,& + & 4.185200e-02,4.470700e-03,3.757200e-03,2.936400e-03,3.427200e-03,& + & 5.585500e-04,2.978900e-01,2.829800e-01,1.199900e-01,1.004400e-01,& + & 8.192700e-02,6.098900e-02,4.066500e-02,4.448100e-03,3.736900e-03,& + & 2.948200e-03,3.425700e-03,5.585500e-04 / + + + data fracrefb(:) / 3.131500e-01,2.756000e-01,1.163400e-01,& + & 9.891400e-02,8.023600e-02,6.019700e-02,4.062400e-02,4.422500e-03,& + & 3.668800e-03,2.907400e-03,3.390100e-03,5.544640e-04 / + +!........................................! + end module module_radlw_kgb07 ! +!========================================! + + +!> This module sets up absorption coefficients for band 08: 1080-1180 +!! cm-1 (low - h2o; high - o3) +!========================================! + module module_radlw_kgb08 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG08 +! + implicit none +! + private +! +!> msa08=65 + integer, public :: MSA08 +!> msb08=235 + integer, public :: MSB08 +!> msf08=10 + integer, public :: MSF08 +!> mfr08=4 + integer, public :: MFR08 +!> mmc08=19 + integer, public :: MMC08 + parameter (MSA08=65, MSB08=235, MSF08=10, MFR08=4, MMC08=19) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG08=8). + real (kind=kind_phys), public :: forref(NG08,MFR08) + +!> the array absa(NG08,65) = ka(NG08,5,13) contains absorption coefs +!! at the NG08=8 g-intervals for a range of pressure levels > ~100mb, +!! temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature +!! of tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 1 to 13 and refers to the corresponding +!! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). +!! the third index, ig, goes from 1 to NG08=8, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG08,MSA08) + +!> the array absb(NG08,235) = kb(NG08,5,13:59) contains absorption coefs +!! at the NG08=8 chosen g-values for a range of pressure levels < ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG08=8, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG08,MSB08) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG08=8). + real (kind=kind_phys), public :: selfref(NG08,MSF08) + +!> planck fraction mapping level : p=473.4280 mb, t = 259.83 k + real (kind=kind_phys), public :: fracrefa(NG08) + +!> planck fraction mapping level : p=95.5835 mb, t= 215.7 k + real (kind=kind_phys), public :: fracrefb(NG08) + +!> minor gas mapping level:lower - o3, p = 317.348 mb, t = 240.77 k + real (kind=kind_phys), public :: ka_mo3(NG08,MMC08) + +!> minor gas mapping level:lower - co2, p = 1053.63 mb, t = 294.2 k + real (kind=kind_phys), public :: ka_mco2(NG08,MMC08) + +!> minor gas mapping level:upper - co2, p = 35.1632 mb, t = 223.28 k + real (kind=kind_phys), public :: kb_mco2(NG08,MMC08) + +!> minor gas mapping level:lower - cfc12 + real (kind=kind_phys), public :: cfc12(NG08) + +!> minor gas mapping level:lower - n2o, p = 706.2720 mb, t= 278.94 k + real (kind=kind_phys), public :: ka_mn2o(NG08,MMC08) + +!> minor gas mapping level:upper - n2o, p = 8.716e-2 mb, t = 226.03 k + real (kind=kind_phys), public :: kb_mn2o(NG08,MMC08) + +!> original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1 +!! and 1290-1335 cm-1 bands. + real (kind=kind_phys), public :: cfc22adj(NG08) + + data absa(:, 1:30) / & + & 1.958396E-05,3.183247E-05,1.147706E-04,7.165406E-04,4.596619E-03,& + & 1.500965E-02,4.932945E-02,1.051658E-01,1.958781E-05,4.539081E-05,& + & 1.530297E-04,9.218818E-04,6.039420E-03,1.945659E-02,6.252477E-02,& + & 1.341878E-01,2.197629E-05,6.129517E-05,1.957485E-04,1.154755E-03,& + & 7.749431E-03,2.463017E-02,7.716167E-02,1.665131E-01,2.707916E-05,& + & 7.814391E-05,2.448759E-04,1.415920E-03,9.705899E-03,3.074197E-02,& + & 9.306153E-02,2.018327E-01,3.378207E-05,9.732970E-05,3.018455E-04,& + & 1.705389E-03,1.189746E-02,3.792196E-02,1.099548E-01,2.396390E-01,& + & 1.312386E-05,2.486702E-05,8.736836E-05,5.455765E-04,4.047385E-03,& + & 1.315962E-02,4.700676E-02,1.151708E-01,1.428470E-05,3.513769E-05,& + & 1.169014E-04,7.092088E-04,5.361528E-03,1.748045E-02,6.027376E-02,& + & 1.486846E-01,1.738114E-05,4.662754E-05,1.513231E-04,8.965653E-04,& + & 6.919159E-03,2.267644E-02,7.504345E-02,1.863073E-01,2.197906E-05,& + & 5.954290E-05,1.919958E-04,1.108020E-03,8.701905E-03,2.899684E-02,& + & 9.116183E-02,2.275763E-01,2.774622E-05,7.430299E-05,2.405568E-04,& + & 1.344032E-03,1.070073E-02,3.637050E-02,1.087296E-01,2.720342E-01,& + & 8.220369E-06,2.041023E-05,6.530733E-05,3.790970E-04,3.279614E-03,& + & 1.106845E-02,4.125362E-02,1.177557E-01,1.042537E-05,2.783975E-05,& + & 8.617971E-05,5.049024E-04,4.420825E-03,1.507341E-02,5.388283E-02,& + & 1.549454E-01,1.359174E-05,3.638099E-05,1.119854E-04,6.506656E-04,& + & 5.781509E-03,2.004554E-02,6.818503E-02,1.971455E-01,1.772123E-05,& + & 4.605542E-05,1.440657E-04,8.164649E-04,7.336612E-03,2.609911E-02,& + & 8.432134E-02,2.439801E-01,2.272419E-05,5.735541E-05,1.835624E-04,& + & 1.002592E-03,9.082836E-03,3.330838E-02,1.022337E-01,2.948138E-01,& + & 6.516222E-06,1.577621E-05,5.381666E-05,2.467526E-04,2.543719E-03,& + & 9.253564E-03,3.447609E-02,1.150060E-01,8.598137E-06,2.166465E-05,& + & 7.100008E-05,3.385085E-04,3.500237E-03,1.287859E-02,4.619176E-02,& + & 1.547029E-01,1.146016E-05,2.856493E-05,9.192515E-05,4.475220E-04,& + & 4.649609E-03,1.742452E-02,5.988562E-02,2.005519E-01,1.495142E-05,& + & 3.728740E-05,1.152467E-04,5.805231E-04,5.975333E-03,2.297514E-02,& + & 7.566397E-02,2.519839E-01,1.926548E-05,4.788722E-05,1.422604E-04,& + & 7.375964E-04,7.464315E-03,2.967589E-02,9.347730E-02,3.084027E-01,& + & 5.901598E-06,1.306216E-05,4.388300E-05,1.869214E-04,1.821381E-03,& + & 7.727639E-03,2.811502E-02,1.092965E-01,8.024324E-06,1.775354E-05,& + & 5.820900E-05,2.394025E-04,2.646247E-03,1.096022E-02,3.879815E-02,& + & 1.506686E-01,1.047252E-05,2.416660E-05,7.510432E-05,3.211108E-04,& + & 3.601109E-03,1.498761E-02,5.173074E-02,1.992060E-01,1.339403E-05,& + & 3.169363E-05,9.550224E-05,4.297862E-04,4.688646E-03,1.999476E-02,& + & 6.695345E-02,2.544048E-01,1.704689E-05,4.086790E-05,1.185405E-04,& + & 5.643751E-04,5.905412E-03,2.618130E-02,8.441747E-02,3.156223E-01,& + & 5.492619E-06,1.233815E-05,3.252608E-05,1.737548E-04,1.144125E-03,& + & 6.327961E-03,2.213330E-02,9.995311E-02,7.634172E-06,1.651015E-05,& + & 4.368461E-05,2.260438E-04,1.745126E-03,9.163753E-03,3.164094E-02,& + & 1.417245E-01,1.035634E-05,2.121510E-05,5.801303E-05,2.908054E-04,& + & 2.497849E-03,1.272804E-02,4.351092E-02,1.916951E-01,1.324472E-05,& + & 2.728347E-05,7.582391E-05,3.676457E-04,3.401597E-03,1.722825E-02,& + & 5.778393E-02,2.494587E-01,1.666241E-05,3.561607E-05,9.799733E-05,& + & 4.550869E-04,4.449476E-03,2.281235E-02,7.452756E-02,3.141958E-01/ + data absa(:,31:65) / & + & 5.791784E-06,1.167263E-05,2.951983E-05,1.651697E-04,8.748022E-04,& + & 3.167021E-03,1.717266E-02,8.881648E-02,7.980167E-06,1.618323E-05,& + & 3.858676E-05,2.103041E-04,1.116097E-03,6.939103E-03,2.542603E-02,& + & 1.298960E-01,1.047000E-05,2.168716E-05,4.922153E-05,2.727548E-04,& + & 1.602482E-03,1.048954E-02,3.603547E-02,1.801611E-01,1.355789E-05,& + & 2.797714E-05,6.373405E-05,3.451783E-04,2.337767E-03,1.404968E-02,& + & 4.920337E-02,2.391995E-01,1.727381E-05,3.558200E-05,8.272054E-05,& + & 4.273752E-04,3.237111E-03,1.835290E-02,6.496404E-02,3.066865E-01,& + & 6.022697E-06,1.469022E-05,3.414864E-05,1.702941E-04,9.717457E-04,& + & 1.002647E-03,7.691171E-03,7.695259E-02,8.680022E-06,1.919093E-05,& + & 4.356862E-05,2.238740E-04,1.252383E-03,2.897595E-03,1.464582E-02,& + & 1.164228E-01,1.171751E-05,2.532717E-05,5.470007E-05,2.740036E-04,& + & 1.644344E-03,3.182236E-03,2.856500E-02,1.658647E-01,1.546011E-05,& + & 3.129223E-05,7.034292E-05,3.357406E-04,2.092990E-03,7.295650E-03,& + & 3.972281E-02,2.259764E-01,1.997073E-05,3.996377E-05,8.665518E-05,& + & 4.154309E-04,2.551557E-03,1.394453E-02,5.130177E-02,2.969300E-01,& + & 1.023068E-05,2.837612E-05,6.858556E-05,2.241063E-04,6.698225E-04,& + & 1.286054E-03,2.137562E-03,3.105430E-02,1.387371E-05,3.763441E-05,& + & 8.958726E-05,2.938529E-04,1.047720E-03,2.593780E-03,2.021037E-03,& + & 7.828823E-02,1.906267E-05,4.551955E-05,1.067139E-04,3.926764E-04,& + & 1.594331E-03,2.711582E-03,5.976427E-03,1.360901E-01,2.578179E-05,& + & 5.229802E-05,1.339812E-04,4.958549E-04,2.430018E-03,2.832105E-03,& + & 1.037869E-02,2.082780E-01,3.325591E-05,6.480800E-05,1.593324E-04,& + & 5.930269E-04,3.334440E-03,5.179847E-03,2.173596E-02,2.551453E-01,& + & 2.247473E-05,5.848638E-05,1.018020E-04,2.070562E-04,4.726614E-04,& + & 2.404552E-05,2.323989E-05,7.830795E-06,2.999474E-05,8.107596E-05,& + & 1.402494E-04,3.062547E-04,1.134255E-03,3.786421E-05,3.651864E-05,& + & 7.409824E-06,3.817573E-05,1.035147E-04,1.996396E-04,4.176889E-04,& + & 1.507881E-03,4.438231E-03,5.467451E-05,7.239831E-06,4.655295E-05,& + & 1.269769E-04,2.581522E-04,6.296704E-04,1.904709E-03,7.572095E-03,& + & 5.201903E-03,5.693050E-06,5.176430E-05,1.533694E-04,3.518356E-04,& + & 8.925214E-04,2.505665E-03,6.036056E-03,2.010247E-02,4.434105E-06,& + & 3.156392E-05,6.367089E-05,1.246860E-04,2.836208E-04,3.607985E-05,& + & 1.591609E-05,1.972067E-05,6.738563E-06,4.043885E-05,9.286799E-05,& + & 1.763488E-04,3.480681E-04,6.951472E-04,2.569345E-05,3.028334E-05,& + & 6.934120E-06,4.965094E-05,1.293750E-04,2.334686E-04,5.158671E-04,& + & 1.452592E-03,3.642545E-05,4.642008E-05,6.634615E-06,6.270285E-05,& + & 1.670549E-04,3.308644E-04,5.829666E-04,2.851352E-03,4.827347E-05,& + & 6.053183E-05,6.961500E-06,7.736804E-05,1.943527E-04,4.113128E-04,& + & 8.623499E-04,2.921710E-03,9.657949E-03,6.763841E-05,4.334271E-06,& + & 3.312199E-05,6.550862E-05,1.333648E-04,2.588148E-04,5.290710E-05,& + & 1.216148E-05,1.478712E-05,5.421023E-06,4.429797E-05,9.318716E-05,& + & 1.877304E-04,4.059445E-04,4.381540E-04,1.891671E-05,2.297739E-05,& + & 6.135412E-06,5.553526E-05,1.198469E-04,2.547179E-04,5.564153E-04,& + & 1.248219E-03,2.726511E-05,3.431733E-05,6.800004E-06,6.573356E-05,& + & 1.626401E-04,3.558154E-04,7.122331E-04,2.344134E-03,3.581771E-05,& + & 4.703146E-05,6.595706E-06,7.915521E-05,1.958197E-04,4.765472E-04,& + & 8.448034E-04,3.433637E-03,4.293758E-03,5.487858E-05,4.276192E-06,& + & 3.114132E-05,6.261282E-05,1.338075E-04,2.655150E-04,6.070294E-05,& + & 9.213448E-06,9.740101E-06,7.074244E-06,4.241768E-05,9.128375E-05,& + & 1.834008E-04,4.420967E-04,3.711359E-04,1.412635E-05,1.507907E-05,& + & 1.180417E-05,5.352909E-05,1.099729E-04,2.643579E-04,5.728503E-04,& + & 1.224756E-03,2.004100E-05,2.189221E-05,1.999228E-05,6.543450E-05,& + & 1.434427E-04,3.683164E-04,7.949632E-04,2.146065E-03,2.833108E-05,& + & 2.760798E-05,3.023029E-05,7.487870E-05,1.748729E-04,4.853462E-04,& + & 9.349150E-04,3.193713E-03,4.781391E-03,3.768639E-05,1.408527E-05/ + + + data absb(:, 1: 30) / & + & 2.970462E-02,8.096607E-02,2.128310E-01,6.115949E-01,1.399250E+00,& + & 2.139274E+00,2.704115E+00,4.131166E+00,3.114126E-02,8.412567E-02,& + & 2.164415E-01,6.239917E-01,1.423334E+00,2.250876E+00,2.785461E+00,& + & 5.221536E+00,3.268286E-02,8.694356E-02,2.204679E-01,6.358500E-01,& + & 1.449094E+00,2.305011E+00,2.820373E+00,6.227694E+00,3.420715E-02,& + & 8.987521E-02,2.245617E-01,6.456750E-01,1.488993E+00,2.308043E+00,& + & 2.888115E+00,6.062349E+00,3.565154E-02,9.315067E-02,2.300061E-01,& + & 6.523763E-01,1.531763E+00,2.349331E+00,3.223814E+00,2.991774E+00,& + & 2.323684E-02,6.708726E-02,1.889205E-01,5.830706E-01,1.472181E+00,& + & 2.463126E+00,4.656621E+00,9.215488E+00,2.443910E-02,6.969217E-02,& + & 1.925857E-01,5.945041E-01,1.506804E+00,2.545643E+00,4.856838E+00,& + & 9.587609E+00,2.572719E-02,7.257694E-02,1.958213E-01,6.054784E-01,& + & 1.538200E+00,2.581542E+00,5.053929E+00,9.900437E+00,2.705983E-02,& + & 7.535991E-02,1.991176E-01,6.154000E-01,1.575777E+00,2.608062E+00,& + & 5.092182E+00,1.017557E+01,2.830286E-02,7.841210E-02,2.029436E-01,& + & 6.239723E-01,1.611395E+00,2.647525E+00,5.420490E+00,7.985126E+00,& + & 1.829703E-02,5.650910E-02,1.660148E-01,5.533756E-01,1.548537E+00,& + & 3.038919E+00,6.264459E+00,1.102600E+01,1.939989E-02,5.853708E-02,& + & 1.699535E-01,5.639127E-01,1.587162E+00,3.139691E+00,6.427739E+00,& + & 1.143209E+01,2.051768E-02,6.087564E-02,1.734207E-01,5.737237E-01,& + & 1.618923E+00,3.225536E+00,6.589940E+00,1.178846E+01,2.159034E-02,& + & 6.353558E-02,1.764276E-01,5.829119E-01,1.660529E+00,3.273860E+00,& + & 6.593114E+00,1.209619E+01,2.256634E-02,6.652440E-02,1.797084E-01,& + & 5.914242E-01,1.694743E+00,3.428534E+00,6.451507E+00,1.182254E+01,& + & 1.490851E-02,4.776271E-02,1.460104E-01,5.240431E-01,1.656103E+00,& + & 3.625710E+00,6.948183E+00,1.312337E+01,1.586777E-02,4.961491E-02,& + & 1.498554E-01,5.332418E-01,1.699491E+00,3.715112E+00,7.130727E+00,& + & 1.357639E+01,1.681048E-02,5.176015E-02,1.532174E-01,5.424971E-01,& + & 1.737175E+00,3.774194E+00,7.302122E+00,1.397208E+01,1.767059E-02,& + & 5.426220E-02,1.564297E-01,5.508576E-01,1.779705E+00,3.797505E+00,& + & 7.369054E+00,1.431626E+01,1.843710E-02,5.705168E-02,1.599457E-01,& + & 5.579326E-01,1.819781E+00,3.901321E+00,7.215207E+00,1.460708E+01,& + & 1.228045E-02,4.048474E-02,1.280013E-01,4.923691E-01,1.776136E+00,& + & 3.975456E+00,7.658645E+00,1.553188E+01,1.308793E-02,4.221837E-02,& + & 1.315349E-01,5.011541E-01,1.819354E+00,4.074446E+00,7.855743E+00,& + & 1.602980E+01,1.383832E-02,4.421791E-02,1.348903E-01,5.093628E-01,& + & 1.858336E+00,4.143859E+00,8.038302E+00,1.646644E+01,1.451624E-02,& + & 4.652776E-02,1.381454E-01,5.166760E-01,1.898952E+00,4.184378E+00,& + & 8.147588E+00,1.683506E+01,1.510893E-02,4.899082E-02,1.418694E-01,& + & 5.229775E-01,1.937578E+00,4.291366E+00,8.047415E+00,1.714760E+01,& + & 1.017705E-02,3.428600E-02,1.117389E-01,4.590933E-01,1.872316E+00,& + & 4.367281E+00,8.372476E+00,1.826417E+01,1.082960E-02,3.594308E-02,& + & 1.150622E-01,4.673813E-01,1.914620E+00,4.479220E+00,8.585702E+00,& + & 1.879938E+01,1.142113E-02,3.783320E-02,1.182713E-01,4.752265E-01,& + & 1.952045E+00,4.564758E+00,8.783047E+00,1.926243E+01,1.195453E-02,& + & 3.987958E-02,1.216021E-01,4.817712E-01,1.990464E+00,4.629930E+00,& + & 8.915568E+00,1.965340E+01,1.239875E-02,4.194354E-02,1.255039E-01,& + & 4.878981E-01,2.027159E+00,4.738749E+00,8.862872E+00,1.995942E+01/ + data absb(:, 31: 60) / & + & 8.408642E-03,2.900932E-02,9.699050E-02,4.239187E-01,1.946399E+00,& + & 4.804982E+00,9.116461E+00,2.130547E+01,8.935819E-03,3.056264E-02,& + & 1.000468E-01,4.318001E-01,1.987976E+00,4.929049E+00,9.344078E+00,& + & 2.187065E+01,9.403616E-03,3.224556E-02,1.032045E-01,4.391800E-01,& + & 2.024256E+00,5.029692E+00,9.558469E+00,2.234588E+01,9.807269E-03,& + & 3.395360E-02,1.067072E-01,4.456764E-01,2.060600E+00,5.099969E+00,& + & 9.723771E+00,2.272919E+01,1.014464E-02,3.557139E-02,1.108219E-01,& + & 4.518183E-01,2.095120E+00,5.190958E+00,9.754040E+00,2.300157E+01,& + & 6.980816E-03,2.458397E-02,8.381487E-02,3.887866E-01,1.995588E+00,& + & 5.263420E+00,9.932101E+00,2.463996E+01,7.397531E-03,2.597195E-02,& + & 8.670726E-02,3.966820E-01,2.035770E+00,5.396088E+00,1.017312E+01,& + & 2.521748E+01,7.760838E-03,2.739745E-02,8.993160E-02,4.037892E-01,& + & 2.070870E+00,5.507084E+00,1.040224E+01,2.568407E+01,8.072218E-03,& + & 2.877382E-02,9.363297E-02,4.103303E-01,2.107218E+00,5.571201E+00,& + & 1.059165E+01,2.601272E+01,8.335055E-03,3.001602E-02,9.778969E-02,& + & 4.170686E-01,2.139494E+00,5.664532E+00,1.064715E+01,2.625044E+01,& + & 5.788216E-03,2.078197E-02,7.212467E-02,3.538560E-01,2.022712E+00,& + & 5.725198E+00,1.082495E+01,2.821121E+01,6.115942E-03,2.197507E-02,& + & 7.495385E-02,3.618906E-01,2.061566E+00,5.862402E+00,1.107786E+01,& + & 2.877739E+01,6.398688E-03,2.312666E-02,7.825086E-02,3.689256E-01,& + & 2.096945E+00,5.975158E+00,1.132009E+01,2.917510E+01,6.640889E-03,& + & 2.419261E-02,8.203241E-02,3.759334E-01,2.132564E+00,6.038414E+00,& + & 1.151879E+01,2.945420E+01,6.846587E-03,2.510758E-02,8.602986E-02,& + & 3.836012E-01,2.164020E+00,6.131552E+00,1.158211E+01,2.963093E+01,& + & 4.808951E-03,1.756662E-02,6.203839E-02,3.203989E-01,2.031076E+00,& + & 6.199314E+00,1.180022E+01,3.198992E+01,5.061368E-03,1.853579E-02,& + & 6.491329E-02,3.283227E-01,2.070386E+00,6.332595E+00,1.206589E+01,& + & 3.246416E+01,5.281280E-03,1.944043E-02,6.824989E-02,3.357859E-01,& + & 2.105572E+00,6.440134E+00,1.231071E+01,3.278643E+01,5.469856E-03,& + & 2.022934E-02,7.182791E-02,3.437626E-01,2.142427E+00,6.493306E+00,& + & 1.250060E+01,3.298521E+01,5.629299E-03,2.089782E-02,7.544564E-02,& + & 3.525110E-01,2.174182E+00,6.597438E+00,1.253335E+01,3.307653E+01,& + & 3.983454E-03,1.478289E-02,5.333572E-02,2.886133E-01,2.020394E+00,& + & 6.666925E+00,1.283532E+01,3.581520E+01,4.179180E-03,1.554973E-02,& + & 5.621113E-02,2.966448E-01,2.060770E+00,6.794366E+00,1.310281E+01,& + & 3.618027E+01,4.354122E-03,1.623449E-02,5.936039E-02,3.048626E-01,& + & 2.097571E+00,6.890380E+00,1.333903E+01,3.641222E+01,4.500597E-03,& + & 1.680677E-02,6.256334E-02,3.139172E-01,2.137058E+00,6.932223E+00,& + & 1.350664E+01,3.651544E+01,4.626902E-03,1.730258E-02,6.569186E-02,& + & 3.238899E-01,2.170364E+00,7.044007E+00,1.349720E+01,3.649670E+01,& + & 3.289637E-03,1.237002E-02,4.588423E-02,2.587961E-01,1.995527E+00,& + & 7.119592E+00,1.389834E+01,3.964469E+01,3.444163E-03,1.296510E-02,& + & 4.856787E-02,2.672763E-01,2.038483E+00,7.234539E+00,1.415417E+01,& + & 3.990446E+01,3.581714E-03,1.346587E-02,5.134089E-02,2.764294E-01,& + & 2.079624E+00,7.310292E+00,1.436688E+01,4.001678E+01,3.698539E-03,& + & 1.389447E-02,5.410624E-02,2.864492E-01,2.121677E+00,7.348316E+00,& + & 1.450660E+01,3.999464E+01,3.797690E-03,1.427336E-02,5.671848E-02,& + & 2.976524E-01,2.157997E+00,7.456357E+00,1.445605E+01,3.983651E+01/ + data absb(:, 61: 90) / & + & 2.716525E-03,1.031615E-02,3.944872E-02,2.317662E-01,1.960591E+00,& + & 7.543547E+00,1.495420E+01,4.344116E+01,2.840897E-03,1.076099E-02,& + & 4.182129E-02,2.408088E-01,2.007498E+00,7.649265E+00,1.517769E+01,& + & 4.355930E+01,2.949067E-03,1.114087E-02,4.418252E-02,2.508043E-01,& + & 2.054586E+00,7.699941E+00,1.536301E+01,4.351700E+01,3.040694E-03,& + & 1.146772E-02,4.647408E-02,2.617896E-01,2.100082E+00,7.744339E+00,& + & 1.544524E+01,4.333076E+01,3.120243E-03,1.176147E-02,4.855097E-02,& + & 2.740461E-01,2.140956E+00,7.840147E+00,1.536183E+01,4.300201E+01,& + & 2.246085E-03,8.583601E-03,3.383964E-02,2.076936E-01,1.921209E+00,& + & 7.938361E+00,1.596762E+01,4.711226E+01,2.344649E-03,8.917029E-03,& + & 3.586902E-02,2.173429E-01,1.973545E+00,8.029986E+00,1.615632E+01,& + & 4.703243E+01,2.430552E-03,9.206220E-03,3.784186E-02,2.281105E-01,& + & 2.026916E+00,8.057140E+00,1.630514E+01,4.679710E+01,2.503722E-03,& + & 9.460130E-03,3.965779E-02,2.400693E-01,2.076289E+00,8.105647E+00,& + & 1.633081E+01,4.641947E+01,2.567466E-03,9.691525E-03,4.122548E-02,& + & 2.538219E-01,2.120483E+00,8.194968E+00,1.619759E+01,4.590911E+01,& + & 1.858039E-03,7.123492E-03,2.893692E-02,1.863599E-01,1.881508E+00,& + & 8.297391E+00,1.691504E+01,5.052839E+01,1.937060E-03,7.378013E-03,& + & 3.062823E-02,1.967113E-01,1.939911E+00,8.370413E+00,1.706246E+01,& + & 5.023375E+01,2.005132E-03,7.600788E-03,3.222802E-02,2.082379E-01,& + & 2.000358E+00,8.372309E+00,1.717121E+01,4.978976E+01,2.063149E-03,& + & 7.802244E-03,3.360791E-02,2.211888E-01,2.054286E+00,8.435476E+00,& + & 1.710864E+01,4.920632E+01,2.113598E-03,7.989056E-03,3.476966E-02,& + & 2.363376E-01,2.102215E+00,8.502384E+00,1.694424E+01,4.850249E+01,& + & 1.537191E-03,5.902118E-03,2.465422E-02,1.677715E-01,1.844180E+00,& + & 8.617959E+00,1.778350E+01,5.361491E+01,1.600348E-03,6.098371E-03,& + & 2.604157E-02,1.786691E-01,1.910947E+00,8.661624E+00,1.788408E+01,& + & 5.309508E+01,1.654060E-03,6.273483E-03,2.727450E-02,1.910178E-01,& + & 1.976416E+00,8.671634E+00,1.791273E+01,5.243571E+01,1.701056E-03,& + & 6.436989E-03,2.830742E-02,2.054363E-01,2.034025E+00,8.740081E+00,& + & 1.776213E+01,5.165493E+01,1.740438E-03,6.587837E-03,2.920649E-02,& + & 2.212908E-01,2.086367E+00,8.788988E+00,1.757343E+01,5.075921E+01,& + & 1.274832E-03,4.890405E-03,2.094977E-02,1.519931E-01,1.812858E+00,& + & 8.894609E+00,1.855708E+01,5.632648E+01,1.324402E-03,5.045496E-03,& + & 2.205550E-02,1.635778E-01,1.887316E+00,8.909630E+00,1.861037E+01,& + & 5.557888E+01,1.367702E-03,5.189566E-03,2.298447E-02,1.768234E-01,& + & 1.956992E+00,8.939353E+00,1.853726E+01,5.471523E+01,1.405434E-03,& + & 5.320192E-03,2.379492E-02,1.922083E-01,2.018687E+00,9.008561E+00,& + & 1.831441E+01,5.373718E+01,1.437450E-03,5.440895E-03,2.453448E-02,& + & 2.087097E-01,2.076669E+00,9.038795E+00,1.811661E+01,5.242659E+01,& + & 1.057126E-03,4.050996E-03,1.775164E-02,1.386141E-01,1.790227E+00,& + & 9.119996E+00,1.923303E+01,5.863821E+01,1.096754E-03,4.176987E-03,& + & 1.859377E-02,1.508713E-01,1.870813E+00,9.131530E+00,1.920894E+01,& + & 5.768145E+01,1.131728E-03,4.293938E-03,1.932275E-02,1.652762E-01,& + & 1.943295E+00,9.193019E+00,1.900894E+01,5.654552E+01,1.161870E-03,& + & 4.403134E-03,1.997852E-02,1.811683E-01,2.010279E+00,9.230548E+00,& + & 1.876890E+01,5.546533E+01,1.187734E-03,4.499888E-03,2.059356E-02,& + & 1.980926E-01,2.073776E+00,9.245540E+00,1.867671E+01,5.304849E+01/ + data absb(:, 91:120) / & + & 8.774826E-04,3.363455E-03,1.498521E-02,1.276433E-01,1.776584E+00,& + & 9.298159E+00,1.981008E+01,6.055450E+01,9.097143E-04,3.467055E-03,& + & 1.564480E-02,1.408314E-01,1.859784E+00,9.348519E+00,1.965389E+01,& + & 5.940611E+01,9.381296E-04,3.564844E-03,1.623431E-02,1.559474E-01,& + & 1.936957E+00,9.403708E+00,1.938508E+01,5.816552E+01,9.627594E-04,& + & 3.651881E-03,1.679582E-02,1.723532E-01,2.009968E+00,9.423291E+00,& + & 1.917796E+01,5.631083E+01,9.830832E-04,3.732861E-03,1.732699E-02,& + & 1.896996E-01,2.077422E+00,9.430057E+00,1.919288E+01,5.280829E+01,& + & 7.286033E-04,2.796562E-03,1.262338E-02,1.189009E-01,1.768888E+00,& + & 9.481311E+00,2.023449E+01,6.209790E+01,7.550349E-04,2.882791E-03,& + & 1.315665E-02,1.329522E-01,1.855911E+00,9.555220E+00,1.995473E+01,& + & 6.077584E+01,7.779948E-04,2.963187E-03,1.365363E-02,1.485786E-01,& + & 1.939398E+00,9.565690E+00,1.969888E+01,5.921794E+01,7.977501E-04,& + & 3.036447E-03,1.413476E-02,1.654758E-01,2.015073E+00,9.591185E+00,& + & 1.967221E+01,5.574567E+01,8.143367E-04,3.102822E-03,1.458298E-02,& + & 1.830463E-01,2.085721E+00,9.595815E+00,1.977083E+01,5.133788E+01,& + & 6.055382E-04,2.327666E-03,1.062815E-02,1.122443E-01,1.768031E+00,& + & 9.650883E+00,2.053001E+01,6.330975E+01,6.267415E-04,2.400053E-03,& + & 1.106665E-02,1.268184E-01,1.861583E+00,9.692021E+00,2.020556E+01,& + & 6.183519E+01,6.453697E-04,2.465594E-03,1.150412E-02,1.430545E-01,& + & 1.946866E+00,9.712036E+00,2.010965E+01,5.878368E+01,6.612695E-04,& + & 2.527515E-03,1.191135E-02,1.602781E-01,2.025138E+00,9.738597E+00,& + & 2.018402E+01,5.427085E+01,6.749698E-04,2.581784E-03,1.230616E-02,& + & 1.784048E-01,2.097200E+00,9.754207E+00,2.021549E+01,4.974867E+01,& + & 5.025257E-04,1.936060E-03,8.933128E-03,1.065545E-01,1.772896E+00,& + & 9.798533E+00,2.071236E+01,6.426830E+01,5.196964E-04,1.995217E-03,& + & 9.321557E-03,1.216816E-01,1.868046E+00,9.826463E+00,2.047817E+01,& + & 6.201694E+01,5.347080E-04,2.051790E-03,9.693234E-03,1.382982E-01,& + & 1.955249E+00,9.846348E+00,2.052527E+01,5.774175E+01,5.478579E-04,& + & 2.102847E-03,1.005103E-02,1.559437E-01,2.035533E+00,9.886258E+00,& + & 2.051841E+01,5.317237E+01,5.590197E-04,2.148047E-03,1.041982E-02,& + & 1.744037E-01,2.111461E+00,9.883861E+00,2.061203E+01,4.797046E+01,& + & 4.150565E-04,1.606194E-03,7.491990E-03,1.007529E-01,1.772290E+00,& + & 9.898860E+00,2.091734E+01,6.514064E+01,4.291874E-04,1.656694E-03,& + & 7.831468E-03,1.163294E-01,1.869362E+00,9.933808E+00,2.086300E+01,& + & 6.139934E+01,4.416635E-04,1.704698E-03,8.149194E-03,1.332546E-01,& + & 1.958388E+00,9.985880E+00,2.089960E+01,5.655862E+01,4.526046E-04,& + & 1.747496E-03,8.476342E-03,1.512260E-01,2.043389E+00,1.000149E+01,& + & 2.087363E+01,5.185312E+01,4.620065E-04,1.784628E-03,8.810825E-03,& + & 1.701230E-01,2.135758E+00,9.893765E+00,2.098601E+01,4.627555E+01,& + & 3.411312E-04,1.326881E-03,6.257407E-03,9.461303E-02,1.763615E+00,& + & 9.997413E+00,2.116706E+01,6.547457E+01,3.528467E-04,1.370948E-03,& + & 6.545334E-03,1.103926E-01,1.862552E+00,1.005578E+01,2.109809E+01,& + & 6.137242E+01,3.632659E-04,1.412096E-03,6.826142E-03,1.274666E-01,& + & 1.956742E+00,1.009038E+01,2.115360E+01,5.616393E+01,3.724968E-04,& + & 1.448267E-03,7.117815E-03,1.457303E-01,2.042398E+00,1.010230E+01,& + & 2.123929E+01,5.072924E+01,3.804755E-04,1.480415E-03,7.418628E-03,& + & 1.649819E-01,2.147370E+00,9.917454E+00,2.126473E+01,4.548435E+01/ + data absb(:,121:150) / & + & 2.795372E-04,1.093621E-03,5.216151E-03,8.709320E-02,1.740723E+00,& + & 1.006676E+01,2.140074E+01,6.632214E+01,2.894727E-04,1.131287E-03,& + & 5.465344E-03,1.027872E-01,1.843299E+00,1.014538E+01,2.137804E+01,& + & 6.156637E+01,2.984174E-04,1.166227E-03,5.713172E-03,1.198415E-01,& + & 1.941543E+00,1.017243E+01,2.143132E+01,5.624777E+01,3.062635E-04,& + & 1.197636E-03,5.974686E-03,1.381998E-01,2.032131E+00,1.016391E+01,& + & 2.149051E+01,5.090023E+01,3.131330E-04,1.226556E-03,6.236953E-03,& + & 1.576171E-01,2.142610E+00,9.966897E+00,2.160128E+01,4.491709E+01,& + & 2.290400E-04,9.016080E-04,4.358846E-03,8.032529E-02,1.718391E+00,& + & 1.013399E+01,2.165029E+01,6.670938E+01,2.375208E-04,9.335223E-04,& + & 4.574605E-03,9.589864E-02,1.825378E+00,1.021266E+01,2.160569E+01,& + & 6.189256E+01,2.451253E-04,9.638781E-04,4.793890E-03,1.129757E-01,& + & 1.925722E+00,1.024504E+01,2.168631E+01,5.628403E+01,2.518560E-04,& + & 9.915945E-04,5.028408E-03,1.313641E-01,2.027097E+00,1.019297E+01,& + & 2.176112E+01,5.060159E+01,2.580075E-04,1.017733E-03,5.261368E-03,& + & 1.509573E-01,2.137416E+00,1.000290E+01,2.187282E+01,4.459534E+01,& + & 1.877049E-04,7.442957E-04,3.655795E-03,7.440731E-02,1.697074E+00,& + & 1.021723E+01,2.180040E+01,6.713685E+01,1.949354E-04,7.713412E-04,& + & 3.845275E-03,8.983906E-02,1.808973E+00,1.027874E+01,2.186583E+01,& + & 6.162112E+01,2.013935E-04,7.976195E-04,4.041572E-03,1.068895E-01,& + & 1.911676E+00,1.030502E+01,2.189641E+01,5.631737E+01,2.073069E-04,& + & 8.221715E-04,4.245810E-03,1.253843E-01,2.022055E+00,1.021854E+01,& + & 2.201552E+01,5.013279E+01,2.127712E-04,8.454293E-04,4.455814E-03,& + & 1.452394E-01,2.133710E+00,1.004308E+01,2.207901E+01,4.419205E+01,& + & 1.529798E-04,6.111784E-04,3.049442E-03,6.761959E-02,1.664056E+00,& + & 1.025199E+01,2.198225E+01,6.809195E+01,1.592467E-04,6.343456E-04,& + & 3.216457E-03,8.268230E-02,1.779784E+00,1.031937E+01,2.202701E+01,& + & 6.262168E+01,1.647070E-04,6.571734E-04,3.388169E-03,9.948587E-02,& + & 1.885700E+00,1.035976E+01,2.206771E+01,5.709329E+01,1.697964E-04,& + & 6.784821E-04,3.564726E-03,1.178698E-01,1.998628E+00,1.027007E+01,& + & 2.218546E+01,5.094723E+01,1.745141E-04,6.991498E-04,3.747211E-03,& + & 1.377810E-01,2.113133E+00,1.010840E+01,2.223113E+01,4.489610E+01,& + & 1.245578E-04,5.015159E-04,2.542882E-03,6.131102E-02,1.629219E+00,& + & 1.027393E+01,2.213760E+01,6.916663E+01,1.298850E-04,5.216519E-04,& + & 2.693441E-03,7.591540E-02,1.748788E+00,1.034489E+01,2.218067E+01,& + & 6.367424E+01,1.345579E-04,5.415331E-04,2.845763E-03,9.242831E-02,& + & 1.857906E+00,1.040085E+01,2.221171E+01,5.804073E+01,1.389437E-04,& + & 5.603388E-04,3.001458E-03,1.107016E-01,1.972630E+00,1.032522E+01,& + & 2.235287E+01,5.168005E+01,1.430021E-04,5.779729E-04,3.162760E-03,& + & 1.304936E-01,2.090394E+00,1.016454E+01,2.237880E+01,4.567728E+01,& + & 1.013499E-04,4.117363E-04,2.123226E-03,5.558957E-02,1.594242E+00,& + & 1.028765E+01,2.230412E+01,7.003560E+01,1.058979E-04,4.292972E-04,& + & 2.256796E-03,6.971524E-02,1.717836E+00,1.037063E+01,2.230805E+01,& + & 6.464855E+01,1.098786E-04,4.464168E-04,2.393277E-03,8.591200E-02,& + & 1.830105E+00,1.043355E+01,2.234260E+01,5.892888E+01,1.136339E-04,& + & 4.628169E-04,2.537594E-03,1.040259E-01,1.947018E+00,1.036842E+01,& + & 2.248971E+01,5.246374E+01,1.171884E-04,4.779884E-04,2.680897E-03,& + & 1.236851E-01,2.067566E+00,1.021903E+01,2.252837E+01,4.626912E+01/ + data absb(:,151:180) / & + & 8.226910E-05,3.374501E-04,1.769995E-03,4.969770E-02,1.551214E+00,& + & 1.029776E+01,2.243497E+01,7.121158E+01,8.614184E-05,3.525979E-04,& + & 1.889249E-03,6.324205E-02,1.678491E+00,1.039635E+01,2.240261E+01,& + & 6.597451E+01,8.953217E-05,3.675755E-04,2.011851E-03,7.900941E-02,& + & 1.795412E+00,1.046059E+01,2.248494E+01,5.993860E+01,9.278416E-05,& + & 3.817554E-04,2.143821E-03,9.672814E-02,1.913661E+00,1.041120E+01,& + & 2.263094E+01,5.349975E+01,9.587183E-05,3.949240E-04,2.276546E-03,& + & 1.160872E-01,2.037960E+00,1.027422E+01,2.268561E+01,4.706610E+01,& + & 6.666107E-05,2.762217E-04,1.475027E-03,4.403508E-02,1.504396E+00,& + & 1.029283E+01,2.253980E+01,7.260928E+01,6.996973E-05,2.893395E-04,& + & 1.583786E-03,5.700414E-02,1.636339E+00,1.040613E+01,2.251997E+01,& + & 6.718377E+01,7.288822E-05,3.024210E-04,1.696302E-03,7.213627E-02,& + & 1.757380E+00,1.048022E+01,2.260019E+01,6.114276E+01,7.568300E-05,& + & 3.146541E-04,1.818091E-03,8.942065E-02,1.875326E+00,1.046320E+01,& + & 2.276438E+01,5.460441E+01,7.836990E-05,3.260496E-04,1.938627E-03,& + & 1.084618E-01,2.005692E+00,1.032385E+01,2.281989E+01,4.802701E+01,& + & 5.400296E-05,2.261967E-04,1.231604E-03,3.885887E-02,1.457337E+00,& + & 1.026880E+01,2.271335E+01,7.358564E+01,5.679150E-05,2.375650E-04,& + & 1.330846E-03,5.125335E-02,1.593182E+00,1.040259E+01,2.264670E+01,& + & 6.832744E+01,5.932196E-05,2.488548E-04,1.433306E-03,6.578056E-02,& + & 1.718540E+00,1.048834E+01,2.274331E+01,6.212200E+01,6.171767E-05,& + & 2.594296E-04,1.545242E-03,8.250922E-02,1.838219E+00,1.050345E+01,& + & 2.289793E+01,5.553924E+01,6.405263E-05,2.694573E-04,1.657399E-03,& + & 1.011761E-01,1.973083E+00,1.037070E+01,2.296912E+01,4.876428E+01,& + & 4.365049E-05,1.849793E-04,1.025543E-03,3.393248E-02,1.406061E+00,& + & 1.024045E+01,2.286556E+01,7.467342E+01,4.601904E-05,1.948363E-04,& + & 1.116187E-03,4.570978E-02,1.545436E+00,1.039336E+01,2.275119E+01,& + & 6.966251E+01,4.820632E-05,2.044378E-04,1.210809E-03,5.962612E-02,& + & 1.674774E+00,1.049653E+01,2.286009E+01,6.330890E+01,5.026075E-05,& + & 2.136597E-04,1.314323E-03,7.559561E-02,1.797428E+00,1.054909E+01,& + & 2.298370E+01,5.671117E+01,5.226802E-05,2.224274E-04,1.419428E-03,& + & 9.379729E-02,1.936246E+00,1.042027E+01,2.310775E+01,4.962608E+01,& + & 3.514868E-05,1.506926E-04,8.473573E-04,2.906461E-02,1.346801E+00,& + & 1.019348E+01,2.299592E+01,7.610121E+01,3.716804E-05,1.591315E-04,& + & 9.284767E-04,4.001594E-02,1.490195E+00,1.038207E+01,2.284093E+01,& + & 7.119167E+01,3.904828E-05,1.674031E-04,1.014810E-03,5.323055E-02,& + & 1.624669E+00,1.049559E+01,2.291079E+01,6.505995E+01,4.080322E-05,& + & 1.754405E-04,1.110159E-03,6.852540E-02,1.748232E+00,1.058265E+01,& + & 2.306863E+01,5.826365E+01,4.254671E-05,1.831345E-04,1.209310E-03,& + & 8.589294E-02,1.891163E+00,1.047076E+01,2.322588E+01,5.095948E+01,& + & 2.829043E-05,1.227169E-04,7.023985E-04,2.473385E-02,1.286732E+00,& + & 1.011924E+01,2.321208E+01,7.710668E+01,3.000691E-05,1.300368E-04,& + & 7.730579E-04,3.486260E-02,1.434584E+00,1.034181E+01,2.298463E+01,& + & 7.246628E+01,3.162390E-05,1.371737E-04,8.525471E-04,4.732756E-02,& + & 1.573184E+00,1.048482E+01,2.302309E+01,6.640106E+01,3.313013E-05,& + & 1.441821E-04,9.399117E-04,6.195940E-02,1.701142E+00,1.058946E+01,& + & 2.320384E+01,5.938831E+01,3.462909E-05,1.508233E-04,1.034341E-03,& + & 7.859076E-02,1.846442E+00,1.050442E+01,2.342225E+01,5.171255E+01/ + data absb(:,181:210) / & + & 2.277265E-05,1.000146E-04,5.837153E-04,2.098103E-02,1.225134E+00,& + & 1.003538E+01,2.341952E+01,7.807150E+01,2.422574E-05,1.062875E-04,& + & 6.478751E-04,3.022650E-02,1.377350E+00,1.029215E+01,2.312735E+01,& + & 7.370306E+01,2.561266E-05,1.124963E-04,7.175393E-04,4.190699E-02,& + & 1.520551E+00,1.047165E+01,2.316684E+01,6.740345E+01,2.690387E-05,& + & 1.185986E-04,7.985779E-04,5.586067E-02,1.652884E+00,1.059972E+01,& + & 2.331208E+01,6.048677E+01,2.820428E-05,1.243779E-04,8.890817E-04,& + & 7.189587E-02,1.801925E+00,1.053884E+01,2.364213E+01,5.202021E+01,& + & 1.832073E-05,8.133399E-05,4.823463E-04,1.786172E-02,1.165659E+00,& + & 9.919124E+00,2.366717E+01,7.895804E+01,1.954473E-05,8.668862E-05,& + & 5.402754E-04,2.624179E-02,1.321009E+00,1.024258E+01,2.320713E+01,& + & 7.519137E+01,2.071848E-05,9.202286E-05,6.035917E-04,3.708996E-02,& + & 1.468180E+00,1.044453E+01,2.326751E+01,6.875172E+01,2.182054E-05,& + & 9.723633E-05,6.741544E-04,5.033797E-02,1.605346E+00,1.058873E+01,& + & 2.341007E+01,6.178495E+01,2.292161E-05,1.022603E-04,7.570290E-04,& + & 6.581605E-02,1.755628E+00,1.056669E+01,2.373935E+01,5.322380E+01,& + & 1.472778E-05,6.605468E-05,3.975701E-04,1.521226E-02,1.106900E+00,& + & 9.809484E+00,2.387800E+01,7.982007E+01,1.574993E-05,7.058556E-05,& + & 4.482583E-04,2.270779E-02,1.265054E+00,1.016228E+01,2.334945E+01,& + & 7.650208E+01,1.674036E-05,7.512326E-05,5.053681E-04,3.273944E-02,& + & 1.416938E+00,1.040417E+01,2.333018E+01,7.027651E+01,1.767413E-05,& + & 7.958063E-05,5.688106E-04,4.518859E-02,1.558056E+00,1.057026E+01,& + & 2.345473E+01,6.336120E+01,1.860619E-05,8.390048E-05,6.428637E-04,& + & 5.998946E-02,1.708632E+00,1.058599E+01,2.377850E+01,5.482439E+01,& + & 1.184230E-05,5.364884E-05,3.279070E-04,1.297824E-02,1.047513E+00,& + & 9.683870E+00,2.408567E+01,8.067881E+01,1.269259E-05,5.748777E-05,& + & 3.730572E-04,1.970043E-02,1.207650E+00,1.009015E+01,2.344482E+01,& + & 7.785101E+01,1.352937E-05,6.135602E-05,4.234293E-04,2.885870E-02,& + & 1.363890E+00,1.034744E+01,2.339853E+01,7.182871E+01,1.431921E-05,& + & 6.514245E-05,4.810600E-04,4.054336E-02,1.508984E+00,1.054613E+01,& + & 2.351361E+01,6.481242E+01,1.510493E-05,6.884561E-05,5.485922E-04,& + & 5.470244E-02,1.660533E+00,1.059934E+01,2.391893E+01,5.574732E+01,& + & 9.529045E-06,4.357604E-05,2.702254E-04,1.112886E-02,9.873746E-01,& + & 9.538142E+00,2.430137E+01,8.152074E+01,1.023438E-05,4.685378E-05,& + & 3.107907E-04,1.714762E-02,1.149659E+00,9.998596E+00,2.360144E+01,& + & 7.883989E+01,1.094021E-05,5.012807E-05,3.562425E-04,2.550738E-02,& + & 1.309270E+00,1.029112E+01,2.351603E+01,7.295727E+01,1.161048E-05,& + & 5.337677E-05,4.085021E-04,3.637835E-02,1.458581E+00,1.051201E+01,& + & 2.363459E+01,6.587246E+01,1.227948E-05,5.654702E-05,4.711527E-04,& + & 4.983988E-02,1.612248E+00,1.060847E+01,2.404579E+01,5.658611E+01,& + & 7.639564E-06,3.519516E-05,2.197978E-04,9.394868E-03,9.314074E-01,& + & 9.395249E+00,2.450651E+01,8.229020E+01,8.226661E-06,3.793224E-05,& + & 2.543642E-04,1.478427E-02,1.095462E+00,9.868253E+00,2.376045E+01,& + & 8.012937E+01,8.807273E-06,4.068617E-05,2.938917E-04,2.239566E-02,& + & 1.256769E+00,1.021499E+01,2.352899E+01,7.489953E+01,9.365705E-06,& + & 4.338243E-05,3.397231E-04,3.245518E-02,1.409758E+00,1.046314E+01,& + & 2.364612E+01,6.776057E+01,9.920375E-06,4.608220E-05,3.938830E-04,& + & 4.513828E-02,1.559097E+00,1.062944E+01,2.400979E+01,5.879849E+01/ + data absb(:,211:235) / & + & 6.104546E-06,2.829568E-05,1.769778E-04,7.809993E-03,8.765582E-01,& + & 9.272325E+00,2.466867E+01,8.302878E+01,6.594200E-06,3.057415E-05,& + & 2.057376E-04,1.261155E-02,1.042389E+00,9.702070E+00,2.406754E+01,& + & 8.086601E+01,7.067427E-06,3.286844E-05,2.387811E-04,1.943265E-02,& + & 1.204232E+00,1.011846E+01,2.356269E+01,7.697796E+01,7.535190E-06,& + & 3.509986E-05,2.779344E-04,2.870408E-02,1.360420E+00,1.039299E+01,& + & 2.362863E+01,7.010067E+01,7.986570E-06,3.731383E-05,3.233621E-04,& + & 4.046037E-02,1.506700E+00,1.060866E+01,2.376966E+01,6.265074E+01,& + & 4.872535E-06,2.273123E-05,1.421967E-04,6.465159E-03,8.217962E-01,& + & 9.131450E+00,2.483294E+01,8.378074E+01,5.282056E-06,2.463530E-05,& + & 1.659313E-04,1.065204E-02,9.890830E-01,9.566746E+00,2.429399E+01,& + & 8.158899E+01,5.669756E-06,2.653446E-05,1.937191E-04,1.675886E-02,& + & 1.151797E+00,1.000939E+01,2.363629E+01,7.877820E+01,6.055993E-06,& + & 2.838787E-05,2.268662E-04,2.523985E-02,1.311202E+00,1.030238E+01,& + & 2.357523E+01,7.270982E+01,6.427516E-06,3.021005E-05,2.651609E-04,& + & 3.617056E-02,1.461107E+00,1.053392E+01,2.368665E+01,6.547161E+01,& + & 3.882319E-06,1.824310E-05,1.138339E-04,5.295725E-03,7.668928E-01,& + & 8.975955E+00,2.500151E+01,8.453052E+01,4.227013E-06,1.982843E-05,& + & 1.335603E-04,8.932827E-03,9.356878E-01,9.418476E+00,2.451578E+01,& + & 8.231205E+01,4.546303E-06,2.139859E-05,1.568486E-04,1.438523E-02,& + & 1.099877E+00,9.857112E+00,2.382749E+01,8.013649E+01,4.863272E-06,& + & 2.293968E-05,1.845128E-04,2.206506E-02,1.260015E+00,1.022767E+01,& + & 2.355446E+01,7.493784E+01,5.172574E-06,2.445065E-05,2.169010E-04,& + & 3.218988E-02,1.413460E+00,1.046878E+01,2.366298E+01,6.782980E+01,& + & 3.090524E-06,1.462349E-05,9.096467E-05,4.312314E-03,7.177845E-01,& + & 8.793102E+00,2.516074E+01,8.525484E+01,3.380832E-06,1.594584E-05,& + & 1.072939E-04,7.464630E-03,8.835691E-01,9.307585E+00,2.466494E+01,& + & 8.300405E+01,3.645276E-06,1.723994E-05,1.265880E-04,1.232236E-02,& + & 1.049565E+00,9.729897E+00,2.406670E+01,8.082148E+01,3.904256E-06,& + & 1.852511E-05,1.492998E-04,1.921601E-02,1.210706E+00,1.012663E+01,& + & 2.358430E+01,7.700849E+01,4.158926E-06,1.975663E-05,1.767333E-04,& + & 2.858438E-02,1.366816E+00,1.039792E+01,2.362494E+01,7.023896E+01,& + & 2.479081E-06,1.180565E-05,7.339134E-05,3.703495E-03,6.984686E-01,& + & 8.716060E+00,2.522688E+01,8.557618E+01,2.716600E-06,1.287119E-05,& + & 8.646968E-05,6.559069E-03,8.608480E-01,9.277341E+00,2.472896E+01,& + & 8.329127E+01,2.937153E-06,1.390742E-05,1.017366E-04,1.094437E-02,& + & 1.028095E+00,9.661533E+00,2.422856E+01,8.110597E+01,3.147211E-06,& + & 1.495343E-05,1.196128E-04,1.740747E-02,1.189273E+00,1.003993E+01,& + & 2.360267E+01,7.858685E+01,3.351616E-06,1.595156E-05,1.414304E-04,& + & 2.624448E-02,1.344139E+00,1.032495E+01,2.347676E+01,7.300692E+01/ + + + data selfref(:, :) / & + & 3.132587E-02,3.057763E-02,2.970334E-02,2.970046E-02,2.980793E-02,& + & 2.954107E-02,2.937950E-02,2.808840E-02,2.729922E-02,2.671487E-02,& + & 2.603760E-02,2.600795E-02,2.608164E-02,2.587638E-02,2.570511E-02,& + & 2.469870E-02,2.379041E-02,2.334007E-02,2.282422E-02,2.277454E-02,& + & 2.282112E-02,2.266630E-02,2.249030E-02,2.171800E-02,2.073274E-02,& + & 2.039162E-02,2.000740E-02,1.994307E-02,1.996822E-02,1.985441E-02,& + & 1.967754E-02,1.909700E-02,1.806816E-02,1.781566E-02,1.753827E-02,& + & 1.746369E-02,1.747199E-02,1.739137E-02,1.721658E-02,1.679240E-02,& + & 1.574619E-02,1.556515E-02,1.537380E-02,1.529250E-02,1.528779E-02,& + & 1.523394E-02,1.506339E-02,1.476590E-02,1.372276E-02,1.359888E-02,& + & 1.347648E-02,1.339128E-02,1.337668E-02,1.334408E-02,1.317960E-02,& + & 1.298390E-02,1.195942E-02,1.188104E-02,1.181331E-02,1.172644E-02,& + & 1.170447E-02,1.168870E-02,1.153132E-02,1.141700E-02,1.042277E-02,& + & 1.038018E-02,1.035540E-02,1.026856E-02,1.024128E-02,1.023865E-02,& + & 1.008919E-02,1.003920E-02,9.083609E-03,9.068971E-03,9.077405E-03,& + & 8.991937E-03,8.961042E-03,8.968509E-03,8.827454E-03,8.827650E-03/ + + data forref(:, :) / & + & 4.289624E-07,5.409865E-07,6.921023E-07,7.383056E-07,7.577604E-07,& + & 7.666801E-07,1.064651E-06,1.497600E-06,3.598600E-07,5.348426E-07,& + & 7.710439E-07,7.883167E-07,7.758902E-07,7.659813E-07,8.988420E-07,& + & 1.503288E-06,4.835866E-07,5.947177E-07,6.288479E-07,6.277707E-07,& + & 7.807491E-07,9.862459E-07,1.074420E-06,1.378222E-06,7.354748E-07,& + & 5.461910E-07,5.019355E-07,5.212515E-07,4.848762E-07,4.756050E-07,& + & 3.778721E-07,3.481208E-07 / + + data ka_mco2(:, :) / & + & 5.908838E-06,1.539459E-05,2.580637E-05,1.596999E-06,1.110965E-06,& + & 2.729112E-08,1.071680E-07,8.346070E-08,7.242242E-06,1.852355E-05,& + & 3.109992E-05,1.991453E-06,1.414342E-06,3.181888E-08,1.044161E-07,& + & 8.132360E-08,8.877629E-06,2.228855E-05,3.747945E-05,2.483743E-06,& + & 1.800647E-06,3.710200E-08,1.017353E-07,7.924130E-08,1.088365E-05,& + & 2.681906E-05,4.516779E-05,3.098248E-06,2.292574E-06,4.326720E-08,& + & 9.912315E-08,7.721220E-08,1.334464E-05,3.227068E-05,5.443332E-05,& + & 3.865433E-06,2.918994E-06,5.046249E-08,9.657854E-08,7.523510E-08,& + & 1.636423E-05,3.883077E-05,6.559974E-05,4.823392E-06,3.716707E-06,& + & 5.886109E-08,9.409838E-08,7.330870E-08,2.006976E-05,4.672479E-05,& + & 7.905701E-05,6.019766E-06,4.732542E-06,6.866537E-08,9.168275E-08,& + & 7.143150E-08,2.461791E-05,5.622398E-05,9.527503E-05,7.514144E-06,& + & 6.026187E-06,8.011186E-08,8.932864E-08,6.960250E-08,3.020104E-05,& + & 6.765487E-05,1.148211E-04,9.381062E-06,7.673608E-06,9.347719E-08,& + & 8.703508E-08,6.782020E-08,3.705592E-05,8.141031E-05,1.383762E-04,& + & 1.171379E-05,9.771579E-06,1.090851E-07,8.480044E-08,6.608370E-08,& + & 4.547373E-05,9.796345E-05,1.667656E-04,1.462901E-05,1.244335E-05,& + & 1.273130E-07,8.262317E-08,6.439150E-08,5.581238E-05,1.178828E-04,& + & 2.009790E-04,1.827280E-05,1.584587E-05,1.486048E-07,8.050183E-08,& + & 6.274270E-08,6.851330E-05,1.418536E-04,2.422118E-04,2.282806E-05,& + & 2.017909E-05,1.734768E-07,7.843488E-08,6.113610E-08,8.411827E-05,& + & 1.707003E-04,2.919051E-04,2.852361E-05,2.569750E-05,2.025353E-07,& + & 7.642103E-08,5.957070E-08,1.032958E-04,2.054142E-04,3.517947E-04,& + & 3.564616E-05,3.272533E-05,2.364886E-07,7.445890E-08,5.804530E-08,& + & 1.268688E-04,2.471897E-04,4.239735E-04,4.455465E-05,4.167551E-05,& + & 2.761661E-07,7.254716E-08,5.655900E-08,1.558496E-04,2.974634E-04,& + & 5.109614E-04,5.569878E-05,5.307393E-05,3.225377E-07,7.068451E-08,& + & 5.511080E-08,1.914869E-04,3.579641E-04,6.157994E-04,6.964173E-05,& + & 6.759026E-05,3.767398E-07,6.886968E-08,5.369960E-08,2.353193E-04,& + & 4.307728E-04,7.421494E-04,8.708927E-05,8.607747E-05,4.401012E-07,& + & 6.710143E-08,5.232460E-08 / + + + data kb_mco2(:, :) / & + & 8.075010E-08,4.884254E-07,1.783317E-06,7.812465E-06,3.159000E-05,& + & 4.860489E-05,1.083010E-07,7.419713E-09,1.142386E-07,7.054813E-07,& + & 2.566540E-06,1.091763E-05,4.409407E-05,6.683283E-05,1.432693E-07,& + & 7.174487E-09,1.616258E-07,1.019002E-06,3.693752E-06,1.525706E-05,& + & 6.154972E-05,9.189739E-05,1.899039E-07,6.937363E-09,2.286835E-07,& + & 1.471864E-06,5.316035E-06,2.132145E-05,8.591864E-05,1.263638E-04,& + & 2.520846E-07,6.708074E-09,3.235841E-07,2.125987E-06,7.650800E-06,& + & 2.979645E-05,1.199394E-04,1.737588E-04,3.349799E-07,6.486367E-09,& + & 4.578954E-07,3.070826E-06,1.101107E-05,4.164044E-05,1.674382E-04,& + & 2.389334E-04,4.454807E-07,6.271984E-09,6.479962E-07,4.435592E-06,& + & 1.584706E-05,5.819269E-05,2.337537E-04,3.285596E-04,5.927675E-07,& + & 6.064694E-09,9.170744E-07,6.406936E-06,2.280712E-05,8.132489E-05,& + & 3.263453E-04,4.518117E-04,7.890732E-07,5.864247E-09,1.297969E-06,& + & 9.254476E-06,3.282398E-05,1.136534E-04,4.556275E-04,6.213107E-04,& + & 1.050711E-06,5.670424E-09,1.837175E-06,1.336759E-05,4.724023E-05,& + & 1.588338E-04,6.361437E-04,8.544095E-04,1.399398E-06,5.483012E-09,& + & 2.600528E-06,1.930888E-05,6.798820E-05,2.219765E-04,8.882075E-04,& + & 1.174979E-03,1.864102E-06,5.301793E-09,3.681291E-06,2.789089E-05,& + & 9.784876E-05,3.102222E-04,1.240186E-03,1.615861E-03,2.483401E-06,& + & 5.126566E-09,5.211499E-06,4.028743E-05,1.408241E-04,4.335516E-04,& + & 1.731683E-03,2.222219E-03,3.308721E-06,4.957123E-09,7.378242E-06,& + & 5.819411E-05,2.026746E-04,6.059161E-04,2.418047E-03,3.056175E-03,& + & 4.408590E-06,4.793291E-09,1.044638E-05,8.406019E-05,2.916894E-04,& + & 8.468109E-04,3.376548E-03,4.203189E-03,5.874327E-06,4.634863E-09,& + & 1.479125E-05,1.214234E-04,4.198011E-04,1.183484E-03,4.715114E-03,& + & 5.780816E-03,7.827669E-06,4.481674E-09,2.094443E-05,1.753954E-04,& + & 6.041806E-04,1.654019E-03,6.584508E-03,7.950850E-03,1.043069E-05,& + & 4.333550E-09,2.965901E-05,2.533566E-04,8.695407E-04,2.311649E-03,& + & 9.195267E-03,1.093569E-02,1.389966E-05,4.190325E-09,4.200189E-05,& + & 3.659740E-04,1.251446E-03,3.230772E-03,1.284154E-02,1.504152E-02,& + & 1.852249E-05,4.051833E-09 / + + data ka_mo3(:, :) / & + & 1.506381E-01,2.581813E-01,3.580393E-01,3.869487E-01,2.099680E-01,& + & 2.414484E-01,2.305772E-01,2.568382E-02,1.507456E-01,2.599301E-01,& + & 3.624297E-01,3.921226E-01,2.127925E-01,2.428221E-01,2.344826E-01,& + & 2.748392E-02,1.508541E-01,2.616925E-01,3.668748E-01,3.973668E-01,& + & 2.156541E-01,2.442043E-01,2.384706E-01,2.941021E-02,1.509636E-01,& + & 2.634681E-01,3.713755E-01,4.026814E-01,2.185556E-01,2.455949E-01,& + & 2.425430E-01,3.147159E-02,1.510741E-01,2.652565E-01,3.759322E-01,& + & 4.080685E-01,2.214953E-01,2.469940E-01,2.467023E-01,3.367751E-02,& + & 1.511856E-01,2.670580E-01,3.805464E-01,4.135282E-01,2.244749E-01,& + & 2.484017E-01,2.509508E-01,3.603807E-02,1.512981E-01,2.688727E-01,& + & 3.852183E-01,4.190619E-01,2.274944E-01,2.498183E-01,2.552898E-01,& + & 3.856418E-02,1.514110E-01,2.707005E-01,3.899486E-01,4.246699E-01,& + & 2.305548E-01,2.512434E-01,2.597223E-01,4.126732E-02,1.515250E-01,& + & 2.725426E-01,3.947385E-01,4.303546E-01,2.336562E-01,2.526775E-01,& + & 2.642510E-01,4.416008E-02,1.516405E-01,2.743973E-01,3.995882E-01,& + & 4.361156E-01,2.367995E-01,2.541206E-01,2.688772E-01,4.725577E-02,& + & 1.517569E-01,2.762657E-01,4.044989E-01,4.419550E-01,2.399848E-01,& + & 2.555722E-01,2.736040E-01,5.056839E-02,1.518739E-01,2.781483E-01,& + & 4.094710E-01,4.478733E-01,2.432138E-01,2.570334E-01,2.784339E-01,& + & 5.411339E-02,1.519918E-01,2.800451E-01,4.145055E-01,4.538718E-01,& + & 2.464856E-01,2.585034E-01,2.833696E-01,5.790695E-02,1.521108E-01,& + & 2.819550E-01,4.196038E-01,4.599513E-01,2.498022E-01,2.599821E-01,& + & 2.884134E-01,6.196663E-02,1.522307E-01,2.838795E-01,4.247654E-01,& + & 4.661129E-01,2.531627E-01,2.614704E-01,2.935682E-01,6.631095E-02,& + & 1.523522E-01,2.858182E-01,4.299918E-01,4.723589E-01,2.565690E-01,& + & 2.629681E-01,2.988374E-01,7.095995E-02,1.524741E-01,2.877711E-01,& + & 4.352839E-01,4.786887E-01,2.600210E-01,2.644748E-01,3.042225E-01,& + & 7.593502E-02,1.525970E-01,2.897386E-01,4.406428E-01,4.851048E-01,& + & 2.635196E-01,2.659912E-01,3.097280E-01,8.125896E-02,1.527209E-01,& + & 2.917203E-01,4.460684E-01,4.916071E-01,2.670660E-01,2.675170E-01,& + & 3.153551E-01,8.695633E-02 / + + data ka_mn2o(:, :) / & + & 4.543786E-02,1.539160E-01,4.440464E-01,3.558702E-01,3.992789E-01,& + & 2.277012E-01,1.448181E-01,2.204126E-01,4.620570E-02,1.548967E-01,& + & 4.435476E-01,3.554453E-01,3.991047E-01,2.316956E-01,1.455101E-01,& + & 2.164010E-01,4.698867E-02,1.558850E-01,4.430499E-01,3.550222E-01,& + & 3.989333E-01,2.357617E-01,1.462126E-01,2.124625E-01,4.778716E-02,& + & 1.568810E-01,4.425522E-01,3.545996E-01,3.987639E-01,2.399005E-01,& + & 1.469261E-01,2.085959E-01,4.860148E-02,1.578846E-01,4.420558E-01,& + & 3.541779E-01,3.985974E-01,2.441145E-01,1.476498E-01,2.047992E-01,& + & 4.943199E-02,1.588964E-01,4.415600E-01,3.537570E-01,3.984328E-01,& + & 2.484042E-01,1.483850E-01,2.010726E-01,5.027909E-02,1.599159E-01,& + & 4.410646E-01,3.533369E-01,3.982704E-01,2.527716E-01,1.491313E-01,& + & 1.974129E-01,5.114307E-02,1.609430E-01,4.405697E-01,3.529173E-01,& + & 3.981107E-01,2.572175E-01,1.498889E-01,1.938202E-01,5.202440E-02,& + & 1.619788E-01,4.400762E-01,3.524986E-01,3.979541E-01,2.617440E-01,& + & 1.506576E-01,1.902925E-01,5.292347E-02,1.630227E-01,4.395827E-01,& + & 3.520807E-01,3.977996E-01,2.663525E-01,1.514384E-01,1.868296E-01,& + & 5.384059E-02,1.640743E-01,4.390901E-01,3.516642E-01,3.976480E-01,& + & 2.710438E-01,1.522304E-01,1.834290E-01,5.477627E-02,1.651340E-01,& + & 4.385980E-01,3.512476E-01,3.974985E-01,2.758202E-01,1.530342E-01,& + & 1.800911E-01,5.573090E-02,1.662024E-01,4.381068E-01,3.508325E-01,& + & 3.973512E-01,2.806828E-01,1.538492E-01,1.768133E-01,5.670494E-02,& + & 1.672795E-01,4.376161E-01,3.504182E-01,3.972069E-01,2.856337E-01,& + & 1.546765E-01,1.735955E-01,5.769880E-02,1.683648E-01,4.371264E-01,& + & 3.500041E-01,3.970656E-01,2.906738E-01,1.555160E-01,1.704357E-01,& + & 5.871293E-02,1.694587E-01,4.366366E-01,3.495911E-01,3.969265E-01,& + & 2.958057E-01,1.563679E-01,1.673338E-01,5.974783E-02,1.705613E-01,& + & 4.361478E-01,3.491790E-01,3.967896E-01,3.010306E-01,1.572322E-01,& + & 1.642888E-01,6.080390E-02,1.716721E-01,4.356604E-01,3.487672E-01,& + & 3.966558E-01,3.063501E-01,1.581082E-01,1.612980E-01,6.188175E-02,& + & 1.727925E-01,4.351725E-01,3.483568E-01,3.965251E-01,3.117662E-01,& + & 1.589973E-01,1.583630E-01 / + + data kb_mn2o(:, :) / & + & 3.133810E-04,1.362189E-03,1.658212E-02,6.628002E-01,2.820795E+00,& + & 1.182389E-02,1.412564E-02,4.427744E-02,3.280695E-04,1.525586E-03,& + & 1.809630E-02,6.763019E-01,2.735319E+00,1.357150E-02,1.627435E-02,& + & 5.181637E-02,3.436206E-04,1.708828E-03,1.975307E-02,6.908516E-01,& + & 2.652479E+00,1.557735E-02,1.875072E-02,6.066017E-02,3.600891E-04,& + & 1.914350E-03,2.156639E-02,7.065609E-01,2.572198E+00,1.787969E-02,& + & 2.160502E-02,7.104101E-02,3.775330E-04,2.144892E-03,2.355151E-02,& + & 7.235483E-01,2.494397E+00,2.052233E-02,2.489486E-02,8.323374E-02,& + & 3.960165E-04,2.403525E-03,2.572536E-02,7.419420E-01,2.419011E+00,& + & 2.355558E-02,2.868712E-02,9.756490E-02,4.156047E-04,2.693721E-03,& + & 2.810648E-02,7.618907E-01,2.345982E+00,2.703712E-02,3.305858E-02,& + & 1.144219E-01,4.363695E-04,3.019353E-03,3.071537E-02,7.835590E-01,& + & 2.275244E+00,3.103323E-02,3.809798E-02,1.342663E-01,4.583862E-04,& + & 3.384797E-03,3.357448E-02,8.071168E-01,2.206724E+00,3.561998E-02,& + & 4.390768E-02,1.576494E-01,4.817356E-04,3.794974E-03,3.670886E-02,& + & 8.327630E-01,2.140376E+00,4.088463E-02,5.060558E-02,1.852299E-01,& + & 5.065037E-04,4.255407E-03,4.014595E-02,8.607151E-01,2.076138E+00,& + & 4.692744E-02,5.832800E-02,2.177943E-01,5.327822E-04,4.772317E-03,& + & 4.391587E-02,8.912116E-01,2.013974E+00,5.386339E-02,6.723205E-02,& + & 2.562885E-01,5.606681E-04,5.352687E-03,4.805222E-02,9.245128E-01,& + & 1.953818E+00,6.182451E-02,7.749879E-02,3.018475E-01,5.902662E-04,& + & 6.004386E-03,5.259183E-02,9.609239E-01,1.895637E+00,7.096223E-02,& + & 8.933722E-02,3.558422E-01,6.216872E-04,6.736266E-03,5.757534E-02,& + & 1.000754E+00,1.839393E+00,8.145061E-02,1.029888E-01,4.199253E-01,& + & 6.550490E-04,7.558223E-03,6.304797E-02,1.044365E+00,1.785042E+00,& + & 9.348889E-02,1.187324E-01,4.960980E-01,6.904754E-04,8.481509E-03,& + & 6.905929E-02,1.092154E+00,1.732550E+00,1.073072E-01,1.368884E-01,& + & 5.867889E-01,7.281091E-04,9.518724E-03,7.566415E-02,1.144549E+00,& + & 1.681905E+00,1.231671E-01,1.578283E-01,6.949521E-01,7.680800E-04,& + & 1.068399E-02,8.292357E-02,1.202038E+00,1.633060E+00,1.413713E-01,& + & 1.819794E-01,8.241945E-01 / + + + data fracrefa(:) / 3.144100e-01,2.758600e-01,2.129730e-01,& + & 1.406370e-01,4.558820e-02,6.566500e-03,3.423200e-03,5.319940e-04/ + + + data fracrefb(:) / 2.965200e-01,2.735400e-01,2.225400e-01,& + & 1.490440e-01,4.770290e-02,6.638900e-03,3.414800e-03,5.957930e-04/ + + + data cfc12(:) / 8.741204e+01,7.104260e+01,6.062525e+01,& + & 6.180445e+01,6.004920e+01,5.801711e+01,3.676788e+01,3.272258e+01/ + + data cfc22adj(:) / 1.127704e+02,7.130121e+01,6.180924e+01,& + & 6.892368e+01,4.695927e+01,3.454041e+00,5.279695e+00,5.507705e+00/ + +!........................................! + end module module_radlw_kgb08 ! +!========================================! + +!> This module sets up absorption coefficients for band 09: 1180-1390 +!! cm-1 (low - h2o, ch4; high - ch4) +!========================================! + module module_radlw_kgb09 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG09 +! + implicit none +! + private +! +!> msa09=585 + integer, public :: MSA09 +!> msb09=235 + integer, public :: MSB09 +!> msf09=10 + integer, public :: MSF09 +!> mfr09=4 + integer, public :: MFR09 +!> maf09=9 + integer, public :: MAF09 +!> mmn09=19 + integer, public :: MMN09 + parameter (MSA09=585, MSB09=235, MSF09=10, MFR09=4) + parameter (MAF09=9, MMN09=19) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG09=12). + real (kind=kind_phys), public :: forref(NG09,MFR09) + +!> the array absa(NG09,585) = ka(NG09,9,5,13) contains absorption coefs +!! at the NG09=12 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different column +!! amount ratios, as expressed through the binary species parameter eta, +!! defined as eta = gas1/(gas1+(rat)*gas2), where rat is the ratio of +!! the reference mls column amount value of gas1 to that of gas2. the +!! 2nd index in the array, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that the +!! data are for the corresponding temperature of tref-30, tref-15, tref, +!! tref+15, and tref+30, respectively. the third index, jp, runs from +!! 1 to 13 and refers to the reference pressure level (e.g. jp = 1 is +!! for a pressure of 1053.63 mb). the fourth index, ig, goes from 1 to +!! NG09=12, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG09,MSA09) + +!> the array absb(NG09,235) = kb(NG09,5,13:59) contains absorption coefs +!! at the NG09=12 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG09=12, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG09,MSB09) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG09=12). + real (kind=kind_phys), public :: selfref(NG09,MSF09) + +!> planck fractions mapping level : p=212.7250 mb, t = 223.06 k + real (kind=kind_phys), public :: fracrefa(NG09,MAF09) + +!> planck fraction mapping level : p 3.20e-2 mb, t = 197.92 k + real (kind=kind_phys), public :: fracrefb(NG09) + +!> the array ka_mxxx contains the absorption coefficient for +!! a minor species at the 16 chosen g-values for a reference pressure +!! level below 100~ mb. the first index in the array, js, runs +!! from 1 to 9, and corresponds to different gas column amount ratios, +!! as expressed through the binary species parameter eta, defined as +!! eta = gas1/(gas1 + (rat) * gas2), where rat is the +!! ratio of the reference mls column amount value of gas 1 +!! to that of gas2. the second index refers to temperature +!! in 7.2 degree increments. for instance, jt = 1 refers to a +!! temperature of 188.0, jt = 2 refers to 195.2, etc. the third index +!! runs over the g-channel (1 to NG09=12). + real (kind=kind_phys), public :: ka_mn2o(NG09,MAF09,MMN09) + +!> the array kb_mxxx contains the absorption coefficient for +!! a minor species at the NG09=12 chosen g-values for a reference pressure +!! level above 100~ mb. the first index refers to temperature +!! in 7.2 degree increments. For instance, jt = 1 refers to a +!! temperature of 188.0, jt = 2 refers to 195.2, etc. the second index +!! runs over the g-channel (1 to NG09=12). + real (kind=kind_phys), public :: kb_mn2o(NG09,MMN09) + + + data absa( :, 1: 25) / & + & 2.174600E-06,8.134600E-06,2.479300E-05,4.543200E-05,7.720800E-05,& + & 1.504200E-04,2.977500E-04,6.209700E-04,1.734043E-03,3.417499E-03,& + & 4.946048E-03,6.325670E-03,2.022000E-05,1.061500E-04,3.079900E-04,& + & 6.408500E-04,1.298300E-03,2.419800E-03,4.990300E-03,1.411700E-02,& + & 6.727721E-02,2.728465E-01,6.570850E-01,2.157718E+00,3.503900E-05,& + & 1.645100E-04,4.629000E-04,1.047000E-03,2.199000E-03,4.301600E-03,& + & 9.596600E-03,2.827700E-02,1.349209E-01,5.443225E-01,1.308690E+00,& + & 4.277929E+00,4.956400E-05,2.184300E-04,5.932500E-04,1.440400E-03,& + & 3.069800E-03,6.297900E-03,1.445800E-02,4.277500E-02,2.033026E-01,& + & 8.138228E-01,1.951028E+00,6.340179E+00,6.454700E-05,2.721700E-04,& + & 7.173700E-04,1.833300E-03,3.933500E-03,8.516800E-03,1.955000E-02,& + & 5.784800E-02,2.728192E-01,1.079974E+00,2.579716E+00,8.304164E+00,& + & 8.064500E-05,3.327100E-04,8.219300E-04,2.285700E-03,4.893900E-03,& + & 1.096800E-02,2.506600E-02,7.396000E-02,3.444752E-01,1.339605E+00,& + & 3.182595E+00,1.008598E+01,1.005000E-04,4.042400E-04,9.404800E-04,& + & 2.854000E-03,6.050700E-03,1.392900E-02,3.154800E-02,9.240700E-02,& + & 4.205884E-01,1.585051E+00,3.729466E+00,1.147152E+01,1.359100E-04,& + & 5.273700E-04,1.139900E-03,3.747400E-03,7.986400E-03,1.858400E-02,& + & 4.090700E-02,1.186400E-01,5.083110E-01,1.779605E+00,4.116465E+00,& + & 1.166156E+01,1.142200E-04,4.645700E-04,1.025200E-03,3.307800E-03,& + & 7.395000E-03,1.683400E-02,3.892000E-02,1.155400E-01,5.455513E-01,& + & 2.159781E+00,5.159271E+00,1.660815E+01,2.456700E-06,9.535700E-06,& + & 2.629600E-05,4.677500E-05,7.796000E-05,1.540200E-04,2.997400E-04,& + & 6.197400E-04,1.722387E-03,3.319139E-03,4.815310E-03,6.195852E-03,& + & 2.464200E-05,1.224500E-04,3.535000E-04,7.326000E-04,1.495300E-03,& + & 2.787400E-03,5.870800E-03,1.690500E-02,7.979273E-02,3.251557E-01,& + & 7.765198E-01,2.531138E+00,4.257700E-05,1.920300E-04,5.396300E-04,& + & 1.219600E-03,2.537200E-03,5.090600E-03,1.148400E-02,3.388900E-02,& + & 1.600252E-01,6.485417E-01,1.546142E+00,5.019622E+00,6.017900E-05,& + & 2.568600E-04,6.957300E-04,1.690600E-03,3.585200E-03,7.540500E-03,& + & 1.734000E-02,5.127600E-02,2.410513E-01,9.692883E-01,2.306288E+00,& + & 7.440840E+00,7.815600E-05,3.214700E-04,8.491000E-04,2.170000E-03,& + & 4.687700E-03,1.017200E-02,2.348600E-02,6.934800E-02,3.233725E-01,& + & 1.285641E+00,3.049838E+00,9.751635E+00,9.752100E-05,3.909100E-04,& + & 9.900500E-04,2.727900E-03,5.914100E-03,1.304900E-02,3.015600E-02,& + & 8.870300E-02,4.080858E-01,1.593287E+00,3.764302E+00,1.185513E+01,& + & 1.232500E-04,4.763200E-04,1.135300E-03,3.392800E-03,7.445300E-03,& + & 1.652300E-02,3.802200E-02,1.108400E-01,4.979326E-01,1.879399E+00,& + & 4.417956E+00,1.350001E+01,1.643800E-04,6.173600E-04,1.391400E-03,& + & 4.543500E-03,9.666400E-03,2.217200E-02,4.952200E-02,1.417700E-01,& + & 6.026068E-01,2.094540E+00,4.885267E+00,1.376544E+01,1.383400E-04,& + & 5.389000E-04,1.287200E-03,4.003100E-03,8.936200E-03,2.013400E-02,& + & 4.679800E-02,1.385300E-01,6.466520E-01,2.571094E+00,6.099415E+00,& + & 1.950280E+01,2.777800E-06,1.089400E-05,2.781900E-05,4.790700E-05,& + & 7.861600E-05,1.565800E-04,3.024900E-04,6.158700E-04,1.712039E-03,& + & 3.238164E-03,4.687900E-03,6.070625E-03,2.975500E-05,1.402700E-04,& + & 4.034500E-04,8.403000E-04,1.702700E-03,3.211600E-03,6.837900E-03,& + & 1.990000E-02,9.320583E-02,3.803200E-01,9.048590E-01,2.909829E+00,& + & 5.123300E-05,2.232800E-04,6.233700E-04,1.416800E-03,2.942800E-03,& + & 5.965200E-03,1.352300E-02,3.992500E-02,1.868870E-01,7.585765E-01,& + & 1.801497E+00,5.771942E+00,7.253800E-05,3.009800E-04,8.113000E-04,& + & 1.977100E-03,4.189500E-03,8.927400E-03,2.045300E-02,6.042200E-02,& + & 2.814810E-01,1.133844E+00,2.686191E+00,8.559474E+00,9.425600E-05,& + & 3.774000E-04,9.926000E-04,2.562300E-03,5.524100E-03,1.207000E-02,& + & 2.773400E-02,8.172900E-02,3.775669E-01,1.503704E+00,3.551732E+00,& + & 1.122155E+01,1.171600E-04,4.587300E-04,1.172700E-03,3.219900E-03,& + & 7.022000E-03,1.549100E-02,3.568000E-02,1.045100E-01,4.762537E-01,& + & 1.862905E+00,4.383550E+00,1.365125E+01,1.458300E-04,5.625600E-04,& + & 1.374000E-03,4.038000E-03,8.889400E-03,1.955300E-02,4.511600E-02,& + & 1.306100E-01,5.804281E-01,2.196215E+00,5.144739E+00,1.556724E+01/ + data absa( :, 26: 50) / & + & 1.981800E-04,7.283600E-04,1.695800E-03,5.365600E-03,1.183700E-02,& + & 2.605600E-02,5.896000E-02,1.669600E-01,7.017542E-01,2.440765E+00,& + & 5.687049E+00,1.592047E+01,1.672200E-04,6.282000E-04,1.576800E-03,& + & 4.747400E-03,1.069800E-02,2.391900E-02,5.530100E-02,1.632800E-01,& + & 7.550377E-01,3.007264E+00,7.103103E+00,2.244397E+01,3.136400E-06,& + & 1.221800E-05,2.950500E-05,4.873300E-05,7.928400E-05,1.596000E-04,& + & 3.050500E-04,6.118400E-04,1.698960E-03,3.166451E-03,4.561221E-03,& + & 5.959989E-03,3.537600E-05,1.612500E-04,4.582900E-04,9.617100E-04,& + & 1.923300E-03,3.683600E-03,7.916100E-03,2.308600E-02,1.074100E-01,& + & 4.362797E-01,1.043807E+00,3.292360E+00,6.112200E-05,2.583700E-04,& + & 7.130800E-04,1.641600E-03,3.388900E-03,6.961700E-03,1.575000E-02,& + & 4.634400E-02,2.154089E-01,8.703348E-01,2.077717E+00,6.529198E+00,& + & 8.670900E-05,3.498800E-04,9.378600E-04,2.312600E-03,4.886100E-03,& + & 1.046000E-02,2.384300E-02,7.016300E-02,3.243943E-01,1.301282E+00,& + & 3.096827E+00,9.683770E+00,1.126100E-04,4.399100E-04,1.150800E-03,& + & 3.027500E-03,6.486400E-03,1.415400E-02,3.235300E-02,9.490100E-02,& + & 4.350065E-01,1.726307E+00,4.092620E+00,1.269661E+01,1.402500E-04,& + & 5.339600E-04,1.382700E-03,3.794600E-03,8.288600E-03,1.820500E-02,& + & 4.163400E-02,1.213700E-01,5.484036E-01,2.140644E+00,5.045800E+00,& + & 1.545863E+01,1.741100E-04,6.521200E-04,1.646600E-03,4.757100E-03,& + & 1.048900E-02,2.305500E-02,5.268300E-02,1.516500E-01,6.679462E-01,& + & 2.529510E+00,5.907180E+00,1.765010E+01,2.332600E-04,8.578300E-04,& + & 2.060400E-03,6.368400E-03,1.403100E-02,3.055500E-02,6.927900E-02,& + & 1.937000E-01,8.056887E-01,2.817368E+00,6.510483E+00,1.809952E+01,& + & 2.004300E-04,7.325800E-04,1.907400E-03,5.639600E-03,1.268700E-02,& + & 2.808900E-02,6.454400E-02,1.896200E-01,8.699239E-01,3.452369E+00,& + & 8.185057E+00,2.539234E+01,3.486600E-06,1.355900E-05,3.128100E-05,& + & 4.956800E-05,8.031100E-05,1.616500E-04,3.078400E-04,6.095000E-04,& + & 1.685343E-03,3.081321E-03,4.436529E-03,5.856450E-03,4.177300E-05,& + & 1.841800E-04,5.179500E-04,1.096000E-03,2.162300E-03,4.203700E-03,& + & 9.114500E-03,2.646800E-02,1.223363E-01,4.926393E-01,1.189611E+00,& + & 3.686173E+00,7.242100E-05,2.970900E-04,8.147300E-04,1.892600E-03,& + & 3.873000E-03,8.081700E-03,1.817800E-02,5.316400E-02,2.453272E-01,& + & 9.832960E-01,2.367717E+00,7.306885E+00,1.028400E-04,4.056300E-04,& + & 1.077000E-03,2.689300E-03,5.651300E-03,1.217700E-02,2.752900E-02,& + & 8.047800E-02,3.694691E-01,1.470948E+00,3.528602E+00,1.082763E+01,& + & 1.336800E-04,5.091300E-04,1.336600E-03,3.536500E-03,7.560300E-03,& + & 1.648400E-02,3.735300E-02,1.088600E-01,4.953733E-01,1.953652E+00,& + & 4.660800E+00,1.418763E+01,1.665800E-04,6.201800E-04,1.610800E-03,& + & 4.467700E-03,9.706400E-03,2.119100E-02,4.807400E-02,1.392200E-01,& + & 6.244053E-01,2.425538E+00,5.741156E+00,1.725093E+01,2.064500E-04,& + & 7.546400E-04,1.954700E-03,5.598600E-03,1.230600E-02,2.687500E-02,& + & 6.082400E-02,1.739800E-01,7.599438E-01,2.871876E+00,6.705590E+00,& + & 1.971497E+01,2.737900E-04,9.926700E-04,2.490400E-03,7.484800E-03,& + & 1.641900E-02,3.576900E-02,8.005200E-02,2.219200E-01,9.147275E-01,& + & 3.216501E+00,7.354405E+00,2.026948E+01,2.393300E-04,8.524800E-04,& + & 2.280300E-03,6.676000E-03,1.485700E-02,3.273900E-02,7.455100E-02,& + & 2.175300E-01,9.906467E-01,3.907060E+00,9.321416E+00,2.837514E+01,& + & 2.765800E-06,1.064800E-05,3.279300E-05,5.964400E-05,1.051000E-04,& + & 2.099800E-04,4.404400E-04,9.421400E-04,2.741257E-03,5.666418E-03,& + & 8.059416E-03,1.040576E-02,1.866500E-05,1.020500E-04,3.069400E-04,& + & 6.516500E-04,1.201000E-03,2.258900E-03,4.574500E-03,1.186400E-02,& + & 5.902069E-02,2.591064E-01,6.510285E-01,2.255159E+00,2.957900E-05,& + & 1.521800E-04,4.522100E-04,9.709500E-04,1.970800E-03,3.789900E-03,& + & 7.944200E-03,2.336800E-02,1.182507E-01,5.173614E-01,1.298136E+00,& + & 4.487237E+00,4.055600E-05,1.946000E-04,5.645900E-04,1.273500E-03,& + & 2.686300E-03,5.241000E-03,1.165800E-02,3.516800E-02,1.779928E-01,& + & 7.743852E-01,1.939619E+00,6.683750E+00,5.147500E-05,2.346900E-04,& + & 6.580600E-04,1.569300E-03,3.380100E-03,6.774400E-03,1.561200E-02,& + & 4.730800E-02,2.385827E-01,1.029718E+00,2.571662E+00,8.819122E+00/ + data absa( :, 51: 75) / & + & 6.301200E-05,2.744500E-04,7.445600E-04,1.872300E-03,4.040100E-03,& + & 8.570300E-03,1.980900E-02,6.006000E-02,3.007591E-01,1.281408E+00,& + & 3.185431E+00,1.083902E+01,7.603000E-05,3.237400E-04,8.092500E-04,& + & 2.243500E-03,4.806500E-03,1.069700E-02,2.458600E-02,7.429300E-02,& + & 3.663936E-01,1.526394E+00,3.757979E+00,1.259085E+01,9.655400E-05,& + & 3.968700E-04,9.101900E-04,2.830300E-03,5.983900E-03,1.388100E-02,& + & 3.137300E-02,9.354800E-02,4.427791E-01,1.745834E+00,4.196030E+00,& + & 1.343278E+01,8.679000E-05,3.702100E-04,8.694500E-04,2.551800E-03,& + & 5.872000E-03,1.319800E-02,3.091000E-02,9.438100E-02,4.770395E-01,& + & 2.059170E+00,5.143063E+00,1.763812E+01,3.147400E-06,1.247900E-05,& + & 3.466600E-05,6.155000E-05,1.061800E-04,2.145600E-04,4.450200E-04,& + & 9.396700E-04,2.727190E-03,5.526889E-03,7.848548E-03,1.015919E-02,& + & 2.267500E-05,1.186400E-04,3.512300E-04,7.343300E-04,1.371900E-03,& + & 2.600700E-03,5.245700E-03,1.420500E-02,7.056657E-02,3.115300E-01,& + & 7.764889E-01,2.660527E+00,3.632200E-05,1.769300E-04,5.246600E-04,& + & 1.115500E-03,2.289200E-03,4.394600E-03,9.432100E-03,2.822100E-02,& + & 1.413752E-01,6.221174E-01,1.547865E+00,5.295025E+00,4.956900E-05,& + & 2.290600E-04,6.596800E-04,1.486200E-03,3.104000E-03,6.198700E-03,& + & 1.400900E-02,4.249100E-02,2.127719E-01,9.317063E-01,2.311847E+00,& + & 7.889156E+00,6.284800E-05,2.781700E-04,7.704000E-04,1.848000E-03,& + & 3.926400E-03,8.136100E-03,1.880400E-02,5.716500E-02,2.851784E-01,& + & 1.239008E+00,3.063229E+00,1.041285E+01,7.672500E-05,3.263500E-04,& + & 8.824900E-04,2.214400E-03,4.796100E-03,1.027200E-02,2.391500E-02,& + & 7.261600E-02,3.594534E-01,1.542462E+00,3.792069E+00,1.279753E+01,& + & 9.297500E-05,3.810000E-04,9.790600E-04,2.678200E-03,5.835600E-03,& + & 1.273300E-02,2.975600E-02,8.983500E-02,4.379108E-01,1.834885E+00,& + & 4.471338E+00,1.488486E+01,1.192000E-04,4.681200E-04,1.105600E-03,& + & 3.385100E-03,7.335100E-03,1.654100E-02,3.808800E-02,1.132200E-01,& + & 5.287174E-01,2.091126E+00,4.996197E+00,1.592528E+01,1.062800E-04,& + & 4.297200E-04,1.065400E-03,3.102800E-03,7.092500E-03,1.587500E-02,& + & 3.731700E-02,1.140800E-01,5.702257E-01,2.477828E+00,6.126097E+00,& + & 2.082571E+01,3.561900E-06,1.432500E-05,3.673100E-05,6.342400E-05,& + & 1.068900E-04,2.184200E-04,4.489300E-04,9.366600E-04,2.711212E-03,& + & 5.404214E-03,7.637190E-03,9.999886E-03,2.722200E-05,1.361500E-04,& + & 4.000400E-04,8.281400E-04,1.566100E-03,2.956000E-03,5.989800E-03,& + & 1.679300E-02,8.305418E-02,3.660756E-01,9.117436E-01,3.083163E+00,& + & 4.376300E-05,2.061300E-04,6.029200E-04,1.286200E-03,2.626600E-03,& + & 5.088700E-03,1.110100E-02,3.345300E-02,1.664157E-01,7.312483E-01,& + & 1.817730E+00,6.133778E+00,5.989500E-05,2.682200E-04,7.649100E-04,& + & 1.729900E-03,3.594300E-03,7.275200E-03,1.660400E-02,5.040300E-02,& + & 2.504378E-01,1.095323E+00,2.714953E+00,9.134068E+00,7.602500E-05,& + & 3.274200E-04,9.009100E-04,2.166700E-03,4.568100E-03,9.655200E-03,& + & 2.231900E-02,6.782300E-02,3.355784E-01,1.457396E+00,3.597609E+00,& + & 1.205096E+01,9.285500E-05,3.853200E-04,1.028900E-03,2.622000E-03,& + & 5.618000E-03,1.225200E-02,2.841300E-02,8.614300E-02,4.228957E-01,& + & 1.815476E+00,4.452617E+00,1.481228E+01,1.116600E-04,4.499200E-04,& + & 1.166800E-03,3.165400E-03,6.875900E-03,1.523200E-02,3.538600E-02,& + & 1.065700E-01,5.149369E-01,2.162269E+00,5.242972E+00,1.722881E+01,& + & 1.441000E-04,5.558100E-04,1.343800E-03,4.029000E-03,8.864000E-03,& + & 1.958200E-02,4.542500E-02,1.343700E-01,6.211736E-01,2.464049E+00,& + & 5.845856E+00,1.847710E+01,1.284000E-04,5.038200E-04,1.280400E-03,& + & 3.721900E-03,8.450900E-03,1.896800E-02,4.435800E-02,1.353800E-01,& + & 6.710090E-01,2.914404E+00,7.194913E+00,2.410192E+01,4.033200E-06,& + & 1.613100E-05,3.891800E-05,6.461800E-05,1.086100E-04,2.223600E-04,& + & 4.530300E-04,9.349000E-04,2.690601E-03,5.274186E-03,7.436350E-03,& + & 9.848556E-03,3.219400E-05,1.552200E-04,4.542000E-04,9.277000E-04,& + & 1.775200E-03,3.345900E-03,6.834600E-03,1.958900E-02,9.633449E-02,& + & 4.223749E-01,1.055447E+00,3.525239E+00,5.228400E-05,2.382300E-04,& + & 6.890000E-04,1.481200E-03,2.985300E-03,5.873600E-03,1.296600E-02,& + & 3.908700E-02,1.930227E-01,8.437903E-01,2.103870E+00,7.011428E+00/ + data absa( :, 76:100) / & + & 7.166400E-05,3.121600E-04,8.827300E-04,2.000000E-03,4.145300E-03,& + & 8.506700E-03,1.945100E-02,5.890100E-02,2.905122E-01,1.263995E+00,& + & 3.142343E+00,1.043663E+01,9.120100E-05,3.816300E-04,1.046300E-03,& + & 2.528100E-03,5.319200E-03,1.134900E-02,2.616800E-02,7.928100E-02,& + & 3.893154E-01,1.682417E+00,4.163206E+00,1.376338E+01,1.113200E-04,& + & 4.498700E-04,1.204300E-03,3.088900E-03,6.597300E-03,1.441400E-02,& + & 3.333300E-02,1.006800E-01,4.905846E-01,2.096355E+00,5.152787E+00,& + & 1.689949E+01,1.339500E-04,5.242300E-04,1.384500E-03,3.730100E-03,& + & 8.127400E-03,1.796400E-02,4.153400E-02,1.245800E-01,5.970306E-01,& + & 2.498379E+00,6.071594E+00,1.961737E+01,1.694800E-04,6.509500E-04,& + & 1.632200E-03,4.746700E-03,1.045600E-02,2.318700E-02,5.337200E-02,& + & 1.569700E-01,7.195831E-01,2.845903E+00,6.768622E+00,2.103875E+01,& + & 1.548200E-04,5.890100E-04,1.533800E-03,4.455100E-03,1.003100E-02,& + & 2.235500E-02,5.206300E-02,1.582900E-01,7.784868E-01,3.364401E+00,& + & 8.326029E+00,2.752564E+01,4.542600E-06,1.784000E-05,4.107000E-05,& + & 6.649500E-05,1.100400E-04,2.254700E-04,4.565300E-04,9.325500E-04,& + & 2.673429E-03,5.126594E-03,7.247546E-03,9.697075E-03,3.789200E-05,& + & 1.773800E-04,5.113900E-04,1.041300E-03,1.994500E-03,3.771300E-03,& + & 7.798900E-03,2.256100E-02,1.103562E-01,4.791376E-01,1.207816E+00,& + & 3.980379E+00,6.193000E-05,2.741300E-04,7.841200E-04,1.691200E-03,& + & 3.383100E-03,6.750100E-03,1.504500E-02,4.508700E-02,2.210943E-01,& + & 9.571679E-01,2.408065E+00,7.914179E+00,8.520000E-05,3.614500E-04,& + & 1.008200E-03,2.309600E-03,4.736800E-03,9.903900E-03,2.259200E-02,& + & 6.798300E-02,3.327891E-01,1.433822E+00,3.596363E+00,1.178087E+01,& + & 1.084500E-04,4.430700E-04,1.207000E-03,2.932400E-03,6.145400E-03,& + & 1.326400E-02,3.040700E-02,9.150800E-02,4.459437E-01,1.907851E+00,& + & 4.765974E+00,1.552957E+01,1.325700E-04,5.221700E-04,1.400300E-03,& + & 3.606300E-03,7.684600E-03,1.687000E-02,3.871700E-02,1.162100E-01,& + & 5.619113E-01,2.376992E+00,5.899999E+00,1.905748E+01,1.595700E-04,& + & 6.096800E-04,1.610600E-03,4.391500E-03,9.532000E-03,2.103200E-02,& + & 4.821700E-02,1.437500E-01,6.839368E-01,2.832979E+00,6.951571E+00,& + & 2.209024E+01,2.015000E-04,7.492900E-04,1.956600E-03,5.583100E-03,& + & 1.231200E-02,2.715400E-02,6.195300E-02,1.810800E-01,8.232628E-01,& + & 3.238492E+00,7.742966E+00,2.361386E+01,1.853100E-04,6.858800E-04,& + & 1.833800E-03,5.277900E-03,1.175700E-02,2.617600E-02,6.054100E-02,& + & 1.827400E-01,8.917234E-01,3.815358E+00,9.531549E+00,3.105889E+01,& + & 4.651500E-06,1.797500E-05,5.741900E-05,1.046200E-04,1.916600E-04,& + & 3.874900E-04,8.701100E-04,1.961400E-03,5.766874E-03,1.294282E-02,& + & 1.779987E-02,2.422923E-02,1.951800E-05,1.123600E-04,3.441700E-04,& + & 7.293900E-04,1.317200E-03,2.356700E-03,4.751900E-03,1.129900E-02,& + & 4.929054E-02,2.330066E-01,6.226189E-01,2.234083E+00,2.802400E-05,& + & 1.538300E-04,4.765700E-04,1.051000E-03,1.927800E-03,3.578400E-03,& + & 7.419100E-03,1.900500E-02,9.836434E-02,4.654325E-01,1.242839E+00,& + & 4.457995E+00,3.543700E-05,1.873400E-04,5.801100E-04,1.270800E-03,& + & 2.467700E-03,4.730200E-03,9.772400E-03,2.778200E-02,1.477483E-01,& + & 6.977811E-01,1.859939E+00,6.668775E+00,4.206000E-05,2.161200E-04,& + & 6.577600E-04,1.459000E-03,2.970700E-03,5.799200E-03,1.224200E-02,& + & 3.700000E-02,1.975371E-01,9.298636E-01,2.472009E+00,8.851003E+00,& + & 4.894900E-05,2.401400E-04,7.101700E-04,1.626800E-03,3.489500E-03,& + & 6.758400E-03,1.507600E-02,4.652200E-02,2.481123E-01,1.161571E+00,& + & 3.073603E+00,1.098278E+01,5.645800E-05,2.605800E-04,7.435200E-04,& + & 1.807100E-03,3.944000E-03,7.892900E-03,1.829300E-02,5.665700E-02,& + & 3.006323E-01,1.391732E+00,3.650796E+00,1.299182E+01,6.619300E-05,& + & 2.934300E-04,7.516500E-04,2.057100E-03,4.448400E-03,9.681000E-03,& + & 2.240200E-02,6.908000E-02,3.600703E-01,1.612044E+00,4.149317E+00,& + & 1.453874E+01,6.470200E-05,2.975200E-04,7.190500E-04,1.998300E-03,& + & 4.349700E-03,9.895000E-03,2.345400E-02,7.350800E-02,3.948533E-01,& + & 1.859183E+00,4.943517E+00,1.770166E+01,5.308500E-06,2.120800E-05,& + & 6.109800E-05,1.085300E-04,1.933600E-04,3.960300E-04,8.776100E-04,& + & 1.954800E-03,5.752570E-03,1.265101E-02,1.738984E-02,2.360911E-02/ + data absa( :,101:125) / & + & 2.366100E-05,1.308400E-04,3.889400E-04,8.159100E-04,1.488800E-03,& + & 2.646400E-03,5.400400E-03,1.295500E-02,5.961322E-02,2.830076E-01,& + & 7.515899E-01,2.678787E+00,3.425000E-05,1.801300E-04,5.505000E-04,& + & 1.191500E-03,2.199700E-03,4.136600E-03,8.516900E-03,2.289100E-02,& + & 1.190952E-01,5.653679E-01,1.500295E+00,5.343439E+00,4.364900E-05,& + & 2.208000E-04,6.728300E-04,1.460500E-03,2.850000E-03,5.500700E-03,& + & 1.144900E-02,3.390300E-02,1.788638E-01,8.477145E-01,2.245747E+00,& + & 7.990079E+00,5.188200E-05,2.554300E-04,7.681400E-04,1.687800E-03,& + & 3.465600E-03,6.782200E-03,1.465600E-02,4.525400E-02,2.391392E-01,& + & 1.130036E+00,2.984825E+00,1.060406E+01,6.042900E-05,2.843200E-04,& + & 8.356200E-04,1.907900E-03,4.040500E-03,8.047000E-03,1.824500E-02,& + & 5.692200E-02,3.003312E-01,1.411932E+00,3.711884E+00,1.313900E+01,& + & 6.953600E-05,3.119900E-04,8.756300E-04,2.140300E-03,4.649400E-03,& + & 9.491300E-03,2.220300E-02,6.935500E-02,3.637810E-01,1.692488E+00,& + & 4.410279E+00,1.553743E+01,8.245600E-05,3.484600E-04,9.081200E-04,& + & 2.465200E-03,5.388600E-03,1.161900E-02,2.730300E-02,8.455500E-02,& + & 4.354429E-01,1.963363E+00,5.005913E+00,1.739391E+01,7.940000E-05,& + & 3.519600E-04,8.788400E-04,2.385900E-03,5.287600E-03,1.203600E-02,& + & 2.846800E-02,9.000100E-02,4.780235E-01,2.259473E+00,5.969050E+00,& + & 2.120776E+01,6.040100E-06,2.455800E-05,6.495000E-05,1.116100E-04,& + & 1.955200E-04,4.045600E-04,8.855500E-04,1.953400E-03,5.724195E-03,& + & 1.235622E-02,1.697941E-02,2.306585E-02,2.833800E-05,1.502100E-04,& + & 4.399400E-04,9.080700E-04,1.671900E-03,2.955900E-03,6.096000E-03,& + & 1.483300E-02,7.090255E-02,3.358950E-01,8.901994E-01,3.151180E+00,& + & 4.134400E-05,2.087800E-04,6.315900E-04,1.345200E-03,2.497800E-03,& + & 4.738900E-03,9.739900E-03,2.724000E-02,1.417151E-01,6.711053E-01,& + & 1.777233E+00,6.286632E+00,5.267500E-05,2.569300E-04,7.758400E-04,& + & 1.669600E-03,3.279400E-03,6.350800E-03,1.338300E-02,4.059900E-02,& + & 2.128715E-01,1.006216E+00,2.660020E+00,9.398238E+00,6.299600E-05,& + & 2.994500E-04,8.943300E-04,1.943600E-03,4.017100E-03,7.879900E-03,& + & 1.742000E-02,5.423900E-02,2.845925E-01,1.341221E+00,3.535712E+00,& + & 1.246868E+01,7.352700E-05,3.361900E-04,9.756200E-04,2.229800E-03,& + & 4.688300E-03,9.490700E-03,2.180500E-02,6.826400E-02,3.574056E-01,& + & 1.675717E+00,4.397668E+00,1.545479E+01,8.469700E-05,3.704800E-04,& + & 1.027800E-03,2.524500E-03,5.381000E-03,1.139200E-02,2.657800E-02,& + & 8.319400E-02,4.328387E-01,2.009415E+00,5.226839E+00,1.825018E+01,& + & 9.949900E-05,4.133400E-04,1.086000E-03,2.925600E-03,6.366300E-03,& + & 1.395600E-02,3.274700E-02,1.014600E-01,5.176580E-01,2.334585E+00,& + & 5.937110E+00,2.036886E+01,9.616100E-05,4.135000E-04,1.065500E-03,& + & 2.823600E-03,6.359400E-03,1.445700E-02,3.410200E-02,1.079600E-01,& + & 5.689160E-01,2.681754E+00,7.070886E+00,2.492167E+01,6.863600E-06,& + & 2.772000E-05,6.913700E-05,1.146300E-04,1.979300E-04,4.136000E-04,& + & 8.883700E-04,1.947900E-03,5.706023E-03,1.202978E-02,1.659108E-02,& + & 2.263271E-02,3.362500E-05,1.711100E-04,4.960600E-04,1.009600E-03,& + & 1.861800E-03,3.303200E-03,6.830300E-03,1.693900E-02,8.298826E-02,& + & 3.912809E-01,1.038899E+00,3.645881E+00,4.939300E-05,2.401200E-04,& + & 7.190500E-04,1.512600E-03,2.819300E-03,5.402400E-03,1.111600E-02,& + & 3.198100E-02,1.659145E-01,7.817038E-01,2.073817E+00,7.273462E+00,& + & 6.272900E-05,2.990400E-04,8.897900E-04,1.902900E-03,3.742100E-03,& + & 7.298700E-03,1.559800E-02,4.780500E-02,2.492422E-01,1.172210E+00,& + & 3.103823E+00,1.087123E+01,7.570500E-05,3.491000E-04,1.029500E-03,& + & 2.246000E-03,4.600200E-03,9.144700E-03,2.053200E-02,6.391800E-02,& + & 3.332253E-01,1.562542E+00,4.124982E+00,1.442076E+01,8.863200E-05,& + & 3.936700E-04,1.131500E-03,2.595700E-03,5.424600E-03,1.113100E-02,& + & 2.575700E-02,8.050100E-02,4.185351E-01,1.952403E+00,5.129868E+00,& + & 1.787228E+01,1.021800E-04,4.356000E-04,1.203300E-03,2.963700E-03,& + & 6.279000E-03,1.346600E-02,3.144500E-02,9.816400E-02,5.069321E-01,& + & 2.341010E+00,6.094296E+00,2.109364E+01,1.196500E-04,4.835100E-04,& + & 1.295200E-03,3.453900E-03,7.493900E-03,1.656800E-02,3.877300E-02,& + & 1.198000E-01,6.060651E-01,2.720525E+00,6.924338E+00,2.350100E+01/ + data absa( :,126:150) / & + & 1.159500E-04,4.824800E-04,1.283900E-03,3.328600E-03,7.626000E-03,& + & 1.711300E-02,4.038700E-02,1.273100E-01,6.661505E-01,3.124341E+00,& + & 8.249503E+00,2.884052E+01,7.759200E-06,3.083900E-05,7.337500E-05,& + & 1.177100E-04,2.020200E-04,4.186000E-04,8.956800E-04,1.943700E-03,& + & 5.681116E-03,1.168129E-02,1.621742E-02,2.223807E-02,3.948100E-05,& + & 1.941200E-04,5.553600E-04,1.122700E-03,2.062200E-03,3.694100E-03,& + & 7.615900E-03,1.921500E-02,9.581338E-02,4.487236E-01,1.196474E+00,& + & 4.155800E+00,5.824300E-05,2.757000E-04,8.143600E-04,1.699800E-03,& + & 3.177200E-03,6.102500E-03,1.268500E-02,3.701400E-02,1.915564E-01,& + & 8.966903E-01,2.388630E+00,8.289848E+00,7.442900E-05,3.458400E-04,& + & 1.015500E-03,2.162400E-03,4.240800E-03,8.327400E-03,1.813600E-02,& + & 5.543200E-02,2.877626E-01,1.344377E+00,3.575101E+00,1.239179E+01,& + & 9.018400E-05,4.048300E-04,1.179500E-03,2.586700E-03,5.234500E-03,& + & 1.057000E-02,2.401100E-02,7.415900E-02,3.847685E-01,1.791853E+00,& + & 4.751592E+00,1.643293E+01,1.059300E-04,4.591700E-04,1.305100E-03,& + & 3.003100E-03,6.223900E-03,1.301300E-02,3.015700E-02,9.342200E-02,& + & 4.832716E-01,2.238838E+00,5.907738E+00,2.036185E+01,1.222600E-04,& + & 5.062800E-04,1.404600E-03,3.450700E-03,7.292200E-03,1.581300E-02,& + & 3.681700E-02,1.140400E-01,5.853438E-01,2.683587E+00,7.018634E+00,& + & 2.403247E+01,1.432900E-04,5.635600E-04,1.516800E-03,4.069100E-03,& + & 8.819600E-03,1.949600E-02,4.538300E-02,1.393700E-01,6.999782E-01,& + & 3.117017E+00,7.969997E+00,2.674352E+01,1.395700E-04,5.601600E-04,& + & 1.529600E-03,3.921600E-03,9.003500E-03,2.011100E-02,4.735500E-02,& + & 1.478000E-01,7.692001E-01,3.582850E+00,9.502446E+00,3.286486E+01,& + & 7.825400E-06,3.025700E-05,1.008600E-04,1.898000E-04,3.508000E-04,& + & 7.199100E-04,1.721600E-03,4.114100E-03,1.232966E-02,3.031552E-02,& + & 4.035364E-02,5.906610E-02,2.216200E-05,1.334800E-04,4.245400E-04,& + & 8.169000E-04,1.510600E-03,2.858600E-03,5.601400E-03,1.287300E-02,& + & 4.414332E-02,2.020746E-01,5.838504E-01,2.166315E+00,2.876800E-05,& + & 1.679700E-04,5.298500E-04,1.149600E-03,2.104800E-03,3.849300E-03,& + & 7.573600E-03,1.887200E-02,8.066787E-02,4.030918E-01,1.166187E+00,& + & 4.327846E+00,3.409200E-05,1.924000E-04,6.084800E-04,1.374300E-03,& + & 2.553000E-03,4.611500E-03,9.467400E-03,2.379500E-02,1.202152E-01,& + & 6.041416E-01,1.747343E+00,6.481525E+00,3.827300E-05,2.095400E-04,& + & 6.712100E-04,1.517400E-03,2.892300E-03,5.275000E-03,1.119100E-02,& + & 2.931000E-02,1.603689E-01,8.054477E-01,2.326347E+00,8.622808E+00,& + & 4.161700E-05,2.222200E-04,7.072300E-04,1.599700E-03,3.142600E-03,& + & 5.982300E-03,1.253500E-02,3.581300E-02,2.008708E-01,1.006931E+00,& + & 2.901066E+00,1.074034E+01,4.458500E-05,2.289800E-04,7.123700E-04,& + & 1.636400E-03,3.383200E-03,6.593900E-03,1.398700E-02,4.300100E-02,& + & 2.421940E-01,1.209137E+00,3.465997E+00,1.279513E+01,4.784300E-05,& + & 2.314300E-04,6.819300E-04,1.648600E-03,3.636000E-03,7.120400E-03,& + & 1.626800E-02,5.122000E-02,2.866636E-01,1.413218E+00,3.990470E+00,& + & 1.462483E+01,5.009000E-05,2.508100E-04,6.164000E-04,1.686700E-03,& + & 3.609900E-03,6.995000E-03,1.729600E-02,5.627800E-02,3.202536E-01,& + & 1.609784E+00,4.652032E+00,1.724526E+01,9.010700E-06,3.611000E-05,& + & 1.079400E-04,1.968100E-04,3.549400E-04,7.393200E-04,1.729800E-03,& + & 4.118300E-03,1.231389E-02,2.965291E-02,3.944002E-02,5.756868E-02,& + & 2.685200E-05,1.542700E-04,4.688600E-04,9.168200E-04,1.689800E-03,& + & 3.154600E-03,6.187900E-03,1.457500E-02,5.216546E-02,2.492256E-01,& + & 7.148257E-01,2.641886E+00,3.523400E-05,1.968300E-04,6.009900E-04,& + & 1.294700E-03,2.382800E-03,4.329200E-03,8.683200E-03,2.159900E-02,& + & 9.853863E-02,4.972760E-01,1.428028E+00,5.277814E+00,4.206300E-05,& + & 2.249800E-04,7.039700E-04,1.553800E-03,2.916000E-03,5.248700E-03,& + & 1.097800E-02,2.825300E-02,1.474035E-01,7.454459E-01,2.139711E+00,& + & 7.903822E+00,4.736500E-05,2.490000E-04,7.829000E-04,1.735100E-03,& + & 3.305600E-03,6.163200E-03,1.297400E-02,3.580100E-02,1.966539E-01,& + & 9.937639E-01,2.848860E+00,1.051331E+01,5.178700E-05,2.649500E-04,& + & 8.292400E-04,1.852600E-03,3.630400E-03,7.032200E-03,1.474900E-02,& + & 4.430900E-02,2.463515E-01,1.242266E+00,3.553135E+00,1.309479E+01/ + data absa( :,151:175) / & + & 5.527600E-05,2.738300E-04,8.404200E-04,1.906500E-03,3.952000E-03,& + & 7.802500E-03,1.687000E-02,5.336300E-02,2.970716E-01,1.491343E+00,& + & 4.244757E+00,1.559207E+01,5.986400E-05,2.783100E-04,8.065600E-04,& + & 1.958300E-03,4.299400E-03,8.558300E-03,1.990900E-02,6.362800E-02,& + & 3.517178E-01,1.742578E+00,4.888148E+00,1.780675E+01,6.193000E-05,& + & 3.013000E-04,7.392300E-04,2.021500E-03,4.288200E-03,8.494900E-03,& + & 2.143100E-02,6.986700E-02,3.927717E-01,1.986239E+00,5.696836E+00,& + & 2.102626E+01,1.034900E-05,4.202000E-05,1.156400E-04,2.020800E-04,& + & 3.597800E-04,7.582900E-04,1.734100E-03,4.134900E-03,1.227803E-02,& + & 2.892539E-02,3.860504E-02,5.625425E-02,3.217200E-05,1.773100E-04,& + & 5.193700E-04,1.014600E-03,1.883600E-03,3.459200E-03,6.836700E-03,& + & 1.635500E-02,6.121304E-02,3.002784E-01,8.564814E-01,3.155491E+00,& + & 4.256500E-05,2.273300E-04,6.831600E-04,1.451400E-03,2.687700E-03,& + & 4.835500E-03,9.858400E-03,2.467200E-02,1.182912E-01,5.992098E-01,& + & 1.710978E+00,6.303242E+00,5.106100E-05,2.626800E-04,8.076400E-04,& + & 1.751600E-03,3.300800E-03,5.970900E-03,1.261600E-02,3.330500E-02,& + & 1.772522E-01,8.982214E-01,2.563545E+00,9.439252E+00,5.765400E-05,& + & 2.920000E-04,9.048800E-04,1.984100E-03,3.759300E-03,7.139500E-03,& + & 1.494400E-02,4.307400E-02,2.365258E-01,1.197291E+00,3.413283E+00,& + & 1.255445E+01,6.324300E-05,3.127000E-04,9.597500E-04,2.138300E-03,& + & 4.181500E-03,8.190900E-03,1.732400E-02,5.362500E-02,2.963419E-01,& + & 1.496815E+00,4.256687E+00,1.563188E+01,6.767500E-05,3.243000E-04,& + & 9.868000E-04,2.213800E-03,4.605300E-03,9.115900E-03,2.023700E-02,& + & 6.467300E-02,3.574284E-01,1.796564E+00,5.085771E+00,1.861533E+01,& + & 7.339700E-05,3.324300E-04,9.511500E-04,2.308200E-03,4.991700E-03,& + & 1.029200E-02,2.403500E-02,7.722800E-02,4.232295E-01,2.097417E+00,& + & 5.858300E+00,2.124210E+01,7.554800E-05,3.497700E-04,8.969000E-04,& + & 2.399800E-03,5.051400E-03,1.033500E-02,2.599800E-02,8.469500E-02,& + & 4.724826E-01,2.393204E+00,6.825666E+00,2.510891E+01,1.190600E-05,& + & 4.770400E-05,1.233900E-04,2.076200E-04,3.674600E-04,7.695900E-04,& + & 1.753400E-03,4.130800E-03,1.224963E-02,2.807777E-02,3.786967E-02,& + & 5.512030E-02,3.819000E-05,2.025400E-04,5.761000E-04,1.122600E-03,& + & 2.076300E-03,3.802500E-03,7.512800E-03,1.817300E-02,7.125586E-02,& + & 3.542570E-01,1.008495E+00,3.702763E+00,5.096000E-05,2.608000E-04,& + & 7.730100E-04,1.621100E-03,3.008200E-03,5.388000E-03,1.112700E-02,& + & 2.803400E-02,1.397680E-01,7.070363E-01,2.014836E+00,7.396063E+00,& + & 6.116100E-05,3.047000E-04,9.235400E-04,1.972800E-03,3.720300E-03,& + & 6.785300E-03,1.436200E-02,3.886500E-02,2.095635E-01,1.059973E+00,& + & 3.019045E+00,1.107520E+01,6.919200E-05,3.406600E-04,1.035000E-03,& + & 2.262300E-03,4.254900E-03,8.187200E-03,1.721300E-02,5.094900E-02,& + & 2.796774E-01,1.413017E+00,4.019777E+00,1.472863E+01,7.608500E-05,& + & 3.657100E-04,1.109200E-03,2.450600E-03,4.793400E-03,9.467300E-03,& + & 2.031000E-02,6.360600E-02,3.503959E-01,1.766000E+00,5.013119E+00,& + & 1.833743E+01,8.196000E-05,3.817700E-04,1.149300E-03,2.556300E-03,& + & 5.324200E-03,1.063100E-02,2.405300E-02,7.679800E-02,4.226461E-01,& + & 2.120142E+00,5.988171E+00,2.182931E+01,8.908500E-05,3.932900E-04,& + & 1.116900E-03,2.716600E-03,5.816900E-03,1.221800E-02,2.866500E-02,& + & 9.184600E-02,5.005839E-01,2.475479E+00,6.895168E+00,2.489138E+01,& + & 9.151100E-05,4.092800E-04,1.076000E-03,2.834300E-03,5.876000E-03,& + & 1.251600E-02,3.107400E-02,1.005600E-01,5.587477E-01,2.824510E+00,& + & 8.038693E+00,2.945713E+01,1.361000E-05,5.344800E-05,1.310500E-04,& + & 2.138500E-04,3.791100E-04,7.796400E-04,1.764100E-03,4.126400E-03,& + & 1.220138E-02,2.731779E-02,3.717822E-02,5.409584E-02,4.485300E-05,& + & 2.288300E-04,6.390500E-04,1.239700E-03,2.283100E-03,4.179600E-03,& + & 8.276000E-03,1.990500E-02,8.225754E-02,4.113359E-01,1.169777E+00,& + & 4.272795E+00,6.037300E-05,2.976700E-04,8.699600E-04,1.802600E-03,& + & 3.352000E-03,5.994700E-03,1.250700E-02,3.167600E-02,1.627420E-01,& + & 8.212099E-01,2.336955E+00,8.533374E+00,7.233600E-05,3.497600E-04,& + & 1.047500E-03,2.222300E-03,4.161900E-03,7.658200E-03,1.626800E-02,& + & 4.494600E-02,2.440309E-01,1.231054E+00,3.501890E+00,1.277862E+01/ + data absa( :,176:200) / & + & 8.211600E-05,3.926900E-04,1.180900E-03,2.565900E-03,4.791300E-03,& + & 9.344600E-03,1.980200E-02,5.933300E-02,3.256776E-01,1.641128E+00,& + & 4.662531E+00,1.699678E+01,9.043600E-05,4.256500E-04,1.276300E-03,& + & 2.789400E-03,5.460500E-03,1.085000E-02,2.377300E-02,7.419100E-02,& + & 4.081203E-01,2.051146E+00,5.814933E+00,2.115659E+01,9.827000E-05,& + & 4.463600E-04,1.328900E-03,2.954500E-03,6.100300E-03,1.233900E-02,& + & 2.836100E-02,8.964000E-02,4.923005E-01,2.460639E+00,6.947546E+00,& + & 2.518263E+01,1.071700E-04,4.598900E-04,1.307800E-03,3.177100E-03,& + & 6.747600E-03,1.438800E-02,3.384600E-02,1.073500E-01,5.831691E-01,& + & 2.871715E+00,8.000517E+00,2.869790E+01,1.099400E-04,4.727700E-04,& + & 1.286900E-03,3.307600E-03,6.803200E-03,1.500900E-02,3.672700E-02,& + & 1.173900E-01,6.506802E-01,3.280676E+00,9.324063E+00,3.399268E+01,& + & 1.221500E-05,4.698800E-05,1.610000E-04,3.137900E-04,5.870100E-04,& + & 1.224100E-03,3.053900E-03,7.845900E-03,2.397711E-02,6.435672E-02,& + & 8.612390E-02,1.327543E-01,2.642900E-05,1.678700E-04,5.063400E-04,& + & 9.342600E-04,1.729400E-03,3.468500E-03,7.320500E-03,1.527300E-02,& + & 4.998379E-02,1.738848E-01,5.390079E-01,2.084248E+00,3.089300E-05,& + & 1.919100E-04,6.166800E-04,1.216600E-03,2.300700E-03,4.404600E-03,& + & 8.956400E-03,2.031500E-02,7.295331E-02,3.446034E-01,1.076573E+00,& + & 4.166067E+00,3.417600E-05,2.064800E-04,6.646700E-04,1.428500E-03,& + & 2.694000E-03,5.084400E-03,9.924000E-03,2.449000E-02,9.966907E-02,& + & 5.159569E-01,1.613665E+00,6.244247E+00,3.653800E-05,2.152500E-04,& + & 6.874500E-04,1.565400E-03,2.967100E-03,5.487100E-03,1.067500E-02,& + & 2.783300E-02,1.291999E-01,6.873539E-01,2.149653E+00,8.317603E+00,& + & 3.789300E-05,2.159600E-04,6.975800E-04,1.640400E-03,3.113400E-03,& + & 5.717900E-03,1.162500E-02,3.020100E-02,1.608923E-01,8.589648E-01,& + & 2.684196E+00,1.037695E+01,3.829200E-05,2.090600E-04,6.853800E-04,& + & 1.596500E-03,3.176800E-03,5.762000E-03,1.242400E-02,3.337800E-02,& + & 1.934735E-01,1.030864E+00,3.214687E+00,1.240606E+01,3.748200E-05,& + & 1.957600E-04,6.209800E-04,1.482800E-03,3.049000E-03,5.981800E-03,& + & 1.264900E-02,3.841100E-02,2.276228E-01,1.204034E+00,3.728921E+00,& + & 1.431645E+01,3.987600E-05,2.061000E-04,6.172100E-04,1.360400E-03,& + & 3.104900E-03,6.147200E-03,1.247500E-02,4.100100E-02,2.563714E-01,& + & 1.372734E+00,4.298223E+00,1.663568E+01,1.408600E-05,5.651000E-05,& + & 1.736500E-04,3.269900E-04,5.930800E-04,1.260100E-03,3.069700E-03,& + & 7.874700E-03,2.397685E-02,6.296974E-02,8.440364E-02,1.292935E-01,& + & 3.190700E-05,1.931700E-04,5.550500E-04,1.035800E-03,1.911100E-03,& + & 3.807100E-03,8.064200E-03,1.689800E-02,5.572027E-02,2.170044E-01,& + & 6.694414E-01,2.591624E+00,3.787400E-05,2.244800E-04,6.825300E-04,& + & 1.378300E-03,2.583500E-03,4.899500E-03,9.955000E-03,2.317600E-02,& + & 8.668900E-02,4.317896E-01,1.337117E+00,5.181033E+00,4.223700E-05,& + & 2.437300E-04,7.560300E-04,1.616300E-03,3.040700E-03,5.715900E-03,& + & 1.116600E-02,2.848700E-02,1.218757E-01,6.465939E-01,2.004518E+00,& + & 7.763965E+00,4.537700E-05,2.521000E-04,7.963100E-04,1.778600E-03,& + & 3.385100E-03,6.211400E-03,1.242800E-02,3.240500E-02,1.603161E-01,& + & 8.616335E-01,2.670694E+00,1.033918E+01,4.737600E-05,2.552100E-04,& + & 8.160000E-04,1.876300E-03,3.584500E-03,6.559700E-03,1.358700E-02,& + & 3.638300E-02,2.001520E-01,1.076661E+00,3.335041E+00,1.289481E+01,& + & 4.797600E-05,2.503200E-04,8.088800E-04,1.853000E-03,3.644500E-03,& + & 6.816400E-03,1.454500E-02,4.143700E-02,2.407143E-01,1.292168E+00,& + & 3.994243E+00,1.541883E+01,4.723900E-05,2.373700E-04,7.380700E-04,& + & 1.739900E-03,3.574600E-03,7.137000E-03,1.522200E-02,4.831600E-02,& + & 2.832088E-01,1.509459E+00,4.634016E+00,1.778425E+01,4.962200E-05,& + & 2.501500E-04,7.143100E-04,1.655500E-03,3.694000E-03,7.350100E-03,& + & 1.493600E-02,5.276900E-02,3.191179E-01,1.721041E+00,5.340143E+00,& + & 2.067818E+01,1.626400E-05,6.609700E-05,1.864800E-04,3.374900E-04,& + & 6.035600E-04,1.292700E-03,3.097800E-03,7.899200E-03,2.395867E-02,& + & 6.123460E-02,8.289874E-02,1.263471E-01,3.816100E-05,2.211100E-04,& + & 6.099200E-04,1.138700E-03,2.118600E-03,4.122400E-03,8.832000E-03,& + & 1.866100E-02,6.226219E-02,2.653156E-01,8.116024E-01,3.147914E+00/ + data absa( :,201:225) / & + & 4.584500E-05,2.590100E-04,7.614100E-04,1.537400E-03,2.886800E-03,& + & 5.438900E-03,1.100100E-02,2.625300E-02,1.022213E-01,5.280757E-01,& + & 1.621444E+00,6.291361E+00,5.147100E-05,2.818200E-04,8.590100E-04,& + & 1.818400E-03,3.424200E-03,6.388900E-03,1.256000E-02,3.254100E-02,& + & 1.470397E-01,7.909500E-01,2.430651E+00,9.429068E+00,5.541200E-05,& + & 2.948000E-04,9.142800E-04,2.017800E-03,3.848600E-03,6.993800E-03,& + & 1.430600E-02,3.755000E-02,1.948375E-01,1.053984E+00,3.238570E+00,& + & 1.255645E+01,5.814500E-05,2.999200E-04,9.470300E-04,2.121500E-03,& + & 4.111200E-03,7.490100E-03,1.580200E-02,4.326600E-02,2.435686E-01,& + & 1.317290E+00,4.044122E+00,1.566297E+01,5.899300E-05,2.985200E-04,& + & 9.431500E-04,2.145300E-03,4.172200E-03,7.976800E-03,1.690600E-02,& + & 5.042200E-02,2.929603E-01,1.581293E+00,4.843873E+00,1.871965E+01,& + & 5.820400E-05,2.834000E-04,8.743200E-04,2.023900E-03,4.194000E-03,& + & 8.369700E-03,1.830200E-02,5.913600E-02,3.446700E-01,1.847331E+00,& + & 5.619558E+00,2.157852E+01,6.096300E-05,3.011100E-04,8.291800E-04,& + & 1.979400E-03,4.360500E-03,8.691800E-03,1.795700E-02,6.552700E-02,& + & 3.884375E-01,2.105419E+00,6.475757E+00,2.511278E+01,1.885800E-05,& + & 7.537300E-05,1.998800E-04,3.480700E-04,6.181800E-04,1.316800E-03,& + & 3.119100E-03,7.898900E-03,2.395310E-02,5.948953E-02,8.155545E-02,& + & 1.237407E-01,4.514200E-05,2.509500E-04,6.707400E-04,1.252900E-03,& + & 2.327800E-03,4.498000E-03,9.528800E-03,2.055800E-02,6.968166E-02,& + & 3.173261E-01,9.654244E-01,3.741536E+00,5.476300E-05,2.969400E-04,& + & 8.487300E-04,1.713100E-03,3.193600E-03,6.011200E-03,1.213000E-02,& + & 2.940800E-02,1.196076E-01,6.319256E-01,1.929066E+00,7.482347E+00,& + & 6.178100E-05,3.243400E-04,9.749600E-04,2.039700E-03,3.832100E-03,& + & 7.119400E-03,1.414800E-02,3.657600E-02,1.749804E-01,9.465057E-01,& + & 2.891821E+00,1.121411E+01,6.683100E-05,3.423100E-04,1.043700E-03,& + & 2.280800E-03,4.335200E-03,7.865400E-03,1.634800E-02,4.321900E-02,& + & 2.325677E-01,1.261495E+00,3.853309E+00,1.493228E+01,7.014400E-05,& + & 3.512500E-04,1.092200E-03,2.405100E-03,4.666600E-03,8.497900E-03,& + & 1.824500E-02,5.094600E-02,2.908187E-01,1.576325E+00,4.811635E+00,& + & 1.862489E+01,7.143900E-05,3.517200E-04,1.091600E-03,2.471800E-03,& + & 4.755200E-03,9.232500E-03,1.966800E-02,6.020700E-02,3.498767E-01,& + & 1.891835E+00,5.762827E+00,2.225720E+01,7.064200E-05,3.362500E-04,& + & 1.026900E-03,2.350200E-03,4.877900E-03,9.761600E-03,2.184900E-02,& + & 7.082100E-02,4.117112E-01,2.210165E+00,6.686505E+00,2.564918E+01,& + & 7.366400E-05,3.572000E-04,9.748900E-04,2.330000E-03,5.111000E-03,& + & 1.018100E-02,2.201000E-02,7.861600E-02,4.639201E-01,2.520241E+00,& + & 7.705156E+00,2.986356E+01,2.168200E-05,8.465300E-05,2.140300E-04,& + & 3.595400E-04,6.353500E-04,1.349900E-03,3.117300E-03,7.922900E-03,& + & 2.388744E-02,5.781970E-02,8.028943E-02,1.212966E-01,5.299500E-05,& + & 2.827100E-04,7.315200E-04,1.377700E-03,2.551200E-03,4.886400E-03,& + & 1.026900E-02,2.251200E-02,7.790560E-02,3.733789E-01,1.128889E+00,& + & 4.370971E+00,6.483200E-05,3.363300E-04,9.477600E-04,1.898200E-03,& + & 3.532200E-03,6.620100E-03,1.328100E-02,3.259900E-02,1.388018E-01,& + & 7.438251E-01,2.255711E+00,8.735956E+00,7.355500E-05,3.710300E-04,& + & 1.095900E-03,2.279600E-03,4.288200E-03,7.869900E-03,1.593700E-02,& + & 4.091300E-02,2.051185E-01,1.114400E+00,3.381447E+00,1.309181E+01,& + & 7.968900E-05,3.954000E-04,1.187600E-03,2.558600E-03,4.867900E-03,& + & 8.797000E-03,1.860400E-02,4.945400E-02,2.730510E-01,1.485250E+00,& + & 4.505843E+00,1.743319E+01,8.368900E-05,4.085400E-04,1.247700E-03,& + & 2.732300E-03,5.235800E-03,9.663200E-03,2.086100E-02,5.939000E-02,& + & 3.415031E-01,1.856193E+00,5.626801E+00,2.174127E+01,8.545100E-05,& + & 4.101700E-04,1.259200E-03,2.823600E-03,5.392100E-03,1.060600E-02,& + & 2.286800E-02,7.072900E-02,4.108684E-01,2.227141E+00,6.739768E+00,& + & 2.598080E+01,8.513700E-05,3.952300E-04,1.199400E-03,2.716100E-03,& + & 5.619900E-03,1.134400E-02,2.590300E-02,8.331300E-02,4.836320E-01,& + & 2.600161E+00,7.821532E+00,2.993699E+01,8.833000E-05,4.091100E-04,& + & 1.155600E-03,2.723700E-03,5.941200E-03,1.181200E-02,2.673500E-02,& + & 9.257300E-02,5.447655E-01,2.968042E+00,9.010165E+00,3.486551E+01/ + data absa( :,226:250) / & + & 1.773700E-05,6.819400E-05,2.378200E-04,4.780000E-04,9.253200E-04,& + & 1.935900E-03,4.957100E-03,1.375500E-02,4.356832E-02,1.255998E-01,& + & 1.755029E-01,2.809499E-01,3.150700E-05,2.111900E-04,5.847300E-04,& + & 1.089000E-03,2.001500E-03,4.195400E-03,9.159600E-03,2.126400E-02,& + & 6.600805E-02,1.768405E-01,4.886133E-01,1.968386E+00,3.468900E-05,& + & 2.251100E-04,7.005700E-04,1.313300E-03,2.527700E-03,5.005000E-03,& + & 1.092000E-02,2.410300E-02,7.980796E-02,2.906028E-01,9.729427E-01,& + & 3.934676E+00,3.592300E-05,2.290500E-04,7.372700E-04,1.465200E-03,& + & 2.842100E-03,5.546200E-03,1.168300E-02,2.571200E-02,9.472907E-02,& + & 4.305324E-01,1.458455E+00,5.899784E+00,3.604200E-05,2.276100E-04,& + & 7.386600E-04,1.569600E-03,3.043700E-03,5.853900E-03,1.194700E-02,& + & 2.779800E-02,1.106423E-01,5.729559E-01,1.943547E+00,7.861304E+00,& + & 3.554700E-05,2.198200E-04,7.062200E-04,1.607700E-03,3.101800E-03,& + & 5.944300E-03,1.180800E-02,2.923600E-02,1.294006E-01,7.155739E-01,& + & 2.427894E+00,9.816849E+00,3.385500E-05,2.018300E-04,6.557800E-04,& + & 1.581600E-03,3.029600E-03,5.741700E-03,1.121200E-02,2.984600E-02,& + & 1.515599E-01,8.584731E-01,2.910456E+00,1.175632E+01,3.088900E-05,& + & 1.711300E-04,5.715200E-04,1.378200E-03,2.822100E-03,5.147300E-03,& + & 1.107400E-02,2.959300E-02,1.770655E-01,1.002576E+00,3.386171E+00,& + & 1.363462E+01,3.370700E-05,1.712900E-04,6.483400E-04,1.154300E-03,& + & 2.604000E-03,5.247200E-03,1.111300E-02,2.758600E-02,1.986054E-01,& + & 1.142698E+00,3.885550E+00,1.572226E+01,2.066200E-05,8.303200E-05,& + & 2.574400E-04,5.013500E-04,9.292800E-04,2.004500E-03,5.002700E-03,& + & 1.378200E-02,4.373914E-02,1.225687E-01,1.722459E-01,2.737597E-01,& + & 3.827000E-05,2.413800E-04,6.519000E-04,1.169200E-03,2.200000E-03,& + & 4.595700E-03,9.996900E-03,2.299900E-02,7.128964E-02,2.033971E-01,& + & 6.138040E-01,2.505962E+00,4.228200E-05,2.626700E-04,7.674400E-04,& + & 1.478900E-03,2.800500E-03,5.537400E-03,1.215700E-02,2.649000E-02,& + & 9.022230E-02,3.679532E-01,1.225700E+00,5.006189E+00,4.393100E-05,& + & 2.705500E-04,8.229600E-04,1.672500E-03,3.177700E-03,6.187600E-03,& + & 1.308200E-02,2.951400E-02,1.112593E-01,5.497349E-01,1.837454E+00,& + & 7.511807E+00,4.491400E-05,2.699500E-04,8.356900E-04,1.787100E-03,& + & 3.446800E-03,6.596400E-03,1.344900E-02,3.245400E-02,1.346000E-01,& + & 7.318072E-01,2.448498E+00,1.000887E+01,4.446300E-05,2.600500E-04,& + & 8.187100E-04,1.834800E-03,3.557700E-03,6.750100E-03,1.342200E-02,& + & 3.449600E-02,1.612462E-01,9.139713E-01,3.058975E+00,1.249766E+01,& + & 4.274400E-05,2.379300E-04,7.702100E-04,1.810600E-03,3.502900E-03,& + & 6.590700E-03,1.315600E-02,3.556600E-02,1.913959E-01,1.096676E+00,& + & 3.667374E+00,1.496315E+01,3.934700E-05,2.077100E-04,6.823200E-04,& + & 1.608000E-03,3.268600E-03,6.058100E-03,1.313400E-02,3.700000E-02,& + & 2.240257E-01,1.280550E+00,4.267532E+00,1.734817E+01,4.179700E-05,& + & 2.105200E-04,7.163900E-04,1.418500E-03,3.087100E-03,6.287200E-03,& + & 1.327900E-02,3.513200E-02,2.533748E-01,1.460148E+00,4.895252E+00,& + & 2.001674E+01,2.412800E-05,9.731600E-05,2.766400E-04,5.225000E-04,& + & 9.481800E-04,2.065600E-03,5.029900E-03,1.386300E-02,4.374344E-02,& + & 1.194270E-01,1.697175E-01,2.673133E-01,4.561300E-05,2.743500E-04,& + & 7.148800E-04,1.268400E-03,2.434200E-03,4.953800E-03,1.094000E-02,& + & 2.466500E-02,7.658309E-02,2.403818E-01,7.532017E-01,3.103146E+00,& + & 5.089800E-05,3.033400E-04,8.523700E-04,1.644700E-03,3.089200E-03,& + & 6.074800E-03,1.340000E-02,2.904200E-02,1.022316E-01,4.566777E-01,& + & 1.504366E+00,6.203272E+00,5.359000E-05,3.141500E-04,9.176200E-04,& + & 1.889300E-03,3.551300E-03,6.877200E-03,1.448100E-02,3.364100E-02,& + & 1.304640E-01,6.829017E-01,2.255074E+00,9.300554E+00,5.496800E-05,& + & 3.160500E-04,9.462200E-04,2.017300E-03,3.878600E-03,7.377800E-03,& + & 1.509000E-02,3.725400E-02,1.623742E-01,9.093383E-01,3.005320E+00,& + & 1.239176E+01,5.480800E-05,3.026900E-04,9.439200E-04,2.084500E-03,& + & 4.048500E-03,7.615700E-03,1.513700E-02,4.014700E-02,1.976859E-01,& + & 1.136085E+00,3.754583E+00,1.547204E+01,5.300000E-05,2.812300E-04,& + & 8.979500E-04,2.064100E-03,4.036700E-03,7.505400E-03,1.533400E-02,& + & 4.199800E-02,2.362329E-01,1.363259E+00,4.501690E+00,1.852752E+01/ + data absa( :,251:275) / & + & 4.894300E-05,2.499000E-04,8.036300E-04,1.876400E-03,3.756400E-03,& + & 7.129100E-03,1.537000E-02,4.540300E-02,2.767432E-01,1.592061E+00,& + & 5.238501E+00,2.147482E+01,5.114700E-05,2.553100E-04,8.067400E-04,& + & 1.697000E-03,3.608400E-03,7.471700E-03,1.578700E-02,4.492100E-02,& + & 3.130546E-01,1.815094E+00,6.008696E+00,2.478164E+01,2.799900E-05,& + & 1.118400E-04,2.975700E-04,5.401000E-04,9.724500E-04,2.123500E-03,& + & 5.040100E-03,1.392100E-02,4.375807E-02,1.160891E-01,1.673891E-01,& + & 2.616350E-01,5.390700E-05,3.098400E-04,7.768900E-04,1.389000E-03,& + & 2.668800E-03,5.311700E-03,1.187200E-02,2.630900E-02,8.250676E-02,& + & 2.842568E-01,9.051063E-01,3.749661E+00,6.095500E-05,3.468000E-04,& + & 9.366900E-04,1.835000E-03,3.406000E-03,6.641800E-03,1.461600E-02,& + & 3.193700E-02,1.156577E-01,5.543885E-01,1.807813E+00,7.494043E+00,& + & 6.442300E-05,3.622800E-04,1.021200E-03,2.114300E-03,3.952700E-03,& + & 7.604200E-03,1.594700E-02,3.787400E-02,1.522968E-01,8.294220E-01,& + & 2.710402E+00,1.123731E+01,6.644200E-05,3.630300E-04,1.075000E-03,& + & 2.273100E-03,4.341600E-03,8.237400E-03,1.677800E-02,4.233200E-02,& + & 1.934762E-01,1.104640E+00,3.612647E+00,1.497286E+01,6.660500E-05,& + & 3.516500E-04,1.079300E-03,2.359100E-03,4.575400E-03,8.558900E-03,& + & 1.708700E-02,4.598000E-02,2.383397E-01,1.380388E+00,4.512786E+00,& + & 1.869357E+01,6.460400E-05,3.298900E-04,1.039400E-03,2.347600E-03,& + & 4.614000E-03,8.517300E-03,1.773400E-02,4.916100E-02,2.855101E-01,& + & 1.656399E+00,5.410908E+00,2.237976E+01,5.987800E-05,2.965400E-04,& + & 9.392000E-04,2.176200E-03,4.316100E-03,8.315300E-03,1.786800E-02,& + & 5.471900E-02,3.345647E-01,1.934156E+00,6.297155E+00,2.593597E+01,& + & 6.151600E-05,3.071500E-04,9.247800E-04,2.006100E-03,4.242700E-03,& + & 8.734500E-03,1.854800E-02,5.571300E-02,3.786870E-01,2.205621E+00,& + & 7.223173E+00,2.994484E+01,3.215200E-05,1.263200E-04,3.201300E-04,& + & 5.608600E-04,9.933900E-04,2.170800E-03,5.092900E-03,1.401000E-02,& + & 4.351860E-02,1.134600E-01,1.651662E-01,2.562725E-01,6.356400E-05,& + & 3.468300E-04,8.483300E-04,1.515200E-03,2.915800E-03,5.702200E-03,& + & 1.279900E-02,2.795500E-02,8.893562E-02,3.345646E-01,1.067949E+00,& + & 4.435217E+00,7.201200E-05,3.931800E-04,1.024900E-03,2.032300E-03,& + & 3.742600E-03,7.275800E-03,1.586600E-02,3.511900E-02,1.303843E-01,& + & 6.606124E-01,2.133522E+00,8.865897E+00,7.669200E-05,4.120500E-04,& + & 1.144300E-03,2.352200E-03,4.363000E-03,8.407100E-03,1.755100E-02,& + & 4.203400E-02,1.767013E-01,9.888111E-01,3.198467E+00,1.329178E+01,& + & 7.946300E-05,4.156800E-04,1.215000E-03,2.543400E-03,4.850300E-03,& + & 9.162300E-03,1.858400E-02,4.754500E-02,2.278450E-01,1.317355E+00,& + & 4.263034E+00,1.770925E+01,7.982300E-05,4.057200E-04,1.231300E-03,& + & 2.658500E-03,5.143600E-03,9.567800E-03,1.941400E-02,5.214800E-02,& + & 2.824933E-01,1.646165E+00,5.326322E+00,2.211162E+01,7.757300E-05,& + & 3.858400E-04,1.196200E-03,2.664600E-03,5.216600E-03,9.586000E-03,& + & 2.041000E-02,5.716300E-02,3.388862E-01,1.975445E+00,6.385954E+00,& + & 2.647263E+01,7.228100E-05,3.479400E-04,1.092600E-03,2.504300E-03,& + & 4.908200E-03,9.619700E-03,2.081600E-02,6.483300E-02,3.971257E-01,& + & 2.307248E+00,7.431494E+00,3.067606E+01,7.408100E-05,3.633400E-04,& + & 1.055800E-03,2.358000E-03,4.937800E-03,1.011800E-02,2.171300E-02,& + & 6.748000E-02,4.497488E-01,2.630916E+00,8.524023E+00,3.541638E+01,& + & 2.688000E-05,1.038200E-04,3.722600E-04,7.647200E-04,1.530200E-03,& + & 3.208800E-03,8.431400E-03,2.476200E-02,8.337233E-02,2.601728E-01,& + & 3.834327E-01,6.308500E-01,4.145100E-05,2.639500E-04,7.212200E-04,& + & 1.410300E-03,2.541400E-03,5.397600E-03,1.246300E-02,3.177500E-02,& + & 1.002277E-01,2.818302E-01,5.168263E-01,1.833925E+00,4.215300E-05,& + & 2.898900E-04,8.227300E-04,1.581100E-03,2.954000E-03,6.115200E-03,& + & 1.384300E-02,3.374900E-02,1.091057E-01,3.115614E-01,8.745464E-01,& + & 3.666276E+00,4.179500E-05,2.807600E-04,8.742400E-04,1.652100E-03,& + & 3.197400E-03,6.427300E-03,1.440700E-02,3.417600E-02,1.134741E-01,& + & 3.745665E-01,1.297553E+00,5.498033E+00,4.007100E-05,2.634400E-04,& + & 8.490500E-04,1.670000E-03,3.310300E-03,6.556500E-03,1.432900E-02,& + & 3.332300E-02,1.157271E-01,4.748926E-01,1.729197E+00,7.328018E+00/ + data absa( :,276:300) / & + & 3.701000E-05,2.407100E-04,7.950400E-04,1.635500E-03,3.279200E-03,& + & 6.416900E-03,1.364300E-02,3.106000E-02,1.201791E-01,5.890521E-01,& + & 2.160128E+00,9.155630E+00,3.293500E-05,2.110600E-04,6.860000E-04,& + & 1.571600E-03,3.062600E-03,6.048300E-03,1.242300E-02,2.925400E-02,& + & 1.259159E-01,7.061845E-01,2.590931E+00,1.097608E+01,2.715700E-05,& + & 1.679100E-04,5.474800E-04,1.365500E-03,2.647700E-03,5.171800E-03,& + & 1.039800E-02,2.675000E-02,1.366192E-01,8.238647E-01,3.019049E+00,& + & 1.276524E+01,3.016500E-05,1.451600E-04,6.475700E-04,1.195300E-03,& + & 2.229600E-03,4.384000E-03,1.004900E-02,2.628700E-02,1.388860E-01,& + & 9.396533E-01,3.456127E+00,1.465498E+01,3.186700E-05,1.271300E-04,& + & 4.047100E-04,8.040500E-04,1.543700E-03,3.332900E-03,8.487700E-03,& + & 2.495100E-02,8.363629E-02,2.548977E-01,3.774700E-01,6.145722E-01,& + & 5.044900E-05,3.063500E-04,8.058000E-04,1.482000E-03,2.806900E-03,& + & 5.861700E-03,1.342600E-02,3.387000E-02,1.065849E-01,2.943915E-01,& + & 6.049893E-01,2.395929E+00,5.195000E-05,3.355000E-04,9.224100E-04,& + & 1.718200E-03,3.272500E-03,6.706500E-03,1.523700E-02,3.672900E-02,& + & 1.189452E-01,3.561212E-01,1.109039E+00,4.791259E+00,5.135000E-05,& + & 3.289700E-04,9.629000E-04,1.843200E-03,3.573000E-03,7.129300E-03,& + & 1.609900E-02,3.770000E-02,1.261396E-01,4.703433E-01,1.660817E+00,& + & 7.182430E+00,4.950200E-05,3.119600E-04,9.485600E-04,1.904000E-03,& + & 3.689400E-03,7.333200E-03,1.614300E-02,3.712500E-02,1.338844E-01,& + & 6.138322E-01,2.213289E+00,9.572997E+00,4.611700E-05,2.882400E-04,& + & 8.943600E-04,1.883900E-03,3.700000E-03,7.248300E-03,1.546500E-02,& + & 3.564500E-02,1.442099E-01,7.659318E-01,2.765789E+00,1.195931E+01,& + & 4.153600E-05,2.528800E-04,7.908800E-04,1.800400E-03,3.514100E-03,& + & 6.899100E-03,1.414300E-02,3.472500E-02,1.564949E-01,9.183812E-01,& + & 3.316844E+00,1.433551E+01,3.478200E-05,2.003100E-04,6.502400E-04,& + & 1.583600E-03,3.086600E-03,6.007000E-03,1.198000E-02,3.238200E-02,& + & 1.751086E-01,1.071543E+00,3.865093E+00,1.667609E+01,3.742000E-05,& + & 1.814300E-04,7.690600E-04,1.324500E-03,2.751700E-03,5.189300E-03,& + & 1.191200E-02,3.236300E-02,1.835600E-01,1.222124E+00,4.424012E+00,& + & 1.913039E+01,3.727400E-05,1.512600E-04,4.348500E-04,8.397600E-04,& + & 1.582800E-03,3.452600E-03,8.506100E-03,2.517300E-02,8.393132E-02,& + & 2.477800E-01,3.722313E-01,6.003385E-01,6.053700E-05,3.504700E-04,& + & 8.872800E-04,1.592500E-03,3.066300E-03,6.321500E-03,1.445000E-02,& + & 3.583700E-02,1.130105E-01,3.120103E-01,7.176215E-01,3.029725E+00,& + & 6.261000E-05,3.851000E-04,1.020100E-03,1.870600E-03,3.614300E-03,& + & 7.290700E-03,1.673900E-02,3.966000E-02,1.290767E-01,4.163860E-01,& + & 1.378783E+00,6.056626E+00,6.228000E-05,3.806800E-04,1.066400E-03,& + & 2.054700E-03,3.945100E-03,7.848400E-03,1.786500E-02,4.120600E-02,& + & 1.409599E-01,5.848848E-01,2.066623E+00,9.081945E+00,6.035500E-05,& + & 3.646600E-04,1.059800E-03,2.151100E-03,4.119500E-03,8.110500E-03,& + & 1.800600E-02,4.134600E-02,1.549341E-01,7.742026E-01,2.754332E+00,& + & 1.210412E+01,5.684800E-05,3.388900E-04,1.004600E-03,2.158000E-03,& + & 4.157600E-03,8.124400E-03,1.737600E-02,4.102900E-02,1.718766E-01,& + & 9.664569E-01,3.441408E+00,1.512312E+01,5.145700E-05,2.960000E-04,& + & 9.143400E-04,2.049700E-03,4.016300E-03,7.796100E-03,1.599800E-02,& + & 4.047100E-02,1.923348E-01,1.159073E+00,4.127828E+00,1.812615E+01,& + & 4.365800E-05,2.379000E-04,7.647100E-04,1.815100E-03,3.582200E-03,& + & 6.901200E-03,1.386800E-02,3.851800E-02,2.193327E-01,1.352733E+00,& + & 4.809935E+00,2.107862E+01,4.558600E-05,2.232300E-04,8.834500E-04,& + & 1.513600E-03,3.303200E-03,6.111500E-03,1.396200E-02,3.891300E-02,& + & 2.350835E-01,1.542843E+00,5.505858E+00,2.420637E+01,4.331500E-05,& + & 1.745300E-04,4.677900E-04,8.760600E-04,1.619600E-03,3.539800E-03,& + & 8.591900E-03,2.536300E-02,8.375828E-02,2.434328E-01,3.659193E-01,& + & 5.882809E-01,7.193100E-05,3.974900E-04,9.694000E-04,1.704400E-03,& + & 3.325700E-03,6.784100E-03,1.549000E-02,3.788600E-02,1.196351E-01,& + & 3.338363E-01,8.511913E-01,3.722283E+00,7.451100E-05,4.356900E-04,& + & 1.121400E-03,2.055200E-03,3.957800E-03,7.906900E-03,1.825000E-02,& + & 4.259900E-02,1.395584E-01,4.939673E-01,1.677696E+00,7.443642E+00/ + data absa( :,301:325) / & + & 7.500500E-05,4.370800E-04,1.180200E-03,2.284500E-03,4.383400E-03,& + & 8.544800E-03,1.963200E-02,4.502800E-02,1.575208E-01,7.156791E-01,& + & 2.514844E+00,1.116282E+01,7.273100E-05,4.216600E-04,1.177100E-03,& + & 2.421200E-03,4.585300E-03,8.961300E-03,1.993300E-02,4.561600E-02,& + & 1.793471E-01,9.516710E-01,3.351880E+00,1.487708E+01,6.891600E-05,& + & 3.908500E-04,1.131700E-03,2.443300E-03,4.660600E-03,9.060800E-03,& + & 1.934300E-02,4.671300E-02,2.036154E-01,1.188253E+00,4.187939E+00,& + & 1.858160E+01,6.290400E-05,3.447400E-04,1.050600E-03,2.331200E-03,& + & 4.538500E-03,8.776000E-03,1.797800E-02,4.661300E-02,2.329216E-01,& + & 1.425473E+00,5.023320E+00,2.227681E+01,5.375500E-05,2.807400E-04,& + & 8.948700E-04,2.067100E-03,4.126100E-03,7.876800E-03,1.612000E-02,& + & 4.520400E-02,2.686993E-01,1.663765E+00,5.853860E+00,2.589922E+01,& + & 5.526400E-05,2.713700E-04,9.787000E-04,1.768500E-03,3.900000E-03,& + & 7.103000E-03,1.634600E-02,4.591600E-02,2.929245E-01,1.897547E+00,& + & 6.700617E+00,2.975217E+01,4.990700E-05,1.981500E-04,5.056400E-04,& + & 9.106500E-04,1.666000E-03,3.641900E-03,8.624400E-03,2.555400E-02,& + & 8.341465E-02,2.393531E-01,3.601655E-01,5.781586E-01,8.468300E-05,& + & 4.470000E-04,1.049300E-03,1.836800E-03,3.617900E-03,7.210000E-03,& + & 1.654600E-02,3.991300E-02,1.262551E-01,3.614062E-01,1.005304E+00,& + & 4.465962E+00,8.854200E-05,4.902000E-04,1.228500E-03,2.256300E-03,& + & 4.345100E-03,8.521800E-03,1.976200E-02,4.572500E-02,1.509450E-01,& + & 5.837133E-01,2.001408E+00,8.928038E+00,8.929200E-05,4.960800E-04,& + & 1.298900E-03,2.547200E-03,4.822600E-03,9.303600E-03,2.147500E-02,& + & 4.875700E-02,1.763534E-01,8.612265E-01,3.000268E+00,1.338716E+01,& + & 8.663100E-05,4.831600E-04,1.310300E-03,2.705400E-03,5.066800E-03,& + & 9.895900E-03,2.190700E-02,5.039800E-02,2.064846E-01,1.146253E+00,& + & 3.998699E+00,1.784239E+01,8.254900E-05,4.484500E-04,1.282200E-03,& + & 2.738400E-03,5.193000E-03,1.007300E-02,2.141400E-02,5.253200E-02,& + & 2.394456E-01,1.431638E+00,4.996764E+00,2.228977E+01,7.607700E-05,& + & 4.000700E-04,1.200400E-03,2.628400E-03,5.118000E-03,9.850500E-03,& + & 2.009900E-02,5.311800E-02,2.781773E-01,1.717092E+00,5.993378E+00,& + & 2.671872E+01,6.524200E-05,3.281100E-04,1.039900E-03,2.351300E-03,& + & 4.703000E-03,8.929200E-03,1.861700E-02,5.271800E-02,3.228690E-01,& + & 2.004760E+00,6.984319E+00,3.106516E+01,6.589200E-05,3.252900E-04,& + & 1.082700E-03,2.061200E-03,4.547400E-03,8.230800E-03,1.911300E-02,& + & 5.334100E-02,3.566778E-01,2.286443E+00,7.993982E+00,3.568267E+01,& + & 4.762700E-05,1.856800E-04,6.883400E-04,1.436200E-03,2.960200E-03,& + & 6.273400E-03,1.680100E-02,5.177200E-02,1.862734E-01,6.363905E-01,& + & 9.980359E-01,1.669560E+00,6.486400E-05,3.752200E-04,1.049700E-03,& + & 2.140200E-03,3.930400E-03,8.192900E-03,2.016600E-02,5.674200E-02,& + & 1.885187E-01,6.110210E-01,9.504116E-01,2.003783E+00,6.352100E-05,& + & 4.044100E-04,1.135400E-03,2.273300E-03,4.158000E-03,8.734700E-03,& + & 2.070700E-02,5.631100E-02,1.874087E-01,5.802795E-01,1.035855E+00,& + & 3.414195E+00,5.901800E-05,4.040000E-04,1.140300E-03,2.257900E-03,& + & 4.222800E-03,8.839600E-03,2.035900E-02,5.367600E-02,1.807764E-01,& + & 5.497997E-01,1.228876E+00,5.120397E+00,5.310800E-05,3.710100E-04,& + & 1.109100E-03,2.154700E-03,4.116500E-03,8.549800E-03,1.943800E-02,& + & 4.976100E-02,1.693072E-01,5.262593E-01,1.529224E+00,6.826614E+00,& + & 4.657100E-05,3.209000E-04,1.028200E-03,1.968600E-03,3.914700E-03,& + & 7.915300E-03,1.788900E-02,4.443200E-02,1.542388E-01,5.285565E-01,& + & 1.885183E+00,8.530816E+00,3.865000E-05,2.601400E-04,8.692200E-04,& + & 1.719600E-03,3.521600E-03,7.034600E-03,1.555600E-02,3.764200E-02,& + & 1.351899E-01,5.809261E-01,2.261285E+00,1.023249E+01,2.847300E-05,& + & 1.874100E-04,6.217900E-04,1.417700E-03,2.826500E-03,5.680800E-03,& + & 1.209300E-02,2.815900E-02,1.189287E-01,6.691742E-01,2.636398E+00,& + & 1.192031E+01,2.913500E-05,1.409300E-04,6.439400E-04,1.460300E-03,& + & 2.224200E-03,4.155200E-03,8.868700E-03,2.536600E-02,9.259190E-02,& + & 7.455762E-01,3.013751E+00,1.365240E+01,5.776700E-05,2.270600E-04,& + & 7.526200E-04,1.519600E-03,2.999600E-03,6.544100E-03,1.684100E-02,& + & 5.231000E-02,1.877413E-01,6.215888E-01,9.833599E-01,1.627974E+00/ + data absa( :,326:350) / & + & 7.903600E-05,4.410000E-04,1.171900E-03,2.263500E-03,4.266800E-03,& + & 8.858000E-03,2.125800E-02,5.993500E-02,1.969639E-01,6.140468E-01,& + & 9.936196E-01,2.388162E+00,7.775100E-05,4.733100E-04,1.271100E-03,& + & 2.411100E-03,4.602800E-03,9.510800E-03,2.246000E-02,6.010300E-02,& + & 1.998261E-01,6.063824E-01,1.176840E+00,4.533561E+00,7.301200E-05,& + & 4.694100E-04,1.284700E-03,2.449500E-03,4.680600E-03,9.702400E-03,& + & 2.238100E-02,5.824300E-02,1.957997E-01,5.938426E-01,1.532992E+00,& + & 6.797547E+00,6.627900E-05,4.333000E-04,1.249800E-03,2.364200E-03,& + & 4.621200E-03,9.365300E-03,2.160500E-02,5.486100E-02,1.866651E-01,& + & 6.036116E-01,1.982753E+00,9.063017E+00,5.814800E-05,3.793300E-04,& + & 1.135600E-03,2.225800E-03,4.385900E-03,8.836400E-03,2.012400E-02,& + & 4.953000E-02,1.728652E-01,6.597870E-01,2.472422E+00,1.132397E+01,& + & 4.845900E-05,3.111600E-04,9.717700E-04,1.989100E-03,3.954200E-03,& + & 7.948000E-03,1.763200E-02,4.256000E-02,1.576494E-01,7.634422E-01,& + & 2.965623E+00,1.358419E+01,3.630300E-05,2.275300E-04,7.170000E-04,& + & 1.644400E-03,3.244700E-03,6.530400E-03,1.392800E-02,3.294200E-02,& + & 1.478072E-01,8.880113E-01,3.458190E+00,1.582747E+01,3.655200E-05,& + & 1.755000E-04,7.544900E-04,1.717300E-03,2.516500E-03,4.981300E-03,& + & 1.051300E-02,3.079600E-02,1.246987E-01,1.012843E+00,3.953315E+00,& + & 1.812368E+01,6.833100E-05,2.731300E-04,8.119600E-04,1.586300E-03,& + & 3.079000E-03,6.793800E-03,1.694500E-02,5.280300E-02,1.880972E-01,& + & 6.115738E-01,9.670336E-01,1.595821E+00,9.516100E-05,5.068100E-04,& + & 1.292500E-03,2.388200E-03,4.644000E-03,9.521200E-03,2.238900E-02,& + & 6.303700E-02,2.054188E-01,6.239859E-01,1.040309E+00,2.947708E+00,& + & 9.398000E-05,5.466500E-04,1.407500E-03,2.586900E-03,5.025600E-03,& + & 1.031200E-02,2.413800E-02,6.413400E-02,2.124677E-01,6.365553E-01,& + & 1.366191E+00,5.855958E+00,8.874100E-05,5.404100E-04,1.422100E-03,& + & 2.658800E-03,5.144700E-03,1.057300E-02,2.452500E-02,6.276600E-02,& + & 2.113698E-01,6.534275E-01,1.894656E+00,8.781436E+00,8.090100E-05,& + & 5.032800E-04,1.388600E-03,2.595200E-03,5.134800E-03,1.026000E-02,& + & 2.396800E-02,5.964500E-02,2.049351E-01,7.080994E-01,2.501329E+00,& + & 1.170598E+01,7.127900E-05,4.429900E-04,1.265200E-03,2.502500E-03,& + & 4.889200E-03,9.737600E-03,2.249800E-02,5.465500E-02,1.937778E-01,& + & 8.247301E-01,3.125357E+00,1.462863E+01,5.968200E-05,3.662600E-04,& + & 1.089800E-03,2.278000E-03,4.443000E-03,8.872800E-03,1.983600E-02,& + & 4.786400E-02,1.840337E-01,9.756488E-01,3.748823E+00,1.754745E+01,& + & 4.531400E-05,2.670600E-04,8.294600E-04,1.881900E-03,3.728700E-03,& + & 7.430600E-03,1.579200E-02,3.868800E-02,1.814793E-01,1.137037E+00,& + & 4.371440E+00,2.044446E+01,4.411200E-05,2.151200E-04,8.816400E-04,& + & 1.890800E-03,2.938600E-03,5.966100E-03,1.222400E-02,3.714300E-02,& + & 1.649007E-01,1.296971E+00,4.997786E+00,2.340896E+01,7.989400E-05,& + & 3.205000E-04,8.735700E-04,1.658800E-03,3.146700E-03,6.976300E-03,& + & 1.708100E-02,5.346000E-02,1.877160E-01,6.038578E-01,9.498765E-01,& + & 1.568947E+00,1.132000E-04,5.778400E-04,1.411900E-03,2.517700E-03,& + & 5.051500E-03,1.016000E-02,2.361000E-02,6.591800E-02,2.139566E-01,& + & 6.371635E-01,1.098135E+00,3.664566E+00,1.126300E-04,6.246900E-04,& + & 1.546200E-03,2.779200E-03,5.465500E-03,1.110700E-02,2.590300E-02,& + & 6.800300E-02,2.254149E-01,6.721078E-01,1.607874E+00,7.326263E+00,& + & 1.064600E-04,6.176600E-04,1.566200E-03,2.895400E-03,5.629500E-03,& + & 1.142000E-02,2.668200E-02,6.727100E-02,2.278338E-01,7.283873E-01,& + & 2.316606E+00,1.098336E+01,9.741300E-05,5.779900E-04,1.523400E-03,& + & 2.890800E-03,5.644000E-03,1.119300E-02,2.635100E-02,6.471100E-02,& + & 2.238624E-01,8.438656E-01,3.081803E+00,1.464064E+01,8.662600E-05,& + & 5.131000E-04,1.406600E-03,2.799000E-03,5.453200E-03,1.068400E-02,& + & 2.488400E-02,6.013200E-02,2.174118E-01,1.018278E+00,3.850431E+00,& + & 1.829566E+01,7.254000E-05,4.271200E-04,1.218700E-03,2.591500E-03,& + & 4.968900E-03,9.858100E-03,2.219700E-02,5.321500E-02,2.150160E-01,& + & 1.215802E+00,4.618965E+00,2.194457E+01,5.566700E-05,3.123700E-04,& + & 9.558300E-04,2.155800E-03,4.234700E-03,8.399000E-03,1.779000E-02,& + & 4.472400E-02,2.205937E-01,1.417478E+00,5.386643E+00,2.556471E+01/ + data absa( :,351:375) / & + & 5.299600E-05,2.586400E-04,1.026300E-03,2.033300E-03,3.515000E-03,& + & 6.964400E-03,1.413300E-02,4.400500E-02,2.110785E-01,1.617180E+00,& + & 6.158417E+00,2.927653E+01,9.297200E-05,3.649200E-04,9.477600E-04,& + & 1.736700E-03,3.247300E-03,7.191200E-03,1.710700E-02,5.371000E-02,& + & 1.875515E-01,5.961259E-01,9.334339E-01,1.543986E+00,1.343700E-04,& + & 6.497200E-04,1.535100E-03,2.693500E-03,5.431900E-03,1.083200E-02,& + & 2.483100E-02,6.869900E-02,2.224125E-01,6.519705E-01,1.181535E+00,& + & 4.460038E+00,1.332000E-04,7.063200E-04,1.677900E-03,3.001700E-03,& + & 5.909900E-03,1.197900E-02,2.768100E-02,7.163300E-02,2.384373E-01,& + & 7.186388E-01,1.893555E+00,8.914137E+00,1.265100E-04,6.992600E-04,& + & 1.719100E-03,3.161900E-03,6.151300E-03,1.231900E-02,2.881400E-02,& + & 7.203600E-02,2.442280E-01,8.250575E-01,2.788619E+00,1.336775E+01,& + & 1.164800E-04,6.556300E-04,1.676000E-03,3.206500E-03,6.242100E-03,& + & 1.208400E-02,2.876600E-02,6.988700E-02,2.443577E-01,1.007198E+00,& + & 3.716283E+00,1.781953E+01,1.038900E-04,5.853500E-04,1.554100E-03,& + & 3.129700E-03,6.060600E-03,1.164600E-02,2.745300E-02,6.552000E-02,& + & 2.445919E-01,1.236847E+00,4.643714E+00,2.226797E+01,8.724900E-05,& + & 4.897200E-04,1.371100E-03,2.914700E-03,5.548300E-03,1.094200E-02,& + & 2.461000E-02,5.869400E-02,2.508367E-01,1.481391E+00,5.570649E+00,& + & 2.670907E+01,6.759000E-05,3.648700E-04,1.094200E-03,2.452500E-03,& + & 4.775200E-03,9.460500E-03,1.991400E-02,5.114300E-02,2.650626E-01,& + & 1.727158E+00,6.495640E+00,3.111513E+01,6.337100E-05,3.108500E-04,& + & 1.186600E-03,2.176500E-03,4.147600E-03,8.007900E-03,1.638300E-02,& + & 5.130500E-02,2.631843E-01,1.970898E+00,7.426923E+00,3.563319E+01,& + & 1.579900E-04,6.259900E-04,2.403000E-03,5.137700E-03,1.071500E-02,& + & 2.342300E-02,6.271700E-02,2.019800E-01,7.833600E-01,2.917122E+00,& + & 4.878413E+00,8.398051E+00,1.883300E-04,8.665400E-04,2.811600E-03,& + & 5.687900E-03,1.138200E-02,2.387400E-02,6.273500E-02,1.890100E-01,& + & 7.042916E-01,2.574619E+00,4.268847E+00,7.348018E+00,1.755000E-04,& + & 9.063400E-04,2.749000E-03,5.641300E-03,1.089900E-02,2.257000E-02,& + & 5.860300E-02,1.740300E-01,6.305292E-01,2.274526E+00,3.747644E+00,& + & 6.471021E+00,1.561200E-04,8.893700E-04,2.578200E-03,5.377600E-03,& + & 1.000700E-02,2.090700E-02,5.274800E-02,1.556600E-01,5.545386E-01,& + & 1.985692E+00,3.242259E+00,6.357064E+00,1.338000E-04,8.114000E-04,& + & 2.373900E-03,4.822400E-03,9.043700E-03,1.874700E-02,4.626300E-02,& + & 1.346000E-01,4.758386E-01,1.664296E+00,2.845793E+00,6.718319E+00,& + & 1.091800E-04,7.102700E-04,2.045100E-03,4.168900E-03,7.697600E-03,& + & 1.627900E-02,3.911700E-02,1.105000E-01,3.927772E-01,1.349557E+00,& + & 2.451951E+00,7.915285E+00,8.206300E-05,5.716700E-04,1.635200E-03,& + & 3.332500E-03,6.282500E-03,1.326800E-02,3.075900E-02,8.442300E-02,& + & 3.027094E-01,1.017973E+00,2.206840E+00,9.494726E+00,5.124100E-05,& + & 3.573500E-04,1.152500E-03,2.248100E-03,4.497100E-03,9.196700E-03,& + & 2.108700E-02,5.504900E-02,1.998658E-01,6.878751E-01,2.268948E+00,& + & 1.107348E+01,3.534100E-05,2.098200E-04,7.839700E-04,2.012200E-03,& + & 3.765200E-03,5.447200E-03,9.920000E-03,2.740900E-02,1.282164E-01,& + & 3.504483E-01,1.861273E+00,1.266179E+01,1.944300E-04,7.762700E-04,& + & 2.640600E-03,5.451100E-03,1.090900E-02,2.437200E-02,6.309400E-02,& + & 2.049500E-01,7.897211E-01,2.861508E+00,4.812525E+00,8.176760E+00,& + & 2.281900E-04,1.070400E-03,3.078000E-03,6.154800E-03,1.186200E-02,& + & 2.548700E-02,6.467000E-02,1.963900E-01,7.179416E-01,2.541144E+00,& + & 4.231700E+00,7.154676E+00,2.147100E-04,1.104300E-03,3.031100E-03,& + & 6.133200E-03,1.139700E-02,2.452600E-02,6.060200E-02,1.829100E-01,& + & 6.500266E-01,2.286279E+00,3.738710E+00,6.816335E+00,1.924400E-04,& + & 1.058600E-03,2.888000E-03,5.718500E-03,1.077700E-02,2.280600E-02,& + & 5.539200E-02,1.651900E-01,5.792518E-01,1.996989E+00,3.355271E+00,& + & 7.314733E+00,1.656600E-04,9.603200E-04,2.656200E-03,5.159300E-03,& + & 9.887700E-03,2.043000E-02,4.942000E-02,1.430500E-01,5.040053E-01,& + & 1.712633E+00,3.015299E+00,8.634358E+00,1.358700E-04,8.399500E-04,& + & 2.301200E-03,4.455100E-03,8.593700E-03,1.772100E-02,4.255800E-02,& + & 1.188100E-01,4.218319E-01,1.416041E+00,2.753640E+00,1.069894E+01/ + data absa( :,376:400) / & + & 1.032000E-04,6.654700E-04,1.857900E-03,3.630200E-03,7.075500E-03,& + & 1.454700E-02,3.400200E-02,9.224500E-02,3.309163E-01,1.097253E+00,& + & 2.744503E+00,1.283665E+01,6.453600E-05,4.263600E-04,1.294200E-03,& + & 2.523400E-03,5.093800E-03,1.025700E-02,2.373300E-02,6.178700E-02,& + & 2.241040E-01,8.218026E-01,3.031025E+00,1.496910E+01,4.519500E-05,& + & 2.583200E-04,9.530500E-04,2.367300E-03,4.250700E-03,5.887400E-03,& + & 1.213800E-02,3.366300E-02,1.573318E-01,4.519616E-01,2.882664E+00,& + & 1.711586E+01,2.362200E-04,9.379400E-04,2.858800E-03,5.701400E-03,& + & 1.124600E-02,2.532200E-02,6.356300E-02,2.077500E-01,7.929547E-01,& + & 2.818782E+00,4.727337E+00,8.034306E+00,2.768500E-04,1.261900E-03,& + & 3.382600E-03,6.572900E-03,1.241800E-02,2.722800E-02,6.626900E-02,& + & 2.035900E-01,7.307813E-01,2.522230E+00,4.199942E+00,7.059151E+00,& + & 2.605700E-04,1.294900E-03,3.333100E-03,6.525000E-03,1.229300E-02,& + & 2.622800E-02,6.305800E-02,1.917300E-01,6.687322E-01,2.295798E+00,& + & 3.783792E+00,7.380295E+00,2.344500E-04,1.228400E-03,3.200300E-03,& + & 6.083000E-03,1.170100E-02,2.457600E-02,5.835700E-02,1.737000E-01,& + & 6.049078E-01,2.026505E+00,3.491575E+00,8.753738E+00,2.027600E-04,& + & 1.115600E-03,2.949100E-03,5.450700E-03,1.088000E-02,2.216400E-02,& + & 5.263200E-02,1.521200E-01,5.326505E-01,1.770383E+00,3.230474E+00,& + & 1.120352E+01,1.667100E-04,9.718200E-04,2.564500E-03,4.794100E-03,& + & 9.488900E-03,1.936500E-02,4.574300E-02,1.275200E-01,4.518592E-01,& + & 1.488443E+00,3.186666E+00,1.400302E+01,1.265100E-04,7.697900E-04,& + & 2.082200E-03,3.945100E-03,7.824400E-03,1.592100E-02,3.726100E-02,& + & 1.002800E-01,3.600319E-01,1.197465E+00,3.425690E+00,1.680008E+01,& + & 7.979700E-05,5.010900E-04,1.432000E-03,2.856100E-03,5.671800E-03,& + & 1.138900E-02,2.659400E-02,6.852000E-02,2.504051E-01,9.998411E-01,& + & 3.912860E+00,1.959203E+01,5.688200E-05,3.197300E-04,1.137100E-03,& + & 2.724900E-03,4.521300E-03,6.816800E-03,1.471600E-02,3.955600E-02,& + & 1.873129E-01,5.646143E-01,4.137157E+00,2.239594E+01,2.782800E-04,& + & 1.111400E-03,3.075100E-03,5.987600E-03,1.148400E-02,2.614400E-02,& + & 6.400500E-02,2.097100E-01,7.964425E-01,2.765825E+00,4.656747E+00,& + & 7.909881E+00,3.313900E-04,1.453700E-03,3.683700E-03,6.949100E-03,& + & 1.324500E-02,2.870900E-02,6.800500E-02,2.103300E-01,7.423799E-01,& + & 2.514743E+00,4.172559E+00,7.128990E+00,3.121000E-04,1.472200E-03,& + & 3.652100E-03,6.926600E-03,1.325200E-02,2.795800E-02,6.555600E-02,& + & 1.995900E-01,6.886917E-01,2.307089E+00,3.872718E+00,8.140800E+00,& + & 2.814600E-04,1.403000E-03,3.517200E-03,6.399400E-03,1.281600E-02,& + & 2.636600E-02,6.146600E-02,1.817300E-01,6.310030E-01,2.074937E+00,& + & 3.624917E+00,1.077032E+01,2.441300E-04,1.280200E-03,3.233000E-03,& + & 5.866500E-03,1.185000E-02,2.379100E-02,5.612100E-02,1.605200E-01,& + & 5.619579E-01,1.834638E+00,3.540248E+00,1.423145E+01,2.007100E-04,& + & 1.117700E-03,2.826600E-03,5.209400E-03,1.032800E-02,2.097900E-02,& + & 4.930200E-02,1.361900E-01,4.823466E-01,1.573564E+00,3.740469E+00,& + & 1.778567E+01,1.521100E-04,8.844500E-04,2.302200E-03,4.317700E-03,& + & 8.616800E-03,1.736100E-02,4.064200E-02,1.083800E-01,3.896255E-01,& + & 1.328753E+00,4.226996E+00,2.131463E+01,9.727300E-05,5.812000E-04,& + & 1.595800E-03,3.210000E-03,6.325700E-03,1.254200E-02,2.953300E-02,& + & 7.543000E-02,2.790862E-01,1.224792E+00,4.895570E+00,2.488085E+01,& + & 6.908100E-05,3.892200E-04,1.327000E-03,3.065500E-03,4.799900E-03,& + & 7.862300E-03,1.759800E-02,4.621000E-02,2.197124E-01,7.184142E-01,& + & 5.523475E+00,2.844827E+01,3.252800E-04,1.277900E-03,3.340100E-03,& + & 6.257800E-03,1.188300E-02,2.700200E-02,6.430300E-02,2.112200E-01,& + & 7.988563E-01,2.719642E+00,4.576837E+00,7.788492E+00,3.930700E-04,& + & 1.641500E-03,4.013900E-03,7.316100E-03,1.416900E-02,3.024600E-02,& + & 6.947700E-02,2.166100E-01,7.552567E-01,2.509852E+00,4.149684E+00,& + & 7.295436E+00,3.694400E-04,1.656000E-03,3.971200E-03,7.339500E-03,& + & 1.425600E-02,2.956400E-02,6.810900E-02,2.070100E-01,7.089994E-01,& + & 2.334672E+00,3.945813E+00,9.311374E+00,3.344100E-04,1.583400E-03,& + & 3.838700E-03,6.857200E-03,1.385600E-02,2.802800E-02,6.460000E-02,& + & 1.897700E-01,6.569014E-01,2.127486E+00,3.812998E+00,1.319211E+01/ + data absa( :,401:425) / & + & 2.905200E-04,1.451900E-03,3.527300E-03,6.306600E-03,1.283500E-02,& + & 2.553700E-02,5.969100E-02,1.686800E-01,5.914912E-01,1.908592E+00,& + & 3.947201E+00,1.757990E+01,2.394400E-04,1.271300E-03,3.090800E-03,& + & 5.639100E-03,1.119600E-02,2.273100E-02,5.287400E-02,1.445100E-01,& + & 5.136759E-01,1.671765E+00,4.413475E+00,2.196982E+01,1.822000E-04,& + & 1.010500E-03,2.533200E-03,4.741000E-03,9.428600E-03,1.886000E-02,& + & 4.405600E-02,1.169500E-01,4.197918E-01,1.492456E+00,5.134744E+00,& + & 2.635674E+01,1.168900E-04,6.672900E-04,1.773400E-03,3.603500E-03,& + & 7.008400E-03,1.372200E-02,3.267000E-02,8.242600E-02,3.110939E-01,& + & 1.484887E+00,5.981185E+00,3.073546E+01,8.420200E-05,4.662400E-04,& + & 1.542100E-03,3.386400E-03,5.183400E-03,9.031800E-03,2.061200E-02,& + & 5.261100E-02,2.537949E-01,1.034532E+00,6.833835E+00,3.514067E+01,& + & 5.982200E-04,2.455300E-03,9.466100E-03,2.079600E-02,4.334800E-02,& + & 9.675900E-02,2.628300E-01,8.717900E-01,3.759105E+00,1.418834E+01,& + & 2.674780E+01,4.772514E+01,6.237200E-04,2.616500E-03,9.367200E-03,& + & 2.001900E-02,4.064600E-02,8.992000E-02,2.384800E-01,7.730500E-01,& + & 3.292830E+00,1.241580E+01,2.340320E+01,4.173644E+01,5.808900E-04,& + & 2.499300E-03,8.681500E-03,1.816500E-02,3.653900E-02,8.028100E-02,& + & 2.123700E-01,6.767600E-01,2.842070E+00,1.064243E+01,2.005999E+01,& + & 3.579408E+01,5.126100E-04,2.284700E-03,7.767000E-03,1.606800E-02,& + & 3.207800E-02,6.929800E-02,1.839900E-01,5.780000E-01,2.397721E+00,& + & 8.913510E+00,1.671761E+01,2.982755E+01,4.332200E-04,2.026700E-03,& + & 6.653300E-03,1.387300E-02,2.715100E-02,5.816000E-02,1.536400E-01,& + & 4.785800E-01,1.950769E+00,7.234842E+00,1.340311E+01,2.386138E+01,& + & 3.427300E-04,1.711500E-03,5.426700E-03,1.140400E-02,2.184100E-02,& + & 4.668500E-02,1.209600E-01,3.750900E-01,1.502519E+00,5.572633E+00,& + & 1.021654E+01,1.801732E+01,2.420000E-04,1.339700E-03,4.080400E-03,& + & 8.677900E-03,1.618500E-02,3.448900E-02,8.668600E-02,2.678000E-01,& + & 1.042980E+00,3.952108E+00,7.044335E+00,1.338548E+01,1.355800E-04,& + & 8.636800E-04,2.555800E-03,5.278400E-03,9.920100E-03,2.113700E-02,& + & 5.092100E-02,1.525700E-01,5.829266E-01,2.198131E+00,4.048208E+00,& + & 1.080037E+01,7.213500E-05,3.657600E-04,1.068300E-03,2.841300E-03,& + & 6.719300E-03,9.131700E-03,1.266200E-02,3.482500E-02,1.735679E-01,& + & 4.901274E-01,6.636921E-01,5.646439E+00,7.437300E-04,3.062000E-03,& + & 1.040300E-02,2.218800E-02,4.414900E-02,1.013000E-01,2.649500E-01,& + & 8.869000E-01,3.789628E+00,1.398754E+01,2.639271E+01,4.642274E+01,& + & 7.830800E-04,3.251100E-03,1.031000E-02,2.148700E-02,4.206600E-02,& + & 9.492800E-02,2.434800E-01,7.915400E-01,3.324406E+00,1.223919E+01,& + & 2.309283E+01,4.062040E+01,7.222300E-04,3.104900E-03,9.521500E-03,& + & 1.961700E-02,3.809100E-02,8.506300E-02,2.179600E-01,6.968200E-01,& + & 2.884268E+00,1.049158E+01,1.979318E+01,3.481856E+01,6.344300E-04,& + & 2.855300E-03,8.512200E-03,1.744800E-02,3.360900E-02,7.419000E-02,& + & 1.893300E-01,6.008900E-01,2.440396E+00,8.849302E+00,1.650392E+01,& + & 2.901284E+01,5.322300E-04,2.534800E-03,7.312400E-03,1.512400E-02,& + & 2.855200E-02,6.275100E-02,1.581300E-01,5.008500E-01,2.000410E+00,& + & 7.193426E+00,1.337094E+01,2.322063E+01,4.242900E-04,2.126500E-03,& + & 5.981300E-03,1.249900E-02,2.298300E-02,5.081900E-02,1.251300E-01,& + & 3.967700E-01,1.542230E+00,5.663208E+00,1.022555E+01,1.844720E+01,& + & 3.024200E-04,1.631400E-03,4.550900E-03,9.263000E-03,1.737600E-02,& + & 3.781500E-02,9.122800E-02,2.851000E-01,1.086627E+00,4.023337E+00,& + & 7.232713E+00,1.508930E+01,1.710700E-04,1.026900E-03,2.873900E-03,& + & 5.666400E-03,1.100900E-02,2.310700E-02,5.519100E-02,1.638100E-01,& + & 6.214573E-01,2.309504E+00,4.363647E+00,1.443184E+01,9.583100E-05,& + & 4.580300E-04,1.294600E-03,3.396300E-03,7.543600E-03,9.775300E-03,& + & 1.612000E-02,4.084000E-02,2.295805E-01,5.410687E-01,1.148718E+00,& + & 1.024665E+01,9.169100E-04,3.736400E-03,1.128900E-02,2.321900E-02,& + & 4.567400E-02,1.050000E-01,2.670100E-01,8.984600E-01,3.820057E+00,& + & 1.375205E+01,2.601998E+01,4.546410E+01,9.562100E-04,3.962700E-03,& + & 1.121800E-02,2.284300E-02,4.363900E-02,9.989900E-02,2.476200E-01,& + & 8.087300E-01,3.357390E+00,1.203299E+01,2.276872E+01,3.977874E+01/ + data absa( :,426:450) / & + & 8.762500E-04,3.766000E-03,1.034900E-02,2.108600E-02,3.962400E-02,& + & 9.024500E-02,2.228600E-01,7.171200E-01,2.920508E+00,1.037744E+01,& + & 1.951440E+01,3.409901E+01,7.695000E-04,3.422400E-03,9.312700E-03,& + & 1.877700E-02,3.494700E-02,7.968200E-02,1.937900E-01,6.221100E-01,& + & 2.485335E+00,8.783998E+00,1.635773E+01,2.841364E+01,6.514400E-04,& + & 3.012100E-03,8.018200E-03,1.613000E-02,3.018800E-02,6.766700E-02,& + & 1.625000E-01,5.223500E-01,2.038731E+00,7.268280E+00,1.330701E+01,& + & 2.332216E+01,5.170100E-04,2.516600E-03,6.613800E-03,1.320900E-02,& + & 2.488700E-02,5.463800E-02,1.304600E-01,4.152900E-01,1.589008E+00,& + & 5.732649E+00,1.030253E+01,1.965560E+01,3.712100E-04,1.913500E-03,& + & 5.055100E-03,9.905900E-03,1.890300E-02,4.087300E-02,9.627300E-02,& + & 3.003300E-01,1.132519E+00,4.120682E+00,7.492159E+00,1.772513E+01,& + & 2.119900E-04,1.199000E-03,3.207200E-03,6.080200E-03,1.217700E-02,& + & 2.504000E-02,5.964300E-02,1.757600E-01,6.636172E-01,2.417518E+00,& + & 4.796886E+00,1.911936E+01,1.242300E-04,5.668500E-04,1.562200E-03,& + & 4.001900E-03,8.355600E-03,1.033000E-02,2.004100E-02,4.825300E-02,& + & 2.759617E-01,7.603472E-01,1.223406E+00,1.844897E+01,1.104300E-03,& + & 4.453000E-03,1.213000E-02,2.443500E-02,4.694700E-02,1.089600E-01,& + & 2.682700E-01,9.120200E-01,3.850780E+00,1.344140E+01,2.563283E+01,& + & 4.471733E+01,1.141400E-03,4.655400E-03,1.222100E-02,2.408200E-02,& + & 4.530200E-02,1.046300E-01,2.512400E-01,8.271300E-01,3.396081E+00,& + & 1.176140E+01,2.242846E+01,3.913054E+01,1.053900E-03,4.383600E-03,& + & 1.132000E-02,2.230300E-02,4.147700E-02,9.517100E-02,2.268300E-01,& + & 7.385400E-01,2.967227E+00,1.019389E+01,1.923575E+01,3.351927E+01,& + & 9.316100E-04,3.968200E-03,1.018900E-02,1.985100E-02,3.724900E-02,& + & 8.394600E-02,1.984300E-01,6.439900E-01,2.533132E+00,8.704777E+00,& + & 1.624171E+01,2.808346E+01,7.867200E-04,3.482900E-03,8.797900E-03,& + & 1.702300E-02,3.258800E-02,7.142000E-02,1.679900E-01,5.427600E-01,& + & 2.086232E+00,7.285594E+00,1.329429E+01,2.398871E+01,6.262600E-04,& + & 2.880900E-03,7.283200E-03,1.412100E-02,2.674600E-02,5.814400E-02,& + & 1.361800E-01,4.325500E-01,1.641633E+00,5.766709E+00,1.050190E+01,& + & 2.145548E+01,4.516000E-04,2.197200E-03,5.587300E-03,1.041000E-02,& + & 2.081500E-02,4.379900E-02,1.015900E-01,3.146300E-01,1.183016E+00,& + & 4.232117E+00,7.747457E+00,2.156927E+01,2.589200E-04,1.381500E-03,& + & 3.542700E-03,6.584300E-03,1.332000E-02,2.720500E-02,6.393900E-02,& + & 1.872700E-01,7.084439E-01,2.537045E+00,5.396362E+00,2.454034E+01,& + & 1.566600E-04,6.918800E-04,1.838900E-03,4.647700E-03,9.027600E-03,& + & 1.108400E-02,2.403500E-02,5.756700E-02,3.258908E-01,1.065732E+00,& + & 1.223879E+00,2.803950E+01,1.304500E-03,5.157500E-03,1.310000E-02,& + & 2.560900E-02,4.863300E-02,1.128500E-01,2.723400E-01,9.129200E-01,& + & 3.860697E+00,1.330448E+01,2.524180E+01,4.401344E+01,1.355200E-03,& + & 5.326400E-03,1.330000E-02,2.534300E-02,4.788500E-02,1.094200E-01,& + & 2.570500E-01,8.352000E-01,3.417428E+00,1.164578E+01,2.208270E+01,& + & 3.851495E+01,1.255600E-03,4.990900E-03,1.234000E-02,2.356000E-02,& + & 4.409600E-02,9.993100E-02,2.326400E-01,7.531100E-01,2.996422E+00,& + & 1.015216E+01,1.900191E+01,3.299298E+01,1.117200E-03,4.508700E-03,& + & 1.113100E-02,2.093000E-02,3.986400E-02,8.843900E-02,2.040100E-01,& + & 6.605800E-01,2.570193E+00,8.751904E+00,1.609012E+01,2.823570E+01,& + & 9.431600E-04,3.925700E-03,9.618900E-03,1.804200E-02,3.495700E-02,& + & 7.578300E-02,1.737400E-01,5.585100E-01,2.139376E+00,7.297603E+00,& + & 1.334998E+01,2.508671E+01,7.471800E-04,3.260200E-03,7.942800E-03,& + & 1.493700E-02,2.910400E-02,6.170800E-02,1.415700E-01,4.486800E-01,& + & 1.691785E+00,5.865303E+00,1.066921E+01,2.422762E+01,5.400800E-04,& + & 2.488800E-03,6.129100E-03,1.116300E-02,2.265300E-02,4.648400E-02,& + & 1.068900E-01,3.291900E-01,1.232316E+00,4.352784E+00,8.106246E+00,& + & 2.634042E+01,3.119600E-04,1.571500E-03,3.879300E-03,7.140000E-03,& + & 1.442800E-02,2.953100E-02,6.830000E-02,1.984100E-01,7.535785E-01,& + & 2.671441E+00,6.183079E+00,3.055881E+01,1.959900E-04,8.227000E-04,& + & 2.144000E-03,5.259800E-03,9.733300E-03,1.206000E-02,2.824100E-02,& + & 6.565900E-02,3.765147E-01,1.235396E+00,2.313325E+00,3.491657E+01/ + data absa( :,451:475) / & + & 8.771200E-04,3.783300E-03,1.348700E-02,3.021800E-02,6.169200E-02,& + & 1.420400E-01,3.843500E-01,1.310300E+00,6.288946E+00,2.343500E+01,& + & 5.082096E+01,9.378450E+01,8.883700E-04,3.811200E-03,1.298400E-02,& + & 2.846400E-02,5.678000E-02,1.299700E-01,3.448600E-01,1.156500E+00,& + & 5.504456E+00,2.050676E+01,4.446950E+01,8.206034E+01,8.143000E-04,& + & 3.556600E-03,1.178200E-02,2.556600E-02,5.023200E-02,1.152000E-01,& + & 3.040800E-01,1.007200E+00,4.732838E+00,1.757803E+01,3.811588E+01,& + & 7.034232E+01,7.206400E-04,3.198900E-03,1.039800E-02,2.218900E-02,& + & 4.369300E-02,9.876900E-02,2.602500E-01,8.549200E-01,3.976413E+00,& + & 1.464889E+01,3.176482E+01,5.861979E+01,6.079100E-04,2.768600E-03,& + & 8.833600E-03,1.876300E-02,3.666400E-02,8.142000E-02,2.157700E-01,& + & 7.008000E-01,3.218993E+00,1.177913E+01,2.541098E+01,4.689426E+01,& + & 4.863800E-04,2.272300E-03,7.133400E-03,1.516500E-02,2.910100E-02,& + & 6.421700E-02,1.684000E-01,5.440500E-01,2.461543E+00,8.957565E+00,& + & 1.910984E+01,3.517210E+01,3.485500E-04,1.736400E-03,5.226200E-03,& + & 1.128600E-02,2.113900E-02,4.639900E-02,1.182700E-01,3.828800E-01,& + & 1.689514E+00,6.235899E+00,1.295564E+01,2.371632E+01,1.890400E-04,& + & 1.075300E-03,3.159000E-03,6.727100E-03,1.250000E-02,2.741400E-02,& + & 6.686200E-02,2.129600E-01,9.114462E-01,3.400543E+00,6.995874E+00,& + & 1.446010E+01,9.508600E-05,4.059000E-04,1.184500E-03,3.044300E-03,& + & 7.309100E-03,9.351100E-03,1.406700E-02,3.693200E-02,1.910664E-01,& + & 6.632902E-01,5.600943E-01,2.246048E+00,1.102500E-03,4.696600E-03,& + & 1.480400E-02,3.201700E-02,6.363300E-02,1.478100E-01,3.880800E-01,& + & 1.329900E+00,6.352667E+00,2.312193E+01,5.023314E+01,9.135925E+01,& + & 1.122000E-03,4.720700E-03,1.418500E-02,3.028800E-02,5.926800E-02,& + & 1.366900E-01,3.507900E-01,1.179600E+00,5.563428E+00,2.023133E+01,& + & 4.395141E+01,7.993811E+01,1.031000E-03,4.415600E-03,1.282300E-02,& + & 2.735100E-02,5.286500E-02,1.218800E-01,3.094700E-01,1.032700E+00,& + & 4.796551E+00,1.734303E+01,3.767146E+01,6.851959E+01,9.082000E-04,& + & 3.973600E-03,1.134600E-02,2.396000E-02,4.587100E-02,1.049200E-01,& + & 2.670500E-01,8.812500E-01,4.040551E+00,1.449147E+01,3.139313E+01,& + & 5.709865E+01,7.580700E-04,3.455400E-03,9.653000E-03,2.041700E-02,& + & 3.841900E-02,8.766800E-02,2.211500E-01,7.269300E-01,3.285563E+00,& + & 1.171307E+01,2.513601E+01,4.567951E+01,5.986400E-04,2.857700E-03,& + & 7.763100E-03,1.657100E-02,3.060900E-02,6.956600E-02,1.727100E-01,& + & 5.685700E-01,2.521676E+00,9.002457E+00,1.905052E+01,3.427199E+01,& + & 4.306400E-04,2.133800E-03,5.767300E-03,1.220100E-02,2.249600E-02,& + & 5.054900E-02,1.230600E-01,4.033500E-01,1.740104E+00,6.368831E+00,& + & 1.302936E+01,2.422258E+01,2.370200E-04,1.294500E-03,3.538300E-03,& + & 7.215900E-03,1.366000E-02,3.001400E-02,7.110200E-02,2.263300E-01,& + & 9.538031E-01,3.549998E+00,7.243493E+00,1.738246E+01,1.266900E-04,& + & 5.051700E-04,1.427500E-03,3.607200E-03,8.207300E-03,1.033000E-02,& + & 1.728200E-02,4.319000E-02,2.490717E-01,8.946229E-01,9.058994E-01,& + & 5.404180E+00,1.368400E-03,5.718900E-03,1.598000E-02,3.371300E-02,& + & 6.559800E-02,1.538000E-01,3.913300E-01,1.353000E+00,6.387279E+00,& + & 2.285691E+01,4.959501E+01,8.949759E+01,1.374600E-03,5.759000E-03,& + & 1.536700E-02,3.214100E-02,6.128100E-02,1.435300E-01,3.568300E-01,& + & 1.206400E+00,5.598940E+00,2.000400E+01,4.339356E+01,7.832112E+01,& + & 1.259400E-03,5.334500E-03,1.397100E-02,2.917200E-02,5.482800E-02,& + & 1.279300E-01,3.169200E-01,1.060000E+00,4.845582E+00,1.714633E+01,& + & 3.719495E+01,6.712804E+01,1.105800E-03,4.770800E-03,1.236600E-02,& + & 2.569800E-02,4.771300E-02,1.111300E-01,2.732000E-01,9.113100E-01,& + & 4.091760E+00,1.440774E+01,3.099612E+01,5.594172E+01,9.318700E-04,& + & 4.108400E-03,1.054200E-02,2.176800E-02,4.040100E-02,9.332500E-02,& + & 2.265200E-01,7.559800E-01,3.340265E+00,1.170328E+01,2.494793E+01,& + & 4.475043E+01,7.374800E-04,3.372900E-03,8.556500E-03,1.754600E-02,& + & 3.279000E-02,7.410800E-02,1.785400E-01,5.941100E-01,2.571651E+00,& + & 9.111943E+00,1.900419E+01,3.426415E+01,5.246500E-04,2.500800E-03,& + & 6.378000E-03,1.298900E-02,2.429600E-02,5.402900E-02,1.288700E-01,& + & 4.226500E-01,1.802247E+00,6.418648E+00,1.323698E+01,2.563248E+01/ + data absa( :,476:500) / & + & 2.952000E-04,1.507800E-03,3.935100E-03,7.673400E-03,1.512600E-02,& + & 3.249800E-02,7.547100E-02,2.397800E-01,9.997497E-01,3.714732E+00,& + & 7.532449E+00,2.162216E+01,1.618100E-04,6.333700E-04,1.723500E-03,& + & 4.202100E-03,8.870600E-03,1.153300E-02,2.065000E-02,5.276200E-02,& + & 3.138906E-01,8.678991E-01,1.624074E+00,1.085742E+01,1.647100E-03,& + & 6.782700E-03,1.721900E-02,3.552300E-02,6.757500E-02,1.600400E-01,& + & 3.968800E-01,1.358700E+00,6.407998E+00,2.273870E+01,4.890237E+01,& + & 8.786295E+01,1.662300E-03,6.746900E-03,1.674500E-02,3.394100E-02,& + & 6.388400E-02,1.505900E-01,3.640400E-01,1.219500E+00,5.625589E+00,& + & 1.989862E+01,4.278709E+01,7.688291E+01,1.520600E-03,6.227800E-03,& + & 1.525300E-02,3.080200E-02,5.773900E-02,1.346000E-01,3.254700E-01,& + & 1.078100E+00,4.879586E+00,1.710184E+01,3.667564E+01,6.589787E+01,& + & 1.338200E-03,5.536700E-03,1.347500E-02,2.726400E-02,5.071500E-02,& + & 1.170400E-01,2.811800E-01,9.307900E-01,4.142221E+00,1.439711E+01,& + & 3.061595E+01,5.491492E+01,1.131500E-03,4.738000E-03,1.155700E-02,& + & 2.309100E-02,4.338500E-02,9.840400E-02,2.342100E-01,7.763400E-01,& + & 3.389860E+00,1.181724E+01,2.474787E+01,4.410067E+01,8.947100E-04,& + & 3.859400E-03,9.424300E-03,1.851200E-02,3.535800E-02,7.870900E-02,& + & 1.854900E-01,6.132700E-01,2.629167E+00,9.238798E+00,1.898440E+01,& + & 3.489820E+01,6.421400E-04,2.864800E-03,6.988000E-03,1.384800E-02,& + & 2.634300E-02,5.784700E-02,1.349000E-01,4.389200E-01,1.858869E+00,& + & 6.556705E+00,1.345250E+01,2.815105E+01,3.631000E-04,1.729400E-03,& + & 4.333800E-03,8.220700E-03,1.665200E-02,3.479800E-02,8.017500E-02,& + & 2.529700E-01,1.047439E+00,3.881169E+00,7.924071E+00,2.706093E+01,& + & 2.048900E-04,7.741500E-04,2.012100E-03,4.926100E-03,9.512000E-03,& + & 1.251000E-02,2.438500E-02,6.486500E-02,3.633223E-01,1.133515E+00,& + & 2.025718E+00,1.821647E+01,1.968800E-03,7.820000E-03,1.865900E-02,& + & 3.704800E-02,7.095300E-02,1.652900E-01,4.036600E-01,1.360000E+00,& + & 6.411233E+00,2.272596E+01,4.811222E+01,8.634764E+01,1.977200E-03,& + & 7.738200E-03,1.817800E-02,3.565900E-02,6.772800E-02,1.560600E-01,& + & 3.721100E-01,1.228400E+00,5.642471E+00,1.988467E+01,4.209788E+01,& + & 7.555230E+01,1.813800E-03,7.090100E-03,1.658200E-02,3.250000E-02,& + & 6.119500E-02,1.405600E-01,3.331000E-01,1.090800E+00,4.913851E+00,& + & 1.714046E+01,3.608210E+01,6.475996E+01,1.602800E-03,6.264400E-03,& + & 1.473900E-02,2.876600E-02,5.393900E-02,1.231000E-01,2.889100E-01,& + & 9.445700E-01,4.188564E+00,1.448387E+01,3.024001E+01,5.396711E+01,& + & 1.361900E-03,5.353300E-03,1.266700E-02,2.438000E-02,4.628300E-02,& + & 1.039600E-01,2.416800E-01,7.921100E-01,3.441500E+00,1.198252E+01,& + & 2.450437E+01,4.412592E+01,1.082600E-03,4.351000E-03,1.025400E-02,& + & 1.972400E-02,3.809300E-02,8.324000E-02,1.927700E-01,6.269900E-01,& + & 2.692749E+00,9.353124E+00,1.909518E+01,3.597514E+01,7.769900E-04,& + & 3.235600E-03,7.652400E-03,1.473500E-02,2.864800E-02,6.135500E-02,& + & 1.411800E-01,4.526200E-01,1.917400E+00,6.742004E+00,1.362352E+01,& + & 3.196957E+01,4.340400E-04,1.972200E-03,4.748100E-03,8.877300E-03,& + & 1.805100E-02,3.741500E-02,8.525500E-02,2.643700E-01,1.098879E+00,& + & 4.047858E+00,8.445701E+00,3.339426E+01,2.545900E-04,9.331200E-04,& + & 2.366900E-03,5.629200E-03,1.047200E-02,1.328300E-02,2.831500E-02,& + & 7.684800E-02,4.130797E-01,1.560816E+00,1.881099E+00,2.919939E+01,& + & 9.440900E-04,4.278300E-03,1.443000E-02,3.217000E-02,6.628900E-02,& + & 1.523800E-01,4.178800E-01,1.440700E+00,7.663963E+00,2.899264E+01,& + & 7.159818E+01,1.369336E+02,9.503000E-04,4.204100E-03,1.371100E-02,& + & 2.996500E-02,6.078100E-02,1.389700E-01,3.741700E-01,1.271300E+00,& + & 6.708315E+00,2.536566E+01,6.264717E+01,1.198140E+02,8.695800E-04,& + & 3.874200E-03,1.234400E-02,2.677400E-02,5.363600E-02,1.227400E-01,& + & 3.284800E-01,1.106500E+00,5.765433E+00,2.174366E+01,5.369594E+01,& + & 1.026894E+02,7.672300E-04,3.463400E-03,1.079300E-02,2.326500E-02,& + & 4.630400E-02,1.050900E-01,2.802600E-01,9.383500E-01,4.837126E+00,& + & 1.811998E+01,4.474993E+01,8.557653E+01,6.479900E-04,2.972000E-03,& + & 9.131200E-03,1.960400E-02,3.842900E-02,8.681600E-02,2.309300E-01,& + & 7.682500E-01,3.910245E+00,1.454534E+01,3.579948E+01,6.846520E+01/ + data absa( :,501:525) / & + & 5.180400E-04,2.439300E-03,7.278800E-03,1.576700E-02,3.026100E-02,& + & 6.821300E-02,1.790000E-01,5.943200E-01,2.987794E+00,1.101231E+01,& + & 2.687019E+01,5.134851E+01,3.716200E-04,1.835100E-03,5.288500E-03,& + & 1.166500E-02,2.177700E-02,4.881300E-02,1.251600E-01,4.163800E-01,& + & 2.042955E+00,7.628981E+00,1.811120E+01,3.424867E+01,2.017900E-04,& + & 1.117500E-03,3.155600E-03,6.862800E-03,1.275200E-02,2.830300E-02,& + & 6.982900E-02,2.288800E-01,1.093280E+00,4.128444E+00,9.619214E+00,& + & 1.893904E+01,1.018100E-04,3.925300E-04,1.139200E-03,2.969300E-03,& + & 6.774600E-03,8.909400E-03,1.307700E-02,3.468500E-02,1.960140E-01,& + & 8.111293E-01,6.893005E-01,4.566290E-04,1.202400E-03,5.333700E-03,& + & 1.575700E-02,3.387700E-02,6.855100E-02,1.588700E-01,4.234600E-01,& + & 1.469600E+00,7.719665E+00,2.876361E+01,7.085290E+01,1.336984E+02,& + & 1.202400E-03,5.265200E-03,1.492900E-02,3.185700E-02,6.317400E-02,& + & 1.459800E-01,3.819700E-01,1.302900E+00,6.759454E+00,2.517306E+01,& + & 6.199584E+01,1.169874E+02,1.103500E-03,4.830100E-03,1.343100E-02,& + & 2.868600E-02,5.606300E-02,1.293900E-01,3.356800E-01,1.137800E+00,& + & 5.825213E+00,2.157684E+01,5.313978E+01,1.002762E+02,9.710500E-04,& + & 4.318900E-03,1.172900E-02,2.507000E-02,4.834800E-02,1.112300E-01,& + & 2.876100E-01,9.698100E-01,4.901815E+00,1.800478E+01,4.428395E+01,& + & 8.356392E+01,8.124500E-04,3.722300E-03,9.924000E-03,2.130600E-02,& + & 4.005900E-02,9.249700E-02,2.373400E-01,7.976700E-01,3.977688E+00,& + & 1.452748E+01,3.542689E+01,6.684658E+01,6.437900E-04,3.022800E-03,& + & 7.973800E-03,1.704300E-02,3.178500E-02,7.314100E-02,1.845800E-01,& + & 6.210300E-01,3.050545E+00,1.107314E+01,2.674604E+01,5.013704E+01,& + & 4.612300E-04,2.240800E-03,5.846700E-03,1.246000E-02,2.331500E-02,& + & 5.257400E-02,1.303700E-01,4.377900E-01,2.100732E+00,7.773422E+00,& + & 1.814635E+01,3.421008E+01,2.562400E-04,1.344300E-03,3.512300E-03,& + & 7.356700E-03,1.385600E-02,3.088900E-02,7.406900E-02,2.425400E-01,& + & 1.141779E+00,4.274065E+00,9.892635E+00,2.127531E+01,1.374600E-04,& + & 4.879500E-04,1.391100E-03,3.515700E-03,7.662200E-03,9.491000E-03,& + & 1.650100E-02,4.265400E-02,2.513567E-01,9.921298E-01,1.001245E+00,& + & 4.001971E+00,1.500900E-03,6.514300E-03,1.694800E-02,3.582100E-02,& + & 7.044100E-02,1.658300E-01,4.306100E-01,1.481000E+00,7.751675E+00,& + & 2.876527E+01,6.992673E+01,1.309661E+02,1.489500E-03,6.357900E-03,& + & 1.616900E-02,3.384000E-02,6.532700E-02,1.540200E-01,3.903500E-01,& + & 1.321100E+00,6.792696E+00,2.517049E+01,6.118801E+01,1.145945E+02,& + & 1.352700E-03,5.823700E-03,1.463400E-02,3.049700E-02,5.825800E-02,& + & 1.366400E-01,3.448500E-01,1.157800E+00,5.872187E+00,2.157560E+01,& + & 5.244778E+01,9.822697E+01,1.188900E-03,5.181200E-03,1.283000E-02,& + & 2.664600E-02,5.061100E-02,1.178800E-01,2.967600E-01,9.914800E-01,& + & 4.954699E+00,1.806776E+01,4.370428E+01,8.184573E+01,1.001600E-03,& + & 4.411800E-03,1.085600E-02,2.261900E-02,4.258700E-02,9.827600E-02,& + & 2.450200E-01,8.201300E-01,4.044742E+00,1.457823E+01,3.505714E+01,& + & 6.548216E+01,7.937600E-04,3.572100E-03,8.751200E-03,1.810800E-02,& + & 3.417000E-02,7.782600E-02,1.917500E-01,6.418100E-01,3.104768E+00,& + & 1.131276E+01,2.656026E+01,4.932213E+01,5.667100E-04,2.628100E-03,& + & 6.441800E-03,1.327600E-02,2.523700E-02,5.613400E-02,1.367200E-01,& + & 4.546600E-01,2.164374E+00,7.918067E+00,1.828509E+01,3.491347E+01,& + & 3.194300E-04,1.568400E-03,3.876500E-03,7.856100E-03,1.529500E-02,& + & 3.332900E-02,7.843400E-02,2.557800E-01,1.194524E+00,4.442015E+00,& + & 1.013051E+01,2.525387E+01,1.756800E-04,6.039400E-04,1.658500E-03,& + & 4.155900E-03,8.395000E-03,1.035400E-02,1.994200E-02,5.249600E-02,& + & 3.115146E-01,1.081192E+00,1.943478E+00,7.176638E+00,1.819200E-03,& + & 7.646800E-03,1.834000E-02,3.750300E-02,7.325900E-02,1.723200E-01,& + & 4.399100E-01,1.485800E+00,7.766421E+00,2.883165E+01,6.893131E+01,& + & 1.284070E+02,1.811700E-03,7.427600E-03,1.765100E-02,3.550600E-02,& + & 6.884200E-02,1.605600E-01,4.014200E-01,1.330600E+00,6.817648E+00,& + & 2.522786E+01,6.031603E+01,1.123586E+02,1.642200E-03,6.762500E-03,& + & 1.601300E-02,3.212600E-02,6.168500E-02,1.429400E-01,3.562100E-01,& + & 1.172700E+00,5.909910E+00,2.164434E+01,5.169580E+01,9.629948E+01/ + data absa( :,526:550) / & + & 1.441000E-03,6.012000E-03,1.401900E-02,2.828800E-02,5.375800E-02,& + & 1.239800E-01,3.058300E-01,1.007400E+00,5.009086E+00,1.818380E+01,& + & 4.309835E+01,8.025285E+01,1.215100E-03,5.080500E-03,1.196200E-02,& + & 2.390200E-02,4.543600E-02,1.038700E-01,2.535400E-01,8.361800E-01,& + & 4.093960E+00,1.482591E+01,3.471719E+01,6.419973E+01,9.681200E-04,& + & 4.089200E-03,9.666200E-03,1.918100E-02,3.670600E-02,8.252400E-02,& + & 1.994100E-01,6.567200E-01,3.165775E+00,1.155310E+01,2.640737E+01,& + & 4.930590E+01,6.954600E-04,3.002400E-03,7.062300E-03,1.414200E-02,& + & 2.737700E-02,5.998100E-02,1.429400E-01,4.674300E-01,2.226722E+00,& + & 8.102459E+00,1.856208E+01,3.629824E+01,3.913700E-04,1.803200E-03,& + & 4.262100E-03,8.399000E-03,1.677100E-02,3.580000E-02,8.286700E-02,& + & 2.673700E-01,1.245280E+00,4.661390E+00,1.043116E+01,3.053926E+01,& + & 2.178200E-04,7.485600E-04,1.980600E-03,4.808800E-03,8.943900E-03,& + & 1.147100E-02,2.315600E-02,6.336100E-02,3.606875E-01,1.309468E+00,& + & 3.109775E+00,1.060836E+01,2.176600E-03,8.732200E-03,1.991700E-02,& + & 3.921800E-02,7.746700E-02,1.782200E-01,4.501800E-01,1.481500E+00,& + & 7.790363E+00,2.873093E+01,6.803419E+01,1.260122E+02,2.163500E-03,& + & 8.484500E-03,1.919400E-02,3.728900E-02,7.308100E-02,1.671300E-01,& + & 4.138300E-01,1.333500E+00,6.851542E+00,2.514320E+01,5.952891E+01,& + & 1.102520E+02,1.970000E-03,7.687800E-03,1.745000E-02,3.376400E-02,& + & 6.544900E-02,1.498500E-01,3.684700E-01,1.180400E+00,5.956307E+00,& + & 2.162214E+01,5.102502E+01,9.450307E+01,1.731400E-03,6.787500E-03,& + & 1.537500E-02,2.974700E-02,5.741800E-02,1.304500E-01,3.172800E-01,& + & 1.019000E+00,5.075132E+00,1.815844E+01,4.262893E+01,7.875140E+01,& + & 1.465100E-03,5.706400E-03,1.313600E-02,2.525300E-02,4.867700E-02,& + & 1.096500E-01,2.638500E-01,8.498500E-01,4.155554E+00,1.497974E+01,& + & 3.441056E+01,6.331872E+01,1.173600E-03,4.609500E-03,1.055900E-02,& + & 2.034500E-02,3.967100E-02,8.720800E-02,2.076900E-01,6.712100E-01,& + & 3.236702E+00,1.165852E+01,2.645447E+01,4.975075E+01,8.459300E-04,& + & 3.402700E-03,7.706100E-03,1.517500E-02,2.955000E-02,6.353100E-02,& + & 1.498400E-01,4.812100E-01,2.289064E+00,8.322390E+00,1.869544E+01,& + & 3.937428E+01,4.703200E-04,2.049700E-03,4.673500E-03,9.056900E-03,& + & 1.820200E-02,3.840000E-02,8.755000E-02,2.785300E-01,1.298317E+00,& + & 4.877541E+00,1.083710E+01,3.686875E+01,2.576800E-04,9.303000E-04,& + & 2.288600E-03,5.525400E-03,9.631900E-03,1.264800E-02,2.590600E-02,& + & 7.529100E-02,4.101024E-01,1.736313E+00,2.636756E+00,2.374811E+01,& + & 8.206900E-04,3.838300E-03,1.237800E-02,2.702100E-02,5.667100E-02,& + & 1.285100E-01,3.595400E-01,1.261600E+00,7.309074E+00,2.898063E+01,& + & 8.041873E+01,1.601218E+02,8.244500E-04,3.768500E-03,1.174000E-02,& + & 2.524000E-02,5.198200E-02,1.176000E-01,3.229300E-01,1.116300E+00,& + & 6.398424E+00,2.536331E+01,7.036568E+01,1.401047E+02,7.515400E-04,& + & 3.478100E-03,1.052000E-02,2.263800E-02,4.587800E-02,1.043200E-01,& + & 2.829000E-01,9.720400E-01,5.506712E+00,2.174052E+01,6.031346E+01,& + & 1.200876E+02,6.618800E-04,3.100000E-03,9.179400E-03,1.976400E-02,& + & 3.950000E-02,8.947100E-02,2.414900E-01,8.254700E-01,4.625879E+00,& + & 1.811879E+01,5.026180E+01,1.000735E+02,5.618500E-04,2.666100E-03,& + & 7.731300E-03,1.666900E-02,3.280700E-02,7.395200E-02,1.985500E-01,& + & 6.766900E-01,3.744450E+00,1.456283E+01,4.020936E+01,8.006027E+01,& + & 4.508300E-04,2.177700E-03,6.154700E-03,1.338900E-02,2.589400E-02,& + & 5.796500E-02,1.539200E-01,5.239100E-01,2.869181E+00,1.101694E+01,& + & 3.020030E+01,6.004617E+01,3.227500E-04,1.620700E-03,4.483700E-03,& + & 9.803100E-03,1.871700E-02,4.157100E-02,1.079900E-01,3.667300E-01,& + & 1.962442E+00,7.681436E+00,2.034117E+01,4.006676E+01,1.785100E-04,& + & 9.739500E-04,2.665500E-03,5.760900E-03,1.094200E-02,2.424400E-02,& + & 6.053800E-02,2.010600E-01,1.054352E+00,4.154737E+00,1.082370E+01,& + & 2.181943E+01,9.109900E-05,3.443400E-04,9.804100E-04,2.539100E-03,& + & 5.752300E-03,7.527100E-03,1.158200E-02,2.978200E-02,1.848884E-01,& + & 9.712593E-01,6.523105E-01,5.681277E-01,1.047300E-03,4.799100E-03,& + & 1.340000E-02,2.855000E-02,5.857700E-02,1.346100E-01,3.662000E-01,& + & 1.277700E+00,7.342413E+00,2.917513E+01,7.949063E+01,1.564031E+02/ + data absa( :,551:575) / & + & 1.050200E-03,4.728700E-03,1.270400E-02,2.688800E-02,5.401100E-02,& + & 1.243100E-01,3.309500E-01,1.137500E+00,6.431929E+00,2.552834E+01,& + & 6.955286E+01,1.368455E+02,9.596600E-04,4.360400E-03,1.144200E-02,& + & 2.416400E-02,4.789600E-02,1.102000E-01,2.911800E-01,9.934500E-01,& + & 5.552369E+00,2.188299E+01,5.961554E+01,1.172942E+02,8.425700E-04,& + & 3.880100E-03,9.960700E-03,2.114600E-02,4.145900E-02,9.471500E-02,& + & 2.496200E-01,8.480400E-01,4.675569E+00,1.829247E+01,4.968244E+01,& + & 9.775921E+01,7.074100E-04,3.305400E-03,8.416600E-03,1.785900E-02,& + & 3.466100E-02,7.871300E-02,2.057900E-01,6.980600E-01,3.805568E+00,& + & 1.473766E+01,3.976178E+01,7.820017E+01,5.623300E-04,2.665800E-03,& + & 6.782400E-03,1.421100E-02,2.767100E-02,6.219100E-02,1.603500E-01,& + & 5.438800E-01,2.917804E+00,1.129935E+01,3.000318E+01,5.865348E+01,& + & 4.037000E-04,1.975500E-03,4.946400E-03,1.045600E-02,2.018600E-02,& + & 4.472000E-02,1.134500E-01,3.829800E-01,2.018792E+00,7.914435E+00,& + & 2.035492E+01,3.996237E+01,2.267900E-04,1.169200E-03,2.963500E-03,& + & 6.164800E-03,1.202500E-02,2.634900E-02,6.456100E-02,2.126500E-01,& + & 1.101833E+00,4.329658E+00,1.113391E+01,2.404879E+01,1.217200E-04,& + & 4.301800E-04,1.202700E-03,3.035900E-03,6.466400E-03,7.937400E-03,& + & 1.455500E-02,3.753900E-02,2.379477E-01,1.014498E+00,1.338890E+00,& + & 4.230507E+00,1.313300E-03,5.824000E-03,1.437600E-02,3.020600E-02,& + & 6.029600E-02,1.409100E-01,3.749700E-01,1.285700E+00,7.377894E+00,& + & 2.926687E+01,7.851781E+01,1.530898E+02,1.302400E-03,5.663200E-03,& + & 1.382800E-02,2.833600E-02,5.629400E-02,1.307900E-01,3.413900E-01,& + & 1.150100E+00,6.472921E+00,2.560299E+01,6.870360E+01,1.339515E+02,& + & 1.184600E-03,5.189500E-03,1.249700E-02,2.556000E-02,5.026100E-02,& + & 1.158500E-01,3.020500E-01,1.010500E+00,5.604289E+00,2.194713E+01,& + & 5.888901E+01,1.148195E+02,1.037500E-03,4.611400E-03,1.094400E-02,& + & 2.236200E-02,4.370200E-02,1.001500E-01,2.590200E-01,8.653800E-01,& + & 4.738274E+00,1.840389E+01,4.907414E+01,9.568211E+01,8.743600E-04,& + & 3.905200E-03,9.289400E-03,1.895300E-02,3.675100E-02,8.355400E-02,& + & 2.139700E-01,7.156700E-01,3.874538E+00,1.486946E+01,3.939167E+01,& + & 7.655049E+01,6.964500E-04,3.133800E-03,7.485900E-03,1.515100E-02,& + & 2.957900E-02,6.618100E-02,1.675500E-01,5.592800E-01,2.977662E+00,& + & 1.158336E+01,2.982415E+01,5.768910E+01,5.029200E-04,2.306600E-03,& + & 5.462700E-03,1.108600E-02,2.198500E-02,4.781600E-02,1.190700E-01,& + & 3.959600E-01,2.080088E+00,8.104033E+00,2.057472E+01,4.053368E+01,& + & 2.846300E-04,1.372400E-03,3.263900E-03,6.599800E-03,1.325300E-02,& + & 2.855100E-02,6.827400E-02,2.229200E-01,1.151172E+00,4.554374E+00,& + & 1.136211E+01,2.822255E+01,1.554900E-04,5.349000E-04,1.445500E-03,& + & 3.570400E-03,7.051700E-03,8.711300E-03,1.751600E-02,4.537000E-02,& + & 2.796702E-01,1.134537E+00,2.537224E+00,7.304384E+00,1.606400E-03,& + & 6.794200E-03,1.566300E-02,3.149500E-02,6.340300E-02,1.465700E-01,& + & 3.849100E-01,1.287700E+00,7.407810E+00,2.928130E+01,7.758287E+01,& + & 1.499748E+02,1.587300E-03,6.606700E-03,1.508700E-02,2.987800E-02,& + & 5.949200E-02,1.367300E-01,3.529300E-01,1.156600E+00,6.512561E+00,& + & 2.562080E+01,6.788150E+01,1.312295E+02,1.446100E-03,6.006200E-03,& + & 1.367500E-02,2.698900E-02,5.320200E-02,1.218900E-01,3.134400E-01,& + & 1.020400E+00,5.653694E+00,2.201316E+01,5.818636E+01,1.124805E+02,& + & 1.267700E-03,5.292700E-03,1.202300E-02,2.362600E-02,4.664300E-02,& + & 1.057300E-01,2.695100E-01,8.773900E-01,4.804032E+00,1.847926E+01,& + & 4.852848E+01,9.373833E+01,1.071500E-03,4.460700E-03,1.024800E-02,& + & 1.999300E-02,3.943500E-02,8.868000E-02,2.233800E-01,7.283200E-01,& + & 3.931144E+00,1.511244E+01,3.908391E+01,7.498927E+01,8.590100E-04,& + & 3.587000E-03,8.252200E-03,1.605200E-02,3.195100E-02,7.041800E-02,& + & 1.753700E-01,5.717000E-01,3.042768E+00,1.182681E+01,2.971266E+01,& + & 5.749523E+01,6.184200E-04,2.641300E-03,5.999400E-03,1.189100E-02,& + & 2.384100E-02,5.099000E-02,1.255000E-01,4.072700E-01,2.142902E+00,& + & 8.322612E+00,2.086362E+01,4.173736E+01,3.478100E-04,1.576600E-03,& + & 3.598000E-03,7.097700E-03,1.449300E-02,3.063200E-02,7.221300E-02,& + & 2.332500E-01,1.200802E+00,4.783978E+00,1.166725E+01,3.378369E+01/ + data absa( :,576:585) / & + & 1.935700E-04,6.633000E-04,1.713200E-03,4.134900E-03,7.496500E-03,& + & 9.815800E-03,1.968500E-02,5.513400E-02,3.262938E-01,1.468797E+00,& + & 3.401567E+00,1.185587E+01,1.930500E-03,7.713500E-03,1.708400E-02,& + & 3.296900E-02,6.701600E-02,1.519700E-01,3.945600E-01,1.281000E+00,& + & 7.438956E+00,2.932595E+01,7.650146E+01,1.471008E+02,1.905100E-03,& + & 7.485600E-03,1.653800E-02,3.125900E-02,6.334100E-02,1.428100E-01,& + & 3.643000E-01,1.158000E+00,6.552737E+00,2.566406E+01,6.693633E+01,& + & 1.287272E+02,1.736400E-03,6.762300E-03,1.502700E-02,2.828200E-02,& + & 5.710500E-02,1.277800E-01,3.237000E-01,1.026700E+00,5.709484E+00,& + & 2.209441E+01,5.737337E+01,1.103272E+02,1.531400E-03,5.954300E-03,& + & 1.318000E-02,2.500500E-02,5.005800E-02,1.111100E-01,2.788500E-01,& + & 8.877800E-01,4.866529E+00,1.860806E+01,4.798148E+01,9.194261E+01,& + & 1.297200E-03,5.021600E-03,1.122000E-02,2.123200E-02,4.235700E-02,& + & 9.340200E-02,2.320900E-01,7.394100E-01,3.994058E+00,1.536700E+01,& + & 3.873843E+01,7.391520E+01,1.044000E-03,4.047700E-03,9.051300E-03,& + & 1.706100E-02,3.457100E-02,7.409900E-02,1.832600E-01,5.825200E-01,& + & 3.116651E+00,1.197569E+01,2.979753E+01,5.772071E+01,7.531200E-04,& + & 2.985600E-03,6.556700E-03,1.280800E-02,2.567400E-02,5.419200E-02,& + & 1.323500E-01,4.176000E-01,2.207260E+00,8.563850E+00,2.105248E+01,& + & 4.463313E+01,4.221000E-04,1.791800E-03,3.939600E-03,7.657800E-03,& + & 1.575300E-02,3.295200E-02,7.692900E-02,2.424800E-01,1.252910E+00,& + & 5.027342E+00,1.205597E+01,4.030304E+01,2.314500E-04,8.111600E-04,& + & 2.015400E-03,4.718000E-03,8.107500E-03,1.086500E-02,2.110500E-02,& + & 6.622200E-02,3.727104E-01,1.961985E+00,3.081359E+00,2.385465E+01/ + +! --- the array absb(NG09,235) = kb(NG09,5,13:59) contains absorption coefs +! at the NG09=12 chosen g-values for a range of pressure levels< ~100mb +! and temperatures. the first index in the array, jt, which runs from +! 1 to 5, corresponds to different temperatures. more specifically, +! jt = 1-5 means that the data are for the corresponding temperature of +! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +! second index, jp, runs from 13 to 59 and refers to the jpth reference +! pressure level (see taumol.f for the value of these pressure levels +! in mb). the third index, ig, goes from 1 to NG09=12, and tells us +! which g-interval the absorption coefficients are for. + + data absb(:, 1: 25) / & + & 2.338200E-03,1.028900E-02,3.089100E-02,6.700900E-02,1.363400E-01,& + & 3.194300E-01,8.688500E-01,3.013700E+00,1.715343E+01,6.810499E+01,& + & 1.898251E+02,3.779571E+02,2.891800E-03,1.300900E-02,3.311800E-02,& + & 7.074600E-02,1.425200E-01,3.362700E-01,8.942600E-01,3.072100E+00,& + & 1.720338E+01,6.880394E+01,1.868486E+02,3.691861E+02,3.522800E-03,& + & 1.547400E-02,3.630800E-02,7.415000E-02,1.500100E-01,3.515200E-01,& + & 9.207100E-01,3.113500E+00,1.732676E+01,6.886743E+01,1.836631E+02,& + & 3.613714E+02,4.251300E-03,1.783900E-02,3.958800E-02,7.756900E-02,& + & 1.602800E-01,3.685600E-01,9.508100E-01,3.135300E+00,1.747488E+01,& + & 6.831154E+01,1.808959E+02,3.540113E+02,5.099200E-03,2.009700E-02,& + & 4.308900E-02,8.168000E-02,1.713400E-01,3.848900E-01,9.759300E-01,& + & 3.152600E+00,1.761007E+01,6.795611E+01,1.796737E+02,3.346573E+02,& + & 2.099300E-03,9.572500E-03,2.632900E-02,5.594300E-02,1.127400E-01,& + & 2.695500E-01,7.342200E-01,2.588100E+00,1.579850E+01,6.893209E+01,& + & 2.093671E+02,4.363759E+02,2.608700E-03,1.181800E-02,2.865300E-02,& + & 5.869700E-02,1.183900E-01,2.831500E-01,7.569200E-01,2.633100E+00,& + & 1.589088E+01,6.972646E+01,2.063266E+02,4.259892E+02,3.202700E-03,& + & 1.390400E-02,3.132500E-02,6.167800E-02,1.258200E-01,2.963100E-01,& + & 7.852800E-01,2.666900E+00,1.611202E+01,6.923256E+01,2.033610E+02,& + & 4.164375E+02,3.915500E-03,1.591800E-02,3.421100E-02,6.491400E-02,& + & 1.345300E-01,3.103500E-01,8.114100E-01,2.688700E+00,1.623912E+01,& + & 6.908199E+01,2.012944E+02,4.032497E+02,4.707500E-03,1.795800E-02,& + & 3.700000E-02,6.937900E-02,1.437800E-01,3.248000E-01,8.334900E-01,& + & 2.710600E+00,1.627516E+01,7.075098E+01,1.973635E+02,3.855143E+02,& + & 1.906800E-03,8.967500E-03,2.262000E-02,4.684300E-02,9.355000E-02,& + & 2.274400E-01,6.119200E-01,2.201700E+00,1.433998E+01,6.943188E+01,& + & 2.282779E+02,5.015570E+02,2.422400E-03,1.084200E-02,2.470200E-02,& + & 4.921700E-02,9.968200E-02,2.379200E-01,6.344700E-01,2.247700E+00,& + & 1.454828E+01,6.938076E+01,2.256928E+02,4.891568E+02,2.999300E-03,& + & 1.264200E-02,2.710100E-02,5.183300E-02,1.068100E-01,2.493500E-01,& + & 6.583700E-01,2.274700E+00,1.466613E+01,6.972235E+01,2.230619E+02,& + & 4.778661E+02,3.636600E-03,1.439900E-02,2.934200E-02,5.578300E-02,& + & 1.143200E-01,2.612700E-01,6.785400E-01,2.302200E+00,1.473006E+01,& + & 7.118536E+01,2.203029E+02,4.561316E+02,4.449000E-03,1.604800E-02,& + & 3.164500E-02,5.976700E-02,1.233500E-01,2.735900E-01,7.026900E-01,& + & 2.319900E+00,1.489599E+01,7.212131E+01,2.159282E+02,4.397814E+02,& + & 1.763000E-03,8.167700E-03,1.952100E-02,3.923900E-02,7.970400E-02,& + & 1.919000E-01,5.088400E-01,1.874500E+00,1.293843E+01,6.799628E+01,& + & 2.470304E+02,5.736767E+02,2.226700E-03,9.720200E-03,2.149300E-02,& + & 4.126200E-02,8.592600E-02,2.012800E-01,5.284200E-01,1.911900E+00,& + & 1.306240E+01,6.880087E+01,2.445018E+02,5.591248E+02,2.751400E-03,& + & 1.128000E-02,2.353400E-02,4.403200E-02,9.200600E-02,2.120900E-01,& + & 5.467000E-01,1.940700E+00,1.318225E+01,7.029827E+01,2.413828E+02,& + & 5.381551E+02,3.411400E-03,1.268100E-02,2.533800E-02,4.764200E-02,& + & 9.921600E-02,2.235400E-01,5.662700E-01,1.965000E+00,1.336921E+01,& + & 7.169855E+01,2.373332E+02,5.158823E+02,4.161400E-03,1.416800E-02,& + & 2.712000E-02,5.192500E-02,1.066900E-01,2.363400E-01,5.886700E-01,& + & 1.991000E+00,1.349827E+01,7.274373E+01,2.334063E+02,4.980117E+02,& + & 1.651900E-03,7.433800E-03,1.719900E-02,3.310700E-02,6.956200E-02,& + & 1.655000E-01,4.364000E-01,1.586500E+00,1.159677E+01,6.651110E+01,& + & 2.620661E+02,6.527962E+02,2.088600E-03,8.820500E-03,1.886100E-02,& + & 3.529500E-02,7.439900E-02,1.757200E-01,4.541900E-01,1.618100E+00,& + & 1.174743E+01,6.832053E+01,2.579145E+02,6.353080E+02,2.601000E-03,& + & 1.007600E-02,2.037700E-02,3.854100E-02,8.003100E-02,1.857500E-01,& + & 4.728800E-01,1.643800E+00,1.194418E+01,6.959982E+01,2.562247E+02,& + & 6.026273E+02,3.245700E-03,1.126200E-02,2.191800E-02,4.222000E-02,& + & 8.609000E-02,1.963900E-01,4.919700E-01,1.674400E+00,1.209327E+01,& + & 7.058419E+01,2.534571E+02,5.799334E+02,3.906600E-03,1.242800E-02,& + & 2.354500E-02,4.635700E-02,9.321000E-02,2.086400E-01,5.133600E-01,& + & 1.704400E+00,1.225385E+01,7.130875E+01,2.500968E+02,5.596771E+02/ + data absb(:, 26: 50) / & + & 1.556100E-03,6.863400E-03,1.518100E-02,2.879700E-02,6.102800E-02,& + & 1.466400E-01,3.840700E-01,1.346900E+00,1.046751E+01,6.715175E+01,& + & 2.677826E+02,7.374077E+02,1.973300E-03,8.013300E-03,1.644500E-02,& + & 3.162000E-02,6.537300E-02,1.553300E-01,4.020300E-01,1.373700E+00,& + & 1.066994E+01,6.825875E+01,2.676924E+02,6.999803E+02,2.542900E-03,& + & 8.951300E-03,1.779600E-02,3.463100E-02,7.109700E-02,1.646400E-01,& + & 4.199300E-01,1.406100E+00,1.082505E+01,6.949648E+01,2.658030E+02,& + & 6.715042E+02,3.132500E-03,9.936600E-03,1.917100E-02,3.803400E-02,& + & 7.714300E-02,1.749600E-01,4.401800E-01,1.442200E+00,1.099824E+01,& + & 7.063194E+01,2.637296E+02,6.402857E+02,3.676400E-03,1.101400E-02,& + & 2.075900E-02,4.172500E-02,8.415300E-02,1.853200E-01,4.636200E-01,& + & 1.478400E+00,1.120800E+01,7.193999E+01,2.624714E+02,5.965438E+02,& + & 1.477800E-03,6.355200E-03,1.340100E-02,2.562800E-02,5.413800E-02,& + & 1.308600E-01,3.422800E-01,1.158900E+00,9.449248E+00,6.728419E+01,& + & 2.734907E+02,8.110396E+02,1.947700E-03,7.204700E-03,1.452900E-02,& + & 2.828100E-02,5.914500E-02,1.385700E-01,3.591200E-01,1.193600E+00,& + & 9.609275E+00,6.874707E+01,2.728527E+02,7.754265E+02,2.473400E-03,& + & 8.012900E-03,1.571300E-02,3.113900E-02,6.436600E-02,1.475400E-01,& + & 3.774000E-01,1.234800E+00,9.782796E+00,7.022700E+01,2.718278E+02,& + & 7.366707E+02,2.972500E-03,8.896600E-03,1.703100E-02,3.435800E-02,& + & 7.046100E-02,1.567600E-01,3.988800E-01,1.272800E+00,1.002042E+01,& + & 7.164396E+01,2.715080E+02,6.864793E+02,3.441300E-03,9.838100E-03,& + & 1.853100E-02,3.792500E-02,7.682200E-02,1.680400E-01,4.210300E-01,& + & 1.314600E+00,1.022183E+01,7.321138E+01,2.726807E+02,6.253988E+02,& + & 1.376400E-03,5.639700E-03,1.156600E-02,2.257900E-02,4.769800E-02,& + & 1.147600E-01,3.019900E-01,1.024200E+00,8.355374E+00,6.614623E+01,& + & 2.801835E+02,8.933776E+02,1.820600E-03,6.275500E-03,1.259500E-02,& + & 2.490600E-02,5.241900E-02,1.225600E-01,3.173000E-01,1.066000E+00,& + & 8.526456E+00,6.782440E+01,2.795632E+02,8.536294E+02,2.279400E-03,& + & 6.988700E-03,1.361600E-02,2.755400E-02,5.765700E-02,1.304800E-01,& + & 3.348400E-01,1.105600E+00,8.760010E+00,6.981362E+01,2.793113E+02,& + & 8.001346E+02,2.691800E-03,7.784600E-03,1.479700E-02,3.034500E-02,& + & 6.339800E-02,1.399900E-01,3.535100E-01,1.146600E+00,8.975499E+00,& + & 7.155845E+01,2.821188E+02,7.292056E+02,3.080700E-03,8.539100E-03,& + & 1.619500E-02,3.348800E-02,6.952300E-02,1.505200E-01,3.767500E-01,& + & 1.186900E+00,9.158698E+00,7.354298E+01,2.845018E+02,6.576977E+02,& + & 1.254700E-03,4.892500E-03,9.979000E-03,1.952800E-02,4.212600E-02,& + & 1.004200E-01,2.655300E-01,9.112100E-01,7.343447E+00,6.409607E+01,& + & 2.869918E+02,9.755972E+02,1.661400E-03,5.408800E-03,1.085600E-02,& + & 2.173800E-02,4.632300E-02,1.075500E-01,2.804200E-01,9.527300E-01,& + & 7.560285E+00,6.656534E+01,2.873273E+02,9.176579E+02,2.038700E-03,& + & 6.039900E-03,1.173900E-02,2.410700E-02,5.116400E-02,1.155200E-01,& + & 2.960300E-01,9.942700E-01,7.767825E+00,6.894436E+01,2.896836E+02,& + & 8.462094E+02,2.391200E-03,6.700400E-03,1.284000E-02,2.670700E-02,& + & 5.600700E-02,1.245700E-01,3.160900E-01,1.033200E+00,7.965246E+00,& + & 7.091840E+01,2.940902E+02,7.646221E+02,2.722200E-03,7.328900E-03,& + & 1.403900E-02,2.947500E-02,6.159700E-02,1.354100E-01,3.388200E-01,& + & 1.071000E+00,8.163483E+00,7.285848E+01,2.956906E+02,6.975818E+02,& + & 1.169200E-03,4.200400E-03,8.557100E-03,1.710100E-02,3.687300E-02,& + & 8.781100E-02,2.332000E-01,8.064700E-01,6.464242E+00,6.184620E+01,& + & 2.940574E+02,1.046164E+03,1.503400E-03,4.686400E-03,9.318900E-03,& + & 1.898600E-02,4.076300E-02,9.437600E-02,2.472600E-01,8.444000E-01,& + & 6.664922E+00,6.464517E+01,2.973313E+02,9.684770E+02,1.811700E-03,& + & 5.224700E-03,1.014800E-02,2.103900E-02,4.495800E-02,1.024000E-01,& + & 2.643400E-01,8.811400E-01,6.855487E+00,6.690449E+01,3.029620E+02,& + & 8.800683E+02,2.113600E-03,5.752700E-03,1.114900E-02,2.329600E-02,& + & 4.955600E-02,1.113900E-01,2.836800E-01,9.186600E-01,7.062283E+00,& + & 6.939992E+01,3.063455E+02,7.981520E+02,2.395900E-03,6.251000E-03,& + & 1.227100E-02,2.585500E-02,5.420400E-02,1.219000E-01,3.073600E-01,& + & 9.578500E-01,7.308651E+00,7.180229E+01,3.062419E+02,7.319844E+02/ + data absb(:, 51: 75) / & + & 1.085200E-03,3.598200E-03,7.357800E-03,1.486600E-02,3.220100E-02,& + & 7.674600E-02,2.057800E-01,7.083400E-01,5.686672E+00,5.917750E+01,& + & 3.048363E+02,1.089453E+03,1.357800E-03,4.043200E-03,7.996000E-03,& + & 1.650200E-02,3.576100E-02,8.344000E-02,2.194100E-01,7.454200E-01,& + & 5.857412E+00,6.213406E+01,3.098611E+02,1.001652E+03,1.615200E-03,& + & 4.489200E-03,8.806600E-03,1.833700E-02,3.953000E-02,9.095800E-02,& + & 2.357900E-01,7.799800E-01,6.051420E+00,6.500016E+01,3.136406E+02,& + & 9.172000E+02,1.858000E-03,4.919200E-03,9.677400E-03,2.041400E-02,& + & 4.367000E-02,9.943600E-02,2.562900E-01,8.175900E-01,6.293868E+00,& + & 6.777825E+01,3.170380E+02,8.289982E+02,2.098300E-03,5.326000E-03,& + & 1.071900E-02,2.254800E-02,4.792000E-02,1.083700E-01,2.822400E-01,& + & 8.585000E-01,6.529469E+00,7.113247E+01,3.170734E+02,7.518255E+02,& + & 9.919600E-04,3.134100E-03,6.271000E-03,1.282100E-02,2.823900E-02,& + & 6.702000E-02,1.804500E-01,6.217700E-01,4.961186E+00,5.629043E+01,& + & 3.142810E+02,1.137052E+03,1.221600E-03,3.494200E-03,6.851000E-03,& + & 1.428800E-02,3.130500E-02,7.359700E-02,1.936200E-01,6.542500E-01,& + & 5.147010E+00,5.941507E+01,3.216498E+02,1.032319E+03,1.433200E-03,& + & 3.850600E-03,7.582900E-03,1.594100E-02,3.484400E-02,8.018600E-02,& + & 2.113500E-01,6.879900E-01,5.359058E+00,6.270996E+01,3.260581E+02,& + & 9.375716E+02,1.633600E-03,4.183700E-03,8.428500E-03,1.774700E-02,& + & 3.841500E-02,8.765500E-02,2.337600E-01,7.275100E-01,5.578690E+00,& + & 6.648405E+01,3.271342E+02,8.533367E+02,1.839600E-03,4.508300E-03,& + & 9.341000E-03,1.967900E-02,4.215700E-02,9.584700E-02,2.579300E-01,& + & 7.779900E-01,5.830025E+00,7.009455E+01,3.303513E+02,7.522520E+02,& + & 9.062100E-04,2.707800E-03,5.318900E-03,1.106100E-02,2.466900E-02,& + & 5.885200E-02,1.588500E-01,5.458900E-01,4.373273E+00,5.316712E+01,& + & 3.260915E+02,1.160288E+03,1.093400E-03,2.985300E-03,5.922300E-03,& + & 1.236900E-02,2.751100E-02,6.434200E-02,1.731100E-01,5.772900E-01,& + & 4.576431E+00,5.674381E+01,3.314881E+02,1.060594E+03,1.257900E-03,& + & 3.264400E-03,6.573500E-03,1.387200E-02,3.056800E-02,7.065100E-02,& + & 1.917400E-01,6.130900E-01,4.782803E+00,6.073476E+01,3.358040E+02,& + & 9.585115E+02,1.432600E-03,3.552700E-03,7.316300E-03,1.537900E-02,& + & 3.376900E-02,7.755300E-02,2.124900E-01,6.580400E-01,5.012839E+00,& + & 6.511120E+01,3.390006E+02,8.534132E+02,1.597200E-03,3.835400E-03,& + & 8.116700E-03,1.705900E-02,3.689000E-02,8.559500E-02,2.326100E-01,& + & 7.141200E-01,5.268132E+00,6.897414E+01,3.420270E+02,7.502084E+02,& + & 8.119600E-04,2.316600E-03,4.576300E-03,9.535400E-03,2.158200E-02,& + & 5.150100E-02,1.410100E-01,4.812800E-01,3.939068E+00,5.043479E+01,& + & 3.355382E+02,1.179174E+03,9.654400E-04,2.534900E-03,5.122700E-03,& + & 1.072300E-02,2.417300E-02,5.667700E-02,1.563900E-01,5.141800E-01,& + & 4.135607E+00,5.456920E+01,3.411251E+02,1.071791E+03,1.098900E-03,& + & 2.776000E-03,5.720700E-03,1.201200E-02,2.681100E-02,6.267100E-02,& + & 1.741800E-01,5.532400E-01,4.360594E+00,5.914436E+01,3.457966E+02,& + & 9.589355E+02,1.243900E-03,3.009900E-03,6.356100E-03,1.343000E-02,& + & 2.949600E-02,6.930900E-02,1.911400E-01,6.034700E-01,4.608498E+00,& + & 6.370973E+01,3.495347E+02,8.469766E+02,1.377200E-03,3.244100E-03,& + & 7.042500E-03,1.483900E-02,3.233000E-02,7.686200E-02,2.104800E-01,& + & 6.630800E-01,4.869458E+00,6.812463E+01,3.518897E+02,7.409053E+02,& + & 7.240200E-04,1.958100E-03,3.932900E-03,8.197500E-03,1.884900E-02,& + & 4.506800E-02,1.259900E-01,4.268200E-01,3.554951E+00,4.834696E+01,& + & 3.434193E+02,1.194494E+03,8.438200E-04,2.147600E-03,4.422600E-03,& + & 9.267300E-03,2.109400E-02,5.008900E-02,1.407600E-01,4.605500E-01,& + & 3.784957E+00,5.286756E+01,3.491228E+02,1.078832E+03,9.545500E-04,& + & 2.344200E-03,4.928100E-03,1.038700E-02,2.344600E-02,5.557100E-02,& + & 1.555700E-01,5.052400E-01,4.021896E+00,5.764574E+01,3.553876E+02,& + & 9.528326E+02,1.069200E-03,2.533300E-03,5.455400E-03,1.165000E-02,& + & 2.575500E-02,6.205600E-02,1.718300E-01,5.576500E-01,4.282283E+00,& + & 6.245084E+01,3.602242E+02,8.302450E+02,1.179000E-03,2.728400E-03,& + & 6.047400E-03,1.282700E-02,2.837400E-02,6.853200E-02,1.902300E-01,& + & 6.213500E-01,4.577957E+00,6.671352E+01,3.635568E+02,7.169457E+02/ + data absb(:, 76:100) / & + & 6.381600E-04,1.656600E-03,3.381800E-03,7.023100E-03,1.637900E-02,& + & 3.960600E-02,1.121800E-01,3.800600E-01,3.260337E+00,4.632796E+01,& + & 3.515872E+02,1.198873E+03,7.317300E-04,1.806400E-03,3.792600E-03,& + & 7.970200E-03,1.833000E-02,4.419300E-02,1.254600E-01,4.172100E-01,& + & 3.486530E+00,5.126104E+01,3.603127E+02,1.060165E+03,8.233300E-04,& + & 1.970800E-03,4.206600E-03,8.982800E-03,2.036700E-02,4.940800E-02,& + & 1.390300E-01,4.633700E-01,3.735110E+00,5.612332E+01,3.662917E+02,& + & 9.337322E+02,9.153000E-04,2.122100E-03,4.653100E-03,1.003200E-02,& + & 2.254200E-02,5.505700E-02,1.548200E-01,5.191900E-01,4.017010E+00,& + & 6.075078E+01,3.724169E+02,8.033543E+02,1.000800E-03,2.291500E-03,& + & 5.158500E-03,1.105300E-02,2.493100E-02,6.095600E-02,1.721500E-01,& + & 5.832200E-01,4.349544E+00,6.472018E+01,3.780712E+02,6.767691E+02,& + & 5.561100E-04,1.386500E-03,2.903500E-03,6.020000E-03,1.428000E-02,& + & 3.498900E-02,1.007200E-01,3.419600E-01,3.002252E+00,4.546350E+01,& + & 3.606898E+02,1.179991E+03,6.256100E-04,1.522500E-03,3.227100E-03,& + & 6.842100E-03,1.599300E-02,3.917600E-02,1.125400E-01,3.812500E-01,& + & 3.248347E+00,5.031392E+01,3.693555E+02,1.040723E+03,7.045700E-04,& + & 1.651000E-03,3.585500E-03,7.767000E-03,1.772300E-02,4.403200E-02,& + & 1.258300E-01,4.294300E-01,3.511679E+00,5.511646E+01,3.786925E+02,& + & 8.932050E+02,7.723900E-04,1.781700E-03,3.970500E-03,8.609400E-03,& + & 1.973600E-02,4.917400E-02,1.406200E-01,4.858800E-01,3.827345E+00,& + & 5.950934E+01,3.840250E+02,7.674887E+02,8.407400E-04,1.930800E-03,& + & 4.379900E-03,9.524900E-03,2.189500E-02,5.465500E-02,1.565000E-01,& + & 5.522100E-01,4.182849E+00,6.402007E+01,3.889774E+02,6.371376E+02,& + & 4.775800E-04,1.167100E-03,2.483700E-03,5.155800E-03,1.245100E-02,& + & 3.094300E-02,9.071300E-02,3.109300E-01,2.799089E+00,4.464480E+01,& + & 3.715044E+02,1.144962E+03,5.358500E-04,1.277700E-03,2.764700E-03,& + & 5.882300E-03,1.390200E-02,3.497100E-02,1.019200E-01,3.511400E-01,& + & 3.049253E+00,4.956940E+01,3.828774E+02,9.878204E+02,5.960200E-04,& + & 1.382500E-03,3.048800E-03,6.673500E-03,1.547700E-02,3.939800E-02,& + & 1.146400E-01,4.003800E-01,3.341835E+00,5.425202E+01,3.905627E+02,& + & 8.490007E+02,6.484800E-04,1.496000E-03,3.370300E-03,7.414300E-03,& + & 1.732200E-02,4.402700E-02,1.285400E-01,4.586300E-01,3.678200E+00,& + & 5.887417E+01,3.970849E+02,7.116016E+02,7.029900E-04,1.620300E-03,& + & 3.702900E-03,8.222200E-03,1.923400E-02,4.916300E-02,1.439800E-01,& + & 5.227600E-01,4.049274E+00,6.380539E+01,3.983463E+02,5.967433E+02,& + & 4.023300E-04,9.858600E-04,2.092700E-03,4.450800E-03,1.084000E-02,& + & 2.755300E-02,8.227700E-02,2.861600E-01,2.647694E+00,4.406026E+01,& + & 3.829153E+02,1.098391E+03,4.549400E-04,1.072400E-03,2.328300E-03,& + & 5.103100E-03,1.212200E-02,3.128700E-02,9.309700E-02,3.266800E-01,& + & 2.903481E+00,4.899901E+01,3.958494E+02,9.309316E+02,5.009500E-04,& + & 1.160400E-03,2.571200E-03,5.739500E-03,1.359300E-02,3.535100E-02,& + & 1.052400E-01,3.763300E-01,3.215043E+00,5.380328E+01,4.026101E+02,& + & 7.944092E+02,5.416500E-04,1.256300E-03,2.854500E-03,6.399000E-03,& + & 1.515900E-02,3.978200E-02,1.185600E-01,4.347200E-01,3.555888E+00,& + & 5.904693E+01,4.071975E+02,6.612114E+02,5.835900E-04,1.358800E-03,& + & 3.115700E-03,7.093000E-03,1.692100E-02,4.455800E-02,1.335500E-01,& + & 4.994100E-01,3.915806E+00,6.565107E+01,4.085013E+02,5.286802E+02,& + & 3.414700E-04,8.337800E-04,1.766000E-03,3.868700E-03,9.475300E-03,& + & 2.471000E-02,7.530300E-02,2.668800E-01,2.554701E+00,4.354351E+01,& + & 3.978911E+02,1.024010E+03,3.832700E-04,9.039600E-04,1.956800E-03,& + & 4.422600E-03,1.065100E-02,2.815500E-02,8.576300E-02,3.082000E-01,& + & 2.797279E+00,4.877464E+01,4.075251E+02,8.736457E+02,4.204900E-04,& + & 9.742900E-04,2.167600E-03,4.963400E-03,1.199200E-02,3.186900E-02,& + & 9.740100E-02,3.588300E-01,3.110686E+00,5.417385E+01,4.145828E+02,& + & 7.281768E+02,4.551200E-04,1.056800E-03,2.392300E-03,5.549900E-03,& + & 1.339700E-02,3.609900E-02,1.105400E-01,4.152300E-01,3.451158E+00,& + & 6.156417E+01,4.159307E+02,5.901082E+02,4.872100E-04,1.147000E-03,& + & 2.615900E-03,6.144700E-03,1.488700E-02,4.066600E-02,1.252600E-01,& + & 4.820600E-01,3.832574E+00,6.899730E+01,4.157556E+02,4.552091E+02/ + data absb(:,101:125) / & + & 2.921000E-04,7.036900E-04,1.487100E-03,3.386000E-03,8.335800E-03,& + & 2.217300E-02,6.950600E-02,2.514900E-01,2.491926E+00,4.314919E+01,& + & 4.099658E+02,9.624711E+02,3.246500E-04,7.561800E-04,1.649900E-03,& + & 3.841400E-03,9.424900E-03,2.536200E-02,7.954900E-02,2.953800E-01,& + & 2.719665E+00,4.944733E+01,4.189172E+02,8.045441E+02,3.527600E-04,& + & 8.219600E-04,1.821300E-03,4.317000E-03,1.059200E-02,2.899000E-02,& + & 9.090200E-02,3.447300E-01,3.028153E+00,5.722385E+01,4.214446E+02,& + & 6.596747E+02,3.815300E-04,8.919600E-04,2.006600E-03,4.812900E-03,& + & 1.187100E-02,3.296500E-02,1.039800E-01,4.032700E-01,3.383478E+00,& + & 6.497769E+01,4.237375E+02,5.103525E+02,4.112100E-04,9.649300E-04,& + & 2.197900E-03,5.311300E-03,1.320800E-02,3.729700E-02,1.186200E-01,& + & 4.695300E-01,3.787540E+00,7.237877E+01,4.235236E+02,3.742218E+02,& + & 2.493000E-04,5.933400E-04,1.267000E-03,2.966700E-03,7.379900E-03,& + & 2.010700E-02,6.472700E-02,2.406900E-01,2.465767E+00,4.358329E+01,& + & 4.204515E+02,8.975211E+02,2.758400E-04,6.384700E-04,1.401200E-03,& + & 3.357200E-03,8.376500E-03,2.310900E-02,7.455400E-02,2.851600E-01,& + & 2.707250E+00,5.170502E+01,4.249729E+02,7.441554E+02,2.992000E-04,& + & 6.988800E-04,1.548500E-03,3.764200E-03,9.445600E-03,2.657400E-02,& + & 8.591800E-02,3.356300E-01,2.991710E+00,6.009085E+01,4.295727E+02,& + & 5.815181E+02,3.224700E-04,7.567500E-04,1.707300E-03,4.188200E-03,& + & 1.058200E-02,3.033200E-02,9.893000E-02,3.942100E-01,3.366947E+00,& + & 6.813538E+01,4.312619E+02,4.308061E+02,3.475900E-04,8.174100E-04,& + & 1.873500E-03,4.597300E-03,1.186300E-02,3.435700E-02,1.137400E-01,& + & 4.604000E-01,3.805678E+00,7.554326E+01,4.300152E+02,2.980534E+02,& + & 2.120800E-04,4.941900E-04,1.067200E-03,2.585400E-03,6.463100E-03,& + & 1.802200E-02,5.957300E-02,2.292300E-01,2.441440E+00,4.503239E+01,& + & 4.276197E+02,8.417722E+02,2.341900E-04,5.343000E-04,1.181300E-03,& + & 2.916000E-03,7.362800E-03,2.087700E-02,6.948000E-02,2.732800E-01,& + & 2.694810E+00,5.352075E+01,4.334610E+02,6.752497E+02,2.525300E-04,& + & 5.862500E-04,1.313100E-03,3.254200E-03,8.336400E-03,2.413200E-02,& + & 8.060200E-02,3.251000E-01,2.963942E+00,6.245518E+01,4.379281E+02,& + & 5.082222E+02,2.725200E-04,6.369000E-04,1.444900E-03,3.612000E-03,& + & 9.341900E-03,2.771000E-02,9.354900E-02,3.830000E-01,3.347645E+00,& + & 7.056448E+01,4.384199E+02,3.633416E+02,2.927900E-04,6.868500E-04,& + & 1.592400E-03,3.957400E-03,1.052600E-02,3.152000E-02,1.084700E-01,& + & 4.489900E-01,3.810173E+00,7.861197E+01,4.335901E+02,2.429250E+02,& + & 1.781100E-04,4.119600E-04,8.918500E-04,2.213200E-03,5.592600E-03,& + & 1.596300E-02,5.420000E-02,2.167700E-01,2.400906E+00,4.584071E+01,& + & 4.355986E+02,7.905861E+02,1.945900E-04,4.515100E-04,9.873300E-04,& + & 2.500400E-03,6.388800E-03,1.865900E-02,6.382500E-02,2.603700E-01,& + & 2.672545E+00,5.460785E+01,4.423031E+02,6.145612E+02,2.119500E-04,& + & 4.920300E-04,1.095500E-03,2.785900E-03,7.258500E-03,2.166000E-02,& + & 7.484200E-02,3.118300E-01,2.957279E+00,6.364364E+01,4.465865E+02,& + & 4.463068E+02,2.290800E-04,5.316200E-04,1.216800E-03,3.072200E-03,& + & 8.219200E-03,2.492900E-02,8.768900E-02,3.688300E-01,3.300115E+00,& + & 7.263510E+01,4.467396E+02,2.967979E+02,2.461900E-04,5.714000E-04,& + & 1.344100E-03,3.367300E-03,9.246200E-03,2.856000E-02,1.022400E-01,& + & 4.350900E-01,3.756774E+00,8.094682E+01,4.383345E+02,1.953436E+02,& + & 1.425200E-04,3.381300E-04,7.282000E-04,1.839700E-03,4.701500E-03,& + & 1.376400E-02,4.794100E-02,1.984800E-01,2.306324E+00,4.502769E+01,& + & 4.386914E+02,7.931495E+02,1.580200E-04,3.686000E-04,8.053700E-04,& + & 2.079800E-03,5.395100E-03,1.618800E-02,5.708300E-02,2.398600E-01,& + & 2.588910E+00,5.372442E+01,4.456822E+02,6.160712E+02,1.712400E-04,& + & 4.027700E-04,8.952800E-04,2.318500E-03,6.168000E-03,1.891600E-02,& + & 6.756000E-02,2.896500E-01,2.877979E+00,6.295918E+01,4.506632E+02,& + & 4.414597E+02,1.855700E-04,4.345900E-04,9.991000E-04,2.552500E-03,& + & 7.022900E-03,2.193200E-02,8.004100E-02,3.442100E-01,3.224959E+00,& + & 7.203907E+01,4.509162E+02,2.906238E+02,1.996700E-04,4.672200E-04,& + & 1.105000E-03,2.804600E-03,7.932900E-03,2.529400E-02,9.391900E-02,& + & 4.085400E-01,3.625365E+00,8.099352E+01,4.425042E+02,1.866528E+02/ + data absb(:,126:150) / & + & 1.131600E-04,2.781700E-04,5.918600E-04,1.524100E-03,3.951700E-03,& + & 1.184900E-02,4.242300E-02,1.814300E-01,2.219174E+00,4.410285E+01,& + & 4.411041E+02,8.002272E+02,1.269100E-04,3.015100E-04,6.559100E-04,& + & 1.724000E-03,4.564400E-03,1.402800E-02,5.105700E-02,2.212700E-01,& + & 2.504026E+00,5.280035E+01,4.485617E+02,6.206049E+02,1.387500E-04,& + & 3.294300E-04,7.292200E-04,1.925000E-03,5.242900E-03,1.649400E-02,& + & 6.098300E-02,2.690100E-01,2.798253E+00,6.212844E+01,4.543282E+02,& + & 4.405921E+02,1.494000E-04,3.559300E-04,8.175900E-04,2.119000E-03,& + & 6.014100E-03,1.926900E-02,7.287300E-02,3.221200E-01,3.154184E+00,& + & 7.146030E+01,4.546157E+02,2.862920E+02,1.614900E-04,3.822700E-04,& + & 9.044100E-04,2.333400E-03,6.818400E-03,2.234000E-02,8.648400E-02,& + & 3.846800E-01,3.526202E+00,8.079634E+01,4.466375E+02,1.781443E+02,& + & 8.973400E-05,2.286700E-04,4.832700E-04,1.257800E-03,3.326600E-03,& + & 1.020700E-02,3.758900E-02,1.660600E-01,2.135304E+00,4.336645E+01,& + & 4.437596E+02,8.030267E+02,1.011100E-04,2.476200E-04,5.347700E-04,& + & 1.425800E-03,3.862900E-03,1.219400E-02,4.560600E-02,2.045500E-01,& + & 2.424746E+00,5.212161E+01,4.517177E+02,6.199136E+02,1.111000E-04,& + & 2.696800E-04,5.952700E-04,1.597400E-03,4.457500E-03,1.440100E-02,& + & 5.515500E-02,2.502400E-01,2.728329E+00,6.157685E+01,4.573978E+02,& + & 4.387686E+02,1.210400E-04,2.900800E-04,6.688400E-04,1.760200E-03,& + & 5.147300E-03,1.694100E-02,6.651100E-02,3.020300E-01,3.088013E+00,& + & 7.095605E+01,4.584876E+02,2.793129E+02,1.301800E-04,3.120900E-04,& + & 7.402600E-04,1.941400E-03,5.864600E-03,1.979600E-02,7.970300E-02,& + & 3.636300E-01,3.459797E+00,8.041302E+01,4.510607E+02,1.667629E+02,& + & 6.986200E-05,1.834200E-04,3.867100E-04,1.013600E-03,2.728100E-03,& + & 8.557300E-03,3.228700E-02,1.474100E-01,2.011943E+00,4.122962E+01,& + & 4.421276E+02,8.514000E+02,7.933800E-05,1.977300E-04,4.286900E-04,& + & 1.151100E-03,3.181800E-03,1.031500E-02,3.960500E-02,1.832200E-01,& + & 2.302659E+00,4.989532E+01,4.508650E+02,6.653913E+02,8.735100E-05,& + & 2.163100E-04,4.762800E-04,1.292500E-03,3.693200E-03,1.226000E-02,& + & 4.848900E-02,2.260300E-01,2.603335E+00,5.918237E+01,4.585151E+02,& + & 4.754759E+02,9.536100E-05,2.325400E-04,5.368600E-04,1.427400E-03,& + & 4.274200E-03,1.455900E-02,5.915300E-02,2.752000E-01,2.948001E+00,& + & 6.884777E+01,4.604543E+02,3.096009E+02,1.035000E-04,2.497600E-04,& + & 5.950200E-04,1.579900E-03,4.897600E-03,1.714100E-02,7.137900E-02,& + & 3.341700E-01,3.320182E+00,7.821352E+01,4.543665E+02,1.906376E+02,& + & 5.390300E-05,1.467600E-04,3.086200E-04,8.125500E-04,2.227000E-03,& + & 7.129000E-03,2.761100E-02,1.301100E-01,1.894012E+00,3.896620E+01,& + & 4.387234E+02,9.110820E+02,6.137700E-05,1.581000E-04,3.416600E-04,& + & 9.248500E-04,2.611300E-03,8.673800E-03,3.424100E-02,1.630800E-01,& + & 2.176204E+00,4.762262E+01,4.497479E+02,7.131218E+02,6.859600E-05,& + & 1.721600E-04,3.800000E-04,1.042100E-03,3.038600E-03,1.040300E-02,& + & 4.242500E-02,2.031900E-01,2.469588E+00,5.677682E+01,4.583765E+02,& + & 5.202670E+02,7.491000E-05,1.859400E-04,4.274500E-04,1.156000E-03,& + & 3.530800E-03,1.244500E-02,5.231200E-02,2.496500E-01,2.806434E+00,& + & 6.637140E+01,4.605002E+02,3.553271E+02,8.152500E-05,1.996000E-04,& + & 4.758000E-04,1.282300E-03,4.060100E-03,1.480100E-02,6.359700E-02,& + & 3.058800E-01,3.173871E+00,7.592622E+01,4.560935E+02,2.254117E+02,& + & 4.135300E-05,1.174600E-04,2.457700E-04,6.507600E-04,1.809300E-03,& + & 5.917900E-03,2.352600E-02,1.148400E-01,1.786182E+00,3.677655E+01,& + & 4.357723E+02,9.659515E+02,4.732700E-05,1.266500E-04,2.716800E-04,& + & 7.407600E-04,2.140300E-03,7.270900E-03,2.954400E-02,1.449100E-01,& + & 2.058962E+00,4.528501E+01,4.477491E+02,7.656916E+02,5.346400E-05,& + & 1.367200E-04,3.022100E-04,8.389100E-04,2.494700E-03,8.812200E-03,& + & 3.705000E-02,1.823300E-01,2.342435E+00,5.428591E+01,4.568788E+02,& + & 5.731234E+02,5.887300E-05,1.483600E-04,3.394200E-04,9.353600E-04,& + & 2.913600E-03,1.062700E-02,4.606600E-02,2.263800E-01,2.670678E+00,& + & 6.394243E+01,4.592506E+02,4.075060E+02,6.381300E-05,1.588100E-04,& + & 3.802500E-04,1.039800E-03,3.356600E-03,1.278700E-02,5.662400E-02,& + & 2.796400E-01,3.033414E+00,7.344600E+01,4.583852E+02,2.580998E+02/ + data absb(:,151:175) / & + & 3.117700E-05,9.308600E-05,1.941600E-04,5.145700E-04,1.451000E-03,& + & 4.831800E-03,1.972400E-02,9.927900E-02,1.658569E+00,3.416248E+01,& + & 4.318795E+02,1.032743E+03,3.602100E-05,1.001300E-04,2.147900E-04,& + & 5.867500E-04,1.724700E-03,5.989200E-03,2.507700E-02,1.263300E-01,& + & 1.921061E+00,4.245103E+01,4.434389E+02,8.394756E+02,4.074800E-05,& + & 1.078000E-04,2.387800E-04,6.662500E-04,2.029400E-03,7.333400E-03,& + & 3.178700E-02,1.603900E-01,2.197866E+00,5.132745E+01,4.508331E+02,& + & 6.602016E+02,4.523600E-05,1.171100E-04,2.670200E-04,7.502500E-04,& + & 2.371600E-03,8.951400E-03,3.992200E-02,2.017900E-01,2.513621E+00,& + & 6.061988E+01,4.582632E+02,4.704199E+02,4.938800E-05,1.258300E-04,& + & 3.006900E-04,8.333200E-04,2.740700E-03,1.087400E-02,4.965600E-02,& + & 2.514300E-01,2.870672E+00,7.018027E+01,4.598815E+02,3.068001E+02,& + & 2.315500E-05,7.323200E-05,1.537400E-04,4.013000E-04,1.156500E-03,& + & 3.899900E-03,1.636000E-02,8.490400E-02,1.520959E+00,3.173167E+01,& + & 4.243169E+02,1.119873E+03,2.710500E-05,7.880500E-05,1.692900E-04,& + & 4.611200E-04,1.380900E-03,4.876700E-03,2.105400E-02,1.092900E-01,& + & 1.784878E+00,3.935094E+01,4.367258E+02,9.301961E+02,3.075000E-05,& + & 8.488200E-05,1.877600E-04,5.250000E-04,1.635600E-03,6.050100E-03,& + & 2.699400E-02,1.395300E-01,2.053835E+00,4.810636E+01,4.479992E+02,& + & 7.310803E+02,3.448700E-05,9.201100E-05,2.095000E-04,5.935300E-04,& + & 1.917000E-03,7.481600E-03,3.425400E-02,1.776600E-01,2.359550E+00,& + & 5.696384E+01,4.562807E+02,5.428375E+02,3.790200E-05,9.942400E-05,& + & 2.355600E-04,6.639600E-04,2.219900E-03,9.179400E-03,4.310600E-02,& + & 2.237900E-01,2.701588E+00,6.645793E+01,4.573999E+02,3.849120E+02,& + & 1.693900E-05,5.725700E-05,1.216300E-04,3.117400E-04,9.207400E-04,& + & 3.136000E-03,1.347900E-02,7.236700E-02,1.388938E+00,2.934420E+01,& + & 4.175779E+02,1.200692E+03,2.001900E-05,6.228300E-05,1.330100E-04,& + & 3.617600E-04,1.101100E-03,3.960100E-03,1.756300E-02,9.401500E-02,& + & 1.652457E+00,3.636587E+01,4.330832E+02,1.000404E+03,2.315200E-05,& + & 6.682700E-05,1.469500E-04,4.128100E-04,1.311000E-03,4.983700E-03,& + & 2.281000E-02,1.209700E-01,1.916326E+00,4.490043E+01,4.429317E+02,& + & 8.138451E+02,2.603400E-05,7.210400E-05,1.643300E-04,4.694300E-04,& + & 1.543200E-03,6.224000E-03,2.930800E-02,1.552600E-01,2.208993E+00,& + & 5.367247E+01,4.502013E+02,6.347515E+02,2.882500E-05,7.803900E-05,& + & 1.843500E-04,5.274900E-04,1.797400E-03,7.731100E-03,3.733100E-02,& + & 1.978600E-01,2.538957E+00,6.280635E+01,4.556663E+02,4.568260E+02,& + & 1.218800E-05,4.502400E-05,9.492800E-05,2.419800E-04,7.279900E-04,& + & 2.502700E-03,1.098200E-02,6.101200E-02,1.263486E+00,2.679171E+01,& + & 4.071810E+02,1.303954E+03,1.477400E-05,4.893500E-05,1.042600E-04,& + & 2.834700E-04,8.714700E-04,3.182700E-03,1.452400E-02,8.026900E-02,& + & 1.520936E+00,3.365811E+01,4.261947E+02,1.086393E+03,1.722000E-05,& + & 5.260000E-05,1.154600E-04,3.232700E-04,1.046800E-03,4.054000E-03,& + & 1.910900E-02,1.041900E-01,1.782843E+00,4.147411E+01,4.373518E+02,& + & 9.016286E+02,1.959000E-05,5.660000E-05,1.284100E-04,3.694000E-04,& + & 1.237500E-03,5.132900E-03,2.487200E-02,1.347000E-01,2.071174E+00,& + & 5.010071E+01,4.465382E+02,7.142628E+02,2.182000E-05,6.128000E-05,& + & 1.441000E-04,4.184700E-04,1.447500E-03,6.448000E-03,3.203200E-02,& + & 1.733100E-01,2.382887E+00,5.913048E+01,4.536457E+02,5.300825E+02,& + & 8.559800E-06,3.535700E-05,7.399500E-05,1.865300E-04,5.682500E-04,& + & 1.975600E-03,8.818200E-03,5.041800E-02,1.139243E+00,2.419740E+01,& + & 3.945428E+02,1.420814E+03,1.076500E-05,3.809800E-05,8.213000E-05,& + & 2.194600E-04,6.857600E-04,2.527300E-03,1.181500E-02,6.758100E-02,& + & 1.388104E+00,3.072803E+01,4.169752E+02,1.188599E+03,1.271900E-05,& + & 4.133900E-05,9.021200E-05,2.529700E-04,8.282700E-04,3.261000E-03,& + & 1.575500E-02,8.866700E-02,1.650620E+00,3.783955E+01,4.315471E+02,& + & 9.926977E+02,1.462800E-05,4.440500E-05,1.000600E-04,2.903300E-04,& + & 9.830000E-04,4.174900E-03,2.078500E-02,1.155600E-01,1.928939E+00,& + & 4.621325E+01,4.408247E+02,8.097195E+02,1.642800E-05,4.794000E-05,& + & 1.118600E-04,3.311700E-04,1.159500E-03,5.312200E-03,2.711700E-02,& + & 1.502300E-01,2.230587E+00,5.505688E+01,4.477655E+02,6.306715E+02/ + data absb(:,176:200) / & + & 5.926200E-06,2.781500E-05,5.789300E-05,1.427300E-04,4.436200E-04,& + & 1.547300E-03,7.029700E-03,4.155500E-02,1.021029E+00,2.167978E+01,& + & 3.845306E+02,1.519641E+03,7.634900E-06,2.996700E-05,6.396200E-05,& + & 1.699000E-04,5.378500E-04,1.996000E-03,9.522800E-03,5.634500E-02,& + & 1.262812E+00,2.780294E+01,4.069414E+02,1.294443E+03,9.260100E-06,& + & 3.243700E-05,7.035200E-05,1.978000E-04,6.513200E-04,2.604300E-03,& + & 1.288300E-02,7.499900E-02,1.515780E+00,3.475094E+01,4.235808E+02,& + & 1.089993E+03,1.081100E-05,3.487300E-05,7.803200E-05,2.270300E-04,& + & 7.794700E-04,3.377200E-03,1.724800E-02,9.881100E-02,1.793101E+00,& + & 4.238515E+01,4.346126E+02,9.063699E+02,1.230600E-05,3.740200E-05,& + & 8.707200E-05,2.607600E-04,9.272900E-04,4.343700E-03,2.280800E-02,& + & 1.293400E-01,2.086976E+00,5.104489E+01,4.429946E+02,7.226358E+02,& + & 3.933200E-06,2.193900E-05,4.505100E-05,1.102000E-04,3.436000E-04,& + & 1.206800E-03,5.557000E-03,3.390400E-02,9.099893E-01,1.947797E+01,& + & 3.719980E+02,1.628720E+03,5.261200E-06,2.349200E-05,4.990800E-05,& + & 1.307600E-04,4.200400E-04,1.570600E-03,7.614100E-03,4.639200E-02,& + & 1.143301E+00,2.514817E+01,3.952408E+02,1.405914E+03,6.634500E-06,& + & 2.530500E-05,5.530600E-05,1.536900E-04,5.106000E-04,2.067400E-03,& + & 1.044600E-02,6.293900E-02,1.388705E+00,3.170553E+01,4.161318E+02,& + & 1.182559E+03,7.839000E-06,2.733200E-05,6.083700E-05,1.773600E-04,& + & 6.167300E-04,2.709100E-03,1.419300E-02,8.387300E-02,1.663178E+00,& + & 3.877009E+01,4.292970E+02,9.941947E+02,9.016000E-06,2.932300E-05,& + & 6.792700E-05,2.045300E-04,7.391300E-04,3.530700E-03,1.903000E-02,& + & 1.107700E-01,1.949024E+00,4.704754E+01,4.367853E+02,8.220104E+02,& + & 2.691500E-06,1.723700E-05,3.530300E-05,8.584000E-05,2.663900E-04,& + & 9.452100E-04,4.401800E-03,2.792400E-02,8.155819E-01,1.812306E+01,& + & 3.593494E+02,1.727092E+03,3.706200E-06,1.852800E-05,3.932600E-05,& + & 1.009800E-04,3.297400E-04,1.239600E-03,6.098800E-03,3.864400E-02,& + & 1.034042E+00,2.274212E+01,3.857072E+02,1.500094E+03,4.752800E-06,& + & 1.995300E-05,4.332400E-05,1.200300E-04,4.031000E-04,1.644500E-03,& + & 8.507800E-03,5.310300E-02,1.280556E+00,2.893231E+01,4.066573E+02,& + & 1.281878E+03,5.759100E-06,2.152500E-05,4.781200E-05,1.393700E-04,& + & 4.899100E-04,2.180100E-03,1.172700E-02,7.181700E-02,1.540829E+00,& + & 3.584335E+01,4.224789E+02,1.081583E+03,6.682800E-06,2.315900E-05,& + & 5.316400E-05,1.613300E-04,5.918200E-04,2.879200E-03,1.595800E-02,& + & 9.586000E-02,1.822571E+00,4.342707E+01,4.322592E+02,9.051515E+02,& + & 1.903100E-06,1.343600E-05,2.777100E-05,6.737500E-05,2.070500E-04,& + & 7.380400E-04,3.481300E-03,2.302700E-02,7.309611E-01,1.702987E+01,& + & 3.495878E+02,1.803686E+03,2.563300E-06,1.467100E-05,3.085600E-05,& + & 7.866700E-05,2.580300E-04,9.774600E-04,4.879000E-03,3.225400E-02,& + & 9.356239E-01,2.054019E+01,3.745412E+02,1.600229E+03,3.381700E-06,& + & 1.580200E-05,3.405400E-05,9.369100E-05,3.179000E-04,1.307600E-03,& + & 6.908700E-03,4.477000E-02,1.179553E+00,2.635346E+01,3.967939E+02,& + & 1.380083E+03,4.221200E-06,1.695700E-05,3.780400E-05,1.096700E-04,& + & 3.888600E-04,1.754200E-03,9.674000E-03,6.163000E-02,1.428023E+00,& + & 3.297796E+01,4.160016E+02,1.164993E+03,4.997300E-06,1.829600E-05,& + & 4.175800E-05,1.271400E-04,4.740100E-04,2.340900E-03,1.337000E-02,& + & 8.318900E-02,1.707717E+00,4.006617E+01,4.275316E+02,9.849995E+02,& + & 1.302200E-06,1.045000E-05,2.193800E-05,5.233300E-05,1.610400E-04,& + & 5.720600E-04,2.725900E-03,1.886000E-02,6.541814E-01,1.592198E+01,& + & 3.380039E+02,1.890401E+03,1.787600E-06,1.153800E-05,2.422700E-05,& + & 6.132100E-05,2.015600E-04,7.676300E-04,3.864500E-03,2.678300E-02,& + & 8.441163E-01,1.887486E+01,3.636702E+02,1.691349E+03,2.412900E-06,& + & 1.243800E-05,2.691900E-05,7.276500E-05,2.499800E-04,1.033800E-03,& + & 5.550300E-03,3.756300E-02,1.073647E+00,2.396519E+01,3.879539E+02,& + & 1.469714E+03,3.058200E-06,1.342100E-05,2.973300E-05,8.600800E-05,& + & 3.071300E-04,1.401500E-03,7.931300E-03,5.248100E-02,1.318352E+00,& + & 3.025163E+01,4.068159E+02,1.262182E+03,3.677000E-06,1.443300E-05,& + & 3.298100E-05,9.991500E-05,3.775900E-04,1.890900E-03,1.113300E-02,& + & 7.194100E-02,1.589237E+00,3.716215E+01,4.216976E+02,1.066076E+03/ + data absb(:,201:225) / & + & 8.851400E-07,8.110600E-06,1.718700E-05,4.065800E-05,1.242200E-04,& + & 4.422500E-04,2.115300E-03,1.531500E-02,5.809764E-01,1.483172E+01,& + & 3.250322E+02,1.984212E+03,1.253100E-06,9.028200E-06,1.905000E-05,& + & 4.766400E-05,1.567000E-04,5.980500E-04,3.033600E-03,2.204500E-02,& + & 7.577814E-01,1.779149E+01,3.545051E+02,1.764829E+03,1.665100E-06,& + & 9.812000E-06,2.122400E-05,5.651400E-05,1.958700E-04,8.124800E-04,& + & 4.419500E-03,3.136300E-02,9.736213E-01,2.175212E+01,3.761662E+02,& + & 1.574202E+03,2.170100E-06,1.059300E-05,2.337400E-05,6.730000E-05,& + & 2.421100E-04,1.111300E-03,6.430000E-03,4.423100E-02,1.215768E+00,& + & 2.762899E+01,3.975259E+02,1.357807E+03,2.682100E-06,1.133900E-05,& + & 2.598600E-05,7.870100E-05,2.992500E-04,1.517000E-03,9.171400E-03,& + & 6.171000E-02,1.471612E+00,3.425968E+01,4.153930E+02,1.149434E+03,& + & 6.317400E-07,6.316600E-06,1.355100E-05,3.185700E-05,9.644300E-05,& + & 3.446700E-04,1.664900E-03,1.258300E-02,5.168702E-01,1.378783E+01,& + & 3.157118E+02,2.054684E+03,9.049000E-07,7.078500E-06,1.508400E-05,& + & 3.747800E-05,1.223900E-04,4.701000E-04,2.409900E-03,1.840300E-02,& + & 6.826484E-01,1.677473E+01,3.440591E+02,1.843846E+03,1.216400E-06,& + & 7.792400E-06,1.667100E-05,4.430600E-05,1.545900E-04,6.427200E-04,& + & 3.560200E-03,2.658600E-02,8.842607E-01,1.987112E+01,3.678617E+02,& + & 1.652512E+03,1.623100E-06,8.401600E-06,1.849300E-05,5.302500E-05,& + & 1.920300E-04,8.884800E-04,5.265100E-03,3.790100E-02,1.124238E+00,& + & 2.537346E+01,3.891771E+02,1.442117E+03,2.020100E-06,8.992600E-06,& + & 2.063900E-05,6.229900E-05,2.386600E-04,1.227600E-03,7.655800E-03,& + & 5.372700E-02,1.367431E+00,3.169157E+01,4.058309E+02,1.246608E+03,& + & 4.609200E-07,4.936100E-06,1.073600E-05,2.495500E-05,7.534500E-05,& + & 2.688500E-04,1.312000E-03,1.038200E-02,4.596901E-01,1.297040E+01,& + & 3.053208E+02,2.128036E+03,6.638600E-07,5.583000E-06,1.199800E-05,& + & 2.943500E-05,9.616300E-05,3.692500E-04,1.922300E-03,1.540400E-02,& + & 6.151735E-01,1.579746E+01,3.325280E+02,1.927963E+03,9.147700E-07,& + & 6.185800E-06,1.323000E-05,3.482300E-05,1.218500E-04,5.105100E-04,& + & 2.874600E-03,2.258400E-02,8.033748E-01,1.869329E+01,3.603627E+02,& + & 1.716991E+03,1.227800E-06,6.702100E-06,1.471400E-05,4.157800E-05,& + & 1.527800E-04,7.123800E-04,4.320400E-03,3.268400E-02,1.035943E+00,& + & 2.331060E+01,3.784359E+02,1.537716E+03,1.550400E-06,7.174400E-06,& + & 1.638700E-05,4.941900E-05,1.909200E-04,9.942400E-04,6.414400E-03,& + & 4.705300E-02,1.273868E+00,2.936084E+01,3.984203E+02,1.326843E+03,& + & 3.331200E-07,3.847200E-06,8.478000E-06,1.965500E-05,5.847900E-05,& + & 2.089100E-04,1.028000E-03,8.494400E-03,4.084018E-01,1.206493E+01,& + & 2.936294E+02,2.209480E+03,4.857900E-07,4.359600E-06,9.561300E-06,& + & 2.300900E-05,7.538800E-05,2.886600E-04,1.521300E-03,1.279900E-02,& + & 5.520631E-01,1.478916E+01,3.239344E+02,1.994091E+03,6.877400E-07,& + & 4.872700E-06,1.053500E-05,2.716900E-05,9.616300E-05,4.032300E-04,& + & 2.303400E-03,1.913300E-02,7.286563E-01,1.771291E+01,3.510506E+02,& + & 1.789206E+03,9.149500E-07,5.336200E-06,1.172200E-05,3.257000E-05,& + & 1.210900E-04,5.685400E-04,3.525400E-03,2.810600E-02,9.481781E-01,& + & 2.139408E+01,3.718116E+02,1.606710E+03,1.185600E-06,5.726100E-06,& + & 1.298100E-05,3.900500E-05,1.522400E-04,8.031800E-04,5.335500E-03,& + & 4.101000E-02,1.183358E+00,2.712251E+01,3.905569E+02,1.408288E+03,& + & 2.400400E-07,2.983300E-06,6.689200E-06,1.547600E-05,4.517300E-05,& + & 1.620600E-04,8.011900E-04,6.885200E-03,3.625859E-01,1.113253E+01,& + & 2.832435E+02,2.282638E+03,3.556700E-07,3.404500E-06,7.548600E-06,& + & 1.810000E-05,5.872800E-05,2.245700E-04,1.196100E-03,1.059800E-02,& + & 4.930080E-01,1.385817E+01,3.143891E+02,2.064172E+03,5.141800E-07,& + & 3.801900E-06,8.387400E-06,2.134000E-05,7.543200E-05,3.166300E-04,& + & 1.835300E-03,1.608100E-02,6.583089E-01,1.677540E+01,3.393412E+02,& + & 1.874481E+03,6.828000E-07,4.218400E-06,9.304000E-06,2.552100E-05,& + & 9.573500E-05,4.515400E-04,2.856500E-03,2.399100E-02,8.626198E-01,& + & 1.972200E+01,3.653486E+02,1.671287E+03,9.096000E-07,4.553300E-06,& + & 1.032400E-05,3.066700E-05,1.208400E-04,6.443600E-04,4.405400E-03,& + & 3.549800E-02,1.091664E+00,2.496808E+01,3.803870E+02,1.502077E+03/ + data absb(:,226:235) / & + & 1.742400E-07,2.293200E-06,5.328200E-06,1.215400E-05,3.511000E-05,& + & 1.256500E-04,6.259600E-04,5.589500E-03,3.241609E-01,1.026867E+01,& + & 2.715450E+02,2.362130E+03,2.629000E-07,2.674200E-06,5.953000E-06,& + & 1.429200E-05,4.565900E-05,1.753400E-04,9.422300E-04,8.776800E-03,& + & 4.407708E-01,1.302437E+01,3.033619E+02,2.141407E+03,3.830400E-07,& + & 3.002400E-06,6.684100E-06,1.682700E-05,5.910800E-05,2.491900E-04,& + & 1.464800E-03,1.353500E-02,5.950141E-01,1.582170E+01,3.316924E+02,& + & 1.934793E+03,5.188000E-07,3.329100E-06,7.407800E-06,2.005000E-05,& + & 7.568400E-05,3.584900E-04,2.319400E-03,2.056700E-02,7.855509E-01,& + & 1.866531E+01,3.568909E+02,1.739859E+03,6.994800E-07,3.604700E-06,& + & 8.229800E-06,2.416700E-05,9.578000E-05,5.183500E-04,3.641600E-03,& + & 3.087200E-02,1.010848E+00,2.304323E+01,3.748404E+02,1.564491E+03,& + & 1.454500E-07,1.832300E-06,4.345900E-06,9.890100E-06,2.866900E-05,& + & 1.037000E-04,5.292300E-04,4.970500E-03,3.072393E-01,9.957181E+00,& + & 2.673865E+02,2.390573E+03,2.224900E-07,2.171400E-06,4.832100E-06,& + & 1.164700E-05,3.745200E-05,1.459000E-04,8.107900E-04,7.960000E-03,& + & 4.175878E-01,1.260983E+01,2.995630E+02,2.169526E+03,3.305600E-07,& + & 2.429200E-06,5.456700E-06,1.376000E-05,4.857700E-05,2.097200E-04,& + & 1.284700E-03,1.247300E-02,5.663781E-01,1.536696E+01,3.280246E+02,& + & 1.963486E+03,4.448700E-07,2.699900E-06,6.036900E-06,1.645400E-05,& + & 6.255300E-05,3.057200E-04,2.068100E-03,1.931900E-02,7.502640E-01,& + & 1.824670E+01,3.505970E+02,1.784893E+03,6.078000E-07,2.921800E-06,& + & 6.726100E-06,1.983100E-05,7.991300E-05,4.482400E-04,3.306500E-03,& + & 2.946300E-02,9.704137E-01,2.222555E+01,3.722163E+02,1.592918E+03/ + + + data ka_mn2o(:,:, 1) / & + & 5.410780E-02,9.466690E-02,1.500820E-01,6.112480E-01,2.534600E+00,& + & 5.786950E+00,1.234170E+01,2.283840E+01,2.014079E+01,6.318874E+00,& + & 1.325950E+01,2.234971E+01,1.196020E-01,5.119010E-01,3.095510E+00,& + & 5.072530E+00,7.456500E+00,1.228930E+01,9.309570E+00,4.486080E+00,& + & 2.375774E+00,1.152244E-01,4.873717E-05,4.985119E-10,1.496140E-01,& + & 8.329460E-01,4.426610E+00,7.458290E+00,1.063110E+01,7.931180E+00,& + & 4.158670E+00,3.699280E+00,2.210592E+00,1.149944E-01,4.856850E-05,& + & 4.905467E-10,1.800290E-01,1.040320E+00,5.778640E+00,9.588930E+00,& + & 1.039240E+01,4.088990E+00,3.556340E+00,3.178560E+00,2.132410E+00,& + & 1.143589E-01,4.840380E-05,4.825824E-10,2.082790E-01,1.226850E+00,& + & 7.172940E+00,1.163440E+01,7.822770E+00,2.613580E+00,3.094680E+00,& + & 3.165490E+00,2.065575E+00,1.136770E-01,4.826092E-05,4.681371E-10,& + & 2.173360E-01,1.537810E+00,9.050820E+00,1.124600E+01,6.052250E+00,& + & 2.407200E+00,2.754730E+00,3.166120E+00,2.003902E+00,1.125782E-01,& + & 4.740591E-05,4.454618E-10,2.239030E-01,1.904760E+00,1.187490E+01,& + & 8.892650E+00,5.241350E+00,1.996070E+00,2.685870E+00,3.196440E+00,& + & 1.896540E+00,1.101344E-01,4.598920E-05,4.003777E-10,2.234000E-01,& + & 2.382110E+00,1.414280E+01,6.839330E+00,4.402400E+00,1.941500E+00,& + & 2.547780E+00,3.357590E+00,1.534507E+00,1.002951E-01,4.199538E-05,& + & 2.440281E-10,1.892790E-01,1.264640E+00,7.349930E+00,1.106370E+01,& + & 8.565540E+00,2.472590E+00,2.781370E+00,3.173780E+00,2.036778E+00,& + & 1.136770E-01,4.828273E-05,4.681371E-10 / + data ka_mn2o(:,:, 2) / 5.590510E-02,9.771370E-02,& + & 1.590950E-01,6.372250E-01,2.560500E+00,5.789390E+00,1.226180E+01,& + & 2.274500E+01,2.012251E+01,6.364416E+00,1.352143E+01,2.262810E+01,& + & 1.229630E-01,5.249500E-01,3.097800E+00,5.052990E+00,7.442830E+00,& + & 1.225560E+01,9.327750E+00,4.522590E+00,2.398042E+00,1.272307E-01,& + & 6.454683E-05,6.624182E-10,1.534270E-01,8.457800E-01,4.408580E+00,& + & 7.422660E+00,1.061100E+01,7.945900E+00,4.192540E+00,3.725840E+00,& + & 2.232946E+00,1.269783E-01,6.432325E-05,6.518362E-10,1.842020E-01,& + & 1.054750E+00,5.740850E+00,9.547960E+00,1.038950E+01,4.114350E+00,& + & 3.593820E+00,3.195960E+00,2.154748E+00,1.262814E-01,6.410638E-05,& + & 6.412534E-10,2.130290E-01,1.242670E+00,7.108900E+00,1.160120E+01,& + & 7.838720E+00,2.640290E+00,3.126550E+00,3.182880E+00,2.087805E+00,& + & 1.255319E-01,6.391640E-05,6.220443E-10,2.225710E-01,1.552060E+00,& + & 8.961320E+00,1.124020E+01,6.068830E+00,2.434300E+00,2.783560E+00,& + & 3.183550E+00,2.026096E+00,1.243260E-01,6.278564E-05,5.919289E-10,& + & 2.293490E-01,1.918580E+00,1.176480E+01,8.914190E+00,5.256960E+00,& + & 2.017250E+00,2.714310E+00,3.214190E+00,1.918581E+00,1.216428E-01,& + & 6.091228E-05,5.320217E-10,2.288430E-01,2.398190E+00,1.403230E+01,& + & 6.866880E+00,4.409150E+00,1.963980E+00,2.574610E+00,3.377750E+00,& + & 1.554672E+00,1.108353E-01,5.562874E-05,3.242542E-10,1.944230E-01,& + & 1.281070E+00,7.293350E+00,1.102320E+01,8.591850E+00,2.489500E+00,& + & 2.809570E+00,3.191350E+00,2.058882E+00,1.255319E-01,6.394328E-05,& + & 6.220443E-10 / + data ka_mn2o(:,:, 3) / & + & 5.776200E-02,1.008580E-01,1.686500E-01,6.643060E-01,& + & 2.586670E+00,5.791820E+00,1.218230E+01,2.265190E+01,2.010432E+01,& + & 6.410296E+00,1.378850E+01,2.291001E+01,1.264170E-01,5.383310E-01,& + & 3.100080E+00,5.033530E+00,7.429190E+00,1.222210E+01,9.345970E+00,& + & 4.559390E+00,2.420620E+00,1.404895E-01,8.548413E-05,8.802127E-10,& + & 1.573370E-01,8.588130E-01,4.390620E+00,7.387190E+00,1.059090E+01,& + & 7.960650E+00,4.226680E+00,3.752590E+00,2.255618E+00,1.402132E-01,& + & 8.518907E-05,8.661557E-10,1.884720E-01,1.069370E+00,5.703310E+00,& + & 9.507160E+00,1.038670E+01,4.139880E+00,3.631690E+00,3.213450E+00,& + & 2.177410E+00,1.394481E-01,8.490257E-05,8.520952E-10,2.178880E-01,& + & 1.258700E+00,7.045420E+00,1.156810E+01,7.854710E+00,2.667280E+00,& + & 3.158760E+00,3.200370E+00,2.110373E+00,1.386250E-01,8.464966E-05,& + & 8.265515E-10,2.279310E-01,1.566450E+00,8.872710E+00,1.123440E+01,& + & 6.085450E+00,2.461690E+00,2.812680E+00,3.201080E+00,2.048621E+00,& + & 1.373019E-01,8.315420E-05,7.865528E-10,2.349260E-01,1.932510E+00,& + & 1.165560E+01,8.935780E+00,5.272610E+00,2.038650E+00,2.743060E+00,& + & 3.232030E+00,1.940961E+00,1.343549E-01,8.067764E-05,7.069500E-10,& + & 2.344180E-01,2.414380E+00,1.392270E+01,6.894530E+00,4.415910E+00,& + & 1.986710E+00,2.601730E+00,3.398040E+00,1.575175E+00,1.224847E-01,& + & 7.368783E-05,4.308551E-10,1.997070E-01,1.297720E+00,7.237200E+00,& + & 1.098290E+01,8.618240E+00,2.506530E+00,2.838050E+00,3.209010E+00,& + & 2.081316E+00,1.386250E-01,8.468387E-05,8.265515E-10 / + data ka_mn2o(:,:, 4) / 5.968050E-02,& + & 1.041040E-01,1.787790E-01,6.925380E-01,2.613100E+00,5.794260E+00,& + & 1.210340E+01,2.255930E+01,2.008634E+01,6.456531E+00,1.406090E+01,& + & 2.319547E+01,1.299690E-01,5.520530E-01,3.102370E+00,5.014140E+00,& + & 7.415570E+00,1.218860E+01,9.364210E+00,4.596490E+00,2.443518E+00,& + & 1.551322E-01,1.132140E-04,1.169628E-09,1.613460E-01,8.720460E-01,& + & 4.372740E+00,7.351900E+00,1.057090E+01,7.975420E+00,4.261100E+00,& + & 3.779530E+00,2.278625E+00,1.548291E-01,1.128230E-04,1.150947E-09,& + & 1.928410E-01,1.084190E+00,5.666020E+00,9.466540E+00,1.038380E+01,& + & 4.165560E+00,3.669960E+00,3.231040E+00,2.200414E+00,1.539898E-01,& + & 1.124449E-04,1.132257E-09,2.228580E-01,1.274930E+00,6.982510E+00,& + & 1.153510E+01,7.870730E+00,2.694540E+00,3.191290E+00,3.217950E+00,& + & 2.133281E+00,1.530851E-01,1.121095E-04,1.098296E-09,2.334210E-01,& + & 1.580970E+00,8.784980E+00,1.122860E+01,6.102120E+00,2.489400E+00,& + & 2.842110E+00,3.218700E+00,2.071493E+00,1.516337E-01,1.101315E-04,& + & 1.045171E-09,2.406400E-01,1.946530E+00,1.154750E+01,8.957430E+00,& + & 5.288310E+00,2.060280E+00,2.772110E+00,3.249960E+00,1.963697E+00,& + & 1.483979E-01,1.068571E-04,9.393950E-10,2.401300E-01,2.430680E+00,& + & 1.381390E+01,6.922300E+00,4.422680E+00,2.009710E+00,2.629140E+00,& + & 3.418450E+00,1.596053E+00,1.353601E-01,9.761002E-05,5.725025E-10,& + & 2.051350E-01,1.314580E+00,7.181490E+00,1.094270E+01,8.644700E+00,& + & 2.523670E+00,2.866820E+00,3.226770E+00,2.104089E+00,1.530851E-01,& + & 1.121517E-04,1.098296E-09 / + data ka_mn2o(:,:, 5) / 6.166280E-02,1.074550E-01,1.895160E-01,& + & 7.219700E-01,2.639800E+00,5.796700E+00,1.202500E+01,2.246700E+01,& + & 2.006846E+01,6.503118E+00,1.433869E+01,2.348448E+01,1.336210E-01,& + & 5.661250E-01,3.104660E+00,4.994830E+00,7.401980E+00,1.215520E+01,& + & 9.382500E+00,4.633890E+00,2.466735E+00,1.713035E-01,1.499381E-04,& + & 1.554186E-09,1.654570E-01,8.854820E-01,4.354930E+00,7.316770E+00,& + & 1.055090E+01,7.990220E+00,4.295810E+00,3.806660E+00,2.301978E+00,& + & 1.709709E-01,1.494207E-04,1.529368E-09,1.973110E-01,1.099220E+00,& + & 5.628970E+00,9.426090E+00,1.038090E+01,4.191400E+00,3.708630E+00,& + & 3.248720E+00,2.223761E+00,1.700500E-01,1.489222E-04,1.504542E-09,& + & 2.279410E-01,1.291370E+00,6.920170E+00,1.150220E+01,7.886780E+00,& + & 2.722090E+00,3.224160E+00,3.235630E+00,2.156536E+00,1.690566E-01,& + & 1.484763E-04,1.459377E-09,2.390430E-01,1.595630E+00,8.698110E+00,& + & 1.122280E+01,6.118830E+00,2.517410E+00,2.871850E+00,3.236430E+00,& + & 2.094722E+00,1.674647E-01,1.458604E-04,1.388816E-09,2.464930E-01,& + & 1.960650E+00,1.144030E+01,8.979130E+00,5.304050E+00,2.082140E+00,& + & 2.801460E+00,3.268000E+00,1.986809E+00,1.639116E-01,1.415310E-04,& + & 1.248263E-09,2.459800E-01,2.447090E+00,1.370600E+01,6.950180E+00,& + & 4.429460E+00,2.032980E+00,2.656830E+00,3.438990E+00,1.617299E+00,& + & 1.495920E-01,1.292986E-04,7.607172E-10,2.107100E-01,1.331660E+00,& + & 7.126200E+00,1.090260E+01,8.671250E+00,2.540930E+00,2.895890E+00,& + & 3.244620E+00,2.127219E+00,1.690566E-01,1.485288E-04,1.459377E-09/ + data ka_mn2o(:,:, 6) / & + & 6.371100E-02,1.109130E-01,2.008980E-01,7.526530E-01,2.666780E+00,& + & 5.799140E+00,1.194710E+01,2.237510E+01,2.005075E+01,6.550053E+00,& + & 1.462201E+01,2.377712E+01,1.373750E-01,5.805560E-01,3.106950E+00,& + & 4.975590E+00,7.388410E+00,1.212200E+01,9.400820E+00,4.671600E+00,& + & 2.490301E+00,1.891638E-01,1.985748E-04,2.065191E-09,1.696740E-01,& + & 8.991260E-01,4.337190E+00,7.281810E+00,1.053100E+01,8.005050E+00,& + & 4.330790E+00,3.833990E+00,2.325686E+00,1.887990E-01,1.978906E-04,& + & 2.032212E-09,2.018840E-01,1.114460E+00,5.592160E+00,9.385810E+00,& + & 1.037800E+01,4.217400E+00,3.747710E+00,3.266500E+00,2.247471E+00,& + & 1.877893E-01,1.972326E-04,1.999232E-09,2.331400E-01,1.308030E+00,& + & 6.858380E+00,1.146940E+01,7.902870E+00,2.749910E+00,3.257370E+00,& + & 3.253400E+00,2.180159E+00,1.866976E-01,1.966401E-04,1.939164E-09,& + & 2.448010E-01,1.610420E+00,8.612100E+00,1.121700E+01,6.135590E+00,& + & 2.545750E+00,2.901900E+00,3.254250E+00,2.118318E+00,1.849514E-01,& + & 1.931806E-04,1.845451E-09,2.524880E-01,1.974880E+00,1.133420E+01,& + & 9.000880E+00,5.319840E+00,2.104230E+00,2.831130E+00,3.286140E+00,& + & 2.010288E+00,1.810500E-01,1.874565E-04,1.658700E-09,2.519730E-01,& + & 2.463610E+00,1.359890E+01,6.978170E+00,4.436250E+00,2.056510E+00,& + & 2.684820E+00,3.459640E+00,1.638952E+00,1.653240E-01,1.712740E-04,& + & 1.010806E-09,2.164370E-01,1.348960E+00,7.071340E+00,1.086270E+01,& + & 8.697880E+00,2.558310E+00,2.925250E+00,3.262580E+00,2.150708E+00,& + & 1.866976E-01,1.967054E-04,1.939164E-09 / + data ka_mn2o(:,:, 7) / 6.582720E-02,1.144830E-01,& + & 2.129630E-01,7.846390E-01,2.694030E+00,5.801580E+00,1.186970E+01,& + & 2.228350E+01,2.003316E+01,6.597351E+00,1.491093E+01,2.407340E+01,& + & 1.412350E-01,5.953540E-01,3.109250E+00,4.956420E+00,7.374870E+00,& + & 1.208880E+01,9.419180E+00,4.709610E+00,2.514227E+00,2.088910E-01,& + & 2.629890E-04,2.744214E-09,1.739970E-01,9.129800E-01,4.319530E+00,& + & 7.247020E+00,1.051110E+01,8.019900E+00,4.366060E+00,3.861520E+00,& + & 2.349762E+00,2.084911E-01,2.620831E-04,2.700390E-09,2.065640E-01,& + & 1.129910E+00,5.555590E+00,9.345710E+00,1.037510E+01,4.243570E+00,& + & 3.787200E+00,3.284370E+00,2.271562E+00,2.073832E-01,2.612156E-04,& + & 2.656575E-09,2.384580E-01,1.324900E+00,6.797140E+00,1.143660E+01,& + & 7.918990E+00,2.778020E+00,3.290920E+00,3.271280E+00,2.204160E+00,& + & 2.061844E-01,2.604276E-04,2.576696E-09,2.506970E-01,1.625350E+00,& + & 8.526940E+00,1.121120E+01,6.152400E+00,2.574400E+00,2.932270E+00,& + & 3.272170E+00,2.142302E+00,2.042682E-01,2.558526E-04,2.452230E-09,& + & 2.586280E-01,1.989210E+00,1.122900E+01,9.022680E+00,5.335680E+00,& + & 2.126550E+00,2.861110E+00,3.304380E+00,2.034164E+00,1.999858E-01,& + & 2.482849E-04,2.204078E-09,2.581120E-01,2.480240E+00,1.349270E+01,& + & 7.006270E+00,4.443050E+00,2.080320E+00,2.713100E+00,3.480420E+00,& + & 1.661006E+00,1.827145E-01,2.268762E-04,1.343116E-09,2.223190E-01,& + & 1.366490E+00,7.016900E+00,1.082300E+01,8.724600E+00,2.575810E+00,& + & 2.954910E+00,3.280630E+00,2.174574E+00,2.061844E-01,2.605076E-04,& + & 2.576696E-09 / + data ka_mn2o(:,:, 8) / & + & 6.801370E-02,1.181670E-01,2.257530E-01,8.179850E-01,& + & 2.721560E+00,5.804030E+00,1.179280E+01,2.219240E+01,2.001575E+01,& + & 6.645012E+00,1.520560E+01,2.437342E+01,1.452030E-01,6.105300E-01,& + & 3.111540E+00,4.937330E+00,7.361350E+00,1.205570E+01,9.437570E+00,& + & 4.747930E+00,2.538515E+00,2.306809E-01,3.482973E-04,3.646491E-09,& + & 1.784310E-01,9.270480E-01,4.301930E+00,7.212400E+00,1.049120E+01,& + & 8.034780E+00,4.401620E+00,3.889240E+00,2.374215E+00,2.302426E-01,& + & 3.470987E-04,3.588265E-09,2.113520E-01,1.145570E+00,5.519260E+00,& + & 9.305780E+00,1.037220E+01,4.269890E+00,3.827110E+00,3.302350E+00,& + & 2.296029E+00,2.290270E-01,3.459545E-04,3.530038E-09,2.438970E-01,& + & 1.341990E+00,6.736450E+00,1.140400E+01,7.935140E+00,2.806410E+00,& + & 3.324820E+00,3.289250E+00,2.228542E+00,2.277104E-01,3.449075E-04,& + & 3.423824E-09,2.567350E-01,1.640420E+00,8.442620E+00,1.120550E+01,& + & 6.169250E+00,2.603370E+00,2.962950E+00,3.290180E+00,2.166684E+00,& + & 2.256088E-01,3.388566E-04,3.258515E-09,2.649180E-01,2.003650E+00,& + & 1.112480E+01,9.044540E+00,5.351570E+00,2.149120E+00,2.891410E+00,& + & 3.322720E+00,2.058458E+00,2.209072E-01,3.288514E-04,2.928774E-09,& + & 2.644010E-01,2.496990E+00,1.338730E+01,7.034490E+00,4.449860E+00,& + & 2.104400E+00,2.741680E+00,3.501330E+00,1.683485E+00,2.019412E-01,& + & 3.005293E-04,1.784682E-09,2.283610E-01,1.384240E+00,6.962880E+00,& + & 1.078330E+01,8.751390E+00,2.593430E+00,2.984860E+00,3.298790E+00,& + & 2.198831E+00,2.277103E-01,3.450046E-04,3.423824E-09 / + data ka_mn2o(:,:, 9) / 7.027280E-02,& + & 1.219710E-01,2.393110E-01,8.527490E-01,2.749370E+00,5.806470E+00,& + & 1.171640E+01,2.210160E+01,1.999845E+01,6.693034E+00,1.550613E+01,& + & 2.467717E+01,1.492830E-01,6.260930E-01,3.113840E+00,4.918310E+00,& + & 7.347860E+00,1.202270E+01,9.456000E+00,4.786560E+00,2.563178E+00,& + & 2.547520E-01,4.612780E-04,4.845426E-09,1.829780E-01,9.413320E-01,& + & 4.284410E+00,7.177940E+00,1.047130E+01,8.049700E+00,4.437470E+00,& + & 3.917170E+00,2.399069E+00,2.542708E-01,4.596921E-04,4.768071E-09,& + & 2.162520E-01,1.161450E+00,5.483170E+00,9.266020E+00,1.036930E+01,& + & 4.296380E+00,3.867440E+00,3.320420E+00,2.320911E+00,2.529381E-01,& + & 4.581832E-04,4.690707E-09,2.494600E-01,1.359300E+00,6.676300E+00,& + & 1.137150E+01,7.951320E+00,2.835100E+00,3.359070E+00,3.307320E+00,& + & 2.253335E+00,2.514920E-01,4.567916E-04,4.549462E-09,2.629180E-01,& + & 1.655620E+00,8.359140E+00,1.119970E+01,6.186150E+00,2.632670E+00,& + & 2.993950E+00,3.308300E+00,2.191478E+00,2.491873E-01,4.487889E-04,& + & 4.329915E-09,2.713610E-01,2.018190E+00,1.102160E+01,9.066450E+00,& + & 5.367500E+00,2.171920E+00,2.922030E+00,3.341160E+00,2.083165E+00,& + & 2.440261E-01,4.355607E-04,3.891759E-09,2.708430E-01,2.513840E+00,& + & 1.328270E+01,7.062820E+00,4.456680E+00,2.128760E+00,2.770560E+00,& + & 3.522360E+00,1.706412E+00,2.231988E-01,3.980929E-04,2.371412E-09,& + & 2.345680E-01,1.402230E+00,6.909280E+00,1.074390E+01,8.778270E+00,& + & 2.611170E+00,3.015120E+00,3.317040E+00,2.223489E+00,2.514920E-01,& + & 4.569095E-04,4.549462E-09 / + data ka_mn2o(:,:,10) / 7.260690E-02,1.258960E-01,2.536830E-01,& + & 8.889890E-01,2.777460E+00,5.808920E+00,1.164050E+01,2.201120E+01,& + & 1.998135E+01,6.741419E+00,1.581263E+01,2.498476E+01,1.534770E-01,& + & 6.420520E-01,3.116140E+00,4.899370E+00,7.334390E+00,1.198980E+01,& + & 9.474460E+00,4.825510E+00,2.588248E+00,2.813443E-01,6.109101E-04,& + & 6.438561E-09,1.876410E-01,9.558370E-01,4.266960E+00,7.143640E+00,& + & 1.045160E+01,8.064630E+00,4.473600E+00,3.945290E+00,2.424336E+00,& + & 2.808176E-01,6.088086E-04,6.335775E-09,2.212640E-01,1.177550E+00,& + & 5.447310E+00,9.226420E+00,1.036650E+01,4.323040E+00,3.908200E+00,& + & 3.338590E+00,2.346205E+00,2.793560E-01,6.068183E-04,6.232988E-09,& + & 2.551500E-01,1.376830E+00,6.616690E+00,1.133900E+01,7.967540E+00,& + & 2.864080E+00,3.393660E+00,3.325490E+00,2.278553E+00,2.777670E-01,& + & 6.049692E-04,6.045167E-09,2.692510E-01,1.670970E+00,8.276480E+00,& + & 1.119390E+01,6.203090E+00,2.662300E+00,3.025280E+00,3.326520E+00,& + & 2.216688E+00,2.752400E-01,5.943855E-04,5.753568E-09,2.779610E-01,& + & 2.032830E+00,1.091940E+01,9.088410E+00,5.383480E+00,2.194960E+00,& + & 2.952980E+00,3.359700E+00,2.108317E+00,2.695745E-01,5.768963E-04,& + & 5.171362E-09,2.774420E-01,2.530820E+00,1.317900E+01,7.091260E+00,& + & 4.463510E+00,2.153410E+00,2.799740E+00,3.543510E+00,1.729804E+00,& + & 2.467049E-01,5.273298E-04,3.151021E-09,2.409430E-01,1.420440E+00,& + & 6.856090E+00,1.070460E+01,8.805230E+00,2.629030E+00,3.045690E+00,& + & 3.335400E+00,2.248572E+00,2.777671E-01,6.051103E-04,6.045167E-09/ + data ka_mn2o(:,:,11) / & + & 7.501850E-02,1.299480E-01,2.689190E-01,9.267700E-01,2.805850E+00,& + & 5.811360E+00,1.156510E+01,2.192110E+01,1.996435E+01,6.790177E+00,& + & 1.612518E+01,2.529618E+01,1.577890E-01,6.584180E-01,3.118440E+00,& + & 4.880500E+00,7.320950E+00,1.195690E+01,9.492960E+00,4.864780E+00,& + & 2.613721E+00,3.107264E-01,8.090732E-04,8.555518E-09,1.924220E-01,& + & 9.705650E-01,4.249580E+00,7.109510E+00,1.043180E+01,8.079600E+00,& + & 4.510040E+00,3.973610E+00,2.450031E+00,3.101492E-01,8.062936E-04,& + & 8.418945E-09,2.263930E-01,1.193870E+00,5.411690E+00,9.187000E+00,& + & 1.036360E+01,4.349850E+00,3.949380E+00,3.356860E+00,2.371932E+00,& + & 3.085460E-01,8.036729E-04,8.282373E-09,2.609690E-01,1.394590E+00,& + & 6.557610E+00,1.130670E+01,7.983790E+00,2.893350E+00,3.428620E+00,& + & 3.343760E+00,2.304200E+00,3.068014E-01,8.012171E-04,8.032608E-09,& + & 2.757350E-01,1.686460E+00,8.194640E+00,1.118820E+01,6.220080E+00,& + & 2.692260E+00,3.056940E+00,3.344830E+00,2.242356E+00,3.040299E-01,& + & 7.872155E-04,7.645324E-09,2.847210E-01,2.047580E+00,1.081800E+01,& + & 9.110430E+00,5.399510E+00,2.218250E+00,2.984250E+00,3.378350E+00,& + & 2.133929E+00,2.978124E-01,7.640933E-04,6.871702E-09,2.842020E-01,& + & 2.547900E+00,1.307600E+01,7.119820E+00,4.470350E+00,2.178340E+00,& + & 2.829230E+00,3.564800E+00,1.753680E+00,2.727010E-01,6.985203E-04,& + & 4.186952E-09,2.474920E-01,1.438900E+00,6.803310E+00,1.066540E+01,& + & 8.832270E+00,2.647010E+00,3.076570E+00,3.353860E+00,2.274094E+00,& + & 3.068014E-01,8.013821E-04,8.032608E-09 / + data ka_mn2o(:,:,12) / 7.751030E-02,1.341300E-01,& + & 2.850690E-01,9.661570E-01,2.834520E+00,5.813810E+00,1.149010E+01,& + & 2.183140E+01,1.994753E+01,6.839301E+00,1.644395E+01,2.561153E+01,& + & 1.622230E-01,6.752020E-01,3.120740E+00,4.861700E+00,7.307530E+00,& + & 1.192420E+01,9.511500E+00,4.904360E+00,2.639631E+00,3.431948E-01,& + & 1.071521E-03,1.136850E-08,1.973250E-01,9.855200E-01,4.232270E+00,& + & 7.075540E+00,1.041210E+01,8.094590E+00,4.546770E+00,4.002140E+00,& + & 2.476170E+00,3.425617E-01,1.067850E-03,1.118704E-08,2.316410E-01,& + & 1.210420E+00,5.376310E+00,9.147750E+00,1.036070E+01,4.376840E+00,& + & 3.991000E+00,3.375230E+00,2.398118E+00,3.408046E-01,1.064386E-03,& + & 1.100557E-08,2.669220E-01,1.412570E+00,6.499050E+00,1.127440E+01,& + & 8.000080E+00,2.922930E+00,3.463930E+00,3.362130E+00,2.330312E+00,& + & 3.388882E-01,1.061118E-03,1.067350E-08,2.823770E-01,1.702100E+00,& + & 8.113610E+00,1.118240E+01,6.237120E+00,2.722560E+00,3.088920E+00,& + & 3.363250E+00,2.268478E+00,3.358494E-01,1.042608E-03,1.015909E-08,& + & 2.916460E-01,2.062440E+00,1.071770E+01,9.132500E+00,5.415580E+00,& + & 2.241790E+00,3.015850E+00,3.397100E+00,2.160016E+00,3.290260E-01,& + & 1.012039E-03,9.131132E-09,2.911260E-01,2.565100E+00,1.297380E+01,& + & 7.148500E+00,4.477200E+00,2.203550E+00,2.859030E+00,3.586210E+00,& + & 1.778057E+00,3.014552E-01,9.252921E-04,5.563442E-09,2.542180E-01,& + & 1.457590E+00,6.750940E+00,1.062630E+01,8.859390E+00,2.665110E+00,& + & 3.107760E+00,3.372420E+00,2.300071E+00,3.388883E-01,1.061313E-03,& + & 1.067350E-08 / + data ka_mn2o(:,:,13) / & + & 8.008480E-02,1.384470E-01,3.021900E-01,1.007220E+00,& + & 2.863480E+00,5.816260E+00,1.141570E+01,2.174210E+01,1.993093E+01,& + & 6.888806E+00,1.676909E+01,2.593080E+01,1.667800E-01,6.924130E-01,& + & 3.123050E+00,4.842970E+00,7.294130E+00,1.189150E+01,9.530070E+00,& + & 4.944270E+00,2.665986E+00,3.790788E-01,1.419104E-03,1.510634E-08,& + & 2.023540E-01,1.000700E+00,4.215030E+00,7.041730E+00,1.039240E+01,& + & 8.109610E+00,4.583800E+00,4.030880E+00,2.502777E+00,3.783860E-01,& + & 1.414241E-03,1.486526E-08,2.370100E-01,1.227200E+00,5.341150E+00,& + & 9.108660E+00,1.035780E+01,4.403990E+00,4.033050E+00,3.393700E+00,& + & 2.424770E+00,3.764583E-01,1.409672E-03,1.462419E-08,2.730100E-01,& + & 1.430790E+00,6.441020E+00,1.124220E+01,8.016390E+00,2.952800E+00,& + & 3.499610E+00,3.380600E+00,2.356884E+00,3.743541E-01,1.405334E-03,& + & 1.418253E-08,2.891780E-01,1.717880E+00,8.033380E+00,1.117660E+01,& + & 6.254200E+00,2.753200E+00,3.121250E+00,3.381770E+00,2.295090E+00,& + & 3.710232E-01,1.380850E-03,1.349936E-08,2.987390E-01,2.077410E+00,& + & 1.061820E+01,9.154620E+00,5.431710E+00,2.265570E+00,3.047790E+00,& + & 3.415960E+00,2.186595E+00,3.635355E-01,1.340433E-03,1.213346E-08,& + & 2.982190E-01,2.582420E+00,1.287250E+01,7.177290E+00,4.484070E+00,& + & 2.229060E+00,2.889150E+00,3.607750E+00,1.802967E+00,3.332658E-01,& + & 1.225677E-03,7.392465E-09,2.611270E-01,1.476530E+00,6.698970E+00,& + & 1.058750E+01,8.886600E+00,2.683340E+00,3.139270E+00,3.391080E+00,& + & 2.326518E+00,3.743542E-01,1.405560E-03,1.418253E-08 / + data ka_mn2o(:,:,14) / 8.274490E-02,& + & 1.429030E-01,3.203390E-01,1.050020E+00,2.892750E+00,5.818700E+00,& + & 1.134170E+01,2.165320E+01,1.991434E+01,6.938689E+00,1.710061E+01,& + & 2.625411E+01,1.714660E-01,7.100620E-01,3.125350E+00,4.824320E+00,& + & 7.280760E+00,1.185900E+01,9.548680E+00,4.984500E+00,2.692812E+00,& + & 4.187460E-01,1.879434E-03,2.007324E-08,2.075100E-01,1.016120E+00,& + & 4.197870E+00,7.008090E+00,1.037270E+01,8.124660E+00,4.621130E+00,& + & 4.059820E+00,2.529872E+00,4.179870E-01,1.872995E-03,1.975291E-08,& + & 2.425040E-01,1.244210E+00,5.306220E+00,9.069740E+00,1.035490E+01,& + & 4.431310E+00,4.075550E+00,3.412270E+00,2.451906E+00,4.158738E-01,& + & 1.866978E-03,1.943258E-08,2.792370E-01,1.449250E+00,6.383510E+00,& + & 1.121020E+01,8.032740E+00,2.982990E+00,3.535660E+00,3.399170E+00,& + & 2.383955E+00,4.135629E-01,1.861205E-03,1.884523E-08,2.961420E-01,& + & 1.733800E+00,7.953940E+00,1.117090E+01,6.271330E+00,2.784190E+00,& + & 3.153910E+00,3.400390E+00,2.322201E+00,4.099118E-01,1.828828E-03,& + & 1.793790E-08,3.060050E-01,2.092480E+00,1.051970E+01,9.176800E+00,& + & 5.447880E+00,2.289610E+00,3.080060E+00,3.434920E+00,2.213695E+00,& + & 4.016972E-01,1.775393E-03,1.612290E-08,3.054850E-01,2.599850E+00,& + & 1.277190E+01,7.206190E+00,4.490940E+00,2.254870E+00,2.919580E+00,& + & 3.629420E+00,1.828440E+00,3.684653E-01,1.623580E-03,9.822804E-09,& + & 2.682240E-01,1.495720E+00,6.647390E+00,1.054870E+01,8.913890E+00,& + & 2.701690E+00,3.171100E+00,3.409840E+00,2.353462E+00,4.135630E-01,& + & 1.861461E-03,1.884523E-08 / + data ka_mn2o(:,:,15) / 8.549330E-02,1.475020E-01,3.395770E-01,& + & 1.094650E+00,2.922310E+00,5.821150E+00,1.126830E+01,2.156460E+01,& + & 1.989804E+01,6.988951E+00,1.743880E+01,2.658143E+01,1.762840E-01,& + & 7.281620E-01,3.127660E+00,4.805730E+00,7.267420E+00,1.182650E+01,& + & 9.567320E+00,5.025060E+00,2.720128E+00,4.626048E-01,2.489086E-03,& + & 2.667314E-08,2.127980E-01,1.031780E+00,4.180770E+00,6.974610E+00,& + & 1.035310E+01,8.139740E+00,4.658760E+00,4.088960E+00,2.557463E+00,& + & 4.617732E-01,2.480564E-03,2.624753E-08,2.481260E-01,1.261460E+00,& + & 5.271520E+00,9.030990E+00,1.035210E+01,4.458800E+00,4.118500E+00,& + & 3.430950E+00,2.479563E+00,4.594567E-01,2.472622E-03,2.582192E-08,& + & 2.856060E-01,1.467940E+00,6.326510E+00,1.117820E+01,8.049130E+00,& + & 3.013480E+00,3.572080E+00,3.417850E+00,2.411550E+00,4.569191E-01,& + & 2.464962E-03,2.504092E-08,3.032750E-01,1.749870E+00,7.875290E+00,& + & 1.116510E+01,6.288510E+00,2.815520E+00,3.186910E+00,3.419110E+00,& + & 2.349829E+00,4.529180E-01,2.422138E-03,2.383580E-08,3.134470E-01,& + & 2.107670E+00,1.042210E+01,9.199030E+00,5.464100E+00,2.313900E+00,& + & 3.112680E+00,3.453980E+00,2.241335E+00,4.439069E-01,2.351488E-03,& + & 2.142406E-08,3.129280E-01,2.617410E+00,1.267220E+01,7.235210E+00,& + & 4.497820E+00,2.280970E+00,2.950330E+00,3.651220E+00,1.854492E+00,& + & 4.074264E-01,2.150658E-03,1.305210E-08,2.755140E-01,1.515150E+00,& + & 6.596220E+00,1.051010E+01,8.941270E+00,2.720170E+00,3.203240E+00,& + & 3.428710E+00,2.380923E+00,4.569193E-01,2.465236E-03,2.504092E-08/ + data ka_mn2o(:,:,16) / & + & 8.833300E-02,1.522490E-01,3.599710E-01,1.141170E+00,2.952170E+00,& + & 5.823610E+00,1.119520E+01,2.147640E+01,1.988185E+01,7.039601E+00,& + & 1.778364E+01,2.691287E+01,1.812370E-01,7.467230E-01,3.129970E+00,& + & 4.787220E+00,7.254100E+00,1.179410E+01,9.586010E+00,5.065950E+00,& + & 2.747956E+00,5.111111E-01,3.296491E-03,3.544310E-08,2.182210E-01,& + & 1.047680E+00,4.163740E+00,6.941280E+00,1.033360E+01,8.154850E+00,& + & 4.696700E+00,4.118320E+00,2.585581E+00,5.102004E-01,3.285226E-03,& + & 3.487757E-08,2.538770E-01,1.278950E+00,5.237050E+00,8.992400E+00,& + & 1.034920E+01,4.486460E+00,4.161900E+00,3.449720E+00,2.507753E+00,& + & 5.076608E-01,3.274750E-03,3.431205E-08,2.921200E-01,1.486870E+00,& + & 6.270030E+00,1.114630E+01,8.065550E+00,3.044280E+00,3.608870E+00,& + & 3.436620E+00,2.439673E+00,5.048749E-01,3.264566E-03,3.327349E-08,& + & 3.105790E-01,1.766100E+00,7.797420E+00,1.115940E+01,6.305740E+00,& + & 2.847210E+00,3.220250E+00,3.437940E+00,2.378005E+00,5.004906E-01,& + & 3.207937E-03,3.167291E-08,3.210700E-01,2.122960E+00,1.032540E+01,& + & 9.221310E+00,5.480370E+00,2.338450E+00,3.145640E+00,3.473150E+00,& + & 2.269536E+00,4.906077E-01,3.114531E-03,2.846834E-08,3.205520E-01,& + & 2.635080E+00,1.257320E+01,7.264350E+00,4.504720E+00,2.307380E+00,& + & 2.981410E+00,3.673150E+00,1.881167E+00,4.505636E-01,2.848849E-03,& + & 1.734310E-08,2.830020E-01,1.534830E+00,6.545440E+00,1.047160E+01,& + & 8.968730E+00,2.738780E+00,3.235720E+00,3.447690E+00,2.408920E+00,& + & 5.048753E-01,3.264853E-03,3.327349E-08 / + data ka_mn2o(:,:,17) / 9.126700E-02,1.571490E-01,& + & 3.815900E-01,1.189670E+00,2.982340E+00,5.826060E+00,1.112270E+01,& + & 2.138850E+01,1.986576E+01,7.090640E+00,1.813535E+01,2.724845E+01,& + & 1.863290E-01,7.657580E-01,3.132280E+00,4.768780E+00,7.240800E+00,& + & 1.176180E+01,9.604720E+00,5.107170E+00,2.776307E+00,5.647724E-01,& + & 4.365814E-03,4.709651E-08,2.237810E-01,1.063820E+00,4.146780E+00,& + & 6.908120E+00,1.031400E+01,8.169980E+00,4.734950E+00,4.147890E+00,& + & 2.614255E+00,5.637803E-01,4.350902E-03,4.634514E-08,2.597620E-01,& + & 1.296680E+00,5.202810E+00,8.953980E+00,1.034630E+01,4.514300E+00,& + & 4.205760E+00,3.468600E+00,2.536496E+00,5.609939E-01,4.337089E-03,& + & 4.559368E-08,2.987830E-01,1.506050E+00,6.214040E+00,1.111450E+01,& + & 8.082000E+00,3.075400E+00,3.646040E+00,3.455510E+00,2.468355E+00,& + & 5.579349E-01,4.323552E-03,4.421270E-08,3.180600E-01,1.782470E+00,& + & 7.720320E+00,1.115360E+01,6.323010E+00,2.879250E+00,3.253950E+00,& + & 3.456870E+00,2.406758E+00,5.531322E-01,4.248657E-03,4.208692E-08,& + & 3.288790E-01,2.138370E+00,1.022960E+01,9.243650E+00,5.496680E+00,& + & 2.363260E+00,3.178960E+00,3.492430E+00,2.298330E+00,5.422949E-01,& + & 4.125171E-03,3.782871E-08,3.283620E-01,2.652870E+00,1.247500E+01,& + & 7.293610E+00,4.511620E+00,2.334090E+00,3.012820E+00,3.695210E+00,& + & 1.908477E+00,4.983432E-01,3.773702E-03,2.304480E-08,2.906940E-01,& + & 1.554780E+00,6.495050E+00,1.043330E+01,8.996270E+00,2.757510E+00,& + & 3.268520E+00,3.466770E+00,2.437475E+00,5.579354E-01,4.323827E-03,& + & 4.421270E-08 / + data ka_mn2o(:,:,18) / & + & 9.429840E-02,1.622070E-01,4.045070E-01,1.240220E+00,& + & 3.012810E+00,5.828510E+00,1.105070E+01,2.130100E+01,1.984989E+01,& + & 7.142065E+00,1.849400E+01,2.758832E+01,1.915640E-01,7.852770E-01,& + & 3.134590E+00,4.750420E+00,7.227530E+00,1.172960E+01,9.623480E+00,& + & 5.148730E+00,2.805232E+00,6.241619E-01,5.781998E-03,6.258148E-08,& + & 2.294840E-01,1.080210E+00,4.129890E+00,6.875110E+00,1.029450E+01,& + & 8.185140E+00,4.773510E+00,4.177670E+00,2.643509E+00,6.230718E-01,& + & 5.762260E-03,6.158307E-08,2.657830E-01,1.314650E+00,5.168790E+00,& + & 8.915720E+00,1.034340E+01,4.542300E+00,4.250080E+00,3.487580E+00,& + & 2.565834E+00,6.200227E-01,5.744043E-03,6.058474E-08,3.055980E-01,& + & 1.525470E+00,6.158560E+00,1.108280E+01,8.098480E+00,3.106830E+00,& + & 3.683600E+00,3.474490E+00,2.497627E+00,6.166664E-01,5.726059E-03,& + & 5.874826E-08,3.257200E-01,1.798990E+00,7.643980E+00,1.114790E+01,& + & 6.340330E+00,2.911660E+00,3.288000E+00,3.475910E+00,2.436105E+00,& + & 6.114053E-01,5.627015E-03,5.592494E-08,3.368770E-01,2.153880E+00,& + & 1.013470E+01,9.266040E+00,5.513050E+00,2.388340E+00,3.212620E+00,& + & 3.511810E+00,2.327742E+00,5.995250E-01,5.463748E-03,5.026672E-08,& + & 3.363620E-01,2.670780E+00,1.237750E+01,7.322980E+00,4.518540E+00,& + & 2.361110E+00,3.044550E+00,3.717410E+00,1.936470E+00,5.512879E-01,& + & 4.998799E-03,3.062085E-08,2.985940E-01,1.574980E+00,6.445050E+00,& + & 1.039510E+01,9.023900E+00,2.776370E+00,3.301660E+00,3.485950E+00,& + & 2.466620E+00,6.166672E-01,5.726285E-03,5.874826E-08 / + data ka_mn2o(:,:,19) / 9.743060E-02,& + & 1.674270E-01,4.288010E-01,1.292930E+00,3.043600E+00,5.830960E+00,& + & 1.097910E+01,2.121390E+01,1.983412E+01,7.193881E+00,1.885987E+01,& + & 2.793232E+01,1.969460E-01,8.052940E-01,3.136910E+00,4.732120E+00,& + & 7.214280E+00,1.169750E+01,9.642270E+00,5.190620E+00,2.834738E+00,& + & 6.899226E-01,7.657547E-03,8.315773E-08,2.353310E-01,1.096860E+00,& + & 4.113070E+00,6.842260E+00,1.027510E+01,8.200330E+00,4.812390E+00,& + & 4.207660E+00,2.673359E+00,6.887295E-01,7.631462E-03,8.183119E-08,& + & 2.719440E-01,1.332870E+00,5.134990E+00,8.877620E+00,1.034060E+01,& + & 4.570480E+00,4.294860E+00,3.506670E+00,2.595775E+00,6.853864E-01,& + & 7.607393E-03,8.050465E-08,3.125680E-01,1.545150E+00,6.103570E+00,& + & 1.105110E+01,8.115000E+00,3.138590E+00,3.721540E+00,3.493580E+00,& + & 2.527514E+00,6.817026E-01,7.583507E-03,7.806258E-08,3.335650E-01,& + & 1.815670E+00,7.568390E+00,1.114210E+01,6.357690E+00,2.944430E+00,& + & 3.322400E+00,3.495050E+00,2.466078E+00,6.759405E-01,7.452532E-03,& + & 7.431282E-08,3.450710E-01,2.169510E+00,1.004070E+01,9.288490E+00,& + & 5.529460E+00,2.413680E+00,3.246640E+00,3.531300E+00,2.357798E+00,& + & 6.629214E-01,7.236704E-03,6.679437E-08,3.445570E-01,2.688810E+00,& + & 1.228080E+01,7.352480E+00,4.525470E+00,2.388440E+00,3.076620E+00,& + & 3.739740E+00,1.965189E+00,6.099879E-01,6.621598E-03,4.068771E-08,& + & 3.067090E-01,1.595440E+00,6.395430E+00,1.035710E+01,9.051610E+00,& + & 2.795360E+00,3.335130E+00,3.505240E+00,2.496381E+00,6.817038E-01,& + & 7.583629E-03,7.806258E-08 / + + + data kb_mn2o(:, :) / & + & 8.426880E-03,2.249760E-02,5.935420E-02,1.980220E-01,6.414130E-01,& + & 1.479060E+00,3.531520E+00,9.067830E+00,4.622497E+01,1.653518E+02,& + & 2.320270E+01,2.189427E+00,8.967870E-03,2.389350E-02,6.373120E-02,& + & 2.058950E-01,6.462390E-01,1.487680E+00,3.554920E+00,9.045970E+00,& + & 4.598204E+01,1.661148E+02,2.348224E+01,2.339742E+00,9.543580E-03,& + & 2.537620E-02,6.843100E-02,2.140820E-01,6.511010E-01,1.496350E+00,& + & 3.578480E+00,9.024150E+00,4.574057E+01,1.668817E+02,2.376594E+01,& + & 2.500415E+00,1.015630E-02,2.695080E-02,7.347740E-02,2.225940E-01,& + & 6.560000E-01,1.505070E+00,3.602190E+00,9.002390E+00,4.550036E+01,& + & 1.676546E+02,2.405378E+01,2.672153E+00,1.080830E-02,2.862310E-02,& + & 7.889600E-02,2.314450E-01,6.609360E-01,1.513840E+00,3.626060E+00,& + & 8.980690E+00,4.526169E+01,1.684315E+02,2.434591E+01,2.855743E+00,& + & 1.150210E-02,3.039910E-02,8.471410E-02,2.406470E-01,6.659100E-01,& + & 1.522670E+00,3.650080E+00,8.959030E+00,4.502438E+01,1.692134E+02,& + & 2.464236E+01,3.052032E+00,1.224050E-02,3.228540E-02,9.096130E-02,& + & 2.502160E-01,6.709200E-01,1.531540E+00,3.674270E+00,8.937430E+00,& + & 4.478843E+01,1.699997E+02,2.494322E+01,3.261907E+00,1.302630E-02,& + & 3.428870E-02,9.766920E-02,2.601640E-01,6.759680E-01,1.540470E+00,& + & 3.698620E+00,8.915880E+00,4.455383E+01,1.707915E+02,2.524846E+01,& + & 3.486380E+00,1.386260E-02,3.641630E-02,1.048720E-01,2.705090E-01,& + & 6.810540E-01,1.549440E+00,3.723130E+00,8.894380E+00,4.432059E+01,& + & 1.715878E+02,2.555829E+01,3.726507E+00,1.475250E-02,3.867600E-02,& + & 1.126050E-01,2.812650E-01,6.861790E-01,1.558470E+00,3.747800E+00,& + & 8.872930E+00,4.408880E+01,1.723894E+02,2.587275E+01,3.983488E+00,& + & 1.569960E-02,4.107590E-02,1.209100E-01,2.924480E-01,6.913420E-01,& + & 1.567550E+00,3.772630E+00,8.851540E+00,4.385818E+01,1.731955E+02,& + & 2.619181E+01,4.258628E+00,1.670750E-02,4.362460E-02,1.298260E-01,& + & 3.040760E-01,6.965440E-01,1.576690E+00,3.797630E+00,8.830200E+00,& + & 4.362901E+01,1.740071E+02,2.651564E+01,4.553389E+00,1.778000E-02,& + & 4.633150E-02,1.394000E-01,3.161670E-01,7.017850E-01,1.585880E+00,& + & 3.822790E+00,8.808900E+00,4.340120E+01,1.748235E+02,2.684428E+01,& + & 4.869420E+00,1.892150E-02,4.920640E-02,1.496800E-01,3.287380E-01,& + & 7.070650E-01,1.595120E+00,3.848120E+00,8.787660E+00,4.317466E+01,& + & 1.756448E+02,2.717789E+01,5.208626E+00,2.013620E-02,5.225970E-02,& + & 1.607180E-01,3.418090E-01,7.123850E-01,1.604420E+00,3.873620E+00,& + & 8.766470E+00,4.294938E+01,1.764717E+02,2.751636E+01,5.573210E+00,& + & 2.142890E-02,5.550240E-02,1.725700E-01,3.554000E-01,7.177460E-01,& + & 1.613770E+00,3.899290E+00,8.745330E+00,4.272545E+01,1.773034E+02,& + & 2.785992E+01,5.965776E+00,2.280450E-02,5.894640E-02,1.852960E-01,& + & 3.695310E-01,7.231460E-01,1.623170E+00,3.925130E+00,8.724250E+00,& + & 4.250280E+01,1.781410E+02,2.820859E+01,6.389495E+00,2.426850E-02,& + & 6.260400E-02,1.989610E-01,3.842240E-01,7.285870E-01,1.632630E+00,& + & 3.951140E+00,8.703210E+00,4.228150E+01,1.789826E+02,2.856240E+01,& + & 6.848229E+00,2.582650E-02,6.648860E-02,2.136330E-01,3.995010E-01,& + & 7.340700E-01,1.642150E+00,3.977320E+00,8.682230E+00,4.206148E+01,& + & 1.798305E+02,2.892161E+01,7.346878E+00 / + +! --- the array selfref contains the coefficient of the water vapor +! self-continuum (including the energy term). the first index +! refers to temperature in 7.2 degree increments. for instance, +! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +! etc. the second index runs over the g-channel (1 to NG09=12). + + data selfref(:, :) / & + & 2.834530E-02,3.051850E-02,4.238330E-02,5.764810E-02,6.922550E-02,& + & 6.076940E-02,6.237490E-02,6.907440E-02,8.150021E-02,9.279437E-02,& + & 1.018511E-01,1.257602E-01,2.514390E-02,2.723740E-02,3.762500E-02,& + & 5.136860E-02,6.335210E-02,5.941820E-02,6.077440E-02,6.618110E-02,& + & 7.746312E-02,8.857998E-02,9.704026E-02,1.213644E-01,2.230400E-02,& + & 2.430900E-02,3.340100E-02,4.577300E-02,5.797700E-02,5.809700E-02,& + & 5.921500E-02,6.340900E-02,7.362608E-02,8.456960E-02,9.246707E-02,& + & 1.171287E-01,1.978490E-02,2.169550E-02,2.965120E-02,4.078700E-02,& + & 5.305800E-02,5.680520E-02,5.769560E-02,6.075300E-02,6.997905E-02,& + & 8.075282E-02,8.811944E-02,1.130480E-01,1.755030E-02,1.936290E-02,& + & 2.632230E-02,3.634410E-02,4.855630E-02,5.554220E-02,5.621520E-02,& + & 5.820830E-02,6.651269E-02,7.711981E-02,8.398573E-02,1.091152E-01,& + & 1.556810E-02,1.728110E-02,2.336720E-02,3.238510E-02,4.443650E-02,& + & 5.430720E-02,5.477280E-02,5.577020E-02,6.321807E-02,7.366115E-02,& + & 8.005490E-02,1.053262E-01,1.380970E-02,1.542320E-02,2.074390E-02,& + & 2.885740E-02,4.066630E-02,5.309970E-02,5.336740E-02,5.343420E-02,& + & 6.008663E-02,7.036801E-02,7.631665E-02,1.016743E-01,1.225000E-02,& + & 1.376500E-02,1.841500E-02,2.571400E-02,3.721600E-02,5.191900E-02,& + & 5.199800E-02,5.119600E-02,5.711026E-02,6.723196E-02,7.276115E-02,& + & 9.815388E-02,1.086640E-02,1.228510E-02,1.634760E-02,2.291300E-02,& + & 3.405840E-02,5.076460E-02,5.066380E-02,4.905160E-02,5.428132E-02,& + & 6.424513E-02,6.937900E-02,9.476077E-02,9.639120E-03,1.096430E-02,& + & 1.451230E-02,2.041710E-02,3.116870E-02,4.963580E-02,4.936380E-02,& + & 4.699700E-02,5.159255E-02,6.139999E-02,6.616145E-02,9.148991E-02/ + + + data forref(:, :) / & + & 7.535200E-06,2.981200E-05,1.449700E-04,4.400600E-04,1.049200E-03,& + & 1.967600E-03,1.998900E-03,1.909900E-03,2.235373E-03,2.814741E-03,& + & 3.176441E-03,5.064288E-03,6.607000E-06,4.861800E-05,3.111200E-04,& + & 8.423500E-04,1.417900E-03,1.431500E-03,1.468500E-03,1.655400E-03,& + & 2.140412E-03,2.627536E-03,3.023792E-03,4.388469E-03,6.596200E-06,& + & 7.259500E-04,1.342900E-03,1.167500E-03,9.838400E-04,8.878700E-04,& + & 8.755700E-04,8.058900E-04,7.805448E-04,9.328631E-04,1.746371E-03,& + & 4.086134E-03,3.621700E-04,1.070900E-03,1.062800E-03,8.564000E-04,& + & 8.933200E-04,8.337200E-04,7.853900E-04,8.282800E-04,8.350467E-04,& + & 7.656108E-04,7.036482E-04,2.534352E-03 / + + + data fracrefa(:,:) / & + & 1.812900e-01,1.611900e-01,1.330800e-01,1.234200e-01,1.125900e-01,& + & 9.758000e-02,7.917600e-02,5.854100e-02,4.332590e-02,6.124900e-03,& + & 3.162200e-03,5.135390e-04,1.966500e-01,1.564000e-01,1.310100e-01,& + & 1.215300e-01,1.103700e-01,9.604300e-02,7.785600e-02,5.754700e-02,& + & 4.286550e-02,6.088500e-03,3.133800e-03,5.020430e-04,2.027300e-01,& + & 1.550600e-01,1.304400e-01,1.204300e-01,1.095200e-01,9.538400e-02,& + & 7.715700e-02,5.717600e-02,4.253740e-02,6.024800e-03,3.065600e-03,& + & 4.683500e-04,2.027200e-01,1.596300e-01,1.291300e-01,1.206000e-01,& + & 1.082000e-01,9.468500e-02,7.654400e-02,5.685100e-02,4.224630e-02,& + & 5.949600e-03,3.013800e-03,4.248400e-04,2.028000e-01,1.635300e-01,& + & 1.291000e-01,1.196800e-01,1.072500e-01,9.411200e-02,7.582800e-02,& + & 5.652600e-02,4.199250e-02,5.874400e-03,2.914300e-03,4.004200e-04,& + & 2.029400e-01,1.684000e-01,1.285200e-01,1.181300e-01,1.072400e-01,& + & 9.294600e-02,7.502900e-02,5.615800e-02,4.170720e-02,5.770900e-03,& + & 2.763800e-03,4.004200e-04,2.031300e-01,1.739000e-01,1.286400e-01,& + & 1.168900e-01,1.060100e-01,9.179100e-02,7.422400e-02,5.550000e-02,& + & 4.129540e-02,5.614600e-03,2.612150e-03,4.004000e-04,2.033200e-01,& + & 1.780000e-01,1.328600e-01,1.155500e-01,1.040700e-01,9.047500e-02,& + & 7.245200e-02,5.456600e-02,4.046590e-02,5.293800e-03,2.549100e-03,& + & 4.004100e-04,1.962400e-01,1.651900e-01,1.366300e-01,1.153500e-01,& + & 1.071900e-01,9.415600e-02,7.674500e-02,5.698700e-02,4.229760e-02,& + & 6.135900e-03,2.682210e-03,4.004000e-04 / + + + data fracrefb(:) / 2.091400e-01,1.507700e-01,1.287800e-01,& + & 1.185600e-01,1.069500e-01,9.304800e-02,7.764500e-02,6.078500e-02,& + & 4.469190e-02,6.029400e-03,3.111400e-03,4.861310e-04 / + +!........................................! + end module module_radlw_kgb09 ! +!========================================! + + +!> This module sets up absorption coefficients for band 10: 1390-1480 +!! cm-1 (low - h2o; high - h2o) +!========================================! + module module_radlw_kgb10 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG10 +! + implicit none +! + private +! +!> msa10=65 + integer, public :: MSA10 +!> msb10=235 + integer, public :: MSB10 +!> msf10=10 + integer, public :: MSF10 +!> mfr10=4 + integer, public :: MFR10 + parameter (MSA10=65, MSB10=235, MSF10=10, MFR10=4) + + +!> the array absa(NG10,65) = ka(NG10,5,13) contains absorption coefs +!! at the NG10=6 chosen g-values for a range of pressure levels>~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 1 to 13 and refers to the corresponding +!! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). +!! the third index, ig, goes from 1 to NG10=6, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG10,MSA10) + +!> the array absb(NG10,235) = kb(NG10,5,13:59) contains absorption coefs +!! at the NG10=6 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG10=6, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG10,MSB10) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG10=6). + real (kind=kind_phys), public :: selfref(NG10,MSF10) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG10=6). + real (kind=kind_phys), public :: forref(NG10,MFR10) + +!> planck fraction mapping level : p = 212.7250, t = 223.06 k + real (kind=kind_phys), public :: fracrefa(NG10) + +!> planck fraction mapping level : p = 95.58350 mb, t = 215.70 k + real (kind=kind_phys), public :: fracrefb(NG10) + + data absa(:, 1:40) / & + & 3.989876E-02,1.160308E-01,4.029029E-01,2.348630E+00,1.325367E+01,& + & 3.963394E+01,4.251021E-02,1.210691E-01,4.250125E-01,2.464793E+00,& + & 1.397317E+01,4.172640E+01,4.521002E-02,1.256328E-01,4.455153E-01,& + & 2.568893E+00,1.463364E+01,4.364389E+01,4.790582E-02,1.301493E-01,& + & 4.637114E-01,2.662631E+00,1.524228E+01,4.537274E+01,5.029154E-02,& + & 1.350377E-01,4.801620E-01,2.745861E+00,1.579712E+01,4.695446E+01,& + & 3.153566E-02,9.339428E-02,3.276000E-01,2.049267E+00,1.351526E+01,& + & 4.545006E+01,3.375195E-02,9.775344E-02,3.464418E-01,2.156185E+00,& + & 1.429192E+01,4.799459E+01,3.605718E-02,1.017898E-01,3.635724E-01,& + & 2.252812E+00,1.500823E+01,5.029074E+01,3.824218E-02,1.057978E-01,& + & 3.789285E-01,2.337426E+00,1.567067E+01,5.239681E+01,4.021986E-02,& + & 1.100305E-01,3.928703E-01,2.413032E+00,1.627199E+01,5.436173E+01,& + & 2.451949E-02,7.417409E-02,2.618365E-01,1.737250E+00,1.341083E+01,& + & 5.160681E+01,2.633260E-02,7.802285E-02,2.780463E-01,1.836821E+00,& + & 1.425202E+01,5.473445E+01,2.825227E-02,8.152088E-02,2.926506E-01,& + & 1.924538E+00,1.503231E+01,5.756943E+01,3.011622E-02,8.502207E-02,& + & 3.058986E-01,2.003244E+00,1.574598E+01,6.021631E+01,3.178110E-02,& + & 8.870113E-02,3.179342E-01,2.073270E+00,1.639981E+01,6.264411E+01,& + & 1.926598E-02,5.902125E-02,2.097523E-01,1.452220E+00,1.302772E+01,& + & 5.779122E+01,2.066225E-02,6.257400E-02,2.236743E-01,1.542989E+00,& + & 1.394056E+01,6.146524E+01,2.225977E-02,6.565285E-02,2.363545E-01,& + & 1.624140E+00,1.478451E+01,6.486799E+01,2.381197E-02,6.867189E-02,& + & 2.479284E-01,1.696760E+00,1.555557E+01,6.806041E+01,2.526342E-02,& + & 7.181243E-02,2.585942E-01,1.761206E+00,1.626144E+01,7.099782E+01,& + & 1.521625E-02,4.703835E-02,1.678691E-01,1.201124E+00,1.244998E+01,& + & 6.412535E+01,1.639640E-02,5.020494E-02,1.800264E-01,1.283328E+00,& + & 1.342120E+01,6.848089E+01,1.764153E-02,5.300191E-02,1.911358E-01,& + & 1.357739E+00,1.431658E+01,7.257047E+01,1.892948E-02,5.566278E-02,& + & 2.013599E-01,1.424435E+00,1.513945E+01,7.634705E+01,2.017545E-02,& + & 5.835470E-02,2.108430E-01,1.483726E+00,1.589782E+01,7.976654E+01,& + & 1.204014E-02,3.740859E-02,1.334616E-01,9.798859E-01,1.168443E+01,& + & 7.018658E+01,1.296546E-02,4.027884E-02,1.441624E-01,1.054594E+00,& + & 1.269982E+01,7.540901E+01,1.399474E-02,4.276846E-02,1.539530E-01,& + & 1.122654E+00,1.363801E+01,8.027591E+01,1.503245E-02,4.514474E-02,& + & 1.629906E-01,1.184013E+00,1.450750E+01,8.473655E+01,1.609747E-02,& + & 4.744905E-02,1.714372E-01,1.237988E+00,1.530987E+01,8.881626E+01,& + & 9.388515E-03,2.976437E-02,1.057372E-01,7.909480E-01,1.079767E+01,& + & 7.591707E+01,1.027570E-02,3.217380E-02,1.151260E-01,8.586285E-01,& + & 1.183907E+01,8.212724E+01,1.109761E-02,3.443971E-02,1.237798E-01,& + & 9.203469E-01,1.281121E+01,8.788808E+01,1.194584E-02,3.652877E-02,& + & 1.318058E-01,9.753108E-01,1.372085E+01,9.311907E+01,1.281588E-02,& + & 3.854196E-02,1.392889E-01,1.023935E+00,1.455358E+01,9.801168E+01,& + & 7.281664E-03,2.366996E-02,8.357643E-02,6.331257E-01,9.814757E+00,& + & 8.137752E+01,8.188739E-03,2.558476E-02,9.182860E-02,6.938000E-01,& + & 1.086965E+01,8.869789E+01,8.910737E-03,2.755816E-02,9.937643E-02,& + & 7.486774E-01,1.186746E+01,9.541513E+01,9.547997E-03,2.945550E-02,& + & 1.064464E-01,7.975664E-01,1.280017E+01,1.015987E+02,1.023987E-02,& + & 3.123357E-02,1.130077E-01,8.419467E-01,1.365617E+01,1.073501E+02/ + data absa(:,41:65) / & + & 5.799475E-03,1.880967E-02,6.557153E-02,5.027431E-01,8.774647E+00,& + & 8.617327E+01,6.537466E-03,2.049721E-02,7.272729E-02,5.563832E-01,& + & 9.835038E+00,9.463648E+01,7.271373E-03,2.206919E-02,7.932173E-02,& + & 6.047081E-01,1.084658E+01,1.024102E+02,7.999435E-03,2.354482E-02,& + & 8.545094E-02,6.485896E-01,1.178801E+01,1.096490E+02,8.705026E-03,& + & 2.495294E-02,9.119549E-02,6.887944E-01,1.266260E+01,1.162916E+02,& + & 5.323016E-03,1.812429E-02,4.928376E-02,3.970351E-01,7.810838E+00,& + & 9.071149E+01,5.929176E-03,1.824657E-02,5.736582E-02,4.431588E-01,& + & 8.864440E+00,1.002876E+02,6.565686E-03,1.904614E-02,6.402923E-02,& + & 4.851198E-01,9.864968E+00,1.092278E+02,7.240720E-03,1.997865E-02,& + & 7.017200E-02,5.234222E-01,1.080516E+01,1.175064E+02,7.891657E-03,& + & 2.119424E-02,7.532481E-02,5.583704E-01,1.166990E+01,1.252887E+02,& + & 5.234672E-03,1.619650E-02,4.071846E-02,3.310030E-01,7.353980E+00,& + & 9.927333E+01,5.727738E-03,1.723501E-02,4.673398E-02,3.686839E-01,& + & 8.354774E+00,1.098782E+02,6.219769E-03,1.836954E-02,5.224944E-02,& + & 4.033337E-01,9.296465E+00,1.198759E+02,6.642450E-03,1.818974E-02,& + & 5.896017E-02,4.350063E-01,1.016672E+01,1.293443E+02,7.145168E-03,& + & 1.872628E-02,6.423944E-02,4.637293E-01,1.096352E+01,1.382504E+02,& + & 4.676515E-03,1.424309E-02,3.469507E-02,2.755828E-01,6.853607E+00,& + & 1.080595E+02,5.179982E-03,1.485517E-02,4.003583E-02,3.068571E-01,& + & 7.773025E+00,1.199707E+02,5.554922E-03,1.582293E-02,4.456073E-02,& + & 3.358389E-01,8.636631E+00,1.312431E+02,5.938623E-03,1.681589E-02,& + & 4.868316E-02,3.621992E-01,9.435915E+00,1.418514E+02,6.293417E-03,& + & 1.648180E-02,5.433006E-02,3.862282E-01,1.017785E+01,1.516681E+02,& + & 3.937814E-03,1.196182E-02,2.955780E-02,2.311908E-01,6.298200E+00,& + & 1.171577E+02,4.329364E-03,1.241179E-02,3.415281E-02,2.575103E-01,& + & 7.137770E+00,1.303111E+02,4.614823E-03,1.328593E-02,3.794322E-02,& + & 2.819569E-01,7.926714E+00,1.427182E+02,4.928029E-03,1.402133E-02,& + & 4.180069E-02,3.036336E-01,8.670511E+00,1.542483E+02,5.244065E-03,& + & 1.384472E-02,4.654410E-02,3.231360E-01,9.367290E+00,1.648232E+02/ + + + data absb(:, 1: 40) / & + & 3.937814E-03,1.196182E-02,2.955780E-02,2.311908E-01,6.298200E+00,& + & 1.171577E+02,4.329364E-03,1.241179E-02,3.415281E-02,2.575103E-01,& + & 7.137770E+00,1.303111E+02,4.614823E-03,1.328593E-02,3.794322E-02,& + & 2.819569E-01,7.926714E+00,1.427182E+02,4.928029E-03,1.402133E-02,& + & 4.180069E-02,3.036336E-01,8.670511E+00,1.542483E+02,5.244065E-03,& + & 1.384472E-02,4.654410E-02,3.231360E-01,9.367290E+00,1.648232E+02,& + & 3.266219E-03,9.944353E-03,2.567430E-02,1.969493E-01,5.794620E+00,& + & 1.274561E+02,3.569535E-03,1.041259E-02,2.939809E-02,2.186111E-01,& + & 6.555106E+00,1.417088E+02,3.831528E-03,1.116383E-02,3.264990E-02,& + & 2.384375E-01,7.277215E+00,1.550423E+02,4.089330E-03,1.147728E-02,& + & 3.624048E-02,2.564692E-01,7.956900E+00,1.673899E+02,4.364228E-03,& + & 1.150398E-02,4.016704E-02,2.724279E-01,8.579616E+00,1.789252E+02,& + & 2.689113E-03,8.150242E-03,2.222494E-02,1.681922E-01,5.285599E+00,& + & 1.378634E+02,2.908205E-03,8.692254E-03,2.519093E-02,1.863066E-01,& + & 5.973264E+00,1.530689E+02,3.144287E-03,9.323133E-03,2.791695E-02,& + & 2.029245E-01,6.620194E+00,1.673222E+02,3.360466E-03,9.268154E-03,& + & 3.143544E-02,2.178056E-01,7.216509E+00,1.807304E+02,3.602021E-03,& + & 9.477152E-03,3.458441E-02,2.320069E-01,7.755984E+00,1.932518E+02,& + & 2.182489E-03,6.715308E-03,1.901308E-02,1.432318E-01,4.787220E+00,& + & 1.480816E+02,2.365661E-03,7.214391E-03,2.146762E-02,1.582814E-01,& + & 5.391041E+00,1.643346E+02,2.556943E-03,7.521720E-03,2.409179E-02,& + & 1.717977E-01,5.950309E+00,1.796897E+02,2.754894E-03,7.511193E-03,& + & 2.701964E-02,1.844141E-01,6.465167E+00,1.940471E+02,2.960357E-03,& + & 7.788869E-03,2.949016E-02,1.963195E-01,6.941168E+00,2.073210E+02,& + & 1.765535E-03,5.543259E-03,1.613798E-02,1.215560E-01,4.275402E+00,& + & 1.582292E+02,1.926998E-03,5.963761E-03,1.817139E-02,1.338900E-01,& + & 4.794891E+00,1.755198E+02,2.078675E-03,6.000048E-03,2.067920E-02,& + & 1.450362E-01,5.281474E+00,1.917399E+02,2.249273E-03,6.124897E-03,& + & 2.292561E-02,1.558453E-01,5.733333E+00,2.068289E+02,2.427347E-03,& + & 6.392373E-03,2.491727E-02,1.658433E-01,6.156577E+00,2.207110E+02,& + & 1.420269E-03,4.566428E-03,1.357792E-02,1.032468E-01,3.769971E+00,& + & 1.680907E+02,1.556341E-03,4.818966E-03,1.543949E-02,1.132872E-01,& + & 4.221591E+00,1.861950E+02,1.684801E-03,4.796487E-03,1.754359E-02,& + & 1.227849E-01,4.645805E+00,2.031371E+02,1.827040E-03,5.000291E-03,& + & 1.927510E-02,1.317529E-01,5.045368E+00,2.188188E+02,1.979536E-03,& + & 5.233317E-03,2.087754E-02,1.404371E-01,5.414656E+00,2.332839E+02,& + & 1.154124E-03,3.743116E-03,1.145156E-02,8.770424E-02,3.299332E+00,& + & 1.773230E+02,1.262895E-03,3.837505E-03,1.312955E-02,9.601411E-02,& + & 3.691090E+00,1.961249E+02,1.375863E-03,3.906333E-03,1.475610E-02,& + & 1.039480E-01,4.063012E+00,2.136402E+02,1.491607E-03,4.111146E-03,& + & 1.614811E-02,1.115647E-01,4.410365E+00,2.298833E+02,1.596452E-03,& + & 4.316487E-03,1.747450E-02,1.189567E-01,4.735179E+00,2.448180E+02,& + & 9.486578E-04,3.096744E-03,9.714537E-03,7.465840E-02,2.878615E+00,& + & 1.861906E+02,1.037128E-03,3.099058E-03,1.118908E-02,8.175280E-02,& + & 3.218790E+00,2.055240E+02,1.131081E-03,3.224508E-03,1.245813E-02,& + & 8.851926E-02,3.537536E+00,2.235925E+02,1.230596E-03,3.392700E-03,& + & 1.361483E-02,9.496197E-02,3.838629E+00,2.402845E+02,1.306971E-03,& + & 3.587569E-03,1.472815E-02,1.012657E-01,4.122165E+00,2.556130E+02/ + data absb(:, 41: 80) / & + & 7.825086E-04,2.525388E-03,8.274685E-03,6.384398E-02,2.502671E+00,& + & 1.944166E+02,8.552702E-04,2.525468E-03,9.498398E-03,6.977313E-02,& + & 2.791094E+00,2.142907E+02,9.333372E-04,2.669980E-03,1.050977E-02,& + & 7.544853E-02,3.067730E+00,2.327441E+02,1.016411E-03,2.804671E-03,& + & 1.147524E-02,8.101868E-02,3.330362E+00,2.497901E+02,1.077528E-03,& + & 2.976730E-03,1.241279E-02,8.623314E-02,3.579181E+00,2.654057E+02,& + & 6.482434E-04,2.030990E-03,7.139612E-03,5.487990E-02,2.181812E+00,& + & 2.034580E+02,7.098369E-04,2.089035E-03,8.088525E-03,5.987024E-02,& + & 2.432009E+00,2.235603E+02,7.744365E-04,2.219568E-03,8.911908E-03,& + & 6.468818E-02,2.671827E+00,2.422454E+02,8.365216E-04,2.339019E-03,& + & 9.729815E-03,6.935646E-02,2.900532E+00,2.594521E+02,8.889558E-04,& + & 2.479067E-03,1.051200E-02,7.385594E-02,3.118976E+00,2.752177E+02,& + & 5.366934E-04,1.650412E-03,6.121958E-03,4.705822E-02,1.903169E+00,& + & 2.119946E+02,5.880903E-04,1.739171E-03,6.863960E-03,5.136870E-02,& + & 2.119641E+00,2.322732E+02,6.442107E-04,1.838301E-03,7.566977E-03,& + & 5.548270E-02,2.327203E+00,2.510844E+02,6.903216E-04,1.948941E-03,& + & 8.260402E-03,5.937434E-02,2.524989E+00,2.684086E+02,7.359682E-04,& + & 2.062155E-03,8.897160E-03,6.329718E-02,2.714767E+00,2.842545E+02,& + & 4.465924E-04,1.358834E-03,5.238364E-03,4.037198E-02,1.662797E+00,& + & 2.201607E+02,4.897570E-04,1.450523E-03,5.841003E-03,4.405655E-02,& + & 1.848557E+00,2.405370E+02,5.373880E-04,1.528126E-03,6.432413E-03,& + & 4.757673E-02,2.026152E+00,2.594379E+02,5.724888E-04,1.624605E-03,& + & 6.997066E-03,5.098994E-02,2.197571E+00,2.768082E+02,6.113583E-04,& + & 1.717673E-03,7.526765E-03,5.429882E-02,2.367102E+00,2.926282E+02,& + & 3.720441E-04,1.129542E-03,4.476511E-03,3.464371E-02,1.454181E+00,& + & 2.280726E+02,4.087341E-04,1.207740E-03,4.966881E-03,3.776668E-02,& + & 1.612641E+00,2.485024E+02,4.456021E-04,1.275790E-03,5.466901E-03,& + & 4.083175E-02,1.766453E+00,2.673628E+02,4.749314E-04,1.355630E-03,& + & 5.931222E-03,4.378187E-02,1.919253E+00,2.846801E+02,5.080315E-04,& + & 1.432916E-03,6.371417E-03,4.667237E-02,2.072770E+00,3.003844E+02,& + & 3.111150E-04,9.461950E-04,3.823644E-03,2.977171E-02,1.274425E+00,& + & 2.359845E+02,3.425111E-04,1.005871E-03,4.241283E-03,3.248827E-02,& + & 1.411270E+00,2.563235E+02,3.690716E-04,1.069351E-03,4.650029E-03,& + & 3.510722E-02,1.547927E+00,2.750750E+02,3.953641E-04,1.133394E-03,& + & 5.029641E-03,3.768010E-02,1.685938E+00,2.922146E+02,4.232993E-04,& + & 1.193767E-03,5.396663E-03,4.020281E-02,1.825534E+00,3.077647E+02,& + & 2.604715E-04,7.922608E-04,3.265864E-03,2.562608E-02,1.118584E+00,& + & 2.435571E+02,2.870681E-04,8.393442E-04,3.617734E-03,2.795259E-02,& + & 1.240040E+00,2.637323E+02,3.077420E-04,8.937328E-04,3.949174E-03,& + & 3.019431E-02,1.363264E+00,2.822843E+02,3.298732E-04,9.478897E-04,& + & 4.266017E-03,3.242130E-02,1.488163E+00,2.992288E+02,3.532276E-04,& + & 9.970650E-04,4.579950E-03,3.468053E-02,1.616281E+00,3.146029E+02,& + & 2.185289E-04,6.619310E-04,2.787803E-03,2.211638E-02,9.845887E-01,& + & 2.508078E+02,2.408051E-04,7.010474E-04,3.082902E-03,2.406708E-02,& + & 1.094268E+00,2.707638E+02,2.566136E-04,7.479203E-04,3.357089E-03,& + & 2.600968E-02,1.205851E+00,2.890811E+02,2.754070E-04,7.908251E-04,& + & 3.622849E-03,2.794492E-02,1.320272E+00,3.057966E+02,2.950738E-04,& + & 8.340920E-04,3.884995E-03,2.990904E-02,1.438613E+00,3.209641E+02/ + data absb(:, 81:120) / & + & 1.834243E-04,5.523957E-04,2.384256E-03,1.909026E-02,8.715470E-01,& + & 2.578432E+02,1.993854E-04,5.888451E-04,2.625339E-03,2.075798E-02,& + & 9.706007E-01,2.775482E+02,2.138880E-04,6.263060E-04,2.855177E-03,& + & 2.240976E-02,1.072799E+00,2.956126E+02,2.295066E-04,6.614585E-04,& + & 3.079338E-03,2.411362E-02,1.178320E+00,3.120804E+02,2.460096E-04,& + & 6.993794E-04,3.294770E-03,2.586576E-02,1.289157E+00,3.269600E+02,& + & 1.540939E-04,4.615129E-04,2.035671E-03,1.644918E-02,7.759781E-01,& + & 2.646017E+02,1.658587E-04,4.927051E-04,2.234419E-03,1.791172E-02,& + & 8.659560E-01,2.840419E+02,1.784015E-04,5.238895E-04,2.425504E-03,& + & 1.935996E-02,9.595247E-01,3.018168E+02,1.915036E-04,5.539912E-04,& + & 2.613583E-03,2.085470E-02,1.058741E+00,3.179896E+02,2.047566E-04,& + & 5.878188E-04,2.797740E-03,2.244471E-02,1.163590E+00,3.326027E+02,& + & 1.293037E-04,3.856166E-04,1.734866E-03,1.418603E-02,6.949766E-01,& + & 2.711828E+02,1.381820E-04,4.124068E-04,1.900464E-03,1.545874E-02,& + & 7.770773E-01,2.899311E+02,1.486815E-04,4.373950E-04,2.061033E-03,& + & 1.675462E-02,8.647477E-01,3.077749E+02,1.595627E-04,4.645202E-04,& + & 2.216812E-03,1.808298E-02,9.586084E-01,3.236290E+02,1.703056E-04,& + & 4.939586E-04,2.374420E-03,1.942470E-02,1.060638E+00,3.379184E+02,& + & 1.070004E-04,3.234334E-04,1.478320E-03,1.227001E-02,6.259261E-01,& + & 2.775497E+02,1.151056E-04,3.457120E-04,1.614809E-03,1.337940E-02,& + & 7.025897E-01,2.963517E+02,1.238479E-04,3.664647E-04,1.751465E-03,& + & 1.453930E-02,7.852455E-01,3.134691E+02,1.329066E-04,3.900802E-04,& + & 1.882416E-03,1.569063E-02,8.762825E-01,3.289909E+02,1.418326E-04,& + & 4.154427E-04,2.016627E-03,1.685949E-02,9.773727E-01,3.429477E+02,& + & 8.907533E-05,2.709234E-04,1.258914E-03,1.063403E-02,5.677262E-01,& + & 2.837159E+02,9.604699E-05,2.885368E-04,1.374615E-03,1.162150E-02,& + & 6.402334E-01,3.021435E+02,1.034118E-04,3.072583E-04,1.487377E-03,& + & 1.263162E-02,7.200889E-01,3.189194E+02,1.106129E-04,3.281214E-04,& + & 1.599604E-03,1.365990E-02,8.098990E-01,3.340635E+02,1.179680E-04,& + & 3.502393E-04,1.715192E-03,1.467884E-02,9.116261E-01,3.476621E+02,& + & 7.431310E-05,2.266361E-04,1.068977E-03,9.238574E-03,5.165800E-01,& + & 2.889792E+02,8.011741E-05,2.412986E-04,1.166190E-03,1.013691E-02,& + & 5.861510E-01,3.070973E+02,8.609274E-05,2.577415E-04,1.261123E-03,& + & 1.102033E-02,6.646328E-01,3.235290E+02,9.207836E-05,2.757439E-04,& + & 1.357465E-03,1.192304E-02,7.544266E-01,3.383594E+02,9.792505E-05,& + & 2.947751E-04,1.457754E-03,1.281981E-02,8.574408E-01,3.516410E+02,& + & 6.141751E-05,1.887247E-04,9.000550E-04,7.980364E-03,4.682497E-01,& + & 2.922180E+02,6.626091E-05,2.008949E-04,9.822302E-04,8.770762E-03,& + & 5.354092E-01,3.101811E+02,7.121472E-05,2.150436E-04,1.063123E-03,& + & 9.548916E-03,6.127087E-01,3.264295E+02,7.619091E-05,2.304817E-04,& + & 1.145929E-03,1.032109E-02,7.024566E-01,3.411036E+02,8.085083E-05,& + & 2.464457E-04,1.231208E-03,1.114412E-02,8.062111E-01,3.541618E+02,& + & 5.041333E-05,1.558772E-04,7.506100E-04,6.825974E-03,4.215100E-01,& + & 2.933274E+02,5.439817E-05,1.661258E-04,8.198977E-04,7.507457E-03,& + & 4.863004E-01,3.112226E+02,5.847463E-05,1.781645E-04,8.888958E-04,& + & 8.194330E-03,5.620327E-01,3.275058E+02,6.256159E-05,1.910610E-04,& + & 9.601980E-04,8.882833E-03,6.506789E-01,3.421458E+02,6.636943E-05,& + & 2.045069E-04,1.032646E-03,9.621723E-03,7.541592E-01,3.551925E+02/ + data absb(:,121:160) / & + & 4.104131E-05,1.278709E-04,6.213561E-04,5.800132E-03,3.737119E-01,& + & 2.913929E+02,4.435809E-05,1.365930E-04,6.802988E-04,6.403989E-03,& + & 4.349389E-01,3.095772E+02,4.767614E-05,1.468126E-04,7.390475E-04,& + & 7.011932E-03,5.078018E-01,3.260813E+02,5.103903E-05,1.578472E-04,& + & 8.007661E-04,7.638761E-03,5.936314E-01,3.409375E+02,5.418339E-05,& + & 1.690642E-04,8.632211E-04,8.287663E-03,6.944559E-01,3.542140E+02,& + & 3.340442E-05,1.049706E-04,5.138726E-04,4.922984E-03,3.327213E-01,& + & 2.891708E+02,3.612676E-05,1.121960E-04,5.640764E-04,5.461364E-03,& + & 3.908573E-01,3.076409E+02,3.882853E-05,1.208984E-04,6.146577E-04,& + & 6.015927E-03,4.607924E-01,3.243743E+02,4.161371E-05,1.302063E-04,& + & 6.672997E-04,6.565803E-03,5.439976E-01,3.394500E+02,4.422847E-05,& + & 1.395557E-04,7.217779E-04,7.145829E-03,6.421400E-01,3.529589E+02,& + & 2.717286E-05,8.600499E-05,4.254908E-04,4.177952E-03,2.979296E-01,& + & 2.868566E+02,2.937672E-05,9.214868E-05,4.677419E-04,4.658568E-03,& + & 3.533015E-01,3.055637E+02,3.161890E-05,9.956276E-05,5.111362E-04,& + & 5.154421E-03,4.205742E-01,3.225798E+02,3.390578E-05,1.072751E-04,& + & 5.564067E-04,5.649849E-03,5.012959E-01,3.378822E+02,3.608139E-05,& + & 1.150635E-04,6.036089E-04,6.171118E-03,5.968986E-01,3.516257E+02,& + & 2.200381E-05,7.005386E-05,3.507274E-04,3.533794E-03,2.633153E-01,& + & 2.823945E+02,2.375174E-05,7.531732E-05,3.870995E-04,3.966194E-03,& + & 3.152320E-01,3.015532E+02,2.565769E-05,8.158436E-05,4.235075E-04,& + & 4.410850E-03,3.786094E-01,3.189574E+02,2.750451E-05,8.805506E-05,& + & 4.624638E-04,4.860043E-03,4.555979E-01,3.346948E+02,2.934721E-05,& + & 9.453816E-05,5.034183E-04,5.337068E-03,5.470983E-01,3.488067E+02,& + & 1.783678E-05,5.691387E-05,2.888434E-04,2.989704E-03,2.331102E-01,& + & 2.774976E+02,1.920896E-05,6.149157E-05,3.200250E-04,3.374496E-03,& + & 2.815232E-01,2.971053E+02,2.076535E-05,6.675014E-05,3.516047E-04,& + & 3.775226E-03,3.411260E-01,3.149654E+02,2.228998E-05,7.218312E-05,& + & 3.847198E-04,4.183088E-03,4.141752E-01,3.311499E+02,2.386139E-05,& + & 7.760907E-05,4.201830E-04,4.624225E-03,5.015246E-01,3.456526E+02,& + & 1.451865E-05,4.609782E-05,2.378174E-04,2.530174E-03,2.071351E-01,& + & 2.724291E+02,1.557277E-05,5.005625E-05,2.646663E-04,2.867400E-03,& + & 2.522176E-01,2.924835E+02,1.681788E-05,5.452132E-05,2.922585E-04,& + & 3.228751E-03,3.082942E-01,3.107926E+02,1.805927E-05,5.908529E-05,& + & 3.208572E-04,3.602877E-03,3.773926E-01,3.274099E+02,1.934290E-05,& + & 6.364192E-05,3.515720E-04,4.007969E-03,4.607742E-01,3.423453E+02,& + & 1.162507E-05,3.734504E-05,1.952229E-04,2.125430E-03,1.824476E-01,& + & 2.659607E+02,1.258234E-05,4.058266E-05,2.184997E-04,2.429154E-03,& + & 2.239995E-01,2.865868E+02,1.356650E-05,4.431661E-05,2.424080E-04,& + & 2.754907E-03,2.761383E-01,3.054548E+02,1.458232E-05,4.816739E-05,& + & 2.671425E-04,3.096869E-03,3.405830E-01,3.226039E+02,1.563111E-05,& + & 5.198656E-05,2.937994E-04,3.461173E-03,4.193319E-01,3.380430E+02,& + & 9.271416E-06,3.020752E-05,1.594987E-04,1.775475E-03,1.601015E-01,& + & 2.587953E+02,1.018578E-05,3.279123E-05,1.797537E-04,2.055089E-03,& + & 1.983404E-01,2.799725E+02,1.094067E-05,3.588018E-05,2.005303E-04,& + & 2.348016E-03,2.463274E-01,2.994227E+02,1.176915E-05,3.914617E-05,& + & 2.222777E-04,2.654694E-03,3.061533E-01,3.171727E+02,1.261644E-05,& + & 4.235427E-05,2.456580E-04,2.986445E-03,3.798247E-01,3.331762E+02/ + data absb(:,161:200) / & + & 7.396955E-06,2.436360E-05,1.301793E-04,1.482677E-03,1.406569E-01,& + & 2.513606E+02,8.235204E-06,2.650226E-05,1.477416E-04,1.731456E-03,& + & 1.759119E-01,2.731179E+02,8.851764E-06,2.899711E-05,1.660078E-04,& + & 1.999964E-03,2.199938E-01,2.931840E+02,9.508220E-06,3.176819E-05,& + & 1.849348E-04,2.280367E-03,2.754109E-01,3.115194E+02,1.018121E-05,& + & 3.445835E-05,2.055057E-04,2.579397E-03,3.440524E-01,3.280900E+02,& + & 5.883954E-06,1.958742E-05,1.055575E-04,1.235391E-03,1.230446E-01,& + & 2.432369E+02,6.561310E-06,2.143467E-05,1.207684E-04,1.456126E-03,& + & 1.553657E-01,2.656033E+02,7.146771E-06,2.338229E-05,1.368761E-04,& + & 1.696927E-03,1.957398E-01,2.862727E+02,7.657773E-06,2.567900E-05,& + & 1.535738E-04,1.953674E-03,2.467596E-01,3.052181E+02,8.220508E-06,& + & 2.793782E-05,1.717776E-04,2.225944E-03,3.102393E-01,3.224556E+02,& + & 4.674082E-06,1.567026E-05,8.458134E-05,1.020802E-03,1.066597E-01,& + & 2.338235E+02,5.205831E-06,1.718409E-05,9.773791E-05,1.216440E-03,& + & 1.357859E-01,2.568982E+02,5.778314E-06,1.871322E-05,1.117978E-04,& + & 1.427995E-03,1.725494E-01,2.782508E+02,6.181325E-06,2.061205E-05,& + & 1.266448E-04,1.657978E-03,2.188489E-01,2.978932E+02,6.626425E-06,& + & 2.252304E-05,1.428602E-04,1.909526E-03,2.769209E-01,3.158074E+02,& + & 3.731157E-06,1.261841E-05,6.724874E-05,8.417258E-04,9.257680E-02,& + & 2.241550E+02,4.131776E-06,1.377453E-05,7.880367E-05,1.013961E-03,& + & 1.185999E-01,2.478632E+02,4.591864E-06,1.507085E-05,9.097934E-05,& + & 1.202059E-03,1.520543E-01,2.699498E+02,4.982468E-06,1.651190E-05,& + & 1.040123E-04,1.404484E-03,1.940674E-01,2.902784E+02,5.333456E-06,& + & 1.813156E-05,1.184174E-04,1.635174E-03,2.471267E-01,3.089028E+02,& + & 2.949317E-06,1.029446E-05,5.303492E-05,6.913522E-04,8.055481E-02,& + & 2.142425E+02,3.286812E-06,1.107224E-05,6.312291E-05,8.436028E-04,& + & 1.035734E-01,2.385926E+02,3.646663E-06,1.215129E-05,7.360418E-05,& + & 1.010623E-03,1.338065E-01,2.613487E+02,4.039179E-06,1.318766E-05,& + & 8.507787E-05,1.192481E-03,1.720176E-01,2.823869E+02,4.312898E-06,& + & 1.457671E-05,9.760018E-05,1.400050E-03,2.203089E-01,3.016847E+02,& + & 2.380829E-06,8.644108E-06,4.139990E-05,5.707751E-04,7.084354E-02,& + & 2.047339E+02,2.634503E-06,8.941559E-06,5.048274E-05,7.043106E-04,& + & 9.107945E-02,2.296467E+02,2.909480E-06,9.756521E-06,5.954953E-05,& + & 8.522591E-04,1.184234E-01,2.530079E+02,3.217572E-06,1.064259E-05,& + & 6.945702E-05,1.016717E-03,1.534460E-01,2.747024E+02,3.485750E-06,& + & 1.170931E-05,8.041641E-05,1.205978E-03,1.974761E-01,2.946735E+02,& + & 1.941794E-06,7.192310E-06,3.221830E-05,4.709392E-04,6.275081E-02,& + & 1.952857E+02,2.104805E-06,7.256631E-06,4.021317E-05,5.873867E-04,& + & 8.048103E-02,2.207482E+02,2.327782E-06,7.887051E-06,4.798458E-05,& + & 7.190749E-04,1.050482E-01,2.446642E+02,2.573313E-06,8.603976E-06,& + & 5.659474E-05,8.662863E-04,1.371270E-01,2.670292E+02,2.838721E-06,& + & 9.397831E-06,6.608800E-05,1.038158E-03,1.774998E-01,2.875944E+02,& + & 1.555794E-06,5.689150E-06,2.532564E-05,3.882429E-04,5.619486E-02,& + & 1.857313E+02,1.712789E-06,6.083245E-06,3.157460E-05,4.883301E-04,& + & 7.136005E-02,2.116897E+02,1.874631E-06,6.357735E-06,3.848219E-05,& + & 6.041969E-04,9.323222E-02,2.361908E+02,2.059408E-06,6.976873E-06,& + & 4.582805E-05,7.380438E-04,1.224144E-01,2.591156E+02,2.271224E-06,& + & 7.578742E-06,5.420752E-05,8.935220E-04,1.595433E-01,2.803081E+02/ + data absb(:,201:235) / & + & 1.257103E-06,4.503985E-06,1.975593E-05,3.198622E-04,5.037247E-02,& + & 1.759760E+02,1.397879E-06,5.176262E-06,2.452789E-05,4.058089E-04,& + & 6.352084E-02,2.023549E+02,1.517199E-06,5.134869E-06,3.069902E-05,& + & 5.083844E-04,8.277444E-02,2.274243E+02,1.650774E-06,5.630390E-06,& + & 3.698933E-05,6.273302E-04,1.091761E-01,2.509444E+02,1.818796E-06,& + & 6.125238E-06,4.424472E-05,7.685104E-04,1.432972E-01,2.727775E+02,& + & 1.012139E-06,3.589765E-06,1.541514E-05,2.646405E-04,4.537280E-02,& + & 1.669068E+02,1.134928E-06,4.114862E-06,1.943443E-05,3.411285E-04,& + & 5.749717E-02,1.936690E+02,1.242799E-06,4.312417E-06,2.432028E-05,& + & 4.297715E-04,7.425622E-02,2.191974E+02,1.353066E-06,4.543223E-06,& + & 2.990633E-05,5.364630E-04,9.814401E-02,2.432722E+02,1.462327E-06,& + & 4.976090E-06,3.617119E-05,6.623395E-04,1.295564E-01,2.656756E+02,& + & 8.292568E-07,2.879595E-06,1.196113E-05,2.190246E-04,4.090976E-02,& + & 1.581830E+02,9.179034E-07,3.277964E-06,1.535887E-05,2.863720E-04,& + & 5.250150E-02,1.852320E+02,1.019403E-06,3.698102E-06,1.914728E-05,& + & 3.655504E-04,6.704034E-02,2.111933E+02,1.102755E-06,3.689554E-06,& + & 2.413878E-05,4.609147E-04,8.858735E-02,2.357501E+02,1.188997E-06,& + & 4.058980E-06,2.949296E-05,5.725032E-04,1.174897E-01,2.587184E+02,& + & 6.735057E-07,2.325543E-06,9.212281E-06,1.808746E-04,3.701845E-02,& + & 1.493729E+02,7.521523E-07,2.626609E-06,1.205145E-05,2.406149E-04,& + & 4.786531E-02,1.766496E+02,8.293037E-07,3.011087E-06,1.519351E-05,& + & 3.122275E-04,6.096780E-02,2.030365E+02,9.132433E-07,3.079910E-06,& + & 1.927130E-05,3.954507E-04,8.001272E-02,2.280579E+02,9.871518E-07,& + & 3.271138E-06,2.398756E-05,4.980170E-04,1.064712E-01,2.515373E+02,& + & 5.285809E-07,1.863082E-06,7.109533E-06,1.484308E-04,3.375963E-02,& + & 1.405363E+02,6.211058E-07,2.094750E-06,9.410819E-06,2.022993E-04,& + & 4.367997E-02,1.680358E+02,6.759425E-07,2.407133E-06,1.204558E-05,& + & 2.662509E-04,5.584740E-02,1.947245E+02,7.465869E-07,2.653588E-06,& + & 1.523057E-05,3.418088E-04,7.237189E-02,2.202174E+02,8.086300E-07,& + & 2.669302E-06,1.941360E-05,4.346230E-04,9.643498E-02,2.442269E+02,& + & 4.086823E-07,1.476198E-06,5.502336E-06,1.220000E-04,3.075840E-02,& + & 1.321149E+02,5.114186E-07,1.715895E-06,7.283951E-06,1.700905E-04,& + & 4.043882E-02,1.597372E+02,5.647113E-07,1.922401E-06,9.531120E-06,& + & 2.278367E-04,5.149722E-02,1.867359E+02,6.129191E-07,2.203258E-06,& + & 1.211970E-05,2.983851E-04,6.611855E-02,2.126382E+02,6.691039E-07,& + & 2.232575E-06,1.563583E-05,3.825282E-04,8.777469E-02,2.371201E+02,& + & 3.282631E-07,1.206681E-06,4.474188E-06,1.066403E-04,2.945755E-02,& + & 1.287625E+02,4.205595E-07,1.432736E-06,5.933199E-06,1.512903E-04,& + & 3.911298E-02,1.564033E+02,4.749020E-07,1.580700E-06,7.852538E-06,& + & 2.059222E-04,4.967048E-02,1.835156E+02,5.128344E-07,1.812831E-06,& + & 1.010838E-05,2.734323E-04,6.387627E-02,2.095823E+02,5.559251E-07,& + & 1.893362E-06,1.309992E-05,3.521941E-04,8.423455E-02,2.342460E+02/ + + + data selfref(:, :) / & + & 2.757227E-01,3.467635E-01,3.521956E-01,3.675792E-01,3.631232E-01,& + & 4.295592E-01,2.592735E-01,3.249800E-01,3.277287E-01,3.430616E-01,& + & 3.406791E-01,3.955564E-01,2.438054E-01,3.045745E-01,3.049615E-01,& + & 3.201804E-01,3.196245E-01,3.642713E-01,2.292604E-01,2.854600E-01,& + & 2.837763E-01,2.988260E-01,2.998744E-01,3.354847E-01,2.155837E-01,& + & 2.675538E-01,2.640627E-01,2.788967E-01,2.813468E-01,3.089953E-01,& + & 2.027234E-01,2.507793E-01,2.457188E-01,2.602969E-01,2.639667E-01,& + & 2.846184E-01,1.906307E-01,2.350642E-01,2.286492E-01,2.429384E-01,& + & 2.476622E-01,2.621836E-01,1.792595E-01,2.203406E-01,2.127654E-01,& + & 2.267381E-01,2.323669E-01,2.415340E-01,1.685671E-01,2.065467E-01,& + & 1.979849E-01,2.116188E-01,2.180181E-01,2.225270E-01,1.585125E-01,& + & 1.936220E-01,1.842316E-01,1.975081E-01,2.045581E-01,2.050303E-01/ + + + data forref(:, :) / & + & 1.266174E-02,1.692174E-02,1.618326E-02,1.764254E-02,1.822239E-02,& + & 1.908096E-02,1.248327E-02,1.668590E-02,1.675931E-02,1.782114E-02,& + & 1.776257E-02,2.085718E-02,1.102650E-02,1.750663E-02,1.753284E-02,& + & 1.816495E-02,1.779524E-02,2.105855E-02,1.087544E-02,1.801061E-02,& + & 1.797151E-02,1.720104E-02,1.711947E-02,1.648700E-02 / + + + data fracrefa(:) / 3.232800e-01,2.663600e-01,& + & 2.139660e-01,1.403760e-01,5.214150e-02,3.885218e-03 / + + + data fracrefb(:) / 3.307100e-01,2.709100e-01,& + & 2.041140e-01,1.383290e-01,5.196820e-02,3.976258e-03 / + +!........................................! + end module module_radlw_kgb10 ! +!========================================! + + +!> This module sets up absorption coefficients for band 11: 1480-1800 +!! cm-1 (low - h2o; high - h2o) +!========================================! + module module_radlw_kgb11 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG11 +! + implicit none +! + private +! +!> msa11=65 + integer, public :: MSA11 +!> msb11=235 + integer, public :: MSB11 +!> msf11=10 + integer, public :: MSF11 +!> mfr11=4 + integer, public :: MFR11 +!> mmo11=19 + integer, public :: MMO11 + parameter (MSA11=65, MSB11=235, MSF11=10, MFR11=4, MMO11=19) + + +!> the array absa(NG11,65) = ka(NG11,5,13) contains absorption coefs +!! at the NG11=8 chosen g-values for a range of pressure levels>~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 1 to 13 and refers to the corresponding +!! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). +!! the third index, ig, goes from 1 to NG11=8, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG11,MSA11) + +!> the array absb(NG11,235) = kb(NG11,5,13:59) contains absorption coefs +!! at the NG11=8 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG11=8, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG11,MSB11) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG11=8). + real (kind=kind_phys), public :: selfref(NG11,MSF11) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG11=8). + real (kind=kind_phys), public :: forref(NG11,MFR11) + +!> planck fraction mapping level : p=1053.63 mb, t= 294.2 k + real (kind=kind_phys), public :: fracrefa(NG11) + +!> planck fraction mapping level : p=0.353 mb, t = 262.11 k + real (kind=kind_phys), public :: fracrefb(NG11) + +!> the array ka_mxx contains the absorption coefficient for +!! a minor species at the NG11=8 chosen g-values for a reference pressure +!! level below 100~ mb. the first index refers to temperature +!! in 7.2 degree increments. For instance, jt = 1 refers to a +!! temperature of 188.0, jt = 2 refers to 195.2, etc. the second index +!! runs over the g-channel (1 to NG11=8). + real (kind=kind_phys), public :: ka_mo2(NG11,MMO11) + +!> the array kb_mxx contains the absorption coefficient for +!! a minor species at the NG11=8 chosen g-values for a reference pressure +!! level above 100~ mb. the first index refers to temperature +!! in 7.2 degree increments. for instance, jt = 1 refers to a +!! temperature of 188.0, jt = 2 refers to 195.2, etc. the second index +!! runs over the g-channel (1 to NG11=8). + real (kind=kind_phys), public :: kb_mo2(NG11,MMO11) + + data absa(:, 1:30) / & + & 4.942300E-02,1.387400E-01,3.299931E-01,1.143120E+00,5.377672E+00,& + & 2.053154E+01,5.085043E+01,7.625052E+01,4.893800E-02,1.350700E-01,& + & 3.236575E-01,1.127998E+00,5.297679E+00,2.025259E+01,5.037009E+01,& + & 7.552292E+01,4.823600E-02,1.318800E-01,3.176070E-01,1.112598E+00,& + & 5.217844E+00,1.998801E+01,4.987146E+01,7.498029E+01,4.763000E-02,& + & 1.287500E-01,3.121063E-01,1.097108E+00,5.138663E+00,1.972890E+01,& + & 4.936138E+01,7.471715E+01,4.702700E-02,1.257300E-01,3.071508E-01,& + & 1.081046E+00,5.058441E+00,1.948596E+01,4.887250E+01,7.453654E+01,& + & 4.026400E-02,1.144900E-01,2.745614E-01,9.735121E-01,4.952446E+00,& + & 2.136891E+01,5.805202E+01,9.274922E+01,3.999100E-02,1.114300E-01,& + & 2.692479E-01,9.610352E-01,4.872409E+00,2.109017E+01,5.746478E+01,& + & 9.177544E+01,3.941400E-02,1.088000E-01,2.641928E-01,9.479744E-01,& + & 4.795515E+00,2.081269E+01,5.685579E+01,9.107986E+01,3.892100E-02,& + & 1.062600E-01,2.595909E-01,9.344761E-01,4.718922E+00,2.054546E+01,& + & 5.622782E+01,9.064789E+01,3.845500E-02,1.038400E-01,2.555830E-01,& + & 9.206046E-01,4.641956E+00,2.029741E+01,5.559313E+01,9.029956E+01,& + & 3.276200E-02,9.461000E-02,2.286199E-01,8.243747E-01,4.488628E+00,& + & 2.210450E+01,6.548740E+01,1.127575E+02,3.261200E-02,9.215700E-02,& + & 2.241523E-01,8.139105E-01,4.415360E+00,2.180047E+01,6.480552E+01,& + & 1.115772E+02,3.222500E-02,8.989900E-02,2.198631E-01,8.029491E-01,& + & 4.344786E+00,2.150469E+01,6.408117E+01,1.106549E+02,3.184200E-02,& + & 8.783600E-02,2.160677E-01,7.913655E-01,4.273249E+00,2.122700E+01,& + & 6.332965E+01,1.099620E+02,3.144800E-02,8.581300E-02,2.127875E-01,& + & 7.797791E-01,4.203945E+00,2.095330E+01,6.259995E+01,1.093302E+02,& + & 2.692900E-02,7.892100E-02,1.919723E-01,6.998503E-01,4.037933E+00,& + & 2.254768E+01,7.283490E+01,1.354291E+02,2.682800E-02,7.691700E-02,& + & 1.882064E-01,6.911291E-01,3.973588E+00,2.222859E+01,7.202352E+01,& + & 1.338854E+02,2.663600E-02,7.504200E-02,1.845569E-01,6.819122E-01,& + & 3.908840E+00,2.192424E+01,7.117169E+01,1.326203E+02,2.631100E-02,& + & 7.328300E-02,1.814166E-01,6.721604E-01,3.844133E+00,2.162628E+01,& + & 7.033225E+01,1.316038E+02,2.597900E-02,7.161900E-02,1.785833E-01,& + & 6.624935E-01,3.780931E+00,2.132903E+01,6.953747E+01,1.306939E+02,& + & 2.225400E-02,6.602500E-02,1.616606E-01,5.941449E-01,3.603127E+00,& + & 2.267344E+01,8.005309E+01,1.612722E+02,2.219000E-02,6.439500E-02,& + & 1.585059E-01,5.869299E-01,3.546242E+00,2.235293E+01,7.910704E+01,& + & 1.593277E+02,2.213900E-02,6.278800E-02,1.554699E-01,5.791291E-01,& + & 3.487309E+00,2.204209E+01,7.817793E+01,1.575714E+02,2.184400E-02,& + & 6.140600E-02,1.527321E-01,5.710737E-01,3.429392E+00,2.172637E+01,& + & 7.727395E+01,1.561928E+02,2.160600E-02,5.993800E-02,1.503217E-01,& + & 5.631479E-01,3.370190E+00,2.141490E+01,7.642346E+01,1.549279E+02,& + & 1.842800E-02,5.519800E-02,1.362002E-01,5.035447E-01,3.188796E+00,& + & 2.250928E+01,8.709192E+01,1.910876E+02,1.840600E-02,5.397900E-02,& + & 1.335271E-01,4.977502E-01,3.137298E+00,2.219483E+01,8.605497E+01,& + & 1.885049E+02,1.834600E-02,5.265200E-02,1.310492E-01,4.912634E-01,& + & 3.085199E+00,2.187437E+01,8.504752E+01,1.862862E+02,1.822300E-02,& + & 5.142100E-02,1.286536E-01,4.846251E-01,3.030795E+00,2.155336E+01,& + & 8.409243E+01,1.844721E+02,1.798600E-02,5.029100E-02,1.265559E-01,& + & 4.779712E-01,2.975221E+00,2.124612E+01,8.314091E+01,1.827371E+02/ + data absa(:,31:60) / & + & 1.530200E-02,4.598200E-02,1.146100E-01,4.256950E-01,2.796237E+00,& + & 2.204374E+01,9.394809E+01,2.247672E+02,1.527900E-02,4.514200E-02,& + & 1.123442E-01,4.210774E-01,2.750642E+00,2.173153E+01,9.280295E+01,& + & 2.217406E+02,1.522700E-02,4.414200E-02,1.102489E-01,4.156893E-01,& + & 2.702458E+00,2.141852E+01,9.170076E+01,2.190704E+02,1.517300E-02,& + & 4.304500E-02,1.082705E-01,4.102272E-01,2.652757E+00,2.110241E+01,& + & 9.064025E+01,2.167812E+02,1.500100E-02,4.212100E-02,1.064202E-01,& + & 4.046039E-01,2.603859E+00,2.079769E+01,8.955879E+01,2.146204E+02,& + & 1.291700E-02,3.812800E-02,9.617501E-02,3.591317E-01,2.431206E+00,& + & 2.125707E+01,1.004838E+02,2.629513E+02,1.282100E-02,3.763200E-02,& + & 9.424716E-02,3.553741E-01,2.390128E+00,2.095879E+01,9.921004E+01,& + & 2.595272E+02,1.276200E-02,3.691300E-02,9.251772E-02,3.510862E-01,& + & 2.347090E+00,2.065239E+01,9.801346E+01,2.563958E+02,1.267300E-02,& + & 3.612700E-02,9.082964E-02,3.465234E-01,2.304094E+00,2.033851E+01,& + & 9.685204E+01,2.536311E+02,1.261400E-02,3.520700E-02,8.930145E-02,& + & 3.417559E-01,2.262361E+00,2.002685E+01,9.569739E+01,2.510027E+02,& + & 1.436100E-02,2.998800E-02,7.987509E-02,3.018585E-01,2.098526E+00,& + & 2.019047E+01,1.064899E+02,3.057778E+02,1.335500E-02,3.019900E-02,& + & 7.844686E-02,2.990858E-01,2.062496E+00,1.991057E+01,1.051049E+02,& + & 3.018781E+02,1.283600E-02,2.992400E-02,7.702960E-02,2.956903E-01,& + & 2.025292E+00,1.960328E+01,1.038848E+02,2.981198E+02,1.242400E-02,& + & 2.958800E-02,7.563567E-02,2.919687E-01,1.988848E+00,1.929338E+01,& + & 1.026524E+02,2.947103E+02,1.206900E-02,2.910600E-02,7.435177E-02,& + & 2.881050E-01,1.953693E+00,1.898302E+01,1.014479E+02,2.914216E+02,& + & 1.907800E-02,4.855700E-02,6.037650E-02,2.415769E-01,1.796151E+00,& + & 1.886813E+01,1.117048E+02,3.524637E+02,1.907700E-02,4.497400E-02,& + & 5.830761E-02,2.423034E-01,1.765375E+00,1.859297E+01,1.103698E+02,& + & 3.477313E+02,1.930100E-02,3.758800E-02,5.905263E-02,2.415170E-01,& + & 1.734348E+00,1.829789E+01,1.091192E+02,3.432051E+02,1.949400E-02,& + & 3.150800E-02,5.927635E-02,2.403708E-01,1.703826E+00,1.800339E+01,& + & 1.078035E+02,3.390864E+02,1.960000E-02,2.738100E-02,5.901994E-02,& + & 2.384251E-01,1.673917E+00,1.770484E+01,1.065810E+02,3.349530E+02,& + & 1.665100E-02,4.611300E-02,5.706447E-02,1.910607E-01,1.514442E+00,& + & 1.723705E+01,1.156567E+02,3.998313E+02,1.727900E-02,4.427100E-02,& + & 5.388884E-02,1.916988E-01,1.489506E+00,1.696519E+01,1.143481E+02,& + & 3.944185E+02,1.776200E-02,4.237500E-02,5.011264E-02,1.931375E-01,& + & 1.464307E+00,1.669102E+01,1.129668E+02,3.894830E+02,1.821200E-02,& + & 4.002400E-02,4.722036E-02,1.936487E-01,1.439125E+00,1.641262E+01,& + & 1.116803E+02,3.843859E+02,1.850800E-02,3.766500E-02,4.561696E-02,& + & 1.928425E-01,1.414222E+00,1.613470E+01,1.104917E+02,3.791733E+02,& + & 1.435900E-02,4.030500E-02,4.956426E-02,1.570997E-01,1.271663E+00,& + & 1.551522E+01,1.185117E+02,4.502424E+02,1.491200E-02,3.940800E-02,& + & 4.637296E-02,1.576746E-01,1.251574E+00,1.526930E+01,1.171057E+02,& + & 4.442858E+02,1.537000E-02,3.750400E-02,4.399158E-02,1.578747E-01,& + & 1.230761E+00,1.501982E+01,1.157447E+02,4.382492E+02,1.576600E-02,& + & 3.598100E-02,4.187167E-02,1.575681E-01,1.210098E+00,1.477379E+01,& + & 1.144497E+02,4.320605E+02,1.606800E-02,3.439000E-02,3.934413E-02,& + & 1.581222E-01,1.189463E+00,1.453079E+01,1.130878E+02,4.263680E+02/ + data absa(:,61:65) / & + & 1.219000E-02,3.377900E-02,4.101762E-02,1.308636E-01,1.067890E+00,& + & 1.379683E+01,1.196976E+02,5.045471E+02,1.269300E-02,3.273500E-02,& + & 3.861048E-02,1.311845E-01,1.051003E+00,1.358043E+01,1.182887E+02,& + & 4.975876E+02,1.308600E-02,3.117800E-02,3.655374E-02,1.314821E-01,& + & 1.033718E+00,1.336760E+01,1.169076E+02,4.904446E+02,1.335500E-02,& + & 2.981400E-02,3.473269E-02,1.314856E-01,1.016471E+00,1.315406E+01,& + & 1.155454E+02,4.834361E+02,1.360200E-02,2.827100E-02,3.276496E-02,& + & 1.320551E-01,9.987481E-01,1.294379E+01,1.141594E+02,4.768003E+02/ + +! --- the array absb(NG11,235) = kb(NG11,5,13:59) contains absorption coefs +! at the NG11=8 chosen g-values for a range of pressure levels< ~100mb +! and temperatures. the first index in the array, jt, which runs from +! 1 to 5, corresponds to different temperatures. more specifically, +! jt = 1-5 means that the data are for the corresponding temperature of +! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +! second index, jp, runs from 13 to 59 and refers to the jpth reference +! pressure level (see taumol.f for the value of these pressure levels +! in mb). the third index, ig, goes from 1 to NG11=8, and tells us +! which g-interval the absorption coefficients are for. + + data absb(:, 1: 30) / & + & 1.219000E-02,3.377900E-02,4.101762E-02,1.308636E-01,1.067890E+00,& + & 1.379683E+01,1.196976E+02,5.045471E+02,1.269300E-02,3.273500E-02,& + & 3.861048E-02,1.311845E-01,1.051003E+00,1.358043E+01,1.182887E+02,& + & 4.975876E+02,1.308600E-02,3.117800E-02,3.655374E-02,1.314821E-01,& + & 1.033718E+00,1.336760E+01,1.169076E+02,4.904446E+02,1.335500E-02,& + & 2.981400E-02,3.473269E-02,1.314856E-01,1.016471E+00,1.315406E+01,& + & 1.155454E+02,4.834361E+02,1.360200E-02,2.827100E-02,3.276496E-02,& + & 1.320551E-01,9.987481E-01,1.294379E+01,1.141594E+02,4.768003E+02,& + & 1.063900E-02,2.794500E-02,3.390530E-02,1.099298E-01,8.917844E-01,& + & 1.212427E+01,1.190512E+02,5.612786E+02,1.099100E-02,2.684600E-02,& + & 3.199608E-02,1.103532E-01,8.774905E-01,1.194391E+01,1.177140E+02,& + & 5.528703E+02,1.131500E-02,2.541900E-02,3.040391E-02,1.106609E-01,& + & 8.631354E-01,1.176152E+01,1.164289E+02,5.443647E+02,1.156400E-02,& + & 2.415700E-02,2.850448E-02,1.114033E-01,8.482291E-01,1.157975E+01,& + & 1.150845E+02,5.363040E+02,1.151800E-02,2.281400E-02,2.727111E-02,& + & 1.118110E-01,8.329776E-01,1.138779E+01,1.137631E+02,5.287232E+02,& + & 9.434300E-03,2.274800E-02,2.795123E-02,9.531157E-02,7.386687E-01,& + & 1.056070E+01,1.168595E+02,6.196087E+02,9.667600E-03,2.152100E-02,& + & 2.630226E-02,9.616968E-02,7.267447E-01,1.040946E+01,1.157268E+02,& + & 6.093507E+02,9.593800E-03,2.057100E-02,2.456898E-02,9.719866E-02,& + & 7.142012E-01,1.025500E+01,1.144975E+02,5.997160E+02,9.553000E-03,& + & 1.955900E-02,2.352315E-02,9.738663E-02,7.019495E-01,1.008837E+01,& + & 1.132253E+02,5.907797E+02,9.489000E-03,1.804700E-02,2.293218E-02,& + & 9.757065E-02,6.892775E-01,9.918969E+00,1.119357E+02,5.823122E+02,& + & 7.968100E-03,1.833700E-02,2.278163E-02,8.227433E-02,6.121769E-01,& + & 9.126874E+00,1.133804E+02,6.782823E+02,7.841900E-03,1.758700E-02,& + & 2.109997E-02,8.360358E-02,6.017364E-01,8.999255E+00,1.123460E+02,& + & 6.668793E+02,7.816200E-03,1.675000E-02,2.014329E-02,8.391034E-02,& + & 5.916288E-01,8.858976E+00,1.111742E+02,6.564353E+02,7.749200E-03,& + & 1.570500E-02,1.952988E-02,8.413267E-02,5.808006E-01,8.710910E+00,& + & 1.099911E+02,6.465064E+02,7.765200E-03,1.325900E-02,1.967693E-02,& + & 8.436749E-02,5.700691E-01,8.557347E+00,1.088196E+02,6.369960E+02,& + & 6.406800E-03,1.503400E-02,1.819536E-02,7.149926E-02,5.077255E-01,& + & 7.831171E+00,1.085463E+02,7.378790E+02,6.353900E-03,1.434300E-02,& + & 1.727994E-02,7.211399E-02,4.988822E-01,7.716873E+00,1.075550E+02,& + & 7.257573E+02,6.326500E-03,1.373600E-02,1.653697E-02,7.252035E-02,& + & 4.897192E-01,7.590053E+00,1.065368E+02,7.142406E+02,6.329400E-03,& + & 1.154100E-02,1.674336E-02,7.283629E-02,4.802479E-01,7.459484E+00,& + & 1.055108E+02,7.031326E+02,6.229200E-03,9.740000E-03,1.710865E-02,& + & 7.277209E-02,4.712388E-01,7.331638E+00,1.044590E+02,6.923210E+02,& + & 5.142000E-03,1.216400E-02,1.477778E-02,6.186492E-02,4.269554E-01,& + & 6.655741E+00,1.025220E+02,7.979265E+02,5.133500E-03,1.182800E-02,& + & 1.398079E-02,6.244623E-02,4.192300E-01,6.550392E+00,1.017045E+02,& + & 7.847428E+02,5.078000E-03,9.999800E-03,1.419573E-02,6.273356E-02,& + & 4.113424E-01,6.442036E+00,1.008249E+02,7.720692E+02,5.040800E-03,& + & 8.291100E-03,1.457554E-02,6.272110E-02,4.035572E-01,6.335490E+00,& + & 9.993997E+01,7.596023E+02,5.022300E-03,6.977400E-03,1.482692E-02,& + & 6.258739E-02,3.961688E-01,6.235228E+00,9.906305E+01,7.473102E+02/ + data absb(:, 31: 60) / & + & 4.173900E-03,1.005300E-02,1.201656E-02,5.386328E-02,3.655703E-01,& + & 5.597896E+00,9.571190E+01,8.570634E+02,4.140400E-03,8.776000E-03,& + & 1.195515E-02,5.430982E-02,3.590286E-01,5.509736E+00,9.500626E+01,& + & 8.428721E+02,4.103200E-03,7.294400E-03,1.227227E-02,5.436624E-02,& + & 3.524935E-01,5.422345E+00,9.429452E+01,8.288477E+02,4.090800E-03,& + & 6.029100E-03,1.256137E-02,5.432946E-02,3.460577E-01,5.339599E+00,& + & 9.364858E+01,8.146756E+02,4.056200E-03,5.218800E-03,1.265100E-02,& + & 5.418512E-02,3.402378E-01,5.261972E+00,9.299725E+01,8.007339E+02,& + & 3.388700E-03,8.099600E-03,9.839894E-03,4.646657E-02,3.128566E-01,& + & 4.689899E+00,8.825090E+01,9.145009E+02,3.366800E-03,6.662800E-03,& + & 1.013756E-02,4.668998E-02,3.074024E-01,4.619787E+00,8.777127E+01,& + & 8.988037E+02,3.348100E-03,5.474400E-03,1.041913E-02,4.673032E-02,& + & 3.019805E-01,4.552256E+00,8.738633E+01,8.827441E+02,3.335900E-03,& + & 4.547400E-03,1.061921E-02,4.670046E-02,2.968176E-01,4.487837E+00,& + & 8.699629E+01,8.669047E+02,3.294800E-03,4.034300E-03,1.061609E-02,& + & 4.661557E-02,2.924243E-01,4.426159E+00,8.663561E+01,8.512191E+02,& + & 2.758000E-03,6.168500E-03,8.315802E-03,3.963070E-02,2.668218E-01,& + & 3.924547E+00,8.059920E+01,9.687468E+02,2.755100E-03,5.045500E-03,& + & 8.563299E-03,3.978923E-02,2.624515E-01,3.869960E+00,8.045309E+01,& + & 9.511021E+02,2.735600E-03,4.127800E-03,8.785050E-03,3.988151E-02,& + & 2.581955E-01,3.816383E+00,8.035312E+01,9.333585E+02,2.709200E-03,& + & 3.553700E-03,8.868446E-03,3.991588E-02,2.542393E-01,3.766184E+00,& + & 8.028094E+01,9.157690E+02,2.684100E-03,3.146100E-03,8.864932E-03,& + & 3.987368E-02,2.510511E-01,3.718343E+00,8.026287E+01,8.981543E+02,& + & 2.255800E-03,4.668000E-03,6.987740E-03,3.354070E-02,2.273593E-01,& + & 3.279013E+00,7.313047E+01,1.017445E+03,2.243500E-03,3.789400E-03,& + & 7.206077E-03,3.369423E-02,2.238790E-01,3.236276E+00,7.330674E+01,& + & 9.980045E+02,2.223500E-03,3.134700E-03,7.363238E-03,3.382325E-02,& + & 2.205889E-01,3.195198E+00,7.353477E+01,9.785081E+02,2.204100E-03,& + & 2.760200E-03,7.371897E-03,3.382940E-02,2.180518E-01,3.156171E+00,& + & 7.381081E+01,9.590122E+02,2.187000E-03,2.453800E-03,7.372385E-03,& + & 3.372964E-02,2.157863E-01,3.119959E+00,7.415140E+01,9.395651E+02,& + & 1.842600E-03,3.510500E-03,5.874242E-03,2.832866E-02,1.938673E-01,& + & 2.738091E+00,6.612921E+01,1.060871E+03,1.832400E-03,2.843000E-03,& + & 6.046280E-03,2.849186E-02,1.913739E-01,2.705075E+00,6.664705E+01,& + & 1.039639E+03,1.808800E-03,2.431100E-03,6.117093E-03,2.852863E-02,& + & 1.891410E-01,2.673964E+00,6.721547E+01,1.018403E+03,1.797500E-03,& + & 2.144200E-03,6.129536E-03,2.845956E-02,1.874560E-01,2.644658E+00,& + & 6.784268E+01,9.971188E+02,1.788200E-03,1.911600E-03,6.120240E-03,& + & 2.831828E-02,1.859943E-01,2.617243E+00,6.854994E+01,9.757974E+02,& + & 1.509100E-03,2.639400E-03,4.938552E-03,2.391581E-02,1.664432E-01,& + & 2.284216E+00,5.977096E+01,1.098685E+03,1.491400E-03,2.185200E-03,& + & 5.055682E-03,2.398354E-02,1.645559E-01,2.261255E+00,6.059988E+01,& + & 1.075826E+03,1.477000E-03,1.896000E-03,5.083721E-03,2.395436E-02,& + & 1.632409E-01,2.237117E+00,6.150249E+01,1.052888E+03,1.469800E-03,& + & 1.670200E-03,5.095761E-03,2.385206E-02,1.622292E-01,2.214325E+00,& + & 6.250461E+01,1.029774E+03,1.467500E-03,1.499300E-03,5.080364E-03,& + & 2.371244E-02,1.613821E-01,2.196026E+00,6.352733E+01,1.006906E+03/ + data absb(:, 61: 90) / & + & 1.236100E-03,2.004100E-03,4.133232E-03,2.007442E-02,1.429851E-01,& + & 1.908722E+00,5.412364E+01,1.130875E+03,1.217000E-03,1.692000E-03,& + & 4.201562E-03,2.007334E-02,1.419781E-01,1.890726E+00,5.525980E+01,& + & 1.106497E+03,1.206800E-03,1.478400E-03,4.221789E-03,2.000540E-02,& + & 1.413442E-01,1.872037E+00,5.651207E+01,1.081878E+03,1.205900E-03,& + & 1.310700E-03,4.220048E-03,1.990699E-02,1.407332E-01,1.856694E+00,& + & 5.780609E+01,1.057328E+03,1.205400E-03,1.188300E-03,4.204933E-03,& + & 1.978585E-02,1.402912E-01,1.845842E+00,5.909933E+01,1.033152E+03,& + & 1.005000E-03,1.541400E-03,3.443258E-03,1.674170E-02,1.232621E-01,& + & 1.604488E+00,4.919383E+01,1.157364E+03,9.942400E-04,1.318900E-03,& + & 3.481406E-03,1.671073E-02,1.228126E-01,1.586449E+00,5.066255E+01,& + & 1.131526E+03,9.892100E-04,1.156400E-03,3.496234E-03,1.664525E-02,& + & 1.223924E-01,1.572380E+00,5.219970E+01,1.105627E+03,9.895000E-04,& + & 1.033300E-03,3.489098E-03,1.656745E-02,1.221163E-01,1.563034E+00,& + & 5.374815E+01,1.079849E+03,9.910200E-04,9.471000E-04,3.473693E-03,& + & 1.646411E-02,1.220517E-01,1.556396E+00,5.530107E+01,1.054464E+03,& + & 8.192400E-04,1.202500E-03,2.847964E-03,1.386873E-02,1.059018E-01,& + & 1.377848E+00,4.485980E+01,1.179110E+03,8.118100E-04,1.038100E-03,& + & 2.873239E-03,1.383812E-02,1.057484E-01,1.356372E+00,4.665733E+01,& + & 1.151947E+03,8.111100E-04,9.142300E-04,2.878631E-03,1.378245E-02,& + & 1.056622E-01,1.339433E+00,4.847266E+01,1.124850E+03,8.114800E-04,& + & 8.199600E-04,2.874484E-03,1.372122E-02,1.057966E-01,1.327084E+00,& + & 5.029742E+01,1.098023E+03,8.105700E-04,7.632300E-04,2.860478E-03,& + & 1.364526E-02,1.058761E-01,1.323852E+00,5.210278E+01,1.071487E+03,& + & 6.688100E-04,9.448100E-04,2.344241E-03,1.144548E-02,9.060434E-02,& + & 1.190464E+00,4.125707E+01,1.196441E+03,6.639800E-04,8.231400E-04,& + & 2.360667E-03,1.141575E-02,9.080182E-02,1.173397E+00,4.327358E+01,& + & 1.168169E+03,6.647300E-04,7.260100E-04,2.365016E-03,1.138336E-02,& + & 9.104992E-02,1.157638E+00,4.532776E+01,1.140023E+03,6.653600E-04,& + & 6.568000E-04,2.360130E-03,1.133516E-02,9.135216E-02,1.146695E+00,& + & 4.740366E+01,1.112204E+03,6.605700E-04,6.210500E-04,2.350222E-03,& + & 1.127553E-02,9.171136E-02,1.141030E+00,4.946417E+01,1.084722E+03,& + & 5.445200E-04,7.429100E-04,1.917711E-03,9.372427E-03,7.681385E-02,& + & 1.024579E+00,3.837538E+01,1.209684E+03,5.418100E-04,6.513800E-04,& + & 1.928942E-03,9.354266E-03,7.719634E-02,1.010713E+00,4.060261E+01,& + & 1.180461E+03,5.425400E-04,5.796800E-04,1.930677E-03,9.333776E-03,& + & 7.770662E-02,9.992755E-01,4.287491E+01,1.151357E+03,5.434200E-04,& + & 5.291400E-04,1.927040E-03,9.296112E-03,7.806826E-02,9.922756E-01,& + & 4.515277E+01,1.122547E+03,5.355100E-04,5.050800E-04,1.923345E-03,& + & 9.254502E-03,7.868556E-02,9.887137E-01,4.741770E+01,1.094137E+03,& + & 4.425900E-04,5.879600E-04,1.563481E-03,7.660402E-03,6.484793E-02,& + & 8.805741E-01,3.609697E+01,1.219466E+03,4.414000E-04,5.184100E-04,& + & 1.571444E-03,7.649436E-03,6.541873E-02,8.707404E-01,3.852078E+01,& + & 1.189375E+03,4.420700E-04,4.616100E-04,1.573405E-03,7.638918E-03,& + & 6.593060E-02,8.634102E-01,4.099113E+01,1.159386E+03,4.432600E-04,& + & 4.252100E-04,1.572335E-03,7.614616E-03,6.656755E-02,8.590993E-01,& + & 4.344692E+01,1.129811E+03,4.287400E-04,4.167100E-04,1.570488E-03,& + & 7.586013E-03,6.724173E-02,8.601701E-01,4.587576E+01,1.100719E+03/ + data absb(:, 91:120) / & + & 3.589900E-04,4.633400E-04,1.270531E-03,6.231160E-03,5.433721E-02,& + & 7.512834E-01,3.440266E+01,1.226107E+03,3.582600E-04,4.119800E-04,& + & 1.275068E-03,6.230153E-03,5.491369E-02,7.455331E-01,3.701058E+01,& + & 1.195135E+03,3.591100E-04,3.682800E-04,1.277265E-03,6.226487E-03,& + & 5.547190E-02,7.432621E-01,3.962735E+01,1.164514E+03,3.598400E-04,& + & 3.426700E-04,1.277851E-03,6.214474E-03,5.614443E-02,7.429270E-01,& + & 4.223054E+01,1.134275E+03,3.429800E-04,3.432200E-04,1.277495E-03,& + & 6.202885E-03,5.681512E-02,7.470451E-01,4.481021E+01,1.104537E+03,& + & 2.913800E-04,3.668300E-04,1.031911E-03,5.078744E-03,4.554810E-02,& + & 6.428464E-01,3.316511E+01,1.229957E+03,2.910400E-04,3.271800E-04,& + & 1.035713E-03,5.084550E-03,4.611127E-02,6.409011E-01,3.592316E+01,& + & 1.198337E+03,2.917800E-04,2.959800E-04,1.037731E-03,5.084152E-03,& + & 4.670416E-02,6.405532E-01,3.868367E+01,1.167081E+03,2.923700E-04,& + & 2.774300E-04,1.039472E-03,5.082400E-03,4.734264E-02,6.451912E-01,& + & 4.141197E+01,1.136322E+03,2.752200E-04,2.810600E-04,1.040626E-03,& + & 5.085761E-03,4.800942E-02,6.537662E-01,4.408807E+01,1.106183E+03,& + & 2.367400E-04,2.922000E-04,8.368488E-04,4.142374E-03,3.814323E-02,& + & 5.507144E-01,3.232057E+01,1.231511E+03,2.366700E-04,2.610400E-04,& + & 8.408782E-04,4.150950E-03,3.871096E-02,5.511763E-01,3.521147E+01,& + & 1.199378E+03,2.370800E-04,2.391200E-04,8.436365E-04,4.157339E-03,& + & 3.926769E-02,5.546214E-01,3.808463E+01,1.167550E+03,2.374900E-04,& + & 2.252900E-04,8.460591E-04,4.165852E-03,3.983657E-02,5.631455E-01,& + & 4.090925E+01,1.136453E+03,2.211600E-04,2.303200E-04,8.486526E-04,& + & 4.177785E-03,4.042949E-02,5.768215E-01,4.365772E+01,1.106020E+03,& + & 1.929300E-04,2.349400E-04,6.814941E-04,3.395477E-03,3.220355E-02,& + & 4.761343E-01,3.168453E+01,1.232253E+03,1.929500E-04,2.111400E-04,& + & 6.853445E-04,3.408607E-03,3.276044E-02,4.788069E-01,3.467993E+01,& + & 1.199653E+03,1.930700E-04,1.945800E-04,6.887917E-04,3.419696E-03,& + & 3.328439E-02,4.853135E-01,3.764986E+01,1.167514E+03,1.935300E-04,& + & 1.833600E-04,6.912553E-04,3.434345E-03,3.383671E-02,4.956963E-01,& + & 4.055338E+01,1.136059E+03,1.794400E-04,1.884900E-04,6.947444E-04,& + & 3.452460E-03,3.439499E-02,5.135088E-01,4.335896E+01,1.105382E+03,& + & 1.574100E-04,1.911700E-04,5.551502E-04,2.789025E-03,2.721725E-02,& + & 4.125216E-01,3.102541E+01,1.234646E+03,1.573700E-04,1.722000E-04,& + & 5.593014E-04,2.804427E-03,2.774207E-02,4.174790E-01,3.410919E+01,& + & 1.201639E+03,1.573500E-04,1.596900E-04,5.624788E-04,2.819532E-03,& + & 2.822883E-02,4.261118E-01,3.715342E+01,1.169227E+03,1.577800E-04,& + & 1.501300E-04,5.653176E-04,2.837353E-03,2.873963E-02,4.393089E-01,& + & 4.012307E+01,1.137462E+03,1.471300E-04,1.535900E-04,5.692041E-04,& + & 2.858425E-03,2.924397E-02,4.591334E-01,4.298313E+01,1.106612E+03,& + & 1.287200E-04,1.574700E-04,4.525719E-04,2.294588E-03,2.301851E-02,& + & 3.589322E-01,3.022563E+01,1.239442E+03,1.283300E-04,1.422100E-04,& + & 4.565340E-04,2.311076E-03,2.350671E-02,3.652366E-01,3.337967E+01,& + & 1.206143E+03,1.285600E-04,1.317100E-04,4.594083E-04,2.329175E-03,& + & 2.395915E-02,3.753921E-01,3.649789E+01,1.173294E+03,1.288600E-04,& + & 1.237000E-04,4.623624E-04,2.347677E-03,2.444476E-02,3.902339E-01,& + & 3.952715E+01,1.141315E+03,1.214700E-04,1.245900E-04,4.663952E-04,& + & 2.370420E-03,2.490819E-02,4.107520E-01,4.244441E+01,1.110161E+03/ + data absb(:,121:150) / & + & 1.057300E-04,1.325000E-04,3.694345E-04,1.894509E-03,1.955929E-02,& + & 3.135904E-01,2.908399E+01,1.248455E+03,1.052100E-04,1.191000E-04,& + & 3.737934E-04,1.911636E-03,2.002417E-02,3.207893E-01,3.230581E+01,& + & 1.214767E+03,1.053200E-04,1.096800E-04,3.769687E-04,1.929051E-03,& + & 2.046622E-02,3.308817E-01,3.549262E+01,1.181544E+03,1.055200E-04,& + & 1.029600E-04,3.799569E-04,1.949318E-03,2.091546E-02,3.456408E-01,& + & 3.859008E+01,1.149172E+03,1.015300E-04,1.013000E-04,3.839104E-04,& + & 1.971637E-03,2.137359E-02,3.657515E-01,4.157456E+01,1.117690E+03,& + & 8.691200E-05,1.116000E-04,3.015616E-04,1.564623E-03,1.657370E-02,& + & 2.736897E-01,2.803623E+01,1.257074E+03,8.629400E-05,9.971500E-05,& + & 3.061761E-04,1.580943E-03,1.700336E-02,2.815853E-01,3.131559E+01,& + & 1.223018E+03,8.627800E-05,9.166500E-05,3.092367E-04,1.598356E-03,& + & 1.744165E-02,2.918844E-01,3.455967E+01,1.189493E+03,8.639300E-05,& + & 8.573000E-05,3.122167E-04,1.618054E-03,1.785204E-02,3.070662E-01,& + & 3.771609E+01,1.156768E+03,8.566300E-05,8.193300E-05,3.158260E-04,& + & 1.640006E-03,1.828508E-02,3.271461E-01,4.076100E+01,1.124934E+03,& + & 7.147600E-05,9.413500E-05,2.460203E-04,1.290927E-03,1.400438E-02,& + & 2.386493E-01,2.709234E+01,1.264962E+03,7.079700E-05,8.397400E-05,& + & 2.503520E-04,1.307133E-03,1.439347E-02,2.467888E-01,3.042065E+01,& + & 1.228651E+03,7.069300E-05,7.678300E-05,2.533911E-04,1.324343E-03,& + & 1.478552E-02,2.575912E-01,3.371275E+01,1.195064E+03,7.070600E-05,& + & 7.171800E-05,2.563270E-04,1.343170E-03,1.516954E-02,2.738267E-01,& + & 3.691880E+01,1.163852E+03,7.075200E-05,6.751700E-05,2.597278E-04,& + & 1.364352E-03,1.556472E-02,2.939947E-01,4.001355E+01,1.131724E+03,& + & 5.877800E-05,8.099700E-05,2.012544E-04,1.069026E-03,1.194589E-02,& + & 2.099183E-01,2.587354E+01,1.276024E+03,5.837500E-05,7.228800E-05,& + & 2.049568E-04,1.084732E-03,1.233809E-02,2.177847E-01,2.924013E+01,& + & 1.241454E+03,5.814900E-05,6.523500E-05,2.083239E-04,1.100843E-03,& + & 1.273074E-02,2.278766E-01,3.258271E+01,1.207342E+03,5.812000E-05,& + & 6.049100E-05,2.113860E-04,1.118808E-03,1.310647E-02,2.428680E-01,& + & 3.585034E+01,1.173897E+03,5.803800E-05,5.697000E-05,2.146473E-04,& + & 1.139031E-03,1.348065E-02,2.625556E-01,3.900116E+01,1.141438E+03,& + & 4.820800E-05,7.043600E-05,1.644749E-04,8.850431E-04,1.019914E-02,& + & 1.850212E-01,2.467272E+01,1.287124E+03,4.829100E-05,6.209700E-05,& + & 1.677305E-04,9.002645E-04,1.058130E-02,1.925316E-01,2.807066E+01,& + & 1.252298E+03,4.793900E-05,5.543100E-05,1.713341E-04,9.153613E-04,& + & 1.096363E-02,2.020038E-01,3.145450E+01,1.217879E+03,4.783900E-05,& + & 5.112300E-05,1.743331E-04,9.323850E-04,1.134023E-02,2.157483E-01,& + & 3.477314E+01,1.184175E+03,4.771700E-05,4.805400E-05,1.773237E-04,& + & 9.515602E-04,1.170173E-02,2.347118E-01,3.798149E+01,1.151311E+03,& + & 3.973500E-05,6.165500E-05,1.338527E-04,7.326861E-04,8.689735E-03,& + & 1.630003E-01,2.352615E+01,1.297948E+03,3.979400E-05,5.336700E-05,& + & 1.373666E-04,7.466654E-04,9.056679E-03,1.702598E-01,2.694529E+01,& + & 1.262934E+03,3.958800E-05,4.754800E-05,1.406029E-04,7.610448E-04,& + & 9.416014E-03,1.794659E-01,3.036298E+01,1.228274E+03,3.941400E-05,& + & 4.341600E-05,1.434984E-04,7.772289E-04,9.775439E-03,1.920372E-01,& + & 3.372744E+01,1.194201E+03,3.927500E-05,4.055200E-05,1.463303E-04,& + & 7.948840E-04,1.012134E-02,2.103433E-01,3.698616E+01,1.160986E+03/ + data absb(:,151:180) / & + & 3.306900E-05,5.527200E-05,1.082288E-04,6.061264E-04,7.394422E-03,& + & 1.435196E-01,2.222894E+01,1.310419E+03,3.275000E-05,4.683200E-05,& + & 1.121634E-04,6.191602E-04,7.742205E-03,1.504066E-01,2.566038E+01,& + & 1.275302E+03,3.289800E-05,4.154900E-05,1.150438E-04,6.324026E-04,& + & 8.078799E-03,1.589826E-01,2.910784E+01,1.240415E+03,3.264600E-05,& + & 3.714300E-05,1.179665E-04,6.477201E-04,8.425128E-03,1.704736E-01,& + & 3.251130E+01,1.206088E+03,3.243400E-05,3.456300E-05,1.205141E-04,& + & 6.642099E-04,8.760797E-03,1.878017E-01,3.582858E+01,1.172490E+03,& + & 2.716000E-05,5.035000E-05,8.729736E-05,5.006263E-04,6.281806E-03,& + & 1.260541E-01,2.089343E+01,1.323568E+03,2.726300E-05,4.191100E-05,& + & 9.102516E-05,5.129103E-04,6.600778E-03,1.324867E-01,2.432107E+01,& + & 1.288392E+03,2.712000E-05,3.657300E-05,9.396101E-05,5.254422E-04,& + & 6.923850E-03,1.408524E-01,2.779048E+01,1.253278E+03,2.716500E-05,& + & 3.255300E-05,9.655689E-05,5.393820E-04,7.239786E-03,1.511240E-01,& + & 3.123295E+01,1.218655E+03,2.687400E-05,2.962100E-05,9.915237E-05,& + & 5.545959E-04,7.558174E-03,1.674691E-01,3.459766E+01,1.184705E+03,& + & 2.228500E-05,4.668000E-05,6.990000E-05,4.129537E-04,5.314245E-03,& + & 1.102582E-01,1.959986E+01,1.336493E+03,2.256500E-05,3.806200E-05,& + & 7.341045E-05,4.247418E-04,5.610925E-03,1.164376E-01,2.301410E+01,& + & 1.301290E+03,2.250800E-05,3.214900E-05,7.653440E-05,4.364041E-04,& + & 5.905265E-03,1.243845E-01,2.649373E+01,1.266054E+03,2.245600E-05,& + & 2.870300E-05,7.889457E-05,4.489606E-04,6.196484E-03,1.341447E-01,& + & 2.996461E+01,1.231146E+03,2.235700E-05,2.569400E-05,8.125956E-05,& + & 4.632783E-04,6.488095E-03,1.495252E-01,3.336334E+01,1.196902E+03,& + & 1.846800E-05,4.276900E-05,5.594887E-05,3.404017E-04,4.478054E-03,& + & 9.617640E-02,1.826851E+01,1.350075E+03,1.852900E-05,3.569800E-05,& + & 5.867071E-05,3.512631E-04,4.748271E-03,1.021036E-01,2.165812E+01,& + & 1.314874E+03,1.874400E-05,2.913900E-05,6.194019E-05,3.620154E-04,& + & 5.020698E-03,1.095225E-01,2.513421E+01,1.279528E+03,1.864000E-05,& + & 2.519900E-05,6.445045E-05,3.734420E-04,5.289504E-03,1.188511E-01,& + & 2.862673E+01,1.244344E+03,1.858400E-05,2.263800E-05,6.639885E-05,& + & 3.868459E-04,5.559907E-03,1.332417E-01,3.206291E+01,1.209851E+03,& + & 1.526700E-05,3.647700E-05,4.640474E-05,2.796747E-04,3.765165E-03,& + & 8.405947E-02,1.682981E+01,1.364880E+03,1.537300E-05,3.282200E-05,& + & 4.703441E-05,2.900596E-04,4.013981E-03,8.952737E-02,2.018235E+01,& + & 1.329801E+03,1.538900E-05,2.746700E-05,4.955101E-05,3.000864E-04,& + & 4.266488E-03,9.639717E-02,2.364272E+01,1.294389E+03,1.559000E-05,& + & 2.273000E-05,5.215698E-05,3.104846E-04,4.516472E-03,1.049943E-01,& + & 2.714886E+01,1.259063E+03,1.541700E-05,2.007500E-05,5.418435E-05,& + & 3.223986E-04,4.770698E-03,1.180628E-01,3.061839E+01,1.224203E+03,& + & 1.257600E-05,3.060900E-05,3.925226E-05,2.287254E-04,3.146121E-03,& + & 7.277502E-02,1.543475E+01,1.379420E+03,1.276500E-05,2.983200E-05,& + & 3.786893E-05,2.388093E-04,3.373652E-03,7.802409E-02,1.873730E+01,& + & 1.344588E+03,1.277100E-05,2.564100E-05,3.954198E-05,2.480868E-04,& + & 3.601126E-03,8.444492E-02,2.216984E+01,1.309220E+03,1.282800E-05,& + & 2.124600E-05,4.188653E-05,2.577063E-04,3.832117E-03,9.249168E-02,& + & 2.567724E+01,1.273821E+03,1.295300E-05,1.792700E-05,4.399054E-05,& + & 2.685972E-04,4.068441E-03,1.045844E-01,2.917308E+01,1.238676E+03/ + data absb(:,181:210) / & + & 1.052600E-05,2.589200E-05,3.315752E-05,1.863847E-04,2.602490E-03,& + & 6.245250E-02,1.408344E+01,1.393827E+03,1.050300E-05,2.497600E-05,& + & 3.172527E-05,1.959274E-04,2.805675E-03,6.736886E-02,1.732802E+01,& + & 1.359150E+03,1.064100E-05,2.381900E-05,3.148697E-05,2.045922E-04,& + & 3.011911E-03,7.335811E-02,2.072430E+01,1.323951E+03,1.064500E-05,& + & 2.017800E-05,3.328611E-05,2.134277E-04,3.220642E-03,8.103338E-02,& + & 2.421299E+01,1.288496E+03,1.067100E-05,1.671900E-05,3.534206E-05,& + & 2.234821E-04,3.429814E-03,9.259270E-02,2.772048E+01,1.253136E+03,& + & 8.514600E-06,2.206800E-05,2.812462E-05,1.518915E-04,2.170526E-03,& + & 5.426036E-02,1.284858E+01,1.407105E+03,8.828600E-06,2.089700E-05,& + & 2.691304E-05,1.603655E-04,2.351361E-03,5.892305E-02,1.602553E+01,& + & 1.372734E+03,8.787900E-06,2.044500E-05,2.596424E-05,1.687061E-04,& + & 2.540685E-03,6.434796E-02,1.938020E+01,1.337677E+03,8.887000E-06,& + & 1.840100E-05,2.672867E-05,1.769079E-04,2.732040E-03,7.164291E-02,& + & 2.284507E+01,1.302211E+03,8.851500E-06,1.564800E-05,2.831290E-05,& + & 1.860537E-04,2.926733E-03,8.225825E-02,2.635963E+01,1.266779E+03,& + & 6.855100E-06,1.889400E-05,2.423828E-05,1.232904E-04,1.812540E-03,& + & 4.742596E-02,1.168789E+01,1.419770E+03,7.171400E-06,1.806000E-05,& + & 2.264245E-05,1.312641E-04,1.977674E-03,5.171292E-02,1.479211E+01,& + & 1.385821E+03,7.426200E-06,1.704700E-05,2.175142E-05,1.389701E-04,& + & 2.151276E-03,5.676422E-02,1.809389E+01,1.350922E+03,7.356800E-06,& + & 1.680900E-05,2.147509E-05,1.465048E-04,2.326703E-03,6.339379E-02,& + & 2.153111E+01,1.315521E+03,7.403900E-06,1.442600E-05,2.268719E-05,& + & 1.549516E-04,2.506817E-03,7.323471E-02,2.503985E+01,1.279953E+03,& + & 5.511100E-06,1.613100E-05,2.101702E-05,9.964124E-05,1.506581E-03,& + & 4.122136E-02,1.057822E+01,1.432183E+03,5.785400E-06,1.534500E-05,& + & 1.925469E-05,1.070876E-04,1.654983E-03,4.524690E-02,1.359426E+01,& + & 1.398632E+03,6.043100E-06,1.461300E-05,1.846673E-05,1.137891E-04,& + & 1.810349E-03,4.995448E-02,1.683772E+01,1.363985E+03,6.223000E-06,& + & 1.396100E-05,1.794164E-05,1.209694E-04,1.970741E-03,5.594049E-02,& + & 2.023669E+01,1.328730E+03,6.147300E-06,1.339800E-05,1.809640E-05,& + & 1.286373E-04,2.134839E-03,6.515142E-02,2.372611E+01,1.293215E+03,& + & 4.438200E-06,1.372700E-05,1.803057E-05,8.044998E-05,1.242276E-03,& + & 3.562013E-02,9.520642E+00,1.444264E+03,4.655900E-06,1.322200E-05,& + & 1.677953E-05,8.647492E-05,1.373324E-03,3.930396E-02,1.242853E+01,& + & 1.411298E+03,4.871800E-06,1.261900E-05,1.562193E-05,9.294320E-05,& + & 1.511261E-03,4.361201E-02,1.560473E+01,1.377000E+03,5.081500E-06,& + & 1.190600E-05,1.505977E-05,9.942624E-05,1.653848E-03,4.924667E-02,& + & 1.895796E+01,1.341764E+03,5.194100E-06,1.146700E-05,1.489660E-05,& + & 1.064418E-04,1.802530E-03,5.795345E-02,2.242000E+01,1.306387E+03,& + & 3.617700E-06,1.164400E-05,1.517638E-05,6.566439E-05,1.047057E-03,& + & 3.177413E-02,8.590291E+00,1.455065E+03,3.793500E-06,1.120300E-05,& + & 1.447727E-05,7.036875E-05,1.167568E-03,3.524189E-02,1.138679E+01,& + & 1.422754E+03,3.961300E-06,1.077900E-05,1.335690E-05,7.612838E-05,& + & 1.296023E-03,3.924976E-02,1.449010E+01,1.388804E+03,4.134200E-06,& + & 1.037300E-05,1.275977E-05,8.184007E-05,1.432183E-03,4.437728E-02,& + & 1.779464E+01,1.353945E+03,4.293600E-06,9.709000E-06,1.242986E-05,& + & 8.844623E-05,1.570843E-03,5.202136E-02,2.123085E+01,1.318497E+03/ + data absb(:,211:235) / & + & 2.933600E-06,9.960600E-06,1.292572E-05,5.346698E-05,8.940451E-04,& + & 2.895152E-02,7.739085E+00,1.465296E+03,3.100400E-06,9.544000E-06,& + & 1.244875E-05,5.743734E-05,1.005520E-03,3.223846E-02,1.042055E+01,& + & 1.433491E+03,3.242000E-06,9.221600E-06,1.166597E-05,6.216169E-05,& + & 1.129282E-03,3.623989E-02,1.344255E+01,1.399914E+03,3.384600E-06,& + & 8.782200E-06,1.092362E-05,6.754671E-05,1.261309E-03,4.101770E-02,& + & 1.669071E+01,1.365289E+03,3.519400E-06,8.319800E-06,1.047532E-05,& + & 7.346819E-05,1.397287E-03,4.728806E-02,2.009702E+01,1.329966E+03,& + & 2.377700E-06,8.451700E-06,1.130115E-05,4.320393E-05,7.626655E-04,& + & 2.632492E-02,6.936736E+00,1.475003E+03,2.539300E-06,8.169600E-06,& + & 1.045283E-05,4.704793E-05,8.662955E-04,2.974280E-02,9.497379E+00,& + & 1.443948E+03,2.655900E-06,7.837300E-06,1.001859E-05,5.087429E-05,& + & 9.827935E-04,3.365674E-02,1.242171E+01,1.410978E+03,2.773700E-06,& + & 7.509400E-06,9.380954E-06,5.559927E-05,1.106879E-03,3.808398E-02,& + & 1.561090E+01,1.376588E+03,2.881900E-06,7.226600E-06,9.006176E-06,& + & 6.071395E-05,1.240762E-03,4.397364E-02,1.897404E+01,1.341528E+03,& + & 1.925800E-06,7.163400E-06,1.023763E-05,3.436636E-05,6.480790E-04,& + & 2.409193E-02,6.182909E+00,1.484567E+03,2.063500E-06,7.098500E-06,& + & 8.884291E-06,3.828380E-05,7.461716E-04,2.746064E-02,8.614455E+00,& + & 1.454319E+03,2.187500E-06,6.729600E-06,8.628184E-06,4.149692E-05,& + & 8.547821E-04,3.137056E-02,1.142889E+01,1.421893E+03,2.277200E-06,& + & 6.479400E-06,8.216074E-06,4.545959E-05,9.724554E-04,3.579791E-02,& + & 1.454789E+01,1.387867E+03,2.368400E-06,6.164700E-06,7.682973E-06,& + & 5.025578E-05,1.102872E-03,4.124500E-02,1.786420E+01,1.352917E+03,& + & 1.565800E-06,6.228600E-06,9.527658E-06,2.682100E-05,5.537255E-04,& + & 2.242411E-02,5.512557E+00,1.493211E+03,1.681300E-06,5.971300E-06,& + & 7.833803E-06,3.095936E-05,6.446198E-04,2.563610E-02,7.813365E+00,& + & 1.463885E+03,1.791000E-06,5.832300E-06,7.240435E-06,3.406818E-05,& + & 7.467939E-04,2.950675E-02,1.051959E+01,1.432083E+03,1.880000E-06,& + & 5.537000E-06,6.992494E-06,3.741183E-05,8.608811E-04,3.404528E-02,& + & 1.356109E+01,1.398419E+03,1.953000E-06,5.346500E-06,6.595182E-06,& + & 4.151504E-05,9.897272E-04,3.930706E-02,1.682390E+01,1.363711E+03,& + & 1.318800E-06,5.330700E-06,8.379479E-06,2.180234E-05,5.022675E-04,& + & 2.285635E-02,5.240947E+00,1.496649E+03,1.414100E-06,5.036700E-06,& + & 6.775083E-06,2.561472E-05,5.950802E-04,2.660192E-02,7.483703E+00,& + & 1.467627E+03,1.497900E-06,4.969000E-06,6.100870E-06,2.853726E-05,& + & 7.025876E-04,3.085197E-02,1.014362E+01,1.436133E+03,1.576400E-06,& + & 4.675800E-06,5.924158E-06,3.154034E-05,8.270322E-04,3.593549E-02,& + & 1.314934E+01,1.402649E+03,1.638400E-06,4.506200E-06,5.628641E-06,& + & 3.524717E-05,9.685135E-04,4.184342E-02,1.638576E+01,1.368006E+03/ + + + data ka_mo2(:, :) / & + & 2.317230E-06,1.819800E-06,2.214545E-06,2.124552E-06,2.287900E-06,& + & 2.282507E-06,2.557973E-06,2.441890E-06,2.286970E-06,1.813520E-06,& + & 2.201827E-06,2.114357E-06,2.275273E-06,2.271537E-06,2.542166E-06,& + & 2.430773E-06,2.257100E-06,1.807260E-06,2.189179E-06,2.104211E-06,& + & 2.262713E-06,2.260626E-06,2.526457E-06,2.419774E-06,2.227620E-06,& + & 1.801010E-06,2.176608E-06,2.094113E-06,2.250222E-06,2.249765E-06,& + & 2.510847E-06,2.408891E-06,2.198520E-06,1.794790E-06,2.164102E-06,& + & 2.084066E-06,2.237803E-06,2.238960E-06,2.495333E-06,2.398132E-06,& + & 2.169810E-06,1.788600E-06,2.151682E-06,2.074062E-06,2.225450E-06,& + & 2.228206E-06,2.479913E-06,2.387493E-06,2.141470E-06,1.782420E-06,& + & 2.139328E-06,2.064114E-06,2.213168E-06,2.217501E-06,2.464591E-06,& + & 2.376972E-06,2.113500E-06,1.776260E-06,2.127046E-06,2.054208E-06,& + & 2.200951E-06,2.206844E-06,2.449362E-06,2.366574E-06,2.085900E-06,& + & 1.770130E-06,2.114844E-06,2.044353E-06,2.188805E-06,2.196246E-06,& + & 2.434229E-06,2.356294E-06,2.058650E-06,1.764020E-06,2.102708E-06,& + & 2.034547E-06,2.176725E-06,2.185697E-06,2.419189E-06,2.346134E-06,& + & 2.031760E-06,1.757920E-06,2.090643E-06,2.024790E-06,2.164711E-06,& + & 2.175198E-06,2.404244E-06,2.336102E-06,2.005230E-06,1.751850E-06,& + & 2.078649E-06,2.015072E-06,2.152762E-06,2.164747E-06,2.389389E-06,& + & 2.326180E-06,1.979040E-06,1.745800E-06,2.066726E-06,2.005404E-06,& + & 2.140884E-06,2.154344E-06,2.374626E-06,2.316387E-06,1.953190E-06,& + & 1.739770E-06,2.054879E-06,1.995790E-06,2.129062E-06,2.144001E-06,& + & 2.359956E-06,2.306708E-06,1.927680E-06,1.733770E-06,2.043098E-06,& + & 1.986215E-06,2.117316E-06,2.133697E-06,2.345375E-06,2.297154E-06,& + & 1.902500E-06,1.727780E-06,2.031387E-06,1.976685E-06,2.105625E-06,& + & 2.123452E-06,2.330886E-06,2.287729E-06,1.877650E-06,1.721810E-06,& + & 2.019743E-06,1.967208E-06,2.094006E-06,2.113255E-06,2.316485E-06,& + & 2.278415E-06,1.853130E-06,1.715870E-06,2.008169E-06,1.957767E-06,& + & 2.082451E-06,2.103099E-06,2.302174E-06,2.269234E-06,1.828930E-06,& + & 1.709940E-06,1.996666E-06,1.948384E-06,2.070957E-06,2.093000E-06,& + & 2.287951E-06,2.260172E-06 / + + + data kb_mo2(:, :) / & + & 4.976260E-07,3.102320E-06,3.031543E-06,2.452309E-06,2.555656E-06,& + & 1.840844E-06,2.337131E-06,2.713507E-06,5.059550E-07,3.063390E-06,& + & 2.998677E-06,2.437428E-06,2.559647E-06,1.838935E-06,2.329167E-06,& + & 2.706955E-06,5.144240E-07,3.024960E-06,2.966169E-06,2.422647E-06,& + & 2.563652E-06,1.837018E-06,2.321248E-06,2.700454E-06,5.230340E-07,& + & 2.987000E-06,2.934019E-06,2.407954E-06,2.567673E-06,1.835111E-06,& + & 2.313377E-06,2.693994E-06,5.317890E-07,2.949520E-06,2.902212E-06,& + & 2.393371E-06,2.571703E-06,1.833204E-06,2.305546E-06,2.687577E-06,& + & 5.406900E-07,2.912520E-06,2.870754E-06,2.378877E-06,2.575745E-06,& + & 1.831306E-06,2.297764E-06,2.681205E-06,5.497390E-07,2.875970E-06,& + & 2.839638E-06,2.364481E-06,2.579805E-06,1.829399E-06,2.290026E-06,& + & 2.674874E-06,5.589410E-07,2.839890E-06,2.808861E-06,2.350179E-06,& + & 2.583878E-06,1.827503E-06,2.282326E-06,2.668596E-06,5.682960E-07,& + & 2.804260E-06,2.778417E-06,2.335971E-06,2.587964E-06,1.825606E-06,& + & 2.274674E-06,2.662355E-06,5.778080E-07,2.769070E-06,2.748306E-06,& + & 2.321853E-06,2.592062E-06,1.823709E-06,2.267069E-06,2.656157E-06,& + & 5.874790E-07,2.734330E-06,2.718518E-06,2.307832E-06,2.596174E-06,& + & 1.821813E-06,2.259502E-06,2.650010E-06,5.973120E-07,2.700020E-06,& + & 2.689054E-06,2.293906E-06,2.600303E-06,1.819917E-06,2.251977E-06,& + & 2.643895E-06,6.073100E-07,2.666140E-06,2.659913E-06,2.280068E-06,& + & 2.604444E-06,1.818031E-06,2.244500E-06,2.637825E-06,6.174750E-07,& + & 2.632690E-06,2.631091E-06,2.266319E-06,2.608603E-06,1.816145E-06,& + & 2.237060E-06,2.631800E-06,6.278100E-07,2.599660E-06,2.602576E-06,& + & 2.252669E-06,2.612765E-06,1.814259E-06,2.229661E-06,2.625814E-06,& + & 6.383180E-07,2.567040E-06,2.574376E-06,2.239097E-06,2.616950E-06,& + & 1.812373E-06,2.222310E-06,2.619873E-06,6.490020E-07,2.534830E-06,& + & 2.546478E-06,2.225624E-06,2.621148E-06,1.810489E-06,2.214997E-06,& + & 2.613967E-06,6.598650E-07,2.503030E-06,2.518885E-06,2.212234E-06,& + & 2.625363E-06,1.808613E-06,2.207726E-06,2.608110E-06,6.709100E-07,& + & 2.471620E-06,2.491594E-06,2.198933E-06,2.629590E-06,1.806729E-06,& + & 2.200495E-06,2.602284E-06 / + + + data selfref(:, :) / & + & 5.964960E-01,7.464550E-01,7.987986E-01,8.126631E-01,8.187091E-01,& + & 8.341900E-01,8.427325E-01,8.889891E-01,5.491710E-01,6.824590E-01,& + & 7.323321E-01,7.453751E-01,7.527891E-01,7.666934E-01,7.738040E-01,& + & 8.159868E-01,5.056000E-01,6.239500E-01,6.713958E-01,6.836590E-01,& + & 6.921775E-01,7.046627E-01,7.105183E-01,7.489836E-01,4.654860E-01,& + & 5.704570E-01,6.155299E-01,6.270528E-01,6.364463E-01,6.476540E-01,& + & 6.524123E-01,6.874869E-01,4.285550E-01,5.215500E-01,5.643129E-01,& + & 5.751336E-01,5.852028E-01,5.952616E-01,5.990625E-01,6.310445E-01,& + & 3.945540E-01,4.768360E-01,5.173571E-01,5.275131E-01,5.380851E-01,& + & 5.471099E-01,5.500792E-01,5.792389E-01,3.632500E-01,4.359560E-01,& + & 4.743091E-01,4.838359E-01,4.947618E-01,5.028569E-01,5.051042E-01,& + & 5.316905E-01,3.344300E-01,3.985800E-01,4.348424E-01,4.437749E-01,& + & 4.549264E-01,4.621854E-01,4.638093E-01,4.880482E-01,3.078970E-01,& + & 3.644090E-01,3.986597E-01,4.070308E-01,4.182989E-01,4.248059E-01,& + & 4.258935E-01,4.479911E-01,2.834680E-01,3.331670E-01,3.654880E-01,& + & 3.733298E-01,3.846201E-01,3.904518E-01,3.910801E-01,4.112244E-01/ + + + data forref(:, :) / & + & 2.885800E-02,3.687900E-02,4.161900E-02,4.272472E-02,4.429408E-02,& + & 4.515425E-02,4.557366E-02,4.798958E-02,2.788700E-02,3.737600E-02,& + & 4.194487E-02,4.301742E-02,4.401079E-02,4.487157E-02,4.531645E-02,& + & 4.754090E-02,2.584600E-02,3.675300E-02,4.304202E-02,4.355489E-02,& + & 4.402694E-02,4.473116E-02,4.548876E-02,4.674924E-02,2.895500E-02,& + & 3.760800E-02,4.339831E-02,4.282106E-02,4.195525E-02,4.021513E-02,& + & 4.233051E-02,4.448902E-02 / + + + data fracrefa(:) / 1.460100e-01,1.382400e-01,2.770300e-01,& + & 2.238800e-01,1.544590e-01,4.868710e-02,9.805400e-03,1.886952e-03/ + + + data fracrefb(:) / 7.292800e-02,1.490000e-01,3.175900e-01,& + & 2.532800e-01,1.511940e-01,4.464970e-02,9.269700e-03,2.086153e-03/ + +!........................................! + end module module_radlw_kgb11 ! +!========================================! + + +!> This module sets up absorption coefficients for band 12: 1800-2080 +!! cm-1 (low - h2o, co2; high - /) +!========================================! + module module_radlw_kgb12 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG12 +! + implicit none +! + private +! +!> msa12=585 + integer, public :: MSA12 +!> msf12=10 + integer, public :: MSF12 +!> mfr12=4 + integer, public :: MFR12 +!> maf12=9 + integer, public :: MAF12 + parameter (MSA12=585, MSF12=10, MFR12=4, MAF12=9) + + +!> the array absa(NG12,585) = ka(NG12,9,5,13) contains absorption coefs +!! at the NG12=8 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different column +!! amount ratios, as expressed through the binary species parameter eta, +!! defined as eta = gas1/(gas1+(rat)*gas2), where rat is the ratio of +!! the reference mls column amount value of gas1 to that of gas2. the +!! 2nd index in the array, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that the +!! data are for the corresponding temperature of tref-30, tref-15, tref, +!! tref+15, and tref+30, respectively. the third index, jp, runs from +!! 1 to 13 and refers to the reference pressure level (e.g. jp = 1 is +!! for a pressure of 1053.63 mb). the fourth index, ig, goes from 1 to +!! NG12=8, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG12,MSA12) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG12=8). + real (kind=kind_phys), public :: forref(NG12,MFR12) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG12=8). + real (kind=kind_phys), public :: selfref(NG12,MSF12) + +!> planck fraction mapping level : p = 174.1640 mbar, t= 215.78 k + real (kind=kind_phys), public :: fracrefa(NG12,MAF12) + + data absa( :, 1: 30) / & + & 1.751100E-07,3.768300E-07,5.379700E-07,7.934900E-07,5.447496E-06,& + & 4.667830E-05,3.814734E-04,2.663514E-03,6.813500E-05,1.980800E-04,& + & 4.818800E-04,1.071800E-03,3.182932E-03,1.973537E-02,2.103104E-01,& + & 1.733177E+00,1.180400E-04,3.668500E-04,8.972900E-04,2.107600E-03,& + & 6.391670E-03,3.984187E-02,4.210119E-01,3.443252E+00,1.693100E-04,& + & 5.391600E-04,1.320000E-03,3.177300E-03,9.730617E-03,6.054195E-02,& + & 6.321644E-01,5.118197E+00,2.200600E-04,7.116700E-04,1.777000E-03,& + & 4.349300E-03,1.326047E-02,8.223902E-02,8.440879E-01,6.736306E+00,& + & 2.827500E-04,8.930900E-04,2.329100E-03,5.650500E-03,1.715701E-02,& + & 1.058316E-01,1.057146E+00,8.247235E+00,3.572200E-04,1.125100E-03,& + & 3.112200E-03,7.244900E-03,2.193022E-02,1.336536E-01,1.271935E+00,& + & 9.526126E+00,4.953000E-04,1.606000E-03,4.451100E-03,1.012400E-02,& + & 2.967322E-02,1.746717E-01,1.490015E+00,1.008674E+01,3.571900E-04,& + & 1.321600E-03,3.515000E-03,8.680700E-03,2.650884E-02,1.644669E-01,& + & 1.688184E+00,1.347248E+01,1.983100E-07,4.218100E-07,6.126200E-07,& + & 7.917100E-07,5.928104E-06,4.818219E-05,3.893321E-04,2.615890E-03,& + & 7.745900E-05,2.208100E-04,5.261500E-04,1.140500E-03,3.449200E-03,& + & 2.129791E-02,2.252987E-01,1.806956E+00,1.345900E-04,4.084300E-04,& + & 9.884500E-04,2.261700E-03,6.921860E-03,4.299897E-02,4.509512E-01,& + & 3.588999E+00,1.909500E-04,6.000500E-04,1.451700E-03,3.420900E-03,& + & 1.054344E-02,6.534581E-02,6.771118E-01,5.334246E+00,2.533800E-04,& + & 7.985400E-04,1.940800E-03,4.672700E-03,1.437990E-02,8.877195E-02,& + & 9.040263E-01,7.016148E+00,3.172400E-04,1.023500E-03,2.514800E-03,& + & 6.066600E-03,1.862790E-02,1.142435E-01,1.132159E+00,8.584671E+00,& + & 4.134700E-04,1.274700E-03,3.296300E-03,7.839600E-03,2.380577E-02,& + & 1.443551E-01,1.361675E+00,9.904586E+00,5.582300E-04,1.773000E-03,& + & 4.858400E-03,1.070200E-02,3.226687E-02,1.889196E-01,1.591123E+00,& + & 1.048497E+01,4.187600E-04,1.507200E-03,3.832100E-03,9.328500E-03,& + & 2.874757E-02,1.775382E-01,1.808090E+00,1.403216E+01,2.244000E-07,& + & 4.620500E-07,7.063500E-07,8.353400E-07,6.411869E-06,4.972770E-05,& + & 3.968648E-04,2.566223E-03,8.765300E-05,2.450300E-04,5.664700E-04,& + & 1.202200E-03,3.722127E-03,2.283916E-02,2.399487E-01,1.879091E+00,& + & 1.528800E-04,4.539500E-04,1.075300E-03,2.369700E-03,7.484067E-03,& + & 4.612021E-02,4.802541E-01,3.731447E+00,2.163600E-04,6.647100E-04,& + & 1.592500E-03,3.607900E-03,1.138905E-02,7.009434E-02,7.211046E-01,& + & 5.542897E+00,2.832100E-04,8.850300E-04,2.139200E-03,4.965100E-03,& + & 1.551278E-02,9.524030E-02,9.628154E-01,7.286744E+00,3.638700E-04,& + & 1.134500E-03,2.744100E-03,6.486400E-03,2.009484E-02,1.225741E-01,& + & 1.205738E+00,8.908168E+00,4.554700E-04,1.456700E-03,3.530000E-03,& + & 8.365400E-03,2.572782E-02,1.548729E-01,1.449673E+00,1.026873E+01,& + & 6.403600E-04,1.980400E-03,5.041900E-03,1.151300E-02,3.487596E-02,& + & 2.029101E-01,1.692388E+00,1.084352E+01,4.900100E-04,1.667000E-03,& + & 4.229900E-03,9.919300E-03,3.100812E-02,1.904706E-01,1.925655E+00,& + & 1.457354E+01,2.490700E-07,5.149100E-07,7.676600E-07,9.526700E-07,& + & 6.905940E-06,5.130194E-05,4.040229E-04,2.515737E-03,9.892100E-05,& + & 2.706900E-04,6.072700E-04,1.272300E-03,3.991662E-03,2.434751E-02,& + & 2.542261E-01,1.950992E+00,1.727900E-04,5.037800E-04,1.162300E-03,& + & 2.497800E-03,8.038001E-03,4.917181E-02,5.089237E-01,3.873208E+00/ + data absa( :, 31: 60) / & + & 2.449500E-04,7.369900E-04,1.724700E-03,3.794300E-03,1.224102E-02,& + & 7.475280E-02,7.640932E-01,5.751048E+00,3.191100E-04,9.762600E-04,& + & 2.325500E-03,5.199400E-03,1.669756E-02,1.015951E-01,1.020097E+00,& + & 7.556969E+00,4.031700E-04,1.244600E-03,3.005400E-03,6.802500E-03,& + & 2.162032E-02,1.308197E-01,1.277303E+00,9.231426E+00,5.192200E-04,& + & 1.595200E-03,3.855300E-03,8.871500E-03,2.764307E-02,1.652964E-01,& + & 1.535827E+00,1.062475E+01,7.106000E-04,2.218800E-03,5.316300E-03,& + & 1.219000E-02,3.761043E-02,2.165118E-01,1.791245E+00,1.119995E+01,& + & 5.580300E-04,1.846300E-03,4.608100E-03,1.037500E-02,3.338512E-02,& + & 2.031791E-01,2.040169E+00,1.511412E+01,2.757700E-07,5.597700E-07,& + & 8.385100E-07,1.145800E-06,7.391727E-06,5.297655E-05,4.107068E-04,& + & 2.464302E-03,1.108800E-04,2.960800E-04,6.479600E-04,1.355400E-03,& + & 4.254450E-03,2.585518E-02,2.679502E-01,2.025813E+00,1.944800E-04,& + & 5.571900E-04,1.248400E-03,2.648400E-03,8.580270E-03,5.220387E-02,& + & 5.363194E-01,4.020354E+00,2.767000E-04,8.155700E-04,1.861700E-03,& + & 4.010900E-03,1.307760E-02,7.935785E-02,8.054748E-01,5.966823E+00,& + & 3.611200E-04,1.080600E-03,2.512700E-03,5.485600E-03,1.785064E-02,& + & 1.078622E-01,1.075480E+00,7.834750E+00,4.529100E-04,1.373800E-03,& + & 3.252100E-03,7.157800E-03,2.314224E-02,1.389093E-01,1.346852E+00,& + & 9.560443E+00,5.723200E-04,1.749700E-03,4.178700E-03,9.272600E-03,& + & 2.964272E-02,1.756357E-01,1.619294E+00,1.098737E+01,7.964700E-04,& + & 2.431300E-03,5.740700E-03,1.290400E-02,4.024935E-02,2.300733E-01,& + & 1.887677E+00,1.155422E+01,6.371800E-04,2.056200E-03,4.982800E-03,& + & 1.095400E-02,3.568713E-02,2.157090E-01,2.150976E+00,1.566949E+01,& + & 2.174300E-07,4.712300E-07,6.985800E-07,9.145400E-07,7.443194E-06,& + & 6.349307E-05,5.895184E-04,4.323198E-03,5.969700E-05,1.694300E-04,& + & 4.122000E-04,9.053900E-04,2.658606E-03,1.665258E-02,2.002715E-01,& + & 1.864874E+00,1.001100E-04,3.028700E-04,7.587100E-04,1.731500E-03,& + & 5.234875E-03,3.351163E-02,4.009071E-01,3.714559E+00,1.385600E-04,& + & 4.368000E-04,1.089300E-03,2.581700E-03,7.896441E-03,5.071764E-02,& + & 6.021005E-01,5.540391E+00,1.783700E-04,5.766500E-04,1.425000E-03,& + & 3.461100E-03,1.068439E-02,6.852155E-02,8.042237E-01,7.326390E+00,& + & 2.193700E-04,7.099400E-04,1.806900E-03,4.446900E-03,1.367732E-02,& + & 8.747847E-02,1.007973E+00,9.036609E+00,2.766500E-04,8.591100E-04,& + & 2.321800E-03,5.570500E-03,1.719461E-02,1.091088E-01,1.215158E+00,& + & 1.057362E+01,3.593400E-04,1.130800E-03,3.220800E-03,7.444800E-03,& + & 2.250455E-02,1.399386E-01,1.430543E+00,1.156040E+01,2.686500E-04,& + & 1.017200E-03,2.745100E-03,6.878200E-03,2.134962E-02,1.370248E-01,& + & 1.608395E+00,1.465287E+01,2.468900E-07,5.293100E-07,8.100600E-07,& + & 9.518700E-07,8.085125E-06,6.570162E-05,6.020033E-04,4.254522E-03,& + & 6.819900E-05,1.896100E-04,4.469000E-04,9.604100E-04,2.885497E-03,& + & 1.802132E-02,2.153146E-01,1.950941E+00,1.147300E-04,3.397600E-04,& + & 8.375100E-04,1.858800E-03,5.678762E-03,3.626865E-02,4.310609E-01,& + & 3.885614E+00,1.582600E-04,4.886800E-04,1.208300E-03,2.775500E-03,& + & 8.571552E-03,5.489852E-02,6.473335E-01,5.794434E+00,2.029900E-04,& + & 6.433700E-04,1.578100E-03,3.730600E-03,1.160418E-02,7.418003E-02,& + & 8.645734E-01,7.659654E+00,2.526500E-04,8.086200E-04,1.975800E-03,& + & 4.777500E-03,1.487419E-02,9.473094E-02,1.083602E+00,9.443332E+00/ + data absa( :, 61: 90) / & + & 3.099900E-04,9.893500E-04,2.496600E-03,6.031900E-03,1.869715E-02,& + & 1.182166E-01,1.305982E+00,1.104159E+01,4.094100E-04,1.274200E-03,& + & 3.463800E-03,7.989400E-03,2.449674E-02,1.518160E-01,1.536798E+00,& + & 1.204078E+01,3.210300E-04,1.160200E-03,3.026800E-03,7.423800E-03,& + & 2.318870E-02,1.483412E-01,1.729158E+00,1.531906E+01,2.775900E-07,& + & 5.884400E-07,9.071900E-07,1.115000E-06,8.721601E-06,6.798788E-05,& + & 6.139736E-04,4.182086E-03,7.742800E-05,2.112000E-04,4.824500E-04,& + & 1.016400E-03,3.113484E-03,1.937021E-02,2.301137E-01,2.033604E+00,& + & 1.308600E-04,3.793500E-04,9.058000E-04,1.957300E-03,6.150477E-03,& + & 3.899146E-02,4.606315E-01,4.049813E+00,1.804400E-04,5.460600E-04,& + & 1.316700E-03,2.926400E-03,9.284939E-03,5.902748E-02,6.917118E-01,& + & 6.038913E+00,2.294600E-04,7.172200E-04,1.736200E-03,3.948000E-03,& + & 1.256116E-02,7.976115E-02,9.237471E-01,7.981536E+00,2.843400E-04,& + & 8.975800E-04,2.178800E-03,5.121400E-03,1.607302E-02,1.018631E-01,& + & 1.157571E+00,9.836791E+00,3.541200E-04,1.116800E-03,2.714800E-03,& + & 6.461100E-03,2.022097E-02,1.271574E-01,1.395151E+00,1.149108E+01,& + & 4.731300E-04,1.434800E-03,3.661300E-03,8.570200E-03,2.656698E-02,& + & 1.634538E-01,1.641043E+00,1.250236E+01,3.745500E-04,1.300200E-03,& + & 3.347600E-03,7.865400E-03,2.509713E-02,1.594992E-01,1.847473E+00,& + & 1.596324E+01,3.116200E-07,6.439000E-07,9.907000E-07,1.338500E-06,& + & 9.391023E-06,7.030973E-05,6.253587E-04,4.108688E-03,8.731200E-05,& + & 2.333600E-04,5.120200E-04,1.087600E-03,3.334383E-03,2.072305E-02,& + & 2.444640E-01,2.116001E+00,1.483700E-04,4.226600E-04,9.785900E-04,& + & 2.065900E-03,6.608721E-03,4.170830E-02,4.893735E-01,4.212904E+00,& + & 2.048600E-04,6.089900E-04,1.427200E-03,3.081400E-03,9.991730E-03,& + & 6.313260E-02,7.349746E-01,6.279652E+00,2.608600E-04,7.991100E-04,& + & 1.882200E-03,4.157400E-03,1.352695E-02,8.531632E-02,9.816093E-01,& + & 8.296878E+00,3.202600E-04,9.951100E-04,2.378400E-03,5.350700E-03,& + & 1.734176E-02,1.089580E-01,1.230080E+00,1.021918E+01,3.949000E-04,& + & 1.230400E-03,2.976100E-03,6.805200E-03,2.179687E-02,1.360516E-01,& + & 1.482249E+00,1.193011E+01,5.188200E-04,1.635700E-03,3.918900E-03,& + & 9.128700E-03,2.862549E-02,1.749861E-01,1.742890E+00,1.295185E+01,& + & 4.314200E-04,1.453900E-03,3.653400E-03,8.284200E-03,2.702827E-02,& + & 1.706089E-01,1.963219E+00,1.659331E+01,3.448300E-07,7.071700E-07,& + & 1.080000E-06,1.602200E-06,1.009035E-05,7.266457E-05,6.363626E-04,& + & 4.032869E-03,9.790200E-05,2.557300E-04,5.498600E-04,1.156800E-03,& + & 3.554522E-03,2.205544E-02,2.581824E-01,2.201251E+00,1.676000E-04,& + & 4.693900E-04,1.044300E-03,2.205200E-03,7.054568E-03,4.439767E-02,& + & 5.169151E-01,4.381243E+00,2.316300E-04,6.780100E-04,1.537000E-03,& + & 3.270300E-03,1.067788E-02,6.720898E-02,7.763592E-01,6.528523E+00,& + & 2.960000E-04,8.887600E-04,2.034600E-03,4.400200E-03,1.447021E-02,& + & 9.084693E-02,1.037086E+00,8.620988E+00,3.633200E-04,1.105200E-03,& + & 2.575400E-03,5.651000E-03,1.856227E-02,1.160274E-01,1.299896E+00,& + & 1.061085E+01,4.422400E-04,1.359500E-03,3.228900E-03,7.168400E-03,& + & 2.337405E-02,1.448758E-01,1.566888E+00,1.237094E+01,5.848500E-04,& + & 1.781000E-03,4.258100E-03,9.620700E-03,3.072461E-02,1.864021E-01,& + & 1.842153E+00,1.340289E+01,4.965400E-04,1.626800E-03,3.966500E-03,& + & 8.766700E-03,2.891638E-02,1.816733E-01,2.074165E+00,1.724157E+01/ + data absa( :, 91:120) / & + & 3.552200E-07,7.738200E-07,1.195600E-06,1.557400E-06,1.327240E-05,& + & 1.152121E-04,1.216265E-03,9.552670E-03,5.463300E-05,1.559200E-04,& + & 3.653300E-04,7.637100E-04,2.263575E-03,1.381210E-02,1.858634E-01,& + & 1.975875E+00,8.995300E-05,2.600400E-04,6.485700E-04,1.448300E-03,& + & 4.291082E-03,2.747376E-02,3.719303E-01,3.944464E+00,1.194600E-04,& + & 3.591700E-04,9.179700E-04,2.100600E-03,6.331964E-03,4.136840E-02,& + & 5.584085E-01,5.901404E+00,1.473500E-04,4.559700E-04,1.175300E-03,& + & 2.759800E-03,8.428596E-03,5.553210E-02,7.455296E-01,7.837903E+00,& + & 1.754700E-04,5.622100E-04,1.423600E-03,3.462000E-03,1.062253E-02,& + & 7.019619E-02,9.339310E-01,9.735648E+00,2.043800E-04,6.619100E-04,& + & 1.716500E-03,4.195900E-03,1.306709E-02,8.607699E-02,1.125220E+00,& + & 1.153878E+01,2.506400E-04,7.809200E-04,2.236200E-03,5.205600E-03,& + & 1.631456E-02,1.064651E-01,1.326117E+00,1.300743E+01,1.953200E-04,& + & 7.532000E-04,2.089400E-03,5.334400E-03,1.676248E-02,1.110328E-01,& + & 1.491046E+00,1.567627E+01,4.031200E-07,8.790400E-07,1.368500E-06,& + & 1.759100E-06,1.438130E-05,1.195551E-04,1.243297E-03,9.421033E-03,& + & 6.296500E-05,1.746200E-04,3.965900E-04,8.111400E-04,2.463027E-03,& + & 1.500235E-02,2.008771E-01,2.076107E+00,1.033500E-04,2.930100E-04,& + & 7.108400E-04,1.547100E-03,4.672344E-03,2.987796E-02,4.020130E-01,& + & 4.144190E+00,1.374600E-04,4.055300E-04,1.016400E-03,2.276100E-03,& + & 6.881701E-03,4.499827E-02,6.035609E-01,6.199332E+00,1.681700E-04,& + & 5.163900E-04,1.308200E-03,2.986000E-03,9.178287E-03,6.040980E-02,& + & 8.058226E-01,8.232189E+00,1.993900E-04,6.323600E-04,1.585900E-03,& + & 3.730700E-03,1.159315E-02,7.635832E-02,1.009498E+00,1.022150E+01,& + & 2.356200E-04,7.599900E-04,1.884100E-03,4.548900E-03,1.425590E-02,& + & 9.364520E-02,1.216218E+00,1.210829E+01,2.933500E-04,8.959200E-04,& + & 2.358600E-03,5.731500E-03,1.779984E-02,1.159226E-01,1.433231E+00,& + & 1.363268E+01,2.348200E-04,8.680400E-04,2.327400E-03,5.792900E-03,& + & 1.827600E-02,1.207879E-01,1.611643E+00,1.646431E+01,4.534400E-07,& + & 9.828100E-07,1.509300E-06,2.095800E-06,1.555155E-05,1.240637E-04,& + & 1.268514E-03,9.289978E-03,7.181700E-05,1.926300E-04,4.239700E-04,& + & 8.733500E-04,2.659330E-03,1.618678E-02,2.155978E-01,2.171750E+00,& + & 1.182200E-04,3.287000E-04,7.700900E-04,1.641300E-03,5.064120E-03,& + & 3.227657E-02,4.314757E-01,4.334718E+00,1.570900E-04,4.563100E-04,& + & 1.104800E-03,2.398800E-03,7.479796E-03,4.862348E-02,6.478200E-01,& + & 6.484051E+00,1.928700E-04,5.803900E-04,1.434400E-03,3.156500E-03,& + & 9.975726E-03,6.527462E-02,8.648499E-01,8.609340E+00,2.273600E-04,& + & 7.084800E-04,1.756500E-03,3.968900E-03,1.258409E-02,8.252480E-02,& + & 1.083441E+00,1.068855E+01,2.661900E-04,8.486700E-04,2.087000E-03,& + & 4.892000E-03,1.546138E-02,1.011944E-01,1.305404E+00,1.265678E+01,& + & 3.252100E-04,1.036900E-03,2.551400E-03,6.146600E-03,1.934271E-02,& + & 1.252476E-01,1.538097E+00,1.423413E+01,2.772200E-04,9.846300E-04,& + & 2.590700E-03,6.150100E-03,1.986107E-02,1.305132E-01,1.729690E+00,& + & 1.721887E+01,5.134100E-07,1.079100E-06,1.673200E-06,2.494800E-06,& + & 1.679384E-05,1.284582E-04,1.293293E-03,9.152600E-03,8.119700E-05,& + & 2.119600E-04,4.558000E-04,9.319300E-04,2.850428E-03,1.736368E-02,& + & 2.300478E-01,2.264958E+00,1.339900E-04,3.674000E-04,8.253400E-04,& + & 1.755000E-03,5.435086E-03,3.466714E-02,4.603852E-01,4.520590E+00/ + data absa( :,121:150) / & + & 1.790900E-04,5.112500E-04,1.195300E-03,2.542700E-03,8.053172E-03,& + & 5.222105E-02,6.911679E-01,6.760626E+00,2.202100E-04,6.512800E-04,& + & 1.553300E-03,3.338800E-03,1.075698E-02,7.011410E-02,9.228446E-01,& + & 8.975198E+00,2.593600E-04,7.953600E-04,1.905700E-03,4.183800E-03,& + & 1.358880E-02,8.864464E-02,1.156061E+00,1.113964E+01,3.008900E-04,& + & 9.487300E-04,2.280400E-03,5.138400E-03,1.671736E-02,1.087267E-01,& + & 1.392817E+00,1.318519E+01,3.700700E-04,1.149800E-03,2.803100E-03,& + & 6.567000E-03,2.086671E-02,1.345818E-01,1.640721E+00,1.481460E+01,& + & 3.224300E-04,1.113700E-03,2.838700E-03,6.500600E-03,2.143558E-02,& + & 1.401893E-01,1.845668E+00,1.795050E+01,5.709300E-07,1.181100E-06,& + & 1.830400E-06,2.980800E-06,1.812646E-05,1.329144E-04,1.316736E-03,& + & 9.015839E-03,9.093500E-05,2.331400E-04,4.885100E-04,9.873400E-04,& + & 3.044353E-03,1.852785E-02,2.437985E-01,2.361305E+00,1.512900E-04,& + & 4.044400E-04,8.834000E-04,1.875200E-03,5.807394E-03,3.702669E-02,& + & 4.878974E-01,4.711763E+00,2.030300E-04,5.709600E-04,1.273500E-03,& + & 2.725600E-03,8.616938E-03,5.579591E-02,7.326324E-01,7.046448E+00,& + & 2.498100E-04,7.295300E-04,1.670400E-03,3.556200E-03,1.152697E-02,& + & 7.489151E-02,9.782057E-01,9.351887E+00,2.948200E-04,8.901900E-04,& + & 2.064200E-03,4.429700E-03,1.458247E-02,9.469154E-02,1.225653E+00,& + & 1.160243E+01,3.424300E-04,1.059800E-03,2.472700E-03,5.434500E-03,& + & 1.794919E-02,1.161678E-01,1.476777E+00,1.372569E+01,4.091000E-04,& + & 1.276500E-03,3.056100E-03,6.880400E-03,2.246027E-02,1.438365E-01,& + & 1.740097E+00,1.539743E+01,3.740800E-04,1.256300E-03,3.093900E-03,& + & 6.910000E-03,2.298730E-02,1.497413E-01,1.956396E+00,1.870379E+01,& + & 5.902900E-07,1.293100E-06,2.044000E-06,2.833900E-06,2.388547E-05,& + & 2.129432E-04,2.545751E-03,2.175331E-02,4.826900E-05,1.545900E-04,& + & 3.419000E-04,6.555000E-04,1.974898E-03,1.178151E-02,1.693533E-01,& + & 2.075028E+00,8.166100E-05,2.371200E-04,5.752800E-04,1.220400E-03,& + & 3.617473E-03,2.257536E-02,3.388270E-01,4.146482E+00,1.068700E-04,& + & 3.115100E-04,7.855500E-04,1.750500E-03,5.217710E-03,3.357823E-02,& + & 5.085173E-01,6.212424E+00,1.282600E-04,3.805100E-04,9.857600E-04,& + & 2.256900E-03,6.801120E-03,4.478647E-02,6.786421E-01,8.268237E+00,& + & 1.461000E-04,4.473200E-04,1.178900E-03,2.762600E-03,8.393195E-03,& + & 5.626334E-02,8.495511E-01,1.030507E+01,1.633300E-04,5.193900E-04,& + & 1.355700E-03,3.275500E-03,1.009362E-02,6.825048E-02,1.022496E+00,& + & 1.229348E+01,1.867000E-04,5.813900E-04,1.612800E-03,3.852400E-03,& + & 1.215851E-02,8.213850E-02,1.202515E+00,1.410270E+01,1.415100E-04,& + & 5.593200E-04,1.589100E-03,4.131500E-03,1.315003E-02,8.948213E-02,& + & 1.357231E+00,1.653594E+01,6.706000E-07,1.496100E-06,2.280300E-06,& + & 3.298800E-06,2.596756E-05,2.214744E-04,2.604352E-03,2.151761E-02,& + & 5.634900E-05,1.692400E-04,3.662600E-04,7.084500E-04,2.152624E-03,& + & 1.281472E-02,1.841798E-01,2.190999E+00,9.491600E-05,2.674300E-04,& + & 6.261300E-04,1.296600E-03,3.960924E-03,2.466119E-02,3.684755E-01,& + & 4.378157E+00,1.236500E-04,3.530900E-04,8.662100E-04,1.875400E-03,& + & 5.707514E-03,3.673984E-02,5.530498E-01,6.559143E+00,1.480300E-04,& + & 4.327700E-04,1.094500E-03,2.458100E-03,7.422346E-03,4.903406E-02,& + & 7.380897E-01,8.728866E+00,1.677600E-04,5.100500E-04,1.315000E-03,& + & 3.002000E-03,9.176993E-03,6.161021E-02,9.240044E-01,1.087701E+01/ + data absa( :,151:180) / & + & 1.871900E-04,5.872000E-04,1.519100E-03,3.563900E-03,1.105305E-02,& + & 7.472821E-02,1.112158E+00,1.297273E+01,2.103600E-04,6.855700E-04,& + & 1.741200E-03,4.244800E-03,1.332194E-02,8.994417E-02,1.308188E+00,& + & 1.487015E+01,1.719600E-04,6.544900E-04,1.782700E-03,4.513000E-03,& + & 1.440582E-02,9.799298E-02,1.476142E+00,1.745740E+01,7.575900E-07,& + & 1.668700E-06,2.534400E-06,3.949100E-06,2.816587E-05,2.302239E-04,& + & 2.660133E-03,2.127257E-02,6.486900E-05,1.866800E-04,3.930700E-04,& + & 7.619800E-04,2.323479E-03,1.384583E-02,1.987477E-01,2.301556E+00,& + & 1.091600E-04,2.994600E-04,6.751100E-04,1.387100E-03,4.298929E-03,& + & 2.673810E-02,3.976139E-01,4.598864E+00,1.420600E-04,3.981500E-04,& + & 9.437200E-04,1.994200E-03,6.205574E-03,3.988324E-02,5.967550E-01,& + & 6.889625E+00,1.696200E-04,4.897800E-04,1.195400E-03,2.602300E-03,& + & 8.083917E-03,5.326534E-02,7.963615E-01,9.168459E+00,1.934800E-04,& + & 5.771200E-04,1.447400E-03,3.197800E-03,9.994767E-03,6.693742E-02,& + & 9.969523E-01,1.142374E+01,2.132500E-04,6.656800E-04,1.688200E-03,& + & 3.848800E-03,1.202066E-02,8.120426E-02,1.199793E+00,1.362276E+01,& + & 2.423800E-04,7.729300E-04,1.926200E-03,4.580200E-03,1.451537E-02,& + & 9.776953E-02,1.410939E+00,1.561053E+01,2.061100E-04,7.480300E-04,& + & 2.003000E-03,4.844300E-03,1.569489E-02,1.064558E-01,1.592671E+00,& + & 1.833655E+01,8.593700E-07,1.849100E-06,2.863600E-06,4.642500E-06,& + & 3.047666E-05,2.388649E-04,2.713931E-03,2.102716E-02,7.406300E-05,& + & 2.051700E-04,4.197400E-04,8.198200E-04,2.490138E-03,1.485893E-02,& + & 2.130127E-01,2.409026E+00,1.241600E-04,3.298200E-04,7.276900E-04,& + & 1.490200E-03,4.622961E-03,2.878397E-02,4.261581E-01,4.813385E+00,& + & 1.620700E-04,4.474100E-04,1.015300E-03,2.138000E-03,6.685453E-03,& + & 4.298000E-02,6.396418E-01,7.209979E+00,1.941200E-04,5.520200E-04,& + & 1.297700E-03,2.771000E-03,8.723379E-03,5.742024E-02,8.536084E-01,& + & 9.593669E+00,2.212600E-04,6.520500E-04,1.571600E-03,3.397400E-03,& + & 1.081133E-02,7.217107E-02,1.068630E+00,1.195236E+01,2.447900E-04,& + & 7.519800E-04,1.842700E-03,4.048700E-03,1.303691E-02,8.757100E-02,& + & 1.286126E+00,1.424931E+01,2.714600E-04,8.706400E-04,2.131500E-03,& + & 4.865900E-03,1.572461E-02,1.054758E-01,1.512292E+00,1.631895E+01,& + & 2.415700E-04,8.554000E-04,2.208400E-03,5.141300E-03,1.700807E-02,& + & 1.147599E-01,1.707156E+00,1.918709E+01,9.589700E-07,2.032400E-06,& + & 3.066800E-06,5.626500E-06,3.299094E-05,2.474776E-04,2.765797E-03,& + & 2.077398E-02,8.368700E-05,2.216200E-04,4.520700E-04,8.801700E-04,& + & 2.656634E-03,1.586582E-02,2.265938E-01,2.518635E+00,1.397300E-04,& + & 3.646900E-04,7.826700E-04,1.588200E-03,4.950549E-03,3.081828E-02,& + & 4.533391E-01,5.032093E+00,1.836400E-04,4.954400E-04,1.088500E-03,& + & 2.289300E-03,7.165444E-03,4.605945E-02,6.804020E-01,7.537714E+00,& + & 2.205100E-04,6.196800E-04,1.385400E-03,2.976300E-03,9.355116E-03,& + & 6.155967E-02,9.080171E-01,1.002905E+01,2.523400E-04,7.337800E-04,& + & 1.689700E-03,3.635200E-03,1.161443E-02,7.737612E-02,1.136874E+00,& + & 1.249253E+01,2.791100E-04,8.476900E-04,1.996400E-03,4.291600E-03,& + & 1.403893E-02,9.389514E-02,1.368328E+00,1.488890E+01,3.092800E-04,& + & 9.761400E-04,2.314700E-03,5.143900E-03,1.695539E-02,1.131329E-01,& + & 1.609916E+00,1.703183E+01,2.824800E-04,9.719700E-04,2.419500E-03,& + & 5.462200E-03,1.831274E-02,1.230294E-01,1.815959E+00,2.005784E+01/ + data absa( :,181:210) / & + & 9.175900E-07,2.006500E-06,3.131900E-06,4.844700E-06,3.940807E-05,& + & 3.619230E-04,4.876633E-03,4.589266E-02,4.194700E-05,1.515000E-04,& + & 3.241800E-04,5.859400E-04,1.769273E-03,1.052476E-02,1.529139E-01,& + & 2.166293E+00,7.079400E-05,2.296800E-04,5.243300E-04,1.029600E-03,& + & 3.109894E-03,1.918387E-02,3.040125E-01,4.330810E+00,9.488500E-05,& + & 2.838600E-04,6.988500E-04,1.465600E-03,4.379732E-03,2.771141E-02,& + & 4.561817E-01,6.492251E+00,1.124300E-04,3.316800E-04,8.470700E-04,& + & 1.869600E-03,5.627654E-03,3.639254E-02,6.085431E-01,8.649198E+00,& + & 1.259900E-04,3.758100E-04,9.823200E-04,2.261900E-03,6.836552E-03,& + & 4.527589E-02,7.614303E-01,1.079545E+01,1.368300E-04,4.148900E-04,& + & 1.111200E-03,2.638800E-03,8.029332E-03,5.449146E-02,9.154927E-01,& + & 1.291742E+01,1.429300E-04,4.567500E-04,1.241000E-03,3.008400E-03,& + & 9.343720E-03,6.464030E-02,1.074144E+00,1.494406E+01,1.033600E-04,& + & 4.135800E-04,1.222600E-03,3.195000E-03,1.031946E-02,7.198534E-02,& + & 1.217018E+00,1.729827E+01,1.042500E-06,2.325200E-06,3.529500E-06,& + & 5.568000E-06,4.302626E-05,3.774851E-04,4.992057E-03,4.553794E-02,& + & 4.911300E-05,1.685400E-04,3.492900E-04,6.335000E-04,1.926880E-03,& + & 1.148947E-02,1.671597E-01,2.300788E+00,8.372800E-05,2.548000E-04,& + & 5.686800E-04,1.105400E-03,3.410387E-03,2.098563E-02,3.328677E-01,& + & 4.599322E+00,1.114000E-04,3.208100E-04,7.627400E-04,1.564000E-03,& + & 4.819410E-03,3.042710E-02,4.994917E-01,6.894557E+00,1.316800E-04,& + & 3.775400E-04,9.385200E-04,2.014800E-03,6.184376E-03,4.003893E-02,& + & 6.663394E-01,9.184686E+00,1.460500E-04,4.302600E-04,1.097200E-03,& + & 2.470200E-03,7.501632E-03,4.986850E-02,8.337880E-01,1.146294E+01,& + & 1.565000E-04,4.760600E-04,1.247200E-03,2.877200E-03,8.823009E-03,& + & 6.006781E-02,1.002501E+00,1.371350E+01,1.656300E-04,5.282000E-04,& + & 1.381200E-03,3.313000E-03,1.027984E-02,7.125686E-02,1.176352E+00,& + & 1.585995E+01,1.271300E-04,4.936800E-04,1.379800E-03,3.519300E-03,& + & 1.136570E-02,7.935042E-02,1.332590E+00,1.836958E+01,1.183500E-06,& + & 2.608500E-06,3.974500E-06,6.572300E-06,4.686665E-05,3.930971E-04,& + & 5.103821E-03,4.515694E-02,5.726300E-05,1.833100E-04,3.764100E-04,& + & 6.861500E-04,2.081503E-03,1.243293E-02,1.810405E-01,2.430405E+00,& + & 9.739400E-05,2.803300E-04,6.126100E-04,1.197700E-03,3.700322E-03,& + & 2.275410E-02,3.609892E-01,4.858692E+00,1.292400E-04,3.605600E-04,& + & 8.261100E-04,1.675300E-03,5.254761E-03,3.308823E-02,5.416840E-01,& + & 7.282938E+00,1.519000E-04,4.282500E-04,1.025500E-03,2.149700E-03,& + & 6.752972E-03,4.361748E-02,7.226366E-01,9.701499E+00,1.688100E-04,& + & 4.892800E-04,1.206500E-03,2.625400E-03,8.199927E-03,5.439053E-02,& + & 9.042232E-01,1.210806E+01,1.809600E-04,5.430900E-04,1.383600E-03,& + & 3.096900E-03,9.624091E-03,6.556558E-02,1.087258E+00,1.448315E+01,& + & 1.890600E-04,5.980700E-04,1.545400E-03,3.591200E-03,1.123445E-02,& + & 7.780810E-02,1.275869E+00,1.674052E+01,1.543600E-04,5.699300E-04,& + & 1.556300E-03,3.842200E-03,1.241071E-02,8.658687E-02,1.445170E+00,& + & 1.940296E+01,1.339300E-06,2.913200E-06,4.438900E-06,7.853000E-06,& + & 5.099278E-05,4.083097E-04,5.213261E-03,4.474490E-02,6.617800E-05,& + & 1.976100E-04,4.060200E-04,7.427700E-04,2.232020E-03,1.335883E-02,& + & 1.947823E-01,2.553964E+00,1.113200E-04,3.101500E-04,6.576000E-04,& + & 1.288400E-03,3.985299E-03,2.451371E-02,3.887700E-01,5.105380E+00/ + data absa( :,211:240) / & + & 1.475900E-04,3.988200E-04,8.924700E-04,1.810100E-03,5.668335E-03,& + & 3.573953E-02,5.833515E-01,7.653007E+00,1.741100E-04,4.841200E-04,& + & 1.105200E-03,2.310100E-03,7.303667E-03,4.717150E-02,7.782334E-01,& + & 1.019391E+01,1.939600E-04,5.546000E-04,1.315100E-03,2.799200E-03,& + & 8.889085E-03,5.886057E-02,9.737892E-01,1.272177E+01,2.076400E-04,& + & 6.178200E-04,1.507400E-03,3.295200E-03,1.045654E-02,7.097807E-02,& + & 1.170882E+00,1.521518E+01,2.162800E-04,6.798000E-04,1.708100E-03,& + & 3.815100E-03,1.222540E-02,8.425391E-02,1.374001E+00,1.758362E+01,& + & 1.819000E-04,6.583700E-04,1.733400E-03,4.068900E-03,1.352344E-02,& + & 9.374140E-02,1.556354E+00,2.038826E+01,1.498800E-06,3.236100E-06,& + & 4.766300E-06,9.452700E-06,5.546867E-05,4.233538E-04,5.318867E-03,& + & 4.432263E-02,7.510300E-05,2.143400E-04,4.356800E-04,8.010500E-04,& + & 2.384133E-03,1.427339E-02,2.081117E-01,2.675640E+00,1.261700E-04,& + & 3.411800E-04,7.054700E-04,1.387100E-03,4.268458E-03,2.626405E-02,& + & 4.156965E-01,5.348560E+00,1.672100E-04,4.418000E-04,9.625300E-04,& + & 1.937100E-03,6.089839E-03,3.837612E-02,6.237526E-01,8.017486E+00,& + & 1.977800E-04,5.375200E-04,1.190100E-03,2.490800E-03,7.848453E-03,& + & 5.070820E-02,8.321579E-01,1.067931E+01,2.210400E-04,6.258800E-04,& + & 1.410500E-03,3.012100E-03,9.564452E-03,6.332471E-02,1.041237E+00,& + & 1.332623E+01,2.378900E-04,6.993000E-04,1.631900E-03,3.528800E-03,& + & 1.126654E-02,7.639913E-02,1.252012E+00,1.593788E+01,2.479600E-04,& + & 7.711300E-04,1.855900E-03,4.053200E-03,1.321799E-02,9.070368E-02,& + & 1.469190E+00,1.841165E+01,2.141600E-04,7.532700E-04,1.904400E-03,& + & 4.348600E-03,1.461358E-02,1.008676E-01,1.664202E+00,2.135827E+01,& + & 1.350900E-06,2.923000E-06,4.550000E-06,7.968700E-06,6.061689E-05,& + & 5.754326E-04,8.693723E-03,9.119138E-02,3.619000E-05,1.380600E-04,& + & 3.208500E-04,5.450700E-04,1.603057E-03,9.572510E-03,1.391015E-01,& + & 2.237002E+00,6.018600E-05,2.183500E-04,4.895900E-04,8.951300E-04,& + & 2.716645E-03,1.681942E-02,2.699366E-01,4.473066E+00,8.008900E-05,& + & 2.709500E-04,6.259700E-04,1.238200E-03,3.731343E-03,2.360734E-02,& + & 4.026927E-01,6.707738E+00,9.744700E-05,3.019400E-04,7.485500E-04,& + & 1.558900E-03,4.689694E-03,3.018360E-02,5.366380E-01,8.940144E+00,& + & 1.081700E-04,3.275800E-04,8.438600E-04,1.851000E-03,5.620418E-03,& + & 3.679113E-02,6.712069E-01,1.116642E+01,1.147700E-04,3.458700E-04,& + & 9.246300E-04,2.139800E-03,6.504268E-03,4.361565E-02,8.064701E-01,& + & 1.338036E+01,1.145900E-04,3.640800E-04,9.819600E-04,2.386000E-03,& + & 7.368488E-03,5.102775E-02,9.443692E-01,1.554414E+01,7.521600E-05,& + & 3.046800E-04,9.332200E-04,2.463500E-03,8.043813E-03,5.745174E-02,& + & 1.073154E+00,1.788005E+01,1.537900E-06,3.402100E-06,5.183200E-06,& + & 8.871200E-06,6.645496E-05,6.013818E-04,8.911097E-03,9.072193E-02,& + & 4.304800E-05,1.536500E-04,3.489400E-04,5.909800E-04,1.745474E-03,& + & 1.047663E-02,1.524925E-01,2.394296E+00,7.122300E-05,2.457800E-04,& + & 5.264600E-04,9.703900E-04,2.983910E-03,1.848287E-02,2.970114E-01,& + & 4.787721E+00,9.542900E-05,3.040000E-04,6.889200E-04,1.323500E-03,& + & 4.113380E-03,2.598763E-02,4.436645E-01,7.178934E+00,1.155500E-04,& + & 3.428600E-04,8.264200E-04,1.675500E-03,5.180876E-03,3.327239E-02,& + & 5.915328E-01,9.567712E+00,1.277800E-04,3.731800E-04,9.441900E-04,& + & 2.028500E-03,6.198498E-03,4.066291E-02,7.398761E-01,1.195012E+01/ + data absa( :,241:270) / & + & 1.338500E-04,3.986100E-04,1.034400E-03,2.350100E-03,7.185920E-03,& + & 4.830695E-02,8.890068E-01,1.431843E+01,1.355000E-04,4.143800E-04,& + & 1.112000E-03,2.641100E-03,8.140341E-03,5.661011E-02,1.041234E+00,& + & 1.662790E+01,9.374700E-05,3.702100E-04,1.056700E-03,2.755500E-03,& + & 8.907079E-03,6.372632E-02,1.182906E+00,1.913544E+01,1.750500E-06,& + & 3.862000E-06,5.745400E-06,1.030000E-05,7.275049E-05,6.270554E-04,& + & 9.120069E-03,9.022564E-02,5.064900E-05,1.705100E-04,3.762400E-04,& + & 6.394700E-04,1.888663E-03,1.135979E-02,1.657099E-01,2.542887E+00,& + & 8.344300E-05,2.733400E-04,5.659600E-04,1.049700E-03,3.245838E-03,& + & 2.010265E-02,3.237931E-01,5.084553E+00,1.122500E-04,3.343800E-04,& + & 7.419300E-04,1.436600E-03,4.488626E-03,2.830617E-02,4.841701E-01,& + & 7.624906E+00,1.346800E-04,3.871500E-04,8.986600E-04,1.794400E-03,& + & 5.678447E-03,3.630809E-02,6.457018E-01,1.016140E+01,1.492500E-04,& + & 4.243200E-04,1.033900E-03,2.160800E-03,6.810155E-03,4.448661E-02,& + & 8.075933E-01,1.269213E+01,1.551600E-04,4.566200E-04,1.147800E-03,& + & 2.518400E-03,7.890321E-03,5.294413E-02,9.703666E-01,1.520654E+01,& + & 1.552200E-04,4.777200E-04,1.243400E-03,2.880900E-03,8.914407E-03,& + & 6.212218E-02,1.136352E+00,1.765815E+01,1.156600E-04,4.326000E-04,& + & 1.198900E-03,3.021100E-03,9.782297E-03,6.991034E-02,1.291226E+00,& + & 2.032293E+01,1.976900E-06,4.287000E-06,6.418300E-06,1.217100E-05,& + & 7.950304E-05,6.527745E-04,9.320224E-03,8.969824E-02,5.861300E-05,& + & 1.888700E-04,4.004900E-04,6.927700E-04,2.032949E-03,1.222879E-02,& + & 1.788849E-01,2.683171E+00,9.717600E-05,2.966800E-04,6.111900E-04,& + & 1.137000E-03,3.501962E-03,2.170799E-02,3.504726E-01,5.364794E+00,& + & 1.295200E-04,3.713700E-04,7.991700E-04,1.551000E-03,4.853237E-03,& + & 3.059024E-02,5.245612E-01,8.044744E+00,1.551200E-04,4.288600E-04,& + & 9.724100E-04,1.945000E-03,6.152821E-03,3.935040E-02,6.996493E-01,& + & 1.072081E+01,1.722100E-04,4.813300E-04,1.120600E-03,2.321700E-03,& + & 7.404643E-03,4.829511E-02,8.750925E-01,1.339008E+01,1.795200E-04,& + & 5.205300E-04,1.256200E-03,2.689000E-03,8.599472E-03,5.754307E-02,& + & 1.051442E+00,1.604197E+01,1.788400E-04,5.468900E-04,1.372100E-03,& + & 3.069200E-03,9.730873E-03,6.758017E-02,1.231324E+00,1.862617E+01,& + & 1.375400E-04,5.025800E-04,1.355400E-03,3.228400E-03,1.069996E-02,& + & 7.605819E-02,1.399125E+00,2.144129E+01,2.220100E-06,4.842300E-06,& + & 6.932400E-06,1.456400E-05,8.680785E-05,6.786088E-04,9.514948E-03,& + & 8.911612E-02,6.735600E-05,2.066200E-04,4.266800E-04,7.460000E-04,& + & 2.180497E-03,1.308404E-02,1.916928E-01,2.819935E+00,1.120200E-04,& + & 3.197700E-04,6.603800E-04,1.231800E-03,3.755936E-03,2.329032E-02,& + & 3.764264E-01,5.638775E+00,1.482500E-04,4.108900E-04,8.536800E-04,& + & 1.680100E-03,5.218768E-03,3.283259E-02,5.638778E-01,8.454770E+00,& + & 1.772200E-04,4.760900E-04,1.048600E-03,2.094800E-03,6.627789E-03,& + & 4.235512E-02,7.521017E-01,1.126796E+01,1.965000E-04,5.374200E-04,& + & 1.211600E-03,2.511500E-03,7.982756E-03,5.207115E-02,9.406883E-01,& + & 1.407193E+01,2.055400E-04,5.912600E-04,1.359900E-03,2.892300E-03,& + & 9.290624E-03,6.211310E-02,1.130208E+00,1.685816E+01,2.049500E-04,& + & 6.233700E-04,1.500100E-03,3.275600E-03,1.054284E-02,7.301672E-02,& + & 1.323668E+00,1.957124E+01,1.635500E-04,5.782300E-04,1.504300E-03,& + & 3.448300E-03,1.161880E-02,8.214052E-02,1.504013E+00,2.253537E+01/ + data absa( :,271:300) / & + & 2.130400E-06,4.540400E-06,7.279700E-06,1.330200E-05,9.797772E-05,& + & 9.644905E-04,1.618664E-02,1.911172E-01,3.308900E-05,1.314300E-04,& + & 3.067700E-04,5.538600E-04,1.533036E-03,9.186934E-03,1.324235E-01,& + & 2.287107E+00,5.184900E-05,2.072700E-04,4.807100E-04,8.338200E-04,& + & 2.456965E-03,1.521660E-02,2.428372E-01,4.573872E+00,6.873000E-05,& + & 2.605200E-04,5.997100E-04,1.099300E-03,3.272721E-03,2.082598E-02,& + & 3.551305E-01,6.859664E+00,8.230500E-05,2.963500E-04,6.874200E-04,& + & 1.356400E-03,4.016115E-03,2.608746E-02,4.689373E-01,9.144205E+00,& + & 9.347200E-05,3.074300E-04,7.567200E-04,1.566300E-03,4.720090E-03,& + & 3.099432E-02,5.842768E-01,1.142647E+01,9.916400E-05,3.082500E-04,& + & 8.012400E-04,1.752200E-03,5.359449E-03,3.564697E-02,7.012387E-01,& + & 1.370232E+01,9.863100E-05,2.970300E-04,8.105800E-04,1.921200E-03,& + & 5.934757E-03,4.054998E-02,8.199608E-01,1.595335E+01,5.941800E-05,& + & 2.219700E-04,7.095300E-04,1.892800E-03,6.251822E-03,4.555033E-02,& + & 9.338471E-01,1.828828E+01,2.430800E-06,5.264000E-06,8.117700E-06,& + & 1.513700E-05,1.076432E-04,1.008209E-03,1.660667E-02,1.907676E-01,& + & 3.963600E-05,1.477200E-04,3.392000E-04,6.036200E-04,1.669456E-03,& + & 1.003674E-02,1.450504E-01,2.467123E+00,6.205100E-05,2.306800E-04,& + & 5.245500E-04,9.030300E-04,2.698967E-03,1.675758E-02,2.682520E-01,& + & 4.933785E+00,8.196800E-05,2.968700E-04,6.448900E-04,1.181600E-03,& + & 3.625684E-03,2.300172E-02,3.935048E-01,7.399397E+00,9.890900E-05,& + & 3.318400E-04,7.643600E-04,1.435000E-03,4.468081E-03,2.887030E-02,& + & 5.203935E-01,9.864249E+00,1.125600E-04,3.498600E-04,8.433800E-04,& + & 1.694900E-03,5.237022E-03,3.434890E-02,6.489961E-01,1.232490E+01,& + & 1.181000E-04,3.524900E-04,9.040800E-04,1.939100E-03,5.942022E-03,& + & 3.958912E-02,7.792079E-01,1.477972E+01,1.139600E-04,3.454300E-04,& + & 9.214700E-04,2.134500E-03,6.593016E-03,4.520230E-02,9.110878E-01,& + & 1.720705E+01,7.526900E-05,2.733000E-04,8.048200E-04,2.140000E-03,& + & 6.973228E-03,5.086368E-02,1.037667E+00,1.972829E+01,2.753700E-06,& + & 6.046600E-06,8.950900E-06,1.739300E-05,1.182217E-04,1.051899E-03,& + & 1.701822E-02,1.902125E-01,4.682100E-05,1.647000E-04,3.642500E-04,& + & 6.555600E-04,1.811482E-03,1.087437E-02,1.576177E-01,2.635728E+00,& + & 7.379500E-05,2.569600E-04,5.679700E-04,9.776000E-04,2.939412E-03,& + & 1.826782E-02,2.936216E-01,5.270430E+00,9.681200E-05,3.323400E-04,& + & 6.966700E-04,1.275200E-03,3.966001E-03,2.514714E-02,4.318136E-01,& + & 7.904620E+00,1.173800E-04,3.691400E-04,8.204600E-04,1.563800E-03,& + & 4.901107E-03,3.160840E-02,5.717611E-01,1.053714E+01,1.327400E-04,& + & 3.962600E-04,9.259000E-04,1.814200E-03,5.766678E-03,3.763218E-02,& + & 7.136406E-01,1.316605E+01,1.390300E-04,4.024600E-04,9.987400E-04,& + & 2.076000E-03,6.557274E-03,4.350179E-02,8.569125E-01,1.578812E+01,& + & 1.328200E-04,3.990200E-04,1.031700E-03,2.341900E-03,7.257379E-03,& + & 4.982746E-02,1.001969E+00,1.837864E+01,9.264100E-05,3.232900E-04,& + & 9.228000E-04,2.361800E-03,7.709128E-03,5.613369E-02,1.141180E+00,& + & 2.107419E+01,3.121200E-06,6.756500E-06,9.996200E-06,2.019000E-05,& + & 1.298264E-04,1.096774E-03,1.741531E-02,1.895356E-01,5.443900E-05,& + & 1.810700E-04,3.897500E-04,7.087700E-04,1.954768E-03,1.169686E-02,& + & 1.701386E-01,2.794675E+00,8.676500E-05,2.842100E-04,6.121600E-04,& + & 1.058300E-03,3.180965E-03,1.976064E-02,3.188458E-01,5.588266E+00/ + data absa( :,301:330) / & + & 1.137400E-04,3.628600E-04,7.551700E-04,1.383200E-03,4.300074E-03,& + & 2.726774E-02,4.699232E-01,8.381237E+00,1.369400E-04,4.118300E-04,& + & 8.821500E-04,1.693400E-03,5.324438E-03,3.432651E-02,6.228952E-01,& + & 1.117153E+01,1.547400E-04,4.387600E-04,1.000000E-03,1.972000E-03,& + & 6.276595E-03,4.088347E-02,7.779676E-01,1.395960E+01,1.619200E-04,& + & 4.574800E-04,1.089500E-03,2.227300E-03,7.170801E-03,4.740515E-02,& + & 9.341884E-01,1.673851E+01,1.537500E-04,4.583500E-04,1.138200E-03,& + & 2.489600E-03,7.966766E-03,5.442972E-02,1.092325E+00,1.948494E+01,& + & 1.118400E-04,3.791300E-04,1.049200E-03,2.568200E-03,8.458572E-03,& + & 6.138181E-02,1.244099E+00,2.234287E+01,3.521000E-06,7.647400E-06,& + & 1.066900E-05,2.386500E-05,1.424388E-04,1.142693E-03,1.779069E-02,& + & 1.888371E-01,6.261100E-05,1.986700E-04,4.175200E-04,7.624600E-04,& + & 2.096321E-03,1.250854E-02,1.823743E-01,2.948519E+00,9.978200E-05,& + & 3.147500E-04,6.520500E-04,1.147600E-03,3.424519E-03,2.123159E-02,& + & 3.434846E-01,5.895476E+00,1.321400E-04,3.931000E-04,8.176500E-04,& + & 1.500300E-03,4.634072E-03,2.935288E-02,5.071690E-01,8.841851E+00,& + & 1.585000E-04,4.543800E-04,9.501800E-04,1.832500E-03,5.746498E-03,& + & 3.698515E-02,6.729360E-01,1.177338E+01,1.775200E-04,4.895700E-04,& + & 1.074500E-03,2.136300E-03,6.784939E-03,4.408703E-02,8.409027E-01,& + & 1.472729E+01,1.862200E-04,5.138500E-04,1.176700E-03,2.421600E-03,& + & 7.759794E-03,5.127564E-02,1.009808E+00,1.765854E+01,1.773400E-04,& + & 5.232000E-04,1.249800E-03,2.664700E-03,8.654877E-03,5.898751E-02,& + & 1.180801E+00,2.055310E+01,1.335700E-04,4.401600E-04,1.175700E-03,& + & 2.737700E-03,9.242359E-03,6.654761E-02,1.344743E+00,2.357266E+01,& + & 4.118000E-06,8.652000E-06,1.326900E-05,2.872300E-05,1.902176E-04,& + & 1.936108E-03,3.590845E-02,4.806917E-01,3.535600E-05,1.411000E-04,& + & 3.020800E-04,5.878500E-04,1.708675E-03,9.963474E-03,1.490273E-01,& + & 2.314502E+00,4.987500E-05,2.049600E-04,4.854200E-04,8.865400E-04,& + & 2.465667E-03,1.519288E-02,2.362072E-01,4.628666E+00,6.211200E-05,& + & 2.599300E-04,6.172000E-04,1.076900E-03,3.130870E-03,1.967670E-02,& + & 3.262439E-01,6.942561E+00,7.327200E-05,2.974200E-04,7.075100E-04,& + & 1.257900E-03,3.694637E-03,2.377436E-02,4.179587E-01,9.256097E+00,& + & 8.166500E-05,3.182100E-04,7.583200E-04,1.431000E-03,4.172769E-03,& + & 2.753507E-02,5.111673E-01,1.156928E+01,8.755900E-05,3.145600E-04,& + & 7.595600E-04,1.539400E-03,4.605100E-03,3.087095E-02,6.062820E-01,& + & 1.387966E+01,8.637000E-05,2.764900E-04,7.265800E-04,1.598700E-03,& + & 4.921698E-03,3.349049E-02,7.048996E-01,1.617922E+01,4.988100E-05,& + & 1.848500E-04,5.275300E-04,1.447900E-03,4.843043E-03,3.593841E-02,& + & 8.042182E-01,1.851179E+01,4.688000E-06,1.000900E-05,1.528200E-05,& + & 3.195100E-05,2.086444E-04,2.026638E-03,3.689784E-02,4.808600E-01,& + & 4.230800E-05,1.551700E-04,3.280700E-04,6.593400E-04,1.852164E-03,& + & 1.087376E-02,1.608933E-01,2.518306E+00,6.013900E-05,2.320600E-04,& + & 5.396800E-04,9.749300E-04,2.696608E-03,1.667259E-02,2.599545E-01,& + & 5.035505E+00,7.510800E-05,2.917100E-04,6.846700E-04,1.167200E-03,& + & 3.452564E-03,2.172264E-02,3.619481E-01,7.552276E+00,8.800100E-05,& + & 3.440500E-04,7.673300E-04,1.359400E-03,4.099244E-03,2.636786E-02,& + & 4.657304E-01,1.006921E+01,9.926900E-05,3.641400E-04,8.217500E-04,& + & 1.524300E-03,4.672982E-03,3.062683E-02,5.711598E-01,1.258470E+01/ + data absa( :,331:360) / & + & 1.059700E-04,3.593900E-04,8.470800E-04,1.674900E-03,5.139406E-03,& + & 3.442493E-02,6.787010E-01,1.509794E+01,1.040900E-04,3.171300E-04,& + & 8.265500E-04,1.777900E-03,5.493198E-03,3.738897E-02,7.901959E-01,& + & 1.759905E+01,6.323200E-05,2.242400E-04,6.120900E-04,1.653500E-03,& + & 5.442025E-03,4.042538E-02,9.014970E-01,2.013744E+01,5.289300E-06,& + & 1.150900E-05,1.691900E-05,3.602800E-05,2.298441E-04,2.117243E-03,& + & 3.783995E-02,4.808791E-01,4.970500E-05,1.720500E-04,3.545500E-04,& + & 7.334900E-04,1.990043E-03,1.177919E-02,1.727460E-01,2.708873E+00,& + & 7.173300E-05,2.601800E-04,5.867300E-04,1.059700E-03,2.937268E-03,& + & 1.814007E-02,2.836484E-01,5.416513E+00,8.999700E-05,3.263600E-04,& + & 7.500600E-04,1.270400E-03,3.768869E-03,2.374844E-02,3.976286E-01,& + & 8.123568E+00,1.054000E-04,3.824400E-04,8.341700E-04,1.467500E-03,& + & 4.503187E-03,2.892578E-02,5.134836E-01,1.083043E+01,1.180700E-04,& + & 4.124100E-04,8.882000E-04,1.649900E-03,5.150250E-03,3.368157E-02,& + & 6.311229E-01,1.353536E+01,1.272900E-04,4.030400E-04,9.312000E-04,& + & 1.796500E-03,5.693496E-03,3.791978E-02,7.510780E-01,1.623867E+01,& + & 1.236700E-04,3.637700E-04,9.258300E-04,1.928000E-03,6.081991E-03,& + & 4.127039E-02,8.752648E-01,1.892833E+01,7.948800E-05,2.682100E-04,& + & 7.062100E-04,1.844300E-03,6.054024E-03,4.488369E-02,9.986186E-01,& + & 2.165922E+01,5.993400E-06,1.311700E-05,1.861600E-05,4.197200E-05,& + & 2.528119E-04,2.209436E-03,3.874409E-02,4.806440E-01,5.762900E-05,& + & 1.895900E-04,3.866400E-04,7.990100E-04,2.132419E-03,1.266966E-02,& + & 1.845510E-01,2.888138E+00,8.385200E-05,2.894500E-04,6.265300E-04,& + & 1.153400E-03,3.178917E-03,1.958419E-02,3.072990E-01,5.774991E+00,& + & 1.061700E-04,3.654400E-04,8.092700E-04,1.384500E-03,4.083646E-03,& + & 2.576740E-02,4.331560E-01,8.661557E+00,1.250500E-04,4.214700E-04,& + & 9.071200E-04,1.589800E-03,4.899850E-03,3.146519E-02,5.611017E-01,& + & 1.154692E+01,1.396000E-04,4.578800E-04,9.623600E-04,1.781900E-03,& + & 5.622177E-03,3.670375E-02,6.909415E-01,1.443183E+01,1.500100E-04,& + & 4.492200E-04,1.005600E-03,1.961000E-03,6.220681E-03,4.138733E-02,& + & 8.232868E-01,1.731227E+01,1.451900E-04,4.152700E-04,1.018400E-03,& + & 2.065200E-03,6.691469E-03,4.512177E-02,9.601881E-01,2.017922E+01,& + & 9.733200E-05,3.180600E-04,8.093100E-04,2.027800E-03,6.670600E-03,& + & 4.931907E-02,1.095467E+00,2.309217E+01,6.801600E-06,1.479000E-05,& + & 2.032700E-05,4.881800E-05,2.781327E-04,2.305169E-03,3.961541E-02,& + & 4.800488E-01,6.619300E-05,2.090200E-04,4.232100E-04,8.606800E-04,& + & 2.278022E-03,1.355653E-02,1.959793E-01,3.062086E+00,9.723700E-05,& + & 3.184000E-04,6.735400E-04,1.246900E-03,3.419338E-03,2.101963E-02,& + & 3.302347E-01,6.122584E+00,1.234900E-04,4.060300E-04,8.675500E-04,& + & 1.502900E-03,4.404002E-03,2.774201E-02,4.677120E-01,9.182519E+00,& + & 1.456100E-04,4.652100E-04,9.790600E-04,1.725200E-03,5.300638E-03,& + & 3.395311E-02,6.073621E-01,1.224225E+01,1.635900E-04,4.994500E-04,& + & 1.042400E-03,1.935900E-03,6.090658E-03,3.967003E-02,7.491673E-01,& + & 1.530001E+01,1.740500E-04,5.022000E-04,1.086200E-03,2.115300E-03,& + & 6.757340E-03,4.477841E-02,8.936175E-01,1.835375E+01,1.678200E-04,& + & 4.704500E-04,1.098200E-03,2.249300E-03,7.276892E-03,4.895072E-02,& + & 1.042712E+00,2.139342E+01,1.169100E-04,3.719000E-04,9.131600E-04,& + & 2.161300E-03,7.332116E-03,5.369490E-02,1.189564E+00,2.448337E+01/ + data absa( :,361:390) / & + & 1.517300E-05,3.099800E-05,5.011400E-05,1.215100E-04,6.981193E-04,& + & 7.363369E-03,1.492933E-01,2.280200E+00,6.007300E-05,2.063700E-04,& + & 4.165300E-04,7.939400E-04,2.877668E-03,1.662759E-02,2.826550E-01,& + & 3.108652E+00,7.552200E-05,2.794700E-04,5.906300E-04,1.155100E-03,& + & 3.713492E-03,2.145597E-02,3.608200E-01,4.882621E+00,8.460800E-05,& + & 3.353000E-04,7.353900E-04,1.416500E-03,4.234720E-03,2.511530E-02,& + & 4.190538E-01,6.971674E+00,8.939100E-05,3.648000E-04,8.512300E-04,& + & 1.614200E-03,4.560877E-03,2.796476E-02,4.642970E-01,9.268199E+00,& + & 9.104500E-05,3.820500E-04,9.217800E-04,1.691200E-03,4.748012E-03,& + & 3.008654E-02,5.110180E-01,1.158437E+01,9.001500E-05,3.865300E-04,& + & 9.430900E-04,1.660200E-03,4.814533E-03,3.124601E-02,5.612571E-01,& + & 1.389995E+01,8.508900E-05,3.476200E-04,8.539100E-04,1.619400E-03,& + & 4.626216E-03,3.131494E-02,6.161228E-01,1.621348E+01,6.291600E-05,& + & 1.824200E-04,5.149900E-04,1.199100E-03,3.697246E-03,2.806859E-02,& + & 6.843916E-01,1.853402E+01,1.711800E-05,3.609600E-05,5.727300E-05,& + & 1.340800E-04,7.654775E-04,7.682948E-03,1.535719E-01,2.288132E+00,& + & 7.216500E-05,2.307600E-04,4.565600E-04,8.830500E-04,3.144571E-03,& + & 1.795519E-02,3.007457E-01,3.272510E+00,9.097500E-05,3.124000E-04,& + & 6.406900E-04,1.297000E-03,4.048166E-03,2.337605E-02,3.890438E-01,& + & 5.272659E+00,1.020900E-04,3.728400E-04,7.969900E-04,1.602300E-03,& + & 4.620298E-03,2.751948E-02,4.536767E-01,7.640136E+00,1.082300E-04,& + & 4.147100E-04,9.429600E-04,1.793800E-03,4.988322E-03,3.080626E-02,& + & 5.080757E-01,1.018313E+01,1.103100E-04,4.343200E-04,1.036500E-03,& + & 1.866500E-03,5.222690E-03,3.325750E-02,5.656471E-01,1.272769E+01,& + & 1.091000E-04,4.412500E-04,1.044600E-03,1.803100E-03,5.353344E-03,& + & 3.473498E-02,6.269303E-01,1.527140E+01,1.045000E-04,4.037200E-04,& + & 9.322000E-04,1.726400E-03,5.219070E-03,3.504385E-02,6.931120E-01,& + & 1.781308E+01,8.037800E-05,2.236300E-04,6.088300E-04,1.371400E-03,& + & 4.186460E-03,3.186981E-02,7.734631E-01,2.036196E+01,1.933300E-05,& + & 4.203500E-05,6.403500E-05,1.504000E-04,8.418805E-04,8.004272E-03,& + & 1.577003E-01,2.294247E+00,8.477900E-05,2.573400E-04,4.986100E-04,& + & 9.790100E-04,3.402231E-03,1.931081E-02,3.185430E-01,3.422617E+00,& + & 1.071500E-04,3.482200E-04,7.065300E-04,1.428700E-03,4.381507E-03,& + & 2.528629E-02,4.159157E-01,5.649329E+00,1.204200E-04,4.142500E-04,& + & 8.698500E-04,1.786700E-03,4.985417E-03,2.994261E-02,4.872343E-01,& + & 8.278349E+00,1.286500E-04,4.657000E-04,1.011600E-03,2.003300E-03,& + & 5.410064E-03,3.362875E-02,5.522358E-01,1.103541E+01,1.325100E-04,& + & 4.915300E-04,1.146800E-03,2.033900E-03,5.708492E-03,3.638093E-02,& + & 6.208886E-01,1.379279E+01,1.319800E-04,4.953400E-04,1.154300E-03,& + & 1.962000E-03,5.887125E-03,3.818324E-02,6.932762E-01,1.654911E+01,& + & 1.257500E-04,4.624300E-04,1.009200E-03,1.861100E-03,5.795457E-03,& + & 3.873405E-02,7.709511E-01,1.930345E+01,1.018500E-04,2.668600E-04,& + & 7.055300E-04,1.528400E-03,4.691641E-03,3.565389E-02,8.633978E-01,& + & 2.206542E+01,2.202000E-05,4.802900E-05,7.218800E-05,1.690100E-04,& + & 9.275188E-04,8.365762E-03,1.616215E-01,2.298388E+00,9.788500E-05,& + & 2.833500E-04,5.461700E-04,1.084400E-03,3.656777E-03,2.070064E-02,& + & 3.354025E-01,3.568182E+00,1.240200E-04,3.862400E-04,7.809500E-04,& + & 1.563800E-03,4.709502E-03,2.721646E-02,4.418405E-01,6.010051E+00/ + data absa( :,391:420) / & + & 1.403100E-04,4.596800E-04,9.477200E-04,1.965100E-03,5.359496E-03,& + & 3.234292E-02,5.200267E-01,8.886644E+00,1.509100E-04,5.147300E-04,& + & 1.100300E-03,2.181200E-03,5.839233E-03,3.641040E-02,5.957669E-01,& + & 1.184607E+01,1.561500E-04,5.519600E-04,1.232200E-03,2.214600E-03,& + & 6.206269E-03,3.947829E-02,6.752501E-01,1.480568E+01,1.577500E-04,& + & 5.551700E-04,1.256200E-03,2.145900E-03,6.410029E-03,4.161449E-02,& + & 7.585976E-01,1.776456E+01,1.501000E-04,5.180700E-04,1.098800E-03,& + & 2.008600E-03,6.364373E-03,4.239027E-02,8.476385E-01,2.072158E+01,& + & 1.249500E-04,3.157700E-04,7.952600E-04,1.658900E-03,5.220864E-03,& + & 3.942861E-02,9.519717E-01,2.368614E+01,2.499000E-05,5.533100E-05,& + & 7.955000E-05,1.916500E-04,1.022264E-03,8.750591E-03,1.653380E-01,& + & 2.301530E+00,1.110200E-04,3.096600E-04,6.018400E-04,1.194100E-03,& + & 3.919101E-03,2.208577E-02,3.515201E-01,3.709777E+00,1.416700E-04,& + & 4.283700E-04,8.546400E-04,1.710600E-03,5.039053E-03,2.916278E-02,& + & 4.661776E-01,6.366665E+00,1.618100E-04,5.079300E-04,1.041600E-03,& + & 2.126000E-03,5.745581E-03,3.475215E-02,5.520375E-01,9.469661E+00,& + & 1.751100E-04,5.687500E-04,1.195600E-03,2.362400E-03,6.285770E-03,& + & 3.915811E-02,6.383378E-01,1.262473E+01,1.823100E-04,6.097100E-04,& + & 1.319000E-03,2.414200E-03,6.702172E-03,4.253710E-02,7.285728E-01,& + & 1.577866E+01,1.840600E-04,6.236800E-04,1.352800E-03,2.340500E-03,& + & 6.933082E-03,4.498576E-02,8.227908E-01,1.893188E+01,1.773800E-04,& + & 5.651100E-04,1.198400E-03,2.179200E-03,6.926537E-03,4.599328E-02,& + & 9.230108E-01,2.208138E+01,1.489100E-04,3.717100E-04,8.799700E-04,& + & 1.808500E-03,5.750781E-03,4.317981E-02,1.038869E+00,2.524382E+01,& + & 6.384300E-05,1.296400E-04,2.330600E-04,5.986800E-04,2.891391E-03,& + & 3.122757E-02,6.900831E-01,1.205068E+01,1.378500E-04,4.063200E-04,& + & 7.977200E-04,1.599300E-03,5.954791E-03,4.204260E-02,7.865225E-01,& + & 1.083072E+01,1.563500E-04,5.135800E-04,9.856600E-04,1.936400E-03,& + & 7.126028E-03,4.506919E-02,8.478662E-01,1.046434E+01,1.628700E-04,& + & 5.558100E-04,1.118300E-03,2.112900E-03,7.664896E-03,4.616400E-02,& + & 8.697408E-01,1.070939E+01,1.603700E-04,5.698000E-04,1.173700E-03,& + & 2.252400E-03,7.787726E-03,4.586615E-02,8.605697E-01,1.142461E+01,& + & 1.524800E-04,5.611200E-04,1.190200E-03,2.324600E-03,7.526513E-03,& + & 4.428962E-02,8.273250E-01,1.251433E+01,1.360600E-04,5.289200E-04,& + & 1.179300E-03,2.259400E-03,6.860519E-03,4.124258E-02,7.659368E-01,& + & 1.403984E+01,1.076100E-04,4.372800E-04,1.069800E-03,2.014600E-03,& + & 5.663355E-03,3.611869E-02,6.620099E-01,1.621729E+01,1.014400E-04,& + & 2.886500E-04,6.640700E-04,1.356800E-03,3.573015E-03,2.124703E-02,& + & 5.791992E-01,1.853128E+01,7.215600E-05,1.509500E-04,2.677100E-04,& + & 6.675200E-04,3.154133E-03,3.263905E-02,7.101610E-01,1.212311E+01,& + & 1.611100E-04,4.595300E-04,8.899300E-04,1.756700E-03,6.624916E-03,& + & 4.490528E-02,8.236790E-01,1.095706E+01,1.853000E-04,5.719900E-04,& + & 1.095600E-03,2.127700E-03,7.883619E-03,4.843577E-02,8.963238E-01,& + & 1.077258E+01,1.941900E-04,6.259600E-04,1.225900E-03,2.343500E-03,& + & 8.450820E-03,4.991345E-02,9.251303E-01,1.126235E+01,1.948200E-04,& + & 6.398800E-04,1.297100E-03,2.497700E-03,8.550723E-03,4.989122E-02,& + & 9.233504E-01,1.222317E+01,1.854800E-04,6.302300E-04,1.302000E-03,& + & 2.610900E-03,8.256921E-03,4.842427E-02,8.957417E-01,1.358824E+01/ + data absa( :,421:450) / & + & 1.657100E-04,5.912400E-04,1.278500E-03,2.568100E-03,7.540820E-03,& + & 4.537549E-02,8.334271E-01,1.547734E+01,1.313900E-04,5.010000E-04,& + & 1.203600E-03,2.260800E-03,6.236590E-03,4.011616E-02,7.321713E-01,& + & 1.798078E+01,1.260900E-04,3.561000E-04,7.571800E-04,1.517700E-03,& + & 4.110818E-03,2.427969E-02,6.600754E-01,2.054584E+01,8.163300E-05,& + & 1.757300E-04,3.029400E-04,7.490100E-04,3.455390E-03,3.408927E-02,& + & 7.297122E-01,1.218172E+01,1.862300E-04,5.181500E-04,9.804100E-04,& + & 1.922800E-03,7.315418E-03,4.775095E-02,8.592272E-01,1.107475E+01,& + & 2.146700E-04,6.340900E-04,1.212300E-03,2.332400E-03,8.641059E-03,& + & 5.197435E-02,9.423855E-01,1.106228E+01,2.299300E-04,6.969800E-04,& + & 1.347500E-03,2.595700E-03,9.226866E-03,5.379534E-02,9.792941E-01,& + & 1.177066E+01,2.314600E-04,7.154100E-04,1.416800E-03,2.770600E-03,& + & 9.312674E-03,5.394448E-02,9.851544E-01,1.296548E+01,2.209600E-04,& + & 7.051900E-04,1.427300E-03,2.894900E-03,8.989461E-03,5.255524E-02,& + & 9.608308E-01,1.462279E+01,1.965600E-04,6.606100E-04,1.400600E-03,& + & 2.871500E-03,8.202359E-03,4.952688E-02,8.980830E-01,1.685603E+01,& + & 1.575700E-04,5.711200E-04,1.328200E-03,2.474000E-03,6.829904E-03,& + & 4.408118E-02,8.022156E-01,1.964032E+01,1.535000E-04,4.286200E-04,& + & 8.583800E-04,1.668100E-03,4.628670E-03,2.736868E-02,7.409106E-01,& + & 2.244295E+01,9.241300E-05,2.025400E-04,3.418600E-04,8.426800E-04,& + & 3.791912E-03,3.553446E-02,7.484764E-01,1.223439E+01,2.139300E-04,& + & 5.740800E-04,1.083800E-03,2.103500E-03,8.002406E-03,5.060328E-02,& + & 8.934759E-01,1.118187E+01,2.489800E-04,7.014000E-04,1.332900E-03,& + & 2.565100E-03,9.388519E-03,5.550821E-02,9.868146E-01,1.133573E+01,& + & 2.668800E-04,7.648500E-04,1.485500E-03,2.867500E-03,9.995270E-03,& + & 5.771155E-02,1.031781E+00,1.225043E+01,2.683800E-04,7.950900E-04,& + & 1.551400E-03,3.055300E-03,1.007142E-02,5.803247E-02,1.043785E+00,& + & 1.368430E+01,2.571500E-04,7.848700E-04,1.577500E-03,3.176000E-03,& + & 9.724718E-03,5.673406E-02,1.023755E+00,1.560910E+01,2.290100E-04,& + & 7.376700E-04,1.530200E-03,3.174500E-03,8.855831E-03,5.369246E-02,& + & 9.594811E-01,1.819218E+01,1.864000E-04,6.434000E-04,1.429700E-03,& + & 2.720700E-03,7.416415E-03,4.800350E-02,8.715932E-01,2.121491E+01,& + & 1.825700E-04,5.019600E-04,9.773200E-04,1.857500E-03,5.119552E-03,& + & 3.035884E-02,8.210735E-01,2.424203E+01,1.042600E-04,2.373500E-04,& + & 3.794000E-04,9.424500E-04,4.178748E-03,3.734686E-02,7.658120E-01,& + & 1.227765E+01,2.453800E-04,6.343500E-04,1.200600E-03,2.287900E-03,& + & 8.692318E-03,5.354195E-02,9.262442E-01,1.128175E+01,2.833000E-04,& + & 7.747700E-04,1.465700E-03,2.808000E-03,1.014909E-02,5.899519E-02,& + & 1.030376E+00,1.158770E+01,3.029800E-04,8.410700E-04,1.633300E-03,& + & 3.149400E-03,1.077038E-02,6.156945E-02,1.082140E+00,1.271497E+01,& + & 3.075200E-04,8.736900E-04,1.707000E-03,3.354000E-03,1.084904E-02,& + & 6.214031E-02,1.100634E+00,1.437164E+01,2.941600E-04,8.729000E-04,& + & 1.726900E-03,3.481300E-03,1.045831E-02,6.098798E-02,1.082670E+00,& + & 1.658273E+01,2.651100E-04,8.203500E-04,1.683200E-03,3.448700E-03,& + & 9.512881E-03,5.791067E-02,1.018781E+00,1.948146E+01,2.183500E-04,& + & 7.135300E-04,1.555200E-03,2.953600E-03,8.028080E-03,5.184876E-02,& + & 9.399411E-01,2.272211E+01,2.128800E-04,5.737800E-04,1.110800E-03,& + & 2.069100E-03,5.605755E-03,3.329152E-02,9.002147E-01,2.596394E+01/ + data absa( :,451:480) / & + & 9.991400E-05,2.061100E-04,4.137000E-04,1.080500E-03,4.476772E-03,& + & 4.744668E-02,1.117969E+00,2.220485E+01,1.820400E-04,5.057900E-04,& + & 1.048100E-03,2.114800E-03,7.476285E-03,5.744319E-02,1.166108E+00,& + & 1.959076E+01,1.992300E-04,6.090600E-04,1.238200E-03,2.422000E-03,& + & 8.437470E-03,5.836442E-02,1.191673E+00,1.772785E+01,2.043200E-04,& + & 6.659800E-04,1.319300E-03,2.531000E-03,8.877775E-03,5.719877E-02,& + & 1.176667E+00,1.649251E+01,1.973300E-04,6.746300E-04,1.340500E-03,& + & 2.538900E-03,8.859071E-03,5.466018E-02,1.123840E+00,1.581765E+01,& + & 1.820100E-04,6.432500E-04,1.312800E-03,2.462500E-03,8.412664E-03,& + & 5.073558E-02,1.040208E+00,1.560996E+01,1.590400E-04,5.735800E-04,& + & 1.213600E-03,2.350900E-03,7.525082E-03,4.506190E-02,9.239678E-01,& + & 1.590628E+01,1.229900E-04,4.659400E-04,1.053000E-03,2.040100E-03,& + & 5.990322E-03,3.692955E-02,7.514467E-01,1.704557E+01,1.091000E-04,& + & 3.710500E-04,7.994700E-04,1.441700E-03,3.884520E-03,1.965177E-02,& + & 5.111001E-01,1.940455E+01,1.119900E-04,2.416800E-04,4.655100E-04,& + & 1.224800E-03,4.847152E-03,4.987006E-02,1.149416E+00,2.237755E+01,& + & 2.126500E-04,5.745700E-04,1.170200E-03,2.304300E-03,8.280297E-03,& + & 6.087043E-02,1.215458E+00,1.978606E+01,2.338900E-04,6.893000E-04,& + & 1.381300E-03,2.642100E-03,9.366506E-03,6.255558E-02,1.251443E+00,& + & 1.807000E+01,2.408900E-04,7.469500E-04,1.463600E-03,2.780500E-03,& + & 9.825930E-03,6.164578E-02,1.243387E+00,1.704779E+01,2.344200E-04,& + & 7.578800E-04,1.483100E-03,2.805100E-03,9.778702E-03,5.920567E-02,& + & 1.195063E+00,1.662636E+01,2.206900E-04,7.232400E-04,1.447200E-03,& + & 2.729000E-03,9.272059E-03,5.521167E-02,1.115941E+00,1.668111E+01,& + & 1.937100E-04,6.467600E-04,1.331700E-03,2.629800E-03,8.273811E-03,& + & 4.929977E-02,9.994261E-01,1.730720E+01,1.488200E-04,5.294300E-04,& + & 1.144700E-03,2.309400E-03,6.600953E-03,4.075744E-02,8.193155E-01,& + & 1.888107E+01,1.341100E-04,4.428300E-04,9.171600E-04,1.671800E-03,& + & 4.394938E-03,2.246519E-02,5.823205E-01,2.155013E+01,1.268700E-04,& + & 2.785500E-04,5.233700E-04,1.391900E-03,5.270290E-03,5.232007E-02,& + & 1.179856E+00,2.253064E+01,2.449900E-04,6.510900E-04,1.311400E-03,& + & 2.501800E-03,9.120879E-03,6.477311E-02,1.261293E+00,1.996750E+01,& + & 2.702600E-04,7.733600E-04,1.538000E-03,2.869400E-03,1.030409E-02,& + & 6.679207E-02,1.308901E+00,1.838622E+01,2.790900E-04,8.362400E-04,& + & 1.611100E-03,3.052200E-03,1.077241E-02,6.611783E-02,1.307604E+00,& + & 1.757173E+01,2.767500E-04,8.372100E-04,1.641700E-03,3.092100E-03,& + & 1.070688E-02,6.377427E-02,1.264830E+00,1.737716E+01,2.604400E-04,& + & 8.065200E-04,1.591000E-03,3.014000E-03,1.013238E-02,5.977920E-02,& + & 1.188772E+00,1.769863E+01,2.291500E-04,7.264800E-04,1.464100E-03,& + & 2.902400E-03,9.032739E-03,5.355862E-02,1.072172E+00,1.864527E+01,& + & 1.771800E-04,5.913200E-04,1.258500E-03,2.576300E-03,7.196721E-03,& + & 4.457938E-02,8.842171E-01,2.064555E+01,1.602600E-04,5.152300E-04,& + & 1.057500E-03,1.864400E-03,4.910496E-03,2.531011E-02,6.529742E-01,& + & 2.358206E+01,1.426100E-04,3.293400E-04,5.823600E-04,1.559100E-03,& + & 5.776636E-03,5.478945E-02,1.209465E+00,2.266451E+01,2.810100E-04,& + & 7.284300E-04,1.461200E-03,2.719300E-03,9.989403E-03,6.886112E-02,& + & 1.305476E+00,2.012691E+01,3.114100E-04,8.592200E-04,1.698100E-03,& + & 3.131900E-03,1.126180E-02,7.103932E-02,1.364304E+00,1.868258E+01/ + data absa( :,481:510) / & + & 3.225500E-04,9.221100E-04,1.782900E-03,3.341700E-03,1.172459E-02,& + & 7.063996E-02,1.369995E+00,1.805855E+01,3.194800E-04,9.282900E-04,& + & 1.801500E-03,3.399200E-03,1.163744E-02,6.833430E-02,1.332590E+00,& + & 1.808783E+01,3.015000E-04,8.920700E-04,1.745200E-03,3.329200E-03,& + & 1.099739E-02,6.426422E-02,1.259094E+00,1.867387E+01,2.661200E-04,& + & 8.135900E-04,1.606900E-03,3.186500E-03,9.816913E-03,5.785497E-02,& + & 1.141683E+00,1.993549E+01,2.075200E-04,6.596900E-04,1.376100E-03,& + & 2.838800E-03,7.799270E-03,4.844448E-02,9.478248E-01,2.232862E+01,& + & 1.860100E-04,5.914600E-04,1.201000E-03,2.095500E-03,5.406894E-03,& + & 2.815613E-02,7.234845E-01,2.550873E+01,1.578900E-04,3.762400E-04,& + & 6.713100E-04,1.715000E-03,6.361119E-03,5.750491E-02,1.238177E+00,& + & 2.277701E+01,3.192900E-04,8.076400E-04,1.625400E-03,2.947300E-03,& + & 1.091169E-02,7.295177E-02,1.348303E+00,2.026979E+01,3.551300E-04,& + & 9.481600E-04,1.881100E-03,3.398000E-03,1.225343E-02,7.541209E-02,& + & 1.418264E+00,1.895057E+01,3.660200E-04,1.017600E-03,1.966600E-03,& + & 3.655100E-03,1.270962E-02,7.516823E-02,1.430305E+00,1.852182E+01,& + & 3.628200E-04,1.026700E-03,1.974400E-03,3.715800E-03,1.259807E-02,& + & 7.284238E-02,1.397494E+00,1.877702E+01,3.441000E-04,9.858900E-04,& + & 1.913700E-03,3.670800E-03,1.188702E-02,6.870086E-02,1.327917E+00,& + & 1.960331E+01,3.057700E-04,9.000300E-04,1.767700E-03,3.490700E-03,& + & 1.060584E-02,6.210213E-02,1.207260E+00,2.120022E+01,2.409700E-04,& + & 7.336000E-04,1.510500E-03,3.087200E-03,8.423125E-03,5.231048E-02,& + & 1.010769E+00,2.393202E+01,2.135200E-04,6.637300E-04,1.342800E-03,& + & 2.349400E-03,5.944175E-03,3.091110E-02,7.939337E-01,2.734402E+01,& + & 1.112200E-04,2.369000E-04,5.054800E-04,1.389700E-03,5.297233E-03,& + & 5.376604E-02,1.340819E+00,3.035808E+01,1.902200E-04,5.234500E-04,& + & 1.121700E-03,2.328400E-03,7.981710E-03,6.263084E-02,1.363049E+00,& + & 2.672434E+01,2.056800E-04,6.158300E-04,1.296400E-03,2.556200E-03,& + & 8.716071E-03,6.237943E-02,1.362280E+00,2.384402E+01,2.079800E-04,& + & 6.620600E-04,1.378500E-03,2.611400E-03,8.941717E-03,5.971481E-02,& + & 1.320573E+00,2.160474E+01,2.001300E-04,6.730800E-04,1.369200E-03,& + & 2.575600E-03,8.760028E-03,5.586376E-02,1.241289E+00,1.991368E+01,& + & 1.836900E-04,6.441100E-04,1.293500E-03,2.457900E-03,8.181400E-03,& + & 5.063051E-02,1.128400E+00,1.872459E+01,1.575600E-04,5.710800E-04,& + & 1.170500E-03,2.232800E-03,7.230772E-03,4.405254E-02,9.824477E-01,& + & 1.803049E+01,1.203700E-04,4.459400E-04,9.670400E-04,1.890700E-03,& + & 5.657789E-03,3.488261E-02,7.792570E-01,1.819267E+01,1.009800E-04,& + & 3.696600E-04,8.268000E-04,1.446000E-03,3.944692E-03,1.779677E-02,& + & 4.487434E-01,2.025528E+01,1.250000E-04,2.763600E-04,5.732000E-04,& + & 1.569700E-03,5.704284E-03,5.656104E-02,1.377620E+00,3.064615E+01,& + & 2.215600E-04,5.969300E-04,1.256000E-03,2.546200E-03,8.764939E-03,& + & 6.666772E-02,1.416694E+00,2.701940E+01,2.404600E-04,6.982400E-04,& + & 1.461200E-03,2.777300E-03,9.621304E-03,6.665052E-02,1.426719E+00,& + & 2.427330E+01,2.434700E-04,7.508600E-04,1.529000E-03,2.873900E-03,& + & 9.849550E-03,6.435795E-02,1.390895E+00,2.223300E+01,2.376400E-04,& + & 7.537200E-04,1.513300E-03,2.851500E-03,9.659045E-03,6.048072E-02,& + & 1.315058E+00,2.078848E+01,2.211600E-04,7.212900E-04,1.434500E-03,& + & 2.712700E-03,9.043181E-03,5.507027E-02,1.205751E+00,1.985120E+01/ + data absa( :,511:540) / & + & 1.927200E-04,6.401500E-04,1.299200E-03,2.470200E-03,7.973424E-03,& + & 4.815908E-02,1.058054E+00,1.948523E+01,1.464300E-04,5.041700E-04,& + & 1.059500E-03,2.131700E-03,6.246423E-03,3.835630E-02,8.475083E-01,& + & 2.006218E+01,1.239000E-04,4.351900E-04,9.596100E-04,1.671000E-03,& + & 4.411250E-03,2.045527E-02,5.111249E-01,2.251974E+01,1.405600E-04,& + & 3.247500E-04,6.385300E-04,1.756400E-03,6.199230E-03,5.943108E-02,& + & 1.413536E+00,3.090172E+01,2.548900E-04,6.727400E-04,1.412500E-03,& + & 2.773600E-03,9.606603E-03,7.071898E-02,1.468127E+00,2.728957E+01,& + & 2.776400E-04,7.797600E-04,1.637800E-03,3.036800E-03,1.054463E-02,& + & 7.133455E-02,1.487830E+00,2.467129E+01,2.812200E-04,8.418500E-04,& + & 1.691800E-03,3.157500E-03,1.079182E-02,6.916119E-02,1.458669E+00,& + & 2.281901E+01,2.790500E-04,8.405100E-04,1.666300E-03,3.133600E-03,& + & 1.058318E-02,6.505030E-02,1.387728E+00,2.159925E+01,2.588600E-04,& + & 8.011000E-04,1.590900E-03,2.993200E-03,9.905686E-03,5.948523E-02,& + & 1.280309E+00,2.092484E+01,2.263600E-04,7.203600E-04,1.428300E-03,& + & 2.731600E-03,8.720056E-03,5.225681E-02,1.131421E+00,2.087079E+01,& + & 1.735200E-04,5.677100E-04,1.164800E-03,2.368900E-03,6.837474E-03,& + & 4.188976E-02,9.124361E-01,2.186292E+01,1.466400E-04,5.017300E-04,& + & 1.078900E-03,1.916500E-03,4.900820E-03,2.329452E-02,5.735230E-01,& + & 2.466013E+01,1.585800E-04,3.774200E-04,7.136700E-04,1.937300E-03,& + & 6.790356E-03,6.252643E-02,1.448395E+00,3.112576E+01,2.902100E-04,& + & 7.535400E-04,1.588800E-03,3.002800E-03,1.050882E-02,7.512140E-02,& + & 1.517219E+00,2.753409E+01,3.184100E-04,8.695800E-04,1.819400E-03,& + & 3.302600E-03,1.151317E-02,7.602591E-02,1.547427E+00,2.503662E+01,& + & 3.255100E-04,9.297100E-04,1.874500E-03,3.447300E-03,1.176977E-02,& + & 7.397146E-02,1.524820E+00,2.336330E+01,3.190300E-04,9.356700E-04,& + & 1.835800E-03,3.419700E-03,1.153260E-02,6.970718E-02,1.457828E+00,& + & 2.236870E+01,2.984800E-04,8.903400E-04,1.747100E-03,3.288500E-03,& + & 1.077252E-02,6.389982E-02,1.352641E+00,2.194815E+01,2.625400E-04,& + & 7.994200E-04,1.569100E-03,3.010500E-03,9.485016E-03,5.629615E-02,& + & 1.201964E+00,2.220467E+01,2.026500E-04,6.351100E-04,1.286200E-03,& + & 2.597500E-03,7.446721E-03,4.544161E-02,9.756102E-01,2.358675E+01,& + & 1.706100E-04,5.674300E-04,1.203900E-03,2.173400E-03,5.413889E-03,& + & 2.586444E-02,6.364052E-01,2.669404E+01,1.739800E-04,4.265600E-04,& + & 8.220700E-04,2.110300E-03,7.474688E-03,6.584209E-02,1.482300E+00,& + & 3.132309E+01,3.275000E-04,8.346000E-04,1.774200E-03,3.286100E-03,& + & 1.146346E-02,7.970370E-02,1.565166E+00,2.774693E+01,3.620700E-04,& + & 9.619700E-04,2.010300E-03,3.612600E-03,1.253136E-02,8.075772E-02,& + & 1.605538E+00,2.536932E+01,3.688000E-04,1.027600E-03,2.060300E-03,& + & 3.757900E-03,1.280192E-02,7.879432E-02,1.588956E+00,2.387610E+01,& + & 3.605800E-04,1.034800E-03,2.019300E-03,3.747200E-03,1.252184E-02,& + & 7.445961E-02,1.524999E+00,2.310774E+01,3.390700E-04,9.879500E-04,& + & 1.919400E-03,3.598300E-03,1.167783E-02,6.831259E-02,1.423295E+00,& + & 2.291974E+01,2.997000E-04,8.841400E-04,1.724400E-03,3.313700E-03,& + & 1.026762E-02,6.026183E-02,1.269465E+00,2.349984E+01,2.340100E-04,& + & 7.091700E-04,1.419900E-03,2.824300E-03,8.062736E-03,4.894427E-02,& + & 1.037568E+00,2.524054E+01,1.957500E-04,6.318100E-04,1.351400E-03,& + & 2.424100E-03,5.963829E-03,2.836232E-02,6.988181E-01,2.864024E+01/ + data absa( :,541:570) / & + & 9.998200E-05,2.155900E-04,5.042000E-04,1.403400E-03,5.178173E-03,& + & 4.867573E-02,1.286107E+00,3.324118E+01,1.678600E-04,4.703400E-04,& + & 1.031700E-03,2.207300E-03,7.474700E-03,5.677799E-02,1.315180E+00,& + & 2.932436E+01,1.815700E-04,5.531800E-04,1.196500E-03,2.342300E-03,& + & 8.018870E-03,5.648873E-02,1.310493E+00,2.625790E+01,1.831100E-04,& + & 5.876400E-04,1.262700E-03,2.394000E-03,8.056952E-03,5.387733E-02,& + & 1.262773E+00,2.385272E+01,1.773200E-04,5.924600E-04,1.242500E-03,& + & 2.335200E-03,7.798202E-03,5.014632E-02,1.181674E+00,2.193470E+01,& + & 1.625700E-04,5.734200E-04,1.162300E-03,2.228900E-03,7.193235E-03,& + & 4.513960E-02,1.071694E+00,2.045046E+01,1.410700E-04,5.046700E-04,& + & 1.039700E-03,1.986100E-03,6.307397E-03,3.862425E-02,9.296787E-01,& + & 1.944903E+01,1.068400E-04,3.918400E-04,8.455600E-04,1.645300E-03,& + & 4.892464E-03,3.031003E-02,7.339015E-01,1.922842E+01,8.828200E-05,& + & 3.419800E-04,7.615600E-04,1.364100E-03,3.704736E-03,1.596573E-02,& + & 3.929155E-01,2.104335E+01,1.120800E-04,2.515200E-04,5.680800E-04,& + & 1.546800E-03,5.612913E-03,5.135209E-02,1.321164E+00,3.358983E+01,& + & 1.948900E-04,5.342200E-04,1.167000E-03,2.399300E-03,8.162741E-03,& + & 6.056636E-02,1.366259E+00,2.969656E+01,2.120700E-04,6.219500E-04,& + & 1.346300E-03,2.571500E-03,8.768489E-03,6.038912E-02,1.371423E+00,& + & 2.677874E+01,2.142000E-04,6.665900E-04,1.400900E-03,2.635300E-03,& + & 8.821364E-03,5.811938E-02,1.329061E+00,2.457723E+01,2.085600E-04,& + & 6.727200E-04,1.370100E-03,2.590500E-03,8.545984E-03,5.440567E-02,& + & 1.251830E+00,2.289397E+01,1.950100E-04,6.385300E-04,1.295600E-03,& + & 2.468900E-03,7.911336E-03,4.910098E-02,1.144717E+00,2.167105E+01,& + & 1.694200E-04,5.706800E-04,1.156700E-03,2.203500E-03,6.948529E-03,& + & 4.233031E-02,1.000202E+00,2.099935E+01,1.289600E-04,4.443600E-04,& + & 9.302400E-04,1.851600E-03,5.405338E-03,3.337738E-02,7.969640E-01,& + & 2.118771E+01,1.070600E-04,3.945600E-04,8.805000E-04,1.559500E-03,& + & 4.168025E-03,1.833398E-02,4.483040E-01,2.341011E+01,1.258000E-04,& + & 3.030200E-04,6.183800E-04,1.705400E-03,6.091807E-03,5.425327E-02,& + & 1.354819E+00,3.390576E+01,2.239000E-04,6.012700E-04,1.321400E-03,& + & 2.600200E-03,8.908679E-03,6.437018E-02,1.415789E+00,3.003586E+01,& + & 2.436800E-04,6.943700E-04,1.518000E-03,2.804100E-03,9.560617E-03,& + & 6.464654E-02,1.429722E+00,2.726096E+01,2.489900E-04,7.468600E-04,& + & 1.550200E-03,2.900100E-03,9.624507E-03,6.244249E-02,1.393480E+00,& + & 2.525398E+01,2.442600E-04,7.524900E-04,1.502000E-03,2.872600E-03,& + & 9.335121E-03,5.856110E-02,1.321171E+00,2.378595E+01,2.269500E-04,& + & 7.118300E-04,1.436100E-03,2.702000E-03,8.679811E-03,5.313984E-02,& + & 1.214517E+00,2.283841E+01,1.979600E-04,6.400400E-04,1.278000E-03,& + & 2.443700E-03,7.597439E-03,4.597866E-02,1.068623E+00,2.247867E+01,& + & 1.527300E-04,5.016200E-04,1.027200E-03,2.050500E-03,5.927922E-03,& + & 3.645834E-02,8.582746E-01,2.305861E+01,1.265700E-04,4.471400E-04,& + & 9.996700E-04,1.779800E-03,4.649930E-03,2.062628E-02,5.040239E-01,& + & 2.565695E+01,1.411500E-04,3.424200E-04,7.052700E-04,1.874600E-03,& + & 6.630457E-03,5.748386E-02,1.387427E+00,3.419167E+01,2.538200E-04,& + & 6.708100E-04,1.490800E-03,2.834400E-03,9.689323E-03,6.860050E-02,& + & 1.463736E+00,3.033436E+01,2.807900E-04,7.727300E-04,1.679400E-03,& + & 3.075800E-03,1.040896E-02,6.904505E-02,1.486262E+00,2.770509E+01/ + data absa( :,571:585) / & + & 2.849900E-04,8.277400E-04,1.710200E-03,3.188600E-03,1.047901E-02,& + & 6.682930E-02,1.456794E+00,2.587327E+01,2.784300E-04,8.353300E-04,& + & 1.662100E-03,3.154300E-03,1.015362E-02,6.277970E-02,1.387529E+00,& + & 2.464212E+01,2.607200E-04,7.949900E-04,1.579300E-03,2.959100E-03,& + & 9.475668E-03,5.706065E-02,1.282826E+00,2.394631E+01,2.290300E-04,& + & 7.100400E-04,1.414200E-03,2.701000E-03,8.268305E-03,4.957925E-02,& + & 1.134236E+00,2.390423E+01,1.790500E-04,5.639400E-04,1.135500E-03,& + & 2.247300E-03,6.457677E-03,3.948441E-02,9.185197E-01,2.484942E+01,& + & 1.471100E-04,5.010500E-04,1.126700E-03,2.018500E-03,5.149877E-03,& + & 2.296268E-02,5.593285E-01,2.779686E+01,1.546500E-04,3.822000E-04,& + & 8.124700E-04,2.049300E-03,7.241369E-03,6.098582E-02,1.419679E+00,& + & 3.443785E+01,2.879800E-04,7.457500E-04,1.634000E-03,3.129000E-03,& + & 1.052263E-02,7.303899E-02,1.510345E+00,3.060460E+01,3.177400E-04,& + & 8.538300E-04,1.854900E-03,3.371100E-03,1.131799E-02,7.354575E-02,& + & 1.542424E+00,2.810153E+01,3.225800E-04,9.103700E-04,1.887000E-03,& + & 3.504700E-03,1.138680E-02,7.131129E-02,1.517696E+00,2.646653E+01,& + & 3.143100E-04,9.230300E-04,1.837400E-03,3.462600E-03,1.102358E-02,& + & 6.711617E-02,1.452452E+00,2.544731E+01,2.943000E-04,8.858700E-04,& + & 1.729800E-03,3.252900E-03,1.029844E-02,6.103974E-02,1.348631E+00,& + & 2.501162E+01,2.613300E-04,7.855900E-04,1.560600E-03,2.961700E-03,& + & 8.988309E-03,5.312738E-02,1.197416E+00,2.528120E+01,2.049900E-04,& + & 6.320700E-04,1.253400E-03,2.446600E-03,7.004873E-03,4.245691E-02,& + & 9.770258E-01,2.657424E+01,1.680200E-04,5.547500E-04,1.251000E-03,& + & 2.285500E-03,5.653684E-03,2.525732E-02,6.144178E-01,2.984649E+01/ + +! --- the array selfref contains the coefficient of the water vapor +! self-continuum (including the energy term). the first index +! refers to temperature in 7.2 degree increments. for instance, +! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +! etc. the second index runs over the g-channel (1 to NG12=8). + + data selfref(:, :) / & + & 2.378790E-02,3.106250E-02,5.191030E-02,9.124440E-02,1.177956E-01,& + & 1.310288E-01,1.311474E-01,1.558647E-01,2.107190E-02,2.826640E-02,& + & 4.800040E-02,8.386750E-02,1.100793E-01,1.219327E-01,1.224211E-01,& + & 1.453039E-01,1.866600E-02,2.572200E-02,4.438500E-02,7.708700E-02,& + & 1.028693E-01,1.134681E-01,1.142768E-01,1.354682E-01,1.653480E-02,& + & 2.340660E-02,4.104190E-02,7.085470E-02,9.613181E-02,1.055911E-01,& + & 1.066752E-01,1.263074E-01,1.464690E-02,2.129970E-02,3.795060E-02,& + & 6.512630E-02,8.983565E-02,9.826087E-02,9.958016E-02,1.177747E-01,& + & 1.297460E-02,1.938240E-02,3.509220E-02,5.986100E-02,8.395225E-02,& + & 9.143987E-02,9.295790E-02,1.098263E-01,1.149320E-02,1.763770E-02,& + & 3.244910E-02,5.502140E-02,7.845443E-02,8.509231E-02,8.677679E-02,& + & 1.024212E-01,1.018100E-02,1.605000E-02,3.000500E-02,5.057300E-02,& + & 7.331690E-02,7.918540E-02,8.100742E-02,9.552247E-02,9.018580E-03,& + & 1.460530E-02,2.774500E-02,4.648430E-02,6.851601E-02,7.368858E-02,& + & 7.562235E-02,8.909458E-02,7.988880E-03,1.329060E-02,2.565530E-02,& + & 4.272620E-02,6.402972E-02,6.857349E-02,7.059593E-02,8.310508E-02/ + + + data forref(:, :) / & + & 1.473900E-04,3.168600E-04,8.597300E-04,1.903900E-03,3.403156E-03,& + & 3.789137E-03,3.811255E-03,4.611905E-03,1.939700E-04,3.632200E-04,& + & 8.979700E-04,2.100100E-03,3.274082E-03,3.731411E-03,3.673231E-03,& + & 4.491757E-03,3.150600E-04,7.368700E-04,1.967800E-03,2.553100E-03,& + & 2.809680E-03,2.826561E-03,2.732563E-03,4.293922E-03,8.819600E-04,& + & 2.112500E-03,2.804200E-03,2.889100E-03,2.175546E-03,1.318010E-03,& + & 1.195556E-03,1.420311E-03 / + + + data fracrefa(:,:) / & + & 1.398400e-01,1.680900e-01,1.807200e-01,1.540000e-01,2.230890e-01,& + & 9.834400e-02,3.391920e-02,2.006482e-03,1.274500e-01,1.610700e-01,& + & 1.656800e-01,1.543600e-01,2.334900e-01,1.122620e-01,4.327270e-02,& + & 2.428322e-03,1.218100e-01,1.540400e-01,1.654000e-01,1.525500e-01,& + & 2.362160e-01,1.203120e-01,4.654830e-02,3.132630e-03,1.179400e-01,& + & 1.486400e-01,1.631600e-01,1.534100e-01,2.365160e-01,1.275390e-01,& + & 4.907250e-02,3.733200e-03,1.163500e-01,1.434200e-01,1.592400e-01,& + & 1.567000e-01,2.344870e-01,1.340520e-01,5.144970e-02,4.297800e-03,& + & 1.149700e-01,1.375100e-01,1.558700e-01,1.590400e-01,2.329900e-01,& + & 1.412040e-01,5.349550e-02,4.919110e-03,1.133100e-01,1.301500e-01,& + & 1.557400e-01,1.548900e-01,2.344300e-01,1.499220e-01,5.578040e-02,& + & 5.772500e-03,1.099300e-01,1.232000e-01,1.489300e-01,1.457300e-01,& + & 2.432300e-01,1.632680e-01,5.974010e-02,5.971810e-03,1.202800e-01,& + & 1.209100e-01,1.309800e-01,1.344200e-01,2.531300e-01,1.655670e-01,& + & 6.874300e-02,5.972500e-03 / + +!........................................! + end module module_radlw_kgb12 ! +!========================================! + + +!> This module sets up absorption coefficients for band 13: 2080-2250 +!! cm-1 (low - h2o, n2o; high - /) +!========================================! + module module_radlw_kgb13 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG13 +! + implicit none +! + private +! +!> msa13=585 + integer, public :: MSA13 +!> msf13=10 + integer, public :: MSF13 +!> mfr13=4 + integer, public :: MFR13 +!> maf13=9 + integer, public :: MAF13 +!> mmo13=19 + integer, public :: MMO13 + parameter (MSA13=585, MSF13=10, MFR13=4, MAF13=9, MMO13=19) + + +!> the array absa(NG13,585) = ka(NG13,9,5,13) contains absorption coefs +!! at the NG13=4 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different column +!! amount ratios, as expressed through the binary species parameter eta, +!! defined as eta = gas1/(gas1+(rat)*gas2), where rat is the ratio of +!! the reference mls column amount value of gas1 to that of gas2. the +!! 2nd index in the array, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that the +!! data are for the corresponding temperature of tref-30, tref-15, tref, +!! tref+15, and tref+30, respectively. the third index, jp, runs from +!! 1 to 13 and refers to the reference pressure level (e.g. jp = 1 is +!! for a pressure of 1053.63 mb). the fourth index, ig, goes from 1 to +!! NG13=4, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG13,MSA13) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG13=4). + real (kind=kind_phys), public :: forref(NG13,MFR13) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG13=4). + real (kind=kind_phys), public :: selfref(NG13,MSF13) + +!> planck fraction mapping level : p=473.4280 mb, t = 259.83 k + real (kind=kind_phys), public :: fracrefa(NG13,MAF13) + +!> planck fraction mapping level : p=4.758820 mb, t = 250.85 k + real (kind=kind_phys), public :: fracrefb(NG13) + +!> the array ka_mxxx contains the absorption coefficient for a minor +!! species at the NG13=4 chosen g-values for a reference pressure +!! level below 100~ mb. the first index in the array, js, runs from +!! 1 to 9, and corresponds to different gas column amount ratios, as +!! expressed through the binary species parameter eta, defined as +!! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +!! reference mls column amount value of gas1 to that of gas2. the +!! second index refers to temperature in 7.2 degree increments. for +!! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers +!! to 195.2, etc. the third index runs over the g-channel (1 to NG13=4). + real (kind=kind_phys), public :: ka_mco2(NG13,MAF13,MMO13) + + real (kind=kind_phys), public :: ka_mco(NG13,MAF13,MMO13) + real (kind=kind_phys), public :: kb_mo3(NG13,MMO13) + + data absa(:, 1: 60) / & + & 4.181661E-06,3.211034E-04,2.195423E-03,1.543183E-03,3.214366E-05,& + & 4.060939E-04,2.080652E-03,4.585020E-03,4.765304E-05,4.280268E-04,& + & 1.977899E-03,9.920238E-03,5.911808E-05,4.253284E-04,1.903078E-03,& + & 1.570819E-02,6.931263E-05,4.049439E-04,1.815717E-03,2.232517E-02,& + & 7.908138E-05,3.708365E-04,1.757545E-03,2.887761E-02,9.036191E-05,& + & 3.226245E-04,1.720479E-03,3.544069E-02,1.114686E-04,2.628612E-04,& + & 1.796007E-03,3.998152E-02,5.032601E-05,2.407166E-04,2.000267E-03,& + & 4.451846E-02,4.802256E-06,3.296261E-04,2.175027E-03,1.467103E-03,& + & 4.059485E-05,4.361121E-04,2.133376E-03,6.125657E-03,6.014385E-05,& + & 4.661314E-04,2.100001E-03,1.370663E-02,7.479411E-05,4.727167E-04,& + & 2.082117E-03,2.196231E-02,8.705325E-05,4.581574E-04,2.062027E-03,& + & 3.101869E-02,9.697255E-05,4.315132E-04,2.079171E-03,3.989655E-02,& + & 1.071910E-04,3.901176E-04,2.121611E-03,4.877399E-02,1.223300E-04,& + & 3.248774E-04,2.364576E-03,5.467676E-02,6.791983E-05,3.238417E-04,& + & 2.582090E-03,6.194536E-02,5.591471E-06,3.392227E-04,2.151205E-03,& + & 1.413657E-03,5.054173E-05,4.684980E-04,2.192511E-03,8.223977E-03,& + & 7.456732E-05,5.102071E-04,2.250261E-03,1.835431E-02,9.322567E-05,& + & 5.263310E-04,2.299045E-03,2.966883E-02,1.074906E-04,5.208726E-04,& + & 2.356216E-03,4.169009E-02,1.177762E-04,5.032056E-04,2.458120E-03,& + & 5.347278E-02,1.245477E-04,4.715095E-04,2.603437E-03,6.508177E-02,& + & 1.340408E-04,4.140670E-04,3.035438E-03,7.232126E-02,9.007918E-05,& + & 4.210990E-04,3.265251E-03,8.341365E-02,6.486887E-06,3.496334E-04,& + & 2.123540E-03,1.402660E-03,6.149155E-05,5.055652E-04,2.267741E-03,& + & 1.070151E-02,9.127024E-05,5.608029E-04,2.419203E-03,2.407558E-02,& + & 1.139203E-04,5.893131E-04,2.551903E-03,3.889847E-02,1.305840E-04,& + & 5.926007E-04,2.703772E-03,5.444419E-02,1.416816E-04,5.857449E-04,& + & 2.910198E-03,6.955228E-02,1.477050E-04,5.609245E-04,3.212109E-03,& + & 8.375696E-02,1.520237E-04,5.177416E-04,3.833089E-03,9.298220E-02,& + & 1.165842E-04,5.364938E-04,4.066395E-03,1.088806E-01,7.615213E-06,& + & 3.602935E-04,2.093633E-03,1.414907E-03,7.404270E-05,5.452772E-04,& + & 2.364610E-03,1.353753E-02,1.100742E-04,6.189710E-04,2.621927E-03,& + & 3.063309E-02,1.368126E-04,6.603405E-04,2.848887E-03,4.965496E-02,& + & 1.555867E-04,6.753722E-04,3.126716E-03,6.893937E-02,1.680942E-04,& + & 6.809657E-04,3.456977E-03,8.785199E-02,1.746534E-04,6.638613E-04,& + & 3.932137E-03,1.051651E-01,1.793797E-04,6.351687E-04,4.761656E-03,& + & 1.166694E-01,1.474916E-04,6.695217E-04,5.019512E-03,1.379246E-01,& + & 5.906251E-06,4.495596E-04,3.384777E-03,3.660559E-03,3.111753E-05,& + & 5.158008E-04,3.136084E-03,5.002477E-03,4.428771E-05,5.208023E-04,& + & 2.881940E-03,8.862291E-03,5.421091E-05,4.999529E-04,2.627071E-03,& + & 1.367889E-02,6.108743E-05,4.615104E-04,2.377975E-03,1.907643E-02,& + & 6.745290E-05,4.087401E-04,2.098409E-03,2.548022E-02,7.470394E-05,& + & 3.405732E-04,1.853119E-03,3.173150E-02,9.233562E-05,2.448123E-04,& + & 1.667915E-03,3.737723E-02,4.152218E-05,2.069681E-04,1.842784E-03,& + & 3.772655E-02,6.820636E-06,4.609427E-04,3.390203E-03,2.957009E-03,& + & 3.933662E-05,5.493252E-04,3.191000E-03,6.013490E-03,5.649399E-05,& + & 5.632931E-04,2.981367E-03,1.222622E-02,6.877291E-05,5.475469E-04,& + & 2.791951E-03,1.921644E-02,7.789219E-05,5.136733E-04,2.588666E-03,& + & 2.715539E-02,8.518794E-05,4.640286E-04,2.379862E-03,3.575558E-02/ + data absa(:, 61:120) / & + & 9.050723E-05,4.032396E-04,2.197262E-03,4.432473E-02,9.927047E-05,& + & 3.156367E-04,2.108087E-03,5.195427E-02,5.578606E-05,2.800776E-04,& + & 2.373442E-03,5.395719E-02,7.857036E-06,4.741452E-04,3.374337E-03,& + & 2.565709E-03,4.899627E-05,5.863453E-04,3.251957E-03,7.539301E-03,& + & 7.043397E-05,6.108359E-04,3.111826E-03,1.639335E-02,8.599379E-05,& + & 6.015057E-04,2.991452E-03,2.620626E-02,9.747179E-05,5.737990E-04,& + & 2.849353E-03,3.714319E-02,1.055054E-04,5.310969E-04,2.719136E-03,& + & 4.848093E-02,1.095094E-04,4.769337E-04,2.618134E-03,5.982957E-02,& + & 1.112292E-04,3.971118E-04,2.660099E-03,6.955342E-02,7.355090E-05,& + & 3.707607E-04,3.008274E-03,7.396080E-02,9.124237E-06,4.886107E-04,& + & 3.342071E-03,2.418185E-03,6.032777E-05,6.266101E-04,3.315938E-03,& + & 9.679183E-03,8.653097E-05,6.639270E-04,3.265184E-03,2.156759E-02,& + & 1.055456E-04,6.650628E-04,3.232988E-03,3.456231E-02,1.198551E-04,& + & 6.442812E-04,3.163397E-03,4.909292E-02,1.284493E-04,6.087001E-04,& + & 3.126494E-03,6.374508E-02,1.316449E-04,5.625355E-04,3.126657E-03,& + & 7.828942E-02,1.312716E-04,4.848313E-04,3.326012E-03,9.047039E-02,& + & 9.500327E-05,4.787583E-04,3.759785E-03,9.789186E-02,1.072951E-05,& + & 5.015058E-04,3.311845E-03,2.274260E-03,7.273866E-05,6.721678E-04,& + & 3.385545E-03,1.239175E-02,1.045906E-04,7.229001E-04,3.448145E-03,& + & 2.769252E-02,1.278259E-04,7.374686E-04,3.478184E-03,4.505990E-02,& + & 1.445191E-04,7.271454E-04,3.534401E-03,6.302214E-02,1.537370E-04,& + & 6.989592E-04,3.608824E-03,8.152906E-02,1.568110E-04,6.593432E-04,& + & 3.721816E-03,9.994440E-02,1.532412E-04,5.870150E-04,4.118404E-03,& + & 1.147037E-01,1.200224E-04,6.024342E-04,4.642811E-03,1.257949E-01,& + & 1.077627E-05,8.312338E-04,6.955877E-03,1.245355E-02,3.438780E-05,& + & 8.510416E-04,6.231387E-03,1.142918E-02,4.528202E-05,8.181432E-04,& + & 5.538603E-03,1.202702E-02,5.301412E-05,7.535917E-04,4.844136E-03,& + & 1.379502E-02,5.877696E-05,6.690901E-04,4.141200E-03,1.640945E-02,& + & 6.142459E-05,5.685953E-04,3.433672E-03,1.973524E-02,6.245671E-05,& + & 4.498568E-04,2.628275E-03,2.540773E-02,6.743868E-05,2.999098E-04,& + & 1.862525E-03,3.121525E-02,3.662564E-05,1.795822E-04,1.616937E-03,& + & 2.849977E-02,1.244924E-05,8.525919E-04,7.008429E-03,1.034016E-02,& + & 4.323627E-05,8.987564E-04,6.342355E-03,1.033007E-02,5.789018E-05,& + & 8.751395E-04,5.698375E-03,1.279599E-02,6.836816E-05,8.122660E-04,& + & 5.052287E-03,1.671274E-02,7.544599E-05,7.314655E-04,4.377693E-03,& + & 2.182178E-02,7.898359E-05,6.280666E-04,3.672657E-03,2.831094E-02,& + & 8.016195E-05,5.075717E-04,2.906986E-03,3.649995E-02,7.981268E-05,& + & 3.586367E-04,2.206938E-03,4.449749E-02,4.784512E-05,2.454222E-04,& + & 2.143469E-03,4.159486E-02,1.443837E-05,8.770044E-04,7.047123E-03,& + & 8.372348E-03,5.398283E-05,9.496051E-04,6.467078E-03,9.581958E-03,& + & 7.309459E-05,9.333036E-04,5.876319E-03,1.461215E-02,8.640536E-05,& + & 8.794603E-04,5.240849E-03,2.185662E-02,9.497417E-05,8.014246E-04,& + & 4.611963E-03,2.991951E-02,9.980555E-05,6.974384E-04,3.941319E-03,& + & 3.968956E-02,1.008266E-04,5.763511E-04,3.250855E-03,5.049803E-02,& + & 9.582425E-05,4.290210E-04,2.630371E-03,6.114815E-02,6.196750E-05,& + & 3.292091E-04,2.768872E-03,5.828225E-02,1.677099E-05,9.001726E-04,& + & 7.085797E-03,6.445893E-03,6.643880E-05,1.004249E-03,6.574644E-03,& + & 9.759747E-03,9.061040E-05,9.980272E-04,6.011717E-03,1.848461E-02/ + data absa(:,121:180) / & + & 1.071242E-04,9.548039E-04,5.448209E-03,2.872700E-02,1.180678E-04,& + & 8.789113E-04,4.897703E-03,3.997672E-02,1.241255E-04,7.790766E-04,& + & 4.267638E-03,5.356911E-02,1.242747E-04,6.571064E-04,3.675436E-03,& + & 6.743264E-02,1.154613E-04,5.111149E-04,3.149460E-03,8.126844E-02,& + & 7.925389E-05,4.322333E-04,3.518391E-03,7.853246E-02,1.970491E-05,& + & 9.246012E-04,7.064812E-03,5.501744E-03,8.061658E-05,1.060910E-03,& + & 6.656780E-03,1.110961E-02,1.103038E-04,1.074186E-03,6.169689E-03,& + & 2.325105E-02,1.305041E-04,1.038303E-03,5.689356E-03,3.719285E-02,& + & 1.445316E-04,9.690409E-04,5.197289E-03,5.265100E-02,1.514759E-04,& + & 8.723765E-04,4.672766E-03,6.982531E-02,1.498279E-04,7.523632E-04,& + & 4.188158E-03,8.737975E-02,1.381780E-04,6.025849E-04,3.775061E-03,& + & 1.050083E-01,1.000756E-04,5.539262E-04,4.318671E-03,1.039365E-01,& + & 2.012476E-05,1.545944E-03,1.448813E-02,4.013128E-02,4.258949E-05,& + & 1.463175E-03,1.278206E-02,3.512219E-02,5.097968E-05,1.352101E-03,& + & 1.111092E-02,3.097272E-02,5.602963E-05,1.210972E-03,9.455654E-03,& + & 2.763386E-02,5.837483E-05,1.042909E-03,7.799772E-03,2.526124E-02,& + & 5.952732E-05,8.541163E-04,6.151160E-03,2.348452E-02,5.773963E-05,& + & 6.453774E-04,4.484973E-03,2.274345E-02,5.247541E-05,4.061943E-04,& + & 2.734337E-03,2.457521E-02,3.471017E-05,1.574216E-04,1.397851E-03,& + & 2.001285E-02,2.317363E-05,1.594403E-03,1.463787E-02,3.486559E-02,& + & 5.277802E-05,1.534688E-03,1.298986E-02,3.061715E-02,6.427472E-05,& + & 1.431696E-03,1.137145E-02,2.793714E-02,7.190914E-05,1.289957E-03,& + & 9.766301E-03,2.642146E-02,7.618558E-05,1.120426E-03,8.151050E-03,& + & 2.607911E-02,7.761345E-05,9.272402E-04,6.506221E-03,2.714470E-02,& + & 7.486799E-05,7.119320E-04,4.829168E-03,2.961904E-02,6.774398E-05,& + & 4.610403E-04,3.001506E-03,3.601209E-02,4.396850E-05,2.178312E-04,& + & 1.882258E-03,3.049683E-02,2.716633E-05,1.633537E-03,1.475075E-02,& + & 3.053869E-02,6.493209E-05,1.609248E-03,1.316616E-02,2.721094E-02,& + & 8.081795E-05,1.512885E-03,1.162824E-02,2.623515E-02,9.149994E-05,& + & 1.372163E-03,1.008310E-02,2.699018E-02,9.749124E-05,1.206067E-03,& + & 8.482409E-03,2.972951E-02,9.927188E-05,1.011339E-03,6.868688E-03,& + & 3.374236E-02,9.544039E-05,7.891363E-04,5.173346E-03,4.026150E-02,& + & 8.603751E-05,5.261229E-04,3.334296E-03,5.081139E-02,5.532161E-05,& + & 2.958743E-04,2.484874E-03,4.401074E-02,3.164920E-05,1.676338E-03,& + & 1.497015E-02,2.424527E-02,7.895780E-05,1.690176E-03,1.345782E-02,& + & 2.232198E-02,1.000566E-04,1.605492E-03,1.196392E-02,2.424064E-02,& + & 1.144863E-04,1.463505E-03,1.043913E-02,2.877692E-02,1.219189E-04,& + & 1.303012E-03,8.867711E-03,3.502832E-02,1.240487E-04,1.107210E-03,& + & 7.259502E-03,4.320537E-02,1.202126E-04,8.773029E-04,5.504408E-03,& + & 5.526600E-02,1.069851E-04,6.027578E-04,3.754781E-03,6.902304E-02,& + & 6.996011E-05,3.884066E-04,3.213971E-03,6.085785E-02,3.716305E-05,& + & 1.725403E-03,1.509536E-02,1.938081E-02,9.631158E-05,1.776246E-03,& + & 1.368188E-02,1.915241E-02,1.231451E-04,1.702276E-03,1.229042E-02,& + & 2.379477E-02,1.404243E-04,1.568038E-03,1.079608E-02,3.249575E-02,& + & 1.501578E-04,1.408848E-03,9.224051E-03,4.370670E-02,1.532245E-04,& + & 1.213898E-03,7.632588E-03,5.658317E-02,1.480877E-04,9.789539E-04,& + & 5.917457E-03,7.322722E-02,1.301922E-04,6.938808E-04,4.262864E-03,& + & 9.092274E-02,8.749056E-05,5.038529E-04,4.050522E-03,8.157761E-02/ + data absa(:,181:240) / & + & 3.487007E-05,2.614745E-03,2.758127E-02,1.104513E-01,5.434055E-05,& + & 2.383470E-03,2.419328E-02,9.663498E-02,6.032014E-05,2.135055E-03,& + & 2.086619E-02,8.282988E-02,6.297096E-05,1.869601E-03,1.754931E-02,& + & 6.952087E-02,6.229960E-05,1.579013E-03,1.424916E-02,5.685915E-02,& + & 5.997381E-05,1.265992E-03,1.095144E-02,4.492962E-02,5.508085E-05,& + & 9.240691E-04,7.658576E-03,3.391662E-02,4.674013E-05,5.468540E-04,& + & 4.328321E-03,2.484472E-02,3.413801E-05,1.399066E-04,1.228453E-03,& + & 1.286213E-02,4.053366E-05,2.693140E-03,2.777661E-02,1.023605E-01,& + & 6.616746E-05,2.485672E-03,2.441334E-02,8.959451E-02,7.514805E-05,& + & 2.247142E-03,2.113529E-02,7.700292E-02,7.935003E-05,1.979521E-03,& + & 1.784987E-02,6.564478E-02,7.999035E-05,1.679809E-03,1.458194E-02,& + & 5.516276E-02,7.807640E-05,1.354621E-03,1.130420E-02,4.573059E-02,& + & 7.260025E-05,9.996475E-04,8.018157E-03,3.757427E-02,6.117590E-05,& + & 6.069309E-04,4.662331E-03,3.202556E-02,4.226729E-05,1.962412E-04,& + & 1.712427E-03,2.030465E-02,4.669053E-05,2.771180E-03,2.814040E-02,& + & 9.135321E-02,8.096145E-05,2.590574E-03,2.481100E-02,7.996237E-02,& + & 9.362609E-05,2.363834E-03,2.156189E-02,6.949689E-02,9.983103E-05,& + & 2.094048E-03,1.831934E-02,6.052672E-02,1.017762E-04,1.789234E-03,& + & 1.507887E-02,5.282202E-02,1.007647E-04,1.449353E-03,1.181619E-02,& + & 4.670775E-02,9.399733E-05,1.083456E-03,8.482749E-03,4.293542E-02,& + & 7.910396E-05,6.770476E-04,5.049743E-03,4.245031E-02,5.167372E-05,& + & 2.677017E-04,2.265870E-03,3.128085E-02,5.433347E-05,2.856691E-03,& + & 2.855789E-02,7.917263E-02,9.867169E-05,2.704632E-03,2.529064E-02,& + & 6.926595E-02,1.148624E-04,2.486016E-03,2.208459E-02,6.152870E-02,& + & 1.239106E-04,2.219793E-03,1.885957E-02,5.591900E-02,1.282563E-04,& + & 1.906814E-03,1.563375E-02,5.199440E-02,1.268791E-04,1.558961E-03,& + & 1.234616E-02,5.044931E-02,1.188624E-04,1.182557E-03,8.995160E-03,& + & 5.125253E-02,1.004279E-04,7.570262E-04,5.456218E-03,5.722288E-02,& + & 6.414883E-05,3.559010E-04,2.933100E-03,4.549482E-02,6.358358E-05,& + & 2.948379E-03,2.905275E-02,6.545217E-02,1.189515E-04,2.830519E-03,& + & 2.585313E-02,5.749898E-02,1.398955E-04,2.618873E-03,2.270664E-02,& + & 5.298340E-02,1.527385E-04,2.351036E-03,1.951050E-02,5.142728E-02,& + & 1.589470E-04,2.035428E-03,1.627549E-02,5.232011E-02,1.571551E-04,& + & 1.683567E-03,1.297147E-02,5.594854E-02,1.475270E-04,1.297796E-03,& + & 9.583139E-03,6.235096E-02,1.248112E-04,8.513497E-04,5.871264E-03,& + & 7.684310E-02,7.957658E-05,4.633567E-04,3.760209E-03,6.250776E-02,& + & 5.782664E-05,4.094674E-03,4.915533E-02,2.633307E-01,7.463194E-05,& + & 3.659346E-03,4.303796E-02,2.304138E-01,7.529861E-05,3.220805E-03,& + & 3.696370E-02,1.975110E-01,7.339912E-05,2.770908E-03,3.091626E-02,& + & 1.645929E-01,6.961158E-05,2.303546E-03,2.490484E-02,1.316888E-01,& + & 6.369681E-05,1.811517E-03,1.888873E-02,9.972283E-02,5.491964E-05,& + & 1.297529E-03,1.288365E-02,6.838632E-02,4.324939E-05,7.329391E-04,& + & 6.900093E-03,3.839915E-02,3.281928E-05,1.182499E-04,1.061298E-03,& + & 7.413153E-03,6.642918E-05,4.207083E-03,4.958999E-02,2.481025E-01,& + & 8.766981E-05,3.791220E-03,4.345115E-02,2.171005E-01,9.113858E-05,& + & 3.358800E-03,3.738303E-02,1.861298E-01,9.110328E-05,2.905381E-03,& + & 3.136201E-02,1.551159E-01,8.765464E-05,2.427244E-03,2.533705E-02,& + & 1.251142E-01,8.108374E-05,1.922093E-03,1.932197E-02,9.591148E-02/ + data absa(:,241:300) / & + & 7.176242E-05,1.382715E-03,1.331788E-02,6.771823E-02,5.712894E-05,& + & 7.961992E-04,7.278996E-03,4.185247E-02,4.104055E-05,1.668921E-04,& + & 1.493282E-03,1.296015E-02,7.625623E-05,4.348375E-03,5.008741E-02,& + & 2.308694E-01,1.044059E-04,3.955036E-03,4.393260E-02,2.021009E-01,& + & 1.111513E-04,3.522693E-03,3.790820E-02,1.731613E-01,1.129963E-04,& + & 3.062580E-03,3.189328E-02,1.451264E-01,1.108728E-04,2.566486E-03,& + & 2.588552E-02,1.182628E-01,1.034312E-04,2.042374E-03,1.987215E-02,& + & 9.261523E-02,9.259053E-05,1.481889E-03,1.383992E-02,6.855906E-02,& + & 7.459649E-05,8.694042E-04,7.706348E-03,4.824920E-02,5.100607E-05,& + & 2.328472E-04,2.061114E-03,2.036985E-02,8.701070E-05,4.489851E-03,& + & 5.062750E-02,2.129709E-01,1.255348E-04,4.117859E-03,4.449400E-02,& + & 1.863634E-01,1.357035E-04,3.693710E-03,3.851974E-02,1.597501E-01,& + & 1.395042E-04,3.225456E-03,3.251682E-02,1.352872E-01,1.365763E-04,& + & 2.724341E-03,2.650793E-02,1.122486E-01,1.305562E-04,2.176369E-03,& + & 2.050908E-02,9.064992E-02,1.180589E-04,1.591416E-03,1.442462E-02,& + & 7.193926E-02,9.538441E-05,9.571499E-04,8.226556E-03,5.725832E-02,& + & 6.187708E-05,3.203861E-04,2.779074E-03,2.994533E-02,1.017698E-04,& + & 4.637372E-03,5.148424E-02,1.892875E-01,1.492389E-04,4.296561E-03,& + & 4.535313E-02,1.656633E-01,1.651755E-04,3.878231E-03,3.939214E-02,& + & 1.427548E-01,1.695760E-04,3.401020E-03,3.340983E-02,1.225460E-01,& + & 1.692951E-04,2.885031E-03,2.740926E-02,1.040949E-01,1.621202E-04,& + & 2.324759E-03,2.135035E-02,8.832013E-02,1.476675E-04,1.718275E-03,& + & 1.516059E-02,7.657285E-02,1.199235E-04,1.060761E-03,8.808812E-03,& + & 6.984356E-02,7.419969E-05,4.288598E-04,3.617242E-03,4.277109E-02,& + & 1.123242E-04,6.687079E-03,9.070526E-02,6.219041E-01,1.224626E-04,& + & 5.908912E-03,7.936542E-02,5.443740E-01,1.173410E-04,5.133971E-03,& + & 6.806914E-02,4.665992E-01,1.074279E-04,4.355400E-03,5.679173E-02,& + & 3.887842E-01,9.475082E-05,3.572095E-03,4.552179E-02,3.110842E-01,& + & 8.105625E-05,2.766462E-03,3.430442E-02,2.332431E-01,6.534050E-05,& + & 1.931530E-03,2.311382E-02,1.559441E-01,4.597033E-05,1.058932E-03,& + & 1.192763E-02,7.990486E-02,3.168953E-05,1.095760E-04,8.809668E-04,& + & 3.659130E-03,1.254083E-04,6.879296E-03,9.123944E-02,5.986608E-01,& + & 1.404984E-04,6.105801E-03,7.986659E-02,5.238116E-01,1.362731E-04,& + & 5.330139E-03,6.854234E-02,4.489109E-01,1.258658E-04,4.544835E-03,& + & 5.724040E-02,3.742255E-01,1.128248E-04,3.741282E-03,4.599118E-02,& + & 2.992991E-01,9.891015E-05,2.907149E-03,3.477769E-02,2.247508E-01,& + & 8.223288E-05,2.046191E-03,2.354355E-02,1.515039E-01,5.898140E-05,& + & 1.133013E-03,1.232605E-02,7.991397E-02,4.087917E-05,1.504568E-04,& + & 1.277476E-03,7.368339E-03,1.398884E-04,7.074430E-03,9.207800E-02,& + & 5.700366E-01,1.614747E-04,6.313661E-03,8.063725E-02,4.986958E-01,& + & 1.588295E-04,5.541313E-03,6.927000E-02,4.273765E-01,1.492954E-04,& + & 4.744367E-03,5.795718E-02,3.562219E-01,1.377821E-04,3.922013E-03,& + & 4.669699E-02,2.849865E-01,1.226614E-04,3.062842E-03,3.541617E-02,& + & 2.154423E-01,1.022110E-04,2.170602E-03,2.413209E-02,1.472151E-01,& + & 7.557627E-05,1.217651E-03,1.283390E-02,8.139117E-02,5.113899E-05,& + & 2.084133E-04,1.804249E-03,1.261676E-02,1.592741E-04,7.326107E-03,& + & 9.302712E-02,5.377212E-01,1.874460E-04,6.579851E-03,8.151415E-02,& + & 4.705138E-01,1.861842E-04,5.798049E-03,7.013134E-02,4.033186E-01/ + data absa(:,301:360) / & + & 1.775918E-04,4.985218E-03,5.882135E-02,3.361698E-01,1.666154E-04,& + & 4.128998E-03,4.751507E-02,2.704199E-01,1.497443E-04,3.240669E-03,& + & 3.620001E-02,2.060555E-01,1.269532E-04,2.308500E-03,2.487132E-02,& + & 1.435592E-01,9.692694E-05,1.311328E-03,1.345758E-02,8.486320E-02,& + & 6.275427E-05,2.882535E-04,2.520594E-03,1.892202E-02,1.808412E-04,& + & 7.575806E-03,9.458033E-02,4.949996E-01,2.169014E-04,6.855808E-03,& + & 8.294742E-02,4.330295E-01,2.188656E-04,6.070992E-03,7.150910E-02,& + & 3.711151E-01,2.136988E-04,5.244632E-03,6.009766E-02,3.102709E-01,& + & 2.017271E-04,4.363111E-03,4.869382E-02,2.513941E-01,1.831871E-04,& + & 3.434746E-03,3.727447E-02,1.944753E-01,1.580939E-04,2.463811E-03,& + & 2.582217E-02,1.397432E-01,1.219872E-04,1.425353E-03,1.418371E-02,& + & 9.085314E-02,7.651763E-05,3.947831E-04,3.328048E-03,2.842174E-02,& + & 2.872000E-04,1.267831E-02,1.949089E-01,1.679814E+00,2.790118E-04,& + & 1.112914E-02,1.705453E-01,1.469789E+00,2.567850E-04,9.590937E-03,& + & 1.461979E-01,1.259846E+00,2.278808E-04,8.053469E-03,1.218624E-01,& + & 1.049816E+00,1.937941E-04,6.515014E-03,9.753682E-02,8.398911E-01,& + & 1.558012E-04,4.975090E-03,7.322985E-02,6.298952E-01,1.150225E-04,& + & 3.420610E-03,4.895244E-02,4.199393E-01,7.072506E-05,1.813061E-03,& + & 2.477324E-02,2.100931E-01,3.439865E-05,1.207608E-04,7.448077E-04,& + & 6.664684E-06,3.175848E-04,1.305553E-02,1.958576E-01,1.633181E+00,& + & 3.131615E-04,1.148607E-02,1.713840E-01,1.429046E+00,2.888215E-04,& + & 9.922562E-03,1.469439E-01,1.224895E+00,2.579398E-04,8.356857E-03,& + & 1.225170E-01,1.020854E+00,2.213753E-04,6.787145E-03,9.811908E-02,& + & 8.165936E-01,1.803218E-04,5.208004E-03,7.374936E-02,6.124497E-01,& + & 1.346278E-04,3.589524E-03,4.945790E-02,4.083062E-01,8.602815E-05,& + & 1.918802E-03,2.518792E-02,2.055696E-01,4.386507E-05,1.603756E-04,& + & 1.073460E-03,2.662535E-03,3.462508E-04,1.347547E-02,1.969119E-01,& + & 1.583756E+00,3.480671E-04,1.188617E-02,1.723209E-01,1.385834E+00,& + & 3.241371E-04,1.029724E-02,1.477919E-01,1.187828E+00,2.910917E-04,& + & 8.702868E-03,1.232941E-01,9.898451E-01,2.521544E-04,7.094861E-03,& + & 9.883164E-02,7.918926E-01,2.077535E-04,5.459754E-03,7.443111E-02,& + & 5.939268E-01,1.590162E-04,3.779669E-03,5.008283E-02,3.967113E-01,& + & 1.042691E-04,2.034957E-03,2.572347E-02,2.019536E-01,5.647430E-05,& + & 2.150107E-04,1.560278E-03,5.899654E-03,3.837688E-04,1.392510E-02,& + & 1.998616E-01,1.500330E+00,3.902720E-04,1.232277E-02,1.749380E-01,& + & 1.312805E+00,3.653535E-04,1.071162E-02,1.501046E-01,1.125318E+00,& + & 3.302007E-04,9.082543E-03,1.253207E-01,9.376781E-01,2.890756E-04,& + & 7.432389E-03,1.005964E-01,7.501685E-01,2.411994E-04,5.739319E-03,& + & 7.596522E-02,5.625714E-01,1.890612E-04,3.989744E-03,5.126880E-02,& + & 3.781384E-01,1.260451E-04,2.175640E-03,2.656673E-02,1.962208E-01,& + & 7.080866E-05,2.911586E-04,2.229868E-03,9.892879E-03,4.279384E-04,& + & 1.445187E-02,2.033495E-01,1.405392E+00,4.418698E-04,1.283250E-02,& + & 1.780508E-01,1.229525E+00,4.184779E-04,1.119052E-02,1.528540E-01,& + & 1.054109E+00,3.826648E-04,9.513336E-03,1.277707E-01,8.784052E-01,& + & 3.388408E-04,7.799075E-03,1.027797E-01,7.026193E-01,2.866327E-04,& + & 6.033905E-03,7.780506E-02,5.284630E-01,2.254628E-04,4.222317E-03,& + & 5.275529E-02,3.574426E-01,1.523982E-04,2.330191E-03,2.765097E-02,& + & 1.904061E-01,8.721938E-05,3.966872E-04,3.018343E-03,1.617011E-02/ + data absa(:,361:420) / & + & 1.441617E-03,4.537780E-02,7.873658E-01,8.476320E+00,1.287511E-03,& + & 3.972395E-02,6.890125E-01,7.415951E+00,1.129817E-03,3.407954E-02,& + & 5.905287E-01,6.357301E+00,9.662786E-04,2.843951E-02,4.921104E-01,& + & 5.297819E+00,7.948882E-04,2.280800E-02,3.937053E-01,4.238168E+00,& + & 6.154249E-04,1.717708E-02,2.953024E-01,3.178663E+00,4.308692E-04,& + & 1.154493E-02,1.969009E-01,2.119371E+00,2.344795E-04,5.911744E-03,& + & 9.856690E-02,1.059434E+00,5.307665E-05,1.664335E-04,3.703516E-04,& + & 4.139967E-06,1.561834E-03,4.669762E-02,7.907658E-01,8.298064E+00,& + & 1.407543E-03,4.089591E-02,6.919157E-01,7.260659E+00,1.242174E-03,& + & 3.510441E-02,5.930796E-01,6.223458E+00,1.065599E-03,2.932198E-02,& + & 4.942569E-01,5.186235E+00,8.795980E-04,2.354195E-02,3.954403E-01,& + & 4.149012E+00,6.864698E-04,1.775974E-02,2.966529E-01,3.111851E+00,& + & 4.817539E-04,1.197858E-02,1.978760E-01,2.074506E+00,2.655244E-04,& + & 6.178975E-03,9.916479E-02,1.037270E+00,6.669240E-05,2.257853E-04,& + & 6.950867E-04,7.700851E-06,1.693627E-03,4.830109E-02,7.939819E-01,& + & 8.113571E+00,1.539419E-03,4.232000E-02,6.947548E-01,7.099260E+00,& + & 1.360787E-03,3.636841E-02,5.955131E-01,6.085069E+00,1.168528E-03,& + & 3.041113E-02,4.963184E-01,5.070885E+00,9.676814E-04,2.445178E-02,& + & 3.971249E-01,4.056707E+00,7.600084E-04,1.848614E-02,2.979769E-01,& + & 3.042562E+00,5.386477E-04,1.251366E-02,1.988769E-01,2.028392E+00,& + & 3.027630E-04,6.480834E-03,9.991490E-02,1.014199E+00,8.514872E-05,& + & 2.997284E-04,1.181948E-03,1.332109E-05,1.847985E-03,4.988705E-02,& + & 8.025120E-01,7.837071E+00,1.693072E-03,4.374914E-02,7.021978E-01,& + & 6.857694E+00,1.501981E-03,3.763513E-02,6.019210E-01,5.877862E+00,& + & 1.294304E-03,3.150911E-02,5.017476E-01,4.897450E+00,1.078940E-03,& + & 2.537559E-02,4.015614E-01,3.918129E+00,8.505699E-04,1.923026E-02,& + & 3.013749E-01,2.939409E+00,6.084551E-04,1.306057E-02,2.013433E-01,& + & 1.959407E+00,3.500015E-04,6.795876E-03,1.015074E-01,9.795661E-01,& + & 1.066647E-04,3.896635E-04,1.877294E-03,2.195203E-05,2.037217E-03,& + & 5.175904E-02,8.192121E-01,7.409737E+00,1.880140E-03,4.544289E-02,& + & 7.166853E-01,6.485681E+00,1.679123E-03,3.912589E-02,6.144889E-01,& + & 5.557355E+00,1.453590E-03,3.281034E-02,5.122034E-01,4.631895E+00,& + & 1.213048E-03,2.647439E-02,4.100514E-01,3.705646E+00,9.609127E-04,& + & 2.011252E-02,3.079605E-01,2.779148E+00,6.947068E-04,1.370323E-02,& + & 2.059702E-01,1.853108E+00,4.071559E-04,7.148071E-03,1.042876E-01,& + & 9.271666E-01,1.335464E-04,4.927460E-04,2.822159E-03,3.406100E-05,& + & 7.853022E-03,1.815846E-01,3.512270E+00,4.705624E+01,6.891249E-03,& + & 1.589042E-01,3.073231E+00,4.117461E+01,5.929572E-03,1.362184E-01,& + & 2.634497E+00,3.528812E+01,4.967396E-03,1.135437E-01,2.195151E+00,& + & 2.941066E+01,4.003958E-03,9.086772E-02,1.756136E+00,2.352820E+01,& + & 3.039288E-03,6.819194E-02,1.317110E+00,1.764635E+01,2.065431E-03,& + & 4.552740E-02,8.780595E-01,1.176426E+01,1.073957E-03,2.286529E-02,& + & 4.390621E-01,5.882072E+00,6.890473E-05,1.290060E-04,2.355545E-04,& + & 2.673648E-06,8.654330E-03,1.868871E-01,3.531369E+00,4.617670E+01,& + & 7.605278E-03,1.635490E-01,3.090160E+00,4.040021E+01,6.553431E-03,& + & 1.402313E-01,2.648526E+00,3.463134E+01,5.501607E-03,1.168973E-01,& + & 2.206974E+00,2.886339E+01,4.447607E-03,9.356679E-02,1.765721E+00,& + & 2.308818E+01,3.385107E-03,7.025343E-02,1.324260E+00,1.731621E+01/ + data absa(:,421:480) / & + & 2.308995E-03,4.693795E-02,8.829028E-01,1.154429E+01,1.202349E-03,& + & 2.363570E-02,4.415229E-01,5.772106E+00,1.015339E-04,2.146532E-04,& + & 3.878771E-04,5.104623E-06,9.597905E-03,1.921347E-01,3.547082E+00,& + & 4.534619E+01,8.448946E-03,1.681576E-01,3.103547E+00,3.968392E+01,& + & 7.295449E-03,1.441950E-01,2.660373E+00,3.401126E+01,6.136355E-03,& + & 1.202335E-01,2.216966E+00,2.834163E+01,4.965813E-03,9.627947E-02,& + & 1.773591E+00,2.267356E+01,3.785263E-03,7.232560E-02,1.330099E+00,& + & 1.700764E+01,2.579879E-03,4.838458E-02,8.869195E-01,1.133683E+01,& + & 1.350474E-03,2.443491E-02,4.436651E-01,5.668366E+00,1.277184E-04,& + & 3.481203E-04,6.459755E-04,9.145380E-06,1.059528E-02,1.983900E-01,& + & 3.583191E+00,4.413105E+01,9.344452E-03,1.736739E-01,3.135586E+00,& + & 3.861110E+01,8.086535E-03,1.489311E-01,2.687398E+00,3.309907E+01,& + & 6.810012E-03,1.242404E-01,2.239718E+00,2.757884E+01,5.520873E-03,& + & 9.953791E-02,1.791660E+00,2.206658E+01,4.210313E-03,7.483380E-02,& + & 1.343984E+00,1.654795E+01,2.876824E-03,5.012858E-02,8.960046E-01,& + & 1.103476E+01,1.513871E-03,2.539666E-02,4.484452E-01,5.516631E+00,& + & 1.615508E-04,5.059217E-04,1.065132E-03,1.568914E-05,1.150245E-02,& + & 2.057321E-01,3.659089E+00,4.220060E+01,1.017063E-02,1.801139E-01,& + & 3.201713E+00,3.692451E+01,8.816906E-03,1.545091E-01,2.744349E+00,& + & 3.165012E+01,7.440750E-03,1.289373E-01,2.287165E+00,2.637169E+01,& + & 6.031818E-03,1.033610E-01,1.829871E+00,2.109737E+01,4.615111E-03,& + & 7.776978E-02,1.372477E+00,1.582563E+01,3.171313E-03,5.216141E-02,& + & 9.154039E-01,1.054881E+01,1.686684E-03,2.651877E-02,4.582438E-01,& + & 5.276678E+00,2.074552E-04,7.097483E-04,1.639162E-03,2.518685E-05,& + & 1.505655E-02,2.779555E-01,5.385237E+00,8.944192E+01,1.319545E-02,& + & 2.432215E-01,4.712172E+00,7.826397E+01,1.133457E-02,2.084955E-01,& + & 4.039235E+00,6.707571E+01,9.469429E-03,1.737716E-01,3.365826E+00,& + & 5.590044E+01,7.603244E-03,1.390493E-01,2.692601E+00,4.472233E+01,& + & 5.738313E-03,1.043374E-01,2.019473E+00,3.354265E+01,3.868456E-03,& + & 6.961565E-02,1.346254E+00,2.236289E+01,1.985949E-03,3.490483E-02,& + & 6.731644E-01,1.118001E+01,6.836374E-05,1.232487E-04,2.457424E-04,& + & 2.491371E-06,1.654103E-02,2.823315E-01,5.432611E+00,8.783681E+01,& + & 1.450631E-02,2.470717E-01,4.753569E+00,7.685421E+01,1.247115E-02,& + & 2.118055E-01,4.074630E+00,6.587734E+01,1.043207E-02,1.765485E-01,& + & 3.395462E+00,5.489828E+01,8.391232E-03,1.412922E-01,2.716350E+00,& + & 4.391823E+01,6.344466E-03,1.060385E-01,2.037262E+00,3.293947E+01,& + & 4.287518E-03,7.080160E-02,1.358216E+00,2.195959E+01,2.205903E-03,& + & 3.555188E-02,6.791786E-01,1.097995E+01,1.027984E-04,2.054516E-04,& + & 3.993556E-04,4.521093E-06,1.833400E-02,2.874416E-01,5.468716E+00,& + & 8.637991E+01,1.608717E-02,2.515623E-01,4.785185E+00,7.558472E+01,& + & 1.384279E-02,2.156829E-01,4.101611E+00,6.478706E+01,1.159688E-02,& + & 1.797921E-01,3.417999E+00,5.398998E+01,9.342150E-03,1.439342E-01,& + & 2.734137E+00,4.319615E+01,7.083751E-03,1.080554E-01,2.050564E+00,& + & 3.239635E+01,4.800470E-03,7.218278E-02,1.367319E+00,2.159601E+01,& + & 2.475864E-03,3.632997E-02,6.837622E-01,1.079887E+01,1.450401E-04,& + & 3.361708E-04,6.245341E-04,8.177647E-06,2.022644E-02,2.937772E-01,& + & 5.571131E+00,8.373593E+01,1.776845E-02,2.571128E-01,4.873634E+00,& + & 7.328506E+01,1.530602E-02,2.204738E-01,4.177769E+00,6.280910E+01/ + data absa(:,481:540) / & + & 1.283577E-02,1.838541E-01,3.481927E+00,5.233455E+01,1.034623E-02,& + & 1.472120E-01,2.785884E+00,4.186270E+01,7.846969E-03,1.105776E-01,& + & 2.089129E+00,3.140447E+01,5.315927E-03,7.396171E-02,1.393020E+00,& + & 2.093404E+01,2.751407E-03,3.730989E-02,6.968814E-01,1.046740E+01,& + & 1.812994E-04,5.237312E-04,9.827544E-04,1.395870E-05,2.235001E-02,& + & 3.034599E-01,5.691588E+00,8.066653E+01,1.965606E-02,2.656357E-01,& + & 4.979903E+00,7.059151E+01,1.696073E-02,2.278129E-01,4.268777E+00,& + & 6.049898E+01,1.423405E-02,1.900274E-01,3.557705E+00,5.041010E+01,& + & 1.149668E-02,1.522019E-01,2.845653E+00,4.033932E+01,8.734362E-03,& + & 1.143714E-01,2.134673E+00,3.025049E+01,5.935479E-03,7.654980E-02,& + & 1.423457E+00,2.016659E+01,3.089040E-03,3.869977E-02,7.123753E-01,& + & 1.008332E+01,2.316404E-04,7.436444E-04,1.515703E-03,2.234387E-05,& + & 1.947430E-02,3.258731E-01,5.964340E+00,1.233284E+02,1.705682E-02,& + & 2.851599E-01,5.218845E+00,1.079145E+02,1.464140E-02,2.444407E-01,& + & 4.472835E+00,9.250393E+01,1.222710E-02,2.037290E-01,3.727731E+00,& + & 7.707809E+01,9.810909E-03,1.630131E-01,2.982153E+00,6.166335E+01,& + & 7.392738E-03,1.222932E-01,2.236647E+00,4.624851E+01,4.971545E-03,& + & 8.160874E-02,1.491076E+00,3.083222E+01,2.539287E-03,4.089471E-02,& + & 7.455614E-01,1.541598E+01,6.866885E-05,1.138507E-04,2.622089E-04,& + & 2.344268E-06,2.172106E-02,3.296801E-01,6.031034E+00,1.212378E+02,& + & 1.903771E-02,2.885232E-01,5.277165E+00,1.060806E+02,1.634778E-02,& + & 2.473375E-01,4.523305E+00,9.092699E+01,1.366109E-02,2.061588E-01,& + & 3.769478E+00,7.577222E+01,1.097360E-02,1.649720E-01,3.015529E+00,& + & 6.061765E+01,8.281214E-03,1.238358E-01,2.261676E+00,4.546292E+01,& + & 5.576280E-03,8.265304E-02,1.507767E+00,3.030898E+01,2.850797E-03,& + & 4.146404E-02,7.539898E-01,1.515434E+01,1.031064E-04,1.941787E-04,& + & 4.193103E-04,4.170957E-06,2.419287E-02,3.329465E-01,6.117592E+00,& + & 1.188062E+02,2.121210E-02,2.913753E-01,5.352444E+00,1.039546E+02,& + & 1.823008E-02,2.498316E-01,4.587969E+00,8.910415E+01,1.524978E-02,& + & 2.082823E-01,3.823249E+00,7.425376E+01,1.226470E-02,1.667425E-01,& + & 3.058536E+00,5.940329E+01,9.266352E-03,1.251749E-01,2.294197E+00,& + & 4.454673E+01,6.250784E-03,8.358046E-02,1.529359E+00,2.970223E+01,& + & 3.200654E-03,4.201379E-02,7.648973E-01,1.485070E+01,1.422587E-04,& + & 3.279599E-04,6.461752E-04,7.123706E-06,2.673728E-02,3.395817E-01,& + & 6.254152E+00,1.153769E+02,2.345645E-02,2.972118E-01,5.472647E+00,& + & 1.009574E+02,2.018313E-02,2.548513E-01,4.690265E+00,8.654200E+01,& + & 1.689233E-02,2.125407E-01,3.908875E+00,7.211123E+01,1.359427E-02,& + & 1.701522E-01,3.126811E+00,5.769484E+01,1.028300E-02,1.277628E-01,& + & 2.345434E+00,4.326540E+01,6.942055E-03,8.540842E-02,1.563772E+00,& + & 2.884356E+01,3.558379E-03,4.302751E-02,7.822797E-01,1.442166E+01,& + & 1.745874E-04,5.377398E-04,9.726734E-04,1.227072E-05,2.953762E-02,& + & 3.489798E-01,6.419764E+00,1.113709E+02,2.594298E-02,3.054525E-01,& + & 5.616648E+00,9.746369E+01,2.235091E-02,2.619562E-01,4.814170E+00,& + & 8.353915E+01,1.871895E-02,2.184866E-01,4.012293E+00,6.960911E+01,& + & 1.507611E-02,1.749510E-01,3.209617E+00,5.569328E+01,1.141426E-02,& + & 1.314336E-01,2.407748E+00,4.176441E+01,7.718707E-03,8.792393E-02,& + & 1.605298E+00,2.784619E+01,3.974562E-03,4.436795E-02,8.034402E-01,& + & 1.392136E+01,2.241699E-04,7.603610E-04,1.502461E-03,1.991435E-05/ + data absa(:,541:585) / & + & 1.976966E-02,2.995103E-01,5.070361E+00,1.287938E+02,1.731784E-02,& + & 2.620617E-01,4.436453E+00,1.126942E+02,1.486361E-02,2.246376E-01,& + & 3.802362E+00,9.660143E+01,1.240753E-02,1.872251E-01,3.169104E+00,& + & 8.049483E+01,9.950733E-03,1.498137E-01,2.535232E+00,6.439397E+01,& + & 7.496863E-03,1.123986E-01,1.901194E+00,4.830049E+01,5.036520E-03,& + & 7.498482E-02,1.267674E+00,3.219724E+01,2.565350E-03,3.756674E-02,& + & 6.338029E-01,1.609971E+01,6.703627E-05,1.049376E-04,2.822422E-04,& + & 2.129584E-06,2.228657E-02,3.015091E-01,5.138288E+00,1.267552E+02,& + & 1.952829E-02,2.638523E-01,4.495356E+00,1.109268E+02,1.677022E-02,& + & 2.261551E-01,3.853793E+00,9.506733E+01,1.401211E-02,1.885185E-01,& + & 3.211916E+00,7.921688E+01,1.125545E-02,1.508728E-01,2.568883E+00,& + & 6.338401E+01,8.488025E-03,1.132158E-01,1.926667E+00,4.753863E+01,& + & 5.711797E-03,7.555589E-02,1.284523E+00,3.169247E+01,2.909208E-03,& + & 3.790834E-02,6.423897E-01,1.584559E+01,9.402866E-05,1.902967E-04,& + & 4.473239E-04,3.849435E-06,2.484620E-02,3.048380E-01,5.250550E+00,& + & 1.239050E+02,2.178794E-02,2.667822E-01,4.594153E+00,1.084166E+02,& + & 1.872154E-02,2.287235E-01,3.937921E+00,9.292866E+01,1.565908E-02,& + & 1.906856E-01,3.281284E+00,7.744734E+01,1.258288E-02,1.526427E-01,& + & 2.624921E+00,6.195751E+01,9.496569E-03,1.145660E-01,1.968779E+00,& + & 4.646889E+01,6.392791E-03,7.652366E-02,1.312670E+00,3.097858E+01,& + & 3.259411E-03,3.847053E-02,6.566488E-01,1.548765E+01,1.179294E-04,& + & 3.373755E-04,6.848987E-04,6.619677E-06,2.752462E-02,3.112655E-01,& + & 5.383886E+00,1.205806E+02,2.414874E-02,2.724141E-01,4.710813E+00,& + & 1.055070E+02,2.077352E-02,2.336022E-01,4.037917E+00,9.043360E+01,& + & 1.737752E-02,1.947704E-01,3.364846E+00,7.535945E+01,1.397566E-02,& + & 1.559345E-01,2.692038E+00,6.028824E+01,1.056045E-02,1.171125E-01,& + & 2.018807E+00,4.522056E+01,7.118393E-03,7.826501E-02,1.346321E+00,& + & 3.014414E+01,3.640262E-03,3.940981E-02,6.736364E-01,1.507197E+01,& + & 1.547108E-04,5.155244E-04,1.059186E-03,1.089844E-05,3.040570E-02,& + & 3.198316E-01,5.538197E+00,1.168217E+02,2.669795E-02,2.799919E-01,& + & 4.845670E+00,1.022162E+02,2.297793E-02,2.401110E-01,4.153011E+00,& + & 8.762463E+01,1.924257E-02,2.002160E-01,3.460977E+00,7.302043E+01,& + & 1.548526E-02,1.603281E-01,2.768957E+00,5.841573E+01,1.170918E-02,& + & 1.204620E-01,2.076987E+00,4.381136E+01,7.895505E-03,8.058790E-02,& + & 1.385064E+00,2.920838E+01,4.046633E-03,4.069200E-02,6.932778E-01,& + & 1.460414E+01,2.037316E-04,7.222150E-04,1.619575E-03,1.707643E-05/ + +! --- the array ka_mxxx contains the absorption coefficient for a minor +! species at the NG13=4 chosen g-values for a reference pressure +! level below 100~ mb. the first index in the array, js, runs from +! 1 to 9, and corresponds to different gas column amount ratios, as +! expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +! reference mls column amount value of gas1 to that of gas2. the +! second index refers to temperature in 7.2 degree increments. for +! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers +! to 195.2, etc. the third index runs over the g-channel (1 to NG13=4). + + data ka_mco2(:,:, 1: 5) / & + & 2.245478E-04,4.894961E-04,1.680678E-02,4.669680E-01,2.628131E-04,& + & 4.659784E-04,1.934007E-02,4.215419E-01,2.822243E-04,5.590294E-04,& + & 2.194032E-02,3.725018E-01,2.639305E-04,8.076651E-04,2.509101E-02,& + & 3.087841E-01,2.322310E-04,1.394128E-03,2.863718E-02,2.279988E-01,& + & 1.918420E-04,2.100896E-03,3.253488E-02,1.402144E-01,1.807658E-04,& + & 3.342198E-03,3.836297E-02,9.298483E-04,1.169357E-03,5.965105E-03,& + & 3.130842E-02,7.253333E-04,1.157398E-04,1.304234E-03,2.959310E-02,& + & 2.217487E-01,2.395286E-04,5.376539E-04,1.835863E-02,4.980907E-01,& + & 2.801432E-04,5.251652E-04,2.106704E-02,4.492031E-01,3.005720E-04,& + & 6.350459E-04,2.382520E-02,3.968582E-01,2.826681E-04,9.100453E-04,& + & 2.717492E-02,3.289292E-01,2.515500E-04,1.545603E-03,3.094641E-02,& + & 2.427535E-01,2.125053E-04,2.308016E-03,3.506033E-02,1.493270E-01,& + & 2.078847E-04,3.655523E-03,4.119692E-02,9.723338E-04,1.293345E-03,& + & 6.512230E-03,3.349644E-02,7.535552E-04,1.326177E-04,1.460053E-03,& + & 3.191682E-02,2.360319E-01,2.555102E-04,5.920461E-04,2.005405E-02,& + & 5.312905E-01,2.986247E-04,5.925997E-04,2.294875E-02,4.786815E-01,& + & 3.201294E-04,7.216354E-04,2.587333E-02,4.228086E-01,3.027424E-04,& + & 1.025612E-03,2.943374E-02,3.503889E-01,2.724790E-04,1.714130E-03,& + & 3.344424E-02,2.584631E-01,2.354181E-04,2.536479E-03,3.778570E-02,& + & 1.590329E-01,2.390788E-04,3.998528E-03,4.424509E-02,1.016920E-03,& + & 1.431014E-03,7.109585E-03,3.583911E-02,7.829491E-04,1.519722E-04,& + & 1.634613E-03,3.442484E-02,2.512360E-01,2.725585E-04,6.536122E-04,& + & 2.190640E-02,5.667057E-01,3.183346E-04,6.695016E-04,2.499911E-02,& + & 5.100948E-01,3.409786E-04,8.203001E-04,2.809889E-02,4.504576E-01,& + & 3.242481E-04,1.156094E-03,3.188238E-02,3.732497E-01,2.951530E-04,& + & 1.901701E-03,3.614637E-02,2.751910E-01,2.608284E-04,2.788596E-03,& + & 4.072709E-02,1.693711E-01,2.749624E-04,4.374061E-03,4.752366E-02,& + & 1.063708E-03,1.583968E-03,7.761748E-03,3.834749E-02,8.135695E-04,& + & 1.741695E-04,1.830190E-03,3.713202E-02,2.674193E-01,2.907457E-04,& + & 7.234405E-04,2.393029E-02,6.044852E-01,3.393550E-04,7.572723E-04,& + & 2.723322E-02,5.435724E-01,3.632056E-04,9.327563E-04,3.051752E-02,& + & 4.799153E-01,3.472896E-04,1.303460E-03,3.453681E-02,3.976024E-01,& + & 3.197165E-04,2.110562E-03,3.906955E-02,2.930020E-01,2.890107E-04,& + & 3.066947E-03,4.390189E-02,1.803824E-01,3.162415E-04,4.785243E-03,& + & 5.105099E-02,1.112809E-03,1.753979E-03,8.473749E-03,4.103340E-02,& + & 8.454671E-04,1.996291E-04,2.049339E-03,4.005425E-02,2.846460E-01/ + data ka_mco2(:,:, 6:10) / & + & 3.101475E-04,8.027953E-04,2.614157E-02,6.447858E-01,3.617745E-04,& + & 8.575302E-04,2.966766E-02,5.792480E-01,3.869026E-04,1.060973E-03,& + & 3.314596E-02,5.113009E-01,3.719753E-04,1.469931E-03,3.741456E-02,& + & 4.235446E-01,3.463280E-04,2.343217E-03,4.223216E-02,3.119667E-01,& + & 3.202701E-04,3.374391E-03,4.732926E-02,1.921110E-01,3.637287E-04,& + & 5.235503E-03,5.484622E-02,1.164351E-03,1.943065E-03,9.251117E-03,& + & 4.390964E-02,8.787006E-04,2.288324E-04,2.294915E-03,4.320883E-02,& + & 3.029830E-01,3.308450E-04,8.931484E-04,2.855765E-02,6.877772E-01,& + & 3.856861E-04,9.721478E-04,3.232034E-02,6.172665E-01,4.121693E-04,& + & 1.207200E-03,3.600257E-02,5.447411E-01,3.984247E-04,1.658039E-03,& + & 4.053462E-02,4.511803E-01,3.751579E-04,2.602492E-03,4.565402E-02,& + & 3.321597E-01,3.549450E-04,3.714140E-03,5.102931E-02,2.046040E-01,& + & 4.183599E-04,5.728599E-03,5.893006E-02,1.218461E-03,2.153483E-03,& + & 1.009985E-02,4.698981E-02,9.133269E-04,2.623326E-04,2.570130E-03,& + & 4.661439E-02,3.225016E-01,3.529247E-04,9.962039E-04,3.119758E-02,& + & 7.336385E-01,4.111895E-04,1.103270E-03,3.521103E-02,6.577812E-01,& + & 4.391107E-04,1.374013E-03,3.910733E-02,5.803696E-01,4.267638E-04,& + & 1.870644E-03,4.391753E-02,4.806203E-01,4.063920E-04,2.891561E-03,& + & 4.935657E-02,3.536609E-01,3.934117E-04,4.089763E-03,5.502432E-02,& + & 2.179106E-01,4.812101E-04,6.268685E-03,6.332517E-02,1.275266E-03,& + & 2.387774E-03,1.102645E-02,5.028864E-02,9.494068E-04,3.007650E-04,& + & 2.878595E-03,5.029111E-02,3.432782E-01,3.764794E-04,1.113952E-03,& + & 3.408210E-02,7.825616E-01,4.383930E-04,1.253391E-03,3.836103E-02,& + & 7.009579E-01,4.678396E-04,1.564369E-03,4.248185E-02,6.183305E-01,& + & 4.571277E-04,2.111008E-03,4.758568E-02,5.119821E-01,4.402311E-04,& + & 3.213988E-03,5.336342E-02,3.765551E-01,4.360887E-04,4.505234E-03,& + & 5.933835E-02,2.320846E-01,5.535189E-04,6.860307E-03,6.805546E-02,& + & 1.334915E-03,2.648816E-03,1.203814E-02,5.382185E-02,9.870050E-04,& + & 3.448588E-04,3.224355E-03,5.426089E-02,3.653942E-01,4.016075E-04,& + & 1.248701E-03,3.723395E-02,8.347511E-01,4.674090E-04,1.425375E-03,& + & 4.179371E-02,7.469694E-01,4.984760E-04,1.781650E-03,4.614977E-02,& + & 6.587752E-01,4.896628E-04,2.382828E-03,5.156332E-02,5.453908E-01,& + & 4.768928E-04,3.573777E-03,5.769963E-02,4.009320E-01,4.834408E-04,& + & 4.965022E-03,6.399734E-02,2.471820E-01,6.367135E-04,7.508435E-03,& + & 7.314739E-02,1.397549E-03,2.939834E-03,1.314270E-02,5.760589E-02,& + & 1.026189E-03,3.954515E-04,3.611954E-03,5.854714E-02,3.889350E-01/ + data ka_mco2(:,:,11:15) / & + & 4.284137E-04,1.403148E-03,4.067798E-02,8.904273E-01,4.983608E-04,& + & 1.622528E-03,4.553449E-02,7.960045E-01,5.311489E-04,2.029736E-03,& + & 5.013685E-02,7.018692E-01,5.245248E-04,2.690304E-03,5.587688E-02,& + & 5.809803E-01,5.166132E-04,3.975441E-03,6.239290E-02,4.268883E-01,& + & 5.359840E-04,5.474111E-03,6.902932E-02,2.632634E-01,7.324337E-04,& + & 8.218501E-03,7.862932E-02,1.463334E-03,3.264493E-03,1.434866E-02,& + & 6.165961E-02,1.067027E-03,4.535061E-04,4.046497E-03,6.317546E-02,& + & 4.139931E-01,4.570112E-04,1.580420E-03,4.444136E-02,9.498194E-01,& + & 5.313775E-04,1.848685E-03,4.961117E-02,8.482588E-01,5.659960E-04,& + & 2.313072E-03,5.447085E-02,7.477823E-01,5.618807E-04,3.038215E-03,& + & 6.055479E-02,6.188945E-01,5.596471E-04,4.424051E-03,6.747252E-02,& + & 4.545265E-01,5.942928E-04,6.038046E-03,7.446482E-02,2.803928E-01,& + & 8.425717E-04,8.996604E-03,8.453146E-02,1.532431E-03,3.626917E-03,& + & 1.566533E-02,6.600180E-02,1.109591E-03,5.201265E-04,4.533713E-03,& + & 6.817354E-02,4.406666E-01,4.875192E-04,1.784165E-03,4.855375E-02,& + & 1.013180E+00,5.665984E-04,2.108243E-03,5.405386E-02,9.039476E-01,& + & 6.031635E-04,2.636752E-03,5.918252E-02,7.967025E-01,6.019108E-04,& + & 3.431997E-03,6.562834E-02,6.592827E-01,6.062714E-04,4.925336E-03,& + & 7.297085E-02,4.839549E-01,6.590013E-04,6.663046E-03,8.033688E-02,& + & 2.986391E-01,9.692961E-04,9.849300E-03,9.088727E-02,1.605015E-03,& + & 4.031776E-03,1.710287E-02,7.065339E-02,1.153960E-03,5.965815E-04,& + & 5.080041E-03,7.357081E-02,4.690597E-01,5.200659E-04,2.018638E-03,& + & 5.304769E-02,1.080772E+00,6.041717E-04,2.406313E-03,5.889559E-02,& + & 9.632941E-01,6.428086E-04,3.006628E-03,6.430459E-02,8.488239E-01,& + & 6.448049E-04,3.877813E-03,7.113110E-02,7.023078E-01,6.567880E-04,& + & 5.485689E-03,7.892297E-02,5.152906E-01,7.308219E-04,7.356087E-03,& + & 8.668076E-02,3.180747E-01,1.115117E-03,1.078384E-02,9.773206E-02,& + & 1.681268E-03,4.484367E-03,1.867240E-02,7.563706E-02,1.200214E-03,& + & 6.843303E-04,5.692705E-03,7.940007E-02,4.992821E-01,5.547861E-04,& + & 2.288792E-03,5.795851E-02,1.152878E+00,6.442555E-04,2.748779E-03,& + & 6.417244E-02,1.026538E+00,6.851013E-04,3.429403E-03,6.987316E-02,& + & 9.043580E-01,6.907704E-04,4.382706E-03,7.709976E-02,7.481421E-01,& + & 7.115180E-04,6.112431E-03,8.536670E-02,5.486557E-01,8.105373E-04,& + & 8.124944E-03,9.353571E-02,3.387775E-01,1.282913E-03,1.180832E-02,& + & 1.051044E-01,1.761385E-03,4.990672E-03,2.038608E-02,8.097641E-02,& + & 1.248433E-03,7.850456E-04,6.379822E-03,8.569573E-02,5.314521E-01/ + data ka_mco2(:,:,16:19) / & + & 5.918275E-04,2.600407E-03,6.332489E-02,1.229802E+00,6.870189E-04,& + & 3.142455E-03,6.992335E-02,1.093939E+00,7.302149E-04,3.912775E-03,& + & 7.592735E-02,9.635295E-01,7.400328E-04,4.954679E-03,8.357424E-02,& + & 7.969714E-01,7.708210E-04,6.813684E-03,9.234315E-02,5.841836E-01,& + & 8.990300E-04,8.978360E-03,1.009435E-01,3.608301E-01,1.475997E-03,& + & 1.293133E-02,1.130461E-01,1.845578E-03,5.557499E-03,2.225708E-02,& + & 8.669735E-02,1.298709E-03,9.006500E-04,7.150562E-03,9.249585E-02,& + & 5.656969E-01,6.313439E-04,2.960223E-03,6.918965E-02,1.311866E+00,& + & 7.326436E-04,3.595199E-03,7.619137E-02,1.165768E+00,7.783485E-04,& + & 4.465568E-03,8.251018E-02,1.026574E+00,7.928229E-04,5.602818E-03,& + & 9.059751E-02,8.489838E-01,8.350706E-04,7.598717E-03,9.989685E-02,& + & 6.220140E-01,9.972625E-04,9.926162E-03,1.089494E-01,3.843203E-01,& + & 1.698199E-03,1.416272E-02,1.216018E-01,1.934052E-03,6.192559E-03,& + & 2.429988E-02,9.282754E-02,1.351129E-03,1.033355E-03,8.015104E-03,& + & 9.984098E-02,6.021484E-01,6.735009E-04,3.376100E-03,7.559885E-02,& + & 1.399412E+00,7.813214E-04,4.116090E-03,8.302259E-02,1.242315E+00,& + & 8.297016E-04,5.097915E-03,8.966750E-02,1.093747E+00,8.493981E-04,& + & 6.337504E-03,9.821672E-02,9.043942E-01,9.046860E-04,8.477896E-03,& + & 1.080760E-01,6.622953E-01,1.106325E-03,1.097928E-02,1.176029E-01,& + & 4.093427E-01,1.953902E-03,1.551295E-02,1.308201E-01,2.027039E-03,& + & 6.904623E-03,2.653028E-02,9.939688E-02,1.405789E-03,1.185696E-03,& + & 8.985009E-03,1.077754E-01,6.409500E-01,7.184736E-04,3.857217E-03,& + & 8.260324E-02,1.492809E+00,8.332580E-04,4.715651E-03,9.046810E-02,& + & 1.323891E+00,8.844961E-04,5.821481E-03,9.745019E-02,1.165317E+00,& + & 9.100292E-04,7.170541E-03,1.064828E-01,9.634251E-01,9.801179E-04,& + & 9.463039E-03,1.169335E-01,7.051859E-01,1.227410E-03,1.215004E-02,& + & 1.269569E-01,4.359971E-01,2.248179E-03,1.699375E-02,1.407540E-01,& + & 2.124778E-03,7.703661E-03,2.896553E-02,1.064365E-01,1.462794E-03,& + & 1.360594E-03,1.007321E-02,1.163465E-01,6.822542E-01 / + + data ka_mco (:,:, 1: 5) / & + & 1.362159E+00,9.040231E+00,1.118386E+01,1.493782E-03,1.661132E+00,& + & 8.911353E+00,1.072785E+01,6.180467E-02,1.880925E+00,8.897449E+00,& + & 1.022436E+01,3.335288E-01,2.100353E+00,8.803845E+00,9.866605E+00,& + & 6.211619E-01,2.339612E+00,8.891398E+00,9.111367E+00,1.195529E+00,& + & 2.583491E+00,9.037184E+00,8.234580E+00,1.681951E+00,2.812146E+00,& + & 9.408658E+00,6.985765E+00,2.077928E+00,3.206512E+00,1.029151E+01,& + & 4.362893E+00,2.585012E+00,1.255014E+00,4.471238E+00,1.938529E+01,& + & 1.266835E+00,1.326486E+00,8.953245E+00,1.127739E+01,1.804396E-03,& + & 1.616662E+00,8.835640E+00,1.082107E+01,6.271447E-02,1.830278E+00,& + & 8.829911E+00,1.031822E+01,3.273495E-01,2.043882E+00,8.741509E+00,& + & 9.965810E+00,6.067088E-01,2.277945E+00,8.837930E+00,9.209192E+00,& + & 1.163194E+00,2.516470E+00,8.996963E+00,8.325159E+00,1.635705E+00,& + & 2.740146E+00,9.385154E+00,7.061896E+00,2.021844E+00,3.138090E+00,& + & 1.030033E+01,4.385681E+00,2.515879E+00,1.229376E+00,4.429820E+00,& + & 1.942444E+01,1.232309E+00,1.291749E+00,8.868157E+00,1.137232E+01,& + & 2.181166E-03,1.573387E+00,8.761557E+00,1.091562E+01,6.366684E-02,& + & 1.780993E+00,8.763787E+00,1.041336E+01,3.213431E-01,1.988937E+00,& + & 8.680384E+00,1.006629E+01,5.926457E-01,2.217911E+00,8.785463E+00,& + & 9.308254E+00,1.131783E+00,2.451208E+00,8.957456E+00,8.416884E+00,& + & 1.590776E+00,2.670029E+00,9.362036E+00,7.139116E+00,1.967315E+00,& + & 3.071241E+00,1.030960E+01,4.408916E+00,2.448648E+00,1.204282E+00,& + & 4.388864E+00,1.946385E+01,1.198776E+00,1.257923E+00,8.784956E+00,& + & 1.146874E+01,2.638608E-03,1.531268E+00,8.689094E+00,1.101159E+01,& + & 6.466629E-02,1.733038E+00,8.699062E+00,1.050990E+01,3.155061E-01,& + & 1.935468E+00,8.620445E+00,1.016817E+01,5.789621E-01,2.159468E+00,& + & 8.734001E+00,9.408657E+00,1.101267E+00,2.387661E+00,8.918681E+00,& + & 8.509722E+00,1.547131E+00,2.601736E+00,9.339293E+00,7.217448E+00,& + & 1.914302E+00,3.005913E+00,1.031929E+01,4.432609E+00,2.383279E+00,& + & 1.179722E+00,4.348385E+00,1.950358E+01,1.166205E+00,1.224983E+00,& + & 8.703576E+00,1.156672E+01,3.194524E-03,1.490281E+00,8.618187E+00,& + & 1.110902E+01,6.571760E-02,1.686375E+00,8.635731E+00,1.060778E+01,& + & 3.098351E-01,1.883442E+00,8.561643E+00,1.027137E+01,5.656471E-01,& + & 2.102574E+00,8.683477E+00,9.510371E+00,1.071623E+00,2.325778E+00,& + & 8.880607E+00,8.603769E+00,1.504729E+00,2.535222E+00,9.316934E+00,& + & 7.296897E+00,1.862755E+00,2.942074E+00,1.032939E+01,4.456770E+00,& + & 2.319706E+00,1.155691E+00,4.308361E+00,1.954364E+01,1.134569E+00/ + data ka_mco (:,:, 6:10) / & + & 1.192908E+00,8.623988E+00,1.166626E+01,3.870783E-03,1.450386E+00,& + & 8.548820E+00,1.120793E+01,6.682718E-02,1.640968E+00,8.573740E+00,& + & 1.070713E+01,3.043270E-01,1.832815E+00,8.503986E+00,1.037606E+01,& + & 5.526917E-01,2.047186E+00,8.633901E+00,9.613507E+00,1.042826E+00,& + & 2.265520E+00,8.843239E+00,8.698942E+00,1.463525E+00,2.470440E+00,& + & 9.294941E+00,7.377492E+00,1.812644E+00,2.879688E+00,1.033996E+01,& + & 4.481402E+00,2.257891E+00,1.132164E+00,4.268797E+00,1.958401E+01,& + & 1.103838E+00,1.161672E+00,8.546145E+00,1.176744E+01,4.694288E-03,& + & 1.411565E+00,8.480953E+00,1.130845E+01,6.800310E-02,1.596785E+00,& + & 8.513095E+00,1.080795E+01,2.989777E-01,1.783549E+00,8.447481E+00,& + & 1.048214E+01,5.400858E-01,1.993263E+00,8.585286E+00,9.717988E+00,& + & 1.014850E+00,2.206836E+00,8.806578E+00,8.795386E+00,1.423502E+00,& + & 2.407349E+00,9.273292E+00,7.459199E+00,1.763923E+00,2.818719E+00,& + & 1.035090E+01,4.506511E+00,2.197774E+00,1.109142E+00,4.229679E+00,& + & 1.962461E+01,1.073989E+00,1.131255E+00,8.470019E+00,1.187031E+01,& + & 5.698176E-03,1.373779E+00,8.414555E+00,1.141057E+01,6.925480E-02,& + & 1.553790E+00,8.453742E+00,1.091028E+01,2.937847E-01,1.735613E+00,& + & 8.392021E+00,1.058976E+01,5.278204E-01,1.940767E+00,8.537590E+00,& + & 9.823880E+00,9.876671E-01,2.149691E+00,8.770558E+00,8.893019E+00,& + & 1.384616E+00,2.345893E+00,9.252002E+00,7.542126E+00,1.716555E+00,& + & 2.759137E+00,1.036232E+01,4.532103E+00,2.139314E+00,1.086609E+00,& + & 4.191007E+00,1.966559E+01,1.044996E+00,1.101636E+00,8.395605E+00,& + & 1.197495E+01,6.923392E-03,1.337003E+00,8.349633E+00,1.151433E+01,& + & 7.059511E-02,1.511959E+00,8.395651E+00,1.101421E+01,2.887453E-01,& + & 1.688963E+00,8.337679E+00,1.069891E+01,5.158859E-01,1.889662E+00,& + & 8.490766E+00,9.931248E+00,9.612602E-01,2.094045E+00,8.735255E+00,& + & 8.991854E+00,1.346836E+00,2.286041E+00,9.231102E+00,7.626287E+00,& + & 1.670496E+00,2.700905E+00,1.037413E+01,4.558193E+00,2.082467E+00,& + & 1.064551E+00,4.152772E+00,1.970689E+01,1.016831E+00,1.072792E+00,& + & 8.322808E+00,1.208146E+01,8.420372E-03,1.301216E+00,8.286127E+00,& + & 1.161985E+01,7.203939E-02,1.471252E+00,8.338843E+00,1.111973E+01,& + & 2.838568E-01,1.643573E+00,8.284400E+00,1.080959E+01,5.042742E-01,& + & 1.839908E+00,8.444860E+00,1.004006E+01,9.356027E-01,2.039854E+00,& + & 8.700564E+00,9.091982E+00,1.310126E+00,2.227742E+00,9.210530E+00,& + & 7.711615E+00,1.625715E+00,2.643988E+00,1.038638E+01,4.584784E+00,& + & 2.027183E+00,1.042963E+00,4.114968E+00,1.974843E+01,9.894703E-01/ + data ka_mco (:,:,11:15) / & + & 1.044705E+00,8.251688E+00,1.218987E+01,1.025161E-02,1.266382E+00,& + & 8.224038E+00,1.172716E+01,7.360805E-02,1.431638E+00,8.283249E+00,& + & 1.122694E+01,2.791173E-01,1.599407E+00,8.232140E+00,1.092190E+01,& + & 4.929758E-01,1.791474E+00,8.399830E+00,1.015039E+01,9.106771E-01,& + & 1.987083E+00,8.666574E+00,9.193375E+00,1.274463E+00,2.170959E+00,& + & 9.190281E+00,7.798220E+00,1.582175E+00,2.588359E+00,1.039907E+01,& + & 4.611888E+00,1.973418E+00,1.021831E+00,4.077592E+00,1.979031E+01,& + & 9.628923E-01,1.017354E+00,8.182122E+00,1.230020E+01,1.249456E-02,& + & 1.232486E+00,8.163281E+00,1.183636E+01,7.532643E-02,1.393095E+00,& + & 8.228854E+00,1.133585E+01,2.745246E-01,1.556423E+00,8.180935E+00,& + & 1.103584E+01,4.819829E-01,1.744318E+00,8.355627E+00,1.026226E+01,& + & 8.864614E-01,1.935694E+00,8.633190E+00,9.296035E+00,1.239810E+00,& + & 2.115649E+00,9.170406E+00,7.886112E+00,1.539841E+00,2.533986E+00,& + & 1.041214E+01,4.639507E+00,1.921129E+00,1.001151E+00,4.040635E+00,& + & 1.983252E+01,9.370753E-01,9.907201E-01,8.114107E+00,1.241267E+01,& + & 1.524523E-02,1.199491E+00,8.103893E+00,1.194749E+01,7.722748E-02,& + & 1.355591E+00,8.175665E+00,1.144659E+01,2.700777E-01,1.514604E+00,& + & 8.130713E+00,1.115150E+01,4.712874E-01,1.698407E+00,8.312305E+00,& + & 1.037568E+01,8.629306E-01,1.885647E+00,8.600481E+00,9.400023E+00,& + & 1.206144E+00,2.061772E+00,9.150877E+00,7.975277E+00,1.498681E+00,& + & 2.480837E+00,1.042568E+01,4.667651E+00,1.870281E+00,9.809031E-01,& + & 4.004095E+00,1.987500E+01,9.119933E-01,9.647858E-01,8.047645E+00,& + & 1.252722E+01,1.862296E-02,1.167384E+00,8.045815E+00,1.206061E+01,& + & 7.935398E-02,1.319096E+00,8.123634E+00,1.155914E+01,2.657762E-01,& + & 1.473904E+00,8.081486E+00,1.126886E+01,4.608813E-01,1.653715E+00,& + & 8.269807E+00,1.049069E+01,8.400666E-01,1.836909E+00,8.568362E+00,& + & 9.505302E+00,1.173429E+00,2.009294E+00,9.131664E+00,8.065772E+00,& + & 1.458655E+00,2.428885E+00,1.043961E+01,4.696328E+00,1.820827E+00,& + & 9.610806E-01,3.967963E+00,1.991781E+01,8.876258E-01,9.395272E-01,& + & 7.982672E+00,1.264403E+01,2.277625E-02,1.136134E+00,7.989050E+00,& + & 1.217580E+01,8.176014E-02,1.283584E+00,8.072761E+00,1.167360E+01,& + & 2.616198E-01,1.434301E+00,8.033230E+00,1.138807E+01,4.507565E-01,& + & 1.610203E+00,8.228136E+00,1.060734E+01,8.178557E-01,1.789447E+00,& + & 8.536900E+00,9.611972E+00,1.141644E+00,1.958177E+00,9.112782E+00,& + & 8.157666E+00,1.419738E+00,2.378101E+00,1.045396E+01,4.725549E+00,& + & 1.772731E+00,9.416792E-01,3.932241E+00,1.996090E+01,8.639574E-01/ + data ka_mco (:,:,16:19) / & + & 9.149350E-01,7.919165E+00,1.276315E+01,2.789023E-02,1.105722E+00,& + & 7.933548E+00,1.229323E+01,8.451703E-02,1.249028E+00,8.023002E+00,& + & 1.179003E+01,2.576097E-01,1.395765E+00,7.985904E+00,1.150906E+01,& + & 4.409059E-01,1.567844E+00,8.187294E+00,1.072567E+01,7.962699E-01,& + & 1.743225E+00,8.506039E+00,9.719952E+00,1.110762E+00,1.908387E+00,& + & 9.094237E+00,8.250892E+00,1.381899E+00,2.328453E+00,1.046876E+01,& + & 4.755318E+00,1.725953E+00,9.226875E-01,3.896915E+00,2.000435E+01,& + & 8.409609E-01,8.909843E-01,7.857117E+00,1.288471E+01,3.419586E-02,& + & 1.076122E+00,7.879281E+00,1.241285E+01,8.771585E-02,1.215404E+00,& + & 7.974363E+00,1.190850E+01,2.537478E-01,1.358267E+00,7.939544E+00,& + & 1.163193E+01,4.313224E-01,1.526601E+00,8.147221E+00,1.084565E+01,& + & 7.752990E-01,1.698209E+00,8.475766E+00,9.829347E+00,1.080755E+00,& + & 1.859885E+00,9.076019E+00,8.345512E+00,1.345106E+00,2.279918E+00,& + & 1.048398E+01,4.785647E+00,1.680465E+00,9.040951E-01,3.861989E+00,& + & 2.004805E+01,8.186184E-01,8.676623E-01,7.796451E+00,1.300879E+01,& + & 4.198187E-02,1.047317E+00,7.826223E+00,1.253489E+01,9.147508E-02,& + & 1.182684E+00,7.926795E+00,1.202911E+01,2.500379E-01,1.321776E+00,& + & 7.894085E+00,1.175677E+01,4.219988E-01,1.486451E+00,8.107926E+00,& + & 1.096736E+01,7.549209E-01,1.654370E+00,8.446103E+00,9.940119E+00,& + & 1.051598E+00,1.812639E+00,9.058131E+00,8.441556E+00,1.309330E+00,& + & 2.232473E+00,1.049959E+01,4.816547E+00,1.636217E+00,8.858920E-01,& + & 3.827453E+00,2.009214E+01,7.969126E-01,8.449501E-01,7.737189E+00,& + & 1.313548E+01,5.160972E-02,1.019282E+00,7.774388E+00,1.265935E+01,& + & 9.594862E-02,1.150849E+00,7.880277E+00,1.215190E+01,2.464855E-01,& + & 1.286268E+00,7.849537E+00,1.188363E+01,4.129282E-01,1.447362E+00,& + & 8.069399E+00,1.109086E+01,7.351195E-01,1.611673E+00,8.417014E+00,& + & 1.005233E+01,1.023263E+00,1.766613E+00,9.040563E+00,8.539082E+00,& + & 1.274538E+00,2.186083E+00,1.051564E+01,4.848026E+00,1.593183E+00,& + & 8.680714E-01,3.793296E+00,2.013648E+01,7.758270E-01 / + + data kb_mo3 (:, :) / & + & 1.490775E-01,9.702107E-01,1.989764E+00,9.182407E-03,1.501879E-01,& + & 9.642382E-01,1.977290E+00,9.293353E-03,1.513181E-01,9.583019E-01,& + & 1.964900E+00,9.405700E-03,1.524683E-01,9.524045E-01,1.952591E+00,& + & 9.519509E-03,1.536387E-01,9.465425E-01,1.940364E+00,9.634777E-03,& + & 1.548303E-01,9.407191E-01,1.928217E+00,9.751513E-03,1.560438E-01,& + & 9.349365E-01,1.916150E+00,9.869768E-03,1.572796E-01,9.291868E-01,& + & 1.904166E+00,9.989533E-03,1.585381E-01,9.234779E-01,1.892256E+00,& + & 1.011083E-02,1.598196E-01,9.178008E-01,1.880428E+00,1.023370E-02,& + & 1.611261E-01,9.121646E-01,1.868681E+00,1.035812E-02,1.624565E-01,& + & 9.065627E-01,1.857005E+00,1.048419E-02,1.638127E-01,9.009955E-01,& + & 1.845410E+00,1.061188E-02,1.651950E-01,8.954659E-01,1.833888E+00,& + & 1.074120E-02,1.666044E-01,8.899733E-01,1.822445E+00,1.087219E-02,& + & 1.680414E-01,8.845118E-01,1.811075E+00,1.100487E-02,1.695064E-01,& + & 8.790872E-01,1.799785E+00,1.113930E-02,1.710011E-01,8.736995E-01,& + & 1.788565E+00,1.127544E-02,1.725257E-01,8.683426E-01,1.777424E+00,& + & 1.141338E-02 / + + + data selfref(:, :) / & + & 9.644149E-03,7.250704E-03,5.669677E-03,4.386020E-03,8.339429E-03,& + & 6.340405E-03,5.034289E-03,4.269775E-03,7.211276E-03,5.545479E-03,& + & 4.472165E-03,4.159378E-03,6.235786E-03,4.851162E-03,3.974695E-03,& + & 4.054660E-03,5.392303E-03,4.244610E-03,3.534299E-03,3.955470E-03,& + & 4.662947E-03,3.714609E-03,3.144287E-03,3.861662E-03,4.032276E-03,& + & 3.251417E-03,2.798787E-03,3.773114E-03,3.486929E-03,2.846528E-03,& + & 2.492587E-03,3.689710E-03,3.015363E-03,2.492534E-03,2.221122E-03,& + & 3.611348E-03,2.607591E-03,2.182978E-03,1.980355E-03,3.537928E-03/ + + + data forref(:, :) / & + & 1.837004E-05,1.303163E-05,1.029351E-05,2.410602E-05,2.183948E-05,& + & 1.149890E-05,6.173082E-06,5.566388E-06,2.050014E-05,1.363103E-05,& + & 5.472967E-06,3.740946E-06,9.438414E-06,1.799757E-05,2.185755E-05,& + & 2.286482E-05 / + + + data fracrefa(:,:) / 5.101700e-01,3.306330e-01,& + & 1.511470e-01,8.063762e-03,5.077900e-01,3.321570e-01,1.519880e-01,& + & 8.064152e-03,5.066600e-01,3.324660e-01,1.527149e-01,8.164282e-03,& + & 5.055600e-01,3.320860e-01,1.540787e-01,8.276842e-03,5.045200e-01,& + & 3.314060e-01,1.556600e-01,8.424142e-03,5.022900e-01,3.313150e-01,& + & 1.577354e-01,8.670942e-03,4.987800e-01,3.319410e-01,1.601018e-01,& + & 9.186950e-03,4.917600e-01,3.336060e-01,1.642744e-01,1.035594e-02,& + & 4.637300e-01,3.524020e-01,1.752389e-01,8.635202e-03 / + + + data fracrefb(:) / & + & 4.151100e-01,3.596800e-01,2.129404e-01,1.227349e-02 / + +!........................................! + end module module_radlw_kgb13 ! +!========================================! + + +!> This module sets up absorption coefficients for band 14: 2250-2380 +!! cm-1 (low - co2; high - co2) +!========================================! + module module_radlw_kgb14 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG14 +! + implicit none +! + private +! +!> MSA14=65 + integer, public :: MSA14 +!> MSB14=235 + integer, public :: MSB14 +!> MSF14=10 + integer, public :: MSF14 +!> MFR14=4 + integer, public :: MFR14 + parameter (MSA14=65, MSB14=235, MSF14=10, MFR14=4) + + +!> the array absa(NG14,65) = ka(NG14,5,13) contains absorption coefs +!! at the NG14=2 chosen g-values for a range of pressure levels>~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 1 to 13 and refers to the corresponding +!! pressure level in pref (e.g. jp = 1 is for a pressure of 1053.63 mb). +!! the third index, ig, goes from 1 to NG14=2, and tells us which +!! g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(NG14,MSA14) + +!> the array absb(NG14,235) = kb(NG14,5,13:59) contains absorption coefs +!! at the NG14=2 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG14=2, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG14,MSB14) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG14=2). + real (kind=kind_phys), public :: selfref(NG14,MSF14) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG14=2). + real (kind=kind_phys), public :: forref(NG14,MFR14) + +!> planck fraction mapping level : p = 142.5940 mb, t = 215.70 k + real (kind=kind_phys), public :: fracrefa(NG14) + +!> planck fraction mapping level : p = 4.758820mb, t = 250.85 k + real (kind=kind_phys), public :: fracrefb(NG14) + + data absa(:, :) / & + & 3.672142E+01,7.151287E+02,3.682345E+01,7.128533E+02,3.697441E+01,& + & 7.096842E+02,3.716507E+01,7.057605E+02,3.739533E+01,7.010681E+02,& + & 3.289657E+01,7.792290E+02,3.302770E+01,7.765127E+02,3.321198E+01,& + & 7.728433E+02,3.344106E+01,7.683670E+02,3.371554E+01,7.629575E+02,& + & 2.916711E+01,8.417973E+02,2.931510E+01,8.388774E+02,2.952029E+01,& + & 8.348850E+02,2.978160E+01,8.299410E+02,3.008678E+01,8.240860E+02,& + & 2.562912E+01,9.011916E+02,2.578993E+01,8.980582E+02,2.601614E+01,& + & 8.937611E+02,2.629696E+01,8.885151E+02,2.663337E+01,8.822387E+02,& + & 2.236034E+01,9.560654E+02,2.252979E+01,9.527390E+02,2.276736E+01,& + & 9.483328E+02,2.307116E+01,9.427225E+02,2.343269E+01,9.360878E+02,& + & 1.936391E+01,1.006428E+03,1.953682E+01,1.003014E+03,1.978455E+01,& + & 9.983550E+02,2.010015E+01,9.926016E+02,2.047798E+01,9.857235E+02,& + & 1.667592E+01,1.051652E+03,1.684797E+01,1.048233E+03,1.709761E+01,& + & 1.043497E+03,1.742141E+01,1.037560E+03,1.781095E+01,1.030553E+03,& + & 1.430295E+01,1.091613E+03,1.447162E+01,1.088219E+03,1.472015E+01,& + & 1.083452E+03,1.504358E+01,1.077523E+03,1.543669E+01,1.070421E+03,& + & 1.223254E+01,1.126608E+03,1.239288E+01,1.123235E+03,1.263730E+01,& + & 1.118533E+03,1.295647E+01,1.112655E+03,1.334062E+01,1.105677E+03,& + & 1.045609E+01,1.156606E+03,1.061214E+01,1.153282E+03,1.085125E+01,& + & 1.148634E+03,1.116276E+01,1.142796E+03,1.150404E+01,1.136542E+03,& + & 8.994407E+00,1.181062E+03,9.182423E+00,1.177202E+03,9.443404E+00,& + & 1.172106E+03,9.726273E+00,1.166730E+03,1.000912E+01,1.161344E+03,& + & 7.759125E+00,1.201707E+03,7.965956E+00,1.197459E+03,8.199482E+00,& + & 1.192802E+03,8.434102E+00,1.188201E+03,8.674476E+00,1.183497E+03,& + & 6.685969E+00,1.219557E+03,6.875999E+00,1.215627E+03,7.068835E+00,& + & 1.211603E+03,7.267012E+00,1.207542E+03,7.472103E+00,1.203382E+03/ + +! --- the array absb(NG14,235) = kb(NG14,5,13:59) contains absorption coefs +! at the NG14=2 chosen g-values for a range of pressure levels< ~100mb +! and temperatures. the first index in the array, jt, which runs from +! 1 to 5, corresponds to different temperatures. more specifically, +! jt = 1-5 means that the data are for the corresponding temperature of +! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +! second index, jp, runs from 13 to 59 and refers to the jpth reference +! pressure level (see taumol.f for the value of these pressure levels +! in mb). the third index, ig, goes from 1 to NG14=2, and tells us +! which g-interval the absorption coefficients are for. + + data absb(:, 1:120) / & + & 6.685969E+00,1.219557E+03,6.875999E+00,1.215627E+03,7.068835E+00,& + & 1.211603E+03,7.267012E+00,1.207542E+03,7.472103E+00,1.203382E+03,& + & 5.756267E+00,1.235008E+03,5.911652E+00,1.231586E+03,6.072568E+00,& + & 1.228012E+03,6.240518E+00,1.224447E+03,6.416910E+00,1.220745E+03,& + & 4.930640E+00,1.248633E+03,5.057980E+00,1.245596E+03,5.193837E+00,& + & 1.242526E+03,5.337490E+00,1.239297E+03,5.491726E+00,1.235934E+03,& + & 4.206057E+00,1.260573E+03,4.313117E+00,1.257842E+03,4.428992E+00,& + & 1.255046E+03,4.554569E+00,1.252150E+03,4.692069E+00,1.249013E+03,& + & 3.577221E+00,1.270872E+03,3.669137E+00,1.268434E+03,3.769735E+00,& + & 1.265865E+03,3.880746E+00,1.263150E+03,4.004233E+00,1.260238E+03,& + & 3.029131E+00,1.279843E+03,3.109090E+00,1.277538E+03,3.197879E+00,& + & 1.275188E+03,3.297849E+00,1.272642E+03,3.411875E+00,1.269913E+03,& + & 2.555308E+00,1.287563E+03,2.624867E+00,1.285482E+03,2.704294E+00,& + & 1.283190E+03,2.796100E+00,1.280836E+03,2.903534E+00,1.278174E+03,& + & 2.150128E+00,1.294107E+03,2.211954E+00,1.292131E+03,2.284875E+00,& + & 1.290015E+03,2.370965E+00,1.287671E+03,2.473889E+00,1.285138E+03,& + & 1.806568E+00,1.299649E+03,1.862725E+00,1.297813E+03,1.930451E+00,& + & 1.295724E+03,2.012810E+00,1.293491E+03,2.111672E+00,1.291100E+03,& + & 1.520510E+00,1.304225E+03,1.573538E+00,1.302408E+03,1.638732E+00,& + & 1.300427E+03,1.719005E+00,1.298196E+03,1.812584E+00,1.295681E+03,& + & 1.281342E+00,1.307984E+03,1.332606E+00,1.306185E+03,1.396720E+00,& + & 1.304214E+03,1.473303E+00,1.302030E+03,1.559021E+00,1.299725E+03,& + & 1.081496E+00,1.311107E+03,1.132114E+00,1.309317E+03,1.194512E+00,& + & 1.307369E+03,1.266204E+00,1.305292E+03,1.343225E+00,1.303070E+03,& + & 9.159355E-01,1.313636E+03,9.656344E-01,1.311888E+03,1.024809E+00,& + & 1.309969E+03,1.090012E+00,1.308002E+03,1.159841E+00,1.305872E+03,& + & 7.792592E-01,1.315670E+03,8.274369E-01,1.313994E+03,8.819511E-01,& + & 1.312167E+03,9.407707E-01,1.310278E+03,1.003934E+00,1.308203E+03,& + & 6.661180E-01,1.317313E+03,7.110229E-01,1.315697E+03,7.600761E-01,& + & 1.313971E+03,8.132993E-01,1.312182E+03,8.707422E-01,1.310268E+03,& + & 5.712640E-01,1.318665E+03,6.118753E-01,1.317044E+03,6.562169E-01,& + & 1.315455E+03,7.046516E-01,1.313873E+03,7.576346E-01,1.311834E+03,& + & 4.911417E-01,1.319799E+03,5.279823E-01,1.318317E+03,5.684600E-01,& + & 1.316674E+03,6.128948E-01,1.315032E+03,6.624806E-01,1.313208E+03,& + & 4.234191E-01,1.320682E+03,4.569876E-01,1.319240E+03,4.940764E-01,& + & 1.317680E+03,5.356081E-01,1.316044E+03,5.823432E-01,1.314239E+03,& + & 3.663862E-01,1.321410E+03,3.971572E-01,1.319987E+03,4.317073E-01,& + & 1.318477E+03,4.707808E-01,1.316723E+03,5.153889E-01,1.315079E+03,& + & 3.183449E-01,1.322041E+03,3.468829E-01,1.320531E+03,3.794151E-01,& + & 1.319126E+03,4.166778E-01,1.317497E+03,4.596374E-01,1.315709E+03,& + & 2.779478E-01,1.322363E+03,3.047837E-01,1.321076E+03,3.356974E-01,& + & 1.319357E+03,3.715553E-01,1.317974E+03,4.134899E-01,1.316112E+03,& + & 2.432618E-01,1.322734E+03,2.686113E-01,1.321415E+03,2.981571E-01,& + & 1.319998E+03,3.328734E-01,1.318384E+03,3.738584E-01,1.316514E+03,& + & 2.120775E-01,1.323188E+03,2.359104E-01,1.321886E+03,2.639391E-01,& + & 1.320406E+03,2.972953E-01,1.318819E+03,3.370262E-01,1.316901E+03,& + & 1.836655E-01,1.323578E+03,2.057662E-01,1.322416E+03,2.320611E-01,& + & 1.320868E+03,2.636657E-01,1.319303E+03,3.015205E-01,1.317518E+03/ + data absb(:,121:235) / & + & 1.569007E-01,1.324225E+03,1.768941E-01,1.322879E+03,2.009778E-01,& + & 1.321542E+03,2.302032E-01,1.320046E+03,2.654412E-01,1.318389E+03,& + & 1.341250E-01,1.324729E+03,1.522204E-01,1.323512E+03,1.742499E-01,& + & 1.322126E+03,2.012447E-01,1.320701E+03,2.340710E-01,1.318967E+03,& + & 1.148377E-01,1.325118E+03,1.312134E-01,1.323965E+03,1.514136E-01,& + & 1.322671E+03,1.764519E-01,1.321272E+03,2.070380E-01,1.319560E+03,& + & 9.712973E-02,1.325714E+03,1.116694E-01,1.324557E+03,1.298153E-01,& + & 1.323227E+03,1.524952E-01,1.321878E+03,1.804482E-01,1.320289E+03,& + & 8.204486E-02,1.326214E+03,9.491353E-02,1.325038E+03,1.111157E-01,& + & 1.323847E+03,1.315764E-01,1.322458E+03,1.570221E-01,1.320951E+03,& + & 6.926446E-02,1.326637E+03,8.070129E-02,1.325463E+03,9.513955E-02,& + & 1.321166E+03,1.135472E-01,1.322980E+03,1.367096E-01,1.321597E+03,& + & 5.794108E-02,1.327091E+03,6.796800E-02,1.326037E+03,8.068676E-02,& + & 1.324821E+03,9.701704E-02,1.323709E+03,1.177839E-01,1.322307E+03,& + & 4.821716E-02,1.327562E+03,5.693838E-02,1.326468E+03,6.810103E-02,& + & 1.325149E+03,8.244896E-02,1.324145E+03,1.009125E-01,1.322860E+03,& + & 4.007449E-02,1.328032E+03,4.763306E-02,1.326978E+03,5.738321E-02,& + & 1.325885E+03,7.002480E-02,1.324699E+03,8.636919E-02,1.323505E+03,& + & 3.313281E-02,1.328462E+03,3.962039E-02,1.327422E+03,4.805842E-02,& + & 1.326422E+03,5.911164E-02,1.325241E+03,7.350151E-02,1.323974E+03,& + & 2.714435E-02,1.329007E+03,3.262528E-02,1.327862E+03,3.981732E-02,& + & 1.326808E+03,4.931502E-02,1.325761E+03,6.185411E-02,1.324649E+03,& + & 2.219825E-02,1.329568E+03,2.680154E-02,1.328392E+03,3.289387E-02,& + & 1.327362E+03,4.101352E-02,1.326311E+03,5.189236E-02,1.325143E+03,& + & 1.812170E-02,1.329824E+03,2.197023E-02,1.328890E+03,2.709921E-02,& + & 1.327899E+03,3.400640E-02,1.326768E+03,4.337343E-02,1.325673E+03,& + & 1.482534E-02,1.330424E+03,1.807424E-02,1.329336E+03,2.240309E-02,& + & 1.328244E+03,2.829347E-02,1.327211E+03,3.636436E-02,1.326162E+03,& + & 1.211322E-02,1.330738E+03,1.487359E-02,1.329680E+03,1.853599E-02,& + & 1.328819E+03,2.355894E-02,1.327812E+03,3.050050E-02,1.326610E+03,& + & 9.861279E-03,1.331162E+03,1.220299E-02,1.330154E+03,1.531208E-02,& + & 1.329064E+03,1.956939E-02,1.328157E+03,2.551456E-02,1.327076E+03,& + & 7.997304E-03,1.331677E+03,9.969956E-03,1.330511E+03,1.261739E-02,& + & 1.329570E+03,1.622384E-02,1.328408E+03,2.128787E-02,1.327568E+03,& + & 6.506917E-03,1.331748E+03,8.171931E-03,1.330909E+03,1.043827E-02,& + & 1.329919E+03,1.353957E-02,1.328836E+03,1.788070E-02,1.327790E+03,& + & 5.293791E-03,1.331930E+03,6.698743E-03,1.331213E+03,8.637127E-03,& + & 1.330270E+03,1.131588E-02,1.329191E+03,1.506023E-02,1.328251E+03,& + & 4.296892E-03,1.332424E+03,5.473468E-03,1.331482E+03,7.122481E-03,& + & 1.330527E+03,9.427982E-03,1.329488E+03,1.266821E-02,1.328488E+03,& + & 3.476845E-03,1.332619E+03,4.458585E-03,1.331877E+03,5.850893E-03,& + & 1.330995E+03,7.825783E-03,1.329856E+03,1.063109E-02,1.328864E+03,& + & 2.813932E-03,1.332837E+03,3.636628E-03,1.332096E+03,4.811777E-03,& + & 1.331222E+03,6.502977E-03,1.330184E+03,8.937313E-03,1.329209E+03,& + & 2.375139E-03,1.332864E+03,3.109563E-03,1.332268E+03,4.166618E-03,& + & 1.331343E+03,5.708828E-03,1.330438E+03,7.961458E-03,1.329279E+03/ + + + data selfref(:, :) / & + & 3.930090E-03,3.388899E-03,3.293934E-03,2.818632E-03,2.760914E-03,& + & 2.344326E-03,2.314284E-03,1.949837E-03,1.940018E-03,1.621728E-03,& + & 1.626375E-03,1.348838E-03,1.363522E-03,1.121869E-03,1.143214E-03,& + & 9.330872E-04,9.585599E-04,7.760755E-04,8.037774E-04,6.454850E-04/ + + data forref(:, :) / & + & 1.350198E-06,4.360136E-07,1.349980E-06,4.394677E-07,1.349963E-06,& + & 4.399740E-07,1.331931E-06,7.314919E-07 / + + data fracrefa(:) / 9.520200e-01,4.797805e-02 / + + + data fracrefb(:) / 9.474890e-01,5.252305e-02 / + +!........................................! + end module module_radlw_kgb14 ! +!========================================! + + +!> This module sets up absorption coefficients for band 15: 2380-2600 +!! cm-1 (low - n2o, co2; high - /) +!========================================! + module module_radlw_kgb15 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG15 +! + implicit none +! + private +! +!> MSA15=585 + integer, public :: MSA15 +!> MSF15=10 + integer, public :: MSF15 +!> MFR15=4 + integer, public :: MFR15 +!> MAF15=9 + integer, public :: MAF15 +!> MMN15=19 + integer, public :: MMN15 + parameter (MSA15=585, MSF15=10, MFR15=4, MAF15=9, MMN15=19) + +!> the array absa(NG15,585) = ka(NG15,9,5,13) contains absorption coefs +!! at the NG15=2 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different column +!! amount ratios, as expressed through the binary species parameter eta, +!! defined as eta = gas1/(gas1+(rat)*gas2), where rat is the ratio of +!! the reference mls column amount value of gas1 to that of gas2. the +!! 2nd index in the array, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that the +!! data are for the corresponding temperature of tref-30, tref-15, tref, +!! tref+15, and tref+30, respectively. the third index, jp, runs from +!! 1 to 13 and refers to the reference pressure level (e.g. jp = 1 is +!! for a pressure of 1053.63 mb). the fourth index, ig, goes from 1 to +!! NG15=2, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG15,MSA15) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG15=2). + real (kind=kind_phys), public :: forref(NG15,MFR15) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG15=2). + real (kind=kind_phys), public :: selfref(NG15,MSF15) + +!> planck fraction mapping level : p = 1053. mb, t = 294.2 k + real (kind=kind_phys), public :: fracrefa(NG15,MAF15) + +!> the array ka_mxx contains the absorption coefficient for a minor +!! species at the NG15=2 chosen g-values for a reference pressure +!! level below 100~ mb. the first index in the array, js, runs from +!! 1 to 9, and corresponds to different gas column amount ratios, as +!! expressed through the binary species parameter eta, defined as +!! eta = gas1/(gas1 + (rat) * gas2), where rat is the ratio of the +!! reference mls column amount value of gas1 to that of gas2. the +!! second index refers to temperature in 7.2 degree increments. for +!! instance, jt = 1 refers to a temperature of 188.0, jt = 2 refers +!! to 195.2, etc. the third index runs over the g-channel (1 to NG15=2). + real (kind=kind_phys), public :: ka_mn2(NG15,MAF15,MMN15) + + data absa( :, 1:120) / & + & 1.335233E+00,2.404464E+03,1.268224E+00,2.103907E+03,1.201221E+00,& + & 1.803332E+03,1.134218E+00,1.502770E+03,1.067205E+00,1.202237E+03,& + & 1.000205E+00,9.016735E+02,9.331980E-01,6.011177E+02,8.303014E-01,& + & 3.011376E+02,7.991101E-01,2.817155E-03,1.292299E+00,3.108511E+03,& + & 1.230640E+00,2.719927E+03,1.168996E+00,2.331377E+03,1.107341E+00,& + & 1.942811E+03,1.045694E+00,1.554247E+03,9.840356E-01,1.165698E+03,& + & 9.223855E-01,7.771189E+02,8.315372E-01,3.890365E+02,7.989519E-01,& + & 3.687888E-03,1.264555E+00,3.912219E+03,1.206349E+00,3.423199E+03,& + & 1.148143E+00,2.934173E+03,1.089946E+00,2.445145E+03,1.031745E+00,& + & 1.956127E+03,9.735375E-01,1.467080E+03,9.153349E-01,9.780526E+02,& + & 8.361608E-01,4.893710E+02,7.983743E-01,1.041619E-02,1.253257E+00,& + & 4.808980E+03,1.196431E+00,4.207864E+03,1.139605E+00,3.606744E+03,& + & 1.082769E+00,3.005642E+03,1.025950E+00,2.404485E+03,9.691196E-01,& + & 1.803357E+03,9.122871E-01,1.202255E+03,8.417465E-01,6.013494E+02,& + & 7.941315E-01,7.441580E-02,1.261995E+00,5.790115E+03,1.204035E+00,& + & 5.066369E+03,1.146053E+00,4.342602E+03,1.088068E+00,3.618819E+03,& + & 1.030092E+00,2.895055E+03,9.721050E-01,2.171305E+03,9.141278E-01,& + & 1.447530E+03,8.494218E-01,7.238713E+02,7.803744E-01,2.894263E-01,& + & 1.116147E+00,2.114205E+03,1.076619E+00,1.849924E+03,1.037087E+00,& + & 1.585655E+03,9.975606E-01,1.321376E+03,9.580230E-01,1.057101E+03,& + & 9.184952E-01,7.928210E+02,8.693099E-01,5.287109E+02,7.727753E-01,& + & 2.653532E+02,7.965460E-01,5.574995E-02,1.077953E+00,2.773647E+03,& + & 1.043184E+00,2.426954E+03,1.008409E+00,2.080248E+03,9.736438E-01,& + & 1.733527E+03,9.388765E-01,1.386829E+03,9.041096E-01,1.040123E+03,& + & 8.609327E-01,6.935451E+02,7.786692E-01,3.476137E+02,7.590573E-01,& + & 6.605130E-01,1.052242E+00,3.534410E+03,1.020669E+00,3.092610E+03,& + & 9.890808E-01,2.650826E+03,9.575042E-01,2.208980E+03,9.259377E-01,& + & 1.767220E+03,8.943559E-01,1.325409E+03,8.578126E-01,8.836879E+02,& + & 7.861765E-01,4.425292E+02,7.241259E-01,1.222999E+00,1.040079E+00,& + & 4.391368E+03,1.009988E+00,3.842456E+03,9.799087E-01,3.293541E+03,& + & 9.498148E-01,2.744608E+03,9.197223E-01,2.195692E+03,8.896337E-01,& + & 1.646765E+03,8.582703E-01,1.097864E+03,7.959491E-01,5.494647E+02,& + & 6.912953E-01,1.750006E+00,1.044423E+00,5.337352E+03,1.013740E+00,& + & 4.670230E+03,9.830547E-01,4.003021E+03,9.523628E-01,3.335854E+03,& + & 9.216765E-01,2.668695E+03,8.910001E-01,2.001529E+03,8.603111E-01,& + & 1.334347E+03,8.066909E-01,6.675465E+02,6.582553E-01,2.277527E+00,& + & 9.415570E-01,1.744801E+03,9.239313E-01,1.526698E+03,9.063049E-01,& + & 1.308600E+03,8.886713E-01,1.090508E+03,8.710500E-01,8.724027E+02,& + & 8.534200E-01,6.542982E+02,7.971733E-01,4.368231E+02,7.134478E-01,& + & 2.197962E+02,6.847699E-01,1.874328E+00,9.058200E-01,2.339553E+03,& + & 8.926481E-01,2.047118E+03,8.794673E-01,1.754650E+03,8.662916E-01,& + & 1.462214E+03,8.531073E-01,1.169783E+03,8.399340E-01,8.773317E+02,& + & 7.934362E-01,5.854219E+02,7.211071E-01,2.939398E+02,6.505228E-01,& + & 2.426087E+00,8.802880E-01,3.037649E+03,8.702810E-01,2.657956E+03,& + & 8.602869E-01,2.278265E+03,8.502787E-01,1.898539E+03,8.402738E-01,& + & 1.518834E+03,8.302660E-01,1.139131E+03,7.947873E-01,7.598345E+02,& + & 7.316837E-01,3.809806E+02,6.174973E-01,2.958085E+00,8.657269E-01,& + & 3.835846E+03,8.575086E-01,3.356371E+03,8.492976E-01,2.876902E+03/ + data absa( :,121:240) / & + & 8.410905E-01,2.397421E+03,8.328828E-01,1.917922E+03,8.246670E-01,& + & 1.438449E+03,7.983364E-01,9.592580E+02,7.438616E-01,4.805214E+02,& + & 5.875235E-01,3.439472E+00,8.641892E-01,4.727434E+03,8.561351E-01,& + & 4.136501E+03,8.480647E-01,3.545615E+03,8.400004E-01,2.954645E+03,& + & 8.319457E-01,2.363712E+03,8.238742E-01,1.772795E+03,8.055806E-01,& + & 1.182019E+03,7.576215E-01,5.917455E+02,5.628719E-01,3.832890E+00,& + & 7.976964E-01,1.398963E+03,7.981222E-01,1.224090E+03,7.985497E-01,& + & 1.049229E+03,7.989853E-01,8.743627E+02,7.994102E-01,6.994864E+02,& + & 7.781903E-01,5.249603E+02,7.261955E-01,3.509439E+02,6.514020E-01,& + & 1.772883E+02,5.972287E-01,3.300043E+00,7.642214E-01,1.925194E+03,& + & 7.688055E-01,1.684538E+03,7.734030E-01,1.443908E+03,7.779887E-01,& + & 1.203254E+03,7.825745E-01,9.626052E+02,7.658843E-01,7.222921E+02,& + & 7.256373E-01,4.823693E+02,6.609094E-01,2.428428E+02,5.601434E-01,& + & 3.897043E+00,7.392834E-01,2.555051E+03,7.469661E-01,2.235683E+03,& + & 7.546571E-01,1.916296E+03,7.623462E-01,1.596927E+03,7.700286E-01,& + & 1.277527E+03,7.598715E-01,9.584475E+02,7.285995E-01,6.396846E+02,& + & 6.733167E-01,3.213210E+02,5.299548E-01,4.382952E+00,7.232306E-01,& + & 3.287689E+03,7.329003E-01,2.876727E+03,7.425738E-01,2.465784E+03,& + & 7.522475E-01,2.054808E+03,7.619109E-01,1.643861E+03,7.593340E-01,& + & 1.233090E+03,7.358327E-01,8.226591E+02,6.870300E-01,4.126438E+02,& + & 5.044447E-01,4.792699E+00,7.174317E-01,4.118354E+03,7.277985E-01,& + & 3.603550E+03,7.381601E-01,3.088787E+03,7.485210E-01,2.573969E+03,& + & 7.588870E-01,2.059172E+03,7.622320E-01,1.544512E+03,7.457210E-01,& + & 1.030137E+03,7.029573E-01,5.162078E+02,4.801446E-01,5.181516E+00,& + & 6.770113E-01,1.108630E+03,6.925967E-01,9.700560E+02,7.081813E-01,& + & 8.314775E+02,7.237664E-01,6.929017E+02,7.298411E-01,5.544700E+02,& + & 7.009121E-01,4.166162E+02,6.556560E-01,2.790180E+02,5.894298E-01,& + & 1.417624E+02,5.154496E-01,4.632049E+00,6.460197E-01,1.568639E+03,& + & 6.654439E-01,1.372558E+03,6.848658E-01,1.176497E+03,7.042948E-01,& + & 9.804153E+02,7.119394E-01,7.845140E+02,6.921167E-01,5.890705E+02,& + & 6.567281E-01,3.938750E+02,5.995318E-01,1.990345E+02,4.824896E-01,& + & 5.161112E+00,6.223065E-01,2.131876E+03,6.446825E-01,1.865364E+03,& + & 6.670422E-01,1.598887E+03,6.894218E-01,1.332403E+03,7.001455E-01,& + & 1.066117E+03,6.887465E-01,8.001783E+02,6.622117E-01,5.344910E+02,& + & 6.126392E-01,2.691730E+02,4.536579E-01,5.624837E+00,6.059746E-01,& + & 2.799169E+03,6.303594E-01,2.449255E+03,6.547474E-01,2.099373E+03,& + & 6.791397E-01,1.749481E+03,6.945184E-01,1.399729E+03,6.902150E-01,& + & 1.050307E+03,6.709808E-01,7.011079E+02,6.274536E-01,3.523133E+02,& + & 4.284847E-01,6.029149E+00,5.977853E-01,3.567777E+03,6.231640E-01,& + & 3.121816E+03,6.485515E-01,2.675822E+03,6.739326E-01,2.229855E+03,& + & 6.939462E-01,1.783996E+03,6.963749E-01,1.338389E+03,6.832288E-01,& + & 8.930342E+02,6.446298E-01,4.480889E+02,4.106352E-01,6.314285E+00,& + & 5.772661E-01,8.566453E+02,6.053853E-01,7.495682E+02,6.335083E-01,& + & 6.424839E+02,6.612658E-01,5.354069E+02,6.530899E-01,4.289155E+02,& + & 6.276004E-01,3.227007E+02,5.879193E-01,2.167193E+02,5.296104E-01,& + & 1.110359E+02,4.453051E-01,5.775724E+00,5.485347E-01,1.251501E+03,& + & 5.802014E-01,1.095057E+03,6.118746E-01,9.386269E+02,6.412272E-01,& + & 7.822206E+02,6.377618E-01,6.263575E+02,6.202423E-01,4.707145E+02/ + data absa( :,241:360) / & + & 5.896072E-01,3.152821E+02,5.393550E-01,1.601726E+02,4.125986E-01,& + & 6.299421E+00,5.261549E-01,1.747444E+03,5.605913E-01,1.529017E+03,& + & 5.950356E-01,1.310590E+03,6.250380E-01,1.092229E+03,6.283368E-01,& + & 8.743023E+02,6.188483E-01,6.565746E+02,5.959821E-01,4.390710E+02,& + & 5.522111E-01,2.219110E+02,3.857951E-01,6.729408E+00,5.100019E-01,& + & 2.347330E+03,5.464376E-01,2.053927E+03,5.828789E-01,1.760496E+03,& + & 6.152888E-01,1.467151E+03,6.250431E-01,1.174169E+03,6.221274E-01,& + & 8.813815E+02,6.055469E-01,5.888247E+02,5.671086E-01,2.966189E+02,& + & 3.670143E-01,7.030118E+00,5.004738E-01,3.050882E+03,5.380705E-01,& + & 2.669511E+03,5.756718E-01,2.288164E+03,6.110226E-01,1.906835E+03,& + & 6.264878E-01,1.525834E+03,6.296418E-01,1.145018E+03,6.189585E-01,& + & 7.644470E+02,5.843545E-01,3.842583E+02,3.549899E-01,7.221424E+00,& + & 4.993794E-01,6.596871E+02,5.372986E-01,5.772283E+02,5.752315E-01,& + & 4.947696E+02,5.950376E-01,4.125914E+02,5.856193E-01,3.309020E+02,& + & 5.621379E-01,2.494352E+02,5.266466E-01,1.681620E+02,4.736086E-01,& + & 8.717236E+01,3.854757E-01,6.752187E+00,4.725871E-01,9.979452E+02,& + & 5.138073E-01,8.732078E+02,5.550298E-01,7.484706E+02,5.745466E-01,& + & 6.240713E+02,5.710587E-01,5.000488E+02,5.554109E-01,3.762290E+02,& + & 5.284346E-01,2.525846E+02,4.832870E-01,1.292396E+02,3.547171E-01,& + & 7.243169E+00,4.514304E-01,1.435021E+03,4.952632E-01,1.255639E+03,& + & 5.390927E-01,1.076260E+03,5.602377E-01,8.972527E+02,5.628265E-01,& + & 7.185371E+02,5.545397E-01,5.400051E+02,5.343328E-01,3.616653E+02,& + & 4.955736E-01,1.836258E+02,3.320835E-01,7.604812E+00,4.357348E-01,& + & 1.975987E+03,4.814962E-01,1.728984E+03,5.272646E-01,1.481981E+03,& + & 5.514527E-01,1.235340E+03,5.603179E-01,9.889332E+02,5.583857E-01,& + & 7.427081E+02,5.439613E-01,4.966815E+02,5.101598E-01,2.509738E+02,& + & 3.165977E-01,7.851762E+00,4.256230E-01,2.622749E+03,4.726259E-01,& + & 2.294909E+03,5.196361E-01,1.967059E+03,5.485056E-01,1.639512E+03,& + & 5.635593E-01,1.312168E+03,5.665336E-01,9.850542E+02,5.570998E-01,& + & 6.581212E+02,5.265658E-01,3.315321E+02,3.105649E-01,7.946081E+00,& + & 4.428029E-01,5.139836E+02,4.878768E-01,4.497326E+02,5.318371E-01,& + & 3.855007E+02,5.390429E-01,3.218677E+02,5.292119E-01,2.585100E+02,& + & 5.075694E-01,1.953404E+02,4.723958E-01,1.323918E+02,4.204172E-01,& + & 6.971493E+01,3.372478E-01,7.541398E+00,4.173788E-01,8.073871E+02,& + & 4.655684E-01,7.064644E+02,5.095429E-01,6.056061E+02,5.194331E-01,& + & 5.053034E+02,5.154478E-01,4.052234E+02,5.006773E-01,3.053239E+02,& + & 4.745962E-01,2.055998E+02,4.303295E-01,1.061703E+02,3.101850E-01,& + & 7.971140E+00,3.971375E-01,1.197851E+03,4.478020E-01,1.048125E+03,& + & 4.916401E-01,8.985098E+02,5.058785E-01,7.493634E+02,5.073005E-01,& + & 6.004374E+02,4.990655E-01,4.516545E+02,4.799625E-01,3.030479E+02,& + & 4.425900E-01,1.547372E+02,2.904862E-01,8.284012E+00,3.818499E-01,& + & 1.693379E+03,4.343893E-01,1.481715E+03,4.792503E-01,1.270151E+03,& + & 4.976906E-01,1.059041E+03,5.050935E-01,8.480997E+02,5.024062E-01,& + & 6.373179E+02,4.893965E-01,4.267068E+02,4.572733E-01,2.164042E+02,& + & 2.773420E-01,8.492112E+00,3.714979E-01,2.298079E+03,4.253086E-01,& + & 2.010824E+03,4.716628E-01,1.723699E+03,4.953066E-01,1.436901E+03,& + & 5.079493E-01,1.150311E+03,5.104289E-01,8.638886E+02,5.015000E-01,& + & 5.776439E+02,4.736104E-01,2.917008E+02,2.747238E-01,8.531017E+00/ + data absa( :,361:480) / & + & 3.914135E-01,3.915910E+02,4.431272E-01,3.426400E+02,4.807001E-01,& + & 2.939095E+02,4.857408E-01,2.457192E+02,4.765124E-01,1.977536E+02,& + & 4.534599E-01,1.500129E+02,4.183415E-01,1.024677E+02,3.681874E-01,& + & 5.516403E+01,2.958688E-01,8.220020E+00,3.677576E-01,6.408920E+02,& + & 4.222296E-01,5.607829E+02,4.586001E-01,4.809606E+02,4.666603E-01,& + & 4.016044E+02,4.624465E-01,3.224371E+02,4.468480E-01,2.434591E+02,& + & 4.202426E-01,1.646592E+02,3.776024E-01,8.611813E+01,2.716001E-01,& + & 8.602896E+00,3.486607E-01,9.838429E+02,4.054468E-01,8.608737E+02,& + & 4.416083E-01,7.382218E+02,4.537064E-01,6.159585E+02,4.544440E-01,& + & 4.938886E+02,4.455138E-01,3.719641E+02,4.260106E-01,2.502235E+02,& + & 3.894575E-01,1.287522E+02,2.532356E-01,8.892854E+00,3.340286E-01,& + & 1.430984E+03,3.926010E-01,1.252119E+03,4.298531E-01,1.073583E+03,& + & 4.457904E-01,8.954017E+02,4.517048E-01,7.173763E+02,4.489803E-01,& + & 5.394988E+02,4.353901E-01,3.617962E+02,4.036517E-01,1.843789E+02,& + & 2.425754E-01,9.059678E+00,3.238053E-01,1.988767E+03,3.836092E-01,& + & 1.740177E+03,4.227938E-01,1.491904E+03,4.433444E-01,1.243961E+03,& + & 4.541654E-01,9.961397E+02,4.564294E-01,7.484807E+02,4.477377E-01,& + & 5.009934E+02,4.201146E-01,2.538104E+02,2.424166E-01,9.058330E+00,& + & 3.450515E-01,3.065768E+02,4.024646E-01,2.682591E+02,4.309509E-01,& + & 2.304034E+02,4.351406E-01,1.929405E+02,4.247520E-01,1.557151E+02,& + & 4.005889E-01,1.187142E+02,3.672811E-01,8.185889E+01,3.197132E-01,& + & 4.523533E+01,2.572331E-01,8.853244E+00,3.229717E-01,5.215488E+02,& + & 3.830555E-01,4.563584E+02,4.102701E-01,3.916919E+02,4.175087E-01,& + & 3.273569E+02,4.111095E-01,2.632325E+02,3.945872E-01,1.992809E+02,& + & 3.684419E-01,1.354831E+02,3.281532E-01,7.191531E+01,2.358455E-01,& + & 9.188266E+00,3.053793E-01,8.266155E+02,3.674350E-01,7.232957E+02,& + & 3.942488E-01,6.205375E+02,4.047820E-01,5.180480E+02,4.040457E-01,& + & 4.157388E+02,3.938442E-01,3.135876E+02,3.744754E-01,2.115761E+02,& + & 3.395286E-01,1.095509E+02,2.201714E-01,9.433451E+00,2.918418E-01,& + & 1.234353E+03,3.546071E-01,1.080081E+03,3.833820E-01,9.263554E+02,& + & 3.975467E-01,7.728667E+02,4.020706E-01,6.195343E+02,3.978361E-01,& + & 4.663350E+02,3.833712E-01,3.133123E+02,3.531146E-01,1.605380E+02,& + & 2.122833E-01,9.554422E+00,2.822763E-01,1.753839E+03,3.453112E-01,& + & 1.534644E+03,3.771748E-01,1.315937E+03,3.953051E-01,1.097482E+03,& + & 4.047799E-01,8.791434E+02,4.053309E-01,6.609566E+02,3.958548E-01,& + & 4.429358E+02,3.687856E-01,2.251932E+02,2.135665E-01,9.529001E+00,& + & 2.938837E-01,3.118188E+02,3.547306E-01,2.728894E+02,3.752648E-01,& + & 2.346120E+02,3.793159E-01,1.966026E+02,3.682350E-01,1.588372E+02,& + & 3.478252E-01,1.212236E+02,3.189775E-01,8.374482E+01,2.778998E-01,& + & 4.646608E+01,2.147780E-01,9.542432E+00,2.758156E-01,5.322606E+02,& + & 3.361133E-01,4.658291E+02,3.584211E-01,3.999976E+02,3.649083E-01,& + & 3.344242E+02,3.583191E-01,2.690717E+02,3.445077E-01,2.038270E+02,& + & 3.222526E-01,1.387221E+02,2.867958E-01,7.383018E+01,1.982336E-01,& + & 9.798682E+00,2.614376E-01,8.453976E+02,3.217341E-01,7.398440E+02,& + & 3.459607E-01,6.348743E+02,3.554644E-01,5.301381E+02,3.542150E-01,& + & 4.255812E+02,3.461203E-01,3.211351E+02,3.289328E-01,2.168325E+02,& + & 2.983237E-01,1.127492E+02,1.874619E-01,9.964389E+00,2.508048E-01,& + & 1.264236E+03,3.112431E-01,1.106345E+03,3.376118E-01,9.489960E+02/ + data absa( :,481:585) / & + & 3.509984E-01,7.918696E+02,3.550286E-01,6.348889E+02,3.514681E-01,& + & 4.780423E+02,3.390130E-01,3.213267E+02,3.119349E-01,1.648549E+02,& + & 1.865269E-01,9.973146E+00,2.438628E-01,1.797967E+03,3.046014E-01,& + & 1.573384E+03,3.338380E-01,1.349275E+03,3.511945E-01,1.125403E+03,& + & 3.599984E-01,9.016244E+02,3.609541E-01,6.779918E+02,3.520884E-01,& + & 4.545140E+02,3.278441E-01,2.313000E+02,1.893329E-01,9.922980E+00,& + & 2.550046E-01,3.234408E+02,3.120074E-01,2.831968E+02,3.309612E-01,& + & 2.435700E+02,3.317766E-01,2.042418E+02,3.213243E-01,1.650944E+02,& + & 3.029620E-01,1.260716E+02,2.775257E-01,8.716454E+01,2.415060E-01,& + & 4.843031E+01,1.817936E-01,1.007770E+01,2.399725E-01,5.535643E+02,& + & 2.965025E-01,4.845915E+02,3.167029E-01,4.162067E+02,3.203108E-01,& + & 3.480998E+02,3.146067E-01,2.801336E+02,3.013310E-01,2.122961E+02,& + & 2.817695E-01,1.445576E+02,2.504151E-01,7.701120E+01,1.691833E-01,& + & 1.027036E+01,2.287069E-01,8.805414E+02,2.849866E-01,7.707276E+02,& + & 3.066346E-01,6.614646E+02,3.134476E-01,5.524469E+02,3.124509E-01,& + & 4.435607E+02,3.043583E-01,3.347875E+02,2.891273E-01,2.261299E+02,& + & 2.616824E-01,1.176711E+02,1.626736E-01,1.036693E+01,2.206487E-01,& + & 1.317971E+03,2.772399E-01,1.153499E+03,3.005777E-01,9.895450E+02,& + & 3.114184E-01,8.258009E+02,3.145824E-01,6.621814E+02,3.111003E-01,& + & 4.986642E+02,2.998446E-01,3.352819E+02,2.751417E-01,1.721098E+02,& + & 1.646142E-01,1.032896E+01,2.154536E-01,1.875526E+03,2.728514E-01,& + & 1.641332E+03,2.988996E-01,1.407663E+03,3.139749E-01,1.174172E+03,& + & 3.209322E-01,9.408024E+02,3.212623E-01,7.075489E+02,3.129884E-01,& + & 4.744263E+02,2.907841E-01,2.415401E+02,1.681483E-01,1.026696E+01,& + & 2.321142E-01,3.502733E+02,2.844634E-01,3.068027E+02,2.994852E-01,& + & 2.639375E+02,2.978858E-01,2.213314E+02,2.868307E-01,1.788867E+02,& + & 2.693531E-01,1.365410E+02,2.450102E-01,9.431051E+01,2.116923E-01,& + & 5.222243E+01,1.574797E-01,1.047254E+01,2.196172E-01,6.008037E+02,& + & 2.716895E-01,5.260467E+02,2.875399E-01,4.518692E+02,2.882620E-01,& + & 3.779425E+02,2.814570E-01,3.041302E+02,2.686898E-01,2.304236E+02,& + & 2.493786E-01,1.568135E+02,2.204247E-01,8.336163E+01,1.476564E-01,& + & 1.062025E+01,2.099678E-01,9.568188E+02,2.619057E-01,8.375861E+02,& + & 2.796262E-01,7.188883E+02,2.834983E-01,6.004302E+02,2.808067E-01,& + & 4.820654E+02,2.722982E-01,3.638056E+02,2.569910E-01,2.456475E+02,& + & 2.313255E-01,1.276607E+02,1.434537E-01,1.067918E+01,2.034797E-01,& + & 1.433268E+03,2.557565E-01,1.254468E+03,2.757008E-01,1.076200E+03,& + & 2.827781E-01,8.981393E+02,2.840612E-01,7.201854E+02,2.794632E-01,& + & 5.423102E+02,2.676937E-01,3.645547E+02,2.443360E-01,1.869871E+02,& + & 1.461054E-01,1.062963E+01,1.994986E-01,2.040615E+03,2.529750E-01,& + & 1.785906E+03,2.754985E-01,1.531682E+03,2.863979E-01,1.277654E+03,& + & 2.912614E-01,1.023710E+03,2.898782E-01,7.698743E+02,2.810157E-01,& + & 5.161611E+02,2.595202E-01,2.626492E+02,1.489091E-01,1.057919E+01/ + + + data ka_mn2 (:,:, 1:10) / & + & 5.594486E-07,1.738457E-06,5.593694E-07,1.738457E-06,5.597305E-07,& + & 1.738457E-06,5.600172E-07,1.738457E-06,5.620929E-07,1.738457E-06,& + & 5.681331E-07,1.738457E-06,5.714456E-07,1.738457E-06,6.309266E-07,& + & 1.261456E-06,5.602275E-07,1.787695E-06,5.570724E-07,1.704777E-06,& + & 5.569955E-07,1.704777E-06,5.573180E-07,1.704777E-06,5.575582E-07,& + & 1.704777E-06,5.593455E-07,1.704777E-06,5.644641E-07,1.704777E-06,& + & 5.672565E-07,1.704777E-06,6.198865E-07,1.254987E-06,5.575462E-07,& + & 1.750013E-06,5.547872E-07,1.671756E-06,5.547139E-07,1.671756E-06,& + & 5.549982E-07,1.671756E-06,5.551968E-07,1.671756E-06,5.567140E-07,& + & 1.671756E-06,5.610010E-07,1.671756E-06,5.633247E-07,1.671756E-06,& + & 6.097742E-07,1.248710E-06,5.549892E-07,1.713161E-06,5.525921E-07,& + & 1.639367E-06,5.525220E-07,1.639367E-06,5.527704E-07,1.639367E-06,& + & 5.529304E-07,1.639367E-06,5.542022E-07,1.639367E-06,5.577377E-07,& + & 1.639367E-06,5.596432E-07,1.639367E-06,6.005273E-07,1.242620E-06,& + & 5.525553E-07,1.677120E-06,5.504882E-07,1.607614E-06,5.504222E-07,& + & 1.607614E-06,5.506361E-07,1.607614E-06,5.507627E-07,1.607614E-06,& + & 5.518085E-07,1.607614E-06,5.546732E-07,1.607614E-06,5.562082E-07,& + & 1.607614E-06,5.920893E-07,1.236721E-06,5.502457E-07,1.641867E-06,& + & 5.484755E-07,1.576472E-06,5.484148E-07,1.576472E-06,5.485953E-07,& + & 1.576472E-06,5.486908E-07,1.576472E-06,5.495325E-07,1.576472E-06,& + & 5.518037E-07,1.576472E-06,5.530131E-07,1.576472E-06,5.844089E-07,& + & 1.231010E-06,5.480600E-07,1.607395E-06,5.465538E-07,1.545932E-06,& + & 5.464979E-07,1.545932E-06,5.466475E-07,1.545932E-06,5.467182E-07,& + & 1.545932E-06,5.473769E-07,1.545932E-06,5.491281E-07,1.545932E-06,& + & 5.500538E-07,1.545932E-06,5.774360E-07,1.225469E-06,5.459986E-07,& + & 1.573667E-06,5.447237E-07,1.515987E-06,5.446735E-07,1.515987E-06,& + & 5.447942E-07,1.515987E-06,5.448418E-07,1.515987E-06,5.453389E-07,& + & 1.515987E-06,5.466437E-07,1.515987E-06,5.473286E-07,1.515987E-06,& + & 5.711292E-07,1.220108E-06,5.440607E-07,1.540689E-06,5.429829E-07,& + & 1.486622E-06,5.429391E-07,1.486622E-06,5.430330E-07,1.486622E-06,& + & 5.430628E-07,1.486622E-06,5.434201E-07,1.486622E-06,5.443480E-07,& + & 1.486622E-06,5.448287E-07,1.486622E-06,5.654481E-07,1.214925E-06,& + & 5.422469E-07,1.508423E-06,5.413328E-07,1.457825E-06,5.412951E-07,& + & 1.457825E-06,5.413655E-07,1.457825E-06,5.413806E-07,1.457825E-06,& + & 5.416218E-07,1.457825E-06,5.422377E-07,1.457825E-06,5.425523E-07,& + & 1.457825E-06,5.603548E-07,1.209909E-06,5.405579E-07,1.476865E-06/ + data ka_mn2 (:,:,11:19) / & + & 5.397752E-07,1.429587E-06,5.397443E-07,1.429587E-06,5.397936E-07,& + & 1.429587E-06,5.397977E-07,1.429587E-06,5.399441E-07,1.429587E-06,& + & 5.403121E-07,1.429587E-06,5.404963E-07,1.429587E-06,5.558156E-07,& + & 1.205057E-06,5.389955E-07,1.445994E-06,5.383088E-07,1.401896E-06,& + & 5.382854E-07,1.401896E-06,5.383166E-07,1.401896E-06,5.383137E-07,& + & 1.401896E-06,5.383857E-07,1.401896E-06,5.385696E-07,1.401896E-06,& + & 5.386567E-07,1.401896E-06,5.518015E-07,1.200366E-06,5.375572E-07,& + & 1.415799E-06,5.369332E-07,1.374736E-06,5.369180E-07,1.374736E-06,& + & 5.369338E-07,1.374736E-06,5.369276E-07,1.374736E-06,5.369505E-07,& + & 1.374736E-06,5.370075E-07,1.374736E-06,5.370303E-07,1.374736E-06,& + & 5.482826E-07,1.195848E-06,5.362448E-07,1.386259E-06,5.356487E-07,& + & 1.348109E-06,5.356437E-07,1.348109E-06,5.356465E-07,1.348109E-06,& + & 5.356413E-07,1.348109E-06,5.356364E-07,1.348109E-06,5.356238E-07,& + & 1.348109E-06,5.356121E-07,1.348109E-06,5.452337E-07,1.191476E-06,& + & 5.350593E-07,1.357359E-06,5.344578E-07,1.321994E-06,5.344618E-07,& + & 1.321994E-06,5.344569E-07,1.321994E-06,5.344547E-07,1.321994E-06,& + & 5.344436E-07,1.321994E-06,5.344176E-07,1.321994E-06,5.344014E-07,& + & 1.321994E-06,5.426316E-07,1.187266E-06,5.340010E-07,1.329083E-06,& + & 5.333578E-07,1.296390E-06,5.333729E-07,1.296390E-06,5.333627E-07,& + & 1.296390E-06,5.333688E-07,1.296390E-06,5.333753E-07,1.296390E-06,& + & 5.333866E-07,1.296390E-06,5.333956E-07,1.296390E-06,5.404546E-07,& + & 1.183202E-06,5.330696E-07,1.301430E-06,5.323527E-07,1.271276E-06,& + & 5.323788E-07,1.271276E-06,5.323682E-07,1.271276E-06,5.323846E-07,& + & 1.271276E-06,5.324336E-07,1.271276E-06,5.325316E-07,1.271276E-06,& + & 5.325919E-07,1.271276E-06,5.386839E-07,1.179292E-06,5.322681E-07,& + & 1.274365E-06,5.314404E-07,1.246649E-06,5.314792E-07,1.246649E-06,& + & 5.314719E-07,1.246649E-06,5.315006E-07,1.246649E-06,5.316158E-07,& + & 1.246649E-06,5.318504E-07,1.246649E-06,5.319870E-07,1.246649E-06,& + & 5.373009E-07,1.175526E-06,5.315953E-07,1.247887E-06,5.306220E-07,& + & 1.222506E-06,5.306748E-07,1.222506E-06,5.306750E-07,1.222506E-06,& + & 5.307195E-07,1.222506E-06,5.309246E-07,1.222506E-06,5.313402E-07,& + & 1.222506E-06,5.315800E-07,1.222506E-06,5.362903E-07,1.171908E-06,& + & 5.310523E-07,1.221984E-06 / + + + data selfref(:, :) / & + & 2.113244E-03,2.866145E-03,1.732586E-03,2.379109E-03,1.420592E-03,& + & 1.974833E-03,1.164859E-03,1.639260E-03,9.552300E-04,1.360716E-03,& + & 7.833818E-04,1.129511E-03,6.424952E-04,9.375903E-04,5.269840E-04,& + & 7.782827E-04,4.322720E-04,6.460456E-04,3.546087E-04,5.362797E-04/ + + data forref(:, :) / & + & 4.599959E-07,1.470318E-07,4.573767E-07,1.893844E-07,4.480988E-07,& + & 3.394793E-07,4.508676E-07,2.948068E-07 / + + + data fracrefa(:,:) / 9.171470e-01,8.285743e-02,9.171570e-01,& + & 8.285743e-02,9.171270e-01,8.285743e-02,9.171470e-01,8.285743e-02,& + & 9.171570e-01,8.285743e-02,9.171470e-01,8.285743e-02,9.171420e-01,& + & 8.285743e-02,9.208350e-01,7.917243e-02,9.206130e-01,7.939339e-02/ + +!........................................! + end module module_radlw_kgb15 ! +!========================================! + + +!> This module sets up absorption coefficients for band 16: 2600-3000 +!! cm-1 (low - h2o, ch4; high - /) +!========================================! + module module_radlw_kgb16 ! +!........................................! +! + use physparam, only : kind_phys + use module_radlw_parameters, only : NG16 +! + implicit none +! + private +! +!> MSA16=585 + integer, public :: MSA16 +!> MSB16=235 + integer, public :: MSB16 +!> MSF16=10 + integer, public :: MSF16 +!> MFR16=4 + integer, public :: MFR16 +!> MAF16=9 + integer, public :: MAF16 + parameter (MSA16=585, MSB16=235, MSF16=10, MFR16=4, MAF16=9) + +!> the array forref contains the coefficient of the water vapor +!! foreign-continuum (including the energy term). the first +!! index refers to reference temperature (296,260,224,260) and +!! pressure (970,475,219,3 mbar) levels. the second index +!! runs over the g-channel (1 to NG16=2). + real (kind=kind_phys), public :: forref(NG16,MFR16) + +!> the array absa(NG16,585) = ka(NG16,9,5,13) contains absorption coefs +!! at the NG16=2 g-intervals for a range of pressure levels > ~100mb, +!! temperatures, and ratios of water vapor to co2. the first index in +!! the array, js, runs from 1 to 9, and corresponds to different column +!! amount ratios, as expressed through the binary species parameter eta, +!! defined as eta = gas1/(gas1+(rat)*gas2), where rat is the ratio of +!! the reference mls column amount value of gas1 to that of gas2. the +!! 2nd index in the array, jt, which runs from 1 to 5, corresponds to +!! different temperatures. more specifically, jt = 1-5 means that the +!! data are for the corresponding temperature of tref-30, tref-15, tref, +!! tref+15, and tref+30, respectively. the third index, jp, runs from +!! 1 to 13 and refers to the reference pressure level (e.g. jp = 1 is +!! for a pressure of 1053.63 mb). the fourth index, ig, goes from 1 to +!! NG16=2, and tells us which g-interval the absorption coefficients +!! are for. + real (kind=kind_phys), public :: absa(NG16,MSA16) + +!> the array absb(NG16,235) = kb(NG16,5,13:59) contains absorption coefs +!! at the NG16=2 chosen g-values for a range of pressure levels< ~100mb +!! and temperatures. the first index in the array, jt, which runs from +!! 1 to 5, corresponds to different temperatures. more specifically, +!! jt = 1-5 means that the data are for the corresponding temperature of +!! tref-30, tref-15, tref, tref+15, and tref+30, respectively. the +!! second index, jp, runs from 13 to 59 and refers to the jpth reference +!! pressure level (see taumol.f for the value of these pressure levels +!! in mb). the third index, ig, goes from 1 to NG16=2, and tells us +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(NG16,MSB16) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG16=2). + real (kind=kind_phys), public :: selfref(NG16,MSF16) + +!> planck fraction mapping level: p = 387.6100 mbar, t = 250.17 k + real (kind=kind_phys), public :: fracrefa(NG16,MAF16) + +!> planck fraction mapping level : p=95.58350 mb, t = 215.70 k + real (kind=kind_phys), public :: fracrefb(NG16) + + data absa( :, 1:120) / & + & 3.081950E-06,3.707347E-04,3.144653E-05,2.379110E-03,5.103357E-05,& + & 4.399030E-03,6.982088E-05,6.419611E-03,8.866588E-05,8.439390E-03,& + & 1.087866E-04,1.045539E-02,1.321460E-04,1.246333E-02,1.699120E-04,& + & 1.443783E-02,1.476886E-04,1.654405E-02,3.184950E-06,3.698967E-04,& + & 3.218561E-05,2.375298E-03,5.229701E-05,4.392525E-03,7.152374E-05,& + & 6.410414E-03,9.133628E-05,8.426759E-03,1.119559E-04,1.044027E-02,& + & 1.358998E-04,1.244588E-02,1.717975E-04,1.442132E-02,1.520376E-04,& + & 1.652074E-02,3.301788E-06,3.692493E-04,3.292859E-05,2.375073E-03,& + & 5.356124E-05,4.392938E-03,7.361931E-05,6.410951E-03,9.366073E-05,& + & 8.428132E-03,1.149694E-04,1.044239E-02,1.398156E-04,1.244809E-02,& + & 1.759725E-04,1.442563E-02,1.570849E-04,1.652371E-02,3.382889E-06,& + & 3.679816E-04,3.372614E-05,2.377852E-03,5.492661E-05,4.399976E-03,& + & 7.560154E-05,6.422094E-03,9.636844E-05,8.443495E-03,1.181038E-04,& + & 1.046199E-02,1.430338E-04,1.247312E-02,1.803738E-04,1.445460E-02,& + & 1.616953E-04,1.655650E-02,3.478421E-06,3.669572E-04,3.465524E-05,& + & 2.384550E-03,5.652803E-05,4.414490E-03,7.781433E-05,6.444831E-03,& + & 9.911664E-05,8.474393E-03,1.216856E-04,1.050092E-02,1.474522E-04,& + & 1.251979E-02,1.849306E-04,1.451061E-02,1.677684E-04,1.661833E-02,& + & 4.213307E-06,5.704625E-04,3.230796E-05,2.558017E-03,4.964693E-05,& + & 4.559957E-03,6.542439E-05,6.563690E-03,8.090682E-05,8.567359E-03,& + & 9.668079E-05,1.056990E-02,1.143211E-04,1.256737E-02,1.405798E-04,& + & 1.454499E-02,1.252262E-04,1.660827E-02,4.354619E-06,5.692646E-04,& + & 3.299520E-05,2.552579E-03,5.070504E-05,4.550505E-03,6.705208E-05,& + & 6.550156E-03,8.281370E-05,8.550130E-03,9.904596E-05,1.054863E-02,& + & 1.174886E-04,1.254154E-02,1.444534E-04,1.451513E-02,1.293493E-04,& + & 1.657402E-02,4.515103E-06,5.683325E-04,3.385171E-05,2.550485E-03,& + & 5.189632E-05,4.547779E-03,6.860129E-05,6.546662E-03,8.511558E-05,& + & 8.545332E-03,1.017413E-04,1.054329E-02,1.201934E-04,1.253626E-02,& + & 1.475495E-04,1.450981E-02,1.333030E-04,1.656610E-02,4.652734E-06,& + & 5.668313E-04,3.466752E-05,2.551440E-03,5.327657E-05,4.551336E-03,& + & 7.043594E-05,6.553116E-03,8.726154E-05,8.554804E-03,1.045962E-04,& + & 1.055511E-02,1.238085E-04,1.255066E-02,1.507735E-04,1.452852E-02,& + & 1.378397E-04,1.658609E-02,4.763064E-06,5.648788E-04,3.551099E-05,& + & 2.555772E-03,5.474232E-05,4.562129E-03,7.258497E-05,6.570102E-03,& + & 8.999195E-05,8.578393E-03,1.077856E-04,1.058514E-02,1.273080E-04,& + & 1.258781E-02,1.547559E-04,1.457290E-02,1.430361E-04,1.663531E-02,& + & 7.686776E-06,1.186761E-03,3.863036E-05,3.098129E-03,5.458200E-05,& + & 5.029812E-03,6.800565E-05,6.964890E-03,7.978629E-05,8.901913E-03,& + & 9.074642E-05,1.083968E-02,1.018923E-04,1.277621E-02,1.161266E-04,& + & 1.470480E-02,1.051064E-04,1.668024E-02,7.947187E-06,1.184490E-03,& + & 3.944153E-05,3.089870E-03,5.579616E-05,5.015603E-03,6.931286E-05,& + & 6.945369E-03,8.164783E-05,8.876270E-03,9.310084E-05,1.080797E-02,& + & 1.042916E-04,1.273931E-02,1.191554E-04,1.466197E-02,1.086802E-04,& + & 1.663102E-02,8.205718E-06,1.181868E-03,4.036070E-05,3.084199E-03,& + & 5.708598E-05,5.007426E-03,7.098170E-05,6.934410E-03,8.340658E-05,& + & 8.863158E-03,9.515257E-05,1.079255E-02,1.071284E-04,1.272065E-02,& + & 1.219412E-04,1.464180E-02,1.120087E-04,1.660771E-02,8.510726E-06,& + & 1.179802E-03,4.143174E-05,3.082340E-03,5.851994E-05,5.006255E-03/ + data absa( :,121:240) / & + & 7.290486E-05,6.933779E-03,8.568018E-05,8.863265E-03,9.765275E-05,& + & 1.079343E-02,1.097716E-04,1.272278E-02,1.250971E-04,1.464457E-02,& + & 1.159851E-04,1.661009E-02,8.709217E-06,1.175834E-03,4.240035E-05,& + & 3.082407E-03,5.994724E-05,5.010821E-03,7.486066E-05,6.942778E-03,& + & 8.813845E-05,8.876697E-03,1.006339E-04,1.081143E-02,1.130399E-04,& + & 1.274536E-02,1.285629E-04,1.467200E-02,1.202732E-04,1.664159E-02,& + & 1.419208E-05,2.518065E-03,5.017370E-05,4.261664E-03,6.490335E-05,& + & 6.034122E-03,7.631454E-05,7.811045E-03,8.492403E-05,9.591593E-03,& + & 9.208189E-05,1.137405E-02,9.728703E-05,1.315886E-02,1.021381E-04,& + & 1.494251E-02,8.856180E-05,1.675623E-02,1.469256E-05,2.513941E-03,& + & 5.122447E-05,4.249811E-03,6.629560E-05,6.014601E-03,7.788789E-05,& + & 7.784252E-03,8.687209E-05,9.557412E-03,9.387386E-05,1.133292E-02,& + & 9.975998E-05,1.310975E-02,1.045624E-04,1.488646E-02,9.181337E-05,& + & 1.669207E-02,1.520038E-05,2.508833E-03,5.237097E-05,4.239873E-03,& + & 6.787329E-05,6.000112E-03,7.952189E-05,7.765701E-03,8.895278E-05,& + & 9.534297E-03,9.614995E-05,1.130567E-02,1.017253E-04,1.307884E-02,& + & 1.071637E-04,1.485104E-02,9.449124E-05,1.665217E-02,1.568626E-05,& + & 2.503030E-03,5.363553E-05,4.232355E-03,6.948857E-05,5.991622E-03,& + & 8.135734E-05,7.756067E-03,9.108248E-05,9.523657E-03,9.865267E-05,& + & 1.129366E-02,1.044024E-04,1.306602E-02,1.096847E-04,1.483793E-02,& + & 9.779134E-05,1.663734E-02,1.627167E-05,2.498584E-03,5.518539E-05,& + & 4.229154E-03,7.148114E-05,5.990496E-03,8.367882E-05,7.757396E-03,& + & 9.362025E-05,9.527248E-03,1.014668E-04,1.129975E-02,1.076451E-04,& + & 1.307424E-02,1.129078E-04,1.484876E-02,1.013095E-04,1.665045E-02,& + & 2.401929E-05,4.896066E-03,6.535278E-05,6.340956E-03,7.943566E-05,& + & 7.822647E-03,8.821236E-05,9.311489E-03,9.429825E-05,1.080416E-02,& + & 9.740273E-05,1.230054E-02,9.785045E-05,1.380069E-02,9.528923E-05,& + & 1.530424E-02,7.479935E-05,1.683424E-02,2.488190E-05,4.889466E-03,& + & 6.666981E-05,6.324974E-03,8.113938E-05,7.797624E-03,9.012990E-05,& + & 9.277625E-03,9.617283E-05,1.076163E-02,9.958571E-05,1.224906E-02,& + & 9.985922E-05,1.374080E-02,9.765690E-05,1.523522E-02,7.753148E-05,& + & 1.675581E-02,2.576852E-05,4.880768E-03,6.816596E-05,6.309965E-03,& + & 8.298041E-05,7.776427E-03,9.218711E-05,9.250703E-03,9.833967E-05,& + & 1.072885E-02,1.017704E-04,1.221084E-02,1.023375E-04,1.369659E-02,& + & 9.965559E-05,1.518655E-02,7.994142E-05,1.670057E-02,2.663451E-05,& + & 4.870496E-03,6.982085E-05,6.296297E-03,8.502955E-05,7.759935E-03,& + & 9.449610E-05,9.231563E-03,1.007066E-04,1.070752E-02,1.040814E-04,& + & 1.218767E-02,1.049437E-04,1.367029E-02,1.021503E-04,1.515775E-02,& + & 8.276622E-05,1.666974E-02,2.769494E-05,4.862573E-03,7.195316E-05,& + & 6.287647E-03,8.757701E-05,7.751652E-03,9.727872E-05,9.223624E-03,& + & 1.035069E-04,1.070033E-02,1.069566E-04,1.218077E-02,1.078585E-04,& + & 1.366439E-02,1.053350E-04,1.515223E-02,8.562279E-05,1.666544E-02,& + & 3.777093E-05,8.905319E-03,8.390157E-05,9.848604E-03,9.767876E-05,& + & 1.083568E-02,1.044306E-04,1.183241E-02,1.069141E-04,1.283484E-02,& + & 1.060373E-04,1.384204E-02,1.018615E-04,1.485331E-02,9.271065E-05,& + & 1.587104E-02,6.359336E-05,1.691715E-02,3.919659E-05,8.896297E-03,& + & 8.570529E-05,9.828971E-03,9.967353E-05,1.080561E-02,1.066768E-04,& + & 1.179163E-02,1.091642E-04,1.278370E-02,1.082593E-04,1.378076E-02/ + data absa( :,241:360) / & + & 1.040749E-04,1.478227E-02,9.456607E-05,1.578997E-02,6.578828E-05,& + & 1.682541E-02,4.060913E-05,8.883077E-03,8.765658E-05,9.807903E-03,& + & 1.019348E-04,1.077722E-02,1.090652E-04,1.175607E-02,1.117068E-04,& + & 1.274127E-02,1.107148E-04,1.373123E-02,1.062876E-04,1.472586E-02,& + & 9.691139E-05,1.572701E-02,6.801530E-05,1.675538E-02,4.200669E-05,& + & 8.866063E-03,8.976201E-05,9.786465E-03,1.044833E-04,1.075161E-02,& + & 1.117620E-04,1.172672E-02,1.144629E-04,1.270819E-02,1.133876E-04,& + & 1.369466E-02,1.086934E-04,1.468606E-02,9.950223E-05,1.568314E-02,& + & 7.050410E-05,1.670809E-02,4.341546E-05,8.846429E-03,9.210095E-05,& + & 9.765381E-03,1.072361E-04,1.073010E-02,1.147299E-04,1.170423E-02,& + & 1.174611E-04,1.268606E-02,1.164071E-04,1.367251E-02,1.114842E-04,& + & 1.466436E-02,1.022182E-04,1.566161E-02,7.271225E-05,1.668661E-02,& + & 6.244608E-05,1.715520E-02,1.150437E-04,1.706351E-02,1.283613E-04,& + & 1.702468E-02,1.326424E-04,1.699859E-02,1.311154E-04,1.698005E-02,& + & 1.244983E-04,1.696861E-02,1.133173E-04,1.696349E-02,9.618395E-05,& + & 1.696602E-02,5.562339E-05,1.700104E-02,6.494837E-05,1.714426E-02,& + & 1.176012E-04,1.704056E-02,1.310717E-04,1.698996E-02,1.353906E-04,& + & 1.695200E-02,1.337779E-04,1.692172E-02,1.272871E-04,1.689815E-02,& + & 1.158482E-04,1.688162E-02,9.840079E-05,1.687301E-02,5.761111E-05,& + & 1.689656E-02,6.738416E-05,1.712361E-02,1.203553E-04,1.701169E-02,& + & 1.341386E-04,1.695262E-02,1.385127E-04,1.690666E-02,1.368094E-04,& + & 1.686875E-02,1.301423E-04,1.683765E-02,1.184942E-04,1.681286E-02,& + & 1.006101E-04,1.679692E-02,5.973104E-05,1.681260E-02,6.980842E-05,& + & 1.709549E-02,1.233200E-04,1.697848E-02,1.374582E-04,1.691484E-02,& + & 1.419564E-04,1.686409E-02,1.401641E-04,1.682209E-02,1.333942E-04,& + & 1.678682E-02,1.213967E-04,1.675855E-02,1.029117E-04,1.673932E-02,& + & 6.179927E-05,1.675058E-02,7.227345E-05,1.706106E-02,1.265374E-04,& + & 1.694253E-02,1.410825E-04,1.687793E-02,1.456844E-04,1.682672E-02,& + & 1.439185E-04,1.678391E-02,1.369162E-04,1.674842E-02,1.246838E-04,& + & 1.672032E-02,1.055254E-04,1.670139E-02,6.410915E-05,1.671276E-02,& + & 1.219327E-04,3.908084E-02,1.832507E-04,3.623536E-02,1.958621E-04,& + & 3.345643E-02,1.956397E-04,3.069567E-02,1.866096E-04,2.794580E-02,& + & 1.700838E-04,2.520657E-02,1.462815E-04,2.247691E-02,1.129162E-04,& + & 1.976108E-02,5.135206E-05,1.708331E-02,1.270910E-04,3.906987E-02,& + & 1.880674E-04,3.621162E-02,2.002852E-04,3.341946E-02,1.998064E-04,& + & 3.064479E-02,1.904873E-04,2.788189E-02,1.736276E-04,2.512937E-02,& + & 1.493611E-04,2.238716E-02,1.155408E-04,1.965767E-02,5.329273E-05,& + & 1.696665E-02,1.320346E-04,3.903656E-02,1.930401E-04,3.616898E-02,& + & 2.051030E-04,3.336968E-02,2.044815E-04,3.058633E-02,1.948798E-04,& + & 2.781538E-02,1.777218E-04,2.505493E-02,1.527903E-04,2.230470E-02,& + & 1.182122E-04,1.956789E-02,5.535111E-05,1.686976E-02,1.369241E-04,& + & 3.898205E-02,1.982318E-04,3.611237E-02,2.102964E-04,3.330861E-02,& + & 2.094788E-04,3.052273E-02,1.997100E-04,2.774926E-02,1.821334E-04,& + & 2.498589E-02,1.566345E-04,2.223346E-02,1.212090E-04,1.949437E-02,& + & 5.745289E-05,1.679437E-02,1.419943E-04,3.891238E-02,2.037036E-04,& + & 3.604283E-02,2.157559E-04,3.324154E-02,2.149958E-04,3.045710E-02,& + & 2.050260E-04,2.768520E-02,1.869592E-04,2.492447E-02,1.608880E-04,& + & 2.217488E-02,1.245432E-04,1.943848E-02,5.966459E-05,1.674125E-02/ + data absa( :,361:480) / & + & 4.493984E-04,1.686798E-01,5.218135E-04,1.495753E-01,5.137009E-04,& + & 1.305792E-01,4.840477E-04,1.116128E-01,4.397623E-04,9.266476E-02,& + & 3.811989E-04,7.373666E-02,3.065040E-04,5.483147E-02,2.095173E-04,& + & 3.595494E-02,5.935169E-05,1.715230E-02,4.699116E-04,1.687017E-01,& + & 5.392782E-04,1.495767E-01,5.291815E-04,1.305619E-01,4.968809E-04,& + & 1.115748E-01,4.502344E-04,9.261213E-02,3.896147E-04,7.366608E-02,& + & 3.132365E-04,5.474102E-02,2.141024E-04,3.584576E-02,6.300060E-05,& + & 1.702208E-02,4.892756E-04,1.686156E-01,5.567561E-04,1.494866E-01,& + & 5.451667E-04,1.304676E-01,5.107971E-04,1.114801E-01,4.616179E-04,& + & 9.251358E-02,3.987810E-04,7.356324E-02,3.203148E-04,5.463609E-02,& + & 2.191072E-04,3.573819E-02,6.647997E-05,1.691180E-02,5.084043E-04,& + & 1.684305E-01,5.741022E-04,1.493193E-01,5.608018E-04,1.303086E-01,& + & 5.251469E-04,1.113316E-01,4.738214E-04,9.237483E-02,4.088509E-04,& + & 7.343798E-02,3.282406E-04,5.452219E-02,2.245442E-04,3.563686E-02,& + & 7.023435E-05,1.682062E-02,5.277932E-04,1.681706E-01,5.923137E-04,& + & 1.490789E-01,5.773720E-04,1.300939E-01,5.402029E-04,1.111400E-01,& + & 4.868018E-04,9.220897E-02,4.197668E-04,7.329524E-02,3.370004E-04,& + & 5.440448E-02,2.304818E-04,3.554346E-02,7.415532E-05,1.675195E-02,& + & 1.870473E-03,8.182678E-01,1.861845E-03,7.178459E-01,1.715443E-03,& + & 6.176042E-01,1.531736E-03,5.174113E-01,1.321050E-03,4.172655E-01,& + & 1.084026E-03,3.171457E-01,8.185038E-04,2.170691E-01,5.109708E-04,& + & 1.170488E-01,9.575204E-05,1.717469E-02,1.963490E-03,8.186302E-01,& + & 1.939942E-03,7.181542E-01,1.782939E-03,6.178556E-01,1.586560E-03,& + & 5.176042E-01,1.364418E-03,4.173863E-01,1.116923E-03,3.172041E-01,& + & 8.402592E-04,2.170645E-01,5.222441E-04,1.169785E-01,1.040811E-04,& + & 1.702912E-02,2.050826E-03,8.184604E-01,2.015105E-03,7.179841E-01,& + & 1.847851E-03,6.176954E-01,1.642349E-03,5.174464E-01,1.409971E-03,& + & 4.172419E-01,1.151971E-03,3.170655E-01,8.639646E-04,2.169314E-01,& + & 5.350929E-04,1.168528E-01,1.101325E-04,1.690525E-02,2.134630E-03,& + & 8.177970E-01,2.088934E-03,7.173934E-01,1.912621E-03,6.171710E-01,& + & 1.697586E-03,5.169926E-01,1.455523E-03,4.168530E-01,1.186699E-03,& + & 3.167516E-01,8.888043E-04,2.166837E-01,5.492796E-04,1.166803E-01,& + & 1.160457E-04,1.680091E-02,2.218447E-03,8.167033E-01,2.161966E-03,& + & 7.164374E-01,1.976903E-03,6.163312E-01,1.753170E-03,5.162780E-01,& + & 1.500928E-03,4.162695E-01,1.222600E-03,3.162895E-01,9.148688E-04,& + & 2.163552E-01,5.645004E-04,1.164719E-01,1.224543E-04,1.671766E-02,& + & 2.791298E-03,1.386402E+00,2.689881E-03,1.214946E+00,2.438018E-03,& + & 1.043695E+00,2.146104E-03,8.724470E-01,1.822020E-03,7.012731E-01,& + & 1.471907E-03,5.301511E-01,1.088501E-03,3.590450E-01,6.570669E-04,& + & 1.880271E-01,1.107479E-04,1.715867E-02,2.933576E-03,1.387071E+00,& + & 2.810360E-03,1.215495E+00,2.540738E-03,1.044133E+00,2.232496E-03,& + & 8.728012E-01,1.890422E-03,7.015344E-01,1.522448E-03,5.303051E-01,& + & 1.122701E-03,3.591126E-01,6.743861E-04,1.879880E-01,1.168254E-04,& + & 1.701610E-02,3.069863E-03,1.386766E+00,2.926561E-03,1.215207E+00,& + & 2.640827E-03,1.043892E+00,2.316725E-03,8.725735E-01,1.960419E-03,& + & 7.013269E-01,1.575677E-03,5.301161E-01,1.157944E-03,3.589460E-01,& + & 6.923620E-04,1.878495E-01,1.225430E-04,1.689236E-02,3.200234E-03,& + & 1.385643E+00,3.040910E-03,1.214232E+00,2.740499E-03,1.043010E+00/ + data absa( :,481:585) / & + & 2.401200E-03,8.718379E-01,2.029478E-03,7.007194E-01,1.627303E-03,& + & 5.296302E-01,1.194007E-03,3.585923E-01,7.124903E-04,1.876214E-01,& + & 1.281899E-04,1.678809E-02,3.326131E-03,1.383828E+00,3.152676E-03,& + & 1.212635E+00,2.835919E-03,1.041606E+00,2.482519E-03,8.706615E-01,& + & 2.096589E-03,6.997568E-01,1.680666E-03,5.288909E-01,1.232289E-03,& + & 3.580699E-01,7.341745E-04,1.873159E-01,1.344496E-04,1.670439E-02,& + & 3.089878E-03,1.745672E+00,2.938004E-03,1.529300E+00,2.643828E-03,& + & 1.313133E+00,2.313128E-03,1.097015E+00,1.953362E-03,8.809459E-01,& + & 1.564584E-03,6.648982E-01,1.145587E-03,4.488778E-01,6.814354E-04,& + & 2.329607E-01,1.075978E-04,1.716667E-02,3.242559E-03,1.746511E+00,& + & 3.068982E-03,1.530018E+00,2.757965E-03,1.313730E+00,2.408455E-03,& + & 1.097502E+00,2.029708E-03,8.813008E-01,1.623174E-03,6.651278E-01,& + & 1.185101E-03,4.490050E-01,7.010494E-04,2.329432E-01,1.127257E-04,& + & 1.701666E-02,3.395168E-03,1.746191E+00,3.200342E-03,1.529712E+00,& + & 2.869847E-03,1.313462E+00,2.503570E-03,1.097227E+00,2.106695E-03,& + & 8.810627E-01,1.681159E-03,6.649258E-01,1.224474E-03,4.488274E-01,& + & 7.221530E-04,2.327926E-01,1.173207E-04,1.690152E-02,3.535463E-03,& + & 1.744769E+00,3.325639E-03,1.528474E+00,2.978194E-03,1.312355E+00,& + & 2.594449E-03,1.096332E+00,2.181469E-03,8.803030E-01,1.739104E-03,& + & 6.643319E-01,1.265323E-03,4.484013E-01,7.448752E-04,2.325281E-01,& + & 1.222672E-04,1.679853E-02,3.673247E-03,1.742493E+00,3.450080E-03,& + & 1.526487E+00,3.087279E-03,1.310638E+00,2.687387E-03,1.094858E+00,& + & 2.257775E-03,8.791259E-01,1.799266E-03,6.634135E-01,1.307465E-03,& + & 4.477620E-01,7.686124E-04,2.321703E-01,1.276117E-04,1.671634E-02,& + & 2.743023E-03,1.760440E+00,2.604903E-03,1.542279E+00,2.343586E-03,& + & 1.324313E+00,2.047014E-03,1.106311E+00,1.726010E-03,8.884051E-01,& + & 1.381137E-03,6.705171E-01,1.009359E-03,4.526651E-01,5.973268E-04,& + & 2.348647E-01,9.451907E-05,1.718608E-02,2.881836E-03,1.761317E+00,& + & 2.720474E-03,1.543016E+00,2.444417E-03,1.324880E+00,2.132101E-03,& + & 1.106802E+00,1.795706E-03,8.887601E-01,1.433733E-03,6.707415E-01,& + & 1.044131E-03,4.527745E-01,6.158063E-04,2.348515E-01,9.853822E-05,& + & 1.704581E-02,3.017140E-03,1.760921E+00,2.839328E-03,1.542708E+00,& + & 2.544020E-03,1.324608E+00,2.215876E-03,1.106555E+00,1.862629E-03,& + & 8.885468E-01,1.485121E-03,6.705480E-01,1.080058E-03,4.526012E-01,& + & 6.354311E-04,2.347030E-01,1.024080E-04,1.692459E-02,3.140521E-03,& + & 1.759575E+00,2.950574E-03,1.541473E+00,2.640522E-03,1.323532E+00,& + & 2.298080E-03,1.105640E+00,1.930429E-03,8.877960E-01,1.538056E-03,& + & 6.699591E-01,1.117267E-03,4.521718E-01,6.561562E-04,2.344323E-01,& + & 1.067606E-04,1.682152E-02,3.261040E-03,1.757263E+00,3.061994E-03,& + & 1.539452E+00,2.740281E-03,1.321785E+00,2.382651E-03,1.104176E+00,& + & 2.000698E-03,8.865844E-01,1.592790E-03,6.690432E-01,1.154669E-03,& + & 4.515378E-01,6.775183E-04,2.340734E-01,1.112603E-04,1.674009E-02/ + + data absb(:, 1:120) / & + & 7.138436E-03,4.154584E+00,7.449146E-03,4.156656E+00,7.746384E-03,& + & 4.155860E+00,8.043989E-03,4.152614E+00,8.349585E-03,4.147179E+00,& + & 6.434845E-03,4.156263E+00,6.718474E-03,4.157991E+00,6.997157E-03,& + & 4.157056E+00,7.280710E-03,4.153486E+00,7.560912E-03,4.147914E+00,& + & 5.753392E-03,4.157659E+00,6.013131E-03,4.159207E+00,6.275056E-03,& + & 4.157947E+00,6.534586E-03,4.154284E+00,6.789649E-03,4.148491E+00,& + & 5.071855E-03,4.159069E+00,5.300920E-03,4.160306E+00,5.526719E-03,& + & 4.158847E+00,5.764089E-03,4.154944E+00,5.998554E-03,4.149145E+00,& + & 4.478300E-03,4.160359E+00,4.678093E-03,4.161371E+00,4.883221E-03,& + & 4.159575E+00,5.086676E-03,4.155494E+00,5.293133E-03,4.149425E+00,& + & 3.959371E-03,4.161464E+00,4.137081E-03,4.162137E+00,4.326269E-03,& + & 4.160278E+00,4.511218E-03,4.155977E+00,4.693880E-03,4.149741E+00,& + & 3.524154E-03,4.162431E+00,3.685847E-03,4.162842E+00,3.860716E-03,& + & 4.160670E+00,4.030713E-03,4.156148E+00,4.190626E-03,4.149871E+00,& + & 3.068552E-03,4.163436E+00,3.220365E-03,4.163503E+00,3.366676E-03,& + & 4.161154E+00,3.510181E-03,4.156383E+00,3.649085E-03,4.149849E+00,& + & 2.653320E-03,4.164306E+00,2.785346E-03,4.164103E+00,2.915145E-03,& + & 4.161437E+00,3.038844E-03,4.156532E+00,3.152178E-03,4.149800E+00,& + & 2.293160E-03,4.165082E+00,2.405446E-03,4.164481E+00,2.516374E-03,& + & 4.161379E+00,2.619398E-03,4.156162E+00,2.712575E-03,4.149204E+00,& + & 1.980916E-03,4.165787E+00,2.077310E-03,4.164704E+00,2.173317E-03,& + & 4.161138E+00,2.257760E-03,4.155523E+00,2.333968E-03,4.148252E+00,& + & 1.713419E-03,4.166293E+00,1.797998E-03,4.164680E+00,1.877076E-03,& + & 4.160598E+00,1.948257E-03,4.154735E+00,2.009810E-03,4.147268E+00,& + & 1.479632E-03,4.166658E+00,1.550734E-03,4.164412E+00,1.618900E-03,& + & 4.160025E+00,1.676999E-03,4.153784E+00,1.730557E-03,4.145981E+00,& + & 1.274715E-03,4.166827E+00,1.334514E-03,4.163924E+00,1.391153E-03,& + & 4.159122E+00,1.439530E-03,4.152479E+00,1.482912E-03,4.144370E+00,& + & 1.092438E-03,4.166745E+00,1.143233E-03,4.163364E+00,1.190312E-03,& + & 4.158045E+00,1.229393E-03,4.151253E+00,1.266159E-03,4.142764E+00,& + & 9.334404E-04,4.166314E+00,9.766403E-04,4.162582E+00,1.014676E-03,& + & 4.156822E+00,1.046679E-03,4.149506E+00,1.078041E-03,4.140900E+00,& + & 7.933266E-04,4.165957E+00,8.286233E-04,4.161665E+00,8.574718E-04,& + & 4.155483E+00,8.851092E-04,4.147727E+00,9.117666E-04,4.138931E+00,& + & 6.729631E-04,4.165248E+00,6.996480E-04,4.160463E+00,7.238737E-04,& + & 4.153829E+00,7.468581E-04,4.145860E+00,7.949880E-04,4.140235E+00,& + & 5.683982E-04,4.164441E+00,5.886161E-04,4.159164E+00,6.086372E-04,& + & 4.152109E+00,6.285037E-04,4.143850E+00,6.706313E-04,4.137954E+00,& + & 4.789737E-04,4.163387E+00,4.957743E-04,4.157603E+00,5.131500E-04,& + & 4.150202E+00,5.295185E-04,4.141697E+00,5.657290E-04,4.135463E+00,& + & 4.035401E-04,4.162270E+00,4.183278E-04,4.155992E+00,4.330317E-04,& + & 4.148344E+00,4.467448E-04,4.139431E+00,4.795870E-04,4.132853E+00,& + & 3.426910E-04,4.160962E+00,3.551412E-04,4.154567E+00,3.671552E-04,& + & 4.146543E+00,3.953518E-04,4.140851E+00,4.099777E-04,4.130714E+00,& + & 2.911028E-04,4.160404E+00,3.010264E-04,4.153615E+00,3.128607E-04,& + & 4.145389E+00,3.380025E-04,4.139623E+00,3.501847E-04,4.129409E+00,& + & 2.469655E-04,4.160368E+00,2.559690E-04,4.153552E+00,2.662523E-04,& + & 4.145281E+00,2.890048E-04,4.139506E+00,2.999935E-04,4.129308E+00/ + data absb(:,121:235) / & + & 2.048427E-04,4.161176E+00,2.130575E-04,4.154575E+00,2.221824E-04,& + & 4.146445E+00,2.417737E-04,4.140867E+00,2.514425E-04,4.130747E+00,& + & 1.698505E-04,4.161981E+00,1.770539E-04,4.155686E+00,1.846890E-04,& + & 4.147842E+00,2.015762E-04,4.142254E+00,2.101892E-04,4.132278E+00,& + & 1.405219E-04,4.162839E+00,1.470841E-04,4.156651E+00,1.533567E-04,& + & 4.149047E+00,1.601530E-04,4.140205E+00,1.755492E-04,4.133738E+00,& + & 1.148967E-04,4.164162E+00,1.204758E-04,4.158325E+00,1.256810E-04,& + & 4.150900E+00,1.314347E-04,4.142448E+00,1.446197E-04,4.136216E+00,& + & 9.365340E-05,4.165340E+00,9.819553E-05,4.160068E+00,1.026339E-04,& + & 4.153064E+00,1.075379E-04,4.144783E+00,1.186437E-04,4.138858E+00,& + & 7.619108E-05,4.166477E+00,7.990727E-05,4.161579E+00,8.367077E-05,& + & 4.155105E+00,8.778287E-05,4.146961E+00,9.726094E-05,4.141392E+00,& + & 6.143247E-05,4.167380E+00,6.440588E-05,4.163364E+00,6.752373E-05,& + & 4.157326E+00,7.109001E-05,4.149698E+00,7.480007E-05,4.140902E+00,& + & 4.920171E-05,4.168397E+00,5.163899E-05,4.164963E+00,5.424612E-05,& + & 4.159571E+00,5.718820E-05,4.152357E+00,6.031499E-05,4.143967E+00,& + & 3.925276E-05,4.169042E+00,4.126278E-05,4.166370E+00,4.344038E-05,& + & 4.161558E+00,4.584738E-05,4.154939E+00,4.849326E-05,4.147015E+00,& + & 3.122973E-05,4.169442E+00,3.287755E-05,4.167606E+00,3.466434E-05,& + & 4.163597E+00,3.663950E-05,4.157517E+00,3.892644E-05,4.150015E+00,& + & 2.477047E-05,4.169433E+00,2.616274E-05,4.168665E+00,2.764818E-05,& + & 4.165387E+00,2.930297E-05,4.160199E+00,3.120334E-05,4.153190E+00,& + & 1.958056E-05,4.168964E+00,2.073303E-05,4.169392E+00,2.198818E-05,& + & 4.166961E+00,2.330065E-05,4.162554E+00,2.490606E-05,4.156138E+00,& + & 1.538064E-05,4.168061E+00,1.632908E-05,4.169402E+00,1.737536E-05,& + & 4.168187E+00,1.845850E-05,4.164487E+00,1.977280E-05,4.158923E+00,& + & 1.218764E-05,4.166780E+00,1.297147E-05,4.169126E+00,1.383024E-05,& + & 4.168954E+00,1.475097E-05,4.166205E+00,1.583460E-05,4.161202E+00,& + & 9.684113E-06,4.165129E+00,1.031273E-05,4.168658E+00,1.101901E-05,& + & 4.169348E+00,1.180804E-05,4.167476E+00,1.267313E-05,4.163296E+00,& + & 7.655369E-06,4.163195E+00,8.182161E-06,4.167784E+00,8.755822E-06,& + & 4.169478E+00,9.404058E-06,4.168504E+00,1.011196E-05,4.165118E+00,& + & 6.022680E-06,4.160746E+00,6.457494E-06,4.166343E+00,6.941993E-06,& + & 4.169221E+00,7.463392E-06,4.169205E+00,8.048010E-06,4.166619E+00,& + & 4.813075E-06,4.158175E+00,5.176633E-06,4.164770E+00,5.570152E-06,& + & 4.168607E+00,5.998114E-06,4.169568E+00,6.486912E-06,4.167706E+00,& + & 3.875641E-06,4.155246E+00,4.172412E-06,4.163035E+00,4.503391E-06,& + & 4.167615E+00,4.850369E-06,4.169423E+00,5.261367E-06,4.168594E+00,& + & 3.109226E-06,4.152443E+00,3.356489E-06,4.160853E+00,3.632195E-06,& + & 4.166504E+00,3.922811E-06,4.169239E+00,4.257629E-06,4.169081E+00,& + & 2.484414E-06,4.149259E+00,2.698356E-06,4.158364E+00,2.926114E-06,& + & 4.165078E+00,3.167517E-06,4.168621E+00,3.440365E-06,4.169443E+00,& + & 1.986710E-06,4.146019E+00,2.175630E-06,4.155949E+00,2.362437E-06,& + & 4.163336E+00,2.562394E-06,4.167863E+00,2.785356E-06,4.169560E+00,& + & 1.660522E-06,4.144838E+00,1.824662E-06,4.154784E+00,1.986789E-06,& + & 4.162636E+00,2.153293E-06,4.167493E+00,2.349694E-06,4.169450E+00/ + + + data selfref(:, :) / & + & 2.338209E-03,5.039018E-03,1.942789E-03,4.660123E-03,1.619094E-03,& + & 4.309895E-03,1.353323E-03,3.986148E-03,1.134457E-03,3.686872E-03,& + & 9.536756E-04,3.410199E-03,8.039022E-04,3.154424E-03,6.794502E-04,& + & 2.917946E-03,5.757334E-04,2.699306E-03,4.890464E-04,2.497155E-03/ + + + data forref(:, :) / & + & 4.193838E-05,2.979746E-04,6.150636E-05,2.714236E-04,1.086590E-04,& + & 2.074412E-04,1.244444E-04,1.860204E-04 / + + + data fracrefa(:,:) / 6.722400e-01,3.277719e-01,7.402200e-01,& + & 2.597805e-01,7.553300e-01,2.446753e-01,7.643700e-01,2.356218e-01,& + & 7.710900e-01,2.289038e-01,7.758100e-01,2.241963e-01,7.805700e-01,& + & 2.194258e-01,7.852900e-01,2.147208e-01,7.796600e-01,2.203414e-01/ + + + data fracrefb(:) / 6.882100e-01,3.117782e-01 / + +!........................................! + end module module_radlw_kgb16 ! +!========================================! +!! @} diff --git a/gsmphys/radlw_main.f b/gsmphys/radlw_main.f new file mode 100644 index 00000000..69ac69f8 --- /dev/null +++ b/gsmphys/radlw_main.f @@ -0,0 +1,6675 @@ +!> \file radlw_main.f +!! This file contains NCEP's modifications of the rrtmg-lw radiation +!! code from AER. + +!!!!! ============================================================== !!!!! +!!!!! lw-rrtm3 radiation package description !!!!! +!!!!! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-lw radiation ! +! code from aer inc. ! +! ! +! the lw-rrtm3 package includes these parts: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! the 'radlw_rrtm3_param.f' contains: ! +! ! +! 'module_radlw_parameters' -- band parameters set up ! +! ! +! the 'radlw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radlw_avplank' -- plank flux data ! +! 'module_radlw_ref' -- reference temperature and pressure ! +! 'module_radlw_cldprlw' -- cloud property coefficients ! +! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! +! bands, where nn = 01-16 ! +! ! +! the 'radlw_rrtm3_main.f' contains: ! +! ! +! 'module_radlw_main' -- main lw radiation transfer ! +! ! +! in the main module 'module_radlw_main' there are only two ! +! externally callable subroutines: ! +! ! +! ! +! 'lwrad' -- main lw radiation routine ! +! inputs: ! +! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! +! clouds,icseed,aerosols,sfemis,sfgtmp, ! +! npts, nlay, nlp1, lprnt, ! +! outputs: ! +! hlwc,topflx,sfcflx, ! +!! optional outputs: ! +! HLW0,HLWB,FLXPRF) ! +! ! +! 'rlwinit' -- initialization routine ! +! inputs: ! +! ( me ) ! +! outputs: ! +! (none) ! +! ! +! all the lw radiation subprograms become contained subprograms ! +! in module 'module_radlw_main' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! derived data type constructs used: ! +! ! +! 1. radiation flux at toa: (from module 'module_radlw_parameters') ! +! topflw_type - derived data type for toa rad fluxes ! +! upfxc total sky upward flux at toa ! +! upfx0 clear sky upward flux at toa ! +! ! +! 2. radiation flux at sfc: (from module 'module_radlw_parameters') ! +! sfcflw_type - derived data type for sfc rad fluxes ! +! upfxc total sky upward flux at sfc ! +! upfx0 clear sky upward flux at sfc ! +! dnfxc total sky downward flux at sfc ! +! dnfx0 clear sky downward flux at sfc ! +! ! +! 3. radiation flux profiles(from module 'module_radlw_parameters') ! +! proflw_type - derived data type for rad vertical prof ! +! upfxc level upward flux for total sky ! +! dnfxc level downward flux for total sky ! +! upfx0 level upward flux for clear sky ! +! dnfx0 level downward flux for clear sky ! +! ! +! external modules referenced: ! +! ! +! 'module physparam' ! +! 'module physcons' ! +! 'mersenne_twister' ! +! ! +! compilation sequence is: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use lw modules ! +! ! +!==========================================================================! +! ! +! the original aer's program declarations: ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! | +! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). | +! This software may be used, copied, or redistributed as long as it is | +! not sold and this copyright notice is reproduced on each copy made. | +! This model is provided as is without any express or implied warranties. | +! (http://www.rtweb.aer.com/) | +! | +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! ************************************************************************ ! +! ! +! rrtmg_lw ! +! ! +! ! +! a rapid radiative transfer model ! +! for the longwave region ! +! for application to general circulation models ! +! ! +! ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! eli j. mlawer ! +! jennifer s. delamere ! +! michael j. iacono ! +! shepard a. clough ! +! ! +! ! +! email: miacono@aer.com ! +! email: emlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: steven j. taubman, karen cady-pereira, ! +! patrick d. brown, ronald e. farren, luke chen, robert bergstrom. ! +! ! +! ************************************************************************ ! +! ! +! references: ! +! (rrtm_lw/rrtmg_lw): ! +! clough, s.A., m.w. shephard, e.j. mlawer, j.s. delamere, ! +! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! +! atmospheric radiative transfer modeling: a summary of the aer ! +! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! +! ! +! mlawer, e.j., s.j. taubman, p.d. brown, m.j. iacono, and s.a. ! +! clough: radiative transfer for inhomogeneous atmospheres: rrtm, ! +! a validated correlated-k model for the longwave. j. geophys. res., ! +! 102, 16663-16682, 1997. ! +! ! +! (mcica): ! +! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, ! +! approximation technique for computing radiative transfer in ! +! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, ! +! doi:10.1029/2002JD003322, 2003. ! +! ! +! ************************************************************************ ! +! ! +! aer's revision history: ! +! this version of rrtmg_lw has been modified from rrtm_lw to use a ! +! reduced set of g-points for application to gcms. ! +! ! +! -- original version (derived from rrtm_lw), reduction of g-points, ! +! other revisions for use with gcms. ! +! 1999: m. j. iacono, aer, inc. ! +! -- adapted for use with ncar/cam3. ! +! may 2004: m. j. iacono, aer, inc. ! +! -- revised to add mcica capability. ! +! nov 2005: m. j. iacono, aer, inc. ! +! -- conversion to f90 formatting for consistency with rrtmg_sw. ! +! feb 2007: m. j. iacono, aer, inc. ! +! -- modifications to formatting to use assumed-shape arrays. ! +! aug 2007: m. j. iacono, aer, inc. ! +! ! +! ************************************************************************ ! +! ! +! ncep modifications history log: ! +! ! +! nov 1999, ken campana -- received the original code from ! +! aer (1998 ncar ccm version), updated to link up with ! +! ncep mrf model ! +! jun 2000, ken campana -- added option to switch random and ! +! maximum/random cloud overlap ! +! 2001, shrinivas moorthi -- further updates for mrf model ! +! may 2001, yu-tai hou -- updated on trace gases and cloud ! +! property based on rrtm_v3.0 codes. ! +! dec 2001, yu-tai hou -- rewritten code into fortran 90 std ! +! set ncep radiation structure standard that contains ! +! three plug-in compatable fortran program files: ! +! 'radlw_param.f', 'radlw_datatb.f', 'radlw_main.f' ! +! fixed bugs in subprograms taugb14, taugb2, etc. added ! +! out-of-bounds protections. (a detailed note of ! +! up_to_date modifications/corrections by ncep was sent ! +! to aer in 2002) ! +! jun 2004, yu-tai hou -- added mike iacono's apr 2004 ! +! modification of variable diffusivity angles. ! +! apr 2005, yu-tai hou -- minor modifications on module ! +! structures include rain/snow effect (this version of ! +! code was given back to aer in jun 2006) ! +! mar 2007, yu-tai hou -- added aerosol effect for ncep ! +! models using the generallized aerosol optical property! +! scheme for gfs model. ! +! apr 2007, yu-tai hou -- added spectral band heating as an ! +! optional output to support the 500 km gfs model's ! +! upper stratospheric radiation calculations. and ! +! restructure optional outputs for easy access by ! +! different models. ! +! oct 2008, yu-tai hou -- modified to include new features ! +! from aer's newer release v4.4-v4.7, including the ! +! mcica sub-grid cloud option. add rain/snow optical ! +! properties support to cloudy sky calculations. ! +! correct errors in mcica cloud optical properties for ! +! ebert & curry scheme (ilwcice=1) that needs band ! +! index conversion. simplified and unified sw and lw ! +! sub-column cloud subroutines into one module by using ! +! optional parameters. ! +! mar 2009, yu-tai hou -- replaced the original random number! +! generator coming from the original code with ncep w3 ! +! library to simplify the program and moved sub-column ! +! cloud subroutines inside the main module. added ! +! option of user provided permutation seeds that could ! +! be randomly generated from forecast time stamp. ! +! oct 2009, yu-tai hou -- modified subrtines "cldprop" and ! +! "rlwinit" according updats from aer's rrtmg_lw v4.8. ! +! nov 2009, yu-tai hou -- modified subrtine "taumol" according +! updats from aer's rrtmg_lw version 4.82. notice the ! +! cloud ice/liquid are assumed as in-cloud quantities, ! +! not as grid averaged quantities. ! +! jun 2010, yu-tai hou -- optimized code to improve efficiency +! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! +! cloud-snow optical property scheme. ! +! nov 2012, yu-tai hou -- modified control parameters thru ! +! module 'physparam'. ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + + +!> \defgroup module_radlw_main module_radlw_main +!! \ingroup rad +!! This module includes NCEP's modifications of the rrtmg-lw radiation +!! code from AER. +!! +!! The RRTM-LW package includes three files: +!! - radlw_param.f, which contains: +!! - module_radlw_parameters: band parameters set up +!! - radlw_datatb.f, which contains modules: +!! - module_radlw_avplank: plank flux data +!! - module_radlw_ref: reference temperature and pressure +!! - module_radlw_cldprlw: cloud property coefficients +!! - module_radlw_kgbnn: absorption coeffients for 16 bands, where nn = 01-16 +!! - radlw_main.f, which contains: +!! - module_radlw_main, which is the main LW radiation transfer +!! program and contains two externally callable subroutines: +!! - lwrad(): the main LW radiation routine +!! - rlwinit(): the initialization routine +!! +!! All the LW radiation subprograms become contained subprograms in +!! module 'module_radlw_main' and many of them are not directly +!! accessable from places outside the module. +!! +!!\author Eli J. Mlawer, emlawer@aer.com +!!\author Jennifer S. Delamere, jdelamer@aer.com +!!\author Michael J. Iacono, miacono@aer.com +!!\author Shepard A. Clough +!!\version NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 +!! +!! The authors wish to acknowledge the contributions of the +!! following people: Steven J. Taubman, Karen Cady-Pereira, +!! Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. +!! +!!\copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). +!! This software may be used, copied, or redistributed as long as it is +!! not sold and this copyright notice is reproduced on each copy made. +!! This model is provided as is without any express or implied warranties. +!! (http://www.rtweb.aer.com/) +!! @{ +!========================================! + module module_radlw_main ! +!........................................! +! + use physparam, only : ilwrate, ilwrgas, ilwcliq, ilwcice, & + & isubclw, icldflg, iovrlw, ivflip, & + & kind_phys + use physcons, only : con_g, con_cp, con_avgd, con_amd, & + & con_amw, con_amo3 + use mersenne_twister, only : random_setseed, random_number, & + & random_stat + + use module_radlw_parameters +! + use module_radlw_avplank, only : totplnk + use module_radlw_ref, only : preflog, tref, chi_mls +! + implicit none +! + private +! +! ... version tag and last revision date + character(40), parameter :: & + & VTAGLW='NCEP LW v5.1 Nov 2012 -RRTMG-LW v4.82 ' +! & VTAGLW='NCEP LW v5.0 Aug 2012 -RRTMG-LW v4.82 ' +! & VTAGLW='RRTMG-LW v4.82 Nov 2009 ' +! & VTAGLW='RRTMG-LW v4.8 Oct 2009 ' +! & VTAGLW='RRTMG-LW v4.71 Mar 2009 ' +! & VTAGLW='RRTMG-LW v4.4 Oct 2008 ' +! & VTAGLW='RRTM-LW v2.3g Mar 2007 ' +! & VTAGLW='RRTM-LW v2.3g Apr 2004 ' + +! --- constant values + real (kind=kind_phys), parameter :: eps = 1.0e-6 + real (kind=kind_phys), parameter :: oneminus= 1.0-eps + real (kind=kind_phys), parameter :: cldmin = 1.0e-80 + real (kind=kind_phys), parameter :: bpade = 1.0/0.278 ! pade approx constant + real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 + real (kind=kind_phys), parameter :: wtdiff = 0.5 ! weight for radiance to flux conversion + real (kind=kind_phys), parameter :: tblint = ntbl ! lookup table conversion factor + real (kind=kind_phys), parameter :: f_zero = 0.0 + real (kind=kind_phys), parameter :: f_one = 1.0 + +! ... atomic weights for conversion from mass to volume mixing ratios + real (kind=kind_phys), parameter :: amdw = con_amd/con_amw + real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 + +! ... band indices + integer, dimension(nbands) :: nspa, nspb + + data nspa / 1, 1, 9, 9, 9, 1, 9, 1, 9, 1, 1, 9, 9, 1, 9, 9 / + data nspb / 1, 1, 5, 5, 5, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 0 / + +! ... band wavenumber intervals +! real (kind=kind_phys) :: wavenum1(nbands), wavenum2(nbands) +! data wavenum1/ & +! & 10., 350., 500., 630., 700., 820., 980., 1080., & +!err & 1180., 1390., 1480., 1800., 2080., 2250., 2390., 2600. / +! & 1180., 1390., 1480., 1800., 2080., 2250., 2380., 2600. / +! data wavenum2/ & +! & 350., 500., 630., 700., 820., 980., 1080., 1180., & +!err & 1390., 1480., 1800., 2080., 2250., 2390., 2600., 3250. / +! & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3250. / +! real (kind=kind_phys) :: delwave(nbands) +! data delwave / 340., 150., 130., 70., 120., 160., 100., 100., & +! & 210., 90., 320., 280., 170., 130., 220., 650. / + +! --- reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 +! and 1.80) as a function of total column water vapor. the function +! has been defined to minimize flux and cooling rate errors in these bands +! over a wide range of precipitable water values. + real (kind=kind_phys), dimension(nbands) :: a0, a1, a2 + + data a0 / 1.66, 1.55, 1.58, 1.66, 1.54, 1.454, 1.89, 1.33, & + & 1.668, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66, 1.66 / + data a1 / 0.00, 0.25, 0.22, 0.00, 0.13, 0.446, -0.10, 0.40, & + & -0.006, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + data a2 / 0.00, -12.0, -11.7, 0.00, -0.72,-0.243, 0.19,-0.062, & + & 0.414, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00 / + +!! --- logical flags for optional output fields + + logical :: lhlwb = .false. + logical :: lhlw0 = .false. + logical :: lflxprf= .false. + +! --- those data will be set up only once by "rlwinit" + +! ... fluxfac, heatfac are factors for fluxes (in w/m**2) and heating +! rates (in k/day, or k/sec set by subroutine 'rlwinit') +! semiss0 are default surface emissivity for each bands + + real (kind=kind_phys) :: fluxfac, heatfac, semiss0(nbands) + data semiss0(:) / nbands*1.0 / + + real (kind=kind_phys) :: tau_tbl(0:ntbl) !clr-sky opt dep (for cldy transfer) + real (kind=kind_phys) :: exp_tbl(0:ntbl) !transmittance lookup table + real (kind=kind_phys) :: tfn_tbl(0:ntbl) !tau transition function; i.e. the + !transition of planck func from mean lyr + !temp to lyr boundary temp as a func of + !opt dep. "linear in tau" method is used. + +! --- the following variables are used for sub-column cloud scheme + + integer, parameter :: ipsdlw0 = ngptlw ! initial permutation seed + +! --- public accessable subprograms + + public lwrad, rlwinit + + +! ================ + contains +! ================ + +!> This subroutine is the main LW radiation routine. +!!\param plyr model layer mean pressure in mb +!!\param plvl model interface pressure in mb +!!\param tlyr model layer mean temperature in K +!!\param tlvl model interface temperature in K +!!\param qlyr layer specific humidity in gm/gm +!!\param olyr layer ozone concentration in gm/gm +!!\param gasvmr atmospheric gases amount: +!!\n (:,:,1) - co2 volume mixing ratio +!!\n (:,:,2) - n2o volume mixing ratio +!!\n (:,:,3) - ch4 volume mixing ratio +!!\n (:,:,4) - o2 volume mixing ratio +!!\n (:,:,5) - co volume mixing ratio +!!\n (:,:,6) - cfc11 volume mixing ratio +!!\n (:,:,7) - cfc12 volume mixing ratio +!!\n (:,:,8) - cfc22 volume mixing ratio +!!\n (:,:,9) - ccl4 volume mixing ratio +!!\param clouds layer cloud profile +!!\n for ilwcliq > 0 --- +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer in-cloud liq water path (\f$ g/m^2 \f$) +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer in-cloud ice water path (\f$ g/m^2 \f$) +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path (\f$ g/m^2 \f$) +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path (\f$ g/m^2 \f$) +!!\n (:,:,9) - mean eff radius for snow flake(micron) +!!\n for ilwcliq = 0 --- +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer cloud optical depth +!!\n (:,:,3) - layer cloud single scattering albedo +!!\n (:,:,4) - layer cloud asymmetry factor +!!\param icseed auxiliary special cloud related array. +!!\param aerosols aerosol optical properties +!!\n (:,:,:,1) - optical depth +!!\n (:,:,:,2) - single scattering albedo +!!\n (:,:,:,3) - asymmetry parameter +!!\param sfemis surface emissivity +!!\param sfgtmp surface ground temperature in K +!!\param npts total number of horizontal points +!!\param nlay, nlp1 total number of vertical layers, levels +!!\param lprnt cntl flag for diagnostic print out +!!\param hlwc total sky heating rate in k/day or k/sec +!!\param topflx radiation fluxes at top, components +!!\n upfxc - total sky upward flux at top (\f$ w/m^2 \f$) +!!\n upfx0 - clear sky upward flux at top (\f$ w/m^2 \f$) +!!\param sfcflx radiation fluxes at sfc, components +!!\n upfxc - total sky upward flux at sfc (\f$ w/m^2 \f$) +!!\n dnfxc - total sky downward flux at sfc (\f$ w/m^2 \f$) +!!\n upfx0 - clear sky upward flux at sfc (\f$ w/m^2 \f$) +!!\n dnfx0 - clear sky downward flux at sfc (\f$ w/m^2 \f$) +!!\param hlwb spectral band total sky heating rates +!!\param hlw0 clear sky heating rates (k/sec or k/day) +!!\param flxprf level radiation fluxes (\f$ w/m^2 \f$), components +!!\n dnfxc - total sky downward flux +!!\n upfxc - total sky upward flux +!!\n dnfx0 - clear sky downward flux +!!\n upfx0 - clear sky upward flux +!> \section gen_lwrad General Algorithm +!> @{ +! -------------------------------- + subroutine lwrad & + & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & ! --- inputs + & clouds,icseed,aerosols,sfemis,sfgtmp, & + & npts, nlay, nlp1, lprnt, & + & hlwc,topflx,sfcflx, & ! --- outputs + & HLW0,HLWB,FLXPRF & !! --- optional + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! plyr (npts,nlay) : layer mean pressures (mb) ! +! plvl (npts,nlp1) : interface pressures (mb) ! +! tlyr (npts,nlay) : layer mean temperature (k) ! +! tlvl (npts,nlp1) : interface temperatures (k) ! +! qlyr (npts,nlay) : layer specific humidity (gm/gm) *see inside ! +! olyr (npts,nlay) : layer ozone concentration (gm/gm) *see inside ! +! gasvmr(npts,nlay,:): atmospheric gases amount: ! +! (check module_radiation_gases for definition) ! +! gasvmr(:,:,1) - co2 volume mixing ratio ! +! gasvmr(:,:,2) - n2o volume mixing ratio ! +! gasvmr(:,:,3) - ch4 volume mixing ratio ! +! gasvmr(:,:,4) - o2 volume mixing ratio ! +! gasvmr(:,:,5) - co volume mixing ratio ! +! gasvmr(:,:,6) - cfc11 volume mixing ratio ! +! gasvmr(:,:,7) - cfc12 volume mixing ratio ! +! gasvmr(:,:,8) - cfc22 volume mixing ratio ! +! gasvmr(:,:,9) - ccl4 volume mixing ratio ! +! clouds(npts,nlay,:): layer cloud profiles: ! +! (check module_radiation_clouds for definition) ! +! --- for ilwcliq > 0 --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path (g/m**2) ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! clouds(:,:,8) - layer snow flake water path (g/m**2) ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! --- for ilwcliq = 0 --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud optical depth ! +! clouds(:,:,3) - layer cloud single scattering albedo ! +! clouds(:,:,4) - layer cloud asymmetry factor ! +! icseed(npts) : auxiliary special cloud related array ! +! when module variable isubclw=2, it provides ! +! permutation seed for each column profile that ! +! are used for generating random numbers. ! +! when isubclw /=2, it will not be used. ! +! aerosols(npts,nlay,nbands,:) : aerosol optical properties ! +! (check module_radiation_aerosols for definition)! +! (:,:,:,1) - optical depth ! +! (:,:,:,2) - single scattering albedo ! +! (:,:,:,3) - asymmetry parameter ! +! sfemis (npts) : surface emissivity ! +! sfgtmp (npts) : surface ground temperature (k) ! +! npts : total number of horizontal points ! +! nlay, nlp1 : total number of vertical layers, levels ! +! lprnt : cntl flag for diagnostic print out ! +! ! +! output variables: ! +! hlwc (npts,nlay): total sky heating rate (k/day or k/sec) ! +! topflx(npts) : radiation fluxes at top, component: ! +! (check module_radlw_paramters for definition) ! +! upfxc - total sky upward flux at top (w/m2) ! +! upfx0 - clear sky upward flux at top (w/m2) ! +! sfcflx(npts) : radiation fluxes at sfc, component: ! +! (check module_radlw_paramters for definition) ! +! upfxc - total sky upward flux at sfc (w/m2) ! +! upfx0 - clear sky upward flux at sfc (w/m2) ! +! dnfxc - total sky downward flux at sfc (w/m2) ! +! dnfx0 - clear sky downward flux at sfc (w/m2) ! +! ! +!! optional output variables: ! +! hlwb(npts,nlay,nbands): spectral band total sky heating rates ! +! hlw0 (npts,nlay): clear sky heating rate (k/day or k/sec) ! +! flxprf(npts,nlp1): level radiative fluxes (w/m2), components: ! +! (check module_radlw_paramters for definition) ! +! upfxc - total sky upward flux ! +! dnfxc - total sky dnward flux ! +! upfx0 - clear sky upward flux ! +! dnfx0 - clear sky dnward flux ! +! ! +! external module variables: (in physparam) ! +! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! ilwcliq - control flag for liq-cloud optical properties ! +! =0: input cloud optical depth, ignor ilwcice ! +! =1: input cld liqp & reliq, hu & stamnes (1993) ! +! =2: not used ! +! ilwcice - control flag for ice-cloud optical properties ! +! *** if ilwcliq==0, ilwcice is ignored ! +! =1: input cld icep & reice, ebert & curry (1997) ! +! =2: input cld icep & reice, streamer (1996) ! +! =3: input cld icep & reice, fu (1998) ! +! isubclw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovrlw - cloud overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud (used for isubclw>0 only) ! +! ivflip - control flag for vertical index direction ! +! =0: vertical index from toa to surface ! +! =1: vertical index from surface to toa ! +! ! +! module parameters, control variables: ! +! nbands - number of longwave spectral bands ! +! maxgas - maximum number of absorbing gaseous ! +! maxxsec - maximum number of cross-sections ! +! ngptlw - total number of g-point subintervals ! +! ng## - number of g-points in band (##=1-16) ! +! ngb(ngptlw) - band indices for each g-point ! +! bpade - pade approximation constant (1/0.278) ! +! nspa,nspb(nbands)- number of lower/upper ref atm's per band ! +! delwave(nbands) - longwave band width (wavenumbers) ! +! ipsdlw0 - permutation seed for mcica sub-col clds ! +! ! +! major local variables: ! +! pavel (nlay) - layer pressures (mb) ! +! delp (nlay) - layer pressure thickness (mb) ! +! tavel (nlay) - layer temperatures (k) ! +! tz (0:nlay) - level (interface) temperatures (k) ! +! semiss (nbands) - surface emissivity for each band ! +! wx (nlay,maxxsec) - cross-section molecules concentration ! +! coldry (nlay) - dry air column amount ! +! (1.e-20*molecules/cm**2) ! +! cldfrc (0:nlp1) - layer cloud fraction ! +! taucld (nbands,nlay) - layer cloud optical depth for each band ! +! cldfmc (ngptlw,nlay) - layer cloud fraction for each g-point ! +! tauaer (nbands,nlay) - aerosol optical depths ! +! fracs (ngptlw,nlay) - planck fractions ! +! tautot (ngptlw,nlay) - total optical depths (gaseous+aerosols) ! +! colamt (nlay,maxgas) - column amounts of absorbing gases ! +! 1-maxgas are for watervapor, carbon ! +! dioxide, ozone, nitrous oxide, methane, ! +! oxigen, carbon monoxide, respectively ! +! (molecules/cm**2) ! +! pwvcm - column precipitable water vapor (cm) ! +! secdiff(nbands) - variable diffusivity angle defined as ! +! an exponential function of the column ! +! water amount in bands 2-3 and 5-9. ! +! this reduces the bias of several w/m2 in ! +! downward surface flux in high water ! +! profiles caused by using the constant ! +! diffusivity angle of 1.66. (mji) ! +! facij (nlay) - indicator of interpolation factors ! +! =0/1: indicate lower/higher temp & height ! +! selffac(nlay) - scale factor for self-continuum, equals ! +! (w.v. density)/(atm density at 296K,1013 mb) ! +! selffrac(nlay) - factor for temp interpolation of ref ! +! self-continuum data ! +! indself(nlay) - index of the lower two appropriate ref ! +! temp for the self-continuum interpolation ! +! forfac (nlay) - scale factor for w.v. foreign-continuum ! +! forfrac(nlay) - factor for temp interpolation of ref ! +! w.v. foreign-continuum data ! +! indfor (nlay) - index of the lower two appropriate ref ! +! temp for the foreign-continuum interp ! +! laytrop - tropopause layer index at which switch is ! +! made from one conbination kew species to ! +! another. ! +! jp(nlay),jt(nlay),jt1(nlay) ! +! - lookup table indexes ! +! totuflux(0:nlay) - total-sky upward longwave flux (w/m2) ! +! totdflux(0:nlay) - total-sky downward longwave flux (w/m2) ! +! htr(nlay) - total-sky heating rate (k/day or k/sec) ! +! totuclfl(0:nlay) - clear-sky upward longwave flux (w/m2) ! +! totdclfl(0:nlay) - clear-sky downward longwave flux (w/m2) ! +! htrcl(nlay) - clear-sky heating rate (k/day or k/sec) ! +! fnet (0:nlay) - net longwave flux (w/m2) ! +! fnetc (0:nlay) - clear-sky net longwave flux (w/m2) ! +! ! +! ! +! ====================== end of definitions =================== ! + +! --- inputs: + integer, intent(in) :: npts, nlay, nlp1 + integer, intent(in) :: icseed(npts) + + logical, intent(in) :: lprnt + + real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: plvl, & + & tlvl + real (kind=kind_phys), dimension(npts,nlay), intent(in) :: plyr, & + & tlyr, qlyr, olyr + + real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: gasvmr + real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: clouds + + real (kind=kind_phys), dimension(npts), intent(in) :: sfemis, & + & sfgtmp + + real (kind=kind_phys), dimension(npts,nlay,nbands,3),intent(in):: & + & aerosols + +! --- outputs: + real (kind=kind_phys), dimension(npts,nlay), intent(out) :: hlwc + + type (topflw_type), dimension(npts), intent(out) :: topflx + type (sfcflw_type), dimension(npts), intent(out) :: sfcflx + +!! --- optional outputs: + real (kind=kind_phys), dimension(npts,nlay,nbands),optional, & + & intent(out) :: hlwb + real (kind=kind_phys), dimension(npts,nlay), optional, & + & intent(out) :: hlw0 + type (proflw_type), dimension(npts,nlp1), optional, & + & intent(out) :: flxprf + +! --- locals: + real (kind=kind_phys), dimension(0:nlp1) :: cldfrc + + real (kind=kind_phys), dimension(0:nlay) :: totuflux, totdflux, & + & totuclfl, totdclfl, tz + + real (kind=kind_phys), dimension(nlay) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay) :: pavel, tavel, delp, & + & clwp, ciwp, relw, reiw, cda1, cda2, cda3, cda4, & + & coldry, colbrd, h2ovmr, o3vmr, fac00, fac01, fac10, fac11, & + & selffac, selffrac, forfac, forfrac, minorfrac, scaleminor, & + & scaleminorn2, temcol + + real (kind=kind_phys), dimension(nbands,0:nlay) :: pklev, pklay + + real (kind=kind_phys), dimension(nlay,nbands) :: htrb + real (kind=kind_phys), dimension(nbands,nlay) :: taucld, tauaer + real (kind=kind_phys), dimension(ngptlw,nlay) :: fracs, tautot, & + & cldfmc + + real (kind=kind_phys), dimension(nbands) :: semiss, secdiff + +! --- column amount of absorbing gases: +! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co + real (kind=kind_phys) :: colamt(nlay,maxgas) + +! --- column cfc cross-section amounts: +! (:,m) m = 1-ccl4, 2-cfc11, 3-cfc12, 4-cfc22 + real (kind=kind_phys) :: wx(nlay,maxxsec) + +! --- reference ratios of binary species parameter in lower atmosphere: +! (:,m,:) m = 1-h2o/co2, 2-h2o/o3, 3-h2o/n2o, 4-h2o/ch4, 5-n2o/co2, 6-o3/co2 + real (kind=kind_phys) :: rfrate(nlay,nrates,2) + + real (kind=kind_phys) :: tem0, tem1, tem2, pwvcm, summol, stemp + + integer, dimension(npts) :: ipseed + integer, dimension(nlay) :: jp, jt, jt1, indself, indfor, indminor + integer :: laytrop, iplon, i, j, k, k1 + logical :: lcf1 + +! +!===> ... begin here +! + +! --- ... initialization + + lhlwb = present ( hlwb ) + lhlw0 = present ( hlw0 ) + lflxprf= present ( flxprf ) + + + colamt(:,:) = f_zero + +!> -# Change random number seed value for each radiation invocation +!! (isubclw =1 or 2). + + if ( isubclw == 1 ) then ! advance prescribed permutation seed + do i = 1, npts + ipseed(i) = ipsdlw0 + i + enddo + elseif ( isubclw == 2 ) then ! use input array of permutaion seeds + do i = 1, npts + ipseed(i) = icseed(i) + enddo + endif + +! if ( lprnt ) then +! print *,' In radlw, isubclw, ipsdlw0,ipseed =', & +! & isubclw, ipsdlw0, ipseed +! endif + +! --- ... loop over horizontal npts profiles + + lab_do_iplon : do iplon = 1, npts + +!> -# Read surface emissivity. + if (sfemis(iplon) > eps .and. sfemis(iplon) <= 1.0) then ! input surface emissivity + do j = 1, nbands + semiss(j) = sfemis(iplon) + enddo + else ! use default values + do j = 1, nbands + semiss(j) = semiss0(j) + enddo + endif + + stemp = sfgtmp(iplon) ! surface ground temp + +!> -# Prepare atmospheric profile for use in rrtm. +! the vertical index of internal array is from surface to top + +! --- ... molecular amounts are input or converted to volume mixing ratio +! and later then converted to molecular amount (molec/cm2) by the +! dry air column coldry (in molec/cm2) which is calculated from the +! layer pressure thickness (in mb), based on the hydrostatic equation +! --- ... and includes a correction to account for h2o in the layer. + + if (ivflip == 0) then ! input from toa to sfc + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + tz(0) = tlvl(iplon,nlp1) + + do k = 1, nlay + k1 = nlp1 - k + pavel(k)= plyr(iplon,k1) + delp(k) = plvl(iplon,k1+1) - plvl(iplon,k1) + tavel(k)= tlyr(iplon,k1) + tz(k) = tlvl(iplon,k1) + +!> -# Set absorber amount for h2o, co2, and o3. + +!test use +! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(iplon,k1)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(iplon,k1)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(iplon,k1) & + & *amdw/(f_one-qlyr(iplon,k1))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(iplon,k1)*amdo3) ! input mass mixing ratio + +! --- ... tem0 is the molecular weight of moist air + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k1,1)) ! co2 + colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3 + enddo + +!> -# Set up column amount for rare gases n2o,ch4,o2,co,ccl4,cf11,cf12, +!! cf22, convert from volume mixing ratio to molec/cm2 based on +!! coldry (scaled to 1.0e-20). + + if (ilwrgas > 0) then + do k = 1, nlay + k1 = nlp1 - k + colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,2)) ! n2o + colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k1,3)) ! ch4 + colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k1,4)) ! o2 + colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k1,5)) ! co + + wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k1,9) ) ! ccl4 + wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k1,6) ) ! cf11 + wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k1,7) ) ! cf12 + wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k1,8) ) ! cf22 + enddo + else + do k = 1, nlay + colamt(k,4) = f_zero ! n2o + colamt(k,5) = f_zero ! ch4 + colamt(k,6) = f_zero ! o2 + colamt(k,7) = f_zero ! co + + wx(k,1) = f_zero + wx(k,2) = f_zero + wx(k,3) = f_zero + wx(k,4) = f_zero + enddo + endif + +!> -# Set aerosol optical properties. + + do k = 1, nlay + k1 = nlp1 - k + do j = 1, nbands + tauaer(j,k) = aerosols(iplon,k1,j,1) & + & * (f_one - aerosols(iplon,k1,j,2)) + enddo + enddo + +!> -# Read cloud optical properties + if (ilwcliq > 0) then ! use prognostic cloud method + do k = 1, nlay + k1 = nlp1 - k + cldfrc(k)= clouds(iplon,k1,1) + clwp(k) = clouds(iplon,k1,2) + relw(k) = clouds(iplon,k1,3) + ciwp(k) = clouds(iplon,k1,4) + reiw(k) = clouds(iplon,k1,5) + cda1(k) = clouds(iplon,k1,6) + cda2(k) = clouds(iplon,k1,7) + cda3(k) = clouds(iplon,k1,8) + cda4(k) = clouds(iplon,k1,9) + enddo + else ! use diagnostic cloud method + do k = 1, nlay + k1 = nlp1 - k + cldfrc(k)= clouds(iplon,k1,1) + cda1(k) = clouds(iplon,k1,2) + enddo + endif ! end if_ilwcliq + + cldfrc(0) = f_one ! padding value only + cldfrc(nlp1) = f_zero ! padding value only + +!> -# Compute precipitable water vapor for diffusivity angle adjustments. + + tem1 = f_zero + tem2 = f_zero + do k = 1, nlay + tem1 = tem1 + coldry(k) + colamt(k,1) + tem2 = tem2 + colamt(k,1) + enddo + + tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) + pwvcm = tem0 * plvl(iplon,nlp1) + + else ! input from sfc to toa + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + tz(0) = tlvl(iplon,1) + + do k = 1, nlay + pavel(k)= plyr(iplon,k) + delp(k) = plvl(iplon,k) - plvl(iplon,k+1) + tavel(k)= tlyr(iplon,k) + tz(k) = tlvl(iplon,k+1) + +! --- ... set absorber amount +!test use +! h2ovmr(k)= max(f_zero,qlyr(iplon,k)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(iplon,k)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(iplon,k)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(iplon,k) & + & *amdw/(f_one-qlyr(iplon,k))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(iplon,k)*amdo3) ! input mass mixing ratio + +! --- ... tem0 is the molecular weight of moist air + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2*delp(k) / (tem1*tem0*(f_one+h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(iplon,k,1)) ! co2 + colamt(k,3) = max(temcol(k), coldry(k)*o3vmr(k)) ! o3 + enddo + +! --- ... set up col amount for rare gases, convert from volume mixing ratio +! to molec/cm2 based on coldry (scaled to 1.0e-20) + + if (ilwrgas > 0) then + do k = 1, nlay + colamt(k,4)=max(temcol(k), coldry(k)*gasvmr(iplon,k,2)) ! n2o + colamt(k,5)=max(temcol(k), coldry(k)*gasvmr(iplon,k,3)) ! ch4 + colamt(k,6)=max(f_zero, coldry(k)*gasvmr(iplon,k,4)) ! o2 + colamt(k,7)=max(f_zero, coldry(k)*gasvmr(iplon,k,5)) ! co + + wx(k,1) = max( f_zero, coldry(k)*gasvmr(iplon,k,9) ) ! ccl4 + wx(k,2) = max( f_zero, coldry(k)*gasvmr(iplon,k,6) ) ! cf11 + wx(k,3) = max( f_zero, coldry(k)*gasvmr(iplon,k,7) ) ! cf12 + wx(k,4) = max( f_zero, coldry(k)*gasvmr(iplon,k,8) ) ! cf22 + enddo + else + do k = 1, nlay + colamt(k,4) = f_zero ! n2o + colamt(k,5) = f_zero ! ch4 + colamt(k,6) = f_zero ! o2 + colamt(k,7) = f_zero ! co + + wx(k,1) = f_zero + wx(k,2) = f_zero + wx(k,3) = f_zero + wx(k,4) = f_zero + enddo + endif + +! --- ... set aerosol optical properties + + do j = 1, nbands + do k = 1, nlay + tauaer(j,k) = aerosols(iplon,k,j,1) & + & * (f_one - aerosols(iplon,k,j,2)) + enddo + enddo + + if (ilwcliq > 0) then ! use prognostic cloud method + do k = 1, nlay + cldfrc(k)= clouds(iplon,k,1) + clwp(k) = clouds(iplon,k,2) + relw(k) = clouds(iplon,k,3) + ciwp(k) = clouds(iplon,k,4) + reiw(k) = clouds(iplon,k,5) + cda1(k) = clouds(iplon,k,6) + cda2(k) = clouds(iplon,k,7) + cda3(k) = clouds(iplon,k,8) + cda4(k) = clouds(iplon,k,9) + enddo + else ! use diagnostic cloud method + do k = 1, nlay + cldfrc(k)= clouds(iplon,k,1) + cda1(k) = clouds(iplon,k,2) + enddo + endif ! end if_ilwcliq + + cldfrc(0) = f_one ! padding value only + cldfrc(nlp1) = f_zero ! padding value only + +! --- ... compute precipitable water vapor for diffusivity angle adjustments + + tem1 = f_zero + tem2 = f_zero + do k = 1, nlay + tem1 = tem1 + coldry(k) + colamt(k,1) + tem2 = tem2 + colamt(k,1) + enddo + + tem0 = 10.0 * tem2 / (amdw * tem1 * con_g) + pwvcm = tem0 * plvl(iplon,1) + + endif ! if_ivflip + +!> -# Compute column amount for broadening gases. + + do k = 1, nlay + summol = f_zero + do i = 2, maxgas + summol = summol + colamt(k,i) + enddo + colbrd(k) = coldry(k) - summol + enddo + +!> -# Compute diffusivity angle adjustments. + + tem1 = 1.80 + tem2 = 1.50 + do j = 1, nbands + if (j==1 .or. j==4 .or. j==10) then + secdiff(j) = 1.66 + else + secdiff(j) = min( tem1, max( tem2, & + & a0(j)+a1(j)*exp(a2(j)*pwvcm) )) + endif + enddo + +! if (lprnt) then +! print *,' coldry',coldry +! print *,' wx(*,1) ',(wx(k,1),k=1,NLAY) +! print *,' wx(*,2) ',(wx(k,2),k=1,NLAY) +! print *,' wx(*,3) ',(wx(k,3),k=1,NLAY) +! print *,' wx(*,4) ',(wx(k,4),k=1,NLAY) +! print *,' iplon ',iplon +! print *,' pavel ',pavel +! print *,' delp ',delp +! print *,' tavel ',tavel +! print *,' tz ',tz +! print *,' h2ovmr ',h2ovmr +! print *,' o3vmr ',o3vmr +! endif + +!> -# For cloudy atmosphere, call cldprop() to set cloud optical +!! properties. + + lcf1 = .false. + lab_do_k0 : do k = 1, nlay + if ( cldfrc(k) > eps ) then + lcf1 = .true. + exit lab_do_k0 + endif + enddo lab_do_k0 + + if ( lcf1 ) then + + call cldprop & +! --- inputs: + & ( cldfrc,clwp,relw,ciwp,reiw,cda1,cda2,cda3,cda4, & + & nlay, nlp1, ipseed(iplon), & +! --- outputs: + & cldfmc, taucld & + & ) + + else + cldfmc = f_zero + taucld = f_zero + endif + +! if (lprnt) then +! print *,' after cldprop' +! print *,' clwp',clwp +! print *,' ciwp',ciwp +! print *,' relw',relw +! print *,' reiw',reiw +! print *,' taucl',cda1 +! print *,' cldfrac',cldfrc +! endif + +!> -# Calling setcoef() to compute various coefficients needed in +!! radiative transfer calculations. + call setcoef & +! --- inputs: + & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & + & nlay, nlp1, & +! --- outputs: + & laytrop,pklay,pklev,jp,jt,jt1, & + & rfrate,fac00,fac01,fac10,fac11, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor & + & ) + +! if (lprnt) then +! print *,'laytrop',laytrop +! print *,'colh2o',(colamt(k,1),k=1,NLAY) +! print *,'colco2',(colamt(k,2),k=1,NLAY) +! print *,'colo3', (colamt(k,3),k=1,NLAY) +! print *,'coln2o',(colamt(k,4),k=1,NLAY) +! print *,'colch4',(colamt(k,5),k=1,NLAY) +! print *,'fac00',fac00 +! print *,'fac01',fac01 +! print *,'fac10',fac10 +! print *,'fac11',fac11 +! print *,'jp',jp +! print *,'jt',jt +! print *,'jt1',jt1 +! print *,'selffac',selffac +! print *,'selffrac',selffrac +! print *,'indself',indself +! print *,'forfac',forfac +! print *,'forfrac',forfrac +! print *,'indfor',indfor +! endif + +!> -# Call taumol() to calculte the gaseous optical depths and Plank +!! fractions for each longwave spectral band. + + call taumol & +! --- inputs: + & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & + & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor, & + & nlay, & +! --- outputs: + & fracs, tautot & + & ) + +! if (lprnt) then +! print *,' after taumol' +! do k = 1, nlay +! write(6,121) k +!121 format(' k =',i3,5x,'FRACS') +! write(6,122) (fracs(j,k),j=1,ngptlw) +!122 format(10e14.7) +! write(6,123) k +!123 format(' k =',i3,5x,'TAUTOT') +! write(6,122) (tautot(j,k),j=1,ngptlw) +! enddo +! endif + +!> -# Call the radiative transfer routine based on cloud scheme +!! selection. Compute the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere. +!!\n - call rtrn(): clouds are assumed as randomly overlaping in a +!! vertical column +!!\n - call rtrnmr(): clouds are assumed as in maximum-randomly +!! overlaping in a vertical column; +!!\n - call rtrnmc(): clouds are treated with the mcica stochastic +!! approach. + + if (isubclw <= 0) then + + if (iovrlw <= 0) then + + call rtrn & +! --- inputs: + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & + & fracs,secdiff,nlay,nlp1, & +! --- outputs: + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & + & ) + + else + + call rtrnmr & +! --- inputs: + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & + & fracs,secdiff,nlay,nlp1, & +! --- outputs: + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & + & ) + + endif ! end if_iovrlw_block + + else + + call rtrnmc & +! --- inputs: + & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & + & fracs,secdiff,nlay,nlp1, & +! --- outputs: + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & + & ) + + endif ! end if_isubclw_block + +!> -# Save outputs. + + topflx(iplon)%upfxc = totuflux(nlay) + topflx(iplon)%upfx0 = totuclfl(nlay) + + sfcflx(iplon)%upfxc = totuflux(0) + sfcflx(iplon)%upfx0 = totuclfl(0) + sfcflx(iplon)%dnfxc = totdflux(0) + sfcflx(iplon)%dnfx0 = totdclfl(0) + + if (ivflip == 0) then ! output from toa to sfc + +!! --- ... optional fluxes + if ( lflxprf ) then + do k = 0, nlay + k1 = nlp1 - k + flxprf(iplon,k1)%upfxc = totuflux(k) + flxprf(iplon,k1)%dnfxc = totdflux(k) + flxprf(iplon,k1)%upfx0 = totuclfl(k) + flxprf(iplon,k1)%dnfx0 = totdclfl(k) + enddo + endif + + do k = 1, nlay + k1 = nlp1 - k + hlwc(iplon,k1) = htr(k) + enddo + +!! --- ... optional clear sky heating rate + if ( lhlw0 ) then + do k = 1, nlay + k1 = nlp1 - k + hlw0(iplon,k1) = htrcl(k) + enddo + endif + +!! --- ... optional spectral band heating rate + if ( lhlwb ) then + do j = 1, nbands + do k = 1, nlay + k1 = nlp1 - k + hlwb(iplon,k1,j) = htrb(k,j) + enddo + enddo + endif + + else ! output from sfc to toa + +!! --- ... optional fluxes + if ( lflxprf ) then + do k = 0, nlay + flxprf(iplon,k+1)%upfxc = totuflux(k) + flxprf(iplon,k+1)%dnfxc = totdflux(k) + flxprf(iplon,k+1)%upfx0 = totuclfl(k) + flxprf(iplon,k+1)%dnfx0 = totdclfl(k) + enddo + endif + + do k = 1, nlay + hlwc(iplon,k) = htr(k) + enddo + +!! --- ... optional clear sky heating rate + if ( lhlw0 ) then + do k = 1, nlay + hlw0(iplon,k) = htrcl(k) + enddo + endif + +!! --- ... optional spectral band heating rate + if ( lhlwb ) then + do j = 1, nbands + do k = 1, nlay + hlwb(iplon,k,j) = htrb(k,j) + enddo + enddo + endif + + endif ! if_ivflip + + enddo lab_do_iplon + +!................................... + end subroutine lwrad +!----------------------------------- +!> @} + + + +!> This subroutine performs calculations necessary for the initialization +!! of the longwave model. lookup tables are computed for use in the lw +!! radiative transfer, and input absorption coefficient data for each +!! spectral band are reduced from 256 g-point intervals to 140. +!!\param me print control for parallel process +!----------------------------------- + subroutine rlwinit & + & ( me ) ! --- inputs +! --- outputs: (none) + +! =================== program usage description =================== ! +! ! +! purpose: initialize non-varying module variables, conversion factors,! +! and look-up tables. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! me - print control for parallel process ! +! ! +! outputs: (none) ! +! ! +! external module variables: (in physparam) ! +! ilwrate - heating rate unit selections ! +! =1: output in k/day ! +! =2: output in k/second ! +! ilwrgas - control flag for rare gases (ch4,n2o,o2,cfcs, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! ilwcliq - liquid cloud optical properties contrl flag ! +! =0: input cloud opt depth from diagnostic scheme ! +! >0: input cwp,rew, and other cloud content parameters ! +! isubclw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! icldflg - cloud scheme control flag ! +! =0: diagnostic scheme gives cloud tau, omiga, and g. ! +! =1: prognostic scheme gives cloud liq/ice path, etc. ! +! iovrlw - clouds vertical overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud (isubcol>0 only) ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: michael j. iacono; july, 1998 ! +! first revision for ncar ccm: september, 1998 ! +! second revision for rrtm_v3.0: september, 2002 ! +! ! +! this subroutine performs calculations necessary for the initialization +! of the longwave model. lookup tables are computed for use in the lw ! +! radiative transfer, and input absorption coefficient data for each ! +! spectral band are reduced from 256 g-point intervals to 140. ! +! ! +! ******************************************************************* ! +! ! +! definitions: ! +! arrays for 10000-point look-up tables: ! +! tau_tbl - clear-sky optical depth (used in cloudy radiative transfer! +! exp_tbl - exponential lookup table for tansmittance ! +! tfn_tbl - tau transition function; i.e. the transition of the Planck! +! function from that for the mean layer temperature to that ! +! for the layer boundary temperature as a function of optical +! depth. the "linear in tau" method is used to make the table +! ! +! ******************************************************************* ! +! ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: me + +! --- outputs: none + +! --- locals: + real (kind=kind_phys), parameter :: expeps = 1.e-20 + + real (kind=kind_phys) :: tfn, pival, explimit + + integer :: i + +! +!===> ... begin here +! + if ( iovrlw<0 .or. iovrlw>2 ) then + print *,' *** Error in specification of cloud overlap flag', & + & ' IOVRLW=',iovrlw,' in RLWINIT !!' + stop + elseif ( iovrlw==2 .and. isubclw==0 ) then + if (me == 0) then + print *,' *** IOVRLW=2 - maximum cloud overlap, is not yet', & + & ' available for ISUBCLW=0 setting!!' + print *,' The program uses maximum/random overlap', & + & ' instead.' + endif + + iovrlw = 1 + endif + + if (me == 0) then + print *,' - Using AER Longwave Radiation, Version: ', VTAGLW + + if (ilwrgas > 0) then + print *,' --- Include rare gases N2O, CH4, O2, CFCs ', & + & 'absorptions in LW' + else + print *,' --- Rare gases effect is NOT included in LW' + endif + + if ( isubclw == 0 ) then + print *,' --- Using standard grid average clouds, no ', & + & 'sub-column clouds approximation applied' + elseif ( isubclw == 1 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with a prescribed sequence of permutaion seeds' + elseif ( isubclw == 2 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with provided input array of permutation seeds' + else + print *,' *** Error in specification of sub-column cloud ', & + & ' control flag isubclw =',isubclw,' !!' + stop + endif + endif + +! --- ... check cloud flags for consistency + + if ((icldflg == 0 .and. ilwcliq /= 0) .or. & + & (icldflg == 1 .and. ilwcliq == 0)) then + print *,' *** Model cloud scheme inconsistent with LW', & + & ' radiation cloud radiative property setup !!' + stop + endif + +! --- ... setup default surface emissivity for each band here + + semiss0(:) = f_one + +! --- ... setup constant factors for flux and heating rate +! the 1.0e-2 is to convert pressure from mb to N/m**2 + + pival = 2.0 * asin(f_one) + fluxfac = pival * 2.0d4 +! fluxfac = 62831.85307179586 ! = 2 * pi * 1.0e4 + + if (ilwrate == 1) then +! heatfac = 8.4391 +! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) + heatfac = con_g * 864.0 / con_cp ! (in k/day) + else + heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) + endif + +! --- ... compute lookup tables for transmittance, tau transition +! function, and clear sky tau (for the cloudy sky radiative +! transfer). tau is computed as a function of the tau +! transition function, transmittance is calculated as a +! function of tau, and the tau transition function is +! calculated using the linear in tau formulation at values of +! tau above 0.01. tf is approximated as tau/6 for tau < 0.01. +! all tables are computed at intervals of 0.001. the inverse +! of the constant used in the pade approximation to the tau +! transition function is set to b. + + tau_tbl(0) = f_zero + exp_tbl(0) = f_one + tfn_tbl(0) = f_zero + + tau_tbl(ntbl) = 1.e10 + exp_tbl(ntbl) = expeps + tfn_tbl(ntbl) = f_one + + explimit = aint( -log(tiny(exp_tbl(0))) ) + + do i = 1, ntbl-1 +!org tfn = float(i) / float(ntbl) +!org tau_tbl(i) = bpade * tfn / (f_one - tfn) + tfn = real(i, kind_phys) / real(ntbl-i, kind_phys) + tau_tbl(i) = bpade * tfn + if (tau_tbl(i) >= explimit) then + exp_tbl(i) = expeps + else + exp_tbl(i) = exp( -tau_tbl(i) ) + endif + + if (tau_tbl(i) < 0.06) then + tfn_tbl(i) = tau_tbl(i) / 6.0 + else + tfn_tbl(i) = f_one - 2.0*( (f_one / tau_tbl(i)) & + & - ( exp_tbl(i) / (f_one - exp_tbl(i)) ) ) + endif + enddo + +!................................... + end subroutine rlwinit +!----------------------------------- + + +!> This subroutine computes the cloud optical depth(s) for each cloudy +!! layer and g-point interval. +!!\param cfrac layer cloud fraction +!!\n --- for ilwcliq > 0 (prognostic cloud scheme) - - - +!!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) +!!\param reliq mean eff radius for liq cloud (micron) +!!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) +!!\param reice mean eff radius for ice cloud (micron) +!!\param cdat1 layer rain drop water path (\f$g/m^2\f$) +!!\param cdat2 effective radius for rain drop (micron) +!!\param cdat3 layer snow flake water path(\f$g/m^2\f$) +!!\param cdat4 mean effective radius for snow flake(micron) +!!\n --- for ilwcliq = 0 (diagnostic cloud scheme) - - - +!!\param cliqp not used +!!\param cicep not used +!!\param reliq not used +!!\param reice not used +!!\param cdat1 layer cloud optical depth +!!\param cdat2 layer cloud single scattering albedo +!!\param cdat3 layer cloud asymmetry factor +!!\param cdat4 optional use +!!\param nlay number of layer number +!!\param nlp1 number of veritcal levels +!!\param ipseed permutation seed for generating random numbers (isubclw>0) +!!\param cldfmc cloud fraction for each sub-column +!!\param taucld cloud optical depth for bands (non-mcica) +!!\section gen_cldprop General Algorithm +!> @{ +! ---------------------------- + subroutine cldprop & + & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs + & nlay, nlp1, ipseed, & + & cldfmc, taucld & ! --- outputs + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the cloud optical depth(s) for each cloudy layer ! +! and g-point interval. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! cfrac - real, layer cloud fraction 0:nlp1 ! +! ..... for ilwcliq > 0 (prognostic cloud sckeme) - - - ! +! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! +! reliq - real, mean eff radius for liq cloud (micron) nlay ! +! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! +! reice - real, mean eff radius for ice cloud (micron) nlay ! +! cdat1 - real, layer rain drop water path (g/m**2) nlay ! +! cdat2 - real, effective radius for rain drop (microm) nlay ! +! cdat3 - real, layer snow flake water path (g/m**2) nlay ! +! cdat4 - real, effective radius for snow flakes (micron) nlay ! +! ..... for ilwcliq = 0 (diagnostic cloud sckeme) - - - ! +! cdat1 - real, input cloud optical depth nlay ! +! cdat2 - real, layer cloud single scattering albedo nlay ! +! cdat3 - real, layer cloud asymmetry factor nlay ! +! cdat4 - real, optional use nlay ! +! cliqp - not used nlay ! +! reliq - not used nlay ! +! cicep - not used nlay ! +! reice - not used nlay ! +! ! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels 1 ! +! ipseed- permutation seed for generating random numbers (isubclw>0) ! +! ! +! outputs: ! +! cldfmc - real, cloud fraction for each sub-column ngptlw*nlay! +! taucld - real, cld opt depth for bands (non-mcica) nbands*nlay! +! ! +! explanation of the method for each value of ilwcliq, and ilwcice. ! +! set up in module "module_radlw_cntr_para" ! +! ! +! ilwcliq=0 : input cloud optical property (tau, ssa, asy). ! +! (used for diagnostic cloud method) ! +! ilwcliq>0 : input cloud liq/ice path and effective radius, also ! +! require the user of 'ilwcice' to specify the method ! +! used to compute aborption due to water/ice parts. ! +! ................................................................... ! +! ! +! ilwcliq=1: the water droplet effective radius (microns) is input! +! and the opt depths due to water clouds are computed ! +! as in hu and stamnes, j., clim., 6, 728-742, (1993). ! +! the values for absorption coefficients appropriate for +! the spectral bands in rrtm have been obtained for a ! +! range of effective radii by an averaging procedure ! +! based on the work of j. pinto (private communication). +! linear interpolation is used to get the absorption ! +! coefficients for the input effective radius. ! +! ! +! ilwcice=1: the cloud ice path (g/m2) and ice effective radius ! +! (microns) are input and the optical depths due to ice! +! clouds are computed as in ebert and curry, jgr, 97, ! +! 3831-3836 (1992). the spectral regions in this work ! +! have been matched with the spectral bands in rrtm to ! +! as great an extent as possible: ! +! e&c 1 ib = 5 rrtm bands 9-16 ! +! e&c 2 ib = 4 rrtm bands 6-8 ! +! e&c 3 ib = 3 rrtm bands 3-5 ! +! e&c 4 ib = 2 rrtm band 2 ! +! e&c 5 ib = 1 rrtm band 1 ! +! ilwcice=2: the cloud ice path (g/m2) and ice effective radius ! +! (microns) are input and the optical depths due to ice! +! clouds are computed as in rt code, streamer v3.0 ! +! (ref: key j., streamer user's guide, cooperative ! +! institute for meteorological satellite studies, 2001,! +! 96 pp.) valid range of values for re are between 5.0 ! +! and 131.0 micron. ! +! ilwcice=3: the ice generalized effective size (dge) is input and! +! the optical properties, are calculated as in q. fu, ! +! j. climate, (1998). q. fu provided high resolution ! +! tales which were appropriately averaged for the bands! +! in rrtm_lw. linear interpolation is used to get the ! +! coeff from the stored tables. valid range of values ! +! for deg are between 5.0 and 140.0 micron. ! +! ! +! other cloud control module variables: ! +! isubclw =0: standard cloud scheme, no sub-col cloud approximation ! +! >0: mcica sub-col cloud scheme using ipseed as permutation! +! seed for generating rundom numbers ! +! ! +! ====================== end of description block ================= ! +! + use module_radlw_cldprlw + +! --- inputs: + integer, intent(in) :: nlay, nlp1, ipseed + + real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cfrac + real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & + & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4 + +! --- outputs: + real (kind=kind_phys), dimension(ngptlw,nlay),intent(out):: cldfmc + real (kind=kind_phys), dimension(nbands,nlay),intent(out):: taucld + +! --- locals: + real (kind=kind_phys), dimension(nbands) :: tauliq, tauice + real (kind=kind_phys), dimension(nlay) :: cldf + + real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, & + & cldliq, refliq, cldice, refice + + logical :: lcloudy(ngptlw,nlay) + integer :: ia, ib, ig, k, index + +! +!===> ... begin here +! + do k = 1, nlay + do ib = 1, nbands + taucld(ib,k) = f_zero + enddo + enddo + + do k = 1, nlay + do ig = 1, ngptlw + cldfmc(ig,k) = f_zero + enddo + enddo + +!> -# Compute cloud radiative properties for a cloudy column: +!!\n - Compute cloud radiative properties for rain and snow (tauran,tausnw) +!!\n - Calculation of absorption coefficients due to water clouds(tauliq) +!!\n - Calculation of absorption coefficients due to ice clouds (tauice). +!!\n - For prognostic cloud scheme: sum up the cloud optical property: +!!\n \f$ taucld=tauice+tauliq+tauran+tausnw \f$ + +! --- ... compute cloud radiative properties for a cloudy column + + lab_if_ilwcliq : if (ilwcliq > 0) then + + lab_do_k : do k = 1, nlay + lab_if_cld : if (cfrac(k) > cldmin) then + + tauran = absrain * cdat1(k) ! ncar formula +!! tausnw = abssnow1 * cdat3(k) ! ncar formula +! --- if use fu's formula it needs to be normalized by snow density +! !not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2) +! use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2) +! factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size +! use newer factor value 1.0315 +! 1/(0.9167*1.0315) = 1.05756 + if (cdat3(k)>f_zero .and. cdat4(k)>10.0_kind_phys) then + tausnw = abssnow0*1.05756*cdat3(k)/cdat4(k) ! fu's formula + else + tausnw = f_zero + endif + + cldliq = cliqp(k) + cldice = cicep(k) +! refliq = max(2.5e0, min(60.0e0, reliq(k) )) +! refice = max(5.0e0, reice(k) ) + refliq = reliq(k) + refice = reice(k) + +! --- ... calculation of absorption coefficients due to water clouds. + + if ( cldliq <= f_zero ) then + do ib = 1, nbands + tauliq(ib) = f_zero + enddo + else + if ( ilwcliq == 1 ) then + + factor = refliq - 1.5 + index = max( 1, min( 57, int( factor ) )) + fint = factor - float(index) + + do ib = 1, nbands + tauliq(ib) = max(f_zero, cldliq*(absliq1(index,ib) & + & + fint*(absliq1(index+1,ib)-absliq1(index,ib)) )) + enddo + endif ! end if_ilwcliq_block + endif ! end if_cldliq_block + +! --- ... calculation of absorption coefficients due to ice clouds. + + if ( cldice <= f_zero ) then + do ib = 1, nbands + tauice(ib) = f_zero + enddo + else + +! --- ... ebert and curry approach for all particle sizes though somewhat +! unjustified for large ice particles + + if ( ilwcice == 1 ) then + refice = min(130.0, max(13.0, real(refice) )) + + do ib = 1, nbands + ia = ipat(ib) ! eb_&_c band index for ice cloud coeff + tauice(ib) = max(f_zero, cldice*(absice1(1,ia) & + & + absice1(2,ia)/refice) ) + enddo + +! --- ... streamer approach for ice effective radius between 5.0 and 131.0 microns +! and ebert and curry approach for ice eff radius greater than 131.0 microns. +! no smoothing between the transition of the two methods. + + elseif ( ilwcice == 2 ) then + + factor = (refice - 2.0) / 3.0 + index = max( 1, min( 42, int( factor ) )) + fint = factor - float(index) + + do ib = 1, nbands + tauice(ib) = max(f_zero, cldice*(absice2(index,ib) & + & + fint*(absice2(index+1,ib) - absice2(index,ib)) )) + enddo + +! --- ... fu's approach for ice effective radius between 4.8 and 135 microns +! (generalized effective size from 5 to 140 microns) + + elseif ( ilwcice == 3 ) then + +! dgeice = max(5.0, 1.5396*refice) ! v4.4 value + dgeice = max(5.0, 1.0315*refice) ! v4.71 value + factor = (dgeice - 2.0) / 3.0 + index = max( 1, min( 45, int( factor ) )) + fint = factor - float(index) + + do ib = 1, nbands + tauice(ib) = max(f_zero, cldice*(absice3(index,ib) & + & + fint*(absice3(index+1,ib) - absice3(index,ib)) )) + enddo + + endif ! end if_ilwcice_block + endif ! end if_cldice_block + + do ib = 1, nbands + taucld(ib,k) = tauice(ib) + tauliq(ib) + tauran + tausnw + enddo + + endif lab_if_cld + enddo lab_do_k + + else lab_if_ilwcliq + + do k = 1, nlay + if (cfrac(k) > cldmin) then + do ib = 1, nbands + taucld(ib,k) = cdat1(k) + enddo + endif + enddo + + endif lab_if_ilwcliq + +!> -# if physparam::isubclw > 0, call mcica_subcol() to distribute +!! cloud properties to each g-point. + + if ( isubclw > 0 ) then ! mcica sub-col clouds approx + do k = 1, nlay + if ( cfrac(k) < cldmin ) then + cldf(k) = f_zero + else + cldf(k) = cfrac(k) + endif + enddo + +! --- ... call sub-column cloud generator + + call mcica_subcol & +! --- inputs: + & ( cldf, nlay, ipseed, & +! --- output: + & lcloudy & + & ) + + do k = 1, nlay + do ig = 1, ngptlw + if ( lcloudy(ig,k) ) then + cldfmc(ig,k) = f_one + else + cldfmc(ig,k) = f_zero + endif + enddo + enddo + + endif ! end if_isubclw_block + + return +! .................................. + end subroutine cldprop +! ---------------------------------- +!> @} + +!> This suroutine computes sub-colum cloud profile flag array. +!!\param cldf layer cloud fraction +!!\param nlay number of model vertical layers +!!\param ipseed permute seed for random num generator +!!\param lcloudy sub-colum cloud profile flag array +! ---------------------------------- + subroutine mcica_subcol & + & ( cldf, nlay, ipseed, &! --- inputs + & lcloudy & ! --- outputs + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: size ! +! cldf - real, layer cloud fraction nlay ! +! nlay - integer, number of model vertical layers 1 ! +! ipseed - integer, permute seed for random num generator 1 ! +! ** note : if the cloud generator is called multiple times, need ! +! to permute the seed between each call; if between calls ! +! for lw and sw, use values differ by the number of g-pts. ! +! ! +! output variables: ! +! lcloudy - logical, sub-colum cloud profile flag array ngptlw*nlay! +! ! +! other control flags from module variables: ! +! iovrlw : control flag for cloud overlapping method ! +! =0:random; =1:maximum/random: =2:maximum ! +! ! +! ===================== end of definitions ==================== ! + + implicit none + +! --- inputs: + integer, intent(in) :: nlay, ipseed + + real (kind=kind_phys), dimension(nlay), intent(in) :: cldf + +! --- outputs: + logical, dimension(ngptlw,nlay), intent(out) :: lcloudy + +! --- locals: + real (kind=kind_phys) :: cdfunc(ngptlw,nlay), rand1d(ngptlw), & + & rand2d(nlay*ngptlw), tem1 + + type (random_stat) :: stat ! for thread safe random generator + + integer :: k, n, k1 +! +!===> ... begin here +! +! --- ... advance randum number generator by ipseed values + + call random_setseed & +! --- inputs: + & ( ipseed, & +! --- outputs: + & stat & + & ) + +! --- ... sub-column set up according to overlapping assumption + + select case ( iovrlw ) + + case( 0 ) ! random overlap, pick a random value at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptlw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo + + case( 1 ) ! max-ran overlap + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptlw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(n,k) = rand2d(k1) + enddo + enddo + +! --- first pick a random number for bottom (or top) layer. +! then walk up the column: (aer's code) +! if layer below is cloudy, use the same rand num in the layer below +! if layer below is clear, use a new random number + +! --- from bottom up + do k = 2, nlay + k1 = k - 1 + tem1 = f_one - cldf(k1) + + do n = 1, ngptlw + if ( cdfunc(n,k1) > tem1 ) then + cdfunc(n,k) = cdfunc(n,k1) + else + cdfunc(n,k) = cdfunc(n,k) * tem1 + endif + enddo + enddo + +! --- or walk down the column: (if use original author's method) +! if layer above is cloudy, use the same rand num in the layer above +! if layer above is clear, use a new random number + +! --- from top down +! do k = nlay-1, 1, -1 +! k1 = k + 1 +! tem1 = f_one - cldf(k1) + +! do n = 1, ngptlw +! if ( cdfunc(n,k1) > tem1 ) then +! cdfunc(n,k) = cdfunc(n,k1) +! else +! cdfunc(n,k) = cdfunc(n,k) * tem1 +! endif +! enddo +! enddo + + case( 2 ) ! maximum overlap, pick same random numebr at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand1d, stat ) + + do n = 1, ngptlw + tem1 = rand1d(n) + + do k = 1, nlay + cdfunc(n,k) = tem1 + enddo + enddo + + end select + +! --- ... generate subcolumns for homogeneous clouds + + do k = 1, nlay + tem1 = f_one - cldf(k) + + do n = 1, ngptlw + lcloudy(n,k) = cdfunc(n,k) >= tem1 + enddo + enddo + + return +! .................................. + end subroutine mcica_subcol +! ---------------------------------- + +!> This subroutine computes various coefficients needed in radiative +!! transfer calculations. +!!\param pavel layer pressure (mb) +!!\param tavel layer temperature (K) +!!\param tz level(interface) temperatures (K) +!!\param stemp surface ground temperature (K) +!!\param h2ovmr layer w.v. volumn mixing ratio (kg/kg) +!!\param colamt column amounts of absorbing gases. +!! 2nd indices range: 1-maxgas, for watervapor,carbon dioxide, ozone, +!! nitrous oxide, methane,oxigen, carbon monoxide,etc. \f$(mol/cm^2)\f$ +!!\param coldry dry air column amount +!!\param colbrd column amount of broadening gases +!!\param nlay total number of vertical layers +!!\param nlp1 total number of vertical levels +!!\param laytrop tropopause layer index (unitless) +!!\param pklay integrated planck func at lay temp +!!\param pklev integrated planck func at lev temp +!!\param jp indices of lower reference pressure +!!\param jt, jt1 indices of lower reference temperatures +!!\param rfrate ref ratios of binary species param +!!\n (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o, +!! 4-h2o/ch4,5-n2o/co2,6-o3/co2 +!!\n (:,:,n)n=1,2: the rates of ref press at +!! the 2 sides of the layer +!!\param facij factors multiply the reference ks, i,j=0/1 for +!! lower/higher of the 2 appropriate temperatures +!! and altitudes. +!!\param selffac scale factor for w. v. self-continuum equals +!! (w. v. density)/(atmospheric density at 296k and 1013 mb) +!!\param selffrac factor for temperature interpolation of +!! reference w. v. self-continuum data +!!\param indself index of lower ref temp for selffac +!!\param forfac scale factor for w. v. foreign-continuum +!!\param forfrac factor for temperature interpolation of +!! reference w.v. foreign-continuum data +!!\param indfor index of lower ref temp for forfac +!!\param minorfrac factor for minor gases +!!\param scaleminor,scaleminorn2 scale factors for minor gases +!!\param indminor index of lower ref temp for minor gases +! ---------------------------------- + subroutine setcoef & + & ( pavel,tavel,tz,stemp,h2ovmr,colamt,coldry,colbrd, & ! --- inputs: + & nlay, nlp1, & + & laytrop,pklay,pklev,jp,jt,jt1, & ! --- outputs: + & rfrate,fac00,fac01,fac10,fac11, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute various coefficients needed in radiative transfer ! +! calculations. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! pavel - real, layer pressures (mb) nlay ! +! tavel - real, layer temperatures (k) nlay ! +! tz - real, level (interface) temperatures (k) 0:nlay ! +! stemp - real, surface ground temperature (k) 1 ! +! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay ! +! colamt - real, column amounts of absorbing gases nlay*maxgas! +! 2nd indices range: 1-maxgas, for watervapor, ! +! carbon dioxide, ozone, nitrous oxide, methane, ! +! oxigen, carbon monoxide,etc. (molecules/cm**2) ! +! coldry - real, dry air column amount nlay ! +! colbrd - real, column amount of broadening gases nlay ! +! nlay/nlp1 - integer, total number of vertical layers, levels 1 ! +! ! +! outputs: ! +! laytrop - integer, tropopause layer index (unitless) 1 ! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! jp - real, indices of lower reference pressure nlay ! +! jt, jt1 - real, indices of lower reference temperatures nlay ! +! rfrate - real, ref ratios of binary species param nlay*nrates*2! +! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2! +! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer ! +! facij - real, factors multiply the reference ks, nlay ! +! i,j=0/1 for lower/higher of the 2 appropriate ! +! temperatures and altitudes. ! +! selffac - real, scale factor for w. v. self-continuum nlay ! +! equals (w. v. density)/(atmospheric density ! +! at 296k and 1013 mb) ! +! selffrac - real, factor for temperature interpolation of nlay ! +! reference w. v. self-continuum data ! +! indself - integer, index of lower ref temp for selffac nlay ! +! forfac - real, scale factor for w. v. foreign-continuum nlay ! +! forfrac - real, factor for temperature interpolation of nlay ! +! reference w.v. foreign-continuum data ! +! indfor - integer, index of lower ref temp for forfac nlay ! +! minorfrac - real, factor for minor gases nlay ! +! scaleminor,scaleminorn2 ! +! - real, scale factors for minor gases nlay ! +! indminor - integer, index of lower ref temp for minor gases nlay ! +! ! +! ====================== end of definitions =================== ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlay,maxgas),intent(in):: colamt + real (kind=kind_phys), dimension(0:nlay), intent(in):: tz + + real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, & + & tavel, h2ovmr, coldry, colbrd + + real (kind=kind_phys), intent(in) :: stemp + +! --- outputs: + integer, dimension(nlay), intent(out) :: jp, jt, jt1, indself, & + & indfor, indminor + + integer, intent(out) :: laytrop + + real (kind=kind_phys), dimension(nlay,nrates,2), intent(out) :: & + & rfrate + real (kind=kind_phys), dimension(nbands,0:nlay), intent(out) :: & + & pklev, pklay + + real (kind=kind_phys), dimension(nlay), intent(out) :: & + & fac00, fac01, fac10, fac11, selffac, selffrac, forfac, & + & forfrac, minorfrac, scaleminor, scaleminorn2 + +! --- locals: + real (kind=kind_phys) :: tlvlfr, tlyrfr, plog, fp, ft, ft1, & + & tem1, tem2 + + integer :: i, k, jp1, indlev, indlay +! +!===> ... begin here +! +! --- ... calculate information needed by the radiative transfer routine +! that is specific to this atmosphere, especially some of the +! coefficients and indices needed to compute the optical depths +! by interpolating data from stored reference atmospheres. + + indlay = min(180, max(1, int(stemp-159.0) )) + indlev = min(180, max(1, int(tz(0)-159.0) )) + tlyrfr = stemp - int(stemp) + tlvlfr = tz(0) - int(tz(0)) + do i = 1, nbands + tem1 = totplnk(indlay+1,i) - totplnk(indlay,i) + tem2 = totplnk(indlev+1,i) - totplnk(indlev,i) + pklay(i,0) = delwave(i) * (totplnk(indlay,i) + tlyrfr*tem1) + pklev(i,0) = delwave(i) * (totplnk(indlev,i) + tlvlfr*tem2) + enddo + +! --- ... begin layer loop +! calculate the integrated Planck functions for each band at the +! surface, level, and layer temperatures. + + laytrop = 0 + + do k = 1, nlay + + indlay = min(180, max(1, int(tavel(k)-159.0) )) + tlyrfr = tavel(k) - int(tavel(k)) + + indlev = min(180, max(1, int(tz(k)-159.0) )) + tlvlfr = tz(k) - int(tz(k)) + +! --- ... begin spectral band loop + + do i = 1, nbands + pklay(i,k) = delwave(i) * (totplnk(indlay,i) + tlyrfr & + & * (totplnk(indlay+1,i) - totplnk(indlay,i)) ) + pklev(i,k) = delwave(i) * (totplnk(indlev,i) + tlvlfr & + & * (totplnk(indlev+1,i) - totplnk(indlev,i)) ) + enddo + +! --- ... find the two reference pressures on either side of the +! layer pressure. store them in jp and jp1. store in fp the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. + + plog = log(pavel(k)) + jp(k)= max(1, min(58, int(36.0 - 5.0*(plog+0.04)) )) + jp1 = jp(k) + 1 +! --- ... limit pressure extrapolation at the top + fp = max(f_zero, min(f_one, 5.0*(preflog(jp(k))-plog) )) +!org fp = 5.0 * (preflog(jp(k)) - plog) + +! --- ... determine, for each reference pressure (jp and jp1), which +! reference temperature (these are different for each +! reference pressure) is nearest the layer temperature but does +! not exceed it. store these indices in jt and jt1, resp. +! store in ft (resp. ft1) the fraction of the way between jt +! (jt1) and the next highest reference temperature that the +! layer temperature falls. + + tem1 = (tavel(k)-tref(jp(k))) / 15.0 + tem2 = (tavel(k)-tref(jp1 )) / 15.0 + jt (k) = max(1, min(4, int(3.0 + tem1) )) + jt1(k) = max(1, min(4, int(3.0 + tem2) )) +! --- ... restrict extrapolation ranges by limiting abs(det t) < 37.5 deg + ft = max(-0.5, min(1.5, tem1 - float(jt (k) - 3) )) + ft1 = max(-0.5, min(1.5, tem2 - float(jt1(k) - 3) )) +!org ft = tem1 - float(jt (k) - 3) +!org ft1 = tem2 - float(jt1(k) - 3) + +! --- ... we have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). we multiply the pressure +! fraction fp with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines taugbn for band n) + + tem1 = f_one - fp + fac10(k) = tem1 * ft + fac00(k) = tem1 * (f_one - ft) + fac11(k) = fp * ft1 + fac01(k) = fp * (f_one - ft1) + + forfac(k) = pavel(k)*stpfac / (tavel(k)*(1.0 + h2ovmr(k))) + selffac(k) = h2ovmr(k) * forfac(k) + +! --- ... set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + + scaleminor(k) = pavel(k) / tavel(k) + scaleminorn2(k) = (pavel(k) / tavel(k)) & + & * (colbrd(k)/(coldry(k) + colamt(k,1))) + tem1 = (tavel(k) - 180.8) / 7.2 + indminor(k) = min(18, max(1, int(tem1))) + minorfrac(k) = tem1 - float(indminor(k)) + +! --- ... if the pressure is less than ~100mb, perform a different +! set of species interpolations. + + if (plog > 4.56) then + + laytrop = laytrop + 1 + + tem1 = (332.0 - tavel(k)) / 36.0 + indfor(k) = min(2, max(1, int(tem1))) + forfrac(k) = tem1 - float(indfor(k)) + +! --- ... set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + + tem1 = (tavel(k) - 188.0) / 7.2 + indself(k) = min(9, max(1, int(tem1)-7)) + selffrac(k) = tem1 - float(indself(k) + 7) + +! --- ... setup reference ratio to be used in calculation of binary +! species parameter in lower atmosphere. + + rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1) + + rfrate(k,2,1) = chi_mls(1,jp(k)) / chi_mls(3,jp(k)) + rfrate(k,2,2) = chi_mls(1,jp(k)+1) / chi_mls(3,jp(k)+1) + + rfrate(k,3,1) = chi_mls(1,jp(k)) / chi_mls(4,jp(k)) + rfrate(k,3,2) = chi_mls(1,jp(k)+1) / chi_mls(4,jp(k)+1) + + rfrate(k,4,1) = chi_mls(1,jp(k)) / chi_mls(6,jp(k)) + rfrate(k,4,2) = chi_mls(1,jp(k)+1) / chi_mls(6,jp(k)+1) + + rfrate(k,5,1) = chi_mls(4,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,5,2) = chi_mls(4,jp(k)+1) / chi_mls(2,jp(k)+1) + + else + + tem1 = (tavel(k) - 188.0) / 36.0 + indfor(k) = 3 + forfrac(k) = tem1 - f_one + + indself(k) = 0 + selffrac(k) = f_zero + +! --- ... setup reference ratio to be used in calculation of binary +! species parameter in upper atmosphere. + + rfrate(k,1,1) = chi_mls(1,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,1,2) = chi_mls(1,jp(k)+1) / chi_mls(2,jp(k)+1) + + rfrate(k,6,1) = chi_mls(3,jp(k)) / chi_mls(2,jp(k)) + rfrate(k,6,2) = chi_mls(3,jp(k)+1) / chi_mls(2,jp(k)+1) + + endif + +! --- ... rescale selffac and forfac for use in taumol + + selffac(k) = colamt(k,1) * selffac(k) + forfac(k) = colamt(k,1) * forfac(k) + + enddo ! end do_k layer loop + + return +! .................................. + end subroutine setcoef +! ---------------------------------- + + +!> This subroutine computes the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere. Clouds assumed as +!! randomly overlaping in a vertical column. +!!\brief Original Code Description: this program calculates the upward +!! fluxes, downward fluxes, and heating rates for an arbitrary clear or +!! cloudy atmosphere. The input to this program is the atmospheric +!! profile, all Planck function information, and the cloud fraction by +!! layer. A variable diffusivity angle (secdif) is used for the angle +!! integration. Bands 2-3 and 5-9 use a value for secdif that varies +!! from 1.50 to 1.80 as a function of the column water vapor, and other +!! bands use a value of 1.66. The gaussian weight appropriate to this +!! angle (wtdiff =0.5) is applied here. Note that use of the emissivity +!! angle for the flux integration can cause errors of 1 to 4 \f$W/m^2\f$ +!! within cloudy layers. Clouds are treated with a random cloud overlap +!! method. +!!\param semiss lw surface emissivity +!!\param delp layer pressure thickness (mb) +!!\param cldfrc layer cloud fraction +!!\param taucld layer cloud opt depth +!!\param tautot total optical depth (gas+aerosols) +!!\param pklay integrated planck function at lay temp +!!\param pklev integrated planck func at lev temp +!!\param fracs planck fractions +!!\param secdif secant of diffusivity angle +!!\param nlay number of vertical layers +!!\param nlp1 number of vertical levels (interfaces) +!!\param totuflux total sky upward flux \f$(w/m^2)\f$ +!!\param totdflux total sky downward flux \f$(w/m^2)\f$ +!!\param htr total sky heating rate (k/sec or k/day) +!!\param totuclfl clear sky upward flux \f$(w/m^2)\f$ +!!\param totdclfl clear sky downward flux \f$(w/m^2)\f$ +!!\param htrcl clear sky heating rate (k/sec or k/day) +!!\param htrb spectral band lw heating rate (k/day) +!!\section gen_rtrn General Algorithm +! ---------------------------------- + subroutine rtrn & + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, & ! --- inputs + & fracs,secdif, nlay,nlp1, & + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the upward/downward radiative fluxes, and heating ! +! rates for both clear or cloudy atmosphere. clouds are assumed as ! +! randomly overlaping in a vertical colum. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! semiss - real, lw surface emissivity nbands! +! delp - real, layer pressure thickness (mb) nlay ! +! cldfrc - real, layer cloud fraction 0:nlp1 ! +! taucld - real, layer cloud opt depth nbands,nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! fracs - real, planck fractions ngptlw,nlay! +! secdif - real, secant of diffusivity angle nbands! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels (interfaces) 1 ! +! ! +! outputs: ! +! totuflux- real, total sky upward flux (w/m2) 0:nlay ! +! totdflux- real, total sky downward flux (w/m2) 0:nlay ! +! htr - real, total sky heating rate (k/sec or k/day) nlay ! +! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! +! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! +! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! +! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! +! ! +! module veriables: ! +! ngb - integer, band index for each g-value ngptlw! +! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! +! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! +! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! +! bpade - real, pade approx constant (1/0.278) 1 ! +! wtdiff - real, weight for radiance to flux conversion 1 ! +! ntbl - integer, dimension of look-up tables 1 ! +! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! +! exp_tbl - real, transmittance lookup table 0:ntbl ! +! tfn_tbl - real, tau transition function 0:ntbl ! +! ! +! local variables: ! +! itgas - integer, index for gases contribution look-up table 1 ! +! ittot - integer, index for gases plus clouds look-up table 1 ! +! reflct - real, surface reflectance 1 ! +! atrgas - real, gaseous absorptivity 1 ! +! atrtot - real, gaseous and cloud absorptivity 1 ! +! odcld - real, cloud optical depth 1 ! +! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay ! +! odepth - real, optical depth of gaseous only 1 ! +! odtot - real, optical depth of gas and cloud 1 ! +! gasfac - real, gas-only pade factor, used for planck fn 1 ! +! totfac - real, gas+cld pade factor, used for planck fn 1 ! +! bbdgas - real, gas-only planck function for downward rt 1 ! +! bbugas - real, gas-only planck function for upward rt 1 ! +! bbdtot - real, gas and cloud planck function for downward rt 1 ! +! bbutot - real, gas and cloud planck function for upward rt 1 ! +! gassrcu- real, upwd source radiance due to gas only nlay! +! totsrcu- real, upwd source radiance due to gas+cld nlay! +! gassrcd- real, dnwd source radiance due to gas only 1 ! +! totsrcd- real, dnwd source radiance due to gas+cld 1 ! +! radtotu- real, spectrally summed total sky upwd radiance 1 ! +! radclru- real, spectrally summed clear sky upwd radiance 1 ! +! radtotd- real, spectrally summed total sky dnwd radiance 1 ! +! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! +! toturad- real, total sky upward radiance by layer 0:nlay*nbands! +! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! +! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! +! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! +! fnet - real, net longwave flux (w/m2) 0:nlay ! +! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! +! ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: e. j. mlawer, et al. rrtm_v3.0 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! revision for f90: michael j. iacono; june, 2006 ! +! ! +! this program calculates the upward fluxes, downward fluxes, and ! +! heating rates for an arbitrary clear or cloudy atmosphere. the input ! +! to this program is the atmospheric profile, all Planck function ! +! information, and the cloud fraction by layer. a variable diffusivity! +! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! +! use a value for secdif that varies from 1.50 to 1.80 as a function ! +! of the column water vapor, and other bands use a value of 1.66. the ! +! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! +! here. note that use of the emissivity angle for the flux integration! +! can cause errors of 1 to 4 W/m2 within cloudy layers. ! +! clouds are treated with a random cloud overlap method. ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc + real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & + & secdif + real (kind=kind_phys), dimension(nlay), intent(in) :: delp + + real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld + real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & + & tautot + + real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & + & pklev, pklay + +! --- outputs: + real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb + + real (kind=kind_phys), dimension(0:nlay), intent(out) :: & + & totuflux, totdflux, totuclfl, totdclfl + +! --- locals: + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + + real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & + & clrdrad, toturad, totdrad + + real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & + & trngas, efclrfr, rfdelp + real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc + + real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & + & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & + & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & + & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, & + & clfr, trng, gasu + + integer :: ittot, itgas, ib, ig, k +! +!===> ... begin here +! + do ib = 1, NBANDS + do k = 0, NLAY + toturad(k,ib) = f_zero + totdrad(k,ib) = f_zero + clrurad(k,ib) = f_zero + clrdrad(k,ib) = f_zero + enddo + enddo + + do k = 0, nlay + totuflux(k) = f_zero + totdflux(k) = f_zero + totuclfl(k) = f_zero + totdclfl(k) = f_zero + enddo + +! --- ... loop over all g-points + + do ig = 1, ngptlw + ib = ngb(ig) + + radtotd = f_zero + radclrd = f_zero + +!> -# Downward radiative transfer loop. + + do k = nlay, 1, -1 + +!!\n - clear sky, gases contribution + + odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) + if (odepth <= 0.06) then + atrgas = odepth - 0.5*odepth*odepth + trng = f_one - atrgas + gasfac = rec_6 * odepth + else + tblind = odepth / (bpade + odepth) + itgas = tblint*tblind + 0.5 + trng = exp_tbl(itgas) + atrgas = f_one - trng + gasfac = tfn_tbl(itgas) + odepth = tau_tbl(itgas) + endif + + plfrac = fracs(ig,k) + blay = pklay(ib,k) + + dplnku = pklev(ib,k ) - blay + dplnkd = pklev(ib,k-1) - blay + bbdgas = plfrac * (blay + dplnkd*gasfac) + bbugas = plfrac * (blay + dplnku*gasfac) + gassrcd= bbdgas * atrgas + gassrcu(k)= bbugas * atrgas + trngas(k) = trng + +!!\n - total sky, gases+clouds contribution + + clfr = cldfrc(k) + if (clfr >= eps) then +!!\n - cloudy layer + + odcld = secdif(ib) * taucld(ib,k) + efclrfr(k) = f_one-(f_one - exp(-odcld))*clfr + odtot = odepth + odcld + if (odtot < 0.06) then + totfac = rec_6 * odtot + atrtot = odtot - 0.5*odtot*odtot + else + tblind = odtot / (bpade + odtot) + ittot = tblint*tblind + 0.5 + totfac = tfn_tbl(ittot) + atrtot = f_one - exp_tbl(ittot) + endif + + bbdtot = plfrac * (blay + dplnkd*totfac) + bbutot = plfrac * (blay + dplnku*totfac) + totsrcd= bbdtot * atrtot + totsrcu(k)= bbutot * atrtot + +! --- ... total sky radiance + radtotd = radtotd*trng*efclrfr(k) + gassrcd & + & + clfr*(totsrcd - gassrcd) + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotd = radtotd*trng + gassrcd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + endif ! end if_clfr_block + + enddo ! end do_k_loop + +!> -# Compute spectral emissivity & reflectance, include the +!! contribution of spectrally varying longwave emissivity and +!! reflection from the surface to the upward radiative transfer. + +! note: spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + reflct = f_one - semiss(ib) + rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) + +!> -# Compute total sky radiance. + radtotu = rad0 + reflct*radtotd + toturad(0,ib) = toturad(0,ib) + radtotu + +!> -# Compute clear sky radiance + radclru = rad0 + reflct*radclrd + clrurad(0,ib) = clrurad(0,ib) + radclru + +!> -# Upward radiative transfer loop. + + do k = 1, nlay + clfr = cldfrc(k) + trng = trngas(k) + gasu = gassrcu(k) + + if (clfr >= eps) then +! --- ... cloudy layer + +! --- ... total sky radiance + radtotu = radtotu*trng*efclrfr(k) + gasu & + & + clfr*(totsrcu(k) - gasu) + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotu = radtotu*trng + gasu + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + endif ! end if_clfr_block + + enddo ! end do_k_loop + + enddo ! end do_ig_loop + +!> -# Process longwave output from band for total and clear streams. +!! Calculate upward, downward, and net flux. + + flxfac = wtdiff * fluxfac + + do k = 0, nlay + do ib = 1, nbands + totuflux(k) = totuflux(k) + toturad(k,ib) + totdflux(k) = totdflux(k) + totdrad(k,ib) + totuclfl(k) = totuclfl(k) + clrurad(k,ib) + totdclfl(k) = totdclfl(k) + clrdrad(k,ib) + enddo + + totuflux(k) = totuflux(k) * flxfac + totdflux(k) = totdflux(k) * flxfac + totuclfl(k) = totuclfl(k) * flxfac + totdclfl(k) = totdclfl(k) * flxfac + enddo + +! --- ... calculate net fluxes and heating rates + fnet(0) = totuflux(0) - totdflux(0) + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + fnet(k) = totuflux(k) - totdflux(k) + htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + +!! --- ... optional clear sky heating rates + if ( lhlw0 ) then + fnetc(0) = totuclfl(0) - totdclfl(0) + + do k = 1, nlay + fnetc(k) = totuclfl(k) - totdclfl(k) + htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) + enddo + endif + +!! --- ... optional spectral band heating rates + if ( lhlwb ) then + do ib = 1, nbands + fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac + + do k = 1, nlay + fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac + htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + +! .................................. + end subroutine rtrn +! ---------------------------------- + + +!> This subroutine computes the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere. Clouds are +!! assumed as in maximum-randomly overlaping in a vertical column. +!!\param semiss lw surface emissivity +!!\param delp layer pressure thickness (mb) +!!\param cldfrc layer cloud fraction +!!\param taucld layer cloud opt depth +!!\param tautot total optical depth (gas+aerosols) +!!\param pklay integrated planck func at lay temp +!!\param pklev integrated planck func at lev temp +!!\param fracs planck fractions +!!\param secdif secant of diffusivity angle +!!\param nlay number of vertical layers +!!\param nlp1 number of vertical levels (interfaces) +!!\param totuflux total sky upward flux (\f$w/m^2\f$) +!!\param totdflux total sky downward flux (\f$w/m^2\f$) +!!\param htr total sky heating rate (k/sec or k/day) +!!\param totuclfl clear sky upward flux (\f$w/m^2\f$) +!!\param totdclfl clear sky downward flux (\f$w/m^2\f$) +!!\param htrcl clear sky heating rate (k/sec or k/day) +!!\param htrb spectral band lw heating rate (k/day) +!!\section gen_rtrnmr General Algorithm +!> @{ +! ---------------------------------- + subroutine rtrnmr & + & ( semiss,delp,cldfrc,taucld,tautot,pklay,pklev, &! --- inputs + & fracs,secdif, nlay,nlp1, & + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs: + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the upward/downward radiative fluxes, and heating ! +! rates for both clear or cloudy atmosphere. clouds are assumed as in ! +! maximum-randomly overlaping in a vertical colum. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! semiss - real, lw surface emissivity nbands! +! delp - real, layer pressure thickness (mb) nlay ! +! cldfrc - real, layer cloud fraction 0:nlp1 ! +! taucld - real, layer cloud opt depth nbands,nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! fracs - real, planck fractions ngptlw,nlay! +! secdif - real, secant of diffusivity angle nbands! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels (interfaces) 1 ! +! ! +! outputs: ! +! totuflux- real, total sky upward flux (w/m2) 0:nlay ! +! totdflux- real, total sky downward flux (w/m2) 0:nlay ! +! htr - real, total sky heating rate (k/sec or k/day) nlay ! +! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! +! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! +! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! +! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! +! ! +! module veriables: ! +! ngb - integer, band index for each g-value ngptlw! +! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! +! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! +! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! +! bpade - real, pade approx constant (1/0.278) 1 ! +! wtdiff - real, weight for radiance to flux conversion 1 ! +! ntbl - integer, dimension of look-up tables 1 ! +! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! +! exp_tbl - real, transmittance lookup table 0:ntbl ! +! tfn_tbl - real, tau transition function 0:ntbl ! +! ! +! local variables: ! +! itgas - integer, index for gases contribution look-up table 1 ! +! ittot - integer, index for gases plus clouds look-up table 1 ! +! reflct - real, surface reflectance 1 ! +! atrgas - real, gaseous absorptivity 1 ! +! atrtot - real, gaseous and cloud absorptivity 1 ! +! odcld - real, cloud optical depth 1 ! +! odepth - real, optical depth of gaseous only 1 ! +! odtot - real, optical depth of gas and cloud 1 ! +! gasfac - real, gas-only pade factor, used for planck fn 1 ! +! totfac - real, gas+cld pade factor, used for planck fn 1 ! +! bbdgas - real, gas-only planck function for downward rt 1 ! +! bbugas - real, gas-only planck function for upward rt 1 ! +! bbdtot - real, gas and cloud planck function for downward rt 1 ! +! bbutot - real, gas and cloud planck function for upward rt 1 ! +! gassrcu- real, upwd source radiance due to gas only nlay! +! totsrcu- real, upwd source radiance due to gas + cld nlay! +! gassrcd- real, dnwd source radiance due to gas only 1 ! +! totsrcd- real, dnwd source radiance due to gas + cld 1 ! +! radtotu- real, spectrally summed total sky upwd radiance 1 ! +! radclru- real, spectrally summed clear sky upwd radiance 1 ! +! radtotd- real, spectrally summed total sky dnwd radiance 1 ! +! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! +! toturad- real, total sky upward radiance by layer 0:nlay*nbands! +! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! +! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! +! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! +! fnet - real, net longwave flux (w/m2) 0:nlay ! +! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! +! ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: e. j. mlawer, et al. rrtm_v3.0 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! revision for f90: michael j. iacono; june, 2006 ! +! ! +! this program calculates the upward fluxes, downward fluxes, and ! +! heating rates for an arbitrary clear or cloudy atmosphere. the input ! +! to this program is the atmospheric profile, all Planck function ! +! information, and the cloud fraction by layer. a variable diffusivity! +! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! +! use a value for secdif that varies from 1.50 to 1.80 as a function ! +! of the column water vapor, and other bands use a value of 1.66. the ! +! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! +! here. note that use of the emissivity angle for the flux integration! +! can cause errors of 1 to 4 W/m2 within cloudy layers. ! +! clouds are treated with a maximum-random cloud overlap method. ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(0:nlp1), intent(in) :: cldfrc + real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & + & secdif + real (kind=kind_phys), dimension(nlay), intent(in) :: delp + + real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld + real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & + & tautot + + real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & + & pklev, pklay + +! --- outputs: + real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb + + real (kind=kind_phys), dimension(0:nlay), intent(out) :: & + & totuflux, totdflux, totuclfl, totdclfl + +! --- locals: + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + + real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & + & clrdrad, toturad, totdrad + + real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & + & trngas, trntot, rfdelp + real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc + + real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & + & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & + & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & + & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, rad, & + & totradd, clrradd, totradu, clrradu, fmax, fmin, rat1, rat2,& + & radmod, clfr, trng, trnt, gasu, totu + + integer :: ittot, itgas, ib, ig, k + +! dimensions for cloud overlap adjustment + real (kind=kind_phys), dimension(nlp1) :: faccld1u, faccld2u, & + & facclr1u, facclr2u, faccmb1u, faccmb2u + real (kind=kind_phys), dimension(0:nlay) :: faccld1d, faccld2d, & + & facclr1d, facclr2d, faccmb1d, faccmb2d + + logical :: lstcldu(nlay), lstcldd(nlay) +! +!===> ... begin here +! + do k = 1, nlp1 + faccld1u(k) = f_zero + faccld2u(k) = f_zero + facclr1u(k) = f_zero + facclr2u(k) = f_zero + faccmb1u(k) = f_zero + faccmb2u(k) = f_zero + enddo + + lstcldu(1) = cldfrc(1) > eps + rat1 = f_zero + rat2 = f_zero + + do k = 1, nlay-1 + + lstcldu(k+1) = cldfrc(k+1)>eps .and. cldfrc(k)<=eps + + if (cldfrc(k) > eps) then + +!> -# Setup maximum/random cloud overlap. + + if (cldfrc(k+1) >= cldfrc(k)) then + if (lstcldu(k)) then + if (cldfrc(k) < f_one) then + facclr2u(k+1) = (cldfrc(k+1) - cldfrc(k)) & + & / (f_one - cldfrc(k)) + endif + facclr2u(k) = f_zero + faccld2u(k) = f_zero + else + fmax = max(cldfrc(k), cldfrc(k-1)) + if (cldfrc(k+1) > fmax) then + facclr1u(k+1) = rat2 + facclr2u(k+1) = (cldfrc(k+1) - fmax)/(f_one - fmax) + elseif (cldfrc(k+1) < fmax) then + facclr1u(k+1) = (cldfrc(k+1) - cldfrc(k)) & + & / (cldfrc(k-1) - cldfrc(k)) + else + facclr1u(k+1) = rat2 + endif + endif + + if (facclr1u(k+1)>f_zero .or. facclr2u(k+1)>f_zero) then + rat1 = f_one + rat2 = f_zero + else + rat1 = f_zero + rat2 = f_zero + endif + else + if (lstcldu(k)) then + faccld2u(k+1) = (cldfrc(k) - cldfrc(k+1)) / cldfrc(k) + facclr2u(k) = f_zero + faccld2u(k) = f_zero + else + fmin = min(cldfrc(k), cldfrc(k-1)) + if (cldfrc(k+1) <= fmin) then + faccld1u(k+1) = rat1 + faccld2u(k+1) = (fmin - cldfrc(k+1)) / fmin + else + faccld1u(k+1) = (cldfrc(k) - cldfrc(k+1)) & + & / (cldfrc(k) - fmin) + endif + endif + + if (faccld1u(k+1)>f_zero .or. faccld2u(k+1)>f_zero) then + rat1 = f_zero + rat2 = f_one + else + rat1 = f_zero + rat2 = f_zero + endif + endif + + faccmb1u(k+1) = facclr1u(k+1) * faccld2u(k) * cldfrc(k-1) + faccmb2u(k+1) = faccld1u(k+1) * facclr2u(k) & + & * (f_one - cldfrc(k-1)) + endif + + enddo + + do k = 0, nlay + faccld1d(k) = f_zero + faccld2d(k) = f_zero + facclr1d(k) = f_zero + facclr2d(k) = f_zero + faccmb1d(k) = f_zero + faccmb2d(k) = f_zero + enddo + + lstcldd(nlay) = cldfrc(nlay) > eps + rat1 = f_zero + rat2 = f_zero + + do k = nlay, 2, -1 + + lstcldd(k-1) = cldfrc(k-1) > eps .and. cldfrc(k)<=eps + + if (cldfrc(k) > eps) then + + if (cldfrc(k-1) >= cldfrc(k)) then + if (lstcldd(k)) then + if (cldfrc(k) < f_one) then + facclr2d(k-1) = (cldfrc(k-1) - cldfrc(k)) & + & / (f_one - cldfrc(k)) + endif + + facclr2d(k) = f_zero + faccld2d(k) = f_zero + else + fmax = max(cldfrc(k), cldfrc(k+1)) + + if (cldfrc(k-1) > fmax) then + facclr1d(k-1) = rat2 + facclr2d(k-1) = (cldfrc(k-1) - fmax) / (f_one - fmax) + elseif (cldfrc(k-1) < fmax) then + facclr1d(k-1) = (cldfrc(k-1) - cldfrc(k)) & + & / (cldfrc(k+1) - cldfrc(k)) + else + facclr1d(k-1) = rat2 + endif + endif + + if (facclr1d(k-1)>f_zero .or. facclr2d(k-1)>f_zero) then + rat1 = f_one + rat2 = f_zero + else + rat1 = f_zero + rat2 = f_zero + endif + else + if (lstcldd(k)) then + faccld2d(k-1) = (cldfrc(k) - cldfrc(k-1)) / cldfrc(k) + facclr2d(k) = f_zero + faccld2d(k) = f_zero + else + fmin = min(cldfrc(k), cldfrc(k+1)) + + if (cldfrc(k-1) <= fmin) then + faccld1d(k-1) = rat1 + faccld2d(k-1) = (fmin - cldfrc(k-1)) / fmin + else + faccld1d(k-1) = (cldfrc(k) - cldfrc(k-1)) & + & / (cldfrc(k) - fmin) + endif + endif + + if (faccld1d(k-1)>f_zero .or. faccld2d(k-1)>f_zero) then + rat1 = f_zero + rat2 = f_one + else + rat1 = f_zero + rat2 = f_zero + endif + endif + + faccmb1d(k-1) = facclr1d(k-1) * faccld2d(k) * cldfrc(k+1) + faccmb2d(k-1) = faccld1d(k-1) * facclr2d(k) & + & * (f_one - cldfrc(k+1)) + endif + + enddo + +!> -# Initialize for radiative transfer + + do ib = 1, NBANDS + do k = 0, NLAY + toturad(k,ib) = f_zero + totdrad(k,ib) = f_zero + clrurad(k,ib) = f_zero + clrdrad(k,ib) = f_zero + enddo + enddo + + do k = 0, nlay + totuflux(k) = f_zero + totdflux(k) = f_zero + totuclfl(k) = f_zero + totdclfl(k) = f_zero + enddo + +! --- ... loop over all g-points + + do ig = 1, ngptlw + ib = ngb(ig) + + radtotd = f_zero + radclrd = f_zero + +!> -# Downward radiative transfer loop: + + do k = nlay, 1, -1 + +! --- ... clear sky, gases contribution + + odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) + if (odepth <= 0.06) then + atrgas = odepth - 0.5*odepth*odepth + trng = f_one - atrgas + gasfac = rec_6 * odepth + else + tblind = odepth / (bpade + odepth) + itgas = tblint*tblind + 0.5 + trng = exp_tbl(itgas) + atrgas = f_one - trng + gasfac = tfn_tbl(itgas) + odepth = tau_tbl(itgas) + endif + + plfrac = fracs(ig,k) + blay = pklay(ib,k) + + dplnku = pklev(ib,k ) - blay + dplnkd = pklev(ib,k-1) - blay + bbdgas = plfrac * (blay + dplnkd*gasfac) + bbugas = plfrac * (blay + dplnku*gasfac) + gassrcd = bbdgas * atrgas + gassrcu(k)= bbugas * atrgas + trngas(k) = trng + +! --- ... total sky, gases+clouds contribution + + clfr = cldfrc(k) + if (lstcldd(k)) then + totradd = clfr * radtotd + clrradd = radtotd - totradd + rad = f_zero + endif + + if (clfr >= eps) then +!> - cloudy layer + + odcld = secdif(ib) * taucld(ib,k) + odtot = odepth + odcld + if (odtot < 0.06) then + totfac = rec_6 * odtot + atrtot = odtot - 0.5*odtot*odtot + trnt = f_one - atrtot + else + tblind = odtot / (bpade + odtot) + ittot = tblint*tblind + 0.5 + totfac = tfn_tbl(ittot) + trnt = exp_tbl(ittot) + atrtot = f_one - trnt + endif + + bbdtot = plfrac * (blay + dplnkd*totfac) + bbutot = plfrac * (blay + dplnku*totfac) + totsrcd = bbdtot * atrtot + totsrcu(k)= bbutot * atrtot + trntot(k) = trnt + + totradd = totradd*trnt + clfr*totsrcd + clrradd = clrradd*trng + (f_one - clfr)*gassrcd + +!> - total sky radiance + radtotd = totradd + clrradd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +!> - clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + radmod = rad*(facclr1d(k-1)*trng + faccld1d(k-1)*trnt) & + & - faccmb1d(k-1)*gassrcd + faccmb2d(k-1)*totsrcd + + rad = -radmod + facclr2d(k-1)*(clrradd + radmod) & + & - faccld2d(k-1)*(totradd - radmod) + totradd = totradd + rad + clrradd = clrradd - rad + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotd = radtotd*trng + gassrcd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + endif ! end if_clfr_block + + enddo ! end do_k_loop + +!> -# Compute spectral emissivity & reflectance, include the +!! contribution of spectrally varying longwave emissivity and +!! reflection from the surface to the upward radiative transfer. + +! note: spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + reflct = f_one - semiss(ib) + rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) + +!> -# Compute total sky radiance. + radtotu = rad0 + reflct*radtotd + toturad(0,ib) = toturad(0,ib) + radtotu + +!> -# Compute clear sky radiance. + radclru = rad0 + reflct*radclrd + clrurad(0,ib) = clrurad(0,ib) + radclru + +!> -# Upward radiative transfer loop: + + do k = 1, nlay + + clfr = cldfrc(k) + trng = trngas(k) + gasu = gassrcu(k) + + if (lstcldu(k)) then + totradu = clfr * radtotu + clrradu = radtotu - totradu + rad = f_zero + endif + + if (clfr >= eps) then +!> - cloudy layer radiance + + trnt = trntot(k) + totu = totsrcu(k) + totradu = totradu*trnt + clfr*totu + clrradu = clrradu*trng + (f_one - clfr)*gasu + +!> - total sky radiance + radtotu = totradu + clrradu + toturad(k,ib) = toturad(k,ib) + radtotu + +!> - clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + radmod = rad*(facclr1u(k+1)*trng + faccld1u(k+1)*trnt) & + & - faccmb1u(k+1)*gasu + faccmb2u(k+1)*totu + rad = -radmod + facclr2u(k+1)*(clrradu + radmod) & + & - faccld2u(k+1)*(totradu - radmod) + totradu = totradu + rad + clrradu = clrradu - rad + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotu = radtotu*trng + gasu + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + endif ! end if_clfr_block + + enddo ! end do_k_loop + + enddo ! end do_ig_loop + +!> -# Process longwave output from band for total and clear streams. +!! calculate upward, downward, and net flux. + + flxfac = wtdiff * fluxfac + + do k = 0, nlay + do ib = 1, nbands + totuflux(k) = totuflux(k) + toturad(k,ib) + totdflux(k) = totdflux(k) + totdrad(k,ib) + totuclfl(k) = totuclfl(k) + clrurad(k,ib) + totdclfl(k) = totdclfl(k) + clrdrad(k,ib) + enddo + + totuflux(k) = totuflux(k) * flxfac + totdflux(k) = totdflux(k) * flxfac + totuclfl(k) = totuclfl(k) * flxfac + totdclfl(k) = totdclfl(k) * flxfac + enddo + +! --- ... calculate net fluxes and heating rates + fnet(0) = totuflux(0) - totdflux(0) + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + fnet(k) = totuflux(k) - totdflux(k) + htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + +!! --- ... optional clear sky heating rates + if ( lhlw0 ) then + fnetc(0) = totuclfl(0) - totdclfl(0) + + do k = 1, nlay + fnetc(k) = totuclfl(k) - totdclfl(k) + htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) + enddo + endif + +!! --- ... optional spectral band heating rates + if ( lhlwb ) then + do ib = 1, nbands + fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac + + do k = 1, nlay + fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac + htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + +! ................................. + end subroutine rtrnmr +! --------------------------------- +!> @} + + +!> This subroutine computes the upward/downward radiative fluxes, and +!! heating rates for both clear or cloudy atmosphere.Clouds are treated +!! with the mcica stochastic approach. +!!\param semiss lw surface emissivity +!!\param delp layer pressure thickness (mb) +!!\param cldfmc layer cloud fraction (sub-column) +!!\param taucld layer cloud opt depth +!!\param tautot total optical depth (gas+aerosols) +!!\param pklay integrated planck func at lay temp +!!\param pklev integrated planck func at lev temp +!!\param fracs planck fractions +!!\param secdif secant of diffusivity angle +!!\param nlay number of vertical layers +!!\param nlp1 number of vertical levels (interfaces) +!!\param totuflux total sky upward flux \f$(w/m^2)\f$ +!!\param totdflux total sky downward flux \f$(w/m^2)\f$ +!!\param htr total sky heating rate (k/sec or k/day) +!!\param totuclfl clear sky upward flux \f$(w/m^2)\f$ +!!\param totdclfl clear sky downward flux \f$(w/m^2)\f$ +!!\param htrcl clear sky heating rate (k/sec or k/day) +!!\param htrb spectral band lw heating rate (k/day) +!!\section gen_rtrnmc General Algorithm +!> @{ +! --------------------------------- + subroutine rtrnmc & + & ( semiss,delp,cldfmc,taucld,tautot,pklay,pklev, & ! --- inputs: + & fracs,secdif, nlay,nlp1, & + & totuflux,totdflux,htr, totuclfl,totdclfl,htrcl, htrb & ! --- outputs: + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute the upward/downward radiative fluxes, and heating ! +! rates for both clear or cloudy atmosphere. clouds are treated with ! +! the mcica stochastic approach. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! semiss - real, lw surface emissivity nbands! +! delp - real, layer pressure thickness (mb) nlay ! +! cldfmc - real, layer cloud fraction (sub-column) ngptlw*nlay! +! taucld - real, layer cloud opt depth nbands*nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw*nlay! +! pklay - real, integrated planck func at lay temp nbands*0:nlay! +! pklev - real, integrated planck func at lev temp nbands*0:nlay! +! fracs - real, planck fractions ngptlw*nlay! +! secdif - real, secant of diffusivity angle nbands! +! nlay - integer, number of vertical layers 1 ! +! nlp1 - integer, number of vertical levels (interfaces) 1 ! +! ! +! outputs: ! +! totuflux- real, total sky upward flux (w/m2) 0:nlay ! +! totdflux- real, total sky downward flux (w/m2) 0:nlay ! +! htr - real, total sky heating rate (k/sec or k/day) nlay ! +! totuclfl- real, clear sky upward flux (w/m2) 0:nlay ! +! totdclfl- real, clear sky downward flux (w/m2) 0:nlay ! +! htrcl - real, clear sky heating rate (k/sec or k/day) nlay ! +! htrb - real, spectral band lw heating rate (k/day) nlay*nbands! +! ! +! module veriables: ! +! ngb - integer, band index for each g-value ngptlw! +! fluxfac - real, conversion factor for fluxes (pi*2.e4) 1 ! +! heatfac - real, conversion factor for heating rates (g/cp*1e-2) 1 ! +! tblint - real, conversion factor for look-up tbl (float(ntbl) 1 ! +! bpade - real, pade approx constant (1/0.278) 1 ! +! wtdiff - real, weight for radiance to flux conversion 1 ! +! ntbl - integer, dimension of look-up tables 1 ! +! tau_tbl - real, clr-sky opt dep lookup table 0:ntbl ! +! exp_tbl - real, transmittance lookup table 0:ntbl ! +! tfn_tbl - real, tau transition function 0:ntbl ! +! ! +! local variables: ! +! itgas - integer, index for gases contribution look-up table 1 ! +! ittot - integer, index for gases plus clouds look-up table 1 ! +! reflct - real, surface reflectance 1 ! +! atrgas - real, gaseous absorptivity 1 ! +! atrtot - real, gaseous and cloud absorptivity 1 ! +! odcld - real, cloud optical depth 1 ! +! efclrfr- real, effective clear sky fraction (1-efcldfr) nlay! +! odepth - real, optical depth of gaseous only 1 ! +! odtot - real, optical depth of gas and cloud 1 ! +! gasfac - real, gas-only pade factor, used for planck function 1 ! +! totfac - real, gas and cloud pade factor, used for planck fn 1 ! +! bbdgas - real, gas-only planck function for downward rt 1 ! +! bbugas - real, gas-only planck function for upward rt 1 ! +! bbdtot - real, gas and cloud planck function for downward rt 1 ! +! bbutot - real, gas and cloud planck function for upward rt 1 ! +! gassrcu- real, upwd source radiance due to gas nlay! +! totsrcu- real, upwd source radiance due to gas+cld nlay! +! gassrcd- real, dnwd source radiance due to gas 1 ! +! totsrcd- real, dnwd source radiance due to gas+cld 1 ! +! radtotu- real, spectrally summed total sky upwd radiance 1 ! +! radclru- real, spectrally summed clear sky upwd radiance 1 ! +! radtotd- real, spectrally summed total sky dnwd radiance 1 ! +! radclrd- real, spectrally summed clear sky dnwd radiance 1 ! +! toturad- real, total sky upward radiance by layer 0:nlay*nbands! +! clrurad- real, clear sky upward radiance by layer 0:nlay*nbands! +! totdrad- real, total sky downward radiance by layer 0:nlay*nbands! +! clrdrad- real, clear sky downward radiance by layer 0:nlay*nbands! +! fnet - real, net longwave flux (w/m2) 0:nlay ! +! fnetc - real, clear sky net longwave flux (w/m2) 0:nlay ! +! ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! original version: e. j. mlawer, et al. rrtm_v3.0 ! +! revision for gcms: michael j. iacono; october, 2002 ! +! revision for f90: michael j. iacono; june, 2006 ! +! ! +! this program calculates the upward fluxes, downward fluxes, and ! +! heating rates for an arbitrary clear or cloudy atmosphere. the input ! +! to this program is the atmospheric profile, all Planck function ! +! information, and the cloud fraction by layer. a variable diffusivity! +! angle (secdif) is used for the angle integration. bands 2-3 and 5-9 ! +! use a value for secdif that varies from 1.50 to 1.80 as a function ! +! of the column water vapor, and other bands use a value of 1.66. the ! +! gaussian weight appropriate to this angle (wtdiff=0.5) is applied ! +! here. note that use of the emissivity angle for the flux integration! +! can cause errors of 1 to 4 W/m2 within cloudy layers. ! +! clouds are treated with the mcica stochastic approach and ! +! maximum-random cloud overlap. ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nbands), intent(in) :: semiss, & + & secdif + real (kind=kind_phys), dimension(nlay), intent(in) :: delp + + real (kind=kind_phys), dimension(nbands,nlay),intent(in):: taucld + real (kind=kind_phys), dimension(ngptlw,nlay),intent(in):: fracs, & + & tautot, cldfmc + + real (kind=kind_phys), dimension(nbands,0:nlay), intent(in) :: & + & pklev, pklay + +! --- outputs: + real (kind=kind_phys), dimension(nlay), intent(out) :: htr, htrcl + + real (kind=kind_phys), dimension(nlay,nbands),intent(out) :: htrb + + real (kind=kind_phys), dimension(0:nlay), intent(out) :: & + & totuflux, totdflux, totuclfl, totdclfl + +! --- locals: + real (kind=kind_phys), parameter :: rec_6 = 0.166667 + + real (kind=kind_phys), dimension(0:nlay,nbands) :: clrurad, & + & clrdrad, toturad, totdrad + + real (kind=kind_phys), dimension(nlay) :: gassrcu, totsrcu, & + & trngas, efclrfr, rfdelp + real (kind=kind_phys), dimension(0:nlay) :: fnet, fnetc + + real (kind=kind_phys) :: totsrcd, gassrcd, tblind, odepth, odtot, & + & odcld, atrtot, atrgas, reflct, totfac, gasfac, flxfac, & + & plfrac, blay, bbdgas, bbdtot, bbugas, bbutot, dplnku, & + & dplnkd, radtotu, radclru, radtotd, radclrd, rad0, & + & clfm, trng, gasu + + integer :: ittot, itgas, ib, ig, k +! +!===> ... begin here +! + do ib = 1, NBANDS + do k = 0, NLAY + toturad(k,ib) = f_zero + totdrad(k,ib) = f_zero + clrurad(k,ib) = f_zero + clrdrad(k,ib) = f_zero + enddo + enddo + + do k = 0, nlay + totuflux(k) = f_zero + totdflux(k) = f_zero + totuclfl(k) = f_zero + totdclfl(k) = f_zero + enddo + +! --- ... loop over all g-points + + do ig = 1, ngptlw + ib = ngb(ig) + + radtotd = f_zero + radclrd = f_zero + +!> -# Downward radiative transfer loop. +!!\n - Clear sky, gases contribution +!!\n - Total sky, gases+clouds contribution +!!\n - Cloudy layer +!!\n - Total sky radiance +!!\n - Clear sky radiance + + do k = nlay, 1, -1 + +! --- ... clear sky, gases contribution + + odepth = max( f_zero, secdif(ib)*tautot(ig,k) ) + if (odepth <= 0.06) then + atrgas = odepth - 0.5*odepth*odepth + trng = f_one - atrgas + gasfac = rec_6 * odepth + else + tblind = odepth / (bpade + odepth) + itgas = tblint*tblind + 0.5 + trng = exp_tbl(itgas) + atrgas = f_one - trng + gasfac = tfn_tbl(itgas) + odepth = tau_tbl(itgas) + endif + + plfrac = fracs(ig,k) + blay = pklay(ib,k) + + dplnku = pklev(ib,k ) - blay + dplnkd = pklev(ib,k-1) - blay + bbdgas = plfrac * (blay + dplnkd*gasfac) + bbugas = plfrac * (blay + dplnku*gasfac) + gassrcd= bbdgas * atrgas + gassrcu(k)= bbugas * atrgas + trngas(k) = trng + +! --- ... total sky, gases+clouds contribution + + clfm = cldfmc(ig,k) + if (clfm >= eps) then +! --- ... cloudy layer + + odcld = secdif(ib) * taucld(ib,k) + efclrfr(k) = f_one - (f_one - exp(-odcld))*clfm + odtot = odepth + odcld + if (odtot < 0.06) then + totfac = rec_6 * odtot + atrtot = odtot - 0.5*odtot*odtot + else + tblind = odtot / (bpade + odtot) + ittot = tblint*tblind + 0.5 + totfac = tfn_tbl(ittot) + atrtot = f_one - exp_tbl(ittot) + endif + + bbdtot = plfrac * (blay + dplnkd*totfac) + bbutot = plfrac * (blay + dplnku*totfac) + totsrcd= bbdtot * atrtot + totsrcu(k)= bbutot * atrtot + +! --- ... total sky radiance + radtotd = radtotd*trng*efclrfr(k) + gassrcd & + & + clfm*(totsrcd - gassrcd) + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotd = radtotd*trng + gassrcd + totdrad(k-1,ib) = totdrad(k-1,ib) + radtotd + +! --- ... clear sky radiance + radclrd = radclrd*trng + gassrcd + clrdrad(k-1,ib) = clrdrad(k-1,ib) + radclrd + + endif ! end if_clfm_block + + enddo ! end do_k_loop + +!> -# Compute spectral emissivity & reflectance, include the +!! contribution of spectrally varying longwave emissivity and +!! reflection from the surface to the upward radiative transfer. + +! note: spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. + + reflct = f_one - semiss(ib) + rad0 = semiss(ib) * fracs(ig,1) * pklay(ib,0) + +!> -# Compute total sky radiance + radtotu = rad0 + reflct*radtotd + toturad(0,ib) = toturad(0,ib) + radtotu + +!> -# Compute clear sky radiance + radclru = rad0 + reflct*radclrd + clrurad(0,ib) = clrurad(0,ib) + radclru + +!> -# Upward radiative transfer loop +!!\n - Compute total sky radiance +!!\n - Compute clear sky radiance + +! toturad holds summed radiance for total sky stream +! clrurad holds summed radiance for clear sky stream + + do k = 1, nlay + clfm = cldfmc(ig,k) + trng = trngas(k) + gasu = gassrcu(k) + + if (clfm > eps) then +! --- ... cloudy layer + +! --- ... total sky radiance + radtotu = radtotu*trng*efclrfr(k) + gasu & + & + clfm*(totsrcu(k) - gasu) + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + else +! --- ... clear layer + +! --- ... total sky radiance + radtotu = radtotu*trng + gasu + toturad(k,ib) = toturad(k,ib) + radtotu + +! --- ... clear sky radiance + radclru = radclru*trng + gasu + clrurad(k,ib) = clrurad(k,ib) + radclru + + endif ! end if_clfm_block + + enddo ! end do_k_loop + + enddo ! end do_ig_loop + +!> -# Process longwave output from band for total and clear streams. +!! Calculate upward, downward, and net flux. + + flxfac = wtdiff * fluxfac + + do k = 0, nlay + do ib = 1, nbands + totuflux(k) = totuflux(k) + toturad(k,ib) + totdflux(k) = totdflux(k) + totdrad(k,ib) + totuclfl(k) = totuclfl(k) + clrurad(k,ib) + totdclfl(k) = totdclfl(k) + clrdrad(k,ib) + enddo + + totuflux(k) = totuflux(k) * flxfac + totdflux(k) = totdflux(k) * flxfac + totuclfl(k) = totuclfl(k) * flxfac + totdclfl(k) = totdclfl(k) * flxfac + enddo + +! --- ... calculate net fluxes and heating rates + fnet(0) = totuflux(0) - totdflux(0) + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + fnet(k) = totuflux(k) - totdflux(k) + htr (k) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + +!! --- ... optional clear sky heating rates + if ( lhlw0 ) then + fnetc(0) = totuclfl(0) - totdclfl(0) + + do k = 1, nlay + fnetc(k) = totuclfl(k) - totdclfl(k) + htrcl(k) = (fnetc(k-1) - fnetc(k)) * rfdelp(k) + enddo + endif + +!! --- ... optional spectral band heating rates + if ( lhlwb ) then + do ib = 1, nbands + fnet(0) = (toturad(0,ib) - totdrad(0,ib)) * flxfac + + do k = 1, nlay + fnet(k) = (toturad(k,ib) - totdrad(k,ib)) * flxfac + htrb(k,ib) = (fnet(k-1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + +! .................................. + end subroutine rtrnmc +! ---------------------------------- +!> @} + +!> This subroutine contains optical depths developed for the rapid +!! radiative transfer model. +!!\brief This file contains the subroutines taugbn (where n goes from +!! 1 to 16). taugbn calculates the optical depths and planck fractions +!! per g-value and layer for band n. +!!\param laytrop tropopause layer index (unitless) layer at +!! which switch is made for key species +!!\param pavel layer pressures (mb) +!!\param coldry column amount for dry air \f$(mol/cm^2)\f$ +!!\param colamt column amounts of h2o, co2, o3, n2o, ch4,o2, +!! co \f$(mol/cm^2)\f$ +!!\param colbrd column amount of broadening gases +!!\param wx cross-section amounts \f$(mol/cm^2)\f$ +!!\param tauaer aerosol optical depth +!!\param rfrate reference ratios of binary species parameter +!!\n (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4, +!! 5-n2o/co2,6-o3/co2 +!!\n (:,:,n)n=1,2: the rates of ref press at the 2 +!! sides of the layer +!!\param facij factors multiply the reference ks, i,j of 0/1 +!! for lower/higher of the 2 appropriate +!! temperatures and altitudes +!!\param jp index of lower reference pressure +!!\param jt, jt1 indices of lower reference temperatures for +!! pressure levels jp and jp+1, respectively +!!\param selffac scale factor for water vapor self-continuum +!! equals (water vapor density)/(atmospheric +!! density at 296k and 1013 mb) +!!\param selffrac factor for temperature interpolation of +!! reference water vapor self-continuum data +!!\param indself index of lower reference temperature for the +!! self-continuum interpolation +!!\param forfac scale factor for w. v. foreign-continuum +!!\param forfrac factor for temperature interpolation of +!! reference w.v. foreign-continuum data +!!\param indfor index of lower reference temperature for the +!! foreign-continuum interpolation +!!\param minorfrac factor for minor gases +!!\param scaleminor,scaleminorn2 scale factors for minor gases +!!\param indminor index of lower reference temperature for +!! minor gases +!!\param nlay total number of layers +!!\param fracs planck fractions +!!\param tautot total optical depth (gas+aerosols) +! ---------------------------------- + subroutine taumol & + & ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, & ! --- inputs + & rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, & + & selffac,selffrac,indself,forfac,forfrac,indfor, & + & minorfrac,scaleminor,scaleminorn2,indminor, & + & nlay, & + & fracs, tautot & ! --- outputs + & ) + +! ************ original subprogram description *************** ! +! ! +! optical depths developed for the ! +! ! +! rapid radiative transfer model (rrtm) ! +! ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! eli j. mlawer ! +! jennifer delamere ! +! steven j. taubman ! +! shepard a. clough ! +! ! +! email: mlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: karen cady-pereira, patrick d. brown, ! +! michael j. iacono, ronald e. farren, luke chen, ! +! robert bergstrom. ! +! ! +! revision for g-point reduction: michael j. iacono; aer, inc. ! +! ! +! taumol ! +! ! +! this file contains the subroutines taugbn (where n goes from ! +! 1 to 16). taugbn calculates the optical depths and planck ! +! fractions per g-value and layer for band n. ! +! ! +! ******************************************************************* ! +! ================== program usage description ================== ! +! ! +! call taumol ! +! inputs: ! +! ( laytrop,pavel,coldry,colamt,colbrd,wx,tauaer, ! +! rfrate,fac00,fac01,fac10,fac11,jp,jt,jt1, ! +! selffac,selffrac,indself,forfac,forfrac,indfor, ! +! minorfrac,scaleminor,scaleminorn2,indminor, ! +! nlay, ! +! outputs: ! +! fracs, tautot ) ! +! ! +! subprograms called: taugb## (## = 01 -16) ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! laytrop - integer, tropopause layer index (unitless) 1 ! +! layer at which switch is made for key species ! +! pavel - real, layer pressures (mb) nlay ! +! coldry - real, column amount for dry air (mol/cm2) nlay ! +! colamt - real, column amounts of h2o, co2, o3, n2o, ch4, ! +! o2, co (mol/cm**2) nlay*maxgas! +! colbrd - real, column amount of broadening gases nlay ! +! wx - real, cross-section amounts(mol/cm2) nlay*maxxsec! +! tauaer - real, aerosol optical depth nbands*nlay ! +! rfrate - real, reference ratios of binary species parameter ! +! (:,m,:)m=1-h2o/co2,2-h2o/o3,3-h2o/n2o,4-h2o/ch4,5-n2o/co2,6-o3/co2! +! (:,:,n)n=1,2: the rates of ref press at the 2 sides of the layer ! +! nlay*nrates*2! +! facij - real, factors multiply the reference ks, i,j of 0/1 ! +! for lower/higher of the 2 appropriate temperatures ! +! and altitudes nlay ! +! jp - real, index of lower reference pressure nlay ! +! jt, jt1 - real, indices of lower reference temperatures nlay ! +! for pressure levels jp and jp+1, respectively ! +! selffac - real, scale factor for water vapor self-continuum ! +! equals (water vapor density)/(atmospheric density ! +! at 296k and 1013 mb) nlay ! +! selffrac - real, factor for temperature interpolation of ! +! reference water vapor self-continuum data nlay ! +! indself - integer, index of lower reference temperature for ! +! the self-continuum interpolation nlay ! +! forfac - real, scale factor for w. v. foreign-continuum nlay ! +! forfrac - real, factor for temperature interpolation of ! +! reference w.v. foreign-continuum data nlay ! +! indfor - integer, index of lower reference temperature for ! +! the foreign-continuum interpolation nlay ! +! minorfrac - real, factor for minor gases nlay ! +! scaleminor,scaleminorn2 ! +! - real, scale factors for minor gases nlay ! +! indminor - integer, index of lower reference temperature for ! +! minor gases nlay ! +! nlay - integer, total number of layers 1 ! +! ! +! outputs: ! +! fracs - real, planck fractions ngptlw,nlay! +! tautot - real, total optical depth (gas+aerosols) ngptlw,nlay! +! ! +! internal variables: ! +! ng## - integer, number of g-values in band ## (##=01-16) 1 ! +! nspa - integer, for lower atmosphere, the number of ref ! +! atmos, each has different relative amounts of the ! +! key species for the band nbands! +! nspb - integer, same but for upper atmosphere nbands! +! absa - real, k-values for lower ref atmospheres (no w.v. ! +! self-continuum) (cm**2/molecule) nspa(##)*5*13*ng##! +! absb - real, k-values for high ref atmospheres (all sources) ! +! (cm**2/molecule) nspb(##)*5*13:59*ng##! +! ka_m'mgas'- real, k-values for low ref atmospheres minor species ! +! (cm**2/molecule) mmn##*ng##! +! kb_m'mgas'- real, k-values for high ref atmospheres minor species ! +! (cm**2/molecule) mmn##*ng##! +! selfref - real, k-values for w.v. self-continuum for ref atmos ! +! used below laytrop (cm**2/mol) 10*ng##! +! forref - real, k-values for w.v. foreign-continuum for ref atmos +! used below/above laytrop (cm**2/mol) 4*ng##! +! ! +! ****************************************************************** ! + +! --- inputs: + integer, intent(in) :: nlay, laytrop + + integer, dimension(nlay), intent(in) :: jp, jt, jt1, indself, & + & indfor, indminor + + real (kind=kind_phys), dimension(nlay), intent(in) :: pavel, & + & coldry, colbrd, fac00, fac01, fac10, fac11, selffac, & + & selffrac, forfac, forfrac, minorfrac, scaleminor, & + & scaleminorn2 + + real (kind=kind_phys), dimension(nlay,maxgas), intent(in):: colamt + real (kind=kind_phys), dimension(nlay,maxxsec),intent(in):: wx + + real (kind=kind_phys), dimension(nbands,nlay), intent(in):: tauaer + + real (kind=kind_phys), dimension(nlay,nrates,2), intent(in) :: & + & rfrate + +! --- outputs: + real (kind=kind_phys), dimension(ngptlw,nlay), intent(out) :: & + & fracs, tautot + +! --- locals + real (kind=kind_phys), dimension(ngptlw,nlay) :: taug + + integer :: ib, ig, k +! +!===> ... begin here +! + call taugb01 + call taugb02 + call taugb03 + call taugb04 + call taugb05 + call taugb06 + call taugb07 + call taugb08 + call taugb09 + call taugb10 + call taugb11 + call taugb12 + call taugb13 + call taugb14 + call taugb15 + call taugb16 + +! --- combine gaseous and aerosol optical depths + + do ig = 1, ngptlw + ib = ngb(ig) + + do k = 1, nlay + tautot(ig,k) = taug(ig,k) + tauaer(ib,k) + enddo + enddo + +! ================= + contains +! ================= + +!> band 1: 10-350 cm-1 (low key - h2o; low minor - n2); +!! (high key - h2o; high minor - n2) +! ---------------------------------- + subroutine taugb01 +! .................................. + +! ------------------------------------------------------------------ ! +! written by eli j. mlawer, atmospheric & environmental research. ! +! revised by michael j. iacono, atmospheric & environmental research. ! +! ! +! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) ! +! (high key - h2o; high minor - n2) ! +! ! +! compute the optical depth by interpolating in ln(pressure) and ! +! temperature. below laytrop, the water vapor self-continuum and ! +! foreign continuum is interpolated (in temperature) separately. ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb01 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: pp, corradj, scalen2, tauself, taufor, & + & taun2 +! +!===> ... begin here +! +! --- minor gas mapping levels: +! lower - n2, p = 142.5490 mbar, t = 215.70 k +! upper - n2, p = 142.5490 mbar, t = 215.70 k + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(1) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(1) + 1 + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + + pp = pavel(k) + scalen2 = colbrd(k) * scaleminorn2(k) + if (pp < 250.0) then + corradj = f_one - 0.15 * (250.0-pp) / 154.4 + else + corradj = f_one + endif + + do ig = 1, ng01 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + taun2 = scalen2 * (ka_mn2(ig,indm) + minorfrac(k) & + & * (ka_mn2(ig,indmp) - ka_mn2(ig,indm))) + + taug(ig,k) = corradj * (colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + taun2) + + fracs(ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(1) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(1) + 1 + indf = indfor(k) + indm = indminor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + indmp = indm + 1 + + scalen2 = colbrd(k) * scaleminorn2(k) + corradj = f_one - 0.15 * (pavel(k) / 95.6) + + do ig = 1, ng01 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + taun2 = scalen2 * (kb_mn2(ig,indm) + minorfrac(k) & + & * (kb_mn2(ig,indmp) - kb_mn2(ig,indm))) + + taug(ig,k) = corradj * (colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + taun2) + + fracs(ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb01 +! ---------------------------------- + +!> Band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! ---------------------------------- + subroutine taugb02 +! .................................. + +! ------------------------------------------------------------------ ! +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb02 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & ig + + real (kind=kind_phys) :: corradj, tauself, taufor +! +!===> ... begin here +! +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(2) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(2) + 1 + inds = indself(k) + indf = indfor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + + corradj = f_one - 0.05 * (pavel(k) - 100.0) / 900.0 + + do ig = 1, ng02 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns02+ig,k) = corradj * (colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor) + + fracs(ns02+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(2) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(2) + 1 + indf = indfor(k) + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + + do ig = 1, ng02 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns02+ig,k) = colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + + fracs(ns02+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb02 +! ---------------------------------- + +!> Band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o); +!! (high key - h2o,co2; high minor - n2o) +! ---------------------------------- + subroutine taugb03 +! .................................. + +! ------------------------------------------------------------------ ! +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) ! +! (high key - h2o,co2; high minor - n2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb03 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jmn2o, jmn2op, & + & id001, id011, id101, id111, id201, id211, jpl, jplp, & + & ig, js, js1 + + real (kind=kind_phys) :: absn2o, ratn2o, adjfac, adjcoln2o, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & tau_major, tau_major1, tauself, taufor, n2om1, n2om2, & + & p, p4, fk0, fk1, fk2 +! +!===> ... begin here +! +! --- ... minor gas mapping levels: +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + + refrat_planck_a = chi_mls(1,9)/chi_mls(2,9) ! P = 212.725 mb + refrat_planck_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb + refrat_m_a = chi_mls(1,3)/chi_mls(2,3) ! P = 706.270 mb + refrat_m_b = chi_mls(1,13)/chi_mls(2,13) ! P = 95.58 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(3) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(3) + js1 + + speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,2) + specparm_mn2o = colamt(k,1) / speccomb_mn2o + specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus) + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jmn2op= jmn2o+ 1 + jplp = jpl + 1 + +! --- ... in atmospheres where the amount of n2O is too great to be considered +! a minor species, adjust the column amount of n2O by an empirical factor +! to obtain the proper contribution. + + p = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / p + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o - 0.5)**0.65 + adjcoln2o = adjfac * p + else + adjcoln2o = colamt(k,4) + endif + + if (specparm < 0.125) then + p = fs - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + else if (specparm > 0.875) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk0 = f_one - fs + fk1 = fs + fk2 = f_zero + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk0*fac00(k) + fac100 = fk1*fac00(k) + fac200 = fk2*fac00(k) + fac010 = fk0*fac10(k) + fac110 = fk1*fac10(k) + fac210 = fk2*fac10(k) + + if (specparm1 < 0.125) then + p = fs1 - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk0 = f_one - fs1 + fk1 = fs1 + fk2 = f_zero + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk0*fac01(k) + fac101 = fk1*fac01(k) + fac201 = fk2*fac01(k) + fac011 = fk0*fac11(k) + fac111 = fk1*fac11(k) + fac211 = fk2*fac11(k) + + do ig = 1, ng03 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm)) + n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp)) + absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) + + tau_major = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) + + tau_major1 = speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) + + taug(ns03+ig,k) = tau_major + tau_major1 & + & + tauself + taufor + adjcoln2o*absn2o + + fracs(ns03+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo ! end do_k_loop + enddo ! end do_ig_loop + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 4.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(3) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 4.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(3) + js1 + + speccomb_mn2o = colamt(k,1) + refrat_m_b*colamt(k,2) + specparm_mn2o = colamt(k,1) / speccomb_mn2o + specmult_mn2o = 4.0 * min(specparm_mn2o, oneminus) + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_b*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 4.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + indf = indfor(k) + indm = indminor(k) + indfp = indf + 1 + indmp = indm + 1 + jmn2op= jmn2o+ 1 + jplp = jpl + 1 + + id000 = ind0 + id010 = ind0 + 5 + id100 = ind0 + 1 + id110 = ind0 + 6 + id001 = ind1 + id011 = ind1 + 5 + id101 = ind1 + 1 + id111 = ind1 + 6 + +! --- ... in atmospheres where the amount of n2o is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + + p = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / p + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o - 0.5)**0.65 + adjcoln2o = adjfac * p + else + adjcoln2o = colamt(k,4) + endif + + fk0 = f_one - fs + fk1 = fs + fac000 = fk0*fac00(k) + fac010 = fk0*fac10(k) + fac100 = fk1*fac00(k) + fac110 = fk1*fac10(k) + + fk0 = f_one - fs1 + fk1 = fs1 + fac001 = fk0*fac01(k) + fac011 = fk0*fac11(k) + fac101 = fk1*fac01(k) + fac111 = fk1*fac11(k) + + do ig = 1, ng03 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2om1 = kb_mn2o(ig,jmn2o,indm) + fmn2o & + & * (kb_mn2o(ig,jmn2op,indm) - kb_mn2o(ig,jmn2o,indm)) + n2om2 = kb_mn2o(ig,jmn2o,indmp) + fmn2o & + & * (kb_mn2o(ig,jmn2op,indmp) - kb_mn2o(ig,jmn2o,indmp)) + absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) + + tau_major = speccomb & + & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & + & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) + + tau_major1 = speccomb1 & + & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & + & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) + + taug(ns03+ig,k) = tau_major + tau_major1 & + & + taufor + adjcoln2o*absn2o + + fracs(ns03+ig,k) = fracrefb(ig,jpl) + fpl & + & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) + enddo + enddo + +! .................................. + end subroutine taugb03 +! ---------------------------------- + +!> Band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) +! ---------------------------------- + subroutine taugb04 +! .................................. + +! ------------------------------------------------------------------ ! +! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb04 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, & + & id000, id010, id100, id110, id200, id210, ig, js, js1, & + & id001, id011, id101, id111, id201, id211 + + real (kind=kind_phys) :: tauself, taufor, p, p4, fk0, fk1, fk2, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & refrat_planck_a, refrat_planck_b, tau_major, tau_major1 +! +!===> ... begin here +! + refrat_planck_a = chi_mls(1,11)/chi_mls(2,11) ! P = 142.5940 mb + refrat_planck_b = chi_mls(3,13)/chi_mls(2,13) ! P = 95.58350 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(4) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ( jp(k)*5 + (jt1(k)-1)) * nspa(4) + js1 + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, 1.0) + + inds = indself(k) + indf = indfor(k) + indsp = inds + 1 + indfp = indf + 1 + jplp = jpl + 1 + + if (specparm < 0.125) then + p = fs - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk0 = f_one - fs + fk1 = fs + fk2 = f_zero + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk0*fac00(k) + fac100 = fk1*fac00(k) + fac200 = fk2*fac00(k) + fac010 = fk0*fac10(k) + fac110 = fk1*fac10(k) + fac210 = fk2*fac10(k) + + if (specparm1 < 0.125) then + p = fs1 - f_one + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = f_one - p - 2.0*p4 + fk2 = p + p4 + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk0 = f_one - fs1 + fk1 = fs1 + fk2 = f_zero + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk0*fac01(k) + fac101 = fk1*fac01(k) + fac201 = fk2*fac01(k) + fac011 = fk0*fac11(k) + fac111 = fk1*fac11(k) + fac211 = fk2*fac11(k) + + do ig = 1, ng04 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + tau_major = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) + + tau_major1 = speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) + + taug(ns04+ig,k) = tau_major + tau_major1 + tauself + taufor + + fracs(ns04+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo ! end do_k_loop + enddo ! end do_ig_loop + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2) + specparm = colamt(k,3) / speccomb + specmult = 4.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(4) + js + + speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2) + specparm1 = colamt(k,3) / speccomb1 + specmult1 = 4.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(4) + js1 + + speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2) + specparm_planck = colamt(k,3) / speccomb_planck + specmult_planck = 4.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + jplp = jpl + 1 + + id000 = ind0 + id010 = ind0 + 5 + id100 = ind0 + 1 + id110 = ind0 + 6 + id001 = ind1 + id011 = ind1 + 5 + id101 = ind1 + 1 + id111 = ind1 + 6 + + fk0 = f_one - fs + fk1 = fs + fac000 = fk0*fac00(k) + fac010 = fk0*fac10(k) + fac100 = fk1*fac00(k) + fac110 = fk1*fac10(k) + + fk0 = f_one - fs1 + fk1 = fs1 + fac001 = fk0*fac01(k) + fac011 = fk0*fac11(k) + fac101 = fk1*fac01(k) + fac111 = fk1*fac11(k) + + do ig = 1, ng04 + tau_major = speccomb & + & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & + & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) + tau_major1 = speccomb1 & + & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & + & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) + + taug(ns04+ig,k) = tau_major + tau_major1 + + fracs(ns04+ig,k) = fracrefb(ig,jpl) + fpl & + & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) + enddo + +! --- ... empirical modification to code to improve stratospheric cooling rates +! for co2. revised to apply weighting for g-point reduction in this band. + + taug(ns04+ 8,k) = taug(ns04+ 8,k) * 0.92 + taug(ns04+ 9,k) = taug(ns04+ 9,k) * 0.88 + taug(ns04+10,k) = taug(ns04+10,k) * 1.07 + taug(ns04+11,k) = taug(ns04+11,k) * 1.1 + taug(ns04+12,k) = taug(ns04+12,k) * 0.99 + taug(ns04+13,k) = taug(ns04+13,k) * 0.88 + taug(ns04+14,k) = taug(ns04+14,k) * 0.943 + enddo + +! .................................. + end subroutine taugb04 +! ---------------------------------- + +!> Band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +!! (high key - o3,co2) +! ---------------------------------- + subroutine taugb05 +! .................................. + +! ------------------------------------------------------------------ ! +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) ! +! (high key - o3,co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb05 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jmo3, jmo3p, & + & id001, id011, id101, id111, id201, id211, jpl, jplp, & + & ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, o3m1, o3m2, abso3, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mo3, specparm_mo3, specmult_mo3, fmo3, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_planck_b, refrat_m_a, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - o3, p = 317.34 mbar, t = 240.77 k +! lower - ccl4 + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,5)/chi_mls(2,5) ! P = 473.420 mb + refrat_planck_b = chi_mls(3,43)/chi_mls(2,43) ! P = 0.2369 mb + refrat_m_a = chi_mls(1,7)/chi_mls(2,7) ! P = 317.348 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(5) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(5) + js1 + + speccomb_mo3 = colamt(k,1) + refrat_m_a*colamt(k,2) + specparm_mo3 = colamt(k,1) / speccomb_mo3 + specmult_mo3 = 8.0 * min(specparm_mo3, oneminus) + jmo3 = 1 + int(specmult_mo3) + fmo3 = mod(specmult_mo3, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmo3p = jmo3 + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng05 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + o3m1 = ka_mo3(ig,jmo3,indm) + fmo3 & + & * (ka_mo3(ig,jmo3p,indm) - ka_mo3(ig,jmo3,indm)) + o3m2 = ka_mo3(ig,jmo3,indmp) + fmo3 & + & * (ka_mo3(ig,jmo3p,indmp) - ka_mo3(ig,jmo3,indmp)) + abso3 = o3m1 + minorfrac(k)*(o3m2 - o3m1) + + taug(ns05+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor+abso3*colamt(k,3)+wx(k,1)*ccl4(ig) + + fracs(ns05+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + speccomb = colamt(k,3) + rfrate(k,6,1)*colamt(k,2) + specparm = colamt(k,3) / speccomb + specmult = 4.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-13)*5 + (jt(k)-1)) * nspb(5) + js + + speccomb1 = colamt(k,3) + rfrate(k,6,2)*colamt(k,2) + specparm1 = colamt(k,3) / speccomb1 + specmult1 = 4.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(5) + js1 + + speccomb_planck = colamt(k,3) + refrat_planck_b*colamt(k,2) + specparm_planck = colamt(k,3) / speccomb_planck + specmult_planck = 4.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + jplp= jpl + 1 + + id000 = ind0 + id010 = ind0 + 5 + id100 = ind0 + 1 + id110 = ind0 + 6 + id001 = ind1 + id011 = ind1 + 5 + id101 = ind1 + 1 + id111 = ind1 + 6 + + fk00 = f_one - fs + fk10 = fs + + fk01 = f_one - fs1 + fk11 = fs1 + + fac000 = fk00 * fac00(k) + fac010 = fk00 * fac10(k) + fac100 = fk10 * fac00(k) + fac110 = fk10 * fac10(k) + + fac001 = fk01 * fac01(k) + fac011 = fk01 * fac11(k) + fac101 = fk11 * fac01(k) + fac111 = fk11 * fac11(k) + + do ig = 1, ng05 + taug(ns05+ig,k) = speccomb & + & * (fac000*absb(ig,id000) + fac010*absb(ig,id010) & + & + fac100*absb(ig,id100) + fac110*absb(ig,id110)) & + & + speccomb1 & + & * (fac001*absb(ig,id001) + fac011*absb(ig,id011) & + & + fac101*absb(ig,id101) + fac111*absb(ig,id111)) & + & + wx(k,1) * ccl4(ig) + + fracs(ns05+ig,k) = fracrefb(ig,jpl) + fpl & + & * (fracrefb(ig,jplp) - fracrefb(ig,jpl)) + enddo + enddo + +! .................................. + end subroutine taugb05 +! ---------------------------------- + +!> Band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +!! (high key - none; high minor - cfc11, cfc12) +! ---------------------------------- + subroutine taugb06 +! .................................. + +! ------------------------------------------------------------------ ! +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) ! +! (high key - none; high minor - cfc11, cfc12) +! ------------------------------------------------------------------ ! + + use module_radlw_kgb06 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: ratco2, adjfac, adjcolco2, tauself, & + & taufor, absco2, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level: +! lower - co2, p = 706.2720 mb, t = 294.2 k +! upper - cfc11, cfc12 + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(6) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(6) + 1 + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + ind0p = ind0 + 1 + ind1p = ind1 + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.77 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + do ig = 1, ng06 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + absco2 = ka_mco2(ig,indm) + minorfrac(k) & + & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm)) + + taug(ns06+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + adjcolco2*absco2 & + & + wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig) + + fracs(ns06+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop +! nothing important goes on above laytrop in this band. + + do k = laytrop+1, nlay + do ig = 1, ng06 + taug(ns06+ig,k) = wx(k,2)*cfc11adj(ig) + wx(k,3)*cfc12(ig) + + fracs(ns06+ig,k) = fracrefa(ig) + enddo + enddo + +! .................................. + end subroutine taugb06 +! ---------------------------------- + +!> Band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +!! (high key - o3; high minor - co2) +! ---------------------------------- + subroutine taugb07 +! .................................. + +! ------------------------------------------------------------------ ! +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) ! +! (high key - o3; high minor - co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb07 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & id000, id010, id100, id110, id200, id210, indm, indmp, & + & id001, id011, id101, id111, id201, id211, jmco2, jmco2p, & + & jpl, jplp, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, ratco2, adjfac, adjcolco2, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - co2, p = 706.2620 mbar, t= 278.94 k +! upper - co2, p = 12.9350 mbar, t = 234.01 k + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + + refrat_planck_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2620 mb + refrat_m_a = chi_mls(1,3)/chi_mls(3,3) ! P = 706.2720 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,2,1)*colamt(k,3) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(7) + js + + speccomb1 = colamt(k,1) + rfrate(k,2,2)*colamt(k,3) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(7) + js1 + + speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,3) + specparm_mco2 = colamt(k,1) / speccomb_mco2 + specmult_mco2 = 8.0 * min(specparm_mco2, oneminus) + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,3) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmco2p= jmco2+ 1 + ind0p = ind0 + 1 + ind1p = ind1 + 1 + +! --- ... in atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 3.0 + (ratco2-3.0)**0.79 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng07 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 & + & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm)) + co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 & + & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp)) + absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1) + + taug(ns07+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + adjcolco2*absco2 + + fracs(ns07+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + do k = laytrop+1, nlay + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.79 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(7) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(7) + 1 + + indm = indminor(k) + indmp = indm + 1 + ind0p = ind0 + 1 + ind1p = ind1 + 1 + + do ig = 1, ng07 + absco2 = kb_mco2(ig,indm) + minorfrac(k) & + & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm)) + + taug(ns07+ig,k) = colamt(k,3) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + adjcolco2 * absco2 + + fracs(ns07+ig,k) = fracrefb(ig) + enddo + +! --- ... empirical modification to code to improve stratospheric cooling rates +! for o3. revised to apply weighting for g-point reduction in this band. + + taug(ns07+ 6,k) = taug(ns07+ 6,k) * 0.92 + taug(ns07+ 7,k) = taug(ns07+ 7,k) * 0.88 + taug(ns07+ 8,k) = taug(ns07+ 8,k) * 1.07 + taug(ns07+ 9,k) = taug(ns07+ 9,k) * 1.1 + taug(ns07+10,k) = taug(ns07+10,k) * 0.99 + taug(ns07+11,k) = taug(ns07+11,k) * 0.855 + enddo + +! .................................. + end subroutine taugb07 +! ---------------------------------- + +!> Band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +!! (high key - o3; high minor - co2, n2o) +! ---------------------------------- + subroutine taugb08 +! .................................. + +! ------------------------------------------------------------------ ! +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) ! +! (high key - o3; high minor - co2, n2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb08 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: tauself, taufor, absco2, abso3, absn2o, & + & ratco2, adjfac, adjcolco2, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level: +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - o3, p = 317.348 mb, t = 240.77 k +! lower - n2o, p = 706.2720 mb, t= 278.94 k +! lower - cfc12,cfc11 +! upper - co2, p = 35.1632 mb, t = 223.28 k +! upper - n2o, p = 8.716e-2 mb, t = 226.03 k + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(8) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(8) + 1 + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.65 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + do ig = 1, ng08 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + absco2 = (ka_mco2(ig,indm) + minorfrac(k) & + & * (ka_mco2(ig,indmp) - ka_mco2(ig,indm))) + abso3 = (ka_mo3(ig,indm) + minorfrac(k) & + & * (ka_mo3(ig,indmp) - ka_mo3(ig,indm))) + absn2o = (ka_mn2o(ig,indm) + minorfrac(k) & + & * (ka_mn2o(ig,indmp) - ka_mn2o(ig,indm))) + + taug(ns08+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself+taufor + adjcolco2*absco2 & + & + colamt(k,3)*abso3 + colamt(k,4)*absn2o & + & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig) + + fracs(ns08+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(8) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(8) + 1 + + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indmp = indm + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(2,jp(k)+1) + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.65 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + do ig = 1, ng08 + absco2 = (kb_mco2(ig,indm) + minorfrac(k) & + & * (kb_mco2(ig,indmp) - kb_mco2(ig,indm))) + absn2o = (kb_mn2o(ig,indm) + minorfrac(k) & + & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm))) + + taug(ns08+ig,k) = colamt(k,3) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + adjcolco2*absco2 + colamt(k,4)*absn2o & + & + wx(k,3)*cfc12(ig) + wx(k,4)*cfc22adj(ig) + + fracs(ns08+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb08 +! ---------------------------------- + +!> Band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +!! (high key - ch4; high minor - n2o) +! ---------------------------------- + subroutine taugb09 +! .................................. + +! ------------------------------------------------------------------ ! +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) ! +! (high key - ch4; high minor - n2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb09 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & id000, id010, id100, id110, id200, id210, indm, indmp, & + & id001, id011, id101, id111, id201, id211, jmn2o, jmn2op, & + & jpl, jplp, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, n2om1, n2om2, absn2o, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, ratn2o, adjfac, adjcoln2o, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,9)/chi_mls(6,9) ! P = 212 mb + refrat_m_a = chi_mls(1,3)/chi_mls(6,3) ! P = 706.272 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(9) + js + + speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(9) + js1 + + speccomb_mn2o = colamt(k,1) + refrat_m_a*colamt(k,5) + specparm_mn2o = colamt(k,1) / speccomb_mn2o + specmult_mn2o = 8.0 * min(specparm_mn2o, oneminus) + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmn2op= jmn2o+ 1 + +! --- ... in atmospheres where the amount of n2o is too great to be considered +! a minor species, adjust the column amount of n2o by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / temp + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o-0.5)**0.65 + adjcoln2o = adjfac * temp + else + adjcoln2o = colamt(k,4) + endif + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng09 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2om1 = ka_mn2o(ig,jmn2o,indm) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indm) - ka_mn2o(ig,jmn2o,indm)) + n2om2 = ka_mn2o(ig,jmn2o,indmp) + fmn2o & + & * (ka_mn2o(ig,jmn2op,indmp) - ka_mn2o(ig,jmn2o,indmp)) + absn2o = n2om1 + minorfrac(k) * (n2om2 - n2om1) + + taug(ns09+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + adjcoln2o*absn2o + + fracs(ns09+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(9) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(9) + 1 + + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indmp = indm + 1 + +! --- ... in atmospheres where the amount of n2o is too great to be considered +! a minor species, adjust the column amount of n2o by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * chi_mls(4,jp(k)+1) + ratn2o = colamt(k,4) / temp + if (ratn2o > 1.5) then + adjfac = 0.5 + (ratn2o - 0.5)**0.65 + adjcoln2o = adjfac * temp + else + adjcoln2o = colamt(k,4) + endif + + do ig = 1, ng09 + absn2o = kb_mn2o(ig,indm) + minorfrac(k) & + & * (kb_mn2o(ig,indmp) - kb_mn2o(ig,indm)) + + taug(ns09+ig,k) = colamt(k,5) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + adjcoln2o*absn2o + + fracs(ns09+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb09 +! ---------------------------------- + +!> Band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) +! ---------------------------------- + subroutine taugb10 +! .................................. + +! ------------------------------------------------------------------ ! +! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb10 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & ig + + real (kind=kind_phys) :: tauself, taufor +! +!===> ... begin here +! +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(10) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(10) + 1 + + inds = indself(k) + indf = indfor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + + do ig = 1, ng10 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns10+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + + fracs(ns10+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(10) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(10) + 1 + + indf = indfor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + + do ig = 1, ng10 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns10+ig,k) = colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + + fracs(ns10+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb10 +! ---------------------------------- + +!> Band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +!! (high key - h2o; high minor - o2) +! ---------------------------------- + subroutine taugb11 +! .................................. + +! ------------------------------------------------------------------ ! +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) ! +! (high key - h2o; high minor - o2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb11 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & indm, indmp, ig + + real (kind=kind_phys) :: scaleo2, tauself, taufor, tauo2 +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - o2, p = 706.2720 mbar, t = 278.94 k +! upper - o2, p = 4.758820 mbarm t = 250.85 k + +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(11) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(11) + 1 + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + + scaleo2 = colamt(k,6) * scaleminor(k) + + do ig = 1, ng11 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + tauo2 = scaleo2 * (ka_mo2(ig,indm) + minorfrac(k) & + & * (ka_mo2(ig,indmp) - ka_mo2(ig,indm))) + + taug(ns11+ig,k) = colamt(k,1) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + tauo2 + + fracs(ns11+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(11) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(11) + 1 + + indf = indfor(k) + indm = indminor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indfp = indf + 1 + indmp = indm + 1 + + scaleo2 = colamt(k,6) * scaleminor(k) + + do ig = 1, ng11 + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + tauo2 = scaleo2 * (kb_mo2(ig,indm) + minorfrac(k) & + & * (kb_mo2(ig,indmp) - kb_mo2(ig,indm))) + + taug(ns11+ig,k) = colamt(k,1) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) & + & + taufor + tauo2 + + fracs(ns11+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb11 +! ---------------------------------- + +!> Band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! ---------------------------------- + subroutine taugb12 +! .................................. + +! ------------------------------------------------------------------ ! +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb12 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, jpl, jplp, & + & id000, id010, id100, id110, id200, id210, ig, js, js1, & + & id001, id011, id101, id111, id201, id211 + + real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,10)/chi_mls(2,10) ! P = 174.164 mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,1,1)*colamt(k,2) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(12) + js + + speccomb1 = colamt(k,1) + rfrate(k,1,2)*colamt(k,2) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(12) + js1 + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,1) / speccomb_planck + if (specparm_planck >= oneminus) specparm_planck=oneminus + specmult_planck = 8.0 * specparm_planck + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indsp = inds + 1 + indfp = indf + 1 + jplp = jpl + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng12 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns12+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + + fracs(ns12+ig,k) = fracrefa(ig,jpl) + fpl & + & *(fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + do ig = 1, ng12 + taug(ns12+ig,k) = f_zero + fracs(ns12+ig,k) = f_zero + enddo + enddo + +! .................................. + end subroutine taugb12 +! ---------------------------------- + +!> Band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) +! ---------------------------------- + subroutine taugb13 +! .................................. + +! ------------------------------------------------------------------ ! +! band 13: 2080-2250 cm-1 (low key-h2o,n2o; high minor-o3 minor) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb13 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jmco2, jpl, & + & id001, id011, id101, id111, id201, id211, jmco2p, jplp, & + & jmco, jmcop, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, co2m1, co2m2, absco2, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mco2, specparm_mco2, specmult_mco2, fmco2, & + & speccomb_mco, specparm_mco, specmult_mco, fmco, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, refrat_m_a3, ratco2, & + & adjfac, adjcolco2, com1, com2, absco, abso3, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21, temp +! +!===> ... begin here +! +! --- ... minor gas mapping levels : +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - co, p = 706 mb, t = 278.94 k +! upper - o3, p = 95.5835 mb, t = 215.7 k + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + + refrat_planck_a = chi_mls(1,5)/chi_mls(4,5) ! P = 473.420 mb (Level 5) + refrat_m_a = chi_mls(1,1)/chi_mls(4,1) ! P = 1053. (Level 1) + refrat_m_a3 = chi_mls(1,3)/chi_mls(4,3) ! P = 706. (Level 3) + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,3,1)*colamt(k,4) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(13) + js + + speccomb1 = colamt(k,1) + rfrate(k,3,2)*colamt(k,4) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(13) + js1 + + speccomb_mco2 = colamt(k,1) + refrat_m_a*colamt(k,4) + specparm_mco2 = colamt(k,1) / speccomb_mco2 + specmult_mco2 = 8.0 * min(specparm_mco2, oneminus) + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2, f_one) + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + speccomb_mco = colamt(k,1) + refrat_m_a3*colamt(k,4) + specparm_mco = colamt(k,1) / speccomb_mco + specmult_mco = 8.0 * min(specparm_mco, oneminus) + jmco = 1 + int(specmult_mco) + fmco = mod(specmult_mco, f_one) + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,4) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmco2p= jmco2+ 1 + jmcop = jmco + 1 + +! --- ... in atmospheres where the amount of co2 is too great to be considered +! a minor species, adjust the column amount of co2 by an empirical factor +! to obtain the proper contribution. + + temp = coldry(k) * 3.55e-4 + ratco2 = colamt(k,2) / temp + if (ratco2 > 3.0) then + adjfac = 2.0 + (ratco2-2.0)**0.68 + adjcolco2 = adjfac * temp + else + adjcolco2 = colamt(k,2) + endif + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng13 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + co2m1 = ka_mco2(ig,jmco2,indm) + fmco2 & + & * (ka_mco2(ig,jmco2p,indm) - ka_mco2(ig,jmco2,indm)) + co2m2 = ka_mco2(ig,jmco2,indmp) + fmco2 & + & * (ka_mco2(ig,jmco2p,indmp) - ka_mco2(ig,jmco2,indmp)) + absco2 = co2m1 + minorfrac(k) * (co2m2 - co2m1) + com1 = ka_mco(ig,jmco,indm) + fmco & + & * (ka_mco(ig,jmcop,indm) - ka_mco(ig,jmco,indm)) + com2 = ka_mco(ig,jmco,indmp) + fmco & + & * (ka_mco(ig,jmcop,indmp) - ka_mco(ig,jmco,indmp)) + absco = com1 + minorfrac(k) * (com2 - com1) + + taug(ns13+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + adjcolco2*absco2 & + & + colamt(k,7)*absco + + fracs(ns13+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + indm = indminor(k) + indmp = indm + 1 + + do ig = 1, ng13 + abso3 = kb_mo3(ig,indm) + minorfrac(k) & + & * (kb_mo3(ig,indmp) - kb_mo3(ig,indm)) + + taug(ns13+ig,k) = colamt(k,3)*abso3 + + fracs(ns13+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb13 +! ---------------------------------- + +!> Band 14: 2250-2380 cm-1 (low - co2; high - co2) +! ---------------------------------- + subroutine taugb14 +! .................................. + +! ------------------------------------------------------------------ ! +! band 14: 2250-2380 cm-1 (low - co2; high - co2) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb14 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & ig + + real (kind=kind_phys) :: tauself, taufor +! +!===> ... begin here +! +! --- ... lower atmosphere loop + + do k = 1, laytrop + ind0 = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(14) + 1 + ind1 = ( jp(k) *5 + (jt1(k)-1)) * nspa(14) + 1 + + inds = indself(k) + indf = indfor(k) + ind0p = ind0 + 1 + ind1p = ind1 + 1 + indsp = inds + 1 + indfp = indf + 1 + + do ig = 1, ng14 + tauself = selffac(k) * (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns14+ig,k) = colamt(k,2) & + & * (fac00(k)*absa(ig,ind0) + fac10(k)*absa(ig,ind0p) & + & + fac01(k)*absa(ig,ind1) + fac11(k)*absa(ig,ind1p)) & + & + tauself + taufor + + fracs(ns14+ig,k) = fracrefa(ig) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(14) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(14) + 1 + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + + do ig = 1, ng14 + taug(ns14+ig,k) = colamt(k,2) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) + + fracs(ns14+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb14 +! ---------------------------------- + +!> Band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +!! (high - nothing) +! ---------------------------------- + subroutine taugb15 +! .................................. + +! ------------------------------------------------------------------ ! +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) ! +! (high - nothing) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb15 + +! --- locals: + integer :: k, ind0, ind1, inds, indsp, indf, indfp, indm, indmp, & + & id000, id010, id100, id110, id200, id210, jpl, jplp, & + & id001, id011, id101, id111, id201, id211, jmn2, jmn2p, & + & ig, js, js1 + + real (kind=kind_phys) :: scalen2, tauself, taufor, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_mn2, specparm_mn2, specmult_mn2, fmn2, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & refrat_planck_a, refrat_m_a, n2m1, n2m2, taun2, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... minor gas mapping level : +! lower - nitrogen continuum, P = 1053., T = 294. + +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + + refrat_planck_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb (Level 1) + refrat_m_a = chi_mls(4,1)/chi_mls(2,1) ! P = 1053. mb + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,4) + rfrate(k,5,1)*colamt(k,2) + specparm = colamt(k,4) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(15) + js + + speccomb1 = colamt(k,4) + rfrate(k,5,2)*colamt(k,2) + specparm1 = colamt(k,4) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(15) + js1 + + speccomb_mn2 = colamt(k,4) + refrat_m_a*colamt(k,2) + specparm_mn2 = colamt(k,4) / speccomb_mn2 + specmult_mn2 = 8.0 * min(specparm_mn2, oneminus) + jmn2 = 1 + int(specmult_mn2) + fmn2 = mod(specmult_mn2, f_one) + + speccomb_planck = colamt(k,4) + refrat_planck_a*colamt(k,2) + specparm_planck = colamt(k,4) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + scalen2 = colbrd(k) * scaleminor(k) + + inds = indself(k) + indf = indfor(k) + indm = indminor(k) + indsp = inds + 1 + indfp = indf + 1 + indmp = indm + 1 + jplp = jpl + 1 + jmn2p = jmn2 + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng15 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + n2m1 = ka_mn2(ig,jmn2,indm) + fmn2 & + & * (ka_mn2(ig,jmn2p,indm) - ka_mn2(ig,jmn2,indm)) + n2m2 = ka_mn2(ig,jmn2,indmp) + fmn2 & + & * (ka_mn2(ig,jmn2p,indmp) - ka_mn2(ig,jmn2,indmp)) + taun2 = scalen2 * (n2m1 + minorfrac(k) * (n2m2 - n2m1)) + + taug(ns15+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + taun2 + + fracs(ns15+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + do ig = 1, ng15 + taug(ns15+ig,k) = f_zero + + fracs(ns15+ig,k) = f_zero + enddo + enddo + +! .................................. + end subroutine taugb15 +! ---------------------------------- + +!> Band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! ---------------------------------- + subroutine taugb16 +! .................................. + +! ------------------------------------------------------------------ ! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) ! +! ------------------------------------------------------------------ ! + + use module_radlw_kgb16 + +! --- locals: + integer :: k, ind0, ind0p, ind1, ind1p, inds, indsp, indf, indfp, & + & id000, id010, id100, id110, id200, id210, jpl, jplp, & + & id001, id011, id101, id111, id201, id211, ig, js, js1 + + real (kind=kind_phys) :: tauself, taufor, refrat_planck_a, & + & speccomb, specparm, specmult, fs, & + & speccomb1, specparm1, specmult1, fs1, & + & speccomb_planck,specparm_planck,specmult_planck,fpl, & + & fac000, fac100, fac200, fac010, fac110, fac210, & + & fac001, fac101, fac201, fac011, fac111, fac211, & + & p0, p40, fk00, fk10, fk20, p1, p41, fk01, fk11, fk21 +! +!===> ... begin here +! +! --- ... calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + + refrat_planck_a = chi_mls(1,6)/chi_mls(6,6) ! P = 387. mb (Level 6) + +! --- ... lower atmosphere loop + + do k = 1, laytrop + speccomb = colamt(k,1) + rfrate(k,4,1)*colamt(k,5) + specparm = colamt(k,1) / speccomb + specmult = 8.0 * min(specparm, oneminus) + js = 1 + int(specmult) + fs = mod(specmult, f_one) + ind0 = ((jp(k)-1)*5 + (jt(k)-1)) * nspa(16) + js + + speccomb1 = colamt(k,1) + rfrate(k,4,2)*colamt(k,5) + specparm1 = colamt(k,1) / speccomb1 + specmult1 = 8.0 * min(specparm1, oneminus) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1, f_one) + ind1 = (jp(k)*5 + (jt1(k)-1)) * nspa(16) + js1 + + speccomb_planck = colamt(k,1) + refrat_planck_a*colamt(k,5) + specparm_planck = colamt(k,1) / speccomb_planck + specmult_planck = 8.0 * min(specparm_planck, oneminus) + jpl = 1 + int(specmult_planck) + fpl = mod(specmult_planck, f_one) + + inds = indself(k) + indf = indfor(k) + indsp = inds + 1 + indfp = indf + 1 + jplp = jpl + 1 + + if (specparm < 0.125) then + p0 = fs - f_one + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + 2 + id210 = ind0 +11 + elseif (specparm > 0.875) then + p0 = -fs + p40 = p0**4 + fk00 = p40 + fk10 = f_one - p0 - 2.0*p40 + fk20 = p0 + p40 + + id000 = ind0 + 1 + id010 = ind0 +10 + id100 = ind0 + id110 = ind0 + 9 + id200 = ind0 - 1 + id210 = ind0 + 8 + else + fk00 = f_one - fs + fk10 = fs + fk20 = f_zero + + id000 = ind0 + id010 = ind0 + 9 + id100 = ind0 + 1 + id110 = ind0 +10 + id200 = ind0 + id210 = ind0 + endif + + fac000 = fk00 * fac00(k) + fac100 = fk10 * fac00(k) + fac200 = fk20 * fac00(k) + fac010 = fk00 * fac10(k) + fac110 = fk10 * fac10(k) + fac210 = fk20 * fac10(k) + + if (specparm1 < 0.125) then + p1 = fs1 - f_one + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + 2 + id211 = ind1 +11 + elseif (specparm1 > 0.875) then + p1 = -fs1 + p41 = p1**4 + fk01 = p41 + fk11 = f_one - p1 - 2.0*p41 + fk21 = p1 + p41 + + id001 = ind1 + 1 + id011 = ind1 +10 + id101 = ind1 + id111 = ind1 + 9 + id201 = ind1 - 1 + id211 = ind1 + 8 + else + fk01 = f_one - fs1 + fk11 = fs1 + fk21 = f_zero + + id001 = ind1 + id011 = ind1 + 9 + id101 = ind1 + 1 + id111 = ind1 +10 + id201 = ind1 + id211 = ind1 + endif + + fac001 = fk01 * fac01(k) + fac101 = fk11 * fac01(k) + fac201 = fk21 * fac01(k) + fac011 = fk01 * fac11(k) + fac111 = fk11 * fac11(k) + fac211 = fk21 * fac11(k) + + do ig = 1, ng16 + tauself = selffac(k)* (selfref(ig,inds) + selffrac(k) & + & * (selfref(ig,indsp) - selfref(ig,inds))) + taufor = forfac(k) * (forref(ig,indf) + forfrac(k) & + & * (forref(ig,indfp) - forref(ig,indf))) + + taug(ns16+ig,k) = speccomb & + & * (fac000*absa(ig,id000) + fac010*absa(ig,id010) & + & + fac100*absa(ig,id100) + fac110*absa(ig,id110) & + & + fac200*absa(ig,id200) + fac210*absa(ig,id210)) & + & + speccomb1 & + & * (fac001*absa(ig,id001) + fac011*absa(ig,id011) & + & + fac101*absa(ig,id101) + fac111*absa(ig,id111) & + & + fac201*absa(ig,id201) + fac211*absa(ig,id211)) & + & + tauself + taufor + + fracs(ns16+ig,k) = fracrefa(ig,jpl) + fpl & + & * (fracrefa(ig,jplp) - fracrefa(ig,jpl)) + enddo + enddo + +! --- ... upper atmosphere loop + + do k = laytrop+1, nlay + ind0 = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(16) + 1 + ind1 = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(16) + 1 + + ind0p = ind0 + 1 + ind1p = ind1 + 1 + + do ig = 1, ng16 + taug(ns16+ig,k) = colamt(k,5) & + & * (fac00(k)*absb(ig,ind0) + fac10(k)*absb(ig,ind0p) & + & + fac01(k)*absb(ig,ind1) + fac11(k)*absb(ig,ind1p)) + + fracs(ns16+ig,k) = fracrefb(ig) + enddo + enddo + +! .................................. + end subroutine taugb16 +! ---------------------------------- + +! .................................. + end subroutine taumol +!----------------------------------- + + +! +!........................................! + end module module_radlw_main ! +!========================================! + +!! @} diff --git a/gsmphys/radlw_param.f b/gsmphys/radlw_param.f new file mode 100644 index 00000000..c7686497 --- /dev/null +++ b/gsmphys/radlw_param.f @@ -0,0 +1,162 @@ +!> \file radlw_param.f +!! This file contains LW band parameters setup. + +!> \ingroup module_radlw_main +!! @{ + +!!!!! ============================================================== !!!!! +!!!!! lw-rrtm3 radiation package description !!!!! +!!!!! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-lw radiation ! +! code from aer inc. ! +! ! +! the rrtm3 package includes these parts: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! the 'radlw_rrtm3_param.f' contains: ! +! ! +! 'module_radlw_parameters' -- band parameters set up ! +! ! +! the 'radlw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radlw_avplank' -- plank flux data ! +! 'module_radlw_ref' -- reference temperature and pressure ! +! 'module_radlw_cldprlw' -- cloud property coefficients ! +! 'module_radlw_kgbnn' -- absorption coeffients for 16 ! +! bands, where nn = 01-16 ! +! ! +! the 'radlw_rrtm3_main.f' contains: ! +! ! +! 'module_radlw_main' -- main lw radiation transfer ! +! ! +! in the main module 'module_radlw_main' there are only two ! +! externally callable subroutines: ! +! ! +! 'lwrad' -- main rrtm3 lw radiation routine ! +! 'rlwinit' -- to initialize rrtm3 lw radiation ! +! ! +! all the lw radiation subprograms become contained subprograms ! +! in module 'module_radlw_rrtm' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! compilation sequence is: ! +! ! +! 'radlw_rrtm3_param.f' ! +! 'radlw_rrtm3_datatb.f' ! +! 'radlw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use lw modules ! +! ! +! ncep modifications history log: ! +! ! +! see list in program "radlw_rrtm3_main.f" ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + +!> This module contains LW band parameters set up. +!========================================! + module module_radlw_parameters ! +!........................................! + + use physparam, only : kind_phys + + implicit none +! + public +! +! +!> Define type construct for radiation fluxes at toa. + type :: topflw_type +!> total sky upward flux at toa + real (kind=kind_phys) :: upfxc +!> clear sky upward flux at toa + real (kind=kind_phys) :: upfx0 + end type +! +! +!> Define type construct for radiation fluxes at surface. + type :: sfcflw_type +!> total sky upward flux at sfc + real (kind=kind_phys) :: upfxc +!> clear sky upward flux at sfc + real (kind=kind_phys) :: upfx0 +!> total sky downward flux at sfc + real (kind=kind_phys) :: dnfxc +!> clear sky downward flux at sfc + real (kind=kind_phys) :: dnfx0 + end type +! +! +!> Define type construct for optional radiation flux profiles. + type :: proflw_type +!> level up flux for total sky + real (kind=kind_phys) :: upfxc +!> level dn flux for total sky + real (kind=kind_phys) :: dnfxc +!> level up flux fro clear sky + real (kind=kind_phys) :: upfx0 +!> level dn flux for clear sky + real (kind=kind_phys) :: dnfx0 + end type +! +!>\name Parameter constants for LW band structures + +!> num of total spectral bands + integer, parameter :: NBANDS = 16 +!> num of total g-points + integer, parameter :: NGPTLW = 140 +!> lookup table dimension + integer, parameter :: NTBL = 10000 +!> max num of absorbing gases + integer, parameter :: MAXGAS = 7 +!> num of halocarbon gasees + integer, parameter :: MAXXSEC= 4 +!> num of ref rates of binary species + integer, parameter :: NRATES = 6 +!> dim for plank function table + integer, parameter :: NPLNK = 181 + + integer, parameter :: NBDLW = NBANDS + +!> \name Number of g-point in each band + integer :: NG01, NG02, NG03, NG04, NG05, NG06, NG07, NG08, + & NG09, NG10, NG11, NG12, NG13, NG14, NG15, NG16 + parameter (NG01=10, NG02=12, NG03=16, NG04=14, NG05=16, NG06=08, + & NG07=12, NG08=08, NG09=12, NG10=06, NG11=08, NG12=08, + & NG13=04, NG14=02, NG15=02, NG16=02) + +!> \name Begining index of each band + integer :: NS01, NS02, NS03, NS04, NS05, NS06, NS07, NS08, + & NS09, NS10, NS11, NS12, NS13, NS14, NS15, NS16 + parameter (NS01=00, NS02=10, NS03=22, NS04=38, NS05=52, NS06=68, + & NS07=76, NS08=88, NS09=96, NS10=108, NS11=114, + & NS12=122, NS13=130, NS14=134, NS15=136, NS16=138) + +!> band indices for each g-point + integer, dimension(NGPTLW) :: NGB + data NGB(:) / 10*1, 12*2, 16*3, 14*4, 16*5, 8*6, 12*7, 8*8, & ! band 1- 8 + & 12*9, 6*10, 8*11, 8*12, 4*13, 2*14, 2*15, 2*16 / ! band 9-16 + +!> \name Band spectrum structures (wavenumber is 1/cm + real (kind=kind_phys) :: wvnlw1(NBANDS), wvnlw2(NBANDS) + data wvnlw1 / & + & 10., 351., 501., 631., 701., 821., 981., 1081., & + & 1181., 1391., 1481., 1801., 2081., 2251., 2381., 2601. / + data wvnlw2 / & + & 350., 500., 630., 700., 820., 980., 1080., 1180., & + & 1390., 1480., 1800., 2080., 2250., 2380., 2600., 3250. / + + real (kind=kind_phys) :: delwave(nbands) + data delwave / 340., 150., 130., 70., 120., 160., 100., 100., & + & 210., 90., 320., 280., 170., 130., 220., 650. / + +!........................................! + end module module_radlw_parameters ! +!========================================! +!! @} diff --git a/gsmphys/radsw_datatb.f b/gsmphys/radsw_datatb.f new file mode 100644 index 00000000..7da6132c --- /dev/null +++ b/gsmphys/radsw_datatb.f @@ -0,0 +1,22084 @@ +!> \file radsw_datatb.f +!! This file contains many individual data modules with specifically +!! precalculated data tables: +!! - module_radsw_ref (reference temperature and pressure) +!! - module_radsw_cldprtb (cloud property coefficients table) +!! - module_radsw_sflux (spectral solar flux distribution) +!! - module_radsw_kgbnn (absorption coeffients for 14 bands, +!! where nn = 16-29) + +! ============================================================== !!!!! +! sw-rrtm3 radiation package description !!!!! +! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-sw radiation ! +! code from aer inc. ! +! ! +! the sw-rrtm3 package includes these parts: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! the 'radsw_rrtm3_param.f' contains: ! +! ! +! 'module_radsw_parameters' -- band parameters set up ! +! ! +! the 'radsw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radsw_ref' -- reference temperature and pressure ! +! 'module_radsw_cldprtb' -- cloud property coefficients table ! +! 'module_radsw_sflux' -- spectral solar flux distribution ! +! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! +! bands, where nn = 16-29 ! +! ! +! the 'radsw_rrtm3_main.f' contains: ! +! ! +! 'module_radsw_main' -- main sw radiation transfer ! +! ! +! in the main module 'module_radsw_main' there are only two ! +! externally callable subroutines: ! +! ! +! 'swrad' -- main rrtm3 sw radiation routine ! +! 'rswinit' -- initialization routine ! +! ! +! all the sw radiation subprograms become contained subprograms ! +! in module 'module_radsw_main' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! compilation sequence is: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use sw modules ! +! ! +! ncep modifications history log: ! +! ! +! see list in program "radsw_rrtm3_main.f" ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + + +!> \ingroup module_radlw_main +!> This module contains the reference pressures (in logarithm form) at +!! 59 vertical levels (TOA is omitted), and the mid-latitude summer +!! (MLS) standard temperature profile for the 59 pressure layers that +!! are used to establish pre calculated transmission tables. +!! +!========================================! + module module_radsw_ref ! +!........................................! +! + use physparam, only : kind_phys +! + implicit none +! + public + +!> logarithm,ln(p), of a 59-level standard pressure profile + real (kind=kind_phys), dimension(59) :: preflog +!> MLS standard atmosphere temperature at the standard pressure levels + real (kind=kind_phys), dimension(59) :: tref + +! ... these pressures are chosen such that the ln of the first pressure +! has only a few non-zero digits (i.e. ln(pref(1)) = 6.96000) and +! each subsequent ln(pressure) differs from the previous one by 0.2. + +! data pref(:) / & +! & 1.05363e+03,8.62642e+02,7.06272e+02,5.78246e+02,4.73428e+02, & +! & 3.87610e+02,3.17348e+02,2.59823e+02,2.12725e+02,1.74164e+02, & +! & 1.42594e+02,1.16746e+02,9.55835e+01,7.82571e+01,6.40715e+01, & +! & 5.24573e+01,4.29484e+01,3.51632e+01,2.87892e+01,2.35706e+01, & +! & 1.92980e+01,1.57998e+01,1.29358e+01,1.05910e+01,8.67114e+00, & +! & 7.09933e+00,5.81244e+00,4.75882e+00,3.89619e+00,3.18993e+00, & +! & 2.61170e+00,2.13828e+00,1.75067e+00,1.43333e+00,1.17351e+00, & +! & 9.60789e-01,7.86628e-01,6.44036e-01,5.27292e-01,4.31710e-01, & +! & 3.53455e-01,2.89384e-01,2.36928e-01,1.93980e-01,1.58817e-01, & +! & 1.30029e-01,1.06458e-01,8.71608e-02,7.13612e-02,5.84256e-02, & +! & 4.78349e-02,3.91639e-02,3.20647e-02,2.62523e-02,2.14936e-02, & +! & 1.75975e-02,1.44076e-02,1.17959e-02,9.65769e-03 / + + data preflog(:) / & + & 6.9600e+00, 6.7600e+00, 6.5600e+00, 6.3600e+00, 6.1600e+00, & + & 5.9600e+00, 5.7600e+00, 5.5600e+00, 5.3600e+00, 5.1600e+00, & + & 4.9600e+00, 4.7600e+00, 4.5600e+00, 4.3600e+00, 4.1600e+00, & + & 3.9600e+00, 3.7600e+00, 3.5600e+00, 3.3600e+00, 3.1600e+00, & + & 2.9600e+00, 2.7600e+00, 2.5600e+00, 2.3600e+00, 2.1600e+00, & + & 1.9600e+00, 1.7600e+00, 1.5600e+00, 1.3600e+00, 1.1600e+00, & + & 9.6000e-01, 7.6000e-01, 5.6000e-01, 3.6000e-01, 1.6000e-01, & + & -4.0000e-02,-2.4000e-01,-4.4000e-01,-6.4000e-01,-8.4000e-01, & + & -1.0400e+00,-1.2400e+00,-1.4400e+00,-1.6400e+00,-1.8400e+00, & + & -2.0400e+00,-2.2400e+00,-2.4400e+00,-2.6400e+00,-2.8400e+00, & + & -3.0400e+00,-3.2400e+00,-3.4400e+00,-3.6400e+00,-3.8400e+00, & + & -4.0400e+00,-4.2400e+00,-4.4400e+00,-4.6400e+00 / + +! ... these are the temperatures associated with the respective +! pressures for the MLS standard atmosphere. + data tref(:) / & + & 2.9420e+02, 2.8799e+02, 2.7894e+02, 2.6925e+02, 2.5983e+02, & + & 2.5017e+02, 2.4077e+02, 2.3179e+02, 2.2306e+02, 2.1578e+02, & + & 2.1570e+02, 2.1570e+02, 2.1570e+02, 2.1706e+02, 2.1858e+02, & + & 2.2018e+02, 2.2174e+02, 2.2328e+02, 2.2479e+02, 2.2655e+02, & + & 2.2834e+02, 2.3113e+02, 2.3401e+02, 2.3703e+02, 2.4022e+02, & + & 2.4371e+02, 2.4726e+02, 2.5085e+02, 2.5457e+02, 2.5832e+02, & + & 2.6216e+02, 2.6606e+02, 2.6999e+02, 2.7340e+02, 2.7536e+02, & + & 2.7568e+02, 2.7372e+02, 2.7163e+02, 2.6955e+02, 2.6593e+02, & + & 2.6211e+02, 2.5828e+02, 2.5360e+02, 2.4854e+02, 2.4348e+02, & + & 2.3809e+02, 2.3206e+02, 2.2603e+02, 2.2000e+02, 2.1435e+02, & + & 2.0887e+02, 2.0340e+02, 1.9792e+02, 1.9290e+02, 1.8809e+02, & + & 1.8329e+02, 1.7849e+02, 1.7394e+02, 1.7212e+02 / + +!........................................! + end module module_radsw_ref ! +!========================================! + +!> \ingroup module_radlw_main +!> This module contains cloud radiative property coefficients. +!! +!! For liquid water clouds, cloud radiative property coefficients are +!! derived from Hu and Stamnes method (1993)\cite hu_and_stamnes_1993. +!! For ice clouds, there are various choices for model applications, +!! including data tables derived from Ebert and Curry (1992) +!! \cite ebert_and_curry_1992, from the Streamer scheme (Key,2002 +!! \cite key_2002), or from Fu (1996) \cite fu_1996 . Components of +!! snow particles and rain droplets are not parameterized in the +!! operational NEMS/GSM cloud microphysics scheme, and their radiative +!! properties are neither well established yet. Coefficients for those +!! components listed in the module are more experimental oriented that +!! include the entries for snow from Fu (2001, personal communications), +!! and for rain from Chou and Suarez (1999) \cite chou_and_suarez_1999. +!!\n In common practices, the cloud radiative properties (optical depth, +!! single scattering albedo, and asymmetry factor) are usually parametized +!! in the form of a truncated Laurent series (generalized Taylor series) +!!\f[ +!! f(x)=\sum_{n=-N}^Na_{n}(x-c)^n +!!\f] +!! Where \f$x\f$ represents the cloud particle's effective radius (in +!! Fu's scheme, it is called as generalized size parameter) in unites of +!! micro-meters, \f$a_{n}\f$ represents the corresponding coefficients, +!! and the constant \f$c\f$ will be zero. The number of terms, \f$n\f$, +!! are usually kept small, such as \f$n=0,-1\f$ for the extinction +!! coefficients and \f$n=0,1,2\f$ (or a bit larger) for the coefficients +!! of single scattering albedo and asymmetry factor. When using the +!! Ebert and Curry cloud optical property scheme, cloud optical properties +!! are computed 'on the fly' by using the power series in five broad +!! spectral bands (similar expressions are used for Fu's snow and Chou's +!! rain schemes). While for other schemes, optical properties are +!! precomputed for each of the 14 RRTMG-SW bands in corresponding to +!! evenly distributed particle effective radius (e.g. 1 or 3 micro-meter +!! intervals for water or ice clouds, respectively). Simple linear +!! interpolations will be used during radiative transfer calculations. +!========================================! + module module_radsw_cldprtb ! +!........................................! +! +! *********************** module descriptions ********************** ! +! ! +! this module contains coefficients of cloud-optical properties ! +! for each of the spectral bands. modified from aer/ecmwf rrtm ! +! sw radiation package subroutine "susrtop". ! +! ! +! modify history: ! +! jan 2004 -- yu-tai hou convert subroutine to data ! +! module for ncep models. ! +! jun 2008 -- yu-tai hou modified to use aer's newer ! +! release v3.5 data table for cloud ice particles ! +! ! +! ********* the original program descriptions ********* ! +! ! +! adapted from j. delamere, atmospheric & environmental research. ! +! by jjmorcrette, ecmwf 02/10/29 ! +! revision: j.d. 2.6 2002/04/04 18:29:47 ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! name type purpose +! ---- : ---- : --------------------------------------------------! +! xxxliq1 : real : optical properties (extinction coefficient, single! +! scattering albedo, assymetry factor) from ! +! hu & stamnes, 1993, j. clim., 6, 728-742 ! +! xbari : real : optical properties (extinction coefficient, single! +! scattering albedo, assymetry factor) calculated ! +! based on ebert and curry method, jgr, 1992 ! +! xxxice2 : real : optical properties (extinction coefficient, single! +! scattering albedo, assymetry factor) from ! +! streamer v3.0, key.j.streamer user's guide, ! +! cooperative institute for meteorological satellite! +! studies, 2001, 96 pp. ! +! xxxice3 : real : optical properties (extinction coefficient, single! +! scattering albedo, assymetry factor) from ! +! fu, 1996, j. clim., 9, ! +! ! +! ************************* end description ************************ ! + + use physparam, only : kind_phys + use module_radsw_parameters, only : nblow, nbhgh +! + implicit none +! + private + +! +! === for iflagliq = 0, +! cloud optical properties are external inputs to the main program + +! === everything below is for iflagliq >= 1. +!>\name Hu and Stamnes (1993) coefficients for cloud liquid condensate (used if iswcliq=1) + +!> extinction coefficients + real (kind=kind_phys), dimension(58,nblow:nbhgh), public :: & + & extliq1 +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(58,nblow:nbhgh), public :: & + & ssaliq1 +!> asymmetry coefficients + real (kind=kind_phys), dimension(58,nblow:nbhgh), public :: & + & asyliq1 +!>\name Streamer V3 (Key 2002) coefficients for cloud ice condensate (used if iswcice=2) + +!> extinction coefficients + real (kind=kind_phys), dimension(43,nblow:nbhgh), public :: & + & extice2 +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(43,nblow:nbhgh), public :: & + & ssaice2 +!> asymmetry coefficients + real (kind=kind_phys), dimension(43,nblow:nbhgh), public :: & + & asyice2 + +!>\name Fu(1996) coefficients for cloud ice condensate (used if iswcice=3) + +!> extinction coefficients + real (kind=kind_phys), dimension(46,nblow:nbhgh), public :: & + & extice3 +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(46,nblow:nbhgh), public :: & + & ssaice3 +!> asymmetry coefficients + real (kind=kind_phys), dimension(46,nblow:nbhgh), public :: & + & asyice3 +!> fdelta from fu, unitless + real (kind=kind_phys), dimension(46,nblow:nbhgh), public :: & + & fdlice3 + +!> \name Ebert and Curry (1992) coefficients for cloud ice condensate (used if iswcice=1) + +!> extinction coefficients + real (kind=kind_phys), dimension(5), public :: abari +!> extinction coefficients + real (kind=kind_phys), dimension(5), public :: bbari +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(5), public :: cbari +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(5), public :: dbari +!> asymmetry coefficients + real (kind=kind_phys), dimension(5), public :: ebari +!> asymmetry coefficients + real (kind=kind_phys), dimension(5), public :: fbari + +! --- ... coefficients from ebert and curry method + data abari(:)/ 3.448e-03,3.448e-03,3.448e-03,3.448e-03,3.448e-03 / + data bbari(:)/ 2.431e+00,2.431e+00,2.431e+00,2.431e+00,2.431e+00 / + data cbari(:)/ 1.000e-05,1.100e-04,1.240e-02,3.779e-02,4.666e-01 / + data dbari(:)/ 0.000e+00,1.405e-05,6.867e-04,1.284e-03,2.050e-05 / + data ebari(:)/ 7.661e-01,7.730e-01,7.865e-01,8.172e-01,9.595e-01 / + data fbari(:)/ 5.851e-04,5.665e-04,7.204e-04,7.463e-04,1.076e-04 / + +! --- ... extinction coefficient from hu and stamnes + data extliq1(:, 16) / & + & 8.981463e-01,6.317895e-01,4.557508e-01,3.481624e-01,2.797950e-01,& + & 2.342753e-01,2.026934e-01,1.800102e-01,1.632408e-01,1.505384e-01,& + & 1.354524e-01,1.246520e-01,1.154342e-01,1.074756e-01,1.005353e-01,& + & 9.442987e-02,8.901760e-02,8.418693e-02,7.984904e-02,7.593229e-02,& + & 7.237827e-02,6.913887e-02,6.617415e-02,6.345061e-02,6.094001e-02,& + & 5.861834e-02,5.646506e-02,5.446250e-02,5.249596e-02,5.081114e-02,& + & 4.922243e-02,4.772189e-02,4.630243e-02,4.495766e-02,4.368189e-02,& + & 4.246995e-02,4.131720e-02,4.021941e-02,3.917276e-02,3.817376e-02,& + & 3.721926e-02,3.630635e-02,3.543237e-02,3.459491e-02,3.379171e-02,& + & 3.302073e-02,3.228007e-02,3.156798e-02,3.088284e-02,3.022315e-02,& + & 2.958753e-02,2.897468e-02,2.838340e-02,2.781258e-02,2.726117e-02,& + & 2.672821e-02,2.621278e-02,2.5714e-02 / + data extliq1(:, 17) / & + & 8.293797e-01,6.048371e-01,4.465706e-01,3.460387e-01,2.800064e-01,& + & 2.346584e-01,2.022399e-01,1.782626e-01,1.600153e-01,1.457903e-01,& + & 1.334061e-01,1.228548e-01,1.138396e-01,1.060486e-01,9.924856e-02,& + & 9.326208e-02,8.795158e-02,8.320883e-02,7.894750e-02,7.509792e-02,& + & 7.160323e-02,6.841653e-02,6.549889e-02,6.281763e-02,6.034516e-02,& + & 5.805802e-02,5.593615e-02,5.396226e-02,5.202302e-02,5.036246e-02,& + & 4.879606e-02,4.731610e-02,4.591565e-02,4.458852e-02,4.332912e-02,& + & 4.213243e-02,4.099390e-02,3.990941e-02,3.887522e-02,3.788792e-02,& + & 3.694440e-02,3.604183e-02,3.517760e-02,3.434934e-02,3.355485e-02,& + & 3.279211e-02,3.205925e-02,3.135458e-02,3.067648e-02,3.002349e-02,& + & 2.939425e-02,2.878748e-02,2.820200e-02,2.763673e-02,2.709062e-02,& + & 2.656272e-02,2.605214e-02,2.5558e-02 / + data extliq1(:, 18) / & + & 9.193685e-01,6.128292e-01,4.344150e-01,3.303048e-01,2.659500e-01,& + & 2.239727e-01,1.953457e-01,1.751012e-01,1.603515e-01,1.493360e-01,& + & 1.323791e-01,1.219335e-01,1.130076e-01,1.052926e-01,9.855839e-02,& + & 9.262925e-02,8.736918e-02,8.267112e-02,7.844965e-02,7.463585e-02,& + & 7.117343e-02,6.801601e-02,6.512503e-02,6.246815e-02,6.001806e-02,& + & 5.775154e-02,5.564872e-02,5.369250e-02,5.176284e-02,5.011536e-02,& + & 4.856099e-02,4.709211e-02,4.570193e-02,4.438430e-02,4.313375e-02,& + & 4.194529e-02,4.081443e-02,3.973712e-02,3.870966e-02,3.772866e-02,& + & 3.679108e-02,3.589409e-02,3.503514e-02,3.421185e-02,3.342206e-02,& + & 3.266377e-02,3.193513e-02,3.123447e-02,3.056018e-02,2.991081e-02,& + & 2.928502e-02,2.868154e-02,2.809920e-02,2.753692e-02,2.699367e-02,& + & 2.646852e-02,2.596057e-02,2.5469e-02 / + data extliq1(:, 19) / & + & 9.136931e-01,5.743244e-01,4.080708e-01,3.150572e-01,2.577261e-01,& + & 2.197900e-01,1.933037e-01,1.740212e-01,1.595056e-01,1.482756e-01,& + & 1.312164e-01,1.209246e-01,1.121227e-01,1.045095e-01,9.785967e-02,& + & 9.200149e-02,8.680170e-02,8.215531e-02,7.797850e-02,7.420361e-02,& + & 7.077530e-02,6.764798e-02,6.478369e-02,6.215063e-02,5.972189e-02,& + & 5.747458e-02,5.538913e-02,5.344866e-02,5.153216e-02,4.989745e-02,& + & 4.835476e-02,4.689661e-02,4.551629e-02,4.420777e-02,4.296563e-02,& + & 4.178497e-02,4.066137e-02,3.959081e-02,3.856963e-02,3.759452e-02,& + & 3.666244e-02,3.577061e-02,3.491650e-02,3.409777e-02,3.331227e-02,& + & 3.255803e-02,3.183322e-02,3.113617e-02,3.046530e-02,2.981918e-02,& + & 2.919646e-02,2.859591e-02,2.801635e-02,2.745671e-02,2.691599e-02,& + & 2.639324e-02,2.588759e-02,2.5398e-02 / + data extliq1(:, 20) / & + & 8.447548e-01,5.326840e-01,3.921523e-01,3.119082e-01,2.597055e-01,& + & 2.228737e-01,1.954157e-01,1.741155e-01,1.570881e-01,1.431520e-01,& + & 1.302034e-01,1.200491e-01,1.113571e-01,1.038330e-01,9.725657e-02,& + & 9.145949e-02,8.631112e-02,8.170840e-02,7.756901e-02,7.382641e-02,& + & 7.042616e-02,6.732338e-02,6.448069e-02,6.186672e-02,5.945494e-02,& + & 5.722277e-02,5.515089e-02,5.322262e-02,5.132153e-02,4.969799e-02,& + & 4.816556e-02,4.671686e-02,4.534525e-02,4.404480e-02,4.281014e-02,& + & 4.163643e-02,4.051930e-02,3.945479e-02,3.843927e-02,3.746945e-02,& + & 3.654234e-02,3.565518e-02,3.480547e-02,3.399088e-02,3.320930e-02,& + & 3.245876e-02,3.173745e-02,3.104371e-02,3.037600e-02,2.973287e-02,& + & 2.911300e-02,2.851516e-02,2.793818e-02,2.738101e-02,2.684264e-02,& + & 2.632214e-02,2.581863e-02,2.5331e-02 / + data extliq1(:, 21) / & + & 7.727642e-01,5.034865e-01,3.808673e-01,3.080333e-01,2.586453e-01,& + & 2.224989e-01,1.947060e-01,1.725821e-01,1.545096e-01,1.394456e-01,& + & 1.288683e-01,1.188852e-01,1.103317e-01,1.029214e-01,9.643967e-02,& + & 9.072239e-02,8.564194e-02,8.109758e-02,7.700875e-02,7.331026e-02,& + & 6.994879e-02,6.688028e-02,6.406807e-02,6.148133e-02,5.909400e-02,& + & 5.688388e-02,5.483197e-02,5.292185e-02,5.103763e-02,4.942905e-02,& + & 4.791039e-02,4.647438e-02,4.511453e-02,4.382497e-02,4.260043e-02,& + & 4.143616e-02,4.032784e-02,3.927155e-02,3.826375e-02,3.730117e-02,& + & 3.638087e-02,3.550013e-02,3.465646e-02,3.384759e-02,3.307141e-02,& + & 3.232598e-02,3.160953e-02,3.092040e-02,3.025706e-02,2.961810e-02,& + & 2.900220e-02,2.840814e-02,2.783478e-02,2.728106e-02,2.674599e-02,& + & 2.622864e-02,2.572816e-02,2.5244e-02 / + data extliq1(:, 22) / & + & 7.416833e-01,4.959591e-01,3.775057e-01,3.056353e-01,2.565943e-01,& + & 2.206935e-01,1.931479e-01,1.712860e-01,1.534837e-01,1.386906e-01,& + & 1.281198e-01,1.182344e-01,1.097595e-01,1.024137e-01,9.598552e-02,& + & 9.031320e-02,8.527093e-02,8.075927e-02,7.669869e-02,7.302481e-02,& + & 6.968491e-02,6.663542e-02,6.384008e-02,6.126838e-02,5.889452e-02,& + & 5.669654e-02,5.465558e-02,5.275540e-02,5.087937e-02,4.927904e-02,& + & 4.776796e-02,4.633895e-02,4.498557e-02,4.370202e-02,4.248306e-02,& + & 4.132399e-02,4.022052e-02,3.916878e-02,3.816523e-02,3.720665e-02,& + & 3.629011e-02,3.541290e-02,3.457257e-02,3.376685e-02,3.299365e-02,& + & 3.225105e-02,3.153728e-02,3.085069e-02,3.018977e-02,2.955310e-02,& + & 2.893940e-02,2.834742e-02,2.777606e-02,2.722424e-02,2.669099e-02,& + & 2.617539e-02,2.567658e-02,2.5194e-02 / + data extliq1(:, 23) / & + & 7.058580e-01,4.866573e-01,3.712238e-01,2.998638e-01,2.513441e-01,& + & 2.161972e-01,1.895576e-01,1.686669e-01,1.518437e-01,1.380046e-01,& + & 1.267564e-01,1.170399e-01,1.087026e-01,1.014704e-01,9.513729e-02,& + & 8.954555e-02,8.457221e-02,8.012009e-02,7.611136e-02,7.248294e-02,& + & 6.918317e-02,6.616934e-02,6.340584e-02,6.086273e-02,5.851465e-02,& + & 5.634001e-02,5.432027e-02,5.243946e-02,5.058070e-02,4.899628e-02,& + & 4.749975e-02,4.608411e-02,4.474303e-02,4.347082e-02,4.226237e-02,& + & 4.111303e-02,4.001861e-02,3.897528e-02,3.797959e-02,3.702835e-02,& + & 3.611867e-02,3.524791e-02,3.441364e-02,3.361360e-02,3.284577e-02,& + & 3.210823e-02,3.139923e-02,3.071716e-02,3.006052e-02,2.942791e-02,& + & 2.881806e-02,2.822974e-02,2.766185e-02,2.711335e-02,2.658326e-02,& + & 2.607066e-02,2.557473e-02,2.5095e-02 / + data extliq1(:, 24) / & + & 6.822779e-01,4.750373e-01,3.634834e-01,2.940726e-01,2.468060e-01,& + & 2.125768e-01,1.866586e-01,1.663588e-01,1.500326e-01,1.366192e-01,& + & 1.253472e-01,1.158052e-01,1.076101e-01,1.004954e-01,9.426089e-02,& + & 8.875268e-02,8.385090e-02,7.946063e-02,7.550578e-02,7.192466e-02,& + & 6.866669e-02,6.569001e-02,6.295971e-02,6.044642e-02,5.812526e-02,& + & 5.597500e-02,5.397746e-02,5.211690e-02,5.027505e-02,4.870703e-02,& + & 4.722555e-02,4.582373e-02,4.449540e-02,4.323497e-02,4.203742e-02,& + & 4.089821e-02,3.981321e-02,3.877867e-02,3.779118e-02,3.684762e-02,& + & 3.594514e-02,3.508114e-02,3.425322e-02,3.345917e-02,3.269698e-02,& + & 3.196477e-02,3.126082e-02,3.058352e-02,2.993141e-02,2.930310e-02,& + & 2.869732e-02,2.811289e-02,2.754869e-02,2.700371e-02,2.647698e-02,& + & 2.596760e-02,2.547473e-02,2.4998e-02 / + data extliq1(:, 25) / & + & 6.666233e-01,4.662044e-01,3.579517e-01,2.902984e-01,2.440475e-01,& + & 2.104431e-01,1.849277e-01,1.648970e-01,1.487555e-01,1.354714e-01,& + & 1.244173e-01,1.149913e-01,1.068903e-01,9.985323e-02,9.368351e-02,& + & 8.823009e-02,8.337507e-02,7.902511e-02,7.510529e-02,7.155482e-02,& + & 6.832386e-02,6.537113e-02,6.266218e-02,6.016802e-02,5.786408e-02,& + & 5.572939e-02,5.374598e-02,5.189830e-02,5.006825e-02,4.851081e-02,& + & 4.703906e-02,4.564623e-02,4.432621e-02,4.307349e-02,4.188312e-02,& + & 4.075060e-02,3.967183e-02,3.864313e-02,3.766111e-02,3.672269e-02,& + & 3.582505e-02,3.496559e-02,3.414196e-02,3.335198e-02,3.259362e-02,& + & 3.186505e-02,3.116454e-02,3.049052e-02,2.984152e-02,2.921617e-02,& + & 2.861322e-02,2.803148e-02,2.746986e-02,2.692733e-02,2.640295e-02,& + & 2.589582e-02,2.540510e-02,2.4930e-02 / + data extliq1(:, 26) / & + & 6.535669e-01,4.585865e-01,3.529226e-01,2.867245e-01,2.413848e-01,& + & 2.083956e-01,1.833191e-01,1.636150e-01,1.477247e-01,1.346392e-01,& + & 1.236449e-01,1.143095e-01,1.062828e-01,9.930773e-02,9.319029e-02,& + & 8.778150e-02,8.296497e-02,7.864847e-02,7.475799e-02,7.123343e-02,& + & 6.802549e-02,6.509332e-02,6.240285e-02,5.992538e-02,5.763657e-02,& + & 5.551566e-02,5.354483e-02,5.170870e-02,4.988866e-02,4.834061e-02,& + & 4.687751e-02,4.549264e-02,4.417999e-02,4.293410e-02,4.175006e-02,& + & 4.062344e-02,3.955019e-02,3.852663e-02,3.754943e-02,3.661553e-02,& + & 3.572214e-02,3.486669e-02,3.404683e-02,3.326040e-02,3.250542e-02,& + & 3.178003e-02,3.108254e-02,3.041139e-02,2.976511e-02,2.914235e-02,& + & 2.854187e-02,2.796247e-02,2.740309e-02,2.686271e-02,2.634038e-02,& + & 2.583520e-02,2.534636e-02,2.4873e-02 / + data extliq1(:, 27) / & + & 6.448790e-01,4.541425e-01,3.503348e-01,2.850494e-01,2.401966e-01,& + & 2.074811e-01,1.825631e-01,1.629515e-01,1.471142e-01,1.340574e-01,& + & 1.231462e-01,1.138628e-01,1.058802e-01,9.894286e-02,9.285818e-02,& + & 8.747802e-02,8.268676e-02,7.839271e-02,7.452230e-02,7.101580e-02,& + & 6.782418e-02,6.490685e-02,6.222991e-02,5.976484e-02,5.748742e-02,& + & 5.537703e-02,5.341593e-02,5.158883e-02,4.977355e-02,4.823172e-02,& + & 4.677430e-02,4.539465e-02,4.408680e-02,4.284533e-02,4.166539e-02,& + & 4.054257e-02,3.947283e-02,3.845256e-02,3.747842e-02,3.654737e-02,& + & 3.565665e-02,3.480370e-02,3.398620e-02,3.320198e-02,3.244908e-02,& + & 3.172566e-02,3.103002e-02,3.036062e-02,2.971600e-02,2.909482e-02,& + & 2.849582e-02,2.791785e-02,2.735982e-02,2.682072e-02,2.629960e-02,& + & 2.579559e-02,2.530786e-02,2.4836e-02 / + data extliq1(:, 28) / & + & 6.422688e-01,4.528453e-01,3.497232e-01,2.847724e-01,2.400815e-01,& + & 2.074403e-01,1.825502e-01,1.629415e-01,1.470934e-01,1.340183e-01,& + & 1.230935e-01,1.138049e-01,1.058201e-01,9.888245e-02,9.279878e-02,& + & 8.742053e-02,8.263175e-02,7.834058e-02,7.447327e-02,7.097000e-02,& + & 6.778167e-02,6.486765e-02,6.219400e-02,5.973215e-02,5.745790e-02,& + & 5.535059e-02,5.339250e-02,5.156831e-02,4.975308e-02,4.821235e-02,& + & 4.675596e-02,4.537727e-02,4.407030e-02,4.282968e-02,4.165053e-02,& + & 4.052845e-02,3.945941e-02,3.843980e-02,3.746628e-02,3.653583e-02,& + & 3.564567e-02,3.479326e-02,3.397626e-02,3.319253e-02,3.244008e-02,& + & 3.171711e-02,3.102189e-02,3.035289e-02,2.970866e-02,2.908784e-02,& + & 2.848920e-02,2.791156e-02,2.735385e-02,2.681507e-02,2.629425e-02,& + & 2.579053e-02,2.530308e-02,2.4831e-02 / + data extliq1(:, 29) / & + & 4.614710e-01,4.556116e-01,4.056568e-01,3.529833e-01,3.060334e-01,& + & 2.658127e-01,2.316095e-01,2.024325e-01,1.773749e-01,1.556867e-01,& + & 1.455558e-01,1.332882e-01,1.229052e-01,1.140067e-01,1.062981e-01,& + & 9.955703e-02,9.361333e-02,8.833420e-02,8.361467e-02,7.937071e-02,& + & 7.553420e-02,7.204942e-02,6.887031e-02,6.595851e-02,6.328178e-02,& + & 6.081286e-02,5.852854e-02,5.640892e-02,5.431269e-02,5.252561e-02,& + & 5.084345e-02,4.925727e-02,4.775910e-02,4.634182e-02,4.499907e-02,& + & 4.372512e-02,4.251484e-02,4.136357e-02,4.026710e-02,3.922162e-02,& + & 3.822365e-02,3.727004e-02,3.635790e-02,3.548457e-02,3.464764e-02,& + & 3.384488e-02,3.307424e-02,3.233384e-02,3.162192e-02,3.093688e-02,& + & 3.027723e-02,2.964158e-02,2.902864e-02,2.843722e-02,2.786621e-02,& + & 2.731457e-02,2.678133e-02,2.6266e-02 / + +! --- ... single scattering albedo from hu and stamnes + data ssaliq1(:, 16) / & + & 8.143821e-01,7.836739e-01,7.550722e-01,7.306269e-01,7.105612e-01,& + & 6.946649e-01,6.825556e-01,6.737762e-01,6.678448e-01,6.642830e-01,& + & 6.679741e-01,6.584607e-01,6.505598e-01,6.440951e-01,6.388901e-01,& + & 6.347689e-01,6.315549e-01,6.290718e-01,6.271432e-01,6.255928e-01,& + & 6.242441e-01,6.229207e-01,6.214464e-01,6.196445e-01,6.173388e-01,& + & 6.143527e-01,6.105099e-01,6.056339e-01,6.108290e-01,6.073939e-01,& + & 6.043073e-01,6.015473e-01,5.990913e-01,5.969173e-01,5.950028e-01,& + & 5.933257e-01,5.918636e-01,5.905944e-01,5.894957e-01,5.885453e-01,& + & 5.877209e-01,5.870003e-01,5.863611e-01,5.857811e-01,5.852381e-01,& + & 5.847098e-01,5.841738e-01,5.836081e-01,5.829901e-01,5.822979e-01,& + & 5.815089e-01,5.806011e-01,5.795521e-01,5.783396e-01,5.769413e-01,& + & 5.753351e-01,5.734986e-01,5.7141e-01 / + data ssaliq1(:, 17) / & + & 8.165821e-01,8.002015e-01,7.816921e-01,7.634131e-01,7.463721e-01,& + & 7.312469e-01,7.185883e-01,7.088975e-01,7.026671e-01,7.004020e-01,& + & 7.042138e-01,6.960930e-01,6.894243e-01,6.840459e-01,6.797957e-01,& + & 6.765119e-01,6.740325e-01,6.721955e-01,6.708391e-01,6.698013e-01,& + & 6.689201e-01,6.680339e-01,6.669805e-01,6.655982e-01,6.637250e-01,& + & 6.611992e-01,6.578588e-01,6.535420e-01,6.584449e-01,6.553992e-01,& + & 6.526547e-01,6.501917e-01,6.479905e-01,6.460313e-01,6.442945e-01,& + & 6.427605e-01,6.414094e-01,6.402217e-01,6.391775e-01,6.382573e-01,& + & 6.374413e-01,6.367099e-01,6.360433e-01,6.354218e-01,6.348257e-01,& + & 6.342355e-01,6.336313e-01,6.329935e-01,6.323023e-01,6.315383e-01,& + & 6.306814e-01,6.297122e-01,6.286110e-01,6.273579e-01,6.259333e-01,& + & 6.243176e-01,6.224910e-01,6.2043e-01 / + data ssaliq1(:, 18) / & + & 9.900163e-01,9.854307e-01,9.797730e-01,9.733113e-01,9.664245e-01,& + & 9.594976e-01,9.529055e-01,9.470112e-01,9.421695e-01,9.387304e-01,& + & 9.344918e-01,9.305302e-01,9.267048e-01,9.230072e-01,9.194289e-01,& + & 9.159616e-01,9.125968e-01,9.093260e-01,9.061409e-01,9.030330e-01,& + & 8.999940e-01,8.970154e-01,8.940888e-01,8.912058e-01,8.883579e-01,& + & 8.855368e-01,8.827341e-01,8.799413e-01,8.777423e-01,8.749566e-01,& + & 8.722298e-01,8.695605e-01,8.669469e-01,8.643875e-01,8.618806e-01,& + & 8.594246e-01,8.570179e-01,8.546589e-01,8.523459e-01,8.500773e-01,& + & 8.478516e-01,8.456670e-01,8.435219e-01,8.414148e-01,8.393439e-01,& + & 8.373078e-01,8.353047e-01,8.333330e-01,8.313911e-01,8.294774e-01,& + & 8.275904e-01,8.257282e-01,8.238893e-01,8.220721e-01,8.202751e-01,& + & 8.184965e-01,8.167346e-01,8.1499e-01 / + data ssaliq1(:, 19) / & + & 9.999916e-01,9.987396e-01,9.966900e-01,9.950738e-01,9.937531e-01,& + & 9.925912e-01,9.914525e-01,9.902018e-01,9.887046e-01,9.868263e-01,& + & 9.849039e-01,9.832372e-01,9.815265e-01,9.797770e-01,9.779940e-01,& + & 9.761827e-01,9.743481e-01,9.724955e-01,9.706303e-01,9.687575e-01,& + & 9.668823e-01,9.650100e-01,9.631457e-01,9.612947e-01,9.594622e-01,& + & 9.576534e-01,9.558734e-01,9.541275e-01,9.522059e-01,9.504258e-01,& + & 9.486459e-01,9.468676e-01,9.450921e-01,9.433208e-01,9.415548e-01,& + & 9.397955e-01,9.380441e-01,9.363022e-01,9.345706e-01,9.328510e-01,& + & 9.311445e-01,9.294524e-01,9.277761e-01,9.261167e-01,9.244755e-01,& + & 9.228540e-01,9.212534e-01,9.196748e-01,9.181197e-01,9.165894e-01,& + & 9.150851e-01,9.136080e-01,9.121596e-01,9.107410e-01,9.093536e-01,& + & 9.079987e-01,9.066775e-01,9.0539e-01 / + data ssaliq1(:, 20) / & + & 9.979493e-01,9.964113e-01,9.950014e-01,9.937045e-01,9.924964e-01,& + & 9.913546e-01,9.902575e-01,9.891843e-01,9.881136e-01,9.870238e-01,& + & 9.859934e-01,9.849372e-01,9.838873e-01,9.828434e-01,9.818052e-01,& + & 9.807725e-01,9.797450e-01,9.787225e-01,9.777047e-01,9.766914e-01,& + & 9.756823e-01,9.746771e-01,9.736756e-01,9.726775e-01,9.716827e-01,& + & 9.706907e-01,9.697014e-01,9.687145e-01,9.678060e-01,9.668108e-01,& + & 9.658218e-01,9.648391e-01,9.638629e-01,9.628936e-01,9.619313e-01,& + & 9.609763e-01,9.600287e-01,9.590888e-01,9.581569e-01,9.572330e-01,& + & 9.563176e-01,9.554108e-01,9.545128e-01,9.536239e-01,9.527443e-01,& + & 9.518741e-01,9.510137e-01,9.501633e-01,9.493230e-01,9.484931e-01,& + & 9.476740e-01,9.468656e-01,9.460683e-01,9.452824e-01,9.445080e-01,& + & 9.437454e-01,9.429948e-01,9.4226e-01 / + data ssaliq1(:, 21) / & + & 9.988742e-01,9.982668e-01,9.976935e-01,9.971497e-01,9.966314e-01,& + & 9.961344e-01,9.956545e-01,9.951873e-01,9.947286e-01,9.942741e-01,& + & 9.938457e-01,9.933947e-01,9.929473e-01,9.925032e-01,9.920621e-01,& + & 9.916237e-01,9.911875e-01,9.907534e-01,9.903209e-01,9.898898e-01,& + & 9.894597e-01,9.890304e-01,9.886015e-01,9.881726e-01,9.877435e-01,& + & 9.873138e-01,9.868833e-01,9.864516e-01,9.860698e-01,9.856317e-01,& + & 9.851957e-01,9.847618e-01,9.843302e-01,9.839008e-01,9.834739e-01,& + & 9.830494e-01,9.826275e-01,9.822083e-01,9.817918e-01,9.813782e-01,& + & 9.809675e-01,9.805598e-01,9.801552e-01,9.797538e-01,9.793556e-01,& + & 9.789608e-01,9.785695e-01,9.781817e-01,9.777975e-01,9.774171e-01,& + & 9.770404e-01,9.766676e-01,9.762988e-01,9.759340e-01,9.755733e-01,& + & 9.752169e-01,9.748649e-01,9.7452e-01 / + data ssaliq1(:, 22) / & + & 9.994441e-01,9.991608e-01,9.988949e-01,9.986439e-01,9.984054e-01,& + & 9.981768e-01,9.979557e-01,9.977396e-01,9.975258e-01,9.973120e-01,& + & 9.971011e-01,9.968852e-01,9.966708e-01,9.964578e-01,9.962462e-01,& + & 9.960357e-01,9.958264e-01,9.956181e-01,9.954108e-01,9.952043e-01,& + & 9.949987e-01,9.947937e-01,9.945892e-01,9.943853e-01,9.941818e-01,& + & 9.939786e-01,9.937757e-01,9.935728e-01,9.933922e-01,9.931825e-01,& + & 9.929739e-01,9.927661e-01,9.925592e-01,9.923534e-01,9.921485e-01,& + & 9.919447e-01,9.917421e-01,9.915406e-01,9.913403e-01,9.911412e-01,& + & 9.909435e-01,9.907470e-01,9.905519e-01,9.903581e-01,9.901659e-01,& + & 9.899751e-01,9.897858e-01,9.895981e-01,9.894120e-01,9.892276e-01,& + & 9.890447e-01,9.888637e-01,9.886845e-01,9.885070e-01,9.883314e-01,& + & 9.881576e-01,9.879859e-01,9.8782e-01 / + data ssaliq1(:, 23) / & + & 9.999138e-01,9.998730e-01,9.998338e-01,9.997965e-01,9.997609e-01,& + & 9.997270e-01,9.996944e-01,9.996629e-01,9.996321e-01,9.996016e-01,& + & 9.995690e-01,9.995372e-01,9.995057e-01,9.994744e-01,9.994433e-01,& + & 9.994124e-01,9.993817e-01,9.993510e-01,9.993206e-01,9.992903e-01,& + & 9.992600e-01,9.992299e-01,9.991998e-01,9.991698e-01,9.991398e-01,& + & 9.991098e-01,9.990799e-01,9.990499e-01,9.990231e-01,9.989920e-01,& + & 9.989611e-01,9.989302e-01,9.988996e-01,9.988690e-01,9.988386e-01,& + & 9.988084e-01,9.987783e-01,9.987485e-01,9.987187e-01,9.986891e-01,& + & 9.986598e-01,9.986306e-01,9.986017e-01,9.985729e-01,9.985443e-01,& + & 9.985160e-01,9.984879e-01,9.984600e-01,9.984324e-01,9.984050e-01,& + & 9.983778e-01,9.983509e-01,9.983243e-01,9.982980e-01,9.982719e-01,& + & 9.982461e-01,9.982206e-01,9.9820e-01 / + data ssaliq1(:, 24) / & + & 9.999985e-01,9.999979e-01,9.999972e-01,9.999966e-01,9.999961e-01,& + & 9.999955e-01,9.999950e-01,9.999944e-01,9.999938e-01,9.999933e-01,& + & 9.999927e-01,9.999921e-01,9.999915e-01,9.999910e-01,9.999904e-01,& + & 9.999899e-01,9.999893e-01,9.999888e-01,9.999882e-01,9.999877e-01,& + & 9.999871e-01,9.999866e-01,9.999861e-01,9.999855e-01,9.999850e-01,& + & 9.999844e-01,9.999839e-01,9.999833e-01,9.999828e-01,9.999823e-01,& + & 9.999817e-01,9.999812e-01,9.999807e-01,9.999801e-01,9.999796e-01,& + & 9.999791e-01,9.999786e-01,9.999781e-01,9.999776e-01,9.999770e-01,& + & 9.999765e-01,9.999761e-01,9.999756e-01,9.999751e-01,9.999746e-01,& + & 9.999741e-01,9.999736e-01,9.999732e-01,9.999727e-01,9.999722e-01,& + & 9.999718e-01,9.999713e-01,9.999709e-01,9.999705e-01,9.999701e-01,& + & 9.999697e-01,9.999692e-01,9.9997e-01 / + data ssaliq1(:, 25) / & + & 9.999999e-01,9.999998e-01,9.999997e-01,9.999997e-01,9.999997e-01,& + & 9.999996e-01,9.999996e-01,9.999995e-01,9.999995e-01,9.999994e-01,& + & 9.999994e-01,9.999993e-01,9.999993e-01,9.999992e-01,9.999992e-01,& + & 9.999991e-01,9.999991e-01,9.999991e-01,9.999990e-01,9.999989e-01,& + & 9.999989e-01,9.999989e-01,9.999988e-01,9.999988e-01,9.999987e-01,& + & 9.999987e-01,9.999986e-01,9.999986e-01,9.999985e-01,9.999985e-01,& + & 9.999984e-01,9.999984e-01,9.999984e-01,9.999983e-01,9.999983e-01,& + & 9.999982e-01,9.999982e-01,9.999982e-01,9.999981e-01,9.999980e-01,& + & 9.999980e-01,9.999980e-01,9.999979e-01,9.999979e-01,9.999978e-01,& + & 9.999978e-01,9.999977e-01,9.999977e-01,9.999977e-01,9.999976e-01,& + & 9.999976e-01,9.999975e-01,9.999975e-01,9.999974e-01,9.999974e-01,& + & 9.999974e-01,9.999973e-01,1.0000e+00 / + data ssaliq1(:, 26) / & + & 9.999997e-01,9.999995e-01,9.999993e-01,9.999992e-01,9.999990e-01,& + & 9.999989e-01,9.999988e-01,9.999987e-01,9.999986e-01,9.999985e-01,& + & 9.999984e-01,9.999983e-01,9.999982e-01,9.999981e-01,9.999980e-01,& + & 9.999978e-01,9.999977e-01,9.999976e-01,9.999975e-01,9.999974e-01,& + & 9.999973e-01,9.999972e-01,9.999970e-01,9.999969e-01,9.999968e-01,& + & 9.999967e-01,9.999966e-01,9.999965e-01,9.999964e-01,9.999963e-01,& + & 9.999962e-01,9.999961e-01,9.999959e-01,9.999958e-01,9.999957e-01,& + & 9.999956e-01,9.999955e-01,9.999954e-01,9.999953e-01,9.999952e-01,& + & 9.999951e-01,9.999949e-01,9.999949e-01,9.999947e-01,9.999946e-01,& + & 9.999945e-01,9.999944e-01,9.999943e-01,9.999942e-01,9.999941e-01,& + & 9.999940e-01,9.999939e-01,9.999938e-01,9.999937e-01,9.999936e-01,& + & 9.999935e-01,9.999934e-01,9.9999e-01 / + data ssaliq1(:, 27) / & + & 9.999984e-01,9.999976e-01,9.999969e-01,9.999962e-01,9.999956e-01,& + & 9.999950e-01,9.999945e-01,9.999940e-01,9.999935e-01,9.999931e-01,& + & 9.999926e-01,9.999920e-01,9.999914e-01,9.999908e-01,9.999903e-01,& + & 9.999897e-01,9.999891e-01,9.999886e-01,9.999880e-01,9.999874e-01,& + & 9.999868e-01,9.999863e-01,9.999857e-01,9.999851e-01,9.999846e-01,& + & 9.999840e-01,9.999835e-01,9.999829e-01,9.999824e-01,9.999818e-01,& + & 9.999812e-01,9.999806e-01,9.999800e-01,9.999795e-01,9.999789e-01,& + & 9.999783e-01,9.999778e-01,9.999773e-01,9.999767e-01,9.999761e-01,& + & 9.999756e-01,9.999750e-01,9.999745e-01,9.999739e-01,9.999734e-01,& + & 9.999729e-01,9.999723e-01,9.999718e-01,9.999713e-01,9.999708e-01,& + & 9.999703e-01,9.999697e-01,9.999692e-01,9.999687e-01,9.999683e-01,& + & 9.999678e-01,9.999673e-01,9.9997e-01 / + data ssaliq1(:, 28) / & + & 9.999981e-01,9.999973e-01,9.999965e-01,9.999958e-01,9.999951e-01,& + & 9.999943e-01,9.999937e-01,9.999930e-01,9.999924e-01,9.999918e-01,& + & 9.999912e-01,9.999905e-01,9.999897e-01,9.999890e-01,9.999883e-01,& + & 9.999876e-01,9.999869e-01,9.999862e-01,9.999855e-01,9.999847e-01,& + & 9.999840e-01,9.999834e-01,9.999827e-01,9.999819e-01,9.999812e-01,& + & 9.999805e-01,9.999799e-01,9.999791e-01,9.999785e-01,9.999778e-01,& + & 9.999771e-01,9.999764e-01,9.999757e-01,9.999750e-01,9.999743e-01,& + & 9.999736e-01,9.999729e-01,9.999722e-01,9.999715e-01,9.999709e-01,& + & 9.999701e-01,9.999695e-01,9.999688e-01,9.999682e-01,9.999675e-01,& + & 9.999669e-01,9.999662e-01,9.999655e-01,9.999649e-01,9.999642e-01,& + & 9.999636e-01,9.999630e-01,9.999624e-01,9.999618e-01,9.999612e-01,& + & 9.999606e-01,9.999600e-01,9.9996e-01 / + data ssaliq1(:, 29) / & + & 8.505737e-01,8.465102e-01,8.394829e-01,8.279508e-01,8.110806e-01,& + & 7.900397e-01,7.669615e-01,7.444422e-01,7.253055e-01,7.124831e-01,& + & 7.016434e-01,6.885485e-01,6.767340e-01,6.661029e-01,6.565577e-01,& + & 6.480013e-01,6.403373e-01,6.334697e-01,6.273034e-01,6.217440e-01,& + & 6.166983e-01,6.120740e-01,6.077796e-01,6.037249e-01,5.998207e-01,& + & 5.959788e-01,5.921123e-01,5.881354e-01,5.891285e-01,5.851143e-01,& + & 5.814653e-01,5.781606e-01,5.751792e-01,5.724998e-01,5.701016e-01,& + & 5.679634e-01,5.660642e-01,5.643829e-01,5.628984e-01,5.615898e-01,& + & 5.604359e-01,5.594158e-01,5.585083e-01,5.576924e-01,5.569470e-01,& + & 5.562512e-01,5.555838e-01,5.549239e-01,5.542503e-01,5.535420e-01,& + & 5.527781e-01,5.519374e-01,5.509989e-01,5.499417e-01,5.487445e-01,& + & 5.473865e-01,5.458466e-01,5.4410e-01 / + +! --- ... asymmetry parameter from hu and stamnes + data asyliq1(:, 16) / & + & 8.133297e-01,8.133528e-01,8.173865e-01,8.243205e-01,8.333063e-01,& + & 8.436317e-01,8.546611e-01,8.657934e-01,8.764345e-01,8.859837e-01,& + & 8.627394e-01,8.824569e-01,8.976887e-01,9.089541e-01,9.167699e-01,& + & 9.216517e-01,9.241147e-01,9.246743e-01,9.238469e-01,9.221504e-01,& + & 9.201045e-01,9.182299e-01,9.170491e-01,9.170862e-01,9.188653e-01,& + & 9.229111e-01,9.297468e-01,9.398950e-01,9.203269e-01,9.260693e-01,& + & 9.309373e-01,9.349918e-01,9.382935e-01,9.409030e-01,9.428809e-01,& + & 9.442881e-01,9.451851e-01,9.456331e-01,9.456926e-01,9.454247e-01,& + & 9.448902e-01,9.441503e-01,9.432661e-01,9.422987e-01,9.413094e-01,& + & 9.403594e-01,9.395102e-01,9.388230e-01,9.383594e-01,9.381810e-01,& + & 9.383489e-01,9.389251e-01,9.399707e-01,9.415475e-01,9.437167e-01,& + & 9.465399e-01,9.500786e-01,9.5439e-01 / + data asyliq1(:, 17) / & + & 8.794448e-01,8.819306e-01,8.837667e-01,8.853832e-01,8.871010e-01,& + & 8.892675e-01,8.922584e-01,8.964666e-01,9.022940e-01,9.101456e-01,& + & 8.839999e-01,9.035610e-01,9.184568e-01,9.292315e-01,9.364282e-01,& + & 9.405887e-01,9.422554e-01,9.419703e-01,9.402759e-01,9.377159e-01,& + & 9.348345e-01,9.321769e-01,9.302888e-01,9.297166e-01,9.310075e-01,& + & 9.347080e-01,9.413643e-01,9.515216e-01,9.306286e-01,9.361781e-01,& + & 9.408374e-01,9.446692e-01,9.477363e-01,9.501013e-01,9.518268e-01,& + & 9.529756e-01,9.536105e-01,9.537938e-01,9.535886e-01,9.530574e-01,& + & 9.522633e-01,9.512688e-01,9.501370e-01,9.489306e-01,9.477126e-01,& + & 9.465459e-01,9.454934e-01,9.446183e-01,9.439833e-01,9.436519e-01,& + & 9.436866e-01,9.441508e-01,9.451073e-01,9.466195e-01,9.487501e-01,& + & 9.515621e-01,9.551185e-01,9.5948e-01 / + data asyliq1(:, 18) / & + & 8.478817e-01,8.269312e-01,8.161352e-01,8.135960e-01,8.173586e-01,& + & 8.254167e-01,8.357072e-01,8.461167e-01,8.544952e-01,8.586776e-01,& + & 8.335562e-01,8.524273e-01,8.669052e-01,8.775014e-01,8.847277e-01,& + & 8.890958e-01,8.911173e-01,8.913038e-01,8.901669e-01,8.882182e-01,& + & 8.859692e-01,8.839315e-01,8.826164e-01,8.825356e-01,8.842004e-01,& + & 8.881223e-01,8.948131e-01,9.047837e-01,8.855951e-01,8.911796e-01,& + & 8.959229e-01,8.998837e-01,9.031209e-01,9.056939e-01,9.076609e-01,& + & 9.090812e-01,9.100134e-01,9.105167e-01,9.106496e-01,9.104712e-01,& + & 9.100404e-01,9.094159e-01,9.086568e-01,9.078218e-01,9.069697e-01,& + & 9.061595e-01,9.054499e-01,9.048999e-01,9.045683e-01,9.045142e-01,& + & 9.047962e-01,9.054730e-01,9.066037e-01,9.082472e-01,9.104623e-01,& + & 9.133079e-01,9.168427e-01,9.2113e-01 / + data asyliq1(:, 19) / & + & 8.216697e-01,7.982871e-01,7.891147e-01,7.909083e-01,8.003833e-01,& + & 8.142516e-01,8.292290e-01,8.420356e-01,8.493945e-01,8.480316e-01,& + & 8.212381e-01,8.394984e-01,8.534095e-01,8.634813e-01,8.702242e-01,& + & 8.741483e-01,8.757638e-01,8.755808e-01,8.741095e-01,8.718604e-01,& + & 8.693433e-01,8.670686e-01,8.655464e-01,8.652872e-01,8.668006e-01,& + & 8.705973e-01,8.771874e-01,8.870809e-01,8.678284e-01,8.732315e-01,& + & 8.778084e-01,8.816166e-01,8.847146e-01,8.871603e-01,8.890116e-01,& + & 8.903266e-01,8.911632e-01,8.915796e-01,8.916337e-01,8.913834e-01,& + & 8.908869e-01,8.902022e-01,8.893873e-01,8.885001e-01,8.875986e-01,& + & 8.867411e-01,8.859852e-01,8.853891e-01,8.850111e-01,8.849089e-01,& + & 8.851405e-01,8.857639e-01,8.868372e-01,8.884185e-01,8.905656e-01,& + & 8.933368e-01,8.967899e-01,9.0098e-01 / + data asyliq1(:, 20) / & + & 8.063610e-01,7.938147e-01,7.921304e-01,7.985092e-01,8.101339e-01,& + & 8.242175e-01,8.379913e-01,8.486920e-01,8.535547e-01,8.498083e-01,& + & 8.224849e-01,8.405509e-01,8.542436e-01,8.640770e-01,8.705653e-01,& + & 8.742227e-01,8.755630e-01,8.751004e-01,8.733491e-01,8.708231e-01,& + & 8.680365e-01,8.655035e-01,8.637381e-01,8.632544e-01,8.645665e-01,& + & 8.681885e-01,8.746346e-01,8.844188e-01,8.648180e-01,8.700563e-01,& + & 8.744672e-01,8.781087e-01,8.810393e-01,8.833174e-01,8.850011e-01,& + & 8.861485e-01,8.868183e-01,8.870687e-01,8.869579e-01,8.865441e-01,& + & 8.858857e-01,8.850412e-01,8.840686e-01,8.830263e-01,8.819726e-01,& + & 8.809658e-01,8.800642e-01,8.793260e-01,8.788099e-01,8.785737e-01,& + & 8.786758e-01,8.791746e-01,8.801283e-01,8.815955e-01,8.836340e-01,& + & 8.863024e-01,8.896592e-01,8.9376e-01 / + data asyliq1(:, 21) / & + & 7.885899e-01,7.937172e-01,8.020658e-01,8.123971e-01,8.235502e-01,& + & 8.343776e-01,8.437336e-01,8.504711e-01,8.534421e-01,8.514978e-01,& + & 8.238888e-01,8.417463e-01,8.552057e-01,8.647853e-01,8.710038e-01,& + & 8.743798e-01,8.754319e-01,8.746786e-01,8.726386e-01,8.698303e-01,& + & 8.667724e-01,8.639836e-01,8.619823e-01,8.612870e-01,8.624165e-01,& + & 8.658893e-01,8.722241e-01,8.819394e-01,8.620216e-01,8.671239e-01,& + & 8.713983e-01,8.749032e-01,8.776970e-01,8.798385e-01,8.813860e-01,& + & 8.823980e-01,8.829332e-01,8.830500e-01,8.828068e-01,8.822623e-01,& + & 8.814750e-01,8.805031e-01,8.794056e-01,8.782407e-01,8.770672e-01,& + & 8.759432e-01,8.749275e-01,8.740784e-01,8.734547e-01,8.731146e-01,& + & 8.731170e-01,8.735199e-01,8.743823e-01,8.757625e-01,8.777191e-01,& + & 8.803105e-01,8.835953e-01,8.8763e-01 / + data asyliq1(:, 22) / & + & 7.811516e-01,7.962229e-01,8.096199e-01,8.212996e-01,8.312212e-01,& + & 8.393430e-01,8.456236e-01,8.500214e-01,8.524950e-01,8.530031e-01,& + & 8.251485e-01,8.429043e-01,8.562461e-01,8.656954e-01,8.717737e-01,& + & 8.750020e-01,8.759022e-01,8.749953e-01,8.728027e-01,8.698461e-01,& + & 8.666466e-01,8.637257e-01,8.616047e-01,8.608051e-01,8.618483e-01,& + & 8.652557e-01,8.715487e-01,8.812485e-01,8.611645e-01,8.662052e-01,& + & 8.704173e-01,8.738594e-01,8.765901e-01,8.786678e-01,8.801517e-01,& + & 8.810999e-01,8.815713e-01,8.816246e-01,8.813185e-01,8.807114e-01,& + & 8.798621e-01,8.788290e-01,8.776713e-01,8.764470e-01,8.752152e-01,& + & 8.740343e-01,8.729631e-01,8.720602e-01,8.713842e-01,8.709936e-01,& + & 8.709475e-01,8.713041e-01,8.721221e-01,8.734602e-01,8.753774e-01,& + & 8.779319e-01,8.811825e-01,8.8519e-01 / + data asyliq1(:, 23) / & + & 7.865744e-01,8.093340e-01,8.257596e-01,8.369940e-01,8.441574e-01,& + & 8.483602e-01,8.507096e-01,8.523139e-01,8.542834e-01,8.577321e-01,& + & 8.288960e-01,8.465308e-01,8.597175e-01,8.689830e-01,8.748542e-01,& + & 8.778584e-01,8.785222e-01,8.773728e-01,8.749370e-01,8.717419e-01,& + & 8.683145e-01,8.651816e-01,8.628704e-01,8.619077e-01,8.628205e-01,& + & 8.661356e-01,8.723803e-01,8.820815e-01,8.616715e-01,8.666389e-01,& + & 8.707753e-01,8.741398e-01,8.767912e-01,8.787885e-01,8.801908e-01,& + & 8.810570e-01,8.814460e-01,8.814167e-01,8.810283e-01,8.803395e-01,& + & 8.794095e-01,8.782971e-01,8.770613e-01,8.757610e-01,8.744553e-01,& + & 8.732031e-01,8.720634e-01,8.710951e-01,8.703572e-01,8.699086e-01,& + & 8.698084e-01,8.701155e-01,8.708887e-01,8.721872e-01,8.740698e-01,& + & 8.765957e-01,8.798235e-01,8.8381e-01 / + data asyliq1(:, 24) / & + & 8.069513e-01,8.262939e-01,8.398241e-01,8.486352e-01,8.538213e-01,& + & 8.564743e-01,8.576854e-01,8.585455e-01,8.601452e-01,8.635755e-01,& + & 8.337383e-01,8.512655e-01,8.643049e-01,8.733896e-01,8.790535e-01,& + & 8.818295e-01,8.822518e-01,8.808533e-01,8.781676e-01,8.747284e-01,& + & 8.710690e-01,8.677229e-01,8.652236e-01,8.641047e-01,8.648993e-01,& + & 8.681413e-01,8.743640e-01,8.841007e-01,8.633558e-01,8.682719e-01,& + & 8.723543e-01,8.756621e-01,8.782547e-01,8.801915e-01,8.815318e-01,& + & 8.823347e-01,8.826598e-01,8.825663e-01,8.821135e-01,8.813608e-01,& + & 8.803674e-01,8.791928e-01,8.778960e-01,8.765366e-01,8.751738e-01,& + & 8.738670e-01,8.726755e-01,8.716585e-01,8.708755e-01,8.703856e-01,& + & 8.702483e-01,8.705229e-01,8.712687e-01,8.725448e-01,8.744109e-01,& + & 8.769260e-01,8.801496e-01,8.8414e-01 / + data asyliq1(:, 25) / & + & 8.252182e-01,8.379244e-01,8.471709e-01,8.535760e-01,8.577540e-01,& + & 8.603183e-01,8.618820e-01,8.630578e-01,8.644587e-01,8.666970e-01,& + & 8.362159e-01,8.536817e-01,8.666387e-01,8.756240e-01,8.811746e-01,& + & 8.838273e-01,8.841191e-01,8.825871e-01,8.797681e-01,8.761992e-01,& + & 8.724174e-01,8.689593e-01,8.663623e-01,8.651632e-01,8.658988e-01,& + & 8.691064e-01,8.753226e-01,8.850847e-01,8.641620e-01,8.690500e-01,& + & 8.731026e-01,8.763795e-01,8.789400e-01,8.808438e-01,8.821503e-01,& + & 8.829191e-01,8.832095e-01,8.830813e-01,8.825938e-01,8.818064e-01,& + & 8.807787e-01,8.795704e-01,8.782408e-01,8.768493e-01,8.754557e-01,& + & 8.741193e-01,8.728995e-01,8.718561e-01,8.710484e-01,8.705360e-01,& + & 8.703782e-01,8.706347e-01,8.713650e-01,8.726285e-01,8.744849e-01,& + & 8.769933e-01,8.802136e-01,8.8421e-01 / + data asyliq1(:, 26) / & + & 8.370583e-01,8.467920e-01,8.537769e-01,8.585136e-01,8.615034e-01,& + & 8.632474e-01,8.642468e-01,8.650026e-01,8.660161e-01,8.677882e-01,& + & 8.369760e-01,8.543821e-01,8.672699e-01,8.761782e-01,8.816454e-01,& + & 8.842103e-01,8.844114e-01,8.827872e-01,8.798766e-01,8.762179e-01,& + & 8.723500e-01,8.688112e-01,8.661403e-01,8.648758e-01,8.655563e-01,& + & 8.687206e-01,8.749072e-01,8.846546e-01,8.636289e-01,8.684849e-01,& + & 8.725054e-01,8.757501e-01,8.782785e-01,8.801503e-01,8.814249e-01,& + & 8.821620e-01,8.824211e-01,8.822620e-01,8.817440e-01,8.809268e-01,& + & 8.798699e-01,8.786330e-01,8.772756e-01,8.758572e-01,8.744374e-01,& + & 8.730760e-01,8.718323e-01,8.707660e-01,8.699366e-01,8.694039e-01,& + & 8.692271e-01,8.694661e-01,8.701803e-01,8.714293e-01,8.732727e-01,& + & 8.757702e-01,8.789811e-01,8.8297e-01 / + data asyliq1(:, 27) / & + & 8.430819e-01,8.510060e-01,8.567270e-01,8.606533e-01,8.631934e-01,& + & 8.647554e-01,8.657471e-01,8.665760e-01,8.676496e-01,8.693754e-01,& + & 8.384298e-01,8.557913e-01,8.686214e-01,8.774605e-01,8.828495e-01,& + & 8.853287e-01,8.854393e-01,8.837215e-01,8.807161e-01,8.769639e-01,& + & 8.730053e-01,8.693812e-01,8.666321e-01,8.652988e-01,8.659219e-01,& + & 8.690419e-01,8.751999e-01,8.849360e-01,8.638013e-01,8.686371e-01,& + & 8.726369e-01,8.758605e-01,8.783674e-01,8.802176e-01,8.814705e-01,& + & 8.821859e-01,8.824234e-01,8.822429e-01,8.817038e-01,8.808658e-01,& + & 8.797887e-01,8.785323e-01,8.771560e-01,8.757196e-01,8.742828e-01,& + & 8.729052e-01,8.716467e-01,8.705666e-01,8.697250e-01,8.691812e-01,& + & 8.689950e-01,8.692264e-01,8.699346e-01,8.711795e-01,8.730209e-01,& + & 8.755181e-01,8.787312e-01,8.8272e-01 / + data asyliq1(:, 28) / & + & 8.452284e-01,8.522700e-01,8.572973e-01,8.607031e-01,8.628802e-01,& + & 8.642215e-01,8.651198e-01,8.659679e-01,8.671588e-01,8.690853e-01,& + & 8.383803e-01,8.557485e-01,8.685851e-01,8.774303e-01,8.828245e-01,& + & 8.853077e-01,8.854207e-01,8.837034e-01,8.806962e-01,8.769398e-01,& + & 8.729740e-01,8.693393e-01,8.665761e-01,8.652247e-01,8.658253e-01,& + & 8.689182e-01,8.750438e-01,8.847424e-01,8.636140e-01,8.684449e-01,& + & 8.724400e-01,8.756589e-01,8.781613e-01,8.800072e-01,8.812559e-01,& + & 8.819671e-01,8.822007e-01,8.820165e-01,8.814737e-01,8.806322e-01,& + & 8.795518e-01,8.782923e-01,8.769129e-01,8.754737e-01,8.740342e-01,& + & 8.726542e-01,8.713934e-01,8.703111e-01,8.694677e-01,8.689222e-01,& + & 8.687344e-01,8.689646e-01,8.696715e-01,8.709156e-01,8.727563e-01,& + & 8.752531e-01,8.784659e-01,8.8245e-01 / + data asyliq1(:, 29) / & + & 7.800869e-01,8.091120e-01,8.325369e-01,8.466266e-01,8.515495e-01,& + & 8.499371e-01,8.456203e-01,8.430521e-01,8.470286e-01,8.625431e-01,& + & 8.402261e-01,8.610822e-01,8.776608e-01,8.904485e-01,8.999294e-01,& + & 9.065860e-01,9.108995e-01,9.133503e-01,9.144187e-01,9.145855e-01,& + & 9.143320e-01,9.141402e-01,9.144933e-01,9.158754e-01,9.187716e-01,& + & 9.236677e-01,9.310503e-01,9.414058e-01,9.239108e-01,9.300719e-01,& + & 9.353612e-01,9.398378e-01,9.435609e-01,9.465895e-01,9.489829e-01,& + & 9.508000e-01,9.521002e-01,9.529424e-01,9.533860e-01,9.534902e-01,& + & 9.533143e-01,9.529177e-01,9.523596e-01,9.516997e-01,9.509973e-01,& + & 9.503121e-01,9.497037e-01,9.492317e-01,9.489558e-01,9.489356e-01,& + & 9.492311e-01,9.499019e-01,9.510077e-01,9.526084e-01,9.547636e-01,& + & 9.575331e-01,9.609766e-01,9.6515e-01 / + +! --- ... spherical ice particle parameterization from streamer v3 +! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] + data extice2(:, 16) / & + & 4.101824e-01,2.435514e-01,1.713697e-01,1.314865e-01,1.063406e-01,& + & 8.910701e-02,7.659480e-02,6.711784e-02,5.970353e-02,5.375249e-02,& + & 4.887577e-02,4.481025e-02,4.137171e-02,3.842744e-02,3.587948e-02,& + & 3.365396e-02,3.169419e-02,2.995593e-02,2.840419e-02,2.701091e-02,& + & 2.575336e-02,2.461293e-02,2.357423e-02,2.262443e-02,2.175276e-02,& + & 2.095012e-02,2.020875e-02,1.952199e-02,1.888412e-02,1.829018e-02,& + & 1.773586e-02,1.721738e-02,1.673144e-02,1.627510e-02,1.584579e-02,& + & 1.544122e-02,1.505934e-02,1.469833e-02,1.435654e-02,1.403251e-02,& + & 1.372492e-02,1.343255e-02,1.315433e-02 / + data extice2(:, 17) / & + & 3.836650e-01,2.304055e-01,1.637265e-01,1.266681e-01,1.031602e-01,& + & 8.695191e-02,7.511544e-02,6.610009e-02,5.900909e-02,5.328833e-02,& + & 4.857728e-02,4.463133e-02,4.127880e-02,3.839567e-02,3.589013e-02,& + & 3.369280e-02,3.175027e-02,3.002079e-02,2.847121e-02,2.707493e-02,& + & 2.581031e-02,2.465962e-02,2.360815e-02,2.264363e-02,2.175571e-02,& + & 2.093563e-02,2.017592e-02,1.947015e-02,1.881278e-02,1.819901e-02,& + & 1.762463e-02,1.708598e-02,1.657982e-02,1.610330e-02,1.565390e-02,& + & 1.522937e-02,1.482768e-02,1.444706e-02,1.408588e-02,1.374270e-02,& + & 1.341619e-02,1.310517e-02,1.280857e-02 / + data extice2(:, 18) / & + & 4.152673e-01,2.436816e-01,1.702243e-01,1.299704e-01,1.047528e-01,& + & 8.756039e-02,7.513327e-02,6.575690e-02,5.844616e-02,5.259609e-02,& + & 4.781531e-02,4.383980e-02,4.048517e-02,3.761891e-02,3.514342e-02,& + & 3.298525e-02,3.108814e-02,2.940825e-02,2.791096e-02,2.656858e-02,& + & 2.535869e-02,2.426297e-02,2.326627e-02,2.235602e-02,2.152164e-02,& + & 2.075420e-02,2.004613e-02,1.939091e-02,1.878296e-02,1.821744e-02,& + & 1.769015e-02,1.719741e-02,1.673600e-02,1.630308e-02,1.589615e-02,& + & 1.551298e-02,1.515159e-02,1.481021e-02,1.448726e-02,1.418131e-02,& + & 1.389109e-02,1.361544e-02,1.335330e-02 / + data extice2(:, 19) / & + & 3.873250e-01,2.331609e-01,1.655002e-01,1.277753e-01,1.038247e-01,& + & 8.731780e-02,7.527638e-02,6.611873e-02,5.892850e-02,5.313885e-02,& + & 4.838068e-02,4.440356e-02,4.103167e-02,3.813804e-02,3.562870e-02,& + & 3.343269e-02,3.149539e-02,2.977414e-02,2.823510e-02,2.685112e-02,& + & 2.560015e-02,2.446411e-02,2.342805e-02,2.247948e-02,2.160789e-02,& + & 2.080438e-02,2.006139e-02,1.937238e-02,1.873177e-02,1.813469e-02,& + & 1.757689e-02,1.705468e-02,1.656479e-02,1.610435e-02,1.567081e-02,& + & 1.526192e-02,1.487565e-02,1.451020e-02,1.416396e-02,1.383546e-02,& + & 1.352339e-02,1.322657e-02,1.294392e-02 / + data extice2(:, 20) / & + & 3.784280e-01,2.291396e-01,1.632551e-01,1.263775e-01,1.028944e-01,& + & 8.666975e-02,7.480952e-02,6.577335e-02,5.866714e-02,5.293694e-02,& + & 4.822153e-02,4.427547e-02,4.092626e-02,3.804918e-02,3.555184e-02,& + & 3.336440e-02,3.143307e-02,2.971577e-02,2.817912e-02,2.679632e-02,& + & 2.554558e-02,2.440903e-02,2.337187e-02,2.242173e-02,2.154821e-02,& + & 2.074249e-02,1.999706e-02,1.930546e-02,1.866212e-02,1.806221e-02,& + & 1.750152e-02,1.697637e-02,1.648352e-02,1.602010e-02,1.558358e-02,& + & 1.517172e-02,1.478250e-02,1.441413e-02,1.406498e-02,1.373362e-02,& + & 1.341872e-02,1.311911e-02,1.283371e-02 / + data extice2(:, 21) / & + & 3.719909e-01,2.259490e-01,1.613144e-01,1.250648e-01,1.019462e-01,& + & 8.595358e-02,7.425064e-02,6.532618e-02,5.830218e-02,5.263421e-02,& + & 4.796697e-02,4.405891e-02,4.074013e-02,3.788776e-02,3.541071e-02,& + & 3.324008e-02,3.132280e-02,2.961733e-02,2.809071e-02,2.671645e-02,& + & 2.547302e-02,2.434276e-02,2.331102e-02,2.236558e-02,2.149614e-02,& + & 2.069397e-02,1.995163e-02,1.926272e-02,1.862174e-02,1.802389e-02,& + & 1.746500e-02,1.694142e-02,1.644994e-02,1.598772e-02,1.555225e-02,& + & 1.514129e-02,1.475286e-02,1.438515e-02,1.403659e-02,1.370572e-02,& + & 1.339124e-02,1.309197e-02,1.280685e-02 / + data extice2(:, 22) / & + & 3.713158e-01,2.253816e-01,1.608461e-01,1.246718e-01,1.016109e-01,& + & 8.566332e-02,7.399666e-02,6.510199e-02,5.810290e-02,5.245608e-02,& + & 4.780702e-02,4.391478e-02,4.060989e-02,3.776982e-02,3.530374e-02,& + & 3.314296e-02,3.123458e-02,2.953719e-02,2.801794e-02,2.665043e-02,& + & 2.541321e-02,2.428868e-02,2.326224e-02,2.232173e-02,2.145688e-02,& + & 2.065899e-02,1.992067e-02,1.923552e-02,1.859808e-02,1.800356e-02,& + & 1.744782e-02,1.692721e-02,1.643855e-02,1.597900e-02,1.554606e-02,& + & 1.513751e-02,1.475137e-02,1.438586e-02,1.403938e-02,1.371050e-02,& + & 1.339793e-02,1.310050e-02,1.281713e-02 / + data extice2(:, 23) / & + & 3.605883e-01,2.204388e-01,1.580431e-01,1.229033e-01,1.004203e-01,& + & 8.482616e-02,7.338941e-02,6.465105e-02,5.776176e-02,5.219398e-02,& + & 4.760288e-02,4.375369e-02,4.048111e-02,3.766539e-02,3.521771e-02,& + & 3.307079e-02,3.117277e-02,2.948303e-02,2.796929e-02,2.660560e-02,& + & 2.537086e-02,2.424772e-02,2.322182e-02,2.228114e-02,2.141556e-02,& + & 2.061649e-02,1.987661e-02,1.918962e-02,1.855009e-02,1.795330e-02,& + & 1.739514e-02,1.687199e-02,1.638069e-02,1.591845e-02,1.548276e-02,& + & 1.507143e-02,1.468249e-02,1.431416e-02,1.396486e-02,1.363318e-02,& + & 1.331781e-02,1.301759e-02,1.273147e-02 / + data extice2(:, 24) / & + & 3.527890e-01,2.168469e-01,1.560090e-01,1.216216e-01,9.955787e-02,& + & 8.421942e-02,7.294827e-02,6.432192e-02,5.751081e-02,5.199888e-02,& + & 4.744835e-02,4.362899e-02,4.037847e-02,3.757910e-02,3.514351e-02,& + & 3.300546e-02,3.111382e-02,2.942853e-02,2.791775e-02,2.655584e-02,& + & 2.532195e-02,2.419892e-02,2.317255e-02,2.223092e-02,2.136402e-02,& + & 2.056334e-02,1.982160e-02,1.913258e-02,1.849087e-02,1.789178e-02,& + & 1.733124e-02,1.680565e-02,1.631187e-02,1.584711e-02,1.540889e-02,& + & 1.499502e-02,1.460354e-02,1.423269e-02,1.388088e-02,1.354670e-02,& + & 1.322887e-02,1.292620e-02,1.263767e-02 / + data extice2(:, 25) / & + & 3.477874e-01,2.143515e-01,1.544887e-01,1.205942e-01,9.881779e-02,& + & 8.366261e-02,7.251586e-02,6.397790e-02,5.723183e-02,5.176908e-02,& + & 4.725658e-02,4.346715e-02,4.024055e-02,3.746055e-02,3.504080e-02,& + & 3.291583e-02,3.103507e-02,2.935891e-02,2.785582e-02,2.650042e-02,& + & 2.527206e-02,2.415376e-02,2.313142e-02,2.219326e-02,2.132934e-02,& + & 2.053122e-02,1.979169e-02,1.910456e-02,1.846448e-02,1.786680e-02,& + & 1.730745e-02,1.678289e-02,1.628998e-02,1.582595e-02,1.538835e-02,& + & 1.497499e-02,1.458393e-02,1.421341e-02,1.386187e-02,1.352788e-02,& + & 1.321019e-02,1.290762e-02,1.261913e-02 / + data extice2(:, 26) / & + & 3.453721e-01,2.130744e-01,1.536698e-01,1.200140e-01,9.838078e-02,& + & 8.331940e-02,7.223803e-02,6.374775e-02,5.703770e-02,5.160290e-02,& + & 4.711259e-02,4.334110e-02,4.012923e-02,3.736150e-02,3.495208e-02,& + & 3.283589e-02,3.096267e-02,2.929302e-02,2.779560e-02,2.644517e-02,& + & 2.522119e-02,2.410677e-02,2.308788e-02,2.215281e-02,2.129165e-02,& + & 2.049602e-02,1.975874e-02,1.907365e-02,1.843542e-02,1.783943e-02,& + & 1.728162e-02,1.675847e-02,1.626685e-02,1.580401e-02,1.536750e-02,& + & 1.495515e-02,1.456502e-02,1.419537e-02,1.384463e-02,1.351139e-02,& + & 1.319438e-02,1.289246e-02,1.260456e-02 / + data extice2(:, 27) / & + & 3.417883e-01,2.113379e-01,1.526395e-01,1.193347e-01,9.790253e-02,& + & 8.296715e-02,7.196979e-02,6.353806e-02,5.687024e-02,5.146670e-02,& + & 4.700001e-02,4.324667e-02,4.004894e-02,3.729233e-02,3.489172e-02,& + & 3.278257e-02,3.091499e-02,2.924987e-02,2.775609e-02,2.640859e-02,& + & 2.518695e-02,2.407439e-02,2.305697e-02,2.212303e-02,2.126273e-02,& + & 2.046774e-02,1.973090e-02,1.904610e-02,1.840801e-02,1.781204e-02,& + & 1.725417e-02,1.673086e-02,1.623902e-02,1.577590e-02,1.533906e-02,& + & 1.492634e-02,1.453580e-02,1.416571e-02,1.381450e-02,1.348078e-02,& + & 1.316327e-02,1.286082e-02,1.257240e-02 / + data extice2(:, 28) / & + & 3.416111e-01,2.114124e-01,1.527734e-01,1.194809e-01,9.804612e-02,& + & 8.310287e-02,7.209595e-02,6.365442e-02,5.697710e-02,5.156460e-02,& + & 4.708957e-02,4.332850e-02,4.012361e-02,3.736037e-02,3.495364e-02,& + & 3.283879e-02,3.096593e-02,2.929589e-02,2.779751e-02,2.644571e-02,& + & 2.522004e-02,2.410369e-02,2.308271e-02,2.214542e-02,2.128195e-02,& + & 2.048396e-02,1.974429e-02,1.905679e-02,1.841614e-02,1.781774e-02,& + & 1.725754e-02,1.673203e-02,1.623807e-02,1.577293e-02,1.533416e-02,& + & 1.491958e-02,1.452727e-02,1.415547e-02,1.380262e-02,1.346732e-02,& + & 1.314830e-02,1.284439e-02,1.255456e-02 / + data extice2(:, 29) / & + & 4.196611e-01,2.493642e-01,1.761261e-01,1.357197e-01,1.102161e-01,& + & 9.269376e-02,7.992985e-02,7.022538e-02,6.260168e-02,5.645603e-02,& + & 5.139732e-02,4.716088e-02,4.356133e-02,4.046498e-02,3.777303e-02,& + & 3.541094e-02,3.332137e-02,3.145954e-02,2.978998e-02,2.828419e-02,& + & 2.691905e-02,2.567559e-02,2.453811e-02,2.349350e-02,2.253072e-02,& + & 2.164042e-02,2.081464e-02,2.004652e-02,1.933015e-02,1.866041e-02,& + & 1.803283e-02,1.744348e-02,1.688894e-02,1.636616e-02,1.587244e-02,& + & 1.540539e-02,1.496287e-02,1.454295e-02,1.414392e-02,1.376423e-02,& + & 1.340247e-02,1.305739e-02,1.272784e-02 / + +! --- ... single-scattering albedo from streamer v3, unitless + data ssaice2(:, 16) / & + & 6.630615e-01,6.451169e-01,6.333696e-01,6.246927e-01,6.178420e-01,& + & 6.121976e-01,6.074069e-01,6.032505e-01,5.995830e-01,5.963030e-01,& + & 5.933372e-01,5.906311e-01,5.881427e-01,5.858395e-01,5.836955e-01,& + & 5.816896e-01,5.798046e-01,5.780264e-01,5.763429e-01,5.747441e-01,& + & 5.732213e-01,5.717672e-01,5.703754e-01,5.690403e-01,5.677571e-01,& + & 5.665215e-01,5.653297e-01,5.641782e-01,5.630643e-01,5.619850e-01,& + & 5.609381e-01,5.599214e-01,5.589328e-01,5.579707e-01,5.570333e-01,& + & 5.561193e-01,5.552272e-01,5.543558e-01,5.535041e-01,5.526708e-01,& + & 5.518551e-01,5.510561e-01,5.502729e-01 / + data ssaice2(:, 17) / & + & 7.689749e-01,7.398171e-01,7.205819e-01,7.065690e-01,6.956928e-01,& + & 6.868989e-01,6.795813e-01,6.733606e-01,6.679838e-01,6.632742e-01,& + & 6.591036e-01,6.553766e-01,6.520197e-01,6.489757e-01,6.461991e-01,& + & 6.436531e-01,6.413075e-01,6.391375e-01,6.371221e-01,6.352438e-01,& + & 6.334876e-01,6.318406e-01,6.302918e-01,6.288315e-01,6.274512e-01,& + & 6.261436e-01,6.249022e-01,6.237211e-01,6.225953e-01,6.215201e-01,& + & 6.204914e-01,6.195055e-01,6.185592e-01,6.176492e-01,6.167730e-01,& + & 6.159280e-01,6.151120e-01,6.143228e-01,6.135587e-01,6.128177e-01,& + & 6.120984e-01,6.113993e-01,6.107189e-01 / + data ssaice2(:, 18) / & + & 9.956167e-01,9.814770e-01,9.716104e-01,9.639746e-01,9.577179e-01,& + & 9.524010e-01,9.477672e-01,9.436527e-01,9.399467e-01,9.365708e-01,& + & 9.334672e-01,9.305921e-01,9.279118e-01,9.253993e-01,9.230330e-01,& + & 9.207954e-01,9.186719e-01,9.166501e-01,9.147199e-01,9.128722e-01,& + & 9.110997e-01,9.093956e-01,9.077544e-01,9.061708e-01,9.046406e-01,& + & 9.031598e-01,9.017248e-01,9.003326e-01,8.989804e-01,8.976655e-01,& + & 8.963857e-01,8.951389e-01,8.939233e-01,8.927370e-01,8.915785e-01,& + & 8.904464e-01,8.893392e-01,8.882559e-01,8.871951e-01,8.861559e-01,& + & 8.851373e-01,8.841383e-01,8.831581e-01 / + data ssaice2(:, 19) / & + & 9.723177e-01,9.452119e-01,9.267592e-01,9.127393e-01,9.014238e-01,& + & 8.919334e-01,8.837584e-01,8.765773e-01,8.701736e-01,8.643950e-01,& + & 8.591299e-01,8.542942e-01,8.498230e-01,8.456651e-01,8.417794e-01,& + & 8.381324e-01,8.346964e-01,8.314484e-01,8.283687e-01,8.254408e-01,& + & 8.226505e-01,8.199854e-01,8.174348e-01,8.149891e-01,8.126403e-01,& + & 8.103808e-01,8.082041e-01,8.061044e-01,8.040765e-01,8.021156e-01,& + & 8.002174e-01,7.983781e-01,7.965941e-01,7.948622e-01,7.931795e-01,& + & 7.915432e-01,7.899508e-01,7.884002e-01,7.868891e-01,7.854156e-01,& + & 7.839779e-01,7.825742e-01,7.812031e-01 / + data ssaice2(:, 20) / & + & 9.933294e-01,9.860917e-01,9.811564e-01,9.774008e-01,9.743652e-01,& + & 9.718155e-01,9.696159e-01,9.676810e-01,9.659531e-01,9.643915e-01,& + & 9.629667e-01,9.616561e-01,9.604426e-01,9.593125e-01,9.582548e-01,& + & 9.572607e-01,9.563227e-01,9.554347e-01,9.545915e-01,9.537888e-01,& + & 9.530226e-01,9.522898e-01,9.515874e-01,9.509130e-01,9.502643e-01,& + & 9.496394e-01,9.490366e-01,9.484542e-01,9.478910e-01,9.473456e-01,& + & 9.468169e-01,9.463039e-01,9.458056e-01,9.453212e-01,9.448499e-01,& + & 9.443910e-01,9.439438e-01,9.435077e-01,9.430821e-01,9.426666e-01,& + & 9.422607e-01,9.418638e-01,9.414756e-01 / + data ssaice2(:, 21) / & + & 9.900787e-01,9.828880e-01,9.779258e-01,9.741173e-01,9.710184e-01,& + & 9.684012e-01,9.661332e-01,9.641301e-01,9.623352e-01,9.607083e-01,& + & 9.592198e-01,9.578474e-01,9.565739e-01,9.553856e-01,9.542715e-01,& + & 9.532226e-01,9.522314e-01,9.512919e-01,9.503986e-01,9.495472e-01,& + & 9.487337e-01,9.479549e-01,9.472077e-01,9.464897e-01,9.457985e-01,& + & 9.451322e-01,9.444890e-01,9.438673e-01,9.432656e-01,9.426826e-01,& + & 9.421173e-01,9.415684e-01,9.410351e-01,9.405164e-01,9.400115e-01,& + & 9.395198e-01,9.390404e-01,9.385728e-01,9.381164e-01,9.376707e-01,& + & 9.372350e-01,9.368091e-01,9.363923e-01 / + data ssaice2(:, 22) / & + & 9.986793e-01,9.985239e-01,9.983911e-01,9.982715e-01,9.981606e-01,& + & 9.980562e-01,9.979567e-01,9.978613e-01,9.977691e-01,9.976798e-01,& + & 9.975929e-01,9.975081e-01,9.974251e-01,9.973438e-01,9.972640e-01,& + & 9.971855e-01,9.971083e-01,9.970322e-01,9.969571e-01,9.968830e-01,& + & 9.968099e-01,9.967375e-01,9.966660e-01,9.965951e-01,9.965250e-01,& + & 9.964555e-01,9.963867e-01,9.963185e-01,9.962508e-01,9.961836e-01,& + & 9.961170e-01,9.960508e-01,9.959851e-01,9.959198e-01,9.958550e-01,& + & 9.957906e-01,9.957266e-01,9.956629e-01,9.955997e-01,9.955367e-01,& + & 9.954742e-01,9.954119e-01,9.953500e-01 / + data ssaice2(:, 23) / & + & 9.997944e-01,9.997791e-01,9.997664e-01,9.997547e-01,9.997436e-01,& + & 9.997327e-01,9.997219e-01,9.997110e-01,9.996999e-01,9.996886e-01,& + & 9.996771e-01,9.996653e-01,9.996533e-01,9.996409e-01,9.996282e-01,& + & 9.996152e-01,9.996019e-01,9.995883e-01,9.995743e-01,9.995599e-01,& + & 9.995453e-01,9.995302e-01,9.995149e-01,9.994992e-01,9.994831e-01,& + & 9.994667e-01,9.994500e-01,9.994329e-01,9.994154e-01,9.993976e-01,& + & 9.993795e-01,9.993610e-01,9.993422e-01,9.993230e-01,9.993035e-01,& + & 9.992837e-01,9.992635e-01,9.992429e-01,9.992221e-01,9.992008e-01,& + & 9.991793e-01,9.991574e-01,9.991352e-01 / + data ssaice2(:, 24) / & + & 9.999949e-01,9.999947e-01,9.999943e-01,9.999939e-01,9.999934e-01,& + & 9.999927e-01,9.999920e-01,9.999913e-01,9.999904e-01,9.999895e-01,& + & 9.999885e-01,9.999874e-01,9.999863e-01,9.999851e-01,9.999838e-01,& + & 9.999824e-01,9.999810e-01,9.999795e-01,9.999780e-01,9.999764e-01,& + & 9.999747e-01,9.999729e-01,9.999711e-01,9.999692e-01,9.999673e-01,& + & 9.999653e-01,9.999632e-01,9.999611e-01,9.999589e-01,9.999566e-01,& + & 9.999543e-01,9.999519e-01,9.999495e-01,9.999470e-01,9.999444e-01,& + & 9.999418e-01,9.999392e-01,9.999364e-01,9.999336e-01,9.999308e-01,& + & 9.999279e-01,9.999249e-01,9.999219e-01 / + data ssaice2(:, 25) / & + & 9.999997e-01,9.999997e-01,9.999997e-01,9.999996e-01,9.999996e-01,& + & 9.999995e-01,9.999994e-01,9.999993e-01,9.999993e-01,9.999992e-01,& + & 9.999991e-01,9.999989e-01,9.999988e-01,9.999987e-01,9.999986e-01,& + & 9.999984e-01,9.999983e-01,9.999981e-01,9.999980e-01,9.999978e-01,& + & 9.999976e-01,9.999974e-01,9.999972e-01,9.999971e-01,9.999969e-01,& + & 9.999966e-01,9.999964e-01,9.999962e-01,9.999960e-01,9.999957e-01,& + & 9.999955e-01,9.999953e-01,9.999950e-01,9.999947e-01,9.999945e-01,& + & 9.999942e-01,9.999939e-01,9.999936e-01,9.999934e-01,9.999931e-01,& + & 9.999928e-01,9.999925e-01,9.999921e-01 / + data ssaice2(:, 26) / & + & 9.999997e-01,9.999996e-01,9.999996e-01,9.999995e-01,9.999994e-01,& + & 9.999993e-01,9.999992e-01,9.999991e-01,9.999990e-01,9.999989e-01,& + & 9.999987e-01,9.999986e-01,9.999984e-01,9.999982e-01,9.999980e-01,& + & 9.999978e-01,9.999976e-01,9.999974e-01,9.999972e-01,9.999970e-01,& + & 9.999967e-01,9.999965e-01,9.999962e-01,9.999959e-01,9.999956e-01,& + & 9.999954e-01,9.999951e-01,9.999947e-01,9.999944e-01,9.999941e-01,& + & 9.999938e-01,9.999934e-01,9.999931e-01,9.999927e-01,9.999923e-01,& + & 9.999920e-01,9.999916e-01,9.999912e-01,9.999908e-01,9.999904e-01,& + & 9.999899e-01,9.999895e-01,9.999891e-01 / + data ssaice2(:, 27) / & + & 9.999987e-01,9.999987e-01,9.999985e-01,9.999984e-01,9.999982e-01,& + & 9.999980e-01,9.999978e-01,9.999976e-01,9.999973e-01,9.999970e-01,& + & 9.999967e-01,9.999964e-01,9.999960e-01,9.999956e-01,9.999952e-01,& + & 9.999948e-01,9.999944e-01,9.999939e-01,9.999934e-01,9.999929e-01,& + & 9.999924e-01,9.999918e-01,9.999913e-01,9.999907e-01,9.999901e-01,& + & 9.999894e-01,9.999888e-01,9.999881e-01,9.999874e-01,9.999867e-01,& + & 9.999860e-01,9.999853e-01,9.999845e-01,9.999837e-01,9.999829e-01,& + & 9.999821e-01,9.999813e-01,9.999804e-01,9.999796e-01,9.999787e-01,& + & 9.999778e-01,9.999768e-01,9.999759e-01 / + data ssaice2(:, 28) / & + & 9.999989e-01,9.999989e-01,9.999987e-01,9.999986e-01,9.999984e-01,& + & 9.999982e-01,9.999980e-01,9.999978e-01,9.999975e-01,9.999972e-01,& + & 9.999969e-01,9.999966e-01,9.999962e-01,9.999958e-01,9.999954e-01,& + & 9.999950e-01,9.999945e-01,9.999941e-01,9.999936e-01,9.999931e-01,& + & 9.999925e-01,9.999920e-01,9.999914e-01,9.999908e-01,9.999902e-01,& + & 9.999896e-01,9.999889e-01,9.999883e-01,9.999876e-01,9.999869e-01,& + & 9.999861e-01,9.999854e-01,9.999846e-01,9.999838e-01,9.999830e-01,& + & 9.999822e-01,9.999814e-01,9.999805e-01,9.999796e-01,9.999787e-01,& + & 9.999778e-01,9.999769e-01,9.999759e-01 / + data ssaice2(:, 29) / & + & 7.042143e-01,6.691161e-01,6.463240e-01,6.296590e-01,6.166381e-01,& + & 6.060183e-01,5.970908e-01,5.894144e-01,5.826968e-01,5.767343e-01,& + & 5.713804e-01,5.665256e-01,5.620867e-01,5.579987e-01,5.542101e-01,& + & 5.506794e-01,5.473727e-01,5.442620e-01,5.413239e-01,5.385389e-01,& + & 5.358901e-01,5.333633e-01,5.309460e-01,5.286277e-01,5.263988e-01,& + & 5.242512e-01,5.221777e-01,5.201719e-01,5.182280e-01,5.163410e-01,& + & 5.145062e-01,5.127197e-01,5.109776e-01,5.092766e-01,5.076137e-01,& + & 5.059860e-01,5.043911e-01,5.028266e-01,5.012904e-01,4.997805e-01,& + & 4.982951e-01,4.968326e-01,4.953913e-01 / + +! --- ... asymmetry factor from streamer v3, unitless + data asyice2(:, 16) / & + & 7.946655e-01,8.547685e-01,8.806016e-01,8.949880e-01,9.041676e-01,& + & 9.105399e-01,9.152249e-01,9.188160e-01,9.216573e-01,9.239620e-01,& + & 9.258695e-01,9.274745e-01,9.288441e-01,9.300267e-01,9.310584e-01,& + & 9.319665e-01,9.327721e-01,9.334918e-01,9.341387e-01,9.347236e-01,& + & 9.352551e-01,9.357402e-01,9.361850e-01,9.365942e-01,9.369722e-01,& + & 9.373225e-01,9.376481e-01,9.379516e-01,9.382352e-01,9.385010e-01,& + & 9.387505e-01,9.389854e-01,9.392070e-01,9.394163e-01,9.396145e-01,& + & 9.398024e-01,9.399809e-01,9.401508e-01,9.403126e-01,9.404670e-01,& + & 9.406144e-01,9.407555e-01,9.408906e-01 / + data asyice2(:, 17) / & + & 9.078091e-01,9.195850e-01,9.267250e-01,9.317083e-01,9.354632e-01,& + & 9.384323e-01,9.408597e-01,9.428935e-01,9.446301e-01,9.461351e-01,& + & 9.474555e-01,9.486259e-01,9.496722e-01,9.506146e-01,9.514688e-01,& + & 9.522476e-01,9.529612e-01,9.536181e-01,9.542251e-01,9.547883e-01,& + & 9.553124e-01,9.558019e-01,9.562601e-01,9.566904e-01,9.570953e-01,& + & 9.574773e-01,9.578385e-01,9.581806e-01,9.585054e-01,9.588142e-01,& + & 9.591083e-01,9.593888e-01,9.596569e-01,9.599135e-01,9.601593e-01,& + & 9.603952e-01,9.606219e-01,9.608399e-01,9.610499e-01,9.612523e-01,& + & 9.614477e-01,9.616365e-01,9.618192e-01 / + data asyice2(:, 18) / & + & 8.322045e-01,8.528693e-01,8.648167e-01,8.729163e-01,8.789054e-01,& + & 8.835845e-01,8.873819e-01,8.905511e-01,8.932532e-01,8.955965e-01,& + & 8.976567e-01,8.994887e-01,9.011334e-01,9.026221e-01,9.039791e-01,& + & 9.052237e-01,9.063715e-01,9.074349e-01,9.084245e-01,9.093489e-01,& + & 9.102154e-01,9.110303e-01,9.117987e-01,9.125253e-01,9.132140e-01,& + & 9.138682e-01,9.144910e-01,9.150850e-01,9.156524e-01,9.161955e-01,& + & 9.167160e-01,9.172157e-01,9.176959e-01,9.181581e-01,9.186034e-01,& + & 9.190330e-01,9.194478e-01,9.198488e-01,9.202368e-01,9.206126e-01,& + & 9.209768e-01,9.213301e-01,9.216731e-01 / + data asyice2(:, 19) / & + & 8.116560e-01,8.488278e-01,8.674331e-01,8.788148e-01,8.865810e-01,& + & 8.922595e-01,8.966149e-01,9.000747e-01,9.028980e-01,9.052513e-01,& + & 9.072468e-01,9.089632e-01,9.104574e-01,9.117713e-01,9.129371e-01,& + & 9.139793e-01,9.149174e-01,9.157668e-01,9.165400e-01,9.172473e-01,& + & 9.178970e-01,9.184962e-01,9.190508e-01,9.195658e-01,9.200455e-01,& + & 9.204935e-01,9.209130e-01,9.213067e-01,9.216771e-01,9.220262e-01,& + & 9.223560e-01,9.226680e-01,9.229636e-01,9.232443e-01,9.235112e-01,& + & 9.237652e-01,9.240074e-01,9.242385e-01,9.244594e-01,9.246708e-01,& + & 9.248733e-01,9.250674e-01,9.252536e-01 / + data asyice2(:, 20) / & + & 8.047113e-01,8.402864e-01,8.570332e-01,8.668455e-01,8.733206e-01,& + & 8.779272e-01,8.813796e-01,8.840676e-01,8.862225e-01,8.879904e-01,& + & 8.894682e-01,8.907228e-01,8.918019e-01,8.927404e-01,8.935645e-01,& + & 8.942943e-01,8.949452e-01,8.955296e-01,8.960574e-01,8.965366e-01,& + & 8.969736e-01,8.973740e-01,8.977422e-01,8.980820e-01,8.983966e-01,& + & 8.986889e-01,8.989611e-01,8.992153e-01,8.994533e-01,8.996766e-01,& + & 8.998865e-01,9.000843e-01,9.002709e-01,9.004474e-01,9.006146e-01,& + & 9.007731e-01,9.009237e-01,9.010670e-01,9.012034e-01,9.013336e-01,& + & 9.014579e-01,9.015767e-01,9.016904e-01 / + data asyice2(:, 21) / & + & 8.179122e-01,8.480726e-01,8.621945e-01,8.704354e-01,8.758555e-01,& + & 8.797007e-01,8.825750e-01,8.848078e-01,8.865939e-01,8.880564e-01,& + & 8.892765e-01,8.903105e-01,8.911982e-01,8.919689e-01,8.926446e-01,& + & 8.932419e-01,8.937738e-01,8.942506e-01,8.946806e-01,8.950702e-01,& + & 8.954251e-01,8.957497e-01,8.960477e-01,8.963223e-01,8.965762e-01,& + & 8.968116e-01,8.970306e-01,8.972347e-01,8.974255e-01,8.976042e-01,& + & 8.977720e-01,8.979298e-01,8.980784e-01,8.982188e-01,8.983515e-01,& + & 8.984771e-01,8.985963e-01,8.987095e-01,8.988171e-01,8.989195e-01,& + & 8.990172e-01,8.991104e-01,8.991994e-01 / + data asyice2(:, 22) / & + & 8.169789e-01,8.455024e-01,8.586925e-01,8.663283e-01,8.713217e-01,& + & 8.748488e-01,8.774765e-01,8.795122e-01,8.811370e-01,8.824649e-01,& + & 8.835711e-01,8.845073e-01,8.853103e-01,8.860068e-01,8.866170e-01,& + & 8.871560e-01,8.876358e-01,8.880658e-01,8.884533e-01,8.888044e-01,& + & 8.891242e-01,8.894166e-01,8.896851e-01,8.899324e-01,8.901612e-01,& + & 8.903733e-01,8.905706e-01,8.907545e-01,8.909265e-01,8.910876e-01,& + & 8.912388e-01,8.913812e-01,8.915153e-01,8.916419e-01,8.917617e-01,& + & 8.918752e-01,8.919829e-01,8.920851e-01,8.921824e-01,8.922751e-01,& + & 8.923635e-01,8.924478e-01,8.925284e-01 / + data asyice2(:, 23) / & + & 8.387642e-01,8.569979e-01,8.658630e-01,8.711825e-01,8.747605e-01,& + & 8.773472e-01,8.793129e-01,8.808621e-01,8.821179e-01,8.831583e-01,& + & 8.840361e-01,8.847875e-01,8.854388e-01,8.860094e-01,8.865138e-01,& + & 8.869634e-01,8.873668e-01,8.877310e-01,8.880617e-01,8.883635e-01,& + & 8.886401e-01,8.888947e-01,8.891298e-01,8.893477e-01,8.895504e-01,& + & 8.897393e-01,8.899159e-01,8.900815e-01,8.902370e-01,8.903833e-01,& + & 8.905214e-01,8.906518e-01,8.907753e-01,8.908924e-01,8.910036e-01,& + & 8.911094e-01,8.912101e-01,8.913062e-01,8.913979e-01,8.914856e-01,& + & 8.915695e-01,8.916498e-01,8.917269e-01 / + data asyice2(:, 24) / & + & 8.522208e-01,8.648132e-01,8.711224e-01,8.749901e-01,8.776354e-01,& + & 8.795743e-01,8.810649e-01,8.822518e-01,8.832225e-01,8.840333e-01,& + & 8.847224e-01,8.853162e-01,8.858342e-01,8.862906e-01,8.866962e-01,& + & 8.870595e-01,8.873871e-01,8.876842e-01,8.879551e-01,8.882032e-01,& + & 8.884316e-01,8.886425e-01,8.888380e-01,8.890199e-01,8.891895e-01,& + & 8.893481e-01,8.894968e-01,8.896366e-01,8.897683e-01,8.898926e-01,& + & 8.900102e-01,8.901215e-01,8.902272e-01,8.903276e-01,8.904232e-01,& + & 8.905144e-01,8.906014e-01,8.906845e-01,8.907640e-01,8.908402e-01,& + & 8.909132e-01,8.909834e-01,8.910507e-01 / + data asyice2(:, 25) / & + & 8.578202e-01,8.683033e-01,8.735431e-01,8.767488e-01,8.789378e-01,& + & 8.805399e-01,8.817701e-01,8.827485e-01,8.835480e-01,8.842152e-01,& + & 8.847817e-01,8.852696e-01,8.856949e-01,8.860694e-01,8.864020e-01,& + & 8.866997e-01,8.869681e-01,8.872113e-01,8.874330e-01,8.876360e-01,& + & 8.878227e-01,8.879951e-01,8.881548e-01,8.883033e-01,8.884418e-01,& + & 8.885712e-01,8.886926e-01,8.888066e-01,8.889139e-01,8.890152e-01,& + & 8.891110e-01,8.892017e-01,8.892877e-01,8.893695e-01,8.894473e-01,& + & 8.895214e-01,8.895921e-01,8.896597e-01,8.897243e-01,8.897862e-01,& + & 8.898456e-01,8.899025e-01,8.899572e-01 / + data asyice2(:, 26) / & + & 8.625615e-01,8.713831e-01,8.755799e-01,8.780560e-01,8.796983e-01,& + & 8.808714e-01,8.817534e-01,8.824420e-01,8.829953e-01,8.834501e-01,& + & 8.838310e-01,8.841549e-01,8.844338e-01,8.846767e-01,8.848902e-01,& + & 8.850795e-01,8.852484e-01,8.854002e-01,8.855374e-01,8.856620e-01,& + & 8.857758e-01,8.858800e-01,8.859759e-01,8.860644e-01,8.861464e-01,& + & 8.862225e-01,8.862935e-01,8.863598e-01,8.864218e-01,8.864800e-01,& + & 8.865347e-01,8.865863e-01,8.866349e-01,8.866809e-01,8.867245e-01,& + & 8.867658e-01,8.868050e-01,8.868423e-01,8.868778e-01,8.869117e-01,& + & 8.869440e-01,8.869749e-01,8.870044e-01 / + data asyice2(:, 27) / & + & 8.587495e-01,8.684764e-01,8.728189e-01,8.752872e-01,8.768846e-01,& + & 8.780060e-01,8.788386e-01,8.794824e-01,8.799960e-01,8.804159e-01,& + & 8.807660e-01,8.810626e-01,8.813175e-01,8.815390e-01,8.817335e-01,& + & 8.819057e-01,8.820593e-01,8.821973e-01,8.823220e-01,8.824353e-01,& + & 8.825387e-01,8.826336e-01,8.827209e-01,8.828016e-01,8.828764e-01,& + & 8.829459e-01,8.830108e-01,8.830715e-01,8.831283e-01,8.831817e-01,& + & 8.832320e-01,8.832795e-01,8.833244e-01,8.833668e-01,8.834071e-01,& + & 8.834454e-01,8.834817e-01,8.835164e-01,8.835495e-01,8.835811e-01,& + & 8.836113e-01,8.836402e-01,8.836679e-01 / + data asyice2(:, 28) / & + & 8.561110e-01,8.678583e-01,8.727554e-01,8.753892e-01,8.770154e-01,& + & 8.781109e-01,8.788949e-01,8.794812e-01,8.799348e-01,8.802952e-01,& + & 8.805880e-01,8.808300e-01,8.810331e-01,8.812058e-01,8.813543e-01,& + & 8.814832e-01,8.815960e-01,8.816956e-01,8.817839e-01,8.818629e-01,& + & 8.819339e-01,8.819979e-01,8.820560e-01,8.821089e-01,8.821573e-01,& + & 8.822016e-01,8.822425e-01,8.822801e-01,8.823150e-01,8.823474e-01,& + & 8.823775e-01,8.824056e-01,8.824318e-01,8.824564e-01,8.824795e-01,& + & 8.825011e-01,8.825215e-01,8.825408e-01,8.825589e-01,8.825761e-01,& + & 8.825924e-01,8.826078e-01,8.826224e-01 / + data asyice2(:, 29) / & + & 8.311124e-01,8.688197e-01,8.900274e-01,9.040696e-01,9.142334e-01,& + & 9.220181e-01,9.282195e-01,9.333048e-01,9.375689e-01,9.412085e-01,& + & 9.443604e-01,9.471230e-01,9.495694e-01,9.517549e-01,9.537224e-01,& + & 9.555057e-01,9.571316e-01,9.586222e-01,9.599952e-01,9.612656e-01,& + & 9.624458e-01,9.635461e-01,9.645756e-01,9.655418e-01,9.664513e-01,& + & 9.673098e-01,9.681222e-01,9.688928e-01,9.696256e-01,9.703237e-01,& + & 9.709903e-01,9.716280e-01,9.722391e-01,9.728258e-01,9.733901e-01,& + & 9.739336e-01,9.744579e-01,9.749645e-01,9.754546e-01,9.759294e-01,& + & 9.763901e-01,9.768376e-01,9.772727e-01 / + +! --- ... hexagonal ice particle parameterization from fu +! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] + data extice3(:, 16) / & + & 5.194013e-01,3.215089e-01,2.327917e-01,1.824424e-01,1.499977e-01,& + & 1.273492e-01,1.106421e-01,9.780982e-02,8.764435e-02,7.939266e-02,& + & 7.256081e-02,6.681137e-02,6.190600e-02,5.767154e-02,5.397915e-02,& + & 5.073102e-02,4.785151e-02,4.528125e-02,4.297296e-02,4.088853e-02,& + & 3.899690e-02,3.727251e-02,3.569411e-02,3.424393e-02,3.290694e-02,& + & 3.167040e-02,3.052340e-02,2.945654e-02,2.846172e-02,2.753188e-02,& + & 2.666085e-02,2.584322e-02,2.507423e-02,2.434967e-02,2.366579e-02,& + & 2.301926e-02,2.240711e-02,2.182666e-02,2.127551e-02,2.075150e-02,& + & 2.025267e-02,1.977725e-02,1.932364e-02,1.889035e-02,1.847607e-02,& + & 1.807956e-02 / + data extice3(:, 17) / & + & 4.901155e-01,3.065286e-01,2.230800e-01,1.753951e-01,1.445402e-01,& + & 1.229417e-01,1.069777e-01,9.469760e-02,8.495824e-02,7.704501e-02,& + & 7.048834e-02,6.496693e-02,6.025353e-02,5.618286e-02,5.263186e-02,& + & 4.950698e-02,4.673585e-02,4.426164e-02,4.203904e-02,4.003153e-02,& + & 3.820932e-02,3.654790e-02,3.502688e-02,3.362919e-02,3.234041e-02,& + & 3.114829e-02,3.004234e-02,2.901356e-02,2.805413e-02,2.715727e-02,& + & 2.631705e-02,2.552828e-02,2.478637e-02,2.408725e-02,2.342734e-02,& + & 2.280343e-02,2.221264e-02,2.165242e-02,2.112043e-02,2.061461e-02,& + & 2.013308e-02,1.967411e-02,1.923616e-02,1.881783e-02,1.841781e-02,& + & 1.803494e-02 / + data extice3(:, 18) / & + & 5.056264e-01,3.160261e-01,2.298442e-01,1.805973e-01,1.487318e-01,& + & 1.264258e-01,1.099389e-01,9.725656e-02,8.719819e-02,7.902576e-02,& + & 7.225433e-02,6.655206e-02,6.168427e-02,5.748028e-02,5.381296e-02,& + & 5.058572e-02,4.772383e-02,4.516857e-02,4.287317e-02,4.079990e-02,& + & 3.891801e-02,3.720217e-02,3.563133e-02,3.418786e-02,3.285686e-02,& + & 3.162569e-02,3.048352e-02,2.942104e-02,2.843018e-02,2.750395e-02,& + & 2.663621e-02,2.582160e-02,2.505539e-02,2.433337e-02,2.365185e-02,& + & 2.300750e-02,2.239736e-02,2.181878e-02,2.126937e-02,2.074699e-02,& + & 2.024968e-02,1.977567e-02,1.932338e-02,1.889134e-02,1.847823e-02,& + & 1.808281e-02 / + data extice3(:, 19) / & + & 4.881605e-01,3.055237e-01,2.225070e-01,1.750688e-01,1.443736e-01,& + & 1.228869e-01,1.070054e-01,9.478893e-02,8.509997e-02,7.722769e-02,& + & 7.070495e-02,6.521211e-02,6.052311e-02,5.647351e-02,5.294088e-02,& + & 4.983217e-02,4.707539e-02,4.461398e-02,4.240288e-02,4.040575e-02,& + & 3.859298e-02,3.694016e-02,3.542701e-02,3.403655e-02,3.275444e-02,& + & 3.156849e-02,3.046827e-02,2.944481e-02,2.849034e-02,2.759812e-02,& + & 2.676226e-02,2.597757e-02,2.523949e-02,2.454400e-02,2.388750e-02,& + & 2.326682e-02,2.267909e-02,2.212176e-02,2.159253e-02,2.108933e-02,& + & 2.061028e-02,2.015369e-02,1.971801e-02,1.930184e-02,1.890389e-02,& + & 1.852300e-02 / + data extice3(:, 20) / & + & 5.103703e-01,3.188144e-01,2.317435e-01,1.819887e-01,1.497944e-01,& + & 1.272584e-01,1.106013e-01,9.778822e-02,8.762610e-02,7.936938e-02,& + & 7.252809e-02,6.676701e-02,6.184901e-02,5.760165e-02,5.389651e-02,& + & 5.063598e-02,4.774457e-02,4.516295e-02,4.284387e-02,4.074922e-02,& + & 3.884792e-02,3.711438e-02,3.552734e-02,3.406898e-02,3.272425e-02,& + & 3.148038e-02,3.032643e-02,2.925299e-02,2.825191e-02,2.731612e-02,& + & 2.643943e-02,2.561642e-02,2.484230e-02,2.411284e-02,2.342429e-02,& + & 2.277329e-02,2.215686e-02,2.157231e-02,2.101724e-02,2.048946e-02,& + & 1.998702e-02,1.950813e-02,1.905118e-02,1.861468e-02,1.819730e-02,& + & 1.779781e-02 / + data extice3(:, 21) / & + & 5.031161e-01,3.144511e-01,2.286942e-01,1.796903e-01,1.479819e-01,& + & 1.257860e-01,1.093803e-01,9.676059e-02,8.675183e-02,7.861971e-02,& + & 7.188168e-02,6.620754e-02,6.136376e-02,5.718050e-02,5.353127e-02,& + & 5.031995e-02,4.747218e-02,4.492952e-02,4.264544e-02,4.058240e-02,& + & 3.870979e-02,3.700242e-02,3.543933e-02,3.400297e-02,3.267854e-02,& + & 3.145345e-02,3.031691e-02,2.925967e-02,2.827370e-02,2.735203e-02,& + & 2.648858e-02,2.567798e-02,2.491555e-02,2.419710e-02,2.351893e-02,& + & 2.287776e-02,2.227063e-02,2.169491e-02,2.114821e-02,2.062840e-02,& + & 2.013354e-02,1.966188e-02,1.921182e-02,1.878191e-02,1.837083e-02,& + & 1.797737e-02 / + data extice3(:, 22) / & + & 4.949453e-01,3.095918e-01,2.253402e-01,1.771964e-01,1.460446e-01,& + & 1.242383e-01,1.081206e-01,9.572235e-02,8.588928e-02,7.789990e-02,& + & 7.128013e-02,6.570559e-02,6.094684e-02,5.683701e-02,5.325183e-02,& + & 5.009688e-02,4.729909e-02,4.480106e-02,4.255708e-02,4.053025e-02,& + & 3.869051e-02,3.701310e-02,3.547745e-02,3.406631e-02,3.276512e-02,& + & 3.156153e-02,3.044494e-02,2.940626e-02,2.843759e-02,2.753211e-02,& + & 2.668381e-02,2.588744e-02,2.513839e-02,2.443255e-02,2.376629e-02,& + & 2.313637e-02,2.253990e-02,2.197428e-02,2.143718e-02,2.092649e-02,& + & 2.044032e-02,1.997694e-02,1.953478e-02,1.911241e-02,1.870855e-02,& + & 1.832199e-02 / + data extice3(:, 23) / & + & 5.052816e-01,3.157665e-01,2.296233e-01,1.803986e-01,1.485473e-01,& + & 1.262514e-01,1.097718e-01,9.709524e-02,8.704139e-02,7.887264e-02,& + & 7.210424e-02,6.640454e-02,6.153894e-02,5.733683e-02,5.367116e-02,& + & 5.044537e-02,4.758477e-02,4.503066e-02,4.273629e-02,4.066395e-02,& + & 3.878291e-02,3.706784e-02,3.549771e-02,3.405488e-02,3.272448e-02,& + & 3.149387e-02,3.035221e-02,2.929020e-02,2.829979e-02,2.737397e-02,& + & 2.650663e-02,2.569238e-02,2.492651e-02,2.420482e-02,2.352361e-02,& + & 2.287954e-02,2.226968e-02,2.169136e-02,2.114220e-02,2.062005e-02,& + & 2.012296e-02,1.964917e-02,1.919709e-02,1.876524e-02,1.835231e-02,& + & 1.795707e-02 / + data extice3(:, 24) / & + & 5.042067e-01,3.151195e-01,2.291708e-01,1.800573e-01,1.482779e-01,& + & 1.260324e-01,1.095900e-01,9.694202e-02,8.691087e-02,7.876056e-02,& + & 7.200745e-02,6.632062e-02,6.146600e-02,5.727338e-02,5.361599e-02,& + & 5.039749e-02,4.754334e-02,4.499500e-02,4.270580e-02,4.063815e-02,& + & 3.876135e-02,3.705016e-02,3.548357e-02,3.404400e-02,3.271661e-02,& + & 3.148877e-02,3.034969e-02,2.929008e-02,2.830191e-02,2.737818e-02,& + & 2.651279e-02,2.570039e-02,2.493624e-02,2.421618e-02,2.353650e-02,& + & 2.289390e-02,2.228541e-02,2.170840e-02,2.116048e-02,2.063950e-02,& + & 2.014354e-02,1.967082e-02,1.921975e-02,1.878888e-02,1.837688e-02,& + & 1.798254e-02 / + data extice3(:, 25) / & + & 5.022507e-01,3.139246e-01,2.283218e-01,1.794059e-01,1.477544e-01,& + & 1.255984e-01,1.092222e-01,9.662516e-02,8.663439e-02,7.851688e-02,& + & 7.179095e-02,6.612700e-02,6.129193e-02,5.711618e-02,5.347351e-02,& + & 5.026796e-02,4.742530e-02,4.488721e-02,4.260724e-02,4.054790e-02,& + & 3.867866e-02,3.697435e-02,3.541407e-02,3.398029e-02,3.265824e-02,& + & 3.143535e-02,3.030085e-02,2.924551e-02,2.826131e-02,2.734130e-02,& + & 2.647939e-02,2.567026e-02,2.490919e-02,2.419203e-02,2.351509e-02,& + & 2.287507e-02,2.226903e-02,2.169434e-02,2.114862e-02,2.062975e-02,& + & 2.013578e-02,1.966496e-02,1.921571e-02,1.878658e-02,1.837623e-02,& + & 1.798348e-02 / + data extice3(:, 26) / & + & 5.068316e-01,3.166869e-01,2.302576e-01,1.808693e-01,1.489122e-01,& + & 1.265423e-01,1.100080e-01,9.728926e-02,8.720201e-02,7.900612e-02,& + & 7.221524e-02,6.649660e-02,6.161484e-02,5.739877e-02,5.372093e-02,& + & 5.048442e-02,4.761431e-02,4.505172e-02,4.274972e-02,4.067050e-02,& + & 3.878321e-02,3.706244e-02,3.548710e-02,3.403948e-02,3.270466e-02,& + & 3.146995e-02,3.032450e-02,2.925897e-02,2.826527e-02,2.733638e-02,& + & 2.646615e-02,2.564920e-02,2.488078e-02,2.415670e-02,2.347322e-02,& + & 2.282702e-02,2.221513e-02,2.163489e-02,2.108390e-02,2.056002e-02,& + & 2.006128e-02,1.958591e-02,1.913232e-02,1.869904e-02,1.828474e-02,& + & 1.788819e-02 / + data extice3(:, 27) / & + & 5.077707e-01,3.172636e-01,2.306695e-01,1.811871e-01,1.491691e-01,& + & 1.267565e-01,1.101907e-01,9.744773e-02,8.734125e-02,7.912973e-02,& + & 7.232591e-02,6.659637e-02,6.170530e-02,5.748120e-02,5.379634e-02,& + & 5.055367e-02,4.767809e-02,4.511061e-02,4.280423e-02,4.072104e-02,& + & 3.883015e-02,3.710611e-02,3.552776e-02,3.407738e-02,3.274002e-02,& + & 3.150296e-02,3.035532e-02,2.928776e-02,2.829216e-02,2.736150e-02,& + & 2.648961e-02,2.567111e-02,2.490123e-02,2.417576e-02,2.349098e-02,& + & 2.284354e-02,2.223049e-02,2.164914e-02,2.109711e-02,2.057222e-02,& + & 2.007253e-02,1.959626e-02,1.914181e-02,1.870770e-02,1.829261e-02,& + & 1.789531e-02 / + data extice3(:, 28) / & + & 5.062281e-01,3.163402e-01,2.300275e-01,1.807060e-01,1.487921e-01,& + & 1.264523e-01,1.099403e-01,9.723879e-02,8.716516e-02,7.898034e-02,& + & 7.219863e-02,6.648771e-02,6.161254e-02,5.740217e-02,5.372929e-02,& + & 5.049716e-02,4.763092e-02,4.507179e-02,4.277290e-02,4.069649e-02,& + & 3.881175e-02,3.709331e-02,3.552008e-02,3.407442e-02,3.274141e-02,& + & 3.150837e-02,3.036447e-02,2.930037e-02,2.830801e-02,2.738037e-02,& + & 2.651132e-02,2.569547e-02,2.492810e-02,2.420499e-02,2.352243e-02,& + & 2.287710e-02,2.226604e-02,2.168658e-02,2.113634e-02,2.061316e-02,& + & 2.011510e-02,1.964038e-02,1.918740e-02,1.875471e-02,1.834096e-02,& + & 1.794495e-02 / + data extice3(:, 29) / & + & 1.338834e-01,1.924912e-01,1.755523e-01,1.534793e-01,1.343937e-01,& + & 1.187883e-01,1.060654e-01,9.559106e-02,8.685880e-02,7.948698e-02,& + & 7.319086e-02,6.775669e-02,6.302215e-02,5.886236e-02,5.517996e-02,& + & 5.189810e-02,4.895539e-02,4.630225e-02,4.389823e-02,4.171002e-02,& + & 3.970998e-02,3.787493e-02,3.618537e-02,3.462471e-02,3.317880e-02,& + & 3.183547e-02,3.058421e-02,2.941590e-02,2.832256e-02,2.729724e-02,& + & 2.633377e-02,2.542675e-02,2.457136e-02,2.376332e-02,2.299882e-02,& + & 2.227443e-02,2.158707e-02,2.093400e-02,2.031270e-02,1.972091e-02,& + & 1.915659e-02,1.861787e-02,1.810304e-02,1.761055e-02,1.713899e-02,& + & 1.668704e-02 / + +! --- ... single-scattering albedo from fu, unitless + data ssaice3(:, 16) / & + & 6.749442e-01,6.649947e-01,6.565828e-01,6.489928e-01,6.420046e-01,& + & 6.355231e-01,6.294964e-01,6.238901e-01,6.186783e-01,6.138395e-01,& + & 6.093543e-01,6.052049e-01,6.013742e-01,5.978457e-01,5.946030e-01,& + & 5.916302e-01,5.889115e-01,5.864310e-01,5.841731e-01,5.821221e-01,& + & 5.802624e-01,5.785785e-01,5.770549e-01,5.756759e-01,5.744262e-01,& + & 5.732901e-01,5.722524e-01,5.712974e-01,5.704097e-01,5.695739e-01,& + & 5.687747e-01,5.679964e-01,5.672238e-01,5.664415e-01,5.656340e-01,& + & 5.647860e-01,5.638821e-01,5.629070e-01,5.618452e-01,5.606815e-01,& + & 5.594006e-01,5.579870e-01,5.564255e-01,5.547008e-01,5.527976e-01,& + & 5.507005e-01 / + data ssaice3(:, 17) / & + & 7.628550e-01,7.567297e-01,7.508463e-01,7.451972e-01,7.397745e-01,& + & 7.345705e-01,7.295775e-01,7.247881e-01,7.201945e-01,7.157894e-01,& + & 7.115652e-01,7.075145e-01,7.036300e-01,6.999044e-01,6.963304e-01,& + & 6.929007e-01,6.896083e-01,6.864460e-01,6.834067e-01,6.804833e-01,& + & 6.776690e-01,6.749567e-01,6.723397e-01,6.698109e-01,6.673637e-01,& + & 6.649913e-01,6.626870e-01,6.604441e-01,6.582561e-01,6.561163e-01,& + & 6.540182e-01,6.519554e-01,6.499215e-01,6.479099e-01,6.459145e-01,& + & 6.439289e-01,6.419468e-01,6.399621e-01,6.379686e-01,6.359601e-01,& + & 6.339306e-01,6.318740e-01,6.297845e-01,6.276559e-01,6.254825e-01,& + & 6.232583e-01 / + data ssaice3(:, 18) / & + & 9.924147e-01,9.882792e-01,9.842257e-01,9.802522e-01,9.763566e-01,& + & 9.725367e-01,9.687905e-01,9.651157e-01,9.615104e-01,9.579725e-01,& + & 9.544997e-01,9.510901e-01,9.477416e-01,9.444520e-01,9.412194e-01,& + & 9.380415e-01,9.349165e-01,9.318421e-01,9.288164e-01,9.258373e-01,& + & 9.229027e-01,9.200106e-01,9.171589e-01,9.143457e-01,9.115688e-01,& + & 9.088263e-01,9.061161e-01,9.034362e-01,9.007846e-01,8.981592e-01,& + & 8.955581e-01,8.929792e-01,8.904206e-01,8.878803e-01,8.853562e-01,& + & 8.828464e-01,8.803488e-01,8.778616e-01,8.753827e-01,8.729102e-01,& + & 8.704421e-01,8.679764e-01,8.655112e-01,8.630445e-01,8.605744e-01,& + & 8.580989e-01 / + data ssaice3(:, 19) / & + & 9.629413e-01,9.517182e-01,9.409209e-01,9.305366e-01,9.205529e-01,& + & 9.109569e-01,9.017362e-01,8.928780e-01,8.843699e-01,8.761992e-01,& + & 8.683536e-01,8.608204e-01,8.535873e-01,8.466417e-01,8.399712e-01,& + & 8.335635e-01,8.274062e-01,8.214868e-01,8.157932e-01,8.103129e-01,& + & 8.050336e-01,7.999432e-01,7.950294e-01,7.902798e-01,7.856825e-01,& + & 7.812250e-01,7.768954e-01,7.726815e-01,7.685711e-01,7.645522e-01,& + & 7.606126e-01,7.567404e-01,7.529234e-01,7.491498e-01,7.454074e-01,& + & 7.416844e-01,7.379688e-01,7.342485e-01,7.305118e-01,7.267468e-01,& + & 7.229415e-01,7.190841e-01,7.151628e-01,7.111657e-01,7.070811e-01,& + & 7.028972e-01 / + data ssaice3(:, 20) / & + & 9.942270e-01,9.909206e-01,9.876775e-01,9.844960e-01,9.813746e-01,& + & 9.783114e-01,9.753049e-01,9.723535e-01,9.694553e-01,9.666088e-01,& + & 9.638123e-01,9.610641e-01,9.583626e-01,9.557060e-01,9.530928e-01,& + & 9.505211e-01,9.479895e-01,9.454961e-01,9.430393e-01,9.406174e-01,& + & 9.382288e-01,9.358717e-01,9.335446e-01,9.312456e-01,9.289731e-01,& + & 9.267255e-01,9.245010e-01,9.222980e-01,9.201147e-01,9.179496e-01,& + & 9.158008e-01,9.136667e-01,9.115457e-01,9.094359e-01,9.073358e-01,& + & 9.052436e-01,9.031577e-01,9.010763e-01,8.989977e-01,8.969203e-01,& + & 8.948423e-01,8.927620e-01,8.906778e-01,8.885879e-01,8.864907e-01,& + & 8.843843e-01 / + data ssaice3(:, 21) / & + & 9.934014e-01,9.899331e-01,9.865537e-01,9.832610e-01,9.800523e-01,& + & 9.769254e-01,9.738777e-01,9.709069e-01,9.680106e-01,9.651862e-01,& + & 9.624315e-01,9.597439e-01,9.571212e-01,9.545608e-01,9.520605e-01,& + & 9.496177e-01,9.472301e-01,9.448954e-01,9.426111e-01,9.403749e-01,& + & 9.381843e-01,9.360370e-01,9.339307e-01,9.318629e-01,9.298313e-01,& + & 9.278336e-01,9.258673e-01,9.239302e-01,9.220198e-01,9.201338e-01,& + & 9.182700e-01,9.164258e-01,9.145991e-01,9.127874e-01,9.109884e-01,& + & 9.091999e-01,9.074194e-01,9.056447e-01,9.038735e-01,9.021033e-01,& + & 9.003320e-01,8.985572e-01,8.967766e-01,8.949879e-01,8.931888e-01,& + & 8.913770e-01 / + data ssaice3(:, 22) / & + & 9.994833e-01,9.992055e-01,9.989278e-01,9.986500e-01,9.983724e-01,& + & 9.980947e-01,9.978172e-01,9.975397e-01,9.972623e-01,9.969849e-01,& + & 9.967077e-01,9.964305e-01,9.961535e-01,9.958765e-01,9.955997e-01,& + & 9.953230e-01,9.950464e-01,9.947699e-01,9.944936e-01,9.942174e-01,& + & 9.939414e-01,9.936656e-01,9.933899e-01,9.931144e-01,9.928390e-01,& + & 9.925639e-01,9.922889e-01,9.920141e-01,9.917396e-01,9.914652e-01,& + & 9.911911e-01,9.909171e-01,9.906434e-01,9.903700e-01,9.900967e-01,& + & 9.898237e-01,9.895510e-01,9.892784e-01,9.890062e-01,9.887342e-01,& + & 9.884625e-01,9.881911e-01,9.879199e-01,9.876490e-01,9.873784e-01,& + & 9.871081e-01 / + data ssaice3(:, 23) / & + & 9.999343e-01,9.998917e-01,9.998492e-01,9.998067e-01,9.997642e-01,& + & 9.997218e-01,9.996795e-01,9.996372e-01,9.995949e-01,9.995528e-01,& + & 9.995106e-01,9.994686e-01,9.994265e-01,9.993845e-01,9.993426e-01,& + & 9.993007e-01,9.992589e-01,9.992171e-01,9.991754e-01,9.991337e-01,& + & 9.990921e-01,9.990505e-01,9.990089e-01,9.989674e-01,9.989260e-01,& + & 9.988846e-01,9.988432e-01,9.988019e-01,9.987606e-01,9.987194e-01,& + & 9.986782e-01,9.986370e-01,9.985959e-01,9.985549e-01,9.985139e-01,& + & 9.984729e-01,9.984319e-01,9.983910e-01,9.983502e-01,9.983094e-01,& + & 9.982686e-01,9.982279e-01,9.981872e-01,9.981465e-01,9.981059e-01,& + & 9.980653e-01 / + data ssaice3(:, 24) / & + & 9.999978e-01,9.999965e-01,9.999952e-01,9.999939e-01,9.999926e-01,& + & 9.999913e-01,9.999900e-01,9.999887e-01,9.999873e-01,9.999860e-01,& + & 9.999847e-01,9.999834e-01,9.999821e-01,9.999808e-01,9.999795e-01,& + & 9.999782e-01,9.999769e-01,9.999756e-01,9.999743e-01,9.999730e-01,& + & 9.999717e-01,9.999704e-01,9.999691e-01,9.999678e-01,9.999665e-01,& + & 9.999652e-01,9.999639e-01,9.999626e-01,9.999613e-01,9.999600e-01,& + & 9.999587e-01,9.999574e-01,9.999561e-01,9.999548e-01,9.999535e-01,& + & 9.999522e-01,9.999509e-01,9.999496e-01,9.999483e-01,9.999470e-01,& + & 9.999457e-01,9.999444e-01,9.999431e-01,9.999418e-01,9.999405e-01,& + & 9.999392e-01 / + data ssaice3(:, 25) / & + & 9.999994e-01,9.999993e-01,9.999991e-01,9.999990e-01,9.999989e-01,& + & 9.999987e-01,9.999986e-01,9.999984e-01,9.999983e-01,9.999982e-01,& + & 9.999980e-01,9.999979e-01,9.999977e-01,9.999976e-01,9.999975e-01,& + & 9.999973e-01,9.999972e-01,9.999970e-01,9.999969e-01,9.999967e-01,& + & 9.999966e-01,9.999965e-01,9.999963e-01,9.999962e-01,9.999960e-01,& + & 9.999959e-01,9.999957e-01,9.999956e-01,9.999954e-01,9.999953e-01,& + & 9.999952e-01,9.999950e-01,9.999949e-01,9.999947e-01,9.999946e-01,& + & 9.999944e-01,9.999943e-01,9.999941e-01,9.999940e-01,9.999939e-01,& + & 9.999937e-01,9.999936e-01,9.999934e-01,9.999933e-01,9.999931e-01,& + & 9.999930e-01 / + data ssaice3(:, 26) / & + & 9.999997e-01,9.999995e-01,9.999992e-01,9.999990e-01,9.999987e-01,& + & 9.999985e-01,9.999983e-01,9.999980e-01,9.999978e-01,9.999976e-01,& + & 9.999973e-01,9.999971e-01,9.999969e-01,9.999967e-01,9.999965e-01,& + & 9.999963e-01,9.999960e-01,9.999958e-01,9.999956e-01,9.999954e-01,& + & 9.999952e-01,9.999950e-01,9.999948e-01,9.999946e-01,9.999944e-01,& + & 9.999942e-01,9.999939e-01,9.999937e-01,9.999935e-01,9.999933e-01,& + & 9.999931e-01,9.999929e-01,9.999927e-01,9.999925e-01,9.999923e-01,& + & 9.999920e-01,9.999918e-01,9.999916e-01,9.999914e-01,9.999911e-01,& + & 9.999909e-01,9.999907e-01,9.999905e-01,9.999902e-01,9.999900e-01,& + & 9.999897e-01 / + data ssaice3(:, 27) / & + & 9.999991e-01,9.999985e-01,9.999980e-01,9.999974e-01,9.999968e-01,& + & 9.999963e-01,9.999957e-01,9.999951e-01,9.999946e-01,9.999940e-01,& + & 9.999934e-01,9.999929e-01,9.999923e-01,9.999918e-01,9.999912e-01,& + & 9.999907e-01,9.999901e-01,9.999896e-01,9.999891e-01,9.999885e-01,& + & 9.999880e-01,9.999874e-01,9.999869e-01,9.999863e-01,9.999858e-01,& + & 9.999853e-01,9.999847e-01,9.999842e-01,9.999836e-01,9.999831e-01,& + & 9.999826e-01,9.999820e-01,9.999815e-01,9.999809e-01,9.999804e-01,& + & 9.999798e-01,9.999793e-01,9.999787e-01,9.999782e-01,9.999776e-01,& + & 9.999770e-01,9.999765e-01,9.999759e-01,9.999754e-01,9.999748e-01,& + & 9.999742e-01 / + data ssaice3(:, 28) / & + & 9.999975e-01,9.999961e-01,9.999946e-01,9.999931e-01,9.999917e-01,& + & 9.999903e-01,9.999888e-01,9.999874e-01,9.999859e-01,9.999845e-01,& + & 9.999831e-01,9.999816e-01,9.999802e-01,9.999788e-01,9.999774e-01,& + & 9.999759e-01,9.999745e-01,9.999731e-01,9.999717e-01,9.999702e-01,& + & 9.999688e-01,9.999674e-01,9.999660e-01,9.999646e-01,9.999631e-01,& + & 9.999617e-01,9.999603e-01,9.999589e-01,9.999574e-01,9.999560e-01,& + & 9.999546e-01,9.999532e-01,9.999517e-01,9.999503e-01,9.999489e-01,& + & 9.999474e-01,9.999460e-01,9.999446e-01,9.999431e-01,9.999417e-01,& + & 9.999403e-01,9.999388e-01,9.999374e-01,9.999359e-01,9.999345e-01,& + & 9.999330e-01 / + data ssaice3(:, 29) / & + & 4.526500e-01,5.287890e-01,5.410487e-01,5.459865e-01,5.485149e-01,& + & 5.498914e-01,5.505895e-01,5.508310e-01,5.507364e-01,5.503793e-01,& + & 5.498090e-01,5.490612e-01,5.481637e-01,5.471395e-01,5.460083e-01,& + & 5.447878e-01,5.434946e-01,5.421442e-01,5.407514e-01,5.393309e-01,& + & 5.378970e-01,5.364641e-01,5.350464e-01,5.336582e-01,5.323140e-01,& + & 5.310283e-01,5.298158e-01,5.286914e-01,5.276704e-01,5.267680e-01,& + & 5.260000e-01,5.253823e-01,5.249311e-01,5.246629e-01,5.245946e-01,& + & 5.247434e-01,5.251268e-01,5.257626e-01,5.266693e-01,5.278653e-01,& + & 5.293698e-01,5.312022e-01,5.333823e-01,5.359305e-01,5.388676e-01,& + & 5.422146e-01 / + +! --- ... asymmetry factor from fu, unitless + data asyice3(:, 16) / & + & 8.340752e-01,8.435170e-01,8.517487e-01,8.592064e-01,8.660387e-01,& + & 8.723204e-01,8.780997e-01,8.834137e-01,8.882934e-01,8.927662e-01,& + & 8.968577e-01,9.005914e-01,9.039899e-01,9.070745e-01,9.098659e-01,& + & 9.123836e-01,9.146466e-01,9.166734e-01,9.184817e-01,9.200886e-01,& + & 9.215109e-01,9.227648e-01,9.238661e-01,9.248304e-01,9.256727e-01,& + & 9.264078e-01,9.270505e-01,9.276150e-01,9.281156e-01,9.285662e-01,& + & 9.289806e-01,9.293726e-01,9.297557e-01,9.301435e-01,9.305491e-01,& + & 9.309859e-01,9.314671e-01,9.320055e-01,9.326140e-01,9.333053e-01,& + & 9.340919e-01,9.349861e-01,9.360000e-01,9.371451e-01,9.384329e-01,& + & 9.398744e-01 / + data asyice3(:, 17) / & + & 8.728160e-01,8.777333e-01,8.823754e-01,8.867535e-01,8.908785e-01,& + & 8.947611e-01,8.984118e-01,9.018408e-01,9.050582e-01,9.080739e-01,& + & 9.108976e-01,9.135388e-01,9.160068e-01,9.183106e-01,9.204595e-01,& + & 9.224620e-01,9.243271e-01,9.260632e-01,9.276788e-01,9.291822e-01,& + & 9.305817e-01,9.318853e-01,9.331012e-01,9.342372e-01,9.353013e-01,& + & 9.363013e-01,9.372450e-01,9.381400e-01,9.389939e-01,9.398145e-01,& + & 9.406092e-01,9.413856e-01,9.421511e-01,9.429131e-01,9.436790e-01,& + & 9.444561e-01,9.452517e-01,9.460729e-01,9.469270e-01,9.478209e-01,& + & 9.487617e-01,9.497562e-01,9.508112e-01,9.519335e-01,9.531294e-01,& + & 9.544055e-01 / + data asyice3(:, 18) / & + & 7.897566e-01,7.948704e-01,7.998041e-01,8.045623e-01,8.091495e-01,& + & 8.135702e-01,8.178290e-01,8.219305e-01,8.258790e-01,8.296792e-01,& + & 8.333355e-01,8.368524e-01,8.402343e-01,8.434856e-01,8.466108e-01,& + & 8.496143e-01,8.525004e-01,8.552737e-01,8.579384e-01,8.604990e-01,& + & 8.629597e-01,8.653250e-01,8.675992e-01,8.697867e-01,8.718916e-01,& + & 8.739185e-01,8.758715e-01,8.777551e-01,8.795734e-01,8.813308e-01,& + & 8.830315e-01,8.846799e-01,8.862802e-01,8.878366e-01,8.893534e-01,& + & 8.908350e-01,8.922854e-01,8.937090e-01,8.951099e-01,8.964925e-01,& + & 8.978609e-01,8.992192e-01,9.005718e-01,9.019229e-01,9.032765e-01,& + & 9.046369e-01 / + data asyice3(:, 19) / & + & 7.812615e-01,7.887764e-01,7.959664e-01,8.028413e-01,8.094109e-01,& + & 8.156849e-01,8.216730e-01,8.273846e-01,8.328294e-01,8.380166e-01,& + & 8.429556e-01,8.476556e-01,8.521258e-01,8.563753e-01,8.604131e-01,& + & 8.642481e-01,8.678893e-01,8.713455e-01,8.746254e-01,8.777378e-01,& + & 8.806914e-01,8.834948e-01,8.861566e-01,8.886854e-01,8.910897e-01,& + & 8.933779e-01,8.955586e-01,8.976402e-01,8.996311e-01,9.015398e-01,& + & 9.033745e-01,9.051436e-01,9.068555e-01,9.085185e-01,9.101410e-01,& + & 9.117311e-01,9.132972e-01,9.148476e-01,9.163905e-01,9.179340e-01,& + & 9.194864e-01,9.210559e-01,9.226505e-01,9.242784e-01,9.259476e-01,& + & 9.276661e-01 / + data asyice3(:, 20) / & + & 7.640720e-01,7.691119e-01,7.739941e-01,7.787222e-01,7.832998e-01,& + & 7.877304e-01,7.920177e-01,7.961652e-01,8.001765e-01,8.040551e-01,& + & 8.078044e-01,8.114280e-01,8.149294e-01,8.183119e-01,8.215791e-01,& + & 8.247344e-01,8.277812e-01,8.307229e-01,8.335629e-01,8.363046e-01,& + & 8.389514e-01,8.415067e-01,8.439738e-01,8.463560e-01,8.486568e-01,& + & 8.508795e-01,8.530274e-01,8.551039e-01,8.571122e-01,8.590558e-01,& + & 8.609378e-01,8.627618e-01,8.645309e-01,8.662485e-01,8.679178e-01,& + & 8.695423e-01,8.711251e-01,8.726697e-01,8.741792e-01,8.756571e-01,& + & 8.771065e-01,8.785307e-01,8.799331e-01,8.813169e-01,8.826854e-01,& + & 8.840419e-01 / + data asyice3(:, 21) / & + & 7.602598e-01,7.651572e-01,7.699014e-01,7.744962e-01,7.789452e-01,& + & 7.832522e-01,7.874205e-01,7.914538e-01,7.953555e-01,7.991290e-01,& + & 8.027777e-01,8.063049e-01,8.097140e-01,8.130081e-01,8.161906e-01,& + & 8.192645e-01,8.222331e-01,8.250993e-01,8.278664e-01,8.305374e-01,& + & 8.331153e-01,8.356030e-01,8.380037e-01,8.403201e-01,8.425553e-01,& + & 8.447121e-01,8.467935e-01,8.488022e-01,8.507412e-01,8.526132e-01,& + & 8.544210e-01,8.561675e-01,8.578554e-01,8.594875e-01,8.610665e-01,& + & 8.625951e-01,8.640760e-01,8.655119e-01,8.669055e-01,8.682594e-01,& + & 8.695763e-01,8.708587e-01,8.721094e-01,8.733308e-01,8.745255e-01,& + & 8.756961e-01 / + data asyice3(:, 22) / & + & 7.568957e-01,7.606995e-01,7.644072e-01,7.680204e-01,7.715402e-01,& + & 7.749682e-01,7.783057e-01,7.815541e-01,7.847148e-01,7.877892e-01,& + & 7.907786e-01,7.936846e-01,7.965084e-01,7.992515e-01,8.019153e-01,& + & 8.045011e-01,8.070103e-01,8.094444e-01,8.118048e-01,8.140927e-01,& + & 8.163097e-01,8.184571e-01,8.205364e-01,8.225488e-01,8.244958e-01,& + & 8.263789e-01,8.281993e-01,8.299586e-01,8.316580e-01,8.332991e-01,& + & 8.348831e-01,8.364115e-01,8.378857e-01,8.393071e-01,8.406770e-01,& + & 8.419969e-01,8.432682e-01,8.444923e-01,8.456706e-01,8.468044e-01,& + & 8.478952e-01,8.489444e-01,8.499533e-01,8.509234e-01,8.518561e-01,& + & 8.527528e-01 / + data asyice3(:, 23) / & + & 7.575066e-01,7.606912e-01,7.638236e-01,7.669035e-01,7.699306e-01,& + & 7.729046e-01,7.758254e-01,7.786926e-01,7.815060e-01,7.842654e-01,& + & 7.869705e-01,7.896211e-01,7.922168e-01,7.947574e-01,7.972428e-01,& + & 7.996726e-01,8.020466e-01,8.043646e-01,8.066262e-01,8.088313e-01,& + & 8.109796e-01,8.130709e-01,8.151049e-01,8.170814e-01,8.190001e-01,& + & 8.208608e-01,8.226632e-01,8.244071e-01,8.260924e-01,8.277186e-01,& + & 8.292856e-01,8.307932e-01,8.322411e-01,8.336291e-01,8.349570e-01,& + & 8.362244e-01,8.374312e-01,8.385772e-01,8.396621e-01,8.406856e-01,& + & 8.416476e-01,8.425479e-01,8.433861e-01,8.441620e-01,8.448755e-01,& + & 8.455263e-01 / + data asyice3(:, 24) / & + & 7.568829e-01,7.597947e-01,7.626745e-01,7.655212e-01,7.683337e-01,& + & 7.711111e-01,7.738523e-01,7.765565e-01,7.792225e-01,7.818494e-01,& + & 7.844362e-01,7.869819e-01,7.894854e-01,7.919459e-01,7.943623e-01,& + & 7.967337e-01,7.990590e-01,8.013373e-01,8.035676e-01,8.057488e-01,& + & 8.078802e-01,8.099605e-01,8.119890e-01,8.139645e-01,8.158862e-01,& + & 8.177530e-01,8.195641e-01,8.213183e-01,8.230149e-01,8.246527e-01,& + & 8.262308e-01,8.277483e-01,8.292042e-01,8.305976e-01,8.319275e-01,& + & 8.331929e-01,8.343929e-01,8.355265e-01,8.365928e-01,8.375909e-01,& + & 8.385197e-01,8.393784e-01,8.401659e-01,8.408815e-01,8.415240e-01,& + & 8.420926e-01 / + data asyice3(:, 25) / & + & 7.548616e-01,7.575454e-01,7.602153e-01,7.628696e-01,7.655067e-01,& + & 7.681249e-01,7.707225e-01,7.732978e-01,7.758492e-01,7.783750e-01,& + & 7.808735e-01,7.833430e-01,7.857819e-01,7.881886e-01,7.905612e-01,& + & 7.928983e-01,7.951980e-01,7.974588e-01,7.996789e-01,8.018567e-01,& + & 8.039905e-01,8.060787e-01,8.081196e-01,8.101115e-01,8.120527e-01,& + & 8.139416e-01,8.157764e-01,8.175557e-01,8.192776e-01,8.209405e-01,& + & 8.225427e-01,8.240826e-01,8.255585e-01,8.269688e-01,8.283117e-01,& + & 8.295856e-01,8.307889e-01,8.319198e-01,8.329767e-01,8.339579e-01,& + & 8.348619e-01,8.356868e-01,8.364311e-01,8.370930e-01,8.376710e-01,& + & 8.381633e-01 / + data asyice3(:, 26) / & + & 7.491854e-01,7.518523e-01,7.545089e-01,7.571534e-01,7.597839e-01,& + & 7.623987e-01,7.649959e-01,7.675737e-01,7.701303e-01,7.726639e-01,& + & 7.751727e-01,7.776548e-01,7.801084e-01,7.825318e-01,7.849230e-01,& + & 7.872804e-01,7.896020e-01,7.918862e-01,7.941309e-01,7.963345e-01,& + & 7.984951e-01,8.006109e-01,8.026802e-01,8.047009e-01,8.066715e-01,& + & 8.085900e-01,8.104546e-01,8.122636e-01,8.140150e-01,8.157072e-01,& + & 8.173382e-01,8.189063e-01,8.204096e-01,8.218464e-01,8.232148e-01,& + & 8.245130e-01,8.257391e-01,8.268915e-01,8.279682e-01,8.289675e-01,& + & 8.298875e-01,8.307264e-01,8.314824e-01,8.321537e-01,8.327385e-01,& + & 8.332350e-01 / + data asyice3(:, 27) / & + & 7.397086e-01,7.424069e-01,7.450955e-01,7.477725e-01,7.504362e-01,& + & 7.530846e-01,7.557159e-01,7.583283e-01,7.609199e-01,7.634888e-01,& + & 7.660332e-01,7.685512e-01,7.710411e-01,7.735009e-01,7.759288e-01,& + & 7.783229e-01,7.806814e-01,7.830024e-01,7.852841e-01,7.875246e-01,& + & 7.897221e-01,7.918748e-01,7.939807e-01,7.960380e-01,7.980449e-01,& + & 7.999995e-01,8.019000e-01,8.037445e-01,8.055311e-01,8.072581e-01,& + & 8.089235e-01,8.105255e-01,8.120623e-01,8.135319e-01,8.149326e-01,& + & 8.162626e-01,8.175198e-01,8.187025e-01,8.198089e-01,8.208371e-01,& + & 8.217852e-01,8.226514e-01,8.234338e-01,8.241306e-01,8.247399e-01,& + & 8.252599e-01 / + data asyice3(:, 28) / & + & 7.224533e-01,7.251681e-01,7.278728e-01,7.305654e-01,7.332444e-01,& + & 7.359078e-01,7.385539e-01,7.411808e-01,7.437869e-01,7.463702e-01,& + & 7.489291e-01,7.514616e-01,7.539661e-01,7.564408e-01,7.588837e-01,& + & 7.612933e-01,7.636676e-01,7.660049e-01,7.683034e-01,7.705612e-01,& + & 7.727767e-01,7.749480e-01,7.770733e-01,7.791509e-01,7.811789e-01,& + & 7.831556e-01,7.850791e-01,7.869478e-01,7.887597e-01,7.905131e-01,& + & 7.922062e-01,7.938372e-01,7.954044e-01,7.969059e-01,7.983399e-01,& + & 7.997047e-01,8.009985e-01,8.022195e-01,8.033658e-01,8.044357e-01,& + & 8.054275e-01,8.063392e-01,8.071692e-01,8.079157e-01,8.085768e-01,& + & 8.091507e-01 / + data asyice3(:, 29) / & + & 8.850026e-01,9.005489e-01,9.069242e-01,9.121799e-01,9.168987e-01,& + & 9.212259e-01,9.252176e-01,9.289028e-01,9.323000e-01,9.354235e-01,& + & 9.382858e-01,9.408985e-01,9.432734e-01,9.454218e-01,9.473557e-01,& + & 9.490871e-01,9.506282e-01,9.519917e-01,9.531904e-01,9.542374e-01,& + & 9.551461e-01,9.559298e-01,9.566023e-01,9.571775e-01,9.576692e-01,& + & 9.580916e-01,9.584589e-01,9.587853e-01,9.590851e-01,9.593729e-01,& + & 9.596632e-01,9.599705e-01,9.603096e-01,9.606954e-01,9.611427e-01,& + & 9.616667e-01,9.622826e-01,9.630060e-01,9.638524e-01,9.648379e-01,& + & 9.659788e-01,9.672916e-01,9.687933e-01,9.705014e-01,9.724337e-01,& + & 9.746084e-01 / + +! --- ... fdelta from fu, unitless + data fdlice3(:, 16) / & + & 4.959277e-02,4.685292e-02,4.426104e-02,4.181231e-02,3.950191e-02,& + & 3.732500e-02,3.527675e-02,3.335235e-02,3.154697e-02,2.985578e-02,& + & 2.827395e-02,2.679666e-02,2.541909e-02,2.413640e-02,2.294378e-02,& + & 2.183639e-02,2.080940e-02,1.985801e-02,1.897736e-02,1.816265e-02,& + & 1.740905e-02,1.671172e-02,1.606585e-02,1.546661e-02,1.490917e-02,& + & 1.438870e-02,1.390038e-02,1.343939e-02,1.300089e-02,1.258006e-02,& + & 1.217208e-02,1.177212e-02,1.137536e-02,1.097696e-02,1.057210e-02,& + & 1.015596e-02,9.723704e-03,9.270516e-03,8.791565e-03,8.282026e-03,& + & 7.737072e-03,7.151879e-03,6.521619e-03,5.841467e-03,5.106597e-03,& + & 4.312183e-03 / + data fdlice3(:, 17) / & + & 5.071224e-02,5.000217e-02,4.933872e-02,4.871992e-02,4.814380e-02,& + & 4.760839e-02,4.711170e-02,4.665177e-02,4.622662e-02,4.583426e-02,& + & 4.547274e-02,4.514007e-02,4.483428e-02,4.455340e-02,4.429544e-02,& + & 4.405844e-02,4.384041e-02,4.363939e-02,4.345340e-02,4.328047e-02,& + & 4.311861e-02,4.296586e-02,4.282024e-02,4.267977e-02,4.254248e-02,& + & 4.240640e-02,4.226955e-02,4.212995e-02,4.198564e-02,4.183462e-02,& + & 4.167494e-02,4.150462e-02,4.132167e-02,4.112413e-02,4.091003e-02,& + & 4.067737e-02,4.042420e-02,4.014854e-02,3.984840e-02,3.952183e-02,& + & 3.916683e-02,3.878144e-02,3.836368e-02,3.791158e-02,3.742316e-02,& + & 3.689645e-02 / + data fdlice3(:, 18) / & + & 1.062938e-01,1.065234e-01,1.067822e-01,1.070682e-01,1.073793e-01,& + & 1.077137e-01,1.080693e-01,1.084442e-01,1.088364e-01,1.092439e-01,& + & 1.096647e-01,1.100970e-01,1.105387e-01,1.109878e-01,1.114423e-01,& + & 1.119004e-01,1.123599e-01,1.128190e-01,1.132757e-01,1.137279e-01,& + & 1.141738e-01,1.146113e-01,1.150385e-01,1.154534e-01,1.158540e-01,& + & 1.162383e-01,1.166045e-01,1.169504e-01,1.172741e-01,1.175738e-01,& + & 1.178472e-01,1.180926e-01,1.183080e-01,1.184913e-01,1.186405e-01,& + & 1.187538e-01,1.188291e-01,1.188645e-01,1.188580e-01,1.188076e-01,& + & 1.187113e-01,1.185672e-01,1.183733e-01,1.181277e-01,1.178282e-01,& + & 1.174731e-01 / + data fdlice3(:, 19) / & + & 1.076195e-01,1.065195e-01,1.054696e-01,1.044673e-01,1.035099e-01,& + & 1.025951e-01,1.017203e-01,1.008831e-01,1.000808e-01,9.931116e-02,& + & 9.857151e-02,9.785939e-02,9.717230e-02,9.650774e-02,9.586322e-02,& + & 9.523623e-02,9.462427e-02,9.402484e-02,9.343544e-02,9.285358e-02,& + & 9.227675e-02,9.170245e-02,9.112818e-02,9.055144e-02,8.996974e-02,& + & 8.938056e-02,8.878142e-02,8.816981e-02,8.754323e-02,8.689919e-02,& + & 8.623517e-02,8.554869e-02,8.483724e-02,8.409832e-02,8.332943e-02,& + & 8.252807e-02,8.169175e-02,8.081795e-02,7.990419e-02,7.894796e-02,& + & 7.794676e-02,7.689809e-02,7.579945e-02,7.464834e-02,7.344227e-02,& + & 7.217872e-02 / + data fdlice3(:, 20) / & + & 1.119014e-01,1.122706e-01,1.126690e-01,1.130947e-01,1.135456e-01,& + & 1.140199e-01,1.145154e-01,1.150302e-01,1.155623e-01,1.161096e-01,& + & 1.166703e-01,1.172422e-01,1.178233e-01,1.184118e-01,1.190055e-01,& + & 1.196025e-01,1.202008e-01,1.207983e-01,1.213931e-01,1.219832e-01,& + & 1.225665e-01,1.231411e-01,1.237050e-01,1.242561e-01,1.247926e-01,& + & 1.253122e-01,1.258132e-01,1.262934e-01,1.267509e-01,1.271836e-01,& + & 1.275896e-01,1.279669e-01,1.283134e-01,1.286272e-01,1.289063e-01,& + & 1.291486e-01,1.293522e-01,1.295150e-01,1.296351e-01,1.297104e-01,& + & 1.297390e-01,1.297189e-01,1.296480e-01,1.295244e-01,1.293460e-01,& + & 1.291109e-01 / + data fdlice3(:, 21) / & + & 1.133298e-01,1.136777e-01,1.140556e-01,1.144615e-01,1.148934e-01,& + & 1.153492e-01,1.158269e-01,1.163243e-01,1.168396e-01,1.173706e-01,& + & 1.179152e-01,1.184715e-01,1.190374e-01,1.196108e-01,1.201897e-01,& + & 1.207720e-01,1.213558e-01,1.219389e-01,1.225194e-01,1.230951e-01,& + & 1.236640e-01,1.242241e-01,1.247733e-01,1.253096e-01,1.258309e-01,& + & 1.263352e-01,1.268205e-01,1.272847e-01,1.277257e-01,1.281415e-01,& + & 1.285300e-01,1.288893e-01,1.292173e-01,1.295118e-01,1.297710e-01,& + & 1.299927e-01,1.301748e-01,1.303154e-01,1.304124e-01,1.304637e-01,& + & 1.304673e-01,1.304212e-01,1.303233e-01,1.301715e-01,1.299638e-01,& + & 1.296983e-01 / + data fdlice3(:, 22) / & + & 1.145360e-01,1.153256e-01,1.161453e-01,1.169929e-01,1.178666e-01,& + & 1.187641e-01,1.196835e-01,1.206227e-01,1.215796e-01,1.225522e-01,& + & 1.235383e-01,1.245361e-01,1.255433e-01,1.265579e-01,1.275779e-01,& + & 1.286011e-01,1.296257e-01,1.306494e-01,1.316703e-01,1.326862e-01,& + & 1.336951e-01,1.346950e-01,1.356838e-01,1.366594e-01,1.376198e-01,& + & 1.385629e-01,1.394866e-01,1.403889e-01,1.412678e-01,1.421212e-01,& + & 1.429469e-01,1.437430e-01,1.445074e-01,1.452381e-01,1.459329e-01,& + & 1.465899e-01,1.472069e-01,1.477819e-01,1.483128e-01,1.487976e-01,& + & 1.492343e-01,1.496207e-01,1.499548e-01,1.502346e-01,1.504579e-01,& + & 1.506227e-01 / + data fdlice3(:, 23) / & + & 1.153263e-01,1.161445e-01,1.169932e-01,1.178703e-01,1.187738e-01,& + & 1.197016e-01,1.206516e-01,1.216217e-01,1.226099e-01,1.236141e-01,& + & 1.246322e-01,1.256621e-01,1.267017e-01,1.277491e-01,1.288020e-01,& + & 1.298584e-01,1.309163e-01,1.319736e-01,1.330281e-01,1.340778e-01,& + & 1.351207e-01,1.361546e-01,1.371775e-01,1.381873e-01,1.391820e-01,& + & 1.401593e-01,1.411174e-01,1.420540e-01,1.429671e-01,1.438547e-01,& + & 1.447146e-01,1.455449e-01,1.463433e-01,1.471078e-01,1.478364e-01,& + & 1.485270e-01,1.491774e-01,1.497857e-01,1.503497e-01,1.508674e-01,& + & 1.513367e-01,1.517554e-01,1.521216e-01,1.524332e-01,1.526880e-01,& + & 1.528840e-01 / + data fdlice3(:, 24) / & + & 1.160842e-01,1.169118e-01,1.177697e-01,1.186556e-01,1.195676e-01,& + & 1.205036e-01,1.214616e-01,1.224394e-01,1.234349e-01,1.244463e-01,& + & 1.254712e-01,1.265078e-01,1.275539e-01,1.286075e-01,1.296664e-01,& + & 1.307287e-01,1.317923e-01,1.328550e-01,1.339149e-01,1.349699e-01,& + & 1.360179e-01,1.370567e-01,1.380845e-01,1.390991e-01,1.400984e-01,& + & 1.410803e-01,1.420429e-01,1.429840e-01,1.439016e-01,1.447936e-01,& + & 1.456579e-01,1.464925e-01,1.472953e-01,1.480642e-01,1.487972e-01,& + & 1.494923e-01,1.501472e-01,1.507601e-01,1.513287e-01,1.518511e-01,& + & 1.523252e-01,1.527489e-01,1.531201e-01,1.534368e-01,1.536969e-01,& + & 1.538984e-01 / + data fdlice3(:, 25) / & + & 1.168725e-01,1.177088e-01,1.185747e-01,1.194680e-01,1.203867e-01,& + & 1.213288e-01,1.222923e-01,1.232750e-01,1.242750e-01,1.252903e-01,& + & 1.263187e-01,1.273583e-01,1.284069e-01,1.294626e-01,1.305233e-01,& + & 1.315870e-01,1.326517e-01,1.337152e-01,1.347756e-01,1.358308e-01,& + & 1.368788e-01,1.379175e-01,1.389449e-01,1.399590e-01,1.409577e-01,& + & 1.419389e-01,1.429007e-01,1.438410e-01,1.447577e-01,1.456488e-01,& + & 1.465123e-01,1.473461e-01,1.481483e-01,1.489166e-01,1.496492e-01,& + & 1.503439e-01,1.509988e-01,1.516118e-01,1.521808e-01,1.527038e-01,& + & 1.531788e-01,1.536037e-01,1.539764e-01,1.542951e-01,1.545575e-01,& + & 1.547617e-01 / + data fdlice3(:, 26) / & + & 1.180509e-01,1.189025e-01,1.197820e-01,1.206875e-01,1.216171e-01,& + & 1.225687e-01,1.235404e-01,1.245303e-01,1.255363e-01,1.265564e-01,& + & 1.275888e-01,1.286313e-01,1.296821e-01,1.307392e-01,1.318006e-01,& + & 1.328643e-01,1.339284e-01,1.349908e-01,1.360497e-01,1.371029e-01,& + & 1.381486e-01,1.391848e-01,1.402095e-01,1.412208e-01,1.422165e-01,& + & 1.431949e-01,1.441539e-01,1.450915e-01,1.460058e-01,1.468947e-01,& + & 1.477564e-01,1.485888e-01,1.493900e-01,1.501580e-01,1.508907e-01,& + & 1.515864e-01,1.522428e-01,1.528582e-01,1.534305e-01,1.539578e-01,& + & 1.544380e-01,1.548692e-01,1.552494e-01,1.555767e-01,1.558490e-01,& + & 1.560645e-01 / + data fdlice3(:, 27) / & + & 1.200480e-01,1.209267e-01,1.218304e-01,1.227575e-01,1.237059e-01,& + & 1.246739e-01,1.256595e-01,1.266610e-01,1.276765e-01,1.287041e-01,& + & 1.297420e-01,1.307883e-01,1.318412e-01,1.328988e-01,1.339593e-01,& + & 1.350207e-01,1.360813e-01,1.371393e-01,1.381926e-01,1.392396e-01,& + & 1.402783e-01,1.413069e-01,1.423235e-01,1.433263e-01,1.443134e-01,& + & 1.452830e-01,1.462332e-01,1.471622e-01,1.480681e-01,1.489490e-01,& + & 1.498032e-01,1.506286e-01,1.514236e-01,1.521863e-01,1.529147e-01,& + & 1.536070e-01,1.542614e-01,1.548761e-01,1.554491e-01,1.559787e-01,& + & 1.564629e-01,1.568999e-01,1.572879e-01,1.576249e-01,1.579093e-01,& + & 1.581390e-01 / + data fdlice3(:, 28) / & + & 1.247813e-01,1.256496e-01,1.265417e-01,1.274560e-01,1.283905e-01,& + & 1.293436e-01,1.303135e-01,1.312983e-01,1.322964e-01,1.333060e-01,& + & 1.343252e-01,1.353523e-01,1.363855e-01,1.374231e-01,1.384632e-01,& + & 1.395042e-01,1.405441e-01,1.415813e-01,1.426140e-01,1.436404e-01,& + & 1.446587e-01,1.456672e-01,1.466640e-01,1.476475e-01,1.486157e-01,& + & 1.495671e-01,1.504997e-01,1.514117e-01,1.523016e-01,1.531673e-01,& + & 1.540073e-01,1.548197e-01,1.556026e-01,1.563545e-01,1.570734e-01,& + & 1.577576e-01,1.584054e-01,1.590149e-01,1.595843e-01,1.601120e-01,& + & 1.605962e-01,1.610349e-01,1.614266e-01,1.617693e-01,1.620614e-01,& + & 1.623011e-01 / + data fdlice3(:, 29) / & + & 1.006055e-01,9.549582e-02,9.063960e-02,8.602900e-02,8.165612e-02,& + & 7.751308e-02,7.359199e-02,6.988496e-02,6.638412e-02,6.308156e-02,& + & 5.996942e-02,5.703979e-02,5.428481e-02,5.169657e-02,4.926719e-02,& + & 4.698880e-02,4.485349e-02,4.285339e-02,4.098061e-02,3.922727e-02,& + & 3.758547e-02,3.604733e-02,3.460497e-02,3.325051e-02,3.197604e-02,& + & 3.077369e-02,2.963558e-02,2.855381e-02,2.752050e-02,2.652776e-02,& + & 2.556772e-02,2.463247e-02,2.371415e-02,2.280485e-02,2.189670e-02,& + & 2.098180e-02,2.005228e-02,1.910024e-02,1.811781e-02,1.709709e-02,& + & 1.603020e-02,1.490925e-02,1.372635e-02,1.247363e-02,1.114319e-02,& + & 9.727157e-03 / + +!> \name Fu (2001, personal communications) coefficients for cloud snow particles + +!> optical depth coefficients + real (kind=kind_phys), public :: a0s, a1s +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(nblow:nbhgh), public :: b0s, b1s +!> asymmetry coefficients + real (kind=kind_phys), dimension(nblow:nbhgh), public :: c0s + +!> \name Chou(1999) coefficients for cloud rain particles + +!> optical depth coefficients + real (kind=kind_phys), public :: a0r, a1r +!> single scattering albedo coefficients + real (kind=kind_phys), dimension(nblow:nbhgh), public :: b0r +!> asymmetry coefficients + real (kind=kind_phys), dimension(nblow:nbhgh), public :: c0r + + data a0r,a1r / 3.07e-3, 0.0 /, a0s,a1s / 0.0, 1.5 / ! fu's coeff + + data b0r / 0.466, 0.437, 0.416, 0.391, 0.374, 0.352, 0.183, & + & 0.048, 0.012, 0.000, 0.000, 0.000, 0.000, 0.496 / + data c0r / 0.975, 0.965, 0.960, 0.955, 0.952, 0.950, 0.944, & + & 0.894, 0.884, 0.883, 0.883, 0.883, 0.883, 0.980 / + data b0s / 7*0.460, 2*0.000, 4*0.000, 0.460 / + data b1s / 7*0.000, 2*1.62e-5, 4*0.000, 0.000 / + data c0s / 7*0.970, 2*0.970, 4*0.700, 0.970 / + + +!........................................! + end module module_radsw_cldprtb ! +!========================================! + +!> \ingroup module_radlw_main +!> This module contains various indexes and coefficients for SW spectral +!! bands, as well as the spectral distribution of solar flux. The values +!! of spectral solar flux are derived based on a prescribed solar +!! constant (\f$1368.22 W/m^2\f$). Scaling will be applied for the +!! actual inputted solar constant value. +!========================================! + module module_radsw_sflux ! +!........................................! +! +! *********************** module descriptions ********************** ! +! ! +! this module contains spectral distribution of solar radiation ! +! flux used to obtain the incoming solar flux at toa. ! +! ! +! modify history: ! +! originally by j.delamere, atmospheric & environmental research ! +! in 14 bands kgb data table. ! +! feb. 18, 2004 -- yu-tai hou move the reference data table ! +! to a new data module. ! +! ! +! ************************* end description ************************ ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NGMAX, NG16, NG17, NG18, NG19,& + & NG20, NG21, NG22, NG23, NG24, & + & NG25, NG26, NG27, NG28, NG29, & + & nblow, nbhgh +! + implicit none +! + public +! + integer, parameter :: MFS01 = 1 ! + integer, parameter :: MFS02 = 5 ! + integer, parameter :: MFS03 = 9 ! + integer, parameter :: MFB01 = 7 ! + integer, parameter :: MFB02 = 2 ! + integer, parameter :: MFB03 = 5 ! +! +!> coefficients for computing binary absorbing species + real (kind=kind_phys), dimension(nblow:nbhgh), public :: strrat + +!> weighting parameters for major absorbers in each band + real (kind=kind_phys), dimension(nblow:nbhgh), public :: specwt + +! --- original strrat +! data strrat / 2.52131e+2, 3.64641e-1, 3.89589e+1, 5.49281e+0, & +! & 0.00000e+0, 4.53210e-3, 2.27080e-2, 0.00000e+0, 1.24692e-1, & +! & 0.00000e+0, 0.00000e+0, 0.00000e+0, 6.67029e-7, 0.00000e+0 / +! --- strrat(22) has been multified by factor o2adj=1.6 + data strrat / 2.52131e+2, 3.64641e-1, 3.89589e+1, 5.49281e+0, & + & 0.00000e+0, 4.53210e-3, 3.63328e-2, 0.00000e+0, 1.24692e-1, & + & 0.00000e+0, 0.00000e+0, 0.00000e+0, 6.67029e-7, 0.00000e+0 / + + data specwt / 8.,4.,8.,8.,0.,8.,8.,0.,8.,0.,0.,0.,4.,0. / +! +!> reference pressure level for each of the spectral bands + integer, dimension(nblow:nbhgh), public :: layreffr + +!> indexes for 1st entries of the two key species for each of +!! the spectral bands + integer, dimension(nblow:nbhgh), public :: ix1 + +!> indexes for 2nd entries of the two key species for each of +!! the spectral bands + integer, dimension(nblow:nbhgh), public :: ix2 + +!> band index (3rd index in array sfluxref described below) + integer, dimension(nblow:nbhgh), public :: ibx + + data layreffr/ 18,30, 6, 3, 3, 8, 2, 6, 1, 2, 0,32,58,49 / + data ix1 / 1, 1, 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 3, 0 / + data ix2 / 5, 2, 5, 2, 0, 2, 6, 0, 6, 0, 0, 0, 6, 0 / + data ibx / 1, 1, 1, 2, 2, 3, 4, 3, 5, 4, 5, 6, 2, 7 / + + real (kind=kind_phys), parameter, public :: scalekur=50.15/48.37 +!> spectral solar fluxes, j=1,2,...,7 for SW band number of 16,20,23,25,26,27,29 + real (kind=kind_phys), target, public :: & + & sfluxref01(NGMAX,MFS01,MFB01) +!> spectral solar fluxes, j=1,2 for SW band number of 17 and 28 + real (kind=kind_phys), target, public :: & + & sfluxref02(NGMAX,MFS02,MFB02) +!> spectral solar fluxes, j=1,2,...,5 for SW band number of 18,19,21,22,24 + real (kind=kind_phys), target, public :: & + & sfluxref03(NGMAX,MFS03,MFB03) + +! --- setup solar sfluxref01 +! ... band 16, NG16=6 + data sfluxref01(:,:,1) / .36511300e+1,& + & .32277700e+1,.26913900e+1,.18039990e+1,.68068900e+0,.54590270e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! ... band 20, NG20=10 + data sfluxref01(:,:,2) / .93408100e+1,& + & .89372000e+1,.81934600e+1,.73919600e+1,.61212700e+1,.52395600e+1,& + & .42494100e+1,.32001300e+1,.23949790e+1,.55783362e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! ... band 23, NG23=10 + data sfluxref01(:,:,3) / .10462440e+3,& + & .94796000e+2,.40829400e+2,.35180100e+2,.28694700e+2,.21575100e+2,& + & .14638800e+2,.15911100e+1,.23587800e+1,.14541238e+1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! ... band 25, NG25=6 + data sfluxref01(:,:,4) / .42685800e+2,& + & .45772000e+2,.90953400e+2,.88238400e+2,.75011180e+2,.45315347e+1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! ... band 26, NG26=6 + data sfluxref01(:,:,5) / .29007900e+2,& + & .28408800e+2,.33338200e+2,.21820300e+2,.15982813e+2,.93700512e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! the following (NG27) values were obtained using the "low resolution" +! version of the kurucz solar source function. for unknown reasons, +! the total irradiance in this band differs from the corresponding +! total in the "high-resolution" version of the Kurucz function. +! therefore, below these values are scaled by the factor scalekur. + +! ... band 27, NG27=8 + data sfluxref01(:,:,6) / .14052600e+2,& + & .11479400e+2,.87259000e+1,.55696600e+1,.38092700e+1,.15769000e+1,& + & .29680079e+1,.19043253e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! ... band 29, NG29=12 + data sfluxref01(:,:,7) / .13288000e+1,& + & .21401800e+1,.19761200e+1,.17900000e+1,.27421900e+1,.18615160e+1,& + & .83448990e+0,.12731000e+0,.44698800e-1,.30744100e-1,.11672800e-1,& + & .16557300e-2,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! --- setup solar sfluxref02 +! ... band 17, NG17=12 + data sfluxref02(:,:,1) / & + & .31561300e+1,.30344900e+1,.29206900e+1,.26387400e+1,.23458100e+1,& + & .37790500e+1,.12908500e+1,.97039020e+0,.78781300e-1,.10810270e+0,& + & .29412900e-1,.12635380e-1,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.28314700e+1,.29591900e+1,.29667400e+1,.27767700e+1,& + & .24682600e+1,.38472400e+1,.13027900e+1,.97894900e+0,.80212200e-1,& + & .11088140e+0,.29905100e-1,.12675180e-1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.28230000e+1,.29484500e+1,.29588700e+1,& + & .27759300e+1,.24709600e+1,.38644300e+1,.13079600e+1,.98108860e+0,& + & .80199600e-1,.11130020e+0,.30051500e-1,.12844740e-1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.28171500e+1,.29378900e+1,& + & .29509100e+1,.27704600e+1,.24771600e+1,.38795600e+1,.13127700e+1,& + & .98414460e+0,.80339100e-1,.11153510e+0,.30072000e-1,.13100450e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.28233500e+1,& + & .29316800e+1,.29145500e+1,.27521300e+1,.24916800e+1,.39013400e+1,& + & .13240100e+1,.99059630e+0,.80519700e-1,.11150350e+0,.30566700e-1,& + & .13155950e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! ... band 28, NG28=6 + data sfluxref02(:,:,2) / & + & .10615600e+1,.59991000e+0,.82253900e+0,.47011400e+0,.12054496e+0,& + & .52716294e-2,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.10759800e+1,.58509900e+0,.82292900e+0,.47011400e+0,& + & .12059320e+0,.52233221e-2,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.46164700e+0,.40611300e+0,.64001400e+0,& + & .44662400e+0,.10729748e+1,.52565480e-1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.13266900e+0,.17505800e+0,& + & .74740500e+0,.82625100e+0,.11385304e+1,.60026497e-1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.75480000e-1,& + & .23224600e+0,.74740500e+0,.77667600e+0,.11821991e+1,.65932601e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0/ + +! --- setup solar sfluxref03 +! ... band 18, NG18=8 + data sfluxref03(:,:,1) / & + & .36584000e+1,.35437500e+1,.33448100e+1,.31053400e+1,.52272000e+1,& + & .34812500e+1,.12703318e+1,.98650010e-1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.38637200e+1,.34852100e+1,.33079000e+1,.30810300e+1,& + & .51827400e+1,.34533000e+1,.12591244e+1,.96720520e-1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.39037000e+1,.35065700e+1,.33062900e+1,& + & .30604600e+1,.51688900e+1,.34381600e+1,.12512870e+1,.94381020e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.39316500e+1,.35205800e+1,& + & .33134600e+1,.30494400e+1,.51550700e+1,.34226800e+1,.12456526e+1,& + & .91203220e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.39408200e+1,& + & .35522100e+1,.33186300e+1,.30473000e+1,.51324600e+1,.34110100e+1,& + & .12380195e+1,.89290320e-1,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .39419800e+1,.35874300e+1,.33210600e+1,.30586600e+1,.51105400e+1,& + & .33948500e+1,.12272675e+1,.87955720e-1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.39359600e+1,.36336600e+1,.33314400e+1,.30625200e+1,& + & .50954600e+1,.33706900e+1,.12121929e+1,.87814620e-1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.39252000e+1,.36907800e+1,.33565600e+1,& + & .30705500e+1,.50829200e+1,.33242900e+1,.11916105e+1,.87812520e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.38072100e+1,.37443700e+1,& + & .35020500e+1,.31800900e+1,.50494500e+1,.32007600e+1,.11580073e+1,& + & .87812920e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / + +! ... band 19, NG19=8 + data sfluxref03(:,:,2) / & + & .32579100e+1,.32969700e+1,.31603100e+1,.29611500e+1,.50305700e+1,& + & .33767800e+1,.12463848e+1,.97623090e-1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.32276900e+1,.32881700e+1,.31668700e+1,.29766200e+1,& + & .50388700e+1,.33829100e+1,.12493943e+1,.97174500e-1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.32229400e+1,.32778000e+1,.31742400e+1,& + & .29714300e+1,.50477800e+1,.33835100e+1,.12527049e+1,.97276400e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.32244500e+1,.32611300e+1,& + & .31843800e+1,.29692100e+1,.50516500e+1,.33840300e+1,.12553459e+1,& + & .97505500e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.32249700e+1,& + & .32510900e+1,.31874100e+1,.29697000e+1,.50548000e+1,.33852500e+1,& + & .12565675e+1,.97922400e-1,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .32263200e+1,.32417400e+1,.31852400e+1,.29740200e+1,.50554900e+1,& + & .33899800e+1,.12562855e+1,.98616200e-1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.32279300e+1,.32358900e+1,.31772000e+1,.29786900e+1,& + & .50572900e+1,.33942500e+1,.12571685e+1,.99276100e-1,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.32296600e+1,.32408700e+1,.31567600e+1,& + & .29817100e+1,.50586900e+1,.34020900e+1,.12586610e+1,.99259200e-1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.32724000e+1,.32466600e+1,& + & .31388600e+1,.29523800e+1,.50465000e+1,.34105900e+1,.12610396e+1,& + & .99262600e-1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / + +! ... band 21, NG21=10 + data sfluxref03(:,:,3) / & + & .16164300e+2,.15580600e+2,.14725400e+2,.13554100e+2,.11951900e+2,& + & .10444100e+2,.83788400e+1,.62638400e+1,.47495780e+1,.11187392e+1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.15645100e+2,.15317000e+2,.14698700e+2,.13735000e+2,& + & .12226700e+2,.10516460e+2,.84715000e+1,.63887300e+1,.48059700e+1,& + & .11263635e+1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.15609200e+2,.15329300e+2,.14688100e+2,& + & .13669300e+2,.12234200e+2,.10520100e+2,.84944200e+1,.64213800e+1,& + & .48319990e+1,.11333414e+1,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.15578600e+2,.15342200e+2,& + & .14689400e+2,.13604000e+2,.12256700e+2,.10494000e+2,.85352100e+1,& + & .64442700e+1,.48477890e+1,.11392313e+1,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.15538000e+2,& + & .15382600e+2,.14657500e+2,.13572200e+2,.12264600e+2,.10476720e+2,& + & .85715800e+1,.64634300e+1,.48602370e+1,.114454305e+1,.0000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .15512400e+2,.15398600e+2,.14624000e+2,.13553500e+2,.12246800e+2,& + & .10488910e+2,.86043400e+1,.6479850e+1,.48727470e+1,.115032015e+1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.15491000e+2,.15402800e+2,.14577200e+2,.13550700e+2,& + & .12212200e+2,.10527350e+2,.86265000e+1,.64964400e+1,.48903570e+1,& + & .115687915e+1,.0000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.15456200e+2,.15392800e+2,.14551000e+2,& + & .13512200e+2,.12189000e+2,.10582600e+2,.86584200e+1,.65155800e+1,& + & .49081390e+1,.116541315e+1,.0000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.15006900e+2,.15147900e+2,& + & .14780200e+2,.13608500e+2,.12279300e+2,.10692900e+2,.87272300e+1,& + & .65711400e+1,.49500240e+1,.116747315e+1,.0000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / + +! ... band 22, NG22=2 + data sfluxref03(:,:,4) / & + & .22870690e+2,.142292348e+1,.0000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.22872700e+2,.142092788e+1,.0000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.22877410e+2,.141623238e+1,.0000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.0000000e+0,.22879360e+2,.141425888e+1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.22880890e+2,& + & .14127222e+1,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .22882260e+2,.141135631e+1,.0000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.22883070e+2,.141054121e+1,.0000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.22884580e+2,.140903474e+1,.0000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.0000000e+0,.22885890e+2,.140772281e+1,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / + +! ... band 24, NG24=8 + data sfluxref03(:,:,5) / & + & .67485000e+2,.60119600e+2,.46277600e+2,.31190000e+2,.10594640e+2,& + & .15530850e+1,.82783000e+0,.13921180e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.66669400e+2,.58294800e+2,.47994500e+2,.32163300e+2,& + & .10551730e+2,.15462830e+1,.82782300e+0,.13922180e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.66436200e+2,.58556400e+2,.47978900e+2,& + & .32183500e+2,.10528620e+2,.15397570e+1,.82447300e+0,.13921180e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.66368100e+2,.58663000e+2,& + & .47964300e+2,.32188200e+2,.10508680e+2,.15344650e+1,.82105100e+0,& + & .13921180e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.66325500e+2,& + & .58727000e+2,.47967600e+2,.32196900e+2,.10482800e+2,.15295910e+1,& + & .81841600e+0,.13922180e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .66303600e+2,.58785900e+2,.47960400e+2,.32194700e+2,.10462370e+2,& + & .15250500e+1,.81580900e+0,.13921180e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.66332200e+2,.58793500e+2,.47946700e+2,.32196300e+2,& + & .10445690e+2,.15221860e+1,.81413300e+0,.13631770e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.66389100e+2,.58828200e+2,.47920000e+2,& + & .32155700e+2,.10430340e+2,.15208810e+1,.81012300e+0,.13260880e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.67319100e+2,.58382700e+2,& + & .47610800e+2,.32032700e+2,.10390010e+2,.15156730e+1,.80297600e+0,& + & .13316830e+0,.00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0,& + & .00000000e+0,.00000000e+0,.00000000e+0,.00000000e+0 / + +!........................................! + end module module_radsw_sflux ! +!========================================! + +!>\defgroup module_radsw_kgbnn module_radsw_kgbnn +!>\ingroup module_radsw_main +!! @{ + +!> This module sets up absorption coefficients for band 16: 2600-3250 +!! cm-1 (low - h2o, ch4; high - ch4) +!========================================! + module module_radsw_kgb16 ! +!........................................! +! +! *************** the original program descriptions *************** ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep Feb 2004 ! +! ! +! ************************ end description ************************ ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG16 + +! + implicit none +! + private +! +!> msa16=585 + integer, public :: MSA16 +!> msb16=235 + integer, public :: MSB16 +!> msf16=10 + integer, public :: MSF16 +!> mfr16=3 + integer, public :: MFR16 + parameter (MSA16=585, MSB16=235, MSF16=10, MFR16=3) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 6). + real (kind=kind_phys), public :: selfref(MSF16,NG16) + +!> the array absa(585,NG16) (ka(9,5,13,NG16)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds +!! to different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 6, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA16,NG16) + +!> the array absb(235,6) (kb(5,13:59,6)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 6, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB16,NG16) + + real (kind=kind_phys), public :: forref(MFR16,NG16) + +!> rayleigh extinction coefficient at v = \f$2925 cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 2.91e-10 + +! the array absa(585,NG16) (ka(9,5,13,NG16)) contains absorption coefs at +! the 16 chosen g-values for a range of pressure levels> ~100mb, +! temperatures, and binary species parameters (see taumol.f for definition). +! the first index in the array, js, runs from 1 to 9, and corresponds +! to different values of the binary species parameter. for instance, +! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +! js = 3 corresponds to the parameter value 2/8, etc. the second index +! in the array, jt, which runs from 1 to 5, corresponds to different +! temperatures. more specifically, jt = 3 means that the data are for +! the reference temperature tref for this pressure level, jt = 2 refers +! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +! is for tref+30. the third index, jp, runs from 1 to 13 and refers +! to the jpth reference pressure level (see taumol.f for these levels +! in mb). the fourth index, ig, goes from 1 to 6, and indicates +! which g-interval the absorption coefficients are for. + + data absa( 1:180, 1) / & + & .6164391E-04,.1393981E-03,.1485874E-03,.1470456E-03,.1378359E-03,& + & .1251049E-03,.1080809E-03,.8380100E-04,.4375937E-04,.6303123E-04,& + & .1387829E-03,.1476732E-03,.1465675E-03,.1376116E-03,.1247762E-03,& + & .1082831E-03,.8452911E-04,.4545314E-04,.6421152E-04,.1383722E-03,& + & .1469969E-03,.1464177E-03,.1376712E-03,.1247454E-03,.1085938E-03,& + & .8527181E-04,.4714073E-04,.6487941E-04,.1376604E-03,.1463450E-03,& + & .1456654E-03,.1375752E-03,.1247169E-03,.1088288E-03,.8599534E-04,& + & .4882216E-04,.6543285E-04,.1371565E-03,.1459883E-03,.1450442E-03,& + & .1376047E-03,.1246488E-03,.1084938E-03,.8677500E-04,.5041239E-04,& + & .5313622E-04,.1212259E-03,.1294107E-03,.1289969E-03,.1215056E-03,& + & .1099177E-03,.9560988E-04,.7413197E-04,.3741326E-04,.5429633E-04,& + & .1208023E-03,.1288524E-03,.1287190E-03,.1215251E-03,.1095731E-03,& + & .9593147E-04,.7493945E-04,.3890369E-04,.5532831E-04,.1205422E-03,& + & .1285240E-03,.1281017E-03,.1216844E-03,.1097557E-03,.9586096E-04,& + & .7569726E-04,.4033143E-04,.5592005E-04,.1201155E-03,.1280667E-03,& + & .1275655E-03,.1215386E-03,.1099924E-03,.9556109E-04,.7641040E-04,& + & .4181164E-04,.5617841E-04,.1196101E-03,.1275438E-03,.1270047E-03,& + & .1210925E-03,.1101989E-03,.9565779E-04,.7709991E-04,.4321251E-04,& + & .4531290E-04,.1048278E-03,.1125651E-03,.1126461E-03,.1064403E-03,& + & .9599592E-04,.8416227E-04,.6509075E-04,.3260217E-04,.4640094E-04,& + & .1045811E-03,.1122478E-03,.1120739E-03,.1065744E-03,.9607551E-04,& + & .8395460E-04,.6589635E-04,.3382481E-04,.4717230E-04,.1043514E-03,& + & .1118439E-03,.1116296E-03,.1065479E-03,.9636785E-04,.8372961E-04,& + & .6667225E-04,.3501452E-04,.4770015E-04,.1042243E-03,.1115519E-03,& + & .1111144E-03,.1064012E-03,.9685136E-04,.8410622E-04,.6743058E-04,& + & .3619213E-04,.4786332E-04,.1037274E-03,.1110955E-03,.1107897E-03,& + & .1063675E-03,.9719954E-04,.8449192E-04,.6808715E-04,.3740757E-04,& + & .3843039E-04,.9043110E-04,.9770352E-04,.9799335E-04,.9304240E-04,& + & .8389000E-04,.7321734E-04,.5677836E-04,.2994598E-04,.3931732E-04,& + & .9024615E-04,.9732057E-04,.9745928E-04,.9306943E-04,.8414269E-04,& + & .7304152E-04,.5752626E-04,.3089971E-04,.3999765E-04,.9015208E-04,& + & .9690713E-04,.9702354E-04,.9292115E-04,.8443883E-04,.7337197E-04,& + & .5829869E-04,.3187537E-04,.4043089E-04,.8996634E-04,.9668335E-04,& + & .9670285E-04,.9286755E-04,.8481230E-04,.7380442E-04,.5906049E-04,& + & .3283818E-04,.4073202E-04,.8972393E-04,.9645513E-04,.9660020E-04,& + & .9303706E-04,.8536068E-04,.7423279E-04,.5981517E-04,.3379450E-04/ + + data absa(181:315, 1) / & + & .3239990E-04,.7798454E-04,.8455791E-04,.8504346E-04,.8081384E-04,& + & .7294914E-04,.6337302E-04,.4924460E-04,.2913833E-04,.3322912E-04,& + & .7774352E-04,.8406820E-04,.8454204E-04,.8094382E-04,.7323153E-04,& + & .6358291E-04,.4994292E-04,.2993189E-04,.3380830E-04,.7760287E-04,& + & .8375655E-04,.8415223E-04,.8078676E-04,.7365225E-04,.6386151E-04,& + & .5066949E-04,.3071453E-04,.3417420E-04,.7744463E-04,.8351059E-04,& + & .8385781E-04,.8079307E-04,.7414802E-04,.6412908E-04,.5142302E-04,& + & .3151682E-04,.3444762E-04,.7723103E-04,.8340026E-04,.8386295E-04,& + & .8097163E-04,.7469899E-04,.6465444E-04,.5217398E-04,.3235645E-04,& + & .2715767E-04,.6701770E-04,.7283633E-04,.7341902E-04,.6985462E-04,& + & .6319692E-04,.5481578E-04,.4247223E-04,.2909771E-04,.2792146E-04,& + & .6685295E-04,.7241685E-04,.7300079E-04,.6986342E-04,.6356893E-04,& + & .5491074E-04,.4310004E-04,.2966308E-04,.2845821E-04,.6661135E-04,& + & .7209651E-04,.7266374E-04,.6978860E-04,.6395350E-04,.5508302E-04,& + & .4376855E-04,.3030854E-04,.2875713E-04,.6641988E-04,.7186205E-04,& + & .7238777E-04,.6998777E-04,.6431932E-04,.5551791E-04,.4448282E-04,& + & .3094504E-04,.2891644E-04,.6615229E-04,.7169260E-04,.7229235E-04,& + & .7001252E-04,.6472305E-04,.5607907E-04,.4487260E-04,.3162719E-04,& + & .2261551E-04,.5728902E-04,.6237413E-04,.6297079E-04,.5987738E-04,& + & .5427552E-04,.4703020E-04,.3639661E-04,.2945807E-04,.2329813E-04,& + & .5709378E-04,.6201885E-04,.6258230E-04,.5996529E-04,.5461263E-04,& + & .4701194E-04,.3698989E-04,.3029693E-04,.2379683E-04,.5686371E-04,& + & .6178860E-04,.6234127E-04,.5990707E-04,.5500772E-04,.4729286E-04,& + & .3760923E-04,.3119772E-04,.2405414E-04,.5664356E-04,.6153544E-04,& + & .6214186E-04,.6002313E-04,.5529452E-04,.4777815E-04,.3824621E-04,& + & .3201199E-04,.2417921E-04,.5638188E-04,.6131618E-04,.6200411E-04,& + & .5999630E-04,.5566905E-04,.4832075E-04,.3841731E-04,.3273083E-04/ + + data absa(316:450, 1) / & + & .1878381E-04,.4894749E-04,.5331015E-04,.5389221E-04,.5125674E-04,& + & .4647673E-04,.4004232E-04,.3106983E-04,.2910087E-04,.1940228E-04,& + & .4877469E-04,.5302872E-04,.5356337E-04,.5126792E-04,.4678873E-04,& + & .4012482E-04,.3162012E-04,.3075290E-04,.1985918E-04,.4855059E-04,& + & .5279719E-04,.5333080E-04,.5126898E-04,.4707665E-04,.4046924E-04,& + & .3217345E-04,.3150876E-04,.2014062E-04,.4829423E-04,.5255189E-04,& + & .5319514E-04,.5130651E-04,.4737582E-04,.4091784E-04,.3262566E-04,& + & .3216455E-04,.2025329E-04,.4801466E-04,.5234235E-04,.5308048E-04,& + & .5128923E-04,.4759043E-04,.4140204E-04,.3278753E-04,.3333379E-04,& + & .1546471E-04,.4162009E-04,.4540125E-04,.4587423E-04,.4356518E-04,& + & .3940508E-04,.3397440E-04,.2638191E-04,.3148426E-04,.1606324E-04,& + & .4144674E-04,.4510294E-04,.4559038E-04,.4360139E-04,.3960990E-04,& + & .3411097E-04,.2689026E-04,.3297831E-04,.1647624E-04,.4124716E-04,& + & .4486029E-04,.4540089E-04,.4359331E-04,.3994622E-04,.3443250E-04,& + & .2738815E-04,.3466130E-04,.1674831E-04,.4101176E-04,.4463266E-04,& + & .4523420E-04,.4362159E-04,.4026871E-04,.3484293E-04,.2762312E-04,& + & .3608726E-04,.1688109E-04,.4072506E-04,.4442676E-04,.4508760E-04,& + & .4359419E-04,.4044664E-04,.3522608E-04,.2789812E-04,.3743236E-04,& + & .1262626E-04,.3515542E-04,.3839650E-04,.3883879E-04,.3680058E-04,& + & .3322886E-04,.2866957E-04,.2229743E-04,.3542581E-04,.1323548E-04,& + & .3501861E-04,.3816682E-04,.3862136E-04,.3691204E-04,.3341643E-04,& + & .2882784E-04,.2274500E-04,.3810724E-04,.1360997E-04,.3480644E-04,& + & .3790261E-04,.3840467E-04,.3688940E-04,.3369037E-04,.2909482E-04,& + & .2319725E-04,.4051484E-04,.1386341E-04,.3459077E-04,.3769098E-04,& + & .3821868E-04,.3684829E-04,.3399846E-04,.2945016E-04,.2334606E-04,& + & .4250812E-04,.1401007E-04,.3434705E-04,.3748890E-04,.3806620E-04,& + & .3681278E-04,.3416954E-04,.2981567E-04,.2357415E-04,.4469942E-04/ + + data absa(451:585, 1) / & + & .1054345E-04,.2952630E-04,.3222392E-04,.3265638E-04,.3106790E-04,& + & .2796314E-04,.2415008E-04,.1892216E-04,.3133027E-04,.1103113E-04,& + & .2937313E-04,.3202245E-04,.3244622E-04,.3107680E-04,.2818612E-04,& + & .2432663E-04,.1931576E-04,.3420418E-04,.1132648E-04,.2917577E-04,& + & .3179835E-04,.3224295E-04,.3105314E-04,.2839919E-04,.2458295E-04,& + & .1960995E-04,.3745408E-04,.1151773E-04,.2897659E-04,.3158949E-04,& + & .3206591E-04,.3099578E-04,.2862811E-04,.2491522E-04,.1969533E-04,& + & .4018024E-04,.1162646E-04,.2873280E-04,.3141795E-04,.3192928E-04,& + & .3092122E-04,.2876193E-04,.2527302E-04,.1991005E-04,.4272251E-04,& + & .8773859E-05,.2472331E-04,.2698123E-04,.2731286E-04,.2605313E-04,& + & .2347524E-04,.2028179E-04,.1599354E-04,.2710338E-04,.9175082E-05,& + & .2455642E-04,.2677932E-04,.2714788E-04,.2603439E-04,.2367042E-04,& + & .2044068E-04,.1632502E-04,.2976471E-04,.9405766E-05,.2437939E-04,& + & .2657517E-04,.2695641E-04,.2600791E-04,.2387449E-04,.2068968E-04,& + & .1643613E-04,.3198691E-04,.9551613E-05,.2419222E-04,.2638939E-04,& + & .2678440E-04,.2590383E-04,.2398600E-04,.2098502E-04,.1655507E-04,& + & .3463054E-04,.9634553E-05,.2396313E-04,.2622876E-04,.2664925E-04,& + & .2582504E-04,.2410681E-04,.2125060E-04,.1672669E-04,.3742745E-04,& + & .7283549E-05,.2064472E-04,.2252697E-04,.2280007E-04,.2176915E-04,& + & .1965230E-04,.1697791E-04,.1344921E-04,.2262985E-04,.7614582E-05,& + & .2049273E-04,.2234335E-04,.2265284E-04,.2175650E-04,.1980433E-04,& + & .1713132E-04,.1373534E-04,.2489034E-04,.7799854E-05,.2032918E-04,& + & .2216475E-04,.2247253E-04,.2168451E-04,.1997844E-04,.1730534E-04,& + & .1371476E-04,.2674112E-04,.7917832E-05,.2015404E-04,.2198881E-04,& + & .2232428E-04,.2159377E-04,.2002799E-04,.1753711E-04,.1382698E-04,& + & .2881746E-04,.7981504E-05,.1995296E-04,.2184003E-04,.2217179E-04,& + & .2152204E-04,.2013182E-04,.1776050E-04,.1402084E-04,.3110145E-04/ + + data absa( 1:180, 2) / & + & .2930165E-03,.4205176E-03,.4603190E-03,.4714149E-03,.4679470E-03,& + & .4501949E-03,.4185459E-03,.3688035E-03,.2684515E-03,.2936114E-03,& + & .4252087E-03,.4672427E-03,.4798112E-03,.4769734E-03,.4593456E-03,& + & .4281470E-03,.3781642E-03,.2764789E-03,.2946377E-03,.4315576E-03,& + & .4755024E-03,.4896418E-03,.4876102E-03,.4700407E-03,.4395838E-03,& + & .3880213E-03,.2860406E-03,.2952749E-03,.4370625E-03,.4830699E-03,& + & .4992608E-03,.4981682E-03,.4812406E-03,.4500990E-03,.3988892E-03,& + & .2947867E-03,.2963643E-03,.4435447E-03,.4919681E-03,.5108647E-03,& + & .5100757E-03,.4946687E-03,.4633694E-03,.4116274E-03,.3068946E-03,& + & .2564192E-03,.3741028E-03,.4121845E-03,.4222514E-03,.4178533E-03,& + & .4017900E-03,.3723948E-03,.3265092E-03,.2280897E-03,.2572159E-03,& + & .3784588E-03,.4184094E-03,.4294373E-03,.4260348E-03,.4103047E-03,& + & .3806553E-03,.3334951E-03,.2357658E-03,.2585085E-03,.3843346E-03,& + & .4259985E-03,.4392394E-03,.4361957E-03,.4206279E-03,.3905943E-03,& + & .3429498E-03,.2431183E-03,.2596736E-03,.3898247E-03,.4335148E-03,& + & .4488328E-03,.4466516E-03,.4312067E-03,.4012724E-03,.3532432E-03,& + & .2517667E-03,.2607431E-03,.3954864E-03,.4412810E-03,.4585918E-03,& + & .4573106E-03,.4422671E-03,.4128750E-03,.3642066E-03,.2619245E-03,& + & .2235048E-03,.3314541E-03,.3652461E-03,.3744704E-03,.3699739E-03,& + & .3548398E-03,.3279534E-03,.2865252E-03,.1924155E-03,.2243217E-03,& + & .3351441E-03,.3704468E-03,.3812002E-03,.3769484E-03,.3624388E-03,& + & .3347617E-03,.2927657E-03,.1990504E-03,.2253955E-03,.3397624E-03,& + & .3767056E-03,.3889755E-03,.3852321E-03,.3709575E-03,.3432829E-03,& + & .3003296E-03,.2050004E-03,.2269437E-03,.3455225E-03,.3848163E-03,& + & .3985839E-03,.3955107E-03,.3808205E-03,.3527054E-03,.3092164E-03,& + & .2125103E-03,.2280141E-03,.3507535E-03,.3920562E-03,.4069340E-03,& + & .4049634E-03,.3903833E-03,.3628870E-03,.3187283E-03,.2207668E-03,& + & .1945146E-03,.2918639E-03,.3214502E-03,.3303679E-03,.3254231E-03,& + & .3116270E-03,.2876070E-03,.2498710E-03,.1637253E-03,.1954096E-03,& + & .2951961E-03,.3261050E-03,.3361412E-03,.3314562E-03,.3181672E-03,& + & .2938352E-03,.2559070E-03,.1693706E-03,.1965264E-03,.2992768E-03,& + & .3318268E-03,.3430041E-03,.3386437E-03,.3253725E-03,.3007759E-03,& + & .2623706E-03,.1739993E-03,.1975452E-03,.3039553E-03,.3382589E-03,& + & .3504664E-03,.3467920E-03,.3335199E-03,.3082884E-03,.2693916E-03,& + & .1801702E-03,.1992020E-03,.3099779E-03,.3465283E-03,.3595055E-03,& + & .3565400E-03,.3430057E-03,.3175611E-03,.2774855E-03,.1867273E-03/ + + data absa(181:315, 2) / & + & .1692110E-03,.2560783E-03,.2816239E-03,.2892751E-03,.2854340E-03,& + & .2729454E-03,.2512636E-03,.2176013E-03,.1406685E-03,.1700158E-03,& + & .2591285E-03,.2857505E-03,.2942600E-03,.2906779E-03,.2782649E-03,& + & .2565024E-03,.2227555E-03,.1451134E-03,.1711402E-03,.2627639E-03,& + & .2908575E-03,.3002244E-03,.2969592E-03,.2845936E-03,.2626853E-03,& + & .2280973E-03,.1489243E-03,.1723113E-03,.2667721E-03,.2966815E-03,& + & .3070349E-03,.3041790E-03,.2912783E-03,.2694000E-03,.2338131E-03,& + & .1538692E-03,.1740563E-03,.2722405E-03,.3040666E-03,.3151440E-03,& + & .3128365E-03,.2994324E-03,.2773169E-03,.2405489E-03,.1587634E-03,& + & .1467247E-03,.2239121E-03,.2459341E-03,.2521661E-03,.2491285E-03,& + & .2381498E-03,.2185025E-03,.1886728E-03,.1245807E-03,.1473884E-03,& + & .2265685E-03,.2495294E-03,.2564125E-03,.2535594E-03,.2425776E-03,& + & .2232033E-03,.1930135E-03,.1274953E-03,.1482897E-03,.2296257E-03,& + & .2540362E-03,.2615549E-03,.2589723E-03,.2479233E-03,.2285370E-03,& + & .1976049E-03,.1306204E-03,.1494392E-03,.2332170E-03,.2591337E-03,& + & .2675927E-03,.2648872E-03,.2537659E-03,.2341528E-03,.2022251E-03,& + & .1344888E-03,.1508093E-03,.2374102E-03,.2648426E-03,.2740852E-03,& + & .2718576E-03,.2604781E-03,.2406433E-03,.2081661E-03,.1378196E-03,& + & .1263109E-03,.1951428E-03,.2144975E-03,.2195749E-03,.2170080E-03,& + & .2069188E-03,.1894328E-03,.1633783E-03,.1200887E-03,.1271134E-03,& + & .1973810E-03,.2175147E-03,.2232648E-03,.2204590E-03,.2109194E-03,& + & .1937750E-03,.1670597E-03,.1213160E-03,.1278627E-03,.2000293E-03,& + & .2212521E-03,.2276502E-03,.2250313E-03,.2152307E-03,.1982160E-03,& + & .1708010E-03,.1229746E-03,.1288762E-03,.2031265E-03,.2255973E-03,& + & .2327902E-03,.2301752E-03,.2203853E-03,.2029333E-03,.1746039E-03,& + & .1249396E-03,.1300624E-03,.2067082E-03,.2305851E-03,.2383986E-03,& + & .2363202E-03,.2260966E-03,.2085247E-03,.1797897E-03,.1276706E-03/ + + data absa(316:450, 2) / & + & .1087530E-03,.1695227E-03,.1869845E-03,.1912855E-03,.1886016E-03,& + & .1794107E-03,.1640395E-03,.1407348E-03,.1388109E-03,.1095657E-03,& + & .1712971E-03,.1895043E-03,.1945158E-03,.1916236E-03,.1827598E-03,& + & .1678635E-03,.1438343E-03,.1366925E-03,.1103222E-03,.1736665E-03,& + & .1926247E-03,.1982051E-03,.1955376E-03,.1864091E-03,.1715841E-03,& + & .1469470E-03,.1364063E-03,.1111854E-03,.1763283E-03,.1961855E-03,& + & .2023728E-03,.2000777E-03,.1907608E-03,.1757564E-03,.1506354E-03,& + & .1369112E-03,.1122634E-03,.1793268E-03,.2003957E-03,.2070334E-03,& + & .2051943E-03,.1958970E-03,.1805692E-03,.1551262E-03,.1374744E-03,& + & .9300705E-04,.1464182E-03,.1620111E-03,.1662152E-03,.1638421E-03,& + & .1556181E-03,.1415254E-03,.1207125E-03,.2197460E-03,.9379197E-04,& + & .1478848E-03,.1642219E-03,.1688554E-03,.1664207E-03,.1584541E-03,& + & .1446859E-03,.1233342E-03,.2178811E-03,.9457710E-04,.1498107E-03,& + & .1668492E-03,.1719850E-03,.1697382E-03,.1615171E-03,.1478254E-03,& + & .1260245E-03,.2169464E-03,.9536836E-04,.1520740E-03,.1699345E-03,& + & .1755822E-03,.1735872E-03,.1652759E-03,.1515057E-03,.1293800E-03,& + & .2166357E-03,.9627944E-04,.1547433E-03,.1735275E-03,.1795990E-03,& + & .1780373E-03,.1697434E-03,.1556408E-03,.1331356E-03,.2164129E-03,& + & .7917379E-04,.1259529E-03,.1400562E-03,.1440600E-03,.1421290E-03,& + & .1348884E-03,.1219352E-03,.1031837E-03,.3271209E-03,.7977861E-04,& + & .1271040E-03,.1418834E-03,.1462764E-03,.1442107E-03,.1372758E-03,& + & .1246562E-03,.1054164E-03,.3261360E-03,.8053422E-04,.1287862E-03,& + & .1442112E-03,.1488988E-03,.1470409E-03,.1399784E-03,.1274996E-03,& + & .1079546E-03,.3247606E-03,.8124880E-04,.1308583E-03,.1468362E-03,& + & .1519274E-03,.1504180E-03,.1431923E-03,.1307815E-03,.1110513E-03,& + & .3234572E-03,.8201452E-04,.1331325E-03,.1497495E-03,.1553833E-03,& + & .1542308E-03,.1471022E-03,.1343535E-03,.1143694E-03,.3218489E-03/ + + data absa(451:585, 2) / & + & .6728851E-04,.1080906E-03,.1208580E-03,.1247323E-03,.1232827E-03,& + & .1175266E-03,.1060571E-03,.8883780E-04,.3501958E-03,.6791800E-04,& + & .1091898E-03,.1225378E-03,.1268241E-03,.1253901E-03,.1196653E-03,& + & .1084469E-03,.9082183E-04,.3442870E-03,.6851447E-04,.1107863E-03,& + & .1246494E-03,.1293024E-03,.1281246E-03,.1222490E-03,.1111838E-03,& + & .9324574E-04,.3420183E-03,.6908353E-04,.1126804E-03,.1269928E-03,& + & .1321156E-03,.1312354E-03,.1252083E-03,.1140710E-03,.9617117E-04,& + & .3390113E-03,.6957312E-04,.1148165E-03,.1296320E-03,.1352293E-03,& + & .1346612E-03,.1287087E-03,.1172723E-03,.9910752E-04,.3385633E-03,& + & .5686255E-04,.9216035E-04,.1034858E-03,.1071516E-03,.1060652E-03,& + & .1014159E-03,.9163836E-04,.7623805E-04,.3310437E-03,.5734770E-04,& + & .9329051E-04,.1049670E-03,.1090060E-03,.1081383E-03,.1034188E-03,& + & .9390315E-04,.7812498E-04,.3244905E-03,.5781298E-04,.9473394E-04,& + & .1068652E-03,.1112574E-03,.1106069E-03,.1057391E-03,.9631206E-04,& + & .8054235E-04,.3210568E-03,.5822217E-04,.9640942E-04,.1089655E-03,& + & .1137847E-03,.1134036E-03,.1085277E-03,.9896999E-04,.8309374E-04,& + & .3173487E-03,.5853550E-04,.9825196E-04,.1113394E-03,.1165990E-03,& + & .1165067E-03,.1117023E-03,.1018552E-03,.8573085E-04,.3168446E-03,& + & .4783824E-04,.7831477E-04,.8819578E-04,.9148052E-04,.9081639E-04,& + & .8696960E-04,.7879106E-04,.6529420E-04,.2796540E-03,.4821354E-04,& + & .7934773E-04,.8956662E-04,.9314137E-04,.9269390E-04,.8882919E-04,& + & .8080982E-04,.6704726E-04,.2741660E-03,.4859146E-04,.8061493E-04,& + & .9116325E-04,.9515541E-04,.9486227E-04,.9088828E-04,.8295551E-04,& + & .6935405E-04,.2709349E-03,.4883862E-04,.8204290E-04,.9304806E-04,& + & .9741929E-04,.9740051E-04,.9346855E-04,.8534014E-04,.7158356E-04,& + & .2681460E-03,.4903521E-04,.8353294E-04,.9510393E-04,.9997200E-04,& + & .1001833E-03,.9622958E-04,.8790924E-04,.7395389E-04,.2673945E-03/ + + data absa( 1:180, 3) / & + & .8184572E-03,.1288796E-02,.1495187E-02,.1632713E-02,.1719945E-02,& + & .1761605E-02,.1759635E-02,.1698408E-02,.1367318E-02,.8243726E-03,& + & .1301794E-02,.1514658E-02,.1658937E-02,.1753464E-02,.1802877E-02,& + & .1805416E-02,.1745195E-02,.1405620E-02,.8348880E-03,.1320873E-02,& + & .1542641E-02,.1692748E-02,.1795401E-02,.1852780E-02,.1858131E-02,& + & .1800382E-02,.1449500E-02,.8418718E-03,.1340423E-02,.1571743E-02,& + & .1728235E-02,.1837120E-02,.1903874E-02,.1915521E-02,.1859941E-02,& + & .1503155E-02,.8531253E-03,.1366891E-02,.1607512E-02,.1771740E-02,& + & .1886777E-02,.1961375E-02,.1981251E-02,.1927613E-02,.1561788E-02,& + & .7302326E-03,.1151907E-02,.1334524E-02,.1456839E-02,.1533051E-02,& + & .1567636E-02,.1559387E-02,.1499443E-02,.1187382E-02,.7372791E-03,& + & .1164596E-02,.1352581E-02,.1480270E-02,.1561840E-02,.1601428E-02,& + & .1596993E-02,.1539888E-02,.1219763E-02,.7483530E-03,.1183063E-02,& + & .1378407E-02,.1510357E-02,.1596909E-02,.1642217E-02,.1642410E-02,& + & .1586010E-02,.1257897E-02,.7577399E-03,.1203485E-02,.1406414E-02,& + & .1543415E-02,.1634037E-02,.1686222E-02,.1692333E-02,.1636545E-02,& + & .1301186E-02,.7660501E-03,.1226282E-02,.1437446E-02,.1580408E-02,& + & .1675024E-02,.1733502E-02,.1745352E-02,.1693309E-02,.1350969E-02,& + & .6502794E-03,.1026616E-02,.1186960E-02,.1295393E-02,.1364677E-02,& + & .1394889E-02,.1381785E-02,.1317502E-02,.1017363E-02,.6567559E-03,& + & .1037505E-02,.1202583E-02,.1315591E-02,.1388459E-02,.1421306E-02,& + & .1413547E-02,.1351496E-02,.1044406E-02,.6651689E-03,.1050207E-02,& + & .1223023E-02,.1339830E-02,.1416067E-02,.1452943E-02,.1449484E-02,& + & .1390425E-02,.1076530E-02,.6772722E-03,.1071331E-02,.1249580E-02,& + & .1370662E-02,.1449539E-02,.1490615E-02,.1491899E-02,.1434093E-02,& + & .1111777E-02,.6855463E-03,.1091648E-02,.1276403E-02,.1402863E-02,& + & .1483596E-02,.1529594E-02,.1535466E-02,.1481180E-02,.1152638E-02,& + & .5768479E-03,.9115621E-03,.1053538E-02,.1150084E-02,.1211847E-02,& + & .1236742E-02,.1220110E-02,.1153457E-02,.8691713E-03,.5830135E-03,& + & .9209284E-03,.1066914E-02,.1166765E-02,.1232185E-02,.1259290E-02,& + & .1246437E-02,.1180938E-02,.8912098E-03,.5910480E-03,.9345088E-03,& + & .1084575E-02,.1187678E-02,.1255979E-02,.1286682E-02,.1276512E-02,& + & .1213240E-02,.9180720E-03,.6008298E-03,.9515132E-03,.1106486E-02,& + & .1212563E-02,.1283329E-02,.1317431E-02,.1311088E-02,.1249258E-02,& + & .9471810E-03,.6138388E-03,.9709949E-03,.1132455E-02,.1242798E-02,& + & .1315868E-02,.1353280E-02,.1350757E-02,.1291032E-02,.9816019E-03/ + + data absa(181:315, 3) / & + & .5093571E-03,.8080237E-03,.9381643E-03,.1019789E-02,.1071192E-02,& + & .1090471E-02,.1073488E-02,.1005758E-02,.7418709E-03,.5151626E-03,& + & .8165236E-03,.9496789E-03,.1034266E-02,.1088284E-02,.1110067E-02,& + & .1094940E-02,.1028625E-02,.7599047E-03,.5224485E-03,.8286429E-03,& + & .9624412E-03,.1052107E-02,.1109000E-02,.1133457E-02,.1120200E-02,& + & .1055094E-02,.7812729E-03,.5316862E-03,.8438037E-03,.9798289E-03,& + & .1073448E-02,.1132718E-02,.1160426E-02,.1149517E-02,.1085478E-02,& + & .8053947E-03,.5444831E-03,.8638786E-03,.1002962E-02,.1099774E-02,& + & .1161623E-02,.1191798E-02,.1183243E-02,.1121002E-02,.8340163E-03,& + & .4476728E-03,.7152034E-03,.8303044E-03,.9027280E-03,.9422368E-03,& + & .9566089E-03,.9387208E-03,.8743692E-03,.6315594E-03,.4531060E-03,& + & .7229985E-03,.8401962E-03,.9128749E-03,.9571607E-03,.9729227E-03,& + & .9565139E-03,.8930810E-03,.6455309E-03,.4601132E-03,.7340161E-03,& + & .8531068E-03,.9280096E-03,.9748476E-03,.9926457E-03,.9777088E-03,& + & .9149552E-03,.6618730E-03,.4687606E-03,.7470819E-03,.8686951E-03,& + & .9463629E-03,.9951022E-03,.1015485E-02,.1002244E-02,.9403643E-03,& + & .6808008E-03,.4785595E-03,.7635702E-03,.8869579E-03,.9676686E-03,& + & .1018859E-02,.1041246E-02,.1029537E-02,.9684597E-03,.7044125E-03,& + & .3929615E-03,.6307616E-03,.7313469E-03,.7929589E-03,.8247908E-03,& + & .8356659E-03,.8173907E-03,.7575170E-03,.5383971E-03,.3978536E-03,& + & .6382438E-03,.7406018E-03,.8039178E-03,.8378859E-03,.8488038E-03,& + & .8315811E-03,.7727276E-03,.5497760E-03,.4043732E-03,.6478463E-03,& + & .7517647E-03,.8168558E-03,.8526219E-03,.8656075E-03,.8491574E-03,& + & .7907891E-03,.5627384E-03,.4122128E-03,.6599763E-03,.7657659E-03,& + & .8304335E-03,.8701303E-03,.8849440E-03,.8695717E-03,.8115473E-03,& + & .5782796E-03,.4216792E-03,.6747622E-03,.7823998E-03,.8487735E-03,& + & .8905701E-03,.9067120E-03,.8925209E-03,.8346838E-03,.5962302E-03/ + + data absa(316:450, 3) / & + & .3452083E-03,.5538022E-03,.6406411E-03,.6932554E-03,.7213690E-03,& + & .7269628E-03,.7089993E-03,.6545119E-03,.4847209E-03,.3494976E-03,& + & .5608628E-03,.6492121E-03,.7026395E-03,.7319618E-03,.7381217E-03,& + & .7204878E-03,.6670675E-03,.4924614E-03,.3555168E-03,.5695884E-03,& + & .6593390E-03,.7138651E-03,.7429187E-03,.7522301E-03,.7349547E-03,& + & .6817461E-03,.5010009E-03,.3629721E-03,.5805421E-03,.6721512E-03,& + & .7278957E-03,.7573896E-03,.7683553E-03,.7514496E-03,.6984177E-03,& + & .5116719E-03,.3715828E-03,.5938995E-03,.6869808E-03,.7439941E-03,& + & .7750335E-03,.7864892E-03,.7704733E-03,.7174510E-03,.5246067E-03,& + & .3053224E-03,.4856259E-03,.5588804E-03,.6031584E-03,.6264927E-03,& + & .6296159E-03,.6127370E-03,.5636624E-03,.6772975E-03,.3090662E-03,& + & .4924553E-03,.5671508E-03,.6120265E-03,.6363728E-03,.6394116E-03,& + & .6225004E-03,.5739117E-03,.6640269E-03,.3140506E-03,.5003281E-03,& + & .5762886E-03,.6218129E-03,.6467350E-03,.6509293E-03,.6346838E-03,& + & .5862457E-03,.6537700E-03,.3203596E-03,.5098203E-03,.5876621E-03,& + & .6339281E-03,.6587374E-03,.6641130E-03,.6482634E-03,.5998107E-03,& + & .6477927E-03,.3280678E-03,.5213843E-03,.6008020E-03,.6482465E-03,& + & .6724424E-03,.6792561E-03,.6641693E-03,.6153933E-03,.6458298E-03,& + & .2733291E-03,.4289828E-03,.4894421E-03,.5250706E-03,.5435356E-03,& + & .5455983E-03,.5286069E-03,.4846966E-03,.1525269E-02,.2767436E-03,& + & .4347254E-03,.4967461E-03,.5327268E-03,.5517500E-03,.5540458E-03,& + & .5369648E-03,.4938952E-03,.1462778E-02,.2810846E-03,.4416485E-03,& + & .5047342E-03,.5418403E-03,.5610033E-03,.5634743E-03,.5472960E-03,& + & .5038891E-03,.1415701E-02,.2866866E-03,.4502441E-03,.5146077E-03,& + & .5523415E-03,.5718914E-03,.5740346E-03,.5587333E-03,.5149488E-03,& + & .1375472E-02,.2934865E-03,.4607363E-03,.5263019E-03,.5647079E-03,& + & .5847436E-03,.5869370E-03,.5719471E-03,.5277797E-03,.1341507E-02/ + + data absa(451:585, 3) / & + & .2437828E-03,.3835942E-03,.4355111E-03,.4643060E-03,.4763641E-03,& + & .4751451E-03,.4583198E-03,.4193574E-03,.1825342E-02,.2475557E-03,& + & .3898469E-03,.4421366E-03,.4710873E-03,.4839473E-03,.4831741E-03,& + & .4661299E-03,.4275995E-03,.1756933E-02,.2523063E-03,.3973500E-03,& + & .4497777E-03,.4789579E-03,.4924096E-03,.4921150E-03,.4752010E-03,& + & .4363639E-03,.1708388E-02,.2580622E-03,.4058625E-03,.4589941E-03,& + & .4884064E-03,.5025671E-03,.5020326E-03,.4855219E-03,.4461901E-03,& + & .1669299E-02,.2648941E-03,.4157912E-03,.4698491E-03,.4998329E-03,& + & .5143630E-03,.5136245E-03,.4973797E-03,.4575998E-03,.1623002E-02,& + & .2144367E-03,.3401170E-03,.3854223E-03,.4099266E-03,.4196610E-03,& + & .4161366E-03,.3989091E-03,.3620378E-03,.1821655E-02,.2181060E-03,& + & .3463069E-03,.3922259E-03,.4165637E-03,.4265488E-03,.4233797E-03,& + & .4058075E-03,.3692157E-03,.1752071E-02,.2229514E-03,.3537530E-03,& + & .4002355E-03,.4242150E-03,.4345415E-03,.4315545E-03,.4136194E-03,& + & .3770147E-03,.1694072E-02,.2286334E-03,.3622049E-03,.4092201E-03,& + & .4334592E-03,.4440346E-03,.4406362E-03,.4225253E-03,.3857130E-03,& + & .1645638E-02,.2354630E-03,.3723794E-03,.4193491E-03,.4443949E-03,& + & .4547391E-03,.4513798E-03,.4332059E-03,.3959499E-03,.1604607E-02,& + & .1873934E-03,.2995165E-03,.3394711E-03,.3611157E-03,.3690992E-03,& + & .3648908E-03,.3479275E-03,.3123745E-03,.1574790E-02,.1910454E-03,& + & .3056861E-03,.3461932E-03,.3679395E-03,.3758939E-03,.3716238E-03,& + & .3543646E-03,.3186636E-03,.1513357E-02,.1954531E-03,.3127911E-03,& + & .3540282E-03,.3758084E-03,.3835301E-03,.3790064E-03,.3616108E-03,& + & .3254549E-03,.1464333E-02,.2011139E-03,.3213571E-03,.3628469E-03,& + & .3848293E-03,.3922803E-03,.3876951E-03,.3697429E-03,.3333521E-03,& + & .1424128E-02,.2075183E-03,.3308876E-03,.3732484E-03,.3952328E-03,& + & .4025443E-03,.3978826E-03,.3793694E-03,.3424789E-03,.1389880E-02/ + + data absa( 1:180, 4) / & + & .3736324E-02,.6100560E-02,.7728410E-02,.8959576E-02,.9913897E-02,& + & .1060534E-01,.1095043E-01,.1073709E-01,.9408838E-02,.3792238E-02,& + & .6178500E-02,.7827205E-02,.9076284E-02,.1004324E-01,.1073477E-01,& + & .1108085E-01,.1083940E-01,.9519649E-02,.3871754E-02,.6278718E-02,& + & .7949468E-02,.9221394E-02,.1019996E-01,.1088941E-01,.1123148E-01,& + & .1097176E-01,.9657396E-02,.3934975E-02,.6363492E-02,.8064193E-02,& + & .9370476E-02,.1036793E-01,.1105745E-01,.1140542E-01,.1112862E-01,& + & .9816845E-02,.4020724E-02,.6468817E-02,.8206395E-02,.9541906E-02,& + & .1055918E-01,.1126073E-01,.1160795E-01,.1130758E-01,.9996192E-02,& + & .3402273E-02,.5620650E-02,.7030748E-02,.8098078E-02,.8924472E-02,& + & .9508944E-02,.9801255E-02,.9592074E-02,.8097867E-02,.3451518E-02,& + & .5698898E-02,.7132591E-02,.8219355E-02,.9056752E-02,.9642702E-02,& + & .9930623E-02,.9700146E-02,.8198722E-02,.3525436E-02,.5795932E-02,& + & .7258246E-02,.8364978E-02,.9212267E-02,.9796289E-02,.1008263E-01,& + & .9835560E-02,.8322568E-02,.3594242E-02,.5888324E-02,.7386430E-02,& + & .8518910E-02,.9379100E-02,.9970774E-02,.1025951E-01,.9989379E-02,& + & .8466107E-02,.3660490E-02,.5981362E-02,.7519542E-02,.8678334E-02,& + & .9565719E-02,.1017025E-01,.1045322E-01,.1016255E-01,.8625539E-02,& + & .3102796E-02,.5141091E-02,.6344760E-02,.7250524E-02,.7949175E-02,& + & .8434987E-02,.8669628E-02,.8481084E-02,.6903275E-02,.3148146E-02,& + & .5218469E-02,.6443866E-02,.7368450E-02,.8075641E-02,.8560889E-02,& + & .8792122E-02,.8585149E-02,.6988914E-02,.3201454E-02,.5303035E-02,& + & .6555873E-02,.7497631E-02,.8217284E-02,.8706091E-02,.8936316E-02,& + & .8708232E-02,.7092276E-02,.3275760E-02,.5404005E-02,.6690045E-02,& + & .7649565E-02,.8382414E-02,.8880227E-02,.9103836E-02,.8853150E-02,& + & .7213900E-02,.3333969E-02,.5494628E-02,.6816793E-02,.7800860E-02,& + & .8559397E-02,.9065543E-02,.9281723E-02,.9013731E-02,.7356112E-02,& + & .2831427E-02,.4682414E-02,.5696173E-02,.6452550E-02,.7031440E-02,& + & .7425488E-02,.7615078E-02,.7445178E-02,.5905547E-02,.2873398E-02,& + & .4758548E-02,.5791245E-02,.6565599E-02,.7146886E-02,.7543948E-02,& + & .7728470E-02,.7539994E-02,.5975231E-02,.2922042E-02,.4836804E-02,& + & .5896068E-02,.6683182E-02,.7278970E-02,.7678598E-02,.7858498E-02,& + & .7652488E-02,.6063670E-02,.2979003E-02,.4922733E-02,.6010505E-02,& + & .6817378E-02,.7426977E-02,.7832832E-02,.8004073E-02,.7783099E-02,& + & .6166540E-02,.3051509E-02,.5034845E-02,.6147088E-02,.6974054E-02,& + & .7599704E-02,.8009148E-02,.8169023E-02,.7931032E-02,.6289201E-02/ + + data absa(181:315, 4) / & + & .2581422E-02,.4252396E-02,.5095766E-02,.5725588E-02,.6193716E-02,& + & .6511713E-02,.6657529E-02,.6499613E-02,.5066125E-02,.2622021E-02,& + & .4323928E-02,.5186112E-02,.5827234E-02,.6301641E-02,.6620209E-02,& + & .6758605E-02,.6586843E-02,.5124677E-02,.2667849E-02,.4398967E-02,& + & .5285995E-02,.5935349E-02,.6423419E-02,.6740405E-02,.6875009E-02,& + & .6687854E-02,.5199137E-02,.2719644E-02,.4480894E-02,.5391504E-02,& + & .6059082E-02,.6557515E-02,.6877697E-02,.7004932E-02,.6806128E-02,& + & .5284911E-02,.2786609E-02,.4583687E-02,.5519294E-02,.6203484E-02,& + & .6711011E-02,.7035046E-02,.7152458E-02,.6938895E-02,.5385742E-02,& + & .2339609E-02,.3846094E-02,.4554211E-02,.5067608E-02,.5443590E-02,& + & .5691422E-02,.5796061E-02,.5651788E-02,.4350403E-02,.2380923E-02,& + & .3911794E-02,.4637326E-02,.5161799E-02,.5541208E-02,.5788128E-02,& + & .5888423E-02,.5729114E-02,.4399487E-02,.2424975E-02,.3982801E-02,& + & .4723535E-02,.5261943E-02,.5649668E-02,.5897396E-02,.5992483E-02,& + & .5819539E-02,.4460491E-02,.2474162E-02,.4061310E-02,.4818668E-02,& + & .5372412E-02,.5769446E-02,.6018440E-02,.6107034E-02,.5923338E-02,& + & .4530683E-02,.2528477E-02,.4146106E-02,.4927901E-02,.5493040E-02,& + & .5902213E-02,.6153417E-02,.6234974E-02,.6038909E-02,.4613086E-02,& + & .2108102E-02,.3463767E-02,.4067283E-02,.4486100E-02,.4783508E-02,& + & .4968566E-02,.5039362E-02,.4903349E-02,.3736969E-02,.2149169E-02,& + & .3526123E-02,.4141192E-02,.4568003E-02,.4870426E-02,.5056936E-02,& + & .5123533E-02,.4973057E-02,.3776037E-02,.2192220E-02,.3593626E-02,& + & .4218969E-02,.4658171E-02,.4967303E-02,.5154377E-02,.5214872E-02,& + & .5052489E-02,.3823705E-02,.2239930E-02,.3665815E-02,.4305224E-02,& + & .4760112E-02,.5074184E-02,.5261541E-02,.5315916E-02,.5141203E-02,& + & .3879448E-02,.2291457E-02,.3745249E-02,.4403192E-02,.4867213E-02,& + & .5191513E-02,.5380406E-02,.5427689E-02,.5240706E-02,.3946442E-02/ + + data absa(316:450, 4) / & + & .1888206E-02,.3101989E-02,.3625968E-02,.3971182E-02,.4202567E-02,& + & .4344619E-02,.4384538E-02,.4251354E-02,.3181821E-02,.1928325E-02,& + & .3162679E-02,.3693527E-02,.4045345E-02,.4282687E-02,.4424622E-02,& + & .4458656E-02,.4312656E-02,.3213796E-02,.1970231E-02,.3226941E-02,& + & .3764384E-02,.4127675E-02,.4371933E-02,.4510091E-02,.4538985E-02,& + & .4381451E-02,.3253041E-02,.2016368E-02,.3294141E-02,.3842606E-02,& + & .4216009E-02,.4467372E-02,.4604053E-02,.4627489E-02,.4457971E-02,& + & .3298935E-02,.2065463E-02,.3369431E-02,.3930153E-02,.4311858E-02,& + & .4569900E-02,.4708801E-02,.4723164E-02,.4542339E-02,.3355283E-02,& + & .1679110E-02,.2762441E-02,.3217170E-02,.3511424E-02,.3699441E-02,& + & .3807111E-02,.3820305E-02,.3685883E-02,.2768596E-02,.1718111E-02,& + & .2820629E-02,.3280981E-02,.3579835E-02,.3771324E-02,.3877601E-02,& + & .3885055E-02,.3740150E-02,.2792302E-02,.1759096E-02,.2880777E-02,& + & .3347449E-02,.3654997E-02,.3849489E-02,.3952528E-02,.3955472E-02,& + & .3800453E-02,.2822088E-02,.1804159E-02,.2943869E-02,.3420297E-02,& + & .3734906E-02,.3934456E-02,.4035234E-02,.4031563E-02,.3866511E-02,& + & .2856445E-02,.1852018E-02,.3014249E-02,.3500208E-02,.3821348E-02,& + & .4026208E-02,.4126369E-02,.4113254E-02,.3937685E-02,.2897579E-02,& + & .1485209E-02,.2447369E-02,.2842719E-02,.3098235E-02,.3261684E-02,& + & .3343620E-02,.3333197E-02,.3190317E-02,.4072685E-02,.1522667E-02,& + & .2503774E-02,.2902412E-02,.3163342E-02,.3327673E-02,.3406943E-02,& + & .3392715E-02,.3239642E-02,.4013646E-02,.1562338E-02,.2561154E-02,& + & .2966329E-02,.3232897E-02,.3398043E-02,.3474218E-02,.3456041E-02,& + & .3293328E-02,.3960211E-02,.1605822E-02,.2619463E-02,.3035388E-02,& + & .3307311E-02,.3472770E-02,.3548127E-02,.3523210E-02,.3351454E-02,& + & .3918895E-02,.1652396E-02,.2684419E-02,.3109623E-02,.3386474E-02,& + & .3553371E-02,.3627950E-02,.3594923E-02,.3414383E-02,.3895295E-02/ + + data absa(451:585, 4) / & + & .1327826E-02,.2178249E-02,.2523484E-02,.2748178E-02,.2891129E-02,& + & .2953926E-02,.2925626E-02,.2774151E-02,.5032627E-02,.1363836E-02,& + & .2231507E-02,.2582331E-02,.2811256E-02,.2953861E-02,.3013652E-02,& + & .2982332E-02,.2820761E-02,.4894171E-02,.1402555E-02,.2284583E-02,& + & .2644926E-02,.2877676E-02,.3020940E-02,.3077742E-02,.3041427E-02,& + & .2870356E-02,.4763815E-02,.1444850E-02,.2341577E-02,.2711315E-02,& + & .2948500E-02,.3091276E-02,.3147103E-02,.3103922E-02,.2923523E-02,& + & .4657359E-02,.1491126E-02,.2405746E-02,.2783605E-02,.3023985E-02,& + & .3167614E-02,.3221278E-02,.3170403E-02,.2981808E-02,.4593950E-02,& + & .1198258E-02,.1938520E-02,.2240507E-02,.2433881E-02,.2549827E-02,& + & .2596355E-02,.2561600E-02,.2410177E-02,.5165038E-02,.1231984E-02,& + & .1988536E-02,.2296997E-02,.2493517E-02,.2610218E-02,.2654628E-02,& + & .2615348E-02,.2452955E-02,.4998695E-02,.1267303E-02,.2040113E-02,& + & .2355817E-02,.2557194E-02,.2673983E-02,.2716145E-02,.2670737E-02,& + & .2497659E-02,.4849281E-02,.1307299E-02,.2095435E-02,.2418826E-02,& + & .2623945E-02,.2740846E-02,.2781831E-02,.2728441E-02,.2545893E-02,& + & .4735365E-02,.1350768E-02,.2157279E-02,.2487383E-02,.2694912E-02,& + & .2813081E-02,.2851205E-02,.2790976E-02,.2599947E-02,.4638902E-02,& + & .1094611E-02,.1729442E-02,.1987775E-02,.2148646E-02,.2243224E-02,& + & .2274670E-02,.2235199E-02,.2090113E-02,.4614858E-02,.1125402E-02,& + & .1775981E-02,.2041820E-02,.2205584E-02,.2300560E-02,.2330200E-02,& + & .2284917E-02,.2128857E-02,.4463987E-02,.1159259E-02,.1824840E-02,& + & .2098113E-02,.2265637E-02,.2360409E-02,.2388227E-02,.2336076E-02,& + & .2169572E-02,.4338182E-02,.1196616E-02,.1877338E-02,.2157749E-02,& + & .2328747E-02,.2423999E-02,.2448955E-02,.2390335E-02,.2214290E-02,& + & .4232022E-02,.1237500E-02,.1937731E-02,.2222832E-02,.2395916E-02,& + & .2492122E-02,.2513855E-02,.2450198E-02,.2264343E-02,.4147518E-02/ + + data absa( 1:180, 5) / & + & .7569383E-01,.7127726E-01,.7072055E-01,.7167894E-01,.7293550E-01,& + & .7244916E-01,.7056707E-01,.6926245E-01,.7313178E-01,.7613347E-01,& + & .7151997E-01,.7077247E-01,.7153549E-01,.7263614E-01,.7201405E-01,& + & .7009892E-01,.6889573E-01,.7285660E-01,.7647835E-01,.7168221E-01,& + & .7076014E-01,.7134341E-01,.7231870E-01,.7159794E-01,.6969923E-01,& + & .6859261E-01,.7264748E-01,.7670016E-01,.7175750E-01,.7068442E-01,& + & .7110712E-01,.7197697E-01,.7120664E-01,.6933990E-01,.6836243E-01,& + & .7255382E-01,.7691373E-01,.7183982E-01,.7062341E-01,.7088895E-01,& + & .7164992E-01,.7087382E-01,.6904623E-01,.6822798E-01,.7257501E-01,& + & .7421380E-01,.7089850E-01,.7145266E-01,.7330346E-01,.7466460E-01,& + & .7395589E-01,.7188620E-01,.7007745E-01,.7342812E-01,.7470315E-01,& + & .7115943E-01,.7149768E-01,.7312749E-01,.7437682E-01,.7354337E-01,& + & .7146237E-01,.6973763E-01,.7320381E-01,.7511576E-01,.7137057E-01,& + & .7150213E-01,.7293552E-01,.7408060E-01,.7316493E-01,.7110190E-01,& + & .6944710E-01,.7305691E-01,.7543079E-01,.7151417E-01,.7146139E-01,& + & .7272686E-01,.7376978E-01,.7280501E-01,.7076206E-01,.6923458E-01,& + & .7300795E-01,.7568786E-01,.7161383E-01,.7139697E-01,.7250907E-01,& + & .7343069E-01,.7248294E-01,.7048791E-01,.6909555E-01,.7306492E-01,& + & .7230673E-01,.7021426E-01,.7189722E-01,.7451771E-01,.7579082E-01,& + & .7503288E-01,.7282416E-01,.7049154E-01,.7299906E-01,.7286315E-01,& + & .7051801E-01,.7197408E-01,.7438907E-01,.7552182E-01,.7466506E-01,& + & .7245855E-01,.7016762E-01,.7281308E-01,.7332177E-01,.7075910E-01,& + & .7199437E-01,.7424541E-01,.7524477E-01,.7430774E-01,.7210437E-01,& + & .6988899E-01,.7270099E-01,.7375460E-01,.7098234E-01,.7200912E-01,& + & .7408957E-01,.7497762E-01,.7399034E-01,.7179310E-01,.6966381E-01,& + & .7266033E-01,.7410607E-01,.7113688E-01,.7196716E-01,.7387325E-01,& + & .7467008E-01,.7369947E-01,.7152362E-01,.6950511E-01,.7269904E-01,& + & .7006148E-01,.6923816E-01,.7203176E-01,.7518932E-01,.7630010E-01,& + & .7558723E-01,.7324666E-01,.7030687E-01,.7173847E-01,.7070776E-01,& + & .6960480E-01,.7215580E-01,.7510526E-01,.7608714E-01,.7528596E-01,& + & .7291553E-01,.7001785E-01,.7160799E-01,.7124096E-01,.6989489E-01,& + & .7221590E-01,.7501608E-01,.7584481E-01,.7498936E-01,.7259196E-01,& + & .6976034E-01,.7152087E-01,.7170772E-01,.7013752E-01,.7222754E-01,& + & .7487010E-01,.7559690E-01,.7471465E-01,.7231022E-01,.6954421E-01,& + & .7149408E-01,.7217297E-01,.7036437E-01,.7224475E-01,.7470987E-01,& + & .7536578E-01,.7448130E-01,.7207643E-01,.6939518E-01,.7153955E-01/ + + data absa(181:315, 5) / & + & .6746543E-01,.6789511E-01,.7175811E-01,.7512073E-01,.7623306E-01,& + & .7554875E-01,.7299624E-01,.6947460E-01,.6972139E-01,.6817808E-01,& + & .6831863E-01,.7191880E-01,.7511721E-01,.7607693E-01,.7533587E-01,& + & .7272951E-01,.6921640E-01,.6962219E-01,.6878127E-01,.6866239E-01,& + & .7201451E-01,.7507768E-01,.7588347E-01,.7512346E-01,.7245380E-01,& + & .6898486E-01,.6955882E-01,.6931769E-01,.6894903E-01,.7206127E-01,& + & .7499506E-01,.7568911E-01,.7490453E-01,.7221264E-01,.6878897E-01,& + & .6955676E-01,.6984062E-01,.6921967E-01,.7210380E-01,.7490218E-01,& + & .7552190E-01,.7471412E-01,.7202114E-01,.6866058E-01,.6962597E-01,& + & .6453797E-01,.6619435E-01,.7096321E-01,.7435120E-01,.7557506E-01,& + & .7489358E-01,.7213608E-01,.6797549E-01,.6697223E-01,.6531448E-01,& + & .6667806E-01,.7120136E-01,.7443855E-01,.7550608E-01,.7477578E-01,& + & .7192188E-01,.6776652E-01,.6691692E-01,.6599601E-01,.6708647E-01,& + & .7137864E-01,.7446953E-01,.7539664E-01,.7463387E-01,.7169803E-01,& + & .6757635E-01,.6690442E-01,.6658455E-01,.6741621E-01,.7148953E-01,& + & .7446547E-01,.7527439E-01,.7447360E-01,.7150646E-01,.6741051E-01,& + & .6692725E-01,.6710838E-01,.6769670E-01,.7154133E-01,.7442810E-01,& + & .7515746E-01,.7430715E-01,.7133898E-01,.6729366E-01,.6700931E-01,& + & .6127817E-01,.6414812E-01,.6958749E-01,.7293419E-01,.7429145E-01,& + & .7361146E-01,.7059124E-01,.6583890E-01,.6355716E-01,.6212572E-01,& + & .6469369E-01,.6993766E-01,.7312422E-01,.7433484E-01,.7357556E-01,& + & .7045275E-01,.6569828E-01,.6357688E-01,.6288706E-01,.6516584E-01,& + & .7021271E-01,.7326619E-01,.7432982E-01,.7348213E-01,.7031560E-01,& + & .6555824E-01,.6360213E-01,.6354801E-01,.6556305E-01,.7040342E-01,& + & .7334105E-01,.7430526E-01,.7337063E-01,.7018757E-01,.6542809E-01,& + & .6365427E-01,.6412664E-01,.6589381E-01,.7053384E-01,.7337186E-01,& + & .7426386E-01,.7326847E-01,.7006536E-01,.6533352E-01,.6375247E-01/ + + data absa(316:450, 5) / & + & .5769446E-01,.6178260E-01,.6765439E-01,.7096937E-01,.7236097E-01,& + & .7162253E-01,.6841692E-01,.6322137E-01,.5970130E-01,.5863799E-01,& + & .6240216E-01,.6811545E-01,.7126851E-01,.7252091E-01,.7168532E-01,& + & .6838432E-01,.6313347E-01,.5975507E-01,.5948073E-01,.6294022E-01,& + & .6847433E-01,.7150605E-01,.7262755E-01,.7166820E-01,.6832826E-01,& + & .6301598E-01,.5980255E-01,.6019384E-01,.6338337E-01,.6874609E-01,& + & .7165133E-01,.7270983E-01,.7163959E-01,.6825300E-01,.6292421E-01,& + & .5988086E-01,.6082893E-01,.6376171E-01,.6894902E-01,.7174796E-01,& + & .7275284E-01,.7161814E-01,.6819849E-01,.6284853E-01,.5997885E-01,& + & .5384218E-01,.5913297E-01,.6512641E-01,.6847022E-01,.6981558E-01,& + & .6898244E-01,.6574451E-01,.6014063E-01,.5493742E-01,.5486164E-01,& + & .5981373E-01,.6568933E-01,.6889734E-01,.7011656E-01,.6915288E-01,& + & .6580592E-01,.6008501E-01,.5501675E-01,.5576632E-01,.6040455E-01,& + & .6615529E-01,.6921938E-01,.7034252E-01,.6924287E-01,.6580255E-01,& + & .6001888E-01,.5509485E-01,.5653718E-01,.6090010E-01,.6649772E-01,& + & .6944333E-01,.7051698E-01,.6931819E-01,.6580285E-01,.5995294E-01,& + & .5518924E-01,.5724006E-01,.6133632E-01,.6675529E-01,.6962363E-01,& + & .7062688E-01,.6937140E-01,.6580880E-01,.5991082E-01,.5530789E-01,& + & .4986911E-01,.5625720E-01,.6219195E-01,.6550333E-01,.6673087E-01,& + & .6585114E-01,.6260934E-01,.5664518E-01,.4665462E-01,.5094960E-01,& + & .5701871E-01,.6284240E-01,.6603147E-01,.6716332E-01,.6612920E-01,& + & .6275302E-01,.5663929E-01,.4676883E-01,.5188210E-01,.5764984E-01,& + & .6336343E-01,.6646529E-01,.6749570E-01,.6632743E-01,.6282719E-01,& + & .5662832E-01,.4689733E-01,.5269455E-01,.5818682E-01,.6376950E-01,& + & .6678498E-01,.6774711E-01,.6647465E-01,.6289082E-01,.5661653E-01,& + & .4705226E-01,.5340814E-01,.5863202E-01,.6410648E-01,.6704487E-01,& + & .6795408E-01,.6661171E-01,.6295124E-01,.5663255E-01,.4724050E-01/ + + data absa(451:585, 5) / & + & .4634040E-01,.5350954E-01,.5924519E-01,.6235764E-01,.6342928E-01,& + & .6250075E-01,.5915701E-01,.5294180E-01,.3981576E-01,.4736892E-01,& + & .5426407E-01,.5988551E-01,.6297853E-01,.6392000E-01,.6284030E-01,& + & .5933938E-01,.5297399E-01,.3998733E-01,.4826061E-01,.5489369E-01,& + & .6040498E-01,.6345651E-01,.6430714E-01,.6308766E-01,.5949295E-01,& + & .5300748E-01,.4016986E-01,.4903376E-01,.5542677E-01,.6085024E-01,& + & .6383044E-01,.6465029E-01,.6331517E-01,.5962492E-01,.5307512E-01,& + & .4039950E-01,.4974119E-01,.5589358E-01,.6123797E-01,.6415006E-01,& + & .6494753E-01,.6353101E-01,.5976611E-01,.5317271E-01,.4065617E-01,& + & .4271897E-01,.5052183E-01,.5599851E-01,.5891678E-01,.5984422E-01,& + & .5881804E-01,.5542417E-01,.4913608E-01,.3713988E-01,.4368596E-01,& + & .5124809E-01,.5664483E-01,.5957881E-01,.6039071E-01,.5919218E-01,& + & .5567250E-01,.4923797E-01,.3723585E-01,.4453270E-01,.5188770E-01,& + & .5720401E-01,.6010232E-01,.6087078E-01,.5953237E-01,.5588506E-01,& + & .4936407E-01,.3745797E-01,.4529021E-01,.5243444E-01,.5768876E-01,& + & .6053783E-01,.6126963E-01,.5984905E-01,.5610497E-01,.4950780E-01,& + & .3755909E-01,.4600687E-01,.5293281E-01,.5813232E-01,.6093595E-01,& + & .6163456E-01,.6016722E-01,.5635091E-01,.4968371E-01,.3773583E-01,& + & .3908364E-01,.4730786E-01,.5250316E-01,.5524959E-01,.5601420E-01,& + & .5485012E-01,.5154058E-01,.4532019E-01,.3566372E-01,.3998663E-01,& + & .4803344E-01,.5319099E-01,.5592987E-01,.5663652E-01,.5530572E-01,& + & .5183777E-01,.4553398E-01,.3583037E-01,.4078498E-01,.4865307E-01,& + & .5379331E-01,.5649229E-01,.5715869E-01,.5574035E-01,.5214488E-01,& + & .4574777E-01,.3594123E-01,.4154329E-01,.4922239E-01,.5434666E-01,& + & .5701428E-01,.5763600E-01,.5616885E-01,.5247198E-01,.4597428E-01,& + & .3604552E-01,.4229775E-01,.4978726E-01,.5486411E-01,.5751694E-01,& + & .5809005E-01,.5659205E-01,.5281871E-01,.4623884E-01,.3624776E-01/ + + data absa( 1:180, 6) / & + & .4846620E+00,.4254449E+00,.3666979E+00,.3085003E+00,.2601346E+00,& + & .2464956E+00,.2660087E+00,.3021063E+00,.3287759E+00,.4745246E+00,& + & .4166752E+00,.3592695E+00,.3025580E+00,.2553943E+00,.2432268E+00,& + & .2629249E+00,.2987363E+00,.3245474E+00,.4658709E+00,.4092568E+00,& + & .3530642E+00,.2977163E+00,.2515626E+00,.2405793E+00,.2602783E+00,& + & .2957536E+00,.3209745E+00,.4575145E+00,.4020922E+00,.3470681E+00,& + & .2930793E+00,.2481591E+00,.2381801E+00,.2579191E+00,.2931017E+00,& + & .3178371E+00,.4497966E+00,.3954548E+00,.3415131E+00,.2891031E+00,& + & .2456319E+00,.2359968E+00,.2560087E+00,.2910169E+00,.3153507E+00,& + & .5233277E+00,.4592284E+00,.3955317E+00,.3326601E+00,.2881387E+00,& + & .2814594E+00,.3054605E+00,.3475919E+00,.3858173E+00,.5126637E+00,& + & .4500477E+00,.3878258E+00,.3267077E+00,.2828332E+00,.2774387E+00,& + & .3014139E+00,.3430855E+00,.3803776E+00,.5032811E+00,.4419694E+00,& + & .3810629E+00,.3215530E+00,.2784520E+00,.2739908E+00,.2977829E+00,& + & .3391699E+00,.3757057E+00,.4943912E+00,.4343294E+00,.3746578E+00,& + & .3166441E+00,.2747404E+00,.2708931E+00,.2946970E+00,.3358529E+00,& + & .3717479E+00,.4856925E+00,.4268266E+00,.3684341E+00,.3122038E+00,& + & .2717769E+00,.2679905E+00,.2921861E+00,.3332832E+00,.3686250E+00,& + & .5659721E+00,.4964838E+00,.4273442E+00,.3613333E+00,.3229778E+00,& + & .3207717E+00,.3487909E+00,.3970188E+00,.4483696E+00,.5545946E+00,& + & .4866491E+00,.4190737E+00,.3544937E+00,.3171184E+00,.3157821E+00,& + & .3434204E+00,.3913987E+00,.4416557E+00,.5441901E+00,.4776455E+00,& + & .4115043E+00,.3481950E+00,.3119787E+00,.3113749E+00,.3389006E+00,& + & .3865528E+00,.4358447E+00,.5345476E+00,.4693294E+00,.4045767E+00,& + & .3427926E+00,.3075766E+00,.3073312E+00,.3350898E+00,.3825859E+00,& + & .4311541E+00,.5246854E+00,.4609334E+00,.3978727E+00,.3380061E+00,& + & .3038003E+00,.3036818E+00,.3320521E+00,.3795333E+00,.4274614E+00,& + & .6114156E+00,.5360856E+00,.4610841E+00,.3944939E+00,.3631225E+00,& + & .3640797E+00,.3957193E+00,.4512458E+00,.5140119E+00,.5990211E+00,& + & .5253614E+00,.4520735E+00,.3868300E+00,.3563118E+00,.3576976E+00,& + & .3893012E+00,.4443146E+00,.5057705E+00,.5878031E+00,.5156587E+00,& + & .4439389E+00,.3797822E+00,.3504051E+00,.3520245E+00,.3838216E+00,& + & .4383993E+00,.4987384E+00,.5771932E+00,.5065469E+00,.4365968E+00,& + & .3737334E+00,.3451671E+00,.3469143E+00,.3791776E+00,.4335158E+00,& + & .4929659E+00,.5672493E+00,.4980854E+00,.4298759E+00,.3686864E+00,& + & .3406738E+00,.3425037E+00,.3753823E+00,.4296076E+00,.4882770E+00/ + + data absa(181:315, 6) / & + & .6599457E+00,.5784248E+00,.4971773E+00,.4337450E+00,.4071444E+00,& + & .4110564E+00,.4472427E+00,.5099709E+00,.5830348E+00,.6468482E+00,& + & .5670871E+00,.4876631E+00,.4250777E+00,.3993382E+00,.4031458E+00,& + & .4395792E+00,.5018776E+00,.5735256E+00,.6348396E+00,.5566698E+00,& + & .4790978E+00,.4172804E+00,.3925206E+00,.3961110E+00,.4330389E+00,& + & .4948939E+00,.5653109E+00,.6234166E+00,.5469278E+00,.4713504E+00,& + & .4102887E+00,.3864066E+00,.3900014E+00,.4273461E+00,.4889966E+00,& + & .5583254E+00,.6128604E+00,.5379244E+00,.4642610E+00,.4042901E+00,& + & .3809946E+00,.3847891E+00,.4225472E+00,.4840732E+00,.5525507E+00,& + & .7118405E+00,.6237026E+00,.5373473E+00,.4788483E+00,.4552052E+00,& + & .4622830E+00,.5030364E+00,.5735317E+00,.6569249E+00,.6980451E+00,& + & .6117423E+00,.5269042E+00,.4690257E+00,.4461057E+00,.4528737E+00,& + & .4940744E+00,.5641178E+00,.6458719E+00,.6851401E+00,.6005735E+00,& + & .5173938E+00,.4602048E+00,.4380661E+00,.4445391E+00,.4863645E+00,& + & .5558444E+00,.6361244E+00,.6731826E+00,.5903092E+00,.5088902E+00,& + & .4521990E+00,.4308774E+00,.4373808E+00,.4795420E+00,.5488504E+00,& + & .6279339E+00,.6618869E+00,.5806518E+00,.5011956E+00,.4451372E+00,& + & .4243261E+00,.4313958E+00,.4738124E+00,.5429837E+00,.6210544E+00,& + & .7668972E+00,.6717524E+00,.5822052E+00,.5289402E+00,.5074279E+00,& + & .5174762E+00,.5633483E+00,.6412958E+00,.7351146E+00,.7523724E+00,& + & .6591380E+00,.5705110E+00,.5178052E+00,.4967826E+00,.5066462E+00,& + & .5528830E+00,.6302350E+00,.7222090E+00,.7385919E+00,.6472212E+00,& + & .5598496E+00,.5075245E+00,.4872782E+00,.4974170E+00,.5435990E+00,& + & .6206660E+00,.7110675E+00,.7257857E+00,.6361589E+00,.5503268E+00,& + & .4984685E+00,.4786719E+00,.4893603E+00,.5354629E+00,.6125751E+00,& + & .7016399E+00,.7138973E+00,.6259486E+00,.5417002E+00,.4905437E+00,& + & .4710327E+00,.4822383E+00,.5286586E+00,.6057803E+00,.6935878E+00/ + + data absa(316:450, 6) / & + & .8249134E+00,.7223579E+00,.6318367E+00,.5828461E+00,.5642052E+00,& + & .5774889E+00,.6274321E+00,.7112179E+00,.8154752E+00,.8094743E+00,& + & .7089425E+00,.6188253E+00,.5703294E+00,.5519242E+00,.5651410E+00,& + & .6152177E+00,.6988740E+00,.8012054E+00,.7948100E+00,.6962635E+00,& + & .6071335E+00,.5587642E+00,.5408447E+00,.5546817E+00,.6044782E+00,& + & .6883629E+00,.7888678E+00,.7814861E+00,.6847483E+00,.5966332E+00,& + & .5488036E+00,.5307506E+00,.5452968E+00,.5952041E+00,.6791251E+00,& + & .7781169E+00,.7689261E+00,.6739251E+00,.5871415E+00,.5399440E+00,& + & .5219107E+00,.5368668E+00,.5871449E+00,.6714540E+00,.7691532E+00,& + & .8852145E+00,.7750456E+00,.6871055E+00,.6408984E+00,.6254709E+00,& + & .6421647E+00,.6941504E+00,.7835789E+00,.8985979E+00,.8691028E+00,& + & .7609767E+00,.6728330E+00,.6267061E+00,.6112664E+00,.6281600E+00,& + & .6803225E+00,.7701312E+00,.8830032E+00,.8539650E+00,.7478668E+00,& + & .6598673E+00,.6140672E+00,.5985796E+00,.6161528E+00,.6684674E+00,& + & .7583442E+00,.8692469E+00,.8400620E+00,.7358241E+00,.6484499E+00,& + & .6030312E+00,.5871483E+00,.6051785E+00,.6578534E+00,.7481252E+00,& + & .8573340E+00,.8267308E+00,.7243453E+00,.6382877E+00,.5930271E+00,& + & .5773599E+00,.5955257E+00,.6486068E+00,.7393848E+00,.8471526E+00,& + & .9457456E+00,.8285939E+00,.7451511E+00,.7019917E+00,.6899693E+00,& + & .7089637E+00,.7625561E+00,.8572460E+00,.9824613E+00,.9291323E+00,& + & .8136971E+00,.7298541E+00,.6864425E+00,.6740084E+00,.6934007E+00,& + & .7472875E+00,.8425945E+00,.9655705E+00,.9139136E+00,.8002614E+00,& + & .7162229E+00,.6723573E+00,.6598915E+00,.6797955E+00,.7340436E+00,& + & .8294611E+00,.9506098E+00,.8996396E+00,.7878323E+00,.7040173E+00,& + & .6600638E+00,.6474290E+00,.6677087E+00,.7222527E+00,.8180613E+00,& + & .9373243E+00,.8863343E+00,.7763696E+00,.6928464E+00,.6489803E+00,& + & .6362699E+00,.6568098E+00,.7118980E+00,.8079921E+00,.9257131E+00/ + + data absa(451:585, 6) / & + & .9984509E+00,.8767023E+00,.7981236E+00,.7590051E+00,.7500479E+00,& + & .7704148E+00,.8258274E+00,.9236821E+00,.1057116E+01,.9825580E+00,& + & .8620354E+00,.7830513E+00,.7424078E+00,.7334532E+00,.7542144E+00,& + & .8101460E+00,.9086138E+00,.1040043E+01,.9678310E+00,.8486729E+00,& + & .7694638E+00,.7279026E+00,.7187504E+00,.7400787E+00,.7961034E+00,& + & .8951540E+00,.1024689E+01,.9541401E+00,.8363966E+00,.7569500E+00,& + & .7151152E+00,.7053524E+00,.7272043E+00,.7836771E+00,.8829254E+00,& + & .1010610E+01,.9409238E+00,.8247336E+00,.7452605E+00,.7034806E+00,& + & .6932724E+00,.7155504E+00,.7725713E+00,.8720814E+00,.9982035E+00,& + & .1051209E+01,.9265442E+00,.8532619E+00,.8179703E+00,.8119095E+00,& + & .8341371E+00,.8903756E+00,.9888756E+00,.1095956E+01,.1036235E+01,& + & .9123511E+00,.8382101E+00,.8010032E+00,.7947542E+00,.8176096E+00,& + & .8740008E+00,.9731309E+00,.1080421E+01,.1022216E+01,.8989889E+00,& + & .8242808E+00,.7860446E+00,.7790076E+00,.8024437E+00,.8593689E+00,& + & .9586866E+00,.1065303E+01,.1008831E+01,.8865583E+00,.8113619E+00,& + & .7726307E+00,.7650415E+00,.7885957E+00,.8460657E+00,.9457463E+00,& + & .1053284E+01,.9956237E+00,.8746029E+00,.7991663E+00,.7602091E+00,& + & .7523241E+00,.7758775E+00,.8338469E+00,.9341164E+00,.1042323E+01,& + & .1103094E+01,.9779325E+00,.9101471E+00,.8783812E+00,.8752086E+00,& + & .8997168E+00,.9549270E+00,.1052106E+01,.1130777E+01,.1089042E+01,& + & .9638679E+00,.8946771E+00,.8612419E+00,.8571856E+00,.8822649E+00,& + & .9380724E+00,.1035137E+01,.1114750E+01,.1075742E+01,.9508309E+00,& + & .8802630E+00,.8459304E+00,.8411000E+00,.8660581E+00,.9224269E+00,& + & .1019820E+01,.1101053E+01,.1062410E+01,.9382231E+00,.8666081E+00,& + & .8315446E+00,.8263075E+00,.8509882E+00,.9079071E+00,.1005967E+01,& + & .1089316E+01,.1048876E+01,.9255641E+00,.8536249E+00,.8179717E+00,& + & .8126191E+00,.8371360E+00,.8945910E+00,.9933411E+00,.1078307E+01/ + +! the array absb(235,6) (kb(5,13:59,6)) contains absorption coefs at +! the 16 chosen g-values for a range of pressure levels < ~100mb and +! temperatures. the first index in the array, jt, which runs from 1 to 5, +! corresponds to different temperatures. more specifically, jt = 3 means +! that the data are for the reference temperature tref for this pressure +! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +! the second index, jp, runs from 13 to 59 and refers to the jpth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). the third index, ig, goes from 1 to 6, +! and tells us which g-interval the absorption coefficients are for. +! ----------------------------------------------------------------- + + data absb( 1:120, 1) / & + & .2455108E-02,.2494284E-02,.2520068E-02,.2540222E-02,.2547453E-02,& + & .2053818E-02,.2083023E-02,.2101215E-02,.2116145E-02,.2123172E-02,& + & .1734639E-02,.1758680E-02,.1772416E-02,.1781767E-02,.1788224E-02,& + & .1482314E-02,.1503678E-02,.1512899E-02,.1519630E-02,.1524757E-02,& + & .1284745E-02,.1304855E-02,.1312793E-02,.1316311E-02,.1318005E-02,& + & .1129086E-02,.1146597E-02,.1156453E-02,.1156435E-02,.1156401E-02,& + & .9921713E-03,.1008990E-02,.1018291E-02,.1020213E-02,.1018365E-02,& + & .8471850E-03,.8618578E-03,.8693996E-03,.8719597E-03,.8699465E-03,& + & .7178765E-03,.7312448E-03,.7368809E-03,.7383122E-03,.7377363E-03,& + & .6069271E-03,.6192294E-03,.6230026E-03,.6249060E-03,.6240653E-03,& + & .5123512E-03,.5240166E-03,.5274574E-03,.5289784E-03,.5283974E-03,& + & .4327672E-03,.4433865E-03,.4469695E-03,.4481477E-03,.4479432E-03,& + & .3651769E-03,.3741862E-03,.3784929E-03,.3797155E-03,.3799202E-03,& + & .3081802E-03,.3145936E-03,.3193752E-03,.3209357E-03,.3216224E-03,& + & .2600564E-03,.2641825E-03,.2692918E-03,.2713207E-03,.2719491E-03,& + & .2189889E-03,.2226081E-03,.2271490E-03,.2294557E-03,.2302383E-03,& + & .1846009E-03,.1885356E-03,.1916569E-03,.1944705E-03,.1953784E-03,& + & .1569872E-03,.1601747E-03,.1622966E-03,.1649634E-03,.1666332E-03,& + & .1341940E-03,.1363878E-03,.1381676E-03,.1401546E-03,.1421984E-03,& + & .1150202E-03,.1162012E-03,.1182134E-03,.1193516E-03,.1212431E-03,& + & .9900466E-04,.9989409E-04,.1008343E-03,.1022803E-03,.1033529E-03,& + & .8523323E-04,.8592559E-04,.8646982E-04,.8752563E-04,.8834547E-04,& + & .7355247E-04,.7410040E-04,.7455079E-04,.7505627E-04,.7561834E-04,& + & .6386391E-04,.6399156E-04,.6452062E-04,.6507966E-04,.6511678E-04/ + + data absb(121:235, 1) / & + & .5378377E-04,.5383807E-04,.5419748E-04,.5461584E-04,.5475942E-04,& + & .4529476E-04,.4536607E-04,.4551849E-04,.4582121E-04,.4594236E-04,& + & .3805002E-04,.3835500E-04,.3837164E-04,.3841587E-04,.3870224E-04,& + & .3134721E-04,.3153158E-04,.3158800E-04,.3159241E-04,.3173210E-04,& + & .2572678E-04,.2581660E-04,.2592636E-04,.2593449E-04,.2604293E-04,& + & .2111340E-04,.2114297E-04,.2123906E-04,.2126974E-04,.2132702E-04,& + & .1724042E-04,.1721678E-04,.1726492E-04,.1735856E-04,.1734777E-04,& + & .1400853E-04,.1398539E-04,.1400256E-04,.1407486E-04,.1407744E-04,& + & .1138599E-04,.1138052E-04,.1136754E-04,.1138325E-04,.1144462E-04,& + & .9234875E-05,.9228129E-05,.9225511E-05,.9219129E-05,.9274721E-05,& + & .7450018E-05,.7494669E-05,.7491514E-05,.7465424E-05,.7498018E-05,& + & .5987641E-05,.6060252E-05,.6077441E-05,.6062453E-05,.6062401E-05,& + & .4810640E-05,.4877970E-05,.4932441E-05,.4916522E-05,.4908248E-05,& + & .3869095E-05,.3916912E-05,.3981052E-05,.3989636E-05,.3985085E-05,& + & .3125584E-05,.3158316E-05,.3201951E-05,.3234304E-05,.3229423E-05,& + & .2526771E-05,.2539982E-05,.2565764E-05,.2606671E-05,.2620099E-05,& + & .2033741E-05,.2048230E-05,.2064945E-05,.2094217E-05,.2117279E-05,& + & .1636949E-05,.1651544E-05,.1664769E-05,.1682082E-05,.1707938E-05,& + & .1320644E-05,.1329014E-05,.1342957E-05,.1355072E-05,.1374367E-05,& + & .1063144E-05,.1069247E-05,.1082985E-05,.1092178E-05,.1104704E-05,& + & .8523022E-06,.8613254E-06,.8703544E-06,.8805758E-06,.8889748E-06,& + & .6821306E-06,.6939226E-06,.7000980E-06,.7103676E-06,.7161581E-06,& + & .5473000E-06,.5610035E-06,.5662359E-06,.5739016E-06,.5795604E-06/ + + data absb( 1:120, 2) / & + & .1286743E-01,.1298016E-01,.1307688E-01,.1314196E-01,.1318687E-01,& + & .1084483E-01,.1095286E-01,.1104372E-01,.1107916E-01,.1110333E-01,& + & .9173853E-02,.9249031E-02,.9308829E-02,.9349446E-02,.9373813E-02,& + & .7773824E-02,.7815445E-02,.7855507E-02,.7887027E-02,.7894494E-02,& + & .6635671E-02,.6658973E-02,.6677297E-02,.6693544E-02,.6694290E-02,& + & .5714053E-02,.5714835E-02,.5716276E-02,.5728622E-02,.5719424E-02,& + & .4953027E-02,.4935260E-02,.4928449E-02,.4921707E-02,.4912914E-02,& + & .4202051E-02,.4179936E-02,.4170445E-02,.4154196E-02,.4145879E-02,& + & .3546756E-02,.3522656E-02,.3509107E-02,.3496226E-02,.3483466E-02,& + & .2986324E-02,.2962134E-02,.2946586E-02,.2935316E-02,.2924589E-02,& + & .2520037E-02,.2493976E-02,.2477958E-02,.2467618E-02,.2459527E-02,& + & .2128530E-02,.2102617E-02,.2086920E-02,.2077359E-02,.2068955E-02,& + & .1796044E-02,.1774099E-02,.1757802E-02,.1748933E-02,.1740649E-02,& + & .1511042E-02,.1493208E-02,.1478896E-02,.1469321E-02,.1461744E-02,& + & .1272579E-02,.1259504E-02,.1246012E-02,.1235685E-02,.1229631E-02,& + & .1074471E-02,.1063160E-02,.1050792E-02,.1041724E-02,.1036092E-02,& + & .9106300E-03,.8993222E-03,.8888252E-03,.8805708E-03,.8768352E-03,& + & .7732921E-03,.7632043E-03,.7552638E-03,.7485823E-03,.7491950E-03,& + & .6597355E-03,.6512362E-03,.6451463E-03,.6404871E-03,.6392845E-03,& + & .5654918E-03,.5596233E-03,.5545424E-03,.5500160E-03,.5486305E-03,& + & .4880680E-03,.4838686E-03,.4792352E-03,.4746633E-03,.4742358E-03,& + & .4240329E-03,.4198366E-03,.4158480E-03,.4147475E-03,.4118226E-03,& + & .3707047E-03,.3670166E-03,.3635404E-03,.3627127E-03,.3598610E-03,& + & .3269270E-03,.3238737E-03,.3206578E-03,.3192890E-03,.3166364E-03/ + + data absb(121:235, 2) / & + & .2789970E-03,.2765079E-03,.2739652E-03,.2724815E-03,.2694007E-03,& + & .2383170E-03,.2362195E-03,.2338966E-03,.2321906E-03,.2293814E-03,& + & .2043421E-03,.2022653E-03,.1998851E-03,.1974199E-03,.1958820E-03,& + & .1703638E-03,.1685921E-03,.1664446E-03,.1644332E-03,.1632693E-03,& + & .1414648E-03,.1398222E-03,.1381078E-03,.1364105E-03,.1354620E-03,& + & .1171714E-03,.1160394E-03,.1146163E-03,.1132446E-03,.1124903E-03,& + & .9653894E-04,.9566019E-04,.9459747E-04,.9340503E-04,.9220628E-04,& + & .7932991E-04,.7856317E-04,.7774927E-04,.7682321E-04,.7581347E-04,& + & .6515421E-04,.6441758E-04,.6392018E-04,.6313941E-04,.6221003E-04,& + & .5347743E-04,.5297072E-04,.5245890E-04,.5184866E-04,.5107466E-04,& + & .4396154E-04,.4347687E-04,.4303733E-04,.4259063E-04,.4196826E-04,& + & .3615915E-04,.3568995E-04,.3529007E-04,.3492298E-04,.3444102E-04,& + & .2966497E-04,.2925157E-04,.2889217E-04,.2855828E-04,.2821985E-04,& + & .2430508E-04,.2403992E-04,.2370451E-04,.2340581E-04,.2311943E-04,& + & .1995845E-04,.1971625E-04,.1943619E-04,.1919411E-04,.1893202E-04,& + & .1630421E-04,.1613833E-04,.1595861E-04,.1573142E-04,.1549637E-04,& + & .1329543E-04,.1321689E-04,.1306432E-04,.1287719E-04,.1268925E-04,& + & .1082302E-04,.1082655E-04,.1071501E-04,.1058492E-04,.1042620E-04,& + & .8829908E-05,.8878449E-05,.8804000E-05,.8713675E-05,.8582871E-05,& + & .7229747E-05,.7274906E-05,.7243006E-05,.7161434E-05,.7060580E-05,& + & .5920720E-05,.5930473E-05,.5943800E-05,.5878317E-05,.5803165E-05,& + & .4850374E-05,.4842730E-05,.4872181E-05,.4827114E-05,.4773736E-05,& + & .3998381E-05,.3995704E-05,.4020867E-05,.3990354E-05,.3948657E-05/ + + data absb( 1:120, 3) / & + & .5002398E-01,.5100799E-01,.5223444E-01,.5366230E-01,.5534006E-01,& + & .4416861E-01,.4512229E-01,.4624963E-01,.4763751E-01,.4926106E-01,& + & .3889418E-01,.3989178E-01,.4102991E-01,.4233451E-01,.4377504E-01,& + & .3413273E-01,.3507125E-01,.3618746E-01,.3742424E-01,.3870722E-01,& + & .2995928E-01,.3086478E-01,.3189959E-01,.3307320E-01,.3425277E-01,& + & .2638019E-01,.2725271E-01,.2821585E-01,.2927539E-01,.3033342E-01,& + & .2335920E-01,.2414637E-01,.2503317E-01,.2599890E-01,.2699514E-01,& + & .2029208E-01,.2105095E-01,.2183638E-01,.2270657E-01,.2359078E-01,& + & .1752887E-01,.1822677E-01,.1893693E-01,.1971216E-01,.2049024E-01,& + & .1514301E-01,.1576265E-01,.1644949E-01,.1710856E-01,.1777047E-01,& + & .1307907E-01,.1369568E-01,.1429327E-01,.1484508E-01,.1540994E-01,& + & .1135002E-01,.1190407E-01,.1240533E-01,.1289830E-01,.1336006E-01,& + & .9861342E-02,.1032874E-01,.1078971E-01,.1119067E-01,.1159988E-01,& + & .8543786E-02,.8972343E-02,.9361670E-02,.9707599E-02,.1007270E-01,& + & .7399186E-02,.7765826E-02,.8086950E-02,.8410397E-02,.8722569E-02,& + & .6411375E-02,.6715139E-02,.6991916E-02,.7280002E-02,.7586032E-02,& + & .5526867E-02,.5785983E-02,.6041283E-02,.6303233E-02,.6579648E-02,& + & .4774311E-02,.4997352E-02,.5227375E-02,.5480339E-02,.5877541E-02,& + & .4116828E-02,.4325497E-02,.4545463E-02,.4770394E-02,.5153971E-02,& + & .3578769E-02,.3764998E-02,.3969666E-02,.4197341E-02,.4545465E-02,& + & .3124717E-02,.3305659E-02,.3500480E-02,.3709794E-02,.4038550E-02,& + & .2748728E-02,.2923454E-02,.3112152E-02,.3399419E-02,.3626701E-02,& + & .2422516E-02,.2586643E-02,.2766372E-02,.3049770E-02,.3276646E-02,& + & .2131791E-02,.2289101E-02,.2457066E-02,.2736600E-02,.2953943E-02/ + + data absb(121:235, 3) / & + & .1828665E-02,.1969373E-02,.2131950E-02,.2386197E-02,.2591184E-02,& + & .1565325E-02,.1696357E-02,.1846360E-02,.2083995E-02,.2278216E-02,& + & .1339532E-02,.1462299E-02,.1603891E-02,.1761979E-02,.2010098E-02,& + & .1123112E-02,.1231996E-02,.1361344E-02,.1506360E-02,.1731174E-02,& + & .9386379E-03,.1036085E-02,.1150679E-02,.1280160E-02,.1487488E-02,& + & .7829286E-03,.8681007E-03,.9712611E-03,.1088601E-02,.1279327E-02,& + & .6439906E-03,.7179533E-03,.8068447E-03,.9121069E-03,.1038346E-02,& + & .5251100E-03,.5895043E-03,.6665253E-03,.7582909E-03,.8728263E-03,& + & .4272101E-03,.4822133E-03,.5483728E-03,.6283465E-03,.7297410E-03,& + & .3455385E-03,.3919227E-03,.4490025E-03,.5186610E-03,.6080615E-03,& + & .2772875E-03,.3163585E-03,.3648993E-03,.4245665E-03,.5029312E-03,& + & .2215243E-03,.2545308E-03,.2950909E-03,.3456400E-03,.4140863E-03,& + & .1762697E-03,.2034714E-03,.2368499E-03,.2802197E-03,.3391266E-03,& + & .1409510E-03,.1632263E-03,.1911441E-03,.2283913E-03,.2789978E-03,& + & .1124638E-03,.1310401E-03,.1540205E-03,.1857656E-03,.2289863E-03,& + & .8954236E-04,.1047453E-03,.1237097E-03,.1505540E-03,.1870030E-03,& + & .7098317E-04,.8306387E-04,.9912454E-04,.1212505E-03,.1519558E-03,& + & .5681762E-04,.6665919E-04,.7982178E-04,.9805318E-04,.1239971E-03,& + & .4562520E-04,.5359104E-04,.6438194E-04,.7935790E-04,.1011203E-03,& + & .3653132E-04,.4295380E-04,.5170112E-04,.6400146E-04,.8208662E-04,& + & .2913090E-04,.3439039E-04,.4140146E-04,.5133409E-04,.6632514E-04,& + & .2332055E-04,.2755437E-04,.3319705E-04,.4115994E-04,.5350282E-04,& + & .1945717E-04,.2306888E-04,.2793905E-04,.3476686E-04,.4551954E-04/ + + data absb( 1:120, 4) / & + & .2878234E+00,.2961252E+00,.3050441E+00,.3147630E+00,.3253959E+00,& + & .2743822E+00,.2825368E+00,.2911238E+00,.3003062E+00,.3104320E+00,& + & .2632621E+00,.2715744E+00,.2807089E+00,.2905758E+00,.3014280E+00,& + & .2470711E+00,.2556028E+00,.2648564E+00,.2753382E+00,.2872254E+00,& + & .2312754E+00,.2397378E+00,.2488918E+00,.2593077E+00,.2714135E+00,& + & .2159198E+00,.2248574E+00,.2346644E+00,.2452257E+00,.2571951E+00,& + & .2025752E+00,.2115209E+00,.2212761E+00,.2319679E+00,.2443755E+00,& + & .1870918E+00,.1958476E+00,.2056213E+00,.2168964E+00,.2297077E+00,& + & .1719062E+00,.1808017E+00,.1908654E+00,.2024728E+00,.2155574E+00,& + & .1580850E+00,.1674409E+00,.1780281E+00,.1900585E+00,.2031710E+00,& + & .1462403E+00,.1558822E+00,.1666091E+00,.1789235E+00,.1922377E+00,& + & .1362161E+00,.1459406E+00,.1567969E+00,.1692597E+00,.1829005E+00,& + & .1274087E+00,.1370931E+00,.1484132E+00,.1609035E+00,.1746367E+00,& + & .1194990E+00,.1297509E+00,.1410742E+00,.1539492E+00,.1679681E+00,& + & .1123619E+00,.1230023E+00,.1347556E+00,.1477261E+00,.1617005E+00,& + & .1061193E+00,.1170526E+00,.1291360E+00,.1421656E+00,.1564595E+00,& + & .1006760E+00,.1119479E+00,.1241710E+00,.1376384E+00,.1522244E+00,& + & .9607904E-01,.1075948E+00,.1202361E+00,.1342448E+00,.1520624E+00,& + & .9236167E-01,.1042029E+00,.1173986E+00,.1321571E+00,.1502113E+00,& + & .8989190E-01,.1021932E+00,.1159955E+00,.1310628E+00,.1496169E+00,& + & .8834869E-01,.1013779E+00,.1156618E+00,.1310736E+00,.1499564E+00,& + & .8767587E-01,.1011140E+00,.1157497E+00,.1341003E+00,.1509449E+00,& + & .8642676E-01,.1002241E+00,.1151696E+00,.1339998E+00,.1509668E+00,& + & .8444357E-01,.9839768E-01,.1137899E+00,.1328639E+00,.1500538E+00/ + + data absb(121:235, 4) / & + & .8008552E-01,.9397404E-01,.1092312E+00,.1284086E+00,.1456923E+00,& + & .7606488E-01,.8974941E-01,.1049552E+00,.1241503E+00,.1414966E+00,& + & .7241439E-01,.8585292E-01,.1009126E+00,.1172255E+00,.1376072E+00,& + & .6737037E-01,.8040867E-01,.9512233E-01,.1111766E+00,.1313617E+00,& + & .6249839E-01,.7518420E-01,.8941538E-01,.1051429E+00,.1250058E+00,& + & .5796755E-01,.7023093E-01,.8399825E-01,.9941523E-01,.1191081E+00,& + & .5290880E-01,.6463286E-01,.7799108E-01,.9283777E-01,.1092238E+00,& + & .4784261E-01,.5904001E-01,.7178305E-01,.8613347E-01,.1019882E+00,& + & .4314406E-01,.5383664E-01,.6605552E-01,.7975409E-01,.9510036E-01,& + & .3853322E-01,.4870478E-01,.6029343E-01,.7337748E-01,.8815869E-01,& + & .3389054E-01,.4343173E-01,.5438033E-01,.6682346E-01,.8091510E-01,& + & .2963117E-01,.3852479E-01,.4883852E-01,.6062832E-01,.7400013E-01,& + & .2572970E-01,.3391246E-01,.4359826E-01,.5471276E-01,.6736039E-01,& + & .2233416E-01,.2991585E-01,.3901273E-01,.4954145E-01,.6156569E-01,& + & .1939210E-01,.2638719E-01,.3485100E-01,.4478336E-01,.5620570E-01,& + & .1668291E-01,.2307789E-01,.3098475E-01,.4031918E-01,.5116350E-01,& + & .1420262E-01,.2005395E-01,.2735039E-01,.3608786E-01,.4625548E-01,& + & .1217748E-01,.1754282E-01,.2430328E-01,.3256355E-01,.4217429E-01,& + & .1044921E-01,.1536327E-01,.2163899E-01,.2944083E-01,.3855156E-01,& + & .8884509E-02,.1335574E-01,.1918440E-01,.2646426E-01,.3516363E-01,& + & .7483675E-02,.1152870E-01,.1691180E-01,.2368487E-01,.3190062E-01,& + & .6305579E-02,.9961440E-02,.1489973E-01,.2122728E-01,.2897708E-01,& + & .5828592E-02,.9332797E-02,.1413857E-01,.2030539E-01,.2791717E-01/ + + data absb( 1:120, 5) / & + & .9803355E+01,.1002921E+02,.1022928E+02,.1041986E+02,.1060893E+02,& + & .8901187E+01,.9109354E+01,.9307795E+01,.9507481E+01,.9704484E+01,& + & .8037550E+01,.8238379E+01,.8440990E+01,.8639971E+01,.8841430E+01,& + & .7256235E+01,.7456728E+01,.7656282E+01,.7858569E+01,.8063361E+01,& + & .6549121E+01,.6747154E+01,.6948541E+01,.7154546E+01,.7363018E+01,& + & .5920127E+01,.6112982E+01,.6313644E+01,.6520192E+01,.6735708E+01,& + & .5391811E+01,.5564840E+01,.5751524E+01,.5963164E+01,.6187711E+01,& + & .4979063E+01,.5141211E+01,.5319204E+01,.5518536E+01,.5724852E+01,& + & .4685729E+01,.4829264E+01,.4999371E+01,.5176536E+01,.5377588E+01,& + & .4509733E+01,.4627971E+01,.4769025E+01,.4939138E+01,.5138382E+01,& + & .4441848E+01,.4547145E+01,.4654076E+01,.4777266E+01,.4966192E+01,& + & .4392672E+01,.4508636E+01,.4631472E+01,.4750610E+01,.4893241E+01,& + & .4379451E+01,.4509691E+01,.4639368E+01,.4771997E+01,.4917485E+01,& + & .4383266E+01,.4532070E+01,.4679856E+01,.4811910E+01,.4982307E+01,& + & .4373711E+01,.4538212E+01,.4701877E+01,.4859289E+01,.5032829E+01,& + & .4371956E+01,.4552831E+01,.4722242E+01,.4907609E+01,.5087424E+01,& + & .4332160E+01,.4518631E+01,.4697783E+01,.4891344E+01,.5092684E+01,& + & .4305857E+01,.4488111E+01,.4683919E+01,.4875401E+01,.5098906E+01,& + & .4247319E+01,.4442550E+01,.4629624E+01,.4824728E+01,.5055952E+01,& + & .4214744E+01,.4395695E+01,.4595960E+01,.4805492E+01,.5017792E+01,& + & .4194067E+01,.4374577E+01,.4586487E+01,.4793725E+01,.5028709E+01,& + & .4199133E+01,.4388763E+01,.4601898E+01,.4846199E+01,.5088486E+01,& + & .4205331E+01,.4415572E+01,.4636671E+01,.4889061E+01,.5185128E+01,& + & .4239611E+01,.4448023E+01,.4670143E+01,.4942226E+01,.5271353E+01/ + + data absb(121:235, 5) / & + & .4176844E+01,.4378265E+01,.4607587E+01,.4898813E+01,.5254033E+01,& + & .4099489E+01,.4293386E+01,.4533269E+01,.4877379E+01,.5230256E+01,& + & .4007521E+01,.4213195E+01,.4480775E+01,.4835666E+01,.5209135E+01,& + & .3883977E+01,.4090925E+01,.4376746E+01,.4733176E+01,.5114008E+01,& + & .3759955E+01,.3970704E+01,.4272560E+01,.4618469E+01,.4997992E+01,& + & .3631179E+01,.3846064E+01,.4161525E+01,.4505341E+01,.4888289E+01,& + & .3481107E+01,.3699160E+01,.4022359E+01,.4359341E+01,.4726661E+01,& + & .3305633E+01,.3543449E+01,.3873804E+01,.4204009E+01,.4566058E+01,& + & .3130039E+01,.3398800E+01,.3728888E+01,.4056038E+01,.4401957E+01,& + & .2968975E+01,.3253192E+01,.3573124E+01,.3904086E+01,.4239970E+01,& + & .2811010E+01,.3105040E+01,.3413054E+01,.3741891E+01,.4067138E+01,& + & .2663058E+01,.2951303E+01,.3256042E+01,.3581236E+01,.3900989E+01,& + & .2515451E+01,.2806289E+01,.3104377E+01,.3428028E+01,.3740708E+01,& + & .2378861E+01,.2672260E+01,.2967412E+01,.3283792E+01,.3592902E+01,& + & .2250954E+01,.2549314E+01,.2842896E+01,.3146414E+01,.3454348E+01,& + & .2126384E+01,.2425968E+01,.2718676E+01,.3012722E+01,.3313565E+01,& + & .2000566E+01,.2300064E+01,.2594150E+01,.2881717E+01,.3180487E+01,& + & .1893973E+01,.2183036E+01,.2478401E+01,.2762266E+01,.3053944E+01,& + & .1797191E+01,.2073967E+01,.2365713E+01,.2650269E+01,.2928594E+01,& + & .1699063E+01,.1967053E+01,.2254958E+01,.2539431E+01,.2812870E+01,& + & .1602483E+01,.1870209E+01,.2142381E+01,.2424027E+01,.2698355E+01,& + & .1508607E+01,.1774262E+01,.2038629E+01,.2313372E+01,.2585830E+01,& + & .1519868E+01,.1744553E+01,.1991354E+01,.2260467E+01,.2531035E+01/ + + data absb( 1:120, 6) / & + & .2781168E+03,.2745845E+03,.2712239E+03,.2678704E+03,.2644459E+03,& + & .2904946E+03,.2871655E+03,.2838470E+03,.2803941E+03,.2768948E+03,& + & .3022413E+03,.2989983E+03,.2955817E+03,.2921152E+03,.2885458E+03,& + & .3130565E+03,.3098089E+03,.3064324E+03,.3028900E+03,.2992469E+03,& + & .3228674E+03,.3196371E+03,.3162446E+03,.3126653E+03,.3089740E+03,& + & .3316375E+03,.3284418E+03,.3250265E+03,.3214442E+03,.3176680E+03,& + & .3390155E+03,.3360705E+03,.3328242E+03,.3291721E+03,.3252655E+03,& + & .3449713E+03,.3421655E+03,.3390332E+03,.3355221E+03,.3318374E+03,& + & .3493969E+03,.3468038E+03,.3437556E+03,.3405122E+03,.3368916E+03,& + & .3522054E+03,.3499115E+03,.3472051E+03,.3440347E+03,.3404337E+03,& + & .3535539E+03,.3513906E+03,.3491088E+03,.3465269E+03,.3430700E+03,& + & .3545730E+03,.3522557E+03,.3497503E+03,.3472267E+03,.3443498E+03,& + & .3550447E+03,.3525630E+03,.3499373E+03,.3472388E+03,.3443261E+03,& + & .3552526E+03,.3524843E+03,.3496510E+03,.3469402E+03,.3437094E+03,& + & .3555960E+03,.3526031E+03,.3495395E+03,.3465118E+03,.3432573E+03,& + & .3557797E+03,.3525640E+03,.3494123E+03,.3460217E+03,.3426940E+03,& + & .3564043E+03,.3530960E+03,.3498075E+03,.3463239E+03,.3427123E+03,& + & .3568211E+03,.3535487E+03,.3500420E+03,.3465557E+03,.3428692E+03,& + & .3576037E+03,.3541394E+03,.3507368E+03,.3471845E+03,.3434088E+03,& + & .3580188E+03,.3547035E+03,.3511129E+03,.3473748E+03,.3438292E+03,& + & .3581982E+03,.3548803E+03,.3511249E+03,.3474255E+03,.3435849E+03,& + & .3580668E+03,.3546083E+03,.3508286E+03,.3468622E+03,.3427171E+03,& + & .3579811E+03,.3542519E+03,.3503648E+03,.3462908E+03,.3414558E+03,& + & .3576096E+03,.3539086E+03,.3499965E+03,.3456525E+03,.3403969E+03/ + + data absb(121:235, 6) / & + & .3586604E+03,.3550335E+03,.3510399E+03,.3464481E+03,.3408584E+03,& + & .3598800E+03,.3563594E+03,.3522228E+03,.3469653E+03,.3413783E+03,& + & .3612682E+03,.3576057E+03,.3531275E+03,.3475159E+03,.3418607E+03,& + & .3631576E+03,.3595023E+03,.3547940E+03,.3491532E+03,.3434219E+03,& + & .3650737E+03,.3613720E+03,.3564614E+03,.3509635E+03,.3452500E+03,& + & .3670026E+03,.3632776E+03,.3582252E+03,.3527572E+03,.3469855E+03,& + & .3692557E+03,.3655325E+03,.3603844E+03,.3550208E+03,.3492473E+03,& + & .3718397E+03,.3678903E+03,.3626881E+03,.3574203E+03,.3517227E+03,& + & .3744095E+03,.3701124E+03,.3649258E+03,.3597189E+03,.3542337E+03,& + & .3767816E+03,.3723343E+03,.3673166E+03,.3620799E+03,.3567366E+03,& + & .3791321E+03,.3746009E+03,.3697970E+03,.3646097E+03,.3594172E+03,& + & .3813238E+03,.3769336E+03,.3722063E+03,.3670953E+03,.3619918E+03,& + & .3834849E+03,.3791057E+03,.3745237E+03,.3694845E+03,.3645086E+03,& + & .3854281E+03,.3811015E+03,.3766032E+03,.3716952E+03,.3667988E+03,& + & .3872332E+03,.3829179E+03,.3785031E+03,.3738180E+03,.3689635E+03,& + & .3889780E+03,.3847170E+03,.3803790E+03,.3758553E+03,.3711179E+03,& + & .3907123E+03,.3865429E+03,.3822340E+03,.3778545E+03,.3731887E+03,& + & .3921534E+03,.3881790E+03,.3839339E+03,.3796445E+03,.3751081E+03,& + & .3934377E+03,.3896848E+03,.3855532E+03,.3813151E+03,.3769936E+03,& + & .3947370E+03,.3911513E+03,.3871310E+03,.3829493E+03,.3787443E+03,& + & .3959555E+03,.3924751E+03,.3887103E+03,.3846245E+03,.3804545E+03,& + & .3971711E+03,.3937408E+03,.3901626E+03,.3862220E+03,.3821316E+03,& + & .3970289E+03,.3941655E+03,.3908061E+03,.3869572E+03,.3829149E+03/ + +! --- + data forref(1:3,1: 6) / .6585271E-05,.9433300E-05,.7977931E-04,& + & .8154837E-04,.1197092E-03,.1424472E-03,.2535780E-03,.2329964E-03,& + & .1885349E-03,.3380323E-03,.3052715E-03,.2150602E-03,.3685495E-03,& + & .3314392E-03,.2543625E-03,.3806938E-03,.3823779E-03,.2995716E-03/ + +! the array selfref contains the coefficient of the water vapor +! self-continuum (including the energy term). the first index +! refers to temperature in 7.2 degree increments. for instance, +! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +! etc. the second index runs over the g-channel (1 to 6). + + data selfref(1:10,1: 6) / & + & .1352797E-02,.1118049E-02,.9240558E-03,.7637369E-03,.6312454E-03,& + & .5217486E-03,.4312539E-03,.3564616E-03,.2946471E-03,.2435560E-03,& + & .3427292E-02,.2856171E-02,.2390076E-02,.2008096E-02,.1693734E-02,& + & .1433911E-02,.1218251E-02,.1038495E-02,.8880442E-03,.7616162E-03,& + & .4545629E-02,.4185794E-02,.3854444E-02,.3549326E-02,.3268367E-02,& + & .3009646E-02,.2771406E-02,.2552033E-02,.2350020E-02,.2163998E-02,& + & .5477838E-02,.5082542E-02,.4715844E-02,.4375667E-02,.4060089E-02,& + & .3767331E-02,.3495734E-02,.3243771E-02,.3010013E-02,.2793137E-02,& + & .5682360E-02,.5292443E-02,.4929650E-02,.4592058E-02,.4277891E-02,& + & .3985497E-02,.3713349E-02,.3460014E-02,.3224177E-02,.3004612E-02,& + & .7004786E-02,.6372419E-02,.5797303E-02,.5274236E-02,.4798502E-02,& + & .4365805E-02,.3972237E-02,.3614256E-02,.3288634E-02,.2992436E-02/ + +!........................................! + end module module_radsw_kgb16 ! +!========================================! + + +!> This module sets up absorption coeffients for band 17: 3250-4000 +!! cm-1 (low - h2o,co2; high - h2o,co2) +!========================================! + module module_radsw_kgb17 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o, co2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG17 + +! + implicit none +! + private +! +!> msa17=585 + integer, public :: MSA17 +!> msb17=1175 + integer, public :: MSB17 +!> msf17=10 + integer, public :: MSF17 +!> mfr17=4 + integer, public :: MFR17 + parameter (MSA17=585, MSB17=1175, MSF17=10, MFR17=4) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to NG17). + real (kind=kind_phys), public :: selfref(MSF17,NG17) + +!> the array absa(585,NG17) (ka((9,5,13,NG17)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 12, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA17,NG17) + +!> the array absb(1175,12) (kb(5,5,13:59,12)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 12, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB17,NG17) + + real (kind=kind_phys), public :: forref(MFR17,NG17) + +!> rayleigh extinction coefficient at v = 3625 \f$cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 6.86e-10 + + data absa( 1:180, 1) / & + & .1113400E-05,.3209200E-03,.5566300E-03,.7822700E-03,.9942100E-03,& + & .1204500E-02,.1411600E-02,.1606900E-02,.1933000E-02,.1054400E-05,& + & .3543400E-03,.6148000E-03,.8642400E-03,.1105500E-02,.1343100E-02,& + & .1575400E-02,.1795100E-02,.2128000E-02,.9834500E-06,.3898900E-03,& + & .6774700E-03,.9528900E-03,.1219600E-02,.1486400E-02,.1744900E-02,& + & .1989700E-02,.2356400E-02,.9501700E-06,.4258200E-03,.7441900E-03,& + & .1046300E-02,.1342400E-02,.1635300E-02,.1921500E-02,.2193900E-02,& + & .2599300E-02,.9187000E-06,.4637100E-03,.8139400E-03,.1146400E-02,& + & .1471500E-02,.1793700E-02,.2107200E-02,.2407700E-02,.2854000E-02,& + & .9418400E-06,.2653200E-03,.4615700E-03,.6377600E-03,.8108700E-03,& + & .9772800E-03,.1141900E-02,.1299100E-02,.1512100E-02,.8906000E-06,& + & .2941700E-03,.5096700E-03,.7075900E-03,.9020300E-03,.1092000E-02,& + & .1276400E-02,.1454400E-02,.1679500E-02,.8272000E-06,.3236100E-03,& + & .5612400E-03,.7829900E-03,.9971800E-03,.1209400E-02,.1417200E-02,& + & .1616500E-02,.1863700E-02,.7884200E-06,.3549500E-03,.6168400E-03,& + & .8617600E-03,.1099500E-02,.1334500E-02,.1565200E-02,.1785600E-02,& + & .2062100E-02,.7661000E-06,.3872800E-03,.6753800E-03,.9461300E-03,& + & .1208200E-02,.1467500E-02,.1720600E-02,.1964000E-02,.2272000E-02,& + & .7966300E-06,.2136900E-03,.3708800E-03,.5122200E-03,.6454900E-03,& + & .7732200E-03,.8993900E-03,.1020500E-02,.1156800E-02,.7595500E-06,& + & .2378000E-03,.4115300E-03,.5690100E-03,.7200900E-03,.8673500E-03,& + & .1009200E-02,.1147600E-02,.1291300E-02,.7169200E-06,.2627600E-03,& + & .4548800E-03,.6292200E-03,.7983600E-03,.9625900E-03,.1123600E-02,& + & .1279600E-02,.1439800E-02,.6634800E-06,.2889600E-03,.5022100E-03,& + & .6941100E-03,.8822600E-03,.1065800E-02,.1245600E-02,.1419100E-02,& + & .1599100E-02,.6401300E-06,.3164300E-03,.5516600E-03,.7643400E-03,& + & .9721600E-03,.1174500E-02,.1373100E-02,.1565700E-02,.1767100E-02,& + & .6621700E-06,.1696600E-03,.2935800E-03,.4068800E-03,.5111400E-03,& + & .6073900E-03,.7019100E-03,.7944600E-03,.8883200E-03,.6411100E-06,& + & .1890200E-03,.3274200E-03,.4536400E-03,.5708600E-03,.6840100E-03,& + & .7911600E-03,.8950700E-03,.9965500E-03,.6072900E-06,.2100700E-03,& + & .3635400E-03,.5035400E-03,.6345900E-03,.7611300E-03,.8847300E-03,& + & .1003500E-02,.1116300E-02,.5725000E-06,.2320300E-03,.4024500E-03,& + & .5575800E-03,.7029500E-03,.8451500E-03,.9837900E-03,.1116500E-02,& + & .1244400E-02,.5352400E-06,.2552900E-03,.4439900E-03,.6156400E-03,& + & .7762600E-03,.9340500E-03,.1089200E-02,.1236900E-02,.1379500E-02/ + + data absa(181:315, 1) / & + & .5511200E-06,.1342200E-03,.2316600E-03,.3211900E-03,.4026500E-03,& + & .4781200E-03,.5479700E-03,.6187300E-03,.6891200E-03,.5366900E-06,& + & .1499000E-03,.2594900E-03,.3588600E-03,.4523900E-03,.5393600E-03,& + & .6189400E-03,.6971800E-03,.7773200E-03,.5149500E-06,.1670600E-03,& + & .2896000E-03,.4002000E-03,.5046100E-03,.6024900E-03,.6967700E-03,& + & .7846400E-03,.8733400E-03,.4863300E-06,.1854300E-03,.3215900E-03,& + & .4449900E-03,.5609500E-03,.6705500E-03,.7757500E-03,.8771700E-03,& + & .9769400E-03,.4516200E-06,.2047200E-03,.3559100E-03,.4935000E-03,& + & .6216300E-03,.7425300E-03,.8624700E-03,.9751800E-03,.1086400E-02,& + & .4505500E-06,.1055600E-03,.1817600E-03,.2513700E-03,.3143800E-03,& + & .3736300E-03,.4275900E-03,.4788300E-03,.5343700E-03,.4450200E-06,& + & .1181400E-03,.2038300E-03,.2816200E-03,.3554700E-03,.4226100E-03,& + & .4834000E-03,.5406600E-03,.6035200E-03,.4306600E-06,.1321700E-03,& + & .2283600E-03,.3155200E-03,.3976200E-03,.4749300E-03,.5454300E-03,& + & .6106600E-03,.6817600E-03,.4111600E-06,.1473300E-03,.2547200E-03,& + & .3520400E-03,.4433400E-03,.5299700E-03,.6096600E-03,.6862200E-03,& + & .7660700E-03,.3874800E-06,.1634400E-03,.2828100E-03,.3917300E-03,& + & .4930500E-03,.5888000E-03,.6795400E-03,.7648500E-03,.8540100E-03,& + & .3658200E-06,.8295800E-04,.1421000E-03,.1957400E-03,.2444000E-03,& + & .2903900E-03,.3328100E-03,.3717700E-03,.4217800E-03,.3670700E-06,& + & .9290900E-04,.1597700E-03,.2203400E-03,.2774200E-03,.3295500E-03,& + & .3772700E-03,.4195600E-03,.4785900E-03,.3578700E-06,.1043200E-03,& + & .1793000E-03,.2476900E-03,.3115500E-03,.3724200E-03,.4269900E-03,& + & .4747400E-03,.5408300E-03,.3448200E-06,.1168500E-03,.2005500E-03,& + & .2772500E-03,.3486600E-03,.4167700E-03,.4790300E-03,.5351800E-03,& + & .6081200E-03,.3259800E-06,.1300100E-03,.2234100E-03,.3090000E-03,& + & .3891900E-03,.4646500E-03,.5346700E-03,.5992600E-03,.6773300E-03/ + + data absa(316:450, 1) / & + & .2983400E-06,.6500900E-04,.1118300E-03,.1520000E-03,.1896900E-03,& + & .2251700E-03,.2583200E-03,.2873000E-03,.3395500E-03,.2974500E-06,& + & .7287200E-04,.1248200E-03,.1722100E-03,.2158300E-03,.2559600E-03,& + & .2932800E-03,.3252000E-03,.3862000E-03,.2942100E-06,.8203600E-04,& + & .1401000E-03,.1934400E-03,.2436200E-03,.2907100E-03,.3330800E-03,& + & .3686700E-03,.4390100E-03,.2859600E-06,.9225600E-04,.1573800E-03,& + & .2175200E-03,.2732500E-03,.3264300E-03,.3757800E-03,.4171000E-03,& + & .4935800E-03,.2729600E-06,.1032000E-03,.1759800E-03,.2433900E-03,& + & .3059100E-03,.3650500E-03,.4206100E-03,.4687200E-03,.5499300E-03,& + & .2425900E-06,.5062600E-04,.8694500E-04,.1177800E-03,.1469200E-03,& + & .1743100E-03,.2005700E-03,.2213100E-03,.2991900E-03,.2405800E-06,& + & .5696600E-04,.9746700E-04,.1340500E-03,.1675000E-03,.1981400E-03,& + & .2273900E-03,.2528100E-03,.3402200E-03,.2409100E-06,.6432400E-04,& + & .1097100E-03,.1506100E-03,.1899600E-03,.2258000E-03,.2588500E-03,& + & .2869400E-03,.3804500E-03,.2355000E-06,.7245100E-04,.1234500E-03,& + & .1699100E-03,.2136200E-03,.2548400E-03,.2934100E-03,.3252300E-03,& + & .4283600E-03,.2269600E-06,.8135100E-04,.1383900E-03,.1909000E-03,& + & .2398600E-03,.2860800E-03,.3291000E-03,.3663900E-03,.4792500E-03,& + & .1967900E-06,.3976000E-04,.6805200E-04,.9229500E-04,.1149800E-03,& + & .1365600E-03,.1560400E-03,.1717100E-03,.2967900E-03,.1956700E-06,& + & .4484700E-04,.7682900E-04,.1051800E-03,.1310200E-03,.1550900E-03,& + & .1776400E-03,.1984300E-03,.3286300E-03,.1957400E-06,.5056500E-04,& + & .8646600E-04,.1187800E-03,.1492000E-03,.1769800E-03,.2025800E-03,& + & .2252600E-03,.3695900E-03,.1926200E-06,.5712400E-04,.9754600E-04,& + & .1339800E-03,.1680300E-03,.2004600E-03,.2302200E-03,.2557800E-03,& + & .4154300E-03,.1874700E-06,.6426400E-04,.1097100E-03,.1508600E-03,& + & .1892300E-03,.2256500E-03,.2593400E-03,.2892100E-03,.4646300E-03/ + + data absa(451:585, 1) / & + & .1601500E-06,.3302500E-04,.5656200E-04,.7662500E-04,.9564500E-04,& + & .1135800E-03,.1295500E-03,.1426900E-03,.2754500E-03,.1591800E-06,& + & .3714800E-04,.6377500E-04,.8760000E-04,.1089700E-03,.1289300E-03,& + & .1475600E-03,.1646500E-03,.3079900E-03,.1589700E-06,.4199300E-04,& + & .7204000E-04,.9892800E-04,.1243300E-03,.1473300E-03,.1682400E-03,& + & .1869400E-03,.3434000E-03,.1557800E-06,.4744100E-04,.8142600E-04,& + & .1116500E-03,.1398500E-03,.1667300E-03,.1915600E-03,.2126800E-03,& + & .3817600E-03,.1521000E-06,.5339800E-04,.9165700E-04,.1259200E-03,& + & .1576900E-03,.1878100E-03,.2156900E-03,.2406900E-03,.4222800E-03,& + & .1302100E-06,.2727200E-04,.4683200E-04,.6351100E-04,.7920500E-04,& + & .9394900E-04,.1071900E-03,.1182700E-03,.2394400E-03,.1293000E-06,& + & .3068600E-04,.5292500E-04,.7278200E-04,.9052700E-04,.1070800E-03,& + & .1223600E-03,.1362000E-03,.2712100E-03,.1290000E-06,.3472300E-04,& + & .5986700E-04,.8220500E-04,.1032600E-03,.1223800E-03,.1395800E-03,& + & .1549800E-03,.2993000E-03,.1264800E-06,.3925200E-04,.6761800E-04,& + & .9294900E-04,.1163600E-03,.1383500E-03,.1592400E-03,.1765300E-03,& + & .3305000E-03,.1229900E-06,.4421300E-04,.7624400E-04,.1048800E-03,& + & .1313500E-03,.1560100E-03,.1790200E-03,.1997600E-03,.3657900E-03,& + & .1055400E-06,.2238800E-04,.3859700E-04,.5237800E-04,.6540400E-04,& + & .7756700E-04,.8854300E-04,.9780100E-04,.1959900E-03,.1048000E-06,& + & .2518100E-04,.4367000E-04,.6020500E-04,.7488300E-04,.8860500E-04,& + & .1011700E-03,.1124200E-03,.2214600E-03,.1042900E-06,.2853000E-04,& + & .4942200E-04,.6803900E-04,.8543500E-04,.1013600E-03,.1155700E-03,& + & .1282800E-03,.2444700E-03,.1023200E-06,.3230100E-04,.5579700E-04,& + & .7694800E-04,.9644700E-04,.1146200E-03,.1316600E-03,.1461600E-03,& + & .2699900E-03,.9901400E-07,.3639400E-04,.6299400E-04,.8694600E-04,& + & .1090000E-03,.1293700E-03,.1483300E-03,.1654000E-03,.2991600E-03/ + + data absa( 1:180, 2) / & + & .2348800E-04,.1668400E-02,.2957500E-02,.4008300E-02,.4995300E-02,& + & .5902100E-02,.6744600E-02,.7600800E-02,.8703200E-02,.2515600E-04,& + & .1846200E-02,.3271100E-02,.4500800E-02,.5618200E-02,.6628700E-02,& + & .7590900E-02,.8555800E-02,.9754300E-02,.2708400E-04,.2032500E-02,& + & .3603400E-02,.4999200E-02,.6279600E-02,.7413400E-02,.8499400E-02,& + & .9569400E-02,.1084700E-01,.2814700E-04,.2234700E-02,.3962800E-02,& + & .5500500E-02,.6945300E-02,.8242900E-02,.9469900E-02,.1066000E-01,& + & .1199100E-01,.2871900E-04,.2447500E-02,.4336900E-02,.6036000E-02,& + & .7618300E-02,.9087800E-02,.1049300E-01,.1180500E-01,.1320400E-01,& + & .2094700E-04,.1401500E-02,.2472800E-02,.3367600E-02,.4180100E-02,& + & .4924400E-02,.5578700E-02,.6220600E-02,.6974100E-02,.2235200E-04,& + & .1553500E-02,.2739600E-02,.3787000E-02,.4712100E-02,.5557100E-02,& + & .6289200E-02,.7013200E-02,.7809200E-02,.2388200E-04,.1721300E-02,& + & .3034500E-02,.4202000E-02,.5278200E-02,.6228500E-02,.7055600E-02,& + & .7881900E-02,.8733000E-02,.2465000E-04,.1895400E-02,.3338400E-02,& + & .4633600E-02,.5833300E-02,.6931100E-02,.7875100E-02,.8814900E-02,& + & .9691100E-02,.2513600E-04,.2080600E-02,.3664100E-02,.5096600E-02,& + & .6419300E-02,.7628100E-02,.8740300E-02,.9794300E-02,.1070400E-01,& + & .1772000E-04,.1141400E-02,.2004500E-02,.2728800E-02,.3389100E-02,& + & .3975500E-02,.4496700E-02,.4938900E-02,.5385800E-02,.1908700E-04,& + & .1274500E-02,.2233600E-02,.3084100E-02,.3833300E-02,.4498300E-02,& + & .5089500E-02,.5593000E-02,.6066600E-02,.2012500E-04,.1417800E-02,& + & .2479500E-02,.3427800E-02,.4310600E-02,.5060700E-02,.5728000E-02,& + & .6309200E-02,.6828500E-02,.2089500E-04,.1566600E-02,.2734800E-02,& + & .3793400E-02,.4776900E-02,.5662100E-02,.6404600E-02,.7086400E-02,& + & .7602600E-02,.2150800E-04,.1725100E-02,.3015300E-02,.4180900E-02,& + & .5268900E-02,.6246200E-02,.7112500E-02,.7910400E-02,.8438900E-02,& + & .1466100E-04,.9226100E-03,.1608800E-02,.2178800E-02,.2695600E-02,& + & .3161200E-02,.3562600E-02,.3887800E-02,.4152500E-02,.1560700E-04,& + & .1032900E-02,.1797300E-02,.2473500E-02,.3069600E-02,.3595300E-02,& + & .4051100E-02,.4416200E-02,.4699000E-02,.1655900E-04,.1155000E-02,& + & .2001900E-02,.2757700E-02,.3462500E-02,.4066200E-02,.4583100E-02,& + & .4999500E-02,.5307300E-02,.1726300E-04,.1279400E-02,.2218400E-02,& + & .3061400E-02,.3851000E-02,.4566400E-02,.5153200E-02,.5629000E-02,& + & .5943600E-02,.1789500E-04,.1413000E-02,.2452600E-02,.3380500E-02,& + & .4262200E-02,.5055600E-02,.5748900E-02,.6309400E-02,.6625600E-02/ + + data absa(181:315, 2) / & + & .1188500E-04,.7488800E-03,.1282600E-02,.1725800E-02,.2134600E-02,& + & .2497200E-02,.2804600E-02,.3060600E-02,.3232300E-02,.1245200E-04,& + & .8408400E-03,.1438000E-02,.1969800E-02,.2438600E-02,.2853600E-02,& + & .3207500E-02,.3493700E-02,.3656200E-02,.1343900E-04,.9427200E-03,& + & .1606500E-02,.2207900E-02,.2766000E-02,.3238900E-02,.3644000E-02,& + & .3967300E-02,.4139300E-02,.1405300E-04,.1047300E-02,.1789900E-02,& + & .2460300E-02,.3086100E-02,.3652100E-02,.4115600E-02,.4482500E-02,& + & .4652900E-02,.1458600E-04,.1158500E-02,.1988600E-02,.2725700E-02,& + & .3427200E-02,.4059900E-02,.4611500E-02,.5028600E-02,.5208500E-02,& + & .9487200E-05,.5979300E-03,.1021000E-02,.1357200E-02,.1671600E-02,& + & .1951200E-02,.2189000E-02,.2382700E-02,.2534700E-02,.1006000E-04,& + & .6740000E-03,.1143200E-02,.1556400E-02,.1918800E-02,.2238900E-02,& + & .2516100E-02,.2730800E-02,.2877000E-02,.1074300E-04,.7594800E-03,& + & .1280600E-02,.1755100E-02,.2186200E-02,.2554500E-02,.2872900E-02,& + & .3114900E-02,.3271600E-02,.1132200E-04,.8513400E-03,.1432000E-02,& + & .1963000E-02,.2451400E-02,.2893000E-02,.3257800E-02,.3537500E-02,& + & .3691200E-02,.1175500E-04,.9461100E-03,.1598600E-02,.2180400E-02,& + & .2729100E-02,.3230600E-02,.3669500E-02,.3991300E-02,.4143900E-02,& + & .7593100E-05,.4713000E-03,.8121100E-03,.1065800E-02,.1300400E-02,& + & .1517500E-02,.1700200E-02,.1847300E-02,.1986100E-02,.8072400E-05,& + & .5335800E-03,.9116300E-03,.1226100E-02,.1501400E-02,.1748300E-02,& + & .1961200E-02,.2120100E-02,.2259100E-02,.8440400E-05,.6051700E-03,& + & .1023600E-02,.1388700E-02,.1720400E-02,.2003100E-02,.2249700E-02,& + & .2432100E-02,.2582300E-02,.9051100E-05,.6803700E-03,.1147500E-02,& + & .1559600E-02,.1940200E-02,.2278900E-02,.2563300E-02,.2775300E-02,& + & .2924700E-02,.9440500E-05,.7610300E-03,.1283600E-02,.1742200E-02,& + & .2169800E-02,.2558500E-02,.2898900E-02,.3144400E-02,.3301600E-02/ + + data absa(316:450, 2) / & + & .5808000E-05,.3678200E-03,.6351600E-03,.8379900E-03,.1011900E-02,& + & .1175400E-02,.1316100E-02,.1438200E-02,.1583700E-02,.6315600E-05,& + & .4190900E-03,.7197400E-03,.9695200E-03,.1171100E-02,.1361700E-02,& + & .1523400E-02,.1644100E-02,.1811800E-02,.6677600E-05,.4782900E-03,& + & .8115000E-03,.1105600E-02,.1349300E-02,.1564600E-02,.1752400E-02,& + & .1893700E-02,.2069800E-02,.7058200E-05,.5401700E-03,.9133000E-03,& + & .1243400E-02,.1541100E-02,.1788400E-02,.2005700E-02,.2170400E-02,& + & .2354800E-02,.7490200E-05,.6071700E-03,.1026700E-02,.1390800E-02,& + & .1723100E-02,.2028500E-02,.2281000E-02,.2471000E-02,.2663100E-02,& + & .4506100E-05,.2862600E-03,.4944800E-03,.6531700E-03,.7908100E-03,& + & .9106600E-03,.1018200E-02,.1110700E-02,.1459200E-02,.4939200E-05,& + & .3273400E-03,.5655800E-03,.7607700E-03,.9184600E-03,.1057800E-02,& + & .1177600E-02,.1272000E-02,.1677800E-02,.5258000E-05,.3752200E-03,& + & .6384500E-03,.8780500E-03,.1061900E-02,.1219400E-02,.1360600E-02,& + & .1468000E-02,.1925900E-02,.5499100E-05,.4265900E-03,.7210300E-03,& + & .9875600E-03,.1216300E-02,.1400700E-02,.1564700E-02,.1690000E-02,& + & .2177200E-02,.5876900E-05,.4819900E-03,.8146600E-03,.1107200E-02,& + & .1368400E-02,.1598400E-02,.1788700E-02,.1933300E-02,.2433100E-02,& + & .3415400E-05,.2253400E-03,.3878800E-03,.5111300E-03,.6219400E-03,& + & .7143200E-03,.7974300E-03,.8628900E-03,.1475800E-02,.3808500E-05,& + & .2583200E-03,.4474800E-03,.5983500E-03,.7251400E-03,.8328400E-03,& + & .9194100E-03,.9958300E-03,.1735800E-02,.4157800E-05,.2965500E-03,& + & .5055300E-03,.6951100E-03,.8410700E-03,.9637400E-03,.1066600E-02,& + & .1147800E-02,.1962500E-02,.4391700E-05,.3390800E-03,.5735100E-03,& + & .7864000E-03,.9686200E-03,.1110900E-02,.1230900E-02,.1326600E-02,& + & .2210300E-02,.4544600E-05,.3854800E-03,.6488300E-03,.8840100E-03,& + & .1095200E-02,.1270600E-02,.1413600E-02,.1523900E-02,.2475400E-02/ + + data absa(451:585, 2) / & + & .2760400E-05,.1884800E-03,.3253200E-03,.4294900E-03,.5235000E-03,& + & .6008400E-03,.6664000E-03,.7207000E-03,.1369200E-02,.3090800E-05,& + & .2167900E-03,.3725900E-03,.5036600E-03,.6107400E-03,.7015800E-03,& + & .7727100E-03,.8303700E-03,.1568900E-02,.3367400E-05,.2496500E-03,& + & .4224400E-03,.5835300E-03,.7092300E-03,.8133000E-03,.8975000E-03,& + & .9613100E-03,.1797100E-02,.3556800E-05,.2860200E-03,.4804400E-03,& + & .6586800E-03,.8181600E-03,.9385700E-03,.1035700E-02,.1111900E-02,& + & .2050900E-02,.3692100E-05,.3248400E-03,.5462300E-03,.7447500E-03,& + & .9230700E-03,.1075800E-02,.1189500E-02,.1277700E-02,.2325300E-02,& + & .2227200E-05,.1580700E-03,.2716300E-03,.3593500E-03,.4378100E-03,& + & .5032100E-03,.5577600E-03,.6004600E-03,.1185200E-02,.2489800E-05,& + & .1820100E-03,.3100400E-03,.4220600E-03,.5122600E-03,.5882400E-03,& + & .6491900E-03,.6929100E-03,.1362300E-02,.2702100E-05,.2095800E-03,& + & .3532200E-03,.4867600E-03,.5958700E-03,.6836400E-03,.7552700E-03,& + & .8043600E-03,.1565400E-02,.2852600E-05,.2403800E-03,.4026200E-03,& + & .5509600E-03,.6867100E-03,.7910300E-03,.8721100E-03,.9312400E-03,& + & .1789800E-02,.2989900E-05,.2728900E-03,.4590400E-03,.6244800E-03,& + & .7749600E-03,.9021200E-03,.1001800E-02,.1070600E-02,.2026500E-02,& + & .1757600E-05,.1315100E-03,.2251800E-03,.2989000E-03,.3639800E-03,& + & .4188400E-03,.4650500E-03,.5008600E-03,.9791600E-03,.1952400E-05,& + & .1518900E-03,.2568600E-03,.3512300E-03,.4272300E-03,.4906100E-03,& + & .5429300E-03,.5781500E-03,.1126000E-02,.2113400E-05,.1755800E-03,& + & .2938200E-03,.4045700E-03,.4977700E-03,.5715300E-03,.6318500E-03,& + & .6721300E-03,.1296000E-02,.2268100E-05,.2010600E-03,.3358300E-03,& + & .4597700E-03,.5709400E-03,.6627500E-03,.7314900E-03,.7779900E-03,& + & .1485600E-02,.2394000E-05,.2285300E-03,.3832300E-03,.5212600E-03,& + & .6468400E-03,.7545500E-03,.8411500E-03,.8957500E-03,.1681600E-02/ + + data absa( 1:180, 3) / & + & .8715400E-04,.7045600E-02,.1162400E-01,.1600700E-01,.2027700E-01,& + & .2434900E-01,.2790200E-01,.3095600E-01,.3315900E-01,.9267800E-04,& + & .7532400E-02,.1255200E-01,.1744400E-01,.2196700E-01,.2625000E-01,& + & .3024100E-01,.3334800E-01,.3616400E-01,.9795500E-04,.8015300E-02,& + & .1350200E-01,.1881200E-01,.2386200E-01,.2848000E-01,.3251100E-01,& + & .3571300E-01,.3834900E-01,.1040400E-03,.8472400E-02,.1442900E-01,& + & .2013600E-01,.2567200E-01,.3068800E-01,.3501100E-01,.3837900E-01,& + & .4067300E-01,.1111000E-03,.8912300E-02,.1534300E-01,.2147900E-01,& + & .2729000E-01,.3275100E-01,.3745500E-01,.4093100E-01,.4246300E-01,& + & .7321400E-04,.6141000E-02,.1012500E-01,.1365000E-01,.1715800E-01,& + & .2062700E-01,.2362800E-01,.2625100E-01,.2748100E-01,.7793600E-04,& + & .6575100E-02,.1096600E-01,.1487700E-01,.1869300E-01,.2227200E-01,& + & .2563000E-01,.2839500E-01,.2989400E-01,.8306100E-04,.6982800E-02,& + & .1177400E-01,.1606800E-01,.2031700E-01,.2424400E-01,.2774800E-01,& + & .3043200E-01,.3185100E-01,.8856400E-04,.7398500E-02,.1258100E-01,& + & .1722600E-01,.2184200E-01,.2617700E-01,.2996900E-01,.3274800E-01,& + & .3380500E-01,.9493300E-04,.7798800E-02,.1337200E-01,.1836700E-01,& + & .2332300E-01,.2792800E-01,.3196400E-01,.3501300E-01,.3532700E-01,& + & .6094700E-04,.5243600E-02,.8617400E-02,.1152000E-01,.1423100E-01,& + & .1702700E-01,.1946900E-01,.2163400E-01,.2198100E-01,.6492100E-04,& + & .5597500E-02,.9351200E-02,.1252600E-01,.1551600E-01,.1847100E-01,& + & .2127000E-01,.2351200E-01,.2411400E-01,.6952100E-04,.5964800E-02,& + & .1006000E-01,.1358200E-01,.1690300E-01,.2017700E-01,.2305500E-01,& + & .2538000E-01,.2582200E-01,.7434800E-04,.6310400E-02,.1076700E-01,& + & .1459900E-01,.1827300E-01,.2183600E-01,.2498400E-01,.2735800E-01,& + & .2745000E-01,.7978000E-04,.6667100E-02,.1145800E-01,.1559000E-01,& + & .1957900E-01,.2335800E-01,.2680600E-01,.2933500E-01,.2878600E-01,& + & .5079900E-04,.4414800E-02,.7222500E-02,.9648300E-02,.1176700E-01,& + & .1382800E-01,.1584400E-01,.1758800E-01,.1739100E-01,.5422700E-04,& + & .4723100E-02,.7852700E-02,.1049300E-01,.1283500E-01,.1512600E-01,& + & .1746600E-01,.1921900E-01,.1935100E-01,.5815100E-04,.5027700E-02,& + & .8482300E-02,.1141800E-01,.1396900E-01,.1657600E-01,.1890300E-01,& + & .2084000E-01,.2085300E-01,.6243300E-04,.5337200E-02,.9081300E-02,& + & .1232500E-01,.1516300E-01,.1797100E-01,.2059000E-01,.2252900E-01,& + & .2227300E-01,.6685200E-04,.5642900E-02,.9683600E-02,.1318900E-01,& + & .1628000E-01,.1931200E-01,.2213600E-01,.2426300E-01,.2346600E-01/ + + data absa(181:315, 3) / & + & .4259300E-04,.3676000E-02,.5991300E-02,.7981200E-02,.9772900E-02,& + & .1126500E-01,.1287400E-01,.1415000E-01,.1365100E-01,.4577900E-04,& + & .3934400E-02,.6540100E-02,.8703000E-02,.1065000E-01,.1237400E-01,& + & .1413500E-01,.1552900E-01,.1550700E-01,.4886800E-04,.4201300E-02,& + & .7085900E-02,.9491200E-02,.1160900E-01,.1355700E-01,.1538100E-01,& + & .1699300E-01,.1678500E-01,.5250900E-04,.4467400E-02,.7602200E-02,& + & .1027100E-01,.1263000E-01,.1473600E-01,.1683000E-01,.1838700E-01,& + & .1804000E-01,.5619600E-04,.4738100E-02,.8100500E-02,.1102600E-01,& + & .1358600E-01,.1594000E-01,.1816000E-01,.1992000E-01,.1909200E-01,& + & .3611200E-04,.3031600E-02,.4903800E-02,.6532500E-02,.7960600E-02,& + & .9170600E-02,.1028500E-01,.1125200E-01,.1055600E-01,.3850200E-04,& + & .3257500E-02,.5385500E-02,.7130200E-02,.8720000E-02,.1013800E-01,& + & .1131900E-01,.1250400E-01,.1210900E-01,.4107000E-04,.3486900E-02,& + & .5864300E-02,.7802000E-02,.9523200E-02,.1108100E-01,.1241300E-01,& + & .1370000E-01,.1335000E-01,.4403400E-04,.3714200E-02,.6292400E-02,& + & .8486700E-02,.1040000E-01,.1209100E-01,.1361400E-01,.1485000E-01,& + & .1439600E-01,.4702100E-04,.3938700E-02,.6717100E-02,.9131900E-02,& + & .1123100E-01,.1312900E-01,.1474500E-01,.1615500E-01,.1539200E-01,& + & .3000100E-04,.2488400E-02,.3978700E-02,.5326200E-02,.6425400E-02,& + & .7442200E-02,.8241800E-02,.8765100E-02,.8324100E-02,.3206700E-04,& + & .2683100E-02,.4387300E-02,.5800900E-02,.7088100E-02,.8230300E-02,& + & .9111500E-02,.9953000E-02,.9584300E-02,.3441400E-04,.2876200E-02,& + & .4798100E-02,.6365000E-02,.7755500E-02,.9013000E-02,.1005100E-01,& + & .1094400E-01,.1068700E-01,.3654300E-04,.3074900E-02,.5169700E-02,& + & .6954900E-02,.8493900E-02,.9862100E-02,.1101200E-01,.1195000E-01,& + & .1159600E-01,.3898600E-04,.3267200E-02,.5526800E-02,.7495000E-02,& + & .9220600E-02,.1075000E-01,.1197000E-01,.1302900E-01,.1246100E-01/ + + data absa(316:450, 3) / & + & .2471800E-04,.2030400E-02,.3225300E-02,.4295700E-02,.5162100E-02,& + & .5947700E-02,.6554300E-02,.6790100E-02,.6657800E-02,.2622600E-04,& + & .2202700E-02,.3552800E-02,.4684400E-02,.5746300E-02,.6607000E-02,& + & .7356600E-02,.7908600E-02,.7680700E-02,.2809500E-04,.2361400E-02,& + & .3896000E-02,.5152900E-02,.6277300E-02,.7291900E-02,.8147500E-02,& + & .8734400E-02,.8650900E-02,.2985600E-04,.2534600E-02,.4218000E-02,& + & .5650700E-02,.6886700E-02,.7994800E-02,.8916900E-02,.9622600E-02,& + & .9421200E-02,.3143200E-04,.2698900E-02,.4528800E-02,.6115800E-02,& + & .7523100E-02,.8731900E-02,.9744700E-02,.1047000E-01,.1017200E-01,& + & .2015100E-04,.1662200E-02,.2610200E-02,.3434500E-02,.4151800E-02,& + & .4735600E-02,.5119800E-02,.5290100E-02,.5560800E-02,.2129000E-04,& + & .1811200E-02,.2862200E-02,.3777000E-02,.4609800E-02,.5282500E-02,& + & .5871900E-02,.6211500E-02,.6428700E-02,.2260400E-04,.1948300E-02,& + & .3153600E-02,.4141800E-02,.5051300E-02,.5888300E-02,.6519900E-02,& + & .7000000E-02,.7164100E-02,.2403900E-04,.2090900E-02,.3432100E-02,& + & .4563300E-02,.5557500E-02,.6445300E-02,.7180000E-02,.7706200E-02,& + & .7782100E-02,.2527500E-04,.2232500E-02,.3697600E-02,.4972700E-02,& + & .6094500E-02,.7063200E-02,.7869600E-02,.8404800E-02,.8457100E-02,& + & .1652000E-04,.1357900E-02,.2121700E-02,.2765000E-02,.3320900E-02,& + & .3765700E-02,.4026300E-02,.4163200E-02,.5901900E-02,.1730700E-04,& + & .1486800E-02,.2323000E-02,.3061600E-02,.3700000E-02,.4262900E-02,& + & .4695800E-02,.4895600E-02,.6472900E-02,.1821000E-04,.1608600E-02,& + & .2563500E-02,.3348000E-02,.4082700E-02,.4759000E-02,.5242400E-02,& + & .5608800E-02,.7107200E-02,.1926300E-04,.1730800E-02,.2803800E-02,& + & .3701600E-02,.4493300E-02,.5211400E-02,.5822400E-02,.6205300E-02,& + & .7644500E-02,.2045000E-04,.1851400E-02,.3028600E-02,.4056900E-02,& + & .4941700E-02,.5729200E-02,.6380900E-02,.6816200E-02,.8180000E-02/ + + data absa(451:585, 3) / & + & .1374300E-04,.1154400E-02,.1800500E-02,.2338000E-02,.2812700E-02,& + & .3201900E-02,.3418400E-02,.3513700E-02,.5513200E-02,.1431400E-04,& + & .1264800E-02,.1981100E-02,.2579400E-02,.3128300E-02,.3583500E-02,& + & .3963500E-02,.4152400E-02,.6064000E-02,.1498000E-04,.1366700E-02,& + & .2184600E-02,.2831600E-02,.3439000E-02,.4006900E-02,.4428300E-02,& + & .4728200E-02,.6566200E-02,.1584300E-04,.1469100E-02,.2384400E-02,& + & .3134600E-02,.3791500E-02,.4392600E-02,.4910800E-02,.5243100E-02,& + & .7052100E-02,.1680100E-04,.1570900E-02,.2573800E-02,.3425000E-02,& + & .4178100E-02,.4825800E-02,.5377600E-02,.5740000E-02,.7491300E-02,& + & .1126500E-04,.9747300E-03,.1519000E-02,.1977900E-02,.2370800E-02,& + & .2700200E-02,.2895400E-02,.2968900E-02,.4905200E-02,.1170300E-04,& + & .1066000E-02,.1680600E-02,.2174200E-02,.2637000E-02,.3018400E-02,& + & .3346100E-02,.3508100E-02,.5351500E-02,.1227500E-04,.1152400E-02,& + & .1853200E-02,.2401400E-02,.2893200E-02,.3361500E-02,.3733200E-02,& + & .3975900E-02,.5780600E-02,.1296300E-04,.1240500E-02,.2020000E-02,& + & .2657300E-02,.3197800E-02,.3690400E-02,.4122500E-02,.4415100E-02,& + & .6195600E-02,.1369600E-04,.1326600E-02,.2181400E-02,.2893900E-02,& + & .3528400E-02,.4062900E-02,.4519100E-02,.4828300E-02,.6580000E-02,& + & .9117900E-05,.8153100E-03,.1275400E-02,.1659800E-02,.1990000E-02,& + & .2263400E-02,.2444100E-02,.2498400E-02,.4057600E-02,.9503900E-05,& + & .8909300E-03,.1415000E-02,.1828700E-02,.2214300E-02,.2532900E-02,& + & .2809200E-02,.2954600E-02,.4437400E-02,.9976200E-05,.9649400E-03,& + & .1562500E-02,.2028800E-02,.2431900E-02,.2810800E-02,.3137300E-02,& + & .3317700E-02,.4809400E-02,.1050900E-04,.1039800E-02,.1699600E-02,& + & .2244300E-02,.2692500E-02,.3094200E-02,.3448100E-02,.3700300E-02,& + & .5155000E-02,.1103300E-04,.1113400E-02,.1837200E-02,.2440800E-02,& + & .2968200E-02,.3411400E-02,.3785900E-02,.4042400E-02,.5489300E-02/ + + data absa( 1:180, 4) / & + & .2556400E-03,.2394000E-01,.4153500E-01,.5627600E-01,.6856100E-01,& + & .7863000E-01,.8699300E-01,.9179400E-01,.8422900E-01,.2919400E-03,& + & .2517000E-01,.4365900E-01,.5901600E-01,.7230200E-01,.8316700E-01,& + & .9173900E-01,.9677400E-01,.8683800E-01,.3393400E-03,.2643000E-01,& + & .4583500E-01,.6192200E-01,.7561400E-01,.8728500E-01,.9660600E-01,& + & .1015600E+00,.9008400E-01,.3887100E-03,.2773300E-01,.4805800E-01,& + & .6497300E-01,.7909000E-01,.9115600E-01,.1008400E+00,.1058900E+00,& + & .9258300E-01,.4447300E-03,.2902800E-01,.5028700E-01,.6801000E-01,& + & .8280500E-01,.9519300E-01,.1049200E+00,.1099500E+00,.9541900E-01,& + & .2340000E-03,.2075300E-01,.3574200E-01,.4870900E-01,.5954800E-01,& + & .6820600E-01,.7504500E-01,.7891500E-01,.7018000E-01,.2677500E-03,& + & .2183200E-01,.3761100E-01,.5115600E-01,.6276800E-01,.7226700E-01,& + & .7942200E-01,.8326200E-01,.7273500E-01,.3003300E-03,.2296100E-01,& + & .3961800E-01,.5377400E-01,.6577300E-01,.7581900E-01,.8353200E-01,& + & .8749600E-01,.7545900E-01,.3436600E-03,.2411600E-01,.4159700E-01,& + & .5650600E-01,.6894400E-01,.7923100E-01,.8724500E-01,.9133600E-01,& + & .7766900E-01,.3917900E-03,.2528900E-01,.4357500E-01,.5928200E-01,& + & .7213200E-01,.8295600E-01,.9103800E-01,.9493700E-01,.8027200E-01,& + & .2073000E-03,.1804400E-01,.3022700E-01,.4120600E-01,.5062600E-01,& + & .5809500E-01,.6372500E-01,.6672100E-01,.5778000E-01,.2400700E-03,& + & .1897200E-01,.3188300E-01,.4348600E-01,.5357200E-01,.6174200E-01,& + & .6748900E-01,.7055200E-01,.6000900E-01,.2693100E-03,.1993400E-01,& + & .3368100E-01,.4577500E-01,.5625500E-01,.6486900E-01,.7125400E-01,& + & .7423200E-01,.6235000E-01,.3006400E-03,.2096500E-01,.3544800E-01,& + & .4819900E-01,.5903600E-01,.6792100E-01,.7459400E-01,.7768900E-01,& + & .6441000E-01,.3396700E-03,.2197200E-01,.3719200E-01,.5067600E-01,& + & .6188400E-01,.7120700E-01,.7788800E-01,.8094700E-01,.6666700E-01,& + & .1820100E-03,.1559500E-01,.2537200E-01,.3443100E-01,.4240100E-01,& + & .4891500E-01,.5361300E-01,.5595300E-01,.4772700E-01,.2088300E-03,& + & .1642200E-01,.2685100E-01,.3648100E-01,.4507400E-01,.5207800E-01,& + & .5686000E-01,.5928700E-01,.4955300E-01,.2387400E-03,.1728500E-01,& + & .2842500E-01,.3851400E-01,.4754200E-01,.5490400E-01,.6028400E-01,& + & .6256100E-01,.5159500E-01,.2670700E-03,.1820000E-01,.3000700E-01,& + & .4061300E-01,.4998200E-01,.5766200E-01,.6323100E-01,.6566600E-01,& + & .5345000E-01,.3010200E-03,.1911300E-01,.3155200E-01,.4280500E-01,& + & .5253500E-01,.6055900E-01,.6619500E-01,.6854900E-01,.5541500E-01/ + + data absa(181:315, 4) / & + & .1580100E-03,.1329500E-01,.2152400E-01,.2866600E-01,.3514200E-01,& + & .4075700E-01,.4471500E-01,.4674000E-01,.3938400E-01,.1799400E-03,& + & .1405700E-01,.2278600E-01,.3048700E-01,.3756300E-01,.4350900E-01,& + & .4767600E-01,.4963800E-01,.4084900E-01,.2053500E-03,.1481100E-01,& + & .2411600E-01,.3226600E-01,.3976400E-01,.4612200E-01,.5066900E-01,& + & .5241300E-01,.4268300E-01,.2351100E-03,.1559800E-01,.2548100E-01,& + & .3410300E-01,.4192400E-01,.4859200E-01,.5328300E-01,.5523500E-01,& + & .4433500E-01,.2664000E-03,.1640200E-01,.2684400E-01,.3600000E-01,& + & .4418000E-01,.5108600E-01,.5591800E-01,.5779600E-01,.4599100E-01,& + & .1380500E-03,.1122200E-01,.1812500E-01,.2387700E-01,.2893900E-01,& + & .3350600E-01,.3694400E-01,.3867200E-01,.3233500E-01,.1543900E-03,& + & .1188300E-01,.1926200E-01,.2552100E-01,.3106800E-01,.3588200E-01,& + & .3958900E-01,.4113200E-01,.3368400E-01,.1756100E-03,.1255800E-01,& + & .2040900E-01,.2703300E-01,.3305600E-01,.3826000E-01,.4215500E-01,& + & .4363900E-01,.3517500E-01,.1996700E-03,.1323600E-01,.2162800E-01,& + & .2855400E-01,.3493900E-01,.4045900E-01,.4455000E-01,.4614700E-01,& + & .3664300E-01,.2311700E-03,.1393600E-01,.2283600E-01,.3018300E-01,& + & .3690900E-01,.4265200E-01,.4686400E-01,.4844000E-01,.3799200E-01,& + & .1198700E-03,.9398300E-02,.1513000E-01,.1980800E-01,.2379600E-01,& + & .2728500E-01,.3017600E-01,.3190600E-01,.2619300E-01,.1316400E-03,& + & .9974300E-02,.1611800E-01,.2131900E-01,.2560000E-01,.2940400E-01,& + & .3248500E-01,.3390900E-01,.2743900E-01,.1486200E-03,.1055900E-01,& + & .1712400E-01,.2267400E-01,.2737300E-01,.3150100E-01,.3470500E-01,& + & .3611200E-01,.2866700E-01,.1694100E-03,.1114200E-01,.1816300E-01,& + & .2399200E-01,.2902300E-01,.3346100E-01,.3688200E-01,.3828800E-01,& + & .2999000E-01,.1944400E-03,.1174000E-01,.1923100E-01,.2541000E-01,& + & .3070200E-01,.3538000E-01,.3893300E-01,.4032500E-01,.3116300E-01/ + + data absa(316:450, 4) / & + & .1026600E-03,.7813200E-02,.1249500E-01,.1629400E-01,.1955200E-01,& + & .2220300E-01,.2452200E-01,.2615800E-01,.2147700E-01,.1130800E-03,& + & .8299600E-02,.1338500E-01,.1765000E-01,.2111300E-01,.2402600E-01,& + & .2642400E-01,.2777900E-01,.2266100E-01,.1243100E-03,.8811800E-02,& + & .1425400E-01,.1885200E-01,.2271700E-01,.2582200E-01,.2835200E-01,& + & .2966700E-01,.2367400E-01,.1414600E-03,.9308000E-02,.1515200E-01,& + & .2001300E-01,.2415800E-01,.2756900E-01,.3030600E-01,.3149500E-01,& + & .2483800E-01,.1627500E-03,.9828700E-02,.1608000E-01,.2122700E-01,& + & .2559200E-01,.2922600E-01,.3207500E-01,.3335700E-01,.2588700E-01,& + & .8579700E-04,.6441200E-02,.1023100E-01,.1332700E-01,.1592300E-01,& + & .1810300E-01,.1990300E-01,.2118900E-01,.1797500E-01,.9437000E-04,& + & .6851400E-02,.1104100E-01,.1447200E-01,.1729800E-01,.1966100E-01,& + & .2142100E-01,.2263100E-01,.1899000E-01,.1060300E-03,.7287000E-02,& + & .1178600E-01,.1557000E-01,.1871000E-01,.2119500E-01,.2309200E-01,& + & .2415700E-01,.1993400E-01,.1181900E-03,.7721700E-02,.1255900E-01,& + & .1658900E-01,.1999100E-01,.2273800E-01,.2476900E-01,.2577100E-01,& + & .2094600E-01,.1350000E-03,.8162400E-02,.1334600E-01,.1761000E-01,& + & .2122700E-01,.2414000E-01,.2633900E-01,.2738800E-01,.2181900E-01,& + & .7327500E-04,.5314700E-02,.8383200E-02,.1089000E-01,.1299800E-01,& + & .1477200E-01,.1623700E-01,.1716500E-01,.1597200E-01,.8030300E-04,& + & .5659400E-02,.9096400E-02,.1186900E-01,.1418100E-01,.1606500E-01,& + & .1749300E-01,.1844700E-01,.1707500E-01,.8882100E-04,.6028600E-02,& + & .9749100E-02,.1285200E-01,.1538700E-01,.1739400E-01,.1890900E-01,& + & .1970800E-01,.1807800E-01,.1014200E-03,.6396200E-02,.1039200E-01,& + & .1373000E-01,.1652200E-01,.1877100E-01,.2030800E-01,.2109600E-01,& + & .1903700E-01,.1140500E-03,.6775400E-02,.1106500E-01,.1460500E-01,& + & .1758100E-01,.1999100E-01,.2168700E-01,.2245800E-01,.1987500E-01/ + + data absa(451:585, 4) / & + & .6451700E-04,.4513500E-02,.7116500E-02,.9238400E-02,.1099800E-01,& + & .1247400E-01,.1370000E-01,.1438800E-01,.1463100E-01,.7153500E-04,& + & .4807000E-02,.7713700E-02,.1009200E-01,.1202300E-01,.1362300E-01,& + & .1479200E-01,.1544900E-01,.1548100E-01,.7950400E-04,.5119900E-02,& + & .8260000E-02,.1091100E-01,.1307600E-01,.1475500E-01,.1600200E-01,& + & .1654600E-01,.1629800E-01,.9043300E-04,.5435100E-02,.8810100E-02,& + & .1164700E-01,.1401800E-01,.1592200E-01,.1720600E-01,.1771500E-01,& + & .1699100E-01,.1014600E-03,.5759600E-02,.9386500E-02,.1240700E-01,& + & .1492200E-01,.1695100E-01,.1838400E-01,.1889300E-01,.1766600E-01,& + & .5691300E-04,.3836100E-02,.6023800E-02,.7810100E-02,.9294300E-02,& + & .1051500E-01,.1151400E-01,.1205100E-01,.1270800E-01,.6298400E-04,& + & .4088600E-02,.6515300E-02,.8546400E-02,.1016800E-01,.1149800E-01,& + & .1245200E-01,.1293800E-01,.1347300E-01,.7058800E-04,.4356100E-02,& + & .6976100E-02,.9213700E-02,.1106800E-01,.1248200E-01,.1349700E-01,& + & .1389200E-01,.1409000E-01,.7955600E-04,.4622200E-02,.7447200E-02,& + & .9838200E-02,.1185200E-01,.1346100E-01,.1453900E-01,.1486800E-01,& + & .1468400E-01,.8933000E-04,.4903700E-02,.7933200E-02,.1049200E-01,& + & .1261300E-01,.1433100E-01,.1552300E-01,.1586700E-01,.1526600E-01,& + & .4904000E-04,.3247000E-02,.5078200E-02,.6581300E-02,.7825400E-02,& + & .8839800E-02,.9648300E-02,.1009000E-01,.1061400E-01,.5422500E-04,& + & .3461600E-02,.5490600E-02,.7195100E-02,.8571100E-02,.9678100E-02,& + & .1046000E-01,.1084000E-01,.1120600E-01,.6113600E-04,.3687800E-02,& + & .5877700E-02,.7745800E-02,.9318300E-02,.1052800E-01,.1134700E-01,& + & .1168400E-01,.1173000E-01,.6878800E-04,.3921300E-02,.6279100E-02,& + & .8277400E-02,.9976100E-02,.1133200E-01,.1224700E-01,.1249500E-01,& + & .1225000E-01,.7742700E-04,.4164000E-02,.6689000E-02,.8835800E-02,& + & .1062400E-01,.1206900E-01,.1306400E-01,.1334100E-01,.1273000E-01/ + + data absa( 1:180, 5) / & + & .6909800E-02,.8465000E-01,.1300600E+00,.1665200E+00,.1960800E+00,& + & .2197500E+00,.2349600E+00,.2327700E+00,.1800700E+00,.7820000E-02,& + & .8927900E-01,.1363000E+00,.1740900E+00,.2039800E+00,.2271800E+00,& + & .2412900E+00,.2375000E+00,.1843800E+00,.8978700E-02,.9442800E-01,& + & .1429600E+00,.1817000E+00,.2120500E+00,.2345000E+00,.2472600E+00,& + & .2417200E+00,.1887800E+00,.1042600E-01,.1000300E+00,.1500900E+00,& + & .1894300E+00,.2201500E+00,.2420600E+00,.2534100E+00,.2457100E+00,& + & .1932500E+00,.1220900E-01,.1060300E+00,.1578100E+00,.1975600E+00,& + & .2283200E+00,.2496300E+00,.2595700E+00,.2495800E+00,.1974800E+00,& + & .6402000E-02,.7459700E-01,.1145800E+00,.1458100E+00,.1710300E+00,& + & .1910500E+00,.2041200E+00,.2013300E+00,.1524200E+00,.7258600E-02,& + & .7885700E-01,.1202400E+00,.1525700E+00,.1779600E+00,.1976500E+00,& + & .2097200E+00,.2054800E+00,.1562000E+00,.8290300E-02,.8360200E-01,& + & .1262300E+00,.1593100E+00,.1851200E+00,.2042300E+00,.2150300E+00,& + & .2093700E+00,.1599300E+00,.9457800E-02,.8866800E-01,.1327700E+00,& + & .1663500E+00,.1923300E+00,.2109800E+00,.2205000E+00,.2129400E+00,& + & .1639700E+00,.1086500E-01,.9411300E-01,.1398700E+00,.1737500E+00,& + & .1997500E+00,.2177100E+00,.2259200E+00,.2163900E+00,.1674500E+00,& + & .5694300E-02,.6408400E-01,.9929400E-01,.1261400E+00,.1474600E+00,& + & .1641400E+00,.1750300E+00,.1725500E+00,.1273800E+00,.6470200E-02,& + & .6796700E-01,.1042700E+00,.1319700E+00,.1535000E+00,.1698500E+00,& + & .1800800E+00,.1763100E+00,.1308700E+00,.7420000E-02,.7225200E-01,& + & .1095600E+00,.1380100E+00,.1597800E+00,.1756700E+00,.1847600E+00,& + & .1797700E+00,.1342100E+00,.8490700E-02,.7677200E-01,.1153900E+00,& + & .1442700E+00,.1661500E+00,.1816800E+00,.1894700E+00,.1830000E+00,& + & .1376100E+00,.9707800E-02,.8167100E-01,.1217200E+00,.1508200E+00,& + & .1727700E+00,.1876900E+00,.1942700E+00,.1860800E+00,.1406700E+00,& + & .4882900E-02,.5438300E-01,.8507500E-01,.1081500E+00,.1263800E+00,& + & .1402000E+00,.1490300E+00,.1467000E+00,.1061400E+00,.5574000E-02,& + & .5777900E-01,.8943600E-01,.1132300E+00,.1316000E+00,.1451400E+00,& + & .1534900E+00,.1502700E+00,.1094900E+00,.6401500E-02,.6154600E-01,& + & .9413900E-01,.1185000E+00,.1370100E+00,.1501700E+00,.1575700E+00,& + & .1534400E+00,.1125700E+00,.7371900E-02,.6552100E-01,.9923200E-01,& + & .1240300E+00,.1425900E+00,.1554100E+00,.1617500E+00,.1563400E+00,& + & .1155700E+00,.8478900E-02,.6981000E-01,.1047800E+00,.1298500E+00,& + & .1484000E+00,.1607100E+00,.1659700E+00,.1591000E+00,.1183300E+00/ + + data absa(181:315, 5) / & + & .4135700E-02,.4587800E-01,.7186600E-01,.9213000E-01,.1077200E+00,& + & .1193500E+00,.1262700E+00,.1238200E+00,.8849000E-01,.4727800E-02,& + & .4880900E-01,.7572400E-01,.9648500E-01,.1121800E+00,.1236300E+00,& + & .1302300E+00,.1272300E+00,.9164600E-01,.5423400E-02,.5210800E-01,& + & .7992500E-01,.1010500E+00,.1168400E+00,.1279500E+00,.1338900E+00,& + & .1302400E+00,.9438400E-01,.6267200E-02,.5564700E-01,.8443800E-01,& + & .1059100E+00,.1216700E+00,.1325500E+00,.1375900E+00,.1328800E+00,& + & .9703700E-01,.7238700E-02,.5939300E-01,.8932600E-01,.1110200E+00,& + & .1268000E+00,.1372300E+00,.1412800E+00,.1353000E+00,.9958500E-01,& + & .3482000E-02,.3845500E-01,.6010600E-01,.7751500E-01,.9114300E-01,& + & .1009400E+00,.1064900E+00,.1040300E+00,.7350900E-01,.3950700E-02,& + & .4092700E-01,.6340200E-01,.8124000E-01,.9496800E-01,.1046900E+00,& + & .1100100E+00,.1071700E+00,.7642600E-01,.4526600E-02,.4372600E-01,& + & .6704100E-01,.8523400E-01,.9891100E-01,.1084500E+00,.1132900E+00,& + & .1099600E+00,.7886100E-01,.5224200E-02,.4680700E-01,.7093900E-01,& + & .8954700E-01,.1031200E+00,.1124700E+00,.1165300E+00,.1123700E+00,& + & .8125000E-01,.6044900E-02,.5008300E-01,.7517500E-01,.9404100E-01,& + & .1076000E+00,.1165700E+00,.1198000E+00,.1144900E+00,.8354900E-01,& + & .2871100E-02,.3252300E-01,.4997100E-01,.6459700E-01,.7636000E-01,& + & .8491800E-01,.8952300E-01,.8720000E-01,.6061800E-01,.3255000E-02,& + & .3461400E-01,.5280300E-01,.6774000E-01,.7971300E-01,.8820700E-01,& + & .9268100E-01,.9006000E-01,.6333100E-01,.3726300E-02,.3696800E-01,& + & .5590400E-01,.7115300E-01,.8314300E-01,.9150900E-01,.9560700E-01,& + & .9256400E-01,.6559500E-01,.4295300E-02,.3953800E-01,.5928100E-01,& + & .7491200E-01,.8682200E-01,.9495600E-01,.9843800E-01,.9472800E-01,& + & .6768000E-01,.4978800E-02,.4226400E-01,.6295300E-01,.7884200E-01,& + & .9074200E-01,.9851000E-01,.1012900E+00,.9664100E-01,.6974600E-01/ + + data absa(316:450, 5) / & + & .2348000E-02,.2723000E-01,.4167100E-01,.5356500E-01,.6343600E-01,& + & .7099900E-01,.7502000E-01,.7290600E-01,.4938600E-01,.2651700E-02,& + & .2906500E-01,.4401700E-01,.5622500E-01,.6634100E-01,.7393500E-01,& + & .7787900E-01,.7546800E-01,.5175000E-01,.3028500E-02,.3111200E-01,& + & .4659800E-01,.5916100E-01,.6930200E-01,.7680900E-01,.8043900E-01,& + & .7772900E-01,.5390400E-01,.3481600E-02,.3334800E-01,.4944800E-01,& + & .6238000E-01,.7250200E-01,.7978600E-01,.8288700E-01,.7968300E-01,& + & .5573100E-01,.4044400E-02,.3573000E-01,.5254500E-01,.6579400E-01,& + & .7587800E-01,.8288900E-01,.8537900E-01,.8139100E-01,.5750900E-01,& + & .1924700E-02,.2263000E-01,.3475200E-01,.4438700E-01,.5245500E-01,& + & .5883300E-01,.6246800E-01,.6071900E-01,.4188000E-01,.2155700E-02,& + & .2420400E-01,.3675000E-01,.4663600E-01,.5497600E-01,.6142100E-01,& + & .6505200E-01,.6299400E-01,.4401000E-01,.2447700E-02,.2595800E-01,& + & .3898100E-01,.4910800E-01,.5752600E-01,.6390700E-01,.6735100E-01,& + & .6503800E-01,.4592900E-01,.2819600E-02,.2788200E-01,.4143100E-01,& + & .5180200E-01,.6024900E-01,.6648000E-01,.6946700E-01,.6678800E-01,& + & .4755500E-01,.3265400E-02,.2993900E-01,.4407200E-01,.5471400E-01,& + & .6316300E-01,.6920700E-01,.7160000E-01,.6832800E-01,.4907700E-01,& + & .1620000E-02,.1881400E-01,.2891100E-01,.3702500E-01,.4347900E-01,& + & .4869100E-01,.5176700E-01,.5051700E-01,.3656500E-01,.1803100E-02,& + & .2015000E-01,.3063200E-01,.3896700E-01,.4560900E-01,.5094000E-01,& + & .5404600E-01,.5251500E-01,.3842500E-01,.2023200E-02,.2164000E-01,& + & .3257200E-01,.4107900E-01,.4778800E-01,.5310100E-01,.5611400E-01,& + & .5433800E-01,.4016200E-01,.2303800E-02,.2329800E-01,.3470300E-01,& + & .4339300E-01,.5011000E-01,.5529800E-01,.5798200E-01,.5587300E-01,& + & .4178200E-01,.2664900E-02,.2507300E-01,.3698300E-01,.4586800E-01,& + & .5261700E-01,.5764100E-01,.5983300E-01,.5722200E-01,.4324300E-01/ + + data absa(451:585, 5) / & + & .1424100E-02,.1606500E-01,.2458600E-01,.3146500E-01,.3696300E-01,& + & .4109300E-01,.4361700E-01,.4267300E-01,.3234300E-01,.1587800E-02,& + & .1726800E-01,.2614400E-01,.3316900E-01,.3881600E-01,.4298800E-01,& + & .4554600E-01,.4432700E-01,.3405400E-01,.1800300E-02,.1860900E-01,& + & .2788800E-01,.3506600E-01,.4071700E-01,.4486100E-01,.4727700E-01,& + & .4584500E-01,.3556200E-01,.2051300E-02,.2006900E-01,.2979400E-01,& + & .3714700E-01,.4278100E-01,.4677400E-01,.4886900E-01,.4710600E-01,& + & .3688100E-01,.2361000E-02,.2163600E-01,.3178600E-01,.3934100E-01,& + & .4496400E-01,.4883200E-01,.5047800E-01,.4823700E-01,.3813600E-01,& + & .1236700E-02,.1366400E-01,.2084100E-01,.2661900E-01,.3125800E-01,& + & .3476600E-01,.3666500E-01,.3587300E-01,.2781100E-01,.1389800E-02,& + & .1474700E-01,.2223800E-01,.2813400E-01,.3287600E-01,.3639200E-01,& + & .3828600E-01,.3725700E-01,.2921200E-01,.1582200E-02,.1592000E-01,& + & .2380800E-01,.2983000E-01,.3455800E-01,.3801400E-01,.3972800E-01,& + & .3849300E-01,.3051700E-01,.1811700E-02,.1719500E-01,.2547900E-01,& + & .3166400E-01,.3637800E-01,.3967500E-01,.4109800E-01,.3955300E-01,& + & .3170500E-01,.2099600E-02,.1856700E-01,.2722500E-01,.3357100E-01,& + & .3830200E-01,.4143700E-01,.4250100E-01,.4052500E-01,.3274800E-01,& + & .1060600E-02,.1159400E-01,.1761600E-01,.2245600E-01,.2633700E-01,& + & .2928200E-01,.3083100E-01,.3003700E-01,.2325100E-01,.1197500E-02,& + & .1254100E-01,.1885000E-01,.2379500E-01,.2774500E-01,.3067600E-01,& + & .3219100E-01,.3118600E-01,.2446100E-01,.1368600E-02,.1355700E-01,& + & .2023600E-01,.2528700E-01,.2922400E-01,.3208500E-01,.3341100E-01,& + & .3219000E-01,.2553900E-01,.1578700E-02,.1465500E-01,.2168500E-01,& + & .2688700E-01,.3082100E-01,.3353300E-01,.3458100E-01,.3309100E-01,& + & .2648300E-01,.1842200E-02,.1584700E-01,.2320100E-01,.2853500E-01,& + & .3248600E-01,.3505900E-01,.3579100E-01,.3394200E-01,.2734000E-01/ + + data absa( 1:180, 6) / & + & .3839378E+00,.6279180E+00,.7318272E+00,.7920608E+00,.8216785E+00,& + & .8230008E+00,.7947126E+00,.7302326E+00,.5811177E+00,.4128871E+00,& + & .6485557E+00,.7485293E+00,.8043995E+00,.8308183E+00,.8293298E+00,& + & .7988096E+00,.7334673E+00,.5866991E+00,.4408435E+00,.6690805E+00,& + & .7652913E+00,.8177871E+00,.8406473E+00,.8361296E+00,.8033672E+00,& + & .7370020E+00,.5912609E+00,.4672892E+00,.6894163E+00,.7820258E+00,& + & .8313814E+00,.8509556E+00,.8436351E+00,.8085369E+00,.7402632E+00,& + & .5956103E+00,.4927709E+00,.7092005E+00,.7986459E+00,.8452246E+00,& + & .8615155E+00,.8516325E+00,.8138231E+00,.7437317E+00,.5997054E+00,& + & .3325679E+00,.5548358E+00,.6461479E+00,.6995525E+00,.7253118E+00,& + & .7266814E+00,.7024839E+00,.6480527E+00,.5065275E+00,.3575484E+00,& + & .5737759E+00,.6620339E+00,.7123154E+00,.7348811E+00,.7336335E+00,& + & .7074669E+00,.6519501E+00,.5119171E+00,.3814205E+00,.5923353E+00,& + & .6775822E+00,.7253565E+00,.7450096E+00,.7412995E+00,.7131653E+00,& + & .6558395E+00,.5167702E+00,.4042236E+00,.6103975E+00,.6930426E+00,& + & .7383493E+00,.7554787E+00,.7494988E+00,.7190075E+00,.6598135E+00,& + & .5211434E+00,.4265822E+00,.6282698E+00,.7082747E+00,.7513798E+00,& + & .7663755E+00,.7576413E+00,.7252801E+00,.6640475E+00,.5252205E+00,& + & .2819028E+00,.4836690E+00,.5649400E+00,.6121709E+00,.6347883E+00,& + & .6367827E+00,.6170448E+00,.5707116E+00,.4371090E+00,.3032609E+00,& + & .5006309E+00,.5795105E+00,.6243936E+00,.6444057E+00,.6442898E+00,& + & .6228572E+00,.5750819E+00,.4422485E+00,.3236861E+00,.5170268E+00,& + & .5937689E+00,.6365222E+00,.6544181E+00,.6524051E+00,.6289736E+00,& + & .5795020E+00,.4469729E+00,.3434421E+00,.5330792E+00,.6078864E+00,& + & .6485227E+00,.6647491E+00,.6605735E+00,.6354043E+00,.5840256E+00,& + & .4512681E+00,.3630007E+00,.5490413E+00,.6217655E+00,.6606764E+00,& + & .6752251E+00,.6688803E+00,.6420320E+00,.5886154E+00,.4550732E+00,& + & .2364425E+00,.4182373E+00,.4906262E+00,.5320011E+00,.5523509E+00,& + & .5548703E+00,.5383899E+00,.4987899E+00,.3768887E+00,.2546801E+00,& + & .4331987E+00,.5037554E+00,.5432869E+00,.5616903E+00,.5626459E+00,& + & .5445887E+00,.5034773E+00,.3818393E+00,.2721315E+00,.4476600E+00,& + & .5164741E+00,.5543752E+00,.5713544E+00,.5708581E+00,.5510757E+00,& + & .5081946E+00,.3862452E+00,.2892043E+00,.4618692E+00,.5290503E+00,& + & .5654304E+00,.5811711E+00,.5789470E+00,.5577046E+00,.5130234E+00,& + & .3902090E+00,.3062774E+00,.4761272E+00,.5414198E+00,.5765335E+00,& + & .5909044E+00,.5871126E+00,.5644694E+00,.5178294E+00,.3937875E+00/ + + data absa(181:315, 6) / & + & .1976097E+00,.3599556E+00,.4238261E+00,.4601500E+00,.4784937E+00,& + & .4808783E+00,.4668807E+00,.4328773E+00,.3243113E+00,.2131404E+00,& + & .3730680E+00,.4353477E+00,.4703740E+00,.4874113E+00,.4885689E+00,& + & .4731711E+00,.4377759E+00,.3288869E+00,.2280961E+00,.3857179E+00,& + & .4465292E+00,.4804726E+00,.4964950E+00,.4964579E+00,.4796823E+00,& + & .4426578E+00,.3330323E+00,.2427415E+00,.3981437E+00,.4574729E+00,& + & .4906220E+00,.5055377E+00,.5041976E+00,.4863363E+00,.4474608E+00,& + & .3367502E+00,.2574916E+00,.4108035E+00,.4685214E+00,.5005586E+00,& + & .5144711E+00,.5119125E+00,.4929884E+00,.4523415E+00,.3400646E+00,& + & .1644599E+00,.3082155E+00,.3641066E+00,.3958133E+00,.4120577E+00,& + & .4144583E+00,.4024002E+00,.3731548E+00,.2772332E+00,.1776815E+00,& + & .3195976E+00,.3741572E+00,.4049902E+00,.4203131E+00,.4217397E+00,& + & .4086238E+00,.3780822E+00,.2815278E+00,.1904154E+00,.3305911E+00,& + & .3838882E+00,.4140681E+00,.4286082E+00,.4290731E+00,.4150352E+00,& + & .3829532E+00,.2854673E+00,.2029594E+00,.3414094E+00,.3935449E+00,& + & .4230885E+00,.4367885E+00,.4362952E+00,.4213065E+00,.3877874E+00,& + & .2889571E+00,.2156141E+00,.3525176E+00,.4033758E+00,.4319990E+00,& + & .4448634E+00,.4434057E+00,.4275549E+00,.3926902E+00,.2921021E+00,& + & .1365354E+00,.2627938E+00,.3116032E+00,.3390470E+00,.3531982E+00,& + & .3553931E+00,.3450681E+00,.3195057E+00,.2355642E+00,.1476945E+00,& + & .2725931E+00,.3203697E+00,.3471668E+00,.3606270E+00,.3621563E+00,& + & .3510351E+00,.3243608E+00,.2395644E+00,.1584917E+00,.2820807E+00,& + & .3288732E+00,.3551503E+00,.3679817E+00,.3688657E+00,.3570843E+00,& + & .3290971E+00,.2432894E+00,.1692002E+00,.2914586E+00,.3373668E+00,& + & .3630273E+00,.3752511E+00,.3754063E+00,.3629045E+00,.3338612E+00,& + & .2465948E+00,.1800234E+00,.3011255E+00,.3460817E+00,.3709814E+00,& + & .3824342E+00,.3817964E+00,.3686830E+00,.3386098E+00,.2495277E+00/ + + data absa(316:450, 6) / & + & .1130524E+00,.2235733E+00,.2655973E+00,.2894880E+00,.3015165E+00,& + & .3032589E+00,.2943333E+00,.2719817E+00,.1988483E+00,.1224152E+00,& + & .2318861E+00,.2733317E+00,.2965534E+00,.3081331E+00,.3094246E+00,& + & .2999446E+00,.2766238E+00,.2026511E+00,.1315214E+00,.2399609E+00,& + & .2807287E+00,.3034743E+00,.3145900E+00,.3154081E+00,.3054644E+00,& + & .2811905E+00,.2060707E+00,.1406060E+00,.2479709E+00,.2881554E+00,& + & .3103325E+00,.3209441E+00,.3212333E+00,.3107742E+00,.2857474E+00,& + & .2091635E+00,.1498138E+00,.2563308E+00,.2958019E+00,.3173622E+00,& + & .3271974E+00,.3269371E+00,.3159983E+00,.2902250E+00,.2119359E+00,& + & .9301188E-01,.1895129E+00,.2254431E+00,.2461449E+00,.2564128E+00,& + & .2576877E+00,.2498578E+00,.2303767E+00,.1659328E+00,.1009065E+00,& + & .1965526E+00,.2321100E+00,.2522877E+00,.2622065E+00,.2632244E+00,& + & .2549826E+00,.2347053E+00,.1694537E+00,.1085578E+00,.2034287E+00,& + & .2384465E+00,.2583058E+00,.2678405E+00,.2684545E+00,.2599040E+00,& + & .2390279E+00,.1725782E+00,.1162137E+00,.2102907E+00,.2448387E+00,& + & .2642935E+00,.2733148E+00,.2735764E+00,.2646745E+00,.2432888E+00,& + & .1754745E+00,.1240561E+00,.2175246E+00,.2515388E+00,.2703899E+00,& + & .2788204E+00,.2785885E+00,.2693407E+00,.2473703E+00,.1781073E+00,& + & .7640796E-01,.1603808E+00,.1911818E+00,.2086778E+00,.2175552E+00,& + & .2186307E+00,.2116034E+00,.1944515E+00,.1456540E+00,.8306947E-01,& + & .1663339E+00,.1968047E+00,.2139806E+00,.2226600E+00,.2234720E+00,& + & .2162217E+00,.1984391E+00,.1487611E+00,.8952871E-01,.1721996E+00,& + & .2022331E+00,.2191642E+00,.2275327E+00,.2280233E+00,.2205353E+00,& + & .2024797E+00,.1513787E+00,.9600912E-01,.1780570E+00,.2077289E+00,& + & .2243376E+00,.2322476E+00,.2324865E+00,.2247285E+00,.2063451E+00,& + & .1537312E+00,.1026970E+00,.1842930E+00,.2135640E+00,.2296382E+00,& + & .2370510E+00,.2368348E+00,.2288014E+00,.2100442E+00,.1559266E+00/ + + data absa(451:585, 6) / & + & .6498651E-01,.1372893E+00,.1636307E+00,.1784508E+00,.1858229E+00,& + & .1867364E+00,.1805030E+00,.1651282E+00,.1253243E+00,.7051877E-01,& + & .1422924E+00,.1682882E+00,.1829691E+00,.1901293E+00,.1907854E+00,& + & .1844056E+00,.1688531E+00,.1278858E+00,.7594246E-01,.1472381E+00,& + & .1729539E+00,.1873767E+00,.1942330E+00,.1947083E+00,.1880933E+00,& + & .1724213E+00,.1301325E+00,.8152013E-01,.1524039E+00,.1778017E+00,& + & .1918315E+00,.1983471E+00,.1985237E+00,.1916908E+00,.1757953E+00,& + & .1322663E+00,.8732427E-01,.1579555E+00,.1829727E+00,.1965737E+00,& + & .2026361E+00,.2023437E+00,.1952484E+00,.1791155E+00,.1342170E+00,& + & .5506321E-01,.1168681E+00,.1392111E+00,.1518638E+00,.1581057E+00,& + & .1587078E+00,.1534476E+00,.1400850E+00,.1080712E+00,.5967938E-01,& + & .1210769E+00,.1431802E+00,.1556769E+00,.1617277E+00,.1621446E+00,& + & .1567559E+00,.1434036E+00,.1102933E+00,.6432180E-01,.1253570E+00,& + & .1472032E+00,.1594570E+00,.1652341E+00,.1654796E+00,.1599072E+00,& + & .1464712E+00,.1123711E+00,.6912124E-01,.1299527E+00,.1515000E+00,& + & .1634309E+00,.1688516E+00,.1687937E+00,.1630152E+00,.1494484E+00,& + & .1143749E+00,.7411322E-01,.1349524E+00,.1561843E+00,.1676813E+00,& + & .1726787E+00,.1722628E+00,.1662240E+00,.1523717E+00,.1162707E+00,& + & .4671501E-01,.9906607E-01,.1179218E+00,.1285633E+00,.1338684E+00,& + & .1344469E+00,.1299950E+00,.1186902E+00,.9160652E-01,.5062345E-01,& + & .1026419E+00,.1213067E+00,.1318081E+00,.1369356E+00,.1373840E+00,& + & .1328006E+00,.1215065E+00,.9359446E-01,.5459974E-01,.1064175E+00,& + & .1248279E+00,.1351247E+00,.1399943E+00,.1402452E+00,.1355160E+00,& + & .1241771E+00,.9556170E-01,.5873868E-01,.1105265E+00,.1286741E+00,& + & .1386392E+00,.1431974E+00,.1431960E+00,.1382828E+00,.1267833E+00,& + & .9738167E-01,.6302475E-01,.1149971E+00,.1329313E+00,.1425338E+00,& + & .1467358E+00,.1463643E+00,.1411782E+00,.1293360E+00,.9929140E-01/ + + data absa( 1:180, 7) / & + & .2084400E+01,.2334400E+01,.2557600E+01,.2670100E+01,.2701000E+01,& + & .2668100E+01,.2568300E+01,.2365500E+01,.2081000E+01,.2080700E+01,& + & .2330400E+01,.2548900E+01,.2661100E+01,.2692000E+01,.2660900E+01,& + & .2564700E+01,.2364500E+01,.2085900E+01,.2087700E+01,.2334200E+01,& + & .2547700E+01,.2654800E+01,.2684300E+01,.2654100E+01,.2560500E+01,& + & .2363700E+01,.2090300E+01,.2105200E+01,.2345400E+01,.2552000E+01,& + & .2652900E+01,.2677800E+01,.2647800E+01,.2556500E+01,.2363000E+01,& + & .2093500E+01,.2130300E+01,.2363300E+01,.2561900E+01,.2654600E+01,& + & .2674900E+01,.2642900E+01,.2554200E+01,.2361900E+01,.2095800E+01,& + & .1812000E+01,.2110100E+01,.2320400E+01,.2426600E+01,.2465700E+01,& + & .2446900E+01,.2370200E+01,.2193100E+01,.1866900E+01,.1818700E+01,& + & .2113700E+01,.2318800E+01,.2422300E+01,.2462000E+01,.2443600E+01,& + & .2368700E+01,.2194400E+01,.1872600E+01,.1835600E+01,.2125500E+01,& + & .2325600E+01,.2423200E+01,.2459000E+01,.2440700E+01,.2367400E+01,& + & .2196000E+01,.1877600E+01,.1861400E+01,.2144700E+01,.2338600E+01,& + & .2428700E+01,.2459500E+01,.2438700E+01,.2367200E+01,.2197000E+01,& + & .1881600E+01,.1892700E+01,.2168300E+01,.2357900E+01,.2439200E+01,& + & .2463600E+01,.2440700E+01,.2366500E+01,.2197400E+01,.1886400E+01,& + & .1570200E+01,.1894200E+01,.2083700E+01,.2185400E+01,.2232400E+01,& + & .2226600E+01,.2164900E+01,.2013400E+01,.1661700E+01,.1582700E+01,& + & .1903800E+01,.2088600E+01,.2186500E+01,.2232900E+01,.2226600E+01,& + & .2164900E+01,.2016700E+01,.1669500E+01,.1604600E+01,.1921300E+01,& + & .2101900E+01,.2194200E+01,.2236000E+01,.2227100E+01,.2166500E+01,& + & .2019500E+01,.1676200E+01,.1632900E+01,.1944300E+01,.2121300E+01,& + & .2207000E+01,.2242400E+01,.2231100E+01,.2168300E+01,.2021400E+01,& + & .1683000E+01,.1665800E+01,.1971700E+01,.2145200E+01,.2225100E+01,& + & .2253000E+01,.2237100E+01,.2170800E+01,.2023800E+01,.1690400E+01,& + & .1356400E+01,.1686900E+01,.1855000E+01,.1953700E+01,.2004900E+01,& + & .2008500E+01,.1960100E+01,.1828700E+01,.1475600E+01,.1372000E+01,& + & .1700000E+01,.1865500E+01,.1960700E+01,.2010000E+01,.2010500E+01,& + & .1962200E+01,.1833900E+01,.1485400E+01,.1395200E+01,.1720400E+01,& + & .1883700E+01,.1974000E+01,.2018200E+01,.2015400E+01,.1965400E+01,& + & .1838400E+01,.1494800E+01,.1422900E+01,.1746100E+01,.1907200E+01,& + & .1992600E+01,.2030300E+01,.2023400E+01,.1969100E+01,.1842000E+01,& + & .1504000E+01,.1453400E+01,.1775100E+01,.1934500E+01,.2015400E+01,& + & .2046700E+01,.2033700E+01,.1974200E+01,.1846500E+01,.1513100E+01/ + + data absa(181:315, 7) / & + & .1167500E+01,.1490600E+01,.1642200E+01,.1736400E+01,.1787500E+01,& + & .1797000E+01,.1758200E+01,.1645900E+01,.1305700E+01,.1183900E+01,& + & .1506200E+01,.1657300E+01,.1748300E+01,.1795600E+01,.1802000E+01,& + & .1762300E+01,.1652900E+01,.1317600E+01,.1206100E+01,.1528100E+01,& + & .1679000E+01,.1766000E+01,.1808200E+01,.1810600E+01,.1767800E+01,& + & .1658700E+01,.1328900E+01,.1231100E+01,.1554900E+01,.1704800E+01,& + & .1787700E+01,.1825000E+01,.1822200E+01,.1774200E+01,.1664400E+01,& + & .1339800E+01,.1258200E+01,.1583600E+01,.1733800E+01,.1813100E+01,& + & .1845700E+01,.1835900E+01,.1782600E+01,.1671000E+01,.1350700E+01,& + & .9998100E+00,.1308000E+01,.1447700E+01,.1535600E+01,.1582900E+01,& + & .1593600E+01,.1563600E+01,.1468300E+01,.1148200E+01,.1015100E+01,& + & .1325100E+01,.1465500E+01,.1550400E+01,.1594100E+01,.1601500E+01,& + & .1569800E+01,.1476700E+01,.1161900E+01,.1034400E+01,.1347600E+01,& + & .1488700E+01,.1570200E+01,.1609700E+01,.1613000E+01,.1577200E+01,& + & .1484700E+01,.1174300E+01,.1056000E+01,.1373500E+01,.1515500E+01,& + & .1593900E+01,.1629300E+01,.1627600E+01,.1587000E+01,.1492400E+01,& + & .1186400E+01,.1079400E+01,.1399600E+01,.1543800E+01,.1620500E+01,& + & .1652100E+01,.1645100E+01,.1599100E+01,.1500300E+01,.1198200E+01,& + & .8523900E+00,.1141900E+01,.1271400E+01,.1350700E+01,.1393000E+01,& + & .1403900E+01,.1379000E+01,.1297100E+01,.1003400E+01,.8654200E+00,& + & .1159100E+01,.1289800E+01,.1367000E+01,.1406200E+01,.1413900E+01,& + & .1387100E+01,.1307200E+01,.1017900E+01,.8810800E+00,.1180900E+01,& + & .1313000E+01,.1388000E+01,.1424100E+01,.1427800E+01,.1397500E+01,& + & .1317200E+01,.1031000E+01,.8990000E+00,.1204100E+01,.1339000E+01,& + & .1412300E+01,.1445500E+01,.1445300E+01,.1410500E+01,.1326600E+01,& + & .1043400E+01,.9186200E+00,.1227900E+01,.1364900E+01,.1438600E+01,& + & .1469200E+01,.1466400E+01,.1425400E+01,.1336700E+01,.1055800E+01/ + + data absa(316:450, 7) / & + & .7249700E+00,.9920100E+00,.1110700E+01,.1181300E+01,.1219500E+01,& + & .1228500E+01,.1205800E+01,.1135900E+01,.8711000E+00,.7351700E+00,& + & .1008600E+01,.1128500E+01,.1198800E+01,.1234200E+01,.1240500E+01,& + & .1216000E+01,.1147900E+01,.8856800E+00,.7475200E+00,.1028500E+01,& + & .1150700E+01,.1219800E+01,.1253200E+01,.1257000E+01,.1228900E+01,& + & .1158900E+01,.8992700E+00,.7621300E+00,.1048900E+01,.1174700E+01,& + & .1243600E+01,.1275700E+01,.1276900E+01,.1244500E+01,.1170000E+01,& + & .9120300E+00,.7785400E+00,.1069700E+01,.1198000E+01,.1267900E+01,& + & .1300200E+01,.1299400E+01,.1262100E+01,.1181600E+01,.9239200E+00,& + & .6168200E+00,.8584100E+00,.9640300E+00,.1027200E+01,.1060600E+01,& + & .1067900E+01,.1047200E+01,.9871500E+00,.7482500E+00,.6241500E+00,& + & .8740100E+00,.9814000E+00,.1044600E+01,.1076300E+01,.1081100E+01,& + & .1059300E+01,.1000300E+01,.7629400E+00,.6338700E+00,.8910400E+00,& + & .1002200E+01,.1065100E+01,.1096200E+01,.1099700E+01,.1074000E+01,& + & .1012000E+01,.7765900E+00,.6454200E+00,.9087200E+00,.1023000E+01,& + & .1087800E+01,.1118800E+01,.1120700E+01,.1091100E+01,.1024300E+01,& + & .7890500E+00,.6590000E+00,.9267400E+00,.1043600E+01,.1110300E+01,& + & .1142400E+01,.1143500E+01,.1110200E+01,.1037500E+01,.8003400E+00,& + & .5254700E+00,.7422000E+00,.8343300E+00,.8889000E+00,.9174100E+00,& + & .9233600E+00,.9053800E+00,.8531100E+00,.6469600E+00,.5306400E+00,& + & .7560400E+00,.8510700E+00,.9058400E+00,.9336100E+00,.9383600E+00,& + & .9186100E+00,.8662600E+00,.6606200E+00,.5380900E+00,.7703700E+00,& + & .8694200E+00,.9256200E+00,.9540900E+00,.9577400E+00,.9342300E+00,& + & .8787100E+00,.6739100E+00,.5473400E+00,.7857600E+00,.8873400E+00,& + & .9463400E+00,.9761100E+00,.9789000E+00,.9525300E+00,.8919100E+00,& + & .6852600E+00,.5584200E+00,.8012900E+00,.9054200E+00,.9667500E+00,& + & .9978100E+00,.1001300E+01,.9725300E+00,.9059700E+00,.6958300E+00/ + + data absa(451:585, 7) / & + & .4490200E+00,.6464100E+00,.7268200E+00,.7729500E+00,.7967900E+00,& + & .8009500E+00,.7847800E+00,.7388000E+00,.5750000E+00,.4534300E+00,& + & .6581900E+00,.7425900E+00,.7903000E+00,.8150900E+00,.8186600E+00,& + & .7996000E+00,.7513700E+00,.5878400E+00,.4596800E+00,.6709400E+00,& + & .7581200E+00,.8089800E+00,.8352200E+00,.8385400E+00,.8171100E+00,& + & .7646100E+00,.5993900E+00,.4676400E+00,.6841800E+00,.7740200E+00,& + & .8271100E+00,.8551800E+00,.8596800E+00,.8363400E+00,.7785900E+00,& + & .6095400E+00,.4775000E+00,.6979800E+00,.7902100E+00,.8453400E+00,& + & .8748000E+00,.8801100E+00,.8559500E+00,.7926900E+00,.6189600E+00,& + & .3825200E+00,.5612300E+00,.6322100E+00,.6720700E+00,.6919100E+00,& + & .6945100E+00,.6785300E+00,.6367100E+00,.4962400E+00,.3861000E+00,& + & .5715200E+00,.6455900E+00,.6885700E+00,.7099200E+00,.7125000E+00,& + & .6944000E+00,.6494800E+00,.5077200E+00,.3913500E+00,.5825100E+00,& + & .6595300E+00,.7045900E+00,.7279300E+00,.7318800E+00,.7125100E+00,& + & .6631400E+00,.5177100E+00,.3983800E+00,.5940600E+00,.6735700E+00,& + & .7206600E+00,.7457000E+00,.7507500E+00,.7310800E+00,.6769600E+00,& + & .5268000E+00,.4078500E+00,.6062800E+00,.6880200E+00,.7368500E+00,& + & .7634200E+00,.7684200E+00,.7485700E+00,.6913500E+00,.5340800E+00,& + & .3229700E+00,.4855600E+00,.5476000E+00,.5835000E+00,.6007900E+00,& + & .6011600E+00,.5851800E+00,.5469900E+00,.4227600E+00,.3259100E+00,& + & .4944500E+00,.5596300E+00,.5976400E+00,.6165400E+00,.6184400E+00,& + & .6014900E+00,.5597300E+00,.4328000E+00,.3305700E+00,.5040500E+00,& + & .5718400E+00,.6118600E+00,.6323900E+00,.6355700E+00,.6186400E+00,& + & .5730500E+00,.4415100E+00,.3370500E+00,.5142700E+00,.5842800E+00,& + & .6261400E+00,.6482500E+00,.6517500E+00,.6349200E+00,.5868900E+00,& + & .4489300E+00,.3463600E+00,.5254400E+00,.5974000E+00,.6405500E+00,& + & .6634200E+00,.6673600E+00,.6500200E+00,.6005500E+00,.4548700E+00/ + + data absa( 1:180, 8) / & + & .8454475E+01,.7946981E+01,.8106902E+01,.8293415E+01,.8302744E+01,& + & .8132473E+01,.7748332E+01,.7379908E+01,.7837216E+01,.8369020E+01,& + & .7875895E+01,.8045177E+01,.8244563E+01,.8270709E+01,.8116300E+01,& + & .7749859E+01,.7393894E+01,.7847366E+01,.8285211E+01,.7804773E+01,& + & .7981608E+01,.8194058E+01,.8236878E+01,.8095655E+01,.7745523E+01,& + & .7401744E+01,.7853486E+01,.8206631E+01,.7736200E+01,.7920325E+01,& + & .8142313E+01,.8201279E+01,.8071188E+01,.7732988E+01,.7403543E+01,& + & .7855384E+01,.8131353E+01,.7669212E+01,.7859419E+01,.8089006E+01,& + & .8160968E+01,.8041936E+01,.7714112E+01,.7402770E+01,.7854506E+01,& + & .8035329E+01,.7711984E+01,.8054326E+01,.8312552E+01,.8382878E+01,& + & .8255716E+01,.7865615E+01,.7362355E+01,.7659280E+01,.7952578E+01,& + & .7639845E+01,.7991063E+01,.8263177E+01,.8347848E+01,.8239605E+01,& + & .7870529E+01,.7384107E+01,.7682523E+01,.7876313E+01,.7571250E+01,& + & .7929061E+01,.8212430E+01,.8313538E+01,.8219780E+01,.7866208E+01,& + & .7395265E+01,.7697467E+01,.7805455E+01,.7505993E+01,.7868255E+01,& + & .8161157E+01,.8275309E+01,.8195732E+01,.7853413E+01,.7398979E+01,& + & .7704855E+01,.7742281E+01,.7447306E+01,.7808392E+01,.8111167E+01,& + & .8233033E+01,.8164826E+01,.7836884E+01,.7399520E+01,.7708591E+01,& + & .7532706E+01,.7422731E+01,.7921038E+01,.8241749E+01,.8361773E+01,& + & .8264953E+01,.7883764E+01,.7273843E+01,.7366162E+01,.7456853E+01,& + & .7352022E+01,.7858416E+01,.8192991E+01,.8327704E+01,.8251231E+01,& + & .7894283E+01,.7297668E+01,.7395152E+01,.7388143E+01,.7286773E+01,& + & .7797671E+01,.8142220E+01,.8291520E+01,.8232710E+01,.7892900E+01,& + & .7312768E+01,.7415601E+01,.7329897E+01,.7229298E+01,.7738967E+01,& + & .8093725E+01,.8253763E+01,.8209025E+01,.7884574E+01,.7322979E+01,& + & .7429711E+01,.7281243E+01,.7179080E+01,.7684292E+01,.8043638E+01,& + & .8212576E+01,.8180221E+01,.7872560E+01,.7328406E+01,.7440260E+01,& + & .6960506E+01,.7084860E+01,.7692419E+01,.8072395E+01,.8231420E+01,& + & .8158941E+01,.7802620E+01,.7115961E+01,.6985525E+01,.6890460E+01,& + & .7017186E+01,.7632657E+01,.8022920E+01,.8197430E+01,.8148687E+01,& + & .7816871E+01,.7144322E+01,.7020806E+01,.6833009E+01,.6958106E+01,& + & .7575897E+01,.7974036E+01,.8162581E+01,.8133025E+01,.7819855E+01,& + & .7167278E+01,.7050824E+01,.6788341E+01,.6907823E+01,.7522755E+01,& + & .7926643E+01,.8125775E+01,.8111753E+01,.7815827E+01,.7185676E+01,& + & .7075641E+01,.6757259E+01,.6867282E+01,.7475452E+01,.7880340E+01,& + & .8087458E+01,.8084863E+01,.7806464E+01,.7198807E+01,.7097443E+01/ + + data absa(181:315, 8) / & + & .6340185E+01,.6707242E+01,.7374216E+01,.7801587E+01,.7986307E+01,& + & .7935884E+01,.7614843E+01,.6902656E+01,.6547120E+01,.6278416E+01,& + & .6644090E+01,.7317234E+01,.7752832E+01,.7957040E+01,.7930429E+01,& + & .7630569E+01,.6936644E+01,.6589898E+01,.6232993E+01,.6592439E+01,& + & .7264591E+01,.7707509E+01,.7925533E+01,.7918826E+01,.7635078E+01,& + & .6967951E+01,.6630153E+01,.6204934E+01,.6551194E+01,.7219795E+01,& + & .7664391E+01,.7893004E+01,.7899675E+01,.7635240E+01,.6992659E+01,& + & .6663746E+01,.6191620E+01,.6521893E+01,.7181052E+01,.7625747E+01,& + & .7860409E+01,.7878371E+01,.7631859E+01,.7008584E+01,.6691435E+01,& + & .5701027E+01,.6282840E+01,.6983217E+01,.7436614E+01,.7637531E+01,& + & .7613654E+01,.7322878E+01,.6631103E+01,.6068872E+01,.5649363E+01,& + & .6225960E+01,.6931874E+01,.7392920E+01,.7615331E+01,.7612305E+01,& + & .7340268E+01,.6671266E+01,.6121220E+01,.5616215E+01,.6181108E+01,& + & .6886667E+01,.7353790E+01,.7592183E+01,.7603387E+01,.7349200E+01,& + & .6709222E+01,.6171471E+01,.5602211E+01,.6150585E+01,.6849555E+01,& + & .7318623E+01,.7568758E+01,.7589509E+01,.7355024E+01,.6738001E+01,& + & .6212573E+01,.5606495E+01,.6135466E+01,.6822413E+01,.7289641E+01,& + & .7542848E+01,.7572934E+01,.7357114E+01,.6757793E+01,.6246128E+01,& + & .5069814E+01,.5819946E+01,.6539483E+01,.6990273E+01,.7204566E+01,& + & .7201912E+01,.6945088E+01,.6305330E+01,.5574348E+01,.5026679E+01,& + & .5770074E+01,.6492443E+01,.6954397E+01,.7190065E+01,.7204039E+01,& + & .6965377E+01,.6352224E+01,.5636607E+01,.5006597E+01,.5734952E+01,& + & .6454389E+01,.6924197E+01,.7174636E+01,.7200149E+01,.6978142E+01,& + & .6394579E+01,.5692813E+01,.5006429E+01,.5716643E+01,.6426495E+01,& + & .6900048E+01,.7157117E+01,.7191321E+01,.6989772E+01,.6426021E+01,& + & .5738457E+01,.5025396E+01,.5715867E+01,.6411783E+01,.6882764E+01,& + & .7139311E+01,.7183117E+01,.6997950E+01,.6450090E+01,.5778441E+01/ + + data absa(316:450, 8) / & + & .4462234E+01,.5335655E+01,.6051411E+01,.6480333E+01,.6706714E+01,& + & .6719742E+01,.6501878E+01,.5937436E+01,.5082003E+01,.4429084E+01,& + & .5293651E+01,.6011247E+01,.6455537E+01,.6695967E+01,.6727139E+01,& + & .6525443E+01,.5987665E+01,.5149466E+01,.4418913E+01,.5268426E+01,& + & .5981934E+01,.6436217E+01,.6685886E+01,.6728405E+01,.6544585E+01,& + & .6031729E+01,.5208404E+01,.4431057E+01,.5262879E+01,.5965884E+01,& + & .6423698E+01,.6675347E+01,.6726852E+01,.6562473E+01,.6066482E+01,& + & .5259098E+01,.4463604E+01,.5273803E+01,.5964332E+01,.6418269E+01,& + & .6667516E+01,.6727383E+01,.6575984E+01,.6094410E+01,.5304372E+01,& + & .3893017E+01,.4852214E+01,.5530986E+01,.5941479E+01,.6161053E+01,& + & .6192794E+01,.6013485E+01,.5527651E+01,.4603839E+01,.3868292E+01,& + & .4816432E+01,.5499970E+01,.5924581E+01,.6155187E+01,.6204798E+01,& + & .6043116E+01,.5578514E+01,.4673568E+01,.3867315E+01,.4800668E+01,& + & .5481603E+01,.5912694E+01,.6151550E+01,.6211560E+01,.6068531E+01,& + & .5623715E+01,.4735833E+01,.3889089E+01,.4804843E+01,.5478401E+01,& + & .5908385E+01,.6149321E+01,.6219065E+01,.6091671E+01,.5661853E+01,& + & .4790546E+01,.3931954E+01,.4826464E+01,.5491042E+01,.5912928E+01,& + & .6152912E+01,.6229107E+01,.6110084E+01,.5693512E+01,.4840222E+01,& + & .3370800E+01,.4371741E+01,.4996837E+01,.5386824E+01,.5594880E+01,& + & .5641906E+01,.5505250E+01,.5094350E+01,.4102630E+01,.3354024E+01,& + & .4346187E+01,.4976577E+01,.5374389E+01,.5596429E+01,.5658447E+01,& + & .5539483E+01,.5146897E+01,.4175662E+01,.3361375E+01,.4340181E+01,& + & .4971228E+01,.5370928E+01,.5598179E+01,.5672261E+01,.5570116E+01,& + & .5193502E+01,.4240227E+01,.3392497E+01,.4352744E+01,.4980679E+01,& + & .5377112E+01,.5606443E+01,.5688563E+01,.5596813E+01,.5234384E+01,& + & .4299382E+01,.3445749E+01,.4384734E+01,.5004059E+01,.5393218E+01,& + & .5623134E+01,.5706956E+01,.5620707E+01,.5270254E+01,.4350295E+01/ + + data absa(451:585, 8) / & + & .2896690E+01,.3891858E+01,.4467847E+01,.4828220E+01,.5035892E+01,& + & .5103952E+01,.5010639E+01,.4674849E+01,.3670107E+01,.2897792E+01,& + & .3883888E+01,.4462186E+01,.4828076E+01,.5043823E+01,.5124270E+01,& + & .5046967E+01,.4727706E+01,.3740688E+01,.2923572E+01,.3895453E+01,& + & .4471923E+01,.4837551E+01,.5057813E+01,.5145441E+01,.5079272E+01,& + & .4774390E+01,.3805013E+01,.2972461E+01,.3927241E+01,.4497456E+01,& + & .4859388E+01,.5080493E+01,.5168972E+01,.5109386E+01,.4816374E+01,& + & .3861922E+01,.3043384E+01,.3977838E+01,.4537492E+01,.4893037E+01,& + & .5111190E+01,.5197160E+01,.5139056E+01,.4854089E+01,.3912075E+01,& + & .2490281E+01,.3445349E+01,.3966257E+01,.4299151E+01,.4503210E+01,& + & .4585981E+01,.4527887E+01,.4253375E+01,.3285333E+01,.2507718E+01,& + & .3454661E+01,.3975474E+01,.4311153E+01,.4520893E+01,.4611552E+01,& + & .4565739E+01,.4306696E+01,.3353145E+01,.2549112E+01,.3484385E+01,& + & .4000658E+01,.4335871E+01,.4546759E+01,.4639747E+01,.4601392E+01,& + & .4354901E+01,.3414904E+01,.2613534E+01,.3533116E+01,.4041205E+01,& + & .4373302E+01,.4580520E+01,.4672532E+01,.4636635E+01,.4399031E+01,& + & .3469339E+01,.2696279E+01,.3599603E+01,.4096892E+01,.4422225E+01,& + & .4622150E+01,.4711302E+01,.4672921E+01,.4436995E+01,.3520495E+01,& + & .2147723E+01,.3043091E+01,.3506523E+01,.3813045E+01,.4007672E+01,& + & .4097762E+01,.4063337E+01,.3839253E+01,.2937518E+01,.2178826E+01,& + & .3066802E+01,.3529383E+01,.3837562E+01,.4035183E+01,.4129716E+01,& + & .4103957E+01,.3892792E+01,.3003047E+01,.2233352E+01,.3109540E+01,& + & .3568948E+01,.3874858E+01,.4071147E+01,.4166460E+01,.4144730E+01,& + & .3941453E+01,.3061753E+01,.2307024E+01,.3171315E+01,.3623581E+01,& + & .3923493E+01,.4115241E+01,.4208646E+01,.4185941E+01,.3984848E+01,& + & .3115620E+01,.2388613E+01,.3250521E+01,.3691760E+01,.3982688E+01,& + & .4168532E+01,.4255448E+01,.4227404E+01,.4025674E+01,.3167770E+01/ + + data absa( 1:180, 9) / & + & .2529000E+02,.2237800E+02,.1968200E+02,.1909200E+02,.1840100E+02,& + & .1733000E+02,.1719400E+02,.1951300E+02,.2154600E+02,.2515300E+02,& + & .2225100E+02,.1957400E+02,.1900200E+02,.1830900E+02,.1734600E+02,& + & .1716800E+02,.1946900E+02,.2151600E+02,.2499000E+02,.2210800E+02,& + & .1945700E+02,.1889100E+02,.1819700E+02,.1734400E+02,.1715300E+02,& + & .1943500E+02,.2151600E+02,.2478500E+02,.2192600E+02,.1931200E+02,& + & .1877400E+02,.1811100E+02,.1730000E+02,.1716800E+02,.1942600E+02,& + & .2152400E+02,.2456200E+02,.2172900E+02,.1914500E+02,.1865700E+02,& + & .1804300E+02,.1723900E+02,.1719000E+02,.1940000E+02,.2151700E+02,& + & .2673800E+02,.2363500E+02,.2116400E+02,.2088200E+02,.2013300E+02,& + & .1895200E+02,.1839100E+02,.2039700E+02,.2275200E+02,.2657900E+02,& + & .2349300E+02,.2102600E+02,.2077000E+02,.2004600E+02,.1892400E+02,& + & .1835100E+02,.2030200E+02,.2267300E+02,.2636900E+02,.2330400E+02,& + & .2084700E+02,.2063400E+02,.1995500E+02,.1886700E+02,.1835500E+02,& + & .2027400E+02,.2264300E+02,.2614700E+02,.2310800E+02,.2066300E+02,& + & .2049100E+02,.1987000E+02,.1879000E+02,.1836500E+02,.2027100E+02,& + & .2263800E+02,.2587600E+02,.2286700E+02,.2045700E+02,.2030800E+02,& + & .1978800E+02,.1872300E+02,.1835900E+02,.2024200E+02,.2261200E+02,& + & .2780100E+02,.2455800E+02,.2262500E+02,.2245600E+02,.2176600E+02,& + & .2072300E+02,.1978500E+02,.2119300E+02,.2381100E+02,.2758600E+02,& + & .2436600E+02,.2244400E+02,.2234100E+02,.2167000E+02,.2065100E+02,& + & .1973200E+02,.2116300E+02,.2377800E+02,.2736200E+02,.2416600E+02,& + & .2223600E+02,.2220000E+02,.2157500E+02,.2055700E+02,.1971800E+02,& + & .2115500E+02,.2378300E+02,.2708400E+02,.2391900E+02,.2201300E+02,& + & .2201800E+02,.2147100E+02,.2045700E+02,.1970800E+02,.2113600E+02,& + & .2376900E+02,.2679500E+02,.2366600E+02,.2179400E+02,.2182700E+02,& + & .2135500E+02,.2037400E+02,.1965500E+02,.2109200E+02,.2372400E+02,& + & .2832700E+02,.2502600E+02,.2391000E+02,.2372000E+02,.2326500E+02,& + & .2239600E+02,.2108600E+02,.2185900E+02,.2464900E+02,.2809500E+02,& + & .2481600E+02,.2368300E+02,.2359400E+02,.2315600E+02,.2230400E+02,& + & .2102300E+02,.2187300E+02,.2467400E+02,.2781700E+02,.2456900E+02,& + & .2345400E+02,.2344600E+02,.2303100E+02,.2218200E+02,.2102200E+02,& + & .2187800E+02,.2468000E+02,.2752500E+02,.2431000E+02,.2322000E+02,& + & .2326800E+02,.2290800E+02,.2209000E+02,.2102200E+02,.2182400E+02,& + & .2462000E+02,.2719100E+02,.2402300E+02,.2299600E+02,.2307200E+02,& + & .2276900E+02,.2202200E+02,.2098200E+02,.2173700E+02,.2451400E+02/ + + data absa(181:315, 9) / & + & .2825900E+02,.2501400E+02,.2490700E+02,.2470600E+02,.2464200E+02,& + & .2391800E+02,.2233000E+02,.2221900E+02,.2509100E+02,.2799300E+02,& + & .2477100E+02,.2466600E+02,.2459600E+02,.2448700E+02,.2381800E+02,& + & .2234800E+02,.2226900E+02,.2514900E+02,.2769100E+02,.2449900E+02,& + & .2442100E+02,.2443200E+02,.2434000E+02,.2370500E+02,.2242000E+02,& + & .2224200E+02,.2510900E+02,.2735700E+02,.2421400E+02,.2417800E+02,& + & .2425300E+02,.2419100E+02,.2364200E+02,.2242200E+02,.2217400E+02,& + & .2503000E+02,.2700800E+02,.2391600E+02,.2393500E+02,.2406300E+02,& + & .2402000E+02,.2357200E+02,.2235500E+02,.2213200E+02,.2495700E+02,& + & .2762700E+02,.2484100E+02,.2541400E+02,.2551300E+02,.2578800E+02,& + & .2516100E+02,.2356700E+02,.2238400E+02,.2509100E+02,.2731700E+02,& + & .2455000E+02,.2516500E+02,.2538400E+02,.2557800E+02,.2508300E+02,& + & .2366200E+02,.2242300E+02,.2510200E+02,.2699400E+02,.2425900E+02,& + & .2492600E+02,.2520600E+02,.2539100E+02,.2501500E+02,.2375800E+02,& + & .2236300E+02,.2502500E+02,.2664000E+02,.2394500E+02,.2469200E+02,& + & .2500200E+02,.2519300E+02,.2497300E+02,.2373300E+02,.2232800E+02,& + & .2496500E+02,.2626500E+02,.2362500E+02,.2444600E+02,.2478500E+02,& + & .2503700E+02,.2490600E+02,.2365900E+02,.2235200E+02,.2496500E+02,& + & .2643000E+02,.2458100E+02,.2543900E+02,.2614000E+02,.2652400E+02,& + & .2597400E+02,.2455200E+02,.2244100E+02,.2449800E+02,.2610500E+02,& + & .2426300E+02,.2522500E+02,.2597400E+02,.2631500E+02,.2594600E+02,& + & .2467700E+02,.2247100E+02,.2449000E+02,.2575200E+02,.2393800E+02,& + & .2499600E+02,.2574900E+02,.2611300E+02,.2592500E+02,.2475800E+02,& + & .2244200E+02,.2445400E+02,.2538900E+02,.2360900E+02,.2476100E+02,& + & .2549900E+02,.2594000E+02,.2591300E+02,.2472000E+02,.2247300E+02,& + & .2447500E+02,.2501000E+02,.2326000E+02,.2451000E+02,.2526200E+02,& + & .2580400E+02,.2581100E+02,.2464000E+02,.2254700E+02,.2453400E+02/ + + data absa(316:450, 9) / & + & .2476200E+02,.2399700E+02,.2520900E+02,.2646700E+02,.2674800E+02,& + & .2636500E+02,.2509400E+02,.2235700E+02,.2340600E+02,.2442100E+02,& + & .2367200E+02,.2498100E+02,.2621700E+02,.2659500E+02,.2637500E+02,& + & .2519500E+02,.2243500E+02,.2345300E+02,.2406700E+02,.2333600E+02,& + & .2475400E+02,.2595600E+02,.2645500E+02,.2636100E+02,.2524100E+02,& + & .2245800E+02,.2347500E+02,.2369100E+02,.2299600E+02,.2450200E+02,& + & .2569800E+02,.2633000E+02,.2634300E+02,.2519700E+02,.2253300E+02,& + & .2357500E+02,.2331100E+02,.2266000E+02,.2423400E+02,.2545000E+02,& + & .2621500E+02,.2620900E+02,.2512300E+02,.2264200E+02,.2370900E+02,& + & .2280000E+02,.2301100E+02,.2479900E+02,.2618100E+02,.2653300E+02,& + & .2630100E+02,.2504400E+02,.2207700E+02,.2190700E+02,.2243600E+02,& + & .2269700E+02,.2454600E+02,.2594500E+02,.2646000E+02,.2631400E+02,& + & .2512200E+02,.2220400E+02,.2202900E+02,.2207900E+02,.2236700E+02,& + & .2429500E+02,.2570600E+02,.2637000E+02,.2628800E+02,.2516200E+02,& + & .2231400E+02,.2215100E+02,.2171900E+02,.2202900E+02,.2401700E+02,& + & .2548700E+02,.2627300E+02,.2621700E+02,.2511000E+02,.2243500E+02,& + & .2233400E+02,.2134100E+02,.2170700E+02,.2370200E+02,.2528200E+02,& + & .2615900E+02,.2608600E+02,.2506500E+02,.2257800E+02,.2250600E+02,& + & .2060100E+02,.2167800E+02,.2405800E+02,.2535200E+02,.2593100E+02,& + & .2571800E+02,.2443200E+02,.2160700E+02,.2026200E+02,.2025400E+02,& + & .2134500E+02,.2379600E+02,.2518300E+02,.2587500E+02,.2569100E+02,& + & .2450800E+02,.2177400E+02,.2044500E+02,.1989900E+02,.2104800E+02,& + & .2349400E+02,.2500000E+02,.2580000E+02,.2566200E+02,.2453300E+02,& + & .2192200E+02,.2063800E+02,.1954400E+02,.2076600E+02,.2320700E+02,& + & .2482600E+02,.2568600E+02,.2559300E+02,.2452700E+02,.2208500E+02,& + & .2083200E+02,.1919300E+02,.2047000E+02,.2293600E+02,.2467300E+02,& + & .2554400E+02,.2548000E+02,.2453700E+02,.2221800E+02,.2104400E+02/ + + data absa(451:585, 9) / & + & .1817000E+02,.2015500E+02,.2272100E+02,.2414500E+02,.2479800E+02,& + & .2455900E+02,.2340300E+02,.2089500E+02,.1874000E+02,.1783000E+02,& + & .1986000E+02,.2247900E+02,.2401800E+02,.2472100E+02,.2455600E+02,& + & .2346600E+02,.2106900E+02,.1894900E+02,.1749600E+02,.1957600E+02,& + & .2224200E+02,.2388600E+02,.2462100E+02,.2452900E+02,.2352500E+02,& + & .2123100E+02,.1914700E+02,.1716800E+02,.1929200E+02,.2200500E+02,& + & .2373400E+02,.2451400E+02,.2447600E+02,.2358000E+02,.2137600E+02,& + & .1936800E+02,.1684400E+02,.1901300E+02,.2177100E+02,.2357000E+02,& + & .2439000E+02,.2444000E+02,.2365100E+02,.2151700E+02,.1961200E+02,& + & .1576200E+02,.1861500E+02,.2113300E+02,.2263900E+02,.2321400E+02,& + & .2302200E+02,.2206000E+02,.1995800E+02,.1731400E+02,.1545500E+02,& + & .1834100E+02,.2094400E+02,.2251000E+02,.2314800E+02,.2304200E+02,& + & .2216400E+02,.2012700E+02,.1754300E+02,.1515600E+02,.1806800E+02,& + & .2076800E+02,.2237400E+02,.2308400E+02,.2306000E+02,.2225700E+02,& + & .2027500E+02,.1777000E+02,.1486500E+02,.1779400E+02,.2058200E+02,& + & .2223700E+02,.2301800E+02,.2307900E+02,.2235000E+02,.2042700E+02,& + & .1802600E+02,.1461200E+02,.1753400E+02,.2039900E+02,.2208600E+02,& + & .2295600E+02,.2311200E+02,.2244300E+02,.2060700E+02,.1828000E+02,& + & .1351700E+02,.1691400E+02,.1942500E+02,.2079000E+02,.2136700E+02,& + & .2131500E+02,.2060700E+02,.1887100E+02,.1596700E+02,.1324900E+02,& + & .1668800E+02,.1927900E+02,.2069300E+02,.2134400E+02,.2137200E+02,& + & .2072500E+02,.1904300E+02,.1621700E+02,.1299400E+02,.1646700E+02,& + & .1910800E+02,.2060200E+02,.2134300E+02,.2143600E+02,.2083900E+02,& + & .1921200E+02,.1649400E+02,.1278400E+02,.1625000E+02,.1895100E+02,& + & .2050600E+02,.2133500E+02,.2150300E+02,.2096100E+02,.1941500E+02,& + & .1677000E+02,.1273400E+02,.1604900E+02,.1881900E+02,.2043800E+02,& + & .2132900E+02,.2157300E+02,.2110400E+02,.1962300E+02,.1698300E+02/ + + data absa( 1:180,10) / & + & .3587728E+02,.3163298E+02,.2744141E+02,.2457089E+02,.2397093E+02,& + & .2424633E+02,.2723997E+02,.3121916E+02,.3444458E+02,.3583320E+02,& + & .3160263E+02,.2742318E+02,.2450739E+02,.2389581E+02,.2409779E+02,& + & .2700065E+02,.3092695E+02,.3408907E+02,.3574205E+02,.3152702E+02,& + & .2736303E+02,.2442532E+02,.2382519E+02,.2395943E+02,.2677589E+02,& + & .3065092E+02,.3375501E+02,.3559971E+02,.3140018E+02,.2725046E+02,& + & .2431487E+02,.2372351E+02,.2384507E+02,.2657448E+02,.3041293E+02,& + & .3346529E+02,.3540621E+02,.3122776E+02,.2710481E+02,.2417902E+02,& + & .2360279E+02,.2374616E+02,.2639615E+02,.3021059E+02,.3322457E+02,& + & .4028856E+02,.3550073E+02,.3077033E+02,.2797279E+02,.2711240E+02,& + & .2689686E+02,.2944080E+02,.3377959E+02,.3768881E+02,.4023214E+02,& + & .3545689E+02,.3073830E+02,.2787552E+02,.2703385E+02,.2679085E+02,& + & .2921417E+02,.3349222E+02,.3733705E+02,.4012534E+02,.3536466E+02,& + & .3066284E+02,.2776145E+02,.2693419E+02,.2667684E+02,.2898061E+02,& + & .3321866E+02,.3700637E+02,.3994773E+02,.3520594E+02,.3052931E+02,& + & .2761549E+02,.2681235E+02,.2656436E+02,.2878066E+02,.3297874E+02,& + & .3672473E+02,.3972581E+02,.3501021E+02,.3036408E+02,.2745552E+02,& + & .2667155E+02,.2645065E+02,.2861110E+02,.3278003E+02,.3649274E+02,& + & .4476125E+02,.3941959E+02,.3422706E+02,.3167904E+02,.3052481E+02,& + & .2973002E+02,.3165313E+02,.3629435E+02,.4090093E+02,.4471130E+02,& + & .3937886E+02,.3418630E+02,.3155677E+02,.3043113E+02,.2965728E+02,& + & .3143493E+02,.3600307E+02,.4054030E+02,.4457943E+02,.3926295E+02,& + & .3408654E+02,.3140866E+02,.3032055E+02,.2958250E+02,.3123380E+02,& + & .3573596E+02,.4022035E+02,.4439236E+02,.3909796E+02,.3394316E+02,& + & .3123639E+02,.3018674E+02,.2947741E+02,.3105394E+02,.3550064E+02,& + & .3995406E+02,.4412856E+02,.3886401E+02,.3374559E+02,.3104184E+02,& + & .3002428E+02,.2936062E+02,.3091031E+02,.3530951E+02,.3974076E+02,& + & .4910432E+02,.4321511E+02,.3779078E+02,.3556693E+02,.3409226E+02,& + & .3283110E+02,.3395610E+02,.3866004E+02,.4376828E+02,.4902356E+02,& + & .4314962E+02,.3771527E+02,.3544117E+02,.3399674E+02,.3277233E+02,& + & .3377629E+02,.3837960E+02,.4342838E+02,.4888388E+02,.4302756E+02,& + & .3758282E+02,.3527975E+02,.3389250E+02,.3269755E+02,.3359135E+02,& + & .3810582E+02,.4311667E+02,.4865644E+02,.4282619E+02,.3740141E+02,& + & .3507775E+02,.3374861E+02,.3258381E+02,.3342561E+02,.3789331E+02,& + & .4287514E+02,.4836706E+02,.4257131E+02,.3716473E+02,.3485086E+02,& + & .3357022E+02,.3245299E+02,.3329940E+02,.3773038E+02,.4269789E+02/ + + data absa(181:315,10) / & + & .5307594E+02,.4667483E+02,.4130685E+02,.3949369E+02,.3769718E+02,& + & .3615626E+02,.3643522E+02,.4090265E+02,.4638012E+02,.5296984E+02,& + & .4659097E+02,.4119161E+02,.3933623E+02,.3762920E+02,.3609076E+02,& + & .3626818E+02,.4063453E+02,.4606837E+02,.5278655E+02,.4643245E+02,& + & .4102506E+02,.3914923E+02,.3752838E+02,.3600030E+02,.3607944E+02,& + & .4039533E+02,.4580658E+02,.5252049E+02,.4620146E+02,.4079758E+02,& + & .3892166E+02,.3738707E+02,.3586925E+02,.3592354E+02,.4020885E+02,& + & .4560089E+02,.5218739E+02,.4591040E+02,.4053117E+02,.3866135E+02,& + & .3721768E+02,.3572048E+02,.3579033E+02,.4004272E+02,.4542333E+02,& + & .5645060E+02,.4959535E+02,.4476419E+02,.4329540E+02,.4136555E+02,& + & .3958949E+02,.3901626E+02,.4295054E+02,.4873997E+02,.5630605E+02,& + & .4947453E+02,.4458064E+02,.4311329E+02,.4131649E+02,.3950972E+02,& + & .3886403E+02,.4274257E+02,.4850859E+02,.5608434E+02,.4928505E+02,& + & .4434892E+02,.4288710E+02,.4120465E+02,.3940634E+02,.3867749E+02,& + & .4253840E+02,.4828479E+02,.5577797E+02,.4902368E+02,.4406590E+02,& + & .4263870E+02,.4106511E+02,.3925611E+02,.3851716E+02,.4234391E+02,& + & .4807363E+02,.5538906E+02,.4869020E+02,.4373996E+02,.4235043E+02,& + & .4087593E+02,.3908727E+02,.3836821E+02,.4215132E+02,.4786703E+02,& + & .5901771E+02,.5183601E+02,.4798533E+02,.4682270E+02,.4499590E+02,& + & .4308761E+02,.4172136E+02,.4474695E+02,.5079194E+02,.5882554E+02,& + & .5166631E+02,.4772612E+02,.4661016E+02,.4492409E+02,.4299263E+02,& + & .4159694E+02,.4458623E+02,.5061389E+02,.5854583E+02,.5141979E+02,& + & .4742883E+02,.4637327E+02,.4480255E+02,.4286883E+02,.4142281E+02,& + & .4438577E+02,.5039888E+02,.5817816E+02,.5110231E+02,.4708389E+02,& + & .4609738E+02,.4463949E+02,.4268850E+02,.4126044E+02,.4418534E+02,& + & .5018101E+02,.5773974E+02,.5072435E+02,.4670644E+02,.4577129E+02,& + & .4443478E+02,.4250650E+02,.4111702E+02,.4397705E+02,.4997641E+02/ + + data absa(316:450,10) / & + & .6060573E+02,.5344936E+02,.5077793E+02,.4997885E+02,.4845492E+02,& + & .4650628E+02,.4444661E+02,.4611186E+02,.5223587E+02,.6035565E+02,& + & .5321162E+02,.5047679E+02,.4976412E+02,.4835297E+02,.4640277E+02,& + & .4437648E+02,.4597962E+02,.5210068E+02,.6001386E+02,.5290034E+02,& + & .5010907E+02,.4949538E+02,.4818206E+02,.4628144E+02,.4423845E+02,& + & .4582350E+02,.5193692E+02,.5960595E+02,.5253493E+02,.4971769E+02,& + & .4917510E+02,.4797986E+02,.4609629E+02,.4410837E+02,.4565103E+02,& + & .5175207E+02,.5910403E+02,.5209755E+02,.4928800E+02,.4883659E+02,& + & .4774249E+02,.4591174E+02,.4398757E+02,.4546040E+02,.5157175E+02,& + & .6109714E+02,.5440970E+02,.5300408E+02,.5268782E+02,.5157437E+02,& + & .4964597E+02,.4705595E+02,.4702696E+02,.5286716E+02,.6078367E+02,& + & .5409377E+02,.5266455E+02,.5243664E+02,.5140681E+02,.4958118E+02,& + & .4706770E+02,.4700927E+02,.5284723E+02,.6037380E+02,.5371502E+02,& + & .5225748E+02,.5215540E+02,.5119129E+02,.4948761E+02,.4697878E+02,& + & .4691301E+02,.5274423E+02,.5989651E+02,.5328949E+02,.5183758E+02,& + & .5181450E+02,.5096397E+02,.4932968E+02,.4689935E+02,.4677701E+02,& + & .5261482E+02,.5936966E+02,.5280219E+02,.5138276E+02,.5145230E+02,& + & .5070975E+02,.4914571E+02,.4680586E+02,.4662819E+02,.5250407E+02,& + & .6042976E+02,.5467511E+02,.5454288E+02,.5481038E+02,.5409097E+02,& + & .5235706E+02,.4927445E+02,.4742032E+02,.5252935E+02,.6001878E+02,& + & .5427532E+02,.5413495E+02,.5452142E+02,.5389531E+02,.5233375E+02,& + & .4936959E+02,.4752824E+02,.5263857E+02,.5955852E+02,.5382395E+02,& + & .5371774E+02,.5419930E+02,.5366829E+02,.5225894E+02,.4936460E+02,& + & .4753260E+02,.5265555E+02,.5902075E+02,.5331468E+02,.5326153E+02,& + & .5383822E+02,.5344237E+02,.5210269E+02,.4932635E+02,.4747318E+02,& + & .5266176E+02,.5843636E+02,.5278414E+02,.5278267E+02,.5345038E+02,& + & .5319472E+02,.5193593E+02,.4925399E+02,.4743021E+02,.5267090E+02/ + + data absa(451:585,10) / & + & .5841299E+02,.5394652E+02,.5521374E+02,.5605247E+02,.5585908E+02,& + & .5438236E+02,.5102018E+02,.4757287E+02,.5144594E+02,.5792304E+02,& + & .5345752E+02,.5477573E+02,.5572296E+02,.5566296E+02,.5437881E+02,& + & .5115010E+02,.4772352E+02,.5165224E+02,.5737807E+02,.5293116E+02,& + & .5431199E+02,.5537393E+02,.5546638E+02,.5430287E+02,.5118313E+02,& + & .4781700E+02,.5183934E+02,.5678698E+02,.5237535E+02,.5381877E+02,& + & .5500766E+02,.5523934E+02,.5416503E+02,.5117650E+02,.4791639E+02,& + & .5201561E+02,.5615143E+02,.5178837E+02,.5328954E+02,.5460865E+02,& + & .5497459E+02,.5398659E+02,.5113103E+02,.4798503E+02,.5214722E+02,& + & .5536220E+02,.5249053E+02,.5510606E+02,.5651628E+02,.5687411E+02,& + & .5558754E+02,.5214421E+02,.4740469E+02,.4972236E+02,.5479927E+02,& + & .5192667E+02,.5465501E+02,.5620526E+02,.5671006E+02,.5563285E+02,& + & .5229549E+02,.4766073E+02,.5010788E+02,.5421071E+02,.5135180E+02,& + & .5415133E+02,.5586559E+02,.5652158E+02,.5556841E+02,.5239599E+02,& + & .4791820E+02,.5046754E+02,.5358519E+02,.5076397E+02,.5362234E+02,& + & .5548685E+02,.5629675E+02,.5544739E+02,.5247314E+02,.4811189E+02,& + & .5074908E+02,.5294036E+02,.5016394E+02,.5307965E+02,.5511021E+02,& + & .5600283E+02,.5528953E+02,.5251126E+02,.4826838E+02,.5100487E+02,& + & .5148338E+02,.5053874E+02,.5414066E+02,.5624827E+02,.5702373E+02,& + & .5589687E+02,.5255754E+02,.4705268E+02,.4767006E+02,.5089925E+02,& + & .4993871E+02,.5366605E+02,.5594429E+02,.5690194E+02,.5597842E+02,& + & .5278229E+02,.4742535E+02,.4816570E+02,.5028772E+02,.4933321E+02,& + & .5319737E+02,.5560811E+02,.5674811E+02,.5596622E+02,.5298860E+02,& + & .4773920E+02,.4858121E+02,.4966712E+02,.4872563E+02,.5271026E+02,& + & .5528046E+02,.5651701E+02,.5590277E+02,.5315749E+02,.4798366E+02,& + & .4895540E+02,.4904239E+02,.4811862E+02,.5220900E+02,.5494835E+02,& + & .5626643E+02,.5584337E+02,.5327664E+02,.4820949E+02,.4934904E+02/ + + data absa( 1:180,11) / & + & .5140400E+02,.4521200E+02,.3907800E+02,.3297800E+02,.3121300E+02,& + & .3568900E+02,.4223900E+02,.4910900E+02,.5355500E+02,.5145600E+02,& + & .4526300E+02,.3908500E+02,.3297500E+02,.3103400E+02,.3523700E+02,& + & .4175600E+02,.4853100E+02,.5287700E+02,.5141900E+02,.4522600E+02,& + & .3901300E+02,.3293200E+02,.3082600E+02,.3487100E+02,.4137200E+02,& + & .4807000E+02,.5231900E+02,.5131500E+02,.4512200E+02,.3892500E+02,& + & .3288600E+02,.3064300E+02,.3456500E+02,.4105400E+02,.4769000E+02,& + & .5185300E+02,.5113400E+02,.4495800E+02,.3878700E+02,.3281900E+02,& + & .3047600E+02,.3433000E+02,.4079900E+02,.4738400E+02,.5151300E+02,& + & .5957500E+02,.5234300E+02,.4516800E+02,.3815600E+02,.3654900E+02,& + & .4079800E+02,.4843300E+02,.5632000E+02,.6249900E+02,.5965600E+02,& + & .5241500E+02,.4519600E+02,.3815900E+02,.3635600E+02,.4023200E+02,& + & .4780600E+02,.5560300E+02,.6169200E+02,.5963500E+02,.5239500E+02,& + & .4514600E+02,.3811600E+02,.3613900E+02,.3980500E+02,.4733900E+02,& + & .5504600E+02,.6106800E+02,.5952200E+02,.5228500E+02,.4505100E+02,& + & .3806600E+02,.3588900E+02,.3947000E+02,.4698100E+02,.5462100E+02,& + & .6059200E+02,.5930700E+02,.5209400E+02,.4488900E+02,.3796000E+02,& + & .3567700E+02,.3921600E+02,.4668700E+02,.5426800E+02,.6019300E+02,& + & .6880900E+02,.6039700E+02,.5202500E+02,.4416100E+02,.4270100E+02,& + & .4666700E+02,.5552000E+02,.6449300E+02,.7266900E+02,.6892400E+02,& + & .6049900E+02,.5209800E+02,.4413300E+02,.4252100E+02,.4596600E+02,& + & .5473200E+02,.6359400E+02,.7170500E+02,.6895000E+02,.6053100E+02,& + & .5210100E+02,.4410000E+02,.4228500E+02,.4541800E+02,.5409500E+02,& + & .6288300E+02,.7091900E+02,.6885700E+02,.6043400E+02,.5201400E+02,& + & .4404100E+02,.4203100E+02,.4500500E+02,.5356400E+02,.6229100E+02,& + & .7024700E+02,.6866600E+02,.6026500E+02,.5187100E+02,.4394200E+02,& + & .4184200E+02,.4469000E+02,.5313400E+02,.6180600E+02,.6968600E+02,& + & .7931100E+02,.6956100E+02,.5988100E+02,.5127600E+02,.4976100E+02,& + & .5319300E+02,.6339600E+02,.7365600E+02,.8365200E+02,.7951100E+02,& + & .6973600E+02,.6001900E+02,.5117300E+02,.4959400E+02,.5246600E+02,& + & .6246100E+02,.7257800E+02,.8242600E+02,.7956200E+02,.6978900E+02,& + & .6004300E+02,.5107500E+02,.4934600E+02,.5184700E+02,.6163900E+02,& + & .7163200E+02,.8136900E+02,.7951200E+02,.6973300E+02,.5998900E+02,& + & .5097900E+02,.4908800E+02,.5136000E+02,.6094700E+02,.7083600E+02,& + & .8046800E+02,.7932500E+02,.6956900E+02,.5985400E+02,.5087100E+02,& + & .4888200E+02,.5099100E+02,.6036200E+02,.7016100E+02,.7970100E+02/ + + data absa(181:315,11) / & + & .9111200E+02,.7989200E+02,.6878100E+02,.5949600E+02,.5798800E+02,& + & .6041500E+02,.7159500E+02,.8322700E+02,.9485400E+02,.9144700E+02,& + & .8017300E+02,.6902300E+02,.5941600E+02,.5774300E+02,.5967300E+02,& + & .7048300E+02,.8194200E+02,.9339400E+02,.9158300E+02,.8028800E+02,& + & .6910600E+02,.5927600E+02,.5741600E+02,.5903500E+02,.6952800E+02,& + & .8082900E+02,.9213100E+02,.9156600E+02,.8025700E+02,.6907300E+02,& + & .5913600E+02,.5709200E+02,.5852700E+02,.6872400E+02,.7988500E+02,& + & .9105300E+02,.9139000E+02,.8010400E+02,.6893700E+02,.5897300E+02,& + & .5677600E+02,.5810700E+02,.6807900E+02,.7907200E+02,.9012200E+02,& + & .1041900E+03,.9139400E+02,.7865600E+02,.6891600E+02,.6712800E+02,& + & .6846100E+02,.7989400E+02,.9292600E+02,.1060700E+03,.1046300E+03,& + & .9178200E+02,.7900200E+02,.6881900E+02,.6684500E+02,.6773800E+02,& + & .7862800E+02,.9145800E+02,.1044000E+03,.1048600E+03,.9197000E+02,& + & .7915600E+02,.6869800E+02,.6647000E+02,.6706600E+02,.7762800E+02,& + & .9024200E+02,.1030200E+03,.1049400E+03,.9202500E+02,.7920700E+02,& + & .6855500E+02,.6608100E+02,.6654300E+02,.7684300E+02,.8925300E+02,& + & .1018900E+03,.1048100E+03,.9189200E+02,.7910500E+02,.6834400E+02,& + & .6566800E+02,.6610900E+02,.7619000E+02,.8838600E+02,.1009000E+03,& + & .1185000E+03,.1039400E+03,.8942300E+02,.7950900E+02,.7720700E+02,& + & .7719600E+02,.8794300E+02,.1023600E+03,.1169400E+03,.1190500E+03,& + & .1044300E+03,.8986400E+02,.7952800E+02,.7690500E+02,.7649400E+02,& + & .8665000E+02,.1007800E+03,.1151500E+03,.1193900E+03,.1047300E+03,& + & .9011500E+02,.7940100E+02,.7652300E+02,.7585300E+02,.8571500E+02,& + & .9959500E+02,.1138000E+03,.1195100E+03,.1048400E+03,.9022200E+02,& + & .7922000E+02,.7609000E+02,.7540500E+02,.8502200E+02,.9865300E+02,& + & .1127100E+03,.1194200E+03,.1047600E+03,.9016900E+02,.7897600E+02,& + & .7560700E+02,.7501800E+02,.8435200E+02,.9778300E+02,.1116700E+03/ + + data absa(316:450,11) / & + & .1338100E+03,.1173500E+03,.1009500E+03,.9122600E+02,.8818800E+02,& + & .8637900E+02,.9582800E+02,.1115500E+03,.1275500E+03,.1344600E+03,& + & .1179400E+03,.1014500E+03,.9127100E+02,.8794700E+02,.8576600E+02,& + & .9465200E+02,.1100600E+03,.1258300E+03,.1349200E+03,.1183400E+03,& + & .1018000E+03,.9123300E+02,.8761900E+02,.8522800E+02,.9381100E+02,& + & .1089200E+03,.1245200E+03,.1350500E+03,.1184600E+03,.1019200E+03,& + & .9109000E+02,.8715000E+02,.8488700E+02,.9311100E+02,.1079700E+03,& + & .1233700E+03,.1350000E+03,.1184400E+03,.1019200E+03,.9079700E+02,& + & .8662600E+02,.8457000E+02,.9242100E+02,.1071000E+03,.1222600E+03,& + & .1495200E+03,.1311000E+03,.1131600E+03,.1041000E+03,.9992700E+02,& + & .9607400E+02,.1037400E+03,.1206700E+03,.1380100E+03,.1502800E+03,& + & .1317900E+03,.1136000E+03,.1041500E+03,.9987000E+02,.9558900E+02,& + & .1025700E+03,.1191200E+03,.1362300E+03,.1508200E+03,.1322700E+03,& + & .1139200E+03,.1040500E+03,.9957100E+02,.9518900E+02,.1018200E+03,& + & .1180300E+03,.1349600E+03,.1510300E+03,.1324700E+03,.1140300E+03,& + & .1038500E+03,.9912600E+02,.9498000E+02,.1012200E+03,.1172000E+03,& + & .1338800E+03,.1509400E+03,.1324500E+03,.1140100E+03,.1034800E+03,& + & .9855000E+02,.9474600E+02,.1005500E+03,.1163600E+03,.1327600E+03,& + & .1652400E+03,.1448600E+03,.1259400E+03,.1178500E+03,.1122500E+03,& + & .1065400E+03,.1120200E+03,.1296500E+03,.1482900E+03,.1661000E+03,& + & .1456400E+03,.1263600E+03,.1178700E+03,.1123300E+03,.1063000E+03,& + & .1109300E+03,.1281100E+03,.1465300E+03,.1665900E+03,.1460800E+03,& + & .1265600E+03,.1176900E+03,.1121400E+03,.1060900E+03,.1103200E+03,& + & .1271300E+03,.1453200E+03,.1668100E+03,.1463000E+03,.1265900E+03,& + & .1173600E+03,.1116900E+03,.1059700E+03,.1097300E+03,.1262900E+03,& + & .1441600E+03,.1667100E+03,.1462300E+03,.1263900E+03,.1168800E+03,& + & .1111100E+03,.1057600E+03,.1090900E+03,.1254200E+03,.1430300E+03/ + + data absa(451:585,11) / & + & .1806500E+03,.1583200E+03,.1390300E+03,.1320100E+03,.1251900E+03,& + & .1182000E+03,.1204700E+03,.1376000E+03,.1573900E+03,.1813100E+03,& + & .1589300E+03,.1391600E+03,.1318300E+03,.1252000E+03,.1180000E+03,& + & .1197900E+03,.1366000E+03,.1561200E+03,.1816200E+03,.1592500E+03,& + & .1391200E+03,.1314500E+03,.1248700E+03,.1178900E+03,.1192200E+03,& + & .1356600E+03,.1548100E+03,.1816100E+03,.1592700E+03,.1388800E+03,& + & .1309100E+03,.1243200E+03,.1177000E+03,.1185800E+03,.1346200E+03,& + & .1535000E+03,.1812900E+03,.1590100E+03,.1384900E+03,.1302700E+03,& + & .1237100E+03,.1173800E+03,.1180000E+03,.1337800E+03,.1524800E+03,& + & .1943900E+03,.1703100E+03,.1518100E+03,.1457700E+03,.1382800E+03,& + & .1307000E+03,.1297200E+03,.1454600E+03,.1661800E+03,.1948300E+03,& + & .1707300E+03,.1515600E+03,.1454300E+03,.1381200E+03,.1304300E+03,& + & .1291300E+03,.1444300E+03,.1647600E+03,.1949400E+03,.1708700E+03,& + & .1512400E+03,.1449300E+03,.1377100E+03,.1302000E+03,.1284700E+03,& + & .1433000E+03,.1633500E+03,.1947400E+03,.1707300E+03,.1507800E+03,& + & .1442500E+03,.1371800E+03,.1298600E+03,.1277900E+03,.1424000E+03,& + & .1622900E+03,.1942000E+03,.1702900E+03,.1501100E+03,.1433700E+03,& + & .1366600E+03,.1294200E+03,.1272500E+03,.1417100E+03,.1614700E+03,& + & .2056200E+03,.1801400E+03,.1639500E+03,.1588500E+03,.1513100E+03,& + & .1434400E+03,.1392800E+03,.1520100E+03,.1733600E+03,.2058300E+03,& + & .1803400E+03,.1634600E+03,.1584400E+03,.1510200E+03,.1431000E+03,& + & .1386700E+03,.1510100E+03,.1721000E+03,.2057900E+03,.1803400E+03,& + & .1628200E+03,.1578200E+03,.1505100E+03,.1427100E+03,.1380300E+03,& + & .1502600E+03,.1711900E+03,.2053900E+03,.1800200E+03,.1619900E+03,& + & .1569600E+03,.1500500E+03,.1422600E+03,.1374600E+03,.1497700E+03,& + & .1706100E+03,.2047100E+03,.1794600E+03,.1610100E+03,.1558000E+03,& + & .1494200E+03,.1416300E+03,.1368500E+03,.1492200E+03,.1699800E+03/ + + data absa( 1:180,12) / & + & .6180979E+02,.5415023E+02,.4652334E+02,.3927453E+02,.3636930E+02,& + & .4458440E+02,.5332753E+02,.6199779E+02,.6686984E+02,.6201467E+02,& + & .5432712E+02,.4674137E+02,.3945307E+02,.3621804E+02,.4416739E+02,& + & .5281294E+02,.6138502E+02,.6622974E+02,.6212587E+02,.5443223E+02,& + & .4690627E+02,.3958570E+02,.3609178E+02,.4380068E+02,.5235331E+02,& + & .6084698E+02,.6567797E+02,.6210514E+02,.5448391E+02,.4698891E+02,& + & .3965214E+02,.3594726E+02,.4347273E+02,.5194539E+02,.6034581E+02,& + & .6519221E+02,.6202833E+02,.5446118E+02,.4698444E+02,.3963823E+02,& + & .3578608E+02,.4315548E+02,.5153608E+02,.5985270E+02,.6466696E+02,& + & .7408612E+02,.6488258E+02,.5568066E+02,.4672809E+02,.4299401E+02,& + & .5300946E+02,.6345952E+02,.7381337E+02,.8120038E+02,.7431987E+02,& + & .6508647E+02,.5591094E+02,.4696983E+02,.4270620E+02,.5245020E+02,& + & .6277983E+02,.7301412E+02,.8031789E+02,.7445016E+02,.6522132E+02,& + & .5612423E+02,.4716489E+02,.4247167E+02,.5192560E+02,.6214199E+02,& + & .7225979E+02,.7950285E+02,.7449398E+02,.6532501E+02,.5623682E+02,& + & .4725560E+02,.4229442E+02,.5140668E+02,.6150959E+02,.7151980E+02,& + & .7870069E+02,.7445650E+02,.6532487E+02,.5624935E+02,.4725682E+02,& + & .4210652E+02,.5092387E+02,.6091509E+02,.7081995E+02,.7792811E+02,& + & .8862835E+02,.7760021E+02,.6657195E+02,.5566578E+02,.5128990E+02,& + & .6327373E+02,.7579325E+02,.8820522E+02,.9907097E+02,.8897752E+02,& + & .7790504E+02,.6685198E+02,.5596711E+02,.5087545E+02,.6255790E+02,& + & .7492859E+02,.8717970E+02,.9792393E+02,.8915502E+02,.7806522E+02,& + & .6707372E+02,.5618767E+02,.5053795E+02,.6185942E+02,.7408065E+02,& + & .8619344E+02,.9681481E+02,.8920224E+02,.7817532E+02,.6720276E+02,& + & .5630420E+02,.5024670E+02,.6121136E+02,.7329693E+02,.8526792E+02,& + & .9576831E+02,.8916248E+02,.7817526E+02,.6722423E+02,.5632955E+02,& + & .4997369E+02,.6057311E+02,.7252164E+02,.8436173E+02,.9475516E+02,& + & .1056142E+03,.9245626E+02,.7929792E+02,.6618040E+02,.6147280E+02,& + & .7551544E+02,.9049492E+02,.1053424E+03,.1195913E+03,.1061542E+03,& + & .9293152E+02,.7971544E+02,.6661696E+02,.6092308E+02,.7453632E+02,& + & .8931434E+02,.1039588E+03,.1180265E+03,.1064863E+03,.9323304E+02,& + & .8004289E+02,.6692374E+02,.6046019E+02,.7370615E+02,.8831649E+02,& + & .1027830E+03,.1166845E+03,.1066437E+03,.9342567E+02,.8024158E+02,& + & .6710433E+02,.6006174E+02,.7289075E+02,.8732560E+02,.1016334E+03,& + & .1153732E+03,.1066187E+03,.9342970E+02,.8026290E+02,.6712941E+02,& + & .5968287E+02,.7205721E+02,.8632392E+02,.1004504E+03,.1140396E+03/ + + data absa(181:315,12) / & + & .1255319E+03,.1098733E+03,.9422394E+02,.7856981E+02,.7364879E+02,& + & .8993455E+02,.1078090E+03,.1255219E+03,.1431747E+03,.1261993E+03,& + & .1104607E+03,.9472274E+02,.7906163E+02,.7299959E+02,.8871931E+02,& + & .1063433E+03,.1238040E+03,.1412246E+03,.1266478E+03,.1108818E+03,& + & .9515186E+02,.7946770E+02,.7245329E+02,.8760934E+02,.1050151E+03,& + & .1222508E+03,.1394428E+03,.1269276E+03,.1111655E+03,.9543063E+02,& + & .7971950E+02,.7193392E+02,.8655075E+02,.1037357E+03,.1207616E+03,& + & .1377350E+03,.1269774E+03,.1112303E+03,.9549436E+02,.7977777E+02,& + & .7145906E+02,.8552064E+02,.1024909E+03,.1193094E+03,.1360690E+03,& + & .1486316E+03,.1300858E+03,.1115387E+03,.9299465E+02,.8823269E+02,& + & .1068891E+03,.1281501E+03,.1492401E+03,.1705961E+03,.1495263E+03,& + & .1308668E+03,.1122085E+03,.9359013E+02,.8736883E+02,.1053484E+03,& + & .1263026E+03,.1470657E+03,.1681173E+03,.1501396E+03,.1314414E+03,& + & .1127520E+03,.9410033E+02,.8669616E+02,.1039401E+03,.1246072E+03,& + & .1450931E+03,.1658588E+03,.1504832E+03,.1317688E+03,.1130645E+03,& + & .9437770E+02,.8607984E+02,.1025821E+03,.1229795E+03,.1431843E+03,& + & .1636739E+03,.1505906E+03,.1318738E+03,.1131670E+03,.9446367E+02,& + & .8553451E+02,.1012614E+03,.1213902E+03,.1413315E+03,.1615525E+03,& + & .1749535E+03,.1531197E+03,.1312770E+03,.1098627E+03,.1054310E+03,& + & .1267118E+03,.1519465E+03,.1769451E+03,.2025356E+03,.1761867E+03,& + & .1541979E+03,.1321991E+03,.1103506E+03,.1043907E+03,.1247740E+03,& + & .1496095E+03,.1742366E+03,.1994180E+03,.1770334E+03,.1549823E+03,& + & .1329299E+03,.1109139E+03,.1035393E+03,.1229433E+03,.1474132E+03,& + & .1716583E+03,.1964792E+03,.1775830E+03,.1554757E+03,.1333697E+03,& + & .1112711E+03,.1027772E+03,.1211079E+03,.1452057E+03,.1690988E+03,& + & .1935313E+03,.1778130E+03,.1556757E+03,.1335484E+03,.1114211E+03,& + & .1020906E+03,.1193757E+03,.1431352E+03,.1666861E+03,.1907553E+03/ + + data absa(316:450,12) / & + & .2050280E+03,.1794206E+03,.1538132E+03,.1296698E+03,.1256113E+03,& + & .1498126E+03,.1795895E+03,.2091417E+03,.2395094E+03,.2065326E+03,& + & .1807328E+03,.1549517E+03,.1300986E+03,.1242724E+03,.1472448E+03,& + & .1765192E+03,.2055840E+03,.2354240E+03,.2076189E+03,.1817305E+03,& + & .1558434E+03,.1304997E+03,.1232100E+03,.1448216E+03,.1736269E+03,& + & .2021988E+03,.2315773E+03,.2083544E+03,.1823886E+03,.1564141E+03,& + & .1307551E+03,.1223058E+03,.1424212E+03,.1707823E+03,.1989036E+03,& + & .2278090E+03,.2086842E+03,.1826772E+03,.1566702E+03,.1308824E+03,& + & .1214212E+03,.1402293E+03,.1681510E+03,.1958442E+03,.2243003E+03,& + & .2393883E+03,.2094845E+03,.1795806E+03,.1526649E+03,.1492182E+03,& + & .1761707E+03,.2111935E+03,.2459442E+03,.2817236E+03,.2413366E+03,& + & .2111878E+03,.1810490E+03,.1530843E+03,.1474621E+03,.1729020E+03,& + & .2072851E+03,.2414036E+03,.2765008E+03,.2426640E+03,.2123804E+03,& + & .1821044E+03,.1534075E+03,.1461365E+03,.1697315E+03,.2034720E+03,& + & .2369666E+03,.2714312E+03,.2435891E+03,.2131944E+03,.1828085E+03,& + & .1535710E+03,.1449502E+03,.1666087E+03,.1997639E+03,.2326282E+03,& + & .2664788E+03,.2439749E+03,.2135440E+03,.1831044E+03,.1535327E+03,& + & .1438260E+03,.1637945E+03,.1963970E+03,.2287448E+03,.2620139E+03,& + & .2786275E+03,.2438158E+03,.2090742E+03,.1791980E+03,.1764044E+03,& + & .2051521E+03,.2459740E+03,.2864840E+03,.3281621E+03,.2809503E+03,& + & .2458500E+03,.2108110E+03,.1796731E+03,.1742226E+03,.2010652E+03,& + & .2410665E+03,.2807744E+03,.3216182E+03,.2826742E+03,.2473903E+03,& + & .2121402E+03,.1799408E+03,.1725339E+03,.1970313E+03,.2361865E+03,& + & .2750847E+03,.3150950E+03,.2837444E+03,.2483293E+03,.2129494E+03,& + & .1799627E+03,.1710146E+03,.1933057E+03,.2316484E+03,.2698242E+03,& + & .3090609E+03,.2842653E+03,.2487778E+03,.2133179E+03,.1797427E+03,& + & .1695361E+03,.1899175E+03,.2275176E+03,.2649935E+03,.3035329E+03/ + + data absa(451:585,12) / & + & .3246164E+03,.2841571E+03,.2437591E+03,.2099009E+03,.2061338E+03,& + & .2346079E+03,.2807869E+03,.3270860E+03,.3746416E+03,.3270160E+03,& + & .2862343E+03,.2455753E+03,.2101750E+03,.2037891E+03,.2298452E+03,& + & .2746768E+03,.3199854E+03,.3664519E+03,.3287071E+03,.2876768E+03,& + & .2468055E+03,.2102385E+03,.2017300E+03,.2252550E+03,.2691398E+03,& + & .3135254E+03,.3590802E+03,.3296547E+03,.2884880E+03,.2474892E+03,& + & .2100045E+03,.1997651E+03,.2211596E+03,.2640071E+03,.3075507E+03,& + & .3522449E+03,.3298874E+03,.2886932E+03,.2476393E+03,.2093907E+03,& + & .1977676E+03,.2173310E+03,.2589645E+03,.3016760E+03,.3454882E+03,& + & .3764185E+03,.3295629E+03,.2827412E+03,.2448362E+03,.2395515E+03,& + & .2667523E+03,.3170130E+03,.3693427E+03,.4229547E+03,.3787898E+03,& + & .3316408E+03,.2845544E+03,.2447605E+03,.2368444E+03,.2613950E+03,& + & .3103293E+03,.3615554E+03,.4140351E+03,.3801676E+03,.3328413E+03,& + & .2856113E+03,.2443688E+03,.2342033E+03,.2564579E+03,.3041029E+03,& + & .3543252E+03,.4057425E+03,.3807335E+03,.3332994E+03,.2860069E+03,& + & .2436761E+03,.2315207E+03,.2518766E+03,.2980292E+03,.3472163E+03,& + & .3976049E+03,.3804795E+03,.3330315E+03,.2857763E+03,.2425900E+03,& + & .2287390E+03,.2473661E+03,.2919475E+03,.3401341E+03,.3894698E+03,& + & .4337936E+03,.3798110E+03,.3258724E+03,.2839162E+03,.2765829E+03,& + & .3019915E+03,.3551500E+03,.4138455E+03,.4738475E+03,.4358679E+03,& + & .3816444E+03,.3274735E+03,.2832262E+03,.2732493E+03,.2960468E+03,& + & .3477195E+03,.4051747E+03,.4639479E+03,.4367543E+03,.3824308E+03,& + & .3281687E+03,.2821996E+03,.2697997E+03,.2905362E+03,.3403748E+03,& + & .3966217E+03,.4541170E+03,.4367336E+03,.3824073E+03,.3281688E+03,& + & .2807593E+03,.2662071E+03,.2851390E+03,.3330291E+03,.3880528E+03,& + & .4442749E+03,.4356281E+03,.3814241E+03,.3273328E+03,.2789760E+03,& + & .2624596E+03,.2797763E+03,.3260499E+03,.3798827E+03,.4349494E+03/ + + + data absb( 1:175, 1) / & + & .1055400E-06,.3859600E-04,.6540200E-04,.8854000E-04,.1960100E-03,& + & .1047900E-06,.4367200E-04,.7488900E-04,.1011800E-03,.2214600E-03,& + & .1042900E-06,.4941800E-04,.8542900E-04,.1155700E-03,.2444800E-03,& + & .1023200E-06,.5580200E-04,.9645900E-04,.1316700E-03,.2700100E-03,& + & .9901300E-07,.6299600E-04,.1090000E-03,.1483400E-03,.2991700E-03,& + & .8513600E-07,.3194300E-04,.5440200E-04,.7388700E-04,.1589500E-03,& + & .8459700E-07,.3619600E-04,.6242900E-04,.8447900E-04,.1774900E-03,& + & .8362900E-07,.4098200E-04,.7112600E-04,.9657300E-04,.1974000E-03,& + & .8231000E-07,.4634400E-04,.8045800E-04,.1098400E-03,.2184700E-03,& + & .7870900E-07,.5225200E-04,.9098900E-04,.1239400E-03,.2428100E-03,& + & .6849700E-07,.2639300E-04,.4516400E-04,.6157000E-04,.1249300E-03,& + & .6806200E-07,.2993600E-04,.5191900E-04,.7038700E-04,.1395300E-03,& + & .6676600E-07,.3386300E-04,.5905600E-04,.8069300E-04,.1565300E-03,& + & .6563600E-07,.3829400E-04,.6688500E-04,.9155500E-04,.1751000E-03,& + & .6271100E-07,.4318900E-04,.7575600E-04,.1035500E-03,.1943900E-03,& + & .5508300E-07,.2176100E-04,.3748400E-04,.5130100E-04,.9787500E-04,& + & .5409500E-07,.2467000E-04,.4308400E-04,.5863900E-04,.1099600E-03,& + & .5334000E-07,.2792500E-04,.4897600E-04,.6723400E-04,.1241500E-03,& + & .5141200E-07,.3158800E-04,.5557600E-04,.7635200E-04,.1393900E-03,& + & .4934100E-07,.3567700E-04,.6293700E-04,.8636300E-04,.1554300E-03,& + & .4402200E-07,.1796300E-04,.3110200E-04,.4260400E-04,.7829000E-04,& + & .4316700E-07,.2038200E-04,.3575400E-04,.4887500E-04,.8794100E-04,& + & .4221000E-07,.2309100E-04,.4067400E-04,.5605900E-04,.9925700E-04,& + & .4040200E-07,.2612500E-04,.4616200E-04,.6358600E-04,.1116600E-03,& + & .3853200E-07,.2949400E-04,.5232700E-04,.7196000E-04,.1248000E-03,& + & .3493700E-07,.1490300E-04,.2586800E-04,.3550300E-04,.6336800E-04,& + & .3430800E-07,.1692300E-04,.2978100E-04,.4078900E-04,.7111500E-04,& + & .3299500E-07,.1917100E-04,.3387200E-04,.4681000E-04,.8030200E-04,& + & .3165400E-07,.2167900E-04,.3846800E-04,.5304800E-04,.9043100E-04,& + & .3028200E-07,.2449100E-04,.4359600E-04,.6007800E-04,.1013300E-03,& + & .2797100E-07,.1238500E-04,.2154900E-04,.2961800E-04,.5173200E-04,& + & .2712800E-07,.1404200E-04,.2482600E-04,.3404700E-04,.5806400E-04,& + & .2601800E-07,.1592000E-04,.2822100E-04,.3907200E-04,.6549500E-04,& + & .2471700E-07,.1801700E-04,.3205600E-04,.4428500E-04,.7385900E-04,& + & .2385900E-07,.2036000E-04,.3634100E-04,.5017000E-04,.8294400E-04/ + + data absb(176:350, 1) / & + & .2252900E-07,.1033600E-04,.1799900E-04,.2477600E-04,.4260200E-04,& + & .2173300E-07,.1168500E-04,.2076900E-04,.2850300E-04,.4783300E-04,& + & .2079100E-07,.1328000E-04,.2357100E-04,.3265400E-04,.5399500E-04,& + & .1966300E-07,.1502900E-04,.2678800E-04,.3706600E-04,.6094400E-04,& + & .1916900E-07,.1697500E-04,.3035300E-04,.4199600E-04,.6834400E-04,& + & .1814800E-07,.8603900E-05,.1504100E-04,.2071700E-04,.3514300E-04,& + & .1746500E-07,.9728700E-05,.1734800E-04,.2386200E-04,.3950800E-04,& + & .1653700E-07,.1107300E-04,.1968700E-04,.2727100E-04,.4465200E-04,& + & .1586000E-07,.1252600E-04,.2238800E-04,.3101500E-04,.5026900E-04,& + & .1545200E-07,.1415800E-04,.2533900E-04,.3514100E-04,.5632700E-04,& + & .1454200E-07,.7180700E-05,.1268200E-04,.1747300E-04,.2917900E-04,& + & .1396700E-07,.8157400E-05,.1455000E-04,.2014700E-04,.3279500E-04,& + & .1324100E-07,.9283900E-05,.1654700E-04,.2297100E-04,.3703600E-04,& + & .1274600E-07,.1052200E-04,.1884000E-04,.2611400E-04,.4161700E-04,& + & .1242600E-07,.1188600E-04,.2131300E-04,.2960400E-04,.4670900E-04,& + & .1172400E-07,.6019600E-05,.1070300E-04,.1475300E-04,.2414300E-04,& + & .1112400E-07,.6849900E-05,.1223300E-04,.1700900E-04,.2714700E-04,& + & .1055200E-07,.7789700E-05,.1392700E-04,.1936200E-04,.3066100E-04,& + & .1021300E-07,.8839800E-05,.1585000E-04,.2202400E-04,.3451900E-04,& + & .9962700E-08,.9975500E-05,.1791900E-04,.2494400E-04,.3873000E-04,& + & .9383500E-08,.5050500E-05,.9029800E-05,.1245000E-04,.1994000E-04,& + & .8872200E-08,.5749400E-05,.1028700E-04,.1435100E-04,.2245000E-04,& + & .8471900E-08,.6537400E-05,.1172700E-04,.1632900E-04,.2537800E-04,& + & .8192400E-08,.7418600E-05,.1333400E-04,.1856700E-04,.2856000E-04,& + & .7919400E-08,.8371900E-05,.1505600E-04,.2100300E-04,.3199000E-04,& + & .7453500E-08,.4243700E-05,.7622000E-05,.1052300E-04,.1653100E-04,& + & .7051600E-08,.4830000E-05,.8666700E-05,.1208900E-04,.1861600E-04,& + & .6774600E-08,.5494100E-05,.9892700E-05,.1379000E-04,.2102400E-04,& + & .6537500E-08,.6235700E-05,.1123300E-04,.1566200E-04,.2364200E-04,& + & .6300100E-08,.7028200E-05,.1266900E-04,.1769500E-04,.2647800E-04,& + & .5952000E-08,.3573900E-05,.6435000E-05,.8933000E-05,.1375400E-04,& + & .5664400E-08,.4079700E-05,.7329100E-05,.1022800E-04,.1548900E-04,& + & .5422900E-08,.4636600E-05,.8366400E-05,.1165900E-04,.1748600E-04,& + & .5215500E-08,.5254600E-05,.9482900E-05,.1324600E-04,.1964300E-04,& + & .5002600E-08,.5913400E-05,.1067600E-04,.1493300E-04,.2197900E-04/ + + data absb(351:525, 1) / & + & .4734700E-08,.3011700E-05,.5422300E-05,.7581000E-05,.1142400E-04,& + & .4521500E-08,.3442100E-05,.6195900E-05,.8661900E-05,.1288400E-04,& + & .4333400E-08,.3914300E-05,.7070200E-05,.9876100E-05,.1454300E-04,& + & .4135000E-08,.4427500E-05,.8000500E-05,.1119500E-04,.1631900E-04,& + & .3965300E-08,.4976900E-05,.8993100E-05,.1259800E-04,.1816000E-04,& + & .3794800E-08,.2541500E-05,.4581900E-05,.6433600E-05,.9495600E-05,& + & .3608300E-08,.2903800E-05,.5242600E-05,.7340000E-05,.1071900E-04,& + & .3441800E-08,.3301700E-05,.5973300E-05,.8357500E-05,.1206600E-04,& + & .3263600E-08,.3729700E-05,.6749300E-05,.9455800E-05,.1346800E-04,& + & .3134000E-08,.4187300E-05,.7575900E-05,.1062000E-04,.1495300E-04,& + & .3012100E-08,.2153600E-05,.3884100E-05,.5449100E-05,.7909000E-05,& + & .2877500E-08,.2455700E-05,.4446700E-05,.6224700E-05,.8914800E-05,& + & .2719600E-08,.2790000E-05,.5054300E-05,.7078200E-05,.9994300E-05,& + & .2579800E-08,.3147300E-05,.5701100E-05,.7993600E-05,.1113500E-04,& + & .2478500E-08,.3528700E-05,.6389400E-05,.8962400E-05,.1235700E-04,& + & .2403400E-08,.1823100E-05,.3294500E-05,.4618300E-05,.6583700E-05,& + & .2270200E-08,.2076600E-05,.3767100E-05,.5273500E-05,.7387500E-05,& + & .2155100E-08,.2355900E-05,.4274400E-05,.5993200E-05,.8266500E-05,& + & .2039700E-08,.2654100E-05,.4813700E-05,.6754900E-05,.9207100E-05,& + & .1920800E-08,.2971100E-05,.5388000E-05,.7559800E-05,.1021100E-04,& + & .1911600E-08,.1545400E-05,.2795700E-05,.3922800E-05,.5466400E-05,& + & .1804500E-08,.1757900E-05,.3193800E-05,.4478000E-05,.6120500E-05,& + & .1701500E-08,.1991100E-05,.3616700E-05,.5075300E-05,.6852300E-05,& + & .1604200E-08,.2239300E-05,.4066600E-05,.5709400E-05,.7626000E-05,& + & .1518900E-08,.2503500E-05,.4543900E-05,.6378500E-05,.8456200E-05,& + & .1513400E-08,.1308000E-05,.2376300E-05,.3336000E-05,.4538200E-05,& + & .1425400E-08,.1488600E-05,.2708600E-05,.3799500E-05,.5093800E-05,& + & .1347800E-08,.1683100E-05,.3060500E-05,.4297100E-05,.5693300E-05,& + & .1272600E-08,.1890400E-05,.3435300E-05,.4824700E-05,.6335300E-05,& + & .1202700E-08,.2109800E-05,.3831800E-05,.5380900E-05,.7030200E-05,& + & .1202400E-08,.1108400E-05,.2019300E-05,.2831000E-05,.3784900E-05,& + & .1133800E-08,.1260500E-05,.2294900E-05,.3222100E-05,.4245800E-05,& + & .1067800E-08,.1423100E-05,.2588100E-05,.3636500E-05,.4746000E-05,& + & .1005200E-08,.1596300E-05,.2901000E-05,.4072800E-05,.5280400E-05,& + & .9594600E-09,.1777900E-05,.3230100E-05,.4538100E-05,.5854700E-05/ + + data absb(526:700, 1) / & + & .9575000E-09,.9366500E-06,.1706800E-05,.2395400E-05,.3161100E-05,& + & .8999100E-09,.1063600E-05,.1936600E-05,.2720900E-05,.3544000E-05,& + & .8494400E-09,.1199400E-05,.2180400E-05,.3065100E-05,.3960000E-05,& + & .8086300E-09,.1343100E-05,.2440600E-05,.3428500E-05,.4404500E-05,& + & .7669700E-09,.1493700E-05,.2713800E-05,.3815300E-05,.4873900E-05,& + & .7693100E-09,.7814500E-06,.1424300E-05,.2000400E-05,.2608800E-05,& + & .7255400E-09,.8865200E-06,.1614000E-05,.2268400E-05,.2925500E-05,& + & .6867700E-09,.9987200E-06,.1815900E-05,.2553700E-05,.3267200E-05,& + & .6498600E-09,.1117800E-05,.2031200E-05,.2854200E-05,.3630400E-05,& + & .6217700E-09,.1242000E-05,.2256600E-05,.3173700E-05,.4018700E-05,& + & .6224500E-09,.6423500E-06,.1170900E-05,.1644500E-05,.2121300E-05,& + & .5869600E-09,.7287600E-06,.1326600E-05,.1864600E-05,.2379800E-05,& + & .5569300E-09,.8208900E-06,.1492700E-05,.2099100E-05,.2660000E-05,& + & .5293400E-09,.9187400E-06,.1669500E-05,.2345700E-05,.2957500E-05,& + & .5058500E-09,.1021000E-05,.1854900E-05,.2608500E-05,.3275800E-05,& + & .5115600E-09,.5187200E-06,.9455000E-06,.1328700E-05,.1708900E-05,& + & .4825800E-09,.5890800E-06,.1072200E-05,.1507900E-05,.1918700E-05,& + & .4569400E-09,.6642100E-06,.1207800E-05,.1699200E-05,.2145600E-05,& + & .4350200E-09,.7440800E-06,.1352000E-05,.1900000E-05,.2387600E-05,& + & .4151700E-09,.8275800E-06,.1503400E-05,.2114600E-05,.2647300E-05,& + & .4209400E-09,.4183700E-06,.7626000E-06,.1071900E-05,.1375600E-05,& + & .3970000E-09,.4755700E-06,.8657200E-06,.1218000E-05,.1546200E-05,& + & .3756300E-09,.5368400E-06,.9761300E-06,.1373800E-05,.1728900E-05,& + & .3578300E-09,.6019300E-06,.1093600E-05,.1537400E-05,.1925200E-05,& + & .3410700E-09,.6701400E-06,.1217300E-05,.1712700E-05,.2136900E-05,& + & .3463500E-09,.3373200E-06,.6149200E-06,.8644700E-06,.1105500E-05,& + & .3265400E-09,.3838300E-06,.6986900E-06,.9835500E-06,.1244000E-05,& + & .3090900E-09,.4337100E-06,.7886900E-06,.1110500E-05,.1392400E-05,& + & .2942500E-09,.4868100E-06,.8844600E-06,.1243300E-05,.1552600E-05,& + & .2800000E-09,.5425600E-06,.9855000E-06,.1386800E-05,.1723800E-05,& + & .2873100E-09,.2684300E-06,.4891500E-06,.6881000E-06,.8786700E-06,& + & .2708900E-09,.3060000E-06,.5569800E-06,.7843000E-06,.9907500E-06,& + & .2560700E-09,.3462400E-06,.6296600E-06,.8867700E-06,.1110700E-05,& + & .2437200E-09,.3892600E-06,.7073200E-06,.9943000E-06,.1240200E-05,& + & .2317600E-09,.4346500E-06,.7894300E-06,.1110700E-05,.1378700E-05/ + + data absb(701:875, 1) / & + & .2390300E-09,.2132300E-06,.3885500E-06,.5470100E-06,.6978100E-06,& + & .2248700E-09,.2433200E-06,.4432800E-06,.6239700E-06,.7877400E-06,& + & .2123600E-09,.2758100E-06,.5017000E-06,.7066400E-06,.8842700E-06,& + & .2020400E-09,.3106600E-06,.5643500E-06,.7938400E-06,.9889900E-06,& + & .1920900E-09,.3475300E-06,.6311900E-06,.8878700E-06,.1100700E-05,& + & .1986800E-09,.1695000E-06,.3088500E-06,.4342600E-06,.5533600E-06,& + & .1868100E-09,.1933800E-06,.3525000E-06,.4962200E-06,.6262800E-06,& + & .1764900E-09,.2196300E-06,.3995000E-06,.5626900E-06,.7039600E-06,& + & .1675300E-09,.2477800E-06,.4501300E-06,.6334200E-06,.7877000E-06,& + & .1593000E-09,.2777200E-06,.5043900E-06,.7094500E-06,.8778300E-06,& + & .1657700E-09,.1333200E-06,.2432300E-06,.3418400E-06,.4359400E-06,& + & .1559700E-09,.1524500E-06,.2780100E-06,.3913000E-06,.4946000E-06,& + & .1472100E-09,.1735400E-06,.3158400E-06,.4449900E-06,.5570500E-06,& + & .1393600E-09,.1962500E-06,.3566100E-06,.5018900E-06,.6239800E-06,& + & .1325500E-09,.2204400E-06,.4003400E-06,.5630800E-06,.6963400E-06,& + & .1386100E-09,.1044500E-06,.1905800E-06,.2684100E-06,.3423300E-06,& + & .1302700E-09,.1197400E-06,.2183600E-06,.3074400E-06,.3889700E-06,& + & .1229000E-09,.1366200E-06,.2486400E-06,.3506500E-06,.4391600E-06,& + & .1161100E-09,.1548400E-06,.2815500E-06,.3962700E-06,.4927300E-06,& + & .1104200E-09,.1743100E-06,.3166600E-06,.4454000E-06,.5508700E-06,& + & .1158100E-09,.8191500E-07,.1491500E-06,.2114000E-06,.2698700E-06,& + & .1090600E-09,.9407700E-07,.1714300E-06,.2417300E-06,.3058600E-06,& + & .1025400E-09,.1074500E-06,.1958200E-06,.2760600E-06,.3459300E-06,& + & .9675700E-10,.1220500E-06,.2220100E-06,.3127100E-06,.3887600E-06,& + & .9197900E-10,.1377200E-06,.2501500E-06,.3520800E-06,.4356100E-06,& + & .9688900E-10,.6411600E-07,.1170800E-06,.1645500E-06,.2103600E-06,& + & .9128100E-10,.7364100E-07,.1343600E-06,.1889500E-06,.2395100E-06,& + & .8583000E-10,.8416100E-07,.1536000E-06,.2164300E-06,.2717600E-06,& + & .8104800E-10,.9586700E-07,.1744700E-06,.2458200E-06,.3061300E-06,& + & .7671200E-10,.1084400E-06,.1970600E-06,.2774300E-06,.3432900E-06,& + & .8151600E-10,.4969800E-07,.9059600E-07,.1272700E-06,.1631300E-06,& + & .7660900E-10,.5713200E-07,.1043300E-06,.1469400E-06,.1867200E-06,& + & .7197500E-10,.6553400E-07,.1195500E-06,.1685000E-06,.2121500E-06,& + & .6790800E-10,.7482900E-07,.1361900E-06,.1920900E-06,.2395900E-06,& + & .6411700E-10,.8487200E-07,.1543300E-06,.2173300E-06,.2691500E-06/ + + data absb(876:1050, 1) / & + & .6842900E-10,.3871500E-07,.6985400E-07,.9837700E-07,.1261900E-06,& + & .6423600E-10,.4437500E-07,.8089500E-07,.1147100E-06,.1460400E-06,& + & .6051000E-10,.5102500E-07,.9297700E-07,.1312300E-06,.1654200E-06,& + & .5685100E-10,.5834500E-07,.1063300E-06,.1499100E-06,.1874500E-06,& + & .5367400E-10,.6634600E-07,.1207000E-06,.1700100E-06,.2109500E-06,& + & .5738700E-10,.2980000E-07,.5381700E-07,.7590600E-07,.9771000E-07,& + & .5396000E-10,.3450000E-07,.6320500E-07,.8865500E-07,.1131000E-06,& + & .5074000E-10,.3968400E-07,.7250200E-07,.1019300E-06,.1289200E-06,& + & .4771000E-10,.4541800E-07,.8294100E-07,.1169200E-06,.1464900E-06,& + & .4505000E-10,.5179700E-07,.9432000E-07,.1329600E-06,.1652600E-06,& + & .4801000E-10,.2299900E-07,.4168200E-07,.5897500E-07,.7589800E-07,& + & .4528200E-10,.2691700E-07,.4892900E-07,.6876500E-07,.8798300E-07,& + & .4253100E-10,.3087900E-07,.5640600E-07,.7959300E-07,.1010900E-06,& + & .4000200E-10,.3547000E-07,.6470600E-07,.9131200E-07,.1147300E-06,& + & .3767400E-10,.4054200E-07,.7383400E-07,.1041200E-06,.1296700E-06,& + & .4009400E-10,.1781000E-07,.3241200E-07,.4598500E-07,.5904100E-07,& + & .3790100E-10,.2101300E-07,.3792100E-07,.5347900E-07,.6847900E-07,& + & .3558400E-10,.2410000E-07,.4398800E-07,.6240900E-07,.7931100E-07,& + & .3351600E-10,.2773700E-07,.5054400E-07,.7143600E-07,.8991200E-07,& + & .3150300E-10,.3173800E-07,.5788900E-07,.8159100E-07,.1019500E-06,& + & .3346200E-10,.1382900E-07,.2522700E-07,.3549800E-07,.4579300E-07,& + & .3170300E-10,.1627200E-07,.2939300E-07,.4147600E-07,.5334000E-07,& + & .2985600E-10,.1883600E-07,.3453700E-07,.4849000E-07,.6179100E-07,& + & .2803800E-10,.2168400E-07,.3957800E-07,.5575100E-07,.7042200E-07,& + & .2637500E-10,.2482400E-07,.4538900E-07,.6389800E-07,.8007100E-07,& + & .2785900E-10,.1075700E-07,.1943600E-07,.2736800E-07,.3540100E-07,& + & .2648200E-10,.1257500E-07,.2278600E-07,.3227500E-07,.4150400E-07,& + & .2501300E-10,.1471800E-07,.2678600E-07,.3765700E-07,.4815000E-07,& + & .2348100E-10,.1689000E-07,.3087500E-07,.4356100E-07,.5528400E-07,& + & .2210300E-10,.1940500E-07,.3543500E-07,.5004600E-07,.6282400E-07,& + & .2326200E-10,.8353400E-08,.1503300E-07,.2114200E-07,.2749100E-07,& + & .2207500E-10,.9782100E-08,.1779100E-07,.2529800E-07,.3244700E-07,& + & .2088700E-10,.1154100E-07,.2085200E-07,.2939200E-07,.3764300E-07,& + & .1962900E-10,.1322800E-07,.2416400E-07,.3433000E-07,.4362200E-07,& + & .1847500E-10,.1523300E-07,.2777900E-07,.3930400E-07,.4943200E-07/ + + data absb(1051:1175, 1) / & + & .1936000E-10,.6488800E-08,.1164400E-07,.1638700E-07,.2134000E-07,& + & .1837200E-10,.7636700E-08,.1394700E-07,.1967200E-07,.2540100E-07,& + & .1742100E-10,.9008300E-08,.1627500E-07,.2297100E-07,.2952200E-07,& + & .1641300E-10,.1040200E-07,.1908100E-07,.2685400E-07,.3423300E-07,& + & .1541700E-10,.1198400E-07,.2183500E-07,.3085600E-07,.3895400E-07,& + & .1609400E-10,.5017400E-08,.9028300E-08,.1271800E-07,.1657600E-07,& + & .1526500E-10,.5974700E-08,.1085000E-07,.1529700E-07,.1978300E-07,& + & .1451500E-10,.7014200E-08,.1269900E-07,.1796000E-07,.2317100E-07,& + & .1371500E-10,.8162600E-08,.1494000E-07,.2099400E-07,.2686500E-07,& + & .1288000E-10,.9405400E-08,.1720600E-07,.2422100E-07,.3073900E-07,& + & .1336800E-10,.3883800E-08,.6999100E-08,.9837200E-08,.1282100E-07,& + & .1274300E-10,.4675100E-08,.8424300E-08,.1185600E-07,.1540600E-07,& + & .1208700E-10,.5464200E-08,.9929500E-08,.1406900E-07,.1814400E-07,& + & .1144200E-10,.6446100E-08,.1165700E-07,.1640700E-07,.2107200E-07,& + & .1075900E-10,.7371100E-08,.1347800E-07,.1910600E-07,.2431400E-07,& + & .1108100E-10,.3014800E-08,.5416500E-08,.7642100E-08,.9949600E-08,& + & .1059800E-10,.3633700E-08,.6537500E-08,.9204100E-08,.1202500E-07,& + & .1005200E-10,.4271200E-08,.7784100E-08,.1105300E-07,.1430600E-07,& + & .9530800E-11,.5042900E-08,.9113300E-08,.1286500E-07,.1655400E-07,& + & .8979500E-11,.5797900E-08,.1061500E-07,.1505100E-07,.1921600E-07,& + & .9119400E-11,.2421400E-08,.4349600E-08,.6153100E-08,.8013600E-08,& + & .8728700E-11,.2923200E-08,.5253500E-08,.7396600E-08,.9683000E-08,& + & .8276500E-11,.3441200E-08,.6278800E-08,.8899200E-08,.1153400E-07,& + & .7860500E-11,.4063200E-08,.7345400E-08,.1038200E-07,.1337200E-07,& + & .7412700E-11,.4680100E-08,.8591000E-08,.1213700E-07,.1553000E-07/ + + data absb( 1:175, 2) / & + & .1757600E-05,.2251800E-03,.3639800E-03,.4650500E-03,.9792000E-03,& + & .1952200E-05,.2568800E-03,.4272400E-03,.5429300E-03,.1126100E-02,& + & .2113400E-05,.2938200E-03,.4977800E-03,.6318600E-03,.1296100E-02,& + & .2268000E-05,.3358500E-03,.5709500E-03,.7314900E-03,.1485700E-02,& + & .2393900E-05,.3832600E-03,.6468800E-03,.8412000E-03,.1681500E-02,& + & .1386600E-05,.1881600E-03,.3054100E-03,.3908200E-03,.8061400E-03,& + & .1482500E-05,.2152500E-03,.3590600E-03,.4577200E-03,.9297600E-03,& + & .1642800E-05,.2466400E-03,.4189100E-03,.5334100E-03,.1068900E-02,& + & .1780700E-05,.2821800E-03,.4802100E-03,.6186100E-03,.1223600E-02,& + & .1868500E-05,.3220400E-03,.5438500E-03,.7122300E-03,.1384400E-02,& + & .1048300E-05,.1569900E-03,.2557100E-03,.3280300E-03,.6587300E-03,& + & .1131000E-05,.1801600E-03,.3007100E-03,.3853400E-03,.7591600E-03,& + & .1233000E-05,.2067200E-03,.3518100E-03,.4494000E-03,.8704100E-03,& + & .1342600E-05,.2365000E-03,.4029200E-03,.5224600E-03,.9944500E-03,& + & .1451400E-05,.2697900E-03,.4568400E-03,.6019500E-03,.1117300E-02,& + & .8066300E-06,.1309800E-03,.2138200E-03,.2753900E-03,.5372700E-03,& + & .8574700E-06,.1505800E-03,.2520100E-03,.3240600E-03,.6157300E-03,& + & .9243500E-06,.1728300E-03,.2954200E-03,.3787900E-03,.7014000E-03,& + & .9974700E-06,.1979300E-03,.3380700E-03,.4407600E-03,.7946800E-03,& + & .1081900E-05,.2258200E-03,.3835400E-03,.5066300E-03,.8898000E-03,& + & .6177200E-06,.1094100E-03,.1792600E-03,.2314400E-03,.4355400E-03,& + & .6571800E-06,.1257600E-03,.2117400E-03,.2727500E-03,.4975000E-03,& + & .6994900E-06,.1446100E-03,.2485200E-03,.3193700E-03,.5646200E-03,& + & .7538700E-06,.1658000E-03,.2837400E-03,.3721300E-03,.6350700E-03,& + & .7971500E-06,.1892600E-03,.3223600E-03,.4258800E-03,.7072800E-03,& + & .4718800E-06,.9195200E-04,.1510000E-03,.1949500E-03,.3554300E-03,& + & .5093700E-06,.1051300E-03,.1785200E-03,.2299900E-03,.4025000E-03,& + & .5420600E-06,.1213000E-03,.2095900E-03,.2697900E-03,.4566200E-03,& + & .5732800E-06,.1393600E-03,.2381500E-03,.3145100E-03,.5111300E-03,& + & .6107700E-06,.1591600E-03,.2707500E-03,.3596700E-03,.5707600E-03,& + & .3600500E-06,.7698400E-04,.1274300E-03,.1642200E-03,.2888500E-03,& + & .3898800E-06,.8802900E-04,.1506700E-03,.1939600E-03,.3285400E-03,& + & .4198900E-06,.1017200E-03,.1753900E-03,.2278400E-03,.3704500E-03,& + & .4409200E-06,.1172700E-03,.2000400E-03,.2659200E-03,.4159800E-03,& + & .4688300E-06,.1338600E-03,.2276900E-03,.3028500E-03,.4655000E-03/ + + data absb(176:350, 2) / & + & .2790800E-06,.6445000E-04,.1079500E-03,.1388900E-03,.2387800E-03,& + & .3093400E-06,.7418700E-04,.1277300E-03,.1641700E-03,.2701700E-03,& + & .3308600E-06,.8580100E-04,.1478200E-03,.1930700E-03,.3050800E-03,& + & .3505800E-06,.9886100E-04,.1686800E-03,.2250800E-03,.3424900E-03,& + & .3706900E-06,.1130600E-03,.1918800E-03,.2560100E-03,.3851900E-03,& + & .2241800E-06,.5409500E-04,.9141400E-04,.1175700E-03,.1969700E-03,& + & .2455900E-06,.6256700E-04,.1081900E-03,.1390800E-03,.2228400E-03,& + & .2616900E-06,.7238300E-04,.1248100E-03,.1636800E-03,.2520500E-03,& + & .2788500E-06,.8344600E-04,.1425800E-03,.1891000E-03,.2838600E-03,& + & .2934400E-06,.9554000E-04,.1619800E-03,.2160900E-03,.3194700E-03,& + & .1794100E-06,.4583000E-04,.7817600E-04,.1006100E-03,.1631300E-03,& + & .1939700E-06,.5313900E-04,.9255600E-04,.1190100E-03,.1848200E-03,& + & .2070700E-06,.6159300E-04,.1057900E-03,.1400800E-03,.2096500E-03,& + & .2207100E-06,.7101600E-04,.1210000E-03,.1612800E-03,.2366100E-03,& + & .2314800E-06,.8128600E-04,.1379500E-03,.1840100E-03,.2658000E-03,& + & .1429100E-06,.3882500E-04,.6686600E-04,.8614000E-04,.1351100E-03,& + & .1517900E-06,.4513500E-04,.7845000E-04,.1019400E-03,.1536900E-03,& + & .1632600E-06,.5239900E-04,.8991900E-04,.1200100E-03,.1744100E-03,& + & .1730700E-06,.6044000E-04,.1029300E-03,.1373500E-03,.1966800E-03,& + & .1813700E-06,.6918900E-04,.1175900E-03,.1565100E-03,.2199800E-03,& + & .1124500E-06,.3286200E-04,.5716600E-04,.7382800E-04,.1118500E-03,& + & .1195800E-06,.3828100E-04,.6663500E-04,.8739000E-04,.1274000E-03,& + & .1270200E-06,.4451900E-04,.7660600E-04,.1019000E-03,.1441800E-03,& + & .1346700E-06,.5137300E-04,.8762200E-04,.1170000E-03,.1620500E-03,& + & .1412000E-06,.5887400E-04,.1001900E-03,.1334800E-03,.1818800E-03,& + & .8824200E-07,.2795000E-04,.4901000E-04,.6343400E-04,.9287700E-04,& + & .9438300E-07,.3261000E-04,.5669000E-04,.7511400E-04,.1053100E-03,& + & .9971200E-07,.3792900E-04,.6520400E-04,.8711300E-04,.1193100E-03,& + & .1047300E-06,.4377800E-04,.7480500E-04,.9995000E-04,.1342700E-03,& + & .1098800E-06,.5022900E-04,.8559800E-04,.1140600E-03,.1505000E-03,& + & .6969600E-07,.2389500E-04,.4216600E-04,.5473300E-04,.7714600E-04,& + & .7439000E-07,.2792100E-04,.4838700E-04,.6481700E-04,.8760700E-04,& + & .7885600E-07,.3249700E-04,.5569200E-04,.7469100E-04,.9938700E-04,& + & .8325300E-07,.3749100E-04,.6413000E-04,.8560900E-04,.1119300E-03,& + & .8767500E-07,.4301100E-04,.7339800E-04,.9782800E-04,.1257400E-03/ + + data absb(351:525, 2) / & + & .5461900E-07,.2046900E-04,.3586900E-04,.4725900E-04,.6415100E-04,& + & .5865700E-07,.2392500E-04,.4146800E-04,.5549900E-04,.7291100E-04,& + & .6253200E-07,.2783900E-04,.4773500E-04,.6398500E-04,.8295500E-04,& + & .6618400E-07,.3214100E-04,.5500100E-04,.7345600E-04,.9356700E-04,& + & .6930500E-07,.3660500E-04,.6296800E-04,.8393800E-04,.1051700E-03,& + & .4334800E-07,.1747600E-04,.3069200E-04,.4080300E-04,.5327100E-04,& + & .4634800E-07,.2049600E-04,.3549800E-04,.4762900E-04,.6080900E-04,& + & .4950700E-07,.2385700E-04,.4097400E-04,.5494700E-04,.6922200E-04,& + & .5241900E-07,.2756000E-04,.4720500E-04,.6304400E-04,.7812300E-04,& + & .5484200E-07,.3109400E-04,.5402800E-04,.7211600E-04,.8783400E-04,& + & .3448000E-07,.1502700E-04,.2626800E-04,.3535800E-04,.4471100E-04,& + & .3698500E-07,.1763800E-04,.3040500E-04,.4093800E-04,.5105400E-04,& + & .3947600E-07,.2051200E-04,.3523700E-04,.4720700E-04,.5803400E-04,& + & .4165000E-07,.2369400E-04,.4058600E-04,.5428600E-04,.6570800E-04,& + & .4369300E-07,.2643800E-04,.4646700E-04,.6203500E-04,.7387200E-04,& + & .2740200E-07,.1293200E-04,.2258500E-04,.3036500E-04,.3747100E-04,& + & .2937700E-07,.1518300E-04,.2615800E-04,.3519500E-04,.4286700E-04,& + & .3135300E-07,.1765800E-04,.3034300E-04,.4060600E-04,.4885800E-04,& + & .3305600E-07,.2028600E-04,.3492400E-04,.4673500E-04,.5532900E-04,& + & .3467300E-07,.2245100E-04,.3971700E-04,.5332900E-04,.6215100E-04,& + & .2171600E-07,.1115600E-04,.1942700E-04,.2616900E-04,.3151200E-04,& + & .2331300E-07,.1309100E-04,.2256800E-04,.3037700E-04,.3621600E-04,& + & .2480300E-07,.1522100E-04,.2615700E-04,.3505000E-04,.4125600E-04,& + & .2626000E-07,.1727700E-04,.3009100E-04,.4028800E-04,.4669300E-04,& + & .2733400E-07,.1915900E-04,.3377300E-04,.4589200E-04,.5231400E-04,& + & .1712300E-07,.9645300E-05,.1668800E-04,.2252800E-04,.2664800E-04,& + & .1848900E-07,.1130500E-04,.1946400E-04,.2613700E-04,.3061700E-04,& + & .1962100E-07,.1314300E-04,.2255400E-04,.3023800E-04,.3487600E-04,& + & .2065300E-07,.1469800E-04,.2592800E-04,.3471200E-04,.3939800E-04,& + & .2150000E-07,.1631500E-04,.2865100E-04,.3930200E-04,.4409700E-04,& + & .1341400E-07,.8335500E-05,.1440900E-04,.1946100E-04,.2258200E-04,& + & .1445600E-07,.9764700E-05,.1681800E-04,.2257800E-04,.2592300E-04,& + & .1541600E-07,.1125000E-04,.1945100E-04,.2611900E-04,.2948200E-04,& + & .1618400E-07,.1252000E-04,.2206400E-04,.2991100E-04,.3323000E-04,& + & .1686100E-07,.1381000E-04,.2433200E-04,.3336300E-04,.3713500E-04/ + + data absb(526:700, 2) / & + & .1057500E-07,.7178600E-05,.1240700E-04,.1671900E-04,.1915800E-04,& + & .1132800E-07,.8409300E-05,.1445700E-04,.1943300E-04,.2194000E-04,& + & .1204900E-07,.9586000E-05,.1671800E-04,.2242500E-04,.2493200E-04,& + & .1268900E-07,.1065500E-04,.1877100E-04,.2564700E-04,.2806500E-04,& + & .1324100E-07,.1170300E-04,.2062800E-04,.2818400E-04,.3132300E-04,& + & .8248900E-08,.6085000E-05,.1050500E-04,.1414000E-04,.1600400E-04,& + & .8853200E-08,.7130600E-05,.1225000E-04,.1646300E-04,.1833300E-04,& + & .9346800E-08,.8026900E-05,.1415800E-04,.1898900E-04,.2083500E-04,& + & .9847800E-08,.8945000E-05,.1569100E-04,.2157600E-04,.2342800E-04,& + & .1033200E-07,.9835400E-05,.1729300E-04,.2361800E-04,.2612800E-04,& + & .6395100E-08,.5054500E-05,.8737800E-05,.1177800E-04,.1317600E-04,& + & .6825200E-08,.5934800E-05,.1019300E-04,.1373000E-04,.1510400E-04,& + & .7244500E-08,.6648000E-05,.1178300E-04,.1583200E-04,.1716000E-04,& + & .7587100E-08,.7396000E-05,.1300500E-04,.1786600E-04,.1929500E-04,& + & .7907500E-08,.8155800E-05,.1430600E-04,.1961700E-04,.2153200E-04,& + & .5057400E-08,.4121500E-05,.7124900E-05,.9592300E-05,.1068600E-04,& + & .5396700E-08,.4851800E-05,.8328600E-05,.1120600E-04,.1226900E-04,& + & .5751700E-08,.5441100E-05,.9638300E-05,.1294200E-04,.1395800E-04,& + & .6027300E-08,.6059000E-05,.1064400E-04,.1461900E-04,.1571400E-04,& + & .6277500E-08,.6690000E-05,.1172300E-04,.1607700E-04,.1756000E-04,& + & .3994800E-08,.3353500E-05,.5797600E-05,.7798900E-05,.8654800E-05,& + & .4264200E-08,.3958400E-05,.6793200E-05,.9129000E-05,.9950700E-05,& + & .4552900E-08,.4447800E-05,.7874600E-05,.1056300E-04,.1133800E-04,& + & .4791100E-08,.4959200E-05,.8701900E-05,.1195000E-04,.1278300E-04,& + & .4995900E-08,.5482000E-05,.9596400E-05,.1315500E-04,.1430800E-04,& + & .3160700E-08,.2726000E-05,.4714300E-05,.6338100E-05,.7009400E-05,& + & .3377100E-08,.3226300E-05,.5535200E-05,.7432200E-05,.8069500E-05,& + & .3590700E-08,.3631600E-05,.6425600E-05,.8613300E-05,.9201900E-05,& + & .3792000E-08,.4055500E-05,.7112800E-05,.9767700E-05,.1039200E-04,& + & .3968700E-08,.4488200E-05,.7849900E-05,.1075300E-04,.1164700E-04,& + & .2513700E-08,.2178200E-05,.3770000E-05,.5063600E-05,.5587200E-05,& + & .2695300E-08,.2587200E-05,.4441100E-05,.5953800E-05,.6469300E-05,& + & .2873800E-08,.2941500E-05,.5169700E-05,.6921700E-05,.7380600E-05,& + & .3036500E-08,.3288700E-05,.5757400E-05,.7911500E-05,.8354700E-05,& + & .3182700E-08,.3639100E-05,.6373000E-05,.8711400E-05,.9385400E-05/ + + data absb(701:875, 2) / & + & .2004900E-08,.1735000E-05,.3008900E-05,.4034200E-05,.4443700E-05,& + & .2152200E-08,.2068500E-05,.3553200E-05,.4754200E-05,.5157700E-05,& + & .2297800E-08,.2371600E-05,.4149000E-05,.5545900E-05,.5902900E-05,& + & .2427700E-08,.2660800E-05,.4658500E-05,.6392800E-05,.6701500E-05,& + & .2559200E-08,.2943400E-05,.5161400E-05,.7037600E-05,.7547200E-05,& + & .1600700E-08,.1379300E-05,.2393900E-05,.3220300E-05,.3534700E-05,& + & .1718200E-08,.1650900E-05,.2838800E-05,.3795000E-05,.4106900E-05,& + & .1836400E-08,.1905800E-05,.3325000E-05,.4438600E-05,.4716900E-05,& + & .1945900E-08,.2143600E-05,.3767600E-05,.5138900E-05,.5371000E-05,& + & .2055500E-08,.2378100E-05,.4172200E-05,.5691500E-05,.6061300E-05,& + & .1276300E-08,.1085500E-05,.1884200E-05,.2535500E-05,.2789400E-05,& + & .1369300E-08,.1303800E-05,.2243400E-05,.2999100E-05,.3245200E-05,& + & .1466900E-08,.1522700E-05,.2639400E-05,.3519500E-05,.3740300E-05,& + & .1562100E-08,.1714500E-05,.3018800E-05,.4088100E-05,.4275700E-05,& + & .1646700E-08,.1909300E-05,.3348100E-05,.4576800E-05,.4835700E-05,& + & .1016400E-08,.8490800E-06,.1474100E-05,.1986400E-05,.2174400E-05,& + & .1092600E-08,.1023200E-05,.1764200E-05,.2353600E-05,.2556200E-05,& + & .1171700E-08,.1215600E-05,.2083600E-05,.2775000E-05,.2954700E-05,& + & .1250200E-08,.1367100E-05,.2414900E-05,.3237400E-05,.3385600E-05,& + & .1320400E-08,.1529000E-05,.2680100E-05,.3663100E-05,.3843000E-05,& + & .8096700E-09,.6624700E-06,.1152500E-05,.1555700E-05,.1691100E-05,& + & .8709100E-09,.8011400E-06,.1383800E-05,.1845700E-05,.2007100E-05,& + & .9347100E-09,.9606300E-06,.1641400E-05,.2186200E-05,.2335700E-05,& + & .9999600E-09,.1089800E-05,.1928700E-05,.2558700E-05,.2676500E-05,& + & .1059400E-08,.1225500E-05,.2143700E-05,.2923900E-05,.3049100E-05,& + & .6443800E-09,.5140800E-06,.8969200E-06,.1217600E-05,.1309400E-05,& + & .6933800E-09,.6233500E-06,.1078300E-05,.1440800E-05,.1569700E-05,& + & .7424900E-09,.7519700E-06,.1285900E-05,.1711600E-05,.1828600E-05,& + & .7971000E-09,.8678500E-06,.1518200E-05,.2011700E-05,.2107200E-05,& + & .8496600E-09,.9792300E-06,.1715600E-05,.2335400E-05,.2409600E-05,& + & .5123600E-09,.3948300E-06,.6910000E-06,.9487100E-06,.1005000E-05,& + & .5507500E-09,.4807500E-06,.8332600E-06,.1117100E-05,.1216900E-05,& + & .5915300E-09,.5827900E-06,.9992200E-06,.1330700E-05,.1422700E-05,& + & .6348500E-09,.6834700E-06,.1184500E-05,.1569600E-05,.1647400E-05,& + & .6783300E-09,.7735900E-06,.1359300E-05,.1832900E-05,.1893300E-05/ + + data absb(876:1050, 2) / & + & .4074900E-09,.3016200E-06,.5340800E-06,.7277700E-06,.7676800E-06,& + & .4368200E-09,.3697500E-06,.6420100E-06,.8617400E-06,.9333400E-06,& + & .4698100E-09,.4501500E-06,.7746000E-06,.1030600E-05,.1109200E-05,& + & .5030200E-09,.5391200E-06,.9217100E-06,.1222500E-05,.1287400E-05,& + & .5399900E-09,.6101300E-06,.1079000E-05,.1433400E-05,.1482800E-05,& + & .3228800E-09,.2311500E-06,.4162500E-06,.5531800E-06,.5847600E-06,& + & .3473100E-09,.2835500E-06,.4949300E-06,.6685000E-06,.7160000E-06,& + & .3731000E-09,.3468200E-06,.5982000E-06,.7961700E-06,.8598500E-06,& + & .3997500E-09,.4203400E-06,.7152700E-06,.9504600E-06,.1004100E-05,& + & .4297000E-09,.4834100E-06,.8482900E-06,.1119100E-05,.1158200E-05,& + & .2564600E-09,.1774300E-06,.3242300E-06,.4217500E-06,.4475400E-06,& + & .2766900E-09,.2185600E-06,.3822000E-06,.5210200E-06,.5514100E-06,& + & .2965400E-09,.2680800E-06,.4637500E-06,.6192100E-06,.6702500E-06,& + & .3187200E-09,.3266200E-06,.5568700E-06,.7398500E-06,.7829100E-06,& + & .3419800E-09,.3813600E-06,.6638500E-06,.8759100E-06,.9077100E-06,& + & .2047200E-09,.1369400E-06,.2472600E-06,.3221600E-06,.3422900E-06,& + & .2205400E-09,.1684200E-06,.2964600E-06,.4063500E-06,.4240200E-06,& + & .2365300E-09,.2073100E-06,.3591300E-06,.4802700E-06,.5171400E-06,& + & .2540200E-09,.2537900E-06,.4337700E-06,.5768900E-06,.6122800E-06,& + & .2723300E-09,.3020200E-06,.5194000E-06,.6862600E-06,.7114600E-06,& + & .1642800E-09,.1068700E-06,.1880300E-06,.2451700E-06,.2609000E-06,& + & .1752000E-09,.1297800E-06,.2302500E-06,.3110600E-06,.3251200E-06,& + & .1886500E-09,.1599400E-06,.2772600E-06,.3726100E-06,.3988800E-06,& + & .2026500E-09,.1967000E-06,.3370800E-06,.4484500E-06,.4777900E-06,& + & .2171100E-09,.2373900E-06,.4052800E-06,.5366800E-06,.5582800E-06,& + & .1320600E-09,.8267700E-07,.1428400E-06,.1864000E-06,.1989800E-06,& + & .1393800E-09,.9959700E-07,.1809500E-06,.2372500E-06,.2491100E-06,& + & .1505600E-09,.1230900E-06,.2149400E-06,.2902600E-06,.3072000E-06,& + & .1613600E-09,.1520500E-06,.2614700E-06,.3477400E-06,.3733100E-06,& + & .1731800E-09,.1854700E-06,.3156600E-06,.4185700E-06,.4364900E-06,& + & .1062800E-09,.6352900E-07,.1093800E-06,.1428500E-06,.1528100E-06,& + & .1118100E-09,.7706800E-07,.1403600E-06,.1820100E-06,.1916300E-06,& + & .1199200E-09,.9538700E-07,.1669200E-06,.2287800E-06,.2382400E-06,& + & .1290000E-09,.1180900E-06,.2040600E-06,.2716300E-06,.2907800E-06,& + & .1382800E-09,.1451000E-06,.2467800E-06,.3275300E-06,.3421700E-06/ + + data absb(1051:1175, 2) / & + & .8566400E-10,.4844400E-07,.8393200E-07,.1095000E-06,.1178500E-06,& + & .8999900E-10,.5988500E-07,.1077600E-06,.1402300E-06,.1476300E-06,& + & .9583600E-10,.7394100E-07,.1302300E-06,.1787600E-06,.1842600E-06,& + & .1032300E-09,.9179100E-07,.1588200E-06,.2120200E-06,.2261100E-06,& + & .1108100E-09,.1133600E-06,.1931600E-06,.2564700E-06,.2691800E-06,& + & .6909300E-10,.3683200E-07,.6412300E-07,.8403000E-07,.9097400E-07,& + & .7243300E-10,.4708400E-07,.8261300E-07,.1075800E-06,.1134600E-06,& + & .7661600E-10,.5738800E-07,.1018200E-06,.1376800E-06,.1422400E-06,& + & .8270900E-10,.7129400E-07,.1235500E-06,.1653000E-06,.1754900E-06,& + & .8863600E-10,.8844500E-07,.1509400E-06,.2006700E-06,.2111800E-06,& + & .5598000E-10,.2801800E-07,.4886700E-07,.6485700E-07,.7005500E-07,& + & .5839700E-10,.3662000E-07,.6323200E-07,.8242800E-07,.8745700E-07,& + & .6150900E-10,.4444600E-07,.8051200E-07,.1058000E-06,.1098800E-06,& + & .6601500E-10,.5522200E-07,.9640100E-07,.1293500E-06,.1361400E-06,& + & .7097600E-10,.6882100E-07,.1178000E-06,.1563200E-06,.1658600E-06,& + & .4572200E-10,.2150600E-07,.3732600E-07,.5033300E-07,.5485500E-07,& + & .4709000E-10,.2824900E-07,.4861200E-07,.6344200E-07,.6755000E-07,& + & .4955000E-10,.3443000E-07,.6276900E-07,.8150900E-07,.8491700E-07,& + & .5281700E-10,.4295800E-07,.7517300E-07,.1020400E-06,.1060300E-06,& + & .5686400E-10,.5363700E-07,.9204400E-07,.1222900E-06,.1301100E-06,& + & .3749600E-10,.1725500E-07,.2996700E-07,.4039400E-07,.4405900E-07,& + & .3836700E-10,.2278200E-07,.3914400E-07,.5101900E-07,.5440400E-07,& + & .4034600E-10,.2784200E-07,.5069200E-07,.6571600E-07,.6844000E-07,& + & .4290800E-10,.3476100E-07,.6084600E-07,.8283400E-07,.8571300E-07,& + & .4621300E-10,.4346700E-07,.7462600E-07,.9914400E-07,.1051800E-06/ + + data absb( 1:175, 3) / & + & .9118000E-05,.1275400E-02,.1990000E-02,.2444000E-02,.4057600E-02,& + & .9503700E-05,.1415000E-02,.2214500E-02,.2809400E-02,.4437500E-02,& + & .9975700E-05,.1562600E-02,.2432000E-02,.3137500E-02,.4809700E-02,& + & .1050800E-04,.1699700E-02,.2692600E-02,.3448300E-02,.5155400E-02,& + & .1103300E-04,.1837300E-02,.2968400E-02,.3786100E-02,.5489600E-02,& + & .7320900E-05,.1072700E-02,.1678700E-02,.2088100E-02,.3304100E-02,& + & .7679500E-05,.1193700E-02,.1868300E-02,.2361600E-02,.3624600E-02,& + & .8041700E-05,.1317700E-02,.2056700E-02,.2646500E-02,.3943800E-02,& + & .8429600E-05,.1431700E-02,.2282600E-02,.2902200E-02,.4236800E-02,& + & .8895000E-05,.1549500E-02,.2508400E-02,.3190100E-02,.4499200E-02,& + & .5827500E-05,.8989500E-03,.1416100E-02,.1776000E-02,.2650800E-02,& + & .6116600E-05,.1002500E-02,.1570600E-02,.1989300E-02,.2921900E-02,& + & .6434000E-05,.1105500E-02,.1737500E-02,.2223700E-02,.3171800E-02,& + & .6750100E-05,.1202800E-02,.1929100E-02,.2443300E-02,.3401500E-02,& + & .7084300E-05,.1303400E-02,.2115200E-02,.2689200E-02,.3635000E-02,& + & .4577600E-05,.7523300E-03,.1190600E-02,.1495700E-02,.2107600E-02,& + & .4826200E-05,.8405100E-03,.1319200E-02,.1678000E-02,.2326700E-02,& + & .5102400E-05,.9260300E-03,.1465300E-02,.1867100E-02,.2524200E-02,& + & .5385600E-05,.1009300E-02,.1628800E-02,.2059900E-02,.2713400E-02,& + & .5662500E-05,.1093900E-02,.1783400E-02,.2269300E-02,.2909200E-02,& + & .3597800E-05,.6305500E-03,.1000100E-02,.1261800E-02,.1675900E-02,& + & .3809000E-05,.7051900E-03,.1108000E-02,.1414200E-02,.1856300E-02,& + & .4036500E-05,.7759300E-03,.1235200E-02,.1569200E-02,.2021500E-02,& + & .4269200E-05,.8464800E-03,.1375300E-02,.1736100E-02,.2188200E-02,& + & .4532500E-05,.9181500E-03,.1503100E-02,.1915600E-02,.2351100E-02,& + & .2857700E-05,.5292300E-03,.8406000E-03,.1064100E-02,.1352400E-02,& + & .3018900E-05,.5927500E-03,.9326400E-03,.1192500E-02,.1505100E-02,& + & .3197100E-05,.6514000E-03,.1042200E-02,.1317400E-02,.1641300E-02,& + & .3398100E-05,.7114400E-03,.1159400E-02,.1461300E-02,.1785100E-02,& + & .3612700E-05,.7720000E-03,.1268500E-02,.1616400E-02,.1916600E-02,& + & .2283200E-05,.4448900E-03,.7052300E-03,.8915000E-03,.1105400E-02,& + & .2400500E-05,.4986000E-03,.7859600E-03,.1003300E-02,.1231000E-02,& + & .2546500E-05,.5474600E-03,.8809600E-03,.1108400E-02,.1347900E-02,& + & .2716700E-05,.5976000E-03,.9768500E-03,.1230500E-02,.1466800E-02,& + & .2892700E-05,.6484400E-03,.1069500E-02,.1363200E-02,.1574600E-02/ + + data absb(176:350, 3) / & + & .1842600E-05,.3756700E-03,.5927600E-03,.7500200E-03,.9115900E-03,& + & .1932400E-05,.4204900E-03,.6637600E-03,.8430400E-03,.1017500E-02,& + & .2056300E-05,.4610400E-03,.7456100E-03,.9356800E-03,.1115300E-02,& + & .2195200E-05,.5030200E-03,.8249100E-03,.1041000E-02,.1213100E-02,& + & .2342900E-05,.5457000E-03,.9032400E-03,.1151200E-02,.1300200E-02,& + & .1491400E-05,.3172700E-03,.4987900E-03,.6314100E-03,.7548000E-03,& + & .1571100E-05,.3536700E-03,.5610500E-03,.7085900E-03,.8427800E-03,& + & .1672000E-05,.3877600E-03,.6312200E-03,.7906600E-03,.9249200E-03,& + & .1783000E-05,.4232700E-03,.6965500E-03,.8831100E-03,.1004100E-02,& + & .1906500E-05,.4590500E-03,.7623800E-03,.9732000E-03,.1076700E-02,& + & .1200700E-05,.2697600E-03,.4231600E-03,.5375000E-03,.6274700E-03,& + & .1274400E-05,.2988000E-03,.4784000E-03,.6009400E-03,.7013400E-03,& + & .1357200E-05,.3281300E-03,.5367200E-03,.6734100E-03,.7691600E-03,& + & .1445900E-05,.3576100E-03,.5915400E-03,.7542100E-03,.8337100E-03,& + & .1553800E-05,.3879200E-03,.6466300E-03,.8287700E-03,.8952900E-03,& + & .9686100E-06,.2291800E-03,.3601500E-03,.4571900E-03,.5240400E-03,& + & .1033600E-05,.2532100E-03,.4083400E-03,.5116100E-03,.5835100E-03,& + & .1098500E-05,.2776700E-03,.4557100E-03,.5745900E-03,.6398500E-03,& + & .1176800E-05,.3025200E-03,.5019500E-03,.6419000E-03,.6930300E-03,& + & .1261500E-05,.3279400E-03,.5483100E-03,.7057900E-03,.7454000E-03,& + & .7756000E-06,.1943700E-03,.3074800E-03,.3882800E-03,.4352900E-03,& + & .8258000E-06,.2143800E-03,.3483500E-03,.4361700E-03,.4837300E-03,& + & .8820000E-06,.2349200E-03,.3868000E-03,.4916900E-03,.5318900E-03,& + & .9494700E-06,.2557300E-03,.4263500E-03,.5464100E-03,.5763700E-03,& + & .1018200E-05,.2774500E-03,.4660700E-03,.6004600E-03,.6199800E-03,& + & .6196300E-06,.1645400E-03,.2628400E-03,.3301600E-03,.3628400E-03,& + & .6614600E-06,.1816200E-03,.2971400E-03,.3731500E-03,.4037000E-03,& + & .7111100E-06,.1988200E-03,.3294200E-03,.4213000E-03,.4438200E-03,& + & .7657300E-06,.2166300E-03,.3622800E-03,.4664000E-03,.4805200E-03,& + & .8210000E-06,.2350300E-03,.3962700E-03,.5113200E-03,.5177600E-03,& + & .4971800E-06,.1398200E-03,.2252300E-03,.2827500E-03,.3055800E-03,& + & .5336500E-06,.1543100E-03,.2536800E-03,.3204400E-03,.3389500E-03,& + & .5770500E-06,.1688400E-03,.2808200E-03,.3601900E-03,.3717300E-03,& + & .6206100E-06,.1839300E-03,.3086500E-03,.3986600E-03,.4024300E-03,& + & .6642700E-06,.1996800E-03,.3375700E-03,.4366300E-03,.4330900E-03/ + + data absb(351:525, 3) / & + & .3996100E-06,.1188900E-03,.1936100E-03,.2427000E-03,.2569300E-03,& + & .4313600E-06,.1310000E-03,.2163200E-03,.2759100E-03,.2846300E-03,& + & .4649000E-06,.1433300E-03,.2396600E-03,.3084900E-03,.3110600E-03,& + & .5000900E-06,.1563000E-03,.2634600E-03,.3408300E-03,.3371300E-03,& + & .5380800E-06,.1699900E-03,.2876800E-03,.3732300E-03,.3627900E-03,& + & .3198600E-06,.1010600E-03,.1658500E-03,.2089100E-03,.2155800E-03,& + & .3454000E-06,.1111900E-03,.1850000E-03,.2376000E-03,.2385400E-03,& + & .3722600E-06,.1218300E-03,.2045600E-03,.2641900E-03,.2605300E-03,& + & .4031700E-06,.1329000E-03,.2248700E-03,.2915600E-03,.2826200E-03,& + & .4327100E-06,.1448200E-03,.2454100E-03,.3193400E-03,.3041900E-03,& + & .2567700E-06,.8606000E-04,.1420600E-03,.1802300E-03,.1814100E-03,& + & .2773600E-06,.9467700E-04,.1584100E-03,.2037800E-03,.2008800E-03,& + & .3010400E-06,.1037200E-03,.1751500E-03,.2266300E-03,.2192100E-03,& + & .3258400E-06,.1134000E-03,.1923200E-03,.2495300E-03,.2378900E-03,& + & .3489100E-06,.1236800E-03,.2097600E-03,.2736400E-03,.2557000E-03,& + & .2055600E-06,.7327400E-04,.1217000E-03,.1558800E-03,.1531200E-03,& + & .2237600E-06,.8065100E-04,.1356800E-03,.1752400E-03,.1694800E-03,& + & .2431300E-06,.8848100E-04,.1499200E-03,.1944700E-03,.1847700E-03,& + & .2623300E-06,.9682400E-04,.1645800E-03,.2140900E-03,.2002700E-03,& + & .2824900E-06,.1058000E-03,.1798700E-03,.2343500E-03,.2153200E-03,& + & .1655300E-06,.6253600E-04,.1045700E-03,.1344300E-03,.1296800E-03,& + & .1807800E-06,.6886300E-04,.1164300E-03,.1506000E-03,.1430400E-03,& + & .1961900E-06,.7567000E-04,.1286400E-03,.1668100E-03,.1561500E-03,& + & .2115800E-06,.8289900E-04,.1411400E-03,.1838500E-03,.1691100E-03,& + & .2291500E-06,.9062900E-04,.1545600E-03,.2009900E-03,.1814600E-03,& + & .1338000E-06,.5340700E-04,.8993000E-04,.1159100E-03,.1100500E-03,& + & .1460400E-06,.5888700E-04,.1000100E-03,.1296300E-03,.1210700E-03,& + & .1584800E-06,.6479000E-04,.1104000E-03,.1434900E-03,.1323000E-03,& + & .1719000E-06,.7116900E-04,.1212500E-03,.1579200E-03,.1429700E-03,& + & .1858700E-06,.7779200E-04,.1329200E-03,.1726500E-03,.1530800E-03,& + & .1083000E-06,.4568600E-04,.7733900E-04,.9986700E-04,.9356200E-04,& + & .1176500E-06,.5052600E-04,.8595900E-04,.1115300E-03,.1026900E-03,& + & .1282400E-06,.5562700E-04,.9490000E-04,.1235400E-03,.1120500E-03,& + & .1395800E-06,.6115800E-04,.1044000E-03,.1357300E-03,.1209900E-03,& + & .1507800E-06,.6690900E-04,.1143100E-03,.1486100E-03,.1291800E-03/ + + data absb(526:700, 3) / & + & .8753700E-07,.3907300E-04,.6633000E-04,.8586000E-04,.7929600E-04,& + & .9527000E-07,.4328200E-04,.7374300E-04,.9573300E-04,.8708200E-04,& + & .1042300E-06,.4770100E-04,.8144700E-04,.1060900E-03,.9485700E-04,& + & .1134800E-06,.5248400E-04,.8962400E-04,.1163800E-03,.1021100E-03,& + & .1228900E-06,.5743100E-04,.9812200E-04,.1276000E-03,.1086600E-03,& + & .6989100E-07,.3312900E-04,.5632300E-04,.7303600E-04,.6656800E-04,& + & .7646500E-07,.3672400E-04,.6262700E-04,.8152000E-04,.7317600E-04,& + & .8383300E-07,.4061900E-04,.6929300E-04,.9016100E-04,.7954800E-04,& + & .9143600E-07,.4467100E-04,.7636200E-04,.9907500E-04,.8549700E-04,& + & .9926300E-07,.4888600E-04,.8355000E-04,.1084900E-03,.9072000E-04,& + & .5508000E-07,.2779600E-04,.4726100E-04,.6129900E-04,.5523700E-04,& + & .6056200E-07,.3085000E-04,.5263500E-04,.6851500E-04,.6079400E-04,& + & .6644000E-07,.3420000E-04,.5829800E-04,.7584700E-04,.6609700E-04,& + & .7291300E-07,.3765000E-04,.6431000E-04,.8353000E-04,.7103200E-04,& + & .7954500E-07,.4121600E-04,.7039700E-04,.9130400E-04,.7519300E-04,& + & .4364400E-07,.2299700E-04,.3908800E-04,.5071400E-04,.4537400E-04,& + & .4818200E-07,.2558500E-04,.4366100E-04,.5681300E-04,.5005700E-04,& + & .5306700E-07,.2842900E-04,.4846500E-04,.6302000E-04,.5449000E-04,& + & .5834900E-07,.3136500E-04,.5360300E-04,.6951600E-04,.5858500E-04,& + & .6372700E-07,.3439800E-04,.5871000E-04,.7603200E-04,.6204600E-04,& + & .3466100E-07,.1900300E-04,.3229500E-04,.4189800E-04,.3720700E-04,& + & .3841400E-07,.2120000E-04,.3617000E-04,.4704500E-04,.4115000E-04,& + & .4237800E-07,.2360500E-04,.4024700E-04,.5230600E-04,.4487200E-04,& + & .4659800E-07,.2611000E-04,.4462000E-04,.5780000E-04,.4829300E-04,& + & .5099500E-07,.2868300E-04,.4893500E-04,.6325000E-04,.5115500E-04,& + & .2754500E-07,.1570000E-04,.2666100E-04,.3460300E-04,.3048700E-04,& + & .3055300E-07,.1756800E-04,.2994800E-04,.3893500E-04,.3381300E-04,& + & .3377200E-07,.1960100E-04,.3341100E-04,.4340300E-04,.3692200E-04,& + & .3716400E-07,.2172600E-04,.3711300E-04,.4803000E-04,.3977100E-04,& + & .4079500E-07,.2390100E-04,.4076500E-04,.5260700E-04,.4215200E-04,& + & .2185200E-07,.1281900E-04,.2175700E-04,.2822100E-04,.2474500E-04,& + & .2420700E-07,.1439500E-04,.2452700E-04,.3186700E-04,.2750200E-04,& + & .2680600E-07,.1609200E-04,.2746200E-04,.3564600E-04,.3014500E-04,& + & .2961200E-07,.1789400E-04,.3057200E-04,.3952700E-04,.3254300E-04,& + & .3257700E-07,.1974600E-04,.3367200E-04,.4339900E-04,.3455600E-04/ + + data absb(701:875, 3) / & + & .1733600E-07,.1044100E-04,.1769500E-04,.2295400E-04,.2004200E-04,& + & .1918700E-07,.1177100E-04,.2002500E-04,.2602900E-04,.2234600E-04,& + & .2131100E-07,.1319000E-04,.2251600E-04,.2920100E-04,.2457700E-04,& + & .2359700E-07,.1471200E-04,.2512200E-04,.3246600E-04,.2658400E-04,& + & .2595800E-07,.1628000E-04,.2774400E-04,.3576200E-04,.2829500E-04,& + & .1375200E-07,.8497000E-05,.1437900E-04,.1864000E-04,.1620500E-04,& + & .1524000E-07,.9608200E-05,.1632500E-04,.2122500E-04,.1812400E-04,& + & .1692400E-07,.1080200E-04,.1843000E-04,.2389600E-04,.2002400E-04,& + & .1876700E-07,.1208700E-04,.2060900E-04,.2665100E-04,.2169800E-04,& + & .2066600E-07,.1340900E-04,.2283700E-04,.2942700E-04,.2315300E-04,& + & .1082700E-07,.6862400E-05,.1158600E-04,.1499900E-04,.1297500E-04,& + & .1203000E-07,.7784700E-05,.1320500E-04,.1716400E-04,.1460500E-04,& + & .1335200E-07,.8777900E-05,.1497400E-04,.1941000E-04,.1623100E-04,& + & .1482900E-07,.9862000E-05,.1679500E-04,.2175100E-04,.1763400E-04,& + & .1639600E-07,.1097500E-04,.1868200E-04,.2406600E-04,.1887900E-04,& + & .8573100E-08,.5513200E-05,.9286200E-05,.1200000E-04,.1034700E-04,& + & .9503300E-08,.6281600E-05,.1062900E-04,.1381700E-04,.1171200E-04,& + & .1053700E-07,.7096400E-05,.1210800E-04,.1570000E-04,.1309500E-04,& + & .1172200E-07,.8012000E-05,.1362100E-04,.1767900E-04,.1429600E-04,& + & .1299100E-07,.8945700E-05,.1522000E-04,.1961400E-04,.1535000E-04,& + & .6751500E-08,.4421200E-05,.7424400E-05,.9577600E-05,.8242900E-05,& + & .7499900E-08,.5060300E-05,.8536000E-05,.1109500E-04,.9379100E-05,& + & .8318200E-08,.5741100E-05,.9768600E-05,.1266700E-04,.1052800E-04,& + & .9252600E-08,.6494200E-05,.1102800E-04,.1432800E-04,.1156600E-04,& + & .1026900E-07,.7276900E-05,.1237500E-04,.1596400E-04,.1247200E-04,& + & .5303100E-08,.3530100E-05,.5905000E-05,.7596500E-05,.6545200E-05,& + & .5890700E-08,.4056100E-05,.6823300E-05,.8862100E-05,.7477100E-05,& + & .6542200E-08,.4627000E-05,.7839300E-05,.1016900E-04,.8437000E-05,& + & .7266900E-08,.5243300E-05,.8906100E-05,.1156300E-04,.9326800E-05,& + & .8088000E-08,.5896700E-05,.1001600E-04,.1293000E-04,.1010600E-04,& + & .4145900E-08,.2796500E-05,.4652900E-05,.5964800E-05,.5155200E-05,& + & .4632400E-08,.3225300E-05,.5410000E-05,.7009400E-05,.5911000E-05,& + & .5143300E-08,.3701400E-05,.6239500E-05,.8097600E-05,.6710000E-05,& + & .5704500E-08,.4209100E-05,.7138100E-05,.9253700E-05,.7489600E-05,& + & .6352600E-08,.4754100E-05,.8057300E-05,.1042800E-04,.8154000E-05/ + + data absb(876:1050, 3) / & + & .3254900E-08,.2208900E-05,.3657100E-05,.4666300E-05,.4038700E-05,& + & .3619200E-08,.2558100E-05,.4275200E-05,.5526500E-05,.4658200E-05,& + & .4021500E-08,.2951500E-05,.4955300E-05,.6432700E-05,.5323600E-05,& + & .4473600E-08,.3369000E-05,.5701500E-05,.7385900E-05,.5996000E-05,& + & .4976000E-08,.3827600E-05,.6459600E-05,.8384400E-05,.6564700E-05,& + & .2543200E-08,.1739000E-05,.2860700E-05,.3643800E-05,.3142500E-05,& + & .2836400E-08,.2021900E-05,.3369800E-05,.4341200E-05,.3665400E-05,& + & .3160100E-08,.2347200E-05,.3923200E-05,.5096400E-05,.4214200E-05,& + & .3510100E-08,.2694800E-05,.4542900E-05,.5879700E-05,.4771500E-05,& + & .3898900E-08,.3071800E-05,.5173100E-05,.6719000E-05,.5272000E-05,& + & .2009300E-08,.1370400E-05,.2237300E-05,.2837500E-05,.2455000E-05,& + & .2227000E-08,.1602000E-05,.2662600E-05,.3414400E-05,.2896300E-05,& + & .2479700E-08,.1868600E-05,.3113100E-05,.4034800E-05,.3339800E-05,& + & .2761400E-08,.2159300E-05,.3619900E-05,.4685600E-05,.3801900E-05,& + & .3067400E-08,.2469900E-05,.4151700E-05,.5384400E-05,.4232200E-05,& + & .1590700E-08,.1080300E-05,.1751800E-05,.2206400E-05,.1925400E-05,& + & .1750900E-08,.1269100E-05,.2100000E-05,.2679400E-05,.2283200E-05,& + & .1950900E-08,.1486100E-05,.2472600E-05,.3195700E-05,.2641800E-05,& + & .2170300E-08,.1728400E-05,.2883800E-05,.3732500E-05,.3025700E-05,& + & .2412400E-08,.1984400E-05,.3330500E-05,.4312800E-05,.3401500E-05,& + & .1256400E-08,.8466900E-06,.1371700E-05,.1714700E-05,.1494700E-05,& + & .1379400E-08,.1002400E-05,.1652300E-05,.2099300E-05,.1787000E-05,& + & .1532000E-08,.1179000E-05,.1957700E-05,.2522000E-05,.2084500E-05,& + & .1713000E-08,.1379100E-05,.2295200E-05,.2967700E-05,.2404000E-05,& + & .1904100E-08,.1591400E-05,.2663500E-05,.3443900E-05,.2724700E-05,& + & .9952300E-09,.6621900E-06,.1063200E-05,.1334100E-05,.1155000E-05,& + & .1090300E-08,.7902200E-06,.1291400E-05,.1640100E-05,.1392900E-05,& + & .1208200E-08,.9326600E-06,.1544500E-05,.1984100E-05,.1645200E-05,& + & .1343700E-08,.1096900E-05,.1821200E-05,.2351700E-05,.1902900E-05,& + & .1497200E-08,.1273400E-05,.2127600E-05,.2743100E-05,.2172200E-05,& + & .7878200E-09,.5199300E-06,.8275200E-06,.1042100E-05,.8863200E-06,& + & .8664200E-09,.6244000E-06,.1013800E-05,.1282000E-05,.1095800E-05,& + & .9514100E-09,.7405100E-06,.1222100E-05,.1562600E-05,.1301400E-05,& + & .1062200E-08,.8743800E-06,.1448100E-05,.1867500E-05,.1513800E-05,& + & .1182900E-08,.1021700E-05,.1702500E-05,.2190000E-05,.1734900E-05/ + + data absb(1051:1175, 3) / & + & .6273400E-09,.4084400E-06,.6467500E-06,.8116800E-06,.6801500E-06,& + & .6867000E-09,.4943700E-06,.7982200E-06,.1003100E-05,.8595500E-06,& + & .7555100E-09,.5881300E-06,.9664000E-06,.1230500E-05,.1029000E-05,& + & .8389600E-09,.6976200E-06,.1152900E-05,.1484500E-05,.1202500E-05,& + & .9372700E-09,.8199200E-06,.1361800E-05,.1748900E-05,.1385600E-05,& + & .5021400E-09,.3202800E-06,.5052400E-06,.6314700E-06,.5190300E-06,& + & .5477500E-09,.3884100E-06,.6258900E-06,.7844500E-06,.6709900E-06,& + & .5997100E-09,.4660200E-06,.7635600E-06,.9697800E-06,.8091200E-06,& + & .6646600E-09,.5550900E-06,.9153300E-06,.1176600E-05,.9528400E-06,& + & .7393100E-09,.6562500E-06,.1086400E-05,.1394600E-05,.1105500E-05,& + & .4017100E-09,.2500900E-06,.3921100E-06,.4925000E-06,.3933200E-06,& + & .4337900E-09,.3047300E-06,.4893200E-06,.6134200E-06,.5207600E-06,& + & .4772900E-09,.3687400E-06,.5997800E-06,.7624600E-06,.6355600E-06,& + & .5245400E-09,.4407500E-06,.7248800E-06,.9307900E-06,.7544800E-06,& + & .5854600E-09,.5238900E-06,.8656500E-06,.1110700E-05,.8785800E-06,& + & .3222200E-09,.1953600E-06,.3048400E-06,.3812300E-06,.2979800E-06,& + & .3455000E-09,.2400300E-06,.3820600E-06,.4803300E-06,.4019300E-06,& + & .3793000E-09,.2917900E-06,.4722600E-06,.5993800E-06,.5005600E-06,& + & .4167500E-09,.3503500E-06,.5750000E-06,.7364200E-06,.5983600E-06,& + & .4632000E-09,.4185400E-06,.6904100E-06,.8854800E-06,.7000300E-06,& + & .2616600E-09,.1586800E-06,.2469700E-06,.3089200E-06,.2396400E-06,& + & .2809500E-09,.1955200E-06,.3106800E-06,.3903700E-06,.3246900E-06,& + & .3073000E-09,.2385600E-06,.3855400E-06,.4890200E-06,.4073800E-06,& + & .3378100E-09,.2874900E-06,.4715700E-06,.6028600E-06,.4880300E-06,& + & .3752600E-09,.3443900E-06,.5678900E-06,.7274200E-06,.5723800E-06/ + + data absb( 1:175, 4) / & + & .4903800E-04,.5078100E-02,.7825400E-02,.9648400E-02,.1061400E-01,& + & .5422500E-04,.5490500E-02,.8571000E-02,.1046000E-01,.1120600E-01,& + & .6113400E-04,.5877300E-02,.9318300E-02,.1134700E-01,.1172900E-01,& + & .6879300E-04,.6279400E-02,.9976800E-02,.1224800E-01,.1225000E-01,& + & .7742900E-04,.6689300E-02,.1062400E-01,.1306400E-01,.1273000E-01,& + & .4070600E-04,.4304500E-02,.6624000E-02,.8122700E-02,.8710500E-02,& + & .4578900E-04,.4640400E-02,.7254700E-02,.8850800E-02,.9218300E-02,& + & .5135900E-04,.4967000E-02,.7864900E-02,.9592800E-02,.9659000E-02,& + & .5844800E-04,.5311200E-02,.8416500E-02,.1035600E-01,.1008500E-01,& + & .6658500E-04,.5659000E-02,.8977000E-02,.1102200E-01,.1054000E-01,& + & .3316100E-04,.3637400E-02,.5600700E-02,.6840800E-02,.7039900E-02,& + & .3731600E-04,.3914500E-02,.6131800E-02,.7481200E-02,.7453300E-02,& + & .4218400E-04,.4194900E-02,.6627200E-02,.8109700E-02,.7839300E-02,& + & .4824900E-04,.4486100E-02,.7093400E-02,.8733000E-02,.8226200E-02,& + & .5491200E-04,.4782900E-02,.7568800E-02,.9283000E-02,.8605800E-02,& + & .2659800E-04,.3064900E-02,.4732300E-02,.5774200E-02,.5664400E-02,& + & .3009600E-04,.3295000E-02,.5177800E-02,.6314500E-02,.6019300E-02,& + & .3408500E-04,.3535000E-02,.5580600E-02,.6844700E-02,.6370800E-02,& + & .3891900E-04,.3783100E-02,.5971900E-02,.7346500E-02,.6708800E-02,& + & .4449200E-04,.4039300E-02,.6375000E-02,.7812000E-02,.7024900E-02,& + & .2144900E-04,.2575600E-02,.3993600E-02,.4866200E-02,.4620500E-02,& + & .2410300E-04,.2770600E-02,.4361900E-02,.5316400E-02,.4920200E-02,& + & .2745100E-04,.2976500E-02,.4695900E-02,.5763200E-02,.5212200E-02,& + & .3138100E-04,.3188400E-02,.5022200E-02,.6173500E-02,.5479000E-02,& + & .3595300E-04,.3409900E-02,.5364500E-02,.6565900E-02,.5741900E-02,& + & .1746800E-04,.2164200E-02,.3364200E-02,.4097200E-02,.3792100E-02,& + & .1950600E-04,.2330800E-02,.3668300E-02,.4469600E-02,.4038500E-02,& + & .2232600E-04,.2507200E-02,.3945400E-02,.4850700E-02,.4277300E-02,& + & .2555800E-04,.2690100E-02,.4224000E-02,.5185500E-02,.4500000E-02,& + & .2951900E-04,.2881600E-02,.4513500E-02,.5516800E-02,.4725900E-02,& + & .1416200E-04,.1816500E-02,.2831100E-02,.3449100E-02,.3126300E-02,& + & .1588000E-04,.1959400E-02,.3079200E-02,.3757700E-02,.3327700E-02,& + & .1825000E-04,.2112400E-02,.3311000E-02,.4071700E-02,.3525500E-02,& + & .2094800E-04,.2271100E-02,.3551200E-02,.4354100E-02,.3711400E-02,& + & .2427900E-04,.2436000E-02,.3797200E-02,.4633600E-02,.3906300E-02/ + + data absb(176:350, 4) / & + & .1167700E-04,.1526800E-02,.2385400E-02,.2905400E-02,.2592700E-02,& + & .1312700E-04,.1650200E-02,.2588400E-02,.3164200E-02,.2758400E-02,& + & .1514500E-04,.1782700E-02,.2785400E-02,.3419800E-02,.2922800E-02,& + & .1742600E-04,.1920800E-02,.2991900E-02,.3656300E-02,.3083600E-02,& + & .2018700E-04,.2063800E-02,.3202700E-02,.3895500E-02,.3251700E-02,& + & .9624800E-05,.1283900E-02,.2006900E-02,.2443900E-02,.2152100E-02,& + & .1088400E-04,.1390500E-02,.2175300E-02,.2663400E-02,.2290100E-02,& + & .1257600E-04,.1505700E-02,.2343000E-02,.2871400E-02,.2427100E-02,& + & .1449200E-04,.1624500E-02,.2522900E-02,.3070900E-02,.2565300E-02,& + & .1678500E-04,.1748700E-02,.2705300E-02,.3276900E-02,.2704100E-02,& + & .7898700E-05,.1084100E-02,.1696300E-02,.2064600E-02,.1792000E-02,& + & .9068800E-05,.1178300E-02,.1836400E-02,.2252300E-02,.1905400E-02,& + & .1043600E-04,.1277600E-02,.1983200E-02,.2422000E-02,.2020000E-02,& + & .1205100E-04,.1380000E-02,.2139100E-02,.2590400E-02,.2136400E-02,& + & .1399200E-04,.1487700E-02,.2298300E-02,.2769000E-02,.2251900E-02,& + & .6514300E-05,.9162900E-03,.1433700E-02,.1746800E-02,.1489000E-02,& + & .7529500E-05,.9988000E-03,.1553200E-02,.1901700E-02,.1584400E-02,& + & .8617200E-05,.1084300E-02,.1682800E-02,.2045400E-02,.1682200E-02,& + & .1001700E-04,.1172900E-02,.1817600E-02,.2191200E-02,.1780000E-02,& + & .1164000E-04,.1266800E-02,.1954900E-02,.2344700E-02,.1876500E-02,& + & .5343200E-05,.7757100E-03,.1211400E-02,.1480500E-02,.1237200E-02,& + & .6151500E-05,.8471800E-03,.1315300E-02,.1607800E-02,.1318100E-02,& + & .7092300E-05,.9202400E-03,.1429300E-02,.1730000E-02,.1398900E-02,& + & .8268400E-05,.9974000E-03,.1544700E-02,.1857300E-02,.1481100E-02,& + & .9626800E-05,.1078900E-02,.1662700E-02,.1989200E-02,.1562100E-02,& + & .4393200E-05,.6589800E-03,.1025900E-02,.1256800E-02,.1028700E-02,& + & .5048300E-05,.7197300E-03,.1117400E-02,.1361000E-02,.1097300E-02,& + & .5852700E-05,.7826900E-03,.1215700E-02,.1465800E-02,.1164800E-02,& + & .6825800E-05,.8496800E-03,.1315800E-02,.1577400E-02,.1235400E-02,& + & .7978000E-05,.9209300E-03,.1417100E-02,.1691700E-02,.1302900E-02,& + & .3634900E-05,.5613900E-03,.8723200E-03,.1067100E-02,.8574700E-03,& + & .4176300E-05,.6130700E-03,.9528400E-03,.1155900E-02,.9164000E-03,& + & .4864300E-05,.6676900E-03,.1037700E-02,.1248000E-02,.9741700E-03,& + & .5680600E-05,.7261800E-03,.1123800E-02,.1344300E-02,.1034100E-02,& + & .6657400E-05,.7879100E-03,.1211800E-02,.1442600E-02,.1090800E-02/ + + data absb(351:525, 4) / & + & .2984900E-05,.4784500E-03,.7432400E-03,.9069500E-03,.7165400E-03,& + & .3452800E-05,.5230500E-03,.8140700E-03,.9834800E-03,.7662200E-03,& + & .4038600E-05,.5706700E-03,.8863500E-03,.1064300E-02,.8161700E-03,& + & .4734900E-05,.6215900E-03,.9604500E-03,.1147600E-02,.8666700E-03,& + & .5550400E-05,.6748600E-03,.1037300E-02,.1232700E-02,.9143700E-03,& + & .2447400E-05,.4081900E-03,.6346900E-03,.7718400E-03,.5995900E-03,& + & .2852700E-05,.4469400E-03,.6955000E-03,.8380900E-03,.6415100E-03,& + & .3344400E-05,.4880400E-03,.7579700E-03,.9092100E-03,.6846400E-03,& + & .3933200E-05,.5322900E-03,.8217400E-03,.9810300E-03,.7268000E-03,& + & .4624500E-05,.5786400E-03,.8887200E-03,.1054400E-02,.7672300E-03,& + & .2025300E-05,.3492100E-03,.5436500E-03,.6586500E-03,.5033100E-03,& + & .2372000E-05,.3827800E-03,.5957700E-03,.7172900E-03,.5386400E-03,& + & .2794500E-05,.4188700E-03,.6490700E-03,.7782300E-03,.5758100E-03,& + & .3293600E-05,.4569900E-03,.7048100E-03,.8407400E-03,.6108900E-03,& + & .3888100E-05,.4975700E-03,.7632500E-03,.9035600E-03,.6456400E-03,& + & .1679700E-05,.2991800E-03,.4659800E-03,.5631600E-03,.4227000E-03,& + & .1976400E-05,.3283900E-03,.5107600E-03,.6143900E-03,.4530600E-03,& + & .2338400E-05,.3598500E-03,.5568600E-03,.6671200E-03,.4844500E-03,& + & .2766200E-05,.3930200E-03,.6052500E-03,.7209200E-03,.5142500E-03,& + & .3268700E-05,.4283700E-03,.6561000E-03,.7757000E-03,.5439600E-03,& + & .1399100E-05,.2568700E-03,.3999600E-03,.4830700E-03,.3557000E-03,& + & .1656400E-05,.2824600E-03,.4385800E-03,.5274300E-03,.3821100E-03,& + & .1966000E-05,.3097100E-03,.4785600E-03,.5730900E-03,.4082600E-03,& + & .2333400E-05,.3388100E-03,.5206600E-03,.6191900E-03,.4336700E-03,& + & .2758700E-05,.3696400E-03,.5649900E-03,.6666000E-03,.4596900E-03,& + & .1171100E-05,.2210200E-03,.3439400E-03,.4151200E-03,.2998000E-03,& + & .1392800E-05,.2433700E-03,.3771300E-03,.4535100E-03,.3225300E-03,& + & .1658900E-05,.2670400E-03,.4120200E-03,.4927200E-03,.3444200E-03,& + & .1974000E-05,.2926100E-03,.4485500E-03,.5327400E-03,.3663300E-03,& + & .2332300E-05,.3197300E-03,.4872600E-03,.5738300E-03,.3891500E-03,& + & .9830000E-06,.1904700E-03,.2959200E-03,.3573900E-03,.2530300E-03,& + & .1175100E-05,.2098300E-03,.3247400E-03,.3904300E-03,.2725900E-03,& + & .1402700E-05,.2306500E-03,.3550500E-03,.4240500E-03,.2912000E-03,& + & .1669200E-05,.2530200E-03,.3869900E-03,.4588800E-03,.3101800E-03,& + & .1971600E-05,.2771500E-03,.4211900E-03,.4946800E-03,.3298900E-03/ + + data absb(526:700, 4) / & + & .8291500E-06,.1639600E-03,.2543300E-03,.3070000E-03,.2140600E-03,& + & .9935200E-06,.1808300E-03,.2793500E-03,.3355200E-03,.2304800E-03,& + & .1187700E-05,.1991500E-03,.3057800E-03,.3645500E-03,.2465900E-03,& + & .1413900E-05,.2188600E-03,.3338400E-03,.3947600E-03,.2631700E-03,& + & .1667000E-05,.2402100E-03,.3639000E-03,.4260300E-03,.2800500E-03,& + & .6867000E-06,.1397900E-03,.2167300E-03,.2616100E-03,.1797400E-03,& + & .8243700E-06,.1544800E-03,.2384600E-03,.2861100E-03,.1937700E-03,& + & .9864900E-06,.1704400E-03,.2613900E-03,.3113200E-03,.2076500E-03,& + & .1174000E-05,.1877300E-03,.2860900E-03,.3374000E-03,.2219700E-03,& + & .1383300E-05,.2065200E-03,.3123300E-03,.3644900E-03,.2365800E-03,& + & .5556400E-06,.1178600E-03,.1828300E-03,.2208900E-03,.1495100E-03,& + & .6673100E-06,.1305300E-03,.2015100E-03,.2418900E-03,.1614600E-03,& + & .8004800E-06,.1443200E-03,.2215400E-03,.2636400E-03,.1734800E-03,& + & .9519500E-06,.1593700E-03,.2431000E-03,.2860900E-03,.1857700E-03,& + & .1121700E-05,.1758000E-03,.2660100E-03,.3094900E-03,.1985000E-03,& + & .4452600E-06,.9833400E-04,.1523600E-03,.1839500E-03,.1236900E-03,& + & .5355100E-06,.1092700E-03,.1683700E-03,.2019400E-03,.1338700E-03,& + & .6430700E-06,.1211000E-03,.1855600E-03,.2205900E-03,.1441800E-03,& + & .7668800E-06,.1341100E-03,.2041400E-03,.2398500E-03,.1547700E-03,& + & .9059100E-06,.1484200E-03,.2240500E-03,.2599600E-03,.1656600E-03,& + & .3563000E-06,.8199100E-04,.1269000E-03,.1531200E-03,.1022600E-03,& + & .4291100E-06,.9139100E-04,.1406400E-03,.1684900E-03,.1109500E-03,& + & .5158300E-06,.1016300E-03,.1553800E-03,.1844800E-03,.1197700E-03,& + & .6165400E-06,.1128700E-03,.1713800E-03,.2010100E-03,.1288400E-03,& + & .7302800E-06,.1253000E-03,.1886200E-03,.2182600E-03,.1381600E-03,& + & .2845500E-06,.6836200E-04,.1057200E-03,.1274700E-03,.8449400E-04,& + & .3431300E-06,.7641300E-04,.1175100E-03,.1406000E-03,.9190500E-04,& + & .4130500E-06,.8529900E-04,.1301600E-03,.1543100E-03,.9946300E-04,& + & .4946600E-06,.9504700E-04,.1439600E-03,.1685100E-03,.1072500E-03,& + & .5872100E-06,.1058300E-03,.1588600E-03,.1833200E-03,.1151600E-03,& + & .2241600E-06,.5645100E-04,.8719200E-04,.1050300E-03,.6929900E-04,& + & .2705800E-06,.6332500E-04,.9724100E-04,.1162500E-03,.7563500E-04,& + & .3264000E-06,.7094200E-04,.1080100E-03,.1279200E-03,.8206100E-04,& + & .3917800E-06,.7938100E-04,.1198500E-03,.1400500E-03,.8872200E-04,& + & .4669400E-06,.8867300E-04,.1326100E-03,.1527400E-03,.9543700E-04/ + + data absb(701:875, 4) / & + & .1762000E-06,.4649500E-04,.7182900E-04,.8635100E-04,.5670100E-04,& + & .2129500E-06,.5238300E-04,.8038000E-04,.9593700E-04,.6210000E-04,& + & .2572000E-06,.5890000E-04,.8954800E-04,.1059400E-03,.6756800E-04,& + & .3095700E-06,.6613600E-04,.9964300E-04,.1162300E-03,.7328000E-04,& + & .3700300E-06,.7420300E-04,.1106100E-03,.1270700E-03,.7897900E-04,& + & .1384300E-06,.3823800E-04,.5912400E-04,.7098200E-04,.4633100E-04,& + & .1672600E-06,.4326900E-04,.6642400E-04,.7912500E-04,.5095600E-04,& + & .2023200E-06,.4887000E-04,.7424700E-04,.8766100E-04,.5556100E-04,& + & .2440800E-06,.5511900E-04,.8282700E-04,.9645300E-04,.6044700E-04,& + & .2927600E-06,.6202800E-04,.9222100E-04,.1057000E-03,.6528100E-04,& + & .1079300E-06,.3119100E-04,.4830500E-04,.5794800E-04,.3766600E-04,& + & .1301700E-06,.3546500E-04,.5448900E-04,.6484100E-04,.4155600E-04,& + & .1577100E-06,.4023500E-04,.6117600E-04,.7208200E-04,.4545200E-04,& + & .1906400E-06,.4559900E-04,.6848800E-04,.7957600E-04,.4959300E-04,& + & .2294400E-06,.5155200E-04,.7643100E-04,.8746200E-04,.5371500E-04,& + & .8387900E-07,.2532500E-04,.3929700E-04,.4711800E-04,.3051000E-04,& + & .1008700E-06,.2892000E-04,.4453200E-04,.5292900E-04,.3377200E-04,& + & .1223800E-06,.3297700E-04,.5018900E-04,.5907500E-04,.3706900E-04,& + & .1481300E-06,.3755600E-04,.5645100E-04,.6544800E-04,.4056700E-04,& + & .1787400E-06,.4267200E-04,.6319600E-04,.7215900E-04,.4408500E-04,& + & .6526100E-07,.2051600E-04,.3189500E-04,.3827900E-04,.2465000E-04,& + & .7814500E-07,.2354000E-04,.3631900E-04,.4316100E-04,.2739000E-04,& + & .9480500E-07,.2696200E-04,.4113400E-04,.4835700E-04,.3019000E-04,& + & .1149000E-06,.3085800E-04,.4642900E-04,.5378500E-04,.3313600E-04,& + & .1390500E-06,.3521000E-04,.5221600E-04,.5948200E-04,.3612200E-04,& + & .5066800E-07,.1652600E-04,.2575200E-04,.3095400E-04,.1981700E-04,& + & .6036100E-07,.1905800E-04,.2947100E-04,.3506000E-04,.2212300E-04,& + & .7310100E-07,.2193700E-04,.3356900E-04,.3946100E-04,.2449800E-04,& + & .8874700E-07,.2522200E-04,.3804800E-04,.4403900E-04,.2697300E-04,& + & .1076200E-06,.2893200E-04,.4296400E-04,.4887100E-04,.2949900E-04,& + & .3918500E-07,.1320700E-04,.2062600E-04,.2483500E-04,.1582600E-04,& + & .4633500E-07,.1530300E-04,.2372200E-04,.2827700E-04,.1776200E-04,& + & .5589600E-07,.1770300E-04,.2716200E-04,.3197600E-04,.1978000E-04,& + & .6796200E-07,.2045100E-04,.3094000E-04,.3586700E-04,.2183400E-04,& + & .8253500E-07,.2358300E-04,.3512800E-04,.3993300E-04,.2397200E-04/ + + data absb(876:1050, 4) / & + & .3043500E-07,.1052800E-04,.1645800E-04,.1987100E-04,.1263000E-04,& + & .3565700E-07,.1225500E-04,.1903400E-04,.2275700E-04,.1423000E-04,& + & .4277700E-07,.1424100E-04,.2191600E-04,.2585600E-04,.1591600E-04,& + & .5197700E-07,.1653100E-04,.2509400E-04,.2914200E-04,.1763200E-04,& + & .6324600E-07,.1916200E-04,.2863100E-04,.3258600E-04,.1944700E-04,& + & .2372200E-07,.8365600E-05,.1308800E-04,.1583400E-04,.1006000E-04,& + & .2750900E-07,.9786900E-05,.1522700E-04,.1825200E-04,.1136300E-04,& + & .3276900E-07,.1142600E-04,.1762800E-04,.2085300E-04,.1276700E-04,& + & .3971900E-07,.1332600E-04,.2028500E-04,.2363700E-04,.1422300E-04,& + & .4841500E-07,.1552400E-04,.2326800E-04,.2653000E-04,.1573900E-04,& + & .1862300E-07,.6662000E-05,.1042500E-04,.1263400E-04,.8013200E-05,& + & .2139300E-07,.7826400E-05,.1218800E-04,.1464300E-04,.9075700E-05,& + & .2528100E-07,.9178700E-05,.1418600E-04,.1682500E-04,.1024700E-04,& + & .3053000E-07,.1075800E-04,.1641900E-04,.1917800E-04,.1148200E-04,& + & .3721300E-07,.1259300E-04,.1892000E-04,.2164300E-04,.1274900E-04,& + & .1468100E-07,.5304300E-05,.8295600E-05,.1006400E-04,.6366900E-05,& + & .1671700E-07,.6250800E-05,.9750100E-05,.1173700E-04,.7247300E-05,& + & .1958700E-07,.7364300E-05,.1140000E-04,.1355800E-04,.8229000E-05,& + & .2355500E-07,.8674800E-05,.1326800E-04,.1553700E-04,.9263400E-05,& + & .2867100E-07,.1020900E-04,.1537900E-04,.1763500E-04,.1031600E-04,& + & .1162600E-07,.4214900E-05,.6574000E-05,.7983500E-05,.5059500E-05,& + & .1310200E-07,.4988400E-05,.7775800E-05,.9384600E-05,.5785600E-05,& + & .1520800E-07,.5895500E-05,.9139200E-05,.1089800E-04,.6593700E-05,& + & .1817400E-07,.6975800E-05,.1069200E-04,.1255400E-04,.7456400E-05,& + & .2205700E-07,.8250500E-05,.1246200E-04,.1433100E-04,.8330100E-05,& + & .9213000E-08,.3337800E-05,.5199800E-05,.6300600E-05,.4009700E-05,& + & .1029800E-07,.3970400E-05,.6183900E-05,.7477500E-05,.4607700E-05,& + & .1183100E-07,.4708800E-05,.7306200E-05,.8734500E-05,.5262000E-05,& + & .1403000E-07,.5594200E-05,.8592100E-05,.1011900E-04,.5983800E-05,& + & .1697000E-07,.6644700E-05,.1006300E-04,.1162000E-04,.6720800E-05,& + & .7344300E-08,.2649800E-05,.4122900E-05,.4978800E-05,.3192900E-05,& + & .8145300E-08,.3168900E-05,.4932000E-05,.5970100E-05,.3670600E-05,& + & .9285300E-08,.3774600E-05,.5856100E-05,.7013900E-05,.4210500E-05,& + & .1091300E-07,.4498600E-05,.6919200E-05,.8173300E-05,.4808100E-05,& + & .1315100E-07,.5368900E-05,.8146900E-05,.9437700E-05,.5432000E-05/ + + data absb(1051:1175, 4) / & + & .5869000E-08,.2105600E-05,.3271000E-05,.3936200E-05,.2535700E-05,& + & .6482400E-08,.2529200E-05,.3933500E-05,.4765200E-05,.2926600E-05,& + & .7319500E-08,.3026000E-05,.4694200E-05,.5634600E-05,.3370000E-05,& + & .8529800E-08,.3621600E-05,.5572700E-05,.6599000E-05,.3866200E-05,& + & .1022700E-07,.4336600E-05,.6593500E-05,.7662700E-05,.4388900E-05,& + & .4687900E-08,.1667400E-05,.2584800E-05,.3099200E-05,.2009700E-05,& + & .5157900E-08,.2014500E-05,.3130700E-05,.3787500E-05,.2330400E-05,& + & .5782900E-08,.2419900E-05,.3752900E-05,.4511900E-05,.2696200E-05,& + & .6681700E-08,.2909200E-05,.4478800E-05,.5314200E-05,.3103700E-05,& + & .7954800E-08,.3498500E-05,.5324800E-05,.6206600E-05,.3538700E-05,& + & .3748700E-08,.1317700E-05,.2036200E-05,.2427800E-05,.1588800E-05,& + & .4113200E-08,.1600600E-05,.2486300E-05,.3000100E-05,.1853000E-05,& + & .4579600E-08,.1930100E-05,.2995700E-05,.3605300E-05,.2151500E-05,& + & .5244700E-08,.2330100E-05,.3590200E-05,.4269000E-05,.2484400E-05,& + & .6195200E-08,.2817500E-05,.4289400E-05,.5013300E-05,.2850300E-05,& + & .3005300E-08,.1041900E-05,.1603400E-05,.1907100E-05,.1255000E-05,& + & .3290600E-08,.1271700E-05,.1975000E-05,.2375100E-05,.1476100E-05,& + & .3641200E-08,.1541300E-05,.2395000E-05,.2881700E-05,.1717300E-05,& + & .4132700E-08,.1867300E-05,.2880000E-05,.3430100E-05,.1989300E-05,& + & .4844800E-08,.2269900E-05,.3455900E-05,.4049600E-05,.2293800E-05,& + & .2451700E-08,.8536700E-06,.1312100E-05,.1558700E-05,.1020900E-05,& + & .2681400E-08,.1045900E-05,.1624100E-05,.1950500E-05,.1206700E-05,& + & .2960400E-08,.1272600E-05,.1978600E-05,.2376500E-05,.1407100E-05,& + & .3349000E-08,.1548600E-05,.2388400E-05,.2839300E-05,.1635300E-05,& + & .3917700E-08,.1892300E-05,.2875100E-05,.3364800E-05,.1889600E-05/ + + data absb( 1:175, 5) / & + & .1060600E-02,.1761600E-01,.2633700E-01,.3083200E-01,.2325000E-01,& + & .1197500E-02,.1885100E-01,.2774600E-01,.3219100E-01,.2446100E-01,& + & .1368600E-02,.2023600E-01,.2922400E-01,.3340900E-01,.2553800E-01,& + & .1578800E-02,.2168600E-01,.3082200E-01,.3458100E-01,.2648300E-01,& + & .1842200E-02,.2320100E-01,.3248500E-01,.3579100E-01,.2733900E-01,& + & .9029900E-03,.1493900E-01,.2223500E-01,.2596900E-01,.1945900E-01,& + & .1027600E-02,.1604300E-01,.2346400E-01,.2710200E-01,.2041800E-01,& + & .1184800E-02,.1724400E-01,.2476600E-01,.2813700E-01,.2127900E-01,& + & .1376300E-02,.1849400E-01,.2615900E-01,.2914100E-01,.2203500E-01,& + & .1608700E-02,.1980100E-01,.2758600E-01,.3020800E-01,.2271200E-01,& + & .7616900E-03,.1265700E-01,.1874400E-01,.2180700E-01,.1615500E-01,& + & .8742900E-03,.1362200E-01,.1982000E-01,.2275300E-01,.1690800E-01,& + & .1015300E-02,.1465000E-01,.2096700E-01,.2363700E-01,.1759700E-01,& + & .1186000E-02,.1572800E-01,.2215900E-01,.2452100E-01,.1823600E-01,& + & .1394000E-02,.1685500E-01,.2337700E-01,.2544200E-01,.1880000E-01,& + & .6397900E-03,.1071600E-01,.1578200E-01,.1828000E-01,.1333000E-01,& + & .7399200E-03,.1155000E-01,.1672100E-01,.1907400E-01,.1395500E-01,& + & .8653500E-03,.1243200E-01,.1771500E-01,.1983500E-01,.1451900E-01,& + & .1018000E-02,.1335800E-01,.1873300E-01,.2061200E-01,.1505300E-01,& + & .1202000E-02,.1433000E-01,.1978000E-01,.2139000E-01,.1552300E-01,& + & .5382700E-03,.9067500E-02,.1328200E-01,.1531000E-01,.1100200E-01,& + & .6273300E-03,.9781800E-02,.1409300E-01,.1598500E-01,.1151700E-01,& + & .7389400E-03,.1053600E-01,.1493700E-01,.1664200E-01,.1198200E-01,& + & .8747100E-03,.1132900E-01,.1581300E-01,.1730800E-01,.1243100E-01,& + & .1036900E-02,.1216700E-01,.1671700E-01,.1796600E-01,.1283300E-01,& + & .4563200E-03,.7663100E-02,.1117500E-01,.1282100E-01,.9100700E-02,& + & .5361800E-03,.8274100E-02,.1186700E-01,.1340200E-01,.9528400E-02,& + & .6352000E-03,.8917900E-02,.1259100E-01,.1396000E-01,.9922700E-02,& + & .7551300E-03,.9596600E-02,.1334500E-01,.1452900E-01,.1029400E-01,& + & .8982800E-03,.1032500E-01,.1412700E-01,.1508200E-01,.1063700E-01,& + & .3878200E-03,.6468600E-02,.9394700E-02,.1073800E-01,.7536600E-02,& + & .4582600E-03,.6987200E-02,.9987800E-02,.1123000E-01,.7892000E-02,& + & .5454400E-03,.7538600E-02,.1061300E-01,.1170600E-01,.8221900E-02,& + & .6508500E-03,.8124300E-02,.1126100E-01,.1218300E-01,.8544700E-02,& + & .7760100E-03,.8759800E-02,.1193300E-01,.1266000E-01,.8838800E-02/ + + data absb(176:350, 5) / & + & .3330400E-03,.5462300E-02,.7902800E-02,.8996000E-02,.6263500E-02,& + & .3955300E-03,.5905500E-02,.8415500E-02,.9411100E-02,.6561300E-02,& + & .4718000E-03,.6377900E-02,.8950000E-02,.9817200E-02,.6845900E-02,& + & .5645300E-03,.6886200E-02,.9504800E-02,.1022500E-01,.7124600E-02,& + & .6748600E-03,.7441100E-02,.1008200E-01,.1063700E-01,.7378600E-02,& + & .2869300E-03,.4618000E-02,.6650400E-02,.7537900E-02,.5207100E-02,& + & .3418000E-03,.4994800E-02,.7089800E-02,.7886600E-02,.5464500E-02,& + & .4081100E-03,.5400600E-02,.7547400E-02,.8233100E-02,.5712700E-02,& + & .4887300E-03,.5843400E-02,.8021200E-02,.8584400E-02,.5947000E-02,& + & .5859300E-03,.6326000E-02,.8518200E-02,.8940800E-02,.6166200E-02,& + & .2497400E-03,.3924000E-02,.5620800E-02,.6334500E-02,.4343100E-02,& + & .2974900E-03,.4252600E-02,.5999600E-02,.6626600E-02,.4562400E-02,& + & .3560800E-03,.4604700E-02,.6391900E-02,.6925900E-02,.4773800E-02,& + & .4269900E-03,.4992000E-02,.6799300E-02,.7227600E-02,.4971400E-02,& + & .5119800E-03,.5416600E-02,.7230200E-02,.7538700E-02,.5166000E-02,& + & .2171600E-03,.3337500E-02,.4752800E-02,.5323800E-02,.3625800E-02,& + & .2588600E-03,.3624300E-02,.5079700E-02,.5574000E-02,.3810700E-02,& + & .3102600E-03,.3935300E-02,.5416900E-02,.5830900E-02,.3987600E-02,& + & .3723500E-03,.4275700E-02,.5771100E-02,.6091100E-02,.4158600E-02,& + & .4456800E-03,.4646300E-02,.6147600E-02,.6363300E-02,.4327700E-02,& + & .1873800E-03,.2841200E-02,.4025100E-02,.4475400E-02,.3023200E-02,& + & .2242200E-03,.3093000E-02,.4306200E-02,.4692100E-02,.3178800E-02,& + & .2694200E-03,.3369400E-02,.4598300E-02,.4912600E-02,.3328700E-02,& + & .3231700E-03,.3670200E-02,.4909200E-02,.5139300E-02,.3477100E-02,& + & .3863800E-03,.3995100E-02,.5238500E-02,.5381500E-02,.3623200E-02,& + & .1622400E-03,.2423200E-02,.3414100E-02,.3766100E-02,.2526200E-02,& + & .1946500E-03,.2646300E-02,.3657500E-02,.3954100E-02,.2657700E-02,& + & .2339100E-03,.2893600E-02,.3913000E-02,.4144600E-02,.2784100E-02,& + & .2804400E-03,.3159800E-02,.4185300E-02,.4344200E-02,.2909800E-02,& + & .3348300E-03,.3443700E-02,.4473500E-02,.4562500E-02,.3035100E-02,& + & .1413200E-03,.2073700E-02,.2903600E-02,.3176200E-02,.2115700E-02,& + & .1697700E-03,.2274300E-02,.3115200E-02,.3338200E-02,.2225800E-02,& + & .2040900E-03,.2494700E-02,.3340100E-02,.3504800E-02,.2333800E-02,& + & .2447200E-03,.2729700E-02,.3579800E-02,.3683500E-02,.2442100E-02,& + & .2913100E-03,.2980400E-02,.3830800E-02,.3879700E-02,.2550000E-02/ + + data absb(351:525, 5) / & + & .1229300E-03,.1779700E-02,.2472500E-02,.2682200E-02,.1771800E-02,& + & .1478900E-03,.1959500E-02,.2658400E-02,.2822200E-02,.1865500E-02,& + & .1779000E-03,.2155200E-02,.2858400E-02,.2969500E-02,.1958900E-02,& + & .2131500E-03,.2362400E-02,.3068800E-02,.3130900E-02,.2052000E-02,& + & .2528500E-03,.2582500E-02,.3287600E-02,.3306800E-02,.2144500E-02,& + & .1065700E-03,.1531900E-02,.2109600E-02,.2267800E-02,.1484400E-02,& + & .1285600E-03,.1692000E-02,.2274300E-02,.2389900E-02,.1563900E-02,& + & .1547100E-03,.1863600E-02,.2451100E-02,.2522100E-02,.1643600E-02,& + & .1851200E-03,.2047200E-02,.2636400E-02,.2668100E-02,.1723800E-02,& + & .2187200E-03,.2241100E-02,.2827000E-02,.2826000E-02,.1804800E-02,& + & .9287600E-04,.1323700E-02,.1804900E-02,.1921400E-02,.1247100E-02,& + & .1122600E-03,.1465900E-02,.1951800E-02,.2029500E-02,.1314300E-02,& + & .1351900E-03,.1617100E-02,.2108900E-02,.2149800E-02,.1383300E-02,& + & .1610200E-03,.1777800E-02,.2270300E-02,.2281000E-02,.1452800E-02,& + & .1898100E-03,.1948400E-02,.2437400E-02,.2424900E-02,.1523600E-02,& + & .8082800E-04,.1147100E-02,.1548600E-02,.1630700E-02,.1048200E-02,& + & .9806300E-04,.1271800E-02,.1679700E-02,.1728700E-02,.1105300E-02,& + & .1177200E-03,.1405000E-02,.1817700E-02,.1837900E-02,.1164800E-02,& + & .1398100E-03,.1546900E-02,.1958900E-02,.1956500E-02,.1225800E-02,& + & .1644600E-03,.1694700E-02,.2105500E-02,.2087400E-02,.1288500E-02,& + & .7053900E-04,.9962100E-03,.1332500E-02,.1387900E-02,.8822000E-03,& + & .8558900E-04,.1106300E-02,.1449200E-02,.1477600E-02,.9311300E-03,& + & .1024400E-03,.1224000E-02,.1570100E-02,.1576400E-02,.9823700E-03,& + & .1215100E-03,.1348800E-02,.1694200E-02,.1684600E-02,.1036400E-02,& + & .1424500E-03,.1475300E-02,.1822900E-02,.1804200E-02,.1091000E-02,& + & .6159800E-04,.8670800E-03,.1150600E-02,.1185700E-02,.7439600E-03,& + & .7469800E-04,.9644300E-03,.1253300E-02,.1267300E-02,.7859000E-03,& + & .8909200E-04,.1068400E-02,.1359000E-02,.1357100E-02,.8309000E-03,& + & .1053700E-03,.1176600E-02,.1468200E-02,.1456000E-02,.8782700E-03,& + & .1232700E-03,.1285000E-02,.1581300E-02,.1564300E-02,.9259900E-03,& + & .5374800E-04,.7562900E-03,.9959500E-03,.1016300E-02,.6280900E-03,& + & .6497200E-04,.8426500E-03,.1085600E-02,.1090800E-02,.6641600E-03,& + & .7738600E-04,.9339700E-03,.1178700E-02,.1172700E-02,.7038700E-03,& + & .9113800E-04,.1026600E-02,.1274900E-02,.1263000E-02,.7450700E-03,& + & .1064000E-03,.1118900E-02,.1373800E-02,.1360800E-02,.7883000E-03/ + + data absb(526:700, 5) / & + & .4666700E-04,.6588400E-03,.8604900E-03,.8721400E-03,.5309900E-03,& + & .5626300E-04,.7349000E-03,.9390000E-03,.9394600E-03,.5627800E-03,& + & .6685300E-04,.8138300E-03,.1020900E-02,.1014200E-02,.5977600E-03,& + & .7859800E-04,.8931400E-03,.1105400E-02,.1096300E-02,.6341900E-03,& + & .9150300E-04,.9719300E-03,.1192700E-02,.1184000E-02,.6732000E-03,& + & .3959900E-04,.5686600E-03,.7380300E-03,.7449100E-03,.4468800E-03,& + & .4767700E-04,.6349000E-03,.8068500E-03,.8054000E-03,.4746600E-03,& + & .5663000E-04,.7027900E-03,.8786000E-03,.8733200E-03,.5047600E-03,& + & .6650600E-04,.7706100E-03,.9526200E-03,.9467600E-03,.5373000E-03,& + & .7734300E-04,.8387000E-03,.1029500E-02,.1025000E-02,.5720000E-03,& + & .3276700E-04,.4852300E-03,.6275100E-03,.6318300E-03,.3735300E-03,& + & .3945000E-04,.5426100E-03,.6874400E-03,.6858700E-03,.3974400E-03,& + & .4686100E-04,.6009300E-03,.7497700E-03,.7462300E-03,.4231500E-03,& + & .5495600E-04,.6591600E-03,.8146900E-03,.8115800E-03,.4514400E-03,& + & .6390800E-04,.7182000E-03,.8821200E-03,.8810300E-03,.4816500E-03,& + & .2673400E-04,.4075400E-03,.5264500E-03,.5301400E-03,.3111800E-03,& + & .3227300E-04,.4566100E-03,.5782500E-03,.5776600E-03,.3320600E-03,& + & .3848800E-04,.5069700E-03,.6324500E-03,.6305800E-03,.3547600E-03,& + & .4522800E-04,.5570600E-03,.6891800E-03,.6880900E-03,.3794400E-03,& + & .5267500E-04,.6080800E-03,.7479400E-03,.7493400E-03,.4059800E-03,& + & .2175100E-04,.3420900E-03,.4414600E-03,.4445800E-03,.2592000E-03,& + & .2632600E-04,.3841500E-03,.4860300E-03,.4863200E-03,.2773000E-03,& + & .3151500E-04,.4273600E-03,.5332500E-03,.5326200E-03,.2971400E-03,& + & .3721900E-04,.4706400E-03,.5826300E-03,.5832100E-03,.3189000E-03,& + & .4334400E-04,.5149300E-03,.6340200E-03,.6372900E-03,.3421200E-03,& + & .1764300E-04,.2871700E-03,.3702000E-03,.3728800E-03,.2158000E-03,& + & .2141800E-04,.3234300E-03,.4087100E-03,.4095300E-03,.2315100E-03,& + & .2572500E-04,.3604400E-03,.4496600E-03,.4500500E-03,.2488000E-03,& + & .3047900E-04,.3978500E-03,.4926300E-03,.4944500E-03,.2678300E-03,& + & .3565300E-04,.4364600E-03,.5377100E-03,.5423000E-03,.2882200E-03,& + & .1410200E-04,.2381400E-03,.3073000E-03,.3098100E-03,.1786400E-03,& + & .1718700E-04,.2693400E-03,.3403900E-03,.3414600E-03,.1923400E-03,& + & .2073900E-04,.3013000E-03,.3757100E-03,.3767200E-03,.2073700E-03,& + & .2467000E-04,.3333300E-03,.4128300E-03,.4153800E-03,.2240800E-03,& + & .2904600E-04,.3669400E-03,.4521600E-03,.4572900E-03,.2418700E-03/ + + data absb(701:875, 5) / & + & .1122100E-04,.1971000E-03,.2546500E-03,.2569600E-03,.1477300E-03,& + & .1374700E-04,.2239000E-03,.2830500E-03,.2841300E-03,.1595500E-03,& + & .1664900E-04,.2514500E-03,.3134600E-03,.3146700E-03,.1726900E-03,& + & .1989900E-04,.2793500E-03,.3456300E-03,.3484500E-03,.1871800E-03,& + & .2356800E-04,.3083000E-03,.3797400E-03,.3851200E-03,.2028100E-03,& + & .8914700E-05,.1631400E-03,.2108800E-03,.2129400E-03,.1220500E-03,& + & .1095700E-04,.1859600E-03,.2352300E-03,.2362800E-03,.1322500E-03,& + & .1332700E-04,.2097400E-03,.2613400E-03,.2626300E-03,.1435600E-03,& + & .1600500E-04,.2337800E-03,.2892500E-03,.2920200E-03,.1562100E-03,& + & .1903800E-04,.2591400E-03,.3189700E-03,.3241500E-03,.1698200E-03,& + & .6999500E-05,.1340500E-03,.1733800E-03,.1753500E-03,.1003600E-03,& + & .8640600E-05,.1534500E-03,.1941600E-03,.1951400E-03,.1091000E-03,& + & .1055600E-04,.1737300E-03,.2165900E-03,.2176700E-03,.1188700E-03,& + & .1273900E-04,.1944500E-03,.2405300E-03,.2431100E-03,.1298000E-03,& + & .1523200E-04,.2164000E-03,.2664500E-03,.2710700E-03,.1416900E-03,& + & .5471200E-05,.1097000E-03,.1419500E-03,.1438600E-03,.8226000E-04,& + & .6764400E-05,.1261200E-03,.1596300E-03,.1606100E-03,.8972700E-04,& + & .8297300E-05,.1434800E-03,.1787800E-03,.1797500E-03,.9812200E-04,& + & .1008200E-04,.1613200E-03,.1995200E-03,.2015500E-03,.1075500E-03,& + & .1210700E-04,.1800800E-03,.2217900E-03,.2257600E-03,.1178700E-03,& + & .4276700E-05,.8968000E-04,.1161100E-03,.1178100E-03,.6733800E-04,& + & .5286000E-05,.1036000E-03,.1310700E-03,.1320300E-03,.7372200E-04,& + & .6510700E-05,.1183800E-03,.1473500E-03,.1482900E-03,.8085200E-04,& + & .7950100E-05,.1337400E-03,.1652000E-03,.1669300E-03,.8896900E-04,& + & .9593700E-05,.1499300E-03,.1845600E-03,.1878100E-03,.9789700E-04,& + & .3322600E-05,.7291800E-04,.9463500E-04,.9606900E-04,.5491200E-04,& + & .4118500E-05,.8470500E-04,.1072600E-03,.1080900E-03,.6032500E-04,& + & .5079600E-05,.9741400E-04,.1210600E-03,.1218400E-03,.6641500E-04,& + & .6231100E-05,.1105500E-03,.1362500E-03,.1377200E-03,.7335400E-04,& + & .7559400E-05,.1243900E-03,.1529700E-03,.1556900E-03,.8097200E-04,& + & .2550700E-05,.5875300E-04,.7659900E-04,.7779800E-04,.4450800E-04,& + & .3180000E-05,.6867900E-04,.8724000E-04,.8784300E-04,.4911500E-04,& + & .3927300E-05,.7949700E-04,.9887100E-04,.9942100E-04,.5424900E-04,& + & .4834600E-05,.9078200E-04,.1117300E-03,.1128200E-03,.6011300E-04,& + & .5899500E-05,.1026700E-03,.1259200E-03,.1281500E-03,.6665600E-04/ + + data absb(876:1050, 5) / & + & .1953900E-05,.4717400E-04,.6187400E-04,.6291600E-04,.3597300E-04,& + & .2445200E-05,.5557500E-04,.7085300E-04,.7123800E-04,.3989800E-04,& + & .3040200E-05,.6478300E-04,.8063300E-04,.8092100E-04,.4421400E-04,& + & .3739000E-05,.7443900E-04,.9149800E-04,.9220800E-04,.4916200E-04,& + & .4583600E-05,.8460800E-04,.1035800E-03,.1053100E-03,.5470200E-04,& + & .1494000E-05,.3771600E-04,.4982900E-04,.5080400E-04,.2898700E-04,& + & .1875800E-05,.4477700E-04,.5739200E-04,.5769700E-04,.3231700E-04,& + & .2341300E-05,.5260400E-04,.6560800E-04,.6574800E-04,.3594600E-04,& + & .2896100E-05,.6089100E-04,.7482400E-04,.7518200E-04,.4009900E-04,& + & .3552400E-05,.6958700E-04,.8506800E-04,.8629500E-04,.4480400E-04,& + & .1150000E-05,.3016900E-04,.4015700E-04,.4106900E-04,.2336200E-04,& + & .1445300E-05,.3608900E-04,.4654900E-04,.4679900E-04,.2619300E-04,& + & .1812900E-05,.4273500E-04,.5347400E-04,.5351400E-04,.2924900E-04,& + & .2252900E-05,.4984300E-04,.6123400E-04,.6140400E-04,.3274800E-04,& + & .2776200E-05,.5732800E-04,.7002700E-04,.7078300E-04,.3671200E-04,& + & .8885100E-06,.2409500E-04,.3230300E-04,.3321000E-04,.1880500E-04,& + & .1117700E-05,.2908200E-04,.3770500E-04,.3794400E-04,.2120900E-04,& + & .1406000E-05,.3466700E-04,.4357800E-04,.4357000E-04,.2379200E-04,& + & .1753900E-05,.4073900E-04,.5011400E-04,.5017200E-04,.2672000E-04,& + & .2172900E-05,.4722400E-04,.5759800E-04,.5807000E-04,.3007900E-04,& + & .6852500E-06,.1917800E-04,.2589600E-04,.2680900E-04,.1509700E-04,& + & .8630100E-06,.2333600E-04,.3043400E-04,.3071300E-04,.1712000E-04,& + & .1088900E-05,.2802800E-04,.3542200E-04,.3539700E-04,.1930100E-04,& + & .1364900E-05,.3318700E-04,.4095400E-04,.4092100E-04,.2175200E-04,& + & .1698200E-05,.3874700E-04,.4726000E-04,.4755700E-04,.2458800E-04,& + & .5280900E-06,.1520600E-04,.2068800E-04,.2159200E-04,.1208400E-04,& + & .6649300E-06,.1864700E-04,.2447900E-04,.2481900E-04,.1378100E-04,& + & .8410200E-06,.2257400E-04,.2868300E-04,.2869000E-04,.1562100E-04,& + & .1058500E-05,.2695500E-04,.3336400E-04,.3329800E-04,.1767700E-04,& + & .1323900E-05,.3171000E-04,.3873300E-04,.3886400E-04,.2004900E-04,& + & .4096900E-06,.1209300E-04,.1656400E-04,.1742100E-04,.9688200E-05,& + & .5156900E-06,.1493700E-04,.1973400E-04,.2009400E-04,.1111200E-04,& + & .6529600E-06,.1822900E-04,.2328200E-04,.2332100E-04,.1266400E-04,& + & .8257300E-06,.2195000E-04,.2723100E-04,.2715000E-04,.1439300E-04,& + & .1037300E-05,.2601300E-04,.3179100E-04,.3182800E-04,.1637900E-04/ + + data absb(1051:1175, 5) / & + & .3192800E-06,.9616200E-05,.1325700E-04,.1405300E-04,.7774100E-05,& + & .4011200E-06,.1196300E-04,.1590600E-04,.1625700E-04,.8957800E-05,& + & .5081600E-06,.1471700E-04,.1888600E-04,.1894700E-04,.1026200E-04,& + & .6446500E-06,.1786400E-04,.2220700E-04,.2215500E-04,.1171500E-04,& + & .8132800E-06,.2132600E-04,.2607600E-04,.2606100E-04,.1337600E-04,& + & .2482900E-06,.7620400E-05,.1057800E-04,.1130900E-04,.6220800E-05,& + & .3117600E-06,.9548800E-05,.1278000E-04,.1312500E-04,.7201300E-05,& + & .3950600E-06,.1185000E-04,.1527900E-04,.1534800E-04,.8294700E-05,& + & .5026600E-06,.1449200E-04,.1807400E-04,.1804000E-04,.9515300E-05,& + & .6363800E-06,.1744200E-04,.2133600E-04,.2131000E-04,.1090400E-04,& + & .1930200E-06,.6018700E-05,.8416200E-05,.9079900E-05,.4964900E-05,& + & .2422200E-06,.7595900E-05,.1023300E-04,.1057000E-04,.5770100E-05,& + & .3068800E-06,.9508000E-05,.1231800E-04,.1240300E-04,.6691300E-05,& + & .3908900E-06,.1171900E-04,.1467000E-04,.1464400E-04,.7716600E-05,& + & .4967400E-06,.1421400E-04,.1740200E-04,.1738200E-04,.8872700E-05,& + & .1504600E-06,.4766300E-05,.6699800E-05,.7290800E-05,.3963100E-05,& + & .1885600E-06,.6045900E-05,.8190800E-05,.8520600E-05,.4627000E-05,& + & .2386900E-06,.7630200E-05,.9924500E-05,.1002300E-04,.5397700E-05,& + & .3045900E-06,.9476700E-05,.1191100E-04,.1189400E-04,.6257900E-05,& + & .3882000E-06,.1158800E-04,.1420500E-04,.1418200E-04,.7222600E-05,& + & .1221200E-06,.3933200E-05,.5523000E-05,.6009400E-05,.3249900E-05,& + & .1532400E-06,.5017800E-05,.6787900E-05,.7056600E-05,.3810800E-05,& + & .1941800E-06,.6367800E-05,.8264700E-05,.8344300E-05,.4467200E-05,& + & .2482000E-06,.7954300E-05,.9967000E-05,.9951800E-05,.5202700E-05,& + & .3174000E-06,.9770400E-05,.1196400E-04,.1193800E-04,.6027800E-05/ + + data absb( 1:175, 6) / & + & .4672255E-01,.1179341E+00,.1338757E+00,.1299972E+00,.9161157E-01,& + & .5062470E-01,.1213117E+00,.1369429E+00,.1328028E+00,.9360006E-01,& + & .5459974E-01,.1248223E+00,.1399926E+00,.1355144E+00,.9556280E-01,& + & .5873868E-01,.1286746E+00,.1431991E+00,.1382901E+00,.9738836E-01,& + & .6302530E-01,.1329297E+00,.1467302E+00,.1411782E+00,.9929195E-01,& + & .3968991E-01,.9976895E-01,.1131751E+00,.1100474E+00,.7710072E-01,& + & .4301477E-01,.1026851E+00,.1158037E+00,.1124295E+00,.7893417E-01,& + & .4646290E-01,.1058587E+00,.1184976E+00,.1148060E+00,.8065093E-01,& + & .5002899E-01,.1093646E+00,.1214273E+00,.1173032E+00,.8238971E-01,& + & .5370336E-01,.1132393E+00,.1247403E+00,.1199136E+00,.8410182E-01,& + & .3361226E-01,.8419071E-01,.9544048E-01,.9285444E-01,.6446524E-01,& + & .3646479E-01,.8678678E-01,.9771637E-01,.9491470E-01,.6610593E-01,& + & .3943418E-01,.8966612E-01,.1001521E+00,.9704047E-01,.6769280E-01,& + & .4249750E-01,.9286388E-01,.1028925E+00,.9929778E-01,.6917725E-01,& + & .4559710E-01,.9635024E-01,.1059705E+00,.1017312E+00,.7059703E-01,& + & .2841305E-01,.7093757E-01,.8032314E-01,.7813700E-01,.5373624E-01,& + & .3087001E-01,.7327916E-01,.8235049E-01,.7995476E-01,.5513198E-01,& + & .3341491E-01,.7589200E-01,.8459743E-01,.8187839E-01,.5650567E-01,& + & .3600242E-01,.7879372E-01,.8716029E-01,.8394378E-01,.5783239E-01,& + & .3862500E-01,.8189679E-01,.8997661E-01,.8623580E-01,.5901740E-01,& + & .2401634E-01,.5974102E-01,.6747709E-01,.6564216E-01,.4478664E-01,& + & .2611796E-01,.6185142E-01,.6932940E-01,.6726455E-01,.4600594E-01,& + & .2827920E-01,.6420880E-01,.7144020E-01,.6899927E-01,.4720878E-01,& + & .3044618E-01,.6678350E-01,.7379995E-01,.7092071E-01,.4834282E-01,& + & .3265937E-01,.6948508E-01,.7635424E-01,.7306622E-01,.4936137E-01,& + & .2029779E-01,.5028866E-01,.5661750E-01,.5508955E-01,.3739316E-01,& + & .2208972E-01,.5221100E-01,.5834184E-01,.5654839E-01,.3848438E-01,& + & .2389477E-01,.5432163E-01,.6030221E-01,.5814906E-01,.3951198E-01,& + & .2571656E-01,.5658610E-01,.6243776E-01,.5994219E-01,.4048024E-01,& + & .2759559E-01,.5894005E-01,.6471627E-01,.6189304E-01,.4136898E-01,& + & .1714555E-01,.4232553E-01,.4751571E-01,.4621072E-01,.3128045E-01,& + & .1865226E-01,.4405192E-01,.4911024E-01,.4754554E-01,.3222507E-01,& + & .2016046E-01,.4594242E-01,.5088205E-01,.4903912E-01,.3313354E-01,& + & .2170679E-01,.4792414E-01,.5278935E-01,.5068417E-01,.3395265E-01,& + & .2331129E-01,.4999405E-01,.5480871E-01,.5244342E-01,.3473337E-01/ + + data absb(176:350, 6) / & + & .1449397E-01,.3565245E-01,.3997027E-01,.3878295E-01,.2623894E-01,& + & .1574907E-01,.3721054E-01,.4142074E-01,.4002092E-01,.2707613E-01,& + & .1701927E-01,.3887652E-01,.4300733E-01,.4140562E-01,.2785469E-01,& + & .1834230E-01,.4061477E-01,.4467996E-01,.4289260E-01,.2857492E-01,& + & .1972332E-01,.4243979E-01,.4646142E-01,.4447765E-01,.2929449E-01,& + & .1223686E-01,.3005384E-01,.3364453E-01,.3256819E-01,.2203383E-01,& + & .1329184E-01,.3143872E-01,.3496344E-01,.3371716E-01,.2275179E-01,& + & .1437272E-01,.3289059E-01,.3638637E-01,.3497888E-01,.2343303E-01,& + & .1550047E-01,.3441489E-01,.3787367E-01,.3632111E-01,.2407709E-01,& + & .1668336E-01,.3604499E-01,.3944792E-01,.3774085E-01,.2472138E-01,& + & .1038282E-01,.2542597E-01,.2842132E-01,.2744137E-01,.1852562E-01,& + & .1127312E-01,.2664076E-01,.2962239E-01,.2850810E-01,.1915442E-01,& + & .1219323E-01,.2791660E-01,.3088571E-01,.2965335E-01,.1975054E-01,& + & .1315724E-01,.2927559E-01,.3221079E-01,.3086581E-01,.2032424E-01,& + & .1418884E-01,.3074537E-01,.3362124E-01,.3215085E-01,.2090413E-01,& + & .8810984E-02,.2153212E-01,.2404863E-01,.2318381E-01,.1558634E-01,& + & .9557713E-02,.2259858E-01,.2512473E-01,.2414921E-01,.1614064E-01,& + & .1034460E-01,.2372894E-01,.2624401E-01,.2518234E-01,.1665912E-01,& + & .1117906E-01,.2495670E-01,.2743338E-01,.2627714E-01,.1717734E-01,& + & .1208564E-01,.2629206E-01,.2873101E-01,.2745336E-01,.1769705E-01,& + & .7472179E-02,.1826124E-01,.2037977E-01,.1963051E-01,.1311820E-01,& + & .8105914E-02,.1920286E-01,.2133520E-01,.2050264E-01,.1360311E-01,& + & .8786371E-02,.2021445E-01,.2233873E-01,.2143465E-01,.1406558E-01,& + & .9517597E-02,.2132628E-01,.2342388E-01,.2243468E-01,.1453007E-01,& + & .1031444E-01,.2254987E-01,.2462788E-01,.2351153E-01,.1499827E-01,& + & .6339327E-02,.1551891E-01,.1730563E-01,.1666327E-01,.1106485E-01,& + & .6886916E-02,.1635981E-01,.1815633E-01,.1745076E-01,.1148631E-01,& + & .7479578E-02,.1727214E-01,.1906789E-01,.1829842E-01,.1190414E-01,& + & .8122799E-02,.1828117E-01,.2007236E-01,.1921662E-01,.1232324E-01,& + & .8828155E-02,.1940872E-01,.2120238E-01,.2020565E-01,.1274767E-01,& + & .5392272E-02,.1323113E-01,.1473701E-01,.1419217E-01,.9365787E-02,& + & .5870200E-02,.1398439E-01,.1550589E-01,.1490579E-01,.9737495E-02,& + & .6389745E-02,.1481106E-01,.1634605E-01,.1568477E-01,.1010973E-01,& + & .6958634E-02,.1574163E-01,.1728569E-01,.1652721E-01,.1049045E-01,& + & .7581630E-02,.1678655E-01,.1834875E-01,.1744786E-01,.1088430E-01/ + + data absb(351:525, 6) / & + & .4592919E-02,.1130255E-01,.1258234E-01,.1211906E-01,.7936306E-02,& + & .5013344E-02,.1198363E-01,.1328506E-01,.1277230E-01,.8268918E-02,& + & .5471875E-02,.1274465E-01,.1406720E-01,.1349234E-01,.8605208E-02,& + & .5975738E-02,.1360931E-01,.1495090E-01,.1427336E-01,.8951125E-02,& + & .6524713E-02,.1458353E-01,.1594799E-01,.1514041E-01,.9313867E-02,& + & .3921257E-02,.9679135E-02,.1077668E-01,.1037874E-01,.6732679E-02,& + & .4289466E-02,.1030205E-01,.1142417E-01,.1098668E-01,.7034601E-02,& + & .4696449E-02,.1101261E-01,.1215654E-01,.1165356E-01,.7339816E-02,& + & .5140924E-02,.1181986E-01,.1298600E-01,.1238661E-01,.7655437E-02,& + & .5627986E-02,.1273133E-01,.1391895E-01,.1320853E-01,.7987663E-02,& + & .3358374E-02,.8318578E-02,.9266665E-02,.8925427E-02,.5731495E-02,& + & .3681177E-02,.8898948E-02,.9870888E-02,.9491903E-02,.6003477E-02,& + & .4042382E-02,.9566221E-02,.1056008E-01,.1011534E-01,.6284646E-02,& + & .4437145E-02,.1032409E-01,.1134025E-01,.1081068E-01,.6574647E-02,& + & .4869992E-02,.1118221E-01,.1221978E-01,.1159427E-01,.6878293E-02,& + & .2880952E-02,.7177713E-02,.8000548E-02,.7709187E-02,.4888892E-02,& + & .3168109E-02,.7724358E-02,.8567998E-02,.8237375E-02,.5136819E-02,& + & .3487574E-02,.8352795E-02,.9218971E-02,.8825929E-02,.5394241E-02,& + & .3839297E-02,.9067161E-02,.9957533E-02,.9491401E-02,.5660899E-02,& + & .4223712E-02,.9875806E-02,.1079202E-01,.1023576E-01,.5939546E-02,& + & .2478739E-02,.6226385E-02,.6940669E-02,.6691212E-02,.4181873E-02,& + & .2734468E-02,.6743172E-02,.7478246E-02,.7187563E-02,.4408421E-02,& + & .3017927E-02,.7337488E-02,.8096419E-02,.7749978E-02,.4643233E-02,& + & .3331178E-02,.8012614E-02,.8797666E-02,.8384632E-02,.4887248E-02,& + & .3674803E-02,.8776521E-02,.9606185E-02,.9089542E-02,.5147082E-02,& + & .2139286E-02,.5432558E-02,.6053952E-02,.5837608E-02,.3588363E-02,& + & .2366596E-02,.5923173E-02,.6566620E-02,.6309240E-02,.3794714E-02,& + & .2619079E-02,.6485565E-02,.7155112E-02,.6847354E-02,.4009599E-02,& + & .2899192E-02,.7125771E-02,.7834469E-02,.7451217E-02,.4235186E-02,& + & .3206376E-02,.7850198E-02,.8612179E-02,.8123777E-02,.4476963E-02,& + & .1850772E-02,.4769289E-02,.5310687E-02,.5121509E-02,.3086654E-02,& + & .2053571E-02,.5233812E-02,.5801277E-02,.5573075E-02,.3276182E-02,& + & .2279445E-02,.5767992E-02,.6371794E-02,.6087455E-02,.3472505E-02,& + & .2530319E-02,.6378620E-02,.7028994E-02,.6663834E-02,.3681702E-02,& + & .2802247E-02,.7072716E-02,.7774573E-02,.7310658E-02,.3905465E-02/ + + data absb(526:700, 6) / & + & .1599613E-02,.4199571E-02,.4673794E-02,.4506393E-02,.2664028E-02,& + & .1780622E-02,.4639345E-02,.5147271E-02,.4937749E-02,.2836730E-02,& + & .1982209E-02,.5147946E-02,.5697272E-02,.5427726E-02,.3018582E-02,& + & .2205837E-02,.5730040E-02,.6328408E-02,.5979873E-02,.3214093E-02,& + & .2444633E-02,.6402438E-02,.7040553E-02,.6604978E-02,.3423730E-02,& + & .1370767E-02,.3680434E-02,.4101387E-02,.3951642E-02,.2288026E-02,& + & .1530214E-02,.4092955E-02,.4551071E-02,.4359160E-02,.2445148E-02,& + & .1709076E-02,.4573254E-02,.5075448E-02,.4822350E-02,.2615383E-02,& + & .1905572E-02,.5130202E-02,.5673701E-02,.5348975E-02,.2795090E-02,& + & .2113656E-02,.5770683E-02,.6349792E-02,.5951205E-02,.2990809E-02,& + & .1161344E-02,.3200182E-02,.3576104E-02,.3443194E-02,.1950452E-02,& + & .1300611E-02,.3583463E-02,.3997263E-02,.3823311E-02,.2093149E-02,& + & .1456618E-02,.4035349E-02,.4489225E-02,.4258002E-02,.2249394E-02,& + & .1627537E-02,.4558261E-02,.5050496E-02,.4756449E-02,.2415485E-02,& + & .1808199E-02,.5161226E-02,.5687359E-02,.5329814E-02,.2597049E-02,& + & .9689423E-03,.2745553E-02,.3074976E-02,.2960730E-02,.1661770E-02,& + & .1088391E-02,.3094206E-02,.3461113E-02,.3308475E-02,.1792192E-02,& + & .1222284E-02,.3506981E-02,.3912501E-02,.3709778E-02,.1935066E-02,& + & .1369638E-02,.3987964E-02,.4430278E-02,.4173459E-02,.2088437E-02,& + & .1526024E-02,.4545546E-02,.5021863E-02,.4708792E-02,.2255640E-02,& + & .8077252E-03,.2356556E-02,.2645654E-02,.2547112E-02,.1416723E-02,& + & .9097668E-03,.2673661E-02,.2999603E-02,.2865604E-02,.1535808E-02,& + & .1024815E-02,.3051199E-02,.3413691E-02,.3236220E-02,.1665481E-02,& + & .1151477E-02,.3493356E-02,.3891808E-02,.3667727E-02,.1807129E-02,& + & .1286842E-02,.4009109E-02,.4442138E-02,.4167563E-02,.1962379E-02,& + & .6730887E-03,.2025445E-02,.2280105E-02,.2194379E-02,.1207918E-02,& + & .7604151E-03,.2314345E-02,.2604175E-02,.2486551E-02,.1316161E-02,& + & .8589949E-03,.2660424E-02,.2985221E-02,.2829802E-02,.1435082E-02,& + & .9677787E-03,.3067804E-02,.3427622E-02,.3232026E-02,.1564953E-02,& + & .1084841E-02,.3545518E-02,.3940911E-02,.3699314E-02,.1709431E-02,& + & .5540015E-03,.1719029E-02,.1940291E-02,.1868227E-02,.1025773E-02,& + & .6275728E-03,.1977116E-02,.2231569E-02,.2131986E-02,.1124006E-02,& + & .7113040E-03,.2288889E-02,.2577000E-02,.2444792E-02,.1232036E-02,& + & .8041626E-03,.2658785E-02,.2980992E-02,.2813689E-02,.1351842E-02,& + & .9045868E-03,.3094678E-02,.3453278E-02,.3244781E-02,.1485313E-02/ + + data absb(701:875, 6) / & + & .4548896E-03,.1456307E-02,.1647750E-02,.1587652E-02,.8696717E-03,& + & .5169304E-03,.1686770E-02,.1909185E-02,.1825449E-02,.9593282E-03,& + & .5876050E-03,.1966424E-02,.2220965E-02,.2109507E-02,.1057588E-02,& + & .6666461E-03,.2301238E-02,.2589214E-02,.2446720E-02,.1167507E-02,& + & .7525562E-03,.2698055E-02,.3023141E-02,.2843621E-02,.1289308E-02,& + & .3734897E-03,.1232867E-02,.1398777E-02,.1349075E-02,.7359709E-03,& + & .4253634E-03,.1438755E-02,.1632644E-02,.1562815E-02,.8174284E-03,& + & .4850469E-03,.1689562E-02,.1914018E-02,.1820551E-02,.9077182E-03,& + & .5522656E-03,.1992581E-02,.2249528E-02,.2128458E-02,.1008030E-02,& + & .6258618E-03,.2353791E-02,.2648433E-02,.2493658E-02,.1119658E-02,& + & .3045367E-03,.1033446E-02,.1175577E-02,.1135975E-02,.6197699E-03,& + & .3473823E-03,.1215271E-02,.1382545E-02,.1325828E-02,.6926384E-03,& + & .3970307E-03,.1437673E-02,.1633541E-02,.1556762E-02,.7746954E-03,& + & .4539062E-03,.1708894E-02,.1936090E-02,.1834842E-02,.8669180E-03,& + & .5165865E-03,.2034536E-02,.2299010E-02,.2167541E-02,.9692109E-03,& + & .2472336E-03,.8613164E-03,.9823016E-03,.9514129E-03,.5196099E-03,& + & .2828538E-03,.1020438E-02,.1163949E-02,.1118679E-02,.5847521E-03,& + & .3237516E-03,.1216274E-02,.1386324E-02,.1324100E-02,.6591741E-03,& + & .3714736E-03,.1458189E-02,.1657661E-02,.1574061E-02,.7425059E-03,& + & .4245663E-03,.1749792E-02,.1985372E-02,.1874641E-02,.8368539E-03,& + & .2006002E-03,.7166388E-03,.8191347E-03,.7953709E-03,.4345003E-03,& + & .2300088E-03,.8550124E-03,.9779366E-03,.9420990E-03,.4927929E-03,& + & .2640138E-03,.1027318E-02,.1174304E-02,.1124337E-02,.5593878E-03,& + & .3036185E-03,.1241926E-02,.1416866E-02,.1348159E-02,.6350064E-03,& + & .3483255E-03,.1503311E-02,.1712388E-02,.1619624E-02,.7206305E-03,& + & .1620672E-03,.5924002E-03,.6788004E-03,.6609668E-03,.3615247E-03,& + & .1863562E-03,.7120820E-03,.8162499E-03,.7885530E-03,.4130089E-03,& + & .2144232E-03,.8626280E-03,.9887801E-03,.9492287E-03,.4724825E-03,& + & .2473832E-03,.1051309E-02,.1203656E-02,.1147998E-02,.5403679E-03,& + & .2847841E-03,.1284144E-02,.1468365E-02,.1391452E-02,.6179991E-03,& + & .1299474E-03,.4846482E-03,.5565712E-03,.5436535E-03,.2982511E-03,& + & .1498986E-03,.5864424E-03,.6736990E-03,.6529381E-03,.3434172E-03,& + & .1729325E-03,.7163074E-03,.8229894E-03,.7924220E-03,.3957912E-03,& + & .2000081E-03,.8797706E-03,.1010993E-02,.9670011E-03,.4564930E-03,& + & .2313308E-03,.1085043E-02,.1245383E-02,.1182959E-02,.5264754E-03/ + + data absb(876:1050, 6) / & + & .1041538E-03,.3951902E-03,.4548472E-03,.4454470E-03,.2452479E-03,& + & .1203711E-03,.4813274E-03,.5542653E-03,.5387494E-03,.2845514E-03,& + & .1392557E-03,.5925482E-03,.6823171E-03,.6591592E-03,.3305080E-03,& + & .1615406E-03,.7342118E-03,.8463369E-03,.8118950E-03,.3843966E-03,& + & .1875302E-03,.9137067E-03,.1052775E-02,.1002597E-02,.4471473E-03,& + & .8339613E-04,.3212348E-03,.3702850E-03,.3635514E-03,.2009331E-03,& + & .9663218E-04,.3936340E-03,.4542459E-03,.4427976E-03,.2348384E-03,& + & .1119212E-03,.4884335E-03,.5635159E-03,.5461149E-03,.2749028E-03,& + & .1301921E-03,.6106310E-03,.7057229E-03,.6791355E-03,.3226368E-03,& + & .1518690E-03,.7666828E-03,.8867916E-03,.8470024E-03,.3788358E-03,& + & .6703277E-04,.2615715E-03,.3020685E-03,.2972644E-03,.1647457E-03,& + & .7781745E-04,.3226047E-03,.3728758E-03,.3643763E-03,.1940020E-03,& + & .9035340E-04,.4034207E-03,.4665853E-03,.4531468E-03,.2290995E-03,& + & .1051725E-03,.5090275E-03,.5895403E-03,.5690155E-03,.2711767E-03,& + & .1231606E-03,.6451073E-03,.7487546E-03,.7170779E-03,.3213112E-03,& + & .5388627E-04,.2129730E-03,.2462008E-03,.2426751E-03,.1352080E-03,& + & .6277450E-04,.2640459E-03,.3057224E-03,.2995161E-03,.1599361E-03,& + & .7304733E-04,.3329169E-03,.3859229E-03,.3754737E-03,.1906374E-03,& + & .8515751E-04,.4241494E-03,.4919296E-03,.4761974E-03,.2276739E-03,& + & .9991988E-04,.5432688E-03,.6320927E-03,.6069695E-03,.2723849E-03,& + & .4326262E-04,.1729315E-03,.2000827E-03,.1973909E-03,.1105920E-03,& + & .5057315E-04,.2155302E-03,.2498708E-03,.2454105E-03,.1317820E-03,& + & .5902025E-04,.2738145E-03,.3180329E-03,.3099867E-03,.1580455E-03,& + & .6892231E-04,.3521416E-03,.4093245E-03,.3971150E-03,.1905530E-03,& + & .8105656E-04,.4558123E-03,.5314348E-03,.5116504E-03,.2300912E-03,& + & .3466273E-04,.1400139E-03,.1619739E-03,.1598674E-03,.9004375E-04,& + & .4063512E-04,.1754360E-03,.2034983E-03,.2003206E-03,.1082624E-03,& + & .4757947E-04,.2243047E-03,.2609699E-03,.2549037E-03,.1307310E-03,& + & .5575140E-04,.2912187E-03,.3392706E-03,.3296565E-03,.1588775E-03,& + & .6571337E-04,.3810311E-03,.4450150E-03,.4296054E-03,.1937683E-03,& + & .2781043E-04,.1138793E-03,.1316412E-03,.1298484E-03,.7350396E-04,& + & .3277645E-04,.1433051E-03,.1663826E-03,.1640294E-03,.8913117E-04,& + & .3850357E-04,.1846844E-03,.2150481E-03,.2104981E-03,.1086380E-03,& + & .4522837E-04,.2419881E-03,.2824462E-03,.2747396E-03,.1329710E-03,& + & .5347828E-04,.3200061E-03,.3744878E-03,.3622497E-03,.1637392E-03/ + + data absb(1051:1175, 6) / & + & .2232236E-04,.9267720E-04,.1070487E-03,.1054862E-03,.5992194E-04,& + & .2641653E-04,.1172861E-03,.1361391E-03,.1343624E-03,.7334096E-04,& + & .3117369E-04,.1521353E-03,.1772789E-03,.1738983E-03,.9024944E-04,& + & .3674804E-04,.2011031E-03,.2351698E-03,.2290276E-03,.1115235E-03,& + & .4354793E-04,.2690881E-03,.3153806E-03,.3055401E-03,.1384935E-03,& + & .1785498E-04,.7521527E-04,.8673443E-04,.8536647E-04,.4869020E-04,& + & .2122523E-04,.9568767E-04,.1111031E-03,.1096456E-03,.6010776E-04,& + & .2515713E-04,.1249154E-03,.1456399E-03,.1431298E-03,.7472628E-04,& + & .2980978E-04,.1668004E-03,.1951256E-03,.1902764E-03,.9333750E-04,& + & .3542498E-04,.2255442E-03,.2648513E-03,.2567580E-03,.1168654E-03,& + & .1425709E-04,.6087198E-04,.7014411E-04,.6881006E-04,.3939206E-04,& + & .1702198E-04,.7779210E-04,.9029022E-04,.8913052E-04,.4908012E-04,& + & .2026100E-04,.1023006E-03,.1192918E-03,.1173391E-03,.6161544E-04,& + & .2410865E-04,.1377899E-03,.1613227E-03,.1576056E-03,.7784401E-04,& + & .2878722E-04,.1883410E-03,.2215045E-03,.2149526E-03,.9849260E-04,& + & .1138303E-04,.4934557E-04,.5673238E-04,.5553184E-04,.3186568E-04,& + & .1366146E-04,.6335560E-04,.7355595E-04,.7250807E-04,.4005918E-04,& + & .1632332E-04,.8387900E-04,.9788807E-04,.9633384E-04,.5083176E-04,& + & .1950274E-04,.1140523E-03,.1335383E-03,.1306879E-03,.6491699E-04,& + & .2338070E-04,.1577480E-03,.1855710E-03,.1802136E-03,.8318615E-04,& + & .9393833E-05,.4172083E-04,.4794329E-04,.4688225E-04,.2676670E-04,& + & .1131203E-04,.5413446E-04,.6285587E-04,.6190797E-04,.3404469E-04,& + & .1356891E-04,.7245624E-04,.8467100E-04,.8329182E-04,.4370019E-04,& + & .1627959E-04,.9993465E-04,.1171212E-03,.1145831E-03,.5652037E-04,& + & .1962119E-04,.1401179E-03,.1650762E-03,.1601642E-03,.7346404E-04/ + + data absb( 1:175, 7) / & + & .3229900E+00,.5476000E+00,.6007900E+00,.5851700E+00,.4227600E+00,& + & .3259400E+00,.5596300E+00,.6165300E+00,.6014700E+00,.4328100E+00,& + & .3305600E+00,.5718200E+00,.6323600E+00,.6186300E+00,.4414900E+00,& + & .3370600E+00,.5842600E+00,.6482200E+00,.6348900E+00,.4489300E+00,& + & .3463500E+00,.5973900E+00,.6634300E+00,.6500300E+00,.4548600E+00,& + & .2718500E+00,.4739600E+00,.5208700E+00,.5051800E+00,.3589800E+00,& + & .2745500E+00,.4845400E+00,.5347300E+00,.5205800E+00,.3672500E+00,& + & .2787800E+00,.4952300E+00,.5487600E+00,.5355600E+00,.3747700E+00,& + & .2854000E+00,.5066000E+00,.5624400E+00,.5494800E+00,.3809500E+00,& + & .2947400E+00,.5187600E+00,.5759200E+00,.5625500E+00,.3866000E+00,& + & .2281800E+00,.4082500E+00,.4500300E+00,.4358200E+00,.3035000E+00,& + & .2307400E+00,.4174900E+00,.4622000E+00,.4493000E+00,.3106400E+00,& + & .2351000E+00,.4273700E+00,.4743400E+00,.4620200E+00,.3169600E+00,& + & .2418600E+00,.4378300E+00,.4863700E+00,.4738700E+00,.3226500E+00,& + & .2512100E+00,.4494300E+00,.4985500E+00,.4851900E+00,.3281600E+00,& + & .1912000E+00,.3497500E+00,.3873200E+00,.3750900E+00,.2561700E+00,& + & .1938500E+00,.3582600E+00,.3979900E+00,.3866600E+00,.2625900E+00,& + & .1984600E+00,.3672700E+00,.4087200E+00,.3975000E+00,.2681500E+00,& + & .2053700E+00,.3771200E+00,.4195400E+00,.4077700E+00,.2733000E+00,& + & .2142700E+00,.3886800E+00,.4307100E+00,.4178400E+00,.2785300E+00,& + & .1598800E+00,.2985400E+00,.3318000E+00,.3220100E+00,.2161100E+00,& + & .1627900E+00,.3062800E+00,.3412900E+00,.3318800E+00,.2216200E+00,& + & .1676300E+00,.3146300E+00,.3508500E+00,.3412200E+00,.2266400E+00,& + & .1744400E+00,.3243200E+00,.3606800E+00,.3503200E+00,.2316100E+00,& + & .1827400E+00,.3360900E+00,.3714000E+00,.3594400E+00,.2366500E+00,& + & .1335200E+00,.2540400E+00,.2833000E+00,.2757700E+00,.1822500E+00,& + & .1366700E+00,.2610300E+00,.2917100E+00,.2843100E+00,.1871200E+00,& + & .1416400E+00,.2691000E+00,.3003000E+00,.2925400E+00,.1917600E+00,& + & .1480900E+00,.2788600E+00,.3095900E+00,.3007300E+00,.1963700E+00,& + & .1555100E+00,.2905000E+00,.3202000E+00,.3093000E+00,.2011500E+00,& + & .1117700E+00,.2158000E+00,.2413600E+00,.2355200E+00,.1539200E+00,& + & .1150400E+00,.2224300E+00,.2489000E+00,.2430400E+00,.1583300E+00,& + & .1197500E+00,.2303100E+00,.2568700E+00,.2504800E+00,.1624400E+00,& + & .1255300E+00,.2399400E+00,.2658800E+00,.2581200E+00,.1667100E+00,& + & .1320400E+00,.2510700E+00,.2763900E+00,.2662900E+00,.1711000E+00/ + + data absb(176:350, 7) / & + & .9381800E-01,.1833600E+00,.2053300E+00,.2008300E+00,.1306300E+00,& + & .9715300E-01,.1897500E+00,.2122200E+00,.2075400E+00,.1344500E+00,& + & .1015700E+00,.1975900E+00,.2198900E+00,.2143900E+00,.1381900E+00,& + & .1065600E+00,.2069200E+00,.2288500E+00,.2217000E+00,.1420000E+00,& + & .1121700E+00,.2174100E+00,.2391400E+00,.2297200E+00,.1459500E+00,& + & .7886400E-01,.1558100E+00,.1746700E+00,.1711100E+00,.1109300E+00,& + & .8211500E-01,.1621300E+00,.1811400E+00,.1772200E+00,.1144800E+00,& + & .8609100E-01,.1698900E+00,.1885800E+00,.1836800E+00,.1179500E+00,& + & .9054400E-01,.1788300E+00,.1974000E+00,.1907500E+00,.1214000E+00,& + & .9553100E-01,.1885700E+00,.2071900E+00,.1987200E+00,.1249400E+00,& + & .6653600E-01,.1329300E+00,.1491300E+00,.1461800E+00,.9442900E-01,& + & .6963900E-01,.1393100E+00,.1553700E+00,.1518700E+00,.9768000E-01,& + & .7319400E-01,.1468800E+00,.1628200E+00,.1580500E+00,.1008700E+00,& + & .7720500E-01,.1553600E+00,.1713500E+00,.1650300E+00,.1041400E+00,& + & .8166700E-01,.1642700E+00,.1806600E+00,.1729100E+00,.1074400E+00,& + & .5626100E-01,.1138300E+00,.1276000E+00,.1251200E+00,.8055900E-01,& + & .5908600E-01,.1201400E+00,.1338400E+00,.1304800E+00,.8348500E-01,& + & .6228100E-01,.1273800E+00,.1412100E+00,.1364800E+00,.8646000E-01,& + & .6590600E-01,.1351700E+00,.1493700E+00,.1433600E+00,.8946200E-01,& + & .6999800E-01,.1433500E+00,.1580700E+00,.1509800E+00,.9258800E-01,& + & .4764200E-01,.9793300E-01,.1096300E+00,.1074200E+00,.6875000E-01,& + & .5019300E-01,.1039900E+00,.1158700E+00,.1125800E+00,.7143200E-01,& + & .5308500E-01,.1107700E+00,.1229800E+00,.1184500E+00,.7419400E-01,& + & .5638400E-01,.1179500E+00,.1307000E+00,.1251200E+00,.7697300E-01,& + & .6017400E-01,.1255500E+00,.1387900E+00,.1323700E+00,.7992000E-01,& + & .4043200E-01,.8464500E-01,.9472400E-01,.9263700E-01,.5880500E-01,& + & .4274800E-01,.9040900E-01,.1007900E+00,.9765400E-01,.6128900E-01,& + & .4539200E-01,.9668200E-01,.1075600E+00,.1034100E+00,.6381800E-01,& + & .4843800E-01,.1033500E+00,.1147800E+00,.1097800E+00,.6648100E-01,& + & .5201900E-01,.1105000E+00,.1223400E+00,.1166400E+00,.6920900E-01,& + & .3443000E-01,.7356700E-01,.8234900E-01,.8034100E-01,.5048500E-01,& + & .3655800E-01,.7899700E-01,.8816300E-01,.8529300E-01,.5283500E-01,& + & .3900900E-01,.8481800E-01,.9452100E-01,.9085100E-01,.5518100E-01,& + & .4187600E-01,.9107400E-01,.1012700E+00,.9692200E-01,.5764400E-01,& + & .4529400E-01,.9787400E-01,.1084100E+00,.1034000E+00,.6025800E-01/ + + data absb(351:525, 7) / & + & .2941800E-01,.6428900E-01,.7198400E-01,.7011200E-01,.4351400E-01,& + & .3136700E-01,.6933300E-01,.7750000E-01,.7494500E-01,.4565400E-01,& + & .3365000E-01,.7477900E-01,.8345100E-01,.8028400E-01,.4783800E-01,& + & .3637300E-01,.8069800E-01,.8980300E-01,.8603500E-01,.5018800E-01,& + & .3962500E-01,.8722700E-01,.9660500E-01,.9216300E-01,.5266100E-01,& + & .2520600E-01,.5643600E-01,.6328200E-01,.6157100E-01,.3760200E-01,& + & .2700900E-01,.6114700E-01,.6848100E-01,.6623700E-01,.3956200E-01,& + & .2915000E-01,.6630200E-01,.7407400E-01,.7134100E-01,.4160100E-01,& + & .3175000E-01,.7195500E-01,.8010400E-01,.7678500E-01,.4379400E-01,& + & .3483400E-01,.7826800E-01,.8666200E-01,.8263200E-01,.4619300E-01,& + & .2167200E-01,.4982100E-01,.5598500E-01,.5443100E-01,.3267700E-01,& + & .2336000E-01,.5425700E-01,.6087100E-01,.5891800E-01,.3445300E-01,& + & .2542000E-01,.5915900E-01,.6616800E-01,.6376500E-01,.3639800E-01,& + & .2790800E-01,.6462900E-01,.7193500E-01,.6897700E-01,.3849000E-01,& + & .3084300E-01,.7079100E-01,.7832300E-01,.7461000E-01,.4074700E-01,& + & .1870300E-01,.4423600E-01,.4981900E-01,.4842300E-01,.2850300E-01,& + & .2031500E-01,.4844500E-01,.5442500E-01,.5272000E-01,.3017400E-01,& + & .2230700E-01,.5316300E-01,.5948100E-01,.5735900E-01,.3201800E-01,& + & .2468700E-01,.5849500E-01,.6506400E-01,.6236800E-01,.3402200E-01,& + & .2751000E-01,.6459700E-01,.7135200E-01,.6786000E-01,.3624300E-01,& + & .1622700E-01,.3954600E-01,.4461300E-01,.4338400E-01,.2494700E-01,& + & .1779100E-01,.4357600E-01,.4901000E-01,.4750100E-01,.2657700E-01,& + & .1972000E-01,.4816300E-01,.5387700E-01,.5196200E-01,.2834700E-01,& + & .2201000E-01,.5341900E-01,.5936800E-01,.5684200E-01,.3032600E-01,& + & .2477800E-01,.5953300E-01,.6558200E-01,.6227900E-01,.3246400E-01,& + & .1416800E-01,.3561000E-01,.4022800E-01,.3914500E-01,.2199800E-01,& + & .1570100E-01,.3951800E-01,.4445500E-01,.4310800E-01,.2355100E-01,& + & .1756800E-01,.4402800E-01,.4922800E-01,.4744200E-01,.2530300E-01,& + & .1982200E-01,.4927400E-01,.5464400E-01,.5226900E-01,.2721900E-01,& + & .2249200E-01,.5542900E-01,.6087800E-01,.5769600E-01,.2928900E-01,& + & .1246900E-01,.3232100E-01,.3654800E-01,.3558600E-01,.1953500E-01,& + & .1396700E-01,.3616000E-01,.4067000E-01,.3941400E-01,.2105700E-01,& + & .1580400E-01,.4064600E-01,.4537100E-01,.4369700E-01,.2274800E-01,& + & .1800700E-01,.4593500E-01,.5079000E-01,.4850400E-01,.2458900E-01,& + & .2058300E-01,.5211700E-01,.5708300E-01,.5394900E-01,.2661200E-01/ + + data absb(526:700, 7) / & + & .1103000E-01,.2946200E-01,.3333300E-01,.3245700E-01,.1744100E-01,& + & .1248500E-01,.3325200E-01,.3737400E-01,.3620300E-01,.1890200E-01,& + & .1428400E-01,.3773500E-01,.4203900E-01,.4044900E-01,.2053300E-01,& + & .1640600E-01,.4305000E-01,.4747300E-01,.4525000E-01,.2231500E-01,& + & .1888900E-01,.4922100E-01,.5383800E-01,.5070900E-01,.2429500E-01,& + & .9704500E-02,.2676500E-01,.3029400E-01,.2949400E-01,.1552700E-01,& + & .1111600E-01,.3047100E-01,.3423700E-01,.3315600E-01,.1693600E-01,& + & .1283300E-01,.3490800E-01,.3882700E-01,.3733500E-01,.1849400E-01,& + & .1485100E-01,.4016000E-01,.4422800E-01,.4209500E-01,.2023000E-01,& + & .1722000E-01,.4627500E-01,.5060000E-01,.4752400E-01,.2213700E-01,& + & .8478700E-02,.2413100E-01,.2733900E-01,.2661900E-01,.1375600E-01,& + & .9803300E-02,.2770600E-01,.3114700E-01,.3016600E-01,.1510600E-01,& + & .1140700E-01,.3201500E-01,.3561000E-01,.3423900E-01,.1659300E-01,& + & .1330200E-01,.3714000E-01,.4090700E-01,.3890400E-01,.1825700E-01,& + & .1553700E-01,.4312900E-01,.4718200E-01,.4423600E-01,.2007400E-01,& + & .7268500E-02,.2139200E-01,.2430100E-01,.2367900E-01,.1208700E-01,& + & .8473300E-02,.2475900E-01,.2789800E-01,.2704600E-01,.1334200E-01,& + & .9935300E-02,.2884800E-01,.3215200E-01,.3094000E-01,.1474800E-01,& + & .1167300E-01,.3373400E-01,.3722400E-01,.3542200E-01,.1631900E-01,& + & .1374000E-01,.3948100E-01,.4325600E-01,.4056600E-01,.1804900E-01,& + & .6232600E-02,.1899900E-01,.2164400E-01,.2110300E-01,.1062900E-01,& + & .7326900E-02,.2217000E-01,.2504200E-01,.2429900E-01,.1180700E-01,& + & .8658600E-02,.2604500E-01,.2909800E-01,.2801900E-01,.1313800E-01,& + & .1025400E-01,.3069900E-01,.3395200E-01,.3231600E-01,.1462100E-01,& + & .1216800E-01,.3621100E-01,.3974800E-01,.3728800E-01,.1626300E-01,& + & .5352200E-02,.1692500E-01,.1933700E-01,.1886300E-01,.9369700E-02,& + & .6343700E-02,.1991600E-01,.2255500E-01,.2190000E-01,.1047700E-01,& + & .7560000E-02,.2359000E-01,.2642800E-01,.2545300E-01,.1173200E-01,& + & .9027700E-02,.2802700E-01,.3108100E-01,.2958100E-01,.1314000E-01,& + & .1080400E-01,.3332500E-01,.3665500E-01,.3439600E-01,.1471400E-01,& + & .4518300E-02,.1486200E-01,.1704300E-01,.1664000E-01,.8190600E-02,& + & .5396400E-02,.1763000E-01,.2004300E-01,.1948200E-01,.9233500E-02,& + & .6483500E-02,.2104100E-01,.2367400E-01,.2282100E-01,.1040000E-01,& + & .7810000E-02,.2519700E-01,.2805600E-01,.2673300E-01,.1171800E-01,& + & .9431000E-02,.3020300E-01,.3332200E-01,.3132100E-01,.1320900E-01/ + + data absb(701:875, 7) / & + & .3802000E-02,.1303500E-01,.1500700E-01,.1466500E-01,.7164500E-02,& + & .4579600E-02,.1559200E-01,.1780200E-01,.1732000E-01,.8133200E-02,& + & .5546400E-02,.1874900E-01,.2119100E-01,.2044800E-01,.9231200E-02,& + & .6740800E-02,.2262900E-01,.2530900E-01,.2414300E-01,.1045800E-01,& + & .8215500E-02,.2734700E-01,.3027700E-01,.2850600E-01,.1187100E-01,& + & .3196200E-02,.1144400E-01,.1322900E-01,.1293700E-01,.6278800E-02,& + & .3881500E-02,.1379800E-01,.1582200E-01,.1540700E-01,.7177400E-02,& + & .4742200E-02,.1672200E-01,.1899000E-01,.1833900E-01,.8198600E-02,& + & .5815400E-02,.2034200E-01,.2285700E-01,.2183000E-01,.9359400E-02,& + & .7154600E-02,.2478700E-01,.2754500E-01,.2597300E-01,.1068400E-01,& + & .2654200E-02,.9942100E-02,.1154500E-01,.1129700E-01,.5468100E-02,& + & .3246700E-02,.1208500E-01,.1392600E-01,.1357500E-01,.6301700E-02,& + & .4003700E-02,.1475800E-01,.1684800E-01,.1629600E-01,.7243400E-02,& + & .4953400E-02,.1809400E-01,.2043800E-01,.1955600E-01,.8335400E-02,& + & .6152500E-02,.2223000E-01,.2481700E-01,.2345000E-01,.9575100E-02,& + & .2188100E-02,.8585700E-02,.1001900E-01,.9804300E-02,.4745600E-02,& + & .2693700E-02,.1052500E-01,.1219200E-01,.1189800E-01,.5516800E-02,& + & .3353100E-02,.1295200E-01,.1487000E-01,.1440800E-01,.6393800E-02,& + & .4191600E-02,.1601600E-01,.1818700E-01,.1744100E-01,.7399500E-02,& + & .5252900E-02,.1982500E-01,.2224500E-01,.2107400E-01,.8569300E-02,& + & .1797400E-02,.7403600E-02,.8681900E-02,.8494900E-02,.4110000E-02,& + & .2228300E-02,.9155600E-02,.1066400E-01,.1041400E-01,.4825700E-02,& + & .2799300E-02,.1136000E-01,.1311500E-01,.1273100E-01,.5642300E-02,& + & .3535800E-02,.1416400E-01,.1617000E-01,.1554300E-01,.6586700E-02,& + & .4476200E-02,.1767100E-01,.1992800E-01,.1893100E-01,.7672500E-02,& + & .1466600E-02,.6344300E-02,.7471000E-02,.7309900E-02,.3554000E-02,& + & .1828600E-02,.7914000E-02,.9271900E-02,.9058800E-02,.4198100E-02,& + & .2319600E-02,.9908900E-02,.1150800E-01,.1119200E-01,.4965600E-02,& + & .2957500E-02,.1245100E-01,.1429600E-01,.1377900E-01,.5844100E-02,& + & .3784200E-02,.1566200E-01,.1775800E-01,.1692100E-01,.6866000E-02,& + & .1182200E-02,.5370000E-02,.6348300E-02,.6209000E-02,.3050000E-02,& + & .1481700E-02,.6761600E-02,.7967800E-02,.7787400E-02,.3631700E-02,& + & .1891800E-02,.8539200E-02,.9981800E-02,.9725400E-02,.4324800E-02,& + & .2438200E-02,.1082000E-01,.1250300E-01,.1208800E-01,.5147700E-02,& + & .3153300E-02,.1372500E-01,.1565600E-01,.1497000E-01,.6100000E-02/ + + data absb(876:1050, 7) / & + & .9490600E-03,.4529800E-02,.5370600E-02,.5250600E-02,.2616200E-02,& + & .1196500E-02,.5759700E-02,.6821300E-02,.6669800E-02,.3140300E-02,& + & .1536900E-02,.7338000E-02,.8636800E-02,.8424600E-02,.3768700E-02,& + & .2000800E-02,.9381400E-02,.1091100E-01,.1058000E-01,.4521300E-02,& + & .2615900E-02,.1200200E-01,.1377400E-01,.1322100E-01,.5414200E-02,& + & .7591300E-03,.3804300E-02,.4520300E-02,.4418100E-02,.2237900E-02,& + & .9609700E-03,.4889900E-02,.5813800E-02,.5687800E-02,.2709800E-02,& + & .1244700E-02,.6289500E-02,.7450100E-02,.7272700E-02,.3285900E-02,& + & .1632200E-02,.8112200E-02,.9498900E-02,.9234900E-02,.3972000E-02,& + & .2159700E-02,.1047000E-01,.1209200E-01,.1165000E-01,.4793800E-02,& + & .6094900E-03,.3200900E-02,.3808000E-02,.3720400E-02,.1914800E-02,& + & .7733200E-03,.4163700E-02,.4965800E-02,.4858800E-02,.2349800E-02,& + & .1009900E-02,.5409500E-02,.6441600E-02,.6293800E-02,.2871300E-02,& + & .1335300E-02,.7041700E-02,.8300400E-02,.8084400E-02,.3511400E-02,& + & .1787300E-02,.9169100E-02,.1065800E-01,.1030300E-01,.4264100E-02,& + & .4896000E-03,.2687300E-02,.3200800E-02,.3125900E-02,.1637800E-02,& + & .6218700E-03,.3542300E-02,.4234900E-02,.4144300E-02,.2032500E-02,& + & .8178800E-03,.4652900E-02,.5565600E-02,.5442400E-02,.2516400E-02,& + & .1093500E-02,.6115500E-02,.7256500E-02,.7076500E-02,.3100700E-02,& + & .1477600E-02,.8041600E-02,.9408700E-02,.9119700E-02,.3808500E-02,& + & .3930200E-03,.2243500E-02,.2675400E-02,.2612200E-02,.1389800E-02,& + & .4988900E-03,.3000600E-02,.3594300E-02,.3517200E-02,.1753200E-02,& + & .6592200E-03,.3990600E-02,.4790100E-02,.4688000E-02,.2198000E-02,& + & .8907500E-03,.5298000E-02,.6323700E-02,.6174800E-02,.2741200E-02,& + & .1215000E-02,.7031200E-02,.8283700E-02,.8049700E-02,.3395600E-02,& + & .3153300E-03,.1859800E-02,.2221600E-02,.2169000E-02,.1170500E-02,& + & .3991900E-03,.2529000E-02,.3033800E-02,.2967900E-02,.1505100E-02,& + & .5295800E-03,.3409600E-02,.4103000E-02,.4018900E-02,.1913700E-02,& + & .7214700E-03,.4575600E-02,.5489400E-02,.5367800E-02,.2414700E-02,& + & .9956300E-03,.6132100E-02,.7273900E-02,.7082600E-02,.3028600E-02,& + & .2543400E-03,.1547700E-02,.1850200E-02,.1807500E-02,.9889100E-03,& + & .3222100E-03,.2139800E-02,.2570800E-02,.2514800E-02,.1293500E-02,& + & .4277500E-03,.2927200E-02,.3531500E-02,.3459900E-02,.1674100E-02,& + & .5876200E-03,.3976100E-02,.4790700E-02,.4689600E-02,.2137600E-02,& + & .8205300E-03,.5382400E-02,.6424400E-02,.6266400E-02,.2717300E-02/ + + data absb(1051:1175, 7) / & + & .2061800E-03,.1286600E-02,.1540000E-02,.1505500E-02,.8357200E-03,& + & .2605900E-03,.1809400E-02,.2178700E-02,.2130200E-02,.1109000E-02,& + & .3465100E-03,.2514000E-02,.3039200E-02,.2978000E-02,.1462800E-02,& + & .4788200E-03,.3460800E-02,.4183100E-02,.4100300E-02,.1899200E-02,& + & .6767100E-03,.4733100E-02,.5681700E-02,.5550300E-02,.2436000E-02,& + & .1668100E-03,.1062100E-02,.1272800E-02,.1246100E-02,.7016200E-03,& + & .2106400E-03,.1521300E-02,.1835000E-02,.1794500E-02,.9482800E-03,& + & .2802800E-03,.2150000E-02,.2604500E-02,.2552100E-02,.1272100E-02,& + & .3890600E-03,.3002900E-02,.3638700E-02,.3571000E-02,.1683300E-02,& + & .5556800E-03,.4153400E-02,.5011100E-02,.4902700E-02,.2184900E-02,& + & .1348400E-03,.8716800E-03,.1044400E-02,.1024800E-02,.5851600E-03,& + & .1700700E-03,.1271700E-02,.1536000E-02,.1502400E-02,.8080500E-03,& + & .2260300E-03,.1829600E-02,.2221100E-02,.2175700E-02,.1100600E-02,& + & .3156500E-03,.2596300E-02,.3153100E-02,.3095900E-02,.1485100E-02,& + & .4541700E-03,.3636500E-02,.4405800E-02,.4315700E-02,.1962500E-02,& + & .1093800E-03,.7144900E-03,.8565500E-03,.8424000E-03,.4877200E-03,& + & .1375200E-03,.1062400E-02,.1284900E-02,.1258300E-02,.6868900E-03,& + & .1830700E-03,.1557200E-02,.1895400E-02,.1856600E-02,.9534400E-03,& + & .2567300E-03,.2248100E-02,.2736300E-02,.2687700E-02,.1307900E-02,& + & .3723000E-03,.3192100E-02,.3881200E-02,.3807000E-02,.1757000E-02,& + & .9215300E-04,.6279800E-03,.7537400E-03,.7424300E-03,.4316100E-03,& + & .1167600E-03,.9501900E-03,.1152500E-02,.1129600E-02,.6195900E-03,& + & .1568700E-03,.1416800E-02,.1728500E-02,.1693800E-02,.8746800E-03,& + & .2227800E-03,.2074300E-02,.2530200E-02,.2486300E-02,.1216100E-02,& + & .3272400E-03,.2979700E-02,.3631300E-02,.3566400E-02,.1657700E-02/ + + data absb( 1:175, 8) / & + & .2147772E+01,.3506523E+01,.4007672E+01,.4063247E+01,.2937459E+01,& + & .2178726E+01,.3529383E+01,.4034995E+01,.4103957E+01,.3003216E+01,& + & .2233362E+01,.3568760E+01,.4070770E+01,.4144550E+01,.3061714E+01,& + & .2307004E+01,.3623393E+01,.4115151E+01,.4185941E+01,.3115511E+01,& + & .2388633E+01,.3691850E+01,.4168630E+01,.4227592E+01,.3167839E+01,& + & .1860982E+01,.3098016E+01,.3558079E+01,.3627319E+01,.2627403E+01,& + & .1905280E+01,.3134646E+01,.3595375E+01,.3671395E+01,.2687036E+01,& + & .1969054E+01,.3186559E+01,.3641361E+01,.3716596E+01,.2741361E+01,& + & .2041391E+01,.3252536E+01,.3696281E+01,.3763063E+01,.2795119E+01,& + & .2116579E+01,.3332677E+01,.3758858E+01,.3812101E+01,.2847416E+01,& + & .1617458E+01,.2741093E+01,.3152632E+01,.3221428E+01,.2339877E+01,& + & .1670160E+01,.2788238E+01,.3198512E+01,.3269657E+01,.2396388E+01,& + & .1732677E+01,.2849720E+01,.3253678E+01,.3319736E+01,.2449246E+01,& + & .1797925E+01,.2926437E+01,.3317317E+01,.3372271E+01,.2501129E+01,& + & .1862880E+01,.3012958E+01,.3388595E+01,.3427980E+01,.2552877E+01,& + & .1410490E+01,.2430273E+01,.2789567E+01,.2851573E+01,.2070884E+01,& + & .1462546E+01,.2486398E+01,.2843042E+01,.2903268E+01,.2125260E+01,& + & .1517639E+01,.2557586E+01,.2906093E+01,.2957563E+01,.2178494E+01,& + & .1573385E+01,.2638614E+01,.2977318E+01,.3015588E+01,.2231226E+01,& + & .1630346E+01,.2723778E+01,.3055751E+01,.3077711E+01,.2281963E+01,& + & .1230541E+01,.2156310E+01,.2468500E+01,.2517143E+01,.1827564E+01,& + & .1276117E+01,.2220980E+01,.2528907E+01,.2572462E+01,.1880843E+01,& + & .1322689E+01,.2296509E+01,.2597740E+01,.2631249E+01,.1932799E+01,& + & .1370777E+01,.2376996E+01,.2674941E+01,.2694611E+01,.1983918E+01,& + & .1421644E+01,.2457551E+01,.2758874E+01,.2763587E+01,.2034867E+01,& + & .1070969E+01,.1915020E+01,.2186826E+01,.2218812E+01,.1611091E+01,& + & .1109526E+01,.1984117E+01,.2252013E+01,.2276826E+01,.1661713E+01,& + & .1149568E+01,.2059351E+01,.2326295E+01,.2340036E+01,.1710989E+01,& + & .1192105E+01,.2135358E+01,.2407183E+01,.2409247E+01,.1761075E+01,& + & .1238203E+01,.2211009E+01,.2491678E+01,.2482619E+01,.1811988E+01,& + & .9283756E+00,.1702510E+01,.1938601E+01,.1955270E+01,.1419882E+01,& + & .9616580E+00,.1771777E+01,.2008679E+01,.2016979E+01,.1468037E+01,& + & .9971495E+00,.1842985E+01,.2085977E+01,.2084514E+01,.1515441E+01,& + & .1035954E+01,.1914171E+01,.2167568E+01,.2156971E+01,.1563415E+01,& + & .1079188E+01,.1986694E+01,.2252099E+01,.2233773E+01,.1612851E+01/ + + data absb(176:350, 8) / & + & .8036031E+00,.1516186E+01,.1721627E+01,.1727213E+01,.1252674E+01,& + & .8326793E+00,.1581949E+01,.1794758E+01,.1792292E+01,.1298932E+01,& + & .8648349E+00,.1648188E+01,.1873088E+01,.1862805E+01,.1346221E+01,& + & .9010472E+00,.1716012E+01,.1954493E+01,.1937771E+01,.1392209E+01,& + & .9422352E+00,.1787156E+01,.2036790E+01,.2017682E+01,.1438445E+01,& + & .6953625E+00,.1350659E+01,.1532717E+01,.1530267E+01,.1104610E+01,& + & .7214726E+00,.1411984E+01,.1606492E+01,.1597505E+01,.1150564E+01,& + & .7509696E+00,.1474817E+01,.1683945E+01,.1669864E+01,.1196729E+01,& + & .7851546E+00,.1540757E+01,.1763201E+01,.1747500E+01,.1242539E+01,& + & .8247478E+00,.1610749E+01,.1844223E+01,.1828234E+01,.1287882E+01,& + & .6026917E+00,.1207364E+01,.1372521E+01,.1364577E+01,.9775652E+00,& + & .6273178E+00,.1265727E+01,.1445916E+01,.1433870E+01,.1022600E+01,& + & .6557573E+00,.1326639E+01,.1521041E+01,.1508141E+01,.1067263E+01,& + & .6889575E+00,.1391759E+01,.1598467E+01,.1586453E+01,.1112837E+01,& + & .7278457E+00,.1461987E+01,.1679430E+01,.1668167E+01,.1158214E+01,& + & .5220814E+00,.1081272E+01,.1234021E+01,.1222809E+01,.8668184E+00,& + & .5462161E+00,.1137925E+01,.1304901E+01,.1293790E+01,.9111319E+00,& + & .5743245E+00,.1198422E+01,.1378329E+01,.1368895E+01,.9551067E+00,& + & .6074624E+00,.1263493E+01,.1455169E+01,.1447720E+01,.9999031E+00,& + & .6464214E+00,.1334732E+01,.1536800E+01,.1530362E+01,.1044710E+01,& + & .4530676E+00,.9718752E+00,.1113625E+01,.1102459E+01,.7702607E+00,& + & .4767827E+00,.1027819E+01,.1182580E+01,.1173836E+01,.8131121E+00,& + & .5050006E+00,.1088357E+01,.1255221E+01,.1249573E+01,.8570364E+00,& + & .5385629E+00,.1154487E+01,.1332423E+01,.1329078E+01,.9009956E+00,& + & .5782279E+00,.1226660E+01,.1415277E+01,.1412212E+01,.9457995E+00,& + & .3944211E+00,.8783220E+00,.1009831E+01,.1000358E+01,.6870193E+00,& + & .4180031E+00,.9342002E+00,.1077916E+01,.1071914E+01,.7295172E+00,& + & .4466039E+00,.9953298E+00,.1150465E+01,.1147983E+01,.7723351E+00,& + & .4807452E+00,.1062397E+01,.1228665E+01,.1227974E+01,.8161121E+00,& + & .5212184E+00,.1135828E+01,.1313016E+01,.1312663E+01,.8641655E+00,& + & .3452462E+00,.7999293E+00,.9219804E+00,.9149658E+00,.6174465E+00,& + & .3690573E+00,.8557897E+00,.9899741E+00,.9866927E+00,.6583574E+00,& + & .3981461E+00,.9176898E+00,.1063178E+01,.1062821E+01,.7012026E+00,& + & .4331021E+00,.9859104E+00,.1142768E+01,.1144162E+01,.7470311E+00,& + & .4742396E+00,.1061101E+01,.1229416E+01,.1231158E+01,.7973609E+00/ + + data absb(351:525, 8) / & + & .3040686E+00,.7336469E+00,.8476943E+00,.8430763E+00,.5574518E+00,& + & .3283125E+00,.7901985E+00,.9160319E+00,.9148169E+00,.5982934E+00,& + & .3580998E+00,.8530076E+00,.9905938E+00,.9917986E+00,.6421955E+00,& + & .3937998E+00,.9226604E+00,.1072205E+01,.1075289E+01,.6908810E+00,& + & .4350420E+00,.1000013E+01,.1161544E+01,.1165076E+01,.7420692E+00,& + & .2699261E+00,.6782542E+00,.7854145E+00,.7829386E+00,.5064205E+00,& + & .2947504E+00,.7357341E+00,.8549126E+00,.8551804E+00,.5487324E+00,& + & .3252847E+00,.7997113E+00,.9311639E+00,.9339914E+00,.5953021E+00,& + & .3613092E+00,.8712485E+00,.1015309E+01,.1020027E+01,.6445334E+00,& + & .4023145E+00,.9510193E+00,.1107717E+01,.1113072E+01,.6967532E+00,& + & .2420005E+00,.6327790E+00,.7343674E+00,.7337147E+00,.4659044E+00,& + & .2675426E+00,.6914513E+00,.8056098E+00,.8073577E+00,.5100332E+00,& + & .2985977E+00,.7570808E+00,.8841869E+00,.8886282E+00,.5568586E+00,& + & .3345903E+00,.8307955E+00,.9712488E+00,.9777164E+00,.6069869E+00,& + & .3752790E+00,.9132888E+00,.1067298E+01,.1074521E+01,.6606337E+00,& + & .2193104E+00,.5956904E+00,.6933100E+00,.6941123E+00,.4338918E+00,& + & .2454356E+00,.6558867E+00,.7665763E+00,.7700794E+00,.4783097E+00,& + & .2766892E+00,.7234267E+00,.8479414E+00,.8542122E+00,.5258379E+00,& + & .3125185E+00,.7996635E+00,.9383927E+00,.9468621E+00,.5771763E+00,& + & .3530433E+00,.8851441E+00,.1038330E+01,.1047465E+01,.6323351E+00,& + & .2011174E+00,.5662868E+00,.6614813E+00,.6638455E+00,.4081986E+00,& + & .2276405E+00,.6282768E+00,.7371843E+00,.7426597E+00,.4531121E+00,& + & .2588601E+00,.6982349E+00,.8218536E+00,.8302250E+00,.5017038E+00,& + & .2946400E+00,.7772718E+00,.9161532E+00,.9266575E+00,.5545280E+00,& + & .3351557E+00,.8661253E+00,.1020315E+01,.1031181E+01,.6114083E+00,& + & .1865615E+00,.5436250E+00,.6378358E+00,.6421123E+00,.3878649E+00,& + & .2133106E+00,.6078013E+00,.7166414E+00,.7241786E+00,.4336769E+00,& + & .2445042E+00,.6804884E+00,.8049500E+00,.8154355E+00,.4837168E+00,& + & .2803835E+00,.7627085E+00,.9033997E+00,.9157583E+00,.5381867E+00,& + & .3210362E+00,.8552279E+00,.1011978E+01,.1024218E+01,.5970880E+00,& + & .1749538E+00,.5269996E+00,.6215976E+00,.6279908E+00,.3723894E+00,& + & .2017790E+00,.5937199E+00,.7039645E+00,.7136463E+00,.4194095E+00,& + & .2331437E+00,.6694912E+00,.7962787E+00,.8088205E+00,.4711663E+00,& + & .2692141E+00,.7551867E+00,.8989845E+00,.9129664E+00,.5275761E+00,& + & .3102376E+00,.8516644E+00,.1011909E+01,.1025210E+01,.5885594E+00/ + + data absb(526:700, 8) / & + & .1648200E+00,.5135795E+00,.6093601E+00,.6178369E+00,.3595625E+00,& + & .1916764E+00,.5828141E+00,.6952491E+00,.7068257E+00,.4080742E+00,& + & .2231330E+00,.6615194E+00,.7912997E+00,.8055439E+00,.4615211E+00,& + & .2594329E+00,.7506484E+00,.8977476E+00,.9130454E+00,.5197857E+00,& + & .3009092E+00,.8509191E+00,.1014517E+01,.1028676E+01,.5827702E+00,& + & .1542942E+00,.4984661E+00,.5950172E+00,.6050995E+00,.3460966E+00,& + & .1808778E+00,.5696361E+00,.6834611E+00,.6965516E+00,.3958165E+00,& + & .2120868E+00,.6504539E+00,.7821549E+00,.7977925E+00,.4505357E+00,& + & .2483187E+00,.7421169E+00,.8913076E+00,.9077047E+00,.5102050E+00,& + & .2900951E+00,.8450562E+00,.1010731E+01,.1025679E+01,.5747009E+00,& + & .1428838E+00,.4799142E+00,.5760617E+00,.5872644E+00,.3307220E+00,& + & .1688185E+00,.5520986E+00,.6658687E+00,.6800494E+00,.3810810E+00,& + & .1993677E+00,.6340252E+00,.7660136E+00,.7826397E+00,.4366263E+00,& + & .2351442E+00,.7269414E+00,.8765519E+00,.8938786E+00,.4971268E+00,& + & .2767765E+00,.8312265E+00,.9973781E+00,.1013193E+01,.5625664E+00,& + & .1295255E+00,.4542258E+00,.5478587E+00,.5595381E+00,.3107326E+00,& + & .1542935E+00,.5261193E+00,.6373454E+00,.6520435E+00,.3608896E+00,& + & .1835749E+00,.6075514E+00,.7372141E+00,.7544331E+00,.4164074E+00,& + & .2182062E+00,.6998975E+00,.8474540E+00,.8656087E+00,.4768929E+00,& + & .2589005E+00,.8036978E+00,.9679606E+00,.9848442E+00,.5424313E+00,& + & .1175401E+00,.4307071E+00,.5219632E+00,.5338978E+00,.2926245E+00,& + & .1412629E+00,.5022212E+00,.6108981E+00,.6259401E+00,.3424732E+00,& + & .1693284E+00,.5830370E+00,.7102630E+00,.7278824E+00,.3978669E+00,& + & .2028442E+00,.6746033E+00,.8199129E+00,.8387792E+00,.4582588E+00,& + & .2426035E+00,.7776740E+00,.9399588E+00,.9577662E+00,.5237233E+00,& + & .1069057E+00,.4095696E+00,.4986606E+00,.5107070E+00,.2765051E+00,& + & .1297183E+00,.4806709E+00,.5869321E+00,.6022485E+00,.3260232E+00,& + & .1566724E+00,.5608628E+00,.6856622E+00,.7036230E+00,.3812308E+00,& + & .1891795E+00,.6516100E+00,.7946672E+00,.8140707E+00,.4414800E+00,& + & .2280943E+00,.7538152E+00,.9140427E+00,.9326912E+00,.5067756E+00,& + & .9538147E-01,.3836728E+00,.4692157E+00,.4807161E+00,.2573361E+00,& + & .1169920E+00,.4534590E+00,.5555647E+00,.5707684E+00,.3058432E+00,& + & .1425205E+00,.5320323E+00,.6525202E+00,.6704208E+00,.3602199E+00,& + & .1734620E+00,.6207733E+00,.7596824E+00,.7794089E+00,.4197447E+00,& + & .2108876E+00,.7208589E+00,.8772631E+00,.8967522E+00,.4842904E+00/ + + data absb(701:875, 8) / & + & .8483947E-01,.3588563E+00,.4408601E+00,.4516281E+00,.2391711E+00,& + & .1052687E+00,.4273398E+00,.5251982E+00,.5400986E+00,.2865821E+00,& + & .1294958E+00,.5040617E+00,.6199729E+00,.6376780E+00,.3398708E+00,& + & .1588835E+00,.5906162E+00,.7250743E+00,.7449273E+00,.3985409E+00,& + & .1946890E+00,.6883248E+00,.8405775E+00,.8607468E+00,.4621965E+00,& + & .7543551E-01,.3358861E+00,.4145122E+00,.4243832E+00,.2224114E+00,& + & .9465525E-01,.4026844E+00,.4964574E+00,.5108780E+00,.2686287E+00,& + & .1177290E+00,.4776992E+00,.5890965E+00,.6064776E+00,.3207812E+00,& + & .1456605E+00,.5620963E+00,.6920814E+00,.7118635E+00,.3784909E+00,& + & .1798767E+00,.6573786E+00,.8054007E+00,.8260421E+00,.4411895E+00,& + & .6608792E-01,.3109105E+00,.3855264E+00,.3941304E+00,.2044580E+00,& + & .8394591E-01,.3756301E+00,.4645764E+00,.4780384E+00,.2491451E+00,& + & .1057032E+00,.4484352E+00,.5543433E+00,.5711787E+00,.2997657E+00,& + & .1320096E+00,.5302167E+00,.6546096E+00,.6740082E+00,.3560965E+00,& + & .1642833E+00,.6224082E+00,.7650984E+00,.7859469E+00,.4175347E+00,& + & .5738271E-01,.2860275E+00,.3565059E+00,.3636546E+00,.1867469E+00,& + & .7381553E-01,.3484044E+00,.4324451E+00,.4446271E+00,.2297128E+00,& + & .9417454E-01,.4188318E+00,.5189475E+00,.5351023E+00,.2785779E+00,& + & .1189809E+00,.4980563E+00,.6163102E+00,.6351253E+00,.3333660E+00,& + & .1491626E+00,.5867414E+00,.7235000E+00,.7442712E+00,.3933218E+00,& + & .4966189E-01,.2627287E+00,.3290966E+00,.3348944E+00,.1702478E+00,& + & .6472660E-01,.3227122E+00,.4021344E+00,.4129120E+00,.2114833E+00,& + & .8369235E-01,.3907371E+00,.4852534E+00,.5005355E+00,.2585650E+00,& + & .1070502E+00,.4673220E+00,.5794833E+00,.5976216E+00,.3116401E+00,& + & .1353378E+00,.5528051E+00,.6835756E+00,.7040363E+00,.3701096E+00,& + & .4256723E-01,.2397851E+00,.3016717E+00,.3062819E+00,.1540481E+00,& + & .5622816E-01,.2970953E+00,.3718496E+00,.3810025E+00,.1934507E+00,& + & .7377185E-01,.3626587E+00,.4515842E+00,.4655582E+00,.2385992E+00,& + & .9559465E-01,.4363178E+00,.5420972E+00,.5594484E+00,.2897050E+00,& + & .1220368E+00,.5185878E+00,.6428277E+00,.6627182E+00,.3464809E+00,& + & .3589415E-01,.2161673E+00,.2729648E+00,.2765338E+00,.1375028E+00,& + & .4805408E-01,.2703938E+00,.3401678E+00,.3474504E+00,.1747652E+00,& + & .6397943E-01,.3329344E+00,.4160369E+00,.4283381E+00,.2177681E+00,& + & .8411883E-01,.4035911E+00,.5024152E+00,.5187692E+00,.2666244E+00,& + & .1087145E+00,.4824389E+00,.5992777E+00,.6183786E+00,.3213119E+00/ + + data absb(876:1050, 8) / & + & .3011941E-01,.1941366E+00,.2458479E+00,.2487746E+00,.1221988E+00,& + & .4084506E-01,.2453806E+00,.3101120E+00,.3157807E+00,.1572649E+00,& + & .5518255E-01,.3048452E+00,.3825091E+00,.3929551E+00,.1981390E+00,& + & .7368328E-01,.3724217E+00,.4646897E+00,.4797945E+00,.2447415E+00,& + & .9652937E-01,.4480322E+00,.5576115E+00,.5757517E+00,.2972212E+00,& + & .2515607E-01,.1736587E+00,.2203553E+00,.2229593E+00,.1080693E+00,& + & .3453399E-01,.2219693E+00,.2815682E+00,.2859887E+00,.1409424E+00,& + & .4732652E-01,.2782830E+00,.3508111E+00,.3593155E+00,.1796231E+00,& + & .6419246E-01,.3427924E+00,.4290016E+00,.4424221E+00,.2240016E+00,& + & .8533710E-01,.4152474E+00,.5177134E+00,.5349045E+00,.2742416E+00,& + & .2108838E-01,.1557171E+00,.1978594E+00,.2004336E+00,.9577831E-01,& + & .2927578E-01,.2012690E+00,.2560716E+00,.2596510E+00,.1265930E+00,& + & .4069811E-01,.2546968E+00,.3225058E+00,.3293032E+00,.1632049E+00,& + & .5604639E-01,.3162711E+00,.3971951E+00,.4089321E+00,.2055380E+00,& + & .7561968E-01,.3858696E+00,.4819614E+00,.4980595E+00,.2536384E+00,& + & .1767518E-01,.1394513E+00,.1774120E+00,.1800232E+00,.8475686E-01,& + & .2479537E-01,.1824043E+00,.2325611E+00,.2356543E+00,.1136169E+00,& + & .3495024E-01,.2330902E+00,.2962474E+00,.3017090E+00,.1481769E+00,& + & .4886078E-01,.2917985E+00,.3678777E+00,.3778687E+00,.1885266E+00,& + & .6700377E-01,.3587323E+00,.4490277E+00,.4637480E+00,.2345858E+00,& + & .1476895E-01,.1243742E+00,.1583798E+00,.1609596E+00,.7459372E-01,& + & .2091694E-01,.1647602E+00,.2103847E+00,.2132485E+00,.1015375E+00,& + & .2988238E-01,.2127462E+00,.2712282E+00,.2756073E+00,.1340822E+00,& + & .4238686E-01,.2685463E+00,.3400097E+00,.3482087E+00,.1724055E+00,& + & .5904346E-01,.3326286E+00,.4175653E+00,.4306952E+00,.2164369E+00,& + & .1230374E-01,.1104196E+00,.1406329E+00,.1430549E+00,.6528664E-01,& + & .1757050E-01,.1482205E+00,.1894519E+00,.1922843E+00,.9031455E-01,& + & .2540539E-01,.1934889E+00,.2472646E+00,.2509359E+00,.1208463E+00,& + & .3658763E-01,.2464677E+00,.3133038E+00,.3198840E+00,.1571069E+00,& + & .5175125E-01,.3076675E+00,.3875310E+00,.3989625E+00,.1991350E+00,& + & .1033543E-01,.9851647E-01,.1254426E+00,.1276686E+00,.5744944E-01,& + & .1487034E-01,.1339448E+00,.1713721E+00,.1742024E+00,.8071988E-01,& + & .2174783E-01,.1768075E+00,.2263355E+00,.2295753E+00,.1094349E+00,& + & .3178517E-01,.2272599E+00,.2898005E+00,.2951977E+00,.1438116E+00,& + & .4561407E-01,.2857740E+00,.3612374E+00,.3710210E+00,.1839585E+00/ + + data absb(1051:1175, 8) / & + & .8709412E-02,.8794504E-01,.1119210E+00,.1139728E+00,.5066255E-01,& + & .1262413E-01,.1212030E+00,.1551537E+00,.1579143E+00,.7214590E-01,& + & .1865119E-01,.1616922E+00,.2072178E+00,.2102675E+00,.9913095E-01,& + & .2764278E-01,.2097406E+00,.2681310E+00,.2726069E+00,.1317209E+00,& + & .4023984E-01,.2656768E+00,.3370690E+00,.3452748E+00,.1700699E+00,& + & .7309742E-02,.7805313E-01,.9935397E-01,.1011896E+00,.4454450E-01,& + & .1068078E-01,.1092344E+00,.1398484E+00,.1424507E+00,.6420420E-01,& + & .1594110E-01,.1474371E+00,.1891070E+00,.1921023E+00,.8951479E-01,& + & .2393561E-01,.1930891E+00,.2473383E+00,.2511858E+00,.1203039E+00,& + & .3536639E-01,.2465547E+00,.3138627E+00,.3206321E+00,.1568422E+00,& + & .6111505E-02,.6882934E-01,.8775334E-01,.8932843E-01,.3912454E-01,& + & .9015756E-02,.9808206E-01,.1255190E+00,.1279049E+00,.5696209E-01,& + & .1357531E-01,.1339695E+00,.1719655E+00,.1749408E+00,.8050805E-01,& + & .2064520E-01,.1772958E+00,.2274651E+00,.2308615E+00,.1095380E+00,& + & .3095469E-01,.2282972E+00,.2914883E+00,.2970959E+00,.1442483E+00,& + & .5121725E-02,.6067687E-01,.7763361E-01,.7890932E-01,.3444819E-01,& + & .7639216E-02,.8816021E-01,.1127621E+00,.1149702E+00,.5070163E-01,& + & .1160557E-01,.1219458E+00,.1566131E+00,.1595297E+00,.7248142E-01,& + & .1786695E-01,.1630817E+00,.2094426E+00,.2126006E+00,.9988204E-01,& + & .2716600E-01,.2117945E+00,.2710344E+00,.2757215E+00,.1328837E+00,& + & .4599319E-02,.5738031E-01,.7361124E-01,.7479831E-01,.3257284E-01,& + & .6965718E-02,.8418710E-01,.1077301E+00,.1098721E+00,.4821784E-01,& + & .1072080E-01,.1171779E+00,.1505705E+00,.1534484E+00,.6933089E-01,& + & .1668801E-01,.1574612E+00,.2023452E+00,.2054613E+00,.9606507E-01,& + & .2561291E-01,.2052733E+00,.2629716E+00,.2673724E+00,.1283901E+00/ + + data absb( 1:175, 9) / & + & .1351800E+02,.1942600E+02,.2136800E+02,.2060700E+02,.1596700E+02,& + & .1324900E+02,.1927800E+02,.2134500E+02,.2072500E+02,.1621800E+02,& + & .1299100E+02,.1910600E+02,.2134400E+02,.2083800E+02,.1649300E+02,& + & .1278300E+02,.1895300E+02,.2133700E+02,.2095900E+02,.1676900E+02,& + & .1273500E+02,.1882000E+02,.2132800E+02,.2110400E+02,.1698200E+02,& + & .1150400E+02,.1753400E+02,.1945700E+02,.1913100E+02,.1462500E+02,& + & .1128100E+02,.1739600E+02,.1949100E+02,.1927100E+02,.1493900E+02,& + & .1111200E+02,.1729000E+02,.1952700E+02,.1941500E+02,.1525500E+02,& + & .1111500E+02,.1721300E+02,.1956000E+02,.1958000E+02,.1550400E+02,& + & .1134200E+02,.1713900E+02,.1961500E+02,.1975900E+02,.1570600E+02,& + & .9817000E+01,.1559900E+02,.1762700E+02,.1766600E+02,.1335400E+02,& + & .9674700E+01,.1553300E+02,.1769500E+02,.1784200E+02,.1368700E+02,& + & .9698400E+01,.1550200E+02,.1775500E+02,.1803600E+02,.1400400E+02,& + & .9952200E+01,.1548000E+02,.1782900E+02,.1823500E+02,.1426300E+02,& + & .1034400E+02,.1552500E+02,.1792900E+02,.1841800E+02,.1447500E+02,& + & .8433200E+01,.1380600E+02,.1592600E+02,.1621500E+02,.1222400E+02,& + & .8458300E+01,.1380500E+02,.1602100E+02,.1643700E+02,.1255600E+02,& + & .8706600E+01,.1382300E+02,.1610800E+02,.1666000E+02,.1283400E+02,& + & .9082700E+01,.1392400E+02,.1622600E+02,.1688300E+02,.1307800E+02,& + & .9526300E+01,.1415600E+02,.1638200E+02,.1707900E+02,.1333400E+02,& + & .7306800E+01,.1225200E+02,.1434100E+02,.1481000E+02,.1112900E+02,& + & .7529500E+01,.1229100E+02,.1446300E+02,.1505200E+02,.1143900E+02,& + & .7885300E+01,.1240500E+02,.1460600E+02,.1530900E+02,.1172900E+02,& + & .8304000E+01,.1264300E+02,.1477600E+02,.1554800E+02,.1200600E+02,& + & .8712300E+01,.1303900E+02,.1498200E+02,.1576200E+02,.1228600E+02,& + & .6428700E+01,.1093300E+02,.1287900E+02,.1345100E+02,.1005300E+02,& + & .6744600E+01,.1103900E+02,.1304100E+02,.1374000E+02,.1037700E+02,& + & .7127100E+01,.1126600E+02,.1322200E+02,.1401800E+02,.1069900E+02,& + & .7506700E+01,.1165000E+02,.1345500E+02,.1426300E+02,.1101100E+02,& + & .7879700E+01,.1214400E+02,.1376600E+02,.1451700E+02,.1132300E+02,& + & .5716500E+01,.9819800E+01,.1156300E+02,.1221000E+02,.9028700E+01,& + & .6050400E+01,.1003000E+02,.1175900E+02,.1251100E+02,.9377100E+01,& + & .6387200E+01,.1039000E+02,.1200400E+02,.1278700E+02,.9738200E+01,& + & .6726200E+01,.1085800E+02,.1232500E+02,.1307100E+02,.1010000E+02,& + & .7063000E+01,.1139600E+02,.1272000E+02,.1337100E+02,.1043300E+02/ + + data absb(176:350, 9) / & + & .5107700E+01,.8868000E+01,.1041500E+02,.1105300E+02,.8096300E+01,& + & .5401700E+01,.9210700E+01,.1066200E+02,.1136100E+02,.8475800E+01,& + & .5701500E+01,.9669800E+01,.1098200E+02,.1166800E+02,.8848100E+01,& + & .6004100E+01,.1019600E+02,.1138400E+02,.1200000E+02,.9237600E+01,& + & .6310600E+01,.1073200E+02,.1188400E+02,.1234900E+02,.9625500E+01,& + & .4541400E+01,.8084100E+01,.9433300E+01,.1000100E+02,.7298700E+01,& + & .4806000E+01,.8516900E+01,.9739900E+01,.1032400E+02,.7679900E+01,& + & .5075400E+01,.9031100E+01,.1013400E+02,.1067300E+02,.8069200E+01,& + & .5348900E+01,.9566000E+01,.1062600E+02,.1104600E+02,.8467100E+01,& + & .5622600E+01,.1010000E+02,.1118800E+02,.1146700E+02,.8887800E+01,& + & .4051200E+01,.7453700E+01,.8611300E+01,.9076000E+01,.6640600E+01,& + & .4286100E+01,.7945500E+01,.8998800E+01,.9432600E+01,.7029800E+01,& + & .4528400E+01,.8472300E+01,.9480600E+01,.9828200E+01,.7436500E+01,& + & .4776500E+01,.9002200E+01,.1003600E+02,.1026700E+02,.7853000E+01,& + & .5027300E+01,.9537500E+01,.1064400E+02,.1076200E+02,.8292500E+01,& + & .3627200E+01,.6934500E+01,.7929200E+01,.8282100E+01,.6086200E+01,& + & .3832400E+01,.7441200E+01,.8405800E+01,.8677900E+01,.6481400E+01,& + & .4049600E+01,.7955600E+01,.8949700E+01,.9127700E+01,.6903100E+01,& + & .4273600E+01,.8488100E+01,.9551200E+01,.9635300E+01,.7342300E+01,& + & .4500800E+01,.9023100E+01,.1019900E+02,.1019600E+02,.7810700E+01,& + & .3261700E+01,.6492700E+01,.7381400E+01,.7620400E+01,.5635100E+01,& + & .3445500E+01,.6986400E+01,.7914600E+01,.8066800E+01,.6048200E+01,& + & .3637500E+01,.7498200E+01,.8512400E+01,.8568800E+01,.6479300E+01,& + & .3836100E+01,.8025300E+01,.9153000E+01,.9138400E+01,.6948800E+01,& + & .4043400E+01,.8577000E+01,.9824900E+01,.9770100E+01,.7439200E+01,& + & .2950400E+01,.6099600E+01,.6937800E+01,.7093300E+01,.5269600E+01,& + & .3113400E+01,.6585900E+01,.7519300E+01,.7587400E+01,.5690800E+01,& + & .3285000E+01,.7099100E+01,.8158300E+01,.8145500E+01,.6150400E+01,& + & .3463900E+01,.7635700E+01,.8828900E+01,.8776600E+01,.6639100E+01,& + & .3657500E+01,.8203100E+01,.9533500E+01,.9472800E+01,.7118100E+01,& + & .2678500E+01,.5759200E+01,.6594400E+01,.6679300E+01,.4965900E+01,& + & .2830300E+01,.6251200E+01,.7218000E+01,.7229200E+01,.5415800E+01,& + & .2984500E+01,.6770000E+01,.7885300E+01,.7851700E+01,.5892900E+01,& + & .3149800E+01,.7321800E+01,.8589200E+01,.8540500E+01,.6377900E+01,& + & .3336500E+01,.7909500E+01,.9326000E+01,.9287600E+01,.6859300E+01/ + + data absb(351:525, 9) / & + & .2438100E+01,.5471900E+01,.6329600E+01,.6369900E+01,.4737800E+01,& + & .2583300E+01,.5970600E+01,.6983900E+01,.6980900E+01,.5202400E+01,& + & .2727600E+01,.6503200E+01,.7682300E+01,.7662300E+01,.5684900E+01,& + & .2884300E+01,.7076800E+01,.8422300E+01,.8397300E+01,.6161300E+01,& + & .3077600E+01,.7683700E+01,.9192900E+01,.9187100E+01,.6669700E+01,& + & .2223800E+01,.5236600E+01,.6133500E+01,.6157400E+01,.4570500E+01,& + & .2364800E+01,.5745100E+01,.6815100E+01,.6826600E+01,.5034700E+01,& + & .2506700E+01,.6298000E+01,.7546000E+01,.7554800E+01,.5506400E+01,& + & .2668000E+01,.6893000E+01,.8322300E+01,.8330800E+01,.6010300E+01,& + & .2876300E+01,.7523400E+01,.9126900E+01,.9154700E+01,.6544300E+01,& + & .2034300E+01,.5054000E+01,.6002100E+01,.6036000E+01,.4430600E+01,& + & .2173200E+01,.5578500E+01,.6713400E+01,.6754400E+01,.4892400E+01,& + & .2321700E+01,.6155400E+01,.7482800E+01,.7521700E+01,.5389900E+01,& + & .2499100E+01,.6772700E+01,.8294300E+01,.8334100E+01,.5921100E+01,& + & .2729800E+01,.7430900E+01,.9129400E+01,.9187700E+01,.6477600E+01,& + & .1867800E+01,.4920300E+01,.5929100E+01,.5987500E+01,.4320400E+01,& + & .2010200E+01,.5466700E+01,.6674700E+01,.6743000E+01,.4802600E+01,& + & .2171900E+01,.6068200E+01,.7482700E+01,.7547700E+01,.5328100E+01,& + & .2372000E+01,.6712600E+01,.8325200E+01,.8391000E+01,.5882600E+01,& + & .2626400E+01,.7397700E+01,.9187000E+01,.9272300E+01,.6459800E+01,& + & .1724400E+01,.4837000E+01,.5915600E+01,.6000100E+01,.4255500E+01,& + & .1875500E+01,.5410700E+01,.6699900E+01,.6790400E+01,.4764400E+01,& + & .2057300E+01,.6036300E+01,.7540200E+01,.7627400E+01,.5315500E+01,& + & .2282900E+01,.6709400E+01,.8407900E+01,.8496200E+01,.5890100E+01,& + & .2559000E+01,.7419500E+01,.9290900E+01,.9399400E+01,.6487100E+01,& + & .1606900E+01,.4803000E+01,.5957900E+01,.6063900E+01,.4235600E+01,& + & .1770500E+01,.5403700E+01,.6778800E+01,.6887400E+01,.4771200E+01,& + & .1974200E+01,.6057400E+01,.7644800E+01,.7749100E+01,.5343400E+01,& + & .2224700E+01,.6756000E+01,.8531000E+01,.8638500E+01,.5938100E+01,& + & .2523800E+01,.7488000E+01,.9429200E+01,.9557000E+01,.6549700E+01,& + & .1512800E+01,.4814000E+01,.6050100E+01,.6171400E+01,.4255000E+01,& + & .1694600E+01,.5441700E+01,.6900000E+01,.7021200E+01,.4815500E+01,& + & .1920600E+01,.6121300E+01,.7783900E+01,.7902000E+01,.5406900E+01,& + & .2194600E+01,.6842200E+01,.8682700E+01,.8807500E+01,.6016900E+01,& + & .2517300E+01,.7591300E+01,.9592400E+01,.9737300E+01,.6639800E+01/ + + data absb(526:700, 9) / & + & .1435600E+01,.4841800E+01,.6149500E+01,.6282800E+01,.4289600E+01,& + & .1635700E+01,.5493500E+01,.7018400E+01,.7151600E+01,.4869100E+01,& + & .1883800E+01,.6195700E+01,.7915100E+01,.8045700E+01,.5474200E+01,& + & .2178800E+01,.6932500E+01,.8825600E+01,.8964300E+01,.6095600E+01,& + & .2523800E+01,.7693000E+01,.9743900E+01,.9902100E+01,.6726400E+01,& + & .1362000E+01,.4840000E+01,.6191100E+01,.6334100E+01,.4295000E+01,& + & .1576500E+01,.5507700E+01,.7071700E+01,.7214900E+01,.4887200E+01,& + & .1841600E+01,.6223800E+01,.7977800E+01,.8117300E+01,.5501400E+01,& + & .2152800E+01,.6969400E+01,.8895100E+01,.9043000E+01,.6130400E+01,& + & .2513500E+01,.7737000E+01,.9819100E+01,.9986500E+01,.6766200E+01,& + & .1283600E+01,.4789200E+01,.6154900E+01,.6305000E+01,.4254000E+01,& + & .1507000E+01,.5464900E+01,.7041600E+01,.7192300E+01,.4853600E+01,& + & .1783000E+01,.6187200E+01,.7953100E+01,.8099400E+01,.5473400E+01,& + & .2105500E+01,.6936900E+01,.8874500E+01,.9028800E+01,.6106600E+01,& + & .2475400E+01,.7709000E+01,.9802300E+01,.9975900E+01,.6745900E+01,& + & .1187800E+01,.4654100E+01,.5997500E+01,.6153100E+01,.4135700E+01,& + & .1411400E+01,.5327900E+01,.6883600E+01,.7040700E+01,.4736600E+01,& + & .1690700E+01,.6048800E+01,.7796100E+01,.7949200E+01,.5358700E+01,& + & .2017100E+01,.6798700E+01,.8721400E+01,.8878200E+01,.5993100E+01,& + & .2387900E+01,.7572100E+01,.9650500E+01,.9826300E+01,.6634600E+01,& + & .1101900E+01,.4524100E+01,.5841100E+01,.6001500E+01,.4020600E+01,& + & .1324000E+01,.5193800E+01,.6724800E+01,.6888100E+01,.4621500E+01,& + & .1605000E+01,.5912700E+01,.7637700E+01,.7796900E+01,.5244400E+01,& + & .1934400E+01,.6661400E+01,.8565600E+01,.8724100E+01,.5879700E+01,& + & .2305300E+01,.7435200E+01,.9496100E+01,.9673000E+01,.6523200E+01,& + & .1026100E+01,.4403500E+01,.5692500E+01,.5857100E+01,.3913000E+01,& + & .1245800E+01,.5069400E+01,.6573500E+01,.6741100E+01,.4513000E+01,& + & .1528100E+01,.5784400E+01,.7485300E+01,.7649700E+01,.5135300E+01,& + & .1859000E+01,.6531000E+01,.8413900E+01,.8575200E+01,.5771100E+01,& + & .2229600E+01,.7303100E+01,.9346100E+01,.9523300E+01,.6415500E+01,& + & .9402000E+00,.4225200E+01,.5461800E+01,.5630500E+01,.3751400E+01,& + & .1151000E+01,.4880800E+01,.6335900E+01,.6505100E+01,.4346400E+01,& + & .1426700E+01,.5586500E+01,.7242900E+01,.7411600E+01,.4965900E+01,& + & .1753400E+01,.6328400E+01,.8170600E+01,.8334600E+01,.5600400E+01,& + & .2119600E+01,.7095400E+01,.9103800E+01,.9279000E+01,.6244300E+01/ + + data absb(701:875, 9) / & + & .8612900E+00,.4045700E+01,.5226400E+01,.5397600E+01,.3587900E+01,& + & .1063300E+01,.4691500E+01,.6092400E+01,.6263500E+01,.4176800E+01,& + & .1328300E+01,.5384500E+01,.6992600E+01,.7164900E+01,.4792100E+01,& + & .1648500E+01,.6120100E+01,.7917500E+01,.8084400E+01,.5424000E+01,& + & .2009300E+01,.6881200E+01,.8852200E+01,.9024900E+01,.6066800E+01,& + & .7912300E+00,.3873500E+01,.4996000E+01,.5169900E+01,.3428700E+01,& + & .9829500E+00,.4507200E+01,.5853300E+01,.6025400E+01,.4010900E+01,& + & .1236400E+01,.5187600E+01,.6745900E+01,.6921400E+01,.4621200E+01,& + & .1548400E+01,.5915000E+01,.7666500E+01,.7837300E+01,.5250300E+01,& + & .1902600E+01,.6671600E+01,.8601800E+01,.8772800E+01,.5891500E+01,& + & .7198400E+00,.3672900E+01,.4723500E+01,.4897500E+01,.3239700E+01,& + & .8980800E+00,.4291600E+01,.5569700E+01,.5744300E+01,.3815300E+01,& + & .1136000E+01,.4957400E+01,.6451900E+01,.6628900E+01,.4418400E+01,& + & .1434500E+01,.5672800E+01,.7366000E+01,.7541000E+01,.5043700E+01,& + & .1779300E+01,.6422800E+01,.8299900E+01,.8470500E+01,.5682300E+01,& + & .6528500E+00,.3466700E+01,.4437200E+01,.4608200E+01,.3039900E+01,& + & .8165700E+00,.4067400E+01,.5270100E+01,.5446600E+01,.3609400E+01,& + & .1037000E+01,.4717100E+01,.6140500E+01,.6317500E+01,.4203800E+01,& + & .1319400E+01,.5418400E+01,.7047300E+01,.7224800E+01,.4823700E+01,& + & .1651400E+01,.6158400E+01,.7976000E+01,.8147700E+01,.5458100E+01,& + & .5932400E+00,.3268700E+01,.4161000E+01,.4327000E+01,.2843700E+01,& + & .7429200E+00,.3850200E+01,.4975400E+01,.5152500E+01,.3408100E+01,& + & .9460600E+00,.4483800E+01,.5834700E+01,.6011200E+01,.3993200E+01,& + & .1210300E+01,.5169100E+01,.6731200E+01,.6911300E+01,.4606300E+01,& + & .1528300E+01,.5897000E+01,.7652900E+01,.7828300E+01,.5236500E+01,& + & .5366500E+00,.3066500E+01,.3878800E+01,.4034400E+01,.2639600E+01,& + & .6732600E+00,.3627500E+01,.4668500E+01,.4844500E+01,.3197000E+01,& + & .8596400E+00,.4245000E+01,.5516100E+01,.5694000E+01,.3774200E+01,& + & .1102600E+01,.4911200E+01,.6399200E+01,.6579500E+01,.4378500E+01,& + & .1403000E+01,.5624700E+01,.7312800E+01,.7491800E+01,.5003700E+01,& + & .4796500E+00,.2851200E+01,.3577300E+01,.3719000E+01,.2417900E+01,& + & .6049900E+00,.3389500E+01,.4335300E+01,.4507000E+01,.2965300E+01,& + & .7721100E+00,.3985700E+01,.5165600E+01,.5343900E+01,.3534600E+01,& + & .9928000E+00,.4632000E+01,.6034600E+01,.6213800E+01,.4127800E+01,& + & .1271100E+01,.5327200E+01,.6937700E+01,.7118900E+01,.4746400E+01/ + + data absb(876:1050, 9) / & + & .4265100E+00,.2644500E+01,.3289400E+01,.3414800E+01,.2203300E+01,& + & .5438800E+00,.3161100E+01,.4016100E+01,.4179100E+01,.2737300E+01,& + & .6936800E+00,.3734700E+01,.4820600E+01,.4998900E+01,.3299700E+01,& + & .8927900E+00,.4362000E+01,.5676700E+01,.5855400E+01,.3882200E+01,& + & .1148400E+01,.5036900E+01,.6566800E+01,.6749500E+01,.4491800E+01,& + & .3771300E+00,.2443900E+01,.3016000E+01,.3120600E+01,.1997600E+01,& + & .4876600E+00,.2943400E+01,.3710400E+01,.3859900E+01,.2514300E+01,& + & .6240700E+00,.3493900E+01,.4484700E+01,.4659600E+01,.3068000E+01,& + & .8029800E+00,.4100600E+01,.5325500E+01,.5504900E+01,.3641300E+01,& + & .1035300E+01,.4755400E+01,.6201000E+01,.6382000E+01,.4240700E+01,& + & .3333400E+00,.2257300E+01,.2773000E+01,.2853700E+01,.1814100E+01,& + & .4382400E+00,.2747700E+01,.3435900E+01,.3571200E+01,.2311200E+01,& + & .5655500E+00,.3276700E+01,.4180700E+01,.4349700E+01,.2854000E+01,& + & .7266200E+00,.3863100E+01,.5000300E+01,.5179800E+01,.3420600E+01,& + & .9381100E+00,.4499800E+01,.5863500E+01,.6043300E+01,.4009200E+01,& + & .2934400E+00,.2079200E+01,.2549300E+01,.2604500E+01,.1644700E+01,& + & .3932000E+00,.2563300E+01,.3181100E+01,.3299600E+01,.2120200E+01,& + & .5133500E+00,.3073900E+01,.3896800E+01,.4055400E+01,.2649300E+01,& + & .6599100E+00,.3639600E+01,.4691000E+01,.4869200E+01,.3209500E+01,& + & .8530500E+00,.4260200E+01,.5542800E+01,.5722700E+01,.3789000E+01,& + & .2563400E+00,.1906500E+01,.2337300E+01,.2367500E+01,.1484900E+01,& + & .3508500E+00,.2383200E+01,.2938000E+01,.3036300E+01,.1937900E+01,& + & .4646300E+00,.2880600E+01,.3624500E+01,.3770500E+01,.2449900E+01,& + & .6001400E+00,.3424700E+01,.4390100E+01,.4564400E+01,.3001300E+01,& + & .7750200E+00,.4026800E+01,.5226400E+01,.5406400E+01,.3572900E+01,& + & .2219800E+00,.1738200E+01,.2135500E+01,.2144300E+01,.1332100E+01,& + & .3108800E+00,.2203700E+01,.2707000E+01,.2780900E+01,.1763100E+01,& + & .4186800E+00,.2693700E+01,.3362800E+01,.3493700E+01,.2255100E+01,& + & .5459000E+00,.3217200E+01,.4099400E+01,.4266900E+01,.2795000E+01,& + & .7038200E+00,.3799300E+01,.4913400E+01,.5093400E+01,.3360900E+01,& + & .1927900E+00,.1588400E+01,.1957600E+01,.1951600E+01,.1199100E+01,& + & .2761400E+00,.2042300E+01,.2505300E+01,.2555900E+01,.1610600E+01,& + & .3790000E+00,.2526400E+01,.3132300E+01,.3247300E+01,.2082500E+01,& + & .4995400E+00,.3034400E+01,.3842500E+01,.3999400E+01,.2609000E+01,& + & .6448300E+00,.3596700E+01,.4632000E+01,.4810400E+01,.3168300E+01/ + + data absb(1051:1175, 9) / & + & .1675200E+00,.1450600E+01,.1792400E+01,.1778000E+01,.1076600E+01,& + & .2454600E+00,.1892400E+01,.2321500E+01,.2350200E+01,.1471800E+01,& + & .3428200E+00,.2368600E+01,.2920300E+01,.3017100E+01,.1923800E+01,& + & .4575100E+00,.2865700E+01,.3604800E+01,.3750400E+01,.2434700E+01,& + & .5934500E+00,.3409100E+01,.4369200E+01,.4543600E+01,.2986000E+01,& + & .1444200E+00,.1319100E+01,.1630700E+01,.1615800E+01,.9596600E+00,& + & .2162900E+00,.1745600E+01,.2145400E+01,.2155300E+01,.1338400E+01,& + & .3083800E+00,.2211700E+01,.2718400E+01,.2793900E+01,.1771000E+01,& + & .4178000E+00,.2702400E+01,.3376100E+01,.3508300E+01,.2264700E+01,& + & .5463300E+00,.3227700E+01,.4115300E+01,.4283500E+01,.2805700E+01,& + & .1236900E+00,.1194200E+01,.1475100E+01,.1466000E+01,.8479400E+00,& + & .1894300E+00,.1602500E+01,.1975200E+01,.1970600E+01,.1210400E+01,& + & .2758000E+00,.2057700E+01,.2525300E+01,.2578500E+01,.1624900E+01,& + & .3801500E+00,.2542500E+01,.3155400E+01,.3272400E+01,.2099500E+01,& + & .5022000E+00,.3052800E+01,.3869400E+01,.4027500E+01,.2627900E+01,& + & .1061900E+00,.1081500E+01,.1333800E+01,.1334000E+01,.7492400E+00,& + & .1658600E+00,.1471300E+01,.1818300E+01,.1804700E+01,.1093300E+01,& + & .2466800E+00,.1915000E+01,.2349800E+01,.2382400E+01,.1493100E+01,& + & .3461300E+00,.2393600E+01,.2954200E+01,.3054500E+01,.1948900E+01,& + & .4625100E+00,.2892800E+01,.3643900E+01,.3791400E+01,.2462800E+01,& + & .9878100E-01,.1037400E+01,.1279000E+01,.1283400E+01,.7109100E+00,& + & .1564300E+00,.1419900E+01,.1756000E+01,.1740600E+01,.1047500E+01,& + & .2351200E+00,.1858500E+01,.2281500E+01,.2306100E+01,.1440800E+01,& + & .3325000E+00,.2333800E+01,.2875500E+01,.2968600E+01,.1889800E+01,& + & .4469700E+00,.2829800E+01,.3555500E+01,.3698400E+01,.2397500E+01/ + + data absb( 1:175,10) / & + & .5148311E+02,.5413939E+02,.5702358E+02,.5255781E+02,.4767175E+02,& + & .5089809E+02,.5366563E+02,.5690094E+02,.5278229E+02,.4816697E+02,& + & .5028687E+02,.5319767E+02,.5674627E+02,.5298787E+02,.4858275E+02,& + & .4966788E+02,.5270972E+02,.5651558E+02,.5315507E+02,.4895540E+02,& + & .4904266E+02,.5220812E+02,.5626701E+02,.5327637E+02,.4934862E+02,& + & .4695357E+02,.5244112E+02,.5623255E+02,.5228165E+02,.4528190E+02,& + & .4636862E+02,.5203478E+02,.5620209E+02,.5261290E+02,.4583339E+02,& + & .4578848E+02,.5161094E+02,.5610019E+02,.5291867E+02,.4633999E+02,& + & .4522091E+02,.5118237E+02,.5596404E+02,.5316078E+02,.4686589E+02,& + & .4464656E+02,.5075226E+02,.5579719E+02,.5336823E+02,.4742733E+02,& + & .4214601E+02,.5023928E+02,.5465620E+02,.5137721E+02,.4265810E+02,& + & .4159514E+02,.4989728E+02,.5473059E+02,.5180612E+02,.4330876E+02,& + & .4107738E+02,.4954386E+02,.5475515E+02,.5218532E+02,.4396773E+02,& + & .4057407E+02,.4919951E+02,.5475077E+02,.5253512E+02,.4466305E+02,& + & .4017621E+02,.4885046E+02,.5474194E+02,.5287718E+02,.4535369E+02,& + & .3729887E+02,.4762187E+02,.5248346E+02,.4992379E+02,.3996857E+02,& + & .3682707E+02,.4735522E+02,.5268439E+02,.5045155E+02,.4074890E+02,& + & .3639654E+02,.4710649E+02,.5286499E+02,.5096814E+02,.4156839E+02,& + & .3608349E+02,.4686360E+02,.5304363E+02,.5147530E+02,.4241003E+02,& + & .3594030E+02,.4664103E+02,.5320927E+02,.5198934E+02,.4322855E+02,& + & .3267085E+02,.4471454E+02,.4990144E+02,.4806389E+02,.3737273E+02,& + & .3229921E+02,.4458748E+02,.5027045E+02,.4875782E+02,.3829531E+02,& + & .3205109E+02,.4447599E+02,.5065142E+02,.4944055E+02,.3925216E+02,& + & .3198556E+02,.4439449E+02,.5103374E+02,.5013485E+02,.4020794E+02,& + & .3212562E+02,.4431957E+02,.5139858E+02,.5083922E+02,.4116103E+02,& + & .2840862E+02,.4164567E+02,.4712876E+02,.4597745E+02,.3496902E+02,& + & .2819485E+02,.4169424E+02,.4770395E+02,.4685191E+02,.3600935E+02,& + & .2816868E+02,.4176226E+02,.4829256E+02,.4773086E+02,.3708676E+02,& + & .2836998E+02,.4184080E+02,.4888393E+02,.4862950E+02,.3815932E+02,& + & .2876609E+02,.4198837E+02,.4946530E+02,.4954016E+02,.3924359E+02,& + & .2458838E+02,.3854886E+02,.4433510E+02,.4378221E+02,.3278158E+02,& + & .2458406E+02,.3879353E+02,.4511982E+02,.4485465E+02,.3393561E+02,& + & .2481011E+02,.3904687E+02,.4591165E+02,.4596040E+02,.3509830E+02,& + & .2524181E+02,.3936718E+02,.4670940E+02,.4707856E+02,.3628077E+02,& + & .2588043E+02,.3975083E+02,.4751106E+02,.4819091E+02,.3749205E+02/ + + data absb(176:350,10) / & + & .2128943E+02,.3559835E+02,.4162163E+02,.4164333E+02,.3082318E+02,& + & .2150537E+02,.3602723E+02,.4259734E+02,.4292976E+02,.3205684E+02,& + & .2193801E+02,.3650531E+02,.4361086E+02,.4425346E+02,.3332155E+02,& + & .2259310E+02,.3706210E+02,.4463171E+02,.4558654E+02,.3461692E+02,& + & .2342964E+02,.3772964E+02,.4566117E+02,.4688864E+02,.3593171E+02,& + & .1852062E+02,.3287436E+02,.3903572E+02,.3964314E+02,.2907608E+02,& + & .1891782E+02,.3350332E+02,.4024543E+02,.4114241E+02,.3039091E+02,& + & .1954091E+02,.3421519E+02,.4148282E+02,.4268352E+02,.3174986E+02,& + & .2036981E+02,.3502995E+02,.4273744E+02,.4421574E+02,.3314916E+02,& + & .2138764E+02,.3596408E+02,.4400706E+02,.4569955E+02,.3457774E+02,& + & .1624714E+02,.3047658E+02,.3680690E+02,.3795944E+02,.2761997E+02,& + & .1682346E+02,.3133476E+02,.3822752E+02,.3967654E+02,.2904446E+02,& + & .1761414E+02,.3229856E+02,.3969010E+02,.4139802E+02,.3050220E+02,& + & .1860843E+02,.3338503E+02,.4119523E+02,.4312030E+02,.3200324E+02,& + & .1979142E+02,.3455683E+02,.4269211E+02,.4477201E+02,.3355101E+02,& + & .1441593E+02,.2844847E+02,.3488725E+02,.3654168E+02,.2639799E+02,& + & .1513627E+02,.2951628E+02,.3652960E+02,.3844842E+02,.2793035E+02,& + & .1607257E+02,.3073671E+02,.3822881E+02,.4036376E+02,.2949013E+02,& + & .1721158E+02,.3204955E+02,.3993969E+02,.4224228E+02,.3109975E+02,& + & .1853506E+02,.3344658E+02,.4166331E+02,.4405921E+02,.3276077E+02,& + & .1295279E+02,.2677411E+02,.3332381E+02,.3540024E+02,.2541395E+02,& + & .1380491E+02,.2807574E+02,.3519465E+02,.3748808E+02,.2704929E+02,& + & .1487470E+02,.2950308E+02,.3708718E+02,.3957763E+02,.2871542E+02,& + & .1613680E+02,.3102968E+02,.3900635E+02,.4159900E+02,.3042625E+02,& + & .1756668E+02,.3261608E+02,.4093414E+02,.4356179E+02,.3219685E+02,& + & .1181308E+02,.2545547E+02,.3213568E+02,.3454579E+02,.2465802E+02,& + & .1278415E+02,.2697292E+02,.3418991E+02,.3680560E+02,.2639551E+02,& + & .1396046E+02,.2859206E+02,.3627615E+02,.3903520E+02,.2816396E+02,& + & .1530966E+02,.3030034E+02,.3838513E+02,.4119274E+02,.2998441E+02,& + & .1680246E+02,.3204287E+02,.4046635E+02,.4326902E+02,.3183828E+02,& + & .1095745E+02,.2448401E+02,.3130388E+02,.3400597E+02,.2413910E+02,& + & .1202575E+02,.2618548E+02,.3353135E+02,.3640460E+02,.2597275E+02,& + & .1327161E+02,.2798353E+02,.3579506E+02,.3875055E+02,.2784255E+02,& + & .1467686E+02,.2984441E+02,.3805097E+02,.4101420E+02,.2975816E+02,& + & .1623812E+02,.3172488E+02,.4025111E+02,.4318326E+02,.3168296E+02/ + + data absb(351:525,10) / & + & .1031026E+02,.2379955E+02,.3077002E+02,.3371001E+02,.2381408E+02,& + & .1143882E+02,.2566958E+02,.3315826E+02,.3621895E+02,.2574289E+02,& + & .1273674E+02,.2762295E+02,.3556863E+02,.3865824E+02,.2770335E+02,& + & .1420938E+02,.2960954E+02,.3792581E+02,.4100632E+02,.2969115E+02,& + & .1584019E+02,.3161041E+02,.4022388E+02,.4324073E+02,.3167330E+02,& + & .9809660E+01,.2337401E+02,.3050021E+02,.3361805E+02,.2366649E+02,& + & .1099292E+02,.2539109E+02,.3302281E+02,.3621280E+02,.2568000E+02,& + & .1234898E+02,.2746966E+02,.3553468E+02,.3873037E+02,.2771661E+02,& + & .1389015E+02,.2956157E+02,.3797616E+02,.4114283E+02,.2975703E+02,& + & .1559986E+02,.3165438E+02,.4034450E+02,.4341423E+02,.3178583E+02,& + & .9444252E+01,.2318083E+02,.3046927E+02,.3371915E+02,.2368071E+02,& + & .1068902E+02,.2532385E+02,.3309721E+02,.3637816E+02,.2576903E+02,& + & .1210865E+02,.2749920E+02,.3567757E+02,.3895396E+02,.2786288E+02,& + & .1372527E+02,.2967804E+02,.3817975E+02,.4140126E+02,.2994365E+02,& + & .1551148E+02,.3183065E+02,.4058662E+02,.4368854E+02,.3200806E+02,& + & .9197704E+01,.2317475E+02,.3061830E+02,.3396112E+02,.2382472E+02,& + & .1050749E+02,.2541270E+02,.3332073E+02,.3667202E+02,.2597119E+02,& + & .1200173E+02,.2766533E+02,.3594813E+02,.3928170E+02,.2810254E+02,& + & .1369150E+02,.2990848E+02,.3849061E+02,.4174119E+02,.3021392E+02,& + & .1554967E+02,.3210113E+02,.4091548E+02,.4403004E+02,.3230534E+02,& + & .9070152E+01,.2333358E+02,.3092333E+02,.3432849E+02,.2408369E+02,& + & .1044943E+02,.2564057E+02,.3366988E+02,.3707300E+02,.2627089E+02,& + & .1201766E+02,.2795335E+02,.3632847E+02,.3969279E+02,.2842654E+02,& + & .1377594E+02,.3023853E+02,.3888979E+02,.4215285E+02,.3056150E+02,& + & .1570981E+02,.3246011E+02,.4132215E+02,.4443246E+02,.3266580E+02,& + & .9050881E+01,.2361502E+02,.3134148E+02,.3479389E+02,.2443447E+02,& + & .1049856E+02,.2597874E+02,.3411303E+02,.3755332E+02,.2664478E+02,& + & .1213853E+02,.2833372E+02,.3679073E+02,.4016895E+02,.2881882E+02,& + & .1396914E+02,.3064406E+02,.3935900E+02,.4261289E+02,.3096497E+02,& + & .1597202E+02,.3287736E+02,.4178044E+02,.4487584E+02,.3307507E+02,& + & .9121485E+01,.2399340E+02,.3184110E+02,.3533107E+02,.2484905E+02,& + & .1063898E+02,.2639662E+02,.3462510E+02,.3808849E+02,.2707110E+02,& + & .1235080E+02,.2877918E+02,.3730856E+02,.4068584E+02,.2925606E+02,& + & .1425215E+02,.3109959E+02,.3987030E+02,.4310628E+02,.3140551E+02,& + & .1631751E+02,.3333996E+02,.4227596E+02,.4534660E+02,.3351854E+02/ + + data absb(526:700,10) / & + & .9221530E+01,.2435543E+02,.3229891E+02,.3581316E+02,.2522887E+02,& + & .1079853E+02,.2679042E+02,.3509314E+02,.3856585E+02,.2745675E+02,& + & .1257368E+02,.2918513E+02,.3777390E+02,.4114200E+02,.2964790E+02,& + & .1453244E+02,.3151030E+02,.4032236E+02,.4354185E+02,.3180140E+02,& + & .1664739E+02,.3375272E+02,.4271105E+02,.4575694E+02,.3391150E+02,& + & .9234921E+01,.2453098E+02,.3252381E+02,.3605734E+02,.2542131E+02,& + & .1085339E+02,.2698432E+02,.3532561E+02,.3880579E+02,.2765412E+02,& + & .1266775E+02,.2939222E+02,.3801034E+02,.4137794E+02,.2985073E+02,& + & .1466294E+02,.3172547E+02,.4055737E+02,.4377010E+02,.3200723E+02,& + & .1680944E+02,.3397153E+02,.4293979E+02,.4597565E+02,.3411921E+02,& + & .9122231E+01,.2446628E+02,.3246758E+02,.3601819E+02,.2538766E+02,& + & .1075904E+02,.2694105E+02,.3528642E+02,.3878018E+02,.2762932E+02,& + & .1258935E+02,.2936114E+02,.3798364E+02,.4136006E+02,.2983193E+02,& + & .1459875E+02,.3170547E+02,.4053737E+02,.4375979E+02,.3199342E+02,& + & .1675964E+02,.3396515E+02,.4293329E+02,.4597404E+02,.3411195E+02,& + & .8803526E+01,.2404740E+02,.3199538E+02,.3556585E+02,.2502152E+02,& + & .1042899E+02,.2653898E+02,.3484146E+02,.3835958E+02,.2727937E+02,& + & .1224422E+02,.2898189E+02,.3757031E+02,.4097542E+02,.2949406E+02,& + & .1424127E+02,.3135230E+02,.4015581E+02,.4341193E+02,.3166878E+02,& + & .1639118E+02,.3362956E+02,.4258239E+02,.4565679E+02,.3379358E+02,& + & .8495800E+01,.2362002E+02,.3150999E+02,.3509681E+02,.2464648E+02,& + & .1010745E+02,.2612626E+02,.3438400E+02,.3792281E+02,.2691822E+02,& + & .1190476E+02,.2858932E+02,.3713908E+02,.4057067E+02,.2914314E+02,& + & .1388319E+02,.3098024E+02,.3975563E+02,.4304137E+02,.3132741E+02,& + & .1601937E+02,.3327847E+02,.4221299E+02,.4532208E+02,.3346428E+02,& + & .8209035E+01,.2320772E+02,.3103726E+02,.3463708E+02,.2427972E+02,& + & .9807919E+01,.2572338E+02,.3393496E+02,.3749067E+02,.2656635E+02,& + & .1158465E+02,.2820687E+02,.3671655E+02,.4017333E+02,.2879950E+02,& + & .1354242E+02,.3061364E+02,.3936092E+02,.4267581E+02,.3099415E+02,& + & .1566241E+02,.3293272E+02,.4184735E+02,.4498926E+02,.3314168E+02,& + & .7784536E+01,.2254512E+02,.3026965E+02,.3388321E+02,.2367971E+02,& + & .9354919E+01,.2507029E+02,.3319736E+02,.3677442E+02,.2598726E+02,& + & .1108920E+02,.2757544E+02,.3601743E+02,.3950998E+02,.2823588E+02,& + & .1300857E+02,.3000630E+02,.3870211E+02,.4206119E+02,.3044264E+02,& + & .1509523E+02,.3235435E+02,.4123355E+02,.4442692E+02,.3260463E+02/ + + data absb(701:875,10) / & + & .7359863E+01,.2185814E+02,.2946589E+02,.3308961E+02,.2305342E+02,& + & .8903128E+01,.2438939E+02,.3241822E+02,.3601163E+02,.2537863E+02,& + & .1058971E+02,.2690897E+02,.3527629E+02,.3879993E+02,.2764129E+02,& + & .1246583E+02,.2936503E+02,.3800506E+02,.4140154E+02,.2986144E+02,& + & .1451513E+02,.3174374E+02,.4058041E+02,.4382112E+02,.3203789E+02,& + & .6956382E+01,.2118043E+02,.2866324E+02,.3229115E+02,.2242833E+02,& + & .8461548E+01,.2370968E+02,.3163712E+02,.3524703E+02,.2476677E+02,& + & .1010795E+02,.2624061E+02,.3452870E+02,.3808268E+02,.2704785E+02,& + & .1193898E+02,.2872275E+02,.3729875E+02,.4073465E+02,.2928035E+02,& + & .1394781E+02,.3112498E+02,.3991541E+02,.4320304E+02,.3147062E+02,& + & .6487545E+01,.2036428E+02,.2769057E+02,.3132006E+02,.2167153E+02,& + & .7946649E+01,.2289019E+02,.3068619E+02,.3430975E+02,.2402051E+02,& + & .9549264E+01,.2542789E+02,.3361405E+02,.3719415E+02,.2632349E+02,& + & .1132268E+02,.2793770E+02,.3642692E+02,.3990874E+02,.2857172E+02,& + & .1327981E+02,.3036678E+02,.3909744E+02,.4243907E+02,.3077710E+02,& + & .6005571E+01,.1948807E+02,.2664131E+02,.3026331E+02,.2085818E+02,& + & .7413456E+01,.2201077E+02,.2965560E+02,.3329082E+02,.2321444E+02,& + & .8970318E+01,.2455040E+02,.3261620E+02,.3621899E+02,.2554069E+02,& + & .1068617E+02,.2708083E+02,.3547019E+02,.3899468E+02,.2780284E+02,& + & .1258054E+02,.2953954E+02,.3819719E+02,.4159109E+02,.3002584E+02,& + & .5548432E+01,.1861826E+02,.2559278E+02,.2919402E+02,.2004363E+02,& + & .6900092E+01,.2113681E+02,.2862219E+02,.3226196E+02,.2240744E+02,& + & .8410066E+01,.2367383E+02,.3160742E+02,.3522918E+02,.2474973E+02,& + & .1007047E+02,.2621742E+02,.3450362E+02,.3806349E+02,.2703382E+02,& + & .1190409E+02,.2870722E+02,.3728217E+02,.4072426E+02,.2927143E+02,& + & .5089620E+01,.1770102E+02,.2447913E+02,.2805560E+02,.1917787E+02,& + & .6378669E+01,.2021146E+02,.2751878E+02,.3115717E+02,.2154621E+02,& + & .7837964E+01,.2274529E+02,.3052386E+02,.3415832E+02,.2390212E+02,& + & .9443196E+01,.2529235E+02,.3346307E+02,.3705110E+02,.2620879E+02,& + & .1120944E+02,.2781188E+02,.3628879E+02,.3978127E+02,.2846286E+02,& + & .4610896E+01,.1669349E+02,.2324369E+02,.2677647E+02,.1820576E+02,& + & .5824606E+01,.1918277E+02,.2628270E+02,.2990605E+02,.2058572E+02,& + & .7220182E+01,.2171074E+02,.2930791E+02,.3295106E+02,.2294896E+02,& + & .8769986E+01,.2425684E+02,.3228052E+02,.3589409E+02,.2528213E+02,& + & .1046384E+02,.2679654E+02,.3515901E+02,.3869877E+02,.2755405E+02/ + + data absb(876:1050,10) / & + & .4168305E+01,.1570562E+02,.2201962E+02,.2548007E+02,.1723083E+02,& + & .5302277E+01,.1816020E+02,.2504538E+02,.2864169E+02,.1962267E+02,& + & .6628824E+01,.2068096E+02,.2808483E+02,.3173022E+02,.2199260E+02,& + & .8120143E+01,.2322187E+02,.3108353E+02,.3471491E+02,.2434405E+02,& + & .9751318E+01,.2577042E+02,.3400727E+02,.3758542E+02,.2664002E+02,& + & .3760997E+01,.1474503E+02,.2081030E+02,.2417490E+02,.1625573E+02,& + & .4812522E+01,.1715003E+02,.2381102E+02,.2737145E+02,.1865721E+02,& + & .6065394E+01,.1965574E+02,.2685618E+02,.3049364E+02,.2103561E+02,& + & .7493897E+01,.2218813E+02,.2987458E+02,.3351954E+02,.2339558E+02,& + & .9069722E+01,.2473888E+02,.3283783E+02,.3644425E+02,.2572001E+02,& + & .3407008E+01,.1387327E+02,.1968672E+02,.2295130E+02,.1534229E+02,& + & .4384559E+01,.1621715E+02,.2266121E+02,.2616930E+02,.1774766E+02,& + & .5564493E+01,.1869821E+02,.2569991E+02,.2931565E+02,.2013618E+02,& + & .6930044E+01,.2122343E+02,.2873366E+02,.3238405E+02,.2250272E+02,& + & .8451961E+01,.2376957E+02,.3172435E+02,.3535077E+02,.2484828E+02,& + & .3086932E+01,.1305420E+02,.1860890E+02,.2176702E+02,.1445866E+02,& + & .3998495E+01,.1533239E+02,.2155796E+02,.2498933E+02,.1686364E+02,& + & .5105023E+01,.1777463E+02,.2457856E+02,.2816630E+02,.1926213E+02,& + & .6405638E+01,.2029281E+02,.2762298E+02,.3127387E+02,.2163511E+02,& + & .7876512E+01,.2283418E+02,.3063295E+02,.3427110E+02,.2399217E+02,& + & .2791590E+01,.1226154E+02,.1753948E+02,.2058143E+02,.1357966E+02,& + & .3641206E+01,.1447202E+02,.2046653E+02,.2380567E+02,.1597990E+02,& + & .4672585E+01,.1686375E+02,.2346271E+02,.2701461E+02,.1838557E+02,& + & .5905294E+01,.1936440E+02,.2650933E+02,.3014596E+02,.2076820E+02,& + & .7318334E+01,.2189961E+02,.2953666E+02,.3318455E+02,.2313340E+02,& + & .2518774E+01,.1149827E+02,.1648112E+02,.1939248E+02,.1269754E+02,& + & .3307338E+01,.1363661E+02,.1938353E+02,.2262314E+02,.1509794E+02,& + & .4268652E+01,.1596732E+02,.2235360E+02,.2584534E+02,.1750525E+02,& + & .5428748E+01,.1843909E+02,.2539018E+02,.2900296E+02,.1989679E+02,& + & .6779426E+01,.2096706E+02,.2843121E+02,.3208295E+02,.2226801E+02,& + & .2289464E+01,.1082893E+02,.1552622E+02,.1830474E+02,.1189008E+02,& + & .3020620E+01,.1289378E+02,.1840077E+02,.2154161E+02,.1429147E+02,& + & .3922374E+01,.1516305E+02,.2134768E+02,.2476500E+02,.1669686E+02,& + & .5015015E+01,.1759724E+02,.2436604E+02,.2795197E+02,.1909808E+02,& + & .6305470E+01,.2011705E+02,.2741465E+02,.3106251E+02,.2147332E+02/ + + data absb(1051:1175,10) / & + & .2089789E+01,.1021602E+02,.1463344E+02,.1726758E+02,.1112336E+02,& + & .2767245E+01,.1220573E+02,.1746541E+02,.2050030E+02,.1351996E+02,& + & .3612314E+01,.1441119E+02,.2039079E+02,.2372523E+02,.1592114E+02,& + & .4639139E+01,.1679873E+02,.2338586E+02,.2693757E+02,.1832633E+02,& + & .5869463E+01,.1930265E+02,.2643475E+02,.3007091E+02,.2071169E+02,& + & .1902771E+01,.9617449E+01,.1375735E+02,.1623578E+02,.1036934E+02,& + & .2529334E+01,.1153875E+02,.1653836E+02,.1945888E+02,.1274803E+02,& + & .3320906E+01,.1368161E+02,.1944359E+02,.2269151E+02,.1514962E+02,& + & .4286297E+01,.1601548E+02,.2241651E+02,.2591604E+02,.1755694E+02,& + & .5452967E+01,.1849373E+02,.2545654E+02,.2907074E+02,.1994983E+02,& + & .1725440E+01,.9031381E+01,.1289432E+02,.1520765E+02,.9626329E+01,& + & .2309750E+01,.1089872E+02,.1562812E+02,.1842270E+02,.1197707E+02,& + & .3046266E+01,.1297125E+02,.1850543E+02,.2165803E+02,.1437884E+02,& + & .3954352E+01,.1524573E+02,.2145498E+02,.2488428E+02,.1678481E+02,& + & .5056606E+01,.1768754E+02,.2447686E+02,.2806579E+02,.1918626E+02,& + & .1564823E+01,.8489334E+01,.1209006E+02,.1424280E+02,.8931475E+01,& + & .2117660E+01,.1031347E+02,.1477913E+02,.1744092E+02,.1125085E+02,& + & .2802981E+01,.1231464E+02,.1761845E+02,.2067534E+02,.1364984E+02,& + & .3659632E+01,.1453293E+02,.2055035E+02,.2390260E+02,.1605194E+02,& + & .4698820E+01,.1693318E+02,.2355149E+02,.2710920E+02,.1845815E+02,& + & .1502352E+01,.8276308E+01,.1177375E+02,.1385967E+02,.8655479E+01,& + & .2044007E+01,.1008294E+02,.1444326E+02,.1704897E+02,.1096188E+02,& + & .2709296E+01,.1205664E+02,.1726418E+02,.2027874E+02,.1335631E+02,& + & .3545610E+01,.1425196E+02,.2018817E+02,.2350704E+02,.1575791E+02,& + & .4560655E+01,.1663292E+02,.2318230E+02,.2672443E+02,.1816710E+02/ + + data absb( 1:175,11) / & + & .2056300E+03,.1639500E+03,.1513100E+03,.1392800E+03,.1733600E+03,& + & .2058300E+03,.1634600E+03,.1510200E+03,.1386700E+03,.1720900E+03,& + & .2057900E+03,.1628200E+03,.1505100E+03,.1380300E+03,.1711900E+03,& + & .2053800E+03,.1619800E+03,.1500500E+03,.1374600E+03,.1706200E+03,& + & .2047100E+03,.1610000E+03,.1494200E+03,.1368500E+03,.1699800E+03,& + & .2138700E+03,.1748600E+03,.1641000E+03,.1489600E+03,.1792600E+03,& + & .2139800E+03,.1740700E+03,.1635400E+03,.1484900E+03,.1787200E+03,& + & .2137100E+03,.1730600E+03,.1630000E+03,.1479600E+03,.1783800E+03,& + & .2132000E+03,.1719300E+03,.1623800E+03,.1474800E+03,.1780700E+03,& + & .2123900E+03,.1706200E+03,.1615800E+03,.1466100E+03,.1772600E+03,& + & .2186800E+03,.1839200E+03,.1759700E+03,.1587700E+03,.1840900E+03,& + & .2186100E+03,.1828500E+03,.1753300E+03,.1584500E+03,.1841300E+03,& + & .2183800E+03,.1816800E+03,.1746900E+03,.1581400E+03,.1842300E+03,& + & .2178500E+03,.1802800E+03,.1739200E+03,.1574700E+03,.1839100E+03,& + & .2171400E+03,.1788100E+03,.1728100E+03,.1564400E+03,.1833700E+03,& + & .2198900E+03,.1909000E+03,.1866600E+03,.1682300E+03,.1871700E+03,& + & .2200000E+03,.1898900E+03,.1860400E+03,.1682200E+03,.1879700E+03,& + & .2198200E+03,.1885600E+03,.1853300E+03,.1679400E+03,.1885100E+03,& + & .2195400E+03,.1870900E+03,.1843200E+03,.1671500E+03,.1885400E+03,& + & .2189800E+03,.1854200E+03,.1830300E+03,.1660000E+03,.1883900E+03,& + & .2179300E+03,.1959600E+03,.1960300E+03,.1770300E+03,.1885700E+03,& + & .2182100E+03,.1949200E+03,.1954800E+03,.1772500E+03,.1902300E+03,& + & .2185000E+03,.1936900E+03,.1946200E+03,.1770100E+03,.1913300E+03,& + & .2185500E+03,.1922100E+03,.1934300E+03,.1761600E+03,.1919400E+03,& + & .2183900E+03,.1905700E+03,.1920600E+03,.1749000E+03,.1922500E+03,& + & .2131100E+03,.1993500E+03,.2038500E+03,.1849200E+03,.1886400E+03,& + & .2139900E+03,.1983800E+03,.2033900E+03,.1853600E+03,.1911700E+03,& + & .2147700E+03,.1972700E+03,.2025100E+03,.1851700E+03,.1929600E+03,& + & .2153700E+03,.1960200E+03,.2013100E+03,.1843300E+03,.1942600E+03,& + & .2159400E+03,.1946000E+03,.1998900E+03,.1829900E+03,.1951100E+03,& + & .2062800E+03,.2013100E+03,.2101800E+03,.1918100E+03,.1878000E+03,& + & .2078600E+03,.2006100E+03,.2098500E+03,.1924900E+03,.1911700E+03,& + & .2093900E+03,.1997800E+03,.2091500E+03,.1924500E+03,.1937900E+03,& + & .2107800E+03,.1987600E+03,.2080800E+03,.1915900E+03,.1957800E+03,& + & .2119600E+03,.1976200E+03,.2066600E+03,.1902000E+03,.1972600E+03/ + + data absb(176:350,11) / & + & .1980600E+03,.2021500E+03,.2152500E+03,.1978100E+03,.1864600E+03,& + & .2005400E+03,.2018000E+03,.2152700E+03,.1987400E+03,.1907200E+03,& + & .2029800E+03,.2013200E+03,.2147800E+03,.1987700E+03,.1941300E+03,& + & .2052200E+03,.2007000E+03,.2138400E+03,.1979300E+03,.1968100E+03,& + & .2072500E+03,.1997500E+03,.2124900E+03,.1965900E+03,.1989900E+03,& + & .1891900E+03,.2021700E+03,.2194200E+03,.2029100E+03,.1849900E+03,& + & .1926800E+03,.2023900E+03,.2197400E+03,.2041500E+03,.1901200E+03,& + & .1960900E+03,.2023100E+03,.2194700E+03,.2042500E+03,.1943200E+03,& + & .1992600E+03,.2020100E+03,.2186600E+03,.2034600E+03,.1977000E+03,& + & .2022400E+03,.2013600E+03,.2174200E+03,.2021200E+03,.2004400E+03,& + & .1806400E+03,.2018200E+03,.2227600E+03,.2074000E+03,.1840900E+03,& + & .1851300E+03,.2025300E+03,.2234100E+03,.2087600E+03,.1898800E+03,& + & .1895100E+03,.2028700E+03,.2232900E+03,.2089000E+03,.1947400E+03,& + & .1936800E+03,.2028300E+03,.2225900E+03,.2081200E+03,.1986900E+03,& + & .1975200E+03,.2024800E+03,.2214300E+03,.2067600E+03,.2018500E+03,& + & .1726100E+03,.2012900E+03,.2256000E+03,.2112600E+03,.1836000E+03,& + & .1781300E+03,.2025500E+03,.2264500E+03,.2127700E+03,.1899300E+03,& + & .1834700E+03,.2032200E+03,.2264900E+03,.2128800E+03,.1953400E+03,& + & .1885800E+03,.2034500E+03,.2259300E+03,.2121100E+03,.1997200E+03,& + & .1932500E+03,.2033000E+03,.2247000E+03,.2106600E+03,.2031400E+03,& + & .1655000E+03,.2007900E+03,.2279700E+03,.2145900E+03,.1835200E+03,& + & .1719900E+03,.2024700E+03,.2289900E+03,.2161400E+03,.1903100E+03,& + & .1782900E+03,.2034900E+03,.2292000E+03,.2162100E+03,.1961000E+03,& + & .1842400E+03,.2039500E+03,.2286500E+03,.2154400E+03,.2008000E+03,& + & .1896600E+03,.2039300E+03,.2273500E+03,.2138800E+03,.2043700E+03,& + & .1594900E+03,.2004800E+03,.2299900E+03,.2175800E+03,.1839500E+03,& + & .1669800E+03,.2024700E+03,.2311900E+03,.2190300E+03,.1910800E+03,& + & .1741100E+03,.2037000E+03,.2314400E+03,.2190400E+03,.1971100E+03,& + & .1808800E+03,.2043500E+03,.2308200E+03,.2181700E+03,.2019200E+03,& + & .1871000E+03,.2045000E+03,.2295000E+03,.2164800E+03,.2055900E+03,& + & .1547900E+03,.2003800E+03,.2318100E+03,.2201600E+03,.1849000E+03,& + & .1632200E+03,.2025800E+03,.2330700E+03,.2214500E+03,.1922200E+03,& + & .1711900E+03,.2040100E+03,.2332600E+03,.2214000E+03,.1983100E+03,& + & .1786600E+03,.2047800E+03,.2325900E+03,.2203800E+03,.2031500E+03,& + & .1855300E+03,.2049800E+03,.2312200E+03,.2185400E+03,.2068500E+03/ + + data absb(351:525,11) / & + & .1514300E+03,.2004900E+03,.2334400E+03,.2224100E+03,.1861500E+03,& + & .1607000E+03,.2027900E+03,.2346500E+03,.2235200E+03,.1935300E+03,& + & .1693200E+03,.2043000E+03,.2347300E+03,.2233100E+03,.1996000E+03,& + & .1773700E+03,.2051800E+03,.2340200E+03,.2221200E+03,.2044000E+03,& + & .1847200E+03,.2053700E+03,.2325700E+03,.2201500E+03,.2080700E+03,& + & .1493500E+03,.2007800E+03,.2348700E+03,.2243600E+03,.1876200E+03,& + & .1592600E+03,.2031200E+03,.2359700E+03,.2252300E+03,.1949100E+03,& + & .1683900E+03,.2046700E+03,.2359700E+03,.2248400E+03,.2009200E+03,& + & .1768700E+03,.2055400E+03,.2351600E+03,.2234500E+03,.2056200E+03,& + & .1845300E+03,.2057000E+03,.2335700E+03,.2213500E+03,.2092100E+03,& + & .1484400E+03,.2011700E+03,.2361400E+03,.2260100E+03,.1892700E+03,& + & .1587800E+03,.2035000E+03,.2370700E+03,.2266400E+03,.1964200E+03,& + & .1682900E+03,.2050500E+03,.2369600E+03,.2260100E+03,.2022900E+03,& + & .1770200E+03,.2058500E+03,.2360200E+03,.2244500E+03,.2068500E+03,& + & .1848700E+03,.2059900E+03,.2343000E+03,.2222000E+03,.2103100E+03,& + & .1484100E+03,.2016500E+03,.2372400E+03,.2274200E+03,.1910100E+03,& + & .1590300E+03,.2039500E+03,.2379800E+03,.2277400E+03,.1979600E+03,& + & .1687800E+03,.2054300E+03,.2377400E+03,.2268900E+03,.2036700E+03,& + & .1776500E+03,.2061400E+03,.2366200E+03,.2251500E+03,.2080400E+03,& + & .1855600E+03,.2062600E+03,.2347800E+03,.2227400E+03,.2113300E+03,& + & .1491000E+03,.2021900E+03,.2381600E+03,.2285700E+03,.1928000E+03,& + & .1598700E+03,.2044200E+03,.2387300E+03,.2286000E+03,.1995500E+03,& + & .1697400E+03,.2057800E+03,.2383000E+03,.2275100E+03,.2050300E+03,& + & .1787000E+03,.2064000E+03,.2370300E+03,.2255900E+03,.2091700E+03,& + & .1865600E+03,.2064700E+03,.2350400E+03,.2230300E+03,.2123200E+03,& + & .1503100E+03,.2027900E+03,.2389700E+03,.2294900E+03,.1945900E+03,& + & .1611900E+03,.2048900E+03,.2393100E+03,.2292200E+03,.2011300E+03,& + & .1711000E+03,.2061000E+03,.2386900E+03,.2279100E+03,.2063400E+03,& + & .1800200E+03,.2066200E+03,.2372300E+03,.2258200E+03,.2102900E+03,& + & .1877700E+03,.2065900E+03,.2351000E+03,.2230800E+03,.2132200E+03,& + & .1519700E+03,.2034100E+03,.2396500E+03,.2301900E+03,.1963900E+03,& + & .1628500E+03,.2053400E+03,.2397600E+03,.2296400E+03,.2026700E+03,& + & .1727000E+03,.2063800E+03,.2389300E+03,.2281100E+03,.2075800E+03,& + & .1815100E+03,.2068000E+03,.2372700E+03,.2258400E+03,.2113200E+03,& + & .1891200E+03,.2066500E+03,.2350000E+03,.2229600E+03,.2140600E+03/ + + data absb(526:700,11) / & + & .1535200E+03,.2039100E+03,.2401400E+03,.2306900E+03,.1979000E+03,& + & .1643700E+03,.2056600E+03,.2400600E+03,.2299200E+03,.2039600E+03,& + & .1741600E+03,.2066200E+03,.2390700E+03,.2282300E+03,.2086300E+03,& + & .1828500E+03,.2069500E+03,.2372800E+03,.2258000E+03,.2121800E+03,& + & .1903300E+03,.2066700E+03,.2348700E+03,.2228000E+03,.2147400E+03,& + & .1542100E+03,.2041800E+03,.2405200E+03,.2311000E+03,.1987600E+03,& + & .1650700E+03,.2058600E+03,.2403300E+03,.2302000E+03,.2046800E+03,& + & .1748600E+03,.2067700E+03,.2392400E+03,.2284100E+03,.2092300E+03,& + & .1835000E+03,.2070500E+03,.2373700E+03,.2258900E+03,.2126900E+03,& + & .1909400E+03,.2066900E+03,.2348900E+03,.2228100E+03,.2151400E+03,& + & .1538100E+03,.2042400E+03,.2408000E+03,.2314500E+03,.1988800E+03,& + & .1647800E+03,.2059200E+03,.2406000E+03,.2305500E+03,.2048400E+03,& + & .1746400E+03,.2068400E+03,.2395000E+03,.2287400E+03,.2093800E+03,& + & .1833600E+03,.2071500E+03,.2376200E+03,.2261800E+03,.2128400E+03,& + & .1908600E+03,.2067800E+03,.2351400E+03,.2231100E+03,.2153200E+03,& + & .1517700E+03,.2039400E+03,.2409600E+03,.2317800E+03,.1980200E+03,& + & .1629800E+03,.2057800E+03,.2409100E+03,.2310200E+03,.2041600E+03,& + & .1730700E+03,.2068100E+03,.2399400E+03,.2293400E+03,.2089300E+03,& + & .1820400E+03,.2072100E+03,.2381800E+03,.2268800E+03,.2125500E+03,& + & .1897300E+03,.2069500E+03,.2357300E+03,.2238300E+03,.2151600E+03,& + & .1496800E+03,.2035900E+03,.2410400E+03,.2320200E+03,.1970300E+03,& + & .1611300E+03,.2056000E+03,.2411600E+03,.2314300E+03,.2034100E+03,& + & .1714400E+03,.2067400E+03,.2403300E+03,.2298800E+03,.2083800E+03,& + & .1806300E+03,.2072400E+03,.2386600E+03,.2275200E+03,.2121600E+03,& + & .1885500E+03,.2071000E+03,.2363200E+03,.2245300E+03,.2149300E+03,& + & .1476400E+03,.2032200E+03,.2410600E+03,.2322000E+03,.1960400E+03,& + & .1593200E+03,.2054000E+03,.2413700E+03,.2318000E+03,.2026200E+03,& + & .1698400E+03,.2066500E+03,.2406500E+03,.2303600E+03,.2078100E+03,& + & .1792300E+03,.2072500E+03,.2391000E+03,.2281000E+03,.2117500E+03,& + & .1873700E+03,.2072200E+03,.2368400E+03,.2251700E+03,.2146700E+03,& + & .1443800E+03,.2025400E+03,.2409200E+03,.2322500E+03,.1942500E+03,& + & .1563300E+03,.2049800E+03,.2415200E+03,.2321700E+03,.2011500E+03,& + & .1671800E+03,.2064200E+03,.2410500E+03,.2309600E+03,.2067200E+03,& + & .1769000E+03,.2072000E+03,.2396900E+03,.2288700E+03,.2109300E+03,& + & .1853900E+03,.2073300E+03,.2375800E+03,.2260900E+03,.2141100E+03/ + + data absb(701:875,11) / & + & .1409300E+03,.2017000E+03,.2406200E+03,.2321400E+03,.1922600E+03,& + & .1530900E+03,.2044100E+03,.2415500E+03,.2324300E+03,.1995100E+03,& + & .1643400E+03,.2061300E+03,.2413600E+03,.2314900E+03,.2054500E+03,& + & .1743900E+03,.2070900E+03,.2402200E+03,.2296300E+03,.2100000E+03,& + & .1832500E+03,.2073900E+03,.2382900E+03,.2270000E+03,.2134400E+03,& + & .1374200E+03,.2007200E+03,.2401800E+03,.2318800E+03,.1901700E+03,& + & .1498700E+03,.2038100E+03,.2415100E+03,.2326000E+03,.1977800E+03,& + & .1614400E+03,.2058000E+03,.2415900E+03,.2319400E+03,.2040800E+03,& + & .1718200E+03,.2069300E+03,.2406800E+03,.2303000E+03,.2089700E+03,& + & .1810100E+03,.2073900E+03,.2389400E+03,.2278500E+03,.2126900E+03,& + & .1331600E+03,.1994600E+03,.2395200E+03,.2313400E+03,.1874600E+03,& + & .1459000E+03,.2029900E+03,.2413100E+03,.2326500E+03,.1955500E+03,& + & .1578200E+03,.2053100E+03,.2417600E+03,.2323700E+03,.2022800E+03,& + & .1686000E+03,.2066600E+03,.2411300E+03,.2309900E+03,.2076100E+03,& + & .1781800E+03,.2073300E+03,.2396400E+03,.2287800E+03,.2116600E+03,& + & .1285100E+03,.1979300E+03,.2386000E+03,.2305100E+03,.1844000E+03,& + & .1415600E+03,.2019500E+03,.2409200E+03,.2324900E+03,.1929800E+03,& + & .1538100E+03,.2046800E+03,.2418200E+03,.2326800E+03,.2001500E+03,& + & .1649400E+03,.2062500E+03,.2414800E+03,.2316300E+03,.2059700E+03,& + & .1749900E+03,.2071900E+03,.2402900E+03,.2296900E+03,.2104300E+03,& + & .1237700E+03,.1962200E+03,.2374500E+03,.2293800E+03,.1811400E+03,& + & .1371300E+03,.2007400E+03,.2403500E+03,.2321000E+03,.1902400E+03,& + & .1496900E+03,.2038900E+03,.2417100E+03,.2328300E+03,.1978700E+03,& + & .1612200E+03,.2058000E+03,.2417200E+03,.2321500E+03,.2041700E+03,& + & .1716900E+03,.2069700E+03,.2408500E+03,.2305100E+03,.2090700E+03,& + & .1187100E+03,.1941800E+03,.2360000E+03,.2279000E+03,.1774700E+03,& + & .1323100E+03,.1992900E+03,.2395400E+03,.2314300E+03,.1871200E+03,& + & .1451400E+03,.2028800E+03,.2413800E+03,.2328000E+03,.1952600E+03,& + & .1571100E+03,.2052300E+03,.2418700E+03,.2325700E+03,.2020700E+03,& + & .1680200E+03,.2066400E+03,.2413200E+03,.2312600E+03,.2074900E+03,& + & .1129500E+03,.1915900E+03,.2339800E+03,.2258800E+03,.1731300E+03,& + & .1268300E+03,.1974100E+03,.2383500E+03,.2303100E+03,.1834200E+03,& + & .1399900E+03,.2015900E+03,.2408500E+03,.2325300E+03,.1921700E+03,& + & .1523400E+03,.2044200E+03,.2418600E+03,.2328600E+03,.1994900E+03,& + & .1637300E+03,.2061800E+03,.2416900E+03,.2319400E+03,.2054900E+03/ + + data absb(876:1050,11) / & + & .1071200E+03,.1887100E+03,.2315900E+03,.2234700E+03,.1685000E+03,& + & .1212400E+03,.1952900E+03,.2368700E+03,.2288200E+03,.1794600E+03,& + & .1347300E+03,.2000700E+03,.2400500E+03,.2319100E+03,.1888300E+03,& + & .1474200E+03,.2034200E+03,.2416400E+03,.2329400E+03,.1967000E+03,& + & .1592800E+03,.2056200E+03,.2419200E+03,.2324700E+03,.2032500E+03,& + & .1012000E+03,.1855000E+03,.2288000E+03,.2207100E+03,.1636300E+03,& + & .1155600E+03,.1928500E+03,.2350400E+03,.2269700E+03,.1752400E+03,& + & .1293200E+03,.1983200E+03,.2390100E+03,.2309700E+03,.1852400E+03,& + & .1423800E+03,.2022600E+03,.2412000E+03,.2327800E+03,.1937000E+03,& + & .1546000E+03,.2048800E+03,.2419900E+03,.2328300E+03,.2007800E+03,& + & .9560300E+02,.1821600E+03,.2257600E+03,.2176800E+03,.1587800E+03,& + & .1101500E+03,.1903100E+03,.2329800E+03,.2249000E+03,.1710500E+03,& + & .1241500E+03,.1964600E+03,.2377500E+03,.2297500E+03,.1816600E+03,& + & .1375200E+03,.2009400E+03,.2405800E+03,.2323600E+03,.1906900E+03,& + & .1500700E+03,.2040300E+03,.2418700E+03,.2329900E+03,.1982600E+03,& + & .9013700E+02,.1786800E+03,.2224000E+03,.2144200E+03,.1538400E+03,& + & .1048400E+03,.1875700E+03,.2306600E+03,.2225800E+03,.1667700E+03,& + & .1190700E+03,.1944200E+03,.2362800E+03,.2282400E+03,.1779600E+03,& + & .1326900E+03,.1994800E+03,.2397600E+03,.2316700E+03,.1875600E+03,& + & .1455200E+03,.2030200E+03,.2415400E+03,.2329600E+03,.1956500E+03,& + & .8469000E+02,.1749600E+03,.2186400E+03,.2108000E+03,.1486200E+03,& + & .9947100E+02,.1845300E+03,.2279800E+03,.2199200E+03,.1622500E+03,& + & .1139100E+03,.1921300E+03,.2345100E+03,.2264400E+03,.1740600E+03,& + & .1277700E+03,.1978100E+03,.2387200E+03,.2307000E+03,.1842400E+03,& + & .1409100E+03,.2018900E+03,.2410700E+03,.2327300E+03,.1928600E+03,& + & .7926200E+02,.1709500E+03,.2143600E+03,.2068100E+03,.1431700E+03,& + & .9404700E+02,.1812600E+03,.2249400E+03,.2169000E+03,.1574800E+03,& + & .1086500E+03,.1895800E+03,.2324100E+03,.2243400E+03,.1699400E+03,& + & .1227400E+03,.1959500E+03,.2374200E+03,.2294100E+03,.1807000E+03,& + & .1361800E+03,.2005600E+03,.2404000E+03,.2322400E+03,.1898800E+03,& + & .7431200E+02,.1670100E+03,.2100000E+03,.2028300E+03,.1380100E+03,& + & .8905900E+02,.1780200E+03,.2217700E+03,.2138100E+03,.1528900E+03,& + & .1037900E+03,.1870100E+03,.2302100E+03,.2221400E+03,.1659500E+03,& + & .1180800E+03,.1940300E+03,.2360200E+03,.2279700E+03,.1772800E+03,& + & .1317400E+03,.1991800E+03,.2396100E+03,.2315500E+03,.1869700E+03/ + + data absb(1051:1175,11) / & + & .6961500E+02,.1629600E+03,.2054000E+03,.1986600E+03,.1328800E+03,& + & .8427600E+02,.1746600E+03,.2183500E+03,.2105600E+03,.1482800E+03,& + & .9906600E+02,.1843300E+03,.2278200E+03,.2197700E+03,.1619700E+03,& + & .1135400E+03,.1919900E+03,.2344200E+03,.2263600E+03,.1738300E+03,& + & .1274100E+03,.1977000E+03,.2386600E+03,.2306500E+03,.1840300E+03,& + & .6494400E+02,.1587700E+03,.2004400E+03,.1942100E+03,.1276200E+03,& + & .7952400E+02,.1711400E+03,.2146100E+03,.2070700E+03,.1435100E+03,& + & .9432300E+02,.1814400E+03,.2251400E+03,.2171100E+03,.1577800E+03,& + & .1089400E+03,.1897600E+03,.2325700E+03,.2245200E+03,.1702200E+03,& + & .1230100E+03,.1960500E+03,.2375200E+03,.2295400E+03,.1809400E+03,& + & .6035300E+02,.1543100E+03,.1951400E+03,.1894500E+03,.1222500E+03,& + & .7481500E+02,.1674200E+03,.2104900E+03,.2032900E+03,.1386000E+03,& + & .8956700E+02,.1783700E+03,.2221400E+03,.2141900E+03,.1534300E+03,& + & .1043100E+03,.1873300E+03,.2305000E+03,.2224400E+03,.1664400E+03,& + & .1185600E+03,.1942300E+03,.2361800E+03,.2281600E+03,.1776700E+03,& + & .5609800E+02,.1499100E+03,.1898000E+03,.1846500E+03,.1170600E+03,& + & .7037700E+02,.1636700E+03,.2062200E+03,.1994200E+03,.1337800E+03,& + & .8504900E+02,.1752800E+03,.2190200E+03,.2111900E+03,.1491000E+03,& + & .9985700E+02,.1848200E+03,.2282700E+03,.2202200E+03,.1626800E+03,& + & .1142800E+03,.1923300E+03,.2347000E+03,.2266600E+03,.1744400E+03,& + & .5441800E+02,.1480900E+03,.1875400E+03,.1826100E+03,.1149500E+03,& + & .6859800E+02,.1621000E+03,.2044100E+03,.1977800E+03,.1318000E+03,& + & .8324600E+02,.1739800E+03,.2176800E+03,.2099300E+03,.1473300E+03,& + & .9805500E+02,.1837500E+03,.2273200E+03,.2192700E+03,.1611300E+03,& + & .1125500E+03,.1915300E+03,.2340600E+03,.2260100E+03,.1731000E+03/ + + data absb( 1:175,12) / & + & .4338110E+03,.3258785E+03,.2765841E+03,.3551700E+03,.4738213E+03,& + & .4358591E+03,.3274735E+03,.2732330E+03,.3477157E+03,.4639305E+03,& + & .4367994E+03,.3282050E+03,.2698072E+03,.3403736E+03,.4541170E+03,& + & .4367673E+03,.3281913E+03,.2662171E+03,.3330191E+03,.4442737E+03,& + & .4356257E+03,.3273304E+03,.2624520E+03,.3260525E+03,.4349606E+03,& + & .4965751E+03,.3730543E+03,.3165865E+03,.3940821E+03,.5257811E+03,& + & .4977615E+03,.3739641E+03,.3123416E+03,.3853185E+03,.5140967E+03,& + & .4978529E+03,.3740600E+03,.3078301E+03,.3766318E+03,.5024939E+03,& + & .4965358E+03,.3731122E+03,.3030947E+03,.3681551E+03,.4911078E+03,& + & .4942501E+03,.3714089E+03,.2982254E+03,.3606307E+03,.4809116E+03,& + & .5631880E+03,.4233224E+03,.3594901E+03,.4335570E+03,.5784608E+03,& + & .5634438E+03,.4233039E+03,.3539288E+03,.4233711E+03,.5648410E+03,& + & .5619418E+03,.4221964E+03,.3480452E+03,.4132459E+03,.5512312E+03,& + & .5592483E+03,.4202048E+03,.3418750E+03,.4039045E+03,.5386286E+03,& + & .5551436E+03,.4171466E+03,.3356718E+03,.3953284E+03,.5268417E+03,& + & .6327464E+03,.4759753E+03,.4043694E+03,.4738466E+03,.6318088E+03,& + & .6309974E+03,.4742402E+03,.3971672E+03,.4618354E+03,.6156456E+03,& + & .6278582E+03,.4716973E+03,.3895188E+03,.4502024E+03,.5999656E+03,& + & .6230476E+03,.4681132E+03,.3817116E+03,.4394718E+03,.5854793E+03,& + & .6168383E+03,.4634762E+03,.3737303E+03,.4293418E+03,.5716261E+03,& + & .7031362E+03,.5296686E+03,.4502274E+03,.5144971E+03,.6844628E+03,& + & .6994439E+03,.5260700E+03,.4409153E+03,.5003459E+03,.6654934E+03,& + & .6938124E+03,.5214150E+03,.4313297E+03,.4869200E+03,.6474992E+03,& + & .6865591E+03,.5157531E+03,.4215792E+03,.4743711E+03,.6306843E+03,& + & .6778828E+03,.5092809E+03,.4115306E+03,.4623577E+03,.6144981E+03,& + & .7731573E+03,.5833614E+03,.4960552E+03,.5546751E+03,.7351434E+03,& + & .7667584E+03,.5774695E+03,.4843214E+03,.5381637E+03,.7133093E+03,& + & .7584006E+03,.5703374E+03,.4724758E+03,.5225411E+03,.6927570E+03,& + & .7484491E+03,.5623616E+03,.4604054E+03,.5079339E+03,.6733220E+03,& + & .7367135E+03,.5534249E+03,.4480895E+03,.4939401E+03,.6546934E+03,& + & .8409349E+03,.6358707E+03,.5406929E+03,.5933755E+03,.7826997E+03,& + & .8314773E+03,.6270808E+03,.5263991E+03,.5744137E+03,.7580256E+03,& + & .8200103E+03,.6173497E+03,.5119158E+03,.5563407E+03,.7348534E+03,& + & .8068534E+03,.6066626E+03,.4972618E+03,.5395008E+03,.7127611E+03,& + & .7922845E+03,.5951793E+03,.4826400E+03,.5234260E+03,.6916658E+03/ + + data absb(176:350,12) / & + & .9048913E+03,.6856063E+03,.5829003E+03,.6293251E+03,.8259779E+03,& + & .8920622E+03,.6739392E+03,.5656996E+03,.6076975E+03,.7986291E+03,& + & .8773064E+03,.6613225E+03,.5484044E+03,.5872679E+03,.7727058E+03,& + & .8609036E+03,.6477146E+03,.5311640E+03,.5681427E+03,.7481234E+03,& + & .8431150E+03,.6336171E+03,.5140156E+03,.5498732E+03,.7244630E+03,& + & .9636991E+03,.7316951E+03,.6218536E+03,.6620342E+03,.8647359E+03,& + & .9475066E+03,.7168594E+03,.6016241E+03,.6376903E+03,.8346844E+03,& + & .9293968E+03,.7013269E+03,.5815752E+03,.6149608E+03,.8061544E+03,& + & .9098003E+03,.6849951E+03,.5617381E+03,.5935925E+03,.7790911E+03,& + & .8886450E+03,.6681002E+03,.5420821E+03,.5733205E+03,.7530675E+03,& + & .1015405E+04,.7723224E+03,.6554984E+03,.6893842E+03,.8965322E+03,& + & .9957317E+03,.7543125E+03,.6322716E+03,.6625732E+03,.8641101E+03,& + & .9742889E+03,.7357574E+03,.6095984E+03,.6377464E+03,.8332099E+03,& + & .9513341E+03,.7167192E+03,.5872099E+03,.6143318E+03,.8038674E+03,& + & .9271699E+03,.6973008E+03,.5653278E+03,.5922105E+03,.7757920E+03,& + & .1060462E+04,.8075265E+03,.6843897E+03,.7124747E+03,.9230005E+03,& + & .1037459E+04,.7864953E+03,.6584383E+03,.6833274E+03,.8883530E+03,& + & .1012792E+04,.7651897E+03,.6331576E+03,.6565949E+03,.8552652E+03,& + & .9866354E+03,.7436769E+03,.6084848E+03,.6313485E+03,.8239323E+03,& + & .9595800E+03,.7219245E+03,.5846257E+03,.6076220E+03,.7941595E+03,& + & .1098608E+04,.8371963E+03,.7083084E+03,.7311988E+03,.9441461E+03,& + & .1072494E+04,.8134318E+03,.6798957E+03,.7001704E+03,.9076022E+03,& + & .1044667E+04,.7896182E+03,.6523292E+03,.6716308E+03,.8727223E+03,& + & .1015777E+04,.7658591E+03,.6257102E+03,.6448513E+03,.8396486E+03,& + & .9862086E+03,.7420869E+03,.6001289E+03,.6196814E+03,.8085246E+03,& + & .1130080E+04,.8613842E+03,.7273980E+03,.7455565E+03,.9603143E+03,& + & .1100795E+04,.8351571E+03,.6967578E+03,.7129616E+03,.9220699E+03,& + & .1070329E+04,.8092621E+03,.6672876E+03,.6829948E+03,.8856533E+03,& + & .1038932E+04,.7834641E+03,.6390022E+03,.6549212E+03,.8512901E+03,& + & .1007073E+04,.7578586E+03,.6119071E+03,.6285978E+03,.8190226E+03,& + & .1154817E+04,.8801654E+03,.7415039E+03,.7556111E+03,.9714143E+03,& + & .1122664E+04,.8518781E+03,.7090277E+03,.7218209E+03,.9318180E+03,& + & .1089916E+04,.8241127E+03,.6780777E+03,.6907287E+03,.8943125E+03,& + & .1056461E+04,.7965849E+03,.6484079E+03,.6616194E+03,.8589272E+03,& + & .1022590E+04,.7695324E+03,.6201114E+03,.6344623E+03,.8258624E+03/ + + data absb(351:525,12) / & + & .1173826E+04,.8944232E+03,.7516288E+03,.7622958E+03,.9786164E+03,& + & .1139213E+04,.8644602E+03,.7176974E+03,.7275753E+03,.9379617E+03,& + & .1104499E+04,.8350215E+03,.6855100E+03,.6956267E+03,.8996608E+03,& + & .1069228E+04,.8060327E+03,.6547517E+03,.6658171E+03,.8636644E+03,& + & .1033679E+04,.7777792E+03,.6254959E+03,.6380265E+03,.8299256E+03,& + & .1187612E+04,.9045966E+03,.7582339E+03,.7660705E+03,.9825372E+03,& + & .1151104E+04,.8732077E+03,.7232198E+03,.7307711E+03,.9412613E+03,& + & .1114812E+04,.8425100E+03,.6900707E+03,.6982050E+03,.9022920E+03,& + & .1077922E+04,.8124079E+03,.6584780E+03,.6679077E+03,.8658499E+03,& + & .1040927E+04,.7831204E+03,.6285352E+03,.6396645E+03,.8317461E+03,& + & .1196774E+04,.9111403E+03,.7616196E+03,.7671722E+03,.9834539E+03,& + & .1158870E+04,.8786102E+03,.7258194E+03,.7315277E+03,.9417190E+03,& + & .1121068E+04,.8468836E+03,.6919844E+03,.6985953E+03,.9023781E+03,& + & .1082920E+04,.8159387E+03,.6597813E+03,.6679809E+03,.8657188E+03,& + & .1044783E+04,.7858772E+03,.6294298E+03,.6395237E+03,.8313784E+03,& + & .1202260E+04,.9148111E+03,.7624882E+03,.7661952E+03,.9820032E+03,& + & .1163158E+04,.8813333E+03,.7261740E+03,.7304250E+03,.9399991E+03,& + & .1124180E+04,.8488606E+03,.6918461E+03,.6972877E+03,.9005744E+03,& + & .1084954E+04,.8172592E+03,.6592986E+03,.6665878E+03,.8638719E+03,& + & .1045950E+04,.7865464E+03,.6286194E+03,.6380504E+03,.8294321E+03,& + & .1204456E+04,.9157270E+03,.7610818E+03,.7633951E+03,.9784831E+03,& + & .1164367E+04,.8816366E+03,.7244819E+03,.7276259E+03,.9364715E+03,& + & .1124324E+04,.8486129E+03,.6898842E+03,.6945597E+03,.8971270E+03,& + & .1084324E+04,.8165570E+03,.6571659E+03,.6638568E+03,.8604884E+03,& + & .1044694E+04,.7853529E+03,.6263972E+03,.6354464E+03,.8261775E+03,& + & .1204084E+04,.9146184E+03,.7579482E+03,.7592747E+03,.9734683E+03,& + & .1162995E+04,.8799770E+03,.7211610E+03,.7236223E+03,.9315108E+03,& + & .1122270E+04,.8466270E+03,.6864778E+03,.6906781E+03,.8923413E+03,& + & .1081628E+04,.8142783E+03,.6537748E+03,.6601480E+03,.8559108E+03,& + & .1041535E+04,.7827690E+03,.6229791E+03,.6318521E+03,.8217287E+03,& + & .1201431E+04,.9117433E+03,.7533822E+03,.7540042E+03,.9671155E+03,& + & .1159753E+04,.8768687E+03,.7166394E+03,.7186372E+03,.9254210E+03,& + & .1118355E+04,.8432577E+03,.6819604E+03,.6859134E+03,.8865933E+03,& + & .1077205E+04,.8106161E+03,.6493437E+03,.6556209E+03,.8503919E+03,& + & .1036866E+04,.7790721E+03,.6187296E+03,.6275874E+03,.8165163E+03/ + + data absb(526:700,12) / & + & .1198563E+04,.9088441E+03,.7491554E+03,.7492438E+03,.9613627E+03,& + & .1156284E+04,.8737803E+03,.7124077E+03,.7140741E+03,.9199132E+03,& + & .1114455E+04,.8399712E+03,.6778293E+03,.6816338E+03,.8814481E+03,& + & .1073022E+04,.8072052E+03,.6453367E+03,.6515614E+03,.8454321E+03,& + & .1032356E+04,.7755667E+03,.6148054E+03,.6237372E+03,.8118204E+03,& + & .1198333E+04,.9083513E+03,.7477168E+03,.7473560E+03,.9590262E+03,& + & .1155753E+04,.8731138E+03,.7109009E+03,.7122360E+03,.9176511E+03,& + & .1113496E+04,.8390696E+03,.6762632E+03,.6798170E+03,.8792408E+03,& + & .1071776E+04,.8061247E+03,.6437713E+03,.6498449E+03,.8432884E+03,& + & .1030817E+04,.7743687E+03,.6132096E+03,.6220561E+03,.8097579E+03,& + & .1201812E+04,.9109743E+03,.7497301E+03,.7489114E+03,.9607489E+03,& + & .1158859E+04,.8754611E+03,.7126895E+03,.7135931E+03,.9191682E+03,& + & .1116249E+04,.8411676E+03,.6778498E+03,.6810248E+03,.8806473E+03,& + & .1074182E+04,.8079523E+03,.6451507E+03,.6509316E+03,.8445579E+03,& + & .1033029E+04,.7760505E+03,.6144744E+03,.6230304E+03,.8108939E+03,& + & .1211130E+04,.9186048E+03,.7571510E+03,.7557283E+03,.9686341E+03,& + & .1167769E+04,.8825784E+03,.7195377E+03,.7197860E+03,.9264272E+03,& + & .1124863E+04,.8479369E+03,.6841799E+03,.6866852E+03,.8873138E+03,& + & .1082412E+04,.8143560E+03,.6510060E+03,.6560895E+03,.8507530E+03,& + & .1040908E+04,.7820519E+03,.6199358E+03,.6277981E+03,.8166320E+03,& + & .1220285E+04,.9261353E+03,.7646141E+03,.7626244E+03,.9766109E+03,& + & .1176440E+04,.8896203E+03,.7264230E+03,.7260792E+03,.9337937E+03,& + & .1133375E+04,.8546623E+03,.6905960E+03,.6924389E+03,.8940982E+03,& + & .1090677E+04,.8207879E+03,.6569885E+03,.6613756E+03,.8570661E+03,& + & .1048813E+04,.7881007E+03,.6254696E+03,.6327012E+03,.8225054E+03,& + & .1228866E+04,.9332604E+03,.7717386E+03,.7692485E+03,.9842332E+03,& + & .1184837E+04,.8964165E+03,.7330783E+03,.7321425E+03,.9408794E+03,& + & .1141425E+04,.8610630E+03,.6967646E+03,.6979977E+03,.9006456E+03,& + & .1098473E+04,.8268792E+03,.6626986E+03,.6664793E+03,.8631791E+03,& + & .1056323E+04,.7938687E+03,.6308135E+03,.6374322E+03,.8281892E+03,& + & .1241753E+04,.9440723E+03,.7828610E+03,.7798359E+03,.9964019E+03,& + & .1197417E+04,.9066817E+03,.7434365E+03,.7418632E+03,.9522524E+03,& + & .1153661E+04,.8708987E+03,.7064391E+03,.7069149E+03,.9111337E+03,& + & .1110381E+04,.8362458E+03,.6717052E+03,.6746952E+03,.8729740E+03,& + & .1067895E+04,.8028379E+03,.6392420E+03,.6449926E+03,.8372651E+03/ + + data absb(701:875,12) / & + & .1254711E+04,.9552218E+03,.7944804E+03,.7910279E+03,.1009186E+04,& + & .1210280E+04,.9173371E+03,.7543339E+03,.7521533E+03,.9642251E+03,& + & .1166182E+04,.8810139E+03,.7165982E+03,.7163206E+03,.9222282E+03,& + & .1122776E+04,.8459987E+03,.6811757E+03,.6833364E+03,.8832595E+03,& + & .1079901E+04,.8122269E+03,.6480909E+03,.6529289E+03,.8468137E+03,& + & .1267704E+04,.9665631E+03,.8063197E+03,.8024662E+03,.1022026E+04,& + & .1222982E+04,.9279730E+03,.7652524E+03,.7624963E+03,.9762665E+03,& + & .1178689E+04,.8911031E+03,.7268015E+03,.7258004E+03,.9333389E+03,& + & .1134938E+04,.8556974E+03,.6907044E+03,.6920393E+03,.8935613E+03,& + & .1091744E+04,.8215054E+03,.6569768E+03,.6609780E+03,.8565207E+03,& + & .1282885E+04,.9799862E+03,.8205225E+03,.8164768E+03,.1037659E+04,& + & .1238160E+04,.9407046E+03,.7785501E+03,.7751742E+03,.9909163E+03,& + & .1193461E+04,.9032104E+03,.7391944E+03,.7374586E+03,.9470329E+03,& + & .1149466E+04,.8673209E+03,.7023116E+03,.7027833E+03,.9062086E+03,& + & .1106044E+04,.8327209E+03,.6678128E+03,.6708431E+03,.8683165E+03,& + & .1299221E+04,.9946371E+03,.8360635E+03,.8320461E+03,.1054652E+04,& + & .1254105E+04,.9544361E+03,.7930175E+03,.7891647E+03,.1006958E+04,& + & .1209314E+04,.9163157E+03,.7527076E+03,.7503398E+03,.9620928E+03,& + & .1165150E+04,.8800178E+03,.7151041E+03,.7146356E+03,.9201686E+03,& + & .1121407E+04,.8448306E+03,.6796764E+03,.6817394E+03,.8813213E+03,& + & .1315203E+04,.1009411E+04,.8519211E+03,.8481780E+03,.1072024E+04,& + & .1270148E+04,.9683874E+03,.8077450E+03,.8035704E+03,.1023229E+04,& + & .1225178E+04,.9296125E+03,.7664897E+03,.7634566E+03,.9773360E+03,& + & .1180684E+04,.8926430E+03,.7280109E+03,.7267010E+03,.9343522E+03,& + & .1136746E+04,.8570580E+03,.6917330E+03,.6928240E+03,.8944515E+03,& + & .1332014E+04,.1025376E+04,.8690997E+03,.8658147E+03,.1090797E+04,& + & .1287083E+04,.9833984E+03,.8237334E+03,.8194241E+03,.1040908E+04,& + & .1241959E+04,.9438288E+03,.7814714E+03,.7777789E+03,.9938697E+03,& + & .1197174E+04,.9061941E+03,.7419541E+03,.7398805E+03,.9497877E+03,& + & .1152918E+04,.8700812E+03,.7048184E+03,.7049556E+03,.9087731E+03,& + & .1350647E+04,.1043564E+04,.8888305E+03,.8860745E+03,.1112065E+04,& + & .1305779E+04,.1000456E+04,.8419893E+03,.8378345E+03,.1060921E+04,& + & .1260705E+04,.9599420E+03,.7984917E+03,.7943099E+03,.1012757E+04,& + & .1215666E+04,.9215564E+03,.7578604E+03,.7550366E+03,.9674587E+03,& + & .1171119E+04,.8847872E+03,.7197368E+03,.7188825E+03,.9251420E+03/ + + data absb(876:1050,12) / & + & .1369025E+04,.1061988E+04,.9090576E+03,.9070507E+03,.1133822E+04,& + & .1324283E+04,.1017792E+04,.8607146E+03,.8569957E+03,.1081438E+04,& + & .1279221E+04,.9763247E+03,.8159408E+03,.8115038E+03,.1032081E+04,& + & .1234106E+04,.9370840E+03,.7741603E+03,.7706394E+03,.9855998E+03,& + & .1189255E+04,.8996323E+03,.7349893E+03,.7332176E+03,.9419966E+03,& + & .1387296E+04,.1080897E+04,.9299250E+03,.9288068E+03,.1156040E+04,& + & .1342857E+04,.1035650E+04,.8800130E+03,.8768348E+03,.1102421E+04,& + & .1297820E+04,.9930678E+03,.8338259E+03,.8293976E+03,.1051801E+04,& + & .1252579E+04,.9528599E+03,.7908416E+03,.7867574E+03,.1004167E+04,& + & .1207574E+04,.9146924E+03,.7505619E+03,.7480415E+03,.9593335E+03,& + & .1404104E+04,.1098935E+04,.9500783E+03,.9498735E+03,.1177271E+04,& + & .1360008E+04,.1052670E+04,.8986275E+03,.8960550E+03,.1122511E+04,& + & .1315196E+04,.1009091E+04,.8510987E+03,.8469719E+03,.1070745E+04,& + & .1269965E+04,.9680021E+03,.8068947E+03,.8024578E+03,.1021945E+04,& + & .1224670E+04,.9290678E+03,.7655748E+03,.7624022E+03,.9760562E+03,& + & .1420396E+04,.1116667E+04,.9703151E+03,.9709136E+03,.1198267E+04,& + & .1376519E+04,.1069496E+04,.9171148E+03,.9153343E+03,.1142380E+04,& + & .1331895E+04,.1024943E+04,.8682037E+03,.8645664E+03,.1089458E+04,& + & .1286713E+04,.9828640E+03,.8228042E+03,.8182606E+03,.1039599E+04,& + & .1241514E+04,.9432594E+03,.7805968E+03,.7767631E+03,.9926584E+03,& + & .1436295E+04,.1134602E+04,.9911820E+03,.9925055E+03,.1219679E+04,& + & .1392861E+04,.1086682E+04,.9361507E+03,.9351807E+03,.1162507E+04,& + & .1348464E+04,.1041116E+04,.8857605E+03,.8826630E+03,.1108509E+04,& + & .1303445E+04,.9981438E+03,.8391267E+03,.8346717E+03,.1057512E+04,& + & .1258155E+04,.9576321E+03,.7957736E+03,.7914987E+03,.1009530E+04,& + & .1451947E+04,.1152803E+04,.1012912E+04,.1014725E+04,.1241375E+04,& + & .1409171E+04,.1104184E+04,.9558739E+03,.9558293E+03,.1183310E+04,& + & .1365042E+04,.1057601E+04,.9039098E+03,.9014495E+03,.1128065E+04,& + & .1320122E+04,.1013646E+04,.8559028E+03,.8518298E+03,.1075944E+04,& + & .1274918E+04,.9723353E+03,.8114299E+03,.8068514E+03,.1026857E+04,& + & .1466066E+04,.1169745E+04,.1033600E+04,.1035678E+04,.1261517E+04,& + & .1423885E+04,.1120363E+04,.9744091E+03,.9750701E+03,.1202414E+04,& + & .1380086E+04,.1073062E+04,.9208922E+03,.9191581E+03,.1146254E+04,& + & .1335390E+04,.1028184E+04,.8716013E+03,.8680259E+03,.1093132E+04,& + & .1290197E+04,.9859694E+03,.8260174E+03,.8214000E+03,.1043057E+04/ + + data absb(1051:1175,12) / & + & .1479052E+04,.1186138E+04,.1053992E+04,.1056277E+04,.1281061E+04,& + & .1437721E+04,.1136174E+04,.9928663E+03,.9941031E+03,.1221167E+04,& + & .1394340E+04,.1088094E+04,.9376415E+03,.9367024E+03,.1164059E+04,& + & .1349933E+04,.1042434E+04,.8871475E+03,.8840194E+03,.1109960E+04,& + & .1304838E+04,.9993418E+03,.8403647E+03,.8358995E+03,.1058827E+04,& + & .1492071E+04,.1202807E+04,.1075082E+04,.1077418E+04,.1300751E+04,& + & .1451378E+04,.1152078E+04,.1011888E+04,.1013598E+04,.1240207E+04,& + & .1408590E+04,.1103420E+04,.9548463E+03,.9546446E+03,.1182081E+04,& + & .1364310E+04,.1056805E+04,.9029595E+03,.9004074E+03,.1127003E+04,& + & .1319414E+04,.1012901E+04,.8550197E+03,.8508617E+03,.1074911E+04,& + & .1504643E+04,.1219744E+04,.1096579E+04,.1098934E+04,.1320376E+04,& + & .1464791E+04,.1168191E+04,.1031579E+04,.1033563E+04,.1259497E+04,& + & .1422597E+04,.1118810E+04,.9725173E+03,.9730206E+03,.1200352E+04,& + & .1378559E+04,.1071486E+04,.9191235E+03,.9172829E+03,.1144372E+04,& + & .1333898E+04,.1026715E+04,.8699929E+03,.8663091E+03,.1091312E+04,& + & .1516339E+04,.1236030E+04,.1117522E+04,.1119831E+04,.1339023E+04,& + & .1477239E+04,.1183650E+04,.1050741E+04,.1052932E+04,.1277904E+04,& + & .1435679E+04,.1133650E+04,.9897694E+03,.9909248E+03,.1218096E+04,& + & .1392107E+04,.1085680E+04,.9348858E+03,.9337357E+03,.1161095E+04,& + & .1347658E+04,.1040131E+04,.8845784E+03,.8813290E+03,.1107099E+04,& + & .1520825E+04,.1242563E+04,.1126048E+04,.1128336E+04,.1346460E+04,& + & .1482173E+04,.1189885E+04,.1058578E+04,.1060811E+04,.1285327E+04,& + & .1440948E+04,.1139665E+04,.9968499E+03,.9981671E+03,.1225222E+04,& + & .1397470E+04,.1091462E+04,.9413190E+03,.9405053E+03,.1167923E+04,& + & .1353151E+04,.1045578E+04,.8905298E+03,.8874634E+03,.1113520E+04/ + +! --- + data forref(1:4,1:12) / .5532580E-03,.5554860E-03,.6013390E-03,& + & .7082800E-03,.1585580E-02,.1629570E-02,.2049910E-02,.4758810E-02,& + & .7725420E-02,.7845620E-02,.1119790E-01,.2290160E-01,.2550970E-01,& + & .2562720E-01,.2706910E-01,.2595050E-01,.3232630E-01,.3244950E-01,& + & .3055350E-01,.2639930E-01,.3557280E-01,.3564191E-01,.3329601E-01,& + & .2956313E-01,.3784510E-01,.3753410E-01,.3743690E-01,.3203340E-01,& + & .4098704E-01,.3991769E-01,.3953723E-01,.3197576E-01,.4282540E-01,& + & .4411510E-01,.4088870E-01,.3270770E-01,.4529070E-01,.4526648E-01,& + & .4032414E-01,.3589280E-01,.4839280E-01,.4772840E-01,.3806840E-01,& + & .3879400E-01,.5074618E-01,.4940565E-01,.4711472E-01,.3831108E-01/ + + data selfref(1:10,1:12) / & + & .1605370E-01,.1490380E-01,.1383630E-01,.1284520E-01,.1192510E-01,& + & .1107090E-01,.1027790E-01,.9541750E-02,.8858290E-02,.8223790E-02,& + & .3657530E-01,.3422670E-01,.3202880E-01,.2997200E-01,.2804740E-01,& + & .2624630E-01,.2456090E-01,.2298370E-01,.2150780E-01,.2012670E-01,& + & .1274190E+00,.1185530E+00,.1103040E+00,.1026290E+00,.9548830E-01,& + & .8884420E-01,.8266240E-01,.7691070E-01,.7155930E-01,.6658020E-01,& + & .3786870E+00,.3489610E+00,.3215680E+00,.2963250E+00,.2730640E+00,& + & .2516290E+00,.2318760E+00,.2136740E+00,.1969010E+00,.1814440E+00,& + & .4728220E+00,.4350180E+00,.4002360E+00,.3682360E+00,.3387940E+00,& + & .3117060E+00,.2867830E+00,.2638540E+00,.2427570E+00,.2233480E+00,& + & .5168017E+00,.4753661E+00,.4372531E+00,.4021962E+00,.3699493E+00,& + & .3402876E+00,.3130049E+00,.2879097E+00,.2648259E+00,.2435933E+00,& + & .5402220E+00,.4977460E+00,.4586100E+00,.4225510E+00,.3893270E+00,& + & .3587160E+00,.3305110E+00,.3045240E+00,.2805800E+00,.2585190E+00,& + & .5700865E+00,.5267717E+00,.4867481E+00,.4497659E+00,.4155940E+00,& + & .3840184E+00,.3548416E+00,.3278825E+00,.3029720E+00,.2799538E+00,& + & .6451760E+00,.5889570E+00,.5376360E+00,.4907880E+00,.4480220E+00,& + & .4089820E+00,.3733440E+00,.3408120E+00,.3111140E+00,.2840040E+00,& + & .6556933E+00,.6013742E+00,.5515585E+00,.5058718E+00,.4639719E+00,& + & .4255448E+00,.3903026E+00,.3579808E+00,.3283371E+00,.3011502E+00,& + & .6925540E+00,.6355740E+00,.5832820E+00,.5352930E+00,.4912510E+00,& + & .4508340E+00,.4137410E+00,.3797010E+00,.3484610E+00,.3197910E+00,& + & .7229700E+00,.6637789E+00,.6094446E+00,.5595658E+00,.5137786E+00,& + & .4717450E+00,.4331576E+00,.3977321E+00,.3652099E+00,.3353523E+00/ + +!........................................! + end module module_radsw_kgb17 ! +!========================================! + + +!> This module sets up absorption coeffients for band 18: 4000-4650 +!! cm-1 (low - h2o,ch4; high - ch4) +!========================================! + module module_radsw_kgb18 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG18 + +! + implicit none +! + private +! +!> msa18=585 + integer, public :: MSA18 +!> msb18=235 + integer, public :: MSB18 +!> msf18=10 + integer, public :: MSF18 +!> mfr18=3 + integer, public :: MFR18 + parameter (MSA18=585, MSB18=235, MSF18=10, MFR18=3) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 8). + real (kind=kind_phys), public :: selfref(MSF18,NG18) + +!> the array absa(585,NG18) (ka(9,5,13,NG18)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds +!! to different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, Jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 8, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA18,NG18) + +!> the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 8, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB18,NG18) + + real (kind=kind_phys), public :: forref(MFR18,NG18) + +!> rayleigh extinction coefficient at \f$v=4325 cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 1.39e-09 + + + data absa( 1:180, 1) / & + & .1481300E-04,.3984200E-04,.4336200E-04,.4309500E-04,.3981100E-04,& + & .3499400E-04,.2898400E-04,.2060900E-04,.1884500E-05,.1443200E-04,& + & .3874900E-04,.4211900E-04,.4183400E-04,.3890000E-04,.3436500E-04,& + & .2857100E-04,.2050300E-04,.1471500E-05,.1396900E-04,.3766600E-04,& + & .4094200E-04,.4070300E-04,.3798200E-04,.3373100E-04,.2815800E-04,& + & .2035100E-04,.1084200E-05,.1336700E-04,.3660500E-04,.3972900E-04,& + & .3952900E-04,.3703300E-04,.3309600E-04,.2769000E-04,.2015400E-04,& + & .7870200E-06,.1276500E-04,.3558400E-04,.3853600E-04,.3836100E-04,& + & .3607300E-04,.3238400E-04,.2724200E-04,.1993200E-04,.5829600E-06,& + & .1229900E-04,.3417900E-04,.3740500E-04,.3753500E-04,.3471400E-04,& + & .3033500E-04,.2489200E-04,.1752400E-04,.1330100E-05,.1206400E-04,& + & .3322500E-04,.3635700E-04,.3651200E-04,.3387000E-04,.2978900E-04,& + & .2457800E-04,.1743500E-04,.1021700E-05,.1169700E-04,.3230100E-04,& + & .3531600E-04,.3548100E-04,.3304900E-04,.2922600E-04,.2423300E-04,& + & .1730400E-04,.7215200E-06,.1120900E-04,.3139500E-04,.3426300E-04,& + & .3443600E-04,.3217300E-04,.2861000E-04,.2384700E-04,.1716100E-04,& + & .5178700E-06,.1070600E-04,.3049600E-04,.3331100E-04,.3339600E-04,& + & .3129500E-04,.2800200E-04,.2344500E-04,.1697100E-04,.4023000E-06,& + & .1027100E-04,.2927300E-04,.3204900E-04,.3236500E-04,.2985700E-04,& + & .2617100E-04,.2135200E-04,.1481400E-04,.8047000E-06,.1005800E-04,& + & .2845800E-04,.3119600E-04,.3144000E-04,.2913300E-04,.2564000E-04,& + & .2105600E-04,.1475600E-04,.5301000E-06,.9817200E-05,.2765100E-04,& + & .3035200E-04,.3060900E-04,.2839600E-04,.2511000E-04,.2073000E-04,& + & .1465500E-04,.3865200E-06,.9457700E-05,.2687400E-04,.2947500E-04,& + & .2974900E-04,.2766900E-04,.2455300E-04,.2040000E-04,.1453600E-04,& + & .3323600E-06,.9050800E-05,.2612800E-04,.2863100E-04,.2883400E-04,& + & .2695200E-04,.2401500E-04,.2004500E-04,.1438200E-04,.3065900E-06,& + & .8608100E-05,.2489700E-04,.2731700E-04,.2763200E-04,.2546500E-04,& + & .2232800E-04,.1811200E-04,.1246800E-04,.3928600E-06,.8379300E-05,& + & .2427300E-04,.2659000E-04,.2686500E-04,.2487600E-04,.2186700E-04,& + & .1784900E-04,.1242000E-04,.3226600E-06,.8229600E-05,.2358400E-04,& + & .2586900E-04,.2615500E-04,.2425500E-04,.2140300E-04,.1757900E-04,& + & .1233800E-04,.3077500E-06,.7973100E-05,.2291500E-04,.2516600E-04,& + & .2543500E-04,.2362700E-04,.2091700E-04,.1728200E-04,.1224200E-04,& + & .3041800E-06,.7655300E-05,.2225900E-04,.2444000E-04,.2467300E-04,& + & .2300300E-04,.2043700E-04,.1698400E-04,.1211200E-04,.3063800E-06/ + + data absa(181:315, 1) / & + & .7225900E-05,.2108900E-04,.2317700E-04,.2341900E-04,.2158400E-04,& + & .1892600E-04,.1525100E-04,.1041700E-04,.2517000E-06,.7021500E-05,& + & .2056700E-04,.2254100E-04,.2278800E-04,.2110200E-04,.1852600E-04,& + & .1504900E-04,.1037900E-04,.2595800E-06,.6849000E-05,.2001800E-04,& + & .2193800E-04,.2220600E-04,.2057900E-04,.1813900E-04,.1480600E-04,& + & .1031300E-04,.2666600E-06,.6697300E-05,.1944400E-04,.2134000E-04,& + & .2161500E-04,.2007000E-04,.1772800E-04,.1455400E-04,.1023900E-04,& + & .2858900E-06,.6480800E-05,.1888300E-04,.2073800E-04,.2099400E-04,& + & .1954600E-04,.1730400E-04,.1430600E-04,.1014800E-04,.3088600E-06,& + & .6072700E-05,.1779400E-04,.1960900E-04,.1976900E-04,.1822800E-04,& + & .1594600E-04,.1279300E-04,.8655900E-05,.1855900E-06,.5894900E-05,& + & .1739000E-04,.1905900E-04,.1924400E-04,.1782000E-04,.1564700E-04,& + & .1262600E-04,.8635400E-05,.1954400E-06,.5726800E-05,.1693500E-04,& + & .1856400E-04,.1872400E-04,.1740200E-04,.1530400E-04,.1243300E-04,& + & .8588200E-05,.2203300E-06,.5624300E-05,.1645900E-04,.1805400E-04,& + & .1826300E-04,.1698400E-04,.1497100E-04,.1221500E-04,.8526800E-05,& + & .2507200E-06,.5458400E-05,.1598400E-04,.1754800E-04,.1777300E-04,& + & .1655100E-04,.1460100E-04,.1200400E-04,.8456800E-05,.2811000E-06,& + & .5062400E-05,.1496300E-04,.1648200E-04,.1661100E-04,.1533900E-04,& + & .1333300E-04,.1065600E-04,.7157000E-05,.1345300E-06,.4942800E-05,& + & .1463600E-04,.1604000E-04,.1618100E-04,.1499200E-04,.1314400E-04,& + & .1053300E-04,.7153200E-05,.1562000E-06,.4795500E-05,.1425600E-04,& + & .1561100E-04,.1573500E-04,.1464300E-04,.1286500E-04,.1039000E-04,& + & .7124800E-05,.1857100E-06,.4674300E-05,.1387600E-04,.1521300E-04,& + & .1534200E-04,.1429300E-04,.1257600E-04,.1021500E-04,.7073500E-05,& + & .2138200E-06,.4570800E-05,.1347300E-04,.1478200E-04,.1494700E-04,& + & .1393300E-04,.1227400E-04,.1003600E-04,.7017700E-05,.2441900E-06/ + + data absa(316:450, 1) / & + & .4228900E-05,.1252800E-04,.1381700E-04,.1392200E-04,.1286700E-04,& + & .1112600E-04,.8846800E-05,.5901000E-05,.1060000E-06,.4131900E-05,& + & .1228600E-04,.1348000E-04,.1358200E-04,.1258400E-04,.1097300E-04,& + & .8764400E-05,.5904900E-05,.1295100E-06,.4031700E-05,.1199600E-04,& + & .1311600E-04,.1320600E-04,.1229500E-04,.1078600E-04,.8653700E-05,& + & .5889800E-05,.1573100E-06,.3910700E-05,.1166600E-04,.1277100E-04,& + & .1287000E-04,.1201000E-04,.1054600E-04,.8524400E-05,.5853600E-05,& + & .1871600E-06,.3838400E-05,.1134600E-04,.1243500E-04,.1254900E-04,& + & .1170600E-04,.1028900E-04,.8375600E-05,.5810400E-05,.2167900E-06,& + & .3524000E-05,.1041800E-04,.1155800E-04,.1168700E-04,.1074800E-04,& + & .9230500E-05,.7319800E-05,.4851400E-05,.1017600E-06,.3447800E-05,& + & .1029600E-04,.1129600E-04,.1136900E-04,.1053200E-04,.9137500E-05,& + & .7273700E-05,.4863900E-05,.1269500E-06,.3371800E-05,.1006800E-04,& + & .1099600E-04,.1106300E-04,.1029000E-04,.8995700E-05,.7184400E-05,& + & .4858300E-05,.1548200E-06,.3280100E-05,.9799000E-05,.1071200E-04,& + & .1076200E-04,.1005600E-04,.8825500E-05,.7090700E-05,.4836400E-05,& + & .1812300E-06,.3196000E-05,.9535000E-05,.1042700E-04,.1050100E-04,& + & .9805600E-05,.8615700E-05,.6972300E-05,.4801000E-05,.2073800E-06,& + & .2919700E-05,.8618300E-05,.9610000E-05,.9744800E-05,.8918700E-05,& + & .7635400E-05,.6031800E-05,.3973300E-05,.1031000E-06,.2867700E-05,& + & .8556500E-05,.9419100E-05,.9468200E-05,.8765300E-05,.7572500E-05,& + & .6008900E-05,.3995600E-05,.1295100E-06,.2803600E-05,.8412100E-05,& + & .9190200E-05,.9225100E-05,.8581100E-05,.7465300E-05,.5945200E-05,& + & .3996700E-05,.1568400E-06,.2742000E-05,.8203500E-05,.8944000E-05,& + & .8974800E-05,.8381700E-05,.7342200E-05,.5872500E-05,.3984400E-05,& + & .1856400E-06,.2659600E-05,.7973900E-05,.8707400E-05,.8750800E-05,& + & .8178400E-05,.7178100E-05,.5781500E-05,.3956900E-05,.2147600E-06/ + + data absa(451:585, 1) / & + & .2398800E-05,.7113500E-05,.7912100E-05,.8011800E-05,.7337000E-05,& + & .6284400E-05,.4961000E-05,.3264100E-05,.9169700E-07,.2355200E-05,& + & .7058700E-05,.7751900E-05,.7782100E-05,.7211300E-05,.6229700E-05,& + & .4940700E-05,.3281500E-05,.1130700E-06,.2304600E-05,.6936700E-05,& + & .7566200E-05,.7579000E-05,.7063100E-05,.6140900E-05,.4886700E-05,& + & .3281200E-05,.1371500E-06,.2255700E-05,.6763200E-05,.7364000E-05,& + & .7377200E-05,.6897200E-05,.6038100E-05,.4825400E-05,.3270500E-05,& + & .1643600E-06,.2189900E-05,.6574800E-05,.7169500E-05,.7194600E-05,& + & .6729500E-05,.5902200E-05,.4748800E-05,.3247600E-05,.1902500E-06,& + & .1969900E-05,.5867000E-05,.6507500E-05,.6580800E-05,.6030000E-05,& + & .5166500E-05,.4074900E-05,.2678800E-05,.7710000E-07,.1934800E-05,& + & .5814600E-05,.6373000E-05,.6389100E-05,.5926000E-05,.5119600E-05,& + & .4057700E-05,.2692600E-05,.9569300E-07,.1894700E-05,.5713400E-05,& + & .6220700E-05,.6223800E-05,.5809000E-05,.5045900E-05,.4011300E-05,& + & .2691600E-05,.1157200E-06,.1855200E-05,.5570900E-05,.6052200E-05,& + & .6061100E-05,.5669300E-05,.4959400E-05,.3960600E-05,.2682400E-05,& + & .1379700E-06,.1804000E-05,.5413700E-05,.5893500E-05,.5909600E-05,& + & .5529400E-05,.4844300E-05,.3897700E-05,.2663300E-05,.1588400E-06,& + & .1616700E-05,.4827200E-05,.5347500E-05,.5398300E-05,.4950300E-05,& + & .4241300E-05,.3343100E-05,.2195600E-05,.6138100E-07,.1589500E-05,& + & .4780900E-05,.5234200E-05,.5240900E-05,.4865200E-05,.4202100E-05,& + & .3326300E-05,.2207200E-05,.7638200E-07,.1558200E-05,.4698200E-05,& + & .5105500E-05,.5105800E-05,.4771600E-05,.4140600E-05,.3288600E-05,& + & .2205800E-05,.9308300E-07,.1524200E-05,.4583100E-05,.4969600E-05,& + & .4973500E-05,.4653400E-05,.4067800E-05,.3246900E-05,.2196900E-05,& + & .1121100E-06,.1485900E-05,.4449200E-05,.4839200E-05,.4847900E-05,& + & .4537800E-05,.3968900E-05,.3193300E-05,.2181300E-05,.1297000E-06/ + + data absa( 1:180, 2) / & + & .1013800E-03,.2045600E-03,.2211700E-03,.2194800E-03,.2080500E-03,& + & .1837300E-03,.1499900E-03,.9538200E-04,.3321300E-05,.1014100E-03,& + & .2088900E-03,.2245600E-03,.2222300E-03,.2091200E-03,.1846700E-03,& + & .1506000E-03,.9571300E-04,.2847900E-05,.1012500E-03,.2122300E-03,& + & .2271200E-03,.2238800E-03,.2098300E-03,.1851300E-03,.1510000E-03,& + & .9588100E-04,.2633800E-05,.1010500E-03,.2144200E-03,.2286300E-03,& + & .2242100E-03,.2104600E-03,.1854000E-03,.1506000E-03,.9579800E-04,& + & .2763800E-05,.1004000E-03,.2161200E-03,.2289900E-03,.2241600E-03,& + & .2104600E-03,.1857000E-03,.1500100E-03,.9556900E-04,.2931300E-05,& + & .8963900E-04,.1779700E-03,.1928400E-03,.1898600E-03,.1782400E-03,& + & .1578900E-03,.1290600E-03,.8352400E-04,.2392600E-05,.8949900E-04,& + & .1814400E-03,.1956300E-03,.1922700E-03,.1794100E-03,.1584400E-03,& + & .1296100E-03,.8363200E-04,.2196900E-05,.8941100E-04,.1840100E-03,& + & .1975300E-03,.1935000E-03,.1799900E-03,.1588300E-03,.1298900E-03,& + & .8357700E-04,.2315800E-05,.8884100E-04,.1854100E-03,.1987200E-03,& + & .1939800E-03,.1805300E-03,.1590700E-03,.1297200E-03,.8339600E-04,& + & .2376000E-05,.8794900E-04,.1865900E-03,.1990200E-03,.1940700E-03,& + & .1807300E-03,.1591000E-03,.1293700E-03,.8312000E-04,.2524700E-05,& + & .7746600E-04,.1526400E-03,.1670400E-03,.1634200E-03,.1530000E-03,& + & .1349900E-03,.1100700E-03,.7188100E-04,.1783900E-05,.7748300E-04,& + & .1561100E-03,.1695000E-03,.1655100E-03,.1540800E-03,.1358000E-03,& + & .1105500E-03,.7202000E-04,.1856400E-05,.7714200E-04,.1586700E-03,& + & .1711200E-03,.1667200E-03,.1548100E-03,.1361600E-03,.1107700E-03,& + & .7192200E-04,.2022800E-05,.7646000E-04,.1605800E-03,.1718600E-03,& + & .1671700E-03,.1551900E-03,.1364100E-03,.1106000E-03,.7177500E-04,& + & .2171700E-05,.7551000E-04,.1615800E-03,.1721000E-03,.1673000E-03,& + & .1552100E-03,.1364900E-03,.1102200E-03,.7151600E-04,.2314000E-05,& + & .6593100E-04,.1294000E-03,.1429500E-03,.1400500E-03,.1309500E-03,& + & .1149400E-03,.9365600E-04,.6116700E-04,.1709400E-05,.6609000E-04,& + & .1326900E-03,.1454200E-03,.1423300E-03,.1320100E-03,.1155800E-03,& + & .9397500E-04,.6143600E-04,.1852700E-05,.6563000E-04,.1353200E-03,& + & .1471700E-03,.1436400E-03,.1326600E-03,.1160400E-03,.9412600E-04,& + & .6146700E-04,.1957600E-05,.6497100E-04,.1370800E-03,.1481800E-03,& + & .1442700E-03,.1330400E-03,.1161600E-03,.9415200E-04,.6133400E-04,& + & .2061400E-05,.6412200E-04,.1383400E-03,.1486400E-03,.1445100E-03,& + & .1331200E-03,.1163800E-03,.9395500E-04,.6116200E-04,.2164000E-05/ + + data absa(181:315, 2) / & + & .5559400E-04,.1083000E-03,.1206800E-03,.1186500E-03,.1112700E-03,& + & .9792500E-04,.7920800E-04,.5184200E-04,.1595400E-05,.5566900E-04,& + & .1111700E-03,.1229900E-03,.1209100E-03,.1124800E-03,.9864300E-04,& + & .7943300E-04,.5212700E-04,.1696600E-05,.5543000E-04,.1134500E-03,& + & .1247800E-03,.1223500E-03,.1133200E-03,.9911700E-04,.7982300E-04,& + & .5228600E-04,.1830400E-05,.5480000E-04,.1154300E-03,.1260100E-03,& + & .1230400E-03,.1138900E-03,.9934600E-04,.7993500E-04,.5227500E-04,& + & .1947900E-05,.5402700E-04,.1166500E-03,.1266000E-03,.1233900E-03,& + & .1141000E-03,.9953500E-04,.7984000E-04,.5216800E-04,.2058300E-05,& + & .4650000E-04,.8988700E-04,.1004800E-03,.9916100E-04,.9313600E-04,& + & .8227900E-04,.6687200E-04,.4361700E-04,.1473000E-05,.4663200E-04,& + & .9244400E-04,.1027100E-03,.1012300E-03,.9455900E-04,.8313500E-04,& + & .6720400E-04,.4404600E-04,.1621500E-05,.4649000E-04,.9441500E-04,& + & .1044600E-03,.1026900E-03,.9538700E-04,.8367600E-04,.6757900E-04,& + & .4427900E-04,.1735800E-05,.4600400E-04,.9619000E-04,.1057000E-03,& + & .1034600E-03,.9588300E-04,.8403800E-04,.6775300E-04,.4434800E-04,& + & .1809600E-05,.4536200E-04,.9751100E-04,.1064500E-03,.1038400E-03,& + & .9619700E-04,.8434700E-04,.6775800E-04,.4430500E-04,.1888200E-05,& + & .3859700E-04,.7401900E-04,.8288200E-04,.8180700E-04,.7693600E-04,& + & .6827800E-04,.5574400E-04,.3650700E-04,.1340000E-05,.3872800E-04,& + & .7635300E-04,.8503000E-04,.8382200E-04,.7852300E-04,.6922100E-04,& + & .5619900E-04,.3693200E-04,.1476600E-05,.3868800E-04,.7816400E-04,& + & .8669100E-04,.8526900E-04,.7942400E-04,.6984900E-04,.5650700E-04,& + & .3721100E-04,.1607700E-05,.3839900E-04,.7965400E-04,.8788200E-04,& + & .8614500E-04,.7991700E-04,.7021400E-04,.5669800E-04,.3730200E-04,& + & .1736500E-05,.3789900E-04,.8101200E-04,.8870600E-04,.8658900E-04,& + & .8025900E-04,.7042900E-04,.5681000E-04,.3728700E-04,.1859500E-05/ + + data absa(316:450, 2) / & + & .3195900E-04,.6067100E-04,.6796300E-04,.6705300E-04,.6305700E-04,& + & .5628700E-04,.4618700E-04,.3029800E-04,.1207100E-05,.3206200E-04,& + & .6275300E-04,.6989200E-04,.6894100E-04,.6462400E-04,.5718700E-04,& + & .4656600E-04,.3068700E-04,.1358200E-05,.3209800E-04,.6443500E-04,& + & .7142300E-04,.7035900E-04,.6564600E-04,.5788200E-04,.4689700E-04,& + & .3099300E-04,.1521700E-05,.3195600E-04,.6575800E-04,.7265000E-04,& + & .7127500E-04,.6627500E-04,.5829800E-04,.4710000E-04,.3107900E-04,& + & .1679400E-05,.3158400E-04,.6691600E-04,.7350200E-04,.7181900E-04,& + & .6661100E-04,.5850500E-04,.4724300E-04,.3108800E-04,.1825000E-05,& + & .2635500E-04,.4947200E-04,.5541500E-04,.5458400E-04,.5136100E-04,& + & .4613500E-04,.3802700E-04,.2498300E-04,.1354900E-05,.2647200E-04,& + & .5130200E-04,.5716500E-04,.5641700E-04,.5293600E-04,.4704800E-04,& + & .3841700E-04,.2534700E-04,.1494100E-05,.2654500E-04,.5286600E-04,& + & .5856300E-04,.5777600E-04,.5398800E-04,.4770600E-04,.3873900E-04,& + & .2563800E-04,.1656300E-05,.2646900E-04,.5410500E-04,.5974900E-04,& + & .5874600E-04,.5466800E-04,.4816100E-04,.3897000E-04,.2574400E-04,& + & .1826200E-05,.2624800E-04,.5507900E-04,.6061900E-04,.5931700E-04,& + & .5509900E-04,.4843500E-04,.3911500E-04,.2577800E-04,.2023800E-05,& + & .2163100E-04,.4029700E-04,.4517000E-04,.4429800E-04,.4187600E-04,& + & .3769000E-04,.3121200E-04,.2055200E-04,.1632800E-05,.2181400E-04,& + & .4189600E-04,.4668100E-04,.4606500E-04,.4322700E-04,.3860800E-04,& + & .3161400E-04,.2085700E-04,.1861000E-05,.2186400E-04,.4324700E-04,& + & .4794500E-04,.4732700E-04,.4427300E-04,.3920100E-04,.3189400E-04,& + & .2111900E-04,.2077500E-05,.2183500E-04,.4438600E-04,.4898600E-04,& + & .4822800E-04,.4491600E-04,.3963700E-04,.3209300E-04,.2122800E-04,& + & .2254100E-05,.2172800E-04,.4526300E-04,.4980400E-04,.4881800E-04,& + & .4540900E-04,.3995000E-04,.3226900E-04,.2129000E-04,.2452500E-05/ + + data absa(451:585, 2) / & + & .1782300E-04,.3337800E-04,.3733700E-04,.3661900E-04,.3459800E-04,& + & .3111300E-04,.2576100E-04,.1695600E-04,.1504200E-05,.1797000E-04,& + & .3467900E-04,.3858900E-04,.3806500E-04,.3569500E-04,.3186900E-04,& + & .2604400E-04,.1721400E-04,.1684700E-05,.1799700E-04,.3579100E-04,& + & .3961900E-04,.3909700E-04,.3653900E-04,.3237400E-04,.2629800E-04,& + & .1742800E-04,.1888700E-05,.1796700E-04,.3671700E-04,.4046300E-04,& + & .3982100E-04,.3707100E-04,.3271600E-04,.2646100E-04,.1749600E-04,& + & .2054600E-05,.1786800E-04,.3742300E-04,.4112400E-04,.4030400E-04,& + & .3747300E-04,.3297100E-04,.2661200E-04,.1753200E-04,.2224000E-05,& + & .1466500E-04,.2760500E-04,.3081100E-04,.3025000E-04,.2852500E-04,& + & .2564400E-04,.2118600E-04,.1395500E-04,.1258800E-05,.1477500E-04,& + & .2865500E-04,.3185100E-04,.3140800E-04,.2941800E-04,.2626100E-04,& + & .2143000E-04,.1417200E-04,.1418100E-05,.1479900E-04,.2957100E-04,& + & .3268700E-04,.3224200E-04,.3009300E-04,.2668300E-04,.2163600E-04,& + & .1433800E-04,.1561900E-05,.1477700E-04,.3032500E-04,.3337100E-04,& + & .3282600E-04,.3055300E-04,.2694500E-04,.2177500E-04,.1438000E-04,& + & .1691700E-05,.1468500E-04,.3090400E-04,.3390700E-04,.3321400E-04,& + & .3087500E-04,.2715800E-04,.2188300E-04,.1441400E-04,.1842300E-05,& + & .1204400E-04,.2277200E-04,.2537500E-04,.2492600E-04,.2345800E-04,& + & .2105900E-04,.1738700E-04,.1145700E-04,.9912200E-06,.1212800E-04,& + & .2363700E-04,.2624900E-04,.2584200E-04,.2418700E-04,.2158200E-04,& + & .1759000E-04,.1163600E-04,.1103700E-05,.1215200E-04,.2438600E-04,& + & .2691000E-04,.2653100E-04,.2473100E-04,.2192300E-04,.1776000E-04,& + & .1175500E-04,.1202600E-05,.1213000E-04,.2499600E-04,.2746400E-04,& + & .2700600E-04,.2511300E-04,.2213800E-04,.1787400E-04,.1179700E-04,& + & .1302800E-05,.1205000E-04,.2547400E-04,.2789500E-04,.2729700E-04,& + & .2537300E-04,.2230200E-04,.1794800E-04,.1181700E-04,.1401000E-05/ + + data absa( 1:180, 3) / & + & .3682300E-03,.4961300E-03,.5181700E-03,.5053800E-03,.4571100E-03,& + & .3960500E-03,.3148600E-03,.2147400E-03,.1093200E-04,.3700800E-03,& + & .5077800E-03,.5336100E-03,.5177800E-03,.4699500E-03,.4062900E-03,& + & .3230900E-03,.2187800E-03,.1142100E-04,.3698900E-03,.5181200E-03,& + & .5469900E-03,.5292200E-03,.4803600E-03,.4155900E-03,.3296500E-03,& + & .2222600E-03,.1239500E-04,.3672100E-03,.5276300E-03,.5574600E-03,& + & .5395700E-03,.4889100E-03,.4231300E-03,.3354500E-03,.2258800E-03,& + & .1351500E-04,.3631300E-03,.5365200E-03,.5668000E-03,.5479100E-03,& + & .4966400E-03,.4290700E-03,.3404300E-03,.2291600E-03,.1473400E-04,& + & .3241100E-03,.4281500E-03,.4472500E-03,.4381300E-03,.4015000E-03,& + & .3487100E-03,.2791200E-03,.1892900E-03,.8074100E-05,.3256700E-03,& + & .4378600E-03,.4606900E-03,.4502700E-03,.4131900E-03,.3581900E-03,& + & .2863500E-03,.1932500E-03,.8734000E-05,.3242900E-03,.4463800E-03,& + & .4722800E-03,.4607400E-03,.4227200E-03,.3660200E-03,.2920100E-03,& + & .1965300E-03,.9611000E-05,.3213700E-03,.4553100E-03,.4814200E-03,& + & .4695100E-03,.4299600E-03,.3725000E-03,.2970900E-03,.1997400E-03,& + & .1069700E-04,.3177600E-03,.4620700E-03,.4888000E-03,.4765900E-03,& + & .4355100E-03,.3777600E-03,.3013800E-03,.2027400E-03,.1170400E-04,& + & .2848800E-03,.3676700E-03,.3808100E-03,.3743800E-03,.3452500E-03,& + & .3015000E-03,.2433200E-03,.1641500E-03,.6397000E-05,.2853900E-03,& + & .3750900E-03,.3919600E-03,.3851000E-03,.3556600E-03,.3099800E-03,& + & .2496300E-03,.1676600E-03,.7200600E-05,.2839700E-03,.3821500E-03,& + & .4015600E-03,.3942800E-03,.3641800E-03,.3172700E-03,.2544600E-03,& + & .1710700E-03,.7957400E-05,.2813400E-03,.3886700E-03,.4095900E-03,& + & .4023000E-03,.3709300E-03,.3230100E-03,.2589800E-03,.1744700E-03,& + & .8713100E-05,.2788600E-03,.3936000E-03,.4164200E-03,.4085200E-03,& + & .3760900E-03,.3274000E-03,.2631200E-03,.1773700E-03,.9470400E-05,& + & .2492300E-03,.3155500E-03,.3242300E-03,.3173100E-03,.2941000E-03,& + & .2567100E-03,.2076200E-03,.1407400E-03,.5587700E-05,.2497700E-03,& + & .3212000E-03,.3337200E-03,.3265700E-03,.3029500E-03,.2647200E-03,& + & .2130300E-03,.1439600E-03,.6157500E-05,.2486500E-03,.3266800E-03,& + & .3418000E-03,.3344600E-03,.3103300E-03,.2714400E-03,.2177700E-03,& + & .1471400E-03,.6791600E-05,.2470900E-03,.3313300E-03,.3484100E-03,& + & .3413400E-03,.3160000E-03,.2764700E-03,.2217900E-03,.1501600E-03,& + & .7465300E-05,.2445500E-03,.3349100E-03,.3538800E-03,.3470800E-03,& + & .3206900E-03,.2800500E-03,.2252200E-03,.1524200E-03,.8161900E-05/ + + data absa(181:315, 3) / & + & .2152600E-03,.2711500E-03,.2750500E-03,.2680200E-03,.2496800E-03,& + & .2169000E-03,.1748100E-03,.1190600E-03,.5085000E-05,.2161100E-03,& + & .2762100E-03,.2829800E-03,.2762000E-03,.2572200E-03,.2241100E-03,& + & .1800400E-03,.1219700E-03,.5573800E-05,.2158300E-03,.2806000E-03,& + & .2895500E-03,.2828200E-03,.2634600E-03,.2300500E-03,.1841500E-03,& + & .1245100E-03,.6086400E-05,.2144600E-03,.2836300E-03,.2946900E-03,& + & .2889600E-03,.2686000E-03,.2343500E-03,.1876800E-03,.1269000E-03,& + & .6641700E-05,.2121700E-03,.2862600E-03,.2992900E-03,.2937000E-03,& + & .2725000E-03,.2376300E-03,.1907300E-03,.1290900E-03,.7212200E-05,& + & .1826200E-03,.2311200E-03,.2338800E-03,.2268100E-03,.2106200E-03,& + & .1819600E-03,.1463400E-03,.9970700E-04,.4807800E-05,.1839300E-03,& + & .2359100E-03,.2409400E-03,.2336400E-03,.2166300E-03,.1881400E-03,& + & .1511400E-03,.1020500E-03,.5225200E-05,.1837900E-03,.2398400E-03,& + & .2467600E-03,.2395600E-03,.2222100E-03,.1935600E-03,.1548900E-03,& + & .1043400E-03,.5640500E-05,.1827000E-03,.2425800E-03,.2510200E-03,& + & .2445800E-03,.2268500E-03,.1977100E-03,.1580500E-03,.1065500E-03,& + & .6072800E-05,.1806700E-03,.2444600E-03,.2546700E-03,.2489400E-03,& + & .2305100E-03,.2005600E-03,.1608800E-03,.1084400E-03,.6516000E-05,& + & .1526900E-03,.1940700E-03,.1964000E-03,.1907300E-03,.1771500E-03,& + & .1522400E-03,.1218100E-03,.8330200E-04,.4518500E-05,.1545000E-03,& + & .1983400E-03,.2024600E-03,.1967500E-03,.1824200E-03,.1577600E-03,& + & .1261000E-03,.8530600E-04,.4931500E-05,.1545900E-03,.2017800E-03,& + & .2075900E-03,.2017600E-03,.1873700E-03,.1623300E-03,.1295100E-03,& + & .8741700E-04,.5349100E-05,.1536800E-03,.2041000E-03,.2116000E-03,& + & .2062300E-03,.1916100E-03,.1660300E-03,.1324600E-03,.8923700E-04,& + & .5756200E-05,.1520700E-03,.2056700E-03,.2145800E-03,.2099100E-03,& + & .1952500E-03,.1690600E-03,.1348100E-03,.9093200E-04,.6165900E-05/ + + data absa(316:450, 3) / & + & .1267200E-03,.1615900E-03,.1632900E-03,.1582100E-03,.1474600E-03,& + & .1262400E-03,.1011600E-03,.6930600E-04,.4665200E-05,.1285300E-03,& + & .1653900E-03,.1685900E-03,.1635900E-03,.1520800E-03,.1312000E-03,& + & .1051300E-03,.7100500E-04,.5139200E-05,.1290100E-03,.1684100E-03,& + & .1730100E-03,.1681300E-03,.1561400E-03,.1353200E-03,.1082900E-03,& + & .7286300E-04,.5524400E-05,.1283300E-03,.1705800E-03,.1765200E-03,& + & .1718400E-03,.1597100E-03,.1386700E-03,.1108700E-03,.7447500E-04,& + & .5819300E-05,.1271500E-03,.1719700E-03,.1791800E-03,.1751300E-03,& + & .1629200E-03,.1414400E-03,.1130100E-03,.7596500E-04,.6170500E-05,& + & .1042800E-03,.1334800E-03,.1346200E-03,.1299500E-03,.1215800E-03,& + & .1037900E-03,.8300500E-04,.5737100E-04,.5596500E-05,.1061900E-03,& + & .1371000E-03,.1393200E-03,.1346900E-03,.1253800E-03,.1080000E-03,& + & .8663200E-04,.5895400E-04,.6196100E-05,.1069000E-03,.1397800E-03,& + & .1431500E-03,.1387700E-03,.1288500E-03,.1116900E-03,.8964300E-04,& + & .6056800E-04,.6852600E-05,.1066800E-03,.1417800E-03,.1462600E-03,& + & .1421300E-03,.1320700E-03,.1146800E-03,.9198400E-04,.6207000E-04,& + & .7512200E-05,.1058200E-03,.1431600E-03,.1487300E-03,.1450100E-03,& + & .1347100E-03,.1170400E-03,.9387600E-04,.6338800E-04,.8076100E-05,& + & .8547600E-04,.1098200E-03,.1103400E-03,.1064300E-03,.9970200E-04,& + & .8496700E-04,.6800800E-04,.4722900E-04,.6614500E-05,.8724200E-04,& + & .1132200E-03,.1146300E-03,.1104500E-03,.1029300E-03,.8858000E-04,& + & .7111300E-04,.4863100E-04,.7545200E-05,.8811100E-04,.1156300E-03,& + & .1179200E-03,.1140400E-03,.1058700E-03,.9187700E-04,.7379000E-04,& + & .5004400E-04,.8488100E-05,.8820000E-04,.1174300E-03,.1206500E-03,& + & .1170800E-03,.1087000E-03,.9448000E-04,.7589700E-04,.5138400E-04,& + & .9513600E-05,.8758300E-04,.1187100E-03,.1229200E-03,.1195400E-03,& + & .1110300E-03,.9652300E-04,.7752600E-04,.5251800E-04,.1053200E-04/ + + data absa(451:585, 3) / & + & .7055600E-04,.9142800E-04,.9186700E-04,.8846300E-04,.8284600E-04,& + & .7077400E-04,.5663200E-04,.3916700E-04,.6187200E-05,.7193300E-04,& + & .9418200E-04,.9526900E-04,.9164600E-04,.8538300E-04,.7373800E-04,& + & .5921900E-04,.4047400E-04,.6996500E-05,.7256700E-04,.9609800E-04,& + & .9792700E-04,.9460600E-04,.8783700E-04,.7637000E-04,.6132600E-04,& + & .4163300E-04,.7823500E-05,.7252900E-04,.9753200E-04,.1001100E-03,& + & .9707600E-04,.9013400E-04,.7842800E-04,.6301600E-04,.4275400E-04,& + & .8790400E-05,.7199000E-04,.9855200E-04,.1019300E-03,.9908000E-04,& + & .9209100E-04,.8006800E-04,.6434900E-04,.4367400E-04,.9801100E-05,& + & .5807200E-04,.7581500E-04,.7616800E-04,.7325200E-04,.6852100E-04,& + & .5874800E-04,.4702900E-04,.3243000E-04,.5183800E-05,.5914900E-04,& + & .7800500E-04,.7888900E-04,.7585300E-04,.7069100E-04,.6116000E-04,& + & .4910500E-04,.3357200E-04,.5866900E-05,.5961500E-04,.7957200E-04,& + & .8104300E-04,.7830100E-04,.7271600E-04,.6326500E-04,.5077700E-04,& + & .3450600E-04,.6646400E-05,.5950600E-04,.8071200E-04,.8281100E-04,& + & .8032100E-04,.7457100E-04,.6493500E-04,.5216500E-04,.3544700E-04,& + & .7441200E-05,.5906700E-04,.8152000E-04,.8428800E-04,.8197700E-04,& + & .7617200E-04,.6625900E-04,.5328100E-04,.3617800E-04,.8246500E-05,& + & .4764000E-04,.6258300E-04,.6288700E-04,.6048500E-04,.5655900E-04,& + & .4862400E-04,.3890400E-04,.2677300E-04,.4058200E-05,.4849800E-04,& + & .6437900E-04,.6508700E-04,.6264100E-04,.5837700E-04,.5057200E-04,& + & .4056600E-04,.2771700E-04,.4661600E-05,.4884400E-04,.6565600E-04,& + & .6685100E-04,.6462800E-04,.6004200E-04,.5225400E-04,.4191700E-04,& + & .2851000E-04,.5320400E-05,.4872200E-04,.6657400E-04,.6830300E-04,& + & .6630000E-04,.6154700E-04,.5361400E-04,.4305800E-04,.2925400E-04,& + & .5944200E-05,.4835500E-04,.6721700E-04,.6951100E-04,.6765100E-04,& + & .6286400E-04,.5471200E-04,.4399800E-04,.2987500E-04,.6643600E-05/ + + data absa( 1:180, 4) / & + & .8538700E-03,.9726800E-03,.9520100E-03,.8922600E-03,.8146500E-03,& + & .6970700E-03,.5482900E-03,.3588200E-03,.3792000E-04,.8549600E-03,& + & .9874600E-03,.9718800E-03,.9177500E-03,.8352900E-03,.7164900E-03,& + & .5637600E-03,.3706100E-03,.4315500E-04,.8515400E-03,.9990800E-03,& + & .9896900E-03,.9401400E-03,.8560400E-03,.7337900E-03,.5783200E-03,& + & .3818300E-03,.4870200E-04,.8460600E-03,.1009000E-02,.1006800E-02,& + & .9594400E-03,.8743400E-03,.7497500E-03,.5924300E-03,.3918800E-03,& + & .5402200E-04,.8406100E-03,.1017100E-02,.1021800E-02,.9768400E-03,& + & .8890600E-03,.7634500E-03,.6047100E-03,.4018000E-03,.5977800E-04,& + & .7610600E-03,.8676300E-03,.8462000E-03,.7933700E-03,.7236800E-03,& + & .6263300E-03,.4916800E-03,.3234600E-03,.3132200E-04,.7615300E-03,& + & .8814800E-03,.8634900E-03,.8155900E-03,.7448000E-03,.6444800E-03,& + & .5063500E-03,.3343000E-03,.3556600E-04,.7597700E-03,.8919500E-03,& + & .8787100E-03,.8360500E-03,.7628600E-03,.6612700E-03,.5195900E-03,& + & .3447200E-03,.3970500E-04,.7577100E-03,.8998700E-03,.8940600E-03,& + & .8553000E-03,.7812300E-03,.6761200E-03,.5322100E-03,.3544700E-03,& + & .4426600E-04,.7528900E-03,.9065700E-03,.9077100E-03,.8720000E-03,& + & .7971500E-03,.6892600E-03,.5438200E-03,.3637200E-03,.4870800E-04,& + & .6689300E-03,.7624600E-03,.7433400E-03,.6975200E-03,.6350100E-03,& + & .5536200E-03,.4345500E-03,.2884300E-03,.2426000E-04,.6711800E-03,& + & .7758800E-03,.7594400E-03,.7171000E-03,.6546100E-03,.5712200E-03,& + & .4499100E-03,.2990600E-03,.2743400E-04,.6721800E-03,.7850500E-03,& + & .7732800E-03,.7349700E-03,.6728600E-03,.5871800E-03,.4637500E-03,& + & .3093300E-03,.3080800E-04,.6705800E-03,.7924200E-03,.7862700E-03,& + & .7518100E-03,.6894600E-03,.6018300E-03,.4753200E-03,.3174300E-03,& + & .3432400E-04,.6646700E-03,.7982200E-03,.7977600E-03,.7677900E-03,& + & .7048100E-03,.6151000E-03,.4855300E-03,.3252600E-03,.3790500E-04,& + & .5829700E-03,.6602000E-03,.6433700E-03,.6061000E-03,.5522200E-03,& + & .4833800E-03,.3815400E-03,.2553700E-03,.2005400E-04,.5861600E-03,& + & .6731100E-03,.6576400E-03,.6236200E-03,.5699600E-03,.4993900E-03,& + & .3965700E-03,.2641800E-03,.2245700E-04,.5871900E-03,.6829100E-03,& + & .6701400E-03,.6392600E-03,.5870300E-03,.5145300E-03,.4097600E-03,& + & .2728000E-03,.2497400E-04,.5845100E-03,.6892500E-03,.6814400E-03,& + & .6541000E-03,.6031200E-03,.5290300E-03,.4214700E-03,.2809600E-03,& + & .2761300E-04,.5788500E-03,.6936900E-03,.6915300E-03,.6672500E-03,& + & .6166600E-03,.5411400E-03,.4312300E-03,.2890700E-03,.3024300E-04/ + + data absa(181:315, 4) / & + & .5063900E-03,.5689700E-03,.5541200E-03,.5212700E-03,.4734100E-03,& + & .4166900E-03,.3329300E-03,.2221500E-03,.1705700E-04,.5106500E-03,& + & .5811100E-03,.5674000E-03,.5364200E-03,.4897000E-03,.4316600E-03,& + & .3467100E-03,.2311100E-03,.1919100E-04,.5113100E-03,.5892300E-03,& + & .5780200E-03,.5498900E-03,.5051900E-03,.4452000E-03,.3586700E-03,& + & .2395500E-03,.2123800E-04,.5088800E-03,.5943200E-03,.5870000E-03,& + & .5623800E-03,.5189900E-03,.4578700E-03,.3696000E-03,.2473300E-03,& + & .2344200E-04,.5041100E-03,.5980400E-03,.5949700E-03,.5734200E-03,& + & .5315800E-03,.4692400E-03,.3788600E-03,.2545000E-03,.2575600E-04,& + & .4367300E-03,.4878200E-03,.4749900E-03,.4462900E-03,.4035400E-03,& + & .3545700E-03,.2860500E-03,.1908600E-03,.1470200E-04,.4410200E-03,& + & .4983100E-03,.4863900E-03,.4594300E-03,.4187900E-03,.3680800E-03,& + & .2980200E-03,.1998500E-03,.1647100E-04,.4422100E-03,.5051800E-03,& + & .4953800E-03,.4707500E-03,.4318300E-03,.3799500E-03,.3088200E-03,& + & .2076300E-03,.1842000E-04,.4401700E-03,.5099400E-03,.5032300E-03,& + & .4814100E-03,.4436000E-03,.3911600E-03,.3184400E-03,.2146000E-03,& + & .2047300E-04,.4365600E-03,.5124900E-03,.5100000E-03,.4906800E-03,& + & .4542500E-03,.4010700E-03,.3265300E-03,.2210900E-03,.2260000E-04,& + & .3762700E-03,.4152500E-03,.4036500E-03,.3792300E-03,.3425700E-03,& + & .3014700E-03,.2432400E-03,.1609400E-03,.1340000E-04,.3805100E-03,& + & .4248900E-03,.4140000E-03,.3906700E-03,.3555500E-03,.3125700E-03,& + & .2535300E-03,.1694700E-03,.1490500E-04,.3819600E-03,.4315400E-03,& + & .4216900E-03,.4003500E-03,.3670300E-03,.3231100E-03,.2629100E-03,& + & .1767200E-03,.1656600E-04,.3810800E-03,.4358700E-03,.4280900E-03,& + & .4089000E-03,.3769400E-03,.3324600E-03,.2709400E-03,.1830500E-03,& + & .1835200E-04,.3785400E-03,.4388900E-03,.4340200E-03,.4169700E-03,& + & .3853200E-03,.3407400E-03,.2781600E-03,.1887300E-03,.2022000E-04/ + + data absa(316:450, 4) / & + & .3196800E-03,.3530100E-03,.3431000E-03,.3220600E-03,.2890400E-03,& + & .2535600E-03,.2052300E-03,.1343200E-03,.1354800E-04,.3238600E-03,& + & .3622900E-03,.3528800E-03,.3321400E-03,.3003300E-03,.2634500E-03,& + & .2137400E-03,.1419800E-03,.1496600E-04,.3252100E-03,.3684800E-03,& + & .3598600E-03,.3405600E-03,.3104200E-03,.2722200E-03,.2211500E-03,& + & .1484100E-03,.1627800E-04,.3252700E-03,.3725800E-03,.3655300E-03,& + & .3481100E-03,.3191600E-03,.2803400E-03,.2283700E-03,.1544300E-03,& + & .1761400E-04,.3227200E-03,.3753300E-03,.3702500E-03,.3543800E-03,& + & .3263200E-03,.2874000E-03,.2348400E-03,.1595200E-03,.1907500E-04,& + & .2679400E-03,.2965500E-03,.2885100E-03,.2715500E-03,.2429000E-03,& + & .2118200E-03,.1718700E-03,.1115800E-03,.1689300E-04,.2721500E-03,& + & .3047700E-03,.2976500E-03,.2807500E-03,.2533600E-03,.2212000E-03,& + & .1785800E-03,.1179400E-03,.1857600E-04,.2740000E-03,.3106100E-03,& + & .3044700E-03,.2883600E-03,.2622400E-03,.2288600E-03,.1847400E-03,& + & .1237200E-03,.2005600E-04,.2738500E-03,.3142400E-03,.3092300E-03,& + & .2947700E-03,.2697700E-03,.2355400E-03,.1909300E-03,.1288400E-03,& + & .2132100E-04,.2719600E-03,.3164700E-03,.3130800E-03,.3000600E-03,& + & .2760400E-03,.2419100E-03,.1964900E-03,.1335200E-03,.2261100E-04,& + & .2225500E-03,.2471600E-03,.2408700E-03,.2267200E-03,.2021600E-03,& + & .1758200E-03,.1433900E-03,.9252800E-04,.2247100E-04,.2266300E-03,& + & .2542900E-03,.2490800E-03,.2350600E-03,.2116700E-03,.1837700E-03,& + & .1491000E-03,.9797200E-04,.2453600E-04,.2286700E-03,.2596300E-03,& + & .2553200E-03,.2416900E-03,.2192300E-03,.1906700E-03,.1545800E-03,& + & .1029300E-03,.2645300E-04,.2285300E-03,.2627300E-03,.2596000E-03,& + & .2470400E-03,.2254900E-03,.1967900E-03,.1596800E-03,.1072800E-03,& + & .2838300E-04,.2270400E-03,.2646900E-03,.2625900E-03,.2514100E-03,& + & .2308000E-03,.2021600E-03,.1643300E-03,.1111600E-03,.3011100E-04/ + + data absa(451:585, 4) / & + & .1857000E-03,.2079100E-03,.2031000E-03,.1910600E-03,.1706600E-03,& + & .1479700E-03,.1209700E-03,.7870400E-04,.2072000E-04,.1886800E-03,& + & .2135600E-03,.2096900E-03,.1980700E-03,.1782100E-03,.1543400E-03,& + & .1258400E-03,.8317900E-04,.2326800E-04,.1897200E-03,.2173200E-03,& + & .2144700E-03,.2030500E-03,.1841600E-03,.1599300E-03,.1300600E-03,& + & .8713400E-04,.2578100E-04,.1892900E-03,.2195500E-03,.2177100E-03,& + & .2071100E-03,.1890700E-03,.1649300E-03,.1342000E-03,.9069900E-04,& + & .2818100E-04,.1876600E-03,.2209500E-03,.2198700E-03,.2104500E-03,& + & .1931200E-03,.1693400E-03,.1381200E-03,.9384000E-04,.3048900E-04,& + & .1540900E-03,.1739900E-03,.1701000E-03,.1600200E-03,.1431100E-03,& + & .1237600E-03,.1012100E-03,.6642800E-04,.1781300E-04,.1559900E-03,& + & .1783100E-03,.1752100E-03,.1655400E-03,.1489000E-03,.1288100E-03,& + & .1052700E-03,.6996400E-04,.1991800E-04,.1566100E-03,.1811900E-03,& + & .1789200E-03,.1693400E-03,.1536500E-03,.1333800E-03,.1086400E-03,& + & .7314200E-04,.2212100E-04,.1560800E-03,.1829300E-03,.1814500E-03,& + & .1725400E-03,.1574300E-03,.1374700E-03,.1120900E-03,.7597100E-04,& + & .2442500E-04,.1545300E-03,.1838300E-03,.1830900E-03,.1751000E-03,& + & .1606700E-03,.1410200E-03,.1152900E-03,.7860700E-04,.2679100E-04,& + & .1270500E-03,.1448500E-03,.1415500E-03,.1331200E-03,.1191400E-03,& + & .1029900E-03,.8441600E-04,.5559800E-04,.1442900E-04,.1284300E-03,& + & .1482200E-03,.1455500E-03,.1374800E-03,.1237700E-03,.1070200E-03,& + & .8752000E-04,.5840500E-04,.1614700E-04,.1287500E-03,.1504300E-03,& + & .1485000E-03,.1405300E-03,.1275200E-03,.1108100E-03,.9034800E-04,& + & .6093400E-04,.1799200E-04,.1282200E-03,.1517500E-03,.1504900E-03,& + & .1430100E-03,.1305900E-03,.1141300E-03,.9317100E-04,.6329600E-04,& + & .1988800E-04,.1268400E-03,.1523900E-03,.1517900E-03,.1451100E-03,& + & .1332000E-03,.1170200E-03,.9578600E-04,.6546800E-04,.2170600E-04/ + + data absa( 1:180, 5) / & + & .2275875E-02,.2332064E-02,.2216796E-02,.2037339E-02,.1810754E-02,& + & .1542017E-02,.1221835E-02,.8225168E-03,.2378785E-03,.2274525E-02,& + & .2355192E-02,.2253198E-02,.2079119E-02,.1858235E-02,.1590203E-02,& + & .1266759E-02,.8576253E-03,.2590612E-03,.2266023E-02,.2375024E-02,& + & .2283817E-02,.2117878E-02,.1902253E-02,.1637433E-02,.1310064E-02,& + & .8925666E-03,.2839408E-03,.2251924E-02,.2389473E-02,.2311430E-02,& + & .2154739E-02,.1945283E-02,.1682775E-02,.1352510E-02,.9268463E-03,& + & .3108163E-03,.2232455E-02,.2399259E-02,.2336395E-02,.2189553E-02,& + & .1986811E-02,.1727976E-02,.1393776E-02,.9592790E-03,.3382077E-03,& + & .2106993E-02,.2154787E-02,.2043104E-02,.1868719E-02,.1654669E-02,& + & .1404007E-02,.1111065E-02,.7507219E-03,.1949377E-03,.2109908E-02,& + & .2178927E-02,.2078863E-02,.1908781E-02,.1697578E-02,.1448872E-02,& + & .1153419E-02,.7832801E-03,.2139563E-03,.2105465E-02,.2199441E-02,& + & .2109463E-02,.1944753E-02,.1739524E-02,.1492018E-02,.1195120E-02,& + & .8155632E-03,.2349725E-03,.2093796E-02,.2214377E-02,.2136026E-02,& + & .1977275E-02,.1778542E-02,.1533694E-02,.1236220E-02,.8467658E-03,& + & .2569866E-03,.2076724E-02,.2225712E-02,.2159173E-02,.2008267E-02,& + & .1816462E-02,.1574183E-02,.1275209E-02,.8771670E-03,.2791186E-03,& + & .1940537E-02,.1975605E-02,.1864311E-02,.1695911E-02,.1496137E-02,& + & .1263628E-02,.9971610E-03,.6738674E-03,.1565544E-03,.1948245E-02,& + & .2001986E-02,.1900553E-02,.1736295E-02,.1537745E-02,.1305077E-02,& + & .1036131E-02,.7035141E-03,.1728753E-03,.1946880E-02,.2024379E-02,& + & .1930764E-02,.1771154E-02,.1575770E-02,.1344673E-02,.1074374E-02,& + & .7332422E-03,.1899479E-03,.1938868E-02,.2041140E-02,.1955874E-02,& + & .1802287E-02,.1611440E-02,.1382812E-02,.1112406E-02,.7633322E-03,& + & .2072614E-03,.1926362E-02,.2054363E-02,.1977970E-02,.1829838E-02,& + & .1645759E-02,.1419736E-02,.1149822E-02,.7922080E-03,.2267149E-03,& + & .1777321E-02,.1802735E-02,.1693881E-02,.1532687E-02,.1345353E-02,& + & .1130261E-02,.8895753E-03,.5968647E-03,.1247261E-03,.1788584E-02,& + & .1831387E-02,.1729859E-02,.1572174E-02,.1384900E-02,.1169670E-02,& + & .9252263E-03,.6260595E-03,.1385262E-03,.1791618E-02,.1854218E-02,& + & .1759929E-02,.1606995E-02,.1420262E-02,.1206226E-02,.9598075E-03,& + & .6546109E-03,.1526122E-03,.1788339E-02,.1872013E-02,.1786084E-02,& + & .1636442E-02,.1452167E-02,.1240664E-02,.9939639E-03,.6826539E-03,& + & .1672628E-03,.1778773E-02,.1885271E-02,.1807813E-02,.1662029E-02,& + & .1483280E-02,.1274547E-02,.1027899E-02,.7097707E-03,.1836638E-03/ + + data absa(181:315, 5) / & + & .1611039E-02,.1628826E-02,.1528886E-02,.1381805E-02,.1208375E-02,& + & .1011477E-02,.7896015E-03,.5279159E-03,.9908775E-04,.1625251E-02,& + & .1659059E-02,.1564750E-02,.1419820E-02,.1247291E-02,.1047725E-02,& + & .8222728E-03,.5541873E-03,.1104539E-03,.1631934E-02,.1683911E-02,& + & .1595157E-02,.1453710E-02,.1281311E-02,.1080902E-02,.8540548E-03,& + & .5806197E-03,.1219897E-03,.1631403E-02,.1703448E-02,.1621164E-02,& + & .1482847E-02,.1310904E-02,.1111385E-02,.8847073E-03,.6065309E-03,& + & .1346152E-03,.1624079E-02,.1717008E-02,.1643088E-02,.1507761E-02,& + & .1337964E-02,.1141306E-02,.9151343E-03,.6325088E-03,.1481383E-03,& + & .1446415E-02,.1455765E-02,.1361590E-02,.1229351E-02,.1074912E-02,& + & .9006186E-03,.7006813E-03,.4647234E-03,.8189242E-04,.1463779E-02,& + & .1487367E-02,.1398211E-02,.1267666E-02,.1112416E-02,.9358187E-03,& + & .7313361E-03,.4886301E-03,.9135341E-04,.1472351E-02,.1513138E-02,& + & .1428682E-02,.1300953E-02,.1145840E-02,.9675370E-03,.7596020E-03,& + & .5122126E-03,.1005443E-03,.1474221E-02,.1532600E-02,.1454339E-02,& + & .1329459E-02,.1174906E-02,.9956373E-03,.7867852E-03,.5359551E-03,& + & .1109812E-03,.1468517E-02,.1546507E-02,.1474790E-02,.1352688E-02,& + & .1200227E-02,.1022681E-02,.8131587E-03,.5591171E-03,.1219361E-03,& + & .1282142E-02,.1287927E-02,.1202141E-02,.1083733E-02,.9460514E-03,& + & .7915341E-03,.6168183E-03,.4084185E-03,.6913010E-04,.1301052E-02,& + & .1319819E-02,.1238509E-02,.1121340E-02,.9823064E-03,.8254094E-03,& + & .6455635E-03,.4300976E-03,.7651588E-04,.1311903E-02,.1345238E-02,& + & .1268573E-02,.1153718E-02,.1014080E-02,.8553954E-03,.6719282E-03,& + & .4514177E-03,.8484352E-04,.1314609E-02,.1365010E-02,.1292722E-02,& + & .1180653E-02,.1041774E-02,.8822963E-03,.6970864E-03,.4722480E-03,& + & .9377363E-04,.1310264E-02,.1377648E-02,.1311780E-02,.1202781E-02,& + & .1065878E-02,.9070933E-03,.7215140E-03,.4928747E-03,.1032168E-03/ + + data absa(316:450, 5) / & + & .1123722E-02,.1125509E-02,.1049077E-02,.9463051E-03,.8264962E-03,& + & .6910472E-03,.5381327E-03,.3566196E-03,.6074714E-04,.1144528E-02,& + & .1157108E-02,.1084145E-02,.9824251E-03,.8612451E-03,.7227531E-03,& + & .5650534E-03,.3769954E-03,.6752101E-04,.1156115E-02,.1182481E-02,& + & .1113388E-02,.1013135E-02,.8909498E-03,.7510056E-03,.5899576E-03,& + & .3965626E-03,.7509877E-04,.1159636E-02,.1200610E-02,.1136628E-02,& + & .1038419E-02,.9163190E-03,.7757266E-03,.6129711E-03,.4156689E-03,& + & .8319483E-04,.1156675E-02,.1212668E-02,.1153943E-02,.1059223E-02,& + & .9387272E-03,.7983980E-03,.6348116E-03,.4345877E-03,.9149048E-04,& + & .9788217E-03,.9762902E-03,.9076191E-03,.8180805E-03,.7140719E-03,& + & .5979311E-03,.4657057E-03,.3080365E-03,.6376560E-04,.9995801E-03,& + & .1006767E-02,.9409303E-03,.8518710E-03,.7465719E-03,.6272074E-03,& + & .4915396E-03,.3271476E-03,.7043059E-04,.1011283E-02,.1030289E-02,& + & .9679162E-03,.8806454E-03,.7743638E-03,.6533475E-03,.5145414E-03,& + & .3451157E-03,.7748348E-04,.1015523E-02,.1047024E-02,.9891231E-03,& + & .9038676E-03,.7980900E-03,.6765444E-03,.5353367E-03,.3623073E-03,& + & .8485843E-04,.1014685E-02,.1058164E-02,.1005055E-02,.9228604E-03,& + & .8183767E-03,.6971991E-03,.5549716E-03,.3793243E-03,.9265390E-04,& + & .8467257E-03,.8439047E-03,.7839737E-03,.7069600E-03,.6168442E-03,& + & .5161363E-03,.4002993E-03,.2648075E-03,.8538662E-04,.8663801E-03,& + & .8726556E-03,.8143622E-03,.7377253E-03,.6460394E-03,.5429897E-03,& + & .4242444E-03,.2822342E-03,.9232499E-04,.8777160E-03,.8939799E-03,& + & .8388502E-03,.7633777E-03,.6710202E-03,.5661949E-03,.4453570E-03,& + & .2983921E-03,.9968327E-04,.8822976E-03,.9090305E-03,.8576617E-03,& + & .7836215E-03,.6918973E-03,.5865524E-03,.4643056E-03,.3139878E-03,& + & .1075001E-03,.8816821E-03,.9194329E-03,.8721358E-03,.8002626E-03,& + & .7096839E-03,.6047828E-03,.4818629E-03,.3291128E-03,.1153966E-03/ + + data absa(451:585, 5) / & + & .7345259E-03,.7353571E-03,.6844124E-03,.6191407E-03,.5419865E-03,& + & .4543535E-03,.3524790E-03,.2326534E-03,.8831490E-04,.7490617E-03,& + & .7579739E-03,.7093615E-03,.6447658E-03,.5665622E-03,.4774427E-03,& + & .3729073E-03,.2477509E-03,.9439904E-04,.7564292E-03,.7744541E-03,& + & .7287630E-03,.6652977E-03,.5871248E-03,.4970065E-03,.3911667E-03,& + & .2619945E-03,.9990772E-04,.7586881E-03,.7858289E-03,.7437324E-03,& + & .6818515E-03,.6043581E-03,.5141276E-03,.4072910E-03,.2755984E-03,& + & .1066252E-03,.7563639E-03,.7931595E-03,.7548375E-03,.6950726E-03,& + & .6192222E-03,.5294685E-03,.4222590E-03,.2889243E-03,.1133924E-03,& + & .6314226E-03,.6349627E-03,.5926562E-03,.5376114E-03,.4719251E-03,& + & .3962308E-03,.3074879E-03,.2032569E-03,.8003266E-04,.6418725E-03,& + & .6525898E-03,.6125061E-03,.5580757E-03,.4921735E-03,.4155327E-03,& + & .3248794E-03,.2162533E-03,.8576530E-04,.6471266E-03,.6653221E-03,& + & .6276452E-03,.5745768E-03,.5090609E-03,.4319430E-03,.3403545E-03,& + & .2285539E-03,.9041149E-04,.6478227E-03,.6738338E-03,.6394020E-03,& + & .5876220E-03,.5231812E-03,.4462724E-03,.3541410E-03,.2403090E-03,& + & .9584348E-04,.6442291E-03,.6788200E-03,.6475947E-03,.5980228E-03,& + & .5350971E-03,.4588656E-03,.3667841E-03,.2515799E-03,.1017699E-03,& + & .5366413E-03,.5433012E-03,.5091779E-03,.4634801E-03,.4076173E-03,& + & .3421937E-03,.2655508E-03,.1759732E-03,.6609799E-04,.5446297E-03,& + & .5573704E-03,.5249762E-03,.4800512E-03,.4241853E-03,.3581272E-03,& + & .2800981E-03,.1871731E-03,.7047861E-04,.5481742E-03,.5672989E-03,& + & .5373039E-03,.4932643E-03,.4379422E-03,.3716071E-03,.2930461E-03,& + & .1977626E-03,.7433299E-04,.5476171E-03,.5738401E-03,.5461812E-03,& + & .5035685E-03,.4492907E-03,.3832995E-03,.3046021E-03,.2077508E-03,& + & .7880238E-04,.5438946E-03,.5774436E-03,.5525251E-03,.5119901E-03,& + & .4590263E-03,.3938170E-03,.3152705E-03,.2173888E-03,.8388184E-04/ + + data absa( 1:180, 6) / & + & .7453129E-02,.7117405E-02,.6661341E-02,.6078589E-02,.5376308E-02,& + & .4581666E-02,.3692876E-02,.2668674E-02,.1857553E-02,.7414650E-02,& + & .7132841E-02,.6723850E-02,.6175876E-02,.5501579E-02,.4730655E-02,& + & .3847363E-02,.2834084E-02,.2101417E-02,.7367697E-02,.7142450E-02,& + & .6787572E-02,.6271236E-02,.5628812E-02,.4876081E-02,.4005906E-02,& + & .3014246E-02,.2361444E-02,.7309381E-02,.7154158E-02,.6847198E-02,& + & .6364336E-02,.5757194E-02,.5023915E-02,.4174265E-02,.3211257E-02,& + & .2644919E-02,.7240917E-02,.7165375E-02,.6901545E-02,.6460272E-02,& + & .5886974E-02,.5176789E-02,.4355003E-02,.3427381E-02,.2951988E-02,& + & .7302417E-02,.6986029E-02,.6506078E-02,.5915241E-02,.5213714E-02,& + & .4409454E-02,.3509969E-02,.2477433E-02,.1531293E-02,.7272446E-02,& + & .7005207E-02,.6569159E-02,.6009028E-02,.5333024E-02,.4547186E-02,& + & .3651478E-02,.2623452E-02,.1730635E-02,.7229818E-02,.7019119E-02,& + & .6631639E-02,.6101575E-02,.5452906E-02,.4682444E-02,.3795174E-02,& + & .2779605E-02,.1947925E-02,.7174295E-02,.7033174E-02,.6689925E-02,& + & .6193261E-02,.5571003E-02,.4818428E-02,.3945240E-02,.2947728E-02,& + & .2183570E-02,.7110805E-02,.7045732E-02,.6744602E-02,.6284811E-02,& + & .5687916E-02,.4958393E-02,.4105561E-02,.3129372E-02,.2439844E-02,& + & .7107732E-02,.6797516E-02,.6299565E-02,.5698070E-02,.4995391E-02,& + & .4198481E-02,.3302300E-02,.2275195E-02,.1230993E-02,.7086152E-02,& + & .6823070E-02,.6363343E-02,.5788270E-02,.5108424E-02,.4328271E-02,& + & .3431427E-02,.2406277E-02,.1392637E-02,.7052294E-02,.6841431E-02,& + & .6426576E-02,.5878051E-02,.5223227E-02,.4454560E-02,.3563303E-02,& + & .2543558E-02,.1569089E-02,.7006893E-02,.6857640E-02,.6486440E-02,& + & .5967434E-02,.5334883E-02,.4578334E-02,.3699649E-02,.2688020E-02,& + & .1760440E-02,.6949333E-02,.6870773E-02,.6541587E-02,.6057335E-02,& + & .5442169E-02,.4706411E-02,.3839426E-02,.2841732E-02,.1964963E-02,& + & .6855130E-02,.6551944E-02,.6044314E-02,.5438518E-02,.4743060E-02,& + & .3966419E-02,.3087108E-02,.2087789E-02,.9879948E-03,.6846892E-02,& + & .6585398E-02,.6112347E-02,.5528377E-02,.4852610E-02,.4086708E-02,& + & .3208051E-02,.2203856E-02,.1119742E-02,.6824941E-02,.6610372E-02,& + & .6177682E-02,.5615844E-02,.4962743E-02,.4204184E-02,.3329715E-02,& + & .2324960E-02,.1263158E-02,.6787743E-02,.6632257E-02,.6236180E-02,& + & .5702032E-02,.5069502E-02,.4319861E-02,.3453836E-02,.2450583E-02,& + & .1417217E-02,.6740085E-02,.6651560E-02,.6290312E-02,.5788524E-02,& + & .5171266E-02,.4436812E-02,.3580405E-02,.2581552E-02,.1582148E-02/ + + data absa(181:315, 6) / & + & .6558083E-02,.6261779E-02,.5751378E-02,.5145860E-02,.4467228E-02,& + & .3714081E-02,.2872846E-02,.1912747E-02,.7974292E-03,.6563849E-02,& + & .6305787E-02,.5824503E-02,.5238051E-02,.4571578E-02,.3828273E-02,& + & .2985436E-02,.2017845E-02,.9044707E-03,.6552571E-02,.6339245E-02,& + & .5892376E-02,.5324090E-02,.4676050E-02,.3939449E-02,.3097458E-02,& + & .2125514E-02,.1021181E-02,.6528895E-02,.6367176E-02,.5952402E-02,& + & .5408542E-02,.4777701E-02,.4049784E-02,.3211983E-02,.2236558E-02,& + & .1145140E-02,.6494313E-02,.6390805E-02,.6006376E-02,.5490888E-02,& + & .4876710E-02,.4160137E-02,.3328414E-02,.2349602E-02,.1279011E-02,& + & .6217297E-02,.5928758E-02,.5426959E-02,.4833520E-02,.4174155E-02,& + & .3449793E-02,.2650701E-02,.1741615E-02,.6370094E-03,.6238859E-02,& + & .5985757E-02,.5505992E-02,.4926333E-02,.4277869E-02,.3557040E-02,& + & .2755926E-02,.1837721E-02,.7241979E-03,.6246176E-02,.6029777E-02,& + & .5577993E-02,.5013764E-02,.4377842E-02,.3662657E-02,.2861509E-02,& + & .1935493E-02,.8193352E-03,.6236692E-02,.6066266E-02,.5641135E-02,& + & .5097431E-02,.4474642E-02,.3767073E-02,.2967217E-02,.2035588E-02,& + & .9198253E-03,.6214342E-02,.6096770E-02,.5698970E-02,.5179034E-02,& + & .4569107E-02,.3869801E-02,.3075666E-02,.2136680E-02,.1028239E-02,& + & .5843663E-02,.5561987E-02,.5073558E-02,.4502171E-02,.3871558E-02,& + & .3184826E-02,.2432337E-02,.1579438E-02,.5066815E-03,.5883549E-02,& + & .5632733E-02,.5159626E-02,.4598553E-02,.3975656E-02,.3289560E-02,& + & .2531458E-02,.1667525E-02,.5778308E-03,.5906315E-02,.5689718E-02,& + & .5238108E-02,.4688943E-02,.4074005E-02,.3390408E-02,.2630796E-02,& + & .1755973E-02,.6537602E-03,.5911760E-02,.5735215E-02,.5308819E-02,& + & .4775175E-02,.4168666E-02,.3489857E-02,.2728910E-02,.1847257E-02,& + & .7347999E-03,.5905012E-02,.5775036E-02,.5371993E-02,.4856819E-02,& + & .4260538E-02,.3587351E-02,.2827507E-02,.1938584E-02,.8225668E-03/ + + data absa(316:450, 6) / & + & .5448799E-02,.5174237E-02,.4702978E-02,.4159096E-02,.3562636E-02,& + & .2919042E-02,.2216707E-02,.1428474E-02,.4372080E-03,.5503786E-02,& + & .5258826E-02,.4798801E-02,.4260222E-02,.3666742E-02,.3022053E-02,& + & .2311790E-02,.1509380E-02,.4923566E-03,.5542089E-02,.5327495E-02,& + & .4884619E-02,.4354537E-02,.3765908E-02,.3119877E-02,.2406348E-02,& + & .1590203E-02,.5508055E-03,.5564630E-02,.5383808E-02,.4961019E-02,& + & .4443926E-02,.3860688E-02,.3216549E-02,.2498792E-02,.1671379E-02,& + & .6126355E-03,.5570361E-02,.5432506E-02,.5031105E-02,.4526985E-02,& + & .3951398E-02,.3309750E-02,.2590269E-02,.1752856E-02,.6794564E-03,& + & .5025183E-02,.4765836E-02,.4321116E-02,.3810537E-02,.3254592E-02,& + & .2655950E-02,.2006115E-02,.1286407E-02,.4311014E-03,.5098265E-02,& + & .4863995E-02,.4425250E-02,.3917786E-02,.3360874E-02,.2757245E-02,& + & .2097126E-02,.1360829E-02,.4799419E-03,.5154179E-02,.4945399E-02,& + & .4519161E-02,.4017193E-02,.3461670E-02,.2853712E-02,.2187196E-02,& + & .1435268E-02,.5332265E-03,.5190969E-02,.5013790E-02,.4604355E-02,& + & .4110643E-02,.3555937E-02,.2947656E-02,.2275382E-02,.1509403E-02,& + & .5888012E-03,.5208138E-02,.5072165E-02,.4680561E-02,.4195990E-02,& + & .3646519E-02,.3037397E-02,.2361829E-02,.1583627E-02,.6478322E-03,& + & .4623391E-02,.4366790E-02,.3943485E-02,.3465227E-02,.2955259E-02,& + & .2405643E-02,.1812616E-02,.1157161E-02,.4945874E-03,.4710125E-02,& + & .4474615E-02,.4054953E-02,.3577026E-02,.3062985E-02,.2506113E-02,& + & .1900613E-02,.1226503E-02,.5465245E-03,.4776716E-02,.4564405E-02,& + & .4153594E-02,.3680995E-02,.3166029E-02,.2601953E-02,.1986110E-02,& + & .1295516E-02,.6032750E-03,.4823514E-02,.4640328E-02,.4243823E-02,& + & .3778649E-02,.3262225E-02,.2694009E-02,.2069881E-02,.1363711E-02,& + & .6621313E-03,.4852467E-02,.4703395E-02,.4324910E-02,.3866669E-02,& + & .3352109E-02,.2781681E-02,.2151024E-02,.1432036E-02,.7228720E-03/ + + data absa(451:585, 6) / & + & .4268691E-02,.4040183E-02,.3646880E-02,.3203178E-02,.2726389E-02,& + & .2213905E-02,.1666317E-02,.1066325E-02,.4983873E-03,.4358586E-02,& + & .4148745E-02,.3757876E-02,.3313137E-02,.2831232E-02,.2309276E-02,& + & .1749842E-02,.1130782E-02,.5479266E-03,.4428469E-02,.4241143E-02,& + & .3857210E-02,.3414820E-02,.2929730E-02,.2400315E-02,.1831540E-02,& + & .1194311E-02,.6008082E-03,.4479685E-02,.4318791E-02,.3947347E-02,& + & .3507844E-02,.3019422E-02,.2487256E-02,.1910638E-02,.1257207E-02,& + & .6538267E-03,.4513413E-02,.4384415E-02,.4026009E-02,.3591207E-02,& + & .3103605E-02,.2569184E-02,.1986548E-02,.1320050E-02,.7081602E-03,& + & .3915100E-02,.3711716E-02,.3349816E-02,.2944438E-02,.2506601E-02,& + & .2037038E-02,.1533857E-02,.9781961E-03,.4622673E-03,.4005434E-02,& + & .3819687E-02,.3461208E-02,.3053733E-02,.2609936E-02,.2129368E-02,& + & .1612065E-02,.1038339E-02,.5051377E-03,.4076956E-02,.3913286E-02,& + & .3561928E-02,.3154739E-02,.2705010E-02,.2215707E-02,.1687464E-02,& + & .1097449E-02,.5512414E-03,.4130247E-02,.3993297E-02,.3650863E-02,& + & .3245814E-02,.2792524E-02,.2297376E-02,.1759369E-02,.1155953E-02,& + & .5980184E-03,.4167218E-02,.4060665E-02,.3729251E-02,.3327359E-02,& + & .2873454E-02,.2374433E-02,.1829761E-02,.1214279E-02,.6444273E-03,& + & .3565599E-02,.3385516E-02,.3057279E-02,.2688351E-02,.2290666E-02,& + & .1864426E-02,.1405266E-02,.8966862E-03,.3986965E-03,.3656897E-02,& + & .3493575E-02,.3167640E-02,.2795196E-02,.2390148E-02,.1952514E-02,& + & .1480086E-02,.9522316E-03,.4352189E-03,.3729366E-02,.3587046E-02,& + & .3266101E-02,.2893554E-02,.2481255E-02,.2035902E-02,.1551310E-02,& + & .1006380E-02,.4737097E-03,.3784570E-02,.3667287E-02,.3354159E-02,& + & .2981192E-02,.2566707E-02,.2114949E-02,.1619376E-02,.1060223E-02,& + & .5128669E-03,.3823908E-02,.3735653E-02,.3431813E-02,.3061934E-02,& + & .2645587E-02,.2189124E-02,.1685116E-02,.1114442E-02,.5524785E-03/ + + data absa( 1:180, 7) / & + & .2337626E-01,.2175176E-01,.2063054E-01,.1953289E-01,.1869334E-01,& + & .1836575E-01,.1866188E-01,.1986732E-01,.2252135E-01,.2315624E-01,& + & .2164265E-01,.2067161E-01,.1978356E-01,.1921682E-01,.1922562E-01,& + & .1992930E-01,.2155800E-01,.2450575E-01,.2293107E-01,.2154457E-01,& + & .2074715E-01,.2011748E-01,.1985588E-01,.2024390E-01,.2137333E-01,& + & .2342559E-01,.2668727E-01,.2270210E-01,.2145089E-01,.2088033E-01,& + & .2054255E-01,.2062482E-01,.2143098E-01,.2299821E-01,.2549251E-01,& + & .2907234E-01,.2247095E-01,.2137582E-01,.2108331E-01,.2107230E-01,& + & .2155716E-01,.2281018E-01,.2484353E-01,.2780611E-01,.3172795E-01,& + & .2458189E-01,.2285200E-01,.2156813E-01,.2024632E-01,.1900708E-01,& + & .1819156E-01,.1796768E-01,.1857224E-01,.2076937E-01,.2435250E-01,& + & .2275178E-01,.2160965E-01,.2048103E-01,.1947652E-01,.1898219E-01,& + & .1913925E-01,.2015560E-01,.2268231E-01,.2412387E-01,.2265897E-01,& + & .2168600E-01,.2079019E-01,.2005803E-01,.1992705E-01,.2048310E-01,& + & .2192140E-01,.2477362E-01,.2389129E-01,.2256825E-01,.2181441E-01,& + & .2118241E-01,.2077464E-01,.2103762E-01,.2201020E-01,.2389372E-01,& + & .2708335E-01,.2365223E-01,.2248782E-01,.2200444E-01,.2167167E-01,& + & .2165150E-01,.2233835E-01,.2375741E-01,.2611574E-01,.2966311E-01,& + & .2579688E-01,.2397618E-01,.2249064E-01,.2092442E-01,.1929406E-01,& + & .1790138E-01,.1706811E-01,.1698922E-01,.1852242E-01,.2557176E-01,& + & .2388374E-01,.2253992E-01,.2114151E-01,.1969695E-01,.1860179E-01,& + & .1812445E-01,.1843215E-01,.2030655E-01,.2534781E-01,.2379879E-01,& + & .2261460E-01,.2141516E-01,.2020271E-01,.1944733E-01,.1934135E-01,& + & .2004948E-01,.2227174E-01,.2511276E-01,.2371341E-01,.2273562E-01,& + & .2176102E-01,.2083763E-01,.2045509E-01,.2073270E-01,.2187030E-01,& + & .2445363E-01,.2487422E-01,.2363274E-01,.2290622E-01,.2219407E-01,& + & .2162169E-01,.2162715E-01,.2232993E-01,.2392248E-01,.2688023E-01,& + & .2698586E-01,.2506791E-01,.2338609E-01,.2157417E-01,.1958193E-01,& + & .1763778E-01,.1616964E-01,.1538518E-01,.1621144E-01,.2676194E-01,& + & .2498910E-01,.2344897E-01,.2177479E-01,.1993962E-01,.1825433E-01,& + & .1710937E-01,.1668719E-01,.1786207E-01,.2654257E-01,.2491521E-01,& + & .2352676E-01,.2201454E-01,.2038036E-01,.1899998E-01,.1819673E-01,& + & .1814869E-01,.1968096E-01,.2631697E-01,.2483856E-01,.2364114E-01,& + & .2232785E-01,.2093620E-01,.1989270E-01,.1944697E-01,.1980212E-01,& + & .2170612E-01,.2608471E-01,.2475687E-01,.2379589E-01,.2271583E-01,& + & .2161901E-01,.2093691E-01,.2088135E-01,.2166610E-01,.2395288E-01/ + + data absa(181:315, 7) / & + & .2810778E-01,.2610373E-01,.2423479E-01,.2218757E-01,.1986177E-01,& + & .1746306E-01,.1537001E-01,.1389630E-01,.1400744E-01,.2789745E-01,& + & .2604100E-01,.2431619E-01,.2238153E-01,.2019516E-01,.1800500E-01,& + & .1621009E-01,.1507015E-01,.1553290E-01,.2769341E-01,.2597967E-01,& + & .2440064E-01,.2260000E-01,.2059359E-01,.1865773E-01,.1717719E-01,& + & .1638502E-01,.1720845E-01,.2747581E-01,.2591687E-01,.2451639E-01,& + & .2287475E-01,.2108787E-01,.1943977E-01,.1828677E-01,.1786928E-01,& + & .1906661E-01,.2724525E-01,.2584524E-01,.2465979E-01,.2322623E-01,& + & .2169174E-01,.2036043E-01,.1956477E-01,.1955161E-01,.2112946E-01,& + & .2916121E-01,.2706131E-01,.2501249E-01,.2273351E-01,.2011979E-01,& + & .1734949E-01,.1468202E-01,.1254397E-01,.1192697E-01,.2896641E-01,& + & .2702014E-01,.2511575E-01,.2293374E-01,.2042776E-01,.1783904E-01,& + & .1542709E-01,.1359860E-01,.1333064E-01,.2876765E-01,.2697723E-01,& + & .2521010E-01,.2314222E-01,.2079486E-01,.1840512E-01,.1626966E-01,& + & .1476028E-01,.1484637E-01,.2856294E-01,.2693274E-01,.2532642E-01,& + & .2339329E-01,.2123982E-01,.1907661E-01,.1724154E-01,.1606921E-01,& + & .1652405E-01,.2834370E-01,.2687419E-01,.2545751E-01,.2371200E-01,& + & .2178226E-01,.1987947E-01,.1836893E-01,.1756873E-01,.1840173E-01,& + & .3011114E-01,.2792230E-01,.2568609E-01,.2319257E-01,.2034293E-01,& + & .1726900E-01,.1415286E-01,.1138485E-01,.1005692E-01,.2992968E-01,& + & .2790487E-01,.2581306E-01,.2340902E-01,.2064353E-01,.1772380E-01,& + & .1480077E-01,.1231510E-01,.1132697E-01,.2974561E-01,.2787980E-01,& + & .2592483E-01,.2361776E-01,.2099074E-01,.1823014E-01,.1552253E-01,& + & .1333086E-01,.1268422E-01,.2955745E-01,.2785343E-01,.2604522E-01,& + & .2385432E-01,.2139366E-01,.1881776E-01,.1636294E-01,.1447960E-01,& + & .1418800E-01,.2935104E-01,.2781242E-01,.2617843E-01,.2414962E-01,& + & .2187815E-01,.1952002E-01,.1734737E-01,.1580301E-01,.1587593E-01/ + + data absa(316:450, 7) / & + & .3090210E-01,.2863464E-01,.2623745E-01,.2353758E-01,.2049216E-01,& + & .1719200E-01,.1374636E-01,.1041842E-01,.8306976E-02,.3074160E-01,& + & .2864184E-01,.2639435E-01,.2377357E-01,.2080408E-01,.1762587E-01,& + & .1431865E-01,.1122298E-01,.9441247E-02,.3058186E-01,.2864960E-01,& + & .2652689E-01,.2399238E-01,.2114556E-01,.1809030E-01,.1494024E-01,& + & .1210474E-01,.1065458E-01,.3041236E-01,.2865545E-01,.2666041E-01,& + & .2422874E-01,.2152521E-01,.1861362E-01,.1566308E-01,.1310960E-01,& + & .1200349E-01,.3023431E-01,.2863951E-01,.2679661E-01,.2451409E-01,& + & .2196729E-01,.1923952E-01,.1651206E-01,.1426729E-01,.1351982E-01,& + & .3150955E-01,.2917466E-01,.2663128E-01,.2375509E-01,.2054034E-01,& + & .1706533E-01,.1339031E-01,.9619698E-02,.6589618E-02,.3137548E-01,& + & .2921391E-01,.2682829E-01,.2401415E-01,.2086776E-01,.1749458E-01,& + & .1391017E-01,.1031015E-01,.7573865E-02,.3124577E-01,.2926104E-01,& + & .2699356E-01,.2424726E-01,.2121023E-01,.1794016E-01,.1446463E-01,& + & .1107269E-01,.8630532E-02,.3111437E-01,.2930266E-01,.2714520E-01,& + & .2449152E-01,.2158301E-01,.1842118E-01,.1509518E-01,.1193837E-01,& + & .9801078E-02,.3097127E-01,.2932558E-01,.2729444E-01,.2477809E-01,& + & .2199750E-01,.1898438E-01,.1582945E-01,.1293776E-01,.1111997E-01,& + & .3182644E-01,.2948280E-01,.2685783E-01,.2385751E-01,.2050472E-01,& + & .1690419E-01,.1307973E-01,.9016818E-02,.5889262E-02,.3174219E-01,& + & .2957180E-01,.2709658E-01,.2415027E-01,.2085202E-01,.1733699E-01,& + & .1357172E-01,.9617188E-02,.6575397E-02,.3166606E-01,.2967426E-01,& + & .2730658E-01,.2441152E-01,.2120507E-01,.1777789E-01,.1408374E-01,& + & .1027324E-01,.7358277E-02,.3158325E-01,.2976719E-01,.2749330E-01,& + & .2467389E-01,.2157919E-01,.1824104E-01,.1464950E-01,.1102019E-01,& + & .8229230E-02,.3148314E-01,.2984161E-01,.2766625E-01,.2497260E-01,& + & .2198691E-01,.1876667E-01,.1530472E-01,.1188221E-01,.9182963E-02/ + + data absa(451:585, 7) / & + & .3191734E-01,.2961741E-01,.2697787E-01,.2391284E-01,.2049970E-01,& + & .1685955E-01,.1296507E-01,.8750098E-02,.6274631E-02,.3190439E-01,& + & .2977990E-01,.2725815E-01,.2422984E-01,.2087607E-01,.1730510E-01,& + & .1344617E-01,.9295005E-02,.7007386E-02,.3188423E-01,.2993640E-01,& + & .2750670E-01,.2452542E-01,.2126330E-01,.1774973E-01,.1394711E-01,& + & .9900539E-02,.7782927E-02,.3184397E-01,.3007747E-01,.2772343E-01,& + & .2483444E-01,.2166507E-01,.1822702E-01,.1449986E-01,.1058694E-01,& + & .8671897E-02,.3178483E-01,.3018389E-01,.2793133E-01,.2517191E-01,& + & .2210215E-01,.1876481E-01,.1512017E-01,.1136237E-01,.9662908E-02,& + & .3187853E-01,.2963766E-01,.2698548E-01,.2385689E-01,.2040357E-01,& + & .1672870E-01,.1278988E-01,.8497981E-02,.6174837E-02,.3194590E-01,& + & .2988270E-01,.2731430E-01,.2420369E-01,.2080895E-01,.1718277E-01,& + & .1326475E-01,.9006730E-02,.6900214E-02,.3198870E-01,.3010121E-01,& + & .2760049E-01,.2453900E-01,.2122452E-01,.1764036E-01,.1376646E-01,& + & .9568560E-02,.7665374E-02,.3200932E-01,.3028722E-01,.2785313E-01,& + & .2489082E-01,.2164826E-01,.1813119E-01,.1432073E-01,.1019444E-01,& + & .8520390E-02,.3200022E-01,.3043673E-01,.2810016E-01,.2525761E-01,& + & .2211496E-01,.1867947E-01,.1492276E-01,.1090133E-01,.9520500E-02,& + & .3173815E-01,.2955655E-01,.2688573E-01,.2371393E-01,.2023390E-01,& + & .1654567E-01,.1257985E-01,.8246315E-02,.5647340E-02,.3187913E-01,& + & .2987574E-01,.2727046E-01,.2410527E-01,.2067778E-01,.1701522E-01,& + & .1304871E-01,.8729674E-02,.6295753E-02,.3199367E-01,.3016037E-01,& + & .2760193E-01,.2448927E-01,.2112455E-01,.1748698E-01,.1354982E-01,& + & .9254652E-02,.7027536E-02,.3208158E-01,.3040579E-01,.2790109E-01,& + & .2488587E-01,.2157632E-01,.1798983E-01,.1409732E-01,.9833255E-02,& + & .7857223E-02,.3212706E-01,.3060928E-01,.2819618E-01,.2528322E-01,& + & .2206831E-01,.1854255E-01,.1468812E-01,.1048268E-01,.8776360E-02/ + + data absa( 1:180, 8) / & + & .6013431E-01,.5707436E-01,.7233980E-01,.9815382E-01,.1294324E+00,& + & .1617466E+00,.1940373E+00,.2262581E+00,.2513644E+00,.5875631E-01,& + & .5691751E-01,.7437061E-01,.1026345E+00,.1360233E+00,.1699724E+00,& + & .2039042E+00,.2377536E+00,.2641912E+00,.5766566E-01,.5691471E-01,& + & .7651533E-01,.1069690E+00,.1422529E+00,.1777591E+00,.2132449E+00,& + & .2486476E+00,.2761623E+00,.5690082E-01,.5712785E-01,.7881629E-01,& + & .1114369E+00,.1484198E+00,.1854598E+00,.2224755E+00,.2594138E+00,& + & .2880248E+00,.5637766E-01,.5755994E-01,.8139096E-01,.1160220E+00,& + & .1545869E+00,.1931597E+00,.2317210E+00,.2701851E+00,.2998888E+00,& + & .6618075E-01,.6337862E-01,.7888769E-01,.1046010E+00,.1369770E+00,& + & .1711778E+00,.2053496E+00,.2394477E+00,.2688156E+00,.6469675E-01,& + & .6319075E-01,.8109464E-01,.1094837E+00,.1444540E+00,.1805151E+00,& + & .2165594E+00,.2525366E+00,.2834257E+00,.6352136E-01,.6312417E-01,& + & .8332160E-01,.1142143E+00,.1514669E+00,.1892772E+00,.2270740E+00,& + & .2647762E+00,.2971560E+00,.6267746E-01,.6327579E-01,.8565769E-01,& + & .1189657E+00,.1582452E+00,.1977516E+00,.2372313E+00,.2766038E+00,& + & .3104162E+00,.6209896E-01,.6369481E-01,.8824714E-01,.1238764E+00,& + & .1649199E+00,.2060757E+00,.2472064E+00,.2882573E+00,.3234086E+00,& + & .7395912E-01,.7063428E-01,.8565208E-01,.1104255E+00,.1427485E+00,& + & .1783683E+00,.2139880E+00,.2495178E+00,.2828639E+00,.7228712E-01,& + & .7036097E-01,.8793923E-01,.1157395E+00,.1512413E+00,.1890002E+00,& + & .2267276E+00,.2644122E+00,.2997266E+00,.7086841E-01,.7018107E-01,& + & .9023900E-01,.1209004E+00,.1591022E+00,.1988304E+00,.2385408E+00,& + & .2781769E+00,.3153056E+00,.6982927E-01,.7021452E-01,.9257013E-01,& + & .1259826E+00,.1665897E+00,.2081673E+00,.2497368E+00,.2911947E+00,& + & .3300931E+00,.6907982E-01,.7054544E-01,.9512295E-01,.1311315E+00,& + & .1739073E+00,.2173068E+00,.2606881E+00,.3039811E+00,.3445288E+00,& + & .8336981E-01,.7909588E-01,.9293217E-01,.1163289E+00,.1478222E+00,& + & .1841644E+00,.2209570E+00,.2576676E+00,.2934903E+00,.8148502E-01,& + & .7868615E-01,.9524447E-01,.1221028E+00,.1571946E+00,.1961923E+00,& + & .2353851E+00,.2744893E+00,.3126755E+00,.7980558E-01,.7839855E-01,& + & .9757525E-01,.1277440E+00,.1659210E+00,.2072782E+00,.2486777E+00,& + & .2899782E+00,.3303130E+00,.7850723E-01,.7829446E-01,.9994420E-01,& + & .1331287E+00,.1741803E+00,.2176536E+00,.2611345E+00,.3044935E+00,& + & .3468364E+00,.7749949E-01,.7851124E-01,.1025029E+00,.1385272E+00,& + & .1822356E+00,.2277238E+00,.2731983E+00,.3185592E+00,.3628488E+00/ + + data absa(181:315, 8) / & + & .9446343E-01,.8887098E-01,.1010405E+00,.1226819E+00,.1528690E+00,& + & .1887604E+00,.2264637E+00,.2640916E+00,.3014227E+00,.9223331E-01,& + & .8827980E-01,.1033453E+00,.1288736E+00,.1629549E+00,.2021939E+00,& + & .2425871E+00,.2829079E+00,.3229151E+00,.9024155E-01,.8783436E-01,& + & .1057387E+00,.1349856E+00,.1724292E+00,.2146241E+00,.2574756E+00,& + & .3002489E+00,.3427212E+00,.8862647E-01,.8754527E-01,.1081502E+00,& + & .1408020E+00,.1814043E+00,.2262377E+00,.2714152E+00,.3165045E+00,& + & .3612330E+00,.8735280E-01,.8760876E-01,.1107602E+00,.1464752E+00,& + & .1900954E+00,.2373504E+00,.2847413E+00,.3320395E+00,.3789626E+00,& + & .1071919E+00,.1001003E+00,.1101040E+00,.1294657E+00,.1574729E+00,& + & .1915463E+00,.2292568E+00,.2673709E+00,.3054402E+00,.1045794E+00,& + & .9926080E-01,.1123922E+00,.1359833E+00,.1683351E+00,.2062283E+00,& + & .2471625E+00,.2882394E+00,.3292971E+00,.1022687E+00,.9862247E-01,& + & .1148716E+00,.1424605E+00,.1785172E+00,.2200001E+00,.2638803E+00,& + & .3077436E+00,.3515504E+00,.1003101E+00,.9811233E-01,.1173419E+00,& + & .1486525E+00,.1881373E+00,.2329575E+00,.2794837E+00,.3259493E+00,& + & .3723585E+00,.9873698E-01,.9795941E-01,.1200135E+00,.1545733E+00,& + & .1973376E+00,.2452232E+00,.2942202E+00,.3431039E+00,.3919463E+00,& + & .1214673E+00,.1126359E+00,.1204125E+00,.1370664E+00,.1621239E+00,& + & .1935142E+00,.2296249E+00,.2677842E+00,.3060416E+00,.1185186E+00,& + & .1115740E+00,.1227071E+00,.1438053E+00,.1736162E+00,.2092232E+00,& + & .2494502E+00,.2909400E+00,.3324970E+00,.1158775E+00,.1107513E+00,& + & .1251835E+00,.1505785E+00,.1844456E+00,.2241943E+00,.2681063E+00,& + & .3126858E+00,.3573659E+00,.1135645E+00,.1100550E+00,.1276724E+00,& + & .1570942E+00,.1947551E+00,.2383233E+00,.2854861E+00,.3329504E+00,& + & .3805180E+00,.1116111E+00,.1096678E+00,.1303082E+00,.1632798E+00,& + & .2045649E+00,.2516490E+00,.3017320E+00,.3519240E+00,.4021839E+00/ + + data absa(316:450, 8) / & + & .1374520E+00,.1266748E+00,.1318516E+00,.1456457E+00,.1672523E+00,& + & .1950666E+00,.2283281E+00,.2656918E+00,.3037056E+00,.1341802E+00,& + & .1254071E+00,.1340698E+00,.1526186E+00,.1792338E+00,.2117540E+00,& + & .2498928E+00,.2912047E+00,.3328745E+00,.1311544E+00,.1242569E+00,& + & .1365313E+00,.1596294E+00,.1905813E+00,.2277714E+00,.2703124E+00,& + & .3152132E+00,.3603201E+00,.1284296E+00,.1232723E+00,.1390451E+00,& + & .1663760E+00,.2014538E+00,.2429694E+00,.2894262E+00,.3375633E+00,& + & .3858525E+00,.1260194E+00,.1225869E+00,.1416527E+00,.1727500E+00,& + & .2118169E+00,.2572538E+00,.3073512E+00,.3584426E+00,.4097428E+00,& + & .1553761E+00,.1422412E+00,.1444711E+00,.1550385E+00,.1728286E+00,& + & .1965109E+00,.2258295E+00,.2610663E+00,.2984504E+00,.1516669E+00,& + & .1407304E+00,.1465588E+00,.1622080E+00,.1852388E+00,.2140019E+00,& + & .2488334E+00,.2889075E+00,.3302659E+00,.1481522E+00,.1392528E+00,& + & .1489452E+00,.1694320E+00,.1970843E+00,.2308530E+00,.2707638E+00,& + & .3150768E+00,.3601714E+00,.1448954E+00,.1379226E+00,.1514075E+00,& + & .1763709E+00,.2084024E+00,.2469639E+00,.2914326E+00,.3395756E+00,& + & .3881786E+00,.1419554E+00,.1368141E+00,.1539816E+00,.1829006E+00,& + & .2192687E+00,.2621639E+00,.3109195E+00,.3624990E+00,.4144086E+00,& + & .1748198E+00,.1592727E+00,.1584450E+00,.1657904E+00,.1799080E+00,& + & .1994836E+00,.2245418E+00,.2566689E+00,.2810339E+00,.1705294E+00,& + & .1573886E+00,.1604084E+00,.1730449E+00,.1927005E+00,.2176246E+00,& + & .2486329E+00,.2864375E+00,.3169857E+00,.1664134E+00,.1555110E+00,& + & .1626512E+00,.1803894E+00,.2049406E+00,.2351258E+00,.2717671E+00,& + & .3146346E+00,.3505565E+00,.1625805E+00,.1537499E+00,.1650044E+00,& + & .1874575E+00,.2166562E+00,.2519400E+00,.2937443E+00,.3411186E+00,& + & .3823263E+00,.1590426E+00,.1521966E+00,.1674556E+00,.1940812E+00,& + & .2278853E+00,.2678905E+00,.3145120E+00,.3659844E+00,.4129266E+00/ + + data absa(451:585, 8) / & + & .1935762E+00,.1766297E+00,.1744420E+00,.1806968E+00,.1935473E+00,& + & .2114104E+00,.2347348E+00,.2655809E+00,.2757601E+00,.1885866E+00,& + & .1741931E+00,.1762668E+00,.1880588E+00,.2064070E+00,.2298344E+00,& + & .2593418E+00,.2963843E+00,.3112482E+00,.1838929E+00,.1718429E+00,& + & .1783334E+00,.1953918E+00,.2186897E+00,.2477198E+00,.2829811E+00,& + & .3255600E+00,.3451455E+00,.1794971E+00,.1696478E+00,.1805638E+00,& + & .2022902E+00,.2305237E+00,.2647488E+00,.3054649E+00,.3531405E+00,& + & .3769471E+00,.1753728E+00,.1677953E+00,.1828746E+00,.2087886E+00,& + & .2417893E+00,.2809426E+00,.3270047E+00,.3794515E+00,.4073030E+00,& + & .2131992E+00,.1947813E+00,.1912304E+00,.1963678E+00,.2076432E+00,& + & .2236360E+00,.2450570E+00,.2741551E+00,.2789175E+00,.2074072E+00,& + & .1916172E+00,.1927506E+00,.2036992E+00,.2204764E+00,.2423112E+00,& + & .2701300E+00,.3057154E+00,.3147569E+00,.2019948E+00,.1886976E+00,& + & .1945776E+00,.2108178E+00,.2327675E+00,.2604245E+00,.2941651E+00,& + & .3357507E+00,.3491138E+00,.1968339E+00,.1860228E+00,.1965911E+00,& + & .2174692E+00,.2445952E+00,.2776478E+00,.3170335E+00,.3643697E+00,& + & .3816200E+00,.1920176E+00,.1837096E+00,.1986031E+00,.2238583E+00,& + & .2557920E+00,.2940556E+00,.3391509E+00,.3918311E+00,.4121885E+00,& + & .2332827E+00,.2134102E+00,.2085161E+00,.2124079E+00,.2219989E+00,& + & .2359574E+00,.2553647E+00,.2822947E+00,.2887838E+00,.2266775E+00,& + & .2095424E+00,.2096502E+00,.2195248E+00,.2347351E+00,.2548294E+00,& + & .2808212E+00,.3144477E+00,.3259151E+00,.2203906E+00,.2059404E+00,& + & .2111339E+00,.2263053E+00,.2469443E+00,.2730233E+00,.3051566E+00,& + & .3452396E+00,.3610131E+00,.2143742E+00,.2026221E+00,.2127678E+00,& + & .2326886E+00,.2586790E+00,.2903679E+00,.3283839E+00,.3747332E+00,& + & .3941719E+00,.2087774E+00,.1996808E+00,.2143237E+00,.2388436E+00,& + & .2697785E+00,.3069660E+00,.3509603E+00,.4031790E+00,.4260779E+00/ + + data absb( 1:120, 1) / & + & .1281000E-03,.1289100E-03,.1289000E-03,.1271300E-03,.1247700E-03,& + & .1065300E-03,.1066700E-03,.1064800E-03,.1047300E-03,.1029300E-03,& + & .9017600E-04,.9007700E-04,.8928600E-04,.8787900E-04,.8598700E-04,& + & .7770400E-04,.7730400E-04,.7587900E-04,.7424600E-04,.7207000E-04,& + & .6718300E-04,.6590600E-04,.6461900E-04,.6300000E-04,.6105600E-04,& + & .5874100E-04,.5764900E-04,.5602800E-04,.5429300E-04,.5250600E-04,& + & .5183900E-04,.5071500E-04,.4905300E-04,.4719500E-04,.4536800E-04,& + & .4432100E-04,.4329700E-04,.4192300E-04,.4029800E-04,.3874400E-04,& + & .3752700E-04,.3651600E-04,.3538000E-04,.3403700E-04,.3295100E-04,& + & .3175200E-04,.3070300E-04,.2958600E-04,.2849900E-04,.2751900E-04,& + & .2663800E-04,.2564300E-04,.2469300E-04,.2383200E-04,.2291300E-04,& + & .2232500E-04,.2148000E-04,.2062100E-04,.1986700E-04,.1906600E-04,& + & .1876400E-04,.1799800E-04,.1726900E-04,.1652700E-04,.1582100E-04,& + & .1565000E-04,.1499200E-04,.1435600E-04,.1371000E-04,.1311900E-04,& + & .1305400E-04,.1247700E-04,.1192900E-04,.1139300E-04,.1094800E-04,& + & .1085200E-04,.1039000E-04,.9919500E-05,.9502000E-05,.9199300E-05,& + & .9099000E-05,.8720900E-05,.8338400E-05,.8002900E-05,.7724500E-05,& + & .7716900E-05,.7366200E-05,.7055200E-05,.6802900E-05,.6574900E-05,& + & .6525000E-05,.6236400E-05,.6017200E-05,.5780400E-05,.5550400E-05,& + & .5516700E-05,.5302100E-05,.5108800E-05,.4911300E-05,.4715000E-05,& + & .4726100E-05,.4553000E-05,.4364100E-05,.4172500E-05,.4007700E-05,& + & .4064600E-05,.3906200E-05,.3747200E-05,.3600900E-05,.3454900E-05,& + & .3547900E-05,.3405700E-05,.3270400E-05,.3142000E-05,.3021900E-05,& + & .3135300E-05,.3027000E-05,.2902400E-05,.2777600E-05,.2660000E-05/ + + data absb(121:235, 1) / & + & .2659500E-05,.2562100E-05,.2464600E-05,.2358200E-05,.2256300E-05,& + & .2246800E-05,.2165100E-05,.2081200E-05,.2004300E-05,.1922100E-05,& + & .1900900E-05,.1833500E-05,.1768500E-05,.1703900E-05,.1640600E-05,& + & .1574600E-05,.1518800E-05,.1466900E-05,.1414800E-05,.1366800E-05,& + & .1300100E-05,.1256100E-05,.1212200E-05,.1171800E-05,.1130600E-05,& + & .1071600E-05,.1038000E-05,.1001800E-05,.9674500E-06,.9347500E-06,& + & .8765100E-06,.8517200E-06,.8245300E-06,.7956000E-06,.7701100E-06,& + & .7156500E-06,.6969900E-06,.6769900E-06,.6540300E-06,.6320200E-06,& + & .5839100E-06,.5694600E-06,.5531800E-06,.5357500E-06,.5177400E-06,& + & .4749000E-06,.4653100E-06,.4517500E-06,.4368600E-06,.4226000E-06,& + & .3871800E-06,.3761000E-06,.3665000E-06,.3558000E-06,.3441700E-06,& + & .3146400E-06,.3049400E-06,.2987200E-06,.2909600E-06,.2823000E-06,& + & .2554200E-06,.2488500E-06,.2431400E-06,.2374500E-06,.2309200E-06,& + & .2074100E-06,.2017500E-06,.1969900E-06,.1930500E-06,.1879100E-06,& + & .1676000E-06,.1640600E-06,.1599300E-06,.1563100E-06,.1532700E-06,& + & .1357900E-06,.1328700E-06,.1298500E-06,.1272500E-06,.1247000E-06,& + & .1100600E-06,.1075700E-06,.1056800E-06,.1031400E-06,.1010100E-06,& + & .8871100E-07,.8713100E-07,.8516200E-07,.8340500E-07,.8158500E-07,& + & .7088900E-07,.6991700E-07,.6869200E-07,.6746300E-07,.6604700E-07,& + & .5665900E-07,.5607700E-07,.5551800E-07,.5446200E-07,.5356300E-07,& + & .4538000E-07,.4515900E-07,.4471800E-07,.4406300E-07,.4311600E-07,& + & .3596200E-07,.3617700E-07,.3599700E-07,.3560000E-07,.3434000E-07,& + & .2857800E-07,.2892400E-07,.2890100E-07,.2817600E-07,.2724600E-07/ + + data absb( 1:120, 2) / & + & .6321500E-03,.6475600E-03,.6573400E-03,.6651500E-03,.6707700E-03,& + & .5237800E-03,.5363100E-03,.5448500E-03,.5507100E-03,.5560500E-03,& + & .4377700E-03,.4481400E-03,.4552100E-03,.4612400E-03,.4670000E-03,& + & .3702300E-03,.3786900E-03,.3856800E-03,.3907000E-03,.3976000E-03,& + & .3175300E-03,.3263200E-03,.3325400E-03,.3381700E-03,.3431200E-03,& + & .2758000E-03,.2831000E-03,.2891500E-03,.2948800E-03,.2985500E-03,& + & .2412900E-03,.2469700E-03,.2530200E-03,.2578500E-03,.2613700E-03,& + & .2047000E-03,.2104000E-03,.2155200E-03,.2196300E-03,.2226000E-03,& + & .1729000E-03,.1778200E-03,.1818800E-03,.1851300E-03,.1879400E-03,& + & .1459900E-03,.1506300E-03,.1538900E-03,.1568200E-03,.1596500E-03,& + & .1239000E-03,.1279700E-03,.1307100E-03,.1334700E-03,.1357100E-03,& + & .1055300E-03,.1087500E-03,.1113400E-03,.1135100E-03,.1151300E-03,& + & .9026300E-04,.9256000E-04,.9466700E-04,.9622500E-04,.9704100E-04,& + & .7654200E-04,.7822700E-04,.7975500E-04,.8076800E-04,.8141200E-04,& + & .6456200E-04,.6602400E-04,.6712100E-04,.6787800E-04,.6799200E-04,& + & .5458700E-04,.5566800E-04,.5643900E-04,.5677800E-04,.5664900E-04,& + & .4624800E-04,.4688500E-04,.4746900E-04,.4747600E-04,.4746400E-04,& + & .3908400E-04,.3970100E-04,.3983600E-04,.3991900E-04,.3976200E-04,& + & .3329700E-04,.3367000E-04,.3378100E-04,.3357100E-04,.3341800E-04,& + & .2847500E-04,.2847900E-04,.2835200E-04,.2820200E-04,.2810700E-04,& + & .2402300E-04,.2397700E-04,.2387400E-04,.2385800E-04,.2372900E-04,& + & .2027600E-04,.2031400E-04,.2026200E-04,.2020500E-04,.2001300E-04,& + & .1717700E-04,.1717900E-04,.1718100E-04,.1704800E-04,.1691500E-04,& + & .1458600E-04,.1463200E-04,.1456900E-04,.1446500E-04,.1440400E-04/ + + data absb(121:235, 2) / & + & .1216500E-04,.1222000E-04,.1216400E-04,.1209900E-04,.1203600E-04,& + & .1017800E-04,.1022400E-04,.1020100E-04,.1013400E-04,.1006000E-04,& + & .8562200E-05,.8582600E-05,.8552000E-05,.8510900E-05,.8437800E-05,& + & .7026300E-05,.7054900E-05,.7033400E-05,.7000000E-05,.6950000E-05,& + & .5751000E-05,.5774900E-05,.5769200E-05,.5738400E-05,.5712100E-05,& + & .4703800E-05,.4726100E-05,.4727800E-05,.4702300E-05,.4686700E-05,& + & .3824900E-05,.3833900E-05,.3849800E-05,.3836400E-05,.3812500E-05,& + & .3097300E-05,.3112000E-05,.3116600E-05,.3120300E-05,.3102200E-05,& + & .2508500E-05,.2526300E-05,.2529300E-05,.2532800E-05,.2524900E-05,& + & .2026100E-05,.2047900E-05,.2056500E-05,.2057500E-05,.2058800E-05,& + & .1631900E-05,.1663900E-05,.1674500E-05,.1674000E-05,.1675900E-05,& + & .1309700E-05,.1344900E-05,.1361100E-05,.1362400E-05,.1358900E-05,& + & .1052100E-05,.1084700E-05,.1105200E-05,.1110200E-05,.1108500E-05,& + & .8466800E-06,.8723500E-06,.8954400E-06,.9060700E-06,.9061600E-06,& + & .6806000E-06,.7018000E-06,.7218700E-06,.7356200E-06,.7380000E-06,& + & .5463400E-06,.5648100E-06,.5825600E-06,.5954300E-06,.6012200E-06,& + & .4386600E-06,.4557700E-06,.4695700E-06,.4817600E-06,.4894000E-06,& + & .3506200E-06,.3664700E-06,.3793500E-06,.3897800E-06,.3969700E-06,& + & .2788300E-06,.2951400E-06,.3039700E-06,.3125100E-06,.3200400E-06,& + & .2209800E-06,.2355000E-06,.2428900E-06,.2501800E-06,.2570800E-06,& + & .1729500E-06,.1862400E-06,.1933200E-06,.1993400E-06,.2058700E-06,& + & .1362300E-06,.1468000E-06,.1540300E-06,.1591200E-06,.1649900E-06,& + & .1086400E-06,.1168000E-06,.1235300E-06,.1284000E-06,.1335200E-06/ + + data absb( 1:120, 3) / & + & .2106900E-02,.2157100E-02,.2194300E-02,.2206100E-02,.2212400E-02,& + & .1741100E-02,.1783300E-02,.1809700E-02,.1822500E-02,.1825100E-02,& + & .1444000E-02,.1479000E-02,.1496300E-02,.1506600E-02,.1506600E-02,& + & .1199800E-02,.1226100E-02,.1239800E-02,.1250000E-02,.1248700E-02,& + & .9998000E-03,.1020200E-02,.1033200E-02,.1039900E-02,.1039200E-02,& + & .8380500E-03,.8562900E-03,.8682700E-03,.8730300E-03,.8754000E-03,& + & .7074300E-03,.7238100E-03,.7325100E-03,.7355000E-03,.7393100E-03,& + & .5934800E-03,.6057200E-03,.6113700E-03,.6149600E-03,.6176100E-03,& + & .4955600E-03,.5048800E-03,.5098700E-03,.5142100E-03,.5158100E-03,& + & .4146100E-03,.4214500E-03,.4258400E-03,.4296900E-03,.4305500E-03,& + & .3468300E-03,.3518100E-03,.3566000E-03,.3591100E-03,.3595800E-03,& + & .2900400E-03,.2938300E-03,.2978700E-03,.2996400E-03,.3004200E-03,& + & .2414600E-03,.2456100E-03,.2487900E-03,.2505300E-03,.2513400E-03,& + & .2016000E-03,.2053700E-03,.2077400E-03,.2092800E-03,.2102300E-03,& + & .1691600E-03,.1722600E-03,.1738600E-03,.1752900E-03,.1763400E-03,& + & .1418300E-03,.1441400E-03,.1460400E-03,.1474100E-03,.1484400E-03,& + & .1195400E-03,.1216100E-03,.1228600E-03,.1238600E-03,.1244800E-03,& + & .1006700E-03,.1020500E-03,.1033100E-03,.1040900E-03,.1047600E-03,& + & .8501400E-04,.8624800E-04,.8702400E-04,.8795800E-04,.8857900E-04,& + & .7193000E-04,.7307400E-04,.7398500E-04,.7493400E-04,.7484800E-04,& + & .6120500E-04,.6225900E-04,.6320900E-04,.6338300E-04,.6346600E-04,& + & .5204600E-04,.5289600E-04,.5342000E-04,.5351600E-04,.5375500E-04,& + & .4438000E-04,.4512100E-04,.4527700E-04,.4560400E-04,.4576100E-04,& + & .3805800E-04,.3840900E-04,.3865700E-04,.3881300E-04,.3862800E-04/ + + data absb(121:235, 3) / & + & .3173500E-04,.3199000E-04,.3219900E-04,.3228800E-04,.3217900E-04,& + & .2637800E-04,.2666700E-04,.2677800E-04,.2684000E-04,.2676000E-04,& + & .2194900E-04,.2219500E-04,.2234000E-04,.2233000E-04,.2228100E-04,& + & .1800100E-04,.1820900E-04,.1833800E-04,.1837600E-04,.1830900E-04,& + & .1471500E-04,.1490600E-04,.1502500E-04,.1509800E-04,.1502600E-04,& + & .1201900E-04,.1219700E-04,.1231200E-04,.1238000E-04,.1234600E-04,& + & .9756600E-05,.9931800E-05,.1003600E-04,.1009600E-04,.1011800E-04,& + & .7881000E-05,.8071600E-05,.8163700E-05,.8220200E-05,.8260800E-05,& + & .6354100E-05,.6517100E-05,.6633000E-05,.6697700E-05,.6723900E-05,& + & .5107700E-05,.5242800E-05,.5363600E-05,.5436300E-05,.5469300E-05,& + & .4088300E-05,.4219600E-05,.4319900E-05,.4407400E-05,.4446200E-05,& + & .3290900E-05,.3394100E-05,.3474600E-05,.3554600E-05,.3608900E-05,& + & .2640100E-05,.2726900E-05,.2800300E-05,.2861600E-05,.2918800E-05,& + & .2122200E-05,.2203200E-05,.2263800E-05,.2312700E-05,.2360300E-05,& + & .1705600E-05,.1783800E-05,.1838600E-05,.1880400E-05,.1913400E-05,& + & .1366200E-05,.1433300E-05,.1485500E-05,.1523800E-05,.1552100E-05,& + & .1088900E-05,.1144500E-05,.1195500E-05,.1230000E-05,.1256000E-05,& + & .8625100E-06,.9155600E-06,.9599900E-06,.9945400E-06,.1017100E-05,& + & .6864000E-06,.7286800E-06,.7738900E-06,.8062700E-06,.8269600E-06,& + & .5433400E-06,.5833900E-06,.6195300E-06,.6519000E-06,.6728500E-06,& + & .4333600E-06,.4651100E-06,.4956100E-06,.5233700E-06,.5449100E-06,& + & .3442800E-06,.3723600E-06,.3968700E-06,.4201700E-06,.4379000E-06,& + & .2788300E-06,.3023700E-06,.3209600E-06,.3397800E-06,.3548500E-06/ + + data absb( 1:120, 4) / & + & .5280600E-02,.5355100E-02,.5383600E-02,.5381000E-02,.5341300E-02,& + & .4359400E-02,.4411400E-02,.4426800E-02,.4418300E-02,.4387700E-02,& + & .3608000E-02,.3642100E-02,.3660300E-02,.3654000E-02,.3630700E-02,& + & .3000700E-02,.3032400E-02,.3047900E-02,.3037700E-02,.3017500E-02,& + & .2511300E-02,.2541500E-02,.2548900E-02,.2542800E-02,.2528100E-02,& + & .2111900E-02,.2134000E-02,.2139600E-02,.2138100E-02,.2123200E-02,& + & .1770500E-02,.1788400E-02,.1794200E-02,.1793100E-02,.1781900E-02,& + & .1471400E-02,.1485400E-02,.1492100E-02,.1492000E-02,.1487400E-02,& + & .1222400E-02,.1234900E-02,.1243200E-02,.1241100E-02,.1239500E-02,& + & .1017000E-02,.1028100E-02,.1031900E-02,.1031000E-02,.1028600E-02,& + & .8468100E-03,.8548400E-03,.8551700E-03,.8554500E-03,.8557100E-03,& + & .7033000E-03,.7087500E-03,.7107800E-03,.7126100E-03,.7111200E-03,& + & .5848100E-03,.5887000E-03,.5915700E-03,.5930500E-03,.5923400E-03,& + & .4864000E-03,.4904400E-03,.4939500E-03,.4946800E-03,.4946600E-03,& + & .4047200E-03,.4091500E-03,.4123500E-03,.4127800E-03,.4134500E-03,& + & .3382600E-03,.3420500E-03,.3436400E-03,.3448000E-03,.3452800E-03,& + & .2830800E-03,.2862700E-03,.2879200E-03,.2891000E-03,.2895800E-03,& + & .2375900E-03,.2399400E-03,.2419600E-03,.2429500E-03,.2427000E-03,& + & .1999300E-03,.2020200E-03,.2039000E-03,.2045600E-03,.2041100E-03,& + & .1685100E-03,.1706000E-03,.1715100E-03,.1716900E-03,.1713300E-03,& + & .1427500E-03,.1439200E-03,.1444500E-03,.1445200E-03,.1439900E-03,& + & .1206000E-03,.1214200E-03,.1218100E-03,.1216500E-03,.1210500E-03,& + & .1016800E-03,.1024000E-03,.1027600E-03,.1026100E-03,.1020200E-03,& + & .8578000E-04,.8663600E-04,.8681500E-04,.8678000E-04,.8672200E-04/ + + data absb(121:235, 4) / & + & .7154000E-04,.7220100E-04,.7242200E-04,.7250100E-04,.7239800E-04,& + & .5960900E-04,.6015200E-04,.6044300E-04,.6054000E-04,.6053400E-04,& + & .4968100E-04,.5019400E-04,.5048100E-04,.5064900E-04,.5064300E-04,& + & .4081500E-04,.4133500E-04,.4156500E-04,.4172900E-04,.4177600E-04,& + & .3347600E-04,.3393200E-04,.3417100E-04,.3430100E-04,.3439700E-04,& + & .2741900E-04,.2782400E-04,.2808300E-04,.2822100E-04,.2829600E-04,& + & .2234900E-04,.2275300E-04,.2297500E-04,.2310000E-04,.2316400E-04,& + & .1819700E-04,.1848800E-04,.1874700E-04,.1887800E-04,.1894300E-04,& + & .1481500E-04,.1508100E-04,.1528400E-04,.1540800E-04,.1549300E-04,& + & .1204600E-04,.1230400E-04,.1247600E-04,.1259000E-04,.1265400E-04,& + & .9783400E-05,.1001800E-04,.1018700E-04,.1029500E-04,.1036500E-04,& + & .7905800E-05,.8158300E-05,.8315800E-05,.8425900E-05,.8479100E-05,& + & .6384700E-05,.6621200E-05,.6773500E-05,.6881800E-05,.6938200E-05,& + & .5161900E-05,.5369800E-05,.5523900E-05,.5623000E-05,.5693100E-05,& + & .4176400E-05,.4354600E-05,.4501800E-05,.4592700E-05,.4660900E-05,& + & .3369600E-05,.3530200E-05,.3658500E-05,.3754800E-05,.3809100E-05,& + & .2714200E-05,.2858500E-05,.2970000E-05,.3063200E-05,.3116300E-05,& + & .2197400E-05,.2317600E-05,.2416900E-05,.2498000E-05,.2555500E-05,& + & .1782000E-05,.1882700E-05,.1964700E-05,.2034700E-05,.2089500E-05,& + & .1444500E-05,.1527400E-05,.1599900E-05,.1655800E-05,.1700400E-05,& + & .1161200E-05,.1239000E-05,.1302000E-05,.1350800E-05,.1388100E-05,& + & .9360600E-06,.1001700E-05,.1059800E-05,.1101600E-05,.1136700E-05,& + & .7668200E-06,.8231800E-06,.8728100E-06,.9120800E-06,.9403700E-06/ + + data absb( 1:120, 5) / & + & .2162906E-01,.2201877E-01,.2224013E-01,.2232097E-01,.2226088E-01,& + & .1828684E-01,.1857354E-01,.1872091E-01,.1873615E-01,.1863965E-01,& + & .1535086E-01,.1556848E-01,.1564923E-01,.1561925E-01,.1551236E-01,& + & .1285052E-01,.1299486E-01,.1303075E-01,.1299836E-01,.1289615E-01,& + & .1075316E-01,.1084397E-01,.1086973E-01,.1082689E-01,.1072798E-01,& + & .9002505E-02,.9072913E-02,.9081241E-02,.9034900E-02,.8955849E-02,& + & .7562305E-02,.7609626E-02,.7609405E-02,.7571232E-02,.7507851E-02,& + & .6329221E-02,.6362683E-02,.6359991E-02,.6325694E-02,.6271378E-02,& + & .5284028E-02,.5311691E-02,.5305973E-02,.5285178E-02,.5242950E-02,& + & .4403121E-02,.4424122E-02,.4421960E-02,.4403212E-02,.4371719E-02,& + & .3670406E-02,.3685830E-02,.3685814E-02,.3671437E-02,.3647935E-02,& + & .3056358E-02,.3068927E-02,.3067363E-02,.3057520E-02,.3043098E-02,& + & .2542912E-02,.2553558E-02,.2555470E-02,.2549363E-02,.2539078E-02,& + & .2116477E-02,.2124848E-02,.2126732E-02,.2124859E-02,.2121688E-02,& + & .1763370E-02,.1771671E-02,.1775722E-02,.1777888E-02,.1775372E-02,& + & .1472312E-02,.1480631E-02,.1485906E-02,.1489295E-02,.1490270E-02,& + & .1235246E-02,.1243142E-02,.1250718E-02,.1254010E-02,.1256275E-02,& + & .1040850E-02,.1049997E-02,.1055542E-02,.1060339E-02,.1065075E-02,& + & .8811911E-03,.8895566E-03,.8956959E-03,.9025351E-03,.9097381E-03,& + & .7497834E-03,.7578993E-03,.7659613E-03,.7738154E-03,.7827692E-03,& + & .6406593E-03,.6501363E-03,.6581906E-03,.6679566E-03,.6771392E-03,& + & .5512107E-03,.5601135E-03,.5694184E-03,.5792748E-03,.5886259E-03,& + & .4749345E-03,.4844659E-03,.4947239E-03,.5042924E-03,.5143445E-03,& + & .4104977E-03,.4207339E-03,.4309147E-03,.4409904E-03,.4509584E-03/ + + data absb(121:235, 5) / & + & .3490867E-03,.3588313E-03,.3687089E-03,.3789368E-03,.3886881E-03,& + & .2966250E-03,.3063019E-03,.3155889E-03,.3255266E-03,.3349869E-03,& + & .2526321E-03,.2616358E-03,.2706359E-03,.2802750E-03,.2890766E-03,& + & .2118746E-03,.2200243E-03,.2284269E-03,.2373129E-03,.2453378E-03,& + & .1772518E-03,.1845848E-03,.1923345E-03,.2004084E-03,.2080501E-03,& + & .1480145E-03,.1547136E-03,.1617671E-03,.1689561E-03,.1761243E-03,& + & .1228565E-03,.1288933E-03,.1351904E-03,.1417161E-03,.1481713E-03,& + & .1015563E-03,.1069125E-03,.1124515E-03,.1181336E-03,.1240966E-03,& + & .8391796E-04,.8846774E-04,.9331366E-04,.9841094E-04,.1037701E-03,& + & .6907800E-04,.7301768E-04,.7725329E-04,.8170854E-04,.8659904E-04,& + & .5663202E-04,.6003002E-04,.6370177E-04,.6762785E-04,.7189491E-04,& + & .4624238E-04,.4927219E-04,.5239730E-04,.5580819E-04,.5956741E-04,& + & .3765713E-04,.4030391E-04,.4301446E-04,.4597554E-04,.4926441E-04,& + & .3073045E-04,.3306204E-04,.3540699E-04,.3792633E-04,.4077919E-04,& + & .2508246E-04,.2707468E-04,.2909111E-04,.3125371E-04,.3371262E-04,& + & .2044678E-04,.2211599E-04,.2384933E-04,.2568808E-04,.2780633E-04,& + & .1657839E-04,.1800707E-04,.1948311E-04,.2105650E-04,.2284205E-04,& + & .1347071E-04,.1469642E-04,.1596158E-04,.1729776E-04,.1878962E-04,& + & .1095998E-04,.1197888E-04,.1307499E-04,.1421130E-04,.1546214E-04,& + & .8897744E-05,.9746282E-05,.1066740E-04,.1163972E-04,.1268761E-04,& + & .7209215E-05,.7906994E-05,.8676190E-05,.9504972E-05,.1037954E-04,& + & .5835869E-05,.6420526E-05,.7058145E-05,.7757162E-05,.8507066E-05,& + & .4829548E-05,.5320639E-05,.5859975E-05,.6447762E-05,.7091888E-05/ + + data absb( 1:120, 6) / & + & .1413456E+00,.1451118E+00,.1482471E+00,.1506848E+00,.1524351E+00,& + & .1284824E+00,.1323235E+00,.1353715E+00,.1377662E+00,.1396511E+00,& + & .1165087E+00,.1201098E+00,.1230983E+00,.1255529E+00,.1275427E+00,& + & .1056253E+00,.1090989E+00,.1120377E+00,.1145066E+00,.1165271E+00,& + & .9552257E-01,.9900700E-01,.1020287E+00,.1046013E+00,.1068915E+00,& + & .8651031E-01,.9000117E-01,.9310752E-01,.9595637E-01,.9839325E-01,& + & .7836450E-01,.8201222E-01,.8531971E-01,.8822345E-01,.9085876E-01,& + & .7092238E-01,.7459607E-01,.7796568E-01,.8111548E-01,.8403243E-01,& + & .6424556E-01,.6792949E-01,.7138543E-01,.7475690E-01,.7782387E-01,& + & .5852648E-01,.6226349E-01,.6593117E-01,.6939257E-01,.7271605E-01,& + & .5365315E-01,.5746839E-01,.6121888E-01,.6482400E-01,.6833360E-01,& + & .4952470E-01,.5342082E-01,.5723031E-01,.6098038E-01,.6470372E-01,& + & .4609148E-01,.5006244E-01,.5398056E-01,.5794359E-01,.6187053E-01,& + & .4334627E-01,.4739302E-01,.5147575E-01,.5560970E-01,.5968009E-01,& + & .4118624E-01,.4532777E-01,.4955345E-01,.5391898E-01,.5813420E-01,& + & .3952662E-01,.4385566E-01,.4826024E-01,.5268550E-01,.5705181E-01,& + & .3841724E-01,.4291105E-01,.4755308E-01,.5207099E-01,.5646855E-01,& + & .3779958E-01,.4252491E-01,.4729707E-01,.5191028E-01,.5641217E-01,& + & .3769831E-01,.4260967E-01,.4736941E-01,.5212121E-01,.5677123E-01,& + & .3802439E-01,.4300132E-01,.4793508E-01,.5274887E-01,.5740482E-01,& + & .3864580E-01,.4371453E-01,.4869077E-01,.5366066E-01,.5849903E-01,& + & .3933702E-01,.4447547E-01,.4962428E-01,.5473829E-01,.5982359E-01,& + & .3971900E-01,.4497057E-01,.5034745E-01,.5572486E-01,.6081806E-01,& + & .3964192E-01,.4514283E-01,.5071851E-01,.5624884E-01,.6141856E-01/ + + data absb(121:235, 6) / & + & .3866583E-01,.4430320E-01,.4992214E-01,.5555938E-01,.6080523E-01,& + & .3776931E-01,.4345093E-01,.4914913E-01,.5483878E-01,.6021309E-01,& + & .3697431E-01,.4267835E-01,.4846432E-01,.5419260E-01,.5971603E-01,& + & .3540090E-01,.4109817E-01,.4690264E-01,.5270132E-01,.5824775E-01,& + & .3376861E-01,.3944516E-01,.4521743E-01,.5105174E-01,.5670807E-01,& + & .3217884E-01,.3777623E-01,.4359346E-01,.4943539E-01,.5515047E-01,& + & .3023451E-01,.3578942E-01,.4155720E-01,.4739287E-01,.5322236E-01,& + & .2814056E-01,.3368562E-01,.3938021E-01,.4520123E-01,.5100155E-01,& + & .2613012E-01,.3159507E-01,.3723484E-01,.4301429E-01,.4881413E-01,& + & .2404068E-01,.2939351E-01,.3504512E-01,.4079501E-01,.4656480E-01,& + & .2179194E-01,.2706163E-01,.3260199E-01,.3830559E-01,.4403615E-01,& + & .1964345E-01,.2472402E-01,.3015571E-01,.3586422E-01,.4157514E-01,& + & .1761158E-01,.2244787E-01,.2779047E-01,.3341890E-01,.3908741E-01,& + & .1578946E-01,.2041434E-01,.2560918E-01,.3115439E-01,.3682998E-01,& + & .1410355E-01,.1854242E-01,.2353769E-01,.2895272E-01,.3464369E-01,& + & .1247313E-01,.1674870E-01,.2151305E-01,.2681285E-01,.3241759E-01,& + & .1093422E-01,.1501782E-01,.1957117E-01,.2466990E-01,.3022010E-01,& + & .9611967E-02,.1347400E-01,.1786246E-01,.2277546E-01,.2821315E-01,& + & .8428789E-02,.1205812E-01,.1629395E-01,.2103849E-01,.2627794E-01,& + & .7314617E-02,.1072816E-01,.1475277E-01,.1935069E-01,.2443117E-01,& + & .6277076E-02,.9462864E-02,.1326850E-01,.1769409E-01,.2260642E-01,& + & .5370648E-02,.8332516E-02,.1192724E-01,.1617813E-01,.2094606E-01,& + & .5000457E-02,.7850552E-02,.1134835E-01,.1553696E-01,.2024820E-01/ + + data absb( 1:120, 7) / & + & .1233797E+01,.1240309E+01,.1245906E+01,.1249038E+01,.1250667E+01,& + & .1227509E+01,.1237527E+01,.1245130E+01,.1250890E+01,.1254582E+01,& + & .1220370E+01,.1233242E+01,.1243916E+01,.1252002E+01,.1257208E+01,& + & .1209755E+01,.1226066E+01,.1239648E+01,.1251101E+01,.1262465E+01,& + & .1198271E+01,.1218221E+01,.1236549E+01,.1253105E+01,.1264757E+01,& + & .1187954E+01,.1214287E+01,.1237014E+01,.1254616E+01,.1268426E+01,& + & .1184097E+01,.1214093E+01,.1238496E+01,.1259993E+01,.1276453E+01,& + & .1180879E+01,.1213827E+01,.1241956E+01,.1265044E+01,.1281987E+01,& + & .1178298E+01,.1215263E+01,.1245209E+01,.1269051E+01,.1287376E+01,& + & .1182695E+01,.1219813E+01,.1250266E+01,.1274554E+01,.1293058E+01,& + & .1187264E+01,.1225491E+01,.1256328E+01,.1280895E+01,.1299927E+01,& + & .1193354E+01,.1231549E+01,.1262983E+01,.1287976E+01,.1307592E+01,& + & .1201358E+01,.1239017E+01,.1270766E+01,.1295922E+01,.1315914E+01,& + & .1210113E+01,.1248264E+01,.1279581E+01,.1304944E+01,.1322887E+01,& + & .1220261E+01,.1258227E+01,.1289322E+01,.1313044E+01,.1333034E+01,& + & .1231439E+01,.1268725E+01,.1298471E+01,.1322363E+01,.1344202E+01,& + & .1243861E+01,.1279684E+01,.1309193E+01,.1334435E+01,.1354444E+01,& + & .1256537E+01,.1292561E+01,.1320904E+01,.1346216E+01,.1368544E+01,& + & .1270814E+01,.1305822E+01,.1336261E+01,.1360944E+01,.1384844E+01,& + & .1288177E+01,.1321480E+01,.1350393E+01,.1377826E+01,.1400827E+01,& + & .1302859E+01,.1337128E+01,.1367775E+01,.1395784E+01,.1419468E+01,& + & .1319163E+01,.1354279E+01,.1387311E+01,.1414162E+01,.1436650E+01,& + & .1332975E+01,.1371023E+01,.1402616E+01,.1431177E+01,.1453004E+01,& + & .1345134E+01,.1383758E+01,.1415866E+01,.1445650E+01,.1471428E+01/ + + data absb(121:235, 7) / & + & .1345082E+01,.1383743E+01,.1417311E+01,.1448976E+01,.1475650E+01,& + & .1344235E+01,.1383125E+01,.1418137E+01,.1452392E+01,.1479460E+01,& + & .1345148E+01,.1385709E+01,.1420152E+01,.1456438E+01,.1484592E+01,& + & .1336140E+01,.1378290E+01,.1414883E+01,.1450315E+01,.1479273E+01,& + & .1326907E+01,.1369209E+01,.1406929E+01,.1443061E+01,.1473182E+01,& + & .1317970E+01,.1361334E+01,.1398756E+01,.1434897E+01,.1468648E+01,& + & .1307925E+01,.1351090E+01,.1391766E+01,.1425847E+01,.1460105E+01,& + & .1292135E+01,.1338462E+01,.1379193E+01,.1415171E+01,.1450080E+01,& + & .1275926E+01,.1325616E+01,.1367315E+01,.1406267E+01,.1439728E+01,& + & .1262168E+01,.1313046E+01,.1356870E+01,.1395704E+01,.1429802E+01,& + & .1243844E+01,.1297984E+01,.1345253E+01,.1384776E+01,.1423560E+01,& + & .1221932E+01,.1280865E+01,.1330001E+01,.1373395E+01,.1410813E+01,& + & .1200347E+01,.1260855E+01,.1314395E+01,.1359376E+01,.1397674E+01,& + & .1181546E+01,.1245642E+01,.1304804E+01,.1351665E+01,.1391744E+01,& + & .1161296E+01,.1229915E+01,.1291786E+01,.1343999E+01,.1385754E+01,& + & .1137476E+01,.1211401E+01,.1274402E+01,.1331651E+01,.1376935E+01,& + & .1111820E+01,.1188448E+01,.1255900E+01,.1313802E+01,.1364916E+01,& + & .1087055E+01,.1170159E+01,.1237638E+01,.1301159E+01,.1353229E+01,& + & .1062808E+01,.1149118E+01,.1221983E+01,.1285669E+01,.1342137E+01,& + & .1033591E+01,.1125023E+01,.1202761E+01,.1269609E+01,.1328922E+01,& + & .1001992E+01,.1099491E+01,.1180679E+01,.1251796E+01,.1314844E+01,& + & .9714260E+00,.1073483E+01,.1159480E+01,.1233092E+01,.1298532E+01,& + & .9605430E+00,.1062574E+01,.1153238E+01,.1229435E+01,.1295998E+01/ + + data absb( 1:120, 8) / & + & .8974716E+01,.8691653E+01,.8415802E+01,.8168444E+01,.7938743E+01,& + & .9715620E+01,.9387697E+01,.9091159E+01,.8812007E+01,.8550103E+01,& + & .1040539E+02,.1005124E+02,.9716540E+01,.9405217E+01,.9117647E+01,& + & .1107237E+02,.1067879E+02,.1030786E+02,.9949266E+01,.9577784E+01,& + & .1169578E+02,.1125483E+02,.1081775E+02,.1038726E+02,.9999236E+01,& + & .1224439E+02,.1171912E+02,.1121989E+02,.1076358E+02,.1033881E+02,& + & .1266035E+02,.1208097E+02,.1155062E+02,.1103907E+02,.1056995E+02,& + & .1303081E+02,.1240926E+02,.1182594E+02,.1128091E+02,.1079129E+02,& + & .1335386E+02,.1267661E+02,.1206291E+02,.1149646E+02,.1098015E+02,& + & .1353946E+02,.1285236E+02,.1221793E+02,.1163647E+02,.1110309E+02,& + & .1368295E+02,.1297221E+02,.1232355E+02,.1172711E+02,.1117398E+02,& + & .1377130E+02,.1305174E+02,.1238638E+02,.1177241E+02,.1119857E+02,& + & .1380231E+02,.1307928E+02,.1239887E+02,.1176960E+02,.1117753E+02,& + & .1379128E+02,.1305118E+02,.1236306E+02,.1171797E+02,.1114040E+02,& + & .1373516E+02,.1298613E+02,.1228873E+02,.1164833E+02,.1103314E+02,& + & .1364257E+02,.1288771E+02,.1219339E+02,.1154194E+02,.1089134E+02,& + & .1350900E+02,.1275874E+02,.1205091E+02,.1137192E+02,.1073702E+02,& + & .1335003E+02,.1258061E+02,.1187564E+02,.1118588E+02,.1051162E+02,& + & .1314747E+02,.1237631E+02,.1163728E+02,.1094357E+02,.1023812E+02,& + & .1288648E+02,.1212623E+02,.1139312E+02,.1065542E+02,.9954987E+01,& + & .1264609E+02,.1186159E+02,.1109721E+02,.1034029E+02,.9619395E+01,& + & .1238368E+02,.1157958E+02,.1077263E+02,.1001950E+02,.9300261E+01,& + & .1217819E+02,.1132895E+02,.1052829E+02,.9741813E+01,.9027899E+01,& + & .1202662E+02,.1116103E+02,.1034657E+02,.9538267E+01,.8771268E+01/ + + data absb(121:235, 8) / & + & .1208641E+02,.1121978E+02,.1038937E+02,.9556683E+01,.8777908E+01,& + & .1215415E+02,.1128733E+02,.1043945E+02,.9575262E+01,.8790855E+01,& + & .1219484E+02,.1131019E+02,.1047069E+02,.9582740E+01,.8782235E+01,& + & .1240319E+02,.1150569E+02,.1064514E+02,.9772131E+01,.8965666E+01,& + & .1261524E+02,.1172536E+02,.1085921E+02,.9982767E+01,.9163514E+01,& + & .1282029E+02,.1192789E+02,.1107155E+02,.1020133E+02,.9340664E+01,& + & .1305607E+02,.1217814E+02,.1129130E+02,.1045671E+02,.9593408E+01,& + & .1336869E+02,.1246260E+02,.1158864E+02,.1074016E+02,.9877648E+01,& + & .1367966E+02,.1274532E+02,.1187204E+02,.1099717E+02,.1016259E+02,& + & .1395988E+02,.1302676E+02,.1213900E+02,.1127751E+02,.1044562E+02,& + & .1430124E+02,.1334454E+02,.1243000E+02,.1157468E+02,.1069646E+02,& + & .1467926E+02,.1368264E+02,.1276261E+02,.1187105E+02,.1102298E+02,& + & .1504278E+02,.1404941E+02,.1309066E+02,.1219578E+02,.1135077E+02,& + & .1535675E+02,.1433897E+02,.1332735E+02,.1242447E+02,.1156923E+02,& + & .1567971E+02,.1462376E+02,.1359863E+02,.1264514E+02,.1177949E+02,& + & .1604096E+02,.1493692E+02,.1391760E+02,.1291724E+02,.1202255E+02,& + & .1641711E+02,.1529760E+02,.1424404E+02,.1325595E+02,.1230184E+02,& + & .1677154E+02,.1558947E+02,.1455293E+02,.1351142E+02,.1256144E+02,& + & .1711050E+02,.1590689E+02,.1481896E+02,.1379270E+02,.1280515E+02,& + & .1750874E+02,.1625687E+02,.1512545E+02,.1407639E+02,.1306970E+02,& + & .1793109E+02,.1661941E+02,.1546240E+02,.1437682E+02,.1334037E+02,& + & .1833366E+02,.1698072E+02,.1578011E+02,.1467905E+02,.1362875E+02,& + & .1847759E+02,.1713162E+02,.1587877E+02,.1475220E+02,.1369335E+02/ + +! --- + data forref(1:3,1: 8) / & + & .8605600E-06,.1304390E-05,.3823780E-05,.8179260E-06,.1585990E-05,& + & .6587710E-04,.1293690E-05,.8244060E-05,.9527780E-04,.4389180E-05,& + & .3753560E-04,.1191110E-03,.5773510E-04,.7309656E-04,.8352278E-04,& + & .2517591E-03,.2051344E-03,.5589648E-04,.3341543E-03,.2978433E-03,& + & .5905554E-04,.4375873E-03,.4018119E-03,.2342177E-03/ + + + data selfref(1:10,1: 8) / & + & .7503700E-03,.6449380E-03,.5543210E-03,.4764360E-03,.4094940E-03,& + & .3519570E-03,.3025050E-03,.2600020E-03,.2234700E-03,.1920710E-03,& + & .1361350E-02,.1131870E-02,.9410760E-03,.7824400E-03,.6505460E-03,& + & .5408850E-03,.4497090E-03,.3739020E-03,.3108740E-03,.2584710E-03,& + & .3339500E-02,.2563910E-02,.1968450E-02,.1511290E-02,.1160300E-02,& + & .8908240E-03,.6839340E-03,.5250930E-03,.4031430E-03,.3095150E-03,& + & .7933920E-02,.5898650E-02,.4385480E-02,.3260480E-02,.2424080E-02,& + & .1802230E-02,.1339910E-02,.9961860E-03,.7406360E-03,.5506420E-03,& + & .8309571E-02,.7388342E-02,.6584621E-02,.5882080E-02,.5266743E-02,& + & .4726659E-02,.4251616E-02,.3832861E-02,.3462890E-02,.3135269E-02,& + & .1297838E-01,.1251031E-01,.1206401E-01,.1163845E-01,.1123247E-01,& + & .1084516E-01,.1047551E-01,.1012259E-01,.9785517E-02,.9463545E-02,& + & .1916794E-01,.1802151E-01,.1694407E-01,.1593151E-01,.1497992E-01,& + & .1408552E-01,.1324501E-01,.1245490E-01,.1171229E-01,.1101426E-01,& + & .2508831E-01,.2343262E-01,.2189176E-01,.2045740E-01,.1912177E-01,& + & .1787778E-01,.1671886E-01,.1563887E-01,.1463222E-01,.1369363E-01/ + +!........................................! + end module module_radsw_kgb18 ! +!========================================! + +!> This module sets up absorption coeffients for band 19: 4650-5150 +!! cm-1 (low - h2o,co2; high - co2) +!========================================! + module module_radsw_kgb19 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG19 + +! + implicit none +! + private +! +!> MSA19=585 + integer, public :: MSA19 +!> MSB19=235 + integer, public :: MSB19 +!> MSF19=10 + integer, public :: MSF19 +!> MFR19=3 + integer, public :: MFR19 + parameter (MSA19=585, MSB19=235, MSF19=10, MFR19=3) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 8). + real (kind=kind_phys), public :: selfref(MSF19,NG19) + +!> the array absa(585,NG19) (ka(9,5,13,NG19)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 8, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA19,NG19) + +!> the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 8, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB19,NG19) + + real (kind=kind_phys), public :: forref(MFR19,NG19) + +!> rayleigh extinction coefficient at \f$v=4900cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 2.29e-09 + + data absa( 1:180, 1) / & + & .1498100E-05,.2665900E-05,.3187400E-05,.3550900E-05,.3759300E-05,& + & .3851400E-05,.3736900E-05,.3501100E-05,.2389400E-05,.1510300E-05,& + & .2734800E-05,.3269200E-05,.3655800E-05,.3892600E-05,.3973700E-05,& + & .3879800E-05,.3656500E-05,.2407200E-05,.1523300E-05,.2809000E-05,& + & .3374400E-05,.3772900E-05,.4025800E-05,.4110700E-05,.4038900E-05,& + & .3822600E-05,.2470400E-05,.1521900E-05,.2897800E-05,.3501500E-05,& + & .3898400E-05,.4156900E-05,.4277100E-05,.4211000E-05,.3996300E-05,& + & .2550400E-05,.1525400E-05,.2963300E-05,.3622400E-05,.4043500E-05,& + & .4297500E-05,.4441000E-05,.4384900E-05,.4184700E-05,.2642000E-05,& + & .1302400E-05,.2369900E-05,.2837000E-05,.3144300E-05,.3332600E-05,& + & .3379800E-05,.3279700E-05,.3007800E-05,.1881900E-05,.1324900E-05,& + & .2429900E-05,.2910300E-05,.3233600E-05,.3430800E-05,.3501900E-05,& + & .3404600E-05,.3132300E-05,.1951100E-05,.1324100E-05,.2505900E-05,& + & .3001900E-05,.3331700E-05,.3551600E-05,.3633300E-05,.3537200E-05,& + & .3261500E-05,.2025400E-05,.1332500E-05,.2584000E-05,.3100900E-05,& + & .3439900E-05,.3669900E-05,.3772700E-05,.3681100E-05,.3401600E-05,& + & .2061100E-05,.1332100E-05,.2660100E-05,.3218900E-05,.3564000E-05,& + & .3801200E-05,.3911300E-05,.3827100E-05,.3549900E-05,.2136800E-05,& + & .1107900E-05,.2075700E-05,.2484600E-05,.2751100E-05,.2888300E-05,& + & .2914200E-05,.2820300E-05,.2570600E-05,.1512400E-05,.1129800E-05,& + & .2127800E-05,.2555100E-05,.2830600E-05,.2981400E-05,.3012600E-05,& + & .2932800E-05,.2672100E-05,.1578400E-05,.1140500E-05,.2181200E-05,& + & .2623700E-05,.2913000E-05,.3081600E-05,.3126500E-05,.3048000E-05,& + & .2778400E-05,.1646800E-05,.1134700E-05,.2247200E-05,.2709400E-05,& + & .3005700E-05,.3182100E-05,.3253600E-05,.3171400E-05,.2883700E-05,& + & .1718900E-05,.1138300E-05,.2315200E-05,.2801600E-05,.3112600E-05,& + & .3305100E-05,.3375900E-05,.3296100E-05,.2999300E-05,.1791900E-05,& + & .9310400E-06,.1800500E-05,.2169300E-05,.2381900E-05,.2482900E-05,& + & .2486000E-05,.2386000E-05,.2158600E-05,.1219800E-05,.9459100E-06,& + & .1830900E-05,.2215300E-05,.2448700E-05,.2557400E-05,.2572100E-05,& + & .2480200E-05,.2245800E-05,.1310500E-05,.9563800E-06,.1875300E-05,& + & .2278800E-05,.2514900E-05,.2649900E-05,.2667100E-05,.2579700E-05,& + & .2333500E-05,.1401700E-05,.9576300E-06,.1937900E-05,.2327100E-05,& + & .2585800E-05,.2743700E-05,.2779200E-05,.2679000E-05,.2426800E-05,& + & .1487200E-05,.9566800E-06,.1987700E-05,.2399700E-05,.2672100E-05,& + & .2838200E-05,.2880600E-05,.2785700E-05,.2522500E-05,.1569800E-05/ + + data absa(181:315, 1) / & + & .7732900E-06,.1535400E-05,.1872300E-05,.2041100E-05,.2109500E-05,& + & .2101700E-05,.1999800E-05,.1801700E-05,.9762900E-06,.7824100E-06,& + & .1566000E-05,.1909100E-05,.2097000E-05,.2178600E-05,.2173000E-05,& + & .2079400E-05,.1873100E-05,.1064500E-05,.7946300E-06,.1594800E-05,& + & .1945800E-05,.2152900E-05,.2255700E-05,.2257600E-05,.2163100E-05,& + & .1946200E-05,.1150700E-05,.7977900E-06,.1638900E-05,.1987700E-05,& + & .2208700E-05,.2327400E-05,.2346200E-05,.2250100E-05,.2020400E-05,& + & .1236600E-05,.7987500E-06,.1686500E-05,.2041000E-05,.2278900E-05,& + & .2404900E-05,.2428300E-05,.2338800E-05,.2100600E-05,.1315500E-05,& + & .6379900E-06,.1307900E-05,.1587300E-05,.1718700E-05,.1768900E-05,& + & .1750900E-05,.1662500E-05,.1495000E-05,.7762400E-06,.6442300E-06,& + & .1318000E-05,.1617300E-05,.1764800E-05,.1825300E-05,.1815200E-05,& + & .1729900E-05,.1548200E-05,.8545700E-06,.6521400E-06,.1348100E-05,& + & .1647600E-05,.1815800E-05,.1886700E-05,.1885900E-05,.1799900E-05,& + & .1608000E-05,.9396800E-06,.6594900E-06,.1372800E-05,.1679500E-05,& + & .1861800E-05,.1950700E-05,.1956800E-05,.1869300E-05,.1671000E-05,& + & .1025600E-05,.6601200E-06,.1405100E-05,.1717400E-05,.1915400E-05,& + & .2011100E-05,.2023000E-05,.1942100E-05,.1736100E-05,.1107200E-05,& + & .5265200E-06,.1099500E-05,.1322100E-05,.1428200E-05,.1462700E-05,& + & .1449400E-05,.1375400E-05,.1235900E-05,.6239900E-06,.5263100E-06,& + & .1104700E-05,.1349800E-05,.1464600E-05,.1509400E-05,.1496100E-05,& + & .1427200E-05,.1279100E-05,.6969200E-06,.5326300E-06,.1123100E-05,& + & .1376300E-05,.1505900E-05,.1560200E-05,.1553300E-05,.1482700E-05,& + & .1325700E-05,.7695900E-06,.5378800E-06,.1144800E-05,.1402600E-05,& + & .1547800E-05,.1612200E-05,.1613700E-05,.1539800E-05,.1374800E-05,& + & .8448800E-06,.5424300E-06,.1166000E-05,.1428800E-05,.1589100E-05,& + & .1661900E-05,.1667200E-05,.1597800E-05,.1426500E-05,.9243900E-06/ + + data absa(316:450, 1) / & + & .4286000E-06,.9120800E-06,.1088700E-05,.1173200E-05,.1200000E-05,& + & .1190100E-05,.1130000E-05,.1018100E-05,.5136000E-06,.4260500E-06,& + & .9135500E-06,.1110500E-05,.1200400E-05,.1235900E-05,.1223800E-05,& + & .1167400E-05,.1049600E-05,.5859300E-06,.4291000E-06,.9245800E-06,& + & .1134100E-05,.1235500E-05,.1275400E-05,.1266700E-05,.1210000E-05,& + & .1087700E-05,.6520900E-06,.4334500E-06,.9402400E-06,.1154000E-05,& + & .1266900E-05,.1318600E-05,.1316300E-05,.1256700E-05,.1128000E-05,& + & .7205100E-06,.4374400E-06,.9584500E-06,.1176400E-05,.1302200E-05,& + & .1359500E-05,.1361800E-05,.1303400E-05,.1167100E-05,.7937300E-06,& + & .3445800E-06,.7484400E-06,.8921700E-06,.9587500E-06,.9824300E-06,& + & .9756600E-06,.9293600E-06,.8361100E-06,.4418100E-06,.3479700E-06,& + & .7530400E-06,.9081600E-06,.9826400E-06,.1008000E-05,.9988900E-06,& + & .9531800E-06,.8604100E-06,.5101300E-06,.3459300E-06,.7602000E-06,& + & .9270700E-06,.1006200E-05,.1039100E-05,.1029600E-05,.9853000E-06,& + & .8901100E-06,.5807000E-06,.3497100E-06,.7708800E-06,.9462300E-06,& + & .1034200E-05,.1072600E-05,.1068900E-05,.1021000E-05,.9202000E-06,& + & .6569700E-06,.3528200E-06,.7851700E-06,.9624500E-06,.1060900E-05,& + & .1107100E-05,.1107300E-05,.1058300E-05,.9505400E-06,.7295600E-06,& + & .2784000E-06,.6103500E-06,.7293000E-06,.7841500E-06,.8045100E-06,& + & .7992400E-06,.7623100E-06,.6872700E-06,.4020800E-06,.2817100E-06,& + & .6179800E-06,.7419700E-06,.8011500E-06,.8218300E-06,.8162100E-06,& + & .7803000E-06,.7042500E-06,.4670000E-06,.2802300E-06,.6226900E-06,& + & .7568500E-06,.8210100E-06,.8453800E-06,.8382100E-06,.8030100E-06,& + & .7266300E-06,.5378100E-06,.2816300E-06,.6315600E-06,.7721400E-06,& + & .8424400E-06,.8718400E-06,.8675200E-06,.8302400E-06,.7500000E-06,& + & .6047800E-06,.2851800E-06,.6407000E-06,.7862800E-06,.8643900E-06,& + & .8996900E-06,.8991000E-06,.8593300E-06,.7737600E-06,.6701600E-06/ + + data absa(451:585, 1) / & + & .2255500E-06,.5004200E-06,.5996000E-06,.6453700E-06,.6632400E-06,& + & .6592400E-06,.6300300E-06,.5689000E-06,.3446600E-06,.2285800E-06,& + & .5070500E-06,.6099700E-06,.6594800E-06,.6768800E-06,.6731100E-06,& + & .6446200E-06,.5833300E-06,.4030000E-06,.2267700E-06,.5117800E-06,& + & .6229900E-06,.6757200E-06,.6962400E-06,.6912600E-06,.6628500E-06,& + & .6009000E-06,.4606600E-06,.2282500E-06,.5190700E-06,.6350000E-06,& + & .6931100E-06,.7179600E-06,.7148400E-06,.6841600E-06,.6185900E-06,& + & .5196600E-06,.2312200E-06,.5259800E-06,.6457400E-06,.7111600E-06,& + & .7404600E-06,.7397900E-06,.7067200E-06,.6370800E-06,.5819600E-06,& + & .1814900E-06,.4082900E-06,.4902200E-06,.5291000E-06,.5440800E-06,& + & .5416300E-06,.5186700E-06,.4693300E-06,.2849600E-06,.1843300E-06,& + & .4137800E-06,.4990800E-06,.5402700E-06,.5552200E-06,.5528600E-06,& + & .5303800E-06,.4810300E-06,.3333600E-06,.1824600E-06,.4179900E-06,& + & .5096500E-06,.5534700E-06,.5713400E-06,.5678700E-06,.5447700E-06,& + & .4946200E-06,.3802300E-06,.1840900E-06,.4234700E-06,.5193600E-06,& + & .5674900E-06,.5887700E-06,.5864800E-06,.5614900E-06,.5082500E-06,& + & .4308100E-06,.1858200E-06,.4288800E-06,.5283000E-06,.5824000E-06,& + & .6064700E-06,.6059800E-06,.5793300E-06,.5227700E-06,.4856500E-06,& + & .1434500E-06,.3292700E-06,.3975000E-06,.4300000E-06,.4431800E-06,& + & .4420100E-06,.4246900E-06,.3853800E-06,.2337700E-06,.1457100E-06,& + & .3335500E-06,.4043000E-06,.4395400E-06,.4525600E-06,.4515900E-06,& + & .4339900E-06,.3946700E-06,.2733800E-06,.1444200E-06,.3371900E-06,& + & .4131600E-06,.4499600E-06,.4657500E-06,.4636400E-06,.4452800E-06,& + & .4051000E-06,.3115400E-06,.1460000E-06,.3414100E-06,.4213600E-06,& + & .4609600E-06,.4793700E-06,.4781700E-06,.4585000E-06,.4159800E-06,& + & .3528900E-06,.1466700E-06,.3460800E-06,.4285300E-06,.4729600E-06,& + & .4930000E-06,.4935200E-06,.4728000E-06,.4275700E-06,.3975200E-06/ + + data absa( 1:180, 2) / & + & .1628800E-04,.2581700E-04,.2959700E-04,.3131900E-04,.3122000E-04,& + & .2953900E-04,.2562700E-04,.1975800E-04,.7294400E-05,.1812300E-04,& + & .2856500E-04,.3263300E-04,.3442700E-04,.3421900E-04,.3222300E-04,& + & .2798700E-04,.2148500E-04,.7955400E-05,.1995700E-04,.3160700E-04,& + & .3603300E-04,.3788700E-04,.3769400E-04,.3539900E-04,.3071800E-04,& + & .2341200E-04,.8529300E-05,.2200500E-04,.3506400E-04,.3976300E-04,& + & .4169400E-04,.4149000E-04,.3889100E-04,.3371500E-04,.2551200E-04,& + & .9123200E-05,.2424000E-04,.3890600E-04,.4389900E-04,.4587000E-04,& + & .4558000E-04,.4261600E-04,.3691200E-04,.2772800E-04,.9779200E-05,& + & .1494400E-04,.2322300E-04,.2579200E-04,.2701900E-04,.2696300E-04,& + & .2543100E-04,.2206900E-04,.1693300E-04,.5907100E-05,.1661500E-04,& + & .2545200E-04,.2832200E-04,.2980000E-04,.2959300E-04,.2777600E-04,& + & .2412300E-04,.1844400E-04,.6314200E-05,.1835500E-04,.2799600E-04,& + & .3133800E-04,.3289200E-04,.3257500E-04,.3047800E-04,.2650400E-04,& + & .2013200E-04,.6789800E-05,.2009200E-04,.3093800E-04,.3468000E-04,& + & .3625500E-04,.3583600E-04,.3350000E-04,.2910600E-04,.2195000E-04,& + & .7334300E-05,.2189700E-04,.3415000E-04,.3827400E-04,.3993100E-04,& + & .3933700E-04,.3675200E-04,.3183100E-04,.2388200E-04,.7870500E-05,& + & .1313000E-04,.2036300E-04,.2237700E-04,.2300300E-04,.2268300E-04,& + & .2142900E-04,.1862100E-04,.1417700E-04,.4789200E-05,.1461000E-04,& + & .2229900E-04,.2448600E-04,.2514000E-04,.2484200E-04,.2341300E-04,& + & .2036100E-04,.1546900E-04,.5225000E-05,.1613300E-04,.2448200E-04,& + & .2687600E-04,.2765300E-04,.2735700E-04,.2566900E-04,.2234100E-04,& + & .1689700E-04,.5664700E-05,.1770800E-04,.2688700E-04,.2952200E-04,& + & .3057700E-04,.3015100E-04,.2822100E-04,.2454500E-04,.1845500E-04,& + & .6073500E-05,.1930500E-04,.2936400E-04,.3252000E-04,.3374100E-04,& + & .3316200E-04,.3097600E-04,.2680000E-04,.2010300E-04,.6486400E-05,& + & .1116300E-04,.1749800E-04,.1906900E-04,.1956100E-04,.1915400E-04,& + & .1790600E-04,.1552200E-04,.1177800E-04,.4046100E-05,.1250500E-04,& + & .1923800E-04,.2091700E-04,.2136500E-04,.2091300E-04,.1947100E-04,& + & .1698600E-04,.1285600E-04,.4393500E-05,.1384800E-04,.2113200E-04,& + & .2297500E-04,.2343300E-04,.2289300E-04,.2132700E-04,.1866200E-04,& + & .1405600E-04,.4701500E-05,.1521900E-04,.2315900E-04,.2525000E-04,& + & .2575300E-04,.2508800E-04,.2343700E-04,.2045500E-04,.1536600E-04,& + & .5023900E-05,.1663100E-04,.2531100E-04,.2765100E-04,.2824300E-04,& + & .2756600E-04,.2577500E-04,.2234400E-04,.1675800E-04,.5359400E-05/ + + data absa(181:315, 2) / & + & .9268800E-05,.1482900E-04,.1603600E-04,.1638800E-04,.1608700E-04,& + & .1504900E-04,.1293900E-04,.9724300E-05,.3506400E-05,.1042800E-04,& + & .1628900E-04,.1759600E-04,.1792800E-04,.1754700E-04,.1634700E-04,& + & .1410800E-04,.1062100E-04,.3789300E-05,.1160000E-04,.1792200E-04,& + & .1940300E-04,.1970100E-04,.1922700E-04,.1783500E-04,.1543900E-04,& + & .1162700E-04,.4042600E-05,.1279500E-04,.1967200E-04,.2136000E-04,& + & .2167700E-04,.2107800E-04,.1953500E-04,.1691900E-04,.1274600E-04,& + & .4301500E-05,.1402900E-04,.2155100E-04,.2341000E-04,.2374600E-04,& + & .2310600E-04,.2139700E-04,.1850000E-04,.1391800E-04,.4566300E-05,& + & .7535800E-05,.1228400E-04,.1332100E-04,.1358000E-04,.1332200E-04,& + & .1245900E-04,.1075700E-04,.8001200E-05,.2859500E-05,.8480100E-05,& + & .1354100E-04,.1460000E-04,.1485700E-04,.1451900E-04,.1352800E-04,& + & .1174700E-04,.8719900E-05,.3125000E-05,.9479700E-05,.1489800E-04,& + & .1608800E-04,.1632900E-04,.1592200E-04,.1478600E-04,.1283900E-04,& + & .9540600E-05,.3392500E-05,.1051000E-04,.1638700E-04,.1770900E-04,& + & .1796800E-04,.1746500E-04,.1620500E-04,.1399900E-04,.1046500E-04,& + & .3678600E-05,.1155400E-04,.1797300E-04,.1944200E-04,.1973600E-04,& + & .1917000E-04,.1775100E-04,.1528800E-04,.1144100E-04,.3961800E-05,& + & .5999400E-05,.1006800E-04,.1090300E-04,.1110000E-04,.1091000E-04,& + & .1020700E-04,.8830100E-05,.6575500E-05,.2353700E-05,.6791100E-05,& + & .1109800E-04,.1196400E-04,.1216100E-04,.1191000E-04,.1111300E-04,& + & .9647500E-05,.7173300E-05,.2602100E-05,.7601200E-05,.1220500E-04,& + & .1316700E-04,.1336800E-04,.1305800E-04,.1213600E-04,.1057100E-04,& + & .7845200E-05,.2841600E-05,.8458200E-05,.1341200E-04,.1451800E-04,& + & .1472100E-04,.1432800E-04,.1332300E-04,.1152700E-04,.8599500E-05,& + & .3092500E-05,.9334600E-05,.1474900E-04,.1597300E-04,.1618000E-04,& + & .1573000E-04,.1459700E-04,.1260100E-04,.9397300E-05,.3328500E-05/ + + data absa(316:450, 2) / & + & .4717400E-05,.8136700E-05,.8818400E-05,.9000700E-05,.8836300E-05,& + & .8305900E-05,.7210100E-05,.5349600E-05,.1886200E-05,.5354300E-05,& + & .8985200E-05,.9690400E-05,.9866600E-05,.9650900E-05,.9036800E-05,& + & .7870000E-05,.5834100E-05,.2114700E-05,.6008800E-05,.9885500E-05,& + & .1066600E-04,.1084900E-04,.1059700E-04,.9882600E-05,.8624300E-05,& + & .6394900E-05,.2367200E-05,.6695800E-05,.1087300E-04,.1175100E-04,& + & .1194500E-04,.1163600E-04,.1085200E-04,.9410100E-05,.7026200E-05,& + & .2632900E-05,.7419100E-05,.1196000E-04,.1294300E-04,.1315200E-04,& + & .1278800E-04,.1188900E-04,.1029700E-04,.7697700E-05,.2901900E-05,& + & .3688600E-05,.6514000E-05,.7068400E-05,.7237700E-05,.7108000E-05,& + & .6707600E-05,.5835300E-05,.4329700E-05,.1641900E-05,.4177200E-05,& + & .7210400E-05,.7779300E-05,.7933500E-05,.7768200E-05,.7290300E-05,& + & .6364000E-05,.4721000E-05,.1872100E-05,.4712300E-05,.7947100E-05,& + & .8566200E-05,.8739600E-05,.8531900E-05,.7976900E-05,.6969400E-05,& + & .5179300E-05,.2101500E-05,.5261200E-05,.8731900E-05,.9436500E-05,& + & .9619100E-05,.9378300E-05,.8758100E-05,.7627700E-05,.5697400E-05,& + & .2350500E-05,.5840100E-05,.9610600E-05,.1040400E-04,.1059400E-04,& + & .1030800E-04,.9603000E-05,.8340200E-05,.6262700E-05,.2617000E-05,& + & .2902300E-05,.5223000E-05,.5666900E-05,.5815800E-05,.5713700E-05,& + & .5424100E-05,.4741600E-05,.3509800E-05,.1422300E-05,.3275200E-05,& + & .5790300E-05,.6254800E-05,.6385900E-05,.6252800E-05,.5888100E-05,& + & .5154200E-05,.3825700E-05,.1655900E-05,.3704700E-05,.6389200E-05,& + & .6892800E-05,.7031200E-05,.6873400E-05,.6435700E-05,.5636100E-05,& + & .4200300E-05,.1924800E-05,.4147100E-05,.7017900E-05,.7592000E-05,& + & .7749600E-05,.7550800E-05,.7062400E-05,.6177800E-05,.4627100E-05,& + & .2207400E-05,.4606100E-05,.7721500E-05,.8369900E-05,.8530000E-05,& + & .8312100E-05,.7749300E-05,.6755100E-05,.5093100E-05,.2504300E-05/ + + data absa(451:585, 2) / & + & .2406000E-05,.4375200E-05,.4737200E-05,.4859800E-05,.4768900E-05,& + & .4529000E-05,.3965300E-05,.2944400E-05,.1225500E-05,.2712300E-05,& + & .4847900E-05,.5233900E-05,.5348200E-05,.5234200E-05,.4927500E-05,& + & .4323900E-05,.3219600E-05,.1428200E-05,.3063200E-05,.5340200E-05,& + & .5766000E-05,.5893600E-05,.5751500E-05,.5387300E-05,.4734400E-05,& + & .3541000E-05,.1663600E-05,.3424500E-05,.5865300E-05,.6355400E-05,& + & .6487800E-05,.6324400E-05,.5914700E-05,.5185500E-05,.3906800E-05,& + & .1885800E-05,.3798400E-05,.6455700E-05,.7003200E-05,.7143200E-05,& + & .6959100E-05,.6493600E-05,.5674800E-05,.4288900E-05,.2152900E-05,& + & .1982200E-05,.3643800E-05,.3943900E-05,.4042800E-05,.3965600E-05,& + & .3762700E-05,.3304800E-05,.2462000E-05,.1034900E-05,.2234700E-05,& + & .4032900E-05,.4355900E-05,.4453500E-05,.4355600E-05,.4101800E-05,& + & .3615600E-05,.2697600E-05,.1207800E-05,.2519600E-05,.4440500E-05,& + & .4796500E-05,.4902500E-05,.4785000E-05,.4485400E-05,.3954200E-05,& + & .2973400E-05,.1390800E-05,.2814200E-05,.4879200E-05,.5288200E-05,& + & .5396200E-05,.5264600E-05,.4920200E-05,.4322900E-05,.3281700E-05,& + & .1589500E-05,.3118200E-05,.5368400E-05,.5825600E-05,.5941300E-05,& + & .5785500E-05,.5404300E-05,.4729800E-05,.3592500E-05,.1805000E-05,& + & .1620600E-05,.3012200E-05,.3261200E-05,.3345100E-05,.3279400E-05,& + & .3114400E-05,.2743000E-05,.2048800E-05,.8526700E-06,.1826700E-05,& + & .3333100E-05,.3600200E-05,.3681600E-05,.3605400E-05,.3395000E-05,& + & .3002100E-05,.2248700E-05,.9949000E-06,.2058700E-05,.3668100E-05,& + & .3965100E-05,.4053100E-05,.3956400E-05,.3712700E-05,.3281500E-05,& + & .2479500E-05,.1142200E-05,.2297300E-05,.4032500E-05,.4372800E-05,& + & .4460000E-05,.4354000E-05,.4071800E-05,.3584800E-05,.2736600E-05,& + & .1305100E-05,.2545200E-05,.4437900E-05,.4816400E-05,.4910000E-05,& + & .4783300E-05,.4467400E-05,.3919400E-05,.2990400E-05,.1481700E-05/ + + data absa( 1:180, 3) / & + & .6664100E-04,.9299000E-04,.9627700E-04,.9518200E-04,.9142400E-04,& + & .8544500E-04,.7701400E-04,.6209100E-04,.1828400E-04,.7535000E-04,& + & .1039100E-03,.1075100E-03,.1060600E-03,.1017400E-03,.9475600E-04,& + & .8448700E-04,.6726700E-04,.2003700E-04,.8528600E-04,.1156300E-03,& + & .1196600E-03,.1177700E-03,.1125900E-03,.1043500E-03,.9207600E-04,& + & .7249200E-04,.2222900E-04,.9613700E-04,.1283600E-03,.1326500E-03,& + & .1303100E-03,.1240400E-03,.1140900E-03,.9975600E-04,.7789700E-04,& + & .2465600E-04,.1073900E-03,.1420900E-03,.1465200E-03,.1436300E-03,& + & .1357900E-03,.1240800E-03,.1074900E-03,.8327300E-04,.2699800E-04,& + & .5700500E-04,.8068800E-04,.8419900E-04,.8306700E-04,.7948000E-04,& + & .7409600E-04,.6632800E-04,.5353200E-04,.1453400E-04,.6451800E-04,& + & .9027400E-04,.9414900E-04,.9249600E-04,.8837400E-04,.8204800E-04,& + & .7269800E-04,.5787100E-04,.1620200E-04,.7301400E-04,.1006500E-03,& + & .1046600E-03,.1027100E-03,.9788000E-04,.9037200E-04,.7936100E-04,& + & .6235700E-04,.1805600E-04,.8229700E-04,.1119500E-03,.1158600E-03,& + & .1136500E-03,.1079900E-03,.9882900E-04,.8592300E-04,.6689100E-04,& + & .1989000E-04,.9217500E-04,.1239900E-03,.1279400E-03,.1253100E-03,& + & .1182500E-03,.1076400E-03,.9274400E-04,.7160800E-04,.2196800E-04,& + & .4732400E-04,.6816700E-04,.7106900E-04,.7029300E-04,.6731300E-04,& + & .6245600E-04,.5564600E-04,.4493300E-04,.1137400E-04,.5365800E-04,& + & .7634200E-04,.7956000E-04,.7854700E-04,.7499700E-04,.6926400E-04,& + & .6111900E-04,.4858700E-04,.1263900E-04,.6090500E-04,.8524700E-04,& + & .8873800E-04,.8738700E-04,.8309800E-04,.7643200E-04,.6673300E-04,& + & .5227500E-04,.1387100E-04,.6883100E-04,.9496000E-04,.9863800E-04,& + & .9677800E-04,.9181600E-04,.8374700E-04,.7240300E-04,.5616500E-04,& + & .1542300E-04,.7725900E-04,.1054900E-03,.1090900E-03,.1067200E-03,& + & .1006500E-03,.9132000E-04,.7840600E-04,.6015700E-04,.1714100E-04,& + & .4010200E-04,.5699000E-04,.5944400E-04,.5873200E-04,.5609100E-04,& + & .5190200E-04,.4624700E-04,.3744200E-04,.9402200E-05,.4493000E-04,& + & .6389300E-04,.6662900E-04,.6569400E-04,.6262700E-04,.5782200E-04,& + & .5081900E-04,.4042100E-04,.1047500E-04,.5053200E-04,.7142400E-04,& + & .7435200E-04,.7322100E-04,.6965100E-04,.6403400E-04,.5543000E-04,& + & .4352900E-04,.1172800E-04,.5695300E-04,.7974000E-04,.8276900E-04,& + & .8131400E-04,.7727800E-04,.7032400E-04,.6039600E-04,.4674700E-04,& + & .1306300E-04,.6401900E-04,.8864700E-04,.9176800E-04,.8992600E-04,& + & .8495800E-04,.7674000E-04,.6556100E-04,.5006600E-04,.1443500E-04/ + + data absa(181:315, 3) / & + & .3380600E-04,.4782600E-04,.4944300E-04,.4877500E-04,.4647700E-04,& + & .4279100E-04,.3815500E-04,.3117500E-04,.7788600E-05,.3797300E-04,& + & .5339200E-04,.5552600E-04,.5471900E-04,.5206200E-04,.4776300E-04,& + & .4202100E-04,.3351000E-04,.8740400E-05,.4275800E-04,.5966600E-04,& + & .6205800E-04,.6112700E-04,.5801200E-04,.5307100E-04,.4597100E-04,& + & .3611400E-04,.9849900E-05,.4800600E-04,.6667900E-04,.6923000E-04,& + & .6798900E-04,.6440000E-04,.5852100E-04,.5019600E-04,.3871000E-04,& + & .1102200E-04,.5365700E-04,.7424400E-04,.7681300E-04,.7530300E-04,& + & .7101100E-04,.6409200E-04,.5459900E-04,.4148100E-04,.1222500E-04,& + & .2795300E-04,.4022300E-04,.4133100E-04,.4033200E-04,.3811400E-04,& + & .3496700E-04,.3115800E-04,.2570100E-04,.6760400E-05,.3159500E-04,& + & .4497500E-04,.4637400E-04,.4522900E-04,.4277500E-04,.3916200E-04,& + & .3437300E-04,.2761600E-04,.7555800E-05,.3564900E-04,.5026300E-04,& + & .5171300E-04,.5051600E-04,.4785500E-04,.4360500E-04,.3770500E-04,& + & .2980000E-04,.8406300E-05,.4008600E-04,.5590500E-04,.5758400E-04,& + & .5634800E-04,.5320000E-04,.4828300E-04,.4133100E-04,.3193600E-04,& + & .9268600E-05,.4493100E-04,.6202500E-04,.6394200E-04,.6249800E-04,& + & .5878800E-04,.5303200E-04,.4508500E-04,.3422900E-04,.1017500E-04,& + & .2282900E-04,.3327800E-04,.3419600E-04,.3338100E-04,.3144400E-04,& + & .2861500E-04,.2533100E-04,.2109600E-04,.6073200E-05,.2591700E-04,& + & .3742400E-04,.3852700E-04,.3758000E-04,.3530200E-04,.3202000E-04,& + & .2795700E-04,.2266000E-04,.6818000E-05,.2938600E-04,.4193300E-04,& + & .4321300E-04,.4203900E-04,.3944500E-04,.3565900E-04,.3078000E-04,& + & .2443200E-04,.7629600E-05,.3318600E-04,.4681100E-04,.4821800E-04,& + & .4684900E-04,.4384800E-04,.3956700E-04,.3385800E-04,.2625700E-04,& + & .8263400E-05,.3722700E-04,.5206000E-04,.5359200E-04,.5194800E-04,& + & .4847100E-04,.4359500E-04,.3702200E-04,.2813000E-04,.9005300E-05/ + + data absa(316:450, 3) / & + & .1833300E-04,.2725900E-04,.2792900E-04,.2723000E-04,.2567200E-04,& + & .2337400E-04,.2057100E-04,.1733300E-04,.5415700E-05,.2094800E-04,& + & .3077400E-04,.3160400E-04,.3082300E-04,.2900200E-04,.2629200E-04,& + & .2273400E-04,.1859300E-04,.6166900E-05,.2388300E-04,.3464200E-04,& + & .3565600E-04,.3467000E-04,.3250700E-04,.2930300E-04,.2511100E-04,& + & .1998500E-04,.6904800E-05,.2709800E-04,.3880200E-04,.4001300E-04,& + & .3877700E-04,.3621400E-04,.3254200E-04,.2767400E-04,.2152600E-04,& + & .7659100E-05,.3046200E-04,.4330700E-04,.4459600E-04,.4312700E-04,& + & .4014200E-04,.3589000E-04,.3027600E-04,.2306500E-04,.8448000E-05,& + & .1451000E-04,.2204900E-04,.2259600E-04,.2202100E-04,.2075000E-04,& + & .1889500E-04,.1668500E-04,.1415800E-04,.5028400E-05,.1671000E-04,& + & .2501200E-04,.2568600E-04,.2501700E-04,.2353700E-04,.2135000E-04,& + & .1851700E-04,.1517000E-04,.5901600E-05,.1913800E-04,.2827100E-04,& + & .2910400E-04,.2827200E-04,.2649300E-04,.2391600E-04,.2053000E-04,& + & .1629700E-04,.6841300E-05,.2179800E-04,.3185900E-04,.3280200E-04,& + & .3176200E-04,.2960300E-04,.2664300E-04,.2265000E-04,.1755900E-04,& + & .7809300E-05,.2459900E-04,.3561800E-04,.3673600E-04,.3545600E-04,& + & .3298100E-04,.2945900E-04,.2487700E-04,.1882100E-04,.8814900E-05,& + & .1145500E-04,.1779600E-04,.1828200E-04,.1783300E-04,.1681400E-04,& + & .1530500E-04,.1352600E-04,.1162800E-04,.4763700E-05,.1329500E-04,& + & .2029000E-04,.2086200E-04,.2031600E-04,.1912500E-04,.1734800E-04,& + & .1504200E-04,.1245500E-04,.5649500E-05,.1529700E-04,.2299400E-04,& + & .2374000E-04,.2307600E-04,.2162600E-04,.1952900E-04,.1676600E-04,& + & .1339900E-04,.6598800E-05,.1748800E-04,.2598600E-04,.2688200E-04,& + & .2602100E-04,.2424600E-04,.2182000E-04,.1855400E-04,.1442700E-04,& + & .7464400E-05,.1980000E-04,.2916000E-04,.3020800E-04,.2916100E-04,& + & .2708600E-04,.2418900E-04,.2046200E-04,.1547400E-04,.8439500E-05/ + + data absa(451:585, 3) / & + & .9636600E-05,.1516800E-04,.1561100E-04,.1523000E-04,.1438100E-04,& + & .1305800E-04,.1145700E-04,.9819500E-05,.4321000E-05,.1122100E-04,& + & .1730400E-04,.1785900E-04,.1739000E-04,.1638300E-04,.1483700E-04,& + & .1282000E-04,.1054100E-04,.5091500E-05,.1292200E-04,.1961100E-04,& + & .2037600E-04,.1976900E-04,.1851000E-04,.1673300E-04,.1429700E-04,& + & .1137500E-04,.5934900E-05,.1475900E-04,.2222600E-04,.2308700E-04,& + & .2231900E-04,.2078900E-04,.1867700E-04,.1585400E-04,.1223300E-04,& + & .6864600E-05,.1668700E-04,.2490100E-04,.2589400E-04,.2502000E-04,& + & .2323400E-04,.2074600E-04,.1745000E-04,.1314300E-04,.7794500E-05,& + & .8072800E-05,.1283300E-04,.1324100E-04,.1293000E-04,.1220900E-04,& + & .1107700E-04,.9687400E-05,.8251800E-05,.3698700E-05,.9409600E-05,& + & .1464700E-04,.1517900E-04,.1478900E-04,.1392900E-04,.1261400E-04,& + & .1086300E-04,.8883900E-05,.4364200E-05,.1082700E-04,.1662500E-04,& + & .1733600E-04,.1682500E-04,.1575700E-04,.1421500E-04,.1213500E-04,& + & .9570200E-05,.5127600E-05,.1234600E-04,.1882300E-04,.1962600E-04,& + & .1901100E-04,.1771500E-04,.1589100E-04,.1347200E-04,.1029700E-04,& + & .5881800E-05,.1395400E-04,.2107100E-04,.2198500E-04,.2127800E-04,& + & .1977300E-04,.1764200E-04,.1481300E-04,.1110900E-04,.6648500E-05,& + & .6719800E-05,.1077700E-04,.1115300E-04,.1090000E-04,.1030100E-04,& + & .9334500E-05,.8143300E-05,.6915600E-05,.3049800E-05,.7828300E-05,& + & .1228300E-04,.1280500E-04,.1249200E-04,.1175700E-04,.1064900E-04,& + & .9151900E-05,.7449500E-05,.3602800E-05,.8996600E-05,.1398300E-04,& + & .1462900E-04,.1421800E-04,.1331500E-04,.1199000E-04,.1023000E-04,& + & .8023700E-05,.4238200E-05,.1025000E-04,.1579400E-04,.1653600E-04,& + & .1605500E-04,.1497900E-04,.1342100E-04,.1135500E-04,.8637100E-05,& + & .4851100E-05,.1157500E-04,.1768900E-04,.1850200E-04,.1795000E-04,& + & .1668900E-04,.1488300E-04,.1247600E-04,.9353700E-05,.5479900E-05/ + + data absa( 1:180, 4) / & + & .2031300E-03,.2641000E-03,.2705400E-03,.2584200E-03,.2379400E-03,& + & .2103300E-03,.1773000E-03,.1383100E-03,.5299500E-04,.2272200E-03,& + & .2905800E-03,.2957200E-03,.2820000E-03,.2589800E-03,.2281400E-03,& + & .1920900E-03,.1495700E-03,.5909600E-04,.2505400E-03,.3158000E-03,& + & .3199100E-03,.3048600E-03,.2795500E-03,.2463400E-03,.2078700E-03,& + & .1617900E-03,.6511800E-04,.2719700E-03,.3397100E-03,.3431000E-03,& + & .3267700E-03,.3000200E-03,.2657400E-03,.2250200E-03,.1752000E-03,& + & .7171100E-04,.2917800E-03,.3621300E-03,.3650300E-03,.3481500E-03,& + & .3211400E-03,.2859900E-03,.2432800E-03,.1895800E-03,.7852300E-04,& + & .1754700E-03,.2301200E-03,.2363900E-03,.2260600E-03,.2079900E-03,& + & .1832600E-03,.1538500E-03,.1188800E-03,.4363300E-04,.1960100E-03,& + & .2526900E-03,.2575100E-03,.2462900E-03,.2262300E-03,.1992600E-03,& + & .1671200E-03,.1287700E-03,.4838200E-04,.2159800E-03,.2742300E-03,& + & .2781200E-03,.2657600E-03,.2440300E-03,.2155200E-03,.1814100E-03,& + & .1398200E-03,.5356000E-04,.2344900E-03,.2948200E-03,.2982000E-03,& + & .2845400E-03,.2617100E-03,.2325400E-03,.1968100E-03,.1519200E-03,& + & .5905400E-04,.2519800E-03,.3140800E-03,.3172300E-03,.3034100E-03,& + & .2804000E-03,.2502200E-03,.2133300E-03,.1648700E-03,.6477900E-04,& + & .1473600E-03,.1948300E-03,.2006500E-03,.1924200E-03,.1772800E-03,& + & .1562700E-03,.1307800E-03,.1003700E-03,.3421700E-04,.1649200E-03,& + & .2144100E-03,.2189200E-03,.2098000E-03,.1928900E-03,.1700000E-03,& + & .1424900E-03,.1090200E-03,.3835200E-04,.1820000E-03,.2329400E-03,& + & .2365800E-03,.2265800E-03,.2082200E-03,.1839100E-03,.1548400E-03,& + & .1188800E-03,.4270000E-04,.1981100E-03,.2509400E-03,.2538500E-03,& + & .2427600E-03,.2233800E-03,.1984100E-03,.1682200E-03,.1294300E-03,& + & .4725700E-04,.2135200E-03,.2678400E-03,.2702700E-03,.2591700E-03,& + & .2396600E-03,.2139900E-03,.1823900E-03,.1405800E-03,.5199700E-04,& + & .1207000E-03,.1628200E-03,.1687000E-03,.1621500E-03,.1496600E-03,& + & .1319500E-03,.1100300E-03,.8374300E-04,.2684100E-04,.1361600E-03,& + & .1797900E-03,.1842000E-03,.1769200E-03,.1628800E-03,.1435100E-03,& + & .1200000E-03,.9132400E-04,.2995600E-04,.1514200E-03,.1960600E-03,& + & .1993300E-03,.1913200E-03,.1758200E-03,.1550600E-03,.1306100E-03,& + & .9988100E-04,.3317500E-04,.1659100E-03,.2117000E-03,.2142100E-03,& + & .2052500E-03,.1888800E-03,.1674700E-03,.1419200E-03,.1090700E-03,& + & .3662500E-04,.1795600E-03,.2265500E-03,.2283300E-03,.2194900E-03,& + & .2028300E-03,.1808600E-03,.1539300E-03,.1186500E-03,.4051300E-04/ + + data absa(181:315, 4) / & + & .9862500E-04,.1348000E-03,.1409900E-03,.1365300E-03,.1260000E-03,& + & .1110700E-03,.9210200E-04,.6941400E-04,.2259700E-04,.1116500E-03,& + & .1497500E-03,.1542900E-03,.1488600E-03,.1371000E-03,.1207600E-03,& + & .1005100E-03,.7604600E-04,.2526500E-04,.1246100E-03,.1639100E-03,& + & .1672500E-03,.1609100E-03,.1479600E-03,.1304700E-03,.1094100E-03,& + & .8319300E-04,.2796200E-04,.1373800E-03,.1776100E-03,.1798200E-03,& + & .1728100E-03,.1591600E-03,.1408700E-03,.1189200E-03,.9097200E-04,& + & .3085500E-04,.1496700E-03,.1906600E-03,.1923100E-03,.1850900E-03,& + & .1710900E-03,.1522700E-03,.1290600E-03,.9913600E-04,.3401700E-04,& + & .7986300E-04,.1103400E-03,.1162200E-03,.1140000E-03,.1053200E-03,& + & .9297800E-04,.7666100E-04,.5728700E-04,.1866400E-04,.9075300E-04,& + & .1231800E-03,.1276600E-03,.1244000E-03,.1148200E-03,.1011000E-03,& + & .8369700E-04,.6266300E-04,.2092800E-04,.1018300E-03,.1353200E-03,& + & .1390700E-03,.1346400E-03,.1239600E-03,.1092500E-03,.9098400E-04,& + & .6851300E-04,.2326400E-04,.1129300E-03,.1474200E-03,.1499500E-03,& + & .1448100E-03,.1335400E-03,.1179700E-03,.9884500E-04,.7496500E-04,& + & .2585000E-04,.1236000E-03,.1591400E-03,.1609000E-03,.1552100E-03,& + & .1436100E-03,.1275500E-03,.1073900E-03,.8191500E-04,.2863500E-04,& + & .6567900E-04,.9008400E-04,.9568100E-04,.9456700E-04,.8733800E-04,& + & .7727500E-04,.6364200E-04,.4709700E-04,.1550800E-04,.7455100E-04,& + & .1008900E-03,.1053100E-03,.1032700E-03,.9536400E-04,.8415400E-04,& + & .6956900E-04,.5142600E-04,.1723400E-04,.8358400E-04,.1113700E-03,& + & .1146900E-03,.1119300E-03,.1032500E-03,.9107500E-04,.7547900E-04,& + & .5622800E-04,.1912700E-04,.9276200E-04,.1217100E-03,.1242000E-03,& + & .1206000E-03,.1114700E-03,.9846500E-04,.8196900E-04,.6152900E-04,& + & .2145200E-04,.1018900E-03,.1318200E-03,.1336400E-03,.1296000E-03,& + & .1200800E-03,.1065200E-03,.8904500E-04,.6733400E-04,.2371100E-04/ + + data absa(316:450, 4) / & + & .5365600E-04,.7410900E-04,.7862900E-04,.7824500E-04,.7232200E-04,& + & .6391500E-04,.5262500E-04,.3859100E-04,.1441600E-04,.6116300E-04,& + & .8310400E-04,.8683200E-04,.8556200E-04,.7899200E-04,.6966600E-04,& + & .5757400E-04,.4209800E-04,.1592100E-04,.6891400E-04,.9190900E-04,& + & .9459400E-04,.9281600E-04,.8559000E-04,.7549100E-04,.6244500E-04,& + & .4610900E-04,.1720900E-04,.7684700E-04,.1005900E-03,.1025600E-03,& + & .1001900E-03,.9249600E-04,.8172900E-04,.6776300E-04,.5044500E-04,& + & .1858900E-04,.8484700E-04,.1090200E-03,.1107100E-03,.1078400E-03,& + & .9981200E-04,.8851600E-04,.7371800E-04,.5525000E-04,.2019400E-04,& + & .4334600E-04,.6060800E-04,.6481800E-04,.6468100E-04,.5965500E-04,& + & .5261700E-04,.4320600E-04,.3157300E-04,.1469600E-04,.4966900E-04,& + & .6838000E-04,.7180000E-04,.7086000E-04,.6526000E-04,.5749600E-04,& + & .4731300E-04,.3440500E-04,.1616400E-04,.5627400E-04,.7604000E-04,& + & .7845400E-04,.7694400E-04,.7066500E-04,.6234700E-04,.5138300E-04,& + & .3766500E-04,.1784100E-04,.6312700E-04,.8345100E-04,.8517800E-04,& + & .8308200E-04,.7643700E-04,.6753800E-04,.5579700E-04,.4126400E-04,& + & .1950400E-04,.7012400E-04,.9080700E-04,.9196000E-04,.8943200E-04,& + & .8252700E-04,.7317600E-04,.6066800E-04,.4517900E-04,.2099200E-04,& + & .3505900E-04,.4953100E-04,.5337600E-04,.5366500E-04,.4964400E-04,& + & .4359200E-04,.3560900E-04,.2584500E-04,.1323100E-04,.4037600E-04,& + & .5617400E-04,.5950200E-04,.5904000E-04,.5439900E-04,.4768700E-04,& + & .3900700E-04,.2818900E-04,.1522300E-04,.4600600E-04,.6289900E-04,& + & .6521400E-04,.6417800E-04,.5897600E-04,.5172600E-04,.4238600E-04,& + & .3084300E-04,.1724100E-04,.5190500E-04,.6939500E-04,.7098800E-04,& + & .6946100E-04,.6380100E-04,.5604000E-04,.4605900E-04,.3383100E-04,& + & .1971400E-04,.5799000E-04,.7573700E-04,.7682600E-04,.7471800E-04,& + & .6883900E-04,.6066400E-04,.5010500E-04,.3704900E-04,.2230800E-04/ + + data absa(451:585, 4) / & + & .3015000E-04,.4273800E-04,.4601100E-04,.4633000E-04,.4290700E-04,& + & .3760500E-04,.3070200E-04,.2196200E-04,.1179100E-04,.3471400E-04,& + & .4851600E-04,.5112000E-04,.5072600E-04,.4691200E-04,.4103300E-04,& + & .3350500E-04,.2395200E-04,.1324200E-04,.3964900E-04,.5432500E-04,& + & .5614600E-04,.5527000E-04,.5090200E-04,.4455900E-04,.3635100E-04,& + & .2626600E-04,.1507500E-04,.4477900E-04,.5989300E-04,.6116600E-04,& + & .5976600E-04,.5507000E-04,.4830300E-04,.3949100E-04,.2884700E-04,& + & .1716400E-04,.4994600E-04,.6541100E-04,.6625600E-04,.6434500E-04,& + & .5947400E-04,.5228700E-04,.4300300E-04,.3161200E-04,.1954200E-04,& + & .2568100E-04,.3662200E-04,.3942800E-04,.3958200E-04,.3678600E-04,& + & .3221000E-04,.2627000E-04,.1862900E-04,.1003500E-04,.2963600E-04,& + & .4162000E-04,.4370100E-04,.4342500E-04,.4015000E-04,.3510500E-04,& + & .2863700E-04,.2036500E-04,.1141600E-04,.3392100E-04,.4662800E-04,& + & .4806200E-04,.4730100E-04,.4363300E-04,.3818900E-04,.3113300E-04,& + & .2240500E-04,.1294600E-04,.3834100E-04,.5140100E-04,.5245700E-04,& + & .5112900E-04,.4723800E-04,.4142900E-04,.3390500E-04,.2454600E-04,& + & .1477000E-04,.4257600E-04,.5615300E-04,.5686300E-04,.5518200E-04,& + & .5111300E-04,.4494000E-04,.3698700E-04,.2689800E-04,.1686500E-04,& + & .2170700E-04,.3114200E-04,.3348700E-04,.3365000E-04,.3130100E-04,& + & .2739600E-04,.2235200E-04,.1574400E-04,.8300500E-05,.2511200E-04,& + & .3547400E-04,.3715800E-04,.3697000E-04,.3417000E-04,.2987100E-04,& + & .2436100E-04,.1731200E-04,.9355900E-05,.2876200E-04,.3971200E-04,& + & .4092400E-04,.4019900E-04,.3716900E-04,.3256500E-04,.2656600E-04,& + & .1907400E-04,.1067000E-04,.3244800E-04,.4380800E-04,.4473400E-04,& + & .4353400E-04,.4032300E-04,.3536700E-04,.2901100E-04,.2089700E-04,& + & .1224000E-04,.3590500E-04,.4777100E-04,.4848200E-04,.4709400E-04,& + & .4370300E-04,.3847400E-04,.3171500E-04,.2289900E-04,.1395800E-04/ + + data absa( 1:180, 5) / & + & .7617673E-03,.8971104E-03,.9278378E-03,.9076002E-03,.8545237E-03,& + & .7758218E-03,.6640038E-03,.5009860E-03,.2100718E-03,.7925828E-03,& + & .9442955E-03,.9755110E-03,.9542425E-03,.9014791E-03,.8188875E-03,& + & .7022179E-03,.5337239E-03,.2374824E-03,.8249630E-03,.9924062E-03,& + & .1024145E-02,.1003594E-02,.9497958E-03,.8633171E-03,.7423153E-03,& + & .5703062E-03,.2679147E-03,.8583524E-03,.1040661E-02,.1074578E-02,& + & .1055443E-02,.9993194E-03,.9103749E-03,.7856031E-03,.6103198E-03,& + & .3005890E-03,.8914210E-03,.1089831E-02,.1127450E-02,.1108978E-02,& + & .1051150E-02,.9598170E-03,.8317411E-03,.6540146E-03,.3372384E-03,& + & .6627779E-03,.7779969E-03,.8008718E-03,.7838334E-03,.7398886E-03,& + & .6733388E-03,.5758040E-03,.4394197E-03,.1791672E-03,.6931434E-03,& + & .8216003E-03,.8453718E-03,.8264838E-03,.7819403E-03,.7110987E-03,& + & .6107270E-03,.4698192E-03,.2021868E-03,.7240368E-03,.8657540E-03,& + & .8908257E-03,.8720081E-03,.8257095E-03,.7512371E-03,.6480081E-03,& + & .5029834E-03,.2276890E-03,.7549662E-03,.9109098E-03,.9378553E-03,& + & .9196391E-03,.8709512E-03,.7935808E-03,.6875784E-03,.5392493E-03,& + & .2558951E-03,.7854858E-03,.9570998E-03,.9870226E-03,.9682145E-03,& + & .9174446E-03,.8393444E-03,.7305754E-03,.5787675E-03,.2867225E-03,& + & .5698218E-03,.6646945E-03,.6811412E-03,.6675254E-03,.6306449E-03,& + & .5735521E-03,.4911267E-03,.3756753E-03,.1468372E-03,.5979398E-03,& + & .7039422E-03,.7219077E-03,.7061823E-03,.6682445E-03,.6070832E-03,& + & .5222789E-03,.4034172E-03,.1660478E-03,.6260630E-03,.7441821E-03,& + & .7640366E-03,.7472492E-03,.7070503E-03,.6422790E-03,.5549202E-03,& + & .4333711E-03,.1875462E-03,.6541096E-03,.7851727E-03,.8072018E-03,& + & .7903360E-03,.7475103E-03,.6804148E-03,.5905641E-03,.4657632E-03,& + & .2111058E-03,.6816820E-03,.8277472E-03,.8519631E-03,.8340047E-03,& + & .7892681E-03,.7212366E-03,.6290190E-03,.5008742E-03,.2367354E-03,& + & .4861342E-03,.5638913E-03,.5756770E-03,.5644357E-03,.5327681E-03,& + & .4835474E-03,.4138863E-03,.3179456E-03,.1189626E-03,.5113753E-03,& + & .5987845E-03,.6124007E-03,.5992699E-03,.5662793E-03,.5134428E-03,& + & .4408138E-03,.3421165E-03,.1351360E-03,.5363872E-03,.6346295E-03,& + & .6504470E-03,.6359055E-03,.6008677E-03,.5448237E-03,.4696582E-03,& + & .3682585E-03,.1527590E-03,.5608616E-03,.6715761E-03,.6895903E-03,& + & .6743859E-03,.6365185E-03,.5786033E-03,.5010073E-03,.3967389E-03,& + & .1724827E-03,.5849723E-03,.7098200E-03,.7303204E-03,.7137716E-03,& + & .6742570E-03,.6146787E-03,.5348228E-03,.4271745E-03,.1936713E-03/ + + data absa(181:315, 5) / & + & .4124715E-03,.4761738E-03,.4853020E-03,.4745565E-03,.4479021E-03,& + & .4057915E-03,.3474465E-03,.2667416E-03,.9516165E-04,.4344911E-03,& + & .5069050E-03,.5177953E-03,.5062569E-03,.4775319E-03,.4319312E-03,& + & .3702139E-03,.2876629E-03,.1085617E-03,.4559645E-03,.5386154E-03,& + & .5518018E-03,.5389479E-03,.5081875E-03,.4599769E-03,.3953892E-03,& + & .3104428E-03,.1229340E-03,.4769668E-03,.5709955E-03,.5869421E-03,& + & .5732638E-03,.5400999E-03,.4895927E-03,.4226193E-03,.3347530E-03,& + & .1391112E-03,.4977864E-03,.6042702E-03,.6230627E-03,.6084073E-03,& + & .5737828E-03,.5212317E-03,.4520350E-03,.3599815E-03,.1565328E-03,& + & .3481462E-03,.3997927E-03,.4064302E-03,.3958879E-03,.3740189E-03,& + & .3386598E-03,.2894388E-03,.2220176E-03,.7721520E-04,.3667478E-03,& + & .4264134E-03,.4347817E-03,.4238152E-03,.3999290E-03,.3615359E-03,& + & .3088615E-03,.2396985E-03,.8791758E-04,.3848509E-03,.4536800E-03,& + & .4643234E-03,.4533341E-03,.4271237E-03,.3859069E-03,.3305190E-03,& + & .2589672E-03,.9917704E-04,.4025904E-03,.4814459E-03,.4948753E-03,& + & .4836881E-03,.4553829E-03,.4119222E-03,.3539441E-03,.2788595E-03,& + & .1117935E-03,.4204129E-03,.5099243E-03,.5262683E-03,.5145801E-03,& + & .4847600E-03,.4394867E-03,.3794179E-03,.3009917E-03,.1256044E-03,& + & .2923436E-03,.3350198E-03,.3390235E-03,.3289566E-03,.3102593E-03,& + & .2807257E-03,.2400716E-03,.1841474E-03,.6514967E-04,.3079436E-03,& + & .3575834E-03,.3635135E-03,.3531948E-03,.3332576E-03,.3010207E-03,& + & .2570614E-03,.1988560E-03,.7422428E-04,.3232435E-03,.3805545E-03,& + & .3886434E-03,.3787663E-03,.3570394E-03,.3221858E-03,.2755102E-03,& + & .2150719E-03,.8445731E-04,.3383325E-03,.4040182E-03,.4144616E-03,& + & .4051543E-03,.3816543E-03,.3448001E-03,.2956857E-03,.2316464E-03,& + & .9529395E-04,.3535369E-03,.4281879E-03,.4413816E-03,.4318028E-03,& + & .4070455E-03,.3690091E-03,.3175244E-03,.2504699E-03,.1070304E-03/ + + data absa(316:450, 5) / & + & .2453512E-03,.2800882E-03,.2825252E-03,.2730919E-03,.2566169E-03,& + & .2318802E-03,.1983126E-03,.1522973E-03,.5516642E-04,.2581699E-03,& + & .2989905E-03,.3031376E-03,.2937127E-03,.2763027E-03,.2495537E-03,& + & .2126952E-03,.1646454E-03,.6300898E-04,.2707693E-03,.3182237E-03,& + & .3242581E-03,.3153146E-03,.2972863E-03,.2680977E-03,.2289101E-03,& + & .1781625E-03,.7205544E-04,.2834359E-03,.3379200E-03,.3459773E-03,& + & .3376659E-03,.3181431E-03,.2874562E-03,.2463233E-03,.1919211E-03,& + & .8179890E-04,.2961968E-03,.3584988E-03,.3687767E-03,.3605384E-03,& + & .3397168E-03,.3080263E-03,.2651369E-03,.2080999E-03,.9227521E-04,& + & .2054310E-03,.2336020E-03,.2346874E-03,.2262676E-03,.2118556E-03,& + & .1911126E-03,.1628566E-03,.1251317E-03,.5265615E-04,.2158983E-03,& + & .2491904E-03,.2518957E-03,.2435142E-03,.2286421E-03,.2061588E-03,& + & .1755758E-03,.1356394E-03,.5986972E-04,.2262897E-03,.2650278E-03,& + & .2694531E-03,.2615131E-03,.2463445E-03,.2220951E-03,.1892217E-03,& + & .1469564E-03,.6762150E-04,.2368500E-03,.2815163E-03,.2876091E-03,& + & .2802849E-03,.2643048E-03,.2385402E-03,.2043353E-03,.1585617E-03,& + & .7608500E-04,.2475469E-03,.2987922E-03,.3069398E-03,.2998091E-03,& + & .2825176E-03,.2560367E-03,.2200683E-03,.1724086E-03,.8542444E-04,& + & .1724065E-03,.1956039E-03,.1956892E-03,.1881402E-03,.1756197E-03,& + & .1579428E-03,.1342625E-03,.1031020E-03,.6401734E-04,.1809875E-03,& + & .2084355E-03,.2098304E-03,.2024866E-03,.1896267E-03,.1710181E-03,& + & .1452408E-03,.1119637E-03,.7219467E-04,.1895575E-03,.2214531E-03,& + & .2244155E-03,.2174338E-03,.2045039E-03,.1844632E-03,.1570651E-03,& + & .1214344E-03,.8097348E-04,.1983280E-03,.2351430E-03,.2396300E-03,& + & .2331386E-03,.2197000E-03,.1984522E-03,.1696161E-03,.1313673E-03,& + & .9012464E-04,.2073235E-03,.2496450E-03,.2559261E-03,.2497870E-03,& + & .2354805E-03,.2133323E-03,.1830084E-03,.1431258E-03,.9946132E-04/ + + data absa(451:585, 5) / & + & .1474531E-03,.1682762E-03,.1683793E-03,.1616613E-03,.1506254E-03,& + & .1352532E-03,.1147895E-03,.8797863E-04,.6244135E-04,.1544785E-03,& + & .1789686E-03,.1802145E-03,.1739110E-03,.1625411E-03,.1464475E-03,& + & .1243412E-03,.9584180E-04,.7111930E-04,.1616375E-03,.1899537E-03,& + & .1924972E-03,.1864886E-03,.1751900E-03,.1580145E-03,.1346723E-03,& + & .1036729E-03,.7851804E-04,.1690889E-03,.2016073E-03,.2056052E-03,& + & .2000516E-03,.1882465E-03,.1701850E-03,.1455146E-03,.1127735E-03,& + & .8728573E-04,.1768424E-03,.2142601E-03,.2196970E-03,.2143761E-03,& + & .2020742E-03,.1832716E-03,.1571724E-03,.1229344E-03,.9627397E-04,& + & .1259909E-03,.1440828E-03,.1441655E-03,.1384718E-03,.1288147E-03,& + & .1155429E-03,.9784118E-04,.7511447E-04,.5542102E-04,.1317506E-03,& + & .1530088E-03,.1541902E-03,.1487423E-03,.1390011E-03,.1250725E-03,& + & .1060741E-03,.8202844E-04,.6380787E-04,.1377366E-03,.1623281E-03,& + & .1647109E-03,.1596366E-03,.1497584E-03,.1350689E-03,.1149756E-03,& + & .8862399E-04,.7101181E-04,.1440326E-03,.1724497E-03,.1760537E-03,& + & .1714078E-03,.1610900E-03,.1456787E-03,.1244204E-03,.9651500E-04,& + & .7800418E-04,.1507641E-03,.1835052E-03,.1883108E-03,.1838011E-03,& + & .1732376E-03,.1570042E-03,.1346136E-03,.1051140E-03,.8602649E-04,& + & .1072501E-03,.1233653E-03,.1231303E-03,.1180489E-03,.1097712E-03,& + & .9835244E-04,.8317681E-04,.6399482E-04,.4621221E-04,.1121185E-03,& + & .1307584E-03,.1315510E-03,.1267530E-03,.1184196E-03,.1064469E-03,& + & .9028401E-04,.6947188E-04,.5321306E-04,.1172881E-03,.1387038E-03,& + & .1405630E-03,.1362742E-03,.1276910E-03,.1151082E-03,.9795080E-04,& + & .7537889E-04,.5873871E-04,.1228106E-03,.1473997E-03,.1504434E-03,& + & .1464443E-03,.1375481E-03,.1243899E-03,.1061458E-03,.8236870E-04,& + & .6477734E-04,.1289014E-03,.1570159E-03,.1610714E-03,.1572623E-03,& + & .1482077E-03,.1342864E-03,.1150946E-03,.8978401E-04,.7158089E-04/ + + data absa( 1:180, 6) / & + & .3618426E-02,.3641770E-02,.3630477E-02,.3560259E-02,.3416323E-02,& + & .3176047E-02,.2830864E-02,.2373983E-02,.1742217E-02,.3598081E-02,& + & .3703258E-02,.3743793E-02,.3712218E-02,.3589778E-02,.3370737E-02,& + & .3037900E-02,.2596162E-02,.1991398E-02,.3584083E-02,.3774324E-02,& + & .3866788E-02,.3867624E-02,.3769761E-02,.3570448E-02,.3255037E-02,& + & .2830185E-02,.2261505E-02,.3577298E-02,.3852926E-02,.3993744E-02,& + & .4026505E-02,.3954894E-02,.3775808E-02,.3481871E-02,.3078695E-02,& + & .2554303E-02,.3579835E-02,.3939097E-02,.4125092E-02,.4189431E-02,& + & .4145315E-02,.3990234E-02,.3720434E-02,.3340287E-02,.2865995E-02,& + & .3248394E-02,.3297351E-02,.3295356E-02,.3225177E-02,.3084542E-02,& + & .2861202E-02,.2553948E-02,.2123300E-02,.1461572E-02,.3235583E-02,& + & .3361291E-02,.3404532E-02,.3369041E-02,.3247031E-02,.3043618E-02,& + & .2745319E-02,.2323230E-02,.1677107E-02,.3231488E-02,.3436144E-02,& + & .3523056E-02,.3516391E-02,.3416868E-02,.3231131E-02,.2944369E-02,& + & .2533343E-02,.1912294E-02,.3237872E-02,.3517820E-02,.3646256E-02,& + & .3668618E-02,.3593949E-02,.3426895E-02,.3151603E-02,.2756947E-02,& + & .2166557E-02,.3253132E-02,.3606661E-02,.3773434E-02,.3826500E-02,& + & .3776601E-02,.3630583E-02,.3369967E-02,.2994163E-02,.2437904E-02,& + & .2886205E-02,.2942447E-02,.2941032E-02,.2863367E-02,.2725094E-02,& + & .2518760E-02,.2241939E-02,.1855734E-02,.1188420E-02,.2880736E-02,& + & .3006642E-02,.3042538E-02,.2997000E-02,.2874870E-02,.2685370E-02,& + & .2415558E-02,.2030078E-02,.1369150E-02,.2886508E-02,.3082007E-02,& + & .3154756E-02,.3134344E-02,.3033232E-02,.2858755E-02,.2598268E-02,& + & .2216396E-02,.1566621E-02,.2902943E-02,.3166339E-02,.3272849E-02,& + & .3277933E-02,.3197754E-02,.3039090E-02,.2789791E-02,.2414716E-02,& + & .1779400E-02,.2928623E-02,.3256730E-02,.3396972E-02,.3427808E-02,& + & .3370428E-02,.3228051E-02,.2990498E-02,.2624579E-02,.2010439E-02,& + & .2540902E-02,.2597254E-02,.2589360E-02,.2508382E-02,.2375438E-02,& + & .2188928E-02,.1938803E-02,.1600312E-02,.9604968E-03,.2542011E-02,& + & .2659586E-02,.2684388E-02,.2628952E-02,.2511349E-02,.2338234E-02,& + & .2094432E-02,.1754453E-02,.1111332E-02,.2555832E-02,.2734832E-02,& + & .2789039E-02,.2755882E-02,.2656417E-02,.2495319E-02,.2258255E-02,& + & .1919151E-02,.1276371E-02,.2581259E-02,.2819185E-02,.2901637E-02,& + & .2889786E-02,.2808889E-02,.2659442E-02,.2431576E-02,.2093659E-02,& + & .1455003E-02,.2614546E-02,.2911442E-02,.3020621E-02,.3031206E-02,& + & .2967469E-02,.2832291E-02,.2614781E-02,.2279966E-02,.1647719E-02/ + + data absa(181:315, 6) / & + & .2219972E-02,.2275081E-02,.2258189E-02,.2178017E-02,.2052724E-02,& + & .1883431E-02,.1661334E-02,.1366404E-02,.7744816E-03,.2227260E-02,& + & .2335504E-02,.2345620E-02,.2284987E-02,.2174042E-02,.2016070E-02,& + & .1799386E-02,.1503145E-02,.9005459E-03,.2248029E-02,.2409026E-02,& + & .2443618E-02,.2400559E-02,.2304822E-02,.2156227E-02,.1945494E-02,& + & .1648525E-02,.1039558E-02,.2279277E-02,.2492598E-02,.2549202E-02,& + & .2524778E-02,.2443050E-02,.2304879E-02,.2101498E-02,.1803888E-02,& + & .1189595E-02,.2314653E-02,.2584274E-02,.2663118E-02,.2656729E-02,& + & .2589557E-02,.2462949E-02,.2266082E-02,.1970673E-02,.1351586E-02,& + & .1926874E-02,.1977274E-02,.1952607E-02,.1874742E-02,.1757624E-02,& + & .1604309E-02,.1409103E-02,.1152190E-02,.6162171E-03,.1939310E-02,& + & .2034841E-02,.2032252E-02,.1970439E-02,.1864280E-02,.1719652E-02,& + & .1530483E-02,.1272154E-02,.7211166E-03,.1964743E-02,.2105464E-02,& + & .2122862E-02,.2074082E-02,.1979741E-02,.1844073E-02,.1659546E-02,& + & .1399922E-02,.8374058E-03,.1996506E-02,.2186938E-02,.2222376E-02,& + & .2187288E-02,.2103966E-02,.1977177E-02,.1797677E-02,.1537669E-02,& + & .9633722E-03,.2032972E-02,.2273283E-02,.2330136E-02,.2309382E-02,& + & .2237782E-02,.2120007E-02,.1943914E-02,.1683301E-02,.1099973E-02,& + & .1663865E-02,.1707960E-02,.1678656E-02,.1605070E-02,.1496908E-02,& + & .1359728E-02,.1186597E-02,.9637506E-03,.4837199E-03,.1679462E-02,& + & .1762213E-02,.1749710E-02,.1688780E-02,.1589709E-02,.1459287E-02,& + & .1291495E-02,.1067463E-02,.5692182E-03,.1705626E-02,.1829062E-02,& + & .1833331E-02,.1782521E-02,.1691254E-02,.1568704E-02,.1405411E-02,& + & .1178417E-02,.6634981E-03,.1737149E-02,.1904246E-02,.1926414E-02,& + & .1885283E-02,.1802747E-02,.1686750E-02,.1526571E-02,.1298759E-02,& + & .7673774E-03,.1774180E-02,.1984243E-02,.2025542E-02,.1997561E-02,& + & .1924977E-02,.1813742E-02,.1655518E-02,.1426328E-02,.8813749E-03/ + + data absa(316:450, 6) / & + & .1431715E-02,.1468745E-02,.1437010E-02,.1368212E-02,.1270165E-02,& + & .1147038E-02,.9947349E-03,.8008574E-03,.3951453E-03,.1448558E-02,& + & .1518890E-02,.1500478E-02,.1441411E-02,.1351002E-02,.1233436E-02,& + & .1085630E-02,.8898114E-03,.4614759E-03,.1473293E-02,.1580156E-02,& + & .1576676E-02,.1525332E-02,.1440556E-02,.1328775E-02,.1183815E-02,& + & .9858304E-03,.5346545E-03,.1503819E-02,.1648007E-02,.1660678E-02,& + & .1618866E-02,.1540977E-02,.1433665E-02,.1289444E-02,.1090469E-02,& + & .6144704E-03,.1540870E-02,.1721704E-02,.1750156E-02,.1719303E-02,& + & .1651341E-02,.1546906E-02,.1402428E-02,.1200202E-02,.7022918E-03,& + & .1229566E-02,.1259757E-02,.1226783E-02,.1162063E-02,.1073623E-02,& + & .9638267E-03,.8304962E-03,.6619654E-03,.3708964E-03,.1245677E-02,& + & .1304848E-02,.1282510E-02,.1226105E-02,.1143293E-02,.1038470E-02,& + & .9077754E-03,.7376031E-03,.4310410E-03,.1268666E-02,.1359022E-02,& + & .1349687E-02,.1300919E-02,.1222896E-02,.1121551E-02,.9925926E-03,& + & .8196689E-03,.4969197E-03,.1297981E-02,.1419642E-02,.1423650E-02,& + & .1383567E-02,.1312384E-02,.1213886E-02,.1083936E-02,.9092041E-03,& + & .5687180E-03,.1333382E-02,.1486555E-02,.1503607E-02,.1472905E-02,& + & .1409828E-02,.1314124E-02,.1183141E-02,.1003566E-02,.6475735E-03,& + & .1053427E-02,.1080875E-02,.1049457E-02,.9889791E-03,.9098076E-03,& + & .8127675E-03,.6957123E-03,.5493509E-03,.3851070E-03,.1068299E-02,& + & .1121177E-02,.1098614E-02,.1045290E-02,.9707095E-03,.8766135E-03,& + & .7618622E-03,.6136871E-03,.4400535E-03,.1090018E-02,.1169156E-02,& + & .1157141E-02,.1111356E-02,.1041184E-02,.9497327E-03,.8348360E-03,& + & .6839361E-03,.4994168E-03,.1118137E-02,.1223841E-02,.1222357E-02,& + & .1184095E-02,.1119621E-02,.1031067E-02,.9147253E-03,.7606201E-03,& + & .5637416E-03,.1150470E-02,.1284547E-02,.1293867E-02,.1263779E-02,& + & .1204832E-02,.1118950E-02,.1001368E-02,.8420516E-03,.6348671E-03/ + + data absa(451:585, 6) / & + & .9046486E-03,.9397347E-03,.9133460E-03,.8617363E-03,.7934190E-03,& + & .7090706E-03,.6066044E-03,.4794255E-03,.3743553E-03,.9212914E-03,& + & .9782734E-03,.9602049E-03,.9151820E-03,.8507753E-03,.7678173E-03,& + & .6660920E-03,.5356152E-03,.4226059E-03,.9442639E-03,.1023620E-02,& + & .1014658E-02,.9758938E-03,.9151114E-03,.8345845E-03,.7318442E-03,& + & .5984128E-03,.4774443E-03,.9713828E-03,.1075284E-02,.1075663E-02,& + & .1042999E-02,.9862816E-03,.9076184E-03,.8041084E-03,.6658818E-03,& + & .5353482E-03,.1002245E-02,.1131170E-02,.1142136E-02,.1116667E-02,& + & .1063668E-02,.9860813E-03,.8820903E-03,.7392501E-03,.5986885E-03,& + & .7757001E-03,.8156004E-03,.7935608E-03,.7501868E-03,.6919875E-03,& + & .6187418E-03,.5293689E-03,.4171913E-03,.3400983E-03,.7936331E-03,& + & .8519754E-03,.8374063E-03,.7995658E-03,.7443953E-03,.6725458E-03,& + & .5825365E-03,.4667964E-03,.3809920E-03,.8158134E-03,.8946178E-03,& + & .8881924E-03,.8553581E-03,.8027948E-03,.7321369E-03,.6414490E-03,& + & .5225120E-03,.4287453E-03,.8413662E-03,.9418592E-03,.9443588E-03,& + & .9171257E-03,.8676347E-03,.7974095E-03,.7054434E-03,.5826005E-03,& + & .4804212E-03,.8686293E-03,.9928428E-03,.1005484E-02,.9842193E-03,& + & .9373691E-03,.8680623E-03,.7750971E-03,.6486142E-03,.5361541E-03,& + & .6656671E-03,.7063220E-03,.6882893E-03,.6520290E-03,.6021008E-03,& + & .5393669E-03,.4616943E-03,.3624013E-03,.2876110E-03,.6827709E-03,& + & .7403802E-03,.7293362E-03,.6972791E-03,.6496824E-03,.5872587E-03,& + & .5091135E-03,.4069669E-03,.3235500E-03,.7030563E-03,.7795754E-03,& + & .7759040E-03,.7481102E-03,.7027456E-03,.6406035E-03,.5612231E-03,& + & .4560596E-03,.3644783E-03,.7249585E-03,.8222986E-03,.8269765E-03,& + & .8039916E-03,.7610904E-03,.6992438E-03,.6179241E-03,.5093407E-03,& + & .4084015E-03,.7487037E-03,.8678454E-03,.8821100E-03,.8646953E-03,& + & .8237630E-03,.7629048E-03,.6800190E-03,.5680363E-03,.4564484E-03/ + + data absa( 1:180, 7) / & + & .1944086E-01,.1794384E-01,.1665104E-01,.1551773E-01,.1445828E-01,& + & .1338923E-01,.1239141E-01,.1193783E-01,.1267749E-01,.1929939E-01,& + & .1802401E-01,.1696529E-01,.1609074E-01,.1524109E-01,.1436017E-01,& + & .1365895E-01,.1355010E-01,.1460849E-01,.1914240E-01,.1812275E-01,& + & .1733603E-01,.1672488E-01,.1609343E-01,.1543656E-01,.1506976E-01,& + & .1532896E-01,.1671755E-01,.1896990E-01,.1824026E-01,.1775719E-01,& + & .1740823E-01,.1702225E-01,.1660281E-01,.1659697E-01,.1723872E-01,& + & .1897711E-01,.1878230E-01,.1836854E-01,.1822350E-01,.1813959E-01,& + & .1798727E-01,.1786818E-01,.1824983E-01,.1930509E-01,.2141343E-01,& + & .2002304E-01,.1846205E-01,.1712703E-01,.1593023E-01,.1477768E-01,& + & .1360259E-01,.1233974E-01,.1147779E-01,.1184062E-01,.1987095E-01,& + & .1854946E-01,.1743597E-01,.1649501E-01,.1555867E-01,.1455749E-01,& + & .1351955E-01,.1298854E-01,.1367056E-01,.1970539E-01,.1864562E-01,& + & .1779988E-01,.1712573E-01,.1640112E-01,.1560634E-01,.1483953E-01,& + & .1466071E-01,.1566922E-01,.1952211E-01,.1876024E-01,.1821996E-01,& + & .1780079E-01,.1732241E-01,.1670897E-01,.1627296E-01,.1646775E-01,& + & .1781807E-01,.1932576E-01,.1888733E-01,.1868624E-01,.1852437E-01,& + & .1828787E-01,.1789646E-01,.1782466E-01,.1840912E-01,.2012300E-01,& + & .2046316E-01,.1881445E-01,.1742883E-01,.1614035E-01,.1486365E-01,& + & .1356768E-01,.1209778E-01,.1077331E-01,.1065343E-01,.2030717E-01,& + & .1890498E-01,.1772206E-01,.1668034E-01,.1562712E-01,.1448379E-01,& + & .1318643E-01,.1216891E-01,.1235738E-01,.2013274E-01,.1900626E-01,& + & .1806511E-01,.1729725E-01,.1644190E-01,.1549571E-01,.1438909E-01,& + & .1370013E-01,.1420354E-01,.1994378E-01,.1911368E-01,.1847290E-01,& + & .1795539E-01,.1733637E-01,.1657610E-01,.1569548E-01,.1535991E-01,& + & .1619433E-01,.1974273E-01,.1923315E-01,.1892487E-01,.1866106E-01,& + & .1828690E-01,.1769725E-01,.1711524E-01,.1715953E-01,.1834492E-01,& + & .2071926E-01,.1899869E-01,.1758640E-01,.1621993E-01,.1481733E-01,& + & .1340442E-01,.1178457E-01,.1005441E-01,.9415201E-02,.2056070E-01,& + & .1908468E-01,.1786585E-01,.1672760E-01,.1555529E-01,.1427366E-01,& + & .1280976E-01,.1132568E-01,.1098244E-01,.2038159E-01,.1918328E-01,& + & .1818981E-01,.1732353E-01,.1633951E-01,.1523974E-01,.1393712E-01,& + & .1273530E-01,.1270208E-01,.2019166E-01,.1930154E-01,.1857522E-01,& + & .1795884E-01,.1719737E-01,.1628902E-01,.1513446E-01,.1425698E-01,& + & .1454259E-01,.1999244E-01,.1941900E-01,.1900880E-01,.1863941E-01,& + & .1812618E-01,.1738164E-01,.1642114E-01,.1589227E-01,.1651351E-01/ + + data absa(181:315, 7) / & + & .2078596E-01,.1902221E-01,.1759185E-01,.1618479E-01,.1468286E-01,& + & .1316356E-01,.1141915E-01,.9423027E-02,.8269424E-02,.2061989E-01,& + & .1909317E-01,.1787631E-01,.1666093E-01,.1538845E-01,.1399494E-01,& + & .1238597E-01,.1057539E-01,.9705846E-02,.2044247E-01,.1918749E-01,& + & .1817839E-01,.1723098E-01,.1614137E-01,.1490895E-01,.1346159E-01,& + & .1185395E-01,.1127991E-01,.2025356E-01,.1930375E-01,.1854460E-01,& + & .1784554E-01,.1696147E-01,.1591307E-01,.1460469E-01,.1324520E-01,& + & .1297427E-01,.2007410E-01,.1943195E-01,.1896380E-01,.1849843E-01,& + & .1785367E-01,.1697392E-01,.1579435E-01,.1474526E-01,.1480343E-01,& + & .2067653E-01,.1889520E-01,.1744869E-01,.1600835E-01,.1443542E-01,& + & .1280811E-01,.1096768E-01,.8811489E-02,.7161785E-02,.2051191E-01,& + & .1895371E-01,.1772735E-01,.1645848E-01,.1509553E-01,.1360134E-01,& + & .1187179E-01,.9849619E-02,.8463973E-02,.2033498E-01,.1904213E-01,& + & .1803233E-01,.1698898E-01,.1581982E-01,.1446262E-01,.1288709E-01,& + & .1101445E-01,.9901719E-02,.2016531E-01,.1915657E-01,.1837300E-01,& + & .1758375E-01,.1659315E-01,.1541743E-01,.1398290E-01,.1227676E-01,& + & .1145224E-01,.2000011E-01,.1929718E-01,.1877422E-01,.1820930E-01,& + & .1743917E-01,.1643489E-01,.1512599E-01,.1364249E-01,.1312614E-01,& + & .2038344E-01,.1861656E-01,.1717360E-01,.1569740E-01,.1410542E-01,& + & .1238154E-01,.1046720E-01,.8234826E-02,.6157987E-02,.2021852E-01,& + & .1866243E-01,.1743952E-01,.1614631E-01,.1471423E-01,.1312828E-01,& + & .1131255E-01,.9181663E-02,.7325752E-02,.2004782E-01,.1874347E-01,& + & .1774105E-01,.1664594E-01,.1539580E-01,.1393665E-01,.1225989E-01,& + & .1024134E-01,.8627463E-02,.1988902E-01,.1886277E-01,.1808084E-01,& + & .1721183E-01,.1612179E-01,.1483288E-01,.1330233E-01,.1139021E-01,& + & .1003993E-01,.1973638E-01,.1901550E-01,.1847625E-01,.1780825E-01,& + & .1691910E-01,.1580549E-01,.1439570E-01,.1263517E-01,.1157007E-01/ + + data absa(316:450, 7) / & + & .1987279E-01,.1815516E-01,.1673357E-01,.1526588E-01,.1367570E-01,& + & .1190873E-01,.9931491E-02,.7668521E-02,.5208898E-02,.1970849E-01,& + & .1819142E-01,.1699015E-01,.1570273E-01,.1425525E-01,.1259893E-01,& + & .1071895E-01,.8538062E-02,.6255037E-02,.1954825E-01,.1826821E-01,& + & .1728456E-01,.1619427E-01,.1489632E-01,.1335233E-01,.1159816E-01,& + & .9521153E-02,.7436933E-02,.1939994E-01,.1839394E-01,.1763047E-01,& + & .1674380E-01,.1557766E-01,.1418956E-01,.1258113E-01,.1057697E-01,& + & .8728022E-02,.1926214E-01,.1855724E-01,.1803115E-01,.1732234E-01,& + & .1632534E-01,.1511381E-01,.1362321E-01,.1171409E-01,.1013851E-01,& + & .1916880E-01,.1752174E-01,.1613409E-01,.1469612E-01,.1312851E-01,& + & .1136007E-01,.9364186E-02,.7102147E-02,.4213687E-02,.1900554E-01,& + & .1754861E-01,.1637886E-01,.1511063E-01,.1368165E-01,.1201315E-01,& + & .1009580E-01,.7893303E-02,.5110717E-02,.1885316E-01,.1762136E-01,& + & .1666679E-01,.1558750E-01,.1430162E-01,.1272233E-01,.1090848E-01,& + & .8800048E-02,.6141449E-02,.1871378E-01,.1775166E-01,.1701481E-01,& + & .1613266E-01,.1495234E-01,.1350195E-01,.1182791E-01,.9791825E-02,& + & .7281500E-02,.1858911E-01,.1792329E-01,.1741640E-01,.1670595E-01,& + & .1566347E-01,.1437003E-01,.1281383E-01,.1084750E-01,.8535050E-02,& + & .1826944E-01,.1672464E-01,.1541276E-01,.1403848E-01,.1252666E-01,& + & .1078514E-01,.8823245E-02,.6591625E-02,.4177613E-02,.1810805E-01,& + & .1674909E-01,.1564423E-01,.1443382E-01,.1304370E-01,.1140669E-01,& + & .9515283E-02,.7318294E-02,.4841751E-02,.1796423E-01,.1682298E-01,& + & .1593052E-01,.1489393E-01,.1363432E-01,.1209430E-01,.1027133E-01,& + & .8153051E-02,.5674979E-02,.1783274E-01,.1695370E-01,.1627489E-01,& + & .1542379E-01,.1427771E-01,.1283692E-01,.1112848E-01,.9081882E-02,& + & .6511275E-02,.1772600E-01,.1713577E-01,.1668031E-01,.1599272E-01,& + & .1497596E-01,.1366160E-01,.1205854E-01,.1007221E-01,.7398941E-02/ + + data absa(451:585, 7) / & + & .1712738E-01,.1578625E-01,.1465104E-01,.1343124E-01,.1204735E-01,& + & .1040471E-01,.8547650E-02,.6380408E-02,.4682263E-02,.1697749E-01,& + & .1582950E-01,.1490046E-01,.1383672E-01,.1256494E-01,.1102596E-01,& + & .9230857E-02,.7091836E-02,.5424321E-02,.1684963E-01,.1592973E-01,& + & .1520871E-01,.1431627E-01,.1316095E-01,.1170953E-01,.9981803E-02,& + & .7904548E-02,.6291977E-02,.1674859E-01,.1609441E-01,.1557937E-01,& + & .1485696E-01,.1380508E-01,.1246505E-01,.1081864E-01,.8796469E-02,& + & .7234547E-02,.1667150E-01,.1630711E-01,.1601588E-01,.1543527E-01,& + & .1451902E-01,.1330051E-01,.1171274E-01,.9750545E-02,.8163171E-02,& + & .1585812E-01,.1473647E-01,.1378249E-01,.1272207E-01,.1146005E-01,& + & .9946309E-02,.8216259E-02,.6139489E-02,.4795601E-02,.1573042E-01,& + & .1480849E-01,.1405564E-01,.1313767E-01,.1198402E-01,.1056976E-01,& + & .8883654E-02,.6832310E-02,.5569244E-02,.1562948E-01,.1493848E-01,& + & .1438406E-01,.1362526E-01,.1258929E-01,.1125212E-01,.9629528E-02,& + & .7616188E-02,.6452525E-02,.1556093E-01,.1513902E-01,.1478476E-01,& + & .1418150E-01,.1324034E-01,.1201861E-01,.1045886E-01,.8467010E-02,& + & .7448495E-02,.1552707E-01,.1538861E-01,.1525660E-01,.1477573E-01,& + & .1397485E-01,.1285192E-01,.1132600E-01,.9383049E-02,.8380165E-02,& + & .1451815E-01,.1362323E-01,.1284326E-01,.1193288E-01,.1079141E-01,& + & .9422285E-02,.7828749E-02,.5876279E-02,.4564233E-02,.1441454E-01,& + & .1372037E-01,.1313620E-01,.1235490E-01,.1132640E-01,.1004968E-01,& + & .8482915E-02,.6542489E-02,.5277165E-02,.1434814E-01,.1388758E-01,& + & .1349254E-01,.1286003E-01,.1193607E-01,.1073461E-01,.9223888E-02,& + & .7293736E-02,.6181241E-02,.1432181E-01,.1412637E-01,.1392568E-01,& + & .1342872E-01,.1260305E-01,.1150145E-01,.1004198E-01,.8104002E-02,& + & .7114973E-02,.1432961E-01,.1441453E-01,.1442859E-01,.1404464E-01,& + & .1335348E-01,.1232881E-01,.1089297E-01,.8984991E-02,.8052181E-02/ + + data absa( 1:180, 8) / & + & .7758517E-01,.6971744E-01,.6856234E-01,.7085104E-01,.7686968E-01,& + & .8798079E-01,.1038826E+00,.1198350E+00,.1359548E+00,.7760111E-01,& + & .7121281E-01,.7343034E-01,.7934822E-01,.9017738E-01,.1066736E+00,& + & .1269235E+00,.1465907E+00,.1664556E+00,.7752743E-01,.7302330E-01,& + & .7902576E-01,.8954413E-01,.1059545E+00,.1282979E+00,.1531287E+00,& + & .1770168E+00,.2010905E+00,.7732969E-01,.7518701E-01,.8549302E-01,& + & .1015046E+00,.1240275E+00,.1528286E+00,.1826322E+00,.2112286E+00,& + & .2400654E+00,.7704248E-01,.7773694E-01,.9279924E-01,.1151544E+00,& + & .1447190E+00,.1798906E+00,.2150779E+00,.2488116E+00,.2828065E+00,& + & .8996337E-01,.8019925E-01,.7649483E-01,.7619075E-01,.7950947E-01,& + & .8744378E-01,.1013048E+00,.1167488E+00,.1333495E+00,.9002593E-01,& + & .8150228E-01,.8115314E-01,.8427387E-01,.9208357E-01,.1052256E+00,& + & .1239442E+00,.1430385E+00,.1634839E+00,.8993043E-01,.8319207E-01,& + & .8655274E-01,.9399363E-01,.1071792E+00,.1260258E+00,.1498926E+00,& + & .1732190E+00,.1980122E+00,.8971818E-01,.8524906E-01,.9277644E-01,& + & .1055693E+00,.1245408E+00,.1502414E+00,.1793335E+00,.2072943E+00,& + & .2370216E+00,.8937589E-01,.8770760E-01,.9989309E-01,.1188472E+00,& + & .1444723E+00,.1773019E+00,.2118836E+00,.2451113E+00,.2803148E+00,& + & .1035251E+00,.9170912E-01,.8469424E-01,.8124545E-01,.8127330E-01,& + & .8520134E-01,.9536063E-01,.1094892E+00,.1259212E+00,.1036314E+00,& + & .9276163E-01,.8901665E-01,.8866608E-01,.9260241E-01,.1015125E+00,& + & .1166863E+00,.1344219E+00,.1546172E+00,.1035650E+00,.9415806E-01,& + & .9411336E-01,.9760915E-01,.1066039E+00,.1208833E+00,.1416737E+00,& + & .1635528E+00,.1881599E+00,.1033569E+00,.9604690E-01,.9993466E-01,& + & .1084464E+00,.1229492E+00,.1435592E+00,.1703234E+00,.1968385E+00,& + & .2265370E+00,.1029798E+00,.9835979E-01,.1066697E+00,.1210700E+00,& + & .1417416E+00,.1696560E+00,.2023878E+00,.2340132E+00,.2693038E+00,& + & .1182256E+00,.1042918E+00,.9385612E-01,.8708706E-01,.8392123E-01,& + & .8386827E-01,.8993733E-01,.1021139E+00,.1178700E+00,.1183624E+00,& + & .1051802E+00,.9770525E-01,.9387938E-01,.9397963E-01,.9866810E-01,& + & .1093764E+00,.1253639E+00,.1447078E+00,.1183448E+00,.1063559E+00,& + & .1024326E+00,.1020095E+00,.1067911E+00,.1165316E+00,.1326917E+00,& + & .1528199E+00,.1764343E+00,.1181015E+00,.1078331E+00,.1078798E+00,& + & .1120521E+00,.1219908E+00,.1374912E+00,.1601454E+00,.1848559E+00,& + & .2134132E+00,.1177256E+00,.1098961E+00,.1142273E+00,.1239094E+00,& + & .1395842E+00,.1620158E+00,.1913771E+00,.2212322E+00,.2554318E+00/ + + data absa(181:315, 8) / & + & .1337645E+00,.1176975E+00,.1042174E+00,.9408829E-01,.8780506E-01,& + & .8428291E-01,.8648117E-01,.9578625E-01,.1107310E+00,.1340095E+00,& + & .1185612E+00,.1073992E+00,.1002667E+00,.9676787E-01,.9754447E-01,& + & .1041226E+00,.1173533E+00,.1356505E+00,.1339933E+00,.1195717E+00,& + & .1117737E+00,.1076768E+00,.1084293E+00,.1139755E+00,.1254459E+00,& + & .1433024E+00,.1656569E+00,.1337898E+00,.1208507E+00,.1168604E+00,& + & .1168941E+00,.1225882E+00,.1334602E+00,.1509971E+00,.1738575E+00,& + & .2010332E+00,.1333402E+00,.1225783E+00,.1227702E+00,.1280534E+00,& + & .1390939E+00,.1563754E+00,.1810270E+00,.2089873E+00,.2415778E+00,& + & .1499294E+00,.1316511E+00,.1153149E+00,.1019770E+00,.9253012E-01,& + & .8589064E-01,.8430058E-01,.8998453E-01,.1039889E+00,.1502123E+00,& + & .1324781E+00,.1179942E+00,.1074361E+00,.1005474E+00,.9758469E-01,& + & .1000820E+00,.1097714E+00,.1269049E+00,.1502509E+00,.1333737E+00,& + & .1216948E+00,.1142169E+00,.1109667E+00,.1125131E+00,.1194607E+00,& + & .1338501E+00,.1548471E+00,.1500164E+00,.1344800E+00,.1264420E+00,& + & .1225692E+00,.1240810E+00,.1304661E+00,.1429117E+00,.1627629E+00,& + & .1883115E+00,.1495747E+00,.1359816E+00,.1319394E+00,.1329504E+00,& + & .1395630E+00,.1517775E+00,.1709091E+00,.1964203E+00,.2271878E+00,& + & .1667524E+00,.1461966E+00,.1270922E+00,.1109576E+00,.9817555E-01,& + & .8876777E-01,.8374701E-01,.8543513E-01,.9818294E-01,.1671368E+00,& + & .1470313E+00,.1293919E+00,.1154650E+00,.1053506E+00,.9907389E-01,& + & .9777459E-01,.1033433E+00,.1192365E+00,.1672667E+00,.1478601E+00,& + & .1325480E+00,.1215247E+00,.1147604E+00,.1125732E+00,.1153357E+00,& + & .1255724E+00,.1452073E+00,.1670804E+00,.1488123E+00,.1366626E+00,& + & .1291483E+00,.1268401E+00,.1291153E+00,.1368015E+00,.1526760E+00,& + & .1766400E+00,.1666531E+00,.1500830E+00,.1416654E+00,.1387987E+00,& + & .1413161E+00,.1488921E+00,.1627763E+00,.1846442E+00,.2135966E+00/ + + data absa(316:450, 8) / & + & .1846850E+00,.1617527E+00,.1399797E+00,.1208986E+00,.1049700E+00,& + & .9268890E-01,.8468015E-01,.8250239E-01,.9346009E-01,.1852004E+00,& + & .1626022E+00,.1419177E+00,.1246679E+00,.1111616E+00,.1018673E+00,& + & .9711144E-01,.9858998E-01,.1128165E+00,.1854002E+00,.1633815E+00,& + & .1446073E+00,.1298548E+00,.1195851E+00,.1140911E+00,.1130781E+00,& + & .1187616E+00,.1368729E+00,.1852584E+00,.1641980E+00,.1481385E+00,& + & .1365970E+00,.1306723E+00,.1293064E+00,.1327425E+00,.1439504E+00,& + & .1663864E+00,.1848096E+00,.1652487E+00,.1525559E+00,.1454722E+00,& + & .1442002E+00,.1476584E+00,.1567932E+00,.1741988E+00,.2014170E+00,& + & .2035660E+00,.1782138E+00,.1538641E+00,.1319292E+00,.1129603E+00,& + & .9769919E-01,.8663861E-01,.8077073E-01,.8932903E-01,.2042261E+00,& + & .1790867E+00,.1555132E+00,.1351430E+00,.1182459E+00,.1056510E+00,& + & .9764716E-01,.9524493E-01,.1071831E+00,.2045296E+00,.1798786E+00,& + & .1578247E+00,.1395652E+00,.1254969E+00,.1165399E+00,.1121007E+00,& + & .1135498E+00,.1294885E+00,.2044541E+00,.1805616E+00,.1608548E+00,& + & .1453947E+00,.1354455E+00,.1305073E+00,.1300663E+00,.1365302E+00,& + & .1570562E+00,.2040215E+00,.1814068E+00,.1647421E+00,.1533244E+00,& + & .1479662E+00,.1475364E+00,.1523061E+00,.1647332E+00,.1901427E+00,& + & .2235492E+00,.1956768E+00,.1686716E+00,.1440048E+00,.1221516E+00,& + & .1041925E+00,.9012153E-01,.8095605E-01,.7543929E-01,.2243439E+00,& + & .1965703E+00,.1701921E+00,.1468360E+00,.1269493E+00,.1112681E+00,& + & .9999583E-01,.9424336E-01,.9351393E-01,.2246860E+00,.1973265E+00,& + & .1722057E+00,.1507546E+00,.1334737E+00,.1209496E+00,.1133134E+00,& + & .1112100E+00,.1153114E+00,.2246584E+00,.1979469E+00,.1749030E+00,& + & .1560431E+00,.1423719E+00,.1337802E+00,.1300644E+00,.1325688E+00,& + & .1435519E+00,.2242020E+00,.1986013E+00,.1783455E+00,.1632177E+00,& + & .1538706E+00,.1497467E+00,.1509387E+00,.1590812E+00,.1779531E+00/ + + data absa(451:585, 8) / & + & .2450204E+00,.2144676E+00,.1850038E+00,.1579688E+00,.1339651E+00,& + & .1141008E+00,.9793249E-01,.8695958E-01,.6939988E-01,.2456964E+00,& + & .2153041E+00,.1865121E+00,.1608968E+00,.1389868E+00,.1214503E+00,& + & .1082108E+00,.1007628E+00,.8668012E-01,.2459004E+00,.2159604E+00,& + & .1885239E+00,.1648976E+00,.1457743E+00,.1314989E+00,.1219175E+00,& + & .1183238E+00,.1082310E+00,.2456185E+00,.2163907E+00,.1911660E+00,& + & .1703594E+00,.1550454E+00,.1445551E+00,.1392768E+00,.1404833E+00,& + & .1353141E+00,.2449307E+00,.2169326E+00,.1945158E+00,.1777645E+00,& + & .1667152E+00,.1608041E+00,.1609850E+00,.1678148E+00,.1694632E+00,& + & .2671603E+00,.2338498E+00,.2019245E+00,.1725008E+00,.1464684E+00,& + & .1244209E+00,.1059693E+00,.9304783E-01,.6959000E-01,.2676057E+00,& + & .2345222E+00,.2033654E+00,.1755662E+00,.1517012E+00,.1320205E+00,& + & .1167556E+00,.1073595E+00,.8673211E-01,.2675630E+00,.2350038E+00,& + & .2053552E+00,.1797362E+00,.1586943E+00,.1424342E+00,.1308446E+00,& + & .1256134E+00,.1083518E+00,.2670071E+00,.2352413E+00,.2078987E+00,& + & .1853108E+00,.1681964E+00,.1557131E+00,.1486669E+00,.1486318E+00,& + & .1350793E+00,.2659779E+00,.2356017E+00,.2111172E+00,.1928578E+00,& + & .1799895E+00,.1723719E+00,.1711124E+00,.1767808E+00,.1695167E+00,& + & .2893519E+00,.2532903E+00,.2190193E+00,.1873805E+00,.1594254E+00,& + & .1350214E+00,.1142355E+00,.9903594E-01,.7490192E-01,.2895758E+00,& + & .2538124E+00,.2204052E+00,.1906072E+00,.1647749E+00,.1428610E+00,& + & .1254558E+00,.1139403E+00,.9307717E-01,.2892263E+00,.2540433E+00,& + & .2223015E+00,.1948310E+00,.1719923E+00,.1535461E+00,.1399201E+00,& + & .1328863E+00,.1147608E+00,.2883124E+00,.2540521E+00,.2247025E+00,& + & .2005493E+00,.1816141E+00,.1671436E+00,.1582248E+00,.1567001E+00,& + & .1426012E+00,.2869377E+00,.2542235E+00,.2278499E+00,.2081519E+00,& + & .1935477E+00,.1842067E+00,.1812086E+00,.1856280E+00,.1773106E+00/ + + + data absb( 1:120, 1) / & + & .8084900E-06,.8136200E-06,.8139100E-06,.8183200E-06,.8100000E-06,& + & .6259300E-06,.6309000E-06,.6315800E-06,.6282100E-06,.6250200E-06,& + & .4782500E-06,.4785200E-06,.4771300E-06,.4768800E-06,.4798900E-06,& + & .3603900E-06,.3590500E-06,.3606400E-06,.3629800E-06,.3686000E-06,& + & .2767900E-06,.2760800E-06,.2774200E-06,.2811200E-06,.2875900E-06,& + & .2177100E-06,.2182600E-06,.2201900E-06,.2242900E-06,.2299600E-06,& + & .1733400E-06,.1744100E-06,.1768100E-06,.1805500E-06,.1853700E-06,& + & .1397400E-06,.1407600E-06,.1432600E-06,.1469400E-06,.1507000E-06,& + & .1128900E-06,.1139400E-06,.1163100E-06,.1196300E-06,.1228400E-06,& + & .9057400E-07,.9191400E-07,.9404600E-07,.9699800E-07,.9984100E-07,& + & .7248300E-07,.7406900E-07,.7618600E-07,.7848200E-07,.8096400E-07,& + & .5746300E-07,.5913000E-07,.6080200E-07,.6290300E-07,.6521800E-07,& + & .4576700E-07,.4718400E-07,.4869600E-07,.5049400E-07,.5252700E-07,& + & .3663600E-07,.3779400E-07,.3921700E-07,.4076800E-07,.4246500E-07,& + & .2917300E-07,.3018300E-07,.3146900E-07,.3283400E-07,.3421300E-07,& + & .2322500E-07,.2413700E-07,.2516700E-07,.2637800E-07,.2753400E-07,& + & .1867500E-07,.1947200E-07,.2034000E-07,.2134000E-07,.2228600E-07,& + & .1502000E-07,.1569000E-07,.1646800E-07,.1725800E-07,.1806000E-07,& + & .1214900E-07,.1272800E-07,.1337500E-07,.1403500E-07,.1471100E-07,& + & .9859600E-08,.1034400E-07,.1087900E-07,.1142700E-07,.1200300E-07,& + & .8012700E-08,.8419900E-08,.8861000E-08,.9318800E-08,.9810200E-08,& + & .6547300E-08,.6885000E-08,.7247000E-08,.7637900E-08,.8032900E-08,& + & .5310700E-08,.5593000E-08,.5898400E-08,.6216100E-08,.6551100E-08,& + & .4274900E-08,.4507200E-08,.4759200E-08,.5024400E-08,.5303400E-08/ + + data absb(121:235, 1) / & + & .3459300E-08,.3647900E-08,.3855700E-08,.4071400E-08,.4303100E-08,& + & .2798100E-08,.2952500E-08,.3121200E-08,.3298400E-08,.3489000E-08,& + & .2261600E-08,.2387900E-08,.2526600E-08,.2671600E-08,.2829500E-08,& + & .1823200E-08,.1924500E-08,.2036200E-08,.2155400E-08,.2283100E-08,& + & .1467900E-08,.1551100E-08,.1640200E-08,.1737600E-08,.1841300E-08,& + & .1182800E-08,.1248800E-08,.1320000E-08,.1400800E-08,.1484100E-08,& + & .9497000E-09,.1002800E-08,.1061000E-08,.1125400E-08,.1193300E-08,& + & .7621000E-09,.8040100E-09,.8509800E-09,.9020300E-09,.9579400E-09,& + & .6124200E-09,.6447100E-09,.6820500E-09,.7233600E-09,.7684600E-09,& + & .4921400E-09,.5164200E-09,.5463300E-09,.5791600E-09,.6150600E-09,& + & .3955200E-09,.4134300E-09,.4365800E-09,.4626600E-09,.4912100E-09,& + & .3177300E-09,.3316100E-09,.3487800E-09,.3697000E-09,.3923100E-09,& + & .2552600E-09,.2661300E-09,.2790600E-09,.2951000E-09,.3134600E-09,& + & .2057100E-09,.2141900E-09,.2237900E-09,.2362200E-09,.2507600E-09,& + & .1657300E-09,.1725100E-09,.1800200E-09,.1892500E-09,.2007400E-09,& + & .1331200E-09,.1388800E-09,.1448000E-09,.1517000E-09,.1606700E-09,& + & .1071700E-09,.1120000E-09,.1165300E-09,.1218700E-09,.1286400E-09,& + & .8539500E-10,.9019000E-10,.9397800E-10,.9811500E-10,.1032400E-09,& + & .6793300E-10,.7268200E-10,.7585700E-10,.7907900E-10,.8294200E-10,& + & .5357200E-10,.5809500E-10,.6123100E-10,.6373800E-10,.6673800E-10,& + & .4172900E-10,.4638000E-10,.4935700E-10,.5140900E-10,.5374300E-10,& + & .3231900E-10,.3673700E-10,.3957200E-10,.4148700E-10,.4332700E-10,& + & .2582000E-10,.2954100E-10,.3210700E-10,.3376200E-10,.3525000E-10/ + + data absb( 1:120, 2) / & + & .9380900E-05,.1053600E-04,.1177700E-04,.1309800E-04,.1448600E-04,& + & .7705000E-05,.8652000E-05,.9674500E-05,.1075900E-04,.1189100E-04,& + & .6311200E-05,.7091400E-05,.7932000E-05,.8817900E-05,.9734400E-05,& + & .5167200E-05,.5817200E-05,.6496100E-05,.7213300E-05,.7959500E-05,& + & .4247000E-05,.4781700E-05,.5339600E-05,.5922900E-05,.6538500E-05,& + & .3510500E-05,.3951300E-05,.4404200E-05,.4886500E-05,.5398300E-05,& + & .2905700E-05,.3268000E-05,.3640900E-05,.4041900E-05,.4464600E-05,& + & .2413200E-05,.2711100E-05,.3019200E-05,.3349800E-05,.3698500E-05,& + & .2004100E-05,.2248400E-05,.2505200E-05,.2777000E-05,.3066100E-05,& + & .1676200E-05,.1877500E-05,.2090000E-05,.2315800E-05,.2554300E-05,& + & .1401300E-05,.1566500E-05,.1743300E-05,.1930800E-05,.2129000E-05,& + & .1168000E-05,.1303900E-05,.1451500E-05,.1608500E-05,.1773300E-05,& + & .9749100E-06,.1088600E-05,.1211400E-05,.1342800E-05,.1480600E-05,& + & .8160800E-06,.9119800E-06,.1014800E-05,.1124400E-05,.1239200E-05,& + & .6840700E-06,.7643200E-06,.8504800E-06,.9421000E-06,.1039300E-05,& + & .5734000E-06,.6407100E-06,.7131100E-06,.7898800E-06,.8730400E-06,& + & .4823400E-06,.5388600E-06,.5999200E-06,.6655700E-06,.7356500E-06,& + & .4062800E-06,.4538400E-06,.5063800E-06,.5617500E-06,.6208600E-06,& + & .3427600E-06,.3840900E-06,.4281700E-06,.4755100E-06,.5250800E-06,& + & .2902400E-06,.3254800E-06,.3629100E-06,.4026300E-06,.4442300E-06,& + & .2462300E-06,.2759600E-06,.3074800E-06,.3410400E-06,.3757100E-06,& + & .2081400E-06,.2331800E-06,.2597500E-06,.2874600E-06,.3167400E-06,& + & .1739900E-06,.1947600E-06,.2169800E-06,.2402100E-06,.2646300E-06,& + & .1435200E-06,.1607900E-06,.1792000E-06,.1983800E-06,.2185200E-06/ + + data absb(121:235, 2) / & + & .1164400E-06,.1306100E-06,.1456900E-06,.1614800E-06,.1779400E-06,& + & .9432700E-07,.1059700E-06,.1182700E-06,.1312100E-06,.1447100E-06,& + & .7638600E-07,.8593200E-07,.9600400E-07,.1067500E-06,.1178500E-06,& + & .6109300E-07,.6885600E-07,.7708800E-07,.8583100E-07,.9487800E-07,& + & .4878100E-07,.5505800E-07,.6172500E-07,.6885200E-07,.7623400E-07,& + & .3890900E-07,.4398700E-07,.4939100E-07,.5516100E-07,.6119700E-07,& + & .3077900E-07,.3486600E-07,.3922200E-07,.4387000E-07,.4878500E-07,& + & .2424900E-07,.2751400E-07,.3101400E-07,.3477400E-07,.3877200E-07,& + & .1907600E-07,.2169300E-07,.2451400E-07,.2752200E-07,.3075600E-07,& + & .1494900E-07,.1704600E-07,.1930300E-07,.2172100E-07,.2432000E-07,& + & .1162700E-07,.1329400E-07,.1510200E-07,.1704000E-07,.1911500E-07,& + & .9020800E-08,.1035900E-07,.1180300E-07,.1334900E-07,.1500300E-07,& + & .6997900E-08,.8062500E-08,.9207500E-08,.1044500E-07,.1176800E-07,& + & .5450700E-08,.6277700E-08,.7200400E-08,.8189900E-08,.9248800E-08,& + & .4254100E-08,.4893300E-08,.5630400E-08,.6421400E-08,.7272500E-08,& + & .3316100E-08,.3812100E-08,.4397600E-08,.5030100E-08,.5714000E-08,& + & .2581700E-08,.2969100E-08,.3429100E-08,.3936800E-08,.4483600E-08,& + & .2020300E-08,.2322800E-08,.2682300E-08,.3090000E-08,.3528500E-08,& + & .1583300E-08,.1819600E-08,.2102300E-08,.2427600E-08,.2778700E-08,& + & .1240300E-08,.1425000E-08,.1646100E-08,.1904500E-08,.2185500E-08,& + & .9724900E-09,.1116400E-08,.1288100E-08,.1492300E-08,.1717500E-08,& + & .7643100E-09,.8769900E-09,.1010800E-08,.1170900E-08,.1351600E-08,& + & .6155300E-09,.7064900E-09,.8146300E-09,.9431500E-09,.1090700E-08/ + + data absb( 1:120, 3) / & + & .3770800E-04,.4394200E-04,.5058600E-04,.5765600E-04,.6513900E-04,& + & .3169400E-04,.3686200E-04,.4235000E-04,.4819700E-04,.5434100E-04,& + & .2656400E-04,.3082400E-04,.3537200E-04,.4018000E-04,.4523100E-04,& + & .2223200E-04,.2574000E-04,.2951200E-04,.3344700E-04,.3758800E-04,& + & .1857800E-04,.2146700E-04,.2458200E-04,.2783200E-04,.3122100E-04,& + & .1553000E-04,.1792200E-04,.2049800E-04,.2317000E-04,.2597300E-04,& + & .1297200E-04,.1495200E-04,.1705900E-04,.1927000E-04,.2158000E-04,& + & .1085800E-04,.1249800E-04,.1422800E-04,.1606100E-04,.1795800E-04,& + & .9081900E-05,.1044600E-04,.1188000E-04,.1339400E-04,.1495100E-04,& + & .7664800E-05,.8797900E-05,.9993100E-05,.1125500E-04,.1254200E-04,& + & .6463400E-05,.7414000E-05,.8408600E-05,.9454600E-05,.1052700E-04,& + & .5452300E-05,.6246400E-05,.7080900E-05,.7950800E-05,.8844600E-05,& + & .4611000E-05,.5271600E-05,.5969300E-05,.6690400E-05,.7432200E-05,& + & .3913400E-05,.4462000E-05,.5042500E-05,.5643900E-05,.6257700E-05,& + & .3320800E-05,.3777700E-05,.4262900E-05,.4760700E-05,.5271400E-05,& + & .2817700E-05,.3200800E-05,.3603100E-05,.4018700E-05,.4435800E-05,& + & .2393200E-05,.2715800E-05,.3051600E-05,.3394500E-05,.3741600E-05,& + & .2034000E-05,.2303500E-05,.2582700E-05,.2867200E-05,.3155900E-05,& + & .1730800E-05,.1954700E-05,.2186900E-05,.2424300E-05,.2664900E-05,& + & .1473400E-05,.1659300E-05,.1853600E-05,.2051800E-05,.2251400E-05,& + & .1253800E-05,.1409700E-05,.1571800E-05,.1736900E-05,.1901300E-05,& + & .1062600E-05,.1193200E-05,.1329000E-05,.1466200E-05,.1602500E-05,& + & .8899000E-06,.9987800E-06,.1112200E-05,.1226600E-05,.1339500E-05,& + & .7353500E-06,.8269000E-06,.9209900E-06,.1015900E-05,.1109900E-05/ + + data absb(121:235, 3) / & + & .5972800E-06,.6730100E-06,.7512700E-06,.8302100E-06,.9084500E-06,& + & .4848400E-06,.5473700E-06,.6122900E-06,.6776200E-06,.7425800E-06,& + & .3934700E-06,.4448500E-06,.4988600E-06,.5529000E-06,.6067400E-06,& + & .3148800E-06,.3570300E-06,.4014800E-06,.4464000E-06,.4909100E-06,& + & .2513000E-06,.2856100E-06,.3222400E-06,.3595300E-06,.3961800E-06,& + & .2003000E-06,.2284000E-06,.2583400E-06,.2893000E-06,.3196500E-06,& + & .1580700E-06,.1810900E-06,.2054200E-06,.2309400E-06,.2563500E-06,& + & .1241800E-06,.1428200E-06,.1626100E-06,.1836400E-06,.2046500E-06,& + & .9738300E-07,.1124500E-06,.1285500E-06,.1457200E-06,.1630700E-06,& + & .7601500E-07,.8806700E-07,.1012000E-06,.1151000E-06,.1293500E-06,& + & .5881300E-07,.6849300E-07,.7910200E-07,.9027300E-07,.1020000E-06,& + & .4544000E-07,.5314400E-07,.6159700E-07,.7063900E-07,.8025500E-07,& + & .3501500E-07,.4113600E-07,.4786900E-07,.5521600E-07,.6299400E-07,& + & .2705600E-07,.3191000E-07,.3726700E-07,.4321000E-07,.4952200E-07,& + & .2090800E-07,.2475600E-07,.2904400E-07,.3379100E-07,.3890400E-07,& + & .1613100E-07,.1918100E-07,.2258900E-07,.2637800E-07,.3050400E-07,& + & .1241800E-07,.1483500E-07,.1753700E-07,.2054700E-07,.2386000E-07,& + & .9599400E-08,.1151400E-07,.1366200E-07,.1606500E-07,.1871700E-07,& + & .7423900E-08,.8945300E-08,.1065600E-07,.1256900E-07,.1469300E-07,& + & .5730000E-08,.6944100E-08,.8303000E-08,.9819300E-08,.1152300E-07,& + & .4415200E-08,.5381100E-08,.6458100E-08,.7661000E-08,.9020100E-08,& + & .3407200E-08,.4170800E-08,.5029700E-08,.5987600E-08,.7068400E-08,& + & .2730200E-08,.3349200E-08,.4048100E-08,.4826600E-08,.5704600E-08/ + + data absb( 1:120, 4) / & + & .1201500E-03,.1392000E-03,.1593700E-03,.1800100E-03,.1992900E-03,& + & .1025600E-03,.1188300E-03,.1358700E-03,.1525900E-03,.1681200E-03,& + & .8720300E-04,.1009900E-03,.1149800E-03,.1284700E-03,.1411400E-03,& + & .7385900E-04,.8530400E-04,.9681600E-04,.1077400E-03,.1180500E-03,& + & .6233400E-04,.7178600E-04,.8122500E-04,.9009100E-04,.9845400E-04,& + & .5258100E-04,.6034400E-04,.6801800E-04,.7523700E-04,.8190300E-04,& + & .4419700E-04,.5057300E-04,.5684000E-04,.6265600E-04,.6796800E-04,& + & .3715100E-04,.4238400E-04,.4749400E-04,.5219300E-04,.5646700E-04,& + & .3119300E-04,.3548000E-04,.3960000E-04,.4342700E-04,.4687000E-04,& + & .2637400E-04,.2992500E-04,.3322400E-04,.3626100E-04,.3904000E-04,& + & .2231500E-04,.2519800E-04,.2783300E-04,.3029000E-04,.3250900E-04,& + & .1888300E-04,.2118400E-04,.2329100E-04,.2526800E-04,.2704600E-04,& + & .1597700E-04,.1780800E-04,.1952900E-04,.2110600E-04,.2253300E-04,& + & .1352400E-04,.1499600E-04,.1639100E-04,.1765800E-04,.1879600E-04,& + & .1143300E-04,.1263100E-04,.1375700E-04,.1476900E-04,.1567700E-04,& + & .9655800E-05,.1064000E-04,.1153700E-04,.1235700E-04,.1308600E-04,& + & .8163200E-05,.8956000E-05,.9680100E-05,.1033900E-04,.1091900E-04,& + & .6897200E-05,.7532100E-05,.8118900E-05,.8641800E-05,.9112000E-05,& + & .5825500E-05,.6342700E-05,.6811500E-05,.7229100E-05,.7608800E-05,& + & .4923500E-05,.5340400E-05,.5712800E-05,.6045000E-05,.6354000E-05,& + & .4160200E-05,.4490400E-05,.4787300E-05,.5056700E-05,.5308500E-05,& + & .3499300E-05,.3764000E-05,.4003300E-05,.4221700E-05,.4432100E-05,& + & .2916800E-05,.3133100E-05,.3326400E-05,.3507200E-05,.3680800E-05,& + & .2410500E-05,.2586300E-05,.2745900E-05,.2896900E-05,.3043300E-05/ + + data absb(121:235, 4) / & + & .1969900E-05,.2116700E-05,.2249900E-05,.2375100E-05,.2498400E-05,& + & .1608500E-05,.1731600E-05,.1843100E-05,.1948200E-05,.2052000E-05,& + & .1314000E-05,.1417200E-05,.1510200E-05,.1598900E-05,.1686200E-05,& + & .1064300E-05,.1151800E-05,.1230000E-05,.1305200E-05,.1378900E-05,& + & .8610300E-06,.9349400E-06,.1001300E-05,.1064800E-05,.1127500E-05,& + & .6956600E-06,.7580300E-06,.8146800E-06,.8681700E-06,.9211300E-06,& + & .5585600E-06,.6113500E-06,.6599200E-06,.7050100E-06,.7491500E-06,& + & .4464400E-06,.4911300E-06,.5328400E-06,.5706600E-06,.6077600E-06,& + & .3563800E-06,.3938600E-06,.4294700E-06,.4619200E-06,.4929500E-06,& + & .2831700E-06,.3149000E-06,.3450300E-06,.3727600E-06,.3989400E-06,& + & .2234100E-06,.2500200E-06,.2756000E-06,.2995700E-06,.3214400E-06,& + & .1755400E-06,.1979800E-06,.2196200E-06,.2401000E-06,.2587600E-06,& + & .1373700E-06,.1564200E-06,.1745100E-06,.1919200E-06,.2079500E-06,& + & .1075400E-06,.1235700E-06,.1387900E-06,.1534300E-06,.1671200E-06,& + & .8412100E-07,.9744100E-07,.1101800E-06,.1225600E-06,.1341900E-06,& + & .6560400E-07,.7656400E-07,.8735600E-07,.9770300E-07,.1074500E-06,& + & .5094300E-07,.5998800E-07,.6904800E-07,.7762900E-07,.8593300E-07,& + & .3967900E-07,.4712100E-07,.5461400E-07,.6176600E-07,.6878300E-07,& + & .3093400E-07,.3698000E-07,.4311300E-07,.4914200E-07,.5500500E-07,& + & .2405000E-07,.2892300E-07,.3399300E-07,.3904700E-07,.4392800E-07,& + & .1866000E-07,.2255700E-07,.2674800E-07,.3095100E-07,.3500000E-07,& + & .1448800E-07,.1762500E-07,.2104300E-07,.2451100E-07,.2788400E-07,& + & .1167400E-07,.1423400E-07,.1704400E-07,.1990200E-07,.2270200E-07/ + + data absb( 1:120, 5) / & + & .5907500E-03,.6176547E-03,.6462139E-03,.6766147E-03,.7105858E-03,& + & .5021733E-03,.5254919E-03,.5505928E-03,.5781750E-03,.6090718E-03,& + & .4251753E-03,.4458740E-03,.4682385E-03,.4935183E-03,.5206768E-03,& + & .3591813E-03,.3774559E-03,.3977574E-03,.4201300E-03,.4431469E-03,& + & .3027495E-03,.3191476E-03,.3371282E-03,.3563107E-03,.3755935E-03,& + & .2550227E-03,.2694860E-03,.2850784E-03,.3010196E-03,.3174204E-03,& + & .2145715E-03,.2270374E-03,.2400302E-03,.2534708E-03,.2670980E-03,& + & .1804017E-03,.1910788E-03,.2019239E-03,.2130155E-03,.2241997E-03,& + & .1515116E-03,.1603628E-03,.1693253E-03,.1785842E-03,.1878199E-03,& + & .1274750E-03,.1347358E-03,.1422851E-03,.1500079E-03,.1574823E-03,& + & .1070376E-03,.1130951E-03,.1194785E-03,.1258411E-03,.1318753E-03,& + & .8978466E-04,.9494123E-04,.1002546E-03,.1054132E-03,.1102246E-03,& + & .7533356E-04,.7966324E-04,.8405144E-04,.8817180E-04,.9207527E-04,& + & .6331538E-04,.6693246E-04,.7046596E-04,.7375138E-04,.7692004E-04,& + & .5321123E-04,.5620271E-04,.5902917E-04,.6164644E-04,.6430450E-04,& + & .4466516E-04,.4710753E-04,.4935907E-04,.5155918E-04,.5379983E-04,& + & .3751313E-04,.3945958E-04,.4130911E-04,.4316167E-04,.4502731E-04,& + & .3148456E-04,.3306301E-04,.3457534E-04,.3614273E-04,.3767792E-04,& + & .2643306E-04,.2770164E-04,.2898435E-04,.3028820E-04,.3158349E-04,& + & .2217901E-04,.2324093E-04,.2432947E-04,.2540558E-04,.2651303E-04,& + & .1860493E-04,.1950781E-04,.2040165E-04,.2133522E-04,.2227687E-04,& + & .1560186E-04,.1635369E-04,.1712128E-04,.1791364E-04,.1869262E-04,& + & .1303087E-04,.1366605E-04,.1431103E-04,.1497004E-04,.1563111E-04,& + & .1082591E-04,.1136497E-04,.1190838E-04,.1246591E-04,.1301791E-04/ + + data absb(121:235, 5) / & + & .8949161E-05,.9402237E-05,.9857226E-05,.1033892E-04,.1080399E-04,& + & .7398494E-05,.7779511E-05,.8166568E-05,.8566423E-05,.8964480E-05,& + & .6113971E-05,.6437029E-05,.6769198E-05,.7108135E-05,.7445280E-05,& + & .5026369E-05,.5297079E-05,.5578033E-05,.5865750E-05,.6156368E-05,& + & .4126175E-05,.4355500E-05,.4592219E-05,.4836238E-05,.5085641E-05,& + & .3390696E-05,.3580871E-05,.3780710E-05,.3987163E-05,.4198069E-05,& + & .2776281E-05,.2936183E-05,.3106181E-05,.3277157E-05,.3458786E-05,& + & .2266975E-05,.2401731E-05,.2543341E-05,.2688159E-05,.2843911E-05,& + & .1851175E-05,.1964040E-05,.2082434E-05,.2205585E-05,.2334866E-05,& + & .1508390E-05,.1603576E-05,.1702375E-05,.1806116E-05,.1913393E-05,& + & .1224515E-05,.1304492E-05,.1387169E-05,.1474342E-05,.1565346E-05,& + & .9927416E-06,.1060100E-05,.1128545E-05,.1203015E-05,.1278997E-05,& + & .8040118E-06,.8600684E-06,.9178680E-06,.9793761E-06,.1043884E-05,& + & .6511957E-06,.6983405E-06,.7470839E-06,.7982212E-06,.8522692E-06,& + & .5274519E-06,.5672397E-06,.6079811E-06,.6509056E-06,.6959894E-06,& + & .4266819E-06,.4601105E-06,.4940630E-06,.5297410E-06,.5677419E-06,& + & .3444399E-06,.3727641E-06,.4009432E-06,.4307494E-06,.4625489E-06,& + & .2784617E-06,.3023078E-06,.3258711E-06,.3507791E-06,.3773299E-06,& + & .2249763E-06,.2450479E-06,.2650681E-06,.2856452E-06,.3078613E-06,& + & .1813509E-06,.1984089E-06,.2151828E-06,.2323405E-06,.2508149E-06,& + & .1459558E-06,.1603926E-06,.1745826E-06,.1886604E-06,.2039625E-06,& + & .1175460E-06,.1296812E-06,.1415814E-06,.1532665E-06,.1658461E-06,& + & .9640155E-07,.1066253E-06,.1166034E-06,.1263881E-06,.1369759E-06/ + + data absb( 1:120, 6) / & + & .3651810E-02,.3746595E-02,.3858789E-02,.3979164E-02,.4109370E-02,& + & .3141811E-02,.3230210E-02,.3325595E-02,.3429577E-02,.3547976E-02,& + & .2701370E-02,.2775610E-02,.2858077E-02,.2953528E-02,.3061412E-02,& + & .2315393E-02,.2378831E-02,.2454205E-02,.2541014E-02,.2642100E-02,& + & .1977791E-02,.2036050E-02,.2104700E-02,.2186085E-02,.2283190E-02,& + & .1685324E-02,.1740054E-02,.1805015E-02,.1884094E-02,.1978199E-02,& + & .1437021E-02,.1487251E-02,.1550029E-02,.1626786E-02,.1715576E-02,& + & .1225237E-02,.1273610E-02,.1334615E-02,.1407663E-02,.1492701E-02,& + & .1044735E-02,.1092958E-02,.1152692E-02,.1223437E-02,.1303990E-02,& + & .8942887E-03,.9428463E-03,.1001793E-02,.1070477E-02,.1149176E-02,& + & .7694049E-03,.8171499E-03,.8745104E-03,.9407106E-03,.1016851E-02,& + & .6645252E-03,.7113905E-03,.7673264E-03,.8320640E-03,.9036498E-03,& + & .5770389E-03,.6234065E-03,.6779963E-03,.7399304E-03,.8071342E-03,& + & .5049575E-03,.5502834E-03,.6030293E-03,.6613349E-03,.7246181E-03,& + & .4447202E-03,.4886958E-03,.5389704E-03,.5940660E-03,.6530676E-03,& + & .3944259E-03,.4369189E-03,.4843540E-03,.5362101E-03,.5917015E-03,& + & .3520821E-03,.3928555E-03,.4377636E-03,.4866798E-03,.5390983E-03,& + & .3162045E-03,.3551094E-03,.3978195E-03,.4440662E-03,.4940346E-03,& + & .2859841E-03,.3231854E-03,.3639308E-03,.4079919E-03,.4558740E-03,& + & .2600638E-03,.2959725E-03,.3350934E-03,.3776361E-03,.4237286E-03,& + & .2380660E-03,.2725920E-03,.3104257E-03,.3517378E-03,.3964521E-03,& + & .2181478E-03,.2514965E-03,.2881695E-03,.3284820E-03,.3717262E-03,& + & .1983067E-03,.2303075E-03,.2658491E-03,.3047978E-03,.3465710E-03,& + & .1780704E-03,.2085530E-03,.2427653E-03,.2802542E-03,.3204639E-03/ + + data absb(121:235, 6) / & + & .1565144E-03,.1849367E-03,.2172813E-03,.2529291E-03,.2913913E-03,& + & .1374906E-03,.1639820E-03,.1944800E-03,.2286994E-03,.2656361E-03,& + & .1209235E-03,.1455643E-03,.1744351E-03,.2072121E-03,.2429831E-03,& + & .1042521E-03,.1269284E-03,.1536021E-03,.1846991E-03,.2190618E-03,& + & .8956332E-04,.1101797E-03,.1349815E-03,.1642251E-03,.1972149E-03,& + & .7682060E-04,.9563184E-04,.1183845E-03,.1457632E-03,.1774806E-03,& + & .6483539E-04,.8163448E-04,.1023214E-03,.1276117E-03,.1579098E-03,& + & .5421096E-04,.6906822E-04,.8771080E-04,.1108467E-03,.1392070E-03,& + & .4516018E-04,.5817822E-04,.7490186E-04,.9595379E-04,.1222179E-03,& + & .3720506E-04,.4849290E-04,.6322139E-04,.8217544E-04,.1061847E-03,& + & .3014760E-04,.3978783E-04,.5256468E-04,.6924860E-04,.9085729E-04,& + & .2427491E-04,.3242037E-04,.4333198E-04,.5801079E-04,.7732452E-04,& + & .1942608E-04,.2622750E-04,.3554119E-04,.4824771E-04,.6532610E-04,& + & .1560503E-04,.2127119E-04,.2922144E-04,.4016492E-04,.5526442E-04,& + & .1246448E-04,.1717739E-04,.2388696E-04,.3336674E-04,.4667005E-04,& + & .9928517E-05,.1381768E-04,.1943442E-04,.2753949E-04,.3915061E-04,& + & .7845842E-05,.1104661E-04,.1568945E-04,.2259744E-04,.3259294E-04,& + & .6241865E-05,.8874763E-05,.1274389E-04,.1859414E-04,.2728085E-04,& + & .4962728E-05,.7110134E-05,.1034291E-04,.1527272E-04,.2280240E-04,& + & .3921680E-05,.5664841E-05,.8348994E-05,.1247617E-04,.1894519E-04,& + & .3092625E-05,.4493204E-05,.6711569E-05,.1013101E-04,.1563245E-04,& + & .2446444E-05,.3564130E-05,.5373137E-05,.8228205E-05,.1289787E-04,& + & .2061392E-05,.3034672E-05,.4641777E-05,.7229029E-05,.1154580E-04/ + + data absb( 1:120, 7) / & + & .7974511E-01,.7917223E-01,.7880571E-01,.7865688E-01,.7869742E-01,& + & .7216761E-01,.7180196E-01,.7168710E-01,.7178858E-01,.7210934E-01,& + & .6471287E-01,.6460046E-01,.6473991E-01,.6511587E-01,.6570290E-01,& + & .5758865E-01,.5773359E-01,.5813143E-01,.5877105E-01,.5965013E-01,& + & .5098748E-01,.5136835E-01,.5201772E-01,.5291936E-01,.5405095E-01,& + & .4498346E-01,.4559189E-01,.4647453E-01,.4761481E-01,.4899661E-01,& + & .3962956E-01,.4044591E-01,.4154636E-01,.4290895E-01,.4451971E-01,& + & .3494623E-01,.3595631E-01,.3725553E-01,.3882539E-01,.4065371E-01,& + & .3090317E-01,.3209598E-01,.3356918E-01,.3532088E-01,.3734086E-01,& + & .2753735E-01,.2889680E-01,.3055328E-01,.3249469E-01,.3469930E-01,& + & .2472194E-01,.2624583E-01,.2807624E-01,.3018719E-01,.3256894E-01,& + & .2241246E-01,.2409593E-01,.2607770E-01,.2835897E-01,.3091024E-01,& + & .2056186E-01,.2238553E-01,.2452455E-01,.2695966E-01,.2967202E-01,& + & .1912250E-01,.2109409E-01,.2338231E-01,.2597361E-01,.2884315E-01,& + & .1803069E-01,.2014547E-01,.2257560E-01,.2531768E-01,.2833188E-01,& + & .1723757E-01,.1948465E-01,.2205955E-01,.2494239E-01,.2808185E-01,& + & .1671584E-01,.1909967E-01,.2181124E-01,.2481820E-01,.2807426E-01,& + & .1642188E-01,.1893762E-01,.2177522E-01,.2489493E-01,.2825602E-01,& + & .1633447E-01,.1897666E-01,.2192891E-01,.2515422E-01,.2861454E-01,& + & .1642117E-01,.1918126E-01,.2224051E-01,.2556670E-01,.2911713E-01,& + & .1665212E-01,.1952573E-01,.2268617E-01,.2610433E-01,.2973637E-01,& + & .1690445E-01,.1987409E-01,.2312114E-01,.2661658E-01,.3031656E-01,& + & .1697413E-01,.2000260E-01,.2330589E-01,.2685241E-01,.3059806E-01,& + & .1679058E-01,.1984390E-01,.2316985E-01,.2673928E-01,.3050650E-01/ + + data absb(121:235, 7) / & + & .1621314E-01,.1924283E-01,.2254989E-01,.2610500E-01,.2986511E-01,& + & .1565005E-01,.1865129E-01,.2193291E-01,.2546985E-01,.2921685E-01,& + & .1512354E-01,.1809306E-01,.2134739E-01,.2486405E-01,.2859408E-01,& + & .1434388E-01,.1724600E-01,.2044363E-01,.2391201E-01,.2760136E-01,& + & .1356639E-01,.1639374E-01,.1952578E-01,.2293718E-01,.2658026E-01,& + & .1282426E-01,.1557142E-01,.1863464E-01,.2198740E-01,.2557922E-01,& + & .1197741E-01,.1462053E-01,.1760067E-01,.2086625E-01,.2439863E-01,& + & .1111477E-01,.1364234E-01,.1651789E-01,.1969313E-01,.2315038E-01,& + & .1030179E-01,.1271031E-01,.1547643E-01,.1856508E-01,.2193139E-01,& + & .9491085E-02,.1177021E-01,.1441481E-01,.1739504E-01,.2066837E-01,& + & .8639429E-02,.1078206E-01,.1328441E-01,.1613831E-01,.1930011E-01,& + & .7839892E-02,.9857468E-02,.1221482E-01,.1493348E-01,.1797877E-01,& + & .7092072E-02,.8991607E-02,.1120568E-01,.1378380E-01,.1670474E-01,& + & .6432463E-02,.8224187E-02,.1031515E-01,.1275809E-01,.1555586E-01,& + & .5832717E-02,.7522561E-02,.9503860E-02,.1181296E-01,.1448506E-01,& + & .5280145E-02,.6862909E-02,.8736900E-02,.1091927E-01,.1346213E-01,& + & .4760950E-02,.6239258E-02,.8009269E-02,.1007450E-01,.1248495E-01,& + & .4319927E-02,.5706660E-02,.7378235E-02,.9343778E-02,.1163217E-01,& + & .3927425E-02,.5223469E-02,.6805075E-02,.8675949E-02,.1085346E-01,& + & .3566312E-02,.4771326E-02,.6260588E-02,.8040438E-02,.1011504E-01,& + & .3235298E-02,.4349610E-02,.5751274E-02,.7436457E-02,.9414970E-02,& + & .2948268E-02,.3977194E-02,.5291955E-02,.6891886E-02,.8780537E-02,& + & .2838304E-02,.3833360E-02,.5113920E-02,.6679829E-02,.8533277E-02/ + + data absb( 1:120, 8) / & + & .1589380E+01,.1590617E+01,.1588657E+01,.1583627E+01,.1576103E+01,& + & .1709558E+01,.1708607E+01,.1704305E+01,.1697075E+01,.1686632E+01,& + & .1824948E+01,.1821482E+01,.1814617E+01,.1804445E+01,.1791378E+01,& + & .1933407E+01,.1927272E+01,.1917585E+01,.1904625E+01,.1888292E+01,& + & .2032788E+01,.2024036E+01,.2011680E+01,.1995779E+01,.1976689E+01,& + & .2122514E+01,.2111187E+01,.2096103E+01,.2077495E+01,.2055661E+01,& + & .2201894E+01,.2188149E+01,.2170688E+01,.2149637E+01,.2125223E+01,& + & .2271095E+01,.2255113E+01,.2235383E+01,.2211893E+01,.2185029E+01,& + & .2330637E+01,.2312532E+01,.2290760E+01,.2265233E+01,.2236248E+01,& + & .2380235E+01,.2360023E+01,.2336137E+01,.2308453E+01,.2277303E+01,& + & .2421520E+01,.2399497E+01,.2373596E+01,.2343962E+01,.2310850E+01,& + & .2455548E+01,.2431616E+01,.2403985E+01,.2372410E+01,.2337341E+01,& + & .2483000E+01,.2457533E+01,.2427896E+01,.2394579E+01,.2357794E+01,& + & .2504497E+01,.2477271E+01,.2446062E+01,.2410900E+01,.2372279E+01,& + & .2521140E+01,.2492125E+01,.2459283E+01,.2422484E+01,.2382142E+01,& + & .2533448E+01,.2502926E+01,.2468416E+01,.2429941E+01,.2388304E+01,& + & .2541996E+01,.2509801E+01,.2473737E+01,.2433957E+01,.2391015E+01,& + & .2547277E+01,.2513671E+01,.2476134E+01,.2434937E+01,.2390872E+01,& + & .2549698E+01,.2514609E+01,.2475824E+01,.2433436E+01,.2388147E+01,& + & .2549776E+01,.2513277E+01,.2473300E+01,.2429667E+01,.2383220E+01,& + & .2547817E+01,.2510019E+01,.2468803E+01,.2424113E+01,.2376687E+01,& + & .2545438E+01,.2506563E+01,.2464177E+01,.2418709E+01,.2370529E+01,& + & .2545437E+01,.2505887E+01,.2462992E+01,.2416876E+01,.2368167E+01,& + & .2548620E+01,.2508763E+01,.2465654E+01,.2419269E+01,.2370306E+01/ + + data absb(121:235, 8) / & + & .2556882E+01,.2517384E+01,.2474533E+01,.2428347E+01,.2379571E+01,& + & .2564751E+01,.2525708E+01,.2483281E+01,.2437321E+01,.2388806E+01,& + & .2572195E+01,.2533600E+01,.2491357E+01,.2445820E+01,.2397529E+01,& + & .2582733E+01,.2544997E+01,.2503670E+01,.2458754E+01,.2411027E+01,& + & .2593208E+01,.2556450E+01,.2515941E+01,.2471723E+01,.2424698E+01,& + & .2603291E+01,.2567534E+01,.2527827E+01,.2484500E+01,.2438025E+01,& + & .2614485E+01,.2580122E+01,.2541480E+01,.2499317E+01,.2453682E+01,& + & .2626088E+01,.2593101E+01,.2555788E+01,.2514770E+01,.2470119E+01,& + & .2636975E+01,.2605452E+01,.2569448E+01,.2529581E+01,.2486026E+01,& + & .2647757E+01,.2617959E+01,.2583514E+01,.2544917E+01,.2502605E+01,& + & .2659180E+01,.2630964E+01,.2598269E+01,.2561345E+01,.2520508E+01,& + & .2669920E+01,.2643199E+01,.2612358E+01,.2577040E+01,.2537623E+01,& + & .2680036E+01,.2654848E+01,.2625604E+01,.2592088E+01,.2554283E+01,& + & .2688888E+01,.2664859E+01,.2637463E+01,.2605558E+01,.2569275E+01,& + & .2696948E+01,.2674379E+01,.2648210E+01,.2617842E+01,.2583127E+01,& + & .2704362E+01,.2683131E+01,.2658263E+01,.2629633E+01,.2596479E+01,& + & .2711382E+01,.2691630E+01,.2667973E+01,.2640779E+01,.2609393E+01,& + & .2717487E+01,.2698684E+01,.2676350E+01,.2650456E+01,.2620490E+01,& + & .2722676E+01,.2705192E+01,.2684099E+01,.2659244E+01,.2630640E+01,& + & .2727533E+01,.2711288E+01,.2691406E+01,.2667688E+01,.2640330E+01,& + & .2731955E+01,.2717083E+01,.2698177E+01,.2675744E+01,.2649670E+01,& + & .2735798E+01,.2722099E+01,.2704431E+01,.2682979E+01,.2657966E+01,& + & .2737188E+01,.2723903E+01,.2706774E+01,.2685895E+01,.2661240E+01/ + +! --- + + data forref(1:3,1: 8) / & + & .1062750E-05,.1041850E-05,.4201540E-05,.1543430E-05,.6531930E-05,& + & .1745960E-04,.3489170E-05,.1084200E-04,.5408490E-04,.1458220E-04,& + & .1560270E-04,.8812630E-04,.3256123E-04,.1001071E-03,.8710486E-04,& + & .1958190E-03,.1469074E-03,.7616317E-04,.2991387E-03,.1425125E-03,& + & .6636773E-04,.4406950E-03,.1586718E-03,.3817266E-04/ + + + data selfref(1:10,1: 8) / & + & .3317280E-03,.2874800E-03,.2491350E-03,.2159040E-03,.1871060E-03,& + & .1621490E-03,.1405200E-03,.1217770E-03,.1055340E-03,.9145730E-04,& + & .8826280E-03,.6989140E-03,.5534390E-03,.4382440E-03,.3470260E-03,& + & .2747950E-03,.2175980E-03,.1723060E-03,.1364420E-03,.1080420E-03,& + & .1154610E-02,.9372030E-03,.7607300E-03,.6174860E-03,.5012150E-03,& + & .4068370E-03,.3302310E-03,.2680490E-03,.2175760E-03,.1766070E-03,& + & .1034500E-02,.9602680E-03,.8913600E-03,.8273970E-03,.7680240E-03,& + & .7129110E-03,.6617540E-03,.6142670E-03,.5701880E-03,.5292720E-03,& + & .3227190E-02,.2709139E-02,.2274479E-02,.1909745E-02,.1603665E-02,& + & .1346766E-02,.1131137E-02,.9501252E-03,.7981584E-03,.6705633E-03,& + & .3142835E-02,.3104435E-02,.3068990E-02,.3036443E-02,.3006728E-02,& + & .2979763E-02,.2955519E-02,.2933917E-02,.2914907E-02,.2898444E-02,& + & .2729233E-02,.2892026E-02,.3065501E-02,.3250452E-02,.3447726E-02,& + & .3658264E-02,.3883086E-02,.4123283E-02,.4380054E-02,.4654719E-02,& + & .2594476E-02,.2804964E-02,.3065165E-02,.3386332E-02,.3782724E-02,& + & .4272483E-02,.4878732E-02,.5631073E-02,.6567477E-02,.7736768E-02/ + +!........................................! + end module module_radsw_kgb19 ! +!========================================! + + +!> This module sets up absorption coeffients for band 20: 5150-6150 +!! cm-1 (low - h2o; high - h2o) +!========================================! + module module_radsw_kgb20 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG20 + +! + implicit none +! + private +! +!> msa20=65 + integer, public :: MSA20 +!> msb20=235 + integer, public :: MSB20 +!> msf20=10 + integer, public :: MSF20 +!> mfr20=4 + integer, public :: MFR20 + parameter (MSA20=65, MSB20=235, MSF20=10, MFR20=4) + + real (kind=kind_phys), public :: forref(MFR20,NG20) + +!> ch4 + real (kind=kind_phys), public :: absch4(NG20) + +!> the array absa(65,NG20) (ka(5,13,NG20)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 10, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA20,NG20) + +!> the array absb(235,10) (kb(5,13:59,10)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 10, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB20,NG20) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. For instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 10). + real (kind=kind_phys), public :: selfref(MSF20,NG20) + +!> rayleigh extinction coefficient at \f$v=5670cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 4.12e-09 + + data absa( 1: 65, 1) / & + & .7838300E-06,.8622000E-06,.9535900E-06,.1059000E-05,.1178200E-05,& + & .6504000E-06,.7251000E-06,.8131800E-06,.9005900E-06,.9978600E-06,& + & .5807200E-06,.6588800E-06,.7426500E-06,.8185400E-06,.9064500E-06,& + & .5360100E-06,.6076500E-06,.6808800E-06,.7574100E-06,.8380100E-06,& + & .5014200E-06,.5695100E-06,.6402800E-06,.7194400E-06,.7981300E-06,& + & .4716400E-06,.5400800E-06,.6104000E-06,.6800600E-06,.7503400E-06,& + & .4933700E-06,.5617800E-06,.6221500E-06,.6912700E-06,.7606000E-06,& + & .6158100E-06,.7011700E-06,.7894200E-06,.8714500E-06,.9464700E-06,& + & .1415400E-05,.1575400E-05,.1726100E-05,.1873900E-05,.1977400E-05,& + & .3418600E-05,.3701200E-05,.3960200E-05,.4223500E-05,.4425600E-05,& + & .3857400E-05,.4208000E-05,.4470100E-05,.4745400E-05,.5000200E-05,& + & .3579400E-05,.3868600E-05,.4144300E-05,.4393900E-05,.4650000E-05,& + & .2958600E-05,.3193800E-05,.3416700E-05,.3625300E-05,.3825000E-05/ + + data absa( 1: 65, 2) / & + & .5709800E-05,.6463000E-05,.7311700E-05,.8243600E-05,.9194700E-05,& + & .4638400E-05,.5312500E-05,.6030100E-05,.6802800E-05,.7582400E-05,& + & .4065700E-05,.4648600E-05,.5245900E-05,.5895500E-05,.6554600E-05,& + & .3889500E-05,.4425800E-05,.4975900E-05,.5566300E-05,.6170200E-05,& + & .3897100E-05,.4435900E-05,.4993300E-05,.5552300E-05,.6123400E-05,& + & .3953200E-05,.4464400E-05,.4973400E-05,.5487500E-05,.6010200E-05,& + & .4106800E-05,.4583200E-05,.5069800E-05,.5552100E-05,.6017500E-05,& + & .4792200E-05,.5215600E-05,.5681700E-05,.6157600E-05,.6631300E-05,& + & .8319900E-05,.8831700E-05,.9368800E-05,.9975400E-05,.1062000E-04,& + & .1683600E-04,.1852600E-04,.1988700E-04,.2116800E-04,.2210400E-04,& + & .1888200E-04,.2100500E-04,.2289600E-04,.2477700E-04,.2611500E-04,& + & .1774400E-04,.1978000E-04,.2160000E-04,.2352300E-04,.2512800E-04,& + & .1473600E-04,.1635600E-04,.1795500E-04,.1953300E-04,.2086100E-04/ + + data absa( 1: 65, 3) / & + & .4177600E-04,.4815000E-04,.5509700E-04,.6266100E-04,.7092000E-04,& + & .3390900E-04,.3917600E-04,.4462200E-04,.5075400E-04,.5733600E-04,& + & .2743800E-04,.3147300E-04,.3612200E-04,.4113400E-04,.4645600E-04,& + & .2322200E-04,.2653500E-04,.3014100E-04,.3409900E-04,.3841600E-04,& + & .2111400E-04,.2388800E-04,.2688300E-04,.3034000E-04,.3378500E-04,& + & .2075000E-04,.2292600E-04,.2553600E-04,.2849200E-04,.3167600E-04,& + & .2158400E-04,.2411200E-04,.2687200E-04,.2979400E-04,.3294000E-04,& + & .2419400E-04,.2698100E-04,.3013700E-04,.3354600E-04,.3718200E-04,& + & .3746100E-04,.4215800E-04,.4671800E-04,.5104800E-04,.5515400E-04,& + & .7239100E-04,.7716400E-04,.8401600E-04,.8965800E-04,.9551100E-04,& + & .9173600E-04,.9910700E-04,.1046300E-03,.1095200E-03,.1154900E-03,& + & .9120000E-04,.9881200E-04,.1043200E-03,.1089300E-03,.1134900E-03,& + & .7621700E-04,.8270200E-04,.8750000E-04,.9134900E-04,.9534900E-04/ + + data absa( 1: 65, 4) / & + & .7170500E-03,.8274300E-03,.9470000E-03,.1067000E-02,.1190200E-02,& + & .5790900E-03,.6709600E-03,.7672400E-03,.8658200E-03,.9716700E-03,& + & .4477100E-03,.5199700E-03,.5986100E-03,.6796700E-03,.7667600E-03,& + & .3408500E-03,.3983300E-03,.4622600E-03,.5288900E-03,.6000800E-03,& + & .2667800E-03,.3123400E-03,.3634100E-03,.4166300E-03,.4741800E-03,& + & .2090300E-03,.2471800E-03,.2892200E-03,.3335300E-03,.3817600E-03,& + & .1717300E-03,.2033000E-03,.2371100E-03,.2740100E-03,.3144500E-03,& + & .1672200E-03,.1939600E-03,.2230700E-03,.2534700E-03,.2856100E-03,& + & .2504300E-03,.2882400E-03,.3254700E-03,.3619300E-03,.3980600E-03,& + & .4332300E-03,.4866700E-03,.5346200E-03,.5787900E-03,.6204000E-03,& + & .4771900E-03,.5227100E-03,.5640200E-03,.6038800E-03,.6352000E-03,& + & .4506100E-03,.4901400E-03,.5239100E-03,.5527600E-03,.5776000E-03,& + & .3766400E-03,.4095200E-03,.4369000E-03,.4605500E-03,.4801800E-03/ + + data absa( 1: 65, 5) / & + & .6646600E-02,.6868600E-02,.7089700E-02,.7301900E-02,.7491400E-02,& + & .5402300E-02,.5601000E-02,.5800800E-02,.5998700E-02,.6168500E-02,& + & .4321800E-02,.4512700E-02,.4684800E-02,.4864700E-02,.5026700E-02,& + & .3463900E-02,.3647300E-02,.3795100E-02,.3957000E-02,.4104900E-02,& + & .2774500E-02,.2937000E-02,.3075400E-02,.3214800E-02,.3349200E-02,& + & .2202000E-02,.2352000E-02,.2483600E-02,.2596500E-02,.2711900E-02,& + & .1762400E-02,.1896300E-02,.2016100E-02,.2115300E-02,.2211600E-02,& + & .1416900E-02,.1533200E-02,.1635000E-02,.1723100E-02,.1812100E-02,& + & .1303000E-02,.1390400E-02,.1469000E-02,.1550000E-02,.1627500E-02,& + & .1715500E-02,.1816900E-02,.1894300E-02,.1962000E-02,.2021500E-02,& + & .1715600E-02,.1780800E-02,.1841900E-02,.1892500E-02,.1931300E-02,& + & .1526900E-02,.1581100E-02,.1628300E-02,.1668600E-02,.1706100E-02,& + & .1276800E-02,.1320700E-02,.1355500E-02,.1392400E-02,.1423400E-02/ + + data absa( 1: 65, 6) / & + & .1919100E-01,.1946300E-01,.1969200E-01,.1990000E-01,.2011200E-01,& + & .1596700E-01,.1621900E-01,.1642600E-01,.1661300E-01,.1680500E-01,& + & .1318600E-01,.1341100E-01,.1361400E-01,.1378500E-01,.1394400E-01,& + & .1093500E-01,.1113100E-01,.1131800E-01,.1147500E-01,.1162000E-01,& + & .9054100E-02,.9234400E-02,.9403500E-02,.9553700E-02,.9686200E-02,& + & .7472400E-02,.7632000E-02,.7779400E-02,.7929400E-02,.8052800E-02,& + & .6118300E-02,.6264400E-02,.6396100E-02,.6530300E-02,.6647800E-02,& + & .5063800E-02,.5198400E-02,.5322200E-02,.5441200E-02,.5546500E-02,& + & .4287000E-02,.4400900E-02,.4510900E-02,.4597600E-02,.4679600E-02,& + & .4523900E-02,.4607300E-02,.4696800E-02,.4797900E-02,.4895600E-02,& + & .4408900E-02,.4500600E-02,.4588100E-02,.4672100E-02,.4801500E-02,& + & .3959800E-02,.4029000E-02,.4110800E-02,.4189900E-02,.4267200E-02,& + & .3342500E-02,.3414800E-02,.3480800E-02,.3540500E-02,.3598300E-02/ + + data absa( 1: 65, 7) / & + & .5016500E-01,.5034300E-01,.5045200E-01,.5042400E-01,.5032900E-01,& + & .4272300E-01,.4288000E-01,.4293900E-01,.4291000E-01,.4286100E-01,& + & .3611700E-01,.3625500E-01,.3630100E-01,.3629400E-01,.3628800E-01,& + & .3058500E-01,.3072000E-01,.3078700E-01,.3081600E-01,.3084200E-01,& + & .2587900E-01,.2602900E-01,.2611600E-01,.2617900E-01,.2622500E-01,& + & .2182200E-01,.2197800E-01,.2209400E-01,.2217800E-01,.2224400E-01,& + & .1830400E-01,.1847600E-01,.1860600E-01,.1870500E-01,.1878000E-01,& + & .1522400E-01,.1539400E-01,.1551900E-01,.1561900E-01,.1569000E-01,& + & .1283500E-01,.1302900E-01,.1316900E-01,.1328100E-01,.1336900E-01,& + & .1163200E-01,.1171400E-01,.1176000E-01,.1177600E-01,.1180600E-01,& + & .1117000E-01,.1125200E-01,.1128800E-01,.1135700E-01,.1139700E-01,& + & .1040400E-01,.1053300E-01,.1070500E-01,.1083300E-01,.1094700E-01,& + & .9104100E-02,.9267400E-02,.9406800E-02,.9541200E-02,.9676900E-02/ + + data absa( 1: 65, 8) / & + & .1452700E+00,.1448300E+00,.1443200E+00,.1438900E+00,.1434900E+00,& + & .1273900E+00,.1270200E+00,.1266100E+00,.1262400E+00,.1258400E+00,& + & .1109100E+00,.1105800E+00,.1102400E+00,.1099000E+00,.1095300E+00,& + & .9659000E-01,.9633500E-01,.9610500E-01,.9581800E-01,.9553000E-01,& + & .8379900E-01,.8370800E-01,.8357200E-01,.8334700E-01,.8312600E-01,& + & .7236900E-01,.7238800E-01,.7228900E-01,.7214300E-01,.7198100E-01,& + & .6215800E-01,.6224700E-01,.6218500E-01,.6211100E-01,.6200700E-01,& + & .5299800E-01,.5314200E-01,.5316200E-01,.5315400E-01,.5310100E-01,& + & .4477600E-01,.4487300E-01,.4492000E-01,.4494600E-01,.4488500E-01,& + & .3823700E-01,.3851400E-01,.3871600E-01,.3887700E-01,.3896600E-01,& + & .3351100E-01,.3372100E-01,.3384300E-01,.3384000E-01,.3383900E-01,& + & .2970400E-01,.2982500E-01,.2980800E-01,.2978700E-01,.2979400E-01,& + & .2597300E-01,.2600400E-01,.2603200E-01,.2602300E-01,.2610700E-01/ + + data absa( 1: 65, 9) / & + & .6574795E+00,.6554552E+00,.6533155E+00,.6509209E+00,.6484065E+00,& + & .6255494E+00,.6246438E+00,.6232566E+00,.6216554E+00,.6197426E+00,& + & .5862362E+00,.5862909E+00,.5857885E+00,.5847743E+00,.5835312E+00,& + & .5431781E+00,.5440621E+00,.5441314E+00,.5437951E+00,.5431448E+00,& + & .4982859E+00,.4996650E+00,.5003975E+00,.5006596E+00,.5007368E+00,& + & .4522079E+00,.4542740E+00,.4556478E+00,.4567195E+00,.4575025E+00,& + & .4066660E+00,.4093121E+00,.4113888E+00,.4131704E+00,.4142502E+00,& + & .3626680E+00,.3658157E+00,.3685601E+00,.3707145E+00,.3720343E+00,& + & .3201627E+00,.3237696E+00,.3268366E+00,.3290751E+00,.3306950E+00,& + & .2769076E+00,.2802971E+00,.2831727E+00,.2851341E+00,.2866169E+00,& + & .2450947E+00,.2482141E+00,.2507025E+00,.2525044E+00,.2537402E+00,& + & .2182159E+00,.2209177E+00,.2229032E+00,.2242398E+00,.2253965E+00,& + & .1913957E+00,.1940531E+00,.1961425E+00,.1981273E+00,.1993420E+00/ + + data absa( 1: 65,10) / & + & .3268900E+01,.3251984E+01,.3235834E+01,.3221079E+01,.3207393E+01,& + & .3622351E+01,.3601154E+01,.3582181E+01,.3564354E+01,.3547975E+01,& + & .3989098E+01,.3964764E+01,.3942540E+01,.3922453E+01,.3903201E+01,& + & .4343054E+01,.4315865E+01,.4291453E+01,.4268631E+01,.4246808E+01,& + & .4682358E+01,.4653365E+01,.4626500E+01,.4601251E+01,.4576531E+01,& + & .5008731E+01,.4977636E+01,.4948849E+01,.4920625E+01,.4892993E+01,& + & .5317015E+01,.5284091E+01,.5253355E+01,.5222597E+01,.5194092E+01,& + & .5603209E+01,.5569632E+01,.5536865E+01,.5505362E+01,.5476476E+01,& + & .5865108E+01,.5831464E+01,.5798284E+01,.5767336E+01,.5737919E+01,& + & .6093085E+01,.6061308E+01,.6030013E+01,.6000723E+01,.5972079E+01,& + & .6260183E+01,.6230003E+01,.6201202E+01,.6173485E+01,.6146273E+01,& + & .6409424E+01,.6381513E+01,.6354613E+01,.6328684E+01,.6301983E+01,& + & .6564707E+01,.6537322E+01,.6510214E+01,.6481775E+01,.6454592E+01/ + + data absb( 1:120, 1) / & + & .2959700E-05,.3192900E-05,.3415900E-05,.3625600E-05,.3826400E-05,& + & .2423300E-05,.2615100E-05,.2786600E-05,.2950200E-05,.3117000E-05,& + & .1920600E-05,.2078900E-05,.2209900E-05,.2338300E-05,.2450500E-05,& + & .1493300E-05,.1607100E-05,.1703900E-05,.1799400E-05,.1881600E-05,& + & .1142900E-05,.1214400E-05,.1289500E-05,.1350300E-05,.1417400E-05,& + & .8413400E-06,.8926400E-06,.9426000E-06,.9900300E-06,.1039100E-05,& + & .6068300E-06,.6414200E-06,.6801800E-06,.7204200E-06,.7547900E-06,& + & .4580900E-06,.4881300E-06,.5193400E-06,.5482300E-06,.5726100E-06,& + & .3521900E-06,.3783500E-06,.4032200E-06,.4277200E-06,.4473600E-06,& + & .2741900E-06,.2954200E-06,.3161700E-06,.3339800E-06,.3493200E-06,& + & .2138500E-06,.2312700E-06,.2467000E-06,.2595100E-06,.2695200E-06,& + & .1676700E-06,.1817900E-06,.1928200E-06,.2013600E-06,.2111300E-06,& + & .1336100E-06,.1430100E-06,.1498000E-06,.1577800E-06,.1661500E-06,& + & .1061500E-06,.1121800E-06,.1188900E-06,.1257400E-06,.1311100E-06,& + & .8366000E-07,.8929600E-07,.9501900E-07,.1000700E-06,.1039700E-06,& + & .6666700E-07,.7121700E-07,.7561500E-07,.7923700E-07,.8223900E-07,& + & .5277600E-07,.5608600E-07,.5982800E-07,.6251300E-07,.6421800E-07,& + & .4142900E-07,.4437000E-07,.4673100E-07,.4855300E-07,.5014300E-07,& + & .3243700E-07,.3452300E-07,.3620800E-07,.3750000E-07,.3857100E-07,& + & .2523700E-07,.2673000E-07,.2786800E-07,.2882900E-07,.2994300E-07,& + & .1954500E-07,.2061400E-07,.2146700E-07,.2228000E-07,.2314100E-07,& + & .1514600E-07,.1586900E-07,.1650900E-07,.1717900E-07,.1798000E-07,& + & .1148200E-07,.1203900E-07,.1254700E-07,.1325500E-07,.1387400E-07,& + & .8617200E-08,.9002300E-08,.9560700E-08,.1010600E-07,.1059500E-07/ + + data absb(121:235, 1) / & + & .6741100E-08,.7078100E-08,.7555300E-08,.7973900E-08,.8401100E-08,& + & .5260400E-08,.5574300E-08,.5941000E-08,.6303100E-08,.6651600E-08,& + & .4112900E-08,.4385400E-08,.4685100E-08,.4977100E-08,.5246300E-08,& + & .3308900E-08,.3528900E-08,.3770200E-08,.4012500E-08,.4241500E-08,& + & .2679400E-08,.2848800E-08,.3042800E-08,.3243700E-08,.3442000E-08,& + & .2167000E-08,.2303000E-08,.2458900E-08,.2625200E-08,.2786700E-08,& + & .1769900E-08,.1885300E-08,.2000100E-08,.2133000E-08,.2265700E-08,& + & .1444600E-08,.1547100E-08,.1639700E-08,.1742300E-08,.1852600E-08,& + & .1173400E-08,.1275400E-08,.1354200E-08,.1424200E-08,.1519300E-08,& + & .9574300E-09,.1047000E-08,.1118300E-08,.1172600E-08,.1238900E-08,& + & .7734500E-09,.8519700E-09,.9218400E-09,.9736800E-09,.1014900E-08,& + & .6250000E-09,.6928800E-09,.7554800E-09,.8044600E-09,.8442800E-09,& + & .5009500E-09,.5596700E-09,.6190400E-09,.6644100E-09,.7033900E-09,& + & .4080600E-09,.4571200E-09,.5053000E-09,.5497400E-09,.5824600E-09,& + & .3310200E-09,.3713000E-09,.4112100E-09,.4502400E-09,.4843600E-09,& + & .2690600E-09,.3073900E-09,.3384500E-09,.3688400E-09,.4002400E-09,& + & .2220200E-09,.2510800E-09,.2793700E-09,.3059200E-09,.3301200E-09,& + & .1866200E-09,.2076100E-09,.2307200E-09,.2534200E-09,.2744500E-09,& + & .1574100E-09,.1714700E-09,.1914600E-09,.2102900E-09,.2285700E-09,& + & .1315100E-09,.1463700E-09,.1597700E-09,.1754700E-09,.1897400E-09,& + & .1087400E-09,.1244700E-09,.1363400E-09,.1475200E-09,.1602200E-09,& + & .9020600E-10,.1048400E-09,.1161700E-09,.1254500E-09,.1347400E-09,& + & .7675900E-10,.8886600E-10,.9934000E-10,.1070600E-09,.1144400E-09/ + + data absb( 1:120, 2) / & + & .1472700E-04,.1635700E-04,.1796100E-04,.1953000E-04,.2085200E-04,& + & .1214800E-04,.1347800E-04,.1481800E-04,.1604900E-04,.1710000E-04,& + & .9690200E-05,.1078700E-04,.1183500E-04,.1277000E-04,.1351500E-04,& + & .7623500E-05,.8457500E-05,.9221700E-05,.9852600E-05,.1044900E-04,& + & .5804900E-05,.6423900E-05,.6973300E-05,.7413100E-05,.7808200E-05,& + & .4320400E-05,.4751000E-05,.5116500E-05,.5457900E-05,.5743400E-05,& + & .3221100E-05,.3532700E-05,.3817500E-05,.4053500E-05,.4224500E-05,& + & .2526500E-05,.2765200E-05,.2964400E-05,.3133100E-05,.3273000E-05,& + & .1992100E-05,.2174900E-05,.2334300E-05,.2437700E-05,.2545800E-05,& + & .1585900E-05,.1725900E-05,.1823600E-05,.1912400E-05,.1994200E-05,& + & .1259100E-05,.1356500E-05,.1430900E-05,.1503200E-05,.1564200E-05,& + & .1001200E-05,.1070100E-05,.1124600E-05,.1181900E-05,.1227900E-05,& + & .7898500E-06,.8407400E-06,.8902900E-06,.9314500E-06,.9708500E-06,& + & .6299600E-06,.6684700E-06,.7063700E-06,.7351300E-06,.7713500E-06,& + & .5028300E-06,.5311100E-06,.5565300E-06,.5830600E-06,.6179900E-06,& + & .3996200E-06,.4232000E-06,.4426500E-06,.4671500E-06,.4951600E-06,& + & .3181000E-06,.3359700E-06,.3519100E-06,.3744800E-06,.3976800E-06,& + & .2524200E-06,.2644700E-06,.2810900E-06,.3008900E-06,.3154300E-06,& + & .1983700E-06,.2095400E-06,.2244200E-06,.2376200E-06,.2518300E-06,& + & .1559900E-06,.1670100E-06,.1778900E-06,.1888000E-06,.2003000E-06,& + & .1230700E-06,.1321100E-06,.1404600E-06,.1511100E-06,.1598800E-06,& + & .9842900E-07,.1049800E-06,.1132600E-06,.1207400E-06,.1277900E-06,& + & .7774300E-07,.8395100E-07,.9047300E-07,.9627700E-07,.1020400E-06,& + & .6122000E-07,.6639900E-07,.7110200E-07,.7594600E-07,.8080300E-07/ + + data absb(121:235, 2) / & + & .4881900E-07,.5296200E-07,.5666900E-07,.6081700E-07,.6470900E-07,& + & .3887100E-07,.4222600E-07,.4537600E-07,.4864100E-07,.5185500E-07,& + & .3086900E-07,.3348500E-07,.3623300E-07,.3886800E-07,.4152300E-07,& + & .2479800E-07,.2698300E-07,.2918000E-07,.3143700E-07,.3360000E-07,& + & .1995100E-07,.2178400E-07,.2351800E-07,.2546000E-07,.2721900E-07,& + & .1609800E-07,.1754200E-07,.1897900E-07,.2054700E-07,.2201600E-07,& + & .1302000E-07,.1414400E-07,.1541400E-07,.1661000E-07,.1787000E-07,& + & .1054800E-07,.1150000E-07,.1249200E-07,.1352000E-07,.1452400E-07,& + & .8560200E-08,.9324500E-08,.1009600E-07,.1097800E-07,.1181900E-07,& + & .6914900E-08,.7565300E-08,.8215400E-08,.8882200E-08,.9600200E-08,& + & .5570800E-08,.6116400E-08,.6667800E-08,.7192200E-08,.7763300E-08,& + & .4480400E-08,.4931200E-08,.5396700E-08,.5866200E-08,.6278000E-08,& + & .3646700E-08,.3986600E-08,.4362800E-08,.4758900E-08,.5120800E-08,& + & .2952400E-08,.3254000E-08,.3547100E-08,.3863800E-08,.4188700E-08,& + & .2388700E-08,.2652600E-08,.2895900E-08,.3150400E-08,.3411200E-08,& + & .1932100E-08,.2164800E-08,.2362500E-08,.2583900E-08,.2817300E-08,& + & .1568400E-08,.1772500E-08,.1947600E-08,.2124000E-08,.2311800E-08,& + & .1279900E-08,.1446700E-08,.1607300E-08,.1749400E-08,.1916000E-08,& + & .1044200E-08,.1191100E-08,.1321600E-08,.1453700E-08,.1577100E-08,& + & .8574100E-09,.9793700E-09,.1093600E-08,.1205600E-08,.1316700E-08,& + & .7035800E-09,.8033400E-09,.9082400E-09,.1005600E-08,.1101000E-08,& + & .5742800E-09,.6644100E-09,.7542000E-09,.8362700E-09,.9248500E-09,& + & .4792200E-09,.5559200E-09,.6349900E-09,.7073100E-09,.7867800E-09/ + + data absb( 1:120, 3) / & + & .7620100E-04,.8269900E-04,.8749900E-04,.9135200E-04,.9534800E-04,& + & .6282100E-04,.6786100E-04,.7186800E-04,.7510800E-04,.7855700E-04,& + & .4977500E-04,.5336700E-04,.5663900E-04,.5900100E-04,.6230300E-04,& + & .3800500E-04,.4088300E-04,.4326900E-04,.4540300E-04,.4813900E-04,& + & .2855000E-04,.3075000E-04,.3233100E-04,.3448900E-04,.3668700E-04,& + & .2097600E-04,.2232200E-04,.2374300E-04,.2555400E-04,.2722300E-04,& + & .1538900E-04,.1642200E-04,.1779200E-04,.1912700E-04,.2029500E-04,& + & .1188300E-04,.1281600E-04,.1396200E-04,.1487200E-04,.1572500E-04,& + & .9294800E-05,.1018700E-04,.1098600E-04,.1171300E-04,.1242600E-04,& + & .7396900E-05,.8084000E-05,.8726300E-05,.9385600E-05,.9953300E-05,& + & .5896100E-05,.6459100E-05,.6964800E-05,.7449400E-05,.7938500E-05,& + & .4744500E-05,.5174200E-05,.5603600E-05,.5975800E-05,.6372400E-05,& + & .3844200E-05,.4179100E-05,.4483700E-05,.4807800E-05,.5129400E-05,& + & .3133500E-05,.3392300E-05,.3640000E-05,.3896100E-05,.4148700E-05,& + & .2549900E-05,.2743200E-05,.2956000E-05,.3154500E-05,.3343300E-05,& + & .2063500E-05,.2223100E-05,.2389700E-05,.2551600E-05,.2693800E-05,& + & .1663500E-05,.1802400E-05,.1927900E-05,.2049800E-05,.2162700E-05,& + & .1335900E-05,.1447400E-05,.1547000E-05,.1634600E-05,.1745700E-05,& + & .1069700E-05,.1147700E-05,.1225400E-05,.1309700E-05,.1391400E-05,& + & .8495800E-06,.9146400E-06,.9818900E-06,.1048900E-05,.1115000E-05,& + & .6817800E-06,.7335600E-06,.7890500E-06,.8422600E-06,.8947600E-06,& + & .5473700E-06,.5899500E-06,.6337400E-06,.6773200E-06,.7218200E-06,& + & .4368000E-06,.4708600E-06,.5077100E-06,.5420900E-06,.5768700E-06,& + & .3461200E-06,.3746600E-06,.4037000E-06,.4307300E-06,.4597900E-06/ + + data absb(121:235, 3) / & + & .2772500E-06,.3004800E-06,.3245100E-06,.3463800E-06,.3710500E-06,& + & .2222800E-06,.2411400E-06,.2604900E-06,.2787100E-06,.2993500E-06,& + & .1779700E-06,.1931700E-06,.2087800E-06,.2241100E-06,.2410200E-06,& + & .1434600E-06,.1560100E-06,.1691300E-06,.1819700E-06,.1956600E-06,& + & .1155900E-06,.1261500E-06,.1369700E-06,.1478500E-06,.1587400E-06,& + & .9335800E-07,.1021400E-06,.1108900E-06,.1199800E-06,.1290400E-06,& + & .7559900E-07,.8269000E-07,.8980800E-07,.9752400E-07,.1051100E-06,& + & .6128500E-07,.6678600E-07,.7293700E-07,.7908700E-07,.8552500E-07,& + & .4972500E-07,.5429400E-07,.5926300E-07,.6421300E-07,.6958300E-07,& + & .4033600E-07,.4418600E-07,.4803400E-07,.5218400E-07,.5653400E-07,& + & .3290400E-07,.3563300E-07,.3895900E-07,.4240200E-07,.4588300E-07,& + & .2672500E-07,.2910400E-07,.3169300E-07,.3431200E-07,.3730400E-07,& + & .2175100E-07,.2384900E-07,.2580300E-07,.2802400E-07,.3035600E-07,& + & .1758700E-07,.1960900E-07,.2121600E-07,.2302200E-07,.2494200E-07,& + & .1437600E-07,.1599000E-07,.1749300E-07,.1887200E-07,.2046300E-07,& + & .1181100E-07,.1310600E-07,.1448900E-07,.1561500E-07,.1683200E-07,& + & .9600100E-08,.1078800E-07,.1192100E-07,.1298500E-07,.1390400E-07,& + & .7824300E-08,.8917800E-08,.9843000E-08,.1084000E-07,.1161900E-07,& + & .6363800E-08,.7367800E-08,.8221400E-08,.8999700E-08,.9756500E-08,& + & .5175300E-08,.6049700E-08,.6841900E-08,.7456000E-08,.8236200E-08,& + & .4216400E-08,.4991600E-08,.5706600E-08,.6330800E-08,.6895000E-08,& + & .3461800E-08,.4142400E-08,.4805400E-08,.5375700E-08,.5809500E-08,& + & .2908300E-08,.3529100E-08,.4093200E-08,.4628500E-08,.4986500E-08/ + + data absb( 1:120, 4) / & + & .3767400E-03,.4095300E-03,.4369000E-03,.4605900E-03,.4800700E-03,& + & .3120200E-03,.3390600E-03,.3606600E-03,.3800300E-03,.3962700E-03,& + & .2513500E-03,.2727100E-03,.2906900E-03,.3066100E-03,.3200500E-03,& + & .1979700E-03,.2152700E-03,.2295500E-03,.2432800E-03,.2545600E-03,& + & .1535400E-03,.1667900E-03,.1793300E-03,.1910100E-03,.2004100E-03,& + & .1174200E-03,.1279700E-03,.1392300E-03,.1483600E-03,.1565400E-03,& + & .9051900E-04,.9938600E-04,.1081900E-03,.1160100E-03,.1231900E-03,& + & .7257900E-04,.7991000E-04,.8707500E-04,.9372800E-04,.9965600E-04,& + & .5886600E-04,.6480500E-04,.7070500E-04,.7615300E-04,.8099600E-04,& + & .4815700E-04,.5288300E-04,.5774000E-04,.6213000E-04,.6610000E-04,& + & .3933700E-04,.4328900E-04,.4727500E-04,.5090600E-04,.5416100E-04,& + & .3228900E-04,.3557700E-04,.3880800E-04,.4181400E-04,.4443300E-04,& + & .2661500E-04,.2930100E-04,.3198400E-04,.3439600E-04,.3650900E-04,& + & .2206000E-04,.2427000E-04,.2646000E-04,.2845000E-04,.3020300E-04,& + & .1834400E-04,.2017700E-04,.2194800E-04,.2359500E-04,.2500100E-04,& + & .1525600E-04,.1678700E-04,.1824200E-04,.1956100E-04,.2069600E-04,& + & .1267900E-04,.1395200E-04,.1517000E-04,.1621100E-04,.1716300E-04,& + & .1055000E-04,.1160500E-04,.1257900E-04,.1345100E-04,.1421000E-04,& + & .8751200E-05,.9632200E-05,.1043300E-04,.1113300E-04,.1176200E-04,& + & .7300100E-05,.8020300E-05,.8674500E-05,.9229200E-05,.9729500E-05,& + & .6095800E-05,.6686200E-05,.7200600E-05,.7635900E-05,.8057600E-05,& + & .5085500E-05,.5567100E-05,.5967000E-05,.6339200E-05,.6686900E-05,& + & .4203300E-05,.4590500E-05,.4925000E-05,.5238400E-05,.5536900E-05,& + & .3438400E-05,.3761800E-05,.4043000E-05,.4306000E-05,.4557700E-05/ + + data absb(121:235, 4) / & + & .2803900E-05,.3074900E-05,.3313500E-05,.3534400E-05,.3745800E-05,& + & .2284200E-05,.2510400E-05,.2712600E-05,.2896600E-05,.3076800E-05,& + & .1858500E-05,.2051000E-05,.2219400E-05,.2373100E-05,.2524900E-05,& + & .1504100E-05,.1667600E-05,.1809700E-05,.1940200E-05,.2068100E-05,& + & .1215400E-05,.1354100E-05,.1474900E-05,.1585200E-05,.1693400E-05,& + & .9803300E-06,.1097500E-05,.1201100E-05,.1294500E-05,.1385900E-05,& + & .7872400E-06,.8862500E-06,.9748600E-06,.1055400E-05,.1130700E-05,& + & .6305900E-06,.7138200E-06,.7894800E-06,.8575500E-06,.9204400E-06,& + & .5042600E-06,.5739100E-06,.6380800E-06,.6971800E-06,.7497200E-06,& + & .4013300E-06,.4585800E-06,.5141400E-06,.5640000E-06,.6096400E-06,& + & .3158000E-06,.3644000E-06,.4112000E-06,.4543300E-06,.4934800E-06,& + & .2484700E-06,.2890700E-06,.3287900E-06,.3653700E-06,.3990300E-06,& + & .1953000E-06,.2285800E-06,.2624700E-06,.2933100E-06,.3221700E-06,& + & .1536400E-06,.1811300E-06,.2091100E-06,.2358900E-06,.2599400E-06,& + & .1207200E-06,.1441300E-06,.1665600E-06,.1895200E-06,.2098300E-06,& + & .9492500E-07,.1139700E-06,.1325500E-06,.1519300E-06,.1696000E-06,& + & .7447300E-07,.9019700E-07,.1057400E-06,.1215300E-06,.1366100E-06,& + & .5900900E-07,.7159400E-07,.8478100E-07,.9775800E-07,.1101800E-06,& + & .4700800E-07,.5699700E-07,.6783800E-07,.7875300E-07,.8911600E-07,& + & .3741500E-07,.4564200E-07,.5442000E-07,.6346600E-07,.7191000E-07,& + & .2989600E-07,.3663500E-07,.4369700E-07,.5103600E-07,.5826700E-07,& + & .2394600E-07,.2952300E-07,.3531600E-07,.4118300E-07,.4739100E-07,& + & .1988100E-07,.2464200E-07,.2939000E-07,.3409900E-07,.3923400E-07/ + + data absb( 1:120, 5) / & + & .1277100E-02,.1320200E-02,.1355700E-02,.1392700E-02,.1423300E-02,& + & .1060800E-02,.1095100E-02,.1124900E-02,.1154900E-02,.1178800E-02,& + & .8675000E-03,.8967900E-03,.9198600E-03,.9439900E-03,.9640500E-03,& + & .7007300E-03,.7250400E-03,.7463000E-03,.7649500E-03,.7816500E-03,& + & .5628000E-03,.5832100E-03,.6015300E-03,.6154400E-03,.6288500E-03,& + & .4494000E-03,.4659800E-03,.4788700E-03,.4905800E-03,.5022300E-03,& + & .3575300E-03,.3706400E-03,.3829000E-03,.3939000E-03,.4038700E-03,& + & .2901300E-03,.3009900E-03,.3117900E-03,.3211700E-03,.3301100E-03,& + & .2365700E-03,.2460200E-03,.2550400E-03,.2634000E-03,.2714500E-03,& + & .1942300E-03,.2022400E-03,.2098700E-03,.2171100E-03,.2243900E-03,& + & .1596300E-03,.1664300E-03,.1730800E-03,.1794900E-03,.1858000E-03,& + & .1316600E-03,.1374500E-03,.1433200E-03,.1487100E-03,.1542800E-03,& + & .1088500E-03,.1139400E-03,.1189600E-03,.1237100E-03,.1284600E-03,& + & .9040300E-04,.9491400E-04,.9915700E-04,.1031000E-03,.1072900E-03,& + & .7526500E-04,.7916600E-04,.8264800E-04,.8620900E-04,.8988200E-04,& + & .6287000E-04,.6605000E-04,.6911100E-04,.7228900E-04,.7545100E-04,& + & .5246500E-04,.5519200E-04,.5788700E-04,.6066000E-04,.6336700E-04,& + & .4388700E-04,.4619100E-04,.4858800E-04,.5091000E-04,.5327800E-04,& + & .3676000E-04,.3876600E-04,.4078300E-04,.4278300E-04,.4478000E-04,& + & .3083100E-04,.3256100E-04,.3426700E-04,.3600000E-04,.3759400E-04,& + & .2590800E-04,.2738900E-04,.2883200E-04,.3029000E-04,.3158100E-04,& + & .2177600E-04,.2302600E-04,.2426600E-04,.2544400E-04,.2651000E-04,& + & .1823300E-04,.1928000E-04,.2032400E-04,.2126600E-04,.2214100E-04,& + & .1516000E-04,.1604200E-04,.1691800E-04,.1768600E-04,.1840600E-04/ + + data absb(121:235, 5) / & + & .1253800E-04,.1328500E-04,.1401500E-04,.1465700E-04,.1526900E-04,& + & .1035700E-04,.1099000E-04,.1159500E-04,.1214800E-04,.1265100E-04,& + & .8556600E-05,.9085600E-05,.9598600E-05,.1005700E-04,.1047800E-04,& + & .7039000E-05,.7482600E-05,.7920000E-05,.8306100E-05,.8663400E-05,& + & .5782700E-05,.6157200E-05,.6526900E-05,.6852800E-05,.7159500E-05,& + & .4747700E-05,.5065600E-05,.5370500E-05,.5648600E-05,.5910000E-05,& + & .3880200E-05,.4153300E-05,.4408900E-05,.4651500E-05,.4871900E-05,& + & .3165800E-05,.3397100E-05,.3617700E-05,.3820500E-05,.4008900E-05,& + & .2579600E-05,.2774000E-05,.2963500E-05,.3133600E-05,.3298600E-05,& + & .2094500E-05,.2263600E-05,.2421400E-05,.2569800E-05,.2707700E-05,& + & .1693100E-05,.1838300E-05,.1972900E-05,.2099600E-05,.2217200E-05,& + & .1365000E-05,.1488900E-05,.1604300E-05,.1713900E-05,.1813600E-05,& + & .1098100E-05,.1204200E-05,.1302800E-05,.1396300E-05,.1482400E-05,& + & .8840700E-06,.9737000E-06,.1058900E-05,.1138300E-05,.1212400E-05,& + & .7115000E-06,.7868200E-06,.8604800E-06,.9271100E-06,.9912800E-06,& + & .5714000E-06,.6351300E-06,.6979000E-06,.7546600E-06,.8094600E-06,& + & .4587100E-06,.5118300E-06,.5649400E-06,.6137600E-06,.6602200E-06,& + & .3688900E-06,.4131900E-06,.4575900E-06,.4997300E-06,.5393300E-06,& + & .2968300E-06,.3339600E-06,.3711000E-06,.4067100E-06,.4402600E-06,& + & .2382800E-06,.2697300E-06,.3004800E-06,.3309900E-06,.3594900E-06,& + & .1908300E-06,.2178200E-06,.2435000E-06,.2688300E-06,.2930900E-06,& + & .1533400E-06,.1759200E-06,.1975300E-06,.2186900E-06,.2390300E-06,& + & .1263500E-06,.1450400E-06,.1632100E-06,.1807400E-06,.1975900E-06/ + + data absb( 1:120, 6) / & + & .3343300E-02,.3415900E-02,.3479800E-02,.3539700E-02,.3599500E-02,& + & .2803900E-02,.2858900E-02,.2909000E-02,.2959500E-02,.3010800E-02,& + & .2313500E-02,.2357900E-02,.2401200E-02,.2447000E-02,.2490000E-02,& + & .1892500E-02,.1928100E-02,.1967100E-02,.2009000E-02,.2044500E-02,& + & .1536500E-02,.1570300E-02,.1603900E-02,.1642400E-02,.1676000E-02,& + & .1242400E-02,.1274600E-02,.1306700E-02,.1339700E-02,.1368700E-02,& + & .1011300E-02,.1041700E-02,.1066400E-02,.1095800E-02,.1123100E-02,& + & .8337500E-03,.8586300E-03,.8809800E-03,.9068000E-03,.9309300E-03,& + & .6884900E-03,.7105600E-03,.7316100E-03,.7540200E-03,.7743200E-03,& + & .5707600E-03,.5900100E-03,.6092500E-03,.6281600E-03,.6453100E-03,& + & .4746200E-03,.4913800E-03,.5081800E-03,.5242100E-03,.5393000E-03,& + & .3955200E-03,.4101100E-03,.4246000E-03,.4386500E-03,.4520600E-03,& + & .3304100E-03,.3431700E-03,.3557300E-03,.3680000E-03,.3800500E-03,& + & .2769900E-03,.2880600E-03,.2989200E-03,.3098300E-03,.3203800E-03,& + & .2325300E-03,.2422900E-03,.2520800E-03,.2614400E-03,.2703900E-03,& + & .1957300E-03,.2044200E-03,.2127600E-03,.2208700E-03,.2286900E-03,& + & .1652800E-03,.1727100E-03,.1797400E-03,.1868100E-03,.1937300E-03,& + & .1394900E-03,.1459900E-03,.1521400E-03,.1583400E-03,.1644800E-03,& + & .1179300E-03,.1234500E-03,.1289100E-03,.1343200E-03,.1397500E-03,& + & .9984500E-04,.1046400E-03,.1094100E-03,.1142500E-03,.1189600E-03,& + & .8472300E-04,.8880800E-04,.9305400E-04,.9725700E-04,.1014400E-03,& + & .7185700E-04,.7547800E-04,.7924500E-04,.8287800E-04,.8652700E-04,& + & .6074100E-04,.6398700E-04,.6719000E-04,.7044500E-04,.7363400E-04,& + & .5109400E-04,.5395300E-04,.5678700E-04,.5964400E-04,.6242100E-04/ + + data absb(121:235, 6) / & + & .4280900E-04,.4532400E-04,.4780500E-04,.5031400E-04,.5279700E-04,& + & .3586200E-04,.3808200E-04,.4024900E-04,.4245900E-04,.4469100E-04,& + & .3004700E-04,.3197000E-04,.3387700E-04,.3584100E-04,.3779200E-04,& + & .2505100E-04,.2673400E-04,.2842900E-04,.3017700E-04,.3185900E-04,& + & .2085800E-04,.2233700E-04,.2383700E-04,.2534800E-04,.2684500E-04,& + & .1735800E-04,.1865300E-04,.1994700E-04,.2127900E-04,.2261400E-04,& + & .1438200E-04,.1550700E-04,.1663700E-04,.1780800E-04,.1897500E-04,& + & .1187500E-04,.1285100E-04,.1384700E-04,.1486500E-04,.1588600E-04,& + & .9782400E-05,.1064100E-04,.1149700E-04,.1238600E-04,.1328800E-04,& + & .8030500E-05,.8771200E-05,.9517000E-05,.1028200E-04,.1107300E-04,& + & .6555400E-05,.7188100E-05,.7833100E-05,.8502200E-05,.9179900E-05,& + & .5339900E-05,.5881800E-05,.6436400E-05,.7009300E-05,.7599200E-05,& + & .4339600E-05,.4799000E-05,.5272700E-05,.5763300E-05,.6278500E-05,& + & .3527200E-05,.3913900E-05,.4323000E-05,.4742300E-05,.5181900E-05,& + & .2862400E-05,.3191300E-05,.3537900E-05,.3897900E-05,.4274400E-05,& + & .2318900E-05,.2596100E-05,.2890700E-05,.3197600E-05,.3520000E-05,& + & .1873600E-05,.2107200E-05,.2357600E-05,.2617900E-05,.2894300E-05,& + & .1515500E-05,.1713500E-05,.1924500E-05,.2145100E-05,.2380800E-05,& + & .1225000E-05,.1392300E-05,.1571400E-05,.1757800E-05,.1959700E-05,& + & .9901200E-06,.1129600E-05,.1280100E-05,.1439500E-05,.1610700E-05,& + & .7987500E-06,.9141800E-06,.1040800E-05,.1177700E-05,.1321200E-05,& + & .6447400E-06,.7410900E-06,.8466400E-06,.9632800E-06,.1084900E-05,& + & .5329600E-06,.6142700E-06,.7038500E-06,.8037500E-06,.9086300E-06/ + + data absb( 1:120, 7) / & + & .9106300E-02,.9268100E-02,.9404500E-02,.9538800E-02,.9673500E-02,& + & .7848300E-02,.7980600E-02,.8123800E-02,.8252800E-02,.8360300E-02,& + & .6626900E-02,.6744500E-02,.6884500E-02,.6991100E-02,.7085400E-02,& + & .5518300E-02,.5641400E-02,.5757400E-02,.5848700E-02,.5940700E-02,& + & .4569300E-02,.4678000E-02,.4774300E-02,.4862500E-02,.4946700E-02,& + & .3761100E-02,.3853500E-02,.3940800E-02,.4023400E-02,.4100700E-02,& + & .3099100E-02,.3180900E-02,.3264700E-02,.3338800E-02,.3404200E-02,& + & .2585800E-02,.2658500E-02,.2734700E-02,.2799000E-02,.2857900E-02,& + & .2167200E-02,.2232600E-02,.2297300E-02,.2354700E-02,.2405800E-02,& + & .1821100E-02,.1880900E-02,.1936400E-02,.1985900E-02,.2035200E-02,& + & .1531400E-02,.1584400E-02,.1633200E-02,.1676000E-02,.1724300E-02,& + & .1292400E-02,.1338500E-02,.1379300E-02,.1420900E-02,.1465900E-02,& + & .1092600E-02,.1132200E-02,.1168900E-02,.1208100E-02,.1249300E-02,& + & .9275600E-03,.9613600E-03,.9960100E-03,.1032400E-02,.1069500E-02,& + & .7883200E-03,.8189300E-03,.8513700E-03,.8846500E-03,.9188500E-03,& + & .6709700E-03,.6997900E-03,.7298500E-03,.7603800E-03,.7921300E-03,& + & .5723100E-03,.5993400E-03,.6272700E-03,.6547100E-03,.6838900E-03,& + & .4899600E-03,.5144100E-03,.5394500E-03,.5656400E-03,.5916400E-03,& + & .4199800E-03,.4423700E-03,.4655100E-03,.4892400E-03,.5132200E-03,& + & .3613300E-03,.3816800E-03,.4029700E-03,.4244100E-03,.4472200E-03,& + & .3115300E-03,.3305500E-03,.3498000E-03,.3697200E-03,.3908600E-03,& + & .2694100E-03,.2865700E-03,.3043600E-03,.3229500E-03,.3425600E-03,& + & .2321000E-03,.2478200E-03,.2641100E-03,.2812100E-03,.2993000E-03,& + & .1990400E-03,.2131100E-03,.2279700E-03,.2438000E-03,.2603000E-03/ + + data absb(121:235, 7) / & + & .1700000E-03,.1830000E-03,.1966600E-03,.2112800E-03,.2264100E-03,& + & .1452800E-03,.1570400E-03,.1697500E-03,.1832000E-03,.1973500E-03,& + & .1241400E-03,.1349600E-03,.1465400E-03,.1589900E-03,.1721100E-03,& + & .1056700E-03,.1154700E-03,.1261800E-03,.1376500E-03,.1499400E-03,& + & .8977400E-04,.9875100E-04,.1085200E-03,.1191800E-03,.1305700E-03,& + & .7623200E-04,.8438300E-04,.9333600E-04,.1031400E-03,.1138100E-03,& + & .6437000E-04,.7168400E-04,.7979700E-04,.8885000E-04,.9873300E-04,& + & .5412500E-04,.6068000E-04,.6804200E-04,.7631300E-04,.8543200E-04,& + & .4537400E-04,.5128000E-04,.5793200E-04,.6542900E-04,.7385200E-04,& + & .3786100E-04,.4307800E-04,.4901600E-04,.5584400E-04,.6353800E-04,& + & .3134200E-04,.3587900E-04,.4117500E-04,.4725200E-04,.5428600E-04,& + & .2582100E-04,.2977700E-04,.3445800E-04,.3988000E-04,.4621800E-04,& + & .2118000E-04,.2461700E-04,.2871900E-04,.3350700E-04,.3918400E-04,& + & .1737700E-04,.2034500E-04,.2391600E-04,.2817700E-04,.3323700E-04,& + & .1422300E-04,.1679000E-04,.1986800E-04,.2365600E-04,.2816300E-04,& + & .1159300E-04,.1378800E-04,.1647900E-04,.1977300E-04,.2376500E-04,& + & .9414100E-05,.1127900E-04,.1359100E-04,.1644700E-04,.1996900E-04,& + & .7662200E-05,.9241700E-05,.1123300E-04,.1370900E-04,.1681900E-04,& + & .6231500E-05,.7567100E-05,.9269900E-05,.1142900E-04,.1418600E-04,& + & .5047300E-05,.6176600E-05,.7631600E-05,.9497900E-05,.1189000E-04,& + & .4077300E-05,.5024200E-05,.6254000E-05,.7859400E-05,.9937800E-05,& + & .3293700E-05,.4086200E-05,.5122800E-05,.6499200E-05,.8311200E-05,& + & .2759300E-05,.3450500E-05,.4371600E-05,.5603500E-05,.7260900E-05/ + + data absb( 1:120, 8) / & + & .2599000E-01,.2599700E-01,.2602400E-01,.2603800E-01,.2613200E-01,& + & .2264800E-01,.2273100E-01,.2280300E-01,.2286100E-01,.2302000E-01,& + & .1964100E-01,.1981200E-01,.1988000E-01,.1999800E-01,.2014100E-01,& + & .1690900E-01,.1703000E-01,.1714800E-01,.1729600E-01,.1750200E-01,& + & .1436500E-01,.1450400E-01,.1464300E-01,.1480800E-01,.1499600E-01,& + & .1207200E-01,.1220700E-01,.1234600E-01,.1251300E-01,.1274200E-01,& + & .1013500E-01,.1026300E-01,.1040200E-01,.1060200E-01,.1079400E-01,& + & .8650800E-02,.8795100E-02,.8976500E-02,.9153000E-02,.9344700E-02,& + & .7422800E-02,.7596400E-02,.7780500E-02,.7944100E-02,.8126600E-02,& + & .6394900E-02,.6592000E-02,.6758400E-02,.6929800E-02,.7096800E-02,& + & .5538900E-02,.5716500E-02,.5883400E-02,.6049000E-02,.6216300E-02,& + & .4798000E-02,.4969600E-02,.5133300E-02,.5305500E-02,.5469500E-02,& + & .4167600E-02,.4335700E-02,.4499900E-02,.4674900E-02,.4817900E-02,& + & .3639100E-02,.3807900E-02,.3983400E-02,.4137400E-02,.4275400E-02,& + & .3191700E-02,.3358000E-02,.3523700E-02,.3673700E-02,.3798200E-02,& + & .2809600E-02,.2970900E-02,.3124200E-02,.3261300E-02,.3382900E-02,& + & .2478600E-02,.2627200E-02,.2770600E-02,.2898600E-02,.3013000E-02,& + & .2190700E-02,.2328200E-02,.2457400E-02,.2577800E-02,.2680600E-02,& + & .1934600E-02,.2056900E-02,.2175700E-02,.2280500E-02,.2374200E-02,& + & .1710100E-02,.1824700E-02,.1930800E-02,.2025600E-02,.2117600E-02,& + & .1517100E-02,.1616800E-02,.1712100E-02,.1803500E-02,.1891100E-02,& + & .1346600E-02,.1439000E-02,.1524600E-02,.1608300E-02,.1692100E-02,& + & .1187100E-02,.1269800E-02,.1353400E-02,.1432000E-02,.1507100E-02,& + & .1038800E-02,.1117900E-02,.1193400E-02,.1264700E-02,.1339100E-02/ + + data absb(121:235, 8) / & + & .9223300E-03,.9985400E-03,.1072200E-02,.1142600E-02,.1211800E-02,& + & .8184300E-03,.8923600E-03,.9660500E-03,.1034000E-02,.1100300E-02,& + & .7273800E-03,.7977700E-03,.8699700E-03,.9349600E-03,.9985200E-03,& + & .6514900E-03,.7209800E-03,.7923500E-03,.8611600E-03,.9247400E-03,& + & .5831800E-03,.6515400E-03,.7216000E-03,.7940000E-03,.8597300E-03,& + & .5212700E-03,.5877000E-03,.6578100E-03,.7311000E-03,.8016500E-03,& + & .4640400E-03,.5296000E-03,.5988600E-03,.6736600E-03,.7472700E-03,& + & .4122900E-03,.4760900E-03,.5442400E-03,.6191800E-03,.6936600E-03,& + & .3653400E-03,.4262400E-03,.4937400E-03,.5666800E-03,.6436400E-03,& + & .3213400E-03,.3798700E-03,.4459700E-03,.5166900E-03,.5946900E-03,& + & .2785500E-03,.3353100E-03,.3985500E-03,.4683200E-03,.5456200E-03,& + & .2409400E-03,.2944000E-03,.3547700E-03,.4228400E-03,.4976700E-03,& + & .2071000E-03,.2571200E-03,.3142500E-03,.3809800E-03,.4546500E-03,& + & .1775700E-03,.2242200E-03,.2790600E-03,.3423100E-03,.4141900E-03,& + & .1519800E-03,.1953800E-03,.2475800E-03,.3079600E-03,.3776500E-03,& + & .1294300E-03,.1690700E-03,.2181200E-03,.2758500E-03,.3428400E-03,& + & .1094600E-03,.1456000E-03,.1910300E-03,.2463300E-03,.3104900E-03,& + & .9295000E-04,.1259900E-03,.1684800E-03,.2210900E-03,.2826600E-03,& + & .7872200E-04,.1088300E-03,.1483100E-03,.1979000E-03,.2577000E-03,& + & .6632300E-04,.9365100E-04,.1298300E-03,.1763800E-03,.2339300E-03,& + & .5564400E-04,.8008500E-04,.1134900E-03,.1574100E-03,.2127400E-03,& + & .4653700E-04,.6844200E-04,.9919000E-04,.1404500E-03,.1932700E-03,& + & .4155800E-04,.6250300E-04,.9237700E-04,.1325800E-03,.1852800E-03/ + + data absb( 1:120, 9) / & + & .1913712E+00,.1940307E+00,.1961583E+00,.1981395E+00,.1992614E+00,& + & .1688802E+00,.1712855E+00,.1734248E+00,.1752061E+00,.1762731E+00,& + & .1486065E+00,.1508840E+00,.1528820E+00,.1544423E+00,.1558272E+00,& + & .1299204E+00,.1323469E+00,.1341015E+00,.1357898E+00,.1371436E+00,& + & .1134080E+00,.1156327E+00,.1174880E+00,.1190475E+00,.1205541E+00,& + & .9849405E-01,.1005410E+00,.1023631E+00,.1040376E+00,.1053612E+00,& + & .8553764E-01,.8752614E-01,.8929406E-01,.9077432E-01,.9251699E-01,& + & .7472428E-01,.7670302E-01,.7818691E-01,.7985497E-01,.8155359E-01,& + & .6533778E-01,.6717463E-01,.6889333E-01,.7050656E-01,.7229544E-01,& + & .5740823E-01,.5919933E-01,.6095743E-01,.6261078E-01,.6444982E-01,& + & .5056393E-01,.5229127E-01,.5411951E-01,.5593955E-01,.5779249E-01,& + & .4478827E-01,.4654763E-01,.4835743E-01,.5018840E-01,.5221163E-01,& + & .3995582E-01,.4170732E-01,.4352502E-01,.4537017E-01,.4745831E-01,& + & .3584681E-01,.3763708E-01,.3940778E-01,.4140061E-01,.4366003E-01,& + & .3241328E-01,.3414397E-01,.3597457E-01,.3798590E-01,.4030971E-01,& + & .2947190E-01,.3126308E-01,.3314326E-01,.3529197E-01,.3770177E-01,& + & .2705105E-01,.2882380E-01,.3077801E-01,.3304753E-01,.3559583E-01,& + & .2495554E-01,.2671043E-01,.2883204E-01,.3115120E-01,.3377072E-01,& + & .2314399E-01,.2503929E-01,.2721446E-01,.2967647E-01,.3240495E-01,& + & .2168424E-01,.2363375E-01,.2593698E-01,.2846534E-01,.3128868E-01,& + & .2052923E-01,.2253442E-01,.2489053E-01,.2751815E-01,.3055501E-01,& + & .1954963E-01,.2161307E-01,.2412847E-01,.2681518E-01,.3006419E-01,& + & .1858710E-01,.2078212E-01,.2330820E-01,.2617072E-01,.2946078E-01,& + & .1751615E-01,.1979783E-01,.2246608E-01,.2526516E-01,.2885677E-01/ + + data absb(121:235, 9) / & + & .1645401E-01,.1873164E-01,.2142687E-01,.2424787E-01,.2779912E-01,& + & .1549653E-01,.1781459E-01,.2042772E-01,.2337789E-01,.2680098E-01,& + & .1464498E-01,.1698778E-01,.1958951E-01,.2255141E-01,.2592896E-01,& + & .1374930E-01,.1598681E-01,.1858564E-01,.2145636E-01,.2483064E-01,& + & .1297376E-01,.1509265E-01,.1767753E-01,.2043917E-01,.2378184E-01,& + & .1225680E-01,.1431909E-01,.1681124E-01,.1957355E-01,.2273600E-01,& + & .1154426E-01,.1346806E-01,.1585020E-01,.1858172E-01,.2161718E-01,& + & .1073729E-01,.1273625E-01,.1500546E-01,.1763766E-01,.2052634E-01,& + & .1003661E-01,.1202377E-01,.1415118E-01,.1671879E-01,.1956038E-01,& + & .9280320E-02,.1124463E-01,.1334817E-01,.1580509E-01,.1857998E-01,& + & .8562651E-02,.1045470E-01,.1255035E-01,.1487256E-01,.1749111E-01,& + & .7862421E-02,.9650932E-02,.1175305E-01,.1399227E-01,.1656834E-01,& + & .7176180E-02,.8968905E-02,.1094204E-01,.1318820E-01,.1566044E-01,& + & .6553611E-02,.8323164E-02,.1026176E-01,.1243120E-01,.1484228E-01,& + & .6016277E-02,.7685907E-02,.9617875E-02,.1169791E-01,.1410813E-01,& + & .5488131E-02,.7123060E-02,.9006212E-02,.1103169E-01,.1339416E-01,& + & .5039153E-02,.6572314E-02,.8368057E-02,.1042322E-01,.1261228E-01,& + & .4678553E-02,.6104245E-02,.7858028E-02,.9862751E-02,.1203004E-01,& + & .4397629E-02,.5698528E-02,.7389611E-02,.9348370E-02,.1154387E-01,& + & .4125069E-02,.5371631E-02,.6928103E-02,.8831411E-02,.1098275E-01,& + & .3904687E-02,.5099382E-02,.6546356E-02,.8396888E-02,.1047269E-01,& + & .3677700E-02,.4862089E-02,.6220196E-02,.7951650E-02,.1006273E-01,& + & .3646869E-02,.4855547E-02,.6218200E-02,.7940987E-02,.1000532E-01/ + + data absb( 1:120,10) / & + & .6563434E+01,.6536173E+01,.6509225E+01,.6480775E+01,.6453855E+01,& + & .6694993E+01,.6668788E+01,.6641684E+01,.6613791E+01,.6586857E+01,& + & .6814067E+01,.6788196E+01,.6761389E+01,.6734157E+01,.6706224E+01,& + & .6922709E+01,.6896320E+01,.6870266E+01,.6842505E+01,.6814432E+01,& + & .7018842E+01,.6992813E+01,.6966297E+01,.6939182E+01,.6910339E+01,& + & .7104680E+01,.7079554E+01,.7053120E+01,.7025060E+01,.6997053E+01,& + & .7178134E+01,.7153173E+01,.7126816E+01,.7099394E+01,.7069733E+01,& + & .7237652E+01,.7212460E+01,.7187023E+01,.7158873E+01,.7129293E+01,& + & .7288276E+01,.7263276E+01,.7236743E+01,.7208943E+01,.7178798E+01,& + & .7329577E+01,.7304627E+01,.7277602E+01,.7249474E+01,.7218919E+01,& + & .7364634E+01,.7339549E+01,.7311831E+01,.7282930E+01,.7252217E+01,& + & .7393382E+01,.7367435E+01,.7340013E+01,.7310737E+01,.7279210E+01,& + & .7416720E+01,.7390784E+01,.7362566E+01,.7332879E+01,.7300963E+01,& + & .7435429E+01,.7408936E+01,.7380806E+01,.7350034E+01,.7317321E+01,& + & .7450559E+01,.7423883E+01,.7395076E+01,.7363982E+01,.7330904E+01,& + & .7462543E+01,.7435279E+01,.7405991E+01,.7374365E+01,.7340536E+01,& + & .7471315E+01,.7443887E+01,.7414078E+01,.7381879E+01,.7347478E+01,& + & .7478800E+01,.7450609E+01,.7419846E+01,.7387182E+01,.7352811E+01,& + & .7483666E+01,.7454950E+01,.7423611E+01,.7390401E+01,.7355051E+01,& + & .7487253E+01,.7457765E+01,.7425717E+01,.7391895E+01,.7356050E+01,& + & .7488506E+01,.7458765E+01,.7426508E+01,.7392054E+01,.7355156E+01,& + & .7489850E+01,.7459250E+01,.7426035E+01,.7391305E+01,.7353645E+01,& + & .7492443E+01,.7461624E+01,.7428244E+01,.7392628E+01,.7354878E+01,& + & .7497726E+01,.7466429E+01,.7432747E+01,.7397279E+01,.7358181E+01/ + + data absb(121:235,10) / & + & .7505737E+01,.7474800E+01,.7440929E+01,.7405596E+01,.7366801E+01,& + & .7513970E+01,.7482707E+01,.7449119E+01,.7413672E+01,.7375439E+01,& + & .7520741E+01,.7489941E+01,.7456502E+01,.7420983E+01,.7383218E+01,& + & .7530440E+01,.7499850E+01,.7466874E+01,.7431912E+01,.7393870E+01,& + & .7538723E+01,.7509468E+01,.7476827E+01,.7442592E+01,.7405041E+01,& + & .7547204E+01,.7518633E+01,.7486628E+01,.7452286E+01,.7415815E+01,& + & .7556213E+01,.7528691E+01,.7497855E+01,.7463955E+01,.7428134E+01,& + & .7565953E+01,.7538872E+01,.7508898E+01,.7475761E+01,.7440938E+01,& + & .7575062E+01,.7548586E+01,.7519907E+01,.7487622E+01,.7453098E+01,& + & .7584131E+01,.7558667E+01,.7530653E+01,.7499618E+01,.7465741E+01,& + & .7593779E+01,.7569486E+01,.7542361E+01,.7512145E+01,.7479280E+01,& + & .7602657E+01,.7580065E+01,.7553432E+01,.7524179E+01,.7492239E+01,& + & .7610916E+01,.7589199E+01,.7564289E+01,.7535843E+01,.7505070E+01,& + & .7618668E+01,.7597891E+01,.7574135E+01,.7546664E+01,.7516426E+01,& + & .7625181E+01,.7605859E+01,.7582588E+01,.7556608E+01,.7527157E+01,& + & .7630829E+01,.7612911E+01,.7590839E+01,.7566252E+01,.7537672E+01,& + & .7636310E+01,.7619845E+01,.7598957E+01,.7575011E+01,.7547925E+01,& + & .7640632E+01,.7625839E+01,.7606042E+01,.7583011E+01,.7556788E+01,& + & .7644312E+01,.7630300E+01,.7612179E+01,.7589767E+01,.7564669E+01,& + & .7647263E+01,.7634539E+01,.7617801E+01,.7596900E+01,.7572581E+01,& + & .7650044E+01,.7638295E+01,.7623237E+01,.7603393E+01,.7580008E+01,& + & .7651936E+01,.7641531E+01,.7627671E+01,.7609561E+01,.7586309E+01,& + & .7652501E+01,.7642169E+01,.7629030E+01,.7611100E+01,.7588572E+01/ + +! --- + data forref(1:4,1:10) / & + & .2145040E-06,.4604180E-06,.3576080E-05,.1920370E-05,.1425760E-05,& + & .3644630E-05,.1170330E-04,.1120850E-04,.1015360E-04,.1240960E-04,& + & .5091900E-04,.5652820E-04,.1433940E-03,.1547000E-03,.4664980E-03,& + & .9188290E-03,.2516310E-02,.2417290E-02,.2400570E-02,.3504080E-02,& + & .4103090E-02,.4168510E-02,.3909250E-02,.3836940E-02,.4453870E-02,& + & .4486570E-02,.4323100E-02,.3707390E-02,.4581500E-02,.4600140E-02,& + & .4502450E-02,.3367180E-02,.4682248E-02,.4680093E-02,.4684726E-02,& + & .3680135E-02,.5243173E-02,.5159096E-02,.5132896E-02,.3931064E-02/ + + + data selfref(1:10,1:10) / & + & .2170580E-03,.1763910E-03,.1433420E-03,.1164860E-03,.9466140E-04,& + & .7692570E-04,.6251310E-04,.5080070E-04,.4128280E-04,.3354810E-04,& + & .5980550E-03,.4848050E-03,.3930000E-03,.3185800E-03,.2582520E-03,& + & .2093480E-03,.1697050E-03,.1375690E-03,.1115180E-03,.9040080E-04,& + & .1026910E-02,.9302810E-03,.8427400E-03,.7634370E-03,.6915960E-03,& + & .6265160E-03,.5675600E-03,.5141520E-03,.4657690E-03,.4219400E-03,& + & .3885690E-02,.3650980E-02,.3430450E-02,.3223240E-02,.3028540E-02,& + & .2845610E-02,.2673720E-02,.2512220E-02,.2360470E-02,.2217890E-02,& + & .3498450E-01,.3266780E-01,.3050450E-01,.2848450E-01,.2659820E-01,& + & .2483690E-01,.2319210E-01,.2165630E-01,.2022220E-01,.1888310E-01,& + & .6137050E-01,.5626760E-01,.5158900E-01,.4729940E-01,.4336650E-01,& + & .3976060E-01,.3645450E-01,.3342330E-01,.3064420E-01,.2809610E-01,& + & .6569810E-01,.6026600E-01,.5528300E-01,.5071200E-01,.4651900E-01,& + & .4267260E-01,.3914430E-01,.3590770E-01,.3293870E-01,.3021530E-01,& + & .6717820E-01,.6164610E-01,.5656950E-01,.5191100E-01,.4763610E-01,& + & .4371320E-01,.4011340E-01,.3681000E-01,.3377870E-01,.3099700E-01,& + & .6790842E-01,.6238861E-01,.5731740E-01,.5265845E-01,.4837825E-01,& + & .4444589E-01,.4083320E-01,.3751416E-01,.3446487E-01,.3166347E-01,& + & .7454175E-01,.6857684E-01,.6309064E-01,.5804463E-01,.5340338E-01,& + & .4913438E-01,.4520762E-01,.4159562E-01,.3827306E-01,.3521673E-01/ + +! --- ch4 + data absch4(1:10) / & + & .1013810E-02,.6336920E-02,.1941850E-01,.4832100E-01,.2365740E-02,& + & .6619730E-03,.5645520E-03,.2831830E-03,.6714756E-04,.2647642E-06/ + +!........................................! + end module module_radsw_kgb20 ! +!========================================! + + +!> This module sets up absorption coeffients for band 21: 6150-7700 +!! cm-1 (low - h2o,co2; high - h2o,co2) +!========================================! + module module_radsw_kgb21 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 21: 6150-7700 cm-1 (low - j2o,co2; high - h2o,co2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG21 + +! + implicit none +! + private +! +!> msa21=585 + integer, public :: MSA21 +!> msb21=1175 + integer, public :: MSB21 +!> msf21=10 + integer, public :: MSF21 +!> mfr21=4 + integer, public :: MFR21 + parameter (MSA21=585, MSB21=1175, MSF21=10, MFR21=4) + + real (kind=kind_phys), public :: forref(MFR21,NG21) + +!> the array absa(585,NG21) (ka((9,5,13,NG21)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 10, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA21,NG21) + +!> the array absb(1175,10) (kb(5,5,13:59,10)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 10, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB21,NG21) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 10). + real (kind=kind_phys), public :: selfref(MSF21,NG21) + +!> rayleigh extinction coefficient at \f$v=6925cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 9.41e-09 + + + data absa( 1:180, 1) / & + & .3148200E-07,.6401000E-05,.9501700E-05,.1173500E-04,.1356100E-04,& + & .1507700E-04,.1612100E-04,.1613800E-04,.4168700E-06,.2979100E-07,& + & .6820600E-05,.1026000E-04,.1276400E-04,.1488000E-04,.1666500E-04,& + & .1794400E-04,.1817000E-04,.4424600E-06,.2827200E-07,.7244800E-05,& + & .1108300E-04,.1386600E-04,.1625600E-04,.1832300E-04,.1988600E-04,& + & .2022900E-04,.4747200E-06,.2690000E-07,.7693500E-05,.1193400E-04,& + & .1501500E-04,.1765700E-04,.2003800E-04,.2190200E-04,.2236100E-04,& + & .5077000E-06,.2565600E-07,.8166100E-05,.1276900E-04,.1618100E-04,& + & .1912700E-04,.2175500E-04,.2396300E-04,.2442100E-04,.5420500E-06,& + & .2639600E-07,.5222500E-05,.7722100E-05,.9515000E-05,.1100400E-04,& + & .1219500E-04,.1303700E-04,.1298500E-04,.3209700E-06,.2494500E-07,& + & .5573700E-05,.8361200E-05,.1037500E-04,.1211600E-04,.1356900E-04,& + & .1456100E-04,.1471100E-04,.3457900E-06,.2364600E-07,.5933300E-05,& + & .9053100E-05,.1130100E-04,.1324700E-04,.1495600E-04,.1619300E-04,& + & .1639600E-04,.3720000E-06,.2247600E-07,.6314400E-05,.9773200E-05,& + & .1227400E-04,.1443600E-04,.1637700E-04,.1787900E-04,.1822300E-04,& + & .4005100E-06,.2141500E-07,.6713300E-05,.1047100E-04,.1326400E-04,& + & .1568100E-04,.1784300E-04,.1962700E-04,.1995400E-04,.4292900E-06,& + & .2239700E-07,.4193000E-05,.6155900E-05,.7554400E-05,.8690200E-05,& + & .9589600E-05,.1026900E-04,.1011400E-04,.2414800E-06,.2112400E-07,& + & .4483700E-05,.6678600E-05,.8247500E-05,.9635300E-05,.1074200E-04,& + & .1146900E-04,.1155600E-04,.2630400E-06,.1998800E-07,.4783900E-05,& + & .7249900E-05,.9022900E-05,.1056000E-04,.1190000E-04,.1285900E-04,& + & .1293500E-04,.2861800E-06,.1896800E-07,.5104000E-05,.7858600E-05,& + & .9830800E-05,.1155100E-04,.1309400E-04,.1424000E-04,.1445500E-04,& + & .3098300E-06,.1804700E-07,.5436600E-05,.8446200E-05,.1067000E-04,& + & .1258500E-04,.1431300E-04,.1569500E-04,.1593400E-04,.3325500E-06,& + & .1908000E-07,.3340900E-05,.4873800E-05,.5935400E-05,.6787700E-05,& + & .7490000E-05,.7914200E-05,.7720000E-05,.1846600E-06,.1795400E-07,& + & .3591000E-05,.5296000E-05,.6503700E-05,.7574400E-05,.8408200E-05,& + & .8942200E-05,.8930200E-05,.2029200E-06,.1695400E-07,.3831700E-05,& + & .5753600E-05,.7132200E-05,.8342400E-05,.9378800E-05,.1006300E-04,& + & .1009800E-04,.2217300E-06,.1605900E-07,.4093200E-05,.6258600E-05,& + & .7796100E-05,.9147500E-05,.1034700E-04,.1122200E-04,.1131200E-04,& + & .2400500E-06,.1525400E-07,.4367800E-05,.6752500E-05,.8487300E-05,& + & .9999500E-05,.1135300E-04,.1241600E-04,.1258600E-04,.2593900E-06/ + + data absa(181:315, 1) / & + & .1626100E-07,.2654000E-05,.3854100E-05,.4644300E-05,.5296100E-05,& + & .5805400E-05,.6071800E-05,.5854000E-05,.1427400E-06,.1526500E-07,& + & .2859800E-05,.4183100E-05,.5122100E-05,.5911000E-05,.6520700E-05,& + & .6976100E-05,.6868500E-05,.1572500E-06,.1438400E-07,.3062300E-05,& + & .4552800E-05,.5612400E-05,.6565000E-05,.7343600E-05,.7820800E-05,& + & .7852300E-05,.1727100E-06,.1359900E-07,.3272000E-05,.4962200E-05,& + & .6160500E-05,.7224400E-05,.8158200E-05,.8797100E-05,.8809600E-05,& + & .1876600E-06,.1289500E-07,.3498500E-05,.5383300E-05,.6724000E-05,& + & .7909100E-05,.8968800E-05,.9769800E-05,.9863900E-05,.2037500E-06,& + & .1389800E-07,.2098100E-05,.3038400E-05,.3604100E-05,.4104000E-05,& + & .4433400E-05,.4576100E-05,.4395000E-05,.1102500E-06,.1301100E-07,& + & .2264500E-05,.3289000E-05,.4004200E-05,.4585100E-05,.5047300E-05,& + & .5325000E-05,.5185400E-05,.1222700E-06,.1223100E-07,.2432200E-05,& + & .3584200E-05,.4391500E-05,.5125900E-05,.5690300E-05,.6034300E-05,& + & .6016600E-05,.1350600E-06,.1153900E-07,.2603200E-05,.3910700E-05,& + & .4832100E-05,.5652500E-05,.6362500E-05,.6807800E-05,.6802400E-05,& + & .1471900E-06,.1092100E-07,.2786600E-05,.4257800E-05,.5291900E-05,& + & .6218100E-05,.7036200E-05,.7614000E-05,.7651900E-05,.1605200E-06,& + & .1188600E-07,.1656300E-05,.2386000E-05,.2827600E-05,.3144900E-05,& + & .3377100E-05,.3430500E-05,.3282400E-05,.8494300E-07,.1109600E-07,& + & .1787400E-05,.2586100E-05,.3110000E-05,.3542500E-05,.3873700E-05,& + & .4046800E-05,.3893300E-05,.9473400E-07,.1040500E-07,.1928600E-05,& + & .2816600E-05,.3441700E-05,.3978600E-05,.4380400E-05,.4675900E-05,& + & .4583500E-05,.1053100E-06,.9794800E-08,.2068000E-05,.3074100E-05,& + & .3780300E-05,.4416300E-05,.4942000E-05,.5247700E-05,.5250900E-05,& + & .1151700E-06,.9252200E-08,.2214000E-05,.3355800E-05,.4154400E-05,& + & .4871900E-05,.5496800E-05,.5922500E-05,.5902700E-05,.1261800E-06/ + + data absa(316:450, 1) / & + & .1016400E-07,.1305600E-05,.1869000E-05,.2194000E-05,.2421000E-05,& + & .2550400E-05,.2567600E-05,.2444400E-05,.6602100E-07,.9461200E-08,& + & .1410600E-05,.2039800E-05,.2413600E-05,.2742400E-05,.2957800E-05,& + & .3044600E-05,.2918200E-05,.7398500E-07,.8848900E-08,.1525600E-05,& + & .2212300E-05,.2689400E-05,.3070400E-05,.3380800E-05,.3552100E-05,& + & .3452600E-05,.8266600E-07,.8311100E-08,.1639600E-05,.2415900E-05,& + & .2956300E-05,.3450400E-05,.3819600E-05,.4042500E-05,.4009300E-05,& + & .9094000E-07,.7834900E-08,.1757000E-05,.2639800E-05,.3254700E-05,& + & .3806000E-05,.4281300E-05,.4573200E-05,.4546500E-05,.1002200E-06,& + & .8698300E-08,.1028400E-05,.1473400E-05,.1697300E-05,.1855100E-05,& + & .1922300E-05,.1922200E-05,.1828900E-05,.5346000E-07,.8071200E-08,& + & .1114100E-05,.1601600E-05,.1890200E-05,.2102700E-05,.2250400E-05,& + & .2280000E-05,.2174900E-05,.6018000E-07,.7528400E-08,.1203300E-05,& + & .1737600E-05,.2084900E-05,.2371900E-05,.2590600E-05,.2697700E-05,& + & .2591000E-05,.6688600E-07,.7054100E-08,.1297900E-05,.1895900E-05,& + & .2309000E-05,.2669500E-05,.2936700E-05,.3123900E-05,.3057400E-05,& + & .7397800E-07,.6635900E-08,.1393700E-05,.2072000E-05,.2544800E-05,& + & .2968000E-05,.3320800E-05,.3519100E-05,.3509700E-05,.8172400E-07,& + & .7400600E-08,.8170500E-06,.1161000E-05,.1332500E-05,.1430500E-05,& + & .1466800E-05,.1464200E-05,.1376500E-05,.4472400E-07,.6847700E-08,& + & .8830600E-06,.1264000E-05,.1476800E-05,.1632900E-05,.1720900E-05,& + & .1730600E-05,.1644100E-05,.5068800E-07,.6371700E-08,.9552200E-06,& + & .1378300E-05,.1630300E-05,.1854600E-05,.1996300E-05,.2057000E-05,& + & .1967800E-05,.5605200E-07,.5957600E-08,.1033100E-05,.1497500E-05,& + & .1818000E-05,.2077000E-05,.2281300E-05,.2402100E-05,.2335000E-05,& + & .6241200E-07,.5594000E-08,.1110200E-05,.1637000E-05,.1999900E-05,& + & .2334900E-05,.2590000E-05,.2732800E-05,.2705700E-05,.6946600E-07/ + + data absa(451:585, 1) / & + & .6061700E-08,.6716700E-06,.9559400E-06,.1093900E-05,.1176700E-05,& + & .1205900E-05,.1203200E-05,.1131400E-05,.3709300E-07,.5608700E-08,& + & .7270400E-06,.1040600E-05,.1213700E-05,.1343400E-05,.1417100E-05,& + & .1424600E-05,.1352100E-05,.4191800E-07,.5218700E-08,.7868100E-06,& + & .1133800E-05,.1341900E-05,.1525400E-05,.1642600E-05,.1695000E-05,& + & .1620300E-05,.4633900E-07,.4879300E-08,.8501300E-06,.1232700E-05,& + & .1497100E-05,.1710900E-05,.1877600E-05,.1978400E-05,.1924000E-05,& + & .5172500E-07,.4581500E-08,.9142000E-06,.1342700E-05,.1645800E-05,& + & .1922100E-05,.2132300E-05,.2249000E-05,.2226300E-05,.5755500E-07,& + & .4962900E-08,.5522300E-06,.7867700E-06,.8978900E-06,.9677800E-06,& + & .9914800E-06,.9888300E-06,.9302800E-06,.3061000E-07,.4592000E-08,& + & .5983200E-06,.8563200E-06,.9973000E-06,.1105200E-05,.1166500E-05,& + & .1172900E-05,.1112500E-05,.3455300E-07,.4272700E-08,.6476000E-06,& + & .9331500E-06,.1104100E-05,.1255200E-05,.1352100E-05,.1395600E-05,& + & .1333300E-05,.3817600E-07,.3994900E-08,.6992600E-06,.1011000E-05,& + & .1230400E-05,.1408300E-05,.1544200E-05,.1628300E-05,.1583700E-05,& + & .4264800E-07,.3751000E-08,.7523900E-06,.1100600E-05,.1353500E-05,& + & .1578500E-05,.1754700E-05,.1850100E-05,.1829800E-05,.4745200E-07,& + & .4063300E-08,.4537800E-06,.6471900E-06,.7363700E-06,.7957100E-06,& + & .8150300E-06,.8126400E-06,.7648800E-06,.2508000E-07,.3759600E-08,& + & .4920800E-06,.7043000E-06,.8189400E-06,.9085600E-06,.9591900E-06,& + & .9643500E-06,.9141100E-06,.2829300E-07,.3498200E-08,.5325900E-06,& + & .7637000E-06,.9076100E-06,.1031600E-05,.1111600E-05,.1147200E-05,& + & .1095600E-05,.3126700E-07,.3270700E-08,.5748800E-06,.8283300E-06,& + & .1009600E-05,.1157700E-05,.1268800E-05,.1338800E-05,.1301500E-05,& + & .3493000E-07,.3071000E-08,.6183200E-06,.9025000E-06,.1112000E-05,& + & .1296200E-05,.1442400E-05,.1520600E-05,.1503200E-05,.3886100E-07/ + + data absa( 1:180, 2) / & + & .1421500E-06,.6572600E-04,.1132700E-03,.1532400E-03,.1847300E-03,& + & .2065800E-03,.2160300E-03,.2061700E-03,.1325200E-04,.1345200E-06,& + & .6952100E-04,.1205900E-03,.1634200E-03,.1961300E-03,.2198700E-03,& + & .2294600E-03,.2187900E-03,.1481600E-04,.1276600E-06,.7331300E-04,& + & .1278600E-03,.1730300E-03,.2075400E-03,.2332600E-03,.2432400E-03,& + & .2295600E-03,.1653600E-04,.1214700E-06,.7708700E-04,.1352100E-03,& + & .1826300E-03,.2190400E-03,.2461400E-03,.2563700E-03,.2406000E-03,& + & .1809200E-04,.1158400E-06,.8094600E-04,.1423300E-03,.1923000E-03,& + & .2304700E-03,.2586900E-03,.2690400E-03,.2513900E-03,.1976800E-04,& + & .1191800E-06,.5516700E-04,.9455700E-04,.1276000E-03,.1532200E-03,& + & .1714800E-03,.1789400E-03,.1704900E-03,.1071000E-04,.1126400E-06,& + & .5858100E-04,.1011300E-03,.1364800E-03,.1633500E-03,.1828800E-03,& + & .1905900E-03,.1813100E-03,.1206700E-04,.1067800E-06,.6193500E-04,& + & .1075600E-03,.1449700E-03,.1733500E-03,.1943700E-03,.2024500E-03,& + & .1907000E-03,.1355300E-04,.1014900E-06,.6526100E-04,.1140400E-03,& + & .1533100E-03,.1832300E-03,.2055900E-03,.2138500E-03,.2002400E-03,& + & .1480100E-04,.9669900E-07,.6869800E-04,.1203800E-03,.1616700E-03,& + & .1930800E-03,.2163500E-03,.2247900E-03,.2096400E-03,.1624500E-04,& + & .1011200E-06,.4539900E-04,.7722600E-04,.1039700E-03,.1246200E-03,& + & .1395600E-03,.1453100E-03,.1381600E-03,.8363500E-05,.9538100E-07,& + & .4835700E-04,.8298600E-04,.1117300E-03,.1333800E-03,.1489800E-03,& + & .1553400E-03,.1478600E-03,.9491500E-05,.9025700E-07,.5135500E-04,& + & .8872700E-04,.1192000E-03,.1421500E-03,.1585900E-03,.1654100E-03,& + & .1562200E-03,.1068300E-04,.8565300E-07,.5432200E-04,.9436900E-04,& + & .1264600E-03,.1507200E-03,.1683800E-03,.1753600E-03,.1643300E-03,& + & .1176400E-04,.8149200E-07,.5730000E-04,.9994000E-04,.1335500E-03,& + & .1592900E-03,.1780000E-03,.1849600E-03,.1723400E-03,.1297900E-04,& + & .8613200E-07,.3691000E-04,.6234600E-04,.8362800E-04,.1002500E-03,& + & .1122400E-03,.1170600E-03,.1110900E-03,.6471500E-05,.8106200E-07,& + & .3949000E-04,.6727400E-04,.9038400E-04,.1078500E-03,.1202600E-03,& + & .1254300E-03,.1194400E-03,.7399100E-05,.7655300E-07,.4205500E-04,& + & .7226900E-04,.9695600E-04,.1152800E-03,.1283300E-03,.1339600E-03,& + & .1269700E-03,.8389900E-05,.7251600E-07,.4469600E-04,.7723500E-04,& + & .1032100E-03,.1227600E-03,.1367400E-03,.1426000E-03,.1338400E-03,& + & .9305200E-05,.6888100E-07,.4727300E-04,.8211800E-04,.1093500E-03,& + & .1301600E-03,.1450600E-03,.1508000E-03,.1406200E-03,.1031400E-04/ + + data absa(181:315, 2) / & + & .7340100E-07,.2977200E-04,.4995700E-04,.6672000E-04,.8010400E-04,& + & .8976100E-04,.9385300E-04,.8895300E-04,.5017100E-05,.6891600E-07,& + & .3197600E-04,.5421700E-04,.7257000E-04,.8667100E-04,.9665300E-04,& + & .1007300E-03,.9587500E-04,.5774600E-05,.6494500E-07,.3421900E-04,& + & .5841700E-04,.7832700E-04,.9295000E-04,.1035800E-03,.1080300E-03,& + & .1027400E-03,.6619700E-05,.6140500E-07,.3645700E-04,.6269400E-04,& + & .8375600E-04,.9935600E-04,.1105800E-03,.1154200E-03,.1085800E-03,& + & .7372900E-05,.5822900E-07,.3871300E-04,.6705900E-04,.8903300E-04,& + & .1057300E-03,.1176400E-03,.1224300E-03,.1144000E-03,.8214900E-05,& + & .6272300E-07,.2375000E-04,.3964300E-04,.5279600E-04,.6347800E-04,& + & .7115100E-04,.7464000E-04,.7019300E-04,.3889900E-05,.5873500E-07,& + & .2565700E-04,.4327400E-04,.5771900E-04,.6912400E-04,.7737500E-04,& + & .8049800E-04,.7654300E-04,.4483300E-05,.5522200E-07,.2756300E-04,& + & .4686600E-04,.6269900E-04,.7449400E-04,.8294600E-04,.8665300E-04,& + & .8250900E-04,.5163500E-05,.5210300E-07,.2952800E-04,.5047000E-04,& + & .6747300E-04,.7989900E-04,.8900400E-04,.9278600E-04,.8762800E-04,& + & .5810400E-05,.4931700E-07,.3144400E-04,.5417500E-04,.7200000E-04,& + & .8532200E-04,.9488500E-04,.9882600E-04,.9264800E-04,.6499700E-05,& + & .5363400E-07,.1886200E-04,.3132500E-04,.4157500E-04,.5014100E-04,& + & .5619000E-04,.5888200E-04,.5502600E-04,.2979500E-05,.5008400E-07,& + & .2047400E-04,.3434200E-04,.4573200E-04,.5488400E-04,.6149400E-04,& + & .6418700E-04,.6085700E-04,.3458900E-05,.4697300E-07,.2206300E-04,& + & .3741100E-04,.4989300E-04,.5947500E-04,.6627900E-04,.6912900E-04,& + & .6575800E-04,.3998300E-05,.4422400E-07,.2376400E-04,.4048100E-04,& + & .5410700E-04,.6402600E-04,.7135000E-04,.7432800E-04,.7051300E-04,& + & .4552600E-05,.4177700E-07,.2543400E-04,.4355500E-04,.5795800E-04,& + & .6859900E-04,.7630400E-04,.7945600E-04,.7464900E-04,.5104600E-05/ + + data absa(316:450, 2) / & + & .4585700E-07,.1494500E-04,.2459400E-04,.3269600E-04,.3957100E-04,& + & .4434800E-04,.4609000E-04,.4303400E-04,.2283300E-05,.4269700E-07,& + & .1626500E-04,.2719800E-04,.3610800E-04,.4338100E-04,.4864200E-04,& + & .5094300E-04,.4784800E-04,.2666900E-05,.3994400E-07,.1761600E-04,& + & .2977500E-04,.3957700E-04,.4736600E-04,.5279100E-04,.5499200E-04,& + & .5223600E-04,.3093200E-05,.3752200E-07,.1904200E-04,.3235100E-04,& + & .4312600E-04,.5115300E-04,.5698700E-04,.5931600E-04,.5643800E-04,& + & .3566600E-05,.3537600E-07,.2047600E-04,.3494600E-04,.4652100E-04,& + & .5500900E-04,.6122100E-04,.6371400E-04,.6003500E-04,.4003700E-05,& + & .3923300E-07,.1181700E-04,.1925400E-04,.2559600E-04,.3084300E-04,& + & .3457400E-04,.3603500E-04,.3342500E-04,.1767300E-05,.3641800E-07,& + & .1291400E-04,.2140400E-04,.2837200E-04,.3416100E-04,.3832100E-04,& + & .4005300E-04,.3743500E-04,.2075100E-05,.3397900E-07,.1402600E-04,& + & .2357400E-04,.3131600E-04,.3751400E-04,.4197700E-04,.4374700E-04,& + & .4134600E-04,.2415100E-05,.3184400E-07,.1520500E-04,.2577000E-04,& + & .3423100E-04,.4072300E-04,.4531500E-04,.4720200E-04,.4486900E-04,& + & .2815100E-05,.2996100E-07,.1642000E-04,.2795500E-04,.3718700E-04,& + & .4394100E-04,.4887300E-04,.5085600E-04,.4817000E-04,.3173300E-05,& + & .3337300E-07,.9350500E-05,.1521600E-04,.2019800E-04,.2424400E-04,& + & .2707700E-04,.2818600E-04,.2599600E-04,.1394100E-05,.3089300E-07,& + & .1028400E-04,.1690200E-04,.2246800E-04,.2707200E-04,.3038200E-04,& + & .3160300E-04,.2945600E-04,.1635200E-05,.2875400E-07,.1120700E-04,& + & .1871500E-04,.2484900E-04,.2981500E-04,.3337900E-04,.3490100E-04,& + & .3283600E-04,.1918800E-05,.2689200E-07,.1217200E-04,.2057800E-04,& + & .2726900E-04,.3253600E-04,.3618200E-04,.3770300E-04,.3575000E-04,& + & .2246700E-05,.2525500E-07,.1319500E-04,.2242200E-04,.2978100E-04,& + & .3522000E-04,.3915700E-04,.4071900E-04,.3872900E-04,.2553500E-05/ + + data absa(451:585, 2) / & + & .2733500E-07,.7749100E-05,.1260700E-04,.1669500E-04,.2009300E-04,& + & .2243100E-04,.2334500E-04,.2152200E-04,.1156900E-05,.2530300E-07,& + & .8532200E-05,.1402200E-04,.1859300E-04,.2237800E-04,.2513300E-04,& + & .2616100E-04,.2437900E-04,.1370900E-05,.2355100E-07,.9291200E-05,& + & .1553600E-04,.2061800E-04,.2472200E-04,.2764700E-04,.2887400E-04,& + & .2719600E-04,.1609900E-05,.2202500E-07,.1011700E-04,.1711500E-04,& + & .2264500E-04,.2697400E-04,.2994700E-04,.3121000E-04,.2958100E-04,& + & .1884500E-05,.2068400E-07,.1097700E-04,.1864500E-04,.2473400E-04,& + & .2920300E-04,.3245300E-04,.3373300E-04,.3205600E-04,.2132600E-05,& + & .2238000E-07,.6414400E-05,.1043600E-04,.1380200E-04,.1662200E-04,& + & .1855700E-04,.1931400E-04,.1779300E-04,.9590600E-06,.2071600E-07,& + & .7060300E-05,.1162500E-04,.1538500E-04,.1850300E-04,.2077600E-04,& + & .2163000E-04,.2015200E-04,.1136300E-05,.1928200E-07,.7696000E-05,& + & .1288600E-04,.1708700E-04,.2047500E-04,.2286700E-04,.2385600E-04,& + & .2250600E-04,.1340000E-05,.1803200E-07,.8398300E-05,.1420600E-04,& + & .1878300E-04,.2233400E-04,.2476400E-04,.2581500E-04,.2446100E-04,& + & .1563700E-05,.1693400E-07,.9118600E-05,.1549100E-04,.2051300E-04,& + & .2420100E-04,.2686400E-04,.2791700E-04,.2649100E-04,.1770700E-05,& + & .1832300E-07,.5302200E-05,.8627300E-05,.1138500E-04,.1372900E-04,& + & .1531800E-04,.1595200E-04,.1469300E-04,.7892700E-06,.1696100E-07,& + & .5831600E-05,.9620400E-05,.1271700E-04,.1527500E-04,.1714100E-04,& + & .1786300E-04,.1663900E-04,.9365900E-06,.1578700E-07,.6371000E-05,& + & .1067500E-04,.1414000E-04,.1692500E-04,.1888100E-04,.1967500E-04,& + & .1856400E-04,.1105000E-05,.1476400E-07,.6960700E-05,.1177900E-04,& + & .1555400E-04,.1847500E-04,.2046100E-04,.2132000E-04,.2020700E-04,& + & .1286800E-05,.1386500E-07,.7561100E-05,.1284300E-04,.1699100E-04,& + & .2002900E-04,.2220800E-04,.2307900E-04,.2183800E-04,.1456500E-05/ + + data absa( 1:180, 3) / & + & .5594800E-06,.4347200E-03,.6568900E-03,.8023700E-03,.9032600E-03,& + & .9599500E-03,.9424200E-03,.8180100E-03,.1838000E-03,.5317500E-06,& + & .4539500E-03,.6877900E-03,.8404000E-03,.9459800E-03,.1001100E-02,& + & .9848100E-03,.8574800E-03,.1956700E-03,.5064800E-06,.4683500E-03,& + & .7140300E-03,.8768400E-03,.9852000E-03,.1039300E-02,.1023300E-02,& + & .8972900E-03,.2072500E-03,.4833000E-06,.4814300E-03,.7397900E-03,& + & .9106300E-03,.1021200E-02,.1076200E-02,.1060000E-02,.9350700E-03,& + & .2181400E-03,.4619500E-06,.4941300E-03,.7647000E-03,.9420800E-03,& + & .1054700E-02,.1109900E-02,.1096000E-02,.9716400E-03,.2305600E-03,& + & .4681300E-06,.3671100E-03,.5574300E-03,.6807000E-03,.7661400E-03,& + & .8144200E-03,.7994000E-03,.6969100E-03,.1498800E-03,.4445000E-06,& + & .3841300E-03,.5850200E-03,.7150600E-03,.8040900E-03,.8519100E-03,& + & .8372200E-03,.7323100E-03,.1598500E-03,.4230100E-06,.3974400E-03,& + & .6085200E-03,.7474100E-03,.8392000E-03,.8858800E-03,.8720600E-03,& + & .7667700E-03,.1696800E-03,.4033500E-06,.4092700E-03,.6320000E-03,& + & .7783500E-03,.8719000E-03,.9184300E-03,.9046700E-03,.7985900E-03,& + & .1794800E-03,.3852900E-06,.4203400E-03,.6535300E-03,.8075800E-03,& + & .9024800E-03,.9492900E-03,.9371500E-03,.8313600E-03,.1901800E-03,& + & .3959100E-06,.3045900E-03,.4636400E-03,.5659000E-03,.6368000E-03,& + & .6768100E-03,.6651700E-03,.5810600E-03,.1193600E-03,.3753800E-06,& + & .3203600E-03,.4887400E-03,.5964900E-03,.6717000E-03,.7116100E-03,& + & .6994300E-03,.6115900E-03,.1280400E-03,.3567500E-06,.3332100E-03,& + & .5099900E-03,.6259100E-03,.7031900E-03,.7433300E-03,.7301500E-03,& + & .6407000E-03,.1364200E-03,.3397800E-06,.3438200E-03,.5310200E-03,& + & .6539100E-03,.7327800E-03,.7730300E-03,.7599000E-03,.6697900E-03,& + & .1447700E-03,.3242200E-06,.3541600E-03,.5507100E-03,.6804200E-03,& + & .7604100E-03,.8011800E-03,.7891400E-03,.6992300E-03,.1536500E-03,& + & .3359800E-06,.2497000E-03,.3805300E-03,.4646400E-03,.5223400E-03,& + & .5548800E-03,.5467500E-03,.4779400E-03,.9527500E-04,.3180000E-06,& + & .2641500E-03,.4031300E-03,.4921000E-03,.5535900E-03,.5866100E-03,& + & .5769400E-03,.5039300E-03,.1029200E-03,.3017700E-06,.2763800E-03,& + & .4226800E-03,.5182300E-03,.5834800E-03,.6159100E-03,.6049700E-03,& + & .5294700E-03,.1101600E-03,.2870300E-06,.2861200E-03,.4416500E-03,& + & .5432600E-03,.6101000E-03,.6429900E-03,.6315100E-03,.5555800E-03,& + & .1170800E-03,.2735600E-06,.2955000E-03,.4590300E-03,.5670300E-03,& + & .6352200E-03,.6683900E-03,.6581200E-03,.5814200E-03,.1244400E-03/ + + data absa(181:315, 3) / & + & .2851700E-06,.2030500E-03,.3094000E-03,.3785400E-03,.4251600E-03,& + & .4516700E-03,.4461700E-03,.3900600E-03,.7639400E-04,.2694300E-06,& + & .2163100E-03,.3294200E-03,.4027900E-03,.4528100E-03,.4795900E-03,& + & .4727400E-03,.4121900E-03,.8309300E-04,.2552600E-06,.2276000E-03,& + & .3473600E-03,.4260300E-03,.4792800E-03,.5057300E-03,.4975300E-03,& + & .4342300E-03,.8913700E-04,.2424500E-06,.2366100E-03,.3642300E-03,& + & .4483200E-03,.5037300E-03,.5302100E-03,.5209200E-03,.4571500E-03,& + & .9502600E-04,.2307900E-06,.2449000E-03,.3797900E-03,.4695800E-03,& + & .5267100E-03,.5536000E-03,.5442200E-03,.4798200E-03,.1010000E-03,& + & .2425800E-06,.1637400E-03,.2488900E-03,.3052600E-03,.3425600E-03,& + & .3643700E-03,.3605400E-03,.3164300E-03,.6098300E-04,.2287300E-06,& + & .1755700E-03,.2667400E-03,.3266200E-03,.3669800E-03,.3886200E-03,& + & .3839500E-03,.3348100E-03,.6671700E-04,.2163200E-06,.1859600E-03,& + & .2831500E-03,.3471000E-03,.3903200E-03,.4118600E-03,.4059700E-03,& + & .3534700E-03,.7180500E-04,.2051500E-06,.1941200E-03,.2982500E-03,& + & .3667200E-03,.4122300E-03,.4337000E-03,.4265400E-03,.3730800E-03,& + & .7695000E-04,.1950000E-06,.2016300E-03,.3117700E-03,.3857300E-03,& + & .4329800E-03,.4547400E-03,.4465900E-03,.3927300E-03,.8185400E-04,& + & .2064400E-06,.1308800E-03,.1988300E-03,.2445300E-03,.2737900E-03,& + & .2913300E-03,.2897200E-03,.2552700E-03,.4848300E-04,.1942200E-06,& + & .1412300E-03,.2146400E-03,.2630700E-03,.2952000E-03,.3126200E-03,& + & .3097600E-03,.2705700E-03,.5318900E-04,.1833400E-06,.1505600E-03,& + & .2294500E-03,.2810200E-03,.3157000E-03,.3333600E-03,.3292100E-03,& + & .2865700E-03,.5766400E-04,.1735900E-06,.1584500E-03,.2425400E-03,& + & .2981200E-03,.3353300E-03,.3527300E-03,.3473700E-03,.3029000E-03,& + & .6208000E-04,.1647600E-06,.1651500E-03,.2547200E-03,.3149200E-03,& + & .3536800E-03,.3713400E-03,.3646600E-03,.3197100E-03,.6628300E-04/ + + data absa(316:450, 3) / & + & .1756400E-06,.1037700E-03,.1579900E-03,.1944300E-03,.2177500E-03,& + & .2322100E-03,.2317800E-03,.2051800E-03,.3861300E-04,.1648600E-06,& + & .1129100E-03,.1717700E-03,.2106000E-03,.2360500E-03,.2502300E-03,& + & .2486000E-03,.2184000E-03,.4257400E-04,.1553200E-06,.1216000E-03,& + & .1847200E-03,.2261300E-03,.2538300E-03,.2681300E-03,.2656900E-03,& + & .2314900E-03,.4643800E-04,.1467900E-06,.1287100E-03,.1962900E-03,& + & .2411700E-03,.2710100E-03,.2854600E-03,.2814800E-03,.2451100E-03,& + & .5013200E-04,.1391300E-06,.1347000E-03,.2071100E-03,.2558300E-03,& + & .2873500E-03,.3017100E-03,.2965300E-03,.2593100E-03,.5389200E-04,& + & .1495000E-06,.8194100E-04,.1247300E-03,.1536300E-03,.1725700E-03,& + & .1840900E-03,.1842400E-03,.1643900E-03,.3077200E-04,.1399800E-06,& + & .8970200E-04,.1365500E-03,.1676300E-03,.1877900E-03,.1991900E-03,& + & .1987700E-03,.1758100E-03,.3402200E-04,.1316000E-06,.9726300E-04,& + & .1477600E-03,.1808900E-03,.2029200E-03,.2145100E-03,.2131700E-03,& + & .1864000E-03,.3738100E-04,.1241500E-06,.1038900E-03,.1581700E-03,& + & .1940400E-03,.2179400E-03,.2298000E-03,.2271500E-03,.1978400E-03,& + & .4045700E-04,.1174900E-06,.1093400E-03,.1676800E-03,.2068000E-03,& + & .2323400E-03,.2441400E-03,.2402600E-03,.2095900E-03,.4358600E-04,& + & .1265800E-06,.6476300E-04,.9869000E-04,.1217000E-03,.1370900E-03,& + & .1464400E-03,.1470900E-03,.1321500E-03,.2473700E-04,.1182600E-06,& + & .7140500E-04,.1087500E-03,.1336800E-03,.1497800E-03,.1590100E-03,& + & .1593700E-03,.1415300E-03,.2748700E-04,.1109700E-06,.7785700E-04,& + & .1184200E-03,.1451000E-03,.1626100E-03,.1720400E-03,.1712900E-03,& + & .1504100E-03,.3025000E-04,.1045100E-06,.8376400E-04,.1276200E-03,& + & .1562500E-03,.1754400E-03,.1851600E-03,.1834500E-03,.1601000E-03,& + & .3289100E-04,.9876700E-07,.8883300E-04,.1359500E-03,.1672300E-03,& + & .1879800E-03,.1976600E-03,.1947700E-03,.1697900E-03,.3554700E-04/ + + data absa(451:585, 3) / & + & .1036800E-06,.5371400E-04,.8174800E-04,.1008500E-03,.1134900E-03,& + & .1212600E-03,.1218000E-03,.1095000E-03,.2078700E-04,.9685400E-07,& + & .5917500E-04,.9013100E-04,.1108500E-03,.1242500E-03,.1316600E-03,& + & .1320700E-03,.1173300E-03,.2302800E-04,.9088200E-07,.6459300E-04,& + & .9827500E-04,.1204100E-03,.1349700E-03,.1427300E-03,.1421500E-03,& + & .1247900E-03,.2536200E-04,.8560200E-07,.6954500E-04,.1059200E-03,& + & .1298200E-03,.1458300E-03,.1538800E-03,.1522800E-03,.1329700E-03,& + & .2758500E-04,.8088900E-07,.7373100E-04,.1129000E-03,.1391400E-03,& + & .1563700E-03,.1643100E-03,.1618900E-03,.1411600E-03,.2982800E-04,& + & .8488600E-07,.4441800E-04,.6764100E-04,.8349000E-04,.9390600E-04,& + & .1003400E-03,.1007500E-03,.9061400E-04,.1735000E-04,.7929700E-07,& + & .4898100E-04,.7465600E-04,.9182100E-04,.1029900E-03,.1089100E-03,& + & .1093300E-03,.9722100E-04,.1923700E-04,.7440800E-07,.5355300E-04,& + & .8150300E-04,.9987200E-04,.1119600E-03,.1183200E-03,.1178200E-03,& + & .1034100E-03,.2118900E-04,.7008500E-07,.5769800E-04,.8788700E-04,& + & .1078100E-03,.1210700E-03,.1277500E-03,.1262400E-03,.1103400E-03,& + & .2303800E-04,.6622600E-07,.6117700E-04,.9369400E-04,.1156700E-03,& + & .1299500E-03,.1364500E-03,.1343600E-03,.1172600E-03,.2491300E-04,& + & .6949900E-07,.3671600E-04,.5590200E-04,.6906700E-04,.7763500E-04,& + & .8293400E-04,.8330200E-04,.7490500E-04,.1441900E-04,.6492300E-07,& + & .4051100E-04,.6177900E-04,.7598400E-04,.8523900E-04,.9009000E-04,& + & .9045600E-04,.8026400E-04,.1599600E-04,.6092000E-07,.4435600E-04,& + & .6753300E-04,.8274600E-04,.9281600E-04,.9801700E-04,.9759000E-04,& + & .8562100E-04,.1762300E-04,.5738100E-07,.4782600E-04,.7287400E-04,& + & .8944300E-04,.1004000E-03,.1058800E-03,.1045600E-03,.9142900E-04,& + & .1914400E-04,.5422100E-07,.5075000E-04,.7769800E-04,.9600500E-04,& + & .1078400E-03,.1131800E-03,.1113900E-03,.9725800E-04,.2067100E-04/ + + data absa( 1:180, 4) / & + & .3665400E-05,.1368900E-02,.2110800E-02,.2631400E-02,.2945800E-02,& + & .3083100E-02,.3020700E-02,.2600300E-02,.9368900E-03,.3530400E-05,& + & .1402500E-02,.2171600E-02,.2707800E-02,.3055100E-02,.3194800E-02,& + & .3164900E-02,.2725800E-02,.9798300E-03,.3405900E-05,.1434000E-02,& + & .2221400E-02,.2777300E-02,.3134800E-02,.3304900E-02,.3283500E-02,& + & .2846100E-02,.1025100E-02,.3289500E-05,.1461000E-02,.2259600E-02,& + & .2831400E-02,.3211300E-02,.3413100E-02,.3392100E-02,.2950800E-02,& + & .1073000E-02,.3181400E-05,.1481400E-02,.2290500E-02,.2878900E-02,& + & .3278500E-02,.3499600E-02,.3495200E-02,.3052800E-02,.1120500E-02,& + & .3029300E-05,.1160000E-02,.1794600E-02,.2237000E-02,.2520500E-02,& + & .2643200E-02,.2617200E-02,.2269100E-02,.7846600E-03,.2917300E-05,& + & .1191600E-02,.1846800E-02,.2307200E-02,.2609400E-02,.2747700E-02,& + & .2738800E-02,.2380900E-02,.8235600E-03,.2815200E-05,.1220300E-02,& + & .1893900E-02,.2369100E-02,.2681400E-02,.2850600E-02,.2841400E-02,& + & .2482500E-02,.8616100E-03,.2720700E-05,.1245400E-02,.1929100E-02,& + & .2418000E-02,.2748900E-02,.2938000E-02,.2934500E-02,.2580800E-02,& + & .9032800E-03,.2631600E-05,.1264400E-02,.1958600E-02,.2462400E-02,& + & .2814600E-02,.3012500E-02,.3023700E-02,.2669500E-02,.9467800E-03,& + & .2528800E-05,.9734800E-03,.1507000E-02,.1879500E-02,.2120600E-02,& + & .2236200E-02,.2221000E-02,.1936900E-02,.6430800E-03,.2435300E-05,& + & .1003100E-02,.1555200E-02,.1944100E-02,.2201300E-02,.2325700E-02,& + & .2328600E-02,.2036200E-02,.6752900E-03,.2349500E-05,.1029500E-02,& + & .1598600E-02,.2001900E-02,.2266300E-02,.2416000E-02,.2420400E-02,& + & .2127600E-02,.7099100E-03,.2269900E-05,.1053300E-02,.1633700E-02,& + & .2048900E-02,.2328800E-02,.2491100E-02,.2501600E-02,.2214800E-02,& + & .7463500E-03,.2195100E-05,.1072400E-02,.1662500E-02,.2089100E-02,& + & .2389600E-02,.2558200E-02,.2581200E-02,.2292500E-02,.7843200E-03,& + & .2116900E-05,.8105300E-03,.1256800E-02,.1564700E-02,.1765400E-02,& + & .1866200E-02,.1856800E-02,.1626900E-02,.5260800E-03,.2040700E-05,& + & .8387500E-03,.1301900E-02,.1625200E-02,.1838300E-02,.1944100E-02,& + & .1953800E-02,.1713900E-02,.5532500E-03,.1967400E-05,.8632900E-03,& + & .1341700E-02,.1678800E-02,.1898500E-02,.2024600E-02,.2031500E-02,& + & .1797800E-02,.5825300E-03,.1899400E-05,.8855100E-03,.1375300E-02,& + & .1723800E-02,.1956600E-02,.2092300E-02,.2103500E-02,.1872400E-02,& + & .6143800E-03,.1835800E-05,.9044200E-03,.1404200E-02,.1761900E-02,& + & .2011900E-02,.2154200E-02,.2174900E-02,.1942500E-02,.6476200E-03/ + + data absa(181:315, 4) / & + & .1772500E-05,.6714600E-03,.1039600E-02,.1293500E-02,.1457600E-02,& + & .1543700E-02,.1534100E-02,.1353200E-02,.4298100E-03,.1709500E-05,& + & .6977400E-03,.1082300E-02,.1347700E-02,.1522700E-02,.1611700E-02,& + & .1622200E-02,.1430200E-02,.4528600E-03,.1647800E-05,.7204400E-03,& + & .1119000E-02,.1396700E-02,.1578300E-02,.1681700E-02,.1689700E-02,& + & .1504000E-02,.4778200E-03,.1589600E-05,.7413600E-03,.1151200E-02,& + & .1439400E-02,.1630700E-02,.1743500E-02,.1753600E-02,.1568700E-02,& + & .5046800E-03,.1535300E-05,.7597700E-03,.1179000E-02,.1475500E-02,& + & .1681100E-02,.1799000E-02,.1817500E-02,.1627900E-02,.5335300E-03,& + & .1485600E-05,.5516300E-03,.8518200E-03,.1058300E-02,.1193300E-02,& + & .1263300E-02,.1251900E-02,.1112600E-02,.3496900E-03,.1432300E-05,& + & .5753400E-03,.8921100E-03,.1108400E-02,.1251000E-02,.1324800E-02,& + & .1330200E-02,.1181500E-02,.3689300E-03,.1381800E-05,.5970500E-03,& + & .9255200E-03,.1153000E-02,.1301800E-02,.1386000E-02,.1394200E-02,& + & .1243700E-02,.3899100E-03,.1331700E-05,.6167100E-03,.9556800E-03,& + & .1192200E-02,.1348100E-02,.1442600E-02,.1450800E-02,.1300100E-02,& + & .4124800E-03,.1285100E-05,.6341400E-03,.9822700E-03,.1226500E-02,& + & .1393600E-02,.1491300E-02,.1506400E-02,.1351200E-02,.4369600E-03,& + & .1245300E-05,.4498200E-03,.6928600E-03,.8585700E-03,.9711500E-03,& + & .1026800E-02,.1013200E-02,.9066100E-03,.2833300E-03,.1199700E-05,& + & .4716300E-03,.7298400E-03,.9052500E-03,.1020900E-02,.1083000E-02,& + & .1081500E-02,.9682000E-03,.2999100E-03,.1157100E-05,.4917000E-03,& + & .7606400E-03,.9459700E-03,.1068300E-02,.1133700E-02,.1141800E-02,& + & .1021000E-02,.3173800E-03,.1115700E-05,.5096400E-03,.7885900E-03,& + & .9823600E-03,.1108800E-02,.1185900E-02,.1192000E-02,.1069000E-02,& + & .3360000E-03,.1075700E-05,.5257800E-03,.8133000E-03,.1014100E-02,& + & .1149300E-02,.1228500E-02,.1239900E-02,.1115100E-02,.3563100E-03/ + + data absa(316:450, 4) / & + & .1043600E-05,.3647500E-03,.5594800E-03,.6939900E-03,.7869900E-03,& + & .8273300E-03,.8154600E-03,.7344300E-03,.2287400E-03,.1004300E-05,& + & .3846100E-03,.5936500E-03,.7363100E-03,.8290200E-03,.8799600E-03,& + & .8758900E-03,.7874500E-03,.2428100E-03,.9678500E-06,.4022700E-03,& + & .6219100E-03,.7718300E-03,.8706700E-03,.9233800E-03,.9311600E-03,& + & .8333400E-03,.2573500E-03,.9336700E-06,.4188100E-03,.6469700E-03,& + & .8047400E-03,.9075400E-03,.9680600E-03,.9743400E-03,.8743900E-03,& + & .2728600E-03,.9001700E-06,.4337700E-03,.6702600E-03,.8339800E-03,& + & .9426900E-03,.1008000E-02,.1015400E-02,.9147900E-03,.2894800E-03,& + & .8746900E-06,.2934500E-03,.4485700E-03,.5565300E-03,.6337100E-03,& + & .6625300E-03,.6522900E-03,.5900900E-03,.1847500E-03,.8406200E-06,& + & .3115200E-03,.4797500E-03,.5942200E-03,.6707700E-03,.7116800E-03,& + & .7055000E-03,.6367400E-03,.1966900E-03,.8094700E-06,.3277900E-03,& + & .5058200E-03,.6270700E-03,.7070500E-03,.7493600E-03,.7525200E-03,& + & .6768200E-03,.2089600E-03,.7805200E-06,.3426200E-03,.5282000E-03,& + & .6563100E-03,.7400200E-03,.7873100E-03,.7925700E-03,.7115500E-03,& + & .2219700E-03,.7530000E-06,.3561800E-03,.5494000E-03,.6823600E-03,& + & .7697800E-03,.8227100E-03,.8280600E-03,.7465800E-03,.2358800E-03,& + & .7308000E-06,.2361900E-03,.3600200E-03,.4476900E-03,.5100100E-03,& + & .5329400E-03,.5231900E-03,.4749200E-03,.1500500E-03,.7014200E-06,& + & .2522500E-03,.3874200E-03,.4803900E-03,.5428500E-03,.5740700E-03,& + & .5676500E-03,.5144400E-03,.1600000E-03,.6748400E-06,.2668700E-03,& + & .4111900E-03,.5092400E-03,.5737200E-03,.6091200E-03,.6081300E-03,& + & .5494500E-03,.1703600E-03,.6503200E-06,.2800200E-03,.4310400E-03,& + & .5351300E-03,.6029400E-03,.6399800E-03,.6448500E-03,.5788800E-03,& + & .1812000E-03,.6275200E-06,.2918200E-03,.4495000E-03,.5583600E-03,& + & .6284900E-03,.6714800E-03,.6757000E-03,.6091800E-03,.1927100E-03/ + + data absa(451:585, 4) / & + & .5984600E-06,.1960300E-03,.2990200E-03,.3715900E-03,.4236700E-03,& + & .4424100E-03,.4355000E-03,.3961800E-03,.1249800E-03,.5744700E-06,& + & .2095300E-03,.3218700E-03,.3988200E-03,.4502100E-03,.4771700E-03,& + & .4724000E-03,.4289400E-03,.1336200E-03,.5526500E-06,.2218500E-03,& + & .3413300E-03,.4228300E-03,.4761600E-03,.5048100E-03,.5055300E-03,& + & .4565400E-03,.1424600E-03,.5325900E-06,.2330100E-03,.3581600E-03,& + & .4444800E-03,.5004800E-03,.5314700E-03,.5357400E-03,.4816900E-03,& + & .1516800E-03,.5137900E-06,.2430200E-03,.3738300E-03,.4635200E-03,& + & .5220300E-03,.5578300E-03,.5617500E-03,.5073700E-03,.1615300E-03,& + & .4900600E-06,.1625900E-03,.2480200E-03,.3080400E-03,.3511100E-03,& + & .3667200E-03,.3616600E-03,.3296800E-03,.1040100E-03,.4703300E-06,& + & .1737900E-03,.2669700E-03,.3306900E-03,.3729200E-03,.3958700E-03,& + & .3923900E-03,.3567200E-03,.1113800E-03,.4524700E-06,.1841700E-03,& + & .2829500E-03,.3504500E-03,.3946500E-03,.4182500E-03,.4198400E-03,& + & .3786700E-03,.1188200E-03,.4360500E-06,.1935100E-03,.2971600E-03,& + & .3685000E-03,.4148900E-03,.4407400E-03,.4446000E-03,.4003100E-03,& + & .1266700E-03,.4206600E-06,.2020600E-03,.3103800E-03,.3846400E-03,& + & .4333700E-03,.4629700E-03,.4666700E-03,.4220200E-03,.1349800E-03,& + & .4012200E-06,.1346500E-03,.2054100E-03,.2548800E-03,.2900600E-03,& + & .3035800E-03,.2998400E-03,.2737500E-03,.8640600E-04,.3850200E-06,& + & .1439800E-03,.2208600E-03,.2737600E-03,.3083200E-03,.3279400E-03,& + & .3251700E-03,.2956200E-03,.9261400E-04,.3704500E-06,.1526600E-03,& + & .2341600E-03,.2901300E-03,.3267500E-03,.3462200E-03,.3481600E-03,& + & .3140100E-03,.9888000E-04,.3570200E-06,.1605000E-03,.2460800E-03,& + & .3052100E-03,.3433600E-03,.3652200E-03,.3685700E-03,.3324600E-03,& + & .1055900E-03,.3444000E-06,.1677100E-03,.2574200E-03,.3190400E-03,& + & .3594300E-03,.3840500E-03,.3871500E-03,.3508700E-03,.1126200E-03/ + + data absa( 1:180, 5) / & + & .1558300E-03,.3754600E-02,.5353600E-02,.6416100E-02,.7122300E-02,& + & .7498200E-02,.7359600E-02,.6513500E-02,.3517500E-02,.1614800E-03,& + & .3856900E-02,.5525600E-02,.6646100E-02,.7375700E-02,.7753000E-02,& + & .7566500E-02,.6649600E-02,.3684000E-02,.1648400E-03,.3935300E-02,& + & .5674500E-02,.6836400E-02,.7616600E-02,.7971100E-02,.7771700E-02,& + & .6784600E-02,.3848500E-02,.1662100E-03,.3994600E-02,.5794700E-02,& + & .7007100E-02,.7819300E-02,.8158100E-02,.7959200E-02,.6913200E-02,& + & .3976900E-02,.1651800E-03,.4038600E-02,.5892500E-02,.7153000E-02,& + & .7994600E-02,.8325800E-02,.8110700E-02,.7022600E-02,.4113400E-02,& + & .1248200E-03,.3220400E-02,.4610200E-02,.5547500E-02,.6173000E-02,& + & .6500000E-02,.6394200E-02,.5639400E-02,.3000200E-02,.1302700E-03,& + & .3309900E-02,.4761700E-02,.5749700E-02,.6403100E-02,.6718400E-02,& + & .6582900E-02,.5772100E-02,.3144200E-02,.1337000E-03,.3380800E-02,& + & .4884500E-02,.5923500E-02,.6607400E-02,.6904800E-02,.6766000E-02,& + & .5901800E-02,.3278800E-02,.1354900E-03,.3434000E-02,.4988500E-02,& + & .6074500E-02,.6787700E-02,.7078000E-02,.6920200E-02,.6013100E-02,& + & .3394600E-02,.1354300E-03,.3477800E-02,.5074500E-02,.6198100E-02,& + & .6928200E-02,.7222900E-02,.7052100E-02,.6121800E-02,.3509700E-02,& + & .9843700E-04,.2720900E-02,.3903500E-02,.4718500E-02,.5270600E-02,& + & .5557900E-02,.5484600E-02,.4846900E-02,.2507700E-02,.1039600E-03,& + & .2803100E-02,.4038400E-02,.4899300E-02,.5475300E-02,.5757500E-02,& + & .5652500E-02,.4968400E-02,.2636600E-02,.1077000E-03,.2870200E-02,& + & .4151300E-02,.5050400E-02,.5664000E-02,.5924500E-02,.5812500E-02,& + & .5092200E-02,.2747800E-02,.1099600E-03,.2923200E-02,.4245100E-02,& + & .5183800E-02,.5825700E-02,.6079300E-02,.5949800E-02,.5194900E-02,& + & .2849000E-02,.1108800E-03,.2964500E-02,.4325100E-02,.5299200E-02,& + & .5946800E-02,.6209600E-02,.6064800E-02,.5290400E-02,.2949500E-02,& + & .7658700E-04,.2279200E-02,.3273100E-02,.3972400E-02,.4456100E-02,& + & .4710900E-02,.4670600E-02,.4144400E-02,.2081000E-02,.8222500E-04,& + & .2354800E-02,.3394300E-02,.4132500E-02,.4641500E-02,.4893900E-02,& + & .4820000E-02,.4259100E-02,.2192500E-02,.8620300E-04,.2418000E-02,& + & .3499100E-02,.4268400E-02,.4807400E-02,.5041600E-02,.4965100E-02,& + & .4364300E-02,.2293800E-02,.8876600E-04,.2469400E-02,.3587400E-02,& + & .4387500E-02,.4946900E-02,.5181000E-02,.5085000E-02,.4460600E-02,& + & .2379100E-02,.9021800E-04,.2511000E-02,.3661300E-02,.4493700E-02,& + & .5054800E-02,.5298200E-02,.5188300E-02,.4549800E-02,.2465800E-02/ + + data absa(181:315, 5) / & + & .5908000E-04,.1897200E-02,.2729400E-02,.3319500E-02,.3739500E-02,& + & .3968300E-02,.3952300E-02,.3516100E-02,.1719500E-02,.6450800E-04,& + & .1967300E-02,.2837600E-02,.3463200E-02,.3903300E-02,.4134300E-02,& + & .4082600E-02,.3619500E-02,.1817300E-02,.6853800E-04,.2026400E-02,& + & .2934200E-02,.3585600E-02,.4048800E-02,.4266400E-02,.4214100E-02,& + & .3714400E-02,.1908100E-02,.7132800E-04,.2075000E-02,.3016500E-02,& + & .3693300E-02,.4171900E-02,.4388000E-02,.4322100E-02,.3800600E-02,& + & .1981800E-02,.7307300E-04,.2115500E-02,.3086100E-02,.3789200E-02,& + & .4269000E-02,.4490100E-02,.4416100E-02,.3886400E-02,.2058300E-02,& + & .4506900E-04,.1567300E-02,.2259600E-02,.2756600E-02,.3111700E-02,& + & .3316200E-02,.3313500E-02,.2957400E-02,.1408900E-02,.4995900E-04,& + & .1634200E-02,.2357700E-02,.2882800E-02,.3257200E-02,.3462600E-02,& + & .3430200E-02,.3047600E-02,.1495500E-02,.5401300E-04,.1689100E-02,& + & .2445700E-02,.2992600E-02,.3386500E-02,.3580900E-02,.3542700E-02,& + & .3135800E-02,.1576300E-02,.5691000E-04,.1735600E-02,.2522000E-02,& + & .3090300E-02,.3496800E-02,.3685300E-02,.3644300E-02,.3214000E-02,& + & .1642800E-02,.5885200E-04,.1774300E-02,.2586800E-02,.3177100E-02,& + & .3585700E-02,.3778200E-02,.3728400E-02,.3290500E-02,.1707900E-02,& + & .3413100E-04,.1287300E-02,.1861900E-02,.2274500E-02,.2568800E-02,& + & .2749400E-02,.2757400E-02,.2465800E-02,.1144400E-02,.3837900E-04,& + & .1350300E-02,.1949000E-02,.2386900E-02,.2698500E-02,.2876100E-02,& + & .2860700E-02,.2544300E-02,.1224200E-02,.4214600E-04,.1401800E-02,& + & .2028700E-02,.2484300E-02,.2811900E-02,.2984800E-02,.2956900E-02,& + & .2625800E-02,.1295600E-02,.4511600E-04,.1445400E-02,.2098900E-02,& + & .2571800E-02,.2911500E-02,.3074000E-02,.3048200E-02,.2696700E-02,& + & .1353700E-02,.4717800E-04,.1481800E-02,.2159100E-02,.2650900E-02,& + & .2994500E-02,.3159000E-02,.3123500E-02,.2764100E-02,.1410000E-02/ + + data absa(316:450, 5) / & + & .2565600E-04,.1052500E-02,.1526600E-02,.1864800E-02,.2106000E-02,& + & .2266000E-02,.2280700E-02,.2041500E-02,.9248200E-03,.2931300E-04,& + & .1109600E-02,.1602700E-02,.1962800E-02,.2222400E-02,.2373000E-02,& + & .2368300E-02,.2111100E-02,.9936600E-03,.3264300E-04,.1157900E-02,& + & .1673200E-02,.2050300E-02,.2323100E-02,.2472100E-02,.2451200E-02,& + & .2184200E-02,.1057000E-02,.3550900E-04,.1198500E-02,.1737900E-02,& + & .2128400E-02,.2411000E-02,.2551900E-02,.2533900E-02,.2249600E-02,& + & .1111600E-02,.3761600E-04,.1232700E-02,.1793300E-02,.2199600E-02,& + & .2488000E-02,.2625800E-02,.2602900E-02,.2308800E-02,.1159500E-02,& + & .1916600E-04,.8555900E-03,.1244600E-02,.1521300E-02,.1716000E-02,& + & .1852700E-02,.1872300E-02,.1679400E-02,.7431600E-03,.2225100E-04,& + & .9070100E-03,.1310700E-02,.1606100E-02,.1817700E-02,.1945200E-02,& + & .1949600E-02,.1742000E-02,.8016800E-03,.2512300E-04,.9510600E-03,& + & .1372400E-02,.1682600E-02,.1906400E-02,.2035200E-02,.2024100E-02,& + & .1806400E-02,.8565900E-03,.2771300E-04,.9890300E-03,.1430100E-02,& + & .1752300E-02,.1986200E-02,.2107900E-02,.2094400E-02,.1865600E-02,& + & .9065500E-03,.2982100E-04,.1020700E-02,.1481300E-02,.1816300E-02,& + & .2057000E-02,.2173700E-02,.2157400E-02,.1915300E-02,.9488200E-03,& + & .1445500E-04,.6950800E-03,.1014300E-02,.1238200E-02,.1397700E-02,& + & .1510100E-02,.1533900E-02,.1379400E-02,.6006400E-03,.1697500E-04,& + & .7405500E-03,.1071500E-02,.1311700E-02,.1485100E-02,.1593800E-02,& + & .1602600E-02,.1435400E-02,.6503400E-03,.1942100E-04,.7799600E-03,& + & .1124300E-02,.1379100E-02,.1563600E-02,.1670700E-02,.1667800E-02,& + & .1490800E-02,.6987500E-03,.2165900E-04,.8136900E-03,.1174600E-02,& + & .1440800E-02,.1634000E-02,.1737600E-02,.1726700E-02,.1541800E-02,& + & .7433600E-03,.2361600E-04,.8431600E-03,.1221500E-02,.1497200E-02,& + & .1697100E-02,.1794500E-02,.1783400E-02,.1584400E-02,.7804500E-03/ + + data absa(451:585, 5) / & + & .1181200E-04,.5806700E-03,.8465800E-03,.1034900E-02,.1168100E-02,& + & .1262200E-02,.1280600E-02,.1151800E-02,.5019700E-03,.1387000E-04,& + & .6187000E-03,.8936400E-03,.1095700E-02,.1241100E-02,.1330700E-02,& + & .1336600E-02,.1199000E-02,.5441900E-03,.1587200E-04,.6513100E-03,& + & .9384300E-03,.1152000E-02,.1306800E-02,.1396600E-02,.1392700E-02,& + & .1245900E-02,.5841200E-03,.1770600E-04,.6795700E-03,.9812800E-03,& + & .1203700E-02,.1365300E-02,.1451000E-02,.1442300E-02,.1287300E-02,& + & .6208600E-03,.1930700E-04,.7047700E-03,.1020800E-02,.1252200E-02,& + & .1418700E-02,.1500000E-02,.1488200E-02,.1322300E-02,.6527300E-03,& + & .9663300E-05,.4838400E-03,.7046400E-03,.8621400E-03,.9732500E-03,& + & .1052500E-02,.1066100E-02,.9581800E-03,.4183800E-03,.1134600E-04,& + & .5154400E-03,.7437500E-03,.9125500E-03,.1034600E-02,.1108800E-02,& + & .1112400E-02,.9978700E-03,.4543600E-03,.1298300E-04,.5425800E-03,& + & .7819100E-03,.9599400E-03,.1089300E-02,.1163600E-02,.1159500E-02,& + & .1037900E-02,.4876700E-03,.1448300E-04,.5666200E-03,.8179500E-03,& + & .1003600E-02,.1138500E-02,.1209100E-02,.1201200E-02,.1070700E-02,& + & .5181000E-03,.1579000E-04,.5880500E-03,.8516500E-03,.1044700E-02,& + & .1183000E-02,.1250000E-02,.1238900E-02,.1101200E-02,.5450800E-03,& + & .7905700E-05,.4021500E-03,.5851600E-03,.7166600E-03,.8096900E-03,& + & .8751800E-03,.8858100E-03,.7956900E-03,.3482500E-03,.9280800E-05,& + & .4285300E-03,.6181800E-03,.7584700E-03,.8608200E-03,.9216000E-03,& + & .9243600E-03,.8289400E-03,.3787100E-03,.1062100E-04,.4513400E-03,& + & .6502800E-03,.7981500E-03,.9062200E-03,.9675200E-03,.9629100E-03,& + & .8617700E-03,.4064200E-03,.1184900E-04,.4716100E-03,.6809000E-03,& + & .8353000E-03,.9477000E-03,.1005400E-02,.9981500E-03,.8890800E-03,& + & .4314900E-03,.1289700E-04,.4900000E-03,.7094400E-03,.8698200E-03,& + & .9843000E-03,.1039800E-02,.1029700E-02,.9148300E-03,.4545900E-03/ + + data absa( 1:180, 6) / & + & .2357500E-02,.9645700E-02,.1312800E-01,.1536100E-01,.1666200E-01,& + & .1699900E-01,.1630300E-01,.1436800E-01,.1018500E-01,.2450800E-02,& + & .9976800E-02,.1356200E-01,.1578600E-01,.1704600E-01,.1731600E-01,& + & .1653900E-01,.1462700E-01,.1044700E-01,.2517600E-02,.1026200E-01,& + & .1394700E-01,.1618200E-01,.1739000E-01,.1758800E-01,.1675200E-01,& + & .1485700E-01,.1069900E-01,.2562700E-02,.1051000E-01,.1427100E-01,& + & .1651700E-01,.1767800E-01,.1781500E-01,.1694100E-01,.1507300E-01,& + & .1097000E-01,.2590400E-02,.1071200E-01,.1452800E-01,.1678800E-01,& + & .1791200E-01,.1801300E-01,.1712600E-01,.1528200E-01,.1121500E-01,& + & .1942200E-02,.8517900E-02,.1160300E-01,.1356100E-01,.1469400E-01,& + & .1495200E-01,.1427400E-01,.1261600E-01,.8691000E-02,.2023100E-02,& + & .8820800E-02,.1199200E-01,.1394200E-01,.1504300E-01,.1524100E-01,& + & .1450300E-01,.1284900E-01,.8920300E-02,.2082400E-02,.9089200E-02,& + & .1233300E-01,.1428300E-01,.1534300E-01,.1549300E-01,.1470400E-01,& + & .1306500E-01,.9141200E-02,.2123500E-02,.9319300E-02,.1261300E-01,& + & .1457300E-01,.1558600E-01,.1569600E-01,.1490000E-01,.1326900E-01,& + & .9373100E-02,.2150100E-02,.9506400E-02,.1284400E-01,.1480200E-01,& + & .1578900E-01,.1587200E-01,.1507900E-01,.1345900E-01,.9592200E-02,& + & .1571000E-02,.7373900E-02,.1008400E-01,.1179500E-01,.1279100E-01,& + & .1300200E-01,.1240800E-01,.1094800E-01,.7325600E-02,.1644500E-02,& + & .7660300E-02,.1044100E-01,.1213600E-01,.1309800E-01,.1327200E-01,& + & .1262900E-01,.1116900E-01,.7527700E-02,.1701600E-02,.7912000E-02,& + & .1073800E-01,.1244400E-01,.1336500E-01,.1350200E-01,.1282700E-01,& + & .1136500E-01,.7727500E-02,.1741900E-02,.8120400E-02,.1099200E-01,& + & .1270400E-01,.1357900E-01,.1368700E-01,.1302200E-01,.1156500E-01,& + & .7932700E-02,.1769300E-02,.8289600E-02,.1120100E-01,.1290300E-01,& + & .1376100E-01,.1385400E-01,.1319300E-01,.1176000E-01,.8132400E-02,& + & .1256800E-02,.6292500E-02,.8657000E-02,.1015600E-01,.1102000E-01,& + & .1122000E-01,.1071000E-01,.9432900E-02,.6181200E-02,.1324200E-02,& + & .6553200E-02,.8975600E-02,.1046000E-01,.1129200E-01,.1146300E-01,& + & .1092400E-01,.9644900E-02,.6362000E-02,.1378200E-02,.6780700E-02,& + & .9244700E-02,.1073900E-01,.1153100E-01,.1167600E-01,.1111500E-01,& + & .9838400E-02,.6541700E-02,.1418500E-02,.6972800E-02,.9472400E-02,& + & .1096700E-01,.1173200E-01,.1185300E-01,.1129900E-01,.1002900E-01,& + & .6731400E-02,.1446600E-02,.7129400E-02,.9655100E-02,.1115000E-01,& + & .1189700E-01,.1200300E-01,.1145700E-01,.1021200E-01,.6913400E-02/ + + data absa(181:315, 6) / & + & .9981500E-03,.5318400E-02,.7366800E-02,.8666100E-02,.9418900E-02,& + & .9608800E-02,.9186000E-02,.8085400E-02,.5214700E-02,.1059400E-02,& + & .5550200E-02,.7648000E-02,.8938200E-02,.9667500E-02,.9828100E-02,& + & .9390800E-02,.8290400E-02,.5380500E-02,.1109300E-02,.5753400E-02,& + & .7882000E-02,.9187300E-02,.9886000E-02,.1002700E-01,.9573900E-02,& + & .8477400E-02,.5539800E-02,.1148700E-02,.5926400E-02,.8074600E-02,& + & .9395200E-02,.1007000E-01,.1019600E-01,.9746000E-02,.8658600E-02,& + & .5711800E-02,.1177000E-02,.6071500E-02,.8232200E-02,.9559000E-02,& + & .1022500E-01,.1033700E-01,.9889100E-02,.8828200E-02,.5875600E-02,& + & .7848400E-03,.4455700E-02,.6208800E-02,.7323800E-02,.7975800E-02,& + & .8156500E-02,.7823400E-02,.6894900E-02,.4372100E-02,.8410400E-03,& + & .4658400E-02,.6454800E-02,.7572000E-02,.8204900E-02,.8360300E-02,& + & .8013900E-02,.7091200E-02,.4520800E-02,.8870300E-03,.4838600E-02,& + & .6658500E-02,.7793900E-02,.8407700E-02,.8549400E-02,.8187800E-02,& + & .7267300E-02,.4666400E-02,.9242900E-03,.4993900E-02,.6825500E-02,& + & .7979300E-02,.8581100E-02,.8712300E-02,.8342300E-02,.7432400E-02,& + & .4819300E-02,.9528700E-03,.5126900E-02,.6966400E-02,.8121600E-02,& + & .8725600E-02,.8840400E-02,.8479300E-02,.7588500E-02,.4968400E-02,& + & .6117600E-03,.3710500E-02,.5192100E-02,.6149500E-02,.6708600E-02,& + & .6873700E-02,.6619600E-02,.5849900E-02,.3639800E-02,.6635500E-03,& + & .3884500E-02,.5409200E-02,.6368400E-02,.6919100E-02,.7063800E-02,& + & .6796700E-02,.6032900E-02,.3772500E-02,.7058400E-03,.4042900E-02,& + & .5589100E-02,.6566500E-02,.7106100E-02,.7239200E-02,.6956600E-02,& + & .6195800E-02,.3904000E-02,.7401600E-03,.4180400E-02,.5736200E-02,& + & .6730600E-02,.7265600E-02,.7393900E-02,.7100200E-02,.6345800E-02,& + & .4042200E-02,.7679300E-03,.4301300E-02,.5863400E-02,.6860500E-02,& + & .7391700E-02,.7516000E-02,.7229200E-02,.6486700E-02,.4175300E-02/ + + data absa(316:450, 6) / & + & .4738300E-03,.3071900E-02,.4315700E-02,.5129900E-02,.5611300E-02,& + & .5760400E-02,.5558400E-02,.4926300E-02,.3009900E-02,.5203000E-03,& + & .3222400E-02,.4508800E-02,.5325600E-02,.5804900E-02,.5936900E-02,& + & .5724900E-02,.5095000E-02,.3133500E-02,.5589700E-03,.3360100E-02,& + & .4669000E-02,.5500800E-02,.5973300E-02,.6098200E-02,.5870300E-02,& + & .5241600E-02,.3250500E-02,.5905100E-03,.3482300E-02,.4800300E-02,& + & .5649200E-02,.6114700E-02,.6240700E-02,.6001100E-02,.5377600E-02,& + & .3369100E-02,.6163800E-03,.3590800E-02,.4915100E-02,.5768200E-02,& + & .6226900E-02,.6350500E-02,.6122600E-02,.5506100E-02,.3489300E-02,& + & .3645200E-03,.2530100E-02,.3565500E-02,.4255800E-02,.4666800E-02,& + & .4799500E-02,.4639100E-02,.4117600E-02,.2472300E-02,.4052100E-03,& + & .2660900E-02,.3736800E-02,.4431300E-02,.4842200E-02,.4960500E-02,& + & .4787600E-02,.4268200E-02,.2585400E-02,.4404200E-03,.2781100E-02,& + & .3882200E-02,.4587100E-02,.4995100E-02,.5104800E-02,.4918900E-02,& + & .4398800E-02,.2692200E-02,.4693400E-03,.2889000E-02,.4001500E-02,& + & .4720400E-02,.5119500E-02,.5232900E-02,.5039800E-02,.4521100E-02,& + & .2794700E-02,.4929600E-03,.2986300E-02,.4105200E-02,.4829600E-02,& + & .5221200E-02,.5332000E-02,.5151600E-02,.4641000E-02,.2901400E-02,& + & .2814100E-03,.2083900E-02,.2943400E-02,.3525000E-02,.3870500E-02,& + & .3990700E-02,.3857400E-02,.3428000E-02,.2027600E-02,.3164200E-03,& + & .2196200E-02,.3094700E-02,.3679800E-02,.4027900E-02,.4131700E-02,& + & .3990500E-02,.3559100E-02,.2130400E-02,.3474300E-03,.2300200E-02,& + & .3225100E-02,.3816700E-02,.4163200E-02,.4258800E-02,.4107700E-02,& + & .3673700E-02,.2224600E-02,.3733700E-03,.2395800E-02,.3332600E-02,& + & .3935100E-02,.4272700E-02,.4369900E-02,.4216700E-02,.3785000E-02,& + & .2317100E-02,.3946400E-03,.2481800E-02,.3424500E-02,.4034100E-02,& + & .4363500E-02,.4459200E-02,.4313300E-02,.3893100E-02,.2412300E-02/ + + data absa(451:585, 6) / & + & .2304600E-03,.1756100E-02,.2482100E-02,.2969700E-02,.3260300E-02,& + & .3359000E-02,.3246500E-02,.2891100E-02,.1700000E-02,.2590000E-03,& + & .1849900E-02,.2607900E-02,.3098300E-02,.3391400E-02,.3479000E-02,& + & .3359800E-02,.3000000E-02,.1787900E-02,.2843100E-03,.1937100E-02,& + & .2715400E-02,.3212300E-02,.3500900E-02,.3581000E-02,.3458200E-02,& + & .3098900E-02,.1870900E-02,.3055400E-03,.2017500E-02,.2804700E-02,& + & .3309400E-02,.3589700E-02,.3670800E-02,.3550000E-02,.3196400E-02,& + & .1952400E-02,.3229000E-03,.2090600E-02,.2882700E-02,.3390700E-02,& + & .3663800E-02,.3744800E-02,.3632200E-02,.3292100E-02,.2034200E-02,& + & .1887300E-03,.1475300E-02,.2085900E-02,.2493200E-02,.2736200E-02,& + & .2816300E-02,.2723100E-02,.2428700E-02,.1422600E-02,.2120600E-03,& + & .1554200E-02,.2190500E-02,.2599700E-02,.2843600E-02,.2914600E-02,& + & .2818200E-02,.2519600E-02,.1496400E-02,.2327100E-03,.1628200E-02,& + & .2278900E-02,.2693700E-02,.2932000E-02,.2999500E-02,.2900400E-02,& + & .2606300E-02,.1568400E-02,.2500500E-03,.1695900E-02,.2353900E-02,& + & .2773900E-02,.3005200E-02,.3073800E-02,.2978100E-02,.2692400E-02,& + & .1638800E-02,.2642400E-03,.1757900E-02,.2419800E-02,.2841800E-02,& + & .3068800E-02,.3137000E-02,.3047800E-02,.2773400E-02,.1709000E-02,& + & .1545100E-03,.1236200E-02,.1747100E-02,.2085600E-02,.2287000E-02,& + & .2353000E-02,.2275800E-02,.2031800E-02,.1186800E-02,.1735700E-03,& + & .1302700E-02,.1833700E-02,.2173600E-02,.2375200E-02,.2433900E-02,& + & .2354900E-02,.2110400E-02,.1249200E-02,.1904500E-03,.1365100E-02,& + & .1907100E-02,.2252000E-02,.2447900E-02,.2505200E-02,.2425500E-02,& + & .2186200E-02,.1311400E-02,.2045900E-03,.1422500E-02,.1970200E-02,& + & .2319500E-02,.2510900E-02,.2568000E-02,.2490600E-02,.2259200E-02,& + & .1371700E-02,.2162100E-03,.1475100E-02,.2026700E-02,.2377500E-02,& + & .2565400E-02,.2622100E-02,.2551300E-02,.2328300E-02,.1432100E-02/ + + data absa( 1:180, 7) / & + & .1455100E-01,.2628200E-01,.3205300E-01,.3518900E-01,.3660000E-01,& + & .3664600E-01,.3555200E-01,.3321500E-01,.2730900E-01,.1536000E-01,& + & .2684700E-01,.3241100E-01,.3542600E-01,.3680300E-01,.3699400E-01,& + & .3603700E-01,.3367400E-01,.2788100E-01,.1605200E-01,.2735800E-01,& + & .3271100E-01,.3560200E-01,.3700200E-01,.3732200E-01,.3649500E-01,& + & .3409200E-01,.2836500E-01,.1663400E-01,.2776500E-01,.3297500E-01,& + & .3575700E-01,.3719800E-01,.3762900E-01,.3687100E-01,.3448900E-01,& + & .2881700E-01,.1709200E-01,.2808800E-01,.3317300E-01,.3589900E-01,& + & .3736900E-01,.3789400E-01,.3720600E-01,.3485600E-01,.2923600E-01,& + & .1267500E-01,.2375700E-01,.2882700E-01,.3147500E-01,.3264700E-01,& + & .3277900E-01,.3187400E-01,.2965900E-01,.2373500E-01,.1336300E-01,& + & .2426100E-01,.2916500E-01,.3173400E-01,.3290500E-01,.3313700E-01,& + & .3235700E-01,.3011400E-01,.2424100E-01,.1395200E-01,.2467300E-01,& + & .2945800E-01,.3194000E-01,.3316700E-01,.3348600E-01,.3279400E-01,& + & .3054000E-01,.2470400E-01,.1444000E-01,.2501000E-01,.2969200E-01,& + & .3213100E-01,.3340200E-01,.3381600E-01,.3318500E-01,.3094400E-01,& + & .2512300E-01,.1481000E-01,.2524600E-01,.2986500E-01,.3232300E-01,& + & .3362400E-01,.3412500E-01,.3353000E-01,.3129900E-01,.2550100E-01,& + & .1076400E-01,.2118000E-01,.2564500E-01,.2793400E-01,.2889100E-01,& + & .2897800E-01,.2821500E-01,.2625000E-01,.2034000E-01,.1137100E-01,& + & .2161100E-01,.2597600E-01,.2822100E-01,.2920400E-01,.2934700E-01,& + & .2868900E-01,.2668700E-01,.2080300E-01,.1188200E-01,.2197700E-01,& + & .2625800E-01,.2846700E-01,.2949800E-01,.2973000E-01,.2911300E-01,& + & .2711500E-01,.2124100E-01,.1230200E-01,.2227300E-01,.2647700E-01,& + & .2869600E-01,.2976600E-01,.3009900E-01,.2950700E-01,.2750300E-01,& + & .2162000E-01,.1262400E-01,.2248100E-01,.2663100E-01,.2890000E-01,& + & .3003200E-01,.3042500E-01,.2985900E-01,.2784200E-01,.2196600E-01,& + & .8986000E-02,.1865900E-01,.2260500E-01,.2458000E-01,.2538300E-01,& + & .2543500E-01,.2476100E-01,.2303700E-01,.1741400E-01,.9520700E-02,& + & .1904800E-01,.2292400E-01,.2488800E-01,.2573900E-01,.2582300E-01,& + & .2520000E-01,.2345000E-01,.1784700E-01,.9972300E-02,.1938000E-01,& + & .2318200E-01,.2515500E-01,.2606100E-01,.2620900E-01,.2561100E-01,& + & .2386200E-01,.1825100E-01,.1035400E-01,.1964400E-01,.2339700E-01,& + & .2540100E-01,.2634500E-01,.2658000E-01,.2600000E-01,.2423300E-01,& + & .1860000E-01,.1063700E-01,.1982200E-01,.2355600E-01,.2560500E-01,& + & .2661900E-01,.2691300E-01,.2635900E-01,.2456200E-01,.1892500E-01/ + + data absa(181:315, 7) / & + & .7410400E-02,.1626400E-01,.1971700E-01,.2145200E-01,.2217200E-01,& + & .2220700E-01,.2159800E-01,.2007500E-01,.1488000E-01,.7877800E-02,& + & .1662400E-01,.2002200E-01,.2176500E-01,.2253100E-01,.2259600E-01,& + & .2199900E-01,.2045800E-01,.1527900E-01,.8269400E-02,.1692800E-01,& + & .2027700E-01,.2203600E-01,.2285900E-01,.2297800E-01,.2238400E-01,& + & .2083400E-01,.1565000E-01,.8591900E-02,.1716800E-01,.2049800E-01,& + & .2227400E-01,.2314300E-01,.2332600E-01,.2275400E-01,.2118900E-01,& + & .1598000E-01,.8833700E-02,.1733200E-01,.2066400E-01,.2247700E-01,& + & .2340700E-01,.2364800E-01,.2311100E-01,.2150900E-01,.1628300E-01,& + & .6030500E-02,.1400800E-01,.1702800E-01,.1857400E-01,.1923600E-01,& + & .1926900E-01,.1872000E-01,.1734700E-01,.1265600E-01,.6435600E-02,& + & .1433900E-01,.1731800E-01,.1887200E-01,.1958000E-01,.1964500E-01,& + & .1909500E-01,.1770500E-01,.1302500E-01,.6770800E-02,.1462600E-01,& + & .1757500E-01,.1913500E-01,.1988300E-01,.2000400E-01,.1945400E-01,& + & .1805500E-01,.1336600E-01,.7044900E-02,.1485300E-01,.1779500E-01,& + & .1936300E-01,.2015600E-01,.2032400E-01,.1981100E-01,.1839200E-01,& + & .1367900E-01,.7258600E-02,.1501400E-01,.1795400E-01,.1956900E-01,& + & .2040100E-01,.2062200E-01,.2015500E-01,.1870600E-01,.1396300E-01,& + & .4861500E-02,.1193600E-01,.1457400E-01,.1596300E-01,.1657800E-01,& + & .1661500E-01,.1612500E-01,.1490400E-01,.1071800E-01,.5209300E-02,& + & .1224700E-01,.1484500E-01,.1623900E-01,.1689000E-01,.1696500E-01,& + & .1647700E-01,.1523800E-01,.1105000E-01,.5498100E-02,.1252000E-01,& + & .1508900E-01,.1648500E-01,.1716300E-01,.1729600E-01,.1682300E-01,& + & .1556100E-01,.1136700E-01,.5734100E-02,.1273200E-01,.1530200E-01,& + & .1670900E-01,.1741200E-01,.1758700E-01,.1715600E-01,.1588200E-01,& + & .1165700E-01,.5924500E-02,.1287900E-01,.1546000E-01,.1690000E-01,& + & .1764600E-01,.1786200E-01,.1747500E-01,.1618900E-01,.1192400E-01/ + + data absa(316:450, 7) / & + & .3890300E-02,.1008600E-01,.1239300E-01,.1361700E-01,.1417900E-01,& + & .1423000E-01,.1381000E-01,.1274100E-01,.9040200E-02,.4188300E-02,& + & .1037900E-01,.1264200E-01,.1386600E-01,.1445400E-01,.1454900E-01,& + & .1414000E-01,.1305000E-01,.9340700E-02,.4437400E-02,.1062800E-01,& + & .1286600E-01,.1409300E-01,.1470200E-01,.1484700E-01,.1446600E-01,& + & .1335400E-01,.9628900E-02,.4641700E-02,.1082300E-01,.1306700E-01,& + & .1429700E-01,.1493600E-01,.1511300E-01,.1477700E-01,.1365900E-01,& + & .9894600E-02,.4810600E-02,.1095800E-01,.1321200E-01,.1447700E-01,& + & .1515500E-01,.1536900E-01,.1506500E-01,.1395400E-01,.1013700E-01,& + & .3090600E-02,.8471600E-02,.1047500E-01,.1153300E-01,.1203700E-01,& + & .1210200E-01,.1175700E-01,.1084000E-01,.7579000E-02,.3345600E-02,& + & .8738000E-02,.1069800E-01,.1175900E-01,.1228100E-01,.1238400E-01,& + & .1206300E-01,.1112400E-01,.7852400E-02,.3562400E-02,.8963600E-02,& + & .1090800E-01,.1196400E-01,.1250300E-01,.1265100E-01,.1236600E-01,& + & .1141300E-01,.8111600E-02,.3740900E-02,.9139400E-02,.1108500E-01,& + & .1215600E-01,.1271700E-01,.1289500E-01,.1264600E-01,.1170300E-01,& + & .8354300E-02,.3889900E-02,.9266300E-02,.1121000E-01,.1232300E-01,& + & .1292300E-01,.1313500E-01,.1290900E-01,.1197900E-01,.8574800E-02,& + & .2458800E-02,.7099700E-02,.8815600E-02,.9728000E-02,.1017500E-01,& + & .1024600E-01,.9971200E-02,.9195100E-02,.6332400E-02,.2674300E-02,& + & .7339300E-02,.9018300E-02,.9928900E-02,.1038700E-01,.1049600E-01,& + & .1024900E-01,.9456600E-02,.6577000E-02,.2861000E-02,.7535200E-02,& + & .9202800E-02,.1011700E-01,.1058600E-01,.1073000E-01,.1052400E-01,& + & .9730700E-02,.6807700E-02,.3014700E-02,.7689900E-02,.9355000E-02,& + & .1029100E-01,.1078100E-01,.1095400E-01,.1077800E-01,.1000100E-01,& + & .7020100E-02,.3144400E-02,.7805000E-02,.9466800E-02,.1043300E-01,& + & .1097400E-01,.1117300E-01,.1101900E-01,.1025300E-01,.7218900E-02/ + + data absa(451:585, 7) / & + & .2034500E-02,.6024900E-02,.7471600E-02,.8249600E-02,.8645800E-02,& + & .8734000E-02,.8522200E-02,.7865700E-02,.5371400E-02,.2207100E-02,& + & .6217600E-02,.7644000E-02,.8425100E-02,.8827300E-02,.8946100E-02,& + & .8768900E-02,.8112500E-02,.5583500E-02,.2355400E-02,.6372900E-02,& + & .7793200E-02,.8586800E-02,.9005800E-02,.9154800E-02,.9007500E-02,& + & .8366000E-02,.5782700E-02,.2478000E-02,.6494400E-02,.7910600E-02,& + & .8729100E-02,.9185700E-02,.9356500E-02,.9230200E-02,.8603600E-02,& + & .5969500E-02,.2582000E-02,.6580200E-02,.7997400E-02,.8842700E-02,& + & .9348200E-02,.9553900E-02,.9444300E-02,.8818000E-02,.6151200E-02,& + & .1678900E-02,.5090600E-02,.6307800E-02,.6975000E-02,.7317200E-02,& + & .7407800E-02,.7250400E-02,.6701500E-02,.4539400E-02,.1817000E-02,& + & .5243700E-02,.6451200E-02,.7125500E-02,.7479000E-02,.7595900E-02,& + & .7465500E-02,.6930700E-02,.4723700E-02,.1935600E-02,.5368900E-02,& + & .6570100E-02,.7261000E-02,.7641500E-02,.7781100E-02,.7670300E-02,& + & .7150800E-02,.4895300E-02,.2034200E-02,.5464400E-02,.6664000E-02,& + & .7379200E-02,.7792900E-02,.7963500E-02,.7866000E-02,.7353200E-02,& + & .5060700E-02,.2118200E-02,.5532800E-02,.6735200E-02,.7473600E-02,& + & .7928200E-02,.8130700E-02,.8054200E-02,.7540700E-02,.5223400E-02,& + & .1381900E-02,.4282300E-02,.5309600E-02,.5877100E-02,.6174500E-02,& + & .6260100E-02,.6141100E-02,.5689300E-02,.3820100E-02,.1492700E-02,& + & .4407800E-02,.5426100E-02,.6005500E-02,.6316700E-02,.6427800E-02,& + & .6326800E-02,.5889100E-02,.3978900E-02,.1588400E-02,.4509000E-02,& + & .5524600E-02,.6121700E-02,.6457700E-02,.6590300E-02,.6504400E-02,& + & .6075800E-02,.4128800E-02,.1668300E-02,.4585800E-02,.5602900E-02,& + & .6219300E-02,.6585900E-02,.6745400E-02,.6676800E-02,.6250600E-02,& + & .4276500E-02,.1736400E-02,.4641900E-02,.5664400E-02,.6299600E-02,& + & .6699800E-02,.6888800E-02,.6840400E-02,.6418800E-02,.4419800E-02/ + + data absa( 1:180, 8) / & + & .5776000E-01,.6943200E-01,.7640200E-01,.8151700E-01,.8512500E-01,& + & .8728900E-01,.8740800E-01,.8331700E-01,.7472000E-01,.5825600E-01,& + & .6966700E-01,.7672300E-01,.8191100E-01,.8536200E-01,.8728900E-01,& + & .8730600E-01,.8335700E-01,.7517700E-01,.5871000E-01,.6985900E-01,& + & .7697300E-01,.8232800E-01,.8569000E-01,.8742000E-01,.8726400E-01,& + & .8343500E-01,.7570100E-01,.5905200E-01,.7005000E-01,.7717600E-01,& + & .8264200E-01,.8607100E-01,.8766000E-01,.8734100E-01,.8354400E-01,& + & .7623000E-01,.5929800E-01,.7019800E-01,.7737400E-01,.8288300E-01,& + & .8646900E-01,.8797700E-01,.8747300E-01,.8369100E-01,.7676900E-01,& + & .5090800E-01,.6284800E-01,.7000300E-01,.7526300E-01,.7867000E-01,& + & .8059400E-01,.8069400E-01,.7704800E-01,.6704800E-01,.5146900E-01,& + & .6317800E-01,.7039500E-01,.7576300E-01,.7903300E-01,.8077500E-01,& + & .8068600E-01,.7719900E-01,.6760500E-01,.5195600E-01,.6351900E-01,& + & .7074800E-01,.7622100E-01,.7951200E-01,.8106700E-01,.8079700E-01,& + & .7737000E-01,.6818200E-01,.5232900E-01,.6383100E-01,.7111500E-01,& + & .7659100E-01,.8003200E-01,.8144500E-01,.8100100E-01,.7756800E-01,& + & .6876800E-01,.5264800E-01,.6410800E-01,.7144100E-01,.7694100E-01,& + & .8046400E-01,.8186600E-01,.8128200E-01,.7779600E-01,.6937700E-01,& + & .4463600E-01,.5657500E-01,.6366700E-01,.6880400E-01,.7214600E-01,& + & .7394000E-01,.7375600E-01,.7035900E-01,.5944600E-01,.4521600E-01,& + & .5700500E-01,.6411100E-01,.6932800E-01,.7262000E-01,.7422800E-01,& + & .7385400E-01,.7060000E-01,.6008600E-01,.4571600E-01,.5744800E-01,& + & .6459100E-01,.6981600E-01,.7317800E-01,.7461600E-01,.7409300E-01,& + & .7084300E-01,.6073800E-01,.4613700E-01,.5786200E-01,.6506000E-01,& + & .7028300E-01,.7372400E-01,.7506700E-01,.7440800E-01,.7113000E-01,& + & .6138500E-01,.4649000E-01,.5824000E-01,.6553700E-01,.7075200E-01,& + & .7418700E-01,.7554500E-01,.7481700E-01,.7147900E-01,.6199800E-01,& + & .3891000E-01,.5082300E-01,.5750500E-01,.6236400E-01,.6555900E-01,& + & .6715400E-01,.6679800E-01,.6353100E-01,.5240100E-01,.3948800E-01,& + & .5130700E-01,.5802200E-01,.6291200E-01,.6607400E-01,.6751800E-01,& + & .6702500E-01,.6384000E-01,.5309300E-01,.3999100E-01,.5181200E-01,& + & .5856600E-01,.6345100E-01,.6663200E-01,.6801000E-01,.6734800E-01,& + & .6416900E-01,.5378200E-01,.4038700E-01,.5229100E-01,.5911700E-01,& + & .6400100E-01,.6719600E-01,.6851400E-01,.6778900E-01,.6455500E-01,& + & .5447000E-01,.4071900E-01,.5273900E-01,.5969100E-01,.6457200E-01,& + & .6772500E-01,.6903100E-01,.6830700E-01,.6498500E-01,.5509100E-01/ + + data absa(181:315, 8) / & + & .3369200E-01,.4545900E-01,.5170500E-01,.5611100E-01,.5898400E-01,& + & .6038400E-01,.5995100E-01,.5677000E-01,.4593900E-01,.3425400E-01,& + & .4597900E-01,.5225200E-01,.5666400E-01,.5951500E-01,.6081600E-01,& + & .6027300E-01,.5714600E-01,.4664700E-01,.3473800E-01,.4653200E-01,& + & .5284600E-01,.5723800E-01,.6007700E-01,.6135200E-01,.6071400E-01,& + & .5756600E-01,.4735900E-01,.3511700E-01,.4704700E-01,.5345900E-01,& + & .5784900E-01,.6066800E-01,.6190200E-01,.6125900E-01,.5803000E-01,& + & .4803600E-01,.3542800E-01,.4750800E-01,.5408300E-01,.5849300E-01,& + & .6125300E-01,.6248100E-01,.6185100E-01,.5852300E-01,.4864800E-01,& + & .2891000E-01,.4042900E-01,.4617600E-01,.5010800E-01,.5260900E-01,& + & .5375000E-01,.5328900E-01,.5028600E-01,.4006100E-01,.2943300E-01,& + & .4096700E-01,.4673100E-01,.5065300E-01,.5314900E-01,.5423200E-01,& + & .5368700E-01,.5071400E-01,.4075600E-01,.2988300E-01,.4152000E-01,& + & .4734900E-01,.5125100E-01,.5373100E-01,.5479600E-01,.5420700E-01,& + & .5118800E-01,.4144300E-01,.3025200E-01,.4202400E-01,.4799800E-01,& + & .5191800E-01,.5433900E-01,.5538700E-01,.5482000E-01,.5171100E-01,& + & .4208500E-01,.3054200E-01,.4244700E-01,.4863500E-01,.5259800E-01,& + & .5498600E-01,.5603800E-01,.5543000E-01,.5223600E-01,.4267500E-01,& + & .2460000E-01,.3572500E-01,.4095200E-01,.4439800E-01,.4655800E-01,& + & .4746200E-01,.4695000E-01,.4422700E-01,.3475100E-01,.2506000E-01,& + & .3625000E-01,.4149800E-01,.4495000E-01,.4709700E-01,.4797700E-01,& + & .4739900E-01,.4469000E-01,.3541000E-01,.2546600E-01,.3676900E-01,& + & .4211900E-01,.4557200E-01,.4769600E-01,.4854800E-01,.4796500E-01,& + & .4519800E-01,.3605000E-01,.2580400E-01,.3723200E-01,.4276400E-01,& + & .4624900E-01,.4834900E-01,.4917300E-01,.4860300E-01,.4573700E-01,& + & .3664900E-01,.2607500E-01,.3764500E-01,.4337100E-01,.4695000E-01,& + & .4904500E-01,.4985600E-01,.4922300E-01,.4627900E-01,.3719800E-01/ + + data absa(316:450, 8) / & + & .2074700E-01,.3132500E-01,.3601600E-01,.3904700E-01,.4092100E-01,& + & .4165600E-01,.4109700E-01,.3868200E-01,.2995500E-01,.2114500E-01,& + & .3181100E-01,.3654100E-01,.3959700E-01,.4145500E-01,.4216900E-01,& + & .4157500E-01,.3914500E-01,.3057700E-01,.2149700E-01,.3229000E-01,& + & .3715500E-01,.4023800E-01,.4206700E-01,.4274400E-01,.4215400E-01,& + & .3964800E-01,.3117800E-01,.2179600E-01,.3271700E-01,.3776600E-01,& + & .4092300E-01,.4273800E-01,.4339400E-01,.4276800E-01,.4018500E-01,& + & .3173300E-01,.2204400E-01,.3311200E-01,.3833800E-01,.4159700E-01,& + & .4346200E-01,.4408700E-01,.4338500E-01,.4074000E-01,.3225400E-01,& + & .1736000E-01,.2721800E-01,.3140100E-01,.3408400E-01,.3574100E-01,& + & .3637300E-01,.3579800E-01,.3359400E-01,.2566400E-01,.1769300E-01,& + & .2766200E-01,.3190800E-01,.3462200E-01,.3626400E-01,.3687700E-01,& + & .3628500E-01,.3404900E-01,.2625100E-01,.1799200E-01,.2808900E-01,& + & .3247700E-01,.3525500E-01,.3687400E-01,.3744400E-01,.3683100E-01,& + & .3454400E-01,.2681400E-01,.1825800E-01,.2848100E-01,.3305000E-01,& + & .3590900E-01,.3755200E-01,.3807800E-01,.3742100E-01,.3507300E-01,& + & .2733500E-01,.1848400E-01,.2884900E-01,.3360100E-01,.3653600E-01,& + & .3825400E-01,.3875600E-01,.3802600E-01,.3561600E-01,.2782900E-01,& + & .1446200E-01,.2346300E-01,.2718600E-01,.2958800E-01,.3107900E-01,& + & .3162500E-01,.3105300E-01,.2901200E-01,.2191600E-01,.1473700E-01,& + & .2385300E-01,.2766200E-01,.3010900E-01,.3158100E-01,.3211600E-01,& + & .3152700E-01,.2946100E-01,.2246000E-01,.1498300E-01,.2423800E-01,& + & .2818700E-01,.3071000E-01,.3217600E-01,.3266400E-01,.3204400E-01,& + & .2994800E-01,.2298700E-01,.1522800E-01,.2459300E-01,.2871800E-01,& + & .3131200E-01,.3282600E-01,.3328200E-01,.3261500E-01,.3046700E-01,& + & .2347800E-01,.1541100E-01,.2493200E-01,.2922800E-01,.3190300E-01,& + & .3345500E-01,.3394300E-01,.3320700E-01,.3099400E-01,.2393900E-01/ + + data absa(451:585, 8) / & + & .1209700E-01,.2023000E-01,.2355400E-01,.2573700E-01,.2707000E-01,& + & .2752600E-01,.2698700E-01,.2512500E-01,.1884300E-01,.1231600E-01,& + & .2056400E-01,.2401400E-01,.2626500E-01,.2758900E-01,.2802100E-01,& + & .2746200E-01,.2558000E-01,.1934100E-01,.1252500E-01,.2089300E-01,& + & .2449400E-01,.2681700E-01,.2817200E-01,.2857800E-01,.2798500E-01,& + & .2607300E-01,.1981100E-01,.1269800E-01,.2121200E-01,.2497100E-01,& + & .2735800E-01,.2875200E-01,.2919600E-01,.2855400E-01,.2657500E-01,& + & .2025400E-01,.1281300E-01,.2152700E-01,.2542800E-01,.2788600E-01,& + & .2931600E-01,.2979400E-01,.2914400E-01,.2709500E-01,.2066900E-01,& + & .1007900E-01,.1733200E-01,.2032600E-01,.2228300E-01,.2345200E-01,& + & .2384000E-01,.2335100E-01,.2170100E-01,.1615000E-01,.1025300E-01,& + & .1762400E-01,.2073800E-01,.2277200E-01,.2396300E-01,.2434300E-01,& + & .2383000E-01,.2215900E-01,.1660500E-01,.1041200E-01,.1791400E-01,& + & .2116500E-01,.2325700E-01,.2449100E-01,.2490700E-01,.2436400E-01,& + & .2263300E-01,.1703100E-01,.1052800E-01,.1820300E-01,.2158500E-01,& + & .2373200E-01,.2501900E-01,.2546600E-01,.2492500E-01,.2312300E-01,& + & .1744000E-01,.1059500E-01,.1849100E-01,.2198700E-01,.2420500E-01,& + & .2552600E-01,.2601300E-01,.2549700E-01,.2363300E-01,.1782500E-01,& + & .8367500E-02,.1477800E-01,.1745500E-01,.1920100E-01,.2021400E-01,& + & .2054500E-01,.2013300E-01,.1870300E-01,.1381000E-01,.8503700E-02,& + & .1503300E-01,.1782400E-01,.1962100E-01,.2068400E-01,.2105200E-01,& + & .2061600E-01,.1914500E-01,.1421800E-01,.8612900E-02,.1530300E-01,& + & .1819700E-01,.2004300E-01,.2116300E-01,.2157700E-01,.2114300E-01,& + & .1960000E-01,.1461700E-01,.8691200E-02,.1556800E-01,.1856500E-01,& + & .2047200E-01,.2163600E-01,.2209100E-01,.2167400E-01,.2009000E-01,& + & .1499100E-01,.8730200E-02,.1580000E-01,.1891700E-01,.2088700E-01,& + & .2210300E-01,.2259400E-01,.2219800E-01,.2058600E-01,.1535100E-01/ + + data absa( 1:180, 9) / & + & .2875600E+00,.2846608E+00,.3007336E+00,.3116711E+00,.3128429E+00,& + & .3061657E+00,.2955131E+00,.2798330E+00,.2885174E+00,.2846791E+00,& + & .2818630E+00,.2979418E+00,.3088891E+00,.3105850E+00,.3045729E+00,& + & .2947321E+00,.2798508E+00,.2884665E+00,.2823420E+00,.2795426E+00,& + & .2956237E+00,.3062904E+00,.3083329E+00,.3027922E+00,.2937895E+00,& + & .2797232E+00,.2884416E+00,.2804602E+00,.2775936E+00,.2936396E+00,& + & .3040736E+00,.3061042E+00,.3009290E+00,.2927341E+00,.2793614E+00,& + & .2882076E+00,.2789708E+00,.2760060E+00,.2919045E+00,.3021032E+00,& + & .3039633E+00,.2991521E+00,.2914947E+00,.2788660E+00,.2878374E+00,& + & .2691839E+00,.2738289E+00,.2925806E+00,.3047303E+00,.3076965E+00,& + & .3021735E+00,.2903704E+00,.2740484E+00,.2753391E+00,.2667388E+00,& + & .2713965E+00,.2901694E+00,.3021752E+00,.3055593E+00,.3006242E+00,& + & .2897230E+00,.2740378E+00,.2755566E+00,.2649469E+00,.2695060E+00,& + & .2881919E+00,.2999513E+00,.3034581E+00,.2989484E+00,.2889087E+00,& + & .2738977E+00,.2755970E+00,.2636807E+00,.2680315E+00,.2865238E+00,& + & .2980684E+00,.3014061E+00,.2973517E+00,.2879069E+00,.2735423E+00,& + & .2754315E+00,.2627764E+00,.2669319E+00,.2851547E+00,.2963620E+00,& + & .2995768E+00,.2957673E+00,.2866862E+00,.2730982E+00,.2752015E+00,& + & .2490195E+00,.2608954E+00,.2819694E+00,.2948392E+00,.2994181E+00,& + & .2960253E+00,.2839092E+00,.2667913E+00,.2610712E+00,.2470483E+00,& + & .2588078E+00,.2799097E+00,.2926407E+00,.2974527E+00,.2945959E+00,& + & .2834853E+00,.2668456E+00,.2614061E+00,.2457732E+00,.2572386E+00,& + & .2782150E+00,.2907979E+00,.2955550E+00,.2931132E+00,.2827947E+00,& + & .2667547E+00,.2614625E+00,.2450220E+00,.2561881E+00,.2768616E+00,& + & .2892386E+00,.2937867E+00,.2916947E+00,.2819208E+00,.2664583E+00,& + & .2614477E+00,.2447576E+00,.2555647E+00,.2758063E+00,.2878616E+00,& + & .2922788E+00,.2903473E+00,.2808432E+00,.2661024E+00,.2614835E+00,& + & .2278433E+00,.2459460E+00,.2687748E+00,.2823420E+00,.2883606E+00,& + & .2867773E+00,.2761135E+00,.2583114E+00,.2469847E+00,.2262821E+00,& + & .2442492E+00,.2669664E+00,.2804797E+00,.2866383E+00,.2856021E+00,& + & .2758521E+00,.2584755E+00,.2474068E+00,.2254367E+00,.2430836E+00,& + & .2656062E+00,.2789372E+00,.2850299E+00,.2843218E+00,.2753572E+00,& + & .2584303E+00,.2476169E+00,.2252826E+00,.2424728E+00,.2646308E+00,& + & .2777122E+00,.2836401E+00,.2831157E+00,.2746060E+00,.2582669E+00,& + & .2478333E+00,.2256551E+00,.2423529E+00,.2639731E+00,.2766779E+00,& + & .2825116E+00,.2820352E+00,.2736912E+00,.2580734E+00,.2481106E+00/ + + data absa(181:315, 9) / & + & .2062751E+00,.2298044E+00,.2532990E+00,.2676292E+00,.2748784E+00,& + & .2747996E+00,.2666545E+00,.2487411E+00,.2325541E+00,.2051043E+00,& + & .2284554E+00,.2518239E+00,.2660870E+00,.2734853E+00,.2738569E+00,& + & .2665350E+00,.2490789E+00,.2332102E+00,.2047919E+00,.2277211E+00,& + & .2507972E+00,.2649403E+00,.2721940E+00,.2728699E+00,.2661103E+00,& + & .2492251E+00,.2337220E+00,.2051961E+00,.2275744E+00,.2501902E+00,& + & .2640418E+00,.2711870E+00,.2720181E+00,.2654582E+00,.2492504E+00,& + & .2342238E+00,.2061900E+00,.2279645E+00,.2499630E+00,.2633833E+00,& + & .2704230E+00,.2712077E+00,.2647461E+00,.2492510E+00,.2347478E+00,& + & .1853388E+00,.2130833E+00,.2365145E+00,.2513589E+00,.2593134E+00,& + & .2609466E+00,.2549939E+00,.2376988E+00,.2170867E+00,.1845601E+00,& + & .2121024E+00,.2353552E+00,.2502019E+00,.2582784E+00,.2602288E+00,& + & .2550486E+00,.2382771E+00,.2180680E+00,.1846602E+00,.2117219E+00,& + & .2346887E+00,.2493886E+00,.2574166E+00,.2595177E+00,.2547983E+00,& + & .2386926E+00,.2189256E+00,.1855458E+00,.2119966E+00,.2344799E+00,& + & .2488166E+00,.2567948E+00,.2589356E+00,.2543373E+00,.2389459E+00,& + & .2197901E+00,.1870772E+00,.2128598E+00,.2346986E+00,.2485625E+00,& + & .2564000E+00,.2584353E+00,.2538996E+00,.2391912E+00,.2205482E+00,& + & .1654511E+00,.1961135E+00,.2190853E+00,.2338982E+00,.2425818E+00,& + & .2456184E+00,.2412218E+00,.2252744E+00,.2008814E+00,.1650292E+00,& + & .1954131E+00,.2182427E+00,.2330965E+00,.2418982E+00,.2451802E+00,& + & .2414790E+00,.2260855E+00,.2021875E+00,.1654771E+00,.1953910E+00,& + & .2179136E+00,.2326080E+00,.2414414E+00,.2447571E+00,.2414612E+00,& + & .2267328E+00,.2033987E+00,.1667613E+00,.1960735E+00,.2180521E+00,& + & .2324354E+00,.2411480E+00,.2444710E+00,.2413228E+00,.2272824E+00,& + & .2045050E+00,.1686834E+00,.1973572E+00,.2187006E+00,.2325944E+00,& + & .2410697E+00,.2443064E+00,.2412853E+00,.2277903E+00,.2054612E+00/ + + data absa(316:450, 9) / & + & .1466987E+00,.1792921E+00,.2014461E+00,.2160765E+00,.2251959E+00,& + & .2288858E+00,.2256137E+00,.2115906E+00,.1843005E+00,.1465091E+00,& + & .1788078E+00,.2009639E+00,.2155790E+00,.2248838E+00,.2288389E+00,& + & .2260797E+00,.2126564E+00,.1858920E+00,.1472457E+00,.1790577E+00,& + & .2009403E+00,.2154072E+00,.2247365E+00,.2287839E+00,.2263437E+00,& + & .2135828E+00,.1874072E+00,.1487936E+00,.1800885E+00,.2014536E+00,& + & .2156062E+00,.2248091E+00,.2288471E+00,.2265932E+00,.2144085E+00,& + & .1887703E+00,.1510004E+00,.1817540E+00,.2025068E+00,.2162005E+00,& + & .2250829E+00,.2290843E+00,.2269522E+00,.2151187E+00,.1899588E+00,& + & .1290166E+00,.1628134E+00,.1841393E+00,.1984523E+00,.2074091E+00,& + & .2111610E+00,.2086918E+00,.1966022E+00,.1675581E+00,.1290151E+00,& + & .1624988E+00,.1838874E+00,.1982834E+00,.2074512E+00,.2114622E+00,& + & .2094660E+00,.1978766E+00,.1694333E+00,.1299542E+00,.1629858E+00,& + & .1841354E+00,.1984427E+00,.2076315E+00,.2117841E+00,.2100747E+00,& + & .1990529E+00,.1712079E+00,.1317221E+00,.1642880E+00,.1849872E+00,& + & .1989586E+00,.2080569E+00,.2122421E+00,.2107272E+00,.2001600E+00,& + & .1728028E+00,.1340336E+00,.1662556E+00,.1864180E+00,.1999647E+00,& + & .2087569E+00,.2128849E+00,.2114836E+00,.2011527E+00,.1742183E+00,& + & .1126804E+00,.1466556E+00,.1672889E+00,.1811021E+00,.1894716E+00,& + & .1930711E+00,.1911967E+00,.1807203E+00,.1511468E+00,.1128902E+00,& + & .1466324E+00,.1672756E+00,.1812574E+00,.1898492E+00,.1936951E+00,& + & .1922455E+00,.1822647E+00,.1532592E+00,.1140256E+00,.1474289E+00,& + & .1678506E+00,.1817516E+00,.1903705E+00,.1944050E+00,.1932330E+00,& + & .1836902E+00,.1552103E+00,.1159334E+00,.1490190E+00,.1690437E+00,& + & .1826551E+00,.1911836E+00,.1952461E+00,.1942671E+00,.1850452E+00,& + & .1569828E+00,.1181595E+00,.1512541E+00,.1708193E+00,.1840599E+00,& + & .1923574E+00,.1963008E+00,.1954232E+00,.1863167E+00,.1585924E+00/ + + data absa(451:585, 9) / & + & .9798189E-01,.1313265E+00,.1510348E+00,.1641642E+00,.1721410E+00,& + & .1755759E+00,.1741644E+00,.1652309E+00,.1361983E+00,.9876591E-01,& + & .1319241E+00,.1515858E+00,.1647606E+00,.1728744E+00,.1765573E+00,& + & .1754929E+00,.1669557E+00,.1384236E+00,.1003841E+00,.1333210E+00,& + & .1527464E+00,.1657657E+00,.1738505E+00,.1776840E+00,.1768404E+00,& + & .1686021E+00,.1404407E+00,.1023815E+00,.1354349E+00,.1545144E+00,& + & .1673004E+00,.1752277E+00,.1790049E+00,.1782869E+00,.1701818E+00,& + & .1423084E+00,.1045182E+00,.1378387E+00,.1568227E+00,.1693189E+00,& + & .1770176E+00,.1806205E+00,.1797803E+00,.1716817E+00,.1441206E+00,& + & .8513105E-01,.1174272E+00,.1357845E+00,.1479723E+00,.1555369E+00,& + & .1588474E+00,.1576920E+00,.1498764E+00,.1219425E+00,.8639013E-01,& + & .1185546E+00,.1369085E+00,.1490184E+00,.1566903E+00,.1601862E+00,& + & .1592810E+00,.1518099E+00,.1242064E+00,.8811019E-01,.1204518E+00,& + & .1385898E+00,.1506015E+00,.1581843E+00,.1617403E+00,.1609764E+00,& + & .1536670E+00,.1263021E+00,.9004252E-01,.1227432E+00,.1408853E+00,& + & .1527101E+00,.1601143E+00,.1635634E+00,.1627369E+00,.1554561E+00,& + & .1283211E+00,.9212719E-01,.1251177E+00,.1434973E+00,.1553078E+00,& + & .1624820E+00,.1656416E+00,.1645751E+00,.1572251E+00,.1303753E+00,& + & .7386256E-01,.1049065E+00,.1217281E+00,.1327938E+00,.1397977E+00,& + & .1430454E+00,.1419673E+00,.1350204E+00,.1084738E+00,.7529440E-01,& + & .1065145E+00,.1232849E+00,.1343471E+00,.1414069E+00,.1447364E+00,& + & .1438645E+00,.1371204E+00,.1108041E+00,.7697705E-01,.1086621E+00,& + & .1254864E+00,.1364483E+00,.1434325E+00,.1467317E+00,.1458386E+00,& + & .1392068E+00,.1129989E+00,.7887272E-01,.1109542E+00,.1281014E+00,& + & .1390876E+00,.1459050E+00,.1489849E+00,.1479204E+00,.1412350E+00,& + & .1152445E+00,.8092106E-01,.1133621E+00,.1308019E+00,.1420681E+00,& + & .1487342E+00,.1514606E+00,.1501482E+00,.1433560E+00,.1175338E+00/ + + data absa( 1:180,10) / & + & .1892134E+01,.1658490E+01,.1482317E+01,.1379089E+01,.1354260E+01,& + & .1396373E+01,.1493971E+01,.1670802E+01,.1862417E+01,.1891097E+01,& + & .1657654E+01,.1481328E+01,.1378847E+01,.1353670E+01,.1394913E+01,& + & .1490545E+01,.1665288E+01,.1856307E+01,.1886928E+01,.1654075E+01,& + & .1478255E+01,.1377182E+01,.1351932E+01,.1393126E+01,.1486947E+01,& + & .1659721E+01,.1849481E+01,.1880181E+01,.1648189E+01,.1473312E+01,& + & .1373916E+01,.1349297E+01,.1390619E+01,.1483307E+01,.1654665E+01,& + & .1843360E+01,.1870673E+01,.1639925E+01,.1466606E+01,.1369235E+01,& + & .1345693E+01,.1387158E+01,.1479894E+01,.1649791E+01,.1837634E+01,& + & .2033645E+01,.1786076E+01,.1609696E+01,.1508649E+01,.1481540E+01,& + & .1520376E+01,.1619882E+01,.1790721E+01,.2011948E+01,.2032041E+01,& + & .1784578E+01,.1608196E+01,.1508007E+01,.1480683E+01,.1518803E+01,& + & .1616344E+01,.1785487E+01,.2005460E+01,.2027050E+01,.1780171E+01,& + & .1604546E+01,.1505776E+01,.1478425E+01,.1516595E+01,.1612478E+01,& + & .1780218E+01,.1999063E+01,.2019259E+01,.1773344E+01,.1599018E+01,& + & .1501972E+01,.1475347E+01,.1513286E+01,.1608726E+01,.1775367E+01,& + & .1993239E+01,.2008510E+01,.1763923E+01,.1591459E+01,.1496491E+01,& + & .1471124E+01,.1509095E+01,.1605098E+01,.1770446E+01,.1987403E+01,& + & .2178944E+01,.1920080E+01,.1745231E+01,.1648443E+01,.1618386E+01,& + & .1649487E+01,.1748723E+01,.1914679E+01,.2160515E+01,.2176816E+01,& + & .1918278E+01,.1743380E+01,.1647385E+01,.1617218E+01,.1647942E+01,& + & .1744763E+01,.1909779E+01,.2154360E+01,.2171431E+01,.1913602E+01,& + & .1739533E+01,.1644632E+01,.1614855E+01,.1645433E+01,.1740900E+01,& + & .1904856E+01,.2148715E+01,.2162892E+01,.1906049E+01,.1733600E+01,& + & .1640053E+01,.1611602E+01,.1641860E+01,.1736869E+01,.1900085E+01,& + & .2142847E+01,.2151134E+01,.1895842E+01,.1725453E+01,.1633876E+01,& + & .1606822E+01,.1637313E+01,.1732726E+01,.1894852E+01,.2136670E+01,& + & .2323030E+01,.2056823E+01,.1886477E+01,.1793946E+01,.1761503E+01,& + & .1786099E+01,.1877376E+01,.2039031E+01,.2297025E+01,.2320669E+01,& + & .2054539E+01,.1884669E+01,.1792680E+01,.1760212E+01,.1784371E+01,& + & .1873523E+01,.2034631E+01,.2291545E+01,.2314935E+01,.2049383E+01,& + & .1880494E+01,.1789605E+01,.1757829E+01,.1781704E+01,.1869518E+01,& + & .2030102E+01,.2286263E+01,.2305612E+01,.2041188E+01,.1873956E+01,& + & .1784458E+01,.1754036E+01,.1777972E+01,.1865353E+01,.2025199E+01,& + & .2280190E+01,.2293056E+01,.2030193E+01,.1865150E+01,.1777683E+01,& + & .1748548E+01,.1773179E+01,.1860971E+01,.2019743E+01,.2273813E+01/ + + data absa(181:315,10) / & + & .2463042E+01,.2192642E+01,.2030621E+01,.1942197E+01,.1908343E+01,& + & .1927535E+01,.2006081E+01,.2161944E+01,.2425159E+01,.2460420E+01,& + & .2190039E+01,.2028628E+01,.1940843E+01,.1906973E+01,.1925788E+01,& + & .2002593E+01,.2157807E+01,.2420144E+01,.2453905E+01,.2184091E+01,& + & .2024115E+01,.1937152E+01,.1904425E+01,.1922817E+01,.1998960E+01,& + & .2153199E+01,.2414552E+01,.2443881E+01,.2175206E+01,.2017059E+01,& + & .1931637E+01,.1900107E+01,.1918693E+01,.1994945E+01,.2148178E+01,& + & .2408426E+01,.2430382E+01,.2163388E+01,.2007456E+01,.1924180E+01,& + & .1893992E+01,.1913520E+01,.1990266E+01,.2142434E+01,.2401933E+01,& + & .2595361E+01,.2325394E+01,.2174062E+01,.2090012E+01,.2056871E+01,& + & .2069942E+01,.2136930E+01,.2284007E+01,.2549107E+01,.2592280E+01,& + & .2322210E+01,.2171892E+01,.2088399E+01,.2055272E+01,.2068312E+01,& + & .2133783E+01,.2280033E+01,.2544255E+01,.2585394E+01,.2315981E+01,& + & .2166893E+01,.2084474E+01,.2052146E+01,.2065367E+01,.2130298E+01,& + & .2275321E+01,.2538577E+01,.2574759E+01,.2306564E+01,.2159165E+01,& + & .2078513E+01,.2047302E+01,.2061084E+01,.2126258E+01,.2270085E+01,& + & .2532268E+01,.2560534E+01,.2294295E+01,.2148978E+01,.2070421E+01,& + & .2040584E+01,.2055565E+01,.2121352E+01,.2264122E+01,.2525794E+01,& + & .2717730E+01,.2453250E+01,.2313374E+01,.2235402E+01,.2202356E+01,& + & .2210413E+01,.2268848E+01,.2403823E+01,.2668217E+01,.2714408E+01,& + & .2449934E+01,.2311069E+01,.2233513E+01,.2200700E+01,.2208877E+01,& + & .2266063E+01,.2400211E+01,.2663785E+01,.2707312E+01,.2443349E+01,& + & .2305816E+01,.2229419E+01,.2197247E+01,.2206137E+01,.2262718E+01,& + & .2395786E+01,.2658274E+01,.2696315E+01,.2433710E+01,.2297781E+01,& + & .2222901E+01,.2191947E+01,.2201655E+01,.2258338E+01,.2390352E+01,& + & .2652236E+01,.2681738E+01,.2420849E+01,.2287046E+01,.2214166E+01,& + & .2184829E+01,.2195666E+01,.2252886E+01,.2384216E+01,.2646214E+01/ + + data absa(316:450,10) / & + & .2830476E+01,.2574810E+01,.2446984E+01,.2374964E+01,.2342639E+01,& + & .2348427E+01,.2400182E+01,.2520854E+01,.2781859E+01,.2827137E+01,& + & .2571641E+01,.2444361E+01,.2373065E+01,.2340938E+01,.2346711E+01,& + & .2397962E+01,.2517827E+01,.2778017E+01,.2819904E+01,.2565126E+01,& + & .2438846E+01,.2368655E+01,.2337305E+01,.2343718E+01,.2394597E+01,& + & .2513695E+01,.2772893E+01,.2808916E+01,.2555136E+01,.2430441E+01,& + & .2361733E+01,.2331640E+01,.2338952E+01,.2389996E+01,.2508304E+01,& + & .2767177E+01,.2794379E+01,.2541925E+01,.2419332E+01,.2352428E+01,& + & .2324012E+01,.2332369E+01,.2384042E+01,.2502259E+01,.2761425E+01,& + & .2933800E+01,.2689436E+01,.2572674E+01,.2506396E+01,.2476838E+01,& + & .2482312E+01,.2528761E+01,.2636078E+01,.2889382E+01,.2930816E+01,& + & .2686703E+01,.2570265E+01,.2504494E+01,.2475090E+01,.2480774E+01,& + & .2526766E+01,.2633891E+01,.2886327E+01,.2923537E+01,.2680192E+01,& + & .2564715E+01,.2499735E+01,.2471291E+01,.2477512E+01,.2523484E+01,& + & .2630022E+01,.2881726E+01,.2912511E+01,.2670142E+01,.2556117E+01,& + & .2492614E+01,.2465215E+01,.2472392E+01,.2518562E+01,.2624696E+01,& + & .2876581E+01,.2898553E+01,.2656790E+01,.2544582E+01,.2482931E+01,& + & .2457049E+01,.2465309E+01,.2512229E+01,.2618696E+01,.2871034E+01,& + & .3027058E+01,.2797212E+01,.2690074E+01,.2629551E+01,.2604067E+01,& + & .2610197E+01,.2652331E+01,.2748363E+01,.2990031E+01,.3023852E+01,& + & .2794164E+01,.2687619E+01,.2627303E+01,.2602246E+01,.2608704E+01,& + & .2650569E+01,.2746538E+01,.2987720E+01,.3016507E+01,.2787386E+01,& + & .2681752E+01,.2622344E+01,.2598218E+01,.2605186E+01,.2647180E+01,& + & .2742958E+01,.2983973E+01,.3005577E+01,.2777090E+01,.2672822E+01,& + & .2614852E+01,.2591693E+01,.2599702E+01,.2642041E+01,.2737917E+01,& + & .2979411E+01,.2992905E+01,.2763507E+01,.2660993E+01,.2604652E+01,& + & .2582864E+01,.2591914E+01,.2635114E+01,.2731878E+01,.2974194E+01/ + + data absa(451:585,10) / & + & .3108634E+01,.2895420E+01,.2798425E+01,.2744368E+01,.2722653E+01,& + & .2730122E+01,.2769336E+01,.2855617E+01,.3083249E+01,.3103552E+01,& + & .2890636E+01,.2794237E+01,.2740840E+01,.2719834E+01,.2727815E+01,& + & .2767022E+01,.2853516E+01,.3081043E+01,.3094635E+01,.2882058E+01,& + & .2786673E+01,.2734481E+01,.2714488E+01,.2723042E+01,.2762618E+01,& + & .2849365E+01,.3077793E+01,.3083887E+01,.2870120E+01,.2776133E+01,& + & .2725197E+01,.2706459E+01,.2715971E+01,.2756337E+01,.2843995E+01,& + & .3073502E+01,.3072208E+01,.2856377E+01,.2762710E+01,.2713207E+01,& + & .2695854E+01,.2706674E+01,.2748406E+01,.2837477E+01,.3067985E+01,& + & .3179487E+01,.2983632E+01,.2897614E+01,.2850758E+01,.2832739E+01,& + & .2841435E+01,.2878587E+01,.2957109E+01,.3169588E+01,.3172853E+01,& + & .2977291E+01,.2891777E+01,.2845999E+01,.2828739E+01,.2838054E+01,& + & .2875642E+01,.2954402E+01,.3167982E+01,.3164067E+01,.2967272E+01,& + & .2882837E+01,.2838175E+01,.2822030E+01,.2832002E+01,.2870360E+01,& + & .2950082E+01,.3164988E+01,.3154001E+01,.2955025E+01,.2870648E+01,& + & .2827230E+01,.2812357E+01,.2823496E+01,.2863128E+01,.2944286E+01,& + & .3160501E+01,.3142799E+01,.2941633E+01,.2856439E+01,.2813383E+01,& + & .2800017E+01,.2812937E+01,.2854322E+01,.2937121E+01,.3154451E+01,& + & .3241097E+01,.3062217E+01,.2987360E+01,.2948157E+01,.2934292E+01,& + & .2943847E+01,.2979640E+01,.3051660E+01,.3249168E+01,.3234006E+01,& + & .3054284E+01,.2980255E+01,.2942054E+01,.2929013E+01,.2939386E+01,& + & .2975962E+01,.3048876E+01,.3247803E+01,.3225888E+01,.3043668E+01,& + & .2969796E+01,.2932743E+01,.2920751E+01,.2932040E+01,.2969899E+01,& + & .3044051E+01,.3244864E+01,.3216320E+01,.3031794E+01,.2956859E+01,& + & .2920139E+01,.2909436E+01,.2922425E+01,.2961874E+01,.3037648E+01,& + & .3239868E+01,.3205483E+01,.3018784E+01,.2942726E+01,.2905212E+01,& + & .2895638E+01,.2910719E+01,.2952008E+01,.3029378E+01,.3233244E+01/ + + + data absb( 1:175, 1) / & + & .4063300E-08,.6471800E-06,.7956700E-06,.8126400E-06,.2508000E-07,& + & .3759600E-08,.7042900E-06,.9085500E-06,.9643200E-06,.2829200E-07,& + & .3498200E-08,.7637000E-06,.1031600E-05,.1147200E-05,.3126500E-07,& + & .3270700E-08,.8283400E-06,.1157700E-05,.1338700E-05,.3492800E-07,& + & .3071000E-08,.9025200E-06,.1296200E-05,.1520600E-05,.3885900E-07,& + & .3302600E-08,.5359200E-06,.6617100E-06,.6763300E-06,.2076700E-07,& + & .3057400E-08,.5795900E-06,.7538600E-06,.8039500E-06,.2333400E-07,& + & .2846100E-08,.6289700E-06,.8548600E-06,.9574500E-06,.2584100E-07,& + & .2662100E-08,.6835200E-06,.9613200E-06,.1114800E-05,.2886200E-07,& + & .2500500E-08,.7451700E-06,.1073900E-05,.1263200E-05,.3209300E-07,& + & .2682100E-08,.4408100E-06,.5509300E-06,.5646500E-06,.1718600E-07,& + & .2484500E-08,.4777300E-06,.6263600E-06,.6718000E-06,.1923400E-07,& + & .2314000E-08,.5181100E-06,.7079100E-06,.7965800E-06,.2134800E-07,& + & .2165400E-08,.5641600E-06,.7989300E-06,.9287300E-06,.2383200E-07,& + & .2034700E-08,.6153500E-06,.8898500E-06,.1049900E-05,.2648500E-07,& + & .2177500E-08,.3625400E-06,.4587000E-06,.4712500E-06,.1421100E-07,& + & .2018300E-08,.3937600E-06,.5205300E-06,.5616300E-06,.1586900E-07,& + & .1880800E-08,.4268700E-06,.5869900E-06,.6638600E-06,.1762700E-07,& + & .1760800E-08,.4655900E-06,.6638800E-06,.7706300E-06,.1966400E-07,& + & .1655200E-08,.5074700E-06,.7369900E-06,.8724900E-06,.2184400E-07,& + & .1768200E-08,.2983600E-06,.3810400E-06,.3931400E-06,.1173500E-07,& + & .1639900E-08,.3249300E-06,.4321500E-06,.4689700E-06,.1307700E-07,& + & .1529000E-08,.3520300E-06,.4866500E-06,.5532800E-06,.1453500E-07,& + & .1432100E-08,.3838300E-06,.5503300E-06,.6384400E-06,.1620800E-07,& + & .1346800E-08,.4182200E-06,.6095000E-06,.7237600E-06,.1799500E-07,& + & .1436200E-08,.2456000E-06,.3166700E-06,.3279700E-06,.9683100E-08,& + & .1332700E-08,.2678400E-06,.3587200E-06,.3913400E-06,.1077300E-07,& + & .1243200E-08,.2900800E-06,.4033400E-06,.4602600E-06,.1198000E-07,& + & .1165000E-08,.3163700E-06,.4558300E-06,.5288000E-06,.1335000E-07,& + & .1096000E-08,.3450300E-06,.5036300E-06,.5996700E-06,.1481500E-07,& + & .1166700E-08,.2023100E-06,.2631300E-06,.2735900E-06,.7993400E-08,& + & .1083300E-08,.2208500E-06,.2976000E-06,.3262000E-06,.8880700E-08,& + & .1011000E-08,.2391200E-06,.3342300E-06,.3827100E-06,.9877100E-08,& + & .9477800E-09,.2607300E-06,.3768500E-06,.4379100E-06,.1100200E-07,& + & .8919800E-09,.2842500E-06,.4158900E-06,.4968200E-06,.1220400E-07/ + + data absb(176:350, 1) / & + & .9466800E-09,.1673500E-06,.2182200E-06,.2291400E-06,.6623700E-08,& + & .8795600E-09,.1825500E-06,.2477000E-06,.2729000E-06,.7347000E-08,& + & .8213200E-09,.1977600E-06,.2778600E-06,.3191300E-06,.8173200E-08,& + & .7703200E-09,.2155700E-06,.3119700E-06,.3638000E-06,.9101900E-08,& + & .7252800E-09,.2345800E-06,.3444900E-06,.4125700E-06,.1008400E-07,& + & .7680900E-09,.1385800E-06,.1813800E-06,.1918800E-06,.5492900E-08,& + & .7140800E-09,.1508800E-06,.2061400E-06,.2283500E-06,.6082500E-08,& + & .6671700E-09,.1636600E-06,.2311100E-06,.2662200E-06,.6768000E-08,& + & .6260500E-09,.1781600E-06,.2583400E-06,.3024200E-06,.7534400E-08,& + & .5897000E-09,.1937400E-06,.2854200E-06,.3422200E-06,.8339400E-08,& + & .6201300E-09,.1154700E-06,.1521200E-06,.1622700E-06,.4592600E-08,& + & .5770900E-09,.1255200E-06,.1721100E-06,.1926500E-06,.5072800E-08,& + & .5396400E-09,.1361900E-06,.1936300E-06,.2240200E-06,.5645400E-08,& + & .5067500E-09,.1480500E-06,.2155700E-06,.2532000E-06,.6280500E-08,& + & .4776400E-09,.1609700E-06,.2379900E-06,.2857400E-06,.6941400E-08,& + & .5005500E-09,.9616500E-07,.1277600E-06,.1375200E-06,.3793300E-08,& + & .4662700E-09,.1042100E-06,.1438700E-06,.1622600E-06,.4215400E-08,& + & .4363800E-09,.1132000E-06,.1624000E-06,.1880600E-06,.4676100E-08,& + & .4100900E-09,.1231200E-06,.1800200E-06,.2121400E-06,.5172400E-08,& + & .3867900E-09,.1338000E-06,.1983500E-06,.2383600E-06,.5686300E-08,& + & .4038400E-09,.8017400E-07,.1074200E-06,.1166500E-06,.3143500E-08,& + & .3765600E-09,.8661100E-07,.1206200E-06,.1369400E-06,.3474600E-08,& + & .3527300E-09,.9420300E-07,.1361000E-06,.1572900E-06,.3858600E-08,& + & .3317400E-09,.1024600E-06,.1503500E-06,.1777500E-06,.4270700E-08,& + & .3131000E-09,.1112200E-06,.1654300E-06,.1991700E-06,.4702000E-08,& + & .3256200E-09,.6678500E-07,.9044700E-07,.9905900E-07,.2613400E-08,& + & .3039300E-09,.7213300E-07,.1013900E-06,.1157100E-06,.2887200E-08,& + & .2849500E-09,.7844800E-07,.1138500E-06,.1317800E-06,.3206100E-08,& + & .2682100E-09,.8533900E-07,.1256300E-06,.1491400E-06,.3548900E-08,& + & .2533200E-09,.9244500E-07,.1381400E-06,.1667400E-06,.3906000E-08,& + & .2622400E-09,.5568000E-07,.7636900E-07,.8440000E-07,.2175900E-08,& + & .2450400E-09,.6020400E-07,.8542300E-07,.9788500E-07,.2411800E-08,& + & .2299600E-09,.6547700E-07,.9532100E-07,.1109300E-06,.2677400E-08,& + & .2166300E-09,.7118800E-07,.1052900E-06,.1254400E-06,.2961500E-08,& + & .2047500E-09,.7694000E-07,.1155600E-06,.1397700E-06,.3256900E-08/ + + data absb(351:525, 1) / & + & .2112000E-09,.4638200E-07,.6389400E-07,.7137900E-07,.1817800E-08,& + & .1975600E-09,.5027800E-07,.7203300E-07,.8290900E-07,.2018100E-08,& + & .1855700E-09,.5467000E-07,.7995300E-07,.9350500E-07,.2239600E-08,& + & .1749600E-09,.5940800E-07,.8817900E-07,.1055300E-06,.2473700E-08,& + & .1654900E-09,.6402500E-07,.9669600E-07,.1170400E-06,.2709200E-08,& + & .1701000E-09,.3863100E-07,.5377300E-07,.6057900E-07,.1522000E-08,& + & .1592800E-09,.4200100E-07,.6066000E-07,.6972700E-07,.1690100E-08,& + & .1497600E-09,.4566100E-07,.6706500E-07,.7884500E-07,.1869600E-08,& + & .1413100E-09,.4957100E-07,.7380900E-07,.8848100E-07,.2061100E-08,& + & .1337600E-09,.5330400E-07,.8091000E-07,.9801700E-07,.2256500E-08,& + & .1369600E-09,.3227000E-07,.4539200E-07,.5143800E-07,.1272100E-08,& + & .1283900E-09,.3507900E-07,.5094600E-07,.5872600E-07,.1411800E-08,& + & .1208200E-09,.3815000E-07,.5625800E-07,.6649300E-07,.1562800E-08,& + & .1141000E-09,.4132400E-07,.6184300E-07,.7438700E-07,.1720500E-08,& + & .1080800E-09,.4438700E-07,.6773900E-07,.8221600E-07,.1874500E-08,& + & .1102900E-09,.2697000E-07,.3833000E-07,.4369800E-07,.1065500E-08,& + & .1034900E-09,.2931900E-07,.4273900E-07,.4955200E-07,.1182300E-08,& + & .9748300E-10,.3186900E-07,.4721000E-07,.5605700E-07,.1303800E-08,& + & .9213300E-10,.3443600E-07,.5181200E-07,.6248500E-07,.1428500E-08,& + & .8734000E-10,.3695300E-07,.5670900E-07,.6892100E-07,.1556300E-08,& + & .8880600E-10,.2255500E-07,.3238600E-07,.3712900E-07,.8902900E-09,& + & .8341700E-10,.2451900E-07,.3592100E-07,.4187000E-07,.9854800E-09,& + & .7864400E-10,.2663800E-07,.3960900E-07,.4727300E-07,.1085400E-08,& + & .7438800E-10,.2869400E-07,.4342300E-07,.5243500E-07,.1188000E-08,& + & .7056800E-10,.3077600E-07,.4741100E-07,.5775000E-07,.1293100E-08,& + & .7150700E-10,.1887000E-07,.2733200E-07,.3130900E-07,.7443600E-09,& + & .6723500E-10,.2051200E-07,.3018900E-07,.3540700E-07,.8229400E-09,& + & .6344400E-10,.2225900E-07,.3321800E-07,.3973000E-07,.9048300E-09,& + & .6005800E-10,.2392300E-07,.3640500E-07,.4397600E-07,.9890800E-09,& + & .5701500E-10,.2563400E-07,.3954800E-07,.4834600E-07,.1075000E-08,& + & .5758600E-10,.1577900E-07,.2295000E-07,.2641500E-07,.6225600E-09,& + & .5419900E-10,.1715300E-07,.2535400E-07,.2990400E-07,.6873400E-09,& + & .5118800E-10,.1856900E-07,.2786900E-07,.3340400E-07,.7546700E-09,& + & .4849300E-10,.1993500E-07,.3043700E-07,.3685600E-07,.8236900E-09,& + & .4606900E-10,.2134500E-07,.3298800E-07,.4047800E-07,.8940200E-09/ + + data absb(526:700, 1) / & + & .4648700E-10,.1316100E-07,.1921600E-07,.2221200E-07,.5191000E-09,& + & .4378900E-10,.1430100E-07,.2118200E-07,.2509000E-07,.5724700E-09,& + & .4138600E-10,.1544700E-07,.2320800E-07,.2793800E-07,.6276700E-09,& + & .3923400E-10,.1657100E-07,.2534700E-07,.3079500E-07,.6842600E-09,& + & .3729400E-10,.1772500E-07,.2739200E-07,.3378100E-07,.7417900E-09,& + & .3775600E-10,.1089000E-07,.1588200E-07,.1844100E-07,.4287100E-09,& + & .3558100E-10,.1183000E-07,.1751400E-07,.2081000E-07,.4725100E-09,& + & .3364300E-10,.1275700E-07,.1918400E-07,.2314800E-07,.5176900E-09,& + & .3190500E-10,.1368200E-07,.2094100E-07,.2547700E-07,.5639400E-09,& + & .3033800E-10,.1462800E-07,.2261300E-07,.2794800E-07,.6110000E-09,& + & .3087200E-10,.8929000E-08,.1300700E-07,.1510800E-07,.3503400E-09,& + & .2909600E-10,.9699500E-08,.1434300E-07,.1705100E-07,.3860900E-09,& + & .2751300E-10,.1045600E-07,.1571300E-07,.1896800E-07,.4229600E-09,& + & .2609300E-10,.1121300E-07,.1715300E-07,.2087500E-07,.4607300E-09,& + & .2481200E-10,.1198700E-07,.1852200E-07,.2289900E-07,.4991600E-09,& + & .2547900E-10,.7233800E-08,.1050800E-07,.1216500E-07,.2826800E-09,& + & .2400200E-10,.7859300E-08,.1159400E-07,.1374700E-07,.3117300E-09,& + & .2268700E-10,.8484500E-08,.1271200E-07,.1531500E-07,.3417800E-09,& + & .2150800E-10,.9099700E-08,.1389200E-07,.1688600E-07,.3726000E-09,& + & .2044600E-10,.9732200E-08,.1501200E-07,.1852600E-07,.4039800E-09,& + & .2104100E-10,.5856500E-08,.8483100E-08,.9789200E-08,.2279100E-09,& + & .1981100E-10,.6363600E-08,.9361900E-08,.1107200E-07,.2514800E-09,& + & .1871700E-10,.6878400E-08,.1027600E-07,.1236000E-07,.2759500E-09,& + & .1773800E-10,.7379200E-08,.1123400E-07,.1363800E-07,.3010900E-09,& + & .1685600E-10,.7897100E-08,.1216600E-07,.1497700E-07,.3267100E-09,& + & .1737700E-10,.4741800E-08,.6856100E-08,.7879500E-08,.1837300E-09,& + & .1635300E-10,.5153200E-08,.7562000E-08,.8912800E-08,.2028400E-09,& + & .1544300E-10,.5575200E-08,.8306900E-08,.9966600E-08,.2227900E-09,& + & .1462900E-10,.5985700E-08,.9087200E-08,.1101100E-07,.2432700E-09,& + & .1389600E-10,.6408600E-08,.9861600E-08,.1210400E-07,.2642000E-09,& + & .1444500E-10,.3809100E-08,.5479900E-08,.6275400E-08,.1467900E-09,& + & .1358100E-10,.4139100E-08,.6053000E-08,.7090900E-08,.1622000E-09,& + & .1281500E-10,.4488800E-08,.6655500E-08,.7953200E-08,.1784200E-09,& + & .1213100E-10,.4820700E-08,.7285500E-08,.8807100E-08,.1950900E-09,& + & .1151600E-10,.5164600E-08,.7926800E-08,.9693200E-08,.2121400E-09/ + + data absb(701:875, 1) / & + & .1202100E-10,.3056600E-08,.4360600E-08,.4992100E-08,.1171300E-09,& + & .1129100E-10,.3320500E-08,.4834000E-08,.5625600E-08,.1295400E-09,& + & .1064500E-10,.3605300E-08,.5326100E-08,.6347300E-08,.1426900E-09,& + & .1006900E-10,.3878200E-08,.5834700E-08,.7038600E-08,.1562400E-09,& + & .9552000E-11,.4158000E-08,.6364700E-08,.7751500E-08,.1701300E-09,& + & .1000700E-10,.2451600E-08,.3465300E-08,.3939800E-08,.9347500E-10,& + & .9390200E-11,.2663100E-08,.3858800E-08,.4463500E-08,.1034200E-09,& + & .8844900E-11,.2892600E-08,.4260000E-08,.5046600E-08,.1140600E-09,& + & .8359400E-11,.3119800E-08,.4671900E-08,.5621800E-08,.1250700E-09,& + & .7924400E-11,.3346500E-08,.5106500E-08,.6199900E-08,.1364000E-09,& + & .8364700E-11,.1957800E-08,.2734100E-08,.3082700E-08,.7427700E-10,& + & .7838900E-11,.2126300E-08,.3069000E-08,.3521200E-08,.8211800E-10,& + & .7375200E-11,.2310300E-08,.3386500E-08,.3983600E-08,.9067200E-10,& + & .6963300E-11,.2498400E-08,.3719800E-08,.4456900E-08,.9962800E-10,& + & .6595000E-11,.2683300E-08,.4070900E-08,.4926500E-08,.1088300E-09,& + & .7007000E-11,.1562800E-08,.2152100E-08,.2401700E-08,.5911600E-10,& + & .6557000E-11,.1695400E-08,.2425400E-08,.2777200E-08,.6502700E-10,& + & .6161200E-11,.1841300E-08,.2684500E-08,.3131000E-08,.7189200E-10,& + & .5810600E-11,.1997700E-08,.2954200E-08,.3521100E-08,.7914400E-10,& + & .5497600E-11,.2146400E-08,.3236000E-08,.3904500E-08,.8662900E-10,& + & .5872800E-11,.1250000E-08,.1707900E-08,.1874300E-08,.4664600E-10,& + & .5487300E-11,.1350500E-08,.1910500E-08,.2171900E-08,.5149900E-10,& + & .5149200E-11,.1467000E-08,.2125000E-08,.2459000E-08,.5698200E-10,& + & .4850400E-11,.1593100E-08,.2346400E-08,.2780200E-08,.6283900E-10,& + & .4584400E-11,.1716700E-08,.2573100E-08,.3095400E-08,.6890800E-10,& + & .4932800E-11,.9981100E-09,.1339700E-08,.1445700E-08,.3669400E-10,& + & .4601200E-11,.1074200E-08,.1498600E-08,.1687500E-08,.4074200E-10,& + & .4311300E-11,.1166500E-08,.1681300E-08,.1928100E-08,.4504900E-10,& + & .4055800E-11,.1267300E-08,.1856700E-08,.2181700E-08,.4975100E-10,& + & .3828800E-11,.1370200E-08,.2039900E-08,.2441900E-08,.5467900E-10,& + & .4159200E-11,.7920500E-09,.1043800E-08,.1105500E-08,.2870900E-10,& + & .3871700E-11,.8535700E-09,.1171000E-08,.1301500E-08,.3219800E-10,& + & .3621500E-11,.9251500E-09,.1319600E-08,.1510300E-08,.3544800E-10,& + & .3401600E-11,.1004600E-08,.1461900E-08,.1701000E-08,.3920300E-10,& + & .3206900E-11,.1090400E-08,.1610000E-08,.1916800E-08,.4318700E-10/ + + data absb(876:1050, 1) / & + & .3510000E-11,.6284900E-09,.8131900E-09,.8456700E-09,.2245600E-10,& + & .3260500E-11,.6802100E-09,.9216900E-09,.1004000E-08,.2522900E-10,& + & .3044100E-11,.7329400E-09,.1031400E-08,.1166500E-08,.2790300E-10,& + & .2854700E-11,.7961500E-09,.1149500E-08,.1325100E-08,.3087900E-10,& + & .2687400E-11,.8646300E-09,.1270300E-08,.1499400E-08,.3408200E-10,& + & .2964900E-11,.4986700E-09,.6357200E-09,.6455700E-09,.1755400E-10,& + & .2748000E-11,.5412400E-09,.7187100E-09,.7684000E-09,.1974900E-10,& + & .2560600E-11,.5814000E-09,.8041300E-09,.9005400E-09,.2201200E-10,& + & .2397200E-11,.6309700E-09,.9063700E-09,.1034900E-08,.2430800E-10,& + & .2253400E-11,.6854500E-09,.1000600E-08,.1170400E-08,.2687200E-10,& + & .2501900E-11,.3985300E-09,.4937400E-09,.4961500E-09,.1376200E-10,& + & .2313600E-11,.4295200E-09,.5614100E-09,.5898000E-09,.1550000E-10,& + & .2151700E-11,.4633400E-09,.6328400E-09,.6978800E-09,.1739000E-10,& + & .2011000E-11,.5013000E-09,.7112400E-09,.8090300E-09,.1918400E-10,& + & .1887500E-11,.5444600E-09,.7890800E-09,.9143500E-09,.2123000E-10,& + & .2111100E-11,.3153400E-09,.3855200E-09,.3832400E-09,.1085100E-10,& + & .1947800E-11,.3417900E-09,.4398600E-09,.4535500E-09,.1217600E-10,& + & .1807900E-11,.3701600E-09,.4983500E-09,.5391900E-09,.1368300E-10,& + & .1686800E-11,.3984600E-09,.5574600E-09,.6280500E-09,.1516400E-10,& + & .1580900E-11,.4327200E-09,.6231000E-09,.7158700E-09,.1678500E-10,& + & .1783000E-11,.2493900E-09,.3003300E-09,.2970800E-09,.8548000E-11,& + & .1641000E-11,.2724400E-09,.3446700E-09,.3487000E-09,.9564200E-11,& + & .1520000E-11,.2950700E-09,.3902000E-09,.4150500E-09,.1076400E-10,& + & .1415600E-11,.3173600E-09,.4369300E-09,.4875800E-09,.1201600E-10,& + & .1324600E-11,.3440900E-09,.4924300E-09,.5618100E-09,.1326700E-10,& + & .1507400E-11,.1974600E-09,.2344200E-09,.2302700E-09,.6694200E-11,& + & .1383800E-11,.2175400E-09,.2681200E-09,.2686500E-09,.7509500E-11,& + & .1278900E-11,.2344500E-09,.3051000E-09,.3191600E-09,.8462600E-11,& + & .1188800E-11,.2530500E-09,.3449600E-09,.3790600E-09,.9496300E-11,& + & .1110600E-11,.2735500E-09,.3868000E-09,.4388200E-09,.1048600E-10,& + & .1272200E-11,.1567600E-09,.1843600E-09,.1818800E-09,.5260100E-11,& + & .1164900E-11,.1725600E-09,.2103000E-09,.2087600E-09,.5946500E-11,& + & .1074300E-11,.1870600E-09,.2402200E-09,.2465700E-09,.6675000E-11,& + & .9968300E-12,.2026300E-09,.2720600E-09,.2933700E-09,.7501600E-11,& + & .9297500E-12,.2179800E-09,.3042000E-09,.3420300E-09,.8318200E-11/ + + data absb(1051:1175, 1) / & + & .1073300E-11,.1255200E-09,.1466800E-09,.1447700E-09,.4144000E-11,& + & .9802700E-12,.1370500E-09,.1648000E-09,.1629800E-09,.4713700E-11,& + & .9020900E-12,.1496600E-09,.1891100E-09,.1911700E-09,.5273000E-11,& + & .8354600E-12,.1621000E-09,.2141000E-09,.2275800E-09,.5934900E-11,& + & .7780000E-12,.1742300E-09,.2397200E-09,.2672500E-09,.6616300E-11,& + & .9062400E-12,.9978600E-10,.1167400E-09,.1128600E-09,.3277600E-11,& + & .8254700E-12,.1089700E-09,.1293800E-09,.1270500E-09,.3716100E-11,& + & .7579100E-12,.1200900E-09,.1480400E-09,.1482700E-09,.4164600E-11,& + & .7005800E-12,.1292500E-09,.1683700E-09,.1763000E-09,.4695700E-11,& + & .6513100E-12,.1393700E-09,.1899900E-09,.2089900E-09,.5274200E-11,& + & .7659500E-12,.7882200E-10,.9386300E-10,.8752900E-10,.2603300E-11,& + & .6956800E-12,.8655500E-10,.1019000E-09,.1002200E-09,.2928800E-11,& + & .6372100E-12,.9538500E-10,.1164000E-09,.1153300E-09,.3299400E-11,& + & .5878200E-12,.1032500E-09,.1326400E-09,.1366300E-09,.3718600E-11,& + & .5455200E-12,.1117300E-09,.1504200E-09,.1625300E-09,.4181900E-11,& + & .6469300E-12,.6242100E-10,.7617400E-10,.6832400E-10,.2083300E-11,& + & .5858800E-12,.6927800E-10,.8119700E-10,.7969100E-10,.2313000E-11,& + & .5353500E-12,.7587300E-10,.9141400E-10,.9039800E-10,.2635000E-11,& + & .4928500E-12,.8265300E-10,.1049300E-09,.1061700E-09,.2947300E-11,& + & .4566000E-12,.8964300E-10,.1186100E-09,.1264700E-09,.3323100E-11,& + & .5364500E-12,.5055700E-10,.6224000E-10,.5485400E-10,.1693000E-11,& + & .4852300E-12,.5646800E-10,.6560400E-10,.6482700E-10,.1870200E-11,& + & .4429400E-12,.6144200E-10,.7366700E-10,.7268800E-10,.2129200E-11,& + & .4074400E-12,.6718400E-10,.8449000E-10,.8521700E-10,.2383200E-11,& + & .3772000E-12,.7265700E-10,.9569200E-10,.1014400E-09,.2685200E-11/ + + data absb( 1:175, 2) / & + & .1832300E-07,.8626600E-05,.1372800E-04,.1595200E-04,.7892700E-06,& + & .1696100E-07,.9620300E-05,.1527500E-04,.1786300E-04,.9365900E-06,& + & .1578700E-07,.1067500E-04,.1692400E-04,.1967500E-04,.1105000E-05,& + & .1476400E-07,.1177900E-04,.1847400E-04,.2132000E-04,.1286800E-05,& + & .1386500E-07,.1284300E-04,.2002900E-04,.2308000E-04,.1456500E-05,& + & .1489300E-07,.7188200E-05,.1144300E-04,.1327100E-04,.6583500E-06,& + & .1379300E-07,.8027600E-05,.1273200E-04,.1489000E-04,.7813200E-06,& + & .1284400E-07,.8918900E-05,.1410100E-04,.1633900E-04,.9223300E-06,& + & .1201700E-07,.9830900E-05,.1538400E-04,.1772100E-04,.1067600E-05,& + & .1128900E-07,.1070400E-04,.1667900E-04,.1919400E-04,.1209100E-05,& + & .1209600E-07,.5993400E-05,.9544900E-05,.1105800E-04,.5496900E-06,& + & .1120900E-07,.6693200E-05,.1062300E-04,.1240700E-04,.6519700E-06,& + & .1044300E-07,.7444900E-05,.1174600E-04,.1357100E-04,.7694000E-06,& + & .9774700E-08,.8194800E-05,.1281400E-04,.1473200E-04,.8849600E-06,& + & .9186400E-08,.8918800E-05,.1388300E-04,.1594600E-04,.1002300E-05,& + & .9820500E-08,.5002700E-05,.7964400E-05,.9224800E-05,.4587600E-06,& + & .9106100E-08,.5584600E-05,.8859300E-05,.1033100E-04,.5433400E-06,& + & .8488200E-08,.6218300E-05,.9775700E-05,.1127900E-04,.6405000E-06,& + & .7948600E-08,.6827600E-05,.1066400E-04,.1224400E-04,.7334400E-06,& + & .7473200E-08,.7426800E-05,.1154500E-04,.1322400E-04,.8295500E-06,& + & .7975300E-08,.4171300E-05,.6615300E-05,.7689200E-05,.3824700E-06,& + & .7399400E-08,.4656200E-05,.7375300E-05,.8592200E-05,.4518800E-06,& + & .6900800E-08,.5182900E-05,.8128000E-05,.9363800E-05,.5321100E-06,& + & .6465000E-08,.5676500E-05,.8856000E-05,.1016800E-04,.6064700E-06,& + & .6080700E-08,.6175800E-05,.9589400E-05,.1094900E-04,.6854900E-06,& + & .6477900E-08,.3472700E-05,.5487500E-05,.6400000E-05,.3185100E-06,& + & .6013500E-08,.3875100E-05,.6130800E-05,.7137200E-05,.3755200E-06,& + & .5611100E-08,.4313200E-05,.6747800E-05,.7769800E-05,.4414100E-06,& + & .5259000E-08,.4715000E-05,.7344400E-05,.8437000E-05,.5007500E-06,& + & .4948300E-08,.5134500E-05,.7949500E-05,.9063700E-05,.5660100E-06,& + & .5262700E-08,.2890800E-05,.4558600E-05,.5326000E-05,.2651600E-06,& + & .4888200E-08,.3226000E-05,.5094000E-05,.5920000E-05,.3119000E-06,& + & .4563200E-08,.3584300E-05,.5599200E-05,.6439700E-05,.3660800E-06,& + & .4278600E-08,.3916700E-05,.6092300E-05,.6997200E-05,.4136100E-06,& + & .4027300E-08,.4266700E-05,.6590400E-05,.7502100E-05,.4674100E-06/ + + data absb(176:350, 2) / & + & .4270400E-08,.2407400E-05,.3799000E-05,.4445800E-05,.2210300E-06,& + & .3969000E-08,.2694200E-05,.4239300E-05,.4912000E-05,.2601400E-06,& + & .3707100E-08,.2982700E-05,.4657400E-05,.5348700E-05,.3041600E-06,& + & .3477600E-08,.3260100E-05,.5063500E-05,.5807600E-05,.3430400E-06,& + & .3274700E-08,.3551800E-05,.5470000E-05,.6219700E-05,.3875200E-06,& + & .3464900E-08,.2009600E-05,.3168900E-05,.3707000E-05,.1842400E-06,& + & .3222400E-08,.2250300E-05,.3527100E-05,.4078400E-05,.2170500E-06,& + & .3011400E-08,.2483400E-05,.3873700E-05,.4443600E-05,.2522900E-06,& + & .2826300E-08,.2714900E-05,.4208300E-05,.4806100E-05,.2846400E-06,& + & .2662600E-08,.2955600E-05,.4539400E-05,.5156500E-05,.3214800E-06,& + & .2797600E-08,.1691300E-05,.2663200E-05,.3110800E-05,.1553700E-06,& + & .2604300E-08,.1890800E-05,.2955300E-05,.3406700E-05,.1831100E-06,& + & .2435900E-08,.2081100E-05,.3239000E-05,.3711000E-05,.2109400E-06,& + & .2287800E-08,.2274600E-05,.3514400E-05,.4000900E-05,.2381600E-06,& + & .2156700E-08,.2471400E-05,.3783900E-05,.4291000E-05,.2688600E-06,& + & .2258300E-08,.1423400E-05,.2238800E-05,.2608800E-05,.1314300E-06,& + & .2104300E-08,.1586400E-05,.2477600E-05,.2849300E-05,.1546000E-06,& + & .1969900E-08,.1743600E-05,.2707200E-05,.3100900E-05,.1766900E-06,& + & .1851500E-08,.1905700E-05,.2935500E-05,.3330800E-05,.1995300E-06,& + & .1746500E-08,.2065300E-05,.3154200E-05,.3566300E-05,.2250100E-06,& + & .1822100E-08,.1200100E-05,.1880800E-05,.2186800E-05,.1113800E-06,& + & .1699500E-08,.1331500E-05,.2077900E-05,.2382500E-05,.1306800E-06,& + & .1592300E-08,.1462500E-05,.2264700E-05,.2588400E-05,.1482000E-06,& + & .1497800E-08,.1597200E-05,.2451200E-05,.2777100E-05,.1673400E-06,& + & .1413800E-08,.1725400E-05,.2629600E-05,.2964900E-05,.1884800E-06,& + & .1469300E-08,.1011100E-05,.1580900E-05,.1828600E-05,.9436600E-07,& + & .1371800E-08,.1119900E-05,.1743000E-05,.1995200E-05,.1104500E-06,& + & .1286400E-08,.1227300E-05,.1895700E-05,.2157200E-05,.1244500E-06,& + & .1211000E-08,.1337300E-05,.2046200E-05,.2316200E-05,.1404200E-06,& + & .1143800E-08,.1441000E-05,.2191600E-05,.2464800E-05,.1576700E-06,& + & .1183400E-08,.8533100E-06,.1331600E-05,.1532900E-05,.8021200E-07,& + & .1106100E-08,.9419200E-06,.1462600E-05,.1672900E-05,.9277500E-07,& + & .1038200E-08,.1031700E-05,.1589000E-05,.1800600E-05,.1046200E-06,& + & .9781000E-09,.1120500E-05,.1709900E-05,.1931400E-05,.1180000E-06,& + & .9245700E-09,.1203400E-05,.1827600E-05,.2050400E-05,.1320900E-06/ + + data absb(351:525, 2) / & + & .9531100E-09,.7189000E-06,.1121800E-05,.1286700E-05,.6808400E-07,& + & .8917700E-09,.7925800E-06,.1227500E-05,.1401900E-05,.7799900E-07,& + & .8378100E-09,.8660500E-06,.1330800E-05,.1504000E-05,.8802700E-07,& + & .7899800E-09,.9381500E-06,.1428500E-05,.1609100E-05,.9905700E-07,& + & .7472900E-09,.1004600E-05,.1523600E-05,.1705900E-05,.1107400E-06,& + & .7677100E-09,.6062300E-06,.9442700E-06,.1079600E-05,.5784400E-07,& + & .7190400E-09,.6665300E-06,.1029800E-05,.1169900E-05,.6572600E-07,& + & .6761400E-09,.7268900E-06,.1113100E-05,.1256800E-05,.7400900E-07,& + & .6380600E-09,.7848200E-06,.1192700E-05,.1340600E-05,.8320000E-07,& + & .6040100E-09,.8380600E-06,.1269500E-05,.1418600E-05,.9230600E-07,& + & .6181700E-09,.5105300E-06,.7945000E-06,.9068700E-06,.4907800E-07,& + & .5795800E-09,.5607100E-06,.8640300E-06,.9769000E-06,.5525700E-07,& + & .5455100E-09,.6100900E-06,.9307700E-06,.1049500E-05,.6228600E-07,& + & .5152000E-09,.6563100E-06,.9956700E-06,.1115900E-05,.6995400E-07,& + & .4880600E-09,.6983000E-06,.1057600E-05,.1179000E-05,.7722800E-07,& + & .4978300E-09,.4301400E-06,.6673200E-06,.7605800E-06,.4130600E-07,& + & .4672300E-09,.4714800E-06,.7243400E-06,.8168200E-06,.4653700E-07,& + & .4401500E-09,.5114600E-06,.7780900E-06,.8753700E-06,.5245100E-07,& + & .4160300E-09,.5487700E-06,.8307300E-06,.9288400E-06,.5879300E-07,& + & .3944000E-09,.5815900E-06,.8805400E-06,.9803000E-06,.6463000E-07,& + & .4008700E-09,.3625600E-06,.5606200E-06,.6354900E-06,.3477800E-07,& + & .3766000E-09,.3962000E-06,.6067400E-06,.6831300E-06,.3921300E-07,& + & .3551000E-09,.4285500E-06,.6503700E-06,.7299900E-06,.4417600E-07,& + & .3359000E-09,.4585200E-06,.6930800E-06,.7733800E-06,.4942400E-07,& + & .3186600E-09,.4845900E-06,.7329700E-06,.8148400E-06,.5413700E-07,& + & .3228000E-09,.3054700E-06,.4708300E-06,.5314700E-06,.2935300E-07,& + & .3035600E-09,.3327100E-06,.5077000E-06,.5711200E-06,.3307800E-07,& + & .2864700E-09,.3587600E-06,.5433900E-06,.6085200E-06,.3721100E-07,& + & .2712000E-09,.3821400E-06,.5778100E-06,.6435400E-06,.4129500E-07,& + & .2574600E-09,.4037400E-06,.6099000E-06,.6771100E-06,.4536200E-07,& + & .2599700E-09,.2572300E-06,.3950500E-06,.4446700E-06,.2475400E-07,& + & .2447100E-09,.2792600E-06,.4246900E-06,.4770200E-06,.2790700E-07,& + & .2311300E-09,.3002400E-06,.4538400E-06,.5067200E-06,.3134400E-07,& + & .2189800E-09,.3186200E-06,.4814200E-06,.5351500E-06,.3459000E-07,& + & .2080300E-09,.3362400E-06,.5072100E-06,.5624200E-06,.3795700E-07/ + + data absb(526:700, 2) / & + & .2098700E-09,.2156100E-06,.3303500E-06,.3709300E-06,.2080100E-07,& + & .1977100E-09,.2335600E-06,.3543300E-06,.3972300E-06,.2344300E-07,& + & .1868800E-09,.2504200E-06,.3780400E-06,.4212700E-06,.2627100E-07,& + & .1771600E-09,.2651400E-06,.4002900E-06,.4443300E-06,.2886700E-07,& + & .1684000E-09,.2794900E-06,.4210200E-06,.4661200E-06,.3162000E-07,& + & .1704600E-09,.1790900E-06,.2739700E-06,.3073000E-06,.1728300E-07,& + & .1606600E-09,.1937800E-06,.2936700E-06,.3286900E-06,.1945600E-07,& + & .1519100E-09,.2071600E-06,.3128700E-06,.3482000E-06,.2175900E-07,& + & .1440700E-09,.2193800E-06,.3309000E-06,.3670300E-06,.2385400E-07,& + & .1369900E-09,.2311500E-06,.3477900E-06,.3845900E-06,.2612800E-07,& + & .1393800E-09,.1474200E-06,.2253500E-06,.2526100E-06,.1414500E-07,& + & .1313700E-09,.1594900E-06,.2415500E-06,.2701100E-06,.1591700E-07,& + & .1242300E-09,.1703700E-06,.2572100E-06,.2860600E-06,.1780900E-07,& + & .1178200E-09,.1804400E-06,.2720000E-06,.3014900E-06,.1953000E-07,& + & .1120400E-09,.1901100E-06,.2858200E-06,.3158100E-06,.2139100E-07,& + & .1150300E-09,.1199100E-06,.1833900E-06,.2054000E-06,.1139800E-07,& + & .1083700E-09,.1298500E-06,.1967000E-06,.2199100E-06,.1282900E-07,& + & .1024400E-09,.1389500E-06,.2096400E-06,.2331000E-06,.1437000E-07,& + & .9712200E-10,.1472500E-06,.2218300E-06,.2458200E-06,.1579000E-07,& + & .9232500E-10,.1552600E-06,.2332700E-06,.2576700E-06,.1730800E-07,& + & .9499000E-10,.9743400E-07,.1491200E-06,.1669900E-06,.9174500E-08,& + & .8944900E-10,.1056300E-06,.1600700E-06,.1789000E-06,.1033000E-07,& + & .8451600E-10,.1132200E-06,.1707100E-06,.1898200E-06,.1158500E-07,& + & .8009600E-10,.1200900E-06,.1808400E-06,.2003000E-06,.1275900E-07,& + & .7611300E-10,.1267200E-06,.1902800E-06,.2101200E-06,.1399200E-07,& + & .7844400E-10,.7914700E-07,.1212200E-06,.1357300E-06,.7384600E-08,& + & .7383200E-10,.8590100E-07,.1302200E-06,.1455200E-06,.8318000E-08,& + & .6972900E-10,.9223000E-07,.1389900E-06,.1545900E-06,.9337400E-08,& + & .6605600E-10,.9791900E-07,.1473700E-06,.1632500E-06,.1030700E-07,& + & .6274900E-10,.1034100E-06,.1551800E-06,.1713300E-06,.1131200E-07,& + & .6520700E-10,.6371500E-07,.9775500E-07,.1094500E-06,.5883100E-08,& + & .6131900E-10,.6928900E-07,.1052400E-06,.1175700E-06,.6623700E-08,& + & .5786600E-10,.7469400E-07,.1124500E-06,.1251500E-06,.7445500E-08,& + & .5477900E-10,.7935900E-07,.1194100E-06,.1322900E-06,.8259500E-08,& + & .5200300E-10,.8395700E-07,.1259300E-06,.1390900E-06,.9069800E-08/ + + data absb(701:875, 2) / & + & .5426300E-10,.5117200E-07,.7871400E-07,.8818300E-07,.4674000E-08,& + & .5097800E-10,.5583800E-07,.8493900E-07,.9482800E-07,.5265500E-08,& + & .4806600E-10,.6032800E-07,.9085900E-07,.1011800E-06,.5927300E-08,& + & .4546700E-10,.6426000E-07,.9666700E-07,.1071000E-06,.6627900E-08,& + & .4313400E-10,.6808900E-07,.1020800E-06,.1127900E-06,.7256000E-08,& + & .4517000E-10,.4107300E-07,.6333300E-07,.7106700E-07,.3718500E-08,& + & .4239300E-10,.4496400E-07,.6850700E-07,.7645500E-07,.4186400E-08,& + & .3993600E-10,.4866700E-07,.7338200E-07,.8177200E-07,.4715700E-08,& + & .3774700E-10,.5199600E-07,.7822000E-07,.8668900E-07,.5283400E-08,& + & .3578400E-10,.5517800E-07,.8273900E-07,.9143400E-07,.5804000E-08,& + & .3775400E-10,.3277000E-07,.5066200E-07,.5697900E-07,.2940500E-08,& + & .3538700E-10,.3599700E-07,.5499300E-07,.6135700E-07,.3306600E-08,& + & .3329900E-10,.3907300E-07,.5903600E-07,.6579300E-07,.3726500E-08,& + & .3144200E-10,.4190300E-07,.6301400E-07,.6992000E-07,.4184800E-08,& + & .2978100E-10,.4454600E-07,.6682200E-07,.7384900E-07,.4620400E-08,& + & .3162300E-10,.2605400E-07,.4040500E-07,.4569200E-07,.2291800E-08,& + & .2959900E-10,.2871300E-07,.4401000E-07,.4912200E-07,.2605300E-08,& + & .2781700E-10,.3129600E-07,.4739100E-07,.5281500E-07,.2935300E-08,& + & .2623600E-10,.3367700E-07,.5065500E-07,.5626400E-07,.3302300E-08,& + & .2482500E-10,.3589600E-07,.5386300E-07,.5953800E-07,.3673000E-08,& + & .2650200E-10,.2070500E-07,.3215200E-07,.3644800E-07,.1784100E-08,& + & .2476800E-10,.2286800E-07,.3518500E-07,.3932900E-07,.2051500E-08,& + & .2324700E-10,.2502700E-07,.3799900E-07,.4233800E-07,.2311800E-08,& + & .2190000E-10,.2706300E-07,.4069400E-07,.4525800E-07,.2604800E-08,& + & .2070100E-10,.2890100E-07,.4336100E-07,.4796900E-07,.2917400E-08,& + & .2225800E-10,.1642200E-07,.2548000E-07,.2899100E-07,.1383000E-08,& + & .2076700E-10,.1815800E-07,.2803300E-07,.3144200E-07,.1614400E-08,& + & .1946200E-10,.1995300E-07,.3040200E-07,.3385000E-07,.1816200E-08,& + & .1831200E-10,.2165800E-07,.3263900E-07,.3630800E-07,.2047500E-08,& + & .1728900E-10,.2321100E-07,.3483900E-07,.3858300E-07,.2299400E-08,& + & .1876400E-10,.1295100E-07,.2007200E-07,.2298200E-07,.1064500E-08,& + & .1747300E-10,.1433500E-07,.2221400E-07,.2508500E-07,.1247900E-08,& + & .1634700E-10,.1581300E-07,.2420500E-07,.2697100E-07,.1420700E-08,& + & .1535700E-10,.1725500E-07,.2607500E-07,.2901500E-07,.1600800E-08,& + & .1448000E-10,.1855800E-07,.2788500E-07,.3092200E-07,.1801800E-08/ + + data absb(876:1050, 2) / & + & .1583300E-10,.1018600E-07,.1578200E-07,.1817400E-07,.8171800E-09,& + & .1471300E-10,.1131200E-07,.1755500E-07,.1989100E-07,.9609800E-09,& + & .1374000E-10,.1250900E-07,.1924800E-07,.2148200E-07,.1111200E-08,& + & .1288700E-10,.1371900E-07,.2081100E-07,.2314000E-07,.1251500E-08,& + & .1213400E-10,.1484000E-07,.2231300E-07,.2476900E-07,.1410500E-08,& + & .1337200E-10,.8005000E-08,.1240300E-07,.1428300E-07,.6311700E-09,& + & .1239800E-10,.8939300E-08,.1384000E-07,.1575100E-07,.7390700E-09,& + & .1155600E-10,.9882100E-08,.1526100E-07,.1710400E-07,.8664500E-09,& + & .1082100E-10,.1088400E-07,.1658200E-07,.1844100E-07,.9782900E-09,& + & .1017400E-10,.1184100E-07,.1782800E-07,.1980400E-07,.1103400E-08,& + & .1128200E-10,.6272600E-08,.9747800E-08,.1122600E-07,.4839800E-09,& + & .1043700E-10,.7054600E-08,.1093200E-07,.1251800E-07,.5705100E-09,& + & .9710100E-11,.7819300E-08,.1211400E-07,.1367100E-07,.6699700E-09,& + & .9077200E-11,.8637900E-08,.1321800E-07,.1471200E-07,.7662500E-09,& + & .8521600E-11,.9440500E-08,.1425800E-07,.1584400E-07,.8648800E-09,& + & .9517900E-11,.4925100E-08,.7635600E-08,.8776100E-08,.3721300E-09,& + & .8785600E-11,.5568100E-08,.8622000E-08,.9915900E-08,.4407400E-09,& + & .8157600E-11,.6193000E-08,.9598900E-08,.1086500E-07,.5184300E-09,& + & .7613100E-11,.6851800E-08,.1053900E-07,.1174600E-07,.6021000E-09,& + & .7136600E-11,.7520600E-08,.1140300E-07,.1265900E-07,.6784100E-09,& + & .8036800E-11,.3860800E-08,.6001000E-08,.6844100E-08,.2884800E-09,& + & .7400700E-11,.4390300E-08,.6797400E-08,.7812700E-08,.3424500E-09,& + & .6857700E-11,.4908600E-08,.7595900E-08,.8627900E-08,.4010600E-09,& + & .6388600E-11,.5429700E-08,.8380100E-08,.9377800E-08,.4705800E-09,& + & .5979500E-11,.5982900E-08,.9110300E-08,.1011100E-07,.5321800E-09,& + & .6793200E-11,.3010200E-08,.4726900E-08,.5339500E-08,.2243200E-09,& + & .6239700E-11,.3445000E-08,.5345800E-08,.6144900E-08,.2628200E-09,& + & .5769300E-11,.3876800E-08,.6000600E-08,.6861300E-08,.3102000E-09,& + & .5364700E-11,.4300200E-08,.6653300E-08,.7499000E-08,.3644600E-09,& + & .5012900E-11,.4752700E-08,.7263800E-08,.8071700E-08,.4175900E-09,& + & .5732000E-11,.2358200E-08,.3683700E-08,.4131700E-08,.1747700E-09,& + & .5251800E-11,.2716300E-08,.4204800E-08,.4820800E-08,.2032100E-09,& + & .4845700E-11,.3067800E-08,.4747200E-08,.5447200E-08,.2408100E-09,& + & .4497800E-11,.3414800E-08,.5285100E-08,.5973500E-08,.2834500E-09,& + & .4196300E-11,.3780400E-08,.5800100E-08,.6457000E-08,.3292300E-09/ + + data absb(1051:1175, 2) / & + & .4834700E-11,.1853400E-08,.2853900E-08,.3182800E-08,.1349200E-09,& + & .4418600E-11,.2139200E-08,.3319000E-08,.3781700E-08,.1584800E-09,& + & .4068300E-11,.2432000E-08,.3759200E-08,.4315600E-08,.1883500E-09,& + & .3769300E-11,.2715000E-08,.4199900E-08,.4762500E-08,.2207600E-09,& + & .3511100E-11,.3008200E-08,.4634500E-08,.5173600E-08,.2591600E-09,& + & .4081300E-11,.1454300E-08,.2203800E-08,.2448800E-08,.1032800E-09,& + & .3720100E-11,.1681300E-08,.2637100E-08,.2964000E-08,.1244600E-09,& + & .3417500E-11,.1919100E-08,.2974700E-08,.3411500E-08,.1460400E-09,& + & .3160400E-11,.2157500E-08,.3334800E-08,.3801800E-08,.1720200E-09,& + & .2939100E-11,.2393200E-08,.3693000E-08,.4147200E-08,.2023500E-09,& + & .3448600E-11,.1148000E-08,.1703200E-08,.1877100E-08,.7878700E-10,& + & .3134500E-11,.1318900E-08,.2061500E-08,.2312100E-08,.9683200E-10,& + & .2872800E-11,.1514400E-08,.2344000E-08,.2686300E-08,.1131700E-09,& + & .2651300E-11,.1710200E-08,.2643600E-08,.3024600E-08,.1339300E-09,& + & .2461500E-11,.1902200E-08,.2939400E-08,.3313500E-08,.1577200E-09,& + & .2911900E-11,.8950000E-09,.1302000E-08,.1438300E-08,.6025300E-10,& + & .2639200E-11,.1036900E-08,.1603600E-08,.1789100E-08,.7576500E-10,& + & .2413200E-11,.1197500E-08,.1852300E-08,.2111400E-08,.8826000E-10,& + & .2222700E-11,.1357000E-08,.2095900E-08,.2404500E-08,.1047800E-09,& + & .2060100E-11,.1513900E-08,.2340600E-08,.2645600E-08,.1233100E-09,& + & .2414300E-11,.7185100E-09,.1036200E-08,.1151600E-08,.4808600E-10,& + & .2185700E-11,.8373200E-09,.1289200E-08,.1433500E-08,.6063000E-10,& + & .1996500E-11,.9681500E-09,.1499000E-08,.1703900E-08,.7120800E-10,& + & .1837400E-11,.1098200E-08,.1697300E-08,.1945500E-08,.8451400E-10,& + & .1701700E-11,.1227700E-08,.1898100E-08,.2147200E-08,.9928900E-10/ + + data absb( 1:175, 3) / & + & .6949700E-07,.5590000E-04,.7763400E-04,.8330000E-04,.1441900E-04,& + & .6492300E-07,.6177900E-04,.8523800E-04,.9045800E-04,.1599600E-04,& + & .6092000E-07,.6753200E-04,.9281100E-04,.9758800E-04,.1762200E-04,& + & .5737900E-07,.7287600E-04,.1004000E-03,.1045500E-03,.1914400E-04,& + & .5422000E-07,.7769900E-04,.1078400E-03,.1113900E-03,.2067100E-04,& + & .5653800E-07,.4662700E-04,.6467800E-04,.6939900E-04,.1208600E-04,& + & .5283900E-07,.5153600E-04,.7108000E-04,.7529200E-04,.1341400E-04,& + & .4960000E-07,.5633400E-04,.7738400E-04,.8127700E-04,.1473200E-04,& + & .4673100E-07,.6075100E-04,.8375300E-04,.8706700E-04,.1597300E-04,& + & .4417100E-07,.6479200E-04,.8996300E-04,.9261700E-04,.1721400E-04,& + & .4596300E-07,.3892000E-04,.5392100E-04,.5782400E-04,.1008900E-04,& + & .4297600E-07,.4298700E-04,.5928600E-04,.6261500E-04,.1123800E-04,& + & .4035800E-07,.4701400E-04,.6455700E-04,.6765800E-04,.1229300E-04,& + & .3803700E-07,.5064100E-04,.6987900E-04,.7248700E-04,.1331700E-04,& + & .3596400E-07,.5400300E-04,.7506400E-04,.7708300E-04,.1432100E-04,& + & .3735400E-07,.3247900E-04,.4495300E-04,.4814600E-04,.8407900E-05,& + & .3494400E-07,.3587300E-04,.4945400E-04,.5212000E-04,.9340500E-05,& + & .3282900E-07,.3922000E-04,.5386100E-04,.5629300E-04,.1020900E-04,& + & .3095200E-07,.4215500E-04,.5830900E-04,.6026800E-04,.1108000E-04,& + & .2927400E-07,.4501400E-04,.6261000E-04,.6418400E-04,.1188700E-04,& + & .3036400E-07,.2708600E-04,.3745100E-04,.3999500E-04,.7004900E-05,& + & .2842000E-07,.2991900E-04,.4119400E-04,.4336700E-04,.7773600E-05,& + & .2671000E-07,.3265000E-04,.4490200E-04,.4681700E-04,.8483800E-05,& + & .2519200E-07,.3509800E-04,.4860500E-04,.5010300E-04,.9203800E-05,& + & .2383300E-07,.3750700E-04,.5218800E-04,.5341300E-04,.9860700E-05,& + & .2468700E-07,.2258100E-04,.3121100E-04,.3322000E-04,.5836100E-05,& + & .2311600E-07,.2494000E-04,.3430800E-04,.3607800E-04,.6464000E-05,& + & .2173400E-07,.2718100E-04,.3741400E-04,.3893300E-04,.7034400E-05,& + & .2050600E-07,.2921600E-04,.4051700E-04,.4165300E-04,.7627600E-05,& + & .1940600E-07,.3123700E-04,.4349000E-04,.4439700E-04,.8175300E-05,& + & .2007400E-07,.1881800E-04,.2599900E-04,.2759700E-04,.4866200E-05,& + & .1880500E-07,.2078400E-04,.2856200E-04,.2999300E-04,.5372300E-05,& + & .1768800E-07,.2262600E-04,.3115100E-04,.3236300E-04,.5837700E-05,& + & .1669300E-07,.2430000E-04,.3376000E-04,.3462900E-04,.6317700E-05,& + & .1580200E-07,.2598500E-04,.3622600E-04,.3690300E-04,.6774200E-05/ + + data absb(176:350, 3) / & + & .1630600E-07,.1571700E-04,.2168600E-04,.2295900E-04,.4068000E-05,& + & .1528300E-07,.1735500E-04,.2382600E-04,.2496900E-04,.4470600E-05,& + & .1438100E-07,.1885600E-04,.2599200E-04,.2691200E-04,.4855000E-05,& + & .1357800E-07,.2026500E-04,.2816200E-04,.2881700E-04,.5235500E-05,& + & .1285700E-07,.2163800E-04,.3021500E-04,.3070700E-04,.5622400E-05,& + & .1324500E-07,.1312800E-04,.1809100E-04,.1910700E-04,.3388000E-05,& + & .1242000E-07,.1449500E-04,.1988700E-04,.2079400E-04,.3714400E-05,& + & .1169200E-07,.1570400E-04,.2170300E-04,.2239700E-04,.4041500E-05,& + & .1104300E-07,.1690400E-04,.2348900E-04,.2398400E-04,.4345500E-05,& + & .1046000E-07,.1803700E-04,.2519700E-04,.2555800E-04,.4666200E-05,& + & .1071100E-07,.1104400E-04,.1519900E-04,.1600800E-04,.2840900E-05,& + & .1005200E-07,.1216500E-04,.1669900E-04,.1741900E-04,.3104100E-05,& + & .9469000E-08,.1315800E-04,.1822400E-04,.1873300E-04,.3376800E-05,& + & .8948400E-08,.1416600E-04,.1969100E-04,.2005000E-04,.3623700E-05,& + & .8480400E-08,.1508500E-04,.2110500E-04,.2135600E-04,.3887600E-05,& + & .8660600E-08,.9300200E-05,.1277500E-04,.1342000E-04,.2381500E-05,& + & .8134000E-08,.1021000E-04,.1403400E-04,.1455200E-04,.2595500E-05,& + & .7667100E-08,.1103500E-04,.1530200E-04,.1565700E-04,.2815000E-05,& + & .7249700E-08,.1186300E-04,.1651300E-04,.1677000E-04,.3019800E-05,& + & .6873900E-08,.1261600E-04,.1766400E-04,.1784800E-04,.3238700E-05,& + & .6999500E-08,.7839200E-05,.1075400E-04,.1125000E-04,.1998600E-05,& + & .6579000E-08,.8567400E-05,.1180600E-04,.1218600E-04,.2173800E-05,& + & .6205500E-08,.9266400E-05,.1285000E-04,.1310300E-04,.2346900E-05,& + & .5871000E-08,.9937600E-05,.1385400E-04,.1402700E-04,.2519500E-05,& + & .5569600E-08,.1052700E-04,.1479500E-04,.1491700E-04,.2698800E-05,& + & .5653800E-08,.6611800E-05,.9061000E-05,.9442200E-05,.1675300E-05,& + & .5318400E-08,.7198600E-05,.9938900E-05,.1020900E-04,.1822300E-05,& + & .5019900E-08,.7786300E-05,.1080000E-04,.1098100E-04,.1959000E-05,& + & .4752200E-08,.8341500E-05,.1162600E-04,.1173700E-04,.2102000E-05,& + & .4510500E-08,.8801700E-05,.1237300E-04,.1246800E-04,.2249800E-05,& + & .4562000E-08,.5574900E-05,.7646300E-05,.7928500E-05,.1403200E-05,& + & .4295000E-08,.6059000E-05,.8382200E-05,.8565200E-05,.1525500E-05,& + & .4056900E-08,.6551000E-05,.9088800E-05,.9211600E-05,.1637300E-05,& + & .3842900E-08,.6991800E-05,.9760400E-05,.9832900E-05,.1756100E-05,& + & .3649500E-08,.7356600E-05,.1036700E-04,.1042900E-04,.1876900E-05/ + + data absb(351:525, 3) / & + & .3680900E-08,.4696700E-05,.6458000E-05,.6664900E-05,.1178600E-05,& + & .3468300E-08,.5107200E-05,.7066100E-05,.7190200E-05,.1275900E-05,& + & .3278400E-08,.5505300E-05,.7647000E-05,.7725000E-05,.1369100E-05,& + & .3107400E-08,.5847400E-05,.8189800E-05,.8234000E-05,.1466600E-05,& + & .2952600E-08,.6149300E-05,.8681500E-05,.8719900E-05,.1565000E-05,& + & .2970100E-08,.3958200E-05,.5457300E-05,.5595900E-05,.9903700E-06,& + & .2800800E-08,.4304800E-05,.5954600E-05,.6040600E-05,.1065900E-05,& + & .2649300E-08,.4627700E-05,.6428600E-05,.6474500E-05,.1144200E-05,& + & .2512700E-08,.4894000E-05,.6861200E-05,.6891800E-05,.1225000E-05,& + & .2388800E-08,.5142800E-05,.7265400E-05,.7286500E-05,.1304600E-05,& + & .2395800E-08,.3340900E-05,.4611500E-05,.4705400E-05,.8302100E-06,& + & .2261100E-08,.3626700E-05,.5019200E-05,.5075400E-05,.8915700E-06,& + & .2140200E-08,.3880500E-05,.5405300E-05,.5429100E-05,.9566300E-06,& + & .2031100E-08,.4092900E-05,.5752900E-05,.5768500E-05,.1023200E-05,& + & .1932000E-08,.4301400E-05,.6068400E-05,.6086800E-05,.1087400E-05,& + & .1932800E-08,.2821700E-05,.3895500E-05,.3956200E-05,.6946400E-06,& + & .1825500E-08,.3051500E-05,.4229300E-05,.4260500E-05,.7458800E-06,& + & .1729100E-08,.3249600E-05,.4539000E-05,.4550100E-05,.7995700E-06,& + & .1641900E-08,.3423500E-05,.4819100E-05,.4824900E-05,.8537300E-06,& + & .1562600E-08,.3599200E-05,.5063200E-05,.5080500E-05,.9058200E-06,& + & .1559000E-08,.2384100E-05,.3289000E-05,.3328200E-05,.5810800E-06,& + & .1473600E-08,.2568300E-05,.3560500E-05,.3575600E-05,.6240100E-06,& + & .1396700E-08,.2722300E-05,.3805500E-05,.3811000E-05,.6686200E-06,& + & .1327100E-08,.2865200E-05,.4029500E-05,.4033100E-05,.7121600E-06,& + & .1263700E-08,.3006900E-05,.4225700E-05,.4239300E-05,.7552700E-06,& + & .1257500E-08,.2009900E-05,.2776400E-05,.2798800E-05,.4861400E-06,& + & .1189500E-08,.2155100E-05,.2996100E-05,.2999600E-05,.5219900E-06,& + & .1128200E-08,.2277100E-05,.3190100E-05,.3189700E-05,.5586700E-06,& + & .1072600E-08,.2396900E-05,.3365700E-05,.3369600E-05,.5941000E-06,& + & .1021800E-08,.2507600E-05,.3523200E-05,.3536600E-05,.6296500E-06,& + & .1014400E-08,.1694000E-05,.2342100E-05,.2351900E-05,.4070100E-06,& + & .9602400E-09,.1806600E-05,.2514600E-05,.2514800E-05,.4365700E-06,& + & .9113400E-09,.1905300E-05,.2673800E-05,.2669000E-05,.4665600E-06,& + & .8668900E-09,.2003800E-05,.2810400E-05,.2813900E-05,.4951600E-06,& + & .8263000E-09,.2086000E-05,.2929400E-05,.2948500E-05,.5246200E-06/ + + data absb(526:700, 3) / & + & .8200000E-09,.1423100E-05,.1966100E-05,.1970000E-05,.3399600E-06,& + & .7767200E-09,.1510500E-05,.2104700E-05,.2101800E-05,.3643500E-06,& + & .7375700E-09,.1590800E-05,.2230700E-05,.2227200E-05,.3885100E-06,& + & .7019300E-09,.1670600E-05,.2342100E-05,.2344800E-05,.4121900E-06,& + & .6693600E-09,.1733000E-05,.2434200E-05,.2453800E-05,.4360700E-06,& + & .6665200E-09,.1184200E-05,.1638300E-05,.1638200E-05,.2818300E-06,& + & .6315600E-09,.1254100E-05,.1749900E-05,.1745700E-05,.3019500E-06,& + & .5999000E-09,.1320900E-05,.1850400E-05,.1848400E-05,.3217400E-06,& + & .5710700E-09,.1385000E-05,.1941800E-05,.1943800E-05,.3412400E-06,& + & .5447000E-09,.1434800E-05,.2013500E-05,.2033500E-05,.3605000E-06,& + & .5450600E-09,.9787000E-06,.1354100E-05,.1352000E-05,.2319000E-06,& + & .5165000E-09,.1035400E-05,.1445500E-05,.1440400E-05,.2484500E-06,& + & .4906300E-09,.1091000E-05,.1527000E-05,.1524700E-05,.2646400E-06,& + & .4670700E-09,.1142700E-05,.1601200E-05,.1603300E-05,.2807200E-06,& + & .4455300E-09,.1183300E-05,.1660400E-05,.1677400E-05,.2964300E-06,& + & .4494900E-09,.8010400E-06,.1106600E-05,.1104500E-05,.1888800E-06,& + & .4257900E-09,.8481000E-06,.1182600E-05,.1177700E-05,.2024200E-06,& + & .4043500E-09,.8940400E-06,.1250400E-05,.1247700E-05,.2157800E-06,& + & .3848300E-09,.9373700E-06,.1312400E-05,.1312900E-05,.2289200E-06,& + & .3669900E-09,.9711800E-06,.1361700E-05,.1374400E-05,.2419000E-06,& + & .3708800E-09,.6546800E-06,.9034700E-06,.9014000E-06,.1537100E-06,& + & .3512000E-09,.6942100E-06,.9667600E-06,.9622200E-06,.1648400E-06,& + & .3334000E-09,.7321100E-06,.1023300E-05,.1020300E-05,.1757800E-06,& + & .3172100E-09,.7683800E-06,.1075000E-05,.1074500E-05,.1865600E-06,& + & .3024200E-09,.7967600E-06,.1116400E-05,.1125600E-05,.1973000E-06,& + & .3060300E-09,.5351800E-06,.7375500E-06,.7356000E-06,.1250900E-06,& + & .2896700E-09,.5682700E-06,.7901700E-06,.7860700E-06,.1342000E-06,& + & .2749000E-09,.5994600E-06,.8372900E-06,.8341800E-06,.1432000E-06,& + & .2614800E-09,.6296800E-06,.8804500E-06,.8791900E-06,.1520600E-06,& + & .2492200E-09,.6535800E-06,.9151100E-06,.9218700E-06,.1609200E-06,& + & .2540100E-09,.4349100E-06,.5970600E-06,.5958300E-06,.1010300E-06,& + & .2402700E-09,.4624300E-06,.6412700E-06,.6378000E-06,.1085400E-06,& + & .2278800E-09,.4878900E-06,.6811100E-06,.6778500E-06,.1159600E-06,& + & .2166400E-09,.5137000E-06,.7177600E-06,.7155700E-06,.1231800E-06,& + & .2063900E-09,.5341300E-06,.7473800E-06,.7511600E-06,.1305500E-06/ + + data absb(701:875, 3) / & + & .2110300E-09,.3516200E-06,.4824500E-06,.4818100E-06,.8155100E-07,& + & .1994700E-09,.3757700E-06,.5197500E-06,.5168300E-06,.8762400E-07,& + & .1890600E-09,.3968100E-06,.5537200E-06,.5501600E-06,.9377500E-07,& + & .1796300E-09,.4185600E-06,.5840500E-06,.5817700E-06,.9967700E-07,& + & .1710500E-09,.4361000E-06,.6095700E-06,.6115000E-06,.1057800E-06,& + & .1753600E-09,.2841200E-06,.3894800E-06,.3893300E-06,.6579100E-07,& + & .1656300E-09,.3050400E-06,.4209700E-06,.4185400E-06,.7075200E-07,& + & .1568800E-09,.3226500E-06,.4495700E-06,.4462400E-06,.7579000E-07,& + & .1489700E-09,.3408000E-06,.4750200E-06,.4726800E-06,.8064800E-07,& + & .1417800E-09,.3558400E-06,.4969600E-06,.4974700E-06,.8568500E-07,& + & .1462500E-09,.2282800E-06,.3126900E-06,.3130100E-06,.5285800E-07,& + & .1380000E-09,.2466000E-06,.3394500E-06,.3373600E-06,.5687200E-07,& + & .1306000E-09,.2615000E-06,.3638200E-06,.3605200E-06,.6100500E-07,& + & .1239200E-09,.2763700E-06,.3849600E-06,.3826200E-06,.6506400E-07,& + & .1178600E-09,.2896000E-06,.4043200E-06,.4034600E-06,.6913400E-07,& + & .1222000E-09,.1829900E-06,.2500300E-06,.2507500E-06,.4242600E-07,& + & .1151800E-09,.1985800E-06,.2727100E-06,.2712400E-06,.4560500E-07,& + & .1089000E-09,.2114900E-06,.2930600E-06,.2905900E-06,.4898900E-07,& + & .1032400E-09,.2236100E-06,.3112800E-06,.3090900E-06,.5235700E-07,& + & .9811900E-10,.2354000E-06,.3278200E-06,.3265700E-06,.5565000E-07,& + & .1021500E-09,.1460400E-06,.1995700E-06,.2007900E-06,.3400900E-07,& + & .9616800E-10,.1597600E-06,.2185900E-06,.2178200E-06,.3656500E-07,& + & .9083200E-10,.1709200E-06,.2359400E-06,.2340300E-06,.3933600E-07,& + & .8603900E-10,.1807600E-06,.2514800E-06,.2494000E-06,.4212000E-07,& + & .8170500E-10,.1909100E-06,.2657900E-06,.2641700E-06,.4480600E-07,& + & .8554800E-10,.1160600E-06,.1585800E-06,.1602500E-06,.2713800E-07,& + & .8043000E-10,.1277700E-06,.1746500E-06,.1743900E-06,.2926000E-07,& + & .7588200E-10,.1377100E-06,.1895600E-06,.1880100E-06,.3151900E-07,& + & .7180700E-10,.1459700E-06,.2028200E-06,.2008500E-06,.3379000E-07,& + & .6813100E-10,.1545400E-06,.2148500E-06,.2132100E-06,.3601600E-07,& + & .7188000E-10,.9167700E-07,.1251800E-06,.1271700E-06,.2154800E-07,& + & .6747400E-10,.1018200E-06,.1388500E-06,.1388700E-06,.2336600E-07,& + & .6357300E-10,.1103700E-06,.1515500E-06,.1503700E-06,.2514000E-07,& + & .6008900E-10,.1175700E-06,.1629200E-06,.1611500E-06,.2702300E-07,& + & .5695500E-10,.1246000E-06,.1730300E-06,.1715000E-06,.2888600E-07/ + + data absb(876:1050, 3) / & + & .6043800E-10,.7237800E-07,.9858600E-07,.1007500E-06,.1706800E-07,& + & .5663900E-10,.8066200E-07,.1100300E-06,.1105200E-06,.1864300E-07,& + & .5328800E-10,.8839100E-07,.1206900E-06,.1200700E-06,.2005000E-07,& + & .5030600E-10,.9462400E-07,.1304500E-06,.1291600E-06,.2158700E-07,& + & .4763200E-10,.1002600E-06,.1391400E-06,.1377800E-06,.2313600E-07,& + & .5085600E-10,.5704600E-07,.7756500E-07,.7974100E-07,.1351000E-07,& + & .4757400E-10,.6373000E-07,.8693900E-07,.8782600E-07,.1481100E-07,& + & .4469200E-10,.7036700E-07,.9597400E-07,.9570700E-07,.1599200E-07,& + & .4213600E-10,.7595900E-07,.1044100E-06,.1033600E-06,.1723500E-07,& + & .3985100E-10,.8066200E-07,.1117900E-06,.1106100E-06,.1850100E-07,& + & .4275200E-10,.4499400E-07,.6093300E-07,.6317000E-07,.1073300E-07,& + & .3992000E-10,.5041700E-07,.6869500E-07,.6977600E-07,.1177800E-07,& + & .3744500E-10,.5612900E-07,.7638100E-07,.7629200E-07,.1279600E-07,& + & .3525800E-10,.6091600E-07,.8353300E-07,.8274600E-07,.1377000E-07,& + & .3330900E-10,.6501000E-07,.8993300E-07,.8882800E-07,.1480900E-07,& + & .3593500E-10,.3527800E-07,.4790100E-07,.5005600E-07,.8523900E-08,& + & .3349400E-10,.3989700E-07,.5424500E-07,.5543900E-07,.9356200E-08,& + & .3136800E-10,.4457700E-07,.6068700E-07,.6085400E-07,.1022900E-07,& + & .2949700E-10,.4890600E-07,.6666800E-07,.6621700E-07,.1100900E-07,& + & .2783400E-10,.5234800E-07,.7215400E-07,.7132200E-07,.1185600E-07,& + & .3022700E-10,.2757200E-07,.3752400E-07,.3975400E-07,.6719800E-08,& + & .2811800E-10,.3156000E-07,.4281000E-07,.4403100E-07,.7426700E-08,& + & .2629000E-10,.3531900E-07,.4807900E-07,.4848600E-07,.8151100E-08,& + & .2468700E-10,.3904100E-07,.5314100E-07,.5289800E-07,.8804400E-08,& + & .2326700E-10,.4212300E-07,.5783500E-07,.5717700E-07,.9493400E-08,& + & .2544800E-10,.2145600E-07,.2932400E-07,.3145000E-07,.5303500E-08,& + & .2362300E-10,.2492200E-07,.3370600E-07,.3490300E-07,.5902500E-08,& + & .2204800E-10,.2793100E-07,.3800900E-07,.3854800E-07,.6484200E-08,& + & .2067300E-10,.3111700E-07,.4229300E-07,.4218000E-07,.7045400E-08,& + & .1945900E-10,.3380000E-07,.4631600E-07,.4577600E-07,.7588600E-08,& + & .2139000E-10,.1674300E-07,.2303100E-07,.2487700E-07,.4177700E-08,& + & .1981500E-10,.1961900E-07,.2655600E-07,.2772200E-07,.4703100E-08,& + & .1846300E-10,.2216700E-07,.3010100E-07,.3070800E-07,.5164600E-08,& + & .1728600E-10,.2480400E-07,.3370400E-07,.3371600E-07,.5644800E-08,& + & .1625100E-10,.2718300E-07,.3704900E-07,.3669600E-07,.6078800E-08/ + + data absb(1051:1175, 3) / & + & .1797300E-10,.1303700E-07,.1811500E-07,.1972700E-07,.3291200E-08,& + & .1661500E-10,.1540200E-07,.2094200E-07,.2204300E-07,.3730100E-08,& + & .1545400E-10,.1759200E-07,.2384800E-07,.2448500E-07,.4112900E-08,& + & .1444800E-10,.1973300E-07,.2681500E-07,.2695400E-07,.4514600E-08,& + & .1356500E-10,.2178500E-07,.2963300E-07,.2941400E-07,.4876200E-08,& + & .1511200E-10,.1012700E-07,.1426200E-07,.1563700E-07,.2598600E-08,& + & .1393900E-10,.1208200E-07,.1645800E-07,.1756700E-07,.2951000E-08,& + & .1294200E-10,.1398000E-07,.1887600E-07,.1949900E-07,.3280300E-08,& + & .1208000E-10,.1567700E-07,.2129800E-07,.2151600E-07,.3607800E-08,& + & .1132800E-10,.1742100E-07,.2367400E-07,.2355200E-07,.3914200E-08,& + & .1271600E-10,.7842300E-08,.1121800E-07,.1236800E-07,.2057200E-08,& + & .1170300E-10,.9446800E-08,.1294400E-07,.1393900E-07,.2344900E-08,& + & .1084400E-10,.1105400E-07,.1493300E-07,.1550400E-07,.2616100E-08,& + & .1010500E-10,.1244500E-07,.1689500E-07,.1716700E-07,.2878900E-08,& + & .9462900E-11,.1392900E-07,.1888400E-07,.1883700E-07,.3139100E-08,& + & .1069400E-10,.6108400E-08,.8827800E-08,.9780100E-08,.1619200E-08,& + & .9818000E-11,.7385900E-08,.1020600E-07,.1106400E-07,.1848600E-08,& + & .9079700E-11,.8711300E-08,.1180100E-07,.1234800E-07,.2087200E-08,& + & .8447800E-11,.9900300E-08,.1340900E-07,.1370700E-07,.2296700E-08,& + & .7899800E-11,.1110800E-07,.1506900E-07,.1508200E-07,.2518200E-08,& + & .8851300E-11,.4923900E-08,.7138600E-08,.7917000E-08,.1308900E-08,& + & .8118700E-11,.5954100E-08,.8253900E-08,.8975800E-08,.1495200E-08,& + & .7502100E-11,.7045000E-08,.9556700E-08,.1002400E-07,.1691900E-08,& + & .6975300E-11,.8039100E-08,.1087400E-07,.1114300E-07,.1864600E-08,& + & .6519100E-11,.9026500E-08,.1224000E-07,.1226800E-07,.2047100E-08/ + + data absb( 1:175, 4) / & + & .4011500E-06,.2054200E-03,.2900600E-03,.2998300E-03,.8640400E-04,& + & .3850300E-06,.2208600E-03,.3083300E-03,.3251800E-03,.9261100E-04,& + & .3704200E-06,.2341500E-03,.3267400E-03,.3481400E-03,.9887800E-04,& + & .3569900E-06,.2460700E-03,.3433500E-03,.3685800E-03,.1055900E-03,& + & .3443900E-06,.2574100E-03,.3594300E-03,.3871600E-03,.1126200E-03,& + & .3271700E-06,.1708600E-03,.2412100E-03,.2500100E-03,.7212000E-04,& + & .3141100E-06,.1835800E-03,.2559900E-03,.2708900E-03,.7735100E-04,& + & .3022500E-06,.1945600E-03,.2714900E-03,.2900200E-03,.8267600E-04,& + & .2913200E-06,.2046000E-03,.2854400E-03,.3067800E-03,.8833100E-04,& + & .2810500E-06,.2141000E-03,.2991900E-03,.3227100E-03,.9445100E-04,& + & .2667300E-06,.1422100E-03,.2004800E-03,.2084300E-03,.6021300E-04,& + & .2561500E-06,.1526800E-03,.2126400E-03,.2253100E-03,.6453100E-04,& + & .2465200E-06,.1617000E-03,.2256700E-03,.2415700E-03,.6910200E-04,& + & .2376400E-06,.1702300E-03,.2375000E-03,.2554300E-03,.7389100E-04,& + & .2292600E-06,.1781500E-03,.2491200E-03,.2689200E-03,.7916700E-04,& + & .2174000E-06,.1182400E-03,.1664400E-03,.1738100E-03,.5022700E-04,& + & .2088400E-06,.1269600E-03,.1768300E-03,.1878000E-03,.5390300E-04,& + & .2010400E-06,.1343400E-03,.1876400E-03,.2009400E-03,.5777700E-04,& + & .1938100E-06,.1417700E-03,.1975700E-03,.2125900E-03,.6182100E-04,& + & .1869800E-06,.1482800E-03,.2074700E-03,.2241600E-03,.6632600E-04,& + & .1772400E-06,.9828700E-04,.1381300E-03,.1449600E-03,.4185100E-04,& + & .1702900E-06,.1054800E-03,.1470100E-03,.1563600E-03,.4494300E-04,& + & .1639600E-06,.1116900E-03,.1560500E-03,.1672700E-03,.4817600E-04,& + & .1580900E-06,.1179500E-03,.1643500E-03,.1768400E-03,.5171600E-04,& + & .1525100E-06,.1233200E-03,.1726500E-03,.1868300E-03,.5548000E-04,& + & .1445000E-06,.8170300E-04,.1146400E-03,.1207900E-03,.3484900E-04,& + & .1388700E-06,.8758000E-04,.1222400E-03,.1302800E-03,.3746500E-04,& + & .1337300E-06,.9286900E-04,.1296600E-03,.1390600E-03,.4022500E-04,& + & .1289600E-06,.9803400E-04,.1366800E-03,.1471200E-03,.4322700E-04,& + & .1243900E-06,.1025000E-03,.1436700E-03,.1555700E-03,.4638300E-04,& + & .1178200E-06,.6792200E-04,.9512100E-04,.1005900E-03,.2901400E-04,& + & .1132500E-06,.7275900E-04,.1016600E-03,.1084300E-03,.3123900E-04,& + & .1090900E-06,.7721300E-04,.1076900E-03,.1156300E-03,.3359400E-04,& + & .1052100E-06,.8150700E-04,.1136700E-03,.1224400E-03,.3608700E-04,& + & .1014600E-06,.8522900E-04,.1195100E-03,.1295500E-03,.3876000E-04/ + + data absb(176:350, 4) / & + & .9600500E-07,.5653900E-04,.7904800E-04,.8363800E-04,.2418200E-04,& + & .9231100E-07,.6052200E-04,.8450600E-04,.9030800E-04,.2605200E-04,& + & .8892700E-07,.6430500E-04,.8960800E-04,.9622900E-04,.2807100E-04,& + & .8577500E-07,.6781100E-04,.9465900E-04,.1020300E-03,.3018500E-04,& + & .8270900E-07,.7096700E-04,.9955100E-04,.1079600E-03,.3243800E-04,& + & .7822500E-07,.4709400E-04,.6573600E-04,.6970600E-04,.2016800E-04,& + & .7523500E-07,.5038300E-04,.7030900E-04,.7521000E-04,.2174800E-04,& + & .7249100E-07,.5358100E-04,.7457900E-04,.8010600E-04,.2344200E-04,& + & .6992900E-07,.5644800E-04,.7886400E-04,.8510800E-04,.2524800E-04,& + & .6741900E-07,.5909000E-04,.8293200E-04,.8987000E-04,.2709800E-04,& + & .6357200E-07,.3942600E-04,.5497900E-04,.5844300E-04,.1691300E-04,& + & .6116600E-07,.4209700E-04,.5877900E-04,.6293300E-04,.1825900E-04,& + & .5895100E-07,.4479400E-04,.6233000E-04,.6695200E-04,.1967000E-04,& + & .5687200E-07,.4714700E-04,.6596100E-04,.7123000E-04,.2122100E-04,& + & .5482200E-07,.4937700E-04,.6923400E-04,.7503800E-04,.2274300E-04,& + & .5165600E-07,.3295000E-04,.4605200E-04,.4908400E-04,.1418100E-04,& + & .4972100E-07,.3525000E-04,.4910600E-04,.5267500E-04,.1533000E-04,& + & .4793000E-07,.3743800E-04,.5215200E-04,.5609700E-04,.1653200E-04,& + & .4624200E-07,.3941800E-04,.5516000E-04,.5967400E-04,.1781100E-04,& + & .4457000E-07,.4128000E-04,.5789900E-04,.6265400E-04,.1910000E-04,& + & .4196200E-07,.2760800E-04,.3852700E-04,.4116700E-04,.1190800E-04,& + & .4040500E-07,.2954700E-04,.4109900E-04,.4408100E-04,.1288000E-04,& + & .3895900E-07,.3132100E-04,.4368700E-04,.4705100E-04,.1391200E-04,& + & .3758300E-07,.3299400E-04,.4619000E-04,.4989000E-04,.1496100E-04,& + & .3622700E-07,.3456000E-04,.4847300E-04,.5235800E-04,.1603900E-04,& + & .3407500E-07,.2315300E-04,.3230500E-04,.3456600E-04,.1001400E-04,& + & .3282200E-07,.2476900E-04,.3443500E-04,.3696800E-04,.1082200E-04,& + & .3165500E-07,.2624200E-04,.3663500E-04,.3948400E-04,.1169900E-04,& + & .3052800E-07,.2762400E-04,.3864800E-04,.4177000E-04,.1258800E-04,& + & .2943400E-07,.2895100E-04,.4063200E-04,.4377400E-04,.1347900E-04,& + & .2765200E-07,.1946000E-04,.2711400E-04,.2905200E-04,.8437200E-05,& + & .2664500E-07,.2078500E-04,.2893300E-04,.3109100E-04,.9130500E-05,& + & .2570300E-07,.2201800E-04,.3074900E-04,.3317300E-04,.9856000E-05,& + & .2478000E-07,.2316600E-04,.3240500E-04,.3497100E-04,.1059300E-04,& + & .2390000E-07,.2428600E-04,.3404800E-04,.3666300E-04,.1134600E-04/ + + data absb(351:525, 4) / & + & .2243900E-07,.1637000E-04,.2276300E-04,.2439700E-04,.7108400E-05,& + & .2162800E-07,.1746100E-04,.2431800E-04,.2614000E-04,.7696100E-05,& + & .2086500E-07,.1849300E-04,.2582600E-04,.2782400E-04,.8308000E-05,& + & .2011300E-07,.1945200E-04,.2721500E-04,.2928700E-04,.8920700E-05,& + & .1940500E-07,.2037600E-04,.2854300E-04,.3071000E-04,.9547700E-05,& + & .1820800E-07,.1377700E-04,.1913800E-04,.2052400E-04,.5995200E-05,& + & .1755500E-07,.1467900E-04,.2044800E-04,.2199600E-04,.6490700E-05,& + & .1693600E-07,.1552200E-04,.2166100E-04,.2335700E-04,.6996600E-05,& + & .1632500E-07,.1633400E-04,.2284600E-04,.2453700E-04,.7512400E-05,& + & .1575500E-07,.1708800E-04,.2393100E-04,.2572200E-04,.8030500E-05,& + & .1477200E-07,.1159800E-04,.1611700E-04,.1729400E-04,.5060200E-05,& + & .1424600E-07,.1234600E-04,.1719800E-04,.1852100E-04,.5479900E-05,& + & .1373900E-07,.1304700E-04,.1820500E-04,.1956600E-04,.5899200E-05,& + & .1324700E-07,.1372900E-04,.1917300E-04,.2057400E-04,.6325100E-05,& + & .1278900E-07,.1434100E-04,.2006800E-04,.2153600E-04,.6749600E-05,& + & .1198400E-07,.9767900E-05,.1356800E-04,.1456500E-04,.4272100E-05,& + & .1156000E-07,.1038900E-04,.1446100E-04,.1556000E-04,.4618200E-05,& + & .1114400E-07,.1097300E-04,.1530200E-04,.1641000E-04,.4971500E-05,& + & .1075000E-07,.1153200E-04,.1609100E-04,.1724400E-04,.5321200E-05,& + & .1038100E-07,.1203400E-04,.1682100E-04,.1802300E-04,.5671200E-05,& + & .9720500E-08,.8229600E-05,.1144000E-04,.1228800E-04,.3607900E-05,& + & .9377700E-08,.8743100E-05,.1215800E-04,.1306700E-04,.3897400E-05,& + & .9039100E-08,.9230000E-05,.1286200E-04,.1376900E-04,.4188500E-05,& + & .8721900E-08,.9685400E-05,.1350800E-04,.1445400E-04,.4475600E-05,& + & .8425100E-08,.1010100E-04,.1409000E-04,.1506400E-04,.4764300E-05,& + & .7884200E-08,.6937900E-05,.9637800E-05,.1035000E-04,.3046200E-05,& + & .7605800E-08,.7360500E-05,.1023000E-04,.1096400E-04,.3287900E-05,& + & .7331200E-08,.7768500E-05,.1080600E-04,.1155200E-04,.3525800E-05,& + & .7076100E-08,.8139300E-05,.1132900E-04,.1210900E-04,.3764200E-05,& + & .6837500E-08,.8472300E-05,.1180600E-04,.1258200E-04,.4002700E-05,& + & .6394600E-08,.5848400E-05,.8113200E-05,.8713800E-05,.2572200E-05,& + & .6166800E-08,.6198500E-05,.8615200E-05,.9204300E-05,.2771600E-05,& + & .5946000E-08,.6532900E-05,.9076100E-05,.9691400E-05,.2967200E-05,& + & .5741000E-08,.6834900E-05,.9499100E-05,.1012800E-04,.3164900E-05,& + & .5549000E-08,.7109800E-05,.9897200E-05,.1049400E-04,.3361300E-05/ + + data absb(526:700, 4) / & + & .5193100E-08,.4915500E-05,.6812200E-05,.7300300E-05,.2164800E-05,& + & .5006600E-08,.5210800E-05,.7229900E-05,.7712800E-05,.2328000E-05,& + & .4828900E-08,.5483800E-05,.7607600E-05,.8107700E-05,.2490600E-05,& + & .4663600E-08,.5727100E-05,.7946000E-05,.8449400E-05,.2653400E-05,& + & .4508900E-08,.5954300E-05,.8275100E-05,.8742200E-05,.2815900E-05,& + & .4217700E-08,.4110400E-05,.5691400E-05,.6085200E-05,.1807800E-05,& + & .4079500E-08,.4358000E-05,.6033400E-05,.6427400E-05,.1942100E-05,& + & .3935300E-08,.4581400E-05,.6340700E-05,.6744300E-05,.2076700E-05,& + & .3801200E-08,.4780300E-05,.6619600E-05,.7014400E-05,.2211400E-05,& + & .3675600E-08,.4968200E-05,.6888400E-05,.7253900E-05,.2345800E-05,& + & .3416200E-08,.3414100E-05,.4722400E-05,.5041200E-05,.1496500E-05,& + & .3319600E-08,.3621500E-05,.5003700E-05,.5324100E-05,.1607800E-05,& + & .3219500E-08,.3806400E-05,.5258300E-05,.5581700E-05,.1718800E-05,& + & .3109900E-08,.3971500E-05,.5488100E-05,.5800600E-05,.1830700E-05,& + & .3007200E-08,.4127000E-05,.5706500E-05,.5997400E-05,.1941900E-05,& + & .2800800E-08,.2809400E-05,.3880100E-05,.4139300E-05,.1224800E-05,& + & .2712100E-08,.2983600E-05,.4115500E-05,.4374800E-05,.1316800E-05,& + & .2648200E-08,.3139700E-05,.4328200E-05,.4588500E-05,.1408700E-05,& + & .2557600E-08,.3277900E-05,.4520000E-05,.4770600E-05,.1501300E-05,& + & .2472700E-08,.3408200E-05,.4702300E-05,.4935400E-05,.1593500E-05,& + & .2298400E-08,.2310600E-05,.3185600E-05,.3396100E-05,.1001600E-05,& + & .2222000E-08,.2456300E-05,.3382600E-05,.3591500E-05,.1077600E-05,& + & .2158800E-08,.2588200E-05,.3560000E-05,.3769600E-05,.1153800E-05,& + & .2104000E-08,.2703300E-05,.3719900E-05,.3921300E-05,.1230400E-05,& + & .2033900E-08,.2812200E-05,.3872800E-05,.4059700E-05,.1306700E-05,& + & .1886700E-08,.1899000E-05,.2614700E-05,.2785500E-05,.8189500E-06,& + & .1821900E-08,.2021100E-05,.2778900E-05,.2948200E-05,.8816800E-06,& + & .1767100E-08,.2132400E-05,.2927200E-05,.3096200E-05,.9447500E-06,& + & .1720100E-08,.2228700E-05,.3060700E-05,.3223100E-05,.1008000E-05,& + & .1672900E-08,.2319700E-05,.3188500E-05,.3338900E-05,.1071300E-05,& + & .1556700E-08,.1548600E-05,.2129900E-05,.2269700E-05,.6641800E-06,& + & .1503000E-08,.1652500E-05,.2268600E-05,.2406300E-05,.7159100E-06,& + & .1455900E-08,.1746800E-05,.2393800E-05,.2530400E-05,.7680400E-06,& + & .1414700E-08,.1828400E-05,.2506200E-05,.2637700E-05,.8205300E-06,& + & .1380800E-08,.1905100E-05,.2614200E-05,.2736200E-05,.8728200E-06/ + + data absb(701:875, 4) / & + & .1285500E-08,.1262200E-05,.1732600E-05,.1847200E-05,.5377800E-06,& + & .1241400E-08,.1348600E-05,.1849400E-05,.1961200E-05,.5806200E-06,& + & .1200600E-08,.1429000E-05,.1955100E-05,.2066500E-05,.6236500E-06,& + & .1165500E-08,.1498400E-05,.2050600E-05,.2157000E-05,.6670700E-06,& + & .1136600E-08,.1563000E-05,.2141600E-05,.2240400E-05,.7103500E-06,& + & .1061600E-08,.1027300E-05,.1408500E-05,.1503400E-05,.4351400E-06,& + & .1025000E-08,.1099700E-05,.1507000E-05,.1597300E-05,.4706100E-06,& + & .9903000E-09,.1167900E-05,.1595300E-05,.1686100E-05,.5061300E-06,& + & .9606200E-09,.1227200E-05,.1676600E-05,.1764200E-05,.5421600E-06,& + & .9344300E-09,.1281700E-05,.1752900E-05,.1833300E-05,.5778400E-06,& + & .8788300E-09,.8319900E-06,.1140200E-05,.1216800E-05,.3502500E-06,& + & .8482900E-09,.8925400E-06,.1222500E-05,.1295800E-05,.3796000E-06,& + & .8190300E-09,.9507200E-06,.1296600E-05,.1370800E-05,.4089300E-06,& + & .7936900E-09,.1002000E-05,.1366500E-05,.1437900E-05,.4386200E-06,& + & .7710800E-09,.1047800E-05,.1430200E-05,.1496200E-05,.4681700E-06,& + & .7283800E-09,.6708000E-06,.9196200E-06,.9810200E-06,.2810700E-06,& + & .7027900E-09,.7227100E-06,.9885300E-06,.1049100E-05,.3054000E-06,& + & .6785800E-09,.7720300E-06,.1052200E-05,.1112200E-05,.3295800E-06,& + & .6565100E-09,.8162500E-06,.1111500E-05,.1169700E-05,.3540700E-06,& + & .6372700E-09,.8549500E-06,.1165100E-05,.1219200E-05,.3785000E-06,& + & .6037900E-09,.5404700E-06,.7412800E-06,.7910000E-06,.2253500E-06,& + & .5822800E-09,.5842900E-06,.7985400E-06,.8484100E-06,.2454800E-06,& + & .5622000E-09,.6260600E-06,.8528300E-06,.9015700E-06,.2654100E-06,& + & .5432000E-09,.6642300E-06,.9029600E-06,.9501500E-06,.2855800E-06,& + & .5268600E-09,.6971900E-06,.9483000E-06,.9925400E-06,.3058000E-06,& + & .5010800E-09,.4336100E-06,.5955400E-06,.6343200E-06,.1802300E-06,& + & .4829100E-09,.4712700E-06,.6434900E-06,.6851000E-06,.1967700E-06,& + & .4661200E-09,.5062100E-06,.6894200E-06,.7292900E-06,.2132500E-06,& + & .4500400E-09,.5390300E-06,.7316900E-06,.7709500E-06,.2298600E-06,& + & .4360000E-09,.5674000E-06,.7708100E-06,.8071400E-06,.2465400E-06,& + & .4166500E-09,.3461400E-06,.4756500E-06,.5059800E-06,.1434500E-06,& + & .4011900E-09,.3777900E-06,.5164200E-06,.5501500E-06,.1569700E-06,& + & .3870200E-09,.4075200E-06,.5552500E-06,.5875900E-06,.1706400E-06,& + & .3737200E-09,.4356300E-06,.5907600E-06,.6231800E-06,.1843000E-06,& + & .3613900E-09,.4604100E-06,.6247400E-06,.6551500E-06,.1980000E-06/ + + data absb(876:1050, 4) / & + & .3465800E-09,.2749400E-06,.3792400E-06,.4034900E-06,.1140700E-06,& + & .3334000E-09,.3024300E-06,.4134000E-06,.4406600E-06,.1250800E-06,& + & .3214300E-09,.3275600E-06,.4463500E-06,.4730800E-06,.1363600E-06,& + & .3103200E-09,.3514900E-06,.4766900E-06,.5030900E-06,.1476300E-06,& + & .2996900E-09,.3732300E-06,.5054200E-06,.5306200E-06,.1589200E-06,& + & .2884600E-09,.2177800E-06,.3016800E-06,.3215800E-06,.9060700E-07,& + & .2771600E-09,.2413900E-06,.3307100E-06,.3521400E-06,.9957700E-07,& + & .2670000E-09,.2630400E-06,.3580400E-06,.3804900E-06,.1088100E-06,& + & .2576700E-09,.2831300E-06,.3839400E-06,.4056600E-06,.1181400E-06,& + & .2487500E-09,.3018300E-06,.4083200E-06,.4290600E-06,.1274200E-06,& + & .2399400E-09,.1727600E-06,.2403900E-06,.2564400E-06,.7212400E-07,& + & .2302800E-09,.1927500E-06,.2642900E-06,.2811700E-06,.7938800E-07,& + & .2216200E-09,.2110600E-06,.2875800E-06,.3060600E-06,.8692200E-07,& + & .2137700E-09,.2280700E-06,.3094700E-06,.3271400E-06,.9462800E-07,& + & .2064100E-09,.2440000E-06,.3296200E-06,.3471500E-06,.1022800E-06,& + & .1996000E-09,.1370900E-06,.1910100E-06,.2040700E-06,.5756600E-07,& + & .1913200E-09,.1535200E-06,.2112000E-06,.2245500E-06,.6330800E-07,& + & .1839500E-09,.1692400E-06,.2306800E-06,.2456300E-06,.6942100E-07,& + & .1773200E-09,.1835200E-06,.2492600E-06,.2638300E-06,.7577300E-07,& + & .1711700E-09,.1971500E-06,.2663000E-06,.2806800E-06,.8209700E-07,& + & .1661600E-09,.1085200E-06,.1519100E-06,.1613700E-06,.4597500E-07,& + & .1590100E-09,.1218800E-06,.1685500E-06,.1794300E-06,.5045400E-07,& + & .1527200E-09,.1353500E-06,.1850200E-06,.1970500E-06,.5542400E-07,& + & .1471100E-09,.1476500E-06,.2004200E-06,.2125200E-06,.6061600E-07,& + & .1419400E-09,.1590700E-06,.2148400E-06,.2267300E-06,.6582600E-07,& + & .1383900E-09,.8570400E-07,.1202300E-06,.1274400E-06,.3652300E-07,& + & .1322300E-09,.9660000E-07,.1343800E-06,.1431200E-06,.4015200E-07,& + & .1268400E-09,.1080400E-06,.1478400E-06,.1573500E-06,.4420700E-07,& + & .1220800E-09,.1185100E-06,.1609300E-06,.1710800E-06,.4843500E-07,& + & .1177200E-09,.1281100E-06,.1731300E-06,.1829300E-06,.5273300E-07,& + & .1151600E-09,.6780200E-07,.9540000E-07,.1006500E-06,.2904000E-07,& + & .1098600E-09,.7692700E-07,.1071200E-06,.1142800E-06,.3204400E-07,& + & .1052600E-09,.8629500E-07,.1183300E-06,.1258000E-06,.3533500E-07,& + & .1012200E-09,.9519000E-07,.1293600E-06,.1376300E-06,.3876400E-07,& + & .9754500E-10,.1032400E-06,.1396900E-06,.1476800E-06,.4231200E-07/ + + data absb(1051:1175, 4) / & + & .9583200E-10,.5361000E-07,.7598100E-07,.7966700E-07,.2311700E-07,& + & .9128100E-10,.6113000E-07,.8532900E-07,.9100500E-07,.2565700E-07,& + & .8733500E-10,.6882500E-07,.9473600E-07,.1007500E-06,.2826400E-07,& + & .8389700E-10,.7643500E-07,.1039600E-06,.1107000E-06,.3105700E-07,& + & .8081000E-10,.8327800E-07,.1126900E-06,.1192800E-06,.3397200E-07,& + & .7981000E-10,.4232200E-07,.6037400E-07,.6292600E-07,.1840400E-07,& + & .7586400E-10,.4855900E-07,.6803900E-07,.7224100E-07,.2054800E-07,& + & .7248500E-10,.5477300E-07,.7579900E-07,.8075700E-07,.2258100E-07,& + & .6956000E-10,.6122400E-07,.8355400E-07,.8896700E-07,.2485900E-07,& + & .6695100E-10,.6708400E-07,.9079700E-07,.9624600E-07,.2724500E-07,& + & .6652400E-10,.3332000E-07,.4751600E-07,.4954100E-07,.1462000E-07,& + & .6308100E-10,.3844300E-07,.5402700E-07,.5714200E-07,.1637000E-07,& + & .6018700E-10,.4358700E-07,.6061100E-07,.6460800E-07,.1803600E-07,& + & .5768900E-10,.4897000E-07,.6691500E-07,.7123300E-07,.1989500E-07,& + & .5547800E-10,.5392500E-07,.7304500E-07,.7761800E-07,.2183100E-07,& + & .5544700E-10,.2624000E-07,.3743500E-07,.3898900E-07,.1160600E-07,& + & .5244200E-10,.3046000E-07,.4295500E-07,.4523300E-07,.1304700E-07,& + & .4996200E-10,.3476100E-07,.4841800E-07,.5168000E-07,.1443100E-07,& + & .4782600E-10,.3915200E-07,.5362600E-07,.5704700E-07,.1593400E-07,& + & .4595400E-10,.4338000E-07,.5878600E-07,.6253800E-07,.1751100E-07,& + & .4574000E-10,.2124800E-07,.3026100E-07,.3157700E-07,.9422100E-08,& + & .4321000E-10,.2473000E-07,.3494800E-07,.3672200E-07,.1060800E-07,& + & .4114100E-10,.2828800E-07,.3941000E-07,.4205200E-07,.1175400E-07,& + & .3936100E-10,.3190400E-07,.4374000E-07,.4652700E-07,.1298600E-07,& + & .3780500E-10,.3544200E-07,.4802000E-07,.5108300E-07,.1427800E-07/ + + data absb( 1:175, 5) / & + & .7904500E-05,.5851200E-03,.8096700E-03,.8857800E-03,.3482400E-03,& + & .9280700E-05,.6181800E-03,.8608300E-03,.9243700E-03,.3787000E-03,& + & .1062000E-04,.6502500E-03,.9061700E-03,.9629000E-03,.4063900E-03,& + & .1184700E-04,.6808600E-03,.9476700E-03,.9981500E-03,.4314900E-03,& + & .1289700E-04,.7094100E-03,.9842600E-03,.1029600E-02,.4545900E-03,& + & .6568300E-05,.4879800E-03,.6757000E-03,.7375500E-03,.2917200E-03,& + & .7695700E-05,.5155500E-03,.7185600E-03,.7697800E-03,.3170900E-03,& + & .8785200E-05,.5424300E-03,.7560400E-03,.8014200E-03,.3406400E-03,& + & .9762200E-05,.5681700E-03,.7903800E-03,.8309100E-03,.3609500E-03,& + & .1061400E-04,.5920800E-03,.8201800E-03,.8569100E-03,.3809500E-03,& + & .5464300E-05,.4066000E-03,.5637100E-03,.6128600E-03,.2443500E-03,& + & .6388300E-05,.4297300E-03,.5991400E-03,.6409300E-03,.2647500E-03,& + & .7259300E-05,.4521800E-03,.6300400E-03,.6665900E-03,.2848600E-03,& + & .8052600E-05,.4737300E-03,.6584700E-03,.6912800E-03,.3020000E-03,& + & .8736400E-05,.4939300E-03,.6831800E-03,.7132100E-03,.3193000E-03,& + & .4548200E-05,.3387200E-03,.4700300E-03,.5092000E-03,.2047300E-03,& + & .5289300E-05,.3578500E-03,.4989800E-03,.5330600E-03,.2217100E-03,& + & .5998900E-05,.3767300E-03,.5246700E-03,.5546100E-03,.2380300E-03,& + & .6642600E-05,.3947000E-03,.5482700E-03,.5751500E-03,.2524400E-03,& + & .7175900E-05,.4119300E-03,.5690900E-03,.5936100E-03,.2677300E-03,& + & .3769000E-05,.2817700E-03,.3915300E-03,.4226500E-03,.1715500E-03,& + & .4379000E-05,.2977800E-03,.4153500E-03,.4428800E-03,.1856300E-03,& + & .4954500E-05,.3137100E-03,.4366400E-03,.4609000E-03,.1990800E-03,& + & .5456300E-05,.3288600E-03,.4563700E-03,.4785400E-03,.2109700E-03,& + & .5887900E-05,.3435900E-03,.4741600E-03,.4938700E-03,.2244000E-03,& + & .3126000E-05,.2343200E-03,.3259600E-03,.3508200E-03,.1434800E-03,& + & .3618500E-05,.2478600E-03,.3456100E-03,.3676500E-03,.1554600E-03,& + & .4073200E-05,.2612000E-03,.3634300E-03,.3832500E-03,.1662300E-03,& + & .4483900E-05,.2740300E-03,.3799700E-03,.3981100E-03,.1765900E-03,& + & .4830400E-05,.2867400E-03,.3951300E-03,.4111400E-03,.1881300E-03,& + & .2585300E-05,.1948300E-03,.2712800E-03,.2912600E-03,.1196900E-03,& + & .2983400E-05,.2062300E-03,.2874900E-03,.3054100E-03,.1297800E-03,& + & .3354600E-05,.2175000E-03,.3026700E-03,.3187100E-03,.1387400E-03,& + & .3686300E-05,.2284200E-03,.3165600E-03,.3311500E-03,.1478900E-03,& + & .3963400E-05,.2394200E-03,.3294400E-03,.3422000E-03,.1574200E-03/ + + data absb(176:350, 5) / & + & .2148600E-05,.1622100E-03,.2260900E-03,.2423600E-03,.1001400E-03,& + & .2473500E-05,.1717800E-03,.2394900E-03,.2539900E-03,.1085700E-03,& + & .2774400E-05,.1813600E-03,.2522600E-03,.2653500E-03,.1160400E-03,& + & .3041400E-05,.1907600E-03,.2639700E-03,.2756600E-03,.1239800E-03,& + & .3261000E-05,.2001900E-03,.2748800E-03,.2851000E-03,.1319900E-03,& + & .1787700E-05,.1350700E-03,.1884500E-03,.2016300E-03,.8387900E-04,& + & .2051800E-05,.1431900E-03,.1996800E-03,.2113400E-03,.9085800E-04,& + & .2295300E-05,.1513700E-03,.2103800E-03,.2209400E-03,.9709800E-04,& + & .2509800E-05,.1594700E-03,.2201900E-03,.2294800E-03,.1040200E-03,& + & .2683000E-05,.1674900E-03,.2295000E-03,.2376100E-03,.1106900E-03,& + & .1502200E-05,.1129700E-03,.1577300E-03,.1681900E-03,.7080800E-04,& + & .1715700E-05,.1199800E-03,.1671400E-03,.1764400E-03,.7634500E-04,& + & .1911100E-05,.1269000E-03,.1761100E-03,.1845400E-03,.8180400E-04,& + & .2081200E-05,.1338500E-03,.1842500E-03,.1916400E-03,.8759100E-04,& + & .2214400E-05,.1406600E-03,.1923500E-03,.1986700E-03,.9322800E-04,& + & .1262100E-05,.9468100E-04,.1321000E-03,.1403200E-03,.5963000E-04,& + & .1434600E-05,.1006100E-03,.1400900E-03,.1475100E-03,.6414200E-04,& + & .1590800E-05,.1065500E-03,.1474900E-03,.1541300E-03,.6898800E-04,& + & .1725300E-05,.1124600E-03,.1543700E-03,.1601300E-03,.7389300E-04,& + & .1827200E-05,.1182500E-03,.1613000E-03,.1662700E-03,.7864900E-04,& + & .1061100E-05,.7941900E-04,.1107900E-03,.1173600E-03,.5024400E-04,& + & .1199600E-05,.8448600E-04,.1174900E-03,.1234500E-03,.5405400E-04,& + & .1324100E-05,.8956500E-04,.1236400E-03,.1288300E-03,.5825900E-04,& + & .1430000E-05,.9459200E-04,.1294900E-03,.1340600E-03,.6230000E-04,& + & .1507000E-05,.9954500E-04,.1353800E-03,.1392800E-03,.6648500E-04,& + & .8924800E-06,.6675700E-04,.9304300E-04,.9826900E-04,.4239600E-04,& + & .1003400E-05,.7108200E-04,.9865200E-04,.1033200E-03,.4571900E-04,& + & .1102400E-05,.7540400E-04,.1037500E-03,.1078200E-03,.4922800E-04,& + & .1183500E-05,.7969400E-04,.1088200E-03,.1123400E-03,.5264900E-04,& + & .1240600E-05,.8391500E-04,.1137600E-03,.1167700E-03,.5626400E-04,& + & .7514700E-06,.5624800E-04,.7829100E-04,.8244100E-04,.3578100E-04,& + & .8402500E-06,.5992900E-04,.8291700E-04,.8656200E-04,.3871500E-04,& + & .9172800E-06,.6361800E-04,.8723100E-04,.9044200E-04,.4168200E-04,& + & .9794700E-06,.6728500E-04,.9160600E-04,.9431100E-04,.4461000E-04,& + & .1022200E-05,.7087900E-04,.9575900E-04,.9795400E-04,.4767800E-04/ + + data absb(351:525, 5) / & + & .6322800E-06,.4744800E-04,.6592600E-04,.6921100E-04,.3031200E-04,& + & .7018700E-06,.5058300E-04,.6975200E-04,.7262200E-04,.3284400E-04,& + & .7626300E-06,.5372300E-04,.7343100E-04,.7594300E-04,.3528300E-04,& + & .8097500E-06,.5688400E-04,.7713900E-04,.7923500E-04,.3783700E-04,& + & .8409900E-06,.5993700E-04,.8067000E-04,.8219800E-04,.4039800E-04,& + & .5306200E-06,.4005400E-04,.5553600E-04,.5810500E-04,.2568300E-04,& + & .5858100E-06,.4274800E-04,.5871900E-04,.6098800E-04,.2782900E-04,& + & .6328300E-06,.4544500E-04,.6192700E-04,.6380800E-04,.2991400E-04,& + & .6684100E-06,.4814100E-04,.6503300E-04,.6656700E-04,.3210100E-04,& + & .6913200E-06,.5074400E-04,.6800200E-04,.6902400E-04,.3419600E-04,& + & .4448200E-06,.3387600E-04,.4681300E-04,.4882000E-04,.2182200E-04,& + & .4883000E-06,.3617300E-04,.4953400E-04,.5126700E-04,.2359800E-04,& + & .5252000E-06,.3850700E-04,.5226400E-04,.5370000E-04,.2540700E-04,& + & .5514200E-06,.4079000E-04,.5487900E-04,.5593400E-04,.2723300E-04,& + & .5682100E-06,.4300500E-04,.5737400E-04,.5799500E-04,.2893900E-04,& + & .3724000E-06,.2868800E-04,.3949800E-04,.4108200E-04,.1854200E-04,& + & .4069700E-06,.3066200E-04,.4183200E-04,.4313900E-04,.2003700E-04,& + & .4351800E-06,.3265700E-04,.4413700E-04,.4519800E-04,.2159200E-04,& + & .4545900E-06,.3460000E-04,.4634200E-04,.4703000E-04,.2309900E-04,& + & .4667400E-06,.3646800E-04,.4842700E-04,.4875200E-04,.2452400E-04,& + & .3116700E-06,.2432800E-04,.3336500E-04,.3457700E-04,.1577500E-04,& + & .3388000E-06,.2603300E-04,.3537600E-04,.3634300E-04,.1703700E-04,& + & .3602200E-06,.2772800E-04,.3730600E-04,.3802500E-04,.1833400E-04,& + & .3744300E-06,.2938100E-04,.3915300E-04,.3955100E-04,.1955900E-04,& + & .3830400E-06,.3094000E-04,.4088800E-04,.4101200E-04,.2073500E-04,& + & .2606500E-06,.2066600E-04,.2822600E-04,.2912800E-04,.1340300E-04,& + & .2817900E-06,.2213000E-04,.2993400E-04,.3064200E-04,.1449500E-04,& + & .2979100E-06,.2357200E-04,.3155400E-04,.3200500E-04,.1557600E-04,& + & .3081300E-06,.2496300E-04,.3310100E-04,.3327800E-04,.1658200E-04,& + & .3141200E-06,.2626100E-04,.3451000E-04,.3449700E-04,.1753300E-04,& + & .2176800E-06,.1758100E-04,.2390300E-04,.2455800E-04,.1140500E-04,& + & .2340900E-06,.1882700E-04,.2533300E-04,.2581200E-04,.1233100E-04,& + & .2459600E-06,.2005300E-04,.2669600E-04,.2694200E-04,.1320000E-04,& + & .2533800E-06,.2121100E-04,.2797800E-04,.2801200E-04,.1403700E-04,& + & .2573500E-06,.2229200E-04,.2911300E-04,.2901900E-04,.1478900E-04/ + + data absb(526:700, 5) / & + & .1811100E-06,.1493300E-04,.2022100E-04,.2069100E-04,.9685300E-05,& + & .1937300E-06,.1599300E-04,.2141300E-04,.2170800E-04,.1045900E-04,& + & .2026200E-06,.1702500E-04,.2255100E-04,.2265100E-04,.1117000E-04,& + & .2080200E-06,.1799200E-04,.2360300E-04,.2354000E-04,.1184700E-04,& + & .2106800E-06,.1889200E-04,.2452200E-04,.2437000E-04,.1244400E-04,& + & .1494000E-06,.1260400E-04,.1700100E-04,.1733900E-04,.8163000E-05,& + & .1593400E-06,.1350500E-04,.1800800E-04,.1818300E-04,.8789000E-05,& + & .1662600E-06,.1437400E-04,.1896300E-04,.1897600E-04,.9383800E-05,& + & .1704000E-06,.1518700E-04,.1982400E-04,.1972000E-04,.9922900E-05,& + & .1722900E-06,.1593900E-04,.2058200E-04,.2039400E-04,.1041200E-04,& + & .1222400E-06,.1056000E-04,.1420300E-04,.1444700E-04,.6819600E-05,& + & .1303000E-06,.1132600E-04,.1505500E-04,.1515600E-04,.7332100E-05,& + & .1359000E-06,.1206200E-04,.1585600E-04,.1582300E-04,.7823000E-05,& + & .1392900E-06,.1275000E-04,.1657300E-04,.1644900E-04,.8263200E-05,& + & .1408100E-06,.1338400E-04,.1720800E-04,.1700600E-04,.8665600E-05,& + & .9897900E-07,.8750000E-05,.1175500E-04,.1194300E-04,.5626900E-05,& + & .1058300E-06,.9403500E-05,.1248000E-04,.1254400E-04,.6052800E-05,& + & .1106800E-06,.1003100E-04,.1316100E-04,.1311000E-04,.6460400E-05,& + & .1136500E-06,.1061900E-04,.1376700E-04,.1364200E-04,.6825300E-05,& + & .1151000E-06,.1116200E-04,.1430600E-04,.1410800E-04,.7161500E-05,& + & .8005000E-07,.7243600E-05,.9722500E-05,.9865700E-05,.4637500E-05,& + & .8588600E-07,.7800600E-05,.1033800E-04,.1037800E-04,.4991900E-05,& + & .9010800E-07,.8335500E-05,.1091600E-04,.1085600E-04,.5330300E-05,& + & .9269000E-07,.8838000E-05,.1142900E-04,.1130600E-04,.5634900E-05,& + & .9404600E-07,.9301900E-05,.1188500E-04,.1169600E-04,.5915200E-05,& + & .6472000E-07,.5995500E-05,.8038900E-05,.8148800E-05,.3819200E-05,& + & .6966300E-07,.6469900E-05,.8561300E-05,.8581800E-05,.4115900E-05,& + & .7330500E-07,.6924600E-05,.9050600E-05,.8986100E-05,.4396800E-05,& + & .7558800E-07,.7353000E-05,.9485700E-05,.9363700E-05,.4650500E-05,& + & .7682500E-07,.7749200E-05,.9870800E-05,.9689800E-05,.4884100E-05,& + & .5187100E-07,.4919100E-05,.6599400E-05,.6689000E-05,.3118600E-05,& + & .5612700E-07,.5322700E-05,.7043500E-05,.7057800E-05,.3367800E-05,& + & .5939500E-07,.5712400E-05,.7460900E-05,.7401800E-05,.3602500E-05,& + & .6150100E-07,.6079000E-05,.7833300E-05,.7721000E-05,.3816400E-05,& + & .6271000E-07,.6419400E-05,.8161300E-05,.7998000E-05,.4012200E-05/ + + data absb(701:875, 5) / & + & .4147100E-07,.4027600E-05,.5407600E-05,.5481500E-05,.2540200E-05,& + & .4512700E-07,.4371100E-05,.5784700E-05,.5797100E-05,.2750700E-05,& + & .4801800E-07,.4704000E-05,.6140700E-05,.6088300E-05,.2947900E-05,& + & .4998300E-07,.5017700E-05,.6459500E-05,.6358700E-05,.3128600E-05,& + & .5115300E-07,.5309800E-05,.6738900E-05,.6595000E-05,.3292800E-05,& + & .3310800E-07,.3294500E-05,.4426100E-05,.4487100E-05,.2067400E-05,& + & .3622800E-07,.3586100E-05,.4746200E-05,.4757100E-05,.2245200E-05,& + & .3877600E-07,.3870100E-05,.5050500E-05,.5004600E-05,.2410600E-05,& + & .4058000E-07,.4137800E-05,.5321900E-05,.5232300E-05,.2562200E-05,& + & .4168900E-07,.4388100E-05,.5560700E-05,.5435600E-05,.2701500E-05,& + & .2624300E-07,.2678000E-05,.3602100E-05,.3657800E-05,.1672200E-05,& + & .2890300E-07,.2925400E-05,.3875400E-05,.3888600E-05,.1823500E-05,& + & .3115800E-07,.3167400E-05,.4136300E-05,.4099800E-05,.1962800E-05,& + & .3282800E-07,.3396600E-05,.4368700E-05,.4293500E-05,.2090600E-05,& + & .3389600E-07,.3611200E-05,.4574500E-05,.4468000E-05,.2208800E-05,& + & .2069200E-07,.2168800E-05,.2922600E-05,.2973800E-05,.1348600E-05,& + & .2296100E-07,.2377600E-05,.3155600E-05,.3169900E-05,.1475900E-05,& + & .2493400E-07,.2583400E-05,.3377900E-05,.3350700E-05,.1592600E-05,& + & .2647200E-07,.2780000E-05,.3577900E-05,.3516200E-05,.1701700E-05,& + & .2750400E-07,.2963700E-05,.3755800E-05,.3666600E-05,.1801700E-05,& + & .1626900E-07,.1753700E-05,.2367200E-05,.2413300E-05,.1085600E-05,& + & .1819400E-07,.1929100E-05,.2566300E-05,.2580900E-05,.1192700E-05,& + & .1990300E-07,.2103900E-05,.2755200E-05,.2736000E-05,.1290900E-05,& + & .2129300E-07,.2272100E-05,.2927000E-05,.2877500E-05,.1383900E-05,& + & .2228300E-07,.2429200E-05,.3080200E-05,.3006700E-05,.1468600E-05,& + & .1271200E-07,.1412800E-05,.1911300E-05,.1954800E-05,.8711400E-06,& + & .1435100E-07,.1559600E-05,.2080200E-05,.2094900E-05,.9611800E-06,& + & .1581500E-07,.1707600E-05,.2240400E-05,.2228900E-05,.1043600E-05,& + & .1706200E-07,.1851100E-05,.2388900E-05,.2349200E-05,.1122500E-05,& + & .1799300E-07,.1985500E-05,.2520600E-05,.2460900E-05,.1194800E-05,& + & .9836400E-08,.1130600E-05,.1535300E-05,.1574600E-05,.6955400E-06,& + & .1122600E-07,.1253400E-05,.1676500E-05,.1694400E-05,.7692500E-06,& + & .1248300E-07,.1378400E-05,.1813000E-05,.1808700E-05,.8403600E-06,& + & .1358700E-07,.1500700E-05,.1941800E-05,.1912200E-05,.9071200E-06,& + & .1445700E-07,.1615800E-05,.2055700E-05,.2007300E-05,.9684700E-06/ + + data absb(876:1050, 5) / & + & .7582400E-08,.9032900E-06,.1230700E-05,.1265300E-05,.5534600E-06,& + & .8745300E-08,.1005000E-05,.1349000E-05,.1367600E-05,.6147000E-06,& + & .9819400E-08,.1110100E-05,.1465000E-05,.1465100E-05,.6749200E-06,& + & .1077900E-07,.1214100E-05,.1575600E-05,.1554400E-05,.7316300E-06,& + & .1157900E-07,.1312500E-05,.1674300E-05,.1635900E-05,.7840500E-06,& + & .5821900E-08,.7201500E-06,.9837900E-06,.1014300E-05,.4393300E-06,& + & .6781700E-08,.8042300E-06,.1083200E-05,.1102300E-05,.4901800E-06,& + & .7696600E-08,.8920500E-06,.1181900E-05,.1184600E-05,.5413100E-06,& + & .8522400E-08,.9800500E-06,.1276000E-05,.1261700E-05,.5885800E-06,& + & .9235000E-08,.1064400E-05,.1361500E-05,.1331900E-05,.6335800E-06,& + & .4479000E-08,.5741800E-06,.7863500E-06,.8129600E-06,.3488100E-06,& + & .5257900E-08,.6438800E-06,.8705600E-06,.8889600E-06,.3913500E-06,& + & .6027900E-08,.7172200E-06,.9534800E-06,.9580900E-06,.4344400E-06,& + & .6732400E-08,.7913400E-06,.1033100E-05,.1024300E-05,.4739100E-06,& + & .7355100E-08,.8633000E-06,.1107300E-05,.1084200E-05,.5123400E-06,& + & .3445000E-08,.4575300E-06,.6281400E-06,.6515800E-06,.2762500E-06,& + & .4069000E-08,.5153000E-06,.6989200E-06,.7155500E-06,.3126000E-06,& + & .4708700E-08,.5762400E-06,.7684000E-06,.7747700E-06,.3480400E-06,& + & .5308600E-08,.6384300E-06,.8358000E-06,.8309200E-06,.3818100E-06,& + & .5843900E-08,.6995600E-06,.8996200E-06,.8822500E-06,.4141200E-06,& + & .2645400E-08,.3638700E-06,.5000700E-06,.5217900E-06,.2189400E-06,& + & .3140300E-08,.4117300E-06,.5599700E-06,.5747900E-06,.2487000E-06,& + & .3665500E-08,.4621100E-06,.6181900E-06,.6251100E-06,.2784000E-06,& + & .4173000E-08,.5141500E-06,.6754600E-06,.6730700E-06,.3069500E-06,& + & .4631100E-08,.5658200E-06,.7297300E-06,.7169700E-06,.3340700E-06,& + & .2027500E-08,.2887300E-06,.3974900E-06,.4164700E-06,.1735500E-06,& + & .2419000E-08,.3282100E-06,.4473000E-06,.4606300E-06,.1977400E-06,& + & .2844000E-08,.3698100E-06,.4967700E-06,.5041100E-06,.2221800E-06,& + & .3269000E-08,.4131500E-06,.5448800E-06,.5440800E-06,.2464700E-06,& + & .3659200E-08,.4568000E-06,.5909000E-06,.5818900E-06,.2690200E-06,& + & .1561100E-08,.2296200E-06,.3161300E-06,.3330000E-06,.1373000E-06,& + & .1869600E-08,.2618700E-06,.3580200E-06,.3695400E-06,.1570100E-06,& + & .2210000E-08,.2964100E-06,.3997000E-06,.4068300E-06,.1776400E-06,& + & .2561900E-08,.3325500E-06,.4400900E-06,.4406300E-06,.1980800E-06,& + & .2892800E-08,.3690800E-06,.4789200E-06,.4727000E-06,.2169600E-06/ + + data absb(1051:1175, 5) / & + & .1204100E-08,.1825900E-06,.2510800E-06,.2660800E-06,.1084200E-06,& + & .1446600E-08,.2091800E-06,.2863300E-06,.2967700E-06,.1246800E-06,& + & .1717600E-08,.2376500E-06,.3213900E-06,.3279900E-06,.1421300E-06,& + & .2005800E-08,.2676600E-06,.3552300E-06,.3566400E-06,.1590700E-06,& + & .2285200E-08,.2981800E-06,.3880600E-06,.3838100E-06,.1751200E-06,& + & .9293400E-09,.1449600E-06,.1988700E-06,.2121500E-06,.8518500E-07,& + & .1118000E-08,.1666800E-06,.2284100E-06,.2379900E-06,.9917200E-07,& + & .1333300E-08,.1902400E-06,.2579000E-06,.2638500E-06,.1133100E-06,& + & .1566800E-08,.2151200E-06,.2862600E-06,.2882000E-06,.1275800E-06,& + & .1800000E-08,.2405500E-06,.3140500E-06,.3113400E-06,.1410600E-06,& + & .7174700E-09,.1149100E-06,.1576000E-06,.1690700E-06,.6676200E-07,& + & .8631800E-09,.1326600E-06,.1819800E-06,.1905100E-06,.7884400E-07,& + & .1033200E-08,.1519900E-06,.2064600E-06,.2118500E-06,.9031700E-07,& + & .1220500E-08,.1725500E-06,.2304900E-06,.2328000E-06,.1021100E-06,& + & .1413700E-08,.1937400E-06,.2537700E-06,.2520900E-06,.1134700E-06,& + & .5553400E-09,.9116100E-07,.1249500E-06,.1348100E-06,.5252400E-07,& + & .6679600E-09,.1056400E-06,.1449000E-06,.1524600E-06,.6249100E-07,& + & .8020800E-09,.1214200E-06,.1654000E-06,.1701300E-06,.7192300E-07,& + & .9515500E-09,.1384600E-06,.1856200E-06,.1880300E-06,.8176000E-07,& + & .1110000E-08,.1560800E-06,.2051300E-06,.2042500E-06,.9140500E-07,& + & .4448300E-09,.7420100E-07,.1017500E-06,.1098600E-06,.4262600E-07,& + & .5347800E-09,.8625700E-07,.1181800E-06,.1245300E-06,.5081600E-07,& + & .6426500E-09,.9939000E-07,.1353500E-06,.1392800E-06,.5865800E-07,& + & .7636900E-09,.1136000E-06,.1522400E-06,.1541700E-06,.6684500E-07,& + & .8931600E-09,.1282600E-06,.1685000E-06,.1677500E-06,.7484100E-07/ + + data absb( 1:175, 6) / & + & .1545200E-03,.1747100E-02,.2287000E-02,.2275700E-02,.1186800E-02,& + & .1735800E-03,.1833700E-02,.2375200E-02,.2354900E-02,.1249200E-02,& + & .1904300E-03,.1907000E-02,.2447900E-02,.2425500E-02,.1311400E-02,& + & .2045900E-03,.1970200E-02,.2510900E-02,.2490500E-02,.1371700E-02,& + & .2162100E-03,.2026600E-02,.2565300E-02,.2551200E-02,.1432000E-02,& + & .1279300E-03,.1466200E-02,.1914100E-02,.1903200E-02,.9940400E-03,& + & .1433500E-03,.1536700E-02,.1985200E-02,.1969100E-02,.1046200E-02,& + & .1569800E-03,.1597400E-02,.2045400E-02,.2028500E-02,.1098600E-02,& + & .1683700E-03,.1650500E-02,.2098200E-02,.2082800E-02,.1150900E-02,& + & .1776500E-03,.1699000E-02,.2145200E-02,.2135700E-02,.1202000E-02,& + & .1060000E-03,.1228000E-02,.1598700E-02,.1589900E-02,.8316000E-03,& + & .1184600E-03,.1285800E-02,.1657000E-02,.1643800E-02,.8764100E-03,& + & .1294700E-03,.1336200E-02,.1707300E-02,.1693700E-02,.9203700E-03,& + & .1386000E-03,.1381800E-02,.1751900E-02,.1740100E-02,.9651400E-03,& + & .1460500E-03,.1423100E-02,.1792200E-02,.1784900E-02,.1008800E-02,& + & .8784400E-04,.1026800E-02,.1333700E-02,.1325800E-02,.6947100E-03,& + & .9792100E-04,.1074700E-02,.1381600E-02,.1370400E-02,.7330900E-03,& + & .1067800E-03,.1117300E-02,.1424000E-02,.1412200E-02,.7712600E-03,& + & .1141000E-03,.1156100E-02,.1461900E-02,.1452500E-02,.8098300E-03,& + & .1200800E-03,.1191300E-02,.1495700E-02,.1490400E-02,.8468500E-03,& + & .7273600E-04,.8577000E-03,.1111000E-02,.1104300E-02,.5798800E-03,& + & .8087000E-04,.8973700E-03,.1150800E-02,.1141200E-02,.6131000E-03,& + & .8798400E-04,.9333400E-03,.1186500E-02,.1176900E-02,.6456300E-03,& + & .9390000E-04,.9663700E-03,.1218800E-02,.1211500E-02,.6794600E-03,& + & .9866900E-04,.9968200E-03,.1247700E-02,.1244400E-02,.7112900E-03,& + & .6019600E-04,.7158500E-03,.9248400E-03,.9188500E-03,.4842800E-03,& + & .6675900E-04,.7490200E-03,.9580600E-03,.9500700E-03,.5125400E-03,& + & .7248600E-04,.7793600E-03,.9882800E-03,.9803600E-03,.5411800E-03,& + & .7721000E-04,.8075700E-03,.1015700E-02,.1010100E-02,.5699500E-03,& + & .8104600E-04,.8334400E-03,.1040500E-02,.1039000E-02,.5976200E-03,& + & .4979700E-04,.5971400E-03,.7695100E-03,.7640800E-03,.4048700E-03,& + & .5509800E-04,.6250500E-03,.7972800E-03,.7907100E-03,.4290400E-03,& + & .5969000E-04,.6507100E-03,.8229400E-03,.8167100E-03,.4537500E-03,& + & .6345700E-04,.6749000E-03,.8463500E-03,.8424500E-03,.4783300E-03,& + & .6653800E-04,.6968300E-03,.8680500E-03,.8681200E-03,.5023800E-03/ + + data absb(176:350, 6) / & + & .4127700E-04,.4985400E-03,.6404300E-03,.6358200E-03,.3388500E-03,& + & .4555700E-04,.5219700E-03,.6640800E-03,.6585900E-03,.3596000E-03,& + & .4922600E-04,.5438000E-03,.6858200E-03,.6811100E-03,.3810800E-03,& + & .5223800E-04,.5644200E-03,.7059800E-03,.7036400E-03,.4019900E-03,& + & .5469400E-04,.5832000E-03,.7250400E-03,.7264500E-03,.4228200E-03,& + & .3421800E-04,.4162400E-03,.5331200E-03,.5291200E-03,.2837600E-03,& + & .3767000E-04,.4359700E-03,.5531600E-03,.5489300E-03,.3016100E-03,& + & .4060200E-04,.4546700E-03,.5717800E-03,.5686100E-03,.3202300E-03,& + & .4300900E-04,.4722000E-03,.5893100E-03,.5885000E-03,.3380500E-03,& + & .4496800E-04,.4885000E-03,.6062400E-03,.6086700E-03,.3563300E-03,& + & .2855400E-04,.3487200E-03,.4451900E-03,.4420300E-03,.2386500E-03,& + & .3131200E-04,.3654300E-03,.4621500E-03,.4589600E-03,.2542900E-03,& + & .3362300E-04,.3813600E-03,.4780800E-03,.4762500E-03,.2702000E-03,& + & .3551800E-04,.3963800E-03,.4935200E-03,.4939300E-03,.2856700E-03,& + & .3706000E-04,.4104600E-03,.5083300E-03,.5115200E-03,.3016900E-03,& + & .2382500E-04,.2924100E-03,.3720200E-03,.3695700E-03,.2012000E-03,& + & .2601900E-04,.3066400E-03,.3865000E-03,.3843300E-03,.2148400E-03,& + & .2784000E-04,.3202700E-03,.4003800E-03,.3995700E-03,.2282900E-03,& + & .2932900E-04,.3331700E-03,.4139600E-03,.4149800E-03,.2416900E-03,& + & .3054200E-04,.3454700E-03,.4268100E-03,.4304800E-03,.2556800E-03,& + & .1987900E-04,.2455200E-03,.3113500E-03,.3093600E-03,.1698600E-03,& + & .2161700E-04,.2576700E-03,.3237600E-03,.3222800E-03,.1817300E-03,& + & .2305000E-04,.2693700E-03,.3359000E-03,.3357900E-03,.1932000E-03,& + & .2421700E-04,.2805400E-03,.3477200E-03,.3492200E-03,.2050100E-03,& + & .2516400E-04,.2912100E-03,.3588300E-03,.3628600E-03,.2170800E-03,& + & .1658900E-04,.2064500E-03,.2608700E-03,.2594400E-03,.1436900E-03,& + & .1796100E-04,.2168800E-03,.2716200E-03,.2708300E-03,.1538600E-03,& + & .1908300E-04,.2269700E-03,.2822900E-03,.2825800E-03,.1638300E-03,& + & .1999800E-04,.2366800E-03,.2924500E-03,.2943800E-03,.1741800E-03,& + & .2073700E-04,.2458900E-03,.3021600E-03,.3064700E-03,.1846500E-03,& + & .1385800E-04,.1740200E-03,.2190600E-03,.2180400E-03,.1220500E-03,& + & .1493000E-04,.1830000E-03,.2284300E-03,.2281300E-03,.1306500E-03,& + & .1580700E-04,.1917400E-03,.2377000E-03,.2383000E-03,.1393300E-03,& + & .1652200E-04,.2001000E-03,.2464000E-03,.2487600E-03,.1483700E-03,& + & .1709000E-04,.2079800E-03,.2550000E-03,.2594300E-03,.1574800E-03/ + + data absb(351:525, 6) / & + & .1156500E-04,.1468900E-03,.1842300E-03,.1835800E-03,.1037200E-03,& + & .1240400E-04,.1546600E-03,.1924200E-03,.1924200E-03,.1110400E-03,& + & .1308800E-04,.1622500E-03,.2003500E-03,.2013600E-03,.1187700E-03,& + & .1364400E-04,.1693800E-03,.2079300E-03,.2105400E-03,.1265800E-03,& + & .1407900E-04,.1761400E-03,.2155300E-03,.2200400E-03,.1345500E-03,& + & .9642900E-05,.1242200E-03,.1551800E-03,.1548600E-03,.8824000E-04,& + & .1029700E-04,.1309300E-03,.1622900E-03,.1625500E-03,.9466400E-04,& + & .1082900E-04,.1374400E-03,.1691100E-03,.1704300E-03,.1013700E-03,& + & .1126300E-04,.1435500E-03,.1757700E-03,.1786100E-03,.1081800E-03,& + & .1159300E-04,.1493600E-03,.1824500E-03,.1869800E-03,.1151700E-03,& + & .8035700E-05,.1052500E-03,.1309800E-03,.1308700E-03,.7519900E-04,& + & .8545700E-05,.1110600E-03,.1370900E-03,.1375600E-03,.8087700E-04,& + & .8958500E-05,.1165900E-03,.1429800E-03,.1445800E-03,.8670300E-04,& + & .9293600E-05,.1218500E-03,.1488700E-03,.1518400E-03,.9267900E-04,& + & .9541300E-05,.1268500E-03,.1547600E-03,.1592600E-03,.9877000E-04,& + & .6689100E-05,.8932600E-04,.1107000E-03,.1107500E-03,.6425400E-04,& + & .7085500E-05,.9428000E-04,.1159500E-03,.1166800E-03,.6921500E-04,& + & .7406800E-05,.9902900E-04,.1211200E-03,.1229000E-03,.7427800E-04,& + & .7663400E-05,.1035600E-03,.1263100E-03,.1293300E-03,.7948900E-04,& + & .7849900E-05,.1078500E-03,.1315200E-03,.1358800E-03,.8476200E-04,& + & .5564700E-05,.7594300E-04,.9369500E-04,.9390600E-04,.5500200E-04,& + & .5871900E-05,.8016700E-04,.9822900E-04,.9920400E-04,.5932900E-04,& + & .6121200E-05,.8424900E-04,.1028100E-03,.1047100E-03,.6377800E-04,& + & .6316200E-05,.8812200E-04,.1073800E-03,.1104100E-03,.6831800E-04,& + & .6455300E-05,.9183500E-04,.1120400E-03,.1161400E-03,.7290700E-04,& + & .4624600E-05,.6463300E-04,.7939800E-04,.7983100E-04,.4719000E-04,& + & .4862800E-05,.6825800E-04,.8338300E-04,.8452100E-04,.5095300E-04,& + & .5055700E-05,.7175800E-04,.8741800E-04,.8941700E-04,.5482300E-04,& + & .5203500E-05,.7509900E-04,.9148100E-04,.9442300E-04,.5878500E-04,& + & .5306800E-05,.7831700E-04,.9564600E-04,.9945200E-04,.6276600E-04,& + & .3840300E-05,.5507700E-04,.6741000E-04,.6802400E-04,.4053800E-04,& + & .4024400E-05,.5819900E-04,.7092400E-04,.7218000E-04,.4383900E-04,& + & .4173000E-05,.6120600E-04,.7447500E-04,.7650200E-04,.4722200E-04,& + & .4283500E-05,.6409100E-04,.7811400E-04,.8088300E-04,.5065200E-04,& + & .4360400E-05,.6689800E-04,.8179800E-04,.8529300E-04,.5410200E-04/ + + data absb(526:700, 6) / & + & .3180100E-05,.4688800E-04,.5723300E-04,.5794500E-04,.3478100E-04,& + & .3324400E-05,.4958600E-04,.6031900E-04,.6162500E-04,.3764600E-04,& + & .3438900E-05,.5218300E-04,.6346500E-04,.6542200E-04,.4060600E-04,& + & .3522800E-05,.5469600E-04,.6669700E-04,.6926600E-04,.4357100E-04,& + & .3580400E-05,.5716200E-04,.6996400E-04,.7312000E-04,.4656200E-04,& + & .2620000E-05,.3974200E-04,.4841000E-04,.4914100E-04,.2963900E-04,& + & .2735100E-05,.4207500E-04,.5112200E-04,.5238200E-04,.3214600E-04,& + & .2825300E-05,.4432500E-04,.5391600E-04,.5569800E-04,.3470100E-04,& + & .2890700E-05,.4653000E-04,.5676900E-04,.5906800E-04,.3728000E-04,& + & .2935400E-05,.4870700E-04,.5964900E-04,.6246100E-04,.3986400E-04,& + & .2146900E-05,.3349800E-04,.4074400E-04,.4142700E-04,.2504500E-04,& + & .2240700E-05,.3551300E-04,.4312400E-04,.4426200E-04,.2722700E-04,& + & .2314000E-05,.3748100E-04,.4558800E-04,.4715700E-04,.2943300E-04,& + & .2367300E-05,.3941900E-04,.4810900E-04,.5010700E-04,.3167200E-04,& + & .2403500E-05,.4134500E-04,.5064000E-04,.5308900E-04,.3391100E-04,& + & .1746400E-05,.2798400E-04,.3400700E-04,.3458400E-04,.2089900E-04,& + & .1825200E-05,.2973700E-04,.3608800E-04,.3705100E-04,.2278500E-04,& + & .1887700E-05,.3146000E-04,.3824700E-04,.3957300E-04,.2468700E-04,& + & .1933300E-05,.3316500E-04,.4046000E-04,.4214600E-04,.2662600E-04,& + & .1964700E-05,.3486900E-04,.4269100E-04,.4476500E-04,.2856100E-04,& + & .1419800E-05,.2336400E-04,.2836700E-04,.2885400E-04,.1742200E-04,& + & .1486200E-05,.2489200E-04,.3018600E-04,.3099400E-04,.1904700E-04,& + & .1539400E-05,.2639900E-04,.3207600E-04,.3319200E-04,.2068800E-04,& + & .1578600E-05,.2789800E-04,.3402000E-04,.3544100E-04,.2236000E-04,& + & .1605800E-05,.2940100E-04,.3598300E-04,.3773500E-04,.2403300E-04,& + & .1154100E-05,.1950900E-04,.2366300E-04,.2407200E-04,.1452100E-04,& + & .1210000E-05,.2083700E-04,.2525200E-04,.2592900E-04,.1591500E-04,& + & .1255100E-05,.2215500E-04,.2690200E-04,.2784200E-04,.1733100E-04,& + & .1288800E-05,.2347000E-04,.2860300E-04,.2980600E-04,.1877300E-04,& + & .1312300E-05,.2479400E-04,.3033100E-04,.3181500E-04,.2021600E-04,& + & .9324400E-06,.1617100E-04,.1959900E-04,.1991800E-04,.1197700E-04,& + & .9805900E-06,.1732400E-04,.2097600E-04,.2151900E-04,.1316900E-04,& + & .1019600E-05,.1847500E-04,.2241100E-04,.2317800E-04,.1438700E-04,& + & .1049600E-05,.1962600E-04,.2389700E-04,.2488700E-04,.1562500E-04,& + & .1070600E-05,.2079200E-04,.2541100E-04,.2664100E-04,.1687100E-04/ + + data absb(701:875, 6) / & + & .7520600E-06,.1338100E-04,.1620400E-04,.1644800E-04,.9858200E-05,& + & .7936800E-06,.1438000E-04,.1739500E-04,.1782400E-04,.1087300E-04,& + & .8274200E-06,.1538200E-04,.1864000E-04,.1925900E-04,.1191600E-04,& + & .8539000E-06,.1638800E-04,.1993500E-04,.2074500E-04,.1297900E-04,& + & .8728100E-06,.1741200E-04,.2126100E-04,.2227100E-04,.1405300E-04,& + & .6059100E-06,.1106100E-04,.1338500E-04,.1356800E-04,.8104500E-05,& + & .6418200E-06,.1192600E-04,.1441200E-04,.1475100E-04,.8966100E-05,& + & .6710100E-06,.1279700E-04,.1548900E-04,.1598700E-04,.9857800E-05,& + & .6942700E-06,.1367500E-04,.1661600E-04,.1727400E-04,.1077000E-04,& + & .7112200E-06,.1457300E-04,.1777400E-04,.1860100E-04,.1169000E-04,& + & .4856500E-06,.9092900E-05,.1099800E-04,.1112700E-04,.6613600E-05,& + & .5170300E-06,.9840100E-05,.1187800E-04,.1213600E-04,.7343100E-05,& + & .5424600E-06,.1059400E-04,.1280700E-04,.1319700E-04,.8101900E-05,& + & .5630900E-06,.1135900E-04,.1378200E-04,.1430600E-04,.8881200E-05,& + & .5785400E-06,.1214400E-04,.1479100E-04,.1545600E-04,.9668500E-05,& + & .3877700E-06,.7447800E-05,.9006200E-05,.9092100E-05,.5370900E-05,& + & .4152200E-06,.8091900E-05,.9757000E-05,.9947800E-05,.5988900E-05,& + & .4376100E-06,.8743300E-05,.1055500E-04,.1085600E-04,.6633200E-05,& + & .4558400E-06,.9406300E-05,.1139500E-04,.1180800E-04,.7295500E-05,& + & .4699000E-06,.1009100E-04,.1226900E-04,.1279900E-04,.7969600E-05,& + & .3088800E-06,.6089800E-05,.7363200E-05,.7418100E-05,.4353500E-05,& + & .3329100E-06,.6644000E-05,.8002300E-05,.8141600E-05,.4874100E-05,& + & .3525500E-06,.7205200E-05,.8685500E-05,.8915400E-05,.5420700E-05,& + & .3685400E-06,.7778700E-05,.9406800E-05,.9730800E-05,.5983300E-05,& + & .3812500E-06,.8374500E-05,.1016300E-04,.1058300E-04,.6557800E-05,& + & .2449400E-06,.4959800E-05,.5998700E-05,.6028900E-05,.3512300E-05,& + & .2659500E-06,.5435500E-05,.6541100E-05,.6638300E-05,.3949400E-05,& + & .2832800E-06,.5917300E-05,.7123300E-05,.7294300E-05,.4411300E-05,& + & .2973500E-06,.6412300E-05,.7740600E-05,.7990400E-05,.4888300E-05,& + & .3087600E-06,.6928300E-05,.8391300E-05,.8721100E-05,.5376600E-05,& + & .1928700E-06,.4013400E-05,.4858600E-05,.4871800E-05,.2811400E-05,& + & .2112300E-06,.4420800E-05,.5317800E-05,.5379400E-05,.3178100E-05,& + & .2265800E-06,.4833200E-05,.5810400E-05,.5933500E-05,.3564600E-05,& + & .2391200E-06,.5258200E-05,.6335400E-05,.6523000E-05,.3967600E-05,& + & .2493100E-06,.5702500E-05,.6892000E-05,.7145800E-05,.4382600E-05/ + + data absb(876:1050, 6) / & + & .1513200E-06,.3239500E-05,.3926900E-05,.3928900E-05,.2245800E-05,& + & .1671600E-06,.3586600E-05,.4314400E-05,.4351100E-05,.2551200E-05,& + & .1807600E-06,.3939100E-05,.4729400E-05,.4816100E-05,.2874600E-05,& + & .1919400E-06,.4303000E-05,.5174800E-05,.5314200E-05,.3213500E-05,& + & .2009900E-06,.4684200E-05,.5648800E-05,.5843000E-05,.3564400E-05,& + & .1182800E-06,.2607800E-05,.3167200E-05,.3161700E-05,.1789400E-05,& + & .1318500E-06,.2902900E-05,.3492900E-05,.3512500E-05,.2042300E-05,& + & .1437800E-06,.3203000E-05,.3840900E-05,.3900000E-05,.2312100E-05,& + & .1536900E-06,.3513900E-05,.4217900E-05,.4319800E-05,.2597100E-05,& + & .1617600E-06,.3839100E-05,.4619800E-05,.4766700E-05,.2892900E-05,& + & .9236200E-07,.2099700E-05,.2555600E-05,.2547100E-05,.1426700E-05,& + & .1039000E-06,.2349600E-05,.2828600E-05,.2836800E-05,.1635600E-05,& + & .1142100E-06,.2604900E-05,.3121300E-05,.3160600E-05,.1860900E-05,& + & .1229700E-06,.2869400E-05,.3439200E-05,.3512500E-05,.2099600E-05,& + & .1301200E-06,.3147100E-05,.3779400E-05,.3890000E-05,.2348600E-05,& + & .7202900E-07,.1687900E-05,.2060600E-05,.2050600E-05,.1136500E-05,& + & .8171700E-07,.1899400E-05,.2288600E-05,.2290200E-05,.1308100E-05,& + & .9054700E-07,.2116200E-05,.2534700E-05,.2558800E-05,.1496400E-05,& + & .9823100E-07,.2340700E-05,.2801700E-05,.2853700E-05,.1695800E-05,& + & .1045400E-06,.2577000E-05,.3089100E-05,.3171900E-05,.1905300E-05,& + & .5599400E-07,.1353500E-05,.1658300E-05,.1648300E-05,.9021500E-06,& + & .6406500E-07,.1531800E-05,.1848300E-05,.1845200E-05,.1044700E-05,& + & .7160100E-07,.1715600E-05,.2054100E-05,.2067900E-05,.1200500E-05,& + & .7826500E-07,.1905500E-05,.2278600E-05,.2315100E-05,.1367300E-05,& + & .8382700E-07,.2106200E-05,.2520100E-05,.2581200E-05,.1542600E-05,& + & .4337600E-07,.1082300E-05,.1331600E-05,.1322900E-05,.7138700E-06,& + & .5007800E-07,.1232000E-05,.1489800E-05,.1484300E-05,.8319600E-06,& + & .5644000E-07,.1387300E-05,.1661200E-05,.1667800E-05,.9608500E-06,& + & .6218800E-07,.1548100E-05,.1848900E-05,.1873600E-05,.1099500E-05,& + & .6707200E-07,.1717900E-05,.2052000E-05,.2096400E-05,.1246500E-05,& + & .3366200E-07,.8668500E-06,.1071200E-05,.1063800E-05,.5667500E-06,& + & .3918800E-07,.9923700E-06,.1202400E-05,.1196500E-05,.6640700E-06,& + & .4451700E-07,.1123400E-05,.1345300E-05,.1347700E-05,.7701500E-06,& + & .4941000E-07,.1259100E-05,.1502200E-05,.1518600E-05,.8856800E-06,& + & .5366200E-07,.1402800E-05,.1673200E-05,.1705400E-05,.1008800E-05/ + + data absb(1051:1175, 6) / & + & .2610700E-07,.6940900E-06,.8614800E-06,.8553500E-06,.4499300E-06,& + & .3064800E-07,.7987400E-06,.9705000E-06,.9643200E-06,.5298700E-06,& + & .3507000E-07,.9091900E-06,.1089300E-05,.1088900E-05,.6172700E-06,& + & .3922300E-07,.1023700E-05,.1220600E-05,.1230800E-05,.7134500E-06,& + & .4289700E-07,.1145000E-05,.1364100E-05,.1387800E-05,.8161400E-06,& + & .2018300E-07,.5546100E-06,.6918700E-06,.6868600E-06,.3563400E-06,& + & .2390600E-07,.6414300E-06,.7819300E-06,.7761500E-06,.4213300E-06,& + & .2757300E-07,.7342200E-06,.8805900E-06,.8784800E-06,.4938700E-06,& + & .3106600E-07,.8308300E-06,.9900100E-06,.9960400E-06,.5736200E-06,& + & .3421300E-07,.9330200E-06,.1110300E-05,.1127100E-05,.6590600E-06,& + & .1555300E-07,.4422100E-06,.5547500E-06,.5505100E-06,.2815800E-06,& + & .1859700E-07,.5138700E-06,.6288300E-06,.6238100E-06,.3343200E-06,& + & .2162700E-07,.5916500E-06,.7107900E-06,.7076800E-06,.3942300E-06,& + & .2454800E-07,.6728600E-06,.8015900E-06,.8045100E-06,.4600900E-06,& + & .2722300E-07,.7587000E-06,.9019600E-06,.9137200E-06,.5312600E-06,& + & .1198900E-07,.3527100E-06,.4450400E-06,.4416400E-06,.2224700E-06,& + & .1447300E-07,.4116700E-06,.5059300E-06,.5017900E-06,.2655700E-06,& + & .1695900E-07,.4768100E-06,.5738900E-06,.5705500E-06,.3148800E-06,& + & .1938600E-07,.5450300E-06,.6493300E-06,.6504300E-06,.3692700E-06,& + & .2165500E-07,.6170500E-06,.7328500E-06,.7409200E-06,.4282300E-06,& + & .9574500E-08,.2890900E-06,.3650400E-06,.3622100E-06,.1814300E-06,& + & .1160200E-07,.3386900E-06,.4162500E-06,.4126700E-06,.2175400E-06,& + & .1363900E-07,.3936300E-06,.4734500E-06,.4705300E-06,.2587300E-06,& + & .1563500E-07,.4513200E-06,.5372200E-06,.5377900E-06,.3043600E-06,& + & .1751500E-07,.5125500E-06,.6080400E-06,.6144500E-06,.3539500E-06/ + + data absb( 1:175, 7) / & + & .1381800E-02,.5309500E-02,.6174400E-02,.6140900E-02,.3820100E-02,& + & .1492700E-02,.5426200E-02,.6316900E-02,.6326800E-02,.3978700E-02,& + & .1588200E-02,.5524500E-02,.6457500E-02,.6504200E-02,.4128500E-02,& + & .1668300E-02,.5602800E-02,.6585900E-02,.6676400E-02,.4276600E-02,& + & .1736400E-02,.5664200E-02,.6699600E-02,.6840000E-02,.4419600E-02,& + & .1143900E-02,.4464200E-02,.5205200E-02,.5195400E-02,.3218500E-02,& + & .1232200E-02,.4561200E-02,.5329500E-02,.5355400E-02,.3354400E-02,& + & .1308200E-02,.4642500E-02,.5447400E-02,.5511100E-02,.3486900E-02,& + & .1372300E-02,.4707800E-02,.5556800E-02,.5660500E-02,.3617800E-02,& + & .1427300E-02,.4761400E-02,.5653600E-02,.5800400E-02,.3744500E-02,& + & .9460000E-03,.3745200E-02,.4378600E-02,.4383900E-02,.2706400E-02,& + & .1016600E-02,.3827200E-02,.4484500E-02,.4523800E-02,.2825900E-02,& + & .1077200E-02,.3895100E-02,.4585200E-02,.4656900E-02,.2942400E-02,& + & .1128700E-02,.3950800E-02,.4677600E-02,.4785600E-02,.3057300E-02,& + & .1172700E-02,.3998400E-02,.4763900E-02,.4909400E-02,.3170700E-02,& + & .7817000E-03,.3138600E-02,.3675300E-02,.3692500E-02,.2274900E-02,& + & .8382800E-03,.3206700E-02,.3765500E-02,.3810800E-02,.2379100E-02,& + & .8867700E-03,.3263600E-02,.3852400E-02,.3926700E-02,.2480900E-02,& + & .9281400E-03,.3312700E-02,.3933200E-02,.4038900E-02,.2581900E-02,& + & .9634200E-03,.3356100E-02,.4012300E-02,.4149300E-02,.2682500E-02,& + & .6451300E-03,.2625800E-02,.3079200E-02,.3102700E-02,.1910900E-02,& + & .6906500E-03,.2683000E-02,.3157300E-02,.3205600E-02,.2001300E-02,& + & .7295100E-03,.2732100E-02,.3232600E-02,.3306100E-02,.2090500E-02,& + & .7627900E-03,.2775900E-02,.3305700E-02,.3404900E-02,.2179100E-02,& + & .7912700E-03,.2816400E-02,.3377600E-02,.3503700E-02,.2268000E-02,& + & .5321600E-03,.2194500E-02,.2576800E-02,.2604100E-02,.1604700E-02,& + & .5687800E-03,.2243100E-02,.2645300E-02,.2693400E-02,.1682900E-02,& + & .6000200E-03,.2286400E-02,.2712100E-02,.2781200E-02,.1760500E-02,& + & .6266600E-03,.2326500E-02,.2777800E-02,.2868900E-02,.1838900E-02,& + & .6495600E-03,.2364500E-02,.2843600E-02,.2958700E-02,.1917500E-02,& + & .4387800E-03,.1832800E-02,.2155500E-02,.2184400E-02,.1347000E-02,& + & .4683200E-03,.1874900E-02,.2216000E-02,.2261900E-02,.1414700E-02,& + & .4933700E-03,.1913600E-02,.2275200E-02,.2339500E-02,.1483400E-02,& + & .5148300E-03,.1950900E-02,.2334400E-02,.2417700E-02,.1552600E-02,& + & .5332100E-03,.1986300E-02,.2395000E-02,.2498300E-02,.1622800E-02/ + + data absb(176:350, 7) / & + & .3621800E-03,.1531000E-02,.1804400E-02,.1833300E-02,.1132000E-02,& + & .3858700E-03,.1568100E-02,.1857300E-02,.1901000E-02,.1191100E-02,& + & .4059900E-03,.1603400E-02,.1910500E-02,.1969300E-02,.1251600E-02,& + & .4232700E-03,.1637200E-02,.1964200E-02,.2040000E-02,.1313300E-02,& + & .4380000E-03,.1670200E-02,.2019600E-02,.2112000E-02,.1376000E-02,& + & .2989400E-03,.1279400E-02,.1510900E-02,.1539200E-02,.9519600E-03,& + & .3179500E-03,.1312600E-02,.1557800E-02,.1598500E-02,.1004100E-02,& + & .3340900E-03,.1344400E-02,.1605400E-02,.1659000E-02,.1057500E-02,& + & .3479800E-03,.1375200E-02,.1654200E-02,.1722800E-02,.1112400E-02,& + & .3598200E-03,.1406200E-02,.1704600E-02,.1787200E-02,.1168800E-02,& + & .2477900E-03,.1072000E-02,.1268700E-02,.1295900E-02,.8042800E-03,& + & .2628700E-03,.1101200E-02,.1310400E-02,.1348300E-02,.8504600E-03,& + & .2757000E-03,.1130000E-02,.1353200E-02,.1403200E-02,.8979600E-03,& + & .2867600E-03,.1158300E-02,.1397800E-02,.1460200E-02,.9472200E-03,& + & .2961200E-03,.1187300E-02,.1443900E-02,.1518500E-02,.9981200E-03,& + & .2053600E-03,.8990100E-03,.1066600E-02,.1092500E-02,.6807700E-03,& + & .2173200E-03,.9251400E-03,.1103700E-02,.1139400E-02,.7218900E-03,& + & .2275200E-03,.9510900E-03,.1142600E-02,.1188800E-02,.7643700E-03,& + & .2363200E-03,.9772800E-03,.1183200E-02,.1240300E-02,.8087700E-03,& + & .2436900E-03,.1004000E-02,.1226000E-02,.1293400E-02,.8548900E-03,& + & .1702100E-03,.7550600E-03,.8980000E-03,.9226500E-03,.5778800E-03,& + & .1796900E-03,.7785300E-03,.9314900E-03,.9649700E-03,.6144300E-03,& + & .1877800E-03,.8020700E-03,.9668000E-03,.1009700E-02,.6527800E-03,& + & .1947700E-03,.8262200E-03,.1004100E-02,.1056400E-02,.6929300E-03,& + & .2005500E-03,.8510400E-03,.1043900E-02,.1105300E-02,.7342400E-03,& + & .1411000E-03,.6353100E-03,.7574600E-03,.7810900E-03,.4919500E-03,& + & .1486000E-03,.6562900E-03,.7880100E-03,.8195100E-03,.5247200E-03,& + & .1550200E-03,.6780200E-03,.8201800E-03,.8600500E-03,.5592900E-03,& + & .1605400E-03,.7002300E-03,.8548700E-03,.9027000E-03,.5954600E-03,& + & .1650600E-03,.7233300E-03,.8921300E-03,.9479400E-03,.6329600E-03,& + & .1170400E-03,.5356300E-03,.6408900E-03,.6634800E-03,.4203600E-03,& + & .1229600E-03,.5548200E-03,.6685900E-03,.6984200E-03,.4498600E-03,& + & .1280400E-03,.5746000E-03,.6983800E-03,.7353200E-03,.4811500E-03,& + & .1323700E-03,.5952800E-03,.7308100E-03,.7747200E-03,.5137100E-03,& + & .1358700E-03,.6170800E-03,.7656200E-03,.8164900E-03,.5480000E-03/ + + data absb(351:525, 7) / & + & .9703700E-04,.4526300E-03,.5435300E-03,.5652800E-03,.3603100E-03,& + & .1017100E-03,.4701800E-03,.5689900E-03,.5971000E-03,.3869800E-03,& + & .1057200E-03,.4883300E-03,.5967500E-03,.6309600E-03,.4150500E-03,& + & .1091100E-03,.5076700E-03,.6271300E-03,.6673600E-03,.4446600E-03,& + & .1118200E-03,.5283000E-03,.6594900E-03,.7060000E-03,.4762500E-03,& + & .8041900E-04,.3834900E-03,.4622400E-03,.4830800E-03,.3098200E-03,& + & .8411000E-04,.3994300E-03,.4858400E-03,.5121400E-03,.3338600E-03,& + & .8728300E-04,.4163600E-03,.5118900E-03,.5435300E-03,.3592400E-03,& + & .8991400E-04,.4345600E-03,.5402000E-03,.5769800E-03,.3863500E-03,& + & .9200300E-04,.4540600E-03,.5703000E-03,.6128600E-03,.4155300E-03,& + & .6663700E-04,.3258000E-03,.3945300E-03,.4143900E-03,.2673800E-03,& + & .6955200E-04,.3405200E-03,.4166000E-03,.4411600E-03,.2890400E-03,& + & .7204200E-04,.3563300E-03,.4410200E-03,.4700500E-03,.3121800E-03,& + & .7408200E-04,.3735100E-03,.4673100E-03,.5010800E-03,.3371400E-03,& + & .7569200E-04,.3919000E-03,.4952900E-03,.5344700E-03,.3642100E-03,& + & .5519400E-04,.2775700E-03,.3380400E-03,.3567000E-03,.2314800E-03,& + & .5748900E-04,.2913000E-03,.3587600E-03,.3814300E-03,.2511500E-03,& + & .5944500E-04,.3061900E-03,.3814800E-03,.4081000E-03,.2724200E-03,& + & .6102400E-04,.3223300E-03,.4057800E-03,.4369800E-03,.2955200E-03,& + & .6225100E-04,.3396900E-03,.4318500E-03,.4683000E-03,.3205200E-03,& + & .4570100E-04,.2373600E-03,.2908600E-03,.3083400E-03,.2011400E-03,& + & .4751600E-04,.2502000E-03,.3103200E-03,.3311300E-03,.2191600E-03,& + & .4903400E-04,.2642400E-03,.3313100E-03,.3559300E-03,.2387400E-03,& + & .5024700E-04,.2794300E-03,.3539500E-03,.3829900E-03,.2602400E-03,& + & .5118600E-04,.2957800E-03,.3782900E-03,.4125000E-03,.2834100E-03,& + & .3782900E-04,.2037900E-03,.2514500E-03,.2676100E-03,.1754900E-03,& + & .3925600E-04,.2158500E-03,.2695100E-03,.2887100E-03,.1920700E-03,& + & .4043400E-04,.2290400E-03,.2890300E-03,.3119200E-03,.2103400E-03,& + & .4136700E-04,.2433200E-03,.3102000E-03,.3374400E-03,.2302400E-03,& + & .4207200E-04,.2587300E-03,.3330900E-03,.3652700E-03,.2517900E-03,& + & .3130200E-04,.1757200E-03,.2183000E-03,.2332100E-03,.1537500E-03,& + & .3241900E-04,.1870600E-03,.2350400E-03,.2529100E-03,.1691500E-03,& + & .3332700E-04,.1994000E-03,.2532800E-03,.2747900E-03,.1861700E-03,& + & .3403900E-04,.2128300E-03,.2731500E-03,.2988700E-03,.2046500E-03,& + & .3456800E-04,.2273100E-03,.2947400E-03,.3251900E-03,.2248500E-03/ + + data absb(526:700, 7) / & + & .2585100E-04,.1518200E-03,.1897600E-03,.2035300E-03,.1348300E-03,& + & .2673100E-04,.1624100E-03,.2053100E-03,.2219900E-03,.1491800E-03,& + & .2743700E-04,.1739500E-03,.2223700E-03,.2425800E-03,.1649100E-03,& + & .2798800E-04,.1865600E-03,.2411300E-03,.2652900E-03,.1821700E-03,& + & .2838400E-04,.2001700E-03,.2614400E-03,.2902000E-03,.2011600E-03,& + & .2127100E-04,.1307800E-03,.1642600E-03,.1768500E-03,.1175600E-03,& + & .2197500E-04,.1405800E-03,.1786500E-03,.1940300E-03,.1307200E-03,& + & .2253300E-04,.1513200E-03,.1945600E-03,.2132300E-03,.1452300E-03,& + & .2296600E-04,.1630700E-03,.2120600E-03,.2345400E-03,.1613300E-03,& + & .2327400E-04,.1757900E-03,.2311200E-03,.2580000E-03,.1791100E-03,& + & .1743100E-04,.1120500E-03,.1412800E-03,.1526000E-03,.1016100E-03,& + & .1800400E-04,.1210300E-03,.1544800E-03,.1684000E-03,.1135600E-03,& + & .1845800E-04,.1309500E-03,.1691800E-03,.1861600E-03,.1268700E-03,& + & .1881000E-04,.1418200E-03,.1853900E-03,.2059600E-03,.1417900E-03,& + & .1905900E-04,.1536300E-03,.2031700E-03,.2278800E-03,.1583100E-03,& + & .1420400E-04,.9501000E-04,.1200800E-03,.1299600E-03,.8648200E-04,& + & .1468500E-04,.1031300E-03,.1320000E-03,.1442600E-03,.9717900E-04,& + & .1506900E-04,.1121400E-03,.1453600E-03,.1604200E-03,.1092200E-03,& + & .1536900E-04,.1221100E-03,.1602000E-03,.1785500E-03,.1228200E-03,& + & .1558600E-04,.1329600E-03,.1766100E-03,.1987600E-03,.1379700E-03,& + & .1157100E-04,.8054500E-04,.1020600E-03,.1106300E-03,.7356300E-04,& + & .1197600E-04,.8787500E-04,.1128100E-03,.1235700E-03,.8314900E-04,& + & .1230100E-04,.9606300E-04,.1249500E-03,.1382900E-03,.9402600E-04,& + & .1255700E-04,.1051800E-03,.1385100E-03,.1548700E-03,.1064200E-03,& + & .1274400E-04,.1151500E-03,.1536400E-03,.1735200E-03,.1202900E-03,& + & .9425400E-05,.6833300E-04,.8679800E-04,.9424700E-04,.6260400E-04,& + & .9765700E-05,.7494500E-04,.9649500E-04,.1059500E-03,.7118500E-04,& + & .1004100E-04,.8237600E-04,.1075200E-03,.1193400E-03,.8102200E-04,& + & .1025800E-04,.9068700E-04,.1199200E-03,.1345300E-03,.9231500E-04,& + & .1041900E-04,.9985200E-04,.1338700E-03,.1517700E-03,.1050400E-03,& + & .7645200E-05,.5742800E-04,.7302100E-04,.7933300E-04,.5256800E-04,& + & .7935400E-05,.6331500E-04,.8165000E-04,.8975200E-04,.6014400E-04,& + & .8173900E-05,.6996100E-04,.9154200E-04,.1017600E-03,.6890500E-04,& + & .8362600E-05,.7745600E-04,.1027500E-03,.1155200E-03,.7905900E-04,& + & .8506400E-05,.8579500E-04,.1154200E-03,.1312800E-03,.9057800E-04/ + + data absb(701:875, 7) / & + & .6195300E-05,.4816300E-04,.6128700E-04,.6661600E-04,.4401100E-04,& + & .6441800E-05,.5338300E-04,.6893400E-04,.7584200E-04,.5067000E-04,& + & .6648400E-05,.5931200E-04,.7778500E-04,.8658000E-04,.5844800E-04,& + & .6813400E-05,.6605400E-04,.8787600E-04,.9899500E-04,.6754300E-04,& + & .6940200E-05,.7361400E-04,.9937800E-04,.1133700E-03,.7794200E-04,& + & .5017000E-05,.4035800E-04,.5137800E-04,.5587500E-04,.3679400E-04,& + & .5226600E-05,.4497100E-04,.5814100E-04,.6402400E-04,.4263900E-04,& + & .5404600E-05,.5025000E-04,.6603400E-04,.7360100E-04,.4952700E-04,& + & .5548400E-05,.5630200E-04,.7511100E-04,.8478800E-04,.5765400E-04,& + & .5660000E-05,.6315300E-04,.8555100E-04,.9789800E-04,.6704000E-04,& + & .4049800E-05,.3356300E-04,.4271600E-04,.4643300E-04,.3044700E-04,& + & .4229100E-05,.3760300E-04,.4861900E-04,.5355100E-04,.3551600E-04,& + & .4383300E-05,.4226000E-04,.5558500E-04,.6199900E-04,.4154900E-04,& + & .4509900E-05,.4765000E-04,.6366800E-04,.7196400E-04,.4872800E-04,& + & .4609600E-05,.5379000E-04,.7305300E-04,.8377900E-04,.5710500E-04,& + & .3261600E-05,.2778100E-04,.3533500E-04,.3836600E-04,.2503200E-04,& + & .3416400E-05,.3129600E-04,.4044400E-04,.4453100E-04,.2939900E-04,& + & .3549100E-05,.3537500E-04,.4654000E-04,.5192500E-04,.3463300E-04,& + & .3661000E-05,.4014600E-04,.5368700E-04,.6073800E-04,.4093500E-04,& + & .3750000E-05,.4561800E-04,.6206100E-04,.7129800E-04,.4835600E-04,& + & .2623800E-05,.2295200E-04,.2916200E-04,.3163000E-04,.2052200E-04,& + & .2757100E-05,.2599200E-04,.3356700E-04,.3693800E-04,.2426800E-04,& + & .2871300E-05,.2954900E-04,.3888100E-04,.4338300E-04,.2879200E-04,& + & .2969300E-05,.3376000E-04,.4517700E-04,.5114900E-04,.3430300E-04,& + & .3048200E-05,.3862700E-04,.5262400E-04,.6055100E-04,.4085700E-04,& + & .2105100E-05,.1886700E-04,.2393500E-04,.2591700E-04,.1671000E-04,& + & .2220600E-05,.2148000E-04,.2770500E-04,.3044900E-04,.1989300E-04,& + & .2319100E-05,.2455700E-04,.3229800E-04,.3601900E-04,.2376900E-04,& + & .2404600E-05,.2823900E-04,.3779800E-04,.4280700E-04,.2854500E-04,& + & .2474600E-05,.3254300E-04,.4437400E-04,.5110900E-04,.3429900E-04,& + & .1681700E-05,.1538600E-04,.1946400E-04,.2102400E-04,.1345500E-04,& + & .1782200E-05,.1760500E-04,.2265200E-04,.2484000E-04,.1612400E-04,& + & .1868000E-05,.2023600E-04,.2656700E-04,.2958500E-04,.1940100E-04,& + & .1942300E-05,.2341300E-04,.3131700E-04,.3543300E-04,.2347600E-04,& + & .2004900E-05,.2718100E-04,.3705400E-04,.4266800E-04,.2846600E-04/ + + data absb(876:1050, 7) / & + & .1340500E-05,.1251400E-04,.1577900E-04,.1699300E-04,.1079100E-04,& + & .1428000E-05,.1438500E-04,.1846000E-04,.2018700E-04,.1301700E-04,& + & .1502600E-05,.1662300E-04,.2177300E-04,.2420500E-04,.1576800E-04,& + & .1567100E-05,.1935400E-04,.2585400E-04,.2921800E-04,.1922700E-04,& + & .1622400E-05,.2262900E-04,.3083300E-04,.3547900E-04,.2352500E-04,& + & .1066400E-05,.1014900E-04,.1275100E-04,.1368400E-04,.8618800E-05,& + & .1141800E-05,.1172000E-04,.1499900E-04,.1635200E-04,.1046700E-04,& + & .1206900E-05,.1361200E-04,.1778000E-04,.1971600E-04,.1275900E-04,& + & .1263000E-05,.1594500E-04,.2126200E-04,.2399000E-04,.1567600E-04,& + & .1311300E-05,.1877500E-04,.2556000E-04,.2938200E-04,.1935200E-04,& + & .8480800E-06,.8240100E-05,.1031800E-04,.1103600E-04,.6893900E-05,& + & .9126900E-06,.9551300E-05,.1218900E-04,.1324700E-04,.8420900E-05,& + & .9692800E-06,.1116000E-04,.1453900E-04,.1608400E-04,.1033600E-04,& + & .1017700E-05,.1314600E-04,.1749800E-04,.1971100E-04,.1279000E-04,& + & .1059500E-05,.1559200E-04,.2120700E-04,.2435600E-04,.1592900E-04,& + & .6737800E-06,.6682600E-05,.8338100E-05,.8882800E-05,.5505200E-05,& + & .7287300E-06,.7775300E-05,.9890500E-05,.1071400E-04,.6763600E-05,& + & .7776300E-06,.9136800E-05,.1186600E-04,.1309100E-04,.8355900E-05,& + & .8195300E-06,.1082400E-04,.1437800E-04,.1616800E-04,.1041700E-04,& + & .8556100E-06,.1293300E-04,.1757100E-04,.2015900E-04,.1308700E-04,& + & .5344400E-06,.5406600E-05,.6719700E-05,.7129700E-05,.4381400E-05,& + & .5809500E-06,.6312400E-05,.7998900E-05,.8634600E-05,.5412200E-05,& + & .6228200E-06,.7456100E-05,.9648900E-05,.1061400E-04,.6728900E-05,& + & .6591300E-06,.8891700E-05,.1178000E-04,.1322000E-04,.8449700E-05,& + & .6903200E-06,.1069100E-04,.1450400E-04,.1661500E-04,.1070600E-04,& + & .4230900E-06,.4363500E-05,.5401700E-05,.5704700E-05,.3473300E-05,& + & .4622300E-06,.5109700E-05,.6446500E-05,.6932200E-05,.4312000E-05,& + & .4979100E-06,.6064300E-05,.7816600E-05,.8569000E-05,.5394800E-05,& + & .5294200E-06,.7272600E-05,.9604200E-05,.1074800E-04,.6821100E-05,& + & .5563500E-06,.8807400E-05,.1192400E-04,.1363200E-04,.8717600E-05,& + & .3352500E-06,.3529100E-05,.4353300E-05,.4578300E-05,.2761800E-05,& + & .3680100E-06,.4146400E-05,.5209800E-05,.5582100E-05,.3446800E-05,& + & .3983000E-06,.4944200E-05,.6349500E-05,.6939300E-05,.4339000E-05,& + & .4253000E-06,.5963800E-05,.7852000E-05,.8765200E-05,.5523800E-05,& + & .4485000E-06,.7271100E-05,.9825600E-05,.1121300E-04,.7118000E-05/ + + data absb(1051:1175, 7) / & + & .2656100E-06,.2853500E-05,.3509100E-05,.3674700E-05,.2195300E-05,& + & .2929900E-06,.3363000E-05,.4209300E-05,.4493500E-05,.2754300E-05,& + & .3185500E-06,.4028600E-05,.5155500E-05,.5616000E-05,.3488500E-05,& + & .3414900E-06,.4888400E-05,.6416600E-05,.7143200E-05,.4471200E-05,& + & .3614900E-06,.6008200E-05,.8105300E-05,.9233800E-05,.5811400E-05,& + & .2101700E-06,.2301900E-05,.2821700E-05,.2942000E-05,.1740300E-05,& + & .2329400E-06,.2721500E-05,.3392200E-05,.3607000E-05,.2194300E-05,& + & .2543600E-06,.3273200E-05,.4172000E-05,.4529100E-05,.2795000E-05,& + & .2738300E-06,.3995100E-05,.5225200E-05,.5799000E-05,.3605400E-05,& + & .2910600E-06,.4942900E-05,.6651800E-05,.7561300E-05,.4724600E-05,& + & .1660800E-06,.1853100E-05,.2263900E-05,.2350400E-05,.1376000E-05,& + & .1848800E-06,.2197100E-05,.2727100E-05,.2887000E-05,.1742100E-05,& + & .2027900E-06,.2652000E-05,.3365900E-05,.3639200E-05,.2231600E-05,& + & .2193100E-06,.3254300E-05,.4239100E-05,.4689100E-05,.2894900E-05,& + & .2340400E-06,.4052700E-05,.5438000E-05,.6164900E-05,.3823400E-05,& + & .1313100E-06,.1492700E-05,.1817900E-05,.1878700E-05,.1089300E-05,& + & .1467700E-06,.1774800E-05,.2194600E-05,.2312200E-05,.1383900E-05,& + & .1617100E-06,.2149400E-05,.2717100E-05,.2925600E-05,.1782700E-05,& + & .1756700E-06,.2651400E-05,.3440700E-05,.3792300E-05,.2326900E-05,& + & .1881600E-06,.3323700E-05,.4446600E-05,.5028000E-05,.3095800E-05,& + & .1059900E-06,.1237400E-05,.1506000E-05,.1554300E-05,.8975000E-06,& + & .1186800E-06,.1479500E-05,.1828500E-05,.1925100E-05,.1147900E-05,& + & .1309800E-06,.1804200E-05,.2280700E-05,.2455200E-05,.1489700E-05,& + & .1425200E-06,.2243900E-05,.2915200E-05,.3216300E-05,.1962200E-05,& + & .1529100E-06,.2839600E-05,.3808700E-05,.4313800E-05,.2638700E-05/ + + data absb( 1:175, 8) / & + & .8367300E-02,.1745400E-01,.2021300E-01,.2013200E-01,.1381000E-01,& + & .8503900E-02,.1782400E-01,.2068400E-01,.2061600E-01,.1421900E-01,& + & .8612900E-02,.1819600E-01,.2116300E-01,.2114300E-01,.1461600E-01,& + & .8691300E-02,.1856300E-01,.2163500E-01,.2167400E-01,.1499100E-01,& + & .8730100E-02,.1891600E-01,.2210300E-01,.2219800E-01,.1535100E-01,& + & .6934600E-02,.1495200E-01,.1738000E-01,.1734200E-01,.1180300E-01,& + & .7032800E-02,.1527600E-01,.1780800E-01,.1783000E-01,.1218100E-01,& + & .7111300E-02,.1560400E-01,.1824000E-01,.1832100E-01,.1254400E-01,& + & .7158000E-02,.1593700E-01,.1866700E-01,.1881400E-01,.1288400E-01,& + & .7178500E-02,.1622800E-01,.1909300E-01,.1929900E-01,.1323000E-01,& + & .5730700E-02,.1276300E-01,.1489000E-01,.1491200E-01,.1007300E-01,& + & .5801700E-02,.1305200E-01,.1527800E-01,.1537000E-01,.1041700E-01,& + & .5853300E-02,.1334700E-01,.1566600E-01,.1582800E-01,.1074200E-01,& + & .5882600E-02,.1362800E-01,.1605700E-01,.1628900E-01,.1106600E-01,& + & .5893300E-02,.1387300E-01,.1644400E-01,.1673900E-01,.1138800E-01,& + & .4724700E-02,.1086300E-01,.1272300E-01,.1278800E-01,.8582200E-02,& + & .4775500E-02,.1112400E-01,.1307600E-01,.1321100E-01,.8890700E-02,& + & .4809500E-02,.1138500E-01,.1343100E-01,.1364100E-01,.9190300E-02,& + & .4828300E-02,.1162200E-01,.1379000E-01,.1406600E-01,.9491200E-02,& + & .4833300E-02,.1184100E-01,.1413500E-01,.1448700E-01,.9793800E-02,& + & .3888100E-02,.9231300E-02,.1084800E-01,.1094200E-01,.7300600E-02,& + & .3923800E-02,.9460100E-02,.1117100E-01,.1133300E-01,.7579200E-02,& + & .3946800E-02,.9687400E-02,.1150000E-01,.1173200E-01,.7856000E-02,& + & .3959000E-02,.9896200E-02,.1182600E-01,.1212900E-01,.8137600E-02,& + & .3961200E-02,.1009400E-01,.1214400E-01,.1252100E-01,.8429300E-02,& + & .3195300E-02,.7830900E-02,.9236100E-02,.9352300E-02,.6204800E-02,& + & .3220800E-02,.8037200E-02,.9535000E-02,.9714800E-02,.6459000E-02,& + & .3236500E-02,.8234200E-02,.9838200E-02,.1008200E-01,.6715400E-02,& + & .3244700E-02,.8422900E-02,.1013800E-01,.1045000E-01,.6983800E-02,& + & .3245000E-02,.8606100E-02,.1042700E-01,.1081400E-01,.7262600E-02,& + & .2623500E-02,.6639900E-02,.7859900E-02,.7987500E-02,.5272800E-02,& + & .2641400E-02,.6823100E-02,.8135100E-02,.8323000E-02,.5507000E-02,& + & .2653000E-02,.7000400E-02,.8413800E-02,.8662900E-02,.5746800E-02,& + & .2658300E-02,.7175600E-02,.8688700E-02,.9002900E-02,.6000600E-02,& + & .2657300E-02,.7345700E-02,.8954900E-02,.9342200E-02,.6265800E-02/ + + data absb(176:350, 8) / & + & .2152800E-02,.5630000E-02,.6692800E-02,.6827500E-02,.4488700E-02,& + & .2165900E-02,.5796500E-02,.6948300E-02,.7137400E-02,.4704400E-02,& + & .2174200E-02,.5961700E-02,.7203600E-02,.7450300E-02,.4931400E-02,& + & .2177700E-02,.6125100E-02,.7456200E-02,.7765700E-02,.5170000E-02,& + & .2175700E-02,.6285000E-02,.7706500E-02,.8089100E-02,.5422500E-02,& + & .1765900E-02,.4777800E-02,.5705400E-02,.5841700E-02,.3827100E-02,& + & .1775400E-02,.4929900E-02,.5939300E-02,.6125700E-02,.4026400E-02,& + & .1781700E-02,.5083600E-02,.6175000E-02,.6414800E-02,.4239700E-02,& + & .1783600E-02,.5237000E-02,.6408300E-02,.6712500E-02,.4464700E-02,& + & .1781100E-02,.5387600E-02,.6648000E-02,.7020100E-02,.4707600E-02,& + & .1448600E-02,.4067900E-02,.4882600E-02,.5020500E-02,.3280500E-02,& + & .1455400E-02,.4208500E-02,.5098000E-02,.5282700E-02,.3466900E-02,& + & .1459700E-02,.4351500E-02,.5315300E-02,.5553500E-02,.3667400E-02,& + & .1460600E-02,.4495700E-02,.5535300E-02,.5837600E-02,.3881600E-02,& + & .1457700E-02,.4638300E-02,.5767200E-02,.6130200E-02,.4115600E-02,& + & .1188000E-02,.3469800E-02,.4186100E-02,.4324800E-02,.2819900E-02,& + & .1192900E-02,.3601000E-02,.4386200E-02,.4568900E-02,.2995600E-02,& + & .1195800E-02,.3734400E-02,.4587700E-02,.4827300E-02,.3184300E-02,& + & .1195900E-02,.3869700E-02,.4800700E-02,.5096500E-02,.3390300E-02,& + & .1192900E-02,.4006800E-02,.5023200E-02,.5379100E-02,.3613600E-02,& + & .9740600E-03,.2967500E-02,.3600600E-02,.3737900E-02,.2434400E-02,& + & .9775600E-03,.3089600E-02,.3785000E-02,.3968600E-02,.2599400E-02,& + & .9794600E-03,.3215000E-02,.3977500E-02,.4213500E-02,.2777600E-02,& + & .9789900E-03,.3343000E-02,.4182500E-02,.4470800E-02,.2975300E-02,& + & .9761500E-03,.3476100E-02,.4396600E-02,.4745700E-02,.3190000E-02,& + & .7985600E-03,.2545900E-02,.3107700E-02,.3244700E-02,.2111400E-02,& + & .8011000E-03,.2660500E-02,.3280500E-02,.3464000E-02,.2266400E-02,& + & .8022200E-03,.2777800E-02,.3466600E-02,.3695800E-02,.2437600E-02,& + & .8012900E-03,.2901400E-02,.3662300E-02,.3944400E-02,.2626900E-02,& + & .7985700E-03,.3030200E-02,.3869800E-02,.4212600E-02,.2833500E-02,& + & .6546000E-03,.2193300E-02,.2694400E-02,.2833400E-02,.1841700E-02,& + & .6563900E-03,.2300300E-02,.2859900E-02,.3040900E-02,.1988600E-02,& + & .6568500E-03,.2413200E-02,.3038400E-02,.3263900E-02,.2154500E-02,& + & .6557700E-03,.2532300E-02,.3227500E-02,.3505500E-02,.2336600E-02,& + & .6532500E-03,.2657200E-02,.3429400E-02,.3768700E-02,.2536500E-02/ + + data absb(351:525, 8) / & + & .5365500E-03,.1896600E-02,.2347400E-02,.2487300E-02,.1614200E-02,& + & .5377700E-03,.1997900E-02,.2506900E-02,.2684900E-02,.1757000E-02,& + & .5378300E-03,.2107000E-02,.2677800E-02,.2901000E-02,.1916300E-02,& + & .5366100E-03,.2221800E-02,.2860900E-02,.3137300E-02,.2092500E-02,& + & .5342600E-03,.2343700E-02,.3059100E-02,.3395300E-02,.2287100E-02,& + & .4397300E-03,.1646700E-02,.2056400E-02,.2195000E-02,.1424300E-02,& + & .4404600E-03,.1744500E-02,.2209400E-02,.2385400E-02,.1562200E-02,& + & .4402700E-03,.1849500E-02,.2373700E-02,.2595400E-02,.1716000E-02,& + & .4390200E-03,.1960700E-02,.2552700E-02,.2828000E-02,.1887500E-02,& + & .4369000E-03,.2079700E-02,.2748300E-02,.3080900E-02,.2078300E-02,& + & .3603500E-03,.1437700E-02,.1812900E-02,.1950200E-02,.1266500E-02,& + & .3607800E-03,.1532200E-02,.1959300E-02,.2134600E-02,.1399300E-02,& + & .3603500E-03,.1633300E-02,.2119400E-02,.2340700E-02,.1548900E-02,& + & .3591700E-03,.1741600E-02,.2295800E-02,.2569300E-02,.1716900E-02,& + & .3572200E-03,.1858300E-02,.2489300E-02,.2819900E-02,.1905800E-02,& + & .2952200E-03,.1262500E-02,.1607300E-02,.1744400E-02,.1133700E-02,& + & .2954400E-03,.1353400E-02,.1749300E-02,.1924800E-02,.1262900E-02,& + & .2948900E-03,.1451300E-02,.1906400E-02,.2128100E-02,.1409300E-02,& + & .2937700E-03,.1557500E-02,.2081300E-02,.2353600E-02,.1575100E-02,& + & .2920100E-03,.1672500E-02,.2272800E-02,.2603100E-02,.1763300E-02,& + & .2418600E-03,.1115500E-02,.1435300E-02,.1572900E-02,.1023200E-02,& + & .2418900E-03,.1203200E-02,.1573900E-02,.1750800E-02,.1149800E-02,& + & .2413000E-03,.1298800E-02,.1729600E-02,.1951600E-02,.1294200E-02,& + & .2402500E-03,.1403400E-02,.1903000E-02,.2176400E-02,.1459400E-02,& + & .2386600E-03,.1517000E-02,.2094000E-02,.2427000E-02,.1647100E-02,& + & .1981100E-03,.9918800E-03,.1291400E-02,.1431100E-02,.9315700E-03,& + & .1979900E-03,.1077100E-02,.1428200E-02,.1607300E-02,.1056200E-02,& + & .1974100E-03,.1171100E-02,.1582800E-02,.1806800E-02,.1199900E-02,& + & .1964500E-03,.1274600E-02,.1755900E-02,.2032000E-02,.1365400E-02,& + & .1950300E-03,.1387100E-02,.1947300E-02,.2285100E-02,.1553300E-02,& + & .1622500E-03,.8880300E-03,.1171700E-02,.1313800E-02,.8555600E-03,& + & .1620500E-03,.9717400E-03,.1307700E-02,.1489000E-02,.9793000E-03,& + & .1614800E-03,.1064800E-02,.1462100E-02,.1689100E-02,.1123700E-02,& + & .1605900E-03,.1167300E-02,.1635700E-02,.1916500E-02,.1289600E-02,& + & .1593400E-03,.1279500E-02,.1828800E-02,.2173600E-02,.1479100E-02/ + + data absb(526:700, 8) / & + & .1328600E-03,.7983500E-03,.1068300E-02,.1211700E-02,.7890800E-03,& + & .1326100E-03,.8806600E-03,.1203600E-02,.1386500E-02,.9125200E-03,& + & .1320900E-03,.9727000E-03,.1358000E-02,.1587100E-02,.1057000E-02,& + & .1313000E-03,.1074800E-02,.1531800E-02,.1817100E-02,.1223600E-02,& + & .1302200E-03,.1186600E-02,.1726400E-02,.2078600E-02,.1414800E-02,& + & .1087900E-03,.7156700E-03,.9707500E-03,.1111800E-02,.7235300E-03,& + & .1085500E-03,.7962500E-03,.1104100E-02,.1284500E-02,.8454000E-03,& + & .1081100E-03,.8868600E-03,.1256900E-02,.1484700E-02,.9883100E-03,& + & .1074300E-03,.9876100E-03,.1430000E-02,.1715700E-02,.1154100E-02,& + & .1065000E-03,.1098700E-02,.1625100E-02,.1979900E-02,.1346000E-02,& + & .8909100E-04,.6377300E-03,.8752500E-03,.1010600E-02,.6564300E-03,& + & .8889200E-04,.7157200E-03,.1005000E-02,.1179400E-02,.7748200E-03,& + & .8851000E-04,.8039000E-03,.1154400E-02,.1376800E-02,.9143700E-03,& + & .8795100E-04,.9025300E-03,.1325500E-02,.1606300E-02,.1077900E-02,& + & .8717500E-04,.1012000E-02,.1518700E-02,.1870300E-02,.1267700E-02,& + & .7296700E-04,.5605100E-03,.7758600E-03,.9013900E-03,.5831900E-03,& + & .7281800E-04,.6345900E-03,.8996200E-03,.1062700E-02,.6954500E-03,& + & .7252300E-04,.7190900E-03,.1043300E-02,.1253300E-02,.8289600E-03,& + & .7208700E-04,.8142700E-03,.1209200E-02,.1476600E-02,.9867100E-03,& + & .7148600E-04,.9209300E-03,.1397700E-02,.1735500E-02,.1170800E-02,& + & .5976500E-04,.4932000E-03,.6884400E-03,.8047800E-03,.5184900E-03,& + & .5966000E-04,.5635400E-03,.8064000E-03,.9587600E-03,.6246600E-03,& + & .5943600E-04,.6444000E-03,.9445400E-03,.1142600E-02,.7523600E-03,& + & .5910200E-04,.7363100E-03,.1105200E-02,.1359900E-02,.9043300E-03,& + & .5863500E-04,.8400900E-03,.1289100E-02,.1613400E-02,.1082900E-02,& + & .4895600E-04,.4349900E-03,.6123100E-03,.7201700E-03,.4618900E-03,& + & .4889000E-04,.5018100E-03,.7247800E-03,.8673000E-03,.5624400E-03,& + & .4871700E-04,.5792300E-03,.8577800E-03,.1044800E-02,.6846400E-03,& + & .4845100E-04,.6679900E-03,.1013200E-02,.1256300E-02,.8311200E-03,& + & .4808500E-04,.7689800E-03,.1192800E-02,.1504700E-02,.1004400E-02,& + & .4010700E-04,.3786000E-03,.5359600E-03,.6330200E-03,.4035000E-03,& + & .4006800E-04,.4409900E-03,.6412600E-03,.7710500E-03,.4969700E-03,& + & .3994500E-04,.5139900E-03,.7669400E-03,.9393400E-03,.6116600E-03,& + & .3975200E-04,.5985100E-03,.9152800E-03,.1141600E-02,.7503700E-03,& + & .3946900E-04,.6954400E-03,.1088000E-02,.1380900E-02,.9159300E-03/ + + data absb(701:875, 8) / & + & .3285100E-04,.3287800E-03,.4678600E-03,.5546900E-03,.3512000E-03,& + & .3283900E-04,.3868300E-03,.5660700E-03,.6839400E-03,.4376900E-03,& + & .3274900E-04,.4554200E-03,.6844400E-03,.8425900E-03,.5449000E-03,& + & .3260700E-04,.5356400E-03,.8254700E-03,.1035200E-02,.6758500E-03,& + & .3239500E-04,.6284100E-03,.9913300E-03,.1265200E-02,.8333200E-03,& + & .2690600E-04,.2853400E-03,.4080500E-03,.4853500E-03,.3052600E-03,& + & .2690800E-04,.3392200E-03,.4995000E-03,.6060300E-03,.3850500E-03,& + & .2684600E-04,.4036100E-03,.6107600E-03,.7556400E-03,.4852400E-03,& + & .2673900E-04,.4795300E-03,.7445400E-03,.9388200E-03,.6086100E-03,& + & .2658500E-04,.5681600E-03,.9036300E-03,.1159700E-02,.7582900E-03,& + & .2203400E-04,.2449400E-03,.3512600E-03,.4186200E-03,.2613300E-03,& + & .2204500E-04,.2942800E-03,.4352600E-03,.5296000E-03,.3337900E-03,& + & .2200900E-04,.3539400E-03,.5383800E-03,.6689300E-03,.4259900E-03,& + & .2193300E-04,.4251000E-03,.6639200E-03,.8409000E-03,.5406100E-03,& + & .2182000E-04,.5087800E-03,.8147400E-03,.1050300E-02,.6813900E-03,& + & .1804200E-04,.2087800E-03,.2998800E-03,.3578200E-03,.2216000E-03,& + & .1805800E-04,.2536000E-03,.3762100E-03,.4587500E-03,.2867000E-03,& + & .1804100E-04,.3084500E-03,.4712300E-03,.5872700E-03,.3707000E-03,& + & .1798900E-04,.3745900E-03,.5880400E-03,.7473900E-03,.4765000E-03,& + & .1790600E-04,.4531700E-03,.7300300E-03,.9445400E-03,.6076800E-03,& + & .1477000E-04,.1774300E-03,.2551800E-03,.3046100E-03,.1871800E-03,& + & .1479000E-04,.2179400E-03,.3242400E-03,.3960300E-03,.2453400E-03,& + & .1478500E-04,.2682200E-03,.4113200E-03,.5140600E-03,.3215800E-03,& + & .1475100E-04,.3294800E-03,.5196800E-03,.6628800E-03,.4188900E-03,& + & .1469200E-04,.4030900E-03,.6529800E-03,.8479500E-03,.5407800E-03,& + & .1209100E-04,.1495600E-03,.2150700E-03,.2566400E-03,.1564100E-03,& + & .1211200E-04,.1858500E-03,.2768900E-03,.3385300E-03,.2077800E-03,& + & .1211300E-04,.2315600E-03,.3559700E-03,.4457500E-03,.2761900E-03,& + & .1209400E-04,.2878900E-03,.4557600E-03,.5831300E-03,.3649200E-03,& + & .1205400E-04,.3562800E-03,.5798000E-03,.7552300E-03,.4772100E-03,& + & .9895800E-05,.1243600E-03,.1783800E-03,.2124100E-03,.1284100E-03,& + & .9915700E-05,.1563300E-03,.2327900E-03,.2844300E-03,.1729100E-03,& + & .9922400E-05,.1972400E-03,.3035000E-03,.3801700E-03,.2332300E-03,& + & .9915000E-05,.2483100E-03,.3939600E-03,.5048800E-03,.3127400E-03,& + & .9888100E-05,.3111000E-03,.5078800E-03,.6630400E-03,.4148500E-03/ + + data absb(876:1050, 8) / & + & .8098100E-05,.1028400E-03,.1470100E-03,.1745700E-03,.1046400E-03,& + & .8117000E-05,.1308300E-03,.1945200E-03,.2373400E-03,.1429800E-03,& + & .8125400E-05,.1671600E-03,.2572700E-03,.3223000E-03,.1956500E-03,& + & .8125300E-05,.2132800E-03,.3388700E-03,.4347500E-03,.2665200E-03,& + & .8109200E-05,.2706200E-03,.4430100E-03,.5797200E-03,.3588700E-03,& + & .6626200E-05,.8454200E-04,.1203400E-03,.1424500E-03,.8463600E-04,& + & .6643500E-05,.1090300E-03,.1616800E-03,.1968600E-03,.1174000E-03,& + & .6652700E-05,.1409200E-03,.2168500E-03,.2715600E-03,.1630900E-03,& + & .6656700E-05,.1822900E-03,.2898900E-03,.3721400E-03,.2257200E-03,& + & .6648900E-05,.2344300E-03,.3846100E-03,.5041800E-03,.3088300E-03,& + & .5420200E-05,.6960800E-04,.9868000E-04,.1164600E-03,.6851000E-04,& + & .5437400E-05,.9080200E-04,.1343400E-03,.1633000E-03,.9649900E-04,& + & .5447500E-05,.1191600E-03,.1832700E-03,.2293200E-03,.1362000E-03,& + & .5452100E-05,.1560800E-03,.2484500E-03,.3192800E-03,.1915400E-03,& + & .5449800E-05,.2034800E-03,.3346600E-03,.4393700E-03,.2662600E-03,& + & .4435100E-05,.5708800E-04,.8058200E-04,.9479000E-04,.5525000E-04,& + & .4450400E-05,.7543500E-04,.1113100E-03,.1350300E-03,.7902400E-04,& + & .4459900E-05,.1003700E-03,.1542800E-03,.1929100E-03,.1134300E-03,& + & .4465100E-05,.1333600E-03,.2125200E-03,.2733500E-03,.1621800E-03,& + & .4465300E-05,.1764000E-03,.2907500E-03,.3822900E-03,.2292300E-03,& + & .3629000E-05,.4656500E-04,.6536400E-04,.7659800E-04,.4424000E-04,& + & .3642000E-05,.6231400E-04,.9164400E-04,.1109000E-03,.6423400E-04,& + & .3650900E-05,.8410200E-04,.1291000E-03,.1612500E-03,.9383300E-04,& + & .3655500E-05,.1136200E-03,.1811500E-03,.2329700E-03,.1365700E-03,& + & .3657900E-05,.1522600E-03,.2513600E-03,.3309900E-03,.1962100E-03,& + & .2969200E-05,.3774600E-04,.5263200E-04,.6139700E-04,.3516500E-04,& + & .2980800E-05,.5114900E-04,.7487900E-04,.9033500E-04,.5180700E-04,& + & .2988000E-05,.7002800E-04,.1072400E-03,.1337500E-03,.7701000E-04,& + & .2993100E-05,.9610500E-04,.1531400E-03,.1968900E-03,.1141700E-03,& + & .2995900E-05,.1307400E-03,.2161200E-03,.2849200E-03,.1669700E-03,& + & .2429600E-05,.3069800E-04,.4254400E-04,.4940600E-04,.2807200E-04,& + & .2439300E-05,.4212200E-04,.6145400E-04,.7392700E-04,.4196400E-04,& + & .2446000E-05,.5852800E-04,.8950000E-04,.1114600E-03,.6350300E-04,& + & .2450700E-05,.8161100E-04,.1300900E-03,.1672800E-03,.9594700E-04,& + & .2453500E-05,.1127600E-03,.1868200E-03,.2465400E-03,.1428600E-03/ + + data absb(1051:1175, 8) / & + & .1988300E-05,.2492100E-04,.3431200E-04,.3966600E-04,.2237500E-04,& + & .1996300E-05,.3464100E-04,.5034400E-04,.6038100E-04,.3394200E-04,& + & .2002000E-05,.4886800E-04,.7461800E-04,.9280900E-04,.5228000E-04,& + & .2006500E-05,.6925500E-04,.1104200E-03,.1420300E-03,.8056600E-04,& + & .2008900E-05,.9752700E-04,.1618200E-03,.2137300E-03,.1222800E-03,& + & .1626800E-05,.2012200E-04,.2750600E-04,.3162900E-04,.1771800E-04,& + & .1633700E-05,.2832100E-04,.4096600E-04,.4896000E-04,.2727100E-04,& + & .1638500E-05,.4057900E-04,.6182800E-04,.7674700E-04,.4273900E-04,& + & .1642400E-05,.5849000E-04,.9322000E-04,.1199100E-03,.6723200E-04,& + & .1645000E-05,.8377600E-04,.1391700E-03,.1840100E-03,.1040600E-03,& + & .1331100E-05,.1615100E-04,.2190100E-04,.2504400E-04,.1393400E-04,& + & .1336900E-05,.2300500E-04,.3308300E-04,.3937700E-04,.2175100E-04,& + & .1341100E-05,.3350100E-04,.5088800E-04,.6301400E-04,.3469600E-04,& + & .1344300E-05,.4911100E-04,.7819100E-04,.1005100E-03,.5571100E-04,& + & .1346700E-05,.7158600E-04,.1190200E-03,.1574400E-03,.8802500E-04,& + & .1089200E-05,.1296200E-04,.1744300E-04,.1982500E-04,.1095500E-04,& + & .1094200E-05,.1868800E-04,.2671600E-04,.3166400E-04,.1734800E-04,& + & .1097600E-05,.2765000E-04,.4186400E-04,.5171600E-04,.2815900E-04,& + & .1100400E-05,.4125100E-04,.6563000E-04,.8429900E-04,.4615600E-04,& + & .1102500E-05,.6126100E-04,.1019600E-03,.1349600E-03,.7453600E-04,& + & .8919700E-06,.1104700E-04,.1489900E-04,.1696400E-04,.9299900E-05,& + & .8960500E-06,.1621500E-04,.2329100E-04,.2768600E-04,.1501900E-04,& + & .8987500E-06,.2446200E-04,.3726700E-04,.4624300E-04,.2490500E-04,& + & .9011700E-06,.3717500E-04,.5959400E-04,.7696900E-04,.4167200E-04,& + & .9031000E-06,.5611500E-04,.9418700E-04,.1252800E-03,.6849700E-04/ + + data absb( 1:175, 9) / & + & .7386370E-01,.1217270E+00,.1397997E+00,.1419673E+00,.1084738E+00,& + & .7529449E-01,.1232830E+00,.1414079E+00,.1438635E+00,.1108050E+00,& + & .7697992E-01,.1254793E+00,.1434365E+00,.1458286E+00,.1129988E+00,& + & .7887100E-01,.1280855E+00,.1459070E+00,.1479085E+00,.1152446E+00,& + & .8092090E-01,.1307909E+00,.1487251E+00,.1501501E+00,.1175320E+00,& + & .6403379E-01,.1090204E+00,.1253282E+00,.1274699E+00,.9632574E-01,& + & .6547459E-01,.1110735E+00,.1274271E+00,.1295924E+00,.9864560E-01,& + & .6715540E-01,.1136407E+00,.1299702E+00,.1318704E+00,.1010107E+00,& + & .6906380E-01,.1163504E+00,.1328994E+00,.1343146E+00,.1034582E+00,& + & .7105787E-01,.1191957E+00,.1361107E+00,.1370057E+00,.1059074E+00,& + & .5530200E-01,.9757076E-01,.1121740E+00,.1140513E+00,.8533242E-01,& + & .5675787E-01,.1000348E+00,.1147292E+00,.1164809E+00,.8776543E-01,& + & .5846659E-01,.1027322E+00,.1176838E+00,.1190849E+00,.9029882E-01,& + & .6032734E-01,.1055957E+00,.1209546E+00,.1219366E+00,.9286960E-01,& + & .6209121E-01,.1085948E+00,.1243416E+00,.1250550E+00,.9547001E-01,& + & .4762395E-01,.8734512E-01,.1003708E+00,.1018642E+00,.7561273E-01,& + & .4911368E-01,.8996446E-01,.1032731E+00,.1045503E+00,.7815395E-01,& + & .5080031E-01,.9279755E-01,.1065652E+00,.1074922E+00,.8078702E-01,& + & .5243449E-01,.9581412E-01,.1100211E+00,.1107497E+00,.8346128E-01,& + & .5394988E-01,.9894050E-01,.1135959E+00,.1142797E+00,.8622867E-01,& + & .4090347E-01,.7810647E-01,.8979429E-01,.9092391E-01,.6709977E-01,& + & .4239633E-01,.8087453E-01,.9303629E-01,.9387987E-01,.6971100E-01,& + & .4389973E-01,.8384796E-01,.9650459E-01,.9716037E-01,.7239385E-01,& + & .4532474E-01,.8698861E-01,.1001236E+00,.1007738E+00,.7517902E-01,& + & .4664725E-01,.9022266E-01,.1038715E+00,.1046269E+00,.7808115E-01,& + & .3507354E-01,.6984031E-01,.8045794E-01,.8126652E-01,.5967808E-01,& + & .3641404E-01,.7272845E-01,.8387260E-01,.8449727E-01,.6232326E-01,& + & .3773547E-01,.7581798E-01,.8747042E-01,.8807986E-01,.6506146E-01,& + & .3899381E-01,.7905992E-01,.9126223E-01,.9196437E-01,.6793314E-01,& + & .4015940E-01,.8236350E-01,.9521155E-01,.9607923E-01,.7090836E-01,& + & .2996758E-01,.6248612E-01,.7222878E-01,.7286184E-01,.5319451E-01,& + & .3114015E-01,.6548203E-01,.7573235E-01,.7633337E-01,.5587473E-01,& + & .3229126E-01,.6867140E-01,.7946891E-01,.8015608E-01,.5867307E-01,& + & .3340366E-01,.7198946E-01,.8342015E-01,.8425577E-01,.6160468E-01,& + & .3444385E-01,.7527768E-01,.8753864E-01,.8855726E-01,.6465244E-01/ + + data absb(176:350, 9) / & + & .2552897E-01,.5604549E-01,.6504953E-01,.6568338E-01,.4759673E-01,& + & .2655263E-01,.5914810E-01,.6865615E-01,.6934990E-01,.5031583E-01,& + & .2756945E-01,.6242191E-01,.7252447E-01,.7335652E-01,.5316631E-01,& + & .2855171E-01,.6573444E-01,.7661794E-01,.7759839E-01,.5616029E-01,& + & .2946709E-01,.6902393E-01,.8088256E-01,.8205689E-01,.5928927E-01,& + & .2169323E-01,.5042927E-01,.5880926E-01,.5953518E-01,.4276904E-01,& + & .2259137E-01,.5361379E-01,.6252841E-01,.6336797E-01,.4551161E-01,& + & .2349223E-01,.5691109E-01,.6652380E-01,.6748411E-01,.4841701E-01,& + & .2435866E-01,.6022552E-01,.7072962E-01,.7184630E-01,.5147673E-01,& + & .2516486E-01,.6352693E-01,.7511834E-01,.7646009E-01,.5467556E-01,& + & .1845909E-01,.4576813E-01,.5367465E-01,.5454792E-01,.3878639E-01,& + & .1925599E-01,.4899168E-01,.5752566E-01,.5849933E-01,.4157610E-01,& + & .2005017E-01,.5229447E-01,.6163578E-01,.6272679E-01,.4454755E-01,& + & .2080611E-01,.5562768E-01,.6596785E-01,.6724008E-01,.4767687E-01,& + & .2150826E-01,.5895362E-01,.7048564E-01,.7202217E-01,.5095808E-01,& + & .1570422E-01,.4178498E-01,.4935434E-01,.5034621E-01,.3542605E-01,& + & .1640986E-01,.4501386E-01,.5331082E-01,.5440870E-01,.3827459E-01,& + & .1710795E-01,.4833320E-01,.5753856E-01,.5876524E-01,.4130508E-01,& + & .1776552E-01,.5169642E-01,.6199404E-01,.6343553E-01,.4450482E-01,& + & .1836301E-01,.5505656E-01,.6662521E-01,.6837233E-01,.4786425E-01,& + & .1336950E-01,.3839896E-01,.4576222E-01,.4685100E-01,.3263474E-01,& + & .1399497E-01,.4164334E-01,.4982575E-01,.5104297E-01,.3553968E-01,& + & .1459622E-01,.4499292E-01,.5417389E-01,.5554832E-01,.3863403E-01,& + & .1515950E-01,.4838565E-01,.5872737E-01,.6036693E-01,.4189693E-01,& + & .1567094E-01,.5178762E-01,.6347431E-01,.6547102E-01,.4533998E-01,& + & .1139415E-01,.3556539E-01,.4282652E-01,.4400955E-01,.3034823E-01,& + & .1193609E-01,.3883632E-01,.4700523E-01,.4834132E-01,.3330647E-01,& + & .1245410E-01,.4221330E-01,.5145145E-01,.5300744E-01,.3646560E-01,& + & .1293803E-01,.4565202E-01,.5613109E-01,.5799082E-01,.3980753E-01,& + & .1337501E-01,.4910924E-01,.6099932E-01,.6327343E-01,.4334453E-01,& + & .9722913E-02,.3326032E-01,.4052121E-01,.4180726E-01,.2852809E-01,& + & .1018992E-01,.3656568E-01,.4481036E-01,.4630022E-01,.3155388E-01,& + & .1063595E-01,.3998111E-01,.4937235E-01,.5113650E-01,.3479040E-01,& + & .1105185E-01,.4347100E-01,.5418973E-01,.5629833E-01,.3822398E-01,& + & .1143041E-01,.4699477E-01,.5918778E-01,.6176195E-01,.4186182E-01/ + + data absb(351:525, 9) / & + & .8300709E-02,.3138262E-01,.3871373E-01,.4011993E-01,.2708755E-01,& + & .8705608E-02,.3472930E-01,.4312192E-01,.4478609E-01,.3018835E-01,& + & .9091211E-02,.3820073E-01,.4781870E-01,.4980017E-01,.3350792E-01,& + & .9448828E-02,.4175226E-01,.5277360E-01,.5514398E-01,.3704207E-01,& + & .9783765E-02,.4534922E-01,.5791589E-01,.6079477E-01,.4078994E-01,& + & .7094791E-02,.2988609E-01,.3735115E-01,.3890287E-01,.2597883E-01,& + & .7443776E-02,.3328590E-01,.4189354E-01,.4374887E-01,.2916268E-01,& + & .7777473E-02,.3682175E-01,.4673676E-01,.4894363E-01,.3257840E-01,& + & .8091821E-02,.4045146E-01,.5183182E-01,.5446905E-01,.3621756E-01,& + & .8393762E-02,.4412277E-01,.5711772E-01,.6030049E-01,.4008338E-01,& + & .6072721E-02,.2875406E-01,.3642428E-01,.3814167E-01,.2519233E-01,& + & .6375450E-02,.3222477E-01,.4111499E-01,.4316950E-01,.2846448E-01,& + & .6665401E-02,.3583825E-01,.4610908E-01,.4855053E-01,.3198856E-01,& + & .6947813E-02,.3954583E-01,.5134775E-01,.5425463E-01,.3574183E-01,& + & .7224449E-02,.4329363E-01,.5677163E-01,.6025181E-01,.3971948E-01,& + & .5204996E-02,.2793567E-01,.3586995E-01,.3776366E-01,.2467285E-01,& + & .5467917E-02,.3148948E-01,.4071531E-01,.4297096E-01,.2804493E-01,& + & .5726383E-02,.3518386E-01,.4585588E-01,.4852812E-01,.3168056E-01,& + & .5982991E-02,.3897236E-01,.5123260E-01,.5440198E-01,.3555049E-01,& + & .6240892E-02,.4279660E-01,.5678660E-01,.6055093E-01,.3963932E-01,& + & .4469682E-02,.2742048E-01,.3567286E-01,.3774779E-01,.2440899E-01,& + & .4700641E-02,.3106355E-01,.4067206E-01,.4312796E-01,.2789294E-01,& + & .4936385E-02,.3484450E-01,.4595839E-01,.4885735E-01,.3164155E-01,& + & .5173162E-02,.3871026E-01,.5146122E-01,.5488738E-01,.3562372E-01,& + & .5417514E-02,.4260570E-01,.5713175E-01,.6117015E-01,.3982399E-01,& + & .3844994E-02,.2717409E-01,.3578885E-01,.3804312E-01,.2437272E-01,& + & .4053349E-02,.3090840E-01,.4093856E-01,.4359092E-01,.2797192E-01,& + & .4269342E-02,.3477112E-01,.4635566E-01,.4947518E-01,.3183081E-01,& + & .4494036E-02,.3870776E-01,.5197315E-01,.5564894E-01,.3592188E-01,& + & .4730771E-02,.4267219E-01,.5774228E-01,.6204827E-01,.4022778E-01,& + & .3316155E-02,.2716439E-01,.3617214E-01,.3860092E-01,.2453709E-01,& + & .3507741E-02,.3098644E-01,.4145934E-01,.4430670E-01,.2825000E-01,& + & .3708780E-02,.3492455E-01,.4699683E-01,.5032871E-01,.3221778E-01,& + & .3925552E-02,.3892413E-01,.5271553E-01,.5663089E-01,.3641334E-01,& + & .4158892E-02,.4294570E-01,.5857114E-01,.6313194E-01,.4081644E-01/ + + data absb(526:700, 9) / & + & .2863791E-02,.2722174E-01,.3659228E-01,.3917713E-01,.2474498E-01,& + & .3040588E-02,.3112320E-01,.4199421E-01,.4501754E-01,.2855786E-01,& + & .3233150E-02,.3512719E-01,.4763348E-01,.5115797E-01,.3261841E-01,& + & .3445381E-02,.3917826E-01,.5343694E-01,.5756145E-01,.3690166E-01,& + & .3677438E-02,.4324272E-01,.5935861E-01,.6414300E-01,.4138900E-01,& + & .2465329E-02,.2707028E-01,.3666695E-01,.3936557E-01,.2472691E-01,& + & .2632781E-02,.3103171E-01,.4215043E-01,.4529694E-01,.2860992E-01,& + & .2818872E-02,.3508603E-01,.4786198E-01,.5151711E-01,.3273833E-01,& + & .3025017E-02,.3917768E-01,.5372478E-01,.5798985E-01,.3708084E-01,& + & .3257127E-02,.4327518E-01,.5969457E-01,.6462649E-01,.4162399E-01,& + & .2114507E-02,.2661661E-01,.3628160E-01,.3903834E-01,.2439799E-01,& + & .2271568E-02,.3061795E-01,.4180884E-01,.4501716E-01,.2831780E-01,& + & .2449593E-02,.3470815E-01,.4756236E-01,.5128126E-01,.3248201E-01,& + & .2650872E-02,.3883456E-01,.5346450E-01,.5779235E-01,.3685837E-01,& + & .2883010E-02,.4296394E-01,.5947166E-01,.6446457E-01,.4143251E-01,& + & .1797225E-02,.2566144E-01,.3516915E-01,.3791294E-01,.2356973E-01,& + & .1942471E-02,.2967546E-01,.4069640E-01,.4388416E-01,.2748224E-01,& + & .2110732E-02,.3378859E-01,.4645705E-01,.5014523E-01,.3164309E-01,& + & .2305322E-02,.3794341E-01,.5237303E-01,.5666115E-01,.3601691E-01,& + & .2533979E-02,.4209991E-01,.5839699E-01,.6333729E-01,.4058728E-01,& + & .1528499E-02,.2474850E-01,.3408418E-01,.3680675E-01,.2276935E-01,& + & .1662648E-02,.2877135E-01,.3960487E-01,.4276395E-01,.2666990E-01,& + & .1822270E-02,.3290004E-01,.4536537E-01,.4901380E-01,.3081993E-01,& + & .2010407E-02,.3707876E-01,.5128684E-01,.5551957E-01,.3518382E-01,& + & .2236121E-02,.4125795E-01,.5732398E-01,.6219988E-01,.3974976E-01,& + & .1301157E-02,.2390332E-01,.3306486E-01,.3576088E-01,.2202215E-01,& + & .1425753E-02,.2792846E-01,.3857359E-01,.4169850E-01,.2590697E-01,& + & .1577002E-02,.3206803E-01,.4432843E-01,.4793360E-01,.3004339E-01,& + & .1759961E-02,.3626411E-01,.5025187E-01,.5442732E-01,.3439556E-01,& + & .1982828E-02,.4046418E-01,.5629663E-01,.6110344E-01,.3895158E-01,& + & .1098183E-02,.2271194E-01,.3154937E-01,.3417342E-01,.2093772E-01,& + & .1211979E-02,.2671363E-01,.3701515E-01,.4005573E-01,.2477551E-01,& + & .1352163E-02,.3085276E-01,.4273410E-01,.4624396E-01,.2887103E-01,& + & .1526376E-02,.3505659E-01,.4864130E-01,.5269139E-01,.3318689E-01,& + & .1741576E-02,.3927458E-01,.5467901E-01,.5935019E-01,.3770824E-01/ + + data absb(701:875, 9) / & + & .9256636E-03,.2151927E-01,.3001800E-01,.3256386E-01,.1984971E-01,& + & .1029330E-02,.2548720E-01,.3542880E-01,.3837882E-01,.2363194E-01,& + & .1157935E-02,.2961670E-01,.4110275E-01,.4450903E-01,.2767804E-01,& + & .1322566E-02,.3382477E-01,.4698627E-01,.5090557E-01,.3195340E-01,& + & .1529747E-02,.3805510E-01,.5300873E-01,.5753600E-01,.3643451E-01,& + & .7800682E-03,.2037045E-01,.2853508E-01,.3100101E-01,.1880237E-01,& + & .8728720E-03,.2429814E-01,.3387777E-01,.3673821E-01,.2252410E-01,& + & .9913989E-03,.2840935E-01,.3950510E-01,.4280696E-01,.2651603E-01,& + & .1147051E-02,.3261525E-01,.4535763E-01,.4915180E-01,.3074712E-01,& + & .1345265E-02,.3685628E-01,.5135640E-01,.5573969E-01,.3518635E-01,& + & .6520564E-03,.1905366E-01,.2681157E-01,.2917864E-01,.1759490E-01,& + & .7355199E-03,.2291988E-01,.3206051E-01,.3480883E-01,.2123646E-01,& + & .8430968E-03,.2699435E-01,.3762006E-01,.4079097E-01,.2515653E-01,& + & .9861085E-03,.3118915E-01,.4342129E-01,.4706516E-01,.2932868E-01,& + & .1172376E-02,.3543571E-01,.4939030E-01,.5358864E-01,.3371077E-01,& + & .5429238E-03,.1769119E-01,.2501427E-01,.2727445E-01,.1634645E-01,& + & .6168245E-03,.2147865E-01,.3015275E-01,.3277935E-01,.1989356E-01,& + & .7121998E-03,.2550313E-01,.3563092E-01,.3866373E-01,.2373486E-01,& + & .8424551E-03,.2967789E-01,.4136324E-01,.4485540E-01,.2783187E-01,& + & .1016095E-02,.3392096E-01,.4729347E-01,.5130218E-01,.3215264E-01,& + & .4520417E-03,.1638027E-01,.2327058E-01,.2542894E-01,.1514441E-01,& + & .5155432E-03,.2007947E-01,.2829736E-01,.3080698E-01,.1859499E-01,& + & .6014451E-03,.2404182E-01,.3368120E-01,.3657952E-01,.2235065E-01,& + & .7188950E-03,.2818500E-01,.3934025E-01,.4268031E-01,.2636784E-01,& + & .8790319E-03,.3241918E-01,.4522294E-01,.4905072E-01,.3062540E-01,& + & .3739048E-03,.1504727E-01,.2147687E-01,.2353542E-01,.1391939E-01,& + & .4299766E-03,.1864024E-01,.2638349E-01,.2876868E-01,.1726321E-01,& + & .5043505E-03,.2252541E-01,.3165039E-01,.3441216E-01,.2091919E-01,& + & .6094823E-03,.2662193E-01,.3722724E-01,.4040986E-01,.2485188E-01,& + & .7547889E-03,.3083607E-01,.4304298E-01,.4669398E-01,.2903395E-01,& + & .3059529E-03,.1362998E-01,.1954590E-01,.2150308E-01,.1261761E-01,& + & .3544511E-03,.1709153E-01,.2431072E-01,.2656287E-01,.1583432E-01,& + & .4182967E-03,.2087582E-01,.2943979E-01,.3205269E-01,.1937141E-01,& + & .5101848E-03,.2490407E-01,.3491246E-01,.3792397E-01,.2320561E-01,& + & .6398861E-03,.2908833E-01,.4064101E-01,.4410450E-01,.2729138E-01/ + + data absb(876:1050, 9) / & + & .2498082E-03,.1228614E-01,.1769311E-01,.1955495E-01,.1137919E-01,& + & .2913249E-03,.1560283E-01,.2230066E-01,.2443072E-01,.1445974E-01,& + & .3471061E-03,.1927312E-01,.2729375E-01,.2976141E-01,.1787798E-01,& + & .4260536E-03,.2321801E-01,.3264138E-01,.3549044E-01,.2160039E-01,& + & .5402840E-03,.2735520E-01,.3827674E-01,.4155616E-01,.2559086E-01,& + & .2032306E-03,.1100929E-01,.1592358E-01,.1768796E-01,.1020153E-01,& + & .2392377E-03,.1418860E-01,.2036714E-01,.2238632E-01,.1314703E-01,& + & .2862724E-03,.1772046E-01,.2521008E-01,.2753806E-01,.1643822E-01,& + & .3532839E-03,.2156941E-01,.3041971E-01,.3311704E-01,.2004337E-01,& + & .4535630E-03,.2564413E-01,.3595639E-01,.3905830E-01,.2393631E-01,& + & .1658721E-03,.9881414E-02,.1435034E-01,.1601976E-01,.9156258E-02,& + & .1953876E-03,.1291102E-01,.1860859E-01,.2053398E-01,.1196964E-01,& + & .2372144E-03,.1632300E-01,.2331887E-01,.2552322E-01,.1513690E-01,& + & .2956183E-03,.2005853E-01,.2839017E-01,.3094782E-01,.1862793E-01,& + & .3822967E-03,.2406104E-01,.3381785E-01,.3676346E-01,.2242186E-01,& + & .1347727E-03,.8839179E-02,.1288890E-01,.1446932E-01,.8192478E-02,& + & .1593422E-03,.1172817E-01,.1696668E-01,.1880252E-01,.1087547E-01,& + & .1948108E-03,.1500685E-01,.2152813E-01,.2362440E-01,.1391796E-01,& + & .2456981E-03,.1863185E-01,.2647287E-01,.2889888E-01,.1729864E-01,& + & .3210495E-03,.2255415E-01,.3178001E-01,.3458170E-01,.2098803E-01,& + & .1090472E-03,.7861512E-02,.1150652E-01,.1299630E-01,.7284963E-02,& + & .1294974E-03,.1060140E-01,.1539628E-01,.1714133E-01,.9834191E-02,& + & .1592049E-03,.1374264E-01,.1979296E-01,.2179392E-01,.1275057E-01,& + & .2045251E-03,.1726001E-01,.2461884E-01,.2691705E-01,.1601660E-01,& + & .2700821E-03,.2107733E-01,.2978897E-01,.3245179E-01,.1959460E-01,& + & .8802434E-04,.6944882E-02,.1020032E-01,.1159221E-01,.6430862E-02,& + & .1046855E-03,.9527594E-02,.1389317E-01,.1554646E-01,.8842774E-02,& + & .1292946E-03,.1253134E-01,.1811521E-01,.2002416E-01,.1163053E-01,& + & .1677549E-03,.1591776E-01,.2279809E-01,.2497825E-01,.1477209E-01,& + & .2257215E-03,.1963067E-01,.2784013E-01,.3036876E-01,.1824002E-01,& + & .7112381E-04,.6158932E-02,.9074677E-02,.1037208E-01,.5697312E-02,& + & .8497772E-04,.8594221E-02,.1257729E-01,.1414858E-01,.7977017E-02,& + & .1052109E-03,.1146594E-01,.1663179E-01,.1845837E-01,.1064379E-01,& + & .1377962E-03,.1472932E-01,.2117504E-01,.2325811E-01,.1367082E-01,& + & .1885595E-03,.1833924E-01,.2610150E-01,.2850850E-01,.1703634E-01/ + + data absb(1051:1175, 9) / & + & .5743054E-04,.5454299E-02,.8062707E-02,.9263120E-02,.5037907E-02,& + & .6891997E-04,.7748836E-02,.1137635E-01,.1286665E-01,.7190454E-02,& + & .8575160E-04,.1048793E-01,.1526380E-01,.1700893E-01,.9738840E-02,& + & .1130459E-03,.1362883E-01,.1965917E-01,.2165939E-01,.1265333E-01,& + & .1594488E-03,.1714474E-01,.2448136E-01,.2677687E-01,.1591770E-01,& + & .4626830E-04,.4800265E-02,.7116803E-02,.8217649E-02,.4424823E-02,& + & .5574968E-04,.6951784E-02,.1023739E-01,.1164073E-01,.6446800E-02,& + & .6940184E-04,.9552514E-02,.1395187E-01,.1561652E-01,.8874544E-02,& + & .9239592E-04,.1257225E-01,.1819349E-01,.2011229E-01,.1167577E-01,& + & .1322365E-03,.1597315E-01,.2289106E-01,.2508204E-01,.1483008E-01,& + & .3713644E-04,.4193801E-02,.6237852E-02,.7236320E-02,.3854523E-02,& + & .4495045E-04,.6202948E-02,.9160942E-02,.1047397E-01,.5746268E-02,& + & .5606539E-04,.8661882E-02,.1269376E-01,.1427915E-01,.8047359E-02,& + & .7499774E-04,.1155560E-01,.1677574E-01,.1861487E-01,.1073338E-01,& + & .1090623E-03,.1483830E-01,.2133895E-01,.2343538E-01,.1377716E-01,& + & .2983624E-04,.3660809E-02,.5463957E-02,.6366210E-02,.3353712E-02,& + & .3622972E-04,.5534921E-02,.8199583E-02,.9421109E-02,.5120953E-02,& + & .4528199E-04,.7860566E-02,.1155366E-01,.1306274E-01,.7301227E-02,& + & .6078597E-04,.1062904E-01,.1547773E-01,.1723998E-01,.9874672E-02,& + & .8960328E-04,.1379622E-01,.1990262E-01,.2191965E-01,.1281258E-01,& + & .2476815E-04,.3454037E-02,.5166124E-02,.6030808E-02,.3159940E-02,& + & .3026086E-04,.5275928E-02,.7826736E-02,.9011759E-02,.4878738E-02,& + & .3827593E-04,.7548106E-02,.1110916E-01,.1258647E-01,.7009912E-02,& + & .5239001E-04,.1026550E-01,.1496950E-01,.1670101E-01,.9539209E-02,& + & .7936022E-04,.1338634E-01,.1933796E-01,.2132326E-01,.1243426E-01/ + + data absb( 1:175,10) / & + & .3241099E+01,.2987317E+01,.2934217E+01,.2979591E+01,.3249070E+01,& + & .3234075E+01,.2980277E+01,.2928977E+01,.2975887E+01,.3247797E+01,& + & .3225854E+01,.2969842E+01,.2920752E+01,.2969916E+01,.3244885E+01,& + & .3216237E+01,.2956861E+01,.2909451E+01,.2961989E+01,.3239941E+01,& + & .3205570E+01,.2942860E+01,.2895750E+01,.2952083E+01,.3233269E+01,& + & .3294407E+01,.3067418E+01,.3026193E+01,.3071528E+01,.3320951E+01,& + & .3287555E+01,.3058712E+01,.3019273E+01,.3067009E+01,.3319914E+01,& + & .3279570E+01,.3047161E+01,.3009370E+01,.3060158E+01,.3316506E+01,& + & .3270203E+01,.3034142E+01,.2996595E+01,.3051009E+01,.3310913E+01,& + & .3259714E+01,.3019806E+01,.2981647E+01,.3039634E+01,.3303820E+01,& + & .3341126E+01,.3138576E+01,.3108484E+01,.3154777E+01,.3385204E+01,& + & .3334442E+01,.3128468E+01,.3100116E+01,.3149324E+01,.3383891E+01,& + & .3326558E+01,.3116752E+01,.3088845E+01,.3141443E+01,.3379937E+01,& + & .3317437E+01,.3103447E+01,.3075001E+01,.3130952E+01,.3374048E+01,& + & .3307931E+01,.3088783E+01,.3059530E+01,.3118062E+01,.3366502E+01,& + & .3381819E+01,.3201482E+01,.3181519E+01,.3229413E+01,.3441758E+01,& + & .3375218E+01,.3191080E+01,.3171998E+01,.3223235E+01,.3440199E+01,& + & .3367503E+01,.3178917E+01,.3159508E+01,.3214061E+01,.3435864E+01,& + & .3359300E+01,.3165234E+01,.3145138E+01,.3202140E+01,.3429679E+01,& + & .3350904E+01,.3150191E+01,.3129217E+01,.3187795E+01,.3421572E+01,& + & .3416967E+01,.3257138E+01,.3245938E+01,.3295538E+01,.3491078E+01,& + & .3410526E+01,.3246460E+01,.3235248E+01,.3288412E+01,.3489256E+01,& + & .3403411E+01,.3233801E+01,.3222173E+01,.3278081E+01,.3484896E+01,& + & .3396503E+01,.3220051E+01,.3207563E+01,.3264988E+01,.3478422E+01,& + & .3388687E+01,.3204490E+01,.3190965E+01,.3249372E+01,.3469667E+01,& + & .3447347E+01,.3306390E+01,.3302358E+01,.3353515E+01,.3533939E+01,& + & .3441677E+01,.3295397E+01,.3291151E+01,.3345399E+01,.3532046E+01,& + & .3435433E+01,.3282539E+01,.3277801E+01,.3334036E+01,.3527652E+01,& + & .3428932E+01,.3268231E+01,.3262441E+01,.3319876E+01,.3520689E+01,& + & .3421802E+01,.3252582E+01,.3245243E+01,.3303411E+01,.3511826E+01,& + & .3473639E+01,.3349610E+01,.3351573E+01,.3403647E+01,.3571220E+01,& + & .3468683E+01,.3338245E+01,.3340115E+01,.3394675E+01,.3569195E+01,& + & .3463191E+01,.3325117E+01,.3326306E+01,.3382460E+01,.3564603E+01,& + & .3457226E+01,.3310536E+01,.3310441E+01,.3367641E+01,.3557528E+01,& + & .3450573E+01,.3294967E+01,.3292594E+01,.3350498E+01,.3548320E+01/ + + data absb(176:350,10) / & + & .3496427E+01,.3387213E+01,.3394307E+01,.3446696E+01,.3603551E+01,& + & .3492015E+01,.3375447E+01,.3382527E+01,.3437054E+01,.3601524E+01,& + & .3487054E+01,.3362003E+01,.3368240E+01,.3424123E+01,.3596558E+01,& + & .3481600E+01,.3347475E+01,.3351850E+01,.3408660E+01,.3589083E+01,& + & .3475345E+01,.3331832E+01,.3333426E+01,.3390953E+01,.3579691E+01,& + & .3515729E+01,.3419608E+01,.3431233E+01,.3483605E+01,.3631724E+01,& + & .3512042E+01,.3407688E+01,.3419052E+01,.3473258E+01,.3629302E+01,& + & .3507568E+01,.3394146E+01,.3404283E+01,.3459906E+01,.3623996E+01,& + & .3502487E+01,.3379596E+01,.3387427E+01,.3443990E+01,.3616232E+01,& + & .3496406E+01,.3363737E+01,.3368380E+01,.3425639E+01,.3606532E+01,& + & .3532277E+01,.3446949E+01,.3462235E+01,.3514489E+01,.3655808E+01,& + & .3528770E+01,.3434733E+01,.3449373E+01,.3503513E+01,.3652945E+01,& + & .3524634E+01,.3421100E+01,.3434125E+01,.3489643E+01,.3647282E+01,& + & .3519795E+01,.3406260E+01,.3416576E+01,.3472980E+01,.3639037E+01,& + & .3514104E+01,.3390336E+01,.3397008E+01,.3453854E+01,.3628856E+01,& + & .3546078E+01,.3470188E+01,.3488411E+01,.3540723E+01,.3676433E+01,& + & .3542944E+01,.3457842E+01,.3475086E+01,.3529136E+01,.3673056E+01,& + & .3538969E+01,.3443995E+01,.3459112E+01,.3514554E+01,.3666861E+01,& + & .3534492E+01,.3429012E+01,.3441008E+01,.3497202E+01,.3658321E+01,& + & .3528936E+01,.3412721E+01,.3420721E+01,.3477224E+01,.3647530E+01,& + & .3557812E+01,.3489957E+01,.3510431E+01,.3562900E+01,.3693951E+01,& + & .3554915E+01,.3477501E+01,.3496575E+01,.3550650E+01,.3690213E+01,& + & .3551290E+01,.3463442E+01,.3480042E+01,.3535257E+01,.3683497E+01,& + & .3546841E+01,.3448056E+01,.3461256E+01,.3517075E+01,.3674340E+01,& + & .3541285E+01,.3431269E+01,.3440276E+01,.3496294E+01,.3663228E+01,& + & .3567647E+01,.3506550E+01,.3528762E+01,.3581376E+01,.3708814E+01,& + & .3564997E+01,.3493846E+01,.3514220E+01,.3568244E+01,.3704420E+01,& + & .3561496E+01,.3479527E+01,.3497088E+01,.3552055E+01,.3697250E+01,& + & .3557192E+01,.3463748E+01,.3477590E+01,.3533010E+01,.3687653E+01,& + & .3551616E+01,.3446545E+01,.3455968E+01,.3511360E+01,.3675961E+01,& + & .3576050E+01,.3520359E+01,.3543745E+01,.3596477E+01,.3721344E+01,& + & .3573439E+01,.3507280E+01,.3528498E+01,.3582455E+01,.3716375E+01,& + & .3570110E+01,.3492608E+01,.3510656E+01,.3565258E+01,.3708511E+01,& + & .3565744E+01,.3476407E+01,.3490353E+01,.3545222E+01,.3698329E+01,& + & .3559803E+01,.3458419E+01,.3467812E+01,.3522516E+01,.3686100E+01/ + + data absb(351:525,10) / & + & .3582887E+01,.3531577E+01,.3555722E+01,.3608504E+01,.3731686E+01,& + & .3580475E+01,.3518245E+01,.3539855E+01,.3593592E+01,.3726109E+01,& + & .3577189E+01,.3503133E+01,.3521212E+01,.3575393E+01,.3717607E+01,& + & .3572639E+01,.3486267E+01,.3500027E+01,.3554276E+01,.3706744E+01,& + & .3566732E+01,.3467823E+01,.3476736E+01,.3530687E+01,.3693895E+01,& + & .3588948E+01,.3540932E+01,.3565482E+01,.3618178E+01,.3740395E+01,& + & .3586372E+01,.3527032E+01,.3548694E+01,.3602144E+01,.3734037E+01,& + & .3582904E+01,.3511279E+01,.3529122E+01,.3582894E+01,.3724850E+01,& + & .3578253E+01,.3493847E+01,.3507118E+01,.3560863E+01,.3713367E+01,& + & .3571896E+01,.3474633E+01,.3482868E+01,.3536238E+01,.3699809E+01,& + & .3593753E+01,.3548111E+01,.3572749E+01,.3625342E+01,.3747338E+01,& + & .3591161E+01,.3533619E+01,.3554981E+01,.3608138E+01,.3740209E+01,& + & .3587644E+01,.3517376E+01,.3534583E+01,.3587946E+01,.3730305E+01,& + & .3582824E+01,.3499345E+01,.3511738E+01,.3564886E+01,.3718106E+01,& + & .3576090E+01,.3479444E+01,.3486584E+01,.3539307E+01,.3703918E+01,& + & .3597761E+01,.3553599E+01,.3577948E+01,.3630395E+01,.3752803E+01,& + & .3595135E+01,.3538555E+01,.3559293E+01,.3612190E+01,.3744937E+01,& + & .3591361E+01,.3521618E+01,.3537925E+01,.3590860E+01,.3734257E+01,& + & .3586342E+01,.3502980E+01,.3514239E+01,.3566848E+01,.3721332E+01,& + & .3579098E+01,.3482302E+01,.3488295E+01,.3540497E+01,.3706615E+01,& + & .3601000E+01,.3557421E+01,.3581302E+01,.3633532E+01,.3756941E+01,& + & .3598425E+01,.3541845E+01,.3561786E+01,.3614297E+01,.3748264E+01,& + & .3594258E+01,.3524164E+01,.3539472E+01,.3591996E+01,.3736861E+01,& + & .3588813E+01,.3504757E+01,.3514868E+01,.3567024E+01,.3723189E+01,& + & .3581159E+01,.3483405E+01,.3488066E+01,.3539801E+01,.3707789E+01,& + & .3603721E+01,.3559860E+01,.3582917E+01,.3634951E+01,.3759790E+01,& + & .3600695E+01,.3543471E+01,.3562334E+01,.3614594E+01,.3750203E+01,& + & .3596558E+01,.3525354E+01,.3539343E+01,.3591476E+01,.3738184E+01,& + & .3590489E+01,.3505086E+01,.3513885E+01,.3565600E+01,.3723853E+01,& + & .3582281E+01,.3482974E+01,.3486236E+01,.3537560E+01,.3707796E+01,& + & .3606012E+01,.3561147E+01,.3583252E+01,.3635062E+01,.3761716E+01,& + & .3602690E+01,.3544023E+01,.3561757E+01,.3613695E+01,.3751349E+01,& + & .3598158E+01,.3525175E+01,.3537873E+01,.3589589E+01,.3738443E+01,& + & .3591521E+01,.3504190E+01,.3511600E+01,.3562948E+01,.3723509E+01,& + & .3582782E+01,.3481406E+01,.3483237E+01,.3534221E+01,.3706854E+01/ + + data absb(526:700,10) / & + & .3607593E+01,.3561716E+01,.3582936E+01,.3634631E+01,.3762977E+01,& + & .3604207E+01,.3544117E+01,.3560767E+01,.3612484E+01,.3751904E+01,& + & .3599186E+01,.3524501E+01,.3536083E+01,.3587617E+01,.3738408E+01,& + & .3592335E+01,.3503119E+01,.3509231E+01,.3560224E+01,.3722888E+01,& + & .3583023E+01,.3479645E+01,.3480307E+01,.3530962E+01,.3705868E+01,& + & .3609388E+01,.3563205E+01,.3583835E+01,.3635279E+01,.3764323E+01,& + & .3605668E+01,.3545073E+01,.3561130E+01,.3612628E+01,.3752963E+01,& + & .3600435E+01,.3525079E+01,.3535962E+01,.3587210E+01,.3739092E+01,& + & .3593253E+01,.3503218E+01,.3508581E+01,.3559430E+01,.3723196E+01,& + & .3583674E+01,.3479411E+01,.3479316E+01,.3529774E+01,.3705733E+01,& + & .3610877E+01,.3565753E+01,.3586334E+01,.3637630E+01,.3766564E+01,& + & .3607388E+01,.3547593E+01,.3563510E+01,.3614777E+01,.3754879E+01,& + & .3601974E+01,.3527292E+01,.3538093E+01,.3589236E+01,.3740900E+01,& + & .3594896E+01,.3505409E+01,.3510693E+01,.3561326E+01,.3724918E+01,& + & .3585207E+01,.3481394E+01,.3481186E+01,.3531504E+01,.3707454E+01,& + & .3612619E+01,.3570439E+01,.3591639E+01,.3642767E+01,.3769831E+01,& + & .3609315E+01,.3552400E+01,.3569038E+01,.3620211E+01,.3758468E+01,& + & .3604385E+01,.3532422E+01,.3543881E+01,.3594866E+01,.3744636E+01,& + & .3597500E+01,.3510559E+01,.3516551E+01,.3567108E+01,.3728771E+01,& + & .3588141E+01,.3486709E+01,.3487212E+01,.3537489E+01,.3711452E+01,& + & .3614294E+01,.3574997E+01,.3596711E+01,.3647701E+01,.3772830E+01,& + & .3611060E+01,.3557018E+01,.3574287E+01,.3625347E+01,.3761707E+01,& + & .3606301E+01,.3537069E+01,.3549260E+01,.3600210E+01,.3747990E+01,& + & .3599986E+01,.3515632E+01,.3522343E+01,.3572792E+01,.3732484E+01,& + & .3590746E+01,.3491810E+01,.3493076E+01,.3543289E+01,.3715323E+01,& + & .3615385E+01,.3578875E+01,.3601241E+01,.3652114E+01,.3775522E+01,& + & .3612653E+01,.3561267E+01,.3579150E+01,.3630121E+01,.3764687E+01,& + & .3608225E+01,.3541594E+01,.3554508E+01,.3605343E+01,.3751304E+01,& + & .3601890E+01,.3520037E+01,.3527598E+01,.3578113E+01,.3735943E+01,& + & .3593282E+01,.3496658E+01,.3498659E+01,.3548727E+01,.3718739E+01,& + & .3616729E+01,.3584234E+01,.3607568E+01,.3658316E+01,.3778888E+01,& + & .3614336E+01,.3567065E+01,.3586083E+01,.3636983E+01,.3768550E+01,& + & .3610281E+01,.3547775E+01,.3561945E+01,.3612790E+01,.3755757E+01,& + & .3604549E+01,.3526723E+01,.3535518E+01,.3586033E+01,.3740710E+01,& + & .3596403E+01,.3503693E+01,.3506997E+01,.3557144E+01,.3724043E+01/ + + data absb(701:875,10) / & + & .3617849E+01,.3589442E+01,.3613858E+01,.3664479E+01,.3782091E+01,& + & .3615818E+01,.3572805E+01,.3592899E+01,.3643677E+01,.3772222E+01,& + & .3612124E+01,.3553880E+01,.3569311E+01,.3620106E+01,.3759976E+01,& + & .3606887E+01,.3533209E+01,.3543433E+01,.3593996E+01,.3745475E+01,& + & .3599450E+01,.3510687E+01,.3515389E+01,.3565549E+01,.3729132E+01,& + & .3618859E+01,.3594390E+01,.3619692E+01,.3670127E+01,.3784822E+01,& + & .3617031E+01,.3578150E+01,.3599460E+01,.3650217E+01,.3775829E+01,& + & .3613773E+01,.3559780E+01,.3576444E+01,.3627182E+01,.3764034E+01,& + & .3609186E+01,.3539677E+01,.3551204E+01,.3601833E+01,.3750137E+01,& + & .3602259E+01,.3517530E+01,.3523661E+01,.3573794E+01,.3734189E+01,& + & .3619642E+01,.3599861E+01,.3626247E+01,.3676465E+01,.3787596E+01,& + & .3618160E+01,.3584226E+01,.3606851E+01,.3657509E+01,.3779539E+01,& + & .3615477E+01,.3566520E+01,.3584677E+01,.3635460E+01,.3768627E+01,& + & .3611247E+01,.3546802E+01,.3559989E+01,.3610646E+01,.3755225E+01,& + & .3605074E+01,.3525201E+01,.3533059E+01,.3583351E+01,.3739819E+01,& + & .3620312E+01,.3605283E+01,.3632856E+01,.3682831E+01,.3790274E+01,& + & .3619186E+01,.3590447E+01,.3614470E+01,.3665009E+01,.3783275E+01,& + & .3616882E+01,.3573318E+01,.3593065E+01,.3643837E+01,.3773166E+01,& + & .3613451E+01,.3554344E+01,.3569198E+01,.3619779E+01,.3760340E+01,& + & .3607869E+01,.3533334E+01,.3542978E+01,.3593388E+01,.3745727E+01,& + & .3620861E+01,.3610352E+01,.3639014E+01,.3688623E+01,.3792389E+01,& + & .3619907E+01,.3596190E+01,.3621534E+01,.3671961E+01,.3786487E+01,& + & .3618144E+01,.3579813E+01,.3601034E+01,.3651766E+01,.3777268E+01,& + & .3615214E+01,.3561501E+01,.3578086E+01,.3628673E+01,.3765343E+01,& + & .3610346E+01,.3541102E+01,.3552515E+01,.3602980E+01,.3751243E+01,& + & .3621171E+01,.3615299E+01,.3645122E+01,.3694327E+01,.3794232E+01,& + & .3620700E+01,.3602063E+01,.3628647E+01,.3678772E+01,.3789342E+01,& + & .3619172E+01,.3586367E+01,.3609119E+01,.3659731E+01,.3781216E+01,& + & .3616635E+01,.3568642E+01,.3586973E+01,.3637668E+01,.3770251E+01,& + & .3612602E+01,.3549063E+01,.3562386E+01,.3612958E+01,.3756942E+01,& + & .3621585E+01,.3620432E+01,.3651384E+01,.3699855E+01,.3795401E+01,& + & .3621229E+01,.3608077E+01,.3635997E+01,.3685814E+01,.3792009E+01,& + & .3620075E+01,.3593269E+01,.3617681E+01,.3668163E+01,.3785187E+01,& + & .3618192E+01,.3576439E+01,.3596584E+01,.3647184E+01,.3775165E+01,& + & .3614853E+01,.3557603E+01,.3572939E+01,.3623466E+01,.3762716E+01/ + + data absb(876:1050,10) / & + & .3621531E+01,.3624874E+01,.3656941E+01,.3704801E+01,.3796091E+01,& + & .3621578E+01,.3613665E+01,.3642948E+01,.3692378E+01,.3794280E+01,& + & .3620925E+01,.3599898E+01,.3625750E+01,.3676030E+01,.3788596E+01,& + & .3619395E+01,.3583738E+01,.3605662E+01,.3656221E+01,.3779663E+01,& + & .3616452E+01,.3565615E+01,.3582989E+01,.3633553E+01,.3768255E+01,& + & .3621699E+01,.3629071E+01,.3661985E+01,.3709070E+01,.3796100E+01,& + & .3621985E+01,.3618898E+01,.3649290E+01,.3698155E+01,.3795661E+01,& + & .3621415E+01,.3605926E+01,.3633265E+01,.3683249E+01,.3791501E+01,& + & .3620359E+01,.3590761E+01,.3614336E+01,.3664785E+01,.3783789E+01,& + & .3618117E+01,.3573457E+01,.3592656E+01,.3643288E+01,.3773301E+01,& + & .3621904E+01,.3632715E+01,.3666350E+01,.3712572E+01,.3795707E+01,& + & .3622024E+01,.3623236E+01,.3654773E+01,.3703040E+01,.3796613E+01,& + & .3621869E+01,.3611272E+01,.3639856E+01,.3689474E+01,.3793663E+01,& + & .3621052E+01,.3597007E+01,.3622051E+01,.3672345E+01,.3787216E+01,& + & .3619289E+01,.3580478E+01,.3601357E+01,.3651927E+01,.3777750E+01,& + & .3621852E+01,.3635792E+01,.3669888E+01,.3715191E+01,.3794554E+01,& + & .3622079E+01,.3627138E+01,.3659507E+01,.3707091E+01,.3796772E+01,& + & .3622144E+01,.3616154E+01,.3645824E+01,.3695017E+01,.3795270E+01,& + & .3621572E+01,.3602644E+01,.3629021E+01,.3679124E+01,.3790058E+01,& + & .3620273E+01,.3586904E+01,.3609375E+01,.3659834E+01,.3781548E+01,& + & .3621524E+01,.3638153E+01,.3672641E+01,.3717019E+01,.3792489E+01,& + & .3622011E+01,.3630710E+01,.3663819E+01,.3710696E+01,.3796596E+01,& + & .3622140E+01,.3620549E+01,.3651350E+01,.3700088E+01,.3796517E+01,& + & .3621964E+01,.3607992E+01,.3635644E+01,.3685439E+01,.3792448E+01,& + & .3620930E+01,.3593051E+01,.3617045E+01,.3667379E+01,.3785155E+01,& + & .3621285E+01,.3640375E+01,.3675144E+01,.3718598E+01,.3790284E+01,& + & .3621997E+01,.3633935E+01,.3667680E+01,.3713679E+01,.3795786E+01,& + & .3622336E+01,.3624705E+01,.3656432E+01,.3704538E+01,.3797068E+01,& + & .3622150E+01,.3612954E+01,.3641755E+01,.3691352E+01,.3794423E+01,& + & .3621542E+01,.3598955E+01,.3624346E+01,.3674512E+01,.3788265E+01,& + & .3620995E+01,.3641953E+01,.3676700E+01,.3719069E+01,.3787249E+01,& + & .3621905E+01,.3636516E+01,.3670740E+01,.3715933E+01,.3794540E+01,& + & .3622165E+01,.3628082E+01,.3660699E+01,.3708147E+01,.3797220E+01,& + & .3622324E+01,.3617255E+01,.3647220E+01,.3696381E+01,.3795917E+01,& + & .3621972E+01,.3604029E+01,.3630657E+01,.3680650E+01,.3790740E+01/ + + data absb(1051:1175,10) / & + & .3620526E+01,.3643008E+01,.3677709E+01,.3719079E+01,.3783909E+01,& + & .3621663E+01,.3638625E+01,.3673147E+01,.3717490E+01,.3792683E+01,& + & .3622181E+01,.3631146E+01,.3664388E+01,.3711198E+01,.3796901E+01,& + & .3622567E+01,.3621247E+01,.3652054E+01,.3700619E+01,.3796719E+01,& + & .3622221E+01,.3608539E+01,.3636273E+01,.3686109E+01,.3792815E+01,& + & .3620197E+01,.3643890E+01,.3678333E+01,.3718665E+01,.3780167E+01,& + & .3621325E+01,.3640368E+01,.3675148E+01,.3718577E+01,.3790537E+01,& + & .3622155E+01,.3633956E+01,.3667672E+01,.3713768E+01,.3796050E+01,& + & .3622497E+01,.3624766E+01,.3656479E+01,.3704595E+01,.3797402E+01,& + & .3622419E+01,.3612956E+01,.3641709E+01,.3691233E+01,.3794545E+01,& + & .3619809E+01,.3644465E+01,.3678494E+01,.3717752E+01,.3775862E+01,& + & .3621149E+01,.3642028E+01,.3676823E+01,.3719299E+01,.3787818E+01,& + & .3621940E+01,.3636328E+01,.3670542E+01,.3715827E+01,.3794751E+01,& + & .3622399E+01,.3627949E+01,.3660463E+01,.3707973E+01,.3797438E+01,& + & .3622573E+01,.3617046E+01,.3646813E+01,.3695952E+01,.3795817E+01,& + & .3619235E+01,.3644575E+01,.3678035E+01,.3716081E+01,.3771129E+01,& + & .3620784E+01,.3643128E+01,.3677789E+01,.3719247E+01,.3784648E+01,& + & .3621727E+01,.3638446E+01,.3672940E+01,.3717422E+01,.3793308E+01,& + & .3622318E+01,.3630870E+01,.3663967E+01,.3710850E+01,.3797063E+01,& + & .3622631E+01,.3620709E+01,.3651341E+01,.3700062E+01,.3796727E+01,& + & .3618949E+01,.3644500E+01,.3677804E+01,.3715402E+01,.3769243E+01,& + & .3620600E+01,.3643472E+01,.3678108E+01,.3719204E+01,.3783320E+01,& + & .3621596E+01,.3639124E+01,.3673749E+01,.3717908E+01,.3792537E+01,& + & .3622327E+01,.3631967E+01,.3665327E+01,.3711976E+01,.3796952E+01,& + & .3622725E+01,.3622155E+01,.3653104E+01,.3701619E+01,.3797027E+01/ + +! --- + data forref(1:4,1:10) / & + & .1100080E-06,.6309120E-06,.3631590E-05,.6168920E-05,.4297090E-05,& + & .7891740E-05,.2174160E-04,.6393930E-04,.4362830E-04,.5262470E-04,& + & .1163410E-03,.2056160E-03,.2156270E-03,.2345220E-03,.2804970E-03,& + & .8386680E-03,.5292830E-03,.6208480E-03,.9355610E-03,.1712520E-02,& + & .2122670E-02,.2185640E-02,.2222270E-02,.1996500E-02,.2911200E-02,& + & .2811680E-02,.2595430E-02,.2101590E-02,.3162490E-02,.3106950E-02,& + & .2795010E-02,.2080760E-02,.3591895E-02,.3399762E-02,.3018810E-02,& + & .1801670E-02,.4302254E-02,.4229914E-02,.3954639E-02,.2291698E-02/ + + + data selfref(1:10,1:10) / & + & .1158870E-03,.9265370E-04,.7407830E-04,.5922700E-04,.4735300E-04,& + & .3785960E-04,.3026940E-04,.2420100E-04,.1934910E-04,.1547000E-04,& + & .4595570E-03,.3819620E-03,.3174690E-03,.2638660E-03,.2193130E-03,& + & .1822830E-03,.1515050E-03,.1259240E-03,.1046620E-03,.8699040E-04,& + & .1668210E-02,.1511030E-02,.1368660E-02,.1239700E-02,.1122900E-02,& + & .1017100E-02,.9212660E-03,.8344630E-03,.7558390E-03,.6846230E-03,& + & .4601750E-02,.4213720E-02,.3858420E-02,.3533070E-02,.3235160E-02,& + & .2962360E-02,.2712570E-02,.2483850E-02,.2274400E-02,.2082620E-02,& + & .1015890E-01,.9247420E-02,.8417720E-02,.7662470E-02,.6974970E-02,& + & .6349170E-02,.5779510E-02,.5260960E-02,.4788930E-02,.4359260E-02,& + & .3280430E-01,.3008530E-01,.2759170E-01,.2530480E-01,.2320750E-01,& + & .2128390E-01,.1951980E-01,.1790200E-01,.1641820E-01,.1505740E-01,& + & .4059360E-01,.3760320E-01,.3483310E-01,.3226710E-01,.2989010E-01,& + & .2768830E-01,.2564860E-01,.2375910E-01,.2200890E-01,.2038760E-01,& + & .4483620E-01,.4138110E-01,.3819230E-01,.3524920E-01,.3253290E-01,& + & .3002590E-01,.2771210E-01,.2557660E-01,.2360560E-01,.2178660E-01,& + & .4836264E-01,.4491932E-01,.4172126E-01,.3875097E-01,.3599212E-01,& + & .3342979E-01,.3105000E-01,.2883953E-01,.2678655E-01,.2487982E-01,& + & .6056851E-01,.5576215E-01,.5133769E-01,.4726472E-01,.4351530E-01,& + & .4006365E-01,.3688611E-01,.3396089E-01,.3126793E-01,.2878878E-01/ + +!........................................! + end module module_radsw_kgb21 ! +!========================================! + +!> This module sets up absorption coeffients for band 22: 7700-8050 +!! cm-1 (low - h2o, o2; high - o2) +!========================================! + module module_radsw_kgb22 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG22 + +! + implicit none +! + private +! +!> msa22=585 + integer, public :: MSA22 +!> msb22=235 + integer, public :: MSB22 +!> msf22=10 + integer, public :: MSF22 +!> mfr22=3 + integer, public :: MFR22 + parameter (MSA22=585, MSB22=235, MSF22=10, MFR22=3) + + real (kind=kind_phys), public :: forref(MFR22,NG22) + +!> the array absa(585,NG22) (ka(9,5,13,NG22)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 2, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA22,NG22) + +!> the array absb(235,2) (kb(5,13:59,2)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 2, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB22,NG22) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 2). + real (kind=kind_phys), public :: selfref(MSF22,NG22) + +!> rayleigh extinction coefficient at \f$v=8000cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 1.54e-08 + + + data absa( 1:180, 1) / & + & .4811305E-05,.6129178E-05,.6975295E-05,.7459097E-05,.7681764E-05,& + & .7669132E-05,.7386319E-05,.6757954E-05,.4773633E-05,.4852970E-05,& + & .6482051E-05,.7514931E-05,.8141914E-05,.8481015E-05,.8536849E-05,& + & .8278644E-05,.7661509E-05,.5661537E-05,.4887964E-05,.6857744E-05,& + & .8089331E-05,.8885017E-05,.9332288E-05,.9453783E-05,.9249515E-05,& + & .8659290E-05,.6666955E-05,.4916026E-05,.7226977E-05,.8662139E-05,& + & .9602646E-05,.1014228E-04,.1032751E-04,.1017396E-04,.9601762E-05,& + & .7631048E-05,.4939202E-05,.7613809E-05,.9263194E-05,.1033860E-04,& + & .1098728E-04,.1125104E-04,.1116365E-04,.1062721E-04,.8702900E-05,& + & .4106730E-05,.5324296E-05,.6058728E-05,.6475552E-05,.6675502E-05,& + & .6660409E-05,.6407153E-05,.5864093E-05,.3937516E-05,.4142531E-05,& + & .5645457E-05,.6543640E-05,.7093457E-05,.7392197E-05,.7432767E-05,& + & .7202851E-05,.6679036E-05,.4695930E-05,.4172412E-05,.5983858E-05,& + & .7068059E-05,.7761470E-05,.8155332E-05,.8259215E-05,.8079259E-05,& + & .7583378E-05,.5569182E-05,.4197861E-05,.6325920E-05,.7598301E-05,& + & .8416188E-05,.8900428E-05,.9074421E-05,.8942307E-05,.8472099E-05,& + & .6440222E-05,.4216312E-05,.6670040E-05,.8121375E-05,.9056370E-05,& + & .9638048E-05,.9875647E-05,.9796244E-05,.9352752E-05,.7315977E-05,& + & .3467259E-05,.4530486E-05,.5130556E-05,.5469514E-05,.5627152E-05,& + & .5606389E-05,.5378296E-05,.4903857E-05,.3080725E-05,.3499079E-05,& + & .4815823E-05,.5557660E-05,.6015497E-05,.6256261E-05,.6280454E-05,& + & .6078238E-05,.5616791E-05,.3711088E-05,.3526114E-05,.5110612E-05,& + & .6012398E-05,.6587675E-05,.6901419E-05,.6980572E-05,.6815694E-05,& + & .6375015E-05,.4396734E-05,.3547696E-05,.5422743E-05,.6499204E-05,& + & .7185087E-05,.7588601E-05,.7739029E-05,.7620329E-05,.7212753E-05,& + & .5186395E-05,.3563976E-05,.5729219E-05,.6960032E-05,.7748552E-05,& + & .8240995E-05,.8448645E-05,.8371310E-05,.7991578E-05,.5921336E-05,& + & .2903406E-05,.3807717E-05,.4284968E-05,.4550532E-05,.4671249E-05,& + & .4645256E-05,.4435665E-05,.4014615E-05,.2368786E-05,.2932650E-05,& + & .4056866E-05,.4656270E-05,.5027012E-05,.5216501E-05,.5228575E-05,& + & .5042545E-05,.4630358E-05,.2886709E-05,.2956965E-05,.4316547E-05,& + & .5055602E-05,.5525523E-05,.5778913E-05,.5837818E-05,.5685140E-05,& + & .5291024E-05,.3454518E-05,.2976066E-05,.4585564E-05,.5471875E-05,& + & .6031035E-05,.6358030E-05,.6472254E-05,.6355066E-05,.5985167E-05,& + & .4072052E-05,.2992113E-05,.4870065E-05,.5900799E-05,.6563641E-05,& + & .6978014E-05,.7155318E-05,.7090308E-05,.6756111E-05,.4779983E-05/ + + data absa(181:315, 1) / & + & .2416301E-05,.3175817E-05,.3551611E-05,.3757653E-05,.3845981E-05,& + & .3806815E-05,.3615925E-05,.3248989E-05,.1807537E-05,.2442982E-05,& + & .3391649E-05,.3872022E-05,.4168023E-05,.4314273E-05,.4308869E-05,& + & .4135096E-05,.3773612E-05,.2229249E-05,.2464689E-05,.3616511E-05,& + & .4219290E-05,.4597739E-05,.4800153E-05,.4835853E-05,.4687880E-05,& + & .4341846E-05,.2697930E-05,.2482346E-05,.3851272E-05,.4579688E-05,& + & .5036754E-05,.5303465E-05,.5384276E-05,.5269123E-05,.4942816E-05,& + & .3211571E-05,.2496958E-05,.4103453E-05,.4953618E-05,.5507193E-05,& + & .5845841E-05,.5983458E-05,.5915896E-05,.5620275E-05,.3806808E-05,& + & .1999899E-05,.2625031E-05,.2915420E-05,.3071867E-05,.3124395E-05,& + & .3072646E-05,.2900498E-05,.2587050E-05,.1352887E-05,.2024083E-05,& + & .2809833E-05,.3188693E-05,.3420314E-05,.3522509E-05,.3496553E-05,& + & .3339109E-05,.3027660E-05,.1693245E-05,.2044050E-05,.3003017E-05,& + & .3487914E-05,.3787092E-05,.3938052E-05,.3945979E-05,.3809484E-05,& + & .3508701E-05,.2075300E-05,.2060639E-05,.3207415E-05,.3796719E-05,& + & .4165268E-05,.4370415E-05,.4417121E-05,.4305496E-05,.4021839E-05,& + & .2497828E-05,.2073109E-05,.3422126E-05,.4107505E-05,.4555166E-05,& + & .4814366E-05,.4903671E-05,.4826510E-05,.4567702E-05,.2956470E-05,& + & .1648342E-05,.2157145E-05,.2379934E-05,.2491203E-05,.2516412E-05,& + & .2455538E-05,.2301740E-05,.2037661E-05,.1000718E-05,.1669893E-05,& + & .2314044E-05,.2612275E-05,.2784581E-05,.2848144E-05,.2810417E-05,& + & .2667632E-05,.2403320E-05,.1271614E-05,.1688235E-05,.2479334E-05,& + & .2867128E-05,.3096477E-05,.3197978E-05,.3188985E-05,.3063442E-05,& + & .2806027E-05,.1579154E-05,.1703269E-05,.2655822E-05,.3129870E-05,& + & .3418130E-05,.3565529E-05,.3589051E-05,.3483463E-05,.3238464E-05,& + & .1922786E-05,.1714256E-05,.2841908E-05,.3397528E-05,.3751189E-05,& + & .3946139E-05,.4003586E-05,.3926825E-05,.3703912E-05,.2299592E-05/ + + data absa(316:450, 1) / & + & .1353974E-05,.1765068E-05,.1932966E-05,.2007855E-05,.2012902E-05,& + & .1948449E-05,.1811997E-05,.1592898E-05,.7335145E-06,.1373071E-05,& + & .1897413E-05,.2129239E-05,.2252513E-05,.2286864E-05,.2242429E-05,& + & .2114952E-05,.1891560E-05,.9471789E-06,.1389649E-05,.2038030E-05,& + & .2344379E-05,.2513362E-05,.2580054E-05,.2558580E-05,.2443905E-05,& + & .2225644E-05,.1192247E-05,.1403159E-05,.2190301E-05,.2568252E-05,& + & .2784775E-05,.2889879E-05,.2895016E-05,.2795830E-05,.2587464E-05,& + & .1469124E-05,.1413141E-05,.2349730E-05,.2797042E-05,.3067316E-05,& + & .3212459E-05,.3245440E-05,.3170497E-05,.2979658E-05,.1775814E-05,& + & .1109176E-05,.1438260E-05,.1560320E-05,.1608170E-05,.1598482E-05,& + & .1534740E-05,.1415276E-05,.1235245E-05,.5310552E-06,.1125890E-05,& + & .1549645E-05,.1724605E-05,.1809358E-05,.1823301E-05,.1775680E-05,& + & .1662906E-05,.1476017E-05,.6978386E-06,.1140697E-05,.1669212E-05,& + & .1904678E-05,.2026271E-05,.2067267E-05,.2037250E-05,.1934040E-05,& + & .1748711E-05,.8911666E-06,.1152696E-05,.1799505E-05,.2093197E-05,& + & .2254146E-05,.2325995E-05,.2316830E-05,.2226050E-05,.2048536E-05,& + & .1112322E-05,.1161759E-05,.1935095E-05,.2286766E-05,.2492651E-05,& + & .2596669E-05,.2611477E-05,.2539447E-05,.2375149E-05,.1359322E-05,& + & .9077717E-06,.1174065E-05,.1263812E-05,.1292739E-05,.1275331E-05,& + & .1215719E-05,.1112922E-05,.9650216E-06,.3899969E-06,.9222425E-06,& + & .1268083E-05,.1400764E-05,.1458340E-05,.1460261E-05,.1413218E-05,& + & .1314688E-05,.1159764E-05,.5200394E-06,.9352421E-06,.1370113E-05,& + & .1550495E-05,.1639021E-05,.1662747E-05,.1629076E-05,.1537446E-05,& + & .1381442E-05,.6733322E-06,.9455894E-06,.1481006E-05,.1708811E-05,& + & .1830099E-05,.1878238E-05,.1861201E-05,.1779442E-05,.1628569E-05,& + & .8501168E-06,.9536626E-06,.1596411E-05,.1872605E-05,.2030381E-05,& + & .2104312E-05,.2107801E-05,.2041174E-05,.1900067E-05,.1049009E-05/ + + data absa(451:585, 1) / & + & .7476406E-06,.9904317E-06,.1070509E-05,.1095431E-05,.1080587E-05,& + & .1030695E-05,.9437084E-06,.8190527E-06,.3284667E-06,.7596122E-06,& + & .1072730E-05,.1188660E-05,.1237753E-05,.1239815E-05,.1198979E-05,& + & .1115702E-05,.9855200E-06,.4385665E-06,.7699182E-06,.1162790E-05,& + & .1317244E-05,.1392618E-05,.1412049E-05,.1383498E-05,.1305642E-05,& + & .1175399E-05,.5683962E-06,.7780771E-06,.1258890E-05,.1452488E-05,& + & .1555737E-05,.1595474E-05,.1580904E-05,.1512840E-05,.1387631E-05,& + & .7175693E-06,.7842272E-06,.1356608E-05,.1593107E-05,.1725648E-05,& + & .1788723E-05,.1792615E-05,.1737571E-05,.1621220E-05,.8851099E-06,& + & .6151816E-06,.8344601E-06,.9039065E-06,.9253730E-06,.9133751E-06,& + & .8709904E-06,.7977024E-06,.6919990E-06,.2763894E-06,.6250011E-06,& + & .9064917E-06,.1005419E-05,.1047668E-05,.1048849E-05,.1014123E-05,& + & .9437407E-06,.8343490E-06,.3694765E-06,.6331236E-06,.9841850E-06,& + & .1115823E-05,.1179325E-05,.1194996E-05,.1170425E-05,.1105130E-05,& + & .9965785E-06,.4789252E-06,.6395688E-06,.1066132E-05,.1231039E-05,& + & .1317746E-05,.1350903E-05,.1338577E-05,.1281845E-05,.1177960E-05,& + & .6042803E-06,.6438610E-06,.1149508E-05,.1350173E-05,.1462385E-05,& + & .1516252E-05,.1519539E-05,.1474251E-05,.1378037E-05,.7447887E-06,& + & .5057177E-06,.7019314E-06,.7608992E-06,.7796527E-06,.7694622E-06,& + & .7335795E-06,.6717508E-06,.5829027E-06,.2320809E-06,.5135675E-06,& + & .7639636E-06,.8482237E-06,.8838364E-06,.8842773E-06,.8547719E-06,& + & .7955572E-06,.7038419E-06,.3103090E-06,.5201276E-06,.8305264E-06,& + & .9421352E-06,.9952533E-06,.1007989E-05,.9869406E-06,.9321635E-06,& + & .8418452E-06,.4021416E-06,.5249168E-06,.9003622E-06,.1040066E-05,& + & .1112264E-05,.1140134E-05,.1130238E-05,.1082715E-05,.9969161E-06,& + & .5069884E-06,.5279947E-06,.9718501E-06,.1141014E-05,.1235721E-05,& + & .1280968E-05,.1284659E-05,.1246723E-05,.1167012E-05,.6247983E-06/ + + data absa( 1:180, 2) / & + & .3134144E-03,.2768907E-03,.2479948E-03,.2249616E-03,.2061518E-03,& + & .1911399E-03,.1804902E-03,.1753720E-03,.1923166E-03,.3125459E-03,& + & .2772983E-03,.2516939E-03,.2326523E-03,.2182683E-03,.2084544E-03,& + & .2037087E-03,.2047079E-03,.2282142E-03,.3117491E-03,.2781161E-03,& + & .2564198E-03,.2417736E-03,.2327659E-03,.2290275E-03,.2305224E-03,& + & .2382043E-03,.2687208E-03,.3110029E-03,.2794674E-03,.2621069E-03,& + & .2527413E-03,.2498662E-03,.2527146E-03,.2610136E-03,.2760286E-03,& + & .3138217E-03,.3102439E-03,.2812588E-03,.2688570E-03,.2657349E-03,& + & .2695233E-03,.2795220E-03,.2951889E-03,.3180254E-03,.3635083E-03,& + & .3250728E-03,.2877719E-03,.2582845E-03,.2339301E-03,.2130875E-03,& + & .1957091E-03,.1821765E-03,.1732917E-03,.1869083E-03,.3243276E-03,& + & .2884264E-03,.2623057E-03,.2418236E-03,.2253898E-03,.2131266E-03,& + & .2052326E-03,.2020436E-03,.2226017E-03,.3236251E-03,.2895634E-03,& + & .2672790E-03,.2513043E-03,.2401735E-03,.2337268E-03,.2318615E-03,& + & .2350471E-03,.2629556E-03,.3229411E-03,.2911957E-03,.2732898E-03,& + & .2627372E-03,.2575851E-03,.2574466E-03,.2622274E-03,.2724290E-03,& + & .3080495E-03,.3222901E-03,.2933218E-03,.2805641E-03,.2761631E-03,& + & .2774714E-03,.2843448E-03,.2963172E-03,.3141300E-03,.3578779E-03,& + & .3356807E-03,.2975818E-03,.2669711E-03,.2405827E-03,.2171280E-03,& + & .1965563E-03,.1793297E-03,.1660515E-03,.1747079E-03,.3350220E-03,& + & .2984105E-03,.2711015E-03,.2483929E-03,.2291853E-03,.2134785E-03,& + & .2014226E-03,.1935279E-03,.2091221E-03,.3343949E-03,.2997564E-03,& + & .2761602E-03,.2578485E-03,.2437572E-03,.2334625E-03,.2271012E-03,& + & .2251640E-03,.2482498E-03,.3338041E-03,.3015868E-03,.2822818E-03,& + & .2693005E-03,.2608828E-03,.2565529E-03,.2565695E-03,.2612161E-03,& + & .2921963E-03,.3332193E-03,.3039287E-03,.2897558E-03,.2827271E-03,& + & .2804955E-03,.2828580E-03,.2898279E-03,.3016339E-03,.3409420E-03,& + & .3450280E-03,.3062487E-03,.2743678E-03,.2459208E-03,.2198163E-03,& + & .1960751E-03,.1752958E-03,.1579201E-03,.1604421E-03,.3444259E-03,& + & .3072374E-03,.2785358E-03,.2535346E-03,.2314569E-03,.2122613E-03,& + & .1962491E-03,.1838764E-03,.1931422E-03,.3438771E-03,.3087236E-03,& + & .2835940E-03,.2628376E-03,.2455747E-03,.2314574E-03,.2207572E-03,& + & .2139307E-03,.2305496E-03,.3433424E-03,.3107056E-03,.2897639E-03,& + & .2741158E-03,.2622176E-03,.2537611E-03,.2490381E-03,.2483736E-03,& + & .2727973E-03,.3428143E-03,.3132078E-03,.2972996E-03,.2873501E-03,& + & .2814114E-03,.2793015E-03,.2811140E-03,.2872362E-03,.3200560E-03/ + + data absa(181:315, 2) / & + & .3531053E-03,.3137584E-03,.2806342E-03,.2502419E-03,.2217600E-03,& + & .1953442E-03,.1713669E-03,.1502203E-03,.1465365E-03,.3525451E-03,& + & .3148795E-03,.2847860E-03,.2576829E-03,.2329973E-03,.2107590E-03,& + & .1912366E-03,.1747357E-03,.1774476E-03,.3520500E-03,.3165091E-03,& + & .2898443E-03,.2668091E-03,.2466298E-03,.2291220E-03,.2146066E-03,& + & .2032519E-03,.2129838E-03,.3515817E-03,.3186337E-03,.2960481E-03,& + & .2778468E-03,.2627291E-03,.2506136E-03,.2416613E-03,.2361063E-03,& + & .2533676E-03,.3511001E-03,.3212433E-03,.3036225E-03,.2908003E-03,& + & .2814464E-03,.2753399E-03,.2725583E-03,.2734290E-03,.2989606E-03,& + & .3599961E-03,.3201297E-03,.2856670E-03,.2533754E-03,.2227636E-03,& + & .1938352E-03,.1668527E-03,.1421432E-03,.1323787E-03,.3595027E-03,& + & .3213444E-03,.2897706E-03,.2605819E-03,.2334763E-03,.2084445E-03,& + & .1855378E-03,.1651107E-03,.1612872E-03,.3590452E-03,.3230619E-03,& + & .2947399E-03,.2694228E-03,.2465064E-03,.2258970E-03,.2076219E-03,& + & .1919813E-03,.1947351E-03,.3586303E-03,.3252517E-03,.3009081E-03,& + & .2801177E-03,.2619774E-03,.2463994E-03,.2333786E-03,.2231210E-03,& + & .2329972E-03,.3581989E-03,.3279250E-03,.3083841E-03,.2926945E-03,& + & .2800511E-03,.2701445E-03,.2629339E-03,.2586312E-03,.2762878E-03,& + & .3658182E-03,.3254390E-03,.2896752E-03,.2557287E-03,.2231665E-03,& + & .1919902E-03,.1623152E-03,.1344214E-03,.1190659E-03,.3653707E-03,& + & .3267289E-03,.2936760E-03,.2626621E-03,.2334132E-03,.2057935E-03,& + & .1798675E-03,.1559010E-03,.1460080E-03,.3649726E-03,.3284984E-03,& + & .2985492E-03,.2711719E-03,.2458593E-03,.2223271E-03,.2006879E-03,& + & .1811555E-03,.1773614E-03,.3645857E-03,.3307244E-03,.3046099E-03,& + & .2814987E-03,.2606681E-03,.2418349E-03,.2250909E-03,.2105867E-03,& + & .2134590E-03,.3642185E-03,.3334525E-03,.3119355E-03,.2937036E-03,& + & .2780069E-03,.2645516E-03,.2532548E-03,.2443282E-03,.2545442E-03/ + + data absa(316:450, 2) / & + & .3706916E-03,.3298152E-03,.2928733E-03,.2574333E-03,.2231173E-03,& + & .1899407E-03,.1579051E-03,.1272072E-03,.1069023E-03,.3702964E-03,& + & .3311594E-03,.2967583E-03,.2641125E-03,.2329078E-03,.2029732E-03,& + & .1743745E-03,.1473211E-03,.1319665E-03,.3699285E-03,.3329585E-03,& + & .3015284E-03,.2723221E-03,.2447616E-03,.2186223E-03,.1939959E-03,& + & .1710321E-03,.1612919E-03,.3695766E-03,.3351892E-03,.3074184E-03,& + & .2822618E-03,.2589063E-03,.2371561E-03,.2170927E-03,.1987943E-03,& + & .1952513E-03,.3692655E-03,.3379605E-03,.3145686E-03,.2940369E-03,& + & .2755227E-03,.2588395E-03,.2438914E-03,.2307984E-03,.2341519E-03,& + & .3747630E-03,.3333819E-03,.2953456E-03,.2585076E-03,.2226014E-03,& + & .1875711E-03,.1534395E-03,.1202799E-03,.9562602E-04,.3743949E-03,& + & .3347353E-03,.2991026E-03,.2649281E-03,.2319014E-03,.1998657E-03,& + & .1688739E-03,.1390792E-03,.1188772E-03,.3740704E-03,.3365341E-03,& + & .3037434E-03,.2727874E-03,.2431388E-03,.2146370E-03,.1873092E-03,& + & .1613140E-03,.1462150E-03,.3737686E-03,.3387595E-03,.3094625E-03,& + & .2823102E-03,.2566053E-03,.2321963E-03,.2091128E-03,.1874298E-03,& + & .1780428E-03,.3734709E-03,.3415160E-03,.3163831E-03,.2936218E-03,& + & .2724956E-03,.2528123E-03,.2345043E-03,.2177162E-03,.2147257E-03,& + & .3781153E-03,.3363497E-03,.2974396E-03,.2595086E-03,.2223300E-03,& + & .1858397E-03,.1500339E-03,.1149605E-03,.8681636E-04,.3777843E-03,& + & .3377331E-03,.3011323E-03,.2657468E-03,.2312660E-03,.1975718E-03,& + & .1646999E-03,.1327485E-03,.1086418E-03,.3774794E-03,.3395301E-03,& + & .3057000E-03,.2733530E-03,.2420489E-03,.2116788E-03,.1822379E-03,& + & .1538334E-03,.1343822E-03,.3772048E-03,.3417633E-03,.3112954E-03,& + & .2825617E-03,.2549956E-03,.2284826E-03,.2030187E-03,.1786623E-03,& + & .1644876E-03,.3769456E-03,.3445443E-03,.3180728E-03,.2935143E-03,& + & .2703103E-03,.2482498E-03,.2273178E-03,.2075828E-03,.1993535E-03/ + + data absa(451:585, 2) / & + & .3807336E-03,.3393314E-03,.3005620E-03,.2626883E-03,.2254498E-03,& + & .1887780E-03,.1527070E-03,.1172356E-03,.8770656E-04,.3804457E-03,& + & .3409096E-03,.3045588E-03,.2692926E-03,.2347827E-03,.2009743E-03,& + & .1678340E-03,.1354561E-03,.1098393E-03,.3801856E-03,.3428944E-03,& + & .3094604E-03,.2773048E-03,.2460506E-03,.2155751E-03,.1858896E-03,& + & .1570450E-03,.1359353E-03,.3799496E-03,.3453641E-03,.3154279E-03,& + & .2869512E-03,.2594977E-03,.2329282E-03,.2072109E-03,.1824185E-03,& + & .1664584E-03,.3797085E-03,.3484177E-03,.3225651E-03,.2983903E-03,& + & .2753339E-03,.2532382E-03,.2320873E-03,.2119269E-03,.2018178E-03,& + & .3829042E-03,.3418780E-03,.3032789E-03,.2654560E-03,.2281697E-03,& + & .1913858E-03,.1550847E-03,.1193084E-03,.8855999E-04,.3826538E-03,& + & .3436246E-03,.3075479E-03,.2723898E-03,.2378998E-03,.2039790E-03,& + & .1706332E-03,.1379197E-03,.1109681E-03,.3824225E-03,.3458050E-03,& + & .3127369E-03,.2807746E-03,.2495908E-03,.2190408E-03,.1891472E-03,& + & .1599572E-03,.1373987E-03,.3822117E-03,.3485078E-03,.3190368E-03,& + & .2908289E-03,.2634888E-03,.2368723E-03,.2109681E-03,.1858311E-03,& + & .1683087E-03,.3819986E-03,.3517908E-03,.3265146E-03,.3026775E-03,& + & .2797758E-03,.2576864E-03,.2363700E-03,.2158850E-03,.2040952E-03,& + & .3846876E-03,.3440378E-03,.3056059E-03,.2678315E-03,.2305157E-03,& + & .1936247E-03,.1571344E-03,.1210869E-03,.8928501E-04,.3844746E-03,& + & .3459486E-03,.3101125E-03,.2750561E-03,.2405776E-03,.2065779E-03,& + & .1730455E-03,.1400443E-03,.1119334E-03,.3842745E-03,.3483142E-03,& + & .3155650E-03,.2837694E-03,.2526251E-03,.2220255E-03,.1919644E-03,& + & .1624719E-03,.1386492E-03,.3840848E-03,.3512033E-03,.3221367E-03,& + & .2941685E-03,.2669103E-03,.2402530E-03,.2142043E-03,.1887786E-03,& + & .1698933E-03,.3839069E-03,.3546918E-03,.3299208E-03,.3063646E-03,& + & .2835973E-03,.2614972E-03,.2400614E-03,.2193165E-03,.2060528E-03/ + + + data absb( 1:120, 1) / & + & .1148431E-07,.1166076E-07,.1181018E-07,.1191914E-07,.1198918E-07,& + & .9447302E-08,.9588853E-08,.9702321E-08,.9781170E-08,.9829657E-08,& + & .7768804E-08,.7881241E-08,.7964406E-08,.8027339E-08,.8064535E-08,& + & .6387323E-08,.6478389E-08,.6541760E-08,.6584671E-08,.6611940E-08,& + & .5258216E-08,.5325260E-08,.5372095E-08,.5406858E-08,.5433075E-08,& + & .4325046E-08,.4376631E-08,.4414720E-08,.4442940E-08,.4468040E-08,& + & .3558904E-08,.3599790E-08,.3631084E-08,.3656572E-08,.3675668E-08,& + & .2928994E-08,.2962935E-08,.2992609E-08,.3011945E-08,.3028560E-08,& + & .2410261E-08,.2440986E-08,.2461561E-08,.2481755E-08,.2502470E-08,& + & .1987605E-08,.2009776E-08,.2031171E-08,.2053325E-08,.2074842E-08,& + & .1638935E-08,.1660456E-08,.1681270E-08,.1702299E-08,.1720110E-08,& + & .1354484E-08,.1373198E-08,.1393541E-08,.1411146E-08,.1425870E-08,& + & .1120107E-08,.1139127E-08,.1154912E-08,.1169427E-08,.1184272E-08,& + & .9286718E-09,.9430320E-09,.9571872E-09,.9708633E-09,.9838995E-09,& + & .7699187E-09,.7826246E-09,.7946201E-09,.8067476E-09,.8192210E-09,& + & .6396450E-09,.6506736E-09,.6618526E-09,.6737570E-09,.6838369E-09,& + & .5326710E-09,.5429777E-09,.5542978E-09,.5638603E-09,.5735975E-09,& + & .4444457E-09,.4553219E-09,.4646430E-09,.4739935E-09,.4848399E-09,& + & .3733850E-09,.3825372E-09,.3906037E-09,.4005917E-09,.4095546E-09,& + & .3137446E-09,.3209559E-09,.3301769E-09,.3382360E-09,.3459685E-09,& + & .2630519E-09,.2710057E-09,.2790274E-09,.2856675E-09,.2926209E-09,& + & .2217405E-09,.2292329E-09,.2353810E-09,.2416136E-09,.2479216E-09,& + & .1867928E-09,.1929235E-09,.1984309E-09,.2043657E-09,.2098748E-09,& + & .1569163E-09,.1620869E-09,.1668054E-09,.1724993E-09,.1773310E-09/ + + data absb(121:235, 1) / & + & .1308096E-09,.1354063E-09,.1397323E-09,.1448444E-09,.1490380E-09,& + & .1091276E-09,.1131669E-09,.1173393E-09,.1217436E-09,.1254286E-09,& + & .9109868E-10,.9461754E-10,.9833961E-10,.1018699E-09,.1054553E-09,& + & .7563445E-10,.7868380E-10,.8193156E-10,.8518848E-10,.8844146E-10,& + & .6263641E-10,.6531415E-10,.6821057E-10,.7108715E-10,.7394727E-10,& + & .5187154E-10,.5419548E-10,.5674107E-10,.5926221E-10,.6180436E-10,& + & .4271996E-10,.4475106E-10,.4699608E-10,.4922324E-10,.5127378E-10,& + & .3507508E-10,.3687109E-10,.3881362E-10,.4074018E-10,.4258146E-10,& + & .2877982E-10,.3031418E-10,.3201489E-10,.3369063E-10,.3530266E-10,& + & .2354780E-10,.2487550E-10,.2632461E-10,.2777491E-10,.2921257E-10,& + & .1917857E-10,.2030852E-10,.2155848E-10,.2281480E-10,.2406339E-10,& + & .1560083E-10,.1657804E-10,.1762140E-10,.1871016E-10,.1980295E-10,& + & .1265679E-10,.1349811E-10,.1439672E-10,.1532257E-10,.1626259E-10,& + & .1025893E-10,.1099795E-10,.1174551E-10,.1253606E-10,.1335795E-10,& + & .8310093E-11,.8943449E-11,.9572090E-11,.1024901E-10,.1095019E-10,& + & .6730157E-11,.7257352E-11,.7793431E-11,.8371987E-11,.8975155E-11,& + & .5435177E-11,.5888298E-11,.6335711E-11,.6830724E-11,.7343180E-11,& + & .4401117E-11,.4770132E-11,.5149810E-11,.5568023E-11,.6001500E-11,& + & .3553186E-11,.3856211E-11,.4189341E-11,.4542349E-11,.4912188E-11,& + & .2869971E-11,.3121146E-11,.3397253E-11,.3695718E-11,.4009005E-11,& + & .2316841E-11,.2524409E-11,.2751777E-11,.3000391E-11,.3264281E-11,& + & .1868320E-11,.2038026E-11,.2227552E-11,.2436194E-11,.2658837E-11,& + & .1531264E-11,.1674283E-11,.1835257E-11,.2010670E-11,.2200480E-11/ + + data absb( 1:120, 2) / & + & .8735620E-05,.8730295E-05,.8725985E-05,.8721791E-05,.8717868E-05,& + & .8768835E-05,.8764701E-05,.8760332E-05,.8756520E-05,.8752933E-05,& + & .8796329E-05,.8792037E-05,.8788589E-05,.8785089E-05,.8781325E-05,& + & .8818502E-05,.8814986E-05,.8812031E-05,.8808408E-05,.8804794E-05,& + & .8836927E-05,.8833555E-05,.8830851E-05,.8827746E-05,.8824444E-05,& + & .8852216E-05,.8849478E-05,.8846711E-05,.8842936E-05,.8839425E-05,& + & .8864508E-05,.8861820E-05,.8858820E-05,.8855571E-05,.8852261E-05,& + & .8874870E-05,.8872004E-05,.8869799E-05,.8866369E-05,.8862109E-05,& + & .8883129E-05,.8880356E-05,.8877848E-05,.8874404E-05,.8870894E-05,& + & .8890022E-05,.8886869E-05,.8884553E-05,.8881040E-05,.8876761E-05,& + & .8894947E-05,.8892776E-05,.8889874E-05,.8886360E-05,.8882208E-05,& + & .8899699E-05,.8896942E-05,.8893922E-05,.8890629E-05,.8886217E-05,& + & .8903090E-05,.8900055E-05,.8897299E-05,.8893628E-05,.8888999E-05,& + & .8905522E-05,.8902992E-05,.8899724E-05,.8895896E-05,.8891197E-05,& + & .8907716E-05,.8904994E-05,.8901656E-05,.8897848E-05,.8892455E-05,& + & .8909085E-05,.8906056E-05,.8903176E-05,.8899099E-05,.8893887E-05,& + & .8910421E-05,.8907592E-05,.8904343E-05,.8899582E-05,.8894302E-05,& + & .8911657E-05,.8908291E-05,.8904615E-05,.8899966E-05,.8893877E-05,& + & .8912045E-05,.8908750E-05,.8904978E-05,.8899891E-05,.8893523E-05,& + & .8912007E-05,.8908554E-05,.8905008E-05,.8899598E-05,.8893271E-05,& + & .8912113E-05,.8908681E-05,.8904415E-05,.8899216E-05,.8892224E-05,& + & .8911996E-05,.8908643E-05,.8903701E-05,.8898193E-05,.8891198E-05,& + & .8912323E-05,.8908424E-05,.8904030E-05,.8897838E-05,.8890898E-05,& + & .8912745E-05,.8908995E-05,.8904478E-05,.8898387E-05,.8891021E-05/ + + data absb(121:235, 2) / & + & .8913438E-05,.8910133E-05,.8905684E-05,.8899336E-05,.8892605E-05,& + & .8914238E-05,.8910808E-05,.8906957E-05,.8900965E-05,.8894403E-05,& + & .8915350E-05,.8911585E-05,.8907534E-05,.8901916E-05,.8895407E-05,& + & .8916208E-05,.8912694E-05,.8909062E-05,.8903707E-05,.8897419E-05,& + & .8916842E-05,.8914357E-05,.8910350E-05,.8905322E-05,.8899560E-05,& + & .8918148E-05,.8915052E-05,.8911721E-05,.8906637E-05,.8901314E-05,& + & .8918763E-05,.8916311E-05,.8912939E-05,.8908528E-05,.8903349E-05,& + & .8919788E-05,.8917267E-05,.8914201E-05,.8910219E-05,.8904947E-05,& + & .8920650E-05,.8918085E-05,.8915570E-05,.8911600E-05,.8907370E-05,& + & .8921233E-05,.8919303E-05,.8916881E-05,.8913302E-05,.8909080E-05,& + & .8922720E-05,.8920411E-05,.8917844E-05,.8914538E-05,.8910801E-05,& + & .8923377E-05,.8921620E-05,.8918941E-05,.8916117E-05,.8912493E-05,& + & .8924238E-05,.8922269E-05,.8920225E-05,.8917590E-05,.8913869E-05,& + & .8925304E-05,.8923279E-05,.8920969E-05,.8918470E-05,.8915390E-05,& + & .8926224E-05,.8924279E-05,.8921984E-05,.8919554E-05,.8916354E-05,& + & .8926896E-05,.8924592E-05,.8922547E-05,.8920115E-05,.8917801E-05,& + & .8927945E-05,.8925423E-05,.8923860E-05,.8921064E-05,.8918600E-05,& + & .8928033E-05,.8926417E-05,.8923949E-05,.8921931E-05,.8919379E-05,& + & .8929706E-05,.8927053E-05,.8924754E-05,.8922728E-05,.8920444E-05,& + & .8929850E-05,.8927620E-05,.8925048E-05,.8923373E-05,.8920887E-05,& + & .8931261E-05,.8928697E-05,.8925909E-05,.8924267E-05,.8921512E-05,& + & .8931652E-05,.8929478E-05,.8926979E-05,.8924651E-05,.8922436E-05,& + & .8932405E-05,.8929827E-05,.8927149E-05,.8924663E-05,.8922710E-05/ + +! --- + data forref(1:3,1: 2) / .8005249E-06,& + & .8929867E-06,.9310644E-06,.2367132E-05,.8712965E-06,.2553141E-06/ + + + data selfref(1:10,1: 2) / & + & .1890754E-03,.1626696E-03,.1404954E-03,.1218179E-03,.1060361E-03,& + & .9265747E-04,.8127769E-04,.7156485E-04,.6324571E-04,.5609450E-04,& + & .1435463E-03,.1416034E-03,.1400831E-03,.1390223E-03,.1384643E-03,& + & .1384633E-03,.1390821E-03,.1403951E-03,.1424925E-03,.1454806E-03/ + +!........................................! + end module module_radsw_kgb22 ! +!========================================! + + +!> This module sets up absorption coeffients for band 23: 8050-12850 +!! cm-1 (low - h2o; high - nothing) +!========================================! + module module_radsw_kgb23 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG23 + +! + implicit none +! + private +! +!> msa23=65 + integer, public :: MSA23 +!> msf23=10 + integer, public :: MSF23 +!> mfr23=3 + integer, public :: MFR23 + parameter (MSA23=65, MSF23=10, MFR23=3) + + real (kind=kind_phys), public :: forref(MFR23,NG23) + +!> the array absa(65,NG23) (ka(5,13,NG23)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 10, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA23,NG23) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 10). + real (kind=kind_phys), public :: selfref(MSF23,NG23) + +!> rayleigh extinction coefficient at all v + real (kind=kind_phys), public :: rayl(NG23) + +!> average giver et al. correction factor for this band. + real (kind=kind_phys), parameter, public :: givfac = 1.029 + +! --- rayleigh extinction coefficient at all v + data rayl (1:10) / & + & .5828588E-07,.5935776E-07,.5255710E-07,.4733880E-07,.4174660E-07,& + & .3980970E-07,.4007860E-07,.3674780E-07,.3456143E-07,.3212082E-07/ + + data absa( 1: 65, 1) / & + & .4349017E-06,.4470059E-06,.4658775E-06,.4619598E-06,.4690252E-06,& + & .3442571E-06,.3522645E-06,.3709106E-06,.3777774E-06,.3744779E-06,& + & .2678674E-06,.2763444E-06,.2843822E-06,.2996831E-06,.2973083E-06,& + & .2115438E-06,.2202997E-06,.2278028E-06,.2342144E-06,.2458529E-06,& + & .1770743E-06,.1850806E-06,.1926042E-06,.1976887E-06,.2082632E-06,& + & .2400161E-06,.2495213E-06,.2584593E-06,.2672377E-06,.2743845E-06,& + & .2965188E-06,.3124621E-06,.3263585E-06,.3361788E-06,.3465234E-06,& + & .5867176E-06,.6150627E-06,.6378628E-06,.6634773E-06,.6794765E-06,& + & .2613851E-05,.2661762E-05,.2697551E-05,.2717845E-05,.2731026E-05,& + & .4391054E-05,.4625930E-05,.4834719E-05,.5033254E-05,.5183516E-05,& + & .5804333E-05,.6050090E-05,.6263521E-05,.6493135E-05,.6671565E-05,& + & .6793586E-05,.7078673E-05,.7345537E-05,.7567607E-05,.7770683E-05,& + & .7689857E-05,.8029923E-05,.8306724E-05,.8523862E-05,.8740922E-05/ + + data absa( 1: 65, 2) / & + & .1671495E-04,.1698172E-04,.1762477E-04,.1736035E-04,.1748475E-04,& + & .1392235E-04,.1415328E-04,.1470623E-04,.1483132E-04,.1457076E-04,& + & .1145651E-04,.1165559E-04,.1181059E-04,.1229573E-04,.1205623E-04,& + & .9472038E-05,.9654257E-05,.9802561E-05,.9927636E-05,.1031608E-04,& + & .7831263E-05,.7996876E-05,.8135117E-05,.8252891E-05,.8598083E-05,& + & .6358154E-05,.6506960E-05,.6630804E-05,.6734304E-05,.6813372E-05,& + & .5148405E-05,.5280721E-05,.5396333E-05,.5487849E-05,.5553536E-05,& + & .5133743E-05,.5259110E-05,.5361676E-05,.5436170E-05,.5502268E-05,& + & .1218538E-04,.1263140E-04,.1302060E-04,.1326091E-04,.1346663E-04,& + & .4141871E-04,.4267769E-04,.4394235E-04,.4496715E-04,.4594083E-04,& + & .7068660E-04,.7240671E-04,.7377895E-04,.7506963E-04,.7606084E-04,& + & .8723266E-04,.8870892E-04,.9006588E-04,.9131091E-04,.9244792E-04,& + & .9151119E-04,.9291720E-04,.9438789E-04,.9568004E-04,.9699178E-04/ + + data absa( 1: 65, 3) / & + & .8285900E-04,.8481700E-04,.8905600E-04,.8805700E-04,.8941000E-04,& + & .7093700E-04,.7268500E-04,.7679600E-04,.7795500E-04,.7673500E-04,& + & .5987600E-04,.6144800E-04,.6283700E-04,.6629300E-04,.6499600E-04,& + & .5059800E-04,.5205400E-04,.5329300E-04,.5433200E-04,.5733300E-04,& + & .4274200E-04,.4403500E-04,.4516400E-04,.4613400E-04,.4893500E-04,& + & .3576900E-04,.3697500E-04,.3803800E-04,.3891700E-04,.3968100E-04,& + & .2974700E-04,.3082400E-04,.3175600E-04,.3258900E-04,.3331400E-04,& + & .2199400E-04,.2294500E-04,.2378600E-04,.2451700E-04,.2515500E-04,& + & .2229800E-04,.2268800E-04,.2312700E-04,.2380300E-04,.2433500E-04,& + & .8889800E-04,.9128000E-04,.9333300E-04,.9522400E-04,.9629800E-04,& + & .1229900E-03,.1240700E-03,.1253600E-03,.1264200E-03,.1281300E-03,& + & .1453900E-03,.1485100E-03,.1502200E-03,.1515700E-03,.1520400E-03,& + & .1594900E-03,.1623900E-03,.1646700E-03,.1666700E-03,.1680100E-03/ + + data absa( 1: 65, 4) / & + & .2533900E-03,.2599500E-03,.2717000E-03,.2696300E-03,.2741300E-03,& + & .2190800E-03,.2240400E-03,.2352200E-03,.2390200E-03,.2371700E-03,& + & .1861100E-03,.1907600E-03,.1951800E-03,.2050300E-03,.2022200E-03,& + & .1576900E-03,.1621000E-03,.1659700E-03,.1694800E-03,.1781700E-03,& + & .1340200E-03,.1379200E-03,.1415300E-03,.1443400E-03,.1526700E-03,& + & .1139000E-03,.1174300E-03,.1206500E-03,.1231600E-03,.1254300E-03,& + & .9641700E-04,.9961200E-04,.1023300E-03,.1045300E-03,.1065200E-03,& + & .8139500E-04,.8420500E-04,.8634600E-04,.8840600E-04,.9012200E-04,& + & .4777600E-04,.4897100E-04,.4973600E-04,.4991700E-04,.5028900E-04,& + & .1069800E-03,.1081500E-03,.1081700E-03,.1079900E-03,.1085100E-03,& + & .2022000E-03,.2072700E-03,.2124100E-03,.2167500E-03,.2198900E-03,& + & .2347400E-03,.2360100E-03,.2397400E-03,.2438300E-03,.2487600E-03,& + & .2341000E-03,.2380900E-03,.2418500E-03,.2455400E-03,.2495200E-03/ + + data absa( 1: 65, 5) / & + & .6702400E-03,.6802600E-03,.7041900E-03,.7015900E-03,.7108900E-03,& + & .5872900E-03,.5977800E-03,.6209700E-03,.6291200E-03,.6242300E-03,& + & .5096700E-03,.5190000E-03,.5276500E-03,.5479400E-03,.5426600E-03,& + & .4416700E-03,.4500600E-03,.4579300E-03,.4646900E-03,.4833500E-03,& + & .3809600E-03,.3888100E-03,.3957600E-03,.4025900E-03,.4208600E-03,& + & .3281800E-03,.3353900E-03,.3419200E-03,.3482900E-03,.3540500E-03,& + & .2825900E-03,.2894600E-03,.2958400E-03,.3020300E-03,.3074200E-03,& + & .2427300E-03,.2491200E-03,.2554600E-03,.2611000E-03,.2660700E-03,& + & .1993700E-03,.2065300E-03,.2131400E-03,.2196800E-03,.2252000E-03,& + & .1330600E-03,.1333100E-03,.1339300E-03,.1353800E-03,.1361600E-03,& + & .1623600E-03,.1615400E-03,.1618700E-03,.1611300E-03,.1620900E-03,& + & .1787200E-03,.1835500E-03,.1861200E-03,.1879200E-03,.1874500E-03,& + & .1897000E-03,.1938400E-03,.1977300E-03,.2026100E-03,.2037700E-03/ + + data absa( 1: 65, 6) / & + & .1813000E-02,.1830500E-02,.1871600E-02,.1865500E-02,.1881400E-02,& + & .1642000E-02,.1660000E-02,.1700600E-02,.1715600E-02,.1710800E-02,& + & .1468700E-02,.1487000E-02,.1504200E-02,.1542300E-02,.1537600E-02,& + & .1306800E-02,.1324800E-02,.1342100E-02,.1359200E-02,.1396000E-02,& + & .1157400E-02,.1175300E-02,.1192800E-02,.1209700E-02,.1246700E-02,& + & .1016700E-02,.1034200E-02,.1051500E-02,.1068100E-02,.1084000E-02,& + & .8899200E-03,.9066200E-03,.9229900E-03,.9384400E-03,.9534700E-03,& + & .7844500E-03,.8003100E-03,.8163900E-03,.8313100E-03,.8463100E-03,& + & .6981200E-03,.7131200E-03,.7280100E-03,.7422200E-03,.7560500E-03,& + & .3252100E-03,.3383500E-03,.3519400E-03,.3638100E-03,.3759400E-03,& + & .3140600E-03,.3201300E-03,.3245600E-03,.3326100E-03,.3374100E-03,& + & .2813200E-03,.2873200E-03,.2967400E-03,.3050900E-03,.3139300E-03,& + & .2570400E-03,.2631600E-03,.2719500E-03,.2773200E-03,.2890500E-03/ + + data absa( 1: 65, 7) / & + & .6737000E-02,.6787300E-02,.6889600E-02,.6881900E-02,.6926800E-02,& + & .6311100E-02,.6362200E-02,.6462300E-02,.6506000E-02,.6502700E-02,& + & .5883400E-02,.5936100E-02,.5985800E-02,.6081100E-02,.6080600E-02,& + & .5475300E-02,.5530900E-02,.5582300E-02,.5630600E-02,.5722900E-02,& + & .5078100E-02,.5137300E-02,.5189500E-02,.5239100E-02,.5332800E-02,& + & .4679100E-02,.4740800E-02,.4794900E-02,.4847000E-02,.4899300E-02,& + & .4272400E-02,.4338100E-02,.4395100E-02,.4450300E-02,.4506100E-02,& + & .3856800E-02,.3925400E-02,.3984800E-02,.4043100E-02,.4100500E-02,& + & .3565700E-02,.3636200E-02,.3699400E-02,.3760800E-02,.3821500E-02,& + & .3377400E-02,.3450100E-02,.3517100E-02,.3581100E-02,.3645000E-02,& + & .2392300E-02,.2462300E-02,.2526300E-02,.2589000E-02,.2651700E-02,& + & .1695900E-02,.1754200E-02,.1807700E-02,.1861400E-02,.1918700E-02,& + & .1173200E-02,.1223200E-02,.1271200E-02,.1322100E-02,.1367700E-02/ + + data absa( 1: 65, 8) / & + & .1960400E-01,.1969800E-01,.1993800E-01,.1985400E-01,.1995000E-01,& + & .1871400E-01,.1880300E-01,.1903500E-01,.1913100E-01,.1910200E-01,& + & .1767600E-01,.1778500E-01,.1790400E-01,.1818900E-01,.1815600E-01,& + & .1666200E-01,.1677300E-01,.1690800E-01,.1705600E-01,.1730300E-01,& + & .1565500E-01,.1577500E-01,.1594200E-01,.1610300E-01,.1635900E-01,& + & .1469400E-01,.1483800E-01,.1502900E-01,.1520000E-01,.1532000E-01,& + & .1379700E-01,.1395900E-01,.1417400E-01,.1435000E-01,.1447100E-01,& + & .1290200E-01,.1308900E-01,.1331300E-01,.1348900E-01,.1362600E-01,& + & .1189700E-01,.1210500E-01,.1233300E-01,.1251200E-01,.1265600E-01,& + & .1183400E-01,.1207200E-01,.1233100E-01,.1254800E-01,.1272100E-01,& + & .1141600E-01,.1169900E-01,.1196800E-01,.1214100E-01,.1231100E-01,& + & .1077600E-01,.1107000E-01,.1130900E-01,.1150700E-01,.1170200E-01,& + & .9957700E-02,.1026300E-01,.1049200E-01,.1071900E-01,.1095100E-01/ + + data absa( 1: 65, 9) / & + & .3722573E-01,.3735001E-01,.3766995E-01,.3757402E-01,.3768499E-01,& + & .3662238E-01,.3678396E-01,.3719958E-01,.3732433E-01,.3724068E-01,& + & .3562867E-01,.3578960E-01,.3595765E-01,.3640607E-01,.3634033E-01,& + & .3435375E-01,.3454391E-01,.3475193E-01,.3497256E-01,.3549406E-01,& + & .3293358E-01,.3315823E-01,.3338119E-01,.3362894E-01,.3419310E-01,& + & .3144491E-01,.3168016E-01,.3191274E-01,.3218704E-01,.3249824E-01,& + & .2994750E-01,.3018681E-01,.3043038E-01,.3073495E-01,.3106162E-01,& + & .2842901E-01,.2866936E-01,.2893935E-01,.2926623E-01,.2960819E-01,& + & .2613286E-01,.2638746E-01,.2667815E-01,.2703098E-01,.2739097E-01,& + & .2645921E-01,.2674553E-01,.2704316E-01,.2742667E-01,.2777404E-01,& + & .2621020E-01,.2647702E-01,.2689048E-01,.2732045E-01,.2775716E-01,& + & .2539997E-01,.2572727E-01,.2619059E-01,.2665103E-01,.2709386E-01,& + & .2408096E-01,.2452980E-01,.2508382E-01,.2552259E-01,.2603640E-01/ + + data absa( 1: 65,10) / & + & .1157665E+00,.1155684E+00,.1154876E+00,.1152633E+00,.1151482E+00,& + & .1272768E+00,.1270495E+00,.1269626E+00,.1267696E+00,.1265036E+00,& + & .1391213E+00,.1389149E+00,.1387068E+00,.1386130E+00,.1382518E+00,& + & .1505134E+00,.1502913E+00,.1500415E+00,.1497761E+00,.1496606E+00,& + & .1614616E+00,.1612169E+00,.1609519E+00,.1606590E+00,.1605876E+00,& + & .1719962E+00,.1717604E+00,.1715010E+00,.1711819E+00,.1708343E+00,& + & .1820676E+00,.1818515E+00,.1815935E+00,.1812537E+00,.1808999E+00,& + & .1917067E+00,.1915304E+00,.1912634E+00,.1909221E+00,.1905620E+00,& + & .2008731E+00,.2007265E+00,.2004847E+00,.2001356E+00,.1997760E+00,& + & .2030412E+00,.2029033E+00,.2026654E+00,.2022945E+00,.2019604E+00,& + & .2081847E+00,.2080855E+00,.2077116E+00,.2073153E+00,.2068695E+00,& + & .2148279E+00,.2146757E+00,.2142582E+00,.2138204E+00,.2133431E+00,& + & .2225531E+00,.2222204E+00,.2216768E+00,.2212495E+00,.2206397E+00/ + +! --- + data forref(1:3,1:10) / & + & .1709528E-06,.1749320E-06,.2303093E-05,.3273721E-05,.3572838E-05,& + & .7664943E-05,.9640070E-05,.1071100E-04,.1044860E-04,.3027750E-04,& + & .3575300E-04,.3407240E-04,.1024370E-03,.1084750E-03,.1052450E-03,& + & .1460540E-03,.1414900E-03,.1330710E-03,.1639780E-03,.1502080E-03,& + & .1428640E-03,.2204120E-03,.1829430E-03,.1509410E-03,.2312169E-03,& + & .2065332E-03,.1728525E-03,.2740557E-03,.2606475E-03,.2434367E-03/ + + + data selfref(1:10,1:10) / & + & .1042197E-04,.8992829E-05,.7807679E-05,.6819782E-05,.5991772E-05,& + & .5293756E-05,.4701789E-05,.4196660E-05,.3762952E-05,.3388235E-05,& + & .7734423E-04,.6990340E-04,.6317978E-04,.5710393E-04,.5161343E-04,& + & .4665177E-04,.4216797E-04,.3811593E-04,.3445388E-04,.3114436E-04,& + & .2064340E-03,.1874350E-03,.1701850E-03,.1545220E-03,.1403010E-03,& + & .1273880E-03,.1156640E-03,.1050190E-03,.9535400E-04,.8657830E-04,& + & .5906450E-03,.5331090E-03,.4811770E-03,.4343050E-03,.3919980E-03,& + & .3538120E-03,.3193460E-03,.2882380E-03,.2601600E-03,.2348170E-03,& + & .1630290E-02,.1487730E-02,.1357630E-02,.1238910E-02,.1130570E-02,& + & .1031700E-02,.9414830E-03,.8591530E-03,.7840230E-03,.7154620E-03,& + & .2045280E-02,.1892580E-02,.1751280E-02,.1620530E-02,.1499540E-02,& + & .1387580E-02,.1283980E-02,.1188120E-02,.1099410E-02,.1017330E-02,& + & .2105890E-02,.1970780E-02,.1844340E-02,.1726010E-02,.1615280E-02,& + & .1511640E-02,.1414660E-02,.1323900E-02,.1238960E-02,.1159470E-02,& + & .2450980E-02,.2337450E-02,.2229180E-02,.2125920E-02,.2027450E-02,& + & .1933530E-02,.1843970E-02,.1758560E-02,.1677100E-02,.1599410E-02,& + & .2838174E-02,.2668321E-02,.2508780E-02,.2358929E-02,.2218161E-02,& + & .2085920E-02,.1961685E-02,.1844964E-02,.1735293E-02,.1632237E-02,& + & .3679539E-02,.3409274E-02,.3159083E-02,.2927474E-02,.2713037E-02,& + & .2514491E-02,.2330645E-02,.2160398E-02,.2002729E-02,.1856699E-02/ + +!........................................! + end module module_radsw_kgb23 ! +!========================================! + +!> This module sets up absorption coeffients for band 24: 12850-16000 +!! cm-1 (low - h2o, o2; high - o2) +!========================================! + module module_radsw_kgb24 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG24 + +! + implicit none +! + private +! +!> msa24=585 + integer, public :: MSA24 +!> msb24=235 + integer, public :: MSB24 +!> msf24=10 + integer, public :: MSF24 +!> mfr24=3 + integer, public :: MFR24 +!> mfx24=9 + integer, public :: MFX24 + + parameter (MSA24=585, MSB24=235, MSF24=10, MFR24=3, MFX24=9) + + real (kind=kind_phys), public :: forref(MFR24,NG24) + +!> the array absa(585,NG24) (ka(9,5,13,NG24)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 8, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA24,NG24) + +!> the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 8, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB24,NG24) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. for instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 8). + real (kind=kind_phys), public :: selfref(MSF24,NG24) + +!> o3 + real (kind=kind_phys), public :: abso3a(NG24) +!> o3 + real (kind=kind_phys), public :: abso3b(NG24) + +!> rayleigh extinction coefficient at all v + real (kind=kind_phys), public :: rayla(NG24,MFX24) + real (kind=kind_phys), public :: raylb(NG24) + + data rayla (1: 8,1:9) / .1368516E-06,.1805397E-06,& + & .2243572E-06,.2191201E-06,.1450164E-06,.1344697E-06,.1214120E-06,& + & .1199659E-06,.1672218E-06,.2134978E-06,.1793655E-06,.1624268E-06,& + & .1442232E-06,.1377599E-06,.1214250E-06,.1199661E-06,.1708948E-06,& + & .2099293E-06,.1784014E-06,.1622850E-06,.1458217E-06,.1400260E-06,& + & .1241789E-06,.1199661E-06,.1737959E-06,.2064310E-06,.1785495E-06,& + & .1617341E-06,.1480687E-06,.1414056E-06,.1280616E-06,.1199661E-06,& + & .1751957E-06,.2045877E-06,.1784314E-06,.1614815E-06,.1507242E-06,& + & .1421961E-06,.1320991E-06,.1199661E-06,.1757802E-06,.2032567E-06,& + & .1789106E-06,.1613267E-06,.1525379E-06,.1429132E-06,.1360017E-06,& + & .1204062E-06,.1757127E-06,.2027785E-06,.1790739E-06,.1616034E-06,& + & .1535303E-06,.1446526E-06,.1386231E-06,.1317693E-06,.1746465E-06,& + & .2026682E-06,.1793777E-06,.1632574E-06,.1537427E-06,.1462557E-06,& + & .1419684E-06,.1489889E-06,.1524502E-06,.2170624E-06,.1873095E-06,& + & .1679364E-06,.1595036E-06,.1513078E-06,.1490206E-06,.1492883E-06/ + + data raylb (1: 8) / .1320456E-06,.1720100E-06,.2114786E-06,& + & .2446587E-06,.2048151E-06,.1382257E-06,.1353522E-06,.1198919E-06/ + +! --- o3 + data abso3a(1: 8) / .1300197E+00,.1988798E+00,.1272878E+00,& + & .8885802E-01,.6659378E-01,.5166209E-01,.3931020E-01,.2659650E-01/ + + data abso3b(1: 8) / .3634220E-01,.8528316E-01,.1832493E+00,& + & .2884644E+00,.3568897E+00,.3534033E+00,.1043294E+00,.2575196E-01/ + + + data absa( 1:180, 1) / & + & .9478488E-09,.2006042E-07,.2228363E-07,.2263495E-07,.2547446E-07,& + & .2936576E-07,.3475032E-07,.4537659E-07,.1269078E-07,.9492310E-09,& + & .2077413E-07,.2280572E-07,.2371246E-07,.2688328E-07,.3058537E-07,& + & .3544994E-07,.4495120E-07,.1274292E-07,.1009719E-08,.2560505E-07,& + & .2989703E-07,.3567437E-07,.4195170E-07,.4903334E-07,.5753744E-07,& + & .7103506E-07,.2087177E-07,.1021243E-08,.2157727E-07,.2428543E-07,& + & .2545064E-07,.2876447E-07,.3263409E-07,.3724139E-07,.4541822E-07,& + & .1284090E-07,.1028299E-08,.2206984E-07,.2462863E-07,.2608214E-07,& + & .2944973E-07,.3351924E-07,.3801002E-07,.4608904E-07,.1282141E-07,& + & .1105064E-08,.2024352E-07,.2144429E-07,.2292737E-07,.2205869E-07,& + & .2461858E-07,.2882375E-07,.3780175E-07,.1335949E-07,.1115462E-08,& + & .2242119E-07,.2253968E-07,.2374626E-07,.2336119E-07,.2589110E-07,& + & .2968126E-07,.3712386E-07,.1367759E-07,.1127330E-08,.2593823E-07,& + & .3036245E-07,.3217154E-07,.3601214E-07,.4106337E-07,.4749265E-07,& + & .5871813E-07,.2194477E-07,.1151546E-08,.2687708E-07,.3062911E-07,& + & .3274636E-07,.3661706E-07,.4151034E-07,.4800693E-07,.5860615E-07,& + & .2166646E-07,.1215036E-08,.2423972E-07,.2411833E-07,.2469573E-07,& + & .2645282E-07,.2869316E-07,.3165709E-07,.3778384E-07,.1423468E-07,& + & .1327285E-08,.1823139E-07,.2252831E-07,.2249874E-07,.2224138E-07,& + & .2137212E-07,.2379889E-07,.3066259E-07,.3075095E-07,.1374278E-08,& + & .2003317E-07,.2357640E-07,.2309863E-07,.2282640E-07,.2242184E-07,& + & .2479411E-07,.3108145E-07,.3095887E-07,.1409564E-08,.2175633E-07,& + & .2468093E-07,.2423024E-07,.2334201E-07,.2354485E-07,.2574451E-07,& + & .3082158E-07,.3128347E-07,.1450696E-08,.2746727E-07,.3099897E-07,& + & .3259416E-07,.3329255E-07,.3570574E-07,.3986596E-07,.4846921E-07,& + & .4021097E-07,.1442717E-08,.2412402E-07,.2625917E-07,.2602265E-07,& + & .2512855E-07,.2541577E-07,.2680625E-07,.3103534E-07,.3137157E-07,& + & .1649543E-08,.1970815E-07,.2150649E-07,.2298869E-07,.2180025E-07,& + & .2008423E-07,.1973561E-07,.2448138E-07,.8556873E-07,.1735034E-08,& + & .2060802E-07,.2356664E-07,.2443517E-07,.2299440E-07,.2108029E-07,& + & .2105873E-07,.2549524E-07,.8685059E-07,.1736792E-08,.2188572E-07,& + & .2575240E-07,.2521604E-07,.2423738E-07,.2219800E-07,.2218711E-07,& + & .2606412E-07,.8913315E-07,.1802505E-08,.2311836E-07,.2795390E-07,& + & .2628918E-07,.2520889E-07,.2295160E-07,.2272776E-07,.2590098E-07,& + & .9188038E-07,.1819519E-08,.2703557E-07,.3363986E-07,.3350051E-07,& + & .3297237E-07,.3293271E-07,.3417284E-07,.4007015E-07,.1097390E-06/ + + data absa(181:315, 1) / & + & .2076399E-08,.2299543E-07,.2011683E-07,.2214187E-07,.2287048E-07,& + & .2069490E-07,.1709628E-07,.1987151E-07,.2613410E-06,.2054496E-08,& + & .2464912E-07,.2181049E-07,.2435469E-07,.2449140E-07,.2201224E-07,& + & .1834284E-07,.2047387E-07,.2681452E-06,.2212265E-08,.2619392E-07,& + & .2373276E-07,.2675398E-07,.2535082E-07,.2318480E-07,.1957713E-07,& + & .2126646E-07,.2766404E-06,.2373248E-08,.2771181E-07,.2568041E-07,& + & .2923537E-07,.2639253E-07,.2388604E-07,.2054018E-07,.2213864E-07,& + & .2841552E-06,.2343337E-08,.3064130E-07,.3236485E-07,.3551409E-07,& + & .3395783E-07,.3172537E-07,.3073988E-07,.3350972E-07,.3192722E-06,& + & .2376949E-08,.2980194E-07,.2387416E-07,.2049156E-07,.2087214E-07,& + & .2167267E-07,.1825923E-07,.1653693E-07,.6372515E-06,.2667041E-08,& + & .3135808E-07,.2549292E-07,.2250603E-07,.2333514E-07,.2247609E-07,& + & .1950044E-07,.1700265E-07,.6563665E-06,.2966669E-08,.3250866E-07,& + & .2727873E-07,.2457664E-07,.2584670E-07,.2376895E-07,.2074333E-07,& + & .1753015E-07,.6745009E-06,.3145538E-08,.3465169E-07,.2866168E-07,& + & .2652981E-07,.2797349E-07,.2493029E-07,.2162154E-07,.1839404E-07,& + & .6921558E-06,.3048309E-08,.3670297E-07,.3037871E-07,.2846443E-07,& + & .3043302E-07,.2606580E-07,.2240677E-07,.1923357E-07,.7083018E-06,& + & .2954559E-08,.3887753E-07,.2869351E-07,.2420710E-07,.2014166E-07,& + & .1897808E-07,.1853848E-07,.1389583E-07,.1017915E-05,.3249121E-08,& + & .4105480E-07,.3073517E-07,.2582420E-07,.2186903E-07,.2106748E-07,& + & .1950220E-07,.1466410E-07,.1065309E-05,.3560837E-08,.4307434E-07,& + & .3307124E-07,.2749773E-07,.2349186E-07,.2343715E-07,.2046075E-07,& + & .1541227E-07,.1097022E-05,.3768057E-08,.4535221E-07,.3522003E-07,& + & .2913787E-07,.2516808E-07,.2572932E-07,.2163504E-07,.1608168E-07,& + & .1134264E-05,.4127508E-08,.4772213E-07,.3727530E-07,.3084310E-07,& + & .2724223E-07,.2780339E-07,.2276541E-07,.1676406E-07,.1166442E-05/ + + data absa(316:450, 1) / & + & .3755131E-08,.5425837E-07,.4118146E-07,.2970906E-07,.2360125E-07,& + & .1910884E-07,.1685495E-07,.1393367E-07,.1706962E-05,.3837129E-08,& + & .5684497E-07,.4375453E-07,.3243058E-07,.2577570E-07,.2032717E-07,& + & .1872850E-07,.1474043E-07,.1765060E-05,.4347070E-08,.5965052E-07,& + & .4627956E-07,.3497038E-07,.2747824E-07,.2198991E-07,.2061735E-07,& + & .1576341E-07,.1825492E-05,.4988663E-08,.6165437E-07,.4887741E-07,& + & .3754106E-07,.2965672E-07,.2382663E-07,.2246982E-07,.1698318E-07,& + & .1871583E-05,.5424215E-08,.6390254E-07,.5129696E-07,.3972602E-07,& + & .3163844E-07,.2555544E-07,.2420387E-07,.1814940E-07,.1924155E-05,& + & .4442173E-08,.7197256E-07,.5819392E-07,.4306671E-07,.2953792E-07,& + & .2178359E-07,.1602856E-07,.1525612E-07,.4752921E-05,.5074649E-08,& + & .7446008E-07,.6175165E-07,.4628955E-07,.3209104E-07,.2411698E-07,& + & .1784882E-07,.1645798E-07,.4869510E-05,.5728645E-08,.7723379E-07,& + & .6474879E-07,.4922829E-07,.3503195E-07,.2630379E-07,.1935594E-07,& + & .1753886E-07,.4973365E-05,.6351806E-08,.8000072E-07,.6740072E-07,& + & .5210377E-07,.3796839E-07,.2830818E-07,.2112504E-07,.1881638E-07,& + & .5058268E-05,.6912437E-08,.8315033E-07,.7068889E-07,.5412660E-07,& + & .4056832E-07,.3019131E-07,.2281027E-07,.1946796E-07,.5120717E-05,& + & .6424864E-08,.9702677E-07,.8541300E-07,.6566892E-07,.4587460E-07,& + & .2900504E-07,.1935626E-07,.1385212E-07,.8949001E-05,.7095455E-08,& + & .1023503E-06,.8901069E-07,.7031849E-07,.5021834E-07,.3251464E-07,& + & .2150478E-07,.1541222E-07,.9105756E-05,.7837477E-08,.1065872E-06,& + & .9339944E-07,.7381282E-07,.5418142E-07,.3553682E-07,.2351485E-07,& + & .1667046E-07,.9321311E-05,.8700945E-08,.1108036E-06,.9742466E-07,& + & .7752400E-07,.5759385E-07,.3839799E-07,.2580432E-07,.1788370E-07,& + & .9568035E-05,.9372952E-08,.1149751E-06,.1012313E-06,.8204487E-07,& + & .6076544E-07,.4108120E-07,.2793641E-07,.1911302E-07,.9731271E-05/ + + data absa(451:585, 1) / & + & .8979819E-08,.1058443E-06,.1200210E-06,.9695637E-07,.7036848E-07,& + & .4678128E-07,.2686372E-07,.1541405E-07,.1220035E-04,.9805661E-08,& + & .1118530E-06,.1255675E-06,.1030716E-06,.7739733E-07,.5201243E-07,& + & .2992503E-07,.1670143E-07,.1258780E-04,.1069760E-07,.1173469E-06,& + & .1304830E-06,.1095539E-06,.8282101E-07,.5625194E-07,.3263649E-07,& + & .1827566E-07,.1292889E-04,.1119525E-07,.1227001E-06,.1373018E-06,& + & .1148947E-06,.8789054E-07,.5978610E-07,.3529093E-07,.1964769E-07,& + & .1327840E-04,.1201126E-07,.1273789E-06,.1421903E-06,.1200244E-06,& + & .9264785E-07,.6378835E-07,.3808366E-07,.2094784E-07,.1367923E-04,& + & .9719070E-08,.9999501E-07,.1384487E-06,.1213259E-06,.9225490E-07,& + & .6132161E-07,.3331774E-07,.1686558E-07,.1343339E-04,.1109778E-07,& + & .1062708E-06,.1461547E-06,.1279839E-06,.9860632E-07,.6579031E-07,& + & .3628776E-07,.1826740E-07,.1383474E-04,.1211127E-07,.1133042E-06,& + & .1521046E-06,.1333579E-06,.1044442E-06,.7051604E-07,.3966511E-07,& + & .1978957E-07,.1430481E-04,.1342211E-07,.1191516E-06,.1571868E-06,& + & .1380165E-06,.1093802E-06,.7496750E-07,.4327741E-07,.2126680E-07,& + & .1475217E-04,.1467534E-07,.1241612E-06,.1623203E-06,.1431277E-06,& + & .1135740E-06,.7963856E-07,.4685852E-07,.2271310E-07,.1522177E-04,& + & .1161087E-07,.1041677E-06,.1364162E-06,.1423574E-06,.1160046E-06,& + & .7917598E-07,.4352117E-07,.1902079E-07,.1388023E-04,.1297072E-07,& + & .1100490E-06,.1431349E-06,.1479064E-06,.1210891E-06,.8468921E-07,& + & .4817011E-07,.2075879E-07,.1442933E-04,.1434007E-07,.1155767E-06,& + & .1497075E-06,.1533287E-06,.1261775E-06,.8986500E-07,.5204569E-07,& + & .2239805E-07,.1502654E-04,.1566851E-07,.1199822E-06,.1550418E-06,& + & .1587526E-06,.1308995E-06,.9466747E-07,.5568553E-07,.2384695E-07,& + & .1555344E-04,.1683829E-07,.1243538E-06,.1604785E-06,.1641767E-06,& + & .1360688E-06,.9947999E-07,.5921603E-07,.2546256E-07,.1596362E-04/ + + data absa( 1:180, 2) / & + & .4977875E-08,.2921108E-06,.5418060E-06,.7727212E-06,.9911457E-06,& + & .1214800E-05,.1465814E-05,.1829868E-05,.7823624E-06,.4994907E-08,& + & .3018351E-06,.5578764E-06,.7940989E-06,.1016090E-05,.1239397E-05,& + & .1487931E-05,.1836976E-05,.7862442E-06,.5208110E-08,.3874388E-06,& + & .7181819E-06,.1020477E-05,.1309594E-05,.1599138E-05,.1909038E-05,& + & .2327755E-05,.1153932E-05,.5319118E-08,.3178392E-06,.5822238E-06,& + & .8242852E-06,.1050880E-05,.1277685E-05,.1520218E-05,.1852230E-05,& + & .7871951E-06,.5556151E-08,.3235154E-06,.5911725E-06,.8338245E-06,& + & .1062185E-05,.1291143E-05,.1532737E-05,.1857528E-05,.7845580E-06,& + & .5432943E-08,.2394007E-06,.4471522E-06,.6385952E-06,.8269131E-06,& + & .1017096E-05,.1232743E-05,.1559228E-05,.6244771E-06,.5892629E-08,& + & .2459631E-06,.4597979E-06,.6563874E-06,.8463292E-06,.1038052E-05,& + & .1251153E-05,.1563781E-05,.6288295E-06,.5915709E-08,.3242534E-06,& + & .6031237E-06,.8632595E-06,.1113129E-05,.1365831E-05,.1640492E-05,& + & .2027362E-05,.9462585E-06,.6171888E-08,.3261724E-06,.6054889E-06,& + & .8640996E-06,.1112880E-05,.1361041E-05,.1630551E-05,.2003512E-05,& + & .9272718E-06,.6400658E-08,.2632985E-06,.4872328E-06,.6900240E-06,& + & .8829870E-06,.1077466E-05,.1285821E-05,.1578521E-05,.6307027E-06,& + & .6718273E-08,.1967264E-06,.3613932E-06,.5196750E-06,.6756207E-06,& + & .8399391E-06,.1024899E-05,.1319338E-05,.4959268E-06,.7019662E-08,& + & .2019256E-06,.3715815E-06,.5349054E-06,.6929146E-06,.8570698E-06,& + & .1040099E-05,.1317826E-05,.5026796E-06,.6849002E-08,.2066083E-06,& + & .3800896E-06,.5461625E-06,.7072097E-06,.8714979E-06,.1051566E-05,& + & .1319363E-05,.5066881E-06,.7348552E-08,.2698050E-06,.5015846E-06,& + & .7193981E-06,.9328462E-06,.1147717E-05,.1384165E-05,.1724206E-05,& + & .7547895E-06,.7364360E-08,.2140724E-06,.3941245E-06,.5620667E-06,& + & .7253341E-06,.8905787E-06,.1068093E-05,.1327568E-05,.5107295E-06,& + & .7188660E-08,.1608987E-06,.2919364E-06,.4183428E-06,.5474637E-06,& + & .6862098E-06,.8454628E-06,.1112417E-05,.7753418E-06,.7923510E-08,& + & .1660346E-06,.2994130E-06,.4302319E-06,.5615672E-06,.7001230E-06,& + & .8570141E-06,.1102211E-05,.7947637E-06,.8710415E-08,.1699772E-06,& + & .3051256E-06,.4401873E-06,.5730835E-06,.7124193E-06,.8673643E-06,& + & .1099678E-05,.8076872E-06,.9379724E-08,.1733439E-06,.3101037E-06,& + & .4482693E-06,.5824117E-06,.7220472E-06,.8751372E-06,.1103747E-05,& + & .8157169E-06,.9693296E-08,.2255703E-06,.4099284E-06,.5915659E-06,& + & .7704284E-06,.9518875E-06,.1153151E-05,.1447965E-05,.9509966E-06/ + + data absa(181:315, 2) / & + & .8742219E-08,.1401619E-06,.2365810E-06,.3367232E-06,.4389881E-06,& + & .5544262E-06,.6941176E-06,.9221962E-06,.1547996E-05,.9825526E-08,& + & .1439063E-06,.2438132E-06,.3455625E-06,.4507360E-06,.5666773E-06,& + & .7024141E-06,.9173596E-06,.1577601E-05,.1032729E-07,.1470757E-06,& + & .2492266E-06,.3522677E-06,.4609870E-06,.5767649E-06,.7112768E-06,& + & .9130431E-06,.1601942E-05,.1052928E-07,.1495088E-06,.2530720E-06,& + & .3574969E-06,.4695458E-06,.5854586E-06,.7174989E-06,.9137192E-06,& + & .1618037E-05,.1150457E-07,.1903978E-06,.3372032E-06,.4819982E-06,& + & .6322987E-06,.7870872E-06,.9614418E-06,.1220624E-05,.1804705E-05,& + & .1081727E-07,.1563034E-06,.1929738E-06,.2720043E-06,.3525847E-06,& + & .4442876E-06,.5631051E-06,.7626249E-06,.2334044E-05,.1150244E-07,& + & .1599274E-06,.1989339E-06,.2804224E-06,.3618620E-06,.4559776E-06,& + & .5702232E-06,.7643768E-06,.2382319E-05,.1175189E-07,.1620605E-06,& + & .2044243E-06,.2860895E-06,.3693875E-06,.4646579E-06,.5769806E-06,& + & .7565793E-06,.2416745E-05,.1306718E-07,.1630619E-06,.2085618E-06,& + & .2905226E-06,.3757709E-06,.4717225E-06,.5824128E-06,.7540595E-06,& + & .2439861E-05,.1426020E-07,.1645534E-06,.2117139E-06,.2947798E-06,& + & .3794331E-06,.4775901E-06,.5875284E-06,.7558601E-06,.2466640E-05,& + & .1207434E-07,.1674269E-06,.1791693E-06,.2187708E-06,.2826358E-06,& + & .3574471E-06,.4560189E-06,.6292048E-06,.4950228E-05,.1327450E-07,& + & .1717629E-06,.1844629E-06,.2269350E-06,.2920013E-06,.3674358E-06,& + & .4607900E-06,.6289581E-06,.4970699E-05,.1458123E-07,.1756793E-06,& + & .1880198E-06,.2332289E-06,.2991457E-06,.3736616E-06,.4662710E-06,& + & .6243034E-06,.5001187E-05,.1616738E-07,.1790958E-06,.1914327E-06,& + & .2381938E-06,.3052274E-06,.3787455E-06,.4719405E-06,.6206030E-06,& + & .5028994E-05,.1738758E-07,.1816052E-06,.1943182E-06,.2415142E-06,& + & .3091524E-06,.3827622E-06,.4755721E-06,.6213090E-06,.5041895E-05/ + + data absa(316:450, 2) / & + & .1665196E-07,.1938979E-06,.2113958E-06,.2003810E-06,.2278096E-06,& + & .2865973E-06,.3718779E-06,.5164350E-06,.1076729E-04,.1817122E-07,& + & .1993569E-06,.2175471E-06,.2075727E-06,.2358089E-06,.2950307E-06,& + & .3720816E-06,.5129796E-06,.1080841E-04,.1956687E-07,.2035852E-06,& + & .2222226E-06,.2131321E-06,.2435564E-06,.3019781E-06,.3754017E-06,& + & .5134335E-06,.1082806E-04,.2070597E-07,.2074456E-06,.2260920E-06,& + & .2168666E-06,.2488899E-06,.3073148E-06,.3798904E-06,.5077018E-06,& + & .1084943E-04,.2173248E-07,.2098779E-06,.2294201E-06,.2205251E-06,& + & .2538736E-06,.3118254E-06,.3821669E-06,.5055703E-06,.1085222E-04,& + & .2191248E-07,.2365055E-06,.2390465E-06,.2374263E-06,.2072159E-06,& + & .2312165E-06,.3013057E-06,.4184984E-06,.2723092E-04,.2361382E-07,& + & .2462069E-06,.2472867E-06,.2475309E-06,.2196618E-06,.2383569E-06,& + & .3008372E-06,.4161238E-06,.2736074E-04,.2508833E-07,.2530970E-06,& + & .2541614E-06,.2555112E-06,.2280678E-06,.2448032E-06,.3033101E-06,& + & .4166889E-06,.2760212E-04,.2600366E-07,.2555124E-06,.2601272E-06,& + & .2621345E-06,.2330125E-06,.2502924E-06,.3081806E-06,.4117555E-06,& + & .2781471E-04,.2625556E-07,.2585939E-06,.2658891E-06,.2667422E-06,& + & .2373911E-06,.2553542E-06,.3106119E-06,.4101077E-06,.2799279E-04,& + & .2786381E-07,.2663930E-06,.3136530E-06,.2903642E-06,.2699185E-06,& + & .2154845E-06,.2415255E-06,.3414221E-06,.6623836E-04,.3081478E-07,& + & .2743516E-06,.3245697E-06,.3003308E-06,.2804576E-06,.2242044E-06,& + & .2415067E-06,.3388596E-06,.6704072E-04,.3288814E-07,.2818415E-06,& + & .3322102E-06,.3116516E-06,.2890397E-06,.2345975E-06,.2455989E-06,& + & .3380705E-06,.6784378E-04,.3384756E-07,.2878021E-06,.3383139E-06,& + & .3187847E-06,.2960257E-06,.2435067E-06,.2492429E-06,.3358934E-06,& + & .6873920E-04,.3644271E-07,.2922944E-06,.3431136E-06,.3228649E-06,& + & .3009446E-06,.2515472E-06,.2527789E-06,.3321823E-06,.6964582E-04/ + + data absa(451:585, 2) / & + & .4098843E-07,.3384011E-06,.3624859E-06,.3751623E-06,.3279197E-06,& + & .2825050E-06,.2084273E-06,.2761760E-06,.8850341E-04,.4683147E-07,& + & .3426868E-06,.3709702E-06,.3853158E-06,.3371326E-06,.2929673E-06,& + & .2151462E-06,.2724341E-06,.8924994E-04,.4984644E-07,.3465890E-06,& + & .3781183E-06,.3930485E-06,.3467252E-06,.3026766E-06,.2220474E-06,& + & .2731323E-06,.9000607E-04,.5357426E-07,.3496935E-06,.3823149E-06,& + & .4006097E-06,.3557600E-06,.3109094E-06,.2298146E-06,.2691423E-06,& + & .9077335E-04,.5649178E-07,.3523119E-06,.3864299E-06,.4065303E-06,& + & .3608387E-06,.3158353E-06,.2374848E-06,.2683036E-06,.9190915E-04,& + & .5606804E-07,.3942048E-06,.3696286E-06,.3914481E-06,.3666506E-06,& + & .3045442E-06,.2355668E-06,.2246247E-06,.9830605E-04,.5792873E-07,& + & .3951960E-06,.3767630E-06,.4000468E-06,.3765494E-06,.3169486E-06,& + & .2468239E-06,.2208278E-06,.1003406E-03,.6144867E-07,.3964744E-06,& + & .3840637E-06,.4079564E-06,.3868875E-06,.3269661E-06,.2582322E-06,& + & .2208739E-06,.1013645E-03,.6347446E-07,.3944624E-06,.3901494E-06,& + & .4142722E-06,.3972735E-06,.3364436E-06,.2683503E-06,.2181227E-06,& + & .1025965E-03,.6571022E-07,.3935800E-06,.3934698E-06,.4190604E-06,& + & .4047063E-06,.3426999E-06,.2756876E-06,.2187860E-06,.1036640E-03,& + & .6947980E-07,.4277234E-06,.4260311E-06,.3985021E-06,.3938855E-06,& + & .3382988E-06,.2596779E-06,.1845908E-06,.1007433E-03,.7232340E-07,& + & .4309643E-06,.4284737E-06,.4112915E-06,.4041636E-06,.3526595E-06,& + & .2709767E-06,.1835141E-06,.1027545E-03,.7385675E-07,.4323241E-06,& + & .4337810E-06,.4231404E-06,.4150882E-06,.3638010E-06,.2833177E-06,& + & .1825627E-06,.1048033E-03,.7472322E-07,.4340229E-06,.4375142E-06,& + & .4293950E-06,.4227926E-06,.3709701E-06,.2917057E-06,.1845645E-06,& + & .1071308E-03,.7710708E-07,.4377958E-06,.4436351E-06,.4362045E-06,& + & .4261614E-06,.3773780E-06,.2982907E-06,.1879122E-06,.1086672E-03/ + + data absa( 1:180, 3) / & + & .7885147E-08,.2480177E-05,.4465798E-05,.6288079E-05,.8021775E-05,& + & .9713012E-05,.1149293E-04,.1389792E-04,.9583620E-05,.8337260E-08,& + & .2533549E-05,.4538671E-05,.6376335E-05,.8116846E-05,.9823186E-05,& + & .1160281E-04,.1396043E-04,.9711327E-05,.8347835E-08,.2875505E-05,& + & .5166441E-05,.7269794E-05,.9276602E-05,.1119934E-04,.1322573E-04,& + & .1573805E-04,.1164942E-04,.8341010E-08,.2624899E-05,.4665526E-05,& + & .6527056E-05,.8285471E-05,.9970463E-05,.1177728E-04,.1416190E-04,& + & .9853793E-05,.8441087E-08,.2662384E-05,.4716519E-05,.6584497E-05,& + & .8347227E-05,.1002746E-04,.1181802E-04,.1420893E-04,.9876490E-05,& + & .9538043E-08,.2172518E-05,.3916041E-05,.5520408E-05,.7047709E-05,& + & .8561064E-05,.1016253E-04,.1235053E-04,.8228063E-05,.9896959E-08,& + & .2218811E-05,.3982498E-05,.5600469E-05,.7138336E-05,.8647352E-05,& + & .1025838E-04,.1240949E-04,.8337951E-05,.9725183E-08,.2562004E-05,& + & .4611611E-05,.6497303E-05,.8305798E-05,.1005129E-04,.1190483E-04,& + & .1422914E-04,.1028529E-04,.9815185E-08,.2580610E-05,.4626595E-05,& + & .6503599E-05,.8291966E-05,.1002549E-04,.1185886E-04,.1419713E-04,& + & .1021346E-04,.9353012E-08,.2330951E-05,.4132274E-05,.5770881E-05,& + & .7327013E-05,.8826693E-05,.1043691E-04,.1262749E-04,.8444115E-05,& + & .1055499E-07,.1876951E-05,.3395021E-05,.4794118E-05,.6129975E-05,& + & .7457686E-05,.8897848E-05,.1089769E-04,.6935281E-05,.1082740E-07,& + & .1919857E-05,.3454800E-05,.4863748E-05,.6212902E-05,.7539732E-05,& + & .8988633E-05,.1093165E-04,.7014326E-05,.1237586E-07,.1957445E-05,& + & .3508502E-05,.4924591E-05,.6283591E-05,.7606837E-05,.9064706E-05,& + & .1103621E-04,.7066774E-05,.1310556E-07,.2280479E-05,.4102438E-05,& + & .5774148E-05,.7371455E-05,.8939771E-05,.1061982E-04,.1277638E-04,& + & .8882241E-05,.1381953E-07,.2018379E-05,.3585970E-05,.5012832E-05,& + & .6367746E-05,.7692141E-05,.9142910E-05,.1113079E-04,.7092611E-05,& + & .1302165E-07,.1600407E-05,.2913854E-05,.4120799E-05,.5279357E-05,& + & .6430192E-05,.7712566E-05,.9529299E-05,.5293062E-05,.1389129E-07,& + & .1639258E-05,.2967097E-05,.4184307E-05,.5353035E-05,.6512557E-05,& + & .7798666E-05,.9560399E-05,.5349139E-05,.1483348E-07,.1673536E-05,& + & .3015174E-05,.4237461E-05,.5413790E-05,.6575943E-05,.7862585E-05,& + & .9658800E-05,.5382522E-05,.1563210E-07,.1703299E-05,.3054374E-05,& + & .4280442E-05,.5458053E-05,.6620462E-05,.7906329E-05,.9704216E-05,& + & .5391051E-05,.1599402E-07,.2006384E-05,.3612837E-05,.5084142E-05,& + & .6481925E-05,.7864478E-05,.9387955E-05,.1136686E-04,.7116652E-05/ + + data absa(181:315, 3) / & + & .1759652E-07,.1338435E-05,.2477474E-05,.3510671E-05,.4506288E-05,& + & .5498399E-05,.6620804E-05,.8293824E-05,.3301450E-05,.1839690E-07,& + & .1372726E-05,.2524704E-05,.3567406E-05,.4571892E-05,.5574072E-05,& + & .6701396E-05,.8294132E-05,.3333569E-05,.1844120E-07,.1403022E-05,& + & .2565887E-05,.3614241E-05,.4624775E-05,.5628533E-05,.6758496E-05,& + & .8374936E-05,.3343845E-05,.2053628E-07,.1429066E-05,.2600703E-05,& + & .3651806E-05,.4660425E-05,.5666649E-05,.6798791E-05,.8414165E-05,& + & .3333421E-05,.2112872E-07,.1738328E-05,.3156880E-05,.4451390E-05,& + & .5679788E-05,.6911108E-05,.8277220E-05,.1010231E-04,.4801846E-05,& + & .2138930E-07,.1060078E-05,.2077209E-05,.2959831E-05,.3807513E-05,& + & .4658382E-05,.5629044E-05,.7177701E-05,.5287833E-05,.2197261E-07,& + & .1090324E-05,.2118891E-05,.3009588E-05,.3867726E-05,.4725436E-05,& + & .5702333E-05,.7135044E-05,.5295206E-05,.2370908E-07,.1117799E-05,& + & .2154519E-05,.3051661E-05,.3914248E-05,.4773139E-05,.5753687E-05,& + & .7202983E-05,.5282002E-05,.2418585E-07,.1140836E-05,.2184495E-05,& + & .3085157E-05,.3945767E-05,.4806508E-05,.5792297E-05,.7235984E-05,& + & .5240017E-05,.2563587E-07,.1157256E-05,.2206672E-05,.3110571E-05,& + & .3966388E-05,.4824447E-05,.5812975E-05,.7247817E-05,.5173282E-05,& + & .2761854E-07,.8192162E-06,.1695308E-05,.2467470E-05,.3187895E-05,& + & .3913885E-05,.4745695E-05,.6132573E-05,.8445327E-05,.2791826E-07,& + & .8431674E-06,.1731404E-05,.2511477E-05,.3242547E-05,.3969814E-05,& + & .4810419E-05,.6100692E-05,.8456733E-05,.2941384E-07,.8642535E-06,& + & .1763447E-05,.2547427E-05,.3283616E-05,.4013509E-05,.4856118E-05,& + & .6137849E-05,.8444823E-05,.3093995E-07,.8803612E-06,.1788691E-05,& + & .2576812E-05,.3311827E-05,.4043744E-05,.4889006E-05,.6164513E-05,& + & .8438944E-05,.3175649E-07,.8926786E-06,.1807355E-05,.2599811E-05,& + & .3329744E-05,.4060525E-05,.4908054E-05,.6172563E-05,.8415014E-05/ + + data absa(316:450, 3) / & + & .3594320E-07,.5898798E-06,.1300990E-05,.2005624E-05,.2639841E-05,& + & .3258662E-05,.3970239E-05,.5168834E-05,.1389043E-04,.3842574E-07,& + & .6079368E-06,.1330795E-05,.2043110E-05,.2689852E-05,.3308616E-05,& + & .4024395E-05,.5188513E-05,.1404319E-04,.4003510E-07,.6246941E-06,& + & .1356682E-05,.2074572E-05,.2724323E-05,.3347997E-05,.4066594E-05,& + & .5184194E-05,.1421675E-04,.4109691E-07,.6372206E-06,.1377478E-05,& + & .2099971E-05,.2748886E-05,.3373994E-05,.4094365E-05,.5206120E-05,& + & .1431172E-04,.4160609E-07,.6467677E-06,.1391926E-05,.2119005E-05,& + & .2763924E-05,.3389851E-05,.4111985E-05,.5213753E-05,.1436877E-04,& + & .4460131E-07,.3996422E-06,.9634371E-06,.1535190E-05,.2135126E-05,& + & .2688150E-05,.3299750E-05,.4333189E-05,.2704843E-04,.4831887E-07,& + & .4098677E-06,.9845303E-06,.1564750E-05,.2173466E-05,.2731313E-05,& + & .3343042E-05,.4388007E-05,.2787395E-04,.5033440E-07,.4173500E-06,& + & .1002962E-05,.1587816E-05,.2202008E-05,.2765444E-05,.3380831E-05,& + & .4346875E-05,.2836708E-04,.5144378E-07,.4256035E-06,.1017999E-05,& + & .1606384E-05,.2223268E-05,.2789015E-05,.3404990E-05,.4364321E-05,& + & .2885698E-04,.5376703E-07,.4301287E-06,.1025925E-05,.1621665E-05,& + & .2236412E-05,.2802339E-05,.3420850E-05,.4370319E-05,.2935788E-04,& + & .7159604E-07,.4940214E-06,.6385949E-06,.1108740E-05,.1601203E-05,& + & .2163439E-05,.2727326E-05,.3598975E-05,.4606013E-04,.7586834E-07,& + & .4934774E-06,.6516736E-06,.1132261E-05,.1634648E-05,.2197928E-05,& + & .2762190E-05,.3675388E-05,.4725942E-04,.7940266E-07,.4992704E-06,& + & .6618015E-06,.1146976E-05,.1656272E-05,.2222531E-05,.2791013E-05,& + & .3629707E-05,.4765531E-04,.8216318E-07,.4976479E-06,.6706045E-06,& + & .1160539E-05,.1671805E-05,.2236388E-05,.2810390E-05,.3635786E-05,& + & .4814584E-04,.8519042E-07,.4933370E-06,.6756937E-06,.1170724E-05,& + & .1681781E-05,.2243295E-05,.2821977E-05,.3642627E-05,.4872656E-04/ + + data absa(451:585, 3) / & + & .1081928E-06,.5818788E-06,.6386596E-06,.7432114E-06,.1166448E-05,& + & .1632769E-05,.2234855E-05,.3011606E-05,.5082881E-04,.1059761E-06,& + & .5865974E-06,.6439649E-06,.7553534E-06,.1187103E-05,.1654747E-05,& + & .2252083E-05,.3058057E-05,.5151287E-04,.1087338E-06,.5874771E-06,& + & .6413861E-06,.7655310E-06,.1198176E-05,.1670032E-05,.2266997E-05,& + & .3012908E-05,.5289813E-04,.1114046E-06,.5874841E-06,.6406983E-06,& + & .7727642E-06,.1203345E-05,.1677472E-05,.2275155E-05,.3017584E-05,& + & .5372932E-04,.1149838E-06,.5849412E-06,.6431792E-06,.7741413E-06,& + & .1208047E-05,.1681178E-05,.2276094E-05,.3015110E-05,.5370886E-04,& + & .1308163E-06,.5923091E-06,.7055074E-06,.6422362E-06,.8303543E-06,& + & .1235001E-05,.1751640E-05,.2496860E-05,.5055594E-04,.1362223E-06,& + & .6024702E-06,.7146505E-06,.6458685E-06,.8419302E-06,.1248937E-05,& + & .1758098E-05,.2520128E-05,.4923848E-04,.1383439E-06,.6090485E-06,& + & .7121358E-06,.6578181E-06,.8468564E-06,.1256934E-05,.1760117E-05,& + & .2491841E-05,.5060877E-04,.1418196E-06,.6173069E-06,.7165570E-06,& + & .6647670E-06,.8470868E-06,.1257404E-05,.1760260E-05,.2490114E-05,& + & .5072850E-04,.1467094E-06,.6274341E-06,.7144183E-06,.6594283E-06,& + & .8460663E-06,.1255755E-05,.1758322E-05,.2483648E-05,.5190473E-04,& + & .1679150E-06,.6319279E-06,.7600366E-06,.7654140E-06,.6345031E-06,& + & .8895555E-06,.1341549E-05,.2061106E-05,.5170435E-04,.1687483E-06,& + & .6398709E-06,.7658349E-06,.7599068E-06,.6394553E-06,.8948407E-06,& + & .1341176E-05,.2062854E-05,.5191565E-04,.1856866E-06,.6469542E-06,& + & .7612484E-06,.7510875E-06,.6399811E-06,.8962538E-06,.1338671E-05,& + & .2043994E-05,.5247877E-04,.1946851E-06,.6555257E-06,.7574664E-06,& + & .7531901E-06,.6416353E-06,.8973155E-06,.1338204E-05,.2036318E-05,& + & .5249060E-04,.1959063E-06,.6536393E-06,.7490042E-06,.7486915E-06,& + & .6419812E-06,.8937247E-06,.1335333E-05,.2025525E-05,.5294532E-04/ + + data absa( 1:180, 4) / & + & .1305351E-05,.1815013E-04,.2979305E-04,.3999652E-04,.4905169E-04,& + & .5693488E-04,.6409806E-04,.7177995E-04,.6208906E-04,.1399449E-05,& + & .1830100E-04,.3003956E-04,.4034832E-04,.4948205E-04,.5741995E-04,& + & .6471188E-04,.7264387E-04,.6277389E-04,.1500703E-05,.1907688E-04,& + & .3148533E-04,.4244547E-04,.5212651E-04,.6064266E-04,.6853163E-04,& + & .7718017E-04,.6793589E-04,.1602781E-05,.1859572E-04,.3046861E-04,& + & .4090220E-04,.5010077E-04,.5818133E-04,.6567877E-04,.7391640E-04,& + & .6394695E-04,.1701735E-05,.1874689E-04,.3064865E-04,.4112164E-04,& + & .5031423E-04,.5845409E-04,.6607977E-04,.7447772E-04,.6440095E-04,& + & .1064649E-05,.1659392E-04,.2728440E-04,.3661825E-04,.4488879E-04,& + & .5216469E-04,.5901946E-04,.6679678E-04,.5636200E-04,.1144486E-05,& + & .1674885E-04,.2754084E-04,.3698113E-04,.4529662E-04,.5265143E-04,& + & .5963365E-04,.6763659E-04,.5703090E-04,.1229283E-05,.1755590E-04,& + & .2904804E-04,.3914394E-04,.4801072E-04,.5596306E-04,.6357576E-04,& + & .7232186E-04,.6241105E-04,.1311915E-05,.1765175E-04,.2914597E-04,& + & .3924495E-04,.4810414E-04,.5607476E-04,.6377001E-04,.7264059E-04,& + & .6255768E-04,.1393667E-05,.1719840E-04,.2815613E-04,.3775091E-04,& + & .4611483E-04,.5365819E-04,.6097830E-04,.6951518E-04,.5857723E-04,& + & .8510123E-06,.1505886E-04,.2479646E-04,.3323319E-04,.4067061E-04,& + & .4732001E-04,.5376955E-04,.6151348E-04,.5054458E-04,.9176962E-06,& + & .1522049E-04,.2506909E-04,.3359909E-04,.4107044E-04,.4781093E-04,& + & .5439483E-04,.6241934E-04,.5123952E-04,.9852056E-06,.1537278E-04,& + & .2530125E-04,.3390810E-04,.4140644E-04,.4822544E-04,.5493151E-04,& + & .6311719E-04,.5182421E-04,.1051221E-05,.1616403E-04,.2674998E-04,& + & .3597079E-04,.4404185E-04,.5143084E-04,.5876151E-04,.6767562E-04,& + & .5703403E-04,.1116703E-05,.1566305E-04,.2568848E-04,.3436963E-04,& + & .4192613E-04,.4885053E-04,.5577076E-04,.6434502E-04,.5271676E-04,& + & .6706972E-06,.1356834E-04,.2234016E-04,.2988013E-04,.3652444E-04,& + & .4257018E-04,.4855089E-04,.5610533E-04,.4513334E-04,.7245362E-06,& + & .1373634E-04,.2262553E-04,.3024618E-04,.3692628E-04,.4305715E-04,& + & .4917507E-04,.5705200E-04,.4580726E-04,.7792176E-06,.1389124E-04,& + & .2286472E-04,.3055718E-04,.3727285E-04,.4346813E-04,.4973107E-04,& + & .5777942E-04,.4638437E-04,.8325154E-06,.1403502E-04,.2307317E-04,& + & .3081856E-04,.3756897E-04,.4382456E-04,.5020863E-04,.5845074E-04,& + & .4687437E-04,.8857411E-06,.1481254E-04,.2449491E-04,.3281306E-04,& + & .4013490E-04,.4697409E-04,.5391258E-04,.6287210E-04,.5200378E-04/ + + data absa(181:315, 4) / & + & .5167508E-06,.1213015E-04,.1994761E-04,.2666478E-04,.3257689E-04,& + & .3801490E-04,.4351481E-04,.5071048E-04,.3970568E-04,.5611450E-06,& + & .1230180E-04,.2023486E-04,.2701994E-04,.3297257E-04,.3850691E-04,& + & .4413473E-04,.5168590E-04,.4035843E-04,.6074942E-06,.1245708E-04,& + & .2048237E-04,.2733236E-04,.3332457E-04,.3893535E-04,.4469849E-04,& + & .5243452E-04,.4091681E-04,.6497091E-06,.1260117E-04,.2070243E-04,& + & .2759760E-04,.3363226E-04,.3930008E-04,.4517120E-04,.5311341E-04,& + & .4140540E-04,.6918234E-06,.1342830E-04,.2222680E-04,.2973432E-04,& + & .3639360E-04,.4267235E-04,.4915864E-04,.5781325E-04,.4703066E-04,& + & .3889111E-06,.1075212E-04,.1766146E-04,.2361401E-04,.2885114E-04,& + & .3370300E-04,.3869751E-04,.4540779E-04,.2843576E-04,.4255971E-06,& + & .1092624E-04,.1794903E-04,.2396544E-04,.2925012E-04,.3420204E-04,& + & .3932564E-04,.4642134E-04,.2904572E-04,.4617245E-06,.1108153E-04,& + & .1820339E-04,.2427801E-04,.2960841E-04,.3464423E-04,.3989616E-04,& + & .4717937E-04,.2958696E-04,.4963196E-06,.1122268E-04,.1843067E-04,& + & .2454397E-04,.2992123E-04,.3501424E-04,.4036504E-04,.4787143E-04,& + & .3007661E-04,.5288712E-06,.1136116E-04,.1862698E-04,.2476416E-04,& + & .3018301E-04,.3532236E-04,.4075287E-04,.4844677E-04,.3048386E-04,& + & .2818201E-06,.9454122E-05,.1552584E-04,.2075905E-04,.2537253E-04,& + & .2967483E-04,.3416421E-04,.4036992E-04,.1358631E-04,.3116980E-06,& + & .9630115E-05,.1581178E-04,.2110576E-04,.2577640E-04,.3017903E-04,& + & .3479450E-04,.4135899E-04,.1411977E-04,.3391436E-06,.9785821E-05,& + & .1606901E-04,.2141705E-04,.2613954E-04,.3061951E-04,.3535944E-04,& + & .4214515E-04,.1459742E-04,.3649969E-06,.9929644E-05,.1629735E-04,& + & .2168157E-04,.2645134E-04,.3099353E-04,.3582904E-04,.4283092E-04,& + & .1493885E-04,.3909595E-06,.1006778E-04,.1649654E-04,.2190347E-04,& + & .2671526E-04,.3130880E-04,.3622231E-04,.4340255E-04,.1525050E-04/ + + data absa(316:450, 4) / & + & .1885550E-06,.8237115E-05,.1355115E-04,.1812203E-04,.2216406E-04,& + & .2595910E-04,.2995607E-04,.3567120E-04,.1531929E-04,.2087836E-06,& + & .8413745E-05,.1383332E-04,.1846337E-04,.2256351E-04,.2645687E-04,& + & .3058162E-04,.3655441E-04,.1558368E-04,.2296238E-06,.8571555E-05,& + & .1408726E-04,.1876607E-04,.2292379E-04,.2689093E-04,.3112883E-04,& + & .3737211E-04,.1557312E-04,.2500010E-06,.8719796E-05,.1431412E-04,& + & .1902641E-04,.2323430E-04,.2726681E-04,.3159471E-04,.3804543E-04,& + & .1578427E-04,.2711853E-06,.8859111E-05,.1451202E-04,.1924827E-04,& + & .2349894E-04,.2758553E-04,.3199143E-04,.3860292E-04,.1588112E-04,& + & .1230406E-06,.7071075E-05,.1173600E-04,.1570803E-04,.1922851E-04,& + & .2255710E-04,.2608910E-04,.3126942E-04,.3216989E-04,.1333225E-06,& + & .7245254E-05,.1201186E-04,.1604140E-04,.1961962E-04,.2304330E-04,& + & .2669918E-04,.3205734E-04,.3251376E-04,.1467059E-06,.7408812E-05,& + & .1226050E-04,.1633677E-04,.1997347E-04,.2347166E-04,.2723239E-04,& + & .3289453E-04,.3282901E-04,.1619556E-06,.7561287E-05,.1248084E-04,& + & .1659177E-04,.2028185E-04,.2384470E-04,.2769227E-04,.3354727E-04,& + & .3315058E-04,.1762633E-06,.7701606E-05,.1267408E-04,.1681320E-04,& + & .2054736E-04,.2416501E-04,.2808628E-04,.3409678E-04,.3312584E-04,& + & .1086826E-06,.5647058E-05,.1006035E-04,.1354169E-04,.1659919E-04,& + & .1950529E-04,.2261606E-04,.2728891E-04,.4618372E-04,.1056253E-06,& + & .5824652E-05,.1032706E-04,.1386088E-04,.1697733E-04,.1997451E-04,& + & .2320443E-04,.2799400E-04,.4673866E-04,.1091752E-06,.5977988E-05,& + & .1056852E-04,.1414636E-04,.1732210E-04,.2039088E-04,.2372048E-04,& + & .2879946E-04,.4859587E-04,.1162781E-06,.6130784E-05,.1078173E-04,& + & .1439326E-04,.1762377E-04,.2075664E-04,.2416964E-04,.2942961E-04,& + & .4852916E-04,.1200840E-06,.6274589E-05,.1096931E-04,.1461013E-04,& + & .1788556E-04,.2107397E-04,.2455553E-04,.2995813E-04,.4904614E-04/ + + data absa(451:585, 4) / & + & .1675748E-06,.4418138E-05,.8301726E-05,.1168525E-04,.1439259E-04,& + & .1696072E-04,.1973556E-04,.2395464E-04,.4468651E-04,.1734702E-06,& + & .4573506E-05,.8548681E-05,.1197974E-04,.1474159E-04,.1738826E-04,& + & .2027162E-04,.2462762E-04,.4554179E-04,.1739972E-06,.4723577E-05,& + & .8779827E-05,.1223847E-04,.1505819E-04,.1776729E-04,.2074409E-04,& + & .2535087E-04,.4445044E-04,.1750928E-06,.4863503E-05,.8978592E-05,& + & .1246324E-04,.1533399E-04,.1810410E-04,.2114969E-04,.2591012E-04,& + & .4445933E-04,.1808266E-06,.4993518E-05,.9148942E-05,.1266696E-04,& + & .1557959E-04,.1839978E-04,.2150457E-04,.2639122E-04,.4563702E-04,& + & .2010952E-06,.3480775E-05,.6740064E-05,.9826566E-05,.1239046E-04,& + & .1466668E-04,.1712740E-04,.2092359E-04,.4828846E-04,.2004906E-06,& + & .3617594E-05,.6950190E-05,.1010039E-04,.1271291E-04,.1505595E-04,& + & .1761624E-04,.2155447E-04,.4984876E-04,.2193992E-06,.3747107E-05,& + & .7152981E-05,.1032882E-04,.1300048E-04,.1539966E-04,.1804326E-04,& + & .2217884E-04,.4995284E-04,.2317770E-06,.3868823E-05,.7322475E-05,& + & .1053445E-04,.1325413E-04,.1570896E-04,.1841202E-04,.2268552E-04,& + & .5167058E-04,.2292152E-06,.3975147E-05,.7484804E-05,.1073491E-04,& + & .1348680E-04,.1598438E-04,.1873862E-04,.2312606E-04,.4992244E-04,& + & .2573677E-06,.2629386E-05,.5319732E-05,.7892318E-05,.1048730E-04,& + & .1260461E-04,.1478749E-04,.1816822E-04,.4948787E-04,.2535694E-06,& + & .2751139E-05,.5519585E-05,.8143370E-05,.1078554E-04,.1295471E-04,& + & .1522905E-04,.1876027E-04,.5038619E-04,.2296209E-06,.2871168E-05,& + & .5705427E-05,.8368314E-05,.1104763E-04,.1326931E-04,.1561214E-04,& + & .1930238E-04,.4875010E-04,.2285283E-06,.2976458E-05,.5870383E-05,& + & .8562471E-05,.1128721E-04,.1355655E-04,.1595638E-04,.1975997E-04,& + & .4655490E-04,.2277949E-06,.3086384E-05,.6023967E-05,.8743382E-05,& + & .1150669E-04,.1381686E-04,.1626204E-04,.2015870E-04,.4599833E-04/ + + data absa( 1:180, 5) / & + & .1258379E-03,.1792232E-03,.2263834E-03,.2643095E-03,.2960118E-03,& + & .3236055E-03,.3486226E-03,.3708136E-03,.3537227E-03,.1252867E-03,& + & .1784744E-03,.2256677E-03,.2637463E-03,.2957115E-03,.3235207E-03,& + & .3487202E-03,.3710916E-03,.3547494E-03,.1246492E-03,.1788252E-03,& + & .2273405E-03,.2669495E-03,.3004867E-03,.3297723E-03,.3562380E-03,& + & .3799251E-03,.3658619E-03,.1240169E-03,.1766881E-03,.2240641E-03,& + & .2627788E-03,.2953183E-03,.3234639E-03,.3488432E-03,.3713321E-03,& + & .3567172E-03,.1233679E-03,.1757608E-03,.2232662E-03,.2622089E-03,& + & .2951315E-03,.3234287E-03,.3488259E-03,.3713523E-03,.3576976E-03,& + & .1069251E-03,.1638851E-03,.2111585E-03,.2498003E-03,.2830029E-03,& + & .3120257E-03,.3378034E-03,.3624640E-03,.3424007E-03,.1064316E-03,& + & .1632513E-03,.2106727E-03,.2494364E-03,.2829718E-03,.3122311E-03,& + & .3381458E-03,.3630252E-03,.3438497E-03,.1058739E-03,.1637860E-03,& + & .2127118E-03,.2531195E-03,.2882500E-03,.3190771E-03,.3463354E-03,& + & .3723861E-03,.3557833E-03,.1053157E-03,.1629041E-03,.2119399E-03,& + & .2525668E-03,.2878735E-03,.3188283E-03,.3460548E-03,.3719927E-03,& + & .3563658E-03,.1048030E-03,.1609177E-03,.2089982E-03,.2486370E-03,& + & .2829942E-03,.3129743E-03,.3391967E-03,.3638899E-03,.3480124E-03,& + & .9052393E-04,.1496647E-03,.1963928E-03,.2353138E-03,.2692949E-03,& + & .2994397E-03,.3259337E-03,.3522926E-03,.3288949E-03,.9011012E-04,& + & .1491318E-03,.1961079E-03,.2352015E-03,.2695824E-03,.2999606E-03,& + & .3266081E-03,.3531618E-03,.3308028E-03,.8966771E-04,.1485392E-03,& + & .1958028E-03,.2351815E-03,.2698429E-03,.3005448E-03,.3273009E-03,& + & .3538438E-03,.3326818E-03,.8920657E-04,.1491611E-03,.1980348E-03,& + & .2389898E-03,.2753310E-03,.3075620E-03,.3356528E-03,.3632137E-03,& + & .3449423E-03,.8880078E-04,.1472741E-03,.1951287E-03,.2350641E-03,& + & .2704561E-03,.3016661E-03,.3287211E-03,.3549932E-03,.3361806E-03,& + & .7642425E-04,.1365161E-03,.1822415E-03,.2208431E-03,.2550453E-03,& + & .2857390E-03,.3131524E-03,.3407797E-03,.3140906E-03,.7610890E-04,& + & .1361051E-03,.1821158E-03,.2209982E-03,.2556705E-03,.2866395E-03,& + & .3142723E-03,.3419173E-03,.3164057E-03,.7573557E-04,.1356867E-03,& + & .1820099E-03,.2212242E-03,.2562294E-03,.2875830E-03,.3152966E-03,& + & .3429191E-03,.3186642E-03,.7538404E-04,.1352458E-03,.1818638E-03,& + & .2214386E-03,.2568082E-03,.2884658E-03,.3163349E-03,.3438669E-03,& + & .3207779E-03,.7505591E-04,.1360347E-03,.1841939E-03,.2254174E-03,& + & .2624835E-03,.2957188E-03,.3250526E-03,.3534819E-03,.3333120E-03/ + + data absa(181:315, 5) / & + & .6441960E-04,.1243382E-03,.1686492E-03,.2063321E-03,.2401962E-03,& + & .2709669E-03,.2991358E-03,.3279206E-03,.2981254E-03,.6417820E-04,& + & .1241020E-03,.1687386E-03,.2068102E-03,.2412076E-03,.2722842E-03,& + & .3007606E-03,.3294871E-03,.3009391E-03,.6388399E-04,.1238576E-03,& + & .1687898E-03,.2073172E-03,.2421411E-03,.2736197E-03,.3022572E-03,& + & .3309669E-03,.3036272E-03,.6360964E-04,.1235961E-03,.1688422E-03,& + & .2077864E-03,.2431068E-03,.2749041E-03,.3037508E-03,.3323669E-03,& + & .3061923E-03,.6334715E-04,.1246342E-03,.1715166E-03,.2122785E-03,& + & .2493866E-03,.2829267E-03,.3132804E-03,.3430618E-03,.3198672E-03,& + & .5428305E-04,.1131178E-03,.1555172E-03,.1918587E-03,.2248108E-03,& + & .2552688E-03,.2837909E-03,.3135092E-03,.2808167E-03,.5410275E-04,& + & .1130139E-03,.1558251E-03,.1926789E-03,.2262062E-03,.2569617E-03,& + & .2858483E-03,.3156324E-03,.2840877E-03,.5388978E-04,.1129118E-03,& + & .1560839E-03,.1935035E-03,.2275082E-03,.2586750E-03,.2877475E-03,& + & .3176409E-03,.2872619E-03,.5366157E-04,.1128154E-03,.1563700E-03,& + & .1943089E-03,.2288065E-03,.2603020E-03,.2896110E-03,.3195144E-03,& + & .2902915E-03,.5344784E-04,.1126980E-03,.1566320E-03,.1951184E-03,& + & .2300546E-03,.2619121E-03,.2914792E-03,.3214494E-03,.2932874E-03,& + & .4571342E-04,.1026942E-03,.1428236E-03,.1775296E-03,.2091830E-03,& + & .2387595E-03,.2671739E-03,.2978545E-03,.2594784E-03,.4560282E-04,& + & .1027218E-03,.1433756E-03,.1786580E-03,.2109254E-03,.2408706E-03,& + & .2696813E-03,.3004723E-03,.2634130E-03,.4544692E-04,.1027687E-03,& + & .1438888E-03,.1797866E-03,.2125279E-03,.2429678E-03,.2720358E-03,& + & .3029173E-03,.2670716E-03,.4528151E-04,.1028069E-03,.1444180E-03,& + & .1808751E-03,.2141242E-03,.2449535E-03,.2743172E-03,.3052177E-03,& + & .2706270E-03,.4511742E-04,.1028521E-03,.1449287E-03,.1819408E-03,& + & .2156718E-03,.2468811E-03,.2765286E-03,.3074942E-03,.2741063E-03/ + + data absa(316:450, 5) / & + & .3845347E-04,.9301429E-04,.1306852E-03,.1633456E-03,.1934332E-03,& + & .2218378E-03,.2497592E-03,.2809541E-03,.1575108E-03,.3839587E-04,& + & .9318412E-04,.1314652E-03,.1648012E-03,.1954890E-03,.2243498E-03,& + & .2526899E-03,.2840733E-03,.1617842E-03,.3829010E-04,.9337649E-04,& + & .1322053E-03,.1662204E-03,.1974070E-03,.2268068E-03,.2554975E-03,& + & .2869785E-03,.1663258E-03,.3818495E-04,.9357010E-04,.1329542E-03,& + & .1675979E-03,.1993416E-03,.2291758E-03,.2582113E-03,.2897317E-03,& + & .1701293E-03,.3807196E-04,.9375146E-04,.1336930E-03,.1689218E-03,& + & .2012206E-03,.2314740E-03,.2608244E-03,.2924501E-03,.1741563E-03,& + & .3222272E-04,.8402664E-04,.1190004E-03,.1495500E-03,.1778606E-03,& + & .2048436E-03,.2318785E-03,.2632322E-03,.2491014E-04,.3221362E-04,& + & .8435285E-04,.1199991E-03,.1512485E-03,.1802135E-03,.2077441E-03,& + & .2352663E-03,.2668367E-03,.2569053E-04,.3215953E-04,.8468829E-04,& + & .1209883E-03,.1529182E-03,.1824779E-03,.2105732E-03,.2385311E-03,& + & .2702367E-03,.2701309E-04,.3210851E-04,.8503241E-04,.1219626E-03,& + & .1545750E-03,.1847085E-03,.2133101E-03,.2416857E-03,.2734763E-03,& + & .2805465E-04,.3204318E-04,.8537283E-04,.1229412E-03,.1561853E-03,& + & .1869065E-03,.2159588E-03,.2447099E-03,.2766143E-03,.2860049E-04,& + & .2668365E-04,.7570181E-04,.1080203E-03,.1364318E-03,.1629303E-03,& + & .1883981E-03,.2142724E-03,.2453798E-03,.3073231E-04,.2671397E-04,& + & .7619513E-04,.1092103E-03,.1383829E-03,.1655646E-03,.1916417E-03,& + & .2180830E-03,.2494081E-03,.2860411E-04,.2670321E-04,.7667716E-04,& + & .1104090E-03,.1402846E-03,.1681221E-03,.1948231E-03,.2217702E-03,& + & .2532299E-03,.2852470E-04,.2669101E-04,.7717197E-04,.1115742E-03,& + & .1422043E-03,.1706685E-03,.1979160E-03,.2253063E-03,.2569544E-03,& + & .3387605E-04,.2666179E-04,.7765343E-04,.1127755E-03,.1440858E-03,& + & .1731700E-03,.2008739E-03,.2287122E-03,.2605352E-03,.3169336E-04/ + + data absa(451:585, 5) / & + & .2167692E-04,.6827587E-04,.9836512E-04,.1250201E-03,.1498886E-03,& + & .1739600E-03,.1987214E-03,.2293404E-03,.2440081E-04,.2169387E-04,& + & .6891366E-04,.9974241E-04,.1271668E-03,.1528340E-03,.1776053E-03,& + & .2029862E-03,.2337700E-03,.2638768E-04,.2170600E-04,.6954070E-04,& + & .1011255E-03,.1293455E-03,.1556958E-03,.1811079E-03,.2069944E-03,& + & .2380400E-03,.3200312E-04,.2170812E-04,.7016990E-04,.1025105E-03,& + & .1314880E-03,.1585164E-03,.1844769E-03,.2108627E-03,.2421072E-03,& + & .3275541E-04,.2168923E-04,.7080350E-04,.1038948E-03,.1335789E-03,& + & .1612308E-03,.1877502E-03,.2145673E-03,.2460134E-03,.3270936E-04,& + & .1752912E-04,.6154969E-04,.8955810E-04,.1143831E-03,.1376209E-03,& + & .1602880E-03,.1838222E-03,.2134820E-03,.2872965E-04,.1755385E-04,& + & .6231518E-04,.9115429E-04,.1168314E-03,.1408712E-03,.1642185E-03,& + & .1883638E-03,.2183575E-03,.3183547E-04,.1752199E-04,.6309426E-04,& + & .9273525E-04,.1192604E-03,.1440348E-03,.1680514E-03,.1927365E-03,& + & .2230115E-03,.3077672E-04,.1749575E-04,.6385017E-04,.9430365E-04,& + & .1216307E-03,.1471390E-03,.1717409E-03,.1969541E-03,.2274695E-03,& + & .2312932E-04,.1752070E-04,.6462019E-04,.9584906E-04,.1239388E-03,& + & .1501161E-03,.1753754E-03,.2010501E-03,.2317004E-03,.2383092E-04,& + & .1387461E-04,.5546622E-04,.8152797E-04,.1045929E-03,.1262746E-03,& + & .1474566E-03,.1696496E-03,.1981242E-03,.3139074E-04,.1392397E-04,& + & .5636393E-04,.8334885E-04,.1072746E-03,.1297503E-03,.1516626E-03,& + & .1744739E-03,.2033126E-03,.2572972E-04,.1396545E-04,.5726788E-04,& + & .8511400E-04,.1099575E-03,.1332042E-03,.1557803E-03,.1791529E-03,& + & .2083642E-03,.2669035E-04,.1397377E-04,.5816790E-04,.8688926E-04,& + & .1125444E-03,.1365495E-03,.1597819E-03,.1837038E-03,.2131552E-03,& + & .2848091E-04,.1401956E-04,.5906486E-04,.8860992E-04,.1150938E-03,& + & .1398565E-03,.1638183E-03,.1882562E-03,.2178384E-03,.2719011E-04/ + + data absa( 1:180, 6) / & + & .1127779E-02,.1042084E-02,.1103730E-02,.1177585E-02,.1245882E-02,& + & .1305946E-02,.1334440E-02,.1306277E-02,.1318375E-02,.1125070E-02,& + & .1037761E-02,.1098032E-02,.1171270E-02,.1239267E-02,.1299657E-02,& + & .1328359E-02,.1299803E-02,.1315607E-02,.1123280E-02,.1035695E-02,& + & .1095422E-02,.1170386E-02,.1240633E-02,.1304457E-02,.1337002E-02,& + & .1309998E-02,.1335448E-02,.1122248E-02,.1032813E-02,.1088190E-02,& + & .1159040E-02,.1227090E-02,.1287160E-02,.1316759E-02,.1286817E-02,& + & .1309802E-02,.1121332E-02,.1030797E-02,.1084488E-02,.1154404E-02,& + & .1221682E-02,.1281593E-02,.1311385E-02,.1280520E-02,.1306178E-02,& + & .1019965E-02,.9810459E-03,.1068764E-02,.1149672E-02,.1228423E-02,& + & .1296985E-02,.1342592E-02,.1331587E-02,.1337457E-02,.1017770E-02,& + & .9768453E-03,.1063034E-02,.1145111E-02,.1222358E-02,.1291726E-02,& + & .1337570E-02,.1326202E-02,.1335613E-02,.1016813E-02,.9753083E-03,& + & .1061473E-02,.1145518E-02,.1226142E-02,.1297946E-02,.1347626E-02,& + & .1338886E-02,.1357689E-02,.1015843E-02,.9725487E-03,.1057441E-02,& + & .1140180E-02,.1220522E-02,.1291191E-02,.1340908E-02,.1331183E-02,& + & .1353078E-02,.1015463E-02,.9698700E-03,.1050819E-02,.1130971E-02,& + & .1207619E-02,.1275709E-02,.1322301E-02,.1309378E-02,.1327704E-02,& + & .9119475E-03,.9235847E-03,.1031890E-02,.1126261E-02,.1212118E-02,& + & .1287381E-02,.1346323E-02,.1352648E-02,.1351799E-02,.9104425E-03,& + & .9200649E-03,.1026543E-02,.1122353E-02,.1206597E-02,.1282710E-02,& + & .1341997E-02,.1348233E-02,.1350149E-02,.9096645E-03,.9174474E-03,& + & .1022607E-02,.1117149E-02,.1202222E-02,.1277201E-02,.1337011E-02,& + & .1343242E-02,.1348493E-02,.9088794E-03,.9162707E-03,.1022764E-02,& + & .1119302E-02,.1206504E-02,.1284741E-02,.1348507E-02,.1357512E-02,& + & .1369635E-02,.9088680E-03,.9133197E-03,.1016712E-02,.1109724E-02,& + & .1192813E-02,.1268948E-02,.1329585E-02,.1335432E-02,.1344303E-02,& + & .8030336E-03,.8629808E-03,.9905516E-03,.1102706E-02,.1194581E-02,& + & .1276097E-02,.1344985E-02,.1368489E-02,.1358472E-02,.8020685E-03,& + & .8599499E-03,.9864952E-03,.1098943E-02,.1190085E-02,.1271988E-02,& + & .1340997E-02,.1365627E-02,.1358480E-02,.8014347E-03,.8575084E-03,& + & .9835460E-03,.1094344E-02,.1186524E-02,.1267351E-02,.1337492E-02,& + & .1362554E-02,.1358055E-02,.8012884E-03,.8553201E-03,.9810718E-03,& + & .1090482E-02,.1182154E-02,.1264203E-02,.1334958E-02,.1360018E-02,& + & .1357215E-02,.8017028E-03,.8553036E-03,.9828813E-03,.1094204E-02,& + & .1188558E-02,.1274654E-02,.1347715E-02,.1376787E-02,.1377563E-02/ + + data absa(181:315, 6) / & + & .6989341E-03,.8008136E-03,.9474693E-03,.1073693E-02,.1176718E-02,& + & .1263281E-02,.1337495E-02,.1377174E-02,.1357373E-02,.6982803E-03,& + & .7984718E-03,.9443526E-03,.1071067E-02,.1172943E-02,.1259834E-02,& + & .1334341E-02,.1375767E-02,.1358133E-02,.6978266E-03,.7963865E-03,& + & .9422629E-03,.1067324E-02,.1169642E-02,.1256400E-02,.1331961E-02,& + & .1374337E-02,.1358589E-02,.6981011E-03,.7946817E-03,.9401344E-03,& + & .1064498E-02,.1165906E-02,.1254292E-02,.1329925E-02,.1372816E-02,& + & .1358794E-02,.6987926E-03,.7955223E-03,.9431432E-03,.1070202E-02,& + & .1174838E-02,.1266995E-02,.1345241E-02,.1390924E-02,.1382115E-02,& + & .6011592E-03,.7388959E-03,.9023729E-03,.1040717E-02,.1155626E-02,& + & .1247524E-02,.1326820E-02,.1381148E-02,.1347234E-02,.6009151E-03,& + & .7373240E-03,.9002892E-03,.1038951E-02,.1152565E-02,.1245208E-02,& + & .1324569E-02,.1380312E-02,.1349694E-02,.6008914E-03,.7360400E-03,& + & .8989538E-03,.1035946E-02,.1150472E-02,.1242758E-02,.1323179E-02,& + & .1379317E-02,.1351734E-02,.6017350E-03,.7352405E-03,.8972176E-03,& + & .1033783E-02,.1147905E-02,.1241675E-02,.1321813E-02,.1377843E-02,& + & .1353588E-02,.6024658E-03,.7352400E-03,.8961216E-03,.1032038E-02,& + & .1146289E-02,.1240281E-02,.1320537E-02,.1375799E-02,.1354849E-02,& + & .5131365E-03,.6802953E-03,.8558547E-03,.1004257E-02,.1129015E-02,& + & .1228658E-02,.1311670E-02,.1377495E-02,.1326794E-02,.5128417E-03,& + & .6796430E-03,.8551433E-03,.1003333E-02,.1127459E-02,.1227610E-02,& + & .1310680E-02,.1377165E-02,.1331440E-02,.5128844E-03,.6791129E-03,& + & .8543752E-03,.1001545E-02,.1126702E-02,.1226436E-02,.1310287E-02,& + & .1377210E-02,.1336197E-02,.5138776E-03,.6790044E-03,.8533106E-03,& + & .1000677E-02,.1125665E-02,.1226017E-02,.1310194E-02,.1376877E-02,& + & .1340793E-02,.5148503E-03,.6794602E-03,.8527717E-03,.1000386E-02,& + & .1125230E-02,.1225940E-02,.1310446E-02,.1376564E-02,.1344823E-02/ + + data absa(316:450, 6) / & + & .4354937E-03,.6258347E-03,.8095219E-03,.9652907E-03,.1096244E-02,& + & .1204241E-02,.1290647E-02,.1366018E-02,.1291769E-02,.4351834E-03,& + & .6260531E-03,.8097110E-03,.9658306E-03,.1096299E-02,.1204907E-02,& + & .1291676E-02,.1367386E-02,.1299495E-02,.4354926E-03,.6262211E-03,& + & .8099139E-03,.9655329E-03,.1097699E-02,.1205112E-02,.1292665E-02,& + & .1368366E-02,.1307945E-02,.4366061E-03,.6265142E-03,.8100645E-03,& + & .9659489E-03,.1098184E-02,.1206245E-02,.1294118E-02,.1369694E-02,& + & .1316015E-02,.4374936E-03,.6275003E-03,.8106097E-03,.9669869E-03,& + & .1099303E-02,.1207811E-02,.1295643E-02,.1370889E-02,.1323956E-02,& + & .3685128E-03,.5745214E-03,.7639287E-03,.9223177E-03,.1057771E-02,& + & .1170619E-02,.1261579E-02,.1344082E-02,.3978360E-03,.3683928E-03,& + & .5756454E-03,.7650351E-03,.9248369E-03,.1060206E-02,.1174221E-02,& + & .1265274E-02,.1347856E-02,.4071014E-03,.3688375E-03,.5764859E-03,& + & .7661665E-03,.9267124E-03,.1063374E-02,.1176667E-02,.1268148E-02,& + & .1350882E-02,.4149611E-03,.3697059E-03,.5774958E-03,.7676652E-03,& + & .9288451E-03,.1065840E-02,.1179962E-02,.1271481E-02,.1354201E-02,& + & .4230889E-03,.3705971E-03,.5790606E-03,.7693590E-03,.9312187E-03,& + & .1068730E-02,.1183767E-02,.1275156E-02,.1357593E-02,.4395701E-03,& + & .3118513E-03,.5278670E-03,.7179922E-03,.8762847E-03,.1013004E-02,& + & .1129188E-02,.1225380E-02,.1313014E-02,.2823336E-04,.3119642E-03,& + & .5295040E-03,.7205085E-03,.8810719E-03,.1018490E-02,.1135842E-02,& + & .1231411E-02,.1319687E-02,.2591174E-04,.3123480E-03,.5313833E-03,& + & .7231295E-03,.8852977E-03,.1024173E-02,.1141110E-02,.1237009E-02,& + & .1325493E-02,.2490050E-04,.3131033E-03,.5329730E-03,.7261876E-03,& + & .8890594E-03,.1028824E-02,.1147600E-02,.1243500E-02,.1331641E-02,& + & .2358085E-04,.3141200E-03,.5351677E-03,.7291337E-03,.8933695E-03,& + & .1034263E-02,.1154416E-02,.1249926E-02,.1337840E-02,.1914261E-04/ + + data absa(451:585, 6) / & + & .2645518E-03,.4865074E-03,.6737735E-03,.8307780E-03,.9684326E-03,& + & .1087714E-02,.1187390E-02,.1279536E-02,.3096728E-04,.2646171E-03,& + & .4891259E-03,.6781457E-03,.8380014E-03,.9763776E-03,.1095878E-02,& + & .1195388E-02,.1287784E-02,.1937897E-04,.2653275E-03,.4912812E-03,& + & .6826723E-03,.8439569E-03,.9843890E-03,.1104414E-02,.1204820E-02,& + & .1296209E-02,.2310672E-04,.2660999E-03,.4938062E-03,.6869132E-03,& + & .8501984E-03,.9923360E-03,.1114850E-02,.1214879E-02,.1305902E-02,& + & .1551854E-04,.2672744E-03,.4963201E-03,.6913518E-03,.8568207E-03,& + & .1001054E-02,.1124616E-02,.1224913E-02,.1315531E-02,.1902280E-04,& + & .2249381E-03,.4491543E-03,.6314125E-03,.7873093E-03,.9244395E-03,& + & .1044841E-02,.1147218E-02,.1242720E-02,.1795873E-04,.2253436E-03,& + & .4522769E-03,.6374135E-03,.7959199E-03,.9349022E-03,.1056532E-02,& + & .1159671E-02,.1253800E-02,.3013456E-04,.2260901E-03,.4552587E-03,& + & .6435905E-03,.8039747E-03,.9457286E-03,.1069229E-02,.1173356E-02,& + & .1266548E-02,.1199840E-04,.2269143E-03,.4587430E-03,.6495108E-03,& + & .8129332E-03,.9570070E-03,.1082883E-02,.1186741E-02,.1279448E-02,& + & .1794789E-04,.2280730E-03,.4618575E-03,.6559639E-03,.8219928E-03,& + & .9685634E-03,.1095437E-02,.1200070E-02,.1292864E-02,.3604270E-04,& + & .1921277E-03,.4151006E-03,.5920383E-03,.7457881E-03,.8813168E-03,& + & .1001800E-02,.1105493E-02,.1202692E-02,.2297239E-04,.1928316E-03,& + & .4191322E-03,.5996165E-03,.7563148E-03,.8956200E-03,.1018058E-02,& + & .1123450E-02,.1218805E-02,.7650963E-05,.1934147E-03,.4229466E-03,& + & .6073039E-03,.7668297E-03,.9096828E-03,.1035442E-02,.1141697E-02,& + & .1235773E-02,.1552682E-04,.1943616E-03,.4270842E-03,.6149144E-03,& + & .7783265E-03,.9240174E-03,.1052153E-02,.1158854E-02,.1252683E-02,& + & .1480436E-06,.1954216E-03,.4310524E-03,.6232033E-03,.7895004E-03,& + & .9380216E-03,.1067280E-02,.1175445E-02,.1269539E-02,.1885871E-06/ + + data absa( 1:180, 7) / & + & .6726057E-02,.5885484E-02,.5089667E-02,.4459280E-02,.3971837E-02,& + & .3599783E-02,.3258569E-02,.2761804E-02,.3295159E-02,.6741033E-02,& + & .5898281E-02,.5098508E-02,.4461017E-02,.3965454E-02,.3586408E-02,& + & .3239758E-02,.2739181E-02,.3264504E-02,.6753803E-02,.5909939E-02,& + & .5108959E-02,.4465734E-02,.3967543E-02,.3586504E-02,.3237724E-02,& + & .2736408E-02,.3262274E-02,.6761981E-02,.5916777E-02,.5112425E-02,& + & .4461186E-02,.3950994E-02,.3560504E-02,.3206228E-02,.2700475E-02,& + & .3204452E-02,.6766641E-02,.5920869E-02,.5113796E-02,.4457946E-02,& + & .3942736E-02,.3547005E-02,.3190693E-02,.2682249E-02,.3178026E-02,& + & .6602172E-02,.5776872E-02,.5061456E-02,.4534366E-02,.4128541E-02,& + & .3833906E-02,.3516765E-02,.3008287E-02,.3509874E-02,.6617721E-02,& + & .5790525E-02,.5069114E-02,.4531714E-02,.4120691E-02,.3818183E-02,& + & .3497546E-02,.2984974E-02,.3478859E-02,.6628661E-02,.5799925E-02,& + & .5076114E-02,.4533842E-02,.4120334E-02,.3817738E-02,.3496943E-02,& + & .2984746E-02,.3479524E-02,.6637051E-02,.5807576E-02,.5078438E-02,& + & .4529659E-02,.4109342E-02,.3801331E-02,.3478883E-02,.2965136E-02,& + & .3448943E-02,.6644129E-02,.5813792E-02,.5079055E-02,.4521155E-02,& + & .4092528E-02,.3771957E-02,.3445403E-02,.2926792E-02,.3395993E-02,& + & .6403543E-02,.5608393E-02,.4995394E-02,.4569211E-02,.4267045E-02,& + & .4052917E-02,.3769832E-02,.3262352E-02,.3718785E-02,.6418428E-02,& + & .5620905E-02,.5000985E-02,.4564662E-02,.4256975E-02,.4036131E-02,& + & .3749359E-02,.3237816E-02,.3690475E-02,.6431526E-02,.5631313E-02,& + & .5004466E-02,.4561740E-02,.4245515E-02,.4020306E-02,.3730187E-02,& + & .3216366E-02,.3662511E-02,.6443000E-02,.5641170E-02,.5008963E-02,& + & .4562706E-02,.4244648E-02,.4017451E-02,.3728288E-02,.3215678E-02,& + & .3669714E-02,.6454834E-02,.5651225E-02,.5010564E-02,.4555174E-02,& + & .4226789E-02,.3985960E-02,.3691258E-02,.3172291E-02,.3616086E-02,& + & .6136735E-02,.5394093E-02,.4895063E-02,.4573199E-02,.4385068E-02,& + & .4249509E-02,.4003690E-02,.3510981E-02,.3909452E-02,.6155380E-02,& + & .5408904E-02,.4900856E-02,.4569405E-02,.4373257E-02,.4232877E-02,& + & .3984093E-02,.3485462E-02,.3882943E-02,.6172980E-02,.5422475E-02,& + & .4904945E-02,.4567515E-02,.4361079E-02,.4216322E-02,.3963626E-02,& + & .3461480E-02,.3857723E-02,.6190567E-02,.5436595E-02,.4910048E-02,& + & .4565398E-02,.4351183E-02,.4198401E-02,.3942356E-02,.3437743E-02,& + & .3835996E-02,.6207595E-02,.5450671E-02,.4917790E-02,.4569064E-02,& + & .4350510E-02,.4193413E-02,.3939962E-02,.3434045E-02,.3850556E-02/ + + data absa(181:315, 7) / & + & .5805911E-02,.5141666E-02,.4763038E-02,.4558815E-02,.4481648E-02,& + & .4418775E-02,.4218480E-02,.3750496E-02,.4085582E-02,.5829599E-02,& + & .5159492E-02,.4770932E-02,.4555269E-02,.4469546E-02,.4402981E-02,& + & .4198610E-02,.3724260E-02,.4061967E-02,.5854540E-02,.5177705E-02,& + & .4778238E-02,.4554312E-02,.4457721E-02,.4386787E-02,.4178282E-02,& + & .3698112E-02,.4040118E-02,.5879038E-02,.5196952E-02,.4787326E-02,& + & .4553873E-02,.4447674E-02,.4369633E-02,.4158545E-02,.3673692E-02,& + & .4021141E-02,.5902275E-02,.5214049E-02,.4797276E-02,.4557481E-02,& + & .4445243E-02,.4367290E-02,.4159851E-02,.3673710E-02,.4041450E-02,& + & .5423597E-02,.4859083E-02,.4609862E-02,.4529795E-02,.4557832E-02,& + & .4560070E-02,.4409076E-02,.3975219E-02,.4252602E-02,.5454365E-02,& + & .4881607E-02,.4620352E-02,.4527565E-02,.4548530E-02,.4548237E-02,& + & .4391661E-02,.3949326E-02,.4232009E-02,.5488044E-02,.4905751E-02,& + & .4632103E-02,.4528708E-02,.4538967E-02,.4534788E-02,.4373488E-02,& + & .3924420E-02,.4212910E-02,.5518713E-02,.4928892E-02,.4643930E-02,& + & .4529113E-02,.4529842E-02,.4520746E-02,.4357460E-02,.3901482E-02,& + & .4195693E-02,.5549581E-02,.4949387E-02,.4654691E-02,.4528154E-02,& + & .4518717E-02,.4507320E-02,.4341984E-02,.3878945E-02,.4179215E-02,& + & .5010662E-02,.4562289E-02,.4450406E-02,.4497408E-02,.4612122E-02,& + & .4668231E-02,.4573752E-02,.4184611E-02,.4407478E-02,.5048488E-02,& + & .4588791E-02,.4462195E-02,.4495999E-02,.4605287E-02,.4662092E-02,& + & .4561288E-02,.4161583E-02,.4389563E-02,.5087790E-02,.4615970E-02,& + & .4475379E-02,.4496880E-02,.4598974E-02,.4654027E-02,.4547703E-02,& + & .4139097E-02,.4372125E-02,.5124133E-02,.4641212E-02,.4488105E-02,& + & .4495983E-02,.4593289E-02,.4645512E-02,.4535541E-02,.4118063E-02,& + & .4355876E-02,.5162759E-02,.4667582E-02,.4502006E-02,.4496029E-02,& + & .4585626E-02,.4636559E-02,.4523214E-02,.4097252E-02,.4340154E-02/ + + data absa(316:450, 7) / & + & .4587688E-02,.4265942E-02,.4293117E-02,.4465668E-02,.4646838E-02,& + & .4746553E-02,.4710731E-02,.4377367E-02,.4543398E-02,.4630881E-02,& + & .4294688E-02,.4306044E-02,.4466382E-02,.4646169E-02,.4747955E-02,& + & .4704166E-02,.4357348E-02,.4528127E-02,.4671866E-02,.4321409E-02,& + & .4317765E-02,.4465517E-02,.4644351E-02,.4746523E-02,.4697148E-02,& + & .4338778E-02,.4512456E-02,.4713989E-02,.4350596E-02,.4331423E-02,& + & .4464363E-02,.4642472E-02,.4743704E-02,.4690020E-02,.4320460E-02,& + & .4498985E-02,.4761723E-02,.4382334E-02,.4348263E-02,.4465420E-02,& + & .4638543E-02,.4740624E-02,.4683278E-02,.4302003E-02,.4484275E-02,& + & .4164717E-02,.3979215E-02,.4144193E-02,.4422962E-02,.4657806E-02,& + & .4800744E-02,.4824067E-02,.4555259E-02,.4602286E-02,.4211716E-02,& + & .4008521E-02,.4157412E-02,.4428976E-02,.4663384E-02,.4809552E-02,& + & .4822353E-02,.4539339E-02,.4590712E-02,.4257203E-02,.4037513E-02,& + & .4169430E-02,.4432371E-02,.4669584E-02,.4816112E-02,.4822125E-02,& + & .4523735E-02,.4581771E-02,.4307089E-02,.4070222E-02,.4184488E-02,& + & .4434611E-02,.4676070E-02,.4820311E-02,.4822098E-02,.4508261E-02,& + & .4573178E-02,.4362715E-02,.4106878E-02,.4203483E-02,.4440385E-02,& + & .4678627E-02,.4823705E-02,.4820573E-02,.4492558E-02,.4565516E-02,& + & .3757322E-02,.3709073E-02,.4010509E-02,.4365375E-02,.4646644E-02,& + & .4836629E-02,.4911390E-02,.4716037E-02,.2246564E-04,.3804915E-02,& + & .3737287E-02,.4021585E-02,.4379566E-02,.4660941E-02,.4852517E-02,& + & .4918338E-02,.4703233E-02,.1560965E-04,.3856320E-02,.3768752E-02,& + & .4034329E-02,.4388713E-02,.4676333E-02,.4865802E-02,.4925596E-02,& + & .4691751E-02,.2028569E-04,.3915081E-02,.3807123E-02,.4052103E-02,& + & .4397870E-02,.4691010E-02,.4877070E-02,.4930793E-02,.4679143E-02,& + & .8984221E-05,.3978571E-02,.3848618E-02,.4073285E-02,.4408428E-02,& + & .4700559E-02,.4888012E-02,.4935723E-02,.4666034E-02,.2377631E-04/ + + data absa(451:585, 7) / & + & .3392928E-02,.3472731E-02,.3891540E-02,.4305406E-02,.4626003E-02,& + & .4865579E-02,.4987193E-02,.4850053E-02,.7140743E-05,.3445972E-02,& + & .3503144E-02,.3906610E-02,.4325733E-02,.4652048E-02,.4888232E-02,& + & .5003402E-02,.4843920E-02,.1439870E-04,.3506494E-02,.3541411E-02,& + & .3924176E-02,.4343703E-02,.4677805E-02,.4908831E-02,.5016389E-02,& + & .4837310E-02,.2945034E-04,.3573835E-02,.3584076E-02,.3945325E-02,& + & .4362029E-02,.4698214E-02,.4926791E-02,.5027125E-02,.4828102E-02,& + & .4370988E-04,.3640920E-02,.3627224E-02,.3965033E-02,.4380312E-02,& + & .4714810E-02,.4945090E-02,.5036845E-02,.4818793E-02,.2945488E-04,& + & .3062423E-02,.3266343E-02,.3779589E-02,.4238657E-02,.4602824E-02,& + & .4884734E-02,.5053548E-02,.4961911E-02,.2279693E-04,.3122111E-02,& + & .3300450E-02,.3801982E-02,.4268791E-02,.4639422E-02,.4914708E-02,& + & .5076081E-02,.4964486E-02,.3897689E-12,.3189802E-02,.3342291E-02,& + & .3827671E-02,.4296813E-02,.4673472E-02,.4942459E-02,.5094747E-02,& + & .4963101E-02,.2288291E-04,.3258443E-02,.3383882E-02,.3851683E-02,& + & .4323754E-02,.4700766E-02,.4969560E-02,.5112385E-02,.4958514E-02,& + & .5725606E-12,.3332531E-02,.3430641E-02,.3873322E-02,.4350068E-02,& + & .4725169E-02,.4995061E-02,.5126654E-02,.4953566E-02,.2246441E-04,& + & .2769676E-02,.3091600E-02,.3674265E-02,.4169149E-02,.4577937E-02,& + & .4901246E-02,.5107166E-02,.5055949E-02,.2616949E-12,.2834654E-02,& + & .3128534E-02,.3705750E-02,.4210247E-02,.4623099E-02,.4938500E-02,& + & .5137406E-02,.5065069E-02,.1482104E-04,.2902742E-02,.3167333E-02,& + & .3738974E-02,.4249285E-02,.4663578E-02,.4972092E-02,.5164558E-02,& + & .5069435E-02,.4171247E-12,.2976402E-02,.3210834E-02,.3767797E-02,& + & .4287152E-02,.4699067E-02,.5006489E-02,.5189897E-02,.5072755E-02,& + & .2892462E-04,.3057599E-02,.3261050E-02,.3794966E-02,.4320752E-02,& + & .4731977E-02,.5038479E-02,.5208571E-02,.5071823E-02,.5748148E-12/ + + data absa( 1:180, 8) / & + & .2384831E-01,.2086796E-01,.1788674E-01,.1490488E-01,.1192466E-01,& + & .8942720E-02,.6435132E-02,.5216105E-02,.8046861E-02,.2383260E-01,& + & .2085323E-01,.1787386E-01,.1489524E-01,.1191574E-01,.8936646E-02,& + & .6410723E-02,.5172302E-02,.7958914E-02,.2381817E-01,.2084152E-01,& + & .1786363E-01,.1488699E-01,.1190859E-01,.8931517E-02,.6409801E-02,& + & .5184894E-02,.7931542E-02,.2382505E-01,.2084563E-01,.1786745E-01,& + & .1488939E-01,.1191159E-01,.8933625E-02,.6363063E-02,.5080538E-02,& + & .7797373E-02,.2384370E-01,.2086411E-01,.1788240E-01,.1490168E-01,& + & .1192085E-01,.8941188E-02,.6342996E-02,.5038349E-02,.7721574E-02,& + & .2736703E-01,.2394425E-01,.2052396E-01,.1710455E-01,.1368277E-01,& + & .1026855E-01,.7533161E-02,.6102509E-02,.9457556E-02,.2733895E-01,& + & .2392100E-01,.2050455E-01,.1708673E-01,.1366891E-01,.1025512E-01,& + & .7493273E-02,.6042133E-02,.9346029E-02,.2732514E-01,.2390916E-01,& + & .2049354E-01,.1707793E-01,.1366282E-01,.1024661E-01,.7477603E-02,& + & .6033817E-02,.9291851E-02,.2732521E-01,.2390831E-01,.2049329E-01,& + & .1707676E-01,.1366198E-01,.1024619E-01,.7441129E-02,.5964001E-02,& + & .9183864E-02,.2732055E-01,.2390460E-01,.2048954E-01,.1707397E-01,& + & .1365928E-01,.1024450E-01,.7386349E-02,.5857452E-02,.9032475E-02,& + & .3111827E-01,.2722823E-01,.2333792E-01,.1944912E-01,.1556020E-01,& + & .1174017E-01,.8774373E-02,.7126843E-02,.1107681E-01,.3108435E-01,& + & .2719812E-01,.2331276E-01,.1942815E-01,.1554155E-01,.1171142E-01,& + & .8719646E-02,.7046216E-02,.1093045E-01,.3105719E-01,.2717391E-01,& + & .2328911E-01,.1940895E-01,.1552703E-01,.1168858E-01,.8669582E-02,& + & .6965164E-02,.1078986E-01,.3102639E-01,.2714667E-01,.2326970E-01,& + & .1939161E-01,.1551301E-01,.1167462E-01,.8637664E-02,.6932578E-02,& + & .1069100E-01,.3098455E-01,.2711278E-01,.2323876E-01,.1936649E-01,& + & .1549184E-01,.1165288E-01,.8564686E-02,.6812398E-02,.1050557E-01,& + & .3509245E-01,.3070408E-01,.2631947E-01,.2193322E-01,.1754460E-01,& + & .1336963E-01,.1019024E-01,.8304991E-02,.1279060E-01,.3502835E-01,& + & .3065102E-01,.2627132E-01,.2189262E-01,.1751355E-01,.1331920E-01,& + & .1010855E-01,.8200658E-02,.1260628E-01,.3496387E-01,.3059309E-01,& + & .2622344E-01,.2185116E-01,.1748300E-01,.1327541E-01,.1003370E-01,& + & .8097466E-02,.1242619E-01,.3489136E-01,.3053088E-01,.2616852E-01,& + & .2180854E-01,.1744581E-01,.1323085E-01,.9958124E-02,.7996001E-02,& + & .1224573E-01,.3480910E-01,.3045842E-01,.2610586E-01,.2175555E-01,& + & .1740387E-01,.1318718E-01,.9898605E-02,.7943117E-02,.1209514E-01/ + + data absa(181:315, 8) / & + & .3922337E-01,.3432089E-01,.2941855E-01,.2451621E-01,.1961212E-01,& + & .1515625E-01,.1177220E-01,.9640074E-02,.1459421E-01,.3912061E-01,& + & .3423066E-01,.2933971E-01,.2445001E-01,.1956031E-01,.1507474E-01,& + & .1166291E-01,.9508349E-02,.1436943E-01,.3900929E-01,.3413223E-01,& + & .2925716E-01,.2437959E-01,.1950452E-01,.1499589E-01,.1155252E-01,& + & .9377833E-02,.1414677E-01,.3888582E-01,.3402602E-01,.2916246E-01,& + & .2430215E-01,.1944160E-01,.1491429E-01,.1144124E-01,.9247519E-02,& + & .1391910E-01,.3876452E-01,.3391846E-01,.2907242E-01,.2422862E-01,& + & .1938320E-01,.1483471E-01,.1134199E-01,.9163542E-02,.1372356E-01,& + & .4343721E-01,.3800576E-01,.3257544E-01,.2714774E-01,.2177640E-01,& + & .1709399E-01,.1352071E-01,.1113282E-01,.1649120E-01,.4327842E-01,& + & .3786995E-01,.3246159E-01,.2705100E-01,.2168123E-01,.1696268E-01,& + & .1336889E-01,.1097194E-01,.1622011E-01,.4310942E-01,.3772166E-01,& + & .3233366E-01,.2694253E-01,.2158320E-01,.1684054E-01,.1321804E-01,& + & .1080800E-01,.1594714E-01,.4294323E-01,.3757194E-01,.3220476E-01,& + & .2683910E-01,.2148483E-01,.1671415E-01,.1306213E-01,.1064614E-01,& + & .1567355E-01,.4277920E-01,.3742913E-01,.3208316E-01,.2673469E-01,& + & .2139400E-01,.1658867E-01,.1290640E-01,.1049169E-01,.1540259E-01,& + & .4758398E-01,.4163822E-01,.3568958E-01,.2974106E-01,.2404453E-01,& + & .1920360E-01,.1543848E-01,.1277750E-01,.1847724E-01,.4738640E-01,& + & .4146564E-01,.3554040E-01,.2961803E-01,.2390579E-01,.1900947E-01,& + & .1522766E-01,.1257734E-01,.1815308E-01,.4718171E-01,.4128335E-01,& + & .3538475E-01,.2948927E-01,.2375761E-01,.1882582E-01,.1502284E-01,& + & .1237488E-01,.1783112E-01,.4697763E-01,.4110594E-01,.3523272E-01,& + & .2936065E-01,.2361055E-01,.1864217E-01,.1481297E-01,.1217429E-01,& + & .1750726E-01,.4675913E-01,.4091320E-01,.3506988E-01,.2922357E-01,& + & .2347293E-01,.1846131E-01,.1460514E-01,.1197957E-01,.1718605E-01/ + + data absa(316:450, 8) / & + & .5157307E-01,.4512456E-01,.3867815E-01,.3225755E-01,.2639876E-01,& + & .2145781E-01,.1750537E-01,.1456533E-01,.2056891E-01,.5133970E-01,& + & .4492267E-01,.3850493E-01,.3209518E-01,.2619464E-01,.2118929E-01,& + & .1723033E-01,.1431879E-01,.2018920E-01,.5111942E-01,.4472821E-01,& + & .3833961E-01,.3195026E-01,.2598683E-01,.2093775E-01,.1695719E-01,& + & .1406885E-01,.1981018E-01,.5087613E-01,.4451558E-01,.3815604E-01,& + & .3179899E-01,.2578609E-01,.2068553E-01,.1668237E-01,.1381989E-01,& + & .1942343E-01,.5060089E-01,.4427189E-01,.3795104E-01,.3162743E-01,& + & .2558999E-01,.2043394E-01,.1640721E-01,.1357794E-01,.1904337E-01,& + & .5534675E-01,.4842752E-01,.4150943E-01,.3476993E-01,.2883356E-01,& + & .2383857E-01,.1970071E-01,.1648151E-01,.2277280E-01,.5509028E-01,& + & .4820517E-01,.4131655E-01,.3454903E-01,.2856187E-01,.2348302E-01,& + & .1935846E-01,.1617643E-01,.2231934E-01,.5483513E-01,.4798329E-01,& + & .4112957E-01,.3434599E-01,.2827236E-01,.2314776E-01,.1900981E-01,& + & .1587603E-01,.2186150E-01,.5455249E-01,.4773592E-01,.4091413E-01,& + & .3413989E-01,.2798959E-01,.2281411E-01,.1865486E-01,.1557181E-01,& + & .2140320E-01,.5423071E-01,.4745272E-01,.4067235E-01,.3391765E-01,& + & .2771937E-01,.2248276E-01,.1830805E-01,.1527494E-01,.2095422E-01,& + & .5884200E-01,.5148486E-01,.4413720E-01,.3726346E-01,.3131906E-01,& + & .2625246E-01,.2197329E-01,.1846472E-01,.2390318E-01,.5857990E-01,& + & .5125704E-01,.4393628E-01,.3696356E-01,.3095564E-01,.2581323E-01,& + & .2154391E-01,.1810523E-01,.2329308E-01,.5829302E-01,.5100372E-01,& + & .4371805E-01,.3669137E-01,.3057614E-01,.2539516E-01,.2111008E-01,& + & .1774335E-01,.2234009E-01,.5795260E-01,.5070680E-01,.4346190E-01,& + & .3641971E-01,.3020199E-01,.2497397E-01,.2067529E-01,.1737760E-01,& + & .2139251E-01,.5758016E-01,.5038153E-01,.4318130E-01,.3612879E-01,& + & .2984663E-01,.2454856E-01,.2024342E-01,.1701514E-01,.2073609E-01/ + + data absa(451:585, 8) / & + & .6192199E-01,.5417932E-01,.4648962E-01,.3955997E-01,.3362055E-01,& + & .2844545E-01,.2405185E-01,.2035174E-01,.1147313E-01,.6162491E-01,& + & .5392502E-01,.4624284E-01,.3918782E-01,.3314307E-01,.2793088E-01,& + & .2352660E-01,.1992303E-01,.1059037E-01,.6128035E-01,.5361653E-01,& + & .4596296E-01,.3883034E-01,.3266054E-01,.2741823E-01,.2300155E-01,& + & .1948403E-01,.9386733E-02,.6089037E-01,.5327663E-01,.4566324E-01,& + & .3846602E-01,.3220217E-01,.2689963E-01,.2248042E-01,.1904677E-01,& + & .8579093E-02,.6048928E-01,.5292930E-01,.4536869E-01,.3808824E-01,& + & .3175943E-01,.2638003E-01,.2196410E-01,.1861176E-01,.7679777E-02,& + & .6465333E-01,.5657427E-01,.4867177E-01,.4175377E-01,.3579281E-01,& + & .3056479E-01,.2606485E-01,.2228565E-01,.5410855E-02,.6431550E-01,& + & .5627490E-01,.4834862E-01,.4128883E-01,.3521242E-01,.2995578E-01,& + & .2544242E-01,.2175694E-01,.4314129E-02,.6391863E-01,.5593558E-01,& + & .4799090E-01,.4083615E-01,.3463083E-01,.2933897E-01,.2482046E-01,& + & .2122362E-01,.3358717E-02,.6351746E-01,.5557930E-01,.4765095E-01,& + & .4037369E-01,.3408214E-01,.2871059E-01,.2420299E-01,.2070479E-01,& + & .2857525E-02,.6306892E-01,.5519351E-01,.4730897E-01,.3991011E-01,& + & .3354065E-01,.2809407E-01,.2359936E-01,.2018705E-01,.1777796E-02,& + & .6703446E-01,.5865676E-01,.5067634E-01,.4381050E-01,.3782219E-01,& + & .3255454E-01,.2802206E-01,.2421920E-01,.3263487E-02,.6665902E-01,& + & .5832721E-01,.5026612E-01,.4325080E-01,.3713778E-01,.3183964E-01,& + & .2728129E-01,.2358311E-01,.2472960E-02,.6626616E-01,.5798723E-01,& + & .4984365E-01,.4269195E-01,.3646735E-01,.3111990E-01,.2654294E-01,& + & .2295618E-01,.1479400E-02,.6583606E-01,.5760454E-01,.4944157E-01,& + & .4212139E-01,.3581890E-01,.3039518E-01,.2581655E-01,.2233056E-01,& + & .6227714E-03,.6534867E-01,.5717837E-01,.4902999E-01,.4157439E-01,& + & .3517603E-01,.2968487E-01,.2512196E-01,.2172312E-01,.0000000E+00/ + +! the array iabsb(235,8) (kb(5,13:59,8)) contains absorption coefs at +! the 16 chosen g-values for a range of pressure levels < ~100mb and +! temperatures. the first index in the array, jt, which runs from 1 to 5, +! corresponds to different temperatures. more specifically, jt = 3 means +! that the data are for the reference temperature tref for this pressure +! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +! the second index, jp, runs from 13 to 59 and refers to the jpth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). the third index, ig, goes from 1 to 8, +! and tells us which g-interval the absorption coefficients are for. + + data absb( 1:120, 1) / & + & .1504485E-08,.1655173E-08,.1834066E-08,.2005073E-08,.2225228E-08,& + & .2825609E-08,.3120559E-08,.3367595E-08,.3608461E-08,.3837790E-08,& + & .4601061E-08,.4908305E-08,.5119376E-08,.5374147E-08,.5818231E-08,& + & .6064902E-08,.6787357E-08,.7300746E-08,.8100588E-08,.8763709E-08,& + & .9117383E-08,.9716817E-08,.1020886E-07,.1060372E-07,.1107971E-07,& + & .1180416E-07,.1231184E-07,.1271306E-07,.1305533E-07,.1325092E-07,& + & .1466240E-07,.1530788E-07,.1602711E-07,.1636818E-07,.1670250E-07,& + & .1693173E-07,.1796180E-07,.1893120E-07,.2002152E-07,.2083754E-07,& + & .2023944E-07,.2129216E-07,.2220720E-07,.2278656E-07,.2334708E-07,& + & .2244645E-07,.2315295E-07,.2356590E-07,.2386446E-07,.2427953E-07,& + & .2319360E-07,.2372368E-07,.2396595E-07,.2414683E-07,.2427181E-07,& + & .2327042E-07,.2360101E-07,.2379715E-07,.2393742E-07,.2409578E-07,& + & .2292965E-07,.2319441E-07,.2326480E-07,.2333873E-07,.2344359E-07,& + & .2207835E-07,.2228167E-07,.2230807E-07,.2237370E-07,.2237045E-07,& + & .2063469E-07,.2078315E-07,.2069998E-07,.2077522E-07,.2076445E-07,& + & .1888890E-07,.1895087E-07,.1888552E-07,.1896680E-07,.1893800E-07,& + & .1661684E-07,.1660531E-07,.1660816E-07,.1663392E-07,.1655720E-07,& + & .1439584E-07,.1436756E-07,.1440958E-07,.1432625E-07,.1427447E-07,& + & .1206857E-07,.1208380E-07,.1201089E-07,.1199160E-07,.1194784E-07,& + & .1009433E-07,.1006531E-07,.1001838E-07,.9943710E-08,.9961010E-08,& + & .8315238E-08,.8268144E-08,.8236950E-08,.8211572E-08,.8220796E-08,& + & .6957233E-08,.6909506E-08,.6862800E-08,.6872511E-08,.6883916E-08,& + & .5813067E-08,.5757273E-08,.5742704E-08,.5742958E-08,.5758679E-08,& + & .4871874E-08,.4830498E-08,.4812558E-08,.4818784E-08,.4830929E-08/ + + data absb(121:235, 1) / & + & .4145901E-08,.4106507E-08,.4098022E-08,.4099861E-08,.4120380E-08,& + & .3494406E-08,.3465963E-08,.3462820E-08,.3456337E-08,.3467275E-08,& + & .2913432E-08,.2889628E-08,.2883621E-08,.2884851E-08,.2891869E-08,& + & .2518380E-08,.2496362E-08,.2483940E-08,.2484762E-08,.2483586E-08,& + & .2170390E-08,.2145546E-08,.2143039E-08,.2142370E-08,.2144634E-08,& + & .1858046E-08,.1844624E-08,.1839065E-08,.1839091E-08,.1839162E-08,& + & .1593689E-08,.1577154E-08,.1573460E-08,.1568484E-08,.1569186E-08,& + & .1355958E-08,.1341138E-08,.1331384E-08,.1328120E-08,.1330151E-08,& + & .1137083E-08,.1126680E-08,.1120107E-08,.1113883E-08,.1115922E-08,& + & .9476994E-09,.9397984E-09,.9335405E-09,.9287986E-09,.9311504E-09,& + & .7932191E-09,.7894802E-09,.7806572E-09,.7786638E-09,.7792733E-09,& + & .6576028E-09,.6532665E-09,.6444048E-09,.6406832E-09,.6417746E-09,& + & .5317563E-09,.5279691E-09,.5215721E-09,.5171123E-09,.5157522E-09,& + & .4412974E-09,.4375477E-09,.4332457E-09,.4272818E-09,.4275019E-09,& + & .3706852E-09,.3662403E-09,.3636864E-09,.3584788E-09,.3586079E-09,& + & .3049173E-09,.3029969E-09,.3014427E-09,.2964519E-09,.2955262E-09,& + & .2463755E-09,.2449361E-09,.2438107E-09,.2391687E-09,.2384375E-09,& + & .2163852E-09,.2148951E-09,.2136504E-09,.2102694E-09,.2093443E-09,& + & .1986154E-09,.1986504E-09,.1964941E-09,.1948428E-09,.1924552E-09,& + & .1827696E-09,.1814666E-09,.1809023E-09,.1806150E-09,.1773916E-09,& + & .1651185E-09,.1676846E-09,.1675465E-09,.1672040E-09,.1645195E-09,& + & .1529359E-09,.1572349E-09,.1577673E-09,.1563134E-09,.1551000E-09,& + & .1662330E-09,.1742843E-09,.1737219E-09,.1735156E-09,.1726745E-09/ + + data absb( 1:120, 2) / & + & .8620280E-08,.8996610E-08,.9179512E-08,.9273313E-08,.9496698E-08,& + & .1372714E-07,.1415234E-07,.1568014E-07,.1633632E-07,.1660623E-07,& + & .2431506E-07,.2468338E-07,.2511484E-07,.2544479E-07,.2520146E-07,& + & .3107454E-07,.3086269E-07,.3175603E-07,.3173983E-07,.3139772E-07,& + & .3808811E-07,.3902271E-07,.4062594E-07,.4223852E-07,.4271310E-07,& + & .4796946E-07,.4857088E-07,.4939986E-07,.5006781E-07,.5049110E-07,& + & .5417823E-07,.5385088E-07,.5369254E-07,.5418624E-07,.5425686E-07,& + & .5417471E-07,.5315715E-07,.5265850E-07,.5227965E-07,.5182433E-07,& + & .5084925E-07,.4952405E-07,.4900280E-07,.4911242E-07,.4895983E-07,& + & .4638127E-07,.4550613E-07,.4547382E-07,.4602960E-07,.4609687E-07,& + & .4282135E-07,.4200746E-07,.4233769E-07,.4314509E-07,.4364517E-07,& + & .4009028E-07,.3966390E-07,.4021359E-07,.4114239E-07,.4138132E-07,& + & .3718799E-07,.3696495E-07,.3760314E-07,.3889000E-07,.3926156E-07,& + & .3428008E-07,.3436242E-07,.3521050E-07,.3663400E-07,.3706092E-07,& + & .3131405E-07,.3161472E-07,.3286669E-07,.3437652E-07,.3468898E-07,& + & .2838426E-07,.2902508E-07,.3042525E-07,.3175777E-07,.3176690E-07,& + & .2508366E-07,.2604667E-07,.2745713E-07,.2796496E-07,.2814461E-07,& + & .2198601E-07,.2304237E-07,.2412502E-07,.2435339E-07,.2460182E-07,& + & .1894551E-07,.1992262E-07,.2052438E-07,.2042507E-07,.2067876E-07,& + & .1617250E-07,.1693348E-07,.1699496E-07,.1708234E-07,.1690581E-07,& + & .1380557E-07,.1391757E-07,.1389405E-07,.1394496E-07,.1376301E-07,& + & .1155663E-07,.1155203E-07,.1168102E-07,.1152309E-07,.1127853E-07,& + & .9697158E-08,.9695956E-08,.9680578E-08,.9559403E-08,.9302754E-08,& + & .8154203E-08,.8120989E-08,.8036412E-08,.7883272E-08,.7698274E-08/ + + data absb(121:235, 2) / & + & .6967330E-08,.6906568E-08,.6813175E-08,.6653576E-08,.6523040E-08,& + & .5881983E-08,.5845620E-08,.5707887E-08,.5564188E-08,.5496845E-08,& + & .4867982E-08,.4842877E-08,.4723792E-08,.4610581E-08,.4535252E-08,& + & .4220891E-08,.4197573E-08,.4091011E-08,.3984631E-08,.3910118E-08,& + & .3693929E-08,.3663715E-08,.3538644E-08,.3460285E-08,.3368615E-08,& + & .3187896E-08,.3159197E-08,.3046331E-08,.2969790E-08,.2900429E-08,& + & .2727771E-08,.2707740E-08,.2609750E-08,.2537780E-08,.2466859E-08,& + & .2336416E-08,.2288611E-08,.2243157E-08,.2156881E-08,.2077391E-08,& + & .1962744E-08,.1900100E-08,.1900600E-08,.1810939E-08,.1740140E-08,& + & .1641370E-08,.1585025E-08,.1598322E-08,.1519198E-08,.1446996E-08,& + & .1369667E-08,.1331096E-08,.1332974E-08,.1271075E-08,.1212575E-08,& + & .1134932E-08,.1101458E-08,.1088461E-08,.1059785E-08,.1000704E-08,& + & .9094399E-09,.8846586E-09,.8692260E-09,.8514667E-09,.8067748E-09,& + & .7475365E-09,.7309474E-09,.7248197E-09,.7107080E-09,.6704647E-09,& + & .6155314E-09,.6185778E-09,.6128860E-09,.5976466E-09,.5727505E-09,& + & .5007571E-09,.5092447E-09,.5016075E-09,.4940536E-09,.4741181E-09,& + & .3942016E-09,.4100999E-09,.4008001E-09,.3983216E-09,.3787150E-09,& + & .3377646E-09,.3579863E-09,.3566328E-09,.3468912E-09,.3368833E-09,& + & .3036220E-09,.3322234E-09,.3325357E-09,.3256853E-09,.3158305E-09,& + & .2804988E-09,.3017266E-09,.3108715E-09,.2978439E-09,.2936541E-09,& + & .2609790E-09,.2661588E-09,.2860275E-09,.2792342E-09,.2602529E-09,& + & .2458827E-09,.2411410E-09,.2673329E-09,.2554838E-09,.2352146E-09,& + & .2526218E-09,.2394002E-09,.2533229E-09,.2725054E-09,.2570953E-09/ + + data absb( 1:120, 3) / & + & .2094454E-07,.2103723E-07,.2317421E-07,.2429927E-07,.2443259E-07,& + & .3496380E-07,.3490941E-07,.3349223E-07,.3343521E-07,.3310576E-07,& + & .4585045E-07,.4658060E-07,.4768562E-07,.5006330E-07,.5247674E-07,& + & .6284991E-07,.6579582E-07,.6633160E-07,.6800469E-07,.6989589E-07,& + & .7248123E-07,.7171694E-07,.7074783E-07,.6969505E-07,.7027375E-07,& + & .6908485E-07,.6849817E-07,.6716994E-07,.6730050E-07,.6828500E-07,& + & .6934186E-07,.6902567E-07,.6864856E-07,.6846652E-07,.6943860E-07,& + & .6706792E-07,.6726913E-07,.6653898E-07,.6592318E-07,.6689835E-07,& + & .6315693E-07,.6388301E-07,.6354862E-07,.6322257E-07,.6392275E-07,& + & .6021001E-07,.6063825E-07,.6004737E-07,.5982331E-07,.6053882E-07,& + & .5662743E-07,.5727057E-07,.5683287E-07,.5634445E-07,.5728420E-07,& + & .5345713E-07,.5415602E-07,.5376082E-07,.5388461E-07,.5551090E-07,& + & .5097174E-07,.5174221E-07,.5185410E-07,.5170391E-07,.5343406E-07,& + & .4885071E-07,.4964076E-07,.4957246E-07,.4927493E-07,.5181847E-07,& + & .4607099E-07,.4641337E-07,.4642465E-07,.4657013E-07,.4906130E-07,& + & .4289388E-07,.4288894E-07,.4267067E-07,.4328417E-07,.4696503E-07,& + & .3872644E-07,.3855498E-07,.3845341E-07,.4062810E-07,.4336730E-07,& + & .3420706E-07,.3415253E-07,.3481498E-07,.3737966E-07,.3894101E-07,& + & .2944343E-07,.2985002E-07,.3132611E-07,.3395546E-07,.3326394E-07,& + & .2542129E-07,.2622059E-07,.2846268E-07,.2890366E-07,.2912570E-07,& + & .2147717E-07,.2336132E-07,.2481620E-07,.2489857E-07,.2493064E-07,& + & .1865200E-07,.2074963E-07,.2073473E-07,.2113566E-07,.2126999E-07,& + & .1634412E-07,.1718199E-07,.1732143E-07,.1735331E-07,.1757109E-07,& + & .1379461E-07,.1435679E-07,.1452171E-07,.1458681E-07,.1440034E-07/ + + data absb(121:235, 3) / & + & .1173430E-07,.1207008E-07,.1230757E-07,.1227543E-07,.1218723E-07,& + & .9814963E-08,.1008580E-07,.1002846E-07,.1018936E-07,.9936886E-08,& + & .8116338E-08,.8224445E-08,.8137160E-08,.8175235E-08,.7809894E-08,& + & .6934363E-08,.6954010E-08,.7028701E-08,.6954052E-08,.6730920E-08,& + & .6044805E-08,.6051282E-08,.6043548E-08,.5955009E-08,.5737156E-08,& + & .5148115E-08,.5173181E-08,.5143460E-08,.5091858E-08,.4844251E-08,& + & .4357708E-08,.4427891E-08,.4341154E-08,.4374327E-08,.4087965E-08,& + & .3575010E-08,.3758880E-08,.3640315E-08,.3685335E-08,.3462657E-08,& + & .2951838E-08,.3149133E-08,.2949301E-08,.3004140E-08,.2803498E-08,& + & .2384856E-08,.2593067E-08,.2441925E-08,.2455559E-08,.2313264E-08,& + & .1941929E-08,.2123023E-08,.2023449E-08,.2026484E-08,.1914693E-08,& + & .1543067E-08,.1703838E-08,.1718628E-08,.1615796E-08,.1571495E-08,& + & .1183980E-08,.1356359E-08,.1356083E-08,.1273436E-08,.1237516E-08,& + & .9485975E-09,.1113593E-08,.1117504E-08,.1051262E-08,.1016169E-08,& + & .7815940E-09,.9032580E-09,.9357674E-09,.8676745E-09,.8421725E-09,& + & .6380256E-09,.7279036E-09,.7623641E-09,.7144892E-09,.6975727E-09,& + & .5107804E-09,.5598705E-09,.6119439E-09,.5744789E-09,.5583942E-09,& + & .4463278E-09,.4765332E-09,.5199521E-09,.5043420E-09,.4788736E-09,& + & .4250688E-09,.4156415E-09,.4855086E-09,.4508491E-09,.4411532E-09,& + & .3832275E-09,.3697062E-09,.4153029E-09,.4390022E-09,.4199681E-09,& + & .3471974E-09,.3281596E-09,.3530108E-09,.4078183E-09,.4102159E-09,& + & .3136929E-09,.3137942E-09,.3117708E-09,.4176296E-09,.4265890E-09,& + & .3736120E-09,.4038289E-09,.4253194E-09,.5208493E-09,.6353775E-09/ + + data absb( 1:120, 4) / & + & .3207017E-07,.3159502E-07,.2858870E-07,.2844242E-07,.2837738E-07,& + & .3793390E-07,.3899797E-07,.4004916E-07,.4219287E-07,.4324826E-07,& + & .6367926E-07,.6755417E-07,.7008340E-07,.7122591E-07,.7118042E-07,& + & .7271716E-07,.6967355E-07,.6852180E-07,.6761184E-07,.6663393E-07,& + & .6791256E-07,.6626521E-07,.6475029E-07,.6335519E-07,.6341090E-07,& + & .6702275E-07,.6576791E-07,.6566342E-07,.6383917E-07,.6283841E-07,& + & .6421842E-07,.6328175E-07,.6271542E-07,.6152237E-07,.6029747E-07,& + & .6063945E-07,.6050892E-07,.6120783E-07,.6022239E-07,.5821503E-07,& + & .5811689E-07,.5640629E-07,.5625783E-07,.5511738E-07,.5487818E-07,& + & .5348844E-07,.5166798E-07,.5260953E-07,.5132573E-07,.5125687E-07,& + & .5056797E-07,.4945797E-07,.5018027E-07,.5055972E-07,.5015391E-07,& + & .4934735E-07,.4858752E-07,.4903720E-07,.4872055E-07,.4906669E-07,& + & .4696374E-07,.4689614E-07,.4670931E-07,.4783716E-07,.4808487E-07,& + & .4579724E-07,.4485585E-07,.4523316E-07,.4654221E-07,.4697737E-07,& + & .4177011E-07,.4195636E-07,.4315538E-07,.4366803E-07,.4370471E-07,& + & .3826636E-07,.3900949E-07,.4040767E-07,.4050401E-07,.3926292E-07,& + & .3417724E-07,.3398437E-07,.3497769E-07,.3504542E-07,.3635089E-07,& + & .2972685E-07,.3050472E-07,.3019202E-07,.2941542E-07,.3300928E-07,& + & .2569885E-07,.2510078E-07,.2547159E-07,.2603840E-07,.3137309E-07,& + & .2253041E-07,.2113115E-07,.2134413E-07,.2537857E-07,.2492397E-07,& + & .1910416E-07,.1866822E-07,.2015910E-07,.2178797E-07,.2103215E-07,& + & .1751768E-07,.1752356E-07,.1997915E-07,.1876099E-07,.1868247E-07,& + & .1601254E-07,.1739373E-07,.1791673E-07,.1773318E-07,.1719741E-07,& + & .1475039E-07,.1681135E-07,.1649793E-07,.1611369E-07,.1570679E-07/ + + data absb(121:235, 4) / & + & .1303339E-07,.1487026E-07,.1490773E-07,.1478564E-07,.1430577E-07,& + & .1163810E-07,.1261966E-07,.1306776E-07,.1264305E-07,.1269552E-07,& + & .9753745E-08,.1052021E-07,.1077719E-07,.1076181E-07,.1057069E-07,& + & .8428703E-08,.9412717E-08,.9437343E-08,.9161081E-08,.9398817E-08,& + & .6734710E-08,.7798478E-08,.8144691E-08,.8022473E-08,.8252301E-08,& + & .5704222E-08,.6683171E-08,.6786990E-08,.6802772E-08,.7124318E-08,& + & .4641578E-08,.5477035E-08,.5637589E-08,.5540870E-08,.5878158E-08,& + & .3894186E-08,.4572580E-08,.4683803E-08,.4627519E-08,.4835245E-08,& + & .3094846E-08,.3631163E-08,.3872510E-08,.3801876E-08,.4051812E-08,& + & .2505988E-08,.2813430E-08,.3115255E-08,.3108868E-08,.3368799E-08,& + & .1974147E-08,.2337742E-08,.2632663E-08,.2536104E-08,.2818301E-08,& + & .1571250E-08,.1795999E-08,.2019658E-08,.2053809E-08,.2214852E-08,& + & .1279646E-08,.1412932E-08,.1556847E-08,.1606893E-08,.1672149E-08,& + & .1031072E-08,.1097428E-08,.1196985E-08,.1290650E-08,.1288385E-08,& + & .8938603E-09,.8837689E-09,.9745065E-09,.1061662E-08,.1059312E-08,& + & .7322346E-09,.7033864E-09,.7896888E-09,.8643607E-09,.8131766E-09,& + & .5805907E-09,.5690340E-09,.6243145E-09,.6418920E-09,.6258469E-09,& + & .5029656E-09,.4690698E-09,.5424865E-09,.6080127E-09,.5841233E-09,& + & .4250789E-09,.4197107E-09,.4660663E-09,.6124726E-09,.5623562E-09,& + & .4019151E-09,.3994626E-09,.4466929E-09,.5705557E-09,.5871247E-09,& + & .3606061E-09,.4105570E-09,.4275902E-09,.5426140E-09,.6398303E-09,& + & .3779486E-09,.4060351E-09,.4385552E-09,.5030377E-09,.6537476E-09,& + & .5016060E-09,.5443259E-09,.6140966E-09,.6419200E-09,.8282210E-09/ + + data absb( 1:120, 5) / & + & .1729944E-05,.1736124E-05,.1741333E-05,.1742362E-05,.1748113E-05,& + & .1274396E-05,.1276178E-05,.1276894E-05,.1273619E-05,.1277683E-05,& + & .7962882E-06,.7847962E-06,.7761880E-06,.7674539E-06,.7644962E-06,& + & .4154425E-06,.4161228E-06,.4168582E-06,.4153229E-06,.4178350E-06,& + & .1529712E-06,.1587454E-06,.1627009E-06,.1686135E-06,.1698471E-06,& + & .5915086E-07,.5907368E-07,.5815373E-07,.5755800E-07,.5672556E-07,& + & .5797453E-07,.5829676E-07,.5862911E-07,.5886891E-07,.5612632E-07,& + & .5902708E-07,.5607408E-07,.5455860E-07,.5499325E-07,.5710234E-07,& + & .5283276E-07,.5163077E-07,.5070747E-07,.5268528E-07,.5249233E-07,& + & .4705563E-07,.5073384E-07,.5033114E-07,.5234450E-07,.5415567E-07,& + & .4780445E-07,.4964787E-07,.5059932E-07,.4884527E-07,.5386605E-07,& + & .4658544E-07,.4857945E-07,.4939821E-07,.4877906E-07,.5115413E-07,& + & .4761843E-07,.4933275E-07,.5350810E-07,.4890684E-07,.5018725E-07,& + & .4263688E-07,.5007044E-07,.5014879E-07,.4749372E-07,.4465415E-07,& + & .4455329E-07,.4855181E-07,.4368603E-07,.4298662E-07,.4551816E-07,& + & .4053097E-07,.4563140E-07,.3772562E-07,.4071168E-07,.4236715E-07,& + & .3588889E-07,.3889871E-07,.3518841E-07,.3620149E-07,.3217659E-07,& + & .3083266E-07,.2840331E-07,.3135215E-07,.3222827E-07,.3059802E-07,& + & .2609754E-07,.2597536E-07,.2416454E-07,.2407412E-07,.2851713E-07,& + & .1942653E-07,.2176047E-07,.1994188E-07,.2100237E-07,.2564799E-07,& + & .1872337E-07,.1873896E-07,.1659557E-07,.1939157E-07,.1979997E-07,& + & .1520850E-07,.1331818E-07,.1631543E-07,.1634361E-07,.1553305E-07,& + & .1209783E-07,.1336203E-07,.1561210E-07,.1467477E-07,.1431486E-07,& + & .1182141E-07,.1046697E-07,.1289913E-07,.1276273E-07,.1359344E-07/ + + data absb(121:235, 5) / & + & .1184794E-07,.1311106E-07,.1238478E-07,.1217861E-07,.1239514E-07,& + & .9765005E-08,.1222800E-07,.1250535E-07,.1265256E-07,.1275629E-07,& + & .8730087E-08,.1006998E-07,.1108201E-07,.1107370E-07,.1128404E-07,& + & .7184544E-08,.8280430E-08,.9337916E-08,.1097275E-07,.9422199E-08,& + & .7139569E-08,.8403293E-08,.8805228E-08,.8723704E-08,.8768754E-08,& + & .5638776E-08,.6617168E-08,.8131084E-08,.7952481E-08,.7843380E-08,& + & .4925723E-08,.6108668E-08,.6899038E-08,.7204770E-08,.7687590E-08,& + & .4080853E-08,.4506541E-08,.5062322E-08,.5570520E-08,.6245092E-08,& + & .3631086E-08,.3803154E-08,.4237952E-08,.4459341E-08,.4641922E-08,& + & .2798333E-08,.3196813E-08,.3468125E-08,.3333398E-08,.3634127E-08,& + & .2078749E-08,.2197782E-08,.2749626E-08,.2961556E-08,.2737758E-08,& + & .1606200E-08,.1840574E-08,.2290696E-08,.2323292E-08,.2090580E-08,& + & .1242108E-08,.1231152E-08,.1604400E-08,.1622018E-08,.1621244E-08,& + & .1142268E-08,.1161378E-08,.1312609E-08,.1332037E-08,.1336670E-08,& + & .7937740E-09,.9156464E-09,.9774718E-09,.1301830E-08,.1022826E-08,& + & .6792043E-09,.5672534E-09,.8065168E-09,.9174893E-09,.8812439E-09,& + & .4994562E-09,.4116159E-09,.6437120E-09,.8032581E-09,.6371815E-09,& + & .3965500E-09,.4502722E-09,.5469149E-09,.6195100E-09,.6194173E-09,& + & .4642266E-09,.4594787E-09,.4914294E-09,.5762278E-09,.7042388E-09,& + & .3468720E-09,.4302644E-09,.4377266E-09,.5298753E-09,.6737359E-09,& + & .4090614E-09,.3868913E-09,.4712038E-09,.5590598E-09,.5935130E-09,& + & .3717901E-09,.5393381E-09,.5139211E-09,.5362056E-09,.6355660E-09,& + & .5106858E-09,.5935961E-09,.6679782E-09,.7444804E-09,.8364933E-09/ + + data absb( 1:120, 6) / & + & .2395686E-04,.2404438E-04,.2411693E-04,.2423607E-04,.2436738E-04,& + & .2056849E-04,.2065059E-04,.2074045E-04,.2087079E-04,.2099978E-04,& + & .1768295E-04,.1777975E-04,.1792091E-04,.1803977E-04,.1817680E-04,& + & .1516668E-04,.1531217E-04,.1547416E-04,.1561878E-04,.1578350E-04,& + & .1290092E-04,.1310023E-04,.1328029E-04,.1346289E-04,.1365293E-04,& + & .1024835E-04,.1050381E-04,.1075123E-04,.1101880E-04,.1126531E-04,& + & .7489506E-05,.7760773E-05,.8019168E-05,.8297504E-05,.8573388E-05,& + & .5464496E-05,.5734262E-05,.6016157E-05,.6302015E-05,.6577927E-05,& + & .3936259E-05,.4224419E-05,.4513834E-05,.4789178E-05,.5070700E-05,& + & .2805984E-05,.3072729E-05,.3338950E-05,.3623166E-05,.3891777E-05,& + & .1900823E-05,.2167276E-05,.2408743E-05,.2685381E-05,.2917449E-05,& + & .1174025E-05,.1409556E-05,.1643976E-05,.1906921E-05,.2111832E-05,& + & .6636735E-06,.8537937E-06,.1064189E-05,.1305203E-05,.1520120E-05,& + & .3317132E-06,.4631507E-06,.6718687E-06,.8755380E-06,.1099835E-05,& + & .1412547E-06,.2795370E-06,.4605960E-06,.6358157E-06,.8299133E-06,& + & .5886507E-07,.1686485E-06,.3427727E-06,.5009229E-06,.7048885E-06,& + & .5375997E-07,.1921376E-06,.3466112E-06,.4979867E-06,.7234630E-06,& + & .9833696E-07,.2424778E-06,.3777826E-06,.5767946E-06,.7689130E-06,& + & .1780398E-06,.3286727E-06,.5106210E-06,.7063377E-06,.9191132E-06,& + & .2791479E-06,.4463444E-06,.6419014E-06,.8393519E-06,.1186341E-05,& + & .3815600E-06,.5566532E-06,.7712321E-06,.1041457E-05,.1452473E-05,& + & .4683750E-06,.6571130E-06,.8750377E-06,.1244250E-05,.1672199E-05,& + & .5302781E-06,.7255338E-06,.9960660E-06,.1375837E-05,.1817809E-05,& + & .5718819E-06,.7824923E-06,.1082650E-05,.1463943E-05,.1914798E-05/ + + data absb(121:235, 6) / & + & .5779563E-06,.7793008E-06,.1089554E-05,.1465980E-05,.1912492E-05,& + & .6012058E-06,.8101817E-06,.1114671E-05,.1481773E-05,.1917882E-05,& + & .6359830E-06,.8577926E-06,.1156572E-05,.1515261E-05,.1953664E-05,& + & .6218324E-06,.8312575E-06,.1120830E-05,.1466837E-05,.1889580E-05,& + & .6020577E-06,.7988481E-06,.1076839E-05,.1420463E-05,.1818710E-05,& + & .5888633E-06,.7776144E-06,.1041644E-05,.1370194E-05,.1754483E-05,& + & .5631597E-06,.7415089E-06,.9956498E-06,.1305861E-05,.1669685E-05,& + & .5356640E-06,.7073841E-06,.9466091E-06,.1238098E-05,.1585048E-05,& + & .5104786E-06,.6741957E-06,.8973165E-06,.1175203E-05,.1505003E-05,& + & .4827379E-06,.6379585E-06,.8434834E-06,.1105762E-05,.1414222E-05,& + & .4471224E-06,.5931371E-06,.7785484E-06,.1020135E-05,.1311082E-05,& + & .4093237E-06,.5500658E-06,.7202141E-06,.9432841E-06,.1215064E-05,& + & .3743207E-06,.5084612E-06,.6692669E-06,.8748475E-06,.1125655E-05,& + & .3375380E-06,.4645308E-06,.6183099E-06,.8066744E-06,.1040697E-05,& + & .3011207E-06,.4225809E-06,.5687082E-06,.7426667E-06,.9612401E-06,& + & .2668279E-06,.3832441E-06,.5209688E-06,.6850474E-06,.8874070E-06,& + & .2381612E-06,.3456426E-06,.4754255E-06,.6316630E-06,.8198579E-06,& + & .2073586E-06,.3073931E-06,.4304397E-06,.5791758E-06,.7545941E-06,& + & .1768447E-06,.2704831E-06,.3869748E-06,.5275204E-06,.6934370E-06,& + & .1503327E-06,.2353970E-06,.3469204E-06,.4790892E-06,.6362293E-06,& + & .1255561E-06,.2028854E-06,.3081471E-06,.4327060E-06,.5822767E-06,& + & .1038629E-06,.1726647E-06,.2718683E-06,.3906697E-06,.5319483E-06,& + & .8678777E-07,.1522598E-06,.2477843E-06,.3639270E-06,.4979000E-06/ + + data absb( 1:120, 7) / & + & .3453565E-03,.3534617E-03,.3619531E-03,.3711305E-03,.3812639E-03,& + & .3141656E-03,.3221962E-03,.3311595E-03,.3411912E-03,.3521288E-03,& + & .2869233E-03,.2952510E-03,.3048137E-03,.3155602E-03,.3272615E-03,& + & .2633665E-03,.2725298E-03,.2826467E-03,.2940184E-03,.3062037E-03,& + & .2432615E-03,.2533698E-03,.2641385E-03,.2758932E-03,.2885698E-03,& + & .2263129E-03,.2373054E-03,.2487516E-03,.2608205E-03,.2739867E-03,& + & .2120588E-03,.2239554E-03,.2359421E-03,.2484613E-03,.2621061E-03,& + & .2005107E-03,.2131852E-03,.2256599E-03,.2387045E-03,.2528263E-03,& + & .1911925E-03,.2045282E-03,.2175666E-03,.2310156E-03,.2455442E-03,& + & .1846431E-03,.1985047E-03,.2120615E-03,.2260435E-03,.2409818E-03,& + & .1798623E-03,.1940866E-03,.2081664E-03,.2226065E-03,.2379772E-03,& + & .1766175E-03,.1912018E-03,.2057461E-03,.2205236E-03,.2363363E-03,& + & .1746678E-03,.1895715E-03,.2044754E-03,.2196431E-03,.2358377E-03,& + & .1739647E-03,.1892010E-03,.2043935E-03,.2199752E-03,.2365860E-03,& + & .1742702E-03,.1897414E-03,.2051758E-03,.2211667E-03,.2381552E-03,& + & .1753432E-03,.1911018E-03,.2067274E-03,.2230734E-03,.2404076E-03,& + & .1772791E-03,.1932058E-03,.2090684E-03,.2257815E-03,.2433940E-03,& + & .1798122E-03,.1958563E-03,.2119375E-03,.2289267E-03,.2468559E-03,& + & .1828739E-03,.1989598E-03,.2152598E-03,.2325938E-03,.2507241E-03,& + & .1862774E-03,.2023367E-03,.2189782E-03,.2365487E-03,.2548744E-03,& + & .1898946E-03,.2060048E-03,.2229518E-03,.2407447E-03,.2592115E-03,& + & .1930147E-03,.2092865E-03,.2264529E-03,.2444439E-03,.2630292E-03,& + & .1947320E-03,.2110719E-03,.2284152E-03,.2464695E-03,.2651495E-03,& + & .1947235E-03,.2111115E-03,.2284595E-03,.2465787E-03,.2652695E-03/ + + data absb(121:235, 7) / & + & .1923135E-03,.2086721E-03,.2258790E-03,.2439421E-03,.2625178E-03,& + & .1898304E-03,.2061203E-03,.2232301E-03,.2411648E-03,.2597217E-03,& + & .1873764E-03,.2036289E-03,.2206075E-03,.2384662E-03,.2569599E-03,& + & .1832260E-03,.1995592E-03,.2162785E-03,.2339279E-03,.2523120E-03,& + & .1788996E-03,.1952895E-03,.2118287E-03,.2292618E-03,.2475232E-03,& + & .1745665E-03,.1910561E-03,.2074156E-03,.2246436E-03,.2426726E-03,& + & .1693616E-03,.1858699E-03,.2021660E-03,.2190895E-03,.2369106E-03,& + & .1636984E-03,.1802123E-03,.1965993E-03,.2131937E-03,.2307370E-03,& + & .1579848E-03,.1745716E-03,.1910412E-03,.2074387E-03,.2246686E-03,& + & .1517765E-03,.1686193E-03,.1851339E-03,.2014696E-03,.2183450E-03,& + & .1446931E-03,.1619128E-03,.1784332E-03,.1948757E-03,.2113871E-03,& + & .1374469E-03,.1550648E-03,.1717760E-03,.1882836E-03,.2046026E-03,& + & .1301193E-03,.1480729E-03,.1651093E-03,.1816194E-03,.1979742E-03,& + & .1232387E-03,.1413641E-03,.1587786E-03,.1753667E-03,.1918502E-03,& + & .1165074E-03,.1347306E-03,.1525223E-03,.1693426E-03,.1858642E-03,& + & .1098514E-03,.1281199E-03,.1461473E-03,.1632796E-03,.1797964E-03,& + & .1032338E-03,.1214316E-03,.1396126E-03,.1571081E-03,.1737446E-03,& + & .9707472E-04,.1152633E-03,.1335133E-03,.1513622E-03,.1682314E-03,& + & .9122100E-04,.1094451E-03,.1276962E-03,.1457224E-03,.1629077E-03,& + & .8538680E-04,.1036587E-03,.1218392E-03,.1400148E-03,.1575026E-03,& + & .7959199E-04,.9778645E-04,.1159632E-03,.1342022E-03,.1520145E-03,& + & .7417050E-04,.9223069E-04,.1104637E-03,.1287103E-03,.1467060E-03,& + & .7201794E-04,.9003123E-04,.1082584E-03,.1264928E-03,.1445780E-03/ + + data absb( 1:120, 8) / & + & .8358600E-02,.8311878E-02,.8262807E-02,.8209212E-02,.8148456E-02,& + & .8611422E-02,.8564644E-02,.8512562E-02,.8452401E-02,.8387225E-02,& + & .8829188E-02,.8780796E-02,.8724483E-02,.8660460E-02,.8590523E-02,& + & .9017237E-02,.8963386E-02,.8903457E-02,.8835037E-02,.8761588E-02,& + & .9177720E-02,.9117835E-02,.9052597E-02,.8982454E-02,.8905848E-02,& + & .9312725E-02,.9247622E-02,.9178554E-02,.9105643E-02,.9025534E-02,& + & .9426857E-02,.9355560E-02,.9283636E-02,.9207311E-02,.9124846E-02,& + & .9520420E-02,.9444026E-02,.9368533E-02,.9289838E-02,.9203532E-02,& + & .9596404E-02,.9516161E-02,.9437583E-02,.9356012E-02,.9267042E-02,& + & .9652643E-02,.9569500E-02,.9487039E-02,.9401969E-02,.9310716E-02,& + & .9695422E-02,.9609692E-02,.9524686E-02,.9435966E-02,.9342924E-02,& + & .9727439E-02,.9637865E-02,.9550739E-02,.9460899E-02,.9364315E-02,& + & .9747348E-02,.9657887E-02,.9567816E-02,.9475420E-02,.9377002E-02,& + & .9759778E-02,.9668908E-02,.9576933E-02,.9481742E-02,.9380067E-02,& + & .9764468E-02,.9671597E-02,.9578772E-02,.9481823E-02,.9378210E-02,& + & .9763831E-02,.9670378E-02,.9575566E-02,.9476824E-02,.9370080E-02,& + & .9759671E-02,.9663673E-02,.9567437E-02,.9466585E-02,.9358136E-02,& + & .9749029E-02,.9653783E-02,.9555706E-02,.9452450E-02,.9342273E-02,& + & .9736435E-02,.9639659E-02,.9540533E-02,.9435413E-02,.9323567E-02,& + & .9720078E-02,.9623847E-02,.9522512E-02,.9415460E-02,.9302259E-02,& + & .9703088E-02,.9605298E-02,.9501404E-02,.9392140E-02,.9278916E-02,& + & .9686283E-02,.9587583E-02,.9483967E-02,.9371995E-02,.9257294E-02,& + & .9678111E-02,.9578966E-02,.9473567E-02,.9361585E-02,.9246698E-02,& + & .9679790E-02,.9580995E-02,.9474493E-02,.9363423E-02,.9247588E-02/ + + data absb(121:235, 8) / & + & .9697036E-02,.9597631E-02,.9491980E-02,.9381268E-02,.9266303E-02,& + & .9712567E-02,.9614449E-02,.9509960E-02,.9399294E-02,.9284125E-02,& + & .9728855E-02,.9630143E-02,.9527100E-02,.9417372E-02,.9302616E-02,& + & .9755136E-02,.9656175E-02,.9554532E-02,.9445454E-02,.9332069E-02,& + & .9781450E-02,.9682450E-02,.9581889E-02,.9475267E-02,.9362746E-02,& + & .9808399E-02,.9708959E-02,.9609987E-02,.9504452E-02,.9392809E-02,& + & .9839580E-02,.9740865E-02,.9642287E-02,.9538676E-02,.9428802E-02,& + & .9874370E-02,.9776400E-02,.9676193E-02,.9575430E-02,.9467798E-02,& + & .9908878E-02,.9809623E-02,.9710657E-02,.9611071E-02,.9505151E-02,& + & .9946962E-02,.9845757E-02,.9746231E-02,.9647315E-02,.9544139E-02,& + & .9988261E-02,.9885906E-02,.9786939E-02,.9687236E-02,.9586655E-02,& + & .1003101E-01,.9927336E-02,.9827361E-02,.9728363E-02,.9628271E-02,& + & .1007558E-01,.9968398E-02,.9867081E-02,.9768397E-02,.9669498E-02,& + & .1011578E-01,.1000878E-01,.9905269E-02,.9805950E-02,.9706828E-02,& + & .1015569E-01,.1004819E-01,.9942285E-02,.9841944E-02,.9742563E-02,& + & .1019452E-01,.1008719E-01,.9980576E-02,.9878353E-02,.9779624E-02,& + & .1023378E-01,.1012695E-01,.1001916E-01,.9915168E-02,.9815063E-02,& + & .1026952E-01,.1016297E-01,.1005517E-01,.9949717E-02,.9848721E-02,& + & .1030346E-01,.1019748E-01,.1008930E-01,.9983003E-02,.9880655E-02,& + & .1033774E-01,.1023094E-01,.1012441E-01,.1001809E-01,.9912916E-02,& + & .1037133E-01,.1026548E-01,.1015955E-01,.1005208E-01,.9945433E-02,& + & .1040238E-01,.1029750E-01,.1019014E-01,.1008328E-01,.9977541E-02,& + & .1041506E-01,.1031116E-01,.1020458E-01,.1009725E-01,.9990140E-02/ + +! --- + data forref(1:3,1: 8) / & + & .1889348E-07,.2790121E-06,.2442243E-05,.3917008E-06,.7957867E-06,& + & .1584630E-05,.1690886E-05,.1737327E-05,.5814421E-06,.4276674E-05,& + & .3754692E-05,.3297487E-06,.4845389E-05,.3046027E-05,.8469466E-06,& + & .5624835E-05,.1676442E-05,.3856211E-07,.3141158E-05,.1459015E-07,& + & .2568816E-07,.8749816E-12,.8199214E-12,.8132942E-12/ + + + data selfref(1:10,1: 8) / & + & .1216369E-04,.7423490E-05,.4532882E-05,.2769295E-05,.1692770E-05,& + & .1035295E-05,.6335399E-06,.3879104E-06,.2376510E-06,.1456812E-06,& + & .1738951E-04,.1350041E-04,.1061362E-04,.8452065E-05,.6817644E-05,& + & .5568311E-05,.4602063E-05,.3845424E-05,.3245295E-05,.2763136E-05,& + & .2573945E-04,.2373710E-04,.2191428E-04,.2025397E-04,.1874100E-04,& + & .1736167E-04,.1610330E-04,.1495474E-04,.1390567E-04,.1294697E-04,& + & .5188697E-04,.4899932E-04,.4628324E-04,.4372800E-04,.4132363E-04,& + & .3906076E-04,.3693055E-04,.3492493E-04,.3303618E-04,.3125709E-04,& + & .3645284E-04,.3672976E-04,.3702492E-04,.3733989E-04,.3767626E-04,& + & .3803589E-04,.3842086E-04,.3883327E-04,.3927557E-04,.3975032E-04,& + & .1526953E-04,.1771468E-04,.2057485E-04,.2392454E-04,.2785266E-04,& + & .3246491E-04,.3788738E-04,.4427053E-04,.5179416E-04,.6067315E-04,& + & .1304688E-06,.2753468E-06,.5813077E-06,.1227665E-05,.2593570E-05,& + & .5480882E-05,.1158601E-04,.2449863E-04,.5181665E-04,.1096252E-03,& + & .2493662E-06,.2172185E-06,.1892149E-06,.1648213E-06,.1435736E-06,& + & .1250641E-06,.1089414E-06,.9489759E-07,.8266404E-07,.7200766E-07/ + +!........................................! + end module module_radsw_kgb24 ! +!========================================! + + +!> This module sets up absorption coeffients for band 25: 16000-22650 +!! cm-1 (low - h2o; high - nothing) +!========================================! + module module_radsw_kgb25 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG25 + +! + implicit none +! + private +! +!> msa25=65 + integer, public :: MSA25 + parameter (MSA25=65) + +!> the array absa(65,NG25) (ka(5,13,NG25)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 6, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA25,NG25) + +!> rayleigh extinction coefficient + real (kind=kind_phys), public :: rayl(NG25) + +!> o3 + real (kind=kind_phys), public :: abso3a(NG25) + +!> o3 + real (kind=kind_phys), public :: abso3b(NG25) + + data rayl (1: 6) / .9811320E-06,& + & .8256050E-06,.6146670E-06,.3838724E-06,.4417251E-06,.3613850E-06/ + + data abso3a(1: 6) / .2326640E-01,& + & .5761540E-01,.1854021E+00,.3896100E+00,.3610619E+00,.4362158E+00/ + + data abso3b(1: 6) / .1769170E-01,& + & .4641850E-01,.1449232E+00,.3484920E+00,.4676420E+00,.5178092E+00/ + + + data absa( 1: 65, 1) / & + & .1646100E-08,.1678200E-08,.1933900E-08,.1710000E-08,.1704500E-08,& + & .2875900E-08,.2946900E-08,.3378900E-08,.3435700E-08,.2883300E-08,& + & .5514800E-08,.5480800E-08,.5419000E-08,.6826000E-08,.5197200E-08,& + & .9533600E-08,.9455200E-08,.9300100E-08,.9096100E-08,.1445100E-07,& + & .1493000E-07,.1473600E-07,.1443200E-07,.1407400E-07,.2410200E-07,& + & .2277000E-07,.2230100E-07,.2177800E-07,.2119400E-07,.2056900E-07,& + & .3469900E-07,.3395100E-07,.3312400E-07,.3214400E-07,.3122000E-07,& + & .6233900E-07,.6040500E-07,.5954800E-07,.5821400E-07,.5697700E-07,& + & .1741100E-06,.1765400E-06,.1831500E-06,.1810000E-06,.1783900E-06,& + & .2352600E-06,.2272900E-06,.2194700E-06,.2118800E-06,.2045400E-06,& + & .2353500E-06,.2273700E-06,.2195600E-06,.2119600E-06,.2046100E-06,& + & .2353900E-06,.2274000E-06,.2195900E-06,.2119900E-06,.2046500E-06,& + & .2354300E-06,.2274400E-06,.2196200E-06,.2120200E-06,.2046700E-06/ + + data absa( 1: 65, 2) / & + & .6291200E-08,.6155900E-08,.8464000E-08,.5924000E-08,.5821700E-08,& + & .8374900E-08,.8075600E-08,.1162300E-07,.1127200E-07,.7363600E-08,& + & .1330400E-07,.1279500E-07,.1234300E-07,.2123500E-07,.1157700E-07,& + & .2070400E-07,.1973600E-07,.1890000E-07,.1822800E-07,.3160100E-07,& + & .3114900E-07,.2966900E-07,.2831800E-07,.2710100E-07,.4964900E-07,& + & .4571300E-07,.4351900E-07,.4148800E-07,.3991800E-07,.3829100E-07,& + & .7726500E-07,.7384800E-07,.7043700E-07,.6794500E-07,.6612700E-07,& + & .1575400E-06,.1566400E-06,.1537800E-06,.1502700E-06,.1463300E-06,& + & .1643900E-06,.1467800E-06,.1261000E-06,.1153200E-06,.1059100E-06,& + & .1436600E-06,.1350600E-06,.1258300E-06,.1177400E-06,.1101100E-06,& + & .1452100E-06,.1376600E-06,.1307200E-06,.1221800E-06,.1140000E-06,& + & .1452400E-06,.1376900E-06,.1307400E-06,.1224100E-06,.1155200E-06,& + & .1452500E-06,.1377000E-06,.1307500E-06,.1225200E-06,.1155300E-06/ + + data absa( 1: 65, 3) / & + & .2304255E-07,.2212848E-07,.4109493E-07,.2019160E-07,.1941596E-07,& + & .2701108E-07,.2633924E-07,.5665284E-07,.5516586E-07,.2490900E-07,& + & .4992253E-07,.4901988E-07,.4802034E-07,.7658263E-07,.4679826E-07,& + & .9936387E-07,.9737083E-07,.9572112E-07,.9398584E-07,.1435192E-06,& + & .1737489E-06,.1690329E-06,.1649946E-06,.1608759E-06,.2616677E-06,& + & .2850168E-06,.2771528E-06,.2703079E-06,.2636367E-06,.2572958E-06,& + & .4363192E-06,.4270658E-06,.4142017E-06,.4031191E-06,.3921783E-06,& + & .6694834E-06,.6560782E-06,.6423565E-06,.6305881E-06,.6197580E-06,& + & .1127398E-05,.1109264E-05,.1096811E-05,.1079010E-05,.1060076E-05,& + & .1142385E-05,.1123159E-05,.1103836E-05,.1083587E-05,.1063058E-05,& + & .1141922E-05,.1122126E-05,.1101516E-05,.1081516E-05,.1061329E-05,& + & .1142101E-05,.1122316E-05,.1101648E-05,.1081539E-05,.1060666E-05,& + & .1142284E-05,.1122439E-05,.1101810E-05,.1081628E-05,.1060802E-05/ + + data absa( 1: 65, 4) / & + & .5358826E-07,.5191800E-07,.1241794E-06,.4941069E-07,.4826537E-07,& + & .6634855E-07,.6497957E-07,.1011451E-06,.9587780E-07,.6034307E-07,& + & .1109051E-06,.1079549E-06,.1052181E-06,.1673772E-06,.9938209E-07,& + & .1837864E-06,.1778823E-06,.1716021E-06,.1661914E-06,.2696765E-06,& + & .2944786E-06,.2858136E-06,.2767250E-06,.2693989E-06,.4648876E-06,& + & .4455888E-06,.4336889E-06,.4201096E-06,.4076205E-06,.3956245E-06,& + & .6742110E-06,.6611647E-06,.6510830E-06,.6399340E-06,.6276101E-06,& + & .8969775E-06,.8864724E-06,.8790142E-06,.8698967E-06,.8588636E-06,& + & .7342734E-06,.7160851E-06,.6891067E-06,.6701000E-06,.6510138E-06,& + & .7386682E-06,.7215150E-06,.7046031E-06,.6851616E-06,.6677641E-06,& + & .7580174E-06,.7411749E-06,.7247261E-06,.7009916E-06,.6816196E-06,& + & .7649827E-06,.7506295E-06,.7339233E-06,.7090960E-06,.6870193E-06,& + & .7676832E-06,.7529800E-06,.7370035E-06,.7118011E-06,.6888372E-06/ + + data absa( 1: 65, 5) / & + & .7117654E-05,.7054566E-05,.8530292E-05,.6912687E-05,.6834460E-05,& + & .6579625E-05,.6521231E-05,.8074960E-05,.7892008E-05,.6316120E-05,& + & .5972427E-05,.5925015E-05,.5871889E-05,.7336016E-05,.5749214E-05,& + & .5324376E-05,.5290991E-05,.5251560E-05,.5205073E-05,.6531106E-05,& + & .4622548E-05,.4605694E-05,.4579758E-05,.4546281E-05,.5745046E-05,& + & .3863569E-05,.3864350E-05,.3857382E-05,.3842378E-05,.3819669E-05,& + & .3076464E-05,.3091729E-05,.3102707E-05,.3099905E-05,.3090770E-05,& + & .2816484E-05,.2825815E-05,.2821070E-05,.2804759E-05,.2789727E-05,& + & .6454490E-05,.6508164E-05,.6551126E-05,.6559912E-05,.6545487E-05,& + & .1257978E-04,.1269684E-04,.1274689E-04,.1276159E-04,.1276158E-04,& + & .1419438E-04,.1414710E-04,.1407662E-04,.1400149E-04,.1389726E-04,& + & .1419357E-04,.1414993E-04,.1408845E-04,.1402116E-04,.1393645E-04,& + & .1419415E-04,.1414965E-04,.1408763E-04,.1402335E-04,.1394694E-04/ + + data absa( 1: 65, 6) / & + & .1587872E-03,.1576306E-03,.1591069E-03,.1553587E-03,.1542553E-03,& + & .1690035E-03,.1677837E-03,.1693876E-03,.1678861E-03,.1641727E-03,& + & .1796181E-03,.1782899E-03,.1769631E-03,.1785679E-03,.1743591E-03,& + & .1896678E-03,.1882560E-03,.1868296E-03,.1854223E-03,.1871320E-03,& + & .1991122E-03,.1976085E-03,.1961276E-03,.1946438E-03,.1968553E-03,& + & .2076995E-03,.2061273E-03,.2045536E-03,.2029803E-03,.2014317E-03,& + & .2138594E-03,.2121941E-03,.2104844E-03,.2088605E-03,.2072504E-03,& + & .2079296E-03,.2064979E-03,.2051095E-03,.2037779E-03,.2023372E-03,& + & .1359973E-03,.1343382E-03,.1327011E-03,.1314602E-03,.1305188E-03,& + & .2924225E-04,.2660282E-04,.2493377E-04,.2376549E-04,.2266769E-04,& + & .7730806E-06,.9895626E-06,.1411477E-05,.1894061E-05,.2654902E-05,& + & .6900584E-06,.7953827E-06,.1063045E-05,.1425467E-05,.1894041E-05,& + & .6604518E-06,.7863470E-06,.1049399E-05,.1366331E-05,.1711475E-05/ + +!........................................! + end module module_radsw_kgb25 ! +!========================================! + + +!> This module sets up absorption coeffients for band 26: 22650-29000 +!! cm-1 (low - nothing; high - nothing) +!========================================! + module module_radsw_kgb26 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG26 + +! + implicit none +! + private +! +!> rayleigh extinction coefficient at all v + real (kind=kind_phys), public :: rayl(NG26) + + data rayl (1: 6) / .1212630E-05,& + & .1434280E-05,.1799798E-05,.2307617E-05,.2814376E-05,.3092339E-05/ + +!........................................! + end module module_radsw_kgb26 ! +!========================================! + + +!> This module sets up absorption coeffients for band 27: 29000-38000 +!! cm-1 (low - o3; high - o3) +!========================================! + module module_radsw_kgb27 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG27 + +! + implicit none +! + private +! +!> msa27=65 + integer, public :: MSA27 +!> msb27=235 + integer, public :: MSB27 + parameter (MSA27=65, MSB27=235) + + +!> the array absa(65,NG27) (ka(5,13,NG27)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 8, and indicates +!! which g-interval the absorption coefficients are for. + real(kind=kind_phys), public :: absa(MSA27,NG27) + +!> the array absb(235,8) (kb(5,13:59,8)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 8, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB27,NG27) + +!> rayleigh extinction coefficient + real (kind=kind_phys), public :: rayl(NG27) + +! --- rayleigh extinction coefficient at v = cm-1. + data rayl (1: 8) / .3445340E-05,.4144800E-05,.4950690E-05,& + & .5812040E-05,.6697480E-05,.7564880E-05,.8886761E-05,.9744758E-05/ + + data absa( 1: 65, 1) / & + & .2290700E+00,.2562500E+00,.2877900E+00,.3237600E+00,.3642600E+00,& + & .2191300E+00,.2444500E+00,.2742200E+00,.3083200E+00,.3469400E+00,& + & .2060200E+00,.2286400E+00,.2557400E+00,.2872100E+00,.3231000E+00,& + & .1937900E+00,.2135200E+00,.2377100E+00,.2664300E+00,.2994000E+00,& + & .1836900E+00,.2006100E+00,.2220000E+00,.2478600E+00,.2781600E+00,& + & .1751700E+00,.1892000E+00,.2077100E+00,.2306900E+00,.2581700E+00,& + & .1688800E+00,.1798800E+00,.1955900E+00,.2157700E+00,.2404200E+00,& + & .1644200E+00,.1727300E+00,.1856500E+00,.2031500E+00,.2251200E+00,& + & .1615900E+00,.1673800E+00,.1775200E+00,.1924200E+00,.2117900E+00,& + & .1603700E+00,.1640200E+00,.1720400E+00,.1846300E+00,.2018300E+00,& + & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00,& + & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00,& + & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00/ + + data absa( 1: 65, 2) / & + & .2071600E+01,.2192500E+01,.2332700E+01,.2492100E+01,.2672600E+01,& + & .2027200E+01,.2140100E+01,.2272300E+01,.2423800E+01,.2595000E+01,& + & .1968400E+01,.2069700E+01,.2190200E+01,.2330100E+01,.2489200E+01,& + & .1913300E+01,.2002100E+01,.2110100E+01,.2237500E+01,.2384200E+01,& + & .1867300E+01,.1944100E+01,.2040000E+01,.2155300E+01,.2289800E+01,& + & .1827700E+01,.1892500E+01,.1976000E+01,.2078800E+01,.2200900E+01,& + & .1796300E+01,.1849700E+01,.1921400E+01,.2012100E+01,.2122200E+01,& + & .1774900E+01,.1815600E+01,.1876300E+01,.1955500E+01,.2054000E+01,& + & .1760000E+01,.1788500E+01,.1838800E+01,.1907100E+01,.1994300E+01,& + & .1752600E+01,.1772900E+01,.1812100E+01,.1871600E+01,.1949600E+01,& + & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01,& + & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01,& + & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01/ + + data absa( 1: 65, 3) / & + & .1218900E+02,.1261900E+02,.1311000E+02,.1366300E+02,.1427500E+02,& + & .1203000E+02,.1243400E+02,.1289900E+02,.1342700E+02,.1401500E+02,& + & .1181600E+02,.1218300E+02,.1261100E+02,.1310100E+02,.1365300E+02,& + & .1161100E+02,.1193800E+02,.1232700E+02,.1277700E+02,.1328900E+02,& + & .1143700E+02,.1172600E+02,.1207600E+02,.1248800E+02,.1296100E+02,& + & .1128400E+02,.1153300E+02,.1184300E+02,.1221500E+02,.1264900E+02,& + & .1116000E+02,.1137000E+02,.1164100E+02,.1197500E+02,.1237000E+02,& + & .1106300E+02,.1123700E+02,.1147100E+02,.1176800E+02,.1212600E+02,& + & .1099000E+02,.1112900E+02,.1132700E+02,.1158800E+02,.1191000E+02,& + & .1094500E+02,.1105300E+02,.1122300E+02,.1145400E+02,.1174600E+02,& + & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02,& + & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02,& + & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02/ + + data absa( 1: 65, 4) / & + & .5505700E+02,.5614300E+02,.5736400E+02,.5871900E+02,.6020800E+02,& + & .5464700E+02,.5567700E+02,.5684200E+02,.5814200E+02,.5957500E+02,& + & .5409000E+02,.5503900E+02,.5612300E+02,.5734200E+02,.5869400E+02,& + & .5354800E+02,.5441000E+02,.5540800E+02,.5653900E+02,.5780500E+02,& + & .5307400E+02,.5385300E+02,.5476600E+02,.5581300E+02,.5699500E+02,& + & .5264400E+02,.5333600E+02,.5416200E+02,.5512300E+02,.5621800E+02,& + & .5227900E+02,.5288700E+02,.5362900E+02,.5450500E+02,.5551600E+02,& + & .5197900E+02,.5250700E+02,.5316800E+02,.5396500E+02,.5489500E+02,& + & .5173400E+02,.5218300E+02,.5276700E+02,.5348500E+02,.5433700E+02,& + & .5156500E+02,.5194800E+02,.5246700E+02,.5312000E+02,.5390700E+02,& + & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02,& + & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02,& + & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02/ + + data absa( 1: 65, 5) / & + & .1779400E+03,.1797300E+03,.1816400E+03,.1836600E+03,.1858100E+03,& + & .1772400E+03,.1789800E+03,.1808300E+03,.1828100E+03,.1849100E+03,& + & .1762400E+03,.1779100E+03,.1797000E+03,.1816000E+03,.1836300E+03,& + & .1752300E+03,.1768200E+03,.1785300E+03,.1803600E+03,.1823100E+03,& + & .1742900E+03,.1758100E+03,.1774400E+03,.1792000E+03,.1810700E+03,& + & .1733800E+03,.1748200E+03,.1763800E+03,.1780500E+03,.1798500E+03,& + & .1725300E+03,.1739000E+03,.1753900E+03,.1769900E+03,.1787100E+03,& + & .1717700E+03,.1730700E+03,.1744800E+03,.1760100E+03,.1776700E+03,& + & .1710700E+03,.1723000E+03,.1736400E+03,.1751100E+03,.1766900E+03,& + & .1705200E+03,.1716900E+03,.1729800E+03,.1743800E+03,.1759100E+03,& + & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03,& + & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03,& + & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03/ + + data absa( 1: 65, 6) / & + & .3768000E+05,.3680100E+05,.3601100E+05,.3529800E+05,.3471500E+05,& + & .3928600E+03,.3946300E+03,.3961600E+03,.3974800E+03,.3985800E+03,& + & .3916900E+03,.3935900E+03,.3952600E+03,.3967100E+03,.3979400E+03,& + & .3903400E+03,.3923900E+03,.3942100E+03,.3958000E+03,.3971700E+03,& + & .3889500E+03,.3911300E+03,.3930900E+03,.3948300E+03,.3963400E+03,& + & .3874200E+03,.3897500E+03,.3918500E+03,.3937300E+03,.3953900E+03,& + & .3858500E+03,.3883200E+03,.3905600E+03,.3925800E+03,.3943800E+03,& + & .3842600E+03,.3868600E+03,.3892400E+03,.3914000E+03,.3933300E+03,& + & .3826400E+03,.3853800E+03,.3878900E+03,.3901700E+03,.3922300E+03,& + & .3812300E+03,.3840800E+03,.3867000E+03,.3890900E+03,.3912600E+03,& + & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03,& + & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03,& + & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03/ + + data absa( 1: 65, 7) / & + & .5138014E+07,.5012023E+07,.4897696E+07,.4788104E+07,.4690601E+07,& + & .7716789E+03,.7727576E+03,.7738234E+03,.7748824E+03,.7760097E+03,& + & .7709970E+03,.7720920E+03,.7731683E+03,.7742329E+03,.7752795E+03,& + & .7702703E+03,.7713814E+03,.7724638E+03,.7735352E+03,.7745939E+03,& + & .7695623E+03,.7706840E+03,.7717805E+03,.7728581E+03,.7739261E+03,& + & .7688269E+03,.7699602E+03,.7710739E+03,.7721618E+03,.7732324E+03,& + & .7681233E+03,.7692532E+03,.7703760E+03,.7714779E+03,.7725630E+03,& + & .7674388E+03,.7685763E+03,.7697000E+03,.7708216E+03,.7719092E+03,& + & .7667706E+03,.7679148E+03,.7690491E+03,.7701722E+03,.7712802E+03,& + & .7662119E+03,.7673655E+03,.7684992E+03,.7696303E+03,.7707457E+03,& + & .7662075E+03,.7673571E+03,.7684953E+03,.7696203E+03,.7707387E+03,& + & .7662135E+03,.7673563E+03,.7684924E+03,.7696200E+03,.7707387E+03,& + & .7662080E+03,.7673567E+03,.7684935E+03,.7696200E+03,.7707387E+03/ + + data absa( 1: 65, 8) / & + & .1263473E+08,.1241774E+08,.1224143E+08,.1219450E+08,.1211569E+08,& + & .1001941E+04,.1000716E+04,.9984375E+03,.9948240E+03,.9885902E+03,& + & .1002595E+04,.1001895E+04,.1000220E+04,.9973344E+03,.9934343E+03,& + & .1002661E+04,.1002592E+04,.1001621E+04,.9995163E+03,.9962347E+03,& + & .1002279E+04,.1002873E+04,.1002423E+04,.1001059E+04,.9984745E+03,& + & .1001370E+04,.1002671E+04,.1002871E+04,.1002175E+04,.1000396E+04,& + & .9999024E+03,.1002012E+04,.1002937E+04,.1002823E+04,.1001683E+04,& + & .9980806E+03,.1000892E+04,.1002512E+04,.1003003E+04,.1002533E+04,& + & .9959107E+03,.9994193E+03,.1001722E+04,.1002845E+04,.1002953E+04,& + & .9937920E+03,.9978415E+03,.1000716E+04,.1002445E+04,.1003004E+04,& + & .9937640E+03,.9978135E+03,.1000658E+04,.1002444E+04,.1003004E+04,& + & .9936612E+03,.9978143E+03,.1000698E+04,.1002407E+04,.1003004E+04,& + & .9937589E+03,.9978125E+03,.1000708E+04,.1002433E+04,.1003006E+04/ + + + data absb( 1:120, 1) / & + & .1603600E+00,.1639900E+00,.1719800E+00,.1845500E+00,.2017300E+00,& + & .1605000E+00,.1645400E+00,.1729200E+00,.1859200E+00,.2035100E+00,& + & .1607100E+00,.1651900E+00,.1740000E+00,.1875000E+00,.2055400E+00,& + & .1609800E+00,.1659300E+00,.1751700E+00,.1892100E+00,.2077200E+00,& + & .1612900E+00,.1667000E+00,.1764200E+00,.1909300E+00,.2099100E+00,& + & .1616400E+00,.1675000E+00,.1777100E+00,.1926700E+00,.2121100E+00,& + & .1620300E+00,.1683200E+00,.1790100E+00,.1944300E+00,.2143100E+00,& + & .1625500E+00,.1693400E+00,.1805900E+00,.1965300E+00,.2169400E+00,& + & .1631300E+00,.1704400E+00,.1822500E+00,.1987300E+00,.2196700E+00,& + & .1641600E+00,.1722700E+00,.1849800E+00,.2022900E+00,.2240600E+00,& + & .1653900E+00,.1743100E+00,.1879600E+00,.2061200E+00,.2287500E+00,& + & .1668400E+00,.1766600E+00,.1912500E+00,.2103200E+00,.2338500E+00,& + & .1685600E+00,.1793900E+00,.1949300E+00,.2149500E+00,.2394300E+00,& + & .1706700E+00,.1826000E+00,.1991900E+00,.2202400E+00,.2457800E+00,& + & .1730600E+00,.1861300E+00,.2037700E+00,.2258800E+00,.2524800E+00,& + & .1757000E+00,.1899400E+00,.2086500E+00,.2318400E+00,.2595200E+00,& + & .1788200E+00,.1941700E+00,.2139900E+00,.2382800E+00,.2670800E+00,& + & .1822300E+00,.1987000E+00,.2196400E+00,.2450500E+00,.2749200E+00,& + & .1860200E+00,.2036400E+00,.2257200E+00,.2522900E+00,.2832500E+00,& + & .1901800E+00,.2089500E+00,.2321900E+00,.2599400E+00,.2920000E+00,& + & .1946600E+00,.2146100E+00,.2390200E+00,.2679500E+00,.3011400E+00,& + & .1988000E+00,.2197600E+00,.2452000E+00,.2750900E+00,.3093200E+00,& + & .2012900E+00,.2228300E+00,.2488600E+00,.2793100E+00,.3141200E+00,& + & .2017000E+00,.2233400E+00,.2494600E+00,.2800000E+00,.3149200E+00/ + + data absb(121:235, 1) / & + & .1992000E+00,.2202600E+00,.2457900E+00,.2757800E+00,.3101000E+00,& + & .1966200E+00,.2170600E+00,.2419700E+00,.2713500E+00,.3050400E+00,& + & .1941400E+00,.2139600E+00,.2382400E+00,.2670400E+00,.3001000E+00,& + & .1900300E+00,.2087700E+00,.2319700E+00,.2596800E+00,.2917100E+00,& + & .1859700E+00,.2035700E+00,.2256400E+00,.2521900E+00,.2831400E+00,& + & .1822000E+00,.1986500E+00,.2195800E+00,.2449800E+00,.2748400E+00,& + & .1779800E+00,.1930400E+00,.2125700E+00,.2365700E+00,.2651000E+00,& + & .1739700E+00,.1874600E+00,.2054800E+00,.2279800E+00,.2549600E+00,& + & .1705300E+00,.1823900E+00,.1989000E+00,.2198900E+00,.2453500E+00,& + & .1673900E+00,.1775400E+00,.1924500E+00,.2118300E+00,.2356800E+00,& + & .1645400E+00,.1729200E+00,.1859200E+00,.2035100E+00,.2255600E+00,& + & .1623900E+00,.1690300E+00,.1801100E+00,.1959000E+00,.2161500E+00,& + & .1609500E+00,.1658400E+00,.1750400E+00,.1890200E+00,.2074700E+00,& + & .1602500E+00,.1634800E+00,.1710900E+00,.1832200E+00,.2000000E+00,& + & .1602100E+00,.1617900E+00,.1678100E+00,.1782100E+00,.1933500E+00,& + & .1607800E+00,.1606800E+00,.1651100E+00,.1738700E+00,.1873100E+00,& + & .1619700E+00,.1601800E+00,.1629900E+00,.1701700E+00,.1818600E+00,& + & .1636200E+00,.1602600E+00,.1615500E+00,.1672900E+00,.1773800E+00,& + & .1657000E+00,.1608300E+00,.1606400E+00,.1649800E+00,.1736500E+00,& + & .1682500E+00,.1618700E+00,.1602000E+00,.1631100E+00,.1704100E+00,& + & .1712900E+00,.1634000E+00,.1602300E+00,.1616900E+00,.1676100E+00,& + & .1746200E+00,.1652900E+00,.1606900E+00,.1607700E+00,.1653500E+00,& + & .1760700E+00,.1661700E+00,.1610000E+00,.1605100E+00,.1645600E+00/ + + data absb( 1:120, 2) / & + & .1752500E+01,.1772700E+01,.1811900E+01,.1871200E+01,.1949100E+01,& + & .1753600E+01,.1775500E+01,.1816500E+01,.1877500E+01,.1957100E+01,& + & .1754900E+01,.1778700E+01,.1821900E+01,.1884700E+01,.1966200E+01,& + & .1756500E+01,.1781900E+01,.1827800E+01,.1892500E+01,.1976100E+01,& + & .1758300E+01,.1785000E+01,.1833600E+01,.1900300E+01,.1985900E+01,& + & .1760300E+01,.1789100E+01,.1839600E+01,.1908200E+01,.1995700E+01,& + & .1762400E+01,.1793400E+01,.1845700E+01,.1916200E+01,.2005600E+01,& + & .1765200E+01,.1798600E+01,.1853000E+01,.1925700E+01,.2017400E+01,& + & .1768300E+01,.1804200E+01,.1860700E+01,.1935600E+01,.2029600E+01,& + & .1773600E+01,.1813300E+01,.1873200E+01,.1951600E+01,.2049200E+01,& + & .1779600E+01,.1823400E+01,.1886800E+01,.1968900E+01,.2070200E+01,& + & .1785700E+01,.1834700E+01,.1901800E+01,.1987700E+01,.2092900E+01,& + & .1794600E+01,.1847500E+01,.1918500E+01,.2008500E+01,.2117800E+01,& + & .1805300E+01,.1862300E+01,.1937700E+01,.2032200E+01,.2146000E+01,& + & .1817200E+01,.1878500E+01,.1958300E+01,.2057400E+01,.2175700E+01,& + & .1830300E+01,.1895900E+01,.1980200E+01,.2083900E+01,.2206900E+01,& + & .1844800E+01,.1915000E+01,.2004200E+01,.2112600E+01,.2240400E+01,& + & .1860600E+01,.1935500E+01,.2029500E+01,.2142800E+01,.2275400E+01,& + & .1878000E+01,.1957700E+01,.2056600E+01,.2174900E+01,.2312500E+01,& + & .1896900E+01,.1981600E+01,.2085500E+01,.2208800E+01,.2351400E+01,& + & .1917200E+01,.2006900E+01,.2116000E+01,.2244300E+01,.2392000E+01,& + & .1935900E+01,.2030000E+01,.2143400E+01,.2276200E+01,.2428200E+01,& + & .1947100E+01,.2043700E+01,.2159700E+01,.2294900E+01,.2449500E+01,& + & .1949000E+01,.2046000E+01,.2162400E+01,.2298000E+01,.2453000E+01/ + + data absb(121:235, 2) / & + & .1937700E+01,.2032200E+01,.2146100E+01,.2279200E+01,.2431700E+01,& + & .1926100E+01,.2017900E+01,.2129100E+01,.2259500E+01,.2409300E+01,& + & .1914900E+01,.2004000E+01,.2112500E+01,.2240200E+01,.2387300E+01,& + & .1896300E+01,.1980700E+01,.2084500E+01,.2207600E+01,.2350100E+01,& + & .1877800E+01,.1957400E+01,.2056300E+01,.2174500E+01,.2312000E+01,& + & .1860400E+01,.1935200E+01,.2029200E+01,.2142500E+01,.2275000E+01,& + & .1840900E+01,.1909900E+01,.1997800E+01,.2105000E+01,.2231500E+01,& + & .1821700E+01,.1884500E+01,.1966000E+01,.2066700E+01,.2186700E+01,& + & .1804600E+01,.1861300E+01,.1936400E+01,.2030600E+01,.2144100E+01,& + & .1788600E+01,.1838900E+01,.1907200E+01,.1994500E+01,.2101100E+01,& + & .1775500E+01,.1816500E+01,.1877500E+01,.1957100E+01,.2055900E+01,& + & .1764400E+01,.1797000E+01,.1850800E+01,.1922800E+01,.2013900E+01,& + & .1756300E+01,.1781600E+01,.1827100E+01,.1891600E+01,.1974900E+01,& + & .1751700E+01,.1770200E+01,.1807400E+01,.1865100E+01,.1941300E+01,& + & .1750400E+01,.1761100E+01,.1790800E+01,.1842000E+01,.1911300E+01,& + & .1752300E+01,.1754700E+01,.1778300E+01,.1821200E+01,.1883900E+01,& + & .1756600E+01,.1751000E+01,.1767500E+01,.1802800E+01,.1858900E+01,& + & .1762300E+01,.1750700E+01,.1759800E+01,.1788100E+01,.1838100E+01,& + & .1769100E+01,.1752400E+01,.1754400E+01,.1777700E+01,.1820100E+01,& + & .1777600E+01,.1756200E+01,.1751200E+01,.1768200E+01,.1804000E+01,& + & .1788100E+01,.1761600E+01,.1750500E+01,.1760600E+01,.1789700E+01,& + & .1799600E+01,.1767800E+01,.1752000E+01,.1755200E+01,.1779400E+01,& + & .1804500E+01,.1770700E+01,.1753000E+01,.1753600E+01,.1775600E+01/ + + data absb( 1:120, 3) / & + & .1094500E+02,.1105200E+02,.1122200E+02,.1145200E+02,.1174400E+02,& + & .1095200E+02,.1106500E+02,.1124000E+02,.1147600E+02,.1177400E+02,& + & .1096100E+02,.1108000E+02,.1126100E+02,.1150300E+02,.1180700E+02,& + & .1097100E+02,.1109700E+02,.1128400E+02,.1153300E+02,.1184400E+02,& + & .1098100E+02,.1111500E+02,.1130700E+02,.1156200E+02,.1187900E+02,& + & .1099200E+02,.1113200E+02,.1133100E+02,.1159200E+02,.1191500E+02,& + & .1100300E+02,.1114900E+02,.1135400E+02,.1162200E+02,.1195100E+02,& + & .1101700E+02,.1117000E+02,.1138200E+02,.1165700E+02,.1199400E+02,& + & .1103100E+02,.1119200E+02,.1141200E+02,.1169400E+02,.1203800E+02,& + & .1105600E+02,.1122800E+02,.1146000E+02,.1175400E+02,.1210900E+02,& + & .1108500E+02,.1126700E+02,.1151100E+02,.1181700E+02,.1218400E+02,& + & .1111800E+02,.1131200E+02,.1156800E+02,.1188600E+02,.1226600E+02,& + & .1115400E+02,.1136100E+02,.1163000E+02,.1196200E+02,.1235400E+02,& + & .1119600E+02,.1141800E+02,.1170200E+02,.1204800E+02,.1245500E+02,& + & .1124300E+02,.1148000E+02,.1177800E+02,.1213800E+02,.1256000E+02,& + & .1129400E+02,.1154500E+02,.1185900E+02,.1223400E+02,.1267000E+02,& + & .1135100E+02,.1161700E+02,.1194600E+02,.1233600E+02,.1278800E+02,& + & .1141100E+02,.1169400E+02,.1203800E+02,.1244300E+02,.1291000E+02,& + & .1147800E+02,.1177600E+02,.1213600E+02,.1255700E+02,.1304000E+02,& + & .1154900E+02,.1186400E+02,.1223900E+02,.1267700E+02,.1317500E+02,& + & .1162600E+02,.1195600E+02,.1234800E+02,.1280100E+02,.1331600E+02,& + & .1169500E+02,.1204000E+02,.1244600E+02,.1291300E+02,.1344200E+02,& + & .1173700E+02,.1208900E+02,.1250300E+02,.1297900E+02,.1351500E+02,& + & .1174400E+02,.1209800E+02,.1251300E+02,.1298900E+02,.1352800E+02/ + + data absb(121:235, 3) / & + & .1170200E+02,.1204800E+02,.1245500E+02,.1292400E+02,.1345400E+02,& + & .1165900E+02,.1199600E+02,.1239500E+02,.1285500E+02,.1337600E+02,& + & .1161700E+02,.1194600E+02,.1233600E+02,.1278700E+02,.1330000E+02,& + & .1154700E+02,.1186100E+02,.1223600E+02,.1267300E+02,.1317100E+02,& + & .1147700E+02,.1177500E+02,.1213400E+02,.1255500E+02,.1303800E+02,& + & .1141100E+02,.1169300E+02,.1203700E+02,.1244200E+02,.1290900E+02,& + & .1133500E+02,.1159800E+02,.1192300E+02,.1230900E+02,.1275700E+02,& + & .1126100E+02,.1150300E+02,.1180700E+02,.1217200E+02,.1259900E+02,& + & .1119300E+02,.1141400E+02,.1169700E+02,.1204200E+02,.1244800E+02,& + & .1112900E+02,.1132800E+02,.1158800E+02,.1191100E+02,.1229500E+02,& + & .1106500E+02,.1124000E+02,.1147600E+02,.1177400E+02,.1213300E+02,& + & .1101200E+02,.1116300E+02,.1137400E+02,.1164700E+02,.1198100E+02,& + & .1096900E+02,.1109500E+02,.1128200E+02,.1153000E+02,.1183900E+02,& + & .1093800E+02,.1104000E+02,.1120400E+02,.1142900E+02,.1171500E+02,& + & .1091600E+02,.1099600E+02,.1113800E+02,.1134000E+02,.1160400E+02,& + & .1090000E+02,.1096000E+02,.1107900E+02,.1125900E+02,.1150000E+02,& + & .1089400E+02,.1093200E+02,.1102800E+02,.1118600E+02,.1140500E+02,& + & .1089500E+02,.1091200E+02,.1098900E+02,.1112700E+02,.1132500E+02,& + & .1090300E+02,.1090000E+02,.1095800E+02,.1107500E+02,.1125500E+02,& + & .1092100E+02,.1089400E+02,.1093300E+02,.1103100E+02,.1119100E+02,& + & .1094400E+02,.1089400E+02,.1091400E+02,.1099300E+02,.1113400E+02,& + & .1097200E+02,.1090100E+02,.1090200E+02,.1096300E+02,.1108400E+02,& + & .1098400E+02,.1090600E+02,.1089800E+02,.1095200E+02,.1106600E+02/ + + data absb( 1:120, 4) / & + & .5156300E+02,.5194600E+02,.5246400E+02,.5311600E+02,.5390200E+02,& + & .5159300E+02,.5198700E+02,.5251700E+02,.5318200E+02,.5398000E+02,& + & .5162600E+02,.5203500E+02,.5257900E+02,.5325600E+02,.5406900E+02,& + & .5166400E+02,.5208700E+02,.5264400E+02,.5333700E+02,.5416300E+02,& + & .5170100E+02,.5213800E+02,.5271000E+02,.5341600E+02,.5425700E+02,& + & .5174000E+02,.5219100E+02,.5277600E+02,.5349600E+02,.5435100E+02,& + & .5177900E+02,.5224400E+02,.5284300E+02,.5357600E+02,.5444400E+02,& + & .5182700E+02,.5230700E+02,.5292200E+02,.5367100E+02,.5455500E+02,& + & .5187700E+02,.5237300E+02,.5300400E+02,.5377000E+02,.5466900E+02,& + & .5195900E+02,.5248100E+02,.5313600E+02,.5392700E+02,.5485100E+02,& + & .5204900E+02,.5259600E+02,.5327800E+02,.5409400E+02,.5504400E+02,& + & .5214800E+02,.5272300E+02,.5343100E+02,.5427400E+02,.5525200E+02,& + & .5225900E+02,.5286200E+02,.5359900E+02,.5447100E+02,.5547700E+02,& + & .5238700E+02,.5302200E+02,.5379000E+02,.5469300E+02,.5573000E+02,& + & .5252500E+02,.5319100E+02,.5399200E+02,.5492600E+02,.5599500E+02,& + & .5267200E+02,.5337100E+02,.5420300E+02,.5517000E+02,.5627100E+02,& + & .5283300E+02,.5356500E+02,.5443000E+02,.5543000E+02,.5656500E+02,& + & .5300300E+02,.5376800E+02,.5466800E+02,.5570200E+02,.5687000E+02,& + & .5318600E+02,.5398600E+02,.5492000E+02,.5598800E+02,.5719000E+02,& + & .5338100E+02,.5421600E+02,.5518400E+02,.5628700E+02,.5752500E+02,& + & .5358700E+02,.5445700E+02,.5546000E+02,.5659900E+02,.5787100E+02,& + & .5377300E+02,.5467300E+02,.5570700E+02,.5687600E+02,.5817900E+02,& + & .5388300E+02,.5480000E+02,.5585200E+02,.5703900E+02,.5835900E+02,& + & .5390100E+02,.5482200E+02,.5587600E+02,.5706600E+02,.5838900E+02/ + + data absb(121:235, 4) / & + & .5379100E+02,.5469400E+02,.5573100E+02,.5690300E+02,.5820800E+02,& + & .5367600E+02,.5456000E+02,.5557800E+02,.5673100E+02,.5801800E+02,& + & .5356300E+02,.5442900E+02,.5542900E+02,.5656300E+02,.5783200E+02,& + & .5337500E+02,.5420800E+02,.5517500E+02,.5627700E+02,.5751300E+02,& + & .5318400E+02,.5398300E+02,.5491600E+02,.5598400E+02,.5718600E+02,& + & .5300100E+02,.5376600E+02,.5466500E+02,.5569900E+02,.5686600E+02,& + & .5279000E+02,.5351300E+02,.5437000E+02,.5536200E+02,.5648800E+02,& + & .5257700E+02,.5325400E+02,.5406600E+02,.5501200E+02,.5609300E+02,& + & .5237900E+02,.5301100E+02,.5377700E+02,.5467800E+02,.5571300E+02,& + & .5218400E+02,.5276800E+02,.5348600E+02,.5433900E+02,.5532600E+02,& + & .5198700E+02,.5251700E+02,.5318200E+02,.5398000E+02,.5491300E+02,& + & .5181200E+02,.5228800E+02,.5289800E+02,.5364300E+02,.5452200E+02,& + & .5165900E+02,.5208100E+02,.5263700E+02,.5332700E+02,.5415200E+02,& + & .5153500E+02,.5190600E+02,.5241200E+02,.5305200E+02,.5382600E+02,& + & .5143300E+02,.5175500E+02,.5221100E+02,.5280200E+02,.5352700E+02,& + & .5134900E+02,.5162200E+02,.5202900E+02,.5257100E+02,.5324700E+02,& + & .5128500E+02,.5150700E+02,.5186500E+02,.5235800E+02,.5298500E+02,& + & .5124000E+02,.5141700E+02,.5173000E+02,.5217800E+02,.5276000E+02,& + & .5121100E+02,.5134600E+02,.5161500E+02,.5202000E+02,.5255900E+02,& + & .5119400E+02,.5128800E+02,.5151400E+02,.5187500E+02,.5237100E+02,& + & .5119000E+02,.5124500E+02,.5142600E+02,.5174600E+02,.5219800E+02,& + & .5120000E+02,.5121600E+02,.5135700E+02,.5163500E+02,.5204600E+02,& + & .5120700E+02,.5120700E+02,.5133300E+02,.5159400E+02,.5198900E+02/ + + data absb( 1:120, 5) / & + & .1705100E+03,.1716800E+03,.1729700E+03,.1743700E+03,.1759000E+03,& + & .1706100E+03,.1717900E+03,.1730900E+03,.1745100E+03,.1760400E+03,& + & .1707300E+03,.1719200E+03,.1732300E+03,.1746600E+03,.1762100E+03,& + & .1708500E+03,.1720500E+03,.1733800E+03,.1748200E+03,.1763800E+03,& + & .1709700E+03,.1721800E+03,.1735200E+03,.1749700E+03,.1765500E+03,& + & .1710900E+03,.1723200E+03,.1736600E+03,.1751300E+03,.1767100E+03,& + & .1712100E+03,.1724500E+03,.1738100E+03,.1752800E+03,.1768800E+03,& + & .1713400E+03,.1726000E+03,.1739700E+03,.1754700E+03,.1770800E+03,& + & .1714900E+03,.1727600E+03,.1741500E+03,.1756500E+03,.1772800E+03,& + & .1717200E+03,.1730100E+03,.1744200E+03,.1759400E+03,.1775900E+03,& + & .1719500E+03,.1732700E+03,.1747000E+03,.1762500E+03,.1779200E+03,& + & .1722100E+03,.1735500E+03,.1750000E+03,.1765800E+03,.1782700E+03,& + & .1724800E+03,.1738500E+03,.1753300E+03,.1769300E+03,.1786500E+03,& + & .1727900E+03,.1741800E+03,.1756900E+03,.1773200E+03,.1790600E+03,& + & .1731100E+03,.1745300E+03,.1760600E+03,.1777200E+03,.1794900E+03,& + & .1734400E+03,.1748800E+03,.1764500E+03,.1781300E+03,.1799400E+03,& + & .1737900E+03,.1752600E+03,.1768600E+03,.1785700E+03,.1804000E+03,& + & .1741400E+03,.1756500E+03,.1772700E+03,.1790200E+03,.1808800E+03,& + & .1745200E+03,.1760500E+03,.1777100E+03,.1794800E+03,.1813700E+03,& + & .1749100E+03,.1764700E+03,.1781600E+03,.1799600E+03,.1818800E+03,& + & .1753100E+03,.1769000E+03,.1786200E+03,.1804500E+03,.1824100E+03,& + & .1756600E+03,.1772800E+03,.1790300E+03,.1808900E+03,.1828700E+03,& + & .1758600E+03,.1775000E+03,.1792600E+03,.1811400E+03,.1831300E+03,& + & .1759000E+03,.1775400E+03,.1793000E+03,.1811800E+03,.1831800E+03/ + + data absb(121:235, 5) / & + & .1756900E+03,.1773200E+03,.1790600E+03,.1809300E+03,.1829100E+03,& + & .1754700E+03,.1770800E+03,.1788100E+03,.1806600E+03,.1826300E+03,& + & .1752600E+03,.1768500E+03,.1785700E+03,.1804000E+03,.1823500E+03,& + & .1748900E+03,.1764600E+03,.1781400E+03,.1799500E+03,.1818700E+03,& + & .1745100E+03,.1760500E+03,.1777000E+03,.1794800E+03,.1813700E+03,& + & .1741400E+03,.1756500E+03,.1772700E+03,.1790100E+03,.1808700E+03,& + & .1736900E+03,.1751600E+03,.1767500E+03,.1784600E+03,.1802800E+03,& + & .1732300E+03,.1746500E+03,.1762000E+03,.1778700E+03,.1796500E+03,& + & .1727700E+03,.1741600E+03,.1756700E+03,.1772900E+03,.1790400E+03,& + & .1723000E+03,.1736500E+03,.1751100E+03,.1766900E+03,.1784000E+03,& + & .1717900E+03,.1730900E+03,.1745100E+03,.1760400E+03,.1777000E+03,& + & .1713000E+03,.1725500E+03,.1739200E+03,.1754100E+03,.1770200E+03,& + & .1708300E+03,.1720400E+03,.1733600E+03,.1748000E+03,.1763600E+03,& + & .1704100E+03,.1715700E+03,.1728500E+03,.1742400E+03,.1757600E+03,& + & .1700200E+03,.1711300E+03,.1723700E+03,.1737200E+03,.1751900E+03,& + & .1696400E+03,.1707100E+03,.1719000E+03,.1732100E+03,.1746400E+03,& + & .1692700E+03,.1703100E+03,.1714500E+03,.1727200E+03,.1741100E+03,& + & .1689600E+03,.1699500E+03,.1710600E+03,.1722800E+03,.1736300E+03,& + & .1686600E+03,.1696200E+03,.1706900E+03,.1718800E+03,.1731800E+03,& + & .1683900E+03,.1693000E+03,.1703300E+03,.1714800E+03,.1727500E+03,& + & .1681200E+03,.1689900E+03,.1699900E+03,.1711000E+03,.1723300E+03,& + & .1678800E+03,.1687100E+03,.1696800E+03,.1707500E+03,.1719500E+03,& + & .1677900E+03,.1686100E+03,.1695500E+03,.1706200E+03,.1718000E+03/ + + data absb( 1:120, 6) / & + & .3812200E+03,.3840600E+03,.3866800E+03,.3890800E+03,.3912500E+03,& + & .3814800E+03,.3843100E+03,.3869100E+03,.3892900E+03,.3914400E+03,& + & .3817800E+03,.3845800E+03,.3871600E+03,.3895100E+03,.3916400E+03,& + & .3820900E+03,.3848700E+03,.3874200E+03,.3897500E+03,.3918600E+03,& + & .3823900E+03,.3851400E+03,.3876700E+03,.3899800E+03,.3920600E+03,& + & .3826800E+03,.3854100E+03,.3879200E+03,.3902000E+03,.3922600E+03,& + & .3829700E+03,.3856800E+03,.3881600E+03,.3904200E+03,.3924600E+03,& + & .3833000E+03,.3859800E+03,.3884400E+03,.3906700E+03,.3926800E+03,& + & .3836300E+03,.3862900E+03,.3887200E+03,.3909200E+03,.3929100E+03,& + & .3841400E+03,.3867500E+03,.3891400E+03,.3913100E+03,.3932500E+03,& + & .3846600E+03,.3872300E+03,.3895800E+03,.3917000E+03,.3936000E+03,& + & .3852000E+03,.3877200E+03,.3900200E+03,.3921000E+03,.3939500E+03,& + & .3857500E+03,.3882300E+03,.3904800E+03,.3925100E+03,.3943200E+03,& + & .3863500E+03,.3887700E+03,.3909800E+03,.3929500E+03,.3947000E+03,& + & .3869400E+03,.3893200E+03,.3914600E+03,.3933900E+03,.3950900E+03,& + & .3875300E+03,.3898500E+03,.3919400E+03,.3938100E+03,.3954600E+03,& + & .3881300E+03,.3903900E+03,.3924300E+03,.3942400E+03,.3958300E+03,& + & .3887100E+03,.3909200E+03,.3929000E+03,.3946600E+03,.3962000E+03,& + & .3893000E+03,.3914500E+03,.3933800E+03,.3950800E+03,.3965500E+03,& + & .3898800E+03,.3919700E+03,.3938400E+03,.3954800E+03,.3969000E+03,& + & .3904500E+03,.3924800E+03,.3942900E+03,.3958700E+03,.3972300E+03,& + & .3909300E+03,.3929100E+03,.3946700E+03,.3962000E+03,.3975100E+03,& + & .3912000E+03,.3931600E+03,.3948800E+03,.3963900E+03,.3976600E+03,& + & .3912500E+03,.3932000E+03,.3949200E+03,.3964200E+03,.3976900E+03/ + + data absb(121:235, 6) / & + & .3909800E+03,.3929500E+03,.3947100E+03,.3962300E+03,.3975400E+03,& + & .3906800E+03,.3926900E+03,.3944700E+03,.3960300E+03,.3973700E+03,& + & .3903900E+03,.3924300E+03,.3942400E+03,.3958300E+03,.3972000E+03,& + & .3898600E+03,.3919600E+03,.3938200E+03,.3954700E+03,.3968900E+03,& + & .3892900E+03,.3914400E+03,.3933700E+03,.3950700E+03,.3965500E+03,& + & .3887100E+03,.3909200E+03,.3929000E+03,.3946600E+03,.3961900E+03,& + & .3879700E+03,.3902500E+03,.3923000E+03,.3941300E+03,.3957400E+03,& + & .3871500E+03,.3895100E+03,.3916400E+03,.3935400E+03,.3952200E+03,& + & .3863100E+03,.3887400E+03,.3909400E+03,.3929200E+03,.3946800E+03,& + & .3853800E+03,.3878900E+03,.3901800E+03,.3922400E+03,.3940700E+03,& + & .3843100E+03,.3869100E+03,.3892900E+03,.3914400E+03,.3933600E+03,& + & .3832000E+03,.3858900E+03,.3883600E+03,.3906000E+03,.3926200E+03,& + & .3820600E+03,.3848400E+03,.3873900E+03,.3897200E+03,.3918300E+03,& + & .3809500E+03,.3838200E+03,.3864600E+03,.3888700E+03,.3910600E+03,& + & .3798500E+03,.3827900E+03,.3855200E+03,.3880200E+03,.3902900E+03,& + & .3787300E+03,.3817500E+03,.3845500E+03,.3871300E+03,.3894900E+03,& + & .3776200E+03,.3806700E+03,.3835500E+03,.3862100E+03,.3886500E+03,& + & .3766100E+03,.3796500E+03,.3826100E+03,.3853500E+03,.3878600E+03,& + & .3755900E+03,.3786700E+03,.3816900E+03,.3845000E+03,.3870800E+03,& + & .3745900E+03,.3776800E+03,.3807400E+03,.3836200E+03,.3862800E+03,& + & .3735300E+03,.3767300E+03,.3797700E+03,.3827200E+03,.3854500E+03,& + & .3725100E+03,.3757700E+03,.3788500E+03,.3818500E+03,.3846500E+03,& + & .3721200E+03,.3753900E+03,.3784700E+03,.3815000E+03,.3843200E+03/ + + data absb( 1:120, 7) / & + & .7662137E+03,.7673567E+03,.7684935E+03,.7696200E+03,.7707387E+03,& + & .7663163E+03,.7674596E+03,.7685948E+03,.7697242E+03,.7708374E+03,& + & .7664298E+03,.7675754E+03,.7687154E+03,.7698361E+03,.7709498E+03,& + & .7665525E+03,.7676972E+03,.7688307E+03,.7699581E+03,.7710677E+03,& + & .7666756E+03,.7678182E+03,.7689507E+03,.7700728E+03,.7711794E+03,& + & .7667902E+03,.7679332E+03,.7690672E+03,.7701907E+03,.7712951E+03,& + & .7669059E+03,.7680487E+03,.7691780E+03,.7703003E+03,.7714030E+03,& + & .7670396E+03,.7681833E+03,.7693099E+03,.7704320E+03,.7715291E+03,& + & .7671791E+03,.7683177E+03,.7694439E+03,.7705613E+03,.7716607E+03,& + & .7673923E+03,.7685297E+03,.7696521E+03,.7707717E+03,.7718639E+03,& + & .7676078E+03,.7687458E+03,.7698715E+03,.7709807E+03,.7720702E+03,& + & .7678360E+03,.7689728E+03,.7700933E+03,.7712034E+03,.7722895E+03,& + & .7680791E+03,.7692104E+03,.7703330E+03,.7714362E+03,.7725191E+03,& + & .7683474E+03,.7694736E+03,.7705880E+03,.7716873E+03,.7727677E+03,& + & .7686113E+03,.7697379E+03,.7708539E+03,.7719439E+03,.7730324E+03,& + & .7688808E+03,.7700069E+03,.7711126E+03,.7722067E+03,.7732788E+03,& + & .7691627E+03,.7702826E+03,.7713890E+03,.7724701E+03,.7735411E+03,& + & .7694444E+03,.7705613E+03,.7716614E+03,.7727369E+03,.7738092E+03,& + & .7697324E+03,.7708439E+03,.7719374E+03,.7730147E+03,.7740850E+03,& + & .7700239E+03,.7711302E+03,.7722186E+03,.7732904E+03,.7743608E+03,& + & .7703148E+03,.7714174E+03,.7725031E+03,.7735736E+03,.7746415E+03,& + & .7705710E+03,.7716646E+03,.7727437E+03,.7738133E+03,.7748784E+03,& + & .7707135E+03,.7718066E+03,.7728840E+03,.7739535E+03,.7750133E+03,& + & .7707385E+03,.7718282E+03,.7729073E+03,.7739754E+03,.7750350E+03/ + + data absb(121:235, 7) / & + & .7705883E+03,.7716906E+03,.7727677E+03,.7738341E+03,.7749005E+03,& + & .7704377E+03,.7715367E+03,.7726181E+03,.7736893E+03,.7747501E+03,& + & .7702833E+03,.7713847E+03,.7724701E+03,.7735404E+03,.7746103E+03,& + & .7700132E+03,.7711226E+03,.7722110E+03,.7732832E+03,.7743549E+03,& + & .7697309E+03,.7708439E+03,.7719342E+03,.7730115E+03,.7740748E+03,& + & .7694415E+03,.7705563E+03,.7716549E+03,.7727369E+03,.7738016E+03,& + & .7690928E+03,.7702101E+03,.7713174E+03,.7724017E+03,.7734724E+03,& + & .7687110E+03,.7698351E+03,.7709476E+03,.7720367E+03,.7731196E+03,& + & .7683270E+03,.7694544E+03,.7705715E+03,.7716689E+03,.7727485E+03,& + & .7679197E+03,.7690513E+03,.7701707E+03,.7712793E+03,.7723644E+03,& + & .7674632E+03,.7685951E+03,.7697242E+03,.7708374E+03,.7719299E+03,& + & .7669980E+03,.7681419E+03,.7692751E+03,.7703917E+03,.7714912E+03,& + & .7665390E+03,.7676847E+03,.7688180E+03,.7699424E+03,.7710534E+03,& + & .7661024E+03,.7672540E+03,.7683924E+03,.7695234E+03,.7706427E+03,& + & .7656917E+03,.7668356E+03,.7679808E+03,.7691095E+03,.7702308E+03,& + & .7652690E+03,.7664166E+03,.7675626E+03,.7687003E+03,.7698229E+03,& + & .7648234E+03,.7659942E+03,.7671451E+03,.7682868E+03,.7694142E+03,& + & .7643942E+03,.7656164E+03,.7667615E+03,.7679051E+03,.7690364E+03,& + & .7640026E+03,.7652413E+03,.7663923E+03,.7675375E+03,.7686735E+03,& + & .7636170E+03,.7648611E+03,.7660227E+03,.7671711E+03,.7683104E+03,& + & .7632407E+03,.7644461E+03,.7656618E+03,.7668033E+03,.7679489E+03,& + & .7628680E+03,.7640652E+03,.7653090E+03,.7664582E+03,.7676042E+03,& + & .7627137E+03,.7639260E+03,.7651678E+03,.7663198E+03,.7674646E+03/ + + data absb( 1:120, 8) / & + & .9936589E+03,.9978124E+03,.1000713E+04,.1002438E+04,.1003006E+04,& + & .9941671E+03,.9981368E+03,.1000893E+04,.1002525E+04,.1002981E+04,& + & .9946170E+03,.9984729E+03,.1001113E+04,.1002623E+04,.1003004E+04,& + & .9950818E+03,.9987774E+03,.1001345E+04,.1002694E+04,.1002984E+04,& + & .9955234E+03,.9990646E+03,.1001517E+04,.1002779E+04,.1002969E+04,& + & .9959436E+03,.9994208E+03,.1001709E+04,.1002856E+04,.1002912E+04,& + & .9963433E+03,.9996951E+03,.1001890E+04,.1002878E+04,.1002898E+04,& + & .9968098E+03,.1000016E+04,.1002055E+04,.1002942E+04,.1002824E+04,& + & .9972440E+03,.1000327E+04,.1002227E+04,.1002982E+04,.1002721E+04,& + & .9979060E+03,.1000761E+04,.1002461E+04,.1002998E+04,.1002590E+04,& + & .9985543E+03,.1001122E+04,.1002633E+04,.1002989E+04,.1002393E+04,& + & .9991623E+03,.1001557E+04,.1002797E+04,.1002959E+04,.1002134E+04,& + & .9997568E+03,.1001925E+04,.1002931E+04,.1002871E+04,.1001821E+04,& + & .1000377E+04,.1002254E+04,.1002986E+04,.1002709E+04,.1001396E+04,& + & .1000957E+04,.1002526E+04,.1002996E+04,.1002513E+04,.1000729E+04,& + & .1001400E+04,.1002743E+04,.1002971E+04,.1002233E+04,.1000328E+04,& + & .1001865E+04,.1002878E+04,.1002898E+04,.1001880E+04,.9997574E+03,& + & .1002181E+04,.1002979E+04,.1002724E+04,.1001454E+04,.9990322E+03,& + & .1002525E+04,.1003008E+04,.1002510E+04,.1000958E+04,.9981303E+03,& + & .1002747E+04,.1002980E+04,.1002223E+04,.1000349E+04,.9972023E+03,& + & .1002906E+04,.1002878E+04,.1001840E+04,.9996791E+03,.9962163E+03,& + & .1002974E+04,.1002724E+04,.1001436E+04,.9990028E+03,.9953155E+03,& + & .1003027E+04,.1002635E+04,.1001189E+04,.9985939E+03,.9947732E+03,& + & .1003027E+04,.1002599E+04,.1001143E+04,.9985204E+03,.9946814E+03/ + + data absb(121:235, 8) / & + & .1002986E+04,.1002724E+04,.1001390E+04,.9989482E+03,.9952234E+03,& + & .1002962E+04,.1002812E+04,.1001649E+04,.9993614E+03,.9957896E+03,& + & .1002875E+04,.1002898E+04,.1001877E+04,.9997601E+03,.9963253E+03,& + & .1002746E+04,.1002968E+04,.1002233E+04,.1000370E+04,.9972315E+03,& + & .1002537E+04,.1002981E+04,.1002514E+04,.1000975E+04,.9981846E+03,& + & .1002227E+04,.1002980E+04,.1002742E+04,.1001469E+04,.9990389E+03,& + & .1001759E+04,.1002861E+04,.1002915E+04,.1001995E+04,.9999268E+03,& + & .1001110E+04,.1002626E+04,.1002989E+04,.1002426E+04,.1000671E+04,& + & .1000338E+04,.1002249E+04,.1002983E+04,.1002727E+04,.1001434E+04,& + & .9993803E+03,.1001695E+04,.1002852E+04,.1002935E+04,.1002009E+04,& + & .9981347E+03,.1000918E+04,.1002522E+04,.1002979E+04,.1002520E+04,& + & .9966771E+03,.9999354E+03,.1002008E+04,.1002956E+04,.1002842E+04,& + & .9950417E+03,.9987633E+03,.1001326E+04,.1002702E+04,.1002988E+04,& + & .9933422E+03,.9974970E+03,.1000473E+04,.1002331E+04,.1002942E+04,& + & .9914154E+03,.9961148E+03,.9995247E+03,.1001775E+04,.1002873E+04,& + & .9892683E+03,.9945791E+03,.9984181E+03,.1001097E+04,.1002599E+04,& + & .9870330E+03,.9928966E+03,.9971671E+03,.1000265E+04,.1002220E+04,& + & .9848582E+03,.9910375E+03,.9958675E+03,.9993760E+03,.1001692E+04,& + & .9825219E+03,.9891516E+03,.9944982E+03,.9983573E+03,.1001066E+04,& + & .9797028E+03,.9871901E+03,.9930195E+03,.9972541E+03,.1000326E+04,& + & .9768957E+03,.9851199E+03,.9912663E+03,.9960243E+03,.9994761E+03,& + & .9741514E+03,.9830479E+03,.9894876E+03,.9947451E+03,.9985504E+03,& + & .9730254E+03,.9819457E+03,.9887533E+03,.9941968E+03,.9981408E+03/ + +!........................................! + end module module_radsw_kgb27 ! +!========================================! + + +!> This module sets up absorption coeffients for band 28: 38000-50000 +!! cm-1 (low - o3,o2; high - o3,o2) +!========================================! + module module_radsw_kgb28 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG28 + +! + implicit none +! + private +! +!> msa28=585 + integer, public :: MSA28 +!> msb28=1175 + integer, public :: MSB28 + parameter (MSA28=585, MSB28=1175) + + +!> the array absa(585,NG28) (ka((9,5,13,NG28)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 6, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA28,NG28) + +!> the array absb(1175,6) (kb(5,5,13:59,6)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 6, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB28,NG28) + +!> rayleigh extinction coefficient + real (kind=kind_phys), parameter, public :: rayl = 2.02e-05 + + data absa( 1:180, 1) / & + & .4644700E+02,.1800100E+03,.3133800E+03,.4465200E+03,.5463600E+03,& + & .5417300E+03,.4570700E+03,.2736300E+03,.3500000E+02,.4527000E+02,& + & .1788600E+03,.3122500E+03,.4454100E+03,.5417700E+03,.5343600E+03,& + & .4493200E+03,.2674800E+03,.3500000E+02,.4421400E+02,.1777600E+03,& + & .3111500E+03,.4442700E+03,.5373300E+03,.5275600E+03,.4422400E+03,& + & .2619500E+03,.3500000E+02,.4325900E+02,.1767300E+03,.3100500E+03,& + & .4430500E+03,.5329800E+03,.5212900E+03,.4357400E+03,.2569600E+03,& + & .3500000E+02,.4239300E+02,.1757500E+03,.3089600E+03,.4417300E+03,& + & .5288300E+03,.5154800E+03,.4297600E+03,.2524200E+03,.3500000E+02,& + & .4290800E+02,.1769500E+03,.3107700E+03,.4443400E+03,.5316100E+03,& + & .5189500E+03,.4333200E+03,.2551200E+03,.3500000E+02,.4189900E+02,& + & .1759600E+03,.3098000E+03,.4433600E+03,.5268600E+03,.5121300E+03,& + & .4263200E+03,.2498400E+03,.3500000E+02,.4099500E+02,.1750200E+03,& + & .3088400E+03,.4423200E+03,.5223000E+03,.5059200E+03,.4199500E+03,& + & .2451100E+03,.3500000E+02,.4018100E+02,.1741200E+03,.3078800E+03,& + & .4411900E+03,.5178500E+03,.5002500E+03,.4141400E+03,.2408500E+03,& + & .3500000E+02,.3944300E+02,.1732600E+03,.3069100E+03,.4399200E+03,& + & .5136400E+03,.4950300E+03,.4088200E+03,.2369900E+03,.3500000E+02,& + & .4012600E+02,.1745700E+03,.3087600E+03,.4424800E+03,.5175500E+03,& + & .4998600E+03,.4137500E+03,.2405600E+03,.3500000E+02,.3924000E+02,& + & .1737000E+03,.3079200E+03,.4414600E+03,.5125400E+03,.4935800E+03,& + & .4073500E+03,.2359300E+03,.3500000E+02,.3845000E+02,.1728800E+03,& + & .3070800E+03,.4403100E+03,.5079300E+03,.4878600E+03,.4015500E+03,& + & .2317900E+03,.3500000E+02,.3774000E+02,.1721000E+03,.3062400E+03,& + & .4390800E+03,.5036800E+03,.4826400E+03,.3962900E+03,.2280800E+03,& + & .3500000E+02,.3709900E+02,.1713400E+03,.3053900E+03,.4378100E+03,& + & .4997500E+03,.4778700E+03,.3914900E+03,.2247300E+03,.3500000E+02,& + & .3781800E+02,.1725800E+03,.3070800E+03,.4396700E+03,.5041200E+03,& + & .4832100E+03,.3968700E+03,.2284800E+03,.3500000E+02,.3703400E+02,& + & .1718300E+03,.3063600E+03,.4383300E+03,.4993500E+03,.4773800E+03,& + & .3910000E+03,.2243900E+03,.3500000E+02,.3633800E+02,.1711100E+03,& + & .3056400E+03,.4370000E+03,.4949600E+03,.4721200E+03,.3857200E+03,& + & .2207500E+03,.3500000E+02,.3571600E+02,.1704300E+03,.3049100E+03,& + & .4356900E+03,.4909400E+03,.4673200E+03,.3809400E+03,.2174900E+03,& + & .3500000E+02,.3515600E+02,.1697700E+03,.3041600E+03,.4343700E+03,& + & .4872600E+03,.4629400E+03,.3766000E+03,.2145600E+03,.3500000E+02/ + + data absa(181:315, 1) / & + & .3585700E+02,.1708900E+03,.3056300E+03,.4361900E+03,.4918600E+03,& + & .4684100E+03,.3820200E+03,.2182200E+03,.3500000E+02,.3516300E+02,& + & .1702300E+03,.3050200E+03,.4347800E+03,.4873100E+03,.4630000E+03,& + & .3766600E+03,.2146000E+03,.3500000E+02,.3455000E+02,.1696100E+03,& + & .3044100E+03,.4333200E+03,.4832100E+03,.4581300E+03,.3718600E+03,& + & .2113900E+03,.3500000E+02,.3400400E+02,.1690200E+03,.3037800E+03,& + & .4319400E+03,.4795000E+03,.4537500E+03,.3675500E+03,.2085300E+03,& + & .3500000E+02,.3351400E+02,.1684400E+03,.3031200E+03,.4305800E+03,& + & .4761100E+03,.4497700E+03,.3636500E+03,.2059700E+03,.3500000E+02,& + & .3421200E+02,.1694600E+03,.3044000E+03,.4324700E+03,.4809200E+03,& + & .4554200E+03,.3692000E+03,.2096200E+03,.3500000E+02,.3359500E+02,& + & .1688900E+03,.3038900E+03,.4309300E+03,.4766700E+03,.4504300E+03,& + & .3643000E+03,.2063900E+03,.3500000E+02,.3305200E+02,.1683500E+03,& + & .3033700E+03,.4294600E+03,.4728700E+03,.4459900E+03,.3599300E+03,& + & .2035500E+03,.3500000E+02,.3257100E+02,.1678400E+03,.3028300E+03,& + & .4280700E+03,.4694700E+03,.4420100E+03,.3560200E+03,.2010300E+03,& + & .3500000E+02,.3214100E+02,.1673300E+03,.3022700E+03,.4267400E+03,& + & .4664000E+03,.4384200E+03,.3525000E+03,.1987900E+03,.3500000E+02,& + & .3281200E+02,.1682300E+03,.3033400E+03,.4285900E+03,.4711800E+03,& + & .4440100E+03,.3579900E+03,.2023000E+03,.3500000E+02,.3226300E+02,& + & .1677400E+03,.3029100E+03,.4270800E+03,.4672700E+03,.4394400E+03,& + & .3535000E+03,.1994200E+03,.3500000E+02,.3178200E+02,.1672800E+03,& + & .3024800E+03,.4255800E+03,.4638100E+03,.4353900E+03,.3495400E+03,& + & .1969100E+03,.3500000E+02,.3135700E+02,.1668300E+03,.3020300E+03,& + & .4241300E+03,.4606900E+03,.4317700E+03,.3459900E+03,.1946800E+03,& + & .3500000E+02,.3098000E+02,.1664000E+03,.3015400E+03,.4227600E+03,& + & .4578700E+03,.4285200E+03,.3428000E+03,.1927100E+03,.3500000E+02/ + + data absa(316:450, 1) / & + & .3161400E+02,.1671600E+03,.3023900E+03,.4247300E+03,.4625900E+03,& + & .4339700E+03,.3481400E+03,.1960300E+03,.3500000E+02,.3112500E+02,& + & .1667400E+03,.3020600E+03,.4231100E+03,.4589600E+03,.4297800E+03,& + & .3440300E+03,.1934700E+03,.3500000E+02,.3069900E+02,.1663500E+03,& + & .3017000E+03,.4216300E+03,.4557300E+03,.4260800E+03,.3403900E+03,& + & .1912400E+03,.3500000E+02,.3032500E+02,.1659700E+03,.3013300E+03,& + & .4202700E+03,.4528600E+03,.4228100E+03,.3371600E+03,.1892800E+03,& + & .3500000E+02,.2999300E+02,.1655900E+03,.3009200E+03,.4190100E+03,& + & .4503000E+03,.4198800E+03,.3342700E+03,.1875500E+03,.3500000E+02,& + & .3059400E+02,.1662400E+03,.3015600E+03,.4208700E+03,.4549300E+03,& + & .4251700E+03,.3394900E+03,.1906900E+03,.3500000E+02,.3015800E+02,& + & .1658900E+03,.3013100E+03,.4193700E+03,.4515700E+03,.4213400E+03,& + & .3357000E+03,.1884100E+03,.3500000E+02,.2978000E+02,.1655600E+03,& + & .3010300E+03,.4180000E+03,.4486400E+03,.4179900E+03,.3323900E+03,& + & .1864300E+03,.3500000E+02,.2945000E+02,.1652300E+03,.3007200E+03,& + & .4167400E+03,.4460600E+03,.4150400E+03,.3294600E+03,.1847100E+03,& + & .3500000E+02,.2915900E+02,.1649100E+03,.3003900E+03,.4155700E+03,& + & .4437700E+03,.4124200E+03,.3268600E+03,.1831800E+03,.3500000E+02,& + & .2969100E+02,.1654100E+03,.3008100E+03,.4172200E+03,.4479500E+03,& + & .4172000E+03,.3316000E+03,.1859700E+03,.3500000E+02,.2930700E+02,& + & .1651200E+03,.3006300E+03,.4158100E+03,.4449300E+03,.4137500E+03,& + & .3281800E+03,.1839600E+03,.3500000E+02,.2897500E+02,.1648500E+03,& + & .3004200E+03,.4145400E+03,.4423100E+03,.4107600E+03,.3252000E+03,& + & .1822200E+03,.3500000E+02,.2868700E+02,.1645800E+03,.3001800E+03,& + & .4134000E+03,.4400200E+03,.4081400E+03,.3225900E+03,.1807100E+03,& + & .3500000E+02,.2843400E+02,.1643100E+03,.2998900E+03,.4123500E+03,& + & .4379900E+03,.4058300E+03,.3202800E+03,.1793900E+03,.3500000E+02/ + + data absa(451:585, 1) / & + & .2876000E+02,.1645900E+03,.3001000E+03,.4132100E+03,.4406000E+03,& + & .4088000E+03,.3232500E+03,.1810900E+03,.3500000E+02,.2844400E+02,& + & .1643600E+03,.2999700E+03,.4120000E+03,.4380700E+03,.4059200E+03,& + & .3203800E+03,.1794400E+03,.3500000E+02,.2817300E+02,.1641400E+03,& + & .2998100E+03,.4109200E+03,.4358700E+03,.4034200E+03,.3178800E+03,& + & .1780200E+03,.3500000E+02,.2793700E+02,.1639200E+03,.2996000E+03,& + & .4099400E+03,.4339500E+03,.4012400E+03,.3157000E+03,.1767900E+03,& + & .3500000E+02,.2773000E+02,.1636900E+03,.2993600E+03,.4090500E+03,& + & .4322400E+03,.3993100E+03,.3137700E+03,.1757100E+03,.3500000E+02,& + & .2799500E+02,.1639100E+03,.2995100E+03,.4097000E+03,.4344300E+03,& + & .4017800E+03,.3162400E+03,.1770900E+03,.3500000E+02,.2773700E+02,& + & .1637400E+03,.2994300E+03,.4086900E+03,.4323000E+03,.3993800E+03,& + & .3138400E+03,.1757400E+03,.3500000E+02,.2751500E+02,.1635600E+03,& + & .2993000E+03,.4077900E+03,.4304600E+03,.3973000E+03,.3117600E+03,& + & .1745800E+03,.3500000E+02,.2732200E+02,.1633800E+03,.2991300E+03,& + & .4069700E+03,.4288300E+03,.3954800E+03,.3099400E+03,.1735700E+03,& + & .3500000E+02,.2715200E+02,.1631800E+03,.2989200E+03,.4062200E+03,& + & .4274000E+03,.3938700E+03,.3083400E+03,.1726800E+03,.3500000E+02,& + & .2736900E+02,.1633600E+03,.2990300E+03,.4067100E+03,.4292400E+03,& + & .3959300E+03,.3103900E+03,.1738200E+03,.3500000E+02,.2715800E+02,& + & .1632300E+03,.2989800E+03,.4058700E+03,.4274500E+03,.3939300E+03,& + & .3084000E+03,.1727100E+03,.3500000E+02,.2697600E+02,.1630900E+03,& + & .2988900E+03,.4051300E+03,.4259000E+03,.3922100E+03,.3066700E+03,& + & .1717600E+03,.3500000E+02,.2681800E+02,.1629300E+03,.2987500E+03,& + & .4044500E+03,.4245500E+03,.3907000E+03,.3051600E+03,.1709300E+03,& + & .3500000E+02,.2667900E+02,.1627600E+03,.2985500E+03,.4038100E+03,& + & .4233500E+03,.3893700E+03,.3038400E+03,.1702100E+03,.3500000E+02/ + + data absa( 1:180, 2) / & + & .1727100E+03,.2764600E+03,.3803900E+03,.4842000E+03,.5693200E+03,& + & .5753400E+03,.4787300E+03,.2814700E+03,.7184000E+02,.1683400E+03,& + & .2724600E+03,.3767800E+03,.4809100E+03,.5647100E+03,.5673400E+03,& + & .4700500E+03,.2759300E+03,.7184000E+02,.1644100E+03,.2688300E+03,& + & .3734100E+03,.4777700E+03,.5603700E+03,.5600300E+03,.4621000E+03,& + & .2709600E+03,.7184000E+02,.1608600E+03,.2654800E+03,.3702500E+03,& + & .4747900E+03,.5562900E+03,.5532700E+03,.4548100E+03,.2664700E+03,& + & .7184000E+02,.1576400E+03,.2623700E+03,.3672500E+03,.4719500E+03,& + & .5523500E+03,.5470100E+03,.4481000E+03,.2623900E+03,.7184000E+02,& + & .1595500E+03,.2650000E+03,.3706700E+03,.4759500E+03,.5548000E+03,& + & .5507400E+03,.4521000E+03,.2648200E+03,.7184000E+02,.1558000E+03,& + & .2615700E+03,.3675600E+03,.4730300E+03,.5502800E+03,.5433900E+03,& + & .4442300E+03,.2600700E+03,.7184000E+02,.1524400E+03,.2584400E+03,& + & .3646500E+03,.4702300E+03,.5461900E+03,.5366400E+03,.4370800E+03,& + & .2558100E+03,.7184000E+02,.1494100E+03,.2555600E+03,.3619100E+03,& + & .4675300E+03,.5425300E+03,.5304100E+03,.4305200E+03,.2519800E+03,& + & .7184000E+02,.1466700E+03,.2528900E+03,.3593000E+03,.4649400E+03,& + & .5390800E+03,.5247000E+03,.4244800E+03,.2485100E+03,.7184000E+02,& + & .1492100E+03,.2560100E+03,.3630800E+03,.4687200E+03,.5423400E+03,& + & .5299900E+03,.4300700E+03,.2517200E+03,.7184000E+02,.1459100E+03,& + & .2530100E+03,.3603600E+03,.4659900E+03,.5383400E+03,.5231300E+03,& + & .4228000E+03,.2475500E+03,.7184000E+02,.1429700E+03,.2502800E+03,& + & .3578200E+03,.4635000E+03,.5345900E+03,.5169600E+03,.4161900E+03,& + & .2438300E+03,.7184000E+02,.1403300E+03,.2477700E+03,.3554200E+03,& + & .4611600E+03,.5310000E+03,.5112200E+03,.4101600E+03,.2404900E+03,& + & .7184000E+02,.1379500E+03,.2454400E+03,.3531300E+03,.4588200E+03,& + & .5275100E+03,.5059100E+03,.4046300E+03,.2374700E+03,.7184000E+02,& + & .1406200E+03,.2485600E+03,.3567800E+03,.4626000E+03,.5313700E+03,& + & .5118600E+03,.4108200E+03,.2408600E+03,.7184000E+02,.1377100E+03,& + & .2459200E+03,.3544000E+03,.4602000E+03,.5273200E+03,.5053700E+03,& + & .4040700E+03,.2371700E+03,.7184000E+02,.1351200E+03,.2435300E+03,& + & .3521900E+03,.4579600E+03,.5234800E+03,.4995400E+03,.3979800E+03,& + & .2338900E+03,.7184000E+02,.1328100E+03,.2413300E+03,.3500800E+03,& + & .4558300E+03,.5198500E+03,.4943100E+03,.3924600E+03,.2309600E+03,& + & .7184000E+02,.1307300E+03,.2392800E+03,.3480700E+03,.4537800E+03,& + & .5164300E+03,.4895700E+03,.3874500E+03,.2283300E+03,.7184000E+02/ + + data absa(181:315, 2) / & + & .1333300E+03,.2422200E+03,.3514100E+03,.4570200E+03,.5205700E+03,& + & .4955000E+03,.3937200E+03,.2316300E+03,.7184000E+02,.1307500E+03,& + & .2399000E+03,.3493400E+03,.4547600E+03,.5165100E+03,.4896300E+03,& + & .3875200E+03,.2283600E+03,.7184000E+02,.1284700E+03,.2378000E+03,& + & .3474100E+03,.4526600E+03,.5127100E+03,.4843800E+03,.3819600E+03,& + & .2254800E+03,.7184000E+02,.1264400E+03,.2358800E+03,.3455700E+03,& + & .4506600E+03,.5091100E+03,.4796200E+03,.3769600E+03,.2229100E+03,& + & .7184000E+02,.1246200E+03,.2340900E+03,.3438100E+03,.4487400E+03,& + & .5057000E+03,.4752600E+03,.3724500E+03,.2206000E+03,.7184000E+02,& + & .1272200E+03,.2369000E+03,.3468800E+03,.4517700E+03,.5103200E+03,& + & .4814400E+03,.3788700E+03,.2238900E+03,.7184000E+02,.1249200E+03,& + & .2348500E+03,.3450800E+03,.4496700E+03,.5062000E+03,.4759800E+03,& + & .3731900E+03,.2209800E+03,.7184000E+02,.1229000E+03,.2330100E+03,& + & .3434000E+03,.4476900E+03,.5024200E+03,.4710800E+03,.3681500E+03,& + & .2184300E+03,.7184000E+02,.1211100E+03,.2313200E+03,.3418000E+03,& + & .4458200E+03,.4989400E+03,.4666800E+03,.3636300E+03,.2161600E+03,& + & .7184000E+02,.1195200E+03,.2297600E+03,.3402600E+03,.4440700E+03,& + & .4957400E+03,.4627000E+03,.3595600E+03,.2141400E+03,.7184000E+02,& + & .1220100E+03,.2323500E+03,.3430000E+03,.4470000E+03,.5005400E+03,& + & .4688900E+03,.3659000E+03,.2173000E+03,.7184000E+02,.1199700E+03,& + & .2305500E+03,.3414500E+03,.4449200E+03,.4965700E+03,.4638300E+03,& + & .3607100E+03,.2147100E+03,.7184000E+02,.1181800E+03,.2289400E+03,& + & .3399900E+03,.4430900E+03,.4929200E+03,.4593400E+03,.3561300E+03,& + & .2124500E+03,.7184000E+02,.1166000E+03,.2274600E+03,.3385900E+03,& + & .4414600E+03,.4895900E+03,.4553300E+03,.3520800E+03,.2104500E+03,& + & .7184000E+02,.1152000E+03,.2260900E+03,.3372400E+03,.4399600E+03,& + & .4865700E+03,.4517500E+03,.3484700E+03,.2086700E+03,.7184000E+02/ + + data absa(316:450, 2) / & + & .1175600E+03,.2284400E+03,.3396500E+03,.4426100E+03,.4914700E+03,& + & .4577600E+03,.3545400E+03,.2116600E+03,.7184000E+02,.1157400E+03,& + & .2268700E+03,.3383000E+03,.4408200E+03,.4876700E+03,.4531300E+03,& + & .3498600E+03,.2093600E+03,.7184000E+02,.1141500E+03,.2254600E+03,& + & .3370400E+03,.4391500E+03,.4842900E+03,.4490800E+03,.3457900E+03,& + & .2073500E+03,.7184000E+02,.1127600E+03,.2241700E+03,.3358400E+03,& + & .4375800E+03,.4812600E+03,.4454900E+03,.3422000E+03,.2055900E+03,& + & .7184000E+02,.1115300E+03,.2229800E+03,.3346600E+03,.4361700E+03,& + & .4785500E+03,.4422800E+03,.3390200E+03,.2040300E+03,.7184000E+02,& + & .1137600E+03,.2251000E+03,.3367400E+03,.4388200E+03,.4833600E+03,& + & .4480700E+03,.3447900E+03,.2068600E+03,.7184000E+02,.1121400E+03,& + & .2237200E+03,.3355900E+03,.4370600E+03,.4798900E+03,.4438800E+03,& + & .3406000E+03,.2048000E+03,.7184000E+02,.1107400E+03,.2225000E+03,& + & .3345100E+03,.4354700E+03,.4767900E+03,.4402000E+03,.3369700E+03,& + & .2030300E+03,.7184000E+02,.1095100E+03,.2213800E+03,.3334800E+03,& + & .4340400E+03,.4740400E+03,.4369400E+03,.3337900E+03,.2014700E+03,& + & .7184000E+02,.1084300E+03,.2203400E+03,.3324600E+03,.4327700E+03,& + & .4715900E+03,.4340500E+03,.3309600E+03,.2001000E+03,.7184000E+02,& + & .1104100E+03,.2221400E+03,.3341400E+03,.4351700E+03,.4760400E+03,& + & .4393200E+03,.3361100E+03,.2026100E+03,.7184000E+02,.1089800E+03,& + & .2209500E+03,.3331700E+03,.4335800E+03,.4728300E+03,.4355200E+03,& + & .3323900E+03,.2008000E+03,.7184000E+02,.1077400E+03,.2198900E+03,& + & .3322600E+03,.4321300E+03,.4700200E+03,.4322200E+03,.3291700E+03,& + & .1992400E+03,.7184000E+02,.1066700E+03,.2189300E+03,.3313900E+03,& + & .4308300E+03,.4675300E+03,.4293200E+03,.3263400E+03,.1978800E+03,& + & .7184000E+02,.1057300E+03,.2180300E+03,.3305300E+03,.4296500E+03,& + & .4653200E+03,.4267700E+03,.3238600E+03,.1966900E+03,.7184000E+02/ + + data absa(451:585, 2) / & + & .1069400E+03,.2191100E+03,.3315200E+03,.4312700E+03,.4681600E+03,& + & .4300500E+03,.3270600E+03,.1982200E+03,.7184000E+02,.1057700E+03,& + & .2181500E+03,.3307400E+03,.4298400E+03,.4654100E+03,.4268700E+03,& + & .3239600E+03,.1967400E+03,.7184000E+02,.1047600E+03,.2172800E+03,& + & .3300000E+03,.4285500E+03,.4630100E+03,.4241100E+03,.3213000E+03,& + & .1954600E+03,.7184000E+02,.1038800E+03,.2164900E+03,.3292800E+03,& + & .4274100E+03,.4608900E+03,.4216900E+03,.3189700E+03,.1943500E+03,& + & .7184000E+02,.1031100E+03,.2157500E+03,.3285500E+03,.4263900E+03,& + & .4590200E+03,.4195400E+03,.3169200E+03,.1933800E+03,.7184000E+02,& + & .1041000E+03,.2166300E+03,.3293700E+03,.4277800E+03,.4614100E+03,& + & .4222900E+03,.3195500E+03,.1946300E+03,.7184000E+02,.1031400E+03,& + & .2158500E+03,.3287500E+03,.4265400E+03,.4590900E+03,.4196100E+03,& + & .3170000E+03,.1934100E+03,.7184000E+02,.1023100E+03,.2151500E+03,& + & .3281500E+03,.4254400E+03,.4570700E+03,.4172900E+03,.3148000E+03,& + & .1923600E+03,.7184000E+02,.1015900E+03,.2144900E+03,.3275400E+03,& + & .4244500E+03,.4553200E+03,.4152600E+03,.3128800E+03,.1914500E+03,& + & .7184000E+02,.1009600E+03,.2138700E+03,.3269200E+03,.4235600E+03,& + & .4537700E+03,.4134700E+03,.3111900E+03,.1906600E+03,.7184000E+02,& + & .1017700E+03,.2146000E+03,.3276100E+03,.4247500E+03,.4557500E+03,& + & .4157600E+03,.3133500E+03,.1916800E+03,.7184000E+02,.1009900E+03,& + & .2139700E+03,.3271200E+03,.4236800E+03,.4538300E+03,.4135300E+03,& + & .3112500E+03,.1906800E+03,.7184000E+02,.1003100E+03,.2134000E+03,& + & .3266300E+03,.4227200E+03,.4521600E+03,.4116000E+03,.3094300E+03,& + & .1898300E+03,.7184000E+02,.9972000E+02,.2128600E+03,.3261200E+03,& + & .4218700E+03,.4507100E+03,.4099100E+03,.3078500E+03,.1890800E+03,& + & .7184000E+02,.9920400E+02,.2123300E+03,.3255800E+03,.4211200E+03,& + & .4494200E+03,.4084200E+03,.3064600E+03,.1884300E+03,.7184000E+02/ + + data absa( 1:180, 3) / & + & .6511264E+03,.6329084E+03,.6146856E+03,.5966652E+03,.6074063E+03,& + & .6528610E+03,.5099603E+03,.3749181E+03,.2774131E+03,.6346287E+03,& + & .6184704E+03,.6023125E+03,.5863930E+03,.6020757E+03,.6446762E+03,& + & .4994119E+03,.3715684E+03,.2774131E+03,.6198152E+03,.6055045E+03,& + & .5912038E+03,.5771678E+03,.5973361E+03,.6369385E+03,.4900862E+03,& + & .3685614E+03,.2774131E+03,.6064342E+03,.5938030E+03,.5811717E+03,& + & .5688415E+03,.5930984E+03,.6294842E+03,.4817900E+03,.3658423E+03,& + & .2774131E+03,.5942932E+03,.5831782E+03,.5720635E+03,.5612806E+03,& + & .5892330E+03,.6221730E+03,.4743525E+03,.3633754E+03,.2774131E+03,& + & .6015146E+03,.5894958E+03,.5774770E+03,.5658111E+03,.5943788E+03,& + & .6267589E+03,.4787630E+03,.3648436E+03,.2774131E+03,.5873680E+03,& + & .5771175E+03,.5668670E+03,.5570576E+03,.5905502E+03,.6181492E+03,& + & .4701504E+03,.3619729E+03,.2774131E+03,.5746935E+03,.5660284E+03,& + & .5573637E+03,.5492284E+03,.5870483E+03,.6098467E+03,.4625325E+03,& + & .3594001E+03,.2774131E+03,.5632785E+03,.5560360E+03,.5487986E+03,& + & .5422048E+03,.5837067E+03,.6020593E+03,.4557839E+03,.3570844E+03,& + & .2774131E+03,.5529351E+03,.5469870E+03,.5410436E+03,.5358636E+03,& + & .5804343E+03,.5946671E+03,.4497552E+03,.3549858E+03,.2774131E+03,& + & .5625080E+03,.5553643E+03,.5482206E+03,.5421149E+03,.5857773E+03,& + & .6015260E+03,.4553353E+03,.3569280E+03,.2774131E+03,.5500901E+03,& + & .5445026E+03,.5389099E+03,.5346354E+03,.5824284E+03,.5925618E+03,& + & .4481108E+03,.3544056E+03,.2774131E+03,.5390110E+03,.5348064E+03,& + & .5306017E+03,.5279541E+03,.5791807E+03,.5842402E+03,.4417818E+03,& + & .3521607E+03,.2774131E+03,.5290630E+03,.5260980E+03,.5231382E+03,& + & .5219585E+03,.5760337E+03,.5766944E+03,.4361804E+03,.3501376E+03,& + & .2774131E+03,.5200781E+03,.5182394E+03,.5163958E+03,.5165553E+03,& + & .5729753E+03,.5696064E+03,.4311945E+03,.3483165E+03,.2774131E+03,& + & .5301497E+03,.5270514E+03,.5239531E+03,.5232218E+03,.5779936E+03,& + & .5775254E+03,.4367865E+03,.3503547E+03,.2774131E+03,.5191743E+03,& + & .5174492E+03,.5157190E+03,.5168800E+03,.5747472E+03,.5688802E+03,& + & .4306977E+03,.3481297E+03,.2774131E+03,.5094140E+03,.5089090E+03,& + & .5084039E+03,.5112313E+03,.5716791E+03,.5610450E+03,.4253723E+03,& + & .3461523E+03,.2774131E+03,.5006908E+03,.5012725E+03,.5018541E+03,& + & .5061415E+03,.5687148E+03,.5539480E+03,.4206699E+03,.3443815E+03,& + & .2774131E+03,.4928322E+03,.4944017E+03,.4959664E+03,.5015429E+03,& + & .5658453E+03,.5474233E+03,.4164958E+03,.3427822E+03,.2774131E+03/ + + data absa(181:315, 3) / & + & .5026617E+03,.5029964E+03,.5033359E+03,.5079576E+03,.5703975E+03,& + & .5555608E+03,.4217244E+03,.3447801E+03,.2774131E+03,.4929459E+03,& + & .4944957E+03,.4960504E+03,.5025983E+03,.5672753E+03,.5475129E+03,& + & .4165470E+03,.3428074E+03,.2774131E+03,.4843464E+03,.4869729E+03,& + & .4895995E+03,.4978824E+03,.5642908E+03,.5402030E+03,.4120341E+03,& + & .3410570E+03,.2774131E+03,.4766902E+03,.4802750E+03,.4838598E+03,& + & .4936340E+03,.5614813E+03,.5336150E+03,.4080600E+03,.3395081E+03,& + & .2774131E+03,.4698243E+03,.4742636E+03,.4787081E+03,.4897906E+03,& + & .5587886E+03,.5276339E+03,.4045435E+03,.3381108E+03,.2774131E+03,& + & .4796093E+03,.4828287E+03,.4860480E+03,.4958831E+03,.5631234E+03,& + & .5361276E+03,.4095724E+03,.3400983E+03,.2774131E+03,.4709554E+03,& + & .4752614E+03,.4795626E+03,.4913793E+03,.5601219E+03,.5286289E+03,& + & .4051219E+03,.3383427E+03,.2774131E+03,.4633537E+03,.4686031E+03,& + & .4738526E+03,.4874207E+03,.5572835E+03,.5219272E+03,.4012664E+03,& + & .3367990E+03,.2774131E+03,.4566014E+03,.4626954E+03,.4687945E+03,& + & .4838547E+03,.5545520E+03,.5159087E+03,.3978937E+03,.3354268E+03,& + & .2774131E+03,.4505703E+03,.4574252E+03,.4642700E+03,.4806076E+03,& + & .5519154E+03,.5104788E+03,.3949126E+03,.3342010E+03,.2774131E+03,& + & .4599800E+03,.4656593E+03,.4713286E+03,.4861245E+03,.5561434E+03,& + & .5189328E+03,.3995824E+03,.3361129E+03,.2774131E+03,.4522794E+03,& + & .4589169E+03,.4655493E+03,.4823660E+03,.5531814E+03,.5120152E+03,& + & .3957540E+03,.3345540E+03,.2774131E+03,.4455371E+03,.4530143E+03,& + & .4604964E+03,.4790627E+03,.5504387E+03,.5058908E+03,.3924488E+03,& + & .3331819E+03,.2774131E+03,.4395801E+03,.4478082E+03,.4560363E+03,& + & .4760716E+03,.5478683E+03,.5004584E+03,.3895600E+03,.3319712E+03,& + & .2774131E+03,.4342899E+03,.4431749E+03,.4520702E+03,.4733295E+03,& + & .5454191E+03,.4955934E+03,.3870166E+03,.3309017E+03,.2774131E+03/ + + data absa(316:450, 3) / & + & .4431908E+03,.4509594E+03,.4587381E+03,.4781967E+03,.5493562E+03,& + & .5037547E+03,.3913036E+03,.3327077E+03,.2774131E+03,.4363300E+03,& + & .4449580E+03,.4535964E+03,.4750441E+03,.5465445E+03,.4974754E+03,& + & .3879943E+03,.3313103E+03,.2774131E+03,.4303582E+03,.4397370E+03,& + & .4491215E+03,.4722875E+03,.5439163E+03,.4918909E+03,.3851474E+03,& + & .3301045E+03,.2774131E+03,.4251124E+03,.4351433E+03,.4451950E+03,& + & .4698098E+03,.5414411E+03,.4869096E+03,.3826759E+03,.3290350E+03,& + & .2774131E+03,.4204694E+03,.4310783E+03,.4417179E+03,.4675130E+03,& + & .5390622E+03,.4824898E+03,.3805037E+03,.3280966E+03,.2774131E+03,& + & .4288912E+03,.4384478E+03,.4480252E+03,.4717437E+03,.5428850E+03,& + & .4904977E+03,.3844535E+03,.3298019E+03,.2774131E+03,.4227713E+03,& + & .4330984E+03,.4434414E+03,.4691286E+03,.5401449E+03,.4846799E+03,& + & .3815770E+03,.3285608E+03,.2774131E+03,.4174811E+03,.4284602E+03,& + & .4394805E+03,.4668405E+03,.5375978E+03,.4796375E+03,.3791166E+03,& + & .3274861E+03,.2774131E+03,.4128529E+03,.4244148E+03,.4360182E+03,& + & .4647682E+03,.5352111E+03,.4752154E+03,.3769855E+03,.3265430E+03,& + & .2774131E+03,.4087727E+03,.4208485E+03,.4329611E+03,.4628378E+03,& + & .5329651E+03,.4713043E+03,.3751287E+03,.3257206E+03,.2774131E+03,& + & .4162315E+03,.4273735E+03,.4385419E+03,.4662891E+03,.5364495E+03,& + & .4784476E+03,.3785445E+03,.3272290E+03,.2774131E+03,.4108377E+03,& + & .4226565E+03,.4345069E+03,.4641370E+03,.5338298E+03,.4732874E+03,& + & .3760645E+03,.3261392E+03,.2774131E+03,.4061995E+03,.4185915E+03,& + & .4310298E+03,.4622539E+03,.5314356E+03,.4688122E+03,.3739650E+03,& + & .3251960E+03,.2774131E+03,.4021541E+03,.4150596E+03,.4280071E+03,& + & .4605480E+03,.5292326E+03,.4648804E+03,.3721593E+03,.3243736E+03,& + & .2774131E+03,.3986074E+03,.4119528E+03,.4253550E+03,.4589564E+03,& + & .5271755E+03,.4613869E+03,.3705866E+03,.3236571E+03,.2774131E+03/ + + data absa(451:585, 3) / & + & .4031715E+03,.4159438E+03,.4287676E+03,.4609884E+03,.5292837E+03,& + & .4658721E+03,.3726094E+03,.3245855E+03,.2774131E+03,.3987507E+03,& + & .4120761E+03,.4254586E+03,.4593570E+03,.5269580E+03,.4615362E+03,& + & .3706474E+03,.3236875E+03,.2774131E+03,.3949475E+03,.4087520E+03,& + & .4226140E+03,.4578984E+03,.5248194E+03,.4578690E+03,.3689687E+03,& + & .3229107E+03,.2774131E+03,.3916430E+03,.4058525E+03,.4201396E+03,& + & .4565441E+03,.5228408E+03,.4544830E+03,.3675280E+03,.3222398E+03,& + & .2774131E+03,.3887335E+03,.4033137E+03,.4179614E+03,.4552601E+03,& + & .5210222E+03,.4515774E+03,.3662647E+03,.3216544E+03,.2774131E+03,& + & .3924531E+03,.4065686E+03,.4207468E+03,.4569108E+03,.5228838E+03,& + & .4553196E+03,.3678766E+03,.3224061E+03,.2774131E+03,.3888324E+03,& + & .4034026E+03,.4180454E+03,.4556544E+03,.5208037E+03,.4516870E+03,& + & .3663098E+03,.3216696E+03,.2774131E+03,.3857204E+03,.4006760E+03,& + & .4157143E+03,.4545126E+03,.5188851E+03,.4485672E+03,.3649658E+03,& + & .3210391E+03,.2774131E+03,.3830138E+03,.3983049E+03,.4136846E+03,& + & .4534319E+03,.5171572E+03,.4458556E+03,.3638040E+03,.3204890E+03,& + & .2774131E+03,.3806279E+03,.3962256E+03,.4118963E+03,.4523829E+03,& + & .5156086E+03,.4434924E+03,.3627937E+03,.3200048E+03,.2774131E+03,& + & .3836807E+03,.3988929E+03,.4141833E+03,.4537401E+03,.5172110E+03,& + & .4465237E+03,.3640918E+03,.3206253E+03,.2774131E+03,.3807168E+03,& + & .3962996E+03,.4119655E+03,.4527776E+03,.5153732E+03,.4435721E+03,& + & .3628289E+03,.3200248E+03,.2774131E+03,.3781631E+03,.3940670E+03,& + & .4100595E+03,.4518853E+03,.5137515E+03,.4410437E+03,.3617483E+03,& + & .3195054E+03,.2774131E+03,.3759453E+03,.3921257E+03,.4084000E+03,& + & .4510200E+03,.5123154E+03,.4388535E+03,.3608140E+03,.3190564E+03,& + & .2774131E+03,.3739993E+03,.3904218E+03,.4069430E+03,.4501424E+03,& + & .5110249E+03,.4369317E+03,.3599960E+03,.3186578E+03,.2774131E+03/ + + data absa( 1:180, 4) / & + & .1490491E+04,.1320345E+04,.1150192E+04,.9800544E+03,.8098902E+03,& + & .7197150E+03,.6792147E+03,.7402425E+03,.8002384E+03,.1452731E+04,& + & .1287287E+04,.1121843E+04,.9564311E+03,.7910079E+03,.7120191E+03,& + & .6771483E+03,.7390036E+03,.7998958E+03,.1418780E+04,.1257599E+04,& + & .1096434E+04,.9352534E+03,.7740540E+03,.7025255E+03,.6751582E+03,& + & .7376910E+03,.7993864E+03,.1388200E+04,.1230836E+04,.1073482E+04,& + & .9161180E+03,.7587353E+03,.6923034E+03,.6731990E+03,.7363185E+03,& + & .7987103E+03,.1360397E+04,.1206504E+04,.1052610E+04,.8987339E+03,& + & .7448387E+03,.6822317E+03,.6712136E+03,.7348370E+03,.7978722E+03,& + & .1376903E+04,.1220978E+04,.1065010E+04,.9090577E+03,.7531056E+03,& + & .6894651E+03,.6733436E+03,.7372884E+03,.8003310E+03,.1344538E+04,& + & .1192629E+04,.1040735E+04,.8888218E+03,.7369143E+03,.6768296E+03,& + & .6715747E+03,.7362303E+03,.8000578E+03,.1315550E+04,.1167251E+04,& + & .1018964E+04,.8706883E+03,.7224512E+03,.6656647E+03,.6698697E+03,& + & .7351070E+03,.7996179E+03,.1289379E+04,.1144358E+04,.9993773E+03,& + & .8543538E+03,.7095866E+03,.6560533E+03,.6681935E+03,.7339123E+03,& + & .7990113E+03,.1265740E+04,.1123642E+04,.9815969E+03,.8395554E+03,& + & .6981281E+03,.6477726E+03,.6664850E+03,.7326277E+03,.7982380E+03,& + & .1287647E+04,.1142819E+04,.9980492E+03,.8532534E+03,.7089617E+03,& + & .6555751E+03,.6687079E+03,.7349497E+03,.8004236E+03,.1259199E+04,& + & .1117994E+04,.9767252E+03,.8354916E+03,.6953763E+03,.6460584E+03,& + & .6671911E+03,.7340872E+03,.8002431E+03,.1233874E+04,.1095802E+04,& + & .9576897E+03,.8196373E+03,.6835316E+03,.6380393E+03,.6657230E+03,& + & .7331401E+03,.7999004E+03,.1211081E+04,.1075833E+04,.9406536E+03,& + & .8054044E+03,.6731147E+03,.6310221E+03,.6642968E+03,.7321310E+03,& + & .7993957E+03,.1190512E+04,.1057848E+04,.9251886E+03,.7925536E+03,& + & .6639048E+03,.6250737E+03,.6628407E+03,.7310159E+03,.7987242E+03,& + & .1213605E+04,.1078027E+04,.9425174E+03,.8069604E+03,.6747932E+03,& + & .6317831E+03,.6648333E+03,.7329850E+03,.8004607E+03,.1188427E+04,& + & .1056052E+04,.9236605E+03,.7912500E+03,.6637826E+03,.6247883E+03,& + & .6635334E+03,.7322842E+03,.8003773E+03,.1166126E+04,.1036497E+04,& + & .9069190E+03,.7772941E+03,.6542493E+03,.6188027E+03,.6622900E+03,& + & .7315166E+03,.8001412E+03,.1146104E+04,.1019036E+04,.8919134E+03,& + & .7648103E+03,.6459064E+03,.6135679E+03,.6610584E+03,.7306623E+03,& + & .7997430E+03,.1128166E+04,.1003292E+04,.8784385E+03,.7535801E+03,& + & .6385155E+03,.6090063E+03,.6598247E+03,.7297259E+03,.7991780E+03/ + + data absa(181:315, 4) / & + & .1150667E+04,.1022958E+04,.8952985E+03,.7676352E+03,.6485262E+03,& + & .6146217E+03,.6614995E+03,.7312576E+03,.8004375E+03,.1128412E+04,& + & .1003487E+04,.8786170E+03,.7537286E+03,.6397248E+03,.6092128E+03,& + & .6603950E+03,.7307176E+03,.8004468E+03,.1108741E+04,.9862884E+03,& + & .8638632E+03,.7414333E+03,.6321640E+03,.6047173E+03,.6593415E+03,& + & .7301049E+03,.8003079E+03,.1091213E+04,.9709590E+03,.8507153E+03,& + & .7304755E+03,.6255493E+03,.6008338E+03,.6583092E+03,.7294008E+03,& + & .8000115E+03,.1075469E+04,.9572202E+03,.8389248E+03,.7206527E+03,& + & .6197031E+03,.5974555E+03,.6572486E+03,.7286139E+03,.7995531E+03,& + & .1097870E+04,.9768019E+03,.8557256E+03,.7346486E+03,.6288307E+03,& + & .6020713E+03,.6586595E+03,.7297565E+03,.8003542E+03,.1078052E+04,& + & .9594624E+03,.8408779E+03,.7222787E+03,.6218550E+03,.5979982E+03,& + & .6577350E+03,.7293614E+03,.8004561E+03,.1060670E+04,.9442276E+03,& + & .8278139E+03,.7113901E+03,.6158860E+03,.5946078E+03,.6568508E+03,& + & .7288896E+03,.8004144E+03,.1045194E+04,.9306942E+03,.8162219E+03,& + & .7017312E+03,.6107127E+03,.5916997E+03,.6559770E+03,.7283342E+03,& + & .8002199E+03,.1031388E+04,.9186406E+03,.8058789E+03,.6931126E+03,& + & .6061547E+03,.5891687E+03,.6550888E+03,.7276821E+03,.7998680E+03,& + & .1052963E+04,.9374921E+03,.8220302E+03,.7065729E+03,.6139864E+03,& + & .5928231E+03,.6561758E+03,.7284058E+03,.8001736E+03,.1035335E+04,& + & .9220734E+03,.8088077E+03,.6955512E+03,.6085341E+03,.5897484E+03,& + & .6554522E+03,.7281509E+03,.8004051E+03,.1019870E+04,.9085454E+03,& + & .7972311E+03,.6859069E+03,.6038862E+03,.5871960E+03,.6547087E+03,& + & .7278186E+03,.8004607E+03,.1006236E+04,.8966542E+03,.7870120E+03,& + & .6773876E+03,.5998494E+03,.5849802E+03,.6539834E+03,.7273980E+03,& + & .8003588E+03,.9941610E+03,.8860349E+03,.7779226E+03,.6698202E+03,& + & .5962793E+03,.5830334E+03,.6532431E+03,.7268747E+03,.8001088E+03/ + + data absa(316:450, 4) / & + & .1014525E+04,.9038521E+03,.7932066E+03,.6825518E+03,.6028710E+03,& + & .5859051E+03,.6539946E+03,.7271787E+03,.7999513E+03,.9987919E+03,& + & .8901187E+03,.7814262E+03,.6727344E+03,.5986427E+03,.5835388E+03,& + & .6534210E+03,.7270632E+03,.8002847E+03,.9851423E+03,.8781550E+03,& + & .7711724E+03,.6641905E+03,.5950831E+03,.5816419E+03,.6528439E+03,& + & .7268557E+03,.8004468E+03,.9731156E+03,.8676435E+03,.7621676E+03,& + & .6566870E+03,.5920005E+03,.5800708E+03,.6522571E+03,.7265599E+03,& + & .8004375E+03,.9624848E+03,.8583463E+03,.7541885E+03,.6500361E+03,& + & .5892896E+03,.5786674E+03,.6516491E+03,.7261614E+03,.8002755E+03,& + & .9817773E+03,.8752109E+03,.7686499E+03,.6620890E+03,.5946884E+03,& + & .5807066E+03,.6520760E+03,.7260596E+03,.7996781E+03,.9677814E+03,& + & .8629603E+03,.7581484E+03,.6533365E+03,.5914754E+03,.5790226E+03,& + & .6516633E+03,.7260782E+03,.8001134E+03,.9556546E+03,.8523548E+03,& + & .7490543E+03,.6457592E+03,.5888086E+03,.5776101E+03,.6512193E+03,& + & .7259955E+03,.8003773E+03,.9450453E+03,.8430869E+03,.7411152E+03,& + & .6391429E+03,.5865198E+03,.5764053E+03,.6507649E+03,.7258146E+03,& + & .8004607E+03,.9357266E+03,.8349146E+03,.7341173E+03,.6333100E+03,& + & .5843768E+03,.5753367E+03,.6502809E+03,.7255256E+03,.8003866E+03,& + & .9528090E+03,.8498570E+03,.7469182E+03,.6439800E+03,.5885144E+03,& + & .5767160E+03,.6503433E+03,.7250381E+03,.7994049E+03,.9404359E+03,& + & .8390577E+03,.7376609E+03,.6362634E+03,.5861145E+03,.5754558E+03,& + & .6500784E+03,.7251769E+03,.7999235E+03,.9298105E+03,.8297558E+03,& + & .7296865E+03,.6296179E+03,.5839417E+03,.5744210E+03,.6497768E+03,& + & .7252044E+03,.8002708E+03,.9205811E+03,.8216675E+03,.7227532E+03,& + & .6238388E+03,.5819578E+03,.5735632E+03,.6494410E+03,.7251291E+03,& + & .8004422E+03,.9124496E+03,.8145610E+03,.7166625E+03,.6187693E+03,& + & .5800439E+03,.5728294E+03,.6490647E+03,.7249410E+03,.8004422E+03/ + + data absa(451:585, 4) / & + & .9228965E+03,.8236997E+03,.7244976E+03,.6252963E+03,.5826587E+03,& + & .5732062E+03,.6487682E+03,.7242367E+03,.7994003E+03,.9127905E+03,& + & .8148481E+03,.7169103E+03,.6189724E+03,.5806411E+03,.5724380E+03,& + & .6486216E+03,.7244324E+03,.7999189E+03,.9040966E+03,.8072260E+03,& + & .7103786E+03,.6135258E+03,.5787682E+03,.5716879E+03,.6484230E+03,& + & .7245206E+03,.8002662E+03,.8965007E+03,.8005998E+03,.7046989E+03,& + & .6087980E+03,.5770291E+03,.5712760E+03,.6481694E+03,.7244914E+03,& + & .8004422E+03,.8898544E+03,.7947815E+03,.6997086E+03,.6046349E+03,& + & .5752976E+03,.5708062E+03,.6478707E+03,.7243347E+03,.8004422E+03,& + & .8983644E+03,.8022304E+03,.7060963E+03,.6099576E+03,.5774937E+03,& + & .5708077E+03,.6474759E+03,.7235789E+03,.7994003E+03,.8901061E+03,& + & .7949847E+03,.6998817E+03,.6047834E+03,.5757149E+03,.5704095E+03,& + & .6474223E+03,.7238307E+03,.7999235E+03,.8829565E+03,.7887454E+03,& + & .6945344E+03,.6003279E+03,.5739676E+03,.5700508E+03,.6473059E+03,& + & .7239504E+03,.8002662E+03,.8767566E+03,.7833188E+03,.6898858E+03,& + & .5964527E+03,.5721368E+03,.5697050E+03,.6471298E+03,.7239527E+03,& + & .8004422E+03,.8713100E+03,.7785510E+03,.6858020E+03,.5930430E+03,& + & .5702838E+03,.5693558E+03,.6468926E+03,.7238360E+03,.8004422E+03,& + & .8782779E+03,.7846517E+03,.6910308E+03,.5974092E+03,.5724839E+03,& + & .5692167E+03,.6464156E+03,.7230395E+03,.7994003E+03,.8714985E+03,& + & .7787195E+03,.6859459E+03,.5931669E+03,.5705842E+03,.5689690E+03,& + & .6464442E+03,.7233274E+03,.7999235E+03,.8656602E+03,.7736099E+03,& + & .6815696E+03,.5895194E+03,.5686553E+03,.5687141E+03,.6463947E+03,& + & .7234879E+03,.8002708E+03,.8605853E+03,.7691745E+03,.6777583E+03,& + & .5863474E+03,.5667574E+03,.5684512E+03,.6462754E+03,.7235209E+03,& + & .8004422E+03,.8561252E+03,.7652692E+03,.6744132E+03,.5835572E+03,& + & .5649152E+03,.5681796E+03,.6460944E+03,.7234350E+03,.8004422E+03/ + + data absa( 1:180, 5) / & + & .1921397E+04,.1686175E+04,.1450918E+04,.1215651E+04,.9804589E+03,& + & .7485868E+03,.8483659E+03,.9768410E+03,.1106468E+04,.1872699E+04,& + & .1643569E+04,.1414370E+04,.1185266E+04,.9561203E+03,.7344024E+03,& + & .8467260E+03,.9754207E+03,.1105202E+04,.1828966E+04,.1605287E+04,& + & .1381610E+04,.1157925E+04,.9342532E+03,.7247494E+03,.8449271E+03,& + & .9738067E+03,.1103587E+04,.1789486E+04,.1570750E+04,.1351993E+04,& + & .1133258E+04,.9145250E+03,.7183685E+03,.8429653E+03,.9719387E+03,& + & .1101677E+04,.1753694E+04,.1539382E+04,.1325155E+04,.1110855E+04,& + & .8966094E+03,.7139851E+03,.8408707E+03,.9698995E+03,.1099550E+04,& + & .1775002E+04,.1558008E+04,.1341156E+04,.1124178E+04,.9072693E+03,& + & .7199288E+03,.8471982E+03,.9765647E+03,.1106903E+04,.1733216E+04,& + & .1521534E+04,.1309834E+04,.1098091E+04,.8863907E+03,.7174123E+03,& + & .8457590E+03,.9752894E+03,.1105710E+04,.1695794E+04,.1488814E+04,& + & .1281745E+04,.1074723E+04,.8676958E+03,.7156385E+03,.8441368E+03,& + & .9737966E+03,.1104271E+04,.1662143E+04,.1459341E+04,.1256502E+04,& + & .1053659E+04,.8508412E+03,.7137237E+03,.8423258E+03,.9720960E+03,& + & .1102513E+04,.1631619E+04,.1432618E+04,.1233592E+04,.1034579E+04,& + & .8355734E+03,.7116486E+03,.8403867E+03,.9701499E+03,.1100500E+04,& + & .1659891E+04,.1457315E+04,.1254812E+04,.1052240E+04,.8497202E+03,& + & .7175527E+03,.8464715E+03,.9765415E+03,.1107518E+04,.1623228E+04,& + & .1425304E+04,.1227301E+04,.1029375E+04,.8314009E+03,.7161499E+03,& + & .8452402E+03,.9754612E+03,.1106487E+04,.1590539E+04,.1396639E+04,& + & .1202788E+04,.1008908E+04,.8150480E+03,.7145901E+03,.8438213E+03,& + & .9741374E+03,.1105224E+04,.1561180E+04,.1371014E+04,.1180792E+04,& + & .9905638E+03,.8003605E+03,.7128878E+03,.8422042E+03,.9726066E+03,& + & .1103635E+04,.1534665E+04,.1347786E+04,.1160902E+04,.9740042E+03,& + & .7871058E+03,.7110306E+03,.8404136E+03,.9708259E+03,.1101753E+04,& + & .1564387E+04,.1373801E+04,.1183199E+04,.9925688E+03,.8019746E+03,& + & .7163274E+03,.8458907E+03,.9765642E+03,.1107990E+04,.1532032E+04,& + & .1345436E+04,.1158880E+04,.9723223E+03,.7857601E+03,.7151483E+03,& + & .8448704E+03,.9756467E+03,.1107164E+04,.1503216E+04,.1320225E+04,& + & .1137324E+04,.9543379E+03,.7713655E+03,.7138061E+03,.8436484E+03,& + & .9745256E+03,.1106074E+04,.1477480E+04,.1297700E+04,.1117987E+04,& + & .9382370E+03,.7585035E+03,.7123059E+03,.8422273E+03,.9731665E+03,& + & .1104675E+04,.1454275E+04,.1277417E+04,.1100599E+04,.9237584E+03,& + & .7469097E+03,.7106555E+03,.8406082E+03,.9715630E+03,.1103011E+04/ + + data absa(181:315, 5) / & + & .1483270E+04,.1302824E+04,.1122346E+04,.9418665E+03,.7613975E+03,& + & .7152456E+03,.8453518E+03,.9765193E+03,.1108347E+04,.1454554E+04,& + & .1277730E+04,.1100817E+04,.9239508E+03,.7470711E+03,.7142698E+03,& + & .8445296E+03,.9757838E+03,.1107704E+04,.1429277E+04,.1255537E+04,& + & .1081803E+04,.9080984E+03,.7343933E+03,.7131346E+03,.8435047E+03,& + & .9748486E+03,.1106819E+04,.1406637E+04,.1235745E+04,.1064862E+04,& + & .8939670E+03,.7230809E+03,.7118341E+03,.8422567E+03,.9736530E+03,& + & .1105584E+04,.1386352E+04,.1217991E+04,.1049654E+04,.8813175E+03,& + & .7129541E+03,.7103644E+03,.8408216E+03,.9722114E+03,.1104099E+04,& + & .1415280E+04,.1243273E+04,.1071368E+04,.8993573E+03,.7273941E+03,& + & .7142932E+03,.8448580E+03,.9764281E+03,.1108541E+04,.1389733E+04,& + & .1220958E+04,.1052188E+04,.8834056E+03,.7146427E+03,.7135269E+03,& + & .8442338E+03,.9758859E+03,.1108141E+04,.1367294E+04,.1201275E+04,& + & .1035372E+04,.8693794E+03,.7034205E+03,.7125886E+03,.8433949E+03,& + & .9751144E+03,.1107408E+04,.1347369E+04,.1183915E+04,.1020401E+04,& + & .8569345E+03,.6934430E+03,.7114752E+03,.8423448E+03,.9741143E+03,& + & .1106423E+04,.1329578E+04,.1168334E+04,.1007064E+04,.8458218E+03,& + & .6845663E+03,.7101924E+03,.8410834E+03,.9728599E+03,.1105097E+04,& + & .1357347E+04,.1192598E+04,.1027874E+04,.8631699E+03,.6984448E+03,& + & .7134207E+03,.8443831E+03,.9763011E+03,.1108758E+04,.1334644E+04,& + & .1172715E+04,.1010833E+04,.8489539E+03,.6870762E+03,.7128438E+03,& + & .8439045E+03,.9759286E+03,.1108430E+04,.1314672E+04,.1155279E+04,& + & .9959069E+03,.8365335E+03,.6771252E+03,.7120902E+03,.8432747E+03,& + & .9753288E+03,.1107888E+04,.1297153E+04,.1139973E+04,.9827356E+03,& + & .8255379E+03,.6683354E+03,.7111590E+03,.8424009E+03,.9744943E+03,& + & .1107103E+04,.1281549E+04,.1126289E+04,.9710294E+03,.8157849E+03,& + & .6605299E+03,.7100490E+03,.8413065E+03,.9734035E+03,.1105937E+04/ + + data absa(316:450, 5) / & + & .1307799E+04,.1149258E+04,.9907270E+03,.8322002E+03,.6736660E+03,& + & .7126027E+03,.8439097E+03,.9761135E+03,.1108805E+04,.1287540E+04,& + & .1131537E+04,.9755603E+03,.8195432E+03,.6635490E+03,.7122058E+03,& + & .8436121E+03,.9758993E+03,.1108673E+04,.1269927E+04,.1116126E+04,& + & .9623208E+03,.8085370E+03,.6547258E+03,.7116273E+03,.8431237E+03,& + & .9754680E+03,.1108244E+04,.1254438E+04,.1102594E+04,.9507274E+03,& + & .7988474E+03,.6469982E+03,.7108636E+03,.8424204E+03,.9747864E+03,& + & .1107597E+04,.1240737E+04,.1090596E+04,.9404282E+03,.7903006E+03,& + & .6401369E+03,.7099113E+03,.8414889E+03,.9738621E+03,.1106649E+04,& + & .1265622E+04,.1112367E+04,.9590789E+03,.8058196E+03,.6525657E+03,& + & .7118328E+03,.8434406E+03,.9758605E+03,.1108716E+04,.1247560E+04,& + & .1096553E+04,.9455416E+03,.7945397E+03,.6435460E+03,.7116013E+03,& + & .8432871E+03,.9758224E+03,.1108744E+04,.1231894E+04,.1082859E+04,& + & .9338167E+03,.7847896E+03,.6357324E+03,.7111927E+03,.8429522E+03,& + & .9755286E+03,.1108560E+04,.1218302E+04,.1070950E+04,.9235833E+03,& + & .7762412E+03,.6289015E+03,.7105830E+03,.8424056E+03,.9749952E+03,& + & .1108010E+04,.1206262E+04,.1060398E+04,.9145570E+03,.7687192E+03,& + & .6229813E+03,.7097942E+03,.8416349E+03,.9742335E+03,.1107264E+04,& + & .1228234E+04,.1079659E+04,.9310619E+03,.7824865E+03,.6338926E+03,& + & .7111057E+03,.8429845E+03,.9755941E+03,.1108579E+04,.1212319E+04,& + & .1065758E+04,.9191269E+03,.7725251E+03,.6260392E+03,.7110095E+03,& + & .8429498E+03,.9756589E+03,.1108771E+04,.1198612E+04,.1053738E+04,& + & .9088499E+03,.7639808E+03,.6194625E+03,.7107383E+03,.8427382E+03,& + & .9755143E+03,.1108675E+04,.1186692E+04,.1043289E+04,.8999106E+03,& + & .7565209E+03,.6138184E+03,.7102789E+03,.8423199E+03,.9751033E+03,& + & .1108322E+04,.1176220E+04,.1034168E+04,.8920570E+03,.7499699E+03,& + & .6090103E+03,.7096231E+03,.8416809E+03,.9744656E+03,.1107679E+04/ + + data absa(451:585, 5) / & + & .1189698E+04,.1045913E+04,.9021705E+03,.7583950E+03,.6153540E+03,& + & .7104698E+03,.8425981E+03,.9754239E+03,.1108576E+04,.1176635E+04,& + & .1034523E+04,.8923869E+03,.7502341E+03,.6094352E+03,.7104222E+03,& + & .8425962E+03,.9755058E+03,.1108734E+04,.1165429E+04,.1024685E+04,& + & .8839611E+03,.7432232E+03,.6045181E+03,.7101914E+03,.8424044E+03,& + & .9753409E+03,.1108675E+04,.1155697E+04,.1016166E+04,.8766431E+03,& + & .7371151E+03,.6003622E+03,.7097679E+03,.8420139E+03,.9749621E+03,& + & .1108322E+04,.1147121E+04,.1008658E+04,.8702118E+03,.7317633E+03,& + & .5967883E+03,.7091490E+03,.8413991E+03,.9743362E+03,.1107679E+04,& + & .1158071E+04,.1018256E+04,.8784521E+03,.7386226E+03,.6015990E+03,& + & .7099541E+03,.8422884E+03,.9752818E+03,.1108579E+04,.1147403E+04,& + & .1008908E+04,.8704370E+03,.7319491E+03,.5971897E+03,.7099414E+03,& + & .8423049E+03,.9753726E+03,.1108766E+04,.1138174E+04,.1000855E+04,& + & .8635459E+03,.7261979E+03,.5935081E+03,.7097458E+03,.8421398E+03,& + & .9752320E+03,.1108695E+04,.1130203E+04,.9938656E+03,.8575435E+03,& + & .7212024E+03,.5905613E+03,.7093511E+03,.8417643E+03,.9748491E+03,& + & .1108322E+04,.1123201E+04,.9877521E+03,.8522707E+03,.7168232E+03,& + & .5880771E+03,.7087599E+03,.8411666E+03,.9742254E+03,.1107679E+04,& + & .1132182E+04,.9955937E+03,.8590183E+03,.7224580E+03,.5914804E+03,& + & .7095304E+03,.8420290E+03,.9751646E+03,.1108576E+04,.1123422E+04,& + & .9879637E+03,.8524632E+03,.7169730E+03,.5885566E+03,.7095493E+03,& + & .8420734E+03,.9752650E+03,.1108766E+04,.1115932E+04,.9813727E+03,& + & .8468160E+03,.7122910E+03,.5862722E+03,.7093820E+03,.8419175E+03,& + & .9751333E+03,.1108697E+04,.1109330E+04,.9756452E+03,.8419083E+03,& + & .7081783E+03,.5843612E+03,.7090122E+03,.8415604E+03,.9747502E+03,& + & .1108322E+04,.1103600E+04,.9706010E+03,.8376039E+03,.7045930E+03,& + & .5827075E+03,.7084398E+03,.8409654E+03,.9741292E+03,.1107699E+04/ + + data absa( 1:180, 6) / & + & .1959531E+04,.1718854E+04,.1478161E+04,.1237527E+04,.9965716E+03,& + & .7556952E+03,.8878598E+03,.1025441E+04,.1163518E+04,.1910117E+04,& + & .1675238E+04,.1441129E+04,.1206451E+04,.9715933E+03,.7486894E+03,& + & .8856157E+03,.1023242E+04,.1161590E+04,.1865741E+04,.1636653E+04,& + & .1407543E+04,.1178524E+04,.9494810E+03,.7463519E+03,.8833101E+03,& + & .1021156E+04,.1159586E+04,.1825329E+04,.1601414E+04,.1377281E+04,& + & .1153436E+04,.9292048E+03,.7441661E+03,.8810616E+03,.1019015E+04,& + & .1157664E+04,.1788734E+04,.1569552E+04,.1349728E+04,.1130211E+04,& + & .9109703E+03,.7423144E+03,.8791860E+03,.1017194E+04,.1156120E+04,& + & .1810667E+04,.1588518E+04,.1365889E+04,.1144195E+04,.9217339E+03,& + & .7496752E+03,.8873525E+03,.1025601E+04,.1164351E+04,.1767935E+04,& + & .1551019E+04,.1334009E+04,.1117420E+04,.9004784E+03,.7475656E+03,& + & .8852456E+03,.1023476E+04,.1162461E+04,.1730070E+04,.1517401E+04,& + & .1305332E+04,.1093709E+04,.8814078E+03,.7453610E+03,.8830458E+03,& + & .1021470E+04,.1160440E+04,.1695360E+04,.1487399E+04,.1279829E+04,& + & .1072014E+04,.8642946E+03,.7431708E+03,.8808442E+03,.1019364E+04,& + & .1158466E+04,.1664351E+04,.1460274E+04,.1256503E+04,.1052675E+04,& + & .8488905E+03,.7412704E+03,.8787936E+03,.1017361E+04,.1156598E+04,& + & .1692847E+04,.1485753E+04,.1277843E+04,.1070752E+04,.8629425E+03,& + & .7489667E+03,.8873589E+03,.1026231E+04,.1165463E+04,.1655805E+04,& + & .1452438E+04,.1250044E+04,.1047170E+04,.8442632E+03,.7470728E+03,& + & .8854219E+03,.1024283E+04,.1163647E+04,.1622518E+04,.1423594E+04,& + & .1225186E+04,.1026305E+04,.8276242E+03,.7450344E+03,.8833410E+03,& + & .1022268E+04,.1161651E+04,.1592305E+04,.1397067E+04,.1202289E+04,& + & .1007702E+04,.8128099E+03,.7429351E+03,.8811642E+03,.1020198E+04,& + & .1159643E+04,.1565538E+04,.1374036E+04,.1182269E+04,.9906999E+03,& + & .7993235E+03,.7408812E+03,.8791490E+03,.1018131E+04,.1157722E+04,& + & .1595853E+04,.1400292E+04,.1205058E+04,.1009761E+04,.8142929E+03,& + & .7485108E+03,.8875129E+03,.1026919E+04,.1166552E+04,.1562424E+04,& + & .1371454E+04,.1180385E+04,.9891526E+03,.7980135E+03,.7468116E+03,& + & .8857444E+03,.1025101E+04,.1164785E+04,.1533329E+04,.1345902E+04,& + & .1157909E+04,.9706094E+03,.7833915E+03,.7449296E+03,.8838178E+03,& + & .1023113E+04,.1162949E+04,.1506815E+04,.1322783E+04,.1138509E+04,& + & .9542707E+03,.7700244E+03,.7429706E+03,.8817581E+03,.1021134E+04,& + & .1160909E+04,.1483525E+04,.1302151E+04,.1120847E+04,.9395369E+03,& + & .7583538E+03,.7409557E+03,.8796852E+03,.1019111E+04,.1158929E+04/ + + data absa(181:315, 6) / & + & .1513129E+04,.1327990E+04,.1143143E+04,.9581972E+03,.7731973E+03,& + & .7481396E+03,.8876647E+03,.1027513E+04,.1167635E+04,.1483937E+04,& + & .1302350E+04,.1121247E+04,.9397374E+03,.7584554E+03,.7466326E+03,& + & .8860686E+03,.1025860E+04,.1165939E+04,.1457483E+04,.1279624E+04,& + & .1101680E+04,.9236394E+03,.7454131E+03,.7449496E+03,.8842965E+03,& + & .1024016E+04,.1164125E+04,.1434740E+04,.1259742E+04,.1084277E+04,& + & .9093323E+03,.7341125E+03,.7431059E+03,.8823611E+03,.1022090E+04,& + & .1162195E+04,.1414268E+04,.1241399E+04,.1069062E+04,.8962430E+03,& + & .7237532E+03,.7411783E+03,.8803301E+03,.1020088E+04,.1160046E+04,& + & .1443413E+04,.1267263E+04,.1090769E+04,.9146514E+03,.7383327E+03,& + & .7478733E+03,.8878478E+03,.1028105E+04,.1168673E+04,.1417362E+04,& + & .1244305E+04,.1071260E+04,.8985200E+03,.7252711E+03,.7465473E+03,& + & .8864251E+03,.1026618E+04,.1167048E+04,.1394536E+04,.1224485E+04,& + & .1054035E+04,.8840393E+03,.7137145E+03,.7450404E+03,.8848148E+03,& + & .1024911E+04,.1165266E+04,.1374225E+04,.1206403E+04,.1039030E+04,& + & .8713103E+03,.7039093E+03,.7433577E+03,.8830245E+03,.1023032E+04,& + & .1163474E+04,.1355994E+04,.1190773E+04,.1025482E+04,.8599459E+03,& + & .6945499E+03,.7415048E+03,.8810884E+03,.1021122E+04,.1161496E+04,& + & .1384460E+04,.1215767E+04,.1046795E+04,.8776721E+03,.7087541E+03,& + & .7476361E+03,.8879985E+03,.1028620E+04,.1169529E+04,.1361124E+04,& + & .1195393E+04,.1029345E+04,.8633440E+03,.6972452E+03,.7464861E+03,& + & .8867535E+03,.1027287E+04,.1168092E+04,.1341125E+04,.1177698E+04,& + & .1014028E+04,.8503722E+03,.6871520E+03,.7451498E+03,.8852979E+03,& + & .1025745E+04,.1166403E+04,.1323047E+04,.1161999E+04,.1000760E+04,& + & .8395248E+03,.6782983E+03,.7436254E+03,.8836587E+03,.1024005E+04,& + & .1164622E+04,.1306967E+04,.1147930E+04,.9887562E+03,.8294106E+03,& + & .6702789E+03,.7419326E+03,.8818404E+03,.1022008E+04,.1162734E+04/ + + data absa(316:450, 6) / & + & .1334109E+04,.1171345E+04,.1008923E+04,.8461200E+03,.6835456E+03,& + & .7474174E+03,.8881153E+03,.1029011E+04,.1170451E+04,.1313327E+04,& + & .1153250E+04,.9930497E+03,.8333106E+03,.6731748E+03,.7464228E+03,& + & .8870239E+03,.1027877E+04,.1168986E+04,.1295219E+04,.1137547E+04,& + & .9799434E+03,.8219514E+03,.6643371E+03,.7452458E+03,.8857278E+03,& + & .1026491E+04,.1167438E+04,.1279553E+04,.1123751E+04,.9678431E+03,& + & .8123012E+03,.6562950E+03,.7438793E+03,.8842286E+03,.1024816E+04,& + & .1165703E+04,.1265724E+04,.1111449E+04,.9576137E+03,.8031933E+03,& + & .6494532E+03,.7423259E+03,.8825429E+03,.1023034E+04,.1163868E+04,& + & .1290515E+04,.1133583E+04,.9764835E+03,.8192474E+03,.6620508E+03,& + & .7472103E+03,.8882292E+03,.1029567E+04,.1171352E+04,.1272606E+04,& + & .1117592E+04,.9626389E+03,.8077755E+03,.6527492E+03,.7463629E+03,& + & .8872547E+03,.1028405E+04,.1169825E+04,.1256652E+04,.1103698E+04,& + & .9508267E+03,.7976036E+03,.6448586E+03,.7453404E+03,.8861112E+03,& + & .1027107E+04,.1168295E+04,.1242559E+04,.1091491E+04,.9403080E+03,& + & .7891129E+03,.6378974E+03,.7441189E+03,.8847532E+03,.1025673E+04,& + & .1166733E+04,.1230258E+04,.1080509E+04,.9310347E+03,.7814702E+03,& + & .6317827E+03,.7427070E+03,.8832010E+03,.1023957E+04,.1164903E+04,& + & .1252792E+04,.1100066E+04,.9479412E+03,.7952615E+03,.6429338E+03,& + & .7470122E+03,.8882931E+03,.1029973E+04,.1172174E+04,.1236775E+04,& + & .1086029E+04,.9357359E+03,.7854390E+03,.6347013E+03,.7462389E+03,& + & .8873859E+03,.1028765E+04,.1170458E+04,.1222725E+04,.1073962E+04,& + & .9252515E+03,.7763294E+03,.6276457E+03,.7453420E+03,.8863540E+03,& + & .1027586E+04,.1169067E+04,.1210413E+04,.1063428E+04,.9161707E+03,& + & .7689610E+03,.6219689E+03,.7442455E+03,.8851226E+03,.1026224E+04,& + & .1167546E+04,.1199891E+04,.1053872E+04,.9082626E+03,.7623785E+03,& + & .6166061E+03,.7429574E+03,.8836539E+03,.1024662E+04,.1165837E+04/ + + data absa(451:585, 6) / & + & .1213435E+04,.1066122E+04,.9182536E+03,.7707858E+03,.6233804E+03,& + & .7465268E+03,.8879869E+03,.1029819E+04,.1172194E+04,.1200202E+04,& + & .1054292E+04,.9083498E+03,.7627042E+03,.6165912E+03,.7457906E+03,& + & .8870951E+03,.1028665E+04,.1170524E+04,.1188659E+04,.1044342E+04,& + & .8998639E+03,.7554328E+03,.6110074E+03,.7449213E+03,.8860867E+03,& + & .1027451E+04,.1169072E+04,.1178858E+04,.1035658E+04,.8922892E+03,& + & .7492634E+03,.6059606E+03,.7438596E+03,.8848729E+03,.1026124E+04,& + & .1167566E+04,.1169796E+04,.1027749E+04,.8857341E+03,.7436862E+03,& + & .6022412E+03,.7425912E+03,.8834588E+03,.1024571E+04,.1165837E+04,& + & .1181101E+04,.1037633E+04,.8940681E+03,.7506851E+03,.6074386E+03,& + & .7461265E+03,.8877353E+03,.1029711E+04,.1172179E+04,.1170091E+04,& + & .1028027E+04,.8859634E+03,.7439636E+03,.6039202E+03,.7454203E+03,& + & .8868566E+03,.1028531E+04,.1170527E+04,.1161160E+04,.1020142E+04,& + & .8789356E+03,.7381596E+03,.6035305E+03,.7445721E+03,.8858628E+03,& + & .1027386E+04,.1169067E+04,.1152818E+04,.1012820E+04,.8728840E+03,& + & .7330614E+03,.6026851E+03,.7435297E+03,.8846310E+03,.1025991E+04,& + & .1167566E+04,.1145364E+04,.1006499E+04,.8676452E+03,.7284487E+03,& + & .6016648E+03,.7422863E+03,.8832630E+03,.1024470E+04,.1165837E+04,& + & .1154769E+04,.1014599E+04,.8744908E+03,.7339035E+03,.6044416E+03,& + & .7457969E+03,.8875272E+03,.1029611E+04,.1172169E+04,.1146093E+04,& + & .1006648E+04,.8677377E+03,.7287407E+03,.6038007E+03,.7451183E+03,& + & .8866614E+03,.1028431E+04,.1170524E+04,.1138431E+04,.1000012E+04,& + & .8620420E+03,.7235398E+03,.6031357E+03,.7442908E+03,.8856774E+03,& + & .1027286E+04,.1169074E+04,.1131504E+04,.9941179E+03,.8570033E+03,& + & .7197199E+03,.6023129E+03,.7432633E+03,.8844627E+03,.1025923E+04,& + & .1167566E+04,.1125720E+04,.9892480E+03,.8524798E+03,.7159207E+03,& + & .6012892E+03,.7420375E+03,.8831033E+03,.1024380E+04,.1165837E+04/ + + data absb( 1:175, 1) / & + & .2736900E+02,.2990300E+03,.4292400E+03,.3103900E+03,.3500000E+02,& + & .2715800E+02,.2989800E+03,.4274500E+03,.3084000E+03,.3500000E+02,& + & .2697600E+02,.2988900E+03,.4259000E+03,.3066800E+03,.3500000E+02,& + & .2681800E+02,.2987500E+03,.4245500E+03,.3051700E+03,.3500000E+02,& + & .2667900E+02,.2985500E+03,.4233500E+03,.3038400E+03,.3500000E+02,& + & .2684000E+02,.2986300E+03,.4247400E+03,.3053800E+03,.3500000E+02,& + & .2666900E+02,.2986200E+03,.4232700E+03,.3037500E+03,.3500000E+02,& + & .2652200E+02,.2985400E+03,.4219900E+03,.3023400E+03,.3500000E+02,& + & .2639400E+02,.2984200E+03,.4208800E+03,.3011100E+03,.3500000E+02,& + & .2628200E+02,.2982400E+03,.4199000E+03,.3000200E+03,.3500000E+02,& + & .2640800E+02,.2983100E+03,.4210000E+03,.3012400E+03,.3500000E+02,& + & .2627100E+02,.2983200E+03,.4198000E+03,.2999100E+03,.3500000E+02,& + & .2615200E+02,.2982600E+03,.4187600E+03,.2987700E+03,.3500000E+02,& + & .2604900E+02,.2981400E+03,.4178500E+03,.2977600E+03,.3500000E+02,& + & .2595800E+02,.2979700E+03,.4170500E+03,.2968800E+03,.3500000E+02,& + & .2605700E+02,.2980600E+03,.4179300E+03,.2978400E+03,.3500000E+02,& + & .2594600E+02,.2980700E+03,.4169500E+03,.2967600E+03,.3500000E+02,& + & .2585100E+02,.2980300E+03,.4161000E+03,.2958300E+03,.3500000E+02,& + & .2576700E+02,.2979200E+03,.4153600E+03,.2950200E+03,.3500000E+02,& + & .2569400E+02,.2977600E+03,.4147000E+03,.2943000E+03,.3500000E+02,& + & .2577200E+02,.2978500E+03,.4154000E+03,.2950600E+03,.3500000E+02,& + & .2568300E+02,.2978700E+03,.4146000E+03,.2941900E+03,.3500000E+02,& + & .2560600E+02,.2978400E+03,.4139100E+03,.2934300E+03,.3500000E+02,& + & .2553800E+02,.2977400E+03,.4133100E+03,.2927700E+03,.3500000E+02,& + & .2547900E+02,.2975800E+03,.4127800E+03,.2921900E+03,.3500000E+02,& + & .2554100E+02,.2976800E+03,.4133400E+03,.2928000E+03,.3500000E+02,& + & .2546900E+02,.2977200E+03,.4126900E+03,.2920900E+03,.3500000E+02,& + & .2540700E+02,.2976800E+03,.4121300E+03,.2914700E+03,.3500000E+02,& + & .2535300E+02,.2975800E+03,.4116300E+03,.2909400E+03,.3500000E+02,& + & .2530500E+02,.2974300E+03,.4112000E+03,.2904600E+03,.3500000E+02,& + & .2535400E+02,.2975500E+03,.4116500E+03,.2909500E+03,.3500000E+02,& + & .2529600E+02,.2975800E+03,.4111200E+03,.2903700E+03,.3500000E+02,& + & .2524500E+02,.2975500E+03,.4106700E+03,.2898800E+03,.3500000E+02,& + & .2520100E+02,.2974600E+03,.4102700E+03,.2894400E+03,.3500000E+02,& + & .2516300E+02,.2973000E+03,.4099100E+03,.2890500E+03,.3500000E+02/ + + data absb(176:350, 1) / & + & .2520100E+02,.2974400E+03,.4102600E+03,.2894300E+03,.3500000E+02,& + & .2515400E+02,.2974800E+03,.4098400E+03,.2889700E+03,.3500000E+02,& + & .2511300E+02,.2974500E+03,.4094700E+03,.2885600E+03,.3500000E+02,& + & .2507800E+02,.2973500E+03,.4091400E+03,.2882100E+03,.3500000E+02,& + & .2504700E+02,.2971900E+03,.4088600E+03,.2879000E+03,.3500000E+02,& + & .2507600E+02,.2973600E+03,.4091300E+03,.2881900E+03,.3500000E+02,& + & .2503900E+02,.2973900E+03,.4087900E+03,.2878200E+03,.3500000E+02,& + & .2500600E+02,.2973600E+03,.4084900E+03,.2874900E+03,.3500000E+02,& + & .2497800E+02,.2972600E+03,.4082300E+03,.2872200E+03,.3500000E+02,& + & .2495200E+02,.2971000E+03,.4080000E+03,.2869500E+03,.3500000E+02,& + & .2497300E+02,.2972900E+03,.4081900E+03,.2871700E+03,.3500000E+02,& + & .2494400E+02,.2973200E+03,.4079200E+03,.2868700E+03,.3500000E+02,& + & .2491700E+02,.2972800E+03,.4076800E+03,.2866100E+03,.3500000E+02,& + & .2489500E+02,.2971700E+03,.4074700E+03,.2863800E+03,.3500000E+02,& + & .2487400E+02,.2970000E+03,.4072800E+03,.2861800E+03,.3500000E+02,& + & .2489000E+02,.2972400E+03,.4074300E+03,.2863400E+03,.3500000E+02,& + & .2486600E+02,.2972600E+03,.4072100E+03,.2861000E+03,.3500000E+02,& + & .2484600E+02,.2972100E+03,.4070200E+03,.2858900E+03,.3500000E+02,& + & .2482700E+02,.2971000E+03,.4068500E+03,.2857100E+03,.3500000E+02,& + & .2481100E+02,.2969200E+03,.4067100E+03,.2855400E+03,.3500000E+02,& + & .2482300E+02,.2972100E+03,.4068100E+03,.2856600E+03,.3500000E+02,& + & .2480400E+02,.2972100E+03,.4066400E+03,.2854700E+03,.3500000E+02,& + & .2478700E+02,.2971500E+03,.4064900E+03,.2853000E+03,.3500000E+02,& + & .2477300E+02,.2970300E+03,.4063500E+03,.2851600E+03,.3500000E+02,& + & .2476000E+02,.2968400E+03,.4062300E+03,.2850300E+03,.3500000E+02,& + & .2476900E+02,.2971700E+03,.4063100E+03,.2851100E+03,.3500000E+02,& + & .2475300E+02,.2971700E+03,.4061800E+03,.2849600E+03,.3500000E+02,& + & .2474000E+02,.2971000E+03,.4060600E+03,.2848300E+03,.3500000E+02,& + & .2472900E+02,.2969600E+03,.4059500E+03,.2847200E+03,.3500000E+02,& + & .2471800E+02,.2967600E+03,.4058500E+03,.2846200E+03,.3500000E+02,& + & .2472400E+02,.2971500E+03,.4059100E+03,.2846700E+03,.3500000E+02,& + & .2471200E+02,.2971300E+03,.4058000E+03,.2845600E+03,.3500000E+02,& + & .2470200E+02,.2970400E+03,.4057000E+03,.2844500E+03,.3500000E+02,& + & .2469300E+02,.2968900E+03,.4056200E+03,.2843500E+03,.3500000E+02,& + & .2468400E+02,.2966800E+03,.4055400E+03,.2842700E+03,.3500000E+02/ + + data absb(351:525, 1) / & + & .2468900E+02,.2971300E+03,.4055800E+03,.2843100E+03,.3500000E+02,& + & .2467900E+02,.2970900E+03,.4055000E+03,.2842200E+03,.3500000E+02,& + & .2467100E+02,.2969900E+03,.4054200E+03,.2842300E+03,.3500000E+02,& + & .2466400E+02,.2968300E+03,.4053500E+03,.2840500E+03,.3500000E+02,& + & .2465700E+02,.2966000E+03,.4052900E+03,.2839900E+03,.3500000E+02,& + & .2466000E+02,.2971000E+03,.4053200E+03,.2840400E+03,.3500000E+02,& + & .2465300E+02,.2970600E+03,.4052500E+03,.2839500E+03,.3500000E+02,& + & .2464600E+02,.2969400E+03,.4051900E+03,.2838900E+03,.3500000E+02,& + & .2464000E+02,.2967600E+03,.4051400E+03,.2838300E+03,.3500000E+02,& + & .2463500E+02,.2965100E+03,.4050900E+03,.2837600E+03,.3500000E+02,& + & .2463700E+02,.2970800E+03,.4051100E+03,.2838000E+03,.3500000E+02,& + & .2463100E+02,.2970200E+03,.4050500E+03,.2837400E+03,.3500000E+02,& + & .2462600E+02,.2968900E+03,.4050000E+03,.2836800E+03,.3500000E+02,& + & .2462100E+02,.2966900E+03,.4049600E+03,.2836400E+03,.3500000E+02,& + & .2461700E+02,.2964300E+03,.4049200E+03,.2835900E+03,.3500000E+02,& + & .2461900E+02,.2970600E+03,.4049400E+03,.2836000E+03,.3500000E+02,& + & .2461400E+02,.2969800E+03,.4048900E+03,.2835500E+03,.3500000E+02,& + & .2461000E+02,.2968300E+03,.4048500E+03,.2835100E+03,.3500000E+02,& + & .2460600E+02,.2966200E+03,.4048200E+03,.2834700E+03,.3500000E+02,& + & .2460300E+02,.2963400E+03,.4047900E+03,.2834400E+03,.3500000E+02,& + & .2460400E+02,.2970400E+03,.4048000E+03,.2834500E+03,.3500000E+02,& + & .2460000E+02,.2969400E+03,.4047700E+03,.2834100E+03,.3500000E+02,& + & .2459700E+02,.2967800E+03,.4047300E+03,.2833800E+03,.3500000E+02,& + & .2459400E+02,.2965500E+03,.4047100E+03,.2833600E+03,.3500000E+02,& + & .2459100E+02,.2962500E+03,.4046800E+03,.2833200E+03,.3500000E+02,& + & .2459200E+02,.2970100E+03,.4046900E+03,.2833300E+03,.3500000E+02,& + & .2458900E+02,.2968900E+03,.4046600E+03,.2833000E+03,.3500000E+02,& + & .2458600E+02,.2967200E+03,.4046400E+03,.2832800E+03,.3500000E+02,& + & .2458400E+02,.2964700E+03,.4046100E+03,.2832400E+03,.3500000E+02,& + & .2458200E+02,.2961500E+03,.4045900E+03,.2832500E+03,.3500000E+02,& + & .2458200E+02,.2969800E+03,.4046000E+03,.2832300E+03,.3500000E+02,& + & .2458000E+02,.2968500E+03,.4045800E+03,.2832100E+03,.3500000E+02,& + & .2457800E+02,.2966500E+03,.4045600E+03,.2831800E+03,.3500000E+02,& + & .2457600E+02,.2963900E+03,.4045400E+03,.2831700E+03,.3500000E+02,& + & .2457400E+02,.2960500E+03,.4045200E+03,.2831500E+03,.3500000E+02/ + + data absb(526:700, 1) / & + & .2457400E+02,.2969500E+03,.4045300E+03,.2831500E+03,.3500000E+02,& + & .2457200E+02,.2968000E+03,.4045100E+03,.2831300E+03,.3500000E+02,& + & .2457100E+02,.2965900E+03,.4044900E+03,.2831200E+03,.3500000E+02,& + & .2456900E+02,.2963100E+03,.4044800E+03,.2831000E+03,.3500000E+02,& + & .2456800E+02,.2959600E+03,.4044700E+03,.2830800E+03,.3500000E+02,& + & .2456800E+02,.2969300E+03,.4044700E+03,.2830900E+03,.3500000E+02,& + & .2456700E+02,.2967800E+03,.4044600E+03,.2830800E+03,.3500000E+02,& + & .2456500E+02,.2965600E+03,.4044400E+03,.2830600E+03,.3500000E+02,& + & .2456400E+02,.2962700E+03,.4044300E+03,.2830500E+03,.3500000E+02,& + & .2456300E+02,.2959000E+03,.4044200E+03,.2830400E+03,.3500000E+02,& + & .2456300E+02,.2969200E+03,.4044300E+03,.2830500E+03,.3500000E+02,& + & .2456200E+02,.2967700E+03,.4044200E+03,.2830400E+03,.3500000E+02,& + & .2456100E+02,.2965500E+03,.4044000E+03,.2830100E+03,.3500000E+02,& + & .2456000E+02,.2962600E+03,.4044000E+03,.2830200E+03,.3500000E+02,& + & .2455900E+02,.2958900E+03,.4043900E+03,.2830100E+03,.3500000E+02,& + & .2456000E+02,.2969300E+03,.4043900E+03,.2830100E+03,.3500000E+02,& + & .2455900E+02,.2967900E+03,.4043800E+03,.2829900E+03,.3500000E+02,& + & .2455800E+02,.2965800E+03,.4043700E+03,.2829900E+03,.3500000E+02,& + & .2455700E+02,.2963000E+03,.4043700E+03,.2829700E+03,.3500000E+02,& + & .2455600E+02,.2959400E+03,.4043600E+03,.2829700E+03,.3500000E+02,& + & .2455700E+02,.2969500E+03,.4043600E+03,.2829700E+03,.3500000E+02,& + & .2455600E+02,.2968100E+03,.4043600E+03,.2829600E+03,.3500000E+02,& + & .2455500E+02,.2966100E+03,.4043500E+03,.2829700E+03,.3500000E+02,& + & .2455400E+02,.2963400E+03,.4043400E+03,.2829600E+03,.3500000E+02,& + & .2455400E+02,.2959900E+03,.4043400E+03,.2829400E+03,.3500000E+02,& + & .2455400E+02,.2969600E+03,.4043400E+03,.2829500E+03,.3500000E+02,& + & .2455300E+02,.2968300E+03,.4043300E+03,.2829400E+03,.3500000E+02,& + & .2455300E+02,.2966400E+03,.4043300E+03,.2829300E+03,.3500000E+02,& + & .2455200E+02,.2963800E+03,.4043200E+03,.2829200E+03,.3500000E+02,& + & .2455200E+02,.2960400E+03,.4043200E+03,.2829200E+03,.3500000E+02,& + & .2455200E+02,.2969800E+03,.4043200E+03,.2829200E+03,.3500000E+02,& + & .2455100E+02,.2968700E+03,.4043200E+03,.2829300E+03,.3500000E+02,& + & .2455100E+02,.2966900E+03,.4043100E+03,.2829200E+03,.3500000E+02,& + & .2455000E+02,.2964500E+03,.4043100E+03,.2829100E+03,.3500000E+02,& + & .2455000E+02,.2961300E+03,.4043000E+03,.2829100E+03,.3500000E+02/ + + data absb(701:875, 1) / & + & .2455000E+02,.2969900E+03,.4043100E+03,.2829000E+03,.3500000E+02,& + & .2455000E+02,.2969000E+03,.4043000E+03,.2829100E+03,.3500000E+02,& + & .2454900E+02,.2967400E+03,.4043000E+03,.2828900E+03,.3500000E+02,& + & .2454900E+02,.2965100E+03,.4042900E+03,.2829000E+03,.3500000E+02,& + & .2454900E+02,.2962200E+03,.4042900E+03,.2828900E+03,.3500000E+02,& + & .2454900E+02,.2970000E+03,.4042900E+03,.2828900E+03,.3500000E+02,& + & .2454900E+02,.2969300E+03,.4042900E+03,.2828900E+03,.3500000E+02,& + & .2454800E+02,.2967900E+03,.4042900E+03,.2828900E+03,.3500000E+02,& + & .2454800E+02,.2965800E+03,.4042800E+03,.2828900E+03,.3500000E+02,& + & .2454700E+02,.2963000E+03,.4042800E+03,.2828800E+03,.3500000E+02,& + & .2454800E+02,.2970100E+03,.4042800E+03,.2828800E+03,.3500000E+02,& + & .2454700E+02,.2969600E+03,.4042800E+03,.2828800E+03,.3500000E+02,& + & .2454700E+02,.2968400E+03,.4042800E+03,.2828800E+03,.3500000E+02,& + & .2454700E+02,.2966500E+03,.4042700E+03,.2828800E+03,.3500000E+02,& + & .2454700E+02,.2963900E+03,.4042700E+03,.2828800E+03,.3500000E+02,& + & .2454700E+02,.2970200E+03,.4042700E+03,.2828700E+03,.3500000E+02,& + & .2454700E+02,.2969800E+03,.4042700E+03,.2828700E+03,.3500000E+02,& + & .2454600E+02,.2968800E+03,.4042700E+03,.2828700E+03,.3500000E+02,& + & .2454600E+02,.2967200E+03,.4042700E+03,.2828700E+03,.3500000E+02,& + & .2454600E+02,.2964900E+03,.4042600E+03,.2828600E+03,.3500000E+02,& + & .2454600E+02,.2970100E+03,.4042700E+03,.2828700E+03,.3500000E+02,& + & .2454600E+02,.2970000E+03,.4042600E+03,.2828700E+03,.3500000E+02,& + & .2454600E+02,.2969200E+03,.4042600E+03,.2828600E+03,.3500000E+02,& + & .2454500E+02,.2967800E+03,.4042600E+03,.2828600E+03,.3500000E+02,& + & .2454500E+02,.2965700E+03,.4042600E+03,.2828600E+03,.3500000E+02,& + & .2454500E+02,.2969900E+03,.4042600E+03,.2828700E+03,.3500000E+02,& + & .2454500E+02,.2970100E+03,.4042600E+03,.2828500E+03,.3500000E+02,& + & .2454500E+02,.2969600E+03,.4042600E+03,.2828600E+03,.3500000E+02,& + & .2454500E+02,.2968400E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454500E+02,.2966500E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454500E+02,.2969600E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454500E+02,.2970100E+03,.4042500E+03,.2828600E+03,.3500000E+02,& + & .2454400E+02,.2969900E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454400E+02,.2969000E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454400E+02,.2967400E+03,.4042500E+03,.2828600E+03,.3500000E+02/ + + data absb(876:1050, 1) / & + & .2454400E+02,.2969100E+03,.4042500E+03,.2828600E+03,.3500000E+02,& + & .2454400E+02,.2970000E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454400E+02,.2970100E+03,.4042500E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2969400E+03,.4042500E+03,.2828500E+03,.3500000E+02,& + & .2454400E+02,.2968100E+03,.4042500E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2968500E+03,.4042500E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2969800E+03,.4042500E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2970100E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2969700E+03,.4042400E+03,.2828500E+03,.3500000E+02,& + & .2454400E+02,.2968700E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2967800E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454400E+02,.2969400E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2970100E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2970000E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2969200E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2967000E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2968900E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2969900E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2970100E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2969500E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2966000E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2968400E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2969700E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2970100E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2969800E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2964800E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2967600E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2969300E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2970100E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2970000E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2963500E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2966800E+03,.4042400E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2968800E+03,.4042400E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2969900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2970100E+03,.4042300E+03,.2828500E+03,.3500000E+02/ + + data absb(1051:1175, 1) / & + & .2454300E+02,.2962200E+03,.4042400E+03,.2828500E+03,.3500000E+02,& + & .2454300E+02,.2965900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2968300E+03,.4042300E+03,.2828400E+03,.3500000E+02,& + & .2454300E+02,.2969600E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2970100E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2960700E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2964900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2967600E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2969300E+03,.4042300E+03,.2828200E+03,.3500000E+02,& + & .2454200E+02,.2970000E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454300E+02,.2959100E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2963700E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2966900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2968900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2969900E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2957400E+03,.4042300E+03,.2828200E+03,.3500000E+02,& + & .2454200E+02,.2962400E+03,.4042300E+03,.2828200E+03,.3500000E+02,& + & .2454200E+02,.2966000E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2968400E+03,.4042300E+03,.2828400E+03,.3500000E+02,& + & .2454200E+02,.2969700E+03,.4042300E+03,.2828200E+03,.3500000E+02,& + & .2454200E+02,.2956600E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2961900E+03,.4042300E+03,.2828200E+03,.3500000E+02,& + & .2454200E+02,.2965700E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2968200E+03,.4042300E+03,.2828300E+03,.3500000E+02,& + & .2454200E+02,.2969600E+03,.4042300E+03,.2828300E+03,.3500000E+02/ + + data absb( 1:175, 2) / & + & .1017700E+03,.3276100E+03,.4557500E+03,.3133500E+03,.7183900E+02,& + & .1009900E+03,.3271300E+03,.4538300E+03,.3112500E+03,.7183900E+02,& + & .1003100E+03,.3266300E+03,.4521600E+03,.3094300E+03,.7183900E+02,& + & .9972100E+02,.3261200E+03,.4507100E+03,.3078500E+03,.7183900E+02,& + & .9920400E+02,.3255800E+03,.4494200E+03,.3064600E+03,.7183900E+02,& + & .9980300E+02,.3261300E+03,.4509100E+03,.3080700E+03,.7183900E+02,& + & .9916900E+02,.3257400E+03,.4493400E+03,.3063600E+03,.7183900E+02,& + & .9862200E+02,.3253400E+03,.4479700E+03,.3048900E+03,.7183900E+02,& + & .9814600E+02,.3249100E+03,.4467700E+03,.3036200E+03,.7183900E+02,& + & .9772800E+02,.3244400E+03,.4457100E+03,.3024800E+03,.7183900E+02,& + & .9819800E+02,.3249300E+03,.4469000E+03,.3037500E+03,.7183900E+02,& + & .9768700E+02,.3246200E+03,.4456000E+03,.3023700E+03,.7183900E+02,& + & .9724500E+02,.3242900E+03,.4444800E+03,.3011900E+03,.7183900E+02,& + & .9686100E+02,.3239200E+03,.4435000E+03,.3001400E+03,.7183900E+02,& + & .9652300E+02,.3235000E+03,.4426300E+03,.2992300E+03,.7183900E+02,& + & .9689200E+02,.3239500E+03,.4435800E+03,.3002300E+03,.7183900E+02,& + & .9648000E+02,.3237100E+03,.4425200E+03,.2991200E+03,.7183900E+02,& + & .9612500E+02,.3234300E+03,.4416100E+03,.2981700E+03,.7183900E+02,& + & .9581400E+02,.3231100E+03,.4408100E+03,.2973300E+03,.7183900E+02,& + & .9554100E+02,.3227300E+03,.4401000E+03,.2966100E+03,.7183900E+02,& + & .9583300E+02,.3231600E+03,.4408600E+03,.2973700E+03,.7183900E+02,& + & .9550100E+02,.3229700E+03,.4400000E+03,.2964800E+03,.7183900E+02,& + & .9521400E+02,.3227400E+03,.4392500E+03,.2956900E+03,.7183900E+02,& + & .9496400E+02,.3224500E+03,.4386000E+03,.2950200E+03,.7183900E+02,& + & .9474300E+02,.3221000E+03,.4380300E+03,.2944200E+03,.7183900E+02,& + & .9497400E+02,.3225100E+03,.4386300E+03,.2950400E+03,.7183900E+02,& + & .9470700E+02,.3223600E+03,.4379300E+03,.2943200E+03,.7183900E+02,& + & .9447500E+02,.3221700E+03,.4373300E+03,.2936900E+03,.7183900E+02,& + & .9427200E+02,.3219100E+03,.4368000E+03,.2931500E+03,.7183900E+02,& + & .9409400E+02,.3215800E+03,.4363300E+03,.2926700E+03,.7183900E+02,& + & .9427700E+02,.3219900E+03,.4368100E+03,.2931600E+03,.7183900E+02,& + & .9406100E+02,.3218700E+03,.4362400E+03,.2925800E+03,.7183900E+02,& + & .9387400E+02,.3217000E+03,.4357500E+03,.2920700E+03,.7183900E+02,& + & .9371100E+02,.3214600E+03,.4353200E+03,.2916400E+03,.7183900E+02,& + & .9356600E+02,.3211500E+03,.4349400E+03,.2912500E+03,.7183900E+02/ + + data absb(176:350, 2) / & + & .9370800E+02,.3215700E+03,.4353100E+03,.2916300E+03,.7183900E+02,& + & .9353400E+02,.3214700E+03,.4348500E+03,.2911700E+03,.7183900E+02,& + & .9338300E+02,.3213200E+03,.4344500E+03,.2907600E+03,.7183900E+02,& + & .9325100E+02,.3210900E+03,.4341100E+03,.2904100E+03,.7183900E+02,& + & .9313500E+02,.3207900E+03,.4338000E+03,.2901000E+03,.7183900E+02,& + & .9324600E+02,.3212200E+03,.4340900E+03,.2904000E+03,.7183900E+02,& + & .9310600E+02,.3211400E+03,.4337200E+03,.2900300E+03,.7183900E+02,& + & .9298500E+02,.3210000E+03,.4334000E+03,.2897000E+03,.7183900E+02,& + & .9287800E+02,.3207900E+03,.4331100E+03,.2894100E+03,.7183900E+02,& + & .9278400E+02,.3204900E+03,.4328600E+03,.2891700E+03,.7183900E+02,& + & .9286300E+02,.3209400E+03,.4330700E+03,.2893800E+03,.7183900E+02,& + & .9275100E+02,.3208700E+03,.4327800E+03,.2890800E+03,.7183900E+02,& + & .9265500E+02,.3207300E+03,.4325200E+03,.2888200E+03,.7183900E+02,& + & .9256900E+02,.3205100E+03,.4322900E+03,.2886000E+03,.7183900E+02,& + & .9249400E+02,.3202200E+03,.4320900E+03,.2884000E+03,.7183900E+02,& + & .9255300E+02,.3207200E+03,.4322500E+03,.2885500E+03,.7183900E+02,& + & .9246500E+02,.3206400E+03,.4320100E+03,.2883200E+03,.7183900E+02,& + & .9238700E+02,.3205000E+03,.4318000E+03,.2881100E+03,.7183900E+02,& + & .9231900E+02,.3202900E+03,.4316200E+03,.2879300E+03,.7183900E+02,& + & .9225900E+02,.3199800E+03,.4314600E+03,.2877800E+03,.7183900E+02,& + & .9230300E+02,.3205300E+03,.4315800E+03,.2878900E+03,.7183900E+02,& + & .9223300E+02,.3204600E+03,.4313900E+03,.2877000E+03,.7183900E+02,& + & .9217100E+02,.3203100E+03,.4312200E+03,.2875400E+03,.7183900E+02,& + & .9211700E+02,.3200900E+03,.4310800E+03,.2874000E+03,.7183900E+02,& + & .9206800E+02,.3197800E+03,.4309500E+03,.2872700E+03,.7183900E+02,& + & .9210100E+02,.3203800E+03,.4310300E+03,.2873600E+03,.7183900E+02,& + & .9204500E+02,.3203000E+03,.4308800E+03,.2872100E+03,.7183900E+02,& + & .9199600E+02,.3201500E+03,.4307500E+03,.2870800E+03,.7183900E+02,& + & .9195200E+02,.3199100E+03,.4306400E+03,.2869600E+03,.7183900E+02,& + & .9191400E+02,.3195900E+03,.4305300E+03,.2868400E+03,.7183900E+02,& + & .9193700E+02,.3202500E+03,.4305900E+03,.2869300E+03,.7183900E+02,& + & .9189200E+02,.3201600E+03,.4304700E+03,.2868000E+03,.7183900E+02,& + & .9185300E+02,.3200000E+03,.4303700E+03,.2867000E+03,.7183900E+02,& + & .9181900E+02,.3197500E+03,.4302800E+03,.2866100E+03,.7183900E+02,& + & .9178800E+02,.3194200E+03,.4301900E+03,.2865300E+03,.7183900E+02/ + + data absb(351:525, 2) / & + & .9180500E+02,.3201500E+03,.4302400E+03,.2865800E+03,.7183900E+02,& + & .9177000E+02,.3200500E+03,.4301400E+03,.2864800E+03,.7183900E+02,& + & .9173800E+02,.3198600E+03,.4300600E+03,.2863000E+03,.7183900E+02,& + & .9171100E+02,.3196000E+03,.4299800E+03,.2863300E+03,.7183900E+02,& + & .9168700E+02,.3192500E+03,.4299200E+03,.2862600E+03,.7183900E+02,& + & .9169800E+02,.3200500E+03,.4299500E+03,.2862800E+03,.7183900E+02,& + & .9167000E+02,.3199400E+03,.4298700E+03,.2862200E+03,.7183900E+02,& + & .9164600E+02,.3197400E+03,.4298100E+03,.2861500E+03,.7183900E+02,& + & .9162400E+02,.3194600E+03,.4297500E+03,.2860900E+03,.7183900E+02,& + & .9160400E+02,.3191000E+03,.4297000E+03,.2860500E+03,.7183900E+02,& + & .9161300E+02,.3199700E+03,.4297200E+03,.2860500E+03,.7183900E+02,& + & .9159100E+02,.3198400E+03,.4296600E+03,.2860000E+03,.7183900E+02,& + & .9157100E+02,.3196300E+03,.4296000E+03,.2859500E+03,.7183900E+02,& + & .9155400E+02,.3193300E+03,.4295600E+03,.2859000E+03,.7183900E+02,& + & .9153800E+02,.3189500E+03,.4295200E+03,.2858600E+03,.7183900E+02,& + & .9154400E+02,.3199000E+03,.4295300E+03,.2858900E+03,.7183900E+02,& + & .9152600E+02,.3197500E+03,.4294800E+03,.2858400E+03,.7183900E+02,& + & .9151100E+02,.3195200E+03,.4294400E+03,.2858000E+03,.7183900E+02,& + & .9149700E+02,.3192000E+03,.4294000E+03,.2857700E+03,.7183900E+02,& + & .9148400E+02,.3188000E+03,.4293700E+03,.2857300E+03,.7183900E+02,& + & .9148800E+02,.3198300E+03,.4293800E+03,.2857400E+03,.7183900E+02,& + & .9147400E+02,.3196600E+03,.4293400E+03,.2857100E+03,.7183900E+02,& + & .9146200E+02,.3194100E+03,.4293100E+03,.2856700E+03,.7183900E+02,& + & .9145100E+02,.3190800E+03,.4292800E+03,.2856400E+03,.7183900E+02,& + & .9144100E+02,.3186600E+03,.4292500E+03,.2856200E+03,.7183900E+02,& + & .9144300E+02,.3197600E+03,.4292600E+03,.2856200E+03,.7183900E+02,& + & .9143200E+02,.3195800E+03,.4292300E+03,.2855900E+03,.7183900E+02,& + & .9142300E+02,.3193000E+03,.4292000E+03,.2855700E+03,.7183900E+02,& + & .9141400E+02,.3189500E+03,.4291800E+03,.2855500E+03,.7183900E+02,& + & .9140600E+02,.3185100E+03,.4291600E+03,.2855100E+03,.7183900E+02,& + & .9140700E+02,.3197000E+03,.4291600E+03,.2855300E+03,.7183900E+02,& + & .9139900E+02,.3194900E+03,.4291400E+03,.2855100E+03,.7183900E+02,& + & .9139100E+02,.3192000E+03,.4291200E+03,.2854900E+03,.7183900E+02,& + & .9138400E+02,.3188200E+03,.4291000E+03,.2854700E+03,.7183900E+02,& + & .9137800E+02,.3183700E+03,.4290800E+03,.2854600E+03,.7183900E+02/ + + data absb(526:700, 2) / & + & .9137900E+02,.3196400E+03,.4290800E+03,.2854600E+03,.7183900E+02,& + & .9137200E+02,.3194100E+03,.4290600E+03,.2854400E+03,.7183900E+02,& + & .9136500E+02,.3191000E+03,.4290500E+03,.2854200E+03,.7183900E+02,& + & .9136000E+02,.3187100E+03,.4290300E+03,.2854100E+03,.7183900E+02,& + & .9135500E+02,.3182400E+03,.4290200E+03,.2854000E+03,.7183900E+02,& + & .9135600E+02,.3196000E+03,.4290200E+03,.2853900E+03,.7183900E+02,& + & .9135000E+02,.3193600E+03,.4290100E+03,.2853800E+03,.7183900E+02,& + & .9134500E+02,.3190400E+03,.4289900E+03,.2853700E+03,.7183900E+02,& + & .9134100E+02,.3186300E+03,.4289800E+03,.2853500E+03,.7183900E+02,& + & .9133700E+02,.3181600E+03,.4289700E+03,.2853500E+03,.7183900E+02,& + & .9133800E+02,.3195800E+03,.4289700E+03,.2853500E+03,.7183900E+02,& + & .9133400E+02,.3193400E+03,.4289600E+03,.2853300E+03,.7183900E+02,& + & .9133000E+02,.3190200E+03,.4289500E+03,.2853300E+03,.7183900E+02,& + & .9132600E+02,.3186200E+03,.4289400E+03,.2853000E+03,.7183900E+02,& + & .9132300E+02,.3181400E+03,.4289300E+03,.2853000E+03,.7183900E+02,& + & .9132400E+02,.3195900E+03,.4289400E+03,.2853100E+03,.7183900E+02,& + & .9132000E+02,.3193700E+03,.4289300E+03,.2853000E+03,.7183900E+02,& + & .9131700E+02,.3190600E+03,.4289200E+03,.2852900E+03,.7183900E+02,& + & .9131400E+02,.3186600E+03,.4289100E+03,.2852900E+03,.7183900E+02,& + & .9131100E+02,.3181900E+03,.4289000E+03,.2852700E+03,.7183900E+02,& + & .9131300E+02,.3196100E+03,.4289000E+03,.2852800E+03,.7183900E+02,& + & .9131000E+02,.3193900E+03,.4289000E+03,.2852800E+03,.7183900E+02,& + & .9130700E+02,.3191000E+03,.4288900E+03,.2852600E+03,.7183900E+02,& + & .9130400E+02,.3187100E+03,.4288800E+03,.2852500E+03,.7183900E+02,& + & .9130200E+02,.3182600E+03,.4288800E+03,.2852500E+03,.7183900E+02,& + & .9130300E+02,.3196200E+03,.4288800E+03,.2852500E+03,.7183900E+02,& + & .9130100E+02,.3194200E+03,.4288700E+03,.2852500E+03,.7183900E+02,& + & .9129800E+02,.3191400E+03,.4288600E+03,.2852500E+03,.7183900E+02,& + & .9129600E+02,.3187700E+03,.4288600E+03,.2852400E+03,.7183900E+02,& + & .9129400E+02,.3183200E+03,.4288500E+03,.2852300E+03,.7183900E+02,& + & .9129600E+02,.3196500E+03,.4288600E+03,.2852400E+03,.7183900E+02,& + & .9129300E+02,.3194700E+03,.4288500E+03,.2852200E+03,.7183900E+02,& + & .9129200E+02,.3192100E+03,.4288500E+03,.2852200E+03,.7183900E+02,& + & .9129000E+02,.3188600E+03,.4288400E+03,.2852200E+03,.7183900E+02,& + & .9128800E+02,.3184300E+03,.4288400E+03,.2852100E+03,.7183900E+02/ + + data absb(701:875, 2) / & + & .9128900E+02,.3196800E+03,.4288400E+03,.2852300E+03,.7183900E+02,& + & .9128800E+02,.3195200E+03,.4288400E+03,.2852100E+03,.7183900E+02,& + & .9128600E+02,.3192800E+03,.4288300E+03,.2852200E+03,.7183900E+02,& + & .9128400E+02,.3189500E+03,.4288300E+03,.2852100E+03,.7183900E+02,& + & .9128300E+02,.3185400E+03,.4288200E+03,.2852100E+03,.7183900E+02,& + & .9128400E+02,.3197000E+03,.4288300E+03,.2852100E+03,.7183900E+02,& + & .9128300E+02,.3195700E+03,.4288200E+03,.2852100E+03,.7183900E+02,& + & .9128100E+02,.3193400E+03,.4288200E+03,.2852000E+03,.7183900E+02,& + & .9128000E+02,.3190400E+03,.4288200E+03,.2851900E+03,.7183900E+02,& + & .9127900E+02,.3186500E+03,.4288100E+03,.2852000E+03,.7183900E+02,& + & .9128000E+02,.3197200E+03,.4288200E+03,.2852000E+03,.7183900E+02,& + & .9127900E+02,.3196100E+03,.4288100E+03,.2852000E+03,.7183900E+02,& + & .9127700E+02,.3194200E+03,.4288100E+03,.2851900E+03,.7183900E+02,& + & .9127600E+02,.3191400E+03,.4288100E+03,.2851800E+03,.7183900E+02,& + & .9127500E+02,.3187800E+03,.4288000E+03,.2851800E+03,.7183900E+02,& + & .9127600E+02,.3197400E+03,.4288100E+03,.2851900E+03,.7183900E+02,& + & .9127500E+02,.3196600E+03,.4288000E+03,.2851900E+03,.7183900E+02,& + & .9127400E+02,.3194900E+03,.4288000E+03,.2851800E+03,.7183900E+02,& + & .9127300E+02,.3192400E+03,.4288000E+03,.2851800E+03,.7183900E+02,& + & .9127300E+02,.3189000E+03,.4288000E+03,.2851800E+03,.7183900E+02,& + & .9127400E+02,.3197400E+03,.4288000E+03,.2851800E+03,.7183900E+02,& + & .9127300E+02,.3196900E+03,.4288000E+03,.2851700E+03,.7183900E+02,& + & .9127200E+02,.3195500E+03,.4287900E+03,.2851800E+03,.7183900E+02,& + & .9127100E+02,.3193300E+03,.4287900E+03,.2851700E+03,.7183900E+02,& + & .9127000E+02,.3190300E+03,.4287900E+03,.2851700E+03,.7183900E+02,& + & .9127100E+02,.3197400E+03,.4287900E+03,.2851600E+03,.7183900E+02,& + & .9127000E+02,.3197200E+03,.4287900E+03,.2851700E+03,.7183900E+02,& + & .9127000E+02,.3196100E+03,.4287900E+03,.2851700E+03,.7183900E+02,& + & .9126900E+02,.3194200E+03,.4287900E+03,.2851700E+03,.7183900E+02,& + & .9126800E+02,.3191400E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126900E+02,.3197300E+03,.4287900E+03,.2851700E+03,.7183900E+02,& + & .9126800E+02,.3197400E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126800E+02,.3196600E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126700E+02,.3195100E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126700E+02,.3192600E+03,.4287800E+03,.2851500E+03,.7183900E+02/ + + data absb(876:1050, 2) / & + & .9126700E+02,.3197000E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126700E+02,.3197400E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126600E+02,.3197000E+03,.4287800E+03,.2851700E+03,.7183900E+02,& + & .9126600E+02,.3195800E+03,.4287800E+03,.2851500E+03,.7183900E+02,& + & .9126500E+02,.3193700E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126600E+02,.3196600E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126500E+02,.3197300E+03,.4287800E+03,.2851600E+03,.7183900E+02,& + & .9126500E+02,.3197300E+03,.4287700E+03,.2851600E+03,.7183900E+02,& + & .9126500E+02,.3196400E+03,.4287800E+03,.2851500E+03,.7183900E+02,& + & .9126400E+02,.3194600E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126500E+02,.3196200E+03,.4287700E+03,.2851600E+03,.7183900E+02,& + & .9126400E+02,.3197200E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126400E+02,.3197400E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126400E+02,.3196800E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126300E+02,.3195400E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126400E+02,.3195800E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126300E+02,.3196900E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126300E+02,.3197400E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126300E+02,.3197100E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3196000E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126300E+02,.3195300E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126300E+02,.3196500E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3197300E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3197300E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3196500E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3194800E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3196100E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126200E+02,.3197100E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3197400E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3196900E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126200E+02,.3194200E+03,.4287700E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3195700E+03,.4287700E+03,.2851400E+03,.7183900E+02,& + & .9126100E+02,.3196800E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3197300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3197100E+03,.4287600E+03,.2851300E+03,.7183900E+02/ + + data absb(1051:1175, 2) / & + & .9126100E+02,.3193700E+03,.4287600E+03,.2851300E+03,.7183900E+02,& + & .9126100E+02,.3195300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3196500E+03,.4287600E+03,.2851300E+03,.7183900E+02,& + & .9126100E+02,.3197300E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3197300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126100E+02,.3193200E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3194700E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3196100E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3197100E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3197400E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3192700E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3194300E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3195700E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3196800E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3197400E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3192200E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3193800E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3195300E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3196500E+03,.4287600E+03,.2851300E+03,.7183900E+02,& + & .9126000E+02,.3197300E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9126000E+02,.3192000E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9126000E+02,.3193600E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9125900E+02,.3195200E+03,.4287600E+03,.2851500E+03,.7183900E+02,& + & .9125900E+02,.3196400E+03,.4287600E+03,.2851400E+03,.7183900E+02,& + & .9125900E+02,.3197200E+03,.4287600E+03,.2851400E+03,.7183900E+02/ + + data absb( 1:175, 3) / & + & .3836807E+03,.4141833E+03,.5172110E+03,.3640918E+03,.2774131E+03,& + & .3807168E+03,.4119655E+03,.5153720E+03,.3628289E+03,.2774131E+03,& + & .3781683E+03,.4100543E+03,.5137563E+03,.3617431E+03,.2774131E+03,& + & .3759505E+03,.4084000E+03,.5123154E+03,.3608140E+03,.2774131E+03,& + & .3739993E+03,.4069430E+03,.5110249E+03,.3599960E+03,.2774131E+03,& + & .3762615E+03,.4086321E+03,.5121752E+03,.3609451E+03,.2774131E+03,& + & .3738708E+03,.4068442E+03,.5106639E+03,.3599404E+03,.2774131E+03,& + & .3718062E+03,.4053084E+03,.5093378E+03,.3590820E+03,.2774131E+03,& + & .3700131E+03,.4039599E+03,.5081625E+03,.3583348E+03,.2774131E+03,& + & .3684325E+03,.4027847E+03,.5070887E+03,.3576839E+03,.2774131E+03,& + & .3702108E+03,.4041080E+03,.5079686E+03,.3584156E+03,.2774131E+03,& + & .3682844E+03,.4026711E+03,.5067285E+03,.3576132E+03,.2774131E+03,& + & .3666197E+03,.4014215E+03,.5056295E+03,.3569267E+03,.2774131E+03,& + & .3651676E+03,.4003400E+03,.5046264E+03,.3563362E+03,.2774131E+03,& + & .3638932E+03,.3993817E+03,.5037145E+03,.3558113E+03,.2774131E+03,& + & .3652861E+03,.4004288E+03,.5043985E+03,.3563818E+03,.2774131E+03,& + & .3637351E+03,.3992685E+03,.5033654E+03,.3557405E+03,.2774131E+03,& + & .3623914E+03,.3982658E+03,.5024332E+03,.3551856E+03,.2774131E+03,& + & .3612211E+03,.3973916E+03,.5015961E+03,.3547114E+03,.2774131E+03,& + & .3601936E+03,.3966211E+03,.5008297E+03,.3542768E+03,.2774131E+03,& + & .3612951E+03,.3974409E+03,.5013689E+03,.3547466E+03,.2774131E+03,& + & .3600403E+03,.3965075E+03,.5005214E+03,.3542320E+03,.2774131E+03,& + & .3589636E+03,.3957025E+03,.4997495E+03,.3537982E+03,.2774131E+03,& + & .3580154E+03,.3949965E+03,.4990576E+03,.3534148E+03,.2774131E+03,& + & .3571805E+03,.3943741E+03,.4984268E+03,.3530769E+03,.2774131E+03,& + & .3580546E+03,.3950209E+03,.4988311E+03,.3534300E+03,.2774131E+03,& + & .3570472E+03,.3942704E+03,.4981389E+03,.3530214E+03,.2774131E+03,& + & .3561678E+03,.3936184E+03,.4975118E+03,.3526631E+03,.2774131E+03,& + & .3554121E+03,.3930456E+03,.4969402E+03,.3523553E+03,.2774131E+03,& + & .3547353E+03,.3925469E+03,.4964247E+03,.3520830E+03,.2774131E+03,& + & .3554270E+03,.3930604E+03,.4967238E+03,.3523605E+03,.2774131E+03,& + & .3546120E+03,.3924480E+03,.4961563E+03,.3520326E+03,.2774131E+03,& + & .3539056E+03,.3919245E+03,.4956492E+03,.3517500E+03,.2774131E+03,& + & .3532932E+03,.3914654E+03,.4951929E+03,.3514977E+03,.2774131E+03,& + & .3527448E+03,.3910603E+03,.4947773E+03,.3512758E+03,.2774131E+03/ + + data absb(176:350, 3) / & + & .3532784E+03,.3914554E+03,.4949665E+03,.3514929E+03,.2774131E+03,& + & .3526264E+03,.3909667E+03,.4945186E+03,.3512254E+03,.2774131E+03,& + & .3520584E+03,.3905468E+03,.4941167E+03,.3509983E+03,.2774131E+03,& + & .3515593E+03,.3901714E+03,.4937504E+03,.3507916E+03,.2774131E+03,& + & .3511198E+03,.3898455E+03,.4934100E+03,.3506149E+03,.2774131E+03,& + & .3515397E+03,.3901565E+03,.4935235E+03,.3507864E+03,.2774131E+03,& + & .3510113E+03,.3897615E+03,.4931757E+03,.3505745E+03,.2774131E+03,& + & .3505518E+03,.3894209E+03,.4928538E+03,.3503830E+03,.2774131E+03,& + & .3501516E+03,.3891195E+03,.4925527E+03,.3502215E+03,.2774131E+03,& + & .3498009E+03,.3888529E+03,.4922746E+03,.3500751E+03,.2774131E+03,& + & .3500923E+03,.3890750E+03,.4923299E+03,.3501963E+03,.2774131E+03,& + & .3496725E+03,.3887640E+03,.4920480E+03,.3500247E+03,.2774131E+03,& + & .3493070E+03,.3884875E+03,.4917957E+03,.3498784E+03,.2774131E+03,& + & .3489908E+03,.3882505E+03,.4915549E+03,.3497473E+03,.2774131E+03,& + & .3487043E+03,.3880380E+03,.4913246E+03,.3496361E+03,.2774131E+03,& + & .3489268E+03,.3882061E+03,.4913510E+03,.3497221E+03,.2774131E+03,& + & .3485958E+03,.3879591E+03,.4911335E+03,.3495858E+03,.2774131E+03,& + & .3483044E+03,.3877418E+03,.4909320E+03,.3494698E+03,.2774131E+03,& + & .3480474E+03,.3875440E+03,.4907313E+03,.3493639E+03,.2774131E+03,& + & .3478153E+03,.3873763E+03,.4905513E+03,.3492731E+03,.2774131E+03,& + & .3479882E+03,.3874996E+03,.4905518E+03,.3493387E+03,.2774131E+03,& + & .3477164E+03,.3873023E+03,.4903795E+03,.3492327E+03,.2774131E+03,& + & .3474843E+03,.3871294E+03,.4902184E+03,.3491368E+03,.2774131E+03,& + & .3472817E+03,.3869713E+03,.4900628E+03,.3490560E+03,.2774131E+03,& + & .3470992E+03,.3868380E+03,.4899176E+03,.3489804E+03,.2774131E+03,& + & .3472225E+03,.3869268E+03,.4898977E+03,.3490308E+03,.2774131E+03,& + & .3470103E+03,.3867739E+03,.4897703E+03,.3489501E+03,.2774131E+03,& + & .3468274E+03,.3866354E+03,.4896391E+03,.3488745E+03,.2774131E+03,& + & .3466645E+03,.3865122E+03,.4895135E+03,.3488037E+03,.2774131E+03,& + & .3465212E+03,.3864033E+03,.4893984E+03,.3487433E+03,.2774131E+03,& + & .3466053E+03,.3864725E+03,.4893673E+03,.3487785E+03,.2774131E+03,& + & .3464372E+03,.3863441E+03,.4892706E+03,.3487130E+03,.2774131E+03,& + & .3462891E+03,.3862356E+03,.4891699E+03,.3486526E+03,.2774131E+03,& + & .3461606E+03,.3861367E+03,.4890743E+03,.3485970E+03,.2774131E+03,& + & .3460421E+03,.3860479E+03,.4889791E+03,.3485566E+03,.2774131E+03/ + + data absb(351:525, 3) / & + & .3461062E+03,.3860971E+03,.4889425E+03,.3485818E+03,.2774131E+03,& + & .3459729E+03,.3859934E+03,.4888662E+03,.3485263E+03,.2774131E+03,& + & .3458544E+03,.3859146E+03,.4887903E+03,.3484759E+03,.2774131E+03,& + & .3457556E+03,.3858305E+03,.4887099E+03,.3484355E+03,.2774131E+03,& + & .3456567E+03,.3857613E+03,.4886347E+03,.3484003E+03,.2774131E+03,& + & .3457063E+03,.3858009E+03,.4885977E+03,.3484155E+03,.2774131E+03,& + & .3455975E+03,.3857169E+03,.4885414E+03,.3483751E+03,.2774131E+03,& + & .3455086E+03,.3856528E+03,.4884806E+03,.3483347E+03,.2774131E+03,& + & .3454245E+03,.3855836E+03,.4884203E+03,.3483044E+03,.2774131E+03,& + & .3453505E+03,.3855291E+03,.4883603E+03,.3482740E+03,.2774131E+03,& + & .3453801E+03,.3855539E+03,.4883177E+03,.3482844E+03,.2774131E+03,& + & .3452961E+03,.3854947E+03,.4882766E+03,.3482540E+03,.2774131E+03,& + & .3452220E+03,.3854355E+03,.4882358E+03,.3482236E+03,.2774131E+03,& + & .3451580E+03,.3853910E+03,.4881858E+03,.3481984E+03,.2774131E+03,& + & .3450987E+03,.3853414E+03,.4881306E+03,.3481732E+03,.2774131E+03,& + & .3451183E+03,.3853614E+03,.4880977E+03,.3481784E+03,.2774131E+03,& + & .3450543E+03,.3853170E+03,.4880718E+03,.3481480E+03,.2774131E+03,& + & .3449999E+03,.3852674E+03,.4880362E+03,.3481328E+03,.2774131E+03,& + & .3449454E+03,.3852281E+03,.4879958E+03,.3481076E+03,.2774131E+03,& + & .3448962E+03,.3851933E+03,.4879510E+03,.3480925E+03,.2774131E+03,& + & .3449110E+03,.3852033E+03,.4879177E+03,.3480925E+03,.2774131E+03,& + & .3448566E+03,.3851637E+03,.4878970E+03,.3480725E+03,.2774131E+03,& + & .3448121E+03,.3851293E+03,.4878714E+03,.3480521E+03,.2774131E+03,& + & .3447725E+03,.3850996E+03,.4878362E+03,.3480369E+03,.2774131E+03,& + & .3447381E+03,.3850700E+03,.4878014E+03,.3480269E+03,.2774131E+03,& + & .3447429E+03,.3850800E+03,.4877729E+03,.3480269E+03,.2774131E+03,& + & .3446985E+03,.3850504E+03,.4877618E+03,.3480117E+03,.2774131E+03,& + & .3446640E+03,.3850156E+03,.4877414E+03,.3479917E+03,.2774131E+03,& + & .3446344E+03,.3849960E+03,.4877114E+03,.3479765E+03,.2774131E+03,& + & .3445996E+03,.3849712E+03,.4876818E+03,.3479665E+03,.2774131E+03,& + & .3446096E+03,.3849812E+03,.4876577E+03,.3479713E+03,.2774131E+03,& + & .3445752E+03,.3849515E+03,.4876518E+03,.3479613E+03,.2774131E+03,& + & .3445456E+03,.3849267E+03,.4876366E+03,.3479461E+03,.2774131E+03,& + & .3445208E+03,.3849119E+03,.4876118E+03,.3479361E+03,.2774131E+03,& + & .3444960E+03,.3848871E+03,.4875822E+03,.3479261E+03,.2774131E+03/ + + data absb(526:700, 3) / & + & .3444960E+03,.3848971E+03,.4875677E+03,.3479261E+03,.2774131E+03,& + & .3444763E+03,.3848775E+03,.4875670E+03,.3479209E+03,.2774131E+03,& + & .3444515E+03,.3848575E+03,.4875518E+03,.3479057E+03,.2774131E+03,& + & .3444319E+03,.3848427E+03,.4875270E+03,.3478957E+03,.2774131E+03,& + & .3444071E+03,.3848279E+03,.4874973E+03,.3478906E+03,.2774131E+03,& + & .3444171E+03,.3848331E+03,.4874977E+03,.3478957E+03,.2774131E+03,& + & .3443923E+03,.3848183E+03,.4874922E+03,.3478857E+03,.2774131E+03,& + & .3443775E+03,.3847983E+03,.4874818E+03,.3478757E+03,.2774131E+03,& + & .3443579E+03,.3847883E+03,.4874622E+03,.3478706E+03,.2774131E+03,& + & .3443430E+03,.3847734E+03,.4874377E+03,.3478606E+03,.2774131E+03,& + & .3443479E+03,.3847834E+03,.4874377E+03,.3478654E+03,.2774131E+03,& + & .3443330E+03,.3847686E+03,.4874373E+03,.3478554E+03,.2774131E+03,& + & .3443182E+03,.3847538E+03,.4874270E+03,.3478554E+03,.2774131E+03,& + & .3443034E+03,.3847438E+03,.4874122E+03,.3478454E+03,.2774131E+03,& + & .3442886E+03,.3847390E+03,.4873877E+03,.3478402E+03,.2774131E+03,& + & .3442934E+03,.3847442E+03,.4873881E+03,.3478454E+03,.2774131E+03,& + & .3442786E+03,.3847342E+03,.4873873E+03,.3478402E+03,.2774131E+03,& + & .3442638E+03,.3847242E+03,.4873870E+03,.3478302E+03,.2774131E+03,& + & .3442590E+03,.3847094E+03,.4873722E+03,.3478302E+03,.2774131E+03,& + & .3442442E+03,.3846994E+03,.4873477E+03,.3478250E+03,.2774131E+03,& + & .3442490E+03,.3847146E+03,.4873433E+03,.3478250E+03,.2774131E+03,& + & .3442390E+03,.3847046E+03,.4873525E+03,.3478202E+03,.2774131E+03,& + & .3442294E+03,.3846946E+03,.4873522E+03,.3478150E+03,.2774131E+03,& + & .3442194E+03,.3846846E+03,.4873422E+03,.3478150E+03,.2774131E+03,& + & .3442094E+03,.3846798E+03,.4873177E+03,.3478050E+03,.2774131E+03,& + & .3442146E+03,.3846850E+03,.4873085E+03,.3478150E+03,.2774131E+03,& + & .3442046E+03,.3846750E+03,.4873225E+03,.3478050E+03,.2774131E+03,& + & .3441946E+03,.3846698E+03,.4873222E+03,.3478050E+03,.2774131E+03,& + & .3441898E+03,.3846650E+03,.4873173E+03,.3477998E+03,.2774131E+03,& + & .3441798E+03,.3846550E+03,.4872977E+03,.3477998E+03,.2774131E+03,& + & .3441898E+03,.3846650E+03,.4872737E+03,.3477998E+03,.2774131E+03,& + & .3441749E+03,.3846602E+03,.4872929E+03,.3477950E+03,.2774131E+03,& + & .3441701E+03,.3846502E+03,.4872973E+03,.3477898E+03,.2774131E+03,& + & .3441649E+03,.3846453E+03,.4872922E+03,.3477898E+03,.2774131E+03,& + & .3441601E+03,.3846402E+03,.4872825E+03,.3477898E+03,.2774131E+03/ + + data absb(701:875, 3) / & + & .3441601E+03,.3846453E+03,.4872441E+03,.3477898E+03,.2774131E+03,& + & .3441553E+03,.3846453E+03,.4872681E+03,.3477898E+03,.2774131E+03,& + & .3441501E+03,.3846353E+03,.4872773E+03,.3477846E+03,.2774131E+03,& + & .3441453E+03,.3846305E+03,.4872773E+03,.3477798E+03,.2774131E+03,& + & .3441405E+03,.3846253E+03,.4872673E+03,.3477798E+03,.2774131E+03,& + & .3441453E+03,.3846305E+03,.4872244E+03,.3477798E+03,.2774131E+03,& + & .3441353E+03,.3846305E+03,.4872433E+03,.3477798E+03,.2774131E+03,& + & .3441305E+03,.3846205E+03,.4872577E+03,.3477798E+03,.2774131E+03,& + & .3441305E+03,.3846205E+03,.4872622E+03,.3477746E+03,.2774131E+03,& + & .3441205E+03,.3846105E+03,.4872573E+03,.3477746E+03,.2774131E+03,& + & .3441305E+03,.3846205E+03,.4871948E+03,.3477746E+03,.2774131E+03,& + & .3441205E+03,.3846157E+03,.4872237E+03,.3477746E+03,.2774131E+03,& + & .3441157E+03,.3846157E+03,.4872377E+03,.3477746E+03,.2774131E+03,& + & .3441157E+03,.3846057E+03,.4872473E+03,.3477698E+03,.2774131E+03,& + & .3441109E+03,.3846057E+03,.4872473E+03,.3477646E+03,.2774131E+03,& + & .3441157E+03,.3846109E+03,.4871704E+03,.3477698E+03,.2774131E+03,& + & .3441109E+03,.3846057E+03,.4872041E+03,.3477646E+03,.2774131E+03,& + & .3441057E+03,.3846057E+03,.4872229E+03,.3477646E+03,.2774131E+03,& + & .3441009E+03,.3846009E+03,.4872325E+03,.3477646E+03,.2774131E+03,& + & .3441009E+03,.3845957E+03,.4872373E+03,.3477646E+03,.2774131E+03,& + & .3441009E+03,.3846009E+03,.4871412E+03,.3477646E+03,.2774131E+03,& + & .3441009E+03,.3846009E+03,.4871844E+03,.3477646E+03,.2774131E+03,& + & .3440961E+03,.3846009E+03,.4872085E+03,.3477646E+03,.2774131E+03,& + & .3440909E+03,.3845909E+03,.4872225E+03,.3477646E+03,.2774131E+03,& + & .3440909E+03,.3845909E+03,.4872273E+03,.3477646E+03,.2774131E+03,& + & .3440909E+03,.3845961E+03,.4871167E+03,.3477646E+03,.2774131E+03,& + & .3440909E+03,.3845909E+03,.4871600E+03,.3477646E+03,.2774131E+03,& + & .3440861E+03,.3845909E+03,.4871937E+03,.3477594E+03,.2774131E+03,& + & .3440861E+03,.3845861E+03,.4872129E+03,.3477594E+03,.2774131E+03,& + & .3440861E+03,.3845861E+03,.4872225E+03,.3477594E+03,.2774131E+03,& + & .3440861E+03,.3845961E+03,.4870879E+03,.3477594E+03,.2774131E+03,& + & .3440861E+03,.3845861E+03,.4871408E+03,.3477594E+03,.2774131E+03,& + & .3440813E+03,.3845861E+03,.4871741E+03,.3477546E+03,.2774131E+03,& + & .3440761E+03,.3845861E+03,.4871981E+03,.3477546E+03,.2774131E+03,& + & .3440761E+03,.3845809E+03,.4872125E+03,.3477546E+03,.2774131E+03/ + + data absb(876:1050, 3) / & + & .3440761E+03,.3845913E+03,.4870490E+03,.3477546E+03,.2774131E+03,& + & .3440761E+03,.3845861E+03,.4871115E+03,.3477546E+03,.2774131E+03,& + & .3440761E+03,.3845813E+03,.4871548E+03,.3477546E+03,.2774131E+03,& + & .3440713E+03,.3845813E+03,.4871837E+03,.3477546E+03,.2774131E+03,& + & .3440713E+03,.3845761E+03,.4872029E+03,.3477546E+03,.2774131E+03,& + & .3440761E+03,.3845865E+03,.4870153E+03,.3477546E+03,.2774131E+03,& + & .3440713E+03,.3845813E+03,.4870875E+03,.3477546E+03,.2774131E+03,& + & .3440713E+03,.3845761E+03,.4871352E+03,.3477546E+03,.2774131E+03,& + & .3440713E+03,.3845761E+03,.4871689E+03,.3477494E+03,.2774131E+03,& + & .3440713E+03,.3845761E+03,.4871929E+03,.3477494E+03,.2774131E+03,& + & .3440713E+03,.3845917E+03,.4869717E+03,.3477494E+03,.2774131E+03,& + & .3440713E+03,.3845813E+03,.4870582E+03,.3477494E+03,.2774131E+03,& + & .3440713E+03,.3845761E+03,.4871160E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845713E+03,.4871544E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845713E+03,.4871833E+03,.3477494E+03,.2774131E+03,& + & .3440665E+03,.3845917E+03,.4869380E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845765E+03,.4870246E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845713E+03,.4870919E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845713E+03,.4871400E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845713E+03,.4871737E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845869E+03,.4868891E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845817E+03,.4869957E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845713E+03,.4870727E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845661E+03,.4871256E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845713E+03,.4871541E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845921E+03,.4868455E+03,.3477494E+03,.2774131E+03,& + & .3440613E+03,.3845817E+03,.4869569E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845765E+03,.4870386E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845713E+03,.4871012E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845713E+03,.4871396E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845921E+03,.4867966E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845869E+03,.4869180E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845765E+03,.4870146E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845665E+03,.4870819E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845613E+03,.4871300E+03,.3477494E+03,.2774131E+03/ + + data absb(1051:1175, 3) / & + & .3440565E+03,.3845972E+03,.4867477E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845821E+03,.4868843E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845717E+03,.4869857E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845665E+03,.4870627E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845613E+03,.4871156E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845976E+03,.4866985E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845872E+03,.4868403E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845769E+03,.4869520E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845665E+03,.4870386E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845665E+03,.4871012E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3846028E+03,.4866393E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845872E+03,.4868014E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845769E+03,.4869180E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3845717E+03,.4870146E+03,.3477494E+03,.2774131E+03,& + & .3440465E+03,.3845613E+03,.4870819E+03,.3477494E+03,.2774131E+03,& + & .3440565E+03,.3846028E+03,.4865852E+03,.3477494E+03,.2774131E+03,& + & .3440513E+03,.3845924E+03,.4867526E+03,.3477494E+03,.2774131E+03,& + & .3440465E+03,.3845821E+03,.4868839E+03,.3477494E+03,.2774131E+03,& + & .3440465E+03,.3845717E+03,.4869857E+03,.3477494E+03,.2774131E+03,& + & .3440465E+03,.3845665E+03,.4870627E+03,.3477442E+03,.2774131E+03,& + & .3440465E+03,.3846080E+03,.4865652E+03,.3477494E+03,.2774131E+03,& + & .3440465E+03,.3845924E+03,.4867329E+03,.3477494E+03,.2774131E+03,& + & .3440465E+03,.3845821E+03,.4868695E+03,.3477442E+03,.2774131E+03,& + & .3440465E+03,.3845717E+03,.4869761E+03,.3477442E+03,.2774131E+03,& + & .3440465E+03,.3845665E+03,.4870531E+03,.3477442E+03,.2774131E+03/ + + data absb( 1:175, 4) / & + & .8782833E+03,.6910354E+03,.5724886E+03,.6464156E+03,.7993949E+03,& + & .8715031E+03,.6859459E+03,.5705842E+03,.6464442E+03,.7999135E+03,& + & .8656602E+03,.6815696E+03,.5686553E+03,.6463947E+03,.8002608E+03,& + & .8605853E+03,.6777583E+03,.5667574E+03,.6462801E+03,.8004368E+03,& + & .8561252E+03,.6744132E+03,.5649105E+03,.6460944E+03,.8004368E+03,& + & .8612940E+03,.6782938E+03,.5669216E+03,.6455568E+03,.7994505E+03,& + & .8558228E+03,.6741854E+03,.5649339E+03,.6456484E+03,.7999506E+03,& + & .8511049E+03,.6706518E+03,.5630723E+03,.6456464E+03,.8002840E+03,& + & .8469964E+03,.6675691E+03,.5613310E+03,.6455686E+03,.8004461E+03,& + & .8433882E+03,.6648582E+03,.5596704E+03,.6454205E+03,.8004322E+03,& + & .8474420E+03,.6679062E+03,.5613362E+03,.6448724E+03,.7995061E+03,& + & .8430265E+03,.6645957E+03,.5595545E+03,.6450016E+03,.7999923E+03,& + & .8392252E+03,.6617362E+03,.5578650E+03,.6450418E+03,.8003071E+03,& + & .8359047E+03,.6592484E+03,.5563042E+03,.6449917E+03,.8004461E+03,& + & .8329859E+03,.6570576E+03,.5548590E+03,.6448650E+03,.8004183E+03,& + & .8361725E+03,.6594516E+03,.5562448E+03,.6443217E+03,.7995709E+03,& + & .8326189E+03,.6567852E+03,.5546746E+03,.6444831E+03,.8000339E+03,& + & .8295516E+03,.6544805E+03,.5532717E+03,.6445409E+03,.8003349E+03,& + & .8268752E+03,.6524736E+03,.5519977E+03,.6445269E+03,.8004507E+03,& + & .8245113E+03,.6507091E+03,.5508204E+03,.6444124E+03,.8004090E+03,& + & .8270338E+03,.6525975E+03,.5518584E+03,.6438793E+03,.7996218E+03,& + & .8241743E+03,.6504514E+03,.5505821E+03,.6440683E+03,.8000756E+03,& + & .8216964E+03,.6485930E+03,.5494126E+03,.6441476E+03,.8003534E+03,& + & .8195356E+03,.6469724E+03,.5483183E+03,.6441412E+03,.8004600E+03,& + & .8176273E+03,.6455403E+03,.5473063E+03,.6440475E+03,.8003951E+03,& + & .8196249E+03,.6470370E+03,.5481983E+03,.6435253E+03,.7996774E+03,& + & .8173102E+03,.6453072E+03,.5470865E+03,.6437357E+03,.8001127E+03,& + & .8153180E+03,.6438105E+03,.5460498E+03,.6438219E+03,.8003720E+03,& + & .8135635E+03,.6424969E+03,.5451238E+03,.6438316E+03,.8004553E+03,& + & .8120275E+03,.6413426E+03,.5443103E+03,.6437493E+03,.8003812E+03,& + & .8136081E+03,.6425269E+03,.5450518E+03,.6432481E+03,.7997283E+03,& + & .8117397E+03,.6411295E+03,.5440951E+03,.6434654E+03,.8001451E+03,& + & .8101291E+03,.6399152E+03,.5434568E+03,.6435677E+03,.8003905E+03,& + & .8087217E+03,.6388594E+03,.5425558E+03,.6435788E+03,.8004553E+03,& + & .8074728E+03,.6379229E+03,.5418598E+03,.6434981E+03,.8003720E+03/ + + data absb(176:350, 4) / & + & .8086917E+03,.6388394E+03,.5425140E+03,.6430324E+03,.7997885E+03,& + & .8071950E+03,.6377198E+03,.5416354E+03,.6432465E+03,.8001867E+03,& + & .8058968E+03,.6367433E+03,.5409750E+03,.6433603E+03,.8004044E+03,& + & .8047572E+03,.6358860E+03,.5404031E+03,.6433729E+03,.8004507E+03,& + & .8037507E+03,.6351327E+03,.5398890E+03,.6432929E+03,.8003442E+03,& + & .8047072E+03,.6358514E+03,.5402679E+03,.6428628E+03,.7998441E+03,& + & .8034982E+03,.6349442E+03,.5396729E+03,.6430884E+03,.8002192E+03,& + & .8024525E+03,.6341615E+03,.5391603E+03,.6431890E+03,.8004183E+03,& + & .8015306E+03,.6334675E+03,.5387162E+03,.6432031E+03,.8004461E+03,& + & .8007226E+03,.6328626E+03,.5383107E+03,.6431246E+03,.8003210E+03,& + & .8014021E+03,.6333736E+03,.5385286E+03,.6427532E+03,.7999274E+03,& + & .8004402E+03,.6326495E+03,.5380753E+03,.6429610E+03,.8002701E+03,& + & .7996030E+03,.6320254E+03,.5376858E+03,.6430585E+03,.8004368E+03,& + & .7988743E+03,.6314752E+03,.5373442E+03,.6430640E+03,.8004368E+03,& + & .7982202E+03,.6309896E+03,.5370303E+03,.6429770E+03,.8002794E+03,& + & .7987304E+03,.6313713E+03,.5371412E+03,.6426697E+03,.8000062E+03,& + & .7979624E+03,.6307965E+03,.5368049E+03,.6428597E+03,.8003164E+03,& + & .7972983E+03,.6302955E+03,.5365078E+03,.6429533E+03,.8004507E+03,& + & .7967135E+03,.6298546E+03,.5362486E+03,.6429503E+03,.8004183E+03,& + & .7961933E+03,.6294629E+03,.5359978E+03,.6428455E+03,.8002331E+03,& + & .7965696E+03,.6297507E+03,.5360417E+03,.6426162E+03,.8000849E+03,& + & .7959601E+03,.6292944E+03,.5357832E+03,.6427892E+03,.8003581E+03,& + & .7954299E+03,.6288935E+03,.5355640E+03,.6428696E+03,.8004600E+03,& + & .7949590E+03,.6285410E+03,.5353686E+03,.6428489E+03,.8003905E+03,& + & .7945427E+03,.6282340E+03,.5351678E+03,.6427355E+03,.8001775E+03,& + & .7948251E+03,.6284372E+03,.5351625E+03,.6425749E+03,.8001590E+03,& + & .7943395E+03,.6280755E+03,.5349778E+03,.6427340E+03,.8003951E+03,& + & .7939186E+03,.6277584E+03,.5348178E+03,.6427966E+03,.8004553E+03,& + & .7935415E+03,.6274807E+03,.5346625E+03,.6427574E+03,.8003581E+03,& + & .7932145E+03,.6272282E+03,.5344964E+03,.6426309E+03,.8001127E+03,& + & .7934130E+03,.6273768E+03,.5344664E+03,.6425483E+03,.8002238E+03,& + & .7930260E+03,.6270890E+03,.5343317E+03,.6426996E+03,.8004229E+03,& + & .7926943E+03,.6268366E+03,.5342117E+03,.6427344E+03,.8004461E+03,& + & .7923919E+03,.6266134E+03,.5340864E+03,.6426820E+03,.8003164E+03,& + & .7921295E+03,.6264149E+03,.5339549E+03,.6425323E+03,.8000339E+03/ + + data absb(351:525, 4) / & + & .7922680E+03,.6265242E+03,.5339049E+03,.6425377E+03,.8002886E+03,& + & .7919656E+03,.6262964E+03,.5338156E+03,.6426613E+03,.8004414E+03,& + & .7916978E+03,.6260932E+03,.5337303E+03,.6426876E+03,.8004275E+03,& + & .7914600E+03,.6259147E+03,.5336295E+03,.6426074E+03,.8002608E+03,& + & .7912522E+03,.6257562E+03,.5335134E+03,.6424353E+03,.7999413E+03,& + & .7913561E+03,.6258354E+03,.5334642E+03,.6425425E+03,.8003396E+03,& + & .7911083E+03,.6256569E+03,.5334042E+03,.6426337E+03,.8004553E+03,& + & .7908952E+03,.6254984E+03,.5333388E+03,.6426322E+03,.8004044E+03,& + & .7907120E+03,.6253545E+03,.5332580E+03,.6425389E+03,.8002006E+03,& + & .7905435E+03,.6252260E+03,.5331566E+03,.6423436E+03,.7998395E+03,& + & .7906128E+03,.6252806E+03,.5331127E+03,.6425289E+03,.8003859E+03,& + & .7904242E+03,.6251367E+03,.5330727E+03,.6426115E+03,.8004553E+03,& + & .7902511E+03,.6250128E+03,.5330219E+03,.6425922E+03,.8003673E+03,& + & .7901026E+03,.6248989E+03,.5329519E+03,.6424757E+03,.8001266E+03,& + & .7899687E+03,.6247997E+03,.5328605E+03,.6422481E+03,.7997283E+03,& + & .7900179E+03,.6248343E+03,.5328366E+03,.6425305E+03,.8004183E+03,& + & .7898694E+03,.6247204E+03,.5328112E+03,.6425854E+03,.8004461E+03,& + & .7897355E+03,.6246211E+03,.5327658E+03,.6425429E+03,.8003210E+03,& + & .7896116E+03,.6245319E+03,.5327051E+03,.6423987E+03,.8000432E+03,& + & .7895077E+03,.6244526E+03,.5326190E+03,.6421432E+03,.7995987E+03,& + & .7895370E+03,.6244726E+03,.5326105E+03,.6425329E+03,.8004414E+03,& + & .7894185E+03,.6243834E+03,.5325958E+03,.6425646E+03,.8004275E+03,& + & .7893092E+03,.6243041E+03,.5325597E+03,.6424944E+03,.8002655E+03,& + & .7892153E+03,.6242295E+03,.5325043E+03,.6423270E+03,.7999460E+03,& + & .7891307E+03,.6241702E+03,.5324182E+03,.6420445E+03,.7994598E+03,& + & .7891507E+03,.6241848E+03,.5324351E+03,.6425307E+03,.8004553E+03,& + & .7890568E+03,.6241156E+03,.5324243E+03,.6425392E+03,.8003998E+03,& + & .7889722E+03,.6240463E+03,.5323943E+03,.6424466E+03,.8001960E+03,& + & .7888929E+03,.6239917E+03,.5323429E+03,.6422514E+03,.7998348E+03,& + & .7888283E+03,.6239424E+03,.5322521E+03,.6419319E+03,.7993069E+03,& + & .7888437E+03,.6239471E+03,.5322936E+03,.6425292E+03,.8004553E+03,& + & .7887644E+03,.6238924E+03,.5322836E+03,.6425100E+03,.8003627E+03,& + & .7886998E+03,.6238432E+03,.5322582E+03,.6423942E+03,.8001173E+03,& + & .7886405E+03,.6237985E+03,.5322021E+03,.6421666E+03,.7997144E+03,& + & .7885859E+03,.6237585E+03,.5321068E+03,.6418054E+03,.7991402E+03/ + + data absb(526:700, 4) / & + & .7885959E+03,.6237639E+03,.5321829E+03,.6425185E+03,.8004461E+03,& + & .7885312E+03,.6237193E+03,.5321775E+03,.6424761E+03,.8003210E+03,& + & .7884766E+03,.6236793E+03,.5321475E+03,.6423418E+03,.8000386E+03,& + & .7884320E+03,.6236446E+03,.5320868E+03,.6420918E+03,.7995987E+03,& + & .7883873E+03,.6236100E+03,.5319860E+03,.6416882E+03,.7989828E+03,& + & .7883973E+03,.6236200E+03,.5320921E+03,.6425078E+03,.8004414E+03,& + & .7883527E+03,.6235854E+03,.5320868E+03,.6424568E+03,.8002933E+03,& + & .7883081E+03,.6235507E+03,.5320621E+03,.6423040E+03,.7999923E+03,& + & .7882688E+03,.6235207E+03,.5320014E+03,.6420401E+03,.7995246E+03,& + & .7882288E+03,.6234961E+03,.5318953E+03,.6416133E+03,.7988948E+03,& + & .7882488E+03,.6235061E+03,.5320114E+03,.6424978E+03,.8004368E+03,& + & .7882042E+03,.6234715E+03,.5320168E+03,.6424468E+03,.8002886E+03,& + & .7881696E+03,.6234469E+03,.5319914E+03,.6422940E+03,.7999830E+03,& + & .7881396E+03,.6234269E+03,.5319360E+03,.6420255E+03,.7995153E+03,& + & .7881103E+03,.6234022E+03,.5318299E+03,.6415941E+03,.7988763E+03,& + & .7881249E+03,.6234169E+03,.5319460E+03,.6424924E+03,.8004507E+03,& + & .7880903E+03,.6233922E+03,.5319614E+03,.6424554E+03,.8003164E+03,& + & .7880603E+03,.6233676E+03,.5319414E+03,.6423118E+03,.8000339E+03,& + & .7880357E+03,.6233476E+03,.5318907E+03,.6420618E+03,.7995848E+03,& + & .7880110E+03,.6233276E+03,.5317953E+03,.6416589E+03,.7989689E+03,& + & .7880257E+03,.6233376E+03,.5318907E+03,.6424878E+03,.8004507E+03,& + & .7880010E+03,.6233176E+03,.5319107E+03,.6424646E+03,.8003442E+03,& + & .7879710E+03,.6233030E+03,.5319014E+03,.6423342E+03,.8000849E+03,& + & .7879510E+03,.6232830E+03,.5318553E+03,.6420981E+03,.7996589E+03,& + & .7879318E+03,.6232683E+03,.5317753E+03,.6417184E+03,.7990662E+03,& + & .7879464E+03,.6232783E+03,.5318507E+03,.6424778E+03,.8004553E+03,& + & .7879218E+03,.6232583E+03,.5318707E+03,.6424639E+03,.8003673E+03,& + & .7879018E+03,.6232483E+03,.5318607E+03,.6423574E+03,.8001266E+03,& + & .7878818E+03,.6232337E+03,.5318307E+03,.6421351E+03,.7997283E+03,& + & .7878672E+03,.6232183E+03,.5317553E+03,.6417832E+03,.7991588E+03,& + & .7878772E+03,.6232283E+03,.5318053E+03,.6424639E+03,.8004553E+03,& + & .7878572E+03,.6232137E+03,.5318353E+03,.6424778E+03,.8004044E+03,& + & .7878425E+03,.6232037E+03,.5318407E+03,.6423844E+03,.8002006E+03,& + & .7878225E+03,.6231891E+03,.5318153E+03,.6421946E+03,.7998395E+03,& + & .7878125E+03,.6231791E+03,.5317499E+03,.6418751E+03,.7993116E+03/ + + data absb(701:875, 4) / & + & .7878225E+03,.6231891E+03,.5317645E+03,.6424400E+03,.8004461E+03,& + & .7878079E+03,.6231791E+03,.5317999E+03,.6424770E+03,.8004275E+03,& + & .7877925E+03,.6231691E+03,.5318153E+03,.6424168E+03,.8002655E+03,& + & .7877779E+03,.6231544E+03,.5317999E+03,.6422548E+03,.7999460E+03,& + & .7877679E+03,.6231444E+03,.5317445E+03,.6419769E+03,.7994598E+03,& + & .7877779E+03,.6231544E+03,.5317245E+03,.6424122E+03,.8004183E+03,& + & .7877633E+03,.6231444E+03,.5317699E+03,.6424770E+03,.8004461E+03,& + & .7877533E+03,.6231344E+03,.5317899E+03,.6424400E+03,.8003210E+03,& + & .7877433E+03,.6231244E+03,.5317853E+03,.6423057E+03,.8000432E+03,& + & .7877333E+03,.6231198E+03,.5317445E+03,.6420556E+03,.7996033E+03,& + & .7877433E+03,.6231244E+03,.5316899E+03,.6423705E+03,.8003766E+03,& + & .7877333E+03,.6231144E+03,.5317399E+03,.6424678E+03,.8004553E+03,& + & .7877186E+03,.6231098E+03,.5317699E+03,.6424585E+03,.8003766E+03,& + & .7877086E+03,.6231044E+03,.5317699E+03,.6423566E+03,.8001451E+03,& + & .7876986E+03,.6230998E+03,.5317445E+03,.6421383E+03,.7997561E+03,& + & .7877086E+03,.6231044E+03,.5316492E+03,.6423150E+03,.8003071E+03,& + & .7876986E+03,.6230998E+03,.5317045E+03,.6424392E+03,.8004461E+03,& + & .7876940E+03,.6230898E+03,.5317445E+03,.6424670E+03,.8004229E+03,& + & .7876840E+03,.6230798E+03,.5317599E+03,.6424022E+03,.8002423E+03,& + & .7876786E+03,.6230798E+03,.5317499E+03,.6422216E+03,.7999089E+03,& + & .7876886E+03,.6230898E+03,.5316092E+03,.6422494E+03,.8002238E+03,& + & .7876786E+03,.6230798E+03,.5316792E+03,.6424068E+03,.8004229E+03,& + & .7876740E+03,.6230698E+03,.5317245E+03,.6424717E+03,.8004461E+03,& + & .7876640E+03,.6230698E+03,.5317445E+03,.6424300E+03,.8003210E+03,& + & .7876540E+03,.6230652E+03,.5317445E+03,.6422957E+03,.8000386E+03,& + & .7876640E+03,.6230698E+03,.5315738E+03,.6421614E+03,.8001080E+03,& + & .7876540E+03,.6230652E+03,.5316438E+03,.6423605E+03,.8003720E+03,& + & .7876540E+03,.6230598E+03,.5316992E+03,.6424578E+03,.8004553E+03,& + & .7876440E+03,.6230552E+03,.5317345E+03,.6424578E+03,.8003812E+03,& + & .7876394E+03,.6230552E+03,.5317399E+03,.6423559E+03,.8001590E+03,& + & .7876494E+03,.6230552E+03,.5315245E+03,.6420410E+03,.7999552E+03,& + & .7876440E+03,.6230552E+03,.5316045E+03,.6422957E+03,.8002840E+03,& + & .7876340E+03,.6230452E+03,.5316692E+03,.6424300E+03,.8004414E+03,& + & .7876294E+03,.6230452E+03,.5317145E+03,.6424670E+03,.8004322E+03,& + & .7876294E+03,.6230406E+03,.5317299E+03,.6424068E+03,.8002655E+03/ + + data absb(876:1050, 4) / & + & .7876340E+03,.6230452E+03,.5314838E+03,.6419067E+03,.7997700E+03,& + & .7876294E+03,.6230452E+03,.5315692E+03,.6422077E+03,.8001729E+03,& + & .7876194E+03,.6230352E+03,.5316392E+03,.6423883E+03,.8003998E+03,& + & .7876194E+03,.6230352E+03,.5316892E+03,.6424670E+03,.8004553E+03,& + & .7876194E+03,.6230352E+03,.5317192E+03,.6424439E+03,.8003488E+03,& + & .7876194E+03,.6230352E+03,.5314438E+03,.6417493E+03,.7995616E+03,& + & .7876194E+03,.6230352E+03,.5315284E+03,.6421012E+03,.8000293E+03,& + & .7876094E+03,.6230306E+03,.5316038E+03,.6423281E+03,.8003581E+03,& + & .7876094E+03,.6230252E+03,.5316692E+03,.6424485E+03,.8004507E+03,& + & .7876047E+03,.6230252E+03,.5317045E+03,.6424624E+03,.8004090E+03,& + & .7876094E+03,.6230306E+03,.5314031E+03,.6415826E+03,.7993394E+03,& + & .7876094E+03,.6230252E+03,.5314884E+03,.6419808E+03,.7998719E+03,& + & .7876047E+03,.6230206E+03,.5315738E+03,.6422540E+03,.8002377E+03,& + & .7875994E+03,.6230206E+03,.5316438E+03,.6424115E+03,.8004275E+03,& + & .7875994E+03,.6230206E+03,.5316892E+03,.6424670E+03,.8004414E+03,& + & .7875994E+03,.6230206E+03,.5313623E+03,.6414066E+03,.7991032E+03,& + & .7875994E+03,.6230206E+03,.5314538E+03,.6418512E+03,.7996959E+03,& + & .7875947E+03,.6230152E+03,.5315392E+03,.6421707E+03,.8001266E+03,& + & .7875947E+03,.6230152E+03,.5316138E+03,.6423652E+03,.8003766E+03,& + & .7875894E+03,.6230106E+03,.5316745E+03,.6424578E+03,.8004553E+03,& + & .7875947E+03,.6230152E+03,.5313123E+03,.6412029E+03,.7988393E+03,& + & .7875947E+03,.6230152E+03,.5314184E+03,.6417030E+03,.7995014E+03,& + & .7875894E+03,.6230106E+03,.5315084E+03,.6420688E+03,.7999876E+03,& + & .7875847E+03,.6230106E+03,.5315838E+03,.6423096E+03,.8003071E+03,& + & .7875847E+03,.6230106E+03,.5316538E+03,.6424346E+03,.8004507E+03,& + & .7875894E+03,.6230106E+03,.5312631E+03,.6409852E+03,.7985568E+03,& + & .7875847E+03,.6230106E+03,.5313777E+03,.6415409E+03,.7992838E+03,& + & .7875847E+03,.6230106E+03,.5314738E+03,.6419484E+03,.7998302E+03,& + & .7875847E+03,.6230106E+03,.5315538E+03,.6422355E+03,.8002099E+03,& + & .7875794E+03,.6230052E+03,.5316292E+03,.6424022E+03,.8004183E+03,& + & .7875847E+03,.6230106E+03,.5312184E+03,.6407722E+03,.7982743E+03,& + & .7875847E+03,.6230106E+03,.5313370E+03,.6413696E+03,.7990569E+03,& + & .7875794E+03,.6230006E+03,.5314384E+03,.6418280E+03,.7996635E+03,& + & .7875747E+03,.6230006E+03,.5315284E+03,.6421522E+03,.8001034E+03,& + & .7875747E+03,.6230006E+03,.5315992E+03,.6423559E+03,.8003673E+03/ + + data absb(1051:1175, 4) / & + & .7875794E+03,.6230006E+03,.5311645E+03,.6405500E+03,.7979826E+03,& + & .7875747E+03,.6230006E+03,.5313070E+03,.6411936E+03,.7988254E+03,& + & .7875747E+03,.6230006E+03,.5314031E+03,.6416937E+03,.7994875E+03,& + & .7875747E+03,.6230006E+03,.5314984E+03,.6420642E+03,.7999784E+03,& + & .7875747E+03,.6230006E+03,.5315738E+03,.6423050E+03,.8003025E+03,& + & .7875747E+03,.6230006E+03,.5311153E+03,.6403138E+03,.7976770E+03,& + & .7875747E+03,.6230006E+03,.5312577E+03,.6409991E+03,.7985753E+03,& + & .7875747E+03,.6230006E+03,.5313723E+03,.6415502E+03,.7992977E+03,& + & .7875747E+03,.6230006E+03,.5314684E+03,.6419577E+03,.7998395E+03,& + & .7875701E+03,.6230006E+03,.5315484E+03,.6422401E+03,.8002238E+03,& + & .7875747E+03,.6230006E+03,.5310514E+03,.6400638E+03,.7973482E+03,& + & .7875747E+03,.6230006E+03,.5312184E+03,.6408000E+03,.7983067E+03,& + & .7875701E+03,.6230006E+03,.5313423E+03,.6413927E+03,.7990847E+03,& + & .7875647E+03,.6230006E+03,.5314331E+03,.6418419E+03,.7996866E+03,& + & .7875647E+03,.6229959E+03,.5315238E+03,.6421660E+03,.8001173E+03,& + & .7875701E+03,.6230006E+03,.5309975E+03,.6398091E+03,.7970241E+03,& + & .7875647E+03,.6230006E+03,.5311692E+03,.6405870E+03,.7980382E+03,& + & .7875647E+03,.6229959E+03,.5313023E+03,.6412260E+03,.7988717E+03,& + & .7875647E+03,.6229959E+03,.5314077E+03,.6417115E+03,.7995246E+03,& + & .7875647E+03,.6229906E+03,.5314984E+03,.6420727E+03,.8000015E+03,& + & .7875647E+03,.6229959E+03,.5309682E+03,.6397072E+03,.7968852E+03,& + & .7875647E+03,.6229959E+03,.5311492E+03,.6404983E+03,.7979224E+03,& + & .7875647E+03,.6229906E+03,.5312931E+03,.6411512E+03,.7987791E+03,& + & .7875647E+03,.6229906E+03,.5313977E+03,.6416652E+03,.7994505E+03,& + & .7875647E+03,.6229906E+03,.5314884E+03,.6420356E+03,.7999552E+03/ + + data absb( 1:175, 5) / & + & .1132160E+04,.8590321E+03,.5914771E+03,.8420290E+03,.1108579E+04,& + & .1123473E+04,.8524625E+03,.5885652E+03,.8420681E+03,.1108734E+04,& + & .1115900E+04,.8468347E+03,.5862702E+03,.8419164E+03,.1108697E+04,& + & .1109376E+04,.8419137E+03,.5843636E+03,.8415502E+03,.1108322E+04,& + & .1103614E+04,.8376140E+03,.5827038E+03,.8409654E+03,.1107682E+04,& + & .1110333E+04,.8425995E+03,.5848362E+03,.8418344E+03,.1108619E+04,& + & .1103219E+04,.8373133E+03,.5831283E+03,.8418712E+03,.1108805E+04,& + & .1097195E+04,.8327409E+03,.5816627E+03,.8417168E+03,.1108673E+04,& + & .1091865E+04,.8287858E+03,.5803753E+03,.8413520E+03,.1108225E+04,& + & .1087188E+04,.8252839E+03,.5792120E+03,.8407467E+03,.1107577E+04,& + & .1092412E+04,.8291999E+03,.5808570E+03,.8416771E+03,.1108633E+04,& + & .1086772E+04,.8249577E+03,.5797842E+03,.8417051E+03,.1108778E+04,& + & .1081872E+04,.8212500E+03,.5788998E+03,.8415393E+03,.1108609E+04,& + & .1077591E+04,.8180528E+03,.5780798E+03,.8411541E+03,.1108196E+04,& + & .1073799E+04,.8152246E+03,.5772425E+03,.8405502E+03,.1107530E+04,& + & .1077932E+04,.8183131E+03,.5785343E+03,.8415558E+03,.1108628E+04,& + & .1073370E+04,.8148772E+03,.5779321E+03,.8415699E+03,.1108773E+04,& + & .1069367E+04,.8118993E+03,.5773345E+03,.8413946E+03,.1108586E+04,& + & .1065923E+04,.8093364E+03,.5766911E+03,.8409868E+03,.1108139E+04,& + & .1062906E+04,.8070496E+03,.5759923E+03,.8403687E+03,.1107413E+04,& + & .1066103E+04,.8094792E+03,.5771890E+03,.8414562E+03,.1108645E+04,& + & .1062427E+04,.8067082E+03,.5767835E+03,.8414606E+03,.1108749E+04,& + & .1059242E+04,.8043159E+03,.5763730E+03,.8412660E+03,.1108562E+04,& + & .1056471E+04,.8022149E+03,.5759120E+03,.8408523E+03,.1108069E+04,& + & .1053956E+04,.8003803E+03,.5753382E+03,.8402087E+03,.1107311E+04,& + & .1056573E+04,.8023128E+03,.5763612E+03,.8413744E+03,.1108681E+04,& + & .1053614E+04,.8000761E+03,.5761904E+03,.8413677E+03,.1108744E+04,& + & .1050995E+04,.7981568E+03,.5759572E+03,.8411623E+03,.1108557E+04,& + & .1048738E+04,.7964524E+03,.5755889E+03,.8407256E+03,.1108012E+04,& + & .1046781E+04,.7949640E+03,.5750302E+03,.8400566E+03,.1107234E+04,& + & .1048831E+04,.7964881E+03,.5759871E+03,.8413116E+03,.1108751E+04,& + & .1046421E+04,.7947095E+03,.5759550E+03,.8412858E+03,.1108763E+04,& + & .1044326E+04,.7931394E+03,.5755277E+03,.8410568E+03,.1108455E+04,& + & .1042519E+04,.7917703E+03,.5753386E+03,.8406038E+03,.1107955E+04,& + & .1040912E+04,.7905575E+03,.5748294E+03,.8399213E+03,.1107129E+04/ + + data absb(176:350, 5) / & + & .1042504E+04,.7917365E+03,.5757083E+03,.8412594E+03,.1108725E+04,& + & .1040562E+04,.7902912E+03,.5758192E+03,.8412189E+03,.1108733E+04,& + & .1038874E+04,.7890443E+03,.5756096E+03,.8409680E+03,.1108430E+04,& + & .1037398E+04,.7879351E+03,.5752218E+03,.8404909E+03,.1107888E+04,& + & .1036091E+04,.7869710E+03,.5746527E+03,.8397830E+03,.1107005E+04,& + & .1037338E+04,.7878931E+03,.5757405E+03,.8412192E+03,.1108773E+04,& + & .1035785E+04,.7867242E+03,.5757045E+03,.8411493E+03,.1108704E+04,& + & .1034434E+04,.7857049E+03,.5754770E+03,.8408953E+03,.1108371E+04,& + & .1033255E+04,.7848307E+03,.5750727E+03,.8403820E+03,.1107804E+04,& + & .1032221E+04,.7840296E+03,.5744847E+03,.8396477E+03,.1106878E+04,& + & .1033083E+04,.7846984E+03,.5756617E+03,.8411849E+03,.1108731E+04,& + & .1031809E+04,.7837832E+03,.5755890E+03,.8410839E+03,.1108675E+04,& + & .1030787E+04,.7829597E+03,.5753383E+03,.8407754E+03,.1108320E+04,& + & .1029807E+04,.7822396E+03,.5749009E+03,.8402301E+03,.1107645E+04,& + & .1028979E+04,.7816263E+03,.5742825E+03,.8394539E+03,.1106694E+04,& + & .1029657E+04,.7821089E+03,.5755832E+03,.8411501E+03,.1108780E+04,& + & .1028643E+04,.7813695E+03,.5754905E+03,.8410195E+03,.1108611E+04,& + & .1027767E+04,.7807233E+03,.5752049E+03,.8406589E+03,.1108196E+04,& + & .1027001E+04,.7801530E+03,.5747429E+03,.8400708E+03,.1107518E+04,& + & .1026393E+04,.7796516E+03,.5740912E+03,.8392499E+03,.1106487E+04,& + & .1026855E+04,.7800266E+03,.5755207E+03,.8411092E+03,.1108746E+04,& + & .1026108E+04,.7794325E+03,.5753911E+03,.8409396E+03,.1108560E+04,& + & .1025405E+04,.7789140E+03,.5750771E+03,.8405361E+03,.1108069E+04,& + & .1024798E+04,.7784615E+03,.5745776E+03,.8399056E+03,.1107291E+04,& + & .1024258E+04,.7780677E+03,.5738970E+03,.8390391E+03,.1106226E+04,& + & .1024599E+04,.7783363E+03,.5754652E+03,.8410717E+03,.1108755E+04,& + & .1023976E+04,.7778616E+03,.5752948E+03,.8408626E+03,.1108455E+04,& + & .1023441E+04,.7774535E+03,.5749424E+03,.8404102E+03,.1107910E+04,& + & .1022936E+04,.7771014E+03,.5744109E+03,.8397256E+03,.1107107E+04,& + & .1022522E+04,.7767688E+03,.5736917E+03,.8388102E+03,.1105992E+04,& + & .1022769E+04,.7769692E+03,.5754043E+03,.8410269E+03,.1108704E+04,& + & .1022268E+04,.7765895E+03,.5751966E+03,.8407518E+03,.1108371E+04,& + & .1021836E+04,.7762638E+03,.5748030E+03,.8402567E+03,.1107761E+04,& + & .1021436E+04,.7759755E+03,.5742299E+03,.8395192E+03,.1106876E+04,& + & .1021119E+04,.7757229E+03,.5734692E+03,.8385490E+03,.1105715E+04/ + + data absb(351:525, 5) / & + & .1021292E+04,.7758615E+03,.5753413E+03,.8409718E+03,.1108668E+04,& + & .1020929E+04,.7755643E+03,.5750916E+03,.8406449E+03,.1108220E+04,& + & .1020592E+04,.7753101E+03,.5746540E+03,.8400874E+03,.1107585E+04,& + & .1020272E+04,.7750812E+03,.5740383E+03,.8393001E+03,.1106614E+04,& + & .1019972E+04,.7748751E+03,.5732385E+03,.8382776E+03,.1105351E+04,& + & .1020107E+04,.7749807E+03,.5752706E+03,.8408913E+03,.1108584E+04,& + & .1019789E+04,.7747389E+03,.5749801E+03,.8405246E+03,.1108134E+04,& + & .1019546E+04,.7745422E+03,.5745060E+03,.8399165E+03,.1107403E+04,& + & .1019286E+04,.7743596E+03,.5738419E+03,.8390704E+03,.1106328E+04,& + & .1019084E+04,.7741942E+03,.5730024E+03,.8379946E+03,.1105002E+04,& + & .1019170E+04,.7742594E+03,.5751978E+03,.8408308E+03,.1108460E+04,& + & .1018904E+04,.7740885E+03,.5748611E+03,.8403860E+03,.1107988E+04,& + & .1018723E+04,.7739185E+03,.5743390E+03,.8397187E+03,.1107159E+04,& + & .1018501E+04,.7737687E+03,.5736328E+03,.8388110E+03,.1106037E+04,& + & .1018361E+04,.7736360E+03,.5727529E+03,.8376904E+03,.1104671E+04,& + & .1018405E+04,.7736814E+03,.5751164E+03,.8407303E+03,.1108371E+04,& + & .1018184E+04,.7735401E+03,.5747312E+03,.8402361E+03,.1107809E+04,& + & .1018016E+04,.7734164E+03,.5741681E+03,.8395069E+03,.1106893E+04,& + & .1017890E+04,.7732973E+03,.5734155E+03,.8385510E+03,.1105713E+04,& + & .1017756E+04,.7731912E+03,.5724903E+03,.8373611E+03,.1104249E+04,& + & .1017792E+04,.7732316E+03,.5750249E+03,.8406141E+03,.1108220E+04,& + & .1017606E+04,.7731185E+03,.5745953E+03,.8400642E+03,.1107577E+04,& + & .1017494E+04,.7730061E+03,.5739811E+03,.8392794E+03,.1106592E+04,& + & .1017366E+04,.7729075E+03,.5731866E+03,.8382606E+03,.1105362E+04,& + & .1017266E+04,.7728198E+03,.5722190E+03,.8370243E+03,.1103792E+04,& + & .1017292E+04,.7728676E+03,.5749177E+03,.8404941E+03,.1108136E+04,& + & .1017190E+04,.7727693E+03,.5744446E+03,.8398803E+03,.1107391E+04,& + & .1017083E+04,.7726878E+03,.5737816E+03,.8390343E+03,.1106328E+04,& + & .1016964E+04,.7726050E+03,.5729440E+03,.8379568E+03,.1105000E+04,& + & .1016882E+04,.7725450E+03,.5719281E+03,.8366665E+03,.1103367E+04,& + & .1016898E+04,.7725446E+03,.5748005E+03,.8403534E+03,.1107950E+04,& + & .1016789E+04,.7724810E+03,.5742785E+03,.8396774E+03,.1107107E+04,& + & .1016697E+04,.7724226E+03,.5735704E+03,.8387721E+03,.1105974E+04,& + & .1016611E+04,.7723504E+03,.5726872E+03,.8376384E+03,.1104578E+04,& + & .1016571E+04,.7723041E+03,.5716302E+03,.8363014E+03,.1102913E+04/ + + data absb(526:700, 5) / & + & .1016584E+04,.7723202E+03,.5746950E+03,.8402176E+03,.1107804E+04,& + & .1016488E+04,.7722577E+03,.5741300E+03,.8394890E+03,.1106878E+04,& + & .1016426E+04,.7722026E+03,.5733811E+03,.8385253E+03,.1105713E+04,& + & .1016380E+04,.7721456E+03,.5724560E+03,.8373415E+03,.1104249E+04,& + & .1016306E+04,.7721127E+03,.5713670E+03,.8359703E+03,.1102470E+04,& + & .1016292E+04,.7721168E+03,.5746264E+03,.8401340E+03,.1107701E+04,& + & .1016228E+04,.7720667E+03,.5740386E+03,.8393714E+03,.1106751E+04,& + & .1016205E+04,.7720362E+03,.5732662E+03,.8383847E+03,.1105553E+04,& + & .1016128E+04,.7719854E+03,.5723210E+03,.8371730E+03,.1104011E+04,& + & .1016090E+04,.7719561E+03,.5712032E+03,.8357753E+03,.1102230E+04,& + & .1016110E+04,.7719675E+03,.5746079E+03,.8401177E+03,.1107679E+04,& + & .1016065E+04,.7719395E+03,.5740164E+03,.8393596E+03,.1106716E+04,& + & .1016018E+04,.7718925E+03,.5732410E+03,.8383584E+03,.1105484E+04,& + & .1015979E+04,.7718623E+03,.5722888E+03,.8371394E+03,.1103992E+04,& + & .1015924E+04,.7718361E+03,.5711776E+03,.8357521E+03,.1102176E+04,& + & .1015947E+04,.7718575E+03,.5746707E+03,.8401949E+03,.1107761E+04,& + & .1015896E+04,.7718201E+03,.5741037E+03,.8394653E+03,.1106876E+04,& + & .1015883E+04,.7717903E+03,.5733511E+03,.8384984E+03,.1105710E+04,& + & .1015843E+04,.7717658E+03,.5724260E+03,.8373113E+03,.1104216E+04,& + & .1015798E+04,.7717449E+03,.5713285E+03,.8359335E+03,.1102415E+04,& + & .1015834E+04,.7717612E+03,.5747316E+03,.8402799E+03,.1107885E+04,& + & .1015782E+04,.7717396E+03,.5741902E+03,.8395813E+03,.1107005E+04,& + & .1015801E+04,.7717242E+03,.5734642E+03,.8386440E+03,.1105870E+04,& + & .1015718E+04,.7716962E+03,.5725620E+03,.8374954E+03,.1104414E+04,& + & .1015732E+04,.7716614E+03,.5714866E+03,.8361383E+03,.1102708E+04,& + & .1015729E+04,.7716742E+03,.5747862E+03,.8403517E+03,.1107983E+04,& + & .1015723E+04,.7716656E+03,.5742723E+03,.8396911E+03,.1107164E+04,& + & .1015702E+04,.7716450E+03,.5735710E+03,.8387908E+03,.1106042E+04,& + & .1015640E+04,.7716167E+03,.5726959E+03,.8376665E+03,.1104643E+04,& + & .1015624E+04,.7716061E+03,.5716434E+03,.8363327E+03,.1102967E+04,& + & .1015631E+04,.7716188E+03,.5748861E+03,.8404775E+03,.1108129E+04,& + & .1015600E+04,.7716030E+03,.5744127E+03,.8398706E+03,.1107389E+04,& + & .1015613E+04,.7715764E+03,.5737556E+03,.8390288E+03,.1106328E+04,& + & .1015597E+04,.7715697E+03,.5729199E+03,.8379553E+03,.1105002E+04,& + & .1015567E+04,.7715535E+03,.5719103E+03,.8366668E+03,.1103378E+04/ + + data absb(701:875, 5) / & + & .1015593E+04,.7715621E+03,.5749733E+03,.8405981E+03,.1108255E+04,& + & .1015568E+04,.7715451E+03,.5745491E+03,.8400486E+03,.1107577E+04,& + & .1015524E+04,.7715394E+03,.5739392E+03,.8392612E+03,.1106614E+04,& + & .1015503E+04,.7715146E+03,.5731507E+03,.8382433E+03,.1105384E+04,& + & .1015505E+04,.7715078E+03,.5721820E+03,.8370057E+03,.1103824E+04,& + & .1015532E+04,.7715161E+03,.5750518E+03,.8407005E+03,.1108396E+04,& + & .1015508E+04,.7715165E+03,.5746709E+03,.8402103E+03,.1107804E+04,& + & .1015497E+04,.7714992E+03,.5741118E+03,.8394869E+03,.1106898E+04,& + & .1015491E+04,.7714822E+03,.5733668E+03,.8385286E+03,.1105713E+04,& + & .1015451E+04,.7714746E+03,.5724432E+03,.8373437E+03,.1104253E+04,& + & .1015486E+04,.7714820E+03,.5751302E+03,.8408091E+03,.1108535E+04,& + & .1015439E+04,.7714848E+03,.5748127E+03,.8403847E+03,.1108012E+04,& + & .1015433E+04,.7714633E+03,.5743039E+03,.8397376E+03,.1107232E+04,& + & .1015424E+04,.7714749E+03,.5736175E+03,.8388518E+03,.1106104E+04,& + & .1015410E+04,.7714655E+03,.5727504E+03,.8377374E+03,.1104743E+04,& + & .1015436E+04,.7714612E+03,.5751941E+03,.8408969E+03,.1108616E+04,& + & .1015415E+04,.7714466E+03,.5749379E+03,.8405563E+03,.1108196E+04,& + & .1015431E+04,.7714422E+03,.5744930E+03,.8399786E+03,.1107523E+04,& + & .1015404E+04,.7714254E+03,.5738675E+03,.8391725E+03,.1106533E+04,& + & .1015390E+04,.7714259E+03,.5730571E+03,.8381379E+03,.1105227E+04,& + & .1015396E+04,.7714361E+03,.5752396E+03,.8409521E+03,.1108709E+04,& + & .1015390E+04,.7714279E+03,.5750483E+03,.8406969E+03,.1108371E+04,& + & .1015395E+04,.7714259E+03,.5746631E+03,.8402006E+03,.1107804E+04,& + & .1015371E+04,.7714032E+03,.5740972E+03,.8394745E+03,.1106873E+04,& + & .1015337E+04,.7714081E+03,.5733553E+03,.8385150E+03,.1105708E+04,& + & .1015386E+04,.7714066E+03,.5752600E+03,.8409913E+03,.1108744E+04,& + & .1015370E+04,.7713985E+03,.5751351E+03,.8408196E+03,.1108557E+04,& + & .1015337E+04,.7713964E+03,.5748223E+03,.8404045E+03,.1108012E+04,& + & .1015367E+04,.7713981E+03,.5743244E+03,.8397592E+03,.1107234E+04,& + & .1015333E+04,.7713847E+03,.5736421E+03,.8388851E+03,.1106199E+04,& + & .1015347E+04,.7714005E+03,.5752587E+03,.8410118E+03,.1108805E+04,& + & .1015311E+04,.7713902E+03,.5752086E+03,.8409157E+03,.1108668E+04,& + & .1015318E+04,.7713893E+03,.5749690E+03,.8405927E+03,.1108222E+04,& + & .1015319E+04,.7713841E+03,.5745459E+03,.8400467E+03,.1107577E+04,& + & .1015312E+04,.7713874E+03,.5739392E+03,.8392646E+03,.1106614E+04/ + + data absb(876:1050, 5) / & + & .1015326E+04,.7713768E+03,.5752286E+03,.8409923E+03,.1108751E+04,& + & .1015341E+04,.7713759E+03,.5752489E+03,.8409777E+03,.1108755E+04,& + & .1015327E+04,.7713686E+03,.5750877E+03,.8407611E+03,.1108430E+04,& + & .1015298E+04,.7713645E+03,.5747398E+03,.8402950E+03,.1107885E+04,& + & .1015298E+04,.7713757E+03,.5742018E+03,.8396055E+03,.1107040E+04,& + & .1015315E+04,.7713740E+03,.5751637E+03,.8409394E+03,.1108628E+04,& + & .1015298E+04,.7713705E+03,.5752637E+03,.8410091E+03,.1108775E+04,& + & .1015291E+04,.7713551E+03,.5751720E+03,.8408697E+03,.1108543E+04,& + & .1015296E+04,.7713612E+03,.5748985E+03,.8405081E+03,.1108141E+04,& + & .1015287E+04,.7713533E+03,.5744395E+03,.8399107E+03,.1107418E+04,& + & .1015330E+04,.7713626E+03,.5750740E+03,.8408557E+03,.1108508E+04,& + & .1015299E+04,.7713625E+03,.5752467E+03,.8410077E+03,.1108736E+04,& + & .1015318E+04,.7713499E+03,.5752320E+03,.8409497E+03,.1108707E+04,& + & .1015318E+04,.7713544E+03,.5750237E+03,.8406755E+03,.1108347E+04,& + & .1015282E+04,.7713600E+03,.5746353E+03,.8401644E+03,.1107726E+04,& + & .1015292E+04,.7713486E+03,.5749639E+03,.8407482E+03,.1108372E+04,& + & .1015292E+04,.7713504E+03,.5752056E+03,.8409790E+03,.1108713E+04,& + & .1015299E+04,.7713406E+03,.5752580E+03,.8409900E+03,.1108719E+04,& + & .1015282E+04,.7713457E+03,.5751224E+03,.8408012E+03,.1108533E+04,& + & .1015288E+04,.7713329E+03,.5748024E+03,.8403755E+03,.1108010E+04,& + & .1015278E+04,.7713411E+03,.5748265E+03,.8406142E+03,.1108188E+04,& + & .1015285E+04,.7713391E+03,.5751400E+03,.8409197E+03,.1108633E+04,& + & .1015300E+04,.7713296E+03,.5752623E+03,.8410092E+03,.1108780E+04,& + & .1015260E+04,.7713359E+03,.5751941E+03,.8408949E+03,.1108613E+04,& + & .1015249E+04,.7713381E+03,.5749404E+03,.8405598E+03,.1108215E+04,& + & .1015290E+04,.7713457E+03,.5746781E+03,.8404406E+03,.1107881E+04,& + & .1015286E+04,.7713522E+03,.5750445E+03,.8408353E+03,.1108489E+04,& + & .1015263E+04,.7713448E+03,.5752353E+03,.8410044E+03,.1108763E+04,& + & .1015276E+04,.7713348E+03,.5752379E+03,.8409611E+03,.1108729E+04,& + & .1015251E+04,.7713276E+03,.5750531E+03,.8407073E+03,.1108401E+04,& + & .1015261E+04,.7713452E+03,.5745201E+03,.8402523E+03,.1107669E+04,& + & .1015285E+04,.7713402E+03,.5749379E+03,.8407260E+03,.1108316E+04,& + & .1015244E+04,.7713261E+03,.5751964E+03,.8409694E+03,.1108716E+04,& + & .1015225E+04,.7713244E+03,.5752625E+03,.8409972E+03,.1108744E+04,& + & .1015265E+04,.7713303E+03,.5751375E+03,.8408146E+03,.1108557E+04/ + + data absb(1051:1175, 5) / & + & .1015244E+04,.7713264E+03,.5743548E+03,.8400510E+03,.1107362E+04,& + & .1015239E+04,.7713259E+03,.5748138E+03,.8406007E+03,.1108145E+04,& + & .1015247E+04,.7713243E+03,.5751348E+03,.8409159E+03,.1108592E+04,& + & .1015239E+04,.7713274E+03,.5752584E+03,.8410086E+03,.1108765E+04,& + & .1015225E+04,.7713165E+03,.5751971E+03,.8409024E+03,.1108626E+04,& + & .1015239E+04,.7713283E+03,.5741622E+03,.8398247E+03,.1107071E+04,& + & .1015242E+04,.7713198E+03,.5746895E+03,.8404515E+03,.1107922E+04,& + & .1015259E+04,.7713226E+03,.5750496E+03,.8408398E+03,.1108489E+04,& + & .1015245E+04,.7713144E+03,.5752404E+03,.8410002E+03,.1108765E+04,& + & .1015213E+04,.7713098E+03,.5752355E+03,.8409584E+03,.1108726E+04,& + & .1015251E+04,.7713192E+03,.5739542E+03,.8395683E+03,.1106711E+04,& + & .1015233E+04,.7713215E+03,.5745434E+03,.8402746E+03,.1107712E+04,& + & .1015233E+04,.7713191E+03,.5749555E+03,.8407368E+03,.1108359E+04,& + & .1015225E+04,.7713188E+03,.5752003E+03,.8409744E+03,.1108718E+04,& + & .1015230E+04,.7713144E+03,.5752584E+03,.8409937E+03,.1108785E+04,& + & .1015229E+04,.7713118E+03,.5737443E+03,.8392982E+03,.1106304E+04,& + & .1015223E+04,.7713138E+03,.5743800E+03,.8400877E+03,.1107435E+04,& + & .1015225E+04,.7713224E+03,.5748430E+03,.8406293E+03,.1108163E+04,& + & .1015242E+04,.7713219E+03,.5751451E+03,.8409290E+03,.1108631E+04,& + & .1015245E+04,.7713273E+03,.5752596E+03,.8410108E+03,.1108780E+04,& + & .1015256E+04,.7713168E+03,.5736529E+03,.8391840E+03,.1106202E+04,& + & .1015245E+04,.7713129E+03,.5743168E+03,.8400016E+03,.1107303E+04,& + & .1015228E+04,.7713181E+03,.5747952E+03,.8405779E+03,.1108104E+04,& + & .1015223E+04,.7713094E+03,.5751176E+03,.8408989E+03,.1108617E+04,& + & .1015221E+04,.7713103E+03,.5752541E+03,.8410111E+03,.1108805E+04/ + + data absb( 1:175, 6) / & + & .1154807E+04,.8742824E+03,.6044416E+03,.8875279E+03,.1172179E+04,& + & .1145735E+04,.8678557E+03,.6038007E+03,.8866634E+03,.1170524E+04,& + & .1138341E+04,.8618214E+03,.6031354E+03,.8856771E+03,.1169072E+04,& + & .1131676E+04,.8569035E+03,.6023105E+03,.8844938E+03,.1167566E+04,& + & .1125765E+04,.8523731E+03,.6012823E+03,.8831031E+03,.1165768E+04,& + & .1132423E+04,.8576942E+03,.6040145E+03,.8872823E+03,.1171938E+04,& + & .1125222E+04,.8521701E+03,.6034057E+03,.8864202E+03,.1170389E+04,& + & .1118840E+04,.8476932E+03,.6027501E+03,.8854305E+03,.1168930E+04,& + & .1113657E+04,.8434208E+03,.6018925E+03,.8841002E+03,.1167350E+04,& + & .1108930E+04,.8400398E+03,.6009245E+03,.8828407E+03,.1165664E+04,& + & .1114323E+04,.8441225E+03,.6036531E+03,.8870573E+03,.1171838E+04,& + & .1108136E+04,.8393878E+03,.6030685E+03,.8861976E+03,.1170255E+04,& + & .1103477E+04,.8360310E+03,.6024155E+03,.8851986E+03,.1168810E+04,& + & .1098878E+04,.8326282E+03,.6015839E+03,.8839936E+03,.1167258E+04,& + & .1095319E+04,.8298688E+03,.6005810E+03,.8825764E+03,.1165436E+04,& + & .1099193E+04,.8328782E+03,.6033501E+03,.8868553E+03,.1171666E+04,& + & .1094160E+04,.8293321E+03,.6027849E+03,.8859925E+03,.1170121E+04,& + & .1090881E+04,.8264769E+03,.6021240E+03,.8849814E+03,.1168673E+04,& + & .1087108E+04,.8233209E+03,.6012865E+03,.8837601E+03,.1167082E+04,& + & .1083860E+04,.8212156E+03,.6002431E+03,.8823316E+03,.1165266E+04,& + & .1087573E+04,.8238271E+03,.6030927E+03,.8866823E+03,.1171492E+04,& + & .1083841E+04,.8210481E+03,.6025442E+03,.8858138E+03,.1169959E+04,& + & .1080483E+04,.8185717E+03,.6018720E+03,.8847842E+03,.1168471E+04,& + & .1077525E+04,.8165982E+03,.6010297E+03,.8835474E+03,.1166895E+04,& + & .1075183E+04,.8146439E+03,.6000078E+03,.8821013E+03,.1165101E+04,& + & .1077583E+04,.8165170E+03,.6028710E+03,.8865245E+03,.1171303E+04,& + & .1074539E+04,.8142927E+03,.6023309E+03,.8856430E+03,.1169820E+04,& + & .1072137E+04,.8120580E+03,.6016533E+03,.8845555E+03,.1168326E+04,& + & .1069843E+04,.8106399E+03,.6007990E+03,.8833472E+03,.1166722E+04,& + & .1067730E+04,.8091125E+03,.5997668E+03,.8818852E+03,.1164922E+04,& + & .1069797E+04,.8107198E+03,.6026903E+03,.8863807E+03,.1171163E+04,& + & .1067434E+04,.8085376E+03,.6021520E+03,.8854952E+03,.1169596E+04,& + & .1065302E+04,.8070848E+03,.6014625E+03,.8844335E+03,.1168167E+04,& + & .1063248E+04,.8057185E+03,.6005661E+03,.8831570E+03,.1166538E+04,& + & .1061700E+04,.8046590E+03,.5995523E+03,.8816793E+03,.1164754E+04/ + + data absb(176:350, 6) / & + & .1063387E+04,.8058664E+03,.6025225E+03,.8862332E+03,.1170967E+04,& + & .1061291E+04,.8043546E+03,.6019839E+03,.8853313E+03,.1169477E+04,& + & .1059375E+04,.8029392E+03,.6012771E+03,.8842066E+03,.1167966E+04,& + & .1058118E+04,.8019047E+03,.6003971E+03,.8829591E+03,.1166269E+04,& + & .1057001E+04,.8008290E+03,.5993321E+03,.8814537E+03,.1164472E+04,& + & .1058126E+04,.8017380E+03,.6023731E+03,.8860941E+03,.1170779E+04,& + & .1056377E+04,.8006266E+03,.6018305E+03,.8851768E+03,.1169335E+04,& + & .1055112E+04,.7997092E+03,.6011088E+03,.8838887E+03,.1167803E+04,& + & .1053591E+04,.7985932E+03,.6002092E+03,.8827556E+03,.1166104E+04,& + & .1052710E+04,.7980450E+03,.5991296E+03,.8811895E+03,.1164303E+04,& + & .1053535E+04,.7985078E+03,.6022154E+03,.8859028E+03,.1170510E+04,& + & .1052649E+04,.7973207E+03,.6016135E+03,.8849596E+03,.1169037E+04,& + & .1051227E+04,.7967413E+03,.6008956E+03,.8838144E+03,.1167519E+04,& + & .1050475E+04,.7962211E+03,.5999630E+03,.8824642E+03,.1165766E+04,& + & .1049370E+04,.7952948E+03,.5988541E+03,.8809085E+03,.1163969E+04,& + & .1050325E+04,.7960009E+03,.6020625E+03,.8857073E+03,.1170186E+04,& + & .1049398E+04,.7952026E+03,.6014647E+03,.8847301E+03,.1168748E+04,& + & .1048230E+04,.7945935E+03,.6006799E+03,.8835488E+03,.1167182E+04,& + & .1047667E+04,.7940912E+03,.5997159E+03,.8821562E+03,.1165463E+04,& + & .1047042E+04,.7935326E+03,.5985744E+03,.8805687E+03,.1163647E+04,& + & .1047281E+04,.7937988E+03,.6019135E+03,.8855050E+03,.1169920E+04,& + & .1046440E+04,.7933166E+03,.6012784E+03,.8844912E+03,.1168471E+04,& + & .1045887E+04,.7928309E+03,.6004624E+03,.8832652E+03,.1166849E+04,& + & .1045297E+04,.7923255E+03,.5994646E+03,.8818357E+03,.1165063E+04,& + & .1044505E+04,.7918388E+03,.5982572E+03,.8802121E+03,.1163214E+04,& + & .1045195E+04,.7920747E+03,.6017576E+03,.8852861E+03,.1169584E+04,& + & .1044449E+04,.7917074E+03,.6010868E+03,.8840962E+03,.1168127E+04,& + & .1043910E+04,.7912987E+03,.6002298E+03,.8829669E+03,.1166499E+04,& + & .1043360E+04,.7907238E+03,.5992000E+03,.8814921E+03,.1164668E+04,& + & .1042953E+04,.7905956E+03,.5979889E+03,.8798344E+03,.1162852E+04,& + & .1043336E+04,.7906786E+03,.6015878E+03,.8850466E+03,.1169289E+04,& + & .1042560E+04,.7904597E+03,.6008783E+03,.8839470E+03,.1167776E+04,& + & .1042396E+04,.7901232E+03,.5999833E+03,.8826272E+03,.1166071E+04,& + & .1041865E+04,.7898279E+03,.5989107E+03,.8811075E+03,.1164265E+04,& + & .1041536E+04,.7894512E+03,.5976609E+03,.8794176E+03,.1162232E+04/ + + data absb(351:525, 6) / & + & .1041735E+04,.7896371E+03,.6014126E+03,.8847933E+03,.1168848E+04,& + & .1041235E+04,.7894095E+03,.6006558E+03,.8836405E+03,.1167384E+04,& + & .1040839E+04,.7890744E+03,.5997245E+03,.8822749E+03,.1165633E+04,& + & .1040637E+04,.7888720E+03,.5986096E+03,.8807131E+03,.1163845E+04,& + & .1040454E+04,.7886684E+03,.5973211E+03,.8789887E+03,.1161882E+04,& + & .1040668E+04,.7886417E+03,.6012280E+03,.8845275E+03,.1168593E+04,& + & .1040157E+04,.7885219E+03,.6004316E+03,.8833250E+03,.1166996E+04,& + & .1039836E+04,.7881981E+03,.5994554E+03,.8819140E+03,.1165226E+04,& + & .1039810E+04,.7880131E+03,.5982992E+03,.8802613E+03,.1163390E+04,& + & .1039396E+04,.7878410E+03,.5969813E+03,.8785538E+03,.1161371E+04,& + & .1039719E+04,.7879584E+03,.6010368E+03,.8841057E+03,.1168138E+04,& + & .1039383E+04,.7875535E+03,.6001922E+03,.8829897E+03,.1166558E+04,& + & .1038687E+04,.7875554E+03,.5991728E+03,.8815245E+03,.1164748E+04,& + & .1038748E+04,.7874938E+03,.5979743E+03,.8798787E+03,.1162892E+04,& + & .1038605E+04,.7873559E+03,.5966233E+03,.8780670E+03,.1160883E+04,& + & .1038508E+04,.7874554E+03,.6008293E+03,.8839425E+03,.1167803E+04,& + & .1038655E+04,.7872552E+03,.5999122E+03,.8825924E+03,.1166035E+04,& + & .1038537E+04,.7869660E+03,.5988787E+03,.8811226E+03,.1164305E+04,& + & .1038302E+04,.7868881E+03,.5976363E+03,.8794383E+03,.1162412E+04,& + & .1038080E+04,.7868277E+03,.5962613E+03,.8776832E+03,.1160344E+04,& + & .1037957E+04,.7867389E+03,.6006076E+03,.8836238E+03,.1167419E+04,& + & .1037919E+04,.7865797E+03,.5996797E+03,.8822650E+03,.1165664E+04,& + & .1037579E+04,.7865886E+03,.5985653E+03,.8807029E+03,.1163863E+04,& + & .1037883E+04,.7866633E+03,.5972822E+03,.8789799E+03,.1161882E+04,& + & .1037601E+04,.7866140E+03,.5958926E+03,.8772343E+03,.1159884E+04,& + & .1037461E+04,.7861854E+03,.6003749E+03,.8832869E+03,.1166982E+04,& + & .1037326E+04,.7862094E+03,.5994026E+03,.8818705E+03,.1165163E+04,& + & .1037061E+04,.7861750E+03,.5982418E+03,.8802656E+03,.1163356E+04,& + & .1037419E+04,.7862176E+03,.5969241E+03,.8785113E+03,.1161372E+04,& + & .1037145E+04,.7860371E+03,.5955189E+03,.8767759E+03,.1159373E+04,& + & .1037013E+04,.7863353E+03,.6001314E+03,.8829351E+03,.1166533E+04,& + & .1036952E+04,.7860923E+03,.5991081E+03,.8814656E+03,.1164747E+04,& + & .1036909E+04,.7858192E+03,.5979043E+03,.8797720E+03,.1162848E+04,& + & .1037101E+04,.7860878E+03,.5965532E+03,.8780077E+03,.1160772E+04,& + & .1037052E+04,.7858782E+03,.5951462E+03,.8762643E+03,.1158850E+04/ + + data absb(526:700, 6) / & + & .1036873E+04,.7857554E+03,.5999088E+03,.8825714E+03,.1166104E+04,& + & .1036902E+04,.7858253E+03,.5988157E+03,.8811019E+03,.1164303E+04,& + & .1036596E+04,.7858513E+03,.5976035E+03,.8794171E+03,.1162395E+04,& + & .1036614E+04,.7859297E+03,.5962301E+03,.8776601E+03,.1160341E+04,& + & .1036517E+04,.7857179E+03,.5947950E+03,.8759039E+03,.1158401E+04,& + & .1036789E+04,.7858044E+03,.5997786E+03,.8824249E+03,.1165869E+04,& + & .1036568E+04,.7858527E+03,.5986878E+03,.8808902E+03,.1164075E+04,& + & .1036290E+04,.7856385E+03,.5973952E+03,.8791810E+03,.1162152E+04,& + & .1036375E+04,.7857728E+03,.5960430E+03,.8773906E+03,.1160111E+04,& + & .1036584E+04,.7856477E+03,.5946509E+03,.8756676E+03,.1158142E+04,& + & .1036449E+04,.7856991E+03,.5997524E+03,.8823952E+03,.1165837E+04,& + & .1036546E+04,.7855390E+03,.5986607E+03,.8808071E+03,.1164007E+04,& + & .1036324E+04,.7856328E+03,.5973933E+03,.8791438E+03,.1162099E+04,& + & .1036443E+04,.7855912E+03,.5960116E+03,.8773979E+03,.1160087E+04,& + & .1036138E+04,.7855274E+03,.5946182E+03,.8754914E+03,.1158117E+04,& + & .1036317E+04,.7854628E+03,.5998802E+03,.8825810E+03,.1166071E+04,& + & .1036407E+04,.7855544E+03,.5988135E+03,.8810642E+03,.1164250E+04,& + & .1036350E+04,.7855655E+03,.5975664E+03,.8793754E+03,.1162334E+04,& + & .1036135E+04,.7854510E+03,.5961891E+03,.8776234E+03,.1160316E+04,& + & .1036293E+04,.7854258E+03,.5947873E+03,.8758601E+03,.1158372E+04,& + & .1036190E+04,.7854073E+03,.6000093E+03,.8827730E+03,.1166300E+04,& + & .1036230E+04,.7852517E+03,.5989682E+03,.8812856E+03,.1164529E+04,& + & .1035870E+04,.7851557E+03,.5977157E+03,.8796174E+03,.1162655E+04,& + & .1036108E+04,.7852461E+03,.5963833E+03,.8777687E+03,.1160603E+04,& + & .1035856E+04,.7854329E+03,.5949784E+03,.8761109E+03,.1158641E+04,& + & .1036008E+04,.7854391E+03,.6001409E+03,.8829635E+03,.1166558E+04,& + & .1035672E+04,.7852254E+03,.5991240E+03,.8815002E+03,.1164752E+04,& + & .1035771E+04,.7851997E+03,.5979225E+03,.8798541E+03,.1162890E+04,& + & .1035959E+04,.7853362E+03,.5965775E+03,.8780456E+03,.1160878E+04,& + & .1036077E+04,.7852519E+03,.5951718E+03,.8763106E+03,.1158912E+04,& + & .1036065E+04,.7853034E+03,.6003541E+03,.8832840E+03,.1166995E+04,& + & .1036122E+04,.7852033E+03,.5993846E+03,.8818706E+03,.1165191E+04,& + & .1035790E+04,.7853073E+03,.5982296E+03,.8802674E+03,.1163356E+04,& + & .1035706E+04,.7852523E+03,.5969107E+03,.8785167E+03,.1161368E+04,& + & .1035830E+04,.7852339E+03,.5955085E+03,.8767385E+03,.1159384E+04/ + + data absb(701:875, 6) / & + & .1035691E+04,.7852423E+03,.6005711E+03,.8836138E+03,.1167419E+04,& + & .1035908E+04,.7853193E+03,.5996475E+03,.8822488E+03,.1165664E+04,& + & .1035762E+04,.7850877E+03,.5985371E+03,.8806907E+03,.1163865E+04,& + & .1035976E+04,.7852798E+03,.5972262E+03,.8789734E+03,.1161918E+04,& + & .1035858E+04,.7852361E+03,.5958649E+03,.8772263E+03,.1159899E+04,& + & .1035722E+04,.7852842E+03,.6007813E+03,.8839238E+03,.1167804E+04,& + & .1035719E+04,.7850227E+03,.5999002E+03,.8826192E+03,.1166124E+04,& + & .1035600E+04,.7850937E+03,.5988393E+03,.8811085E+03,.1164303E+04,& + & .1035738E+04,.7852072E+03,.5975958E+03,.8794250E+03,.1162408E+04,& + & .1035762E+04,.7851633E+03,.5962227E+03,.8776696E+03,.1160304E+04,& + & .1035752E+04,.7852392E+03,.6010174E+03,.8841948E+03,.1168330E+04,& + & .1035945E+04,.7849973E+03,.6001604E+03,.8830466E+03,.1166677E+04,& + & .1035925E+04,.7851444E+03,.5991890E+03,.8815961E+03,.1164885E+04,& + & .1035817E+04,.7848046E+03,.5979682E+03,.8799616E+03,.1162996E+04,& + & .1035850E+04,.7847913E+03,.5966615E+03,.8782015E+03,.1161017E+04,& + & .1035638E+04,.7850513E+03,.6012543E+03,.8846111E+03,.1168741E+04,& + & .1035730E+04,.7851337E+03,.6004922E+03,.8834894E+03,.1167254E+04,& + & .1035445E+04,.7850312E+03,.5995458E+03,.8821086E+03,.1165365E+04,& + & .1035700E+04,.7851973E+03,.5984185E+03,.8805353E+03,.1163672E+04,& + & .1035789E+04,.7850241E+03,.5971269E+03,.8788018E+03,.1161708E+04,& + & .1035632E+04,.7849920E+03,.6014692E+03,.8850013E+03,.1169266E+04,& + & .1035755E+04,.7850265E+03,.6007663E+03,.8838589E+03,.1167803E+04,& + & .1035534E+04,.7848868E+03,.5998828E+03,.8825962E+03,.1166100E+04,& + & .1035605E+04,.7851301E+03,.5988206E+03,.8810847E+03,.1164299E+04,& + & .1035576E+04,.7849624E+03,.5975789E+03,.8793971E+03,.1162393E+04,& + & .1035448E+04,.7851267E+03,.6016773E+03,.8853457E+03,.1169825E+04,& + & .1035833E+04,.7851690E+03,.6010423E+03,.8842300E+03,.1168330E+04,& + & .1035814E+04,.7850287E+03,.6002225E+03,.8830915E+03,.1166729E+04,& + & .1035463E+04,.7849992E+03,.5992224E+03,.8816502E+03,.1164925E+04,& + & .1035596E+04,.7851550E+03,.5980443E+03,.8800202E+03,.1163074E+04,& + & .1035621E+04,.7849593E+03,.6018789E+03,.8857046E+03,.1170389E+04,& + & .1035804E+04,.7849848E+03,.6013182E+03,.8847579E+03,.1168918E+04,& + & .1035665E+04,.7849816E+03,.6005690E+03,.8836138E+03,.1167420E+04,& + & .1035718E+04,.7848933E+03,.5996475E+03,.8822566E+03,.1165667E+04,& + & .1035684E+04,.7848079E+03,.5985373E+03,.8806947E+03,.1163864E+04/ + + data absb(876:1050, 6) / & + & .1035396E+04,.7850994E+03,.6020651E+03,.8860430E+03,.1170959E+04,& + & .1035443E+04,.7850165E+03,.6015627E+03,.8851600E+03,.1169522E+04,& + & .1035416E+04,.7850543E+03,.6008940E+03,.8838713E+03,.1168065E+04,& + & .1035678E+04,.7850493E+03,.6000376E+03,.8828269E+03,.1166399E+04,& + & .1035656E+04,.7848387E+03,.5990054E+03,.8813440E+03,.1164574E+04,& + & .1035799E+04,.7849568E+03,.6022304E+03,.8863649E+03,.1171665E+04,& + & .1035662E+04,.7849150E+03,.6017841E+03,.8855314E+03,.1170121E+04,& + & .1035790E+04,.7851167E+03,.6011844E+03,.8845494E+03,.1168673E+04,& + & .1035751E+04,.7849497E+03,.6004028E+03,.8833168E+03,.1167013E+04,& + & .1035765E+04,.7850336E+03,.5994082E+03,.8819645E+03,.1165343E+04,& + & .1035223E+04,.7849097E+03,.6024415E+03,.8866859E+03,.1172339E+04,& + & .1035610E+04,.7848771E+03,.6019601E+03,.8858592E+03,.1170680E+04,& + & .1035292E+04,.7850288E+03,.6014302E+03,.8849412E+03,.1169154E+04,& + & .1035255E+04,.7849051E+03,.6007179E+03,.8837423E+03,.1167730E+04,& + & .1035724E+04,.7847308E+03,.5998232E+03,.8825148E+03,.1166003E+04,& + & .1035548E+04,.7850328E+03,.6026138E+03,.8870664E+03,.1173037E+04,& + & .1035703E+04,.7849473E+03,.6021374E+03,.8861617E+03,.1171252E+04,& + & .1035663E+04,.7850676E+03,.6016439E+03,.8852969E+03,.1169745E+04,& + & .1035770E+04,.7849775E+03,.6010002E+03,.8842177E+03,.1168267E+04,& + & .1035731E+04,.7851009E+03,.6001688E+03,.8830217E+03,.1166634E+04,& + & .1035751E+04,.7850608E+03,.6027803E+03,.8874485E+03,.1173984E+04,& + & .1035764E+04,.7849860E+03,.6023128E+03,.8864542E+03,.1171860E+04,& + & .1035482E+04,.7850930E+03,.6018352E+03,.8856260E+03,.1170255E+04,& + & .1035535E+04,.7849801E+03,.6012570E+03,.8846634E+03,.1168815E+04,& + & .1035673E+04,.7849343E+03,.6004942E+03,.8834988E+03,.1167257E+04,& + & .1035524E+04,.7848552E+03,.6029106E+03,.8880716E+03,.1174957E+04,& + & .1035658E+04,.7846826E+03,.6024834E+03,.8867342E+03,.1172519E+04,& + & .1035489E+04,.7848135E+03,.6020058E+03,.8859421E+03,.1170818E+04,& + & .1035424E+04,.7848886E+03,.6014905E+03,.8850368E+03,.1169362E+04,& + & .1035663E+04,.7850003E+03,.6007966E+03,.8839492E+03,.1167867E+04,& + & .1035504E+04,.7848111E+03,.6031050E+03,.8887172E+03,.1175944E+04,& + & .1035279E+04,.7847971E+03,.6026411E+03,.8871385E+03,.1173254E+04,& + & .1035415E+04,.7850072E+03,.6021673E+03,.8862095E+03,.1171363E+04,& + & .1035656E+04,.7850409E+03,.6016799E+03,.8853554E+03,.1169825E+04,& + & .1035406E+04,.7848736E+03,.6010491E+03,.8843357E+03,.1168391E+04/ + + data absb(1051:1175, 6) / & + & .1035713E+04,.7849729E+03,.6032946E+03,.8893995E+03,.1176941E+04,& + & .1035444E+04,.7849707E+03,.6027864E+03,.8875237E+03,.1174025E+04,& + & .1035565E+04,.7850045E+03,.6023190E+03,.8864702E+03,.1171867E+04,& + & .1035712E+04,.7849606E+03,.6018460E+03,.8856449E+03,.1170317E+04,& + & .1035707E+04,.7850798E+03,.6012695E+03,.8846865E+03,.1168843E+04,& + & .1035705E+04,.7849167E+03,.6035391E+03,.8900967E+03,.1177953E+04,& + & .1035730E+04,.7849972E+03,.6028979E+03,.8880295E+03,.1174870E+04,& + & .1035405E+04,.7849160E+03,.6024731E+03,.8867542E+03,.1172461E+04,& + & .1035544E+04,.7850359E+03,.6019902E+03,.8859187E+03,.1170739E+04,& + & .1035719E+04,.7850739E+03,.6014757E+03,.8850119E+03,.1169315E+04,& + & .1035505E+04,.7850447E+03,.6039271E+03,.8909936E+03,.1179187E+04,& + & .1035517E+04,.7849136E+03,.6030826E+03,.8886380E+03,.1175823E+04,& + & .1035643E+04,.7849538E+03,.6026205E+03,.8870923E+03,.1173152E+04,& + & .1035536E+04,.7849523E+03,.6021490E+03,.8861784E+03,.1171261E+04,& + & .1035534E+04,.7850334E+03,.6016601E+03,.8853177E+03,.1169773E+04,& + & .1035546E+04,.7850318E+03,.6043242E+03,.8919185E+03,.1180418E+04,& + & .1035602E+04,.7849911E+03,.6032555E+03,.8892747E+03,.1176756E+04,& + & .1035555E+04,.7849176E+03,.6027602E+03,.8874056E+03,.1173878E+04,& + & .1035566E+04,.7849074E+03,.6022939E+03,.8864253E+03,.1171787E+04,& + & .1035501E+04,.7847965E+03,.6018145E+03,.8855936E+03,.1170187E+04,& + & .1035450E+04,.7849937E+03,.6045469E+03,.8923132E+03,.1180947E+04,& + & .1035470E+04,.7849930E+03,.6033415E+03,.8895406E+03,.1177165E+04,& + & .1035648E+04,.7849151E+03,.6028185E+03,.8876106E+03,.1174216E+04,& + & .1035655E+04,.7850350E+03,.6023184E+03,.8865228E+03,.1172007E+04,& + & .1035589E+04,.7850346E+03,.6018757E+03,.8856974E+03,.1170389E+04/ + +!........................................! + end module module_radsw_kgb28 ! +!========================================! + + +!> This module sets up absorption coeffients for band 29: 820-2600 +!! cm-1 (low - h2o; high - co2) +!========================================! + module module_radsw_kgb29 ! +!........................................! +! +! ********* the original program descriptions ********* ! +! ! +! originally by j.delamere, atmospheric & environmental research. ! +! revision: 2.4 ! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) ! +! reformatted for f90 by jjmorcrette, ecmwf ! +! ! +! this table has been re-generated for reduced number of g-point ! +! by y.t.hou, ncep ! +! ! +! ********* ********* end description ********* ********* ! +! + use physparam, only : kind_phys + use module_radsw_parameters, only : NG29 + +! + implicit none +! + private +! +!> msa29=65 + integer, public :: MSA29 +!> msb29=235 + integer, public :: MSB29 +!> msf29=10 + integer, public :: MSF29 +!> mfr29=4 + integer, public :: MFR29 + parameter (MSA29=65, MSB29=235, MSF29=10, MFR29=4) + + real (kind=kind_phys), public :: forref(MFR29,NG29) + +!> the array absa(65,NG29) (ka(5,13,NG29)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels> ~100mb, +!! temperatures, and binary species parameters (see taumol.f for definition). +!! the first index in the array, js, runs from 1 to 9, and corresponds to +!! different values of the binary species parameter. for instance, +!! js=1 refers to dry air, js = 2 corresponds to the paramter value 1/8, +!! js = 3 corresponds to the parameter value 2/8, etc. the second index +!! in the array, jt, which runs from 1 to 5, corresponds to different +!! temperatures. more specifically, jt = 3 means that the data are for +!! the reference temperature tref for this pressure level, jt = 2 refers +!! to tref-15, jt = 1 is for tref-30, jt = 4 is for tref+15, and jt = 5 +!! is for tref+30. the third index, jp, runs from 1 to 13 and refers +!! to the jpth reference pressure level (see taumol.f for these levels +!! in mb). the fourth index, ig, goes from 1 to 12, and indicates +!! which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absa(MSA29,NG29) + +!> the array absb(235,12) (kb(5,13:59,12)) contains absorption coefs at +!! the 16 chosen g-values for a range of pressure levels < ~100mb and +!! temperatures. the first index in the array, jt, which runs from 1 to 5, +!! corresponds to different temperatures. more specifically, jt = 3 means +!! that the data are for the reference temperature tref for this pressure +!! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +!! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +!! the second index, jp, runs from 13 to 59 and refers to the jpth +!! reference pressure level (see taumol.f for the value of these +!! pressure levels in mb). the third index, ig, goes from 1 to 12, +!! and tells us which g-interval the absorption coefficients are for. + real (kind=kind_phys), public :: absb(MSB29,NG29) + +!> the array selfref contains the coefficient of the water vapor +!! self-continuum (including the energy term). the first index +!! refers to temperature in 7.2 degree increments. For instance, +!! jt = 1 refers to a temperature of 245.6, jt = 2 refers to 252.8, +!! etc. the second index runs over the g-channel (1 to 12). + real (kind=kind_phys), public :: selfref(MSF29,NG29) + +!> h2o + real (kind=kind_phys), public :: absh2o(NG29) + +!> co2 + real (kind=kind_phys), public :: absco2(NG29) + +!> rayleigh extinction coefficient at \f$v=2200cm^{-1}\f$ + real (kind=kind_phys), parameter, public :: rayl = 9.30e-11 + +! --- h2o + data absh2o (1:12) / .2995080E-03,.3950120E-02,& + & .1493160E-01,.3243840E-01,.9440181E-01,.1006542E+01,.9383158E+01,& + & .2134138E+00,.2155620E+00,.2180870E+00,.2209180E+00,.2185460E+00/ + +! --- co2 + data absco2 (1:12) / .2900730E-05,.2123820E-04,& + & .1030320E-03,.1864810E-03,.5136065E-03,.2118687E-01,.4146680E+01,& + & .4301567E+02,.1641290E+03,.8322820E+03,.4995020E+04,.1267810E+05/ + + data absa( 1: 65, 1) / & + & .1156500E-03,.1012300E-03,.9080400E-04,.8228200E-04,.7108300E-04,& + & .9643400E-04,.8283000E-04,.7236600E-04,.6180300E-04,.5249700E-04,& + & .6453900E-04,.5665900E-04,.4660500E-04,.3981500E-04,.3711800E-04,& + & .3441700E-04,.2711300E-04,.2536200E-04,.3034500E-04,.3627500E-04,& + & .1226000E-04,.1585600E-04,.2083400E-04,.2736300E-04,.3611400E-04,& + & .1022100E-04,.1459800E-04,.1969500E-04,.2597600E-04,.3370200E-04,& + & .9756300E-05,.1380900E-04,.2023100E-04,.2723800E-04,.3611000E-04,& + & .1406200E-04,.1958700E-04,.2706900E-04,.3693700E-04,.4941500E-04,& + & .3637100E-04,.4812200E-04,.6158600E-04,.7764700E-04,.9989700E-04,& + & .9920300E-04,.1284200E-03,.1658800E-03,.2083400E-03,.2600000E-03,& + & .1323300E-03,.1731800E-03,.2205900E-03,.2890400E-03,.3606200E-03,& + & .1337900E-03,.1748400E-03,.2368700E-03,.3028600E-03,.3750400E-03,& + & .1174000E-03,.1566700E-03,.2096200E-03,.2676800E-03,.3348500E-03/ + + data absa( 1: 65, 2) / & + & .1024600E-03,.1045000E-03,.9738300E-04,.9639800E-04,.1054900E-03,& + & .1058900E-03,.1024000E-03,.9580100E-04,.9850900E-04,.1199300E-03,& + & .9405400E-04,.8700900E-04,.1094100E-03,.1348600E-03,.1591800E-03,& + & .1188300E-03,.1423600E-03,.1663600E-03,.1823500E-03,.1978500E-03,& + & .1780000E-03,.1934700E-03,.2097700E-03,.2273000E-03,.2511100E-03,& + & .2224300E-03,.2415700E-03,.2656700E-03,.2854900E-03,.3072300E-03,& + & .2924800E-03,.3224200E-03,.3463500E-03,.3791500E-03,.4080300E-03,& + & .4338600E-03,.4861100E-03,.5268100E-03,.5681200E-03,.6064200E-03,& + & .8910900E-03,.1034500E-02,.1179400E-02,.1304500E-02,.1430300E-02,& + & .2153800E-02,.2445900E-02,.2732900E-02,.3093200E-02,.3525300E-02,& + & .2927200E-02,.3267600E-02,.3635300E-02,.4006200E-02,.4544100E-02,& + & .3076200E-02,.3436500E-02,.3814600E-02,.4155600E-02,.4716400E-02,& + & .2780800E-02,.3111400E-02,.3438300E-02,.3795400E-02,.4257600E-02/ + + data absa( 1: 65, 3) / & + & .2404200E-03,.3271900E-03,.4437000E-03,.5683600E-03,.7035700E-03,& + & .2330300E-03,.3190100E-03,.4192600E-03,.5240000E-03,.6236500E-03,& + & .3505000E-03,.4215800E-03,.4749000E-03,.5339000E-03,.6041100E-03,& + & .4995400E-03,.5306700E-03,.5633800E-03,.6085900E-03,.6656900E-03,& + & .6690800E-03,.6972700E-03,.7289800E-03,.7675600E-03,.8035800E-03,& + & .8863400E-03,.9285300E-03,.9685600E-03,.1010100E-02,.1055600E-02,& + & .1165900E-02,.1235500E-02,.1323800E-02,.1388900E-02,.1449100E-02,& + & .1748500E-02,.1822300E-02,.1941100E-02,.2070500E-02,.2202500E-02,& + & .4244200E-02,.4356100E-02,.4506100E-02,.4750500E-02,.5035800E-02,& + & .1094000E-01,.1149900E-01,.1190600E-01,.1257000E-01,.1280300E-01,& + & .1428700E-01,.1501000E-01,.1558100E-01,.1605400E-01,.1660900E-01,& + & .1485600E-01,.1554600E-01,.1607400E-01,.1647800E-01,.1705700E-01,& + & .1325700E-01,.1383400E-01,.1415500E-01,.1472300E-01,.1509500E-01/ + + data absa( 1: 65, 4) / & + & .2439100E-02,.2872000E-02,.3349700E-02,.3892600E-02,.4505400E-02,& + & .2250600E-02,.2600400E-02,.3000200E-02,.3449000E-02,.3957900E-02,& + & .2215300E-02,.2571100E-02,.2932000E-02,.3333000E-02,.3772800E-02,& + & .2248300E-02,.2544500E-02,.2874500E-02,.3248400E-02,.3655400E-02,& + & .2338800E-02,.2598500E-02,.2891400E-02,.3237700E-02,.3611300E-02,& + & .2466900E-02,.2657900E-02,.2883400E-02,.3153800E-02,.3459300E-02,& + & .3253600E-02,.3341300E-02,.3437500E-02,.3590500E-02,.3801000E-02,& + & .5122800E-02,.5196700E-02,.5282000E-02,.5344600E-02,.5379700E-02,& + & .1302900E-01,.1306500E-01,.1289100E-01,.1284800E-01,.1277700E-01,& + & .2991100E-01,.3011700E-01,.2834000E-01,.2732100E-01,.2748500E-01,& + & .3666300E-01,.3687700E-01,.3468800E-01,.3300400E-01,.3243700E-01,& + & .3728200E-01,.3777500E-01,.3491000E-01,.3346300E-01,.3307400E-01,& + & .3341200E-01,.3296100E-01,.3032300E-01,.2943700E-01,.2957200E-01/ + + data absa( 1: 65, 5) / & + & .5737669E-01,.6072679E-01,.6409123E-01,.6738949E-01,.7052420E-01,& + & .5012852E-01,.5294581E-01,.5563579E-01,.5843403E-01,.6127801E-01,& + & .4354787E-01,.4609744E-01,.4874155E-01,.5138444E-01,.5397080E-01,& + & .3827336E-01,.4064492E-01,.4287087E-01,.4511010E-01,.4735934E-01,& + & .3418365E-01,.3615136E-01,.3817782E-01,.4009673E-01,.4202725E-01,& + & .3135060E-01,.3301048E-01,.3465038E-01,.3632036E-01,.3815047E-01,& + & .2990607E-01,.3131211E-01,.3276228E-01,.3421907E-01,.3588465E-01,& + & .3047960E-01,.3187197E-01,.3323626E-01,.3465826E-01,.3619150E-01,& + & .4306469E-01,.4376339E-01,.4465622E-01,.4556160E-01,.4646970E-01,& + & .8678394E-01,.8535671E-01,.8559355E-01,.8558578E-01,.8553480E-01,& + & .1070789E+00,.1044012E+00,.1040583E+00,.1040024E+00,.1036748E+00,& + & .1081364E+00,.1052681E+00,.1050326E+00,.1048529E+00,.1046392E+00,& + & .9356527E-01,.9192786E-01,.9227488E-01,.9212577E-01,.9173403E-01/ + + data absa( 1: 65, 6) / & + & .5500343E+00,.5549109E+00,.5588616E+00,.5629779E+00,.5667564E+00,& + & .4994114E+00,.5037790E+00,.5100008E+00,.5169978E+00,.5240736E+00,& + & .5046611E+00,.5105279E+00,.5158277E+00,.5226637E+00,.5303378E+00,& + & .5302528E+00,.5393967E+00,.5458119E+00,.5537515E+00,.5618237E+00,& + & .5411203E+00,.5556023E+00,.5677558E+00,.5802746E+00,.5898268E+00,& + & .5252486E+00,.5447502E+00,.5651635E+00,.5824674E+00,.6014351E+00,& + & .5100890E+00,.5352169E+00,.5583076E+00,.5833005E+00,.6058393E+00,& + & .5180699E+00,.5497814E+00,.5808233E+00,.6108346E+00,.6398736E+00,& + & .6522488E+00,.6891866E+00,.7325459E+00,.7797722E+00,.8260960E+00,& + & .9640811E+00,.1024659E+01,.1093085E+01,.1161786E+01,.1235652E+01,& + & .1047820E+01,.1114446E+01,.1186733E+01,.1258652E+01,.1334983E+01,& + & .1011033E+01,.1074570E+01,.1140350E+01,.1211241E+01,.1280754E+01,& + & .9007538E+00,.9506568E+00,.1005449E+01,.1058464E+01,.1116021E+01/ + + data absa( 1: 65, 7) / & + & .4649358E+01,.4659442E+01,.4675452E+01,.4685713E+01,.4692899E+01,& + & .4599705E+01,.4611058E+01,.4611629E+01,.4612755E+01,.4607683E+01,& + & .4619900E+01,.4611704E+01,.4611644E+01,.4599592E+01,.4592568E+01,& + & .4687320E+01,.4681368E+01,.4668829E+01,.4653209E+01,.4637546E+01,& + & .4851120E+01,.4815554E+01,.4796404E+01,.4771634E+01,.4773910E+01,& + & .5130952E+01,.5103158E+01,.5076979E+01,.5135909E+01,.5190723E+01,& + & .5614324E+01,.5655787E+01,.5731968E+01,.5785423E+01,.5820571E+01,& + & .6802466E+01,.6894140E+01,.6919677E+01,.6955254E+01,.6983671E+01,& + & .9510364E+01,.9545777E+01,.9589682E+01,.9667897E+01,.9623013E+01,& + & .9447407E+01,.9253876E+01,.9037997E+01,.8820753E+01,.8587497E+01,& + & .9261615E+01,.9040240E+01,.8802081E+01,.8566366E+01,.8317559E+01,& + & .9408423E+01,.9193385E+01,.8974202E+01,.8739541E+01,.8508727E+01,& + & .9731443E+01,.9563647E+01,.9382645E+01,.9207221E+01,.9018631E+01/ + + data absa( 1: 65, 8) / & + & .1544733E+02,.1554976E+02,.1552859E+02,.1550737E+02,.1552125E+02,& + & .1738703E+02,.1741986E+02,.1747727E+02,.1744027E+02,.1739669E+02,& + & .1987281E+02,.1989151E+02,.1998931E+02,.1999712E+02,.1998411E+02,& + & .2258389E+02,.2260003E+02,.2268696E+02,.2264651E+02,.2270608E+02,& + & .2504125E+02,.2510226E+02,.2517712E+02,.2519913E+02,.2495283E+02,& + & .2747847E+02,.2717648E+02,.2695792E+02,.2626421E+02,.2537969E+02,& + & .2961485E+02,.2896370E+02,.2795835E+02,.2715755E+02,.2643866E+02,& + & .2732825E+02,.2612667E+02,.2538192E+02,.2458336E+02,.2384624E+02,& + & .5753079E+01,.4812161E+01,.3663267E+01,.2188469E+01,.1578210E+01,& + & .1936683E+00,.1796201E+00,.1673070E+00,.1564801E+00,.1466219E+00,& + & .2745909E+00,.2544928E+00,.2369058E+00,.2210443E+00,.2070125E+00,& + & .2913703E+00,.2698520E+00,.2503822E+00,.2335086E+00,.2184884E+00,& + & .2490616E+00,.2300611E+00,.2134111E+00,.1990053E+00,.1862957E+00/ + + data absa( 1: 65, 9) / & + & .2967200E+02,.2929100E+02,.2919100E+02,.2917000E+02,.2911600E+02,& + & .2471300E+02,.2496500E+02,.2503900E+02,.2535500E+02,.2565000E+02,& + & .3051000E+02,.3116600E+02,.3066300E+02,.3102100E+02,.3090100E+02,& + & .3869500E+02,.3892200E+02,.3874100E+02,.3920400E+02,.3882600E+02,& + & .4511800E+02,.4433700E+02,.4366400E+02,.4326700E+02,.4352400E+02,& + & .3465200E+02,.3518200E+02,.3533900E+02,.3534000E+02,.3589900E+02,& + & .1880100E+02,.1859800E+02,.1885500E+02,.1881900E+02,.1905200E+02,& + & .1229700E-01,.1142500E-01,.1067000E-01,.9999400E-02,.9413900E-02,& + & .4682100E-01,.4336100E-01,.4036800E-01,.3775200E-01,.3549300E-01,& + & .1981700E+00,.1830300E+00,.1700200E+00,.1588300E+00,.1493300E+00,& + & .2814500E+00,.2599500E+00,.2418100E+00,.2266000E+00,.2132600E+00,& + & .2951000E+00,.2729400E+00,.2551900E+00,.2394700E+00,.2255100E+00,& + & .2483000E+00,.2307400E+00,.2155600E+00,.2022600E+00,.1902900E+00/ + + data absa( 1: 65,10) / & + & .4716800E+02,.4689000E+02,.4661200E+02,.4635300E+02,.4608800E+02,& + & .4777100E+02,.4698000E+02,.4644500E+02,.4582800E+02,.4543700E+02,& + & .4294600E+02,.4265200E+02,.4379100E+02,.4323700E+02,.4410400E+02,& + & .3095700E+02,.3009800E+02,.3005500E+02,.2955500E+02,.2990200E+02,& + & .2839700E+01,.3857200E+01,.4290600E+01,.4709100E+01,.4813500E+01,& + & .3697800E-02,.3459100E-02,.3252400E-02,.3064900E-02,.2901800E-02,& + & .6173300E-02,.5758900E-02,.5392500E-02,.5074200E-02,.4783500E-02,& + & .1239000E-01,.1152600E-01,.1076600E-01,.1009600E-01,.9501000E-02,& + & .4710500E-01,.4364800E-01,.4066500E-01,.3805400E-01,.3572200E-01,& + & .1991500E+00,.1841200E+00,.1709900E+00,.1595700E+00,.1494800E+00,& + & .2828000E+00,.2612400E+00,.2426600E+00,.2264500E+00,.2121400E+00,& + & .2989100E+00,.2761300E+00,.2564800E+00,.2392700E+00,.2242300E+00,& + & .2542100E+00,.2348400E+00,.2180900E+00,.2034700E+00,.1905700E+00/ + + data absa( 1: 65,11) / & + & .6499400E+02,.6428300E+02,.6375500E+02,.6340700E+02,.6328700E+02,& + & .7826600E+02,.7736400E+02,.7672200E+02,.7628500E+02,.7599200E+02,& + & .4171000E+02,.3837900E+02,.3507600E+02,.3541800E+02,.3330600E+02,& + & .1417000E-02,.1340100E-02,.1271600E-02,.1207300E-02,.1153500E-02,& + & .2365900E-02,.2226100E-02,.2104200E-02,.1995000E-02,.1897000E-02,& + & .3743200E-02,.3510500E-02,.3300600E-02,.3122200E-02,.2952100E-02,& + & .6240800E-02,.5825800E-02,.5478200E-02,.5159400E-02,.4876700E-02,& + & .1252200E-01,.1165200E-01,.1092200E-01,.1026500E-01,.9667200E-02,& + & .4754500E-01,.4415200E-01,.4125100E-01,.3866600E-01,.3635800E-01,& + & .2009700E+00,.1859200E+00,.1734100E+00,.1620300E+00,.1523500E+00,& + & .2849900E+00,.2642800E+00,.2458500E+00,.2298000E+00,.2157500E+00,& + & .3017200E+00,.2792900E+00,.2598000E+00,.2430600E+00,.2278900E+00,& + & .2565500E+00,.2373100E+00,.2209200E+00,.2063900E+00,.1936700E+00/ + + data absa( 1: 65,12) / & + & .8081000E+02,.8109900E+02,.8119000E+02,.8110700E+02,.8098900E+02,& + & .9931900E+02,.9970800E+02,.9982200E+02,.9987100E+02,.9999300E+02,& + & .4692700E+02,.5431600E+02,.5735500E+02,.5371500E+02,.5280200E+02,& + & .1280200E-02,.1202700E-02,.1138600E-02,.1086600E-02,.1052500E-02,& + & .2167500E-02,.2071500E-02,.1942200E-02,.1840200E-02,.1768100E-02,& + & .3470700E-02,.3279600E-02,.3098600E-02,.2924600E-02,.2803400E-02,& + & .5865900E-02,.5531000E-02,.5182000E-02,.4882900E-02,.4678400E-02,& + & .1187500E-01,.1118300E-01,.1043800E-01,.9803800E-02,.9366500E-02,& + & .4551900E-01,.4285000E-01,.3971500E-01,.3744700E-01,.3536900E-01,& + & .1939200E+00,.1810800E+00,.1681700E+00,.1588300E+00,.1486400E+00,& + & .2783000E+00,.2571500E+00,.2410000E+00,.2259500E+00,.2132100E+00,& + & .2953300E+00,.2742200E+00,.2563600E+00,.2393600E+00,.2265800E+00,& + & .2531000E+00,.2353500E+00,.2185500E+00,.2055200E+00,.1929300E+00/ + +! the array absb(235,12) (kb(5,13:59,12)) contains absorption coefs at +! the 16 chosen g-values for a range of pressure levels < ~100mb and +! temperatures. the first index in the array, jt, which runs from 1 to 5, +! corresponds to different temperatures. more specifically, jt = 3 means +! that the data are for the reference temperature tref for this pressure +! level, jt = 2 refers to the temperature tref-15, jt = 1 is for +! tref-30, jt = 4 is for tref+15, and jt = 5 is for tref+30. +! the second index, jp, runs from 13 to 59 and refers to the jpth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). the third index, ig, goes from 1 to 12, +! and tells us which g-interval the absorption coefficients are for. + + data absb( 1:120, 1) / & + & .1837900E-05,.2329600E-05,.2900700E-05,.3590200E-05,.4343700E-05,& + & .1591900E-05,.1983200E-05,.2472000E-05,.3068300E-05,.3725300E-05,& + & .1385000E-05,.1711500E-05,.2122500E-05,.2629200E-05,.3194500E-05,& + & .1189600E-05,.1468000E-05,.1814200E-05,.2253700E-05,.2728400E-05,& + & .1022800E-05,.1259700E-05,.1553200E-05,.1927200E-05,.2316300E-05,& + & .8824300E-06,.1083500E-05,.1331600E-05,.1660300E-05,.1980800E-05,& + & .7567700E-06,.9292500E-06,.1140100E-05,.1410700E-05,.1690100E-05,& + & .6461400E-06,.7936100E-06,.9735300E-06,.1196400E-05,.1441400E-05,& + & .5532300E-06,.6758000E-06,.8264700E-06,.1013700E-05,.1231800E-05,& + & .4771900E-06,.5814900E-06,.7106000E-06,.8700500E-06,.1060500E-05,& + & .4112800E-06,.5008000E-06,.6110400E-06,.7534700E-06,.9120000E-06,& + & .3530600E-06,.4286000E-06,.5232000E-06,.6515600E-06,.7812200E-06,& + & .3036300E-06,.3673100E-06,.4467300E-06,.5609700E-06,.6679100E-06,& + & .2607300E-06,.3153700E-06,.3873800E-06,.4821000E-06,.5738200E-06,& + & .2230300E-06,.2698600E-06,.3362800E-06,.4116100E-06,.4872200E-06,& + & .1895400E-06,.2295200E-06,.2879700E-06,.3516600E-06,.4144000E-06,& + & .1610600E-06,.1943000E-06,.2466100E-06,.2981500E-06,.3515100E-06,& + & .1363000E-06,.1652800E-06,.2092200E-06,.2519300E-06,.2991300E-06,& + & .1150400E-06,.1427600E-06,.1780700E-06,.2148200E-06,.2545100E-06,& + & .9698000E-07,.1221500E-06,.1515900E-06,.1817900E-06,.2151500E-06,& + & .8159800E-07,.1031500E-06,.1273000E-06,.1519000E-06,.1809300E-06,& + & .6770000E-07,.8597000E-07,.1055900E-06,.1260800E-06,.1500600E-06,& + & .5517700E-07,.6951900E-07,.8596700E-07,.1022300E-06,.1214700E-06,& + & .4392400E-07,.5439500E-07,.6799800E-07,.8114200E-07,.9571700E-07/ + + data absb(121:235, 1) / & + & .3446900E-07,.4103600E-07,.5257500E-07,.6311700E-07,.7430100E-07,& + & .2677700E-07,.3173400E-07,.4055500E-07,.4903200E-07,.5765300E-07,& + & .2067000E-07,.2472100E-07,.3068500E-07,.3787300E-07,.4455500E-07,& + & .1586000E-07,.1903200E-07,.2261200E-07,.2884500E-07,.3424600E-07,& + & .1212900E-07,.1460300E-07,.1735700E-07,.2185100E-07,.2634600E-07,& + & .9231900E-08,.1119900E-07,.1336500E-07,.1617400E-07,.2001900E-07,& + & .6928900E-08,.8453700E-08,.1015900E-07,.1199200E-07,.1494000E-07,& + & .5154600E-08,.6338000E-08,.7659300E-08,.9056200E-08,.1071600E-07,& + & .3833500E-08,.4708500E-08,.5721900E-08,.6814800E-08,.7951800E-08,& + & .2858300E-08,.3472400E-08,.4244700E-08,.5088800E-08,.5949400E-08,& + & .2094500E-08,.2541800E-08,.3105800E-08,.3749400E-08,.4427400E-08,& + & .1516400E-08,.1856000E-08,.2262800E-08,.2737100E-08,.3277300E-08,& + & .1091600E-08,.1346500E-08,.1638700E-08,.1974000E-08,.2386500E-08,& + & .7832400E-09,.9836100E-09,.1197700E-08,.1451700E-08,.1745700E-08,& + & .5726300E-09,.7178600E-09,.8768900E-09,.1070500E-08,.1288100E-08,& + & .4157400E-09,.5126400E-09,.6415200E-09,.7831500E-09,.9470500E-09,& + & .2994000E-09,.3683600E-09,.4588600E-09,.5640500E-09,.6916600E-09,& + & .2261700E-09,.2739500E-09,.3375400E-09,.4209500E-09,.5154400E-09,& + & .1748300E-09,.2084500E-09,.2554600E-09,.3181700E-09,.3911900E-09,& + & .1349600E-09,.1593000E-09,.1938000E-09,.2386100E-09,.2977000E-09,& + & .1040600E-09,.1224700E-09,.1474900E-09,.1807800E-09,.2259700E-09,& + & .8134500E-10,.9481600E-10,.1132900E-09,.1383200E-09,.1716100E-09,& + & .6715900E-10,.7831200E-10,.9474500E-10,.1154400E-09,.1444200E-09/ + + data absb( 1:120, 2) / & + & .1665400E-04,.1872800E-04,.2123800E-04,.2449100E-04,.2903800E-04,& + & .1563600E-04,.1757400E-04,.1991800E-04,.2367100E-04,.2723700E-04,& + & .1485300E-04,.1662900E-04,.1970000E-04,.2260400E-04,.2558600E-04,& + & .1351900E-04,.1592300E-04,.1828900E-04,.2053000E-04,.2279900E-04,& + & .1241100E-04,.1443900E-04,.1643100E-04,.1823500E-04,.2010900E-04,& + & .1126700E-04,.1288000E-04,.1442900E-04,.1600500E-04,.1753800E-04,& + & .1002500E-04,.1133200E-04,.1255000E-04,.1385300E-04,.1510300E-04,& + & .8634200E-05,.9745500E-05,.1077800E-04,.1189800E-04,.1278900E-04,& + & .7400400E-05,.8310700E-05,.9163300E-05,.1007100E-04,.1067400E-04,& + & .6370000E-05,.7054900E-05,.7827100E-05,.8517000E-05,.9002200E-05,& + & .5440400E-05,.6015600E-05,.6639300E-05,.7132000E-05,.7500700E-05,& + & .4599700E-05,.5071800E-05,.5571300E-05,.5945500E-05,.6211800E-05,& + & .3874500E-05,.4261700E-05,.4647900E-05,.4929700E-05,.5163800E-05,& + & .3248800E-05,.3559200E-05,.3868500E-05,.4075900E-05,.4309200E-05,& + & .2699500E-05,.2960100E-05,.3206500E-05,.3366600E-05,.3560900E-05,& + & .2235900E-05,.2442900E-05,.2640800E-05,.2775200E-05,.2929300E-05,& + & .1848700E-05,.2008900E-05,.2166800E-05,.2279300E-05,.2402900E-05,& + & .1529100E-05,.1658900E-05,.1773300E-05,.1870600E-05,.1958400E-05,& + & .1255400E-05,.1358900E-05,.1443600E-05,.1519500E-05,.1592800E-05,& + & .1024800E-05,.1104600E-05,.1171600E-05,.1228800E-05,.1291600E-05,& + & .8327200E-06,.8912000E-06,.9503600E-06,.9904000E-06,.1040900E-05,& + & .6751800E-06,.7209700E-06,.7685400E-06,.8024600E-06,.8391200E-06,& + & .5357700E-06,.5787000E-06,.6171500E-06,.6498700E-06,.6722000E-06,& + & .4240200E-06,.4582500E-06,.4930700E-06,.5200500E-06,.5402900E-06/ + + data absb(121:235, 2) / & + & .3341900E-06,.3621300E-06,.3891100E-06,.4135900E-06,.4317700E-06,& + & .2624000E-06,.2835500E-06,.3053000E-06,.3288100E-06,.3461700E-06,& + & .2046800E-06,.2224500E-06,.2398000E-06,.2577600E-06,.2742400E-06,& + & .1607000E-06,.1747800E-06,.1885600E-06,.2023000E-06,.2180100E-06,& + & .1258300E-06,.1368000E-06,.1485100E-06,.1591700E-06,.1718400E-06,& + & .9849400E-07,.1063900E-06,.1163400E-06,.1250000E-06,.1349000E-06,& + & .7519600E-07,.8280900E-07,.9009500E-07,.9795200E-07,.1050900E-06,& + & .5730500E-07,.6378700E-07,.6922700E-07,.7563500E-07,.8168700E-07,& + & .4296500E-07,.4824500E-07,.5334600E-07,.5806100E-07,.6312000E-07,& + & .3104800E-07,.3645700E-07,.4051400E-07,.4455700E-07,.4855000E-07,& + & .2309400E-07,.2635600E-07,.3044300E-07,.3395400E-07,.3678900E-07,& + & .1685800E-07,.1940200E-07,.2244900E-07,.2540100E-07,.2825400E-07,& + & .1141300E-07,.1405500E-07,.1604600E-07,.1892700E-07,.2108000E-07,& + & .7865000E-08,.9987900E-08,.1184600E-07,.1365400E-07,.1587100E-07,& + & .5541700E-08,.6897700E-08,.8700600E-08,.1010800E-07,.1182900E-07,& + & .3914300E-08,.4802500E-08,.6018000E-08,.7376200E-08,.8585100E-08,& + & .2763700E-08,.3339700E-08,.4199600E-08,.5278700E-08,.6292300E-08,& + & .1969100E-08,.2452900E-08,.3007100E-08,.3804100E-08,.4698100E-08,& + & .1303400E-08,.1825700E-08,.2235900E-08,.2821000E-08,.3538600E-08,& + & .1002600E-08,.1342200E-08,.1668700E-08,.2079300E-08,.2605400E-08,& + & .7773000E-09,.9119000E-09,.1246800E-08,.1530200E-08,.1941800E-08,& + & .6035900E-09,.6784800E-09,.9241400E-09,.1151100E-08,.1440100E-08,& + & .5044100E-09,.5679700E-09,.7736900E-09,.9561200E-09,.1195700E-08/ + + data absb( 1:120, 3) / & + & .9812400E-04,.1014900E-03,.1030300E-03,.1066900E-03,.1087000E-03,& + & .8811000E-04,.8973000E-04,.9067900E-04,.9189200E-04,.9141300E-04,& + & .7855500E-04,.7863300E-04,.7914500E-04,.7768900E-04,.7779100E-04,& + & .6724500E-04,.6774300E-04,.6669000E-04,.6576500E-04,.6595000E-04,& + & .5755300E-04,.5749000E-04,.5601200E-04,.5563400E-04,.5601600E-04,& + & .4972900E-04,.4830200E-04,.4741800E-04,.4726200E-04,.4773200E-04,& + & .4210100E-04,.4090600E-04,.4054100E-04,.4022900E-04,.4067100E-04,& + & .3504600E-04,.3419300E-04,.3403200E-04,.3388100E-04,.3469100E-04,& + & .2919200E-04,.2881300E-04,.2852500E-04,.2848500E-04,.2976400E-04,& + & .2421200E-04,.2397000E-04,.2380400E-04,.2394700E-04,.2431000E-04,& + & .2016700E-04,.1996100E-04,.1983700E-04,.2052800E-04,.1988700E-04,& + & .1681700E-04,.1662400E-04,.1652500E-04,.1726300E-04,.1648100E-04,& + & .1389600E-04,.1380600E-04,.1381000E-04,.1434800E-04,.1363400E-04,& + & .1151500E-04,.1147400E-04,.1155300E-04,.1170500E-04,.1116700E-04,& + & .9500400E-05,.9454300E-05,.9565000E-05,.9531600E-05,.9165100E-05,& + & .7813500E-05,.7786200E-05,.7871500E-05,.7782500E-05,.7487700E-05,& + & .6361500E-05,.6360100E-05,.6419800E-05,.6350700E-05,.6120000E-05,& + & .5173800E-05,.5178100E-05,.5225000E-05,.5170900E-05,.5024300E-05,& + & .4182500E-05,.4224000E-05,.4251000E-05,.4224100E-05,.4105800E-05,& + & .3402400E-05,.3430200E-05,.3451400E-05,.3443600E-05,.3347400E-05,& + & .2751000E-05,.2782800E-05,.2805900E-05,.2812500E-05,.2739400E-05,& + & .2219500E-05,.2251700E-05,.2274300E-05,.2272800E-05,.2225400E-05,& + & .1802900E-05,.1823800E-05,.1843200E-05,.1846100E-05,.1824100E-05,& + & .1447700E-05,.1473400E-05,.1493600E-05,.1511600E-05,.1487400E-05/ + + data absb(121:235, 3) / & + & .1163700E-05,.1192900E-05,.1209800E-05,.1226500E-05,.1207600E-05,& + & .9329200E-06,.9624600E-06,.9816900E-06,.9943500E-06,.9874900E-06,& + & .7492700E-06,.7674200E-06,.7902000E-06,.8060400E-06,.8141500E-06,& + & .6047900E-06,.6174300E-06,.6397300E-06,.6529500E-06,.6626100E-06,& + & .4845000E-06,.4974200E-06,.5136600E-06,.5287600E-06,.5381300E-06,& + & .3829800E-06,.4008800E-06,.4119200E-06,.4265100E-06,.4359500E-06,& + & .3031000E-06,.3190500E-06,.3290700E-06,.3415400E-06,.3500700E-06,& + & .2374500E-06,.2503500E-06,.2622400E-06,.2714500E-06,.2814600E-06,& + & .1865300E-06,.1951000E-06,.2064400E-06,.2151000E-06,.2235400E-06,& + & .1475900E-06,.1532200E-06,.1614500E-06,.1703400E-06,.1774400E-06,& + & .1141000E-06,.1200700E-06,.1250700E-06,.1323700E-06,.1399500E-06,& + & .8832700E-07,.9396700E-07,.9768300E-07,.1025700E-06,.1092100E-06,& + & .6671500E-07,.7217200E-07,.7644200E-07,.7921400E-07,.8400600E-07,& + & .5145800E-07,.5576100E-07,.5923900E-07,.6229200E-07,.6447000E-07,& + & .3995700E-07,.4240000E-07,.4587000E-07,.4859200E-07,.5028700E-07,& + & .3115000E-07,.3272500E-07,.3559800E-07,.3763300E-07,.3960700E-07,& + & .2378300E-07,.2541500E-07,.2663400E-07,.2888500E-07,.3062000E-07,& + & .1853100E-07,.1993800E-07,.2098800E-07,.2267800E-07,.2386700E-07,& + & .1481000E-07,.1577200E-07,.1665100E-07,.1772700E-07,.1886100E-07,& + & .1165200E-07,.1255700E-07,.1331900E-07,.1393000E-07,.1507700E-07,& + & .9152300E-08,.9983500E-08,.1060300E-07,.1108100E-07,.1199900E-07,& + & .7238300E-08,.7906000E-08,.8448900E-08,.8861500E-08,.9445600E-08,& + & .6031500E-08,.6593100E-08,.7100100E-08,.7401200E-08,.7876100E-08/ + + data absb( 1:120, 4) / & + & .2188200E-03,.2096800E-03,.1864800E-03,.1750500E-03,.1732000E-03,& + & .1914000E-03,.1702600E-03,.1590300E-03,.1555200E-03,.1600900E-03,& + & .1600300E-03,.1453100E-03,.1400700E-03,.1451100E-03,.1461900E-03,& + & .1338700E-03,.1242300E-03,.1244400E-03,.1274300E-03,.1274900E-03,& + & .1126600E-03,.1078000E-03,.1111000E-03,.1105100E-03,.1107500E-03,& + & .9615600E-04,.9561700E-04,.9677500E-04,.9622000E-04,.9607800E-04,& + & .8271200E-04,.8294600E-04,.8326500E-04,.8282700E-04,.8204400E-04,& + & .7108000E-04,.7116700E-04,.7104000E-04,.7044300E-04,.6906900E-04,& + & .6011000E-04,.6083600E-04,.5999400E-04,.5899200E-04,.5723700E-04,& + & .5068800E-04,.5129600E-04,.5027100E-04,.4888900E-04,.4847100E-04,& + & .4270600E-04,.4262800E-04,.4176400E-04,.3999900E-04,.4089300E-04,& + & .3580300E-04,.3531600E-04,.3453500E-04,.3322900E-04,.3412700E-04,& + & .2990600E-04,.2920100E-04,.2833600E-04,.2745500E-04,.2804400E-04,& + & .2465900E-04,.2392600E-04,.2315900E-04,.2282700E-04,.2326600E-04,& + & .2022100E-04,.1957800E-04,.1883800E-04,.1885300E-04,.1906700E-04,& + & .1634500E-04,.1591300E-04,.1532700E-04,.1541200E-04,.1556000E-04,& + & .1319500E-04,.1287000E-04,.1243000E-04,.1251800E-04,.1263900E-04,& + & .1062200E-04,.1038400E-04,.1006800E-04,.1015100E-04,.1025600E-04,& + & .8578500E-05,.8352300E-05,.8122700E-05,.8199800E-05,.8331300E-05,& + & .6911400E-05,.6709300E-05,.6575800E-05,.6622200E-05,.6767900E-05,& + & .5545600E-05,.5434200E-05,.5322900E-05,.5361000E-05,.5481900E-05,& + & .4446100E-05,.4389100E-05,.4311200E-05,.4363200E-05,.4456000E-05,& + & .3572500E-05,.3519200E-05,.3470300E-05,.3507500E-05,.3591900E-05,& + & .2884200E-05,.2836200E-05,.2814300E-05,.2809700E-05,.2905700E-05/ + + data absb(121:235, 4) / & + & .2337400E-05,.2298700E-05,.2293400E-05,.2281200E-05,.2345100E-05,& + & .1896600E-05,.1867900E-05,.1861300E-05,.1843700E-05,.1889400E-05,& + & .1530000E-05,.1518000E-05,.1509600E-05,.1491500E-05,.1510700E-05,& + & .1242600E-05,.1235700E-05,.1217100E-05,.1217000E-05,.1222700E-05,& + & .1010200E-05,.1007700E-05,.9859300E-06,.9847800E-06,.9921300E-06,& + & .8220100E-06,.8105000E-06,.8031300E-06,.8018100E-06,.8036100E-06,& + & .6731800E-06,.6534700E-06,.6547800E-06,.6436000E-06,.6472200E-06,& + & .5559800E-06,.5335500E-06,.5277800E-06,.5209700E-06,.5199700E-06,& + & .4615700E-06,.4345700E-06,.4241200E-06,.4213700E-06,.4175000E-06,& + & .3915600E-06,.3569000E-06,.3449800E-06,.3399500E-06,.3361400E-06,& + & .3339200E-06,.2974600E-06,.2807400E-06,.2734400E-06,.2707900E-06,& + & .2706600E-06,.2536900E-06,.2311500E-06,.2221300E-06,.2176600E-06,& + & .2219800E-06,.2139500E-06,.1927400E-06,.1804000E-06,.1754200E-06,& + & .1807000E-06,.1736700E-06,.1647300E-06,.1491600E-06,.1430600E-06,& + & .1459500E-06,.1428700E-06,.1384700E-06,.1241800E-06,.1169700E-06,& + & .1181900E-06,.1158800E-06,.1122500E-06,.1060400E-06,.9626900E-07,& + & .9502800E-07,.9309400E-07,.9130300E-07,.8890000E-07,.8026200E-07,& + & .7700500E-07,.7623800E-07,.7422800E-07,.7252600E-07,.6796500E-07,& + & .6297900E-07,.6269200E-07,.6093000E-07,.5957900E-07,.5770000E-07,& + & .5157100E-07,.5119600E-07,.5003100E-07,.4891600E-07,.4812700E-07,& + & .4260200E-07,.4167800E-07,.4100600E-07,.3970900E-07,.3928300E-07,& + & .3515500E-07,.3405200E-07,.3356100E-07,.3239500E-07,.3205700E-07,& + & .2931800E-07,.2851600E-07,.2809700E-07,.2688800E-07,.2684000E-07/ + + data absb( 1:120, 5) / & + & .5646872E-03,.5312795E-03,.5136090E-03,.4988131E-03,.4861599E-03,& + & .4760303E-03,.4583276E-03,.4410876E-03,.4269357E-03,.4186013E-03,& + & .4126853E-03,.3974268E-03,.3837132E-03,.3732654E-03,.3704958E-03,& + & .3556932E-03,.3439374E-03,.3332957E-03,.3278663E-03,.3305577E-03,& + & .3078248E-03,.2969033E-03,.2891762E-03,.2901475E-03,.2947469E-03,& + & .2641839E-03,.2566180E-03,.2537464E-03,.2556275E-03,.2621378E-03,& + & .2264940E-03,.2242650E-03,.2242408E-03,.2276949E-03,.2362173E-03,& + & .1928877E-03,.1922497E-03,.1939580E-03,.2003837E-03,.2081227E-03,& + & .1635486E-03,.1630146E-03,.1664181E-03,.1738976E-03,.1825902E-03,& + & .1382623E-03,.1384386E-03,.1433107E-03,.1505458E-03,.1586465E-03,& + & .1166097E-03,.1183846E-03,.1231655E-03,.1300138E-03,.1374265E-03,& + & .9834271E-04,.1010835E-03,.1058259E-03,.1119955E-03,.1194249E-03,& + & .8297870E-04,.8621261E-04,.9065743E-04,.9659067E-04,.1036206E-03,& + & .7010856E-04,.7362109E-04,.7751831E-04,.8322905E-04,.8970605E-04,& + & .5878661E-04,.6208067E-04,.6580331E-04,.7089987E-04,.7670386E-04,& + & .4892928E-04,.5181644E-04,.5527233E-04,.5975857E-04,.6469853E-04,& + & .4032031E-04,.4266267E-04,.4576398E-04,.4929704E-04,.5363977E-04,& + & .3303540E-04,.3480435E-04,.3759482E-04,.4053873E-04,.4384522E-04,& + & .2673301E-04,.2829877E-04,.3049062E-04,.3280744E-04,.3503681E-04,& + & .2153689E-04,.2293629E-04,.2454493E-04,.2633007E-04,.2814543E-04,& + & .1733556E-04,.1848199E-04,.1972836E-04,.2105193E-04,.2271445E-04,& + & .1408268E-04,.1485471E-04,.1586389E-04,.1695541E-04,.1841529E-04,& + & .1134570E-04,.1192884E-04,.1268134E-04,.1362048E-04,.1483775E-04,& + & .9049567E-05,.9502726E-05,.1010072E-04,.1086491E-04,.1182301E-04/ + + data absb(121:235, 5) / & + & .7259175E-05,.7610477E-05,.8079510E-05,.8694654E-05,.9481533E-05,& + & .5822175E-05,.6083328E-05,.6462080E-05,.6945629E-05,.7579310E-05,& + & .4661372E-05,.4850691E-05,.5152008E-05,.5531782E-05,.6026600E-05,& + & .3768035E-05,.3907858E-05,.4148848E-05,.4439852E-05,.4849767E-05,& + & .3050174E-05,.3152689E-05,.3345838E-05,.3584204E-05,.3905864E-05,& + & .2466186E-05,.2558199E-05,.2693344E-05,.2890245E-05,.3143101E-05,& + & .1984827E-05,.2063835E-05,.2154679E-05,.2317622E-05,.2513311E-05,& + & .1591044E-05,.1657599E-05,.1723355E-05,.1849164E-05,.2007180E-05,& + & .1271611E-05,.1327766E-05,.1384275E-05,.1468719E-05,.1594678E-05,& + & .1012700E-05,.1059571E-05,.1106049E-05,.1165592E-05,.1261722E-05,& + & .8134862E-06,.8456735E-06,.8847293E-06,.9280001E-06,.9964830E-06,& + & .6601437E-06,.6702279E-06,.7033487E-06,.7382687E-06,.7869122E-06,& + & .5354273E-06,.5343277E-06,.5561338E-06,.5862383E-06,.6207320E-06,& + & .4385697E-06,.4345687E-06,.4441542E-06,.4677126E-06,.4945272E-06,& + & .3616858E-06,.3547589E-06,.3578695E-06,.3746540E-06,.3960932E-06,& + & .2980067E-06,.2907198E-06,.2906884E-06,.2989166E-06,.3168227E-06,& + & .2459704E-06,.2382262E-06,.2364831E-06,.2390246E-06,.2515295E-06,& + & .2050509E-06,.1972206E-06,.1946661E-06,.1956373E-06,.2034775E-06,& + & .1708630E-06,.1642309E-06,.1612950E-06,.1615287E-06,.1659752E-06,& + & .1426277E-06,.1371033E-06,.1336511E-06,.1333485E-06,.1355595E-06,& + & .1182556E-06,.1146132E-06,.1111012E-06,.1106095E-06,.1111974E-06,& + & .9823259E-07,.9553915E-07,.9253575E-07,.9185070E-07,.9208712E-07,& + & .8406156E-07,.8113764E-07,.7830100E-07,.7796398E-07,.7863117E-07/ + + data absb( 1:120, 6) / & + & .1876746E-01,.1987652E-01,.2118689E-01,.2284887E-01,.2484965E-01,& + & .1797735E-01,.1911766E-01,.2049609E-01,.2208055E-01,.2390495E-01,& + & .1742326E-01,.1850993E-01,.1995764E-01,.2157831E-01,.2349113E-01,& + & .1632945E-01,.1753946E-01,.1884180E-01,.2053655E-01,.2251614E-01,& + & .1528056E-01,.1648257E-01,.1780611E-01,.1941673E-01,.2129325E-01,& + & .1439040E-01,.1554780E-01,.1695518E-01,.1850787E-01,.2029757E-01,& + & .1364127E-01,.1485684E-01,.1620134E-01,.1772745E-01,.1951994E-01,& + & .1258716E-01,.1381209E-01,.1512804E-01,.1667637E-01,.1840520E-01,& + & .1143111E-01,.1260773E-01,.1397144E-01,.1543741E-01,.1714336E-01,& + & .1034838E-01,.1151140E-01,.1288246E-01,.1434110E-01,.1596120E-01,& + & .9434287E-02,.1058629E-01,.1186231E-01,.1323644E-01,.1478338E-01,& + & .8644308E-02,.9731339E-02,.1097791E-01,.1231507E-01,.1383818E-01,& + & .7945748E-02,.8966157E-02,.1013410E-01,.1144951E-01,.1288499E-01,& + & .7251090E-02,.8253964E-02,.9351761E-02,.1060751E-01,.1200048E-01,& + & .6579748E-02,.7509664E-02,.8524470E-02,.9703299E-02,.1107385E-01,& + & .5951880E-02,.6756479E-02,.7704468E-02,.8845964E-02,.1010461E-01,& + & .5237878E-02,.5963536E-02,.6868194E-02,.7873626E-02,.9058934E-02,& + & .4564340E-02,.5246869E-02,.6058901E-02,.6986798E-02,.8100707E-02,& + & .3927773E-02,.4563237E-02,.5276212E-02,.6126524E-02,.7132796E-02,& + & .3396746E-02,.3962408E-02,.4607092E-02,.5396614E-02,.6293512E-02,& + & .2938365E-02,.3441438E-02,.4024490E-02,.4739722E-02,.5537536E-02,& + & .2568850E-02,.3016246E-02,.3558015E-02,.4198155E-02,.4896116E-02,& + & .2216648E-02,.2607125E-02,.3108998E-02,.3673395E-02,.4285795E-02,& + & .1888038E-02,.2238310E-02,.2672219E-02,.3167173E-02,.3704008E-02/ + + data absb(121:235, 6) / & + & .1589604E-02,.1898430E-02,.2275337E-02,.2698109E-02,.3168934E-02,& + & .1330328E-02,.1601088E-02,.1927308E-02,.2289886E-02,.2702347E-02,& + & .1106058E-02,.1339532E-02,.1622095E-02,.1933708E-02,.2294633E-02,& + & .9232322E-03,.1129388E-02,.1374137E-02,.1641005E-02,.1954041E-02,& + & .7695851E-03,.9499734E-03,.1161581E-02,.1391249E-02,.1659990E-02,& + & .6391411E-03,.7954699E-03,.9764327E-03,.1175728E-02,.1405980E-02,& + & .5221445E-03,.6543645E-03,.8097738E-03,.9801297E-03,.1177108E-02,& + & .4212175E-03,.5316807E-03,.6646766E-03,.8090125E-03,.9773287E-03,& + & .3365734E-03,.4274844E-03,.5406354E-03,.6629665E-03,.8061362E-03,& + & .2659082E-03,.3406968E-03,.4346710E-03,.5386141E-03,.6603153E-03,& + & .2084988E-03,.2688505E-03,.3471450E-03,.4345779E-03,.5367697E-03,& + & .1617409E-03,.2100645E-03,.2734876E-03,.3468514E-03,.4310783E-03,& + & .1230350E-03,.1615169E-03,.2121423E-03,.2726679E-03,.3415988E-03,& + & .9571658E-04,.1268700E-03,.1676066E-03,.2182467E-03,.2753833E-03,& + & .7483539E-04,.1000772E-03,.1334398E-03,.1757280E-03,.2239868E-03,& + & .5772027E-04,.7803984E-04,.1048734E-03,.1398792E-03,.1799578E-03,& + & .4394505E-04,.6019842E-04,.8138845E-04,.1097945E-03,.1427362E-03,& + & .3482804E-04,.4819989E-04,.6606100E-04,.8999622E-04,.1184452E-03,& + & .2824956E-04,.3942832E-04,.5468547E-04,.7556789E-04,.1004720E-03,& + & .2272475E-04,.3212105E-04,.4507284E-04,.6295422E-04,.8486593E-04,& + & .1816142E-04,.2604650E-04,.3689143E-04,.5210509E-04,.7114512E-04,& + & .1460417E-04,.2125717E-04,.3044873E-04,.4347568E-04,.6004634E-04,& + & .1318588E-04,.1949094E-04,.2845284E-04,.4096246E-04,.5730208E-04/ + + data absb( 1:120, 7) / & + & .3908183E+01,.4021612E+01,.4146726E+01,.4284083E+01,.4438438E+01,& + & .3284599E+01,.3380615E+01,.3488659E+01,.3611242E+01,.3752108E+01,& + & .2750113E+01,.2833708E+01,.2928922E+01,.3039836E+01,.3169125E+01,& + & .2307053E+01,.2379505E+01,.2464791E+01,.2564854E+01,.2681085E+01,& + & .1936077E+01,.2001044E+01,.2079025E+01,.2171276E+01,.2276173E+01,& + & .1622572E+01,.1681244E+01,.1752186E+01,.1836321E+01,.1928176E+01,& + & .1369492E+01,.1421024E+01,.1484095E+01,.1556113E+01,.1634126E+01,& + & .1180311E+01,.1227272E+01,.1282719E+01,.1341372E+01,.1403599E+01,& + & .1020024E+01,.1063783E+01,.1111019E+01,.1162039E+01,.1215624E+01,& + & .8833680E+00,.9215968E+00,.9637706E+00,.1008479E+01,.1057170E+01,& + & .7624334E+00,.7970585E+00,.8346574E+00,.8755899E+00,.9193781E+00,& + & .6579273E+00,.6887119E+00,.7224049E+00,.7595641E+00,.7997812E+00,& + & .5668077E+00,.5946957E+00,.6255016E+00,.6592894E+00,.6963418E+00,& + & .4881446E+00,.5135679E+00,.5418786E+00,.5730494E+00,.6077831E+00,& + & .4200990E+00,.4431037E+00,.4688805E+00,.4974060E+00,.5298295E+00,& + & .3617384E+00,.3821010E+00,.4055724E+00,.4323227E+00,.4633921E+00,& + & .3109227E+00,.3293125E+00,.3507763E+00,.3762455E+00,.4052117E+00,& + & .2674240E+00,.2843698E+00,.3044221E+00,.3282655E+00,.3551022E+00,& + & .2297019E+00,.2456549E+00,.2646151E+00,.2871844E+00,.3119468E+00,& + & .1979105E+00,.2130118E+00,.2313507E+00,.2522008E+00,.2753351E+00,& + & .1710687E+00,.1855135E+00,.2029507E+00,.2226155E+00,.2446203E+00,& + & .1485780E+00,.1623096E+00,.1788155E+00,.1972862E+00,.2180352E+00,& + & .1285687E+00,.1414891E+00,.1566691E+00,.1740024E+00,.1933684E+00,& + & .1107491E+00,.1226288E+00,.1365049E+00,.1524192E+00,.1703572E+00/ + + data absb(121:235, 7) / & + & .9456369E-01,.1051244E+00,.1175196E+00,.1318208E+00,.1481765E+00,& + & .8066956E-01,.9002222E-01,.1011931E+00,.1140601E+00,.1288872E+00,& + & .6867032E-01,.7709429E-01,.8709495E-01,.9877474E-01,.1121550E+00,& + & .5832603E-01,.6556338E-01,.7444062E-01,.8488976E-01,.9692322E-01,& + & .4942472E-01,.5585419E-01,.6358733E-01,.7286335E-01,.8372396E-01,& + & .4180841E-01,.4754454E-01,.5435437E-01,.6256355E-01,.7229908E-01,& + & .3508489E-01,.4013132E-01,.4608275E-01,.5327848E-01,.6197794E-01,& + & .2922066E-01,.3367674E-01,.3885124E-01,.4519646E-01,.5282863E-01,& + & .2427508E-01,.2810853E-01,.3265710E-01,.3827469E-01,.4498559E-01,& + & .2006569E-01,.2335359E-01,.2727995E-01,.3220620E-01,.3815593E-01,& + & .1645503E-01,.1925848E-01,.2264332E-01,.2682076E-01,.3208388E-01,& + & .1342964E-01,.1577348E-01,.1865261E-01,.2224444E-01,.2683651E-01,& + & .1090974E-01,.1285284E-01,.1527245E-01,.1835280E-01,.2231368E-01,& + & .8925769E-02,.1055870E-01,.1261660E-01,.1523191E-01,.1867393E-01,& + & .7332235E-02,.8686707E-02,.1044642E-01,.1267886E-01,.1562635E-01,& + & .6005950E-02,.7116692E-02,.8597108E-02,.1050258E-01,.1303347E-01,& + & .4886737E-02,.5803324E-02,.7029411E-02,.8649638E-02,.1082164E-01,& + & .4045146E-02,.4827713E-02,.5866804E-02,.7255958E-02,.9118484E-02,& + & .3386333E-02,.4055976E-02,.4960277E-02,.6153907E-02,.7764407E-02,& + & .2833529E-02,.3404009E-02,.4187592E-02,.5222472E-02,.6607700E-02,& + & .2365720E-02,.2858268E-02,.3529390E-02,.4419998E-02,.5636682E-02,& + & .1989667E-02,.2413827E-02,.2992976E-02,.3780796E-02,.4842075E-02,& + & .1799658E-02,.2201226E-02,.2751996E-02,.3518772E-02,.4547327E-02/ + + data absb( 1:120, 8) / & + & .4033644E+02,.4167953E+02,.4301570E+02,.4435920E+02,.4567833E+02,& + & .3531377E+02,.3641380E+02,.3752525E+02,.3863489E+02,.3972127E+02,& + & .3071410E+02,.3160600E+02,.3251995E+02,.3343214E+02,.3433462E+02,& + & .2650555E+02,.2724233E+02,.2800390E+02,.2877429E+02,.2956326E+02,& + & .2275030E+02,.2336977E+02,.2400486E+02,.2465588E+02,.2535498E+02,& + & .1940546E+02,.1993156E+02,.2047118E+02,.2104774E+02,.2171625E+02,& + & .1638172E+02,.1683509E+02,.1732028E+02,.1787385E+02,.1854784E+02,& + & .1365200E+02,.1402511E+02,.1446383E+02,.1502684E+02,.1574369E+02,& + & .1137022E+02,.1169679E+02,.1212312E+02,.1267823E+02,.1337177E+02,& + & .9506496E+01,.9827971E+01,.1025128E+02,.1081497E+02,.1148308E+02,& + & .8052710E+01,.8344535E+01,.8752518E+01,.9286286E+01,.9908091E+01,& + & .7005129E+01,.7297737E+01,.7690454E+01,.8150077E+01,.8636301E+01,& + & .6181432E+01,.6493698E+01,.6873626E+01,.7267363E+01,.7701472E+01,& + & .5486352E+01,.5805127E+01,.6164438E+01,.6541233E+01,.6910418E+01,& + & .4874205E+01,.5201845E+01,.5533903E+01,.5877592E+01,.6211504E+01,& + & .4354064E+01,.4662856E+01,.4960467E+01,.5268278E+01,.5590873E+01,& + & .3870676E+01,.4151579E+01,.4424561E+01,.4713940E+01,.5019965E+01,& + & .3432801E+01,.3695370E+01,.3951313E+01,.4223258E+01,.4521613E+01,& + & .3046684E+01,.3280864E+01,.3528685E+01,.3785450E+01,.4072281E+01,& + & .2707644E+01,.2931362E+01,.3163706E+01,.3412966E+01,.3691298E+01,& + & .2413017E+01,.2622420E+01,.2842869E+01,.3091981E+01,.3368488E+01,& + & .2161287E+01,.2357984E+01,.2569356E+01,.2810989E+01,.3097338E+01,& + & .1925443E+01,.2108054E+01,.2317393E+01,.2555114E+01,.2840446E+01,& + & .1703781E+01,.1879720E+01,.2080458E+01,.2316042E+01,.2597137E+01/ + + data absb(121:235, 8) / & + & .1493092E+01,.1657976E+01,.1851046E+01,.2073961E+01,.2343340E+01,& + & .1311161E+01,.1466732E+01,.1645509E+01,.1859825E+01,.2118946E+01,& + & .1150929E+01,.1297548E+01,.1468104E+01,.1672256E+01,.1922471E+01,& + & .1004409E+01,.1141010E+01,.1301607E+01,.1492747E+01,.1726160E+01,& + & .8769985E+00,.1002882E+01,.1151293E+01,.1329471E+01,.1549835E+01,& + & .7649098E+00,.8805424E+00,.1016103E+01,.1181723E+01,.1389132E+01,& + & .6598121E+00,.7637212E+00,.8887136E+00,.1040010E+01,.1230413E+01,& + & .5657958E+00,.6586754E+00,.7718739E+00,.9084100E+00,.1082238E+01,& + & .4835182E+00,.5668068E+00,.6687172E+00,.7926556E+00,.9499754E+00,& + & .4118145E+00,.4852766E+00,.5756963E+00,.6868494E+00,.8286511E+00,& + & .3488019E+00,.4139755E+00,.4938550E+00,.5910229E+00,.7163238E+00,& + & .2935726E+00,.3516563E+00,.4223583E+00,.5090453E+00,.6171835E+00,& + & .2445646E+00,.2963715E+00,.3583947E+00,.4363324E+00,.5322580E+00,& + & .2063336E+00,.2514543E+00,.3069415E+00,.3769572E+00,.4647802E+00,& + & .1745065E+00,.2143204E+00,.2634212E+00,.3259536E+00,.4065898E+00,& + & .1469747E+00,.1815841E+00,.2245475E+00,.2809591E+00,.3526955E+00,& + & .1226579E+00,.1531164E+00,.1907781E+00,.2400747E+00,.3043525E+00,& + & .1036864E+00,.1314203E+00,.1647845E+00,.2083891E+00,.2666072E+00,& + & .8816513E-01,.1136512E+00,.1440561E+00,.1835360E+00,.2351002E+00,& + & .7437710E-01,.9768257E-01,.1255978E+00,.1607081E+00,.2071018E+00,& + & .6227610E-01,.8346943E-01,.1093711E+00,.1408269E+00,.1825617E+00,& + & .5263552E-01,.7135997E-01,.9530909E-01,.1242291E+00,.1612246E+00,& + & .4825418E-01,.6650163E-01,.8992737E-01,.1186811E+00,.1555922E+00/ + + data absb( 1:120, 9) / & + & .1646500E+03,.1629800E+03,.1641300E+03,.1679600E+03,.1742500E+03,& + & .1413400E+03,.1422300E+03,.1458400E+03,.1518300E+03,.1582300E+03,& + & .1233400E+03,.1264200E+03,.1317000E+03,.1371900E+03,.1424800E+03,& + & .1090300E+03,.1135000E+03,.1182500E+03,.1228400E+03,.1272000E+03,& + & .9674400E+02,.1007700E+03,.1047300E+03,.1085600E+03,.1122500E+03,& + & .8536800E+02,.8866900E+02,.9193400E+02,.9512700E+02,.9821600E+02,& + & .7486500E+02,.7756000E+02,.8026300E+02,.8291200E+02,.8549900E+02,& + & .6530400E+02,.6758800E+02,.6984900E+02,.7209900E+02,.7431600E+02,& + & .5670400E+02,.5861600E+02,.6054100E+02,.6245700E+02,.6444400E+02,& + & .4909900E+02,.5078800E+02,.5245100E+02,.5411900E+02,.5597000E+02,& + & .4207600E+02,.4364600E+02,.4523000E+02,.4688800E+02,.4879800E+02,& + & .3545700E+02,.3690400E+02,.3844700E+02,.4026200E+02,.4256500E+02,& + & .2983200E+02,.3103600E+02,.3250800E+02,.3450200E+02,.3697900E+02,& + & .2520500E+02,.2634800E+02,.2779200E+02,.2978800E+02,.3245900E+02,& + & .2148600E+02,.2258600E+02,.2416200E+02,.2626000E+02,.2894400E+02,& + & .1871200E+02,.1969300E+02,.2137000E+02,.2359100E+02,.2615800E+02,& + & .1663000E+02,.1771600E+02,.1936900E+02,.2156500E+02,.2410200E+02,& + & .1492300E+02,.1611900E+02,.1778300E+02,.1998900E+02,.2237900E+02,& + & .1353200E+02,.1485300E+02,.1657600E+02,.1874500E+02,.2108400E+02,& + & .1245300E+02,.1378400E+02,.1558700E+02,.1771800E+02,.2002200E+02,& + & .1158000E+02,.1303800E+02,.1485100E+02,.1689200E+02,.1919200E+02,& + & .1082000E+02,.1237600E+02,.1413400E+02,.1615200E+02,.1840200E+02,& + & .1011600E+02,.1168600E+02,.1340200E+02,.1534600E+02,.1755600E+02,& + & .9393300E+01,.1091000E+02,.1257200E+02,.1443200E+02,.1653600E+02/ + + data absb(121:235, 9) / & + & .8516000E+01,.9975500E+01,.1155400E+02,.1335800E+02,.1535000E+02,& + & .7750500E+01,.9122500E+01,.1067000E+02,.1238000E+02,.1427300E+02,& + & .7089700E+01,.8388500E+01,.9869400E+01,.1150200E+02,.1334300E+02,& + & .6329500E+01,.7550600E+01,.8946600E+01,.1049500E+02,.1228700E+02,& + & .5630200E+01,.6798800E+01,.8095700E+01,.9601300E+01,.1128000E+02,& + & .5023400E+01,.6107100E+01,.7338900E+01,.8781600E+01,.1038000E+02,& + & .4422500E+01,.5428200E+01,.6596300E+01,.7943300E+01,.9466600E+01,& + & .3855800E+01,.4791200E+01,.5890500E+01,.7147800E+01,.8614500E+01,& + & .3357500E+01,.4235100E+01,.5247500E+01,.6429200E+01,.7829600E+01,& + & .2905300E+01,.3707400E+01,.4643200E+01,.5748400E+01,.7067400E+01,& + & .2470600E+01,.3185100E+01,.4052400E+01,.5083700E+01,.6299000E+01,& + & .2090700E+01,.2732000E+01,.3523200E+01,.4468900E+01,.5599800E+01,& + & .1765200E+01,.2339700E+01,.3052500E+01,.3913000E+01,.4964100E+01,& + & .1498000E+01,.1999500E+01,.2638600E+01,.3430900E+01,.4393000E+01,& + & .1288300E+01,.1722900E+01,.2280800E+01,.3005800E+01,.3892100E+01,& + & .1103200E+01,.1487800E+01,.1994500E+01,.2622500E+01,.3432700E+01,& + & .9425600E+00,.1280300E+01,.1743600E+01,.2309500E+01,.3025800E+01,& + & .8084700E+00,.1104500E+01,.1525000E+01,.2057300E+01,.2704800E+01,& + & .6997200E+00,.9500800E+00,.1321500E+01,.1817800E+01,.2432600E+01,& + & .6065900E+00,.8129800E+00,.1143000E+01,.1592500E+01,.2178300E+01,& + & .5266400E+00,.6967000E+00,.9799800E+00,.1389100E+01,.1933300E+01,& + & .4598500E+00,.6068200E+00,.8433700E+00,.1211300E+01,.1718800E+01,& + & .4385300E+00,.5787900E+00,.7901800E+00,.1113000E+01,.1603900E+01/ + + data absb( 1:120,10) / & + & .8601600E+03,.8462600E+03,.8322800E+03,.8181700E+03,.8045000E+03,& + & .7598100E+03,.7466300E+03,.7334500E+03,.7210400E+03,.7122400E+03,& + & .6620100E+03,.6499300E+03,.6389100E+03,.6321000E+03,.6297800E+03,& + & .5701400E+03,.5602700E+03,.5546600E+03,.5537800E+03,.5572100E+03,& + & .4886100E+03,.4835400E+03,.4832400E+03,.4876000E+03,.4960200E+03,& + & .4198700E+03,.4196400E+03,.4241100E+03,.4329100E+03,.4457500E+03,& + & .3630300E+03,.3670200E+03,.3755600E+03,.3883400E+03,.4047100E+03,& + & .3165100E+03,.3242100E+03,.3362700E+03,.3521900E+03,.3707200E+03,& + & .2786700E+03,.2894700E+03,.3043400E+03,.3213100E+03,.3382300E+03,& + & .2491600E+03,.2625100E+03,.2776800E+03,.2929600E+03,.3084400E+03,& + & .2257100E+03,.2393200E+03,.2529100E+03,.2667000E+03,.2806900E+03,& + & .2050300E+03,.2176500E+03,.2302900E+03,.2429100E+03,.2557500E+03,& + & .1857400E+03,.1976300E+03,.2096000E+03,.2215100E+03,.2335600E+03,& + & .1682500E+03,.1794500E+03,.1908500E+03,.2024200E+03,.2140600E+03,& + & .1525400E+03,.1631100E+03,.1740200E+03,.1852100E+03,.1969600E+03,& + & .1381500E+03,.1485700E+03,.1591300E+03,.1702200E+03,.1823800E+03,& + & .1256000E+03,.1357100E+03,.1463000E+03,.1576300E+03,.1701900E+03,& + & .1149700E+03,.1247600E+03,.1355000E+03,.1471900E+03,.1604400E+03,& + & .1060200E+03,.1157700E+03,.1267100E+03,.1388900E+03,.1528900E+03,& + & .9851900E+02,.1085500E+03,.1197800E+03,.1326500E+03,.1474400E+03,& + & .9251700E+02,.1027400E+03,.1145200E+03,.1282200E+03,.1438900E+03,& + & .8744100E+02,.9793600E+02,.1104400E+03,.1249500E+03,.1414800E+03,& + & .8249900E+02,.9333300E+02,.1063500E+03,.1215100E+03,.1387400E+03,& + & .7744200E+02,.8849300E+02,.1018400E+03,.1174000E+03,.1351300E+03/ + + data absb(121:235,10) / & + & .7177100E+02,.8273100E+02,.9603200E+02,.1115800E+03,.1294100E+03,& + & .6672700E+02,.7761000E+02,.9079500E+02,.1063200E+03,.1241500E+03,& + & .6233900E+02,.7311300E+02,.8620000E+02,.1016700E+03,.1194200E+03,& + & .5760100E+02,.6799900E+02,.8072400E+02,.9585800E+02,.1132300E+03,& + & .5328500E+02,.6320300E+02,.7557700E+02,.9024200E+02,.1072600E+03,& + & .4939200E+02,.5890800E+02,.7083400E+02,.8504500E+02,.1016300E+03,& + & .4544600E+02,.5445200E+02,.6575100E+02,.7940200E+02,.9539700E+02,& + & .4162000E+02,.5018400E+02,.6077700E+02,.7378600E+02,.8907600E+02,& + & .3805900E+02,.4628200E+02,.5622600E+02,.6853900E+02,.8313600E+02,& + & .3455400E+02,.4250100E+02,.5182900E+02,.6338300E+02,.7722000E+02,& + & .3100900E+02,.3861000E+02,.4738500E+02,.5805800E+02,.7108000E+02,& + & .2771500E+02,.3493400E+02,.4331900E+02,.5319000E+02,.6534700E+02,& + & .2465800E+02,.3147800E+02,.3950000E+02,.4874300E+02,.5999700E+02,& + & .2203400E+02,.2843700E+02,.3609300E+02,.4489400E+02,.5534600E+02,& + & .1968400E+02,.2562600E+02,.3293700E+02,.4138500E+02,.5115400E+02,& + & .1750400E+02,.2299500E+02,.2992500E+02,.3805700E+02,.4730700E+02,& + & .1555200E+02,.2054400E+02,.2707900E+02,.3483200E+02,.4372200E+02,& + & .1388600E+02,.1847600E+02,.2460700E+02,.3196600E+02,.4054000E+02,& + & .1239600E+02,.1668100E+02,.2238500E+02,.2938400E+02,.3759200E+02,& + & .1102800E+02,.1500600E+02,.2029700E+02,.2695500E+02,.3478000E+02,& + & .9749300E+01,.1345200E+02,.1835400E+02,.2464400E+02,.3209900E+02,& + & .8641100E+01,.1206800E+02,.1662700E+02,.2256900E+02,.2968400E+02,& + & .8089400E+01,.1144900E+02,.1590500E+02,.2175300E+02,.2872800E+02/ + + data absb( 1:120,11) / & + & .5004600E+04,.5003400E+04,.4995000E+04,.4978100E+04,.4954200E+04,& + & .5181200E+04,.5173800E+04,.5158200E+04,.5135700E+04,.5105400E+04,& + & .5279300E+04,.5264500E+04,.5245000E+04,.5217200E+04,.5183600E+04,& + & .5300100E+04,.5281800E+04,.5256800E+04,.5227400E+04,.5192400E+04,& + & .5244800E+04,.5224200E+04,.5200400E+04,.5171500E+04,.5137700E+04,& + & .5120000E+04,.5103100E+04,.5081700E+04,.5057100E+04,.5030800E+04,& + & .4938900E+04,.4928400E+04,.4915300E+04,.4900700E+04,.4881900E+04,& + & .4718100E+04,.4716800E+04,.4716300E+04,.4712900E+04,.4711100E+04,& + & .4471800E+04,.4486500E+04,.4499000E+04,.4515300E+04,.4540300E+04,& + & .4219200E+04,.4249700E+04,.4286100E+04,.4331600E+04,.4380900E+04,& + & .3972700E+04,.4027500E+04,.4093600E+04,.4164600E+04,.4240400E+04,& + & .3750700E+04,.3833600E+04,.3923900E+04,.4020600E+04,.4120900E+04,& + & .3560600E+04,.3669400E+04,.3782600E+04,.3902600E+04,.4024400E+04,& + & .3404300E+04,.3536400E+04,.3673100E+04,.3813000E+04,.3951900E+04,& + & .3280300E+04,.3434600E+04,.3591200E+04,.3747600E+04,.3901400E+04,& + & .3187600E+04,.3361000E+04,.3534400E+04,.3704200E+04,.3869900E+04,& + & .3123900E+04,.3313700E+04,.3499500E+04,.3681300E+04,.3857300E+04,& + & .3085000E+04,.3287200E+04,.3483700E+04,.3674500E+04,.3859100E+04,& + & .3067400E+04,.3279500E+04,.3484800E+04,.3682600E+04,.3872400E+04,& + & .3068300E+04,.3287900E+04,.3499000E+04,.3702200E+04,.3895300E+04,& + & .3083100E+04,.3308700E+04,.3524300E+04,.3730300E+04,.3925000E+04,& + & .3101700E+04,.3330800E+04,.3549600E+04,.3758000E+04,.3952700E+04,& + & .3105700E+04,.3338700E+04,.3560100E+04,.3770000E+04,.3965400E+04,& + & .3089500E+04,.3326000E+04,.3550400E+04,.3763000E+04,.3960600E+04/ + + data absb(121:235,11) / & + & .3040000E+04,.3281100E+04,.3509600E+04,.3726300E+04,.3927700E+04,& + & .2991300E+04,.3236100E+04,.3469000E+04,.3689000E+04,.3894200E+04,& + & .2944100E+04,.3192600E+04,.3429400E+04,.3652600E+04,.3861200E+04,& + & .2872200E+04,.3125400E+04,.3366700E+04,.3594300E+04,.3807300E+04,& + & .2797100E+04,.3054800E+04,.3300400E+04,.3532600E+04,.3750500E+04,& + & .2722600E+04,.2983700E+04,.3233600E+04,.3470100E+04,.3692500E+04,& + & .2633200E+04,.2898100E+04,.3152500E+04,.3394400E+04,.3622300E+04,& + & .2537200E+04,.2805000E+04,.3064300E+04,.3311400E+04,.3544100E+04,& + & .2441700E+04,.2711300E+04,.2974800E+04,.3226800E+04,.3465100E+04,& + & .2339500E+04,.2611500E+04,.2878300E+04,.3135100E+04,.3379200E+04,& + & .2224300E+04,.2499800E+04,.2769400E+04,.3031300E+04,.3281000E+04,& + & .2108300E+04,.2387700E+04,.2659200E+04,.2925700E+04,.3180300E+04,& + & .1992500E+04,.2274100E+04,.2548800E+04,.2818000E+04,.3078300E+04,& + & .1884100E+04,.2166600E+04,.2444700E+04,.2715900E+04,.2980600E+04,& + & .1779800E+04,.2061800E+04,.2342800E+04,.2616000E+04,.2883900E+04,& + & .1676200E+04,.1957400E+04,.2239800E+04,.2515600E+04,.2786200E+04,& + & .1573100E+04,.1853000E+04,.2135800E+04,.2415200E+04,.2687200E+04,& + & .1480200E+04,.1758100E+04,.2040100E+04,.2321900E+04,.2595600E+04,& + & .1391500E+04,.1667500E+04,.1948800E+04,.2231800E+04,.2508000E+04,& + & .1303900E+04,.1577800E+04,.1857700E+04,.2140600E+04,.2420000E+04,& + & .1216700E+04,.1489000E+04,.1767200E+04,.2049300E+04,.2331300E+04,& + & .1134900E+04,.1405700E+04,.1681800E+04,.1963100E+04,.2246400E+04,& + & .1102500E+04,.1372100E+04,.1647600E+04,.1928300E+04,.2211700E+04/ + + data absb( 1:120,12) / & + & .1249200E+05,.1260200E+05,.1267800E+05,.1273000E+05,.1274900E+05,& + & .1469600E+05,.1479200E+05,.1486200E+05,.1489000E+05,.1488900E+05,& + & .1715300E+05,.1724200E+05,.1727500E+05,.1727400E+05,.1723100E+05,& + & .1984300E+05,.1989400E+05,.1989800E+05,.1984500E+05,.1974700E+05,& + & .2272700E+05,.2273100E+05,.2266700E+05,.2255100E+05,.2238600E+05,& + & .2576100E+05,.2568400E+05,.2554400E+05,.2534200E+05,.2507000E+05,& + & .2887800E+05,.2870100E+05,.2845400E+05,.2813100E+05,.2775900E+05,& + & .3198100E+05,.3169500E+05,.3131400E+05,.3087100E+05,.3036000E+05,& + & .3501700E+05,.3457500E+05,.3406400E+05,.3348000E+05,.3282100E+05,& + & .3785400E+05,.3726400E+05,.3658900E+05,.3584000E+05,.3504600E+05,& + & .4047300E+05,.3971000E+05,.3886200E+05,.3796700E+05,.3702300E+05,& + & .4279600E+05,.4186400E+05,.4086900E+05,.3981700E+05,.3871800E+05,& + & .4481300E+05,.4371900E+05,.4257800E+05,.4138000E+05,.4014300E+05,& + & .4650400E+05,.4526300E+05,.4397300E+05,.4264100E+05,.4129400E+05,& + & .4789300E+05,.4650700E+05,.4508700E+05,.4364700E+05,.4219700E+05,& + & .4899300E+05,.4748000E+05,.4595200E+05,.4441700E+05,.4287800E+05,& + & .4982300E+05,.4820600E+05,.4658800E+05,.4496900E+05,.4335300E+05,& + & .5041500E+05,.4871600E+05,.4702500E+05,.4533900E+05,.4365900E+05,& + & .5081100E+05,.4904200E+05,.4728800E+05,.4554300E+05,.4381300E+05,& + & .5103200E+05,.4920300E+05,.4740000E+05,.4561000E+05,.4384100E+05,& + & .5110700E+05,.4923400E+05,.4739300E+05,.4556500E+05,.4377500E+05,& + & .5113000E+05,.4922800E+05,.4735000E+05,.4549700E+05,.4368800E+05,& + & .5125600E+05,.4931600E+05,.4741300E+05,.4554000E+05,.4371100E+05,& + & .5151900E+05,.4955500E+05,.4762600E+05,.4573100E+05,.4388500E+05/ + + data absb(121:235,12) / & + & .5203400E+05,.5004100E+05,.4809000E+05,.4616800E+05,.4430200E+05,& + & .5252900E+05,.5051100E+05,.4853500E+05,.4659500E+05,.4470600E+05,& + & .5298500E+05,.5095200E+05,.4895400E+05,.4699600E+05,.4508500E+05,& + & .5363300E+05,.5157500E+05,.4955600E+05,.4757800E+05,.4564800E+05,& + & .5428900E+05,.5221100E+05,.5017100E+05,.4817100E+05,.4622000E+05,& + & .5493200E+05,.5283600E+05,.5077800E+05,.4875900E+05,.4678500E+05,& + & .5567300E+05,.5356900E+05,.5148800E+05,.4944900E+05,.4745600E+05,& + & .5646100E+05,.5434600E+05,.5224700E+05,.5019000E+05,.4817800E+05,& + & .5724100E+05,.5512100E+05,.5300700E+05,.5092900E+05,.4889700E+05,& + & .5806300E+05,.5593300E+05,.5380600E+05,.5171000E+05,.4965600E+05,& + & .5897800E+05,.5682800E+05,.5469700E+05,.5258200E+05,.5050500E+05,& + & .5989100E+05,.5772000E+05,.5558600E+05,.5345900E+05,.5136700E+05,& + & .6079500E+05,.5862100E+05,.5647200E+05,.5433600E+05,.5222400E+05,& + & .6163900E+05,.5946600E+05,.5729800E+05,.5516200E+05,.5303400E+05,& + & .6244700E+05,.6028400E+05,.5811000E+05,.5596100E+05,.5382400E+05,& + & .6324000E+05,.6109800E+05,.5891600E+05,.5676000E+05,.5461200E+05,& + & .6403000E+05,.6190300E+05,.5972700E+05,.5755800E+05,.5541100E+05,& + & .6473500E+05,.6263700E+05,.6047100E+05,.5828700E+05,.5613800E+05,& + & .6540700E+05,.6333200E+05,.6118100E+05,.5900300E+05,.5683400E+05,& + & .6606900E+05,.6401500E+05,.6188100E+05,.5970200E+05,.5752900E+05,& + & .6672500E+05,.6468300E+05,.6257600E+05,.6041100E+05,.5822500E+05,& + & .6732700E+05,.6531500E+05,.6323200E+05,.6107800E+05,.5889100E+05,& + & .6757700E+05,.6557200E+05,.6349600E+05,.6134900E+05,.5916100E+05/ + +! --- + data forref(1:4,1:12) / .2998180E-05,.2092820E-05,.9883530E-04,& + & .6321780E-03,.6336480E-05,.5092140E-04,.6505350E-03,.2640190E-02,& + & .6367820E-04,.1365770E-03,.1665000E-02,.7508210E-02,.4723140E-03,& + & .9882960E-03,.5857510E-02,.1873520E-01,.1306617E-01,.1521008E-01,& + & .1910962E-01,.1640369E-01,.2664425E-01,.2836468E-01,.1997971E-01,& + & .6508449E-02,.3071268E-01,.1794967E-01,.9099105E-02,.1435908E-02,& + & .3256760E-01,.2153142E-01,.9594611E-03,.2499136E-02,.3451570E-01,& + & .1686790E-01,.5053610E-06,.2766470E-02,.4487650E-01,.1237910E-02,& + & .4883670E-06,.1222450E-02,.4869250E-01,.4643710E-06,.4642410E-06,& + & .7538460E-06,.5305110E-01,.3762340E-06,.4098240E-06,.4706500E-06/ + + + data selfref(1:10,1:12) / & + & .1180690E+00,.7135230E-01,.4311990E-01,.2605840E-01,.1574770E-01,& + & .9516750E-02,.5751210E-02,.3475600E-02,.2100390E-02,.1269320E-02,& + & .1370810E-01,.1390460E-01,.1410400E-01,.1430610E-01,.1451120E-01,& + & .1471930E-01,.1493030E-01,.1514430E-01,.1536140E-01,.1558160E-01,& + & .1665750E-01,.1649160E-01,.1632730E-01,.1616470E-01,.1600370E-01,& + & .1584430E-01,.1568640E-01,.1553020E-01,.1537550E-01,.1522240E-01,& + & .5973790E-01,.5095170E-01,.4345790E-01,.3706620E-01,.3161450E-01,& + & .2696470E-01,.2299880E-01,.1961620E-01,.1673110E-01,.1427030E-01,& + & .3320371E+00,.2986281E+00,.2687252E+00,.2419448E+00,.2179475E+00,& + & .1964309E+00,.1771281E+00,.1598017E+00,.1442398E+00,.1302553E+00,& + & .5353614E+00,.4870549E+00,.4431120E+00,.4031396E+00,.3667769E+00,& + & .3336985E+00,.3036077E+00,.2762334E+00,.2513302E+00,.2286753E+00,& + & .2654145E+00,.2716462E+00,.2780447E+00,.2846162E+00,.2913638E+00,& + & .2982924E+00,.3054070E+00,.3127136E+00,.3202159E+00,.3279193E+00,& + & .3297702E+00,.3292642E+00,.3288167E+00,.3284279E+00,.3280982E+00,& + & .3278270E+00,.3276143E+00,.3274609E+00,.3273666E+00,.3273316E+00,& + & .2274450E+00,.2415450E+00,.2565190E+00,.2724220E+00,.2893110E+00,& + & .3072470E+00,.3262940E+00,.3465230E+00,.3680050E+00,.3908200E+00,& + & .6162030E-02,.1135230E-01,.2091440E-01,.3853070E-01,.7098520E-01,& + & .1307760E+00,.2409290E+00,.4438650E+00,.8177330E+00,.1506510E+01,& + & .2795520E-03,.8084720E-03,.2338120E-02,.6761920E-02,.1955570E-01,& + & .5655550E-01,.1635600E+00,.4730200E+00,.1367990E+01,.3956260E+01,& + & .2610060E-03,.7710430E-03,.2277760E-02,.6728790E-02,.1987770E-01,& + & .5872120E-01,.1734700E+00,.5124520E+00,.1513850E+01,.4472090E+01/ + +!........................................! + end module module_radsw_kgb29 ! +!========================================! +!! @} diff --git a/gsmphys/radsw_main.f b/gsmphys/radsw_main.f new file mode 100644 index 00000000..6897c02d --- /dev/null +++ b/gsmphys/radsw_main.f @@ -0,0 +1,5383 @@ +!> \file radsw_main.f +!! This file contains NCEP's modifications of the rrtmg-sw radiation +!! code from AER. + +! ============================================================== !!!!! +! sw-rrtm3 radiation package description !!!!! +! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-sw radiation ! +! code from aer inc. ! +! ! +! the sw-rrtm3 package includes these parts: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! the 'radsw_rrtm3_param.f' contains: ! +! ! +! 'module_radsw_parameters' -- band parameters set up ! +! ! +! the 'radsw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radsw_ref' -- reference temperature and pressure ! +! 'module_radsw_cldprtb' -- cloud property coefficients table ! +! 'module_radsw_sflux' -- spectral distribution of solar flux ! +! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! +! bands, where nn = 16-29 ! +! ! +! the 'radsw_rrtm3_main.f' contains: ! +! ! +! 'module_radsw_main' -- main sw radiation transfer ! +! ! +! in the main module 'module_radsw_main' there are only two ! +! externally callable subroutines: ! +! ! +! 'swrad' -- main sw radiation routine ! +! inputs: ! +! (plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, ! +! clouds,icseed,aerosols,sfcalb, ! +! cosz,solcon,NDAY,idxday, ! +! npts, nlay, nlp1, lprnt, ! +! outputs: ! +! hswc,topflx,sfcflx, ! +!! optional outputs: ! +! HSW0,HSWB,FLXPRF,FDNCMP) ! +! ) ! +! ! +! 'rswinit' -- initialization routine ! +! inputs: ! +! ( me ) ! +! outputs: ! +! (none) ! +! ! +! all the sw radiation subprograms become contained subprograms ! +! in module 'module_radsw_main' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! derived data type constructs used: ! +! ! +! 1. radiation flux at toa: (from module 'module_radsw_parameters') ! +! topfsw_type - derived data type for toa rad fluxes ! +! upfxc total sky upward flux at toa ! +! dnfxc total sky downward flux at toa ! +! upfx0 clear sky upward flux at toa ! +! ! +! 2. radiation flux at sfc: (from module 'module_radsw_parameters') ! +! sfcfsw_type - derived data type for sfc rad fluxes ! +! upfxc total sky upward flux at sfc ! +! dnfxc total sky downward flux at sfc ! +! upfx0 clear sky upward flux at sfc ! +! dnfx0 clear sky downward flux at sfc ! +! ! +! 3. radiation flux profiles(from module 'module_radsw_parameters') ! +! profsw_type - derived data type for rad vertical prof ! +! upfxc level upward flux for total sky ! +! dnfxc level downward flux for total sky ! +! upfx0 level upward flux for clear sky ! +! dnfx0 level downward flux for clear sky ! +! ! +! 4. surface component fluxes(from module 'module_radsw_parameters' ! +! cmpfsw_type - derived data type for component sfc flux ! +! uvbfc total sky downward uv-b flux at sfc ! +! uvbf0 clear sky downward uv-b flux at sfc ! +! nirbm surface downward nir direct beam flux ! +! nirdf surface downward nir diffused flux ! +! visbm surface downward uv+vis direct beam flx ! +! visdf surface downward uv+vis diffused flux ! +! ! +! external modules referenced: ! +! ! +! 'module physparam' ! +! 'module physcons' ! +! 'mersenne_twister' ! +! ! +! compilation sequence is: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use sw modules ! +! ! +!==========================================================================! +! ! +! the original program declarations: ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! Copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). ! +! This software may be used, copied, or redistributed as long as it is ! +! not sold and this copyright notice is reproduced on each copy made. ! +! This model is provided as is without any express or implied warranties. ! +! (http://www.rtweb.aer.com/) ! +! ! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! +! ************************************************************************ ! +! ! +! rrtmg_sw ! +! ! +! ! +! a rapid radiative transfer model ! +! for the solar spectral region ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! eli j. mlawer ! +! jennifer s. delamere ! +! michael j. iacono ! +! shepard a. clough ! +! ! +! ! +! email: miacono@aer.com ! +! email: emlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: steven j. taubman, patrick d. brown, ! +! ronald e. farren, luke chen, robert bergstrom. ! +! ! +! ************************************************************************ ! +! ! +! references: ! +! (rrtm_sw/rrtmg_sw): ! +! clough, s.a., m.w. shephard, e.j. mlawer, j.s. delamere, ! +! m.j. iacono, k. cady-pereira, s. boukabara, and p.d. brown: ! +! atmospheric radiative transfer modeling: a summary of the aer ! +! codes, j. quant. spectrosc. radiat. transfer, 91, 233-244, 2005. ! +! ! +! (mcica): ! +! pincus, r., h. w. barker, and j.-j. morcrette: a fast, flexible, ! +! approximation technique for computing radiative transfer in ! +! inhomogeneous cloud fields, j. geophys. res., 108(d13), 4376, ! +! doi:10.1029/2002jd003322, 2003. ! +! ! +! ************************************************************************ ! +! ! +! aer's revision history: ! +! this version of rrtmg_sw has been modified from rrtm_sw to use a ! +! reduced set of g-point intervals and a two-stream model for ! +! application to gcms. ! +! ! +! -- original version (derived from rrtm_sw) ! +! 2002: aer. inc. ! +! -- conversion to f90 formatting; addition of 2-stream radiative transfer! +! feb 2003: j.-j. morcrette, ecmwf ! +! -- additional modifications for gcm application ! +! aug 2003: m. j. iacono, aer inc. ! +! -- total number of g-points reduced from 224 to 112. original ! +! set of 224 can be restored by exchanging code in module parrrsw.f90 ! +! and in file rrtmg_sw_init.f90. ! +! apr 2004: m. j. iacono, aer, inc. ! +! -- modifications to include output for direct and diffuse ! +! downward fluxes. there are output as "true" fluxes without ! +! any delta scaling applied. code can be commented to exclude ! +! this calculation in source file rrtmg_sw_spcvrt.f90. ! +! jan 2005: e. j. mlawer, m. j. iacono, aer, inc. ! +! -- revised to add mcica capability. ! +! nov 2005: m. j. iacono, aer, inc. ! +! -- reformatted for consistency with rrtmg_lw. ! +! feb 2007: m. j. iacono, aer, inc. ! +! -- modifications to formatting to use assumed-shape arrays. ! +! aug 2007: m. j. iacono, aer, inc. ! +! ! +! ************************************************************************ ! +! ! +! ncep modifications history log: ! +! ! +! sep 2003, yu-tai hou -- received aer's rrtm-sw gcm version ! +! code (v224) ! +! nov 2003, yu-tai hou -- corrected errors in direct/diffuse ! +! surface alabedo components. ! +! jan 2004, yu-tai hou -- modified code into standard modular! +! f9x code for ncep models. the original three cloud ! +! control flags are simplified into two: iflagliq and ! +! iflagice. combined the org subr sw_224 and setcoef ! +! into radsw (the main program); put all kgb##together ! +! and reformat into a separated data module; combine ! +! reftra and vrtqdr as swflux; optimized taumol and all ! +! taubgs to form a contained subroutines. ! +! jun 2004, yu-tai hou -- modified code based on aer's faster! +! version rrtmg_sw (v2.0) with 112 g-points. ! +! mar 2005, yu-tai hou -- modified to aer v2.3, correct cloud! +! scaling error, total sky properties are delta scaled ! +! after combining clear and cloudy parts. the testing ! +! criterion of ssa is saved before scaling. added cloud ! +! layer rain and snow contributions. all cloud water ! +! partical contents are treated the same way as other ! +! atmos particles. ! +! apr 2005, yu-tai hou -- modified on module structures (this! +! version of code was given back to aer in jun 2006) ! +! nov 2006, yu-tai hou -- modified code to include the ! +! generallized aerosol optical property scheme for gcms.! +! apr 2007, yu-tai hou -- added spectral band heating as an ! +! optional output to support the 500km model's upper ! +! stratospheric radiation calculations. restructure ! +! optional outputs for easy access by different models. ! +! oct 2008, yu-tai hou -- modified to include new features ! +! from aer's newer release v3.5-v3.61, including mcica ! +! sub-grid cloud option and true direct/diffuse fluxes ! +! without delta scaling. added rain/snow opt properties ! +! support to cloudy sky calculations. simplified and ! +! unified sw and lw sub-column cloud subroutines into ! +! one module by using optional parameters. ! +! mar 2009, yu-tai hou -- replaced the original random number! +! generator coming with the original code with ncep w3 ! +! library to simplify the program and moved sub-column ! +! cloud subroutines inside the main module. added ! +! option of user provided permutation seeds that could ! +! be randomly generated from forecast time stamp. ! +! mar 2009, yu-tai hou -- replaced random number generator ! +! programs coming from the original code with the ncep ! +! w3 library to simplify the program and moved sub-col ! +! cloud subroutines inside the main module. added ! +! option of user provided permutation seeds that could ! +! be randomly generated from forecast time stamp. ! +! nov 2009, yu-tai hou -- updated to aer v3.7-v3.8 version. ! +! notice the input cloud ice/liquid are assumed as ! +! in-cloud quantities, not grid average quantities. ! +! aug 2010, yu-tai hou -- uptimized code to improve efficiency +! splited subroutine spcvrt into two subs, spcvrc and ! +! spcvrm, to handling non-mcica and mcica type of calls.! +! apr 2012, b. ferrier and y. hou -- added conversion factor to fu's! +! cloud-snow optical property scheme. ! +! jul 2012, s. moorthi and Y. hou -- eliminated the pointer array ! +! in subr 'spcvrt' for multi-threading issue running ! +! under intel's fortran compiler. ! +! nov 2012, yu-tai hou -- modified control parameters thru ! +! module 'physparam'. ! +! jun 2013, yu-tai hou -- moving band 9 surface treatment ! +! back as in the rrtm2 version, spliting surface flux ! +! into two spectral regions (vis & nir), instead of ! +! designated it in nir region only. ! +! may 2016 yu-tai hou --reverting swflux name back to vrtqdr! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + + +!> \ingroup rad +!! \defgroup module_radsw_main module_radsw_main +!! This module includes NCEP's modifications of the rrtmg-sw radiation +!! code from AER. +!! +!! The SW radiation model in the current NOAA Environmental Modeling +!! System (NEMS) was adapted from the RRTM radiation model developed by +!! AER Inc. (Clough et al., 2005 \cite clough_et_al_2005; +!! Mlawer et al., 1997 \cite mlawer_et_al_1997). It contains 14 +!! spectral bands spanning a spectral wavenumber range of +!! \f$50000-820 cm^{-1}\f$ (corresponding to a wavelength range +!! \f$0.2-12.2\mu m\f$), each spectral band focuses on a specific set of +!! atmospheric absorbing species as shown in Table 1. To achieve great +!! computation efficiency while at the same time to maintain a high +!! degree of accuracy, the RRTM radiation model employs a corrected-k +!! distribution method (i.e. mapping the highly spectral changing +!! absorption coefficient, k, into a monotonic and smooth varying +!! cumulative probability function, g). In the RRTM-SW, there are 16 +!! unevenly distributed g points for each of the 14 bands for a total +!! of 224 g points. The GCM version of the code (RRTMG-SW) uses a reduced +!! number (various between 2 to 16) of g points for each of the bands +!! that totals to 112 instead of the full set of 224. To get high +!! quality for the scheme, many advanced techniques are used in RRTM +!! such as carefully selecting the band structure to handle various +!! major (key-species) and minor absorbers; deriving a binary parameter +!! for a paired key molecular species in the same domain; and using two +!! pressure regions (dividing level is at about 96mb) for optimal +!! treatment of various species, etc. +!!\tableofcontents +!! Table 1. RRTMG-SW spectral bands and the corresponding absorbing species +!! |Band #| Wavenumber Range | Lower Atm (Key)| Lower Atm (Minor)| Mid/Up Atm (Key)| Mid/Up Atm (Minor)| +!! |------|------------------|----------------|------------------|-----------------|-------------------| +!! | 16 | 2600-3250 |H2O,CH4 | |CH4 | | +!! | 17 | 3250-4000 |H2O,CO2 | |H2O,CO2 | | +!! | 18 | 4000-4650 |H2O,CH4 | |CH4 | | +!! | 19 | 4650-5150 |H2O,CO2 | |CO2 | | +!! | 20 | 5150-6150 |H2O |CH4 |H2O |CH4 | +!! | 21 | 6150-7700 |H2O,CO2 | |H2O,CO2 | | +!! | 22 | 7700-8050 |H2O,O2 | |O2 | | +!! | 23 | 8050-12850 |H2O | |--- | | +!! | 24 | 12850-16000 |H2O,O2 |O3 |O2 |O3 | +!! | 25 | 16000-22650 |H2O |O3 |--- |O3 | +!! | 26 | 22650-29000 |--- | |--- | | +!! | 27 | 29000-38000 |O3 | |O3 | | +!! | 28 | 38000-50000 |O3,O2 | |O3,O2 | | +!! | 29 | 820-2600 |H2O |CO2 |CO2 |H2O | +!!\tableofcontents +!!\n scattering due to clouds greatly complicate the SW radiative +!! transfer computations. To balance the trade-off between computation +!! and speed, RRTMG-SW uses a two-stream approximation method with a +!! delta-function adjustment. Several variations of the delta-two +!! method are included in the radiation transfer code; each holds its +!! own strength and shortcomings (King and Harshvadhan, 1986 +!! \cite king_and_harshvardhan_1986 ; +!! \f$R\ddot{a}is\ddot{a}nen\f$,2002 \cite raisanen_2002 ; +!! Barker et al., 2015 \cite barker_et_al_2015). The default (the same +!! in operation runs) selection (iswmode=2) activates the Practical +!! Improved Flux Method (PIFM) by Zdunkowski et al.(1980) +!! \cite zdunkowski_et_al_1980 . In dealing with a column of cloudy +!! atmosphere, two approaches are included in the RRTMG-SW. One is the +!! commonly used treatment that sees each of the cloud contaminated +!! layers as independent, partially and uniformly filled slabs. Cloud +!! inhomogeneity within and the nature coherence among adjacent cloud +!! layers are largely ignored to reduce the overwhelm complexities +!! associated with scattering process. The effective layer reflectance +!! and transmittance are weighted mean according to cloud fraction. The +!! approach may overestimate cloud effect, especially for multi-layered +!! cloud system associated with deep convection. In NEMS radiation code, +!! to mitigate this shortcoming without increase computation cost, the +!! cloud contaminated column is divided into two parts based on the +!! column's total cloud coverage (a maximum-random overlapping is used +!! in the operational models) to form a cloud free part and an overcast +!! part. Layered clouds are then normalized by the total cloud amount +!! before going through radiative transfer calculations. Fluxes from the +!! cloud-free part and cloudy part are combined together to obtain the +!! final result. +!!\n On the other hand, the Monte-Carlo Independent Column Approximation +!! (McICA) (Pincus et al.,2003 \cite pincus_et_al_2003 ; +!! \f$R\ddot{a}is\ddot{a}nen\f$ and Barker, 2004 +!! \cite raisanen_and_barker_2004), provides a simple and effective way +!! to solve cloud overlapping issue without increasing computational +!! burden. The method is based on the concept of an ICA scheme that +!! divides each grid column into a large number of sub-columns, and +!! statistically redistributes layered clouds (under an assumed overlapping +!! condition, such as the maximum-random method) into the sub-columns +!! (i.e. at any layer it will be either clear or overcast). Thus the +!! grid domain averaged flux under ICA scheme can be expressed as: +!! \f[ +!! \overline{F}=\frac{1}{N}\sum_{n=1}^N F_{n} +!! =\frac{1}{N}\sum_{n=1}^N\sum_{k=1}^K F_{n,k} +!! \f] +!! Where \f$N\f$ is the number of total sub-columns, and \f$K\f$ is the +!! number of spectral terms in integration.\f$F_{n}\f$ is flux obtained +!! in the \f$n^{th}\f$ sub-column, that is the summation of total of +!! \f$K\f$ spectral corresponding fluxes, \f$F_{n,k}\f$ . The double +!! integrations (summations) make ICA impractical for GCM applications. +!! The McICA method is to divide a model grid into \f$K\f$ sub-columns +!! and randomly to pair a sub-column's cloud profile with one of the +!! radiative spectral intervals (e.g. the g-point in RRTM). The double +!! summations will then be reduced to only one: +!! \f[ +!! \overline{F}=\frac{1}{N}\sum_{n=1}^N\sum_{k=1}^K F_{n,k} +!! \approx\overline{F}=\sum_{k=1}^K F_{S_{k},k} +!! \f] +!! +!! The RRTM-SW package includes three files: +!! - radsw_param.f, which contains: +!! - module_radsw_parameters: specifies major parameters of the spectral +!! bands and defines the construct structures of derived-type variables +!! for holding the output results. +!! - radsw_datatb.f, which contains: +!! - module_radsw_ref: reference temperature and pressure +!! - module_radsw_cldprtb: cloud property coefficients table +!! - module_radsw_sflux: indexes and coefficients for spectral +!! distribution of solar flux +!! - module_radsw_kgbnn: absorption coefficents for 14 bands, where +!! nn = 16-29 +!! - mersenne_twister.f, which contains: +!! - mersenne_twister: program of random number generators using the +!! Mersenne-Twister algorithm +!! - radsw_main.f, which contains: +!! - module_radsw_main: the main SW radiation computation programming +!! source codes, which contains two externally callable subroutines: +!! - swrad(): the main radiation routine +!! - rswinit(): the initialization routine +!! +!!\author Eli J. Mlawer, emlawer@aer.com +!!\author Jennifer S. Delamere, jdelamer@aer.com +!!\author Michael J. Iacono, miacono@aer.com +!!\author Shepard A. Clough +!!\version NCEP SW v5.1 Nov 2012 -RRTMG-SW v3.8 +!! +!! The authors wish to acknowledge the contributions of the +!! following people: Steven J. Taubman, Karen Cady-Pereira, +!! Patrick D. Brown, Ronald E. Farren, Luke Chen, Robert Bergstrom. +!! +!!\copyright 2002-2007, Atmospheric & Environmental Research, Inc. (AER). +!! This software may be used, copied, or redistributed as long as it is +!! not sold and this copyright notice is reproduced on each copy made. +!! This model is provided as is without any express or implied warranties. +!! (http://www.rtweb.aer.com/) +!! @{ +!========================================! + module module_radsw_main ! +!........................................! +! + use physparam, only : iswrate, iswrgas, iswcliq, iswcice, & + & isubcsw, icldflg, iovrsw, ivflip, & + & iswmode, kind_phys + use physcons, only : con_g, con_cp, con_avgd, con_amd, & + & con_amw, con_amo3 + + use module_radsw_parameters + use mersenne_twister, only : random_setseed, random_number, & + & random_stat + use module_radsw_ref, only : preflog, tref + use module_radsw_sflux +! + implicit none +! + private +! +! --- version tag and last revision date + character(40), parameter :: & + & VTAGSW='NCEP SW v5.1 Nov 2012 -RRTMG-SW v3.8 ' +! & VTAGSW='NCEP SW v5.0 Aug 2012 -RRTMG-SW v3.8 ' +! & VTAGSW='RRTMG-SW v3.8 Nov 2009' +! & VTAGSW='RRTMG-SW v3.7 Nov 2009' +! & VTAGSW='RRTMG-SW v3.61 Oct 2008' +! & VTAGSW='RRTMG-SW v3.5 Oct 2008' +! & VTAGSW='RRTM-SW 112v2.3 Apr 2007' +! & VTAGSW='RRTM-SW 112v2.3 Mar 2005' +! & VTAGSW='RRTM-SW 112v2.0 Jul 2004' + +!> \name constant values + + real (kind=kind_phys), parameter :: eps = 1.0e-6 + real (kind=kind_phys), parameter :: oneminus= 1.0 - eps +!> pade approx constant + real (kind=kind_phys), parameter :: bpade = 1.0/0.278 + real (kind=kind_phys), parameter :: stpfac = 296.0/1013.0 + real (kind=kind_phys), parameter :: ftiny = 1.0e-12 + real (kind=kind_phys), parameter :: flimit = 1.0e-20 +!> internal solar constant + real (kind=kind_phys), parameter :: s0 = 1368.22 + + real (kind=kind_phys), parameter :: f_zero = 0.0 + real (kind=kind_phys), parameter :: f_one = 1.0 + +!> \name atomic weights for conversion from mass to volume mixing ratios + real (kind=kind_phys), parameter :: amdw = con_amd/con_amw + real (kind=kind_phys), parameter :: amdo3 = con_amd/con_amo3 + +!> \name band indices + integer, dimension(nblow:nbhgh) :: nspa, nspb +!> band index for sfc flux + integer, dimension(nblow:nbhgh) :: idxsfc +!> band index for cld prop + integer, dimension(nblow:nbhgh) :: idxebc + + data nspa(:) / 9, 9, 9, 9, 1, 9, 9, 1, 9, 1, 0, 1, 9, 1 / + data nspb(:) / 1, 5, 1, 1, 1, 5, 1, 0, 1, 0, 0, 1, 5, 1 / + +! data idxsfc(:) / 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 1 / ! band index for sfc flux + data idxsfc(:) / 1, 1, 1, 1, 1, 1, 1, 1, 0, 2, 2, 2, 2, 1 / ! band index for sfc flux + data idxebc(:) / 5, 5, 4, 4, 3, 3, 2, 2, 1, 1, 1, 1, 1, 5 / ! band index for cld prop + +! --- band wavenumber intervals +! real (kind=kind_phys), dimension(nblow:nbhgh):: wavenum1,wavenum2 +! data wavenum1(:) / & +! & 2600.0, 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, & +! & 8050.0,12850.0,16000.0,22650.0,29000.0,38000.0, 820.0 / +! data wavenum2(:) / & +! 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & +! & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / +! real (kind=kind_phys), dimension(nblow:nbhgh) :: delwave +! data delwave(:) / & +! & 650.0, 750.0, 650.0, 500.0, 1000.0, 1550.0, 350.0, & +! & 4800.0, 3150.0, 6650.0, 6350.0, 9000.0,12000.0, 1780.0 / + +!> uv-b band index + integer, parameter :: nuvb = 27 + +!>\name logical flags for optional output fields + logical :: lhswb = .false. + logical :: lhsw0 = .false. + logical :: lflxprf= .false. + logical :: lfdncmp= .false. + + +!> those data will be set up only once by "rswinit" + real (kind=kind_phys) :: exp_tbl(0:NTBMX) + + +!> the factor for heating rates (in k/day, or k/sec set by subroutine +!! 'rswinit') + real (kind=kind_phys) :: heatfac + + +!> initial permutation seed used for sub-column cloud scheme + integer, parameter :: ipsdsw0 = 1 + +! --- public accessable subprograms + + public swrad, rswinit + + +! ================= + contains +! ================= + +!> This subroutine is the main SW radiation routine. +!!\param plyr model layer mean pressure in mb +!!\param plvl model level pressure in mb +!!\param tlyr model layer mean temperature in K +!!\param tlvl model level temperature in K (not in use) +!!\param qlyr layer specific humidity in gm/gm +!!\param olyr layer ozone concentration in gm/gm +!!\param gasvmr atmospheric constent gases +!!\n (:,:,1) - co2 volume mixing ratio +!!\n (:,:,2) - n2o volume mixing ratio +!!\n (:,:,3) - ch4 volume mixing ratio +!!\n (:,:,4) - o2 volume mixing ratio +!!\n (:,:,5) - co volume mixing ratio (not used) +!!\n (:,:,6) - cfc11 volume mixing ratio (not used) +!!\n (:,:,7) - cfc12 volume mixing ratio (not used) +!!\n (:,:,8) - cfc22 volume mixing ratio (not used) +!!\n (:,:,9) - ccl4 volume mixing ratio (not used) +!!\param clouds cloud profile +!!\n (:,:,1) - layer total cloud fraction +!!\n (:,:,2) - layer in-cloud liq water path (\f$g/m^2\f$) +!!\n (:,:,3) - mean eff radius for liq cloud (micron) +!!\n (:,:,4) - layer in-cloud ice water path (\f$g/m^2\f$) +!!\n (:,:,5) - mean eff radius for ice cloud (micron) +!!\n (:,:,6) - layer rain drop water path (\f$g/m^2\f$) +!!\n (:,:,7) - mean eff radius for rain drop (micron) +!!\n (:,:,8) - layer snow flake water path (\f$g/m^2\f$) +!!\n (:,:,9) - mean eff radius for snow flake (micron) +!!\param icseed auxiliary special cloud related array. +!!\param aerosols aerosol optical properties +!!\n (:,:,:,1) - optical depth +!!\n (:,:,:,2) - single scattering albedo +!!\n (:,:,:,3) - asymmetry parameter +!!\param sfcalb surface albedo in fraction +!!\n (:,1) - near ir direct beam albedo +!!\n (:,2) - near ir diffused albedo +!!\n (:,3) - uv+vis direct beam albedo +!!\n (:,4) - uv+vis diffused albedo +!!\param cosz cosine of solar zenith angle +!!\param solcon solar constant (\f$W/m^2\f$) +!!\param NDAY num of daytime points +!!\param idxday index array for daytime points +!!\param npts number of horizontal points +!!\param nlay,nlp1 vertical layer/lavel numbers +!!\param lprnt logical check print flag +!!\param hswc total sky heating rates (k/sec or k/day) +!!\param topflx radiation fluxes at toa (\f$W/m^2\f$), components: +!!\n upfxc - total sky upward flux at toa +!!\n dnflx - total sky downward flux at toa +!!\n upfx0 - clear sky upward flux at toa +!!\param sfcflx radiation fluxes at sfc (\f$W/m^2\f$), components: +!!\n upfxc - total sky upward flux at sfc +!!\n dnfxc - total sky downward flux at sfc +!!\n upfx0 - clear sky upward flux at sfc +!!\n dnfx0 - clear sky downward flux at sfc +!!\param hswb spectral band total sky heating rates +!!\param hsw0 clear sky heating rates (k/sec or k/day) +!!\param flxprf level radiation fluxes (\f$ W/m^2 \f$), components: +!!\n dnfxc - total sky downward flux at interface +!!\n upfxc - total sky upward flux at interface +!!\n dnfx0 - clear sky downward flux at interface +!!\n upfx0 - clear sky upward flux at interface +!!\param fdncmp surface downward fluxes (\f$W/m^2\f$), components: +!!\n uvbfc - total sky downward uv-b flux at sfc +!!\n uvbf0 - clear sky downward uv-b flux at sfc +!!\n nirbm - downward surface nir direct beam flux +!!\n nirdf - downward surface nir diffused flux +!!\n visbm - downward surface uv+vis direct beam flux +!!\n visdf - downward surface uv+vis diffused flux +!> \section General_swrad General Algorithm +!> @{ +!----------------------------------- + subroutine swrad & + & ( plyr,plvl,tlyr,tlvl,qlyr,olyr,gasvmr, & ! --- inputs + & clouds,icseed,aerosols,sfcalb, & + & cosz,solcon,NDAY,idxday, & + & npts, nlay, nlp1, lprnt, & + & hswc,topflx,sfcflx, & ! --- outputs + & HSW0,HSWB,FLXPRF,FDNCMP & ! --- optional + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! plyr (npts,nlay) : model layer mean pressure in mb ! +! plvl (npts,nlp1) : model level pressure in mb ! +! tlyr (npts,nlay) : model layer mean temperature in k ! +! tlvl (npts,nlp1) : model level temperature in k (not in use) ! +! qlyr (npts,nlay) : layer specific humidity in gm/gm *see inside ! +! olyr (npts,nlay) : layer ozone concentration in gm/gm ! +! gasvmr(npts,nlay,:): atmospheric constent gases: ! +! (check module_radiation_gases for definition) ! +! gasvmr(:,:,1) - co2 volume mixing ratio ! +! gasvmr(:,:,2) - n2o volume mixing ratio ! +! gasvmr(:,:,3) - ch4 volume mixing ratio ! +! gasvmr(:,:,4) - o2 volume mixing ratio ! +! gasvmr(:,:,5) - co volume mixing ratio (not used) ! +! gasvmr(:,:,6) - cfc11 volume mixing ratio (not used) ! +! gasvmr(:,:,7) - cfc12 volume mixing ratio (not used) ! +! gasvmr(:,:,8) - cfc22 volume mixing ratio (not used) ! +! gasvmr(:,:,9) - ccl4 volume mixing ratio (not used) ! +! clouds(npts,nlay,:): cloud profile ! +! (check module_radiation_clouds for definition) ! +! --- for iswcliq > 0 --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer in-cloud liq water path (g/m**2) ! +! clouds(:,:,3) - mean eff radius for liq cloud (micron) ! +! clouds(:,:,4) - layer in-cloud ice water path (g/m**2) ! +! clouds(:,:,5) - mean eff radius for ice cloud (micron) ! +! clouds(:,:,6) - layer rain drop water path (g/m**2) ! +! clouds(:,:,7) - mean eff radius for rain drop (micron) ! +! clouds(:,:,8) - layer snow flake water path (g/m**2) ! +! clouds(:,:,9) - mean eff radius for snow flake (micron) ! +! --- for iswcliq = 0 --- ! +! clouds(:,:,1) - layer total cloud fraction ! +! clouds(:,:,2) - layer cloud optical depth ! +! clouds(:,:,3) - layer cloud single scattering albedo ! +! clouds(:,:,4) - layer cloud asymmetry factor ! +! icseed(npts) : auxiliary special cloud related array ! +! when module variable isubcsw=2, it provides ! +! permutation seed for each column profile that ! +! are used for generating random numbers. ! +! when isubcsw /=2, it will not be used. ! +! aerosols(npts,nlay,nbdsw,:) : aerosol optical properties ! +! (check module_radiation_aerosols for definition) ! +! (:,:,:,1) - optical depth ! +! (:,:,:,2) - single scattering albedo ! +! (:,:,:,3) - asymmetry parameter ! +! sfcalb(npts, : ) : surface albedo in fraction ! +! (check module_radiation_surface for definition) ! +! ( :, 1 ) - near ir direct beam albedo ! +! ( :, 2 ) - near ir diffused albedo ! +! ( :, 3 ) - uv+vis direct beam albedo ! +! ( :, 4 ) - uv+vis diffused albedo ! +! cosz (npts) : cosine of solar zenith angle ! +! solcon : solar constant (w/m**2) ! +! NDAY : num of daytime points ! +! idxday(npts) : index array for daytime points ! +! npts : number of horizontal points ! +! nlay,nlp1 : vertical layer/lavel numbers ! +! lprnt : logical check print flag ! +! ! +! output variables: ! +! hswc (npts,nlay): total sky heating rates (k/sec or k/day) ! +! topflx(npts) : radiation fluxes at toa (w/m**2), components: ! +! (check module_radsw_parameters for definition) ! +! upfxc - total sky upward flux at toa ! +! dnflx - total sky downward flux at toa ! +! upfx0 - clear sky upward flux at toa ! +! sfcflx(npts) : radiation fluxes at sfc (w/m**2), components: ! +! (check module_radsw_parameters for definition) ! +! upfxc - total sky upward flux at sfc ! +! dnfxc - total sky downward flux at sfc ! +! upfx0 - clear sky upward flux at sfc ! +! dnfx0 - clear sky downward flux at sfc ! +! ! +!!optional outputs variables: ! +! hswb(npts,nlay,nbdsw): spectral band total sky heating rates ! +! hsw0 (npts,nlay): clear sky heating rates (k/sec or k/day) ! +! flxprf(npts,nlp1): level radiation fluxes (w/m**2), components: ! +! (check module_radsw_parameters for definition) ! +! dnfxc - total sky downward flux at interface ! +! upfxc - total sky upward flux at interface ! +! dnfx0 - clear sky downward flux at interface ! +! upfx0 - clear sky upward flux at interface ! +! fdncmp(npts) : component surface downward fluxes (w/m**2): ! +! (check module_radsw_parameters for definition) ! +! uvbfc - total sky downward uv-b flux at sfc ! +! uvbf0 - clear sky downward uv-b flux at sfc ! +! nirbm - downward surface nir direct beam flux ! +! nirdf - downward surface nir diffused flux ! +! visbm - downward surface uv+vis direct beam flux ! +! visdf - downward surface uv+vis diffused flux ! +! ! +! external module variables: (in physparam) ! +! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! iswcliq - control flag for liq-cloud optical properties ! +! =0: input cloud optical depth, fixed ssa, asy ! +! =1: use hu and stamnes(1993) method for liq cld ! +! =2: not used ! +! iswcice - control flag for ice-cloud optical properties ! +! *** if iswcliq==0, iswcice is ignored ! +! =1: use ebert and curry (1992) scheme for ice clouds ! +! =2: use streamer v3.0 (2001) method for ice clouds ! +! =3: use fu's method (1996) for ice clouds ! +! iswmode - control flag for 2-stream transfer scheme ! +! =1; delta-eddington (joseph et al., 1976) ! +! =2: pifm (zdunkowski et al., 1980) ! +! =3: discrete ordinates (liou, 1973) ! +! isubcsw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! iovrsw - cloud overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud ! +! ivflip - control flg for direction of vertical index ! +! =0: index from toa to surface ! +! =1: index from surface to toa ! +! ! +! module parameters, control variables: ! +! nblow,nbhgh - lower and upper limits of spectral bands ! +! maxgas - maximum number of absorbing gaseous ! +! ngptsw - total number of g-point subintervals ! +! ng## - number of g-points in band (##=16-29) ! +! ngb(ngptsw) - band indices for each g-point ! +! bpade - pade approximation constant (1/0.278) ! +! nspa,nspb(nblow:nbhgh) ! +! - number of lower/upper ref atm's per band ! +! ipsdsw0 - permutation seed for mcica sub-col clds ! +! ! +! major local variables: ! +! pavel (nlay) - layer pressures (mb) ! +! delp (nlay) - layer pressure thickness (mb) ! +! tavel (nlay) - layer temperatures (k) ! +! coldry (nlay) - dry air column amount ! +! (1.e-20*molecules/cm**2) ! +! cldfrc (nlay) - layer cloud fraction (norm by tot cld) ! +! cldfmc (nlay,ngptsw) - layer cloud fraction for g-point ! +! taucw (nlay,nbdsw) - cloud optical depth ! +! ssacw (nlay,nbdsw) - cloud single scattering albedo (weighted) ! +! asycw (nlay,nbdsw) - cloud asymmetry factor (weighted) ! +! tauaer (nlay,nbdsw) - aerosol optical depths ! +! ssaaer (nlay,nbdsw) - aerosol single scattering albedo ! +! asyaer (nlay,nbdsw) - aerosol asymmetry factor ! +! colamt (nlay,maxgas) - column amounts of absorbing gases ! +! 1 to maxgas are for h2o, co2, o3, n2o, ! +! ch4, o2, co, respectively (mol/cm**2) ! +! facij (nlay) - indicator of interpolation factors ! +! =0/1: indicate lower/higher temp & height ! +! selffac(nlay) - scale factor for self-continuum, equals ! +! (w.v. density)/(atm density at 296K,1013 mb) ! +! selffrac(nlay) - factor for temp interpolation of ref ! +! self-continuum data ! +! indself(nlay) - index of the lower two appropriate ref ! +! temp for the self-continuum interpolation ! +! forfac (nlay) - scale factor for w.v. foreign-continuum ! +! forfrac(nlay) - factor for temp interpolation of ref ! +! w.v. foreign-continuum data ! +! indfor (nlay) - index of the lower two appropriate ref ! +! temp for the foreign-continuum interp ! +! laytrop - layer at which switch is made from one ! +! combination of key species to another ! +! jp(nlay),jt(nlay),jt1(nlay) ! +! - lookup table indexes ! +! flxucb(nlp1,nbdsw) - spectral bnd total-sky upward flx (w/m2) ! +! flxdcb(nlp1,nbdsw) - spectral bnd total-sky downward flx (w/m2)! +! flxu0b(nlp1,nbdsw) - spectral bnd clear-sky upward flx (w/m2) ! +! flxd0b(nlp1,nbdsw) - spectral b d clear-sky downward flx (w/m2)! +! ! +! ! +! ===================== end of definitions ==================== ! + +! --- inputs: + integer, intent(in) :: npts, nlay, nlp1, NDAY + + integer, dimension(:), intent(in) :: idxday, icseed + + logical, intent(in) :: lprnt + + real (kind=kind_phys), dimension(npts,nlp1), intent(in) :: & + & plvl, tlvl + real (kind=kind_phys), dimension(npts,nlay), intent(in) :: & + & plyr, tlyr, qlyr, olyr + real (kind=kind_phys), dimension(npts,4), intent(in) :: sfcalb + + real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: gasvmr + real (kind=kind_phys), dimension(npts,nlay,9),intent(in):: clouds + real (kind=kind_phys), dimension(npts,nlay,nbdsw,3),intent(in):: & + & aerosols + + real (kind=kind_phys), intent(in) :: cosz(npts), solcon + +! --- outputs: + real (kind=kind_phys), dimension(npts,nlay), intent(out) :: hswc + + type (topfsw_type), dimension(npts), intent(out) :: topflx + type (sfcfsw_type), dimension(npts), intent(out) :: sfcflx + +!! --- optional outputs: + real (kind=kind_phys), dimension(npts,nlay,nbdsw), optional, & + & intent(out) :: hswb + + real (kind=kind_phys), dimension(npts,nlay), optional, & + & intent(out) :: hsw0 + type (profsw_type), dimension(npts,nlp1), optional, & + & intent(out) :: flxprf + type (cmpfsw_type), dimension(npts), optional, & + & intent(out) :: fdncmp + +! --- locals: + real (kind=kind_phys), dimension(nlay,ngptsw) :: cldfmc, & + & taug, taur + real (kind=kind_phys), dimension(nlp1,nbdsw):: fxupc, fxdnc, & + & fxup0, fxdn0 + + real (kind=kind_phys), dimension(nlay,nbdsw) :: & + & tauae, ssaae, asyae, taucw, ssacw, asycw + + real (kind=kind_phys), dimension(ngptsw) :: sfluxzen + + real (kind=kind_phys), dimension(nlay) :: cldfrc, delp, & + & pavel, tavel, coldry, colmol, h2ovmr, o3vmr, temcol, & + & cliqp, reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, & + & cfrac, fac00, fac01, fac10, fac11, forfac, forfrac, & + & selffac, selffrac, rfdelp + + real (kind=kind_phys), dimension(nlp1) :: fnet, flxdc, flxuc, & + & flxd0, flxu0 + + real (kind=kind_phys), dimension(2) :: albbm, albdf, sfbmc, & + & sfbm0, sfdfc, sfdf0 + + real (kind=kind_phys) :: cosz1, sntz1, tem0, tem1, tem2, s0fac, & + & ssolar, zcf0, zcf1, ftoau0, ftoauc, ftoadc, & + & fsfcu0, fsfcuc, fsfcd0, fsfcdc, suvbfc, suvbf0 + +! --- column amount of absorbing gases: +! (:,m) m = 1-h2o, 2-co2, 3-o3, 4-n2o, 5-ch4, 6-o2, 7-co + real (kind=kind_phys) :: colamt(nlay,maxgas) + + integer, dimension(npts) :: ipseed + integer, dimension(nlay) :: indfor, indself, jp, jt, jt1 + + integer :: i, ib, ipt, j1, k, kk, laytrop, mb +! +!===> ... begin here +! + + lhswb = present ( hswb ) + lhsw0 = present ( hsw0 ) + lflxprf= present ( flxprf ) + lfdncmp= present ( fdncmp ) + +!> -# Compute solar constant adjustment factor (s0fac) according to solcon. +! *** s0, the solar constant at toa in w/m**2, is hard-coded with +! each spectra band, the total flux is about 1368.22 w/m**2. + + s0fac = solcon / s0 + +!> -# Initial output arrays (and optional) as zero. + + hswc(:,:) = f_zero + topflx = topfsw_type ( f_zero, f_zero, f_zero ) + sfcflx = sfcfsw_type ( f_zero, f_zero, f_zero, f_zero ) + +!! --- ... initial optional outputs + if ( lflxprf ) then + flxprf = profsw_type ( f_zero, f_zero, f_zero, f_zero ) + endif + + if ( lfdncmp ) then + fdncmp = cmpfsw_type (f_zero,f_zero,f_zero,f_zero,f_zero,f_zero) + endif + + if ( lhsw0 ) then + hsw0(:,:) = f_zero + endif + + if ( lhswb ) then + hswb(:,:,:) = f_zero + endif + +!> -# Change random number seed value for each radiation invocation +!! (isubcsw =1 or 2). + + if ( isubcsw == 1 ) then ! advance prescribed permutation seed + do i = 1, npts + ipseed(i) = ipsdsw0 + i + enddo + elseif ( isubcsw == 2 ) then ! use input array of permutaion seeds + do i = 1, npts + ipseed(i) = icseed(i) + enddo + endif + + if ( lprnt ) then + write(0,*)' In radsw, isubcsw, ipsdsw0,ipseed =', & + & isubcsw, ipsdsw0, ipseed + endif + +! --- ... loop over each daytime grid point + + lab_do_ipt : do ipt = 1, NDAY + + j1 = idxday(ipt) + + cosz1 = cosz(j1) + sntz1 = f_one / cosz(j1) + ssolar = s0fac * cosz(j1) + +!> -# Prepare surface albedo: bm,df - dir,dif; 1,2 - nir,uvv. + albbm(1) = sfcalb(j1,1) + albdf(1) = sfcalb(j1,2) + albbm(2) = sfcalb(j1,3) + albdf(2) = sfcalb(j1,4) + +!> -# Prepare atmospheric profile for use in rrtm. +! the vertical index of internal array is from surface to top + + if (ivflip == 0) then ! input from toa to sfc + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + + do k = 1, nlay + kk = nlp1 - k + pavel(k) = plyr(j1,kk) + tavel(k) = tlyr(j1,kk) + delp (k) = plvl(j1,kk+1) - plvl(j1,kk) +!> -# Set absorber and gas column amount, convert from volume mixing +!! ratio to molec/cm2 based on coldry (scaled to 1.0e-20) +!! - colamt(nlay,maxgas):column amounts of absorbing gases 1 to +!! maxgas are for h2o,co2,o3,n2o,ch4,o2,co, respectively +!! (\f$ mol/cm^2 \f$) + +!test use +! h2ovmr(k)= max(f_zero,qlyr(j1,kk)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(j1,kk)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(j1,kk)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(j1,kk)*amdw/(f_one-qlyr(j1,kk))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(j1,kk)*amdo3) ! input mass mixing ratio + + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2 * delp(k) / (tem1*tem0*(f_one + h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(j1,kk,1)) ! co2 + colamt(k,3) = max(f_zero, coldry(k)*o3vmr(k)) ! o3 + colmol(k) = coldry(k) + colamt(k,1) + enddo + +! --- ... set up gas column amount, convert from volume mixing ratio +! to molec/cm2 based on coldry (scaled to 1.0e-20) + + if (iswrgas > 0) then + do k = 1, nlay + kk = nlp1 - k + colamt(k,4) = max(temcol(k), coldry(k)*gasvmr(j1,kk,2)) ! n2o + colamt(k,5) = max(temcol(k), coldry(k)*gasvmr(j1,kk,3)) ! ch4 + colamt(k,6) = max(temcol(k), coldry(k)*gasvmr(j1,kk,4)) ! o2 +! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,kk,5)) ! co - notused + enddo + else + do k = 1, nlay + colamt(k,4) = temcol(k) ! n2o + colamt(k,5) = temcol(k) ! ch4 + colamt(k,6) = temcol(k) ! o2 +! colamt(k,7) = temcol(k) ! co - notused + enddo + endif + +!> -# Read aerosol optical properties from 'aerosols'. + + do k = 1, nlay + kk = nlp1 - k + do ib = 1, nbdsw + tauae(k,ib) = aerosols(j1,kk,ib,1) + ssaae(k,ib) = aerosols(j1,kk,ib,2) + asyae(k,ib) = aerosols(j1,kk,ib,3) + enddo + enddo + +!> -# Read cloud optical properties from 'clouds'. + if (iswcliq > 0) then ! use prognostic cloud method + do k = 1, nlay + kk = nlp1 - k + cfrac(k) = clouds(j1,kk,1) ! cloud fraction + cliqp(k) = clouds(j1,kk,2) ! cloud liq path + reliq(k) = clouds(j1,kk,3) ! liq partical effctive radius + cicep(k) = clouds(j1,kk,4) ! cloud ice path + reice(k) = clouds(j1,kk,5) ! ice partical effctive radius + cdat1(k) = clouds(j1,kk,6) ! cloud rain drop path + cdat2(k) = clouds(j1,kk,7) ! rain partical effctive radius + cdat3(k) = clouds(j1,kk,8) ! cloud snow path + cdat4(k) = clouds(j1,kk,9) ! snow partical effctive radius + enddo + else ! use diagnostic cloud method + do k = 1, nlay + kk = nlp1 - k + cfrac(k) = clouds(j1,kk,1) ! cloud fraction + cdat1(k) = clouds(j1,kk,2) ! cloud optical depth + cdat2(k) = clouds(j1,kk,3) ! cloud single scattering albedo + cdat3(k) = clouds(j1,kk,4) ! cloud asymmetry factor + enddo + endif ! end if_iswcliq + + else ! input from sfc to toa + + tem1 = 100.0 * con_g + tem2 = 1.0e-20 * 1.0e3 * con_avgd + + do k = 1, nlay + pavel(k) = plyr(j1,k) + tavel(k) = tlyr(j1,k) + delp (k) = plvl(j1,k) - plvl(j1,k+1) + +! --- ... set absorber amount +!test use +! h2ovmr(k)= max(f_zero,qlyr(j1,k)*amdw) ! input mass mixing ratio +! h2ovmr(k)= max(f_zero,qlyr(j1,k)) ! input vol mixing ratio +! o3vmr (k)= max(f_zero,olyr(j1,k)) ! input vol mixing ratio +!ncep model use + h2ovmr(k)= max(f_zero,qlyr(j1,k)*amdw/(f_one-qlyr(j1,k))) ! input specific humidity + o3vmr (k)= max(f_zero,olyr(j1,k)*amdo3) ! input mass mixing ratio + + tem0 = (f_one - h2ovmr(k))*con_amd + h2ovmr(k)*con_amw + coldry(k) = tem2 * delp(k) / (tem1*tem0*(f_one + h2ovmr(k))) + temcol(k) = 1.0e-12 * coldry(k) + + colamt(k,1) = max(f_zero, coldry(k)*h2ovmr(k)) ! h2o + colamt(k,2) = max(temcol(k), coldry(k)*gasvmr(j1,k,1)) ! co2 + colamt(k,3) = max(f_zero, coldry(k)*o3vmr(k)) ! o3 + colmol(k) = coldry(k) + colamt(k,1) + enddo + + + if (lprnt) then + if (ipt == 1) then + write(0,*)' pavel=',pavel + write(0,*)' tavel=',tavel + write(0,*)' delp=',delp + write(0,*)' h2ovmr=',h2ovmr*1000 + write(0,*)' o3vmr=',o3vmr*1000000 + endif + endif + +! --- ... set up gas column amount, convert from volume mixing ratio +! to molec/cm2 based on coldry (scaled to 1.0e-20) + + if (iswrgas > 0) then + do k = 1, nlay + colamt(k,4) = max(temcol(k), coldry(k)*gasvmr(j1,k,2)) ! n2o + colamt(k,5) = max(temcol(k), coldry(k)*gasvmr(j1,k,3)) ! ch4 + colamt(k,6) = max(temcol(k), coldry(k)*gasvmr(j1,k,4)) ! o2 +! colamt(k,7) = max(temcol(k), coldry(k)*gasvmr(j1,k,5)) ! co - notused + enddo + else + do k = 1, nlay + colamt(k,4) = temcol(k) ! n2o + colamt(k,5) = temcol(k) ! ch4 + colamt(k,6) = temcol(k) ! o2 +! colamt(k,7) = temcol(k) ! co - notused + enddo + endif + +! --- ... set aerosol optical properties + + do ib = 1, nbdsw + do k = 1, nlay + tauae(k,ib) = aerosols(j1,k,ib,1) + ssaae(k,ib) = aerosols(j1,k,ib,2) + asyae(k,ib) = aerosols(j1,k,ib,3) + enddo + enddo + + if (iswcliq > 0) then ! use prognostic cloud method + do k = 1, nlay + cfrac(k) = clouds(j1,k,1) ! cloud fraction + cliqp(k) = clouds(j1,k,2) ! cloud liq path + reliq(k) = clouds(j1,k,3) ! liq partical effctive radius + cicep(k) = clouds(j1,k,4) ! cloud ice path + reice(k) = clouds(j1,k,5) ! ice partical effctive radius + cdat1(k) = clouds(j1,k,6) ! cloud rain drop path + cdat2(k) = clouds(j1,k,7) ! rain partical effctive radius + cdat3(k) = clouds(j1,k,8) ! cloud snow path + cdat4(k) = clouds(j1,k,9) ! snow partical effctive radius + enddo + else ! use diagnostic cloud method + do k = 1, nlay + cfrac(k) = clouds(j1,k,1) ! cloud fraction + cdat1(k) = clouds(j1,k,2) ! cloud optical depth + cdat2(k) = clouds(j1,k,3) ! cloud single scattering albedo + cdat3(k) = clouds(j1,k,4) ! cloud asymmetry factor + enddo + endif ! end if_iswcliq + + endif ! if_ivflip + +!> -# Compute fractions of clear sky view: +!! - random overlapping +!! - max/ran overlapping +!! - maximum overlapping + + zcf0 = f_one + zcf1 = f_one + if (iovrsw == 0) then ! random overlapping + do k = 1, nlay + zcf0 = zcf0 * (f_one - cfrac(k)) + enddo + else if (iovrsw == 1) then ! max/ran overlapping + do k = 1, nlay + if (cfrac(k) > ftiny) then ! cloudy layer + zcf1 = min ( zcf1, f_one-cfrac(k) ) + elseif (zcf1 < f_one) then ! clear layer + zcf0 = zcf0 * zcf1 + zcf1 = f_one + endif + enddo + zcf0 = zcf0 * zcf1 + else if (iovrsw == 2) then ! maximum overlapping + do k = 1, nlay + zcf0 = min ( zcf0, f_one-cfrac(k) ) + enddo + endif + + if (zcf0 <= ftiny) zcf0 = f_zero + if (zcf0 > oneminus) zcf0 = f_one + zcf1 = f_one - zcf0 + +!> -# For cloudy sky column, call cldprop() to compute the cloud +!! optical properties for each cloudy layer. + + if (zcf1 > f_zero) then ! cloudy sky column + + call cldprop & +! --- inputs: + & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & + & zcf1, nlay, ipseed(j1), & +! --- outputs: + & taucw, ssacw, asycw, cldfrc, cldfmc & + & ) + + else ! clear sky column + cldfrc(:) = f_zero + cldfmc(:,:)= f_zero + do i = 1, nbdsw + do k = 1, nlay + taucw(k,i) = f_zero + ssacw(k,i) = f_zero + asycw(k,i) = f_zero + enddo + enddo + endif ! end if_zcf1_block + +!> -# Call setcoef() to compute various coefficients needed in +!! radiative transfer calculations. + call setcoef & +! --- inputs: + & ( pavel,tavel,h2ovmr, nlay,nlp1, & +! --- outputs: + & laytrop,jp,jt,jt1,fac00,fac01,fac10,fac11, & + & selffac,selffrac,indself,forfac,forfrac,indfor & + & ) + +!> -# Call taumol() to calculate optical depths for gaseous absorption +!! and rayleigh scattering + call taumol & +! --- inputs: + & ( colamt,colmol,fac00,fac01,fac10,fac11,jp,jt,jt1,laytrop, & + & forfac,forfrac,indfor,selffac,selffrac,indself, NLAY, & +! --- outputs: + & sfluxzen, taug, taur & + & ) + +!> -# Call the 2-stream radiation transfer model: +!! - if physparam::isubcsw .le.0, using standard cloud scheme, +!! call spcvrtc(). +!! - if physparam::isubcsw .gt.0, using mcica cloud scheme, +!! call spcvrtm(). + + if ( isubcsw <= 0 ) then ! use standard cloud scheme + + call spcvrtc & +! --- inputs: + & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfrc, & + & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & +! --- outputs: + & fxupc,fxdnc,fxup0,fxdn0, & + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + + else ! use mcica cloud scheme + + call spcvrtm & +! --- inputs: + & ( ssolar,cosz1,sntz1,albbm,albdf,sfluxzen,cldfmc, & + & zcf1,zcf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & +! --- outputs: + & fxupc,fxdnc,fxup0,fxdn0, & + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + + endif + +!> -# Save outputs. +! --- ... sum up total spectral fluxes for total-sky + + do k = 1, nlp1 + flxuc(k) = f_zero + flxdc(k) = f_zero + + do ib = 1, nbdsw + flxuc(k) = flxuc(k) + fxupc(k,ib) + flxdc(k) = flxdc(k) + fxdnc(k,ib) + enddo + enddo + +!! --- ... optional clear sky fluxes + + if ( lhsw0 .or. lflxprf ) then + do k = 1, nlp1 + flxu0(k) = f_zero + flxd0(k) = f_zero + + do ib = 1, nbdsw + flxu0(k) = flxu0(k) + fxup0(k,ib) + flxd0(k) = flxd0(k) + fxdn0(k,ib) + enddo + enddo + endif + +! --- ... prepare for final outputs + + do k = 1, nlay + rfdelp(k) = heatfac / delp(k) + enddo + + if ( lfdncmp ) then +!! --- ... optional uv-b surface downward flux + fdncmp(j1)%uvbf0 = suvbf0 + fdncmp(j1)%uvbfc = suvbfc + +!! --- ... optional beam and diffuse sfc fluxes + fdncmp(j1)%nirbm = sfbmc(1) + fdncmp(j1)%nirdf = sfdfc(1) + fdncmp(j1)%visbm = sfbmc(2) + fdncmp(j1)%visdf = sfdfc(2) + endif ! end if_lfdncmp + +! --- ... toa and sfc fluxes + + topflx(j1)%upfxc = ftoauc + topflx(j1)%dnfxc = ftoadc + topflx(j1)%upfx0 = ftoau0 + + sfcflx(j1)%upfxc = fsfcuc + sfcflx(j1)%dnfxc = fsfcdc + sfcflx(j1)%upfx0 = fsfcu0 + sfcflx(j1)%dnfx0 = fsfcd0 + + if (ivflip == 0) then ! output from toa to sfc + +! --- ... compute heating rates + + fnet(1) = flxdc(1) - flxuc(1) + + do k = 2, nlp1 + kk = nlp1 - k + 1 + fnet(k) = flxdc(k) - flxuc(k) + hswc(j1,kk) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + +!! --- ... optional flux profiles + + if ( lflxprf ) then + do k = 1, nlp1 + kk = nlp1 - k + 1 + flxprf(j1,kk)%upfxc = flxuc(k) + flxprf(j1,kk)%dnfxc = flxdc(k) + flxprf(j1,kk)%upfx0 = flxu0(k) + flxprf(j1,kk)%dnfx0 = flxd0(k) + enddo + endif + +!! --- ... optional clear sky heating rates + + if ( lhsw0 ) then + fnet(1) = flxd0(1) - flxu0(1) + + do k = 2, nlp1 + kk = nlp1 - k + 1 + fnet(k) = flxd0(k) - flxu0(k) + hsw0(j1,kk) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + endif + +!! --- ... optional spectral band heating rates + + if ( lhswb ) then + do mb = 1, nbdsw + fnet(1) = fxdnc(1,mb) - fxupc(1,mb) + + do k = 2, nlp1 + kk = nlp1 - k + 1 + fnet(k) = fxdnc(k,mb) - fxupc(k,mb) + hswb(j1,kk,mb) = (fnet(k) - fnet(k-1)) * rfdelp(k-1) + enddo + enddo + endif + + else ! output from sfc to toa + +! --- ... compute heating rates + + fnet(1) = flxdc(1) - flxuc(1) + + do k = 2, nlp1 + fnet(k) = flxdc(k) - flxuc(k) + hswc(j1,k-1) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + +!! --- ... optional flux profiles + + if ( lflxprf ) then + do k = 1, nlp1 + flxprf(j1,k)%upfxc = flxuc(k) + flxprf(j1,k)%dnfxc = flxdc(k) + flxprf(j1,k)%upfx0 = flxu0(k) + flxprf(j1,k)%dnfx0 = flxd0(k) + enddo + endif + +!! --- ... optional clear sky heating rates + + if ( lhsw0 ) then + fnet(1) = flxd0(1) - flxu0(1) + + do k = 2, nlp1 + fnet(k) = flxd0(k) - flxu0(k) + hsw0(j1,k-1) = (fnet(k)-fnet(k-1)) * rfdelp(k-1) + enddo + endif + +!! --- ... optional spectral band heating rates + + if ( lhswb ) then + do mb = 1, nbdsw + fnet(1) = fxdnc(1,mb) - fxupc(1,mb) + + do k = 1, nlay + fnet(k+1) = fxdnc(k+1,mb) - fxupc(k+1,mb) + hswb(j1,k,mb) = (fnet(k+1) - fnet(k)) * rfdelp(k) + enddo + enddo + endif + + endif ! if_ivflip + + enddo lab_do_ipt + + return +!................................... + end subroutine swrad +!----------------------------------- +!> @} + + +!> This subroutine initializes non-varying module variables, conversion +!! factors, and look-up tables. +!!\param me print control for parallel process +!----------------------------------- + subroutine rswinit & + & ( me ) ! --- inputs: +! --- outputs: (none) + +! =================== program usage description =================== ! +! ! +! purpose: initialize non-varying module variables, conversion factors,! +! and look-up tables. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: ! +! me - print control for parallel process ! +! ! +! outputs: (none) ! +! ! +! external module variables: (in physparam) ! +! iswrate - heating rate unit selections ! +! =1: output in k/day ! +! =2: output in k/second ! +! iswrgas - control flag for rare gases (ch4,n2o,o2, etc.) ! +! =0: do not include rare gases ! +! >0: include all rare gases ! +! iswcliq - liquid cloud optical properties contrl flag ! +! =0: input cloud opt depth from diagnostic scheme ! +! >0: input cwp,rew, and other cloud content parameters ! +! isubcsw - sub-column cloud approximation control flag ! +! =0: no sub-col cld treatment, use grid-mean cld quantities ! +! =1: mcica sub-col, prescribed seeds to get random numbers ! +! =2: mcica sub-col, providing array icseed for random numbers! +! icldflg - cloud scheme control flag ! +! =0: diagnostic scheme gives cloud tau, omiga, and g. ! +! =1: prognostic scheme gives cloud liq/ice path, etc. ! +! iovrsw - clouds vertical overlapping control flag ! +! =0: random overlapping clouds ! +! =1: maximum/random overlapping clouds ! +! =2: maximum overlap cloud ! +! iswmode - control flag for 2-stream transfer scheme ! +! =1; delta-eddington (joseph et al., 1976) ! +! =2: pifm (zdunkowski et al., 1980) ! +! =3: discrete ordinates (liou, 1973) ! +! ! +! ******************************************************************* ! +! ! +! definitions: ! +! arrays for 10000-point look-up tables: ! +! tau_tbl clear-sky optical depth ! +! exp_tbl exponential lookup table for transmittance ! +! ! +! ******************************************************************* ! +! ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: me + +! --- outputs: none + +! --- locals: + real (kind=kind_phys), parameter :: expeps = 1.e-20 + + integer :: i + + real (kind=kind_phys) :: tfn, tau + +! +!===> ... begin here +! + if ( iovrsw<0 .or. iovrsw>2 ) then + print *,' *** Error in specification of cloud overlap flag', & + & ' IOVRSW=',iovrsw,' in RSWINIT !!' + stop + endif + + if (me == 0) then + print *,' - Using AER Shortwave Radiation, Version: ',VTAGSW + + if (iswmode == 1) then + print *,' --- Delta-eddington 2-stream transfer scheme' + else if (iswmode == 2) then + print *,' --- PIFM 2-stream transfer scheme' + else if (iswmode == 3) then + print *,' --- Discrete ordinates 2-stream transfer scheme' + endif + + if (iswrgas <= 0) then + print *,' --- Rare gases absorption is NOT included in SW' + else + print *,' --- Include rare gases N2O, CH4, O2, absorptions',& + & ' in SW' + endif + + if ( isubcsw == 0 ) then + print *,' --- Using standard grid average clouds, no ', & + & 'sub-column clouds approximation applied' + elseif ( isubcsw == 1 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with a prescribed sequence of permutation seeds' + elseif ( isubcsw == 2 ) then + print *,' --- Using MCICA sub-colum clouds approximation ', & + & 'with provided input array of permutation seeds' + else + print *,' *** Error in specification of sub-column cloud ', & + & ' control flag isubcsw =',isubcsw,' !!' + stop + endif + endif + +! --- ... check cloud flags for consistency + + if ((icldflg == 0 .and. iswcliq /= 0) .or. & + & (icldflg == 1 .and. iswcliq == 0)) then + print *,' *** Model cloud scheme inconsistent with SW', & + & ' radiation cloud radiative property setup !!' + stop + endif + +! --- ... setup constant factors for heating rate +! the 1.0e-2 is to convert pressure from mb to N/m**2 + + if (iswrate == 1) then +! heatfac = 8.4391 +! heatfac = con_g * 86400. * 1.0e-2 / con_cp ! (in k/day) + heatfac = con_g * 864.0 / con_cp ! (in k/day) + else + heatfac = con_g * 1.0e-2 / con_cp ! (in k/second) + endif + +! --- ... define exponential lookup tables for transmittance. tau is +! computed as a function of the tau transition function, and +! transmittance is calculated as a function of tau. all tables +! are computed at intervals of 0.0001. the inverse of the +! constant used in the Pade approximation to the tau transition +! function is set to bpade. + + exp_tbl(0) = 1.0 + exp_tbl(NTBMX) = expeps + + do i = 1, NTBMX-1 + tfn = float(i) / float(NTBMX-i) + tau = bpade * tfn + exp_tbl(i) = exp( -tau ) + enddo + + return +!................................... + end subroutine rswinit +!----------------------------------- + +!> This subroutine computes the cloud optical properties for each +!! cloudy layer and g-point interval. +!!\param cfrac layer cloud fraction +!!\n for physparam::iswcliq > 0 (prognostic cloud scheme) - - - +!!\param cliqp layer in-cloud liq water path (\f$g/m^2\f$) +!!\param reliq mean eff radius for liq cloud (micron) +!!\param cicep layer in-cloud ice water path (\f$g/m^2\f$) +!!\param reice mean eff radius for ice cloud (micron) +!!\param cdat1 layer rain drop water path (\f$g/m^2\f$) +!!\param cdat2 effective radius for rain drop (micron) +!!\param cdat3 layer snow flake water path(\f$g/m^2\f$) +!!\param cdat4 mean eff radius for snow flake(micron) +!!\n for physparam::iswcliq = 0 (diagnostic cloud scheme) - - - +!!\param cliqp not used +!!\param cicep not used +!!\param reliq not used +!!\param reice not used +!!\param cdat1 layer cloud optical depth +!!\param cdat2 layer cloud single scattering albedo +!!\param cdat3 layer cloud asymmetry factor +!!\param cdat4 optional use +!!\param cf1 effective total cloud cover at surface +!!\param nlay vertical layer number +!!\param ipseed permutation seed for generating random numbers +!! (isubcsw>0) +!!\param taucw cloud optical depth, w/o delta scaled +!!\param ssacw weighted cloud single scattering albedo +!! (ssa = ssacw / taucw) +!!\param asycw weighted cloud asymmetry factor +!! (asy = asycw / ssacw) +!!\param cldfrc cloud fraction of grid mean value +!!\param cldfmc cloud fraction for each sub-column +!!\section General_cldprop General Algorithm +!> @{ +!----------------------------------- + subroutine cldprop & + & ( cfrac,cliqp,reliq,cicep,reice,cdat1,cdat2,cdat3,cdat4, & ! --- inputs + & cf1, nlay, ipseed, & + & taucw, ssacw, asycw, cldfrc, cldfmc & ! --- output + & ) + +! =================== program usage description =================== ! +! ! +! Purpose: Compute the cloud optical properties for each cloudy layer ! +! and g-point interval. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! cfrac - real, layer cloud fraction nlay ! +! ..... for iswcliq > 0 (prognostic cloud sckeme) - - - ! +! cliqp - real, layer in-cloud liq water path (g/m**2) nlay ! +! reliq - real, mean eff radius for liq cloud (micron) nlay ! +! cicep - real, layer in-cloud ice water path (g/m**2) nlay ! +! reice - real, mean eff radius for ice cloud (micron) nlay ! +! cdat1 - real, layer rain drop water path (g/m**2) nlay ! +! cdat2 - real, effective radius for rain drop (micron) nlay ! +! cdat3 - real, layer snow flake water path(g/m**2) nlay ! +! cdat4 - real, mean eff radius for snow flake(micron) nlay ! +! ..... for iswcliq = 0 (diagnostic cloud sckeme) - - - ! +! cdat1 - real, layer cloud optical depth nlay ! +! cdat2 - real, layer cloud single scattering albedo nlay ! +! cdat3 - real, layer cloud asymmetry factor nlay ! +! cdat4 - real, optional use nlay ! +! cliqp - real, not used nlay ! +! cicep - real, not used nlay ! +! reliq - real, not used nlay ! +! reice - real, not used nlay ! +! ! +! cf1 - real, effective total cloud cover at surface 1 ! +! nlay - integer, vertical layer number 1 ! +! ipseed- permutation seed for generating random numbers (isubcsw>0) ! +! ! +! outputs: ! +! taucw - real, cloud optical depth, w/o delta scaled nlay*nbdsw ! +! ssacw - real, weighted cloud single scattering albedo nlay*nbdsw ! +! (ssa = ssacw / taucw) ! +! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! +! (asy = asycw / ssacw) ! +! cldfrc - real, cloud fraction of grid mean value nlay ! +! cldfmc - real, cloud fraction for each sub-column nlay*ngptsw! +! ! +! ! +! explanation of the method for each value of iswcliq, and iswcice. ! +! set up in module "physparam" ! +! ! +! iswcliq=0 : input cloud optical property (tau, ssa, asy). ! +! (used for diagnostic cloud method) ! +! iswcliq>0 : input cloud liq/ice path and effective radius, also ! +! require the user of 'iswcice' to specify the method ! +! used to compute aborption due to water/ice parts. ! +! ................................................................... ! +! ! +! iswcliq=1 : liquid water cloud optical properties are computed ! +! as in hu and stamnes (1993), j. clim., 6, 728-742. ! +! ! +! iswcice used only when iswcliq > 0 ! +! the cloud ice path (g/m2) and ice effective radius ! +! (microns) are inputs. ! +! iswcice=1 : ice cloud optical properties are computed as in ! +! ebert and curry (1992), jgr, 97, 3831-3836. ! +! iswcice=2 : ice cloud optical properties are computed as in ! +! streamer v3.0 (2001), key, streamer user's guide, ! +! cooperative institude for meteorological studies,95pp! +! iswcice=3 : ice cloud optical properties are computed as in ! +! fu (1996), j. clim., 9. ! +! ! +! other cloud control module variables: ! +! isubcsw =0: standard cloud scheme, no sub-col cloud approximation ! +! >0: mcica sub-col cloud scheme using ipseed as permutation! +! seed for generating rundom numbers ! +! ! +! ====================== end of description block ================= ! +! + use module_radsw_cldprtb + +! --- inputs: + integer, intent(in) :: nlay, ipseed + real (kind=kind_phys), intent(in) :: cf1 + + real (kind=kind_phys), dimension(nlay), intent(in) :: cliqp, & + & reliq, cicep, reice, cdat1, cdat2, cdat3, cdat4, cfrac + +! --- outputs: + real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & + & cldfmc + real (kind=kind_phys), dimension(nlay,nbdsw), intent(out) :: & + & taucw, ssacw, asycw + real (kind=kind_phys), dimension(nlay), intent(out) :: cldfrc + +! --- locals: + real (kind=kind_phys), dimension(nblow:nbhgh) :: tauliq, tauice, & + & ssaliq, ssaice, ssaran, ssasnw, asyliq, asyice, & + & asyran, asysnw + real (kind=kind_phys), dimension(nlay) :: cldf + + real (kind=kind_phys) :: dgeice, factor, fint, tauran, tausnw, & + & cldliq, refliq, cldice, refice, cldran, cldsnw, refsnw, & + & extcoliq, ssacoliq, asycoliq, extcoice, ssacoice, asycoice,& + & dgesnw + + logical :: lcloudy(nlay,ngptsw) + integer :: ia, ib, ig, jb, k, index + +! +!===> ... begin here +! + do ib = 1, nbdsw + do k = 1, nlay + taucw (k,ib) = f_zero + ssacw (k,ib) = f_one + asycw (k,ib) = f_zero + enddo + enddo + +!> -# Compute cloud radiative properties for a cloudy column. + + lab_if_iswcliq : if (iswcliq > 0) then + + lab_do_k : do k = 1, nlay + lab_if_cld : if (cfrac(k) > ftiny) then + +!> - Compute optical properties for rain and snow. +!!\n For rain: tauran/ssaran/asyran +!!\n For snow: tausnw/ssasnw/asysnw +!> - Calculation of absorption coefficients due to water clouds +!!\n For water clouds: tauliq/ssaliq/asyliq +!> - Calculation of absorption coefficients due to ice clouds +!!\n For ice clouds: tauice/ssaice/asyice +!> - For Prognostic cloud scheme: sum up the cloud optical property: +!!\n \f$ taucw=tauliq+tauice+tauran+tausnw \f$ +!!\n \f$ ssacw=ssaliq+ssaice+ssaran+ssasnw \f$ +!!\n \f$ asycw=asyliq+asyice+asyran+asysnw \f$ + + cldran = cdat1(k) +! refran = cdat2(k) + cldsnw = cdat3(k) + refsnw = cdat4(k) + dgesnw = 1.0315 * refsnw ! for fu's snow formula + + tauran = cldran * a0r + +! --- if use fu's formula it needs to be normalized by snow/ice density +! !not use snow density = 0.1 g/cm**3 = 0.1 g/(mu * m**2) +! use ice density = 0.9167 g/cm**3 = 0.9167 g/(mu * m**2) +! 1/0.9167 = 1.09087 +! factor 1.5396=8/(3*sqrt(3)) converts reff to generalized ice particle size +! use newer factor value 1.0315 + if (cldsnw>f_zero .and. refsnw>10.0_kind_phys) then +! tausnw = cldsnw * (a0s + a1s/refsnw) + tausnw = cldsnw*1.09087*(a0s + a1s/dgesnw) ! fu's formula + else + tausnw = f_zero + endif + + do ib = nblow, nbhgh + ssaran(ib) = tauran * (f_one - b0r(ib)) + ssasnw(ib) = tausnw * (f_one - (b0s(ib)+b1s(ib)*dgesnw)) + asyran(ib) = ssaran(ib) * c0r(ib) + asysnw(ib) = ssasnw(ib) * c0s(ib) + enddo + + cldliq = cliqp(k) + cldice = cicep(k) + refliq = reliq(k) + refice = reice(k) + +! --- ... calculation of absorption coefficients due to water clouds. + + if ( cldliq <= f_zero ) then + do ib = nblow, nbhgh + tauliq(ib) = f_zero + ssaliq(ib) = f_zero + asyliq(ib) = f_zero + enddo + else + if ( iswcliq == 1 ) then + factor = refliq - 1.5 + index = max( 1, min( 57, int( factor ) )) + fint = factor - float(index) + + do ib = nblow, nbhgh + extcoliq = max(f_zero, extliq1(index,ib) & + & + fint*(extliq1(index+1,ib)-extliq1(index,ib)) ) + ssacoliq = max(f_zero, min(f_one, ssaliq1(index,ib) & + & + fint*(ssaliq1(index+1,ib)-ssaliq1(index,ib)) )) + + asycoliq = max(f_zero, min(f_one, asyliq1(index,ib) & + & + fint*(asyliq1(index+1,ib)-asyliq1(index,ib)) )) +! forcoliq = asycoliq * asycoliq + + tauliq(ib) = cldliq * extcoliq + ssaliq(ib) = tauliq(ib) * ssacoliq + asyliq(ib) = ssaliq(ib) * asycoliq + enddo + endif ! end if_iswcliq_block + endif ! end if_cldliq_block + +! --- ... calculation of absorption coefficients due to ice clouds. + + if ( cldice <= f_zero ) then + do ib = nblow, nbhgh + tauice(ib) = f_zero + ssaice(ib) = f_zero + asyice(ib) = f_zero + enddo + else + +! --- ... ebert and curry approach for all particle sizes though somewhat +! unjustified for large ice particles + + if ( iswcice == 1 ) then + refice = min(130.0_kind_phys,max(13.0_kind_phys,refice)) + + do ib = nblow, nbhgh + ia = idxebc(ib) ! eb_&_c band index for ice cloud coeff + + extcoice = max(f_zero, abari(ia)+bbari(ia)/refice ) + ssacoice = max(f_zero, min(f_one, & + & f_one-cbari(ia)-dbari(ia)*refice )) + asycoice = max(f_zero, min(f_one, & + & ebari(ia)+fbari(ia)*refice )) +! forcoice = asycoice * asycoice + + tauice(ib) = cldice * extcoice + ssaice(ib) = tauice(ib) * ssacoice + asyice(ib) = ssaice(ib) * asycoice + enddo + +! --- ... streamer approach for ice effective radius between 5.0 and 131.0 microns + + elseif ( iswcice == 2 ) then + refice = min(131.0_kind_phys,max(5.0_kind_phys,refice)) + + factor = (refice - 2.0) / 3.0 + index = max( 1, min( 42, int( factor ) )) + fint = factor - float(index) + + do ib = nblow, nbhgh + extcoice = max(f_zero, extice2(index,ib) & + & + fint*(extice2(index+1,ib)-extice2(index,ib)) ) + ssacoice = max(f_zero, min(f_one, ssaice2(index,ib) & + & + fint*(ssaice2(index+1,ib)-ssaice2(index,ib)) )) + asycoice = max(f_zero, min(f_one, asyice2(index,ib) & + & + fint*(asyice2(index+1,ib)-asyice2(index,ib)) )) +! forcoice = asycoice * asycoice + + tauice(ib) = cldice * extcoice + ssaice(ib) = tauice(ib) * ssacoice + asyice(ib) = ssaice(ib) * asycoice + enddo + +! --- ... fu's approach for ice effective radius between 4.8 and 135 microns +! (generalized effective size from 5 to 140 microns) + + elseif ( iswcice == 3 ) then + dgeice = max( 5.0, min( 140.0, 1.0315*refice )) + + factor = (dgeice - 2.0) / 3.0 + index = max( 1, min( 45, int( factor ) )) + fint = factor - float(index) + + do ib = nblow, nbhgh + extcoice = max(f_zero, extice3(index,ib) & + & + fint*(extice3(index+1,ib)-extice3(index,ib)) ) + ssacoice = max(f_zero, min(f_one, ssaice3(index,ib) & + & + fint*(ssaice3(index+1,ib)-ssaice3(index,ib)) )) + asycoice = max(f_zero, min(f_one, asyice3(index,ib) & + & + fint*(asyice3(index+1,ib)-asyice3(index,ib)) )) +! fdelta = max(f_zero, min(f_one, fdlice3(index,ib) & +! & + fint*(fdlice3(index+1,ib)-fdlice3(index,ib)) )) +! forcoice = min( asycoice, fdelta+0.5/ssacoice ) ! see fu 1996 p. 2067 + + tauice(ib) = cldice * extcoice + ssaice(ib) = tauice(ib) * ssacoice + asyice(ib) = ssaice(ib) * asycoice + enddo + + endif ! end if_iswcice_block + endif ! end if_cldice_block + + do ib = 1, nbdsw + jb = nblow + ib - 1 + taucw(k,ib) = tauliq(jb)+tauice(jb)+tauran+tausnw + ssacw(k,ib) = ssaliq(jb)+ssaice(jb)+ssaran(jb)+ssasnw(jb) + asycw(k,ib) = asyliq(jb)+asyice(jb)+asyran(jb)+asysnw(jb) + enddo + + endif lab_if_cld + enddo lab_do_k + + else lab_if_iswcliq + + do k = 1, nlay + if (cfrac(k) > ftiny) then + do ib = 1, nbdsw + taucw(k,ib) = cdat1(k) + ssacw(k,ib) = cdat1(k) * cdat2(k) + asycw(k,ib) = ssacw(k,ib) * cdat3(k) + enddo + endif + enddo + + endif lab_if_iswcliq + +!> -# if physparam::isubcsw > 0, call mcica_subcol() to distribute +!! cloud properties to each g-point. + + if ( isubcsw > 0 ) then ! mcica sub-col clouds approx + + cldf(:) = cfrac(:) + where (cldf(:) < ftiny) + cldf(:) = f_zero + end where + +! --- ... call sub-column cloud generator + + call mcica_subcol & +! --- inputs: + & ( cldf, nlay, ipseed, & +! --- outputs: + & lcloudy & + & ) + + do ig = 1, ngptsw + do k = 1, nlay + if ( lcloudy(k,ig) ) then + cldfmc(k,ig) = f_one + else + cldfmc(k,ig) = f_zero + endif + enddo + enddo + + else ! non-mcica, normalize cloud + + do k = 1, nlay + cldfrc(k) = cfrac(k) / cf1 + enddo + endif ! end if_isubcsw_block + + return +!................................... + end subroutine cldprop +!----------------------------------- +!> @} + + +!> This subroutine computes the sub-colum cloud profile flag array. +!!\param cldf layer cloud fraction +!!\param nlay number of model vertical layers +!!\param ipseed permute seed for random num generator +!!\param lcloudy sub-colum cloud profile flag array +! ---------------------------------- + subroutine mcica_subcol & + & ( cldf, nlay, ipseed, & ! --- inputs + & lcloudy & ! --- outputs + & ) + +! ==================== defination of variables ==================== ! +! ! +! input variables: size ! +! cldf - real, layer cloud fraction nlay ! +! nlay - integer, number of model vertical layers 1 ! +! ipseed - integer, permute seed for random num generator 1 ! +! ** note : if the cloud generator is called multiple times, need ! +! to permute the seed between each call; if between calls ! +! for lw and sw, use values differ by the number of g-pts. ! +! ! +! output variables: ! +! lcloudy - logical, sub-colum cloud profile flag array nlay*ngptsw! +! ! +! other control flags from module variables: ! +! iovrsw : control flag for cloud overlapping method ! +! =0:random; =1:maximum/random; =2:maximum ! +! ! +! ! +! ===================== end of definitions ==================== ! + + implicit none + +! --- inputs: + integer, intent(in) :: nlay, ipseed + + real (kind=kind_phys), dimension(nlay), intent(in) :: cldf + +! --- outputs: + logical, dimension(nlay,ngptsw), intent(out):: lcloudy + +! --- locals: + real (kind=kind_phys) :: cdfunc(nlay,ngptsw), tem1, & + & rand2d(nlay*ngptsw), rand1d(ngptsw) + + type (random_stat) :: stat ! for thread safe random generator + + integer :: k, n, k1 +! +!===> ... begin here +! +! --- ... advance randum number generator by ipseed values + + call random_setseed & +! --- inputs: + & ( ipseed, & +! --- outputs: + & stat & + & ) + +! --- ... sub-column set up according to overlapping assumption + + select case ( iovrsw ) + + case( 0 ) ! random overlap, pick a random value at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(k,n) = rand2d(k1) + enddo + enddo + + case( 1 ) ! max-ran overlap + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand2d, stat ) + + k1 = 0 + do n = 1, ngptsw + do k = 1, nlay + k1 = k1 + 1 + cdfunc(k,n) = rand2d(k1) + enddo + enddo + +! --- first pick a random number for bottom/top layer. +! then walk up the column: (aer's code) +! if layer below is cloudy, use the same rand num in the layer below +! if layer below is clear, use a new random number + +! --- from bottom up + do k = 2, nlay + k1 = k - 1 + tem1 = f_one - cldf(k1) + + do n = 1, ngptsw + if ( cdfunc(k1,n) > tem1 ) then + cdfunc(k,n) = cdfunc(k1,n) + else + cdfunc(k,n) = cdfunc(k,n) * tem1 + endif + enddo + enddo + +! --- then walk down the column: (if use original author's method) +! if layer above is cloudy, use the same rand num in the layer above +! if layer above is clear, use a new random number + +! --- from top down +! do k = nlay-1, 1, -1 +! k1 = k + 1 +! tem1 = f_one - cldf(k1) + +! do n = 1, ngptsw +! if ( cdfunc(k1,n) > tem1 ) then +! cdfunc(k,n) = cdfunc(k1,n) +! else +! cdfunc(k,n) = cdfunc(k,n) * tem1 +! endif +! enddo +! enddo + + case( 2 ) ! maximum overlap, pick same random numebr at every level + + call random_number & +! --- inputs: ( none ) +! --- outputs: + & ( rand1d, stat ) + + do n = 1, ngptsw + tem1 = rand1d(n) + + do k = 1, nlay + cdfunc(k,n) = tem1 + enddo + enddo + + end select + +! --- ... generate subcolumns for homogeneous clouds + + do k = 1, nlay + tem1 = f_one - cldf(k) + + do n = 1, ngptsw + lcloudy(k,n) = cdfunc(k,n) >= tem1 + enddo + enddo + + return +! .................................. + end subroutine mcica_subcol +! ---------------------------------- + +!> This subroutine computes various coefficients needed in radiative +!! transfer calculation. +!!\param pavel layer pressure (mb) +!!\param tavel layer temperature (k) +!!\param h2ovmr layer w.v. volumn mixing ratio (kg/kg) +!!\param nlay total number of vertical layers +!!\param nlp1 total number of vertical levels +!!\param laytrop tropopause layer index (unitless) +!!\param jp indices of lower reference pressure +!!\param jt,jt1 indices of lower reference temperatures at +!! levels of jp and jp+1 +!!\param facij factors mltiply the reference ks,i,j=0/1 for +!! lower/higher of the 2 appropriate temperature +!! and altitudes. +!!\param selffac scale factor for w. v. self-continuum equals +!! (w.v. density)/(atmospheric density at 296k +!! and 1013 mb) +!!\param seffrac factor for temperature interpolation of +!! reference w.v. self-continuum data +!!\param indself index of lower ref temp for selffac +!!\param forfac scale factor for w. v. foreign-continuum +!!\param forfrac factor for temperature interpolation of +!! reference w.v. foreign-continuum data +!!\param indfor index of lower ref temp for forfac +! ---------------------------------- + subroutine setcoef & + & ( pavel,tavel,h2ovmr, nlay,nlp1, & ! --- inputs + & laytrop,jp,jt,jt1,fac00,fac01,fac10,fac11, & ! --- outputs + & selffac,selffrac,indself,forfac,forfrac,indfor & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: compute various coefficients needed in radiative transfer ! +! calculations. ! +! ! +! subprograms called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: -size- ! +! pavel - real, layer pressures (mb) nlay ! +! tavel - real, layer temperatures (k) nlay ! +! h2ovmr - real, layer w.v. volum mixing ratio (kg/kg) nlay ! +! nlay/nlp1 - integer, total number of vertical layers, levels 1 ! +! ! +! outputs: ! +! laytrop - integer, tropopause layer index (unitless) 1 ! +! jp - real, indices of lower reference pressure nlay ! +! jt, jt1 - real, indices of lower reference temperatures nlay ! +! at levels of jp and jp+1 ! +! facij - real, factors multiply the reference ks, nlay ! +! i,j=0/1 for lower/higher of the 2 appropriate ! +! temperatures and altitudes. ! +! selffac - real, scale factor for w. v. self-continuum nlay ! +! equals (w. v. density)/(atmospheric density ! +! at 296k and 1013 mb) ! +! selffrac - real, factor for temperature interpolation of nlay ! +! reference w. v. self-continuum data ! +! indself - integer, index of lower ref temp for selffac nlay ! +! forfac - real, scale factor for w. v. foreign-continuum nlay ! +! forfrac - real, factor for temperature interpolation of nlay ! +! reference w.v. foreign-continuum data ! +! indfor - integer, index of lower ref temp for forfac nlay ! +! ! +! ====================== end of definitions =================== ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(:), intent(in) :: pavel, tavel, & + & h2ovmr + +! --- outputs: + integer, dimension(nlay), intent(out) :: indself, indfor, & + & jp, jt, jt1 + integer, intent(out) :: laytrop + + real (kind=kind_phys), dimension(nlay), intent(out) :: fac00, & + & fac01, fac10, fac11, selffac, selffrac, forfac, forfrac + +! --- locals: + real (kind=kind_phys) :: plog, fp, fp1, ft, ft1, tem1, tem2 + + integer :: i, k, jp1 +! +!===> ... begin here +! + laytrop= nlay + + do k = 1, nlay + + forfac(k) = pavel(k)*stpfac / (tavel(k)*(f_one + h2ovmr(k))) + +! --- ... find the two reference pressures on either side of the +! layer pressure. store them in jp and jp1. store in fp the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. + + plog = log(pavel(k)) + jp(k) = max(1, min(58, int(36.0 - 5.0*(plog+0.04)) )) + jp1 = jp(k) + 1 + fp = 5.0 * (preflog(jp(k)) - plog) + +! --- ... determine, for each reference pressure (jp and jp1), which +! reference temperature (these are different for each reference +! pressure) is nearest the layer temperature but does not exceed it. +! store these indices in jt and jt1, resp. store in ft (resp. ft1) +! the fraction of the way between jt (jt1) and the next highest +! reference temperature that the layer temperature falls. + + tem1 = (tavel(k) - tref(jp(k))) / 15.0 + tem2 = (tavel(k) - tref(jp1 )) / 15.0 + jt (k) = max(1, min(4, int(3.0 + tem1) )) + jt1(k) = max(1, min(4, int(3.0 + tem2) )) + ft = tem1 - float(jt (k) - 3) + ft1 = tem2 - float(jt1(k) - 3) + +! --- ... we have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). we multiply the pressure +! fraction fp with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines taugbn for band n). + + fp1 = f_one - fp + fac10(k) = fp1 * ft + fac00(k) = fp1 * (f_one - ft) + fac11(k) = fp * ft1 + fac01(k) = fp * (f_one - ft1) + +! --- ... if the pressure is less than ~100mb, perform a different +! set of species interpolations. + + if ( plog > 4.56 ) then + + laytrop = k + +! --- ... set up factors needed to separately include the water vapor +! foreign-continuum in the calculation of absorption coefficient. + + tem1 = (332.0 - tavel(k)) / 36.0 + indfor (k) = min(2, max(1, int(tem1))) + forfrac(k) = tem1 - float(indfor(k)) + +! --- ... set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + + tem2 = (tavel(k) - 188.0) / 7.2 + indself (k) = min(9, max(1, int(tem2)-7)) + selffrac(k) = tem2 - float(indself(k) + 7) + selffac (k) = h2ovmr(k) * forfac(k) + + else + +! --- ... set up factors needed to separately include the water vapor +! foreign-continuum in the calculation of absorption coefficient. + + tem1 = (tavel(k) - 188.0) / 36.0 + indfor (k) = 3 + forfrac(k) = tem1 - f_one + + indself (k) = 0 + selffrac(k) = f_zero + selffac (k) = f_zero + + endif + + enddo ! end_do_k_loop + + return +! .................................. + end subroutine setcoef +! ---------------------------------- + +!> This subroutine computes the shortwave radiative fluxes using +!! two-stream method. +!!\param ssolar incoming solar flux at top +!!\param cosz cosine solar zenith angle +!!\param sntz secant solar zenith angle +!!\param albbm surface albedo for direct beam radiation +!!\param albdf surface albedo for diffused radiation +!!\param sfluxzen spectral distribution of incoming solar flux +!!\param cldfrc layer cloud fraction +!!\param cf1 >0: cloudy sky, otherwise: clear sky +!!\param cf0 =1-cf1 +!!\param taug spectral optical depth for gases +!!\param taur optical depth for rayleigh scattering +!!\param tauae aerosols optical depth +!!\param ssaae aerosols single scattering albedo +!!\param asyae aerosols asymmetry factor +!!\param taucw weighted cloud optical depth +!!\param ssacw weighted cloud single scat albedo +!!\param asycw weighted cloud asymmetry factor +!!\param nlay,nlp1 number of layers/levels +!!\param fxupc tot sky upward flux +!!\param fxdnc tot sky downward flux +!!\param fxup0 clr sky upward flux +!!\param fxdn0 clr sky downward flux +!!\param ftoauc tot sky toa upwd flux +!!\param ftoau0 clr sky toa upwd flux +!!\param ftoadc toa downward (incoming) solar flux +!!\param fsfcuc tot sky sfc upwd flux +!!\param fsfcu0 clr sky sfc upwd flux +!!\param fsfcdc tot sky sfc dnwd flux +!!\param fsfcd0 clr sky sfc dnwd flux +!!\param sfbmc tot sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdfc tot sky sfc dnwd diff flux (nir/uv+vis) +!!\param sfbm0 clr sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdf0 clr sky sfc dnwd diff flux (nir/uv+vis) +!!\param suvbfc tot sky sfc dnwd uv-b flux +!!\param suvbf0 clr sky sfc dnwd uv-b flux +!!\section General_spcvrtc General Algorithm +!> @{ +!----------------------------------- + subroutine spcvrtc & + & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfrc, & ! --- inputs + & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & + & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: computes the shortwave radiative fluxes using two-stream ! +! method ! +! ! +! subprograms called: vrtqdr ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! ssolar - real, incoming solar flux at top 1 ! +! cosz - real, cosine solar zenith angle 1 ! +! sntz - real, secant solar zenith angle 1 ! +! albbm - real, surface albedo for direct beam radiation 2 ! +! albdf - real, surface albedo for diffused radiation 2 ! +! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! +! cldfrc - real, layer cloud fraction nlay ! +! cf1 - real, >0: cloudy sky, otherwise: clear sky 1 ! +! cf0 - real, =1-cf1 1 ! +! taug - real, spectral optical depth for gases nlay*ngptsw! +! taur - real, optical depth for rayleigh scattering nlay*ngptsw! +! tauae - real, aerosols optical depth nlay*nbdsw ! +! ssaae - real, aerosols single scattering albedo nlay*nbdsw ! +! asyae - real, aerosols asymmetry factor nlay*nbdsw ! +! taucw - real, weighted cloud optical depth nlay*nbdsw ! +! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! +! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! +! nlay,nlp1 - integer, number of layers/levels 1 ! +! ! +! output variables: ! +! fxupc - real, tot sky upward flux nlp1*nbdsw ! +! fxdnc - real, tot sky downward flux nlp1*nbdsw ! +! fxup0 - real, clr sky upward flux nlp1*nbdsw ! +! fxdn0 - real, clr sky downward flux nlp1*nbdsw ! +! ftoauc - real, tot sky toa upwd flux 1 ! +! ftoau0 - real, clr sky toa upwd flux 1 ! +! ftoadc - real, toa downward (incoming) solar flux 1 ! +! fsfcuc - real, tot sky sfc upwd flux 1 ! +! fsfcu0 - real, clr sky sfc upwd flux 1 ! +! fsfcdc - real, tot sky sfc dnwd flux 1 ! +! fsfcd0 - real, clr sky sfc dnwd flux 1 ! +! sfbmc - real, tot sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdfc - real, tot sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! sfbm0 - real, clr sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdf0 - real, clr sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! suvbfc - real, tot sky sfc dnwd uv-b flux 1 ! +! suvbf0 - real, clr sky sfc dnwd uv-b flux 1 ! +! ! +! internal variables: ! +! zrefb - real, direct beam reflectivity for clear/cloudy nlp1 ! +! zrefd - real, diffuse reflectivity for clear/cloudy nlp1 ! +! ztrab - real, direct beam transmissivity for clear/cloudy nlp1 ! +! ztrad - real, diffuse transmissivity for clear/cloudy nlp1 ! +! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! +! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! +! ! +! control parameters in module "physparam" ! +! iswmode - control flag for 2-stream transfer schemes ! +! = 1 delta-eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! method: ! +! ------- ! +! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. ! +! kmodts = 1 eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! modifications: ! +! -------------- ! +! original: h. barker ! +! revision: merge with rrtmg_sw: j.-j.morcrette, ecmwf, feb 2003 ! +! revision: add adjustment for earth/sun distance:mjiacono,aer,oct2003! +! revision: bug fix for use of palbp and palbd: mjiacono, aer, nov2003! +! revision: bug fix to apply delta scaling to clear sky: aer, dec2004 ! +! revision: code modified so that delta scaling is not done in cloudy ! +! profiles if routine cldprop is used; delta scaling can be ! +! applied by swithcing code below if cldprop is not used to ! +! get cloud properties. aer, jan 2005 ! +! revision: uniform formatting for rrtmg: mjiacono, aer, jul 2006 ! +! revision: use exponential lookup table for transmittance: mjiacono, ! +! aer, aug 2007 ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- constant parameters: + real (kind=kind_phys), parameter :: zcrit = 0.9999995 ! thresold for conservative scattering + real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) + real (kind=kind_phys), parameter :: od_lo = 0.06 + real (kind=kind_phys), parameter :: eps1 = 1.0e-8 + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & + & taug, taur + real (kind=kind_phys), dimension(nlay,nbdsw), intent(in) :: & + & taucw, ssacw, asycw, tauae, ssaae, asyae + + real (kind=kind_phys), dimension(ngptsw), intent(in) :: sfluxzen + real (kind=kind_phys), dimension(nlay), intent(in) :: cldfrc + + real (kind=kind_phys), dimension(2), intent(in) :: albbm, albdf + + real (kind=kind_phys), intent(in) :: cosz, sntz, cf1, cf0, ssolar + +! --- outputs: + real (kind=kind_phys), dimension(nlp1,nbdsw), intent(out) :: & + & fxupc, fxdnc, fxup0, fxdn0 + + real (kind=kind_phys), dimension(2), intent(out) :: sfbmc, sfdfc, & + & sfbm0, sfdf0 + + real (kind=kind_phys), intent(out) :: suvbfc, suvbf0, ftoadc, & + & ftoauc, ftoau0, fsfcuc, fsfcu0, fsfcdc, fsfcd0 + +! --- locals: + real (kind=kind_phys), dimension(nlay) :: ztaus, zssas, zasys, & + & zldbt0 + + real (kind=kind_phys), dimension(nlp1) :: zrefb, zrefd, ztrab, & + & ztrad, ztdbt, zldbt, zfu, zfd + + real (kind=kind_phys) :: ztau1, zssa1, zasy1, ztau0, zssa0, & + & zasy0, zasy3, zssaw, zasyw, zgam1, zgam2, zgam3, zgam4, & + & zc0, zc1, za1, za2, zb1, zb2, zrk, zrk2, zrp, zrp1, zrm1, & + & zrpp, zrkg1, zrkg3, zrkg4, zexp1, zexm1, zexp2, zexm2, & + & zexp3, zexp4, zden1, ze1r45, ftind, zsolar, zrefb1, & + & zrefd1, ztrab1, ztrad1, ztdbt0, zr1, zr2, zr3, zr4, zr5, & + & zt1, zt2, zt3, zf1, zf2, zrpp1 + + integer :: ib, ibd, jb, jg, k, kp, itind +! +!===> ... begin here + +!> -# Initialize output fluxes. + do ib = 1, nbdsw + do k = 1, nlp1 + fxdnc(k,ib) = f_zero + fxupc(k,ib) = f_zero + fxdn0(k,ib) = f_zero + fxup0(k,ib) = f_zero + enddo + enddo + + ftoadc = f_zero + ftoauc = f_zero + ftoau0 = f_zero + fsfcuc = f_zero + fsfcu0 = f_zero + fsfcdc = f_zero + fsfcd0 = f_zero + +!! --- ... uv-b surface downward fluxes + suvbfc = f_zero + suvbf0 = f_zero + +!! --- ... output surface flux components + sfbmc(1) = f_zero + sfbmc(2) = f_zero + sfdfc(1) = f_zero + sfdfc(2) = f_zero + sfbm0(1) = f_zero + sfbm0(2) = f_zero + sfdf0(1) = f_zero + sfdf0(2) = f_zero + +! --- ... loop over all g-points in each band + + lab_do_jg : do jg = 1, ngptsw + + jb = NGB(jg) + ib = jb + 1 - nblow + ibd = idxsfc(jb) + + zsolar = ssolar * sfluxzen(jg) + +! --- ... set up toa direct beam and surface values (beam and diff) + + ztdbt(nlp1) = f_one + ztdbt0 = f_one + + zldbt(1) = f_zero + if (ibd /= 0) then + zrefb(1) = albbm(ibd) + zrefd(1) = albdf(ibd) + else + zrefb(1) = 0.5 * (albbm(1) + albbm(2)) + zrefd(1) = 0.5 * (albdf(1) + albdf(2)) + endif + ztrab(1) = f_zero + ztrad(1) = f_zero + +!> -# Compute clear-sky optical parameters, layer reflectance and +!! transmittance. +!! - Set up toa direct beam and surface values (beam and diff) +!! - Delta scaling for clear-sky condition +!! - General two-stream expressions for physparam::iswmode +!! - Compute homogeneous reflectance and transmittance for both +!! conservative and non-conservative scattering +!! - Pre-delta-scaling clear and cloudy direct beam transmittance +!! - Call swflux() to compute the upward and downward radiation +!! fluxes + + do k = nlay, 1, -1 + kp = k + 1 + + ztau0 = max( ftiny, taur(k,jg)+taug(k,jg)+tauae(k,ib) ) + zssa0 = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) + zasy0 = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) + zssaw = min( oneminus, zssa0 / ztau0 ) + zasyw = zasy0 / max( ftiny, zssa0 ) + +! --- ... saving clear-sky quantities for later total-sky usage + ztaus(k) = ztau0 + zssas(k) = zssa0 + zasys(k) = zasy0 + +! --- ... delta scaling for clear-sky condition + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) ! this line is replaced by the next + zasy1 = zasyw / (f_one + zasyw) ! to reduce truncation error + zasy3 = 0.75 * zasy1 + +! --- ... general two-stream expressions + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + +! --- ... compute homogeneous reflectance and transmittance + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp) )) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2/(f_one + za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one-zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( sntz*ztau1, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if (ze1r45>=-eps1 .and. ze1r45<=eps1) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1 - zr2*zexm1 - zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one & + & - (zt1*zexp1 - zt2*zexm1 - zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +! --- ... direct beam transmittance. use exponential lookup table +! for transmittance, or expansion of exponential for low +! optical depth + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + ztdbt(k) = zexp3 * ztdbt(kp) + zldbt(kp) = zexp3 + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + zldbt0(k) = zexp4 + ztdbt0 = zexp4 * ztdbt0 + enddo ! end do_k_loop + + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +! --- ... compute upward and downward fluxes at levels + do k = 1, nlp1 + fxup0(k,ib) = fxup0(k,ib) + zsolar*zfu(k) + fxdn0(k,ib) = fxdn0(k,ib) + zsolar*zfd(k) + enddo + +!! --- ... surface downward beam/diffused flux components + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbm0(ibd) = sfbm0(ibd) + zb1 + sfdf0(ibd) = sfdf0(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbm0(1) = sfbm0(1) + zf1 + sfdf0(1) = sfdf0(1) + zf2 + sfbm0(2) = sfbm0(2) + zf1 + sfdf0(2) = sfdf0(2) + zf2 + endif +! sfbm0(ibd) = sfbm0(ibd) + zsolar*ztdbt0 +! sfdf0(ibd) = sfdf0(ibd) + zsolar*(zfd(1) - ztdbt0) + +!> -# Compute total sky optical parameters, layer reflectance and +!! transmittance. +!! - Set up toa direct beam and surface values (beam and diff) +!! - Delta scaling for total-sky condition +!! - General two-stream expressions for physparam::iswmode +!! - Compute homogeneous reflectance and transmittance for +!! conservative scattering and non-conservative scattering +!! - Pre-delta-scaling clear and cloudy direct beam transmittance +!! - Call swflux() to compute the upward and downward radiation fluxes + + if ( cf1 > eps ) then + +! --- ... set up toa direct beam and surface values (beam and diff) + ztdbt0 = f_one + zldbt(1) = f_zero + + do k = nlay, 1, -1 + kp = k + 1 + zc0 = f_one - cldfrc(k) + zc1 = cldfrc(k) + if ( zc1 > ftiny ) then ! it is a cloudy-layer + + ztau0 = ztaus(k) + taucw(k,ib) + zssa0 = zssas(k) + ssacw(k,ib) + zasy0 = zasys(k) + asycw(k,ib) + zssaw = min(oneminus, zssa0 / ztau0) + zasyw = zasy0 / max(ftiny, zssa0) + +! --- ... delta scaling for total-sky condition + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) + zasy1 = zasyw / (f_one + zasyw) + zasy3 = 0.75 * zasy1 + +! --- ... general two-stream expressions + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + + zrefb1 = zrefb(kp) + zrefd1 = zrefd(kp) + ztrab1 = ztrab(kp) + ztrad1 = ztrad(kp) + +! --- ... compute homogeneous reflectance and transmittance + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp))) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2 / (f_one+za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one - zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( ztau1*sntz, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one - & + & (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +! --- ... combine clear and cloudy contributions for total sky +! and calculate direct beam transmittances + + zrefb(kp) = zc0*zrefb1 + zc1*zrefb(kp) + zrefd(kp) = zc0*zrefd1 + zc1*zrefd(kp) + ztrab(kp) = zc0*ztrab1 + zc1*ztrab(kp) + ztrad(kp) = zc0*ztrad1 + zc1*ztrad(kp) + +! --- ... direct beam transmittance. use exponential lookup table +! for transmittance, or expansion of exponential for low +! optical depth + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + zldbt(kp) = zc0*zldbt(kp) + zc1*zexp3 + ztdbt(k) = zldbt(kp) * ztdbt(kp) + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + ztdbt0 = (zc0*zldbt0(k) + zc1*zexp4) * ztdbt0 + + else ! if_zc1_block --- it is a clear layer + +! --- ... direct beam transmittance + ztdbt(k) = zldbt(kp) * ztdbt(kp) + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance + ztdbt0 = zldbt0(k) * ztdbt0 + + endif ! end if_zc1_block + enddo ! end do_k_loop + +! --- ... perform vertical quadrature + + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +! --- ... compute upward and downward fluxes at levels + do k = 1, nlp1 + fxupc(k,ib) = fxupc(k,ib) + zsolar*zfu(k) + fxdnc(k,ib) = fxdnc(k,ib) + zsolar*zfd(k) + enddo + +!> -# Process and save outputs. +! --- ... surface downward beam/diffused flux components + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbmc(ibd) = sfbmc(ibd) + zb1 + sfdfc(ibd) = sfdfc(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbmc(1) = sfbmc(1) + zf1 + sfdfc(1) = sfdfc(1) + zf2 + sfbmc(2) = sfbmc(2) + zf1 + sfdfc(2) = sfdfc(2) + zf2 + endif +! sfbmc(ibd) = sfbmc(ibd) + zsolar*ztdbt0 +! sfdfc(ibd) = sfdfc(ibd) + zsolar*(zfd(1) - ztdbt0) + + endif ! end if_cf1_block + + enddo lab_do_jg + +! --- ... end of g-point loop + + do ib = 1, nbdsw + ftoadc = ftoadc + fxdn0(nlp1,ib) + ftoau0 = ftoau0 + fxup0(nlp1,ib) + fsfcu0 = fsfcu0 + fxup0(1,ib) + fsfcd0 = fsfcd0 + fxdn0(1,ib) + enddo + +!! --- ... uv-b surface downward flux + ibd = nuvb - nblow + 1 + suvbf0 = fxdn0(1,ibd) + + if ( cf1 <= eps ) then ! clear column, set total-sky=clear-sky fluxes + do ib = 1, nbdsw + do k = 1, nlp1 + fxupc(k,ib) = fxup0(k,ib) + fxdnc(k,ib) = fxdn0(k,ib) + enddo + enddo + + ftoauc = ftoau0 + fsfcuc = fsfcu0 + fsfcdc = fsfcd0 + +!! --- ... surface downward beam/diffused flux components + sfbmc(1) = sfbm0(1) + sfdfc(1) = sfdf0(1) + sfbmc(2) = sfbm0(2) + sfdfc(2) = sfdf0(2) + +!! --- ... uv-b surface downward flux + suvbfc = suvbf0 + else ! cloudy column, compute total-sky fluxes + do ib = 1, nbdsw + do k = 1, nlp1 + fxupc(k,ib) = cf1*fxupc(k,ib) + cf0*fxup0(k,ib) + fxdnc(k,ib) = cf1*fxdnc(k,ib) + cf0*fxdn0(k,ib) + enddo + enddo + + do ib = 1, nbdsw + ftoauc = ftoauc + fxupc(nlp1,ib) + fsfcuc = fsfcuc + fxupc(1,ib) + fsfcdc = fsfcdc + fxdnc(1,ib) + enddo + +!! --- ... uv-b surface downward flux + suvbfc = fxdnc(1,ibd) + +!! --- ... surface downward beam/diffused flux components + sfbmc(1) = cf1*sfbmc(1) + cf0*sfbm0(1) + sfbmc(2) = cf1*sfbmc(2) + cf0*sfbm0(2) + sfdfc(1) = cf1*sfdfc(1) + cf0*sfdf0(1) + sfdfc(2) = cf1*sfdfc(2) + cf0*sfdf0(2) + endif ! end if_cf1_block + + return +!................................... + end subroutine spcvrtc +!----------------------------------- +!> @} + +!> This subroutine computes the shortwave radiative fluxes using +!! two-stream method of h. barder and mcica,the monte-carlo independent +!! column approximation, for the representation of sub-grid cloud +!! variability (i.e. cloud overlap). +!!\param ssolar incoming solar flux at top +!!\param cosz cosine solar zenith angle +!!\param sntz secant solar zenith angle +!!\param albbm surface albedo for direct beam radiation +!!\param albdf surface albedo for diffused radiation +!!\param sfluxzen spectral distribution of incoming solar flux +!!\param cldfmc layer cloud fraction for g-point +!!\param cf1 >0: cloudy sky, otherwise: clear sky +!!\param cf0 =1-cf1 +!!\param taug spectral optical depth for gases +!!\param taur optical depth for rayleigh scattering +!!\param tauae aerosols optical depth +!!\param ssaae aerosols single scattering albedo +!!\param asyae aerosols asymmetry factor +!!\param taucw weighted cloud optical depth +!!\param ssacw weighted cloud single scat albedo +!!\param asycw weighted cloud asymmetry factor +!!\param nlay,nlp1 number of layers/levels +!!\param fxupc tot sky upward flux +!!\param fxdnc tot sky downward flux +!!\param fxup0 clr sky upward flux +!!\param fxdn0 clr sky downward flux +!!\param ftoauc tot sky toa upwd flux +!!\param ftoau0 clr sky toa upwd flux +!!\param ftoadc toa downward (incoming) solar flux +!!\param fsfcuc tot sky sfc upwd flux +!!\param fsfcu0 clr sky sfc upwd flux +!!\param fsfcdc tot sky sfc dnwd flux +!!\param fsfcd0 clr sky sfc dnwd flux +!!\param sfbmc tot sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdfc tot sky sfc dnwd diff flux (nir/uv+vis) +!!\param sfbm0 clr sky sfc dnwd beam flux (nir/uv+vis) +!!\param sfdf0 clr sky sfc dnwd diff flux (nir/uv+vis) +!!\param suvbfc tot sky sfc dnwd uv-b flux +!!\param suvbf0 clr sky sfc dnwd uv-b flux +!----------------------------------- + subroutine spcvrtm & + & ( ssolar,cosz,sntz,albbm,albdf,sfluxzen,cldfmc, & ! --- inputs + & cf1,cf0,taug,taur,tauae,ssaae,asyae,taucw,ssacw,asycw, & + & nlay, nlp1, & + & fxupc,fxdnc,fxup0,fxdn0, & ! --- outputs + & ftoauc,ftoau0,ftoadc,fsfcuc,fsfcu0,fsfcdc,fsfcd0, & + & sfbmc,sfdfc,sfbm0,sfdf0,suvbfc,suvbf0 & + & ) + +! =================== program usage description =================== ! +! ! +! purpose: computes the shortwave radiative fluxes using two-stream ! +! method of h. barker and mcica, the monte-carlo independent! +! column approximation, for the representation of sub-grid ! +! cloud variability (i.e. cloud overlap). ! +! ! +! subprograms called: vrtqdr ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! ssolar - real, incoming solar flux at top 1 ! +! cosz - real, cosine solar zenith angle 1 ! +! sntz - real, secant solar zenith angle 1 ! +! albbm - real, surface albedo for direct beam radiation 2 ! +! albdf - real, surface albedo for diffused radiation 2 ! +! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! +! cldfmc - real, layer cloud fraction for g-point nlay*ngptsw! +! cf1 - real, >0: cloudy sky, otherwise: clear sky 1 ! +! cf0 - real, =1-cf1 1 ! +! taug - real, spectral optical depth for gases nlay*ngptsw! +! taur - real, optical depth for rayleigh scattering nlay*ngptsw! +! tauae - real, aerosols optical depth nlay*nbdsw ! +! ssaae - real, aerosols single scattering albedo nlay*nbdsw ! +! asyae - real, aerosols asymmetry factor nlay*nbdsw ! +! taucw - real, weighted cloud optical depth nlay*nbdsw ! +! ssacw - real, weighted cloud single scat albedo nlay*nbdsw ! +! asycw - real, weighted cloud asymmetry factor nlay*nbdsw ! +! nlay,nlp1 - integer, number of layers/levels 1 ! +! ! +! output variables: ! +! fxupc - real, tot sky upward flux nlp1*nbdsw ! +! fxdnc - real, tot sky downward flux nlp1*nbdsw ! +! fxup0 - real, clr sky upward flux nlp1*nbdsw ! +! fxdn0 - real, clr sky downward flux nlp1*nbdsw ! +! ftoauc - real, tot sky toa upwd flux 1 ! +! ftoau0 - real, clr sky toa upwd flux 1 ! +! ftoadc - real, toa downward (incoming) solar flux 1 ! +! fsfcuc - real, tot sky sfc upwd flux 1 ! +! fsfcu0 - real, clr sky sfc upwd flux 1 ! +! fsfcdc - real, tot sky sfc dnwd flux 1 ! +! fsfcd0 - real, clr sky sfc dnwd flux 1 ! +! sfbmc - real, tot sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdfc - real, tot sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! sfbm0 - real, clr sky sfc dnwd beam flux (nir/uv+vis) 2 ! +! sfdf0 - real, clr sky sfc dnwd diff flux (nir/uv+vis) 2 ! +! suvbfc - real, tot sky sfc dnwd uv-b flux 1 ! +! suvbf0 - real, clr sky sfc dnwd uv-b flux 1 ! +! ! +! internal variables: ! +! zrefb - real, direct beam reflectivity for clear/cloudy nlp1 ! +! zrefd - real, diffuse reflectivity for clear/cloudy nlp1 ! +! ztrab - real, direct beam transmissivity for clear/cloudy nlp1 ! +! ztrad - real, diffuse transmissivity for clear/cloudy nlp1 ! +! zldbt - real, layer beam transmittance for clear/cloudy nlp1 ! +! ztdbt - real, lev total beam transmittance for clr/cld nlp1 ! +! ! +! control parameters in module "physparam" ! +! iswmode - control flag for 2-stream transfer schemes ! +! = 1 delta-eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! ******************************************************************* ! +! original code description ! +! ! +! method: ! +! ------- ! +! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. ! +! kmodts = 1 eddington (joseph et al., 1976) ! +! = 2 pifm (zdunkowski et al., 1980) ! +! = 3 discrete ordinates (liou, 1973) ! +! ! +! modifications: ! +! -------------- ! +! original: h. barker ! +! revision: merge with rrtmg_sw: j.-j.morcrette, ecmwf, feb 2003 ! +! revision: add adjustment for earth/sun distance:mjiacono,aer,oct2003! +! revision: bug fix for use of palbp and palbd: mjiacono, aer, nov2003! +! revision: bug fix to apply delta scaling to clear sky: aer, dec2004 ! +! revision: code modified so that delta scaling is not done in cloudy ! +! profiles if routine cldprop is used; delta scaling can be ! +! applied by swithcing code below if cldprop is not used to ! +! get cloud properties. aer, jan 2005 ! +! revision: uniform formatting for rrtmg: mjiacono, aer, jul 2006 ! +! revision: use exponential lookup table for transmittance: mjiacono, ! +! aer, aug 2007 ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- constant parameters: + real (kind=kind_phys), parameter :: zcrit = 0.9999995 ! thresold for conservative scattering + real (kind=kind_phys), parameter :: zsr3 = sqrt(3.0) + real (kind=kind_phys), parameter :: od_lo = 0.06 + real (kind=kind_phys), parameter :: eps1 = 1.0e-8 + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlay,ngptsw), intent(in) :: & + & taug, taur, cldfmc + real (kind=kind_phys), dimension(nlay,nbdsw), intent(in) :: & + & taucw, ssacw, asycw, tauae, ssaae, asyae + + real (kind=kind_phys), dimension(ngptsw), intent(in) :: sfluxzen + + real (kind=kind_phys), dimension(2), intent(in) :: albbm, albdf + + real (kind=kind_phys), intent(in) :: cosz, sntz, cf1, cf0, ssolar + +! --- outputs: + real (kind=kind_phys), dimension(nlp1,nbdsw), intent(out) :: & + & fxupc, fxdnc, fxup0, fxdn0 + + real (kind=kind_phys), dimension(2), intent(out) :: sfbmc, sfdfc, & + & sfbm0, sfdf0 + + real (kind=kind_phys), intent(out) :: suvbfc, suvbf0, ftoadc, & + & ftoauc, ftoau0, fsfcuc, fsfcu0, fsfcdc, fsfcd0 + +! --- locals: + real (kind=kind_phys), dimension(nlay) :: ztaus, zssas, zasys, & + & zldbt0 + + real (kind=kind_phys), dimension(nlp1) :: zrefb, zrefd, ztrab, & + & ztrad, ztdbt, zldbt, zfu, zfd + + real (kind=kind_phys) :: ztau1, zssa1, zasy1, ztau0, zssa0, & + & zasy0, zasy3, zssaw, zasyw, zgam1, zgam2, zgam3, zgam4, & + & za1, za2, zb1, zb2, zrk, zrk2, zrp, zrp1, zrm1, zrpp, & + & zrkg1, zrkg3, zrkg4, zexp1, zexm1, zexp2, zexm2, zden1, & + & zexp3, zexp4, ze1r45, ftind, zsolar, ztdbt0, zr1, zr2, & + & zr3, zr4, zr5, zt1, zt2, zt3, zf1, zf2, zrpp1 + + integer :: ib, ibd, jb, jg, k, kp, itind +! +!===> ... begin here +! +!> -# Initialize output fluxes. + + do ib = 1, nbdsw + do k = 1, nlp1 + fxdnc(k,ib) = f_zero + fxupc(k,ib) = f_zero + fxdn0(k,ib) = f_zero + fxup0(k,ib) = f_zero + enddo + enddo + + ftoadc = f_zero + ftoauc = f_zero + ftoau0 = f_zero + fsfcuc = f_zero + fsfcu0 = f_zero + fsfcdc = f_zero + fsfcd0 = f_zero + +!! --- ... uv-b surface downward fluxes + suvbfc = f_zero + suvbf0 = f_zero + +!! --- ... output surface flux components + sfbmc(1) = f_zero + sfbmc(2) = f_zero + sfdfc(1) = f_zero + sfdfc(2) = f_zero + sfbm0(1) = f_zero + sfbm0(2) = f_zero + sfdf0(1) = f_zero + sfdf0(2) = f_zero + +! --- ... loop over all g-points in each band + + lab_do_jg : do jg = 1, ngptsw + + jb = NGB(jg) + ib = jb + 1 - nblow + ibd = idxsfc(jb) ! spectral band index + + zsolar = ssolar * sfluxzen(jg) + +! --- ... set up toa direct beam and surface values (beam and diff) + + ztdbt(nlp1) = f_one + ztdbt0 = f_one + + zldbt(1) = f_zero + if (ibd /= 0) then + zrefb(1) = albbm(ibd) + zrefd(1) = albdf(ibd) + else + zrefb(1) = 0.5 * (albbm(1) + albbm(2)) + zrefd(1) = 0.5 * (albdf(1) + albdf(2)) + endif + ztrab(1) = f_zero + ztrad(1) = f_zero + +!> -# Compute clear-sky optical parameters, layer reflectance and +!! transmittance. +!! - Set up toa direct beam and surface values (beam and diff) +!! - Delta scaling for clear-sky condition +!! - General two-stream expressions for physparam::iswmode +!! - Compute homogeneous reflectance and transmittance for both +!! conservative and non-conservative scattering +!! - Pre-delta-scaling clear and cloudy direct beam transmittance +!! - Call swflux() to compute the upward and downward radiation fluxes + + do k = nlay, 1, -1 + kp = k + 1 + + ztau0 = max( ftiny, taur(k,jg)+taug(k,jg)+tauae(k,ib) ) + zssa0 = taur(k,jg) + tauae(k,ib)*ssaae(k,ib) + zasy0 = asyae(k,ib)*ssaae(k,ib)*tauae(k,ib) + zssaw = min( oneminus, zssa0 / ztau0 ) + zasyw = zasy0 / max( ftiny, zssa0 ) + +! --- ... saving clear-sky quantities for later total-sky usage + ztaus(k) = ztau0 + zssas(k) = zssa0 + zasys(k) = zasy0 + +! --- ... delta scaling for clear-sky condition + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) ! this line is replaced by the next + zasy1 = zasyw / (f_one + zasyw) ! to reduce truncation error + zasy3 = 0.75 * zasy1 + +! --- ... general two-stream expressions + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + +! --- ... compute homogeneous reflectance and transmittance + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp) )) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2/(f_one + za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one-zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( sntz*ztau1, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if (ze1r45>=-eps1 .and. ze1r45<=eps1) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1 - zr2*zexm1 - zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one & + & - (zt1*zexp1 - zt2*zexm1 - zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +! --- ... direct beam transmittance. use exponential lookup table +! for transmittance, or expansion of exponential for low +! optical depth + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + ztdbt(k) = zexp3 * ztdbt(kp) + zldbt(kp) = zexp3 + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + zldbt0(k) = zexp4 + ztdbt0 = zexp4 * ztdbt0 + enddo ! end do_k_loop + + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +! --- ... compute upward and downward fluxes at levels + do k = 1, nlp1 + fxup0(k,ib) = fxup0(k,ib) + zsolar*zfu(k) + fxdn0(k,ib) = fxdn0(k,ib) + zsolar*zfd(k) + enddo + +!! --- ... surface downward beam/diffuse flux components + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbm0(ibd) = sfbm0(ibd) + zb1 + sfdf0(ibd) = sfdf0(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbm0(1) = sfbm0(1) + zf1 + sfdf0(1) = sfdf0(1) + zf2 + sfbm0(2) = sfbm0(2) + zf1 + sfdf0(2) = sfdf0(2) + zf2 + endif +! sfbm0(ibd) = sfbm0(ibd) + zsolar*ztdbt0 +! sfdf0(ibd) = sfdf0(ibd) + zsolar*(zfd(1) - ztdbt0) + +!> -# Compute total sky optical parameters, layer reflectance and +!! transmittance. +!! - Set up toa direct beam and surface values (beam and diff) +!! - Delta scaling for total-sky condition +!! - General two-stream expressions for physparam::iswmode +!! - Compute homogeneous reflectance and transmittance for +!! conservative scattering and non-conservative scattering +!! - Pre-delta-scaling clear and cloudy direct beam transmittance +!! - Call swflux() to compute the upward and downward radiation fluxes + + if ( cf1 > eps ) then + +! --- ... set up toa direct beam and surface values (beam and diff) + ztdbt0 = f_one + zldbt(1) = f_zero + + do k = nlay, 1, -1 + kp = k + 1 + if ( cldfmc(k,jg) > ftiny ) then ! it is a cloudy-layer + + ztau0 = ztaus(k) + taucw(k,ib) + zssa0 = zssas(k) + ssacw(k,ib) + zasy0 = zasys(k) + asycw(k,ib) + zssaw = min(oneminus, zssa0 / ztau0) + zasyw = zasy0 / max(ftiny, zssa0) + +! --- ... delta scaling for total-sky condition + za1 = zasyw * zasyw + za2 = zssaw * za1 + + ztau1 = (f_one - za2) * ztau0 + zssa1 = (zssaw - za2) / (f_one - za2) +!org zasy1 = (zasyw - za1) / (f_one - za1) + zasy1 = zasyw / (f_one + zasyw) + zasy3 = 0.75 * zasy1 + +! --- ... general two-stream expressions + if ( iswmode == 1 ) then + zgam1 = 1.75 - zssa1 * (f_one + zasy3) + zgam2 =-0.25 + zssa1 * (f_one - zasy3) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 2 ) then ! pifm + zgam1 = 2.0 - zssa1 * (1.25 + zasy3) + zgam2 = 0.75* zssa1 * (f_one- zasy1) + zgam3 = 0.5 - zasy3 * cosz + elseif ( iswmode == 3 ) then ! discrete ordinates + zgam1 = zsr3 * (2.0 - zssa1 * (1.0 + zasy1)) * 0.5 + zgam2 = zsr3 * zssa1 * (1.0 - zasy1) * 0.5 + zgam3 = (1.0 - zsr3 * zasy1 * cosz) * 0.5 + endif + zgam4 = f_one - zgam3 + +! --- ... compute homogeneous reflectance and transmittance + + if ( zssaw >= zcrit ) then ! for conservative scattering + za1 = zgam1 * cosz - zgam3 + za2 = zgam1 * ztau1 + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( ztau1*sntz , 500.0 ) + if ( zb1 <= od_lo ) then + zb2 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zb2 = exp_tbl(itind) + endif + +! ... collimated beam + zrefb(kp) = max(f_zero, min(f_one, & + & (za2 - za1*(f_one - zb2))/(f_one + za2) )) + ztrab(kp) = max(f_zero, min(f_one, f_one-zrefb(kp))) + +! ... isotropic incidence + zrefd(kp) = max(f_zero, min(f_one, za2 / (f_one+za2) )) + ztrad(kp) = max(f_zero, min(f_one, f_one - zrefd(kp) )) + + else ! for non-conservative scattering + za1 = zgam1*zgam4 + zgam2*zgam3 + za2 = zgam1*zgam3 + zgam2*zgam4 + zrk = sqrt ( (zgam1 - zgam2) * (zgam1 + zgam2) ) + zrk2= 2.0 * zrk + + zrp = zrk * cosz + zrp1 = f_one + zrp + zrm1 = f_one - zrp + zrpp1= f_one - zrp*zrp + zrpp = sign( max(flimit, abs(zrpp1)), zrpp1 ) ! avoid numerical singularity + zrkg1= zrk + zgam1 + zrkg3= zrk * zgam3 + zrkg4= zrk * zgam4 + + zr1 = zrm1 * (za2 + zrkg3) + zr2 = zrp1 * (za2 - zrkg3) + zr3 = zrk2 * (zgam3 - za2*cosz) + zr4 = zrpp * zrkg1 + zr5 = zrpp * (zrk - zgam1) + + zt1 = zrp1 * (za1 + zrkg4) + zt2 = zrm1 * (za1 - zrkg4) + zt3 = zrk2 * (zgam4 + za1*cosz) + +! --- ... use exponential lookup table for transmittance, or expansion +! of exponential for low optical depth + + zb1 = min ( zrk*ztau1, 500.0 ) + if ( zb1 <= od_lo ) then + zexm1 = f_one - zb1 + 0.5*zb1*zb1 + else + ftind = zb1 / (bpade + zb1) + itind = ftind*NTBMX + 0.5 + zexm1 = exp_tbl(itind) + endif + zexp1 = f_one / zexm1 + + zb2 = min ( ztau1*sntz, 500.0 ) + if ( zb2 <= od_lo ) then + zexm2 = f_one - zb2 + 0.5*zb2*zb2 + else + ftind = zb2 / (bpade + zb2) + itind = ftind*NTBMX + 0.5 + zexm2 = exp_tbl(itind) + endif + zexp2 = f_one / zexm2 + ze1r45 = zr4*zexp1 + zr5*zexm1 + +! ... collimated beam + if ( ze1r45>=-eps1 .and. ze1r45<=eps1 ) then + zrefb(kp) = eps1 + ztrab(kp) = zexm2 + else + zden1 = zssa1 / ze1r45 + zrefb(kp) = max(f_zero, min(f_one, & + & (zr1*zexp1-zr2*zexm1-zr3*zexm2)*zden1 )) + ztrab(kp) = max(f_zero, min(f_one, zexm2*(f_one - & + & (zt1*zexp1-zt2*zexm1-zt3*zexp2)*zden1) )) + endif + +! ... diffuse beam + zden1 = zr4 / (ze1r45 * zrkg1) + zrefd(kp) = max(f_zero, min(f_one, & + & zgam2*(zexp1 - zexm1)*zden1 )) + ztrad(kp) = max(f_zero, min(f_one, zrk2*zden1 )) + endif ! end if_zssaw_block + +! --- ... direct beam transmittance. use exponential lookup table +! for transmittance, or expansion of exponential for low +! optical depth + + zr1 = ztau1 * sntz + if ( zr1 <= od_lo ) then + zexp3 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp3 = exp_tbl(itind) + endif + + zldbt(kp) = zexp3 + ztdbt(k) = zexp3 * ztdbt(kp) + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance +! (must use 'orig', unscaled cloud optical depth) + + zr1 = ztau0 * sntz + if ( zr1 <= od_lo ) then + zexp4 = f_one - zr1 + 0.5*zr1*zr1 + else + ftind = zr1 / (bpade + zr1) + itind = max(0, min(NTBMX, int(0.5+NTBMX*ftind) )) + zexp4 = exp_tbl(itind) + endif + + ztdbt0 = zexp4 * ztdbt0 + + else ! if_cldfmc_block --- it is a clear layer + +! --- ... direct beam transmittance + ztdbt(k) = zldbt(kp) * ztdbt(kp) + +! --- ... pre-delta-scaling clear and cloudy direct beam transmittance + ztdbt0 = zldbt0(k) * ztdbt0 + + endif ! end if_cldfmc_block + enddo ! end do_k_loop + +! --- ... perform vertical quadrature + + call vrtqdr & +! --- inputs: + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & + & nlay, nlp1, & +! --- outputs: + & zfu, zfd & + & ) + +! --- ... compute upward and downward fluxes at levels + do k = 1, nlp1 + fxupc(k,ib) = fxupc(k,ib) + zsolar*zfu(k) + fxdnc(k,ib) = fxdnc(k,ib) + zsolar*zfd(k) + enddo + +!> -# Process and save outputs. +! --- ... surface downward beam/diffused flux components + zb1 = zsolar*ztdbt0 + zb2 = zsolar*(zfd(1) - ztdbt0) + + if (ibd /= 0) then + sfbmc(ibd) = sfbmc(ibd) + zb1 + sfdfc(ibd) = sfdfc(ibd) + zb2 + else + zf1 = 0.5 * zb1 + zf2 = 0.5 * zb2 + sfbmc(1) = sfbmc(1) + zf1 + sfdfc(1) = sfdfc(1) + zf2 + sfbmc(2) = sfbmc(2) + zf1 + sfdfc(2) = sfdfc(2) + zf2 + endif +! sfbmc(ibd) = sfbmc(ibd) + zsolar*ztdbt0 +! sfdfc(ibd) = sfdfc(ibd) + zsolar*(zfd(1) - ztdbt0) + + endif ! end if_cf1_block + + enddo lab_do_jg + +! --- ... end of g-point loop + + do ib = 1, nbdsw + ftoadc = ftoadc + fxdn0(nlp1,ib) + ftoau0 = ftoau0 + fxup0(nlp1,ib) + fsfcu0 = fsfcu0 + fxup0(1,ib) + fsfcd0 = fsfcd0 + fxdn0(1,ib) + enddo + +!! --- ... uv-b surface downward flux + ibd = nuvb - nblow + 1 + suvbf0 = fxdn0(1,ibd) + + if ( cf1 <= eps ) then ! clear column, set total-sky=clear-sky fluxes + do ib = 1, nbdsw + do k = 1, nlp1 + fxupc(k,ib) = fxup0(k,ib) + fxdnc(k,ib) = fxdn0(k,ib) + enddo + enddo + + ftoauc = ftoau0 + fsfcuc = fsfcu0 + fsfcdc = fsfcd0 + +!! --- ... surface downward beam/diffused flux components + sfbmc(1) = sfbm0(1) + sfdfc(1) = sfdf0(1) + sfbmc(2) = sfbm0(2) + sfdfc(2) = sfdf0(2) + +!! --- ... uv-b surface downward flux + suvbfc = suvbf0 + else ! cloudy column, compute total-sky fluxes + do ib = 1, nbdsw + ftoauc = ftoauc + fxupc(nlp1,ib) + fsfcuc = fsfcuc + fxupc(1,ib) + fsfcdc = fsfcdc + fxdnc(1,ib) + enddo + +!! --- ... uv-b surface downward flux + suvbfc = fxdnc(1,ibd) + endif ! end if_cf1_block + + return +!................................... + end subroutine spcvrtm +!----------------------------------- + +!> This subroutine is called by spcvrtc() and spcvrtm(), and computes +!! the upward and downward radiation fluxes. +!!\param zrefb layer direct beam reflectivity +!!\param zrefd layer diffuse reflectivity +!!\param ztrab layer direct beam transmissivity +!!\param ztrad layer diffuse transmissivity +!!\param zldbt layer mean beam transmittance +!!\param ztdbt total beam transmittance at levels +!!\param NLAY, NLP1 number of layers/levels +!!\param zfu upward flux at layer interface +!!\param zfd downward flux at layer interface +!!\section General_swflux General Algorithm +!> @{ +!----------------------------------- + subroutine vrtqdr & + & ( zrefb,zrefd,ztrab,ztrad,zldbt,ztdbt, & ! inputs + & NLAY, NLP1, & + & zfu, zfd & ! outputs: + & ) + +! =================== program usage description =================== ! +! ! +! purpose: computes the upward and downward radiation fluxes ! +! ! +! interface: "vrtqdr" is called by "spcvrc" and "spcvrm" ! +! ! +! subroutines called : none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! input variables: ! +! zrefb(NLP1) - layer direct beam reflectivity ! +! zrefd(NLP1) - layer diffuse reflectivity ! +! ztrab(NLP1) - layer direct beam transmissivity ! +! ztrad(NLP1) - layer diffuse transmissivity ! +! zldbt(NLP1) - layer mean beam transmittance ! +! ztdbt(NLP1) - total beam transmittance at levels ! +! NLAY, NLP1 - number of layers/levels ! +! ! +! output variables: ! +! zfu (NLP1) - upward flux at layer interface ! +! zfd (NLP1) - downward flux at layer interface ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, nlp1 + + real (kind=kind_phys), dimension(nlp1), intent(in) :: zrefb, & + & zrefd, ztrab, ztrad, ztdbt, zldbt + +! --- outputs: + real (kind=kind_phys), dimension(nlp1), intent(out) :: zfu, zfd + +! --- locals: + real (kind=kind_phys), dimension(nlp1) :: zrupb,zrupd,zrdnd,ztdn + + real (kind=kind_phys) :: zden1 + + integer :: k, kp +! +!===> ... begin here +! + +!> -# Link lowest layer with surface. + zrupb(1) = zrefb(1) ! direct beam + zrupd(1) = zrefd(1) ! diffused + +!> -# Pass from bottom to top. + do k = 1, nlay + kp = k + 1 + + zden1 = f_one / ( f_one - zrupd(k)*zrefd(kp) ) + zrupb(kp) = zrefb(kp) + ( ztrad(kp) * & + & ( (ztrab(kp) - zldbt(kp))*zrupd(k) + & + & zldbt(kp)*zrupb(k)) ) * zden1 + zrupd(kp) = zrefd(kp) + ztrad(kp)*ztrad(kp)*zrupd(k)*zden1 + enddo + +!> -# Upper boundary conditions + ztdn (nlp1) = f_one + zrdnd(nlp1) = f_zero + ztdn (nlay) = ztrab(nlp1) + zrdnd(nlay) = zrefd(nlp1) + +!> -# Pass from top to bottom + do k = nlay, 2, -1 + zden1 = f_one / (f_one - zrefd(k)*zrdnd(k)) + ztdn (k-1) = ztdbt(k)*ztrab(k) + ( ztrad(k) * & + & ( (ztdn(k) - ztdbt(k)) + ztdbt(k) * & + & zrefb(k)*zrdnd(k) )) * zden1 + zrdnd(k-1) = zrefd(k) + ztrad(k)*ztrad(k)*zrdnd(k)*zden1 + enddo + +!> -# Up and down-welling fluxes at levels. + do k = 1, nlp1 + zden1 = f_one / (f_one - zrdnd(k)*zrupd(k)) + zfu(k) = ( ztdbt(k)*zrupb(k) + & + & (ztdn(k) - ztdbt(k))*zrupd(k) ) * zden1 + zfd(k) = ztdbt(k) + ( ztdn(k) - ztdbt(k) + & + & ztdbt(k)*zrupb(k)*zrdnd(k) ) * zden1 + enddo + + return +!................................... + end subroutine vrtqdr +!----------------------------------- +!> @} + +!> This subroutine calculates optical depths for gaseous absorption and +!! rayleigh scattering +!!\n subroutine called taumol## (## = 16-29) +!!\param colamt column amounts of absorbing gases the index +!! are for h2o, co2, o3, n2o, ch4, and o2, +!! respectively \f$(mol/cm^2)\f$ +!!\param colmol total column amount (dry air+water vapor) +!!\param facij for each layer, these are factors that are +!! needed to compute the interpolation factors +!! that multiply the appropriate reference +!! k-values. a value of 0/1 for i,j indicates +!! that the corresponding factor multiplies +!! reference k-value for the lower/higher of the +!! two appropriate temperatures, and altitudes, +!! respectively. +!!\param jp the index of the lower (in altitude) of the +!! two appropriate ref pressure levels needed +!! for interpolation. +!!\param jt, jt1 the indices of the lower of the two approp +!! ref temperatures needed for interpolation +!! (for pressure levels jp and jp+1, respectively) +!!\param laytrop tropopause layer index +!!\param forfac scale factor needed to foreign-continuum. +!!\param forfrac factor needed for temperature interpolation +!!\param indfor index of the lower of the two appropriate +!! reference temperatures needed for +!! foreign-continuum interpolation +!!\param selffac scale factor needed to h2o self-continuum. +!!\param selffrac factor needed for temperature interpolation +!! of reference h2o self-continuum data +!!\param indself index of the lower of the two appropriate +!! reference temperatures needed for the +!! self-continuum interpolation +!!\param nlay number of vertical layers +!!\param sfluxzen spectral distribution of incoming solar flux +!!\param taug spectral optical depth for gases +!!\param taur opt depth for rayleigh scattering +!>\section gen_al General Algorithm +!! @{ +!----------------------------------- + subroutine taumol & + & ( colamt,colmol,fac00,fac01,fac10,fac11,jp,jt,jt1,laytrop, & ! --- inputs + & forfac,forfrac,indfor,selffac,selffrac,indself, nlay, & + & sfluxzen, taug, taur & ! --- outputs + & ) + +! ================== program usage description ================== ! +! ! +! description: ! +! calculate optical depths for gaseous absorption and rayleigh ! +! scattering. ! +! ! +! subroutines called: taugb## (## = 16 - 29) ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! colamt - real, column amounts of absorbing gases the index ! +! are for h2o, co2, o3, n2o, ch4, and o2, ! +! respectively (molecules/cm**2) nlay*maxgas! +! colmol - real, total column amount (dry air+water vapor) nlay ! +! facij - real, for each layer, these are factors that are ! +! needed to compute the interpolation factors ! +! that multiply the appropriate reference k- ! +! values. a value of 0/1 for i,j indicates ! +! that the corresponding factor multiplies ! +! reference k-value for the lower/higher of the ! +! two appropriate temperatures, and altitudes, ! +! respectively. naly ! +! jp - real, the index of the lower (in altitude) of the ! +! two appropriate ref pressure levels needed ! +! for interpolation. nlay ! +! jt, jt1 - integer, the indices of the lower of the two approp ! +! ref temperatures needed for interpolation (for ! +! pressure levels jp and jp+1, respectively) nlay ! +! laytrop - integer, tropopause layer index 1 ! +! forfac - real, scale factor needed to foreign-continuum. nlay ! +! forfrac - real, factor needed for temperature interpolation nlay ! +! indfor - integer, index of the lower of the two appropriate ! +! reference temperatures needed for foreign- ! +! continuum interpolation nlay ! +! selffac - real, scale factor needed to h2o self-continuum. nlay ! +! selffrac- real, factor needed for temperature interpolation ! +! of reference h2o self-continuum data nlay ! +! indself - integer, index of the lower of the two appropriate ! +! reference temperatures needed for the self- ! +! continuum interpolation nlay ! +! nlay - integer, number of vertical layers 1 ! +! ! +! output: ! +! sfluxzen- real, spectral distribution of incoming solar flux ngptsw! +! taug - real, spectral optical depth for gases nlay*ngptsw! +! taur - real, opt depth for rayleigh scattering nlay*ngptsw! +! ! +! =================================================================== ! +! ************ original subprogram description *************** ! +! ! +! optical depths developed for the ! +! ! +! rapid radiative transfer model (rrtm) ! +! ! +! atmospheric and environmental research, inc. ! +! 131 hartwell avenue ! +! lexington, ma 02421 ! +! ! +! ! +! eli j. mlawer ! +! jennifer delamere ! +! steven j. taubman ! +! shepard a. clough ! +! ! +! ! +! ! +! email: mlawer@aer.com ! +! email: jdelamer@aer.com ! +! ! +! the authors wish to acknowledge the contributions of the ! +! following people: patrick d. brown, michael j. iacono, ! +! ronald e. farren, luke chen, robert bergstrom. ! +! ! +! ******************************************************************* ! +! ! +! taumol ! +! ! +! this file contains the subroutines taugbn (where n goes from ! +! 16 to 29). taugbn calculates the optical depths and Planck ! +! fractions per g-value and layer for band n. ! +! ! +! output: optical depths (unitless) ! +! fractions needed to compute planck functions at every layer ! +! and g-value ! +! ! +! modifications: ! +! ! +! revised: adapted to f90 coding, j.-j.morcrette, ecmwf, feb 2003 ! +! revised: modified for g-point reduction, mjiacono, aer, dec 2003 ! +! revised: reformatted for consistency with rrtmg_lw, mjiacono, aer, ! +! jul 2006 ! +! ! +! ******************************************************************* ! +! ====================== end of description block ================= ! + +! --- inputs: + integer, intent(in) :: nlay, laytrop + + integer, dimension(nlay), intent(in) :: indfor, indself, & + & jp, jt, jt1 + + real (kind=kind_phys), dimension(nlay), intent(in) :: colmol, & + & fac00, fac01, fac10, fac11, forfac, forfrac, selffac, & + & selffrac + + real (kind=kind_phys), dimension(nlay,maxgas),intent(in) :: colamt + +! --- outputs: + real (kind=kind_phys), dimension(ngptsw), intent(out) :: sfluxzen + + real (kind=kind_phys), dimension(nlay,ngptsw), intent(out) :: & + & taug, taur + +! --- locals: + real (kind=kind_phys) :: fs, speccomb, specmult, colm1, colm2 + + integer, dimension(nlay,nblow:nbhgh) :: id0, id1 + + integer :: ibd, j, jb, js, k, klow, khgh, klim, ks, njb, ns +! +!===> ... begin here +! +! --- ... loop over each spectral band + + do jb = nblow, nbhgh + +! --- ... indices for layer optical depth + + do k = 1, laytrop + id0(k,jb) = ((jp(k)-1)*5 + (jt (k)-1)) * nspa(jb) + id1(k,jb) = ( jp(k) *5 + (jt1(k)-1)) * nspa(jb) + enddo + + do k = laytrop+1, nlay + id0(k,jb) = ((jp(k)-13)*5 + (jt (k)-1)) * nspb(jb) + id1(k,jb) = ((jp(k)-12)*5 + (jt1(k)-1)) * nspb(jb) + enddo + +! --- ... calculate spectral flux at toa + + ibd = ibx(jb) + njb = ng (jb) + ns = ngs(jb) + + select case (jb) + + case (16, 20, 23, 25, 26, 29) + + do j = 1, njb + sfluxzen(ns+j) = sfluxref01(j,1,ibd) + enddo + + case (27) + + do j = 1, njb + sfluxzen(ns+j) = scalekur * sfluxref01(j,1,ibd) + enddo + + case default + + if (jb==17 .or. jb==28) then + + ks = nlay + lab_do_k1 : do k = laytrop, nlay-1 + if (jp(k)=layreffr(jb)) then + ks = k + 1 + exit lab_do_k1 + endif + enddo lab_do_k1 + + colm1 = colamt(ks,ix1(jb)) + colm2 = colamt(ks,ix2(jb)) + speccomb = colm1 + strrat(jb)*colm2 + specmult = specwt(jb) * min( oneminus, colm1/speccomb ) + js = 1 + int( specmult ) + fs = mod(specmult, f_one) + + do j = 1, njb + sfluxzen(ns+j) = sfluxref02(j,js,ibd) & + & + fs * (sfluxref02(j,js+1,ibd) - sfluxref02(j,js,ibd)) + enddo + + else + + ks = laytrop + lab_do_k2 : do k = 1, laytrop-1 + if (jp(k)=layreffr(jb)) then + ks = k + 1 + exit lab_do_k2 + endif + enddo lab_do_k2 + + colm1 = colamt(ks,ix1(jb)) + colm2 = colamt(ks,ix2(jb)) + speccomb = colm1 + strrat(jb)*colm2 + specmult = specwt(jb) * min( oneminus, colm1/speccomb ) + js = 1 + int( specmult ) + fs = mod(specmult, f_one) + + do j = 1, njb + sfluxzen(ns+j) = sfluxref03(j,js,ibd) & + & + fs * (sfluxref03(j,js+1,ibd) - sfluxref03(j,js,ibd)) + enddo + + endif + + end select + + enddo + +!> - Call taumol## (##: 16-29) to calculate layer optical depth. + +!> - call taumol16() + call taumol16 +!> - call taumol17() + call taumol17 +!> - call taumol18() + call taumol18 +!> - call taumol19() + call taumol19 +!> - call taumol20() + call taumol20 +!> - call taumol21() + call taumol21 +!> - call taumol22() + call taumol22 +!> - call taumol23() + call taumol23 +!> - call taumol24() + call taumol24 +!> - call taumol25() + call taumol25 +!> - call taumol26() + call taumol26 +!> - call taumol27() + call taumol27 +!> - call taumol28() + call taumol28 +!> - call taumol29() + call taumol29 + + +! ================= + contains +! ================= + +!> The subroutine computes the optical depth in band 16: 2600-3250 +!! cm-1 (low - h2o,ch4; high - ch4) +!----------------------------------- + subroutine taumol16 +!................................... + +! ------------------------------------------------------------------ ! +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb16 + +! --- locals: + + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG16 + taur(k,NS16+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(16)*colamt(k,5) + specmult = 8.0 * min( oneminus, colamt(k,1)/speccomb ) + + js = 1 + int( specmult ) + fs = mod( specmult, f_one ) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,16) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,16) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG16 + taug(k,NS16+j) = speccomb & + & *( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,16) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,16) + 1 + ind12 = ind11 + 1 + + do j = 1, NG16 + taug(k,NS16+j) = colamt(k,5) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol16 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 17: 3250-4000 +!! cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------- + subroutine taumol17 +!................................... + +! ------------------------------------------------------------------ ! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb17 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG17 + taur(k,NS17+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(17)*colamt(k,2) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,17) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,17) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG17 + taug(k,NS17+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + speccomb = colamt(k,1) + strrat(17)*colamt(k,2) + specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,17) + js + ind02 = ind01 + 1 + ind03 = ind01 + 5 + ind04 = ind01 + 6 + ind11 = id1(k,17) + js + ind12 = ind11 + 1 + ind13 = ind11 + 5 + ind14 = ind11 + 6 + + indf = indfor(k) + indfp= indf + 1 + + do j = 1, NG17 + taug(k,NS17+j) = speccomb & + & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & + & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & + & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & + & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & + & + colamt(k,1) * forfac(k) * (forref(indf,j) & + & + forfrac(k) * (forref(indfp,j) - forref(indf,j))) + enddo + enddo + + return +!................................... + end subroutine taumol17 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 18: 4000-4650 +!! cm-1 (low - h2o,ch4; high - ch4) +!----------------------------------- + subroutine taumol18 +!................................... + +! ------------------------------------------------------------------ ! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb18 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG18 + taur(k,NS18+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(18)*colamt(k,5) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,18) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,18) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG18 + taug(k,NS18+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,18) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,18) + 1 + ind12 = ind11 + 1 + + do j = 1, NG18 + taug(k,NS18+j) = colamt(k,5) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol18 +!----------------------------------- + +!> The subroutine computes the optical depth in band 19: 4650-5150 +!! cm-1 (low - h2o,co2; high - co2) +!----------------------------------- + subroutine taumol19 +!................................... + +! ------------------------------------------------------------------ ! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb19 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG19 + taur(k,NS19+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(19)*colamt(k,2) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,19) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,19) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG19 + taug(k,NS19+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,19) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,19) + 1 + ind12 = ind11 + 1 + + do j = 1, NG19 + taug(k,NS19+j) = colamt(k,2) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + +!................................... + end subroutine taumol19 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 20: 5150-6150 +!! cm-1 (low - h2o; high - h2o) +!----------------------------------- + subroutine taumol20 +!................................... + +! ------------------------------------------------------------------ ! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb20 + +! --- locals: + real (kind=kind_phys) :: tauray + + integer :: ind01, ind02, ind11, ind12 + integer :: inds, indf, indsp, indfp, j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG20 + taur(k,NS20+j) = tauray + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,20) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,20) + 1 + ind12 = ind11 + 1 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG20 + taug(k,NS20+j) = colamt(k,1) & + & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j)) & + & + selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j))) ) & + & + colamt(k,5) * absch4(j) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,20) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,20) + 1 + ind12 = ind11 + 1 + + indf = indfor(k) + indfp= indf + 1 + + do j = 1, NG20 + taug(k,NS20+j) = colamt(k,1) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j))) ) & + & + colamt(k,5) * absch4(j) + enddo + enddo + + return +!................................... + end subroutine taumol20 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 21: 6150-7700 +!! cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------- + subroutine taumol21 +!................................... + +! ------------------------------------------------------------------ ! +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb21 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG21 + taur(k,NS21+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(21)*colamt(k,2) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,21) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,21) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG21 + taug(k,NS21+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + speccomb = colamt(k,1) + strrat(21)*colamt(k,2) + specmult = 4.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,21) + js + ind02 = ind01 + 1 + ind03 = ind01 + 5 + ind04 = ind01 + 6 + ind11 = id1(k,21) + js + ind12 = ind11 + 1 + ind13 = ind11 + 5 + ind14 = ind11 + 6 + + indf = indfor(k) + indfp= indf + 1 + + do j = 1, NG21 + taug(k,NS21+j) = speccomb & + & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & + & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & + & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & + & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) & + & + colamt(k,1) * forfac(k) * (forref(indf,j) & + & + forfrac(k) * (forref(indfp,j) - forref(indf,j))) + enddo + enddo + +!................................... + end subroutine taumol21 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 22: 7700-8050 +!! cm-1 (low - h2o,o2; high - o2) +!----------------------------------- + subroutine taumol22 +!................................... + +! ------------------------------------------------------------------ ! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb22 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111, & + & o2adj, o2cont, o2tem + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! +! --- ... the following factor is the ratio of total o2 band intensity (lines +! and mate continuum) to o2 band intensity (line only). it is needed +! to adjust the optical depths since the k's include only lines. + + o2adj = 1.6 + o2tem = 4.35e-4 / (350.0*2.0) + + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG22 + taur(k,NS22+j) = tauray + enddo + enddo + + do k = 1, laytrop + o2cont = o2tem * colamt(k,6) + speccomb = colamt(k,1) + strrat(22)*colamt(k,6) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,22) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,22) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG22 + taug(k,NS22+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,1) * (selffac(k) * (selfref(inds,j) & + & + selffrac(k) * (selfref(indsp,j)-selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + o2cont + enddo + enddo + + do k = laytrop+1, nlay + o2cont = o2tem * colamt(k,6) + + ind01 = id0(k,22) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,22) + 1 + ind12 = ind11 + 1 + + do j = 1, NG22 + taug(k,NS22+j) = colamt(k,6) * o2adj & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & + & + o2cont + enddo + enddo + + return +!................................... + end subroutine taumol22 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 23: 8050-12850 +!! cm-1 (low - h2o; high - nothing) +!----------------------------------- + subroutine taumol23 +!................................... + +! ------------------------------------------------------------------ ! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb23 + +! --- locals: + integer :: ind01, ind02, ind11, ind12 + integer :: inds, indf, indsp, indfp, j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG23 + taur(k,NS23+j) = colmol(k) * rayl(j) + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,23) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,23) + 1 + ind12 = ind11 + 1 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG23 + taug(k,NS23+j) = colamt(k,1) * (givfac & + & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & + & + selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + enddo + enddo + + do k = laytrop+1, nlay + do j = 1, NG23 + taug(k,NS23+j) = f_zero + enddo + enddo + +!................................... + end subroutine taumol23 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 24: 12850-16000 +!! cm-1 (low - h2o,o2; high - o2) +!----------------------------------- + subroutine taumol24 +!................................... + +! ------------------------------------------------------------------ ! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb24 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: inds, indf, indsp, indfp, j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, laytrop + speccomb = colamt(k,1) + strrat(24)*colamt(k,6) + specmult = 8.0 * min(oneminus, colamt(k,1) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,24) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,24) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG24 + taug(k,NS24+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) & + & + colamt(k,3) * abso3a(j) + colamt(k,1) & + & * (selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) + + taur(k,NS24+j) = colmol(k) & + & * (rayla(j,js) + fs*(rayla(j,js+1) - rayla(j,js))) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,24) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,24) + 1 + ind12 = ind11 + 1 + + do j = 1, NG24 + taug(k,NS24+j) = colamt(k,6) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & + & + colamt(k,3) * abso3b(j) + + taur(k,NS24+j) = colmol(k) * raylb(j) + enddo + enddo + + return +!................................... + end subroutine taumol24 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 25: 16000-22650 +!! cm-1 (low - h2o; high - nothing) +!----------------------------------- + subroutine taumol25 +!................................... + +! ------------------------------------------------------------------ ! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb25 + +! --- locals: + integer :: ind01, ind02, ind11, ind12 + integer :: j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG25 + taur(k,NS25+j) = colmol(k) * rayl(j) + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,25) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,25) + 1 + ind12 = ind11 + 1 + + do j = 1, NG25 + taug(k,NS25+j) = colamt(k,1) & + & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & + & + colamt(k,3) * abso3a(j) + enddo + enddo + + do k = laytrop+1, nlay + do j = 1, NG25 + taug(k,NS25+j) = colamt(k,3) * abso3b(j) + enddo + enddo + + return +!................................... + end subroutine taumol25 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 26: 22650-29000 +!! cm-1 (low - nothing; high - nothing) +!----------------------------------- + subroutine taumol26 +!................................... + +! ------------------------------------------------------------------ ! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb26 + +! --- locals: + integer :: j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG26 + taug(k,NS26+j) = f_zero + taur(k,NS26+j) = colmol(k) * rayl(j) + enddo + enddo + + return +!................................... + end subroutine taumol26 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 27: 29000-38000 +!! cm-1 (low - o3; high - o3) +!----------------------------------- + subroutine taumol27 +!................................... + +! ------------------------------------------------------------------ ! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb27 +! +! --- locals: + integer :: ind01, ind02, ind11, ind12 + integer :: j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + do j = 1, NG27 + taur(k,NS27+j) = colmol(k) * rayl(j) + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,27) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,27) + 1 + ind12 = ind11 + 1 + + do j = 1, NG27 + taug(k,NS27+j) = colamt(k,3) & + & * ( fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,27) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,27) + 1 + ind12 = ind11 + 1 + + do j = 1, NG27 + taug(k,NS27+j) = colamt(k,3) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol27 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 28: 38000-50000 +!! cm-1 (low - o3,o2; high - o3,o2) +!----------------------------------- + subroutine taumol28 +!................................... + +! ------------------------------------------------------------------ ! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb28 + +! --- locals: + real (kind=kind_phys) :: speccomb, specmult, tauray, fs, fs1, & + & fac000,fac001,fac010,fac011, fac100,fac101,fac110,fac111 + + integer :: ind01, ind02, ind03, ind04, ind11, ind12, ind13, ind14 + integer :: j, js, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG28 + taur(k,NS28+j) = tauray + enddo + enddo + + do k = 1, laytrop + speccomb = colamt(k,3) + strrat(28)*colamt(k,6) + specmult = 8.0 * min(oneminus, colamt(k,3) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,28) + js + ind02 = ind01 + 1 + ind03 = ind01 + 9 + ind04 = ind01 + 10 + ind11 = id1(k,28) + js + ind12 = ind11 + 1 + ind13 = ind11 + 9 + ind14 = ind11 + 10 + + do j = 1, NG28 + taug(k,NS28+j) = speccomb & + & * ( fac000 * absa(ind01,j) + fac100 * absa(ind02,j) & + & + fac010 * absa(ind03,j) + fac110 * absa(ind04,j) & + & + fac001 * absa(ind11,j) + fac101 * absa(ind12,j) & + & + fac011 * absa(ind13,j) + fac111 * absa(ind14,j) ) + enddo + enddo + + do k = laytrop+1, nlay + speccomb = colamt(k,3) + strrat(28)*colamt(k,6) + specmult = 4.0 * min(oneminus, colamt(k,3) / speccomb) + + js = 1 + int(specmult) + fs = mod(specmult, f_one) + fs1= f_one - fs + fac000 = fs1 * fac00(k) + fac010 = fs1 * fac10(k) + fac100 = fs * fac00(k) + fac110 = fs * fac10(k) + fac001 = fs1 * fac01(k) + fac011 = fs1 * fac11(k) + fac101 = fs * fac01(k) + fac111 = fs * fac11(k) + + ind01 = id0(k,28) + js + ind02 = ind01 + 1 + ind03 = ind01 + 5 + ind04 = ind01 + 6 + ind11 = id1(k,28) + js + ind12 = ind11 + 1 + ind13 = ind11 + 5 + ind14 = ind11 + 6 + + do j = 1, NG28 + taug(k,NS28+j) = speccomb & + & * ( fac000 * absb(ind01,j) + fac100 * absb(ind02,j) & + & + fac010 * absb(ind03,j) + fac110 * absb(ind04,j) & + & + fac001 * absb(ind11,j) + fac101 * absb(ind12,j) & + & + fac011 * absb(ind13,j) + fac111 * absb(ind14,j) ) + enddo + enddo + + return +!................................... + end subroutine taumol28 +!----------------------------------- + + +!> The subroutine computes the optical depth in band 29: 820-2600 +!! cm-1 (low - h2o; high - co2) +!----------------------------------- + subroutine taumol29 +!................................... + +! ------------------------------------------------------------------ ! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) ! +! ------------------------------------------------------------------ ! +! + use module_radsw_kgb29 + +! --- locals: + real (kind=kind_phys) :: tauray + + integer :: ind01, ind02, ind11, ind12 + integer :: inds, indf, indsp, indfp, j, k + +! +!===> ... begin here +! + +! --- ... compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. below laytrop, the water +! vapor self-continuum is interpolated (in temperature) separately. + + do k = 1, nlay + tauray = colmol(k) * rayl + + do j = 1, NG29 + taur(k,NS29+j) = tauray + enddo + enddo + + do k = 1, laytrop + ind01 = id0(k,29) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,29) + 1 + ind12 = ind11 + 1 + + inds = indself(k) + indf = indfor (k) + indsp= inds + 1 + indfp= indf + 1 + + do j = 1, NG29 + taug(k,NS29+j) = colamt(k,1) & + & * ( (fac00(k)*absa(ind01,j) + fac10(k)*absa(ind02,j) & + & + fac01(k)*absa(ind11,j) + fac11(k)*absa(ind12,j) ) & + & + selffac(k) * (selfref(inds,j) + selffrac(k) & + & * (selfref(indsp,j) - selfref(inds,j))) & + & + forfac(k) * (forref(indf,j) + forfrac(k) & + & * (forref(indfp,j) - forref(indf,j)))) & + & + colamt(k,2) * absco2(j) + enddo + enddo + + do k = laytrop+1, nlay + ind01 = id0(k,29) + 1 + ind02 = ind01 + 1 + ind11 = id1(k,29) + 1 + ind12 = ind11 + 1 + + do j = 1, NG29 + taug(k,NS29+j) = colamt(k,2) & + & * ( fac00(k)*absb(ind01,j) + fac10(k)*absb(ind02,j) & + & + fac01(k)*absb(ind11,j) + fac11(k)*absb(ind12,j) ) & + & + colamt(k,1) * absh2o(j) + enddo + enddo + + return +!................................... + end subroutine taumol29 +!----------------------------------- + +!................................... + end subroutine taumol +!----------------------------------- +!! @} + +! +!........................................! + end module module_radsw_main ! +!========================================! +!! @} diff --git a/gsmphys/radsw_param.f b/gsmphys/radsw_param.f new file mode 100644 index 00000000..a1551395 --- /dev/null +++ b/gsmphys/radsw_param.f @@ -0,0 +1,202 @@ +!> \file radsw_param.f +!! This file contains SW band parameters setup. + +!> \ingroup module_radsw_main +!! @{ + +!!!!! ============================================================== !!!!! +!!!!! sw-rrtm3 radiation package description !!!!! +!!!!! ============================================================== !!!!! +! ! +! this package includes ncep's modifications of the rrtm-sw radiation ! +! code from aer inc. ! +! ! +! the sw-rrtm3 package includes these parts: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! the 'radsw_rrtm3_param.f' contains: ! +! ! +! 'module_radsw_parameters' -- band parameters set up ! +! ! +! the 'radsw_rrtm3_datatb.f' contains: ! +! ! +! 'module_radsw_ref' -- reference temperature and pressure ! +! 'module_radsw_cldprtb' -- cloud property coefficients table ! +! 'module_radsw_sflux' -- spectral distribution of solar flux ! +! 'module_radsw_kgbnn' -- absorption coeffients for 14 ! +! bands, where nn = 16-29 ! +! ! +! the 'radsw_rrtm3_main.f' contains: ! +! ! +! 'module_radsw_main' -- main sw radiation transfer ! +! ! +! in the main module 'module_radsw_main' there are only two ! +! externally callable subroutines: ! +! ! +! 'swrad' -- main rrtm3 sw radiation routine ! +! 'rswinit' -- initialization routine ! +! ! +! all the sw radiation subprograms become contained subprograms ! +! in module 'module_radsw_main' and many of them are not directly ! +! accessable from places outside the module. ! +! ! +! compilation sequence is: ! +! ! +! 'radsw_rrtm3_param.f' ! +! 'radsw_rrtm3_datatb.f' ! +! 'radsw_rrtm3_main.f' ! +! ! +! and all should be put in front of routines that use sw modules ! +! ! +! ncep modifications history log: ! +! ! +! see list in program "radsw_rrtm3_main.f" ! +! ! +!!!!! ============================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ============================================================== !!!!! + + +!> This module is for specifying the band structures and program parameters +!! used by the RRTMG-SW scheme. +!========================================! + module module_radsw_parameters ! +!........................................! + + use physparam, only : kind_phys + + implicit none +! + public +! +!> derived type for SW fluxes at TOA + type :: topfsw_type +!> total-sky upward flux + real (kind=kind_phys) :: upfxc +!> total-sky downward flux + real (kind=kind_phys) :: dnfxc +!> clear-sky upward flux + real (kind=kind_phys) :: upfx0 + end type +! +!> derived type for SW fluxes at surface + type :: sfcfsw_type +!> total-sky upward flux + real (kind=kind_phys) :: upfxc +!> total-sky downward flux + real (kind=kind_phys) :: dnfxc +!> clear-sky upward flux + real (kind=kind_phys) :: upfx0 +!> clear-sky downward flux + real (kind=kind_phys) :: dnfx0 + end type +! +!> derived type for SW fluxes' column profiles (at layer interfaces) + type :: profsw_type +!> total-sky upward flux + real (kind=kind_phys) :: upfxc +!> total-sky downward flux + real (kind=kind_phys) :: dnfxc +!> clear-sky upward flux + real (kind=kind_phys) :: upfx0 +!> clear-sky downward flux + real (kind=kind_phys) :: dnfx0 + end type +! +!> derived type for special components of surface SW fluxes + type :: cmpfsw_type +!> total-sky downward flux cover UV-B spectrum + real (kind=kind_phys) :: uvbfc +!> clear-sky downward flux cover UV-B spectrum + real (kind=kind_phys) :: uvbf0 +!> total-sky downward flux for near-IR direct beam + real (kind=kind_phys) :: nirbm +!> total-sky downward flux for near-IR diffused part + real (kind=kind_phys) :: nirdf +!> total-sky downward flux for UV+Visible direct + real (kind=kind_phys) :: visbm +!> total-sky downward flux for UV+Visible diffused + real (kind=kind_phys) :: visdf + end type +! +!! \name Parameter constants for SW band structures + +!> band range lower index + integer, parameter :: NBLOW = 16 +!> band range upper index + integer, parameter :: NBHGH = 29 +!> total number of SW bands (14) + integer, parameter :: NBANDS = NBHGH-NBLOW+1 +!> total number of g-point in all bands + integer, parameter :: NGPTSW = 112 +!> maximum number of g-point in one band + integer, parameter :: NGMAX = 16 +!> maximum number of absorbing gases + integer, parameter :: MAXGAS = 7 +!> index upper limit of optical depth and transmittance tables + integer, parameter :: NTBMX = 10000 +!> SW bands counter starting index (for compatibility with previous +!! SW radiation schemes) + integer, parameter :: NSWSTR = 1 +! integer, parameter :: NSWEND = NBANDS + integer, parameter :: NBDSW = NBANDS + +!> \name The actual number of g-point for bands 16-29 + integer :: NG16, NG17, NG18, NG19, NG20, NG21, NG22, + & NG23, NG24, NG25, NG26, NG27, NG28, NG29 + parameter ( NG16=06, NG17=12, NG18=08, NG19=08, NG20=10, + & NG21=10, NG22=02, NG23=10, NG24=08, NG25=06, + & NG26=06, NG27=08, NG28=06, NG29=12) + + integer, dimension(NBLOW:NBHGH) :: NG + data NG / NG16, NG17, NG18, NG19, NG20, NG21, NG22, + & NG23, NG24, NG25, NG26, NG27, NG28, NG29 / + +!> \name Accumulative starting index for bands 16-29 + integer :: NS16, NS17, NS18, NS19, NS20, NS21, NS22, + & NS23, NS24, NS25, NS26, NS27, NS28, NS29 + parameter ( NS16=00, NS17=NS16+NG16, NS18=NS17+NG17, + & NS19=NS18+NG18, NS20=NS19+NG19, NS21=NS20+NG20, + & NS22=NS21+NG21, NS23=NS22+NG22, NS24=NS23+NG23, + & NS25=NS24+NG24, NS26=NS25+NG25, NS27=NS26+NG26, + & NS28=NS27+NG27, NS29=NS28+NG28 ) + +!> array contains values of NS16-NS29 + integer, dimension(NBLOW:NBHGH) :: NGS + data NGS / NS16, NS17, NS18, NS19, NS20, NS21, NS22, & + & NS23, NS24, NS25, NS26, NS27, NS28, NS29 / + +!> reverse checking of band index for each g-point + integer, dimension(NGPTSW) :: NGB + data NGB(:) / 16,16,16,16,16,16, & ! band 16 + & 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17 + & 18,18,18,18,18,18,18,18, & ! band 18 + & 19,19,19,19,19,19,19,19, & ! band 19 + & 20,20,20,20,20,20,20,20,20,20, & ! band 20 + & 21,21,21,21,21,21,21,21,21,21, & ! band 21 + & 22,22, & ! band 22 + & 23,23,23,23,23,23,23,23,23,23, & ! band 23 + & 24,24,24,24,24,24,24,24, & ! band 24 + & 25,25,25,25,25,25, & ! band 25 + & 26,26,26,26,26,26, & ! band 26 + & 27,27,27,27,27,27,27,27, & ! band 27 + & 28,28,28,28,28,28, & ! band 28 + & 29,29,29,29,29,29,29,29,29,29,29,29 / ! band 29 + +!> \name Starting/ending wavenumber for each of the SW bands + real (kind=kind_phys), dimension(NBANDS):: wvnum1, wvnum2 + data wvnum1(:) / & + & 2600.0, 3251.0, 4001.0, 4651.0, 5151.0, 6151.0, 7701.0, & + & 8051.0,12851.0,16001.0,22651.0,29001.0,38001.0, 820.0 / + data wvnum2(:) / & + & 3250.0, 4000.0, 4650.0, 5150.0, 6150.0, 7700.0, 8050.0, & + & 12850.0,16000.0,22650.0,29000.0,38000.0,50000.0, 2600.0 / + +! +!........................................! + end module module_radsw_parameters ! +!========================================! +!! @} diff --git a/gsmphys/rascnvv2.f b/gsmphys/rascnvv2.f new file mode 100644 index 00000000..2dfccfc7 --- /dev/null +++ b/gsmphys/rascnvv2.f @@ -0,0 +1,4321 @@ + module module_ras + USE MACHINE , ONLY : kind_phys + use physcons, grav => con_g, cp => con_cp, alhl => con_hvap & + &, alhf => con_hfus, rgas => con_rd, rkap => con_rocp & + &, nu => con_FVirt, pi => con_pi + implicit none + SAVE +! + integer, parameter :: nrcmax=32 ! Maximum # of random clouds per 1200s + + real (kind=kind_phys), parameter :: delt_c=1800.0/3600.0 & +! Adjustment time scales in hrs for deep and shallow clouds +! &, adjts_d=3.0, adjts_s=0.5 +! &, adjts_d=2.5, adjts_s=0.5 + &, adjts_d=2.0, adjts_s=0.5 +! + logical, parameter :: fix_ncld_hr=.true. +! + real (kind=kind_phys), parameter :: ZERO=0.0, HALF=0.5 & + &, ONE=1.0, TWO=2.0, FOUR=4.& + &, FOUR_P2=4.E2, ONE_M10=1.E-10 & + &, ONE_M6=1.E-6, ONE_M5=1.E-5 & + &, ONE_M2=1.E-2, ONE_M1=1.E-1 & + &, cmb2pa = 100.0 ! Conversion from Mb to Pa +! + real(kind=kind_phys), parameter :: & + & ONEBG = ONE / GRAV, GRAVCON = cmb2pa * ONEBG & + &, GRAVFAC = GRAV / CMB2PA, ELOCP = ALHL / CP & + &, ELFOCP = (ALHL+ALHF) / CP & +! &, RKAPI = ONE / RKAP, RKPP1I = ONE / (ONE+RKAP) & + &, CMPOR = CMB2PA / RGAS & + &, zfac = 0.28888889E-4 * ONEBG +! +! logical, parameter :: advcld=.true., advups=.true., advtvd=.false. + logical, parameter :: advcld=.true., advups=.false., advtvd=.true. +! logical, parameter :: advcld=.true., advups=.false.,advtvd=.false. +! + real(kind=kind_phys) RHMAX, qudfac, QUAD_LAM, RHRAM, TESTMB, & + & TSTMBI, HCRITD, DD_DP, RKNOB, AFC, EKNOB& + &, shalfac,HCRITS, HPERT_FAC + +! PARAMETER (DD_DP=1000.0, RKNOB=1.0, EKNOB=1.0) ! No downdraft! + PARAMETER (DD_DP=500.0, RKNOB=1.0, EKNOB=1.0) +! PARAMETER (DD_DP=500.0, RKNOB=2.0, EKNOB=1.0) +! + PARAMETER (RHMAX=1.0 ) ! MAX RELATIVE HUMIDITY + PARAMETER (QUAD_LAM=1.0) ! MASK FOR QUADRATIC LAMBDA +! PARAMETER (RHRAM=0.15) ! PBL RELATIVE HUMIDITY RAMP + PARAMETER (RHRAM=0.05) ! PBL RELATIVE HUMIDITY RAMP + PARAMETER (HCRITD=4000.0) ! Critical Moist Static Energy + PARAMETER (HCRITS=2000.0) ! Critical Moist Static Energy + +! parameter (hpert_fac=1.01) ! Perturbation on hbl when ctei=.true. +! parameter (hpert_fac=1.005)! Perturbation on hbl when ctei=.true. +! parameter (hpert_fac=1.00) ! Perturbation on hbl when ctei=.true. +! parameter (qudfac=quad_lam*half, shalfac=1.0) +! parameter (qudfac=quad_lam*half, shalfac=2.0) + parameter (qudfac=quad_lam*half, shalfac=3.0) +! parameter (qudfac=quad_lam*0.25) ! Yogesh's + parameter (testmb=0.1, tstmbi=one/testmb) +! + real(kind=kind_phys) ALMIN1, ALMIN2, ALMAX + real(kind=kind_phys) facdt +! +! PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=1.0E-2) + PARAMETER (ALMIN1=0.00E-6, ALMIN2=0.00E-5, ALMAX=1.0E-2) +! PARAMETER (ALMIN1=0.00E-6, ALMIN2=4.00E-5, ALMAX=1.0E-2) +!cnt PARAMETER (ALMIN1=0.00E-6, ALMIN2=2.50E-5, ALMAX=5.0E-3) +! +! real(kind=kind_phys), parameter :: BLDMAX = 200.0 + real(kind=kind_phys), parameter :: BLDMAX = 300.0 +!! real(kind=kind_phys), parameter :: BLDMAX = 350.0 +! + real(kind=kind_phys) C0, C0I, QI0, QW0, c00, c00i, dlq_fac + PARAMETER (QI0=1.0E-5, QW0=1.0E-5) +! PARAMETER (QI0=1.0E-4, QW0=1.0E-5) ! 20050509 +! PARAMETER (QI0=1.0E-5, QW0=1.0E-6) +!!! PARAMETER (C0I=1.0E-3) + PARAMETER (C00I=1.0E-3) +! PARAMETER (C00I=2.0E-3) +! parameter (c0=1.0e-3) +! parameter (c0=1.5e-3) +!!! parameter (c0=2.0e-3) + parameter (c00=2.0e-3) +! + real(kind=kind_phys) TF, TCR, TCRF, TCL +! parameter (TF=130.16, TCR=160.16, TCRF=1.0/(TCR-TF),TCL=2.0) +! parameter (TF=230.16, TCR=260.16, TCRF=1.0/(TCR-TF)) +! parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF),TCL=2.0) + parameter (TF=258.16, TCR=273.16, TCRF=1.0/(TCR-TF),TCL=2.0) +! +! For Tilting Angle Specification +! + real(kind=kind_phys) REFP(6), REFR(6), TLAC(8), PLAC(8), TLBPL(7) & + &, drdp(5), VTP +! + DATA PLAC/100.0, 200.0, 300.0, 400.0, 500.0, 600.0, 700.0, 800.0/ + DATA TLAC/ 35.0, 25.0, 20.0, 17.5, 15.0, 12.5, 10.0, 7.5/ + DATA REFP/500.0, 300.0, 250.0, 200.0, 150.0, 100.0/ + DATA REFR/ 1.0, 2.0, 3.0, 4.0, 6.0, 8.0/ +! + real(kind=kind_phys) AC(16), AD(16) +! + integer, parameter :: nqrp=500001 + real(kind=kind_phys) C1XQRP, C2XQRP, TBQRP(NQRP), TBQRA(NQRP) & + &, TBQRB(NQRP) +! + integer, parameter :: nvtp=10001 + real(kind=kind_phys) C1XVTP, C2XVTP, TBVTP(NVTP) +! + contains +! + subroutine set_ras_afc(dt) + implicit none + real(kind=kind_phys) DT +! AFC = -(1.04E-4*DT)*(3600./DT)**0.578 + AFC = -(1.01097E-4*DT)*(3600./DT)**0.57777778 + end subroutine set_ras_afc + + subroutine ras_init(levs, me) +! + Implicit none +! + integer levs, me +! + real(kind=kind_phys) actp, facm, tem, actop, tem1, tem2 + integer i, l + PARAMETER (ACTP=1.7, FACM=1.00) +! + real(kind=kind_phys) PH(15), A(15) +! + DATA PH/150.0, 200.0, 250.0, 300.0, 350.0, 400.0, 450.0, 500.0 & + &, 550.0, 600.0, 650.0, 700.0, 750.0, 800.0, 850.0/ +! + DATA A/ 1.6851, 1.1686, 0.7663, 0.5255, 0.4100, 0.3677 & + &, 0.3151, 0.2216, 0.1521, 0.1082, 0.0750, 0.0664 & + &, 0.0553, 0.0445, 0.0633/ +! + logical first + data first/.true./ +! + if (first) then +! set critical workfunction arrays + ACTOP = ACTP*FACM + DO L=1,15 + A(L) = A(L)*FACM + ENDDO + DO L=2,15 + TEM = 1.0 / (PH(L) - PH(L-1)) + AC(L) = (PH(L)*A(L-1) - PH(L-1)*A(L)) * TEM + AD(L) = (A(L) - A(L-1)) * TEM + ENDDO + AC(1) = ACTOP + AC(16) = A(15) + AD(1) = 0.0 + AD(16) = 0.0 +! + CALL SETQRP + CALL SETVTP +! + do i=1,7 + tlbpl(i) = (tlac(i)-tlac(i+1)) / (plac(i)-plac(i+1)) + enddo + do i=1,5 + drdp(i) = (REFR(i+1)-REFR(i)) / (REFP(i+1)-REFP(i)) + enddo +! + VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 +! + if (me == 0) print *,' NO DOWNDRAFT FOR CLOUD TYPES' & + &, ' DETRAINING WITHIN THE BOTTOM ',DD_DP,' hPa LAYERS' +! + first = .false. + endif +! + end subroutine ras_init + end module module_ras +! + module module_rascnv +! + USE MACHINE , ONLY : kind_phys + implicit none + SAVE +! +! logical REVAP, CUMFRC + logical CUMFRC + LOGICAL WRKFUN, CALKBL, CRTFUN, UPDRET, BOTOP, vsmooth + + real(kind=kind_phys), parameter :: frac=0.5, crtmsf=0.0 & + &, rhfacs=0.70, rhfacl=0.70 & + &, face=5.0, delx=10000.0 & + &, ddfac=face*delx*0.001 & + &, max_neg_bouy=0.15 +! &, max_neg_bouy=0.25 + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! real(kind=kind_phys) FRAC, CRTMSF, MAX_NEG_BOUY, rhfacs, rhfacl & +!! &, FACE, DELX, DDFAC +! parameter (frac=0.1, crtmsf=0.0) +! parameter (frac=0.25, crtmsf=0.0) +!! parameter (frac=0.5, crtmsf=0.0) +! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.false.) +! PARAMETER (MAX_NEG_BOUY=0.15, REVAP=.true., CUMFRC=.true.) +! PARAMETER (MAX_NEG_BOUY=0.10, REVAP=.true., CUMFRC=.true.) +! PARAMETER (MAX_NEG_BOUY=0.20, REVAP=.true., CUMFRC=.true.) +!! PARAMETER (MAX_NEG_BOUY=0.25, REVAP=.true., CUMFRC=.true.) +! PARAMETER (MAX_NEG_BOUY=0.30, REVAP=.true., CUMFRC=.true.) +!! PARAMETER (MAX_NEG_BOUY=0.05, REVAP=.true., CUMFRC=.true.) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! PARAMETER ( REVAP = .true., CUMFRC=.true.) + PARAMETER ( CUMFRC=.true.) + PARAMETER (WRKFUN = .FALSE., UPDRET = .FALSE., vsmooth=.false.) +! PARAMETER (CRTFUN = .TRUE., CALKBL = .false., BOTOP=.true.) + PARAMETER (CRTFUN = .TRUE., CALKBL = .true., BOTOP=.true.) +! +!! parameter (rhfacs=0.70, rhfacl=0.70) +! parameter (rhfacs=0.75, rhfacl=0.75) +! parameter (rhfacs=0.85, rhfacl=0.85) +! parameter (rhfacs=0.80, rhfacl=0.80) ! August 26, 2008 +! parameter (rhfacs=0.80, rhfacl=0.85) +!! PARAMETER (FACE=5.0, DELX=10000.0, DDFAC=FACE*DELX*0.001) +! +! real (kind=kind_phys), parameter :: pgftop=0.7, pgfbot=0.3 & +! real (kind=kind_phys), parameter :: pgftop=0.75, pgfbot=0.35 & +! For pressure gradient force in momentum mixing +! real (kind=kind_phys), parameter :: pgftop=0.80, pgfbot=0.30 & +! No pressure gradient force in momentum mixing + real (kind=kind_phys), parameter :: pgftop=0.0, pgfbot=0.0 & +! real (kind=kind_phys), parameter :: pgftop=0.55, pgfbot=0.55 & + &, pgfgrad=(pgfbot-pgftop)*0.001 +! + end module module_rascnv +! +! + subroutine rascnv(IM, IX, k, dt, dtf, rannum & + &, tin, qin, uin, vin, ccin, trac, fscav& + &, prsi, prsl, prsik, prslk, phil, phii & + &, KPBL, CDRAG, RAINC, kbot, ktop, kcnv & + &, DDVEL, FLIPV, facmb, me, garea, lmh, ccwfac& + &, nrcm, rhc, ud_mf, dd_mf, det_mf, dlqfac & + &, lprnt, ipr, kdt, revap & + &, QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3 & + &, CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,ncld) +! &, lprnt, ipr, kdt, fscav, ctei_r, ctei_rm) +! +!********************************************************************* +!********************************************************************* +!************ Relaxed Arakawa-Schubert ****************** +!************ Parameterization ****************** +!************ Plug Compatible Driver ****************** +!************ 23 May 2002 ****************** +!************ ****************** +!************ Developed By ****************** +!************ ****************** +!************ Shrinivas Moorthi ****************** +!************ ****************** +!************ EMC/NCEP ****************** +!********************************************************************* +!********************************************************************* +! +! + USE MACHINE , ONLY : kind_phys + use module_ras, DPD => DD_DP + use module_rascnv + Implicit none +! + LOGICAL FLIPV, lprnt,revap +! +! input +! + Integer IM, IX, k, ncrnd, me, trac, ipr, nrcm, ncld, kdt + integer, dimension(im) :: kbot, ktop, kcnv, kpbl, lmh +! + real(kind=kind_phys), dimension(ix,k) :: tin, qin, uin, vin & + &, prsl, prslk, phil + real(kind=kind_phys), dimension(ix,k+1) :: prsi, prsik, phii + real(kind=kind_phys), dimension(im,k) :: ud_mf, dd_mf, det_mf & + &, rhc, qlcn, qicn, w_upi & + &, cnv_mfd, cnv_prc3 & + &, cnv_dqldt, clcn & + &, cnv_fice, cnv_ndrop & + &, cnv_nice, cf_upi + real(kind=kind_phys), dimension(im) :: ccwfac, rainc, cdrag & + &, ddvel, garea + real(kind=kind_phys), dimension(ix,nrcm):: rannum + real(kind=kind_phys) ccin(ix,k,trac+2) + real(kind=kind_phys) dlqfac, DT, facmb, dtf +! +! Added for aerosol scavenging for GOCART +! + real(kind=kind_phys), intent(in) :: fscav(trac) + +! &, ctei_r(im), ctei_rm +! +! locals +! + real(kind=kind_phys), dimension(k) :: toi, qoi, tcu, qcu & + &, pcu, clw, cli, qii, qli & + &, phi_l,prsm,psjm & + &, alfinq, alfind, rhc_l + real(kind=kind_phys), dimension(k+1) :: prs, psj, phi_h, flx, flxd + + + integer, parameter :: icm = 100 + real, parameter :: DAYLEN=86400.0, PFAC=1.0/450.0 & + &, clwmin=1.0e-10 + Integer IC(ICM) +! + real(kind=kind_phys), allocatable :: ALFINT(:,:), uvi(:,:) + &, trcfac(:,:), rcu(:,:) + real(kind=kind_phys) dtvd(2,4) +! &, DPI(K), psjp(k+1) + real(kind=kind_phys) CFAC, TEM, sgc, ccwf, tem1, tem2 & + &, rain,wfnc,tla,pl,qiid,qlid +! + Integer KCR, KFX, NCMX, NC, KTEM, I, L, lm1 & + &, ntrc, ia, ll, km1, kp1, ipt, lv, KBL, n & + &, lmhij, KRMIN, KRMAX, KFMAX, kblmx, irnd,ib + real(kind=kind_phys) sgcs(k,im) +! + LOGICAL DNDRFT, lprint +! LOGICAL DNDRFT, lprint, ctei +! +! Scavenging related parameters +! + real fscav_(trac+2) ! Fraction scavenged per km +! +! write(0,*)' fscav=',fscav,' trac=',trac + + fscav_ = 0.0 ! By default no scavenging + if (trac > 0) then + do i=1,trac + fscav_(i) = fscav(i) + enddo + endif + + if (lprnt) write(0,*)' in RAS fscav=',fscav_,' ccwfac=', + & ccwfac(ipr),' ncld=',ncld +! + km1 = k - 1 + kp1 = k + 1 +! + dlq_fac = dlqfac + tem = 1.0 + dlq_fac + c0 = c00 * tem + c0i = c00i * tem +! + ntrc = trac + IF (CUMFRC) THEN + ntrc = ntrc + 2 + ENDIF + if (ntrc > 0) then + if (.not. allocated(trcfac)) allocate (trcfac(k,ntrc)) + if (.not. allocated(uvi)) allocate (uvi(k,ntrc)) + if (.not. allocated(rcu)) allocate (rcu(k,ntrc)) + do n=1, ntrc + do l=1,k + trcfac(l,n) = 1.0 ! For other tracers + rcu(l,n) = 0.0 + enddo + enddo + endif +! +!!!!! initialization for microphysics ACheng + if(ncld == 2) then + do l=1,K + do i=1,im + QLCN(i,l) = 0.0 + QICN(i,l) = 0.0 + w_upi(i,l) = 0.0 + cf_upi(i,l) = 0.0 + CNV_MFD(i,l) = 0.0 + CNV_PRC3(i,l) = 0.0 + CNV_DQLDT(i,l) = 0.0 + CLCN(i,l) = 0.0 + CNV_FICE(i,l) = 0.0 + CNV_NDROP(i,l) = 0.0 + CNV_NICE(i,l) = 0.0 + enddo + enddo + endif +! + if (.not. allocated(alfint)) allocate(alfint(k,ntrc+4)) +! + call set_ras_afc(dt) +! + DO IPT=1,IM + + ccwf = 0.5 + if (ccwfac(ipt) >= 0.0) ccwf = ccwfac(ipt) + +! +! ctei = .false. +! if (ctei_r(ipt) > ctei_rm) ctei = .true. +! + + do l=1,k + ud_mf(ipt,l) = 0.0 + dd_mf(ipt,l) = 0.0 + det_mf(ipt,l) = 0.0 + enddo +! +! Compute NCRND : here LMH is the number of layers above the +! bottom surface. For sigma coordinate LMH=K. +! if flipv is true, then input variables are from bottom +! to top while RAS goes top to bottom +! + LMHIJ = LMH(ipt) + if (flipv) then + ll = kp1 - LMHIJ + tem = 1.0 / prsi(ipt,ll) + else + ll = LMHIJ + tem = 1.0 / prsi(ipt,ll+1) + endif + KRMIN = 1 + KRMAX = km1 + KFMAX = KRMAX + kblmx = 1 + DO L=1,LMHIJ-1 + ll = l + if (flipv) ll = kp1 -l ! Input variables are bottom to top! + SGC = prsl(ipt,ll) * tem + sgcs(l,ipt) = sgc + IF (SGC <= 0.050) KRMIN = L +! IF (SGC <= 0.700) KRMAX = L +! IF (SGC <= 0.800) KRMAX = L + IF (SGC <= 0.760) KRMAX = L +! IF (SGC <= 0.930) KFMAX = L + IF (SGC <= 0.970) KFMAX = L ! Commented on 20060202 +! IF (SGC <= 0.700) kblmx = L ! Commented on 20101015 + IF (SGC <= 0.600) kblmx = L ! +! IF (SGC <= 0.650) kblmx = L ! Commented on 20060202 + ENDDO + krmin = max(krmin,2) + +! if (lprnt .and. ipt == ipr) print *,' krmin=',krmin,' krmax=', +! &krmax,' kfmax=',kfmax,' lmhij=',lmhij,' tem=',tem +! + if (fix_ncld_hr) then +!!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.50001 + NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/1200) + 0.10001 +!! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/600) + 0.50001 +! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * (DTF/360) + 0.50001 +! & + 0.50001 +! NCRND = min(nrcmax, (KRMAX-KRMIN+1)) * min(1.0,DTF/360) + 0.1 + facdt = delt_c / dt + else + NCRND = min(nrcmax, (KRMAX-KRMIN+1)) + facdt = 1.0 / 3600.0 + endif + NCRND = min(nrcm,max(NCRND, 1)) +! + KCR = MIN(LMHIJ,KRMAX) + KTEM = MIN(LMHIJ,KFMAX) + KFX = KTEM - KCR + +! if(lprnt)print*,' enter RASCNV k=',k,' ktem=',ktem,' LMHIJ=' +! &, LMHIJ +! &, ' krmax=',krmax,' kfmax=',kfmax +! &, ' kcr=',kcr, ' cdrag=',cdrag(ipr) + + IF (KFX > 0) THEN + IF (BOTOP) THEN + DO NC=1,KFX + IC(NC) = KTEM + 1 - NC + ENDDO + ELSE + DO NC=KFX,1,-1 + IC(NC) = KTEM + 1 - NC + ENDDO + ENDIF + ENDIF +! + NCMX = KFX + NCRND + IF (NCRND > 0) THEN + DO I=1,NCRND + IRND = (RANNUM(ipt,I)-0.0005)*(KCR-KRMIN+1) + IC(KFX+I) = IRND + KRMIN + ENDDO + ENDIF +! +! ia = 1 +! +! print *,' in rascnv: k=',k,'lat=',lat,' lprnt=',lprnt +! if (lprnt) then +! if (me == 0) then +! print *,' tin',(tin(ia,l),l=k,1,-1) +! print *,' qin',(qin(ia,l),l=k,1,-1) +! endif +! +! + lprint = lprnt .and. ipt == ipr +! lprint = lprnt + do l=1,k + ll = l + if (flipv) ll = kp1 -l ! Input variables are bottom to top! + CLW(l) = 0.0 ! Assumes initial value of Cloud water + CLI(l) = 0.0 ! Assumes initial value of Cloud ice + ! to be zero i.e. no environmental condensate!!! + QII(l) = 0.0 + QLI(l) = 0.0 +! Initialize heating, drying, cloudiness etc. + tcu(l) = 0.0 + qcu(l) = 0.0 + pcu(l) = 0.0 + flx(l) = 0.0 + flxd(l) = 0.0 + do n=1,ntrc + rcu(l,n) = 0.0 + enddo +! Transfer input prognostic data into local variable + toi(l) = tin(ipt,ll) + qoi(l) = qin(ipt,ll) +! + if (ntrc > trac) then ! CUMFRC is true + uvi(l,trac+1) = uin(ipt,ll) + uvi(l,trac+2) = vin(ipt,ll) + endif +! + if (trac > 0) then ! tracers such as O3, dust etc + do n=1,trac + uvi(l,n) = ccin(ipt,ll,n+2) + if (abs(uvi(l,n)) < 1.0e-20) uvi(l,n) = 0.0 + enddo + endif +! + enddo + flx(k+1) = 0.0 + flxd(k+1) = 0.0 +! + if (ccin(ipt,1,2) <= -999.0) then ! input ice/water are together + do l=1,k + ll = l + if (flipv) ll = kp1 -l ! Input variables are bottom to top! + tem = ccin(ipt,ll,1) & + & * MAX(ZERO, MIN(ONE, (TCR-toi(L))*TCRF)) + ccin(ipt,ll,2) = ccin(ipt,ll,1) - tem + ccin(ipt,ll,1) = tem + enddo + endif + if (advcld) then + do l=1,k + ll = l + if (flipv) ll = kp1 -l ! Input variables are bottom to top! + QII(L) = ccin(ipt,ll,1) + QLI(L) = ccin(ipt,ll,2) + enddo + endif +! + KBL = KPBL(ipt) + if (flipv) KBL = MAX(MIN(k, kp1-KPBL(ipt)), k/2) + rain = 0.0 +! + DO L=1,kp1 + ll = l + if (flipv) ll = kp1 + 1 - l ! Input variables are bottom to top! + PRS(LL) = prsi(ipt, L) * facmb ! facmb is for conversion to MB + PSJ(LL) = prsik(ipt,L) + phi_h(LL) = phii(ipt,L) + ENDDO +! + DO L=1,k + ll = l + if (flipv) ll = kp1 - l ! Input variables are bottom to top! + PRSM(LL) = prsl(ipt, L) * facmb ! facmb is for conversion to MB + PSJM(LL) = prslk(ipt,L) + phi_l(LL) = phil(ipt,L) + rhc_l(LL) = rhc(ipt,L) + ENDDO +! +! if (lprnt .and. ipt == ipr) print *,' phi_h=',phi_h(:) +! if(lprint) print *,' PRS=',PRS +! if(lprint) print *,' PRSM=',PRSM +! if (lprint) then +! print *,' qns=',qns(ia),' qoi=',qn0(ia,k),'qin=',qin(ia,1) +! if (me == 0) then +! print *,' toi',(tn0(ia,l),l=1,k) +! print *,' qoi',(qn0(ia,l),l=1,k),' kbl=',kbl +! endif +! +! +! do l=k,kctop(1),-1 +!! DPI(L) = 1.0 / (PRS(L+1) - PRS(L)) +! enddo +! +! print *,' ipt=',ipt + + if (advups) then ! For first order upstream for updraft + alfint(:,:) = 1.0 + elseif (advtvd) then ! TVD flux limiter scheme for updraft + alfint(:,:) = 1.0 + l = krmin + lm1 = l - 1 + dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & + & + alhl*(qoi(l)-qoi(lm1)) + dtvd(1,2) = qoi(l) - qoi(lm1) + dtvd(1,3) = qli(l) - qli(lm1) + dtvd(1,4) = qii(l) - qii(lm1) + do l=krmin+1,k + lm1 = l - 1 + +! print *,' toi=',toi(l),toi(lm1),' phi_l=',phi_l(l),phi_l(lm1) +! &,' qoi=',qoi(l),qoi(lm1),' cp=',cp,' alhl=',alhl + + dtvd(2,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) & + & + alhl*(qoi(l)-qoi(lm1)) + +! print *,' l=',l,' dtvd=',dtvd(:,1) + + if (abs(dtvd(2,1)) > 1.0e-10) then + tem1 = dtvd(1,1) / dtvd(2,1) + tem2 = abs(tem1) + alfint(l,1) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for h + endif + +! print *,' alfint=',alfint(l,1),' l=',l,' ipt=',ipt + + dtvd(1,1) = dtvd(2,1) +! + dtvd(2,2) = qoi(l) - qoi(lm1) + +! print *,' l=',l,' dtvd2=',dtvd(:,2) + + if (abs(dtvd(2,2)) > 1.0e-10) then + tem1 = dtvd(1,2) / dtvd(2,2) + tem2 = abs(tem1) + alfint(l,2) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for q + endif + dtvd(1,2) = dtvd(2,2) +! + dtvd(2,3) = qli(l) - qli(lm1) + +! print *,' l=',l,' dtvd3=',dtvd(:,3) + + if (abs(dtvd(2,3)) > 1.0e-10) then + tem1 = dtvd(1,3) / dtvd(2,3) + tem2 = abs(tem1) + alfint(l,3) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for ql + endif + dtvd(1,3) = dtvd(2,3) +! + dtvd(2,4) = qii(l) - qii(lm1) + +! print *,' l=',l,' dtvd4=',dtvd(:,4) + + if (abs(dtvd(2,4)) > 1.0e-10) then + tem1 = dtvd(1,4) / dtvd(2,4) + tem2 = abs(tem1) + alfint(l,4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for qi + endif + dtvd(1,4) = dtvd(2,4) + enddo +! + if (ntrc > 0) then + do n=1,ntrc + l = krmin + dtvd(1,1) = uvi(l,n) - uvi(l-1,n) + do l=krmin+1,k + dtvd(2,1) = uvi(l,n) - uvi(l-1,n) + +! print *,' l=',l,' dtvdn=',dtvd(:,1),' n=',n,' l=',l + + if (abs(dtvd(2,1)) > 1.0e-10) then + tem1 = dtvd(1,1) / dtvd(2,1) + tem2 = abs(tem1) + alfint(l,n+4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for tracers + endif + dtvd(1,1) = dtvd(2,1) + enddo + enddo + endif + else + alfint(:,:) = 0.5 ! For second order scheme + endif + alfind(:) = 0.5 +! +! print *,' after alfint for ipt=',ipt + +! Resolution dependent press grad correction momentum mixing + + if (CUMFRC) then + do l=krmin,k + tem = 1.0 - max(pgfbot, min(pgftop, pgftop+pgfgrad*prsm(l))) + trcfac(l,trac+1) = tem + trcfac(l,trac+2) = tem + enddo + endif +! +! lprint = lprnt .and. ipt == ipr + +! if (lprint) then +! print *,' trcfac=',trcfac(krmin:k,1+trac) +! print *,' alfint=',alfint(krmin:k,1) +! print *,' alfinq=',alfint(krmin:k,2) +! print *,' alfini=',alfint(krmin:k,4) +! print *,' alfinu=',alfint(krmin:k,5) +! endif +! + if (calkbl) kbl = k + DO NC=1,NCMX +! + IB = IC(NC) + if (ib > kbl) cycle + +! lprint = lprnt .and. ipt == ipr +! lprint = lprnt .and. ipt == ipr .and. ib == 41 +! + DNDRFT = DPD > 0.0 +! +! if (lprint) print *,' calling cloud type ib=',ib,' kbl=',kbl +! *, ' kpbl=',kpbl,' alfint=',alfint,' frac=',frac +! *, ' ntrc=',ntrc,' ipt=',ipt +! +!**************************************************************************** +! if (advtvd) then ! TVD flux limiter scheme for updraft +! l = ib +! lm1 = l - 1 +! dtvd(1,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) +! & + alhl*(qoi(l)-qoi(lm1)) +! dtvd(1,2) = qoi(l) - qoi(lm1) +! dtvd(1,3) = qli(l) - qli(lm1) +! dtvd(1,4) = qii(l) - qii(lm1) +! do l=ib+1,k +! lm1 = l - 1 +! dtvd(2,1) = cp*(toi(l)-toi(lm1)) + phi_l(l)-phi_l(lm1) +! & + alhl*(qoi(l)-qoi(lm1)) +! if (abs(dtvd(2,1)) > 1.0e-10) then +! tem1 = dtvd(1,1) / dtvd(2,1) +! tem2 = abs(tem1) +! alfint(l,1) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for h +! endif +! dtvd(1,1) = dtvd(2,1) +! +! dtvd(2,2) = qoi(l) - qoi(lm1) +! if (abs(dtvd(2,2)) > 1.0e-10) then +! tem1 = dtvd(1,2) / dtvd(2,2) +! tem2 = abs(tem1) +! alfint(l,2) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for q +! endif +! dtvd(1,2) = dtvd(2,2) +! +! dtvd(2,3) = qli(l) - qli(lm1) +! if (abs(dtvd(2,3)) > 1.0e-10) then +! tem1 = dtvd(1,3) / dtvd(2,3) +! tem2 = abs(tem1) +! alfint(l,3) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for ql +! endif +! dtvd(1,3) = dtvd(2,3) +! +! dtvd(2,4) = qii(l) - qii(lm1) +! if (abs(dtvd(2,4)) > 1.0e-10) then +! tem1 = dtvd(1,4) / dtvd(2,4) +! tem2 = abs(tem1) +! alfint(l,4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for qi +! endif +! dtvd(1,4) = dtvd(2,4) +! enddo +! +! if (ntrc > 0) then +! do n=1,ntrc +! l = ib +! dtvd(1,1) = uvi(l,n) - uvi(l-1,n) +! do l=ib+1,k +! dtvd(2,1) = uvi(l,n) - uvi(l-1,n) +! if (abs(dtvd(2,1)) > 1.0e-10) then +! tem1 = dtvd(1,1) / dtvd(2,1) +! tem2 = abs(tem1) +! alfint(l,n+4) = 1.0 - 0.5*(tem1 + tem2)/(1.0 + tem2) ! for tracers +! endif +! dtvd(1,1) = dtvd(2,1) +! enddo +! enddo +! endif +! endif +!**************************************************************************** +! +! if (lprint) then +! ia = ipt +! print *,' toi=',(toi(ia,l),l=1,K) +! print *,' qoi=',(qoi(ia,l),l=1,K),' kbl=',kbl +! print *,' toi=',(toi(l),l=1,K) +! print *,' qoi=',(qoi(l),l=1,K),' kbl=',kbl +! print *,' prs=',(prs(l),l=1,K) +! endif +! + WFNC = 0.0 + do L=IB,K+1 + FLX(L) = 0.0 + FLXD(L)= 0.0 + enddo +! +! if(lprint)then +! print *,' CALLING CLOUD TYPE IB= ', IB,' DT=',DT,' K=',K +! &, 'ipt=',ipt +! print *,' TOI=',(TOI(L),L=IB,K) +! print *,' QOI=',(QOI(L),L=IB,K) +! print *,' qliin=',qli +! print *,' qiiin=',qii +! endif +! + TLA = -10.0 +! + qiid = qii(ib) ! cloud top level ice before convection + qlid = qli(ib) ! cloud top level water before convection +! + CALL CLOUD(lmhij, IB, ntrc, kblmx & + &, FRAC, MAX_NEG_BOUY, vsmooth & + &, REVAP, WRKFUN, CALKBL, CRTFUN, DNDRFT, lprint & + &, DT, KDT, TLA, DPD & + &, ALFINT, rhfacl, rhfacs, garea(ipt) & + &, ccwf, CDRAG(ipt), trcfac & + &, alfind, rhc_l, phi_l, phi_h, PRS, PRSM,sgcs(1,ipt) & + &, TOI, QOI, UVI, QLI, QII, KBL, DDVEL(ipt) & + &, TCU, QCU, RCU, PCU, FLX, FLXD, RAIN, WFNC, fscav_ & + & ) +! &, ctei) + +! if (lprint) then +! print *,' rain=',rain,' ipt=',ipt +! print *,' after calling CLOUD TYPE IB= ', IB & +! &,' rain=',rain,' prskd=',prs(ib),' qli=',qli(ib),' qii=',qii(ib) +! print *,' phi_h=',phi_h(K-5:K+1) +! print *,' TOI=',(TOI(L),L=1,K),' me=',me,' ib=',ib +! print *,' QOI=',(QOI(L),L=1,K) +! print *,' qliou=',qli +! print *,' qiiou=',qii +! endif +! + do L=IB,K + ll = l + if (flipv) ll = kp1 -l ! Input variables are bottom to top! + ud_mf(ipt,ll) = ud_mf(ipt,ll) + flx(l+1) + dd_mf(ipt,ll) = dd_mf(ipt,ll) + flxd(l+1) + enddo + ll = ib + if (flipv) ll = kp1 - ib + det_mf(ipt,ll) = det_mf(ipt,ll) + flx(ib) + +! Anning Cheng for microphysics 11/14/2015 + if (ncld == 2) then + if (lprint) write(0,*)' ib=',ib,' flx=',flx(ib),' ll=',ll + &,' ud_mf=',ud_mf(ipt,:) + CNV_MFD(ipt,ll) = CNV_MFD(ipt,ll) + flx(ib)/dt + if (lprint) write(0,*)' ib=',ib,' CNV_MFD=',CNV_MFD(ipt,ll) + &,' ll=',ll,' kp1=',kp1 +! CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) +! & + max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt + CNV_DQLDT(ipt,ll) = CNV_DQLDT(ipt,ll) + flx(ib)* + & max(0.,(QLI(ib)+QII(ib)-qiid-qlid))/dt +! & max(0.,(QLI(ib)+QII(ib)))/dt/3. + if(flx(ib)<0) write(*,*)"AAA666", flx(ib),QLI(ib),QII(ib) + & ,ipt,ll + end if +! +! +! Warining!!!! +! ------------ +! By doing the following, CLOUD does not contain environmental +! condensate! +! + if (.not. advcld) then + do l=1,K + clw(l ) = clw(l) + QLI(L) + cli(l ) = cli(l) + QII(L) + QLI(L) = 0.0 + QII(L) = 0.0 + enddo + endif +! + ENDDO ! End of the NC loop! +! + RAINC(ipt) = rain * 0.001 ! Output rain is in meters + +! if (lprint) then +! print*,' convective precip=',rain*86400/dt,' mm/day' +! 1, ' ipt=',ipt +! print *,' toi',(tn0(imax,l),l=1,k) +! print *,' qoi',(qn0(imax,l),l=1,k) +! endif +! + do l=1,k + ll = l + if (flipv) ll = kp1 - l + tin(ipt,ll) = toi(l) ! Temperature + qin(ipt,ll) = qoi(l) ! Specific humidity + uin(ipt,ll) = uvi(l,trac+1) ! U momentum + vin(ipt,ll) = uvi(l,trac+2) ! V momentum + +!! for 2M microphysics, always output these variables + if (ncld == 2) then + qli(l) = max(qli(l),0.) + qii(l) = max(qii(l),0.) + if (advcld) then + QLCN(ipt,ll) = max(qli(l)-ccin(ipt,ll,2), 0.0) + QICN(ipt,ll) = max(qii(l)-ccin(ipt,ll,1), 0.0) + CNV_FICE(ipt,ll) = QICN(ipt,ll) + & / max(1.e-10,QLCN(ipt,ll)+QICN(ipt,ll)) + else + QLCN(ipt,ll) = qli(l) + QICN(ipt,ll) = qii(l) + CNV_FICE(ipt,ll) = qii(l)/max(1.e-10,qii(l)+qli(l)) + endif +! CNV_PRC3(ipt,ll) = PCU(l)/dt + CNV_PRC3(ipt,ll) = 0.0 + if(PCU(l)<0.) write(*,*)"AAA777",PCU(l),ipt,ll + cf_upi(ipt,ll) = max(0.0,min(0.02*log(1.0+ + & 500*ud_mf(ipt,ll)/dt),0.25)) +! & 500*ud_mf(ipt,ll)/dt),0.60)) + CLCN(ipt,ll) = cf_upi(ipt,ll) !downdraft is below updraft + w_upi(ipt,ll) = ud_mf(ipt,ll)*toi(l)*rgas / + & (dt*max(cf_upi(ipt,ll),1.e-12)*prsl(ipt,ll)) + endif + + if (trac > 0) then + do n=1,trac + ccin(ipt,ll,n+2) = uvi(l,n) ! Tracers + enddo + endif + enddo + if (advcld) then + do l=1,k + ll = l + if (flipv) ll = kp1 - l + ccin(ipt,ll,1) = qii(l) ! Cloud ice + ccin(ipt,ll,2) = qli(l) ! Cloud water + enddo + else + do l=1,k + ll = l + if (flipv) ll = kp1 - l + ccin(ipt,ll,1) = ccin(ipt,ll,1) + cli(l) + ccin(ipt,ll,2) = ccin(ipt,ll,2) + clw(l) + enddo + endif +! + ktop(ipt) = kp1 + kbot(ipt) = 0 + + kcnv(ipt) = 0 + + do l=lmhij-1,1,-1 + if (sgcs(l,ipt) < 0.93 .and. tcu(l) .ne. 0.0) then +! if (sgcs(l,ipt) < 0.90 .and. tcu(l) .ne. 0.0) then +! if (sgcs(l,ipt) < 0.85 .and. tcu(l) .ne. 0.0) then +! if (sgcs(l,ipt) < 0.70 .and. tcu(l) .ne. 0.0) then +! if (sgcs(l,ipt) < 0.60 .and. tcu(l) .ne. 0.0) then +! if (tcu(l) .ne. 0.0) then + kcnv(ipt) = 1 + endif +! New test for convective clouds ! added in 08/21/96 + if (clw(l)+cli(l) > 0.0 .OR. & + & qli(l)+qii(l) > clwmin) ktop(ipt) = l + enddo + do l=1,km1 + if (clw(l)+cli(l) > 0.0 .OR. & + & qli(l)+qii(l) > clwmin) kbot(ipt) = l + enddo + if (flipv) then + ktop(ipt) = kp1 - ktop(ipt) + kbot(ipt) = kp1 - kbot(ipt) + endif +! +! if (lprint) then +! print *,' tin',(tin(ia,l),l=k,1,-1) +! print *,' qin',(qin(ia,l),l=k,1,-1) +! endif +! +! Velocity scale from the downdraft! +! + DDVEL(ipt) = DDVEL(ipt) * DDFAC * GRAV / (prs(K+1)-prs(k)) +! + ENDDO ! End of the IPT Loop! + + deallocate (alfint,uvi,trcfac,rcu) +! + RETURN + END + SUBROUTINE CRTWRK(PL, CCWF, ACR) + USE MACHINE , ONLY : kind_phys + use module_ras , only : ac, ad + Implicit none +! + real(kind=kind_phys) PL, CCWF, ACR + INTEGER IWK +! + IWK = PL * 0.02 - 0.999999999 + IWK = MAX(1, MIN(IWK,16)) + ACR = (AC(IWK) + PL * AD(IWK)) * CCWF +! + RETURN + END + SUBROUTINE CLOUD( & + & K, KD, NTRC, KBLMX & + &, FRACBL, MAX_NEG_BOUY, vsmooth & + &, REVAP, WRKFUN, CALKBL, CRTFUN, DNDRFT, lprnt & + &, DT, KDT, TLA, DPD & + &, ALFINT, RHFACL, RHFACS, garea, ccwf, cd, trcfac & + &, alfind, rhc_ls, phil, phih, prs, prsm, sgcs & + &, TOI, QOI, ROI, QLI, QII, KPBL, DSFC & + &, TCU, QCU, RCU, PCU, FLX, FLXD, CUP, WFNC,fscav_ & + & ) +! &, ctei) + +! +!*********************************************************************** +!******************** Relaxed Arakawa-Schubert ************************ +!****************** Plug Compatible Scalar Version ********************* +!************************ SUBROUTINE CLOUD **************************** +!************************ October 2004 **************************** +!******************** VERSION 2.0 (modified) ************************* +!************* Shrinivas.Moorthi@noaa.gov (301) 683-3718 ***** ******** +!*********************************************************************** +!*Reference: +!----------- +! NOAA Technical Report NWS/NCEP 99-01: +! Documentation of Version 2 of Relaxed-Arakawa-Schubert +! Cumulus Parameterization with Convective Downdrafts, June 1999. +! by S. Moorthi and M. J. Suarez. +! +!*********************************************************************** +! +!===> UPDATES CLOUD TENDENCIES DUE TO A SINGLE CLOUD +!===> DETRAINING AT LEVEL KD. +! +!*********************************************************************** +! +!===> TOI(K) INOUT TEMPERATURE KELVIN +!===> QOI(K) INOUT SPECIFIC HUMIDITY NON-DIMENSIONAL +!===> ROI(K,NTRC)INOUT TRACER ARBITRARY +!===> QLI(K) INOUT LIQUID WATER NON-DIMENSIONAL +!===> QII(K) INOUT ICE NON-DIMENSIONAL + +!===> PRS(K+1) INPUT PRESSURE @ EDGES MB +!===> PRSM(K) INPUT PRESSURE @ LAYERS MB +!===> SGCS(K) INPUT Local sigma +!===> PHIH(K+1) INPUT GEOPOTENTIAL @ EDGES IN MKS units +!===> PHIL(K) INPUT GEOPOTENTIAL @ LAYERS IN MKS units +!===> PRJ(K+1) INPUT (P/P0)^KAPPA @ EDGES NON-DIMENSIONAL +!===> PRJM(K) INPUT (P/P0)^KAPPA @ LAYERS NON-DIMENSIONAL + +!===> K INPUT THE RISE & THE INDEX OF THE SUBCLOUD LAYER +!===> KD INPUT DETRAINMENT LEVEL ( 1<= KD < K ) +!===> NTRC INPUT NUMBER OF TRACERS. MAY BE ZERO. +!===> kblmx INPUT highest level the pbl can take +!===> DNDRFT INPUT LOGICAL .TRUE. OR .FALSE. +!===> DPD INPUT Minumum Cloud Depth for DOWNDRFAT Computation hPa +! +!===> TCU(K ) UPDATE TEMPERATURE TENDENCY DEG +!===> QCU(K ) UPDATE WATER VAPOR TENDENCY (G/G) +!===> RCU(K,NTRC)UPDATE TRACER TENDENCIES ND +!===> PCU(K-1) UPDATE PRECIP @ BASE OF LAYER KG/M^2 +!===> FLX(K ) UPDATE MASS FLUX @ TOP OF LAYER KG/M^2 +!===> CUP UPDATE PRECIPITATION AT THE SURFACE KG/M^2 +! + USE MACHINE , ONLY : kind_phys + use module_ras + IMPLICIT NONE +! +! INPUT ARGUMENTS + +! LOGICAL REVAP, DNDRFT, WRKFUN, CALKBL, CRTFUN, CALCUP, ctei + LOGICAL REVAP, DNDRFT, WRKFUN, CALKBL, CRTFUN, CALCUP + logical vsmooth, lprnt + INTEGER K, KD, NTRC, kblmx + + + real(kind=kind_phys), dimension(K) :: TOI, QOI, PRSM, QLI, QII& + &, PHIL, SGCS, rhc_ls & + &, alfind + real(kind=kind_phys), dimension(K+1) :: PRS, PHIH + real(kind=kind_phys), dimension(K,NTRC) :: ROI, trcfac + real(kind=kind_phys) :: CD, UFN, DSFC + INTEGER :: KPBL, KBL, KB1, kdt + + real(kind=kind_phys) ALFINT(K,NTRC+4) + real(kind=kind_phys) FRACBL, MAX_NEG_BOUY, DPD, & + & RHFACL, RHFACS, garea, ccwf + +! UPDATE ARGUMENTS + + real(kind=kind_phys), dimension(K) :: TCU, QCU, TCD, QCD, PCU + real(kind=kind_phys), dimension(K+1) :: FLX, FLXD + real(kind=kind_phys), dimension(K,NTRC) :: RCU + real(kind=kind_phys) :: CUP + +! TEMPORARY WORK SPACE + + real(kind=kind_phys), dimension(KD:K) :: HOL, QOL, HST, QST & + &, TOL, GMH, AKT, AKC, BKC, LTL, RNN & + &, FCO, PRI, QIL, QLL, ZET, XI, RNS & + &, Q0U, Q0D, vtf, CIL, CLL, ETAI, dlq & + &, wrk1, wrk2, dhdp, qrb, qrt, evp & + &, ghd, gsd, etz, cldfr + + real(kind=kind_phys), dimension(KD:K+1) :: GAF, GMS, GAM, DLB & + &, DLT, ETA, PRL, BUY, ETD, HOD, QOD + real(kind=kind_phys), dimension(KD:K-1) :: etzi + + real(kind=kind_phys) fscav_(ntrc) + + LOGICAL ep_wfn, cnvflg, LOWEST, SKPDD, DDFT, UPDRET + + real(kind=kind_phys) ALM, DET, HCC, CLP & + &, HSU, HSD, QTL, QTV & + &, AKM, WFN, HOS, QOS & + &, AMB, TX1, TX2, TX3 & + &, TX4, TX5, QIS, QLS & + &, HBL, QBL, RBL(NTRC) & + &, QLB, QIB, PRIS & + &, WFNC, TX6, ACR & + &, TX7, TX8, TX9, RHC & + &, hstkd, qstkd, ltlkd, q0ukd, q0dkd, dlbkd & + &, qtp, qw00, qi00, qrbkd & + &, hstold, rel_fac, prism & + &, TL, PL, QL, QS, DQS, ST1, SGN, TAU, & + & QTVP, HB, QB, TB, QQQ, & + & HCCP, DS, DH, AMBMAX, X00, EPP, QTLP, & + & DPI, DPHIB, DPHIT, DEL_ETA, DETP, & + & TEM, TEM1, TEM2, TEM3, TEM4, & + & ST2, ST3, ST4, ST5, & + & ERRH, ERRW, ERRE, TEM5, & + & TEM6, HBD, QBD, st1s, shal_fac, hmax, hmin, & + & dhdpmn, avt, avq, avr, avh & + &, TRAIN, DOF, CLDFRD, tla, gmf & + &, FAC, RSUM1, RSUM2, RSUM3, dpneg, hcrit & + &, ACTEVAP,AREARAT,DELTAQ,MASS,MASSINV,POTEVAP & + &, TEQ,QSTEQ,DQDT,QEQ & + &, CLFRAC, DT, clf, clvfr, delzkm, fnoscav + + real(kind=kind_phys), parameter :: ERRMIN=0.0001 & + &, ERRMI2=0.1*ERRMIN + INTEGER I, L, N, KD1, II, idh, lcon & + &, KP1, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1, kbls, kmxh + &, kblh, kblm, kblpmn, kmax, kmaxm1, kmaxp1, klcl, kmin, kmxb +! + +! real(kind=kind_phys), parameter :: rainmin=1.0e-9 + real(kind=kind_phys), parameter :: rainmin=1.0e-8 + real(kind=kind_phys), parameter :: oneopt9=1.0/0.09 + real(kind=kind_phys), parameter :: oneopt4=1.0/0.04 +! +!*********************************************************************** +! + do l=1,K + tcd(L) = 0.0 + qcd(L) = 0.0 + enddo +! + KP1 = K + 1 + KM1 = K - 1 + KD1 = KD + 1 +! +! if (lprnt) then +! print *,' IN CLOUD for KD=',kd +! print *,' prs=',prs(Kd:K+1) +! print *,' phil=',phil(KD:K) +! print *,' phih=',phih(1:K+1),' kdt=',kdt +! print *,' phih=',phih(KD:K+1) +! print *,' toi=',toi +! print *,' qoi=',qoi +! endif +! + CLDFRD = 0.0 + DOF = 0.0 + PRL(KP1) = PRS(KP1) +! + DO L=KD,K + RNN(L) = 0.0 + ZET(L) = 0.0 + XI(L) = 0.0 +! + TOL(L) = TOI(L) + QOL(L) = QOI(L) + PRL(L) = PRS(L) + BUY(L) = 0.0 + CLL(L) = QLI(L) + CIL(L) = QII(L) + ENDDO +! + if (vsmooth) then + do l=kd,k + wrk1(l) = tol(l) + wrk2(l) = qol(l) + enddo + do l=kd1,km1 + tol(l) = 0.25*wrk1(l-1) + 0.5*wrk1(l) + 0.25*wrk1(l+1) + qol(l) = 0.25*wrk2(l-1) + 0.5*wrk2(l) + 0.25*wrk2(l+1) + enddo + endif +! + DO L=KD, K + DPI = ONE / (PRL(L+1) - PRL(L)) + PRI(L) = GRAVFAC * DPI +! + PL = PRSM(L) + TL = TOL(L) + + AKT(L) = (PRL(L+1) - PL) * DPI +! + CALL QSATCN(TL, PL, QS, DQS) +! CALL QSATCN(TL, PL, QS, DQS,lprnt) +! + QST(L) = QS + GAM(L) = DQS * ELOCP + ST1 = ONE + GAM(L) + GAF(L) = (ONE/ALHL) * GAM(L)/ST1 + + QL = MAX(MIN(QS*RHMAX,QOL(L)), ONE_M10) + QOL(L) = QL + + TEM = CP * TL + LTL(L) = TEM * ST1 / (ONE+NU*(QST(L)+TL*DQS)) + vtf(L) = 1.0 + NU * QL + ETA(L) = ONE / (LTL(L) * VTF(L)) + + HOL(L) = TEM + QL * ALHL + HST(L) = TEM + QS * ALHL +! + ENDDO +! + ETA(K+1) = ZERO + GMS(K) = ZERO +! + AKT(KD) = HALF + GMS(KD) = ZERO +! + CLP = ZERO +! + GAM(K+1) = GAM(K) + GAF(K+1) = GAF(K) +! + DO L=K,KD1,-1 + DPHIB = PHIL(L) - PHIH(L+1) + DPHIT = PHIH(L) - PHIL(L) +! + DLB(L) = DPHIB * ETA(L) + DLT(L) = DPHIT * ETA(L) +! + QRB(L) = DPHIB + QRT(L) = DPHIT +! + ETA(L) = ETA(L+1) + DPHIB + + HOL(L) = HOL(L) + ETA(L) + hstold = hst(l) + HST(L) = HST(L) + ETA(L) +! + ETA(L) = ETA(L) + DPHIT + ENDDO +! +! For the cloud top layer +! + L = KD + + DPHIB = PHIL(L) - PHIH(L+1) +! + DLB(L) = DPHIB * ETA(L) +! + QRB(L) = DPHIB + QRT(L) = DPHIB +! + ETA(L) = ETA(L+1) + DPHIB + + HOL(L) = HOL(L) + ETA(L) + HST(L) = HST(L) + ETA(L) +! +! if (kd == 12) then +! if (lprnt) then +! print *,' IN CLOUD for KD=',KD,' K=',K +! print *,' l=',l,' hol=',hol(l),' hst=',hst(l) +! print *,' TOL=',tol +! print *,' qol=',qol +! print *,' hol=',hol +! print *,' hst=',hst +! endif +! endif +! +! To determine KBL internally -- If KBL is defined externally +! the following two loop should be skipped +! +! if (lprnt) print *,' calkbl=',calkbl + + hcrit = hcritd + if (sgcs(kd) > 0.65) hcrit = hcrits + IF (CALKBL) THEN + KTEM = MAX(KD+1, KBLMX) + hmin = hol(k) + kmin = k + do l=km1,kd,-1 + if (hmin > hol(l)) then + hmin = hol(l) + kmin = l + endif + enddo + if (kmin == k) return + hmax = hol(k) + kmax = k + do l=km1,ktem,-1 + if (hmax < hol(l)) then + hmax = hol(l) + kmax = l + endif + enddo + kmxb = kmax + if (kmax < kmin) then + kmax = k + kmxb = k + hmax = hol(kmax) + elseif (kmax < k) then + do l=kmax+1,k + if (abs(hol(kmax)-hol(l)) > 0.5 * hcrit) then + kmxb = l - 1 + exit + endif + enddo + endif + kmaxm1 = kmax - 1 + kmaxp1 = kmax + 1 + kblpmn = kmax +! + dhdp(kmax:k) = 0.0 + dhdpmn = dhdp(kmax) + do l=kmaxm1,ktem,-1 + dhdp(l) = (HOL(L)-HOL(L+1)) / (PRL(L+2)-PRL(L)) + if (dhdp(l) < dhdpmn) then + dhdpmn = dhdp(l) + kblpmn = l + 1 + elseif (dhdp(l) > 0.0 .and. l <= kmin) then + exit + endif + enddo + kbl = kmax + if (kblpmn < kmax) then + do l=kblpmn,kmaxm1 + if (hmax-hol(l) < 0.5*hcrit) then + kbl = l + exit + endif + enddo + endif + +! if(lprnt) print *,' kbl=',kbl,' kbls=',kbls,' kmax=',kmax +! + klcl = kd1 + if (kmax > kd1) then + do l=kmaxm1,kd1,-1 + if (hmax > hst(l)) then + klcl = l+1 + exit + endif + enddo + endif +! if(lprnt) print *,' klcl=',klcl,' ii=',ii +! if (klcl == kd .or. klcl < ktem) return + +! This is to handle mid-level convection from quasi-uniform h + + if (kmax < kmxb) then + kmax = max(kd1, min(kmxb,k)) + kmaxm1 = kmax - 1 + kmaxp1 = kmax + 1 + endif + + +! if (prl(Kmaxp1) - prl(klcl) > 250.0 ) return + + ii = max(kbl,kd1) + kbl = max(klcl,kd1) + tem = min(50.0,max(10.0,(prl(kmaxp1)-prl(kd))*0.10)) + if (prl(kmaxp1) - prl(ii) > tem .and. ii > kbl) kbl = ii + +! if(lprnt) print *,' kbl2=',kbl,' ii=',ii + + if (kbl .ne. ii) then + if (PRL(kmaxp1)-PRL(KBL) > bldmax) kbl = max(kbl,ii) + endif + if (kbl < ii) then + if (hol(ii)-hol(ii-1) > 0.5*hcrit) kbl = ii + endif + +! if (prl(kbl) - prl(klcl) > 300.0 ) return + if (prl(kbl) - prl(klcl) > 250.0 ) return +! + KBL = min(kmax, MAX(KBL,KBLMX)) +! kbl = min(kblh,kbl) +!!! +! tem1 = max(prl(k+1)-prl(k), & +! & min((prl(kbl) - prl(kd))*0.05, 10.0)) +!! & min((prl(kbl) - prl(kd))*0.05, 20.0)) +!! & min((prl(kbl) - prl(kd))*0.05, 30.0)) +! if (prl(k+1)-prl(kbl) < tem1) then +! KTEM = MAX(KD+1, KBLMX) +! do l=k,KTEM,-1 +! tem = prl(k+1) - prl(l) +! if (tem > tem1) then +! kbl = min(kbl,l) +! exit +! endif +! enddo +! endif +! if (kbl == kblmx .and. kmax >= k-1) kbl = k - 1 +!!! + + KPBL = KBL + +! if(lprnt)print*,' 1st kbl=',kbl,' kblmx=',kblmx,' kd=',kd +! if(lprnt)print*,' tx3=',tx3,' tx1=',tx1,' tem=',tem +! 1, ' hcrit=',hcrit + + ELSE + KBL = KPBL +! if(lprnt)print*,' 2nd kbl=',kbl + ENDIF + +! if(lprnt)print*,' after CALKBL l=',l,' hol=',hol(l) +! 1, ' hst=',hst(l) +! + KBL = min(kmax,MAX(KBL,KD+2)) + KB1 = KBL - 1 +!! +! if (lprnt) print *,' kbl=',kbl,' prlkbl=',prl(kbl),prl(k+1) + + if(PRL(Kmaxp1)-PRL(KBL) > bldmax .or. kb1 <= kd) then + return + endif +! +! if (lprnt) print *,' kbl=',kbl +! write(0,*)' kbl=',kbl,' kmax=',kmax,' kmaxp1=',kmaxp1,' k=',k +! + PRIS = ONE / (PRL(K+1)-PRL(KBL)) + PRISM = ONE / (PRL(Kmaxp1)-PRL(KBL)) + TX1 = ETA(KBL) +! + GMS(KBL) = 0.0 + XI(KBL) = 0.0 + ZET(KBL) = 0.0 +! + shal_fac = 1.0 +! if (prl(kbl)-prl(kd) < 300.0 .and. kmax == k) shal_fac = shalfac + if (prl(kbl)-prl(kd) < 350.0 .and. kmax == k) shal_fac = shalfac + DO L=Kmax,KD,-1 + IF (L >= KBL) THEN + ETA(L) = (PRL(Kmaxp1)-PRL(L)) * PRISM + ELSE + ZET(L) = (ETA(L) - TX1) * ONEBG + XI(L) = ZET(L) * ZET(L) * (QUDFAC*shal_fac) + ETA(L) = ZET(L) - ZET(L+1) + GMS(L) = XI(L) - XI(L+1) + ENDIF +! if (lprnt) print *,' l=',l,' eta=',eta(l),' kbl=',kbl + ENDDO + if (kmax < k) then + do l=kmaxp1,kp1 + eta(l) = 0.0 + enddo + endif +! + HBL = HOL(Kmax) * ETA(Kmax) + QBL = QOL(Kmax) * ETA(Kmax) + QLB = CLL(Kmax) * ETA(Kmax) + QIB = CIL(Kmax) * ETA(Kmax) + TX1 = QST(Kmax) * ETA(Kmax) +! + DO L=Kmaxm1,KBL,-1 + TEM = ETA(L) - ETA(L+1) + HBL = HBL + HOL(L) * TEM + QBL = QBL + QOL(L) * TEM + QLB = QLB + CLL(L) * TEM + QIB = QIB + CIL(L) * TEM + TX1 = TX1 + QST(L) * TEM + ENDDO + +! if (ctei .and. sgcs(kd) > 0.65) then +! hbl = hbl * hpert_fac +! qbl = qbl * hpert_fac +! endif + +! if (lprnt) print *,' hbl=',hbl,' qbl=',qbl +! Find Min value of HOL in TX2 + TX2 = HOL(KD) + IDH = KD1 + DO L=KD1,KB1 + IF (HOL(L) < TX2) THEN + TX2 = HOL(L) + IDH = L ! Level of minimum moist static energy! + ENDIF + ENDDO + IDH = 1 + IDH = MAX(KD1, IDH) +! + TEM1 = HBL - HOL(KD) + TEM = HBL - HST(KD1) - LTL(KD1) * NU *(QOL(KD1)-QST(KD1)) + LOWEST = KD == KB1 + + lcon = kd + do l=kb1,kd1,-1 + if (hbl >= hst(l)) then + lcon = l + exit + endif + enddo +! + if (lcon == kd .or. kbl <= kd .or. prl(kbl)-prsm(lcon) > 150.0) & + & return +! + TX1 = RHFACS - QBL / TX1 ! Average RH + + cnvflg = (TEM > ZERO .OR. (LOWEST .AND. TEM1 >= ZERO)) & + & .AND. (TX1 < RHRAM) + +! if(lprnt) print *,' cnvflg=',cnvflg,' tem=',tem,' tem1=',tem1 +! &,' tx1=',tx1,' rhram=',rhram,' kbl=',kbl,' kd=',kd,' lowest=' +! &,lowest,' rhfacs=',rhfacs,' ltl=',ltl(kd1),' qol=',qol(kd1) +! &,' qst=',qst(kd1),' hst=',hst(kd1),' nu=',nu +! if(lprnt .and. (.not. cnvflg)) print *,' tx1=',tx1,' rhfacs=' +! &,rhfacs, ' tem=',tem,' hst=',hst(kd1) + + IF (.NOT. cnvflg) RETURN +! + RHC = MAX(ZERO, MIN(ONE, EXP(-20.0*TX1) )) +! + if (ntrc > 0) then + DO N=1,NTRC + RBL(N) = ROI(Kmax,N) * ETA(Kmax) + ENDDO + DO N=1,NTRC + DO L=KmaxM1,KBL,-1 + RBL(N) = RBL(N) + ROI(L,N)*(ETA(L)-ETA(L+1)) + ENDDO + ENDDO + endif +! + TX4 = 0.0 + TX5 = 0.0 +! + TX3 = QST(KBL) - GAF(KBL) * HST(KBL) + DO L=KBL,K + QIL(L) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(L))*TCRF)) + ENDDO +! + DO L=KB1,KD1,-1 + TEM = QST(L) - GAF(L) * HST(L) + TEM1 = (TX3 + TEM) * 0.5 + ST2 = (GAF(L)+GAF(L+1)) * 0.5 +! + FCO(L+1) = TEM1 + ST2 * HBL + +! if(lprnt) print *,' fco=',fco(l+1),' tem1=',tem1,' st2=',st2 +! &,' hbl=',hbl,' tx3=',tx3,' tem=',tem,' gaf=',gaf(l),' l=',l + + RNN(L+1) = ZET(L+1) * TEM1 + ST2 * TX4 + GMH(L+1) = XI(L+1) * TEM1 + ST2 * TX5 +! + TX3 = TEM + TX4 = TX4 + ETA(L) * HOL(L) + TX5 = TX5 + GMS(L) * HOL(L) +! + QIL(L) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(L))*TCRF)) + QLL(L+1) = (0.5*ALHF) * ST2 * (QIL(L)+QIL(L+1)) + ONE + ENDDO +! +! FOR THE CLOUD TOP -- L=KD +! + L = KD +! + TEM = QST(L) - GAF(L) * HST(L) + TEM1 = (TX3 + TEM) * 0.5 + ST2 = (GAF(L)+GAF(L+1)) * 0.5 +! + FCO(L+1) = TEM1 + ST2 * HBL + RNN(L+1) = ZET(L+1) * TEM1 + ST2 * TX4 + GMH(L+1) = XI(L+1) * TEM1 + ST2 * TX5 +! + FCO(L) = TEM + GAF(L) * HBL + RNN(L) = TEM * ZET(L) + (TX4 + ETA(L)*HOL(L)) * GAF(L) + GMH(L) = TEM * XI(L) + (TX5 + GMS(L)*HOL(L)) * GAF(L) +! +! Replace FCO for the Bottom +! + FCO(KBL) = QBL + RNN(KBL) = 0.0 + GMH(KBL) = 0.0 +! + QIL(KD) = MAX(ZERO, MIN(ONE, (TCR-TCL-TOL(KD))*TCRF)) + QLL(KD1) = (0.5*ALHF) * ST2 * (QIL(KD) + QIL(KD1)) + ONE + QLL(KD ) = ALHF * GAF(KD) * QIL(KD) + ONE +! +! if (lprnt) then +! print *,' fco=',fco(kd:kbl) +! print *,' qil=',qil(kd:kbl) +! print *,' qll=',qll(kd:kbl) +! endif +! + st1 = qil(kd) + st2 = c0i * st1 + tem = c0 * (1.0-st1) + tem2 = st2*qi0 + tem*qw0 +! + DO L=KD,KB1 + tx2 = akt(l) * eta(l) + tx1 = tx2 * tem2 + q0u(l) = tx1 + FCO(L) = FCO(L+1) - FCO(L) + tx1 + RNN(L) = RNN(L+1) - RNN(L) & + & + ETA(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*zet(l) + GMH(L) = GMH(L+1) - GMH(L) & + & + GMS(L)*(QOL(L)+CLL(L)+CIL(L)) + tx1*xi(l) +! + tem1 = (1.0-akt(l)) * eta(l) + +! if(lprnt) print *,' qll=',qll(l),' st2=',st2,' tem=',tem +! &,' tx2=',tx2,' akt=',akt(l),' eta=',eta(l) + + AKT(L) = QLL(L) + (st2 + tem) * tx2 + +! if(lprnt) print *,' akt==',akt(l),' l==',l + + AKC(L) = 1.0 / AKT(L) +! + st1 = 0.5 * (qil(l)+qil(l+1)) + st2 = c0i * st1 + tem = c0 * (1.0-st1) + tem2 = st2*qi0 + tem*qw0 +! + BKC(L) = QLL(L+1) - (st2 + tem) * tem1 +! + tx1 = tem1*tem2 + q0d(l) = tx1 + FCO(L) = FCO(L) + tx1 + RNN(L) = RNN(L) + tx1*zet(l+1) + GMH(L) = GMH(L) + tx1*xi(l+1) + ENDDO + +! if(lprnt) print *,' akt=',akt(kd:kb1) +! if(lprnt) print *,' akc=',akc(kd:kb1) + + qw00 = qw0 + qi00 = qi0 + ii = 0 + 777 continue +! +! if (lprnt) print *,' after 777 ii=',ii,' ep_wfn=',ep_wfn +! + ep_wfn = .false. + RNN(KBL) = 0.0 + TX3 = bkc(kb1) * (QIB + QLB) + TX4 = 0.0 + TX5 = 0.0 + DO L=KB1,KD1,-1 + TEM = BKC(L-1) * AKC(L) +! if (lprnt) print *,' tx3=',tx3,' fco=',fco(l),' akc=',akc(l) +! &,' bkc=',bkc(l-1), ' l=',l + TX3 = (TX3 + FCO(L)) * TEM + TX4 = (TX4 + RNN(L)) * TEM + TX5 = (TX5 + GMH(L)) * TEM + ENDDO + IF (KD < KB1) THEN + HSD = HST(KD1) + LTL(KD1) * NU *(QOL(KD1)-QST(KD1)) + ELSE + HSD = HBL + ENDIF +! +! if (lprnt) print *,' tx3=',tx3,' fco=',fco(kd),' akc=',akc(kd) + + TX3 = (TX3 + FCO(KD)) * AKC(KD) + TX4 = (TX4 + RNN(KD)) * AKC(KD) + TX5 = (TX5 + GMH(KD)) * AKC(KD) + ALM = ALHF*QIL(KD) - LTL(KD) * VTF(KD) +! + HSU = HST(KD) + LTL(KD) * NU * (QOL(KD)-QST(KD)) + +! if (lprnt) print *,' hsu=',hsu,' hst=',hst(kd), +! &' ltl=',ltl(kd),' qol=',qol(kd),' qst=',qst(kd) +! +!===> VERTICAL INTEGRALS NEEDED TO COMPUTE THE ENTRAINMENT PARAMETER +! + TX1 = ALM * TX4 + TX2 = ALM * TX5 + + DO L=KD,KB1 + TAU = HOL(L) - HSU + TX1 = TX1 + TAU * ETA(L) + TX2 = TX2 + TAU * GMS(L) + ENDDO +! +! MODIFY HSU TO INCLUDE CLOUD LIQUID WATER AND ICE TERMS +! +! if (lprnt) print *,' hsu=',hsu,' alm=',alm,' tx3=',tx3 + + HSU = HSU - ALM * TX3 +! + CLP = ZERO + ALM = -100.0 + HOS = HOL(KD) + QOS = QOL(KD) + QIS = CIL(KD) + QLS = CLL(KD) + cnvflg = HBL > HSU .and. abs(tx1) > 1.0e-4 + +! if (lprnt) print *,' ii=',ii,' cnvflg=',cnvflg,' hsu=',hsu +! &,' hbl=',hbl,' tx1=',tx1,' hsd=',hsd + + +!*********************************************************************** + + + ST1 = HALF*(HSU + HSD) + IF (cnvflg) THEN +! +! STANDARD CASE: +! CLOUD CAN BE NEUTRALLY BOUYANT AT MIDDLE OF LEVEL KD W/ +VE LAMBDA. +! EPP < .25 IS REQUIRED TO HAVE REAL ROOTS. +! + clp = 1.0 + st2 = hbl - hsu + +! if(lprnt) print *,' tx2=',tx2,' tx1=',tx1,' st2=',st2 +! + if (tx2 == 0.0) then + alm = - st2 / tx1 + if (alm > almax) alm = -100.0 + else + x00 = tx2 + tx2 + epp = tx1 * tx1 - (x00+x00)*st2 + if (epp > 0.0) then + x00 = 1.0 / x00 + tem = sqrt(epp) + tem1 = (-tx1-tem)*x00 + tem2 = (-tx1+tem)*x00 + if (tem1 > almax) tem1 = -100.0 + if (tem2 > almax) tem2 = -100.0 + alm = max(tem1,tem2) + +! if (lprnt) print *,' tem1=',tem1,' tem2=',tem2,' alm=',alm +! &,' tx1=',tx1,' tem=',tem,' epp=',epp,' x00=',x00,' st2=',st2 + + endif + endif + +! if (lprnt) print *,' almF=',alm,' ii=',ii,' qw00=',qw00 +! &,' qi00=',qi00 +! +! CLIP CASE: +! NON-ENTRAINIG CLOUD DETRAINS IN LOWER HALF OF TOP LAYER. +! NO CLOUDS ARE ALLOWED TO DETRAIN BELOW THE TOP LAYER. +! + ELSEIF ( (HBL <= HSU) .AND. & + & (HBL > ST1 ) ) THEN + ALM = ZERO +! CLP = (HBL-ST1) / (HSU-ST1) ! commented on Jan 16, 2010 + ENDIF +! + cnvflg = .TRUE. + IF (ALMIN1 > 0.0) THEN + IF (ALM >= ALMIN1) cnvflg = .FALSE. + ELSE + LOWEST = KD == KB1 + IF ( (ALM > ZERO) .OR. & + & (.NOT. LOWEST .AND. ALM == ZERO) ) cnvflg = .FALSE. + ENDIF +! +!===> IF NO SOUNDING MEETS SECOND CONDITION, RETURN +! + IF (cnvflg) THEN + IF (ii > 0 .or. (qw00 == 0.0 .and. qi00 == 0.0)) RETURN + CLP = 1.0 + ep_wfn = .true. + GO TO 888 + ENDIF +! +! if (lprnt) print *,' hstkd=',hst(kd),' qstkd=',qst(kd) +! &,' ii=',ii,' clp=',clp + + st1s = ONE + IF(CLP > ZERO .AND. CLP < ONE) THEN + ST1 = HALF*(ONE+CLP) + ST2 = ONE - ST1 + st1s = st1 + hstkd = hst(kd) + qstkd = qst(kd) + ltlkd = ltl(kd) + q0ukd = q0u(kd) + q0dkd = q0d(kd) + dlbkd = dlb(kd) + qrbkd = qrb(kd) +! + HST(KD) = HST(KD)*ST1 + HST(KD1)*ST2 + HOS = HOL(KD)*ST1 + HOL(KD1)*ST2 + QST(KD) = QST(KD)*ST1 + QST(KD1)*ST2 + QOS = QOL(KD)*ST1 + QOL(KD1)*ST2 + QLS = CLL(KD)*ST1 + CLL(KD1)*ST2 + QIS = CIL(KD)*ST1 + CIL(KD1)*ST2 + LTL(KD) = LTL(KD)*ST1 + LTL(KD1)*ST2 +! + DLB(KD) = DLB(KD)*CLP + qrb(KD) = qrb(KD)*CLP + ETA(KD) = ETA(KD)*CLP + GMS(KD) = GMS(KD)*CLP + Q0U(KD) = Q0U(KD)*CLP + Q0D(KD) = Q0D(KD)*CLP + ENDIF +! +! +!*********************************************************************** +! +! Critical workfunction is included in this version +! + ACR = 0.0 + TEM = PRL(KD1) - (PRL(KD1)-PRL(KD)) * CLP * HALF + tx1 = PRL(KBL) - TEM + tx2 = min(900.0,max(tx1,100.0)) + tem1 = log(tx2*0.01) / log(10.0) + if ( kdt == 1 ) then + rel_fac = (dt * facdt) / (tem1*12.0 + (1-tem1)*3.0) + else + rel_fac = (dt * facdt) / (tem1*adjts_d + (1-tem1)*adjts_s) + endif +! +! rel_fac = max(zero, min(one,rel_fac)) + rel_fac = max(zero, min(half,rel_fac)) + + IF (CRTFUN) THEN + CALL CRTWRK(TEM, CCWF, ST1) + ACR = TX1 * ST1 + ENDIF +! +!===> NORMALIZED MASSFLUX +! +! ETA IS THE THICKNESS COMING IN AND THE MASS FLUX GOING OUT. +! GMS IS THE THICKNESS OF THE SQUARE; IT IS LATER REUSED FOR GAMMA_S +! +! ETA(K) = ONE + + DO L=KB1,KD,-1 + ETA(L) = ETA(L+1) + ALM * (ETA(L) + ALM * GMS(L)) + ENDDO + DO L=KD,KBL + ETAI(L) = 1.0 / ETA(L) + ENDDO + +! if (lprnt) print *,' eta=',eta,' ii=',ii,' alm=',alm +! +!===> CLOUD WORKFUNCTION +! + WFN = ZERO + AKM = ZERO + DET = ZERO + HCC = HBL + cnvflg = .FALSE. + QTL = QST(KB1) - GAF(KB1)*HST(KB1) + TX1 = HBL +! + qtv = qbl + det = qlb + qib +! + tx2 = 0.0 + dpneg = 0.0 +! + DO L=KB1,KD1,-1 + DEL_ETA = ETA(L) - ETA(L+1) + HCCP = HCC + DEL_ETA*HOL(L) +! + QTLP = QST(L-1) - GAF(L-1)*HST(L-1) + QTVP = 0.5 * ((QTLP+QTL)*ETA(L) & + & + (GAF(L)+GAF(L-1))*HCCP) + ST1 = ETA(L)*Q0U(L) + ETA(L+1)*Q0D(L) + DETP = (BKC(L)*DET - (QTVP-QTV) & + & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) + ST1) * AKC(L) + +! if(lprnt) print *,' detp=',detp,' bkc=',bkc(l),' det=',det +! if (lprnt .and. kd == 15) +! & print *,' detp=',detp,' bkc=',bkc(l),' det=',det +! &,' qtvp=',qtvp,' qtv=',qtv,' del_eta=',del_eta,' qol=' +! &,qol(l),' st1=',st1,' akc=',akc(l) +! + TEM1 = AKT(L) - QLL(L) + TEM2 = QLL(L+1) - BKC(L) + RNS(L) = TEM1*DETP + TEM2*DET - ST1 + + qtp = 0.5 * (qil(L)+qil(L-1)) + tem2 = min(qtp*(detp-eta(l)*qw00), & + & (1.0-qtp)*(detp-eta(l)*qi00)) + st1 = min(tx2,tem2) + tx2 = tem2 +! + IF (rns(l) < zero .or. st1 < zero) ep_wfn = .TRUE. + IF (DETP <= ZERO) cnvflg = .TRUE. + + ST1 = HST(L) - LTL(L)*NU*(QST(L)-QOL(L)) + + + TEM2 = HCCP + DETP * QTP * ALHF +! +! if(lprnt) print *,' hst=',hst(l),' ltl=',ltl(l),' nu=',nu +! if (lprnt .and. kd == 15) +! & print *,' hst=',hst(l),' ltl=',ltl(l),' nu=',nu +! &,' qst=',qst(l),' qol=',qol(l),' hccp=',hccp,' detp=',detp +! *,' qtp=',qtp,' alhf=',alhf,' vtf=',vtf(l) + + ST2 = LTL(L) * VTF(L) + TEM5 = CLL(L) + CIL(L) + TEM3 = (TX1 - ETA(L+1)*ST1 - ST2*(DET-TEM5*eta(l+1))) * DLB(L) + TEM4 = (TEM2 - ETA(L )*ST1 - ST2*(DETP-TEM5*eta(l))) * DLT(L) +! +! if (lprnt) then +! if (lprnt .and. kd == 12) then +! print *,' tem3=',tem3,' tx1=',tx1,' st1=',st1,' eta1=',eta(l+1) +! &, ' st2=',st2,' det=',det,' tem5=',tem5,' dlb=',dlb(l) +! print *,' tem4=',tem4,' tem2=',tem2,' detp=',detp +! &, ' eta=',eta(l),' dlt=',dlt(l),' rns=',rns(l),' l=',l +! print *,' bt1=',tem3/(eta(l+1)*qrb(l)) +! &, ' bt2=',tem4/(eta(l)*qrt(l)) +! endif + + ST1 = TEM3 + TEM4 + +! if (lprnt) print *,' wfn=',wfn,' st1=',st1,' l=',l,' ep_wfn=', +! &ep_wfn,' akm=',akm + + WFN = WFN + ST1 + AKM = AKM - min(ST1,ZERO) + +! if (lprnt) print *,' wfn=',wfn,' akm=',akm + + if (st1 < zero .and. wfn < zero) then + dpneg = dpneg + prl(l+1) - prl(l) + endif + + BUY(L) = 0.5 * (tem3/(eta(l+1)*qrb(l)) + tem4/(eta(l)*qrt(l))) +! + HCC = HCCP + DET = DETP + QTL = QTLP + QTV = QTVP + TX1 = TEM2 + + ENDDO + + DEL_ETA = ETA(KD) - ETA(KD1) + HCCP = HCC + DEL_ETA*HOS +! + QTLP = QST(KD) - GAF(KD)*HST(KD) + QTVP = QTLP*ETA(KD) + GAF(KD)*HCCP + ST1 = ETA(KD)*Q0U(KD) + ETA(KD1)*Q0D(KD) + DETP = (BKC(KD)*DET - (QTVP-QTV) & + & + DEL_ETA*(QOS+QLS+QIS) + ST1) * AKC(KD) +! + TEM1 = AKT(KD) - QLL(KD) + TEM2 = QLL(KD1) - BKC(KD) + RNS(KD) = TEM1*DETP + TEM2*DET - ST1 +! + IF (rns(kd) < zero) ep_wfn = .TRUE. + IF (DETP <= ZERO) cnvflg = .TRUE. +! + 888 continue + +! if (lprnt) print *,' ep_wfn=',ep_wfn,' ii=',ii,' rns=',rns(kd) +! &,' clp=',clp,' hst(kd)=',hst(kd) + + if (ep_wfn) then + IF ((qw00 == 0.0 .and. qi00 == 0.0)) RETURN + if (ii == 0) then + ii = 1 + if (clp > 0.0 .and. clp < 1.0) then + hst(kd) = hstkd + qst(kd) = qstkd + ltl(kd) = ltlkd + q0u(kd) = q0ukd + q0d(kd) = q0dkd + dlb(kd) = dlbkd + qrb(kd) = qrbkd + endif + do l=kd,kb1 + FCO(L) = FCO(L) - q0u(l) - q0d(l) + RNN(L) = RNN(L) - q0u(l)*zet(l) - q0d(l)*zet(l+1) + GMH(L) = GMH(L) - q0u(l)*xi(l) - q0d(l)*zet(l+1) + ETA(L) = ZET(L) - ZET(L+1) + GMS(L) = XI(L) - XI(L+1) + Q0U(L) = 0.0 + Q0D(L) = 0.0 + ENDDO + qw00 = 0.0 + qi00 = 0.0 + +! if (lprnt) print *,' returning to 777 : ii=',ii,' qw00=',qw00,qi00 +! &,' clp=',clp,' hst(kd)=',hst(kd) + + go to 777 + else + cnvflg = .true. + endif + endif +! +! +! ST1 = 0.5 * (HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) +! & + HST(KD1) - LTL(KD1)*NU*(QST(KD1)-QOL(KD1))) +! + ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) + ST2 = LTL(KD) * VTF(KD) + TEM5 = (QLS + QIS) * eta(kd1) + ST1 = HALF * (TX1-ETA(KD1)*ST1-ST2*(DET-TEM5))*DLB(KD) +! +! if (lprnt) print *,' st1=',st1,' st2=',st2,' ltl=',ltl(kd) +! *,ltl(kd1),' qos=',qos,qol(kd1) + + WFN = WFN + ST1 + AKM = AKM - min(ST1,ZERO) ! Commented on 08/26/02 - does not include top +! + + BUY(KD) = ST1 / (ETA(KD1)*qrb(kd)) +! +! if (lprnt) print *,' wfn=',wfn,' akm=',akm,' st1=',st1 +! &,' dpneg=',dpneg + + DET = DETP + HCC = HCCP + AKM = AKM / WFN + + +!*********************************************************************** +! +! If only to calculate workfunction save it and return +! + IF (WRKFUN) THEN + IF (WFN >= 0.0) WFNC = WFN + RETURN + ELSEIF (.NOT. CRTFUN) THEN + ACR = WFNC + ENDIF +! +!===> THIRD CHECK BASED ON CLOUD WORKFUNCTION +! + CALCUP = .FALSE. + + TEM = max(0.05, MIN(CD*200.0, MAX_NEG_BOUY)) + IF (WFN > ACR .AND. (.NOT. cnvflg) & +! & .and. dpneg < 100.0 .AND. AKM <= TEM) THEN + & .and. dpneg < 150.0 .AND. AKM <= TEM) THEN +! & .and. dpneg < 200.0 .AND. AKM <= TEM) THEN +! + CALCUP = .TRUE. + ENDIF + +! if (lprnt) print *,' calcup=',calcup,' akm=',akm,' tem=',tem +! *,' cnvflg=',cnvflg,' clp=',clp,' rhc=',rhc,' cd=',cd,' acr=',acr +! +!===> IF NO SOUNDING MEETS THIRD CONDITION, RETURN +! + IF (.NOT. CALCUP) RETURN +! +! This is for not LL - 20050601 + IF (ALMIN2 .NE. 0.0) THEN + IF (ALMIN1 .NE. ALMIN2) ST1 = 1.0 / max(ONE_M10,(ALMIN2-ALMIN1)) + IF (ALM < ALMIN2) THEN + CLP = CLP * max(0.0, min(1.0,(0.3 + 0.7*(ALM-ALMIN1)*ST1))) +! CLP = CLP * max(0.0, min(1.0,(0.2 + 0.8*(ALM-ALMIN1)*ST1))) +! CLP = CLP * max(0.0, min(1.0,(0.1 + 0.9*(ALM-ALMIN1)*ST1))) + ENDIF + ENDIF +! +! if (lprnt) print *,' clp=',clp +! + CLP = CLP * RHC + dlq = 0.0 + tem = 1.0 / (1.0 + dlq_fac) + do l=kd,kb1 + rnn(l) = rns(l) * tem + dlq(l) = rns(l) * tem * dlq_fac + enddo + DO L=KBL,K + RNN(L) = 0.0 + ENDDO +! if (lprnt) print *,' rnn=',rnn +! +! If downdraft is to be invoked, do preliminary check to see +! if enough rain is available and then call DDRFT. +! + DDFT = .FALSE. + IF (DNDRFT) THEN +! + TRAIN = 0.0 + IF (CLP > 0.0) THEN + DO L=KD,KB1 + TRAIN = TRAIN + RNN(L) + ENDDO + ENDIF + + PL = (PRL(KD1) + PRL(KD))*HALF + TEM = PRL(K+1)*(1.0-DPD*0.001) + IF (TRAIN > 1.0E-4 .AND. PL <= TEM) DDFT = .TRUE. +! + ENDIF +! +! if (lprnt) then +! print *,' BEFORE CALLING DDRFT KD=',kd,' DDFT=',DDFT +! &, ' PL=',PL,' TRAIN=',TRAIN +! print *,' buy=',(buy(l),l=kd,kb1) +! endif + + IF (DDFT) THEN ! Downdraft scheme based on (Cheng and Arakawa, 1997) + CALL DDRFT( & + & K, KD & + &, TLA, ALFIND & + &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF & +! &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF, HBL, QBL & + &, QRB, QRT, BUY, KBL, IDH, ETA, RNN, ETAI & + &, ALM, WFN, TRAIN, DDFT & + &, ETD, HOD, QOD, EVP, DOF, CLDFR, ETZ & + &, GMS, GSD, GHD, lprnt) + + ENDIF +! +! No Downdraft case (including case with no downdraft solution) +! --------------------------------------------------------- +! + IF (.NOT. DDFT) THEN + DO L=KD,K+1 + ETD(L) = 0.0 + HOD(L) = 0.0 + QOD(L) = 0.0 + ENDDO + DO L=KD,K + EVP(L) = 0.0 + ETZ(L) = 0.0 + ENDDO + + ENDIF + +! if (lprnt) print *,' hod=',hod +! if (lprnt) print *,' etd=',etd +! +! +!===> CALCULATE GAMMAS i.e. TENDENCIES PER UNIT CLOUD BASE MASSFLUX +! Includes downdraft terms! + + avh = 0.0 + +! +! Fraction of detrained condensate evaporated +! +! tem1 = max(ZERO, min(HALF, (prl(kd)-FOUR_P2)*ONE_M2)) +! tem1 = max(ZERO, min(HALF, (prl(kd)-300.0)*0.005)) + tem1 = 0.0 +! tem1 = 1.0 +! if (kd1 == kbl) tem1 = 0.0 +! + tem2 = 1.0 - tem1 + TEM = DET * QIL(KD) + + + st1 = (HCC+ALHF*TEM-ETA(KD)*HST(KD)) / (1.0+gam(KD)) + DS = ETA(KD1) * (HOS- HOL(KD)) - ALHL*(QOS - QOL(KD)) + DH = ETA(KD1) * (HOS- HOL(KD)) + + + GMS(KD) = (DS + st1 - tem1*det*alhl-tem*alhf) * PRI(KD) + GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOS + DH) + + +! if (lprnt) print *,' gmhkd=',gmh(kd),' gmskd=',gms(kd) +! &,' det=',det,' tem=',tem,' tem1=',tem1,' tem2=',tem2 +! +! TENDENCY FOR SUSPENDED ENVIRONMENTAL ICE AND/OR LIQUID WATER +! + QLL(KD) = (tem2*(DET-TEM) + ETA(KD1)*(QLS-CLL(KD)) & + & + (1.0-QIL(KD))*dlq(kd) - ETA(KD)*QLS ) * PRI(KD) + + QIL(KD) = (tem2*TEM + ETA(KD1)*(QIS-CIL(KD)) & + & + QIL(KD)*dlq(kd) - ETA(KD)*QIS ) * PRI(KD) +! + GHD(KD) = 0.0 + GSD(KD) = 0.0 +! + DO L=KD1,K + ST1 = ONE - ALFINT(L,1) + ST2 = ONE - ALFINT(L,2) + ST3 = ONE - ALFINT(L,3) + ST4 = ONE - ALFINT(L,4) + ST5 = ONE - ALFIND(L) + HB = ALFINT(L,1)*HOL(L-1) + ST1*HOL(L) + QB = ALFINT(L,2)*QOL(L-1) + ST2*QOL(L) + + TEM = ALFINT(L,4)*CIL(L-1) + ST4*CIL(L) + TEM2 = ALFINT(L,3)*CLL(L-1) + ST3*CLL(L) + + TEM1 = ETA(L) * (TEM - CIL(L)) + TEM3 = ETA(L) * (TEM2 - CLL(L)) + + HBD = ALFIND(L)*HOL(L-1) + ST5*HOL(L) + QBD = ALFIND(L)*QOL(L-1) + ST5*QOL(L) + + TEM5 = ETD(L) * (HOD(L) - HBD) + TEM6 = ETD(L) * (QOD(L) - QBD) +! + DH = ETA(L) * (HB - HOL(L)) + TEM5 + DS = DH - ALHL * (ETA(L) * (QB - QOL(L)) + TEM6) + + GMH(L) = DH * PRI(L) + GMS(L) = DS * PRI(L) + +! if (lprnt) print *,' gmh=',gmh(l),' gms=',gms(l) +! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l),' eta=',eta(l) +! &,' hb=',hb,' hol=',hol(l),' l=',l,' hod=',hod(l) +! &,' etd=',etd(l),' qod=',qod(l),' tem5=',tem5,' tem6=',tem6 +! + GHD(L) = TEM5 * PRI(L) + GSD(L) = (TEM5 - ALHL * TEM6) * PRI(L) +! + QLL(L) = (TEM3 + (1.0-QIL(L))*dlq(l)) * PRI(L) + QIL(L) = (TEM1 + QIL(L)*dlq(l)) * PRI(L) + + TEM1 = ETA(L) * (CIL(L-1) - TEM) + TEM3 = ETA(L) * (CLL(L-1) - TEM2) + + DH = ETA(L) * (HOL(L-1) - HB) - TEM5 + DS = DH - ALHL * ETA(L) * (QOL(L-1) - QB) & + & + ALHL * (TEM6 - EVP(L-1)) + + GMH(L-1) = GMH(L-1) + DH * PRI(L-1) + GMS(L-1) = GMS(L-1) + DS * PRI(L-1) +! +! if (lprnt) print *,' gmh1=',gmh(l-1),' gms1=',gms(l-1) +! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l-1) +! &,' hb=',hb,' hol=',hol(l-1),' evp=',evp(l-1) +! + GHD(L-1) = GHD(L-1) - TEM5 * PRI(L-1) + GSD(L-1) = GSD(L-1) - (TEM5-ALHL*(TEM6-EVP(L-1))) * PRI(L-1) + + QIL(L-1) = QIL(L-1) + TEM1 * PRI(L-1) + QLL(L-1) = QLL(L-1) + TEM3 * PRI(L-1) + + +! if (lprnt) print *,' gmh=',gmh(l),' gms=',gms(l) +! &,' dh=',dh,' ds=',ds,' qb=',qb,' qol=',qol(l),' eta=',eta(l) +! &,' hb=',hb,' hol=',hol(l),' l=',l +! + avh = avh + gmh(l-1)*(prs(l)-prs(l-1)) + + ENDDO +! + HBD = HOL(K) + QBD = QOL(K) + TEM5 = ETD(K+1) * (HOD(K+1) - HBD) + TEM6 = ETD(K+1) * (QOD(K+1) - QBD) + DH = - TEM5 + DS = DH + ALHL * TEM6 + TEM1 = DH * PRI(K) + TEM2 = (DS - ALHL * EVP(K)) * PRI(K) + GMH(K) = GMH(K) + TEM1 + GMS(K) = GMS(K) + TEM2 + GHD(K) = GHD(K) + TEM1 + GSD(K) = GSD(K) + TEM2 + +! if (lprnt) print *,' gmhk=',gmh(k),' gmsk=',gms(k) +! &,' tem1=',tem1,' tem2=',tem2,' dh=',dh,' ds=',ds +! + avh = avh + gmh(K)*(prs(KP1)-prs(K)) +! + tem4 = - GRAVFAC * pris + TX1 = DH * tem4 + TX2 = DS * tem4 +! + DO L=KBL,K + GMH(L) = GMH(L) + TX1 + GMS(L) = GMS(L) + TX2 + GHD(L) = GHD(L) + TX1 + GSD(L) = GSD(L) + TX2 +! + avh = avh + tx1*(prs(l+1)-prs(l)) + ENDDO + +! +! if (lprnt) then +! print *,' gmh=',gmh +! print *,' gms=',gms(KD:K) +! endif +! +!*********************************************************************** +!*********************************************************************** + +!===> KERNEL (AKM) CALCULATION BEGINS + +!===> MODIFY SOUNDING WITH UNIT MASS FLUX +! + DO L=KD,K + + TEM1 = GMH(L) + TEM2 = GMS(L) + HOL(L) = HOL(L) + TEM1*TESTMB + QOL(L) = QOL(L) + (TEM1-TEM2) * (TESTMB/ALHL) + HST(L) = HST(L) + TEM2*(ONE+GAM(L))*TESTMB + QST(L) = QST(L) + TEM2*GAM(L)*(TESTMB/ALHL) + CLL(L) = CLL(L) + QLL(L) * TESTMB + CIL(L) = CIL(L) + QIL(L) * TESTMB + ENDDO +! + if (alm > 0.0) then + HOS = HOS + GMH(KD) * TESTMB + QOS = QOS + (GMH(KD)-GMS(KD)) * (TESTMB/ALHL) + QLS = QLS + QLL(KD) * TESTMB + QIS = QIS + QIL(KD) * TESTMB + else + st2 = 1.0 - st1s + HOS = HOS + (st1s*GMH(KD)+st2*GMH(KD1)) * TESTMB + QOS = QOS + (st1s * (GMH(KD)-GMS(KD)) & + & + st2 * (GMH(KD1)-GMS(KD1))) * (TESTMB/ALHL) + HST(kd) = HST(kd) + (st1s*GMS(kd)*(ONE+GAM(kd)) & + & + st2*gms(kd1)*(ONE+GAM(kd1))) * TESTMB + QST(kd) = QST(kd) + (st1s*GMS(kd)*GAM(kd) & + & + st2*gms(kd1)*gam(kd1)) * (TESTMB/ALHL) + + QLS = QLS + (st1s*QLL(KD)+st2*QLL(KD1)) * TESTMB + QIS = QIS + (st1s*QIL(KD)+st2*QIL(KD1)) * TESTMB + endif + +! + TEM = PRL(Kmaxp1) - PRL(Kmax) + HBL = HOL(Kmax) * TEM + QBL = QOL(Kmax) * TEM + QLB = CLL(Kmax) * TEM + QIB = CIL(Kmax) * TEM + DO L=KmaxM1,KBL,-1 + TEM = PRL(L+1) - PRL(L) + HBL = HBL + HOL(L) * TEM + QBL = QBL + QOL(L) * TEM + QLB = QLB + CLL(L) * TEM + QIB = QIB + CIL(L) * TEM + ENDDO + HBL = HBL * PRISM + QBL = QBL * PRISM + QLB = QLB * PRISM + QIB = QIB * PRISM + +! if (ctei .and. sgcs(kd) > 0.65) then +! hbl = hbl * hpert_fac +! qbl = qbl * hpert_fac +! endif + +! if (lprnt) print *,' hbla=',hbl,' qbla=',qbl + +!*********************************************************************** + +!===> CLOUD WORKFUNCTION FOR MODIFIED SOUNDING, THEN KERNEL (AKM) +! + AKM = ZERO + TX1 = ZERO + QTL = QST(KB1) - GAF(KB1)*HST(KB1) + QTV = QBL + HCC = HBL + TX2 = HCC + TX4 = (ALHF*0.5)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(KB1))*TCRF)) +! + qtv = qbl + tx1 = qib + qlb +! + + DO L=KB1,KD1,-1 + DEL_ETA = ETA(L) - ETA(L+1) + HCCP = HCC + DEL_ETA*HOL(L) +! + QTLP = QST(L-1) - GAF(L-1)*HST(L-1) + QTVP = 0.5 * ((QTLP+QTL)*ETA(L) + (GAF(L)+GAF(L-1))*HCCP) + + DETP = (BKC(L)*TX1 - (QTVP-QTV) & + & + DEL_ETA*(QOL(L)+CLL(L)+CIL(L)) & + & + ETA(L)*Q0U(L) + ETA(L+1)*Q0D(L)) * AKC(L) + IF (DETP .LE. ZERO) cnvflg = .TRUE. + + ST1 = HST(L) - LTL(L)*NU*(QST(L)-QOL(L)) + + TEM2 = (ALHF*0.5)*MAX(ZERO,MIN(ONE,(TCR-TCL-TOL(L-1))*TCRF)) + TEM1 = HCCP + DETP * (TEM2+TX4) + + ST2 = LTL(L) * VTF(L) + TEM5 = CLL(L) + CIL(L) + AKM = AKM + & + & ( (TX2 -ETA(L+1)*ST1-ST2*(TX1-TEM5*eta(l+1))) * DLB(L) & + & + (TEM1 -ETA(L )*ST1-ST2*(DETP-TEM5*eta(l))) * DLT(L) ) +! + HCC = HCCP + TX1 = DETP + TX2 = TEM1 + QTL = QTLP + QTV = QTVP + TX4 = TEM2 + ENDDO +! + if (cnvflg) return +! +! Eventhough we ignore the change in lambda, we still assume +! that the cLoud-top contribution is zero; as though we still +! had non-bouyancy there. +! +! + ST1 = HST(KD) - LTL(KD)*NU*(QST(KD)-QOS) + ST2 = LTL(KD) * VTF(KD) + TEM5 = (QLS + QIS) * eta(kd1) + AKM = AKM + HALF * (TX2-ETA(KD1)*ST1-ST2*(TX1-TEM5)) * DLB(KD) +! + AKM = (AKM - WFN) * (ONE/TESTMB) + + +!*********************************************************************** + +!===> MASS FLUX + + tem2 = rel_fac +! + AMB = - (WFN-ACR) / AKM +! +! if(lprnt) print *,' wfn=',wfn,' acr=',acr,' akm=',akm & +! &,' amb=',amb,' KD=',kd,' cldfrd=',cldfrd,' tem2=',tem2 & +! &,' rel_fac=',rel_fac,' prskd=',prs(kd) + +!===> RELAXATION AND CLIPPING FACTORS +! + AMB = AMB * CLP * tem2 + +!!! if (DDFT) AMB = MIN(AMB, ONE/CLDFRD) + +!===> SUB-CLOUD LAYER DEPTH LIMIT ON MASS FLUX + + AMBMAX = (PRL(KMAXP1)-PRL(KBL))*(FRACBL*GRAVCON) + AMB = MAX(MIN(AMB, AMBMAX),ZERO) + + +! if(lprnt) print *,' AMB=',amb,' clp=',clp,' ambmax=',ambmax +!*********************************************************************** +!*************************RESULTS*************************************** +!*********************************************************************** + +!===> PRECIPITATION AND CLW DETRAINMENT +! + if (amb > 0.0) then + avt = 0.0 + avq = 0.0 + avr = dof + +! + DSFC = DSFC + AMB * ETD(K) * (1.0/DT) +! +! DO L=KBL,KD,-1 + DO L=K,KD,-1 + PCU(L) = PCU(L) + AMB*RNN(L) ! (A40) + avr = avr + rnn(l) +! if(lprnt) print *,' avr=',avr,' rnn=',rnn(l),' l=',l + ENDDO + pcu(k) = pcu(k) + dof +! +!===> TEMPARATURE AND Q CHANGE AND CLOUD MASS FLUX DUE TO CLOUD TYPE KD +! + TX1 = AMB * (ONE/CP) + TX2 = AMB * (ONE/ALHL) + DO L=KD,K + ST1 = GMS(L)*TX1 + TOI(L) = TOI(L) + ST1 + TCU(L) = TCU(L) + ST1 + TCD(L) = TCD(L) + GSD(L) * TX1 +! + st1 = st1 - (alhl/cp) * (QIL(L) + QLL(L)) * AMB + + avt = avt + st1 * (prs(l+1)-prs(l)) + + FLX(L) = FLX(L) + ETA(L)*AMB + FLXD(L) = FLXD(L) + ETD(L)*AMB +! + QII(L) = QII(L) + QIL(L) * AMB + TEM = 0.0 + + QLI(L) = QLI(L) + QLL(L) * AMB + TEM + + ST1 = (GMH(L)-GMS(L)) * TX2 + + QOI(L) = QOI(L) + ST1 + QCU(L) = QCU(L) + ST1 + QCD(L) = QCD(L) + (GHD(L)-GSD(L)) * TX2 +! + avq = avq + (st1+(QLL(L)+QIL(L))*amb) * (prs(l+1)-prs(l)) +! avq = avq + st1 * (prs(l+1)-prs(l)) +! avr = avr + (QLL(L) + QIL(L)*(1+alhf/alhl)) +! avr = avr + (QLL(L) + QIL(L)) +! * * (prs(l+1)-prs(l)) * gravcon + +! if(lprnt) print *,' avr=',avr,' qll=',qll(l),' l=',l +! &, ' qil=',qil(l) + + ENDDO + avr = avr * amb +! +! Correction for negative condensate! +! if (advcld) then +! do l=kd,k +! if (qli(l) < 0.0) then +! qoi(l) = qoi(l) + qli(l) +! toi(l) = toi(l) - (alhl/cp) * qli(l) +! qli(l) = 0.0 +! endif +! if (qii(l) < 0.0) then +! qoi(l) = qoi(l) + qii(l) +! toi(l) = toi(l) - ((alhl+alhf)/cp) * qii(l) +! qii(l) = 0.0 +! endif +! enddo +! endif + +! +! +! if (lprnt) then +! print *,' For KD=',KD +! avt = avt * cp * 100.0*86400.0 / (alhl*DT*grav) +! avq = avq * 100.0*86400.0 / (DT*grav) +! avr = avr * 86400.0 / DT +! print *,' avt=',avt,' avq=',avq,' avr=',avr,' avh=' +! * ,avh,' alm=',alm,' DDFT=',DDFT,' KD=',KD +! &,' TOIK-',toi(k),' TOIK-1=',toi(k-1),' TOIK-2=',toi(k-2) +! if (kd == 12 .and. .not. ddft) stop +! if (avh > 0.1 .or. abs(avt+avq) > 1.0e-5 .or. +! & abs(avt-avr) > 1.0e-5 .or. abs(avr+avq) > 1.0e-5) stop +! +! if (lprnt) then +! print *,' For KD=',KD +! print *,' TCU=',(tcu(l),l=kd,k) +! print *,' QCU=',(Qcu(l),l=kd,k) +! endif +! + TX1 = 0.0 + TX2 = 0.0 +! + IF (REVAP) THEN ! REEVAPORATION OF FALLING CONVECTIVE RAIN +! + tem = 0.0 + do l=kd,kbl + IF (L < IDH .or. (.not. DDFT)) THEN + tem = tem + amb * rnn(l) + endif + enddo + tem = tem + amb * dof + tem = tem * (3600.0/dt) +!!!! tem1 = max(1.0, min(100.0,sqrt((5.0E10/max(garea,one))))) +! tem1 = max(1.0, min(100.0,(7.5E10/max(garea,one)))) +! tem1 = max(1.0, min(100.0,(5.0E10/max(garea,one)))) +! tem1 = max(1.0, min(100.0,(4.0E10/max(garea,one)))) +!! tem1 = sqrt(max(1.0, min(100.0,(4.0E10/max(garea,one))))) ! 20100902 + tem1 = sqrt(max(1.0, min(100.0,(6.25E10/max(garea,one))))) ! 20110530 + +! if (lprnt) print *,' clfr0=',clf(tem),' tem=',tem,' tem1=',tem1 + +! clfrac = max(ZERO, min(ONE, rknob*clf(tem)*tem1)) +! clfrac = max(ZERO, min(0.25, rknob*clf(tem)*tem1)) + clfrac = max(ZERO, min(half, rknob*clf(tem)*tem1)) + +! if (lprnt) then +! print *,' cldfrd=',cldfrd,' amb=',amb,' clfrac=',clfrac +! print *,' tx3=',tx3,' etakd=',eta(kd),' pri=',pri(kd) +! print *,' RNN=',RNN(kd:k) +! endif +! +!cnt DO L=KD,K + DO L=KD,KBL ! Testing on 20070926 +! for L=KD,K + IF (L >= IDH .AND. DDFT) THEN + TX2 = TX2 + AMB * RNN(L) + CLDFRD = MIN(AMB*CLDFR(L), clfrac) + ELSE + TX1 = TX1 + AMB * RNN(L) + ENDIF + tx4 = zfac * phil(l) + tx4 = (one - tx4 * (one - half*tx4)) * afc +! + IF (TX1 > 0. .OR. TX2 > 0.0) THEN + TEQ = TOI(L) + QEQ = QOI(L) + PL = 0.5 * (PRL(L+1)+PRL(L)) + + ST1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) + ST2 = ST1*ELFOCP + (1.0-ST1)*ELOCP + + CALL QSATCN ( TEQ,PL,QSTEQ,DQDT) +! CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) +! + DELTAQ = 0.5 * (QSTEQ*rhc_ls(l)-QEQ) / (1.+ST2*DQDT) +! + QEQ = QEQ + DELTAQ + TEQ = TEQ - DELTAQ*ST2 +! + TEM1 = MAX(ZERO, MIN(ONE, (TCR-TEQ)*TCRF)) + TEM2 = TEM1*ELFOCP + (1.0-TEM1)*ELOCP + + CALL QSATCN ( TEQ,PL,QSTEQ,DQDT) +! CALL QSATCN ( TEQ,PL,QSTEQ,DQDT,.false.) +! + DELTAQ = (QSTEQ*rhc_ls(l)-QEQ) / (1.+TEM2*DQDT) +! + QEQ = QEQ + DELTAQ + TEQ = TEQ - DELTAQ*TEM2 + + IF (QEQ > QOI(L)) THEN + POTEVAP = (QEQ-QOI(L))*(PRL(L+1)-PRL(L))*GRAVCON + + tem4 = 0.0 + if (tx1 > 0.0) & + & TEM4 = POTEVAP * (1. - EXP( tx4*TX1**0.57777778 ) ) +! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX1) ) ) + ACTEVAP = MIN(TX1, TEM4*CLFRAC) + +! if(lprnt) print *,' L=',L,' actevap=',actevap,' tem4=',tem4, +! &' clfrac=' +! &,clfrac,' potevap=',potevap,'efac=',AFC*SQRT(TX1*TEM3) +! &,' tx1=',tx1 + + if (tx1 < rainmin*dt) actevap = min(tx1, potevap) +! + tem4 = 0.0 + if (tx2 > 0.0) & + & TEM4 = POTEVAP * (1. - EXP( tx4*TX2**0.57777778 ) ) +! & TEM4 = POTEVAP * (1. - EXP( AFC*tx4*SQRT(TX2) ) ) + TEM4 = min(MIN(TX2, TEM4*CLDFRD), potevap-actevap) + if (tx2 < rainmin*dt) tem4 = min(tx2, potevap-actevap) +! + TX1 = TX1 - ACTEVAP + TX2 = TX2 - TEM4 + ST1 = (ACTEVAP+TEM4) * PRI(L) + QOI(L) = QOI(L) + ST1 + QCU(L) = QCU(L) + ST1 +! + + ST1 = ST1 * ELOCP + TOI(L) = TOI(L) - ST1 + TCU(L) = TCU(L) - ST1 + ENDIF + ENDIF + ENDDO +! + CUP = CUP + TX1 + TX2 + DOF * AMB + ELSE + DO L=KD,K + TX1 = TX1 + AMB * RNN(L) + ENDDO + CUP = CUP + TX1 + DOF * AMB + ENDIF + +! if (lprnt) print *,' tx1=',tx1,' tx2=',tx2,' dof=',dof +! &,' cup=',cup*86400/dt,' amb=',amb +! &,' amb=',amb,' cup=',cup,' clfrac=',clfrac,' cldfrd=',cldfrd +! &,' ddft=',ddft,' kd=',kd,' kbl=',kbl,' k=',k +! +! Convective transport (mixing) of passive tracers +! + if (NTRC > 0) then + do l=kd,k-1 + if (etz(l) /= zero) etzi(l) = one / etz(l) + enddo + DO N=1,NTRC ! Tracer loop ; first two are u and v + + DO L=KD,K + HOL(L) = ROI(L,N) + ENDDO +! + HCC = RBL(N) + HOD(KD) = HOL(KD) +! Compute downdraft properties for the tracer + DO L=KD1,K + ST1 = ONE - ALFIND(L) + HB = ALFIND(L) * HOL(L-1) + ST1 * HOL(L) + IF (ETZ(L-1) /= ZERO) THEN + TEM = ETZI(L-1) + IF (ETD(L) > ETD(L-1)) THEN + HOD(L) = (ETD(L-1)*(HOD(L-1)-HOL(L-1)) & + & + ETD(L) *(HOL(L-1)-HB) + ETZ(L-1)*HB) * TEM + ELSE + HOD(L) = (ETD(L-1)*(HOD(L-1)-HB) + ETZ(L-1)*HB) * TEM + ENDIF + ELSE + HOD(L) = HB + ENDIF + ENDDO + + DO L=KB1,KD,-1 + HCC = HCC + (ETA(L)-ETA(L+1))*HOL(L) + ENDDO +! +! Scavenging -- fscav - fraction scavenged [km-1] +! delz - distance from the entrainment to detrainment layer [km] +! fnoscav - the fraction not scavenged +! following Liu et al. [JGR,2001] Eq 1 + + if (FSCAV_(N) > 0.0) then + DELZKM = ( PHIL(KD) - PHIH(KD1) ) *(onebg*0.001) + FNOSCAV = exp(- FSCAV_(N) * DELZKM) + else + FNOSCAV = 1.0 + endif + + GMH(KD) = PRI(KD) * (HCC-ETA(KD)*HOL(KD)) * trcfac(kd,n) & + & * FNOSCAV + DO L=KD1,K + if (FSCAV_(N) > 0.0) then + DELZKM = ( PHIL(KD) - PHIH(L+1) ) *(onebg*0.001) + FNOSCAV = exp(- FSCAV_(N) * DELZKM) + endif + ST1 = ONE - ALFINT(L,N+4) + ST2 = ONE - ALFIND(L) + HB = ALFINT(L,N+4) * HOL(L-1) + ST1 * HOL(L) + HBD = ALFIND(L) * HOL(L-1) + ST2 * HOL(L) + TEM5 = ETD(L) * (HOD(L) - HBD) + DH = ETA(L) * (HB - HOL(L)) * FNOSCAV + TEM5 + GMH(L ) = DH * PRI(L) * trcfac(l,n) + DH = ETA(L) * (HOL(L-1) - HB) * FNOSCAV - TEM5 + GMH(L-1) = GMH(L-1) + DH * PRI(L-1) * trcfac(l,n) + ENDDO +! + DO L=KD,K + ST1 = GMH(L)*AMB + ROI(L,N) = HOL(L) + ST1 + RCU(L,N) = RCU(L,N) + ST1 + ENDDO + ENDDO ! Tracer loop NTRC + endif + endif ! amb > 0.0 + +! if (lprnt) print *,' toio=',toi +! if (lprnt) print *,' qoio=',qoi + + RETURN + END + + SUBROUTINE DDRFT( & + & K, KD & + &, TLA, ALFIND & + &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF & +! &, TOL, QOL, HOL, PRL, QST, HST, GAM, GAF, HBL, QBL& + &, QRB, QRT, BUY, KBL, IDH, ETA, RNN, ETAI & + &, ALM, WFN, TRAIN, DDFT & + &, ETD, HOD, QOD, EVP, DOF, CLDFRD, WCB & + &, GMS, GSD, GHD,lprnt) + +! +!*********************************************************************** +!******************** Cumulus Downdraft Subroutine ********************* +!****************** Based on Cheng and Arakawa (1997) ****** ********** +!************************ SUBROUTINE DDRFT **************************** +!************************* October 2004 ****************************** +!*********************************************************************** +!*********************************************************************** +!************* Shrinivas.Moorthi@noaa.gov (301) 683-3718 *************** +!*********************************************************************** +!*********************************************************************** +!23456789012345678901234567890123456789012345678901234567890123456789012 +! +!===> TOL(K) INPUT TEMPERATURE KELVIN +!===> QOL(K) INPUT SPECIFIC HUMIDITY NON-DIMENSIONAL + +!===> PRL(K+1) INPUT PRESSURE @ EDGES MB + +!===> K INPUT THE RISE & THE INDEX OF THE SUBCLOUD LAYER +!===> KD INPUT DETRAINMENT LEVEL ( 1<= KD < K ) +! + USE MACHINE , ONLY : kind_phys + use module_ras + IMPLICIT NONE +! +! INPUT ARGUMENTS +! + INTEGER K, KD, KBL + real(kind=kind_phys) ALFIND(K) + + real(kind=kind_phys), dimension(kd:k) :: HOL, QOL, HST, QST & + &, TOL, QRB, QRT, RNN & + &, RNS, ETAI + real(kind=kind_phys), dimension(kd:k+1) :: GAF, BUY, GAM, ETA & + &, PRL +! +! real(kind=kind_phys) HBL, QBL, PRIS & +! &, TRAIN, WFN, ALM +! +! TEMPORARY WORK SPACE +! + real(kind=kind_phys), dimension(KD:K) :: RNF, WCB, EVP, STLT & + &, GHD, GSD, CLDFRD & + &, GQW, QRPI, QRPS, BUD + + real(kind=kind_phys), dimension(KD:K+1) :: QRP, WVL, WVLO, ETD & + &, HOD, QOD, ROR, GMS + + real(kind=kind_phys) TL, PL, QL, QS, DQS, ST1 & + &, QQQ, PICON, DEL_ETA, HB, QB, TB & + &, TEM, TEM1, TEM2, TEM3, TEM4, ST2 & + &, ERRMIN, ERRMI2, ERRH, ERRW, ERRE, TEM5 & + &, TEM6, HBD, QBD, TX1, TX2, TX3 & + &, TX4, TX5, TX6, TX7, TX8, TX9 & + &, WFN, ALM, VTPEXP , AL2 & + &, TRAIN, GMF, ONPG, CTLA, VTRM & + &, RPART, QRMIN, AA1, BB1, CC1, DD1 & + &, WC2MIN, WCMIN, WCBASE, F2, F3, F5 & + &, GMF1, GMF5, QRAF, QRBF, del_tla & + &, TLA, STLA, CTL2, CTL3, ASIN & + &, RNT, RNB, ERRQ, RNTP, QRPF, VTPF & + &, EDZ, DDZ, CE, QHS, FAC, FACG & + &, RSUM1, RSUM2, RSUM3, CEE, DOF, DOFW +! &, sialf + + INTEGER I, L, N, IX, KD1, II, kb1, IP1, JJ, ntla & + &, KP1, IT, KM1, KTEM, KK, KK1, LM1, LL, LP1 & + &, IDW, IDH, IDN(K), idnm +! + integer, parameter :: NUMTLA=2 +! integer, parameter :: NUMTLA=4 + parameter (ERRMIN=0.0001, ERRMI2=0.1*ERRMIN) +! parameter (ERRMIN=0.00001, ERRMI2=0.1*ERRMIN) +! + real (kind=kind_phys), parameter :: PIINV=1.0/PI +! + parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.0) +! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=1.0) +! parameter (ONPG=1.0+0.5, GMF=1.0/ONPG, RPART=0.5) +! PARAMETER (AA1=1.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) +! PARAMETER (AA1=2.0, BB1=1.5, CC1=1.1, DD1=0.85, F3=CC1, F5=2.5) + PARAMETER (AA1=1.0, BB1=1.0, CC1=1.0, DD1=1.0, F3=CC1, F5=1.0) + parameter (QRMIN=1.0E-6, WC2MIN=0.01, GMF1=GMF/AA1, GMF5=GMF/F5) +! parameter (QRMIN=1.0E-6, WC2MIN=1.00, GMF1=GMF/AA1, GMF5=GMF/F5) +! parameter (sialf=0.5) +! + INTEGER ITR, ITRMU, ITRMD, KTPD, ITRMIN, ITRMND +! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=7) + PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12, ITRMND=12) +! PARAMETER (ITRMU=25, ITRMD=25, ITRMIN=12) +! PARAMETER (ITRMU=14, ITRMD=18, ITRMIN=7) +! PARAMETER (ITRMU=10, ITRMD=10, ITRMIN=5) +! +! real(kind=kind_phys) EM(K*K), ELM(K) + real(kind=kind_phys) ELM(K), AA(KD:K,KD:K+1), QW(KD:K,KD:K) & + &, VT(2), VRW(2), TRW(2), QA(3), WA(3) + + LOGICAL SKPDD, SKPUP, cnvflg, DDFT, UPDRET, DDLGK, lprnt + +!*********************************************************************** + +! if(lprnt) print *,' K=',K,' KD=',KD,' In Downdrft' + + KD1 = KD + 1 + KP1 = K + 1 + KM1 = K - 1 + KB1 = KBL - 1 +! +! VTP = 36.34*SQRT(1.2)* (0.001)**0.1364 + VTPEXP = -0.3636 +! PIINV = 1.0 / PI + PICON = PI * ONEBG * 0.5 +! +! Compute Rain Water Budget of the Updraft (Cheng and Arakawa, 1997) +! + CLDFRD = 0.0 + RNTP = 0.0 + DOF = 0.0 + ERRQ = 10.0 + RNB = 0.0 + RNT = 0.0 + TX2 = PRL(KBL) +! + TX1 = (PRL(KD) + PRL(KD1)) * 0.5 + ROR(KD) = CMPOR*TX1 / (TOL(KD)*(1.0+NU*QOL(KD))) +! GMS(KD) = VTP * ROR(KD) ** VTPEXP + GMS(KD) = VTP * VTPF(ROR(KD)) +! + QRP(KD) = QRMIN +! + TEM = TOL(K) * (1.0 + NU * QOL(K)) + ROR(K+1) = 0.5 * CMPOR * (PRL(K+1)+PRL(K)) / TEM + GMS(K+1) = VTP * VTPF(ROR(K+1)) + QRP(K+1) = QRMIN +! + kk = kbl + DO L=KD1,K + TEM = 0.5 * (TOL(L)+TOL(L-1)) & + & * (1.0 + (0.5*NU) * (QOL(L)+QOL(L-1))) + ROR(L) = CMPOR * PRL(L) / TEM +! GMS(L) = VTP * ROR(L) ** VTPEXP + GMS(L) = VTP * VTPF(ROR(L)) + QRP(L) = QRMIN + if (buy(l) <= 0.0 .and. kk == KBL) then + kk = l + endif + ENDDO + if (kk /= kbl) then + do l=kk,kbl + buy(l) = 0.9 * buy(l-1) + enddo + endif +! + do l=kd,k + qrpi(l) = buy(l) + enddo + do l=kd1,kb1 + buy(l) = 0.25 * (qrpi(l-1)+qrpi(l)+qrpi(l)+qrpi(l+1)) + enddo + +! +! CALL ANGRAD(TX1, ALM, STLA, CTL2, AL2, PI, TLA, TX2, WFN, TX3) + tx1 = 1000.0 + tx1 - prl(k+1) + CALL ANGRAD(TX1, ALM, AL2, TLA, TX2, WFN, TX3) +! +! Following Ucla approach for rain profile +! + F2 = 2.0*BB1*ONEBG/(PI*0.2) + WCMIN = SQRT(WC2MIN) + WCBASE = WCMIN +! +! del_tla = TLA * 0.2 +! del_tla = TLA * 0.25 + del_tla = TLA * 0.3 + TLA = TLA - DEL_TLA +! + DO L=KD,K + RNF(L) = 0.0 + RNS(L) = 0.0 + WVL(L) = 0.0 + STLT(L) = 0.0 + GQW(L) = 0.0 + QRP(L) = QRMIN + DO N=KD,K + QW(N,L) = 0.0 + ENDDO + ENDDO +! +!-----QW(N,L) = D(W(N)*W(N))/DQR(L) +! + KK = KBL + QW(KD,KD) = -QRB(KD) * GMF1 + GHD(KD) = ETA(KD) * ETA(KD) + GQW(KD) = QW(KD,KD) * GHD(KD) + GSD(KD) = ETAI(KD) * ETAI(KD) +! + GQW(KK) = - QRB(KK-1) * (GMF1+GMF1) +! + WCB(KK) = WCBASE * WCBASE + + TX1 = WCB(KK) + GSD(KK) = 1.0 + GHD(KK) = 1.0 +! + TEM = GMF1 + GMF1 + DO L=KB1,KD1,-1 + GHD(L) = ETA(L) * ETA(L) + GSD(L) = ETAI(L) * ETAI(L) + GQW(L) = - GHD(L) * (QRB(L-1)+QRT(L)) * TEM + QW(L,L) = - QRT(L) * TEM +! + st1 = 0.5 * (eta(l) + eta(l+1)) + TX1 = TX1 + BUY(L) * TEM * (qrb(l)+qrt(l)) * st1 * st1 + WCB(L) = TX1 * GSD(L) + ENDDO +! + TEM1 = (QRB(KD) + QRT(KD1) + QRT(KD1)) * GMF1 + GQW(KD1) = - GHD(KD1) * TEM1 + QW(KD1,KD1) = - QRT(KD1) * TEM + st1 = 0.5 * (eta(kd) + eta(kd1)) + WCB(KD) = (TX1 + BUY(KD)*TEM*qrb(kd)*st1*st1) * GSD(KD) +! + DO L=KD1,KBL + DO N=KD,L-1 + QW(N,L) = GQW(L) * GSD(N) + ENDDO + ENDDO + QW(KBL,KBL) = 0.0 +! + do ntla=1,numtla +! +! if (errq < 1.0 .or. tla > 45.0) cycle + if (errq < 0.1 .or. tla > 45.0) cycle +! + tla = tla + del_tla + STLA = SIN(TLA*PI/180.0) + CTL2 = 1.0 - STLA * STLA +! +! if (lprnt) print *,' tla=',tla,' al2=',al2,' ptop=' +! &,0.5*(prl(kd)+prl(kd1)),' ntla=',ntla,' f2=',f2,' stla=',stla +! if (lprnt) print *,' buy=',(buy(l),l=kd,kbl) +! + STLA = F2 * STLA * AL2 + CTL2 = DD1 * CTL2 + CTL3 = 0.1364 * CTL2 +! + DO L=KD,K + RNF(L) = 0.0 + WVL(L) = 0.0 + STLT(L) = 0.0 + QRP(L) = QRMIN + ENDDO + WVL(KBL) = WCBASE + STLT(KBL) = 1.0 / WCBASE +! + DO L=KD,K+1 + DO N=KD,K + AA(N,L) = 0.0 + ENDDO + ENDDO +! + SKPUP = .FALSE. +! + DO ITR=1,ITRMU ! Rain Profile Iteration starts! + IF (.NOT. SKPUP) THEN + wvlo = wvl +! +!-----CALCULATING THE VERTICAL VELOCITY +! + TX1 = 0.0 + QRPI(KBL) = 1.0 / QRP(KBL) + DO L=KB1,KD,-1 + TX1 = TX1 + QRP(L+1) * GQW(L+1) + ST1 = WCB(L) + QW(L,L) * QRP(L) & + & + TX1 * GSD(L) + if (st1 > wc2min) then +! WVL(L) = SQRT(ST1) + WVL(L) = 0.5 * (SQRT(ST1) + WVL(L)) +! if (itr == 1) wvl(l) = wvl(l) * 0.25 + else + +! if (lprnt) print *,' l=',l,' st1=',st1,' wcb=',wcb(l),' qw=' +! &,qw(l,l),' qrp=',qrp(l),' tx1=',tx1,' gsd=',gsd(l),' ite=',itr + +! wvl(l) = 0.5*(wcmin+wvl(l)) + wvl(l) = 0.5*(wvl(l) + wvl(l+1)) + qrp(l) = 0.5*((wvl(l)*wvl(l)-wcb(l)-tx1*gsd(l))/qw(l,l) & + & + qrp(l)) +!! wvl(l) = 0.5 * (wvl(l) + wvl(l+1)) + endif +! wvl(l) = 0.5 * (wvl(l) + wvlo(l)) +! WVL(L) = SQRT(MAX(ST1,WC2MIN)) + wvl(l) = max(wvl(l), wcbase) + STLT(L) = 1.0 / WVL(L) + QRPI(L) = 1.0 / QRP(L) + ENDDO +! +! if (lprnt) then +! print *,' ITR=',ITR,' ITRMU=',ITRMU +! print *,' WVL=',(WVL(L),L=KD,KBL) +! print *,' qrp=',(qrp(L),L=KD,KBL) +! print *,' qrpi=',(qrpi(L),L=KD,KBL) +! print *,' rnf=',(rnf(L),L=KD,KBL) +! endif +! +!-----CALCULATING TRW, VRW AND OF +! +! VT(1) = GMS(KD) * QRP(KD)**0.1364 + VT(1) = GMS(KD) * QRPF(QRP(KD)) + TRW(1) = ETA(KD) * QRP(KD) * STLT(KD) + TX6 = TRW(1) * VT(1) + VRW(1) = F3*WVL(KD) - CTL2*VT(1) + BUD(KD) = STLA * TX6 * QRB(KD) * 0.5 + RNF(KD) = BUD(KD) + DOF = 1.1364 * BUD(KD) * QRPI(KD) + DOFW = -BUD(KD) * STLT(KD) +! + RNT = TRW(1) * VRW(1) + TX2 = 0.0 + TX4 = 0.0 + RNB = RNT + TX1 = 0.5 + TX8 = 0.0 +! + IF (RNT >= 0.0) THEN + TX3 = (RNT-CTL3*TX6) * QRPI(KD) + TX5 = CTL2 * TX6 * STLT(KD) + ELSE + TX3 = 0.0 + TX5 = 0.0 + RNT = 0.0 + RNB = 0.0 + ENDIF +! + DO L=KD1,KB1 + KTEM = MAX(L-2, KD) + LL = L - 1 +! +! VT(2) = GMS(L) * QRP(L)**0.1364 + VT(2) = GMS(L) * QRPF(QRP(L)) + TRW(2) = ETA(L) * QRP(L) * STLT(L) + VRW(2) = F3*WVL(L) - CTL2*VT(2) + QQQ = STLA * TRW(2) * VT(2) + ST1 = TX1 * QRB(LL) + BUD(L) = QQQ * (ST1 + QRT(L)) +! + QA(2) = DOF + WA(2) = DOFW + DOF = 1.1364 * BUD(L) * QRPI(L) + DOFW = -BUD(L) * STLT(L) +! + RNF(LL) = RNF(LL) + QQQ * ST1 + RNF(L) = QQQ * QRT(L) +! + TEM3 = VRW(1) + VRW(2) + TEM4 = TRW(1) + TRW(2) +! + TX6 = .25 * TEM3 * TEM4 + TEM4 = TEM4 * CTL3 +! +!-----BY QR ABOVE +! +! TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*TX7 + TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) + ST1 = .25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & + & * STLT(LL) + F3*TRW(2)) +!-----BY QR BELOW + TEM2 = .25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) + ST2 = .25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & + & * STLT(L) + F3*TRW(1)) +! +! From top to the KBL-2 layer +! + QA(1) = TX2 + QA(2) = QA(2) + TX3 - TEM1 + QA(3) = -TEM2 +! + WA(1) = TX4 + WA(2) = WA(2) + TX5 - ST1 + WA(3) = -ST2 +! + TX2 = TEM1 + TX3 = TEM2 + TX4 = ST1 + TX5 = ST2 +! + VT(1) = VT(2) + TRW(1) = TRW(2) + VRW(1) = VRW(2) +! + IF (WVL(KTEM) == WCMIN) WA(1) = 0.0 + IF (WVL(LL) == WCMIN) WA(2) = 0.0 + IF (WVL(L) == WCMIN) WA(3) = 0.0 + DO N=KTEM,KBL + AA(LL,N) = (WA(1)*QW(KTEM,N) * STLT(KTEM) & + & + WA(2)*QW(LL,N) * STLT(LL) & + & + WA(3)*QW(L,N) * STLT(L) ) * 0.5 + ENDDO + AA(LL,KTEM) = AA(LL,KTEM) + QA(1) + AA(LL,LL) = AA(LL,LL) + QA(2) + AA(LL,L) = AA(LL,L) + QA(3) + BUD(LL) = (TX8 + RNN(LL)) * 0.5 & + & - RNB + TX6 - BUD(LL) + AA(LL,KBL+1) = BUD(LL) + RNB = TX6 + TX1 = 1.0 + TX8 = RNN(LL) + ENDDO + L = KBL + LL = L - 1 +! VT(2) = GMS(L) * QRP(L)**0.1364 + VT(2) = GMS(L) * QRPF(QRP(L)) + TRW(2) = ETA(L) * QRP(L) * STLT(L) + VRW(2) = F3*WVL(L) - CTL2*VT(2) + ST1 = STLA * TRW(2) * VT(2) * QRB(LL) + BUD(L) = ST1 + + QA(2) = DOF + WA(2) = DOFW + DOF = 1.1364 * BUD(L) * QRPI(L) + DOFW = -BUD(L) * STLT(L) +! + RNF(LL) = RNF(LL) + ST1 +! + TEM3 = VRW(1) + VRW(2) + TEM4 = TRW(1) + TRW(2) +! + TX6 = .25 * TEM3 * TEM4 + TEM4 = TEM4 * CTL3 +! +!-----BY QR ABOVE +! + TEM1 = .25*(TRW(1)*TEM3 - TEM4*VT(1))*QRPI(LL) + ST1 = .25*(TRW(1)*(CTL2*VT(1)-VRW(2)) & + & * STLT(LL) + F3*TRW(2)) +!-----BY QR BELOW + TEM2 = .25*(TRW(2)*TEM3 - TEM4*VT(2))*QRPI(L) + ST2 = .25*(TRW(2)*(CTL2*VT(2)-VRW(1)) & + & * STLT(L) + F3*TRW(1)) +! +! For the layer next to the top of the boundary layer +! + QA(1) = TX2 + QA(2) = QA(2) + TX3 - TEM1 + QA(3) = -TEM2 +! + WA(1) = TX4 + WA(2) = WA(2) + TX5 - ST1 + WA(3) = -ST2 +! + TX2 = TEM1 + TX3 = TEM2 + TX4 = ST1 + TX5 = ST2 +! + IDW = MAX(L-2, KD) +! + IF (WVL(IDW) == WCMIN) WA(1) = 0.0 + IF (WVL(LL) == WCMIN) WA(2) = 0.0 + IF (WVL(L) == WCMIN) WA(3) = 0.0 +! + KK = IDW + DO N=KK,L + AA(LL,N) = (WA(1)*QW(KK,N) * STLT(KK) & + & + WA(2)*QW(LL,N) * STLT(LL) & + & + WA(3)*QW(L,N) * STLT(L) ) * 0.5 + + ENDDO +! + AA(LL,IDW) = AA(LL,IDW) + QA(1) + AA(LL,LL) = AA(LL,LL) + QA(2) + AA(LL,L) = AA(LL,L) + QA(3) + BUD(LL) = (TX8+RNN(LL)) * 0.5 - RNB + TX6 - BUD(LL) +! + AA(LL,L+1) = BUD(LL) +! + RNB = TRW(2) * VRW(2) +! +! For the top of the boundary layer +! + IF (RNB < 0.0) THEN + KK = KBL + TEM = VT(2) * TRW(2) + QA(2) = (RNB - CTL3*TEM) * QRPI(KK) + WA(2) = CTL2 * TEM * STLT(KK) + ELSE + RNB = 0.0 + QA(2) = 0.0 + WA(2) = 0.0 + ENDIF +! + QA(1) = TX2 + QA(2) = DOF + TX3 - QA(2) + QA(3) = 0.0 +! + WA(1) = TX4 + WA(2) = DOFW + TX5 - WA(2) + WA(3) = 0.0 +! + KK = KBL + IF (WVL(KK-1) == WCMIN) WA(1) = 0.0 + IF (WVL(KK) == WCMIN) WA(2) = 0.0 +! + DO II=1,2 + N = KK + II - 2 + AA(KK,N) = (WA(1)*QW(KK-1,N) * STLT(KK-1) & + & + WA(2)*QW(KK,N) * STLT(KK)) * 0.5 + ENDDO + FAC = 0.5 + LL = KBL + L = LL + 1 + LM1 = LL - 1 + AA(LL,LM1) = AA(LL,LM1) + QA(1) + AA(LL,LL) = AA(LL,LL) + QA(2) + BUD(LL) = 0.5*RNN(LM1) - TX6 + RNB - BUD(LL) + AA(LL,LL+1) = BUD(LL) +! +!-----SOLVING THE BUDGET EQUATIONS FOR DQR +! + DO L=KD1,KBL + LM1 = L - 1 + cnvflg = ABS(AA(LM1,LM1)) < ABS(AA(L,LM1)) + DO N=LM1,KBL+1 + IF (cnvflg) THEN + TX1 = AA(LM1,N) + AA(LM1,N) = AA(L,N) + AA(L,N) = TX1 + ENDIF + ENDDO + TX1 = AA(L,LM1) / AA(LM1,LM1) + DO N=L,KBL+1 + AA(L,N) = AA(L,N) - TX1 * AA(LM1,N) + ENDDO + ENDDO +! +!-----BACK SUBSTITUTION AND CHECK IF THE SOLUTION CONVERGES +! + KK = KBL + KK1 = KK + 1 + AA(KK,KK1) = AA(KK,KK1) / AA(KK,KK) ! Qr correction ! + TX2 = ABS(AA(KK,KK1)) * QRPI(KK) ! Error Measure ! +! if (lprnt) print *,' tx2a=',tx2,' aa1=',aa(kk,kk1) +! &,' qrpi=',qrpi(kk) +! + KK = KBL + 1 + DO L=KB1,KD,-1 + LP1 = L + 1 + TX1 = 0.0 + DO N=LP1,KBL + TX1 = TX1 + AA(L,N) * AA(N,KK) + ENDDO + AA(L,KK) = (AA(L,KK) - TX1) / AA(L,L) ! Qr correction ! + TX2 = MAX(TX2, ABS(AA(L,KK))*QRPI(L)) ! Error Measure ! + +! if (lprnt) print *,' tx2b=',tx2,' aa1=',aa(l,kk) +! &,' qrpi=',qrpi(l),' L=',L + + ENDDO +! +! tem = 0.5 + if (tx2 > 1.0 .and. abs(errq-tx2) > 0.1) then + tem = 0.5 +!! elseif (tx2 < 0.1) then +!! tem = 1.2 + else + tem = 1.0 + endif +! + DO L=KD,KBL +! QRP(L) = MAX(QRP(L)+AA(L,KBL+1), QRMIN) + QRP(L) = MAX(QRP(L)+AA(L,KBL+1)*tem, QRMIN) + ENDDO +! +! if (lprnt) print *,' itr=',itr,' tx2=',tx2 + + IF (ITR < ITRMIN) THEN + TEM = ABS(ERRQ-TX2) + IF (TEM >= ERRMI2 .AND. TX2 >= ERRMIN) THEN + ERRQ = TX2 ! Further iteration ! + ELSE + SKPUP = .TRUE. ! Converges ! + ERRQ = 0.0 ! Rain profile exists! +! if (lprnt) print *,' here1',' tem=',tem,' tx2=',tx2,' errmi2=', +! *errmi2,' errmin=',errmin + ENDIF + ELSE + TEM = ERRQ - TX2 +! IF (TEM < ZERO .AND. ERRQ > 0.1) THEN + IF (TEM < ZERO .AND. ERRQ > 0.5) THEN +! IF (TEM < ZERO .and. & +! & (ntla < numtla .or. ERRQ > 0.5)) THEN +! if (lprnt) print *,' tx2=',tx2,' errq=',errq,' tem=',tem + SKPUP = .TRUE. ! No convergence ! + ERRQ = 10.0 ! No rain profile! +!!!! ELSEIF (ABS(TEM) < ERRMI2 .OR. TX2 < ERRMIN) THEN + ELSEIF (TX2 < ERRMIN) THEN + SKPUP = .TRUE. ! Converges ! + ERRQ = 0.0 ! Rain profile exists! +! if (lprnt) print *,' here2' + elseif (tem < zero .and. errq < 0.1) then + skpup = .true. +! if (ntla == numtla .or. tem > -0.003) then + errq = 0.0 +! else +! errq = 10.0 +! endif + ELSE + ERRQ = TX2 ! Further iteration ! +! if (lprnt) print *,' itr=',itr,' errq=',errq +! if (itr == itrmu .and. ERRQ > ERRMIN*10 & +! & .and. ntla == 1) ERRQ = 10.0 + ENDIF + ENDIF +! +! if (lprnt) print *,' ERRQ=',ERRQ + + ENDIF ! SKPUP ENDIF! +! + ENDDO ! End of the ITR Loop!! +! +! if(lprnt) then +! print *,' QRP=',(QRP(L),L=KD,KBL) +! print *,'RNF=',(RNF(L),L=KD,KBL),' RNT=',RNT,' RNB=',RNB +! &,' errq=',errq +! endif +! + IF (ERRQ < 0.1) THEN + DDFT = .TRUE. + RNB = - RNB +! do l=kd1,kb1-1 +! if (wvl(l)-wcbase < 1.0E-9) ddft = .false. +! enddo + ELSE + DDFT = .FALSE. + ENDIF +! +! Caution !! Below is an adjustment to rain flux to maintain +! conservation of precip! +! + IF (DDFT) THEN + TX1 = 0.0 + DO L=KD,KB1 + TX1 = TX1 + RNF(L) + ENDDO +! if (lprnt) print *,' tx1+rnt+rnb=',tx1+rnt+rnb, ' train=',train + TX1 = TRAIN / (TX1+RNT+RNB) + IF (ABS(TX1-1.0) < 0.2) THEN + RNT = MAX(RNT*TX1,ZERO) + RNB = RNB * TX1 + ELSE + DDFT = .FALSE. + ERRQ = 10.0 + ENDIF + ENDIF + enddo ! End of ntla loop +! + DOF = 0.0 + IF (.NOT. DDFT) RETURN ! Rain profile did not converge! +! + + DO L=KD,KB1 + RNF(L) = RNF(L) * TX1 + + ENDDO +! if (lprnt) print *,' TRAIN=',TRAIN +! if (lprnt) print *,' RNF=',RNF +! +! Adjustment is over +! +! Downdraft +! + DO L=KD,K + WCB(L) = 0.0 + ENDDO +! + SKPDD = .NOT. DDFT +! + ERRQ = 10.0 + IF (.NOT. SKPDD) THEN +! +! Calculate Downdraft Properties +! + + KK = MAX(KB1,KD1) + DO L=KK,K + STLT(L) = STLT(L-1) + ENDDO + TEM1 = 1.0 / BB1 +! + DO L=KD,K + IF (L .LE. KBL) THEN + TEM = STLA * TEM1 + STLT(L) = ETA(L) * STLT(L) * TEM / ROR(L) + ELSE + STLT(L) = 0.0 + ENDIF + ENDDO +! if (lprnt) print *,' STLT=',stlt + + rsum1 = 0.0 + rsum2 = 0.0 + +! + IDN = 99 + DO L=KD,K+1 + ETD(L) = 0.0 + WVL(L) = 0.0 +! QRP(L) = 0.0 + ENDDO + DO L=KD,K + EVP(L) = 0.0 + BUY(L) = 0.0 + QRP(L+1) = 0.0 + ENDDO + HOD(KD) = HOL(KD) + QOD(KD) = QOL(KD) + TX1 = 0.0 ! sigma at the top +!!! TX1 = STLT(KD)*QRB(KD)*ONE ! sigma at the top +! TX1 = MIN(STLT(KD)*QRB(KD)*ONE, ONE) ! sigma at the top +! TX1 = MIN(STLT(KD)*QRB(KD)*0.5, ONE) ! sigma at the top + RNTP = 0.0 + TX5 = TX1 + QA(1) = 0.0 +! if(lprnt) print *,' stlt=',stlt(kd),' qrb=',qrb(kd) +! *,' tx1=',tx1,' ror=',ror(kd),' gms=',gms(kd),' rpart=',rpart +! *,' rnt=',rnt +! +! Here we assume RPART of detrained rain RNT goes to Pd +! + IF (RNT > 0.0) THEN + if (TX1 > 0.0) THEN + QRP(KD) = (RPART*RNT / (ROR(KD)*TX1*GMS(KD))) & + & ** (1.0/1.1364) + else + tx1 = RPART*RNT / (ROR(KD)*GMS(KD)*QRP(KD)**1.1364) + endif + RNTP = (1.0 - RPART) * RNT + BUY(KD) = - ROR(KD) * TX1 * QRP(KD) + ELSE + QRP(KD) = 0.0 + ENDIF +! +! L-loop for the downdraft iteration from KD1 to K+1 (bottom surface) +! +! BUD(KD) = ROR(KD) + idnm = 1 + DO L=KD1,K+1 + + QA(1) = 0.0 + ddlgk = idn(idnm) == 99 + if (.not. ddlgk) cycle + IF (L <= K) THEN + ST1 = 1.0 - ALFIND(L) + WA(1) = ALFIND(L)*HOL(L-1) + ST1*HOL(L) + WA(2) = ALFIND(L)*QOL(L-1) + ST1*QOL(L) + WA(3) = ALFIND(L)*TOL(L-1) + ST1*TOL(L) + QA(2) = ALFIND(L)*HST(L-1) + ST1*HST(L) + QA(3) = ALFIND(L)*QST(L-1) + ST1*QST(L) + ELSE + WA(1) = HOL(K) + WA(2) = QOL(K) + WA(3) = TOL(K) + QA(2) = HST(K) + QA(3) = QST(K) + ENDIF +! + FAC = 2.0 + IF (L == KD1) FAC = 1.0 + + FACG = FAC * 0.5 * GMF5 ! 12/17/97 +! +! DDLGK = IDN(idnm) == 99 + BUD(KD) = ROR(L) + +! IF (DDLGK) THEN + TX1 = TX5 + WVL(L) = MAX(WVL(L-1),ONE_M1) + + QRP(L) = MAX(QRP(L-1),QRP(L)) +! +! VT(1) = GMS(L-1) * QRP(L-1) ** 0.1364 + VT(1) = GMS(L-1) * QRPF(QRP(L-1)) + RNT = ROR(L-1) * (WVL(L-1)+VT(1))*QRP(L-1) +! if(lprnt) print *,' l=',l,' qa=',qa(1), ' tx1RNT=',RNT*tx1, +! *' wvl=',wvl(l-1) +! *,' qrp=',qrp(l-1),' tx5=',tx5,' tx1=',tx1,' rnt=',rnt + +! + +! TEM = MAX(ALM, 2.5E-4) * MAX(ETA(L), 1.0) + TEM = MAX(ALM,ONE_M6) * MAX(ETA(L), ONE) +! TEM = MAX(ALM, 1.0E-5) * MAX(ETA(L), 1.0) + TRW(1) = PICON*TEM*(QRB(L-1)+QRT(L-1)) + TRW(2) = 1.0 / TRW(1) +! + VRW(1) = 0.5 * (GAM(L-1) + GAM(L)) + VRW(2) = 1.0 / (VRW(1) + VRW(1)) +! + TX4 = (QRT(L-1)+QRB(L-1))*(ONEBG*FAC*500.00*EKNOB) +! + DOFW = 1.0 / (WA(3) * (1.0 + NU*WA(2))) ! 1.0 / TVbar! +! + ETD(L) = ETD(L-1) + HOD(L) = HOD(L-1) + QOD(L) = QOD(L-1) +! + ERRQ = 10.0 + +! + IF (L <= KBL) THEN + TX3 = STLT(L-1) * QRT(L-1) * (0.5*FAC) + TX8 = STLT(L) * QRB(L-1) * (0.5*FAC) + TX9 = TX8 + TX3 + ELSE + TX3 = 0.0 + TX8 = 0.0 + TX9 = 0.0 + ENDIF +! + TEM = WVL(L-1) + VT(1) + IF (TEM > 0.0) THEN + TEM1 = 1.0 / (TEM*ROR(L-1)) + TX3 = VT(1) * TEM1 * ROR(L-1) * TX3 + TX6 = TX1 * TEM1 + ELSE + TX6 = 1.0 + ENDIF +! ENDIF +! + IF (L == KD1) THEN + IF (RNT > 0.0) THEN + TEM = MAX(QRP(L-1),QRP(L)) + WVL(L) = TX1 * TEM * QRB(L-1)*(FACG*5.0) + ENDIF + WVL(L) = MAX(ONE_M2, WVL(L)) + TRW(1) = TRW(1) * 0.5 + TRW(2) = TRW(2) + TRW(2) + ELSE + IF (DDLGK) EVP(L-1) = EVP(L-2) + ENDIF +! +! No downdraft above level IDH +! + + IF (L < IDH) THEN + + ETD(L) = 0.0 + HOD(L) = WA(1) + QOD(L) = WA(2) + EVP(L-1) = 0.0 + WVL(L) = 0.0 + QRP(L) = 0.0 + BUY(L) = 0.0 + TX5 = TX9 + ERRQ = 0.0 + RNTP = RNTP + RNT * TX1 + RNT = 0.0 + WCB(L-1) = 0.0 + ENDIF +! BUD(KD) = ROR(L) +! +! Iteration loop for a given level L begins +! +! if (lprnt) print *,' tx8=',tx8,' tx9=',tx9,' tx5=',tx5 +! &, ' tx1=',tx1 + DO ITR=1,ITRMD +! +! cnvflg = DDLGK .AND. (ERRQ > ERRMIN) + cnvflg = ERRQ > ERRMIN + IF (cnvflg) THEN +! +! VT(1) = GMS(L) * QRP(L) ** 0.1364 + VT(1) = GMS(L) * QRPF(QRP(L)) + TEM = WVL(L) + VT(1) +! + IF (TEM > 0.0) THEN + ST1 = ROR(L) * TEM * QRP(L) + RNT + IF (ST1 /= 0.0) ST1 = 2.0 * EVP(L-1) / ST1 + TEM1 = 1.0 / (TEM*ROR(L)) + TEM2 = VT(1) * TEM1 * ROR(L) * TX8 + ELSE + TEM1 = 0.0 + TEM2 = TX8 + ST1 = 0.0 + ENDIF +! if (lprnt) print *,' st1=',st1,' tem=',tem,' ror=',ror(l) +! &,' qrp=',qrp(l),' rnt=',rnt,' ror1=',ror(l-1),' wvl=',wvl(l) +! &,' wvl1=',wvl(l-1),' tem2=',tem2,' vt=',vt(1),' tx3=',tx3 +! + st2 = tx5 + TEM = ROR(L)*WVL(L) - ROR(L-1)*WVL(L-1) + if (tem > 0.0) then + TX5 = (TX1 - ST1 + TEM2 + TX3)/(1.0+tem*tem1) + else + TX5 = TX1 - tem*tx6 - ST1 + TEM2 + TX3 + endif + TX5 = MAX(TX5,ZERO) + tx5 = 0.5 * (tx5 + st2) +! +! qqq = 1.0 + tem * tem1 * (1.0 - sialf) +! +! if (qqq > 0.0) then +! TX5 = (TX1 - sialf*tem*tx6 - ST1 + TEM2 + TX3) / qqq +! else +! TX5 = (TX1 - tem*tx6 - ST1 + TEM2 + TX3) +! endif +! +! if(lprnt) print *,' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' +! if(tx5 <= 0.0 .and. l > kd+2) +! * print *,' tx51=',tx5,' tx1=',tx1,' st1=',st1,' tem2=' +! *,tem2,' tx3=',tx3,' tem=',tem,' tem1=',tem1,' wvl=',wvl(l-1), +! &wvl(l),' l=',l,' itr=',itr,' evp=',evp(l-1),' vt=',vt(1) +! *,' qrp=',qrp(l),' rnt=',rnt,' kd=',kd +! if (lprnt) print *,' etd=',etd(l),' wvl=',wvl(l) +! &,' trw=',trw(1),trw(2),' ror=',ror(l),' wa=',wa + + +! + TEM1 = ETD(L) + ETD(L) = ROR(L) * TX5 * MAX(WVL(L),ZERO) +! + if (etd(l) > 0.0) etd(l) = 0.5 * (etd(l) + tem1) +! + + DEL_ETA = ETD(L) - ETD(L-1) + +! TEM = DEL_ETA * TRW(2) +! TEM2 = MAX(MIN(TEM, 1.0), -1.0) +! IF (ABS(TEM) > 1.0 .AND. ETD(L) > 0.0 ) THEN +! DEL_ETA = TEM2 * TRW(1) +! ETD(L) = ETD(L-1) + DEL_ETA +! ENDIF +! IF (WVL(L) > 0.0) TX5 = ETD(L) / (ROR(L)*WVL(L)) +! + ERRE = ETD(L) - TEM1 +! + tem = max(abs(del_eta), trw(1)) + tem2 = del_eta / tem + TEM1 = SQRT(MAX((tem+DEL_ETA)*(tem-DEL_ETA),ZERO)) +! TEM1 = SQRT(MAX((TRW(1)+DEL_ETA)*(TRW(1)-DEL_ETA),0.0)) + + EDZ = (0.5 + ASIN(TEM2)*PIINV)*DEL_ETA + TEM1*PIINV + + DDZ = EDZ - DEL_ETA + WCB(L-1) = ETD(L) + DDZ +! + TEM1 = HOD(L) + IF (DEL_ETA > 0.0) THEN + QQQ = 1.0 / (ETD(L) + DDZ) + HOD(L) = (ETD(L-1)*HOD(L-1) + DEL_ETA*HOL(L-1) & + & + DDZ*WA(1)) * QQQ + QOD(L) = (ETD(L-1)*QOD(L-1) + DEL_ETA*QOL(L-1) & + & + DDZ*WA(2)) * QQQ + ELSEif((ETD(L-1) + EDZ) > 0.0) then + QQQ = 1.0 / (ETD(L-1) + EDZ) + HOD(L) = (ETD(L-1)*HOD(L-1) + EDZ*WA(1)) * QQQ + QOD(L) = (ETD(L-1)*QOD(L-1) + EDZ*WA(2)) * QQQ + ENDIF + ERRH = HOD(L) - TEM1 + ERRQ = ABS(ERRH/HOD(L)) + ABS(ERRE/MAX(ETD(L),ONE_M5)) +! if (lprnt) print *,' ERRQP=',errq,' errh=',errh,' hod=',hod(l) +! &,' erre=',erre,' etd=',etd(l),' del_eta=',del_eta + DOF = DDZ + VT(2) = QQQ + +! + DDZ = DOF + TEM4 = QOD(L) + TEM1 = VRW(1) +! + QHS = QA(3) + 0.5 * (GAF(L-1)+GAF(L)) & + & * (HOD(L)-QA(2)) +! +! First iteration ! +! + ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) + TEM2 = ROR(L) * QRP(L) + CALL QRABF(TEM2,QRAF,QRBF) + TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 +! + CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) +! + TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*QOD(L)) + TEM3 = (1.0 + TEM1) * QHS * (QOD(L)+CE) + TEM = MAX(TEM2*TEM2 - 4.0*TEM1*TEM3,ZERO) + QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) +! + +! +! second iteration ! +! + ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) + CE = TEM6 * ST2 / ((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) +! CEE = CE * (ETD(L)+DDZ) +! + + + TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*tem4) + TEM3 = (1.0 + TEM1) * QHS * (tem4+CE) + TEM = MAX(TEM2*TEM2 - 4.0*TEM1*TEM3,ZERO) + QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) +! Evaporation in Layer L-1 +! + + EVP(L-1) = (QOD(L)-TEM4) * (ETD(L)+DDZ) +! Calculate Pd (L+1/2) + QA(1) = TX1*RNT + RNF(L-1) - EVP(L-1) +! +! if(lprnt) print *,' etd=',etd(l),' tx5=',tx5,' rnt=',rnt +! *,' rnf=',rnf(l-1),' evp=',evp(l-1),' itr=',itr,' L=',L + +! + if (qa(1) > 0.0) then + IF (ETD(L) > 0.0) THEN + TEM = QA(1) / (ETD(L)+ROR(L)*TX5*VT(1)) + QRP(L) = MAX(TEM,ZERO) + ELSEIF (TX5 > 0.0) THEN + QRP(L) = (MAX(ZERO,QA(1)/(ROR(L)*TX5*GMS(L)))) & + & ** (1.0/1.1364) + ELSE + QRP(L) = 0.0 + ENDIF + else + qrp(l) = 0.5 * qrp(l) + endif +! Compute Buoyancy + TEM1 = WA(3)+(HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & + & * (1.0/CP) +! if (lprnt) print *,' tem1=',tem1,' wa3=',wa(3),' hod=' +! &,hod(l),' wa1=',wa(1),' qod=',qod(l),' wa2=',wa(2),' alhl=',alhl +! &,' cmpor=',cmpor,' dofw=',dofw,' prl=',prl(l),' qrp=',qrp(l) + TEM1 = TEM1 * (1.0 + NU*QOD(L)) + ROR(L) = CMPOR * PRL(L) / TEM1 + TEM1 = TEM1 * DOFW +!!! TEM1 = TEM1 * (1.0 + NU*QOD(L)) * DOFW + + BUY(L) = (TEM1 - 1.0 - QRP(L)) * ROR(L) * TX5 +! Compute W (L+1/2) + + TEM1 = WVL(L) +! IF (ETD(L) > 0.0) THEN + WVL(L) = VT(2) * (ETD(L-1)*WVL(L-1) - FACG & + & * (BUY(L-1)*QRT(L-1)+BUY(L)*QRB(L-1))) +! +! if (lprnt) print *,' wvl=',wvl(l),'vt2=',vt(2),' buy1=' +! &,buy(l-1),' buy=',buy(l),' qrt1=',qrt(l-1),' qrb1=',qrb(l-1) +! &,' etd1=',etd(l-1),' wvl1=',wvl(l-1) +! ENDIF +! + if (wvl(l) < 0.0) then +! WVL(L) = max(wvl(l), 0.1*tem1) +! WVL(L) = 0.5*tem1 +! WVL(L) = 0.1*tem1 +! WVL(L) = 0.0 + WVL(L) = 1.0e-10 + else + WVL(L) = 0.5*(WVL(L)+TEM1) + endif + +! +! WVL(L) = max(0.5*(WVL(L)+TEM1), 0.0) + + ERRW = WVL(L) - TEM1 +! + ERRQ = ERRQ + ABS(ERRW/MAX(WVL(L),ONE_M5)) + +! if (lprnt) print *,' errw=',errw,' wvl=',wvl(l) +! if(lprnt .or. tx5 == 0.0) then +! if(tx5 == 0.0 .and. l > kbl) then +! print *,' errq=',errq,' itr=',itr,' l=',l,' wvl=',wvl(l) +! &,' tx5=',tx5,' idnm=',idnm,' etd1=',etd(l-1),' etd=',etd(l) +! &,' kbl=',kbl +! endif +! +! if(lprnt) print *,' itr=',itr,' itrmnd=',itrmnd,' itrmd=',itrmd +! IF (ITR >= MIN(ITRMIN,ITRMD/2)) THEN + IF (ITR >= MIN(ITRMND,ITRMD/2)) THEN +! if(lprnt) print *,' itr=',itr,' etd1=',etd(l-1),' errq=',errq + IF (ETD(L-1) == 0.0 .AND. ERRQ > 0.2) THEN +! if(lprnt) print *,' bud=',bud(kd),' wa=',wa(1),wa(2) + ROR(L) = BUD(KD) + ETD(L) = 0.0 + WVL(L) = 0.0 + ERRQ = 0.0 + HOD(L) = WA(1) + QOD(L) = WA(2) +! TX5 = TX1 + TX9 + if (L .le. KBL) then + TX5 = TX9 + else + TX5 = (STLT(KB1) * QRT(KB1) & + & + STLT(KBL) * QRB(KB1)) * (0.5*FAC) + endif + +! if(lprnt) print *,' tx1=',tx1,' rnt=',rnt,' rnf=',rnf(l-1) +! *,' evp=',evp(l-1),' l=',l + + EVP(L-1) = 0.0 + TEM = MAX(TX1*RNT+RNF(L-1),ZERO) + QA(1) = TEM - EVP(L-1) +! IF (QA(1) > 0.0) THEN + +! if(lprnt) print *,' ror=',ror(l),' tx5=',tx5,' tx1=',tx1 +! *,' tx9=',tx9,' gms=',gms(l),' qa=',qa(1) +! if(lprnt) call mpi_quit(13) +! if (tx5 == 0.0 .or. gms(l) == 0.0) +! if (lprnt) +! * print *,' Atx5=',tx5,' gms=',gms(l),' ror=',ror(l) +! *,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 +! *,' kbl=',kbl,' etd1=',etd(l-1),' idnm=',idnm,' idn=',idn(idnm) +! *,' errq=',errq + + QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & + & ** (1.0/1.1364) +! endif + BUY(L) = - ROR(L) * TX5 * QRP(L) + WCB(L-1) = 0.0 + ENDIF +! + DEL_ETA = ETD(L) - ETD(L-1) + IF(DEL_ETA < 0.0 .AND. ERRQ > 0.1) THEN + ROR(L) = BUD(KD) + ETD(L) = 0.0 + WVL(L) = 0.0 +!!!!! TX5 = TX1 + TX9 + CLDFRD(L-1) = TX5 +! + DEL_ETA = - ETD(L-1) + EDZ = 0.0 + DDZ = -DEL_ETA + WCB(L-1) = DDZ +! + HOD(L) = HOD(L-1) + QOD(L) = QOD(L-1) +! + TEM4 = QOD(L) + TEM1 = VRW(1) +! + QHS = QA(3) + 0.5 * (GAF(L-1)+GAF(L)) & + & * (HOD(L)-QA(2)) + +! +! First iteration ! +! + ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) + TEM2 = ROR(L) * QRP(L-1) + CALL QRABF(TEM2,QRAF,QRBF) + TEM6 = TX5 * (1.6 + 124.9 * QRAF) * QRBF * TX4 +! + CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) +! + + TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*QOD(L)) + TEM3 = (1.0 + TEM1) * QHS * (QOD(L)+CE) + TEM = MAX(TEM2*TEM2 -FOUR*TEM1*TEM3,ZERO) + QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) +! +! second iteration ! +! + ST2 = PRL(L) * (QHS + TEM1 * (QHS-QOD(L))) + CE = TEM6*ST2/((5.4E5*ST2 + 2.55E6)*(ETD(L)+DDZ)) +! CEE = CE * (ETD(L)+DDZ) +! + + + TEM2 = - ((1.0+TEM1)*(QHS+CE) + TEM1*tem4) + TEM3 = (1.0 + TEM1) * QHS * (tem4+CE) + TEM = MAX(TEM2*TEM2 -FOUR*TEM1*TEM3,ZERO) + QOD(L) = MAX(TEM4, (- TEM2 - SQRT(TEM)) * VRW(2)) + +! Evaporation in Layer L-1 +! + EVP(L-1) = (QOD(L)-TEM4) * (ETD(L)+DDZ) + +! Calculate Pd (L+1/2) +! RNN(L-1) = TX1*RNT + RNF(L-1) - EVP(L-1) + + QA(1) = TX1*RNT + RNF(L-1) + EVP(L-1) = min(EVP(L-1), QA(1)) + QA(1) = QA(1) - EVP(L-1) + qrp(l) = 0.0 + +! +! if (tx5 == 0.0 .or. gms(l) == 0.0) +! if (lprnt) +! * print *,' Btx5=',tx5,' gms=',gms(l),' ror=',ror(l) +! *,' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 +! *,' kbl=',kbl,' etd1=',etd(l-1),' DEL_ETA=',DEL_ETA +! &,' evp=',evp(l-1) +! +! IF (QA(1) > 0.0) THEN +!! RNS(L-1) = QA(1) +!!! tx5 = tx9 +! QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & +! & ** (1.0/1.1364) +! endif +! ERRQ = 0.0 +! Compute Buoyancy +! TEM1 = WA(3)+(HOD(L)-WA(1)-ALHL*(QOD(L)-WA(2))) & +! & * (1.0/CP) +! TEM1 = TEM1 * (1.0 + NU*QOD(L)) * DOFW +! BUY(L) = (TEM1 - 1.0 - QRP(L)) * ROR(L) * TX5 +! +! IF (QA(1) > 0.0) RNS(L) = QA(1) + + IF (L .LE. K) THEN + RNS(L) = QA(1) + QA(1) = 0.0 + ENDIF + tx5 = tx9 + ERRQ = 0.0 + QRP(L) = 0.0 + BUY(L) = 0.0 +! + ENDIF + ENDIF + ENDIF +! + ENDDO ! End of the iteration loop for a given L! + IF (L <= K) THEN + IF (ETD(L-1) == 0.0 .AND. ERRQ > 0.1 .and. l <= kbl) THEN +!!! & .AND. ERRQ > ERRMIN*10.0 .and. l <= kbl) THEN +! & .AND. ERRQ > ERRMIN*10.0) THEN + ROR(L) = BUD(KD) + HOD(L) = WA(1) + QOD(L) = WA(2) + TX5 = TX9 ! Does not make too much difference! +! TX5 = TX1 + TX9 + EVP(L-1) = 0.0 +! EVP(L-1) = CEE * (1.0 - qod(l)/qa(3)) + QA(1) = TX1*RNT + RNF(L-1) + EVP(L-1) = min(EVP(L-1), QA(1)) + QA(1) = QA(1) - EVP(L-1) + +! QRP(L) = 0.0 +! if (tx5 == 0.0 .or. gms(l) == 0.0) then +! print *,' Ctx5=',tx5,' gms=',gms(l),' ror=',ror(l) & +! &, ' L=',L,' QA=',QA(1),' tx1=',tx1,' tx9=',tx9 & +! &, ' kbl=',kbl,' etd1=',etd(l-1),' DEL_ETA=',DEL_ETA +! endif +! IF (QA(1) > 0.0) THEN + + QRP(L) = (QA(1) / (ROR(L)*TX5*GMS(L))) & + & ** (1.0/1.1364) +! ENDIF + ETD(L) = 0.0 + WVL(L) = 0.0 + ST1 = 1.0 - ALFIND(L) + + ERRQ = 0.0 + BUY(L) = - ROR(L) * TX5 * QRP(L) + WCB(L-1) = 0.0 + ENDIF + ENDIF +! + LL = MIN(IDN(idnm), K+1) + IF (ERRQ < 1.0 .AND. L <= LL) THEN + IF (ETD(L-1) > 0.0 .AND. ETD(L) == 0.0) THEN + IDN(idnm) = L + wvl(l) = 0.0 + if (L < KBL .or. tx5 > 0.0) idnm = idnm + 1 + errq = 0.0 + ENDIF + if (etd(l) == 0.0 .and. l > kbl) then + idn(idnm) = l + if (tx5 > 0.0) idnm = idnm + 1 + endif + ENDIF + +! if (lprnt) then +! print *,' ERRQ=',ERRQ,' IDN=',IDN(idnm),' idnm=',idnm +! print *,' L=',L,' QRP=',QRP(L),' ETD=',ETD(L),' QA=',QA(1) +! *,' evp=',evp(l-1),' rnf=',rnf(l-1) +! endif + +! +! If downdraft properties are not obtainable, (i.e.solution does +! not converge) , no downdraft is assumed +! +! IF (ERRQ > ERRMIN*100.0 .AND. IDN(idnm) == 99) & + IF (ERRQ > 0.1 .AND. IDN(idnm) == 99) & + & DDFT = .FALSE. +! +! + DOF = 0.0 + IF (.NOT. DDFT) RETURN +! +! if (ddlgk .or. l .le. idn(idnm)) then +! rsum2 = rsum2 + evp(l-1) +! print *,' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' qa=',qa(1)& +! &, ' evp=',evp(l-1) +! else +! rsum1 = rsum1 + rnf(l-1) +! print *,' rsum1=',rsum1,' rsum2=',rsum2,' L=',L,' rnf=', & +! & rnf(l-1) +! endif + + ENDDO ! End of the L Loop of downdraft ! + + TX1 = 0.0 + + DOF = QA(1) +! +! print *,' dof=',dof,' rntp=',rntp,' rnb=',rnb +! print *,' total=',(rsum1+dof+rntp+rnb) + + ENDIF ! SKPDD endif +! + + dof = max(dof, 0.0) + RNN(KD) = RNTP + TX1 = EVP(KD) + TX2 = RNTP + RNB + DOF + +! if (lprnt) print *,' tx2=',tx2 + II = IDH + IF (II >= KD1+1) THEN + RNN(KD) = RNN(KD) + RNF(KD) + TX2 = TX2 + RNF(KD) + RNN(II-1) = 0.0 + TX1 = EVP(II-1) + ENDIF +! if (lprnt) print *,' tx2=',tx2,' idnm=',idnm,' idn=',idn(idnm) + DO L=KD,K + II = IDH + + IF (L > KD1 .AND. L < II) THEN + RNN(L-1) = RNF(L-1) + TX2 = TX2 + RNN(L-1) + ELSEIF (L >= II .AND. L < IDN(idnm)) THEN + rnn(l) = rns(l) + tx2 = tx2 + rnn(l) + TX1 = TX1 + EVP(L) + ELSEIF (L >= IDN(idnm)) THEN + ETD(L+1) = 0.0 + HOD(L+1) = 0.0 + QOD(L+1) = 0.0 + EVP(L) = 0.0 + RNN(L) = RNF(L) + RNS(L) + TX2 = TX2 + RNN(L) + ENDIF +! if (lprnt) print *,' tx2=',tx2,' L=',L,' rnn=',rnn(l) + ENDDO +! +! For Downdraft case the rain is that falls thru the bottom + + L = KBL + + RNN(L) = RNN(L) + RNB + CLDFRD(L) = TX5 + +! +! Caution !! Below is an adjustment to rain flux to maintain +! conservation of precip! + +! +! if (lprnt) print *,' train=',train,' tx2=',tx2,' tx1=',tx1 + + IF (TX1 > 0.0) THEN + TX1 = (TRAIN - TX2) / TX1 + ELSE + TX1 = 0.0 + ENDIF + + DO L=KD,K + EVP(L) = EVP(L) * TX1 + ENDDO +! +!*********************************************************************** +!*********************************************************************** + + RETURN + END + + SUBROUTINE QSATCN(TT,P,Q,DQDT) +! SUBROUTINE QSATCN(TT,P,Q,DQDT,lprnt) + + USE MACHINE , ONLY : kind_phys + USE FUNCPHYS , ONLY : fpvs + USE PHYSCONS, RV => con_RV, CVAP => con_CVAP, CLIQ => con_CLIQ & + &, CSOL => con_CSOL, TTP => con_TTP, HVAP => con_HVAP & + &, HFUS => con_HFUS, EPS => con_eps & + &, EPSM1 => con_epsm1 + implicit none +! + real(kind=kind_phys) TT, P, Q, DQDT +! + real(kind=kind_phys) rvi, facw, faci, hsub, tmix, DEN + real(kind=kind_phys) ZERO,ONE,ONE_M10 + PARAMETER (RVI=1.0/RV) + PARAMETER (FACW=CVAP-CLIQ, FACI=CVAP-CSOL) + PARAMETER (HSUB=HVAP+HFUS, tmix=TTP-20.0, DEN=1.0/(TTP-TMIX)) + PARAMETER (ZERO=0.,ONE=1.,ONE_M10=1.E-10) +! logical lprnt +! + real(kind=kind_phys) es, d, hlorv, W +! +! es = 10.0 * fpvs(tt) ! fpvs is in centibars! + es = 0.01 * fpvs(tt) ! fpvs is in Pascals! + D = 1.0 / max(p+epsm1*es,ONE_M10) +! + q = MIN(eps*es*D, ONE) +! + W = max(ZERO, min(ONE, (TT - TMIX)*DEN)) + hlorv = ( W * (HVAP + FACW * (tt-ttp)) & + & + (1.0-W) * (HSUB + FACI * (tt-ttp)) ) * RVI + dqdt = p * q * hlorv * D / (tt*tt) +! + return + end + + SUBROUTINE ANGRAD( PRES, ALM, AL2, TLA, PRB, WFN, UFN) + USE MACHINE , ONLY : kind_phys + use module_ras , only : refp, refr, tlac, plac, tlbpl, drdp, almax + implicit none + + real(kind=kind_phys) PRES, ALM, AL2, TLA, TEM, TEM1 & + &, PRB, ACR, WFN, UFN +! + integer i +! + IF (TLA < 0.0) THEN + IF (PRES <= PLAC(1)) THEN + TLA = TLAC(1) + ELSEIF (PRES <= PLAC(2)) THEN + TLA = TLAC(2) + (PRES-PLAC(2))*tlbpl(1) + ELSEIF (PRES <= PLAC(3)) THEN + TLA = TLAC(3) + (PRES-PLAC(3))*tlbpl(2) + ELSEIF (PRES <= PLAC(4)) THEN + TLA = TLAC(4) + (PRES-PLAC(4))*tlbpl(3) + ELSEIF (PRES <= PLAC(5)) THEN + TLA = TLAC(5) + (PRES-PLAC(5))*tlbpl(4) + ELSEIF (PRES <= PLAC(6)) THEN + TLA = TLAC(6) + (PRES-PLAC(6))*tlbpl(5) + ELSEIF (PRES <= PLAC(7)) THEN + TLA = TLAC(7) + (PRES-PLAC(7))*tlbpl(6) + ELSEIF (PRES <= PLAC(8)) THEN + TLA = TLAC(8) + (PRES-PLAC(8))*tlbpl(7) + ELSE + TLA = TLAC(8) + ENDIF + ENDIF + IF (PRES >= REFP(1)) THEN + TEM = REFR(1) + ELSEIF (PRES >= REFP(2)) THEN + TEM = REFR(1) + (PRES-REFP(1)) * drdp(1) + ELSEIF (PRES >= REFP(3)) THEN + TEM = REFR(2) + (PRES-REFP(2)) * drdp(2) + ELSEIF (PRES >= REFP(4)) THEN + TEM = REFR(3) + (PRES-REFP(3)) * drdp(3) + ELSEIF (PRES >= REFP(5)) THEN + TEM = REFR(4) + (PRES-REFP(4)) * drdp(4) + ELSEIF (PRES >= REFP(6)) THEN + TEM = REFR(5) + (PRES-REFP(5)) * drdp(5) + ELSE + TEM = REFR(6) + ENDIF +! + tem = 2.0E-4 / tem + al2 = min(4.0*tem, max(alm, tem)) +! + RETURN + END + SUBROUTINE SETQRP + USE MACHINE , ONLY : kind_phys + use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB + implicit none + + real(kind=kind_phys) tem2,tem1,x,xinc,xmax,xmin + integer jx +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! XMIN = 1.0E-6 + XMIN = 0.0 + XMAX = 5.0 + XINC = (XMAX-XMIN)/(NQRP-1) + C2XQRP = 1.0/XINC + C1XQRP = 1.0 - XMIN*C2XQRP + TEM1 = 0.001 ** 0.2046 + TEM2 = 0.001 ** 0.525 + DO JX=1,NQRP + X = XMIN + (JX-1)*XINC + TBQRP(JX) = X ** 0.1364 + TBQRA(JX) = TEM1 * X ** 0.2046 + TBQRB(JX) = TEM2 * X ** 0.525 + ENDDO +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END + FUNCTION QRPF(QRP) +! + USE MACHINE , ONLY : kind_phys + use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB + implicit none + + real(kind=kind_phys) QRP, QRPF, XJ, REAL_NQRP, ONE + PARAMETER (ONE=1.0) + INTEGER JX +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL_NQRP = REAL(NQRP) + XJ = MIN(MAX(C1XQRP+C2XQRP*QRP,ONE),REAL_NQRP) +! XJ = MIN(MAX(C1XQRP+C2XQRP*QRP,ONE),FLOAT(NQRP)) + JX = MIN(XJ,NQRP-ONE) + QRPF = TBQRP(JX) + (XJ-JX) * (TBQRP(JX+1)-TBQRP(JX)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END + SUBROUTINE QRABF(QRP,QRAF,QRBF) + USE MACHINE , ONLY : kind_phys + use module_ras , only : NQRP,C1XQRP,C2XQRP,TBQRP,TBQRA,TBQRB + implicit none +! + real(kind=kind_phys) QRP, QRAF, QRBF, XJ, REAL_NQRP, ONE + PARAMETER (ONE=1.0) + INTEGER JX +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL_NQRP = REAL(NQRP) + XJ = MIN(MAX(C1XQRP+C2XQRP*QRP,ONE),REAL_NQRP) + JX = MIN(XJ,NQRP-ONE) + XJ = XJ - JX + QRAF = TBQRA(JX) + XJ * (TBQRA(JX+1)-TBQRA(JX)) + QRBF = TBQRB(JX) + XJ * (TBQRB(JX+1)-TBQRB(JX)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END + SUBROUTINE SETVTP + USE MACHINE , ONLY : kind_phys + use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP + implicit none + + real(kind=kind_phys) vtpexp,xinc,x,xmax,xmin + integer jx + PARAMETER(VTPEXP=-0.3636) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + XMIN = 0.05 + XMAX = 1.5 + XINC = (XMAX-XMIN)/(NVTP-1) + C2XVTP = 1.0/XINC + C1XVTP = 1.0 - XMIN*C2XVTP + DO JX=1,NVTP + X = XMIN + (JX-1)*XINC + TBVTP(JX) = X ** VTPEXP + ENDDO +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END + FUNCTION VTPF(ROR) +! + USE MACHINE , ONLY : kind_phys + use module_ras , only : NVTP,C1XVTP,C2XVTP,TBVTP + implicit none + real(kind=kind_phys) ROR, VTPF, XJ, REAL_NVTP, ONE + PARAMETER (ONE=1.0) + INTEGER JX +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + REAL_NVTP = REAL(NVTP) + XJ = MIN(MAX(C1XVTP+C2XVTP*ROR,ONE),REAL_NVTP) + JX = MIN(XJ,NVTP-ONE) + VTPF = TBVTP(JX) + (XJ-JX) * (TBVTP(JX+1)-TBVTP(JX)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END + FUNCTION CLF(PRATE) +! + USE MACHINE , ONLY : kind_phys + implicit none + real(kind=kind_phys) PRATE, CLF +! + real (kind=kind_phys), parameter :: ccf1=0.30, ccf2=0.09 & + &, ccf3=0.04, ccf4=0.01 & + &, pr1=1.0, pr2=5.0 & + &, pr3=20.0 +! + if (prate < pr1) then + clf = ccf1 + elseif (prate < pr2) then + clf = ccf2 + elseif (prate < pr3) then + clf = ccf3 + else + clf = ccf4 + endif +! + RETURN + END diff --git a/gsmphys/rayleigh_damp.f b/gsmphys/rayleigh_damp.f new file mode 100755 index 00000000..8149fa02 --- /dev/null +++ b/gsmphys/rayleigh_damp.f @@ -0,0 +1,90 @@ + SUBROUTINE Rayleigh_damp(IM,IX,IY,KM,A,B,C,U1,V1,DT,CP, + & LEVR,pgr,PRSL,PRSLRD0,ral_ts) +! +! ******************************************************************** +! -----> I M P L E M E N T A T I O N V E R S I O N <---------- +! +! --- rayleigh friction with total energy conservation --- +! ---------------- ----------------------- +! +!------ friction coefficient is based on deldif ---- +!----------------------------------------------------------------------C +! USE +! ROUTINE IS CALLED FROM GBPHYS (AFTER CALL TO GWDPS) +! +! PURPOSE +! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- +! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V ARE +! ALTERED TO INCLUDE/MIMIC THE EFFECT OF NON-STATIONARY +! GRAVITY WAVE DRAG FROM CONVECTION, FRONTGENOSIS, +! WIND SHEAR ETC. LOSS OF KINETIC ENERGY FORM GWD DRAG +! IS CONVERTED INTO INTERNAL ENERGY. +! +! INPUT +! A(IY,KM) NON-LIN TENDENCY FOR V WIND COMPONENT +! B(IY,KM) NON-LIN TENDENCY FOR U WIND COMPONENT +! C(IY,KM) NON-LIN TENDENCY FOR TEMPERATURE +! U1(IX,KM) ZONAL WIND M/SEC AT T0-DT +! V1(IX,KM) MERIDIONAL WIND M/SEC AT T0-DT +! T1(IX,KM) TEMPERATURE DEG K AT T0-DT +! +! DT TIME STEP SECS +! pgr(im) surface pressure (Pa) +! prsl(IX,KM) PRESSURE AT MIDDLE OF LAYER (Pa) +! prslrd0 pressure level above which to apply Rayleigh damping +! ral_ts timescale in days for Rayleigh damping +! +! OUTPUT +! A, B, C AS AUGMENTED BY TENDENCY DUE TO RAYLEIGH FRICTION +! ******************************************************************** + USE MACHINE , ONLY : kind_phys + implicit none +! + integer,intent(in) :: im, ix, iy, km,levr + real(kind=kind_phys),intent(in) :: DT, CP, PRSLRD0, ral_ts + real(kind=kind_phys),intent(in) :: pgr(im), PRSL(IX,KM) + real(kind=kind_phys),intent(in) :: U1(IX,KM), V1(IX,KM) + real(kind=kind_phys),intent(inout) :: A(IY,KM), B(IY,KM), C(IY,KM) + +!--- local variables + real(kind=kind_phys), parameter :: cons1=1.0, cons2=2.0, half=0.5 + real(kind=kind_phys) DTAUX, DTAUY, wrk1, rtrd1, rfactrd, wrk2 + &, ENG0, ENG1, tem1, tem2, dti, hfbcpdt, rtrd + real(kind=kind_phys) tx1(im) + integer i, k +! + if (ral_ts <= 0.0 .or. prslrd0 == 0.0) return +! + RTRD1 = 1.0/(ral_ts*86400) ! RECIPROCAL OF TIME SCALE PER SCALE HEIGHT + ! ABOVE BEGINNING SIGMA LEVEL FOR RAYLEIGH DAMPING + dti = cons1 / dt + hfbcpdt = half / (cp*dt) +! + DO K=1,km + IF(PRSL(1,K) < PRSLRD0) THEN ! applied only on constant pressure surfaces + wrk1 = LOG(PRSLRD0/PRSL(1,K)) + if (k > levr) then + RTRD = RTRD1 * wrk1 * wrk1 + else + RTRD = RTRD1 * wrk1 + endif + ELSE + RTRD = 0 + ENDIF + DO I = 1,IM + RFACTRD = CONS1 / (CONS1+DT*RTRD) - cons1 + DTAUX = U1(I,k) * RFACTRD + DTAUY = V1(I,k) * RFACTRD + ENG0 = U1(I,K)*U1(I,K) + V1(I,K)*V1(I,K) + tem1 = U1(I,K) + DTAUX + tem2 = V1(I,K) + DTAUY + ENG1 = tem1*tem1 + tem2*tem2 + A(I,K) = A(I,K) + DTAUY * dti + B(I,K) = B(I,K) + DTAUX * dti + C(I,K) = C(I,K) + max((ENG0-ENG1),0.0) * hfbcpdt + ENDDO + ENDDO + + + RETURN + END diff --git a/gsmphys/rayleigh_damp_mesopause.f b/gsmphys/rayleigh_damp_mesopause.f new file mode 100755 index 00000000..9338f92b --- /dev/null +++ b/gsmphys/rayleigh_damp_mesopause.f @@ -0,0 +1,105 @@ + SUBROUTINE Rayleigh_damp_mesopause(IM,IX,IY,KM,A,B,C,U1,V1,DT,CP, + & LEVR,PRSL,PRSLRD0) +! +! ******************************************************************** +! -----> I M P L E M E N T A T I O N V E R S I O N <---------- +! +! --- rayleigh friction with total energy conserving --- +! ---------------- ----------------------- +! +!------ friction coefficient is based on deldif ---- +!----------------------------------------------------------------------C +! USE +! ROUTINE IS CALLED FROM GBPHYS (AFTER CALL TO GWDPS) +! +! PURPOSE +! USING THE GWD PARAMETERIZATIONS OF PS-GLAS AND PH- +! GFDL TECHNIQUE. THE TIME TENDENCIES OF U V ARE +! ALTERED TO INCLUDE/MIMIC THE EFFECT OF NON-STATIONARY +! GRAVITY WAVE DRAG FROM CONVECTION, FRONTGENOSIS, +! WIND SHEAR ETC. LOSS OF KINETIC ENERGY FORM GWD DRAG +! IS CONVERTED INTO INTERNAL ENERGY. +! +! INPUT +! A(IY,KM) NON-LIN TENDENCY FOR V WIND COMPONENT +! B(IY,KM) NON-LIN TENDENCY FOR U WIND COMPONENT +! C(IY,KM) NON-LIN TENDENCY FOR TEMPERATURE +! U1(IX,KM) ZONAL WIND M/SEC AT T0-DT +! V1(IX,KM) MERIDIONAL WIND M/SEC AT T0-DT +! T1(IX,KM) TEMPERATURE DEG K AT T0-DT +! +! DT TIME STEP SECS +! PSRL(IX,KM) P AT MIDDLE OF LAYER PASCAL +! PSRLRD0 P LEVEL AT MIDDLE OF LAYER PASCAL FROM WHICH RAYLEIGH +! FRICTION IS APPLIED +! +! OUTPUT +! A, B, C AS AUGMENTED BY TENDENCY DUE TO RAYLEIGH FRICTION +! Revision +! Jan 2014: Jun Wang Modified grid point rayleigh damping (henry Juang) +! to apply it around mesopause,and use pressure +! instead of p/psfc at model layer +! ******************************************************************** + USE MACHINE , ONLY : kind_phys + implicit none +! + integer,intent(in) :: im, ix, iy, km,levr + real(kind=kind_phys),intent(in) :: DT, CP, PRSLRD0 + real(kind=kind_phys),intent(in) :: PRSL(IX,KM) + real(kind=kind_phys),intent(in) :: U1(IX,KM), V1(IX,KM) + real(kind=kind_phys),intent(inout) :: A(IY,KM), B(IY,KM), C(IY,KM) +! +!--- local vars + real(kind=kind_phys) RTRD(km) + real(kind=kind_phys) CONS1, CONS2, HALF + real(kind=kind_phys) SCLK + real(kind=kind_phys) DTAUX, DTAUY, WRK1, RTRD0, RTRD1, RFACTRD + real(kind=kind_phys) ENG0, ENG1 + integer I, K, KSTR, kmesopause +! +! Some constants +! + CONS1 = 1.0 + CONS2 = 2.0 + HALF = CONS1/CONS2 +!change prslrd0(2mb) to pascal +!jw PRSLRD0 = 200 +!-----INITIALIZE SOME ARRAYS +! + RTRD0=1./(80*86400.) ! RECIPROCAL OF TIME SCALE PER SCALE HEIGHT, k0 + RTRD1=1./(4*86400.) ! RECIPROCAL OF TIME SCALE PER SCALE HEIGHT, k1 + Kmesopause=95 +! if (me == 0) then +! print *, '***IDEA*** Using physical diffusion in all layers' +! print *,'rtrd1=',RTRD1,'rtrd0=',RTRD0,'Kmesopause=',Kmesopause +! endif +! pressure in pascal + KSTR=1 + DO K=1,km + IF(PRSL(1,K) < PRSLRD0) THEN + sclk=(K-Kmesopause)/10. + RTRD(K) = RTRD0 + RTRD1*2.0/cosh(sclk) + ELSE + RTRD(K) = 0 + ENDIF +! print *,'in rayleigh_damp_mesopause, k=',k, +! & 'RTRD(K)=',RTRD(K),'RTRD1=',RTRD1,2.0/cosh(sclk), +! & 'prsl(1,k)=',prsl(1,k),'prslrd0=',prslrd0 + ENDDO + + DO K = 1,KM + DO I = 1,IM + RFACTRD = CONS1/(CONS1+DT*RTRD(K)) + DTAUX = U1(I,k)*(RFACTRD-CONS1)/DT + DTAUY = V1(I,k)*(RFACTRD-CONS1)/DT + ENG0 = HALF*(U1(I,K)*U1(I,K)+V1(I,K)*V1(I,K)) + ENG1 = HALF*((U1(I,K)+DTAUX*DT)*(U1(I,K)+DTAUX*DT)+ + & (V1(I,K)+DTAUY*DT)*(V1(I,K)+DTAUY*DT)) + A(I,K) = A(I,K) + DTAUY + B(I,K) = B(I,K) + DTAUX + C(I,K) = C(I,K) + (ENG0-ENG1)/CP/DT + ENDDO + ENDDO + + RETURN + END diff --git a/gsmphys/samfaerosols.f b/gsmphys/samfaerosols.f new file mode 100644 index 00000000..8befb5b1 --- /dev/null +++ b/gsmphys/samfaerosols.f @@ -0,0 +1,803 @@ + subroutine samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, + & xlamde, xlamdd, cnvflg, jmin, kb, kmax, kbcon, ktcon, fscav, + & edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, + & qtr, qaero) + + use machine , only : kind_phys + use physcons, only : g => con_g, qamin + + implicit none + +c -- input arguments + integer, intent(in) :: im, + & ix, km, itc, ntc, ntr + real(kind=kind_phys), intent(in) :: delt, + & xlamde, xlamdd + logical, dimension(im), intent(in) :: cnvflg + integer, dimension(im), intent(in) :: jmin, + & kb, kmax, kbcon, ktcon + real(kind=kind_phys), dimension(im), intent(in) :: edto, + & xlamd, xmb + real(kind=kind_phys), dimension(ntc), intent(in) :: fscav + real(kind=kind_phys), dimension(im,km), intent(in) :: c0t, + & eta, etad, zi, xlamue, xlamud + real(kind=kind_phys), dimension(ix,km), intent(in) :: delp + real(kind=kind_phys), dimension(ix,km,ntr+2), intent(in) :: qtr +c -- output arguments + real(kind=kind_phys), dimension(im,km,ntc), intent(out) :: qaero + +c -- local variables +c -- general variables + integer :: i, indx, it, k, kk, km1, kp1, n + real(kind=kind_phys) :: adw, aup, dtime_max, dv1q, dv2q, dv3q, + & dtovdz, dz, factor, ptem, ptem1, qamax, tem, tem1 + real(kind=kind_phys), dimension(ix,km) :: xmbp +c -- chemical transport variables + real(kind=kind_phys), dimension(im,km,ntc) :: ctro2, ecko2, ecdo2, + & dellae2 +c -- additional variables for tracers for wet deposition, + real(kind=kind_phys), dimension(im,km,ntc) :: chem_c, chem_pw, + & wet_dep +c -- if reevaporation is enabled, uncomment lines below +c real(kind=kind_phys), dimension(im,ntc) :: pwav +c real(kind=kind_phys), dimension(im,km) :: pwdper +c real(kind=kind_phys), dimension(im,km,ntr) :: chem_pwd +c -- additional variables for fct + real(kind=kind_phys), dimension(im,km) :: flx_lo, totlout, clipout + + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: half = 0.5_kind_phys + real(kind=kind_phys), parameter :: quarter = 0.25_kind_phys + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: epsil = 1.e-22_kind_phys ! prevent division by zero + +c -- begin + +c -- check if aerosols are present + if ( ntc <= 0 .or. itc <= 0 .or. ntr <= 0 ) return + if ( ntr < itc + ntc - 3 ) return + +c -- initialize work variables + km1 = km - 1 + + chem_c = zero + chem_pw = zero + ctro2 = zero + dellae2 = zero + ecdo2 = zero + ecko2 = zero + qaero = zero + +c -- set work arrays + + do n = 1, ntc + it = n + itc - 1 + do k = 1, km + do i = 1, im + if (k <= kmax(i)) qaero(i,k,n) = max(qamin, qtr(i,k,it)) + enddo + enddo + enddo + + do k = 1, km + do i = 1, im + xmbp(i,k) = g * xmb(i) / delp(i,k) + enddo + enddo + + do n = 1, ntc +c -- interface level + do k = 1, km1 + kp1 = k + 1 + do i = 1, im + if (kp1 <= kmax(i)) ctro2(i,k,n) = + & half * (qaero(i,k,n) + qaero(i,kp1,n)) + enddo + enddo +c -- top level + do i = 1, im + ctro2(i,kmax(i),n) = qaero(i,kmax(i),n) + enddo + enddo + + do n = 1, ntc + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (k <= kb(i))) + & ecko2(i,k,n) = ctro2(i,k,n) + enddo + enddo + enddo + + do n = 1, ntc + do i = 1, im + if (cnvflg(i)) ecdo2(i,jmin(i),n) = ctro2(i,jmin(i),n) + enddo + enddo + +c do chemical tracers, first need to know how much reevaporates + +c aerosol re-evaporation is set to zero for now +c uncomment and edit the following code to enable re-evaporation +c chem_pwd = zero +c pwdper = zero +c pwav = zero +c do i = 1, im +c do k=1,jmin(i) +c pwdper(i,k)= -edto(i)*pwdo(i,k)/pwavo(i) +c enddo +c enddo +c +c calculate include mixing ratio (ecko2), how much goes into +c rainwater to be rained out (chem_pw), and total scavenged, +c if not reevaporated (pwav) + + do n = 1, ntc + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i)) then + if ((k > kb(i)) .and. (k < ktcon(i))) then + dz = zi(i,k) - zi(i,kk) + tem = half * (xlamue(i,k)+xlamue(i,kk)) * dz + tem1 = quarter * (xlamud(i,k)+xlamud(i,kk)) * dz + factor = one + tem - tem1 + +c if conserved (not scavenging) then + ecko2(i,k,n) = ((one-tem1)*ecko2(i,kk,n) + & + half*tem*(ctro2(i,k,n)+ctro2(i,kk,n)))/factor + +c how much will be scavenged +c +c this choice was used in GF, and is also described in a +c successful implementation into CESM in GRL (Yu et al. 2019), +c it uses dimesnsionless scavenging coefficients (fscav), +c but includes henry coeffs with gas phase chemistry + +c fraction fscav is going into liquid + chem_c(i,k,n)=fscav(n)*ecko2(i,k,n) + +c of that part is going into rain out (chem_pw) + tem=chem_c(i,k,n)/(one+c0t(i,k)*dz) + chem_pw(i,k,n)=c0t(i,k)*dz*tem*eta(i,kk) !etah + ecko2(i,k,n)=tem+ecko2(i,k,n)-chem_c(i,k,n) + +c pwav needed fo reevaporation in downdraft +c if including reevaporation, please uncomment code below +c pwav(i,n)=pwav(i,n)+chem_pw(i,k,n) + endif + endif + enddo + enddo + do k = 1, km1 + do i = 1, im + if (k >= ktcon(i)) ecko2(i,k,n)=ctro2(i,k,n) + enddo + enddo + enddo + +c reevaporation of some, pw and pwd terms needed later for dellae2 + + do n = 1, ntc + do k = km1, 1, -1 + kp1 = k + 1 + do i = 1, im + if (cnvflg(i) .and. (k < jmin(i))) then + dz = zi(i,kp1) - zi(i,k) + if (k >= kbcon(i)) then + tem = xlamde * dz + tem1 = half * xlamdd * dz + else + tem = xlamde * dz + tem1 = half * (xlamd(i)+xlamdd) * dz + endif + factor = one + tem - tem1 + ecdo2(i,k,n) = ((one-tem1)*ecdo2(i,kp1,n) + & +half*tem*(ctro2(i,k,n)+ctro2(i,kp1,n)))/factor +c if including reevaporation, please uncomment code below +c ecdo2(i,k,n)=ecdo2(i,k,n)+pwdper(i,kp1)*pwav(i,n) +c chem_pwd(i,k,n)=max(zero,pwdper(i,kp1)*pwav(i,n)) + endif + enddo + enddo + enddo + + do n = 1, ntc + do i = 1, im + if (cnvflg(i)) then +c subsidence term treated in fct routine + dellae2(i,1,n) = edto(i)*etad(i,1)*ecdo2(i,1,n)*xmbp(i,1) + endif + enddo + enddo + + do n = 1, ntc + do i = 1, im + if (cnvflg(i)) then + k = ktcon(i) + kk = k - 1 +c for the subsidence term already is considered + dellae2(i,k,n) = eta(i,kk) * ecko2(i,kk,n) * xmbp(i,k) + endif + enddo + enddo + +c --- for updraft & downdraft vertical transport +c +c initialize maximum allowed timestep for upstream difference approach +c + dtime_max=delt + do k=2,km1 + kk = k - 1 + do i = 1, im + if (kk < ktcon(i)) dtime_max = min(dtime_max,half*delp(i,kk)) + enddo + enddo + +c now for every chemistry tracer + do n = 1, ntc + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i) .and. (k < ktcon(i))) then + dz = zi(i,k) - zi(i,kk) + aup = one + if (k <= kb(i)) aup = zero + adw = one + if (k > jmin(i)) adw = zero + + dv1q = half * (ecko2(i,k,n) + ecko2(i,kk,n)) + dv2q = half * (ctro2(i,k,n) + ctro2(i,kk,n)) + dv3q = half * (ecdo2(i,k,n) + ecdo2(i,kk,n)) + + tem = half * (xlamue(i,k) + xlamue(i,kk)) + tem1 = half * (xlamud(i,k) + xlamud(i,kk)) + + if (k <= kbcon(i)) then + ptem = xlamde + ptem1 = xlamd(i) + xlamdd + else + ptem = xlamde + ptem1 = xlamdd + endif + dellae2(i,k,n) = dellae2(i,k,n) + +c detrainment from updraft + & ( aup*tem1*eta(i,kk)*dv1q +c entrainement into up and downdraft + & - (aup*tem*eta(i,kk)+adw*edto(i)*ptem*etad(i,k))*dv2q +c detrainment from downdraft + & + (adw*edto(i)*ptem1*etad(i,k)*dv3q) ) * dz * xmbp(i,k) + + wet_dep(i,k,n)=chem_pw(i,k,n)*g/delp(i,k) + +c sinks from where updraft and downdraft start + if (k == jmin(i)+1) then + dellae2(i,k,n) = dellae2(i,k,n) + & -edto(i)*etad(i,kk)*ctro2(i,kk,n)*xmbp(i,k) + endif + if (k == kb(i))then + dellae2(i,k,n) = dellae2(i,k,n) + & -eta(i,k)*ctro2(i,k,n)*xmbp(i,k) + endif + endif + enddo + enddo + + do i = 1, im + if (cnvflg(i)) then + if (kb(i) == 1) then + k=kb(i) + dellae2(i,k,n) = dellae2(i,k,n) + & -eta(i,k)*ctro2(i,k,n)*xmbp(i,k) + endif + endif + enddo + + enddo + +c for every tracer... + + do n = 1, ntc + flx_lo = zero + totlout = zero + clipout = zero +c compute low-order mass flux, upstream + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i) .and. (kk < ktcon(i))) then + tem = zero + if (kk >= kb(i) ) tem = eta(i,kk) + if (kk <= jmin(i)) tem = tem - edto(i)*etad(i,kk) +c low-order flux,upstream + if (tem > zero) then + flx_lo(i,k) = -xmb(i) * tem * qaero(i,k,n) + elseif (tem < zero) then + flx_lo(i,k) = -xmb(i) * tem * qaero(i,kk,n) + endif + endif + enddo + enddo + +c --- make sure low-ord fluxes don't violate positive-definiteness + do k=1,km1 + kp1 = k + 1 + do i=1,im + if (cnvflg(i) .and. (k <= ktcon(i))) then +c time step / grid spacing + dtovdz = g * dtime_max / abs(delp(i,k)) +c total flux out + totlout(i,k)=max(zero,flx_lo(i,kp1))-min(zero,flx_lo(i,k)) + clipout(i,k)=min(one ,qaero(i,k,n)/max(epsil,totlout(i,k)) + & / (1.0001_kind_phys*dtovdz)) + endif + enddo + enddo + +c recompute upstream mass fluxes + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i) .and. (kk < ktcon(i))) then + tem = zero + if (kk >= kb(i) ) tem = eta(i,kk) + if (kk <= jmin(i)) tem = tem - edto(i)*etad(i,kk) + if (tem > zero) then + flx_lo(i,k) = flx_lo(i,k) * clipout(i,k) + elseif (tem < zero) then + flx_lo(i,k) = flx_lo(i,k) * clipout(i,kk) + endif + endif + enddo + enddo + +c --- a positive-definite low-order (diffusive) solution for the subsidnce fluxes + do k=1,km1 + kp1 = k + 1 + do i=1,im + if (cnvflg(i) .and. (k <= ktcon(i))) then + dtovdz = g * dtime_max / abs(delp(i,k)) ! time step /grid spacing + dellae2(i,k,n) = dellae2(i,k,n) + & -(flx_lo(i,kp1)-flx_lo(i,k))*dtovdz/dtime_max + endif + enddo + enddo + + enddo ! ctr + +c convert wet deposition to total mass deposited over dt and dp + + do n = 1, ntc + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (k < ktcon(i))) + & wet_dep(i,k,n) = wet_dep(i,k,n)*xmb(i)*delt*delp(i,k) + enddo + enddo + enddo + +c compute final aerosol concentrations + + do n = 1, ntc + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (k <= min(kmax(i),ktcon(i)))) then + qaero(i,k,n) = qaero(i,k,n) + dellae2(i,k,n) * delt + if (qaero(i,k,n) < zero) then +c add negative mass to wet deposition + wet_dep(i,k,n) = wet_dep(i,k,n)-qaero(i,k,n)*delp(i,k) + qaero(i,k,n) = qamin + endif + endif + enddo + enddo + enddo + + return + end + + + subroutine samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, + & cnvflg, kb, kmax, kbcon, ktcon, fscav, + & xmb, c0t, eta, zi, xlamue, xlamud, delp, + & qtr, qaero) + + use machine , only : kind_phys + use physcons, only : g => con_g, qamin + + implicit none + +c -- input arguments + integer, intent(in) :: im, + & ix, km, itc, ntc, ntr + real(kind=kind_phys), intent(in) :: delt +! & xlamde, xlamdd + logical, dimension(im), intent(in) :: cnvflg +! integer, dimension(im), intent(in) :: jmin, + integer, dimension(im), intent(in) :: + & kb, kmax, kbcon, ktcon + real(kind=kind_phys), dimension(im), intent(in) :: + & xmb, xlamud + real(kind=kind_phys), dimension(ntc), intent(in) :: fscav + real(kind=kind_phys), dimension(im,km), intent(in) :: c0t, + & eta, zi, xlamue !, xlamud + real(kind=kind_phys), dimension(ix,km), intent(in) :: delp + real(kind=kind_phys), dimension(ix,km,ntr+2), intent(in) :: qtr +c -- output arguments + real(kind=kind_phys), dimension(im,km,ntc), intent(out) :: qaero + +c -- local variables +c -- general variables + integer :: i, indx, it, k, kk, km1, kp1, n +! real(kind=kind_phys) :: adw, aup, dtime_max, dv1q, dv2q, dv3q, + real(kind=kind_phys) :: aup, dtime_max, dv1q, dv2q, dv3q, + & dtovdz, dz, factor, ptem, ptem1, qamax, tem, tem1 + real(kind=kind_phys), dimension(ix,km) :: xmbp +c -- chemical transport variables + real(kind=kind_phys), dimension(im,km,ntc) :: ctro2,ecko2,dellae2 +c -- additional variables for tracers for wet deposition, + real(kind=kind_phys), dimension(im,km,ntc) :: chem_c, chem_pw, + & wet_dep +c -- if reevaporation is enabled, uncomment lines below +c real(kind=kind_phys), dimension(im,ntc) :: pwav +c real(kind=kind_phys), dimension(im,km) :: pwdper +c real(kind=kind_phys), dimension(im,km,ntr) :: chem_pwd +c -- additional variables for fct + real(kind=kind_phys), dimension(im,km) :: flx_lo, totlout, clipout + + real(kind=kind_phys), parameter :: one = 1.0_kind_phys + real(kind=kind_phys), parameter :: half = 0.5_kind_phys + real(kind=kind_phys), parameter :: quarter = 0.25_kind_phys + real(kind=kind_phys), parameter :: zero = 0.0_kind_phys + real(kind=kind_phys), parameter :: epsil = 1.e-22_kind_phys ! prevent division by zero + real(kind=kind_phys), parameter :: escav = 0.8_kind_phys ! wet scavenging efficiency + +c -- begin + +c -- check if aerosols are present + if ( ntc <= 0 .or. itc <= 0 .or. ntr <= 0 ) return + if ( ntr < itc + ntc - 3 ) return + +c -- initialize work variables + km1 = km - 1 + + chem_c = zero + chem_pw = zero + ctro2 = zero + dellae2 = zero + !ecdo2 = zero + ecko2 = zero + qaero = zero + +c -- set work arrays + + do n = 1, ntc + it = n + itc - 1 + do k = 1, km + do i = 1, im + if (k <= kmax(i)) qaero(i,k,n) = max(qamin, qtr(i,k,it)) + enddo + enddo + enddo + + do k = 1, km + do i = 1, im + xmbp(i,k) = g * xmb(i) / delp(i,k) + enddo + enddo + + do n = 1, ntc +c -- interface level + do k = 1, km1 + kp1 = k + 1 + do i = 1, im + if (kp1 <= kmax(i)) ctro2(i,k,n) = + & half * (qaero(i,k,n) + qaero(i,kp1,n)) + enddo + enddo +c -- top level + do i = 1, im + ctro2(i,kmax(i),n) = qaero(i,kmax(i),n) + enddo + enddo + + do n = 1, ntc + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (k <= kb(i))) + & ecko2(i,k,n) = ctro2(i,k,n) + enddo + enddo + enddo + + !do n = 1, ntc + ! do i = 1, im + ! if (cnvflg(i)) ecdo2(i,jmin(i),n) = ctro2(i,jmin(i),n) + ! enddo + !enddo + +c do chemical tracers, first need to know how much reevaporates + +c aerosol re-evaporation is set to zero for now +c uncomment and edit the following code to enable re-evaporation +c chem_pwd = zero +c pwdper = zero +c pwav = zero +c do i = 1, im +c do k=1,jmin(i) +c pwdper(i,k)= -edto(i)*pwdo(i,k)/pwavo(i) +c enddo +c enddo +c +c calculate include mixing ratio (ecko2), how much goes into +c rainwater to be rained out (chem_pw), and total scavenged, +c if not reevaporated (pwav) + + do n = 1, ntc + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i)) then + if ((k > kb(i)) .and. (k < ktcon(i))) then + dz = zi(i,k) - zi(i,kk) + tem = half * (xlamue(i,k)+xlamue(i,kk)) * dz +! tem1 = quarter * (xlamud(i,k)+xlamud(i,kk)) * dz + tem1 = quarter * (xlamud(i )+xlamud(i )) * dz + factor = one + tem - tem1 + +c if conserved (not scavenging) then + ecko2(i,k,n) = ((one-tem1)*ecko2(i,kk,n) + & + half*tem*(ctro2(i,k,n)+ctro2(i,kk,n)))/factor + +c how much will be scavenged +c +c this choice was used in GF, and is also described in a +c successful implementation into CESM in GRL (Yu et al. 2019), +c it uses dimesnsionless scavenging coefficients (fscav), +c but includes henry coeffs with gas phase chemistry + +c fraction fscav is going into liquid + chem_c(i,k,n)=escav*fscav(n)*ecko2(i,k,n) + +c of that part is going into rain out (chem_pw) + tem=chem_c(i,k,n)/(one+c0t(i,k)*dz) + chem_pw(i,k,n)=c0t(i,k)*dz*tem*eta(i,kk) !etah + ecko2(i,k,n)=tem+ecko2(i,k,n)-chem_c(i,k,n) + +c pwav needed fo reevaporation in downdraft +c if including reevaporation, please uncomment code below +c pwav(i,n)=pwav(i,n)+chem_pw(i,k,n) + endif + endif + enddo + enddo + do k = 1, km1 + do i = 1, im + if (k >= ktcon(i)) ecko2(i,k,n)=ctro2(i,k,n) + enddo + enddo + enddo + +c reevaporation of some, pw and pwd terms needed later for dellae2 + +! do n = 1, ntc +! do k = km1, 1, -1 +! kp1 = k + 1 +! do i = 1, im +! if (cnvflg(i) .and. (k < jmin(i))) then +! dz = zi(i,kp1) - zi(i,k) +! if (k >= kbcon(i)) then +! tem = xlamde * dz +! tem1 = half * xlamdd * dz +! else +! tem = xlamde * dz +! tem1 = half * (xlamd(i)+xlamdd) * dz +! endif +! factor = one + tem - tem1 +! ecdo2(i,k,n) = ((one-tem1)*ecdo2(i,kp1,n) +! & +half*tem*(ctro2(i,k,n)+ctro2(i,kp1,n)))/factor +c if including reevaporation, please uncomment code below +c ecdo2(i,k,n)=ecdo2(i,k,n)+pwdper(i,kp1)*pwav(i,n) +c chem_pwd(i,k,n)=max(zero,pwdper(i,kp1)*pwav(i,n)) +! endif +! enddo +! enddo +! enddo + +! do n = 1, ntc +! do i = 1, im +! if (cnvflg(i)) then +c subsidence term treated in fct routine +! dellae2(i,1,n) = edto(i)*etad(i,1)*ecdo2(i,1,n)*xmbp(i,1) +! endif +! enddo +! enddo + + do n = 1, ntc + do i = 1, im + if (cnvflg(i)) then + k = ktcon(i) + kk = k - 1 +c for the subsidence term already is considered + dellae2(i,k,n) = eta(i,kk) * ecko2(i,kk,n) * xmbp(i,k) + endif + enddo + enddo + +c --- for updraft & downdraft vertical transport +c +c initialize maximum allowed timestep for upstream difference approach +c + dtime_max=delt + do k=2,km1 + kk = k - 1 + do i = 1, im + if (kk < ktcon(i)) dtime_max = min(dtime_max,half*delp(i,kk)) + enddo + enddo + +c now for every chemistry tracer + do n = 1, ntc + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i) .and. (k < ktcon(i))) then + dz = zi(i,k) - zi(i,kk) + aup = one + if (k <= kb(i)) aup = zero +! adw = one +! if (k > jmin(i)) adw = zero + + dv1q = half * (ecko2(i,k,n) + ecko2(i,kk,n)) + dv2q = half * (ctro2(i,k,n) + ctro2(i,kk,n)) +c dv3q = half * (ecdo2(i,k,n) + ecdo2(i,kk,n)) + + tem = half * (xlamue(i,k) + xlamue(i,kk)) + !tem1 = half * (xlamud(i,k) + xlamud(i,kk)) + tem1 = half * (xlamud(i ) + xlamud(i )) + +! if (k <= kbcon(i)) then +! ptem = xlamde +! ptem1 = xlamd(i) + xlamdd +! else +! ptem = xlamde +! ptem1 = xlamdd +! endif + dellae2(i,k,n) = dellae2(i,k,n) + +c detrainment from updraft + & ( aup*tem1*eta(i,kk)*dv1q +c entrainement into up and downdraft +! & - (aup*tem*eta(i,kk)+adw*edto(i)*ptem*etad(i,k))*dv2q + & - (aup*tem*eta(i,kk))*dv2q +c detrainment from downdraft +! & + (adw*edto(i)*ptem1*etad(i,k)*dv3q) + & ) * dz * xmbp(i,k) + + wet_dep(i,k,n)=chem_pw(i,k,n)*g/delp(i,k) + +c sinks from where updraft and downdraft start +! if (k == jmin(i)+1) then +! dellae2(i,k,n) = dellae2(i,k,n) +! & -edto(i)*etad(i,kk)*ctro2(i,kk,n)*xmbp(i,k) +! endif + if (k == kb(i))then + dellae2(i,k,n) = dellae2(i,k,n) + & -eta(i,k)*ctro2(i,k,n)*xmbp(i,k) + endif + endif + enddo + enddo + + do i = 1, im + if (cnvflg(i)) then + if (kb(i) == 1) then + k=kb(i) + dellae2(i,k,n) = dellae2(i,k,n) + & -eta(i,k)*ctro2(i,k,n)*xmbp(i,k) + endif + endif + enddo + + enddo + +c for every tracer... + + do n = 1, ntc + flx_lo = zero + totlout = zero + clipout = zero +c compute low-order mass flux, upstream + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i) .and. (kk < ktcon(i))) then + tem = zero + if (kk >= kb(i) ) tem = eta(i,kk) +! if (kk <= jmin(i)) tem = tem - edto(i)*etad(i,kk) +c low-order flux,upstream + if (tem > zero) then + flx_lo(i,k) = -xmb(i) * tem * qaero(i,k,n) + elseif (tem < zero) then + flx_lo(i,k) = -xmb(i) * tem * qaero(i,kk,n) + endif + endif + enddo + enddo + +c --- make sure low-ord fluxes don't violate positive-definiteness + do k=1,km1 + kp1 = k + 1 + do i=1,im + if (cnvflg(i) .and. (k <= ktcon(i))) then +c time step / grid spacing + dtovdz = g * dtime_max / abs(delp(i,k)) +c total flux out + totlout(i,k)=max(zero,flx_lo(i,kp1))-min(zero,flx_lo(i,k)) + clipout(i,k)=min(one ,qaero(i,k,n)/max(epsil,totlout(i,k)) + & / (1.0001_kind_phys*dtovdz)) + endif + enddo + enddo + +c recompute upstream mass fluxes + do k = 2, km1 + kk = k - 1 + do i = 1, im + if (cnvflg(i) .and. (kk < ktcon(i))) then + tem = zero + if (kk >= kb(i) ) tem = eta(i,kk) +! if (kk <= jmin(i)) tem = tem - edto(i)*etad(i,kk) + if (tem > zero) then + flx_lo(i,k) = flx_lo(i,k) * clipout(i,k) + elseif (tem < zero) then + flx_lo(i,k) = flx_lo(i,k) * clipout(i,kk) + endif + endif + enddo + enddo + +c --- a positive-definite low-order (diffusive) solution for the subsidnce fluxes + do k=1,km1 + kp1 = k + 1 + do i=1,im + if (cnvflg(i) .and. (k <= ktcon(i))) then + dtovdz = g * dtime_max / abs(delp(i,k)) ! time step /grid spacing + dellae2(i,k,n) = dellae2(i,k,n) + & -(flx_lo(i,kp1)-flx_lo(i,k))*dtovdz/dtime_max + endif + enddo + enddo + + enddo ! ctr + +c convert wet deposition to total mass deposited over dt and dp + + do n = 1, ntc + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (k < ktcon(i))) + & wet_dep(i,k,n) = wet_dep(i,k,n)*xmb(i)*delt*delp(i,k) + enddo + enddo + enddo + +c compute final aerosol concentrations + + do n = 1, ntc + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. (k <= min(kmax(i),ktcon(i)))) then + qaero(i,k,n) = qaero(i,k,n) + dellae2(i,k,n) * delt + if (qaero(i,k,n) < zero) then +c add negative mass to wet deposition + wet_dep(i,k,n) = wet_dep(i,k,n)-qaero(i,k,n)*delp(i,k) + qaero(i,k,n) = qamin + endif + endif + enddo + enddo + enddo + + return + end + diff --git a/gsmphys/samfdeepcnv.f b/gsmphys/samfdeepcnv.f new file mode 100644 index 00000000..fd38fac9 --- /dev/null +++ b/gsmphys/samfdeepcnv.f @@ -0,0 +1,2797 @@ +!> \defgroup SAMF Scale-Aware Mass-Flux Deep Convection +!! @{ +!! \brief The scale-aware mass-flux (SAMF) deep convection scheme is an updated version of the previous Simplified Arakawa-Schubert (SAS) scheme with scale and aerosol awareness and parameterizes the effect of deep convection on the environment (represented by the model state variables) in the following way. First, a simple cloud model is used to determine the change in model state variables due to one entraining/detraining cloud type, per unit cloud-base mass flux. Next, the total change in state variables is retrieved by determining the actual cloud base mass flux using the quasi-equilibrium assumption (for grid sizes larger than a threshold value [currently set to 8 km]) or a mean updraft velocity (for grid sizes smaller than the threshold value). With a scale-aware parameterization, the cloud mass flux decreases with increasing grid resolution. A simple aerosol-aware parameterization is employed, where rain conversion in the convective updraft is modified by aerosol number concentration. The name SAS is replaced with SAMF as for the smaller grid sizes, the parameterization does not use Arakawa-Schubert's quasi-equilibrium assumption any longer where the cloud work function (interpreted as entrainment-moderated convective available potential energy [CAPE]) by the large scale dynamics is in balance with the consumption of the cloud work function by the convection. +!! +!! The SAS scheme uses the working concepts put forth in Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 but includes modifications and simplifications from Grell (1993) \cite grell_1993 such as saturated downdrafts and only one cloud type (the deepest possible), rather than a spectrum based on cloud top heights or assumed entrainment rates. The scheme was implemented for the GFS in 1995 by Pan and Wu \cite pan_and_wu_1995, with further modifications discussed in Han and Pan (2011) \cite han_and_pan_2011 , including the calculation of cloud top, a greater CFL-criterion-based maximum cloud base mass flux, updated cloud model entrainment and detrainment, improved convective transport of horizontal momentum, a more general triggering function, and the inclusion of convective overshooting. +!! +!! The SAMF scheme updates the SAS scheme with scale- and aerosol-aware parameterizations from Han et al. (2017) \cite han_et_al_2017 based on the studies by Arakawa and Wu (2013) \cite arakawa_and_wu_2013 and Grell and Freitas (2014) \cite grell_and_freitus_2014 for scale awareness and by Lim (2011) \cite lim_2011 for aerosol awareness. The ratio of advective time to convective turnover time is also taken into account for the scale-aware parameterization. Along with the scale- and aerosol-aware parameterizations, more changes are made to the SAMF scheme. The cloud base mass-flux computation is modified to use convective turnover time as the convective adjustment time scale. The rain conversion rate is modified to decrease with decreasing air temperature above the freezing level. Convective inhibition in the sub-cloud layer is used as an additional trigger condition. Convective cloudiness is enhanced by considering suspended cloud condensate in the updraft. The lateral entrainment is also enhanced to more strongly suppress convection in a drier environment. +!! +!! In further update for FY19 GFS implementation, interaction with turbulent kinetic energy (TKE), which is a prognostic variable used in a scale-aware TKE-based moist EDMF vertical turbulent mixing scheme, is included. Entrainment rates in updrafts and downdrafts are proportional to sub-cloud mean TKE. TKE is transported by cumulus convection. TKE contribution from cumulus convection is deduced from cumulus mass flux. On the other hand, tracers such as ozone and aerosol are also transported by cumulus convection. +!! +!! Occasional model crashes have been occurred when stochastic physics is on, due to too much convective cooling and heating tendencies near the cumulus top which are amplified by stochastic physics. To reduce too much convective cooling at the cloud top, the convection schemes have been modified for the rain conversion rate, entrainment and detrainment rates, overshooting layers, and maximum allowable cloudbase mass flux (as of June 2018). +!! +!! \section diagram Calling Hierarchy Diagram +!! \image html SAMF_Flowchart.png "Diagram depicting how the SAMF deep convection scheme is called from the FV3GFS physics time loop" height=2cm +!! \section intraphysics Intraphysics Communication +!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. + +!> \file samfdeepcnv.f +!! Contains the entire SAMF deep convection scheme. + +!> \brief This subroutine contains the entirety of the SAMF deep convection scheme. +!! +!! For grid sizes larger than threshold value, as in Grell (1993) \cite grell_1993 , the SAMF deep convection scheme can be described in terms of three types of "controls": static, dynamic, and feedback. The static control component consists of the simple entraining/detraining updraft/downdraft cloud model and is used to determine the cloud properties, convective precipitation, as well as the convective cloud top height. The dynamic control is the determination of the potential energy available for convection to "consume", or how primed the large-scale environment is for convection to occur due to changes by the dyanmics of the host model. The feedback control is the determination of how the parameterized convection changes the large-scale environment (the host model state variables) given the changes to the state variables per unit cloud base mass flux calculated in the static control portion and the deduced cloud base mass flux determined from the dynamic control. +!! +!! For grid sizes smaller than threshold value, the cloud base mass flux in the SAMF scheme is determined by the cumulus updraft velocity averaged ove the whole cloud depth (Han et al., 2017 \cite han_et_al_2017 ), which in turn, determines changes of the large-scale environment due to the cumulus convection. +!! +!! \param[in] im number of used points +!! \param[in] ix horizontal dimension +!! \param[in] km vertical layer dimension +!! \param[in] delt physics time step in seconds +!! \param[in] ntk index for TKE +!! \param[in] ntr total number of tracers including TKE +!! \param[in] delp pressure difference between level k and k+1 (Pa) +!! \param[in] prslp mean layer presure (Pa) +!! \param[in] psp surface pressure (Pa) +!! \param[in] phil layer geopotential (\f$m^2/s^2\f$) +!! \param[in] qtr tracer array including cloud condensate (\f$kg/kg\f$) +!! \param[inout] ql cloud water or ice (kg/kg) +!! \param[inout] q1 updated tracers (kg/kg) +!! \param[inout] t1 updated temperature (K) +!! \param[inout] u1 updated zonal wind (\f$m s^{-1}\f$) +!! \param[inout] v1 updated meridional wind (\f$m s^{-1}\f$) +!! \param[out] cldwrk cloud workfunction (\f$m^2/s^2\f$) +!! \param[out] rn convective rain (m) +!! \param[out] kbot index for cloud base +!! \param[out] ktop index for cloud top +!! \param[out] kcnv flag to denote deep convection (0=no, 1=yes) +!! \param[in] islimsk sea/land/ice mask (=0/1/2) +!! \param[in] garea area of grid box (\f$m^2\f$) +!! \param[in] dot layer mean vertical velocity (Pa/s) +!! \param[in] ncloud number of cloud species +!! \param[out] ud_mf updraft mass flux multiplied by time step (\f$kg/m^2\f$) +!! \param[out] dd_mf downdraft mass flux multiplied by time step (\f$kg/m^2\f$) +!! \param[out] dt_mf ud_mf at cloud top (\f$kg/m^2\f$) +!! \param[out] cnvw convective cloud water (kg/kg) +!! \param[out] cnvc convective cloud cover (unitless) +!! \param[in] clam coefficient for entrainment rate +!! \param[in] c0s convective rain conversion parameter (1/m) +!! \param[in] c1 conversion parameter of detrainment from liquid water into grid-scale cloud water (1/m) +!! \param[in] betal fraction factor of downdraft air mass reaching ground surface over land +!! \param[in] betas fraction factor of downdraft air mass reaching ground surface over sea +!! \param[in] evfact evaporation factor from convective rain +!! \param[in] evfactl evaporation factor from convective rain over land +!! \param[in] pgcon reduction factor in momentum transport due to convection induced pressure gradient force +!! \param[in] asolfac aerosol-aware parameter inversely proportional to CCN number concentraion +!! +!! \section general General Algorithm +!! -# Compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm. +!! -# Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!! -# Perform calculations related to the downdraft of the entraining/detraining cloud model ("static control"). +!! +!! -# For grid sizes larger than the threshold value (currently 8 km): +!! + 1) Using the updated temperature and moisture profiles that were modified by the convection on a short time-scale, recalculate the total cloud work function to determine the change in the cloud work function due to convection, or the stabilizing effect of the cumulus. +!! + 2) For the "dynamic control", using a reference cloud work function, estimate the change in cloud work function due to the large-scale dynamics. Following the quasi-equilibrium assumption, calculate the cloud base mass flux required to keep the large-scale convective destabilization in balance with the stabilization effect of the convection. +!! -# For grid sizes smaller than the threshold value (currently 8 km): +!! + 1) compute the cloud base mass flux using the cumulus updraft velocity averaged ove the whole cloud depth. +!! -# For scale awareness, the updraft fraction (sigma) is obtained as a function of cloud base entrainment. Then, the final cloud base mass flux is obtained by the original mass flux multiplied by the (1sigma) 2 . +!! -# For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!! +!! \section detailed Detailed Algorithm +!! @{ + subroutine samfdeepcnv(im,ix,km,delt,itc,ntc,ntk,ntr,delp, + & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav, + & do_ca,ca_deep,cldwrk,rn,kbot,ktop,kcnv,islimsk,garea, + & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, + & QLCN, QICN, w_upi, cf_upi, CNV_MFD, +! & QLCN, QICN, w_upi, cf_upi, CNV_MFD, CNV_PRC3, + & CNV_DQLDT,CLCN,CNV_FICE,CNV_NDROP,CNV_NICE,mp_phys, + & clam,c0s,c1,betal,betas,evfact,evfactl,pgcon,asolfac) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps,epsm1 => con_epsm1 + implicit none +! + integer, intent(in) :: im, ix, km, itc, ntc, ntk, ntr, ncloud + integer, intent(in) :: islimsk(im) + real(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), intent(in) :: psp(im), delp(ix,km), + & prslp(ix,km), garea(im), dot(ix,km), phil(ix,km) + real(kind=kind_phys), intent(in) :: fscav(ntc) + real(kind=kind_phys), intent(in) :: ca_deep(ix) + logical, intent(in) :: do_ca + integer, intent(inout) :: kcnv(im) + real(kind=kind_phys), intent(inout) :: qtr(ix,km,ntr+2), + & q1(ix,km), t1(ix,km), u1(ix,km), v1(ix,km) + + integer, intent(out) :: kbot(im), ktop(im) + real(kind=kind_phys), intent(out) :: cldwrk(im), + & rn(im), cnvw(ix,km), cnvc(ix,km), + & ud_mf(im,km),dd_mf(im,km), dt_mf(im,km) + + real(kind=kind_phys) clam, c0s, c1, + & betal, betas, asolfac, + & evfact, evfactl, pgcon +! +!------local variables + integer i, indx, jmn, k, kk, km1, n +! integer latd,lond +! + real(kind=kind_phys) clamd, tkemx, tkemn, dtke, + & beta, dbeta, betamx, betamn, + & cxlame, cxlamd, + & xlamde, xlamdd, + & crtlame, crtlamd +! +! real(kind=kind_phys) detad + real(kind=kind_phys) adw, aup, aafac, d0, + & dellat, delta, desdt, dg, + & dh, dhh, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, + & dxcrtas, dxcrtuf, + & dv1h, dv2h, dv3h, + & dv1q, dv2q, dv3q, + & dz, dz1, e1, edtmax, + & edtmaxl, edtmaxs, el2orc, elocp, + & es, etah, + & cthk, dthk, + & evef, fact1, fact2, factor, + & g, gamma, pprime, cm, + & qlk, qrch, qs, + & rain, rfact, shear, tfac, + & val, val1, val2, + & w1, w1l, w1s, w2, + & w2l, w2s, w3, w3l, + & w3s, w4, w4l, w4s, + & rho, betaw, + & xdby, xpw, xpwd, +! & xqrch, mbdt, tem, + & xqrch, tem, tem1, tem2, + & ptem, ptem1, ptem2 +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), ktconn(im), + & jmin(im), lmin(im), kbmax(im), + & kbm(im), kmax(im) +! +! real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), + real(kind=kind_phys) aa1(im), tkemean(im),clamt(im), + & ps(im), del(ix,km), prsl(ix,km), + & umean(im), tauadv(im), gdx(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & edto(im), edtx(im), fld(im), + & hcdo(im,km), hmax(im), hmin(im), + & ucdo(im,km), vcdo(im,km),aa2(im), + & ecdo(im,km,ntr), + & pdot(im), po(im,km), + & pwavo(im), pwevo(im), mbdt(im), + & qcdo(im,km), qcond(im), qevap(im), + & rntot(im), vshear(im), xaa0(im), + & xlamd(im), xk(im), cina(im), + & xmb(im), xmbmax(im), xpwav(im), +! & xpwev(im), xlamx(im), delebar(im,ntr), + & xpwev(im), delebar(im,ntr), + & delubar(im), delvbar(im) +! + real(kind=kind_phys) c0(im) +cj + real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, + & cinacr, cinacrmx, cinacrmn +cj +! +! parameters for updraft velocity calculation + real(kind=kind_phys) bet1, cd1, f1, gam1, + & bb1, bb2 +! & bb1, bb2, wucb +! +c physical parameters +! parameter(g=grav,asolfac=0.958) + parameter(g=grav) + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) +! parameter(c0s=.002,c1=.002,d0=.01) +! parameter(d0=.01) + parameter(d0=.001) +! parameter(c0l=c0s*asolfac) +! +! asolfac: aerosol-aware parameter based on Lim (2011) +! asolfac= cx / c0s(=.002) +! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) +! Nccn: CCN number concentration in cm^(-3) +! Until a realistic Nccn is provided, Nccns are assumed +! as Nccn=100 for sea and Nccn=1000 for land +! + parameter(cm=1.0,delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(clamd=0.03,tkemx=0.65,tkemn=0.05) + parameter(dtke=tkemx-tkemn) + parameter(dbeta=0.1) + parameter(cthk=200.,dthk=25.) + parameter(cinpcrmx=180.,cinpcrmn=120.) +! parameter(cinacrmx=-120.,cinacrmn=-120.) + parameter(cinacrmx=-120.,cinacrmn=-80.) + parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) + parameter(betaw=.03,dxcrtas=8.e3,dxcrtuf=15.e3) +! +! local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km), + & ctr(im,km,ntr), ctro(im,km,ntr) +! for aerosol transport + real(kind=kind_phys) qaero(im,km,ntc) +! for updraft velocity calculation + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) + real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) +! +c cloud water +! real(kind=kind_phys) tvo(im,km) + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + & dbyo(im,km), zo(im,km), + & xlamue(im,km), xlamud(im,km), + & fent1(im,km), fent2(im,km), frh(im,km), + & heo(im,km), heso(im,km), + & qrcd(im,km), dellah(im,km), dellaq(im,km), + & dellae(im,km,ntr), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & ecko(im,km,ntr), + & eta(im,km), etad(im,km), zi(im,km), + & qrcko(im,km), qrcdo(im,km), + & pwo(im,km), pwdo(im,km), c0t(im,km), + & tx1(im), sumx(im), cnvwt(im,km) +! &, rhbar(im) +! + real(kind=kind_phys), dimension(im,km) :: qlcn, qicn, w_upi + &, cnv_mfd +! &, cnv_mfd, cnv_prc3 + &, cnv_dqldt, clcn + &, cnv_fice, cnv_ndrop + &, cnv_nice, cf_upi + integer mp_phys + logical do_aerosols, totflg, cnvflg(im), asqecflg(im), flg(im) +! +! asqecflg: flag for the quasi-equilibrium assumption of Arakawa-Schubert +! +! real(kind=kind_phys) pcrit(15), acritt(15), acrit(15) +!! save pcrit, acritt +! data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., +! & 350.,300.,250.,200.,150./ +! data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, +! & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ +c gdas derived acrit +c data acritt/.203,.515,.521,.566,.625,.665,.659,.688, +c & .743,.813,.886,.947,1.138,1.377,1.896/ + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +!> ## Determine whether to perform aerosol transport + do_aerosols = (itc > 0) .and. (ntc > 0) .and. (ntr > 0) + if (do_aerosols) do_aerosols = (ntr >= itc + ntc - 3) +! +c----------------------------------------------------------------------- +!> ## Compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm. +!> - Convert input pressure terms to centibar units. +!************************************************************************ +! convert input Pa terms to Cb terms -- Moorthi + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! +! + km1 = km - 1 +!> - Initialize column-integrated and other single-value-per-column variable arrays. +c +c initialize arrays +c + do i=1,im + cnvflg(i) = .true. + rn(i)=0. + mbdt(i)=10. + kbot(i)=km+1 + ktop(i)=0 + kbcon(i)=km + ktcon(i)=1 + ktconn(i)=1 + dtconv(i) = 3600. + cldwrk(i) = 0. + pdot(i) = 0. + lmin(i) = 1 + jmin(i) = 1 + qlko_ktcon(i) = 0. + edt(i) = 0. + edto(i) = 0. + edtx(i) = 0. +! acrt(i) = 0. +! acrtfct(i) = 1. + aa1(i) = 0. + aa2(i) = 0. + xaa0(i) = 0. + cina(i) = 0. + pwavo(i)= 0. + pwevo(i)= 0. + xpwav(i)= 0. + xpwev(i)= 0. + vshear(i) = 0. + gdx(i) = sqrt(garea(i)) + enddo +! +!> - determine aerosol-aware rain conversion parameter over land + do i=1,im + if(islimsk(i) == 1) then + c0(i) = c0s*asolfac + else + c0(i) = c0s + endif + enddo +!> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. + do k = 1, km + do i = 1, im + if(t1(i,k) > 273.16) then + c0t(i,k) = c0(i) + else + tem = d0 * (t1(i,k) - 273.16) + tem1 = exp(tem) + c0t(i,k) = c0(i) * tem1 + endif + enddo + enddo +!> - Initialize convective cloud water and cloud cover to zero. + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +! hchuang code change +!> - Initialize updraft and downdraft mass fluxes to zero. + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dd_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo + if(mp_phys == 10) then + do k = 1, km + do i = 1, im + QLCN(i,k) = qtr(i,k,2) + QICN(i,k) = qtr(i,k,1) + w_upi(i,k) = 0.0 + cf_upi(i,k) = 0.0 + CNV_MFD(i,k) = 0.0 + + CNV_DQLDT(i,k) = 0.0 + CLCN(i,k) = 0.0 + CNV_FICE(i,k) = 0.0 + CNV_NDROP(i,k) = 0.0 + CNV_NICE(i,k) = 0.0 + enddo + enddo + endif +c +! do k = 1, 15 +! acrit(k) = acritt(k) * (975. - pcrit(k)) +! enddo +! + dt2 = delt +! val = 1200. + val = 600. + dtmin = max(dt2, val ) +! val = 5400. + val = 10800. + dtmax = max(dt2, val ) +! model tunable parameters are all here + edtmaxl = .3 + edtmaxs = .3 +! clam = .1 +! aafac = .1 + aafac = .05 +! betal = .15 +! betas = .15 +! betal = .05 +! betas = .05 +! evef = 0.07 +! evfact = 0.3 +! evfactl = 0.3 +! + crtlame = 1.0e-4 + crtlamd = 1.0e-4 +! +! cxlame = 1.0e-3 + cxlame = 1.0e-4 + cxlamd = 1.0e-4 + xlamde = 1.0e-4 + xlamdd = 1.0e-4 +! +! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) +! pgcon = 0.55 ! Zhang & Wu (2003,JAS) +! + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c +!> - Determine maximum indices for the parcel starting point (kbm), LFC (kbmax), and cloud top (kmax). + do i=1,im + kbmax(i) = km + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) > 0.04) kmax(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.45) kbmax(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + enddo + enddo + do i=1,im + kmax(i) = min(km,kmax(i)) + kbmax(i) = min(kbmax(i),kmax(i)) + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and initially assume +c updraft entrainment rate as an inverse function of height +c +!> - Calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential. + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo +!> - Calculate interface height + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + enddo + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c +!> - Convert prsl from centibar to millibar, set normalized mass fluxes to 1, cloud properties to 0, and save model state variables (after advection/turbulence). + do k = 1, km + do i = 1, im + if (k <= kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + eta(i,k) = 1. + fent1(i,k)= 1. + fent2(i,k)= 1. + frh(i,k) = 0. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + etad(i,k) = 1. + hcdo(i,k) = 0. + qcdo(i,k) = 0. + ucdo(i,k) = 0. + vcdo(i,k) = 0. + qrcd(i,k) = 0. + qrcdo(i,k)= 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + pwdo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) + wu2(i,k) = 0. + buo(i,k) = 0. + drag(i,k) = 0. + cnvwt(i,k)= 0. + endif + enddo + enddo +! +! initialize tracer variables +! + do n = 3, ntr+2 + kk = n-2 + do k = 1, km + do i = 1, im + if (k <= kmax(i)) then + ctr(i,k,kk) = qtr(i,k,n) + ctro(i,k,kk) = qtr(i,k,n) + ecko(i,k,kk) = 0. + ecdo(i,k,kk) = 0. + endif + enddo + enddo + enddo +! +!> - Calculate saturation specific humidity and enforce minimum moisture values. + do k = 1, km + do i=1,im + if (k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c +!> - Calculate moist static energy (heo) and saturation moist static energy (heso). + do k = 1, km + do i=1,im + if (k <= kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy +c this is the level where updraft starts +c +!> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!> - Search below index "kbm" for the level of maximum moist static energy. + do i=1,im + hmax(i) = heo(i,1) + kb(i) = 1 + enddo + do k = 2, km + do i=1,im + if (k <= kbm(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c +!> - Calculate the temperature, specific humidity, and pressure at interface levels. + do k = 1, km1 + do i=1,im + if (k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! +!> - Recalculate saturation specific humidity, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. Enforce minimum specific humidity and calculate \f$(1 - RH)\f$. + do k = 1, km1 + do i=1,im + if (k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + tem = min(qo(i,k)/qeso(i,k), 1.) + frh(i,k) = 1. - tem + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo + do n = 1, ntr + do k = 1, km1 + do i=1,im + if (k <= kmax(i)-1) then + ctro(i,k,n) = .5 * (ctro(i,k,n) + ctro(i,k+1,n)) + endif + enddo + enddo + enddo +c +c look for the level of free convection as cloud base +c +!> - Search below the index "kbmax" for the level of free convection (LFC) where the condition \f$h_b > h^*\f$ is first met, where \f$h_b, h^*\f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. Set "kbcon" to the index of the LFC. + do i=1,im + flg(i) = .true. + kbcon(i) = kmax(i) + enddo + do k = 1, km1 + do i=1,im + if (flg(i) .and. k <= kbmax(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c +!> - If no LFC, return to the calling routine without modifying state variables. + do i=1,im + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +!> - Determine the vertical pressure velocity at the LFC. After Han and Pan (2011) \cite han_and_pan_2011 , determine the maximum pressure thickness between a parcel's starting level and the LFC. If a parcel doesn't reach the LFC within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables. + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +c +c turn off convection if pressure depth between parcel source level +c and cloud base is larger than a critical value, cinpcr +c + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + ptem = 1. - tem + ptem1= .5*(cinpcrmx-cinpcrmn) + cinpcr = cinpcrmx - ptem * ptem1 + tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(tem1 > cinpcr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +! turbulent entrainment rate assumed to be proportional +! to subcloud mean TKE +! + if(ntk > 0) then +! + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + tkemean(i) = 0. + endif + enddo + do k = 1, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kb(i) .and. k < kbcon(i)) then + dz = zo(i,k+1) - zo(i,k) + tem = 0.5 * (qtr(i,k,ntk)+qtr(i,k+1,ntk)) + tkemean(i) = tkemean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo +! + do i= 1, im + if(cnvflg(i)) then + tkemean(i) = tkemean(i) / sumx(i) + if(tkemean(i) > tkemx) then + clamt(i) = clam + clamd + else if(tkemean(i) < tkemn) then + clamt(i) = clam - clamd + else + tem = tkemx - tkemean(i) + tem1 = 1. - 2. * tem / dtke + clamt(i) = clam + clamd * tem1 + endif + endif + enddo +! + else +! + do i= 1, im + if(cnvflg(i)) then + clamt(i) = clam + endif + enddo +! + endif +! +! also initially assume updraft entrainment rate +! is an inverse function of height +! + do k = 1, km1 + do i=1,im + if(cnvflg(i)) then + xlamue(i,k) = clamt(i) / zi(i,k) + xlamue(i,k) = max(xlamue(i,k), crtlame) + endif + enddo + enddo +c +c assume that updraft entrainment rate above cloud base is +c same as that at cloud base +c +!> - Calculate the entrainment rate according to Han and Pan (2011) \cite han_and_pan_2011 , equation 8, after Bechtold et al. (2008) \cite bechtold_et_al_2008, equation 2 given by: +!! \f[ +!! \epsilon = \epsilon_0F_0 + d_1\left(1-RH\right)F_1 +!! \f] +!! where \f$\epsilon_0\f$ is the cloud base entrainment rate, \f$d_1\f$ is a tunable constant, and \f$F_0=\left(\frac{q_s}{q_{s,b}}\right)^2\f$ and \f$F_1=\left(\frac{q_s}{q_{s,b}}\right)^3\f$ where \f$q_s\f$ and \f$q_{s,b}\f$ are the saturation specific humidities at a given level and cloud base, respectively. The detrainment rate in the cloud is assumed to be equal to the entrainment rate at cloud base. +! do i=1,im +! if(cnvflg(i)) then +! xlamx(i) = xlamue(i,kbcon(i)) +! endif +! enddo +! do k = 2, km1 +! do i=1,im +! if(cnvflg(i).and. +! & (k > kbcon(i) .and. k < kmax(i))) then +! xlamue(i,k) = xlamx(i) +! endif +! enddo +! enddo +c +c specify detrainment rate for the updrafts +c +!! (The updraft detrainment rate is set constant and equal to the entrainment rate at cloud base.) +!! +!> - The updraft detrainment rate is vertically constant and proportional to clamt + do k = 1, km1 + do i=1,im + if(cnvflg(i) .and. k < kmax(i)) then +! xlamud(i,k) = xlamx(i) +! xlamud(i,k) = crtlamd + xlamud(i,k) = 0.001 * clamt(i) + endif + enddo + enddo +c +c entrainment functions decreasing with height (fent), +c mimicking a cloud ensemble +c (Bechtold et al., 2008) +c + do k = 2, km1 + do i=1,im + if(cnvflg(i).and. + & (k > kbcon(i) .and. k < kmax(i))) then + tem = qeso(i,k)/qeso(i,kbcon(i)) + fent1(i,k) = tem**2 + fent2(i,k) = tem**3 + endif + enddo + enddo +c +c final entrainment and detrainment rates as the sum of turbulent part and +c organized one depending on the environmental relative humidity +c (Bechtold et al., 2008; Derbyshire et al., 2011) +c + do k = 2, km1 + do i=1,im + if(cnvflg(i) .and. + & (k > kbcon(i) .and. k < kmax(i))) then + tem = cxlame * frh(i,k) * fent2(i,k) + xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem + tem1 = cxlamd * frh(i,k) + xlamud(i,k) = xlamud(i,k) + tem1 + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c determine updraft mass flux for the subcloud layers +c +!> - Calculate the normalized mass flux for subcloud and in-cloud layers according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 1: +!! \f[ +!! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d +!! \f] +!! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < kbcon(i) .and. k >= kb(i)) then + dz = zi(i,k+1) - zi(i,k) + tem = 0.5*(xlamud(i,k)+xlamud(i,k+1)) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-tem + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do i = 1, im + flg(i) = cnvflg(i) + enddo + do k = 2, km1 + do i = 1, im + if(flg(i))then + if(k > kbcon(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5*(xlamud(i,k)+xlamud(i,k-1)) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-tem + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + if(eta(i,k) <= 0.) then + kmax(i) = k + ktconn(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute updraft cloud properties +c +!> - Set cloud properties equal to the state variables at updraft starting level (kb). + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + pwavo(i) = 0. + endif + enddo +! for tracers + do n = 1, ntr + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + ecko(i,indx,n) = ctro(i,indx,n) + endif + enddo + enddo +c +c cloud property is modified by the entrainment process +c +! cm is an enhancement factor in entrainment rates for momentum +! +!> - Calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. Discretization follows Appendix B of Grell (1993) \cite grell_1993 . Following Han and Pan (2006) \cite han_and_pan_2006, the convective momentum transport is reduced by the convection-induced pressure gradient force by the constant "pgcon", currently set to 0.55 after Zhang and Wu (2003) \cite zhang_and_wu_2003 . + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + endif + endif + enddo + enddo + do n = 1, ntr + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + factor = 1. + tem + ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* + & (ctro(i,k,n)+ctro(i,k-1,n)))/factor + endif + endif + enddo + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c +!> - With entrainment, recalculate the LFC as the first level where buoyancy is positive. The difference in pressure levels between LFCs calculated with/without entrainment must be less than a threshold (currently 25 hPa). Otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. This is the subcloud dryness trigger modification discussed in Han and Pan (2011) \cite han_and_pan_2011. + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kmax(i)) then + if(k >= kbcon(i) .and. dbyo(i,k) > 0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem > dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c calculate convective inhibition +c +!> - Calculate additional trigger condition of the convective inhibition (CIN) according to Han et al.'s (2017) \cite han_et_al_2017 equation 13. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kbcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + cina(i) = cina(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + cina(i) = cina(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +!> - Turn off convection if the CIN is less than a critical value (cinacr) which is inversely proportional to the large-scale vertical velocity. + do i = 1, im + if(cnvflg(i)) then +! + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + tem = 1. - tem + tem1= .5*(cinacrmx-cinacrmn) + cinacr = cinacrmx - tem * tem1 +! +! cinacr = cinacrmx + if(cina(i) < cinacr) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c +!> - Calculate the cloud top as the first level where parcel buoyancy becomes negative. If the thickness of the calculated convection is less than a threshold (currently 200 hPa), then convection is inhibited, and the scheme returns to the calling routine. + do i = 1, im + flg(i) = cnvflg(i) + ktcon(i) = 1 + enddo + do k = 2, km1 + do i = 1, im + if (flg(i) .and. k < kmax(i)) then + if(k > kbcon1(i) .and. dbyo(i,k) < 0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i = 1, im + if(cnvflg(i)) then + if(ktcon(i) == 1 .and. ktconn(i) > 1) then + ktcon(i) = ktconn(i) + endif + tem = pfld(i,kbcon(i))-pfld(i,ktcon(i)) + if(tem < cthk) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c search for downdraft originating level above theta-e minimum +c +!> - To originate the downdraft, search for the level above the minimum in moist static energy. Return to the calling routine without modification if this level is determined to be outside of the convective cloud layers. + do i = 1, im + if(cnvflg(i)) then + hmin(i) = heo(i,kbcon1(i)) + lmin(i) = kbmax(i) + jmin(i) = kbmax(i) + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i) .and. k <= kbmax(i)) then + if(k > kbcon1(i) .and. heo(i,k) < hmin(i)) then + lmin(i) = k + 1 + hmin(i) = heo(i,k) + endif + endif + enddo + enddo +c +c make sure that jmin is within the cloud +c + do i = 1, im + if(cnvflg(i)) then + jmin(i) = min(lmin(i),ktcon(i)-1) + jmin(i) = max(jmin(i),kbcon1(i)+1) + if(jmin(i) >= ktcon(i)) cnvflg(i) = .false. + endif + enddo +c +c specify upper limit of mass flux at cloud base +c +!> - Calculate the maximum value of the cloud base mass flux using the CFL-criterion-based formula of Han and Pan (2011) \cite han_and_pan_2011, equation 7. + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (2. * g * dt2) +! +! xmbmax(i) = dp / (g * dt2) +! +! mbdt(i) = 0.1 * dp / g +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c +!> - Set cloud moisture property equal to the enviromental moisture at updraft starting level (kb). + do i = 1, im + if (cnvflg(i)) then +! aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) +! rhbar(i) = 0. + endif + enddo +!> - Calculate the moisture content of the entraining/detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation A.14 in Grell (1993) \cite grell_1993 . Their difference is the amount of convective cloud water (qlk = rain + condensate). Determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo). Calculate and save the negative cloud work function (aa1) due to water loading. The liquid water in the updraft layer is assumed to be detrained from the layers above the level of the minimum moist static energy into the grid-scale cloud water (dellal). + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c check if there is excess moisture to release latent heat +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0 .and. k > jmin(i)) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif +! aa1(i) = aa1(i) - dz * g * qlk * etah +! aa1(i) = aa1(i) - dz * g * qlk + buo(i,k) = buo(i,k) - g * qlk + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + pwavo(i) = pwavo(i) + pwo(i,k) +! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp + cnvwt(i,k) = etah * qlk * g / dp + endif +! +! compute buoyancy and drag for updraft velocity +! + if(k >= kbcon(i)) then + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + buo(i,k) = buo(i,k) + g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + drag(i,k) = max(xlamue(i,k),xlamud(i,k)) + endif +! + endif + endif + enddo + enddo +c +! do i = 1, im +! if(cnvflg(i)) then +! indx = ktcon(i) - kb(i) - 1 +! rhbar(i) = rhbar(i) / float(indx) +! endif +! enddo +c +c calculate cloud work function +c +! do k = 2, km1 +! do i = 1, im +! if (cnvflg(i)) then +! if(k >= kbcon(i) .and. k < ktcon(i)) then +! dz1 = zo(i,k+1) - zo(i,k) +! gamma = el2orc * qeso(i,k) / (to(i,k)**2) +! rfact = 1. + delta * cp * gamma +! & * to(i,k) / hvap +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * (g / (cp * to(i,k))) +! & dz1 * (g / (cp * to(i,k))) +! & * dbyo(i,k) / (1. + gamma) +! & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) +! endif +! endif +! enddo +! enddo +! +! calculate cloud work function +! +!> - Calculate the cloud work function according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 4: +!! \f[ +!! A_u=\int_{z_0}^{z_t}\frac{g}{c_pT(z)}\frac{\eta}{1 + \gamma}[h(z)-h^*(z)]dz +!! \f] +!! (discretized according to Grell (1993) \cite grell_1993 equation B.10 using B.2 and B.3 of Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 and assuming \f$\eta=1\f$) where \f$A_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{L}{c_p}\left(\frac{\partial \overline{q_s}}{\partial T}\right)_p\f$ and other quantities are previously defined. + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) +! aa1(i) = aa1(i) + buo(i,k) * dz1 * eta(i,k) + aa1(i) = aa1(i) + buo(i,k) * dz1 + endif + endif + enddo + enddo +! +!> - If the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine. + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the onvective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c +!> - Continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to Han and Pan (2011) \cite han_and_pan_2011 . Convective overshooting stops when \f$ cA_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force. + do i = 1, im + if (cnvflg(i)) then + aa2(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + if(k >= ktcon(i) .and. k < kmax(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa2(i) = aa2(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact +! val = 0. +! aa2(i) = aa2(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) + if(aa2(i) < 0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c +!> - For the overshooting convection, calculate the moisture content of the entraining/detraining parcel as before. Partition convective cloud water and precipitation and detrain convective cloud water above the mimimum in moist static energy. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= ktcon(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + pwavo(i) = pwavo(i) + pwo(i,k) +! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +! +! compute updraft velocity square(wu2) +!> - Calculate updraft velocity square(wu2) according to Han et al.'s (2017) \cite han_et_al_2017 equation 7. +! +! bb1 = 2. * (1.+bet1*cd1) +! bb2 = 2. / (f1*(1.+gam1)) +! +! bb1 = 3.9 +! bb2 = 0.67 +! +! bb1 = 2.0 +! bb2 = 4.0 +! + bb1 = 4.0 + bb2 = 0.8 +! +! do i = 1, im +! if (cnvflg(i)) then +! k = kbcon1(i) +! tem = po(i,k) / (rd * to(i,k)) +! wucb = -0.01 * dot(i,k) / (tem * g) +! if(wucb > 0.) then +! wu2(i,k) = wucb * wucb +! else +! wu2(i,k) = 0. +! endif +! endif +! enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo +! +! compute updraft velocity average over the whole cumulus +! +!> - Calculate the mean updraft velocity within the cloud (wc). + do i = 1, im + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) cnvflg(i)=.false. + endif + enddo +c +c exchange ktcon with ktcon1 +c +!> - Swap the indices of the convective cloud top (ktcon) and the overshooting convection top (ktcon1) to use the same cloud top level in the calculations of \f$A^+\f$ and \f$A^*\f$. + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c +!> - Separate the total updraft cloud water at cloud top into vapor and condensate. + if(ncloud > 0) then +c +c compute liquid and vapor separation at cloud top +c + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +ccccc if(lat.==.latd.and.lon.==.lond.and.cnvflg(i)) then +ccccc print *, ' aa1(i) before dwndrft =', aa1(i) +ccccc endif +c +c------- downdraft calculations +c +c--- compute precipitation efficiency in terms of windshear +c +!> ## Perform calculations related to the downdraft of the entraining/detraining cloud model ("static control"). +!! - First, in order to calculate the downdraft mass flux (as a fraction of the updraft mass flux), calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : +!! \f[ +!! E = 1.591 - 0.639\frac{\Delta V}{\Delta z} + 0.0953\left(\frac{\Delta V}{\Delta z}\right)^2 - 0.00496\left(\frac{\Delta V}{\Delta z}\right)^3 +!! \f] +!! where \f$\Delta V\f$ is the integrated horizontal shear over the cloud depth, \f$\Delta z\f$, (the ratio is converted to units of \f$10^{-3} s^{-1}\f$). The variable "edto" is \f$1-E\f$ and is constrained to the range \f$[0,0.9]\f$. + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + edto(i)=edt(i) + edtx(i)=edt(i) + endif + enddo +c +c determine detrainment rate between 1 and kbcon +c +!> - Next, calculate the variable detrainment rate between the surface and the LFC according to: +!! \f[ +!! \lambda_d = \frac{1-\beta^{\frac{1}{k_{LFC}}}}{\overline{\Delta z}} +!! \f] +!! \f$\lambda_d\f$ is the detrainment rate, \f$\beta\f$ is a constant currently set to 0.05, implying that only 5% of downdraft mass flux at LFC reaches the ground surface due to detrainment, \f$k_{LFC}\f$ is the vertical index of the LFC level, and \f$\overline{\Delta z}\f$ is the average vertical grid spacing below the LFC. + do i = 1, im + if(cnvflg(i)) then + sumx(i) = 0. + endif + enddo + do k = 1, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= 1 .and. k < kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + betamn = betas + if(islimsk(i) == 1) betamn = betal + if(ntk > 0) then + betamx = betamn + dbeta + if(tkemean(i) > tkemx) then + beta = betamn + else if(tkemean(i) < tkemn) then + beta = betamx + else + tem = (betamx - betamn) * (tkemean(i) - tkemn) + beta = betamx - tem / dtke + endif + else + beta = betamn + endif + dz = (sumx(i)+zi(i,1))/float(kbcon(i)) + tem = 1./float(kbcon(i)) + xlamd(i) = (1.-beta**tem)/dz + endif + enddo +c +c determine downdraft mass flux +c +!> - Calculate the normalized downdraft mass flux from equation 1 of Pan and Wu (1995) \cite pan_and_wu_1995 . Downdraft entrainment and detrainment rates are constants from the downdraft origination to the LFC. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)-1) then + if(k < jmin(i) .and. k >= kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = xlamdd - xlamde + etad(i,k) = etad(i,k+1) * (1. - ptem * dz) + else if(k < kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = xlamd(i) + xlamdd - xlamde + etad(i,k) = etad(i,k+1) * (1. - ptem * dz) + endif + endif + enddo + enddo +c +c--- downdraft moisture properties +c +!> - Set initial cloud downdraft properties equal to the state variables at the downdraft origination level. + do i = 1, im + if(cnvflg(i)) then + jmn = jmin(i) + hcdo(i,jmn) = heo(i,jmn) + qcdo(i,jmn) = qo(i,jmn) + qrcdo(i,jmn)= qo(i,jmn) + ucdo(i,jmn) = uo(i,jmn) + vcdo(i,jmn) = vo(i,jmn) + pwevo(i) = 0. + endif + enddo +! for tracers + do n = 1, ntr + do i = 1, im + if(cnvflg(i)) then + jmn = jmin(i) + ecdo(i,jmn,n) = ctro(i,jmn,n) + endif + enddo + enddo +cj +!> - Calculate the cloud properties as a parcel descends, modified by entrainment and detrainment. Discretization follows Appendix B of Grell (1993) \cite grell_1993 . + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* + & (heo(i,k)+heo(i,k+1)))/factor + dbyo(i,k) = hcdo(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem - pgcon + ptem1= tem + pgcon + ucdo(i,k) = ((1.-tem)*ucdo(i,k+1)+ptem*uo(i,k+1) + & +ptem1*uo(i,k))/factor + vcdo(i,k) = ((1.-tem)*vcdo(i,k+1)+ptem*vo(i,k+1) + & +ptem1*vo(i,k))/factor + endif + enddo + enddo + do n = 1, ntr + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + tem = 0.5 * xlamde * dz + factor = 1. + tem + ecdo(i,k,n) = ((1.-tem)*ecdo(i,k+1,n)+tem* + & (ctro(i,k,n)+ctro(i,k+1,n)))/factor + endif + enddo + enddo + enddo +c +!> - Compute the amount of moisture that is necessary to keep the downdraft saturated. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrcdo(i,k) = qeso(i,k)+ + & (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k) +! detad = etad(i,k+1) - etad(i,k) +cj + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5* + & (qo(i,k)+qo(i,k+1)))/factor +cj +! pwdo(i,k) = etad(i,k+1) * qcdo(i,k+1) - +! & etad(i,k) * qrcdo(i,k) +! pwdo(i,k) = pwdo(i,k) - detad * +! & .5 * (qrcdo(i,k) + qrcdo(i,k+1)) +cj + pwdo(i,k) = etad(i,k) * (qcdo(i,k) - qrcdo(i,k)) + pwevo(i) = pwevo(i) + pwdo(i,k) + endif + enddo + enddo +c +c--- final downdraft strength dependent on precip +c--- efficiency (edt), normalized condensate (pwav), and +c--- evaporate (pwev) +c +!> - Update the precipitation efficiency (edto) based on the ratio of normalized cloud condensate (pwavo) to normalized cloud evaporate (pwevo). + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(cnvflg(i)) then + if(pwevo(i) < 0.) then + edto(i) = -edto(i) * pwavo(i) / pwevo(i) + edto(i) = min(edto(i),edtmax) + else + edto(i) = 0. + endif + endif + enddo +c +c--- downdraft cloudwork functions +c +!> - Calculate downdraft cloud work function (\f$A_d\f$) according to equation A.42 (discretized by B.11) in Grell (1993) \cite grell_1993 . Add it to the updraft cloud work function, \f$A_u\f$. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k < jmin(i)) then + gamma = el2orc * qeso(i,k) / to(i,k)**2 + dhh=hcdo(i,k) + dt=to(i,k) + dg=gamma + dh=heso(i,k) + dz=-1.*(zo(i,k+1)-zo(i,k)) +! aa1(i)=aa1(i)+edto(i)*dz*etad(i,k) + aa1(i)=aa1(i)+edto(i)*dz + & *(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. +! aa1(i)=aa1(i)+edto(i)*dz*etad(i,k) + aa1(i)=aa1(i)+edto(i)*dz + & *g*delta*max(val,(qeso(i,k)-qo(i,k))) + endif + enddo + enddo +!> - Check for negative total cloud work function; if found, return to calling routine without modifying state variables. + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) then + cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c +!> - Calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux near the surface using equations B.18 and B.19 from Grell (1993) \cite grell_1993, for all layers below cloud top from equations B.14 and B.15, and for the cloud top from B.16 and B.17. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo + do n = 1, ntr + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellae(i,k,n) = 0. + endif + enddo + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + dp = 1000. * del(i,1) + dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1) + & - heo(i,1)) * g / dp + dellaq(i,1) = edto(i) * etad(i,1) * (qrcdo(i,1) + & - qo(i,1)) * g / dp + dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1) + & - uo(i,1)) * g / dp + dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1) + & - vo(i,1)) * g / dp + endif + enddo + do n = 1, ntr + do i = 1, im + if(cnvflg(i)) then + dp = 1000. * del(i,1) + dellae(i,1,n) = edto(i) * etad(i,1) * (ecdo(i,1,n) + & - ctro(i,1,n)) * g / dp + endif + enddo + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i) .and. k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k > jmin(i)) adw = 0. + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1)) +c + if(k <= kbcon(i)) then + ptem = xlamde + ptem1 = xlamd(i)+xlamdd + else + ptem = xlamde + ptem1 = xlamdd + endif +cj + dellah(i,k) = dellah(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz + & + aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz + & + aup*tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qcdo(i,k-1))*dz + & ) *g/dp +cj + tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) + tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) + ptem1=etad(i,k)*(uo(i,k)-ucdo(i,k)) + ptem2=etad(i,k-1)*(uo(i,k-1)-ucdo(i,k-1)) + dellau(i,k) = dellau(i,k) + + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp +cj + tem1=eta(i,k)*(vo(i,k)-vcko(i,k)) + tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1)) + ptem1=etad(i,k)*(vo(i,k)-vcdo(i,k)) + ptem2=etad(i,k-1)*(vo(i,k-1)-vcdo(i,k-1)) + dellav(i,k) = dellav(i,k) + + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp +cj + endif + enddo + enddo + do n = 1, ntr + do k = 2, km1 + do i = 1, im + if (cnvflg(i) .and. k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k > jmin(i)) adw = 0. + dp = 1000. * del(i,k) +cj + tem1=eta(i,k)*(ctro(i,k,n)-ecko(i,k,n)) + tem2=eta(i,k-1)*(ctro(i,k-1,n)-ecko(i,k-1,n)) + ptem1=etad(i,k)*(ctro(i,k,n)-ecdo(i,k,n)) + ptem2=etad(i,k-1)*(ctro(i,k-1,n)-ecdo(i,k-1,n)) + dellae(i,k,n) = dellae(i,k,n) + + & (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp +cj + endif + enddo + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - uo(i,indx-1)) * g / dp + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - vo(i,indx-1)) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo + do n = 1, ntr + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dellae(i,indx,n) = eta(i,indx-1) * + & (ecko(i,indx-1,n) - ctro(i,indx-1,n)) * g / dp + endif + enddo + enddo +c +c------- final changed variable per unit mass flux +c +!> - If grid size is less than a threshold value (dxcrtas: currently 8km), the quasi-equilibrium assumption of Arakawa-Schubert is not used any longer. +! + do i = 1, im + asqecflg(i) = cnvflg(i) + if(asqecflg(i) .and. gdx(i) < dxcrtas) then + asqecflg(i) = .false. + endif + enddo +! +!> - If grid size is larger than the threshold value (i.e., asqecflg=.true.), the quasi-equilibrium assumption is used to obtain the cloud base mass flux. To begin with, calculate the change in the temperature and moisture profiles per unit cloud base mass flux. + do k = 1, km + do i = 1, im + if (asqecflg(i) .and. k <= kmax(i)) then + if(k > ktcon(i)) then + qo(i,k) = q1(i,k) + to(i,k) = t1(i,k) + endif + if(k <= ktcon(i)) then + qo(i,k) = dellaq(i,k) * mbdt(i) + q1(i,k) + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + to(i,k) = dellat * mbdt(i) + t1(i,k) + val = 1.e-10 + qo(i,k) = max(qo(i,k), val ) + endif + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- the above changed environment is now used to calulate the +c--- effect the arbitrary cloud (with unit mass flux) +c--- would have on the stability, +c--- which then is used to calculate the real mass flux, +c--- necessary to keep this change in balance with the large-scale +c--- destabilization. +c +c--- environmental conditions again, first heights +c +!> ## Using the updated temperature and moisture profiles that were modified by the convection on a short time-scale, recalculate the total cloud work function to determine the change in the cloud work function due to convection, or the stabilizing effect of the cumulus. +!! - Using notation from Pan and Wu (1995) \cite pan_and_wu_1995, the previously calculated cloud work function is denoted by \f$A^+\f$. Now, it is necessary to use the entraining/detraining cloud model ("static control") to determine the cloud work function of the environment after the stabilization of the arbitrary convective element (per unit cloud base mass flux) has been applied, denoted by \f$A^*\f$. +!! - Recalculate saturation specific humidity. + do k = 1, km + do i = 1, im + if(asqecflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c--- moist static energy +c +!! - Recalculate moist static energy and saturation moist static energy. + do k = 1, km1 + do i = 1, im + if(asqecflg(i) .and. k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo + do k = 1, km1 + do i = 1, im + if(asqecflg(i) .and. k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + endif + enddo + enddo + do i = 1, im + if(asqecflg(i)) then + k = kmax(i) + heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo +c +c**************************** static control +c +c------- moisture and cloud work functions +c +!> - As before, recalculate the updraft cloud work function. + do i = 1, im + if(asqecflg(i)) then + xaa0(i) = 0. + xpwav(i) = 0. + endif + enddo +c + do i = 1, im + if(asqecflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + qcko(i,indx) = qo(i,indx) + endif + enddo + do k = 2, km1 + do i = 1, im + if (asqecflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + endif + endif + enddo + enddo + do k = 2, km1 + do i = 1, im + if (asqecflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + xdby = hcko(i,k) - heso(i,k) + xqrch = qeso(i,k) + & + gamma * xdby / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor +cj + dq = eta(i,k) * (qcko(i,k) - xqrch) +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + if(ncloud > 0 .and. k > jmin(i)) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + if(k < ktcon1(i)) then +! xaa0(i) = xaa0(i) - dz * g * qlk * etah + xaa0(i) = xaa0(i) - dz * g * qlk + endif + qcko(i,k) = qlk + xqrch + xpw = etah * c0t(i,k) * dz * qlk + xpwav(i) = xpwav(i) + xpw + endif + endif + if(k >= kbcon(i) .and. k < ktcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + xaa0(i) = xaa0(i) +! & + dz1 * eta(i,k) * (g / (cp * to(i,k))) + & + dz1 * (g / (cp * to(i,k))) + & * xdby / (1. + gamma) + & * rfact + val=0. + xaa0(i) = xaa0(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +c +c------- downdraft calculations +c +c--- downdraft moisture properties +c +!> - As before, recalculate the downdraft cloud work function. + do i = 1, im + if(asqecflg(i)) then + jmn = jmin(i) + hcdo(i,jmn) = heo(i,jmn) + qcdo(i,jmn) = qo(i,jmn) + qrcd(i,jmn) = qo(i,jmn) + xpwev(i) = 0. + endif + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (asqecflg(i) .and. k < jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* + & (heo(i,k)+heo(i,k+1)))/factor + endif + enddo + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (asqecflg(i) .and. k < jmin(i)) then + dq = qeso(i,k) + dt = to(i,k) + gamma = el2orc * dq / dt**2 + dh = hcdo(i,k) - heso(i,k) + qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh +! detad = etad(i,k+1) - etad(i,k) +cj + dz = zi(i,k+1) - zi(i,k) + if(k >= kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5* + & (qo(i,k)+qo(i,k+1)))/factor +cj +! xpwd = etad(i,k+1) * qcdo(i,k+1) - +! & etad(i,k) * qrcd(i,k) +! xpwd = xpwd - detad * +! & .5 * (qrcd(i,k) + qrcd(i,k+1)) +cj + xpwd = etad(i,k) * (qcdo(i,k) - qrcd(i,k)) + xpwev(i) = xpwev(i) + xpwd + endif + enddo + enddo +c + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(asqecflg(i)) then + if(xpwev(i) >= 0.) then + edtx(i) = 0. + else + edtx(i) = -edtx(i) * xpwav(i) / xpwev(i) + edtx(i) = min(edtx(i),edtmax) + endif + endif + enddo +c +c +c--- downdraft cloudwork functions +c +c + do k = km1, 1, -1 + do i = 1, im + if (asqecflg(i) .and. k < jmin(i)) then + gamma = el2orc * qeso(i,k) / to(i,k)**2 + dhh=hcdo(i,k) + dt= to(i,k) + dg= gamma + dh= heso(i,k) + dz=-1.*(zo(i,k+1)-zo(i,k)) +! xaa0(i)=xaa0(i)+edtx(i)*dz*etad(i,k) + xaa0(i)=xaa0(i)+edtx(i)*dz + & *(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. +! xaa0(i)=xaa0(i)+edtx(i)*dz*etad(i,k) + xaa0(i)=xaa0(i)+edtx(i)*dz + & *g*delta*max(val,(qeso(i,k)-qo(i,k))) + endif + enddo + enddo +c +c calculate critical cloud work function +c +! do i = 1, im +! if(cnvflg(i)) then +! if(pfld(i,ktcon(i)) < pcrit(15))then +! acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i))) +! & /(975.-pcrit(15)) +! else if(pfld(i,ktcon(i)) > pcrit(1))then +! acrt(i)=acrit(1) +! else +! k = int((850. - pfld(i,ktcon(i)))/50.) + 2 +! k = min(k,15) +! k = max(k,2) +! acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))* +! & (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k)) +! endif +! endif +! enddo +! do i = 1, im +! if(cnvflg(i)) then +! if(islimsk(i) == 1) then +! w1 = w1l +! w2 = w2l +! w3 = w3l +! w4 = w4l +! else +! w1 = w1s +! w2 = w2s +! w3 = w3s +! w4 = w4s +! endif +c +c modify critical cloud workfunction by cloud base vertical velocity +c +! if(pdot(i) <= w4) then +! acrtfct(i) = (pdot(i) - w4) / (w3 - w4) +! elseif(pdot(i) >= -w4) then +! acrtfct(i) = - (pdot(i) + w4) / (w4 - w3) +! else +! acrtfct(i) = 0. +! endif +! val1 = -1. +! acrtfct(i) = max(acrtfct(i),val1) +! val2 = 1. +! acrtfct(i) = min(acrtfct(i),val2) +! acrtfct(i) = 1. - acrtfct(i) +c +c modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent +c +c if(rhbar(i) >= .8) then +c acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10. +c endif +c +c modify adjustment time scale by cloud base vertical velocity +c +! dtconv(i) = dt2 + max((1800. - dt2),0.) * +! & (pdot(i) - w2) / (w1 - w2) +c dtconv(i) = max(dtconv(i), dt2) +c dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2) +! +! dtconv(i) = max(dtconv(i),dtmin) +! dtconv(i) = min(dtconv(i),dtmax) +c +! endif +! enddo +! +! compute convective turn-over time +! +!> - Following Bechtold et al. (2008) \cite bechtold_et_al_2008, the convective adjustment time (dtconv) is set to be proportional to the convective turnover time, which is computed using the mean updraft velocity (wc) and the cloud depth. It is also proportional to the grid size (gdx). + do i= 1, im + if(cnvflg(i)) then + tem = zi(i,ktcon1(i)) - zi(i,kbcon1(i)) + dtconv(i) = tem / wc(i) + tfac = 1. + gdx(i) / 75000. + dtconv(i) = tfac * dtconv(i) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = min(dtconv(i),dtmax) + endif + enddo +! +!> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv(i) = gdx(i) / umean(i) + endif + enddo +!> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity for the grid sizes where the quasi-equilibrium assumption of Arakawa-Schubert is not valid any longer. +!! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. + do i= 1, im + if(cnvflg(i) .and. .not.asqecflg(i)) then + k = kbcon(i) + rho = po(i,k)*100. / (rd*to(i,k)) + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + xmb(i) = tfac*betaw*rho*wc(i) + endif + enddo +!> - For the cases where the quasi-equilibrium assumption of Arakawa-Schubert is valid, first calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : +!! \f[ +!! \frac{\partial A}{\partial t}_{LS}=\frac{A^+-cA^0}{\Delta t_{LS}} +!! \f] +!! Here \f$A^0\f$ is set to zero following Han et al.'s (2017) \cite han_et_al_2017 , implying that the instability is completely eliminated after the convective adjustment time, \f$\Delta t_{LS}\f$. + do i= 1, im + if(asqecflg(i)) then +! fld(i)=(aa1(i)-acrt(i)*acrtfct(i))/dtconv(i) + fld(i)=aa1(i)/dtconv(i) + if(fld(i) <= 0.) then + asqecflg(i) = .false. + cnvflg(i) = .false. + endif + endif +!> - Calculate the stabilization effect of the convection (per unit cloud base mass flux) as in equation 6 of Pan and Wu (1995) \cite pan_and_wu_1995 : +!! \f[ +!! \frac{\partial A}{\partial t}_{cu}=\frac{A^*-A^+}{\Delta t_{cu}} +!! \f] +!! \f$\Delta t_{cu}\f$ is the short timescale of the convection. + if(asqecflg(i)) then +c xaa0(i) = max(xaa0(i),0.) + xk(i) = (xaa0(i) - aa1(i)) / mbdt(i) + if(xk(i) >= 0.) then + asqecflg(i) = .false. + cnvflg(i) = .false. + endif + endif +c +c--- kernel, cloud base mass flux +c +!> - The cloud base mass flux (xmb) is then calculated from equation 7 of Pan and Wu (1995) \cite pan_and_wu_1995 +!! \f[ +!! M_c=\frac{-\frac{\partial A}{\partial t}_{LS}}{\frac{\partial A}{\partial t}_{cu}} +!! \f] +!! +!! Again when dtconv is larger than tauadv, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. + if(asqecflg(i)) then + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + xmb(i) = -tfac * fld(i) / xk(i) +! xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +!! +!> - If the large scale destabilization is less than zero, or the stabilization by the convection is greater than zero, then the scheme returns to the calling routine without modifying the state variables. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +! +!> - For scale-aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see Han et al.'s (2017) \cite han_et_al_2017 equation 4 and 5), following the study by Grell and Freitas (2014) \cite grell_and_freitus_2014. + do i = 1, im + if(cnvflg(i)) then + tem = min(max(xlamue(i,kbcon(i)), 7.e-5), 3.e-4) + tem = 0.2 / tem + tem1 = 3.14 * tem * tem + sigmagfm(i) = tem1 / garea(i) + sigmagfm(i) = max(sigmagfm(i), 0.001) + sigmagfm(i) = min(sigmagfm(i), 0.999) + endif + enddo +! +!> - Then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by Arakawa and Wu (2013) \cite arakawa_and_wu_2013 (also see Han et al.'s (2017) \cite han_et_al_2017 equation 1 and 2). The final cloud base mass flux with scale-aware parameterization is obtained from the mass flux when sigmagfm << 1, multiplied by the reduction factor (Han et al.'s (2017) \cite han_et_al_2017 equation 2). + do i = 1, im + if(cnvflg(i)) then + if (gdx(i) < dxcrtuf) then + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i) = xmb(i) * scaldfunc(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo + +!If stochastic physics using cellular automata is .true. then perturb the mass-flux here: + + if(do_ca)then + do i=1,im + xmb(i) = xmb(i)*(1.0 + ca_deep(i)*5.) + enddo + endif + +c +c transport aerosols if present +c + if (do_aerosols) + & call samfdeepcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, + & xlamde, xlamdd, cnvflg, jmin, kb, kmax, kbcon, ktcon, fscav, + & edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, + & qtr, qaero) + +c +c restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo + do n = 1, ntr + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + ctro(i,k,n) = ctr(i,k,n) + endif + enddo + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- feedback: simply the changes from the cloud with unit mass flux +c--- multiplied by the mass flux necessary to keep the +c--- equilibrium with the larger-scale. +c +!> ## For the "feedback" control, calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!> - Calculate the temperature tendency from the moist static energy and specific humidity tendencies. +!> - Update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux-normalized tendencies by the cloud base mass flux. +!> - Accumulate column-integrated tendencies. + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do n = 1, ntr + do i = 1, im + delebar(i,n) = 0. + enddo + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k <= ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo + do n = 1, ntr + kk = n+2 + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k <= ktcon(i)) then + ctr(i,k,n) = ctr(i,k,n)+dellae(i,k,n)*xmb(i)*dt2 + delebar(i,n)=delebar(i,n)+dellae(i,k,n)*xmb(i)*dp/g + qtr(i,k,kk) = ctr(i,k,n) + endif + endif + enddo + enddo + enddo +!> - Recalculate saturation specific humidity using the updated temperature. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k <= ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c +!> - Add up column-integrated convective precipitation by multiplying the normalized value by the cloud base mass flux. + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k >= jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo +!> - Determine the evaporation of the convective precipitation and update the integrated convective precipitation. +!> - Update state temperature and moisture to account for evaporation of convective precipitation. +!> - Update column-integrated tendencies to account for evaporation of convective precipitation. + do k = km, 1, -1 + do i = 1, im + if (k <= kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i) .and. k < ktcon(i)) then + aup = 1. + if(k <= kb(i)) aup = 0. + adw = 1. + if(k >= jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 + endif + if(flg(i) .and. k < ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i) > 0. .and. qcond(i) < 0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i) > 0. .and. qcond(i) < 0. .and. + & delq2(i) > rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i) > 0. .and. qevap(i) > 0.) then + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + rn(i) = rn(i) - .001 * qevap(i) * dp / g + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me == 31 .and. cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' deep delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +c +c precipitation rate converted to actual precip +c in unit of m instead of kg +c + do i = 1, im + if(cnvflg(i)) then +c +c in the event of upper level rain evaporation and lower level downdraft +c moistening, rn can become negative, in this case, we back out of the +c heating and the moistening +c + if(rn(i) < 0. .and. .not.flg(i)) rn(i) = 0. + if(rn(i) <= 0.) then + rn(i) = 0. + else + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 1 + cldwrk(i) = aa1(i) + endif + endif + enddo +c +c convective cloud water +c +!> - Calculate convective cloud water. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i) > 0.) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +c +c convective cloud cover +c +!> - Calculate convective cloud cover, which is used when pdf-based cloud fraction is used (i.e., pdfcld=.true.). + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i) > 0.) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo +c +c cloud water +c +!> - Separate detrained cloud water into liquid and ice species as a function of temperature only. + if (ncloud > 0) then +! + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i) > 0.) then +! if (k > kb(i) .and. k <= ktcon(i)) then + if (k >= kbcon(i) .and. k <= ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (qtr(i,k,2) > -999.0) then + qtr(i,k,1) = qtr(i,k,1) + tem * tem1 ! ice + qtr(i,k,2) = qtr(i,k,2) + tem *(1.0-tem1) ! water + else + qtr(i,k,1) = qtr(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +c +!> - If convective precipitation is zero or negative, reset the updated state variables back to their original values (negating convective changes). + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) <= 0.) then + if (k <= kmax(i)) then + t1(i,k) = to(i,k) + q1(i,k) = qo(i,k) + u1(i,k) = uo(i,k) + v1(i,k) = vo(i,k) + endif + endif + enddo + enddo + do n = 1, ntr + kk = n+2 + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) <= 0.) then + if (k <= kmax(i)) then + ctr(i,k,n)= ctro(i,k,n) + qtr(i,k,kk)= ctr(i,k,n) + endif + endif + enddo + enddo + enddo + +!> - Store aerosol concentrations if present + if (do_aerosols) then + do n = 1, ntc + kk = n + itc - 1 + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + if (k <= kmax(i)) qtr(i,k,kk) = qaero(i,k,n) + endif + enddo + enddo + enddo + endif +! +! hchuang code change +! +!> - Calculate and retain the updraft and downdraft mass fluxes for dust transport by cumulus convection. +! +!> - Calculate the updraft convective mass flux. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + if(k >= kb(i) .and. k < ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!> - save the updraft convective mass flux at cloud top. + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo +!> - Calculate the downdraft convective mass flux. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + if(k >= 1 .and. k <= jmin(i)) then + dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +! +! include TKE contribution from deep convection +! + if (ntk > 0) then +! + do k = 2, km1 + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + if(k > kb(i) .and. k < ktop(i)) then + tem = 0.5 * (eta(i,k-1) + eta(i,k)) * xmb(i) + tem1 = pfld(i,k) * 100. / (rd * t1(i,k)) + sigmagfm(i) = max(sigmagfm(i), betaw) + ptem = tem / (sigmagfm(i) * tem1) + qtr(i,k,ntk)=qtr(i,k,ntk)+0.5*sigmagfm(i)*ptem*ptem + endif + endif + enddo + enddo +! + do k = 2, km1 + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + if(k > 1 .and. k <= jmin(i)) then + tem = 0.5*edto(i)*(etad(i,k-1)+etad(i,k))*xmb(i) + tem1 = pfld(i,k) * 100. / (rd * t1(i,k)) + sigmagfm(i) = max(sigmagfm(i), betaw) + ptem = tem / (sigmagfm(i) * tem1) + qtr(i,k,ntk)=qtr(i,k,ntk)+0.5*sigmagfm(i)*ptem*ptem + endif + endif + enddo + enddo +! + endif +!! + if(mp_phys == 10) then + do k=1,km + do i=1,im + QLCN(i,k) = qtr(i,k,2) - qlcn(i,k) + QICN(i,k) = qtr(i,k,1) - qicn(i,k) + cf_upi(i,k) = cnvc(i,k) + w_upi(i,k) = ud_mf(i,k)*t1(i,k)*rd / + & (dt2*max(sigmagfm(i),1.e-12)*prslp(i,k)) + CNV_MFD(i,k) = ud_mf(i,k)/dt2 + CLCN(i,k) = cnvc(i,k) + CNV_FICE(i,k) = QICN(i,k) + & / max(1.e-10,QLCN(i,k)+QICN(i,k)) + enddo + enddo + endif + return + end + diff --git a/gsmphys/samfshalcnv.f b/gsmphys/samfshalcnv.f new file mode 100644 index 00000000..2b120009 --- /dev/null +++ b/gsmphys/samfshalcnv.f @@ -0,0 +1,1810 @@ +!> \defgroup SAMF_shal Scale-Aware Mass-Flux Shallow Convection +!! @{ +!! \brief The scale-aware mass-flux shallow (SAMF_shal) convection scheme is an updated version of the previous mass-flux shallow convection scheme with scale and aerosol awareness and parameterizes the effect of shallow convection on the environment. The SAMF_shal scheme is similar to the SAMF deep convection scheme but with a few key differences. First, no quasi-equilibrium assumption is used for any grid size and the shallow cloud base mass flux is parameterized using a mean updraft velocity. Further, there are no convective downdrafts, the entrainment rate is greater than for deep convection, and the shallow convection is limited to not extend over the level where \f$p=0.7p_{sfc}\f$. The paramerization of scale and aerosol awareness follows that of the SAMF deep convection scheme. +!! +!! The previous version of the shallow convection scheme (shalcnv.f) is described in Han and Pan (2011) \cite han_and_pan_2011 and differences between the shallow and deep convection schemes are presented in Han and Pan (2011) \cite han_and_pan_2011 and Han et al. (2017) \cite han_et_al_2017 . Details of scale- and aerosol-aware parameterizations are described in Han et al. (2017) \cite han_et_al_2017 . +!! +!! In further update for FY19 GFS implementation, interaction with turbulent kinetic energy (TKE), which is a prognostic variable used in a scale-aware TKE-based moist EDMF vertical turbulent mixing scheme, is included. Entrainment rates in updrafts are proportional to sub-cloud mean TKE. TKE is transported by cumulus convection. TKE contribution from cumulus convection is deduced from cumulus mass flux. On the other hand, tracers such as ozone and aerosol are also transported by cumulus convection. +!! +!! To reduce too much convective cooling at the cloud top, the convection schemes have been modified for the rain conversion rate, entrainment and detrainment rates, overshooting layers, and maximum allowable cloudbase mass flux (as of June 2018). +!! +!! \section diagram Calling Hierarchy Diagram +!! \image html SAMF_shal_Flowchart.png "Diagram depicting how the SAMF shallow convection scheme is called from the FV3GFS physics time loop" height=2cm +!! \section intraphysics Intraphysics Communication +!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. + +!> \file samfshalcnv.f +!! Contains the entire SAMF shallow convection scheme. + +!> \brief This subroutine contains the entirety of the SAMF shallow convection scheme. +!! +!! This routine follows the \ref SAMF deep scheme quite closely, although it can be interpreted as only having the "static" and "feedback" control portions, since the "dynamic" control is not necessary to find the cloud base mass flux. The algorithm is simplified from SAMF deep convection by excluding convective downdrafts and being confined to operate below \f$p=0.7p_{sfc}\f$. Also, entrainment is both simpler and stronger in magnitude compared to the deep scheme. +!! +!! \param[in] im number of used points +!! \param[in] ix horizontal dimension +!! \param[in] km vertical layer dimension +!! \param[in] delt physics time step in seconds +!! \param[in] ntk index for TKE +!! \param[in] ntr total number of tracers including TKE +!! \param[in] delp pressure difference between level k and k+1 (Pa) +!! \param[in] prslp mean layer presure (Pa) +!! \param[in] psp surface pressure (Pa) +!! \param[in] phil layer geopotential (\f$m^s/s^2\f$) +!! \param[in] qtr tracer array including cloud condensate (\f$kg/kg\f$) +!! \param[inout] ql cloud water or ice (kg/kg) +!! \param[inout] q1 updated tracers (kg/kg) +!! \param[inout] t1 updated temperature (K) +!! \param[inout] u1 updated zonal wind (\f$m s^{-1}\f$) +!! \param[inout] v1 updated meridional wind (\f$m s^{-1}\f$) +!! \param[out] rn convective rain (m) +!! \param[out] kbot index for cloud base +!! \param[out] ktop index for cloud top +!! \param[out] kcnv flag to denote deep convection (0=no, 1=yes) +!! \param[in] islimsk sea/land/ice mask (=0/1/2) +!! \param[in] dot layer mean vertical velocity (Pa/s) +!! \param[in] ncloud number of cloud species +!! \param[in] hpbl PBL height (m) +!! \param[in] heat surface sensible heat flux (K m/s) +!! \param[in] evap surface latent heat flux (kg/kg m/s) +!! \param[out] ud_mf updraft mass flux multiplied by time step (\f$kg/m^2\f$) +!! \param[out] dt_mf ud_mf at cloud top (\f$kg/m^2\f$) +!! \param[out] cnvw convective cloud water (kg/kg) +!! \param[out] cnvc convective cloud cover (unitless) +!! \param[in] clam coefficient for entrainment rate +!! \param[in] c0s convective rain conversion parameter (1/m) +!! \param[in] c1 conversion parameter of detrainment from liquid water into grid-scale cloud water (1/m) +!! \param[in] pgcon reduction factor in momentum transport due to convection induced pressure gradient force +!! \param[in] asolfac aerosol-aware parameter inversely proportional to CCN number concentraion +!! +!! \section general General Algorithm +!! -# Compute preliminary quantities needed for the static and feedback control portions of the algorithm. +!! -# Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!! -# The cloud base mass flux is obtained using the cumulus updraft velocity averaged ove the whole cloud depth. +!! -# Calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux. +!! -# For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!! \section detailed Detailed Algorithm +!! @{ +! subroutine samfshalcnv(im,ix,km,delt,ntk,ntr,delp, + subroutine samfshalcnv(im,ix,km,delt,itc,ntc,ntk,ntr,delp, + & prslp,psp,phil,qtr,q1,t1,u1,v1,fscav, + & rn,kbot,ktop,kcnv,islimsk,garea, + & dot,ncloud,hpbl,ud_mf,dt_mf,cnvw,cnvc, + & clam,c0s,c1,pgcon,asolfac) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + integer, intent(in) :: im, ix, km, itc, ntc, ntk, ntr, ncloud + integer, intent(in) :: islimsk(im) + real(kind=kind_phys), intent(in) :: delt + real(kind=kind_phys), intent(in) :: psp(im), delp(ix,km), + & prslp(ix,km), garea(im), hpbl(im), dot(ix,km), phil(ix,km) +! + real(kind=kind_phys), intent(in) :: fscav(ntc) + integer, intent(inout) :: kcnv(im) + real(kind=kind_phys), intent(inout) :: qtr(ix,km,ntr+2), + & q1(ix,km), t1(ix,km), u1(ix,km), v1(ix,km) +! + integer, intent(out) :: kbot(im), ktop(im) + real(kind=kind_phys), intent(out) :: rn(im), + & cnvw(ix,km), cnvc(ix,km), ud_mf(im,km), dt_mf(im,km) +! + real(kind=kind_phys) clam, c0s, c1, + & asolfac, pgcon +! +! local variables + integer i,j,indx, k, kk, km1, n + integer kpbl(im) +! + real(kind=kind_phys) clamd, tkemx, tkemn, dtke +! + real(kind=kind_phys) dellat, delta, + & c0l, d0, + & desdt, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, dxcrt, + & dv1h, dv2h, dv3h, + & dv1q, dv2q, dv3q, + & dz, dz1, e1, + & el2orc, elocp, aafac, cm, + & es, etah, h1, + & evef, evfact, evfactl, fact1, + & fact2, factor, dthk, + & g, gamma, pprime, betaw, + & qlk, qrch, qs, + & rfact, shear, tfac, + & val, val1, val2, + & w1, w1l, w1s, w2, + & w2l, w2s, w3, w3l, + & w3s, w4, w4l, w4s, + & rho, tem, tem1, tem2, + & ptem, ptem1 +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), ktconn(im), + & kbm(im), kmax(im) +! + real(kind=kind_phys) aa1(im), cina(im), + & tkemean(im), clamt(im), + & ps(im), del(ix,km), prsl(ix,km), + & umean(im), tauadv(im), gdx(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & pdot(im), po(im,km), + & qcond(im), qevap(im), hmax(im), + & rntot(im), vshear(im), + & xlamud(im), xmb(im), xmbmax(im), + & delebar(im,ntr), + & delubar(im), delvbar(im) +! + real(kind=kind_phys) c0(im) +c + real(kind=kind_phys) crtlamd +! + real(kind=kind_phys) cinpcr, cinpcrmx, cinpcrmn, + & cinacr, cinacrmx, cinacrmn +! +! parameters for updraft velocity calculation + real(kind=kind_phys) bet1, cd1, f1, gam1, + & bb1, bb2 +! & bb1, bb2, wucb +cc +c physical parameters +! parameter(g=grav,asolfac=0.89) + parameter(g=grav) + parameter(elocp=hvap/cp, + & el2orc=hvap*hvap/(rv*cp)) +! parameter(c0s=0.002,c1=5.e-4,d0=.01) +! parameter(d0=.01) + parameter(d0=.001) +! parameter(c0l=c0s*asolfac) +! +! asolfac: aerosol-aware parameter based on Lim & Hong (2012) +! asolfac= cx / c0s(=.002) +! cx = min([-0.7 ln(Nccn) + 24]*1.e-4, c0s) +! Nccn: CCN number concentration in cm^(-3) +! Until a realistic Nccn is provided, Nccns are assumed +! as Nccn=100 for sea and Nccn=1000 for land +! + parameter(cm=1.0,delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(clamd=0.1,tkemx=0.65,tkemn=0.05) + parameter(dtke=tkemx-tkemn) + parameter(dthk=25.) + parameter(cinpcrmx=180.,cinpcrmn=120.) +! parameter(cinacrmx=-120.,cinacrmn=-120.) + parameter(cinacrmx=-120.,cinacrmn=-80.) + parameter(crtlamd=3.e-4) + parameter(dtmax=10800.,dtmin=600.) + parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5) + parameter(betaw=.03,dxcrt=15.e3) + parameter(h1=0.33333333) +c local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km), + & ctr(im,km,ntr), ctro(im,km,ntr) +! for aerosol transport + real(kind=kind_phys) qaero(im,km,ntc) +! for updraft velocity calculation + real(kind=kind_phys) wu2(im,km), buo(im,km), drag(im,km) + real(kind=kind_phys) wc(im), scaldfunc(im), sigmagfm(im) +! +c cloud water +! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), + & dbyo(im,km), zo(im,km), xlamue(im,km), + & heo(im,km), heso(im,km), + & dellah(im,km), dellaq(im,km), + & dellae(im,km,ntr), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & qrcko(im,km), ecko(im,km,ntr), + & eta(im,km), + & zi(im,km), pwo(im,km), c0t(im,km), + & sumx(im), tx1(im), cnvwt(im,km) +! + logical do_aerosols, totflg, cnvflg(im), flg(im) +! + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +!> ## Determine whether to perform aerosol transport + do_aerosols = (itc > 0) .and. (ntc > 0) .and. (ntr > 0) + if (do_aerosols) do_aerosols = (ntr >= itc + ntc - 3) +! +!************************************************************************ +! convert input Pa terms to Cb terms -- Moorthi +!> ## Compute preliminary quantities needed for the static and feedback control portions of the algorithm. +!> - Convert input pressure terms to centibar units. + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! + km1 = km - 1 +c +c initialize arrays +c +!> - Initialize column-integrated and other single-value-per-column variable arrays. + do i=1,im + cnvflg(i) = .true. + if(kcnv(i) == 1) cnvflg(i) = .false. + if(cnvflg(i)) then + kbot(i)=km+1 + ktop(i)=0 + endif + rn(i)=0. + kbcon(i)=km + ktcon(i)=1 + ktconn(i)=1 + kb(i)=km + pdot(i) = 0. + qlko_ktcon(i) = 0. + edt(i) = 0. + aa1(i) = 0. + cina(i) = 0. + vshear(i) = 0. + gdx(i) = sqrt(garea(i)) + enddo +!! +!> - Return to the calling routine if deep convection is present or the surface buoyancy flux is negative. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +!> - determine aerosol-aware rain conversion parameter over land + do i=1,im + if(islimsk(i) == 1) then + c0(i) = c0s*asolfac + else + c0(i) = c0s + endif + enddo +! +!> - determine rain conversion parameter above the freezing level which exponentially decreases with decreasing temperature from Han et al.'s (2017) \cite han_et_al_2017 equation 8. + do k = 1, km + do i = 1, im + if(t1(i,k) > 273.16) then + c0t(i,k) = c0(i) + else + tem = d0 * (t1(i,k) - 273.16) + tem1 = exp(tem) + c0t(i,k) = c0(i) * tem1 + endif + enddo + enddo +! +!> - Initialize convective cloud water and cloud cover to zero. + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +! hchuang code change +!> - Initialize updraft mass fluxes to zero. + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +c + dt2 = delt +! +c model tunable parameters are all here +! clam = .3 +! aafac = .1 + aafac = .05 +c evef = 0.07 + evfact = 0.3 + evfactl = 0.3 +! +! pgcon = 0.7 ! Gregory et al. (1997, QJRMS) +! pgcon = 0.55 ! Zhang & Wu (2003,JAS) + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c +!> - Determine maximum indices for the parcel starting point (kbm) and cloud top (kmax). + do i=1,im + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) > 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) > 0.60) kmax(i) = k + 1 + enddo + enddo + do i=1,im + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and compute +c updraft entrainment rate as an inverse function of height +c +!> - Calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential. + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo +!> - Calculate interface height + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + enddo + enddo +c +c pbl height +c +!> - Find the index for the PBL top using the PBL height; enforce that it is lower than the maximum parcel starting level. + do i=1,im + flg(i) = cnvflg(i) + kpbl(i)= 1 + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. zo(i,k) <= hpbl(i)) then + kpbl(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kpbl(i)= min(kpbl(i),kbm(i)) + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c +!> - Convert prsl from centibar to millibar, set normalized mass flux to 1, cloud properties to 0, and save model state variables (after advection/turbulence). + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + eta(i,k) = 1. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) + wu2(i,k) = 0. + buo(i,k) = 0. + drag(i,k) = 0. + cnvwt(i,k) = 0. + endif + enddo + enddo +! +! initialize tracer variables +! + do n = 3, ntr+2 + kk = n-2 + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + ctr(i,k,kk) = qtr(i,k,n) + ctro(i,k,kk) = qtr(i,k,n) + ecko(i,k,kk) = 0. + endif + enddo + enddo + enddo +!> - Calculate saturation specific humidity and enforce minimum moisture values. + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c +!> - Calculate moist static energy (heo) and saturation moist static energy (heso). + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy within pbl +c this is the level where updraft starts +c +!> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!> - Search in the PBL for the level of maximum moist static energy to start the ascending parcel. + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i) .and. k <= kpbl(i)) then + if(heo(i,k) > hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c +!> - Calculate the temperature, water vapor mixing ratio, and pressure at interface levels. + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! +!> - Recalculate saturation specific humidity, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. Enforce minimum specific humidity. + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo + do n = 1, ntr + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k <= kmax(i)-1) then + ctro(i,k,n) = .5 * (ctro(i,k,n) + ctro(i,k+1,n)) + endif + enddo + enddo + enddo +c +c look for the level of free convection as cloud base +c +!> - Search below the index "kbm" for the level of free convection (LFC) where the condition \f$h_b > h^*\f$ is first met, where \f$h_b, h^*\f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. Set "kbcon" to the index of the LFC. + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kb(i) .and. heo(i,kb(i)) > heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i=1,im + if(cnvflg(i)) then + if(kbcon(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo +!! +!> - If no LFC, return to the calling routine without modifying state variables. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +!> - Determine the vertical pressure velocity at the LFC. After Han and Pan (2011) \cite han_and_pan_2011 , determine the maximum pressure thickness between a parcel's starting level and the LFC. If a parcel doesn't reach the LFC within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables. + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s + endif + enddo +c +c turn off convection if pressure depth between parcel source level +c and cloud base is larger than a critical value, cinpcr +c + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + ptem = 1. - tem + ptem1= .5*(cinpcrmx-cinpcrmn) + cinpcr = cinpcrmx - ptem * ptem1 + tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(tem1 > cinpcr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +! +! turbulent entrainment rate assumed to be proportional +! to subcloud mean TKE +! + if(ntk > 0) then +! + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + tkemean(i) = 0. + endif + enddo + do k = 1, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kb(i) .and. k < kbcon(i)) then + dz = zo(i,k+1) - zo(i,k) + tem = 0.5 * (qtr(i,k,ntk)+qtr(i,k+1,ntk)) + tkemean(i) = tkemean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo +! + do i= 1, im + if(cnvflg(i)) then + tkemean(i) = tkemean(i) / sumx(i) + if(tkemean(i) > tkemx) then + clamt(i) = clam + clamd + else if(tkemean(i) < tkemn) then + clamt(i) = clam - clamd + else + tem = tkemx - tkemean(i) + tem1 = 1. - 2. * tem / dtke + clamt(i) = clam + clamd * tem1 + endif + endif + enddo +! + else +! + do i= 1, im + if(cnvflg(i)) then + clamt(i) = clam + endif + enddo +! + endif +!! +! +! assume updraft entrainment rate +! is an inverse function of height +! + do k = 1, km1 + do i=1,im + if(cnvflg(i)) then + xlamue(i,k) = clamt(i) / zi(i,k) + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + xlamue(i,km) = xlamue(i,km1) + endif + enddo +c +c specify the detrainment rate for the updrafts +c +!! (The updraft detrainment rate is set constant and equal to the entrainment rate at cloud base.) +!! +!> - The updraft detrainment rate is vertically constant and proportional to clamt + do i = 1, im + if(cnvflg(i)) then +! xlamud(i) = xlamue(i,kbcon(i)) +! xlamud(i) = crtlamd + xlamud(i) = 0.001 * clamt(i) + endif + enddo +c +c determine updraft mass flux for the subcloud layers +c +!> - Calculate the normalized mass flux for subcloud and in-cloud layers according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 1: +!! \f[ +!! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d +!! \f] +!! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate. The normalized mass flux increases upward below the cloud base and decreases upward above. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < kbcon(i) .and. k >= kb(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do i = 1, im + flg(i) = cnvflg(i) + enddo + do k = 2, km1 + do i = 1, im + if(flg(i))then + if(k > kbcon(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + if(eta(i,k) <= 0.) then + kmax(i) = k + ktconn(i) = k + kbm(i) = min(kbm(i),kmax(i)) + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute updraft cloud property +c +!> - Set cloud properties equal to the state variables at updraft starting level (kb). + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + endif + enddo +! for tracers + do n = 1, ntr + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + ecko(i,indx,n) = ctro(i,indx,n) + endif + enddo + enddo +c +! cm is an enhancement factor in entrainment rates for momentum +! +!> - Calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. Discretization follows Appendix B of Grell (1993) \cite grell_1993 . Following Han and Pan (2006) \cite han_and_pan_2006, the convective momentum transport is reduced by the convection-induced pressure gradient force by the constant "pgcon", currently set to 0.55 after Zhang and Wu (2003) \cite zhang_and_wu_2003 . + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) +! + tem = 0.5 * cm * tem + factor = 1. + tem + ptem = tem + pgcon + ptem1= tem - pgcon + ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + endif + endif + enddo + enddo + do n = 1, ntr + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * (xlamue(i,k)+xlamue(i,k-1)) * dz + factor = 1. + tem + ecko(i,k,n) = ((1.-tem)*ecko(i,k-1,n)+tem* + & (ctro(i,k,n)+ctro(i,k-1,n)))/factor + endif + endif + enddo + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c +!> - With entrainment, recalculate the LFC as the first level where buoyancy is positive. The difference in pressure levels between LFCs calculated with/without entrainment must be less than a threshold (currently 25 hPa). Otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. This is the subcloud dryness trigger modification discussed in Han and Pan (2011) \cite han_and_pan_2011. + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k >= kbcon(i) .and. dbyo(i,k) > 0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i) == kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem > dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c calculate convective inhibition +c +!> - Calculate additional trigger condition of the convective inhibition (CIN) according to Han et al.'s (2017) \cite han_et_al_2017 equation 13. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < kbcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + cina(i) = cina(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + cina(i) = cina(i) + +! & dz1 * eta(i,k) * g * delta * + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +!> - Turn off convection if the CIN is less than a critical value (cinacr) which is inversely proportional to the large-scale vertical velocity. + do i = 1, im + if(cnvflg(i)) then +! + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i) <= w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i) >= -w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + tem = 1. - tem + tem1= .5*(cinacrmx-cinacrmn) + cinacr = cinacrmx - tem * tem1 +! +! cinacr = cinacrmx + if(cina(i) < cinacr) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c limited to the level of P/Ps=0.7 +c +!> - Calculate the cloud top as the first level where parcel buoyancy becomes negative; the maximum possible value is at \f$p=0.7p_{sfc}\f$. + do i = 1, im + flg(i) = cnvflg(i) + if(flg(i)) ktcon(i) = kbm(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i) .and. k < kbm(i)) then + if(k > kbcon1(i) .and. dbyo(i,k) < 0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c +c specify upper limit of mass flux at cloud base +c +!> - Calculate the maximum value of the cloud base mass flux using the CFL-criterion-based formula of Han and Pan (2011) \cite han_and_pan_2011, equation 7. + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (2. * g * dt2) +! +! xmbmax(i) = dp / (g * dt2) +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c +!> - Set cloud moisture property equal to the enviromental moisture at updraft starting level (kb). + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) + endif + enddo +!> - Calculate the moisture content of the entraining/detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation A.14 in Grell (1993) \cite grell_1993 . Their difference is the amount of convective cloud water (qlk = rain + condensate). Determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo). Calculate and save the negative cloud work function (aa1) due to water loading. Above the level of minimum moist static energy, some of the cloud water is detrained into the grid-scale cloud water from every cloud layer with a rate of 0.0005 \f$m^{-1}\f$ (dellal). + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c below lfc check if there is excess moisture to release latent heat +c + if(k >= kbcon(i) .and. dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + buo(i,k) = buo(i,k) - g * qlk + qcko(i,k)= qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif +! +! compute buoyancy and drag for updraft velocity +! + if(k >= kbcon(i)) then + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + buo(i,k) = buo(i,k) + (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + buo(i,k) = buo(i,k) + g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + drag(i,k) = max(xlamue(i,k),xlamud(i)) + endif +! + endif + endif + enddo + enddo +c +c calculate cloud work function +c +! do k = 2, km1 +! do i = 1, im +! if (cnvflg(i)) then +! if(k >= kbcon(i) .and. k < ktcon(i)) then +! dz1 = zo(i,k+1) - zo(i,k) +! gamma = el2orc * qeso(i,k) / (to(i,k)**2) +! rfact = 1. + delta * cp * gamma +! & * to(i,k) / hvap +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * (g / (cp * to(i,k))) +! & dz1 * (g / (cp * to(i,k))) +! & * dbyo(i,k) / (1. + gamma) +! & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) +! endif +! endif +! enddo +! enddo +! do i = 1, im +! if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. +! enddo +! +! calculate cloud work function +! +!> - Calculate the cloud work function according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 4: +!! \f[ +!! A_u=\int_{z_0}^{z_t}\frac{g}{c_pT(z)}\frac{\eta}{1 + \gamma}[h(z)-h^*(z)]dz +!! \f] +!! (discretized according to Grell (1993) \cite grell_1993 equation B.10 using B.2 and B.3 of Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 and assuming \f$\eta=1\f$) where \f$A_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{L}{c_p}\left(\frac{\partial \overline{q_s}}{\partial T}\right)_p\f$ and other quantities are previously defined. + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= kbcon(i) .and. k < ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) + aa1(i) = aa1(i) + buo(i,k) * dz1 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false. + enddo +!! +!> - If the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the onvective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c limited to the level of P/Ps=0.7 +c +!> - Continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to Han and Pan (2011) \cite han_and_pan_2011 . Convective overshooting stops when \f$ cA_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force. Overshooting is also limited to the level where \f$p=0.7p_{sfc}\f$. + do i = 1, im + if (cnvflg(i)) then + aa1(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon1(i) = kbm(i) + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + if(k >= ktcon(i) .and. k < kbm(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa1(i) = aa1(i) + +! & dz1 * eta(i,k) * (g / (cp * to(i,k))) + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact +! val = 0. +! aa1(i) = aa1(i) + +!! & dz1 * eta(i,k) * g * delta * +! & dz1 * g * delta * +! & max(val,(qeso(i,k) - qo(i,k))) + if(aa1(i) < 0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c +!> - For the overshooting convection, calculate the moisture content of the entraining/detraining parcel as before. Partition convective cloud water and precipitation and detrain convective cloud water in the overshooting layers. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k >= ktcon(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud > 0) then + ptem = c0t(i,k) + c1 + qlk = dq / (eta(i,k) + etah * ptem * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz) + endif + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0t(i,k) * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +! +! compute updraft velocity square(wu2) +!> - Calculate updraft velocity square(wu2) according to Han et al.'s (2017) \cite han_et_al_2017 equation 7. +! +! bb1 = 2. * (1.+bet1*cd1) +! bb2 = 2. / (f1*(1.+gam1)) +! +! bb1 = 3.9 +! bb2 = 0.67 +! +! bb1 = 2.0 +! bb2 = 4.0 +! + bb1 = 4.0 + bb2 = 0.8 +! +! do i = 1, im +! if (cnvflg(i)) then +! k = kbcon1(i) +! tem = po(i,k) / (rd * to(i,k)) +! wucb = -0.01 * dot(i,k) / (tem * g) +! if(wucb > 0.) then +! wu2(i,k) = wucb * wucb +! else +! wu2(i,k) = 0. +! endif +! endif +! enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz + tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz + ptem = (1. - tem) * wu2(i,k-1) + ptem1 = 1. + tem + wu2(i,k) = (ptem + tem1) / ptem1 + wu2(i,k) = max(wu2(i,k), 0.) + endif + endif + enddo + enddo +! +! compute updraft velocity averaged over the whole cumulus +! +!> - Calculate the mean updraft velocity within the cloud (wc). + do i = 1, im + wc(i) = 0. + sumx(i) = 0. + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kbcon1(i) .and. k < ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1))) + wc(i) = wc(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + if(sumx(i) == 0.) then + cnvflg(i)=.false. + else + wc(i) = wc(i) / sumx(i) + endif + val = 1.e-4 + if (wc(i) < val) cnvflg(i)=.false. + endif + enddo +c +c exchange ktcon with ktcon1 +c + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c + if(ncloud > 0) then +c +c compute liquid and vapor separation at cloud top +c +!> - => Separate the total updraft cloud water at cloud top into vapor and condensate. + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq > 0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +c--- compute precipitation efficiency in terms of windshear +c +!! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : +!! \f[ +!! E = 1.591 - 0.639\frac{\Delta V}{\Delta z} + 0.0953\left(\frac{\Delta V}{\Delta z}\right)^2 - 0.00496\left(\frac{\Delta V}{\Delta z}\right)^3 +!! \f] +!! where \f$\Delta V\f$ is the integrated horizontal shear over the cloud depth, \f$\Delta z\f$, (the ratio is converted to units of \f$10^{-3} s^{-1}\f$). The variable "edt" is \f$1-E\f$ and is constrained to the range \f$[0,0.9]\f$. + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + endif + enddo +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c +!> ## Calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux. +!> - Calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux for all layers below cloud top from equations B.14 and B.15 from Grell (1993) \cite grell_1993, and for the cloud top from B.16 and B.17. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo + do n = 1, ntr + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k <= kmax(i)) then + dellae(i,k,n) = 0. + endif + enddo + enddo + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = xlamud(i) +cj + dellah(i,k) = dellah(i,k) + + & ( eta(i,k)*dv1h - eta(i,k-1)*dv3h + & - tem*eta(i,k-1)*dv2h*dz + & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ( eta(i,k)*dv1q - eta(i,k-1)*dv3q + & - tem*eta(i,k-1)*dv2q*dz + & + tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & ) *g/dp +cj + tem1=eta(i,k)*(uo(i,k)-ucko(i,k)) + tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1)) + dellau(i,k) = dellau(i,k) + (tem1-tem2) * g/dp +cj + tem1=eta(i,k)*(vo(i,k)-vcko(i,k)) + tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1)) + dellav(i,k) = dellav(i,k) + (tem1-tem2) * g/dp +cj + endif + endif + enddo + enddo + do n = 1, ntr + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k < ktcon(i)) then + dp = 1000. * del(i,k) +cj + tem1=eta(i,k)*(ctro(i,k,n)-ecko(i,k,n)) + tem2=eta(i,k-1)*(ctro(i,k-1,n)-ecko(i,k-1,n)) + dellae(i,k,n) = dellae(i,k,n) + (tem1-tem2) * g/dp +cj + endif + endif + enddo + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - uo(i,indx-1)) * g / dp + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - vo(i,indx-1)) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo + do n = 1, ntr + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dellae(i,indx,n) = eta(i,indx-1) * + & (ecko(i,indx-1,n) - ctro(i,indx-1,n)) * g / dp + endif + enddo + enddo +! +! compute convective turn-over time +! +!> - Following Bechtold et al. (2008) \cite bechtold_et_al_2008, calculate the convective turnover time using the mean updraft velocity (wc) and the cloud depth. It is also proportional to the grid size (gdx). + do i= 1, im + if(cnvflg(i)) then + tem = zi(i,ktcon1(i)) - zi(i,kbcon1(i)) + dtconv(i) = tem / wc(i) + tfac = 1. + gdx(i) / 75000. + dtconv(i) = tfac * dtconv(i) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = max(dtconv(i),dt2) + dtconv(i) = min(dtconv(i),dtmax) + endif + enddo +! +!> - Calculate advective time scale (tauadv) using a mean cloud layer wind speed. + do i= 1, im + if(cnvflg(i)) then + sumx(i) = 0. + umean(i) = 0. + endif + enddo + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k >= kbcon1(i) .and. k < ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = sqrt(u1(i,k)*u1(i,k)+v1(i,k)*v1(i,k)) + umean(i) = umean(i) + tem * dz + sumx(i) = sumx(i) + dz + endif + endif + enddo + enddo + do i= 1, im + if(cnvflg(i)) then + umean(i) = umean(i) / sumx(i) + umean(i) = max(umean(i), 1.) + tauadv(i) = gdx(i) / umean(i) + endif + enddo +c +c compute cloud base mass flux as a function of the mean +c updraft velcoity +c +!> - From Han et al.'s (2017) \cite han_et_al_2017 equation 6, calculate cloud base mass flux as a function of the mean updraft velcoity. +!! As discussed in Han et al. (2017) \cite han_et_al_2017 , when dtconv is larger than tauadv, the convective mixing is not fully conducted before the cumulus cloud is advected out of the grid cell. In this case, therefore, the cloud base mass flux is further reduced in proportion to the ratio of tauadv to dtconv. + do i= 1, im + if(cnvflg(i)) then + k = kbcon(i) + rho = po(i,k)*100. / (rd*to(i,k)) + tfac = tauadv(i) / dtconv(i) + tfac = min(tfac, 1.) + xmb(i) = tfac*betaw*rho*wc(i) + endif + enddo +! +!> - For scale-aware parameterization, the updraft fraction (sigmagfm) is first computed as a function of the lateral entrainment rate at cloud base (see Han et al.'s (2017) \cite han_et_al_2017 equation 4 and 5), following the study by Grell and Freitas (2014) \cite grell_and_freitus_2014. + do i = 1, im + if(cnvflg(i)) then + tem = min(max(xlamue(i,kbcon(i)), 2.e-4), 6.e-4) + tem = 0.2 / tem + tem1 = 3.14 * tem * tem + sigmagfm(i) = tem1 / garea(i) + sigmagfm(i) = max(sigmagfm(i), 0.001) + sigmagfm(i) = min(sigmagfm(i), 0.999) + endif + enddo +! +!> - Then, calculate the reduction factor (scaldfunc) of the vertical convective eddy transport of mass flux as a function of updraft fraction from the studies by Arakawa and Wu (2013) \cite arakawa_and_wu_2013 (also see Han et al.'s (2017) \cite han_et_al_2017 equation 1 and 2). The final cloud base mass flux with scale-aware parameterization is obtained from the mass flux when sigmagfm << 1, multiplied by the reduction factor (Han et al.'s (2017) \cite han_et_al_2017 equation 2). + do i = 1, im + if(cnvflg(i)) then + if (gdx(i) < dxcrt) then + scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) + scaldfunc(i) = max(min(scaldfunc(i), 1.0), 0.) + else + scaldfunc(i) = 1.0 + endif + xmb(i) = xmb(i) * scaldfunc(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo + +c +c transport aerosols if present +c + if (do_aerosols) + & call samfshalcnv_aerosols(im, ix, km, itc, ntc, ntr, delt, +! & xlamde, xlamdd, cnvflg, jmin, kb, kmax, kbcon, ktcon, fscav, + & cnvflg, kb, kmax, kbcon, ktcon, fscav, +! & edto, xlamd, xmb, c0t, eta, etad, zi, xlamue, xlamud, delp, + & xmb, c0t, eta, zi, xlamue, xlamud, delp, + & qtr, qaero) + +!> ## For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!! - Recalculate saturation specific humidity. +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +!> - Calculate the temperature tendency from the moist static energy and specific humidity tendencies. +!> - Update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux-normalized tendencies by the cloud base mass flux. +!> - Accumulate column-integrated tendencies. + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do n = 1, ntr + do i = 1, im + delebar(i,n) = 0. + enddo + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo + do n = 1, ntr + kk = n+2 + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k <= kmax(i)) then + if(k <= ktcon(i)) then + ctr(i,k,n) = ctr(i,k,n)+dellae(i,k,n)*xmb(i)*dt2 + delebar(i,n)=delebar(i,n)+dellae(i,k,n)*xmb(i)*dp/g + qtr(i,k,kk) = ctr(i,k,n) + endif + endif + enddo + enddo + enddo +! +!> - Recalculate saturation specific humidity using the updated temperature. + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k > kb(i) .and. k <= ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c +!> - Add up column-integrated convective precipitation by multiplying the normalized value by the cloud base mass flux. + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k < ktcon(i) .and. k > kb(i)) then + rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo +c +c evaporating rain +c +!> - Determine the evaporation of the convective precipitation and update the integrated convective precipitation. +!> - Update state temperature and moisture to account for evaporation of convective precipitation. +!> - Update column-integrated tendencies to account for evaporation of convective precipitation. + do k = km, 1, -1 + do i = 1, im + if (k <= kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i)) then + if(k < ktcon(i) .and. k > kb(i)) then + rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + if(flg(i) .and. k < ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i) > 0. .and. qcond(i) < 0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i) > 0. .and. qcond(i) < 0. .and. + & delq2(i) > rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i) > 0. .and. qevap(i) > 0.) then + tem = .001 * dp / g + tem1 = qevap(i) * tem + if(tem1 > rn(i)) then + qevap(i) = rn(i) / tem + rn(i) = 0. + else + rn(i) = rn(i) - tem1 + endif + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me == 31 .and. cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' shallow delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +! do n = 1, ntr +! do i = 1, im +! if(me == 31 .and. cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' tracer delebar = ',delebar(i,n) +! endif +! enddo +! enddo +cj + do i = 1, im + if(cnvflg(i)) then + if(rn(i) < 0. .or. .not.flg(i)) rn(i) = 0. + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 2 + endif + enddo +c +c convective cloud water +c +!> - Calculate shallow convective cloud water. + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + +c +c convective cloud cover +c +!> - Calculate convective cloud cover, which is used when pdf-based cloud fraction is used (i.e., pdfcld=.true.). + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if (k >= kbcon(i) .and. k < ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.2) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo +c +c cloud water +c +!> - Separate detrained cloud water into liquid and ice species as a function of temperature only. + if (ncloud > 0) then +! + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then +! if (k > kb(i) .and. k <= ktcon(i)) then + if (k >= kbcon(i) .and. k <= ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (qtr(i,k,2) > -999.0) then + qtr(i,k,1) = qtr(i,k,1) + tem * tem1 ! ice + qtr(i,k,2) = qtr(i,k,2) + tem *(1.0-tem1) ! water + else + qtr(i,k,1) = qtr(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +!> - Store aerosol concentrations if present + if (do_aerosols) then + do n = 1, ntc + kk = n + itc - 1 + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. rn(i) > 0.) then + if (k <= kmax(i)) qtr(i,k,kk) = qaero(i,k,n) + endif + enddo + enddo + enddo + endif +! +! hchuang code change +! +!> - Calculate and retain the updraft mass flux for dust transport by cumulus convection. +! +!> - Calculate the updraft convective mass flux. + do k = 1, km + do i = 1, im + if(cnvflg(i)) then + if(k >= kb(i) .and. k < ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!> - save the updraft convective mass flux at cloud top. + do i = 1, im + if(cnvflg(i)) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo +! +! include TKE contribution from shallow convection +! + if (ntk > 0) then +! + do k = 2, km1 + do i = 1, im + if(cnvflg(i)) then + if(k > kb(i) .and. k < ktop(i)) then + tem = 0.5 * (eta(i,k-1) + eta(i,k)) * xmb(i) + tem1 = pfld(i,k) * 100. / (rd * t1(i,k)) + sigmagfm(i) = max(sigmagfm(i), betaw) + ptem = tem / (sigmagfm(i) * tem1) + qtr(i,k,ntk)=qtr(i,k,ntk)+0.5*sigmagfm(i)*ptem*ptem + endif + endif + enddo + enddo +! + endif +!! + return + end + diff --git a/gsmphys/sascnv.f b/gsmphys/sascnv.f new file mode 100644 index 00000000..a35d12e3 --- /dev/null +++ b/gsmphys/sascnv.f @@ -0,0 +1,1771 @@ + subroutine sascnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, +! subroutine sascnv(im,ix,km,jcap,delt,del,prsl,phil,ql, + & q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kuo,islimsk, + & dot,xkt2,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc) +! hchuang code change [r1l] +! & dot,xkt2,ncloud) +! +! 10/14/2008 ho-chun huang the cloudmass flux fields was added by jongil +! +! for cloud water version +! parameter(ncloud=0) +! subroutine sascnv(km,jcap,delt,del,sl,slk,ps,ql, +! & q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kuo,slimsk, +! & dot,xkt2,ncloud) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c + &, cvap => con_cvap, cliq => con_cliq + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! +! + integer im, ix, km, jcap, ncloud, + & kbot(im), ktop(im), kuo(im) + real(kind=kind_phys) delt + real(kind=kind_phys) psp(im), delp(ix,km), prslp(ix,km) + real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), +! real(kind=kind_phys) del(ix,km), prsl(ix,km), + & ql(ix,km,2),q1(ix,km), t1(ix,km), + & u1(ix,km), v1(ix,km), + & cldwrk(im), rn(im), + & dot(ix,km), xkt2(im), phil(ix,km) + &, cnvw(ix,km),cnvc(ix,km) +! hchuang code change [+1l] mass flux output + &, ud_mf(im,km),dd_mf(im,km),dt_mf(im,km) +! + integer islimsk(im) + integer i, indx, jmn, k, knumb, latd, lond, km1 +! + real(kind=kind_phys) adw, alpha, alphal, alphas, + & aup, beta, betal, betas, + & c0, dellat, delta, + & desdt, deta, detad, dg, + & dh, dhh, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, dv1, + & dv1q, dv2, dv2q, dv1u, + & dv1v, dv2u, dv2v, dv3u, + & dv3v, dv3, dv3q, dvq1, + & dz, dz1, e1, edtmax, + & edtmaxl, edtmaxs, el2orc, elocp, + & es, etah, + & evef, evfact, evfactl, fact1, + & fact2, factor, fjcap, fkm, + & fuv, g, gamma, onemf, + & onemfu, pdetrn, pdpdwn, pprime, + & qc, qlk, qrch, qs, + & rain, rfact, shear, tem1, + & tem2, val, val1, + & val2, w1, w1l, w1s, + & w2, w2l, w2s, w3, + & w3l, w3s, w4, w4l, + & w4s, xdby, xpw, xpwd, + & xqc, xqrch, xlambu, mbdt, + & tem +! +! + integer jmin(im), kb(im), kbcon(im), kbdtr(im), + & kt2(im), ktcon(im), lmin(im), + & kbm(im), kbmax(im), kmax(im) +! + real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & edto(im), edtx(im), fld(im), + & hcdo(im), hkbo(im), hmax(im), + & hmin(im), hsbar(im), ucdo(im), + & ukbo(im), vcdo(im), vkbo(im), + & pbcdif(im), pdot(im), po(im,km), + & pwavo(im), pwevo(im), +! & psfc(im), pwavo(im), pwevo(im), + & qcdo(im), qcond(im), qevap(im), + & qkbo(im), rntot(im), vshear(im), + & xaa0(im), xhcd(im), xhkb(im), + & xk(im), xlamb(im), xlamd(im), + & xmb(im), xmbmax(im), xpwav(im), + & xpwev(im), xqcd(im), xqkb(im) +cc +c physical parameters + parameter(g=grav) + parameter(elocp=hvap/cp, + & el2orc=hvap*hvap/(rv*cp)) + parameter(c0=.002,delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) +! real terr +! parameter(terr=0.) +c local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km) +c cloud water + real(kind=kind_phys) qlko_ktcon(im), dellal(im), tvo(im,km), + & dbyo(im,km), zo(im,km), sumz(im,km), + & sumh(im,km), heo(im,km), heso(im,km), + & qrcd(im,km), dellah(im,km), dellaq(im,km), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & eta(im,km), etau(im,km), etad(im,km), + & qrcdo(im,km), pwo(im,km), pwdo(im,km), + & rhbar(im), tx1(im), cnvwt(im,km) +! + logical totflg, cnvflg(im), dwnflg(im), dwnflg2(im), flg(im) +! + real(kind=kind_phys) pcrit(15), acritt(15), acrit(15) +cmy save pcrit, acritt + data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., + & 350.,300.,250.,200.,150./ + data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, + & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ +c gdas derived acrit +c data acritt/.203,.515,.521,.566,.625,.665,.659,.688, +c & .743,.813,.886,.947,1.138,1.377,1.896/ +cc + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) ! from lord(1978) +! +! parameter (tf=258.16, tcr=273.16, tcrf=1.0/(tcr-tf)) +! + real(kind=kind_phys), parameter :: cons_0=0.0 +c +c-------------------------------------------------------------------- +! +!************************************************************************ +! convert input pa terms to cb terms -- moorthi + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! + km1 = km - 1 +c initialize arrays +c + do i=1,im + rn(i)=0. + kbot(i)=km+1 + ktop(i)=0 +! kuo(i)=0 + cnvflg(i) = .true. + dtconv(i) = 3600. + cldwrk(i) = 0. + pdot(i) = 0. + kt2(i) = 0 + qlko_ktcon(i) = 0. + dellal(i) = 0. + enddo + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +! hchuang code change [+7l] + do k = 1, km + do i=1,im + ud_mf(i,k) = 0. + dd_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +!! + do k = 1, 15 + acrit(k) = acritt(k) * (975. - pcrit(k)) + enddo + dt2 = delt + val = 1200. + dtmin = max(dt2, val ) + val = 3600. + dtmax = max(dt2, val ) +c model tunable parameters are all here + mbdt = 10. + edtmaxl = .3 + edtmaxs = .3 + alphal = .5 + alphas = .5 + betal = .15 + betas = .15 + betal = .05 + betas = .05 +c evef = 0.07 + evfact = 0.3 + evfactl = 0.3 + pdpdwn = 0. + pdetrn = 200. + xlambu = 1.e-4 + fjcap = (float(jcap) / 126.) ** 2 + val = 1. + fjcap = max(fjcap,val) + fkm = (float(km) / 28.) ** 2 + fkm = max(fkm,val) + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +ccccc if(im.eq.384) then + latd = 92 + lond = 189 +ccccc elseif(im.eq.768) then +ccccc latd = 80 +ccccc else +ccccc latd = 0 +ccccc endif +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c + do i=1,im + kbmax(i) = km + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1 + if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i) = k + 1 + enddo + enddo + do i=1,im + kmax(i) = min(km,kmax(i)) + kbmax(i) = min(kbmax(i),kmax(i)) + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c convert surface pressure to mb from cb +c +!! + do k = 1, km + do i=1,im + if (k .le. kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + pwo(i,k) = 0. + pwdo(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) + dbyo(i,k) = 0. + sumz(i,k) = 0. + sumh(i,k) = 0. + cnvwt(i,k)= 0. + endif + enddo + enddo +c +c column variables +c p is pressure of the layer (mb) +c t is temperature at t-dt (k)..tn +c q is mixing ratio at t-dt (kg/kg)..qn +c to is temperature at t+dt (k)... this is after advection and turbulan +c qo is mixing ratio at t+dt (kg/kg)..q1 +c + do k = 1, km + do i=1,im + if (k .le. kmax(i)) then +!jfe qeso(i,k) = 10. * fpvs(t1(i,k)) +! + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa +! + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +c qo(i,k) = min(qo(i,k),qeso(i,k)) + tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c hydrostatic height assume zero terr +c + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo +c compute moist static energy + do k = 1, km + do i=1,im + if (k .le. kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy +c this is the level where updraft starts +c + do i=1,im + hmax(i) = heo(i,1) + kb(i) = 1 + enddo +!! + do k = 2, km + do i=1,im + if (k .le. kbm(i)) then + if(heo(i,k).gt.hmax(i).and.cnvflg(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c do k = 1, kmax - 1 +c tol(k) = .5 * (to(i,k) + to(i,k+1)) +c qol(k) = .5 * (qo(i,k) + qo(i,k+1)) +c qesol(i,k) = .5 * (qeso(i,k) + qeso(i,k+1)) +c heol(i,k) = .5 * (heo(i,k) + heo(i,k+1)) +c hesol(i,k) = .5 * (heso(i,k) + heso(i,k+1)) +c enddo + do k = 1, km1 + do i=1,im + if (k .le. kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) +!jfe es = 10. * fpvs(to(i,k+1)) +! + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa +! + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! + do k = 1, km1 + do i=1,im + if (k .le. kmax(i)-1) then +!jfe qeso(i,k) = 10. * fpvs(to(i,k)) +! + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa +! + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +c qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo +c k = kmax +c heo(i,k) = heo(i,k) +c hesol(k) = heso(i,k) +c if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +c print *, ' heo =' +c print 6001, (heo(i,k),k=1,kmax) +c print *, ' heso =' +c print 6001, (heso(i,k),k=1,kmax) +c print *, ' to =' +c print 6002, (to(i,k)-273.16,k=1,kmax) +c print *, ' qo =' +c print 6003, (qo(i,k),k=1,kmax) +c print *, ' qso =' +c print 6003, (qeso(i,k),k=1,kmax) +c endif +c +c look for convective cloud base as the level of free convection +c + do i=1,im + if(cnvflg(i)) then + indx = kb(i) + hkbo(i) = heo(i,indx) + qkbo(i) = qo(i,indx) + ukbo(i) = uo(i,indx) + vkbo(i) = vo(i,indx) + endif + flg(i) = cnvflg(i) + kbcon(i) = kmax(i) + enddo +!! + do k = 1, km + do i=1,im + if (k .le. kbmax(i)) then + if(flg(i).and.k.gt.kb(i)) then + hsbar(i) = heso(i,k) + if(hkbo(i).gt.hsbar(i)) then + flg(i) = .false. + kbcon(i) = k + endif + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + pbcdif(i) = -pfld(i,kbcon(i)) + pfld(i,kb(i)) +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! now dot is in pa/s + if(pbcdif(i).gt.150.) cnvflg(i) = .false. + if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +c found lfc, can define rest of variables + 6001 format(2x,-2p10f12.2) + 6002 format(2x,10f12.2) + 6003 format(2x,3p10f12.2) +c +c determine entrainment rate between kb and kbcon +c + do i = 1, im + alpha = alphas + if(islimsk(i) == 1) alpha = alphal + if(cnvflg(i)) then + if(kb(i).eq.1) then + dz = .5 * (zo(i,kbcon(i)) + zo(i,kbcon(i)-1)) - zo(i,1) + else + dz = .5 * (zo(i,kbcon(i)) + zo(i,kbcon(i)-1)) + & - .5 * (zo(i,kb(i)) + zo(i,kb(i)-1)) + endif + if(kbcon(i).ne.kb(i)) then + xlamb(i) = - log(alpha) / dz + else + xlamb(i) = 0. + endif + endif + enddo +c determine updraft mass flux + do k = 1, km + do i = 1, im + if (k .le. kmax(i) .and. cnvflg(i)) then + eta(i,k) = 1. + etau(i,k) = 1. + endif + enddo + enddo + do k = km1, 2, -1 + do i = 1, im + if (k .le. kbmax(i)) then + if(cnvflg(i).and.k.lt.kbcon(i).and.k.ge.kb(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k-1)) + eta(i,k) = eta(i,k+1) * exp(-xlamb(i) * dz) + etau(i,k) = eta(i,k) + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i).and.kb(i).eq.1.and.kbcon(i).gt.1) then + dz = .5 * (zo(i,2) - zo(i,1)) + eta(i,1) = eta(i,2) * exp(-xlamb(i) * dz) + etau(i,1) = eta(i,1) + endif + enddo +c +c work up updraft cloud properties +c + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = hkbo(i) + qcko(i,indx) = qkbo(i) + ucko(i,indx) = ukbo(i) + vcko(i,indx) = vkbo(i) + pwavo(i) = 0. + endif + enddo +c +c cloud property below cloud base is modified by the entrainment proces +c + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(cnvflg(i).and.k.gt.kb(i).and.k.le.kbcon(i)) then + factor = eta(i,k-1) / eta(i,k) + onemf = 1. - factor + hcko(i,k) = factor * hcko(i,k-1) + onemf * + & .5 * (heo(i,k) + heo(i,k+1)) + ucko(i,k) = factor * ucko(i,k-1) + onemf * + & .5 * (uo(i,k) + uo(i,k+1)) + vcko(i,k) = factor * vcko(i,k-1) + onemf * + & .5 * (vo(i,k) + vo(i,k+1)) + dbyo(i,k) = hcko(i,k) - heso(i,k) + endif + if(cnvflg(i).and.k.gt.kbcon(i)) then + hcko(i,k) = hcko(i,k-1) + ucko(i,k) = ucko(i,k-1) + vcko(i,k) = vcko(i,k-1) + dbyo(i,k) = hcko(i,k) - heso(i,k) + endif + endif + enddo + enddo +c determine cloud top + do i = 1, im + flg(i) = cnvflg(i) + ktcon(i) = 1 + enddo +c do k = 2, kmax +c kk = kmax - k + 1 +c if(dbyo(i,kk).ge.0..and.flg(i).and.kk.gt.kbcon(i)) then +c ktcon(i) = kk + 1 +c flg(i) = .false. +c endif +c enddo + do k = 2, km + do i = 1, im + if (k .le. kmax(i)) then + if(dbyo(i,k).lt.0..and.flg(i).and.k.gt.kbcon(i)) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i).and.(pfld(i,kbcon(i)) - pfld(i,ktcon(i))).lt.150.) + & cnvflg(i) = .false. + enddo + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +c +c search for downdraft originating level above theta-e minimum +c + do i = 1, im + hmin(i) = heo(i,kbcon(i)) + lmin(i) = kbmax(i) + jmin(i) = kbmax(i) + enddo + do i = 1, im + do k = kbcon(i), kbmax(i) + if(heo(i,k).lt.hmin(i).and.cnvflg(i)) then + lmin(i) = k + 1 + hmin(i) = heo(i,k) + endif + enddo + enddo +c +c make sure that jmin(i) is within the cloud +c + do i = 1, im + if(cnvflg(i)) then + jmin(i) = min(lmin(i),ktcon(i)-1) + xmbmax(i) = .1 + jmin(i) = max(jmin(i),kbcon(i)+1) + endif + enddo +c +c entraining cloud +c + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(cnvflg(i).and.k.gt.jmin(i).and.k.le.ktcon(i)) then + sumz(i,k) = sumz(i,k-1) + .5 * (zo(i,k+1) - zo(i,k-1)) + sumh(i,k) = sumh(i,k-1) + .5 * (zo(i,k+1) - zo(i,k-1)) + & * heo(i,k) + endif + endif + enddo + enddo +!! + do i = 1, im + if(cnvflg(i)) then +c call random_number(xkt2) +c call srand(fhour) +c xkt2(i) = rand() + kt2(i) = nint(xkt2(i)*float(ktcon(i)-jmin(i))-.5)+jmin(i)+1 +! kt2(i) = nint(sqrt(xkt2(i))*float(ktcon(i)-jmin(i))-.5) + jmin(i) + 1 +c kt2(i) = nint(ranf() *float(ktcon(i)-jmin(i))-.5) + jmin(i) + 1 + tem1 = (hcko(i,jmin(i)) - heso(i,kt2(i))) + tem2 = (sumz(i,kt2(i)) * heso(i,kt2(i)) - sumh(i,kt2(i))) + if (abs(tem2) .gt. 0.000001) then + xlamb(i) = tem1 / tem2 + else + cnvflg(i) = .false. + endif +! xlamb(i) = (hcko(i,jmin(i)) - heso(i,kt2(i))) +! & / (sumz(i,kt2(i)) * heso(i,kt2(i)) - sumh(i,kt2(i))) + xlamb(i) = max(xlamb(i),cons_0) + xlamb(i) = min(xlamb(i),2.3/sumz(i,kt2(i))) + endif + enddo +!! + do i = 1, im + dwnflg(i) = cnvflg(i) + dwnflg2(i) = cnvflg(i) + if(cnvflg(i)) then + if(kt2(i).ge.ktcon(i)) dwnflg(i) = .false. + if(xlamb(i).le.1.e-30.or.hcko(i,jmin(i))-heso(i,kt2(i)).le.1.e-30) + & dwnflg(i) = .false. + do k = jmin(i), kt2(i) + if(dwnflg(i).and.heo(i,k).gt.heso(i,kt2(i))) dwnflg(i)=.false. + enddo +c if(cnvflg(i).and.(pfld(kbcon(i))-pfld(ktcon(i))).gt.pdetrn) +c & dwnflg(i)=.false. + if(cnvflg(i).and.(pfld(i,kbcon(i))-pfld(i,ktcon(i))).lt.pdpdwn) + & dwnflg2(i)=.false. + endif + enddo +!! + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(dwnflg(i).and.k.gt.jmin(i).and.k.le.kt2(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k-1)) +c eta(i,k) = eta(i,k-1) * exp( xlamb(i) * dz) +c to simplify matter, we will take the linear approach here +c + eta(i,k) = eta(i,k-1) * (1. + xlamb(i) * dz) + etau(i,k) = etau(i,k-1) * (1. + (xlamb(i)+xlambu) * dz) + endif + endif + enddo + enddo +!! + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then +c if(.not.dwnflg(i).and.k.gt.jmin(i).and.k.le.kt2(i)) then + if(.not.dwnflg(i).and.k.gt.jmin(i).and.k.le.ktcon(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k-1)) + etau(i,k) = etau(i,k-1) * (1. + xlambu * dz) + endif + endif + enddo + enddo +c if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +c print *, ' lmin(i), kt2(i)=', lmin(i), kt2(i) +c print *, ' kbot, ktop, jmin(i) =', kbcon(i), ktcon(i), jmin(i) +c endif +c if(lat.eq.latd.and.lon.eq.lond) then +c print *, ' xlamb =', xlamb +c print *, ' eta =', (eta(k),k=1,kt2(i)) +c print *, ' etau =', (etau(i,k),k=1,kt2(i)) +c print *, ' hcko =', (hcko(i,k),k=1,kt2(i)) +c print *, ' sumz =', (sumz(i,k),k=1,kt2(i)) +c print *, ' sumh =', (sumh(i,k),k=1,kt2(i)) +c endif + do i = 1, im + if(dwnflg(i)) then + ktcon(i) = kt2(i) + endif + enddo +c +c cloud property above cloud base is modified by the detrainment process +c + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then +cjfe + if(cnvflg(i).and.k.gt.kbcon(i).and.k.le.ktcon(i)) then +cjfe if(k.gt.kbcon(i).and.k.le.ktcon(i)) then + factor = eta(i,k-1) / eta(i,k) + onemf = 1. - factor + fuv = etau(i,k-1) / etau(i,k) + onemfu = 1. - fuv + hcko(i,k) = factor * hcko(i,k-1) + onemf * + & .5 * (heo(i,k) + heo(i,k+1)) + ucko(i,k) = fuv * ucko(i,k-1) + onemfu * + & .5 * (uo(i,k) + uo(i,k+1)) + vcko(i,k) = fuv * vcko(i,k-1) + onemfu * + & .5 * (vo(i,k) + vo(i,k+1)) + dbyo(i,k) = hcko(i,k) - heso(i,k) + endif + endif + enddo + enddo +c if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +c print *, ' ucko=', (ucko(i,k),k=kbcon(i)+1,ktcon(i)) +c print *, ' uenv=', (.5*(uo(i,k)+uo(i,k-1)),k=kbcon(i)+1,ktcon(i)) +c endif + do i = 1, im + if(cnvflg(i).and.dwnflg2(i).and.jmin(i).le.kbcon(i)) + & then + cnvflg(i) = .false. + dwnflg(i) = .false. + dwnflg2(i) = .false. + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c compute cloud moisture property and precipitation +c + do i = 1, im + aa1(i) = 0. + rhbar(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.k.gt.kb(i).and.k.lt.ktcon(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k-1)) + dz1 = (zo(i,k) - zo(i,k-1)) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + factor = eta(i,k-1) / eta(i,k) + onemf = 1. - factor + qcko(i,k) = factor * qcko(i,k-1) + onemf * + & .5 * (qo(i,k) + qo(i,k+1)) + dq = eta(i,k) * qcko(i,k) - eta(i,k) * qrch + rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c below lfc check if there is excess moisture to release latent heat +c + if(dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp =1000. * del(i,k) + qlk = dq / (eta(i,k) + etah * c0 * dz) + aa1(i) = aa1(i) - dz1 * g * qlk + qc = qlk + qrch + pwo(i,k) = etah * c0 * dz * qlk + qcko(i,k) = qc + pwavo(i) = pwavo(i) + pwo(i,k) + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo + do i = 1, im + rhbar(i) = rhbar(i) / float(ktcon(i) - kb(i) - 1) + enddo +c +c this section is ready for cloud water +c + if(ncloud.gt.0) then +c +c compute liquid and vapor separation at cloud top +c + do i = 1, im + k = ktcon(i) + if(cnvflg(i)) then + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k-1) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq.gt.0.) then + qlko_ktcon(i) = dq + qcko(i,k-1) = qrch + endif + endif + enddo + endif +c +c calculate cloud work function at t+dt +c + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.k.gt.kbcon(i).and.k.le.ktcon(i)) then + dz1 = zo(i,k) - zo(i,k-1) + gamma = el2orc * qeso(i,k-1) / (to(i,k-1)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k-1) / hvap + aa1(i) = aa1(i) + + & dz1 * (g / (cp * to(i,k-1))) + & * dbyo(i,k-1) / (1. + gamma) + & * rfact + val = 0. + aa1(i)=aa1(i)+ + & dz1 * g * delta * + & max(val,(qeso(i,k-1) - qo(i,k-1))) + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i).and.aa1(i).le.0.) dwnflg(i) = .false. + if(cnvflg(i).and.aa1(i).le.0.) dwnflg2(i) = .false. + if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +ccccc print *, ' aa1(i) before dwndrft =', aa1(i) +ccccc endif +c +c------- downdraft calculations +c +c +c--- determine downdraft strength in terms of windshear +c + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(k.ge.kb(i).and.k.le.ktcon(i).and.cnvflg(i)) then + shear = sqrt((uo(i,k+1)-uo(i,k)) ** 2 + & + (vo(i,k+1)-vo(i,k)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + edt(i) = 0. + if(cnvflg(i)) then + knumb = ktcon(i) - kb(i) + 1 + knumb = max(knumb,1) + vshear(i) = 1.e3 * vshear(i) / (zo(i,ktcon(i))-zo(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + edto(i)=edt(i) + edtx(i)=edt(i) + endif + enddo +c determine detrainment rate between 1 and kbdtr + do i = 1, im + kbdtr(i) = kbcon(i) + beta = betas + if(islimsk(i) == 1) beta = betal + if(cnvflg(i)) then + kbdtr(i) = kbcon(i) + kbdtr(i) = max(kbdtr(i),1) + xlamd(i) = 0. + if(kbdtr(i).gt.1) then + dz = .5 * zo(i,kbdtr(i)) + .5 * zo(i,kbdtr(i)-1) + & - zo(i,1) + xlamd(i) = log(beta) / dz + endif + endif + enddo +c determine downdraft mass flux + do k = 1, km + do i = 1, im + if(k .le. kmax(i)) then + if(cnvflg(i)) then + etad(i,k) = 1. + endif + qrcdo(i,k) = 0. + endif + enddo + enddo + do k = km1, 2, -1 + do i = 1, im + if (k .le. kbmax(i)) then + if(cnvflg(i).and.k.lt.kbdtr(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k-1)) + etad(i,k) = etad(i,k+1) * exp(xlamd(i) * dz) + endif + endif + enddo + enddo + k = 1 + do i = 1, im + if(cnvflg(i).and.kbdtr(i).gt.1) then + dz = .5 * (zo(i,2) - zo(i,1)) + etad(i,k) = etad(i,k+1) * exp(xlamd(i) * dz) + endif + enddo +c +c--- downdraft moisture properties +c + do i = 1, im + pwevo(i) = 0. + flg(i) = cnvflg(i) + enddo + do i = 1, im + if(cnvflg(i)) then + jmn = jmin(i) + hcdo(i) = heo(i,jmn) + qcdo(i) = qo(i,jmn) + qrcdo(i,jmn) = qeso(i,jmn) + ucdo(i) = uo(i,jmn) + vcdo(i) = vo(i,jmn) + endif + enddo + do k = km1, 1, -1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(cnvflg(i).and.k.lt.jmin(i)) then + dq = qeso(i,k) + dt = to(i,k) + gamma = el2orc * dq / dt**2 + dh = hcdo(i) - heso(i,k) + qrcdo(i,k) = dq+(1./hvap)*(gamma/(1.+gamma))*dh + detad = etad(i,k+1) - etad(i,k) + pwdo(i,k) = etad(i,k+1) * qcdo(i) - + & etad(i,k) * qrcdo(i,k) + pwdo(i,k) = pwdo(i,k) - detad * + & .5 * (qrcdo(i,k) + qrcdo(i,k+1)) + qcdo(i) = qrcdo(i,k) + pwevo(i) = pwevo(i) + pwdo(i,k) + endif + endif + enddo + enddo +c if(lat.eq.latd.and.lon.eq.lond.and.dwnflg(i)) then +c print *, ' pwavo(i), pwevo(i) =', pwavo(i), pwevo(i) +c endif +c +c--- final downdraft strength dependent on precip +c--- efficiency (edt), normalized condensate (pwav), and +c--- evaporate (pwev) +c + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(dwnflg2(i)) then + if(pwevo(i).lt.0.) then + edto(i) = -edto(i) * pwavo(i) / pwevo(i) + edto(i) = min(edto(i),edtmax) + else + edto(i) = 0. + endif + else + edto(i) = 0. + endif + enddo +c +c +c--- downdraft cloudwork functions +c +c + do k = km1, 1, -1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(dwnflg2(i).and.k.lt.jmin(i)) then + gamma = el2orc * qeso(i,k+1) / to(i,k+1)**2 + dhh=hcdo(i) + dt=to(i,k+1) + dg=gamma + dh=heso(i,k+1) + dz=-1.*(zo(i,k+1)-zo(i,k)) + aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. + aa1(i)=aa1(i)+edto(i)* + & dz*g*delta*max(val,(qeso(i,k+1)-qo(i,k+1))) + endif + endif + enddo + enddo +ccccc if(lat.eq.latd.and.lon.eq.lond.and.dwnflg2(i)) then +ccccc print *, ' aa1(i) after dwndrft =', aa1(i) +ccccc endif + do i = 1, im + if(aa1(i).le.0.) cnvflg(i) = .false. + if(aa1(i).le.0.) dwnflg(i) = .false. + if(aa1(i).le.0.) dwnflg2(i) = .false. + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c + do k = 1, km + do i = 1, im + if(k .le. kmax(i) .and. cnvflg(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + dp = 1000. * del(i,1) + dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i) + & - heo(i,1)) * g / dp + dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i) + & - qo(i,1)) * g / dp + dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i) + & - uo(i,1)) * g / dp + dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i) + & - vo(i,1)) * g / dp + endif + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(cnvflg(i).and.k.lt.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.gt.jmin(i)) adw = 0. + dv1= heo(i,k) + dv2 = .5 * (heo(i,k) + heo(i,k+1)) + dv3= heo(i,k-1) + dv1q= qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k+1)) + dv3q= qo(i,k-1) + dv1u= uo(i,k) + dv2u = .5 * (uo(i,k) + uo(i,k+1)) + dv3u= uo(i,k-1) + dv1v= vo(i,k) + dv2v = .5 * (vo(i,k) + vo(i,k+1)) + dv3v= vo(i,k-1) + dp = 1000. * del(i,k) + dz = .5 * (zo(i,k+1) - zo(i,k-1)) + deta = eta(i,k) - eta(i,k-1) + detad = etad(i,k) - etad(i,k-1) + dellah(i,k) = dellah(i,k) + + & ((aup * eta(i,k) - adw * edto(i) * etad(i,k)) * dv1 + & - (aup * eta(i,k-1) - adw * edto(i) * etad(i,k-1))* dv3 + & - aup * deta * dv2 + & + adw * edto(i) * detad * hcdo(i)) * g / dp + dellaq(i,k) = dellaq(i,k) + + & ((aup * eta(i,k) - adw * edto(i) * etad(i,k)) * dv1q + & - (aup * eta(i,k-1) - adw * edto(i) * etad(i,k-1))* dv3q + & - aup * deta * dv2q + & +adw*edto(i)*detad*.5*(qrcdo(i,k)+qrcdo(i,k-1))) * g / dp + dellau(i,k) = dellau(i,k) + + & ((aup * eta(i,k) - adw * edto(i) * etad(i,k)) * dv1u + & - (aup * eta(i,k-1) - adw * edto(i) * etad(i,k-1))* dv3u + & - aup * deta * dv2u + & + adw * edto(i) * detad * ucdo(i) + & ) * g / dp + dellav(i,k) = dellav(i,k) + + & ((aup * eta(i,k) - adw * edto(i) * etad(i,k)) * dv1v + & - (aup * eta(i,k-1) - adw * edto(i) * etad(i,k-1))* dv3v + & - aup * deta * dv2v + & + adw * edto(i) * detad * vcdo(i) + & ) * g / dp + endif + endif + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1 = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1) * g / dp + dvq1 = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dvq1) * g / dp + dv1u = uo(i,indx-1) + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - dv1u) * g / dp + dv1v = vo(i,indx-1) + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - dv1v) * g / dp +c +c cloud water +c + dellal(i) = eta(i,indx-1) * qlko_ktcon(i) * g / dp + endif + enddo +c +c------- final changed variable per unit mass flux +c + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.k.gt.ktcon(i)) then + qo(i,k) = q1(i,k) + to(i,k) = t1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) + endif + if(cnvflg(i).and.k.le.ktcon(i)) then + qo(i,k) = dellaq(i,k) * mbdt + q1(i,k) + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + to(i,k) = dellat * mbdt + t1(i,k) + val = 1.e-10 + qo(i,k) = max(qo(i,k), val ) + endif + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- the above changed environment is now used to calulate the +c--- effect the arbitrary cloud (with unit mass flux) +c--- would have on the stability, +c--- which then is used to calculate the real mass flux, +c--- necessary to keep this change in balance with the large-scale +c--- destabilization. +c +c--- environmental conditions again, first heights +c + do k = 1, km + do i = 1, im + if(k .le. kmax(i) .and. cnvflg(i)) then +!jfe qeso(i,k) = 10. * fpvs(to(i,k)) +! + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa +! + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + xaa0(i) = 0. + xpwav(i) = 0. + endif + enddo +c +c hydrostatic height assume zero terr +c +! do i = 1, im +! if(cnvflg(i)) then +! dlnsig = log(prsl(i,1)/ps(i)) +! zo(i,1) = terr - dlnsig * rd / g * tvo(i,1) +! endif +! enddo +! do k = 2, km +! do i = 1, im +! if(k .le. kmax(i) .and. cnvflg(i)) then +! dlnsig = log(prsl(i,k) / prsl(i,k-1)) +! zo(i,k) = zo(i,k-1) - dlnsig * rd / g +! & * .5 * (tvo(i,k) + tvo(i,k-1)) +! endif +! enddo +! enddo +c +c--- moist static energy +c + do k = 1, km1 + do i = 1, im + if(k .le. kmax(i)-1 .and. cnvflg(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) +cjfe es = 10. * fpvs(to(i,k+1)) +! + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa +! + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo + do k = 1, km1 + do i = 1, im + if(k .le. kmax(i)-1 .and. cnvflg(i)) then +cjfe qeso(i,k) = 10. * fpvs(to(i,k)) +! + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa +! + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +c qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + endif + enddo + enddo + do i = 1, im + k = kmax(i) + if(cnvflg(i)) then + heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + xhkb(i) = heo(i,indx) + xqkb(i) = qo(i,indx) + hcko(i,indx) = xhkb(i) + qcko(i,indx) = xqkb(i) + endif + enddo +c +c +c**************************** static control +c +c +c------- moisture and cloud work functions +c + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then +c if(cnvflg(i).and.k.gt.kb(i).and.k.le.kbcon(i)) then + if(cnvflg(i).and.k.gt.kb(i).and.k.le.ktcon(i)) then + factor = eta(i,k-1) / eta(i,k) + onemf = 1. - factor + hcko(i,k) = factor * hcko(i,k-1) + onemf * + & .5 * (heo(i,k) + heo(i,k+1)) + endif +c if(cnvflg(i).and.k.gt.kbcon(i)) then +c heo(i,k) = heo(i,k-1) +c endif + endif + enddo + enddo + do k = 2, km1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(cnvflg(i).and.k.gt.kb(i).and.k.lt.ktcon(i)) then + dz = .5 * (zo(i,k+1) - zo(i,k-1)) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + xdby = hcko(i,k) - heso(i,k) + val = 0. + xdby = max(xdby,val) + xqrch = qeso(i,k) + & + gamma * xdby / (hvap * (1. + gamma)) + factor = eta(i,k-1) / eta(i,k) + onemf = 1. - factor + qcko(i,k) = factor * qcko(i,k-1) + onemf * + & .5 * (qo(i,k) + qo(i,k+1)) + dq = eta(i,k) * qcko(i,k) - eta(i,k) * xqrch + if(dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + qlk = dq / (eta(i,k) + etah * c0 * dz) + xaa0(i) = xaa0(i) - (zo(i,k) - zo(i,k-1)) * g * qlk + xqc = qlk + xqrch + xpw = etah * c0 * dz * qlk + qcko(i,k) = xqc + xpwav(i) = xpwav(i) + xpw + endif + endif +c if(cnvflg(i).and.k.gt.kbcon(i).and.k.lt.ktcon(i)) then + if(cnvflg(i).and.k.gt.kbcon(i).and.k.le.ktcon(i)) then + dz1 = zo(i,k) - zo(i,k-1) + gamma = el2orc * qeso(i,k-1) / (to(i,k-1)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k-1) / hvap + xdby = hcko(i,k-1) - heso(i,k-1) + xaa0(i) = xaa0(i) + & + dz1 * (g / (cp * to(i,k-1))) + & * xdby / (1. + gamma) + & * rfact + val=0. + xaa0(i)=xaa0(i)+ + & dz1 * g * delta * + & max(val,(qeso(i,k-1) - qo(i,k-1))) + endif + endif + enddo + enddo +ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +ccccc print *, ' xaa before dwndrft =', xaa0(i) +ccccc endif +c +c------- downdraft calculations +c +c +c--- downdraft moisture properties +c + do i = 1, im + xpwev(i) = 0. + enddo + do i = 1, im + if(dwnflg2(i)) then + jmn = jmin(i) + xhcd(i) = heo(i,jmn) + xqcd(i) = qo(i,jmn) + qrcd(i,jmn) = qeso(i,jmn) + endif + enddo + do k = km1, 1, -1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(dwnflg2(i).and.k.lt.jmin(i)) then + dq = qeso(i,k) + dt = to(i,k) + gamma = el2orc * dq / dt**2 + dh = xhcd(i) - heso(i,k) + qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh + detad = etad(i,k+1) - etad(i,k) + xpwd = etad(i,k+1) * qrcd(i,k+1) - + & etad(i,k) * qrcd(i,k) + xpwd = xpwd - detad * + & .5 * (qrcd(i,k) + qrcd(i,k+1)) + xpwev(i) = xpwev(i) + xpwd + endif + endif + enddo + enddo +c + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(dwnflg2(i)) then + if(xpwev(i).ge.0.) then + edtx(i) = 0. + else + edtx(i) = -edtx(i) * xpwav(i) / xpwev(i) + edtx(i) = min(edtx(i),edtmax) + endif + else + edtx(i) = 0. + endif + enddo +c +c +c +c--- downdraft cloudwork functions +c +c + do k = km1, 1, -1 + do i = 1, im + if (k .le. kmax(i)-1) then + if(dwnflg2(i).and.k.lt.jmin(i)) then + gamma = el2orc * qeso(i,k+1) / to(i,k+1)**2 + dhh=xhcd(i) + dt= to(i,k+1) + dg= gamma + dh= heso(i,k+1) + dz=-1.*(zo(i,k+1)-zo(i,k)) + xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. + xaa0(i)=xaa0(i)+edtx(i)* + & dz*g*delta*max(val,(qeso(i,k+1)-qo(i,k+1))) + endif + endif + enddo + enddo +ccccc if(lat.eq.latd.and.lon.eq.lond.and.dwnflg2(i)) then +ccccc print *, ' xaa after dwndrft =', xaa0(i) +ccccc endif +c +c calculate critical cloud work function +c + do i = 1, im + acrt(i) = 0. + if(cnvflg(i)) then +c if(cnvflg(i).and.islimsk(i) /= 1) then + if(pfld(i,ktcon(i)).lt.pcrit(15))then + acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i))) + & /(975.-pcrit(15)) + else if(pfld(i,ktcon(i)).gt.pcrit(1))then + acrt(i)=acrit(1) + else + k = int((850. - pfld(i,ktcon(i)))/50.) + 2 + k = min(k,15) + k = max(k,2) + acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))* + * (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k)) + endif +c else +c acrt(i) = .5 * (pfld(i,kbcon(i)) - pfld(i,ktcon(i))) + endif + enddo + do i = 1, im + acrtfct(i) = 1. + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif +c if(cnvflg(i).and.islimsk(i) == 1) then +c acrtfct(i) = pdot(i) / w3 +c +c modify critical cloud workfunction by cloud base vertical velocity +c + if(pdot(i).le.w4) then + acrtfct(i) = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i).ge.-w4) then + acrtfct(i) = - (pdot(i) + w4) / (w4 - w3) + else + acrtfct(i) = 0. + endif + val1 = -1. + acrtfct(i) = max(acrtfct(i),val1) + val2 = 1. + acrtfct(i) = min(acrtfct(i),val2) + acrtfct(i) = 1. - acrtfct(i) +c +c modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent +c +c if(rhbar(i).ge..8) then +c acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10. +c endif +c +c modify adjustment time scale by cloud base vertical velocity +c + dtconv(i) = dt2 + max((1800. - dt2),cons_0) * + & (pdot(i) - w2) / (w1 - w2) +c dtconv(i) = max(dtconv(i), dt2) +c dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = min(dtconv(i),dtmax) + + endif + enddo +c +c--- large scale forcing +c + do i= 1, im + flg(i) = cnvflg(i) + if(cnvflg(i)) then +c f = aa1(i) / dtconv(i) + fld(i) = (aa1(i) - acrt(i) * acrtfct(i)) / dtconv(i) + if(fld(i).le.0.) flg(i) = .false. + endif + cnvflg(i) = flg(i) + if(cnvflg(i)) then +c xaa0(i) = max(xaa0(i),0.) + xk(i) = (xaa0(i) - aa1(i)) / mbdt + if(xk(i).ge.0.) flg(i) = .false. + endif +c +c--- kernel, cloud base mass flux +c + cnvflg(i) = flg(i) + if(cnvflg(i)) then + xmb(i) = -fld(i) / xk(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +c if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +c print *, ' rhbar(i), acrtfct(i) =', rhbar(i), acrtfct(i) +c print *, ' a1, xa =', aa1(i), xaa0(i) +c print *, ' xmb(i), acrt =', xmb(i), acrt +c endif + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +c +c restore t0 and qo to t1 and q1 in case convection stops +c + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) +!jfe qeso(i,k) = 10. * fpvs(t1(i,k)) +! + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa +! + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- feedback: simply the changes from the cloud with unit mass flux +c--- multiplied by the mass flux necessary to keep the +c--- equilibrium with the larger-scale. +c + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + qcond(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.k.le.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.gt.jmin(i)) adw = 0. + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + endif + endif + enddo + enddo + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.k.le.ktcon(i)) then +!jfe qeso(i,k) = 10. * fpvs(t1(i,k)) +! + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa +! + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) +c +c cloud water +c + if(ncloud.gt.0.and.cnvflg(i).and.k.eq.ktcon(i)) then + tem = dellal(i) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (ql(i,k,2) .gt. -999.0) then + ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice + ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water + else + ql(i,k,1) = ql(i,k,1) + tem + endif + dp = 1000. * del(i,k) + dellal(i) = dellal(i) * xmb(i) * dp / g + endif +! +! if(ncloud.gt.0.and.cnvflg(i).and.k.eq.ktcon(i)) then +! ql(i,k) = ql(i,k) + dellal(i) * xmb(i) * dt2 +! dp = 1000. * del(i,k) +! dellal(i) = dellal(i) * xmb(i) * dp / g +! endif +! + endif + endif + enddo + enddo +c if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i) ) then +c print *, ' delhbar, delqbar, deltbar =' +c print *, delhbar, hvap*delqbar, cp*deltbar +c print *, ' dellbar =' +c print 6003, hvap*dellbar +c print *, ' dellaq =' +c print 6003, (hvap*dellaq(i,k)*xmb(i),k=1,kmax) +c print *, ' dellat =' +c print 6003, (dellah(i,k)*xmb(i)-hvap*dellaq(i,k)*xmb(i), +c & k=1,kmax) +c endif + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.k.le.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.gt.jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo + do k = km, 1, -1 + do i = 1, im + if (k .le. kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i).and.k.le.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.gt.jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 + endif + if(flg(i).and.k.le.ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) /= 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i).gt.0..and.qcond(i).lt.0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i).gt.0..and.qcond(i).lt.0..and. + & delq2(i).gt.rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i).gt.0..and.qevap(i).gt.0.) then + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + rn(i) = rn(i) - .001 * qevap(i) * dp / g + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i) + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +c if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i) ) then +c print *, ' dellah =' +c print 6003, (dellah(k)*xmb(i),k=1,kmax) +c print *, ' dellaq =' +c print 6003, (hvap*dellaq(i,k)*xmb(i),k=1,kmax) +c print *, ' delhbar, delqbar, deltbar =' +c print *, delhbar, hvap*delqbar, cp*deltbar +c print *, ' precip =', hvap*rn(i)*1000./dt2 +ccccc print *, ' dellbar =' +ccccc print *, hvap*dellbar +c endif +c +c precipitation rate converted to actual precip +c in unit of m instead of kg +c + do i = 1, im + if(cnvflg(i)) then +c +c in the event of upper level rain evaporation and lower level downdraf +c moistening, rn can become negative, in this case, we back out of th +c heating and the moistening +c + if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0. + if(rn(i).le.0.) then + rn(i) = 0. + else + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kuo(i) = 1 + cldwrk(i) = aa1(i) + endif + endif + enddo +c +c convective cloud water +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +c +c convective cloud cover +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 576. * eta(i,k) * xmb(i)) ! in uetm da run +! cnvc(i,k) = 0.01 * log(1. + 500. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo + + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + if(cnvflg(i).and.rn(i).le.0.) then + t1(i,k) = to(i,k) + q1(i,k) = qo(i,k) + endif + endif + enddo + enddo +! hchuang code change [+24l] + do k = 1, km + do i = 1, im + if(cnvflg(i).and.rn(i).gt.0.) then + if(k.ge.kb(i) .and. k.lt.ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i).and.rn(i).gt.0.) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo + do k = 1, km + do i = 1, im + if(cnvflg(i).and.rn(i).gt.0.) then + if(k.ge.1 .and. k.le.jmin(i)) then + dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!! + return + end diff --git a/gsmphys/sascnvn.f b/gsmphys/sascnvn.f new file mode 100644 index 00000000..81e3d507 --- /dev/null +++ b/gsmphys/sascnvn.f @@ -0,0 +1,2043 @@ +!> \defgroup SAS Simplified Arakawa-Schubert Deep Convection +!! @{ +!! \brief The Simplified Arakawa-Schubert scheme parameterizes the effect of deep convection on the environment (represented by the model state variables) in the following way. First, a simple cloud model is used to determine the change in model state variables due to one entraining/detraining cloud type, per unit cloud-base mass flux. Next, the total change in state variables is retrieved by determining the actual cloud base mass flux using the quasi-equilibrium assumption, whereby convection is assumed to be steady-state. This implies that the generation of the cloud work function (interpreted as entrainment-moderated convective available potential energy (CAPE)) by the large scale dynamics is in balance with the consumption of the cloud work function by the convection. +!! +!! The SAS scheme uses the working concepts put forth in Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 but includes modifications and simplifications from Grell (1993) \cite grell_1993 such as saturated downdrafts and only one cloud type (the deepest possible), rather than a spectrum based on cloud top heights or assumed entrainment rates. The scheme was implemented for the GFS in 1995 by Pan and Wu \cite pan_and_wu_1995, with further modifications discussed in Han and Pan (2011) \cite han_and_pan_2011 , including the calculation of cloud top, a greater CFL-criterion-based maximum cloud base mass flux, updated cloud model entrainment and detrainment, improved convective transport of horizontal momentum, a more general triggering function, and the inclusion of convective overshooting. +!! +!! \section diagram Calling Hierarchy Diagram +!! \image html SAS_Flowchart.png "Diagram depicting how the SAS deep convection scheme is called from the GSM physics time loop" height=2cm +!! \section intraphysics Intraphysics Communication +!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. + +!> \file sascnvn.f +!! Contains the entire SAS deep convection scheme. + +!> \brief This subroutine contains the entirety of the SAS deep convection scheme. +!! +!! As in Grell (1993) \cite grell_1993 , the SAS convective scheme can be described in terms of three types of "controls": static, dynamic, and feedback. The static control component consists of the simple entraining/detraining updraft/downdraft cloud model and is used to determine the cloud properties, convective precipitation, as well as the convective cloud top height. The dynamic control is the determination of the potential energy available for convection to "consume", or how primed the large-scale environment is for convection to occur due to changes by the dyanmics of the host model. The feedback control is the determination of how the parameterized convection changes the large-scale environment (the host model state variables) given the changes to the state variables per unit cloud base mass flux calculated in the static control portion and the deduced cloud base mass flux determined from the dynamic control. +!! +!! \param[in] im number of used points +!! \param[in] ix horizontal dimension +!! \param[in] km vertical layer dimension +!! \param[in] jcap number of spectral wave trancation +!! \param[in] delt physics time step in seconds +!! \param[in] delp pressure difference between level k and k+1 (Pa) +!! \param[in] prslp mean layer presure (Pa) +!! \param[in] psp surface pressure (Pa) +!! \param[in] phil layer geopotential (\f$m^2/s^2\f$) +!! \param[inout] ql cloud water or ice (kg/kg) +!! \param[inout] q1 updated tracers (kg/kg) +!! \param[inout] t1 updated temperature (K) +!! \param[inout] u1 updated zonal wind (\f$m s^{-1}\f$) +!! \param[inout] v1 updated meridional wind (\f$m s^{-1}\f$) +!! \param[out] cldwrk cloud workfunction (\f$m^2/s^2\f$) +!! \param[out] rn convective rain (m) +!! \param[out] kbot index for cloud base +!! \param[out] ktop index for cloud top +!! \param[out] kcnv flag to denote deep convection (0=no, 1=yes) +!! \param[in] islimsk sea/land/ice mask (=0/1/2) +!! \param[in] dot layer mean vertical velocity (Pa/s) +!! \param[in] ncloud number of cloud species +!! \param[out] ud_mf updraft mass flux multiplied by time step (\f$kg/m^2\f$) +!! \param[out] dd_mf downdraft mass flux multiplied by time step (\f$kg/m^2\f$) +!! \param[out] dt_mf ud_mf at cloud top (\f$kg/m^2\f$) +!! \param[out] cnvw convective cloud water (kg/kg) +!! \param[out] cnvc convective cloud cover (unitless) +!! +!! \section general General Algorithm +!! -# Compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm. +!! -# Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!! -# Perform calculations related to the downdraft of the entraining/detraining cloud model ("static control"). +!! -# Using the updated temperature and moisture profiles that were modified by the convection on a short time-scale, recalculate the total cloud work function to determine the change in the cloud work function due to convection, or the stabilizing effect of the cumulus. +!! -# For the "dynamic control", using a reference cloud work function, estimate the change in cloud work function due to the large-scale dynamics. Following the quasi-equilibrium assumption, calculate the cloud base mass flux required to keep the large-scale convective destabilization in balance with the stabilization effect of the convection. +!! -# For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!! \section detailed Detailed Algorithm +!! @{ + subroutine sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & + & q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kcnv,islimsk, & + & dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, & +! & q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,islimsk, +! & dot,ncloud,ud_mf,dd_mf,dt_mf,me) + & clam,c0,c1,betal,betas,evfact,evfactl,pgcon) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap & + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c & + &, cvap => con_cvap, cliq => con_cliq & + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + integer im, ix, km, jcap, ncloud, & + & kbot(im), ktop(im), kcnv(im) +! &, me + real(kind=kind_phys) delt + real(kind=kind_phys) psp(im), delp(ix,km), prslp(ix,km) + real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), & + & ql(ix,km,2),q1(ix,km), t1(ix,km), & + & u1(ix,km), v1(ix,km), & !rcs(im), + & cldwrk(im), rn(im), & + & dot(ix,km), phil(ix,km), & + & cnvw(ix,km), cnvc(ix,km), & + & ud_mf(im,km),dd_mf(im,km),dt_mf(im,km) ! hchuang code change mass flux output +! + integer i, indx, jmn, k, kk, km1 + integer, dimension(im), intent(in) :: islimsk +! integer latd,lond +! + real(kind=kind_phys) clam, cxlamu, xlamde, xlamdd +! +! real(kind=kind_phys) detad + real(kind=kind_phys) adw, aup, aafac, + & beta, betal, betas, + & c0, dellat, delta, + & desdt, dg, + & dh, dhh, dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, dv1h, + & dv1q, dv2h, dv2q, dv1u, + & dv1v, dv2u, dv2v, dv3q, + & dv3h, dv3u, dv3v, + & dz, dz1, e1, edtmax, + & edtmaxl, edtmaxs, el2orc, elocp, + & es, etah, cthk, dthk, + & evef, evfact, evfactl, fact1, + & fact2, factor, fjcap, fkm, + & g, gamma, pprime, + & qlk, qrch, qs, c1, + & rain, rfact, shear, tem1, + & val, val1, + & val2, w1, w1l, w1s, + & w2, w2l, w2s, w3, + & w3l, w3s, w4, w4l, + & w4s, xdby, xpw, xpwd, + & xqrch, mbdt, tem, + & ptem, ptem1, pgcon +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), + & jmin(im), lmin(im), kbmax(im), + & kbm(im), kmax(im) +! + real(kind=kind_phys) aa1(im), acrt(im), acrtfct(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), dtconv(im), edt(im), + & edto(im), edtx(im), fld(im), + & hcdo(im,km), hmax(im), hmin(im), + & ucdo(im,km), vcdo(im,km),aa2(im), + & pbcdif(im), pdot(im), po(im,km), + & pwavo(im), pwevo(im), xlamud(im), + & qcdo(im,km), qcond(im), qevap(im), + & rntot(im), vshear(im), xaa0(im), + & xk(im), xlamd(im), + & xmb(im), xmbmax(im), xpwav(im), + & xpwev(im), delubar(im),delvbar(im) +cj + real(kind=kind_phys) cincr, cincrmax, cincrmin +cj +c physical parameters + parameter(g=grav) + parameter(elocp=hvap/cp, + & el2orc=hvap*hvap/(rv*cp)) +! parameter(c0=.002,c1=.002,delta=fv) + parameter(delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.) +c local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km) +c cloud water +! real(kind=kind_phys) tvo(im,km) + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + & dbyo(im,km), zo(im,km), xlamue(im,km), + & fent1(im,km), fent2(im,km), frh(im,km), + & heo(im,km), heso(im,km), + & qrcd(im,km), dellah(im,km), dellaq(im,km), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & eta(im,km), etad(im,km), zi(im,km), + & qrcko(im,km), qrcdo(im,km), + & pwo(im,km), pwdo(im,km), + & tx1(im), sumx(im), cnvwt(im,km) +! &, rhbar(im) +! + logical totflg, cnvflg(im), flg(im) +! + real(kind=kind_phys) pcrit(15), acritt(15), acrit(15) +! save pcrit, acritt + data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400., + & 350.,300.,250.,200.,150./ + data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216, + & .3151,.3677,.41,.5255,.7663,1.1686,1.6851/ +c gdas derived acrit +c data acritt/.203,.515,.521,.566,.625,.665,.659,.688, +c & .743,.813,.886,.947,1.138,1.377,1.896/ + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +!> ## Compute preliminary quantities needed for static, dynamic, and feedback control portions of the algorithm. +!> - Convert input pressure terms to centibar units. +!************************************************************************ +! convert input pa terms to cb terms -- moorthi + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! +! + km1 = km - 1 +!> - Initialize column-integrated and other single-value-per-column variable arrays. +c +c initialize arrays +c + do i=1,im + cnvflg(i) = .true. + rn(i)=0. + kbot(i)=km+1 + ktop(i)=0 + kbcon(i)=km + ktcon(i)=1 + dtconv(i) = 3600. + cldwrk(i) = 0. + pdot(i) = 0. + pbcdif(i)= 0. + lmin(i) = 1 + jmin(i) = 1 + qlko_ktcon(i) = 0. + edt(i) = 0. + edto(i) = 0. + edtx(i) = 0. + acrt(i) = 0. + acrtfct(i) = 1. + aa1(i) = 0. + aa2(i) = 0. + xaa0(i) = 0. + pwavo(i)= 0. + pwevo(i)= 0. + xpwav(i)= 0. + xpwev(i)= 0. + vshear(i) = 0. + enddo +!> - Initialize convective cloud water and cloud cover to zero. + do k = 1, km + do i = 1, im + cnvw(i,k) = 0. + cnvc(i,k) = 0. + enddo + enddo +!> - Initialize updraft, downdraft, detrainment mass fluxes to zero. +! hchuang code change + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dd_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +!> - Initialize the reference cloud work function, define min/max convective adjustment timescales, and tunable parameters. +c + do k = 1, 15 + acrit(k) = acritt(k) * (975. - pcrit(k)) + enddo + dt2 = delt + val = 1200. + dtmin = max(dt2, val ) + val = 3600. + dtmax = max(dt2, val ) +c model tunable parameters are all here + mbdt = 10. + edtmaxl = .3 + edtmaxs = .3 +! clam = .1 + aafac = .1 +! betal = .15 +! betas = .15 +! betal = .05 +! betas = .05 +c evef = 0.07 +! evfact = 0.3 +! evfactl = 0.3 +! + cxlamu = 1.0e-4 + xlamde = 1.0e-4 + xlamdd = 1.0e-4 +! +! pgcon = 0.7 ! gregory et al. (1997, qjrms) +! pgcon = 0.55 ! zhang & wu (2003,jas) + fjcap = (float(jcap) / 126.) ** 2 + val = 1. + fjcap = max(fjcap,val) + fkm = (float(km) / 28.) ** 2 + fkm = max(fkm,val) + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +!> - Determine maximum indices for the parcel starting point (kbm), LFC (kbmax), and cloud top (kmax). +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c + do i=1,im + kbmax(i) = km + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i) = k + 1 + if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1 + if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i) = k + 1 + enddo + enddo + do i=1,im + kmax(i) = min(km,kmax(i)) + kbmax(i) = min(kbmax(i),kmax(i)) + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and initially assume +c updraft entrainment rate as an inverse function of height +c +!> - Calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential. + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo +!> - Calculate interface height and the initial entrainment rate as an inverse function of height. + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + xlamue(i,k) = clam / zi(i,k) + enddo + enddo +!> - Convert prsl from centibar to millibar, set normalized mass fluxes to 1, cloud properties to 0, and save model state variables (after advection/turbulence). +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c + do k = 1, km + do i = 1, im + if (k .le. kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + eta(i,k) = 1. + fent1(i,k)= 1. + fent2(i,k)= 1. + frh(i,k) = 0. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + etad(i,k) = 1. + hcdo(i,k) = 0. + qcdo(i,k) = 0. + ucdo(i,k) = 0. + vcdo(i,k) = 0. + qrcd(i,k) = 0. + qrcdo(i,k)= 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + pwdo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) + cnvwt(i,k)= 0. + endif + enddo + enddo +c +c column variables +c p is pressure of the layer (mb) +c t is temperature at t-dt (k)..tn +c q is mixing ratio at t-dt (kg/kg)..qn +c to is temperature at t+dt (k)... this is after advection and turbulan +c qo is mixing ratio at t+dt (kg/kg)..q1 +c +!> - Calculate saturation mixing ratio and enforce minimum moisture values. + do k = 1, km + do i=1,im + if (k .le. kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c +!> - Calculate moist static energy (heo) and saturation moist static energy (heso). + do k = 1, km + do i=1,im + if (k .le. kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo + +!> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +c +c determine level with largest moist static energy +c this is the level where updraft starts +c +!> - Search below index "kbm" for the level of maximum moist static energy. + do i=1,im + hmax(i) = heo(i,1) + kb(i) = 1 + enddo + do k = 2, km + do i=1,im + if (k .le. kbm(i)) then + if(heo(i,k).gt.hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +!> - Calculate the temperature, water vapor mixing ratio, and pressure at interface levels. +c + do k = 1, km1 + do i=1,im + if (k .le. kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +!> - Recalculate saturation mixing ratio, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. Enforce minimum mixing ratios and calculate \f$(1 - RH)\f$. +! + do k = 1, km1 + do i=1,im + if (k .le. kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + frh(i,k) = 1. - min(qo(i,k)/qeso(i,k), 1.) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo +c +c look for the level of free convection as cloud base +c +!> - Search below the index "kbmax" for the level of free convection (LFC) where the condition \f$h_b > h^*\f$ is first met, where \f$h_b, h^*\f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. Set "kbcon" to the index of the LFC. + do i=1,im + flg(i) = .true. + kbcon(i) = kmax(i) + enddo + do k = 1, km1 + do i=1,im + if (flg(i).and.k.le.kbmax(i)) then + if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +!> - If no LFC, return to the calling routine without modifying state variables. +c + do i=1,im + if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine critical convective inhibition +c as a function of vertical velocity at cloud base. +c +!> - Determine the vertical pressure velocity at the LFC. After Han and Pan (2011) \cite han_and_pan_2011 , determine the maximum pressure thickness between a parcel's starting level and the LFC. If a parcel doesn't reach the LFC within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables. + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! now dot is in pa/s + endif + enddo + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i).le.w4) then + tem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i).ge.-w4) then + tem = - (pdot(i) + w4) / (w4 - w3) + else + tem = 0. + endif + val1 = -1. + tem = max(tem,val1) + val2 = 1. + tem = min(tem,val2) + tem = 1. - tem + tem1= .5*(cincrmax-cincrmin) + cincr = cincrmax - tem * tem1 + pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(pbcdif(i).gt.cincr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c assume that updraft entrainment rate above cloud base is +c same as that at cloud base +c +!> - Calculate the entrainment rate according to Han and Pan (2011) \cite han_and_pan_2011 , equation 8, after Bechtold et al. (2008) \cite bechtold_et_al_2008, equation 2 given by: +!! \f[ +!! \epsilon = \epsilon_0F_0 + d_1\left(1-RH\right)F_1 +!! \f] +!! where \f$\epsilon_0\f$ is the cloud base entrainment rate, \f$d_1\f$ is a tunable constant, and \f$F_0=\left(\frac{q_s}{q_{s,b}}\right)^2\f$ and \f$F_1=\left(\frac{q_s}{q_{s,b}}\right)^3\f$ where \f$q_s\f$ and \f$q_{s,b}\f$ are the saturation specific humidities at a given level and cloud base, respectively. The detrainment rate in the cloud is assumed to be equal to the entrainment rate at cloud base. + do k = 2, km1 + do i=1,im + if(cnvflg(i).and. + & (k.gt.kbcon(i).and.k.lt.kmax(i))) then + xlamue(i,k) = xlamue(i,kbcon(i)) + endif + enddo + enddo +c +c assume the detrainment rate for the updrafts to be same as +c the entrainment rate at cloud base +c +!> - The updraft detrainment rate is set constant and equal to the entrainment rate at cloud base. + do i = 1, im + if(cnvflg(i)) then + xlamud(i) = xlamue(i,kbcon(i)) + endif + enddo +c +c functions rapidly decreasing with height, mimicking a cloud ensemble +c (bechtold et al., 2008) +c + do k = 2, km1 + do i=1,im + if(cnvflg(i).and. + & (k.gt.kbcon(i).and.k.lt.kmax(i))) then + tem = qeso(i,k)/qeso(i,kbcon(i)) + fent1(i,k) = tem**2 + fent2(i,k) = tem**3 + endif + enddo + enddo +c +c final entrainment rate as the sum of turbulent part and organized entrainment +c depending on the environmental relative humidity +c (bechtold et al., 2008) +c + do k = 2, km1 + do i=1,im + if(cnvflg(i).and. + & (k.ge.kbcon(i).and.k.lt.kmax(i))) then + tem = cxlamu * frh(i,k) * fent2(i,k) + xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem + endif + enddo + enddo +c +c determine updraft mass flux for the subcloud layers +c +!> - Calculate the normalized mass flux for subcloud and in-cloud layers according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 1: +!! \f[ +!! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d +!! \f] +!! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k.lt.kbcon(i).and.k.ge.kb(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do k = 2, km1 + do i = 1, im + if(cnvflg(i))then + if(k.gt.kbcon(i).and.k.lt.kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + endif + endif + enddo + enddo +c +c compute updraft cloud properties +c +!> - Set initial cloud properties equal to the state variables at cloud base. + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + pwavo(i) = 0. + endif + enddo +c +c cloud property is modified by the entrainment process +c +!> - Calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. Discretization follows Appendix B of Grell (1993) \cite grell_1993 . Following Han and Pan (2006) \cite han_and_pan_2006, the convective momentum transport is reduced by the convection-induced pressure gradient force by the constant "pgcon", currently set to 0.55 after Zhang and Wu (2003) \cite zhang_and_wu_2003 . + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.lt.kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + ptem = 0.5 * tem + pgcon + ptem1= 0.5 * tem - pgcon + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) + endif + endif + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c +!> - With entrainment, recalculate the LFC as the first level where buoyancy is positive. The difference in pressure levels between LFCs calculated with/without entrainment must be less than a threshold (currently 25 hPa). Otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. This is the subcloud dryness trigger modification discussed in Han and Pan (2011) \cite han_and_pan_2011. + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i).and.k.lt.kmax(i)) then + if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem.gt.dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c +!> - Calculate the cloud top as the first level where parcel buoyancy becomes negative. If the thickness of the calculated convection is less than a threshold (currently 150 hPa), then convection is inhibited, and the scheme returns to the calling routine. + do i = 1, im + flg(i) = cnvflg(i) + ktcon(i) = 1 + enddo + do k = 2, km1 + do i = 1, im + if (flg(i).and.k .lt. kmax(i)) then + if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c + do i = 1, im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i))-pfld(i,ktcon(i)) + if(tem.lt.cthk) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c search for downdraft originating level above theta-e minimum +c +!> - To originate the downdraft, search for the level above the minimum in moist static energy. Return to the calling routine without modification if this level is determined to be outside of the convective cloud layers. + do i = 1, im + if(cnvflg(i)) then + hmin(i) = heo(i,kbcon1(i)) + lmin(i) = kbmax(i) + jmin(i) = kbmax(i) + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i) .and. k .le. kbmax(i)) then + if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then + lmin(i) = k + 1 + hmin(i) = heo(i,k) + endif + endif + enddo + enddo +c +c make sure that jmin(i) is within the cloud +c + do i = 1, im + if(cnvflg(i)) then + jmin(i) = min(lmin(i),ktcon(i)-1) + jmin(i) = max(jmin(i),kbcon1(i)+1) + if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false. + endif + enddo +c +c specify upper limit of mass flux at cloud base +c +!> - Calculate the maximum value of the cloud base mass flux using the CFL-criterion-based formula of Han and Pan (2011) \cite han_and_pan_2011, equation 7. + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (g * dt2) +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c +!> - Initialize the cloud moisture at cloud base and set the cloud work function to zero. + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) +! rhbar(i) = 0. + endif + enddo +!> - Calculate the moisture content of the entraining/detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation A.14 in Grell (1993) \cite grell_1993 . Their difference is the amount of convective cloud water (qlk = rain + condensate). Determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo). Calculate and save the negative cloud work function (aa1) due to water loading. The liquid water in the updraft layer is assumed to be detrained from the layers above the level of the minimum moist static energy into the grid-scale cloud water (dellal). + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.lt.ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c check if there is excess moisture to release latent heat +c + if(k.ge.kbcon(i).and.dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud.gt.0..and.k.gt.jmin(i)) then + qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0 * dz) + endif + aa1(i) = aa1(i) - dz * g * qlk + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0 * dz * qlk + pwavo(i) = pwavo(i) + pwo(i,k) +! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +c +! do i = 1, im +! if(cnvflg(i)) then +! indx = ktcon(i) - kb(i) - 1 +! rhbar(i) = rhbar(i) / float(indx) +! endif +! enddo +c +c calculate cloud work function +c +!> - Calculate the cloud work function according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 4: +!! \f[ +!! A_u=\int_{z_0}^{z_t}\frac{g}{c_pT(z)}\frac{\eta}{1 + \gamma}[h(z)-h^*(z)]dz +!! \f] +!! (discretized according to Grell (1993) \cite grell_1993 equation B.10 using B.2 and B.3 of Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 and assuming \f$\eta=1\f$) where \f$A_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{L}{c_p}\left(\frac{\partial \overline{q_s}}{\partial T}\right)_p\f$ and other quantities are previously defined. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa1(i) = aa1(i) + + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + aa1(i)=aa1(i)+ + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +!> - If the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine. + do i = 1, im + if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the onvective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c +!> - Continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to Han and Pan (2011) \cite han_and_pan_2011 . Convective overshooting stops when \f$ cA_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force. + do i = 1, im + if (cnvflg(i)) then + aa2(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon1(i) = kmax(i) - 1 + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + if(k.ge.ktcon(i).and.k.lt.kmax(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa2(i) = aa2(i) + + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + if(aa2(i).lt.0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c +!> - For the overshooting convection, calculate the moisture content of the entraining/detraining parcel as before. Partition convective cloud water and precipitation and detrain convective cloud water above the mimimum in moist static energy. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c + if(dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + dp = 1000. * del(i,k) + if(ncloud.gt.0.) then + qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0 * dz) + endif + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0 * dz * qlk + pwavo(i) = pwavo(i) + pwo(i,k) +! cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +c +c exchange ktcon with ktcon1 +c +!> - Swap the indices of the convective cloud top (ktcon) and the overshooting convection top (ktcon1) to use the same cloud top level in the calculations of \f$A^+\f$ and \f$A^*\f$. + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c +!> - Separate the total updraft cloud water at cloud top into vapor and condensate. + if(ncloud.gt.0) then +c +c compute liquid and vapor separation at cloud top +c + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq.gt.0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then +ccccc print *, ' aa1(i) before dwndrft =', aa1(i) +ccccc endif +c +c------- downdraft calculations +c +c--- compute precipitation efficiency in terms of windshear +c +!> ## Perform calculations related to the downdraft of the entraining/detraining cloud model ("static control"). +!! - First, in order to calculate the downdraft mass flux (as a fraction of the updraft mass flux), calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : +!! \f[ +!! E = 1.591 - 0.639\frac{\Delta V}{\Delta z} + 0.0953\left(\frac{\Delta V}{\Delta z}\right)^2 - 0.00496\left(\frac{\Delta V}{\Delta z}\right)^3 +!! \f] +!! where \f$\Delta V\f$ is the integrated horizontal shear over the cloud depth, \f$\Delta z\f$, (the ratio is converted to units of \f$10^{-3} s^{-1}\f$). The variable "edto" is \f$1-E\f$ and is constrained to the range \f$[0,0.9]\f$. + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.le.ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + edto(i)=edt(i) + edtx(i)=edt(i) + endif + enddo +c +c determine detrainment rate between 1 and kbcon +c +!> - Next, calculate the variable detrainment rate between the surface and the LFC according to: +!! \f[ +!! \lambda_d = \frac{1-\beta^{\frac{1}{k_{LFC}}}}{\overline{\Delta z}} +!! \f] +!! \f$\lambda_d\f$ is the detrainment rate, \f$\beta\f$ is a constant currently set to 0.05, \f$k_{LFC}\f$ is the vertical index of the LFC level, and \f$\overline{\Delta z}\f$ is the average vertical grid spacing below the LFC. + do i = 1, im + if(cnvflg(i)) then + sumx(i) = 0. + endif + enddo + do k = 1, km1 + do i = 1, im + if(cnvflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + sumx(i) = sumx(i) + dz + endif + enddo + enddo + do i = 1, im + beta = betas + if(islimsk(i) == 1) beta = betal + if(cnvflg(i)) then + dz = (sumx(i)+zi(i,1))/float(kbcon(i)) + tem = 1./float(kbcon(i)) + xlamd(i) = (1.-beta**tem)/dz + endif + enddo +c +c determine downdraft mass flux +c +!> - Calculate the normalized downdraft mass flux from equation 1 of Pan and Wu (1995) \cite pan_and_wu_1995 . Downdraft entrainment and detrainment rates are constants from the downdraft origination to the LFC. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)-1) then + if(k.lt.jmin(i).and.k.ge.kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = xlamdd - xlamde + etad(i,k) = etad(i,k+1) * (1. - ptem * dz) + else if(k.lt.kbcon(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = xlamd(i) + xlamdd - xlamde + etad(i,k) = etad(i,k+1) * (1. - ptem * dz) + endif + endif + enddo + enddo +c +c--- downdraft moisture properties +c +!> - Set initial cloud downdraft properties equal to the state variables at the downdraft origination level. + do i = 1, im + if(cnvflg(i)) then + jmn = jmin(i) + hcdo(i,jmn) = heo(i,jmn) + qcdo(i,jmn) = qo(i,jmn) + qrcdo(i,jmn)= qo(i,jmn) + ucdo(i,jmn) = uo(i,jmn) + vcdo(i,jmn) = vo(i,jmn) + pwevo(i) = 0. + endif + enddo +cj +!> - Calculate the cloud properties as a parcel descends, modified by entrainment and detrainment. Discretization follows Appendix B of Grell (1993) \cite grell_1993 . + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k.lt.jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + if(k.ge.kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + ptem = 0.5 * tem - pgcon + ptem1= 0.5 * tem + pgcon + hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* + & (heo(i,k)+heo(i,k+1)))/factor + ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1) + & +ptem1*uo(i,k))/factor + vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1) + & +ptem1*vo(i,k))/factor + dbyo(i,k) = hcdo(i,k) - heso(i,k) + endif + enddo + enddo +c +!> - Compute the amount of moisture that is necessary to keep the downdraft saturated. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i).and.k.lt.jmin(i)) then + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrcdo(i,k) = qeso(i,k)+ + & (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k) +! detad = etad(i,k+1) - etad(i,k) +cj + dz = zi(i,k+1) - zi(i,k) + if(k.ge.kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5* + & (qo(i,k)+qo(i,k+1)))/factor +cj +! pwdo(i,k) = etad(i,k+1) * qcdo(i,k+1) - +! & etad(i,k) * qrcdo(i,k) +! pwdo(i,k) = pwdo(i,k) - detad * +! & .5 * (qrcdo(i,k) + qrcdo(i,k+1)) +cj + pwdo(i,k) = etad(i,k) * (qcdo(i,k) - qrcdo(i,k)) + pwevo(i) = pwevo(i) + pwdo(i,k) + endif + enddo + enddo +c +c--- final downdraft strength dependent on precip +c--- efficiency (edt), normalized condensate (pwav), and +c--- evaporate (pwev) +c +!> - Update the precipitation efficiency (edto) based on the ratio of normalized cloud condensate (pwavo) to normalized cloud evaporate (pwevo). + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(cnvflg(i)) then + if(pwevo(i).lt.0.) then + edto(i) = -edto(i) * pwavo(i) / pwevo(i) + edto(i) = min(edto(i),edtmax) + else + edto(i) = 0. + endif + endif + enddo +c +c--- downdraft cloudwork functions +c +!> - Calculate downdraft cloud work function (\f$A_d\f$) according to equation A.42 (discretized by B.11) in Grell (1993) \cite grell_1993 . Add it to the updraft cloud work function, \f$A_u\f$. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k .lt. jmin(i)) then + gamma = el2orc * qeso(i,k) / to(i,k)**2 + dhh=hcdo(i,k) + dt=to(i,k) + dg=gamma + dh=heso(i,k) + dz=-1.*(zo(i,k+1)-zo(i,k)) + aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. + aa1(i)=aa1(i)+edto(i)* + & dz*g*delta*max(val,(qeso(i,k)-qo(i,k))) + endif + enddo + enddo +!> - Check for negative total cloud work function; if found, return to calling routine without modifying state variables. + do i = 1, im + if(cnvflg(i).and.aa1(i).le.0.) then + cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c +!> - Calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux near the surface using equations B.18 and B.19 from Grell (1993) \cite grell_1993, for all layers below cloud top from equations B.14 and B.15, and for the cloud top from B.16 and B.17. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k .le. kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + dp = 1000. * del(i,1) + dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1) + & - heo(i,1)) * g / dp + dellaq(i,1) = edto(i) * etad(i,1) * (qrcdo(i,1) + & - qo(i,1)) * g / dp + dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1) + & - uo(i,1)) * g / dp + dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1) + & - vo(i,1)) * g / dp + endif + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i).and.k.lt.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.gt.jmin(i)) adw = 0. + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) + dv1u = uo(i,k) + dv2u = .5 * (uo(i,k) + uo(i,k-1)) + dv3u = uo(i,k-1) + dv1v = vo(i,k) + dv2v = .5 * (vo(i,k) + vo(i,k-1)) + dv3v = vo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = xlamud(i) +c + if(k.le.kbcon(i)) then + ptem = xlamde + ptem1 = xlamd(i)+xlamdd + else + ptem = xlamde + ptem1 = xlamdd + endif +cj + dellah(i,k) = dellah(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz + & + aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz + & + aup*tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qcdo(i,k-1))*dz + & ) *g/dp +cj + dellau(i,k) = dellau(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1u + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3u + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2u*dz + & + aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz + & - pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1u-dv3u) + & ) *g/dp +cj + dellav(i,k) = dellav(i,k) + + & ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1v + & - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3v + & - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2v*dz + & + aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz + & + adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz + & - pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1v-dv3v) + & ) *g/dp +cj + endif + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dv1u = uo(i,indx-1) + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - dv1u) * g / dp + dv1v = vo(i,indx-1) + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - dv1v) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo +c +c------- final changed variable per unit mass flux +c +!> - Calculate the change in the temperature and moisture profiles per unit cloud base mass flux. + do k = 1, km + do i = 1, im + if (cnvflg(i).and.k .le. kmax(i)) then + if(k.gt.ktcon(i)) then + qo(i,k) = q1(i,k) + to(i,k) = t1(i,k) + endif + if(k.le.ktcon(i)) then + qo(i,k) = dellaq(i,k) * mbdt + q1(i,k) + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + to(i,k) = dellat * mbdt + t1(i,k) + val = 1.e-10 + qo(i,k) = max(qo(i,k), val ) + endif + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- the above changed environment is now used to calulate the +c--- effect the arbitrary cloud (with unit mass flux) +c--- would have on the stability, +c--- which then is used to calculate the real mass flux, +c--- necessary to keep this change in balance with the large-scale +c--- destabilization. +c +c--- environmental conditions again, first heights +c +!> ## Using the updated temperature and moisture profiles that were modified by the convection on a short time-scale, recalculate the total cloud work function to determine the change in the cloud work function due to convection, or the stabilizing effect of the cumulus. +!! - Using notation from Pan and Wu (1995) \cite pan_and_wu_1995, the previously calculated cloud work function is denoted by \f$A^+\f$. Now, it is necessary to use the entraining/detraining cloud model ("static control") to determine the cloud work function of the environment after the stabilization of the arbitrary convective element (per unit cloud base mass flux) has been applied, denoted by \f$A^*\f$. +!! - Recalculate saturation specific humidity. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k .le. kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c--- moist static energy +c +!! - Recalculate moist static energy and saturation moist static energy. + do k = 1, km1 + do i = 1, im + if(cnvflg(i) .and. k .le. kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo + do k = 1, km1 + do i = 1, im + if(cnvflg(i) .and. k .le. kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + k = kmax(i) + heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo +c +c**************************** static control +c +c------- moisture and cloud work functions +c +!> - As before, recalculate the updraft cloud work function. + do i = 1, im + if(cnvflg(i)) then + xaa0(i) = 0. + xpwav(i) = 0. + endif + enddo +c + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + qcko(i,indx) = qo(i,indx) + endif + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.le.ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + endif + endif + enddo + enddo + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.lt.ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + xdby = hcko(i,k) - heso(i,k) + xqrch = qeso(i,k) + & + gamma * xdby / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor +cj + dq = eta(i,k) * (qcko(i,k) - xqrch) +c + if(k.ge.kbcon(i).and.dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + if(ncloud.gt.0..and.k.gt.jmin(i)) then + qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) + else + qlk = dq / (eta(i,k) + etah * c0 * dz) + endif + if(k.lt.ktcon1(i)) then + xaa0(i) = xaa0(i) - dz * g * qlk + endif + qcko(i,k) = qlk + xqrch + xpw = etah * c0 * dz * qlk + xpwav(i) = xpwav(i) + xpw + endif + endif + if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + xaa0(i) = xaa0(i) + & + dz1 * (g / (cp * to(i,k))) + & * xdby / (1. + gamma) + & * rfact + val=0. + xaa0(i)=xaa0(i)+ + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +c +c------- downdraft calculations +c +c--- downdraft moisture properties +c +!> - As before, recalculate the downdraft cloud work function. + do i = 1, im + if(cnvflg(i)) then + jmn = jmin(i) + hcdo(i,jmn) = heo(i,jmn) + qcdo(i,jmn) = qo(i,jmn) + qrcd(i,jmn) = qo(i,jmn) + xpwev(i) = 0. + endif + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k.lt.jmin(i)) then + dz = zi(i,k+1) - zi(i,k) + if(k.ge.kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5* + & (heo(i,k)+heo(i,k+1)))/factor + endif + enddo + enddo +cj + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k .lt. jmin(i)) then + dq = qeso(i,k) + dt = to(i,k) + gamma = el2orc * dq / dt**2 + dh = hcdo(i,k) - heso(i,k) + qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh +! detad = etad(i,k+1) - etad(i,k) +cj + dz = zi(i,k+1) - zi(i,k) + if(k.ge.kbcon(i)) then + tem = xlamde * dz + tem1 = 0.5 * xlamdd * dz + else + tem = xlamde * dz + tem1 = 0.5 * (xlamd(i)+xlamdd) * dz + endif + factor = 1. + tem - tem1 + qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5* + & (qo(i,k)+qo(i,k+1)))/factor +cj +! xpwd = etad(i,k+1) * qcdo(i,k+1) - +! & etad(i,k) * qrcd(i,k) +! xpwd = xpwd - detad * +! & .5 * (qrcd(i,k) + qrcd(i,k+1)) +cj + xpwd = etad(i,k) * (qcdo(i,k) - qrcd(i,k)) + xpwev(i) = xpwev(i) + xpwd + endif + enddo + enddo +c + do i = 1, im + edtmax = edtmaxl + if(islimsk(i) == 0) edtmax = edtmaxs + if(cnvflg(i)) then + if(xpwev(i).ge.0.) then + edtx(i) = 0. + else + edtx(i) = -edtx(i) * xpwav(i) / xpwev(i) + edtx(i) = min(edtx(i),edtmax) + endif + endif + enddo +c +c +c--- downdraft cloudwork functions +c +c + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k.lt.jmin(i)) then + gamma = el2orc * qeso(i,k) / to(i,k)**2 + dhh=hcdo(i,k) + dt= to(i,k) + dg= gamma + dh= heso(i,k) + dz=-1.*(zo(i,k+1)-zo(i,k)) + xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) + & *(1.+delta*cp*dg*dt/hvap) + val=0. + xaa0(i)=xaa0(i)+edtx(i)* + & dz*g*delta*max(val,(qeso(i,k)-qo(i,k))) + endif + enddo + enddo +c +c calculate critical cloud work function +c +!> ## For the "dynamic control", using a reference cloud work function, estimate the change in cloud work function due to the large-scale dynamics. Following the quasi-equilibrium assumption, calculate the cloud base mass flux required to keep the large-scale convective destabilization in balance with the stabilization effect of the convection. +!! - Calculate the reference, or "critical", cloud work function derived from observations, denoted by \f$A^0\f$. + do i = 1, im + if(cnvflg(i)) then + if(pfld(i,ktcon(i)).lt.pcrit(15))then + acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i))) + & /(975.-pcrit(15)) + else if(pfld(i,ktcon(i)).gt.pcrit(1))then + acrt(i)=acrit(1) + else + k = int((850. - pfld(i,ktcon(i)))/50.) + 2 + k = min(k,15) + k = max(k,2) + acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))* + & (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k)) + endif + endif + enddo +!> - Calculate a correction factor, "acrtfct", that is a function of the cloud base vertical velocity, to multiply the critical cloud work function. + do i = 1, im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif +c +c modify critical cloud workfunction by cloud base vertical velocity +c + if(pdot(i).le.w4) then + acrtfct(i) = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i).ge.-w4) then + acrtfct(i) = - (pdot(i) + w4) / (w4 - w3) + else + acrtfct(i) = 0. + endif + val1 = -1. + acrtfct(i) = max(acrtfct(i),val1) + val2 = 1. + acrtfct(i) = min(acrtfct(i),val2) + acrtfct(i) = 1. - acrtfct(i) +c +c modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent +c +c if(rhbar(i).ge..8) then +c acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10. +c endif +c +c modify adjustment time scale by cloud base vertical velocity +c +!> - Also, modify the time scale over which the large-scale destabilization takes place (dtconv) according to the cloud base vertical velocity, ensuring that this timescale stays between previously calculated minimum and maximum values. + dtconv(i) = dt2 + max((1800. - dt2),0.) * + & (pdot(i) - w2) / (w1 - w2) +c dtconv(i) = max(dtconv(i), dt2) +c dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2) + dtconv(i) = max(dtconv(i),dtmin) + dtconv(i) = min(dtconv(i),dtmax) +c + endif + enddo +c +c--- large scale forcing +c +!> - Calculate the large scale destabilization as in equation 5 of Pan and Wu (1995) \cite pan_and_wu_1995 : +!! \f[ +!! \frac{\partial A}{\partial t}_{LS}=\frac{A^+-cA^0}{\Delta t_{LS}} +!! \f] +!! where \f$c\f$ is the correction factor "acrtfct", \f$\Delta t_{LS}\f$ is the modified timescale over which the environment is destabilized, and the other quantities have been previously defined. + do i= 1, im + if(cnvflg(i)) then + fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i) + if(fld(i).le.0.) cnvflg(i) = .false. + endif +!> - Calculate the stabilization effect of the convection (per unit cloud base mass flux) as in equation 6 of Pan and Wu (1995) \cite pan_and_wu_1995 : +!! \f[ +!! \frac{\partial A}{\partial t}_{cu}=\frac{A^*-A^+}{\Delta t_{cu}} +!! \f] +!! \f$\Delta t_{cu}\f$ is the short timescale of the convection. + if(cnvflg(i)) then +c xaa0(i) = max(xaa0(i),0.) + xk(i) = (xaa0(i) - aa1(i)) / mbdt + if(xk(i).ge.0.) cnvflg(i) = .false. + endif +c +c--- kernel, cloud base mass flux +c +!> - The cloud base mass flux (xmb) is then calculated from equation 7 of Pan and Wu (1995) \cite pan_and_wu_1995 +!! \f[ +!! M_c=\frac{-\frac{\partial A}{\partial t}_{LS}}{\frac{\partial A}{\partial t}_{cu}} +!! \f] + if(cnvflg(i)) then + xmb(i) = -fld(i) / xk(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +!! +!> - If the large scale destabilization is less than zero, or the stabilization by the convection is greater than zero, then the scheme returns to the calling routine without modifying the state variables. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops +c + + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)) then + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +c--- feedback: simply the changes from the cloud with unit mass flux +c--- multiplied by the mass flux necessary to keep the +c--- equilibrium with the larger-scale. +c +!> ## For the "feedback" control, calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!> - Calculate the temperature tendency from the moist static energy and specific humidity tendencies. +!> - Update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux-normalized tendencies by the cloud base mass flux. +!> - Accumulate column-integrated tendencies. + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)) then + if(k.le.ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo +!> - Recalculate saturation specific humidity using the updated temperature. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)) then + if(k.le.ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c +!> - Add up column-integrated convective precipitation by multiplying the normalized value by the cloud base mass flux. + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)) then + if(k.lt.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.ge.jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo +!> - Determine the evaporation of the convective precipitation and update the integrated convective precipitation. +!> - Update state temperature and moisture to account for evaporation of convective precipitation. +!> - Update column-integrated tendencies to account for evaporation of convective precipitation. + do k = km, 1, -1 + do i = 1, im + if (k .le. kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i).and.k.lt.ktcon(i)) then + aup = 1. + if(k.le.kb(i)) aup = 0. + adw = 1. + if(k.ge.jmin(i)) adw = 0. + rain = aup * pwo(i,k) + adw * edto(i) * pwdo(i,k) + rn(i) = rn(i) + rain * xmb(i) * .001 * dt2 + endif + if(flg(i).and.k.lt.ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i).gt.0..and.qcond(i).lt.0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i).gt.0..and.qcond(i).lt.0..and. + & delq2(i).gt.rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i).gt.0..and.qevap(i).gt.0.) then + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + rn(i) = rn(i) - .001 * qevap(i) * dp / g + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i) + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me.eq.31.and.cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' deep delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +c +c precipitation rate converted to actual precip +c in unit of m instead of kg +c + do i = 1, im + if(cnvflg(i)) then +c +c in the event of upper level rain evaporation and lower level downdraft +c moistening, rn can become negative, in this case, we back out of the +c heating and the moistening +c + + if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0. + if(rn(i).le.0.) then + rn(i) = 0. + else + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 1 + cldwrk(i) = aa1(i) + endif + endif + enddo +c +c convective cloud water +c +!> - Calculate convective cloud water. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +c +c convective cloud cover +c +!> - Calculate convective cloud cover. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.6) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo + +c +c cloud water +c +!> - Separate detrained cloud water into liquid and ice species as a function of temperature only. + if (ncloud.gt.0) then +! + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.gt.kb(i).and.k.le.ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (ql(i,k,2) .gt. -999.0) then + ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice + ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water + else + ql(i,k,1) = ql(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +c +!> - If convective precipitation is zero or negative, reset the updated state variables back to their original values (negating convective changes). + do k = 1, km + do i = 1, im + if(cnvflg(i).and.rn(i).le.0.) then + if (k .le. kmax(i)) then + t1(i,k) = to(i,k) + q1(i,k) = qo(i,k) + u1(i,k) = uo(i,k) + v1(i,k) = vo(i,k) + endif + endif + enddo + enddo +! +! hchuang code change +! +!> - Calculate the updraft convective mass flux. + do k = 1, km + do i = 1, im + if(cnvflg(i).and.rn(i).gt.0.) then + if(k.ge.kb(i) .and. k.lt.ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!> - Calculate the detrainment mass flux at cloud top. + do i = 1, im + if(cnvflg(i).and.rn(i).gt.0.) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo +!> - Calculate the downdraft convective mass flux. + do k = 1, km + do i = 1, im + if(cnvflg(i).and.rn(i).gt.0.) then + if(k.ge.1 .and. k.le.jmin(i)) then + dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!! + return +!> @} +!! @} + end +! \section original Original Documentation +! Penetrative convection is simulated following Pan and Wu (1994), which is based on Arakawa and Schubert(1974) as simplified by Grell (1993) and with a saturated downdraft. Convection occurs when the cloud work function (CWF) exceeds a certain threshold. Mass flux of the cloud is determined using a quasi-equilibrium assumption based on this threshold CWF. The CWF is a function of temperature and moisture in each air column of the model gridpoint. The temperature and moisture profiles are adjusted towards the equilibrium CWF within a specified time scale using the deduced mass flux. A major simplification of the original Arakawa-Shubert scheme is to consider only the deepest cloud and not the spectrum of clouds. The cloud model incorporates a downdraft mechanism as well as the evaporation of precipitation. Entrainment of the updraft and detrainment of the downdraft in the sub-cloud layers are included. Downdraft strength is based on the vertical wind shear through the cloud. The critical CWF is a function of the cloud base vertical motion. As the large-scale rising motion becomes strong, the CWF [similar to convective available potential energy (CAPE)] is allowed to approach zero (therefore approaching neutral stability). +! +! Mass fluxes induced in the updraft and the downdraft are allowed to transport momentum. The momentum exchange is calculated through the mass flux formulation in a manner similar to that for heat and moisture. The effect of the convection-induced pressure gradient force on cumulus momentum transport is parameterized in terms of mass flux and vertical wind shear (Han and Pan, 2006). As a result, the cumulus momentum exchange is reduced by about 55 % compared to the full exchange. +! +! The entrainment rate in cloud layers is dependent upon environmental humidity (Han and Pan, 2010). A drier environment increases the entrainment, suppressing the convection. The entrainment rate in sub-cloud layers is given as inversely proportional to height. The detrainment rate is assumed to be a constant in all layers and equal to the entrainment rate value at cloud base, which is O(10-4). The liquid water in the updraft layer is assumed to be detrained from the layers above the level of the minimum moist static energy into the grid-scale cloud water with conversion parameter of 0.002 m-1, which is same as the rain conversion parameter. +! +! Following Han and Pan (2010), the trigger condition is that a parcel lifted from the convection starting level without entrainment must reach its level of free convection within 120-180 hPa of ascent, proportional to the large-scale vertical velocity. This is intended to produce more convection in large-scale convergent regions but less convection in large-scale subsidence regions. Another important trigger mechanism is to include the effect of environmental humidity in the sub-cloud layer, taking into account convection inhibition due to existence of dry layers below cloud base. On the other hand, the cloud parcel might overshoot beyond the level of neutral buoyancy due to its inertia, eventually stopping its overshoot at cloud top. The CWF is used to model the overshoot. The overshoot of the cloud top is stopped at the height where a parcel lifted from the neutral buoyancy level with energy equal to 10% of the CWF would first have zero energy. +! +! Deep convection parameterization (SAS) modifications include: +! - Detraining cloud water from every updraft layer +! - Starting convection from the level of maximum moist static energy within PBL +! - Random cloud top is eliminated and only deepest cloud is considered +! - Cloud water is detrained from every cloud layer +! - Finite entrainment and detrainment rates for heat, moisture, and momentum are specified +! - Similar to shallow convection scheme, +! - entrainment rate is given to be inversely proportional to height in sub-cloud layers +! - detrainment rate is set to be a constant as entrainment rate at the cloud base. +! -Above cloud base, an organized entrainment is added, which is a function of environmental relative humidity diff --git a/gsmphys/satmedmfvdiff.f b/gsmphys/satmedmfvdiff.f new file mode 100644 index 00000000..4c7e32f4 --- /dev/null +++ b/gsmphys/satmedmfvdiff.f @@ -0,0 +1,1566 @@ +!!!!! ================================================================== !!!!! +! subroutine 'satmedmfvdif.f' computes subgrid vertical turbulence mixing +! using scale-aware TKE-based moist eddy-diffusion mass-flux (EDMF) parameterization +! (by Jongil Han) +! +! For the convective boundary layer, the scheme adopts +! EDMF parameterization (Siebesma et al., 2007) to take +! into account nonlocal transport by large eddies (mfpblt.f). +! +! A new mass-flux parameterization for stratocumulus-top-induced turbulence +! mixing has been introduced (previously, it was eddy diffusion form) +! [mfscu.f]. +! +! For local turbulence mixing, a TKE closure model is used. +! +!---------------------------------------------------------------------- + +! ======= Updates at GFDL ======= +! 1) Jul 2019 by Kun Gao +! goal: to allow for tke advection +! change: rearange tracers (q1) and their tendencies (rtg) +! tke no longer needs to be the last tracer +! 2) Nov 2019 by Kun Gao +! turn off non-local mixing for hydrometers to avoid unphysical negative values +! 3) Jun 2020 by Kun Gao +! a) add option for turning off upper-limter on background diff. in inversion layer +! over land/ice points (cap_k0_land) +! b) use different xkzm_m,xkzm_h for land, ocean and sea ice points +! c) add option for turning off HB19 formula for surface backgroud diff. (do_dk_hb19) + + subroutine satmedmfvdif(ix,im,km,ntrac,ntcw,ntiw,ntke, + & dv,du,tdt,rtg_in,u1,v1,t1,q1_in,swh,hlw,xmu,garea,islimsk, + & psk,rbsoil,zorl,u10m,v10m,fm,fh, + & tsea,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,delt, + & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl, + & kinver,xkzm_mo,xkzm_ho,xkzm_ml,xkzm_hl,xkzm_mi,xkzm_hi, + & xkzm_s,xkzinv,do_dk_hb19,xkzm_lim,xkgdx, + & rlmn, rlmx, cap_k0_land, dkt_out) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, rv => con_rv, hvap => con_hvap + &, hfus => con_hfus, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 +! + implicit none +! +!---------------------------------------------------------------------- + integer ix, im, km, ntrac, ntcw, ntiw, ntke, ntcw_new + integer kpbl(im), kinver(im), islimsk(im) +! + real(kind=kind_phys) delt, xkzm_s, xkzm_lim, + & xkzm_mo, xkzm_ho, xkzm_ml, xkzm_hl, + & xkzm_mi, xkzm_hi + real(kind=kind_phys) dv(im,km), du(im,km), + & tdt(im,km), rtg(im,km,ntrac), + & u1(ix,km), v1(ix,km), + & t1(ix,km), q1(ix,km,ntrac), + & swh(ix,km), hlw(ix,km), + & xmu(im), garea(im), + & psk(ix), rbsoil(im), + & zorl(im), tsea(im), + & u10m(im), v10m(im), + & fm(im), fh(im), + & evap(im), heat(im), + & stress(im), spd1(im), + & prsi(ix,km+1), del(ix,km), + & prsl(ix,km), prslk(ix,km), + & phii(ix,km+1), phil(ix,km), + & dusfc(im), dvsfc(im), + & dtsfc(im), dqsfc(im), + & hpbl(im), + & q1_in(ix,km,ntrac), + & rtg_in(im,km,ntrac) +! kgao note - q1 and rtg are local var now + +! + logical dspheat, cap_k0_land, do_dk_hb19 +! flag for tke dissipative heating + real(kind=kind_phys),dimension(1:im,1:km),intent(OUT)::dkt_out + +! +!---------------------------------------------------------------------- +!*** +!*** local variables +!*** + integer i,is,k,kk,n,km1,kmpbl,kmscu,ntrac1 + integer lcld(im),kcld(im),krad(im),mrad(im) + integer kx1(im), kpblx(im) +! + real(kind=kind_phys) tke(im,km), tkeh(im,km-1) +! + real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), + & qlx(im,km), thetae(im,km),thlx(im,km), + & slx(im,km), svx(im,km), qtx(im,km), + & tvx(im,km), pix(im,km), radx(im,km-1), + & dku(im,km-1),dkt(im,km-1), dkq(im,km-1), + & cku(im,km-1),ckt(im,km-1) +! + real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), + & qstl(im,km) +! + real(kind=kind_phys) dtdz1(im), gdx(im), + & phih(im), phim(im), prn(im,km-1), + & rbdn(im), rbup(im), thermal(im), + & ustar(im), wstar(im), hpblx(im), + & ust3(im), wst3(im), + & z0(im), crb(im), + & hgamt(im), hgamq(im), + & wscale(im),vpert(im), + & zol(im), sflux(im), radj(im), + & tx1(im), tx2(im) +! + real(kind=kind_phys) radmin(im) +! + real(kind=kind_phys) zi(im,km+1), zl(im,km), zm(im,km), + & xkzo(im,km-1),xkzmo(im,km-1), + & xkzm_hx(im), xkzm_mx(im), + & rdzt(im,km-1), + & al(im,km-1), ad(im,km), au(im,km-1), + & f1(im,km), f2(im,km*(ntrac-1)) +! + real(kind=kind_phys) elm(im,km), ele(im,km), rle(im,km-1), + & ckz(im,km), chz(im,km), + & diss(im,km-1),prod(im,km-1), + & bf(im,km-1), shr2(im,km-1), + & xlamue(im,km-1), xlamde(im,km-1), + & gotvx(im,km), rlam(im,km-1) +! +! variables for updrafts (thermals) +! + real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), + & ucko(im,km), vcko(im,km), + & buou(im,km), xmf(im,km) +! +! variables for stratocumulus-top induced downdrafts +! + real(kind=kind_phys) tcdo(im,km), qcdo(im,km,ntrac), + & ucdo(im,km), vcdo(im,km), + & buod(im,km), xmfd(im,km) +! + logical pblflg(im), sfcflg(im), flg(im) + logical scuflg(im), pcnvflg(im) + logical mlenflg +! +! pcnvflg: true for unstable pbl +! + real(kind=kind_phys) aphi16, aphi5, + & wfac, cfac, + & gamcrt, gamcrq, sfcfrac, + & conq, cont, conw, + & dsdz2, dsdzt, dkmax, + & dsig, dt2, dtodsd, + & dtodsu, g, factor, dz, + & gocp, gravi, zol1, zolcru, + & buop, shrp, dtn, cdtn, + & prnum, prmax, prmin, prtke, + & prscu, dw2, dw2min, zk, + & elmfac, elefac, dspmax, + & alp, clwt, cql, + & f0, robn, crbmin, crbmax, + & es, qs, value, onemrh, + & cfh, gamma, elocp, el2orc, + & epsi, beta, chx, cqx, + & rdt, rdz, qmin, qlmin, + & ri, rimin, + & rbcr, rbint, tdzmin, + & rlmn, rlmx, elmx, + & ttend, utend, vtend, qtend, + & zfac, zfmin, vk, spdk2, + & tkmin, xkzinv, dspfac, xkgdx, + & zlup, zldn, bsum, + & tem, tem1, tem2, + & ptem, ptem0, ptem1, ptem2 +! + real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck +! + real(kind=kind_phys) qlcr, zstblmax +! + real(kind=kind_phys) h1 +!! + parameter(gravi=1.0/grav) + parameter(g=grav) + parameter(gocp=g/cp) + parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa +! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) + parameter(wfac=7.0,cfac=4.5) + parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) + parameter(vk=0.4,rimin=-100.) + parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) + !parameter(rlmn=30.,rlmx=500.,elmx=500.) + parameter(prmin=0.25,prmax=4.0,prtke=1.0,prscu=0.67) + parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) + parameter(tkmin=1.e-9,dspfac=0.5,dspmax=10.0) + parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) + parameter(aphi5=5.,aphi16=16.) + parameter(elmfac=1.0,elefac=1.0,cql=100.) + parameter(dw2min=1.e-4,dkmax=1000.) + parameter(qlcr=3.5e-5,zstblmax=2500.) !,xkzinv=0.15) + parameter(h1=0.33333333) + parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15,ce0=0.4) + parameter(rchck=1.5,cdtn=25.) + + elmx = rlmx +! +!************************************************************************ +! +! kgao note (jul 2019) +! the code was originally written assuming ntke=ntrac +! in this version ntke does not need to be equal to ntrac +! in the following we rearrange q1 (and rtg) so that tke is the last tracer +! + !if(ntrac >= 3 ) then + if(ntke == ntrac) then ! tke is the last tracer + q1(:,:,:) = q1_in(:,:,:) + rtg(:,:,:) = rtg_in(:,:,:) + else ! tke is not + do kk = 1, ntke-1 + q1(:,:,kk) = q1_in(:,:,kk) + rtg(:,:,kk) = rtg_in(:,:,kk) + enddo + do kk = ntke+1, ntrac + q1(:,:,kk-1) = q1_in(:,:,kk) + rtg(:,:,kk-1) = rtg_in(:,:,kk) + enddo + q1(:,:,ntrac) = q1_in(:,:,ntke) + rtg(:,:,ntrac) = rtg_in(:,:,ntke) + endif + !endif +! + dt2 = delt + rdt = 1. / dt2 +! + ntrac1 = ntrac - 1 + km1 = km - 1 + kmpbl = km / 2 + kmscu = km / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + xmf(i,k) = 0. + xmfd(i,k) = 0. + buou(i,k) = 0. + buod(i,k) = 0. + ckz(i,k) = ck1 + chz(i,k) = ch1 + enddo + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo + do k=1,km + do i=1,im + zm(i,k) = zi(i,k+1) + enddo + enddo +! horizontal grid size + do i=1,im + gdx(i) = sqrt(garea(i)) + enddo +! + do k=1,km + do i=1,im + tke(i,k) = max(q1_in(i,k,ntke), tkmin) ! tke at layer centers + enddo + enddo + do k=1,km1 + do i=1,im + tkeh(i,k) = 0.5 * (tke(i,k) + tke(i,k+1)) ! tke at interfaces + enddo + enddo +! + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + prn(i,k) = 1.0 + enddo + enddo + +! Han and Bretherton, 2019 +! set background diffusivities as a function of +! horizontal grid size with xkzm_h & xkzm_m for gdx >= xkgdx +! and 0.01 for gdx=5m, i.e., +! xkzm_hx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) +! xkzm_mx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) +! + do i=1,im + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + + ! kgao change - set surface value of background diff (dk) below + if (do_dk_hb19) then ! use eq43 in HB2019 + + if(gdx(i) >= xkgdx) then ! resolution coarser than xkgdx + if( islimsk(i) == 1 ) then ! land points + xkzm_hx(i) = xkzm_hl + xkzm_mx(i) = xkzm_ml + elseif ( islimsk(i) == 2 ) then! sea ice points + xkzm_hx(i) = xkzm_hi + xkzm_mx(i) = xkzm_mi + else ! ocean points + xkzm_hx(i) = xkzm_ho + xkzm_mx(i) = xkzm_mo + endif + else ! resolution finer than xkgdx + tem = 1. / (xkgdx - 5.) + if ( islimsk(i) == 1 ) then ! land points + tem1 = (xkzm_hl - xkzm_lim) * tem + tem2 = (xkzm_ml - xkzm_lim) * tem + elseif ( islimsk(i) == 2 ) then! sea ice points + tem1 = (xkzm_hi - xkzm_lim) * tem + tem2 = (xkzm_mi - xkzm_lim) * tem + else ! ocean points + tem1 = (xkzm_ho - xkzm_lim) * tem + tem2 = (xkzm_mo - xkzm_lim) * tem + endif + ptem = gdx(i) - 5. + xkzm_hx(i) = xkzm_lim + tem1 * ptem + xkzm_mx(i) = xkzm_lim + tem2 * ptem + endif + + else ! use values in the namelist; no res dependency + + if ( islimsk(i) == 1 ) then ! land points + xkzm_hx(i) = xkzm_hl + xkzm_mx(i) = xkzm_ml + elseif ( islimsk(i) == 2 ) then ! sea ice points + xkzm_hx(i) = xkzm_hi + xkzm_mx(i) = xkzm_mi + else ! ocean points + xkzm_hx(i) = xkzm_ho + xkzm_mx(i) = xkzm_mo + endif + + endif + enddo + + do k = 1,km1 + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem1 = tem1 * tem1 * 10.0 + xkzo(i,k) = xkzm_hx(i) * min(1.0, exp(-tem1)) +! vertical background diffusivity for momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_mx(i) + kx1(i) = k + 1 + else + if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) + tem1 = 1.0 - prsi(i,k+1) * tx2(i) + tem1 = tem1 * tem1 * 5.0 + xkzmo(i,k) = xkzm_mx(i) * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! + do i = 1,im + z0(i) = 0.01 * zorl(i) + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + kpbl(i) = 1 + hpbl(i) = 0. + kpblx(i) = 1 + hpblx(i) = 0. + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + pcnvflg(i)= .false. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + mrad(i) = km1 + krad(i) = 1 + lcld(i) = km1 + kcld(i) = km1 + endif + enddo +! + do k=1,km + do i=1,im + pix(i,k) = psk(i) / prslk(i,k) + theta(i,k) = t1(i,k) * pix(i,k) + if(ntiw > 0) then + tem = max(q1_in(i,k,ntcw),qlmin) + tem1 = max(q1_in(i,k,ntiw),qlmin) + qlx(i,k) = tem + tem1 + ptem = hvap*tem + (hvap+hfus)*tem1 + slx(i,k) = cp * t1(i,k) + phil(i,k) - ptem + else + qlx(i,k) = max(q1_in(i,k,ntcw),qlmin) + slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) + endif + tem2 = 1.+fv*max(q1(i,k,1),qmin)-qlx(i,k) + thvx(i,k) = theta(i,k) * tem2 + tvx(i,k) = t1(i,k) * tem2 + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + thlx(i,k) = theta(i,k) - pix(i,k)*elocp*qlx(i,k) + thlvx(i,k) = thlx(i,k) * (1. + fv * qtx(i,k)) + svx(i,k) = cp * tvx(i,k) + ptem1 = elocp * pix(i,k) * max(q1(i,k,1),qmin) + thetae(i,k)= theta(i,k) + ptem1 + gotvx(i,k) = g / tvx(i,k) + enddo + enddo +! +! The background vertical diffusivities in the inversion layers are limited +! to be less than or equal to xkzminv +! + do k = 1,km1 + do i=1,im + tem1 = (tvx(i,k+1)-tvx(i,k)) * rdzt(i,k) + + if (cap_k0_land) then + if(tem1 > 1.e-5) then + xkzo(i,k) = min(xkzo(i,k),xkzinv) + xkzmo(i,k) = min(xkzmo(i,k),xkzinv) + endif + else + ! kgao note: do not apply upper-limiter over land and sea ice points + ! (consistent with change in satmedmfdifq.f in Jun 2020) + if(tem1 > 0. .and. islimsk(i) == 0 ) then + xkzo(i,k) = min(xkzo(i,k), xkzinv) + xkzmo(i,k) = min(xkzmo(i,k), xkzinv) + endif + endif + + enddo + enddo +! +! compute an empirical cloud fraction based on +! Xu & Randall's (1996,JAS) study +! + do k = 1, km + do i = 1, im + plyr(i,k) = 0.01 * prsl(i,k) ! pa to mb (hpa) +! --- ... compute relative humidity + es = 0.01 * fpvs(t1(i,k)) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k) + epsm1*es)) + rhly(i,k) = max(0.0, min(1.0, max(qmin, q1(i,k,1))/qs)) + qstl(i,k) = qs + enddo + enddo +! + do k = 1, km + do i = 1, im + cfly(i,k) = 0. + clwt = 1.0e-6 * (plyr(i,k)*0.001) + if (qlx(i,k) > clwt) then + onemrh= max(1.e-10, 1.0-rhly(i,k)) + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) + tem1 = cql / tem1 + value = max(min( tem1*qlx(i,k), 50.0), 0.0) + tem2 = sqrt(sqrt(rhly(i,k))) + cfly(i,k) = min(max(tem2*(1.0-exp(-value)), 0.0), 1.0) + endif + enddo + enddo +! +! compute buoyancy modified by clouds +! + do k = 1, km1 + do i = 1, im + tem = 0.5 * (svx(i,k) + svx(i,k+1)) + tem1 = 0.5 * (t1(i,k) + t1(i,k+1)) + tem2 = 0.5 * (qstl(i,k) + qstl(i,k+1)) + cfh = min(cfly(i,k+1),0.5*(cfly(i,k)+cfly(i,k+1))) + alp = g / tem + gamma = el2orc * tem2 / (tem1**2) + epsi = tem1 / elocp + beta = (1. + gamma*epsi*(1.+fv)) / (1. + gamma) + chx = cfh * alp * beta + (1. - cfh) * alp + cqx = cfh * alp * hvap * (beta - epsi) + cqx = cqx + (1. - cfh) * fv * g + ptem1 = (slx(i,k+1)-slx(i,k))*rdzt(i,k) + ptem2 = (qtx(i,k+1)-qtx(i,k))*rdzt(i,k) + bf(i,k) = chx * ptem1 + cqx * ptem2 + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k=1,km1 + do i=1,im + dku(i,k) = 0. + dkt(i,k) = 0. + dkq(i,k) = 0. + cku(i,k) = 0. + ckt(i,k) = 0. + tem = zi(i,k+1)-zi(i,k) + radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) + enddo + enddo +! + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + enddo +! +! compute critical bulk richardson number +! + do i = 1,im + if(pblflg(i)) then +! thermal(i) = thvx(i,1) + thermal(i) = thlvx(i,1) + crb(i) = rbcr + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + enddo +! + do i=1,im + dtdz1(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! + do i=1,im + ustar(i) = sqrt(stress(i)) + enddo +! +! compute buoyancy (bf) and winshear square +! + do k = 1, km1 + do i = 1, im + rdz = rdzt(i,k) +! bf(i,k) = gotvx(i,k)*(thvx(i,k+1)-thvx(i,k))*rdz + dw2 = (u1(i,k)-u1(i,k+1))**2 + & + (v1(i,k)-v1(i,k+1))**2 + shr2(i,k) = max(dw2,dw2min)*rdz*rdz + enddo + enddo +! +! find pbl height based on bulk richardson number (mrf pbl scheme) +! and also for diagnostic purpose +! + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + enddo +! + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) +! rbup(i) = (thvx(i,k)-thermal(i))* +! & (g*zl(i,k)/thvx(i,1))/spdk2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpblx(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(kpblx(i) > 1) then + k = kpblx(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpblx(i) < zi(i,kpblx(i))) kpblx(i)=kpblx(i)-1 + else + hpblx(i) = zl(i,1) + kpblx(i) = 1 + endif + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + if(kpbl(i) <= 1) pblflg(i)=.false. + enddo +! +! compute similarity parameters +! + do i=1,im + zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + if(sfcflg(i)) then + zol(i) = min(zol(i),-zfmin) + else + zol(i) = max(zol(i),zfmin) + endif +! + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then + tem = 1.0 / (1. - aphi16*zol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + endif + enddo +! + do i=1,im + if(pblflg(i)) then + if(zol(i) < zolcru) then + pcnvflg(i) = .true. + endif + wst3(i) = gotvx(i,1)*sflux(i)*hpbl(i) + wstar(i)= wst3(i)**h1 + ust3(i) = ustar(i)**3. + wscale(i)=(ust3(i)+wfac*vk*wst3(i)*sfcfrac)**h1 + ptem = ustar(i)/aphi5 + wscale(i) = max(wscale(i),ptem) + endif + enddo +! +! compute a thermal excess +! + do i = 1,im + if(pcnvflg(i)) then + hgamt(i) = heat(i)/wscale(i) + hgamq(i) = evap(i)/wscale(i) + vpert(i) = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert(i) = max(vpert(i),0.) + tem = min(cfac*vpert(i),gamcrt) + thermal(i)= thermal(i) + tem + endif + enddo +! +! enhance the pbl height by considering the thermal excess +! (overshoot pbl top) +! + do i=1,im + flg(i) = .true. + if(pcnvflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pcnvflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) then + kpbl(i) = kpbl(i) - 1 + endif + if(kpbl(i) <= 1) then + pcnvflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! look for stratocumulus +! + do i=1,im + flg(i) = scuflg(i) + enddo + do k = 1, km1 + do i=1,im + if(flg(i).and.zl(i,k) >= zstblmax) then + lcld(i)=k + flg(i)=.false. + endif + enddo + enddo + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k <= lcld(i)) then + if(qlx(i,k) >= qlcr) then + kcld(i)=k + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false. + enddo +! + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k <= kcld(i)) then + if(qlx(i,k) >= qlcr) then + if(radx(i,k) < radmin(i)) then + radmin(i)=radx(i,k) + krad(i)=k + endif + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false. + if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false. + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute components for mass flux mixing by large thermals +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + tcko(i,k) = t1(i,k) + ucko(i,k) = u1(i,k) + vcko(i,k) = v1(i,k) + endif + if(scuflg(i)) then + tcdo(i,k) = t1(i,k) + ucdo(i,k) = u1(i,k) + vcdo(i,k) = v1(i,k) + endif + enddo + enddo + do kk = 1, ntrac1 + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + qcko(i,k,kk) = q1(i,k,kk) + endif + if(scuflg(i)) then + qcdo(i,k,kk) = q1(i,k,kk) + endif + enddo + enddo + enddo + +! kgao note - change ntcw if q1 is rearranged + if (ntke > ntcw) then + ntcw_new = ntcw + else + ntcw_new = ntcw-1 + endif +! EDMF parameterization Siebesma et al.(2007) + call mfpblt(im,ix,km,kmpbl,ntcw_new,ntrac1,dt2, + & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, + & gdx,hpbl,kpbl,vpert,buou,xmf, + & tcko,qcko,ucko,vcko,xlamue) +! mass-flux parameterization for stratocumulus-top-induced turbulence mixing + call mfscu(im,ix,km,kmscu,ntcw_new,ntrac1,dt2, + & scuflg,zl,zm,q1,t1,u1,v1,plyr,pix, + & thlx,thvx,thlvx,gdx,thetae,radj, + & krad,mrad,radmin,buod,xmfd, + & tcdo,qcdo,ucdo,vcdo,xlamde) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute prandtl number and exchange coefficient varying with height +! + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + tem = phih(i)/phim(i) + ptem = -3.*(max(zi(i,k+1)-sfcfrac*hpbl(i),0.))**2. + & /hpbl(i)**2. + if(pcnvflg(i)) then + prn(i,k) = 1. + (tem-1.)*exp(ptem) + else + prn(i,k) = tem + endif + prn(i,k) = min(prn(i,k),prmax) + prn(i,k) = max(prn(i,k),prmin) +! + ckz(i,k) = ck1 + (ck0-ck1)*exp(ptem) + ckz(i,k) = min(ckz(i,k),ck0) + ckz(i,k) = max(ckz(i,k),ck1) + chz(i,k) = ch1 + (ch0-ch1)*exp(ptem) + chz(i,k) = min(chz(i,k),ch0) + chz(i,k) = max(chz(i,k),ch1) + endif + enddo + enddo + +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute an asymtotic mixing length +! + do k = 1, km1 + do i = 1, im + zlup = 0.0 + bsum = 0.0 + mlenflg = .true. + do n = k, km1 + if(mlenflg) then + dz = zl(i,n+1) - zl(i,n) + ptem = gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))*dz +! ptem = gotvx(i,n)*(thlvx(i,n+1)-thlvx(i,k))*dz + bsum = bsum + ptem + zlup = zlup + dz + if(bsum >= tke(i,k)) then + if(ptem >= 0.) then + tem2 = max(ptem, zfmin) + else + tem2 = min(ptem, -zfmin) + endif + ptem1 = (bsum - tke(i,k)) / tem2 + zlup = zlup - ptem1 * dz + zlup = max(zlup, 0.) + mlenflg = .false. + endif + endif + enddo + zldn = 0.0 + bsum = 0.0 + mlenflg = .true. + do n = k, 1, -1 + if(mlenflg) then + if(n == 1) then + dz = zl(i,1) + tem1 = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + else + dz = zl(i,n) - zl(i,n-1) + tem1 = thvx(i,n-1) +! tem1 = thlvx(i,n-1) + endif + ptem = gotvx(i,n)*(thvx(i,k)-tem1)*dz +! ptem = gotvx(i,n)*(thlvx(i,k)-tem1)*dz + bsum = bsum + ptem + zldn = zldn + dz + if(bsum >= tke(i,k)) then + if(ptem >= 0.) then + tem2 = max(ptem, zfmin) + else + tem2 = min(ptem, -zfmin) + endif + ptem1 = (bsum - tke(i,k)) / tem2 + zldn = zldn - ptem1 * dz + zldn = max(zldn, 0.) + mlenflg = .false. + endif + endif + enddo +! + tem = 0.5 * (zi(i,k+1)-zi(i,k)) + tem1 = min(tem, rlmn) +! + ptem2 = min(zlup,zldn) + rlam(i,k) = elmfac * ptem2 + rlam(i,k) = max(rlam(i,k), tem1) + rlam(i,k) = min(rlam(i,k), rlmx) +! + ptem2 = sqrt(zlup*zldn) + ele(i,k) = elefac * ptem2 + ele(i,k) = max(ele(i,k), tem1) + ele(i,k) = min(ele(i,k), elmx) +! + enddo + enddo +! + do k = 1, km1 + do i = 1, im + tem = vk * zl(i,k) + if (zol(i) < 0.) then + ptem = 1. - 100. * zol(i) + ptem1 = ptem**0.2 + zk = tem * ptem1 + elseif (zol(i) >= 1.) then + zk = tem / 3.7 + else + ptem = 1. + 2.7 * zol(i) + zk = tem / ptem + endif + elm(i,k) = zk*rlam(i,k)/(rlam(i,k)+zk) +! + dz = zi(i,k+1) - zi(i,k) + tem = max(gdx(i),dz) + elm(i,k) = min(elm(i,k), tem) + ele(i,k) = min(ele(i,k), tem) +! + enddo + enddo + do i = 1, im + elm(i,km) = elm(i,km1) + ele(i,km) = ele(i,km1) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute eddy diffusivities +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km1 + do i = 1, im + tem = 0.5 * (elm(i,k) + elm(i,k+1)) + tem = tem * sqrt(tkeh(i,k)) + if(k < kpbl(i)) then + if(pblflg(i)) then + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else + dkt(i,k) = chz(i,k) * tem + dku(i,k) = dkt(i,k) * prn(i,k) + endif + else + ri = max(bf(i,k)/shr2(i,k),rimin) + if(ri < 0.) then ! unstable regime + dku(i,k) = ck1 * tem + dkt(i,k) = rchck * dku(i,k) + else ! stable regime + dkt(i,k) = ch1 * tem + prnum = 1.0 + 2.1*ri + prnum = min(prnum,prmax) + dku(i,k) = dkt(i,k) * prnum + endif + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + tem1 = ckz(i,k) * tem + ptem1 = tem1 / prscu + dku(i,k) = max(dku(i,k), tem1) + dkt(i,k) = max(dkt(i,k), ptem1) + endif + endif +! + dkq(i,k) = prtke * dkt(i,k) +! + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dkq(i,k) = min(dkq(i,k),dkmax) + dkq(i,k) = max(dkq(i,k),xkzo(i,k)) + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) +! + enddo + enddo +! + do i = 1, im + if(scuflg(i)) then + k = krad(i) + tem = bf(i,k) / gotvx(i,k) + tem1 = max(tem, tdzmin) + ptem = radj(i) / tem1 + dkt(i,k) = dkt(i,k) + ptem + dku(i,k) = dku(i,k) + ptem + dkq(i,k) = dkq(i,k) + ptem + endif + enddo + +! kgao + do k=1,km1 + do i=1,im + dkt_out(i,k) = dkt(i,k) + enddo + enddo + +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute buoyancy and shear productions of tke +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km1 + do i = 1, im + if (k == 1) then + tem = -dkt(i,1) * bf(i,1) +! if(pcnvflg(i)) then +! ptem1 = xmf(i,1) * buou(i,1) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem2 = xmfd(i,1) * buod(i,1) + else + ptem2 = 0. + endif + tem = tem + ptem1 + ptem2 + buop = 0.5 * (gotvx(i,1) * sflux(i) + tem) +! + tem1 = dku(i,1) * shr2(i,1) +! + tem = (u1(i,2)-u1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem1 = 0.5 * ptem * (u1(i,2)-ucko(i,2)) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = ucdo(i,1)+ucdo(i,2)-u1(i,1)-u1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem1 = ptem1 + ptem +! + tem = (v1(i,2)-v1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem2 = 0.5 * ptem * (v1(i,2)-vcko(i,2)) +! else + ptem2 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = vcdo(i,1)+vcdo(i,2)-v1(i,1)-v1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem2 = ptem2 + ptem +! +! tem2 = stress(i)*spd1(i)/zl(i,1) + tem2 = stress(i)*ustar(i)*phim(i)/(vk*zl(i,1)) + shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) + else + tem1 = -dkt(i,k-1) * bf(i,k-1) + tem2 = -dkt(i,k) * bf(i,k) + tem = 0.5 * (tem1 + tem2) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = 0.5 * (xmf(i,k-1) + xmf(i,k)) + ptem1 = ptem * buou(i,k) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = 0.5 * (xmfd(i,k-1) + xmfd(i,k)) + ptem2 = ptem0 * buod(i,k) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + buop = tem + ptem1 + ptem2 +! + tem1 = dku(i,k-1) * shr2(i,k-1) + tem2 = dku(i,k) * shr2(i,k) + tem = 0.5 * (tem1 + tem2) + tem1 = (u1(i,k+1)-u1(i,k))*rdzt(i,k) + tem2 = (u1(i,k)-u1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (u1(i,k)-ucko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (ucdo(i,k)-u1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = tem + ptem1 + ptem2 + tem1 = (v1(i,k+1)-v1(i,k))*rdzt(i,k) + tem2 = (v1(i,k)-v1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (v1(i,k)-vcko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (vcdo(i,k)-v1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = shrp + ptem1 + ptem2 + endif + prod(i,k) = buop + shrp + enddo + enddo +! +!---------------------------------------------------------------------- +! first predict tke due to tke production & dissipation(diss) +! + do k = 1,km1 + do i=1,im + rle(i,k) = ce0 / ele(i,k) + enddo + enddo + kk = max(nint(dt2/cdtn), 1) + dtn = dt2 / float(kk) + do n = 1, kk + do k = 1,km1 + do i=1,im + tem = sqrt(tke(i,k)) + diss(i,k) = rle(i,k) * tke(i,k) * tem + tem1 = prod(i,k) + tke(i,k) / dtn + diss(i,k)=max(min(diss(i,k), tem1), 0.) + tke(i,k) = tke(i,k) + dtn * (prod(i,k)-diss(i,k)) ! no diffusion yet + tke(i,k) = max(tke(i,k), tkmin) + enddo + enddo + enddo +! +! compute updraft & downdraft properties for tke +! + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then +! kgao change +! qcko(i,k,ntke) = tke(i,k) + qcko(i,k,ntrac) = tke(i,k) + endif + if(scuflg(i)) then +! kgao change +! qcdo(i,k,ntke) = tke(i,k) + qcdo(i,k,ntrac) = tke(i,k) + endif + enddo + enddo + do k = 2, kmpbl + do i = 1, im + if (pcnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! kgao change +! qcko(i,k,ntke)=((1.-tem)*qcko(i,k-1,ntke)+tem* +! & (tke(i,k)+tke(i,k-1)))/factor + qcko(i,k,ntrac)=((1.-tem)*qcko(i,k-1,ntrac)+tem* + & (tke(i,k)+tke(i,k-1)))/factor + + endif + enddo + enddo + do k = kmscu, 1, -1 + do i = 1, im + if (scuflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! kgao change +! qcdo(i,k,ntke)=((1.-tem)*qcdo(i,k+1,ntke)+tem* +! & (tke(i,k)+tke(i,k+1)))/factor + qcdo(i,k,ntrac)=((1.-tem)*qcdo(i,k+1,ntrac)+tem* + & (tke(i,k)+tke(i,k+1)))/factor + endif + endif + enddo + enddo +! +!---------------------------------------------------------------------- +! compute tridiagonal matrix elements for turbulent kinetic energy +! + do i=1,im + ad(i,1) = 1.0 + f1(i,1) = tke(i,1) + enddo +! + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkq(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = tke(i,k) + tke(i,k+1) +! kgao change +! ptem = qcko(i,k,ntke) + qcko(i,k+1,ntke) + ptem = qcko(i,k,ntrac) + qcko(i,k+1,ntrac) + f1(i,k) = f1(i,k)-(ptem-tem)*ptem1 + f1(i,k+1) = tke(i,k+1)+(ptem-tem)*ptem2 + else + f1(i,k+1) = tke(i,k+1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = tke(i,k) + tke(i,k+1) +! kgao change +! ptem = qcdo(i,k,ntke) + qcdo(i,k+1,ntke) + ptem = qcdo(i,k,ntrac) + qcdo(i,k+1,ntrac) + f1(i,k) = f1(i,k) + (ptem - tem) * ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) * ptem2 + endif + endif +! + enddo + enddo +c +c solve tridiagonal problem for tke +c + call tridit(im,km,1,al,ad,au,f1,au,f1) +c +c recover tendency of tke +c + do k = 1,km + do i = 1,im +! fix negative tke + f1(i,k) = max(f1(i,k), tkmin) +! kgao change +! qtend = (f1(i,k)-q1(i,k,ntke))*rdt +! rtg(i,k,ntke) = rtg(i,k,ntke)+qtend + qtend = (f1(i,k)-q1(i,k,ntrac))*rdt + rtg(i,k,ntrac) = rtg(i,k,ntrac)+qtend + enddo + enddo +c +c compute tridiagonal matrix elements for heat and moisture (and other tracers, except tke) +c + do i=1,im + ad(i,1) = 1. + f1(i,1) = t1(i,1) + dtdz1(i) * heat(i) + f2(i,1) = q1(i,1,1) + dtdz1(i) * evap(i) + enddo + if(ntrac1 >= 2) then + do kk = 2, ntrac1 + is = (kk-1) * km + do i = 1, im + f2(i,1+is) = q1(i,1,kk) + enddo + enddo + endif +c + do k = 1,km1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + dsdzt = tem1 * gocp + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = t1(i,k) + t1(i,k+1) + ptem = tcko(i,k) + tcko(i,k+1) + f1(i,k) = f1(i,k)+dtodsd*dsdzt-(ptem-tem)*ptem1 + f1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+(ptem-tem)*ptem2 + tem = q1(i,k,1) + q1(i,k+1,1) + ptem = qcko(i,k,1) + qcko(i,k+1,1) + f2(i,k) = f2(i,k) - (ptem - tem) * ptem1 + f2(i,k+1) = q1(i,k+1,1) + (ptem - tem) * ptem2 + else + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + f2(i,k+1) = q1(i,k+1,1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = tcdo(i,k) + tcdo(i,k+1) + tem = t1(i,k) + t1(i,k+1) + f1(i,k) = f1(i,k) + (ptem - tem) * ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) * ptem2 + tem = q1(i,k,1) + q1(i,k+1,1) + ptem = qcdo(i,k,1) + qcdo(i,k+1,1) + f2(i,k) = f2(i,k) + (ptem - tem) * ptem1 + f2(i,k+1) = f2(i,k+1) - (ptem - tem) * ptem2 + endif + endif + enddo + enddo +! + if(ntrac1 >= 2) then + do kk = 2, ntrac1 + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + if(pcnvflg(i) .and. k < kpbl(i)) then + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + tem = dsig * rdzt(i,k) + ptem = 0.5 * tem * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem1 = qcko(i,k,kk) + qcko(i,k+1,kk) + tem2 = q1(i,k,kk) + q1(i,k+1,kk) + ! kgao note - turn off non-local mixing + f2(i,k+is) = f2(i,k+is) ! - (tem1 - tem2) * ptem1 + f2(i,k+1+is)= q1(i,k+1,kk) ! + (tem1 - tem2) * ptem2 + else + f2(i,k+1+is) = q1(i,k+1,kk) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + tem = dsig * rdzt(i,k) + ptem = 0.5 * tem * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem1 = qcdo(i,k,kk) + qcdo(i,k+1,kk) + tem2 = q1(i,k,kk) + q1(i,k+1,kk) + ! kgao note - turn off non-local mixing + f2(i,k+is) = f2(i,k+is) !+ (tem1 - tem2) * ptem1 + f2(i,k+1+is)= f2(i,k+1+is)! - (tem1 - tem2) * ptem2 + endif + endif +! + enddo + enddo + enddo + endif +c +c solve tridiagonal problem for heat and moisture +c + call tridin(im,km,ntrac1,al,ad,au,f1,f2,au,f1,f2) +c +c recover tendencies of heat and moisture +c + do k = 1,km + do i = 1,im + ttend = (f1(i,k)-t1(i,k))*rdt + qtend = (f2(i,k)-q1(i,k,1))*rdt + tdt(i,k) = tdt(i,k)+ttend + rtg(i,k,1) = rtg(i,k,1)+qtend + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend + enddo + enddo +! + if(ntrac1 >= 2) then + do kk = 2, ntrac1 + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (f2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk)+qtend + enddo + enddo + enddo + endif +! +! kgao note - rearrange tracer tendencies +! + !if(ntrac >= 3 ) then + if(ntke == ntrac) then ! tke is the last tracer + rtg_in(:,:,:) = rtg(:,:,:) + else ! tke is not + do kk = 1, ntke-1 + rtg_in(:,:,kk) = rtg(:,:,kk) + enddo + rtg_in(:,:,ntke) = rtg(:,:,ntrac) + do kk = ntke+1, ntrac + rtg_in(:,:,kk) = rtg(:,:,kk-1) + enddo + endif + !endif +! +! add tke dissipative heating to temperature tendency +! + if(dspheat) then + do k = 1,km1 + do i = 1,im +! tem = min(diss(i,k), dspmax) +! ttend = tem / cp + ttend = diss(i,k) / cp + tdt(i,k) = tdt(i,k) + dspfac * ttend + enddo + enddo + endif +c +c compute tridiagonal matrix elements for momentum +c + do i=1,im + ad(i,1) = 1.0 + dtdz1(i) * stress(i) / spd1(i) + f1(i,1) = u1(i,1) + f2(i,1) = v1(i,1) + enddo +c + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dku(i,k) * rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = u1(i,k) + u1(i,k+1) + ptem = ucko(i,k) + ucko(i,k+1) + f1(i,k) = f1(i,k) - (ptem - tem) * ptem1 + f1(i,k+1) = u1(i,k+1) + (ptem - tem) * ptem2 + tem = v1(i,k) + v1(i,k+1) + ptem = vcko(i,k) + vcko(i,k+1) + f2(i,k) = f2(i,k) - (ptem - tem) * ptem1 + f2(i,k+1) = v1(i,k+1) + (ptem - tem) * ptem2 + else + f1(i,k+1) = u1(i,k+1) + f2(i,k+1) = v1(i,k+1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = u1(i,k) + u1(i,k+1) + ptem = ucdo(i,k) + ucdo(i,k+1) + f1(i,k) = f1(i,k) + (ptem - tem) *ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) *ptem2 + tem = v1(i,k) + v1(i,k+1) + ptem = vcdo(i,k) + vcdo(i,k+1) + f2(i,k) = f2(i,k) + (ptem - tem) * ptem1 + f2(i,k+1) = f2(i,k+1) - (ptem - tem) * ptem2 + endif + endif +! + enddo + enddo +c +c solve tridiagonal problem for momentum +c + call tridi2(im,km,al,ad,au,f1,f2,au,f1,f2) +c +c recover tendencies of momentum +c + do k = 1,km + do i = 1,im + utend = (f1(i,k)-u1(i,k))*rdt + vtend = (f2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k)+utend + dv(i,k) = dv(i,k)+vtend + dusfc(i) = dusfc(i)+conw*del(i,k)*utend + dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! pbl height for diagnostic purpose +! + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end +! +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine tridit(l,n,nt,cl,cm,cu,rt,au,at) +!----------------------------------------------------------------------- +cc + use machine , only : kind_phys + implicit none + integer is,k,kk,n,nt,l,i + real(kind=kind_phys) fk(l) +cc + real(kind=kind_phys) cl(l,2:n), cm(l,n), cu(l,n-1), + & rt(l,n*nt), + & au(l,n-1), at(l,n*nt), + & fkk(l,2:n-1) +c----------------------------------------------------------------------- + do i=1,l + fk(i) = 1./cm(i,1) + au(i,1) = fk(i)*cu(i,1) + enddo + do k = 1, nt + is = (k-1) * n + do i = 1, l + at(i,1+is) = fk(i) * rt(i,1+is) + enddo + enddo + do k=2,n-1 + do i=1,l + fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fkk(i,k)*cu(i,k) + enddo + enddo + do kk = 1, nt + is = (kk-1) * n + do k=2,n-1 + do i=1,l + at(i,k+is) = fkk(i,k)*(rt(i,k+is)-cl(i,k)*at(i,k+is-1)) + enddo + enddo + enddo + do i=1,l + fk(i) = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + enddo + do k = 1, nt + is = (k-1) * n + do i = 1, l + at(i,n+is) = fk(i)*(rt(i,n+is)-cl(i,n)*at(i,n+is-1)) + enddo + enddo + do kk = 1, nt + is = (kk-1) * n + do k=n-1,1,-1 + do i=1,l + at(i,k+is) = at(i,k+is) - au(i,k)*at(i,k+is+1) + enddo + enddo + enddo +c----------------------------------------------------------------------- + return + end diff --git a/gsmphys/satmedmfvdifq.f b/gsmphys/satmedmfvdifq.f new file mode 100644 index 00000000..4b233c04 --- /dev/null +++ b/gsmphys/satmedmfvdifq.f @@ -0,0 +1,1592 @@ +!!!!! ================================================================== !!!!! +! subroutine 'satmedmfvdifq.f' computes subgrid vertical turbulence mixing +! using scale-aware TKE-based moist eddy-diffusion mass-flux (EDMF) parameterization +! +! --- Overview +! +! Originally developed by Jongil Han at NOAA/NCEP/EMC +! +! 1) For the convective boundary layer, the scheme adopts +! EDMF parameterization (Siebesma et al., 2007) to take +! into account nonlocal transport by large eddies (mfpbltq.f). +! +! 2) A new mass-flux parameterization for stratocumulus-top-induced turbulence +! mixing has been introduced (previously, it was eddy diffusion form) +! [mfscu.f]. +! +! 3) For local turbulence mixing, a TKE closure model is used. +! +! --- Updates +! +! 1) May 2019 by Jongil Han (EMC) +! goals: to have better low-level inversion, +! to reduce the cold bias in lower troposphere, +! to reduce the negative wind speed bias in upper troposphere +! changes: reduce the minimum and maximum characteristic mixing lengths, +! reduce core downdraft and updraft fractions, +! change of updraft top height calculation, +! reduce the background diffusivity with increasing surface layer stability (for inversion) + +! 2) Jul 2019 by Kun Gao (GFDL; kun.gao@noaa.gov) +! goal: to allow for tke advection +! change: rearange tracers (q1) and their tendencies (rtg) +! tke no longer needs to be the last tracer +! 3) Nov 2019 by Kun Gao +! turn off non-local mixing for hydrometers to avoid unphysical negative values +! 4) Jan 2020 by Kun Gao +! add rlmn2 parameter (set to 10.) to be consistent with EMC's version +! 5) Jun 2020 by Kun Gao +! a) disable the upper-limter on background diff. in inversion layer +! over land points to be consistent with EMC's version +! b) use different xkzm_m,xkzm_h for land, ocean and sea ice points +! c) add option for turning off HB19 formula for surface backgroud diff. (do_dk_hb19) +! +! 6) Jul 2020 from Jongil Han: significant revisions to improve SCu +! a) revised xkzo and rlmnz in inversion layer +! b) limited updraft overshooting +! +!---------------------------------------------------------------------- + subroutine satmedmfvdifq(ix,im,km,ntrac,ntcw,ntiw,ntke, + & dv,du,tdt,rtg_in,u1,v1,t1,q1_in, + & swh,hlw,xmu,garea,zvfun,islimsk, + & psk,rbsoil,zorl,u10m,v10m,fm,fh, + & tsea,heat,evap,stress,spd1,kpbl, + & prsi,del,prsl,prslk,phii,phil,delt, + & dspheat,dusfc,dvsfc,dtsfc,dqsfc,hpbl, + & kinver,xkzm_mo,xkzm_ho,xkzm_ml,xkzm_hl,xkzm_mi,xkzm_hi, + & xkzm_s,xkzinv,rlmx,zolcru,cs0, + & do_dk_hb19,xkgdx,dspfac,bl_upfr,bl_dnfr,dkt_out, + & flux_up, flux_dn) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, rd => con_rd, cp => con_cp + &, rv => con_rv, hvap => con_hvap + &, hfus => con_hfus, fv => con_fvirt + &, eps => con_eps, epsm1 => con_epsm1 +! + implicit none +! +!---------------------------------------------------------------------- + integer ix, im, km, ntrac, ntcw, ntiw, ntke, ntcw_new + integer kpbl(im), kinver(im), islimsk(im) +! + real(kind=kind_phys) delt, xkzm_mo, xkzm_ho, xkzm_s, dspfac, + & bl_upfr, bl_dnfr, xkzm_ml, xkzm_hl, + & xkzm_mi, xkzm_hi + real(kind=kind_phys) dv(im,km), du(im,km), + & tdt(im,km), rtg(im,km,ntrac), + & u1(ix,km), v1(ix,km), + & t1(ix,km), q1(ix,km,ntrac), + & swh(ix,km), hlw(ix,km), + & xmu(im), garea(im), + & zvfun(im), + & psk(ix), rbsoil(im), + & zorl(im), tsea(im), + & u10m(im), v10m(im), + & fm(im), fh(im), + & evap(im), heat(im), + & stress(im), spd1(im), + & prsi(ix,km+1), del(ix,km), + & prsl(ix,km), prslk(ix,km), + & phii(ix,km+1), phil(ix,km), + & dusfc(im), dvsfc(im), + & dtsfc(im), dqsfc(im), + & hpbl(im), + & q1_in(ix,km,ntrac), + & rtg_in(im,km,ntrac) +! kgao note - q1 and rtg are local var now +! + logical dspheat, do_dk_hb19 +! flag for tke dissipative heating + real(kind=kind_phys)::dkt_out(im,km),flux_up(im,km),flux_dn(im,km) +! +!---------------------------------------------------------------------- +!*** +!*** local variables +!*** + integer i,is,k,kk,n,ndt,km1,kmpbl,kmscu,ntrac1 + integer lcld(im),kcld(im),krad(im),mrad(im) + integer kx1(im), kpblx(im) +! + real(kind=kind_phys) tke(im,km), tkeh(im,km-1) +! + real(kind=kind_phys) theta(im,km),thvx(im,km), thlvx(im,km), + & qlx(im,km), thetae(im,km),thlx(im,km), + & slx(im,km), svx(im,km), qtx(im,km), + & tvx(im,km), pix(im,km), radx(im,km-1), + & dku(im,km-1),dkt(im,km-1), dkq(im,km-1), + & cku(im,km-1),ckt(im,km-1) +! + real(kind=kind_phys) plyr(im,km), rhly(im,km), cfly(im,km), + & qstl(im,km) +! + real(kind=kind_phys) dtdz1(im), gdx(im), + & phih(im), phim(im), prn(im,km-1), + & rbdn(im), rbup(im), thermal(im), + & ustar(im), wstar(im), hpblx(im), + & ust3(im), wst3(im), + & z0(im), crb(im), + & hgamt(im), hgamq(im), + & wscale(im),vpert(im), + & zol(im), sflux(im), + & tx1(im), tx2(im) +! + real(kind=kind_phys) radmin(im) +! + real(kind=kind_phys) zi(im,km+1), zl(im,km), zm(im,km), + & xkzo(im,km),xkzmo(im,km), + & xkzm_hx(im), xkzm_mx(im), + & ri(im,km-1), tkmnz(im,km-1), + & rdzt(im,km-1),rlmnz(im,km), + & al(im,km-1), ad(im,km), au(im,km-1), + & f1(im,km), f2(im,km*(ntrac-1)) +! + real(kind=kind_phys) elm(im,km), ele(im,km), + & ckz(im,km), chz(im,km), frik(im), + & diss(im,km-1),prod(im,km-1), + & bf(im,km-1), shr2(im,km-1), + & xlamue(im,km-1), xlamde(im,km-1), + & gotvx(im,km), rlam(im,km-1) +! +! variables for updrafts (thermals) +! + real(kind=kind_phys) tcko(im,km), qcko(im,km,ntrac), + & ucko(im,km), vcko(im,km), + & buou(im,km), xmf(im,km) +! +! variables for stratocumulus-top induced downdrafts +! + real(kind=kind_phys) tcdo(im,km), qcdo(im,km,ntrac), + & ucdo(im,km), vcdo(im,km), + & buod(im,km), xmfd(im,km) +! + logical pblflg(im), sfcflg(im), flg(im) + logical scuflg(im), pcnvflg(im) + logical mlenflg +! +! pcnvflg: true for unstable pbl +! + real(kind=kind_phys) aphi16, aphi5, + & wfac, cfac, + & gamcrt, gamcrq, sfcfrac, + & conq, cont, conw, + & dsdz2, dsdzt, dkmax, + & dsig, dt2, dtodsd, + & dtodsu, g, factor, dz, + & gocp, gravi, zol1, zolcru, + & buop, shrp, dtn, + & prnum, prmax, prmin, prtke, + & prscu, pr0, + & dw2, dw2min, zk, + & elmfac, elefac, dspmax, + & alp, clwt, cql, + & f0, robn, crbmin, crbmax, + & es, qs, value, onemrh, + & cfh, gamma, elocp, el2orc, + & epsi, beta, chx, cqx, + & rdt, rdz, qmin, qlmin, + & rimin, rbcr, rbint, tdzmin, + & rlmn, rlmn1, rlmn2, + & rlmx, elmx, + & ttend, utend, vtend, qtend, + & zfac, zfmin, vk, spdk2, + & tkmin, tkminx, xkgdx, xkzinv, + & zlup, zldn, bsum, cs0, + & tem, tem1, tem2, tem3, + & ptem, ptem0, ptem1, ptem2 +! + real(kind=kind_phys) ck0, ck1, ch0, ch1, ce0, rchck +! + real(kind=kind_phys) qlcr, zstblmax, hcrinv +! + real(kind=kind_phys) h1 +!! + parameter(gravi=1.0/grav) + parameter(g=grav) + parameter(gocp=g/cp) + parameter(cont=cp/g,conq=hvap/g,conw=1.0/g) ! for del in pa +! parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) !kpa + parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp)) + parameter(wfac=7.0,cfac=4.5) + parameter(gamcrt=3.,gamcrq=0.,sfcfrac=0.1) + parameter(vk=0.4,rimin=-100.) +! parameter(rbcr=0.25,zolcru=-0.02,tdzmin=1.e-3) + parameter(rbcr=0.25,tdzmin=1.e-3) + parameter(rlmn=30.,rlmn1=5.,rlmn2=10.) +! parameter(rlmx=300.,elmx=300.) + parameter(prmin=0.25,prmax=4.0) + parameter(pr0=1.0,prtke=1.0,prscu=0.67) + parameter(f0=1.e-4,crbmin=0.15,crbmax=0.35) + parameter(tkmin=1.e-9,tkminx=0.2,dspmax=10.0) + parameter(qmin=1.e-8,qlmin=1.e-12,zfmin=1.e-8) + parameter(aphi5=5.,aphi16=16.) + parameter(elmfac=1.0,elefac=1.0,cql=100.) + parameter(dw2min=1.e-4,dkmax=1000.)!,xkgdx=5000.) + parameter(qlcr=3.5e-5,zstblmax=2500.) !,xkzinv=0.1) + parameter(h1=0.33333333,hcrinv=250.) + parameter(ck0=0.4,ck1=0.15,ch0=0.4,ch1=0.15) +! parameter(ce0=0.4,cs0=0.5) + parameter(ce0=0.4) + parameter(rchck=1.5,ndt=20) +! +!************************************************************************ + elmx = rlmx + dt2 = delt + rdt = 1. / dt2 + dkt_out = 0. + flux_up = 0. + flux_dn = 0. +! +! kgao note (jul 2019) +! the code was originally written assuming ntke=ntrac +! in this version ntke does not need to be equal to ntrac +! in the following we rearrange q1 (and rtg) so that tke is the last tracer +! + !if(ntrac >= 3 ) then + if(ntke == ntrac) then ! tke is the last tracer + q1(:,:,:) = q1_in(:,:,:) + rtg(:,:,:) = rtg_in(:,:,:) + else ! tke is not + do kk = 1, ntke-1 + q1(:,:,kk) = q1_in(:,:,kk) + rtg(:,:,kk) = rtg_in(:,:,kk) + enddo + do kk = ntke+1, ntrac + q1(:,:,kk-1) = q1_in(:,:,kk) + rtg(:,:,kk-1) = rtg_in(:,:,kk) + enddo + q1(:,:,ntrac) = q1_in(:,:,ntke) + rtg(:,:,ntrac) = rtg_in(:,:,ntke) + endif + !endif +! + ntrac1 = ntrac - 1 + km1 = km - 1 + kmpbl = km / 2 + kmscu = km / 2 +! + do k=1,km + do i=1,im + zi(i,k) = phii(i,k) * gravi + zl(i,k) = phil(i,k) * gravi + xmf(i,k) = 0. + xmfd(i,k) = 0. + buou(i,k) = 0. + buod(i,k) = 0. + ckz(i,k) = ck1 + chz(i,k) = ch1 + rlmnz(i,k) = rlmn + enddo + enddo + do i=1,im + frik(i) = 1.0 + enddo + do i=1,im + zi(i,km+1) = phii(i,km+1) * gravi + enddo + do k=1,km + do i=1,im + zm(i,k) = zi(i,k+1) + enddo + enddo +! horizontal grid size + do i=1,im + gdx(i) = sqrt(garea(i)) + enddo +! + do k=1,km + do i=1,im + tke(i,k) = max(q1_in(i,k,ntke), tkmin) ! tke at layer centers + enddo + enddo + do k=1,km1 + do i=1,im + tkeh(i,k) = 0.5 * (tke(i,k) + tke(i,k+1)) ! tke at interfaces + enddo + enddo +! + do k = 1,km1 + do i=1,im + rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k)) + prn(i,k) = pr0 + enddo + enddo +! +! set background diffusivities as a function of +! horizontal grid size with xkzm_h & xkzm_m for gdx >= 25km +! and 0.01 for gdx=5m, i.e., +! xkzm_hx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) +! xkzm_mx = 0.01 + (xkzm_h - 0.01)/(xkgdx-5.) * (gdx-5.) +! + do i=1,im + kx1(i) = 1 + tx1(i) = 1.0 / prsi(i,1) + tx2(i) = tx1(i) + + ! kgao change - set surface value of background diff (dk) below + + !if(gdx(i) >= xkgdx) then + ! xkzm_hx(i) = xkzm_h + ! xkzm_mx(i) = xkzm_m + !else + ! tem = 1. / (xkgdx - 5.) + ! tem1 = (xkzm_h - 0.01) * tem + ! tem2 = (xkzm_m - 0.01) * tem + ! ptem = gdx(i) - 5. + ! xkzm_hx(i) = 0.01 + tem1 * ptem + ! xkzm_mx(i) = 0.01 + tem2 * ptem + !endif + + if (do_dk_hb19) then ! use eq43 in HB2019 + + if(gdx(i) >= xkgdx) then ! resolution coarser than xkgdx + if( islimsk(i) == 1 ) then ! land points + xkzm_hx(i) = xkzm_hl + xkzm_mx(i) = xkzm_ml + elseif ( islimsk(i) == 2 ) then! sea ice points + xkzm_hx(i) = xkzm_hi + xkzm_mx(i) = xkzm_mi + else ! ocean points + xkzm_hx(i) = xkzm_ho + xkzm_mx(i) = xkzm_mo + endif + else ! resolution finer than xkgdx + tem = 1. / (xkgdx - 5.) + if ( islimsk(i) == 1 ) then ! land points + tem1 = (xkzm_hl - 0.01) * tem + tem2 = (xkzm_ml - 0.01) * tem + elseif ( islimsk(i) == 2 ) then! sea ice points + tem1 = (xkzm_hi - 0.01) * tem + tem2 = (xkzm_mi - 0.01) * tem + else ! ocean points + tem1 = (xkzm_ho - 0.01) * tem + tem2 = (xkzm_mo - 0.01) * tem + endif + ptem = gdx(i) - 5. + xkzm_hx(i) = 0.01 + tem1 * ptem + xkzm_mx(i) = 0.01 + tem2 * ptem + endif + + else ! use values in the namelist; no res dependency + + if ( islimsk(i) == 1 ) then ! land points + xkzm_hx(i) = xkzm_hl + xkzm_mx(i) = xkzm_ml + elseif ( islimsk(i) == 2 ) then ! sea ice points + xkzm_hx(i) = xkzm_hi + xkzm_mx(i) = xkzm_mi + else ! ocean points + xkzm_hx(i) = xkzm_ho + xkzm_mx(i) = xkzm_mo + endif + endif + enddo + + do k = 1,km + do i=1,im + xkzo(i,k) = 0.0 + xkzmo(i,k) = 0.0 + if (k < kinver(i)) then +! vertical background diffusivity + ptem = prsi(i,k+1) * tx1(i) + tem1 = 1.0 - ptem + tem2 = tem1 * tem1 * 10.0 + tem2 = min(1.0, exp(-tem2)) + xkzo(i,k) = xkzm_hx(i) * tem2 +! + ptem = prsl(i,k) * tx1(i) + tem1 = 1.0 - ptem + tem2 = tem1 * tem1 * 2.5 + tem2 = min(1.0, exp(-tem2)) + rlmnz(i,k)= rlmn * tem2 + rlmnz(i,k)= max(rlmnz(i,k), rlmn1) +! vertical background diffusivity for momentum + if (ptem >= xkzm_s) then + xkzmo(i,k) = xkzm_mx(i) + kx1(i) = k + 1 + else + if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k) + tem1 = 1.0 - prsi(i,k+1) * tx2(i) + tem1 = tem1 * tem1 * 5.0 + xkzmo(i,k) = xkzm_mx(i) * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! + do i = 1,im + z0(i) = 0.01 * zorl(i) + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + kpbl(i) = 1 + hpbl(i) = 0. + kpblx(i) = 1 + hpblx(i) = 0. + pblflg(i)= .true. + sfcflg(i)= .true. + if(rbsoil(i) > 0.) sfcflg(i) = .false. + pcnvflg(i)= .false. + scuflg(i)= .true. + if(scuflg(i)) then + radmin(i)= 0. + mrad(i) = km1 + krad(i) = 1 + lcld(i) = km1 + kcld(i) = km1 + endif + enddo +! + do k=1,km + do i=1,im + pix(i,k) = psk(i) / prslk(i,k) + theta(i,k) = t1(i,k) * pix(i,k) + if(ntiw > 0) then + tem = max(q1_in(i,k,ntcw),qlmin) + tem1 = max(q1_in(i,k,ntiw),qlmin) + qlx(i,k) = tem + tem1 + ptem = hvap*tem + (hvap+hfus)*tem1 + slx(i,k) = cp * t1(i,k) + phil(i,k) - ptem + else + qlx(i,k) = max(q1_in(i,k,ntcw),qlmin) + slx(i,k) = cp * t1(i,k) + phil(i,k) - hvap*qlx(i,k) + endif + tem2 = 1.+fv*max(q1(i,k,1),qmin)-qlx(i,k) + thvx(i,k) = theta(i,k) * tem2 + tvx(i,k) = t1(i,k) * tem2 + qtx(i,k) = max(q1(i,k,1),qmin)+qlx(i,k) + thlx(i,k) = theta(i,k) - pix(i,k)*elocp*qlx(i,k) + thlvx(i,k) = thlx(i,k) * (1. + fv * qtx(i,k)) + svx(i,k) = cp * tvx(i,k) + ptem1 = elocp * pix(i,k) * max(q1(i,k,1),qmin) + thetae(i,k)= theta(i,k) + ptem1 + gotvx(i,k) = g / tvx(i,k) + enddo + enddo +! +! compute an empirical cloud fraction based on +! Xu & Randall's (1996,JAS) study +! + do k = 1, km + do i = 1, im + plyr(i,k) = 0.01 * prsl(i,k) ! pa to mb (hpa) +! --- ... compute relative humidity + es = 0.01 * fpvs(t1(i,k)) ! fpvs in pa + qs = max(qmin, eps * es / (plyr(i,k) + epsm1*es)) + rhly(i,k) = max(0.0, min(1.0, max(qmin, q1(i,k,1))/qs)) + qstl(i,k) = qs + enddo + enddo +! + do k = 1, km + do i = 1, im + cfly(i,k) = 0. + clwt = 1.0e-6 * (plyr(i,k)*0.001) + if (qlx(i,k) > clwt) then + onemrh= max(1.e-10, 1.0-rhly(i,k)) + tem1 = min(max((onemrh*qstl(i,k))**0.49,0.0001),1.0) + tem1 = cql / tem1 + value = max(min( tem1*qlx(i,k), 50.0), 0.0) + tem2 = sqrt(sqrt(rhly(i,k))) + cfly(i,k) = min(max(tem2*(1.0-exp(-value)), 0.0), 1.0) + endif + enddo + enddo +! +! compute buoyancy modified by clouds +! + do k = 1, km1 + do i = 1, im + tem = 0.5 * (svx(i,k) + svx(i,k+1)) + tem1 = 0.5 * (t1(i,k) + t1(i,k+1)) + tem2 = 0.5 * (qstl(i,k) + qstl(i,k+1)) + cfh = min(cfly(i,k+1),0.5*(cfly(i,k)+cfly(i,k+1))) + alp = g / tem + gamma = el2orc * tem2 / (tem1**2) + epsi = tem1 / elocp + beta = (1. + gamma*epsi*(1.+fv)) / (1. + gamma) + chx = cfh * alp * beta + (1. - cfh) * alp + cqx = cfh * alp * hvap * (beta - epsi) + cqx = cqx + (1. - cfh) * fv * g + ptem1 = (slx(i,k+1)-slx(i,k))*rdzt(i,k) + ptem2 = (qtx(i,k+1)-qtx(i,k))*rdzt(i,k) + bf(i,k) = chx * ptem1 + cqx * ptem2 + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k=1,km1 + do i=1,im + dku(i,k) = 0. + dkt(i,k) = 0. + dkq(i,k) = 0. + cku(i,k) = 0. + ckt(i,k) = 0. + tem = zi(i,k+1)-zi(i,k) + radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k)) + enddo + enddo +! + do i = 1,im + sflux(i) = heat(i) + evap(i)*fv*theta(i,1) + if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false. + enddo +! +! compute critical bulk richardson number +! + do i = 1,im + if(pblflg(i)) then +! thermal(i) = thvx(i,1) + thermal(i) = thlvx(i,1) + crb(i) = rbcr + else + thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + tem = sqrt(u10m(i)**2+v10m(i)**2) + tem = max(tem, 1.) + robn = tem / (f0 * z0(i)) + tem1 = 1.e-7 * robn + crb(i) = 0.16 * (tem1 ** (-0.18)) + crb(i) = max(min(crb(i), crbmax), crbmin) + endif + enddo +! + do i=1,im + dtdz1(i) = dt2 / (zi(i,2)-zi(i,1)) + enddo +! + do i=1,im + ustar(i) = sqrt(stress(i)) + enddo +! +! compute buoyancy (bf) and winshear square +! + do k = 1, km1 + do i = 1, im + rdz = rdzt(i,k) +! bf(i,k) = gotvx(i,k)*(thvx(i,k+1)-thvx(i,k))*rdz + dw2 = (u1(i,k)-u1(i,k+1))**2 + & + (v1(i,k)-v1(i,k+1))**2 + shr2(i,k) = max(dw2,dw2min)*rdz*rdz + ri(i,k) = max(bf(i,k)/shr2(i,k),rimin) + enddo + enddo +! +! find pbl height based on bulk richardson number (mrf pbl scheme) +! and also for diagnostic purpose +! + do i=1,im + flg(i) = .false. + rbup(i) = rbsoil(i) + enddo +! + do k = 1, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) +! rbup(i) = (thvx(i,k)-thermal(i))* +! & (g*zl(i,k)/thvx(i,1))/spdk2 + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpblx(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(kpblx(i) > 1) then + k = kpblx(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpblx(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpblx(i) < zi(i,kpblx(i))) kpblx(i)=kpblx(i)-1 + else + hpblx(i) = zl(i,1) + kpblx(i) = 1 + endif + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + if(kpbl(i) <= 1) pblflg(i)=.false. + enddo +! +! compute similarity parameters +! + do i=1,im + zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin) + if(sfcflg(i)) then + zol(i) = min(zol(i),-zfmin) + else + zol(i) = max(zol(i),zfmin) + endif +! + zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1) + if(sfcflg(i)) then + tem = 1.0 / (1. - aphi16*zol1) + phih(i) = sqrt(tem) + phim(i) = sqrt(phih(i)) + else + phim(i) = 1. + aphi5*zol1 + phih(i) = phim(i) + endif + enddo +! + do i=1,im + if(pblflg(i)) then + if(zol(i) < zolcru) then + pcnvflg(i) = .true. + endif + wst3(i) = gotvx(i,1)*sflux(i)*hpbl(i) + wstar(i)= wst3(i)**h1 + ust3(i) = ustar(i)**3. + wscale(i)=(ust3(i)+wfac*vk*wst3(i)*sfcfrac)**h1 + ptem = ustar(i)/aphi5 + wscale(i) = max(wscale(i),ptem) + endif + enddo +! +! compute a thermal excess +! + do i = 1,im + if(pcnvflg(i)) then + hgamt(i) = heat(i)/wscale(i) + hgamq(i) = evap(i)/wscale(i) + vpert(i) = hgamt(i) + hgamq(i)*fv*theta(i,1) + vpert(i) = max(vpert(i),0.) + tem = min(cfac*vpert(i),gamcrt) + thermal(i)= thermal(i) + tem !jih jul2020 + endif + enddo +! +! enhance the pbl height by considering the thermal excess +! (overshoot pbl top) -- jih jul2020 +! + do i=1,im + flg(i) = .true. + if(pcnvflg(i)) then + flg(i) = .false. + rbup(i) = rbsoil(i) + endif + enddo + do k = 2, kmpbl + do i = 1, im + if(.not.flg(i)) then + rbdn(i) = rbup(i) + spdk2 = max((u1(i,k)**2+v1(i,k)**2),1.) + rbup(i) = (thlvx(i,k)-thermal(i))* + & (g*zl(i,k)/thlvx(i,1))/spdk2 + kpbl(i) = k + flg(i) = rbup(i) > crb(i) + endif + enddo + enddo + do i = 1,im + if(pcnvflg(i)) then + k = kpbl(i) + if(rbdn(i) >= crb(i)) then + rbint = 0. + elseif(rbup(i) <= crb(i)) then + rbint = 1. + else + rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i)) + endif + hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1)) + if(hpbl(i) < zi(i,kpbl(i))) then + kpbl(i) = kpbl(i) - 1 + endif + if(kpbl(i) <= 1) then + pcnvflg(i) = .false. + pblflg(i) = .false. + endif + endif + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! look for stratocumulus +! + do i=1,im + flg(i) = scuflg(i) + enddo + do k = 1, km1 + do i=1,im + if(flg(i).and.zl(i,k) >= zstblmax) then + lcld(i)=k + flg(i)=.false. + endif + enddo + enddo + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k <= lcld(i)) then + if(qlx(i,k) >= qlcr) then + kcld(i)=k + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false. + enddo +! + do i = 1, im + flg(i)=scuflg(i) + enddo + do k = kmscu,1,-1 + do i = 1, im + if(flg(i) .and. k <= kcld(i)) then + if(qlx(i,k) >= qlcr) then + if(radx(i,k) < radmin(i)) then + radmin(i)=radx(i,k) + krad(i)=k + endif + else + flg(i)=.false. + endif + endif + enddo + enddo + do i = 1, im + if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false. + if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false. + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute components for mass flux mixing by large thermals +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + tcko(i,k) = t1(i,k) + ucko(i,k) = u1(i,k) + vcko(i,k) = v1(i,k) + endif + if(scuflg(i)) then + tcdo(i,k) = t1(i,k) + ucdo(i,k) = u1(i,k) + vcdo(i,k) = v1(i,k) + endif + enddo + enddo + do kk = 1, ntrac1 + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then + qcko(i,k,kk) = q1(i,k,kk) + endif + if(scuflg(i)) then + qcdo(i,k,kk) = q1(i,k,kk) + endif + enddo + enddo + enddo +! kgao note - change ntcw if q1 is rearranged + if (ntke > ntcw) then + ntcw_new = ntcw + else + ntcw_new = ntcw-1 + endif +! EDMF parameterization Siebesma et al.(2007) + call mfpbltq(im,ix,km,kmpbl,ntcw_new,ntrac1,dt2, + & pcnvflg,zl,zm,q1,t1,u1,v1,plyr,pix,thlx,thvx, + & gdx,hpbl,kpbl,vpert,buou,xmf, + & tcko,qcko,ucko,vcko,xlamue,bl_upfr) +! mass-flux parameterization for stratocumulus-top-induced turbulence mixing + call mfscuq(im,ix,km,kmscu,ntcw_new,ntrac1,dt2, + & scuflg,zl,zm,q1,t1,u1,v1,plyr,pix, + & thlx,thvx,thlvx,gdx,thetae, + & krad,mrad,radmin,buod,xmfd, + & tcdo,qcdo,ucdo,vcdo,xlamde,bl_dnfr) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute prandtl number and exchange coefficient varying with height +! + do k = 1, kmpbl + do i = 1, im + if(k < kpbl(i)) then + tem = phih(i)/phim(i) + ptem = sfcfrac*hpbl(i) + tem1 = max(zi(i,k+1)-ptem, 0.) + tem2 = tem1 / (hpbl(i) - ptem) + if(pcnvflg(i)) then + tem = min(tem, pr0) + prn(i,k) = tem + (pr0 - tem) * tem2 + else + tem = max(tem, pr0) + prn(i,k) = tem + endif + prn(i,k) = min(prn(i,k),prmax) + prn(i,k) = max(prn(i,k),prmin) +! + ckz(i,k) = ck0 + (ck1 - ck0) * tem2 + ckz(i,k) = max(min(ckz(i,k), ck0), ck1) + chz(i,k) = ch0 + (ch1 - ch0) * tem2 + chz(i,k) = max(min(chz(i,k), ch0), ch1) +! + endif + enddo + enddo +! +! Above a threshold height (hcrinv), the background vertical diffusivities & mixing length +! in the inversion layers are set to much smaller values (xkzinv & rlmn2) +! +! Below the threshold height (hcrinv), the background vertical diffusivities & mixing length +! in the inversion layers are increased with increasing roughness length & vegetation fraction +! + do k = 1,km1 + do i=1,im + if(zi(i,k+1) > hcrinv) then + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 >= 0. .and. islimsk(i) == 0) then ! kgao note: only apply limiter over ocean points + xkzo(i,k) = min(xkzo(i,k), xkzinv) + xkzmo(i,k) = min(xkzmo(i,k), xkzinv) + rlmnz(i,k) = min(rlmnz(i,k), rlmn2) + endif + else + tem1 = tvx(i,k+1)-tvx(i,k) + if(tem1 > 0.) then + ptem = xkzo(i,k) * zvfun(i) + xkzo(i,k) = min(max(ptem, xkzinv), xkzo(i,k)) + ptem = xkzmo(i,k) * zvfun(i) + xkzmo(i,k) = min(max(ptem, xkzinv), xkzmo(i,k)) + ptem = rlmnz(i,k) * zvfun(i) + rlmnz(i,k) = min(max(ptem, rlmn2), rlmnz(i,k)) + endif + endif + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute an asymtotic mixing length +! + do k = 1, km1 + do i = 1, im + zlup = 0.0 + bsum = 0.0 + mlenflg = .true. + do n = k, km1 + if(mlenflg) then + dz = zl(i,n+1) - zl(i,n) + ! kgao note - new: with shear effect + tem3=((u1(i,n+1)-u1(i,n))/dz)**2 + tem3=tem3+((v1(i,n+1)-v1(i,n))/dz)**2 + tem3=cs0*sqrt(tem3)*sqrt(tke(i,k)) + ptem = (gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))+tem3)*dz + ! kgao note - old: no shear effect + !ptem = gotvx(i,n)*(thvx(i,n+1)-thvx(i,k))*dz + bsum = bsum + ptem + zlup = zlup + dz + if(bsum >= tke(i,k)) then + if(ptem >= 0.) then + tem2 = max(ptem, zfmin) + else + tem2 = min(ptem, -zfmin) + endif + ptem1 = (bsum - tke(i,k)) / tem2 + zlup = zlup - ptem1 * dz + zlup = max(zlup, 0.) + mlenflg = .false. + endif + endif + enddo + zldn = 0.0 + bsum = 0.0 + mlenflg = .true. + do n = k, 1, -1 + if(mlenflg) then + if(n == 1) then + dz = zl(i,1) + tem1 = tsea(i)*(1.+fv*max(q1(i,1,1),qmin)) + !jih jul2020 + tem3 = (u1(i,1)/dz)**2 + tem3 = tem3+(v1(i,1)/dz)**2 + tem3 = cs0*sqrt(tem3)*sqrt(tke(i,1)) + else + dz = zl(i,n) - zl(i,n-1) + tem1 = thvx(i,n-1) +! tem1 = thlvx(i,n-1) + ! kgao note - shear effect + tem3 = ((u1(i,n)-u1(i,n-1))/dz)**2 + tem3 = tem3+((v1(i,n)-v1(i,n-1))/dz)**2 + tem3 = cs0*sqrt(tem3)*sqrt(tke(i,k)) + endif + ! kgao note - new: shear effect + ptem = (gotvx(i,n)*(thvx(i,k)-tem1)+tem3)*dz + ! kgao note - old: no shear effect + !ptem = gotvx(i,n)*(thvx(i,k)-tem1)*dz + bsum = bsum + ptem + zldn = zldn + dz + if(bsum >= tke(i,k)) then + if(ptem >= 0.) then + tem2 = max(ptem, zfmin) + else + tem2 = min(ptem, -zfmin) + endif + ptem1 = (bsum - tke(i,k)) / tem2 + zldn = zldn - ptem1 * dz + zldn = max(zldn, 0.) + mlenflg = .false. + endif + endif + enddo +! + tem = 0.5 * (zi(i,k+1)-zi(i,k)) + tem1 = min(tem, rlmnz(i,k)) +! + ptem2 = min(zlup,zldn) + rlam(i,k) = elmfac * ptem2 + rlam(i,k) = max(rlam(i,k), tem1) + rlam(i,k) = min(rlam(i,k), rlmx) +! + ptem2 = sqrt(zlup*zldn) + ele(i,k) = elefac * ptem2 + ele(i,k) = max(ele(i,k), tem1) + ele(i,k) = min(ele(i,k), elmx) +! + enddo + enddo +! + do k = 1, km1 + do i = 1, im + tem = vk * zl(i,k) + if (zol(i) < 0.) then + ptem = 1. - 100. * zol(i) + ptem1 = ptem**0.2 + zk = tem * ptem1 + elseif (zol(i) >= 1.) then + zk = tem / 3.7 + else + ptem = 1. + 2.7 * zol(i) + zk = tem / ptem + endif + elm(i,k) = zk*rlam(i,k)/(rlam(i,k)+zk) +! + dz = zi(i,k+1) - zi(i,k) + tem = max(gdx(i),dz) + elm(i,k) = min(elm(i,k), tem) + ele(i,k) = min(ele(i,k), tem) +! + enddo + enddo + do i = 1, im + elm(i,km) = elm(i,km1) + ele(i,km) = ele(i,km1) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute eddy diffusivities +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km1 + do i = 1, im + xkzo(i,k) = 0.5 * (xkzo(i,k) + xkzo(i,k+1)) + xkzmo(i,k) = 0.5 * (xkzmo(i,k) + xkzmo(i,k+1)) + enddo + enddo + do k = 1, km1 + do i = 1, im + tem = 0.5 * (elm(i,k) + elm(i,k+1)) + tem = tem * sqrt(tkeh(i,k)) + if(k < kpbl(i)) then + if(pcnvflg(i)) then + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else + if(ri(i,k) < 0.) then ! unstable regime + dku(i,k) = ckz(i,k) * tem + dkt(i,k) = dku(i,k) / prn(i,k) + else ! stable regime + dkt(i,k) = chz(i,k) * tem + dku(i,k) = dkt(i,k) * prn(i,k) + endif + endif + else + if(ri(i,k) < 0.) then ! unstable regime + dku(i,k) = ck1 * tem + dkt(i,k) = rchck * dku(i,k) + else ! stable regime + dkt(i,k) = ch1 * tem + prnum = 1.0 + 2.1 * ri(i,k) + prnum = min(prnum,prmax) + dku(i,k) = dkt(i,k) * prnum + endif + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + tem1 = ckz(i,k) * tem + ptem1 = tem1 / prscu + dku(i,k) = max(dku(i,k), tem1) + dkt(i,k) = max(dkt(i,k), ptem1) + endif + endif +! + dkq(i,k) = prtke * dkt(i,k) +! + dkt(i,k) = min(dkt(i,k),dkmax) + dkt(i,k) = max(dkt(i,k),xkzo(i,k)) + dkq(i,k) = min(dkq(i,k),dkmax) + dkq(i,k) = max(dkq(i,k),xkzo(i,k)) + dku(i,k) = min(dku(i,k),dkmax) + dku(i,k) = max(dku(i,k),xkzmo(i,k)) +! + enddo + enddo +! +! compute a minimum TKE deduced from background diffusivity for momentum. +! + do k = 1, km1 + do i = 1, im + if(k == 1) then + tem = ckz(i,1) + tem1 = 0.5 * xkzmo(i,1) + else + tem = 0.5 * (ckz(i,k-1) + ckz(i,k)) + tem1 = 0.5 * (xkzmo(i,k-1) + xkzmo(i,k)) + endif + ptem = tem1 / (tem * elm(i,k)) + tkmnz(i,k) = ptem * ptem + tkmnz(i,k) = min(tkmnz(i,k), tkminx) + tkmnz(i,k) = max(tkmnz(i,k), tkmin) + enddo + enddo +! kgao + do k=1,km1 + do i=1,im + dkt_out(i,k) = dkt(i,k) + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! compute buoyancy and shear productions of tke +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! + do k = 1, km1 + do i = 1, im + if (k == 1) then + tem = -dkt(i,1) * bf(i,1) +! if(pcnvflg(i)) then +! ptem1 = xmf(i,1) * buou(i,1) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem2 = xmfd(i,1) * buod(i,1) + else + ptem2 = 0. + endif + tem = tem + ptem1 + ptem2 + buop = 0.5 * (gotvx(i,1) * sflux(i) + tem) +! + tem1 = dku(i,1) * shr2(i,1) +! + tem = (u1(i,2)-u1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem1 = 0.5 * ptem * (u1(i,2)-ucko(i,2)) +! else + ptem1 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = ucdo(i,1)+ucdo(i,2)-u1(i,1)-u1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem1 = ptem1 + ptem +! + tem = (v1(i,2)-v1(i,1))*rdzt(i,1) +! if(pcnvflg(i)) then +! ptem = xmf(i,1) * tem +! ptem2 = 0.5 * ptem * (v1(i,2)-vcko(i,2)) +! else + ptem2 = 0. +! endif + if(scuflg(i) .and. mrad(i) == 1) then + ptem = vcdo(i,1)+vcdo(i,2)-v1(i,1)-v1(i,2) + ptem = 0.5 * tem * xmfd(i,1) * ptem + else + ptem = 0. + endif + ptem2 = ptem2 + ptem +! +! tem2 = stress(i)*spd1(i)/zl(i,1) + tem2 = stress(i)*ustar(i)*phim(i)/(vk*zl(i,1)) + shrp = 0.5 * (tem1 + ptem1 + ptem2 + tem2) + else + tem1 = -dkt(i,k-1) * bf(i,k-1) + tem2 = -dkt(i,k) * bf(i,k) + tem = 0.5 * (tem1 + tem2) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = 0.5 * (xmf(i,k-1) + xmf(i,k)) + ptem1 = ptem * buou(i,k) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = 0.5 * (xmfd(i,k-1) + xmfd(i,k)) + ptem2 = ptem0 * buod(i,k) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + buop = tem + ptem1 + ptem2 +! + tem1 = dku(i,k-1) * shr2(i,k-1) + tem2 = dku(i,k) * shr2(i,k) + tem = 0.5 * (tem1 + tem2) + tem1 = (u1(i,k+1)-u1(i,k))*rdzt(i,k) + tem2 = (u1(i,k)-u1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (u1(i,k)-ucko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (ucdo(i,k)-u1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = tem + ptem1 + ptem2 + tem1 = (v1(i,k+1)-v1(i,k))*rdzt(i,k) + tem2 = (v1(i,k)-v1(i,k-1))*rdzt(i,k-1) + if(pcnvflg(i) .and. k <= kpbl(i)) then + ptem = xmf(i,k) * tem1 + xmf(i,k-1) * tem2 + ptem1 = 0.5 * ptem * (v1(i,k)-vcko(i,k)) + else + ptem1 = 0. + endif + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem0 = xmfd(i,k) * tem1 + xmfd(i,k-1) * tem2 + ptem2 = 0.5 * ptem0 * (vcdo(i,k)-v1(i,k)) + else + ptem2 = 0. + endif + else + ptem2 = 0. + endif + shrp = shrp + ptem1 + ptem2 + endif + prod(i,k) = buop + shrp + enddo + enddo +! +!---------------------------------------------------------------------- +! first predict tke due to tke production & dissipation(diss) +! + dtn = dt2 / float(ndt) + do n = 1, ndt + do k = 1,km1 + do i=1,im + tem = sqrt(tke(i,k)) + ptem = ce0 / ele(i,k) + diss(i,k) = ptem * tke(i,k) * tem + tem1 = prod(i,k) + tke(i,k) / dtn + diss(i,k)=max(min(diss(i,k), tem1), 0.) + tke(i,k) = tke(i,k) + dtn * (prod(i,k)-diss(i,k))! no diffusion yet +! tke(i,k) = max(tke(i,k), tkmin) + tke(i,k) = max(tke(i,k), tkmnz(i,k)) + enddo + enddo + enddo +! +! compute updraft & downdraft properties for tke +! + do k = 1, km + do i = 1, im + if(pcnvflg(i)) then +! kgao change +! qcko(i,k,ntke) = tke(i,k) + qcko(i,k,ntrac) = tke(i,k) + endif + if(scuflg(i)) then +! kgao change +! qcdo(i,k,ntke) = tke(i,k) + qcdo(i,k,ntrac) = tke(i,k) + endif + enddo + enddo + do k = 2, kmpbl + do i = 1, im + if (pcnvflg(i) .and. k <= kpbl(i)) then + dz = zl(i,k) - zl(i,k-1) + tem = 0.5 * xlamue(i,k-1) * dz + factor = 1. + tem +! kgao change +! qcko(i,k,ntke)=((1.-tem)*qcko(i,k-1,ntke)+tem* +! & (tke(i,k)+tke(i,k-1)))/factor + qcko(i,k,ntrac)=((1.-tem)*qcko(i,k-1,ntrac)+tem* + & (tke(i,k)+tke(i,k-1)))/factor + endif + enddo + enddo + do k = kmscu, 1, -1 + do i = 1, im + if (scuflg(i) .and. k < krad(i)) then + if(k >= mrad(i)) then + dz = zl(i,k+1) - zl(i,k) + tem = 0.5 * xlamde(i,k) * dz + factor = 1. + tem +! kgao change +! qcdo(i,k,ntke)=((1.-tem)*qcdo(i,k+1,ntke)+tem* +! & (tke(i,k)+tke(i,k+1)))/factor + qcdo(i,k,ntrac)=((1.-tem)*qcdo(i,k+1,ntrac)+tem* + & (tke(i,k)+tke(i,k+1)))/factor + endif + endif + enddo + enddo +! +!---------------------------------------------------------------------- +! compute tridiagonal matrix elements for turbulent kinetic energy +! + do i=1,im + ad(i,1) = 1.0 + f1(i,1) = tke(i,1) + enddo +! + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkq(i,k) * rdz + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = tke(i,k) + tke(i,k+1) +! kgao change +! ptem = qcko(i,k,ntke) + qcko(i,k+1,ntke) + ptem = qcko(i,k,ntrac) + qcko(i,k+1,ntrac) + f1(i,k) = f1(i,k)-(ptem-tem)*ptem1 + f1(i,k+1) = tke(i,k+1)+(ptem-tem)*ptem2 + else + f1(i,k+1) = tke(i,k+1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = tke(i,k) + tke(i,k+1) +! kgao change +! ptem = qcdo(i,k,ntke) + qcdo(i,k+1,ntke) + ptem = qcdo(i,k,ntrac) + qcdo(i,k+1,ntrac) + f1(i,k) = f1(i,k) + (ptem - tem) * ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) * ptem2 + endif + endif +! + enddo + enddo +c +c solve tridiagonal problem for tke +c + call tridit(im,km,1,al,ad,au,f1,au,f1) +c +c recover tendency of tke +c + do k = 1,km + do i = 1,im +! fix negative tke + f1(i,k) = max(f1(i,k), tkmin) +! kgao change +! qtend = (f1(i,k)-q1(i,k,ntke))*rdt +! rtg(i,k,ntke) = rtg(i,k,ntke)+qtend + qtend = (f1(i,k)-q1(i,k,ntrac))*rdt + rtg(i,k,ntrac) = rtg(i,k,ntrac)+qtend + enddo + enddo +c +c compute tridiagonal matrix elements for heat and moisture (and other tracers, except tke) +c + do i=1,im + ad(i,1) = 1. + f1(i,1) = t1(i,1) + dtdz1(i) * heat(i) + f2(i,1) = q1(i,1,1) + dtdz1(i) * evap(i) + enddo + if(ntrac1 >= 2) then + do kk = 2, ntrac1 + is = (kk-1) * km + do i = 1, im + f2(i,1+is) = q1(i,1,kk) + enddo + enddo + endif +c + do k = 1,km1 + do i = 1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dkt(i,k) * rdz + dsdzt = tem1 * gocp + dsdz2 = tem1 * rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = t1(i,k) + t1(i,k+1) + ptem = tcko(i,k) + tcko(i,k+1) + f1(i,k) = f1(i,k)+dtodsd*dsdzt -(ptem-tem)*ptem1 + f1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt +(ptem-tem)*ptem2 + ! kgao - t flux by updraft + flux_up(i,k) = 0.5*(ptem-tem)*xmf(i,k) + + tem = q1(i,k,1) + q1(i,k+1,1) + ptem = qcko(i,k,1) + qcko(i,k+1,1) + f2(i,k) = f2(i,k) - (ptem - tem) * ptem1 + f2(i,k+1) = q1(i,k+1,1) + (ptem - tem) * ptem2 + else + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt + f2(i,k+1) = q1(i,k+1,1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + ptem = tcdo(i,k) + tcdo(i,k+1) + tem = t1(i,k) + t1(i,k+1) + f1(i,k) = f1(i,k) + (ptem - tem) * ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) * ptem2 + ! kgao - t flux by downdraft + flux_dn(i,k) = -0.5*(ptem-tem)*xmfd(i,k) + + tem = q1(i,k,1) + q1(i,k+1,1) + ptem = qcdo(i,k,1) + qcdo(i,k+1,1) + f2(i,k) = f2(i,k) + (ptem - tem) * ptem1 + f2(i,k+1) = f2(i,k+1) - (ptem - tem) * ptem2 + endif + endif + enddo + enddo +! + if(ntrac1 >= 2) then + do kk = 2, ntrac1 + is = (kk-1) * km + do k = 1, km1 + do i = 1, im + if(pcnvflg(i) .and. k < kpbl(i)) then + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + tem = dsig * rdzt(i,k) + ptem = 0.5 * tem * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem1 = qcko(i,k,kk) + qcko(i,k+1,kk) + tem2 = q1(i,k,kk) + q1(i,k+1,kk) + ! kgao note - turn off non-local mixing + f2(i,k+is) = f2(i,k+is) !- (tem1 - tem2) * ptem1 + f2(i,k+1+is)= q1(i,k+1,kk) !+ (tem1 - tem2) * ptem2 + else + f2(i,k+1+is) = q1(i,k+1,kk) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + tem = dsig * rdzt(i,k) + ptem = 0.5 * tem * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem1 = qcdo(i,k,kk) + qcdo(i,k+1,kk) + tem2 = q1(i,k,kk) + q1(i,k+1,kk) + ! kgao note - turn off non-local mixing + f2(i,k+is) = f2(i,k+is) !+ (tem1 - tem2) * ptem1 + f2(i,k+1+is)= f2(i,k+1+is) !- (tem1 - tem2) * ptem2 + endif + endif +! + enddo + enddo + enddo + endif +c +c solve tridiagonal problem for heat and moisture +c + call tridin(im,km,ntrac1,al,ad,au,f1,f2,au,f1,f2) +c +c recover tendencies of heat and moisture +c + do k = 1,km + do i = 1,im + ttend = (f1(i,k)-t1(i,k))*rdt + qtend = (f2(i,k)-q1(i,k,1))*rdt + tdt(i,k) = tdt(i,k)+ttend + rtg(i,k,1) = rtg(i,k,1)+qtend + dtsfc(i) = dtsfc(i)+cont*del(i,k)*ttend + dqsfc(i) = dqsfc(i)+conq*del(i,k)*qtend + enddo + enddo +! + if(ntrac1 >= 2) then + do kk = 2, ntrac1 + is = (kk-1) * km + do k = 1, km + do i = 1, im + qtend = (f2(i,k+is)-q1(i,k,kk))*rdt + rtg(i,k,kk) = rtg(i,k,kk)+qtend + enddo + enddo + enddo + endif +! +! kgao note - rearrange tracer tendencies +! + !if(ntrac >= 3 ) then + if(ntke == ntrac) then ! tke is the last tracer + rtg_in(:,:,:) = rtg(:,:,:) + else ! tke is not + do kk = 1, ntke-1 + rtg_in(:,:,kk) = rtg(:,:,kk) + enddo + rtg_in(:,:,ntke) = rtg(:,:,ntrac) + do kk = ntke+1, ntrac + rtg_in(:,:,kk) = rtg(:,:,kk-1) + enddo + endif + !endif +! +! add tke dissipative heating to temperature tendency +! + if(dspheat) then + do k = 1,km1 + do i = 1,im +! tem = min(diss(i,k), dspmax) +! ttend = tem / cp + ttend = diss(i,k) / cp + tdt(i,k) = tdt(i,k) + dspfac * ttend + enddo + enddo + endif +c +c compute tridiagonal matrix elements for momentum +c + do i=1,im + ad(i,1) = 1.0 + dtdz1(i) * stress(i) / spd1(i) + f1(i,1) = u1(i,1) + f2(i,1) = v1(i,1) + enddo +c + do k = 1,km1 + do i=1,im + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) + dsig = prsl(i,k)-prsl(i,k+1) + rdz = rdzt(i,k) + tem1 = dsig * dku(i,k) * rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1)= 1.-al(i,k) + tem2 = dsig * rdz +! + if(pcnvflg(i) .and. k < kpbl(i)) then + ptem = 0.5 * tem2 * xmf(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = u1(i,k) + u1(i,k+1) + ptem = ucko(i,k) + ucko(i,k+1) + f1(i,k) = f1(i,k) - (ptem - tem) * ptem1 + f1(i,k+1) = u1(i,k+1) + (ptem - tem) * ptem2 + tem = v1(i,k) + v1(i,k+1) + ptem = vcko(i,k) + vcko(i,k+1) + f2(i,k) = f2(i,k) - (ptem - tem) * ptem1 + f2(i,k+1) = v1(i,k+1) + (ptem - tem) * ptem2 + else + f1(i,k+1) = u1(i,k+1) + f2(i,k+1) = v1(i,k+1) + endif +! + if(scuflg(i)) then + if(k >= mrad(i) .and. k < krad(i)) then + ptem = 0.5 * tem2 * xmfd(i,k) + ptem1 = dtodsd * ptem + ptem2 = dtodsu * ptem + tem = u1(i,k) + u1(i,k+1) + ptem = ucdo(i,k) + ucdo(i,k+1) + f1(i,k) = f1(i,k) + (ptem - tem) *ptem1 + f1(i,k+1) = f1(i,k+1) - (ptem - tem) *ptem2 + tem = v1(i,k) + v1(i,k+1) + ptem = vcdo(i,k) + vcdo(i,k+1) + f2(i,k) = f2(i,k) + (ptem - tem) * ptem1 + f2(i,k+1) = f2(i,k+1) - (ptem - tem) * ptem2 + endif + endif +! + enddo + enddo +c +c solve tridiagonal problem for momentum +c + call tridi2(im,km,al,ad,au,f1,f2,au,f1,f2) +c +c recover tendencies of momentum +c + do k = 1,km + do i = 1,im + utend = (f1(i,k)-u1(i,k))*rdt + vtend = (f2(i,k)-v1(i,k))*rdt + du(i,k) = du(i,k)+utend + dv(i,k) = dv(i,k)+vtend + dusfc(i) = dusfc(i)+conw*del(i,k)*utend + dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend + enddo + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! pbl height for diagnostic purpose +! + do i = 1, im + hpbl(i) = hpblx(i) + kpbl(i) = kpblx(i) + enddo +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + return + end diff --git a/gsmphys/set_soilveg.F b/gsmphys/set_soilveg.F new file mode 100644 index 00000000..91eb8ca8 --- /dev/null +++ b/gsmphys/set_soilveg.F @@ -0,0 +1,445 @@ + subroutine set_soilveg(Model,isot,ivet,logunit,sz_nml, + $ input_nml_file) + use namelist_soilveg + use GFS_typedefs, only : GFS_control_type, GFS_grid_type + implicit none + + integer, intent(in) :: isot,ivet,logunit,sz_nml + character (len = *), intent (in) :: input_nml_file(sz_nml) !NEEDED for f77 + type (GFS_control_type), intent(in) :: Model + +!my begin locals +!for 20 igbp veg type and 19 stasgo soil type + integer i, ios + logical exists + REAL WLTSMC1,REFSMC1 +! ---------------------------------------------------------------------- +! SET TWO SOIL MOISTURE WILT, SOIL MOISTURE REFERENCE PARAMETERS +! ---------------------------------------------------------------------- + REAL SMLOW + REAL SMLOW_DATA + DATA SMLOW_DATA /0.5/ + + REAL SMHIGH + REAL SMHIGH_DATA +! changed in 2.6 from 3 to 6 on June 2nd 2003 +! DATA SMHIGH_DATA /3.0/ + DATA SMHIGH_DATA /6.0/ + NAMELIST /soil_veg_nml/ SLOPE_DATA, RSMTBL, RGLTBL, HSTBL, SNUPX, + & BB, DRYSMC, F11, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, + & WLTSMC, QTZ, LPARAM, ZBOT_DATA, SALP_DATA, CFACTR_DATA, + & CMCMAX_DATA, SBETA_DATA, RSMAX_DATA, TOPT_DATA, + & REFDK_DATA, FRZK_DATA, BARE, DEFINED_VEG, DEFINED_SOIL, + & DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA, + & CZIL_DATA, LAI_DATA, CSOIL_DATA + +cmy end locals + if(ivet.eq.2) then + +!using umd veg table + slope_data =(/0.1, 0.6, 1.0, 0.35, 0.55, 0.8, + & 0.63, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/) + rsmtbl =(/300.0, 175.0, 175.0, 300.0, 300.0, 70.0, + & 20.0, 225.0, 225.0, 225.0, 400.0, 20.0, + & 150.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) +c----------------------------- + rgltbl =(/30.0, 30.0, 30.0, 30.0, 30.0, 65.0, + & 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + & 100.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + hstbl =(/41.69, 54.53, 51.93, 47.35, 47.35, 54.53, + & 36.35, 42.00, 42.00, 42.00, 42.00, 36.35, + & 42.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) +! changed for version 2.6 on june 2nd 2003 +! data snupx /0.080, 0.080, 0.080, 0.080, 0.080, 0.080, +! & 0.040, 0.040, 0.040, 0.040, 0.025, 0.040, +! & 0.025, 0.000, 0.000, 0.000, 0.000, 0.000, + snupx =(/0.040, 0.040, 0.040, 0.040, 0.040, 0.040, + * 0.020, 0.020, 0.020, 0.020, 0.013, 0.020, + * 0.013, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + + bare =11 + +c--------------------------------------------------------------------- +! number of defined veg used. +! ---------------------------------------------------------------------- + defined_veg=13 + nroot_data =(/4,4,4,4,4,4,3,3,3,2,3,3,2,0,0, + & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/) +! ---------------------------------------------------------------------- +! vegetation class-related arrays +! ---------------------------------------------------------------------- + z0_data =(/2.653, 0.826, 0.563, 1.089, 0.854, 0.856, + & 0.035, 0.238, 0.065, 0.076, 0.011, 0.125, + & 0.011, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +clu: change to 3 or 2 oct 15, 2004 + lai_data =(/3.0, 3.0, 3.0, 3.0, 3.0, 3.0, + & 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, + & 3.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) +! use igbp table + elseif(ivet.eq.1)then + + SLOPE_DATA =(/1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + & 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + & 1.0 , 1.0, 1.0, 1.0, 1.0, 1.0, + & 1.0 , 1.0, 0.0, 0.0, 0.0, 0.0, + & 0.0 , 0.0, 0.0, 0.0, 0.0, 0.0/) + RSMTBL =(/300.0, 300.0, 70.0, 175.0, 175.0, 70.0, + & 70.0, 70.0, 70.0, 20.0, 40.0, 20.0, + & 400.0, 35.0, 200.0, 70.0, 100.0, 70.0, + & 150.0, 200.0, 0.0, 0.0,0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) +c----------------------------- + RGLTBL =(/30.0, 30.0, 30.0, 30.0, 30.0, 100.0, + & 100.0, 65.0, 65.0, 100.0, 100.0, 100.0, + & 100.0, 100.0, 100.0,100.0,30.0, 100.0, + & 100.0, 100.0, 0.0,0.0,0.0,0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + HSTBL =(/47.35, 41.69, 47.35, 54.53, 51.93, 42.00, + & 42.00, 42.00, 42.00, 36.35, 60.00, 36.25, + & 42.00, 36.25, 42.00, 42.00, 51.75, 42.00, + & 42.00, 42.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + SNUPX =(/0.080, 0.080, 0.080, 0.080, 0.080, 0.020, + * 0.020, 0.060, 0.040, 0.020, 0.010, 0.020, + * 0.020, 0.020, 0.013, 0.013, 0.010, 0.020, + & 0.020, 0.020, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + + bare =16 + +!--------------------------------------------------------------------- +! number of defined veg used. +! ---------------------------------------------------------------------- + defined_veg=20 + + NROOT_DATA =(/4,4,4,4,4,3,3,3,3,3,3,3,1,3,2, + & 3,0,3,3,2,0,0,0,0,0,0,0,0,0,0/) +! ---------------------------------------------------------------------- +! VEGETATION CLASS-RELATED ARRAYS +! ---------------------------------------------------------------------- + Z0_DATA =(/1.089, 2.653, 0.854, 0.826, 0.80, 0.05, + & 0.03, 0.856, 0.856, 0.15, 0.04, 0.13, + & 1.00, 0.25, 0.011, 0.011, 0.001, 0.076, + & 0.05, 0.03, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + + lai_data =(/3.0, 3.0, 3.0, 3.0, 3.0, 3.0, + & 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, + & 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, + & 3.0, 3.0, 0.0, 0.0, 0.0, 0.0, + & 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/) + +! end if veg table + endif + + if(isot.eq.0) then + + bb =(/4.26, 8.72, 11.55, 4.74, 10.73, 8.17, + & 6.77, 5.25, 4.26, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) +! !!!!!!!!!!!!!! the following values in the table are not used +! !!!!!!!!!!!!!! and are just given for reference + drysmc=(/0.029, 0.119, 0.139, 0.047, 0.100, 0.103, + & 0.069, 0.066, 0.029, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! !!!!!!!!!!!!!! the following values in the table are not used +! !!!!!!!!!!!!!! and are just given for reference + f11 =(/-0.999, -1.116, -2.137, -0.572, -3.201, -1.302, + & -1.519, -0.329, -0.999, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + maxsmc=(/0.421, 0.464, 0.468, 0.434, 0.406, 0.465, + & 0.404, 0.439, 0.421, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! +! ---------------------------------------------------------------------- +! the following 5 parameters are derived later in redprm.f from the soil +! data, and are just given here for reference and to force static +! storage allocation. -dag lohmann, feb. 2001 +! ---------------------------------------------------------------------- +! data refsmc/0.283, 0.387, 0.412, 0.312, 0.338, 0.382, +! & 0.315, 0.329, 0.283, 0.000, 0.000, 0.000, +! !!!!!!!!!!!!!! the following values in the table are not used +! !!!!!!!!!!!!!! and are just given for reference + refsmc=(/0.248, 0.368, 0.398, 0.281, 0.321, 0.361, + & 0.293, 0.301, 0.248, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! ---------------------------------------------------------------------- +! soil texture-related arrays. +! ---------------------------------------------------------------------- + satpsi=(/0.04, 0.62, 0.47, 0.14, 0.10, 0.26, + & 0.14, 0.36, 0.04, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + satdk =(/1.41e-5, 0.20e-5, 0.10e-5, 0.52e-5, 0.72e-5, + & 0.25e-5, 0.45e-5, 0.34e-5, 1.41e-5, 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/) + qtz =(/0.82, 0.10, 0.25, 0.60, 0.52, 0.35, + & 0.60, 0.40, 0.82, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + +! !!!!!!!!!!!!!! the following values in the table are not used +! !!!!!!!!!!!!!! and are just given for reference + wltsmc=(/0.029, 0.119, 0.139, 0.047, 0.100, 0.103, + & 0.069, 0.066, 0.029, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! !!!!!!!!!!!!!! the following values in the table are not used +! !!!!!!!!!!!!!! and are just given for reference + satdw =(/5.71e-6, 2.33e-5, 1.16e-5, 7.95e-6, 1.90e-5, + & 1.14e-5, 1.06e-5, 1.46e-5, 5.71e-6, 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/) + +! ---------------------------------------------------------------------- +! number of defined soiltyps used. +! ---------------------------------------------------------------------- + + defined_soil=9 + + else + +! using stasgo table + BB =(/4.05, 4.26, 4.74, 5.33, 5.33, 5.25, + & 6.77, 8.72, 8.17, 10.73, 10.39, 11.55, + & 5.25, 4.26, 4.05, 4.26, 11.55, 4.05, + & 4.05, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference +! DRYSMC=(/0.023, 0.028, 0.047, 0.084, 0.084, 0.066, +! & 0.069, 0.120, 0.103, 0.100, 0.126, 0.135, +! & 0.069, 0.028, 0.012, 0.028, 0.135, 0.012, +! & 0.023, 0.000, 0.000, 0.000, 0.000, 0.000, +! & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + DRYSMC=(/0.010, 0.025, 0.010, 0.010, 0.010, 0.010, + & 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + & 0.010, 0.010, 0.010, 0.010, 0.010, 0.010, + & 0.010, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + F11 =(/-1.090, -1.041, -0.568, 0.162, 0.162, -0.327, + & -1.535, -1.118, -1.297, -3.211, -1.916, -2.258, + & -0.201, -1.041, -2.287, -1.041, -2.258, -2.287, + & -1.090, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) + MAXSMC=(/0.395, 0.421, 0.434, 0.476, 0.476, 0.439, + & 0.404, 0.464, 0.465, 0.406, 0.468, 0.457, + & 0.464, 0.421, 0.200, 0.421, 0.457, 0.200, + & 0.395, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! +! ---------------------------------------------------------------------- +! THE FOLLOWING 5 PARAMETERS ARE DERIVED LATER IN REDPRM.F FROM THE SOIL +! DATA, AND ARE JUST GIVEN HERE FOR REFERENCE AND TO FORCE STATIC +! STORAGE ALLOCATION. -DAG LOHMANN, FEB. 2001 +! ---------------------------------------------------------------------- +! DATA REFSMC/0.283, 0.387, 0.412, 0.312, 0.338, 0.382, +! & 0.315, 0.329, 0.283, 0.000, 0.000, 0.000, +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + REFSMC=(/0.236, 0.283, 0.312, 0.360, 0.360, 0.329, + & 0.315, 0.387, 0.382, 0.338, 0.404, 0.403, + & 0.348, 0.283, 0.133, 0.283, 0.403, 0.133, + & 0.236, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! ---------------------------------------------------------------------- +! SOIL TEXTURE-RELATED ARRAYS. +! ---------------------------------------------------------------------- + SATPSI=(/0.035, 0.0363, 0.1413, 0.7586, 0.7586, 0.3548, + & 0.1349, 0.6166, 0.2630, 0.0977, 0.3236, 0.4677, + & 0.3548, 0.0363, 0.0350, 0.0363, 0.4677, 0.0350, + & 0.0350, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + SATDK =(/1.76e-4, 1.4078e-5, 5.2304e-6, 2.8089e-6, 2.8089e-6, + & 3.377e-6, 4.4518e-6, 2.0348e-6, 2.4464e-6, 7.2199e-6, + & 1.3444e-6, 9.7394e-7, 3.377e-6, 1.4078e-5, 1.4087e-05, + & 1.4078e-5, 9.7394e-7, 1.4078e-5, 1.760e-4, 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/) +! QTZ =(/0.92, 0.82, 0.60, 0.25, 0.10, 0.40, + QTZ =(/0.92, 0.82, 0.25, 0.15, 0.10, 0.20, + & 0.60, 0.10, 0.35, 0.52, 0.10, 0.25, + & 0.05, 0.25, 0.07, 0.25, 0.60, 0.52, + & 0.92, 0.00, 0.00, 0.00, 0.00, 0.00, + & 0.00, 0.00, 0.00, 0.00, 0.00, 0.00/) + +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + WLTSMC=(/0.023, 0.028, 0.047, 0.084, 0.084, 0.066, + & 0.069, 0.120, 0.103, 0.100, 0.126, 0.135, + & 0.069, 0.028, 0.012, 0.028, 0.135, 0.012, + & 0.023, 0.000, 0.000, 0.000, 0.000, 0.000, + & 0.000, 0.000, 0.000, 0.000, 0.000, 0.000/) +! !!!!!!!!!!!!!! The following values in the table are NOT used +! !!!!!!!!!!!!!! and are just given for reference + SATDW =(/0.6316e-4, 0.5171e-5, 0.8072e-5, 0.2386e-4, 0.2386e-4, + & 0.1433e-4, 0.1006e-4, 0.2358e-4, 0.1130e-4,0.1864e-04, + & 0.9658e-05,0.1151e-04,0.1356e-04,0.5171e-05,0.9978e-05, + & 0.5171e-05, 0.1151e-04, 0.9978e-05, 0.6316e-04, 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00, + & 0.00 , 0.00 , 0.00 , 0.00 , 0.00/) +! ---------------------------------------------------------------------- +! number of defined soiltyps used. +! ---------------------------------------------------------------------- + + defined_soil=19 +! end if soil table + endif + + +! the values shared by different veg/soil type data + +! PT 5/18/2015 - changed to FALSE to match atm_namelist setting +! PT LPARAM is not used anywhere +! LPARAM =.TRUE. + LPARAM =.FALSE. + +! changed for version 2.5.2 +! data zbot_data /-3.0/ + zbot_data =-8.0 +! changed for version 2.6 june 2nd 2003 +! data salp_data /2.6/ + salp_data =4.0 + cfactr_data =0.5 + cmcmax_data =0.5e-3 + sbeta_data =-2.0 + rsmax_data =5000.0 + topt_data =298.0 + refdk_data =2.0e-6 + frzk_data =0.15 + + defined_slope=9 + fxexp_data =2.0 + refkdt_data =3.0 +! changed in version 2.6 june 2nd 2003 +! data czil_data /0.2/ + czil_data =0.075 + +! DATA CSOIL_DATA /1.26E+6/ + CSOIL_DATA = 2.00E+6 +! ---------------------------------------------------------------------- +! READ NAMELIST FILE TO OVERRIDE DEFAULT PARAMETERS ONLY ONCE. +! NAMELIST_NAME must be 50 characters or less. +! ---------------------------------------------------------------------- +!lu: namelist is set up in run script +!PT if (me == 0) write(0,*) 'read namelist cwsoilvegSOIL_VEG' +!$$$ READ(5, SOIL_VEG) +!PT rewind(logunit) +!PT READ(logunit, SOIL_VEG) + +!* WRITE(6, SOIL_VEG) +! OPEN(58, FILE = 'namelist_filename.txt') +! READ(58,'(A)') NAMELIST_NAME +! CLOSE(58) +! WRITE(0,*) 'Namelist Filename is ', NAMELIST_NAME +! OPEN(59, FILE = NAMELIST_NAME) +! 50 CONTINUE +! READ(59, SOIL_VEG, END=100) +! IF (LPARAM) GOTO 50 +! 100 CONTINUE +! CLOSE(59) +#ifdef INTERNAL_FILE_NML + read(input_nml_file, nml=soil_veg_nml, iostat=ios) +#else + inquire (file=trim(Model%fn_nml), exist=exists) + if (.not. exists) then + write(6,*) 'soil_veg_namelist_read:: namelist file: ', + & trim(Model%fn_nml),' does not exist' + stop + else + open (unit=Model%nlunit, file=Model%fn_nml, READONLY, + & status='OLD', iostat=ios) + endif + rewind(Model%nlunit) + read (Model%nlunit,soil_veg_nml) + close (Model%nlunit) + +#endif + + + + + IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN + WRITE(0,*) 'Warning: DEFINED_SOIL too large in namelist' + STOP 222 + ENDIF + IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN + WRITE(0,*) 'Warning: DEFINED_VEG too large in namelist' + STOP 222 + ENDIF + IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN + WRITE(0,*) 'Warning: DEFINED_SLOPE too large in namelist' + STOP 222 + ENDIF + +!--- write namelist to log file --- + if (Model%me == Model%master) then + write(logunit, *) + $ "=============================================" + write(logunit, *) "Soil/vegetation parameters" + write(logunit, nml=soil_veg_nml) + endif + + SMLOW = SMLOW_DATA + SMHIGH = SMHIGH_DATA + + DO I = 1,DEFINED_SOIL + if (satdk(i) /= 0.0 .and. bb(i) > 0.0) then + SATDW(I) = BB(I)*SATDK(I)*(SATPSI(I)/MAXSMC(I)) + F11(I) = ALOG10(SATPSI(I)) + BB(I)*ALOG10(MAXSMC(I)) + 2.0 + REFSMC1 = MAXSMC(I)*(5.79E-9/SATDK(I)) + & **(1.0/(2.0*BB(I)+3.0)) + REFSMC(I) = REFSMC1 + (MAXSMC(I)-REFSMC1) / SMHIGH + WLTSMC1 = MAXSMC(I) * (200.0/SATPSI(I))**(-1.0/BB(I)) + WLTSMC(I) = WLTSMC1 - SMLOW * WLTSMC1 + +! ---------------------------------------------------------------------- +! CURRENT VERSION DRYSMC VALUES THAT EQUATE TO WLTSMC. +! FUTURE VERSION COULD LET DRYSMC BE INDEPENDENTLY SET VIA NAMELIST. +! ---------------------------------------------------------------------- +! DRYSMC(I) = WLTSMC(I) + endif + END DO + +! if (me == 0) write(6,soil_veg) + !! DEBUG CODE + if (Model%me == Model%master) print*, Model%me, + $ ' czil_data = ', czil_data + !! END DEBUG CODE + return + end diff --git a/gsmphys/sfc_cice.f b/gsmphys/sfc_cice.f new file mode 100644 index 00000000..8c60540a --- /dev/null +++ b/gsmphys/sfc_cice.f @@ -0,0 +1,112 @@ +!----------------------------------- + subroutine sfc_cice & +!................................... +! --- inputs: + & ( im, u1, v1, t1, q1, cm, ch, prsl1, prslki, & + & islimsk, ddvel, flag_iter, dqsfc, dtsfc, & +! --- outputs: + & qsurf, cmm, chh, evap, hflx ) + +! ===================================================================== ! +! description: ! +! Sep 2015 -- Xingren Wu created from sfc_sice for coupling to CICE ! +! ! +! usage: ! +! ! +! call sfc_cice ! +! inputs: ! +! ( im, u1, v1, t1, q1, cm, ch, prsl1, prslki, ! +! islimsk, ddvel, flag_iter, dqsfc, dtsfc, ! +! outputs: ! +! qsurf, cmm, chh, evap, hflx) ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: +! im, - integer, horiz dimension +! u1, v1 - real, u/v component of surface layer wind +! t1 - real, surface layer mean temperature ( k ) +! q1 - real, surface layer mean specific humidity +! cm - real, surface exchange coeff for momentum (m/s) +! ch - real, surface exchange coeff heat & moisture(m/s) +! prsl1 - real, surface layer mean pressure +! prslki - real, ? +! islimsk - integer, sea/land/ice mask +! ddvel - real, ? +! flag_iter- logical +! dqsfc - real, latent heat flux +! dtsfc - real, sensible heat flux +! outputs: +! qsurf - real, specific humidity at sfc +! cmm - real, ? +! chh - real, ? +! evap - real, evaperation from latent heat +! hflx - real, sensible heat +! ===================================================================== ! +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, only : hvap => con_hvap, cp => con_cp, & + & eps => con_eps, epsm1 => con_epsm1, & + & rvrdm1 => con_fvirt, rd => con_rd +! + implicit none +! +! --- constant parameters: + real(kind=kind_phys), parameter :: cpinv = 1.0/cp + real(kind=kind_phys), parameter :: hvapi = 1.0/hvap + real(kind=kind_phys), parameter :: elocp = hvap/cp + +! --- inputs: + integer, intent(in) :: im + + real (kind=kind_phys), dimension(im), intent(in) :: u1, v1, & + & t1, q1, cm, ch, prsl1, prslki, ddvel, dqsfc, dtsfc + + integer, dimension(im), intent(in) :: islimsk + + logical, intent(in) :: flag_iter(im) + +! --- outputs: + real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & + & cmm, chh, evap, hflx + +! --- locals: + real (kind=kind_phys), dimension(im) :: q0, rch, rho, tv1, wind + + real (kind=kind_phys) :: tem + + integer :: i + + logical :: flag(im) +! + + do i = 1, im + flag(i) = (islimsk(i) == 4) .and. flag_iter(i) + enddo +! + do i = 1, im + if (flag(i)) then + + wind(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + & + max(0.0, min(ddvel(i), 30.0)) + wind(i) = max(wind(i), 1.0) + + q0(i) = max(q1(i), 1.0e-8) + tv1(i) = t1(i) * (1.0 + rvrdm1*q0(i)) + rho(i) = prsl1(i) / (rd*tv1(i)) + + cmm(i) = cm(i) * wind(i) + chh(i) = rho(i) * ch(i) * wind(i) + rch(i) = chh(i) * cp + + qsurf(i) = q1(i) + dqsfc(i) / (elocp*rch(i)) + tem = 1.0 / rho(i) + hflx(i) = dtsfc(i) * tem * cpinv + evap(i) = dqsfc(i) * tem * hvapi + endif + enddo + + return + + end subroutine sfc_cice diff --git a/gsmphys/sfc_diag.f b/gsmphys/sfc_diag.f new file mode 100644 index 00000000..0ed0dfe1 --- /dev/null +++ b/gsmphys/sfc_diag.f @@ -0,0 +1,60 @@ + subroutine sfc_diag(im,ps,u1,v1,t1,q1, + & tskin,qsurf,f10m,u10m,v10m,t2m,q2m, + & prslki,evap,fm,fh,fm10,fh2) +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, grav => con_g, cp => con_cp, + & eps => con_eps, epsm1 => con_epsm1 + implicit none +! + integer im + real, dimension(im) :: ps, u1, v1, t1, q1, tskin, qsurf, + & f10m, u10m, v10m, t2m, q2m, prslki, evap, + & fm, fh, fm10, fh2 +! +! locals +! + real (kind=kind_phys), parameter :: qmin=1.0e-8 + integer k,i +! + real(kind=kind_phys) fhi, qss, wrk +! real(kind=kind_phys) sig2k, fhi, qss +! +! real, parameter :: g=grav +! +! estimate sigma ** k at 2 m +! +! sig2k = 1. - 4. * g * 2. / (cp * 280.) +! +! initialize variables. all units are supposedly m.k.s. unless specified +! ps is in pascals +! +!! + do i = 1, im + f10m(i) = fm10(i) / fm(i) +! f10m(i) = min(f10m(i),1.) + u10m(i) = f10m(i) * u1(i) + v10m(i) = f10m(i) * v1(i) + fhi = fh2(i) / fh(i) +! t2m(i) = tskin(i)*(1. - fhi) + t1(i) * prslki(i) * fhi +! sig2k = 1. - (grav+grav) / (cp * t2m(i)) +! t2m(i) = t2m(i) * sig2k + wrk = 1.0 - fhi + + t2m(i) = tskin(i)*wrk + t1(i)*prslki(i)*fhi - (grav+grav)/cp + + if(evap(i) >= 0.) then ! for evaporation>0, use inferred qsurf to deduce q2m + q2m(i) = qsurf(i)*wrk + max(qmin,q1(i))*fhi + else ! for dew formation, use saturated q at tskin + qss = fpvs(tskin(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = qss*wrk + max(qmin,q1(i))*fhi + endif + qss = fpvs(t2m(i)) + qss = eps * qss / (ps(i) + epsm1 * qss) + q2m(i) = min(q2m(i),qss) + enddo + + return + end diff --git a/gsmphys/sfc_diff.f b/gsmphys/sfc_diff.f new file mode 100644 index 00000000..9220d4da --- /dev/null +++ b/gsmphys/sfc_diff.f @@ -0,0 +1,421 @@ + subroutine sfc_diff(im,ps,u1,v1,t1,q1,z1, + & snwdph,tskin,z0rl,cm,ch,rb, + & prsl1,prslki,islimsk, + & stress,fm,fh, + & ustar,wind,ddvel,fm10,fh2, + & sigmaf,vegtype,shdmax,ivegsrc, + & tsurf,flag_iter,redrag,czilc, + & z0s_max, + & do_z0_moon, do_z0_hwrf15, do_z0_hwrf17, + & do_z0_hwrf17_hwonly, wind_th_hwrf) +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, grav => con_g, cp => con_cp + &, rvrdm1 => con_fvirt, rd => con_rd + &, eps => con_eps, epsm1 => con_epsm1 + + implicit none +! + integer im, ivegsrc + real(kind=kind_phys), dimension(im) :: ps, u1, v1, t1, q1, z1 + &, tskin, z0rl, cm, ch, rb + &, prsl1, prslki, stress + &, fm, fh, ustar, wind, ddvel + &, fm10, fh2, sigmaf, shdmax + &, tsurf, snwdph + integer, dimension(im) :: vegtype, islimsk + real(kind=kind_phys) czilc + + logical flag_iter(im) ! added by s.lu + logical redrag ! reduced drag coeff. flag for high wind over sea (j.han) + logical do_z0_moon, do_z0_hwrf15, do_z0_hwrf17 + &, do_z0_hwrf17_hwonly ! added by kgao +! +! locals +! + integer i +! + real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv,qs1, + & hl1, hl12, pm, ph, pm10, ph2, rat, + & thv1, tvs, z1i, z0, z0max, ztmax, + & fms, fhs, hl0, hl0inf, hlinf, + & hl110, hlt, hltinf, olinf, + & restar, tem1, tem2, ztmax1, + & z0_adj, wind_th_moon, ustar_th, a,b,c, !kgao + & u10m, v10m, ws10m !kgao +! + + real(kind=kind_phys),intent(in ) :: z0s_max, wind_th_hwrf ! kgao + + real(kind=kind_phys), parameter :: + & charnock=.014, ca=.4 ! ca - von karman constant + &, alpha=5., a0=-3.975, a1=12.32, alpha4=4.0*alpha + &, b1=-7.755, b2=6.041, alpha2=alpha+alpha, beta=1.0 + &, a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899 + &, vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis + + &, log01=log(0.01), log05=log(0.05), log07=log(0.07) + &, ztmin1=-999.0 +! following is added by kgao + &, bs0=-8.367276172397277e-12 + &, bs1=1.7398510865876079e-09 + &, bs2=-1.331896578363359e-07 + &, bs3=4.507055294438727e-06 + &, bs4=-6.508676881906914e-05 + &, bs5=0.00044745137674732834 + &, bs6=-0.0010745704660847233 + &, cf0=2.1151080765239772e-13 + &, cf1=-3.2260663894433345e-11 + &, cf2=-3.329705958751961e-10 + &, cf3=1.7648562021709124e-07 + &, cf4=7.107636825694182e-06 + &, cf5=-0.0013914681964973246 + &, cf6=0.0406766967657759 + &, p13=-1.296521881682694e-02 + &, p12= 2.855780863283819e-01 + &, p11=-1.597898515251717e+00 + &, p10=-8.396975715683501e+00 + &, p25= 3.790846746036765e-10 + &, p24= 3.281964357650687e-09 + &, p23= 1.962282433562894e-07 + &, p22=-1.240239171056262e-06 + &, p21=1.739759082358234e-07 + &, p20=2.147264020369413e-05 + &, p35=1.840430200185075e-07 + &, p34=-2.793849676757154e-05 + &, p33=1.735308193700643e-03 + &, p32=-6.139315534216305e-02 + &, p31=1.255457892775006e+00 + &, p30=-1.663993561652530e+01 + &, p40=4.579369142033410e-04 + +! parameter (charnock=.014,ca=.4)!c ca is the von karman constant +! parameter (alpha=5.,a0=-3.975,a1=12.32,b1=-7.755,b2=6.041) +! parameter (a0p=-7.941,a1p=24.75,b1p=-8.705,b2p=7.899,vis=1.4e-5) + +! real(kind=kind_phys) aa1,bb1,bb2,cc,cc1,cc2,arnu +! parameter (aa1=-1.076,bb1=.7045,cc1=-.05808) +! parameter (bb2=-.1954,cc2=.009999) +! parameter (arnu=.135*rnu) +! +! z0s_max=.196e-2 for u10_crit=25 m/s +! z0s_max=.317e-2 for u10_crit=30 m/s +! z0s_max=.479e-2 for u10_crit=35 m/s +! +! mbek -- toga-coare flux algorithm +! parameter (rnu=1.51e-5,arnu=0.11*rnu) +! +! initialize variables. all units are supposedly m.k.s. unless specified +! ps is in pascals, wind is wind speed, +! surface roughness length is converted to m from cm +! + do i=1,im + if(flag_iter(i)) then + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) + & + max(0.0, min(ddvel(i), 30.0)), 1.0) + tem1 = 1.0 + rvrdm1 * max(q1(i),1.e-8) + thv1 = t1(i) * prslki(i) * tem1 + tvs = 0.5 * (tsurf(i)+tskin(i)) * tem1 + qs1 = fpvs(t1(i)) + qs1 = max(1.0e-8, eps * qs1 / (prsl1(i) + epsm1 * qs1)) + + z0 = 0.01 * z0rl(i) + z0max = max(1.0e-6, min(z0,z1(i))) + z1i = 1.0 / z1(i) + +! compute stability dependent exchange coefficients +! this portion of the code is presently suppressed +! + + if(islimsk(i) == 0) then ! over ocean + ustar(i) = sqrt(grav * z0 / charnock) + +!** test xubin's new z0 + +! ztmax = z0max + + restar = max(ustar(i)*z0max*visi, 0.000001) + +! restar = log(restar) +! restar = min(restar,5.) +! restar = max(restar,-5.) +! rat = aa1 + (bb1 + cc1*restar) * restar +! rat = rat / (1. + (bb2 + cc2*restar) * restar)) +! rat taken from zeng, zhao and dickinson 1997 + + rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) + ztmax = z0max * exp(-rat) + + else ! over land and sea ice +!** xubin's new z0 over land and sea ice + tem1 = 1.0 - shdmax(i) + tem2 = tem1 * tem1 + tem1 = 1.0 - tem2 + + if( ivegsrc == 1 ) then + + if (vegtype(i) == 10) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 6) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 7) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + elseif (vegtype(i) == 16) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + elseif (ivegsrc == 2 ) then + + if (vegtype(i) == 7) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 8) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 9) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + elseif (vegtype(i) == 11) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + endif + z0max = max(z0max,1.0e-6) +! +! czilc = 10.0 ** (- (0.40/0.07) * z0) ! fei's canopy height dependance of czil +! czilc = 0.8 + + tem1 = 1.0 - sigmaf(i) + ztmax = z0max*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar(i)*(0.01/1.5e-05))) + + endif ! end of if(islimsk(i) == 0) then + + ztmax = max(ztmax,1.0e-6) + tem1 = z0max/z1(i) + if (abs(1.0-tem1) > 1.0e-6) then + ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1)) + else + ztmax1 = 99.0 + endif + if( z0max < 0.05 .and. snwdph(i) < 10.0 ) ztmax1 = 99.0 + + +! compute stability indices (rb and hlinf) + + dtv = thv1 - tvs + adtv = max(abs(dtv),0.001) + dtv = sign(1.,dtv) * adtv + rb(i) = max(-5000.0, (grav+grav) * dtv * z1(i) + & / ((thv1 + tvs) * wind(i) * wind(i))) + tem1 = 1.0 / z0max + tem2 = 1.0 / ztmax + fm(i) = log((z0max+z1(i)) * tem1) + fh(i) = log((ztmax+z1(i)) * tem2) + fm10(i) = log((z0max+10.) * tem1) + fh2(i) = log((ztmax+2.) * tem2) + hlinf = rb(i) * fm(i) * fm(i) / fh(i) + hlinf = min(max(hlinf,ztmin1),ztmax1) +! +! stable case +! + if (dtv >= 0.0) then + hl1 = hlinf + if(hlinf > .25) then + tem1 = hlinf * z1i + hl0inf = z0max * tem1 + hltinf = ztmax * tem1 + aa = sqrt(1. + alpha4 * hlinf) + aa0 = sqrt(1. + alpha4 * hl0inf) + bb = aa + bb0 = sqrt(1. + alpha4 * hltinf) + pm = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) ) + ph = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) ) + fms = fm(i) - pm + fhs = fh(i) - ph + hl1 = fms * fms * rb(i) / fhs + hl1 = min(max(hl1, ztmin1), ztmax1) + endif +! +! second iteration +! + tem1 = hl1 * z1i + hl0 = z0max * tem1 + hlt = ztmax * tem1 + aa = sqrt(1. + alpha4 * hl1) + aa0 = sqrt(1. + alpha4 * hl0) + bb = aa + bb0 = sqrt(1. + alpha4 * hlt) + pm = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + ph = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + aa = sqrt(1. + alpha4 * hl110) + pm10 = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12,ztmin1),ztmax1) +! aa = sqrt(1. + alpha4 * hl12) + bb = sqrt(1. + alpha4 * hl12) + ph2 = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) +! +! unstable case - check for unphysical obukhov length +! + else ! dtv < 0 case + olinf = z1(i) / hlinf + tem1 = 50.0 * z0max + if(abs(olinf) <= tem1) then + hlinf = -z1(i) / tem1 + hlinf = min(max(hlinf,ztmin1),ztmax1) + endif +! +! get pm and ph +! + if (hlinf >= -0.5) then + hl1 = hlinf + pm = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + ph = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12) + else ! hlinf < 0.05 + hl1 = -hlinf + tem1 = 1.0 / sqrt(hl1) + pm = log(hl1) + 2. * sqrt(tem1) - .8776 + ph = log(hl1) + .5 * tem1 + 1.386 +! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 +! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776 +! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = log(hl12) + 0.5 / sqrt(hl12) + 1.386 +! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 + endif + + endif ! end of if (dtv >= 0 ) then loop +! +! finish the exchange coefficient computation to provide fm and fh +! + fm(i) = fm(i) - pm + fh(i) = fh(i) - ph + fm10(i) = fm10(i) - pm10 + fh2(i) = fh2(i) - ph2 + cm(i) = ca * ca / (fm(i) * fm(i)) + ch(i) = ca * ca / (fm(i) * fh(i)) + tem1 = 0.00001/z1(i) + cm(i) = max(cm(i), tem1) + ch(i) = max(ch(i), tem1) + stress(i) = cm(i) * wind(i) * wind(i) + ustar(i) = sqrt(stress(i)) +! +! update z0 over ocean +! + if(islimsk(i) == 0) then + + z0 = (charnock / grav) * ustar(i) * ustar(i) + +! mbek -- toga-coare flux algorithm +! z0 = (charnock / grav) * ustar(i)*ustar(i) + arnu/ustar(i) +! new implementation of z0 +! cc = ustar(i) * z0 / rnu +! pp = cc / (1. + cc) +! ff = grav * arnu / (charnock * ustar(i) ** 3) +! z0 = arnu / (ustar(i) * ff ** pp) + +! -------------------------- modify z0 by kgao + +! diagnose 10m wind (same as sfc_diag.f) + + u10m = u1(i) * fm10(i) / fm(i) + v10m = v1(i) * fm10(i) / fm(i) + ws10m = sqrt(u10m*u10m + v10m*v10m) + +! option - URI/GFDL (HWRF 2015) +! note there is discontinuity at 10m/s in original formulation +! needs to be fixed + + if (do_z0_hwrf15) then + if (ws10m <= 5.0) then + z0 = 0.0185/9.8*(7.59e-4*ws10m**2+2.46e-2*ws10m)**2 + elseif (ws10m > 5.0 .and. ws10m <= 10.) then + z0 = 0.00000235*(ws10m**2-25.)+3.805129199617346e-05 + elseif (ws10m > 10.0 .and. ws10m <= 60.) then + z0 = bs6 + bs5*ws10m + bs4*ws10m**2 + bs3*ws10m**3 + & + bs2*ws10m**4 + bs1*ws10m**5 + bs0*ws10m**6 + else + z0 = cf6 + cf5*ws10m + cf4*ws10m**2 + cf3*ws10m**3 + & + cf2*ws10m**4 + cf1*ws10m**5 + cf0*ws10m**6 + endif + endif + +! option - HWRF 2017 + + if (do_z0_hwrf17) then + if (ws10m <= 6.5) then + z0 = exp( p10 + p11*ws10m + p12*ws10m**2 + p13*ws10m**3) + elseif (ws10m > 6.5 .and. ws10m <= 15.7) then + z0 = p25*ws10m**5 + p24*ws10m**4 + p23*ws10m**3 + & + p22*ws10m**2 + p21*ws10m + p20 + elseif (ws10m > 15.7 .and. ws10m <= 53.) then + z0 = exp( p35*ws10m**5 + p34*ws10m**4 + p33*ws10m**3 + & + p32*ws10m**2 + p31*ws10m + p30 ) + else + z0 = p40 + endif + endif + +! option - GFS (low wind) + HWRF 2017 (high wind) + + if (do_z0_hwrf17_hwonly) then + + if (ws10m > wind_th_hwrf .and. ws10m <= 53.) then + z0 = exp( p35*ws10m**5 + p34*ws10m**4 + p33*ws10m**3 + & + p32*ws10m**2 + p31*ws10m + p30 ) + elseif (ws10m > 53.) then + z0 = p40 + endif + + endif + +! option - GFS (low wind) + Moon et al (high wind) + + if (do_z0_moon) then + wind_th_moon = 20. + a = 0.56 + b = -20.255 + c = wind_th_moon - 2.458 + ustar_th = (-b-sqrt(b*b-4*a*c))/(2*a) + + z0_adj = 0.001*(0.085*wind_th_moon - 0.58) - + & (charnock/grav)*ustar_th*ustar_th + + ws10m = 2.458 + ustar(i)*(20.255-0.56*ustar(i)) ! Eq(7) Moon et al. 2007 + if ( ws10m > wind_th_moon ) then ! No modification in low wind conditions + z0 = 0.001*(0.085*ws10m - 0.58) - z0_adj ! Eq(8b) Moon et al. 2007 modified by kgao + endif + endif + +! ---------------------------- modify z0 end + + if (redrag) then + z0rl(i) = 100.0 * max(min(z0, z0s_max), 1.e-7) + else + z0rl(i) = 100.0 * max(min(z0,.1), 1.e-7) + endif + endif + endif ! end of if(flagiter) loop + enddo + + return + end diff --git a/gsmphys/sfc_diff_gfdl.f b/gsmphys/sfc_diff_gfdl.f new file mode 100644 index 00000000..139f2586 --- /dev/null +++ b/gsmphys/sfc_diff_gfdl.f @@ -0,0 +1,614 @@ + subroutine sfc_diff_gfdl(im,ps,u1,v1,t1,q1,z1, + & snwdph,tskin,z0rl,ztrl,cm,ch,rb, + & prsl1,prslki,islimsk, + & stress,fm,fh, + & ustar,wind,ddvel,fm10,fh2, + & sigmaf,vegtype,shdmax,ivegsrc, + & tsurf,flag_iter,redrag, + & z0s_max, + & do_z0_moon, do_z0_hwrf15, do_z0_hwrf17, + & do_z0_hwrf17_hwonly, wind_th_hwrf) + +! oct 2019 - a clean and updated version by Kun Gao at GFDL (Kun.Gao@noaa.gov) + + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, grav => con_g, cp => con_cp + &, rvrdm1 => con_fvirt, rd => con_rd + &, eps => con_eps, epsm1 => con_epsm1 + + implicit none + +! --- input/output + + integer im, ivegsrc + + real(kind=kind_phys), dimension(im)::ps, u1, v1, t1, q1, z1 + &, tskin, z0rl, ztrl, cm, ch, rb + &, prsl1, prslki, stress + &, fm, fh, ustar, wind, ddvel + &, fm10, fh2, sigmaf, shdmax + &, tsurf, snwdph + integer, dimension(im) ::vegtype, islimsk + + logical flag_iter(im) + logical redrag + logical do_z0_moon, do_z0_hwrf15, do_z0_hwrf17 ! kgao + &, do_z0_hwrf17_hwonly ! kgao + +! --- local + + integer i +! + real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv,qs1, + & hl1, hl12, pm, ph, pm10, ph2, rat, + & thv1, tvs, z1i, z0, zt, z0max, ztmax, + & fms, fhs, hl0, hl0inf, hlinf, + & hl110, hlt, hltinf, olinf, + & restar, czilc, tem1, tem2, + & u10m, v10m, ws10m, ws10m_moon, !kgao + & z0_1, zt_1, fm1, fh1, ustar_1, ztmax_1 !kgao +! + + real(kind=kind_phys),intent(in ) :: z0s_max, wind_th_hwrf ! kgao + + real(kind=kind_phys), parameter :: + & charnock=.014, ca=.4 + &, vis=1.4e-5, rnu=1.51e-5, visi=1.0/vis + &, log01=log(0.01), log05=log(0.05), log07=log(0.07) + &, ztmin1=-999.0 + +!================================================ +! Main program starts here +!================================================ + + do i=1,im + + if(flag_iter(i)) then + +! --- get variables at model lowest layer and surface (water/ice/land) + + wind(i) = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) + & + max(0.0, min(ddvel(i), 30.0)), 1.0) + tem1 = 1.0 + rvrdm1 * max(q1(i),1.e-8) + thv1 = t1(i) * prslki(i) * tem1 + tvs = 0.5 * (tsurf(i)+tskin(i)) * tem1 + qs1 = fpvs(t1(i)) + qs1 = max(1.0e-8, eps * qs1 / (prsl1(i) + epsm1 * qs1)) + + !(sea/land/ice mask =0/1/2) + if(islimsk(i) == 1 .or. islimsk(i) == 2) then ! over land or sea ice + +!================================================ +! if over land or sea ice: +! step 1 - get z0/zt +! step 2 - call similarity +!================================================ + +! --- get surface roughness for momentum (z0) + + z0 = 0.01 * z0rl(i) + z0max = max(1.0e-6, min(z0,z1(i))) + + !xubin's new z0 over land and sea ice + tem1 = 1.0 - shdmax(i) ! shdmax is max vegetation area fraction + tem2 = tem1 * tem1 + tem1 = 1.0 - tem2 + + if( ivegsrc == 1 ) then + + if (vegtype(i) == 10) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 6) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 7) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + elseif (vegtype(i) == 16) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + elseif (ivegsrc == 2 ) then + + if (vegtype(i) == 7) then + z0max = exp( tem2*log01 + tem1*log07 ) + elseif (vegtype(i) == 8) then + z0max = exp( tem2*log01 + tem1*log05 ) + elseif (vegtype(i) == 9) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + elseif (vegtype(i) == 11) then +! z0max = exp( tem2*log01 + tem1*log01 ) + z0max = 0.01 + else + z0max = exp( tem2*log01 + tem1*log(z0max) ) + endif + + z0max = max(z0max,1.0e-6) + + endif + +! --- get surface roughness for heat (zt) + +! czilc = 10.0 ** (- (0.40/0.07) * z0) ! let czilc depend on canopy height + czilc = 0.8 + + tem1 = 1.0 - sigmaf(i) + ztmax = z0max*exp( - tem1*tem1 + & * czilc*ca*sqrt(ustar(i)*(0.01/1.5e-05))) + + ztmax = max(ztmax,1.0e-6) + +! --- call similarity + + call monin_obukhov_similarity + & (z1(i), snwdph(i), thv1, wind(i), z0max, ztmax, tvs, + & rb(i), fm(i), fh(i), fm10(i), fh2(i), + & cm(i), ch(i), stress(i), ustar(i)) + + elseif (islimsk(i) == 0) then ! over water + +!================================================ +! if over water (redesigned by Kun Gao) +! iteration 1 +! step 1 get z0/zt from previous step +! step 2 call similarity +! iteration 2 +! step 1 update z0/zt +! step 2 call similarity +!================================================ + +! === iteration 1 + + ! --- get z0/zt + z0 = 0.01 * z0rl(i) + zt = 0.01 * ztrl(i) + + z0max = max(1.0e-6, min(z0,z1(i))) + ztmax = max(zt,1.0e-6) + + ! --- call similarity + call monin_obukhov_similarity + & (z1(i), snwdph(i), thv1, wind(i), z0max, ztmax, tvs, + & rb(i), fm(i), fh(i), fm10(i), fh2(i), + & cm(i), ch(i), stress(i), ustar(i)) + +! === iteration 2 + + ! --- get z0/zt following the old sfc_diff.f + z0 = (charnock / grav) * ustar(i) * ustar(i) + if (redrag) then + z0 = max(min(z0, z0s_max), 1.e-7) + else + z0 = max(min(z0,.1), 1.e-7) + endif + + ! zt calculations copied from old sfc_diff.f + !ustar(i) = sqrt(grav * z0 / charnock) + !restar = max(ustar(i)*z0max*visi, 0.000001) + !rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) + !ztmax = z0max * exp(-rat) + + ustar_1 = sqrt(grav * z0 / charnock) + restar = max(ustar_1*z0max*visi, 0.000001) + rat = min(7.0, 2.67 * sqrt(sqrt(restar)) - 2.57) + zt = z0max * exp(-rat) ! zeng, zhao and dickinson 1997 (eq 25) + + ! --- update z0/zt with new options + ! only z0 options in the following + ! will add zt options in the future + + u10m = u1(i) * fm10(i) / fm(i) + v10m = v1(i) * fm10(i) / fm(i) + ws10m = sqrt(u10m*u10m + v10m*v10m) + + if (do_z0_hwrf15) then + ! option 1: HWRF15, originally developed by URI/GFDL + call cal_z0_hwrf15(ws10m, z0) + call cal_zt_hwrf15(ws10m, zt) + + elseif (do_z0_hwrf17) then + ! option 2: HWRF17 + call cal_z0_hwrf17(ws10m, z0) + call cal_zt_hwrf17(ws10m, zt) + + elseif (do_z0_hwrf17_hwonly) then + ! option 3: HWRF17 under high wind only + if (ws10m > wind_th_hwrf) then + call cal_z0_hwrf17(ws10m, z0) + z0 = max(min(z0, z0s_max), 1.e-7) ! must apply limiter here + endif + + elseif (do_z0_moon) then + ! option 4: Moon et al 2007 under high winds (same as in HiRAM) + ws10m_moon = 2.458 + ustar(i)*(20.255-0.56*ustar(i)) ! Eq(7) Moon et al. 2007 + if ( ws10m_moon > 20. ) then + call cal_z0_moon(ws10m_moon, z0) + z0 = max(min(z0, z0s_max), 1.e-7) ! must apply limiter here + endif + endif + + z0max = max(z0,1.0e-6) + ztmax = max(zt,1.0e-6) + + ! --- call similarity + call monin_obukhov_similarity + & (z1(i), snwdph(i), thv1, wind(i), z0max, ztmax, tvs, + & rb(i), fm(i), fh(i), fm10(i), fh2(i), + & cm(i), ch(i), stress(i), ustar(i)) + + z0rl(i) = 100.0 * z0max + ztrl(i) = 100.0 * ztmax + + endif ! end of if(islimsk) loop + endif ! end of if(flagiter) loop + enddo ! end of do i=1,im loop + + return + end subroutine sfc_diff_gfdl + +! ======================================================================= + + subroutine cal_z0_hwrf15(ws10m, z0) + ! coded by Kun Gao (Kun.Gao@noaa.gov) + ! originally developed by URI/GFDL + use machine , only : kind_phys + real(kind=kind_phys) :: ws10m, z0 + real(kind=kind_phys), parameter :: + & a0=-8.367276172397277e-12 + &, a1=1.7398510865876079e-09 + &, a2=-1.331896578363359e-07 + &, a3=4.507055294438727e-06 + &, a4=-6.508676881906914e-05 + &, a5=0.00044745137674732834 + &, a6=-0.0010745704660847233 + &, b0=2.1151080765239772e-13 + &, b1=-3.2260663894433345e-11 + &, b2=-3.329705958751961e-10 + &, b3=1.7648562021709124e-07 + &, b4=7.107636825694182e-06 + &, b5=-0.0013914681964973246 + &, b6=0.0406766967657759 + + if (ws10m <= 5.0) then + z0 = 0.0185/9.8*(7.59e-4*ws10m**2+2.46e-2*ws10m)**2 + elseif (ws10m > 5.0 .and. ws10m <= 10.) then + z0 = 0.00000235*(ws10m**2-25.)+3.805129199617346e-05 + elseif (ws10m > 10.0 .and. ws10m <= 60.) then + z0 = a6 + a5*ws10m + a4*ws10m**2 + a3*ws10m**3 + & + a2*ws10m**4 + a1*ws10m**5 + a0*ws10m**6 + else + z0 = b6 + b5*ws10m + b4*ws10m**2 + b3*ws10m**3 + & + b2*ws10m**4 + b1*ws10m**5 + b0*ws10m**6 + endif + + end subroutine cal_z0_hwrf15 + + subroutine cal_zt_hwrf15(ws10m, zt) + ! coded by Kun Gao (Kun.Gao@noaa.gov) + ! originally developed by URI/GFDL + use machine , only : kind_phys + real(kind=kind_phys) :: ws10m, zt + real(kind=kind_phys), parameter :: + & a0 = 2.51715926619e-09 + &, a1 = -1.66917514012e-07 + &, a2 = 4.57345863551e-06 + &, a3 = -6.64883696932e-05 + &, a4 = 0.00054390175125 + &, a5 = -0.00239645231325 + &, a6 = 0.00453024927761 + &, b0 = -1.72935914649e-14 + &, b1 = 2.50587455802e-12 + &, b2 = -7.90109676541e-11 + &, b3 = -4.40976353607e-09 + &, b4 = 3.68968179733e-07 + &, b5 = -9.43728336756e-06 + &, b6 = 8.90731312383e-05 + &, c0 = 4.68042680888e-14 + &, c1 = -1.98125754931e-11 + &, c2 = 3.41357133496e-09 + &, c3 = -3.05130605309e-07 + &, c4 = 1.48243563819e-05 + &, c5 = -0.000367207751936 + &, c6 = 0.00357204479347 + + if (ws10m <= 7.0) then + zt = 0.0185/9.8*(7.59e-4*ws10m**2+2.46e-2*ws10m)**2 + elseif (ws10m > 7.0 .and. ws10m <= 15.) then + zt = a6 + a5*ws10m + a4*ws10m**2 + a3*ws10m**3 + & + a2*ws10m**4 + a1*ws10m**5 + a0*ws10m**6 + elseif (ws10m > 15.0 .and. ws10m <= 60.) then + zt = b6 + b5*ws10m + b4*ws10m**2 + b3*ws10m**3 + & + b2*ws10m**4 + b1*ws10m**5 + b0*ws10m**6 + else + zt = c6 + c5*ws10m + c4*ws10m**2 + c3*ws10m**3 + & + c2*ws10m**4 + c1*ws10m**5 + c0*ws10m**6 + endif + end subroutine cal_zt_hwrf15 + +! ======================================================================= + + subroutine cal_z0_hwrf17(ws10m, z0) + ! coded by Kun Gao (Kun.Gao@noaa.gov) + use machine , only : kind_phys + real(kind=kind_phys) :: ws10m, z0 + real(kind=kind_phys), parameter :: + & p13=-1.296521881682694e-02 + &, p12= 2.855780863283819e-01 + &, p11=-1.597898515251717e+00 + &, p10=-8.396975715683501e+00 + &, p25= 3.790846746036765e-10 + &, p24= 3.281964357650687e-09 + &, p23= 1.962282433562894e-07 + &, p22=-1.240239171056262e-06 + &, p21=1.739759082358234e-07 + &, p20=2.147264020369413e-05 + &, p35=1.840430200185075e-07 + &, p34=-2.793849676757154e-05 + &, p33=1.735308193700643e-03 + &, p32=-6.139315534216305e-02 + &, p31=1.255457892775006e+00 + &, p30=-1.663993561652530e+01 + &, p40=4.579369142033410e-04 + + if (ws10m <= 6.5) then + z0 = exp( p10 + p11*ws10m + p12*ws10m**2 + p13*ws10m**3) + elseif (ws10m > 6.5 .and. ws10m <= 15.7) then + z0 = p25*ws10m**5 + p24*ws10m**4 + p23*ws10m**3 + & + p22*ws10m**2 + p21*ws10m + p20 + elseif (ws10m > 15.7 .and. ws10m <= 53.) then + z0 = exp( p35*ws10m**5 + p34*ws10m**4 + p33*ws10m**3 + & + p32*ws10m**2 + p31*ws10m + p30 ) + else + z0 = p40 + endif + end subroutine cal_z0_hwrf17 + + subroutine cal_zt_hwrf17(ws10m, zt) + ! coded by Kun Gao (Kun.Gao@noaa.gov) + use machine , only : kind_phys + real(kind=kind_phys) :: ws10m, zt + real(kind=kind_phys), parameter :: p00 = 1.100000000000000e-04, + & p15 = -9.144581627678278e-10, p14 = 7.020346616456421e-08, + & p13 = -2.155602086883837e-06, p12 = 3.333848806567684e-05, + & p11 = -2.628501274963990e-04, p10 = 8.634221567969181e-04, + & p25 = -8.654513012535990e-12, p24 = 1.232380050058077e-09, + & p23 = -6.837922749505057e-08, p22 = 1.871407733439947e-06, + & p21 = -2.552246987137160e-05, p20 = 1.428968311457630e-04, + & p35 = 3.207515102100162e-12, p34 = -2.945761895342535e-10, + & p33 = 8.788972147364181e-09, p32 = -3.814457439412957e-08, + & p31 = -2.448983648874671e-06, p30 = 3.436721779020359e-05, + & p45 = -3.530687797132211e-11, p44 = 3.939867958963747e-09, + & p43 = -1.227668406985956e-08, p42 = -1.367469811838390e-05, + & p41 = 5.988240863928883e-04, p40 = -7.746288511324971e-03, + & p56 = -1.187982453329086e-13, p55 = 4.801984186231693e-11, + & p54 = -8.049200462388188e-09, p53 = 7.169872601310186e-07, + & p52 = -3.581694433758150e-05, p51 = 9.503919224192534e-04, + & p50 = -1.036679430885215e-02, + & p60 = 4.751256171799112e-05 + + if (ws10m >= 0.0 .and. ws10m < 5.9 ) then + zt = p00 + elseif (ws10m >= 5.9 .and. ws10m <= 15.4) then + zt = p10 + ws10m * (p11 + ws10m * (p12 + ws10m * (p13 + & + ws10m * (p14 + ws10m * p15)))) + elseif (ws10m > 15.4 .and. ws10m <= 21.6) then + zt = p20 + ws10m * (p21 + ws10m * (p22 + ws10m * (p23 + & + ws10m * (p24 + ws10m * p25)))) + elseif (ws10m > 21.6 .and. ws10m <= 42.2) then + zt = p30 + ws10m * (p31 + ws10m * (p32 + ws10m * (p33 + & + ws10m * (p34 + ws10m * p35)))) + elseif ( ws10m > 42.2 .and. ws10m <= 53.3) then + zt = p40 + ws10m * (p41 + ws10m * (p42 + ws10m * (p43 + & + ws10m * (p44 + ws10m * p45)))) + elseif ( ws10m > 53.3 .and. ws10m <= 80.0) then + zt = p50 + ws10m * (p51 + ws10m * (p52 + ws10m * (p53 + & + ws10m * (p54 + ws10m * (p55 + ws10m * p56))))) + elseif ( ws10m > 80.0) then + zt = p60 + endif + end subroutine cal_zt_hwrf17 + +! ======================================================================= + + subroutine cal_z0_moon(ws10m, z0) + ! coded by Kun Gao (Kun.Gao@noaa.gov) + use machine , only : kind_phys + use physcons, grav => con_g + + real(kind=kind_phys) :: ws10m, z0 + real(kind=kind_phys) :: ustar_th, z0_adj + + real(kind=kind_phys), parameter :: + & charnock=.014 + &, wind_th_moon = 20. + &, a = 0.56 + &, b = -20.255 + &, c = wind_th_moon - 2.458 + + ustar_th = (-b-sqrt(b*b-4*a*c))/(2*a) + + z0_adj = 0.001*(0.085*wind_th_moon - 0.58) - + & (charnock/grav)*ustar_th*ustar_th + + z0 = 0.001*(0.085*ws10m - 0.58) - z0_adj ! Eq(8b) Moon et al. 2007 modified by kgao + + end subroutine cal_z0_moon + +! ======================================================================= + + subroutine monin_obukhov_similarity + & ( z1, snwdph, thv1, wind, z0max, ztmax, tvs, + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar) + +! --- input +! z1 - lowest model level height +! snwdph - surface snow thickness +! wind - wind speed at lowest model layer +! thv1 - virtual potential temp at lowest model layer +! tvs - surface temp +! z0max - surface roughness length for momentum +! ztmax - surface roughness length for heat +! +! --- output +! rb - a bulk richardson number +! fm, fh - similarity function defined at lowest model layer +! fm10, fh2 - similarity function defined at 10m (for momentum) and 2m (for heat) +! cm, ch - surface exchange coefficients for momentum and heat +! stress - surface wind stress +! ustar - surface frictional velocity + + use machine , only : kind_phys + use physcons, grav => con_g + +! --- inputs: + real(kind=kind_phys), intent(in) :: + & z1, snwdph, thv1, wind, z0max, ztmax, tvs + +! --- outputs: + real(kind=kind_phys), intent(out) :: + & rb, fm, fh, fm10, fh2, cm, ch, stress, ustar + +! --- locals: + + real(kind=kind_phys), parameter :: alpha=5., a0=-3.975 + &, a1=12.32, alpha4=4.0*alpha + &, b1=-7.755, b2=6.041, alpha2=alpha+alpha, beta=1.0 + &, a0p=-7.941, a1p=24.75, b1p=-8.705, b2p=7.899 + &, ztmin1=-999.0, ca=.4 + + real(kind=kind_phys) aa, aa0, bb, bb0, dtv, adtv, + & hl1, hl12, pm, ph, pm10, ph2, + & z1i, + & fms, fhs, hl0, hl0inf, hlinf, + & hl110, hlt, hltinf, olinf, + & tem1, tem2, ztmax1 + + z1i = 1.0 / z1 + + tem1 = z0max/z1 + if (abs(1.0-tem1) > 1.0e-6) then + ztmax1 = - beta*log(tem1)/(alpha2*(1.-tem1)) + else + ztmax1 = 99.0 + endif + if( z0max < 0.05 .and. snwdph < 10.0 ) ztmax1 = 99.0 + +! +! compute stability indices (rb and hlinf) +! + dtv = thv1 - tvs + adtv = max(abs(dtv),0.001) + dtv = sign(1.,dtv) * adtv + rb = max(-5000.0, (grav+grav) * dtv * z1 + & / ((thv1 + tvs) * wind * wind)) + tem1 = 1.0 / z0max + tem2 = 1.0 / ztmax + fm = log((z0max+z1) * tem1) + fh = log((ztmax+z1) * tem2) + fm10 = log((z0max+10.) * tem1) + fh2 = log((ztmax+2.) * tem2) + hlinf = rb * fm * fm / fh + hlinf = min(max(hlinf,ztmin1),ztmax1) +! +! stable case +! + if (dtv >= 0.0) then + hl1 = hlinf + if(hlinf > .25) then + tem1 = hlinf * z1i + hl0inf = z0max * tem1 + hltinf = ztmax * tem1 + aa = sqrt(1. + alpha4 * hlinf) + aa0 = sqrt(1. + alpha4 * hl0inf) + bb = aa + bb0 = sqrt(1. + alpha4 * hltinf) + pm = aa0 - aa + log( (aa + 1.)/(aa0 + 1.) ) + ph = bb0 - bb + log( (bb + 1.)/(bb0 + 1.) ) + fms = fm - pm + fhs = fh - ph + hl1 = fms * fms * rb / fhs + hl1 = min(max(hl1, ztmin1), ztmax1) + endif +! +! second iteration +! + tem1 = hl1 * z1i + hl0 = z0max * tem1 + hlt = ztmax * tem1 + aa = sqrt(1. + alpha4 * hl1) + aa0 = sqrt(1. + alpha4 * hl0) + bb = aa + bb0 = sqrt(1. + alpha4 * hlt) + pm = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + ph = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + aa = sqrt(1. + alpha4 * hl110) + pm10 = aa0 - aa + log( (1.0+aa)/(1.0+aa0) ) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12,ztmin1),ztmax1) +! aa = sqrt(1. + alpha4 * hl12) + bb = sqrt(1. + alpha4 * hl12) + ph2 = bb0 - bb + log( (1.0+bb)/(1.0+bb0) ) +! +! unstable case - check for unphysical obukhov length +! + else ! dtv < 0 case + olinf = z1 / hlinf + tem1 = 50.0 * z0max + if(abs(olinf) <= tem1) then + hlinf = -z1 / tem1 + hlinf = min(max(hlinf,ztmin1),ztmax1) + endif +! +! get pm and ph +! + if (hlinf >= -0.5) then + hl1 = hlinf + pm = (a0 + a1*hl1) * hl1 / (1.+ (b1+b2*hl1) *hl1) + ph = (a0p + a1p*hl1) * hl1 / (1.+ (b1p+b2p*hl1)*hl1) + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = (a0 + a1*hl110) * hl110 / (1.+(b1+b2*hl110)*hl110) + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = (a0p + a1p*hl12) * hl12 / (1.+(b1p+b2p*hl12)*hl12) + else ! hlinf < 0.05 + hl1 = -hlinf + tem1 = 1.0 / sqrt(hl1) + pm = log(hl1) + 2. * sqrt(tem1) - .8776 + ph = log(hl1) + .5 * tem1 + 1.386 +! pm = log(hl1) + 2.0 * hl1 ** (-.25) - .8776 +! ph = log(hl1) + 0.5 * hl1 ** (-.5) + 1.386 + hl110 = hl1 * 10. * z1i + hl110 = min(max(hl110, ztmin1), ztmax1) + pm10 = log(hl110) + 2.0 / sqrt(sqrt(hl110)) - .8776 +! pm10 = log(hl110) + 2. * hl110 ** (-.25) - .8776 + hl12 = (hl1+hl1) * z1i + hl12 = min(max(hl12, ztmin1), ztmax1) + ph2 = log(hl12) + 0.5 / sqrt(hl12) + 1.386 +! ph2 = log(hl12) + .5 * hl12 ** (-.5) + 1.386 + endif + + endif ! end of if (dtv >= 0 ) then loop +! +! finish the exchange coefficient computation to provide fm and fh +! + fm = fm - pm + fh = fh - ph + fm10 = fm10 - pm10 + fh2 = fh2 - ph2 + cm = ca * ca / (fm * fm) + ch = ca * ca / (fm * fh) + tem1 = 0.00001/z1 + cm = max(cm, tem1) + ch = max(ch, tem1) + stress = cm * wind * wind + ustar = sqrt(stress) + + return + end subroutine monin_obukhov_similarity diff --git a/gsmphys/sfc_drv.f b/gsmphys/sfc_drv.f new file mode 100644 index 00000000..e5626362 --- /dev/null +++ b/gsmphys/sfc_drv.f @@ -0,0 +1,602 @@ + module module_sfc_drv + contains +!> \file sfc_drv.f +!! This file contains the NOAH land surface scheme. +!> \defgroup NOAH NOAH Land Surface +!! @{ +!! +!! The Noah LSM (Chen et al., 1996; Koren et al., 1999; Ek et al., 2003) is targeted for moderate complexity and good computational efficiency for numerical weather prediction and climate models. Thus, it omits subgrid surface tiling and uses a single-layer snowpack. The surface energy balance is solved via a Penman-based approximation for latent heat flux. The Noah model includes packages to simulate soil moisture, soil ice, soil temperature, skin temperature, snow depth, snow water equivalent, energy fluxes such as latent heat, sensible heat and ground heat, and water fluxes such as evaporation and total runoff. The Noah surface infiltration scheme follows that of Schaake et al. (1996) for its treatment of the subgrid variability of precipitation and soil moisture. +!! +!! On 31 May and 14 June 2005, NCEP extensively upgraded the land-surface component of its Global Forecast System (GFS), including its Global Data Assimilation System (GDAS). The Noah LSM upgrade includes an increase from two (10, 190 cm thick) to four soil layers (10, 30, 60, 100 cm thick), addition of frozen soil physics, new formulations for infiltration and runoff (giving more runoff for unsaturated soils), revised physics of the snowpack and its influence on surface heat fluxes and albedo, tuning and adding canopy resistance parameters, allowing spatially varying root depth, revised treatment of ground heat flux and soil thermal conductivity, reformulation for dependence of direct surface evaporation on first layer soil moisture, and improved seasonality of green vegetation cover. The frozen soil physics includes soil heat sinks/sources from freezing/thawing and influences vertical transport of soil moisture, soil thermal conductivity and heat capacity, and surface infiltration. The prognostic states of snowpack depth and liquid soil moisture were added to the already present prognostic states of snowpack water-equivalent (SWE), total soil moisture (liquid plus frozen), soil temperature, canopy water, and skin temperature. SWE divided by the snowpack depth gives the snowpack density. Total soil moisture minus liquid soil moisture gives the frozen soil moisture (Mitchell et al. 2005) +!! +!! The addition of Noah LSM greatly reduced the two prominent biases in land-surface processes: 1) an early depletion of snowpack; and 2) a high bias in both surface evaporation and precipitation in the warm season in non-arid mid-latitudes. However, a lower tropospheric warm bias as well as increased surface sensible heat flux emerged, particularly over the arid areas during the daytime. Extensive tests attributed this bias mainly to improper treatment of the thermal roughness length. In May 2011, a new thermal roughness length formulation, which assigned a smaller value for the thermal roughness length compared to the momentum roughness length, was implemented. This greatly reduced the warm surface air temperature bias and the cold skin temperature bias over the arid areas during the daytime (Wei et al. 2009; Zheng et al. 2012). +!! +!! In January 2015, CFS/GLDAS soil moisture climatology at T574 was used for soil moisture nudge to replace the out-of-date coarse resolution bucket soil moisture climatology; a dependence of the ratio of the thermal and momentum roughness on vegetation type was added to address the land-atmosphere coupling strength; a look-up table based on vegetation type was used to replace 1.0 degree momentum roughness length climatology. After this implementation summer warm/dry biases were found over cropland/grassland areas. Some evaporation-related parameters were refined to increase the evaporation to address this issue. The refinement was implemented in May 2016. +!! +!! In July 2017, new high-resolution MODIS-based snow-free albedo, maximum snow albedo, soil type and vegetation type were used to address the cold biases over the snow area and the blockiness of surface fields due to the coarse resolution data of soil type and vegetation type. The surface layer parameterization scheme was upgraded to modify the roughness-length formulation and introduce a stability parameter constraint in the Monin-Obukhov similarity theory to prevent the land-atmosphere system from decoupling which causes the rapid temperature drop during the sunset (Zheng et al. 2017). +!! +!! \section diagram Calling Hierarchy Diagram +!! \section intraphysics Intraphysics Communication +!! +!> \brief Brief description of the subroutine +!! +!! +!! \section arg_table_Noah_run Arguments +!! | local var name | longname | description | units | rank | type | kind | intent | optional | +!! |----------------|----------------------------------------------------|------------------------------------|---------|------|---------|-----------|--------|----------| +!! | im | horizontal_loop_extent | horizontal loop extent, start at 1 | index | 0 | integer | | in | F | +!! +!! \section general General Algorithm +!! \section detailed Detailed Algorithm +!! @{ +! ===================================================================== ! +! description: ! +! ! +! usage: ! +! ! +! call sfc_drv ! +! --- inputs: ! +! ( im, km, ps, t1, q1, soiltyp, vegtype, sigmaf, ! +! sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, ! +! prsl1, prslki, zf, land, wind, slopetyp, ! +! shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, ! +! lheatstrg, isot, ivegsrc, ! +! --- in/outs: ! +! weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, ! +! canopy, trans, tsurf, zorl, ! +! --- outputs: ! +! sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, ! +! cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, ! +! smcwlt2, smcref2, wet1 ) ! +! ! +! ! +! subprogram called: sflx ! +! ! +! program history log: ! +! xxxx -- created ! +! 200x -- sarah lu modified ! +! oct 2006 -- h. wei modified ! +! apr 2009 -- y.-t. hou modified to include surface emissivity ! +! effect on lw radiation. replaced the comfussing ! +! slrad (net sw + dlw) with sfc net sw snet=dsw-usw ! +! sep 2009 -- s. moorthi modification to remove rcl and unit change! +! nov 2011 -- sarah lu corrected wet1 calculation +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! im - integer, horiz dimention and num of used pts 1 ! +! km - integer, vertical soil layer dimension 1 ! +! ps - real, surface pressure (pa) im ! +! t1 - real, surface layer mean temperature (k) im ! +! q1 - real, surface layer mean specific humidity im ! +! soiltyp - integer, soil type (integer index) im ! +! vegtype - integer, vegetation type (integer index) im ! +! sigmaf - real, areal fractional cover of green vegetation im ! +! sfcemis - real, sfc lw emissivity ( fraction ) im ! +! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! +! dswflx - real, total sky sfc downward sw flux ( w/m**2 ) im ! +! snet - real, total sky sfc netsw flx into ground(w/m**2) im ! +! delt - real, time interval (second) 1 ! +! tg3 - real, deep soil temperature (k) im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, sfc layer 1 mean pressure (pa) im ! +! prslki - real, im ! +! zf - real, height of bottom layer (m) im ! +! land - logical, = T if a point with any land im ! +! wind - real, wind speed (m/s) im ! +! slopetyp - integer, class of sfc slope (integer index) im ! +! shdmin - real, min fractional coverage of green veg im ! +! shdmax - real, max fractnl cover of green veg (not used) im ! +! snoalb - real, upper bound on max albedo over deep snow im ! +! sfalb - real, mean sfc diffused sw albedo (fractional) im ! +! flag_iter- logical, im ! +! flag_guess-logical, im ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! isot - integer, sfc soil type data source zobler or statsgo ! +! ivegsrc - integer, sfc veg type data source umd or igbp ! +! ! +! input/outputs: ! +! weasd - real, water equivalent accumulated snow depth (mm) im ! +! snwdph - real, snow depth (water equiv) over land im ! +! tskin - real, ground surface skin temperature ( k ) im ! +! tprcp - real, total precipitation im ! +! srflag - real, snow/rain flag for precipitation im ! +! smc - real, total soil moisture content (fractional) im,km ! +! stc - real, soil temp (k) im,km ! +! slc - real, liquid soil moisture im,km ! +! canopy - real, canopy moisture content (m) im ! +! trans - real, total plant transpiration (m/s) im ! +! tsurf - real, surface skin temperature (after iteration) im ! +! zorl - real, surface roughness im ! +! ! +! outputs: ! +! sncovr1 - real, snow cover over land (fractional) im ! +! qsurf - real, specific humidity at sfc im ! +! gflux - real, soil heat flux (w/m**2) im ! +! drain - real, subsurface runoff (mm/s) im ! +! evap - real, evaperation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ep - real, potential evaporation im ! +! runoff - real, surface runoff (m/s) im ! +! cmm - real, im ! +! chh - real, im ! +! evbs - real, direct soil evaporation (m/s) im ! +! evcw - real, canopy water evaporation (m/s) im ! +! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! snowc - real, fractional snow cover im ! +! stm - real, total soil column moisture content (m) im ! +! snohf - real, snow/freezing-rain latent heat flux (w/m**2)im ! +! smcwlt2 - real, dry soil moisture threshold im ! +! smcref2 - real, soil moisture threshold im ! +! wet1 - real, normalized soil wetness im ! +! ! +! ==================== end of description ===================== ! + +!----------------------------------- + subroutine sfc_drv & +!................................... +! --- inputs: + & ( im, km, ps, t1, q1, soiltyp, vegtype, sigmaf, & + & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & prsl1, prslki, zf, land, wind, slopetyp, & + & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & + & lheatstrg, isot, ivegsrc, & + & bexppert, xlaipert, vegfpert,pertvegf, & ! sfc perts, mgehne +! --- in/outs: + & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & + & canopy, trans, tsurf, zorl, & +! --- outputs: + & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & + & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & + & smcwlt2, smcref2, wet1 & + & ) +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, only : grav => con_g, cp => con_cp, & + & hvap => con_hvap, rd => con_rd, & + & eps => con_eps, epsm1 => con_epsm1, & + & rvrdm1 => con_fvirt + + use surface_perturbation, only : ppfbet + + implicit none + +! --- constant parameters: + real(kind=kind_phys), parameter :: cpinv = 1.0/cp + real(kind=kind_phys), parameter :: hvapi = 1.0/hvap + real(kind=kind_phys), parameter :: elocp = hvap/cp + real(kind=kind_phys), parameter :: rhoh2o = 1000.0 + real(kind=kind_phys), parameter :: a2 = 17.2693882 + real(kind=kind_phys), parameter :: a3 = 273.16 + real(kind=kind_phys), parameter :: a4 = 35.86 + real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) + + real(kind=kind_phys), save :: zsoil_noah(4) + data zsoil_noah / -0.1, -0.4, -1.0, -2.0 / + +! --- input: + integer, intent(in) :: im, km, isot, ivegsrc + real (kind=kind_phys), dimension(5), intent(in) :: pertvegf + + integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp + + real (kind=kind_phys), dimension(im), intent(in) :: ps, & + & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & + & ch, prsl1, prslki, wind, shdmin, shdmax, & + & snoalb, sfalb, zf, + & bexppert, xlaipert, vegfpert + + real (kind=kind_phys), intent(in) :: delt + + logical, dimension(im), intent(in) :: flag_iter, flag_guess, land + + logical, intent(in) :: lheatstrg + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf, zorl + + real (kind=kind_phys), dimension(im,km), intent(inout) :: & + & smc, stc, slc + +! --- output: + real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & + & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2, & + & wet1 + +! --- locals: + real (kind=kind_phys), dimension(im) :: rch, rho, & + & q0, qs1, theta1, weasd_old, snwdph_old, & + & tprcp_old, srflag_old, tskin_old, canopy_old + + real (kind=kind_phys), dimension(km) :: et, sldpth, stsoil, & + & smsoil, slsoil + + real (kind=kind_phys), dimension(im,km) :: zsoil, smc_old, & + & stc_old, slc_old + + real (kind=kind_phys) :: alb, albedo, beta, chx, cmx, cmc, & + & dew, drip, dqsdt2, ec, edir, ett, eta, esnow, etp, & + & flx1, flx2, flx3, ffrozp, lwdn, pc, prcp, ptu, q2, & + & q2sat, solnet, rc, rcs, rct, rcq, rcsoil, rsmin, & + & runoff1, runoff2, runoff3, sfcspd, sfcprs, sfctmp, & + & sfcems, sheat, shdfac, shdmin1d, shdmax1d, smcwlt, & + & smcdry, smcref, smcmax, sneqv, snoalb1d, snowh, & + & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, tbot, & + & xlai, zlvl, swdn, tem, z0, bexpp, xlaip, vegfp, & + & mv,sv,alphav,betav,vegftmp + + integer :: couple, ice, nsoil, nroot, slope, stype, vtype + integer :: i, k, iflag + +! +!===> ... begin here +! +! --- ... save land-related prognostic fields for guess run + + do i = 1, im + if (land(i) .and. flag_guess(i)) then + weasd_old(i) = weasd(i) + snwdph_old(i) = snwdph(i) + tskin_old(i) = tskin(i) + canopy_old(i) = canopy(i) + tprcp_old(i) = tprcp(i) + srflag_old(i) = srflag(i) + + do k = 1, km + smc_old(i,k) = smc(i,k) + stc_old(i,k) = stc(i,k) + slc_old(i,k) = slc(i,k) + enddo + endif ! land & flag_guess + enddo + +! --- ... initialization block + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + ep(i) = 0.0 + evap (i) = 0.0 + hflx (i) = 0.0 + gflux(i) = 0.0 + drain(i) = 0.0 + canopy(i) = max(canopy(i), 0.0) + + evbs (i) = 0.0 + evcw (i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + endif ! flag_iter & land + enddo + +! --- ... initialize variables + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) + + rho(i) = prsl1(i) / (rd*t1(i)*(1.0+rvrdm1*q0(i))) + qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) + qs1(i) = max(eps*qs1(i) / (prsl1(i)+epsm1*qs1(i)), 1.e-8) + q0 (i) = min(qs1(i), q0(i)) + endif ! flag_iter & land + enddo + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + do k = 1, km + zsoil(i,k) = zsoil_noah(k) + enddo + endif ! flag_iter & land + enddo + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + +! --- ... noah: prepare variables to run noah lsm +! 1. configuration information (c): +! ------------------------------ +! couple - couple-uncouple flag (=1: coupled, =0: uncoupled) +! ffrozp - flag for snow-rain detection (1.=all snow, 0.=all rain, 0-1 mixed) +! ice - sea-ice flag (=1: sea-ice, =0: land) +! dt - timestep (sec) (dt should not exceed 3600 secs) = delt +! zlvl - height (m) above ground of atmospheric forcing variables +! nsoil - number of soil layers (at least 2) +! sldpth - the thickness of each soil layer (m) + + couple = 1 ! run noah lsm in 'couple' mode +! use srflag directly to allow fractional rain/snow +! if (srflag(i) == 1.0) then ! snow phase +! ffrozp = 1.0 +! elseif (srflag(i) == 0.0) then ! rain phase +! ffrozp = 0.0 +! endif + ffrozp = srflag(i) + ice = 0 + + zlvl = zf(i) + + nsoil = km + sldpth(1) = - zsoil(i,1) + do k = 2, km + sldpth(k) = zsoil(i,k-1) - zsoil(i,k) + enddo + +! 2. forcing data (f): +! ----------------- +! lwdn - lw dw radiation flux (w/m2) +! solnet - net sw radiation flux (dn-up) (w/m2) +! sfcprs - pressure at height zlvl above ground (pascals) +! prcp - precip rate (kg m-2 s-1) +! sfctmp - air temperature (k) at height zlvl above ground +! th2 - air potential temperature (k) at height zlvl above ground +! q2 - mixing ratio at height zlvl above ground (kg kg-1) + + lwdn = dlwflx(i) !..downward lw flux at sfc in w/m2 + swdn = dswsfc(i) !..downward sw flux at sfc in w/m2 + solnet = snet(i) !..net sw rad flx (dn-up) at sfc in w/m2 + sfcems = sfcemis(i) + + sfcprs = prsl1(i) + prcp = rhoh2o * tprcp(i) / delt + sfctmp = t1(i) + th2 = theta1(i) + q2 = q0(i) + +! 3. other forcing (input) data (i): +! ------------------------------ +! sfcspd - wind speed (m s-1) at height zlvl above ground +! q2sat - sat mixing ratio at height zlvl above ground (kg kg-1) +! dqsdt2 - slope of sat specific humidity curve at t=sfctmp (kg kg-1 k-1) + + sfcspd = wind(i) + q2sat = qs1(i) + dqsdt2 = q2sat * a23m4/(sfctmp-a4)**2 + +! 4. canopy/soil characteristics (s): +! -------------------------------- +! vegtyp - vegetation type (integer index) -> vtype +! soiltyp - soil type (integer index) -> stype +! slopetyp- class of sfc slope (integer index) -> slope +! shdfac - areal fractional coverage of green vegetation (0.0-1.0) +! shdmin - minimum areal fractional coverage of green vegetation -> shdmin1d +! ptu - photo thermal unit (plant phenology for annuals/crops) +! alb - backround snow-free surface albedo (fraction) +! snoalb - upper bound on maximum albedo over deep snow -> snoalb1d +! tbot - bottom soil temperature (local yearly-mean sfc air temp) + + vtype = vegtype(i) + stype = soiltyp(i) + slope = slopetyp(i) + shdfac = sigmaf(i) + +! perturb vegetation fraction that goes into sflx, use the same +! perturbation strategy as for albedo (percentile matching) + vegfp = vegfpert(i) ! sfc-perts, mgehne + if (pertvegf(1) > 0.0) then + ! compute beta distribution parameters for vegetation fraction + mv = shdfac + sv = pertvegf(1)*mv*(1.-mv) + alphav = mv*mv*(1.0-mv)/(sv*sv)-mv + betav = alphav*(1.0-mv)/mv +! compute beta distribution value corresponding +! to the given percentile albPpert to use as new albedo + call ppfbet(vegfp,alphav,betav,iflag,vegftmp) + shdfac = vegftmp + endif +! *** sfc-perts, mgehne + + shdmin1d = shdmin(i) + shdmax1d = shdmax(i) + snoalb1d = snoalb(i) + + ptu = 0.0 + alb = sfalb(i) + tbot = tg3(i) + +! 5. history (state) variables (h): +! ------------------------------ +! cmc - canopy moisture content (m) +! t1 - ground/canopy/snowpack) effective skin temperature (k) -> tsea +! stc(nsoil) - soil temp (k) -> stsoil +! smc(nsoil) - total soil moisture content (volumetric fraction) -> smsoil +! sh2o(nsoil)- unfrozen soil moisture content (volumetric fraction) -> slsoil +! snowh - actual snow depth (m) +! sneqv - liquid water-equivalent snow depth (m) +! albedo - surface albedo including snow effect (unitless fraction) +! ch - surface exchange coefficient for heat and moisture (m s-1) -> chx +! cm - surface exchange coefficient for momentum (m s-1) -> cmx + + cmc = canopy(i) * 0.001 ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter + + do k = 1, km + stsoil(k) = stc(i,k) + smsoil(k) = smc(i,k) + slsoil(k) = slc(i,k) + enddo + + snowh = snwdph(i) * 0.001 ! convert from mm to m + sneqv = weasd(i) * 0.001 ! convert from mm to m + if (sneqv /= 0.0 .and. snowh == 0.0) then + snowh = 10.0 * sneqv + endif + + chx = ch(i) * wind(i) ! compute conductance + cmx = cm(i) * wind(i) + chh(i) = chx * rho(i) + cmm(i) = cmx + +! ---- ... outside sflx, roughness uses cm as unit + z0 = zorl(i)/100. +! ---- mgehne, sfc-perts + bexpp = bexppert(i) ! sfc perts, mgehne + xlaip = xlaipert(i) ! sfc perts, mgehne + +! --- ... call noah lsm + + call sflx & +! --- inputs: + & ( nsoil, couple, ice, ffrozp, delt, zlvl, sldpth, & + & swdn, solnet, lwdn, sfcems, sfcprs, sfctmp, & + & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & + & vtype, stype, slope, shdmin1d, alb, snoalb1d, & + & bexpp, xlaip, & ! sfc-perts, mgehne + & lheatstrg, & +! --- input/outputs: + & tbot, cmc, tsea, stsoil, smsoil, slsoil, sneqv, chx, cmx, & + & z0, & +! --- outputs: + & nroot, shdfac, snowh, albedo, eta, sheat, ec, & + & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & + & flx1, flx2, flx3, runoff1, runoff2, runoff3, & + & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + +! --- ... noah: prepare variables for return to parent mode +! 6. output (o): +! ----------- +! eta - actual latent heat flux (w m-2: positive, if upward from sfc) +! sheat - sensible heat flux (w m-2: positive, if upward from sfc) +! beta - ratio of actual/potential evap (dimensionless) +! etp - potential evaporation (w m-2) +! ssoil - soil heat flux (w m-2: negative if downward from surface) +! runoff1 - surface runoff (m s-1), not infiltrating the surface +! runoff2 - subsurface runoff (m s-1), drainage out bottom + + evap(i) = eta + hflx(i) = sheat + gflux(i) = ssoil + + evbs(i) = edir + evcw(i) = ec + trans(i) = ett + sbsno(i) = esnow + snowc(i) = sncovr + stm(i) = soilm * 1000.0 ! unit conversion (from m to kg m-2) + snohf(i) = flx1 + flx2 + flx3 + + smcwlt2(i) = smcwlt + smcref2(i) = smcref + + ep(i) = etp + tsurf(i) = tsea + + do k = 1, km + stc(i,k) = stsoil(k) + smc(i,k) = smsoil(k) + slc(i,k) = slsoil(k) + enddo + wet1(i) = smsoil(1) / smcmax !Sarah Lu added 09/09/2010 (for GOCART) + +! --- ... unit conversion (from m s-1 to mm s-1 and kg m-2 s-1) + runoff(i) = runoff1 * 1000.0 + drain (i) = runoff2 * 1000.0 + +! --- ... unit conversion (from m to mm) + canopy(i) = cmc * 1000.0 + snwdph(i) = snowh * 1000.0 + weasd(i) = sneqv * 1000.0 + sncovr1(i) = sncovr +! ---- ... outside sflx, roughness uses cm as unit (update after snow's +! effect) + zorl(i) = z0*100. + +! --- ... do not return the following output fields to parent model +! ec - canopy water evaporation (m s-1) +! edir - direct soil evaporation (m s-1) +! et(nsoil)-plant transpiration from a particular root layer (m s-1) +! ett - total plant transpiration (m s-1) +! esnow - sublimation from (or deposition to if <0) snowpack (m s-1) +! drip - through-fall of precip and/or dew in excess of canopy +! water-holding capacity (m) +! dew - dewfall (or frostfall for t<273.15) (m) +! beta - ratio of actual/potential evap (dimensionless) +! flx1 - precip-snow sfc (w m-2) +! flx2 - freezing rain latent heat flux (w m-2) +! flx3 - phase-change heat flux from snowmelt (w m-2) +! snomlt - snow melt (m) (water equivalent) +! sncovr - fractional snow cover (unitless fraction, 0-1) +! runoff3 - numerical trunctation in excess of porosity (smcmax) +! for a given soil layer at the end of a time step +! rc - canopy resistance (s m-1) +! pc - plant coefficient (unitless fraction, 0-1) where pc*etp +! = actual transp +! xlai - leaf area index (dimensionless) +! rsmin - minimum canopy resistance (s m-1) +! rcs - incoming solar rc factor (dimensionless) +! rct - air temperature rc factor (dimensionless) +! rcq - atmos vapor pressure deficit rc factor (dimensionless) +! rcsoil - soil moisture rc factor (dimensionless) +! soilw - available soil moisture in root zone (unitless fraction +! between smcwlt and smcmax) +! soilm - total soil column moisture content (frozen+unfrozen) (m) +! smcwlt - wilting point (volumetric) +! smcdry - dry soil moisture threshold where direct evap frm top +! layer ends (volumetric) +! smcref - soil moisture threshold where transpiration begins to +! stress (volumetric) +! smcmax - porosity, i.e. saturated value of soil moisture +! (volumetric) +! nroot - number of root layers, a function of veg type, determined +! in subroutine redprm. + + endif ! flag_iter and flag + enddo ! end do_i_loop + +! --- ... compute qsurf (specific humidity at sfc) + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + rch(i) = rho(i) * cp * ch(i) * wind(i) + qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) + endif ! flag_iter & flag + enddo + + do i = 1, im + if (flag_iter(i) .and. land(i)) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif ! flag_iter & flag + enddo + +! --- ... restore land-related prognostic fields for guess run + + do i = 1, im + if (land(i)) then + if (flag_guess(i)) then + weasd(i) = weasd_old(i) + snwdph(i) = snwdph_old(i) + tskin(i) = tskin_old(i) + canopy(i) = canopy_old(i) + tprcp(i) = tprcp_old(i) + srflag(i) = srflag_old(i) + + do k = 1, km + smc(i,k) = smc_old(i,k) + stc(i,k) = stc_old(i,k) + slc(i,k) = slc_old(i,k) + enddo + else ! flag_guess = F + tskin(i) = tsurf(i) + endif ! flag_guess + endif ! flag + + enddo +! + return +!................................... + end subroutine sfc_drv +!----------------------------------- +!> @} +!> @} + end module module_sfc_drv diff --git a/gsmphys/sfc_land.f b/gsmphys/sfc_land.f new file mode 100644 index 00000000..394ac758 --- /dev/null +++ b/gsmphys/sfc_land.f @@ -0,0 +1,1079 @@ +!----------------------------------- + subroutine sfc_land & +!................................... +! --- inputs: + & ( im, km, ps, u1, v1, t1, q1, smc, soiltyp, & + & sigmaf, vegtype, sfcemis, dlwflx, swnet, delt, & + & tg3, cm, ch, prsl1, prslki, islimsk, & +! & zorl, tg3, cm, ch, prsl1, prslki, islimsk, & + & ddvel, flag_iter, flag_guess, & +! --- input/outputs: + & weasd, tskin, tprcp, srflag, stc, canopy, tsurf, & +! --- outputs: + & qsurf, snowmt, gflux, zsoil, rhscnpy, rhsmc, & + & aim, bim, cim, drain, evap, hflx, ep, cmm, chh, & + & evbs, evcw, trans, sbsno, snowc, stm, snohf, & + & twilt, tref + & ) + +! ===================================================================== ! +! description: osu land surface model ! +! ! +! usage: ! +! ! +! call sfc_land ! +! inputs: ! +! ( im, km, ps, u1, v1, t1, q1, smc, soiltyp, ! +! sigmaf, vegtype, sfcemis, dlwflx, swnet, delt, ! +! zorl, tg3, cm, ch, prsl1, prslki, islimsk, ! +! ddvel, flag_iter, flag_guess, ! +! input/outputs: ! +! weasd, tskin, tprcp, srflag, stc, canopy, tsurf, ! +! outputs: ! +! qsurf, snowmt, gflux, zsoil, rhscnpy, rhsmc, ! +! aim, bim, cim, drain, evap, hflx, ep, cmm, chh, ! +! evbs, evcw, trans, sbsno, snowc, stm, snohf, ! +! twilt, tref ) ! +! ! +! subprograms called: none ! +! ! +! ! +! program history log: ! +! xxxx -- original version created from Hula Lu's progtm ! ! +! 200x -- sarah lu modified (need description) ! +! oct 2006 -- h. wei modified (need description) ! +! apr 2009 -- y.-t. hou modified to include surface emissivity ! +! effect on lw radiation. also replaced slrad (a ! +! confussing term) with sfc net sw flux swnet ! +! that is redefined as (du-up). rewrite the code ! +! and add program documentation block. ! +! sep 2009 -- s. moorthi some additional modification ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! im, km - integer, horiz dimension and num of soil layers 1 ! +! ps - real, surface pressure im ! +! u1, v1 - real, u/v component of surface layer wind im ! +! t1 - real, surface layer mean temperature ( k ) im ! +! q1 - real, surface layer mean specific humidity im ! +! smc - real, soil moisture content (fractional) im,km ! +! soiltyp - integer, soil type (integer index) im ! +! sigmaf - real, areal fractional cover of green vegetation im ! +! vegtype - integer, vegetation type (integer index) im ! +! sfcemis - real, sfc lw emissivity ( fraction ) im ! +! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! +! swnet - real, total sky sfc netsw flx into ground(w/m**2) im ! +! delt - real, time interval (second) 1 ! +! zorl - real, surface roughness im ! +! tg3 - real, deep soil temperature im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, surface layer mean pressure im ! +! prslki - real, im ! +! islimsk - integer, sea/land/ice mask (=0/1/2) im ! +! ddvel - real, im ! +! flag_iter- logical, im ! +! flag_guess-logical, im ! +! ! +! input/outputs: ! +! weasd - real, water equivalent accumulated snow depth (mm)im ! +! tskin - real, ground surface skin temperature ( k ) im ! +! tprcp - real, total precipitation im ! +! srflag - real, snow/rain flag for precipitation im ! +! stc - real, soil temp (k) im,km ! +! canopy - real, canopy moisture content (m) im ! +! tsurf - real, surface skin temperature (after iteration) im ! +! ! +! outputs: ! +! qsurf - real, specific humidity at sfc im ! +! snowmt - real, snow melt (m) im ! +! gflux - real, soil heat flux (w/m**2) im ! +! zsoil - real, soil depth im,km ! +! rhscnpy - real, im ! +! rhsmc - real, im,km ! +! aim - real, tridiagonal matrix coeff for soil moist im,km ! +! bim - real, tridiagonal matrix coeff for soil moist im,km ! +! cim - real, tridiagonal matrix coeff for soil moist im,km ! +! drain - real, subsurface runoff im ! +! evap - real, evaperation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ep - real, potential evaporation im ! +! cmm - real, im ! +! chh - real, im ! +! evbs - real, direct soil evaporation (m/s) im ! +! evcw - real, canopy water evaporation (m/s) im ! +! trans - real, im ! +! sbsno - real, sublimation/deposit from snopack (m/s) im ! +! snowc - real, fractional snow cover im ! +! stm - real, total soil column moisture content (m) im ! +! snohf - real, snow/freezing-rain latent heat flux (w/m**2)im ! +! twilt - real, dry soil moisture threshold im ! +! tref - real, soil moisture threshold im ! +! ! +! ==================== end of description ===================== ! +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, only : grav => con_g, sbc => con_sbc, cp => con_cp, & + & hvap => con_hvap, hfus => con_hfus, & + & eps => con_eps, epsm1 => con_epsm1, & + & t0c => con_t0c, rvrdm1 => con_fvirt, & + & rd => con_rd +! + implicit none +! +! --- constant parameters: + real (kind=kind_phys), parameter :: cpinv = 1.0/cp + real (kind=kind_phys), parameter :: hvapi = 1.0/hvap + real (kind=kind_phys), parameter :: elocp = hvap/cp + real (kind=kind_phys), parameter :: dfsnow = 0.31 + real (kind=kind_phys), parameter :: ch2o = 4.2e6 + real (kind=kind_phys), parameter :: csoil = 1.26e6 + real (kind=kind_phys), parameter :: scanop = 0.5 + real (kind=kind_phys), parameter :: cfactr = 0.5 + real (kind=kind_phys), parameter :: zbot =-3.0 + real (kind=kind_phys), parameter :: topt = 298.0 + real (kind=kind_phys), parameter :: rhoh2o = 1000.0 + real (kind=kind_phys), parameter :: ctfil1 = 0.5 + real (kind=kind_phys), parameter :: ctfil2 = 1.0-ctfil1 + real (kind=kind_phys), parameter :: snomin = 1.0e-9 + +! --- input: + integer, intent(in) :: im, km + integer, dimension(im), intent(in) :: islimsk, soiltyp, vegtype + + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, sigmaf, sfcemis, dlwflx, swnet, tg3, cm, ch, & +! & t1, q1, sigmaf, sfcemis, dlwflx, swnet, zorl, tg3, cm, ch, & + & prsl1, prslki, ddvel + + real (kind=kind_phys), dimension(im,km), intent(in) :: smc + + real (kind=kind_phys), intent(in) :: delt + + logical, intent(in) :: flag_iter(im), flag_guess(im) + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & + & tskin, tprcp, srflag, canopy, tsurf + + real (kind=kind_phys), dimension(im,km), intent(inout) :: stc + +! --- output: + real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & + & snowmt, gflux, rhscnpy, drain, evap, hflx, ep, chh, cmm, & + & evbs, evcw, trans, sbsno, snowc, stm, snohf, twilt, & + & tref + + real (kind=kind_phys), dimension(im,km), intent(out) :: zsoil, & + & rhsmc, aim, bim, cim + +! --- external functions: + real (kind=kind_phys) :: funcdf, funckt, ktsoil + +! --- locals: + real (kind=kind_phys), dimension(im) :: weasd_old, tprcp_old, & + & srflag_old, tskin_old, canopy_old, wind, canfac, ddz, & + & ddz2, delta, dew, df1, dft0, dft1, dft2, dmdz, dmdz2, & + & dtdz1, dtdz2, ec, edir, etpfac, factsnw, fx, gx, hcpct, & + & partlnd, q0, qs1, qss, rcap, rch, rho, rs, rsmall, & + & slwd, smcz, snoevp, snowd, term1, term2, theta1, tv1, & + & tsea, xx, yy, zz, kt1, kt2 + + + real (kind=kind_phys), dimension(im,km) :: stc_old, et, stsoil, & + & ai, bi, ci, rhstc + + real (kind=kind_phys) :: bfact, cc, delt2, df2, eth, ff, g, rcq, & + & rcs, rct, rsi, rss, smcdry, t12, t14, tflx, tem + + integer :: i, k + + logical :: flag(im), flagsnw(im) + +! --- local data arrays: +! the 13 vegetation types are: +! 1 ... broadleave-evergreen trees (tropical forest) +! 2 ... broadleave-deciduous trees +! 3 ... broadleave and needle leave trees (mixed forest) +! 4 ... needleleave-evergreen trees +! 5 ... needleleave-deciduous trees (larch) +! 6 ... broadleave trees with groundcover (savanna) +! 7 ... groundcover only (perenial) +! 8 ... broadleave shrubs with perenial groundcover +! 9 ... broadleave shrubs with bare soil +! 10 ... dwarf trees and shrubs with ground cover (trunda) +! 11 ... bare soil +! 12 ... cultivations (use parameters from type 7) +! 13 ... glacial + + real(kind=kind_phys),dimension(13), save :: rsmax, rsmin, rgl, hs + + data rsmax / 13*5000.0 / + data rsmin / 150., 100., 125., 150., 100., 70., 40., & + & 300., 400., 150., 999., 040., 999. / + + data rgl / 5*30., 65., 4*100., 999., 100., 999. / + + data hs / 41.69, 54.53, 51.93, 47.35, 47.35, 54.53, 36.35, & + & 3*42.00, 999.0, 36.35, 999.0 / + + real(kind=kind_phys), dimension(9), save :: smdry, smref, smwlt + data smdry / .07, .14, .22, .08, .18, .16, .12, .10, .07 / + data smref / .283,.387,.412,.312,.338,.382,.315,.329,.283 / + data smwlt / .029,.119,.139,.047,.010,.103,.069,.066,.029 / +! +!===> ... begin here +! + delt2 = delt + delt + +! --- ... set default flag for land + + do i = 1, im + flag(i) = ( islimsk(i) == 1 ) + enddo + +! --- ... save land-related prognostic fields for guess run + + do i = 1, im + if (flag(i) .and. flag_guess(i)) then + weasd_old(i) = weasd(i) + tskin_old (i) = tskin(i) + canopy_old(i) = canopy(i) + tprcp_old (i) = tprcp(i) + srflag_old(i) = srflag(i) + + do k = 1, km + stc_old(i,k) = stc(i,k) + enddo + endif + enddo + +! --- ... initialize variables. all units are supposedly m.k.s. unless +! specifie ps is in pascals +! wind is wind speed, theta1 is adiabatic surface temp from +! level 1, rho is density, qs1 is sat. hum. at level1 and qss +! is sat. hum. at surface +! surface roughness length is converted to m from cm +! net sw flux swnet is dn-up, and dlw is positive dnwd + +! qs1 = fpvs(t1) +! qss = fpvs(tskin) + + do i = 1, im + + if (flag_iter(i) .and. flag(i)) then + slwd(i) = swnet(i) + dlwflx(i) + + wind(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + & + max(0.0, min(ddvel(i), 30.0)) + wind(i) = max(wind(i), 1.0) + + q0(i) = max(q1(i), 1.e-8) +! tsurf(i) = tskin(i) + tsea(i) = tsurf(i) + theta1(i) = t1(i) * prslki(i) + tv1(i) = t1(i) * (1.0 + rvrdm1*q0(i)) +! thv1(i) = theta1(i) * (1.0 + rvrdm1*q0(i)) +! tvs(i) = tsea(i) * (1.0 + rvrdm1*q0(i)) + rho(i) = prsl1(i) / (rd * tv1(i)) + + qs1(i) = fpvs(t1(i)) + qs1(i) = eps*qs1(i) / (prsl1(i) + epsm1*qs1(i)) + qs1(i) = max(qs1(i), 1.e-8) + q0(i) = min(qs1(i), q0(i)) + + qss(i) = fpvs(tskin(i)) !!! change to tsurf? + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) + +! rs = plantr + rs(i) = 0. + if (vegtype(i) > 0.0) rs(i) = rsmin(vegtype(i)) + + canopy(i) = max(canopy(i), 0.0) + factsnw(i) = 10.0 + +! --- ... snow depth in water equivalent is converted from mm to m unit + + snowd(i) = weasd(i) * 0.001 + flagsnw(i) = .false. + +! --- ... when snow depth is less than 1 mm, a patchy snow is assumed +! and soil is allowed to interact with the atmosphere. +! we should eventually move to a linear combination of soil and +! snow under the condition of patchy snow. + + if (snowd(i)>0.001 .or. islimsk(i) == 2) rs(i) = 0.0 + if (snowd(i)>0.001) flagsnw(i) = .true. + endif ! end if_flag_iter_block + + enddo ! end do_i_loop + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + zsoil(i,1) = -0.10 + + do k = 2, km + zsoil(i,k) = zsoil(i,k-1) + (-2.0 - zsoil(i,1)) / (km - 1) + enddo + +! --- ... wei: use the same soil layer structure as noah if running with 4-layer + + if (km > 0.2)then + zsoil(i,2) = -0.4 + zsoil(i,3) = -1.0 + zsoil(i,4) = -2.0 + endif + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + drain(i) = 0.0 + endif + enddo + + do k = 1, km + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + et (i,k) = 0.0 + rhsmc(i,k) = 0.0 + aim (i,k) = 0.0 + bim (i,k) = 1.0 + cim (i,k) = 0.0 + stsoil(i,k) = stc(i,k) + endif + enddo + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + edir(i) = 0.0 + ec (i) = 0.0 + evap(i) = 0.0 + hflx(i) = 0.0 + ep (i) = 0.0 + fx (i) = 0.0 + + snowmt(i) = 0.0 + gflux (i) = 0.0 + rhscnpy(i)= 0.0 + etpfac(i) = 0.0 + canfac(i) = 0.0 + + evbs (i) = 0.0 + evcw (i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + endif + enddo + +! --- ... rcp = rho cp ch v + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + rch(i) = rho(i) * cp * ch(i) * wind(i) + + cmm(i) = cm(i) * wind(i) + chh(i) = rho(i) * ch(i) * wind(i) + endif + enddo + +! --- ... compute soil/snow/ice heat flux in preparation for surface +! energy balance calculation + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + smcz(i) = 0.5 * (smc(i,1) + 0.20) + dft0(i) = ktsoil(smcz(i), soiltyp(i)) + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + if (flagsnw(i)) then + +! --- ... when snow covered, ground heat flux comes from snow + + tflx = min(t1(i), tsea(i)) + gflux(i) = -dfsnow * (tflx - stsoil(i,1)) & + & / (factsnw(i) * max(snowd(i), 0.001)) + else + + gflux(i) = dft0(i) * (stsoil(i,1) - tsea(i)) & + & / (-0.5 * zsoil(i,1)) + + endif + + gflux(i) = max(gflux(i), -200.0) + gflux(i) = min(gflux(i), 200.0) + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + partlnd(i) = 1.0 + + if (snowd(i)>0.0 .and. snowd(i)<=0.001) then + partlnd(i) = 1.0 - snowd(i) / 0.001 + endif + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + snoevp(i) = 0.0 + if (snowd(i) > 0.001) partlnd(i) = 0.0 + endif + enddo + +! --- ... compute potential evaporation for land and sea ice + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + t12 = t1(i) * t1(i) + t14 = t12 * t12 + +! --- ... rcap = fnet - sigma t**4 + gflx - rho cp ch v (t1-theta1) + + rcap(i) = slwd(i) - sfcemis(i)*sbc*t14 + gflux(i) & + & - rch(i)*(t1(i) - theta1(i)) + +! --- ... rsmall = 4 sigma t**3 / rch(i) + 1 + + rsmall(i) = 4.0*sfcemis(i)*sbc*t1(i)*t12 / rch(i) + 1.0 + +! --- ... delta = l / cp * dqs/dt + + delta(i) = elocp*eps*hvap*qs1(i) / (rd*t12) + +! --- ... potential evapotranspiration ( watts / m**2 ) and +! potential evaporation + + term1(i) = elocp*rsmall(i)*rch(i) * (qs1(i) - q0(i)) + term2(i) = rcap(i) * delta(i) + ep(i) = (elocp*rsmall(i)*rch(i) * (qs1(i) - q0(i)) & + & + rcap(i)*delta(i)) + ep(i) = ep(i) / (rsmall(i) + delta(i)) + endif + enddo + +! --- ... actual evaporation over land in three parts : edir, et, and ec +! direct evaporation from soil, the unit goes from m s-1 to kg m-2 s-1 + + do i = 1, im + flag(i) = (islimsk(i) == 1) .and. (ep(i) > 0.0) + enddo + + do i = 1, im + if (flag_iter(i))then + if (flag(i)) then + df1(i) = funcdf(smc(i,1),soiltyp(i)) + kt1(i) = funckt(smc(i,1),soiltyp(i)) + endif + + if (flag(i) .and. stc(i,1) 0) + enddo + +! --- ... change of snow depth due to evaporation or sublimation +! convert evap from kg m-2 s-1 to m s-1 to determine the reduction of s + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + bfact = snowd(i) / (delt*ep(i) / (hvap*rhoh2o)) + bfact = min(bfact, 1.0) + +! --- ... the evaporation of snow + + if (ep(i) <= 0.0) bfact = 1.0 + + if (snowd(i) <= 0.001) then +! evap = (snowd(i)/0.001) * bfact*ep(i) + evap +! snoevp(i) = bfact*ep(i) * (1.0 - partlnd(i)) +! evap = evap + snoevp(i) + snoevp(i) = bfact * ep(i) +! evap = evap + snoevp(i) * (1.0 - partlnd(i)) + evap(i) = evap(i) + snoevp(i) * (1.0 - partlnd(i)) + else +! evap(i) = bfact * ep(i) + snoevp(i) = bfact * ep(i) + evap(i) = snoevp(i) + endif + + tsea(i) = t1(i) & + & + (rcap(i) - gflux(i) - dfsnow*(t1(i) - stsoil(i,1)) & + & / (factsnw(i) * max(snowd(i), 0.001)) & +! & + theta1 - t1 & +! & - bfact * ep(i)) / (rsmall(i) * rch(i) & + & - snoevp(i)) / (rsmall(i) * rch(i) & + & + dfsnow / (factsnw(i) * max(snowd(i), 0.001))) + +! snowd(i) = snowd(i) - bfact*ep(i)*delt / (rhoh2o*hvap) + snowd(i) = snowd(i) - snoevp(i)*delt / (rhoh2o*hvap) + snowd(i) = max(snowd(i), 0.0) + endif + enddo + +! --- ... snow melt (m) + + do i = 1, im + flag(i) = (islimsk(i) == 1) .and. (snowd(i) > 0) + enddo + + do i = 1, im + if (flag_iter(i)) then + if (flag(i) .and. tsea(i)>t0c) then + snowmt(i) = rch(i)*rsmall(i)*delt * (tsea(i) - t0c) & + & / (rhoh2o*hfus) + snowmt(i) = min(snowmt(i), snowd(i)) + snowd(i) = snowd(i) - snowmt(i) + snowd(i) = max(snowd(i), 0.0) + tsea (i) = max(t0c, tsea(i) - hfus*snowmt(i)*rhoh2o & + & / (rch(i)*rsmall(i)*delt)) + endif + endif + enddo + +! --- ... we need to re-evaluate evaporation because of snow melt +! the skin temperature is now bounded to 0 deg c + +! qss = fpvs(tsea) + do i = 1, im + flag(i) = (islimsk(i) == 1) + + if (flag_iter(i) .and. flag(i))then +! if (snowd(i) > 0.0) then + if (snowd(i) > snomin) then +!jfe qss(i) = 1000.0 * fpvs(tsea(i)) + qss(i) = fpvs(tsea(i)) + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) + evap(i) = elocp*rch(i) * (qss(i) - q0(i)) + endif + endif + enddo + +! --- ... prepare tendency terms for the soil moisture field without +! precipitat. the unit of moisture flux needs to become m s-1 +! for soil moisture. hence the factor of rhoh2o + + do i = 1, im + if (flag_iter(i)) then + if (flag(i)) then + df1(i) = funcdf(smcz(i),soiltyp(i)) + kt1(i) = funckt(smcz(i),soiltyp(i)) + endif + + if (flag(i) .and. stc(i,1) 0.001) then + if (flag(i) .and. flagsnw(i)) then + yy(i) = stsoil(i,1) + +! --- ... heat flux from snow is explicit in time + + zz(i) = 1.0 + xx(i) = dfsnow * (stsoil(i,1) - tsea(i)) & + & / (-factsnw(i) * max(snowd(i), 0.001)) + endif + endif + enddo + +! --- ... compute the forcing and the implicit matrix elements for update +! ch2o is the heat capacity of water and csoil is the heat capacity +! of soil + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + smcz(i) = max(smc(i,1), smc(i,2)) + dtdz1(i) = (stsoil(i,1) - stsoil(i,2)) / (-0.5*zsoil(i,2)) + dft1(i) = ktsoil(smcz(i),soiltyp(i)) + hcpct(i) = smc(i,1)*ch2o + (1.0 - smc(i,1)) * csoil + dft2(i) = dft1(i) + ddz(i) = 1.0 / (-0.5*zsoil(i,2)) + +! --- ... ai, bi, and ci are the elements of the tridiagonal matrix for the +! implicit update of the soil temperature + + ai(i,1) = 0.0 + bi(i,1) = dft1(i)*ddz(i) / (-zsoil(i,1)*hcpct(i)) + ci(i,1) = -bi(i,1) + bi(i,1) = bi(i,1) & + & + dft0(i) / (0.5*zsoil(i,1)**2 * hcpct(i)*zz(i)) + rhstc(i,1) = (dft1(i)*dtdz1(i) - xx(i))/(zsoil(i,1)*hcpct(i)) + endif + enddo + + do k = 2, km + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + hcpct(i) = smc(i,k)*ch2o + (1.0 - smc(i,k)) * csoil + endif + enddo + + if (k < km) then + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + dtdz2(i) = (stsoil(i,k) - stsoil(i,k+1)) & + & / (0.5 * (zsoil(i,k-1) - zsoil(i,k+1))) + smcz(i) = max(smc(i,k), smc(i,k+1)) + dft2(i) = ktsoil(smcz(i),soiltyp(i)) + ddz2(i) = 2.0 / (zsoil(i,k-1) - zsoil(i,k+1)) + ci(i,k) = -dft2(i) * ddz2(i) & + & / ((zsoil(i,k-1) - zsoil(i,k)) * hcpct(i)) + endif + enddo + + else ! if_k_block + +! --- ... at the bottom, climatology is assumed at 2m depth for land and +! freezing temperature is assumed for sea ice at z(km) + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + dtdz2(i) = (stsoil(i,k) - tg3(i)) & + & / (0.5 * (zsoil(i,k-1) + zsoil(i,k)) - zbot) + dft2(i) = ktsoil(smc(i,k),soiltyp(i)) + ci(i,k) = 0.0 + endif + enddo + + endif ! end if_k_block + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + rhstc(i,k) = (dft2(i)*dtdz2(i) - dft1(i)*dtdz1(i)) & + & / ((zsoil(i,k) - zsoil(i,k-1)) * hcpct(i)) + ai(i,k) = -dft1(i) * ddz(i) & + & / ((zsoil(i,k-1) - zsoil(i,k)) * hcpct(i)) + bi(i,k) = -(ai(i,k) + ci(i,k)) + dft1(i) = dft2(i) + dtdz1(i) = dtdz2(i) + ddz(i) = ddz2(i) + endif + enddo + enddo ! end do_k_loop + +! --- ... solve the tri-diagonal matrix + + do k = 1, km + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + rhstc(i,k) = rhstc(i,k) * delt2 + ai(i,k) = ai(i,k) * delt2 + bi(i,k) = 1.0 + bi(i,k)*delt2 + ci(i,k) = ci(i,k) * delt2 + endif + enddo + enddo + +! --- ... forward elimination + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + ci(i,1) = -ci(i,1) / bi(i,1) + rhstc(i,1) = rhstc(i,1) / bi(i,1) + endif + enddo + + do k = 2, km + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + cc = 1.0 / (bi(i,k) + ai(i,k)*ci(i,k-1)) + ci(i,k) = -ci(i,k) * cc + rhstc(i,k) = (rhstc(i,k) - ai(i,k)*rhstc(i,k-1)) * cc + endif + enddo + enddo + +! --- ... backward substituttion + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + ci(i,km) = rhstc(i,km) + endif + enddo + + do k = km-1, 1 + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + ci(i,k) = ci(i,k)*ci(i,k+1) + rhstc(i,k) + endif + enddo + enddo + +! --- ... update soil and ice temperature + + do k = 1, km + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + stsoil(i,k) = stsoil(i,k) + ci(i,k) + endif + enddo + enddo + +! --- ... update surface temperature for snow free surfaces + + do i = 1, im + if (flag_iter(i)) then + if (flag(i) .and. .not.flagsnw(i)) then + tsea(i) = (yy(i) + (zz(i) - 1.0) * stsoil(i,1)) / zz(i) + endif + endif + enddo + +! --- ... time filter for soil and skin temperature + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + tsurf(i) = ctfil1*tsea(i) + ctfil2*tsurf(i) + endif + enddo + + do k = 1, km + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + stc(i,k) = ctfil1*stsoil(i,k) + ctfil2*stc(i,k) + endif + enddo + enddo + +! --- ... gflux calculation + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + if (flagsnw(i)) then + gflux(i) = -dfsnow * (tsurf(i) - stc(i,1)) & + & / (factsnw(i) * max(snowd(i), 0.001)) + else + gflux(i) = dft0(i) * (stc(i,1) - tsurf(i)) & + & / (-0.5*zsoil(i,1)) + endif + endif + enddo + +! --- ... calculate sensible heat flux + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + hflx(i) = rch(i) * (tsurf(i) - theta1(i)) + endif + enddo + +! --- ... the rest of the output + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + qsurf(i) = q1(i) + evap(i) / (elocp*rch(i)) + + evbs (i) = edir(i) + evcw (i) = ec(i) + sbsno(i) = snoevp(i) + snowc(i) = 1.0 - partlnd(i) + stm (i) = -smc(i,1) * zsoil(i,1) + snohf(i) = dfsnow * (t1(i) - stsoil(i,1)) + trans(i) = et(i,1) + + do k = 2, km + stm(i) = stm(i) + smc(i,k) * (zsoil(i,k-1) - zsoil(i,k)) + trans(i) = trans(i) + et(i,k) + enddo + +! --- ... convert snow depth back to mm of water equivalent + + weasd(i) = snowd(i) * 1000.0 + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo + +! --- ... restore land-related prognostic fields for guess run + + do i = 1, im + if (flag(i)) then + if (flag_guess(i)) then + weasd(i) = weasd_old(i) + tskin(i) = tskin_old(i) + canopy(i) = canopy_old(i) + tprcp(i) = tprcp_old(i) + srflag(i) = srflag_old(i) + + do k = 1, km + stc(i,k) = stc_old(i,k) + enddo + else + tskin(i) = tsurf(i) + endif + endif + enddo + + return + end diff --git a/gsmphys/sfc_noahmp_drv.f b/gsmphys/sfc_noahmp_drv.f new file mode 100644 index 00000000..af19acb9 --- /dev/null +++ b/gsmphys/sfc_noahmp_drv.f @@ -0,0 +1,1139 @@ +! ! +!----------------------------------- + subroutine noahmpdrv & +!................................... +! --- inputs: + & ( im, km,itime,ps, u1, v1, t1, q1, soiltyp, vegtype, sigmaf, & + & sfcemis, dlwflx, dswsfc, snet, delt, tg3, cm, ch, & + & prsl1, prslki, zf, dry, wind, slopetyp, & + & shdmin, shdmax, snoalb, sfalb, flag_iter, flag_guess, & + & idveg,iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, & + & iopt_inf,iopt_rad, iopt_alb, iopt_snf,iopt_tbot,iopt_stc, & + & xlatin,xcoszin, iyrlen, julian,imon, & + & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp, & + +! --- in/outs: + & weasd, snwdph, tskin, tprcp, srflag, smc, stc, slc, & + & canopy, trans, tsurf,zorl, & + +! --- Noah MP specific + + & snowxy, tvxy, tgxy, canicexy,canliqxy, eahxy,tahxy,cmxy, & + & chxy, fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, & + & zwtxy, waxy, wtxy, tsnoxy,zsnsoxy, snicexy, snliqxy, & + & lfmassxy, rtmassxy,stmassxy, woodxy, stblcpxy, fastcpxy, & + & xlaixy,xsaixy,taussxy,smoiseq,smcwtdxy,deeprechxy,rechxy, & + +! --- outputs: + & sncovr1, qsurf, gflux, drain, evap, hflx, ep, runoff, & + & cmm, chh, evbs, evcw, sbsno, snowc, stm, snohf, & + & smcwlt2, smcref2,wet1,t2mmp,q2mp) +! +! + use machine , only : kind_phys +! use date_def, only : idate + use funcphys, only : fpvs + use physcons, only : con_g, con_hvap, con_cp, con_jcal, & + & con_eps, con_epsm1, con_fvirt, con_rd,con_hfus + + use module_sf_noahmplsm + use module_sf_noahmp_glacier + use noahmp_tables, only : isice_table, co2_table, o2_table, & + & isurban_table,smcref_table,smcdry_table, & + & smcmax_table,co2_table,o2_table, & + & saim_table,laim_table + + implicit none + +! --- constant parameters: + + real(kind=kind_phys), parameter :: cpinv = 1.0/con_cp + real(kind=kind_phys), parameter :: hvapi = 1.0/con_hvap + real(kind=kind_phys), parameter :: elocp = con_hvap/con_cp + real(kind=kind_phys), parameter :: rhoh2o = 1000.0 + real(kind=kind_phys), parameter :: convrad = con_jcal*1.e4/60.0 + real(kind=kind_phys), parameter :: a2 = 17.2693882 + real(kind=kind_phys), parameter :: a3 = 273.16 + real(kind=kind_phys), parameter :: a4 = 35.86 + real(kind=kind_phys), parameter :: a23m4 = a2*(a3-a4) +! +! --- +! + + real, parameter :: undefined = -1.e36 + + real :: dz8w = undefined + real :: dx = undefined + real :: qc = undefined + real :: foln = 1.0 ! foliage + integer :: nsoil = 4 ! hardwired to Noah + integer :: nsnow = 3 ! max. snow layers + integer :: ist = 1 ! soil type, 1 soil; 2 lake; 14 is water + integer :: isc = 4 ! middle day soil color: soil 1-9 lightest + + real(kind=kind_phys), save :: zsoil(4),sldpth(4) + data zsoil / -0.1, -0.4, -1.0, -2.0 / + data sldpth /0.1, 0.3, 0.6, 1.0 / +! data dzs /0.1, 0.3, 0.6, 1.0 / + +! +! --- input: +! + + integer, intent(in) :: im, km, itime,imon + + integer, dimension(im), intent(in) :: soiltyp, vegtype, slopetyp + + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, sigmaf, sfcemis, dlwflx, dswsfc, snet, tg3, cm, & + & ch, prsl1, prslki, wind, shdmin, shdmax, & + & snoalb, sfalb, zf, & + & rainn_mp,rainc_mp,snow_mp,graupel_mp,ice_mp + + logical, dimension(im), intent(in) :: dry + + real (kind=kind_phys),dimension(im),intent(in) :: xlatin,xcoszin + + integer, intent(in) :: idveg, iopt_crs,iopt_btr,iopt_run, & + & iopt_sfc,iopt_frz,iopt_inf,iopt_rad, & + & iopt_alb,iopt_snf,iopt_tbot,iopt_stc + + real (kind=kind_phys), intent(in) :: julian + integer, intent(in) :: iyrlen + + + real (kind=kind_phys), intent(in) :: delt + logical, dimension(im), intent(in) :: flag_iter, flag_guess + +! --- in/out: + real (kind=kind_phys), dimension(im), intent(inout) :: weasd, & + & snwdph, tskin, tprcp, srflag, canopy, trans, tsurf,zorl + + real (kind=kind_phys), dimension(im,km), intent(inout) :: & + & smc, stc, slc + + real (kind=kind_phys), dimension(im), intent(inout) :: snowxy, & + & tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy, & + & cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy, & + & wslakexy,zwtxy,waxy,wtxy,lfmassxy,rtmassxy, & + & stmassxy,woodxy,stblcpxy,fastcpxy,xlaixy, & + & xsaixy,taussxy,smcwtdxy,deeprechxy,rechxy + + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: tsnoxy + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: snicexy + real (kind=kind_phys),dimension(im,-2:0),intent(inout) :: snliqxy + real (kind=kind_phys),dimension(im,1:4), intent(inout) :: smoiseq + real (kind=kind_phys),dimension(im,-2:4),intent(inout) :: zsnsoxy + + integer, dimension(im) :: jsnowxy + real (kind=kind_phys),dimension(im) :: snodep + real (kind=kind_phys),dimension(im,-2:4) :: tsnsoxy + +! --- output: + + real (kind=kind_phys), dimension(im), intent(out) :: sncovr1, & + & qsurf, gflux, drain, evap, hflx, ep, runoff, cmm, chh, & + & evbs, evcw, sbsno, snowc, stm, snohf, smcwlt2, smcref2,wet1, & + & t2mmp,q2mp + +! --- locals: + real (kind=kind_phys), dimension(im) :: rch, rho, & + & q0, qs1, theta1, tv1, weasd_old, snwdph_old, & + & tprcp_old, srflag_old, tskin_old, canopy_old + + real (kind=kind_phys), dimension(km) :: et,stsoil,smsoil, slsoil + + real (kind=kind_phys),dimension(im,km) :: smc_old,stc_old,slc_old + + real (kind=kind_phys), dimension(im) :: snow_old, tv_old,tg_old, & + & canice_old,canliq_old,eah_old,tah_old,fwet_old,sneqvo_old, & + & albold_old,qsnow_old,wslake_old,zwt_old,wa_old,wt_old, & + & lfmass_old,rtmass_old,stmass_old,wood_old,stblcp_old, & + & fastcp_old,xlai_old,xsai_old,tauss_old,smcwtd_old, & + & deeprech_old,rech_old + + real(kind=kind_phys),dimension(im,1:4) :: smoiseq_old + real(kind=kind_phys),dimension(im,-2:0) :: tsno_old + real(kind=kind_phys),dimension(im,-2:0) :: snice_old + real(kind=kind_phys),dimension(im,-2:0) :: snliq_old + real(kind=kind_phys),dimension(im,-2:4) :: zsnso_old + real(kind=kind_phys),dimension(im,-2:4) :: tsnso_old + + + real (kind=kind_phys) :: alb, albedo, beta, chx, cmx, cmc, & + & dew, drip, dqsdt2, ec, edir, ett, eta, esnow, etp, & + & flx1, flx2, flx3, ffrozp, lwdn, pc, prcp, ptu, q2, & + & q2sat, solnet, rc, rcs, rct, rcq, rcsoil, rsmin, & + & runoff1, runoff2, runoff3, sfcspd, sfcprs, sfctmp, & + & sfcems, sheat, shdfac, shdmin1d, shdmax1d, smcwlt, & + & smcdry, smcref, smcmax, sneqv, snoalb1d, snowh, & + & snomlt, sncovr, soilw, soilm, ssoil, tsea, th2, & + & xlai, zlvl, swdn, tem, psfc,fdown,t2v,tbot + + real (kind=kind_phys) :: pconv,pnonc,pshcv,psnow,pgrpl,phail + real (kind=kind_phys) :: lat,cosz,uu,vv,swe + integer :: isnowx + + real (kind=kind_phys) :: tvx,tgx,canicex,canliqx,eahx, & + & tahx,fwetx,sneqvox,alboldx,qsnowx,wslakex,zwtx, & + & wax,wtx,lfmassx, rtmassx,stmassx, woodx,stblcpx, & + & fastcpx,xlaix,xsaix,taussx,smcwtdx,deeprechx,rechx, & + & qsfc1d + + real (kind=kind_phys), dimension(-2:0) :: tsnox, snicex, snliqx + real (kind=kind_phys), dimension(-2:0) :: ficeold + real (kind=kind_phys), dimension( km ) :: smoiseqx + real (kind=kind_phys), dimension(-2:4) :: zsnsox + real (kind=kind_phys), dimension(-2:4) :: tsnsox + + real (kind=kind_phys) :: z0wrf,fsa,fsr,fira,fsh,fcev,fgev, & + & fctr,ecan,etran,trad,tgb,tgv,t2mv, & + & t2mb,q2v,q2b,runsrf,runsub,apar, & + & psn,sav,sag,fsno,nee,gpp,npp,fveg, & + & qsnbot,ponding,ponding1,ponding2, & + & rssun,rssha,bgap,wgap,chv,chb,emissi, & + & shg,shc,shb,evg,evb,ghv,ghb,irg,irc, & + & irb,tr,evc,chleaf,chuc,chv2,chb2, & + & fpice,pahv,pahg,pahb,pah,co2pp,o2pp,ch2b + + integer :: i, k, ice, stype, vtype ,slope,nroot,couple + logical :: flag(im) + logical :: snowng,frzgra + + type(noahmp_parameters) :: parameters + +! +!===> ... begin here +! + +! --- ... set flag for land points + + do i = 1, im + flag(i) = dry(i) + enddo + +! --- ... save land-related prognostic fields for guess run + + do i = 1, im + if (flag(i) .and. flag_guess(i)) then + weasd_old(i) = weasd(i) + snwdph_old(i) = snwdph(i) + tskin_old(i) = tskin(i) + canopy_old(i) = canopy(i) + tprcp_old(i) = tprcp(i) + srflag_old(i) = srflag(i) +! +! + snow_old(i) = snowxy(i) + tv_old(i) = tvxy(i) + tg_old(i) = tgxy(i) + canice_old(i) = canicexy(i) + canliq_old(i) = canliqxy(i) + eah_old(i) = eahxy(i) + tah_old(i) = tahxy(i) + fwet_old(i) = fwetxy(i) + sneqvo_old(i) = sneqvoxy(i) + albold_old(i) = alboldxy(i) + qsnow_old(i) = qsnowxy(i) + wslake_old(i) = wslakexy(i) + zwt_old(i) = zwtxy(i) + wa_old(i) = waxy(i) + wt_old(i) = wtxy(i) + lfmass_old(i) = lfmassxy(i) + rtmass_old(i) = rtmassxy(i) + stmass_old(i) = stmassxy(i) + wood_old(i) = woodxy(i) + stblcp_old(i) = stblcpxy(i) + fastcp_old(i) = fastcpxy(i) + xlai_old(i) = xlaixy(i) + xsai_old(i) = xsaixy(i) + tauss_old(i) = taussxy(i) + smcwtd_old(i) = smcwtdxy(i) + rech_old(i) = rechxy(i) + + deeprech_old(i) = deeprechxy(i) +! + do k = 1, km + smc_old(i,k) = smc(i,k) + stc_old(i,k) = stc(i,k) + slc_old(i,k) = slc(i,k) + enddo + +! + do k = 1, km + smoiseq_old(i,k) = smoiseq(i,k) + enddo + + do k = -2,0 + tsno_old(i,k) = tsnoxy(i,k) + snice_old(i,k) = snicexy(i,k) + snliq_old(i,k) = snliqxy(i,k) + enddo + + do k = -2,4 + zsnso_old (i,k) = zsnsoxy(i,k) + enddo + + endif + enddo + +! +! call to init MP options +! +! &_________________________________________________________________ & + +! --- ... initialization block + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + ep(i) = 0.0 + evap (i) = 0.0 + hflx (i) = 0.0 + gflux(i) = 0.0 + drain(i) = 0.0 + canopy(i) = max(canopy(i), 0.0) + + evbs (i) = 0.0 + evcw (i) = 0.0 + trans(i) = 0.0 + sbsno(i) = 0.0 + snowc(i) = 0.0 + snohf(i) = 0.0 + endif + enddo + +! --- ... initialize variables + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + q0(i) = max(q1(i), 1.e-8) !* q1=specific humidity at level 1 (kg/kg) + theta1(i) = t1(i) * prslki(i) !* adiabatic temp at level 1 (k) + + tv1(i) = t1(i) * (1.0 + con_fvirt*q0(i)) + rho(i) = prsl1(i) / (con_rd * tv1(i)) + qs1(i) = fpvs( t1(i) ) !* qs1=sat. humidity at level 1 (kg/kg) + qs1(i) = con_eps*qs1(i) / (prsl1(i) + con_epsm1*qs1(i)) + qs1(i) = max(qs1(i), 1.e-8) + q0 (i) = min(qs1(i), q0(i)) + + if (vegtype(i) == isice_table ) then + if (weasd(i) < 0.1) then + weasd(i) = 0.1 + endif + endif + + endif + enddo + +! --- ... noah: prepare variables to run noah lsm +! 1. configuration information (c): +! ------------------------------ +! couple - couple-uncouple flag (=1: coupled, =0: uncoupled) +! ffrozp - fraction for snow-rain (1.=snow, 0.=rain, 0-1 mixed)) +! ice - sea-ice flag (=1: sea-ice, =0: land) +! dt - timestep (sec) (dt should not exceed 3600 secs) = delt +! zlvl - height (m) above ground of atmospheric forcing variables +! nsoil - number of soil layers (at least 2) +! sldpth - the thickness of each soil layer (m) + + do i = 1, im + + if (flag_iter(i) .and. flag(i)) then + + + couple = 1 + + ice = 0 + nsoil = km + snowng = .false. + frzgra = .false. + + +! if (srflag(i) == 1.0) then ! snow phase +! ffrozp = 1.0 +! elseif (srflag(i) == 0.0) then ! rain phase +! ffrozp = 0.0 +! endif +! use srflag directly to allow fractional rain/snow + ffrozp = srflag(i) + + zlvl = zf(i) + +! 2. forcing data (f): +! ----------------- +! lwdn - lw dw radiation flux (w/m2) +! solnet - net sw radiation flux (dn-up) (w/m2) +! sfcprs - pressure at height zlvl above ground (pascals) +! prcp - precip rate (kg m-2 s-1) +! sfctmp - air temperature (k) at height zlvl above ground +! th2 - air potential temperature (k) at height zlvl above ground +! q2 - mixing ratio at height zlvl above ground (kg kg-1) + + lat = xlatin(i) ! in radian + cosz = xcoszin(i) + + lwdn = dlwflx(i) !..downward lw flux at sfc in w/m2 + swdn = dswsfc(i) !..downward sw flux at sfc in w/m2 + solnet = snet(i) !..net sw rad flx (dn-up) at sfc in w/m2 + sfcems = sfcemis(i) + + sfctmp = t1(i) + sfcprs = prsl1(i) + psfc = ps(i) + prcp = rhoh2o * tprcp(i) / delt + + if (prcp > 0.0) then + if (ffrozp > 0.0) then ! rain/snow flag, one condition is enough? + snowng = .true. + qsnowxy(i) = ffrozp * prcp/10.0 !still use rho water? + else + if (sfctmp <= 275.15) frzgra = .true. + endif + endif + + th2 = theta1(i) + q2 = q0(i) + +! 3. other forcing (input) data (i): +! ------------------------------ +! sfcspd - wind speed (m s-1) at height zlvl above ground +! q2sat - sat mixing ratio at height zlvl above ground (kg kg-1) +! dqsdt2 - slope of sat specific humidity curve at t=sfctmp (kg kg-1 k-1) + + uu = u1(i) + vv = v1(i) + + sfcspd = wind(i) + q2sat = qs1(i) + dqsdt2 = q2sat * a23m4/(sfctmp-a4)**2 + +! 4. canopy/soil characteristics (s): +! -------------------------------- +! vegtyp - vegetation type (integer index) -> vtype +! soiltyp - soil type (integer index) -> stype +! slopetyp- class of sfc slope (integer index) -> slope +! shdfac - areal fractional coverage of green vegetation (0.0-1.0) +! shdmin - minimum areal fractional coverage of green vegetation -> shdmin1d +! ptu - photo thermal unit (plant phenology for annuals/crops) +! alb - backround snow-free surface albedo (fraction) +! snoalb - upper bound on maximum albedo over deep snow -> snoalb1d +! tbot - bottom soil temperature (local yearly-mean sfc air temp) + + vtype = vegtype(i) + stype = soiltyp(i) + slope = slopetyp(i) + shdfac= sigmaf(i) + + shdmin1d = shdmin(i) + shdmax1d = shdmax(i) + snoalb1d = snoalb(i) + + alb = sfalb(i) + + tbot = tg3(i) + ptu = 0.0 + + + cmc = canopy(i)/1000. ! convert from mm to m + tsea = tsurf(i) ! clu_q2m_iter + + snowh = snwdph(i) * 0.001 ! convert from mm to m + sneqv = weasd(i) * 0.001 ! convert from mm to m + + + +! 5. history (state) variables (h): +! ------------------------------ +! cmc - canopy moisture content (m) +! t1 - ground/canopy/snowpack) effective skin temperature (k) -> tsea +! stc(nsoil) - soil temp (k) -> stsoil +! smc(nsoil) - total soil moisture content (volumetric fraction) -> smsoil +! sh2o(nsoil)- unfrozen soil moisture content (volumetric fraction) -> slsoil +! snowh - actual snow depth (m) +! sneqv - liquid water-equivalent snow depth (m) +! albedo - surface albedo including snow effect (unitless fraction) +! ch - surface exchange coefficient for heat and moisture (m s-1) -> chx +! cm - surface exchange coefficient for momentum (m s-1) -> cmx + + isnowx = nint(snowxy(i)) + tvx = tvxy(i) + tgx = tgxy(i) + canliqx = canliqxy(i) !in mm + canicex = canicexy(i) + + eahxy(i) = (ps(i)*q2)/(0.622+q2) ! use q0 to reinit; + eahx = eahxy(i) + tahx = tahxy(i) + + co2pp = co2_table * sfcprs + o2pp = o2_table * sfcprs + fwetx = fwetxy(i) + + sneqvox = sneqvoxy(i) + alboldx = alboldxy(i) + + qsnowx = qsnowxy(i) + wslakex = wslakexy(i) + + zwtx = zwtxy(i) + wax = waxy(i) + wtx = waxy(i) + + do k = -2,0 + tsnsoxy(i,k) = tsnoxy(i,k) + enddo + + do k = 1,4 + tsnsoxy(i,k) = stc(i,k) + enddo + + do k = -2,0 + snicex(k) = snicexy(i,k) ! in k/m3; mm + snliqx(k) = snliqxy(i,k) ! in k/m3; mm + tsnox (k) = tsnoxy(i,k) + + ficeold(k) = 0.0 ! derived + + if (snicex(k) > 0.0 ) then + ficeold(k) = snicex(k) /(snicex(k)+snliqx(k)) + + endif + enddo + + do k = -2, km + zsnsox(k) = zsnsoxy(i,k) + tsnsox(k) = tsnsoxy(i,k) + enddo + + lfmassx = lfmassxy(i) + rtmassx = rtmassxy(i) + stmassx = stmassxy(i) + + woodx = woodxy(i) + stblcpx = stblcpxy(i) + fastcpx = fastcpxy(i) + + xsaix = xsaixy(i) + xlaix = xlaixy(i) + + taussx = taussxy(i) + + qsfc1d = undefined ! derive later, it is an in/out? + swe = weasd(i) + + do k = 1, km + smoiseqx(k) = smoiseq(i,k) + enddo + + smcwtdx = smcwtdxy(i) + rechx = rechxy(i) + deeprechx = deeprechxy(i) +!-- +! the optional details for precip +!-- + +! pconv = 0. ! convective - may introduce later +! pnonc = (1 - ffrozp) * prcp ! large scale total in mm/s; +! pshcv = 0. +! psnow = ffrozp * prcp /10.0 ! snow = qsnowx? +! pgrpl = 0. +! phail = 0. + pnonc = rainn_mp(i) + pconv = rainc_mp(i) + pshcv = 0. + psnow = snow_mp(i) + pgrpl = graupel_mp(i) + phail = ice_mp(i) +! +!-- old +! + do k = 1, km +! stsoil(k) = stc(i,k) + smsoil(k) = smc(i,k) + slsoil(k) = slc(i,k) + enddo + + snowh = snwdph(i) * 0.001 ! convert from mm to m + + if (swe /= 0.0 .and. snowh == 0.0) then + snowh = 10.0 * swe /1000.0 + endif + + chx = chxy(i) ! maybe chxy + cmx = cmxy(i) + + chh(i) = ch(i) * wind(i) * rho(i) + cmm(i) = cm(i) * wind(i) + + + + call transfer_mp_parameters(vtype,stype,slope,isc,parameters) + + call noahmp_options(idveg ,iopt_crs,iopt_btr,iopt_run,iopt_sfc, & + & iopt_frz,iopt_inf,iopt_rad,iopt_alb,iopt_snf,iopt_tbot,iopt_stc) + + if ( vtype == isice_table ) then + + ice = -1 + tbot = min(tbot,263.15) + + call noahmp_options_glacier & + & (idveg ,iopt_crs ,iopt_btr, iopt_run ,iopt_sfc ,iopt_frz, & + & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + + call noahmp_glacier ( & + & i ,1 ,cosz ,nsnow ,nsoil ,delt , & ! in : time/space/model-related + & sfctmp ,sfcprs ,uu ,vv ,q2 ,swdn , & ! in : forcing + & prcp ,lwdn ,tbot ,zlvl ,ficeold ,zsoil , & ! in : forcing + & qsnowx ,sneqvox ,alboldx ,cmx ,chx ,isnowx, & ! in/out :sneqvox + alboldx -LST + & swe ,smsoil ,zsnsox ,snowh ,snicex ,snliqx , & ! in/out : sneqvx + snowhx are avgd + & tgx ,tsnsox ,slsoil ,taussx ,qsfc1d , & ! in/out : + & fsa ,fsr ,fira ,fsh ,fgev ,ssoil , & ! out : + & trad ,edir ,runsrf ,runsub ,sag ,albedo , & ! out : albedo is surface albedo + & qsnbot ,ponding ,ponding1,ponding2,t2mb ,q2b , & ! out : + & emissi ,fpice ,ch2b ,esnow ) + +! +! in/out and outs +! + + fsno = 1.0 + + tvx = undefined + canicex = undefined + canliqx = undefined + eahx = undefined + tahx = undefined + + fwetx = undefined + wslakex = undefined + zwtx = undefined + wax = undefined + wtx = undefined + + lfmassx = undefined + rtmassx = undefined + stmassx = undefined + woodx = undefined + stblcpx = undefined + fastcpx = undefined + xlaix = undefined + xsaix = undefined + + smcwtdx = 0.0 + rechx = 0.0 + deeprechx = 0.0 + + do k = 1,4 + smoiseqx(k) = smsoil(k) + enddo + + fctr = undefined + fcev = undefined + + z0wrf = 0.002 + + eta = fgev + t2mmp(i) = t2mb + q2mp(i) = q2b +! +! Non-glacial case +! + else + ice = 0 + +! write(*,*)'tsnsox(1)=',tsnsox,'tgx=',tgx + call noahmp_sflx (parameters ,& + & i , 1 , lat , iyrlen , julian , cosz ,& ! in : time/space-related + & delt , dx , dz8w , nsoil , zsoil , nsnow ,& ! in : model configuration + & shdfac , shdmax1d, vtype , ice , ist ,& ! in : vegetation/soil + & smoiseqx ,& ! in + & sfctmp , sfcprs , psfc , uu , vv , q2 ,& ! in : forcing + & qc , swdn , lwdn ,& ! in : forcing + & pconv , pnonc , pshcv , psnow , pgrpl , phail ,& ! in : forcing + & tbot , co2pp , o2pp , foln , ficeold , zlvl ,& ! in : forcing + & alboldx , sneqvox ,& ! in/out : + & tsnsox , slsoil , smsoil , tahx , eahx , fwetx ,& ! in/out : + & canliqx , canicex , tvx , tgx , qsfc1d , qsnowx ,& ! in/out : + & isnowx , zsnsox , snowh , swe , snicex , snliqx ,& ! in/out : + & zwtx , wax , wtx , wslakex , lfmassx , rtmassx,& ! in/out : + & stmassx , woodx , stblcpx , fastcpx , xlaix ,xsaix ,& ! in/out : + & cmx , chx , taussx ,& ! in/out : + & smcwtdx ,deeprechx, rechx ,& ! in/out : + & z0wrf ,& ! out + & fsa , fsr , fira , fsh , ssoil , fcev ,& ! out : + & fgev , fctr , ecan , etran , edir , trad ,& ! out : + & tgb , tgv , t2mv , t2mb , q2v , q2b ,& ! out : + & runsrf , runsub , apar , psn , sav , sag ,& ! out : + & fsno , nee , gpp , npp , fveg , albedo ,& ! out : + & qsnbot , ponding , ponding1, ponding2, rssun , rssha ,& ! out : + & bgap , wgap , chv , chb , emissi ,& ! out : + & shg , shc , shb , evg , evb , ghv ,&! out : + & ghb , irg , irc , irb , tr , evc ,& ! out : + & chleaf , chuc , chv2 , chb2 , fpice , pahv ,& ! out + & pahg , pahb , pah , esnow ) + + + eta = fcev + fgev + fctr ! the flux w/m2 + + t2mmp(i) = t2mv*fveg+t2mb*(1-fveg) + q2mp(i) = q2v*fveg+q2b*(1-fveg) + + endif ! glacial split ends + +! +! mp in/out +! + snowxy (i) = float(isnowx) + tvxy (i) = tvx + tgxy (i) = tgx + canliqxy (i) = canliqx + canicexy (i) = canicex + eahxy (i) = eahx + tahxy (i) = tahx + + cmxy (i) = cmx + chxy (i) = chx + + fwetxy (i) = fwetx + sneqvoxy (i) = sneqvox + alboldxy (i) = alboldx + qsnowxy (i) = qsnowx + + wslakexy (i) = wslakex + zwtxy (i) = zwtx + waxy (i) = wax + wtxy (i) = wtx + + do k = -2,0 + tsnoxy (i,k) = tsnsox(k) + snicexy (i,k) = snicex (k) + snliqxy (i,k) = snliqx (k) + enddo + + do k = -2,4 + zsnsoxy (i,k) = zsnsox(k) + enddo + + lfmassxy (i) = lfmassx + rtmassxy (i) = rtmassx + stmassxy (i) = stmassx + woodxy (i) = woodx + stblcpxy (i) = stblcpx + fastcpxy (i) = fastcpx + + xlaixy (i) = xlaix + xsaixy (i) = xsaix + + taussxy (i) = taussx + + rechxy (i) = rechx + deeprechxy(i) = deeprechx + smcwtdxy(i) = smcwtdx + smoiseq(i,1:4) = smoiseqx(1:4) + +! +! generic in/outs +! + do k = 1, km + stc(i,k) = tsnsox(k) + smc(i,k) = smsoil(k) + slc(i,k) = slsoil(k) + enddo + + canopy(i) = canicex + canliqx + weasd(i) = swe + snwdph(i) = snowh * 1000.0 + +! write(*,*) 'swe,snowh,can' +! write (*,*) swe,snowh*1000.0,canopy(i) +! + smcmax = smcmax_table(stype) + smcref = smcref_table(stype) + smcwlt = smcdry_table(stype) +! +! outs +! + wet1(i) = smsoil(1) / smcmax + smcwlt2(i) = smcwlt + smcref2(i) = smcref + + runoff(i) = runsrf + drain(i) = runsub + + zorl(i) = z0wrf * 100.0 + + sncovr1(i) = fsno + snowc (i) = fsno + + sbsno(i) = esnow + gflux(i) = -1.0*ssoil + hflx(i) = fsh + evbs(i) = fgev + evcw(i) = fcev + trans(i) = fctr + evap(i) = eta + +! write(*,*) 'vtype, stype are',vtype,stype +! write(*,*) 'fsh,gflx,eta',fsh,ssoil,eta +! write(*,*) 'esnow,runsrf,runsub',esnow,runsrf,runsub +! write(*,*) 'evbs,evcw,trans',fgev,fcev,fctr +! write(*,*) 'snowc',fsno + + tsurf(i) = trad + + stm(i) = (0.1*smsoil(1)+0.3*smsoil(2)+0.6*smsoil(3)+ & + & 1.0*smsoil(4))*1000.0 ! unit conversion from m to kg m-2 +! + snohf (i) = qsnbot * con_hfus ! only part of it but is diagnostic +! write(*,*) 'snohf',snohf(i) + + fdown = fsa + lwdn + t2v = sfctmp * (1.0 + 0.61*q2) +! ssoil = -1.0 *ssoil + + call penman (sfctmp,sfcprs,chx,t2v,th2,prcp,fdown,ssoil, & + & q2,q2sat,etp,snowng,frzgra,ffrozp,dqsdt2,emissi,fsno) + + ep(i) = etp + + endif ! end if_flag_iter_and_flag_block + enddo ! end do_i_loop + +! --- ... compute qsurf (specific humidity at sfc) + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + rch(i) = rho(i) * con_cp * ch(i) * wind(i) + qsurf(i) = q1(i) + evap(i) / (elocp * rch(i)) + endif + enddo + + do i = 1, im + if (flag_iter(i) .and. flag(i)) then + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo + +! --- ... restore land-related prognostic fields for guess run + + do i = 1, im + if (flag(i)) then + if (flag_guess(i)) then + weasd(i) = weasd_old(i) + snwdph(i) = snwdph_old(i) + tskin(i) = tskin_old(i) + canopy(i) = canopy_old(i) + tprcp(i) = tprcp_old(i) + srflag(i) = srflag_old(i) + + + snowxy(i) = snow_old(i) + tvxy(i) = tv_old(i) + tgxy(i) = tg_old(i) + + canicexy(i) = canice_old(i) + canliqxy(i) = canliq_old(i) + eahxy(i) = eah_old(i) + tahxy(i) = tah_old(i) + fwetxy(i) = fwet_old(i) + sneqvoxy(i) = sneqvo_old(i) + alboldxy(i) = albold_old(i) + qsnowxy(i) = qsnow_old(i) + wslakexy(i) = wslake_old(i) + zwtxy(i) = zwt_old(i) + waxy(i) = wa_old(i) + wtxy(i) = wt_old(i) + lfmassxy(i) = lfmass_old(i) + rtmassxy(i) = rtmass_old(i) + stmassxy(i) = stmass_old(i) + woodxy(i) = wood_old(i) + stblcpxy(i) = stblcp_old(i) + fastcpxy(i) = fastcp_old(i) + xlaixy(i) = xlai_old(i) + xsaixy(i) = xsai_old(i) + taussxy(i) = tauss_old(i) + smcwtdxy(i) = smcwtd_old(i) + deeprechxy(i) = deeprech_old(i) + rechxy(i) = rech_old(i) + + do k = 1, km + smc(i,k) = smc_old(i,k) + stc(i,k) = stc_old(i,k) + slc(i,k) = slc_old(i,k) + enddo +! + do k = 1, km + smoiseq(i,k) = smoiseq_old(i,k) + enddo + + do k = -2,0 + tsnoxy(i,k) = tsno_old(i,k) + snicexy(i,k) = snice_old(i,k) + snliqxy(i,k) = snliq_old(i,k) + enddo + + do k = -2,4 + zsnsoxy(i,k) = zsnso_old(i,k) + enddo + else + tskin(i) = tsurf(i) + endif + endif + enddo +! + return +!................................... + end subroutine noahmpdrv +!----------------------------------- + + subroutine transfer_mp_parameters (vegtype,soiltype,slopetype, & + & soilcolor,parameters) + + use noahmp_tables + use module_sf_noahmplsm + + implicit none + + integer, intent(in) :: vegtype + integer, intent(in) :: soiltype + integer, intent(in) :: slopetype + integer, intent(in) :: soilcolor + + type (noahmp_parameters), intent(out) :: parameters + + real :: refdk + real :: refkdt + real :: frzk + real :: frzfact + + parameters%iswater = iswater_table + parameters%isbarren = isbarren_table + parameters%isice = isice_table + parameters%eblforest = eblforest_table + +!-----------------------------------------------------------------------& + parameters%urban_flag = .false. + if( vegtype == isurban_table .or. vegtype == 31 & + & .or.vegtype == 32 .or. vegtype == 33) then + parameters%urban_flag = .true. + endif + +!------------------------------------------------------------------------------------------! +! transfer veg parameters +!------------------------------------------------------------------------------------------! + + parameters%ch2op = ch2op_table(vegtype) !maximum intercepted h2o per unit lai+sai (mm) + parameters%dleaf = dleaf_table(vegtype) !characteristic leaf dimension (m) + parameters%z0mvt = z0mvt_table(vegtype) !momentum roughness length (m) + parameters%hvt = hvt_table(vegtype) !top of canopy (m) + parameters%hvb = hvb_table(vegtype) !bottom of canopy (m) + parameters%den = den_table(vegtype) !tree density (no. of trunks per m2) + parameters%rc = rc_table(vegtype) !tree crown radius (m) + parameters%mfsno = mfsno_table(vegtype) !snowmelt m parameter () + parameters%saim = saim_table(vegtype,:) !monthly stem area index, one-sided + parameters%laim = laim_table(vegtype,:) !monthly leaf area index, one-sided + parameters%sla = sla_table(vegtype) !single-side leaf area per kg [m2/kg] + parameters%dilefc = dilefc_table(vegtype) !coeficient for leaf stress death [1/s] + parameters%dilefw = dilefw_table(vegtype) !coeficient for leaf stress death [1/s] + parameters%fragr = fragr_table(vegtype) !fraction of growth respiration !original was 0.3 + parameters%ltovrc = ltovrc_table(vegtype) !leaf turnover [1/s] + + parameters%c3psn = c3psn_table(vegtype) !photosynthetic pathway: 0. = c4, 1. = c3 + parameters%kc25 = kc25_table(vegtype) !co2 michaelis-menten constant at 25c (pa) + parameters%akc = akc_table(vegtype) !q10 for kc25 + parameters%ko25 = ko25_table(vegtype) !o2 michaelis-menten constant at 25c (pa) + parameters%ako = ako_table(vegtype) !q10 for ko25 + parameters%vcmx25 = vcmx25_table(vegtype) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + parameters%avcmx = avcmx_table(vegtype) !q10 for vcmx25 + parameters%bp = bp_table(vegtype) !minimum leaf conductance (umol/m**2/s) + parameters%mp = mp_table(vegtype) !slope of conductance-to-photosynthesis relationship + parameters%qe25 = qe25_table(vegtype) !quantum efficiency at 25c (umol co2 / umol photon) + parameters%aqe = aqe_table(vegtype) !q10 for qe25 + parameters%rmf25 = rmf25_table(vegtype) !leaf maintenance respiration at 25c (umol co2/m**2/s) + parameters%rms25 = rms25_table(vegtype) !stem maintenance respiration at 25c (umol co2/kg bio/s) + parameters%rmr25 = rmr25_table(vegtype) !root maintenance respiration at 25c (umol co2/kg bio/s) + parameters%arm = arm_table(vegtype) !q10 for maintenance respiration + parameters%folnmx = folnmx_table(vegtype) !foliage nitrogen concentration when f(n)=1 (%) + parameters%tmin = tmin_table(vegtype) !minimum temperature for photosynthesis (k) + + parameters%xl = xl_table(vegtype) !leaf/stem orientation index + parameters%rhol = rhol_table(vegtype,:) !leaf reflectance: 1=vis, 2=nir + parameters%rhos = rhos_table(vegtype,:) !stem reflectance: 1=vis, 2=nir + parameters%taul = taul_table(vegtype,:) !leaf transmittance: 1=vis, 2=nir + parameters%taus = taus_table(vegtype,:) !stem transmittance: 1=vis, 2=nir + + parameters%mrp = mrp_table(vegtype) !microbial respiration parameter (umol co2 /kg c/ s) + parameters%cwpvt = cwpvt_table(vegtype) !empirical canopy wind parameter + + parameters%wrrat = wrrat_table(vegtype) !wood to non-wood ratio + parameters%wdpool = wdpool_table(vegtype) !wood pool (switch 1 or 0) depending on woody or not [-] + parameters%tdlef = tdlef_table(vegtype) !characteristic t for leaf freezing [k] + + parameters%nroot = nroot_table(vegtype) !number of soil layers with root present + parameters%rgl = rgl_table(vegtype) !parameter used in radiation stress function + parameters%rsmin = rs_table(vegtype) !minimum stomatal resistance [s m-1] + parameters%hs = hs_table(vegtype) !parameter used in vapor pressure deficit function + parameters%topt = topt_table(vegtype) !optimum transpiration air temperature [k] + parameters%rsmax = rsmax_table(vegtype) !maximal stomatal resistance [s m-1] + +!------------------------------------------------------------------------------------------! +! transfer rad parameters +!------------------------------------------------------------------------------------------! + + parameters%albsat = albsat_table(soilcolor,:) + parameters%albdry = albdry_table(soilcolor,:) + parameters%albice = albice_table + parameters%alblak = alblak_table + parameters%omegas = omegas_table + parameters%betads = betads_table + parameters%betais = betais_table + parameters%eg = eg_table + +!------------------------------------------------------------------------------------------! +! transfer global parameters +!------------------------------------------------------------------------------------------! + + parameters%co2 = co2_table + parameters%o2 = o2_table + parameters%timean = timean_table + parameters%fsatmx = fsatmx_table + parameters%z0sno = z0sno_table + parameters%ssi = ssi_table + parameters%swemx = swemx_table + +! ---------------------------------------------------------------------- +! transfer soil parameters +! ---------------------------------------------------------------------- + + parameters%bexp = bexp_table (soiltype) + parameters%dksat = dksat_table (soiltype) + parameters%dwsat = dwsat_table (soiltype) + parameters%f1 = f1_table (soiltype) + parameters%psisat = psisat_table (soiltype) + parameters%quartz = quartz_table (soiltype) + parameters%smcdry = smcdry_table (soiltype) + parameters%smcmax = smcmax_table (soiltype) + parameters%smcref = smcref_table (soiltype) + parameters%smcwlt = smcwlt_table (soiltype) + +! ---------------------------------------------------------------------- +! transfer genparm parameters +! ---------------------------------------------------------------------- + parameters%csoil = csoil_table + parameters%zbot = zbot_table + parameters%czil = czil_table + + frzk = frzk_table + refdk = refdk_table + refkdt = refkdt_table + parameters%kdt = refkdt * parameters%dksat / refdk + parameters%slope = slope_table(slopetype) + + if(parameters%urban_flag)then ! hardcoding some urban parameters for soil + parameters%smcmax = 0.45 + parameters%smcref = 0.42 + parameters%smcwlt = 0.40 + parameters%smcdry = 0.40 + parameters%csoil = 3.e6 + endif + + ! adjust frzk parameter to actual soil type: frzk * frzfact + +!-----------------------------------------------------------------------& + if(soiltype /= 14) then + frzfact = (parameters%smcmax / parameters%smcref) & + & * (0.412 / 0.468) + parameters%frzx = frzk * frzfact + end if + + end subroutine transfer_mp_parameters + +!-----------------------------------------------------------------------& + + + subroutine penman (sfctmp,sfcprs,ch,t2v,th2,prcp,fdown,ssoil, & + & q2,q2sat,etp,snowng,frzgra,ffrozp, & + & dqsdt2,emissi_in,sncovr) + +! etp is calcuated right after ssoil + +! ---------------------------------------------------------------------- +! subroutine penman +! ---------------------------------------------------------------------- +! calculate potential evaporation for the current point. various +! partial sums/products are also calculated and passed back to the +! calling routine for later use. +! ---------------------------------------------------------------------- + implicit none + logical, intent(in) :: snowng, frzgra + real, intent(in) :: ch, dqsdt2,fdown,prcp,ffrozp, & + & q2, q2sat, ssoil, sfcprs, sfctmp, & + & t2v, th2,emissi_in,sncovr + real, intent(out) :: etp + real :: epsca,flx2,rch,rr,t24 + real :: a, delta, fnet,rad,rho,emissi,elcp1,lvs + + real, parameter :: elcp = 2.4888e+3, lsubc = 2.501000e+6,cp = 1004.6 + real, parameter :: lsubs = 2.83e+6, rd = 287.05, cph2o = 4.1855e+3 + real, parameter :: cpice = 2.106e+3, lsubf = 3.335e5 + real, parameter :: sigma = 5.6704e-8 + +! ---------------------------------------------------------------------- +! executable code begins here: +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! prepare partial quantities for penman equation. +! ---------------------------------------------------------------------- + emissi=emissi_in +! elcp1 = (1.0-sncovr)*elcp + sncovr*elcp*lsubs/lsubc + lvs = (1.0-sncovr)*lsubc + sncovr*lsubs + + flx2 = 0.0 + delta = elcp * dqsdt2 +! delta = elcp1 * dqsdt2 + t24 = sfctmp * sfctmp * sfctmp * sfctmp + rr = t24 * 6.48e-8 / (sfcprs * ch) + 1.0 +! rr = emissi*t24 * 6.48e-8 / (sfcprs * ch) + 1.0 + rho = sfcprs / (rd * t2v) + +! ---------------------------------------------------------------------- +! adjust the partial sums / products with the latent heat +! effects caused by falling precipitation. +! ---------------------------------------------------------------------- + rch = rho * cp * ch + if (.not. snowng) then + if (prcp > 0.0) rr = rr + cph2o * prcp / rch + else +! ---- ... fractional snowfall/rainfall + rr = rr + (cpice*ffrozp+cph2o*(1.-ffrozp)) & + & *prcp/rch + end if + +! ---------------------------------------------------------------------- +! include the latent heat effects of frzng rain converting to ice on +! impact in the calculation of flx2 and fnet. +! ---------------------------------------------------------------------- +! fnet = fdown - sigma * t24- ssoil + fnet = fdown - emissi*sigma * t24- ssoil + if (frzgra) then + flx2 = - lsubf * prcp + fnet = fnet - flx2 +! ---------------------------------------------------------------------- +! finish penman equation calculations. +! ---------------------------------------------------------------------- + end if + rad = fnet / rch + th2- sfctmp + a = elcp * (q2sat - q2) +! a = elcp1 * (q2sat - q2) + epsca = (a * rr + rad * delta) / (delta + rr) + etp = epsca * rch / lsubc +! etp = epsca * rch / lvs + +! ---------------------------------------------------------------------- + end subroutine penman + + + diff --git a/gsmphys/sfc_nst.f b/gsmphys/sfc_nst.f new file mode 100644 index 00000000..9155172d --- /dev/null +++ b/gsmphys/sfc_nst.f @@ -0,0 +1,570 @@ + + subroutine sfc_nst & +!................................... +! --- inputs: + & ( im, km, ps, u1, v1, t1, q1, tref, cm, ch, & + & prsl1, prslki, islimsk, xlon, sinlat, stress, & + & sfcemis, dlwflx, sfcnsw, rain, timestep, kdt, solhr,xcosz, & + & ddvel, flag_iter, flag_guess, nstf_name, & + & lprnt, ipr, & +! --- input/output + & tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & + & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, & +! --- outputs: + & qsurf, gflux, cmm, chh, evap, hflx, ep & + & ) +! +! ===================================================================== ! +! description: ! +! ! +! ! +! usage: ! +! ! +! call sfc_nst ! +! inputs: ! +! ( im, km, ps, u1, v1, t1, q1, tref, cm, ch, ! +! prsl1, prslki, islimsk, xlon, sinlat, stress, ! +! sfcemis, dlwflx, sfcnsw, rain, timestep, kdt,solhr,xcosz, ! +! ddvel, flag_iter, flag_guess, nstf_name, ! +! lprnt, ipr, ! +! input/outputs: ! +! tskin, tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, ! +! z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain, ! +! -- outputs: +! qsurf, gflux, cmm, chh, evap, hflx, ep ! +! ) +! ! +! ! +! subprogram/functions called: w3movdat, iw3jdn, fpvs, density, ! +! rhocoef, cool_skin, warm_layer, jacobi_temp. ! +! ! +! program history log: ! +! 2007 -- xu li createad original code ! +! 2008 -- s. moorthi adapted to the parallel version ! +! may 2009 -- y.-t. hou modified to include input lw surface ! +! emissivity from radiation. also replaced the ! +! often comfusing combined sw and lw suface ! +! flux with separate sfc net sw flux (defined ! +! as dn-up) and lw flux. added a program doc block. ! +! sep 2009 -- s. moorthi removed rcl and additional reformatting ! +! and optimization + made pa as input pressure unit.! +! 2009 -- xu li recreatead the code ! +! feb 2010 -- s. moorthi added some changes made to the previous ! +! version ! +! Jul 2016 -- X. Li, modify the diurnal warming event reset ! +! ! +! ! +! ==================== definition of variables ==================== ! +! ! +! inputs: size ! +! im - integer, horiz dimension 1 ! +! km - integer, vertical dimension 1 ! +! ps - real, surface pressure (pa) im ! +! u1, v1 - real, u/v component of surface layer wind (m/s) im ! +! t1 - real, surface layer mean temperature ( k ) im ! +! q1 - real, surface layer mean specific humidity im ! +! tref - real, reference/foundation temperature ( k ) im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, surface layer mean pressure (pa) im ! +! prslki - real, im ! +! islimsk - integer, sea/land/ice mask (=0/1/2) im ! +! xlon - real, longitude (radians) im ! +! sinlat - real, sin of latitude im ! +! stress - real, wind stress (n/m**2) im ! +! sfcemis - real, sfc lw emissivity (fraction) im ! +! dlwflx - real, total sky sfc downward lw flux (w/m**2) im ! +! sfcnsw - real, total sky sfc netsw flx into ocean (w/m**2) im ! +! rain - real, rainfall rate (kg/m**2/s) im ! +! timestep - real, timestep interval (second) 1 ! +! kdt - integer, time step counter 1 ! +! solhr - real, fcst hour at the end of prev time step 1 ! +! xcosz - real, consine of solar zenith angle 1 ! +! ddvel - real, wind enhancement due to convection (m/s) im ! +! flag_iter- logical, execution or not im ! +! when iter = 1, flag_iter = .true. for all grids im ! +! when iter = 2, flag_iter = .true. when wind < 2 im ! +! for both land and ocean (when nstf_name(1) > 0) im ! +! flag_guess-logical, .true.= guess step to get CD et al im ! +! when iter = 1, flag_guess = .true. when wind < 2 im ! +! when iter = 2, flag_guess = .false. for all grids im ! +! nstf_name -integer array, NSST related flag parameters 1 ! +! nstf_name(1) : 0 = NSSTM off 1 ! +! 1 = NSSTM on but uncoupled 1 ! +! 2 = NSSTM on and coupled 1 ! +! nstf_name(2) : 1 = NSSTM spin up on 1 ! +! 0 = NSSTM spin up off 1 ! +! nstf_name(3) : 1 = NSST analysis on 1 ! +! 0 = NSSTM analysis off 1 ! +! nstf_name(4) : zsea1 in mm 1 ! +! nstf_name(5) : zsea2 in mm 1 ! +! lprnt - logical, control flag for check print out 1 ! +! ipr - integer, grid index for check print out 1 ! +! ! +! input/outputs: +! li added for oceanic components +! tskin - real, ocean surface skin temperature ( k ) im ! +! tsurf - real, the same as tskin ( k ) but for guess run im ! +! xt - real, heat content in dtl im ! +! xs - real, salinity content in dtl im ! +! xu - real, u-current content in dtl im ! +! xv - real, v-current content in dtl im ! +! xz - real, dtl thickness im ! +! zm - real, mxl thickness im ! +! xtts - real, d(xt)/d(ts) im ! +! xzts - real, d(xz)/d(ts) im ! +! dt_cool - real, sub-layer cooling amount im ! +! d_conv - real, thickness of free convection layer (fcl) im ! +! z_c - sub-layer cooling thickness im ! +! c_0 - coefficient1 to calculate d(tz)/d(ts) im ! +! c_d - coefficient2 to calculate d(tz)/d(ts) im ! +! w_0 - coefficient3 to calculate d(tz)/d(ts) im ! +! w_d - coefficient4 to calculate d(tz)/d(ts) im ! +! ifd - real, index to start dtlm run or not im ! +! qrain - real, sensible heat flux due to rainfall (watts) im ! + +! outputs: ! + +! qsurf - real, surface air saturation specific humidity im ! +! gflux - real, soil heat flux (w/m**2) im ! +! cmm - real, im ! +! chh - real, im ! +! evap - real, evaperation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ep - real, potential evaporation im ! +! ! +! ===================================================================== ! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, hvap => con_hvap & + &, cp => con_cp, hfus => con_hfus, jcal => con_jcal & + &, eps => con_eps, epsm1 => con_epsm1 & + &, rvrdm1 => con_fvirt, rd => con_rd & + &, rhw0 => con_rhw0,sbc => con_sbc,pi => con_pi + use date_def, only: idate + use module_nst_water_prop, only: get_dtzm_point + use module_nst_parameters, only : t0k,cp_w,omg_m,omg_sh, & + & sigma_r,solar_time_6am,ri_c,z_w_max,delz,wd_max, & + & rad2deg,const_rot,tau_min,tw_max,sst_max + use module_nst_water_prop, only: solar_time_from_julian, & + & density,rhocoef,compjd,grv & + &, sw_ps_9b + use nst_module, only : cool_skin,dtm_1p,cal_w,cal_ttop, & + & convdepth,dtm_1p_fca,dtm_1p_tla, & + & dtm_1p_mwa,dtm_1p_mda,dtm_1p_mta, & + & dtl_reset +! + implicit none +! +! --- constant parameters: + real (kind=kind_phys), parameter :: cpinv=1.0/cp, hvapi=1.0/hvap + real (kind=kind_phys), parameter :: f24 = 24.0 ! hours/day + real (kind=kind_phys), parameter :: f1440 = 1440.0 ! minutes/day + real (kind=kind_phys), parameter :: czmin = 0.0001 ! cos(89.994) + + +! --- inputs: + integer, intent(in) :: im, km, kdt, ipr,nstf_name(5) + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, tref, cm, ch, prsl1, prslki, xlon,xcosz, & + & sinlat, stress, sfcemis, dlwflx, sfcnsw, rain, ddvel + integer, intent(in), dimension(im):: islimsk + real (kind=kind_phys), intent(in) :: timestep + real (kind=kind_phys), intent(in) :: solhr + + logical, intent(in) :: flag_iter(im), flag_guess(im), lprnt + +! --- input/outputs: +! control variables of dtl system (5+2) and sl (2) and coefficients for d(tz)/d(ts) calculation + real (kind=kind_phys), dimension(im), intent(inout) :: tskin, & + & tsurf, xt, xs, xu, xv, xz, zm, xtts, xzts, dt_cool, & + & z_c, c_0, c_d, w_0, w_d, d_conv, ifd, qrain + +! --- outputs: + real (kind=kind_phys), dimension(im), intent(out) :: & + & qsurf, gflux, cmm, chh, evap, hflx, ep + +! +! locals +! + integer :: k,i +! + real (kind=kind_phys), dimension(im) :: q0, qss, rch, + & rho_a, theta1, tv1, wind, wndmag + + real(kind=kind_phys) elocp,tem +! +! nstm related prognostic fields +! + logical flag(im) + real (kind=kind_phys), dimension(im) :: + & xt_old, xs_old, xu_old, xv_old, xz_old,zm_old,xtts_old, + & xzts_old, ifd_old, tref_old, tskin_old, dt_cool_old,z_c_old + + real(kind=kind_phys) ulwflx(im), nswsfc(im) +! real(kind=kind_phys) rig(im), +! & ulwflx(im),dlwflx(im), +! & slrad(im),nswsfc(im) + real(kind=kind_phys) alpha,beta,rho_w,f_nsol,sss,sep, + & cosa,sina,taux,tauy,grav,dz,t0,ttop0,ttop + + real(kind=kind_phys) le,fc,dwat,dtmp,wetc,alfac,ustar_a,rich + real(kind=kind_phys) rnl_ts,hs_ts,hl_ts,rf_ts,q_ts + real(kind=kind_phys) fw,q_warm + real(kind=kind_phys) t12,alon,tsea,sstc,dta,dtz + real(kind=kind_phys) zsea1,zsea2,soltim + +! external functions called: iw3jdn + integer :: iw3jdn +!====================================================================================================== +cc + parameter (elocp=hvap/cp) + + sss = 34.0 ! temporarily, when sea surface salinity data is not ready +! +! flag for open water and where the iteration is on +! + do i = 1, im + flag(i) = islimsk(i) == 0 .and. flag_iter(i) + enddo +! +! save nst-related prognostic fields for guess run +! + do i=1, im + if((islimsk(i) == 0) .and. flag_guess(i)) then + xt_old(i) = xt(i) + xs_old(i) = xs(i) + xu_old(i) = xu(i) + xv_old(i) = xv(i) + xz_old(i) = xz(i) + zm_old(i) = zm(i) + xtts_old(i) = xtts(i) + xzts_old(i) = xzts(i) + ifd_old(i) = ifd(i) + tskin_old(i) = tskin(i) + dt_cool_old(i) = dt_cool(i) + z_c_old(i) = z_c(i) + endif + enddo + + +! --- ... initialize variables. all units are m.k.s. unless specified. +! ps is in pascals, wind is wind speed, theta1 is surface air +! estimated from level 1 temperature, rho_a is air density and +! qss is saturation specific humidity at the water surface +!! + do i = 1, im + if ( flag(i) ) then + + nswsfc(i) = sfcnsw(i) ! net solar radiation at the air-sea surface (positive downward) + wndmag(i) = sqrt(u1(i)*u1(i) + v1(i)*v1(i)) + wind(i) = wndmag(i) + max( 0.0, min( ddvel(i), 30.0 ) ) + wind(i) = max( wind(i), 1.0 ) + + q0(i) = max(q1(i), 1.0e-8) + theta1(i) = t1(i) * prslki(i) + tv1(i) = t1(i) * (1.0 + rvrdm1*q0(i)) + rho_a(i) = prsl1(i) / (rd*tv1(i)) + qss(i) = fpvs(tsurf(i)) ! pa + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) ! pa +! + evap(i) = 0.0 + hflx(i) = 0.0 + gflux(i) = 0.0 + ep(i) = 0.0 + +! --- ... rcp = rho cp ch v + + rch(i) = rho_a(i) * cp * ch(i) * wind(i) + cmm(i) = cm (i) * wind(i) + chh(i) = rho_a(i) * ch(i) * wind(i) + +! --- ... latent and sensible heat flux over open water with tskin +! at previous time step + evap(i) = elocp * rch(i) * (qss(i) - q0(i)) + qsurf(i) = qss(i) + hflx(i) = rch(i) * (tsurf(i) - theta1(i)) + +! if (lprnt .and. i == ipr) print *,' tskin=',tskin(i),' theta1=', +! & theta1(i),' hflx=',hflx(i),' t1=',t1(i),'prslki=',prslki(i) +! &,' tsurf=',tsurf(i) + endif + enddo + +! run nst model: dtm + slm +! + zsea1 = 0.001*real(nstf_name(4)) + zsea2 = 0.001*real(nstf_name(5)) + do i = 1, im + if ( flag(i) ) then + tsea = tsurf(i) + t12 = tsea*tsea + ulwflx(i) = sfcemis(i) * sbc * t12 * t12 + alon = xlon(i)*rad2deg + grav = grv(sinlat(i)) + soltim = mod(alon/15.0 + solhr, 24.0)*3600.0 + call density(tsea,sss,rho_w) ! sea water density + call rhocoef(tsea,sss,rho_w,alpha,beta) ! alpha & beta +! +! calculate sensible heat flux due to rainfall +! + le = (2.501-.00237*tsea)*1e6 + dwat = 2.11e-5*(t1(i)/t0k)**1.94 ! water vapor diffusivity + dtmp = (1.+3.309e-3*(t1(i)-t0k)-1.44e-6*(t1(i)-t0k)* + & (t1(i)-t0k))*0.02411/(rho_a(i)*cp) ! heat diffusivity + wetc = 622.0*le*qss(i)/(rd*t1(i)*t1(i)) + alfac = 1/(1+(wetc*le*dwat)/(cp*dtmp)) ! wet bulb factor + qrain(i) = (1000.*rain(i)/rho_w)*alfac*cp_w* + & (tsea-t1(i)+(1000.*qss(i)-1000.*q0(i))*le/cp) + +! --- ... input non solar heat flux as upward = positive to models here + + f_nsol = hflx(i) + evap(i) + ulwflx(i) - dlwflx(i) + & + omg_sh*qrain(i) + +! if (lprnt .and. i == ipr) print *,' f_nsol=',f_nsol,' hflx=', +! &hflx(i),' evap=',evap(i),' ulwflx=',ulwflx(i),' dlwflx=',dlwflx(i) +! &,' omg_sh=',omg_sh,' qrain=',qrain(i) + + sep = sss*(evap(i)/le-rain(i))/rho_w + ustar_a = sqrt(stress(i)/rho_a(i)) ! air friction velocity +! +! sensitivities of heat flux components to ts +! + rnl_ts = 4.0*sfcemis(i)*sbc*tsea*tsea*tsea ! d(rnl)/d(ts) + hs_ts = rch(i) + hl_ts = rch(i)*elocp*eps*hvap*qss(i)/(rd*t12) + rf_ts = (1000.*rain(i)/rho_w)*alfac*cp_w*(1.0+rch(i)*hl_ts) + q_ts = rnl_ts + hs_ts + hl_ts + omg_sh*rf_ts +! +! run sub-layer cooling model/parameterization & calculate c_0, c_d +! + call cool_skin(ustar_a,f_nsol,nswsfc(i),evap(i),sss,alpha,beta + &, rho_w,rho_a(i),tsea,q_ts,hl_ts,grav,le + &, dt_cool(i),z_c(i),c_0(i),c_d(i)) + + tem = 1.0 / wndmag(i) + cosa = u1(i)*tem + sina = v1(i)*tem + taux = max(stress(i),tau_min)*cosa + tauy = max(stress(i),tau_min)*sina + fc = const_rot*sinlat(i) +! +! run dtm-1p system +! + if ( (soltim > solar_time_6am .and. ifd(i) == 0.0) ) then + else + ifd(i) = 1.0 +! +! calculate fcl thickness with current forcing and previous time's profile +! +! if (lprnt .and. i == ipr) print *,' beg xz=',xz(i) + + if ( f_nsol > 0.0 .and. xt(i) > 0.0 ) then + call convdepth(kdt,timestep,nswsfc(i),f_nsol,sss,sep,rho_w + &, alpha,beta,xt(i),xs(i),xz(i),d_conv(i)) + else + d_conv(i) = 0.0 + endif + +! if (lprnt .and. i == ipr) print *,' beg xz1=',xz(i) +! +! determine rich: wind speed dependent (right now) +! +! if ( wind(i) < 1.0 ) then +! rich = 0.25 + 0.03*wind(i) +! elseif ( wind(i) >= 1.0 .and. wind(i) < 1.5 ) then +! rich = 0.25 + 0.1*wind(i) +! elseif ( wind(i) >= 1.5 .and. wind(i) < 6.0 ) then +! rich = 0.25 + 0.6*wind(i) +! elseif ( wind(i) >= 6.0 ) then +! rich = 0.25 + min(0.8*wind(i),0.50) +! endif + + rich = ri_c + + call dtm_1p(kdt,timestep,rich,taux,tauy,nswsfc(i), + & f_nsol,sss,sep,q_ts,hl_ts,rho_w,alpha,beta,alon, + & sinlat(i),soltim,grav,le,d_conv(i), + & xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + +! if (lprnt .and. i == ipr) print *,' beg xz2=',xz(i) + +! apply mda + if ( xt(i) > 0.0 ) then + call dtm_1p_mda(xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset(xt(i),xs(i),xu(i),xv(i),xz(i),xtts(i), + & xzts(i)) + +! if (lprnt .and. i == ipr) print *,' beg xz3=',xz(i),' z_w_max=' +! &,z_w_max + endif + +! apply fca + if ( d_conv(i) > 0.0 ) then + call dtm_1p_fca(d_conv(i),xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset + & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + +! if (lprnt .and. i == ipr) print *,' beg xz4=',xz(i) + +! apply tla + dz = min(xz(i),max(d_conv(i),delz)) +! + call sw_ps_9b(delz,fw) + q_warm = fw*nswsfc(i)-f_nsol !total heat absorbed in warm layer + if ( q_warm > 0.0 ) then + call cal_ttop(kdt,timestep,q_warm,rho_w,dz, + & xt(i),xz(i),ttop0) + +! if (lprnt .and. i == ipr) print *,' d_conv=',d_conv(i),' delz=', +! &delz,' kdt=',kdt,' timestep=',timestep,' nswsfc=',nswsfc(i), +! &' f_nsol=',f_nsol,' rho_w=',rho_w,' dz=',dz,' xt=',xt(i), +! &' xz=',xz(i),' qrain=',qrain(i) + + ttop = ((xt(i)+xt(i))/xz(i))*(1.0-dz/((xz(i)+xz(i)))) + +! if (lprnt .and. i == ipr) print *,' beg xz4a=',xz(i) +! &,' ttop=',ttop,' ttop0=',ttop0,' xt=',xt(i),' dz=',dz +! &,' xznew=',(xt(i)+sqrt(xt(i)*(xt(i)-dz*ttop0)))/ttop0 + + if ( ttop > ttop0 ) then + call dtm_1p_tla(dz,ttop0,xt(i),xtts(i),xz(i),xzts(i)) + +! if (lprnt .and. i == ipr) print *,' beg xz4b=',xz(i),'z_w_max=', +! &z_w_max + if ( xz(i) >= z_w_max ) then + call dtl_reset + & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + endif ! if ( q_warm > 0.0 ) then + +! if (lprnt .and. i == ipr) print *,' beg xz5=',xz(i) + +! apply mwa + t0 = (xt(i)+xt(i))/xz(i) + if ( t0 > tw_max ) then + call dtm_1p_mwa(xt(i),xtts(i),xz(i),xzts(i)) + if ( xz(i) >= z_w_max ) then + call dtl_reset + & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif + +! if (lprnt .and. i == ipr) print *,' beg xz6=',xz(i) + +! apply mta + sstc = tref(i) + (xt(i)+xt(i))/xz(i) - dt_cool(i) + + if ( sstc > sst_max ) then + dta = sstc - sst_max + call dtm_1p_mta(dta,xt(i),xtts(i),xz(i),xzts(i)) +! write(*,'(a,f3.0,7f8.3)') 'mta, sstc,dta :',islimsk(i), +! & sstc,dta,tref(i),xt(i),xz(i),2.0*xt(i)/xz(i),dt_cool(i) + if ( xz(i) >= z_w_max ) then + call dtl_reset + & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + endif +! + endif ! if ( xt(i) > 0.0 ) then +! reset dtl at midnight and when solar zenith angle > 89.994 degree + if ( abs(soltim) < 2.0*timestep ) then + call dtl_reset + & (xt(i),xs(i),xu(i),xv(i),xz(i),xzts(i),xtts(i)) + endif + + endif ! if (solar_time > solar_time_6am .and. ifd(i) == 0.0 ) then: too late to start the first day + +! if (lprnt .and. i == ipr) print *,' beg xz7=',xz(i) + +! update tsurf (when flag(i) .eqv. .true. ) + call get_dtzm_point(xt(i),xz(i),dt_cool(i),z_c(i), + & zsea1,zsea2,dtz) + tsurf(i) = max(271.2, tref(i) + dtz ) + + if (lprnt .and. i == ipr) print *,' tsurf=',tsurf(i),' tref=', + &tref(i),' xz=',xz(i),' dt_cool=',dt_cool(i) + + if ( xt(i) > 0.0 ) then + call cal_w(kdt,xz(i),xt(i),xzts(i),xtts(i),w_0(i),w_d(i)) + else + w_0(i) = 0.0 + w_d(i) = 0.0 + endif + +! if ( xt(i) > 0.0 ) then +! rig(i) = grav*xz(i)*xz(i)*(alpha*xt(i)-beta*xs(i)) +! & /(2.0*(xu(i)*xu(i)+xv(i)*xv(i))) +! else +! rig(i) = 0.25 +! endif + +! qrain(i) = rig(i) + zm(i) = wind(i) + + endif + enddo + +! restore nst-related prognostic fields for guess run + do i=1, im + if((islimsk(i) == 0) ) then + if(flag_guess(i)) then ! when it is guess of + xt(i) = xt_old(i) + xs(i) = xs_old(i) + xu(i) = xu_old(i) + xv(i) = xv_old(i) + xz(i) = xz_old(i) + zm(i) = zm_old(i) + xtts(i) = xtts_old(i) + xzts(i) = xzts_old(i) + ifd(i) = ifd_old(i) + tskin(i) = tskin_old(i) + dt_cool(i) = dt_cool_old(i) + z_c(i) = z_c_old(i) + else +! +! update tskin when coupled and not guess run +! (all other NSST variables have been updated in this case) +! + if ( nstf_name(1) > 1 ) then + tskin(i) = tsurf(i) + endif ! if ( nstf_name(1) > 1 then + endif ! if(flag_guess(i)) then + endif ! if((islimsk(i).eq. 0.) ) then + enddo + +! if (lprnt .and. i == ipr) print *,' beg xz8=',xz(i) + + if ( nstf_name(1) > 1 ) then +! --- ... latent and sensible heat flux over open water with updated tskin +! for the grids of open water and the iteration is on + do i = 1, im + if ( flag(i) ) then + qss(i) = fpvs( tskin(i) ) + qss(i) = eps*qss(i) / (ps(i) + epsm1*qss(i)) + qsurf(i) = qss(i) + evap(i) = elocp*rch(i) * (qss(i) - q0(i)) + hflx(i) = rch(i) * (tskin(i) - theta1(i)) + endif + enddo + endif ! if ( nstf_name(1) > 1 ) then + +! + do i=1,im + if ( flag(i) ) then + tem = 1.0 / rho_a(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo +! +! if (lprnt) print *,' tskin=',tskin(ipr) + + return + end diff --git a/gsmphys/sfc_ocean.f b/gsmphys/sfc_ocean.f new file mode 100644 index 00000000..6fc68b15 --- /dev/null +++ b/gsmphys/sfc_ocean.f @@ -0,0 +1,147 @@ +!----------------------------------- + subroutine sfc_ocean & +!................................... +! --- inputs: + & ( im, ps, u1, v1, t1, q1, tskin, cm, ch, & + & prsl1, prslki, islimsk, ddvel, flag_iter, & +! --- outputs: + & qsurf, cmm, chh, gflux, evap, hflx, ep & + & ) + +! ===================================================================== ! +! description: ! +! ! +! usage: ! +! ! +! call sfc_ocean ! +! inputs: ! +! ( im, ps, u1, v1, t1, q1, tskin, cm, ch, ! +! prsl1, prslki, islimsk, ddvel, flag_iter, ! +! outputs: ! +! qsurf, cmm, chh, gflux, evap, hflx, ep ) ! +! ! +! ! +! subprograms/functions called: fpvs ! +! ! +! ! +! program history log: ! +! 2005 -- created from the original progtm to account for ! +! ocean only ! +! oct 2006 -- h. wei added cmm and chh to the output ! +! apr 2009 -- y.-t. hou modified to match the modified gbphys.f ! +! reformatted the code and added program documentation ! +! sep 2009 -- s. moorthi removed rcl and made pa as pressure unit ! +! and furthur reformatted the code ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! im - integer, horizontal dimension 1 ! +! ps - real, surface pressure im ! +! u1, v1 - real, u/v component of surface layer wind im ! +! t1 - real, surface layer mean temperature ( k ) im ! +! q1 - real, surface layer mean specific humidity im ! +! tskin - real, ground surface skin temperature ( k ) im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, surface layer mean pressure im ! +! prslki - real, im ! +! islimsk - integer, sea/land/ice mask (=0/1/2) im ! +! ddvel - real, wind enhancement due to convection (m/s) im ! +! flag_iter- logical, im ! +! ! +! outputs: ! +! qsurf - real, specific humidity at sfc im ! +! cmm - real, im ! +! chh - real, im ! +! gflux - real, ground heat flux (zero for ocean) im ! +! evap - real, evaporation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ep - real, potential evaporation im ! +! ! +! ===================================================================== ! +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, only : cp => con_cp, rd => con_rd, eps => con_eps, & + & epsm1 => con_epsm1, hvap => con_hvap, & + & rvrdm1 => con_fvirt +! + implicit none +! +! --- constant parameters: + real (kind=kind_phys), parameter :: cpinv = 1.0/cp & + &, hvapi = 1.0/hvap & + &, elocp = hvap/cp + +! --- inputs: + integer, intent(in) :: im + + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, tskin, cm, ch, prsl1, prslki, ddvel + integer, dimension(im), intent(in):: islimsk + + logical, intent(in) :: flag_iter(im) + +! --- outputs: + real (kind=kind_phys), dimension(im), intent(out) :: qsurf, & + & cmm, chh, gflux, evap, hflx, ep + +! --- locals: + + real (kind=kind_phys) :: q0, qss, rch, rho, wind, tem + + integer :: i + + logical :: flag(im) +! +!===> ... begin here +! +! --- ... flag for open water + do i = 1, im + flag(i) = ( islimsk(i) == 0 .and. flag_iter(i) ) + +! --- ... initialize variables. all units are supposedly m.k.s. unless specified +! ps is in pascals, wind is wind speed, +! rho is density, qss is sat. hum. at surface + + if ( flag(i) ) then + + wind = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + & + max( 0.0, min( ddvel(i), 30.0 ) ), 1.0) + + q0 = max( q1(i), 1.0e-8 ) + rho = prsl1(i) / (rd*t1(i)*(1.0 + rvrdm1*q0)) + + qss = fpvs( tskin(i) ) + qss = eps*qss / (ps(i) + epsm1*qss) + + evap(i) = 0.0 + hflx(i) = 0.0 + ep(i) = 0.0 + gflux(i) = 0.0 + +! --- ... rcp = rho cp ch v + + rch = rho * cp * ch(i) * wind + cmm(i) = cm(i) * wind + chh(i) = rho * ch(i) * wind + +! --- ... sensible and latent heat flux over open water + + hflx(i) = rch * (tskin(i) - t1(i) * prslki(i)) + + evap(i) = elocp*rch * (qss - q0) + qsurf(i) = qss + + tem = 1.0 / rho + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo +! + return +!................................... + end subroutine sfc_ocean +!----------------------------------- diff --git a/gsmphys/sfc_sice.f b/gsmphys/sfc_sice.f new file mode 100644 index 00000000..43dc075b --- /dev/null +++ b/gsmphys/sfc_sice.f @@ -0,0 +1,652 @@ +!----------------------------------- + subroutine sfc_sice & +!................................... +! --- inputs: + & ( im, km, ps, u1, v1, t1, q1, delt, & + & sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, & + & cm, ch, prsl1, prslki, islimsk, ddvel, & + & flag_iter, mom4ice, lsm, lprnt,ipr, & +! --- input/outputs: + & hice, fice, tice, weasd, tskin, tprcp, stc, ep, & +! --- outputs: + & snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx & + & ) + +! ===================================================================== ! +! description: ! +! ! +! usage: ! +! ! +! call sfc_sice ! +! inputs: ! +! ( im, km, ps, u1, v1, t1, q1, delt, ! +! sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, ! +! cm, ch, prsl1, prslki, islimsk, ddvel, ! +! flag_iter, mom4ice, lsm, ! +! input/outputs: ! +! hice, fice, tice, weasd, tskin, tprcp, stc, ep, ! +! outputs: ! +! snwdph, qsurf, snowmt, gflux, cmm, chh, evap, hflx ) ! +! ! +! subprogram called: ice3lay. ! +! ! +! program history log: ! +! 2005 -- xingren wu created from original progtm and added ! +! two-layer ice model ! +! 200x -- sarah lu added flag_iter ! +! oct 2006 -- h. wei added cmm and chh to output ! +! 2007 -- x. wu modified for mom4 coupling (i.e. mom4ice) ! +! 2007 -- s. moorthi micellaneous changes ! +! may 2009 -- y.-t. hou modified to include surface emissivity ! +! effect on lw radiation. replaced the confusing ! +! slrad with sfc net sw sfcnsw (dn-up). reformatted ! +! the code and add program documentation block. ! +! sep 2009 -- s. moorthi removed rcl, changed pressure units and ! +! further optimized ! +! jan 2015 -- x. wu change "cimin = 0.15" for both ! +! uncoupled and coupled case ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! im, km - integer, horiz dimension and num of soil layers 1 ! +! ps - real, surface pressure im ! +! u1, v1 - real, u/v component of surface layer wind im ! +! t1 - real, surface layer mean temperature ( k ) im ! +! q1 - real, surface layer mean specific humidity im ! +! delt - real, time interval (second) 1 ! +! sfcemis - real, sfc lw emissivity ( fraction ) im ! +! dlwflx - real, total sky sfc downward lw flux ( w/m**2 ) im ! +! sfcnsw - real, total sky sfc netsw flx into ground(w/m**2) im ! +! sfcdsw - real, total sky sfc downward sw flux ( w/m**2 ) im ! +! srflag - real, snow/rain flag for precipitation im ! +! cm - real, surface exchange coeff for momentum (m/s) im ! +! ch - real, surface exchange coeff heat & moisture(m/s) im ! +! prsl1 - real, surface layer mean pressure im ! +! prslki - real, im ! +! islimsk - integer, sea/land/ice mask (=0/1/2) im ! +! ddvel - real, im ! +! flag_iter- logical, im ! +! mom4ice - logical, im ! +! lsm - integer, flag for land surface model scheme 1 ! +! =0: use osu scheme; =1: use noah scheme ! +! ! +! input/outputs: ! +! hice - real, sea-ice thickness im ! +! fice - real, sea-ice concentration im ! +! tice - real, sea-ice surface temperature im ! +! weasd - real, water equivalent accumulated snow depth (mm)im ! +! tskin - real, ground surface skin temperature ( k ) im ! +! tprcp - real, total precipitation im ! +! stc - real, soil temp (k) im,km ! +! ep - real, potential evaporation im ! +! ! +! outputs: ! +! snwdph - real, water equivalent snow depth (mm) im ! +! qsurf - real, specific humidity at sfc im ! +! snowmt - real, snow melt (m) im ! +! gflux - real, soil heat flux (w/m**2) im ! +! cmm - real, im ! +! chh - real, im ! +! evap - real, evaperation from latent heat flux im ! +! hflx - real, sensible heat flux im ! +! ! +! ===================================================================== ! +! + use machine , only : kind_phys + use funcphys, only : fpvs + use physcons, only : sbc => con_sbc, hvap => con_hvap, & + & tgice => con_tice, cp => con_cp, & + & eps => con_eps, epsm1 => con_epsm1, & + & grav => con_g, rvrdm1 => con_fvirt, & + & t0c => con_t0c, rd => con_rd +! + implicit none +! +! --- constant parameters: + integer, parameter :: kmi = 2 ! 2-layer of ice + real(kind=kind_phys), parameter :: cpinv = 1.0/cp + real(kind=kind_phys), parameter :: hvapi = 1.0/hvap + real(kind=kind_phys), parameter :: elocp = hvap/cp + real(kind=kind_phys), parameter :: himax = 8.0 ! maximum ice thickness allowed + real(kind=kind_phys), parameter :: himin = 0.1 ! minimum ice thickness required + real(kind=kind_phys), parameter :: hsmax = 2.0 ! maximum snow depth allowed + real(kind=kind_phys), parameter :: timin = 173.0 ! minimum temperature allowed for snow/ice + real(kind=kind_phys), parameter :: albfw = 0.06 ! albedo for lead + real(kind=kind_phys), parameter :: dsi = 1.0/0.33 + +! --- inputs: + integer, intent(in) :: im, km, lsm, ipr + logical, intent(in) :: lprnt + + real (kind=kind_phys), dimension(im), intent(in) :: ps, u1, v1, & + & t1, q1, sfcemis, dlwflx, sfcnsw, sfcdsw, srflag, cm, ch, & + & prsl1, prslki, ddvel + + integer, dimension(im), intent(in) :: islimsk + real (kind=kind_phys), intent(in) :: delt + + logical, intent(in) :: flag_iter(im), mom4ice + +! --- input/outputs: + real (kind=kind_phys), dimension(im), intent(inout) :: hice, & + & fice, tice, weasd, tskin, tprcp, ep + + real (kind=kind_phys), dimension(im,km), intent(inout) :: stc + +! --- outputs: + real (kind=kind_phys), dimension(im), intent(out) :: snwdph, & + & qsurf, snowmt, gflux, cmm, chh, evap, hflx + +! --- locals: + real (kind=kind_phys), dimension(im) :: ffw, evapi, evapw, & + & sneti, snetw, hfd, hfi, & +! & hflxi, hflxw, sneti, snetw, qssi, qssw, hfd, hfi, hfw, & + & focn, snof, hi_save, hs_save, rch, rho, & + & snowd, theta1 + + real (kind=kind_phys) :: t12, t14, tem, stsice(im,kmi) + &, hflxi, hflxw, q0, qs1, wind, qssi, qssw + real (kind=kind_phys), parameter :: cimin=0.15 ! --- minimum ice concentration + + integer :: i, k + + logical :: flag(im) +! +!===> ... begin here +! +! --- ... set flag for sea-ice + + do i = 1, im + flag(i) = (islimsk(i) >= 2) .and. flag_iter(i) + if (flag_iter(i) .and. islimsk(i) < 2) then + hice(i) = 0.0 + fice(i) = 0.0 + endif + enddo + +! --- ... update sea ice temperature + + do k = 1, kmi + do i = 1, im + if (flag(i)) then + stsice(i,k) = stc(i,k) + endif + enddo + enddo +! + if (mom4ice) then + do i = 1, im + if (flag(i)) then + hi_save(i) = hice(i) + hs_save(i) = weasd(i) * 0.001 + endif + enddo + elseif (lsm > 0) then ! --- ... snow-rain detection + do i = 1, im + if (flag(i)) then + if (srflag(i) == 1.0) then + ep(i) = 0.0 + weasd(i) = weasd(i) + 1.e3*tprcp(i) + tprcp(i) = 0.0 + endif + endif + enddo + endif + +! --- ... initialize variables. all units are supposedly m.k.s. unless specifie +! psurf is in pascals, wind is wind speed, theta1 is adiabatic surface +! temp from level 1, rho is density, qs1 is sat. hum. at level1 and qss +! is sat. hum. at surface +! convert slrad to the civilized unit from langley minute-1 k-4 + + do i = 1, im + if (flag(i)) then +! psurf(i) = 1000.0 * ps(i) +! ps1(i) = 1000.0 * prsl1(i) + +! dlwflx has been given a negative sign for downward longwave +! sfcnsw is the net shortwave flux (direction: dn-up) + + wind = max(sqrt(u1(i)*u1(i) + v1(i)*v1(i)) & + & + max(0.0, min(ddvel(i), 30.0)), 1.0) + + q0 = max(q1(i), 1.0e-8) +! tsurf(i) = tskin(i) + theta1(i) = t1(i) * prslki(i) + rho(i) = prsl1(i) / (rd*t1(i)*(1.0+rvrdm1*q0)) + qs1 = fpvs(t1(i)) + qs1 = max(eps*qs1 / (prsl1(i) + epsm1*qs1), 1.e-8) + q0 = min(qs1, q0) + + ffw(i) = 1.0 - fice(i) + if (fice(i) < cimin) then + print *,'warning: ice fraction is low:', fice(i) + fice(i) = cimin + ffw (i) = 1.0 - fice(i) + tice(i) = tgice + tskin(i)= tgice + print *,'fix ice fraction: reset it to:', fice(i) + endif + + qssi = fpvs(tice(i)) + qssi = eps*qssi / (ps(i) + epsm1*qssi) + qssw = fpvs(tgice) + qssw = eps*qssw / (ps(i) + epsm1*qssw) + +! --- ... snow depth in water equivalent is converted from mm to m unit + + if (mom4ice) then + snowd(i) = weasd(i) * 0.001 / fice(i) + else + snowd(i) = weasd(i) * 0.001 + endif +! flagsnw(i) = .false. + +! --- ... when snow depth is less than 1 mm, a patchy snow is assumed and +! soil is allowed to interact with the atmosphere. +! we should eventually move to a linear combination of soil and +! snow under the condition of patchy snow. + +! --- ... rcp = rho cp ch v + + cmm(i) = cm(i) * wind + chh(i) = rho(i) * ch(i) * wind + rch(i) = chh(i) * cp + +! --- ... sensible and latent heat flux over open water & sea ice + + evapi(i) = elocp * rch(i) * (qssi - q0) + evapw(i) = elocp * rch(i) * (qssw - q0) +! evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) + +! if (lprnt) write(0,*)' tice=',tice(ipr) + + snetw(i) = sfcdsw(i) * (1.0 - albfw) + snetw(i) = min(3.0*sfcnsw(i)/(1.0+2.0*ffw(i)), snetw(i)) + sneti(i) = (sfcnsw(i) - ffw(i)*snetw(i)) / fice(i) + + t12 = tice(i) * tice(i) + t14 = t12 * t12 + +! --- ... hfi = net non-solar and upir heat flux @ ice surface + + hfi(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapi(i) & + & + rch(i)*(tice(i) - theta1(i)) + hfd(i) = 4.0*sfcemis(i)*sbc*tice(i)*t12 & + & + (1.0 + elocp*eps*hvap*qs1/(rd*t12)) * rch(i) + + t12 = tgice * tgice + t14 = t12 * t12 + +! --- ... hfw = net heat flux @ water surface (within ice) + +! hfw(i) = -dlwflx(i) + sfcemis(i)*sbc*t14 + evapw(i) & +! & + rch(i)*(tgice - theta1(i)) - snetw(i) + + focn(i) = 2.0 ! heat flux from ocean - should be from ocn model + snof(i) = 0.0 ! snowfall rate - snow accumulates in gbphys + + hice(i) = max( min( hice(i), himax ), himin ) + snowd(i) = min( snowd(i), hsmax ) + + if (snowd(i) > (2.0*hice(i))) then + print *, 'warning: too much snow :',snowd(i) + snowd(i) = hice(i) + hice(i) + print *,'fix: decrease snow depth to:',snowd(i) + endif + endif + enddo + +! if (lprnt) write(0,*)' tice2=',tice(ipr) + call ice3lay +! --- inputs: ! +! & ( im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, ! +! --- outputs: ! +! & snowd, hice, stsice, tice, snof, snowmt, gflux ) ! + +! if (lprnt) write(0,*)' tice3=',tice(ipr) + if (mom4ice) then + do i = 1, im + if (flag(i)) then + hice(i) = hi_save(i) + snowd(i) = hs_save(i) + endif + enddo + endif + + do i = 1, im + if (flag(i)) then + if (tice(i) < timin) then + print *,'warning: snow/ice temperature is too low:',tice(i) + &,' i=',i + tice(i) = timin + print *,'fix snow/ice temperature: reset it to:',tice(i) + endif + + if (stsice(i,1) < timin) then + print *,'warning: layer 1 ice temp is too low:',stsice(i,1) + &,' i=',i + stsice(i,1) = timin + print *,'fix layer 1 ice temp: reset it to:',stsice(i,1) + endif + + if (stsice(i,2) < timin) then + print *,'warning: layer 2 ice temp is too low:',stsice(i,2) + stsice(i,2) = timin + print *,'fix layer 2 ice temp: reset it to:',stsice(i,2) + endif + + tskin(i) = tice(i)*fice(i) + tgice*ffw(i) + endif + enddo + + do k = 1, kmi + do i = 1, im + if (flag(i)) then + stc(i,k) = min(stsice(i,k), t0c) + endif + enddo + enddo + + do i = 1, im + if (flag(i)) then +! --- ... calculate sensible heat flux (& evap over sea ice) + + hflxi = rch(i) * (tice(i) - theta1(i)) + hflxw = rch(i) * (tgice - theta1(i)) + hflx(i) = fice(i)*hflxi + ffw(i)*hflxw + evap(i) = fice(i)*evapi(i) + ffw(i)*evapw(i) +! +! --- ... the rest of the output + + qsurf(i) = q1(i) + evap(i) / (elocp*rch(i)) + +! --- ... convert snow depth back to mm of water equivalent + + weasd(i) = snowd(i) * 1000.0 + snwdph(i) = weasd(i) * dsi ! snow depth in mm + + tem = 1.0 / rho(i) + hflx(i) = hflx(i) * tem * cpinv + evap(i) = evap(i) * tem * hvapi + endif + enddo +! + return + +! ================= + contains +! ================= + + +!----------------------------------- + subroutine ice3lay +!................................... +! --- inputs: +! & ( im, kmi, fice, flag, hfi, hfd, sneti, focn, delt, & +! --- input/outputs: +! & snowd, hice, stsice, tice, snof, & +! --- outputs: +! & snowmt, gflux & +! & ) + +!************************************************************************** +! * +! three-layer sea ice vertical thermodynamics * +! * +! based on: m. winton, "a reformulated three-layer sea ice model", * +! journal of atmospheric and oceanic technology, 2000 * +! * +! * +! -> +---------+ <- tice - diagnostic surface temperature ( <= 0c )* +! / | | * +! snowd | snow | <- 0-heat capacity snow layer * +! \ | | * +! => +---------+ * +! / | | * +! / | | <- t1 - upper 1/2 ice temperature; this layer has * +! / | | a variable (t/s dependent) heat capacity * +! hice |...ice...| * +! \ | | * +! \ | | <- t2 - lower 1/2 ice temp. (fixed heat capacity) * +! \ | | * +! -> +---------+ <- base of ice fixed at seawater freezing temp. * +! * +! ===================== defination of variables ===================== ! +! ! +! inputs: size ! +! im, kmi - integer, horiz dimension and num of ice layers 1 ! +! fice - real, sea-ice concentration im ! +! flag - logical, ice mask flag 1 ! +! hfi - real, net non-solar and heat flux @ surface(w/m^2) im ! +! hfd - real, heat flux derivatice @ sfc (w/m^2/deg-c) im ! +! sneti - real, net solar incoming at top (w/m^2) im ! +! focn - real, heat flux from ocean (w/m^2) im ! +! delt - real, timestep (sec) 1 ! +! ! +! input/outputs: ! +! snowd - real, surface pressure im ! +! hice - real, sea-ice thickness im ! +! stsice - real, temp @ midpt of ice levels (deg c) im,kmi! +! tice - real, surface temperature (deg c) im ! +! snof - real, snowfall rate (m/sec) im ! +! ! +! outputs: ! +! snowmt - real, snow melt during delt (m) im ! +! gflux - real, conductive heat flux (w/m^2) im ! +! ! +! locals: ! +! hdi - real, ice-water interface (m) ! +! hsni - real, snow-ice (m) ! +! ! +! ======================================================================= ! +! + +! --- constant parameters: (properties of ice, snow, and seawater) + real (kind=kind_phys), parameter :: ds = 330.0 ! snow (ov sea ice) density (kg/m^3) + real (kind=kind_phys), parameter :: dw =1000.0 ! fresh water density (kg/m^3) + real (kind=kind_phys), parameter :: dsdw = ds/dw + real (kind=kind_phys), parameter :: dwds = dw/ds + real (kind=kind_phys), parameter :: t0c =273.15 ! freezing temp of fresh ice (k) + real (kind=kind_phys), parameter :: ks = 0.31 ! conductivity of snow (w/mk) + real (kind=kind_phys), parameter :: i0 = 0.3 ! ice surface penetrating solar fraction + real (kind=kind_phys), parameter :: ki = 2.03 ! conductivity of ice (w/mk) + real (kind=kind_phys), parameter :: di = 917.0 ! density of ice (kg/m^3) + real (kind=kind_phys), parameter :: didw = di/dw + real (kind=kind_phys), parameter :: dsdi = ds/di + real (kind=kind_phys), parameter :: ci = 2054.0 ! heat capacity of fresh ice (j/kg/k) + real (kind=kind_phys), parameter :: li = 3.34e5 ! latent heat of fusion (j/kg-ice) + real (kind=kind_phys), parameter :: si = 1.0 ! salinity of sea ice + real (kind=kind_phys), parameter :: mu = 0.054 ! relates freezing temp to salinity + real (kind=kind_phys), parameter :: tfi = -mu*si ! sea ice freezing temp = -mu*salinity + real (kind=kind_phys), parameter :: tfw = -1.8 ! tfw - seawater freezing temp (c) + real (kind=kind_phys), parameter :: tfi0 = tfi-0.0001 + real (kind=kind_phys), parameter :: dici = di*ci + real (kind=kind_phys), parameter :: dili = di*li + real (kind=kind_phys), parameter :: dsli = ds*li + real (kind=kind_phys), parameter :: ki4 = ki*4.0 + +! --- inputs: +! integer, intent(in) :: im, kmi + +! real (kind=kind_phys), dimension(im), intent(in) :: fice, hfi, & +! & hfd, sneti, focn + +! real (kind=kind_phys), intent(in) :: delt + +! logical, dimension(im), intent(in) :: flag + +! --- input/outputs: +! real (kind=kind_phys), dimension(im), intent(inout) :: snowd, & +! & hice, tice, snof + +! real (kind=kind_phys), dimension(im,kmi), intent(inout) :: stsice + +! --- outputs: +! real (kind=kind_phys), dimension(im), intent(out) :: snowmt, & +! & gflux + +! --- locals: + + real (kind=kind_phys) :: dt2, dt4, dt6, h1, h2, dh, wrk, wrk1, & + & dt2i, hdi, hsni, ai, bi, a1, b1, a10, b10& + &, c1, ip, k12, k32, tsf, f1, tmelt, bmelt + + integer :: i +! +!===> ... begin here +! + dt2 = 2.0 * delt + dt4 = 4.0 * delt + dt6 = 6.0 * delt + dt2i = 1.0 / dt2 + + do i = 1, im + if (flag(i)) then + snowd(i) = snowd(i) * dwds + hdi = (dsdw*snowd(i) + didw*hice(i)) + + if (hice(i) < hdi) then + snowd(i) = snowd(i) + hice(i) - hdi + hsni = (hdi - hice(i)) * dsdi + hice (i) = hice(i) + hsni + endif + + snof(i) = snof(i) * dwds + tice(i) = tice(i) - t0c + stsice(i,1) = min(stsice(i,1)-t0c, tfi0) ! degc + stsice(i,2) = min(stsice(i,2)-t0c, tfi0) ! degc + + ip = i0 * sneti(i) ! ip +v (in winton ip=-i0*sneti as sol -v) + if (snowd(i) > 0.0) then + tsf = 0.0 + ip = 0.0 + else + tsf = tfi + ip = i0 * sneti(i) ! ip +v here (in winton ip=-i0*sneti) + endif + tice(i) = min(tice(i), tsf) + +! --- ... compute ice temperature + + bi = hfd(i) + ai = hfi(i) - sneti(i) + ip - tice(i)*bi ! +v sol input here + k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) + k32 = (ki+ki) / hice(i) + + wrk = 1.0 / (dt6*k32 + dici*hice(i)) + a10 = dici*hice(i)*dt2i + k32*(dt4*k32 + dici*hice(i))*wrk + b10 = -di*hice(i) * (ci*stsice(i,1) + li*tfi/stsice(i,1)) & + & * dt2i - ip & + & - k32*(dt4*k32*tfw + dici*hice(i)*stsice(i,2)) * wrk + + wrk1 = k12 / (k12 + bi) + a1 = a10 + bi * wrk1 + b1 = b10 + ai * wrk1 + c1 = dili * tfi * dt2i * hice(i) + + stsice(i,1) = -(sqrt(b1*b1 - 4.0*a1*c1) + b1)/(a1+a1) + tice(i) = (k12*stsice(i,1) - ai) / (k12 + bi) + + if (tice(i) > tsf) then + a1 = a10 + k12 + b1 = b10 - k12*tsf + stsice(i,1) = -(sqrt(b1*b1 - 4.0*a1*c1) + b1)/(a1+a1) + tice(i) = tsf + tmelt = (k12*(stsice(i,1)-tsf) - (ai+bi*tsf)) * delt + else + tmelt = 0.0 + snowd(i) = snowd(i) + snof(i)*delt + endif + + stsice(i,2) = (dt2*k32*(stsice(i,1) + tfw + tfw) & + & + dici*hice(i)*stsice(i,2)) * wrk + + bmelt = (focn(i) + ki4*(stsice(i,2) - tfw)/hice(i)) * delt + +! --- ... resize the ice ... + + h1 = 0.5 * hice(i) + h2 = 0.5 * hice(i) + +! --- ... top ... + + if (tmelt <= snowd(i)*dsli) then + snowmt(i) = tmelt / dsli + snowd (i) = snowd(i) - snowmt(i) + else + snowmt(i) = snowd(i) + h1 = h1 - (tmelt - snowd(i)*dsli) & + & / (di * (ci - li/stsice(i,1)) * (tfi - stsice(i,1))) + snowd(i) = 0.0 + endif + +! --- ... and bottom + + if (bmelt < 0.0) then + dh = -bmelt / (dili + dici*(tfi - tfw)) + stsice(i,2) = (h2*stsice(i,2) + dh*tfw) / (h2 + dh) + h2 = h2 + dh + else + h2 = h2 - bmelt / (dili + dici*(tfi - stsice(i,2))) + endif + +! --- ... if ice remains, even up 2 layers, else, pass negative energy back in snow + + hice(i) = h1 + h2 + + if (hice(i) > 0.0) then + if (h1 > 0.5*hice(i)) then + f1 = 1.0 - (h2+h2) / hice(i) + stsice(i,2) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& + & + (1.0 - f1)*stsice(i,2) + + if (stsice(i,2) > tfi) then + hice(i) = hice(i) - h2*ci*(stsice(i,2) - tfi)/ (li*delt) + stsice(i,2) = tfi + endif + else + f1 = (h1+h1) / hice(i) + stsice(i,1) = f1 * (stsice(i,1) + li*tfi/(ci*stsice(i,1)))& + & + (1.0 - f1)*stsice(i,2) + stsice(i,1) = (stsice(i,1) - sqrt(stsice(i,1)*stsice(i,1) & + & - 4.0*tfi*li/ci)) * 0.5 + endif + + k12 = ki4*ks / (ks*hice(i) + ki4*snowd(i)) + gflux(i) = k12 * (stsice(i,1) - tice(i)) + else + snowd(i) = snowd(i) + (h1*(ci*(stsice(i,1) - tfi) & + & - li*(1.0 - tfi/stsice(i,1))) & + & + h2*(ci*(stsice(i,2) - tfi) - li)) / li + + hice(i) = max(0.0, snowd(i)*dsdi) + snowd(i) = 0.0 + stsice(i,1) = tfw + stsice(i,2) = tfw + gflux(i) = 0.0 + endif ! end if_hice_block + + gflux(i) = fice(i) * gflux(i) + snowmt(i) = snowmt(i) * dsdw + snowd(i) = snowd(i) * dsdw + tice(i) = tice(i) + t0c + stsice(i,1) = stsice(i,1) + t0c + stsice(i,2) = stsice(i,2) + t0c + endif ! end if_flag_block + enddo ! end do_i_loop + + return +!................................... + end subroutine ice3lay +!----------------------------------- + +! =========================== ! +! end contain programs ! +! =========================== ! + +!................................... + end subroutine sfc_sice +!----------------------------------- diff --git a/gsmphys/sfcsub.F b/gsmphys/sfcsub.F new file mode 100644 index 00000000..c6a585fa --- /dev/null +++ b/gsmphys/sfcsub.F @@ -0,0 +1,8705 @@ + module sfccyc_module + implicit none + save +! +! grib code for each parameter - used in subroutines sfccycle and setrmsk. +! + integer kpdtsf,kpdwet,kpdsno,kpdzor,kpdais,kpdtg3,kpdplr,kpdgla, + & kpdmxi,kpdscv,kpdsmc,kpdoro,kpdmsk,kpdstc,kpdacn,kpdveg, + & kpdvet,kpdsot,kpdmld, kpdqflux + &, kpdvmn,kpdvmx,kpdslp,kpdabs + &, kpdsnd, kpdabs_0, kpdabs_1, kpdalb(4) + parameter(kpdtsf=11, kpdwet=86, kpdsno=65, kpdzor=83, +! 1 kpdalb=84, kpdais=91, kpdtg3=11, kpdplr=224, + 1 kpdais=91, kpdtg3=11, kpdplr=224, + 2 kpdgla=238, kpdmxi=91, kpdscv=238, kpdsmc=144, + 3 kpdoro=8, kpdmsk=81, kpdstc=11, kpdacn=91, kpdveg=87, +!cbosu max snow albedo uses a grib id number of 159, not 255. + & kpdvmn=255, kpdvmx=255,kpdslp=236, kpdabs_0=255, + & kpdvet=225, kpdsot=224,kpdmld=11, kpdabs_1=159, + & kpdsnd=66 , kpdqflux=11) +! + integer, parameter :: kpdalb_0(4)=(/212,215,213,216/) + integer, parameter :: kpdalb_1(4)=(/189,190,191,192/) + integer, parameter :: kpdalf(2)=(/214,217/) +! + integer, parameter :: xdata=5000, ydata=2500, mdata=xdata*ydata + integer :: veg_type_landice + integer :: soil_type_landice + logical, parameter :: print_debug = .false. +! + end module sfccyc_module + subroutine sfccycle(lugb,len,lsoil,sig1t,deltsfc + &, iy,im,id,ih,fh + &, rla, rlo, slmask,orog,orog_uf,use_ufo,nst_anl + &, sihfcs,sicfcs,sitfcs + &, swdfcs,slcfcs + &, vmnfcs,vmxfcs,slpfcs,absfcs + &, tsffcs,tsfclm, snofcs,zorfcs,albfcs + &, mldclm,qfluxadj + &, tg3fcs,cnpfcs,smcfcs,stcfcs,slifcs,aisfcs,f10m + &, vegfcs,vetfcs,sotfcs,alffcs + &, cvfcs,cvbfcs,cvtfcs,me,nlunit + &, sz_nml,input_nml_file + &, ialb,isot,ivegsrc,tile_num_ch,i_index,j_index) +! + use machine , only : kind_io8,kind_io4 + use sfccyc_module + implicit none + character(len=*), intent(in) :: tile_num_ch + integer,intent(in) :: i_index(len), j_index(len) + logical use_ufo, nst_anl + real (kind=kind_io8) sllnd,slsea,aicice,aicsea,tgice,rlapse, + & orolmx,orolmn,oroomx,oroomn,orosmx, + & orosmn,oroimx,oroimn,orojmx,orojmn, + & alblmx,alblmn,albomx,albomn,albsmx, + & albsmn,albimx,albimn,albjmx,albjmn, + & wetlmx,wetlmn,wetomx,wetomn,wetsmx, + & wetsmn,wetimx,wetimn,wetjmx,wetjmn, + & snolmx,snolmn,snoomx,snoomn,snosmx, + & snosmn,snoimx,snoimn,snojmx,snojmn, + & zorlmx,zorlmn,zoromx,zoromn,zorsmx, + & zorsmn,zorimx,zorimn,zorjmx, zorjmn, + & plrlmx,plrlmn,plromx,plromn,plrsmx, + & plrsmn,plrimx,plrimn,plrjmx,plrjmn, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfsmx, + & tsfsmn,tsfimx,tsfimn,tsfjmx,tsfjmn, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3smx, + & tg3smn,tg3imx,tg3imn,tg3jmx,tg3jmn, + & stclmx,stclmn,stcomx,stcomn,stcsmx, + & stcsmn,stcimx,stcimn,stcjmx,stcjmn, + & smclmx,smclmn,smcomx,smcomn,smcsmx, + & smcsmn,smcimx,smcimn,smcjmx,smcjmn, + & scvlmx,scvlmn,scvomx,scvomn,scvsmx, + & scvsmn,scvimx,scvimn,scvjmx,scvjmn, + & veglmx,veglmn,vegomx,vegomn,vegsmx, + & vegsmn,vegimx,vegimn,vegjmx,vegjmn, + & vetlmx,vetlmn,vetomx,vetomn,vetsmx, + & vetsmn,vetimx,vetimn,vetjmx,vetjmn, + & sotlmx,sotlmn,sotomx,sotomn,sotsmx, + & sotsmn,sotimx,sotimn,sotjmx,sotjmn, + & alslmx,alslmn,alsomx,alsomn,alssmx, + & alssmn,alsimx,alsimn,alsjmx,alsjmn, + & epstsf,epsalb,epssno,epswet,epszor, + & epsplr,epsoro,epssmc,epsscv,eptsfc, + & epstg3,epsais,epsacn,epsveg,epsvet, + & epssot,epsalf,qctsfs,qcsnos,qctsfi, + & aislim,snwmin,snwmax,cplrl,cplrs, + & cvegl,czors,csnol,csnos,czorl,csots, + & csotl,cvwgs,cvetl,cvets,calfs, + & fcalfl,fcalfs,ccvt,ccnp,ccv,ccvb, + & calbl,calfl,calbs,ctsfs,grboro, + & grbmsk,ctsfl,deltf,caisl,caiss, + & fsalfl,fsalfs,flalfs,falbl,ftsfl, + & ftsfs,fzorl,fzors,fplrl,fsnos,faisl, + & faiss,fsnol,bltmsk,falbs,cvegs,percrit, + & deltsfc,critp2,critp3,blnmsk,critp1, + & fcplrl,fcplrs,fczors,fvets,fsotl,fsots, + & fvetl,fplrs,fvegl,fvegs,fcsnol,fcsnos, + & fczorl,fcalbs,fctsfl,fctsfs,fcalbl, + & falfs,falfl,fh,crit,zsca,ztsfc,tem1,tem2 + &, fsihl,fsihs,fsicl,fsics, + & csihl,csihs,csicl,csics,epssih,epssic + &, fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss,cvmnl,cvmns,cvmxl,cvmxs, + & cslpl,cslps,cabsl,cabss,epsvmn,epsvmx, + & epsslp,epsabs + &, sihlmx,sihlmn,sihomx,sihomn,sihsmx, + & sihsmn,sihimx,sihimn,sihjmx,sihjmn, + & siclmx,siclmn,sicomx,sicomn,sicsmx, + & sicsmn,sicimx,sicimn,sicjmx,sicjmn + &, glacir_hice + &, vmnlmx,vmnlmn,vmnomx,vmnomn,vmnsmx, + & vmnsmn,vmnimx,vmnimn,vmnjmx,vmnjmn, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmxsmx, + & vmxsmn,vmximx,vmximn,vmxjmx,vmxjmn, + & slplmx,slplmn,slpomx,slpomn,slpsmx, + & slpsmn,slpimx,slpimn,slpjmx,slpjmn, + & abslmx,abslmn,absomx,absomn,abssmx, + & abssmn,absimx,absimn,absjmx,absjmn + &, sihnew + + integer imsk,jmsk,ifp,irtscv,irtacn,irtais,irtsno,irtzor, + & irtalb,irtsot,irtalf,j,irtvet,irtsmc,irtstc,irtveg, + & irtwet,k,iprnt,kk,irttsf,iret,i,igrdbg,iy,im,id, + & icalbl,icalbs,icalfl,ictsfs,lugb,len,lsoil,ih, + & ictsfl,iczors,icplrl,icplrs,iczorl,icalfs,icsnol, + & icsnos,irttg3,me,kqcm,nlunit,sz_nml,ialb + &, irtvmn, irtvmx, irtslp, irtabs, isot, ivegsrc + logical gausm, deads, qcmsk, znlst, monclm, monanl, + & monfcs, monmer, mondif, landice + character(len=*), intent(in) :: input_nml_file(sz_nml) + + integer num_parthds +! +! this is a limited point version of surface program. +! +! this program runs in two different modes: +! +! 1. analysis mode (fh=0.) +! +! this program merges climatology, analysis and forecast guess to create +! new surface fields. if analysis file is given, the program +! uses it if date of the analysis matches with iy,im,id,ih (see note +! below). +! +! 2. forecast mode (fh.gt.0.) +! +! this program interpolates climatology to the date corresponding to the +! forecast hour. if surface analysis file is given, for the corresponding +! dates, the program will use it. +! +! note: +! +! if the date of the analysis does not match given iy,im,id,ih, (and fh), +! the program searches an old analysis by going back 6 hours, then 12 hours, +! then one day upto nrepmx days (parameter statement in the subrotine fixrd. +! now defined as 8). this allows the user to provide non-daily analysis to +! be used. if matching field is not found, the forecast guess will be used. +! +! use of a combined earlier surface analyses and current analysis is +! not allowed (as was done in the old version for snow analysis in which +! old snow analysis is used in combination with initial guess), except +! for sea surface temperature. for sst anolmaly interpolation, you need to +! set lanom=.true. and must provide sst analysis at initial time. +! +! if you want to do complex merging of past and present surface field analysis, +! you need to create a separate file that contains daily surface field. +! +! for a dead start, do not supply fnbgsi or set fnbgsi=' ' +! +! lugb is the unit number used in this subprogram +! len ... number of points on which sfccyc operates +! lsoil .. number of soil layers (2 as of april, 1994) +! iy,im,id,ih .. year, month, day, and hour of initial state. +! fh .. forecast hour +! rla, rlo -- latitude and longitudes of the len points +! sig1t .. sigma level 1 temperature for dead start. should be on gaussian +! grid. if not dead start, no need for dimension but set to zero +! as in the example below. +! +! variable naming conventions: +! +! oro .. orography +! alb .. albedo +! wet .. soil wetness as defined for bucket model +! sno .. snow depth +! zor .. surface roughness length +! vet .. vegetation type +! plr .. plant evaporation resistance +! tsf .. surface skin temperature. sea surface temp. over ocean. +! tg3 .. deep soil temperature (at 500cm) +! stc .. soil temperature (lsoil layrs) +! smc .. soil moisture (lsoil layrs) +! scv .. snow cover (not snow depth) +! ais .. sea ice mask (0 or 1) +! acn .. sea ice concentration (fraction) +! gla .. glacier (permanent snow) mask (0 or 1) +! mxi .. maximum sea ice extent (0 or 1) +! msk .. land ocean mask (0=ocean 1=land) +! cnp .. canopy water content +! cv .. convective cloud cover +! cvb .. convective cloud base +! cvt .. convective cloud top +! sli .. land/sea/sea-ice mask. (1/0/2 respectively) +! veg .. vegetation cover +! sot .. soil type +!cwu [+2l] add sih & sic +! sih .. sea ice thickness +! sic .. sea ice concentration +!clu [+6l] add swd,slc,vmn,vmx,slp,abs +! swd .. actual snow depth +! slc .. liquid soil moisture (lsoil layers) +! vmn .. vegetation cover minimum +! vmx .. vegetation cover maximum +! slp .. slope type +! abs .. maximum snow albedo + +! +! definition of land/sea mask. sllnd for land and slsea for sea. +! definition of sea/ice mask. aicice for ice, aicsea for sea. +! tgice=max ice temperature +! rlapse=lapse rate for sst correction due to surface angulation +! + parameter(sllnd =1.0,slsea =0.0) + parameter(aicice=1.0,aicsea=0.0) + parameter(tgice=271.2) + parameter(rlapse=0.65e-2) +! +! max/min of fields for check and replace. +! +! ???lmx .. max over bare land +! ???lmn .. min over bare land +! ???omx .. max over open ocean +! ???omn .. min over open ocean +! ???smx .. max over snow surface (land and sea-ice) +! ???smn .. min over snow surface (land and sea-ice) +! ???imx .. max over bare sea ice +! ???imn .. min over bare sea ice +! ???jmx .. max over snow covered sea ice +! ???jmn .. min over snow covered sea ice +! + parameter(orolmx=8000.,orolmn=-1000.,oroomx=3000.,oroomn=-1000., + & orosmx=8000.,orosmn=-1000.,oroimx=3000.,oroimn=-1000., + & orojmx=3000.,orojmn=-1000.) +! parameter(alblmx=0.80,alblmn=0.06,albomx=0.06,albomn=0.06, +! & albsmx=0.80,albsmn=0.06,albimx=0.80,albimn=0.80, +! & albjmx=0.80,albjmn=0.80) +!cwu [-3l/+9l] change min/max for alb; add min/max for sih & sic +! parameter(alblmx=0.80,alblmn=0.01,albomx=0.01,albomn=0.01, +! & albsmx=0.80,albsmn=0.01,albimx=0.01,albimn=0.01, +! & albjmx=0.01,albjmn=0.01) +! note: the range values for bare land and snow covered land +! (alblmx, alblmn, albsmx, albsmn) are set below +! based on whether the old or new radiation is selected + parameter(albomx=0.06,albomn=0.06, + & albimx=0.80,albimn=0.06, + & albjmx=0.80,albjmn=0.06) + parameter(sihlmx=0.0,sihlmn=0.0,sihomx=5.0,sihomn=0.0, + & sihsmx=5.0,sihsmn=0.0,sihimx=5.0,sihimn=0.10, + & sihjmx=5.0,sihjmn=0.10,glacir_hice=3.0) +!cwu change sicimn & sicjmn Jan 2015 +! parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, +! & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.50, +! & sicjmx=1.0,sicjmn=0.50) +! +! parameter(sihlmx=0.0,sihlmn=0.0,sihomx=8.0,sihomn=0.0, +! & sihsmx=8.0,sihsmn=0.0,sihimx=8.0,sihimn=0.10, +! & sihjmx=8.0,sihjmn=0.10,glacir_hice=3.0) + parameter(siclmx=0.0,siclmn=0.0,sicomx=1.0,sicomn=0.0, + & sicsmx=1.0,sicsmn=0.0,sicimx=1.0,sicimn=0.15, + & sicjmx=1.0,sicjmn=0.15) + + parameter(wetlmx=0.15,wetlmn=0.00,wetomx=0.15,wetomn=0.15, + & wetsmx=0.15,wetsmn=0.15,wetimx=0.15,wetimn=0.15, + & wetjmx=0.15,wetjmn=0.15) + parameter(snolmx=0.0,snolmn=0.0,snoomx=0.0,snoomn=0.0, + & snosmx=55000.,snosmn=0.001,snoimx=0.,snoimn=0.0, + & snojmx=10000.,snojmn=0.01) + parameter(zorlmx=300.,zorlmn=1.0,zoromx=1.0,zoromn=1.e-05, + & zorsmx=300.,zorsmn=1.0,zorimx=1.0,zorimn=1.0, + & zorjmx=1.0,zorjmn=1.0) + parameter(plrlmx=1000.,plrlmn=0.0,plromx=1000.0,plromn=0.0, + & plrsmx=1000.,plrsmn=0.0,plrimx=1000.,plrimn=0.0, + & plrjmx=1000.,plrjmn=0.0) +!clu [-1l/+1l] relax tsfsmx (for noah lsm) + parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.2, + & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.2,tsfimn=173.0, + & tsfjmx=273.16,tsfjmn=173.0) +! parameter(tsflmx=353.,tsflmn=173.0,tsfomx=313.0,tsfomn=271.21, +!* & tsfsmx=273.16,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, +! & tsfsmx=305.0,tsfsmn=173.0,tsfimx=271.21,tsfimn=173.0, + parameter(tg3lmx=310.,tg3lmn=200.0,tg3omx=310.0,tg3omn=200.0, + & tg3smx=310.,tg3smn=200.0,tg3imx=310.0,tg3imn=200.0, + & tg3jmx=310.,tg3jmn=200.0) + parameter(stclmx=353.,stclmn=173.0,stcomx=313.0,stcomn=200.0, + & stcsmx=310.,stcsmn=200.0,stcimx=310.0,stcimn=200.0, + & stcjmx=310.,stcjmn=200.0) +!landice mods force a flag value of soil moisture of 1.0 +! at non-land points + parameter(smclmx=0.55,smclmn=0.0,smcomx=1.0,smcomn=1.0, + & smcsmx=0.55,smcsmn=0.0,smcimx=1.0,smcimn=1.0, + & smcjmx=1.0,smcjmn=1.0) + parameter(scvlmx=0.0,scvlmn=0.0,scvomx=0.0,scvomn=0.0, + & scvsmx=1.0,scvsmn=1.0,scvimx=0.0,scvimn=0.0, + & scvjmx=1.0,scvjmn=1.0) + parameter(veglmx=1.0,veglmn=0.0,vegomx=0.0,vegomn=0.0, + & vegsmx=1.0,vegsmn=0.0,vegimx=0.0,vegimn=0.0, + & vegjmx=0.0,vegjmn=0.0) + parameter(vmnlmx=1.0,vmnlmn=0.0,vmnomx=0.0,vmnomn=0.0, + & vmnsmx=1.0,vmnsmn=0.0,vmnimx=0.0,vmnimn=0.0, + & vmnjmx=0.0,vmnjmn=0.0) + parameter(vmxlmx=1.0,vmxlmn=0.0,vmxomx=0.0,vmxomn=0.0, + & vmxsmx=1.0,vmxsmn=0.0,vmximx=0.0,vmximn=0.0, + & vmxjmx=0.0,vmxjmn=0.0) + parameter(slplmx=9.0,slplmn=1.0,slpomx=0.0,slpomn=0.0, + & slpsmx=9.0,slpsmn=1.0,slpimx=0.,slpimn=0., + & slpjmx=0.,slpjmn=0.) +! note: the range values for bare land and snow covered land +! (alblmx, alblmn, albsmx, albsmn) are set below +! based on whether the old or new radiation is selected + parameter(absomx=0.0,absomn=0.0, + & absimx=0.0,absimn=0.0, + & absjmx=0.0,absjmn=0.0) +! vegetation type + parameter(vetlmx=20.,vetlmn=1.0,vetomx=0.0,vetomn=0.0, + & vetsmx=20.,vetsmn=1.0,vetimx=0.,vetimn=0., + & vetjmx=0.,vetjmn=0.) +! soil type + parameter(sotlmx=16.,sotlmn=1.0,sotomx=0.0,sotomn=0.0, + & sotsmx=16.,sotsmn=1.0,sotimx=0.,sotimn=0., + & sotjmx=0.,sotjmn=0.) +! fraction of vegetation for strongly and weakly zeneith angle dependent +! albedo + parameter(alslmx=1.0,alslmn=0.0,alsomx=0.0,alsomn=0.0, + & alssmx=1.0,alssmn=0.0,alsimx=0.0,alsimn=0.0, + & alsjmx=0.0,alsjmn=0.0) +! +! criteria used for monitoring +! + parameter(epstsf=0.01,epsalb=0.001,epssno=0.01, + & epswet=0.01,epszor=0.0000001,epsplr=1.,epsoro=0., + & epssmc=0.0001,epsscv=0.,eptsfc=0.01,epstg3=0.01, + & epsais=0.,epsacn=0.01,epsveg=0.01, + & epssih=0.001,epssic=0.001, + & epsvmn=0.01,epsvmx=0.01,epsabs=0.001,epsslp=0.01, + & epsvet=.01,epssot=.01,epsalf=.001) +! +! quality control of analysis snow and sea ice +! +! qctsfs .. surface temperature above which no snow allowed +! qcsnos .. snow depth above which snow must exist +! qctsfi .. sst above which sea-ice is not allowed +! +!clu relax qctsfs (for noah lsm) +!* parameter(qctsfs=283.16,qcsnos=100.,qctsfi=280.16) +!* parameter(qctsfs=288.16,qcsnos=100.,qctsfi=280.16) + parameter(qctsfs=293.16,qcsnos=100.,qctsfi=280.16) +! +!cwu [-2l] +!* ice concentration for ice limit (55 percent) +! +!* parameter(aislim=0.55) +! +! parameters to obtain snow depth from snow cover and temperature +! +! parameter(snwmin=25.,snwmax=100.) + parameter(snwmin=5.0,snwmax=100.) + real (kind=kind_io8), parameter :: ten=10.0, one=1.0 +! +! coeeficients of blending forecast and interpolated clim +! (or analyzed) fields over sea or land(l) (not for clouds) +! 1.0 = use of forecast +! 0.0 = replace with interpolated analysis +! +! these values are set for analysis mode. +! +! variables land sea +! --------------------------------------------------------- +! surface temperature forecast analysis +! surface temperature forecast forecast (over sea ice) +! albedo analysis analysis +! sea-ice analysis analysis +! snow analysis forecast (over sea ice) +! roughness analysis forecast +! plant resistance analysis analysis +! soil wetness (layer) weighted average analysis +! soil temperature forecast analysis +! canopy waver content forecast forecast +! convective cloud cover forecast forecast +! convective cloud bottm forecast forecast +! convective cloud top forecast forecast +! vegetation cover analysis analysis +! vegetation type analysis analysis +! soil type analysis analysis +! sea-ice thickness forecast forecast +! sea-ice concentration analysis analysis +! vegetation cover min analysis analysis +! vegetation cover max analysis analysis +! max snow albedo analysis analysis +! slope type analysis analysis +! liquid soil wetness analysis-weighted analysis +! actual snow depth analysis-weighted analysis +! +! note: if analysis file is not given, then time interpolated climatology +! is used. if analyiss file is given, it will be used as far as the +! date and time matches. if they do not match, it uses forecast. +! +! critical percentage value for aborting bad points when lgchek=.true. +! + logical lgchek + data lgchek/.true./ + data critp1,critp2,critp3/80.,80.,25./ +! +! integer kpdalb(4), kpdalf(2) +! data kpdalb/212,215,213,216/, kpdalf/214,217/ +! save kpdalb, kpdalf +! +! mask orography and variance on gaussian grid +! + real (kind=kind_io8) slmask(len),orog(len), orog_uf(len) + &, orogd(len) + real (kind=kind_io8) rla(len), rlo(len) +! +! permanent/extremes +! + character*500 fnglac,fnmxic + real (kind=kind_io8), allocatable :: glacir(:),amxice(:),tsfcl0(:) +! +! tsfcl0 is the climatological tsf at fh=0 +! +! climatology surface fields (last character 'c' or 'clm' indicate climatology) +! + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, + & fnvegc,fnvetc,fnsotc + &, fnvmnc,fnvmxc,fnslpc,fnabsc, fnalbc2, fnmldc, + & fnqfluxc + real (kind=kind_io8) tsfclm(len), wetclm(len), snoclm(len), + & zorclm(len), albclm(len,4), aisclm(len), + & tg3clm(len), acnclm(len), cnpclm(len), + & cvclm (len), cvbclm(len), cvtclm(len), + & scvclm(len), tsfcl2(len), vegclm(len), + & vetclm(len), sotclm(len), alfclm(len,2), sliclm(len), + & smcclm(len,lsoil), stcclm(len,lsoil) + &, sihclm(len), sicclm(len) + &, vmnclm(len), vmxclm(len), slpclm(len), absclm(len) + &, mldclm(len), qfluxadj(len) +! +! analyzed surface fields (last character 'a' or 'anl' indicate analysis) +! + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, + & fnvega,fnveta,fnsota + &, fnvmna,fnvmxa,fnslpa,fnabsa +! + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & tg3anl(len), acnanl(len), cnpanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & scvanl(len), tsfan2(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2), slianl(len), + & smcanl(len,lsoil), stcanl(len,lsoil) + &, sihanl(len), sicanl(len) + &, vmnanl(len), vmxanl(len), slpanl(len), absanl(len) +! + real (kind=kind_io8) tsfan0(len) ! sea surface temperature analysis at ft=0. +! +! predicted surface fields (last characters 'fcs' indicates forecast) +! + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), + & zorfcs(len), albfcs(len,4), aisfcs(len), + & tg3fcs(len), acnfcs(len), cnpfcs(len), + & cvfcs (len), cvbfcs(len), cvtfcs(len), + & slifcs(len), vegfcs(len), + & vetfcs(len), sotfcs(len), alffcs(len,2), + & smcfcs(len,lsoil), stcfcs(len,lsoil) + &, sihfcs(len), sicfcs(len), sitfcs(len) + &, vmnfcs(len), vmxfcs(len), slpfcs(len), absfcs(len) + &, swdfcs(len), slcfcs(len,lsoil) +! +! ratio of sigma level 1 wind and 10m wind (diagnozed by model and not touched +! in this program). +! + real (kind=kind_io8) f10m (len) + real (kind=kind_io8) fsmcl(25),fsmcs(25),fstcl(25),fstcs(25) + real (kind=kind_io8) fcsmcl(25),fcsmcs(25),fcstcl(25),fcstcs(25) + +!clu [+1l] add swratio (soil moisture liquid-to-total ratio) + real (kind=kind_io8) swratio(len,lsoil) +!clu [+1l] add fixratio (option to adjust slc from smc) + logical fixratio(lsoil) +! + integer icsmcl(25), icsmcs(25), icstcl(25), icstcs(25) +! + real (kind=kind_io8) csmcl(25), csmcs(25) + real (kind=kind_io8) cstcl(25), cstcs(25) +! + real (kind=kind_io8) slmskh(mdata) + character*500 fnmskh + integer kpd7, kpd9 +! + logical icefl1(len), icefl2(len) +! +! input and output surface fields (bges) file names +! +! +! sigma level 1 temperature for dead start +! + real (kind=kind_io8) sig1t(len) +! + character*32 label +! +! = 1 ==> forecast is used +! = 0 ==> analysis (or climatology) is used +! +! output file ... primary surface file for radiation and forecast +! +! rec. 1 label +! rec. 2 date record +! rec. 3 tsf +! rec. 4 soilm(two layers) ----> 4 layers +! rec. 5 snow +! rec. 6 soilt(two layers) ----> 4 layers +! rec. 7 tg3 +! rec. 8 zor +! rec. 9 cv +! rec. 10 cvb +! rec. 11 cvt +! rec. 12 albedo (four types) +! rec. 13 slimsk +! rec. 14 vegetation cover +! rec. 14 plantr -----> skip this record +! rec. 15 f10m -----> canopy +! rec. 16 canopy water content (cnpanl) -----> f10m +! rec. 17 vegetation type +! rec. 18 soil type +! rec. 19 zeneith angle dependent vegetation fraction (two types) +! rec. 20 uustar +! rec. 21 ffmm +! rec. 22 ffhh +!cwu add sih & sic +! rec. 23 sih(one category only) +! rec. 24 sic +!clu [+8l] add prcp, flag, swd, slc, vmn, vmx, slp, abs +! rec. 25 tprcp +! rec. 26 srflag +! rec. 27 swd +! rec. 28 slc (4 layers) +! rec. 29 vmn +! rec. 30 vmx +! rec. 31 slp +! rec. 32 abs + +! +! debug only +! ldebug=.true. creates bges files for climatology and analysis +! lqcbgs=.true. quality controls input bges file before merging (should have been +! qced in the forecast program) +! + logical ldebug,lqcbgs + logical lprnt +! +! debug only +! + character*500 fndclm,fndanl +! + logical lanom + +! + namelist/namsfc/fnglac,fnmxic, + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc, + & fnvegc,fnvetc,fnsotc,fnalbc2, fnmldc,fnqfluxc, + & fnvmnc,fnvmxc,fnslpc,fnabsc, + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna, + & fnvega,fnveta,fnsota, + & fnvmna,fnvmxa,fnslpa,fnabsa, + & fnmskh, + & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, + & fndclm,fndanl, + & lanom, + & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, + & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs, + & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, + & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, + & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, + & fcstcl,fcstcs,fsalfl,fsalfs,fcalfl,flalfs, + & fsihl,fsicl,fsihs,fsics,aislim,sihnew, + & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss, + & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, + & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, + & icstcl,icstcs,icalfl,icalfs, + & gausm, deads, qcmsk, znlst, + & monclm, monanl, monfcs, monmer, mondif, igrdbg, + & blnmsk, bltmsk, landice +! + data gausm/.true./, deads/.false./, blnmsk/0.0/, bltmsk/90.0/ + &, qcmsk/.false./, znlst/.false./, igrdbg/-1/ + &, monclm/.false./, monanl/.false./, monfcs/.false./ + &, monmer/.false./, mondif/.false./, landice/.true./ +! +! defaults file names +! + data fnmskh/'global_slmask.t126.grb'/ + data fnalbc/'global_albedo4.1x1.grb'/ + data fnalbc2/'global_albedo4.1x1.grb'/ + data fntsfc/'global_sstclim.2x2.grb'/ + data fnsotc/'global_soiltype.1x1.grb'/ + data fnvegc/'global_vegfrac.1x1.grb'/ + data fnvetc/'global_vegtype.1x1.grb'/ + data fnglac/'global_glacier.2x2.grb'/ + data fnmxic/'global_maxice.2x2.grb'/ + data fnsnoc/'global_snoclim.1.875.grb'/ + data fnzorc/'global_zorclim.1x1.grb'/ + data fnaisc/'global_iceclim.2x2.grb'/ + data fntg3c/'global_tg3clim.2.6x1.5.grb'/ + data fnsmcc/'global_soilmcpc.1x1.grb'/ +!clu [+4l] add fn()c for vmn, vmx, abs, slp + data fnvmnc/'global_shdmin.0.144x0.144.grb'/ + data fnvmxc/'global_shdmax.0.144x0.144.grb'/ + data fnslpc/'global_slope.1x1.grb'/ + data fnabsc/'global_snoalb.1x1.grb'/ +! + data fnwetc/' '/ + data fnmldc/' '/ + data fnqfluxc/' '/ + data fnplrc/' '/ + data fnstcc/' '/ + data fnscvc/' '/ + data fnacnc/' '/ +! + data fntsfa/' '/ + data fnweta/' '/ + data fnsnoa/' '/ + data fnzora/' '/ + data fnalba/' '/ + data fnaisa/' '/ + data fnplra/' '/ + data fntg3a/' '/ + data fnsmca/' '/ + data fnstca/' '/ + data fnscva/' '/ + data fnacna/' '/ + data fnvega/' '/ + data fnveta/' '/ + data fnsota/' '/ +!clu [+4l] add fn()a for vmn, vmx, abs, slp + data fnvmna/' '/ + data fnvmxa/' '/ + data fnslpa/' '/ + data fnabsa/' '/ +! + data ldebug/.false./, lqcbgs/.true./ + data fndclm/' '/ + data fndanl/' '/ + data lanom/.false./ +! +! default relaxation time in hours to analysis or climatology + data ftsfl/99999.0/, ftsfs/0.0/ + data falbl/0.0/, falbs/0.0/ + data falfl/0.0/, falfs/0.0/ + data faisl/0.0/, faiss/0.0/ + data fsnol/0.0/, fsnos/99999.0/ + data fzorl/0.0/, fzors/99999.0/ + data fplrl/0.0/, fplrs/0.0/ + data fvetl/0.0/, fvets/99999.0/ + data fsotl/0.0/, fsots/99999.0/ + data fvegl/0.0/, fvegs/99999.0/ +!cwu [+4l] add f()l and f()s for sih, sic and aislim, sihlim + data fsihl/99999.0/, fsihs/99999.0/ +! data fsicl/99999.0/, fsics/99999.0/ + data fsicl/0.0/, fsics/0.0/ +! default ice concentration limit (50%), new ice thickness (20cm) +!cwu change ice concentration limit (15%) Jan 2015 +! data aislim/0.50/, sihnew/0.2/ + data aislim/0.15/, sihnew/0.2/ +!clu [+4l] add f()l and f()s for vmn, vmx, abs, slp + data fvmnl/0.0/, fvmns/99999.0/ + data fvmxl/0.0/, fvmxs/99999.0/ + data fslpl/0.0/, fslps/99999.0/ + data fabsl/0.0/, fabss/99999.0/ +! default relaxation time in hours to climatology if analysis missing + data fctsfl/99999.0/, fctsfs/99999.0/ + data fcalbl/99999.0/, fcalbs/99999.0/ + data fcsnol/99999.0/, fcsnos/99999.0/ + data fczorl/99999.0/, fczors/99999.0/ + data fcplrl/99999.0/, fcplrs/99999.0/ +! default flag to apply climatological annual cycle + data ictsfl/0/, ictsfs/1/ + data icalbl/1/, icalbs/1/ + data icalfl/1/, icalfs/1/ + data icsnol/0/, icsnos/0/ + data iczorl/1/, iczors/0/ + data icplrl/1/, icplrs/0/ +! + data ccnp/1.0/ + data ccv/1.0/, ccvb/1.0/, ccvt/1.0/ +! + data ifp/0/ +! + save ifp,fnglac,fnmxic, + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fnplrc,fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fnplra,fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnvetc,fnveta, + & fnsotc,fnsota, fnmldc,fnqfluxc, +!clu [+2l] add fn()c and fn()a for vmn, vmx, slp, abs + & fnvmnc,fnvmxc,fnabsc,fnslpc, + & fnvmna,fnvmxa,fnabsa,fnslpa, + & ldebug,lgchek,lqcbgs,critp1,critp2,critp3, + & fndclm,fndanl, + & lanom, + & ftsfl,ftsfs,falbl,falbs,faisl,faiss,fsnol,fsnos, + & fzorl,fzors,fplrl,fplrs,fsmcl,fsmcs,falfl,falfs, + & fstcl,fstcs,fvegl,fvegs,fvetl,fvets,fsotl,fsots, + & fctsfl,fctsfs,fcalbl,fcalbs,fcsnol,fcsnos, + & fczorl,fczors,fcplrl,fcplrs,fcsmcl,fcsmcs, + & fcstcl,fcstcs,fcalfl,fcalfs, +!cwu [+1l] add f()l and f()s for sih, sic and aislim, sihnew + & fsihl,fsihs,fsicl,fsics,aislim,sihnew, +!clu [+2l] add f()l and f()s for vmn, vmx, slp, abs + & fvmnl,fvmns,fvmxl,fvmxs,fslpl,fslps, + & fabsl,fabss, + & ictsfl,ictsfs,icalbl,icalbs,icsnol,icsnos, + & iczorl,iczors,icplrl,icplrs,icsmcl,icsmcs, + & icstcl,icstcs,icalfl,icalfs, + & gausm, deads, qcmsk, + & monclm, monanl, monfcs, monmer, mondif, igrdbg, + & grboro, grbmsk, +! + & ctsfl, ctsfs, calbl, calfl, calbs, calfs, csmcs, + & csnol, csnos, czorl, czors, cplrl, cplrs, cstcl, + & cstcs, cvegl, cvwgs, cvetl, cvets, csotl, csots, + & csmcl +!cwu [+1l] add c()l and c()s for sih, sic + &, csihl, csihs, csicl, csics +!clu [+2l] add c()l and c()s for vmn, vmx, slp, abs + &, cvmnl, cvmns, cvmxl, cvmxs, cslpl, cslps, + & cabsl, cabss + &, imsk, jmsk, slmskh, blnmsk, bltmsk + &, glacir, amxice, tsfcl0 + &, caisl, caiss, cvegs +! + lprnt = .false. + iprnt = 1 +! do i=1,len +! if (ifp .eq. 0 .and. rla(i) .gt. 80.0) print *,' rla=',rla(i) +! *,' rlo=',rlo(i) +! tem1 = abs(rla(i) - 48.75) +! tem2 = abs(rlo(i) - (-68.50)) +! if(tem1 .lt. 0.25 .and. tem2 .lt. 0.50) then +! lprnt = .true. +! iprnt = i +! print *,' lprnt=',lprnt,' iprnt=',iprnt +! print *,' rla(i)=',rla(i),' rlo(i)=',rlo(i) +! endif +! enddo + if (ialb == 1) then + kpdabs = kpdabs_1 + kpdalb = kpdalb_1 + alblmx = .99 + albsmx = .99 + alblmn = .01 + albsmn = .01 + abslmx = 1.0 + abssmx = 1.0 + abssmn = .01 + abslmn = .01 + else + kpdabs = kpdabs_0 + kpdalb = kpdalb_0 + alblmx = .80 + albsmx = .80 + alblmn = .06 + albsmn = .06 + abslmx = .80 + abssmx = .80 + abslmn = .01 + abssmn = .01 + endif + if(ifp.eq.0) then + ifp = 1 + do k=1,lsoil + fsmcl(k) = 99999. + fsmcs(k) = 0. + fstcl(k) = 99999. + fstcs(k) = 0. + enddo +#ifdef INTERNAL_FILE_NML + read(input_nml_file, nml=namsfc) +#else +! print *,' in sfcsub nlunit=',nlunit,' me=',me,' ialb=',ialb + rewind(nlunit) + read (nlunit,namsfc) +#endif +! write(6,namsfc) +! + if (me .eq. 0 .and. print_debug) then + print *,'ftsfl,falbl,faisl,fsnol,fzorl=', + & ftsfl,falbl,faisl,fsnol,fzorl + print *,'fsmcl=',fsmcl(1:lsoil) + print *,'fstcl=',fstcl(1:lsoil) + print *,'ftsfs,falbs,faiss,fsnos,fzors=', + & ftsfs,falbs,faiss,fsnos,fzors + print *,'fsmcs=',fsmcs(1:lsoil) + print *,'fstcs=',fstcs(1:lsoil) + print *,' aislim=',aislim,' sihnew=',sihnew + print *,' isot=', isot,' ivegsrc=',ivegsrc + endif + + if (ivegsrc == 2) then ! sib + veg_type_landice=13 + else + veg_type_landice=15 + endif + if (isot == 0) then + soil_type_landice=9 + else + soil_type_landice=16 + endif +! + deltf = deltsfc / 24.0 +! + ctsfl=0. !... tsfc over land + if(ftsfl.ge.99999.) ctsfl=1. + if((ftsfl.gt.0.).and.(ftsfl.lt.99999)) ctsfl=exp(-deltf/ftsfl) +! + ctsfs=0. !... tsfc over sea + if(ftsfs.ge.99999.) ctsfs=1. + if((ftsfs.gt.0.).and.(ftsfs.lt.99999)) ctsfs=exp(-deltf/ftsfs) +! + do k=1,lsoil + csmcl(k)=0. !... soilm over land + if(fsmcl(k).ge.99999.) csmcl(k)=1. + if((fsmcl(k).gt.0.).and.(fsmcl(k).lt.99999)) + & csmcl(k)=exp(-deltf/fsmcl(k)) + csmcs(k)=0. !... soilm over sea + if(fsmcs(k).ge.99999.) csmcs(k)=1. + if((fsmcs(k).gt.0.).and.(fsmcs(k).lt.99999)) + & csmcs(k)=exp(-deltf/fsmcs(k)) + enddo +! + calbl=0. !... albedo over land + if(falbl.ge.99999.) calbl=1. + if((falbl.gt.0.).and.(falbl.lt.99999)) calbl=exp(-deltf/falbl) +! + calfl=0. !... fraction field for albedo over land + if(falfl.ge.99999.) calfl=1. + if((falfl.gt.0.).and.(falfl.lt.99999)) calfl=exp(-deltf/falfl) +! + calbs=0. !... albedo over sea + if(falbs.ge.99999.) calbs=1. + if((falbs.gt.0.).and.(falbs.lt.99999)) calbs=exp(-deltf/falbs) +! + calfs=0. !... fraction field for albedo over sea + if(falfs.ge.99999.) calfs=1. + if((falfs.gt.0.).and.(falfs.lt.99999)) calfs=exp(-deltf/falfs) +! + caisl=0. !... sea ice over land + if(faisl.ge.99999.) caisl=1. + if((faisl.gt.0.).and.(faisl.lt.99999)) caisl=1. +! + caiss=0. !... sea ice over sea + if(faiss.ge.99999.) caiss=1. + if((faiss.gt.0.).and.(faiss.lt.99999)) caiss=1. +! + csnol=0. !... snow over land + if(fsnol.ge.99999.) csnol=1. + if((fsnol.gt.0.).and.(fsnol.lt.99999)) csnol=exp(-deltf/fsnol) +! using the same way to bending snow as narr when fsnol is the negative value +! the magnitude of fsnol is the thread to determine the lower and upper bound +! of final swe + if(fsnol.lt.0.)csnol=fsnol +! + csnos=0. !... snow over sea + if(fsnos.ge.99999.) csnos=1. + if((fsnos.gt.0.).and.(fsnos.lt.99999)) csnos=exp(-deltf/fsnos) +! + czorl=0. !... roughness length over land + if(fzorl.ge.99999.) czorl=1. + if((fzorl.gt.0.).and.(fzorl.lt.99999)) czorl=exp(-deltf/fzorl) +! + czors=0. !... roughness length over sea + if(fzors.ge.99999.) czors=1. + if((fzors.gt.0.).and.(fzors.lt.99999)) czors=exp(-deltf/fzors) +! +! cplrl=0. !... plant resistance over land +! if(fplrl.ge.99999.) cplrl=1. +! if((fplrl.gt.0.).and.(fplrl.lt.99999)) cplrl=exp(-deltf/fplrl) +! +! cplrs=0. !... plant resistance over sea +! if(fplrs.ge.99999.) cplrs=1. +! if((fplrs.gt.0.).and.(fplrs.lt.99999)) cplrs=exp(-deltf/fplrs) +! + do k=1,lsoil + cstcl(k)=0. !... soilt over land + if(fstcl(k).ge.99999.) cstcl(k)=1. + if((fstcl(k).gt.0.).and.(fstcl(k).lt.99999)) + & cstcl(k)=exp(-deltf/fstcl(k)) + cstcs(k)=0. !... soilt over sea + if(fstcs(k).ge.99999.) cstcs(k)=1. + if((fstcs(k).gt.0.).and.(fstcs(k).lt.99999)) + & cstcs(k)=exp(-deltf/fstcs(k)) + enddo +! + cvegl=0. !... vegetation fraction over land + if(fvegl.ge.99999.) cvegl=1. + if((fvegl.gt.0.).and.(fvegl.lt.99999)) cvegl=exp(-deltf/fvegl) +! + cvegs=0. !... vegetation fraction over sea + if(fvegs.ge.99999.) cvegs=1. + if((fvegs.gt.0.).and.(fvegs.lt.99999)) cvegs=exp(-deltf/fvegs) +! + cvetl=0. !... vegetation type over land + if(fvetl.ge.99999.) cvetl=1. + if((fvetl.gt.0.).and.(fvetl.lt.99999)) cvetl=exp(-deltf/fvetl) +! + cvets=0. !... vegetation type over sea + if(fvets.ge.99999.) cvets=1. + if((fvets.gt.0.).and.(fvets.lt.99999)) cvets=exp(-deltf/fvets) +! + csotl=0. !... soil type over land + if(fsotl.ge.99999.) csotl=1. + if((fsotl.gt.0.).and.(fsotl.lt.99999)) csotl=exp(-deltf/fsotl) +! + csots=0. !... soil type over sea + if(fsots.ge.99999.) csots=1. + if((fsots.gt.0.).and.(fsots.lt.99999)) csots=exp(-deltf/fsots) + +!cwu [+16l]--------------------------------------------------------------- +! + csihl=0. !... sea ice thickness over land + if(fsihl.ge.99999.) csihl=1. + if((fsihl.gt.0.).and.(fsihl.lt.99999)) csihl=exp(-deltf/fsihl) +! + csihs=0. !... sea ice thickness over sea + if(fsihs.ge.99999.) csihs=1. + if((fsihs.gt.0.).and.(fsihs.lt.99999)) csihs=exp(-deltf/fsihs) +! + csicl=0. !... sea ice concentration over land + if(fsicl.ge.99999.) csicl=1. + if((fsicl.gt.0.).and.(fsicl.lt.99999)) csicl=exp(-deltf/fsicl) +! + csics=0. !... sea ice concentration over sea + if(fsics.ge.99999.) csics=1. + if((fsics.gt.0.).and.(fsics.lt.99999)) csics=exp(-deltf/fsics) + +!clu [+32l]--------------------------------------------------------------- +! + cvmnl=0. !... min veg cover over land + if(fvmnl.ge.99999.) cvmnl=1. + if((fvmnl.gt.0.).and.(fvmnl.lt.99999)) cvmnl=exp(-deltf/fvmnl) +! + cvmns=0. !... min veg cover over sea + if(fvmns.ge.99999.) cvmns=1. + if((fvmns.gt.0.).and.(fvmns.lt.99999)) cvmns=exp(-deltf/fvmns) +! + cvmxl=0. !... max veg cover over land + if(fvmxl.ge.99999.) cvmxl=1. + if((fvmxl.gt.0.).and.(fvmxl.lt.99999)) cvmxl=exp(-deltf/fvmxl) +! + cvmxs=0. !... max veg cover over sea + if(fvmxs.ge.99999.) cvmxs=1. + if((fvmxs.gt.0.).and.(fvmxs.lt.99999)) cvmxs=exp(-deltf/fvmxs) +! + cslpl=0. !... slope type over land + if(fslpl.ge.99999.) cslpl=1. + if((fslpl.gt.0.).and.(fslpl.lt.99999)) cslpl=exp(-deltf/fslpl) +! + cslps=0. !... slope type over sea + if(fslps.ge.99999.) cslps=1. + if((fslps.gt.0.).and.(fslps.lt.99999)) cslps=exp(-deltf/fslps) +! + cabsl=0. !... snow albedo over land + if(fabsl.ge.99999.) cabsl=1. + if((fabsl.gt.0.).and.(fabsl.lt.99999)) cabsl=exp(-deltf/fabsl) +! + cabss=0. !... snow albedo over sea + if(fabss.ge.99999.) cabss=1. + if((fabss.gt.0.).and.(fabss.lt.99999)) cabss=exp(-deltf/fabss) +!clu ---------------------------------------------------------------------- +! +! read a high resolution mask field for use in grib interpolation +! + call hmskrd(lugb,imsk,jmsk,fnmskh, + & kpdmsk,slmskh,gausm,blnmsk,bltmsk,me) +! if (qcmsk) call qcmask(slmskh,sllnd,slsea,imsk,jmsk,rla,rlo) +! + if (me .eq. 0 .and. print_debug) then + write(6,*) ' ' + write(6,*) ' lugb=',lugb,' len=',len, ' lsoil=',lsoil + write(6,*) 'iy=',iy,' im=',im,' id=',id,' ih=',ih,' fh=',fh + &, ' sig1t(1)=',sig1t(1) + &, ' gausm=',gausm,' blnmsk=',blnmsk,' bltmsk=',bltmsk + write(6,*) ' ' + endif +! +! reading permanent/extreme features (glacier points and maximum ice extent) +! + allocate (tsfcl0(len)) + allocate (glacir(len)) + allocate (amxice(len)) +! +! read glacier +! + kpd9 = -1 + kpd7 = -1 + call fixrdc(lugb,fnglac,kpdgla,kpd7,kpd9,slmask, + & glacir,len,iret + &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk + &, rla, rlo, me) +! znnt=1. +! call nntprt(glacir,len,znnt) +! +! read maximum ice extent +! + kpd7 = -1 + call fixrdc(lugb,fnmxic,kpdmxi,kpd7,kpd9,slmask, + & amxice,len,iret + &, imsk, jmsk, slmskh, gausm, blnmsk, bltmsk + &, rla, rlo, me) +! znnt=1. +! call nntprt(amxice,len,znnt) +! + crit=0.5 + call rof01(glacir,len,'ge',crit) + call rof01(amxice,len,'ge',crit) +! +! quality control max ice limit based on glacier points +! + call qcmxice(glacir,amxice,len,me) +! + endif ! first time loop finished +! + do i=1,len + sliclm(i) = 1. + snoclm(i) = 0. + icefl1(i) = .true. + enddo +! if(lprnt) print *,' tsffcsin=',tsffcs(iprnt) +! +! read climatology fields +! + if (me .eq. 0) then + write(6,*) '==============' + write(6,*) 'climatology' + write(6,*) '==============' + endif +! + percrit=critp1 +! + call clima(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + & fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc, + & fnvmnc,fnvmxc,fnslpc,fnabsc,fnmldc,fnqfluxc, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, + & vetclm,sotclm,alfclm, + & vmnclm,vmxclm,slpclm,absclm,mldclm,qfluxadj, + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf,tsfcl0, + & kpdvmn,kpdvmx,kpdslp,kpdabs,kpdmld,kpdqflux, + & deltsfc, lanom + &, imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me + &, lprnt,iprnt,fnalbc2,ialb,tile_num_ch,i_index,j_index) +! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) +! +! scale surface roughness and albedo to model required units +! + zsca=100. + call scale(zorclm,len,zsca) + zsca=0.01 + call scale(albclm,len,zsca) + call scale(albclm(1,2),len,zsca) + call scale(albclm(1,3),len,zsca) + call scale(albclm(1,4),len,zsca) + call scale(alfclm,len,zsca) + call scale(alfclm(1,2),len,zsca) +!clu [+4l] scale vmn, vmx, abs from percent to fraction + zsca=0.01 + call scale(vmnclm,len,zsca) + call scale(vmxclm,len,zsca) + call scale(absclm,len,zsca) + +! +! set albedo over ocean to albomx +! + call albocn(albclm,slmask,albomx,len) +! +! make sure vegetation type and soil type are non zero over land +! + call landtyp(vetclm,sotclm,slpclm,slmask,len) +! +!cwu [-1l/+1l] +!* ice concentration or ice mask (only ice mask used in the model now) +! ice concentration and ice mask (both are used in the model now) +! + if(fnaisc(1:8).ne.' ') then +!cwu [+5l/-1l] update sihclm, sicclm + do i=1,len + sihclm(i) = 3.0*aisclm(i) + sicclm(i) = aisclm(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicclm(i).ne.1.) then + sicclm(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim +!* crit=0.5 + call rof01(aisclm,len,'ge',crit) + elseif(fnacnc(1:8).ne.' ') then +!cwu [+4l] update sihclm, sicclm + do i=1,len + sihclm(i) = 3.0*acnclm(i) + sicclm(i) = acnclm(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicclm(i).ne.1.) then + sicclm(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + call rof01(acnclm,len,'ge',aislim) + do i=1,len + aisclm(i) = acnclm(i) + enddo + endif +! +! quality control of sea ice mask +! + call qcsice(aisclm,glacir,amxice,aicice,aicsea,sllnd,slmask, + & rla,rlo,len,me) +! +! set ocean/land/sea-ice mask +! + call setlsi(slmask,aisclm,len,aicice,sliclm) +! if(lprnt) print *,' aisclm=',aisclm(iprnt),' sliclm=' +! *,sliclm(iprnt),' slmask=',slmask(iprnt) +! +! write(6,*) 'sliclm' +! znnt=1. +! call nntprt(sliclm,len,znnt) +! +! quality control of snow +! + call qcsnow(snoclm,slmask,aisclm,glacir,len,snosmx,landice,me) +! + call setzro(snoclm,epssno,len) +! +! snow cover handling (we assume climatological snow depth is available) +! quality control of snow depth (note that snow should be corrected first +! because it influences tsf +! + kqcm=1 + call qcmxmn('snow ',snoclm,sliclm,snoclm,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! write(6,*) 'snoclm' +! znnt=1. +! call nntprt(snoclm,len,znnt) +! +! get snow cover from snow depth array +! + if(fnscvc(1:8).eq.' ') then + call getscv(snoclm,scvclm,len) + endif +! +! set tsfc over snow to tsfsmx if greater +! + call snosfc(snoclm,tsfclm,tsfsmx,len,me) +! call snosfc(snoclm,tsfcl2,tsfsmx,len) + +! +! quality control +! + do i=1,len + icefl2(i) = sicclm(i) .gt. 0.99999 + enddo + kqcm=1 + call qcmxmn('tsfc ',tsfclm,sliclm,snoclm,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('tsf2 ',tsfcl2,sliclm,snoclm,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('albc ',albclm(1,kk),sliclm,snoclm,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ') then + call qcmxmn('wetc ',wetclm,sliclm,snoclm,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zorc ',zorclm,sliclm,snoclm,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ') then +! call qcmxmn('plntc ',plrclm,sliclm,snoclm,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('tg3c ',tg3clm,sliclm,snoclm,icefl1, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, + & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! +! get soil temp and moisture (after all the qcs are completed) +! + if(fnsmcc(1:8).eq.' ') then + call getsmc(wetclm,len,lsoil,smcclm,me) + endif + call qcmxmn('smc1c ',smcclm(1,1),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2c ',smcclm(1,2),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcclm(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3c ',smcclm(1,3),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4c ',smcclm(1,4),sliclm,snoclm,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + if(fnstcc(1:8).eq.' ') then + call getstc(tsfclm,tg3clm,sliclm,len,lsoil,stcclm,tsfimx) + endif + call qcmxmn('stc1c ',stcclm(1,1),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2c ',stcclm(1,2),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcclm(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3c ',stcclm(1,3),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4c ',stcclm(1,4),sliclm,snoclm,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('vegc ',vegclm,sliclm,snoclm,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vetc ',vetclm,sliclm,snoclm,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sotc ',sotclm,sliclm,snoclm,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!cwu [+8l] --------------------------------------------------------------- + call qcmxmn('sihc ',sihclm,sliclm,snoclm,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sicc ',sicclm,sliclm,snoclm,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+16l] --------------------------------------------------------------- + call qcmxmn('vmnc ',vmnclm,sliclm,snoclm,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxc ',vmxclm,sliclm,snoclm,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpc ',slpclm,sliclm,snoclm,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absc ',absclm,sliclm,snoclm,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu ---------------------------------------------------------------------- +! +! monitoring prints +! + if (monclm) then + if (me .eq. 0) then + print *,' ' + print *,'monitor of time and space interpolated climatology' + print *,' ' +! call count(sliclm,snoclm,len) + print *,' ' + call monitr('tsfclm',tsfclm,sliclm,snoclm,len) + call monitr('albclm',albclm(1,1),sliclm,snoclm,len) + call monitr('albclm',albclm(1,2),sliclm,snoclm,len) + call monitr('albclm',albclm(1,3),sliclm,snoclm,len) + call monitr('albclm',albclm(1,4),sliclm,snoclm,len) + call monitr('aisclm',aisclm,sliclm,snoclm,len) + call monitr('snoclm',snoclm,sliclm,snoclm,len) + call monitr('scvclm',scvclm,sliclm,snoclm,len) + call monitr('smcclm1',smcclm(1,1),sliclm,snoclm,len) + call monitr('smcclm2',smcclm(1,2),sliclm,snoclm,len) + call monitr('stcclm1',stcclm(1,1),sliclm,snoclm,len) + call monitr('stcclm2',stcclm(1,2),sliclm,snoclm,len) +!clu [+4l] add smcclm(3:4) and stcclm(3:4) + if(lsoil.gt.2) then + call monitr('smcclm3',smcclm(1,3),sliclm,snoclm,len) + call monitr('smcclm4',smcclm(1,4),sliclm,snoclm,len) + call monitr('stcclm3',stcclm(1,3),sliclm,snoclm,len) + call monitr('stcclm4',stcclm(1,4),sliclm,snoclm,len) + endif + call monitr('tg3clm',tg3clm,sliclm,snoclm,len) + call monitr('zorclm',zorclm,sliclm,snoclm,len) +! if (gaus) then + call monitr('cvaclm',cvclm ,sliclm,snoclm,len) + call monitr('cvbclm',cvbclm,sliclm,snoclm,len) + call monitr('cvtclm',cvtclm,sliclm,snoclm,len) +! endif + call monitr('sliclm',sliclm,sliclm,snoclm,len) +! call monitr('plrclm',plrclm,sliclm,snoclm,len) + call monitr('orog ',orog ,sliclm,snoclm,len) + call monitr('vegclm',vegclm,sliclm,snoclm,len) + call monitr('vetclm',vetclm,sliclm,snoclm,len) + call monitr('sotclm',sotclm,sliclm,snoclm,len) +!cwu [+2l] add sih, sic + call monitr('sihclm',sihclm,sliclm,snoclm,len) + call monitr('sicclm',sicclm,sliclm,snoclm,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnclm',vmnclm,sliclm,snoclm,len) + call monitr('vmxclm',vmxclm,sliclm,snoclm,len) + call monitr('slpclm',slpclm,sliclm,snoclm,len) + call monitr('absclm',absclm,sliclm,snoclm,len) + endif + endif +! +! + if (me .eq. 0) then + write(6,*) '==============' + write(6,*) ' analysis' + write(6,*) '==============' + endif +! +! fill in analysis array with climatology before reading analysis. +! + call filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, + & vetanl,sotanl,alfanl, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, + & vetclm,sotclm,alfclm, + & sihclm,sicclm, + & vmnclm,vmxclm,slpclm,absclm, + & len,lsoil) +! +! reverse scaling to match with grib analysis input +! + zsca=0.01 + call scale(zoranl,len, zsca) + zsca=100. + call scale(albanl,len,zsca) + call scale(albanl(1,2),len,zsca) + call scale(albanl(1,3),len,zsca) + call scale(albanl(1,4),len,zsca) + call scale(alfanl,len,zsca) + call scale(alfanl(1,2),len,zsca) +!clu [+4l] reverse scale for vmn, vmx, abs + zsca=100. + call scale(vmnanl,len,zsca) + call scale(vmxanl,len,zsca) + call scale(absanl,len,zsca) +! + percrit=critp2 +! +! read analysis fields +! + call analy(lugb,iy,im,id,ih,fh,len,lsoil,slmask, + & fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota, + & fnvmna,fnvmxa,fnslpa,fnabsa, + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, + & vetanl,sotanl,alfanl,tsfan0, + & vmnanl,vmxanl,slpanl,absanl, + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf, + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvet,irtsot,irtalf + &, irtvmn,irtvmx,irtslp,irtabs, + & imsk, jmsk, slmskh, rla, rlo, gausm, blnmsk, bltmsk,me) +! if(lprnt) print *,' tsfanl=',tsfanl(iprnt) +! +! scale zor and alb to match forecast model units +! + zsca=100. + call scale(zoranl,len, zsca) + zsca=0.01 + call scale(albanl,len,zsca) + call scale(albanl(1,2),len,zsca) + call scale(albanl(1,3),len,zsca) + call scale(albanl(1,4),len,zsca) + call scale(alfanl,len,zsca) + call scale(alfanl(1,2),len,zsca) +!clu [+4] scale vmn, vmx, abs from percent to fraction + zsca=0.01 + call scale(vmnanl,len,zsca) + call scale(vmxanl,len,zsca) + call scale(absanl,len,zsca) +! +! interpolate climatology but fixing initial anomaly +! + if(fh.gt.0.0.and.fntsfa(1:8).ne.' '.and.lanom) then + call anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) + endif +! +! if the tsfanl is at sea level, then bring it to the surface using +! unfiltered orography (for lakes). if the analysis is at lake surface +! as in the nst model, then this call should be removed - moorthi 09/23/2011 +! + if (use_ufo .and. .not. nst_anl) then + ztsfc = 0.0 + call tsfcor(tsfanl,orog_uf,slmask,ztsfc,len,rlapse) + endif +! +! ice concentration or ice mask (only ice mask used in the model now) +! + if(fnaisa(1:8).ne.' ') then +!cwu [+5l/-1l] update sihanl, sicanl + do i=1,len + sihanl(i) = 3.0*aisanl(i) + sicanl(i) = aisanl(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicanl(i).ne.1.) then + sicanl(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim +!* crit=0.5 + call rof01(aisanl,len,'ge',crit) + elseif(fnacna(1:8).ne.' ') then +!cwu [+17l] update sihanl, sicanl + do i=1,len + sihanl(i) = 3.0*acnanl(i) + sicanl(i) = acnanl(i) + if(slmask(i).eq.0..and.glacir(i).eq.1..and. + & sicanl(i).ne.1.) then + sicanl(i) = sicimx + sihfcs(i) = glacir_hice + endif + enddo + crit=aislim + do i=1,len + if((slianl(i).eq.0.).and.(sicanl(i).ge.crit)) then + slianl(i)=2. +! print *,'cycle - new ice form: fice=',sicanl(i) + else if((slianl(i).ge.2.).and.(sicanl(i).lt.crit)) then + slianl(i)=0. +! print *,'cycle - ice free: fice=',sicanl(i) + else if((slianl(i).eq.1.).and.(sicanl(i).ge.sicimn)) then +! print *,'cycle - land covered by sea-ice: fice=',sicanl(i) + sicanl(i)=0. + endif + enddo +! znnt=10. +! call nntprt(acnanl,len,znnt) +! if(lprnt) print *,' acnanl=',acnanl(iprnt) +! do i=1,len +! if (acnanl(i) .gt. 0.3 .and. aisclm(i) .eq. 1.0 +! & .and. aisfcs(i) .ge. 0.75) acnanl(i) = aislim +! enddo +! if(lprnt) print *,' acnanl=',acnanl(iprnt) + call rof01(acnanl,len,'ge',aislim) + do i=1,len + aisanl(i)=acnanl(i) + enddo + endif +! if(lprnt) print *,' aisanl1=',aisanl(iprnt),' glacir=' +! &,glacir(iprnt),' slmask=',slmask(iprnt) +! + call qcsice(aisanl,glacir,amxice,aicice,aicsea,sllnd,slmask, + & rla,rlo,len,me) +! +! set ocean/land/sea-ice mask +! + call setlsi(slmask,aisanl,len,aicice,slianl) +! if(lprnt) print *,' aisanl=',aisanl(iprnt),' slianl=' +! *,slianl(iprnt),' slmask=',slmask(iprnt) +! +! + do k=1,lsoil + do i=1,len + if (slianl(i) .eq. 0) then + smcanl(i,k) = smcomx + stcanl(i,k) = tsfanl(i) + endif + enddo + enddo + +! write(6,*) 'slianl' +! znnt=1. +! call nntprt(slianl,len,znnt) +!cwu [+8l]---------------------------------------------------------------------- + call qcmxmn('siha ',sihanl,slianl,snoanl,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sica ',sicanl,slianl,snoanl,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! +! set albedo over ocean to albomx +! + call albocn(albanl,slmask,albomx,len) +! +! quality control of snow and sea-ice +! process snow depth or snow cover +! + if(fnsnoa(1:8).ne.' ') then + call setzro(snoanl,epssno,len) + call qcsnow(snoanl,slmask,aisanl,glacir,len,ten,landice,me) + if (.not.landice) then + call snodpth2(glacir,snosmx,snoanl, len, me) + endif + kqcm=1 + call snosfc(snoanl,tsfanl,tsfsmx,len,me) + call qcmxmn('snoa ',snoanl,slianl,snoanl,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call getscv(snoanl,scvanl,len) + call qcmxmn('sncva ',scvanl,slianl,snoanl,icefl1, + & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, + & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, + & rla,rlo,len,kqcm,percrit,lgchek,me) + else + crit=0.5 + call rof01(scvanl,len,'ge',crit) + call qcsnow(scvanl,slmask,aisanl,glacir,len,one,landice,me) + call qcmxmn('sncva ',scvanl,slianl,scvanl,icefl1, + & scvlmx,scvlmn,scvomx,scvomn,scvimx,scvimn, + & scvjmx,scvjmn,scvsmx,scvsmn,epsscv, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call snodpth(scvanl,slianl,tsfanl,snoclm, + & glacir,snwmax,snwmin,landice,len,snoanl,me) + call qcsnow(scvanl,slmask,aisanl,glacir,len,snosmx,landice,me) + call snosfc(snoanl,tsfanl,tsfsmx,len,me) + call qcmxmn('snowa ',snoanl,slianl,snoanl,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif +! + do i=1,len + icefl2(i) = sicanl(i) .gt. 0.99999 + enddo + call qcmxmn('tsfa ',tsfanl,slianl,snoanl,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('alba ',albanl(1,kk),slianl,snoanl,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) then + call qcmxmn('weta ',wetanl,slianl,snoanl,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zora ',zoranl,slianl,snoanl,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) then +! call qcmxmn('plna ',plranl,slianl,snoanl,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('tg3a ',tg3anl,slianl,snoanl,icefl1, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, + & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! +! get soil temp and moisture +! + if(fnsmca(1:8).eq.' ' .and. fnsmcc(1:8).eq.' ') then + call getsmc(wetanl,len,lsoil,smcanl,me) + endif + call qcmxmn('smc1a ',smcanl(1,1),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2a ',smcanl(1,2),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3a ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4a ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + if(fnstca(1:8).eq.' ') then + call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) + endif + call qcmxmn('stc1a ',stcanl(1,1),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2a ',stcanl(1,2),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3a ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4a ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('vega ',veganl,slianl,snoanl,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('veta ',vetanl,slianl,snoanl,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sota ',sotanl,slianl,snoanl,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+16l]---------------------------------------------------------------------- + call qcmxmn('vmna ',vmnanl,slianl,snoanl,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxa ',vmxanl,slianl,snoanl,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpa ',slpanl,slianl,snoanl,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absa ',absanl,slianl,snoanl,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu ---------------------------------------------------------------------------- +! +! monitoring prints +! + if (monanl) then + if (me .eq. 0) then + print *,' ' + print *,'monitor of time and space interpolated analysis' + print *,' ' +! call count(slianl,snoanl,len) + print *,' ' + call monitr('tsfanl',tsfanl,slianl,snoanl,len) + call monitr('albanl',albanl,slianl,snoanl,len) + call monitr('aisanl',aisanl,slianl,snoanl,len) + call monitr('snoanl',snoanl,slianl,snoanl,len) + call monitr('scvanl',scvanl,slianl,snoanl,len) + call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) + call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) + call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) + call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) +!clu [+4l] add smcanl(3:4) and stcanl(3:4) + if(lsoil.gt.2) then + call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + endif + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) +! if (gaus) then + call monitr('cvaanl',cvanl ,slianl,snoanl,len) + call monitr('cvbanl',cvbanl,slianl,snoanl,len) + call monitr('cvtanl',cvtanl,slianl,snoanl,len) +! endif + call monitr('slianl',slianl,slianl,snoanl,len) +! call monitr('plranl',plranl,slianl,snoanl,len) + call monitr('orog ',orog ,slianl,snoanl,len) + call monitr('veganl',veganl,slianl,snoanl,len) + call monitr('vetanl',vetanl,slianl,snoanl,len) + call monitr('sotanl',sotanl,slianl,snoanl,len) +!cwu [+2l] add sih, sic + call monitr('sihanl',sihanl,slianl,snoanl,len) + call monitr('sicanl',sicanl,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnanl',vmnanl,slianl,snoanl,len) + call monitr('vmxanl',vmxanl,slianl,snoanl,len) + call monitr('slpanl',slpanl,slianl,snoanl,len) + call monitr('absanl',absanl,slianl,snoanl,len) + endif + + endif +! +! read in forecast fields if needed +! + if (me .eq. 0) then + write(6,*) '==============' + write(6,*) ' fcst guess' + write(6,*) '==============' + endif +! + percrit=critp2 +! + if(deads) then +! +! fill in guess array with analysis if dead start. +! + percrit=critp3 + if (me .eq. 0) write(6,*) 'this run is dead start run' + call filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, + & vegfcs,vetfcs,sotfcs,alffcs, +!cwu [+1l] add ()fcs for sih, sic + & sihfcs,sicfcs, +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsfanl,wetanl,snoanl,zoranl,albanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,aisanl, + & veganl,vetanl,sotanl,alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & len,lsoil) + if(sig1t(1).ne.0.) then + call usesgt(sig1t,slianl,tg3anl,len,lsoil,tsffcs,stcfcs, + & tsfimx) + do i=1,len + icefl2(i) = sicfcs(i) .gt. 0.99999 + enddo + kqcm=1 + call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + else + percrit=critp2 +! +! make reverse angulation correction to tsf +! make reverse orography correction to tg3 +! + if (use_ufo) then + orogd = orog - orog_uf +! +! The tiled version of the substrate temperature is properly +! adjusted to the terrain. Only invoke when using the old +! global tg3 grib file. +! + if ( index(fntg3c, "tileX.nc") == 0) then ! global file + ztsfc = 1.0 + call tsfcor(tg3fcs,orogd,slmask,ztsfc,len,-rlapse) + endif + ztsfc = 0. + call tsfcor(tsffcs,orogd,slmask,ztsfc,len,-rlapse) + else + ztsfc = 0. + call tsfcor(tsffcs,orog,slmask,ztsfc,len,-rlapse) + endif + +!clu [+12l] -------------------------------------------------------------- +! +! compute soil moisture liquid-to-total ratio over land +! + do j=1, lsoil + do i=1, len + if(smcfcs(i,j) .ne. 0.) then + swratio(i,j) = slcfcs(i,j)/smcfcs(i,j) + else + swratio(i,j) = -999. + endif + enddo + enddo +!clu ----------------------------------------------------------------------- +! + if(lqcbgs .and. irtacn .eq. 0) then + call qcsli(slianl,slifcs,len,me) + call albocn(albfcs,slmask,albomx,len) + do i=1,len + icefl2(i) = sicfcs(i) .gt. 0.99999 + enddo + kqcm=1 + call qcmxmn('snof ',snofcs,slifcs,snofcs,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('tsff ',tsffcs,slifcs,snofcs,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('albf ',albfcs(1,kk),slifcs,snofcs,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + & then + call qcmxmn('wetf ',wetfcs,slifcs,snofcs,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zorf ',zorfcs,slifcs,snofcs,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) +! call qcmxmn('plnf ',plrfcs,slifcs,snofcs,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('tg3f ',tg3fcs,slifcs,snofcs,icefl1, + & tg3lmx,tg3lmn,tg3omx,tg3omn,tg3imx,tg3imn, + & tg3jmx,tg3jmn,tg3smx,tg3smn,epstg3, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!cwu [+8l] --------------------------------------------------------------- + call qcmxmn('sihf ',sihfcs,slifcs,snofcs,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sicf ',sicfcs,slifcs,snofcs,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc1f ',smcfcs(1,1),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2f ',smcfcs(1,2),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcfcs(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3f ',smcfcs(1,3),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4f ',smcfcs(1,4),slifcs,snofcs,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('stc1f ',stcfcs(1,1),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2f ',stcfcs(1,2),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcfcs(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3f ',stcfcs(1,3),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4f ',stcfcs(1,4),slifcs,snofcs,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('vegf ',vegfcs,slifcs,snofcs,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vetf ',vetfcs,slifcs,snofcs,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sotf ',sotfcs,slifcs,snofcs,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) + +!clu [+16l] --------------------------------------------------------------- + call qcmxmn('vmnf ',vmnfcs,slifcs,snofcs,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxf ',vmxfcs,slifcs,snofcs,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpf ',slpfcs,slifcs,snofcs,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absf ',absfcs,slifcs,snofcs,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu ----------------------------------------------------------------------- + endif + endif +! + if (monfcs) then + if (me .eq. 0) then + print *,' ' + print *,'monitor of guess' + print *,' ' +! call count(slifcs,snofcs,len) + print *,' ' + call monitr('tsffcs',tsffcs,slifcs,snofcs,len) + call monitr('albfcs',albfcs,slifcs,snofcs,len) + call monitr('aisfcs',aisfcs,slifcs,snofcs,len) + call monitr('snofcs',snofcs,slifcs,snofcs,len) + call monitr('smcfcs1',smcfcs(1,1),slifcs,snofcs,len) + call monitr('smcfcs2',smcfcs(1,2),slifcs,snofcs,len) + call monitr('stcfcs1',stcfcs(1,1),slifcs,snofcs,len) + call monitr('stcfcs2',stcfcs(1,2),slifcs,snofcs,len) +!clu [+4l] add smcfcs(3:4) and stcfcs(3:4) + if(lsoil.gt.2) then + call monitr('smcfcs3',smcfcs(1,3),slifcs,snofcs,len) + call monitr('smcfcs4',smcfcs(1,4),slifcs,snofcs,len) + call monitr('stcfcs3',stcfcs(1,3),slifcs,snofcs,len) + call monitr('stcfcs4',stcfcs(1,4),slifcs,snofcs,len) + endif + call monitr('tg3fcs',tg3fcs,slifcs,snofcs,len) + call monitr('zorfcs',zorfcs,slifcs,snofcs,len) +! if (gaus) then + call monitr('cvafcs',cvfcs ,slifcs,snofcs,len) + call monitr('cvbfcs',cvbfcs,slifcs,snofcs,len) + call monitr('cvtfcs',cvtfcs,slifcs,snofcs,len) +! endif + call monitr('slifcs',slifcs,slifcs,snofcs,len) +! call monitr('plrfcs',plrfcs,slifcs,snofcs,len) + call monitr('orog ',orog ,slifcs,snofcs,len) + call monitr('vegfcs',vegfcs,slifcs,snofcs,len) + call monitr('vetfcs',vetfcs,slifcs,snofcs,len) + call monitr('sotfcs',sotfcs,slifcs,snofcs,len) +!cwu [+2l] add sih, sic + call monitr('sihfcs',sihfcs,slifcs,snofcs,len) + call monitr('sicfcs',sicfcs,slifcs,snofcs,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnfcs',vmnfcs,slifcs,snofcs,len) + call monitr('vmxfcs',vmxfcs,slifcs,snofcs,len) + call monitr('slpfcs',slpfcs,slifcs,snofcs,len) + call monitr('absfcs',absfcs,slifcs,snofcs,len) + endif + endif +! +!... update annual cycle in the sst guess.. +! +! if(lprnt) print *,'tsfclm=',tsfclm(iprnt),' tsfcl2=',tsfcl2(iprnt) +! *,' tsffcs=',tsffcs(iprnt),' slianl=',slianl(iprnt) + + if (fh-deltsfc > -0.001 ) then + do i=1,len + if(slianl(i) == 0.0) then + tsffcs(i) = tsffcs(i) + (tsfclm(i) - tsfcl2(i)) + endif + enddo + endif +! +! quality control analysis using forecast guess +! + call qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi,len,lsoil, + & snoanl,aisanl,slianl,tsfanl,albanl, + & zoranl,smcanl, + & smcclm,tsfsmx,albomx,zoromx,me) +! +! blend climatology and predicted fields +! + if(me .eq. 0) then + write(6,*) '==============' + write(6,*) ' merging' + write(6,*) '==============' + endif +! if(lprnt) print *,' tsffcs=',tsffcs(iprnt) +! + percrit=critp3 +! +! merge analysis and forecast. note tg3, ais are not merged +! + call merge(len,lsoil,iy,im,id,ih,fh,deltsfc, + & sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, + & cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, + & vetfcs,sotfcs,alffcs, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,veganl, + & vetanl,sotanl,alfanl, + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, + & calfl,calfs, + & csihl,csihs,csicl,csics, + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvmn,irtvmx,irtslp,irtabs, + & irtvet,irtsot,irtalf,landice,me) + + call setzro(snoanl,epssno,len) + +! if(lprnt) print *,' tanlm=',tsfanl(iprnt),' tfcsm=',tsffcs(iprnt) +! if(lprnt) print *,' sliam=',slianl(iprnt),' slifm=',slifcs(iprnt) + +! +! new ice/melted ice +! + call newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, +!cwu [+1l] add sihnew, aislim, sihanl & sicanl + & sihnew,aislim,sihanl,sicanl, + & albanl,snoanl,zoranl,smcanl,stcanl, + & albomx,snoomx,zoromx,smcomx,smcimx, +!cwu [-1l/+1l] change albimx to albimn - note albimx & albimn have been modified +! & tsfomn,tsfimx,albimx,zorimx,tgice, + & tsfomn,tsfimx,albimn,zorimx,tgice, + & rla,rlo,me) + +! if(lprnt) print *,'tsfanl=',tsfanl(iprnt),' tsffcs=',tsffcs(iprnt) +! if(lprnt) print *,' slian=',slianl(iprnt),' slifn=',slifcs(iprnt) +! +! set tsfc to tsnow over snow +! + call snosfc(snoanl,tsfanl,tsfsmx,len,me) +! + do i=1,len + icefl2(i) = sicanl(i) .gt. 0.99999 + enddo + kqcm=0 + call qcmxmn('snowm ',snoanl,slianl,snoanl,icefl1, + & snolmx,snolmn,snoomx,snoomn,snoimx,snoimn, + & snojmx,snojmn,snosmx,snosmn,epssno, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('tsfm ',tsfanl,slianl,snoanl,icefl2, + & tsflmx,tsflmn,tsfomx,tsfomn,tsfimx,tsfimn, + & tsfjmx,tsfjmn,tsfsmx,tsfsmn,epstsf, + & rla,rlo,len,kqcm,percrit,lgchek,me) + do kk = 1, 4 + call qcmxmn('albm ',albanl(1,kk),slianl,snoanl,icefl1, + & alblmx,alblmn,albomx,albomn,albimx,albimn, + & albjmx,albjmn,albsmx,albsmn,epsalb, + & rla,rlo,len,kqcm,percrit,lgchek,me) + enddo + if(fnwetc(1:8).ne.' ' .or. fnweta(1:8).ne.' ' ) + & then + call qcmxmn('wetm ',wetanl,slianl,snoanl,icefl1, + & wetlmx,wetlmn,wetomx,wetomn,wetimx,wetimn, + & wetjmx,wetjmn,wetsmx,wetsmn,epswet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('zorm ',zoranl,slianl,snoanl,icefl1, + & zorlmx,zorlmn,zoromx,zoromn,zorimx,zorimn, + & zorjmx,zorjmn,zorsmx,zorsmn,epszor, + & rla,rlo,len,kqcm,percrit,lgchek,me) +! if(fnplrc(1:8).ne.' ' .or. fnplra(1:8).ne.' ' ) +! & then +! call qcmxmn('plntm ',plranl,slianl,snoanl,icefl1, +! & plrlmx,plrlmn,plromx,plromn,plrimx,plrimn, +! & plrjmx,plrjmn,plrsmx,plrsmn,epsplr, +! & rla,rlo,len,kqcm,percrit,lgchek,me) +! endif + call qcmxmn('stc1m ',stcanl(1,1),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc2m ',stcanl(1,2),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add stcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('stc3m ',stcanl(1,3),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('stc4m ',stcanl(1,4),slianl,snoanl,icefl1, + & stclmx,stclmn,stcomx,stcomn,stcimx,stcimn, + & stcjmx,stcjmn,stcsmx,stcsmn,eptsfc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + call qcmxmn('smc1m ',smcanl(1,1),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc2m ',smcanl(1,2),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+8l] add smcanl(3:4) + if(lsoil.gt.2) then + call qcmxmn('smc3m ',smcanl(1,3),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('smc4m ',smcanl(1,4),slianl,snoanl,icefl1, + & smclmx,smclmn,smcomx,smcomn,smcimx,smcimn, + & smcjmx,smcjmn,smcsmx,smcsmn,epssmc, + & rla,rlo,len,kqcm,percrit,lgchek,me) + endif + kqcm=1 + call qcmxmn('vegm ',veganl,slianl,snoanl,icefl1, + & veglmx,veglmn,vegomx,vegomn,vegimx,vegimn, + & vegjmx,vegjmn,vegsmx,vegsmn,epsveg, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vetm ',vetanl,slianl,snoanl,icefl1, + & vetlmx,vetlmn,vetomx,vetomn,vetimx,vetimn, + & vetjmx,vetjmn,vetsmx,vetsmn,epsvet, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sotm ',sotanl,slianl,snoanl,icefl1, + & sotlmx,sotlmn,sotomx,sotomn,sotimx,sotimn, + & sotjmx,sotjmn,sotsmx,sotsmn,epssot, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!cwu [+8l] add sih, sic, + call qcmxmn('sihm ',sihanl,slianl,snoanl,icefl1, + & sihlmx,sihlmn,sihomx,sihomn,sihimx,sihimn, + & sihjmx,sihjmn,sihsmx,sihsmn,epssih, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('sicm ',sicanl,slianl,snoanl,icefl1, + & siclmx,siclmn,sicomx,sicomn,sicimx,sicimn, + & sicjmx,sicjmn,sicsmx,sicsmn,epssic, + & rla,rlo,len,kqcm,percrit,lgchek,me) +!clu [+16l] add vmn, vmx, slp, abs + call qcmxmn('vmnm ',vmnanl,slianl,snoanl,icefl1, + & vmnlmx,vmnlmn,vmnomx,vmnomn,vmnimx,vmnimn, + & vmnjmx,vmnjmn,vmnsmx,vmnsmn,epsvmn, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('vmxm ',vmxanl,slianl,snoanl,icefl1, + & vmxlmx,vmxlmn,vmxomx,vmxomn,vmximx,vmximn, + & vmxjmx,vmxjmn,vmxsmx,vmxsmn,epsvmx, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('slpm ',slpanl,slianl,snoanl,icefl1, + & slplmx,slplmn,slpomx,slpomn,slpimx,slpimn, + & slpjmx,slpjmn,slpsmx,slpsmn,epsslp, + & rla,rlo,len,kqcm,percrit,lgchek,me) + call qcmxmn('absm ',absanl,slianl,snoanl,icefl1, + & abslmx,abslmn,absomx,absomn,absimx,absimn, + & absjmx,absjmn,abssmx,abssmn,epsabs, + & rla,rlo,len,kqcm,percrit,lgchek,me) + +! + if(me .eq. 0) then + write(6,*) '==============' + write(6,*) 'final results' + write(6,*) '==============' + endif +! +! foreward correction to tg3 and tsf at the last stage +! +! if(lprnt) print *,' tsfbc=',tsfanl(iprnt) + if (use_ufo) then +! +! The tiled version of the substrate temperature is properly +! adjusted to the terrain. Only invoke when using the old +! global tg3 grib file. +! + if ( index(fntg3c, "tileX.nc") == 0) then ! global file + ztsfc = 1. + call tsfcor(tg3anl,orogd,slmask,ztsfc,len,rlapse) + endif + ztsfc = 0. + call tsfcor(tsfanl,orogd,slmask,ztsfc,len,rlapse) + else + ztsfc = 0. + call tsfcor(tsfanl,orog,slmask,ztsfc,len,rlapse) + endif +! if(lprnt) print *,' tsfaf=',tsfanl(iprnt) +! +! check the final merged product +! + if (monmer) then + if(me .eq. 0) then + print *,' ' + print *,'monitor of updated surface fields' + print *,' (includes angulation correction)' + print *,' ' +! call count(slianl,snoanl,len) + print *,' ' + call monitr('tsfanl',tsfanl,slianl,snoanl,len) + call monitr('albanl',albanl,slianl,snoanl,len) + call monitr('aisanl',aisanl,slianl,snoanl,len) + call monitr('snoanl',snoanl,slianl,snoanl,len) + call monitr('smcanl1',smcanl(1,1),slianl,snoanl,len) + call monitr('smcanl2',smcanl(1,2),slianl,snoanl,len) + call monitr('stcanl1',stcanl(1,1),slianl,snoanl,len) + call monitr('stcanl2',stcanl(1,2),slianl,snoanl,len) +!clu [+4l] add smcanl(3:4) and stcanl(3:4) + if(lsoil.gt.2) then + call monitr('smcanl3',smcanl(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcanl(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcanl(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcanl(1,4),slianl,snoanl,len) + call monitr('tg3anl',tg3anl,slianl,snoanl,len) + call monitr('zoranl',zoranl,slianl,snoanl,len) + endif +! if (gaus) then + call monitr('cvaanl',cvanl ,slianl,snoanl,len) + call monitr('cvbanl',cvbanl,slianl,snoanl,len) + call monitr('cvtanl',cvtanl,slianl,snoanl,len) +! endif + call monitr('slianl',slianl,slianl,snoanl,len) +! call monitr('plranl',plranl,slianl,snoanl,len) + call monitr('orog ',orog ,slianl,snoanl,len) + call monitr('cnpanl',cnpanl,slianl,snoanl,len) + call monitr('veganl',veganl,slianl,snoanl,len) + call monitr('vetanl',vetanl,slianl,snoanl,len) + call monitr('sotanl',sotanl,slianl,snoanl,len) +!cwu [+2l] add sih, sic, + call monitr('sihanl',sihanl,slianl,snoanl,len) + call monitr('sicanl',sicanl,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmnanl',vmnanl,slianl,snoanl,len) + call monitr('vmxanl',vmxanl,slianl,snoanl,len) + call monitr('slpanl',slpanl,slianl,snoanl,len) + call monitr('absanl',absanl,slianl,snoanl,len) + endif + endif +! + if (mondif) then + do i=1,len + tsffcs(i) = tsfanl(i) - tsffcs(i) + snofcs(i) = snoanl(i) - snofcs(i) + tg3fcs(i) = tg3anl(i) - tg3fcs(i) + zorfcs(i) = zoranl(i) - zorfcs(i) +! plrfcs(i) = plranl(i) - plrfcs(i) +! albfcs(i) = albanl(i) - albfcs(i) + slifcs(i) = slianl(i) - slifcs(i) + aisfcs(i) = aisanl(i) - aisfcs(i) + cnpfcs(i) = cnpanl(i) - cnpfcs(i) + vegfcs(i) = veganl(i) - vegfcs(i) + vetfcs(i) = vetanl(i) - vetfcs(i) + sotfcs(i) = sotanl(i) - sotfcs(i) +!clu [+2l] add sih, sic + sihfcs(i) = sihanl(i) - sihfcs(i) + sicfcs(i) = sicanl(i) - sicfcs(i) +!clu [+4l] add vmn, vmx, slp, abs + vmnfcs(i) = vmnanl(i) - vmnfcs(i) + vmxfcs(i) = vmxanl(i) - vmxfcs(i) + slpfcs(i) = slpanl(i) - slpfcs(i) + absfcs(i) = absanl(i) - absfcs(i) + enddo + do j = 1,lsoil + do i = 1,len + smcfcs(i,j) = smcanl(i,j) - smcfcs(i,j) + stcfcs(i,j) = stcanl(i,j) - stcfcs(i,j) + enddo + enddo + do j = 1,4 + do i = 1,len + albfcs(i,j) = albanl(i,j) - albfcs(i,j) + enddo + enddo +! +! monitoring prints +! + if(me .eq. 0) then + print *,' ' + print *,'monitor of difference' + print *,' (includes angulation correction)' + print *,' ' + call monitr('tsfdif',tsffcs,slianl,snoanl,len) + call monitr('albdif',albfcs,slianl,snoanl,len) + call monitr('albdif1',albfcs,slianl,snoanl,len) + call monitr('albdif2',albfcs(1,2),slianl,snoanl,len) + call monitr('albdif3',albfcs(1,3),slianl,snoanl,len) + call monitr('albdif4',albfcs(1,4),slianl,snoanl,len) + call monitr('aisdif',aisfcs,slianl,snoanl,len) + call monitr('snodif',snofcs,slianl,snoanl,len) + call monitr('smcanl1',smcfcs(1,1),slianl,snoanl,len) + call monitr('smcanl2',smcfcs(1,2),slianl,snoanl,len) + call monitr('stcanl1',stcfcs(1,1),slianl,snoanl,len) + call monitr('stcanl2',stcfcs(1,2),slianl,snoanl,len) +!clu [+4l] add smcfcs(3:4) and stc(3:4) + if(lsoil.gt.2) then + call monitr('smcanl3',smcfcs(1,3),slianl,snoanl,len) + call monitr('smcanl4',smcfcs(1,4),slianl,snoanl,len) + call monitr('stcanl3',stcfcs(1,3),slianl,snoanl,len) + call monitr('stcanl4',stcfcs(1,4),slianl,snoanl,len) + endif + call monitr('tg3dif',tg3fcs,slianl,snoanl,len) + call monitr('zordif',zorfcs,slianl,snoanl,len) +! if (gaus) then + call monitr('cvadif',cvfcs ,slianl,snoanl,len) + call monitr('cvbdif',cvbfcs,slianl,snoanl,len) + call monitr('cvtdif',cvtfcs,slianl,snoanl,len) +! endif + call monitr('slidif',slifcs,slianl,snoanl,len) +! call monitr('plrdif',plrfcs,slianl,snoanl,len) + call monitr('cnpdif',cnpfcs,slianl,snoanl,len) + call monitr('vegdif',vegfcs,slianl,snoanl,len) + call monitr('vetdif',vetfcs,slianl,snoanl,len) + call monitr('sotdif',sotfcs,slianl,snoanl,len) +!cwu [+2l] add sih, sic + call monitr('sihdif',sihfcs,slianl,snoanl,len) + call monitr('sicdif',sicfcs,slianl,snoanl,len) +!clu [+4l] add vmn, vmx, slp, abs + call monitr('vmndif',vmnfcs,slianl,snoanl,len) + call monitr('vmxdif',vmxfcs,slianl,snoanl,len) + call monitr('slpdif',slpfcs,slianl,snoanl,len) + call monitr('absdif',absfcs,slianl,snoanl,len) + endif + endif +! +! + do i=1,len + tsffcs(i) = tsfanl(i) + snofcs(i) = snoanl(i) + tg3fcs(i) = tg3anl(i) + zorfcs(i) = zoranl(i) +! plrfcs(i) = plranl(i) +! albfcs(i) = albanl(i) + slifcs(i) = slianl(i) + aisfcs(i) = aisanl(i) + cvfcs(i) = cvanl(i) + cvbfcs(i) = cvbanl(i) + cvtfcs(i) = cvtanl(i) + cnpfcs(i) = cnpanl(i) + vegfcs(i) = veganl(i) + vetfcs(i) = vetanl(i) + sotfcs(i) = sotanl(i) +!clu [+4l] add vmn, vmx, slp, abs + vmnfcs(i) = vmnanl(i) + vmxfcs(i) = vmxanl(i) + slpfcs(i) = slpanl(i) + absfcs(i) = absanl(i) + enddo + do j = 1,lsoil + do i = 1,len + smcfcs(i,j) = smcanl(i,j) + if (slifcs(i) .gt. 0.0) then + stcfcs(i,j) = stcanl(i,j) + else + stcfcs(i,j) = tsffcs(i) + endif + enddo + enddo + do j = 1,4 + do i = 1,len + albfcs(i,j) = albanl(i,j) + enddo + enddo + do j = 1,2 + do i = 1,len + alffcs(i,j) = alfanl(i,j) + enddo + enddo + +!cwu [+20l] update sihfcs, sicfcs. remove sea ice over non-ice points + crit=aislim + do i=1,len + sihfcs(i) = sihanl(i) + sitfcs(i) = tsffcs(i) + if (slifcs(i).ge.2.) then + if (sicfcs(i).gt.crit) then + tsffcs(i) = (sicanl(i)*tsffcs(i) + & + (sicfcs(i)-sicanl(i))*tgice)/sicfcs(i) + sitfcs(i) = (tsffcs(i)-tgice*(1.0-sicfcs(i))) / sicfcs(i) + else + tsffcs(i) = tsfanl(i) +! tsffcs(i) = tgice + sihfcs(i) = sihnew + endif + endif + sicfcs(i) = sicanl(i) + enddo + do i=1,len + if (slifcs(i).lt.1.5) then + sihfcs(i) = 0. + sicfcs(i) = 0. + sitfcs(i) = tsffcs(i) + else if ((slifcs(i).ge.1.5).and.(sicfcs(i).lt.crit)) then + print *,'warning: check, slifcs and sicfcs', + & slifcs(i),sicfcs(i) + endif + enddo + +! +! ensure the consistency between slc and smc +! + do k=1, lsoil + fixratio(k) = .false. + if (fsmcl(k).lt.99999.) fixratio(k) = .true. + enddo + + if(me .eq. 0 .and. print_debug) then + print *,'dbgx --fixratio:',(fixratio(k),k=1,lsoil) + endif + + do k=1, lsoil + if(fixratio(k)) then + do i = 1, len + if(swratio(i,k) .eq. -999.) then + slcfcs(i,k) = smcfcs(i,k) + else + slcfcs(i,k) = swratio(i,k) * smcfcs(i,k) + endif + if (slifcs(i) .ne. 1.0) slcfcs(i,k) = 1.0 ! flag value for non-land points. + enddo + endif + enddo +! set liquid soil moisture to a flag value of 1.0 + if (landice) then + do i = 1, len + if (slifcs(i) .eq. 1.0 .and. + & nint(vetfcs(i)) == veg_type_landice) then + do k=1, lsoil + slcfcs(i,k) = 1.0 + enddo + endif + enddo + end if +! +! ensure the consistency between snwdph and sheleg +! + if(fsnol .lt. 99999.) then + if(me .eq. 0 .and. print_debug) then + print *,'dbgx -- scale snwdph from sheleg' + endif + do i = 1, len + if(slifcs(i).eq.1.) swdfcs(i) = 10.* snofcs(i) + enddo + endif + +! sea ice model only uses the liquid equivalent depth. +! so update the physical depth only for display purposes. +! use the same 3:1 ratio used by ice model. + + do i = 1, len + if (slifcs(i).ne.1) swdfcs(i) = 3.*snofcs(i) + enddo + + do i = 1, len + if(slifcs(i).eq.1.) then + if(snofcs(i).ne.0. .and. swdfcs(i).eq.0.) then + print *,'dbgx --scale snwdph from sheleg', + + i, swdfcs(i), snofcs(i) + swdfcs(i) = 10.* snofcs(i) + endif + endif + enddo +! landice mods - impose same minimum snow depth at +! landice as noah lsm. also ensure +! lower thermal boundary condition +! and skin t is no warmer than freezing +! after adjustment to terrain. + if (landice) then + do i = 1, len + if (slifcs(i) .eq. 1.0 .and. + & nint(vetfcs(i)) == veg_type_landice) then + snofcs(i) = max(snofcs(i),100.0) ! in mm + swdfcs(i) = max(swdfcs(i),1000.0) ! in mm + tg3fcs(i) = min(tg3fcs(i),273.15) + tsffcs(i) = min(tsffcs(i),273.15) + endif + enddo + end if +! +! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) + return + end subroutine sfccycle + subroutine count(slimsk,sno,ijmax) + use machine , only : kind_io8,kind_io4 + implicit none + real (kind=kind_io8) rl3,rl1,rl0,rl2,rl6,rl7,rl4,rl5 + integer l8,l7,l1,l2,ijmax,l0,l3,l5,l6,l4,ij +! + real (kind=kind_io8) slimsk(1),sno(1) +! +! count number of points for the four surface conditions +! + l0 = 0 + l1 = 0 + l2 = 0 + l3 = 0 + l4 = 0 + do ij=1,ijmax + if(slimsk(ij).eq.0.) l1 = l1 + 1 + if(slimsk(ij).eq.1. .and. sno(ij).le.0.) l0 = l0 + 1 + if(slimsk(ij).eq.2. .and. sno(ij).le.0.) l2 = l2 + 1 + if(slimsk(ij).eq.1. .and. sno(ij).gt.0.) l3 = l3 + 1 + if(slimsk(ij).eq.2. .and. sno(ij).gt.0.) l4 = l4 + 1 + enddo + l5 = l0 + l3 + l6 = l2 + l4 + l7 = l1 + l6 + l8 = l1 + l5 + l6 + rl0 = float(l0) / float(l8)*100. + rl3 = float(l3) / float(l8)*100. + rl1 = float(l1) / float(l8)*100. + rl2 = float(l2) / float(l8)*100. + rl4 = float(l4) / float(l8)*100. + rl5 = float(l5) / float(l8)*100. + rl6 = float(l6) / float(l8)*100. + rl7 = float(l7) / float(l8)*100. + print *,'1) no. of not snow-covered land points ',l0,' ',rl0,' ' + print *,'2) no. of snow covered land points ',l3,' ',rl3,' ' + print *,'3) no. of open sea points ',l1,' ',rl1,' ' + print *,'4) no. of not snow-covered seaice points ',l2,' ',rl2,' ' + print *,'5) no. of snow covered sea ice points ',l4,' ',rl4,' ' + print *,' ' + print *,'6) no. of land points ',l5,' ',rl5,' ' + print *,'7) no. sea points (including sea ice) ',l7,' ',rl7,' ' + print *,' (no. of sea ice points) (',l6,')',' ',rl6,' ' + print *,' ' + print *,'9) no. of total grid points ',l8 +! print *,' ' +! print *,' ' + +! +! if(lprnt) print *,' tsffcsf=',tsffcs(iprnt) + return + end + subroutine monitr(lfld,fld,slimsk,sno,ijmax) + use machine , only : kind_io8,kind_io4 + implicit none + integer ij,n,ijmax +! + real (kind=kind_io8) fld(ijmax), slimsk(ijmax),sno(ijmax) +! + real (kind=kind_io8) rmax(5),rmin(5) + character(len=*) lfld +! +! find max/min +! + do n=1,5 + rmax(n) = -9.e20 + rmin(n) = 9.e20 + enddo +! + do ij=1,ijmax + if(slimsk(ij).eq.0.) then + rmax(1) = max(rmax(1), fld(ij)) + rmin(1) = min(rmin(1), fld(ij)) + elseif(slimsk(ij).eq.1.) then + if(sno(ij).le.0.) then + rmax(2) = max(rmax(2), fld(ij)) + rmin(2) = min(rmin(2), fld(ij)) + else + rmax(4) = max(rmax(4), fld(ij)) + rmin(4) = min(rmin(4), fld(ij)) + endif + else + if(sno(ij).le.0.) then + rmax(3) = max(rmax(3), fld(ij)) + rmin(3) = min(rmin(3), fld(ij)) + else + rmax(5) = max(rmax(5), fld(ij)) + rmin(5) = min(rmin(5), fld(ij)) + endif + endif + enddo +! + print 100,lfld + print 101,rmax(1),rmin(1) + print 102,rmax(2),rmin(2), rmax(4), rmin(4) + print 103,rmax(3),rmin(3), rmax(5), rmin(5) +! +! print 102,rmax(2),rmin(2) +! print 103,rmax(3),rmin(3) +! print 104,rmax(4),rmin(4) +! print 105,rmax(5),rmin(5) + 100 format('0 *** ',a8,' ***') + 101 format(' open sea ......... max=',e12.4,' min=',e12.4) + 102 format(' land nosnow/snow .. max=',e12.4,' min=',e12.4 + &, ' max=',e12.4,' min=',e12.4) + 103 format(' seaice nosnow/snow max=',e12.4,' min=',e12.4 + &, ' max=',e12.4,' min=',e12.4) +! +! 100 format('0',2x,'*** ',a8,' ***') +! 102 format(2x,' land without snow ..... max=',e12.4,' min=',e12.4) +! 103 format(2x,' seaice without snow ... max=',e12.4,' min=',e12.4) +! 104 format(2x,' land with snow ........ max=',e12.4,' min=',e12.4) +! 105 format(2x,' sea ice with snow ..... max=',e12.4,' min=',e12.4) +! + return + end + subroutine dayoyr(iyr,imo,idy,ldy) + implicit none + integer ldy,i,idy,iyr,imo +! +! this routine figures out the day of the year given imo and idy +! + integer month(13) + data month/0,31,28,31,30,31,30,31,31,30,31,30,31/ + if(mod(iyr,4).eq.0) month(3) = 29 + ldy = idy + do i = 1, imo + ldy = ldy + month(i) + enddo + return + end + subroutine hmskrd(lugb,imsk,jmsk,fnmskh, + & kpds5,slmskh,gausm,blnmsk,bltmsk,me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, xdata, ydata, print_debug + implicit none + integer kpds5,me,i,imsk,jmsk,lugb +! + character*500 fnmskh +! + real (kind=kind_io8) slmskh(mdata) + logical gausm + real (kind=kind_io8) blnmsk,bltmsk +! + imsk = xdata + jmsk = ydata + + if (me .eq. 0 .and. print_debug) then + write(6,*)' imsk=',imsk,' jmsk=',jmsk,' xdata=',xdata,' ydata=' + &, ydata + endif + + call fixrdg(lugb,imsk,jmsk,fnmskh, + & kpds5,slmskh,gausm,blnmsk,bltmsk,me) + +! print *,'in sfc_sub, aft fixrdg,slmskh=',maxval(slmskh), +! & minval(slmskh),'mdata=',mdata,'imsk*jmsk=',imsk*jmsk + + do i=1,imsk*jmsk + slmskh(i) = nint(slmskh(i)) + enddo +! + return + end + subroutine fixrdg(lugb,idim,jdim,fngrib, + & kpds5,gdata,gaus,blno,blto,me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + integer lgrib,n,lskip,jret,j,ndata,lugi,jdim,idim,lugb, + & iret, me,kpds5,kdata,i,w3kindreal,w3kindint +! + character*(*) fngrib +! + real (kind=kind_io8) gdata(idim*jdim) + logical gaus + real (kind=kind_io8) blno,blto + real (kind=kind_io8) data8(idim*jdim) + real (kind=kind_io4), allocatable :: data4(:) +! + logical*1 lbms(mdata) +! + integer kpds(200),kgds(200) + integer jpds(200),jgds(200), kpds0(200) +! +! if(me .eq. 0 .and. print_debug) then +! write(6,*) ' ' +! write(6,*) '************************************************' +! endif +! + close(lugb) + call baopenr(lugb,fngrib,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fngrib) + print *,'error in opening file ',trim(fngrib) + call abort + endif + if (me .eq. 0 .and. print_debug) + & write(6,'(A6, A, A, I4)') ' file ',trim(fngrib), + & ' opened. unit=',lugb + lugi = 0 + lskip = -1 + n = 0 + jpds = -1 + jgds = -1 + jpds(5) = kpds5 + kpds = jpds +! + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) +! + if(me .eq. 0 .and. print_debug) then + write(6,*) ' first grib record.' + write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) + write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) + write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) + endif +! + kpds0=jpds + kpds0(4)=-1 + kpds0(18)=-1 + if(iret.ne.0) then + write(6,*) ' error in getgbh. iret: ', iret + if (iret == 99) write(6,*) ' field not found.' + call abort + endif +! + jpds = kpds0 + lskip = -1 + kdata=idim*jdim + call w3kind(w3kindreal,w3kindint) + if (w3kindreal == 8) then + call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data8,jret) + else if (w3kindreal == 4) then + allocate(data4(idim*jdim)) + call getgb(lugb,lugi,kdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data4,jret) + data8 = data4 + deallocate(data4) + else + write(0,*)' Invalid w3kindreal --- aborting' + call abort + endif +! + if(jret == 0) then + if(ndata.eq.0) then + write(6,*) ' error in getgb' + write(6,*) ' kpds=',kpds + write(6,*) ' kgds=',kgds + call abort + endif + idim = kgds(2) + jdim = kgds(3) + gaus = kgds(1).eq.4 + blno = kgds(5)*1.d-3 + blto = kgds(4)*1.d-3 + gdata(1:idim*jdim) = data8(1:idim*jdim) + if (me == 0 .and. print_debug) write(6,*) 'idim,jdim=',idim,jdim + &, ' gaus=',gaus,' blno=',blno,' blto=',blto + else + if (me ==. 0) write(6,*) 'idim,jdim=',idim,jdim + &, ' gaus=',gaus,' blno=',blno,' blto=',blto + write(6,*) ' error in getgb : jret=',jret + write(6,*) ' kpds(13)=',kpds(13),' kpds(15)=',kpds(15) + call abort + endif +! + return + end + subroutine getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr + &, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + integer j,me,kgds11 + real (kind=kind_io8) f0lon,f0lat,elon,dlon,dlat,rslat,wlon,rnlat +! +! get area of the grib record +! + integer kgds(22) + logical ijordr +! + if (me .eq. 0 .and. print_debug) then + write(6,*) ' kgds( 1-12)=',(kgds(j),j= 1,12) + write(6,*) ' kgds(13-22)=',(kgds(j),j=13,22) + endif +! + if(kgds(1).eq.0) then ! lat/lon grid +! + if (me .eq. 0 .and. print_debug) write(6,*) 'lat/lon grid' + dlat = float(kgds(10)) * 0.001 + dlon = float(kgds( 9)) * 0.001 + f0lon = float(kgds(5)) * 0.001 + f0lat = float(kgds(4)) * 0.001 + kgds11 = kgds(11) + if(kgds11.ge.128) then + wlon = f0lon - dlon*(kgds(2)-1) + elon = f0lon + if(dlon*kgds(2).gt.359.99) then + wlon =f0lon - dlon*kgds(2) + endif + dlon = -dlon + kgds11 = kgds11 - 128 + else + wlon = f0lon + elon = f0lon + dlon*(kgds(2)-1) + if(dlon*kgds(2).gt.359.99) then + elon = f0lon + dlon*kgds(2) + endif + endif + if(kgds11.ge.64) then + rnlat = f0lat + dlat*(kgds(3)-1) + rslat = f0lat + kgds11 = kgds11 - 64 + else + rnlat = f0lat + rslat = f0lat - dlat*(kgds(3)-1) + dlat = -dlat + endif + if(kgds11.ge.32) then + ijordr = .false. + else + ijordr = .true. + endif + + if(wlon.gt.180.) wlon = wlon - 360. + if(elon.gt.180.) elon = elon - 360. + wlon = nint(wlon*1000.) * 0.001 + elon = nint(elon*1000.) * 0.001 + rslat = nint(rslat*1000.) * 0.001 + rnlat = nint(rnlat*1000.) * 0.001 + return +! + elseif(kgds(1).eq.1) then ! mercator projection + write(6,*) 'mercator grid' + write(6,*) 'cannot process' + call abort +! + elseif(kgds(1).eq.2) then ! gnomonic projection + write(6,*) 'gnomonic grid' + write(6,*) 'error!! gnomonic projection not coded' + call abort +! + elseif(kgds(1).eq.3) then ! lambert conformal + write(6,*) 'lambert conformal' + write(6,*) 'cannot process' + call abort + elseif(kgds(1).eq.4) then ! gaussian grid +! + if (me .eq. 0 .and. print_debug) write(6,*) 'gaussian grid' + dlat = 99. + dlon = float(kgds( 9)) / 1000.0 + f0lon = float(kgds(5)) / 1000.0 + f0lat = 99. + kgds11 = kgds(11) + if(kgds11.ge.128) then + wlon = f0lon + elon = f0lon + if(dlon*kgds(2).gt.359.99) then + wlon = f0lon - dlon*kgds(2) + endif + dlon = -dlon + kgds11 = kgds11-128 + else + wlon = f0lon + elon = f0lon + dlon*(kgds(2)-1) + if(dlon*kgds(2).gt.359.99) then + elon = f0lon + dlon*kgds(2) + endif + endif + if(kgds11.ge.64) then + rnlat = 99. + rslat = 99. + kgds11 = kgds11 - 64 + else + rnlat = 99. + rslat = 99. + dlat = -99. + endif + if(kgds11.ge.32) then + ijordr = .false. + else + ijordr = .true. + endif + return +! + elseif(kgds(1).eq.5) then ! polar strereographic + write(6,*) 'polar stereographic grid' + write(6,*) 'cannot process' + call abort + return +! + elseif(kgds(1).eq.13) then ! oblique lambert conformal + write(6,*) 'oblique lambert conformal grid' + write(6,*) 'cannot process' + call abort +! + elseif(kgds(1).eq.50) then ! spherical coefficient + write(6,*) 'spherical coefficient' + write(6,*) 'cannot process' + call abort + return +! + elseif(kgds(1).eq.90) then ! space view perspective +! (orthographic grid) + write(6,*) 'space view perspective grid' + write(6,*) 'cannot process' + call abort + return +! + else ! unknown projection. abort. + write(6,*) 'error!! unknown map projection' + write(6,*) 'kgds(1)=',kgds(1) + print *,'error!! unknown map projection' + print *,'kgds(1)=',kgds(1) + call abort + endif +! + return + end + subroutine subst(data,imax,jmax,dlon,dlat,ijordr) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,ii,jj,jmax,imax,iret + real (kind=kind_io8) dlat,dlon +! + logical ijordr +! + real (kind=kind_io8) data(imax,jmax) + real (kind=kind_io8), allocatable :: work(:,:) +! + if(.not.ijordr.or. + & (ijordr.and.(dlat.gt.0..or.dlon.lt.0.))) then + allocate (work(imax,jmax)) + + if(.not.ijordr) then + do j=1,jmax + do i=1,imax + work(i,j) = data(j,i) + enddo + enddo + else + do j=1,jmax + do i=1,imax + work(i,j) = data(i,j) + enddo + enddo + endif + if (dlat > 0.0) then + if (dlon > 0.0) then + do j=1,jmax + jj = jmax - j + 1 + do i=1,imax + data(i,jj) = work(i,j) + enddo + enddo + else + do i=1,imax + data(imax-i+1,jj) = work(i,j) + enddo + endif + else + if (dlon > 0.0) then + do j=1,jmax + do i=1,imax + data(i,j) = work(i,j) + enddo + enddo + else + do j=1,jmax + do i=1,imax + data(imax-i+1,j) = work(i,j) + enddo + enddo + endif + endif + deallocate (work, stat=iret) + endif + return + end + subroutine la2ga(regin,imxin,jmxin,rinlon,rinlat,rlon,rlat,inttyp, + & gauout,len,lmask,rslmsk,slmask + &, outlat, outlon,me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + real (kind=kind_io8) wei4,wei3,wei2,sum2,sum1,sum3,wei1,sum4, + & wsum,tem,wsumiv,sums,sumn,wi2j2,x,y,wi1j1, + & wi1j2,wi2j1,rlat,rlon,aphi, + & rnume,alamd,denom + integer jy,ifills,ix,len,inttyp,me,i,j,jmxin,imxin,jq,jx,j1,j2, + & ii,i1,i2,kmami,it + integer nx,kxs,kxt + integer, allocatable, save :: imxnx(:) + integer, allocatable :: ifill(:) +! +! interpolation from lat/lon or gaussian grid to other lat/lon grid +! + real (kind=kind_io8) outlon(len),outlat(len),gauout(len), + & slmask(len) + real (kind=kind_io8) regin (imxin,jmxin),rslmsk(imxin,jmxin) +! + real (kind=kind_io8) rinlat(jmxin), rinlon(imxin) + integer iindx1(len), iindx2(len) + integer jindx1(len), jindx2(len) + real (kind=kind_io8) ddx(len), ddy(len), wrk(len) +! + logical lmask +! + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, len_thread, i1_t, i2_t + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + if (.not. allocated(imxnx)) allocate (imxnx(num_threads)) + endif +! + if (me == 0 .and. print_debug) print *,' num_threads =', + & num_threads,' me=',me +! +! if(me .eq. 0) then +! print *,'rlon=',rlon,' me=',me +! print *,'rlat=',rlat,' me=',me,' imxin=',imxin,' jmxin=',jmxin +! endif +! +! do j=1,jmxin +! if(rlat.gt.0.) then +! rinlat(j) = rlat - float(j-1)*dlain +! else +! rinlat(j) = rlat + float(j-1)*dlain +! endif +! enddo +! +! if (me .eq. 0) then +! print *,'rinlat=' +! print *,(rinlat(j),j=1,jmxin) +! print *,'rinlon=' +! print *,(rinlon(i),i=1,imxin) +! +! print *,'outlat=' +! print *,(outlat(j),j=1,len) +! print *,(outlon(j),j=1,len) +! endif +! +! do i=1,imxin +! rinlon(i) = rlon + float(i-1)*dloin +! enddo +! +! print *,'rinlon=' +! print *,(rinlon(i),i=1,imxin) +! + len_thread_m = (len+num_threads-1) / num_threads + + if (inttyp /=1) allocate (ifill(num_threads)) +! +!$omp parallel do default(none) +!$omp+private(i1_t,i2_t,len_thread,it,i,ii,i1,i2) +!$omp+private(j,j1,j2,jq,ix,jy,nx,kxs,kxt,kmami) +!$omp+private(alamd,denom,rnume,aphi,x,y,wsum,wsumiv,sum1,sum2) +!$omp+private(sum3,sum4,wi1j1,wi2j1,wi1j2,wi2j2,wei1,wei2,wei3,wei4) +!$omp+private(sumn,sums) +!$omp+shared(imxin,jmxin,ifill) +!$omp+shared(outlon,outlat,wrk,iindx1,rinlon,jindx1,rinlat,ddx,ddy) +!$omp+shared(rlon,rlat,regin,gauout,imxnx) +!$omp+private(tem) +!$omp+shared(num_threads,len_thread_m,len,lmask,iindx2,jindx2,rslmsk) +!$omp+shared(inttyp,me,slmask) +! + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) + len_thread = i2_t-i1_t+1 +! +! find i-index for interpolation +! + do i=i1_t, i2_t + alamd = outlon(i) + if (alamd .lt. rlon) alamd = alamd + 360.0 + if (alamd .gt. 360.0+rlon) alamd = alamd - 360.0 + wrk(i) = alamd + iindx1(i) = imxin + enddo + do i=i1_t,i2_t + do ii=1,imxin + if(wrk(i) .ge. rinlon(ii)) iindx1(i) = ii + enddo + enddo + do i=i1_t,i2_t + i1 = iindx1(i) + if (i1 .lt. 1) i1 = imxin + i2 = i1 + 1 + if (i2 .gt. imxin) i2 = 1 + iindx1(i) = i1 + iindx2(i) = i2 + denom = rinlon(i2) - rinlon(i1) + if(denom.lt.0.) denom = denom + 360. + rnume = wrk(i) - rinlon(i1) + if(rnume.lt.0.) rnume = rnume + 360. + ddx(i) = rnume / denom + enddo +! +! find j-index for interplation +! + if(rlat.gt.0.) then + do j=i1_t,i2_t + jindx1(j)=0 + enddo + do jx=1,jmxin + do j=i1_t,i2_t + if(outlat(j).le.rinlat(jx)) jindx1(j) = jx + enddo + enddo + do j=i1_t,i2_t + jq = jindx1(j) + aphi=outlat(j) + if(jq.ge.1 .and. jq .lt. jmxin) then + j2=jq+1 + j1=jq + ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) + elseif (jq .eq. 0) then + j2=1 + j1=1 + if(abs(90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + else + j2=jmxin + j1=jmxin + if(abs(-90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + endif + jindx1(j)=j1 + jindx2(j)=j2 + enddo + else + do j=i1_t,i2_t + jindx1(j) = jmxin+1 + enddo + do jx=jmxin,1,-1 + do j=i1_t,i2_t + if(outlat(j).le.rinlat(jx)) jindx1(j) = jx + enddo + enddo + do j=i1_t,i2_t + jq = jindx1(j) + aphi=outlat(j) + if(jq.gt.1 .and. jq .le. jmxin) then + j2=jq + j1=jq-1 + ddy(j)=(aphi-rinlat(j1))/(rinlat(j2)-rinlat(j1)) + elseif (jq .eq. 1) then + j2=1 + j1=1 + if(abs(-90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(-90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + else + j2=jmxin + j1=jmxin + if(abs(90.-rinlat(j1)).gt.0.001) then + ddy(j)=(aphi-rinlat(j1))/(90.-rinlat(j1)) + else + ddy(j)=0.0 + endif + endif + jindx1(j)=j1 + jindx2(j)=j2 + enddo + endif +! +! if (me .eq. 0 .and. inttyp .eq. 1) then +! print *,'la2ga' +! print *,'iindx1' +! print *,(iindx1(n),n=1,len) +! print *,'iindx2' +! print *,(iindx2(n),n=1,len) +! print *,'jindx1' +! print *,(jindx1(n),n=1,len) +! print *,'jindx2' +! print *,(jindx2(n),n=1,len) +! print *,'ddy' +! print *,(ddy(n),n=1,len) +! print *,'ddx' +! print *,(ddx(n),n=1,len) +! endif +! + sum1 = 0. + sum2 = 0. + sum3 = 0. + sum4 = 0. + if (lmask) then + wei1 = 0. + wei2 = 0. + wei3 = 0. + wei4 = 0. + do i=1,imxin + sum1 = sum1 + regin(i,1) * rslmsk(i,1) + sum2 = sum2 + regin(i,jmxin) * rslmsk(i,jmxin) + wei1 = wei1 + rslmsk(i,1) + wei2 = wei2 + rslmsk(i,jmxin) +! + sum3 = sum3 + regin(i,1) * (1.0-rslmsk(i,1)) + sum4 = sum4 + regin(i,jmxin) * (1.0-rslmsk(i,jmxin)) + wei3 = wei3 + (1.0-rslmsk(i,1)) + wei4 = wei4 + (1.0-rslmsk(i,jmxin)) + enddo +! + if(wei1.gt.0.) then + sum1 = sum1 / wei1 + else + sum1 = 0. + endif + if(wei2.gt.0.) then + sum2 = sum2 / wei2 + else + sum2 = 0. + endif + if(wei3.gt.0.) then + sum3 = sum3 / wei3 + else + sum3 = 0. + endif + if(wei4.gt.0.) then + sum4 = sum4 / wei4 + else + sum4 = 0. + endif + else + do i=1,imxin + sum1 = sum1 + regin(i,1) + sum2 = sum2 + regin(i,jmxin) + enddo + sum1 = sum1 / imxin + sum2 = sum2 / imxin + sum3 = sum1 + sum4 = sum2 + endif +! +! print *,' sum1=',sum1,' sum2=',sum2 +! *,' sum3=',sum3,' sum4=',sum4 +! print *,' rslmsk=',(rslmsk(i,1),i=1,imxin) +! print *,' slmask=',(slmask(i),i=1,imxout) +! *,' j1=',jindx1(1),' j2=',jindx2(1) +! +! +! inttyp=1 take the closest point value +! + if(inttyp.eq.1) then + + do i=i1_t,i2_t + jy = jindx1(i) + if(ddy(i) .ge. 0.5) jy = jindx2(i) + ix = iindx1(i) + if(ddx(i) .ge. 0.5) ix = iindx2(i) +! +!cggg start +! + if (.not. lmask) then + + gauout(i) = regin(ix,jy) + + else + + if(slmask(i).eq.rslmsk(ix,jy)) then + + gauout(i) = regin(ix,jy) + + else + + i1 = ix + j1 = jy + +! spiral around until matching mask is found. + do nx=1,jmxin*imxin/2 + kxs=sqrt(4*nx-2.5) + kxt=nx-int(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-kxs/4+kxt + jx=j1-kxs/4 + case(2) + ix=i1+1+kxs/4 + jx=j1-kxs/4+kxt + case(3) + ix=i1+1+kxs/4-kxt + jx=j1+1+kxs/4 + case default + ix=i1-kxs/4 + jx=j1+kxs/4-kxt + end select + if(jx.lt.1) then + ix=ix+imxin/2 + jx=2-jx + elseif(jx.gt.jmxin) then + ix=ix+imxin/2 + jx=2*jmxin-jx + endif + ix=modulo(ix-1,imxin)+1 + if(slmask(i).eq.rslmsk(ix,jx)) then + gauout(i) = regin(ix,jx) + go to 81 + endif + enddo + +!cggg here, set the gauout value to be 0, and let's sarah's land +!cggg routine assign a default. + + if (num_threads == 1) then + print*,'no matching mask found ',i,i1,j1,ix,jx + print*,'set to default value.' + endif + gauout(i) = 0.0 + + + 81 continue + + end if + + end if + +!cggg end + + enddo + kmami=1 + if (me == 0 .and. num_threads == 1) + & call maxmin(gauout(i1_t),len_thread,kmami) + else ! nearest neighbor interpolation + +! +! quasi-bilinear interpolation +! + ifill(it) = 0 + imxnx(it) = 0 + do i=i1_t,i2_t + y = ddy(i) + j1 = jindx1(i) + j2 = jindx2(i) + x = ddx(i) + i1 = iindx1(i) + i2 = iindx2(i) +! + wi1j1 = (1.-x) * (1.-y) + wi2j1 = x *( 1.-y) + wi1j2 = (1.-x) * y + wi2j2 = x * y +! + tem = 4.*slmask(i) - rslmsk(i1,j1) - rslmsk(i2,j1) + & - rslmsk(i1,j2) - rslmsk(i2,j2) + if(lmask .and. abs(tem) .gt. 0.01) then + if(slmask(i).eq.1.) then + wi1j1 = wi1j1 * rslmsk(i1,j1) + wi2j1 = wi2j1 * rslmsk(i2,j1) + wi1j2 = wi1j2 * rslmsk(i1,j2) + wi2j2 = wi2j2 * rslmsk(i2,j2) + else + wi1j1 = wi1j1 * (1.0-rslmsk(i1,j1)) + wi2j1 = wi2j1 * (1.0-rslmsk(i2,j1)) + wi1j2 = wi1j2 * (1.0-rslmsk(i1,j2)) + wi2j2 = wi2j2 * (1.0-rslmsk(i2,j2)) + endif + endif +! + wsum = wi1j1 + wi2j1 + wi1j2 + wi2j2 + wrk(i) = wsum + if(wsum.ne.0.) then + wsumiv = 1./wsum +! + if(j1.ne.j2) then + gauout(i) = (wi1j1*regin(i1,j1) + wi2j1*regin(i2,j1) + + & wi1j2*regin(i1,j2) + wi2j2*regin(i2,j2)) + & *wsumiv + else +! + if (rlat .gt. 0.0) then + if (slmask(i) .eq. 1.0) then + sumn = sum1 + sums = sum2 + else + sumn = sum3 + sums = sum4 + endif + if( j1 .eq. 1) then + gauout(i) = (wi1j1*sumn +wi2j1*sumn + + & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) + & * wsumiv + elseif (j1 .eq. jmxin) then + gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ + & wi1j2*sums +wi2j2*sums ) + & * wsumiv + endif +! print *,' slmask=',slmask(i),' sums=',sums,' sumn=',sumn +! & ,' regin=',regin(i1,j2),regin(i2,j2),' j1=',j1,' j2=',j2 +! & ,' wij=',wi1j1, wi2j1, wi1j2, wi2j2,wsumiv + else + if (slmask(i) .eq. 1.0) then + sums = sum1 + sumn = sum2 + else + sums = sum3 + sumn = sum4 + endif + if( j1 .eq. 1) then + gauout(i) = (wi1j1*regin(i1,j1)+wi2j1*regin(i2,j1)+ + & wi1j2*sums +wi2j2*sums ) + & * wsumiv + elseif (j1 .eq. jmxin) then + gauout(i) = (wi1j1*sumn +wi2j1*sumn + + & wi1j2*regin(i1,j2)+wi2j2*regin(i2,j2)) + & * wsumiv + endif + endif + endif ! if j1 .ne. j2 + endif + enddo + do i=i1_t,i2_t + j1 = jindx1(i) + j2 = jindx2(i) + i1 = iindx1(i) + i2 = iindx2(i) + if(wrk(i) .eq. 0.0) then + if(.not.lmask) then + if (num_threads == 1) + & write(6,*) ' la2ga called with lmask=.true. but bad', + & ' rslmsk or slmask given' + call abort + endif + ifill(it) = ifill(it) + 1 + if(ifill(it) <= 2 ) then + if (me == 0 .and. num_threads == 1) then + write(6,*) 'i1,i2,j1,j2=',i1,i2,j1,j2 + write(6,*) 'rslmsk=',rslmsk(i1,j1),rslmsk(i1,j2), + & rslmsk(i2,j1),rslmsk(i2,j2) +! write(6,*) 'i,j=',i,j,' slmask(i)=',slmask(i) + write(6,*) 'i=',i,' slmask(i)=',slmask(i) + &, ' outlon=',outlon(i),' outlat=',outlat(i) + endif + endif +! spiral around until matching mask is found. + do nx=1,jmxin*imxin/2 + kxs=sqrt(4*nx-2.5) + kxt=nx-int(kxs**2/4+1) + select case(mod(kxs,4)) + case(1) + ix=i1-kxs/4+kxt + jx=j1-kxs/4 + case(2) + ix=i1+1+kxs/4 + jx=j1-kxs/4+kxt + case(3) + ix=i1+1+kxs/4-kxt + jx=j1+1+kxs/4 + case default + ix=i1-kxs/4 + jx=j1+kxs/4-kxt + end select + if(jx.lt.1) then + ix=ix+imxin/2 + jx=2-jx + elseif(jx.gt.jmxin) then + ix=ix+imxin/2 + jx=2*jmxin-jx + endif + ix=modulo(ix-1,imxin)+1 + if(slmask(i).eq.rslmsk(ix,jx)) then + gauout(i) = regin(ix,jx) + imxnx(it) = max(imxnx(it),nx) + go to 71 + endif + enddo +! + if (num_threads == 1) then + write(6,*) ' error!!! no filling value found in la2ga' +! write(6,*) ' i ix jx slmask(i) rslmsk ', +! & i,ix,jx,slmask(i),rslmsk(ix,jx) + endif + call abort +! + 71 continue + endif +! + enddo + endif + enddo ! end of threaded loop ................... +!$omp end parallel do +! + if(inttyp /= 1)then + ifills = 0 + do it=1,num_threads + ifills = ifills + ifill(it) + enddo + + if(ifills.gt.1) then + if (me .eq. 0) then + write(6,*) ' unable to interpolate. filled with nearest', + & ' point value at ',ifills,' points' +! & ' point value at ',ifills,' points imxnx=',imxnx(:) + endif + endif + deallocate (ifill) + endif +! + kmami=1 + if (me .eq. 0 .and. print_debug) call maxmin(gauout,len,kmami) +! + return + end subroutine la2ga + subroutine maxmin(f,imax,kmax) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,iimin,iimax,kmax,imax,k + real (kind=kind_io8) fmin,fmax +! + real (kind=kind_io8) f(imax,kmax) +! + do k=1,kmax +! + fmax = f(1,k) + fmin = f(1,k) +! + do i=1,imax + if(fmax.le.f(i,k)) then + fmax = f(i,k) + iimax = i + endif + if(fmin.ge.f(i,k)) then + fmin = f(i,k) + iimin = i + endif + enddo +! + write(6,100) k,fmax,iimax,fmin,iimin + 100 format(2x,'level=',i2,' max=',e11.4,' at i=',i7, + & ' min=',e11.4,' at i=',i7) +! + enddo +! + return + end + subroutine filanl(tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl, + & aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,scvanl,veganl, + & vetanl,sotanl,alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm, + & aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,vegclm, + & vetclm,sotclm,alfclm, +!cwu [+1l] add ()clm for sih, sic + & sihclm,sicclm, +!clu [+1l] add ()clm for vmn, vmx, slp, abs + & vmnclm,vmxclm,slpclm,absclm, + & len,lsoil) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,len,lsoil +! + real (kind=kind_io8) tsfanl(len),tsfan2(len),wetanl(len), + & snoanl(len), + & zoranl(len),albanl(len,4),aisanl(len), + & tg3anl(len), + & cvanl (len),cvbanl(len),cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len),scvanl(len),veganl(len), + & vetanl(len),sotanl(len),alfanl(len,2) +!cwu [+1l] add ()anl for sih, sic + &, sihanl(len),sicanl(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) + real (kind=kind_io8) tsfclm(len),tsfcl2(len),wetclm(len), + & snoclm(len), + & zorclm(len),albclm(len,4),aisclm(len), + & tg3clm(len), + & cvclm (len),cvbclm(len),cvtclm(len), + & cnpclm(len), + & smcclm(len,lsoil),stcclm(len,lsoil), + & sliclm(len),scvclm(len),vegclm(len), + & vetclm(len),sotclm(len),alfclm(len,2) +!cwu [+1l] add ()clm for sih, sic + &, sihclm(len),sicclm(len) +!clu [+1l] add ()clm for vmn, vmx, slp, abs + &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) +! + do i=1,len + tsfanl(i) = tsfclm(i) ! tsf at t + tsfan2(i) = tsfcl2(i) ! tsf at t-deltsfc + wetanl(i) = wetclm(i) ! soil wetness + snoanl(i) = snoclm(i) ! snow + scvanl(i) = scvclm(i) ! snow cover + aisanl(i) = aisclm(i) ! seaice + slianl(i) = sliclm(i) ! land/sea/snow mask + zoranl(i) = zorclm(i) ! surface roughness +! plranl(i) = plrclm(i) ! maximum stomatal resistance + tg3anl(i) = tg3clm(i) ! deep soil temperature + cnpanl(i) = cnpclm(i) ! canopy water content + veganl(i) = vegclm(i) ! vegetation cover + vetanl(i) = vetclm(i) ! vegetation type + sotanl(i) = sotclm(i) ! soil type + cvanl(i) = cvclm(i) ! cv + cvbanl(i) = cvbclm(i) ! cvb + cvtanl(i) = cvtclm(i) ! cvt +!cwu [+4l] add sih, sic + sihanl(i) = sihclm(i) ! sea ice thickness + sicanl(i) = sicclm(i) ! sea ice concentration +!clu [+4l] add vmn, vmx, slp, abs + vmnanl(i) = vmnclm(i) ! min vegetation cover + vmxanl(i) = vmxclm(i) ! max vegetation cover + slpanl(i) = slpclm(i) ! slope type + absanl(i) = absclm(i) ! max snow albedo + enddo +! + do j=1,lsoil + do i=1,len + smcanl(i,j) = smcclm(i,j) ! layer soil wetness + stcanl(i,j) = stcclm(i,j) ! soil temperature + enddo + enddo + do j=1,4 + do i=1,len + albanl(i,j) = albclm(i,j) ! albedo + enddo + enddo + do j=1,2 + do i=1,len + alfanl(i,j) = alfclm(i,j) ! vegetation fraction for albedo + enddo + enddo +! + return + end + subroutine analy(lugb,iy,im,id,ih,fh,len,lsoil, + & slmask,fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota, +!clu [+1l] add fn()a for vmn, vmx, slp, abs + & fnvmna,fnvmxa,fnslpa,fnabsa, + & tsfanl,wetanl,snoanl,zoranl,albanl,aisanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & smcanl,stcanl,slianl,scvanl,acnanl,veganl, + & vetanl,sotanl,alfanl,tsfan0, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, +!cggg snow mods start & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtsf,kpdwet,kpdsno,kpdsnd,kpdzor,kpdalb,kpdais, +!cggg snow mods end + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kprvet,kpdsot,kpdalf, +!clu [+1l] add kpd() for vmn, vmx, slp, abs + & kpdvmn,kpdvmx,kpdslp,kpdabs, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvet,irtsot,irtalf +!clu [+1l] add irt() for vmn, vmx, slp, abs + &, irtvmn,irtvmx,irtslp,irtabs + &, imsk, jmsk, slmskh, outlat, outlon + &, gaus, blno, blto, me) + use machine , only : kind_io8,kind_io4 + implicit none + integer irtsmc,irtacn,irtstc,irtvet,irtveg,irtscv,irtzor,irtsno, + & irtalb,irttg3,irtais,iret,me,kk,kpdvet,i,irtalf,irtsot, +!cggg snow mods start & imsk,jmsk,irtwet,lsoil,len, kpdtsf,kpdsno,kpdwet,iy, + & imsk,jmsk,irtwet,lsoil,len,kpdtsf,kpdsno,kpdsnd,kpdwet,iy, +!cggg snow mods end + & lugb,im,ih,id,kpdveg,kpdstc,kprvet,irttsf,kpdsot,kpdsmc, + & kpdais,kpdzor,kpdtg3,kpdacn,kpdscv,j +!clu [+1l] add kpd() and irt() for vmn, vmx, slp, abs + &, kpdvmn,kpdvmx,kpdslp,kpdabs,irtvmn,irtvmx,irtslp,irtabs + real (kind=kind_io8) blto,blno,fh +! + real (kind=kind_io8) slmask(len) + real (kind=kind_io8) slmskh(imsk,jmsk) + real (kind=kind_io8) outlat(len), outlon(len) + integer kpdalb(4), kpdalf(2) +!cggg snow mods start + integer kpds(1000),kgds(1000),jpds(1000),jgds(1000) + integer lugi, lskip, lgrib, ndata +!cggg snow mods end +! + character*500 fntsfa,fnweta,fnsnoa,fnzora,fnalba,fnaisa, + & fntg3a,fnscva,fnsmca,fnstca,fnacna,fnvega, + & fnveta,fnsota +!clu [+1l] add fn()a for vmn, vmx, slp, abs + &, fnvmna,fnvmxa,fnslpa,fnabsa + + real (kind=kind_io8) tsfanl(len), wetanl(len), snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & tg3anl(len), acnanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & slianl(len), scvanl(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2), + & smcanl(len,lsoil), stcanl(len,lsoil), + & tsfan0(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + logical gaus +! +! tsf +! + irttsf = 1 + if(fntsfa(1:8).ne.' ') then + call fixrda(lugb,fntsfa,kpdtsf,slmask, + & iy,im,id,ih,fh,tsfanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irttsf = iret + if(iret.eq.1) then + write(6,*) 't surface analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old t surface analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'t surface analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no tsf analysis available. climatology used' + endif + endif +! +! tsf0 +! +! if(fntsfa(1:8).ne.' ') then +! call fixrda(lugb,fntsfa,kpdtsf,slmask, +! & iy,im,id,ih,0.,tsfan0,len,iret +! &, imsk, jmsk, slmskh, gaus,blno, blto +! &, outlat, outlon, me) +! if(iret.eq.1) then +! write(6,*) 't surface at ft=0 analysis read error' +! call abort +! elseif(iret.eq.-1) then +! write(6,*) 'could not find t surface analysis at ft=0' +! call abort +! else +! print *,'t surface analysis at ft=0 found.' +! endif +! else +! do i=1,len +! tsfan0(i)=-999.9 +! enddo +! endif +! +! albedo +! + irtalb=0 + if(fnalba(1:8).ne.' ') then + do kk = 1, 4 + call fixrda(lugb,fnalba,kpdalb(kk),slmask, + & iy,im,id,ih,fh,albanl(1,kk),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtalb=iret + if(iret.eq.1) then + write(6,*) 'albedo analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old albedo analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0 .and. kk .eq. 4) + & print *,'albedo analysis provided.' + endif + enddo + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no albedo analysis available. climatology used' + endif + endif +! +! vegetation fraction for albedo +! + irtalf=0 + if(fnalba(1:8).ne.' ') then + do kk = 1, 2 + call fixrda(lugb,fnalba,kpdalf(kk),slmask, + & iy,im,id,ih,fh,alfanl(1,kk),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtalf=iret + if(iret.eq.1) then + write(6,*) 'albedo analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old albedo analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0 .and. kk .eq. 4) + & print *,'albedo analysis provided.' + endif + enddo + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no vegfalbedo analysis available. climatology used' + endif + endif +! +! soil wetness +! + irtwet=0 + irtsmc=0 + if(fnweta(1:8).ne.' ') then + call fixrda(lugb,fnweta,kpdwet,slmask, + & iy,im,id,ih,fh,wetanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtwet=iret + if(iret.eq.1) then + write(6,*) 'bucket wetness analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old wetness analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'bucket wetness analysis provided.' + endif + elseif(fnsmca(1:8).ne.' ') then + call fixrda(lugb,fnsmca,kpdsmc,slmask, + & iy,im,id,ih,fh,smcanl(1,1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + call fixrda(lugb,fnsmca,kpdsmc,slmask, + & iy,im,id,ih,fh,smcanl(1,2),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsmc=iret + if(iret.eq.1) then + write(6,*) 'layer soil wetness analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old layer soil wetness analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'layer soil wetness analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no soil wetness analysis available. climatology used' + endif + endif +! +! read in snow depth/snow cover +! + irtscv=0 + if(fnsnoa(1:8).ne.' ') then + do i=1,len + scvanl(i)=0. + enddo +!cggg snow mods start +!cggg need to determine if the snow data is on the gaussian grid +!cggg or not. if gaussian, then data is a depth, not liq equiv +!cggg depth. if not gaussian, then data is from hua-lu's +!cggg program and is a liquid equiv. need to communicate +!cggg this to routine fixrda via the 3rd argument which is +!cggg the grib parameter id number. + call baopenr(lugb,fnsnoa,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fnsnoa) + print *,'error in opening file ',trim(fnsnoa) + call abort + endif + lugi=0 + lskip=-1 + jpds=-1 + jgds=-1 + kpds=jpds + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) + close(lugb) + if (iret .ne. 0) then + write(6,*) ' error reading header of file: ',trim(fnsnoa) + print *,'error reading header of file: ',trim(fnsnoa) + call abort + endif + if (kgds(1) == 4) then ! gaussian data is depth + call fixrda(lugb,fnsnoa,kpdsnd,slmask, + & iy,im,id,ih,fh,snoanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + snoanl=snoanl*100. ! convert from meters to liq. eq. + ! depth in mm using 10:1 ratio + else ! lat/lon data is liq equv. depth + call fixrda(lugb,fnsnoa,kpdsno,slmask, + & iy,im,id,ih,fh,snoanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif +!cggg snow mods end + irtscv=iret + if(iret.eq.1) then + write(6,*) 'snow depth analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old snow depth analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'snow depth analysis provided.' + endif + irtsno=0 + elseif(fnscva(1:8).ne.' ') then + do i=1,len + snoanl(i)=0. + enddo + call fixrda(lugb,fnscva,kpdscv,slmask, + & iy,im,id,ih,fh,scvanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsno=iret + if(iret.eq.1) then + write(6,*) 'snow cover analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old snow cover analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'snow cover analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no snow/snocov analysis available. climatology used' + endif + endif +! +! sea ice mask +! + irtacn=0 + irtais=0 + if(fnacna(1:8).ne.' ') then + call fixrda(lugb,fnacna,kpdacn,slmask, + & iy,im,id,ih,fh,acnanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtacn=iret + if(iret.eq.1) then + write(6,*) 'ice concentration analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old ice concentration analysis provided', + & ' indicating proper file name is given' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'ice concentration analysis provided.' + endif + elseif(fnaisa(1:8).ne.' ') then + call fixrda(lugb,fnaisa,kpdais,slmask, + & iy,im,id,ih,fh,aisanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtais=iret + if(iret.eq.1) then + write(6,*) 'ice mask analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old ice-mask analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'ice mask analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no sea-ice analysis available. climatology used' + endif + endif +! +! surface roughness +! + irtzor=0 + if(fnzora(1:8).ne.' ') then + call fixrda(lugb,fnzora,kpdzor,slmask, + & iy,im,id,ih,fh,zoranl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtzor=iret + if(iret.eq.1) then + write(6,*) 'roughness analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old roughness analysis provided, indicating proper', + & ' file name is given. no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'roughness analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no srfc roughness analysis available. climatology used' + endif + endif +! +! deep soil temperature +! + irttg3=0 + irtstc=0 + if(fntg3a(1:8).ne.' ') then + call fixrda(lugb,fntg3a,kpdtg3,slmask, + & iy,im,id,ih,fh,tg3anl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irttg3=iret + if(iret.eq.1) then + write(6,*) 'deep soil tmp analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old deep soil temp analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'deep soil tmp analysis provided.' + endif + elseif(fnstca(1:8).ne.' ') then + call fixrda(lugb,fnstca,kpdstc,slmask, + & iy,im,id,ih,fh,stcanl(1,1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + call fixrda(lugb,fnstca,kpdstc,slmask, + & iy,im,id,ih,fh,stcanl(1,2),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtstc=iret + if(iret.eq.1) then + write(6,*) 'layer soil tmp analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old deep soil temp analysis provided', + & 'iindicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'layer soil tmp analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no deep soil temp analy available. climatology used' + endif + endif +! +! vegetation cover +! + irtveg=0 + if(fnvega(1:8).ne.' ') then + call fixrda(lugb,fnvega,kpdveg,slmask, + & iy,im,id,ih,fh,veganl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtveg=iret + if(iret.eq.1) then + write(6,*) 'vegetation cover analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old vegetation cover analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'gegetation cover analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no vegetation cover anly available. climatology used' + endif + endif +! +! vegetation type +! + irtvet=0 + if(fnveta(1:8).ne.' ') then + call fixrda(lugb,fnveta,kpdvet,slmask, + & iy,im,id,ih,fh,vetanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtvet=iret + if(iret.eq.1) then + write(6,*) 'vegetation type analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old vegetation type analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'vegetation type analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no vegetation type anly available. climatology used' + endif + endif +! +! soil type +! + irtsot=0 + if(fnsota(1:8).ne.' ') then + call fixrda(lugb,fnsota,kpdsot,slmask, + & iy,im,id,ih,fh,sotanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtsot=iret + if(iret.eq.1) then + write(6,*) 'soil type analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old soil type analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'soil type analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no soil type anly available. climatology used' + endif + endif + +!clu [+120l]-------------------------------------------------------------- +! +! min vegetation cover +! + irtvmn=0 + if(fnvmna(1:8).ne.' ') then + call fixrda(lugb,fnvmna,kpdvmn,slmask, + & iy,im,id,ih,fh,vmnanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtvmn=iret + if(iret.eq.1) then + write(6,*) 'shdmin analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old shdmin analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'shdmin analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no shdmin anly available. climatology used' + endif + endif + +! +! max vegetation cover +! + irtvmx=0 + if(fnvmxa(1:8).ne.' ') then + call fixrda(lugb,fnvmxa,kpdvmx,slmask, + & iy,im,id,ih,fh,vmxanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtvmx=iret + if(iret.eq.1) then + write(6,*) 'shdmax analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old shdmax analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'shdmax analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no shdmax anly available. climatology used' + endif + endif + +! +! slope type +! + irtslp=0 + if(fnslpa(1:8).ne.' ') then + call fixrda(lugb,fnslpa,kpdslp,slmask, + & iy,im,id,ih,fh,slpanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtslp=iret + if(iret.eq.1) then + write(6,*) 'slope type analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old slope type analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'slope type analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no slope type anly available. climatology used' + endif + endif + +! +! max snow albedo +! + irtabs=0 + if(fnabsa(1:8).ne.' ') then + call fixrda(lugb,fnabsa,kpdabs,slmask, + & iy,im,id,ih,fh,absanl,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + irtabs=iret + if(iret.eq.1) then + write(6,*) 'snoalb analysis read error' + call abort + elseif(iret.eq.-1) then + if (me .eq. 0) then + print *,'old snoalb analysis provided', + & ' indicating proper file name is given.' + print *,' no error suspected.' + write(6,*) 'forecast guess will be used' + endif + else + if (me .eq. 0) print *,'snoalb analysis provided.' + endif + else + if (me .eq. 0) then +! print *,'************************************************' + print *,'no snoalb anly available. climatology used' + endif + endif + +!clu ---------------------------------------------------------------------- +! + return + end + subroutine filfcs(tsffcs,wetfcs,snofcs,zorfcs,albfcs, + & tg3fcs,cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,aisfcs, + & vegfcs, vetfcs, sotfcs, alffcs, +!cwu [+1l] add ()fcs for sih, sic + & sihfcs,sicfcs, +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsfanl,wetanl,snoanl,zoranl,albanl, + & tg3anl,cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,aisanl, + & veganl, vetanl, sotanl, alfanl, +!cwu [+1l] add ()anl for sih, sic + & sihanl,sicanl, +!clu [+1l] add ()anl for vmn, vmx, slp, abs + & vmnanl,vmxanl,slpanl,absanl, + & len,lsoil) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,len,lsoil + real (kind=kind_io8) tsffcs(len),wetfcs(len),snofcs(len), + & zorfcs(len),albfcs(len,4),aisfcs(len), + & tg3fcs(len), + & cvfcs (len),cvbfcs(len),cvtfcs(len), + & cnpfcs(len), + & smcfcs(len,lsoil),stcfcs(len,lsoil), + & slifcs(len),vegfcs(len), + & vetfcs(len),sotfcs(len),alffcs(len,2) +!cwu [+1l] add ()fcs for sih, sic + &, sihfcs(len),sicfcs(len) +!clu [+1l] add ()fcs for vmn, vmx, slp, abs + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + real (kind=kind_io8) tsfanl(len),wetanl(len),snoanl(len), + & zoranl(len),albanl(len,4),aisanl(len), + & tg3anl(len), + & cvanl (len),cvbanl(len),cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len),veganl(len), + & vetanl(len),sotanl(len),alfanl(len,2) +!cwu [+1l] add ()anl for sih, sic + &, sihanl(len),sicanl(len) +!clu [+1l] add ()anl for vmn, vmx, slp, abs + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + write(6,*) ' this is a dead start run, tsfc over land is', + & ' set as lowest sigma level temperture if given.' + write(6,*) ' if not, set to climatological tsf over land is used' +! +! + do i=1,len + tsffcs(i) = tsfanl(i) ! tsf + albfcs(i,1) = albanl(i,1) ! albedo + albfcs(i,2) = albanl(i,2) ! albedo + albfcs(i,3) = albanl(i,3) ! albedo + albfcs(i,4) = albanl(i,4) ! albedo + wetfcs(i) = wetanl(i) ! soil wetness + snofcs(i) = snoanl(i) ! snow + aisfcs(i) = aisanl(i) ! seaice + slifcs(i) = slianl(i) ! land/sea/snow mask + zorfcs(i) = zoranl(i) ! surface roughness +! plrfcs(i) = plranl(i) ! maximum stomatal resistance + tg3fcs(i) = tg3anl(i) ! deep soil temperature + cnpfcs(i) = cnpanl(i) ! canopy water content + cvfcs(i) = cvanl(i) ! cv + cvbfcs(i) = cvbanl(i) ! cvb + cvtfcs(i) = cvtanl(i) ! cvt + vegfcs(i) = veganl(i) ! vegetation cover + vetfcs(i) = vetanl(i) ! vegetation type + sotfcs(i) = sotanl(i) ! soil type + alffcs(i,1) = alfanl(i,1) ! vegetation fraction for albedo + alffcs(i,2) = alfanl(i,2) ! vegetation fraction for albedo +!cwu [+2l] add sih, sic + sihfcs(i) = sihanl(i) ! sea ice thickness + sicfcs(i) = sicanl(i) ! sea ice concentration +!clu [+4l] add vmn, vmx, slp, abs + vmnfcs(i) = vmnanl(i) ! min vegetation cover + vmxfcs(i) = vmxanl(i) ! max vegetation cover + slpfcs(i) = slpanl(i) ! slope type + absfcs(i) = absanl(i) ! max snow albedo + enddo +! + do j=1,lsoil + do i=1,len + smcfcs(i,j) = smcanl(i,j) ! layer soil wetness + stcfcs(i,j) = stcanl(i,j) ! soil temperature + enddo + enddo +! + return + end + subroutine bktges(smcfcs,slianl,stcfcs,len,lsoil) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,j,len,lsoil,k + real (kind=kind_io8) smcfcs(len,lsoil), stcfcs(len,lsoil), + & slianl(len) +! +! note that smfcs comes in with the original unit (cm?) (not grib file) +! + do i = 1, len + smcfcs(i,1) = (smcfcs(i,1)/150.) * .37 + .1 + enddo + do k = 2, lsoil + do i = 1, len + smcfcs(i,k) = smcfcs(i,1) + enddo + enddo + if(lsoil.gt.2) then + do k = 3, lsoil + do i = 1, len + stcfcs(i,k) = stcfcs(i,2) + enddo + enddo + endif +! + return + end + subroutine rof01(aisfld,len,op,crit) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) aisfld(len),crit + character*2 op +! + if(op.eq.'ge') then + do i=1,len + if(aisfld(i).ge.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + elseif(op.eq.'gt') then + do i=1,len + if(aisfld(i).gt.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + elseif(op.eq.'le') then + do i=1,len + if(aisfld(i).le.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + elseif(op.eq.'lt') then + do i=1,len + if(aisfld(i).lt.crit) then + aisfld(i)=1. + else + aisfld(i)=0. + endif + enddo + else + write(6,*) ' illegal operator in rof01. op=',op + call abort + endif +! + return + end + subroutine tsfcor(tsfc,orog,slmask,umask,len,rlapse) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) rlapse,umask + real (kind=kind_io8) tsfc(len), orog(len), slmask(len) +! + do i=1,len + if(slmask(i).eq.umask) then + tsfc(i) = tsfc(i) - orog(i)*rlapse + endif + enddo + return + end + subroutine snodpth(scvanl,slianl,tsfanl,snoclm, + & glacir,snwmax,snwmin,landice,len,snoanl, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + integer i,me,len + logical, intent(in) :: landice + real (kind=kind_io8) sno,snwmax,snwmin +! + real (kind=kind_io8) scvanl(len), slianl(len), tsfanl(len), + & snoclm(len), snoanl(len), glacir(len) +! + if (me .eq. 0 .and. print_debug) write(6,*) 'snodpth' +! +! use surface temperature to get snow depth estimate +! + do i=1,len + sno = 0.0 +! +! over land +! + if(slianl(i).eq.1.) then + if(scvanl(i).eq.1.0) then + if(tsfanl(i).lt.243.0) then + sno = snwmax + elseif(tsfanl(i).lt.273.0) then + sno = snwmin+(snwmax-snwmin)*(273.0-tsfanl(i))/30.0 + else + sno = snwmin + endif + endif +! +! if glacial points has snow in climatology, set sno to snomax +! + if (.not.landice) then + if(glacir(i).eq.1.0) then + sno = snoclm(i) + if(sno.eq.0.) sno=snwmax + endif + endif + endif +! +! over sea ice +! +! snow over sea ice is cycled as of 01/01/94.....hua-lu pan +! + if(slianl(i).eq.2.0) then + sno=snoclm(i) + if(sno.eq.0.) sno=snwmax + endif +! + snoanl(i) = sno + enddo + return + end subroutine snodpth + subroutine merge(len,lsoil,iy,im,id,ih,fh,deltsfc, + & sihfcs,sicfcs, + & vmnfcs,vmxfcs,slpfcs,absfcs, + & tsffcs,wetfcs,snofcs,zorfcs,albfcs,aisfcs, + & cvfcs ,cvbfcs,cvtfcs, + & cnpfcs,smcfcs,stcfcs,slifcs,vegfcs, + & vetfcs,sotfcs,alffcs, + & sihanl,sicanl, + & vmnanl,vmxanl,slpanl,absanl, + & tsfanl,tsfan2,wetanl,snoanl,zoranl,albanl,aisanl, + & cvanl ,cvbanl,cvtanl, + & cnpanl,smcanl,stcanl,slianl,veganl, + & vetanl,sotanl,alfanl, + & ctsfl,calbl,caisl,csnol,csmcl,czorl,cstcl,cvegl, + & ctsfs,calbs,caiss,csnos,csmcs,czors,cstcs,cvegs, + & ccv,ccvb,ccvt,ccnp,cvetl,cvets,csotl,csots, + & calfl,calfs, + & csihl,csihs,csicl,csics, + & cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps,cabsl,cabss, + & irttsf,irtwet,irtsno,irtzor,irtalb,irtais, + & irttg3,irtscv,irtacn,irtsmc,irtstc,irtveg, + & irtvmn,irtvmx,irtslp,irtabs, + & irtvet,irtsot,irtalf, landice, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : veg_type_landice, soil_type_landice + use sfccyc_module, only : print_debug + implicit none + integer k,i,im,id,iy,len,lsoil,ih,irtacn,irtsmc,irtscv,irtais, + & irttg3,irtstc,irtalf,me,irtsot,irtveg,irtvet, irtzor, + & irtalb,irtsno,irttsf,irtwet,j + &, irtvmn,irtvmx,irtslp,irtabs + logical, intent(in) :: landice + real (kind=kind_io8) rvegs,rvets,rzors,raiss,rsnos,rsots,rcnp, + & rcvt,rcv,rcvb,rsnol,rzorl,raisl,ralbl, + & ralfl,rvegl,ralbs,ralfs,rtsfs,rvetl,rsotl, + & qzors,qvegs,qsnos,qalfs,qaiss,qvets,qcvt, + & qcnp,qcvb,qsots,qcv,qaisl,qsnol,qalfl, + & qtsfl,qalbl,qzorl,qtsfs,qalbs,qsotl,qvegl, + & qvetl,rtsfl,calbs,caiss,ctsfs,czorl,cvegl, + & csnos,ccvb,ccvt,ccv,czors,cvegs,caisl,csnol, + & calbl,fh,ctsfl,ccnp,csots,calfl,csotl,cvetl, + & cvets,calfs,deltsfc, + & csihl,csihs,csicl,csics, + & rsihl,rsihs,rsicl,rsics, + & qsihl,qsihs,qsicl,qsics + &, cvmnl,cvmns,cvmxl,cvmxs,cslpl,cslps + &, cabsl,cabss,rvmnl,rvmns,rvmxl,rvmxs + &, rslpl,rslps,rabsl,rabss,qvmnl,qvmns + &, qvmxl,qvmxs,qslpl,qslps,qabsl,qabss +! + real (kind=kind_io8) tsffcs(len), wetfcs(len), snofcs(len), + & zorfcs(len), albfcs(len,4), aisfcs(len), + & cvfcs (len), cvbfcs(len), cvtfcs(len), + & cnpfcs(len), + & smcfcs(len,lsoil),stcfcs(len,lsoil), + & slifcs(len), vegfcs(len), + & vetfcs(len), sotfcs(len), alffcs(len,2) + &, sihfcs(len), sicfcs(len) + &, vmnfcs(len),vmxfcs(len),slpfcs(len),absfcs(len) + real (kind=kind_io8) tsfanl(len),tsfan2(len), + & wetanl(len),snoanl(len), + & zoranl(len), albanl(len,4), aisanl(len), + & cvanl (len), cvbanl(len), cvtanl(len), + & cnpanl(len), + & smcanl(len,lsoil),stcanl(len,lsoil), + & slianl(len), veganl(len), + & vetanl(len), sotanl(len), alfanl(len,2) + &, sihanl(len),sicanl(len) + &, vmnanl(len),vmxanl(len),slpanl(len),absanl(len) +! + real (kind=kind_io8) csmcl(lsoil), csmcs(lsoil), + & cstcl(lsoil), cstcs(lsoil) + real (kind=kind_io8) rsmcl(lsoil), rsmcs(lsoil), + & rstcl(lsoil), rstcs(lsoil) + real (kind=kind_io8) qsmcl(lsoil), qsmcs(lsoil), + & qstcl(lsoil), qstcs(lsoil) + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, i1_t, i2_t, it + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + endif +! +! coeeficients of blending forecast and interpolated clim +! (or analyzed) fields over sea or land(l) (not for clouds) +! 1.0 = use of forecast +! 0.0 = replace with interpolated analysis +! +! merging coefficients are defined by parameter statement in calling program +! and therefore they should not be modified in this program. +! + rtsfl = ctsfl + ralbl = calbl + ralfl = calfl + raisl = caisl + rsnol = csnol +!clu rsmcl = csmcl + rzorl = czorl + rvegl = cvegl + rvetl = cvetl + rsotl = csotl + rsihl = csihl + rsicl = csicl + rvmnl = cvmnl + rvmxl = cvmxl + rslpl = cslpl + rabsl = cabsl +! + rtsfs = ctsfs + ralbs = calbs + ralfs = calfs + raiss = caiss + rsnos = csnos +! rsmcs = csmcs + rzors = czors + rvegs = cvegs + rvets = cvets + rsots = csots + rsihs = csihs + rsics = csics + rvmns = cvmns + rvmxs = cvmxs + rslps = cslps + rabss = cabss +! + rcv = ccv + rcvb = ccvb + rcvt = ccvt + rcnp = ccnp +! + do k=1,lsoil + rsmcl(k) = csmcl(k) + rsmcs(k) = csmcs(k) + rstcl(k) = cstcl(k) + rstcs(k) = cstcs(k) + enddo + if (fh-deltsfc < -0.001 .and. irttsf == 1) then + rtsfs = 1.0 + rtsfl = 1.0 +! do k=1,lsoil +! rsmcl(k) = 1.0 +! rsmcs(k) = 1.0 +! rstcl(k) = 1.0 +! rstcs(k) = 1.0 +! enddo + endif +! +! if analysis file name is given but no matching analysis date found, +! use guess (these are flagged by irt???=1). +! + if(irttsf == -1) then + rtsfl = 1. + rtsfs = 1. + endif + if(irtalb == -1) then + ralbl = 1. + ralbs = 1. + ralfl = 1. + ralfs = 1. + endif + if(irtais == -1) then + raisl = 1. + raiss = 1. + endif + if(irtsno == -1 .or. irtscv == -1) then + rsnol = 1. + rsnos = 1. + endif + if(irtsmc == -1 .or. irtwet == -1) then +! rsmcl = 1. +! rsmcs = 1. + do k=1,lsoil + rsmcl(k) = 1. + rsmcs(k) = 1. + enddo + endif + if(irtstc.eq.-1) then + do k=1,lsoil + rstcl(k) = 1. + rstcs(k) = 1. + enddo + endif + if(irtzor == -1) then + rzorl = 1. + rzors = 1. + endif + if(irtveg == -1) then + rvegl = 1. + rvegs = 1. + endif + if(irtvet.eq.-1) then + rvetl = 1. + rvets = 1. + endif + if(irtsot == -1) then + rsotl = 1. + rsots = 1. + endif + + if(irtacn == -1) then + rsicl = 1. + rsics = 1. + endif + if(irtvmn == -1) then + rvmnl = 1. + rvmns = 1. + endif + if(irtvmx == -1) then + rvmxl = 1. + rvmxs = 1. + endif + if(irtslp == -1) then + rslpl = 1. + rslps = 1. + endif + if(irtabs == -1) then + rabsl = 1. + rabss = 1. + endif +! + if(raiss == 1. .or. irtacn == -1) then + if (me == 0) print *,'use forecast land-sea-ice mask' + do i = 1, len + aisanl(i) = aisfcs(i) + slianl(i) = slifcs(i) + enddo + endif +! + if (me == 0 .and. print_debug) then + write(6,100) rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl + 100 format('rtsfl,ralbl,raisl,rsnol,rsmcl,rzorl,rvegl=',10f7.3) + write(6,101) rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs + 101 format('rtsfs,ralbs,raiss,rsnos,rsmcs,rzors,rvegs=',10f7.3) +! print *,' ralfl=',ralfl,' ralfs=',ralfs,' rsotl=',rsotl +! *,' rsots=',rsots,' rvetl=',rvetl,' rvets=',rvets + endif +! + qtsfl = 1. - rtsfl + qalbl = 1. - ralbl + qalfl = 1. - ralfl + qaisl = 1. - raisl + qsnol = 1. - rsnol +! qsmcl = 1. - rsmcl + qzorl = 1. - rzorl + qvegl = 1. - rvegl + qvetl = 1. - rvetl + qsotl = 1. - rsotl + qsihl = 1. - rsihl + qsicl = 1. - rsicl + qvmnl = 1. - rvmnl + qvmxl = 1. - rvmxl + qslpl = 1. - rslpl + qabsl = 1. - rabsl +! + qtsfs = 1. - rtsfs + qalbs = 1. - ralbs + qalfs = 1. - ralfs + qaiss = 1. - raiss + qsnos = 1. - rsnos +! qsmcs = 1. - rsmcs + qzors = 1. - rzors + qvegs = 1. - rvegs + qvets = 1. - rvets + qsots = 1. - rsots + qsihs = 1. - rsihs + qsics = 1. - rsics + qvmns = 1. - rvmns + qvmxs = 1. - rvmxs + qslps = 1. - rslps + qabss = 1. - rabss +! + qcv = 1. - rcv + qcvb = 1. - rcvb + qcvt = 1. - rcvt + qcnp = 1. - rcnp +! + do k=1,lsoil + qsmcl(k) = 1. - rsmcl(k) + qsmcs(k) = 1. - rsmcs(k) + qstcl(k) = 1. - rstcl(k) + qstcs(k) = 1. - rstcs(k) + enddo +! +! merging +! + if(me .eq. 0 .and. print_debug) then + print *, 'dbgx-- csmcl:', (csmcl(k),k=1,lsoil) + print *, 'dbgx-- rsmcl:', (rsmcl(k),k=1,lsoil) + print *, 'dbgx-- csnol, csnos:',csnol,csnos + print *, 'dbgx-- rsnol, rsnos:',rsnol,rsnos + endif + +! print *, rtsfs, qtsfs, raiss , qaiss +! *, rsnos , qsnos, rzors , qzors, rvegs , qvegs +! *, rvets , qvets, rsots , qsots +! *, rcv, rcvb, rcvt, qcv, qcvb, qcvt +! *, ralbs, qalbs, ralfs, qalfs +! print *, rtsfl, qtsfl, raisl , qaisl +! *, rsnol , qsnol, rzorl , qzorl, rvegl , qvegl +! *, rvetl , qvetl, rsotl , qsotl +! *, ralbl, qalbl, ralfl, qalfl +! +! + len_thread_m = (len+num_threads-1) / num_threads + +!$omp parallel do private(i1_t,i2_t,it,i) + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + vetanl(i) = vetfcs(i)*rvets + vetanl(i)*qvets + sotanl(i) = sotfcs(i)*rsots + sotanl(i)*qsots + else + vetanl(i) = vetfcs(i)*rvetl + vetanl(i)*qvetl + sotanl(i) = sotfcs(i)*rsotl + sotanl(i)*qsotl + endif + enddo + enddo +!$omp end parallel do +! +!$omp parallel do private(i1_t,i2_t,it,i,k) +! + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) +! + do i=i1_t,i2_t + if(slianl(i).eq.0.) then +!.... tsffc2 is the previous anomaly + today's climatology +! tsffc2 = (tsffcs(i)-tsfan2(i))+tsfanl(i) +! tsfanl(i) = tsffc2 *rtsfs+tsfanl(i)*qtsfs +! + tsfanl(i) = tsffcs(i)*rtsfs + tsfanl(i)*qtsfs +! albanl(i) = albfcs(i)*ralbs + albanl(i)*qalbs + aisanl(i) = aisfcs(i)*raiss + aisanl(i)*qaiss + snoanl(i) = snofcs(i)*rsnos + snoanl(i)*qsnos + + zoranl(i) = zorfcs(i)*rzors + zoranl(i)*qzors + veganl(i) = vegfcs(i)*rvegs + veganl(i)*qvegs + sihanl(i) = sihfcs(i)*rsihs + sihanl(i)*qsihs + sicanl(i) = sicfcs(i)*rsics + sicanl(i)*qsics + vmnanl(i) = vmnfcs(i)*rvmns + vmnanl(i)*qvmns + vmxanl(i) = vmxfcs(i)*rvmxs + vmxanl(i)*qvmxs + slpanl(i) = slpfcs(i)*rslps + slpanl(i)*qslps + absanl(i) = absfcs(i)*rabss + absanl(i)*qabss + else + tsfanl(i) = tsffcs(i)*rtsfl + tsfanl(i)*qtsfl +! albanl(i) = albfcs(i)*ralbl + albanl(i)*qalbl + aisanl(i) = aisfcs(i)*raisl + aisanl(i)*qaisl + if(rsnol.ge.0)then + snoanl(i) = snofcs(i)*rsnol + snoanl(i)*qsnol + else ! envelope method + if(snoanl(i).ne.0)then + snoanl(i) = max(-snoanl(i)/rsnol, + & min(-snoanl(i)*rsnol, snofcs(i))) + endif + endif + zoranl(i) = zorfcs(i)*rzorl + zoranl(i)*qzorl + veganl(i) = vegfcs(i)*rvegl + veganl(i)*qvegl + vmnanl(i) = vmnfcs(i)*rvmnl + vmnanl(i)*qvmnl + vmxanl(i) = vmxfcs(i)*rvmxl + vmxanl(i)*qvmxl + slpanl(i) = slpfcs(i)*rslpl + slpanl(i)*qslpl + absanl(i) = absfcs(i)*rabsl + absanl(i)*qabsl + sihanl(i) = sihfcs(i)*rsihl + sihanl(i)*qsihl + sicanl(i) = sicfcs(i)*rsicl + sicanl(i)*qsicl + endif + + cnpanl(i) = cnpfcs(i)*rcnp + cnpanl(i)*qcnp +! +! snow over sea ice is cycled +! + if(slianl(i).eq.2.) then + snoanl(i) = snofcs(i) + endif +! + enddo + +! at landice points, set the soil type, slope type and +! greenness fields to flag values. + + if (landice) then + do i=i1_t,i2_t + if (nint(slianl(i)) == 1) then + if (nint(vetanl(i)) == veg_type_landice) then + sotanl(i) = soil_type_landice + veganl(i) = 0.0 + slpanl(i) = 9.0 + vmnanl(i) = 0.0 + vmxanl(i) = 0.0 + endif + end if ! if land + enddo + endif + + do i=i1_t,i2_t + cvanl(i) = cvfcs(i)*rcv + cvanl(i)*qcv + cvbanl(i) = cvbfcs(i)*rcvb + cvbanl(i)*qcvb + cvtanl(i) = cvtfcs(i)*rcvt + cvtanl(i)*qcvt + enddo +! + do k = 1, 4 + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + albanl(i,k) = albfcs(i,k)*ralbs + albanl(i,k)*qalbs + else + albanl(i,k) = albfcs(i,k)*ralbl + albanl(i,k)*qalbl + endif + enddo + enddo +! + do k = 1, 2 + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + alfanl(i,k) = alffcs(i,k)*ralfs + alfanl(i,k)*qalfs + else + alfanl(i,k) = alffcs(i,k)*ralfl + alfanl(i,k)*qalfl + endif + enddo + enddo +! + do k = 1, lsoil + do i=i1_t,i2_t + if(slianl(i).eq.0.) then + smcanl(i,k) = smcfcs(i,k)*rsmcs(k) + smcanl(i,k)*qsmcs(k) + stcanl(i,k) = stcfcs(i,k)*rstcs(k) + stcanl(i,k)*qstcs(k) + else +! soil moisture not used at landice points, so +! don't bother merging it. also, for now don't allow nudging +! to raise subsurface temperature above freezing. + stcanl(i,k) = stcfcs(i,k)*rstcl(k) + stcanl(i,k)*qstcl(k) + if (landice .and. slianl(i) == 1.0 .and. + & nint(vetanl(i)) == veg_type_landice) then + smcanl(i,k) = 1.0 ! use value as flag + stcanl(i,k) = min(stcanl(i,k), 273.15) + else + smcanl(i,k) = smcfcs(i,k)*rsmcl(k) + smcanl(i,k)*qsmcl(k) + end if + endif + enddo + enddo +! + enddo ! end of threaded loop ................... +!$omp end parallel do + return + end subroutine merge + subroutine newice(slianl,slifcs,tsfanl,tsffcs,len,lsoil, +!cwu [+1l] add sihnew,sicnew,sihanl,sicanl + & sihnew,sicnew,sihanl,sicanl, + & albanl,snoanl,zoranl,smcanl,stcanl, + & albsea,snosea,zorsea,smcsea,smcice, + & tsfmin,tsfice,albice,zorice,tgice, + & rla,rlo,me) +! + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + real (kind=kind_io8), parameter :: one=1.0 + real (kind=kind_io8) tgice,albice,zorice,tsfice,albsea,snosea, + & smcice,tsfmin,zorsea,smcsea +!cwu [+1l] add sicnew,sihnew + &, sicnew,sihnew + integer i,me,kount1,kount2,k,len,lsoil + real (kind=kind_io8) slianl(len), slifcs(len), + & tsffcs(len),tsfanl(len) + real (kind=kind_io8) albanl(len,4), snoanl(len), zoranl(len) + real (kind=kind_io8) smcanl(len,lsoil), stcanl(len,lsoil) +!cwu [+1l] add sihanl & sicanl + real (kind=kind_io8) sihanl(len), sicanl(len) +! + real (kind=kind_io8) rla(len), rlo(len) +! + if (me .eq. 0 .and. print_debug) write(6,*) 'newice' +! + kount1 = 0 + kount2 = 0 + do i=1,len + if(slifcs(i).ne.slianl(i)) then + if(slifcs(i).eq.1..or.slianl(i).eq.1.) then + print *,'inconsistency in slifcs or slianl' + print 910,rla(i),rlo(i),slifcs(i),slianl(i), + & tsffcs(i),tsfanl(i) + 910 format(2x,'at lat=',f5.1,' lon=',f5.1,' slifcs=',f4.1, + & ' slimsk=',f4.1,' tsffcs=',f5.1,' set to tsfanl=',f5.1) + call abort + endif +! +! interpolated climatology indicates melted sea ice +! + if(slianl(i).eq.0..and.slifcs(i).eq.2.) then + tsfanl(i) = tsfmin + albanl(i,1) = albsea + albanl(i,2) = albsea + albanl(i,3) = albsea + albanl(i,4) = albsea + snoanl(i) = snosea + zoranl(i) = zorsea + do k = 1, lsoil + smcanl(i,k) = smcsea +!cwu [+1l] set stcanl to tgice (over sea-ice) + stcanl(i,k) = tgice + enddo +!cwu [+2l] set siganl and sicanl + sihanl(i) = 0. + sicanl(i) = 0. + kount1 = kount1 + 1 + endif +! +! interplated climatoloyg/analysis indicates new sea ice +! + if(slianl(i).eq.2..and.slifcs(i).eq.0.) then + tsfanl(i) = tsfice + albanl(i,1) = albice + albanl(i,2) = albice + albanl(i,3) = albice + albanl(i,4) = albice + snoanl(i) = 0. + zoranl(i) = zorice + do k = 1, lsoil + smcanl(i,k) = smcice + stcanl(i,k) = tgice + enddo +!cwu [+2l] add sihanl & sicanl + sihanl(i) = sihnew + sicanl(i) = min(one, max(sicnew,sicanl(i))) + kount2 = kount2 + 1 + endif + endif + enddo +! + if (me .eq. 0 .and. print_debug) then + if(kount1.gt.0) then + write(6,*) 'sea ice melted. tsf,alb,zor are filled', + & ' at ',kount1,' points' + endif + if(kount2.gt.0) then + write(6,*) 'sea ice formed. tsf,alb,zor are filled', + & ' at ',kount2,' points' + endif + endif +! + return + end + subroutine qcsnow(snoanl,slmask,aisanl,glacir,len,snoval, + & landice,me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + integer kount,i,len,me + logical, intent(in) :: landice + real (kind=kind_io8) per,snoval + real (kind=kind_io8) snoanl(len),slmask(len), + & aisanl(len),glacir(len) + if (me .eq. 0) then + write(6,*) ' ' + write(6,*) 'qc of snow' + endif + if (.not.landice) then + kount=0 + do i=1,len + if(glacir(i).ne.0..and.snoanl(i).eq.0.) then +! if(glacir(i).ne.0..and.snoanl(i).lt.snoval*0.5) then + snoanl(i) = snoval + kount = kount + 1 + endif + enddo + per = float(kount) / float(len)*100. + if(kount.gt.0) then + if (me .eq. 0 .and. print_debug) then + print *,'snow filled over glacier points at ',kount, + & ' points (',per,'percent)' + endif + endif + endif ! landice check + kount = 0 + do i=1,len + if(slmask(i).eq.0.and.aisanl(i).eq.0) then + snoanl(i) = 0. + kount = kount + 1 + endif + enddo + per = float(kount) / float(len)*100. + if(kount.gt.0) then + if (me .eq. 0) then + print *,'snow set to zero over open sea at ',kount, + & ' points (',per,'percent)' + endif + endif + return + end subroutine qcsnow + subroutine qcsice(ais,glacir,amxice,aicice,aicsea,sllnd,slmask, + & rla,rlo,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer kount1,kount,i,me,len + real (kind=kind_io8) per,aicsea,aicice,sllnd +! + real (kind=kind_io8) ais(len), glacir(len), + & amxice(len), slmask(len) + real (kind=kind_io8) rla(len), rlo(len) +! +! check sea-ice cover mask against land-sea mask +! + if (me .eq. 0) write(6,*) 'qc of sea ice' + kount = 0 + kount1 = 0 + do i=1,len + if(ais(i).ne.aicice.and.ais(i).ne.aicsea) then + print *,'sea ice mask not ',aicice,' or ',aicsea + print *,'ais(i),aicice,aicsea,rla(i),rlo(i,=', + & ais(i),aicice,aicsea,rla(i),rlo(i) + call abort + endif + if(slmask(i).eq.0..and.glacir(i).eq.1..and. +! if(slmask(i).eq.0..and.glacir(i).eq.2..and. + & ais(i).ne.1.) then + kount1 = kount1 + 1 + ais(i) = 1. + endif + if(slmask(i).eq.sllnd.and.ais(i).eq.aicice) then + kount = kount + 1 + ais(i) = aicsea + endif + enddo +! enddo + per = float(kount) / float(len)*100. + if(kount.gt.0) then + if(me .eq. 0) then + print *,' sea ice over land mask at ',kount,' points (',per, + & 'percent)' + endif + endif + per = float(kount1) / float(len)*100. + if(kount1.gt.0) then + if(me .eq. 0) then + print *,' sea ice set over glacier points over ocean at ', + & kount1,' points (',per,'percent)' + endif + endif +! kount=0 +! do j=1,jdim +! do i=1,idim +! if(amxice(i,j).ne.0..and.ais(i,j).eq.0.) then +! ais(i,j)=0. +! kount=kount+1 +! endif +! enddo +! enddo +! per=float(kount)/float(idim*jdim)*100. +! if(kount.gt.0) then +! print *,' sea ice exceeds maxice at ',kount,' points (',per, +! & 'percent)' +! endif +! +! remove isolated open ocean surrounded by sea ice and/or land +! +! remove isolated open ocean surrounded by sea ice and/or land +! +! ij = 0 +! do j=1,jdim +! do i=1,idim +! ij = ij + 1 +! ip = i + 1 +! im = i - 1 +! jp = j + 1 +! jm = j - 1 +! if(jp.gt.jdim) jp = jdim - 1 +! if(jm.lt.1) jm = 2 +! if(ip.gt.idim) ip = 1 +! if(im.lt.1) im = idim +! if(slmask(i,j).eq.0..and.ais(i,j).eq.0.) then +! if((slmask(ip,jp).eq.1..or.ais(ip,jp).eq.1.).and. +! & (slmask(i ,jp).eq.1..or.ais(i ,jp).eq.1.).and. +! & (slmask(im,jp).eq.1..or.ais(im,jp).eq.1.).and. +! & (slmask(ip,j ).eq.1..or.ais(ip,j ).eq.1.).and. +! & (slmask(im,j ).eq.1..or.ais(im,j ).eq.1.).and. +! & (slmask(ip,jm).eq.1..or.ais(ip,jm).eq.1.).and. +! & (slmask(i ,jm).eq.1..or.ais(i ,jm).eq.1.).and. +! & (slmask(im,jm).eq.1..or.ais(im,jm).eq.1.)) then +! ais(i,j) = 1. +! write(6,*) ' isolated open sea point surrounded by', +! & ' sea ice or land modified to sea ice', +! & ' at lat=',rla(i,j),' lon=',rlo(i,j) +! endif +! endif +! enddo +! enddo + return + end + subroutine setlsi(slmask,aisfld,len,aicice,slifld) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) aicice + real (kind=kind_io8) slmask(len), slifld(len), aisfld(len) +! +! set surface condition indicator slimsk +! + do i=1,len + slifld(i) = slmask(i) +! if(aisfld(i).eq.aicice) slifld(i) = 2.0 + if(aisfld(i).eq.aicice .and. slmask(i) .eq. 0.0) + & slifld(i) = 2.0 + enddo + return + end + subroutine scale(fld,len,scl) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) fld(len),scl + do i=1,len + fld(i) = fld(i) * scl + enddo + return + end + subroutine qcmxmn(ttl,fld,slimsk,sno,iceflg, + & fldlmx,fldlmn,fldomx,fldomn,fldimx,fldimn, + & fldjmx,fldjmn,fldsmx,fldsmn,epsfld, + & rla,rlo,len,mode,percrit,lgchek,me) +! + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + real (kind=kind_io8) permax,per,fldimx,fldimn,fldjmx,fldomn, + & fldlmx,fldlmn,fldomx,fldjmn,percrit, + & fldsmx,fldsmn,epsfld + integer kmaxi,kmini,kmaxj,kmino,kmaxl,kminl,kmaxo,mmprt,kminj, + & ij,nprt,kmaxs,kmins,i,me,len,mode + parameter(mmprt=2) +! + character*8 ttl + logical iceflg(len) + real (kind=kind_io8) fld(len),slimsk(len),sno(len), + & rla(len), rlo(len) + integer iwk(len) + logical lgchek +! + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, i1_t, i2_t, it + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + endif +! +! check against land-sea mask and ice cover mask +! + if(me .eq. 0 .and. print_debug) then +! print *,' ' + print *,'performing qc of ',ttl,' mode=',mode, + & '(0=count only, 1=replace)' + endif +! + len_thread_m = (len+num_threads-1) / num_threads +! +!$omp parallel do private(i1_t,i2_t,it,i) +!$omp+private(nprt,ij,iwk,kmaxs,kmins) +!$omp+private(kmaxl,kminl,kmaxo,kmino,kmaxi,kmini,kmaxj,kminj) +!$omp+shared(mode,epsfld) +!$omp+shared(fldlmx,fldlmn,fldomx,fldjmn,fldsmx,fldsmn) +!$omp+shared(fld,slimsk,sno,rla,rlo) +! + do it=1,num_threads ! start of threaded loop ................... + i1_t = (it-1)*len_thread_m+1 + i2_t = min(i1_t+len_thread_m-1,len) +! + kmaxl = 0 + kminl = 0 + kmaxo = 0 + kmino = 0 + kmaxi = 0 + kmini = 0 + kmaxj = 0 + kminj = 0 + kmaxs = 0 + kmins = 0 +! +! +! lower bound check over bare land +! + if (fldlmn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).le.0..and. + & fld(i).lt.fldlmn-epsfld) then + kminl=kminl+1 + iwk(kminl) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kminl) + do i=1,nprt + ij = iwk(i) + print 8001,rla(ij),rlo(ij),fld(ij),fldlmn + 8001 format(' bare land min. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) + enddo + endif + if (mode .eq. 1) then + do i=1,kminl + fld(iwk(i)) = fldlmn + enddo + endif + endif +! +! upper bound check over bare land +! + if (fldlmx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).le.0..and. + & fld(i).gt.fldlmx+epsfld) then + kmaxl=kmaxl+1 + iwk(kmaxl) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxl) + do i=1,nprt + ij = iwk(i) + print 8002,rla(ij),rlo(ij),fld(ij),fldlmx + 8002 format(' bare land max. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e13.6, ' to ',e13.6) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxl + fld(iwk(i)) = fldlmx + enddo + endif + endif +! +! lower bound check over snow covered land +! + if (fldsmn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).gt.0..and. + & fld(i).lt.fldsmn-epsfld) then + kmins=kmins+1 + iwk(kmins) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmins) + do i=1,nprt + ij = iwk(i) + print 8003,rla(ij),rlo(ij),fld(ij),fldsmn + 8003 format(' sno covrd land min. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmins + fld(iwk(i)) = fldsmn + enddo + endif + endif +! +! upper bound check over snow covered land +! + if (fldsmx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.1..and.sno(i).gt.0..and. + & fld(i).gt.fldsmx+epsfld) then + kmaxs=kmaxs+1 + iwk(kmaxs) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxs) + do i=1,nprt + ij = iwk(i) + print 8004,rla(ij),rlo(ij),fld(ij),fldsmx + 8004 format(' snow land max. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxs + fld(iwk(i)) = fldsmx + enddo + endif + endif +! +! lower bound check over open ocean +! + if (fldomn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.0..and. + & fld(i).lt.fldomn-epsfld) then + kmino=kmino+1 + iwk(kmino) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmino) + do i=1,nprt + ij = iwk(i) + print 8005,rla(ij),rlo(ij),fld(ij),fldomn + 8005 format(' open ocean min. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4,' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmino + fld(iwk(i)) = fldomn + enddo + endif + endif +! +! upper bound check over open ocean +! + if (fldomx .ne. 999.0) then + do i=i1_t,i2_t + if(fldomx.ne.999..and.slimsk(i).eq.0..and. + & fld(i).gt.fldomx+epsfld) then + kmaxo=kmaxo+1 + iwk(kmaxo) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxo) + do i=1,nprt + ij = iwk(i) + print 8006,rla(ij),rlo(ij),fld(ij),fldomx + 8006 format(' open ocean max. check. lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxo + fld(iwk(i)) = fldomx + enddo + endif + endif +! +! lower bound check over sea ice without snow +! + if (fldimn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).le.0..and. + & fld(i).lt.fldimn-epsfld) then + kmini=kmini+1 + iwk(kmini) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmini) + do i=1,nprt + ij = iwk(i) + print 8007,rla(ij),rlo(ij),fld(ij),fldimn + 8007 format(' seaice no snow min. check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmini + fld(iwk(i)) = fldimn + enddo + endif + endif +! +! upper bound check over sea ice without snow +! + if (fldimx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).le.0..and. + & fld(i).gt.fldimx+epsfld .and. iceflg(i)) then +! & fld(i).gt.fldimx+epsfld) then + kmaxi=kmaxi+1 + iwk(kmaxi) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxi) + do i=1,nprt + ij = iwk(i) + print 8008,rla(ij),rlo(ij),fld(ij),fldimx + 8008 format(' seaice no snow max. check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxi + fld(iwk(i)) = fldimx + enddo + endif + endif +! +! lower bound check over sea ice with snow +! + if (fldjmn .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).gt.0..and. + & fld(i).lt.fldjmn-epsfld) then + kminj=kminj+1 + iwk(kminj) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kminj) + do i=1,nprt + ij = iwk(i) + print 8009,rla(ij),rlo(ij),fld(ij),fldjmn + 8009 format(' sea ice snow min. check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kminj + fld(iwk(i)) = fldjmn + enddo + endif + endif +! +! upper bound check over sea ice with snow +! + if (fldjmx .ne. 999.0) then + do i=i1_t,i2_t + if(slimsk(i).eq.2..and.sno(i).gt.0..and. + & fld(i).gt.fldjmx+epsfld .and. iceflg(i)) then +! & fld(i).gt.fldjmx+epsfld) then + kmaxj=kmaxj+1 + iwk(kmaxj) = i + endif + enddo + if(me == 0 . and. it == 1 .and. num_threads == 1) then + nprt = min(mmprt,kmaxj) + do i=1,nprt + ij = iwk(i) + print 8010,rla(ij),rlo(ij),fld(ij),fldjmx + 8010 format(' seaice snow max check lat=',f5.1, + & ' lon=',f6.1,' fld=',e11.4, ' to ',e11.4) + enddo + endif + if (mode .eq. 1) then + do i=1,kmaxj + fld(iwk(i)) = fldjmx + enddo + endif + endif + enddo ! end of threaded loop ................... +!$omp end parallel do +! +! print results +! + if(me .eq. 0) then +! write(6,*) 'summary of qc' + permax=0. + if(kminl.gt.0) then + per=float(kminl)/float(len)*100. + print 9001,fldlmn,kminl,per + 9001 format(' bare land min check. modified to ',f8.1, + & ' at ',i5,' points ',f8.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxl.gt.0) then + per=float(kmaxl)/float(len)*100. + print 9002,fldlmx,kmaxl,per + 9002 format(' bare land max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmino.gt.0) then + per=float(kmino)/float(len)*100. + print 9003,fldomn,kmino,per + 9003 format(' open ocean min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxo.gt.0) then + per=float(kmaxo)/float(len)*100. + print 9004,fldomx,kmaxo,per + 9004 format(' open sea max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmins.gt.0) then + per=float(kmins)/float(len)*100. + print 9009,fldsmn,kmins,per + 9009 format(' snow covered land min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxs.gt.0) then + per=float(kmaxs)/float(len)*100. + print 9010,fldsmx,kmaxs,per + 9010 format(' snow covered land max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmini.gt.0) then + per=float(kmini)/float(len)*100. + print 9005,fldimn,kmini,per + 9005 format(' bare ice min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxi.gt.0) then + per=float(kmaxi)/float(len)*100. + print 9006,fldimx,kmaxi,per + 9006 format(' bare ice max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kminj.gt.0) then + per=float(kminj)/float(len)*100. + print 9007,fldjmn,kminj,per + 9007 format(' snow covered ice min check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif + if(kmaxj.gt.0) then + per=float(kmaxj)/float(len)*100. + print 9008,fldjmx,kmaxj,per + 9008 format(' snow covered ice max check. modified to ',f8.1, + & ' at ',i5,' points ',f4.1,'percent') + if(per.gt.permax) permax=per + endif +! commented on 06/30/99 -- moorthi +! if(lgchek) then +! if(permax.gt.percrit) then +! write(6,*) ' too many bad points. aborting ....' +! call abort +! endif +! endif +! + endif +! + return + end + subroutine setzro(fld,eps,len) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) fld(len),eps + do i=1,len + if(abs(fld(i)).lt.eps) fld(i) = 0. + enddo + return + end + subroutine getscv(snofld,scvfld,len) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) snofld(len),scvfld(len) +! + do i=1,len + scvfld(i) = 0. + if(snofld(i).gt.0.) scvfld(i) = 1. + enddo + return + end + subroutine getstc(tsffld,tg3fld,slifld,len,lsoil,stcfld,tsfimx) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer k,i,len,lsoil + real (kind=kind_io8) factor,tsfimx + real (kind=kind_io8) tsffld(len), tg3fld(len), slifld(len) + real (kind=kind_io8) stcfld(len,lsoil) +! +! layer soil temperature +! + do k = 1, lsoil + do i = 1, len + if(slifld(i).eq.1.0) then + factor = ((k-1) * 2 + 1) / (2. * lsoil) + stcfld(i,k) = factor*tg3fld(i)+(1.-factor)*tsffld(i) + elseif(slifld(i).eq.2.0) then + factor = ((k-1) * 2 + 1) / (2. * lsoil) + stcfld(i,k) = factor*tsfimx+(1.-factor)*tsffld(i) + else + stcfld(i,k) = tg3fld(i) + endif + enddo + enddo + if(lsoil.gt.2) then + do k = 3, lsoil + do i = 1, len + stcfld(i,k) = stcfld(i,2) + enddo + enddo + endif + return + end + subroutine getsmc(wetfld,len,lsoil,smcfld,me) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer k,i,len,lsoil,me + real (kind=kind_io8) wetfld(len), smcfld(len,lsoil) +! + if (me .eq. 0) write(6,*) 'getsmc' +! +! layer soil wetness +! + do k = 1, lsoil + do i = 1, len + smcfld(i,k) = (wetfld(i)*1000./150.)*.37 + .1 + enddo + enddo + return + end + subroutine usesgt(sig1t,slianl,tg3anl,len,lsoil,tsfanl,stcanl, + & tsfimx) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len,lsoil + real (kind=kind_io8) tsfimx + real (kind=kind_io8) sig1t(len), slianl(len), tg3anl(len) + real (kind=kind_io8) tsfanl(len), stcanl(len,lsoil) +! +! soil temperature +! + if(sig1t(1).gt.0.) then + do i=1,len + if(slianl(i).ne.0.) then + tsfanl(i) = sig1t(i) + endif + enddo + endif + call getstc(tsfanl,tg3anl,slianl,len,lsoil,stcanl,tsfimx) +! + return + end + subroutine snosfc(snoanl,tsfanl,tsfsmx,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer kount,i,len,me + real (kind=kind_io8) per,tsfsmx + real (kind=kind_io8) snoanl(len), tsfanl(len) +! + if (me .eq. 0) write(6,*) 'set snow temp to tsfsmx if greater' + kount=0 + do i=1,len + if(snoanl(i).gt.0.) then + if(tsfanl(i).gt.tsfsmx) tsfanl(i)=tsfsmx + kount = kount + 1 + endif + enddo + if(kount.gt.0) then + if(me .eq. 0) then + per=float(kount)/float(len)*100. + write(6,*) 'snow sfc. tsf set to ',tsfsmx,' at ', + & kount, ' points ',per,'percent' + endif + endif + return + end + subroutine albocn(albclm,slmask,albomx,len) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) albomx + real (kind=kind_io8) albclm(len,4), slmask(len) + do i=1,len + if(slmask(i).eq.0) then + albclm(i,1) = albomx + albclm(i,2) = albomx + albclm(i,3) = albomx + albclm(i,4) = albomx + endif + enddo + return + end + subroutine qcmxice(glacir,amxice,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,kount,len,me + real (kind=kind_io8) glacir(len),amxice(len),per + if (me .eq. 0) write(6,*) 'qc of maximum ice extent' + kount=0 + do i=1,len + if(glacir(i).eq.1..and.amxice(i).eq.0.) then + amxice(i) = 0. + kount = kount + 1 + endif + enddo + if(kount.gt.0) then + per = float(kount) / float(len)*100. + if(me .eq. 0) write(6,*) ' max ice limit less than glacier' + &, ' coverage at ', kount, ' points ',per,'percent' + endif + return + end + subroutine qcsli(slianl,slifcs,len,me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,kount,len,me + real (kind=kind_io8) slianl(len), slifcs(len),per + if (me .eq. 0) then + write(6,*) ' ' + write(6,*) 'qcsli' + endif + kount=0 + do i=1,len + if(slianl(i).eq.1..and.slifcs(i).eq.0.) then + kount = kount + 1 + slifcs(i) = 1. + endif + if(slianl(i).eq.0..and.slifcs(i).eq.1.) then + kount = kount + 1 + slifcs(i) = 0. + endif + if(slianl(i).eq.2..and.slifcs(i).eq.1.) then + kount = kount + 1 + slifcs(i) = 0. + endif + if(slianl(i).eq.1..and.slifcs(i).eq.2.) then + kount = kount + 1 + slifcs(i) = 1. + endif + enddo + if(kount.gt.0) then + per=float(kount)/float(len)*100. + if(me .eq. 0) then + write(6,*) ' inconsistency of slmask between forecast and', + & ' analysis corrected at ',kount, ' points ',per, + & 'percent' + endif + endif + return + end +! subroutine nntprt(data,imax,fact) +! real (kind=kind_io8) data(imax) +! ilast=0 +! i1=1 +! i2=80 +!1112 continue +! if(i2.ge.imax) then +! ilast=1 +! i2=imax +! endif +! write(6,*) ' ' +! do j=1,jmax +! write(6,1111) (nint(data(imax*(j-1)+i)*fact),i=i1,i2) +! enddo +! if(ilast.eq.1) return +! i1=i1+80 +! i2=i1+79 +! if(i2.ge.imax) then +! ilast=1 +! i2=imax +! endif +! go to 1112 +!1111 format(80i1) +! return +! end + subroutine qcbyfc(tsffcs,snofcs,qctsfs,qcsnos,qctsfi, + & len,lsoil,snoanl,aisanl,slianl,tsfanl,albanl, + & zoranl,smcanl, + & smcclm,tsfsmx,albomx,zoromx, me) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer kount,me,k,i,lsoil,len + real (kind=kind_io8) zoromx,per,albomx,qctsfi,qcsnos,qctsfs,tsfsmx + real (kind=kind_io8) tsffcs(len), snofcs(len) + real (kind=kind_io8) snoanl(len), aisanl(len), + & slianl(len), zoranl(len), + & tsfanl(len), albanl(len,4), + & smcanl(len,lsoil) + real (kind=kind_io8) smcclm(len,lsoil) +! + if (me .eq. 0) write(6,*) 'qc of snow and sea-ice analysis' +! +! qc of snow analysis +! +! questionable snow cover +! + kount = 0 + do i=1,len + if(slianl(i).gt.0..and. + & tsffcs(i).gt.qctsfs.and.snoanl(i).gt.0.) then + kount = kount + 1 + snoanl(i) = 0. + tsfanl(i) = tsffcs(i) + endif + enddo + if(kount.gt.0) then + per=float(kount)/float(len)*100. + if (me .eq. 0) then + write(6,*) ' guess surface temp .gt. ',qctsfs, + & ' but snow analysis indicates snow cover' + write(6,*) ' snow analysis set to zero', + & ' at ',kount, ' points ',per,'percent' + endif + endif +! +! questionable no snow cover +! + kount = 0 + do i=1,len + if(slianl(i).gt.0..and. + & snofcs(i).gt.qcsnos.and.snoanl(i).lt.0.) then + kount = kount + 1 + snoanl(i) = snofcs(i) + tsfanl(i) = tsffcs(i) + endif + enddo + if(kount.gt.0) then + per=float(kount)/float(len)*100. + if (me .eq. 0) then + write(6,*) ' guess snow depth .gt. ',qcsnos, + & ' but snow analysis indicates no snow cover' + write(6,*) ' snow analysis set to guess value', + & ' at ',kount, ' points ',per,'percent' + endif + endif +! +! questionable sea ice cover ! this qc is disable to correct error in +! surface temparature over observed sea ice points +! +! kount = 0 +! do i=1,len +! if(slianl(i).eq.2..and. +! & tsffcs(i).gt.qctsfi.and.aisanl(i).eq.1.) then +! kount = kount + 1 +! aisanl(i) = 0. +! slianl(i) = 0. +! tsfanl(i) = tsffcs(i) +! snoanl(i) = 0. +! zoranl(i) = zoromx +! albanl(i,1) = albomx +! albanl(i,2) = albomx +! albanl(i,3) = albomx +! albanl(i,4) = albomx +! do k=1,lsoil +! smcanl(i,k) = smcclm(i,k) +! enddo +! endif +! enddo +! if(kount.gt.0) then +! per=float(kount)/float(len)*100. +! if (me .eq. 0) then +! write(6,*) ' guess surface temp .gt. ',qctsfi, +! & ' but sea-ice analysis indicates sea-ice' +! write(6,*) ' sea-ice analysis set to zero', +! & ' at ',kount, ' points ',per,'percent' +! endif +! endif +! + return + end + subroutine setrmsk(kpds5,slmask,igaul,jgaul,wlon,rnlat, + & data,imax,jmax,rlnout,rltout,lmask,rslmsk + &, gaus,blno, blto, kgds1, kpds4, lbms) + use machine , only : kind_io8,kind_io4 + use sfccyc_module + implicit none + real (kind=kind_io8) blno,blto,wlon,rnlat,crit,data_max + integer i,j,ijmax,jgaul,igaul,kpds5,jmax,imax, kgds1, kspla + integer, intent(in) :: kpds4 + logical*1, intent(in) :: lbms(imax,jmax) + real*4 :: dummy(imax,jmax) + + real (kind=kind_io8) slmask(igaul,jgaul) + real (kind=kind_io8) data(imax,jmax),rslmsk(imax,jmax) + &, rlnout(imax), rltout(jmax) + real (kind=kind_io8) a(jmax), w(jmax), radi, dlat, dlon + logical lmask, gaus +! +! set the longitude and latitudes for the grib file +! + if (kgds1 .eq. 4) then ! grib file on gaussian grid + kspla=4 + call splat(kspla, jmax, a, w) +! + radi = 180.0 / (4.*atan(1.)) + do j=1,jmax + rltout(j) = acos(a(j)) * radi + enddo +! + if (rnlat .gt. 0.0) then + do j=1,jmax + rltout(j) = 90. - rltout(j) + enddo + else + do j=1,jmax + rltout(j) = -90. + rltout(j) + enddo + endif + elseif (kgds1 .eq. 0) then ! grib file on lat/lon grid + dlat = -(rnlat+rnlat) / float(jmax-1) + do j=1,jmax + rltout(j) = rnlat + (j-1) * dlat + enddo + else ! grib file on some other grid + call abort + endif + dlon = 360.0 / imax + do i=1,imax + rlnout(i) = wlon + (i-1)*dlon + enddo +! +! + ijmax = imax*jmax + rslmsk = 0. +! +! surface temperature +! + if(kpds5.eq.kpdtsf) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! +! bucket soil wetness +! + elseif(kpds5.eq.kpdwet) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'wet rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! snow depth +! + elseif(kpds5.eq.kpdsnd) then + if(kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask=.true. + else + lmask=.false. + end if +! +! snow liq equivalent depth +! + elseif(kpds5.eq.kpdsno) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'sno rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! soil moisture +! + elseif(kpds5.eq.kpdsmc) then + if(kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask=.true. + else + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. + endif +! +! surface roughness +! + elseif(kpds5.eq.kpdzor) then + do j=1,jmax + do i=1,imax + rslmsk(i,j)=data(i,j) + enddo + enddo + crit=9.9 + call rof01(rslmsk,ijmax,'lt',crit) + lmask=.true. +! write(6,*) 'zor rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! albedo +! +! elseif(kpds5.eq.kpdalb) then +! do j=1,jmax +! do i=1,imax +! rslmsk(i,j)=data(i,j) +! enddo +! enddo +! crit=99. +! call rof01(rslmsk,ijmax,'lt',crit) +! lmask=.true. +! write(6,*) 'alb rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! albedo +! +!cbosu new snowfree albedo database has bitmap, use it. + elseif(kpds5.eq.kpdalb(1)) then + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if + elseif(kpds5.eq.kpdalb(2)) then +!cbosu + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if + elseif(kpds5.eq.kpdalb(3)) then +!cbosu + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if + elseif(kpds5.eq.kpdalb(4)) then +!cbosu + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has no water flag. + lmask=.false. + end if +! +! vegetation fraction for albedo +! + elseif(kpds5.eq.kpdalf(1)) then +! rslmsk=data +! crit=0. +! call rof01(rslmsk,ijmax,'gt',crit) +! lmask=.true. + lmask=.false. + elseif(kpds5.eq.kpdalf(2)) then +! rslmsk=data +! crit=0. +! call rof01(rslmsk,ijmax,'gt',crit) +! lmask=.true. + lmask=.false. +! +! sea ice +! + elseif(kpds5.eq.kpdais) then + lmask=.false. +! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat +! &, dlon, dlat, gaus, blno, blto) +! crit=0.5 +! call rof01(rslmsk,ijmax,'ge',crit) +! + data_max = 0.0 + do j=1,jmax + do i=1,imax + rslmsk(i,j) = data(i,j) + data_max= max(data_max,data(i,j)) + enddo + enddo + crit=1.0 + if (data_max .gt. crit) then + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. + else + lmask=.false. + endif +! write(6,*) 'acn rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! deep soil temperature +! + elseif(kpds5.eq.kpdtg3) then + lmask=.false. +! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat +! &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) +! crit=0.5 +! call rof01(rslmsk,ijmax,'ge',crit) +! lmask=.true. +! +! plant resistance +! +! elseif(kpds5.eq.kpdplr) then +! call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat +! &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) +! crit=0.5 +! call rof01(rslmsk,ijmax,'ge',crit) +! lmask=.true. +! +! write(6,*) 'plr rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! glacier points +! + elseif(kpds5.eq.kpdgla) then + lmask=.false. +! +! max ice extent +! + elseif(kpds5.eq.kpdmxi) then + lmask=.false. +! +! snow cover +! + elseif(kpds5.eq.kpdscv) then + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'scv rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! sea ice concentration +! + elseif(kpds5.eq.kpdacn) then + lmask=.false. + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) +! &, dlon, dlat, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. +! write(6,*) 'acn rslmsk' +! znnt=1. +! call nntprt(rslmsk,ijmax,znnt) +! +! vegetation cover +! + elseif(kpds5.eq.kpdveg) then +!cggg + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,jmax-j+1) = 1. ! need to flip grid in n/s direction + end if + enddo + enddo + lmask = .true. + else ! no bitmap, set mask the old way. + + call ga2la(slmask,igaul,jgaul,rslmsk,imax,jmax,wlon,rnlat + &, rlnout, rltout, gaus, blno, blto) + crit=0.5 + call rof01(rslmsk,ijmax,'ge',crit) + lmask=.true. + + end if +! +! soil type +! + elseif(kpds5.eq.kpdsot) then + + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo +! soil type is zero over water, use this to get a bitmap. + else + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + endif + lmask=.true. +! +! vegetation type +! + elseif(kpds5.eq.kpdvet) then + + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo +! veg type is zero over water, use this to get a bitmap. + else + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + endif + lmask=.true. +! +! these are for four new data type added by clu -- not sure its correct! +! + elseif(kpds5.eq.kpdvmn) then +! +!cggg greenness is zero over water, use this to get a bitmap. +! + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo +! + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. +!cggg lmask=.false. +! + elseif(kpds5.eq.kpdvmx) then +! +!cggg greenness is zero over water, use this to get a bitmap. +! + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo +! + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. +!cggg lmask=.false. +! + elseif(kpds5.eq.kpdslp) then +! +!cggg slope type is zero over water, use this to get a bitmap. +! + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo +! + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. +!cggg lmask=.false. +! +!cbosu new maximum snow albedo database has bitmap + elseif(kpds5.eq.kpdabs) then + if (kpds4 == 192) then ! use the bitmap + rslmsk = 0. + do j = 1, jmax + do i = 1, imax + if (lbms(i,j)) then + rslmsk(i,j) = 1. + end if + enddo + enddo + lmask = .true. + else ! no bitmap. old database has zero over water + do j = 1, jmax + do i = 1, imax + rslmsk(i,j) = data(i,j) + enddo + enddo + crit=0.1 + call rof01(rslmsk,ijmax,'gt',crit) + lmask=.true. + end if + endif +! + return + end + subroutine ga2la(gauin,imxin,jmxin,regout,imxout,jmxout, + & wlon,rnlat,rlnout,rltout,gaus,blno, blto) + use machine , only : kind_io8,kind_io4 + implicit none + integer i1,i2,j2,ishft,i,jj,j1,jtem,jmxout,imxin,jmxin,imxout, + & j,iret + real (kind=kind_io8) alamd,dxin,aphi,x,sum1,sum2,y,dlati,wlon, + & rnlat,dxout,dphi,dlat,facns,tem,blno, + & blto +! +! interpolation from lat/lon grid to other lat/lon grid +! + real (kind=kind_io8) gauin (imxin,jmxin), regout(imxout,jmxout) + &, rlnout(imxout), rltout(jmxout) + logical gaus +! + real, allocatable :: gaul(:) + real (kind=kind_io8) ddx(imxout),ddy(jmxout) + integer iindx1(imxout), iindx2(imxout), + & jindx1(jmxout), jindx2(jmxout) + integer jmxsav,n,kspla + data jmxsav/0/ + save jmxsav, gaul, dlati + real (kind=kind_io8) radi + real (kind=kind_io8) a(jmxin), w(jmxin) +! +! + logical first + integer num_threads + data first /.true./ + save num_threads, first +! + integer len_thread_m, j1_t, j2_t, it + integer num_parthds +! + if (first) then + num_threads = num_parthds() + first = .false. + endif +! + if (jmxin .ne. jmxsav) then + if (jmxsav .gt. 0) deallocate (gaul, stat=iret) + allocate (gaul(jmxin)) + jmxsav = jmxin + if (gaus) then +cjfe call gaulat(gaul,jmxin) +cjfe +! + kspla=4 + call splat(kspla, jmxin, a, w) +! + radi = 180.0 / (4.*atan(1.)) + do n=1,jmxin + gaul(n) = acos(a(n)) * radi + enddo +cjfe + do j=1,jmxin + gaul(j) = 90. - gaul(j) + enddo + else + dlat = -2*blto / float(jmxin-1) + dlati = 1 / dlat + do j=1,jmxin + gaul(j) = blto + (j-1) * dlat + enddo + endif + endif +! +! + dxin = 360. / float(imxin ) +! + do i=1,imxout + alamd = rlnout(i) + i1 = floor((alamd-blno)/dxin) + 1 + ddx(i) = (alamd-blno)/dxin-(i1-1) + iindx1(i) = modulo(i1-1,imxin) + 1 + iindx2(i) = modulo(i1 ,imxin) + 1 + enddo +! +! + len_thread_m = (jmxout+num_threads-1) / num_threads +! + if (gaus) then +! +!$omp parallel do private(j1_t,j2_t,it,j1,j2,jj) +!$omp+private(aphi) +!$omp+shared(num_threads,len_thread_m) +!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy) +! + do it=1,num_threads ! start of threaded loop ................... + j1_t = (it-1)*len_thread_m+1 + j2_t = min(j1_t+len_thread_m-1,jmxout) +! + j2=1 + do 40 j=j1_t,j2_t + aphi=rltout(j) + do 50 jj=1,jmxin + if(aphi.lt.gaul(jj)) go to 50 + j2=jj + go to 42 + 50 continue + 42 continue + if(j2.gt.2) go to 43 + j1=1 + j2=2 + go to 44 + 43 continue + if(j2.le.jmxin) go to 45 + j1=jmxin-1 + j2=jmxin + go to 44 + 45 continue + j1=j2-1 + 44 continue + jindx1(j)=j1 + jindx2(j)=j2 + ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) + 40 continue + enddo ! end of threaded loop ................... +!$omp end parallel do +! + else +!$omp parallel do private(j1_t,j2_t,it,j1,j2,jtem) +!$omp+private(aphi) +!$omp+shared(num_threads,len_thread_m) +!$omp+shared(jmxin,jmxout,gaul,rltout,jindx1,ddy,dlati,blto) +! + do it=1,num_threads ! start of threaded loop ................... + j1_t = (it-1)*len_thread_m+1 + j2_t = min(j1_t+len_thread_m-1,jmxout) +! + j2=1 + do 400 j=j1_t,j2_t + aphi=rltout(j) + jtem = (aphi - blto) * dlati + 1 + if (jtem .ge. 1 .and. jtem .lt. jmxin) then + j1 = jtem + j2 = j1 + 1 + ddy(j)=(aphi-gaul(j1))/(gaul(j2)-gaul(j1)) + elseif (jtem .eq. jmxin) then + j1 = jmxin + j2 = jmxin + ddy(j)=1.0 + else + j1 = 1 + j2 = 1 + ddy(j)=1.0 + endif +! + jindx1(j) = j1 + jindx2(j) = j2 + 400 continue + enddo ! end of threaded loop ................... +!$omp end parallel do + endif +! +! write(6,*) 'ga2la' +! write(6,*) 'iindx1' +! write(6,*) (iindx1(n),n=1,imxout) +! write(6,*) 'iindx2' +! write(6,*) (iindx2(n),n=1,imxout) +! write(6,*) 'jindx1' +! write(6,*) (jindx1(n),n=1,jmxout) +! write(6,*) 'jindx2' +! write(6,*) (jindx2(n),n=1,jmxout) +! write(6,*) 'ddy' +! write(6,*) (ddy(n),n=1,jmxout) +! write(6,*) 'ddx' +! write(6,*) (ddx(n),n=1,jmxout) +! +! +!$omp parallel do private(j1_t,j2_t,it,i,i1,i2) +!$omp+private(j,j1,j2,x,y) +!$omp+shared(num_threads,len_thread_m) +!$omp+shared(imxout,iindx1,jindx1,ddx,ddy,gauin,regout) +! + do it=1,num_threads ! start of threaded loop ................... + j1_t = (it-1)*len_thread_m+1 + j2_t = min(j1_t+len_thread_m-1,jmxout) +! + do j=j1_t,j2_t + y = ddy(j) + j1 = jindx1(j) + j2 = jindx2(j) + do i=1,imxout + x = ddx(i) + i1 = iindx1(i) + i2 = iindx2(i) + regout(i,j) = (1.-x)*((1.-y)*gauin(i1,j1) + y*gauin(i1,j2)) + & + x *((1.-y)*gauin(i2,j1) + y*gauin(i2,j2)) + enddo + enddo + enddo ! end of threaded loop ................... +!$omp end parallel do +! + sum1 = 0. + sum2 = 0. + do i=1,imxin + sum1 = sum1 + gauin(i,1) + sum2 = sum2 + gauin(i,jmxin) + enddo + sum1 = sum1 / float(imxin) + sum2 = sum2 / float(imxin) +! + if (gaus) then + if (rnlat .gt. 0.0) then + do i=1,imxout + regout(i, 1) = sum1 + regout(i,jmxout) = sum2 + enddo + else + do i=1,imxout + regout(i, 1) = sum2 + regout(i,jmxout) = sum1 + enddo + endif + else + if (blto .lt. 0.0) then + if (rnlat .gt. 0.0) then + do i=1,imxout + regout(i, 1) = sum2 + regout(i,jmxout) = sum1 + enddo + else + do i=1,imxout + regout(i, 1) = sum1 + regout(i,jmxout) = sum2 + enddo + endif + else + if (rnlat .lt. 0.0) then + do i=1,imxout + regout(i, 1) = sum2 + regout(i,jmxout) = sum1 + enddo + else + do i=1,imxout + regout(i, 1) = sum1 + regout(i,jmxout) = sum2 + enddo + endif + endif + endif +! + return + end + subroutine landtyp(vegtype,soiltype,slptype,slmask,len) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) vegtype(len),soiltype(len),slmask(len) + +, slptype(len) +! +! make sure that the soil type and veg type are non-zero over land +! + do i = 1, len + if (slmask(i) .eq. 1) then + if (vegtype(i) .eq. 0.) vegtype(i) = 7 + if (soiltype(i) .eq. 0.) soiltype(i) = 2 + if (slptype(i) .eq. 0.) slptype(i) = 1 + endif + enddo + return + end subroutine landtyp + subroutine gaulat(gaul,k) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer n,k + real (kind=kind_io8) radi + real (kind=kind_io8) a(k), w(k), gaul(k) +! + call splat(4, k, a, w) +! + radi = 180.0 / (4.*atan(1.)) + do n=1,k + gaul(n) = acos(a(n)) * radi + enddo +! +! print *,'gaussian lat (deg) for jmax=',k +! print *,(gaul(n),n=1,k) +! + return + 70 write(6,6000) + 6000 format(//5x,'error in gauaw'//) + stop + end +!----------------------------------------------------------------------- + subroutine anomint(tsfan0,tsfclm,tsfcl0,tsfanl,len) +! + use machine , only : kind_io8,kind_io4 + implicit none + integer i,len + real (kind=kind_io8) tsfanl(len), tsfan0(len), + & tsfclm(len), tsfcl0(len) +! +! time interpolation of anomalies +! add initial anomaly to date interpolated climatology +! + write(6,*) 'anomint' + do i=1,len + tsfanl(i) = tsfan0(i) - tsfcl0(i) + tsfclm(i) + enddo + return + end + subroutine clima(lugb,iy,im,id,ih,fh,len,lsoil, + & slmask,fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc, + & fnvmnc,fnvmxc,fnslpc,fnabsc,fnmldc,fnqfluxc, + & tsfclm,tsfcl2,wetclm,snoclm,zorclm,albclm,aisclm, + & tg3clm,cvclm ,cvbclm,cvtclm, + & cnpclm,smcclm,stcclm,sliclm,scvclm,acnclm,vegclm, + & vetclm,sotclm,alfclm, + & vmnclm,vmxclm,slpclm,absclm,mldclm,qfluxadj, + & kpdtsf,kpdwet,kpdsno,kpdzor,kpdalb,kpdais, + & kpdtg3,kpdscv,kpdacn,kpdsmc,kpdstc,kpdveg, + & kpdvet,kpdsot,kpdalf,tsfcl0, + & kpdvmn,kpdvmx,kpdslp,kpdabs,kpdmld,kpdqflux, + & deltsfc, lanom + &, imsk, jmsk, slmskh, outlat, outlon + &, gaus, blno, blto, me,lprnt,iprnt, fnalbc2, ialb + &, tile_num_ch, i_index, j_index) +! + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: i_index(len), j_index(len) + real (kind=kind_io8) rjday,wei1x,wei2x,rjdayh,wei2m,wei1m,wei1s, + & wei2s,fh,stcmon1s,blto,blno,deltsfc,rjdayh2 + real (kind=kind_io8) wei1y,wei2y + integer jdoy,jday,jh,jdow,mmm,mmp,mm,iret,monend,i,k,jm,jd,iy4, + & jy,mon1,is2,isx,kpd9,is1,l,nn,mon2,mon,is,kpdsno, + & kpdzor,kpdtsf,kpdwet,kpdscv,kpdacn,kpdais,kpdtg3,im,id, + & lugb,iy,len,lsoil,ih,kpdsmc,iprnt,me,m1,m2,k1,k2, + & kpdvet,kpdsot,kpdstc,kpdveg,jmsk,imsk,j,ialb + &, kpdvmn,kpdvmx,kpdslp,kpdabs,kpdmld,kpdqflux,landice_cat + integer kpdalb(4), kpdalf(2) +! + character*500 fntsfc,fnwetc,fnsnoc,fnzorc,fnalbc,fnaisc, + & fntg3c,fnscvc,fnsmcc,fnstcc,fnacnc,fnvegc, + & fnvetc,fnsotc,fnalbc2, fnmldc, fnqfluxc, + & fnvmnc,fnvmxc,fnslpc,fnabsc + real (kind=kind_io8) tsfclm(len),tsfcl2(len), + & wetclm(len),snoclm(len), + & zorclm(len),albclm(len,4),aisclm(len), + & tg3clm(len),acnclm(len), + & cvclm (len),cvbclm(len),cvtclm(len), + & cnpclm(len), + & smcclm(len,lsoil),stcclm(len,lsoil), + & sliclm(len),scvclm(len),vegclm(len), + & vetclm(len),sotclm(len),alfclm(len,2) + &, vmnclm(len),vmxclm(len),slpclm(len),absclm(len) + &, mldclm(len), qfluxadj(len) + real (kind=kind_io8) slmskh(imsk,jmsk) + real (kind=kind_io8) outlat(len), outlon(len) +! + real (kind=kind_io8) slmask(len), tsfcl0(len) + real (kind=kind_io8), allocatable :: slmask_noice(:) +! + logical lanom, gaus, first +! +! set z0 based on sib vegetation type + real (kind=kind_io8) z0_sib(13) + data z0_sib /2.653, 0.826, 0.563, 1.089, 0.854, 0.856, + & 0.035, 0.238, 0.065, 0.076, 0.011, 0.125, + & 0.011 / +! set z0 based on igbp vegetation type + real (kind=kind_io8) z0_igbp_min(20), z0_igbp_max(20) + real (kind=kind_io8) z0_season(12) + data z0_igbp_min /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, + & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, + & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, + & 0.050, 0.030/ + data z0_igbp_max /1.089, 2.653, 0.854, 0.826, 0.800, 0.050, + & 0.030, 0.856, 0.856, 0.150, 0.040, 0.130, + & 1.000, 0.250, 0.011, 0.011, 0.001, 0.076, + & 0.050, 0.030/ +! +! dayhf : julian day of the middle of each month +! + real (kind=kind_io8) dayhf(13) + data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, + & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ +! + real (kind=kind_io8) fha(5) + real(4) fha4(5) + integer w3kindreal,w3kindint + integer ida(8),jda(8),ivtyp, kpd7 +! + real (kind=kind_io8), allocatable :: tsf(:,:),sno(:,:), + & zor(:,:),wet(:,:), + & ais(:,:), acn(:,:), scv(:,:), smc(:,:,:), + & tg3(:), alb(:,:,:), alf(:,:), + & vet(:), sot(:), tsf2(:), + & veg(:,:), stc(:,:,:) + &, vmn(:), vmx(:), slp(:), abs(:), + & mld(:,:), qflux(:,:) +! + integer mon1s, mon2s, sea1s, sea2s, sea1, sea2, hyr1, hyr2 + data first/.true./ + data mon1s/0/, mon2s/0/, sea1s/0/, sea2s/0/ +! + save first, tsf, sno, zor, wet, ais, acn, scv, smc, tg3, + & alb, alf, vet, sot, tsf2, veg, stc, + & vmn, vmx, slp, abs, mld, qflux, + & mon1s, mon2s, sea1s, sea2s, dayhf, k1, k2, m1, m2, + & landice_cat +! + logical lprnt +! + do i=1,len + tsfclm(i) = 0.0 + tsfcl2(i) = 0.0 + snoclm(i) = 0.0 + wetclm(i) = 0.0 + zorclm(i) = 0.0 + aisclm(i) = 0.0 + tg3clm(i) = 0.0 + acnclm(i) = 0.0 + cvclm(i) = 0.0 + cvbclm(i) = 0.0 + cvtclm(i) = 0.0 + cnpclm(i) = 0.0 + sliclm(i) = 0.0 + scvclm(i) = 0.0 + vmnclm(i) = 0.0 + vmxclm(i) = 0.0 + slpclm(i) = 0.0 + absclm(i) = 0.0 + mldclm(i) = 0.0 + qfluxadj(i) = 0.0 + enddo + do k=1,lsoil + do i=1,len + smcclm(i,k) = 0.0 + stcclm(i,k) = 0.0 + enddo + enddo + do k=1,4 + do i=1,len + albclm(i,k) = 0.0 + enddo + enddo + do k=1,2 + do i=1,len + alfclm(i,k) = 0.0 + enddo + enddo +! + iret = 0 + monend = 9999 +! + if (first) then +! +! allocate variables to be saved +! + allocate (tsf(len,2), sno(len,2), zor(len,2), + & wet(len,2), ais(len,2), acn(len,2), + & scv(len,2), smc(len,lsoil,2), + & tg3(len), alb(len,4,2), alf(len,2), + & vet(len), sot(len), tsf2(len), +!clu [+1l] add vmn, vmx, slp, abs + & vmn(len), vmx(len), slp(len), abs(len), + & veg(len,2), mld(len,2), qflux(len,2), + & stc(len,lsoil,2)) +! +! get tsf climatology for the begining of the forecast +! + if (fh .gt. 0.0) then +!cbosu + if (me == 0 .and. print_debug) print*,'bosu fh gt 0' + + iy4=iy + if(iy.lt.101) iy4=1900+iy4 + fha=0 + ida=0 + jda=0 +! fha(2)=nint(fh) + ida(1)=iy + ida(2)=im + ida(3)=id + ida(5)=ih + call w3kind(w3kindreal,w3kindint) + if(w3kindreal == 4) then + fha4=fha + call w3movdat(fha4,ida,jda) + else + call w3movdat(fha,ida,jda) + endif + jy=jda(1) + jm=jda(2) + jd=jda(3) + jh=jda(5) + if (me .eq. 0 .and. print_debug) + & write(6,*) ' forecast jy,jm,jd,jh', + & jy,jm,jd,jh + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jda,jdow,jdoy,jday) + rjday=jdoy+jda(5)/24. + if(rjday.lt.dayhf(1)) rjday=rjday+365. +! + if (me .eq. 0 .and. print_debug) + & write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh +! +! for monthly mean climatology +! + monend = 12 + do mm=1,monend + mmm=mm + mmp=mm+1 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + mon1=mmm + mon2=mmp + go to 10 + endif + enddo + print *,'wrong rjday',rjday + call abort + 10 continue + wei1m = (dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) + wei2m = (rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if(mon2.eq.13) mon2=1 + if (me .eq. 0 .and. print_debug) + & print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m +! +! read monthly mean climatology of tsf +! + kpd7 = -1 + do nn=1,2 + mon = mon1 + if (nn .eq. 2) mon = mon2 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo +! +! tsf at the begining of forecast i.e. fh=0 +! + do i=1,len + tsfcl0(i) = wei1m * tsf(i,1) + wei2m * tsf(i,2) + enddo + endif + endif +! +! compute current jy,jm,jd,jh of forecast and the day of the year +! + iy4=iy + if(iy.lt.101) iy4=1900+iy4 + fha = 0 + ida = 0 + jda = 0 + fha(2) = nint(fh) + ida(1) = iy + ida(2) = im + ida(3) = id + ida(5) = ih + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + fha4=fha + call w3movdat(fha4,ida,jda) + else + call w3movdat(fha,ida,jda) + endif + jy = jda(1) + jm = jda(2) + jd = jda(3) + jh = jda(5) +! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', +! & jy,jm,jd,jh,rjday + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jda,jdow,jdoy,jday) + rjday = jdoy+jda(5)/24. + if(rjday.lt.dayhf(1)) rjday=rjday+365. + + if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', + & jy,jm,jd,jh,rjday +! + if (me .eq. 0) write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh +! +! for monthly mean climatology +! + monend = 12 + do mm=1,monend + mmm=mm + mmp=mm+1 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + mon1=mmm + mon2=mmp + go to 20 + endif + enddo + print *,'wrong rjday',rjday + call abort + 20 continue + wei1m=(dayhf(mon2)-rjday)/(dayhf(mon2)-dayhf(mon1)) + wei2m=(rjday-dayhf(mon1))/(dayhf(mon2)-dayhf(mon1)) + if(mon2.eq.13) mon2=1 + if (me .eq. 0 .and. print_debug) + & print *,'rjday,mon1,mon2,wei1m,wei2m=', + & rjday,mon1,mon2,wei1m,wei2m +! +! for seasonal mean climatology +! + monend = 4 + is = im/3 + 1 + if (is.eq.5) is = 1 + do mm=1,monend + mmm = mm*3 - 2 + mmp = (mm+1)*3 - 2 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + sea1 = mmm + sea2 = mmp + go to 30 + endif + enddo + print *,'wrong rjday',rjday + call abort + 30 continue + wei1s = (dayhf(sea2)-rjday)/(dayhf(sea2)-dayhf(sea1)) + wei2s = (rjday-dayhf(sea1))/(dayhf(sea2)-dayhf(sea1)) + if(sea2.eq.13) sea2=1 + if (me .eq. 0) print *,'rjday,sea1,sea2,wei1s,wei2s=', + & rjday,sea1,sea2,wei1s,wei2s +! +! for summer and winter values (maximum and minimum). +! + monend = 2 + is = im/6 + 1 + if (is.eq.3) is = 1 + do mm=1,monend + mmm = mm*6 - 5 + mmp = (mm+1)*6 - 5 + if(rjday.ge.dayhf(mmm).and.rjday.lt.dayhf(mmp)) then + hyr1 = mmm + hyr2 = mmp + go to 31 + endif + enddo + print *,'wrong rjday',rjday + call abort + 31 continue + wei1y = (dayhf(hyr2)-rjday)/(dayhf(hyr2)-dayhf(hyr1)) + wei2y = (rjday-dayhf(hyr1))/(dayhf(hyr2)-dayhf(hyr1)) + if(hyr2.eq.13) hyr2=1 + if (me .eq. 0) print *,'rjday,hyr1,hyr2,wei1y,wei2y=', + & rjday,hyr1,hyr2,wei1y,wei2y +! +! start reading in climatology and interpolate to the date +! + first_time : if (first) then +!cbosu + if (me == 0 .and. print_debug) print*,'bosu first time thru' +! +! annual mean climatology +! +! fraction of vegetation field for albedo -- there are two +! fraction fields in this version: strong zenith angle dependent +! and weak zenith angle dependent +! + kpd9 = -1 +cjfe + alf=0. +cjfe + + kpd7=-1 + if (ialb == 1) then +!cbosu still need facsf and facwf. read them from the production +!cbosu file + if ( index(fnalbc2, "tileX.nc") == 0) then ! grib file + call fixrdc(lugb,fnalbc2,kpdalf(1),kpd7,kpd9,slmask + &, alf,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnalbc2, tile_num_ch, i_index, j_index, + & kpdalf(1), alf(:,1), 1, len, me) + endif + else + call fixrdc(lugb,fnalbc,kpdalf(1),kpd7,kpd9,slmask + &, alf,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif + do i = 1, len + if(slmask(i).eq.1.) then + alf(i,2) = 100. - alf(i,1) + endif + enddo +! +! deep soil temperature +! + if(fntg3c(1:8).ne.' ') then + if ( index(fntg3c, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fntg3c,kpdtg3,kpd7,kpd9,slmask, + & tg3,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fntg3c, tile_num_ch, i_index, j_index, + & kpdtg3, tg3, 1, len, me) + endif + endif +! +! vegetation type +! +! when using the new gldas soil moisture climatology, a veg type +! dataset must be selected. +! + if(fnvetc(1:8).ne.' ') then + if ( index(fnvetc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvetc,kpdvet,kpd7,kpd9,slmask, + & vet,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + landice_cat=13 + if (maxval(vet)> 13.0) landice_cat=15 + else + call fixrdc_tile(fnvetc, tile_num_ch, i_index, j_index, + & kpdvet, vet, 1, len, me) + landice_cat=15 + endif + if (me .eq. 0) write(6,*) 'climatological vegetation', + & ' type read in.' + elseif(index(fnsmcc,'soilmgldas') /= 0) then ! new soil moisture climo + if (me .eq. 0) write(6,*) 'fatal error: must choose' + if (me .eq. 0) write(6,*) 'climatological veg type when' + if (me .eq. 0) write(6,*) 'using new gldas soil moisture.' + call abort + endif +! +! soil type +! + if(fnsotc(1:8).ne.' ') then + if ( index(fnsotc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnsotc,kpdsot,kpd7,kpd9,slmask, + & sot,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnsotc, tile_num_ch, i_index, j_index, + & kpdsot, sot, 1, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological soil type read in.' + endif + +! +! min vegetation cover +! + if(fnvmnc(1:8).ne.' ') then + if ( index(fnvmnc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvmnc,kpdvmn,kpd7,kpd9,slmask, + & vmn,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvmnc, tile_num_ch, i_index, j_index, + & 257, vmn, 99, len, me) + + endif + if (me .eq. 0) write(6,*) 'climatological shdmin read in.' + endif +! +! max vegetation cover +! + if(fnvmxc(1:8).ne.' ') then + if ( index(fnvmxc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvmxc,kpdvmx,kpd7,kpd9,slmask, + & vmx,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvmxc, tile_num_ch, i_index, j_index, + & 256, vmx, 99, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological shdmax read in.' + endif +! +! slope type +! + if(fnslpc(1:8).ne.' ') then + if ( index(fnslpc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnslpc,kpdslp,kpd7,kpd9,slmask, + & slp,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnslpc, tile_num_ch, i_index, j_index, + & kpdslp, slp, 1, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological slope read in.' + endif +! +! max snow albeod +! + if(fnabsc(1:8).ne.' ') then + if ( index(fnabsc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnabsc,kpdabs,kpd7,kpd9,slmask, + & abs,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnabsc, tile_num_ch, i_index, j_index, + & kpdabs, abs, 1, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological snoalb read in.' + endif +!clu ---------------------------------------------------------------------- +! + is1 = sea1/3 + 1 + is2 = sea2/3 + 1 + if (is1 .eq. 5) is1 = 1 + if (is2 .eq. 5) is2 = 1 + do nn=1,2 +! +! seasonal mean climatology + if(nn.eq.1) then + isx=is1 + else + isx=is2 + endif + if(isx.eq.1) kpd9 = 12 + if(isx.eq.2) kpd9 = 3 + if(isx.eq.3) kpd9 = 6 + if(isx.eq.4) kpd9 = 9 +! +! seasonal mean climatology +! +! albedo +! there are four albedo fields in this version: +! two for strong zeneith angle dependent (visible and near ir) +! and two for weak zeneith angle dependent (vis ans nir) +! + if (ialb == 0) then + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask, + & alb(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + endif +! +! monthly mean climatology +! + mon = mon1 + if (nn .eq. 2) mon = mon2 +!cbosu +!cbosu new snowfree albedo database is monthly. + if (ialb == 1) then + if ( index(fnalbc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + & alb(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + else + do k = 1, 4 + call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, + & kpdalb(k), alb(:,k,nn), mon, len, me) + enddo + endif + endif + +! if(lprnt) print *,' mon1=',mon1,' mon2=',mon2 +! +! tsf at the current time t +! + kpd7=-1 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! if(lprnt) print *,' tsf=',tsf(iprnt,nn),' nn=',nn +! +! tsf...at time t-deltsfc +! +! fh2 = fh - deltsfc +! if (fh2 .gt. 0.0) then +! call fixrd(lugb,fntsfc,kpdtsf,lclim,slmask, +! & iy,im,id,ih,fh2,tsfcl2,len,iret +! &, imsk, jmsk, slmskh, gaus,blno, blto +! &, outlat, outlon, me) +! else +! do i=1,len +! tsfcl2(i) = tsfclm(i) +! enddo +! endif +! +! soil wetness +! + if(fnwetc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + & wet(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnsmcc(1:8).ne.' ') then + if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data + kpd7=-1 + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + & smc(1,lsoil,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + do l=1,lsoil-1 + do i = 1, len + smc(i,l,nn) = smc(i,lsoil,nn) + enddo + enddo + else ! the new gldas data. it does not have data defined at landice + ! points. so for efficiency, don't have fixrdc try to + ! find a value at landice points as defined by the vet type (vet). + allocate(slmask_noice(len)) + slmask_noice=1.0 + do i = 1, len + if (nint(vet(i)) < 1 .or. + & nint(vet(i)) == landice_cat) then + slmask_noice(i) = 0.0 + endif + enddo + do k = 1, lsoil + if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) + if (k==2) kpd7=2600 ! 10_40 cm + if (k==3) kpd7=10340 ! 40_100 cm + if (k==4) kpd7=25800 ! 100_200 cm + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, + & smc(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + deallocate(slmask_noice) + endif + else + write(6,*) 'climatological soil wetness file not given' + call abort + endif +! +! soil temperature +! + if(fnstcc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnstcc,kpdstc,kpd7,mon,slmask, + & stc(1,lsoil,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + do l=1,lsoil-1 + do i = 1, len + stc(i,l,nn) = stc(i,lsoil,nn) + enddo + enddo + endif +! +! sea ice +! + kpd7=-1 + if(fnacnc(1:8).ne.' ') then + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + & acn(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnaisc(1:8).ne.' ') then + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + & ais(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + write(6,*) 'climatological ice cover file not given' + call abort + endif +! +! snow depth +! + kpd7=-1 + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + & sno(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! +! snow cover +! + if(fnscvc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + & scv(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + write(6,*) 'climatological snow cover read in.' + endif +! +! ocean mixed layer depth (MLD) +! + if(fnmldc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnmldc,kpdmld,kpd7,mon,slmask, + & mld(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + if (me .eq. 0) write(6,*) 'climatological ocean + & mixed layer depth read in.' + + endif +! +! qflux for slab ocean model +! + if(fnqfluxc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnqfluxc,kpdqflux,kpd7,mon,slmask, + & qflux(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + if (me .eq. 0) write(6,*) 'climatological ocean + & mixed layer depth read in.' + + endif +! +! surface roughness +! + if(fnzorc(1:3) == 'sib') then + if (me == 0) then + write(6,*) 'roughness length to be set from sib veg type' + endif + elseif(fnzorc(1:4) == 'igbp') then + if (me == 0) then + write(6,*) 'roughness length to be set from igbp veg type' + endif + else + kpd7=-1 + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + & zor(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif +! + do i = 1, len +! set clouds climatology to zero + cvclm (i) = 0. + cvbclm(i) = 0. + cvtclm(i) = 0. +! + cnpclm(i) = 0. !set canopy water content climatology to zero + enddo +! +! vegetation cover +! + if(fnvegc(1:8).ne.' ') then + if ( index(fnvegc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + & veg(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, + & kpdveg, veg(:,nn), mon, len, me) + endif + if (me .eq. 0) write(6,*) 'climatological vegetation', + & ' cover read in for mon=',mon + endif + + enddo +! + mon1s = mon1 ; mon2s = mon2 ; sea1s = sea1 ; sea2s = sea2 +! + if (me .eq. 0) print *,' mon1s=',mon1s,' mon2s=',mon2s + &,' sea1s=',sea1s,' sea2s=',sea2s +! + k1 = 1 ; k2 = 2 + m1 = 1 ; m2 = 2 +! + first = .false. + endif first_time +! +! to get tsf climatology at the previous call to sfccycle +! +! if (fh-deltsfc >= 0.0) then + rjdayh = rjday - deltsfc/24.0 +! else +! rjdayh = rjday +! endif +! if(lprnt) print *,' rjdayh=',rjdayh,' mon1=',mon1,' mon2=' +! &,mon2,' mon1s=',mon1s,' mon2s=',mon2s,' k1=',k1,' k2=',k2 + if (rjdayh .ge. dayhf(mon1)) then + if (mon2 .eq. 1) mon2 = 13 + wei1x = (dayhf(mon2)-rjdayh)/(dayhf(mon2)-dayhf(mon1)) + wei2x = 1.0 - wei1x + if (mon2 .eq. 13) mon2 = 1 + else + rjdayh2 = rjdayh + if (rjdayh .lt. dayhf(1)) rjdayh2 = rjdayh2 + 365.0 + if (mon1s .eq. mon1) then + mon1s = mon1 - 1 + if (mon1s .eq. 0) mon1s = 12 + k2 = k1 + k1 = mod(k2,2) + 1 + mon = mon1s + kpd7=-1 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,k1),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif + mon2s = mon1s + 1 +! if (mon2s .eq. 1) mon2s = 13 + wei1x = (dayhf(mon2s)-rjdayh2)/(dayhf(mon2s)-dayhf(mon1s)) + wei2x = 1.0 - wei1x + if (mon2s .eq. 13) mon2s = 1 + do i=1,len + tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) + enddo + endif +! +!cbosu new albedo is monthly + if (sea1 .ne. sea1s) then + sea1s = sea1 + sea2s = sea2 + m1 = mod(m1,2) + 1 + m2 = mod(m1,2) + 1 +! +! seasonal mean climatology +! + isx = sea2/3 + 1 + if (isx .eq. 5) isx = 1 + if(isx.eq.1) kpd9 = 12 + if(isx.eq.2) kpd9 = 3 + if(isx.eq.3) kpd9 = 6 + if(isx.eq.4) kpd9 = 9 +! +! albedo +! there are four albedo fields in this version: +! two for strong zeneith angle dependent (visible and near ir) +! and two for weak zeneith angle dependent (vis ans nir) +! +!cbosu + if (ialb == 0) then + kpd7=-1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,kpd9,slmask + &, alb(1,k,m2),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + endif + + endif + + if (mon1 .ne. mon1s) then + + mon1s = mon1 + mon2s = mon2 + k1 = mod(k1,2) + 1 + k2 = mod(k1,2) + 1 +! +! monthly mean climatology +! + mon = mon2 + nn = k2 +!cbosu + if (ialb == 1) then + if (me == 0) print*,'bosu 2nd time in clima for month ', + & mon, k1,k2 + if ( index(fnalbc, "tileX.nc") == 0) then ! grib file + kpd7 = -1 + do k = 1, 4 + call fixrdc(lugb,fnalbc,kpdalb(k),kpd7,mon,slmask, + & alb(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + else + do k = 1, 4 + call fixrdc_tile(fnalbc, tile_num_ch, i_index, j_index, + & kpdalb(k), alb(:,k,nn), mon, len, me) + enddo + endif + endif +! +! tsf at the current time t +! + kpd7=-1 + call fixrdc(lugb,fntsfc,kpdtsf,kpd7,mon,slmask, + & tsf(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! +! soil wetness +! + if(fnwetc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnwetc,kpdwet,kpd7,mon,slmask, + & wet(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnsmcc(1:8).ne.' ') then + if (index(fnsmcc,'global_soilmcpc.1x1.grb') /= 0) then ! the old climo data + kpd7=-1 + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask, + & smc(1,lsoil,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + do l=1,lsoil-1 + do i = 1, len + smc(i,l,nn) = smc(i,lsoil,nn) + enddo + enddo + else ! the new gldas data. it does not have data defined at landice + ! points. so for efficiency, don't have fixrdc try to + ! find a value at landice points as defined by the vet type (vet). + allocate(slmask_noice(len)) + slmask_noice=1.0 + do i = 1, len + if (nint(vet(i)) < 1 .or. + & nint(vet(i)) == landice_cat) then + slmask_noice(i) = 0.0 + endif + enddo + do k = 1, lsoil + if (k==1) kpd7=10 ! 0_10 cm (pds octs 11 and 12) + if (k==2) kpd7=2600 ! 10_40 cm + if (k==3) kpd7=10340 ! 40_100 cm + if (k==4) kpd7=25800 ! 100_200 cm + call fixrdc(lugb,fnsmcc,kpdsmc,kpd7,mon,slmask_noice, + & smc(1,k,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + enddo + deallocate(slmask_noice) + endif + else + write(6,*) 'climatological soil wetness file not given' + call abort + endif +! +! sea ice +! + kpd7=-1 + if(fnacnc(1:8).ne.' ') then + call fixrdc(lugb,fnacnc,kpdacn,kpd7,mon,slmask, + & acn(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + elseif(fnaisc(1:8).ne.' ') then + call fixrdc(lugb,fnaisc,kpdais,kpd7,mon,slmask, + & ais(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + write(6,*) 'climatological ice cover file not given' + call abort + endif +! +! snow depth +! + kpd7=-1 + call fixrdc(lugb,fnsnoc,kpdsno,kpd7,mon,slmask, + & sno(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) +! +! snow cover +! + if(fnscvc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnscvc,kpdscv,kpd7,mon,slmask, + & scv(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + write(6,*) 'climatological snow cover read in.' + endif +! +! ocean mixed layer depth (MLD) +! + if(fnmldc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnmldc,kpdmld,kpd7,mon,slmask, + & mld(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + if (me .eq. 0) write(6,*) 'climatological ocean + & mixed layer depth read in.' + + endif +! +! qflux for slab ocean model +! + if(fnqfluxc(1:8).ne.' ') then + kpd7=-1 + call fixrdc(lugb,fnqfluxc,kpdqflux,kpd7,mon,slmask, + & qflux(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + if (me .eq. 0) write(6,*) 'climatological ocean + & mixed layer depth read in.' + + endif +! +! surface roughness +! + if(fnzorc(1:3) == 'sib') then + if (me == 0) then + write(6,*) 'roughness length to be set from sib veg type' + endif + elseif(fnzorc(1:4) == 'igbp') then + if (me == 0) then + write(6,*) 'roughness length to be set from igbp veg type' + endif + else + kpd7=-1 + call fixrdc(lugb,fnzorc,kpdzor,kpd7,mon,slmask, + & zor(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + endif +! +! vegetation cover +! + if (fnvegc(1:8) .ne. ' ') then + if ( index(fnvegc, "tileX.nc") == 0) then ! grib file + kpd7=-1 + call fixrdc(lugb,fnvegc,kpdveg,kpd7,mon,slmask, + & veg(1,nn),len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + else + call fixrdc_tile(fnvegc, tile_num_ch, i_index, j_index, + & kpdveg, veg(:,nn), mon, len, me) + endif +! if (me .eq. 0) write(6,*) 'climatological vegetation', +! & ' cover read in for mon=',mon + endif +! + endif +! +! now perform the time interpolation +! +! when chosen, set the z0 based on the vegetation type. +! for this option to work, namelist variable fnvetc must be +! set to point at the proper vegetation type file. + if(fnzorc(1:3) == 'sib') then + if(fnvetc(1:4) == ' ') then + if (me==0) write(6,*) "must choose sib veg type climo file" + call abort + endif + zorclm = 0.0 + do i=1,len + ivtyp=nint(vet(i)) + if (ivtyp >= 1 .and. ivtyp <= 13) then + zorclm(i) = z0_sib(ivtyp) + endif + enddo + elseif(fnzorc(1:4) == 'igbp') then + if(fnvetc(1:4) == ' ') then + if (me==0) write(6,*) "must choose igbp veg type climo file" + call abort + endif + zorclm = 0.0 + do i=1,len + ivtyp=nint(vet(i)) + if (ivtyp >= 1 .and. ivtyp <= 20) then + z0_season(1) = z0_igbp_min(ivtyp) + z0_season(7) = z0_igbp_max(ivtyp) + if(outlat(i) < 0.0)then + zorclm(i) = wei1y * z0_season(hyr2) + + & wei2y *z0_season(hyr1) + else + zorclm(i) = wei1y * z0_season(hyr1) + + & wei2y *z0_season(hyr2) + endif + endif + enddo + else + do i=1,len + zorclm(i) = wei1m * zor(i,k1) + wei2m * zor(i,k2) + enddo + endif +! + do i=1,len + tsfclm(i) = wei1m * tsf(i,k1) + wei2m * tsf(i,k2) + snoclm(i) = wei1m * sno(i,k1) + wei2m * sno(i,k2) + cvclm(i) = 0.0 + cvbclm(i) = 0.0 + cvtclm(i) = 0.0 + cnpclm(i) = 0.0 + tsfcl2(i) = tsf2(i) + enddo +! if(lprnt) print *,' tsfclm=',tsfclm(iprnt),' wei1m=',wei1m +! &,' wei2m=',wei2m,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) +! + if (fh .eq. 0.0) then + do i=1,len + tsfcl0(i) = tsfclm(i) + enddo + endif + if (rjdayh .ge. dayhf(mon1)) then + do i=1,len + tsf2(i) = wei1x * tsf(i,k1) + wei2x * tsf(i,k2) + tsfcl2(i) = tsf2(i) + enddo + endif +! if(lprnt) print *,' tsf2=',tsf2(iprnt),' wei1x=',wei1x +! &,' wei2x=',wei2x,' tsfk12=',tsf(iprnt,k1),tsf(iprnt,k2) +! &,' mon1s=',mon1s,' mon2s=',mon2s +! &,' slmask=',slmask(iprnt) +! + if(fnacnc(1:8).ne.' ') then + do i=1,len + acnclm(i) = wei1m * acn(i,k1) + wei2m * acn(i,k2) + enddo + elseif(fnaisc(1:8).ne.' ') then + do i=1,len + aisclm(i) = wei1m * ais(i,k1) + wei2m * ais(i,k2) + enddo + endif +! + if(fnwetc(1:8).ne.' ') then + do i=1,len + wetclm(i) = wei1m * wet(i,k1) + wei2m * wet(i,k2) + enddo + elseif(fnsmcc(1:8).ne.' ') then + do k=1,lsoil + do i=1,len + smcclm(i,k) = wei1m * smc(i,k,k1) + wei2m * smc(i,k,k2) + enddo + enddo + endif +! + if(fnscvc(1:8).ne.' ') then + do i=1,len + scvclm(i) = wei1m * scv(i,k1) + wei2m * scv(i,k2) + enddo + endif +! + if(fntg3c(1:8).ne.' ') then + do i=1,len + tg3clm(i) = tg3(i) + enddo + elseif(fnstcc(1:8).ne.' ') then + do k=1,lsoil + do i=1,len + stcclm(i,k) = wei1m * stc(i,k,k1) + wei2m * stc(i,k,k2) + enddo + enddo + endif +! + if(fnvegc(1:8).ne.' ') then + do i=1,len + vegclm(i) = wei1m * veg(i,k1) + wei2m * veg(i,k2) + enddo + endif +! + if(fnvetc(1:8).ne.' ') then + do i=1,len + vetclm(i) = vet(i) + enddo + endif +! + if(fnsotc(1:8).ne.' ') then + do i=1,len + sotclm(i) = sot(i) + enddo + endif + + +!clu ---------------------------------------------------------------------- +! + if(fnvmnc(1:8).ne.' ') then + do i=1,len + vmnclm(i) = vmn(i) + enddo + endif +! + if(fnvmxc(1:8).ne.' ') then + do i=1,len + vmxclm(i) = vmx(i) + enddo + endif +! + if(fnslpc(1:8).ne.' ') then + do i=1,len + slpclm(i) = slp(i) + enddo + endif +! + if(fnabsc(1:8).ne.' ') then + do i=1,len + absclm(i) = abs(i) + enddo + endif + + if(fnmldc(1:8).ne.' ') then + do i=1,len + mldclm(i) = wei1m * mld(i,k1) + wei2m * mld(i,k2) + enddo + endif +!clu ---------------------------------------------------------------------- +! +!cbosu diagnostic print + if (me == 0) print*,'monthly albedo weights are ', + & wei1m,' for k', k1, wei2m, ' for k', k2 + + if (ialb == 1) then + do k=1,4 + do i=1,len + albclm(i,k) = wei1m * alb(i,k,k1) + wei2m * alb(i,k,k2) + enddo + enddo + else + do k=1,4 + do i=1,len + albclm(i,k) = wei1s * alb(i,k,m1) + wei2s * alb(i,k,m2) + enddo + enddo + endif +! + do k=1,2 + do i=1,len + alfclm(i,k) = alf(i,k) + enddo + enddo +! +! end of climatology reads +! + return + end subroutine clima + subroutine fixrdc_tile(filename_raw, tile_num_ch, + & i_index, j_index, kpds, + & var, mon, npts, me) + use netcdf + use machine , only : kind_io8 + implicit none + character(len=*), intent(in) :: filename_raw + character(len=*), intent(in) :: tile_num_ch + integer, intent(in) :: npts, me, kpds, mon + integer, intent(in) :: i_index(npts) + integer, intent(in) :: j_index(npts) + real(kind_io8), intent(out) :: var(npts) + character(len=500) :: filename + character(len=80) :: errmsg + integer :: i, ii, ncid, t + integer :: error, id_dim + integer :: nx, ny, num_times + integer :: id_var + real(kind=4), allocatable :: dummy(:,:,:) + ii=index(filename_raw,"tileX") + + do i = 1, len(filename) + filename(i:i) = " " + enddo + + filename = filename_raw(1:ii-1) // tile_num_ch // ".nc" + + if (me == 0) print*, ' in fixrdc_tile for mon=',mon, + & ' filename=', trim(filename) + + error=nf90_open(trim(filename), nf90_nowrite, ncid) + if (error /= nf90_noerr) call netcdf_err(error) + + error=nf90_inq_dimid(ncid, 'nx', id_dim) + if (error /= nf90_noerr) call netcdf_err(error) + error=nf90_inquire_dimension(ncid,id_dim,len=nx) + if (error /= nf90_noerr) call netcdf_err(error) + + error=nf90_inq_dimid(ncid, 'ny', id_dim) + if (error /= nf90_noerr) call netcdf_err(error) + error=nf90_inquire_dimension(ncid,id_dim,len=ny) + if (error /= nf90_noerr) call netcdf_err(error) + + error=nf90_inq_dimid(ncid, 'time', id_dim) + if (error /= nf90_noerr) call netcdf_err(error) + error=nf90_inquire_dimension(ncid,id_dim,len=num_times) + if (error /= nf90_noerr) call netcdf_err(error) + + select case (kpds) + case(11) + error=nf90_inq_varid(ncid, 'substrate_temperature', id_var) + case(87) + error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) + case(159) + error=nf90_inq_varid(ncid, 'maximum_snow_albedo', id_var) + case(189) + error=nf90_inq_varid(ncid, 'visible_black_sky_albedo', id_var) + case(190) + error=nf90_inq_varid(ncid, 'visible_white_sky_albedo', id_var) + case(191) + error=nf90_inq_varid(ncid, 'near_IR_black_sky_albedo', id_var) + case(192) + error=nf90_inq_varid(ncid, 'near_IR_white_sky_albedo', id_var) + case(214) + error=nf90_inq_varid(ncid, 'facsf', id_var) + case(224) + error=nf90_inq_varid(ncid, 'soil_type', id_var) + case(225) + error=nf90_inq_varid(ncid, 'vegetation_type', id_var) + case(236) + error=nf90_inq_varid(ncid, 'slope_type', id_var) + case(256:257) + error=nf90_inq_varid(ncid, 'vegetation_greenness', id_var) + case default + print*,'fatal error in fixrdc_tile of sfcsub.F.' + print*,'unknown variable.' + call abort + end select + if (error /= nf90_noerr) call netcdf_err(error) + + allocate(dummy(nx,ny,1)) + + if (kpds == 256) then ! max veg greenness + + var = -9999. + do t = 1, num_times + error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), + & count=(/nx,ny,1/) ) + if (error /= nf90_noerr) call netcdf_err(error) + do ii = 1,npts + var(ii) = max(var(ii), dummy(i_index(ii),j_index(ii),1)) + enddo + enddo + + elseif (kpds == 257) then ! min veg greenness + + var = 9999. + do t = 1, num_times + error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,t/), + & count=(/nx,ny,1/) ) + if (error /= nf90_noerr) call netcdf_err(error) + do ii = 1, npts + var(ii) = min(var(ii), dummy(i_index(ii),j_index(ii),1)) + enddo + enddo + + else + + error=nf90_get_var(ncid, id_var, dummy, start=(/1,1,mon/), + & count=(/nx,ny,1/) ) + if (error /= nf90_noerr) call netcdf_err(error) + + do ii = 1, npts + var(ii) = dummy(i_index(ii),j_index(ii),1) + enddo + + endif + + deallocate(dummy) + + error=nf90_close(ncid) + + select case (kpds) + case(159) ! max snow alb + var = var * 100.0 + case(214) ! facsf + where (var < 0.0) var = 0.0 + var = var * 100.0 + case(189:192) + var = var * 100.0 + case(256:257) + var = var * 100.0 + end select + + return + + end subroutine fixrdc_tile + subroutine netcdf_err(error) + + use netcdf + implicit none + + integer,intent(in) :: error + character(len=256) :: errmsg + + errmsg = nf90_strerror(error) + print*,'fatal error in sfcsub.F: ', trim(errmsg) + call abort + + end subroutine netcdf_err + subroutine fixrdc(lugb,fngrib,kpds5,kpds7,mon,slmask, + & gdata,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + integer imax,jmax,ijmax,i,j,n,jret,inttyp,iret,imsk, + & jmsk,len,lugb,kpds5,mon,lskip,lgrib,ndata,lugi,me,kmami + &, jj,w3kindreal,w3kindint + real (kind=kind_io8) wlon,elon,rnlat,dlat,dlon,rslat,blno,blto +! +! read in grib climatology files and interpolate to the input +! grid. grib files should allow all the necessary parameters +! to be extracted from the description records. +! +! + character*500 fngrib +! character*80 fngrib, asgnstr +! + real (kind=kind_io8) slmskh(imsk,jmsk) +! + real (kind=kind_io8) gdata(len), slmask(len) + real (kind=kind_io8), allocatable :: data(:,:), rslmsk(:,:) + real (kind=kind_io8) data8(mdata) + real (kind=kind_io4), allocatable :: data4(:) + real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) +! + logical lmask, yr2kc, gaus, ijordr + logical*1 lbms(mdata) +! + integer, intent(in) :: kpds7 + integer kpds(1000),kgds(1000) + integer jpds(1000),jgds(1000), kpds0(1000) + real (kind=kind_io8) outlat(len), outlon(len) +! +! integer imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv +! date imax_sv/0/, jmax_sv/0/, wlon_sv/999.0/, rnlat_sv/999.0/ +! &, kpds1_sv/-1/ +! save imax_sv, jmax_sv, wlon_sv, rnlat_sv, kpds1_sv +! &, rlngrb, rltgrb +! + iret = 0 +! + if (me .eq. 0 .and. print_debug) write(6,*) + & ' in fixrdc for mon=',mon + &,' fngrib=',trim(fngrib) +! + close(lugb) + call baopenr(lugb,fngrib,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fngrib) + print *,'error in opening file ',trim(fngrib) + call abort + endif + if (me .eq. 0 .and. print_debug) + & write(6,'(A6, A, A, I4)') ' file ',trim(fngrib), + & ' opened. unit=',lugb +! + lugi = 0 +! + lskip = -1 + jpds = -1 + jgds = -1 + jpds(5) = kpds5 + jpds(7) = kpds7 + kpds = jpds + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) + if (me .eq. 0 .and. print_debug) then + write(6,*) ' first grib record.' + write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) + write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) + write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) + endif + yr2kc = (kpds(8) / 100) .gt. 0 + kpds0 = jpds + kpds0(4) = -1 + kpds0(18) = -1 + if(iret.ne.0) then + write(6,*) ' error in getgbh. iret: ', iret + if (iret==99) write(6,*) ' field not found.' + call abort + endif +! +! handling climatology file +! + lskip = -1 + n = 0 + jpds = kpds0 + jpds(9) = mon + if(jpds(9).eq.13) jpds(9) = 1 + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==8) then + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data8,jret) + else if (w3kindreal==4) then + allocate(data4(mdata)) + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data4,jret) + data8 = data4 + deallocate(data4) + endif + if (me .eq. 0 .and. print_debug) + & write(6,*) ' input grib file dates=', + & (kpds(i),i=8,11) + if(jret.eq.0) then + if(ndata.eq.0) then + write(6,*) ' error in getgb' + write(6,*) ' kpds=',kpds + write(6,*) ' kgds=',kgds + call abort + endif + imax=kgds(2) + jmax=kgds(3) + ijmax=imax*jmax + allocate (data(imax,jmax)) + do j=1,jmax + jj = (j-1)*imax + do i=1,imax + data(i,j) = data8(jj+i) + enddo + enddo + if (me .eq. 0 .and. print_debug) write(6,*) 'imax,jmax,ijmax=',imax,jmax,ijmax + else + write(6,*) ' error in getgb - jret=', jret + call abort + endif +! + if (me .eq. 0 .and. print_debug) then + write(6,*) ' maxmin of input as is' + kmami=1 + call maxmin(data(1,1),ijmax,kmami) + endif +! + call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) + if (me .eq. 0 .and. print_debug) then + write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' + write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat + endif + call subst(data,imax,jmax,dlon,dlat,ijordr) +! +! first get slmask over input grid +! + allocate (rlngrb(imax), rltgrb(jmax)) + allocate (rslmsk(imax,jmax)) + + call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, + & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk + &, gaus,blno, blto, kgds(1), kpds(4), lbms) +! write(6,*) ' kpds5=',kpds5,' lmask=',lmask +! + inttyp = 0 + if(kpds5.eq.225) inttyp = 1 + if(kpds5.eq.230) inttyp = 1 + if(kpds5.eq.236) inttyp = 1 + if(kpds5.eq.224) inttyp = 1 + if (me .eq. 0 .and. print_debug) then + if(inttyp.eq.1) print *, ' nearest grid point used' + &, ' kpds5=',kpds5, ' lmask = ',lmask + endif +! + call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, + & gdata,len,lmask,rslmsk,slmask + &, outlat, outlon,me) +! + deallocate (rlngrb, stat=iret) + deallocate (rltgrb, stat=iret) + deallocate (data, stat=iret) + deallocate (rslmsk, stat=iret) + call baclose(lugb,iret) +! + return + end + subroutine fixrda(lugb,fngrib,kpds5,slmask, + & iy,im,id,ih,fh,gdata,len,iret + &, imsk, jmsk, slmskh, gaus,blno, blto + &, outlat, outlon, me) + use machine , only : kind_io8,kind_io4 + use sfccyc_module, only : mdata, print_debug + implicit none + integer nrepmx,nvalid,imo,iyr,idy,jret,ihr,nrept,lskip,lugi, + & lgrib,j,ndata,i,inttyp,jmax,imax,ijmax,ij,jday,len,iret, + & jmsk,imsk,ih,kpds5,lugb,iy,id,im,jh,jd,jdoy,jdow,jm,me, + & monend,jy,iy4,kmami,iret2,jj,w3kindreal,w3kindint + real (kind=kind_io8) rnlat,rslat,wlon,elon,dlon,dlat,fh,blno, + & rjday,blto +! +! read in grib climatology/analysis files and interpolate to the input +! dates and the grid. grib files should allow all the necessary parameters +! to be extracted from the description records. +! +! nrepmx: max number of days for going back date search +! nvalid: analysis later than (current date - nvalid) is regarded as +! valid for current analysis +! + parameter(nrepmx=15, nvalid=4) +! + character*500 fngrib +! character*80 fngrib, asgnstr +! + real (kind=kind_io8) slmskh(imsk,jmsk) +! + real (kind=kind_io8) gdata(len), slmask(len) + real (kind=kind_io8), allocatable :: data(:,:),rslmsk(:,:) + real (kind=kind_io8) data8(mdata) + real (kind=kind_io4), allocatable :: data4(:) + real (kind=kind_io8), allocatable :: rlngrb(:), rltgrb(:) +! + logical lmask, yr2kc, gaus, ijordr + logical*1 lbms(mdata) +! + integer kpds(1000),kgds(1000) + integer jpds(1000),jgds(1000), kpds0(1000) + real (kind=kind_io8) outlat(len), outlon(len) +! +! dayhf : julian day of the middle of each month +! + real (kind=kind_io8) dayhf(13) + data dayhf/ 15.5, 45.0, 74.5,105.0,135.5,166.0, + & 196.5,227.5,258.0,288.5,319.0,349.5,380.5/ +! +! mjday : number of days in a month +! + integer mjday(12) + data mjday/31,28,31,30,31,30,31,31,30,31,30,31/ +! + real (kind=kind_io8) fha(5) + real(4) fha4(5) + integer ida(8),jda(8) +! + iret = 0 + monend = 9999 +! +! compute jy,jm,jd,jh of forecast and the day of the year +! + iy4=iy + if(iy.lt.101) iy4=1900+iy4 + fha=0 + ida=0 + jda=0 + fha(2)=nint(fh) + ida(1)=iy + ida(2)=im + ida(3)=id + ida(5)=ih + call w3kind(w3kindreal,w3kindint) + if(w3kindreal==4) then + fha4=fha + call w3movdat(fha4,ida,jda) + else + call w3movdat(fha,ida,jda) + endif + jy=jda(1) + jm=jda(2) + jd=jda(3) + jh=jda(5) +! if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', +! & jy,jm,jd,jh,rjday + jdow = 0 + jdoy = 0 + jday = 0 + call w3doxdat(jda,jdow,jdoy,jday) + rjday=jdoy+jda(5)/24. + if(rjday.lt.dayhf(1)) rjday=rjday+365. + + if (me .eq. 0) write(6,*) ' forecast jy,jm,jd,jh,rjday=', + & jy,jm,jd,jh,rjday +! + if (me .eq. 0) then + write(6,*) 'forecast jy,jm,jd,jh=',jy,jm,jd,jh +! + write(6,*) ' ' + write(6,*) '************************************************' + endif +! + close(lugb) + call baopenr(lugb,fngrib,iret) + if (iret .ne. 0) then + write(6,*) ' error in opening file ',trim(fngrib) + print *,'error in opening file ',trim(fngrib) + call abort + endif + if (me .eq. 0 .and. print_debug) + & write(6,'(A6, A, A, I4)') ' file ',trim(fngrib), + & ' opened. unit=',lugb +! + lugi = 0 +! + lskip=-1 + jpds=-1 + jgds=-1 + jpds(5)=kpds5 + kpds = jpds + call getgbh(lugb,lugi,lskip,jpds,jgds,lgrib,ndata, + & lskip,kpds,kgds,iret) + if (me .eq. 0 .and. print_debug) then + write(6,*) ' first grib record.' + write(6,*) ' kpds( 1-10)=',(kpds(j),j= 1,10) + write(6,*) ' kpds(11-20)=',(kpds(j),j=11,20) + write(6,*) ' kpds(21- )=',(kpds(j),j=21,22) + endif + yr2kc = (kpds(8) / 100) .gt. 0 + kpds0=jpds + kpds0(4)=-1 + kpds0(18)=-1 + if(iret.ne.0) then + write(6,*) ' error in getgbh. iret: ', iret + if(iret==99) write(6,*) ' field not found.' + call abort + endif +! +! handling analysis file +! +! find record for the given hour/day/month/year +! + nrept=0 + jpds=kpds0 + lskip = -1 + iyr=jy + if(iyr.le.100) iyr=2050-mod(2050-iyr,100) + imo=jm + idy=jd + ihr=jh +! year 2000 compatible data + if (yr2kc) then + jpds(8) = iyr + else + jpds(8) = mod(iyr,1900) + endif + 50 continue + jpds( 8)=mod(iyr-1,100)+1 + jpds( 9)=imo + jpds(10)=idy +! jpds(11)=ihr + jpds(21)=(iyr-1)/100+1 + call w3kind(w3kindreal,w3kindint) + if (w3kindreal == 8) then + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data8,jret) + elseif (w3kindreal == 4) then + allocate (data4(mdata)) + call getgb(lugb,lugi,mdata,lskip,jpds,jgds,ndata,lskip, + & kpds,kgds,lbms,data4,jret) + data8 = data4 + deallocate(data4) + endif + if (me .eq. 0 .and. print_debug) write(6,*) + & ' input grib file dates=', + & (kpds(i),i=8,11) + if(jret.eq.0) then + if(ndata.eq.0) then + write(6,*) ' error in getgb' + write(6,*) ' kpds=',kpds + write(6,*) ' kgds=',kgds + call abort + endif + imax=kgds(2) + jmax=kgds(3) + ijmax=imax*jmax + allocate (data(imax,jmax)) + do j=1,jmax + jj = (j-1)*imax + do i=1,imax + data(i,j) = data8(jj+i) + enddo + enddo + else + if(nrept.eq.0) then + if (me .eq. 0) then + write(6,*) ' no matching dates found. start searching', + & ' nearest matching dates (going back).' + endif + endif +! +! no matching ih found. search nearest hour +! + if(ihr.eq.6) then + ihr=0 + go to 50 + elseif(ihr.eq.12) then + ihr=0 + go to 50 + elseif(ihr.eq.18) then + ihr=12 + go to 50 + elseif(ihr.eq.0.or.ihr.eq.-1) then + idy=idy-1 + if(idy.eq.0) then + imo=imo-1 + if(imo.eq.0) then + iyr=iyr-1 + if(iyr.lt.0) iyr=99 + imo=12 + endif + idy=31 + if(imo.eq.4.or.imo.eq.6.or.imo.eq.9.or.imo.eq.11) idy=30 + if(imo.eq.2) then + if(mod(iyr,4).eq.0) then + idy=29 + else + idy=28 + endif + endif + endif + ihr=-1 + if (me .eq. 0) write(6,*) ' decremented dates=', + & iyr,imo,idy,ihr + nrept=nrept+1 + if(nrept.gt.nvalid) iret=-1 + if(nrept.gt.nrepmx) then + if (me .eq. 0) then + write(6,*) ' searching range exceeded.' + &, ' may be wrong grib file given' + write(6,*) ' fngrib=',trim(fngrib) + write(6,*) ' terminating search and', + & ' and setting gdata to -999' + write(6,*) ' range max=',nrepmx + endif +! imax=kgds(2) +! jmax=kgds(3) +! ijmax=imax*jmax +! do ij=1,ijmax +! data(ij)=0. +! enddo + go to 100 + endif + go to 50 + else + if (me .eq. 0) then + write(6,*) ' search of analysis for ihr=',ihr,' failed.' + write(6,*) ' kpds=',kpds + write(6,*) ' iyr,imo,idy,ihr=',iyr,imo,idy,ihr + endif + go to 100 + endif + endif +! + 80 continue + if (me .eq. 0) then + write(6,*) ' maxmin of input as is' + kmami=1 + call maxmin(data(1,1),ijmax,kmami) + endif +! + call getarea(kgds,dlat,dlon,rslat,rnlat,wlon,elon,ijordr,me) + if (me .eq. 0 .and. print_debug) then + write(6,*) 'imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat=' + write(6,*) imax,jmax,ijmax,dlon,dlat,ijordr,wlon,rnlat + endif + call subst(data,imax,jmax,dlon,dlat,ijordr) +! +! first get slmask over input grid +! + allocate (rlngrb(imax), rltgrb(jmax)) + allocate (rslmsk(imax,jmax)) + call setrmsk(kpds5,slmskh,imsk,jmsk,wlon,rnlat, + & data,imax,jmax,rlngrb,rltgrb,lmask,rslmsk +! & data,imax,jmax,abs(dlon),abs(dlat),lmask,rslmsk +!cggg &, gaus,blno, blto, kgds(1)) + &, gaus,blno, blto, kgds(1), kpds(4), lbms) + +! write(6,*) ' kpds5=',kpds5,' lmask=',lmask +! + inttyp = 0 + if(kpds5.eq.225) inttyp = 1 + if(kpds5.eq.230) inttyp = 1 + if(kpds5.eq.66) inttyp = 1 + if(inttyp.eq.1) print *, ' nearest grid point used' +! + call la2ga(data,imax,jmax,rlngrb,rltgrb,wlon,rnlat,inttyp, + & gdata,len,lmask,rslmsk,slmask + &, outlat, outlon, me) +! + deallocate (rlngrb, stat=iret) + deallocate (rltgrb, stat=iret) + deallocate (data, stat=iret) + deallocate (rslmsk, stat=iret) + call baclose(lugb,iret2) +! write(6,*) ' ' + return +! + 100 continue + iret=1 + do i=1,len + gdata(i) = -999. + enddo +! + call baclose(lugb,iret2) +! + return + end subroutine fixrda + subroutine snodpth2(glacir,snwmax,snoanl, len, me) + use machine , only : kind_io8,kind_io4 + implicit none + integer i,me,len + real (kind=kind_io8) snwmax +! + real (kind=kind_io8) snoanl(len), glacir(len) +! + if (me .eq. 0) write(6,*) 'snodpth2' +! + do i=1,len +! +! if glacial points has snow in climatology, set sno to snomax +! + if(glacir(i).ne.0..and.snoanl(i).lt.snwmax*0.5) then + snoanl(i) = snwmax + snoanl(i) + endif +! + enddo + return + end diff --git a/gsmphys/sflx.f b/gsmphys/sflx.f new file mode 100644 index 00000000..bb816e9b --- /dev/null +++ b/gsmphys/sflx.f @@ -0,0 +1,5571 @@ +!----------------------------------- + subroutine sflx & +!................................... +! --- inputs: + & ( nsoil, couple, icein, ffrozp, dt, zlvl, sldpth, & + & swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, & + & sfcspd, prcp, q2, q2sat, dqsdt2, th2, ivegsrc, & + & vegtyp, soiltyp, slopetyp, shdmin, alb, snoalb, & + & bexpp, xlaip, & ! sfc-perts, mgehne + & lheatstrg, & +! --- input/outputs: + & tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm,z0, & +! --- outputs: + & nroot, shdfac, snowh, albedo, eta, sheat, ec, & + & edir, et, ett, esnow, drip, dew, beta, etp, ssoil, & + & flx1, flx2, flx3, runoff1, runoff2, runoff3, & + & snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, & + & rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax) + +! ===================================================================== ! +! description: ! +! ! +! subroutine sflx - version 2.7: ! +! sub-driver for "noah/osu lsm" family of physics subroutines for a ! +! soil/veg/snowpack land-surface model to update soil moisture, soil ! +! ice, soil temperature, skin temperature, snowpack water content, ! +! snowdepth, and all terms of the surface energy balance and surface ! +! water balance (excluding input atmospheric forcings of downward ! +! radiation and precip) ! +! ! +! usage: ! +! ! +! call sflx ! +! --- inputs: ! +! ( nsoil, couple, icein, ffrozp, dt, zlvl, sldpth, ! +! swdn, swnet, lwdn, sfcems, sfcprs, sfctmp, ! +! sfcspd, prcp, q2, q2sat, dqsdt2, th2,ivegsrc, ! +! vegtyp, soiltyp, slopetyp, shdmin, alb, snoalb, ! +! --- input/outputs: ! +! tbot, cmc, t1, stc, smc, sh2o, sneqv, ch, cm, ! +! --- outputs: ! +! nroot, shdfac, snowh, albedo, eta, sheat, ec, ! +! edir, et, ett, esnow, drip, dew, beta, etp, ssoil, ! +! flx1, flx2, flx3, runoff1, runoff2, runoff3, ! +! snomlt, sncovr, rc, pc, rsmin, xlai, rcs, rct, rcq, ! +! rcsoil, soilw, soilm, smcwlt, smcdry, smcref, smcmax ) ! +! ! +! ! +! subprograms called: redprm, snow_new, csnow, snfrac, alcalc, ! +! tdfcnd, snowz0, sfcdif, penman, canres, nopac, snopac. ! +! ! +! ! +! program history log: ! +! jun 2003 -- k. mitchell et. al -- created version 2.7 ! +! 200x -- sarah lu modified the code including: ! +! added passing argument, couple; replaced soldn ! +! and solnet by radflx; call sfcdif if couple=0; ! +! apply time filter to stc and tskin; and the ! +! way of namelist inport. ! +! feb 2004 -- m. ek noah v2.7.1 non-linear weighting of snow vs ! +! non-snow covered portions of gridbox ! +! apr 2009 -- y.-t. hou added lw surface emissivity effect, ! +! streamlined and reformatted the code, and ! +! consolidated constents/parameters by using ! +! module physcons, and added program documentation! ! +! sep 2009 -- s. moorthi minor fixes ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers (>=2 but <=nsold) 1 ! +! couple - integer, =0:uncoupled (land model only) 1 ! +! =1:coupled with parent atmos model ! +! icein - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! ffrozp - real, fractional snow/rain 1 ! +! dt - real, time step (<3600 sec) 1 ! +! zlvl - real, height abv atmos ground forcing vars (m) 1 ! +! sldpth - real, thickness of each soil layer (m) nsoil ! +! swdn - real, downward sw radiation flux (w/m**2) 1 ! +! swnet - real, downward sw net (dn-up) flux (w/m**2) 1 ! +! lwdn - real, downward lw radiation flux (w/m**2) 1 ! +! sfcems - real, sfc lw emissivity (fractional) 1 ! +! sfcprs - real, pressure at height zlvl abv ground(pascals) 1 ! +! sfctmp - real, air temp at height zlvl abv ground (k) 1 ! +! sfcspd - real, wind speed at height zlvl abv ground (m/s) 1 ! +! prcp - real, precip rate (kg m-2 s-1) 1 ! +! q2 - real, mixing ratio at hght zlvl abv grnd (kg/kg) 1 ! +! q2sat - real, sat mixing ratio at zlvl abv grnd (kg/kg) 1 ! +! dqsdt2 - real, slope of sat specific humidity curve at 1 ! +! t=sfctmp (kg kg-1 k-1) ! +! th2 - real, air potential temp at zlvl abv grnd (k) 1 ! +! ivegsrc - integer, sfc veg type data source umd or igbp ! +! vegtyp - integer, vegetation type (integer index) 1 ! +! soiltyp - integer, soil type (integer index) 1 ! +! slopetyp - integer, class of sfc slope (integer index) 1 ! +! shdmin - real, min areal coverage of green veg (fraction) 1 ! +! alb - real, bkground snow-free sfc albedo (fraction) 1 ! +! snoalb - real, max albedo over deep snow (fraction) 1 ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! +! input/outputs: ! +! tbot - real, bottom soil temp (k) 1 ! +! (local yearly-mean sfc air temp) ! +! cmc - real, canopy moisture content (m) 1 ! +! t1 - real, ground/canopy/snowpack eff skin temp (k) 1 ! +! stc - real, soil temp (k) nsoil ! +! smc - real, total soil moisture (vol fraction) nsoil ! +! sh2o - real, unfrozen soil moisture (vol fraction) nsoil ! +! note: frozen part = smc-sh2o ! +! sneqv - real, water-equivalent snow depth (m) 1 ! +! note: snow density = snwqv/snowh ! +! ch - real, sfc exchange coeff for heat & moisture (m/s)1 ! +! note: conductance since it's been mult by wind ! +! cm - real, sfc exchange coeff for momentum (m/s) 1 ! +! note: conductance since it's been mult by wind ! +! ! +! outputs: ! +! nroot - integer, number of root layers 1 ! +! shdfac - real, aeral coverage of green veg (fraction) 1 ! +! snowh - real, snow depth (m) 1 ! +! albedo - real, sfc albedo incl snow effect (fraction) 1 ! +! eta - real, downward latent heat flux (w/m2) 1 ! +! sheat - real, downward sensible heat flux (w/m2) 1 ! +! ec - real, canopy water evaporation (w/m2) 1 ! +! edir - real, direct soil evaporation (w/m2) 1 ! +! et - real, plant transpiration (w/m2) nsoil ! +! ett - real, total plant transpiration (w/m2) 1 ! +! esnow - real, sublimation from snowpack (w/m2) 1 ! +! drip - real, through-fall of precip and/or dew in excess 1 ! +! of canopy water-holding capacity (m) ! +! dew - real, dewfall (or frostfall for t<273.15) (m) 1 ! +! beta - real, ratio of actual/potential evap 1 ! +! etp - real, potential evaporation (w/m2) 1 ! +! ssoil - real, upward soil heat flux (w/m2) 1 ! +! flx1 - real, precip-snow sfc flux (w/m2) 1 ! +! flx2 - real, freezing rain latent heat flux (w/m2) 1 ! +! flx3 - real, phase-change heat flux from snowmelt (w/m2) 1 ! +! snomlt - real, snow melt (m) (water equivalent) 1 ! +! sncovr - real, fractional snow cover 1 ! +! runoff1 - real, surface runoff (m/s) not infiltrating sfc 1 ! +! runoff2 - real, sub sfc runoff (m/s) (baseflow) 1 ! +! runoff3 - real, excess of porosity for a given soil layer 1 ! +! rc - real, canopy resistance (s/m) 1 ! +! pc - real, plant coeff (fraction) where pc*etp=transpi 1 ! +! rsmin - real, minimum canopy resistance (s/m) 1 ! +! xlai - real, leaf area index (dimensionless) 1 ! +! rcs - real, incoming solar rc factor (dimensionless) 1 ! +! rct - real, air temp rc factor (dimensionless) 1 ! +! rcq - real, atoms vapor press deficit rc factor 1 ! +! rcsoil - real, soil moisture rc factor (dimensionless) 1 ! +! soilw - real, available soil mois in root zone 1 ! +! soilm - real, total soil column mois (frozen+unfrozen) (m)1 ! +! smcwlt - real, wilting point (volumetric) 1 ! +! smcdry - real, dry soil mois threshold (volumetric) 1 ! +! smcref - real, soil mois threshold (volumetric) 1 ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! ! +! ==================== end of description ===================== ! +! + use machine , only : kind_phys +! + use physcons, only : con_cp, con_rd, con_t0c, con_g, con_pi, & + & con_cliq, con_csol, con_hvap, con_hfus, & + & con_sbc +! + implicit none + +! --- constant parameters: +! *** note: some of the constants are different in subprograms and need to +! be consolidated with the standard def in module physcons at sometime +! at the present time, those diverse values are kept temperately to +! provide the same result as the original codes. -- y.t.h. may09 + + integer, parameter :: nsold = 4 ! max soil layers + +! real (kind=kind_phys), parameter :: gs = con_g ! con_g =9.80665 + real (kind=kind_phys), parameter :: gs1 = 9.8 ! con_g in sfcdif + real (kind=kind_phys), parameter :: gs2 = 9.81 ! con_g in snowpack, frh2o + real (kind=kind_phys), parameter :: tfreez = con_t0c ! con_t0c =273.16 + real (kind=kind_phys), parameter :: lsubc = 2.501e+6 ! con_hvap=2.5000e+6 + real (kind=kind_phys), parameter :: lsubf = 3.335e5 ! con_hfus=3.3358e+5 + real (kind=kind_phys), parameter :: lsubs = 2.83e+6 ! ? in sflx, snopac + real (kind=kind_phys), parameter :: elcp = 2.4888e+3 ! ? in penman +! real (kind=kind_phys), parameter :: rd = con_rd ! con_rd =287.05 + real (kind=kind_phys), parameter :: rd1 = 287.04 ! con_rd in sflx, penman, canres + real (kind=kind_phys), parameter :: cp = con_cp ! con_cp =1004.6 + real (kind=kind_phys), parameter :: cp1 = 1004.5 ! con_cp in sflx, canres + real (kind=kind_phys), parameter :: cp2 = 1004.0 ! con_cp in htr +! real (kind=kind_phys), parameter :: cph2o = con_cliq ! con_cliq=4.1855e+3 + real (kind=kind_phys), parameter :: cph2o1 = 4.218e+3 ! con_cliq in penman, snopac + real (kind=kind_phys), parameter :: cph2o2 = 4.2e6 ! con_cliq in hrt *unit diff! + real (kind=kind_phys), parameter :: cpice = con_csol ! con_csol=2.106e+3 + real (kind=kind_phys), parameter :: cpice1 = 2.106e6 ! con_csol in hrt *unit diff! +! real (kind=kind_phys), parameter :: sigma = con_sbc ! con_sbc=5.6704e-8 + real (kind=kind_phys), parameter :: sigma1 = 5.67e-8 ! con_sbc in penman, nopac, snopac + +! --- inputs: + integer, intent(in) :: nsoil, couple, icein, vegtyp, soiltyp, & + & slopetyp, ivegsrc + + real (kind=kind_phys), intent(in) :: ffrozp, dt, zlvl, lwdn, & + & sldpth(nsoil), swdn, swnet, sfcems, sfcprs, sfctmp, & + & sfcspd, prcp, q2, q2sat, dqsdt2, th2, shdmin, alb, snoalb, & + & bexpp, xlaip & !sfc-perts, mgehne + + logical, intent(in) :: lheatstrg + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: tbot, cmc, t1, sneqv, & + & stc(nsoil), smc(nsoil), sh2o(nsoil), ch, cm + +! --- outputs: + integer, intent(out) :: nroot + + real (kind=kind_phys), intent(out) :: shdfac, snowh, albedo, & + & eta, sheat, ec, edir, et(nsoil), ett, esnow, drip, dew, & + & beta, etp, ssoil, flx1, flx2, flx3, snomlt, sncovr, & + & runoff1, runoff2, runoff3, rc, pc, rsmin, xlai, rcs, & + & rct, rcq, rcsoil, soilw, soilm, smcwlt, smcdry, smcref, & + & smcmax + +! --- locals: +! real (kind=kind_phys) :: df1h, + real (kind=kind_phys) :: bexp, cfactr, cmcmax, csoil, czil, & + & df1, df1a, dksat, dwsat, dsoil, dtot, frcsno, & + & frcsoi, epsca, fdown, f1, fxexp, frzx, hs, kdt, prcp1, & + & psisat, quartz, rch, refkdt, rr, rgl, rsmax, sndens, & + & sncond, sbeta, sn_new, slope, snup, salp, soilwm, soilww, & + & t1v, t24, t2v, th2v, topt, tsnow, zbot, z0 + + real (kind=kind_phys) :: shdfac0 + real (kind=kind_phys), dimension(nsold) :: rtdis, zsoil + + logical :: frzgra, snowng + + integer :: ice, k, kz +! +!===> ... begin here +! +! --- ... initialization + + runoff1 = 0.0 + runoff2 = 0.0 + runoff3 = 0.0 + snomlt = 0.0 + rc = 0.0 + +! --- ... define local variable ice to achieve: +! sea-ice case, ice = 1 +! non-glacial land, ice = 0 +! glacial-ice land, ice = -1 +! if vegtype=15 (glacial-ice), re-set ice flag = -1 (glacial-ice) +! note - for open-sea, sflx should *not* have been called. set green +! vegetation fraction (shdfac) = 0. + + shdfac0 = shdfac + ice = icein + + if(ivegsrc == 2) then + if (vegtyp == 13) then + ice = -1 + shdfac = 0.0 + endif + endif + + if(ivegsrc == 1) then + if (vegtyp == 15) then + ice = -1 + shdfac = 0.0 + endif + endif + + if (ice == 1) then + + shdfac = 0.0 + +! --- ... set green vegetation fraction (shdfac) = 0. +! set sea-ice layers of equal thickness and sum to 3 meters + + do kz = 1, nsoil + zsoil(kz) = -3.0 * float(kz) / float(nsoil) + enddo + + else + +! --- ... calculate depth (negative) below ground from top skin sfc to +! bottom of each soil layer. +! note - sign of zsoil is negative (denoting below ground) + + zsoil(1) = -sldpth(1) + do kz = 2, nsoil + zsoil(kz) = -sldpth(kz) + zsoil(kz-1) + end do + + endif ! end if_ice_block + +! --- ... next is crucial call to set the land-surface parameters, +! including soil-type and veg-type dependent parameters. +! set shdfac=0.0 for bare soil surfaces + + call redprm + if(ivegsrc == 1) then +!only igbp type has urban +!urban + if(vegtyp == 13)then +! shdfac=0.05 +! rsmin=400.0 +! smcmax = 0.45 +! smcref = 0.42 +! smcwlt = 0.40 +! smcdry = 0.40 + rsmin=400.0*(1-shdfac0)+40.0*shdfac0 ! gvf + shdfac=shdfac0 ! gvf + smcmax = 0.45*(1-shdfac0)+smcmax*shdfac0 + smcref = 0.42*(1-shdfac0)+smcref*shdfac0 + smcwlt = 0.40*(1-shdfac0)+smcwlt*shdfac0 + smcdry = 0.40*(1-shdfac0)+smcdry*shdfac0 + endif + endif + +! --- inputs: ! +! ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, ! +! --- outputs: ! +! cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, ! +! sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, ! +! snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, ! +! smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, ! +! z0, czil, xlai, csoil ) ! + + +! --- ... bexp sfc-perts, mgehne + if( bexpp < 0.) then + bexp = bexp * max(1.+bexpp, 0.) + endif + if( bexpp >= 0.) then + bexp = bexp * min(1.+bexpp, 2.) + endif +! --- ... lai sfc-perts, mgehne + xlai = xlai * (1.+xlaip) + xlai = max(xlai, .75) + +! --- ... initialize precipitation logicals. + + snowng = .false. + frzgra = .false. + +! --- ... over sea-ice or glacial-ice, if s.w.e. (sneqv) below threshold +! lower bound (0.01 m for sea-ice, 0.10 m for glacial-ice), then +! set at lower bound and store the source increment in subsurface +! runoff/baseflow (runoff2). +! note - runoff2 is then a negative value (as a flag) over sea-ice or +! glacial-ice, in order to achieve water balance. + + if (ice == 1) then + + if (sneqv < 0.01) then + sneqv = 0.01 + snowh = 0.10 +! snowh = sneqv / sndens + endif + + elseif (ice == -1) then + + if (sneqv < 0.10) then +! sndens = sneqv / snowh +! runoff2 = -(0.10 - sneqv) / dt + sneqv = 0.10 + snowh = 1.00 +! snowh = sneqv / sndens + endif + + endif ! end if_ice_block + +! --- ... for sea-ice and glacial-ice cases, set smc and sh2o values = 1 +! as a flag for non-soil medium + + if (ice /= 0) then + do kz = 1, nsoil + smc (kz) = 1.0 + sh2o(kz) = 1.0 + enddo + endif + +! --- ... if input snowpack is nonzero, then compute snow density "sndens" +! and snow thermal conductivity "sncond" (note that csnow is a +! function subroutine) + + if (sneqv .eq. 0.0) then + sndens = 0.0 + snowh = 0.0 + sncond = 1.0 + else + sndens = sneqv / snowh + sndens = max( 0.0, min( 1.0, sndens )) ! added by moorthi + + call csnow +! --- inputs: ! +! ( sndens, ! +! --- outputs: ! +! sncond ) ! + + endif + +! --- ... determine if it's precipitating and what kind of precip it is. +! if it's prcping and the air temp is colder than 0 c, it's snowing! +! if it's prcping and the air temp is warmer than 0 c, but the grnd +! temp is colder than 0 c, freezing rain is presumed to be falling. + + if (prcp > 0.0) then + if (ffrozp > 0.) then + snowng = .true. + else + if (t1 <= tfreez) frzgra = .true. + endif + endif + +! --- ... if either prcp flag is set, determine new snowfall (converting +! prcp rate from kg m-2 s-1 to a liquid equiv snow depth in meters) +! and add it to the existing snowpack. +! note - that since all precip is added to snowpack, no precip infiltrates +! into the soil so that prcp1 is set to zero. + + if (snowng .or. frzgra) then + +! snowfall + if (snowng) then + sn_new = ffrozp*prcp * dt * 0.001 + sneqv = sneqv + sn_new + prcp1 = (1.-ffrozp)*prcp + endif +! freezing rain + if (frzgra) then + sn_new = prcp * dt * 0.001 + sneqv = sneqv + sn_new + prcp1 = 0.0 + endif + +! --- ... update snow density based on new snowfall, using old and new +! snow. update snow thermal conductivity + + call snow_new +! --- inputs: ! +! ( sfctmp, sn_new, ! +! --- input/outputs: ! +! snowh, sndens ) ! + + call csnow +! --- inputs: ! +! ( sndens, ! +! --- outputs: ! +! sncond ) ! + + else + +! --- ... precip is liquid (rain), hence save in the precip variable +! that later can wholely or partially infiltrate the soil (along +! with any canopy "drip" added to this later) + + prcp1 = prcp + + endif ! end if_snowng_block + +! --- ... determine snowcover fraction and albedo fraction over land. + + if (ice /= 0) then + +! --- ... snow cover, albedo over sea-ice, glacial-ice + + sncovr = 1.0 + albedo = 0.65 + + else + +! --- ... non-glacial land +! if snow depth=0, set snowcover fraction=0, albedo=snow free albedo. + + if (sneqv == 0.0) then + + sncovr = 0.0 + albedo = alb + + else + +! --- ... determine snow fraction cover. +! determine surface albedo modification due to snowdepth state. + + call snfrac +! --- inputs: ! +! ( sneqv, snup, salp, snowh, ! +! --- outputs: ! +! sncovr ) ! + + call alcalc +! --- inputs: ! +! ( alb, snoalb, shdfac, shdmin, sncovr, tsnow, ! +! --- outputs: ! +! albedo ) ! + + endif ! end if_sneqv_block + + endif ! end if_ice_block + +! --- ... thermal conductivity for sea-ice case, glacial-ice case + + if (ice /= 0) then + + df1 = 2.2 + + else + +! --- ... next calculate the subsurface heat flux, which first requires +! calculation of the thermal diffusivity. treatment of the +! latter follows that on pages 148-149 from "heat transfer in +! cold climates", by v. j. lunardini (published in 1981 +! by van nostrand reinhold co.) i.e. treatment of two contiguous +! "plane parallel" mediums (namely here the first soil layer +! and the snowpack layer, if any). this diffusivity treatment +! behaves well for both zero and nonzero snowpack, including the +! limit of very thin snowpack. this treatment also eliminates +! the need to impose an arbitrary upper bound on subsurface +! heat flux when the snowpack becomes extremely thin. + +! --- ... first calculate thermal diffusivity of top soil layer, using +! both the frozen and liquid soil moisture, following the +! soil thermal diffusivity function of peters-lidard et al. +! (1998,jas, vol 55, 1209-1224), which requires the specifying +! the quartz content of the given soil class (see routine redprm) + + call tdfcnd & +! --- inputs: + & ( smc(1), quartz, smcmax, sh2o(1), & +! --- outputs: + & df1 & + & ) +! if(ivegsrc == 1) then +!only igbp type has urban +!urban +! if ( vegtyp == 13 ) df1=3.24 +! endif + +! --- ... next add subsurface heat flux reduction effect from the +! overlying green canopy, adapted from section 2.1.2 of +! peters-lidard et al. (1997, jgr, vol 102(d4)) +!wz only urban for igbp type +! +!jhan urban canopy heat storage effect is included in pbl scheme +! + if((.not.lheatstrg) .and. + & (ivegsrc == 1 .and. vegtyp == 13)) then + df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) + else + df1 = df1 * exp( sbeta*shdfac ) + endif + + endif ! end if_ice_block + +! --- ... finally "plane parallel" snowpack effect following +! v.j. linardini reference cited above. note that dtot is +! combined depth of snowdepth and thickness of first soil layer + + dsoil = -0.5 * zsoil(1) + + if (sneqv == 0.0) then + + ssoil = df1 * (t1 - stc(1)) / dsoil + + else + + dtot = snowh + dsoil + frcsno = snowh / dtot + frcsoi = dsoil / dtot + +! --- ... 1. harmonic mean (series flow) + +! df1 = (sncond*df1) / (frcsoi*sncond + frcsno*df1) +! df1h = (sncond*df1) / (frcsoi*sncond + frcsno*df1) + +! --- ... 2. arithmetic mean (parallel flow) + +! df1 = frcsno*sncond + frcsoi*df1 + df1a = frcsno*sncond + frcsoi*df1 + +! --- ... 3. geometric mean (intermediate between harmonic and arithmetic mean) + +! df1 = (sncond**frcsno) * (df1**frcsoi) +! df1 = df1h*sncovr + df1a*(1.0-sncovr) +! df1 = df1h*sncovr + df1 *(1.0-sncovr) + df1 = df1a*sncovr + df1 *(1.0-sncovr) + +! --- ... calculate subsurface heat flux, ssoil, from final thermal +! diffusivity of surface mediums, df1 above, and skin +! temperature and top mid-layer soil temperature + + ssoil = df1 * (t1 - stc(1)) / dtot + + endif ! end if_sneqv_block + +! --- ... determine surface roughness over snowpack using snow condition +! from the previous timestep. + +! if (couple == 0) then ! uncoupled mode + if (sncovr > 0.0) then + + call snowz0 +! --- inputs: ! +! ( sncovr, ! +! --- input/outputs: ! +! z0 ) ! + + endif +! endif + +! --- ... calc virtual temps and virtual potential temps needed by +! subroutines sfcdif and penman. + + t2v = sfctmp * (1.0 + 0.61*q2) + +! --- ... next call routine sfcdif to calculate the sfc exchange coef (ch) +! for heat and moisture. +! note - comment out call sfcdif, if sfcdif already called in calling +! program (such as in coupled atmospheric model). +! - do not call sfcdif until after above call to redprm, in case +! alternative values of roughness length (z0) and zilintinkevich +! coef (czil) are set there via namelist i/o. +! - routine sfcdif returns a ch that represents the wind spd times +! the "original" nondimensional "ch" typical in literature. hence +! the ch returned from sfcdif has units of m/s. the important +! companion coefficient of ch, carried here as "rch", is the ch +! from sfcdif times air density and parameter "cp". "rch" is +! computed in "call penman". rch rather than ch is the coeff +! usually invoked later in eqns. +! - sfcdif also returns the surface exchange coefficient for momentum, +! cm, also known as the surface drage coefficient, but cm is not +! used here. + +! --- ... key required radiation term is the total downward radiation +! (fdown) = net solar (swnet) + downward longwave (lwdn), +! for use in penman ep calculation (penman) and other surface +! energy budget calcuations. also need downward solar (swdn) +! for canopy resistance routine (canres). +! note - fdown, swdn are derived differently in the uncoupled and +! coupled modes. + + if (couple == 0) then !......uncoupled mode + +! --- ... uncoupled mode: +! compute surface exchange coefficients + + t1v = t1 * (1.0 + 0.61 * q2) + th2v = th2 * (1.0 + 0.61 * q2) + + call sfcdif +! --- inputs: ! +! ( zlvl, z0, t1v, th2v, sfcspd, czil, ! +! --- input/outputs: ! +! cm, ch ) ! + +! swnet = net solar radiation into the ground (w/m2; dn-up) from input +! fdown = net solar + downward lw flux at sfc (w/m2) + + fdown = swnet + lwdn + + else !......coupled mode + +! --- ... coupled mode (couple .ne. 0): +! surface exchange coefficients computed externally and passed in, +! hence subroutine sfcdif not called. + +! swnet = net solar radiation into the ground (w/m2; dn-up) from input +! fdown = net solar + downward lw flux at sfc (w/m2) + + fdown = swnet + lwdn + + endif ! end if_couple_block + +! --- ... call penman subroutine to calculate potential evaporation (etp), +! and other partial products and sums save in common/rite for later +! calculations. + + call penman +! --- inputs: ! +! ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, ! +! ssoil, q2, q2sat, dqsdt2, snowng, frzgra, ! +! --- outputs: ! +! t24, etp, rch, epsca, rr, flx2 ) ! + +! --- ... call canres to calculate the canopy resistance and convert it +! into pc if nonzero greenness fraction + + if (shdfac > 0.) then + +! --- ... frozen ground extension: total soil water "smc" was replaced +! by unfrozen soil water "sh2o" in call to canres below + + call canres +! --- inputs: ! +! ( nsoil, nroot, swdn, ch, q2, q2sat, dqsdt2, sfctmp, ! +! sfcprs, sfcems, sh2o, smcwlt, smcref, zsoil, rsmin, ! +! rsmax, topt, rgl, hs, xlai, ! +! --- outputs: ! +! rc, pc, rcs, rct, rcq, rcsoil ) ! + + endif + +! --- ... now decide major pathway branch to take depending on whether +! snowpack exists or not: + + esnow = 0.0 + + if (sneqv .eq. 0.0) then + + call nopac +! --- inputs: ! +! ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, ! +! smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, ! +! t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, ! +! slope, kdt, frzx, psisat, zsoil, dksat, dwsat, ! +! zbot, ice, rtdis, quartz, fxexp, csoil, lheatstrg, ! +! --- input/outputs: ! +! cmc, t1, stc, sh2o, tbot, ! +! --- outputs: ! +! eta, smc, ssoil, runoff1, runoff2, runoff3, edir, ! +! ec, et, ett, beta, drip, dew, flx1, flx3 ) ! + + else + + call snopac +! --- inputs: ! +! ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, ! +! cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, ! +! bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, ! +! zsoil, dwsat, dksat, zbot, shdfac, ice, rtdis, quartz, ! +! fxexp, csoil, flx2, snowng, lheatstrg, ! +! --- input/outputs: ! +! prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, ! +! sh2o, tbot, beta, ! +! --- outputs: ! +! smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, ! +! ett, snomlt, drip, dew, flx1, flx3, esnow ) ! + + endif + +! --- ... prepare sensible heat (h) for return to parent model + + sheat = -(ch*cp1*sfcprs) / (rd1*t2v) * (th2 - t1) + +! --- ... convert units and/or sign of total evap (eta), potential evap (etp), +! subsurface heat flux (s), and runoffs for what parent model expects +! convert eta from kg m-2 s-1 to w m-2 +! eta = eta * lsubc +! etp = etp * lsubc + + edir = edir * lsubc + ec = ec * lsubc + + do k = 1, 4 + et(k) = et(k) * lsubc + enddo + + ett = ett * lsubc + esnow = esnow * lsubs + etp = etp * ((1.0 - sncovr)*lsubc + sncovr*lsubs) + + if (etp > 0.) then + eta = edir + ec + ett + esnow + else + eta = etp + endif + + beta = eta / etp + +! --- ... convert the sign of soil heat flux so that: +! ssoil>0: warm the surface (night time) +! ssoil<0: cool the surface (day time) + + ssoil = -1.0 * ssoil + + if (ice == 0) then + +! --- ... for the case of land (but not glacial-ice): +! convert runoff3 (internal layer runoff from supersat) from m +! to m s-1 and add to subsurface runoff/baseflow (runoff2). +! runoff2 is already a rate at this point. + + runoff3 = runoff3 / dt + runoff2 = runoff2 + runoff3 + + else + +! --- ... for the case of sea-ice (ice=1) or glacial-ice (ice=-1), add any +! snowmelt directly to surface runoff (runoff1) since there is no +! soil medium, and thus no call to subroutine smflx (for soil +! moisture tendency). + + runoff1 = snomlt / dt + endif + +! --- ... total column soil moisture in meters (soilm) and root-zone +! soil moisture availability (fraction) relative to porosity/saturation + + soilm = -1.0 * smc(1) * zsoil(1) + do k = 2, nsoil + soilm = soilm + smc(k)*(zsoil(k-1) - zsoil(k)) + enddo + + soilwm = -1.0 * (smcmax - smcwlt) * zsoil(1) + soilww = -1.0 * (smc(1) - smcwlt) * zsoil(1) + do k = 2, nroot + soilwm = soilwm + (smcmax - smcwlt) * (zsoil(k-1) - zsoil(k)) + soilww = soilww + (smc(k) - smcwlt) * (zsoil(k-1) - zsoil(k)) + enddo + + soilw = soilww / soilwm +! + return + + +! ================= + contains +! ================= + +!*************************************! +! section-1 1st level subprograms ! +!*************************************! + +!----------------------------------- + subroutine alcalc +!................................... +! --- inputs: +! & ( alb, snoalb, shdfac, shdmin, sncovr, tsnow, & +! --- outputs: +! & albedo & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine alcalc calculates albedo including snow effect (0 -> 1) ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! alb - real, snowfree albedo 1 ! +! snoalb - real, maximum (deep) snow albedo 1 ! +! shdfac - real, areal fractional coverage of green veg. 1 ! +! shdmin - real, minimum areal coverage of green veg. 1 ! +! sncovr - real, fractional snow cover 1 ! +! tsnow - real, snow surface temperature (k) 1 ! +! ! +! outputs to calling program: ! +! albedo - real, surface albedo including snow effect 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real (kind=kind_phys), intent(in) :: alb, snoalb, shdfac, & +! & shdmin, sncovr, tsnow + +! --- outputs: +! real (kind=kind_phys), intent(out) :: albedo + +! --- locals: (none) + +! +!===> ... begin here +! +! --- ... snoalb is argument representing maximum albedo over deep snow, +! as passed into sflx, and adapted from the satellite-based +! maximum snow albedo fields provided by d. robinson and g. kukla +! (1985, jcam, vol 24, 402-411) + +! albedo = alb + (1.0-(shdfac-shdmin))*sncovr*(snoalb-alb) + albedo = alb + sncovr*(snoalb - alb) + + if (albedo > snoalb) albedo = snoalb + +! --- ... base formulation (dickinson et al., 1986, cogley et al., 1990) + +! if (tsnow <= 263.16) then +! albedo = snoalb +! else +! if (tsnow < 273.16) then +! tm = 0.1 * (tsnow - 263.16) +! albedo = 0.5 * ((0.9 - 0.2*(tm**3)) + (0.8 - 0.16*(tm**3))) +! else +! albedo = 0.67 +! endif +! endif + +! --- ... isba formulation (verseghy, 1991; baker et al., 1990) + +! if (tsnow < 273.16) then +! albedo = snoalb - 0.008*dt/86400 +! else +! albedo = (snoalb - 0.5) * exp( -0.24*dt/86400 ) + 0.5 +! endif + +! + return +!................................... + end subroutine alcalc +!----------------------------------- + + +!----------------------------------- + subroutine canres +!................................... +! --- inputs: +! & ( nsoil, nroot, swdn, ch, q2, q2sat, dqsdt2, sfctmp, & +! & sfcprs, sfcems, sh2o, smcwlt, smcref, zsoil, rsmin, & +! & rsmax, topt, rgl, hs, xlai, & +! --- outputs: +! & rc, pc, rcs, rct, rcq, rcsoil & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine canres calculates canopy resistance which depends on ! +! incoming solar radiation, air temperature, atmospheric water vapor ! +! pressure deficit at the lowest model level, and soil moisture ! +! (preferably unfrozen soil moisture rather than total) ! +! ! +! source: jarvis (1976), noilhan and planton (1989, mwr), jacquemin ! +! and noilhan (1990, blm) ! +! see also: chen et al (1996, jgr, vol 101(d3), 7251-7268), eqns ! +! 12-14 and table 2 of sec. 3.1.2 ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, no. of soil layers 1 ! +! nroot - integer, no. of soil layers in root zone ( ... begin here +! +! --- ... initialize canopy resistance multiplier terms. + + rcs = 0.0 + rct = 0.0 + rcq = 0.0 + rcsoil = 0.0 + rc = 0.0 + +! --- ... contribution due to incoming solar radiation + + ff = 0.55 * 2.0 * swdn / (rgl*xlai) + rcs = (ff + rsmin/rsmax) / (1.0 + ff) + rcs = max( rcs, 0.0001 ) + +! --- ... contribution due to air temperature at first model level above ground +! rct expression from noilhan and planton (1989, mwr). + + rct = 1.0 - 0.0016 * (topt - sfctmp)**2.0 + rct = max( rct, 0.0001 ) + +! --- ... contribution due to vapor pressure deficit at first model level. +! rcq expression from ssib + + rcq = 1.0 / (1.0 + hs*(q2sat-q2)) + rcq = max( rcq, 0.01 ) + +! --- ... contribution due to soil moisture availability. +! determine contribution from each soil layer, then add them up. + + gx = (sh2o(1) - smcwlt) / (smcref - smcwlt) + gx = max( 0.0, min( 1.0, gx ) ) + +! --- ... use soil depth as weighting factor + part(1) = (zsoil(1)/zsoil(nroot)) * gx + +! --- ... use root distribution as weighting factor +! part(1) = rtdis(1) * gx + + do k = 2, nroot + + gx = (sh2o(k) - smcwlt) / (smcref - smcwlt) + gx = max( 0.0, min( 1.0, gx ) ) + +! --- ... use soil depth as weighting factor + part(k) = ((zsoil(k) - zsoil(k-1)) / zsoil(nroot)) * gx + +! --- ... use root distribution as weighting factor +! part(k) = rtdis(k) * gx + + enddo + + do k = 1, nroot + rcsoil = rcsoil + part(k) + enddo + rcsoil = max( rcsoil, 0.0001 ) + +! --- ... determine canopy resistance due to all factors. convert canopy +! resistance (rc) to plant coefficient (pc) to be used with +! potential evap in determining actual evap. pc is determined by: +! pc * linerized penman potential evap = penman-monteith actual +! evaporation (containing rc term). + + rc = rsmin / (xlai*rcs*rct*rcq*rcsoil) + rr = (4.0*sfcems*sigma1*rd1/cp1) * (sfctmp**4.0)/(sfcprs*ch) + 1.0 + delta = (lsubc/cp1) * dqsdt2 + + pc = (rr + delta) / (rr*(1.0 + rc*ch) + delta) +! + return +!................................... + end subroutine canres +!----------------------------------- + + +!----------------------------------- + subroutine csnow +!................................... +! --- inputs: +! & ( sndens, & +! --- outputs: +! & sncond & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine csnow calculates snow termal conductivity ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sndens - real, snow density 1 ! +! ! +! outputs to the calling program: ! +! sncond - real, snow termal conductivity 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + real (kind=kind_phys), parameter :: unit = 0.11631 + +! --- inputs: +! real (kind=kind_phys), intent(in) :: sndens + +! --- outputs: +! real (kind=kind_phys), intent(out) :: sncond + +! --- locals: + real (kind=kind_phys) :: c + +! +!===> ... begin here +! +! --- ... sncond in units of cal/(cm*hr*c), returned in w/(m*c) +! basic version is dyachkova equation (1960), for range 0.1-0.4 + + c = 0.328 * 10**(2.25*sndens) + sncond = unit * c + +! --- ... de vaux equation (1933), in range 0.1-0.6 + +! sncond = 0.0293 * (1.0 + 100.0*sndens**2) + +! --- ... e. andersen from flerchinger + +! sncond = 0.021 + 2.51 * sndens**2 +! + return +!................................... + end subroutine csnow +!----------------------------------- + + +!----------------------------------- + subroutine nopac +!................................... +! --- inputs: +! & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, & +! & smcdry, cmcmax, dt, shdfac, sbeta, sfctmp, sfcems, & +! & t24, th2, fdown, epsca, bexp, pc, rch, rr, cfactr, & +! & slope, kdt, frzx, psisat, zsoil, dksat, dwsat, & +! & zbot, ice, rtdis, quartz, fxexp, csoil, lheatstrg, & +! --- input/outputs: +! & cmc, t1, stc, sh2o, tbot, & +! --- outputs: +! & eta, smc, ssoil, runoff1, runoff2, runoff3, edir, & +! & ec, et, ett, beta, drip, dew, flx1, flx3 & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine nopac calculates soil moisture and heat flux values and ! +! update soil moisture content and soil heat content values for the ! +! case when no snow pack is present. ! +! ! +! ! +! subprograms called: evapo, smflx, tdfcnd, shflx ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! etp - real, potential evaporation 1 ! +! prcp - real, precip rate 1 ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! dt - real, time step 1 ! +! shdfac - real, aeral coverage of green veg 1 ! +! sbeta - real, param to cal veg effect on soil heat flux 1 ! +! sfctmp - real, air temp at height zlvl abv ground 1 ! +! sfcems - real, sfc lw emissivity 1 ! +! t24 - real, sfctmp**4 1 ! +! th2 - real, air potential temp at zlvl abv grnd 1 ! +! fdown - real, net solar + downward lw flux at sfc 1 ! +! epsca - real, 1 ! +! bexp - real, soil type "b" parameter 1 ! +! pc - real, plant coeff 1 ! +! rch - real, companion coefficient of ch 1 ! +! rr - real, 1 ! +! cfactr - real, canopy water parameters 1 ! +! slope - real, linear reservoir coefficient 1 ! +! kdt - real, 1 ! +! frzx - real, frozen ground parameter 1 ! +! psisat - real, saturated soil potential 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! zbot - real, specify depth of lower bd soil 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! rtdis - real, root distribution nsoil ! +! quartz - real, soil quartz content 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! csoil - real, soil heat capacity 1 ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! +! input/outputs from and to the calling program: ! +! cmc - real, canopy moisture content 1 ! +! t1 - real, ground/canopy/snowpack eff skin temp 1 ! +! stc - real, soil temp nsoil ! +! sh2o - real, unfrozen soil moisture nsoil ! +! tbot - real, bottom soil temp 1 ! +! ! +! outputs to the calling program: ! +! eta - real, downward latent heat flux 1 ! +! smc - real, total soil moisture nsoil ! +! ssoil - real, upward soil heat flux 1 ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff (baseflow) 1 ! +! runoff3 - real, excess of porosity 1 ! +! edir - real, direct soil evaporation 1 ! +! ec - real, canopy water evaporation 1 ! +! et - real, plant transpiration nsoil ! +! ett - real, total plant transpiration 1 ! +! beta - real, ratio of actual/potential evap 1 ! +! drip - real, through-fall of precip and/or dew 1 ! +! dew - real, dewfall (or frostfall) 1 ! +! flx1 - real, precip-snow sfc flux 1 ! +! flx3 - real, phase-change heat flux from snowmelt 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! integer, intent(in) :: nsoil, nroot, ice + +! real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, & +! & smcwlt, smcref, smcdry, cmcmax, dt, shdfac, sbeta, & +! & sfctmp, sfcems, t24, th2, fdown, epsca, bexp, pc, & +! & rch, rr, cfactr, slope, kdt, frzx, psisat, & +! & zsoil(nsoil), dksat, dwsat, zbot, rtdis(nsoil), & +! & quartz, fxexp, csoil +! +! logical, intent(in) :: lheatstrg +! +! --- input/outputs: +! real (kind=kind_phys), intent(inout) :: cmc, t1, stc(nsoil), & +! & sh2o(nsoil), tbot + +! --- outputs: +! real (kind=kind_phys), intent(out) :: eta, smc(nsoil), ssoil, & +! & runoff1, runoff2, runoff3, edir, ec, et(nsoil), ett, & +! & beta, drip, dew, flx1, flx3 + +! --- locals: + real (kind=kind_phys) :: df1, eta1, etp1, prcp1, yy, yynum, & + & zz1, ec1, edir1, et1(nsoil), ett1 + + integer :: k + +! +!===> ... begin here +! +! --- ... convert etp from kg m-2 s-1 to ms-1 and initialize dew. + + prcp1= prcp * 0.001 + etp1 = etp * 0.001 + dew = 0.0 + edir = 0.0 + edir1= 0.0 + ec = 0.0 + ec1 = 0.0 + + do k = 1, nsoil + et (k) = 0.0 + et1(k) = 0.0 + enddo + + ett = 0.0 + ett1 = 0.0 + + if (etp > 0.0) then + +! --- ... convert prcp from 'kg m-2 s-1' to 'm s-1'. + + call evapo & +! --- inputs: + & ( nsoil, nroot, cmc, cmcmax, etp1, dt, zsoil, & + & sh2o, smcmax, smcwlt, smcref, smcdry, pc, & + & shdfac, cfactr, rtdis, fxexp, & +! --- outputs: + & eta1, edir1, ec1, et1, ett1 & + & ) + + call smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + + else + +! --- ... if etp < 0, assume dew forms (transform etp1 into dew and +! reinitialize etp1 to zero). + + eta1 = 0.0 + dew = -etp1 + +! --- ... convert prcp from 'kg m-2 s-1' to 'm s-1' and add dew amount. + + prcp1 = prcp1 + dew + + call smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + + endif ! end if_etp_block + +! --- ... convert modeled evapotranspiration fm m s-1 to kg m-2 s-1 + + eta = eta1 * 1000.0 + edir = edir1 * 1000.0 + ec = ec1 * 1000.0 + + do k = 1, nsoil + et(k) = et1(k) * 1000.0 + enddo + + ett = ett1 * 1000.0 + +! --- ... based on etp and e values, determine beta + + if ( etp <= 0.0 ) then + beta = 0.0 + if ( etp < 0.0 ) then + beta = 1.0 + endif + else + beta = eta / etp + endif + +! --- ... get soil thermal diffuxivity/conductivity for top soil lyr, +! calc. adjusted top lyr soil temp and adjusted soil flux, then +! call shflx to compute/update soil heat flux and soil temps. + + call tdfcnd & +! --- inputs: + & ( smc(1), quartz, smcmax, sh2o(1), & +! --- outputs: + & df1 & + & ) +! if(ivegsrc == 1) then +!urban +! if ( vegtyp == 13 ) df1=3.24 +! endif + +! --- ... vegetation greenness fraction reduction in subsurface heat +! flux via reduction factor, which is convenient to apply here +! to thermal diffusivity that is later used in hrt to compute +! sub sfc heat flux (see additional comments on veg effect +! sub-sfc heat flx in routine sflx) +!wz only urban for igbp type +! +!jhan urban canopy heat storage effect is included in pbl scheme +! + if((.not.lheatstrg) .and. + & (ivegsrc == 1 .and. vegtyp == 13)) then + df1 = 3.24*(1.-shdfac) + shdfac*df1*exp(sbeta*shdfac) + else + df1 = df1 * exp( sbeta*shdfac ) + endif + +! --- ... compute intermediate terms passed to routine hrt (via routine +! shflx below) for use in computing subsurface heat flux in hrt + + yynum = fdown - sfcems*sigma1*t24 + yy = sfctmp + (yynum/rch + th2 - sfctmp - beta*epsca)/rr + zz1 = df1/(-0.5*zsoil(1)*rch*rr) + 1.0 + + call shflx & +! --- inputs: + & ( nsoil, smc, smcmax, dt, yy, zz1, zsoil, zbot, & + & psisat, bexp, df1, ice, quartz, csoil, vegtyp, & + & shdfac, lheatstrg, & +! --- input/outputs: + & stc, t1, tbot, sh2o, & +! --- outputs: + & ssoil & + & ) + +! --- ... set flx1 and flx3 (snopack phase change heat fluxes) to zero since +! they are not used here in snopac. flx2 (freezing rain heat flux) +! was similarly initialized in the penman routine. + + flx1 = 0.0 + flx3 = 0.0 +! + return +!................................... + end subroutine nopac +!----------------------------------- + + +!----------------------------------- + subroutine penman +!................................... +! --- inputs: +! & ( sfctmp, sfcprs, sfcems, ch, t2v, th2, prcp, fdown, & +! & ssoil, q2, q2sat, dqsdt2, snowng, frzgra, & +! --- outputs: +! & t24, etp, rch, epsca, rr, flx2 & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine penman calculates potential evaporation for the current ! +! point. various partial sums/products are also calculated and passed ! +! back to the calling routine for later use. ! +! ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! sfctmp - real, sfc temperature at 1st level above ground 1 ! +! sfcprs - real, sfc pressure 1 ! +! sfcems - real, sfc emissivity for lw radiation 1 ! +! ch - real, sfc exchange coeff for heat & moisture 1 ! +! t2v - real, sfc virtual temperature 1 ! +! th2 - real, air potential temp at zlvl abv grnd 1 ! +! prcp - real, precip rate 1 ! +! fdown - real, net solar + downward lw flux at sfc 1 ! +! ssoil - real, upward soil heat flux 1 ! +! q2 - real, mixing ratio at hght zlvl abv ground 1 ! +! q2sat - real, sat mixing ratio at zlvl abv ground 1 ! +! dqsdt2 - real, slope of sat specific humidity curve 1 ! +! snowng - logical, snow flag 1 ! +! frzgra - logical, freezing rain flag 1 ! +! ! +! outputs: ! +! t24 - real, sfctmp**4 1 ! +! etp - real, potential evaporation 1 ! +! rch - real, companion coefficient of ch 1 ! +! epsca - real, 1 ! +! rr - real, 1 ! +! flx2 - real, freezing rain latent heat flux 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real (kind=kind_phys), intent(in) :: sfctmp, sfcprs, sfcems, & +! & ch, t2v, th2, prcp, fdown, ssoil, q2, q2sat, dqsdt2 + +! logical, intent(in) :: snowng, frzgra + +! --- outputs: +! real (kind=kind_phys), intent(out) :: t24, etp, rch, epsca, & +! & rr, flx2 + +! --- locals: + real (kind=kind_phys) :: a, delta, fnet, rad, rho + +! +!===> ... begin here +! + flx2 = 0.0 + +! --- ... prepare partial quantities for penman equation. + + delta = elcp * dqsdt2 + t24 = sfctmp * sfctmp * sfctmp * sfctmp + rr = t24 * 6.48e-8 / (sfcprs*ch) + 1.0 + rho = sfcprs / (rd1*t2v) + rch = rho * cp * ch + +! --- ... adjust the partial sums / products with the latent heat +! effects caused by falling precipitation. + + if (.not. snowng) then + if (prcp > 0.0) rr = rr + cph2o1*prcp/rch + else +! ---- ... fractional snowfall/rainfall + rr = rr + (cpice*ffrozp+cph2o1*(1.-ffrozp)) & + & *prcp/rch + endif + + fnet = fdown - sfcems*sigma1*t24 - ssoil + +! --- ... include the latent heat effects of frzng rain converting to ice +! on impact in the calculation of flx2 and fnet. + + if (frzgra) then + flx2 = -lsubf * prcp + fnet = fnet - flx2 + endif + +! --- ... finish penman equation calculations. + + rad = fnet/rch + th2 - sfctmp + a = elcp * (q2sat - q2) + epsca = (a*rr + rad*delta) / (delta + rr) + etp = epsca * rch / lsubc +! + return +!................................... + end subroutine penman +!----------------------------------- + + +!----------------------------------- + subroutine redprm +!................................... +! --- inputs: +! & ( nsoil, vegtyp, soiltyp, slopetyp, sldpth, zsoil, & +! --- outputs: +! & cfactr, cmcmax, rsmin, rsmax, topt, refkdt, kdt, & +! & sbeta, shdfac, rgl, hs, zbot, frzx, psisat, slope, & +! & snup, salp, bexp, dksat, dwsat, smcmax, smcwlt, & +! & smcref, smcdry, f1, quartz, fxexp, rtdis, nroot, & +! & z0, czil, xlai, csoil & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine redprm internally sets(default valuess), or optionally ! +! read-in via namelist i/o, all soil and vegetation parameters ! +! required for the execusion of the noah lsm. ! +! ! +! optional non-default parameters can be read in, accommodating up to ! +! 30 soil, veg, or slope classes, if the default max number of soil, ! +! veg, and/or slope types is reset. ! +! ! +! future upgrades of routine redprm must expand to incorporate some ! +! of the empirical parameters of the frozen soil and snowpack physics ! +! (such as in routines frh2o, snowpack, and snow_new) not yet set in ! +! this redprm routine, but rather set in lower level subroutines. ! +! ! +! all soil, veg, slope, and universal parameters values are defined ! +! externally (in subroutine "set_soilveg.f") and then accessed via ! +! "use namelist_soilveg" (below) and then set here. ! +! ! +! soil types zobler (1986) cosby et al (1984) (quartz cont.(1)) ! +! 1 coarse loamy sand (0.82) ! +! 2 medium silty clay loam (0.10) ! +! 3 fine light clay (0.25) ! +! 4 coarse-medium sandy loam (0.60) ! +! 5 coarse-fine sandy clay (0.52) ! +! 6 medium-fine clay loam (0.35) ! +! 7 coarse-med-fine sandy clay loam (0.60) ! +! 8 organic loam (0.40) ! +! 9 glacial land ice loamy sand (na using 0.82)! +! 13: - glacial land ice - ! +! 13: glacial-ice (no longer use these parameters), now ! +! treated as ice-only surface and sub-surface ! +! (in subroutine hrtice) ! +! upgraded to statsgo (19-type) +! 1: sand +! 2: loamy sand +! 3: sandy loam +! 4: silt loam +! 5: silt +! 6:loam +! 7:sandy clay loam +! 8:silty clay loam +! 9:clay loam +! 10:sandy clay +! 11: silty clay +! 12: clay +! 13: organic material +! 14: water +! 15: bedrock +! 16: other (land-ice) +! 17: playa +! 18: lava +! 19: white sand +! ! +! ssib vegetation types (dorman and sellers, 1989; jam) ! +! 1: broadleaf-evergreen trees (tropical forest) ! +! 2: broadleaf-deciduous trees ! +! 3: broadleaf and needleleaf trees (mixed forest) ! +! 4: needleleaf-evergreen trees ! +! 5: needleleaf-deciduous trees (larch) ! +! 6: broadleaf trees with groundcover (savanna) ! +! 7: groundcover only (perennial) ! +! 8: broadleaf shrubs with perennial groundcover ! +! 9: broadleaf shrubs with bare soil ! +! 10: dwarf trees and shrubs with groundcover (tundra) ! +! 11: bare soil ! +! 12: cultivations (the same parameters as for type 7) ! +! 13: - glacial (the same parameters as for type 11) - ! +! 13: glacial-ice (no longer use these parameters), now treated as ! +! ice-only surface and sub-surface (in subroutine hrtice) ! +! upgraded to IGBP (20-type) +! 1:Evergreen Needleleaf Forest +! 2:Evergreen Broadleaf Forest +! 3:Deciduous Needleleaf Forest +! 4:Deciduous Broadleaf Forest +! 5:Mixed Forests +! 6:Closed Shrublands +! 7:Open Shrublands +! 8:Woody Savannas +! 9:Savannas +! 10:Grasslands +! 11:Permanent wetlands +! 12:Croplands +! 13:Urban and Built-Up +! 14:Cropland/natural vegetation mosaic +! 15:Snow and Ice +! 16:Barren or Sparsely Vegetated +! 17:Water +! 18:Wooded Tundra +! 19:Mixed Tundra +! 20:Bare Ground Tundra +! ! +! slopetyp is to estimate linear reservoir coefficient slope to the ! +! baseflow runoff out of the bottom layer. lowest class (slopetyp=0) ! +! means highest slope parameter = 1. ! +! ! +! slope class percent slope ! +! 1 0-8 ! +! 2 8-30 ! +! 3 > 30 ! +! 4 0-30 ! +! 5 0-8 & > 30 ! +! 6 8-30 & > 30 ! +! 7 0-8, 8-30, > 30 ! +! 9 glacial ice ! +! blank ocean/sea ! +! ! +! note: class 9 from zobler file should be replaced by 8 and 'blank' 9 ! +! ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! vegtyp - integer, vegetation type (integer index) 1 ! +! soiltyp - integer, soil type (integer index) 1 ! +! slopetyp - integer, class of sfc slope (integer index) 1 ! +! sldpth - integer, thickness of each soil layer (m) nsoil ! +! zsoil - integer, soil depth (negative sign) (m) nsoil ! +! ! +! outputs to the calling program: ! +! cfactr - real, canopy water parameters 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! rsmin - real, mimimum stomatal resistance 1 ! +! rsmax - real, maximum stomatal resistance 1 ! +! topt - real, optimum transpiration air temperature 1 ! +! refkdt - real, =2.e-6 the sat. dk. val for soil type 2 1 ! +! kdt - real, 1 ! +! sbeta - real, param to cal veg effect on soil heat flux 1 ! +! shdfac - real, vegetation greenness fraction 1 ! +! rgl - real, canopy resistance func (in solar rad term) 1 ! +! hs - real, canopy resistance func (vapor deficit term) 1 ! +! zbot - real, specify depth of lower bd soil temp (m) 1 ! +! frzx - real, frozen ground parameter, ice content 1 ! +! threshold above which frozen soil is impermeable ! +! psisat - real, saturated soil potential 1 ! +! slope - real, linear reservoir coefficient 1 ! +! snup - real, threshold snow depth (water equi m) 1 ! +! salp - real, snow cover shape parameter 1 ! +! from anderson's hydro-17 best fit salp = 2.6 ! +! bexp - real, the 'b' parameter 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! smcmax - real, max soil moisture content (porosity) 1 ! +! smcwlt - real, wilting pt soil moisture contents 1 ! +! smcref - real, reference soil moisture (onset stress) 1 ! +! smcdry - real, air dry soil moist content limits 1 ! +! f1 - real, used to comp soil diffusivity/conductivity 1 ! +! quartz - real, soil quartz content 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! rtdis - real, root distribution nsoil ! +! nroot - integer, number of root layers 1 ! +! z0 - real, roughness length (m) 1 ! +! czil - real, param to cal roughness length of heat 1 ! +! xlai - real, leaf area index 1 ! +! csoil - real, soil heat capacity (j m-3 k-1) 1 ! +! ! +! ==================== end of description ===================== ! +! + use namelist_soilveg + +! --- input: +! integer, intent(in) :: nsoil, vegtyp, soiltyp, slopetyp + +! real (kind=kind_phys), intent(in) :: sldpth(nsoil), zsoil(nsoil) + +! --- outputs: +! real (kind=kind_phys), intent(out) :: cfactr, cmcmax, rsmin, & +! & rsmax, topt, refkdt, kdt, sbeta, shdfac, rgl, hs, zbot, & +! & frzx, psisat, slope, snup, salp, bexp, dksat, dwsat, & +! & smcmax, smcwlt, smcref, smcdry, f1, quartz, fxexp, z0, & +! & czil, xlai, csoil, rtdis(nsoil) + +! integer, intent(out) :: nroot + +! --- locals: + real (kind=kind_phys) :: frzfact, frzk, refdk + + integer :: i + +! +!===> ... begin here +! + if (soiltyp > defined_soil) then + write(*,*) 'warning: too many soil types,soiltyp=',soiltyp, & + & 'defined_soil=',defined_soil + stop 333 + endif + + if (vegtyp > defined_veg) then + write(*,*) 'warning: too many veg types' + stop 333 + endif + + if (slopetyp > defined_slope) then + write(*,*) 'warning: too many slope types' + stop 333 + endif + +! --- ... set-up universal parameters (not dependent on soiltyp, vegtyp +! or slopetyp) + + zbot = zbot_data + salp = salp_data + cfactr = cfactr_data + cmcmax = cmcmax_data + sbeta = sbeta_data + rsmax = rsmax_data + topt = topt_data + refdk = refdk_data + frzk = frzk_data + fxexp = fxexp_data + refkdt = refkdt_data + czil = czil_data + csoil = csoil_data + +! --- ... set-up soil parameters + + bexp = bb (soiltyp) + dksat = satdk(soiltyp) + dwsat = satdw(soiltyp) + f1 = f11 (soiltyp) + kdt = refkdt * dksat / refdk + + psisat = satpsi(soiltyp) + quartz = qtz (soiltyp) + smcdry = drysmc(soiltyp) + smcmax = maxsmc(soiltyp) + smcref = refsmc(soiltyp) + smcwlt = wltsmc(soiltyp) + + frzfact = (smcmax / smcref) * (0.412 / 0.468) + +! --- ... to adjust frzk parameter to actual soil type: frzk * frzfact + + frzx = frzk * frzfact + +! --- ... set-up vegetation parameters + + nroot = nroot_data(vegtyp) + snup = snupx(vegtyp) + rsmin = rsmtbl(vegtyp) + + rgl = rgltbl(vegtyp) + hs = hstbl(vegtyp) +! roughness lengthe is defined in sfcsub +! z0 = z0_data(vegtyp) + xlai= lai_data(vegtyp) + + if (vegtyp == bare) shdfac = 0.0 + + if (nroot > nsoil) then + write(*,*) 'warning: too many root layers' + stop 333 + endif + +! --- ... calculate root distribution. present version assumes uniform +! distribution based on soil layer depths. + + do i = 1, nroot + rtdis(i) = -sldpth(i) / zsoil(nroot) + enddo + +! --- ... set-up slope parameter + + slope = slope_data(slopetyp) +! + return +!................................... + end subroutine redprm +!----------------------------------- + + +!----------------------------------- + subroutine sfcdif +!................................... +! --- inputs: +! & ( zlvl, z0, t1v, th2v, sfcspd, czil, & +! --- input/outputs: +! & cm, ch & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine sfcdif calculates surface layer exchange coefficients ! +! via iterative process. see chen et al (1997, blm) ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! zlvl - real, height abv atmos ground forcing vars (m) 1 ! +! z0 - real, roughness length (m) 1 ! +! t1v - real, surface exchange coefficient 1 ! +! th2v - real, surface exchange coefficient 1 ! +! sfcspd - real, wind speed at height zlvl abv ground (m/s) 1 ! +! czil - real, param to cal roughness length of heat 1 ! +! ! +! input/outputs from and to the calling program: ! +! cm - real, sfc exchange coeff for momentum (m/s) 1 ! +! ch - real, sfc exchange coeff for heat & moisture (m/s)1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + integer, parameter :: itrmx = 5 + real (kind=kind_phys), parameter :: wwst = 1.2 + real (kind=kind_phys), parameter :: wwst2 = wwst*wwst + real (kind=kind_phys), parameter :: vkrm = 0.40 + real (kind=kind_phys), parameter :: excm = 0.001 + real (kind=kind_phys), parameter :: beta = 1.0/270.0 + real (kind=kind_phys), parameter :: btg = beta*gs1 + real (kind=kind_phys), parameter :: elfc = vkrm*btg + real (kind=kind_phys), parameter :: wold = 0.15 + real (kind=kind_phys), parameter :: wnew = 1.0-wold + real (kind=kind_phys), parameter :: pihf = 3.14159265/2.0 ! con_pi/2.0 + + real (kind=kind_phys), parameter :: epsu2 = 1.e-4 + real (kind=kind_phys), parameter :: epsust = 0.07 + real (kind=kind_phys), parameter :: ztmin = -5.0 + real (kind=kind_phys), parameter :: ztmax = 1.0 + real (kind=kind_phys), parameter :: hpbl = 1000.0 + real (kind=kind_phys), parameter :: sqvisc = 258.2 + + real (kind=kind_phys), parameter :: ric = 0.183 + real (kind=kind_phys), parameter :: rric = 1.0/ric + real (kind=kind_phys), parameter :: fhneu = 0.8 + real (kind=kind_phys), parameter :: rfc = 0.191 + real (kind=kind_phys), parameter :: rfac = ric/(fhneu*rfc*rfc) + +! --- inputs: +! real (kind=kind_phys), intent(in) :: zlvl, z0, t1v, th2v, & +! & sfcspd, czil + +! --- input/outputs: +! real (kind=kind_phys), intent(inout) :: cm, ch + +! --- locals: + real (kind=kind_phys) :: zilfc, zu, zt, rdz, cxch, dthv, du2, & + & btgh, wstar2, ustar, zslu, zslt, rlogu, rlogt, rlmo, & + & zetalt, zetalu, zetau, zetat, xlu4, xlt4, xu4, xt4, & + & xlu, xlt, xu, xt, psmz, simm, pshz, simh, ustark, & + & rlmn, rlma + + integer :: ilech, itr + +! --- define local in-line functions: + + real (kind=kind_phys) :: pslmu, pslms, pslhu, pslhs, zz + real (kind=kind_phys) :: pspmu, pspms, psphu, psphs, xx, yy + +! ... 1) lech's surface functions + + pslmu( zz ) = -0.96 * log( 1.0-4.5*zz ) + pslms( zz ) = zz*rric - 2.076*(1.0 - 1.0/(zz + 1.0)) + pslhu( zz ) = -0.96 * log( 1.0-4.5*zz ) + pslhs( zz ) = zz*rfac - 2.076*(1.0 - 1.0/(zz + 1.0)) + +! ... 2) paulson's surface functions + + pspmu( xx ) = -2.0 * log( (xx + 1.0)*0.5 ) & + & - log( (xx*xx + 1.0)*0.5 ) + 2.0*atan(xx) - pihf + pspms( yy ) = 5.0 * yy + psphu( xx ) = -2.0 * log( (xx*xx + 1.0)*0.5 ) + psphs( yy ) = 5.0 * yy + +! +!===> ... begin here +! +! --- ... this routine sfcdif can handle both over open water (sea, ocean) and +! over solid surface (land, sea-ice). + + ilech = 0 + +! --- ... ztfc: ratio of zoh/zom less or equal than 1 +! czil: constant c in zilitinkevich, s. s.1995,:note about zt + + zilfc = -czil * vkrm * sqvisc + + zu = z0 + + rdz = 1.0 / zlvl + cxch = excm * rdz + dthv = th2v - t1v + du2 = max( sfcspd*sfcspd, epsu2 ) + +! --- ... beljars correction of ustar + + btgh = btg * hpbl + +! --- ... if statements to avoid tangent linear problems near zero + if (btgh*ch*dthv /= 0.0) then + wstar2 = wwst2 * abs( btgh*ch*dthv )**(2.0/3.0) + else + wstar2 = 0.0 + endif + + ustar = max( sqrt( cm*sqrt( du2+wstar2 ) ), epsust ) + +! --- ... zilitinkevitch approach for zt + + zt = exp( zilfc*sqrt( ustar*z0 ) ) * z0 + + zslu = zlvl + zu + zslt = zlvl + zt + +! print*,'zslt=',zslt +! print*,'zlvl=',zvll +! print*,'zt=',zt + + rlogu = log( zslu/zu ) + rlogt = log( zslt/zt ) + + rlmo = elfc*ch*dthv / ustar**3 + +! print*,'rlmo=',rlmo +! print*,'elfc=',elfc +! print*,'ch=',ch +! print*,'dthv=',dthv +! print*,'ustar=',ustar + + do itr = 1, itrmx + +! --- ... 1./ monin-obukkhov length-scale + + zetalt = max( zslt*rlmo, ztmin ) + rlmo = zetalt / zslt + zetalu = zslu * rlmo + zetau = zu * rlmo + zetat = zt * rlmo + + if (ilech == 0) then + + if (rlmo < 0.0) then + xlu4 = 1.0 - 16.0 * zetalu + xlt4 = 1.0 - 16.0 * zetalt + xu4 = 1.0 - 16.0 * zetau + xt4 = 1.0 - 16.0* zetat + + xlu = sqrt( sqrt( xlu4 ) ) + xlt = sqrt( sqrt( xlt4 ) ) + xu = sqrt( sqrt( xu4 ) ) + xt = sqrt( sqrt( xt4 ) ) + + psmz = pspmu(xu) + +! print*,'-----------1------------' +! print*,'psmz=',psmz +! print*,'pspmu(zetau)=',pspmu( zetau ) +! print*,'xu=',xu +! print*,'------------------------' + + simm = pspmu( xlu ) - psmz + rlogu + pshz = psphu( xt ) + simh = psphu( xlt ) - pshz + rlogt + else + zetalu = min( zetalu, ztmax ) + zetalt = min( zetalt, ztmax ) + psmz = pspms( zetau ) + +! print*,'-----------2------------' +! print*,'psmz=',psmz +! print*,'pspms(zetau)=',pspms( zetau ) +! print*,'zetau=',zetau +! print*,'------------------------' + + simm = pspms( zetalu ) - psmz + rlogu + pshz = psphs( zetat ) + simh = psphs( zetalt ) - pshz + rlogt + endif ! end if_rlmo_block + + else + +! --- ... lech's functions + + if (rlmo < 0.0) then + psmz = pslmu( zetau ) + +! print*,'-----------3------------' +! print*,'psmz=',psmz +! print*,'pslmu(zetau)=',pslmu( zetau ) +! print*,'zetau=',zetau +! print*,'------------------------' + + simm = pslmu( zetalu ) - psmz + rlogu + pshz = pslhu( zetat ) + simh = pslhu( zetalt ) - pshz + rlogt + else + zetalu = min( zetalu, ztmax ) + zetalt = min( zetalt, ztmax ) + + psmz = pslms( zetau ) + +! print*,'-----------4------------' +! print*,'psmz=',psmz +! print*,'pslms(zetau)=',pslms( zetau ) +! print*,'zetau=',zetau +! print*,'------------------------' + + simm = pslms( zetalu ) - psmz + rlogu + pshz = pslhs( zetat ) + simh = pslhs( zetalt ) - pshz + rlogt + endif ! end if_rlmo_block + + endif ! end if_ilech_block + +! --- ... beljaars correction for ustar + + ustar = max( sqrt( cm*sqrt( du2+wstar2 ) ), epsust ) + +! --- ... zilitinkevitch fix for zt + + zt = exp( zilfc*sqrt( ustar*z0 ) ) * z0 + + zslt = zlvl + zt + rlogt = log( zslt/zt ) + + ustark = ustar * vkrm + cm = max( ustark/simm, cxch ) + ch = max( ustark/simh, cxch ) + +! --- ... if statements to avoid tangent linear problems near zero + + if (btgh*ch*dthv /= 0.0) then + wstar2 = wwst2 * abs(btgh*ch*dthv) ** (2.0/3.0) + else + wstar2 = 0.0 + endif + + rlmn = elfc*ch*dthv / ustar**3 + rlma = rlmo*wold + rlmn*wnew + + rlmo = rlma + + enddo ! end do_itr_loop + +! print*,'----------------------------' +! print*,'sfcdif output ! ! ! ! ! ! ! ! ! ! ! !' +! +! print*,'zlvl=',zlvl +! print*,'z0=',z0 +! print*,'t1v=',t1v +! print*,'th2v=',th2v +! print*,'sfcspd=',sfcspd +! print*,'czil=',czil +! print*,'cm=',cm +! print*,'ch=',ch +! print*,'----------------------------' +! + return +!................................... + end subroutine sfcdif +!----------------------------------- + + +!----------------------------------- + subroutine snfrac +!................................... +! --- inputs: +! & ( sneqv, snup, salp, snowh, & +! --- outputs: +! & sncovr & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snfrac calculatexsnow fraction (0 -> 1) ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sneqv - real, snow water equivalent (m) 1 ! +! snup - real, threshold sneqv depth above which sncovr=1 1 ! +! salp - real, tuning parameter 1 ! +! snowh - real, snow depth (m) 1 ! +! ! +! outputs to the calling program: ! +! sncovr - real, fractional snow cover 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real (kind=kind_phys), intent(in) :: sneqv, snup, salp, snowh + +! --- outputs: +! real (kind=kind_phys), intent(out) :: sncovr + +! --- locals: + real (kind=kind_phys) :: rsnow, z0n + +! +!===> ... begin here +! +! --- ... snup is veg-class dependent snowdepth threshhold (set in routine +! redprm) above which snocvr=1. + + if (sneqv < snup) then + rsnow = sneqv / snup + sncovr = 1.0 - (exp(-salp*rsnow) - rsnow*exp(-salp)) + else + sncovr = 1.0 + endif + + z0n = 0.035 + +! --- ... formulation of dickinson et al. 1986 + +! sncovr = snowh / (snowh + 5.0*z0n) + +! --- ... formulation of marshall et al. 1994 + +! sncovr = sneqv / (sneqv + 2.0*z0n) + +! + return +!................................... + end subroutine snfrac +!----------------------------------- + + +!----------------------------------- + subroutine snopac +!................................... +! --- inputs: +! & ( nsoil, nroot, etp, prcp, smcmax, smcwlt, smcref, smcdry, & +! & cmcmax, dt, df1, sfcems, sfctmp, t24, th2, fdown, epsca, & +! & bexp, pc, rch, rr, cfactr, slope, kdt, frzx, psisat, & +! & zsoil, dwsat, dksat, zbot, shdfac, ice, rtdis, quartz, & +! & fxexp, csoil, flx2, snowng, lheatstrg, & +! --- input/outputs: +! & prcp1, cmc, t1, stc, sncovr, sneqv, sndens, snowh, & +! & sh2o, tbot, beta, & +! --- outputs: +! & smc, ssoil, runoff1, runoff2, runoff3, edir, ec, et, & +! & ett, snomlt, drip, dew, flx1, flx3, esnow & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snopac calculates soil moisture and heat flux values and ! +! update soil moisture content and soil heat content values for the ! +! case when a snow pack is present. ! +! ! +! ! +! subprograms called: evapo, smflx, shflx, snowpack +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! etp - real, potential evaporation 1 ! +! prcp - real, precip rate 1 ! +! smcmax - real, porosity 1 ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! dt - real, time step 1 ! +! df1 - real, thermal diffusivity m ! +! sfcems - real, lw surface emissivity 1 ! +! sfctmp - real, sfc temperature 1 ! +! t24 - real, sfctmp**4 1 ! +! th2 - real, sfc air potential temperature 1 ! +! fdown - real, net solar + downward lw flux at sfc 1 ! +! epsca - real, 1 ! +! bexp - real, soil type "b" parameter 1 ! +! pc - real, plant coeff 1 ! +! rch - real, companion coefficient of ch 1 ! +! rr - real, 1 ! +! cfactr - real, canopy water parameters 1 ! +! slope - real, linear reservoir coefficient 1 ! +! kdt - real, 1 ! +! frzx - real, frozen ground parameter 1 ! +! psisat - real, saturated soil potential 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! dwsat - real, saturated soil diffusivity 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! zbot - real, specify depth of lower bd soil 1 ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! rtdis - real, root distribution nsoil ! +! quartz - real, soil quartz content 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! csoil - real, soil heat capacity 1 ! +! flx2 - real, freezing rain latent heat flux 1 ! +! snowng - logical, snow flag 1 ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! +! input/outputs from and to the calling program: ! +! prcp1 - real, effective precip 1 ! +! cmc - real, canopy moisture content 1 ! +! t1 - real, ground/canopy/snowpack eff skin temp 1 ! +! stc - real, soil temperature nsoil ! +! sncovr - real, snow cover 1 ! +! sneqv - real, water-equivalent snow depth 1 ! +! sndens - real, snow density 1 ! +! snowh - real, snow depth 1 ! +! sh2o - real, unfrozen soil moisture nsoil ! +! tbot - real, bottom soil temperature 1 ! +! beta - real, ratio of actual/potential evap 1 ! +! ! +! outputs to the calling program: ! +! smc - real, total soil moisture nsoil ! +! ssoil - real, upward soil heat flux 1 ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff 1 ! +! runoff3 - real, excess of porosity for a given soil layer 1 ! +! edir - real, direct soil evaporation 1 ! +! ec - real, canopy water evaporation 1 ! +! et - real, plant transpiration nsoil ! +! ett - real, total plant transpiration 1 ! +! snomlt - real, snow melt water equivalent 1 ! +! drip - real, through-fall of precip 1 ! +! dew - real, dewfall (or frostfall) 1 ! +! flx1 - real, precip-snow sfc flux 1 ! +! flx3 - real, phase-change heat flux from snowmelt 1 ! +! esnow - real, sublimation from snowpack 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + real, parameter :: esdmin = 1.e-6 + +! --- inputs: +! integer, intent(in) :: nsoil, nroot, ice + +! real (kind=kind_phys), intent(in) :: etp, prcp, smcmax, smcref, & +! & smcwlt, smcdry, cmcmax, dt, df1, sfcems, sfctmp, t24, & +! & th2, fdown, epsca, bexp, pc, rch, rr, cfactr, slope, kdt, & +! & frzx, psisat, dwsat, dksat, zbot, shdfac, quartz, & +! & csoil, fxexp, flx2, zsoil(nsoil), rtdis(nsoil) + +! logical, intent(in) :: snowng +! +! logical, intent(in) :: lheatstrg +! + +! --- input/outputs: +! real (kind=kind_phys), intent(inout) :: prcp1, t1, sncovr, sneqv, & +! & sndens, snowh, cmc, tbot, beta, sh2o(nsoil), stc(nsoil) + +! --- outputs: +! real (kind=kind_phys), intent(out) :: ssoil, runoff1, runoff2, & +! & runoff3, edir, ec, et(nsoil), ett, snomlt, drip, dew, & +! & flx1, flx3, esnow, smc(nsoil) + +! --- locals: + real (kind=kind_phys):: denom, dsoil, dtot, etp1, ssoil1, & + & snoexp, ex, t11, t12, t12a, t12b, yy, zz1, seh, t14, & + & ec1, edir1, ett1, etns, etns1, esnow1, esnow2, etanrg, & + & et1(nsoil) + + integer k + +! data snoexp /1.0/ !!! <----- for noah v2.7 + data snoexp /2.0/ !!! <----- for noah v2.7.1 + +! --- ... convert potential evap (etp) from kg m-2 s-1 to m s-1 and then to an +! amount (m) given timestep (dt) and call it an effective snowpack +! reduction amount, esnow2 (m) for a snowcover fraction = 1.0. this is +! the amount the snowpack would be reduced due to sublimation from the +! snow sfc during the timestep. sublimation will proceed at the +! potential rate unless the snow depth is less than the expected +! snowpack reduction. for snowcover fraction = 1.0, 0=edir=et=ec, and +! hence total evap = esnow = sublimation (potential evap rate) + +! --- ... if sea-ice (ice=1) or glacial-ice (ice=-1), snowcover fraction = 1.0, +! and sublimation is at the potential rate. +! for non-glacial land (ice=0), if snowcover fraction < 1.0, total +! evaporation < potential due to non-potential contribution from +! non-snow covered fraction. + + prcp1 = prcp1 * 0.001 + + edir = 0.0 + edir1 = 0.0 + + ec = 0.0 + ec1 = 0.0 + + do k = 1, nsoil + et (k) = 0.0 + et1(k) = 0.0 + enddo + + ett = 0.0 + ett1 = 0.0 + etns = 0.0 + etns1 = 0.0 + esnow = 0.0 + esnow1= 0.0 + esnow2= 0.0 + + dew = 0.0 + etp1 = etp * 0.001 + + if (etp < 0.0) then + +! --- ... if etp<0 (downward) then dewfall (=frostfall in this case). + + dew = -etp1 + esnow2 = etp1 * dt + etanrg = etp * ((1.0-sncovr)*lsubc + sncovr*lsubs) + + else + +! --- ... etp >= 0, upward moisture flux + + if (ice /= 0) then ! for sea-ice and glacial-ice case + + esnow = etp + esnow1 = esnow * 0.001 + esnow2 = esnow1 * dt + etanrg = esnow * lsubs + + else ! for non-glacial land case + + if (sncovr < 1.0) then + + call evapo & +! --- inputs: + & ( nsoil, nroot, cmc, cmcmax, etp1, dt, zsoil, & + & sh2o, smcmax, smcwlt, smcref, smcdry, pc, & + & shdfac, cfactr, rtdis, fxexp, & +! --- outputs: + & etns1, edir1, ec1, et1, ett1 & + & ) + + edir1 = edir1 * (1.0 - sncovr) + ec1 = ec1 * (1.0 - sncovr) + + do k = 1, nsoil + et1(k) = et1(k) * (1.0 - sncovr) + enddo + + ett1 = ett1 * (1.0 - sncovr) + etns1 = etns1 * (1.0 - sncovr) + + edir = edir1 * 1000.0 + ec = ec1 * 1000.0 + + do k = 1, nsoil + et(k) = et1(k) * 1000.0 + enddo + + ett = ett1 * 1000.0 + etns = etns1 * 1000.0 + + endif ! end if_sncovr_block + + esnow = etp * sncovr +! esnow1 = etp * 0.001 + esnow1 = esnow * 0.001 + esnow2 = esnow1 * dt + etanrg = esnow*lsubs + etns*lsubc + + endif ! end if_ice_block + + endif ! end if_etp_block + +! --- ... if precip is falling, calculate heat flux from snow sfc to newly +! accumulating precip. note that this reflects the flux appropriate for +! the not-yet-updated skin temperature (t1). assumes temperature of the +! snowfall striking the gound is =sfctmp (lowest model level air temp). + + flx1 = 0.0 + if ( snowng ) then +! --- ... fractional snowfall/rainfall + flx1 = (cpice* ffrozp + cph2o1*(1.-ffrozp)) & + & * prcp * (t1 - sfctmp) + else + if (prcp > 0.0) flx1 = cph2o1 * prcp * (t1 - sfctmp) + endif + +! --- ... calculate an 'effective snow-grnd sfc temp' (t12) based on heat +! fluxes between the snow pack and the soil and on net radiation. +! include flx1 (precip-snow sfc) and flx2 (freezing rain latent +! heat) fluxes. +! flx2 reflects freezing rain latent heat flux using t1 calculated +! in penman. + + dsoil = -0.5 * zsoil(1) + dtot = snowh + dsoil + denom = 1.0 + df1 / (dtot * rr * rch) + +! t12a = ( (fdown - flx1 - flx2 - sigma1*t24) / rch & +! & + th2 - sfctmp - beta*epsca ) / rr + t12a = ( (fdown - flx1 - flx2 - sfcems*sigma1*t24) / rch & + & + th2 - sfctmp - etanrg/rch ) / rr + + t12b = df1 * stc(1) / (dtot * rr * rch) + t12 = (sfctmp + t12a + t12b) / denom + +! --- ... if the 'effective snow-grnd sfc temp' is at or below freezing, no snow +! melt will occur. set the skin temp to this effective temp. reduce +! (by sublimination ) or increase (by frost) the depth of the snowpack, +! depending on sign of etp. +! update soil heat flux (ssoil) using new skin temperature (t1) +! since no snowmelt, set accumulated snowmelt to zero, set 'effective' +! precip from snowmelt to zero, set phase-change heat flux from snowmelt +! to zero. + + if (t12 <= tfreez) then + + t1 = t12 + ssoil = df1 * (t1 - stc(1)) / dtot +!wz ssoil = (t1 - stc (1)) * max(7.0, df1/dtot) + sneqv = max(0.0, sneqv-esnow2) + flx3 = 0.0 + ex = 0.0 + snomlt = 0.0 + + else + +! --- ... if the 'effective snow-grnd sfc temp' is above freezing, snow melt +! will occur. call the snow melt rate,ex and amt, snomlt. revise the +! effective snow depth. revise the skin temp because it would have chgd +! due to the latent heat released by the melting. calc the latent heat +! released, flx3. set the effective precip, prcp1 to the snow melt rate, +! ex for use in smflx. adjustment to t1 to account for snow patches. +! calculate qsat valid at freezing point. note that esat (saturation +! vapor pressure) value of 6.11e+2 used here is that valid at frzzing +! point. note that etp from call penman in sflx is ignored here in +! favor of bulk etp over 'open water' at freezing temp. +! update soil heat flux (s) using new skin temperature (t1) + +! --- ... noah v2.7.1 mek feb2004 +! non-linear weighting of snow vs non-snow covered portions of gridbox +! so with snoexp = 2.0 (>1), surface skin temperature is higher than +! for the linear case (snoexp = 1). + +! t1 = tfreez * sncovr**snoexp + t12 * (1.0 - sncovr**snoexp) + t1 = tfreez * max(0.01,sncovr**snoexp) + & + & t12 * (1.0 - max(0.01,sncovr**snoexp)) + + beta = 1.0 + ssoil = df1 * (t1 - stc(1)) / dtot + +! --- ... if potential evap (sublimation) greater than depth of snowpack. +! beta<1 +! snowpack has sublimated away, set depth to zero. + + if (sneqv-esnow2 <= esdmin) then + + sneqv = 0.0 + ex = 0.0 + snomlt = 0.0 + flx3 = 0.0 + + else + +! --- ... potential evap (sublimation) less than depth of snowpack, retain +! beta=1. + + sneqv = sneqv - esnow2 + seh = rch * (t1 - th2) + + t14 = t1 * t1 + t14 = t14 * t14 + + flx3 = fdown - flx1 - flx2 - sfcems*sigma1*t14 & + & - ssoil - seh - etanrg + if (flx3 <= 0.0) flx3 = 0.0 + + ex = flx3 * 0.001 / lsubf + +! --- ... snowmelt reduction depending on snow cover +! if snow cover less than 5% no snowmelt reduction +! note: does 'if' below fail to match the melt water with the melt +! energy? + +! if (sncovr > 0.05) ex = ex * sncovr + snomlt = ex * dt + +! --- ... esdmin represents a snowpack depth threshold value below which we +! choose not to retain any snowpack, and instead include it in snowmelt. + + if (sneqv-snomlt >= esdmin) then + + sneqv = sneqv - snomlt + + else + +! --- ... snowmelt exceeds snow depth + + ex = sneqv / dt + flx3 = ex * 1000.0 * lsubf + snomlt = sneqv + sneqv = 0.0 + + endif ! end if_sneqv-snomlt_block + + endif ! end if_sneqv-esnow2_block + +! prcp1 = prcp1 + ex + +! --- ... if non-glacial land, add snowmelt rate (ex) to precip rate to be used +! in subroutine smflx (soil moisture evolution) via infiltration. + +! --- ... for sea-ice and glacial-ice, the snowmelt will be added to subsurface +! runoff/baseflow later near the end of sflx (after return from call to +! subroutine snopac) + + if (ice == 0) prcp1 = prcp1 + ex + + endif ! end if_t12<=tfreez_block + +! --- ... final beta now in hand, so compute evaporation. evap equals etp +! unless beta<1. + +! eta = beta * etp + +! --- ... smflx returns updated soil moisture values for non-glacial land. +! if sea-ice (ice=1) or glacial-ice (ice=-1), skip call to smflx, since +! no soil medium for sea-ice or glacial-ice + + if (ice == 0) then + + call smflx & +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + + endif + +! --- ... before call shflx in this snowpack case, set zz1 and yy arguments to +! special values that ensure that ground heat flux calculated in shflx +! matches that already computed for below the snowpack, thus the sfc +! heat flux to be computed in shflx will effectively be the flux at the +! snow top surface. t11 is a dummy arguement so we will not use the +! skin temp value as revised by shflx. + + zz1 = 1.0 + yy = stc(1) - 0.5*ssoil*zsoil(1)*zz1 / df1 + t11 = t1 + +! --- ... shflx will calc/update the soil temps. note: the sub-sfc heat flux +! (ssoil1) and the skin temp (t11) output from this shflx call are not +! used in any subsequent calculations. rather, they are dummy variables +! here in the snopac case, since the skin temp and sub-sfc heat flux are +! updated instead near the beginning of the call to snopac. + + call shflx & +! --- inputs: + & ( nsoil, smc, smcmax, dt, yy, zz1, zsoil, zbot, & + & psisat, bexp, df1, ice, quartz, csoil, vegtyp, & + & shdfac, lheatstrg, & +! --- input/outputs: + & stc, t11, tbot, sh2o, & +! --- outputs: + & ssoil1 & + & ) + +! --- ... snow depth and density adjustment based on snow compaction. yy is +! assumed to be the soil temperture at the top of the soil column. + + if (ice == 0) then ! for non-glacial land + + if (sneqv > 0.0) then + + call snowpack & +! --- inputs: + & ( sneqv, dt, t1, yy, & +! --- input/outputs: + & snowh, sndens & + & ) + + else + + sneqv = 0.0 + snowh = 0.0 + sndens = 0.0 +! sncond = 1.0 + sncovr = 0.0 + + endif ! end if_sneqv_block + +! --- ... over sea-ice or glacial-ice, if s.w.e. (sneqv) below threshold lower +! bound (0.01 m for sea-ice, 0.10 m for glacial-ice), then set at +! lower bound and store the source increment in subsurface runoff/ +! baseflow (runoff2). note: runoff2 is then a negative value (as +! a flag) over sea-ice or glacial-ice, in order to achieve water balance. + + elseif (ice == 1) then ! for sea-ice + + if (sneqv >= 0.01) then + + call snowpack & +! --- inputs: + & ( sneqv, dt, t1, yy, & +! --- input/outputs: + & snowh, sndens & + & ) + + else + +! sndens = sneqv / snowh +! runoff2 = -(0.01 - sneqv) / dt + sneqv = 0.01 + snowh = 0.05 + sncovr = 1.0 +! snowh = sneqv / sndens + + endif ! end if_sneqv_block + + else ! for glacial-ice + + if (sneqv >= 0.10) then + + call snowpack & +! --- inputs: + & ( sneqv, dt, t1, yy, & +! --- input/outputs: + & snowh, sndens & + & ) + + else + +! sndens = sneqv / snowh +! runoff2 = -(0.10 - sneqv) / dt + sneqv = 0.10 + snowh = 0.50 + sncovr = 1.0 +! snowh = sneqv / sndens + + endif ! end if_sneqv_block + + endif ! end if_ice_block + +! + return +!................................... + end subroutine snopac +!----------------------------------- + + +!----------------------------------- + subroutine snow_new +!................................... +! --- inputs: +! & ( sfctmp, sn_new, & +! --- input/outputs: +! & snowh, sndens & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snow_new calculates snow depth and densitity to account ! +! for the new snowfall. new values of snow depth & density returned. ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sfctmp - real, surface air temperature (k) 1 ! +! sn_new - real, new snowfall (m) 1 ! +! ! +! input/outputs from and to the calling program: ! +! snowh - real, snow depth (m) 1 ! +! sndens - real, snow density 1 ! +! (g/cm3=dimensionless fraction of h2o density) ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real(kind=kind_phys), intent(in) :: sfctmp, sn_new + +! --- input/outputs: +! real(kind=kind_phys), intent(inout) :: snowh, sndens + +! --- locals: + real(kind=kind_phys) :: dsnew, snowhc, hnewc, newsnc, tempc + +! +!===> ... begin here +! +! --- ... conversion into simulation units + + snowhc = snowh * 100.0 + newsnc = sn_new * 100.0 + tempc = sfctmp - tfreez + +! --- ... calculating new snowfall density depending on temperature +! equation from gottlib l. 'a general runoff model for +! snowcovered and glacierized basin', 6th nordic hydrological +! conference, vemadolen, sweden, 1980, 172-177pp. + + if (tempc <= -15.0) then + dsnew = 0.05 + else + dsnew = 0.05 + 0.0017*(tempc + 15.0)**1.5 + endif + +! --- ... adjustment of snow density depending on new snowfall + + hnewc = newsnc / dsnew + sndens = (snowhc*sndens + hnewc*dsnew) / (snowhc + hnewc) + snowhc = snowhc + hnewc + snowh = snowhc * 0.01 +! + return +!................................... + end subroutine snow_new +!----------------------------------- + + +!----------------------------------- + subroutine snowz0 +!................................... +! --- inputs: +! & ( sncovr, & +! --- input/outputs: +! & z0 & +! & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snowz0 calculates total roughness length over snow ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from the calling program: size ! +! sncovr - real, fractional snow cover 1 ! +! ! +! input/outputs from and to the calling program: ! +! z0 - real, roughness length (m) 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: +! real(kind=kind_phys), intent(in) :: sncovr + +! --- input/outputs: +! real(kind=kind_phys), intent(inout) :: z0 + +! --- locals: + real(kind=kind_phys) :: z0s +! +!===> ... begin here +! +! z0s = 0.001 ! snow roughness length:=0.001 (m) +! --- ... current noah lsm condition - mbek, 09-oct-2001 + z0s = z0 + + z0 = (1.0 - sncovr)*z0 + sncovr*z0s + +! + return +!................................... + end subroutine snowz0 +!----------------------------------- + + +!----------------------------------- + subroutine tdfcnd & +!................................... +! --- inputs: + & ( smc, qz, smcmax, sh2o, & +! --- outputs: + & df & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine tdfcnd calculates thermal diffusivity and conductivity ! +! of the soil for a given point and time. ! +! ! +! peters-lidard approach (peters-lidard et al., 1998) ! +! june 2001 changes: frozen soil condition. ! +! ! +! subprogram called: none ! +! ! +! use as in peters-lidard, 1998 (modif. from johansen, 1975). ! +! pablo grunmann, 08/17/98 ! +! refs.: ! +! farouki, o.t.,1986: thermal properties of soils. series on rock ! +! and soil mechanics, vol. 11, trans tech, 136 pp. ! +! johansen, o., 1975: thermal conductivity of soils. ph.d. thesis, ! +! university of trondheim, ! +! peters-lidard, c. d., et al., 1998: the effect of soil thermal ! +! conductivity parameterization on surface energy fluxes ! +! and temperatures. journal of the atmospheric sciences, ! +! vol. 55, pp. 1209-1224. ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! smc - real, top layer total soil moisture 1 ! +! qz - real, quartz content (soil type dependent) 1 ! +! smcmax - real, porosity 1 ! +! sh2o - real, top layer unfrozen soil moisture 1 ! +! ! +! outputs: ! +! df - real, soil thermal diffusivity and conductivity 1 ! +! ! +! locals: ! +! thkw - water thermal conductivity 1 ! +! thkqtz - thermal conductivity for quartz 1 ! +! thko - thermal conductivity for other soil components 1 ! +! thkqtz - thermal conductivity for the solids combined 1 ! +! thkice - ice thermal conductivity 1 ! +! ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + real (kind=kind_phys), intent(in) :: smc, qz, smcmax, sh2o + +! --- output: + real (kind=kind_phys), intent(out) :: df + +! --- locals: + real (kind=kind_phys) :: gammd, thkdry, ake, thkice, thko, & + & thkqtz, thksat, thks, thkw, satratio, xu, xunfroz +! +!===> ... begin here +! +! --- ... if the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils + +! --- ... saturation ratio: + + satratio = smc / smcmax + +! --- ... parameters w/(m.k) + thkice = 2.2 + thkw = 0.57 + thko = 2.0 +! if (qz <= 0.2) thko = 3.0 + thkqtz = 7.7 + +! --- ... solids' conductivity + + thks = (thkqtz**qz) * (thko**(1.0-qz)) + +! --- ... unfrozen fraction (from 1., i.e., 100%liquid, to 0. (100% frozen)) + + xunfroz = (sh2o + 1.e-9) / (smc + 1.e-9) + +! --- ... unfrozen volume for saturation (porosity*xunfroz) + + xu=xunfroz*smcmax + +! --- ... saturated thermal conductivity + + thksat = thks**(1.-smcmax) * thkice**(smcmax-xu) * thkw**(xu) + +! --- ... dry density in kg/m3 + + gammd = (1.0 - smcmax) * 2700.0 + +! --- ... dry thermal conductivity in w.m-1.k-1 + + thkdry = (0.135*gammd + 64.7) / (2700.0 - 0.947*gammd) + + if ( sh2o+0.0005 < smc ) then ! frozen + + ake = satratio + + else ! unfrozen + +! --- ... range of validity for the kersten number (ake) + if ( satratio > 0.1 ) then + +! --- ... kersten number (using "fine" formula, valid for soils containing +! at least 5% of particles with diameter less than 2.e-6 meters.) +! (for "coarse" formula, see peters-lidard et al., 1998). + + ake = log10( satratio ) + 1.0 + + else + +! --- ... use k = kdry + ake = 0.0 + + endif ! end if_satratio_block + + endif ! end if_sh2o+0.0005_block + +! --- ... thermal conductivity + + df = ake * (thksat - thkdry) + thkdry +! + return +!................................... + end subroutine tdfcnd +!----------------------------------- + + +!*********************************************! +! section-2 2nd level subprograms ! +!*********************************************! + + +!----------------------------------- + subroutine evapo & +!................................... +! --- inputs: + & ( nsoil, nroot, cmc, cmcmax, etp1, dt, zsoil, & + & sh2o, smcmax, smcwlt, smcref, smcdry, pc, & + & shdfac, cfactr, rtdis, fxexp, & +! --- outputs: + & eta1, edir1, ec1, et1, ett1 & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine evapo calculates soil moisture flux. the soil moisture ! +! content (smc - a per unit volume measurement) is a dependent variable! +! that is updated with prognostic eqns. the canopy moisture content ! +! (cmc) is also updated. frozen ground version: new states added: ! +! sh2o, and frozen ground correction factor, frzfact and parameter ! +! slope. ! +! ! +! ! +! subprogram called: devap, transp ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs from calling program: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! cmc - real, canopy moisture content 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! etp1 - real, potential evaporation 1 ! +! dt - real, time step 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! sh2o - real, unfrozen soil moisture nsoil ! +! smcmax - real, porosity 1 ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! pc - real, plant coeff 1 ! +! cfactr - real, canopy water parameters 1 ! +! rtdis - real, root distribution nsoil ! +! fxexp - real, bare soil evaporation exponent 1 ! +! ! +! outputs to calling program: ! +! eta1 - real, latent heat flux 1 ! +! edir1 - real, direct soil evaporation 1 ! +! ec1 - real, canopy water evaporation 1 ! +! et1 - real, plant transpiration nsoil ! +! ett1 - real, total plant transpiration 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil, nroot + + real (kind=kind_phys), intent(in) :: cmc, cmcmax, etp1, dt, pc, & + & smcmax, smcwlt, smcref, smcdry, shdfac, cfactr, fxexp, & + & zsoil(nsoil), sh2o(nsoil), rtdis(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: eta1, edir1, ec1, ett1, & + & et1(nsoil) + +! --- locals: + real (kind=kind_phys) :: cmc2ms + + integer :: i, k + +! +!===> ... begin here +! +! --- ... executable code begins here if the potential evapotranspiration +! is greater than zero. + + edir1 = 0.0 + ec1 = 0.0 + + do k = 1, nsoil + et1(k) = 0.0 + enddo + ett1 = 0.0 + + if (etp1 > 0.0) then + +! --- ... retrieve direct evaporation from soil surface. call this function +! only if veg cover not complete. +! frozen ground version: sh2o states replace smc states. + + if (shdfac < 1.0) then + + call devap & +! --- inputs: + & ( etp1, sh2o(1), shdfac, smcmax, smcdry, fxexp, & +! --- outputs: + & edir1 & + & ) + + endif + +! --- ... initialize plant total transpiration, retrieve plant transpiration, +! and accumulate it for all soil layers. + + if (shdfac > 0.0) then + + call transp & +! --- inputs: + & ( nsoil, nroot, etp1, sh2o, smcwlt, smcref, & + & cmc, cmcmax, zsoil, shdfac, pc, cfactr, rtdis, & +! --- outputs: + & et1 & + & ) + + do k = 1, nsoil + ett1 = ett1 + et1(k) + enddo + +! --- ... calculate canopy evaporation. +! if statements to avoid tangent linear problems near cmc=0.0. + + if (cmc > 0.0) then + ec1 = shdfac * ( (cmc/cmcmax)**cfactr ) * etp1 + else + ec1 = 0.0 + endif + +! --- ... ec should be limited by the total amount of available water +! on the canopy. -f.chen, 18-oct-1994 + + cmc2ms = cmc / dt + ec1 = min ( cmc2ms, ec1 ) + endif + + endif ! end if_etp1_block + +! --- ... total up evap and transp types to obtain actual evapotransp + + eta1 = edir1 + ett1 + ec1 + +! + return +!................................... + end subroutine evapo +!----------------------------------- + + +!----------------------------------- + subroutine shflx & +!................................... +! --- inputs: + & ( nsoil, smc, smcmax, dt, yy, zz1, zsoil, zbot, & + & psisat, bexp, df1, ice, quartz, csoil, vegtyp, & + & shdfac, lheatstrg, & +! --- input/outputs: + & stc, t1, tbot, sh2o, & +! --- outputs: + & ssoil & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine shflx updates the temperature state of the soil column ! +! based on the thermal diffusion equation and update the frozen soil ! +! moisture content based on the temperature. ! +! ! +! subprogram called: hstep, hrtice, hrt ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! smc - real, total soil moisture nsoil ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! dt - real, time step 1 ! +! yy - real, soil temperature at the top of column 1 ! +! zz1 - real, 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! zbot - real, specify depth of lower bd soil 1 ! +! psisat - real, saturated soil potential 1 ! +! bexp - real, soil type "b" parameter 1 ! +! df1 - real, thermal diffusivity and conductivity 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! quartz - real, soil quartz content 1 ! +! csoil - real, soil heat capacity 1 ! +! vegtyp - integer, vegtation type 1 ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! +! input/outputs: ! +! stc - real, soil temp nsoil ! +! t1 - real, ground/canopy/snowpack eff skin temp 1 ! +! tbot - real, bottom soil temp 1 ! +! sh2o - real, unfrozen soil moisture nsoil ! +! ! +! outputs: ! +! ssoil - real, upward soil heat flux 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- parameter constants: + real (kind=kind_phys), parameter :: ctfil1 = 0.5 + real (kind=kind_phys), parameter :: ctfil2 = 1.0 - ctfil1 + +! --- inputs: + integer, intent(in) :: nsoil, ice, vegtyp + + real (kind=kind_phys), intent(in) :: smc(nsoil), smcmax, dt, yy, & + & zz1, zsoil(nsoil), zbot, psisat, bexp, df1, quartz,csoil,shdfac +! + logical, intent(in) :: lheatstrg +! +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: stc(nsoil), t1, tbot, & + & sh2o(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: ssoil + +! --- locals: + real (kind=kind_phys) :: ai(nsold), bi(nsold), ci(nsold), oldt1, & + & rhsts(nsold), stcf(nsold), stsoil(nsoil) + + integer :: i + +! +!===> ... begin here +! + oldt1 = t1 + do i = 1, nsoil + stsoil(i) = stc(i) + enddo + +! --- ... hrt routine calcs the right hand side of the soil temp dif eqn + + if (ice /= 0) then + +! --- ... sea-ice case, glacial-ice case + + call hrtice & +! --- inputs: + & ( nsoil, stc, zsoil, yy, zz1, df1, ice, & +! --- input/outputs: + & tbot, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + + call hstep & +! --- inputs: + & ( nsoil, stc, dt, & +! --- input/outputs: + & rhsts, ai, bi, ci, & +! --- outputs: + & stcf & + & ) + + else + +! --- ... land-mass case + + call hrt & +! --- inputs: + & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & + & zbot, psisat, dt, bexp, df1, quartz, csoil,vegtyp, & + & shdfac, lheatstrg, & +! --- input/outputs: + & sh2o, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + + call hstep & +! --- inputs: + & ( nsoil, stc, dt, & +! --- input/outputs: + & rhsts, ai, bi, ci, & +! --- outputs: + & stcf & + & ) + + endif + + do i = 1, nsoil + stc(i) = stcf(i) + enddo + +! --- ... in the no snowpack case (via routine nopac branch,) update the grnd +! (skin) temperature here in response to the updated soil temperature +! profile above. (note: inspection of routine snopac shows that t1 +! below is a dummy variable only, as skin temperature is updated +! differently in routine snopac) + + t1 = (yy + (zz1 - 1.0)*stc(1)) / zz1 + t1 = ctfil1*t1 + ctfil2*oldt1 + + do i = 1, nsoil + stc(i) = ctfil1*stc(i) + ctfil2*stsoil(i) + enddo + +! --- ... calculate surface soil heat flux + + ssoil = df1*(stc(1) - t1) / (0.5*zsoil(1)) + +! + return +!................................... + end subroutine shflx +!----------------------------------- + + + +!----------------------------------- + subroutine smflx & +!................................... +! --- inputs: + & ( nsoil, dt, kdt, smcmax, smcwlt, cmcmax, prcp1, & + & zsoil, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1, & +! --- input/outputs: + & cmc, sh2o, & +! --- outputs: + & smc, runoff1, runoff2, runoff3, drip & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine smflx calculates soil moisture flux. the soil moisture ! +! content (smc - a per unit volume measurement) is a dependent variable! +! that is updated with prognostic eqns. the canopy moisture content ! +! (cmc) is also updated. frozen ground version: new states added: sh2o! +! and frozen ground correction factor, frzx and parameter slope. ! +! ! +! ! +! subprogram called: srt, sstep ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! dt - real, time step 1 ! +! kdt - real, 1 ! +! smcmax - real, porosity 1 ! +! smcwlt - real, wilting point 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! prcp1 - real, effective precip 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! slope - real, linear reservoir coefficient 1 ! +! frzx - real, frozen ground parameter 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! shdfac - real, aeral coverage of green veg 1 ! +! edir1 - real, direct soil evaporation 1 ! +! ec1 - real, canopy water evaporation 1 ! +! et1 - real, plant transpiration nsoil ! +! ! +! input/outputs: ! +! cmc - real, canopy moisture content 1 ! +! sh2o - real, unfrozen soil moisture nsoil ! +! ! +! outputs: ! +! smc - real, total soil moisture nsoil ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff (baseflow) 1 ! +! runoff3 - real, excess of porosity 1 ! +! drip - real, through-fall of precip and/or dew 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), intent(in) :: dt, kdt, smcmax, smcwlt, & + & cmcmax, prcp1, slope, frzx, bexp, dksat, dwsat, shdfac, & + & edir1, ec1, et1(nsoil), zsoil(nsoil) + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: cmc, sh2o(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: smc(nsoil), runoff1, & + & runoff2, runoff3, drip + +! --- locals: + real (kind=kind_phys) :: dummy, excess, pcpdrp, rhsct, trhsct, & + & rhstt(nsold), sice(nsold), sh2oa(nsold), sh2ofg(nsold), & + & ai(nsold), bi(nsold), ci(nsold) + + integer :: i, k +! +!===> ... begin here +! +! --- ... executable code begins here. + + dummy = 0.0 + +! --- ... compute the right hand side of the canopy eqn term ( rhsct ) + + rhsct = shdfac*prcp1 - ec1 + +! --- ... convert rhsct (a rate) to trhsct (an amount) and add it to +! existing cmc. if resulting amt exceeds max capacity, it becomes +! drip and will fall to the grnd. + + drip = 0.0 + trhsct = dt * rhsct + excess = cmc + trhsct + + if (excess > cmcmax) drip = excess - cmcmax + +! --- ... pcpdrp is the combined prcp1 and drip (from cmc) that goes into +! the soil + + pcpdrp = (1.0 - shdfac)*prcp1 + drip/dt + +! --- ... store ice content at each soil layer before calling srt & sstep + + do i = 1, nsoil + sice(i) = smc(i) - sh2o(i) + enddo + +! --- ... call subroutines srt and sstep to solve the soil moisture +! tendency equations. + +! --- if the infiltrating precip rate is nontrivial, +! (we consider nontrivial to be a precip total over the time step +! exceeding one one-thousandth of the water holding capacity of +! the first soil layer) +! then call the srt/sstep subroutine pair twice in the manner of +! time scheme "f" (implicit state, averaged coefficient) +! of section 2 of kalnay and kanamitsu (1988, mwr, vol 116, +! pages 1945-1958)to minimize 2-delta-t oscillations in the +! soil moisture value of the top soil layer that can arise because +! of the extreme nonlinear dependence of the soil hydraulic +! diffusivity coefficient and the hydraulic conductivity on the +! soil moisture state +! otherwise call the srt/sstep subroutine pair once in the manner of +! time scheme "d" (implicit state, explicit coefficient) +! of section 2 of kalnay and kanamitsu +! pcpdrp is units of kg/m**2/s or mm/s, zsoil is negative depth in m + +! if ( pcpdrp .gt. 0.0 ) then + if ( (pcpdrp*dt) > (0.001*1000.0*(-zsoil(1))*smcmax) ) then + +! --- ... frozen ground version: +! smc states replaced by sh2o states in srt subr. sh2o & sice states +! included in sstep subr. frozen ground correction factor, frzx +! added. all water balance calculations using unfrozen water + + call srt & +! --- inputs: + & ( nsoil, edir1, et1, sh2o, sh2o, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + + call sstep & +! --- inputs: + & ( nsoil, sh2o, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & dummy, rhstt, ai, bi, ci, & +! --- outputs: + & sh2ofg, runoff3, smc & + & ) + + do k = 1, nsoil + sh2oa(k) = (sh2o(k) + sh2ofg(k)) * 0.5 + enddo + + call srt & +! --- inputs: + & ( nsoil, edir1, et1, sh2o, sh2oa, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + + call sstep & +! --- inputs: + & ( nsoil, sh2o, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & cmc, rhstt, ai, bi, ci, & +! --- outputs: + & sh2o, runoff3, smc & + & ) + + else + + call srt & +! --- inputs: + & ( nsoil, edir1, et1, sh2o, sh2o, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + + call sstep & +! --- inputs: + & ( nsoil, sh2o, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & cmc, rhstt, ai, bi, ci, & +! --- outputs: + & sh2o, runoff3, smc & + & ) + + endif + +! runof = runoff +! + return +!................................... + end subroutine smflx +!----------------------------------- + + +!----------------------------------- + subroutine snowpack & +!................................... +! --- inputs: + & ( esd, dtsec, tsnow, tsoil, & +! --- input/outputs: + & snowh, sndens & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snowpack calculates compaction of snowpack under ! +! conditions of increasing snow density, as obtained from an ! +! approximate solution of e. anderson's differential equation (3.29),! +! noaa technical report nws 19, by victor koren, 03/25/95. ! +! subroutine will return new values of snowh and sndens ! +! ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! esd - real, water equivalent of snow (m) 1 ! +! dtsec - real, time step (sec) 1 ! +! tsnow - real, snow surface temperature (k) 1 ! +! tsoil - real, soil surface temperature (k) 1 ! +! ! +! input/outputs: ! +! snowh - real, snow depth (m) 1 ! +! sndens - real, snow density 1 ! +! (g/cm3=dimensionless fraction of h2o density) ! +! ! +! ==================== end of description ===================== ! +! +! --- parameter constants: + real (kind=kind_phys), parameter :: c1 = 0.01 + real (kind=kind_phys), parameter :: c2 = 21.0 + +! --- inputs: + real (kind=kind_phys), intent(in) :: esd, dtsec, tsnow, tsoil + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: snowh, sndens + +! --- locals: + real (kind=kind_phys) :: bfac, dsx, dthr, dw, snowhc, pexp, & + & tavgc, tsnowc, tsoilc, esdc, esdcx + + integer :: ipol, j +! +!===> ... begin here +! +! --- ... conversion into simulation units + + snowhc = snowh * 100.0 + esdc = esd * 100.0 + dthr = dtsec / 3600.0 + tsnowc = tsnow - tfreez + tsoilc = tsoil - tfreez + +! --- ... calculating of average temperature of snow pack + + tavgc = 0.5 * (tsnowc + tsoilc) + +! --- ... calculating of snow depth and density as a result of compaction +! sndens=ds0*(exp(bfac*esd)-1.)/(bfac*esd) +! bfac=dthr*c1*exp(0.08*tavgc-c2*ds0) +! note: bfac*esd in sndens eqn above has to be carefully treated +! numerically below: +! c1 is the fractional increase in density (1/(cm*hr)) +! c2 is a constant (cm3/g) kojima estimated as 21 cms/g + + if (esdc > 1.e-2) then + esdcx = esdc + else + esdcx = 1.e-2 + endif + + bfac = dthr*c1 * exp(0.08*tavgc - c2*sndens) + +! dsx = sndens * ((dexp(bfac*esdc)-1.0) / (bfac*esdc)) + +! --- ... the function of the form (e**x-1)/x imbedded in above expression +! for dsx was causing numerical difficulties when the denominator "x" +! (i.e. bfac*esdc) became zero or approached zero (despite the fact +! that the analytical function (e**x-1)/x has a well defined limit +! as "x" approaches zero), hence below we replace the (e**x-1)/x +! expression with an equivalent, numerically well-behaved +! polynomial expansion. + +! --- ... number of terms of polynomial expansion, and hence its accuracy, +! is governed by iteration limit "ipol". +! ipol greater than 9 only makes a difference on double +! precision (relative errors given in percent %). +! ipol=9, for rel.error <~ 1.6 e-6 % (8 significant digits) +! ipol=8, for rel.error <~ 1.8 e-5 % (7 significant digits) +! ipol=7, for rel.error <~ 1.8 e-4 % ... + + ipol = 4 + pexp = 0.0 + + do j = ipol, 1, -1 +! pexp = (1.0 + pexp)*bfac*esdc /real(j+1) + pexp = (1.0 + pexp)*bfac*esdcx/real(j+1) + enddo + pexp = pexp + 1. + + dsx = sndens * pexp + +! --- ... above line ends polynomial substitution +! end of koren formulation + +!! --- ... base formulation (cogley et al., 1990) +! convert density from g/cm3 to kg/m3 + +!! dsm = sndens * 1000.0 + +!! dsx = dsm + dtsec*0.5*dsm*gs2*esd / & +!! & (1.e7*exp(-0.02*dsm + kn/(tavgc+273.16)-14.643)) + +!! --- ... convert density from kg/m3 to g/cm3 + +!! dsx = dsx / 1000.0 + +!! --- ... end of cogley et al. formulation + +! --- ... set upper/lower limit on snow density + + dsx = max( min( dsx, 0.40 ), 0.05 ) + sndens = dsx + +! --- ... update of snow depth and density depending on liquid water +! during snowmelt. assumed that 13% of liquid water can be +! stored in snow per day during snowmelt till snow density 0.40. + + if (tsnowc >= 0.0) then + dw = 0.13 * dthr / 24.0 + sndens = sndens*(1.0 - dw) + dw + if (sndens > 0.40) sndens = 0.40 + endif + +! --- ... calculate snow depth (cm) from snow water equivalent and snow +! density. change snow depth units to meters + + snowhc = esdc / sndens + snowh = snowhc * 0.01 + +! + return +!................................... + end subroutine snowpack +!----------------------------------- + + +!*********************************************! +! section-3 3rd or lower level subprograms ! +!*********************************************! + + +!----------------------------------- + subroutine devap & +!................................... +! --- inputs: + & ( etp1, smc, shdfac, smcmax, smcdry, fxexp, & +! --- outputs: + & edir1 & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine devap calculates direct soil evaporation ! +! ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! etp1 - real, potential evaporation 1 ! +! smc - real, unfrozen soil moisture 1 ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! smcmax - real, porosity (sat val of soil mois) 1 ! +! smcdry - real, dry soil mois threshold 1 ! +! fxexp - real, bare soil evaporation exponent 1 ! +! ! +! outputs: ! +! edir1 - real, direct soil evaporation 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + real (kind=kind_phys), intent(in) :: etp1, smc, shdfac, smcmax, & + & smcdry, fxexp + +! --- outputs: + real (kind=kind_phys), intent(out) :: edir1 + +! --- locals: + real (kind=kind_phys) :: fx, sratio +! +!===> ... begin here +! +! --- ... direct evap a function of relative soil moisture availability, +! linear when fxexp=1. +! fx > 1 represents demand control +! fx < 1 represents flux control + + sratio = (smc - smcdry) / (smcmax - smcdry) + + if (sratio > 0.0) then + fx = sratio**fxexp + fx = max ( min ( fx, 1.0 ), 0.0 ) + else + fx = 0.0 + endif + +! --- ... allow for the direct-evap-reducing effect of shade + + edir1 = fx * ( 1.0 - shdfac ) * etp1 +! + return +!................................... + end subroutine devap +!----------------------------------- + + +!----------------------------------- + subroutine frh2o & +!................................... +! --- inputs: + & ( tkelv, smc, sh2o, smcmax, bexp, psis, & +! --- outputs: + & liqwat & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine frh2o calculates amount of supercooled liquid soil water ! +! content if temperature is below 273.15k (t0). requires newton-type ! +! iteration to solve the nonlinear implicit equation given in eqn 17 ! +! of koren et al (1999, jgr, vol 104(d16), 19569-19585). ! +! ! +! new version (june 2001): much faster and more accurate newton ! +! iteration achieved by first taking log of eqn cited above -- less ! +! than 4 (typically 1 or 2) iterations achieves convergence. also, ! +! explicit 1-step solution option for special case of parameter ck=0, ! +! which reduces the original implicit equation to a simpler explicit ! +! form, known as the "flerchinger eqn". improved handling of solution ! +! in the limit of freezing point temperature t0. ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! tkelv - real, temperature (k) 1 ! +! smc - real, total soil moisture content (volumetric) 1 ! +! sh2o - real, liquid soil moisture content (volumetric) 1 ! +! smcmax - real, saturation soil moisture content 1 ! +! bexp - real, soil type "b" parameter 1 ! +! psis - real, saturated soil matric potential 1 ! +! ! +! outputs: ! +! liqwat - real, supercooled liquid water content 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- constant parameters: + real (kind=kind_phys), parameter :: ck = 8.0 +! real (kind=kind_phys), parameter :: ck = 0.0 + real (kind=kind_phys), parameter :: blim = 5.5 + real (kind=kind_phys), parameter :: error = 0.005 + +! --- inputs: + real (kind=kind_phys), intent(in) :: tkelv, smc, sh2o, smcmax, & + & bexp, psis + +! --- outputs: + real (kind=kind_phys), intent(out) :: liqwat + +! --- locals: + real (kind=kind_phys) :: bx, denom, df, dswl, fk, swl, swlk + + integer :: nlog, kcount +! +!===> ... begin here +! +! --- ... limits on parameter b: b < 5.5 (use parameter blim) +! simulations showed if b > 5.5 unfrozen water content is +! non-realistically high at very low temperatures. + + bx = bexp + if (bexp > blim) bx = blim + +! --- ... initializing iterations counter and iterative solution flag. + + nlog = 0 + kcount= 0 + +! --- ... if temperature not significantly below freezing (t0), sh2o = smc + + if (tkelv > (tfreez-1.e-3)) then + + liqwat = smc + + else + + if (ck /= 0.0) then + +! --- ... option 1: iterated solution for nonzero ck +! in koren et al, jgr, 1999, eqn 17 + +! --- ... initial guess for swl (frozen content) + + swl = smc - sh2o + +! --- ... keep within bounds. + + swl = max( min( swl, smc-0.02 ), 0.0 ) + +! --- ... start of iterations + + do while ( (nlog < 10) .and. (kcount == 0) ) + nlog = nlog + 1 + + df = alog( (psis*gs2/lsubf) * ( (1.0 + ck*swl)**2.0 ) & + & * (smcmax/(smc-swl))**bx ) - alog(-(tkelv-tfreez)/tkelv) + + denom = 2.0*ck/(1.0 + ck*swl) + bx/(smc - swl) + swlk = swl - df/denom + +! --- ... bounds useful for mathematical solution. + + swlk = max( min( swlk, smc-0.02 ), 0.0 ) + +! --- ... mathematical solution bounds applied. + + dswl = abs(swlk - swl) + swl = swlk + +! --- ... if more than 10 iterations, use explicit method (ck=0 approx.) +! when dswl less or eq. error, no more iterations required. + + if ( dswl <= error ) then + kcount = kcount + 1 + endif + enddo ! end do_while_loop + +! --- ... bounds applied within do-block are valid for physical solution. + + liqwat = smc - swl + + endif ! end if_ck_block + +! --- ... option 2: explicit solution for flerchinger eq. i.e. ck=0 +! in koren et al., jgr, 1999, eqn 17 +! apply physical bounds to flerchinger solution + + if (kcount == 0) then + fk = ( ( (lsubf/(gs2*(-psis))) & + & * ((tkelv-tfreez)/tkelv) )**(-1/bx) ) * smcmax + + fk = max( fk, 0.02 ) + + liqwat = min( fk, smc ) + endif + + endif ! end if_tkelv_block +! + return +!................................... + end subroutine frh2o +!----------------------------------- + + +!----------------------------------- + subroutine hrt & +!................................... +! --- inputs: + & ( nsoil, stc, smc, smcmax, zsoil, yy, zz1, tbot, & + & zbot, psisat, dt, bexp, df1, quartz, csoil, vegtyp, & + & shdfac, lheatstrg, & +! --- input/outputs: + & sh2o, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine hrt calculates the right hand side of the time tendency ! +! term of the soil thermal diffusion equation. also to compute ! +! (prepare) the matrix coefficients for the tri-diagonal matrix of ! +! the implicit time scheme. ! +! ! +! subprogram called: tbnd, snksrc, tmpavg ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! stc - real, soil temperature nsoil ! +! smc - real, total soil moisture nsoil ! +! smcmax - real, porosity 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! yy - real, 1 ! +! zz1 - real, soil temperture at the top soil column 1 ! +! tbot - real, bottom soil temp 1 ! +! zbot - real, specify depth of lower bd soil 1 ! +! psisat - real, saturated soil potential 1 ! +! dt - real, time step 1 ! +! bexp - real, soil type "b" parameter 1 ! +! df1 - real, thermal diffusivity 1 ! +! quartz - real, soil quartz content 1 ! +! csoil - real, soil heat capacity 1 ! +! vegtyp - integer, vegetation type 1 ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! lheatstrg- logical, flag for canopy heat storage 1 ! +! parameterization ! +! ! +! input/outputs: ! +! sh2o - real, unfrozen soil moisture nsoil ! +! ! +! outputs: ! +! rhsts - real, time tendency of soil thermal diffusion nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil, vegtyp + + real (kind=kind_phys), intent(in) :: stc(nsoil), smc(nsoil), & + & smcmax, zsoil(nsoil), yy, zz1, tbot, zbot, psisat, dt, & + & bexp, df1, quartz, csoil, shdfac + + logical, intent(in) :: lheatstrg + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: sh2o(nsoil) + +! --- outputs: + real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsold), & + & bi(nsold), ci(nsold) + +! --- locals: + real (kind=kind_phys) :: ddz, ddz2, denom, df1n, df1k, dtsdz, & + & dtsdz2, hcpct, qtot, ssoil, sice, tavg, tbk, tbk1, & + & tsnsr, tsurf, csoil_loc + + integer :: i, k + + logical :: itavg + +! +!===> ... begin here +! + csoil_loc=csoil + + if (.not.lheatstrg .and. ivegsrc == 1)then +!urban +! +!jhan urban canopy heat storage effect is included in pbl scheme +! + if( vegtyp == 13 ) then +! csoil_loc=3.0e6 + csoil_loc=3.0e6*(1.-shdfac)+csoil*shdfac ! gvf + endif + endif + +! --- ... initialize logical for soil layer temperature averaging. + + itavg = .true. +! itavg = .false. + +! === begin section for top soil layer + +! --- ... calc the heat capacity of the top soil layer + + hcpct = sh2o(1)*cph2o2 + (1.0 - smcmax)*csoil_loc & + & + (smcmax - smc(1))*cp2 + (smc(1) - sh2o(1))*cpice1 + +! --- ... calc the matrix coefficients ai, bi, and ci for the top layer + + ddz = 1.0 / ( -0.5*zsoil(2) ) + ai(1) = 0.0 + ci(1) = (df1*ddz) / ( zsoil(1)*hcpct ) + bi(1) = -ci(1) + df1 / ( 0.5*zsoil(1)*zsoil(1)*hcpct*zz1 ) + +! --- ... calculate the vertical soil temp gradient btwn the 1st and 2nd soil +! layers. then calculate the subsurface heat flux. use the temp +! gradient and subsfc heat flux to calc "right-hand side tendency +! terms", or "rhsts", for top soil layer. + + dtsdz = (stc(1) - stc(2)) / (-0.5*zsoil(2)) + ssoil = df1 * (stc(1) - yy) / (0.5*zsoil(1)*zz1) + rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) + +! --- ... next capture the vertical difference of the heat flux at top and +! bottom of first soil layer for use in heat flux constraint applied to +! potential soil freezing/thawing in routine snksrc. + + qtot = ssoil - df1*dtsdz + +! --- ... if temperature averaging invoked (itavg=true; else skip): +! set temp "tsurf" at top of soil column (for use in freezing soil +! physics later in subroutine snksrc). if snowpack content is +! zero, then tsurf expression below gives tsurf = skin temp. if +! snowpack is nonzero (hence argument zz1=1), then tsurf expression +! below yields soil column top temperature under snowpack. then +! calculate temperature at bottom interface of 1st soil layer for use +! later in subroutine snksrc + + if (itavg) then + + tsurf = (yy + (zz1-1)*stc(1)) / zz1 + + call tbnd & +! --- inputs: + & ( stc(1), stc(2), zsoil, zbot, 1, nsoil, & +! --- outputs: + & tbk & + & ) + + endif + +! --- ... calculate frozen water content in 1st soil layer. + + sice = smc(1) - sh2o(1) + +! --- ... if frozen water present or any of layer-1 mid-point or bounding +! interface temperatures below freezing, then call snksrc to +! compute heat source/sink (and change in frozen water content) +! due to possible soil water phase change + + if ( (sice > 0.0) .or. (tsurf < tfreez) .or. & + & (stc(1) < tfreez) .or. (tbk < tfreez) ) then + + if (itavg) then + + call tmpavg & +! --- inputs: + & ( tsurf, stc(1), tbk, zsoil, nsoil, 1, & +! --- outputs: + & tavg & + & ) + + else + + tavg = stc(1) + + endif ! end if_itavg_block + + call snksrc & +! --- inputs: + & ( nsoil, 1, tavg, smc(1), smcmax, psisat, bexp, dt, & + & qtot, zsoil, & +! --- input/outputs: + & sh2o(1), & +! --- outputs: + & tsnsr & + & ) + + + rhsts(1) = rhsts(1) - tsnsr / ( zsoil(1)*hcpct ) + + endif ! end if_sice_block + +! === this ends section for top soil layer. + +! --- ... initialize ddz2 + + ddz2 = 0.0 + +! --- ... loop thru the remaining soil layers, repeating the above process +! (except subsfc or "ground" heat flux not repeated in lower layers) + + df1k = df1 + + do k = 2, nsoil + +! --- ... calculate heat capacity for this soil layer. + + hcpct = sh2o(k)*cph2o2 + (1.0 - smcmax)*csoil_loc & + & + (smcmax - smc(k))*cp2 + (smc(k) - sh2o(k))*cpice1 + + if (k /= nsoil) then + +! --- ... this section for layer 2 or greater, but not last layer. +! calculate thermal diffusivity for this layer. + + call tdfcnd & +! --- inputs: + & ( smc(k), quartz, smcmax, sh2o(k), & +! --- outputs: + & df1n & + & ) +!urban +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1n = 3.24 +! endif +!wz only urban for igbp type +! +!jhan urban canopy heat storage effect is included in pbl scheme +! + if((.not.lheatstrg) .and. + & (ivegsrc == 1 .and. vegtyp == 13)) then + df1n = 3.24*(1.-shdfac) + shdfac*df1n + endif + +! --- ... calc the vertical soil temp gradient thru this layer + + denom = 0.5 * (zsoil(k-1) - zsoil(k+1)) + dtsdz2 = (stc(k) - stc(k+1)) / denom + +! --- ... calc the matrix coef, ci, after calc'ng its partial product + + ddz2 = 2.0 / (zsoil(k-1) - zsoil(k+1)) + ci(k) = -df1n*ddz2 / ((zsoil(k-1) - zsoil(k)) * hcpct) + +! --- ... if temperature averaging invoked (itavg=true; else skip): +! calculate temp at bottom of layer. + + if (itavg) then + + call tbnd & +! --- inputs: + & ( stc(k), stc(k+1), zsoil, zbot, k, nsoil, & +! --- outputs: + & tbk1 & + & ) + + endif + + else + +! --- ... special case of bottom soil layer: calculate thermal diffusivity +! for bottom layer. + + call tdfcnd & +! --- inputs: + & ( smc(k), quartz, smcmax, sh2o(k), & +! --- outputs: + & df1n & + & ) +!urban +! if (ivegsrc == 1)then +! if ( vegtyp == 13 ) df1n = 3.24 +! endif +!wz only urban for igbp type +! +!jhan urban canopy heat storage effect is included in pbl scheme +! + if((.not.lheatstrg) .and. + & (ivegsrc == 1 .and. vegtyp == 13)) then + df1n = 3.24*(1.-shdfac) + shdfac*df1n + endif + +! --- ... calc the vertical soil temp gradient thru bottom layer. + + denom = 0.5 * (zsoil(k-1) + zsoil(k)) - zbot + dtsdz2 = (stc(k) - tbot) / denom + +! --- ... set matrix coef, ci to zero if bottom layer. + + ci(k) = 0.0 + +! --- ... if temperature averaging invoked (itavg=true; else skip): +! calculate temp at bottom of last layer. + + if (itavg) then + + call tbnd & +! --- inputs: + & ( stc(k), tbot, zsoil, zbot, k, nsoil, & +! --- outputs: + & tbk1 & + & ) + + endif + + endif ! end if_k_block + +! --- ... calculate rhsts for this layer after calc'ng a partial product. + + denom = (zsoil(k) - zsoil(k-1)) * hcpct + rhsts(k) = ( df1n*dtsdz2 - df1k*dtsdz ) / denom + + qtot = -1.0 * denom * rhsts(k) + sice = smc(k) - sh2o(k) + + if ( (sice > 0.0) .or. (tbk < tfreez) .or. & + & (stc(k) < tfreez) .or. (tbk1 < tfreez) ) then + + if (itavg) then + + call tmpavg & +! --- inputs: + & ( tbk, stc(k), tbk1, zsoil, nsoil, k, & +! --- outputs: + & tavg & + & ) + + else + tavg = stc(k) + endif + + call snksrc & +! --- inputs: + & ( nsoil, k, tavg, smc(k), smcmax, psisat, bexp, dt, & + & qtot, zsoil, & +! --- input/outputs: + & sh2o(k), & +! --- outputs: + & tsnsr & + & ) + + rhsts(k) = rhsts(k) - tsnsr/denom + endif + +! --- ... calc matrix coefs, ai, and bi for this layer. + + ai(k) = - df1 * ddz / ((zsoil(k-1) - zsoil(k)) * hcpct) + bi(k) = -(ai(k) + ci(k)) + +! --- ... reset values of df1, dtsdz, ddz, and tbk for loop to next soil layer. + + tbk = tbk1 + df1k = df1n + dtsdz = dtsdz2 + ddz = ddz2 + + enddo ! end do_k_loop + +! + return +!................................... + end subroutine hrt +!----------------------------------- + + +!----------------------------------- + subroutine hrtice & +!................................... +! --- inputs: + & ( nsoil, stc, zsoil, yy, zz1, df1, ice, & +! --- input/outputs: + & tbot, & +! --- outputs: + & rhsts, ai, bi, ci & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine hrtice calculates the right hand side of the time tendency! +! term of the soil thermal diffusion equation for sea-ice (ice = 1) or ! +! glacial-ice (ice). compute (prepare) the matrix coefficients for the ! +! tri-diagonal matrix of the implicit time scheme. ! +! (note: this subroutine only called for sea-ice or glacial ice, but ! +! not for non-glacial land (ice = 0). ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! stc - real, soil temperature nsoil ! +! zsoil - real, soil depth (negative sign, as below grd) nsoil ! +! yy - real, soil temperature at the top of column 1 ! +! zz1 - real, 1 ! +! df1 - real, thermal diffusivity and conductivity 1 ! +! ice - integer, sea-ice flag (=1: sea-ice, =0: land) 1 ! +! ! +! input/outputs: ! +! tbot - real, bottom soil temperature 1 ! +! ! +! outputs: ! +! rhsts - real, time tendency of soil thermal diffusion nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil, ice + + real (kind=kind_phys), intent(in) :: stc(nsoil), zsoil(nsoil), & + & yy, zz1, df1 + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: tbot + +! --- outputs: + real (kind=kind_phys), intent(out) :: rhsts(nsoil), ai(nsold), & + & bi(nsold), ci(nsold) + +! --- locals: + real (kind=kind_phys) :: ddz, ddz2, denom, dtsdz, dtsdz2, & + & hcpct, ssoil, zbot + + integer :: k + +! +!===> ... begin here +! +! --- ... set a nominal universal value of the sea-ice specific heat capacity, +! hcpct = 1880.0*917.0 = 1.72396e+6 (source: fei chen, 1995) +! set bottom of sea-ice pack temperature: tbot = 271.16 +! set a nominal universal value of glacial-ice specific heat capacity, +! hcpct = 2100.0*900.0 = 1.89000e+6 (source: bob grumbine, 2005) +! tbot passed in as argument, value from global data set + + if (ice == 1) then +! --- ... sea-ice + hcpct = 1.72396e+6 + tbot = 271.16 + else +! --- ... glacial-ice + hcpct = 1.89000e+6 + endif + +! --- ... the input argument df1 is a universally constant value of sea-ice +! and glacial-ice thermal diffusivity, set in sflx as df1 = 2.2. + +! --- ... set ice pack depth. use tbot as ice pack lower boundary temperature +! (that of unfrozen sea water at bottom of sea ice pack). assume ice +! pack is of n=nsoil layers spanning a uniform constant ice pack +! thickness as defined by zsoil(nsoil) in routine sflx. +! if glacial-ice, set zbot = -25 meters + + if (ice == 1) then +! --- ... sea-ice + zbot = zsoil(nsoil) + else +! --- ... glacial-ice + zbot = -25.0 + endif + +! --- ... calc the matrix coefficients ai, bi, and ci for the top layer + + ddz = 1.0 / (-0.5*zsoil(2)) + ai(1) = 0.0 + ci(1) = (df1*ddz) / (zsoil(1)*hcpct) + bi(1) = -ci(1) + df1 / (0.5*zsoil(1)*zsoil(1)*hcpct*zz1) + +! --- ... calc the vertical soil temp gradient btwn the top and 2nd soil +! layers. recalc/adjust the soil heat flux. use the gradient and +! flux to calc rhsts for the top soil layer. + + dtsdz = (stc(1) - stc(2)) / (-0.5*zsoil(2)) + ssoil = df1 * (stc(1) - yy) / (0.5*zsoil(1)*zz1) + rhsts(1) = (df1*dtsdz - ssoil) / (zsoil(1)*hcpct) + +! --- ... initialize ddz2 + + ddz2 = 0.0 + +! --- ... loop thru the remaining soil layers, repeating the above process + + do k = 2, nsoil + + if (k /= nsoil) then + +! --- ... calc the vertical soil temp gradient thru this layer. + + denom = 0.5 * (zsoil(k-1) - zsoil(k+1)) + dtsdz2 = (stc(k) - stc(k+1)) / denom + +! --- ... calc the matrix coef, ci, after calc'ng its partial product. + + ddz2 = 2.0 / (zsoil(k-1) - zsoil(k+1)) + ci(k) = -df1*ddz2 / ((zsoil(k-1) - zsoil(k))*hcpct) + + else + +! --- ... calc the vertical soil temp gradient thru the lowest layer. + + dtsdz2 = (stc(k) - tbot) & + & / (0.5*(zsoil(k-1) + zsoil(k)) - zbot) + +! --- ... set matrix coef, ci to zero. + + ci(k) = 0.0 + + endif ! end if_k_block + +! --- ... calc rhsts for this layer after calc'ng a partial product. + + denom = (zsoil(k) - zsoil(k-1)) * hcpct + rhsts(k) = (df1*dtsdz2 - df1*dtsdz) / denom + +! --- ... calc matrix coefs, ai, and bi for this layer. + + ai(k) = - df1*ddz / ((zsoil(k-1) - zsoil(k)) * hcpct) + bi(k) = -(ai(k) + ci(k)) + +! --- ... reset values of dtsdz and ddz for loop to next soil lyr. + + dtsdz = dtsdz2 + ddz = ddz2 + + enddo ! end do_k_loop +! + return +!................................... + end subroutine hrtice +!----------------------------------- + + +!----------------------------------- + subroutine hstep & +!................................... +! --- inputs: + & ( nsoil, stcin, dt, & +! --- input/outputs: + & rhsts, ai, bi, ci, & +! --- outputs: + & stcout & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine hstep calculates/updates the soil temperature field. ! +! ! +! subprogram called: rosr12 ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! stcin - real, soil temperature nsoil ! +! dt - real, time step 1 ! +! ! +! input/outputs: ! +! rhsts - real, time tendency of soil thermal diffusion nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! outputs: ! +! stcout - real, updated soil temperature nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), intent(in) :: stcin(nsoil), dt + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: rhsts(nsoil), & + & ai(nsold), bi(nsold), ci(nsold) + +! --- outputs: + real (kind=kind_phys), intent(out) :: stcout(nsoil) + +! --- locals: + integer :: k + + real (kind=kind_phys) :: ciin(nsold), rhstsin(nsoil) + +! +!===> ... begin here +! +! --- ... create finite difference values for use in rosr12 routine + + do k = 1, nsoil + rhsts(k) = rhsts(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1.0 + bi(k)*dt + ci(k) = ci(k) * dt + enddo + +! --- ... copy values for input variables before call to rosr12 + + do k = 1, nsoil + rhstsin(k) = rhsts(k) + enddo + + do k = 1, nsold + ciin(k) = ci(k) + enddo + +! --- ... solve the tri-diagonal matrix equation + + call rosr12 & +! --- inputs: + & ( nsoil, ai, bi, rhstsin, & +! --- input/outputs: + & ciin, & +! --- outputs: + & ci, rhsts & + & ) + +! --- ... calc/update the soil temps using matrix solution + + do k = 1, nsoil + stcout(k) = stcin(k) + ci(k) + enddo +! + return +!................................... + end subroutine hstep +!----------------------------------- + + +!----------------------------------- + subroutine rosr12 & +!................................... +! --- inputs: + & ( nsoil, a, b, d, & +! --- input/outputs: + & c, & +! --- outputs: + & p, delta & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine rosr12 inverts (solve) the tri-diagonal matrix problem ! +! shown below: ! +! ! +! ### ### ### ### ### ###! +! #b(1), c(1), 0 , 0 , 0 , . . . , 0 # # # # #! +! #a(2), b(2), c(2), 0 , 0 , . . . , 0 # # # # #! +! # 0 , a(3), b(3), c(3), 0 , . . . , 0 # # # # d(3) #! +! # 0 , 0 , a(4), b(4), c(4), . . . , 0 # # p(4) # # d(4) #! +! # 0 , 0 , 0 , a(5), b(5), . . . , 0 # # p(5) # # d(5) #! +! # . . # # . # = # . #! +! # . . # # . # # . #! +! # . . # # . # # . #! +! # 0 , . . . , 0 , a(m-2), b(m-2), c(m-2), 0 # #p(m-2)# #d(m-2)#! +! # 0 , . . . , 0 , 0 , a(m-1), b(m-1), c(m-1)# #p(m-1)# #d(m-1)#! +! # 0 , . . . , 0 , 0 , 0 , a(m) , b(m) # # p(m) # # d(m) #! +! ### ### ### ### ### ###! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! a - real, matrix coefficients nsoil ! +! b - real, matrix coefficients nsoil ! +! d - real, soil water time tendency nsoil ! +! ! +! input/outputs: ! +! c - real, matrix coefficients nsoil ! +! ! +! outputs: ! +! p - real, nsoil ! +! delta - real, nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: a, b, d + +! --- input/outputs: + real (kind=kind_phys), dimension(nsoil), intent(inout) :: c + +! --- outputs: + real (kind=kind_phys), dimension(nsoil), intent(out) :: p, delta + +! --- locals: + integer :: k, kk + +! +!===> ... begin here +! +! --- ... initialize eqn coef c for the lowest soil layer + + c(nsoil) = 0.0 + +! --- ... solve the coefs for the 1st soil layer + + p(1) = -c(1) / b(1) + delta(1) = d(1) / b(1) + +! --- ... solve the coefs for soil layers 2 thru nsoil + + do k = 2, nsoil + p(k) = -c(k) * ( 1.0 / (b(k) + a (k)*p(k-1)) ) + delta(k) = (d(k) - a(k)*delta(k-1)) & + & * ( 1.0 / (b(k) + a(k)*p(k-1)) ) + enddo + +! --- ... set p to delta for lowest soil layer + + p(nsoil) = delta(nsoil) + +! --- ... adjust p for soil layers 2 thru nsoil + + do k = 2, nsoil + kk = nsoil - k + 1 + p(kk) = p(kk)*p(kk+1) + delta(kk) + enddo +! + return +!................................... + end subroutine rosr12 +!----------------------------------- + + +!----------------------------------- + subroutine snksrc & +!................................... +! --- inputs: + & ( nsoil, k, tavg, smc, smcmax, psisat, bexp, dt, & + & qtot, zsoil, & +! --- input/outputs: + & sh2o, & +! --- outputs: + & tsrc & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine snksrc calculates sink/source term of the termal ! +! diffusion equation. ! +! ! +! subprograms called: frh2o ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! k - integer, index of soil layers 1 ! +! tavg - real, soil layer average temperature 1 ! +! smc - real, total soil moisture 1 ! +! smcmax - real, porosity 1 ! +! psisat - real, saturated soil potential 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dt - real, time step 1 ! +! qtot - real, tot vertical diff of heat flux 1 ! +! zsoil - real, soil layer depth below ground (negative) nsoil ! +! ! +! input/outputs: ! +! sh2o - real, available liqued water 1 ! +! ! +! outputs: ! +! tsrc - real, heat source/sink 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- parameter constants: + real (kind=kind_phys), parameter :: dh2o = 1.0000e3 + +! --- inputs: + integer, intent(in) :: nsoil, k + + real (kind=kind_phys), intent(in) :: tavg, smc, smcmax, psisat, & + & bexp, dt, qtot, zsoil(nsoil) + +! --- input/outputs: + real (kind=kind_phys), intent(inout) :: sh2o + +! --- outputs: + real (kind=kind_phys), intent(out) :: tsrc + +! --- locals: + real (kind=kind_phys) :: dz, free, xh2o + +! --- external functions: +! real (kind=kind_phys) :: frh2o + +! +!===> ... begin here +! + if (k == 1) then + dz = -zsoil(1) + else + dz = zsoil(k-1) - zsoil(k) + endif + +! --- ... via function frh2o, compute potential or 'equilibrium' unfrozen +! supercooled free water for given soil type and soil layer temperature. +! function frh20 invokes eqn (17) from v. koren et al (1999, jgr, vol. +! 104, pg 19573). (aside: latter eqn in journal in centigrade units. +! routine frh2o use form of eqn in kelvin units.) + +! free = frh2o( tavg,smc,sh2o,smcmax,bexp,psisat ) + + call frh2o & +! --- inputs: + & ( tavg, smc, sh2o, smcmax, bexp, psisat, & +! --- outputs: + & free & + & ) + + +! --- ... in next block of code, invoke eqn 18 of v. koren et al (1999, jgr, +! vol. 104, pg 19573.) that is, first estimate the new amountof liquid +! water, 'xh2o', implied by the sum of (1) the liquid water at the begin +! of current time step, and (2) the freeze of thaw change in liquid +! water implied by the heat flux 'qtot' passed in from routine hrt. +! second, determine if xh2o needs to be bounded by 'free' (equil amt) or +! if 'free' needs to be bounded by xh2o. + + xh2o = sh2o + qtot*dt / (dh2o*lsubf*dz) + +! --- ... first, if freezing and remaining liquid less than lower bound, then +! reduce extent of freezing, thereby letting some or all of heat flux +! qtot cool the soil temp later in routine hrt. + + if ( xh2o < sh2o .and. xh2o < free) then + if ( free > sh2o ) then + xh2o = sh2o + else + xh2o = free + endif + endif + +! --- ... second, if thawing and the increase in liquid water greater than +! upper bound, then reduce extent of thaw, thereby letting some or +! all of heat flux qtot warm the soil temp later in routine hrt. + + if ( xh2o > sh2o .and. xh2o > free ) then + if ( free < sh2o ) then + xh2o = sh2o + else + xh2o = free + endif + endif + + xh2o = max( min( xh2o, smc ), 0.0 ) + +! --- ... calculate phase-change heat source/sink term for use in routine hrt +! and update liquid water to reflcet final freeze/thaw increment. + + tsrc = -dh2o * lsubf * dz * (xh2o - sh2o) / dt + sh2o = xh2o +! + return +!................................... + end subroutine snksrc +!----------------------------------- + + +!----------------------------------- + subroutine srt & +!................................... +! --- inputs: + & ( nsoil, edir, et, sh2o, sh2oa, pcpdrp, zsoil, dwsat, & + & dksat, smcmax, bexp, dt, smcwlt, slope, kdt, frzx, sice, & +! --- outputs: + & rhstt, runoff1, runoff2, ai, bi, ci & + & ) + +! ===================================================================== ! +! description: ! +! subroutine srt calculates the right hand side of the time tendency ! +! term of the soil water diffusion equation. also to compute ! +! ( prepare ) the matrix coefficients for the tri-diagonal matrix ! +! of the implicit time scheme. ! +! ! +! subprogram called: wdfcnd ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! edir - real, direct soil evaporation 1 ! +! et - real, plant transpiration nsoil ! +! sh2o - real, unfrozen soil moisture nsoil ! +! sh2oa - real, nsoil ! +! pcpdrp - real, combined prcp and drip 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! dwsat - real, saturated soil diffusivity 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! smcmax - real, porosity 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dt - real, time step 1 ! +! smcwlt - real, wilting point 1 ! +! slope - real, linear reservoir coefficient 1 ! +! kdt - real, 1 ! +! frzx - real, frozen ground parameter 1 ! +! sice - real, ice content at each soil layer nsoil ! +! ! +! outputs: ! +! rhstt - real, soil water time tendency nsoil ! +! runoff1 - real, surface runoff not infiltrating sfc 1 ! +! runoff2 - real, sub surface runoff (baseflow) 1 ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! ==================== end of description ===================== ! +! +! --- inputs: + integer, intent(in) :: nsoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: et, & + & sh2o, sh2oa, zsoil, sice + + real (kind=kind_phys), intent(in) :: edir, pcpdrp, dwsat, dksat, & + & smcmax, smcwlt, bexp, dt, slope, kdt, frzx + +! --- outputs: + real (kind=kind_phys), intent(out) :: runoff1, runoff2, & + & rhstt(nsoil), ai(nsold), bi(nsold), ci(nsold) + + +! --- locals: + real (kind=kind_phys) :: acrt, dd, ddt, ddz, ddz2, denom, denom2, & + & dice, dsmdz, dsmdz2, dt1, fcr, infmax, mxsmc, mxsmc2, px, & + & numer, pddum, sicemax, slopx, smcav, sstt, sum, val, wcnd, & + & wcnd2, wdf, wdf2, dmax(nsold) + + integer :: cvfrz, ialp1, iohinf, j, jj, k, ks +! +!===> ... begin here +! +! --- ... frozen ground version: +! reference frozen ground parameter, cvfrz, is a shape parameter +! of areal distribution function of soil ice content which equals +! 1/cv. cv is a coefficient of spatial variation of soil ice content. +! based on field data cv depends on areal mean of frozen depth, and +! it close to constant = 0.6 if areal mean frozen depth is above 20 cm. +! that is why parameter cvfrz = 3 (int{1/0.6*0.6}). current logic +! doesn't allow cvfrz be bigger than 3 + + parameter (cvfrz = 3) + +c ---------------------------------------------------------------------- +! --- ... determine rainfall infiltration rate and runoff. include +! the infiltration formule from schaake and koren model. +! modified by q duan + + iohinf = 1 + +! --- ... let sicemax be the greatest, if any, frozen water content within +! soil layers. + + sicemax = 0.0 + do ks = 1, nsoil + if (sice(ks) > sicemax) sicemax = sice(ks) + enddo + +! --- ... determine rainfall infiltration rate and runoff + + pddum = pcpdrp + runoff1 = 0.0 + + if (pcpdrp /= 0.0) then + +! --- ... modified by q. duan, 5/16/94 + + dt1 = dt/86400. + smcav = smcmax - smcwlt + dmax(1) = -zsoil(1) * smcav + +! --- ... frozen ground version: + + dice = -zsoil(1) * sice(1) + + dmax(1) = dmax(1)*(1.0 - (sh2oa(1)+sice(1)-smcwlt)/smcav) + dd = dmax(1) + + do ks = 2, nsoil + +! --- ... frozen ground version: + + dice = dice + ( zsoil(ks-1) - zsoil(ks) ) * sice(ks) + + dmax(ks) = (zsoil(ks-1)-zsoil(ks))*smcav + dmax(ks) = dmax(ks)*(1.0 - (sh2oa(ks)+sice(ks)-smcwlt)/smcav) + dd = dd + dmax(ks) + enddo + +! --- ... val = (1.-exp(-kdt*sqrt(dt1))) +! in below, remove the sqrt in above + + val = 1.0 - exp(-kdt*dt1) + ddt = dd * val + + px = pcpdrp * dt + if (px < 0.0) px = 0.0 + + infmax = (px*(ddt/(px+ddt)))/dt + +! --- ... frozen ground version: +! reduction of infiltration based on frozen ground parameters + + fcr = 1. + + if (dice > 1.e-2) then + acrt = cvfrz * frzx / dice + sum = 1. + + ialp1 = cvfrz - 1 + do j = 1, ialp1 + k = 1 + + do jj = j+1,ialp1 + k = k * jj + enddo + + sum = sum + (acrt**( cvfrz-j)) / float (k) + enddo + + fcr = 1.0 - exp(-acrt) * sum + endif + + infmax = infmax * fcr + +! --- ... correction of infiltration limitation: +! if infmax .le. hydrolic conductivity assign infmax the value +! of hydrolic conductivity + +! mxsmc = max ( sh2oa(1), sh2oa(2) ) + mxsmc = sh2oa(1) + + call wdfcnd & +! --- inputs: + & ( mxsmc, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf, wcnd & + & ) + + infmax = max( infmax, wcnd ) + infmax = min( infmax, px ) + + if (pcpdrp > infmax) then + runoff1 = pcpdrp - infmax + pddum = infmax + endif + + endif ! end if_pcpdrp_block + +! --- ... to avoid spurious drainage behavior, 'upstream differencing' +! in line below replaced with new approach in 2nd line: +! 'mxsmc = max(sh2oa(1), sh2oa(2))' + + mxsmc = sh2oa(1) + + call wdfcnd & +! --- inputs: + & ( mxsmc, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf, wcnd & + & ) + +! --- ... calc the matrix coefficients ai, bi, and ci for the top layer + + ddz = 1.0 / ( -.5*zsoil(2) ) + ai(1) = 0.0 + bi(1) = wdf * ddz / ( -zsoil(1) ) + ci(1) = -bi(1) + +! --- ... calc rhstt for the top layer after calc'ng the vertical soil +! moisture gradient btwn the top and next to top layers. + + dsmdz = ( sh2o(1) - sh2o(2) ) / ( -.5*zsoil(2) ) + rhstt(1) = (wdf*dsmdz + wcnd - pddum + edir + et(1)) / zsoil(1) + sstt = wdf * dsmdz + wcnd + edir + et(1) + +! --- ... initialize ddz2 + + ddz2 = 0.0 + +! --- ... loop thru the remaining soil layers, repeating the abv process + + do k = 2, nsoil + denom2 = (zsoil(k-1) - zsoil(k)) + + if (k /= nsoil) then + slopx = 1.0 + +! --- ... again, to avoid spurious drainage behavior, 'upstream differencing' +! in line below replaced with new approach in 2nd line: +! 'mxsmc2 = max (sh2oa(k), sh2oa(k+1))' + + mxsmc2 = sh2oa(k) + + call wdfcnd & +! --- inputs: + & ( mxsmc2, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf2, wcnd2 & + & ) + +! --- ... calc some partial products for later use in calc'ng rhstt + + denom = (zsoil(k-1) - zsoil(k+1)) + dsmdz2 = (sh2o(k) - sh2o(k+1)) / (denom * 0.5) + +! --- ... calc the matrix coef, ci, after calc'ng its partial product + + ddz2 = 2.0 / denom + ci(k) = -wdf2 * ddz2 / denom2 + + else ! if_k_block + +! --- ... slope of bottom layer is introduced + + slopx = slope + +! --- ... retrieve the soil water diffusivity and hydraulic conductivity +! for this layer + + call wdfcnd & +! --- inputs: + & ( sh2oa(nsoil), smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf2, wcnd2 & + & ) + +! --- ... calc a partial product for later use in calc'ng rhstt + dsmdz2 = 0.0 + +! --- ... set matrix coef ci to zero + + ci(k) = 0.0 + + endif ! end if_k_block + +! --- ... calc rhstt for this layer after calc'ng its numerator + + numer = wdf2*dsmdz2 + slopx*wcnd2 - wdf*dsmdz - wcnd + et(k) + rhstt(k) = numer / (-denom2) + +! --- ... calc matrix coefs, ai, and bi for this layer + + ai(k) = -wdf * ddz / denom2 + bi(k) = -( ai(k) + ci(k) ) + +! --- ... reset values of wdf, wcnd, dsmdz, and ddz for loop to next lyr +! runoff2: sub-surface or baseflow runoff + + if (k == nsoil) then + runoff2 = slopx * wcnd2 + endif + + if (k /= nsoil) then + wdf = wdf2 + wcnd = wcnd2 + dsmdz= dsmdz2 + ddz = ddz2 + endif + enddo ! end do_k_loop +! + return +!................................... + end subroutine srt +!----------------------------------- + + +!----------------------------------- + subroutine sstep & +!................................... +! --- inputs: + & ( nsoil, sh2oin, rhsct, dt, smcmax, cmcmax, zsoil, sice, & +! --- input/outputs: + & cmc, rhstt, ai, bi, ci, & +! --- outputs: + & sh2oout, runoff3, smc & + & ) + +! ===================================================================== ! +! description: ! +! subroutine sstep calculates/updates soil moisture content values ! +! and canopy moisture content values. ! +! ! +! subprogram called: rosr12 ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! sh2oin - real, unfrozen soil moisture nsoil ! +! rhsct - real, 1 ! +! dt - real, time step 1 ! +! smcmax - real, porosity 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! sice - real, ice content at each soil layer nsoil ! +! ! +! input/outputs: ! +! cmc - real, canopy moisture content 1 ! +! rhstt - real, soil water time tendency nsoil ! +! ai - real, matrix coefficients nsold ! +! bi - real, matrix coefficients nsold ! +! ci - real, matrix coefficients nsold ! +! ! +! outputs: ! +! sh2oout - real, updated soil moisture content nsoil ! +! runoff3 - real, excess of porosity 1 ! +! smc - real, total soil moisture nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: nsoil + + real (kind=kind_phys), dimension(nsoil), intent(in) :: sh2oin, & + & zsoil, sice + + real (kind=kind_phys), intent(in) :: rhsct, dt, smcmax, cmcmax + +! --- inout/outputs: + real (kind=kind_phys), intent(inout) :: cmc, rhstt(nsoil), & + & ai(nsold), bi(nsold), ci(nsold) + +! --- outputs: + real (kind=kind_phys), intent(out) :: sh2oout(nsoil), runoff3, & + & smc(nsoil) + +! --- locals: + real (kind=kind_phys) :: ciin(nsold), rhsttin(nsoil), ddz, stot, & + & wplus + + integer :: i, k, kk11 +! +!===> ... begin here +! +! --- ... create 'amount' values of variables to be input to the +! tri-diagonal matrix routine. + + do k = 1, nsoil + rhstt(k) = rhstt(k) * dt + ai(k) = ai(k) * dt + bi(k) = 1. + bi(k) * dt + ci(k) = ci(k) * dt + enddo + +! --- ... copy values for input variables before call to rosr12 + + do k = 1, nsoil + rhsttin(k) = rhstt(k) + enddo + + do k = 1, nsold + ciin(k) = ci(k) + enddo + +! --- ... call rosr12 to solve the tri-diagonal matrix + + call rosr12 & +! --- inputs: + & ( nsoil, ai, bi, rhsttin, & +! --- input/outputs: + & ciin, & +! --- outputs: + & ci, rhstt & + & ) + +! --- ... sum the previous smc value and the matrix solution to get +! a new value. min allowable value of smc will be 0.02. +! runoff3: runoff within soil layers + + wplus = 0.0 + runoff3 = 0.0 + ddz = -zsoil(1) + + do k = 1, nsoil + if (k /= 1) ddz = zsoil(k - 1) - zsoil(k) + + sh2oout(k) = sh2oin(k) + ci(k) + wplus/ddz + + stot = sh2oout(k) + sice(k) + if (stot > smcmax) then + if (k == 1) then + ddz = -zsoil(1) + else + kk11 = k - 1 + ddz = -zsoil(k) + zsoil(kk11) + endif + + wplus = (stot - smcmax) * ddz + else + wplus = 0.0 + endif + + smc(k) = max( min( stot, smcmax ), 0.02 ) + sh2oout(k) = max( smc(k)-sice(k), 0.0 ) + enddo + + runoff3 = wplus + +! --- ... update canopy water content/interception (cmc). convert rhsct to +! an 'amount' value and add to previous cmc value to get new cmc. + + cmc = cmc + dt*rhsct + if (cmc < 1.e-20) cmc = 0.0 + cmc = min( cmc, cmcmax ) +! + return +!................................... + end subroutine sstep +!----------------------------------- + + +!----------------------------------- + subroutine tbnd & +!................................... +! --- inputs: + & ( tu, tb, zsoil, zbot, k, nsoil, & +! --- outputs: + & tbnd1 & + & ) + +! ===================================================================== ! +! description: ! +! ! +! subroutine tbnd calculates temperature on the boundary of the ! +! layer by interpolation of the middle layer temperatures ! +! ! +! subprogram called: none ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! tu - real, soil temperature 1 ! +! tb - real, bottom soil temp 1 ! +! zsoil - real, soil layer depth nsoil ! +! zbot - real, specify depth of lower bd soil 1 ! +! k - integer, soil layer index 1 ! +! nsoil - integer, number of soil layers 1 ! +! ! +! outputs: ! +! tbnd1 - real, temperature at bottom interface of the lyr 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: k, nsoil + + real (kind=kind_phys), intent(in) :: tu, tb, zbot, zsoil(nsoil) + +! --- output: + real (kind=kind_phys), intent(out) :: tbnd1 + +! --- locals: + real (kind=kind_phys) :: zb, zup + +! --- ... use surface temperature on the top of the first layer + + if (k == 1) then + zup = 0.0 + else + zup = zsoil(k-1) + endif + +! --- ... use depth of the constant bottom temperature when interpolate +! temperature into the last layer boundary + + if (k == nsoil) then + zb = 2.0*zbot - zsoil(k) + else + zb = zsoil(k+1) + endif + +! --- ... linear interpolation between the average layer temperatures + + tbnd1 = tu + (tb-tu)*(zup-zsoil(k))/(zup-zb) +! + return +!................................... + end subroutine tbnd +!----------------------------------- + + +!----------------------------------- + subroutine tmpavg & +!................................... +! --- inputs: + & ( tup, tm, tdn, zsoil, nsoil, k, & +! --- outputs: + & tavg & + & ) + +! ===================================================================== ! +! description: ! +! subroutine tmpavg calculates soil layer average temperature (tavg) ! +! in freezing/thawing layer using up, down, and middle layer ! +! temperatures (tup, tdn, tm), where tup is at top boundary of ! +! layer, tdn is at bottom boundary of layer. tm is layer prognostic ! +! state temperature. ! +! ! +! ! +! subprogram called: none ! +! ! +! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! tup - real, temperature ar top boundary of layer 1 ! +! tm - real, layer prognostic state temperature 1 ! +! tdn - real, temperature ar bottom boundary of layer 1 ! +! zsoil - real, soil layer depth nsoil ! +! nsoil - integer, number of soil layers 1 ! +! k - integer, layer index 1 ! +! outputs: ! +! tavg - real, soil layer average temperature 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: nsoil, k + + real (kind=kind_phys), intent(in) :: tup, tm, tdn, zsoil(nsoil) + +! --- output: + real (kind=kind_phys), intent(out) :: tavg + +! --- locals: + real (kind=kind_phys) :: dz, dzh, x0, xdn, xup +! +!===> ... begin here +! + if (k == 1) then + dz = -zsoil(1) + else + dz = zsoil(k-1) - zsoil(k) + endif + + dzh = dz * 0.5 + + if (tup < tfreez) then + + if (tm < tfreez) then + if (tdn < tfreez) then ! tup, tm, tdn < t0 + tavg = (tup + 2.0*tm + tdn) / 4.0 + else ! tup & tm < t0, tdn >= t0 + x0 = (tfreez - tm) * dzh / (tdn - tm) + tavg = 0.5*(tup*dzh + tm*(dzh+x0)+tfreez*(2.*dzh-x0)) / dz + endif + else + if (tdn < tfreez) then ! tup < t0, tm >= t0, tdn < t0 + xup = (tfreez-tup) * dzh / (tm-tup) + xdn = dzh - (tfreez-tm) * dzh / (tdn-tm) + tavg = 0.5*(tup*xup + tfreez*(2.*dz-xup-xdn)+tdn*xdn) / dz + else ! tup < t0, tm >= t0, tdn >= t0 + xup = (tfreez-tup) * dzh / (tm-tup) + tavg = 0.5*(tup*xup + tfreez*(2.*dz-xup)) / dz + endif + endif + + else ! if_tup_block + + if (tm < tfreez) then + if (tdn < tfreez) then ! tup >= t0, tm < t0, tdn < t0 + xup = dzh - (tfreez-tup) * dzh / (tm-tup) + tavg = 0.5*(tfreez*(dz-xup) + tm*(dzh+xup)+tdn*dzh) / dz + else ! tup >= t0, tm < t0, tdn >= t0 + xup = dzh - (tfreez-tup) * dzh / (tm-tup) + xdn = (tfreez-tm) * dzh / (tdn-tm) + tavg = 0.5 * (tfreez*(2.*dz-xup-xdn) + tm*(xup+xdn)) / dz + endif + else + if (tdn < tfreez) then ! tup >= t0, tm >= t0, tdn < t0 + xdn = dzh - (tfreez-tm) * dzh / (tdn-tm) + tavg = (tfreez*(dz-xdn) + 0.5*(tfreez+tdn)*xdn) / dz + else ! tup >= t0, tm >= t0, tdn >= t0 + tavg = (tup + 2.0*tm + tdn) / 4.0 + endif + endif + + endif ! end if_tup_block +! + return +!................................... + end subroutine tmpavg +!----------------------------------- + + +!----------------------------------- + subroutine transp & +!................................... +! --- inputs: + & ( nsoil, nroot, etp1, smc, smcwlt, smcref, & + & cmc, cmcmax, zsoil, shdfac, pc, cfactr, rtdis, & +! --- outputs: + & et1 & + & ) + +! ===================================================================== ! +! description: ! +! subroutine transp calculates transpiration for the veg class. ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! nsoil - integer, number of soil layers 1 ! +! nroot - integer, number of root layers 1 ! +! etp1 - real, potential evaporation 1 ! +! smc - real, unfrozen soil moisture nsoil ! +! smcwlt - real, wilting point 1 ! +! smcref - real, soil mois threshold 1 ! +! cmc - real, canopy moisture content 1 ! +! cmcmax - real, maximum canopy water parameters 1 ! +! zsoil - real, soil layer depth below ground nsoil ! +! shdfac - real, aeral coverage of green vegetation 1 ! +! pc - real, plant coeff 1 ! +! cfactr - real, canopy water parameters 1 ! +! rtdis - real, root distribution nsoil ! +! ! +! outputs: ! +! et1 - real, plant transpiration nsoil ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + integer, intent(in) :: nsoil, nroot + + real (kind=kind_phys), intent(in) :: etp1, smcwlt, smcref, & + & cmc, cmcmax, shdfac, pc, cfactr + + real (kind=kind_phys), dimension(nsoil), intent(in) :: smc, & + & zsoil, rtdis + +! --- output: + real (kind=kind_phys), dimension(nsoil), intent(out) :: et1 + +! --- locals: + real (kind=kind_phys) :: denom, etp1a, rtx, sgx, gx(7) + + integer :: i, k +! +!===> ... begin here +! +! --- ... initialize plant transp to zero for all soil layers. + + do k = 1, nsoil + et1(k) = 0.0 + enddo + +! --- ... calculate an 'adjusted' potential transpiration +! if statement below to avoid tangent linear problems near zero +! note: gx and other terms below redistribute transpiration by layer, +! et(k), as a function of soil moisture availability, while preserving +! total etp1a. + + if (cmc /= 0.0) then + etp1a = shdfac * pc * etp1 * (1.0 - (cmc /cmcmax) ** cfactr) + else + etp1a = shdfac * pc * etp1 + endif + + sgx = 0.0 + do i = 1, nroot + gx(i) = ( smc(i) - smcwlt ) / ( smcref - smcwlt ) + gx(i) = max ( min ( gx(i), 1.0 ), 0.0 ) + sgx = sgx + gx(i) + enddo + sgx = sgx / nroot + + denom = 0.0 + do i = 1, nroot + rtx = rtdis(i) + gx(i) - sgx + gx(i) = gx(i) * max ( rtx, 0.0 ) + denom = denom + gx(i) + enddo + if (denom <= 0.0) denom = 1.0 + + do i = 1, nroot + et1(i) = etp1a * gx(i) / denom + enddo + +! --- ... above code assumes a vertically uniform root distribution +! code below tests a variable root distribution + +! et(1) = ( zsoil(1) / zsoil(nroot) ) * gx * etp1a +! et(1) = ( zsoil(1) / zsoil(nroot) ) * etp1a + +! --- ... using root distribution as weighting factor + +! et(1) = rtdis(1) * etp1a +! et(1) = etp1a * part(1) + +! --- ... loop down thru the soil layers repeating the operation above, +! but using the thickness of the soil layer (rather than the +! absolute depth of each layer) in the final calculation. + +! do k = 2, nroot +! gx = ( smc(k) - smcwlt ) / ( smcref - smcwlt ) +! gx = max ( min ( gx, 1.0 ), 0.0 ) +! --- ... test canopy resistance +! gx = 1.0 +! et(k) = ((zsoil(k)-zsoil(k-1))/zsoil(nroot))*gx*etp1a +! et(k) = ((zsoil(k)-zsoil(k-1))/zsoil(nroot))*etp1a + +! --- ... using root distribution as weighting factor + +! et(k) = rtdis(k) * etp1a +! et(k) = etp1a*part(k) +! enddo + +! + return +!................................... + end subroutine transp +!----------------------------------- + + +!----------------------------------- + subroutine wdfcnd & +!................................... +! --- inputs: + & ( smc, smcmax, bexp, dksat, dwsat, sicemax, & +! --- outputs: + & wdf, wcnd & + & ) + +! ===================================================================== ! +! description: ! +! subroutine wdfcnd calculates soil water diffusivity and soil ! +! hydraulic conductivity. ! +! ! +! subprogram called: none ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! inputs: size ! +! smc - real, layer total soil moisture 1 ! +! smcmax - real, porosity 1 ! +! bexp - real, soil type "b" parameter 1 ! +! dksat - real, saturated soil hydraulic conductivity 1 ! +! dwsat - real, saturated soil diffusivity 1 ! +! sicemax - real, max frozen water content in soil layer 1 ! +! ! +! outputs: ! +! wdf - real, soil water diffusivity 1 ! +! wcnd - real, soil hydraulic conductivity 1 ! +! ! +! ==================== end of description ===================== ! +! +! --- input: + real (kind=kind_phys), intent(in) :: smc, smcmax, bexp, dksat, & + & dwsat, sicemax + +! --- output: + real (kind=kind_phys), intent(out) :: wdf, wcnd + +! --- locals: + real (kind=kind_phys) :: expon, factr1, factr2, vkwgt +! +!===> ... begin here +! +! --- ... calc the ratio of the actual to the max psbl soil h2o content + + factr1 = min(1.0, max(0.0, 0.2/smcmax)) + factr2 = min(1.0, max(0.0, smc/smcmax)) + +! --- ... prep an expntl coef and calc the soil water diffusivity + + expon = bexp + 2.0 + wdf = dwsat * factr2 ** expon + +! --- ... frozen soil hydraulic diffusivity. very sensitive to the vertical +! gradient of unfrozen water. the latter gradient can become very +! extreme in freezing/thawing situations, and given the relatively +! few and thick soil layers, this gradient sufferes serious +! trunction errors yielding erroneously high vertical transports of +! unfrozen water in both directions from huge hydraulic diffusivity. +! therefore, we found we had to arbitrarily constrain wdf +! +! version d_10cm: ....... factr1 = 0.2/smcmax +! weighted approach....... pablo grunmann, 28_sep_1999. + + if (sicemax > 0.0) then + vkwgt = 1.0 / (1.0 + (500.0*sicemax)**3.0) + wdf = vkwgt*wdf + (1.0- vkwgt)*dwsat*factr1**expon + endif + +! --- ... reset the expntl coef and calc the hydraulic conductivity + + expon = (2.0 * bexp) + 3.0 + wcnd = dksat * factr2 ** expon +! + return +!................................... + end subroutine wdfcnd +!----------------------------------- + +! =========================== ! +! end contain programs ! +! =========================== ! + +!................................... + end subroutine sflx +!----------------------------------- diff --git a/gsmphys/shalcnv.f b/gsmphys/shalcnv.f new file mode 100644 index 00000000..46ecf63b --- /dev/null +++ b/gsmphys/shalcnv.f @@ -0,0 +1,1281 @@ +!> \defgroup SASHAL Mass-Flux Shallow Convection +!! @{ +!! \brief The Mass-Flux shallow convection scheme parameterizes the effect of shallow convection on the environment much like the \ref SAS scheme with a few key modifications. Perhaps most importantly, no quasi-equilibrium assumption is necessary since the shallow cloud base mass flux is parameterized from the surface buoyancy flux. Further, there are no convective downdrafts, the entrainment rate is greater than for deep convection, and the shallow convection is limited to not extend over the level where \f$p=0.7p_{sfc}\f$. +!! +!! This scheme was designed to replace the previous eddy-diffusivity approach to shallow convection with a mass-flux based approach as it is used for deep convection. Differences between the shallow and deep SAS schemes are presented in Han and Pan (2011) \cite han_and_pan_2011 . Like the deep scheme, it uses the working concepts put forth in Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 but includes modifications and simplifications from Grell (1993) \cite grell_1993 such as only one cloud type (the deepest possible, up to \f$p=0.7p_{sfc}\f$), rather than a spectrum based on cloud top heights or assumed entrainment rates, although it assumes no convective downdrafts. It contains many modifications associated with deep scheme as discussed in Han and Pan (2011) \cite han_and_pan_2011 , including the calculation of cloud top, a greater CFL-criterion-based maximum cloud base mass flux, and the inclusion of convective overshooting. +!! +!! \section diagram Calling Hierarchy Diagram +!! \image html Shallow_SAS_Flowchart.png "Diagram depicting how the SAS shallow convection scheme is called from the GSM physics time loop" height=2cm +!! \section intraphysics Intraphysics Communication +!! This space is reserved for a description of how this scheme uses information from other scheme types and/or how information calculated in this scheme is used in other scheme types. + +!> \file shalcnv.f +!! Contains the entire SAS shallow convection scheme. + +!> \brief This subroutine contains the entirety of the SAS shallow convection scheme. +!! +!! This routine follows the \ref SAS scheme quite closely, although it can be interpreted as only having the "static" and "feedback" control portions, since the "dynamic" control is not necessary to find the cloud base mass flux. The algorithm is simplified from SAS deep convection by excluding convective downdrafts and being confined to operate below \f$p=0.7p_{sfc}\f$. Also, entrainment is both simpler and stronger in magnitude compared to the deep scheme. +!! +!! \param[in] im number of used points +!! \param[in] ix horizontal dimension +!! \param[in] km vertical layer dimension +!! \param[in] jcap number of spectral wave trancation +!! \param[in] delt physics time step in seconds +!! \param[in] delp pressure difference between level k and k+1 (Pa) +!! \param[in] prslp mean layer presure (Pa) +!! \param[in] psp surface pressure (Pa) +!! \param[in] phil layer geopotential (\f$m^s/s^2\f$) +!! \param[inout] ql cloud water or ice (kg/kg) +!! \param[inout] q1 updated tracers (kg/kg) +!! \param[inout] t1 updated temperature (K) +!! \param[inout] u1 updated zonal wind (\f$m s^{-1}\f$) +!! \param[inout] v1 updated meridional wind (\f$m s^{-1}\f$) +!! \param[out] rn convective rain (m) +!! \param[out] kbot index for cloud base +!! \param[out] ktop index for cloud top +!! \param[out] kcnv flag to denote deep convection (0=no, 1=yes) +!! \param[in] islimsk sea/land/ice mask (=0/1/2) +!! \param[in] dot layer mean vertical velocity (Pa/s) +!! \param[in] ncloud number of cloud species +!! \param[in] hpbl PBL height (m) +!! \param[in] heat surface sensible heat flux (K m/s) +!! \param[in] evap surface latent heat flux (kg/kg m/s) +!! \param[out] ud_mf updraft mass flux multiplied by time step (\f$kg/m^2\f$) +!! \param[out] dt_mf ud_mf at cloud top (\f$kg/m^2\f$) +!! \param[out] cnvw convective cloud water (kg/kg) +!! \param[out] cnvc convective cloud cover (unitless) +!! +!! \section general General Algorithm +!! -# Compute preliminary quantities needed for the static and feedback control portions of the algorithm. +!! -# Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!! -# Calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux. +!! -# For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!! \section detailed Detailed Algorithm +!! @{ + subroutine shalcnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql, & + & q1,t1,u1,v1,rn,kbot,ktop,kcnv,islimsk, & + & dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,cnvw,cnvc, & +! & q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,islimsk, +! & dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,me) + & clam,c0,c1,pgcon) +! + use machine , only : kind_phys + use funcphys , only : fpvs + use physcons, grav => con_g, cp => con_cp, hvap => con_hvap & + &, rv => con_rv, fv => con_fvirt, t0c => con_t0c & + &, rd => con_rd, cvap => con_cvap, cliq => con_cliq & + &, eps => con_eps, epsm1 => con_epsm1 + implicit none +! + integer im, ix, km, jcap, ncloud, & + & kbot(im), ktop(im), kcnv(im) +! &, me + real(kind=kind_phys) delt + real(kind=kind_phys) psp(im), delp(ix,km), prslp(ix,km) + real(kind=kind_phys) ps(im), del(ix,km), prsl(ix,km), & + & ql(ix,km,2),q1(ix,km), t1(ix,km), & + & u1(ix,km), v1(ix,km), & + & rn(im), & + & dot(ix,km), phil(ix,km), hpbl(im), & + & heat(im), evap(im), cnvw(ix,km), & + & cnvc(ix,km), & + & ud_mf(im,km),dt_mf(im,km) +! + integer i,j,indx, k, kk, km1 + integer kpbl(im) + integer, dimension(im), intent(in) :: islimsk +! + real(kind=kind_phys) c0, dellat, delta, + & desdt, + & dp, + & dq, dqsdp, dqsdt, dt, + & dt2, dtmax, dtmin, dv1h, + & dv1q, dv2h, dv2q, dv1u, + & dv1v, dv2u, dv2v, dv3q, + & dv3h, dv3u, dv3v, clam, + & dz, dz1, e1, + & el2orc, elocp, aafac, + & es, etah, h1, dthk, + & evef, evfact, evfactl, fact1, + & fact2, factor, fjcap, + & g, gamma, pprime, betaw, + & qlk, qrch, qs, c1, + & rfact, shear, tem1, + & val, val1, + & val2, w1, w1l, w1s, + & w2, w2l, w2s, w3, + & w3l, w3s, w4, w4l, + & w4s, tem, ptem, ptem1, + & pgcon +! + integer kb(im), kbcon(im), kbcon1(im), + & ktcon(im), ktcon1(im), + & kbm(im), kmax(im) +! + real(kind=kind_phys) aa1(im), + & delhbar(im), delq(im), delq2(im), + & delqbar(im), delqev(im), deltbar(im), + & deltv(im), edt(im), + & wstar(im), sflx(im), + & pdot(im), po(im,km), + & qcond(im), qevap(im), hmax(im), + & rntot(im), vshear(im), + & xlamud(im), xmb(im), xmbmax(im), + & delubar(im), delvbar(im) +c + real(kind=kind_phys) cincr, cincrmax, cincrmin +cc +c physical parameters + parameter(g=grav) + parameter(elocp=hvap/cp, + & el2orc=hvap*hvap/(rv*cp)) +! parameter(c0=.002,c1=5.e-4,delta=fv) + parameter(delta=fv) + parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c) + parameter(cincrmax=180.,cincrmin=120.,dthk=25.) + parameter(h1=0.33333333) +c local variables and arrays + real(kind=kind_phys) pfld(im,km), to(im,km), qo(im,km), + & uo(im,km), vo(im,km), qeso(im,km) +c cloud water +! real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km), + real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), + & dbyo(im,km), zo(im,km), xlamue(im,km), + & heo(im,km), heso(im,km), + & dellah(im,km), dellaq(im,km), + & dellau(im,km), dellav(im,km), hcko(im,km), + & ucko(im,km), vcko(im,km), qcko(im,km), + & qrcko(im,km), eta(im,km), + & zi(im,km), pwo(im,km), + & tx1(im), cnvwt(im,km) +! + logical totflg, cnvflg(im), flg(im) +! + real(kind=kind_phys) tf, tcr, tcrf + parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +! +c----------------------------------------------------------------------- +! +!************************************************************************ +! convert input pa terms to cb terms -- moorthi +!> ## Compute preliminary quantities needed for the static and feedback control portions of the algorithm. +!> - Convert input pressure terms to centibar units. + ps = psp * 0.001 + prsl = prslp * 0.001 + del = delp * 0.001 +!************************************************************************ +! + km1 = km - 1 +c +c compute surface buoyancy flux +c +!> - Compute the surface buoyancy flux according to +!! \f[ +!! \overline{w'\theta_v'}=\overline{w'\theta'}+\left(\frac{R_v}{R_d}-1\right)T_0\overline{w'q'} +!! \f] +!! where \f$\overline{w'\theta'}\f$ is the surface sensible heat flux, \f$\overline{w'q'}\f$ is the surface latent heat flux, \f$R_v\f$ is the gas constant for water vapor, \f$R_d\f$ is the gas constant for dry air, and \f$T_0\f$ is a reference temperature. + do i=1,im + sflx(i) = heat(i)+fv*t1(i,1)*evap(i) + enddo +c +c initialize arrays +c +!> - Initialize column-integrated and other single-value-per-column variable arrays. + do i=1,im + cnvflg(i) = .true. + if(kcnv(i).eq.1) cnvflg(i) = .false. + if(sflx(i).le.0.) cnvflg(i) = .false. + if(cnvflg(i)) then + kbot(i)=km+1 + ktop(i)=0 + endif + rn(i)=0. + kbcon(i)=km + ktcon(i)=1 + kb(i)=km + pdot(i) = 0. + qlko_ktcon(i) = 0. + edt(i) = 0. + aa1(i) = 0. + vshear(i) = 0. + enddo +!> - Initialize updraft and detrainment mass fluxes to zero. +! hchuang code change + do k = 1, km + do i = 1, im + ud_mf(i,k) = 0. + dt_mf(i,k) = 0. + enddo + enddo +!! +!> - Return to the calling routine if deep convection is present or the surface buoyancy flux is negative. + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +!> - Define tunable parameters. + dt2 = delt + val = 1200. + dtmin = max(dt2, val ) + val = 3600. + dtmax = max(dt2, val ) +c model tunable parameters are all here +! clam = .3 + aafac = .1 + betaw = .03 +c evef = 0.07 + evfact = 0.3 + evfactl = 0.3 +! +! pgcon = 0.7 ! gregory et al. (1997, qjrms) +! pgcon = 0.55 ! zhang & wu (2003,jas) + fjcap = (float(jcap) / 126.) ** 2 + val = 1. + fjcap = max(fjcap,val) + w1l = -8.e-3 + w2l = -4.e-2 + w3l = -5.e-3 + w4l = -5.e-4 + w1s = -2.e-4 + w2s = -2.e-3 + w3s = -1.e-3 + w4s = -2.e-5 +c +c define top layer for search of the downdraft originating layer +c and the maximum thetae for updraft +c +!> - Determine maximum indices for the parcel starting point (kbm) and cloud top (kmax). + do i=1,im + kbm(i) = km + kmax(i) = km + tx1(i) = 1.0 / ps(i) + enddo +! + do k = 1, km + do i=1,im + if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i) = k + 1 + if (prsl(i,k)*tx1(i) .gt. 0.60) kmax(i) = k + 1 + enddo + enddo + do i=1,im + kbm(i) = min(kbm(i),kmax(i)) + enddo +c +c hydrostatic height assume zero terr and compute +c updraft entrainment rate as an inverse function of height +c +!> - Calculate hydrostatic height at layer centers assuming a flat surface (no terrain) from the geopotential. + do k = 1, km + do i=1,im + zo(i,k) = phil(i,k) / g + enddo + enddo +!> - Calculate interface height and the entrainment rate as an inverse function of height. + do k = 1, km1 + do i=1,im + zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1)) + xlamue(i,k) = clam / zi(i,k) + enddo + enddo + do i=1,im + xlamue(i,km) = xlamue(i,km1) + enddo +c +c pbl height +c +!> - Find the index for the PBL top using the PBL height; enforce that it is lower than the maximum parcel starting level. + do i=1,im + flg(i) = cnvflg(i) + kpbl(i)= 1 + enddo + do k = 2, km1 + do i=1,im + if (flg(i).and.zo(i,k).le.hpbl(i)) then + kpbl(i) = k + else + flg(i) = .false. + endif + enddo + enddo + do i=1,im + kpbl(i)= min(kpbl(i),kbm(i)) + enddo +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c convert surface pressure to mb from cb +c +!> - Convert prsl from centibar to millibar, set normalized mass flux to 1, cloud properties to 0, and save model state variables (after advection/turbulence). + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)) then + pfld(i,k) = prsl(i,k) * 10.0 + eta(i,k) = 1. + hcko(i,k) = 0. + qcko(i,k) = 0. + qrcko(i,k)= 0. + ucko(i,k) = 0. + vcko(i,k) = 0. + dbyo(i,k) = 0. + pwo(i,k) = 0. + dellal(i,k) = 0. + to(i,k) = t1(i,k) + qo(i,k) = q1(i,k) + uo(i,k) = u1(i,k) + vo(i,k) = v1(i,k) +! uo(i,k) = u1(i,k) * rcs(i) +! vo(i,k) = v1(i,k) * rcs(i) + cnvwt(i,k) = 0. + endif + enddo + enddo +c +c column variables +c p is pressure of the layer (mb) +c t is temperature at t-dt (k)..tn +c q is mixing ratio at t-dt (kg/kg)..qn +c to is temperature at t+dt (k)... this is after advection and turbulan +c qo is mixing ratio at t+dt (kg/kg)..q1 +c +!> - Calculate saturation mixing ratio and enforce minimum moisture values. + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k .le. kmax(i)) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) +! tvo(i,k) = to(i,k) + delta * to(i,k) * qo(i,k) + endif + enddo + enddo +c +c compute moist static energy +c +!> - Calculate moist static energy (heo) and saturation moist static energy (heso). + do k = 1, km + do i=1,im + if (cnvflg(i) .and. k .le. kmax(i)) then +! tem = g * zo(i,k) + cp * to(i,k) + tem = phil(i,k) + cp * to(i,k) + heo(i,k) = tem + hvap * qo(i,k) + heso(i,k) = tem + hvap * qeso(i,k) +c heo(i,k) = min(heo(i,k),heso(i,k)) + endif + enddo + enddo +c +c determine level with largest moist static energy within pbl +c this is the level where updraft starts +c +!> ## Perform calculations related to the updraft of the entraining/detraining cloud model ("static control"). +!> - Search in the PBL for the level of maximum moist static energy to start the ascending parcel. + do i=1,im + if (cnvflg(i)) then + hmax(i) = heo(i,1) + kb(i) = 1 + endif + enddo + do k = 2, km + do i=1,im + if (cnvflg(i).and.k.le.kpbl(i)) then + if(heo(i,k).gt.hmax(i)) then + kb(i) = k + hmax(i) = heo(i,k) + endif + endif + enddo + enddo +c +!> - Calculate the temperature, water vapor mixing ratio, and pressure at interface levels. + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k .le. kmax(i)-1) then + dz = .5 * (zo(i,k+1) - zo(i,k)) + dp = .5 * (pfld(i,k+1) - pfld(i,k)) + es = 0.01 * fpvs(to(i,k+1)) ! fpvs is in pa + pprime = pfld(i,k+1) + epsm1 * es + qs = eps * es / pprime + dqsdp = - qs / pprime + desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2)) + dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime) + gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2) + dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma)) + dq = dqsdt * dt + dqsdp * dp + to(i,k) = to(i,k+1) + dt + qo(i,k) = qo(i,k+1) + dq + po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1)) + endif + enddo + enddo +! +!> - Recalculate saturation mixing ratio, moist static energy, saturation moist static energy, and horizontal momentum on interface levels. Enforce minimum mixing ratios. + do k = 1, km1 + do i=1,im + if (cnvflg(i) .and. k .le. kmax(i)-1) then + qeso(i,k) = 0.01 * fpvs(to(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k)) + val1 = 1.e-8 + qeso(i,k) = max(qeso(i,k), val1) + val2 = 1.e-10 + qo(i,k) = max(qo(i,k), val2 ) +! qo(i,k) = min(qo(i,k),qeso(i,k)) + heo(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qo(i,k) + heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) + + & cp * to(i,k) + hvap * qeso(i,k) + uo(i,k) = .5 * (uo(i,k) + uo(i,k+1)) + vo(i,k) = .5 * (vo(i,k) + vo(i,k+1)) + endif + enddo + enddo +c +c look for the level of free convection as cloud base +c!> - Search below the index "kbm" for the level of free convection (LFC) where the condition \f$h_b > h^*\f$ is first met, where \f$h_b, h^*\f$ are the state moist static energy at the parcel's starting level and saturation moist static energy, respectively. Set "kbcon" to the index of the LFC. + do i=1,im + flg(i) = cnvflg(i) + if(flg(i)) kbcon(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i).and.k.lt.kbm(i)) then + if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then + kbcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c +!> - If no LFC, return to the calling routine without modifying state variables. + do i=1,im + if(cnvflg(i)) then + if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false. + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine critical convective inhibition +c as a function of vertical velocity at cloud base. +c +!> - Determine the vertical pressure velocity at the LFC. After Han and Pan (2011) \cite han_and_pan_2011 , determine the maximum pressure thickness between a parcel's starting level and the LFC. If a parcel doesn't reach the LFC within the critical thickness, then the convective inhibition is deemed too great for convection to be triggered, and the subroutine returns to the calling routine without modifying the state variables. + do i=1,im + if(cnvflg(i)) then +! pdot(i) = 10.* dot(i,kbcon(i)) + pdot(i) = 0.01 * dot(i,kbcon(i)) ! now dot is in pa/s + endif + enddo + do i=1,im + if(cnvflg(i)) then + if(islimsk(i) == 1) then + w1 = w1l + w2 = w2l + w3 = w3l + w4 = w4l + else + w1 = w1s + w2 = w2s + w3 = w3s + w4 = w4s + endif + if(pdot(i).le.w4) then + ptem = (pdot(i) - w4) / (w3 - w4) + elseif(pdot(i).ge.-w4) then + ptem = - (pdot(i) + w4) / (w4 - w3) + else + ptem = 0. + endif + val1 = -1. + ptem = max(ptem,val1) + val2 = 1. + ptem = min(ptem,val2) + ptem = 1. - ptem + ptem1= .5*(cincrmax-cincrmin) + cincr = cincrmax - ptem * ptem1 + tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i)) + if(tem1.gt.cincr) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c assume the detrainment rate for the updrafts to be same as +c the entrainment rate at cloud base +c +!> - The updraft detrainment rate is set constant and equal to the entrainment rate at cloud base. + do i = 1, im + if(cnvflg(i)) then + xlamud(i) = xlamue(i,kbcon(i)) + endif + enddo +c +c determine updraft mass flux for the subcloud layers +c +!> - Calculate the normalized mass flux for subcloud and in-cloud layers according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 1: +!! \f[ +!! \frac{1}{\eta}\frac{\partial \eta}{\partial z} = \lambda_e - \lambda_d +!! \f] +!! where \f$\eta\f$ is the normalized mass flux, \f$\lambda_e\f$ is the entrainment rate and \f$\lambda_d\f$ is the detrainment rate. The normalized mass flux increases upward below the cloud base and decreases upward above. + do k = km1, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k.lt.kbcon(i).and.k.ge.kb(i)) then + dz = zi(i,k+1) - zi(i,k) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i) + eta(i,k) = eta(i,k+1) / (1. + ptem * dz) + endif + endif + enddo + enddo +c +c compute mass flux above cloud base +c + do k = 2, km1 + do i = 1, im + if(cnvflg(i))then + if(k.gt.kbcon(i).and.k.lt.kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + ptem = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i) + eta(i,k) = eta(i,k-1) * (1 + ptem * dz) + endif + endif + enddo + enddo +c +c compute updraft cloud property +c +!> - Set initial cloud properties equal to the state variables at cloud base. + do i = 1, im + if(cnvflg(i)) then + indx = kb(i) + hcko(i,indx) = heo(i,indx) + ucko(i,indx) = uo(i,indx) + vcko(i,indx) = vo(i,indx) + endif + enddo +c +!> - Calculate the cloud properties as a parcel ascends, modified by entrainment and detrainment. Discretization follows Appendix B of Grell (1993) \cite grell_1993 . Following Han and Pan (2006) \cite han_and_pan_2006, the convective momentum transport is reduced by the convection-induced pressure gradient force by the constant "pgcon", currently set to 0.55 after Zhang and Wu (2003) \cite zhang_and_wu_2003 . + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.lt.kmax(i)) then + dz = zi(i,k) - zi(i,k-1) + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + ptem = 0.5 * tem + pgcon + ptem1= 0.5 * tem - pgcon + hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5* + & (heo(i,k)+heo(i,k-1)))/factor + ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k) + & +ptem1*uo(i,k-1))/factor + vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k) + & +ptem1*vo(i,k-1))/factor + dbyo(i,k) = hcko(i,k) - heso(i,k) + endif + endif + enddo + enddo +c +c taking account into convection inhibition due to existence of +c dry layers below cloud base +c +!> - With entrainment, recalculate the LFC as the first level where buoyancy is positive. The difference in pressure levels between LFCs calculated with/without entrainment must be less than a threshold (currently 25 hPa). Otherwise, convection is inhibited and the scheme returns to the calling routine without modifying the state variables. This is the subcloud dryness trigger modification discussed in Han and Pan (2011) \cite han_and_pan_2011. + do i=1,im + flg(i) = cnvflg(i) + kbcon1(i) = kmax(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i).and.k.lt.kbm(i)) then + if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then + kbcon1(i) = k + flg(i) = .false. + endif + endif + enddo + enddo + do i=1,im + if(cnvflg(i)) then + if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false. + endif + enddo + do i=1,im + if(cnvflg(i)) then + tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i)) + if(tem.gt.dthk) then + cnvflg(i) = .false. + endif + endif + enddo +!! + totflg = .true. + do i = 1, im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c determine first guess cloud top as the level of zero buoyancy +c limited to the level of sigma=0.7 +c +!> - Calculate the cloud top as the first level where parcel buoyancy becomes negative; the maximum possible value is at \f$p=0.7p_{sfc}\f$. + do i = 1, im + flg(i) = cnvflg(i) + if(flg(i)) ktcon(i) = kbm(i) + enddo + do k = 2, km1 + do i=1,im + if (flg(i).and.k .lt. kbm(i)) then + if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then + ktcon(i) = k + flg(i) = .false. + endif + endif + enddo + enddo +c +c turn off shallow convection if cloud top is less than pbl top +c +! do i=1,im +! if(cnvflg(i)) then +! kk = kpbl(i)+1 +! if(ktcon(i).le.kk) cnvflg(i) = .false. +! endif +! enddo +!! +! totflg = .true. +! do i = 1, im +! totflg = totflg .and. (.not. cnvflg(i)) +! enddo +! if(totflg) return +!! +c +c specify upper limit of mass flux at cloud base +c +!> - Calculate the maximum value of the cloud base mass flux using the CFL-criterion-based formula of Han and Pan (2011) \cite han_and_pan_2011, equation 7. + do i = 1, im + if(cnvflg(i)) then +! xmbmax(i) = .1 +! + k = kbcon(i) + dp = 1000. * del(i,k) + xmbmax(i) = dp / (g * dt2) +! +! tem = dp / (g * dt2) +! xmbmax(i) = min(tem, xmbmax(i)) + endif + enddo +c +c compute cloud moisture property and precipitation +c +!> - Initialize the cloud moisture at cloud base and set the cloud work function to zero. + do i = 1, im + if (cnvflg(i)) then + aa1(i) = 0. + qcko(i,kb(i)) = qo(i,kb(i)) + qrcko(i,kb(i)) = qo(i,kb(i)) + endif + enddo +!> - Calculate the moisture content of the entraining/detraining parcel (qcko) and the value it would have if just saturated (qrch), according to equation A.14 in Grell (1993) \cite grell_1993 . Their difference is the amount of convective cloud water (qlk = rain + condensate). Determine the portion of convective cloud water that remains suspended and the portion that is converted into convective precipitation (pwo). Calculate and save the negative cloud work function (aa1) due to water loading. Above the level of minimum moist static energy, some of the cloud water is detrained into the grid-scale cloud water from every cloud layer with a rate of 0.0005 \f$m^{-1}\f$ (dellal). + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.lt.ktcon(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +! rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k) +c +c below lfc check if there is excess moisture to release latent heat +c + if(k.ge.kbcon(i).and.dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + if(ncloud.gt.0.) then + dp = 1000. * del(i,k) + qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0 * dz) + endif + aa1(i) = aa1(i) - dz * g * qlk + qcko(i,k)= qlk + qrch + pwo(i,k) = etah * c0 * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +c +c calculate cloud work function +c +!> - Calculate the cloud work function according to Pan and Wu (1995) \cite pan_and_wu_1995 equation 4: +!! \f[ +!! A_u=\int_{z_0}^{z_t}\frac{g}{c_pT(z)}\frac{\eta}{1 + \gamma}[h(z)-h^*(z)]dz +!! \f] +!! (discretized according to Grell (1993) \cite grell_1993 equation B.10 using B.2 and B.3 of Arakawa and Schubert (1974) \cite arakawa_and_schubert_1974 and assuming \f$\eta=1\f$) where \f$A_u\f$ is the updraft cloud work function, \f$z_0\f$ and \f$z_t\f$ are cloud base and cloud top, respectively, \f$\gamma = \frac{L}{c_p}\left(\frac{\partial \overline{q_s}}{\partial T}\right)_p\f$ and other quantities are previously defined. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa1(i) = aa1(i) + + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + val = 0. + aa1(i)=aa1(i)+ + & dz1 * g * delta * + & max(val,(qeso(i,k) - qo(i,k))) + endif + endif + enddo + enddo +!> - If the updraft cloud work function is negative, convection does not occur, and the scheme returns to the calling routine. + do i = 1, im + if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false. + enddo +!! + totflg = .true. + do i=1,im + totflg = totflg .and. (.not. cnvflg(i)) + enddo + if(totflg) return +!! +c +c estimate the onvective overshooting as the level +c where the [aafac * cloud work function] becomes zero, +c which is the final cloud top +c limited to the level of sigma=0.7 +c +!> - Continue calculating the cloud work function past the point of neutral buoyancy to represent overshooting according to Han and Pan (2011) \cite han_and_pan_2011 . Convective overshooting stops when \f$ cA_u < 0\f$ where \f$c\f$ is currently 10%, or when 10% of the updraft cloud work function has been consumed by the stable buoyancy force. Overshooting is also limited to the level where \f$p=0.7p_{sfc}\f$. + do i = 1, im + if (cnvflg(i)) then + aa1(i) = aafac * aa1(i) + endif + enddo +c + do i = 1, im + flg(i) = cnvflg(i) + ktcon1(i) = kbm(i) + enddo + do k = 2, km1 + do i = 1, im + if (flg(i)) then + if(k.ge.ktcon(i).and.k.lt.kbm(i)) then + dz1 = zo(i,k+1) - zo(i,k) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + rfact = 1. + delta * cp * gamma + & * to(i,k) / hvap + aa1(i) = aa1(i) + + & dz1 * (g / (cp * to(i,k))) + & * dbyo(i,k) / (1. + gamma) + & * rfact + if(aa1(i).lt.0.) then + ktcon1(i) = k + flg(i) = .false. + endif + endif + endif + enddo + enddo +c +c compute cloud moisture property, detraining cloud water +c and precipitation in overshooting layers +c +!> - For the overshooting convection, calculate the moisture content of the entraining/detraining parcel as before. Partition convective cloud water and precipitation and detrain convective cloud water in the overshooting layers. + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then + dz = zi(i,k) - zi(i,k-1) + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) +cj + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz + tem1 = 0.5 * xlamud(i) * dz + factor = 1. + tem - tem1 + qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5* + & (qo(i,k)+qo(i,k-1)))/factor + qrcko(i,k) = qcko(i,k) +cj + dq = eta(i,k) * (qcko(i,k) - qrch) +c +c check if there is excess moisture to release latent heat +c + if(dq.gt.0.) then + etah = .5 * (eta(i,k) + eta(i,k-1)) + if(ncloud.gt.0.) then + dp = 1000. * del(i,k) + qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz) + dellal(i,k) = etah * c1 * dz * qlk * g / dp + else + qlk = dq / (eta(i,k) + etah * c0 * dz) + endif + qcko(i,k) = qlk + qrch + pwo(i,k) = etah * c0 * dz * qlk + cnvwt(i,k) = etah * qlk * g / dp + endif + endif + endif + enddo + enddo +c +c exchange ktcon with ktcon1 +c + do i = 1, im + if(cnvflg(i)) then + kk = ktcon(i) + ktcon(i) = ktcon1(i) + ktcon1(i) = kk + endif + enddo +c +c this section is ready for cloud water +c + if(ncloud.gt.0) then +c +c compute liquid and vapor separation at cloud top +c +!> - => Separate the total updraft cloud water at cloud top into vapor and condensate. + do i = 1, im + if(cnvflg(i)) then + k = ktcon(i) - 1 + gamma = el2orc * qeso(i,k) / (to(i,k)**2) + qrch = qeso(i,k) + & + gamma * dbyo(i,k) / (hvap * (1. + gamma)) + dq = qcko(i,k) - qrch +c +c check if there is excess moisture to release latent heat +c + if(dq.gt.0.) then + qlko_ktcon(i) = dq + qcko(i,k) = qrch + endif + endif + enddo + endif +c +c--- compute precipitation efficiency in terms of windshear +c +!! - Calculate the wind shear and precipitation efficiency according to equation 58 in Fritsch and Chappell (1980) \cite fritsch_and_chappell_1980 : +!! \f[ +!! E = 1.591 - 0.639\frac{\Delta V}{\Delta z} + 0.0953\left(\frac{\Delta V}{\Delta z}\right)^2 - 0.00496\left(\frac{\Delta V}{\Delta z}\right)^3 +!! \f] +!! where \f$\Delta V\f$ is the integrated horizontal shear over the cloud depth, \f$\Delta z\f$, (the ratio is converted to units of \f$10^{-3} s^{-1}\f$). The variable "edt" is \f$1-E\f$ and is constrained to the range \f$[0,0.9]\f$. + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 0. + endif + enddo + do k = 2, km + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.le.ktcon(i)) then + shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + & + (vo(i,k)-vo(i,k-1)) ** 2) + vshear(i) = vshear(i) + shear + endif + endif + enddo + enddo + do i = 1, im + if(cnvflg(i)) then + vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i))) + e1=1.591-.639*vshear(i) + & +.0953*(vshear(i)**2)-.00496*(vshear(i)**3) + edt(i)=1.-e1 + val = .9 + edt(i) = min(edt(i),val) + val = .0 + edt(i) = max(edt(i),val) + endif + enddo +c +c--- what would the change be, that a cloud with unit mass +c--- will do to the environment? +c +!> ## Calculate the tendencies of the state variables (per unit cloud base mass flux) and the cloud base mass flux. +!> - Calculate the change in moist static energy, moisture mixing ratio, and horizontal winds per unit cloud base mass flux for all layers below cloud top from equations B.14 and B.15 from Grell (1993) \cite grell_1993, and for the cloud top from B.16 and B.17. + do k = 1, km + do i = 1, im + if(cnvflg(i) .and. k .le. kmax(i)) then + dellah(i,k) = 0. + dellaq(i,k) = 0. + dellau(i,k) = 0. + dellav(i,k) = 0. + endif + enddo + enddo +c +c--- changed due to subsidence and entrainment +c + do k = 2, km1 + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.lt.ktcon(i)) then + dp = 1000. * del(i,k) + dz = zi(i,k) - zi(i,k-1) +c + dv1h = heo(i,k) + dv2h = .5 * (heo(i,k) + heo(i,k-1)) + dv3h = heo(i,k-1) + dv1q = qo(i,k) + dv2q = .5 * (qo(i,k) + qo(i,k-1)) + dv3q = qo(i,k-1) + dv1u = uo(i,k) + dv2u = .5 * (uo(i,k) + uo(i,k-1)) + dv3u = uo(i,k-1) + dv1v = vo(i,k) + dv2v = .5 * (vo(i,k) + vo(i,k-1)) + dv3v = vo(i,k-1) +c + tem = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) + tem1 = xlamud(i) +cj + dellah(i,k) = dellah(i,k) + + & ( eta(i,k)*dv1h - eta(i,k-1)*dv3h + & - tem*eta(i,k-1)*dv2h*dz + & + tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz + & ) *g/dp +cj + dellaq(i,k) = dellaq(i,k) + + & ( eta(i,k)*dv1q - eta(i,k-1)*dv3q + & - tem*eta(i,k-1)*dv2q*dz + & + tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz + & ) *g/dp +cj + dellau(i,k) = dellau(i,k) + + & ( eta(i,k)*dv1u - eta(i,k-1)*dv3u + & - tem*eta(i,k-1)*dv2u*dz + & + tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz + & - pgcon*eta(i,k-1)*(dv1u-dv3u) + & ) *g/dp +cj + dellav(i,k) = dellav(i,k) + + & ( eta(i,k)*dv1v - eta(i,k-1)*dv3v + & - tem*eta(i,k-1)*dv2v*dz + & + tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz + & - pgcon*eta(i,k-1)*(dv1v-dv3v) + & ) *g/dp +cj + endif + endif + enddo + enddo +c +c------- cloud top +c + do i = 1, im + if(cnvflg(i)) then + indx = ktcon(i) + dp = 1000. * del(i,indx) + dv1h = heo(i,indx-1) + dellah(i,indx) = eta(i,indx-1) * + & (hcko(i,indx-1) - dv1h) * g / dp + dv1q = qo(i,indx-1) + dellaq(i,indx) = eta(i,indx-1) * + & (qcko(i,indx-1) - dv1q) * g / dp + dv1u = uo(i,indx-1) + dellau(i,indx) = eta(i,indx-1) * + & (ucko(i,indx-1) - dv1u) * g / dp + dv1v = vo(i,indx-1) + dellav(i,indx) = eta(i,indx-1) * + & (vcko(i,indx-1) - dv1v) * g / dp +c +c cloud water +c + dellal(i,indx) = eta(i,indx-1) * + & qlko_ktcon(i) * g / dp + endif + enddo +c +c mass flux at cloud base for shallow convection +c (grant, 2001) +c +!> - Calculate the cloud base mass flux according to equation 6 in Grant (2001) \cite grant_2001, based on the subcloud layer convective velocity scale, \f$w_*\f$. +!! \f[ +!! M_c = 0.03\rho w_* +!! \f] +!! where \f$M_c\f$ is the cloud base mass flux, \f$\rho\f$ is the air density, and \f$w_*=\left(\frac{g}{T_0}\overline{w'\theta_v'}h\right)^{1/3}\f$ with \f$h\f$ the PBL height and other quantities have been defined previously. + do i= 1, im + if(cnvflg(i)) then + k = kbcon(i) +! ptem = g*sflx(i)*zi(i,k)/t1(i,1) + ptem = g*sflx(i)*hpbl(i)/t1(i,1) + wstar(i) = ptem**h1 + tem = po(i,k)*100. / (rd*t1(i,k)) + xmb(i) = betaw*tem*wstar(i) + xmb(i) = min(xmb(i),xmbmax(i)) + endif + enddo +!> ## For the "feedback control", calculate updated values of the state variables by multiplying the cloud base mass flux and the tendencies calculated per unit cloud base mass flux from the static control. +!! - Recalculate saturation specific humidity. +c +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. k .le. kmax(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + enddo + enddo +c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +c +!> - Calculate the temperature tendency from the moist static energy and specific humidity tendencies. +!> - Update the temperature, specific humidity, and horiztonal wind state variables by multiplying the cloud base mass flux-normalized tendencies by the cloud base mass flux. +!> - Accumulate column-integrated tendencies. + do i = 1, im + delhbar(i) = 0. + delqbar(i) = 0. + deltbar(i) = 0. + delubar(i) = 0. + delvbar(i) = 0. + qcond(i) = 0. + enddo + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.le.ktcon(i)) then + dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp + t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2 + q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2 +! tem = 1./rcs(i) +! u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem +! v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem + u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 + v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 + dp = 1000. * del(i,k) + delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g + delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g + deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g + delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g + delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g + endif + endif + enddo + enddo +!> - Recalculate saturation specific humidity using the updated temperature. + do k = 1, km + do i = 1, im + if (cnvflg(i)) then + if(k.gt.kb(i).and.k.le.ktcon(i)) then + qeso(i,k) = 0.01 * fpvs(t1(i,k)) ! fpvs is in pa + qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k)) + val = 1.e-8 + qeso(i,k) = max(qeso(i,k), val ) + endif + endif + enddo + enddo +c +!> - Add up column-integrated convective precipitation by multiplying the normalized value by the cloud base mass flux. + do i = 1, im + rntot(i) = 0. + delqev(i) = 0. + delq2(i) = 0. + flg(i) = cnvflg(i) + enddo + do k = km, 1, -1 + do i = 1, im + if (cnvflg(i)) then + if(k.lt.ktcon(i).and.k.gt.kb(i)) then + rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + enddo + enddo +c +c evaporating rain +c +!> - Determine the evaporation of the convective precipitation and update the integrated convective precipitation. +!> - Update state temperature and moisture to account for evaporation of convective precipitation. +!> - Update column-integrated tendencies to account for evaporation of convective precipitation. + do k = km, 1, -1 + do i = 1, im + if (k .le. kmax(i)) then + deltv(i) = 0. + delq(i) = 0. + qevap(i) = 0. + if(cnvflg(i)) then + if(k.lt.ktcon(i).and.k.gt.kb(i)) then + rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2 + endif + endif + if(flg(i).and.k.lt.ktcon(i)) then + evef = edt(i) * evfact + if(islimsk(i) == 1) evef=edt(i) * evfactl +! if(islimsk(i) == 1) evef=.07 +c if(islimsk(i) == 1) evef = 0. + qcond(i) = evef * (q1(i,k) - qeso(i,k)) + & / (1. + el2orc * qeso(i,k) / t1(i,k)**2) + dp = 1000. * del(i,k) + if(rn(i).gt.0..and.qcond(i).lt.0.) then + qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i)))) + qevap(i) = min(qevap(i), rn(i)*1000.*g/dp) + delq2(i) = delqev(i) + .001 * qevap(i) * dp / g + endif + if(rn(i).gt.0..and.qcond(i).lt.0..and. + & delq2(i).gt.rntot(i)) then + qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp + flg(i) = .false. + endif + if(rn(i).gt.0..and.qevap(i).gt.0.) then + tem = .001 * dp / g + tem1 = qevap(i) * tem + if(tem1.gt.rn(i)) then + qevap(i) = rn(i) / tem + rn(i) = 0. + else + rn(i) = rn(i) - tem1 + endif + q1(i,k) = q1(i,k) + qevap(i) + t1(i,k) = t1(i,k) - elocp * qevap(i) + deltv(i) = - elocp*qevap(i)/dt2 + delq(i) = + qevap(i)/dt2 + delqev(i) = delqev(i) + .001*dp*qevap(i)/g + endif + dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i) + delqbar(i) = delqbar(i) + delq(i)*dp/g + deltbar(i) = deltbar(i) + deltv(i)*dp/g + endif + endif + enddo + enddo +cj +! do i = 1, im +! if(me.eq.31.and.cnvflg(i)) then +! if(cnvflg(i)) then +! print *, ' shallow delhbar, delqbar, deltbar = ', +! & delhbar(i),hvap*delqbar(i),cp*deltbar(i) +! print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i) +! print *, ' precip =', hvap*rn(i)*1000./dt2 +! print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i)) +! endif +! enddo +cj + do i = 1, im + if(cnvflg(i)) then + if(rn(i).lt.0..or..not.flg(i)) rn(i) = 0. + ktop(i) = ktcon(i) + kbot(i) = kbcon(i) + kcnv(i) = 0 + endif + enddo +c +c convective cloud water +c +!> - Calculate shallow convective cloud water. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then + cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo + +c +c convective cloud cover +c +!> - Calculate shallow convective cloud cover. + do k = 1, km + do i = 1, im + if (cnvflg(i) .and. rn(i).gt.0.) then + if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then + cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) + cnvc(i,k) = min(cnvc(i,k), 0.2) + cnvc(i,k) = max(cnvc(i,k), 0.0) + endif + endif + enddo + enddo + +c +c cloud water +c +!> - Separate detrained cloud water into liquid and ice species as a function of temperature only. + if (ncloud.gt.0) then +! + do k = 1, km1 + do i = 1, im + if (cnvflg(i)) then + if (k.gt.kb(i).and.k.le.ktcon(i)) then + tem = dellal(i,k) * xmb(i) * dt2 + tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf)) + if (ql(i,k,2) .gt. -999.0) then + ql(i,k,1) = ql(i,k,1) + tem * tem1 ! ice + ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1) ! water + else + ql(i,k,1) = ql(i,k,1) + tem + endif + endif + endif + enddo + enddo +! + endif +! +! hchuang code change +! +!> - Calculate the updraft shallow convective mass flux. + do k = 1, km + do i = 1, im + if(cnvflg(i)) then + if(k.ge.kb(i) .and. k.lt.ktop(i)) then + ud_mf(i,k) = eta(i,k) * xmb(i) * dt2 + endif + endif + enddo + enddo +!> - Calculate the detrainment mass flux at shallow cloud top. + do i = 1, im + if(cnvflg(i)) then + k = ktop(i)-1 + dt_mf(i,k) = ud_mf(i,k) + endif + enddo +!! + return + end +!> @} +!! @} diff --git a/gsmphys/shalcv.f b/gsmphys/shalcv.f new file mode 100644 index 00000000..0756628a --- /dev/null +++ b/gsmphys/shalcv.f @@ -0,0 +1,205 @@ + SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,kcnv,Q,T,levshc + &, phil, kinver, ctei_r, ctei_rm, lprnt, ipr) +! + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP + &, RD => con_RD + implicit none +! + logical lprnt + integer ipr + integer IM, IX, KM, kcnv(IM), kinver(im), levshc(im) + real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), + & PRSLK(IX,KM), phil(ix,km), + & Q(IX,KM), T(IX,KM), DT + &, ctei_r(im), ctei_rm(im) +! +! Locals +! + real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, + & dsig, dtodsl, dtodsu, eldq, g, + & gocp, rtdls, toppres +! + integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii + integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk + &, KTOPM(IM), kkt +! + PARAMETER(G=GRAV, GOCP=G/CP) ! PHYSICAL PARAMETERS + PARAMETER(KLIFTL=2,KLIFTU=2) ! BOUNDS OF PARCEL ORIGIN + real, parameter :: ctei_dp=2000.0 ! mix over 20 hPa + LOGICAL LSHC(IM), ctei(im) + real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), + & PRSL2(IM*KM), PRSLK2(IM*KM), + & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) +!----------------------------------------------------------------------- +! COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION +! AND MOIST STATIC INSTABILITY. + DO I=1,IM + LSHC(I)=.FALSE. + ENDDO + DO K=1,KM-1 + DO I=1,IM + IF (kcnv(I) == 0) then + ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) + CPDT = CP*(T(I,K)-T(I,K+1)) + DMSE = ELDQ + CPDT + phil(i,k) - phil(i,k+1) + LSHC(I) = LSHC(I) .OR. DMSE > 0.0 + ENDIF + ENDDO + ENDDO + N2 = 0 + DO I=1,IM + IF(LSHC(I)) THEN + N2 = N2 + 1 + INDEX2(N2) = I + ENDIF + ENDDO +! if (lprnt) print *,' in shalcnv N2=',n2,' ipr=',ipr,' im=',im + IF(N2 == 0) RETURN + DO K=1,KM + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + ii = index2(i) + Q2(IK) = Q(II,K) + T2(IK) = T(II,K) + PRSL2(IK) = PRSL(II,K) + PRSLK2(IK) = PRSLK(II,K) + ENDDO + ENDDO +! + do i=1,N2 + ii = index2(i) + ktopm(i) = levshc(ii) + if (ctei_r(ii) > ctei_rm(ii)) then + ctei(i) = .true. + else + ctei(i) = .false. + ktopm(i) = min(ktopm(i),kinver(ii)) + endif +! if (ctei_r(ii) < ctei_rm(ii)) then +! ktopm(i) = min(ktopm(i),kinver(ii)) +! endif +! if (lprnt .and. ii == ipr) print *,' ktopm=',ktopm(i) +! & ,' kinver=',kinver(ii) + enddo +!----------------------------------------------------------------------- +! COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. +! CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. + CALL MSTADBTN(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2,ctei, + & KLCL,KBOT,KTOP,AL,AU,ktopm,lprnt,ipr,index2) +! & KLCL,KBOT,KTOP,AL,AU) + DO I=1,N2 +! if (lprnt .and. index2(i) == ipr) print *,' kbotb=',kbot(i) +! &, ' ktopb=',ktop(i) + if (ktop(i) > kbot(i)) then + KBOT(I) = min(KLCL(I)-1, ktopm(i)-1) +! KTOP(I) = min(KTOP(I)+1, ktopm(i)) + KTOP(I) = min(KTOP(I), ktopm(i)) ! commented on 11/10/09 for test +! ii = index2(i) +! if (ctei_r(ii) >= ctei_rm(ii)) then +! KTOP(I) = min(KTOP(I)+1, ktopm(i)) +! else +! KTOP(I) = min(KTOP(I), ktopm(i)) ! test on 11/11/09 +! endif +! if (ctei_r(ii) >= ctei_rm(ii)) then +! toppres = prsl(ii,ktop(i)) - ctei_dp +! do kk=ktop(i)+1,km-1 +! if (prsl(ii,kk) > toppres) kkt = kk +! enddo +! KTOP(I) = min(KTOP(I)+1, ktopm(i), kkt) +! else +! KTOP(I) = min(KTOP(I), ktopm(i)) +! endif + endif + LSHC(I) = .FALSE. +! if (lprnt .and. index2(i) == ipr) print *,' kbot=',kbot(i) +! &, ' ktop=',ktop(i) + ENDDO + DO K=1,KM-1 + KK = (K-1)*N2 + DO I=1,N2 + IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN + IK = KK + I + IKU = IK + N2 + ELDQ = HVAP * (Q2(IK)-Q2(IKU)) + CPDT = CP * (T2(IK)-T2(IKU)) +! RTDLS = (PRSL2(IK)-PRSL2(IKU)) / +! & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) + RTDLS = phil(index2(i),k+1) - phil(index2(i),k) + DMSE = ELDQ + CPDT - RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + AU(IK) = G/RTDLS + ENDIF + ENDDO + ENDDO + K1=KM+1 + K2=0 + DO I=1,N2 + IF(.NOT.LSHC(I)) THEN + KBOT(I) = KM+1 + KTOP(I) = 0 + ENDIF + K1 = MIN(K1,KBOT(I)) + K2 = MAX(K2,KTOP(I)) + ENDDO + KT = K2-K1+1 + IF(KT.LT.2) RETURN +!----------------------------------------------------------------------- +! SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. +! COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. +! EXPAND FINAL FIELDS. + KK = (K1-1) * N2 + DO I=1,N2 + IK = KK + I + AD(IK) = 1. + ENDDO +! +! DTODSU=DT/DEL(K1) + DO K=K1,K2-1 +! DTODSL=DTODSU +! DTODSU= DT/DEL(K+1) +! DSIG=SL(K)-SL(K+1) + KK = (K-1) * N2 + DO I=1,N2 + ii = index2(i) + DTODSL = DT/DEL(II,K) + DTODSU = DT/DEL(II,K+1) + DSIG = PRSL(II,K) - PRSL(II,K+1) + IK = KK + I + IKU = IK + N2 + IF(K.EQ.KBOT(I)) THEN + CK=1.5 + ELSEIF(K.EQ.KTOP(I)-1) THEN + CK=1. + ELSEIF(K.EQ.KTOP(I)-2) THEN + CK=3. + ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN + CK=5. + ELSE + CK=0. + ENDIF + DSDZ1 = CK*DSIG*AU(IK)*GOCP + DSDZ2 = CK*DSIG*AU(IK)*AU(IK) + AU(IK) = -DTODSL*DSDZ2 + AL(IK) = -DTODSU*DSDZ2 + AD(IK) = AD(IK)-AU(IK) + AD(IKU) = 1.-AL(IK) + T2(IK) = T2(IK)+DTODSL*DSDZ1 + T2(IKU) = T2(IKU)-DTODSU*DSDZ1 + ENDDO + ENDDO + IK1=(K1-1)*N2+1 + CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), + & AU(IK1),Q2(IK1),T2(IK1)) + DO K=K1,K2 + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + Q(INDEX2(I),K) = Q2(IK) + T(INDEX2(I),K) = T2(IK) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/shalcv_1lyr.f b/gsmphys/shalcv_1lyr.f new file mode 100644 index 00000000..7ef2443f --- /dev/null +++ b/gsmphys/shalcv_1lyr.f @@ -0,0 +1,188 @@ + SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,levshc + &, phil, kinver, ctei_r, ctei_rm, lprnt, ipr) +! + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP + &, RD => con_RD + implicit none +! + logical lprnt + integer ipr + integer IM, IX, KM, KUO(IM), kinver(im), levshc(im) + real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), + & PRSLK(IX,KM), phil(ix,km), + & Q(IX,KM), T(IX,KM), DT + &, ctei_r(im), ctei_rm +! +! Locals +! + real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, + & dsig, dtodsl, dtodsu, eldq, g, + & gocp, rtdls +! + integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii + integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk + &, KTOPM(IM) +! + PARAMETER(G=GRAV, GOCP=G/CP) ! PHYSICAL PARAMETERS + PARAMETER(KLIFTL=2,KLIFTU=2) ! BOUNDS OF PARCEL ORIGIN + LOGICAL LSHC(IM) + real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), + & PRSL2(IM*KM), PRSLK2(IM*KM), + & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) +!----------------------------------------------------------------------- +! COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION +! AND MOIST STATIC INSTABILITY. + DO I=1,IM + LSHC(I)=.FALSE. + ENDDO + DO K=1,KM-1 + DO I=1,IM + IF(KUO(I).EQ.0) THEN + ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) + CPDT = CP*(T(I,K)-T(I,K+1)) + DMSE = ELDQ + CPDT + phil(i,k) - phil(i,k+1) + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + ENDIF + ENDDO + ENDDO + N2 = 0 + DO I=1,IM + IF(LSHC(I)) THEN + N2 = N2 + 1 + INDEX2(N2) = I + ENDIF + ENDDO +! if (lprnt) print *,' in shalcnv N2=',n2,' ipr=',ipr,' im=',im + IF(N2.EQ.0) RETURN + DO K=1,KM + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + ii = index2(i) + Q2(IK) = Q(II,K) + T2(IK) = T(II,K) + PRSL2(IK) = PRSL(II,K) + PRSLK2(IK) = PRSLK(II,K) + ENDDO + ENDDO +! + do i=1,N2 + ii = index2(i) + ktopm(i) = levshc(ii) +! if (ctei_r(ii) < ctei_rm) then +! ktopm(i) = min(ktopm(i),kinver(ii)) +! endif +! if (lprnt .and. ii == ipr) print *,' ktopm=',ktopm(i) +! & ,' kinver=',kinver(ii) + enddo +!----------------------------------------------------------------------- +! COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. +! CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. + CALL MSTADBTN(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, + & KLCL,KBOT,KTOP,AL,AU,ktopm,lprnt,ipr,index2) +! & KLCL,KBOT,KTOP,AL,AU) + DO I=1,N2 +! if (lprnt .and. index2(i) == ipr) print *,' kbotb=',kbot(i) +! &, ' ktopb=',ktop(i) + if (ktop(i) > kbot(i)) then + KBOT(I) = min(KLCL(I)-1, ktopm(i)-1) +! KTOP(I) = min(KTOP(I)+1, ktopm(i)) +!!!! KTOP(I) = min(KTOP(I), ktopm(i)) + if (ctei_r(index2(i)) >= ctei_rm) then + KTOP(I) = min(KTOP(I)+1, ktopm(i)) + else + KTOP(I) = min(KTOP(I), ktopm(i)) + endif + endif + LSHC(I) = .FALSE. +! if (lprnt .and. index2(i) == ipr) print *,' kbot=',kbot(i) +! &, ' ktop=',ktop(i) + ENDDO + DO K=1,KM-1 + KK = (K-1)*N2 + DO I=1,N2 + IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN + IK = KK + I + IKU = IK + N2 + ELDQ = HVAP * (Q2(IK)-Q2(IKU)) + CPDT = CP * (T2(IK)-T2(IKU)) +! RTDLS = (PRSL2(IK)-PRSL2(IKU)) / +! & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) + RTDLS = phil(index2(i),k+1) - phil(index2(i),k) + DMSE = ELDQ + CPDT - RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + AU(IK) = G/RTDLS + ENDIF + ENDDO + ENDDO + K1=KM+1 + K2=0 + DO I=1,N2 + IF(.NOT.LSHC(I)) THEN + KBOT(I) = KM+1 + KTOP(I) = 0 + ENDIF + K1 = MIN(K1,KBOT(I)) + K2 = MAX(K2,KTOP(I)) + ENDDO + KT = K2-K1+1 + IF(KT.LT.2) RETURN +!----------------------------------------------------------------------- +! SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. +! COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. +! EXPAND FINAL FIELDS. + KK = (K1-1) * N2 + DO I=1,N2 + IK = KK + I + AD(IK) = 1. + ENDDO +! +! DTODSU=DT/DEL(K1) + DO K=K1,K2-1 +! DTODSL=DTODSU +! DTODSU= DT/DEL(K+1) +! DSIG=SL(K)-SL(K+1) + KK = (K-1) * N2 + DO I=1,N2 + ii = index2(i) + DTODSL = DT/DEL(II,K) + DTODSU = DT/DEL(II,K+1) + DSIG = PRSL(II,K) - PRSL(II,K+1) + IK = KK + I + IKU = IK + N2 + IF(K.EQ.KBOT(I)) THEN + CK=1.5 + ELSEIF(K.EQ.KTOP(I)-1) THEN + CK=1. + ELSEIF(K.EQ.KTOP(I)-2) THEN + CK=3. + ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN + CK=5. + ELSE + CK=0. + ENDIF + DSDZ1 = CK*DSIG*AU(IK)*GOCP + DSDZ2 = CK*DSIG*AU(IK)*AU(IK) + AU(IK) = -DTODSL*DSDZ2 + AL(IK) = -DTODSU*DSDZ2 + AD(IK) = AD(IK)-AU(IK) + AD(IKU) = 1.-AL(IK) + T2(IK) = T2(IK)+DTODSL*DSDZ1 + T2(IKU) = T2(IKU)-DTODSU*DSDZ1 + ENDDO + ENDDO + IK1=(K1-1)*N2+1 + CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), + & AU(IK1),Q2(IK1),T2(IK1)) + DO K=K1,K2 + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + Q(INDEX2(I),K) = Q2(IK) + T(INDEX2(I),K) = T2(IK) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/shalcv_fixdp.f b/gsmphys/shalcv_fixdp.f new file mode 100644 index 00000000..adbccc43 --- /dev/null +++ b/gsmphys/shalcv_fixdp.f @@ -0,0 +1,194 @@ + SUBROUTINE SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,levshc + &, phil, kinver, ctei_r, ctei_rm, lprnt, ipr) +! + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP + &, RD => con_RD + implicit none +! + logical lprnt + integer ipr + integer IM, IX, KM, KUO(IM), kinver(im), levshc(im) + real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), + & PRSLK(IX,KM), phil(ix,km), + & Q(IX,KM), T(IX,KM), DT + &, ctei_r(im), ctei_rm(im) +! +! Locals +! + real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, + & dsig, dtodsl, dtodsu, eldq, g, + & gocp, rtdls, toppres +! + integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii + integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk + &, KTOPM(IM), kkt +! + PARAMETER(G=GRAV, GOCP=G/CP) ! PHYSICAL PARAMETERS + PARAMETER(KLIFTL=2,KLIFTU=2) ! BOUNDS OF PARCEL ORIGIN + real, parameter :: ctei_dp=2000.0 ! mix over 20 hPa + LOGICAL LSHC(IM) + real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), + & PRSL2(IM*KM), PRSLK2(IM*KM), + & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) +!----------------------------------------------------------------------- +! COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION +! AND MOIST STATIC INSTABILITY. + DO I=1,IM + LSHC(I)=.FALSE. + ENDDO + DO K=1,KM-1 + DO I=1,IM + IF(KUO(I).EQ.0) THEN + ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) + CPDT = CP*(T(I,K)-T(I,K+1)) + DMSE = ELDQ + CPDT + phil(i,k) - phil(i,k+1) + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + ENDIF + ENDDO + ENDDO + N2 = 0 + DO I=1,IM + IF(LSHC(I)) THEN + N2 = N2 + 1 + INDEX2(N2) = I + ENDIF + ENDDO +! if (lprnt) print *,' in shalcnv N2=',n2,' ipr=',ipr,' im=',im + IF(N2.EQ.0) RETURN + DO K=1,KM + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + ii = index2(i) + Q2(IK) = Q(II,K) + T2(IK) = T(II,K) + PRSL2(IK) = PRSL(II,K) + PRSLK2(IK) = PRSLK(II,K) + ENDDO + ENDDO +! + do i=1,N2 + ii = index2(i) + ktopm(i) = levshc(ii) +! if (ctei_r(ii) < ctei_rm(ii)) then +! ktopm(i) = min(ktopm(i),kinver(ii)) +! endif +! if (lprnt .and. ii == ipr) print *,' ktopm=',ktopm(i) +! & ,' kinver=',kinver(ii) + enddo +!----------------------------------------------------------------------- +! COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. +! CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. + CALL MSTADBTN(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, + & KLCL,KBOT,KTOP,AL,AU,ktopm,lprnt,ipr,index2) +! & KLCL,KBOT,KTOP,AL,AU) + DO I=1,N2 +! if (lprnt .and. index2(i) == ipr) print *,' kbotb=',kbot(i) +! &, ' ktopb=',ktop(i) + if (ktop(i) > kbot(i)) then + KBOT(I) = min(KLCL(I)-1, ktopm(i)-1) +! KTOP(I) = min(KTOP(I)+1, ktopm(i)) +!!!! KTOP(I) = min(KTOP(I), ktopm(i)) + ii = index2(i) + if (ctei_r(ii) >= ctei_rm(ii)) then + toppres = prsl(ii,ktop(i)) - ctei_dp + do kk=ktop(i)+1,km-1 + if (prsl(ii,kk) > toppres) kkt = kk + enddo + KTOP(I) = min(KTOP(I)+1, ktopm(i), kkt) + else + KTOP(I) = min(KTOP(I), ktopm(i)) + endif + endif + LSHC(I) = .FALSE. +! if (lprnt .and. index2(i) == ipr) print *,' kbot=',kbot(i) +! &, ' ktop=',ktop(i) + ENDDO + DO K=1,KM-1 + KK = (K-1)*N2 + DO I=1,N2 + IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN + IK = KK + I + IKU = IK + N2 + ELDQ = HVAP * (Q2(IK)-Q2(IKU)) + CPDT = CP * (T2(IK)-T2(IKU)) +! RTDLS = (PRSL2(IK)-PRSL2(IKU)) / +! & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) + RTDLS = phil(index2(i),k+1) - phil(index2(i),k) + DMSE = ELDQ + CPDT - RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + AU(IK) = G/RTDLS + ENDIF + ENDDO + ENDDO + K1=KM+1 + K2=0 + DO I=1,N2 + IF(.NOT.LSHC(I)) THEN + KBOT(I) = KM+1 + KTOP(I) = 0 + ENDIF + K1 = MIN(K1,KBOT(I)) + K2 = MAX(K2,KTOP(I)) + ENDDO + KT = K2-K1+1 + IF(KT.LT.2) RETURN +!----------------------------------------------------------------------- +! SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. +! COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. +! EXPAND FINAL FIELDS. + KK = (K1-1) * N2 + DO I=1,N2 + IK = KK + I + AD(IK) = 1. + ENDDO +! +! DTODSU=DT/DEL(K1) + DO K=K1,K2-1 +! DTODSL=DTODSU +! DTODSU= DT/DEL(K+1) +! DSIG=SL(K)-SL(K+1) + KK = (K-1) * N2 + DO I=1,N2 + ii = index2(i) + DTODSL = DT/DEL(II,K) + DTODSU = DT/DEL(II,K+1) + DSIG = PRSL(II,K) - PRSL(II,K+1) + IK = KK + I + IKU = IK + N2 + IF(K.EQ.KBOT(I)) THEN + CK=1.5 + ELSEIF(K.EQ.KTOP(I)-1) THEN + CK=1. + ELSEIF(K.EQ.KTOP(I)-2) THEN + CK=3. + ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN + CK=5. + ELSE + CK=0. + ENDIF + DSDZ1 = CK*DSIG*AU(IK)*GOCP + DSDZ2 = CK*DSIG*AU(IK)*AU(IK) + AU(IK) = -DTODSL*DSDZ2 + AL(IK) = -DTODSU*DSDZ2 + AD(IK) = AD(IK)-AU(IK) + AD(IKU) = 1.-AL(IK) + T2(IK) = T2(IK)+DTODSL*DSDZ1 + T2(IKU) = T2(IKU)-DTODSU*DSDZ1 + ENDDO + ENDDO + IK1=(K1-1)*N2+1 + CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), + & AU(IK1),Q2(IK1),T2(IK1)) + DO K=K1,K2 + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + Q(INDEX2(I),K) = Q2(IK) + T(INDEX2(I),K) = T2(IK) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/shalcv_opr.f b/gsmphys/shalcv_opr.f new file mode 100644 index 00000000..327a155f --- /dev/null +++ b/gsmphys/shalcv_opr.f @@ -0,0 +1,164 @@ + SUBROUTINE SHALCVT3(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T) +! + USE MACHINE , ONLY : kind_phys + USE PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP + &, RD => con_RD + implicit none +! +! include 'constant.h' +! + integer IM, IX, KM, KUO(IM) + real(kind=kind_phys) DEL(IX,KM), PRSI(IX,KM+1), PRSL(IX,KM), + & PRSLK(IX,KM), + & Q(IX,KM), T(IX,KM), DT +! +! Locals +! + real(kind=kind_phys) ck, cpdt, dmse, dsdz1, dsdz2, + & dsig, dtodsl, dtodsu, eldq, g, + & gocp, rtdls +! + integer k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii + integer INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk +cc +C PHYSICAL PARAMETERS + PARAMETER(G=GRAV, GOCP=G/CP) +C BOUNDS OF PARCEL ORIGIN + PARAMETER(KLIFTL=2,KLIFTU=2) + LOGICAL LSHC(IM) + real(kind=kind_phys) Q2(IM*KM), T2(IM*KM), + & PRSL2(IM*KM), PRSLK2(IM*KM), + & AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1)) +C----------------------------------------------------------------------- +C COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION +C AND MOIST STATIC INSTABILITY. + DO I=1,IM + LSHC(I)=.FALSE. + ENDDO + DO K=1,KM-1 + DO I=1,IM + IF(KUO(I).EQ.0) THEN + ELDQ = HVAP*(Q(I,K)-Q(I,K+1)) + CPDT = CP*(T(I,K)-T(I,K+1)) + RTDLS = (PRSL(I,K)-PRSL(I,K+1)) / + & PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1)) + DMSE = ELDQ+CPDT-RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + ENDIF + ENDDO + ENDDO + N2 = 0 + DO I=1,IM + IF(LSHC(I)) THEN + N2 = N2 + 1 + INDEX2(N2) = I + ENDIF + ENDDO + IF(N2.EQ.0) RETURN + DO K=1,KM + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + ii = index2(i) + Q2(IK) = Q(II,K) + T2(IK) = T(II,K) + PRSL2(IK) = PRSL(II,K) + PRSLK2(IK) = PRSLK(II,K) + ENDDO + ENDDO +C----------------------------------------------------------------------- +C COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION. +C CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD. + CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2, + & KLCL,KBOT,KTOP,AL,AU) + DO I=1,N2 + KBOT(I) = KLCL(I)-1 + KTOP(I) = KTOP(I)+1 + LSHC(I) = .FALSE. + ENDDO + DO K=1,KM-1 + KK = (K-1)*N2 + DO I=1,N2 + IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN + IK = KK + I + IKU = IK + N2 + ELDQ = HVAP * (Q2(IK)-Q2(IKU)) + CPDT = CP * (T2(IK)-T2(IKU)) + RTDLS = (PRSL2(IK)-PRSL2(IKU)) / + & PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU)) + DMSE = ELDQ + CPDT - RTDLS + LSHC(I) = LSHC(I).OR.DMSE.GT.0. + AU(IK) = G/RTDLS + ENDIF + ENDDO + ENDDO + K1=KM+1 + K2=0 + DO I=1,N2 + IF(.NOT.LSHC(I)) THEN + KBOT(I) = KM+1 + KTOP(I) = 0 + ENDIF + K1 = MIN(K1,KBOT(I)) + K2 = MAX(K2,KTOP(I)) + ENDDO + KT = K2-K1+1 + IF(KT.LT.2) RETURN +C----------------------------------------------------------------------- +C SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES. +C COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER. +C EXPAND FINAL FIELDS. + KK = (K1-1) * N2 + DO I=1,N2 + IK = KK + I + AD(IK) = 1. + ENDDO +! +! DTODSU=DT/DEL(K1) + DO K=K1,K2-1 +! DTODSL=DTODSU +! DTODSU= DT/DEL(K+1) +! DSIG=SL(K)-SL(K+1) + KK = (K-1) * N2 + DO I=1,N2 + ii = index2(i) + DTODSL = DT/DEL(II,K) + DTODSU = DT/DEL(II,K+1) + DSIG = PRSL(II,K) - PRSL(II,K+1) + IK = KK + I + IKU = IK + N2 + IF(K.EQ.KBOT(I)) THEN + CK=1.5 + ELSEIF(K.EQ.KTOP(I)-1) THEN + CK=1. + ELSEIF(K.EQ.KTOP(I)-2) THEN + CK=3. + ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN + CK=5. + ELSE + CK=0. + ENDIF + DSDZ1 = CK*DSIG*AU(IK)*GOCP + DSDZ2 = CK*DSIG*AU(IK)*AU(IK) + AU(IK) = -DTODSL*DSDZ2 + AL(IK) = -DTODSU*DSDZ2 + AD(IK) = AD(IK)-AU(IK) + AD(IKU) = 1.-AL(IK) + T2(IK) = T2(IK)+DTODSL*DSDZ1 + T2(IKU) = T2(IKU)-DTODSU*DSDZ1 + ENDDO + ENDDO + IK1=(K1-1)*N2+1 + CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1), + & AU(IK1),Q2(IK1),T2(IK1)) + DO K=K1,K2 + KK = (K-1)*N2 + DO I=1,N2 + IK = KK + I + Q(INDEX2(I),K) = Q2(IK) + T(INDEX2(I),K) = T2(IK) + ENDDO + ENDDO +C----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/som_mlm.F90 b/gsmphys/som_mlm.F90 new file mode 100644 index 00000000..b3509617 --- /dev/null +++ b/gsmphys/som_mlm.F90 @@ -0,0 +1,539 @@ +!> \file som_mlm.f90 +!! This file contains routines for a Slab Ocean Model (SOM) and +!! also a Mixed Layer Ocean Model (MLM) +! +!! Contacted Baoqiang Xiang at baoqiang.xiang@noaa.gov + +! ========================================================== !!!!! +! 'module_ocean' description !!!!! +! ========================================================== !!!!! +! ! +! this module sets up SST using a slab ocean model (SOM) or ! +! mixed layer ocean model (MLM) ! +! in the module, the externally callabe subroutines are : ! +! ! +! 'ocean_init' -- initialization SOM by setting some namelists ! +! ! +! 'update_ocean' -- update SST with the combined effect of net ! +! surface heat flux and the nudging term ! +! ! +!!!!! ========================================================== !!!!! +!!!!! end descriptions !!!!! +!!!!! ========================================================== !!!!! + + +!========================================! + module module_ocean ! +!........................................! +! + use physparam, only : kind_phys + use GFS_typedefs, only : GFS_control_type, GFS_grid_type +! use constants_mod, only : omega, grav +! + implicit none + private + + public ocean_init, update_ocean +! + real (kind=kind_phys) :: maxlat, width_buffer, minmld, & + cpwater, rhowater, omega, grav + parameter(maxlat = 60.) ! determine the maximum latitude band for SOM/MLM + parameter(minmld = 10.) ! minimum mixed layer depth + parameter(width_buffer = 15.) ! the width of a buffer band where SST is determined by both SOM/MLM + ! and climatology (or climatology plus initial anomaly) + parameter(cpwater = 4000.) + parameter(rhowater = 1000.) + parameter(omega = 7.292e-5) + parameter(grav = 9.80) + +! namelist variables + character(len=24) :: ocean_option = 'SOM' ! option to set ocean mixed layer depth (MLD) + ! using either 'SOM' or 'MLM' + character(len=24) :: mld_option = 'obs' ! option to set ocean mixed layer depth (MLD) + ! using either 'obs' or 'const' + real(kind=kind_phys) :: mld_obs_ratio = 1. ! tuning parameter for observed MLD + real(kind=kind_phys) :: stress_ratio = 1. ! how much of wind stress is applied in the mixed layer + integer :: restore_method = 1 ! option 1: nudging toward observational climatology + ! option 2: nudging toward observational climatology plus + ! initial anomaly with a decay time scale of FTSFS (90 days) + ! option 3: nudging toward observed SST + logical :: use_old_mlm = .false. ! if true: very similar to WRF model + logical :: use_rain_flux = .false. ! considering the rainfall induced surface flux + logical :: use_qflux = .false. ! considering the qflux correction + logical :: do_mld_restore = .false. ! restoring MLD toward observed climatology + real(kind=kind_phys) :: const_mld = 40. ! constant ocean MLD (meter) + real(kind=kind_phys) :: Gam = 0.14 ! ocean temp lapese rate at the bottom of MLD (degree per m) + real(kind=kind_phys) :: eps_day = 10. ! damping time scale of ocean current (days) + real(kind=kind_phys) :: sst_restore_tscale = 3. ! restoring time scale for sst (day) + real(kind=kind_phys) :: mld_restore_tscale = 1. ! restoring time scale for mld (day) + real(kind=kind_phys) :: start_lat = -30. ! latitude starting from? Note that this value should not be smaller than -60. + real(kind=kind_phys) :: end_lat = 30. ! latitude ending with? Note that this value should not be bigger than 60. + real(kind=kind_phys) :: tday1 = 3. ! + real(kind=kind_phys) :: tday2 = 10. ! + real(kind=kind_phys) :: sst_restore_tscale1= 3. ! restoring time scale for sst during the period from 1 to tday1 + real(kind=kind_phys) :: sst_restore_tscale2= 10. ! restoring time scale for sst for the period beyond tday2 + real(kind=kind_phys) :: mld_restore_tscale1= 3. ! restoring time scale for mld during the period from 1 to tday1 + real(kind=kind_phys) :: mld_restore_tscale2= 10. ! restoring time scale for mld for the period beyond tday2 + ! beyond the latitude bands (start_lat:end_lat), using climatological SST or + ! climatological SST plus initial anomaly + logical :: use_tvar_restore_sst = .false.! using time varying restoring time scale for sst + logical :: use_tvar_restore_mld = .false.! using time varying restoring time scale for mld + + namelist /ocean_nml/ & + ocean_option, mld_option, mld_obs_ratio, stress_ratio, restore_method, & + use_old_mlm, use_rain_flux, use_qflux, do_mld_restore, const_mld, Gam, & + eps_day, sst_restore_tscale, mld_restore_tscale, start_lat, end_lat, & + tday1, tday2, sst_restore_tscale1, sst_restore_tscale2, mld_restore_tscale1, & + mld_restore_tscale2, use_tvar_restore_sst, use_tvar_restore_mld + +! ================= + contains +! ================= + + +!----------------------------------- + subroutine ocean_init & + & ( Model, logunit, input_nml_file )! --- inputs: + +! =================================================================== ! +! ! +! this program is the initialization program for SOM/MLM model ! +! ! +! usage: call ocean_init ! +! ! +! ! +! ==================== defination of variables ==================== ! +! ! +! + implicit none + +! --- inputs: + type (GFS_control_type), intent(in) :: Model + integer, intent(in) :: logunit + character (len = *), optional, intent (in) :: input_nml_file(:) + +! --- outputs: ( none ) + +! --- locals: + integer :: ios + logical :: exists +! +!===> ... begin here +! +!--- read in the namelist +! inquire (file=trim(Model%fn_nml), exist=exists) +! if (.not. exists) then +! write(6,*) 'ocean_namelist_read:: namelist file: ',trim(Model%fn_nml),' does not exist' +! stop +! else +! open (unit=Model%nlunit, file=Model%fn_nml, READONLY, status='OLD', iostat=ios) +! endif +! rewind(Model%nlunit) +! read (Model%nlunit, nml=ocean_nml) +! close (Model%nlunit) + +#ifdef INTERNAL_FILE_NML + read(input_nml_file, nml=ocean_nml, iostat=ios) +#else +! print *,' in sfcsub nlunit=',nlunit,' me=',me,' ialb=',ialb + inquire (file=trim(Model%fn_nml), exist=exists) + if (.not. exists) then + write(6,*) 'ocean_namelist_read:: namelist file: ',trim(Model%fn_nml),' does not exist' + stop + else + open (unit=Model%nlunit, file=Model%fn_nml, READONLY, status='OLD', iostat=ios) + endif + rewind(Model%nlunit) + read (Model%nlunit,ocean_nml) + close (Model%nlunit) +#endif + + if (start_lat < -maxlat) then + write(*,*) 'start_lat should not be smaller than -60.' + call abort + endif + if (end_lat > maxlat) then + write(*,*) 'end_lat should not be larger than 60.' + call abort + endif + +!--- write namelist to log file --- + if (Model%me == Model%master) then + write(logunit, *) "=============================================" + write(logunit, *) "Slab (or Mixed Layer) Ocean Model" + write(logunit, nml=ocean_nml) + endif +! + return +!................................... + end subroutine ocean_init +!----------------------------------- +! + subroutine update_ocean & + (im, dtp, Grid, islmsk, kdt, kdt_prev, netflxsfc, taux, tauy, rain, tair, & + qflux_restore, qflux_adj, mldclim, tsclim, ts_clim_iano, ts_obs, ts_som, & + tsfc, tml, tml0, mld, mld0, huml, hvml, tmoml, tmoml0, iau_offset) + +! =================================================================== ! +! ! +! this program computes the updated SST based on a simple SOM/MLM model ! +! Within start_lat - end_lat, SST is determined by SOM/MLM +! ! +! ==================== end of description ===================== ! +! + implicit none + +! --- inputs + integer, intent(in) :: im, kdt, kdt_prev, iau_offset + real, intent(in) :: dtp ! model time step + type (GFS_grid_type), intent(in) :: Grid + integer, dimension(:), intent(in) :: islmsk + real (kind=kind_phys), dimension(:), intent(in) :: & + netflxsfc, & ! net surface heat flux + taux, & + tauy, & + rain, & + tair, & ! lowest model level temp + qflux_adj, & ! lowest model level temp + mldclim, & ! ocean MLD + tsclim, & ! observed climatological SST + ts_clim_iano, & ! observed climatological SST plus initial anomaly + ts_obs ! observed SST (for simulation) + +! --- inoutputs + real (kind=kind_phys), dimension(:), intent(inout) :: & + ts_som, & + tsfc, & + tml, & + tml0, & + mld, & + mld0, & + huml, & + hvml, & + tmoml, & + tmoml0 + + real (kind=kind_phys), dimension(:), intent(out) :: & + qflux_restore ! restoring flux for diagnosis purpose + +! --- locals: + real (kind=kind_phys) :: & + lat, mlcp, mldc, taut, taum, & + alphat,alpham, bufzs, & + bufzn, fcor, c1, c2, r1, r2 + real (kind=kind_phys), dimension (size(tsfc,1)) :: tsfc1, tsfc2 + real (kind=kind_phys), dimension (size(tsfc,1)) :: qsfc + integer :: i + real (kind=kind_phys) :: & + tmlp, mldp, humlp, hvmlp, mldn, tmln, tmomln, fday, tem +! +!===> ... begin here +! + if (iau_offset > 0 .and. kdt_prev > 0) then + fday = (kdt - kdt_prev) * dtp / 86400. + else + fday = kdt * dtp / 86400. + endif +! + qsfc = 0. + if (use_tvar_restore_sst) then + if (fday < tday1) then + taut = sst_restore_tscale1*86400. + elseif (fday >= tday1 .and. fday < tday2 ) then + tem = (sst_restore_tscale2 - sst_restore_tscale1)/(tday2-tday1) + taut = (tem*(fday-tday1) + sst_restore_tscale1) *86400. + else + taut = sst_restore_tscale2*86400. + endif + else + taut = sst_restore_tscale*86400. + endif + alphat = 1. + dtp/taut +! + if (use_tvar_restore_mld) then + if (fday < tday1) then + taum = mld_restore_tscale1*86400. + elseif (fday >= tday1 .and. fday < tday2 ) then + tem = (mld_restore_tscale2 - mld_restore_tscale1)/(tday2-tday1) + taum = (tem*(fday-tday1) + mld_restore_tscale1) *86400. + else + taum = mld_restore_tscale2*86400. + endif + else + taum = mld_restore_tscale*86400. + endif + alpham = 1. + dtp/taum + +! two buffer zones: +! (bufzs - start_lat) and (end_lat - bufzn) + bufzs = max(-maxlat - 0.0001, start_lat - width_buffer) + bufzn = min( maxlat + 0.0001, end_lat + width_buffer) +! + if (kdt == 1 .or. (iau_offset > 0 .and. kdt-kdt_prev == 1)) then + do i=1, im + ts_som(i)=tsfc(i) + enddo + if (ocean_option == "MLM") then + do i=1, im + tml(i)=tsfc(i) + tml0(i)=tsfc(i) + enddo + do i=1, im + mld(i)=mldclim(i) + mld0(i)=mld(i) + huml(i)=0. + hvml(i)=0. + tmoml(i)=tsfc(i)-5. + tmoml0(i)=tmoml(i) + enddo + endif + endif +! + if (use_rain_flux) then + do i=1,im + if ( islmsk(i) ==0 ) then + qsfc(i) = netflxsfc (i) + cpwater* rain(i)/dtp*( tair(i)-tsfc(i) ) + endif + enddo + else + qsfc = netflxsfc + endif + + if (use_qflux) then + do i=1,im + qsfc(i) = qsfc (i) + qflux_adj (i) + enddo + endif + + do i = 1, im +! + if (mld_option == 'const') then + mlcp = const_mld * rhowater * cpwater ! rho*Cp*mld + mldc = const_mld + elseif (mld_option == 'obs') then + mlcp = max(minmld, mld_obs_ratio* mldclim(i)) * rhowater *cpwater ! rho*Cp*mld + mldc = mld_obs_ratio* mldclim(i) + else + write(*,*) ' mld_option can only be const or obs now' + call abort + endif + + fcor = 2 * omega * sin (Grid%xlat(i)) + + if ( islmsk(i) ==0 ) then + if (ocean_option == "SOM") then + mld(i) = mldc + elseif (ocean_option == "MLM") then + tmlp = tml(i) + mldp = mld(i) + humlp = huml(i) + hvmlp = hvml(i) + tmln = tml0(i) +! +! tmomln = tmoml0(i) + tmomln = tmoml(i) +! + mldn = mld0(i) + call MLM1D(dtp, fcor, taum, alpham, qsfc(i), taux(i), tauy(i), & + tmlp, tmln, tmomln, mldp, mldn, mldc, humlp, hvmlp) + endif !end ocean_option + + select case (restore_method) + case(1) + tsfc2(i) = tsclim(i) + case(2) + tsfc2(i) = ts_clim_iano(i) + case (3) + tsfc2(i) = ts_obs(i) + case default + !call mpp_error(FATAL, 'restore_method not implemented') + print*, 'restore_method = ', restore_method, ' not implemented' + stop 121 + end select + + select case (ocean_option) + case("SOM") + if (use_qflux) then + tsfc1(i) = ts_som(i) + qsfc(i)/mlcp*dtp + else + tsfc1(i) = (ts_som(i) + qsfc(i)/mlcp*dtp + tsfc2(i)/taut*dtp ) / alphat + endif + case("MLM") + tsfc1(i) = (tmlp + tsfc2(i)/taut*dtp)/alphat + tml(i) = tsfc1(i) + mld(i) = mldp + huml(i) = humlp + hvml(i) = hvmlp + tmoml(i) = tml(i) - 5. ! not used + case default + !call mpp_error(FATAL, "ocean_option must be SOM or MLM") + print*, 'ocean_option must be SOM or MLM; ocean_option set to ', ocean_option + stop 122 + end select + qflux_restore(i) = (ts_clim_iano(i) - tsfc1(i)) * mlcp / taut ! for diagnosis purpose only + + ts_som (i) = tsfc1 (i) + endif ! end islmsk + enddo + + do i = 1, im + if (islmsk(i) == 0 ) then + lat = Grid%xlat(i) * 57.29578 + c1 = min(1.0, abs((lat -bufzs) / (start_lat-bufzs)) ) +! r1 = (exp(c1**interp_order)-1.)/(exp(1.0)-1.) + c2 = min(1.0, abs((bufzn - lat) / (bufzn - end_lat)) ) +! r2 = (exp(c2**interp_order)-1.)/(exp(1.0)-1.) + if (lat >= start_lat .and. lat<= end_lat ) then + tsfc(i) = tsfc1(i) + elseif (lat >= bufzs .and. lat < start_lat) then ! the first buffer zone +! tsfc(i) = c1 * tsfc1(i) + (1.-c1) * tsfc2(i) + tsfc(i) = c1 * ts_som(i) + (1.-c1) * tsfc2(i) + elseif (lat > end_lat .and. lat <= bufzn) then ! the second buffer zone +! tsfc(i) = c2 * tsfc1(i) + (1.-c2) * tsfc2(i) + tsfc(i) = c2 * ts_som(i) + (1.-c2) * tsfc2(i) + else + tsfc(i) = tsfc2(i) + endif + endif !end islmsk + enddo +! + return +!................................... + end subroutine update_ocean +!----------------------------------- + + subroutine MLM1D(dt, F, taum, alpham, qsfc, taux, tauy, & + tml, tml0, tmoml, H, H0, HC, huml, hvml) +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +! +! SUBROUTINE OCEANML CALCULATES THE SEA SURFACE TEMPERATURE +! FROM A SIMPLE OCEAN MIXED LAYER MODEL BASED ON +! (Pollard, Rhines and Thompson (1973). +! +!-- DT time step (second) +!-- F Coriolis parameter +!-- taum MLD restoring time scale +!-- alpham MLD restoring parameter +!-- qsfc net surface heat flux +!-- taux wind stress at zonal direction +!-- tauy wind stress at meridional direction +!-- tml ocean mixed layer temperature (K) +!-- tml0 ocean mixed layer temperature (K) at initial time or previous time step +!-- tmoml top 200 m ocean mean temperature (K) at initial time or previous time step +!-- H ocean mixed layer depth (m) +!-- H0 ocean mixed layer depth (m) at initial time or nudged MLD toward climatology +!-- HC climatological or constant ocean mixed layer depth (m) +!-- huml ocean mixed layer u component of wind +!-- hvml ocean mixed layer v component of wind +! +! Note: Part of the code for this subroutine is from WRF model +!---------------------------------------------------------------- + + REAL, INTENT(INOUT) :: tml, H, huml, hvml + + REAL, INTENT(IN ) :: dt, F, taum, alpham, qsfc, taux, tauy, & + tml0, tmoml, H0, HC +! Local + REAL :: alp, BV2, A1, A2, A3, B2, u, v, & + hu1, hv1, hu2, hv2, q, hold, & + hsqrd, thp, taux2, tauy2, fdt, damp + + hu1=huml + hv1=hvml + fdt = f * dt +! + alp=max((tml-273.15)*1.e-5, 1.e-6) + BV2=alp*grav*Gam + thp=tml0-Gam*(h-h0) + if (use_old_mlm) then + A1=(tml-thp)*h - 0.5*Gam*h*h + else + A1=(tml-tml0)*h + 0.5*Gam*(h-h0)*abs(h-h0) + endif + if(h.ne.0.)then + u=hu1/h + v=hv1/h + else + u=0. + v=0. + endif + +! determine how much of wind stress is applied to mixed layer + taux2 = taux * stress_ratio + tauy2 = tauy * stress_ratio + q=qsfc/(rhowater*cpwater) +! note: forward-backward coriolis force for effective time-centering + if (use_old_mlm) then +! hu2=hu1+dt*( f*hv1 + taux2/rhowater - damp*hu1) +! hv2=hv1+dt*(-f*hu2 + tauy2/rhowater - damp*hv1) + damp = 1. / 86400./eps_day + hu2=( hu1+dt*( f*hv1 + taux2/rhowater ) )/(1.0+damp*dt) + hv2=( hv1+dt*(-f*hu2 + tauy2/rhowater ) )/(1.0+damp*dt) + else + hu2=( (1-fdt**2/4.)*hu1+fdt*hv1+taux2/rhowater*dt+f*dt**2/2./rhowater*tauy2 ) / & + (1.+fdt**2/4.) + hv2=hv1+tauy2/rhowater*dt-fdt/2.*(hu2+hu1) + endif +! consider the flux effect + A2 = A1+q*dt + A3 = A1+q*dt - 0.5*Gam*h0**2 + + huml=hu2 + hvml=hv2 + + hold=h + B2=hu2*hu2+hv2*hv2 + if (use_old_mlm) then + hsqrd=-A2/Gam + sqrt(A2*A2/(Gam*Gam) + 2.*B2/BV2) + else + hsqrd=-A3/Gam + sqrt(A3*A3/(Gam*Gam) + 2.*B2/BV2) + endif + h=sqrt(max(hsqrd,0.0)) + h=min(h, 500.0) + +! write(0,*) 'test0',h,hc,taum,alpham,dt + if(do_mld_restore) then + h = (h + HC/taum*dt)/alpham + endif +! write(0,*) 'test1',h,hc,taum,alpham,dt +! limit to posit ive h change +! if (use_old_mlm) then +! if(h.lt.hold) h=hold +! else +! if(h.lt.hold) h=h0 +! endif +! no change unless tml is warmer than layer mean temp tmol or tsk-5 (see omlinit) + if(tml.ge.tmoml .and. h.ne.0.)then + +! no change unless tml is warmer than layer mean temp tmoml or tsk-5 (see omlinit) + if(tml.ge.tmoml)then + if (use_old_mlm) then +! if MLD does not deepen, we only consider the surface heat flux effect + if (h <= hold) then + tml=max(tml + q*dt/h, tmoml) + else + tml=max(tml0 - Gam*(h-h0) + 0.5*Gam*h + A2/h, tmoml) + endif + else + tml=max(tml0 -0.5* Gam*(h-h0)*abs(h-h0)/h + A2/h, tmoml) + endif + else + tml=tmoml + endif + u=hu2/h + v=hv2/h + else + tml=tml0 + u=0. + v=0. + endif +! + tml = max (273.15, tml) + + end subroutine MLM1D + + end module module_ocean + +!========================================= diff --git a/gsmphys/surface_perturbation.F90 b/gsmphys/surface_perturbation.F90 new file mode 100644 index 00000000..0c653571 --- /dev/null +++ b/gsmphys/surface_perturbation.F90 @@ -0,0 +1,419 @@ +module surface_perturbation + + implicit none + + private + + public cdfnor, ppfbet + + contains + +! mg, sfc-perts *** + +! the routines below are used in the percentile matching algorithm for the +! albedo and vegetation fraction perturbations + subroutine cdfnor(z,cdfz) + use machine + + implicit none + real(kind=kind_phys), intent(out) :: cdfz + real(kind=kind_phys),intent(in) :: z +! local vars + integer iflag + real(kind=kind_phys) del,x,cdfx,eps + + eps = 1.0E-5 + + + ! definition of passed parameters ! + ! z = value for which the normal CDF is to be computed + ! eps = the absolute accuracy requirment for the CDF + ! iflag = error indicator on output 0->no errors, 1->errorflag from + ! cdfgam, 2->errorflag from cdfgam + ! cdfz = the CDF of the standard normal distribution evaluated at z + + del = 2.0*eps + if (z.eq.0.0) then + cdfz = 0.5 + else + x = 0.5*z*z + call cdfgam(x,0.5,del,iflag, cdfx) + if (iflag.ne.0) return + if (z.gt.0.0) then + cdfz = 0.5+0.5*cdfx + else + cdfz = 0.5-0.5*cdfx + endif + endif + + return + end + + subroutine cdfgam(x,alpha,eps,iflag,cdfx) + use machine + + implicit none + real(kind=kind_phys), intent(out) :: cdfx + real(kind=kind_phys),intent(in) :: x, alpha, eps +! local vars + integer iflag,i,j,k, imax + logical LL + real(kind=kind_phys) dx, dgln, p,u,epsx,pdfl, eta, bl, uflo + data imax, uflo / 5000, 1.0E-37 / + + + ! definition of passed parameters ! + ! x = value for which the CDF is to be computed + ! alpha = parameter of gamma function (>0) + ! eps = the absolute accuracy requirment for the CDF + ! iflag = error indicator on output 0->no errors, 1->either alpha or eps + ! is <= oflo, 2->number of terms evaluated in the infinite series exceeds + ! imax. + ! cdf = the CDF evaluated at x + + cdfx = 0.0 + + if (alpha.le.uflo.or.eps.le.uflo) then + iflag=1 + return + endif + iflag=0 + + ! check for special case of x + if (x.le.0) return + + dx = x + call dgamln(alpha,dgln) + pdfl = (alpha-1.0)*log(dx)-dx-dgln + if (pdfl.lt.log(uflo)) then + if (x.ge.alpha) cdfx = 1.0 + else + p = alpha + u = exp(pdfl) + LL = .true. + if (x.ge.p) then + k = int(p) + if (p.le.real(k)) k = k-1 + eta = p - real(k) + call dgamln(eta,dgln) + bl = (eta-1)*log(dx)-dx-dgln + LL = bl.gt.log(eps) + endif + epsx = eps/x + if (LL) then + do i=0,imax + if (u.le.epsx*(p-x)) return + u = x*u/p + cdfx = cdfx+u + p = p+1.0 + enddo + iflag = 2 + else + do j=1,k + p=p-1.0 + if (u.le.epsx*(x-p)) continue + cdfx = cdfx+u + u = p*u/x + enddo + cdfx = 1.0-cdfx + endif + endif + return + end subroutine cdfgam + + subroutine dgamln(x,dgamlnout) + + use machine + implicit none + real(kind=kind_phys), intent(in) :: x + real(kind=kind_phys), intent(out) :: dgamlnout +! local vars + integer i, n + real(kind=kind_phys) absacc, b1, b2, b3, b4, b5, b6, b7, b8 + real(kind=kind_phys) c, dx, q, r, xmin, xn + data xmin, absacc / 6.894d0, 1.0E-15 / + data c / 0.918938533204672741780329736d0 / + data b1 / 0.833333333333333333333333333d-1 / + data b2 / - 0.277777777777777777777777778d-2 / + data b3 / 0.793650793650793650793650794d-3 / + data b4 / - 0.595238095238095238095238095d-3 / + data b5 / 0.841750841750841750841750842d-3 / + data b6 / - 0.191752691752691752691752692d-2 / + data b7 / 0.641025641025641025641025641d-2 / + data b8 / - 0.295506535947712418300653595d-1 / + + if (x.le.0.0) stop '*** x<=0.0 in function dgamln ***' + dx = x + n = max(0,int(xmin - dx + 1.0d0) ) + xn = dx + n + r = 1.0d0/xn + q = r*r + dgamlnout = r*( b1+q*( b2+q*( b3+q*( b4+q*( b5+q*( b6+q*( b7+q*b8 ) ) ) ) ) ) ) +c + (xn-0.5d0)*log(xn)-xn + + if (n.gt.0) then + q = 1.0d0 + do i=0, n-1 + q = q*(dx+i) + enddo + dgamlnout = dgamlnout-log(q) + endif + + if (dgamlnout + absacc.eq.dgamlnout) then + print *,' ********* WARNING FROM FUNCTION DGAMLN *********' + print *,' REQUIRED ABSOLUTE ACCURACY NOT ATTAINED FOR X = ',x + endif + return + end subroutine dgamln + +! --- subroutines for computing the beta distribution value that --- +! --- matches the percentile from the random pattern --- + + subroutine ppfbet(pr,p,q,iflag,x) + use machine + implicit none + real(kind=kind_phys), intent(in) :: pr, p, q + real(kind=kind_phys), intent(out) :: x + ! local variables + integer iflag, iter, itmax + real(kind=kind_phys) tol, a, b, fa, fb, fc, cdf, tol1 + real(kind=kind_phys) c, d, e, xm, s, u, v, r, eps + data itmax, eps / 50, 1.0E-12 / + + ! Compute beta distribution value corresponding to the + ! probability and distribution parameters a,b. + ! + ! pr - a probability value in the interval [0,1] + ! p - the first parameter of the beta(p,q) distribution + ! q - the second parameter of the beta(p,q) distribution + ! iflag - erro indicator in output, 0-no errors, 1,2-error flags + ! from subroutine cdfbet, 3- pr<0 or pr>1, 4-p<=0 or + ! q<=0, 5-tol<1.E-8, 6-the cdfs at the endpoints have + ! the same sign and no value of x is defined, 7-maximum + ! iterations exceeded and current value of x returned + + tol = 1.0E-5 + + + iflag = 0 + if (pr.lt.0.0.or.pr.gt.1.) then + iflag = 3 + return + endif + if(min(p,q).le.0.) then + iflag =4 + return + endif + if (tol.lt.1.0E-8) then + iflag = 5 + return + endif + a = 0. + b = 1. + fa = -pr + fb = 1.-pr + if (fb*fa.gt.0.0) then + iflag = 6 + return + endif + + fc = fb + do iter =1,itmax + if (fb*fc.gt.0.) then + c=a + fc=fa + d = b-a + e=d + endif + if (abs(fc).lt.abs(fb)) then + a=b + b=c + c=a + fa=fb + fb=fc + fc=fa + endif + + tol1 = 2.*eps*abs(b)+0.5*tol + xm = 0.5*(c-b) + if (abs(xm).le.tol1.or.fb.eq.0.0) then + x=b + return + endif + if (abs(e).ge.tol1.and.abs(fa).gt.abs(fb)) then + s = fb/fa + if (a.eq.c) then + u = 2.0*xm*s + v = 1.0-s + else + v = fa/fc + r = fb/fc + u = s*(2.0*xm*v*(v-r)-(b-a)*(r-1.0)) + v = (v-1.0)*(r-1.0)*(s-1.0) + endif + if (u.gt.0.0) v = -v + u = abs(u) + if (2.0*u.lt.min(3.0*xm*v-ABS(tol1*v),ABS(e*v))) then + e = d + d = u/v + else + d = xm + e = d + endif + + else + + d=xm + e=d + endif + + a = b + fa = fb + if (abs(d).gt.tol1) then + b = b+d + else + b = b+sign(tol1,xm) + endif + call cdfbet(b,p,q,eps,iflag,cdf) + if (iflag.ne.0) return + fb = cdf-pr + enddo + x = b + + return + end subroutine ppfbet + + subroutine cdfbet(x,p,q,eps,iflag,cdfx) + use machine + + ! Computes the value of the cumulative beta distribution at a + ! single point x, given the distribution parameters p,q. + ! + ! x - value at which the CDF is to be computed + ! p - first parameter of the beta function + ! q - second parameter of the beta function + ! eps - desired absolute accuracy + + implicit none + real(kind=kind_phys), intent(in) :: x, p, q, eps + real(kind=kind_phys), intent(out) :: cdfx + ! local vars + integer iflag, jmax, j + logical LL + real(kind=kind_phys) dp, dq, gamln, yxeps, w, uflo + real(kind=kind_phys) xy, yx, pq, qp, pdfl, u, r, v + real(kind=kind_phys) tmp + data jmax, w, uflo / 5000, 20.0, 1.0E-30 / + + cdfx = 0.0 + + if (p.le.uflo.or.q.le.uflo.or.eps.le.uflo) then + iflag = 1 + endif + iflag = 0 + + if (x.le.0.0) return + if (x.ge.1.0) then + cdfx=1.0 + else + LL = (p+w).ge.(p+q+2.0*w)*x + if (LL) then + xy = x + yx = 1.-xy + pq = p + qp = q + else + yx = x + xy = 1.-yx + qp = p + pq = q + endif + + call gmln(pq,tmp) + dp = (pq-1.)*log(xy)-tmp + call gmln(qp,tmp) + dq = (qp-1.)*log(yx)-tmp + call gmln(pq+qp,tmp) + pdfl = tmp+dp+dq + + if (pdfl.ge.log(uflo)) then + u = exp(pdfl)*xy/pq + r = xy/yx + do while (qp.gt.1.) + if (u.le.eps*(1.-(pq+qp)*xy/(pq+1.))) then + if (.not.LL) cdfx = 1.-cdfx + return + endif + cdfx = cdfx+u + pq = pq+1. + qp = qp-1. + u = qp*r*u/pq + enddo + v = yx*u + yxeps = yx*eps + do j = 0, jmax + if (v.le.yxeps) then + if (.not.LL) cdfx = 1.-cdfx + return + endif + cdfx = cdfx + v + pq = pq+1. + v = (pq+qp-1.)*xy*v/pq + enddo + iflag = 2 + endif + if (.not.LL) cdfx = 1.-cdfx + endif + + end subroutine cdfbet + + subroutine gmln(x,y) + use machine + ! Computes the natural logarithm of the gamma distribution. Users + ! can set the absolute accuracy and corresponding xmin. + + implicit none + real(kind=kind_phys), intent(in) :: x + real(kind=kind_phys), intent(out) :: y +! local vars + integer i, n + real(kind=kind_phys) absacc, b1, b2, b3, b4, b5, b6, b7, b8 + real(kind=kind_phys) c, dx, q, r, xmin, xn +! data xmin, absacc / 6.894d0, 1.0E-15 / + data xmin, absacc / 1.357d0, 1.0E-3 / + data c / 0.918938533204672741780329736d0 / + data b1 / 0.833333333333333333333333333d-1 / + data b2 / - 0.277777777777777777777777778d-2 / + data b3 / 0.793650793650793650793650794d-3 / + data b4 / - 0.595238095238095238095238095d-3 / + data b5 / 0.841750841750841750841750842d-3 / + data b6 / - 0.191752691752691752691752692d-2 / + data b7 / 0.641025641025641025641025641d-2 / + data b8 / - 0.295506535947712418300653595d-1 / + + if (x.le.0.0) stop '*** x<=0.0 in function gamln ***' + dx = x + n = max(0,int(xmin - dx + 1.0d0) ) + xn = dx + n + r = 1.0d0/xn + q = r*r + y = r*( b1+q*( b2+q*( b3+q*( b4+q*( b5+q*( b6+q*( b7+q*b8 ) & + & )) ) ) ) ) +c + (xn-0.5d0)*log(xn)-xn + + if (n.gt.0) then + q = 1.0d0 + do i=0, n-1 + q = q*(dx+i) + enddo + y = y-log(q) + endif + + if (y + absacc.eq.y) then + print *,' ********* WARNING FROM FUNCTION GAMLN *********' + print *,' REQUIRED ABSOLUTE ACCURACY NOT ATTAINED FOR X = ',x + endif + return + end subroutine gmln + +! *** mg, sfc perts + +end module surface_perturbation diff --git a/gsmphys/tracer_const_h.f b/gsmphys/tracer_const_h.f new file mode 100644 index 00000000..d51a12c6 --- /dev/null +++ b/gsmphys/tracer_const_h.f @@ -0,0 +1,62 @@ + module tracer_const + use machine , only : kind_phys + implicit none + +! !revision history: +! +! 09Feb2010 Sarah Lu, ri/cpi changed to allocatable + + +! real(kind=kind_phys) ri(0:20),cpi(0:20) + real(kind=kind_phys), allocatable :: ri(:),cpi(:) +!hmhj integer, parameter :: num_tracer=3 + + contains +! ------------------------------------------------------------------- + subroutine set_tracer_const (ntrac,me,nlunit) + use machine , only : kind_phys + use physcons , only : rd => con_rd , cpd => con_cp + implicit none + integer ntrac,me,nlunit + namelist /tracer_constant/ ri,cpi + +! +!hmhj + if( ntrac.eq.0 ) then + if( me.eq.0 ) then + write(0,*) ' Error : number of tracer is zero ' + endif + call abort + endif +!hmhj if( ntrac.ne.num_tracer ) then +!hmhj if( me.eq.0 ) then +!hmhj write(0,*) ' Error ; inconsistent number of tracer ' +!hmhj write(0,*) ' ntrac=',ntrac,' num_tracer=',num_tracer +!hmhj endif +!hmhj call abort +!hmhj endif + +! +!! This routine is now called by NMMB only (Sarah Lu) +!! For GFS core, CPI/RI is passed in from DYN export state +!! The allocation below is to support NMMB+GFS_physics package + if (.not. allocated(ri)) then + allocate( ri(0:ntrac)) + allocate(cpi(0:ntrac)) +!hmhj allocate( ri(0:num_tracer)) +!hmhj allocate(cpi(0:num_tracer)) + endif +! + ri=0.0 + cpi=0.0 + ri(0)=rd + cpi(0)=cpd + + rewind(nlunit) + read(nlunit, tracer_constant) + write(0, tracer_constant) + + return + end subroutine set_tracer_const + + end module tracer_const diff --git a/gsmphys/tridi2t3.f b/gsmphys/tridi2t3.f new file mode 100644 index 00000000..d99609dd --- /dev/null +++ b/gsmphys/tridi2t3.f @@ -0,0 +1,41 @@ + SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2) +! + USE MACHINE , ONLY : kind_phys + implicit none + integer L,N +! + real(kind=kind_phys) + & CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), + & AU(L,N-1),A1(L,N),A2(L,N) +! + real(kind=kind_phys) fk + integer k,i +! + DO I=1,L + FK = 1. / CM(I,1) + AU(I,1) = FK*CU(I,1) + A1(I,1) = FK*R1(I,1) + A2(I,1) = FK*R2(I,1) + ENDDO + DO K=2,N-1 + DO I=1,L + FK = 1./(CM(I,K)-CL(I,K)*AU(I,K-1)) + AU(I,K) = FK*CU(I,K) + A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1)) + A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1)) + ENDDO + ENDDO + DO I=1,L + FK = 1./(CM(I,N)-CL(I,N)*AU(I,N-1)) + A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1)) + A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1)) + ENDDO + DO K=N-1,1,-1 + DO I=1,L + A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1) + A2(I,K) = A2(I,K) - AU(I,K)*A2(I,K+1) + ENDDO + ENDDO +!----------------------------------------------------------------------- + RETURN + END diff --git a/gsmphys/wam_f107_kp_mod.f90 b/gsmphys/wam_f107_kp_mod.f90 new file mode 100644 index 00000000..23355cca --- /dev/null +++ b/gsmphys/wam_f107_kp_mod.f90 @@ -0,0 +1,75 @@ + MODULE wam_f107_kp_mod + + IMPLICIT none + + INTEGER :: f107_kp_size, f107_kp_interval + INTEGER :: f107_kp_skip_size + INTEGER :: f107_kp_read_in_size + INTEGER :: f107_kp_data_size + INTEGER :: kdt_3h + REAL, POINTER, DIMENSION(:) :: f107, kp + + CONTAINs + + SUBROUTINE read_wam_f107_kp_txt + +! Subprogram: read_wam_f107_kp_txt read-in the inputted f10.7 and kp data. +! Prgmmr: Weiyu Yang Date: 2015-10-19 +! + CHARACTER*20 :: issuedate, realdate(f107_kp_data_size) + CHARACTER*20 :: realdate_work + INTEGER :: i, j + INTEGER :: f107_flag_work, kp_flag_work + REAL :: f107_81d_avg + REAL :: f107_work, kp_work + +! Flags: 0=Forecast, 1=Estimated, 2=Observed + INTEGER, DIMENSION(f107_kp_data_size) :: f107_flag, kp_flag + +! Skip the observation data before the forecast starting. +!-------------------------------------------------------- + OPEN(79, FILE='wam_input_f107_kp.txt', FORM='formatted') + REWIND 79 + READ(79, 1000) issuedate + READ(79, 1001) f107_81d_avg + DO i = 1, 4 + READ(79, *) + END DO + + DO i = 1, f107_kp_skip_size + READ(79, *) realdate_work, f107_work, kp_work, & + f107_flag_work, kp_flag_work + END DO + +! f107_kp_size is the forecast run length. +!----------------------------------------- + f107_kp_read_in_size = f107_kp_data_size - f107_kp_skip_size + + DO i = 1, MIN(f107_kp_read_in_size, f107_kp_size) + READ(79, *) realdate(i), f107(i), kp(i), & + f107_flag(i), kp_flag(i) + END DO + CLOSE(79) +! If run time longer than the f107 data, use the latest data to run +! continuously. +!------------------------------------------------------------------ + DO i = f107_kp_read_in_size + 1, f107_kp_size + f107(i) = f107(f107_kp_read_in_size) + kp (i) = kp (f107_kp_read_in_size) + END DO + +!For testing. +!------------ +! f107=70.0 +! kp=2.0 + +1000 FORMAT(20x, a20) +1001 FORMAT(20x, f3.0) +! PRINT*, 'issuedate=', issuedate +! PRINT*, 'f107_81d_avg=', f107_81d_avg +! DO i = 1, f107_kp_read_in_size +! PRINT*, i, f107(i), kp(i), f107_flag(i), kp_flag(i) +! END DO + END SUBROUTINE read_wam_f107_kp_txt + + END MODULE wam_f107_kp_mod diff --git a/gsmphys/wv_saturation.F b/gsmphys/wv_saturation.F new file mode 100644 index 00000000..b4d77c87 --- /dev/null +++ b/gsmphys/wv_saturation.F @@ -0,0 +1,1574 @@ +! +! Common block and statement functions for saturation vapor pressure +! look-up procedure, J. J. Hack, February 1990 +! +! $Id: wv_saturation.F90,v 1.1.12.2.10.1 2014-04-14 16:04:56 dbarahon Exp $ +! + module wv_saturation +#ifdef GEOS5 + use MAPL_ConstantsMod, r8 => MAPL_R8 +#endif +#ifdef NEMS_GSM + use funcphys, only: fpvsl, fpvsi, fpvs ! saturation vapor pressure for water & ice +#endif + use machine, only: r8 => kind_phys + + +!++jtb (comm out) + + + +!--jtb + + implicit none + private + save +! +! Public interfaces +! + public gestbl + public estblf + public aqsat + public aqsatd + public vqsatd + public fqsatd + public qsat_water + public vqsat_water + public qsat_ice + public vqsat_ice + public vqsatd_water + public aqsat_water + public vqsatd2_water + public vqsatd2_water_single + public vqsatd2_ice_single + public vqsatd2 + public vqsatd2_single + public polysvp +! +! Data used by cldwat +! + public hlatv, tmin, hlatf, rgasv, pcf, cp, epsqs, ttrice +! +! Data +! + integer plenest + parameter (plenest=250) +! +! Table of saturation vapor pressure values es from tmin degrees +! to tmax+1 degrees k in one degree increments. ttrice defines the +! transition region where es is a combination of ice & water values +! + real(r8) estbl(plenest) + real(r8) tmin + real(r8) tmax + real(r8) ttrice + real(r8) pcf(6) + real(r8) epsqs + real(r8) rgasv + real(r8) hlatf + real(r8) hlatv + real(r8) cp + real(r8) tmelt + logical icephs + + integer, parameter :: iulog=6 + + contains + + real(r8) function estblf( td ) +! +! Saturation vapor pressure table lookup +! + real(r8), intent(in) :: td +! + real(r8) :: e + real(r8) :: ai + integer :: i +! + e = max(min(td,tmax),tmin) + i = int(e-tmin)+1 + ai = aint(e-tmin) + estblf = (tmin+ai-e+1._r8)* estbl(i)-(tmin+ai-e)* estbl(i+1) + end function estblf + + subroutine gestbl(tmn ,tmx ,trice ,ip ,epsil , latvap ,latice , & + & rh2o ,cpair ,tmeltx ) +!----------------------------------------------------------------------- +! +! Purpose: +! Builds saturation vapor pressure table for later lookup procedure. +! +! Method: +! Uses Goff & Gratch (1946) relationships to generate the table +! according to a set of free parameters defined below. Auxiliary +! routines are also included for making rapid estimates (well with 1%) +! of both es and d(es)/dt for the particular table configuration. +! +! Author: J. Hack +! +!----------------------------------------------------------------------- + + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: tmn + real(r8), intent(in) :: tmx + real(r8), intent(in) :: epsil + real(r8), intent(in) :: trice + real(r8), intent(in) :: latvap + real(r8), intent(in) :: latice + real(r8), intent(in) :: rh2o + real(r8), intent(in) :: cpair + real(r8), intent(in) :: tmeltx +! +!---------------------------Local variables----------------------------- +! + real(r8) t + integer n + integer lentbl + integer itype +! 1 -> ice phase, no transition +! -x -> ice phase, x degree transition + logical ip +! +!----------------------------------------------------------------------- +! +! Set es table parameters +! + tmin = tmn + tmax = tmx + ttrice = trice + icephs = ip +! +! Set physical constants required for es calculation +! + epsqs = epsil + hlatv = latvap + hlatf = latice + rgasv = rh2o + cp = cpair + tmelt = tmeltx +! + lentbl = INT(tmax-tmin+2.000001_r8) + if (lentbl .gt. plenest) then + + + + write(*,*) "AHHH wv_sat" + STOP + end if +! +! Begin building es table. +! Check whether ice phase requested. +! If so, set appropriate transition range for temperature +! + if (icephs) then + if (ttrice /= 0.0_r8) then + itype = -ttrice + else + itype = 1 + end if + else + itype = 0 + end if +! + t = tmin - 1.0_r8 + do n=1,lentbl + t = t + 1.0_r8 + call gffgch(t,estbl(n),tmelt,itype) + end do +! + do n=lentbl+1,plenest + estbl(n) = -99999.0_r8 + end do +! +! Table complete -- Set coefficients for polynomial approximation of +! difference between saturation vapor press over water and saturation +! pressure over ice for -ttrice < t < 0 (degrees C). NOTE: polynomial +! is valid in the range -40 < t < 0 (degrees C). +! +! --- Degree 5 approximation --- +! + pcf(1) = 5.04469588506e-01_r8 + pcf(2) = -5.47288442819e+00_r8 + pcf(3) = -3.67471858735e-01_r8 + pcf(4) = -8.95963532403e-03_r8 + pcf(5) = -7.78053686625e-05_r8 +! +! --- Degree 6 approximation --- +! +!-----pcf(1) = 7.63285250063e-02 +!-----pcf(2) = -5.86048427932e+00 +!-----pcf(3) = -4.38660831780e-01 +!-----pcf(4) = -1.37898276415e-02 +!-----pcf(5) = -2.14444472424e-04 +!-----pcf(6) = -1.36639103771e-06 +! + +!++jtb (comment out) +! if (masterproc) then +! !!write(iulog,*)' *** SATURATION VAPOR PRESSURE TABLE COMPLETED ***' +! end if +!--jtb + + return +! +9000 format('GESTBL: FATAL ERROR ********************************* & + &',/, ' TMAX AND TMIN REQUIRE A LARGER DIMENSION ON THE LENGTH', & + & ' OF THE SATURATION VAPOR PRESSURE TABLE ESTBL(PLENEST)',/, & + & ' TMAX, TMIN, AND PLENEST => ', 2f7.2, i3) +! + end subroutine gestbl + + subroutine aqsat(t ,p ,es ,qs ,ii , ilen ,kk ,kstart ,kend ) +!----------------------------------------------------------------------- +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g),for input arrays of temperature and pressure (dimensioned ii,kk) +! This routine is useful for evaluating only a selected region in the +! vertical. +! +! Method: +! +! +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: ii + integer, intent(in) :: kk + integer, intent(in) :: ilen + integer, intent(in) :: kstart + integer, intent(in) :: kend + real(r8), intent(in) :: t(ii,kk) + real(r8), intent(in) :: p(ii,kk) +! +! Output arguments +! + real(r8), intent(out) :: es(ii,kk) + real(r8), intent(out) :: qs(ii,kk) +! +!---------------------------Local workspace----------------------------- +! + real(r8) omeps + integer i, k +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do k=kstart,kend + do i=1,ilen + es(i,k) = min(estblf(t(i,k)),p(i,k)) +! +! Saturation specific humidity +! + qs(i,k) = min(1.0_r8, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) +! +! The following check is to avoid the generation of negative values +! that can occur in the upper stratosphere and mesosphere +! +! if (qs(i,k) < 0.0_r8) then +! qs(i,k) = 1.0_r8 +! es(i,k) = p(i,k) +! end if + + end do + end do +! + return + end subroutine aqsat + +!++xl + subroutine aqsat_water(t, p, es, qs, ii, ilen, kk, kstart,kend) +!----------------------------------------------------------------------- +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g),for input arrays of temperature and pressure (dimensioned ii,kk) +! This routine is useful for evaluating only a selected region in the +! vertical. +! +! Method: +! +! +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: ii + integer, intent(in) :: kk + integer, intent(in) :: ilen + integer, intent(in) :: kstart + integer, intent(in) :: kend + real(r8), intent(in) :: t(ii,kk) + real(r8), intent(in) :: p(ii,kk) +! +! Output arguments +! + real(r8), intent(out) :: es(ii,kk) + real(r8), intent(out) :: qs(ii,kk) +! +!---------------------------Local workspace----------------------------- +! + real(r8) omeps + integer i, k +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do k=kstart,kend + do i=1,ilen +! es(i,k) = estblf(t(i,k)) +#ifdef GEOS5 + es(i,k) = min(polysvp(t(i,k),0), p(i,k)) +#endif +#ifdef NEMS_GSM + es(i,k) = min(fpvsl(t(i,k)), p(i,k)) +#endif +! +! Saturation specific humidity +! + qs(i,k) = min(1.0_r8, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) +! +! The following check is to avoid the generation of negative values +! that can occur in the upper stratosphere and mesosphere +! +! if (qs(i,k) < 0.0_r8) then +! qs(i,k) = 1.0_r8 +! es(i,k) = p(i,k) +! end if + end do + end do +! + return + end subroutine aqsat_water +!--xl + + + subroutine aqsatd(t, p, es, qs, gam, ii, ilen, kk, kstart, kend) +!----------------------------------------------------------------------- +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g). +! +! Method: +! Differs from aqsat by also calculating and returning +! gamma (l/cp)*(d(qsat)/dT) +! Input arrays temperature and pressure (dimensioned ii,kk). +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: ii + integer, intent(in) :: ilen + integer, intent(in) :: kk + integer, intent(in) :: kstart + integer, intent(in) :: kend + + real(r8), intent(in) :: t(ii,kk) + real(r8), intent(in) :: p(ii,kk) + +! +! Output arguments +! + real(r8), intent(out) :: es(ii,kk) + real(r8), intent(out) :: qs(ii,kk) + real(r8), intent(out) :: gam(ii,kk) +! +!---------------------------Local workspace----------------------------- +! + logical lflg + integer i + integer k + real(r8) omeps + real(r8) trinv + real(r8) tc + real(r8) weight + real(r8) hltalt + real(r8) hlatsb + real(r8) hlatvp + real(r8) tterm + real(r8) desdt +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do k=kstart,kend + do i=1,ilen + es(i,k) = min(p(i,k), estblf(t(i,k))) +! +! Saturation specific humidity +! + qs(i,k) = min(1.0_r8, epsqs*es(i,k)/(p(i,k)-omeps*es(i,k))) +! +! The following check is to avoid the generation of negative qs +! values which can occur in the upper stratosphere and mesosphere +! +! +! if (qs(i,k) < 0.0_r8) then +! qs(i,k) = 1.0_r8 +! es(i,k) = p(i,k) +! end if + end do + end do +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! + trinv = 0.0_r8 + if ((.not. icephs) .or. (ttrice == 0.0_r8)) go to 10 + trinv = 1.0_r8/ttrice +! + do k=kstart,kend + do i=1,ilen +! +! Weighting of hlat accounts for transition from water to ice +! polynomial expression approximates difference between es over +! water and es over ice from 0 to -ttrice (C) (min of ttrice is +! -40): required for accurate estimate of es derivative in transition +! range from ice to water also accounting for change of hlatv with t +! above freezing where constant slope is given by -2369 j/(kg c) =cpv - cw +! + tc = t(i,k) - tmelt + lflg = (tc >= -ttrice .and. tc < 0.0_r8) + weight = min(-tc*trinv,1.0_r8) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0_r8*tc + if (t(i,k) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & + & + tc*pcf(5)))) + else + tterm = 0.0_r8 + end if + desdt = hltalt*es(i,k)/(rgasv*t(i,k)*t(i,k)) + tterm*trinv + gam(i,k) = hltalt*qs(i,k)*p(i,k)*desdt/(cp*es(i,k)*(p(i,k) & + & - omeps*es(i,k))) + if (qs(i,k) == 1.0_r8) gam(i,k) = 0.0_r8 + end do + end do +! + go to 20 +! +! No icephs or water to ice transition +! +10 do k=kstart,kend + do i=1,ilen +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t(i,k)-tmelt) + if (icephs) then + hlatsb = hlatv + hlatf + else + hlatsb = hlatv + end if + if (t(i,k) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es(i,k)/(rgasv*t(i,k)*t(i,k)) + gam(i,k) = hltalt*qs(i,k)*p(i,k)*desdt/(cp*es(i,k)*(p(i,k) & + & - omeps*es(i,k))) + if (qs(i,k) == 1.0_r8) gam(i,k) = 0.0_r8 + end do + end do +! +20 return + end subroutine aqsatd + + subroutine vqsatd(t ,p ,es ,qs ,gam , len ) +!----------------------------------------------------------------------- +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT). The same +! function as qsatd, but operates on vectors of temperature and pressure +! +! Method: +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: len + real(r8), intent(in) :: t(len) + real(r8), intent(in) :: p(len) +! +! Output arguments +! + real(r8), intent(out) :: es(len) + real(r8), intent(out) :: qs(len) + real(r8), intent(out) :: gam(len) +! +!--------------------------Local Variables------------------------------ +! + logical lflg +! + integer i +! + real(r8) omeps + real(r8) trinv + real(r8) tc + real(r8) weight + real(r8) hltalt +! + real(r8) hlatsb + real(r8) hlatvp + real(r8) tterm + real(r8) desdt +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do i=1,len + es(i) = min(estblf(t(i)), p(i)) +! +! Saturation specific humidity +! + qs(i) = epsqs*es(i)/(p(i) - omeps*es(i)) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! + qs(i) = min(1.0_r8,qs(i)) +! +! if (qs(i) < 0.0_r8) then +! qs(i) = 1.0_r8 +! es(i) = p(i) +! end if + + end do +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! + trinv = 0.0_r8 + if ((.not. icephs) .or. (ttrice.eq.0.0_r8)) go to 10 + trinv = 1.0_r8/ttrice + do i=1,len +! +! Weighting of hlat accounts for transition from water to ice +! polynomial expression approximates difference between es over +! water and es over ice from 0 to -ttrice (C) (min of ttrice is +! -40): required for accurate estimate of es derivative in transition +! range from ice to water also accounting for change of hlatv with t +! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw +! + tc = t(i) - tmelt + lflg = (tc >= -ttrice .and. tc < 0.0_r8) + weight = min(-tc*trinv,1.0_r8) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0_r8*tc + if (t(i) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & + & + tc*pcf(5)))) + else + tterm = 0.0_r8 + end if + desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv + gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) + if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + end do + return +! +! No icephs or water to ice transition +! +10 do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + if (icephs) then + hlatsb = hlatv + hlatf + else + hlatsb = hlatv + end if + if (t(i) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) + if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + end do +! + return +! + end subroutine vqsatd + +!++xl + subroutine vqsatd_water(t, p, es, qs, gam, len) + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: len + real(r8), intent(in) :: t(len) + real(r8), intent(in) :: p(len) + +! +! Output arguments +! + real(r8), intent(out) :: es(len) + real(r8), intent(out) :: qs(len) + real(r8), intent(out) :: gam(len) + +! +!--------------------------Local Variables------------------------------ +! +! + integer i +! + real(r8) omeps + real(r8) hltalt +! + real(r8) hlatsb + real(r8) hlatvp + real(r8) desdt +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do i=1,len +#ifdef NEMS_GSM + es(i) = min(fpvsl(t(i)), p(i)) +#else + es(i) = min(polysvp(t(i),0), p(i)) +#endif +! +! Saturation specific humidity +! + qs(i) = min(1.0_r8, epsqs*es(i) / (p(i)-omeps*es(i))) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! +! qs(i) = min(1.0_r8,qs(i)) +! +! if (qs(i) < 0.0_r8) then +! qs(i) = 1.0_r8 +! es(i) = p(i) +! end if + + end do +! +! No icephs or water to ice transition +! + do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + hlatsb = hlatv + if (t(i) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) + if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + end do +! + return +! + end subroutine vqsatd_water + + function polysvp (T,typ) +! Compute saturation vapor pressure by using +! function from Goff and Gatch (1946) +! Polysvp returned in units of pa. +! T is input in units of K. +! type refers to saturation with respect to liquid (0) or ice (1) + +!!DONIFF Changed to Murphy and Koop (2005) (03/04/14) + + + real(r8) dum + + real(r8) t,polysvp + + integer typ + + + if (.TRUE.) then +!ice + if (typ == 1) then + polysvp = MurphyKoop_svp_ice(t) + end if + if (typ == 0) then + polysvp = MurphyKoop_svp_water(t) + end if + + else + +! ice + if (typ.eq.1) then + + + + polysvp = 10._r8**(-9.09718_r8*(273.16_r8/t-1._r8)-3.56654_r8* & + & log10(273.16_r8/t)+0.876793_r8*(1._r8-t/273.16_r8)+ & + & log10(6.1071_r8))*100._r8 + + end if + + + + if (typ.eq.0) then + polysvp = 10._r8**(-7.90298_r8*(373.16_r8/t-1._r8)+ 5.02808_r8* & + &log10(373.16_r8/t)- 1.3816e-7_r8*(10._r8**(11.344_r8*(1._r8-t/ & + &373.16_r8))-1._r8)+ 8.1328e-3_r8*(10._r8**(-3.49149_r8*(373.16_r8/ & + &t-1._r8))-1._r8)+ log10(1013.246_r8))*100._r8 + end if + + end if + + end function polysvp +!--xl + + + + integer function fqsatd(t ,p ,es ,qs ,gam , len ) + + + + + + integer, intent(in) :: len + real(r8), intent(in) :: t(len) + real(r8), intent(in) :: p(len) + + real(r8), intent(out) :: es(len) + real(r8), intent(out) :: qs(len) + real(r8), intent(out) :: gam(len) + + call vqsatd(t ,p ,es ,qs ,gam , len ) + fqsatd = 1 + return + end function fqsatd + + real(r8) function qsat_water(t,p) + + real(r8) t + real(r8) p + real(r8) es + real(r8) ps, ts, e1, e2, f1, f2, f3, f4, f5, f + + + + + + ps = 1013.246_r8 + ts = 373.16_r8 + e1 = 11.344_r8*(1.0_r8 - t/ts) + e2 = -3.49149_r8*(ts/t - 1.0_r8) + f1 = -7.90298_r8*(ts/t - 1.0_r8) + f2 = 5.02808_r8*log10(ts/t) + f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8 + f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8 + f5 = log10(ps) + f = f1 + f2 + f3 + f4 + f5 + es = (10.0_r8**f)*100.0_r8 + + qsat_water = epsqs*es/(p-(1.-epsqs)*es) + if(qsat_water < 0.) qsat_water = 1. + + end function qsat_water + + subroutine vqsat_water(t,p,qsat_water,len) + + integer, intent(in) :: len + real(r8) t(len) + real(r8) p(len) + real(r8) qsat_water(len) + real(r8) es + real(r8), parameter :: t0inv = 1._r8/273._r8 + real(r8) coef + integer :: i + + coef = hlatv/rgasv + do i=1,len + es = 611._r8*exp(coef*(t0inv-1./t(i))) + qsat_water(i) = epsqs*es/(p(i)-(1.-epsqs)*es) + if(qsat_water(i) < 0.) qsat_water(i) = 1. + enddo + + return + + end subroutine vqsat_water + + real(r8) function qsat_ice(t,p) + + real(r8) t + real(r8) p + real(r8) es + real(r8), parameter :: t0inv = 1._r8/273._r8 + es = 611.*exp((hlatv+hlatf)/rgasv*(t0inv-1./t)) + qsat_ice = epsqs*es/(p-(1.-epsqs)*es) + if(qsat_ice < 0.) qsat_ice = 1. + + end function qsat_ice + + subroutine vqsat_ice(t,p,qsat_ice,len) + + integer,intent(in) :: len + real(r8) t(len) + real(r8) p(len) + real(r8) qsat_ice(len) + real(r8) es + real(r8), parameter :: t0inv = 1._r8/273._r8 + real(r8) coef + integer :: i + + coef = (hlatv+hlatf)/rgasv + do i=1,len + es = 611.*exp(coef*(t0inv-1./t(i))) + qsat_ice(i) = epsqs*es/(p(i)-(1.-epsqs)*es) + if(qsat_ice(i) < 0.) qsat_ice(i) = 1. + enddo + + return + + end subroutine vqsat_ice + +! Sungsu +! Below two subroutines (vqsatd2_water,vqsatd2_water_single) are by Sungsu +! Replace 'gam -> dqsdt' +! Sungsu + + subroutine vqsatd2_water(t ,p ,es ,qs ,dqsdt , len ) + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: len + real(r8), intent(in) :: t(len) + real(r8), intent(in) :: p(len) + +! +! Output arguments +! + real(r8), intent(out) :: es(len) + real(r8), intent(out) :: qs(len) + + + real(r8), intent(out) :: dqsdt(len) + + +! +!--------------------------Local Variables------------------------------ +! +! + integer i +! + real(r8) omeps + real(r8) hltalt +! + real(r8) hlatsb + real(r8) hlatvp + real(r8) desdt + + + real(r8) gam(len) + + +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do i=1,len +#ifdef GEOS5 + es(i) = min(polysvp(t(i),0), p(i)) +#endif +#ifdef NEMS_GSM + es(i) = min(fpvsl(t(i)), p(i)) +#endif +! +! Saturation specific humidity +! + qs(i) = epsqs*es(i)/(p(i) - omeps*es(i)) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! + qs(i) = min(1.0_r8,qs(i)) +! +! if (qs(i) < 0.0_r8) then +! qs(i) = 1.0_r8 +! es(i) = p(i) +! end if + + end do +! +! No icephs or water to ice transition +! + do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + hlatsb = hlatv + if (t(i) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) + if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + + dqsdt(i) = (cp/hltalt)*gam(i) + + end do +! + return +! + end subroutine vqsatd2_water + + subroutine vqsatd2_water_single(t ,p ,es ,qs ,dqsdt) + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + + real(r8), intent(in) :: t, p + +! +! Output arguments +! + real(r8), intent(out) :: es, qs, dqsdt +! +!--------------------------Local Variables------------------------------ +! +! integer i +! + real(r8) omeps, hltalt, hlatsb, hlatvp, desdt, gam +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs +! do i=1,len +#ifdef GEOS5 + es = min(p, polysvp(t,0)) +#endif +#ifdef NEMS_GSM + es = min(p, fpvsl(t)) +#endif +! +! Saturation specific humidity +! + qs = min(1.0_r8, epsqs*es/(p-omeps*es)) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! +! if (qs < 0.0_r8) then +! qs = 1.0_r8 +! es = p +! end if +! end do +! +! No icephs or water to ice transition +! +! do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t-tmelt) + hlatsb = hlatv + if (t < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es/(rgasv*t*t) + gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) + if (qs >= 1.0_r8) gam = 0.0_r8 + + dqsdt = (cp/hltalt)*gam + +! end do +! + return +! + end subroutine vqsatd2_water_single + + + subroutine vqsatd2(t ,p ,es ,qs ,dqsdt , len ) +!----------------------------------------------------------------------- +! Sungsu : This is directly copied from 'vqsatd' but 'dqsdt' is output +! instead of gam for use in Sungsu's equilibrium stratiform +! macrophysics scheme. +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT). The same +! function as qsatd, but operates on vectors of temperature and pressure +! +! Method: +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: len + real(r8), intent(in) :: t(len) + real(r8), intent(in) :: p(len) +! +! Output arguments +! + real(r8), intent(out) :: es(len) + real(r8), intent(out) :: qs(len) + + + real(r8), intent(out) :: dqsdt(len) + + +! +!--------------------------Local Variables------------------------------ +! + logical lflg +! + integer i +! + real(r8) omeps + real(r8) trinv + real(r8) tc + real(r8) weight + real(r8) hltalt +! + real(r8) hlatsb + real(r8) hlatvp + real(r8) tterm + real(r8) desdt + + + real(r8) gam(len) + +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + do i=1,len +#ifdef GEOS5 + es(i) = min(p(i), estblf(t(i))) +#endif +#ifdef NEMS_GSM + es(i) = min(p(i), fpvsi(t(i))) +#endif +! +! Saturation specific humidity +! + qs(i) = epsqs*es(i)/(p(i) - omeps*es(i)) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! + qs(i) = min(1.0_r8,qs(i)) +! +! if (qs(i) < 0.0_r8) then +! qs(i) = 1.0_r8 +! es(i) = p(i) +! end if + end do +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! + trinv = 0.0_r8 + if ((.not. icephs) .or. (ttrice == 0.0_r8)) go to 10 + trinv = 1.0_r8/ttrice + do i=1,len +! +! Weighting of hlat accounts for transition from water to ice +! polynomial expression approximates difference between es over +! water and es over ice from 0 to -ttrice (C) (min of ttrice is +! -40): required for accurate estimate of es derivative in transition +! range from ice to water also accounting for change of hlatv with t +! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw +! + tc = t(i) - tmelt + lflg = (tc >= -ttrice .and. tc < 0.0_r8) + weight = min(-tc*trinv,1.0_r8) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0_r8*tc + if (t(i) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & + & + tc*pcf(5)))) + else + tterm = 0.0_r8 + end if + desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + tterm*trinv + gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) + if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + + dqsdt(i) = (cp/hltalt)*gam(i) + + end do + return +! +! No icephs or water to ice transition +! +10 do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t(i)-tmelt) + if (icephs) then + hlatsb = hlatv + hlatf + else + hlatsb = hlatv + end if + if (t(i) < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es(i)/(rgasv*t(i)*t(i)) + gam(i) = hltalt*qs(i)*p(i)*desdt/(cp*es(i)*(p(i) - omeps*es(i))) + if (qs(i) == 1.0_r8) gam(i) = 0.0_r8 + + dqsdt(i) = (cp/hltalt)*gam(i) + + end do +! + return +! + end subroutine vqsatd2 + + +! Below routine is by Sungsu + + subroutine vqsatd2_single(t ,p ,es ,qs ,dqsdt) +!----------------------------------------------------------------------- +! Sungsu : This is directly copied from 'vqsatd' but 'dqsdt' is output +! instead of gam for use in Sungsu's equilibrium stratiform +! macrophysics scheme. +! +! Purpose: +! Utility procedure to look up and return saturation vapor pressure from +! precomputed table, calculate and return saturation specific humidity +! (g/g), and calculate and return gamma (l/cp)*(d(qsat)/dT). The same +! function as qsatd, but operates on vectors of temperature and pressure +! +! Method: +! +! Author: J. Hack +! +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: t, p +! +! Output arguments +! + real(r8), intent(out) :: es, qs, dqsdt +! +!--------------------------Local Variables------------------------------ +! + logical lflg +! +! integer i ! index for vector calculations +! + real(r8) omeps + real(r8) trinv + real(r8) tc + real(r8) weight + real(r8) hltalt +! + real(r8) hlatsb + real(r8) hlatvp + real(r8) tterm + real(r8) desdt + + real(r8) gam + +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs + +! do i=1,len + +#ifdef GEOS5 + es = estblf(t) +#endif +#ifdef NEMS_GSM + es = min(fpvs(t), p) +#endif +! +! Saturation specific humidity +! + qs = epsqs*es/(p - omeps*es) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! + qs = min(1.0_r8,qs) +! +! if (qs < 0.0_r8) then +! qs = 1.0_r8 +! es = p +! end if + +! end do +! +! "generalized" analytic expression for t derivative of es +! accurate to within 1 percent for 173.16 < t < 373.16 +! + trinv = 0.0_r8 + if ((.not. icephs) .or. (ttrice == 0.0_r8)) go to 10 + trinv = 1.0_r8/ttrice + +! do i=1,len +! +! Weighting of hlat accounts for transition from water to ice +! polynomial expression approximates difference between es over +! water and es over ice from 0 to -ttrice (C) (min of ttrice is +! -40): required for accurate estimate of es derivative in transition +! range from ice to water also accounting for change of hlatv with t +! above freezing where const slope is given by -2369 j/(kg c) = cpv - cw +! + tc = t - tmelt + lflg = (tc >= -ttrice .and. tc < 0.0_r8) + weight = min(-tc*trinv,1.0_r8) + hlatsb = hlatv + weight*hlatf + hlatvp = hlatv - 2369.0_r8*tc + if (t < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + if (lflg) then + tterm = pcf(1) + tc*(pcf(2) + tc*(pcf(3) + tc*(pcf(4) & + & + tc*pcf(5)))) + else + tterm = 0.0_r8 + end if + desdt = hltalt*es/(rgasv*t*t) + tterm*trinv + gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) + if (qs == 1.0_r8) gam = 0.0_r8 + + dqsdt = (cp/hltalt)*gam + +! end do + return +! +! No icephs or water to ice transition +! + +10 continue + +!10 do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hlatvp = hlatv - 2369.0_r8*(t-tmelt) + if (icephs) then + hlatsb = hlatv + hlatf + else + hlatsb = hlatv + end if + if (t < tmelt) then + hltalt = hlatsb + else + hltalt = hlatvp + end if + desdt = hltalt*es/(rgasv*t*t) + gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) + if (qs == 1.0_r8) gam = 0.0_r8 + + dqsdt = (cp/hltalt)*gam + + +! end do +! + return +! + end subroutine vqsatd2_single + +!---------------------------------------------------------------------- + +!---------------------------------------------------------------------- + + subroutine gffgch(t ,es ,tmelt ,itype ) +!----------------------------------------------------------------------- +! +! Purpose: +! Computes saturation vapor pressure over water and/or over ice using +! Goff & Gratch (1946) relationships. +! +! +! Method: +! T (temperature), and itype are input parameters, while es (saturation +! vapor pressure) is an output parameter. The input parameter itype +! serves two purposes: a value of zero indicates that saturation vapor +! pressures over water are to be returned (regardless of temperature), +! while a value of one indicates that saturation vapor pressures over +! ice should be returned when t is less than freezing degrees. If itype +! is negative, its absolute value is interpreted to define a temperature +! transition region below freezing in which the returned +! saturation vapor pressure is a weighted average of the respective ice +! and water value. That is, in the temperature range 0 => -itype +! degrees c, the saturation vapor pressures are assumed to be a weighted +! average of the vapor pressure over supercooled water and ice (all +! water at 0 c; all ice at -itype c). Maximum transition range => 40 c +! +! Author: J. Hack +! +!----------------------------------------------------------------------- + + + + + + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: t ,tmelt +! +! Output arguments +! + integer, intent(inout) :: itype + + real(r8), intent(out) :: es +! +!---------------------------Local variables----------------------------- +! + real(r8) e1 + real(r8) e2 + real(r8) eswtr + real(r8) f + real(r8) f1 + real(r8) f2 + real(r8) f3 + real(r8) f4 + real(r8) f5 + real(r8) ps + real(r8) t0 + real(r8) term1 + real(r8) term2 + real(r8) term3 + real(r8) tr + real(r8) ts + real(r8) weight + integer itypo +! +!----------------------------------------------------------------------- +! +! Check on whether there is to be a transition region for es +! + if (itype < 0) then + tr = abs(real(itype,r8)) + itypo = itype + itype = 1 + else + tr = 0.0_r8 + itypo = itype + end if + if (tr > 40.0_r8) then + write(iulog,900) tr + + end if +! + if(t < (tmelt - tr) .and. itype == 1) go to 10 +! +! Water +! + ps = 1013.246_r8 + ts = 373.16_r8 + e1 = 11.344_r8*(1.0_r8 - t/ts) + e2 = -3.49149_r8*(ts/t - 1.0_r8) + f1 = -7.90298_r8*(ts/t - 1.0_r8) + f2 = 5.02808_r8*log10(ts/t) + f3 = -1.3816_r8*(10.0_r8**e1 - 1.0_r8)/10000000.0_r8 + f4 = 8.1328_r8*(10.0_r8**e2 - 1.0_r8)/1000.0_r8 + f5 = log10(ps) + f = f1 + f2 + f3 + f4 + f5 + es = (10.0_r8**f)*100.0_r8 + eswtr = es +! + if(t >= tmelt .or. itype == 0) go to 20 +! +! Ice +! +10 continue + t0 = tmelt + term1 = 2.01889049_r8/(t0/t) + term2 = 3.56654_r8*log(t0/t) + term3 = 20.947031_r8*(t0/t) + es = 575.185606e10_r8*exp(-(term1 + term2 + term3)) +! + if (t < (tmelt - tr)) go to 20 +! +! Weighted transition between water and ice +! + weight = min((tmelt - t)/tr,1.0_r8) + es = weight*es + (1.0_r8 - weight)*eswtr +! +20 continue + itype = itypo + return +! +900 format('GFFGCH: FATAL ERROR ******************************',/, & + & 'TRANSITION RANGE FOR WATER TO ICE SATURATION VAPOR', ' PRESSURE, & + & TR, EXCEEDS MAXIMUM ALLOWABLE VALUE OF', ' 40.0 DEGREES C',/, & + & ' TR = ',f7.2) +! + end subroutine gffgch + + +!!DONIF USe Murphy and Koop (2005) (Written by Andrew Gettelman) + + function MurphyKoop_svp_water(tx) result(es) + real(r8), intent(in) :: tx + real(r8) :: es + real(r8):: t + + t=min(tx, 332.0_r8) + t=max(123.0_r8, tx) + + es = exp(54.842763_r8 - (6763.22_r8 / t) - (4.210_r8 * log(t)) + & + & (0.000367_r8 * t) + (tanh(0.0415_r8 * (t - 218.8_r8)) * & + & (53.878_r8 - (1331.22_r8 / t) - (9.44523_r8 * log(t)) + & + & 0.014025_r8 * t))) + + end function MurphyKoop_svp_water + + function MurphyKoop_svp_ice(tx) result(es) + real(r8), intent(in) :: tx + real(r8) :: t + real(r8) :: es + + t=max(100.0_r8, tx) + t=min(274.0_r8, tx) + + + es = exp(9.550426_r8 - (5723.265_r8 / t) + (3.53068_r8 * & + & log(t)) - (0.00728332_r8 * t)) + + end function MurphyKoop_svp_ice +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine vqsatd2_ice_single(t ,p ,es ,qs ,dqsdt) + +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + real(r8), intent(in) :: t, p +! +! Output arguments +! + real(r8), intent(out) :: es, qs, dqsdt + +! +!--------------------------Local Variables------------------------------ +! +! integer i +! + real(r8) omeps, hltalt, hlatsb, hlatvp, desdt, gam +! +!----------------------------------------------------------------------- +! + omeps = 1.0_r8 - epsqs +! do i=1,len +#ifdef GEOS5 + es = min(polysvp(t,1),p) +#endif +#ifdef NEMS_GSM + es = min(fpvsi(t),p) +#endif +! +! Saturation specific humidity +! + qs = min(1.0_r8, epsqs*es/(p-omeps*es)) +! +! The following check is to avoid the generation of negative +! values that can occur in the upper stratosphere and mesosphere +! +! if (qs < 0.0_r8) then +! qs = 1.0_r8 +! es = p +! end if +! end do +! +! No icephs or water to ice transition +! +! do i=1,len +! +! Account for change of hlatv with t above freezing where +! constant slope is given by -2369 j/(kg c) = cpv - cw +! + hltalt = hlatv + hlatf + desdt = hltalt*es/(rgasv*t*t) + if (qs < 1.0_r8) then + gam = hltalt*qs*p*desdt/(cp*es*(p - omeps*es)) + else + gam = 0.0_r8 + endif + + dqsdt = (cp/hltalt)*gam + +! end do +! + return +! + end subroutine vqsatd2_ice_single + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + end module wv_saturation +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/gsmphys/ysupbl.F90 b/gsmphys/ysupbl.F90 new file mode 100644 index 00000000..aa36ffd1 --- /dev/null +++ b/gsmphys/ysupbl.F90 @@ -0,0 +1,1519 @@ +!------------------------------------------------------------------------------- +! + subroutine ysupbl(ix,im,km,ndiff,ntcw,ntiw, & + vtnp,utnp,ttnp,qtnp, & + ux,vx,tx,qx,p2di,p2d,pi2d, & + phi2di,psfcpa, & + htrsw,htrlw,xmu, & + z0rl,ust,hpbl,hgamt,hfxpbl,psim,psih, & + islmsk,heat,evap,wspd,br, & + dusfc,dvsfc,dtsfc,dqsfc, & + dt,kpbl1d,u10,v10, & + kinver,xkzm_m_in,xkzm_h_in,xkzm_s,xkzminv, & + dspheat,ent_fac,dkt,flux_cg,flux_en, & + pfac_q,brcr_ub,rlam,afac,bfac,hpbl_cr, & + tnl_fac, qnl_fac, unl_fac) +!------------------------------------------------------------------------------- + use machine, only : kind_phys +! use mpp_mod, only: mpp_pe + use physcons, cp=>con_cp, g=>con_g, rovcp=>con_rocp, rd=>con_rd, rv=>con_rv,& + rovg=>con_rog, ep1=>con_fvirt, ep2=>con_eps, xlv=>con_hvap +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +! this code is a revised vertical diffusion package ("ysupbl") +! with a nonlocal turbulent mixing in the pbl after "mrfpbl". +! the ysupbl (hong et al. 2006) is based on the study of noh +! et al.(2003) and accumulated realism of the behavior of the +! troen and mahrt (1986) concept implemented by hong and pan(1996). +! the major ingredient of the ysupbl is the inclusion of an explicit +! treatment of the entrainment processes at the entrainment layer. +! this routine uses an implicit approach for vertical flux +! divergence and does not require "miter" timesteps. +! it includes vertical diffusion in the stable atmosphere +! and moist vertical diffusion in clouds. +! +! mrfpbl: +! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) +! fall 1996 +! +! ysupbl: +! coded by song-you hong (yonsei university) and implemented by +! song-you hong (yonsei university) and jimy dudhia (ncar) +! summer 2002 +! +! further modifications : +! an enhanced stable layer mixing, april 2008 +! ==> increase pbl height when sfc is stable (hong 2010) +! pressure-level diffusion, april 2009 +! ==> negligible differences +! implicit forcing for momentum with clean up, july 2009 +! ==> prevents model blowup when sfc layer is too low +! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 +! ==> prevents model blowup when delz is extremely large +! revised prandtl number at surface, peggy lemone, feb 2010 +! ==> increase kh, decrease mixing due to counter-gradient term +! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 +! ==> reduce the thermal strength when z1 < 0.1 h +! revised prandtl number for free convection, dudhia, mar 2012 +! ==> pr0 = 1 + bke (=0.272) when newtral, kh is reduced +! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 +! ==> weaker mixing when stable, and les resolution in vertical +! gz1oz0 is removed, and phim phih are ln(z1/z0)-phim,h, hong, mar 2012 +! ==> consider thermal z0 when differs from mechanical z0 +! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 +! ==> wscale becomes small with height, and less mixing in stable bl +! revision in background diffusion (kzo), jan 2016 +! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for +! internal wave mixing of large et al. (1994), songyou hong, feb 2016 +! ==> alleviate superious excessive mixing when delz is large +! Added minimum diffusion (a bound, not additional background) and +! dissipative heating from the GFS EDMF scheme. Hailey Shin, feb 2018. +! +! references: +! +! hong (2010) quart. j. roy. met. soc +! hong, noh, and dudhia (2006), mon. wea. rev. +! hong and pan (1996), mon. wea. rev. +! noh, chun, hong, and raasch (2003), boundary layer met. +! troen and mahrt (1986), boundary layer met. +! +!------------------------------------------------------------------------------- +! + integer,parameter :: nqci = 2 + integer,parameter :: imvdif = 1 + integer,parameter :: ysu_topdown_pblmix = 1 + real(kind=kind_phys),parameter :: karman = 0.4 + real(kind=kind_phys),parameter :: xkzminm = 0.1,xkzminh = 0.01 + real(kind=kind_phys),parameter :: xkzmin = 0.01,xkzmax = 1000. + real(kind=kind_phys),parameter :: rimin = -100. +! real(kind=kind_phys),parameter :: rlam = 30.,prmin = 0.25,prmax = 4. + real(kind=kind_phys),parameter :: prmin = 0.25,prmax = 4. +! real(kind=kind_phys),parameter :: brcr_ub = 0.0,brcr_sb = 0.25 + real(kind=kind_phys),parameter :: brcr_sb = 0.25 + real(kind=kind_phys),parameter :: cori = 1.e-4 +! real(kind=kind_phys),parameter :: afac = 6.8,bfac = 6.8 + real(kind=kind_phys),parameter :: pfac = 2.0 !,pfac_q = 2.0 + real(kind=kind_phys),parameter :: phifac = 8.,sfcfrac = 0.1 + real(kind=kind_phys),parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 + real(kind=kind_phys),parameter :: h1 = 0.33333335, h2 = 0.6666667 + real(kind=kind_phys),parameter :: zfmin = 1.e-8 + real(kind=kind_phys),parameter :: aphi5 = 5.,aphi16 = 16. + real(kind=kind_phys),parameter :: tmin=1.e-2 + real(kind=kind_phys),parameter :: gamcrt = 3.,gamcrq = 2.e-3 + real(kind=kind_phys),parameter :: xka = 2.4e-5 + real(kind=kind_phys),parameter :: rcl=1.0 + real(kind=kind_phys),parameter :: dw2min=0.0001 +! + integer,intent(in ) :: ix,im,km,ndiff,ntcw,ntiw +! + real(kind=kind_phys),intent(in ) :: dt + real(kind=kind_phys),intent(in ) :: xkzm_m_in,xkzm_h_in,xkzm_s,xkzminv,ent_fac,pfac_q + real(kind=kind_phys),intent(in ) :: brcr_ub,rlam,afac,bfac,hpbl_cr + real(kind=kind_phys),intent(in ) :: tnl_fac, qnl_fac, unl_fac ! controls non-local mixing + +! + real(kind=kind_phys),dimension( 1:ix , 1:km ) , & + intent(in ) :: ux, & !! Statein%ugrs (ix,km) + vx, & !! + tx, & !! + htrsw, & !! Radtend%htrsw (ix,km) + htrlw !! +! + real(kind=kind_phys),dimension( 1:ix , 1:km *ndiff ) , & + intent(in ) :: qx !! qgrs +! + real(kind=kind_phys),dimension( 1:im , 1:km ) , & + intent(inout) :: vtnp, & !! dvdt (im,km) + utnp, & !! + ttnp + real(kind=kind_phys),dimension( 1:im , 1:km *ndiff ) , & + intent(inout) :: qtnp +! + real(kind=kind_phys),dimension( 1:ix , 1:km +1 ) , & + intent(in ) :: p2di, & !! Statein%prsi + phi2di !! Statein%phii +! + real(kind=kind_phys),dimension( 1:ix , 1:km ) , & + intent(in ) :: p2d, & !! Statein%prsl + pi2d !! Statein%prslk +! + real(kind=kind_phys),dimension( 1:im ) , & + intent(in ) :: ust, & !! Sfcprop%uustar + z0rl, & !! Sfcprop%zorl + xmu !! zenith angle adjustment + real(kind=kind_phys),dimension( 1:im ) , & + intent(in ) :: heat, & !! heat flux + evap !! moisture flux + real(kind=kind_phys),dimension( 1:im ) , & + intent(in ) :: br, & !! rb + psim, & !! Sfcprop%ffmm + psih, & !! Sfcprop%ffhh + wspd, & !! wind + psfcpa !! pgr +! + real(kind=kind_phys),dimension( 1:im ) , & + intent(inout) :: hpbl, & !! Diag%hpbl + dusfc,dvsfc, & !! dusfc1, dvsfc1 + dtsfc,dqsfc !! dtsfc1, dqsfc1 + real(kind=kind_phys),dimension( 1:im ),intent(out ) :: hgamt, hfxpbl +! + integer,dimension( 1:im ),intent(in ) :: islmsk, kinver + integer,dimension( 1:im ),intent(out ) :: kpbl1d + logical,intent(in ) :: dspheat +! +! local vars +! + real(kind=kind_phys),dimension( 1:im ) :: xland, & + hfx, & + qfx +! + real(kind=kind_phys),dimension( 1:im ) :: hol, & + znt + real(kind=kind_phys),dimension( 1:im , 1:km+1 ) :: zq, & + p2diorg +! + real(kind=kind_phys),dimension( 1:im , 1:km ) :: & + thx,thvx,thlix, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za + real(kind=kind_phys),dimension( 1:im , 1:km ) :: rthraten +! + real(kind=kind_phys),dimension( 1:im ) :: & + rhox, & + govrth, & + zl1,thermal, & + wscale, & + hgamq, & + brdn,brup, & + phim,phih, & + prpbl, & + wspd1,thermalli +! + real(kind=kind_phys),dimension( 1:im , 1:km ) :: xkzm,xkzh, & + f1,f2, & + r1,r2, & + ad,au, & + cu, & + al, & + xkzq, & + zfac, & + rhox2, & + hgamt2 +! + real(kind=kind_phys),dimension( 1:im ) , & !! Diag%u10m + intent(in ) :: u10, & !! Diag%v10m + v10 + real(kind=kind_phys),dimension( 1:im ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro +! + real(kind=kind_phys),dimension( 1:im , 1:km , ndiff) :: r3,f3 + real(kind=kind_phys),dimension( 1:ix , 1:km , nqci ) :: qxci + integer, dimension( 1:im ) :: kpbl,kpblold + integer, dimension( 1:im ) :: kx1 +! + logical, dimension( 1:im ) :: pblflg, & + sfcflg, & + stable, & + cloudflg + + real(kind=kind_phys),dimension( 1:im, 1:km), intent(OUT), OPTIONAL :: dkt + real(kind=kind_phys),dimension( 1:im, 1:km), intent(OUT)::flux_cg, flux_en + +! Local: + real(kind=kind_phys),dimension( 1:im , 1:km ) :: diss +! SJL + real(kind=kind_phys),dimension( 1:ix , 1:km ) :: p2m + + logical :: definebrup +! + integer :: n,i,k,l,ic,is,kk + integer :: klpbl, ktrace1, ktrace2, ktrace3 + integer :: its,ite,kts,kte +! +! + real(kind=kind_phys) :: dt2,rdt,spdk2,fm,fh,hol1 + real(kind=kind_phys) :: gamfac,vpert,prnum,prnum0 + real(kind=kind_phys) :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri + real(kind=kind_phys) :: brint,dtodsd,dtodsu,rdz + real(kind=kind_phys) :: dsdzt,dsdzq,dsdz2,rlamdz + real(kind=kind_phys) :: utend,vtend,ttend,qtend + real(kind=kind_phys) :: dtstep,govrthv + real(kind=kind_phys) :: cont, conq, conw, conwrc +! + real(kind=kind_phys),dimension( 1:im , 1:km ) :: wscalek, & + wscalek2 + real(kind=kind_phys),dimension( 1:im ) :: wstar, & + delta + real(kind=kind_phys),dimension( 1:im , 1:km ) :: xkzml,xkzhl, & + zfacent,entfac + real(kind=kind_phys),dimension( 1:im ) :: ust3, & + wstar3, & + wstar3_2, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + qfxpbl, & + ufxpbl,vfxpbl, & + dthvx +! + real(kind=kind_phys),dimension( 1:im ) :: uox,vox + real(kind=kind_phys) :: ptem + real(kind=kind_phys) :: xkzm_m,xkzm_h,xkzm_fac + real(kind=kind_phys) :: dw2,shr2,ti,bf,tem,tem2 +! + real(kind=kind_phys) :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & + rcldb,bruptmp,radflux +! +!------------------------------------------------------------------------------- +! + its = 1 + ite = im + kts = 1 + kte = km + klpbl = kte +! + cont=cp/g + conq=xlv/g + conw=1./g + conwrc = conw*sqrt(rcl) + conpr = bfac*karman*sfcfrac +! + xkzm_fac = 0.5 + xkzm_m = xkzm_m_in*xkzm_fac + xkzm_h = xkzm_h_in*xkzm_fac +! +! k-start index for tracer diffusion +! + ktrace1 = 0 + ktrace2 = 0 + kte*(ntcw-1) + ktrace3 = 0 + kte*(ntiw-1) +! + do k = kts,kte + do i = its,ite + rthraten(i,k) = (htrsw(i,k)*xmu(i)+htrlw(i,k))/pi2d(i,k) !converts temp/s to theta/s + enddo + enddo +! + do k = kts,kte + do i = its,ite + qxci(i,k,1:nqci) = 0.0 + if(ntcw > 0) qxci(i,k,1) = qx(i,ktrace2+k) + if(ntiw > 0) qxci(i,k,2) = qx(i,ktrace3+k) + enddo + enddo +! + do i = its,ite + znt(i) = 0.01*z0rl(i) + enddo +! + do k = kts,kte + do i = its,ite + thx(i,k) = tx(i,k)/pi2d(i,k) +! thlix(i,k) = (tx(i,k)-xlv*qxci(i,k,1)/cp-2.834E6*qxci(i,k,2)/cp)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-(xlv*qxci(i,k,1)+2.834E6*qxci(i,k,2))/cp) / pi2d(i,k) + enddo + enddo +! + do k = kts,kte + do i = its,ite + tvcon = (1.+ep1*qx(i,k)) + thvx(i,k) = thx(i,k)*tvcon + enddo + enddo +! + do i = its,ite + tvcon = (1.+ep1*qx(i,1)) + rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) + govrth(i) = g/thx(i,1) + enddo +! +!-----compute the height of full- and half-sigma levels above ground +! level, and the layer thicknesses. +! + do k = kts,kte + do i = its,ite + zq(i,k) = phi2di(i,k)/g + if(k.eq.kte) zq(i,k+1) = phi2di(i,k+1)/g + tvcon = (1.+ep1*qx(i,k)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) +! SJL + p2m(i,k) = 0.5*(p2di(i,k) + p2di(i,k+1)) + enddo + enddo +! + do k = kts,kte + do i = its,ite + za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) + dzq(i,k) = zq(i,k+1)-zq(i,k) + del(i,k) = p2di(i,k)-p2di(i,k+1) + p2diorg(i,k) = p2di(i,k) + if(k.eq.kte) p2diorg(i,k+1) = p2di(i,k+1) + enddo + enddo +! + do i = its,ite + dza(i,1) = za(i,1) + enddo +! + do k = kts+1,kte + do i = its,ite + dza(i,k) = za(i,k)-za(i,k-1) + enddo + enddo +! + do i = its,ite + uox(i) = 0.0 + vox(i) = 0.0 + xland(i) = 1 + if(islmsk(i).eq.0) xland(i) = 2 + hfx(i) = heat(i)*rhox(i)*cp + qfx(i) = evap(i)*rhox(i) + enddo + +! +! +!-----initialize vertical tendencies +! + do i = its,ite +! wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9 + wspd1(i) = sqrt((ux(i,1)-uox(i))**2 + (vx(i,1)-vox(i))**2)+1.e-9 + enddo +! +!---- compute vertical diffusion +! +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! compute preliminary variables +! + dtstep = dt +! dt2 = 2.*dtstep + dt2 = dtstep + rdt = 1./dt2 +! + do i = its,ite + bfxpbl(i) = 0.0 + hfxpbl(i) = 0.0 + qfxpbl(i) = 0.0 + ufxpbl(i) = 0.0 + vfxpbl(i) = 0.0 + hgamu(i) = 0.0 + hgamv(i) = 0.0 + delta(i) = 0.0 + wstar3_2(i) = 0.0 + enddo +! + do k = kts,klpbl + do i = its,ite + wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 + enddo + enddo +! + do k = kts,klpbl + do i = its,ite + zfac(i,k) = 0.0 + enddo + enddo +! +!<--- background vertical diffusivity (same as in GFS) +! +! do k = kts,klpbl-1 +! do i = its,ite +! xkzom(i,k) = xkzminm +! xkzoh(i,k) = xkzminh +! enddo +! enddo +! + do i = its,ite + kx1(i) = 1 + enddo +! + do k = kts,kte + do i = its,ite + xkzoh(i,k) = 0.0 + xkzom(i,k) = 0.0 + enddo + enddo +! + do k = kts,kte-1 + do i = its,ite + if (k.lt.kinver(i)) then + ptem = p2di(i,k+1)/p2di(i,kts) + tem1 = 1.0 - ptem + tem1 = tem1 * tem1 * 10.0 + xkzoh(i,k) = xkzm_h * min(1.0, exp(-tem1)) + if (ptem.ge.xkzm_s) then + xkzom(i,k) = xkzm_m + kx1(i) = k + 1 + else + if (k.eq.kx1(i) .and. k.gt.kts) then + tem1 = 1.0 - p2di(i,k+1)/p2di(i,k) + else + tem1 = 1.0 - p2di(i,k+1)/p2di(i,kts) + endif + tem1 = tem1 * tem1 * 5.0 + xkzom(i,k) = xkzm_m * min(1.0, exp(-tem1)) + endif + endif + enddo + enddo +! + do k = kts,kte/2 + do i = its,ite + if(zq(i,k+1) .gt. 250.) then + tem1 = (tx(i,k+1)-tx(i,k))/(za(i,k+1)-za(i,k)) + if(tem1 .gt. 1.e-5) then + xkzoh(i,k) = min(xkzoh(i,k),xkzminv) + endif + endif + enddo + enddo +! + do i = its,ite + dusfc(i) = 0. + dvsfc(i) = 0. + dtsfc(i) = 0. + dqsfc(i) = 0. + enddo +! + do i = its,ite + hgamt(i) = 0. + hgamq(i) = 0. + wscale(i) = 0. + kpbl(i) = 1 + hpbl(i) = zq(i,1) + zl1(i) = za(i,1) + thermal(i)= thvx(i,1) + thermalli(i) = thlix(i,1) + pblflg(i) = .true. + sfcflg(i) = .true. +! sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) + sflux(i) = hfx(i)/(rhox(i)*cp) + qfx(i)/rhox(i)*ep1*thx(i,1) + if(br(i).gt.0.0) sfcflg(i) = .false. + enddo +! +! compute the first guess of pbl height +! + do i = its,ite + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) +! brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + brup(i) = (thvx(i,k)-thermal(i))*g*za(i,k)/(thvx(i,1)*spdk2) + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + enddo +! + do i = its,ite + fm = psim(i) + fh = psih(i) + zol1(i) = max(br(i)*fm*fm/fh,rimin) + if(sfcflg(i))then + zol1(i) = min(zol1(i),-zfmin) + else + zol1(i) = max(zol1(i),zfmin) + endif + hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac + if(sfcflg(i))then + phim(i) = (1.-aphi16*hol1)**(-1./4.) + phih(i) = (1.-aphi16*hol1)**(-1./2.) + bfx0 = max(sflux(i),0.) +! hfx0 = max(hfx(i)/rhox(i)/cp,0.) + hfx0 = max(hfx(i)/(rhox(i)*cp), 0.) + qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) + wstar3(i) = (govrth(i)*bfx0*hpbl(i)) + wstar(i) = (wstar3(i))**h1 + else + phim(i) = (1.+aphi5*hol1) + phih(i) = phim(i) + wstar(i) = 0. + wstar3(i) = 0. + endif + ust3(i) = ust(i)**3. + wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + enddo +! +! compute the surface variables for pbl height estimation +! under unstable conditions +! + do i = its,ite + if(sfcflg(i).and.sflux(i).gt.0.0)then ! rb < 0 .and. sflux > 0 +! gamfac = bfac/rhox(i)/wscale(i) + gamfac = bfac / (rhox(i)*wscale(i)) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac + thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + hgamt(i) = max(hgamt(i),0.0) + hgamq(i) = max(hgamq(i),0.0) +! brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) + brint = -15.9*ust(i)*ust(i)*wstar3(i)/(wspd(i)*wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + else + pblflg(i) = .false. + endif + enddo +! +! enhance the pbl height by considering the thermal +! + do i = its,ite + if(pblflg(i))then + kpbl(i) = 1 + hpbl(i) = zq(i,1) + endif + enddo +! + do i = its,ite + if(pblflg(i))then + stable(i) = .false. + brup(i) = br(i) + brcr(i) = brcr_ub + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i).and.pblflg(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) +! brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + brup(i) = (thvx(i,k)-thermal(i))*g*za(i,k)/(thvx(i,1)*spdk2) + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! +! enhance pbl by theta-li +! + if (ysu_topdown_pblmix.eq.1)then + do i = its,ite + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), kte-1 + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) +! bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 + bruptmp = (thlix(i,k)-thermalli(i))*g*za(i,k)/(thlix(i,1)*spdk2) + stable(i) = bruptmp.ge.brcr(i) + if (definebrup) then + kpbl(i) = k + brup(i) = bruptmp + definebrup=.false. + endif + if (.not.stable(i)) then !overwrite brup brdn values + brdn(i)=bruptmp + definebrup=.true. + pblflg(i)=.true. + endif + enddo + enddo + endif + + do i = its,ite + if(pblflg(i)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1) pblflg(i) = .false. + endif + enddo +! +! stable boundary layer (rb > 0 .and. hpbl < zq(2) ) +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + brup(i) = br(i) + stable(i) = .false. + else + stable(i) = .true. + endif + enddo +! + do i = its,ite + if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then ! ocean + wspd10 = u10(i)*u10(i) + v10(i)*v10(i) + wspd10 = sqrt(wspd10) + ross = wspd10 / (cori*znt(i)) + brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) + endif + enddo +! + do i = its,ite + if(.not.stable(i))then + if((xland(i)-1.5).ge.0)then ! ocean + brcr(i) = brcr_sbro(i) + else + brcr(i) = brcr_sb + endif + endif + enddo +! + do k = 2,klpbl + do i = its,ite + if(.not.stable(i))then + brdn(i) = brup(i) + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) +! brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 + brup(i) = (thvx(i,k)-thermal(i))*g*za(i,k)/(thvx(i,1)*spdk2) + kpbl(i) = k + stable(i) = brup(i).gt.brcr(i) + endif + enddo + enddo +! + do i = its,ite + if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then + k = kpbl(i) + if(brdn(i).ge.brcr(i))then + brint = 0. + elseif(brup(i).le.brcr(i))then + brint = 1. + else + brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) + endif + hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) + if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 + if(kpbl(i).le.1 .or. hpbl(i) < hpbl_cr) pblflg(i) = .false. + endif + enddo +! +! estimate the entrainment parameters +! + do i = its,ite + cloudflg(i)=.false. + if(pblflg(i)) then + k = kpbl(i) - 1 + wm3 = wstar3(i) + 5. * ust3(i) + wm2(i) = wm3**h2 +! bfxpbl(i) = -ent_fac*thvx(i,1)/g*wm3/hpbl(i) +! bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + bfxpbl(i) = -ent_fac*thvx(i,1)*wm3/(g*hpbl(i)) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + if((qxci(i,k,1)+qxci(i,k,2)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then + if ( kpbl(i) .ge. 2) then + cloudflg(i)=.true. + templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) + temps=templ + ((qx(i,k)+qxci(i,k,1))-rvls)/(cp/xlv + & + ep2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) + rcldb=max((qx(i,k)+qxci(i,k,1))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2)+qxci(i,k+2,1))) & + - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k) +qxci(i,k ,1))) + dthvx(i) = max(dthvx(i),0.1) + tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) + ent_eff = 0.2 * 8. * tmp1 +0.2 + + radsum=0. + do kk = 1,kpbl(i)-1 + radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p2diORG(i,kk)-p2diORG(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !recompute entrainment from sfc thermals + bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) + bfx0 = max(sflux(i),0.0) + wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) + wm2(i) = wm3**h2 +! bfxpbl(i) = -ent_fac*thvx(i,1)/g*wm3/hpbl(i) +! bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + bfxpbl(i) = -ent_fac*thvx(i,1)*wm3/(g*hpbl(i)) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) + wm2(i) = wm2(i)+wm3**h2 + bfxpbl(i) = - ent_eff * bfx0 + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) + we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + + !wstar3_2 + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) + !recompute hgamt + wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + gamfac = bfac/rhox2(i,k)/wscale(i) + hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) + hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + endif + endif + prpbl(i) = 1.0 + dthx = max(thx(i,k+1)-thx(i,k),tmin) + dqx = min(qx(i,k+1)-qx(i,k),0.0) + hfxpbl(i) = we(i)*dthx + qfxpbl(i) = we(i)*dqx +! + dux = ux(i,k+1)-ux(i,k) + dvx = vx(i,k+1)-vx(i,k) + if(dux.gt.tmin) then + ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) + elseif(dux.lt.-tmin) then + ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) + else + ufxpbl(i) = 0.0 + endif + if(dvx.gt.tmin) then + vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) + elseif(dvx.lt.-tmin) then + vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) + else + vfxpbl(i) = 0.0 + endif + delb = govrth(i)*d3*hpbl(i) + delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) + endif + enddo +! + do k = kts,klpbl + do i = its,ite + if(pblflg(i).and.k.ge.kpbl(i))then + entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. + else + entfac(i,k) = 1.e30 + endif + enddo + enddo +! +! compute diffusion coefficients below pbl +! + do k = kts,klpbl + do i = its,ite + if(k.lt.kpbl(i)) then + zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) + zfacent(i,k) = (1.-zfac(i,k))**3. + wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 + if(sfcflg(i)) then + prfac = conpr + prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) + prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. + else + prfac = 0. + prfac2 = 0. + prnumfac = 0. + phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) + wscalek(i,k) = ust(i)/phim8z + wscalek(i,k) = max(wscalek(i,k),0.001) + endif + prnum0 = (phih(i)/phim(i)+prfac) + prnum0 = max(min(prnum0,prmax),prmin) + xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & !!! MUCH MORE COMPLICATED + wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac !!! THAN EDMF + !Do not include xkzm at kpbl-1 since it changes entrainment + if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then + xkzm(i,k) = 0.0 + endif + prnum = 1. + (prnum0-1.)*exp(prnumfac) + xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) + prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) + prnum = 1. + (prnum0-1.)*exp(prnumfac) !!! ALSO MORE COMPLICATED + xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + endif + enddo + enddo +! +! compute diffusion coefficients over pbl (free atmosphere) +! +! if (lprnt) then +! i = im/2 +! write(mpp_pe()+1000,*) kpbl(i), hpbl(i), pblflg(i), sfcflg(i) +! endif + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then +! ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & +! +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & +! /(dza(i,k+1)*dza(i,k+1))+1.e-9 + ss = ((ux(i,k+1)-ux(i,k))**2 + (vx(i,k+1)-vx(i,k))**2) / dza(i,k+1)**2 + ss = max(ss, 1.e-8) + govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) + ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) + if(imvdif.eq.1.and.ndiff.ge.3)then + if((qxci(i,k,1)+qxci(i,k,2)).gt.0.01e-3.and.(qxci(i & + ,k+1,1)+qxci(i,k+1,2)).gt.0.01e-3)then +! in cloud + qmean = 0.5*(qx(i,k)+qx(i,k+1)) + tmean = 0.5*(tx(i,k)+tx(i,k+1)) + alph = xlv*qmean/rd/tmean + chi = xlv*xlv*qmean/cp/rv/tmean/tmean +! ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) + ri = (1.+alph) * (ri - g*g/(ss*tmean*cp)*(chi-alph)/(1.+chi)) + endif + endif + zk = karman*zq(i,k+1) + rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) ! was constant 150 in EDMF + rlamdz = min(dza(i,k+1),rlamdz) + rl2 = (zk*rlamdz/(rlamdz+zk))**2 + dk = rl2*sqrt(ss) + if(ri.lt.0.)then +! unstable regime (same as in EDMF?) + ri = max(ri, rimin) + sri = sqrt(-ri) + xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) + xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) + else +! stable regime + xkzh(i,k) = dk/(1+5.*ri)**2 + prnum = 1.0+2.1*ri ! set to 1 above PBL in EDMF + prnum = min(prnum,prmax) + xkzm(i,k) = xkzh(i,k)*prnum + endif +! + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + xkzml(i,k) = xkzm(i,k) + xkzhl(i,k) = xkzh(i,k) + endif + enddo + enddo + +! +! add hpbl_cr control by kgao - only use non-local fluxes if hbpl is greater than hpbl_cr +! + +! do i = its,ite +! if(hpbl(i).lt.hpbl_cr) then +! pblflg(i) = .false. +! endif +! enddo + + +! +! compute tridiagonal matrix elements for heat +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 + !a1 = t1(i,1) + beta(i)*heat(i) + enddo +! + + flux_cg = 0. + flux_en = 0. + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) +! SJL dsig = p2d(i,k)-p2d(i,k+1) ! ?!? + dsig = p2m(i,k) - p2m(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*rdz + +! kgao - add hpbl_cr option + if(pblflg(i).and.k.lt.kpbl(i)) then + dsdzt = tnl_fac*tem1*(-hgamt(i)*xkzh(i,k)/hpbl(i)-hfxpbl(i)*zfacent(i,k)) + flux_cg(i,k) = -hgamt(i)*xkzh(i,k)/hpbl(i) + flux_en(i,k) = -hfxpbl(i)*zfacent(i,k) + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.lt.kpbl(i).and.hpbl(i).lt.hpbl_cr) then + dsdzt = tnl_fac*tem1*(-hgamt(i)*xkzh(i,k)/hpbl(i))!-hfxpbl(i)*zfacent(i,k)) + !flux_cg(i,k) = -hgamt(i)*xkzh(i,k)/hpbl(i) + !flux_en(i,k) = 0. + f1(i,k) = f1(i,k)+dtodsd*dsdzt + f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6.and.hpbl(i).ge.hpbl_cr) then + xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) + xkzh(i,k) = min(xkzh(i,k),xkzmax) + f1(i,k+1) = thx(i,k+1)-300. + else + f1(i,k+1) = thx(i,k+1)-300. + endif + tem1 = dsig*xkzh(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + enddo + enddo +! + call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) +! +! recover tendencies of heat +! + do k = kte,kts,-1 + do i = its,ite + ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + ttnp(i,k) = ttnp(i,k)+ttend + dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) + enddo + enddo + !!! DEBUG CODE + k=kts + do i=its,ite + if (tx(i,k) +ttnp(i,k) > 325.) then + write(*,'(A, 2I5, 2x, G0)') ' YSUPBL: Extreme temperature found T = ', i,k, tx(i,k)+ttnp(i,k) + write(*,'(A, 3G0)') ' ', thx(i,k), pi2d(i,k), (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + write(*,'(A, 2G0, I0, 2L)') ' ', hgamt(i), hpbl(i), kpbl(i), pblflg(i), sfcflg(i) + write(*,'(A, 3G0)') ' ', xkzh(i,1:3) + write(*,'(A, 3G0)') ' ', tx(i,1:3)+ttnp(i,1:3) + write(*,'(A, 2G0)') ' ', p2d(i,k)-p2d(i,k+1), p2m(i,k)-p2m(i,k+1) + write(*,'(A, 4G0)') ' ', hfxpbl(i), we(i), max(thx(i,k+1)-thx(i,k),tmin), hfxpbl(i)*zfacent(i,k) + write(*,'(A, 4G0)') ' ', wscale(i), wstar3(i)**h1, wstar3_2(i)**h1, hfx(i)/cp + endif + enddo + + do k=kts+1,kte-1 + do i=its,ite + if (tx(i,k) +ttnp(i,k) > 325.) then + write(*,'(A, 2I5, 2x, G0)') ' YSUPBL: Extreme temperature found T = ', i,k, tx(i,k)+ttnp(i,k) + write(*,'(A, 3G0)') ' ', thx(i,k), pi2d(i,k), (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) + write(*,'(A, 3G0, I0, 2L)') ' ', entfac(i,k), hgamt(i), hpbl(i), kpbl(i), pblflg(i), sfcflg(i) + write(*,'(A, 3G0)') ' ', xkzh(i,k-1:k+1) + write(*,'(A, 3G0)') ' ', tx(i,k-1:k+1)+ttnp(i,k-1:k+1) + write(*,'(A, 2G0)') ' ', p2d(i,k)-p2d(i,k+1), p2m(i,k)-p2m(i,k+1) + write(*,'(A, 4G0)') ' ', hfxpbl(i), we(i), max(thx(i,k+1)-thx(i,k),tmin), hfxpbl(i)*zfacent(i,k) + endif + enddo + enddo + !!! END DEBUG CODE + + if (present(dkt)) then + do k=kts,kte + do i=its,ite + dkt(i,k) = xkzh(i,k) + enddo + enddo + endif +! +! compute tridiagonal matrix elements for moisture, clouds, and gases +! + do k = kts,kte + do i = its,ite + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + enddo + enddo +! + do ic = 1,ndiff + do i = its,ite + do k = kts,kte + f3(i,k,ic) = 0. + enddo + enddo + enddo +! + do i = its,ite + ad(i,1) = 1. + f3(i,1,1) = qx(i,1)+qfx(i)*g/del(i,1)*dt2 + !a2(i,1) = q1(i,1,1) + beta(i) * evap(i) + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + is = (ic-1) * kte + do i = its,ite + f3(i,1,ic) = qx(i,1+is) + enddo + enddo + endif +! + do k = kts,kte-1 + do i = its,ite + if(k.ge.kpbl(i)) then + xkzq(i,k) = xkzh(i,k) + endif + enddo + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) +! SJL dsig = p2d(i,k)-p2d(i,k+1) + dsig = p2m(i,k) - p2m(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*rdz + if(pblflg(i).and.k.lt.kpbl(i).and.hpbl(i).ge.hpbl_cr) then + dsdzq = qnl_fac*tem1*(-qfxpbl(i)*zfacent(i,k)) ! no gama term ? + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.lt.kpbl(i)) then + dsdzq = 0. !qnl_fac*tem1*(-qfxpbl(i)*zfacent(i,k)) + f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq + f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then + xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) + xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) + xkzq(i,k) = min(xkzq(i,k),xkzmax) + f3(i,k+1,1) = qx(i,k+1) + else + f3(i,k+1,1) = qx(i,k+1) + endif + tem1 = dsig*xkzq(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) +! exch_hx(i,k+1) = xkzh(i,k) + enddo + enddo +! + if(ndiff.ge.2) then + do ic = 2,ndiff + is = (ic-1) * kte + do k = kts,kte-1 + do i = its,ite + f3(i,k+1,ic) = qx(i,k+1+is) + enddo + enddo + enddo + endif +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + enddo + enddo +! + do ic = 1,ndiff + do k = kts,kte + do i = its,ite + r3(i,k,ic) = f3(i,k,ic) + enddo + enddo + enddo +! +! solve tridiagonal problem for moisture, clouds, and gases +! + call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) +! +! recover tendencies of heat and moisture +! + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,1)-qx(i,k))*rdt + qtnp(i,k) = qtnp(i,k)+qtend + dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + enddo + enddo + + +! + if(ndiff.ge.2) then + do ic = 2,ndiff + is = (ic-1) * kte + do k = kte,kts,-1 + do i = its,ite + qtend = (f3(i,k,ic)-qx(i,k+is))*rdt + qtnp(i,k+is) = qtnp(i,k+is)+qtend + enddo + enddo + enddo + endif +! +! compute tridiagonal matrix elements for momentum +! + do i = its,ite + do k = kts,kte + au(i,k) = 0. + al(i,k) = 0. + ad(i,k) = 0. + f1(i,k) = 0. + f2(i,k) = 0. + enddo + enddo +! + do i = its,ite +! paj: ctopo=1 if topo_wind=0 (default) +! mchen add this line to make sure NMM can still work with YSU PBL +!<---hns +! if(present(ctopo)) then +! ad(i,1) = 1.+ctopo(i)*ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & +! *(wspd1(i)/wspd(i))**2 +! else + ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & + *(wspd1(i)/wspd(i))**2 +! endif +!--->hns + f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) + enddo +! + do k = kts,kte-1 + do i = its,ite + dtodsd = dt2/del(i,k) + dtodsu = dt2/del(i,k+1) +! SJL dsig = p2d(i,k)-p2d(i,k+1) + dsig = p2m(i,k) - p2m(i,k+1) + rdz = 1./dza(i,k+1) + tem1 = dsig*rdz + if(pblflg(i).and.k.lt.kpbl(i).and.hpbl(i).ge.hpbl_cr)then + dsdzu = unl_fac*tem1*(-hgamu(i)*xkzm(i,k)/hpbl(i)-ufxpbl(i)*zfacent(i,k)) + dsdzv = unl_fac*tem1*(-hgamv(i)*xkzm(i,k)/hpbl(i)-vfxpbl(i)*zfacent(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.lt.kpbl(i))then + dsdzu = unl_fac*tem1*(-hgamu(i)*xkzm(i,k)/hpbl(i))!-ufxpbl(i)*zfacent(i,k)) + dsdzv = unl_fac*tem1*(-hgamv(i)*xkzm(i,k)/hpbl(i))!-vfxpbl(i)*zfacent(i,k)) + f1(i,k) = f1(i,k)+dtodsd*dsdzu + f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu + f2(i,k) = f2(i,k)+dtodsd*dsdzv + f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv + elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6.and.hpbl(i).ge.hpbl_cr) then + xkzm(i,k) = prpbl(i)*xkzh(i,k) + xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) + xkzm(i,k) = min(xkzm(i,k),xkzmax) + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + else + f1(i,k+1) = ux(i,k+1) + f2(i,k+1) = vx(i,k+1) + endif + tem1 = dsig*xkzm(i,k)*rdz + dsdz2 = tem1*rdz + au(i,k) = -dtodsd*dsdz2 + al(i,k) = -dtodsu*dsdz2 + ad(i,k) = ad(i,k)-au(i,k) + ad(i,k+1) = 1.-al(i,k) + enddo + enddo +! +! copies here to avoid duplicate input args for tridin +! + do k = kts,kte + do i = its,ite + cu(i,k) = au(i,k) + r1(i,k) = f1(i,k) + r2(i,k) = f2(i,k) + enddo + enddo +! +! solve tridiagonal problem for momentum +! + call tridi1n(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) +! +! recover tendencies of momentum +! + do k = kte,kts,-1 + do i = its,ite + utend = (f1(i,k)-ux(i,k))*rdt + vtend = (f2(i,k)-vx(i,k))*rdt + utnp(i,k) = utnp(i,k)+utend + vtnp(i,k) = vtnp(i,k)+vtend + dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) + dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) + enddo + enddo +! +! paj: ctopo2=1 if topo_wind=0 (default) +! +!<---hns +! do i = its,ite +! if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM +! u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) +! v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) +! endif !mchen +! enddo +!--->hns +! +!---- end of vertical diffusion +! +! +! compute tke dissipation rate +! + if(dspheat) then +! + do k = kts,kte-1 + do i = its,ite + rdz = 1./dza(i,k+1) + dw2 = (ux(i,k)-ux(i,k+1))**2.+(vx(i,k)-vx(i,k+1))**2. + shr2 = max(dw2,dw2min)*rdz*rdz + ti = 2./(tx(i,k)+tx(i,k+1)) + bf = (thvx(i,k+1)-thvx(i,k))*rdz + diss(i,k) = xkzm(i,k)*shr2-g*ti*xkzh(i,k)*bf + enddo + enddo +! +! add dissipative heating at the first model layer +! + do i = its,ite + tem = govrth(i)*sflux(i) + tem1 = tem + ust(i)**2.*wspd1(i)/za(i,1) + tem2 = 0.5 * (tem1+diss(i,1)) + tem2 = max(tem2, 0.) + ttend = tem2 / cp + ttnp(i,1) = ttnp(i,1)+0.5*ttend + enddo +! +! add dissipative heating above the first model layer +! + do k = kts+1,kte-1 + do i = its,ite + tem = 0.5 * (diss(i,k-1)+diss(i,k)) + tem = max(tem, 0.) + ttend = tem / cp + ttnp(i,k) = ttnp(i,k) + 0.5*ttend + enddo + enddo +! + endif +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo +! +! + end subroutine ysupbl +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine, only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm, & + r1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu, & + f1 + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f1(i,1) = fk*r1(i,1) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l +! fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) +! f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + f2(i,k,it) = (r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) / (cm(i,k)-cl(i,k)*au(i,k-1)) + enddo + enddo + enddo +! + do i = its,l +! fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) +! f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) + f1(i,n) = (r1(i,n)-cl(i,n)*f1(i,n-1)) / (cm(i,n)-cl(i,n)*au(i,n-1)) + enddo +! + do it = 1,nt + do i = its,l + fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) + f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + enddo + enddo +! + do k = n-1,kts,-1 + do i = its,l + f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridi1n +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) +!------------------------------------------------------------------------------- + use machine, only : kind_phys +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: its,ite, kts,kte, nt +! + real(kind=kind_phys), dimension( its:ite, kts+1:kte+1 ) , & + intent(in ) :: cl +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(in ) :: cm + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(in ) :: r2 +! + real(kind=kind_phys), dimension( its:ite, kts:kte ) , & + intent(inout) :: au, & + cu + real(kind=kind_phys), dimension( its:ite, kts:kte,nt ) , & + intent(inout) :: f2 +! + real(kind=kind_phys) :: fk + integer :: i,k,l,n,it +! +!------------------------------------------------------------------------------- +! + l = ite + n = kte +! + do it = 1,nt + do i = its,l + fk = 1./cm(i,1) + au(i,1) = fk*cu(i,1) + f2(i,1,it) = fk*r2(i,1,it) + enddo + enddo +! + do it = 1,nt + do k = kts+1,n-1 + do i = its,l + fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) + au(i,k) = fk*cu(i,k) + f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) + enddo + enddo + enddo +! + do it = 1,nt + do i = its,l +! fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) +! f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) + f2(i,n,it) = (r2(i,n,it)-cl(i,n)*f2(i,n-1,it))/(cm(i,n)-cl(i,n)*au(i,n-1)) + enddo + enddo +! + do it = 1,nt + do k = n-1,kts,-1 + do i = its,l + f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) + enddo + enddo + enddo +! + end subroutine tridin_ysu +!------------------------------------------------------------------------------- diff --git a/simple_coupler/coupler_main.F90 b/simple_coupler/coupler_main.F90 new file mode 100644 index 00000000..60f88d67 --- /dev/null +++ b/simple_coupler/coupler_main.F90 @@ -0,0 +1,516 @@ +!*********************************************************************** +!* GNU Lesser General Public License +!* +!* This file is part of the GFDL Flexible Modeling System (FMS) Coupler. +!* +!* FMS Coupler is free software: you can redistribute it and/or modify +!* it under the terms of the GNU Lesser General Public License as +!* published by the Free Software Foundation, either version 3 of the +!* License, or (at your option) any later version. +!* +!* FMS Coupler is distributed in the hope that it will be useful, but +!* WITHOUT ANY WARRANTY; without even the implied warranty of +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +!* General Public License for more details. +!* +!* You should have received a copy of the GNU Lesser General Public +!* License along with FMS Coupler. +!* If not, see . +!*********************************************************************** +program coupler_main + +!----------------------------------------------------------------------- +! +! program that couples component models for the atmosphere, +! ocean (amip), land, and sea-ice using the exchange module +! +!----------------------------------------------------------------------- + +use time_manager_mod, only: time_type, set_calendar_type, set_time, & + set_date, days_in_month, month_name, & + operator(+), operator (<), operator (>), & + operator (/=), operator (/), operator (==),& + operator (*), THIRTY_DAY_MONTHS, JULIAN, & + NOLEAP, NO_CALENDAR, date_to_string, & + get_date + +use atmos_model_mod, only: atmos_model_init, atmos_model_end, & + update_atmos_model_dynamics, & + update_atmos_radiation_physics, & + update_atmos_model_state, & + atmos_data_type, atmos_model_restart + +use constants_mod, only: constants_init +use mpp_mod, only: input_nml_file +use fms_affinity_mod, only: fms_affinity_init, fms_affinity_set + +use fms_mod, only: check_nml_error, & + error_mesg, fms_init, fms_end, & + write_version_number, uppercase +use fms2_io_mod, only: ascii_read, file_exists +use mpp_mod, only: mpp_init, mpp_pe, mpp_root_pe, mpp_npes, mpp_get_current_pelist, & + mpp_set_current_pelist, stdlog, mpp_error, NOTE, FATAL, WARNING +use mpp_mod, only: mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sync + +use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_field, CORNER +use memutils_mod, only: print_memuse_stats +use sat_vapor_pres_mod,only: sat_vapor_pres_init + +use diag_manager_mod, only: diag_manager_init, diag_manager_end, & + get_base_date, diag_manager_set_time_end + +use data_override_mod, only: data_override_init + + +implicit none + +!----------------------------------------------------------------------- + +character(len=128) :: version = '$Id: coupler_main.F90,v 19.0.4.1.2.3 2014/09/09 23:51:59 Rusty.Benson Exp $' +character(len=128) :: tag = '$Name: ulm_201505 $' + +!----------------------------------------------------------------------- +!---- model defined-types ---- + + type (atmos_data_type) :: Atm + +!----------------------------------------------------------------------- +! ----- coupled model time ----- + + type (time_type) :: Time_atmos, Time_init, Time_end, & + Time_step_atmos, Time_step_ocean, & + Time_restart, Time_step_restart, & + Time_start_restart, Time_restart_aux, & + Time_step_restart_aux, Time_start_restart_aux, & + Time_duration_restart_aux, Time_restart_end_aux + + integer :: num_cpld_calls, num_atmos_calls, nc, na, ret + +! ----- coupled model initial date ----- + + integer :: date_init(6) + integer :: calendar_type = -99 + +! ----- timing flags ----- + + integer :: initClock, mainClock, termClock + integer, parameter :: timing_level = 1 + +! ----- namelist ----- + integer, dimension(6) :: current_date = (/ 0, 0, 0, 0, 0, 0 /) + character(len=17) :: calendar = ' ' + logical :: force_date_from_namelist = .false. ! override restart values for date + integer :: months=0, days=0, hours=0, minutes=0, seconds=0 + integer :: iau_offset = 0 + integer :: dt_atmos = 0 + integer :: dt_ocean = 0 + integer :: restart_days = 0 + integer :: restart_secs = 0 + integer :: restart_start_days = 0 + integer :: restart_start_secs = 0 + integer :: restart_days_aux = 0 + integer :: restart_secs_aux = 0 + integer :: restart_start_days_aux = 0 + integer :: restart_start_secs_aux = 0 + integer :: restart_duration_days_aux = 0 + integer :: restart_duration_secs_aux = 0 + integer :: atmos_nthreads = 1 + logical :: memuse_verbose = .false. + logical :: use_hyper_thread = .false. + + namelist /coupler_nml/ current_date, calendar, force_date_from_namelist, & + months, days, hours, minutes, seconds, iau_offset, & + dt_atmos, dt_ocean, atmos_nthreads, memuse_verbose, & + use_hyper_thread, restart_secs, restart_days, & + restart_start_secs, restart_start_days, & + restart_secs_aux, restart_days_aux, & + restart_start_secs_aux, restart_start_days_aux, & + restart_duration_secs_aux, restart_duration_days_aux + +! ----- local variables ----- + character(len=32) :: timestamp + logical :: intrm_rst, intrm_rst_1step + +!####################################################################### + + call fms_init() + call mpp_init() + initClock = mpp_clock_id( 'Initialization' ) + call mpp_clock_begin (initClock) !nesting problem + + call fms_init + call constants_init + call fms_affinity_init + call sat_vapor_pres_init + + call coupler_init + call print_memuse_stats('after coupler init') + + call mpp_set_current_pelist() + call mpp_clock_end (initClock) !end initialization + mainClock = mpp_clock_id( 'Main loop' ) + termClock = mpp_clock_id( 'Termination' ) + call mpp_clock_begin(mainClock) !begin main loop + + do nc = 1, num_cpld_calls + + Time_atmos = Time_atmos + Time_step_atmos + + call update_atmos_model_dynamics (Atm) + + call update_atmos_radiation_physics (Atm) + + call update_atmos_model_state (Atm) + +!--- intermediate restart + if (intrm_rst) then + if (nc /= num_cpld_calls) then + if (intrm_rst_1step .and. nc == 1) then + timestamp = date_to_string (Time_atmos) + call atmos_model_restart(Atm, timestamp) + call coupler_res(timestamp) + endif + if (Time_atmos == Time_restart .or. Time_atmos == Time_restart_aux) then + if (Time_atmos == Time_restart) then + timestamp = date_to_string (Time_restart) + else + timestamp = date_to_string (Time_restart_aux) + endif + call atmos_model_restart(Atm, timestamp) + call coupler_res(timestamp) + if (Time_atmos == Time_restart) & + Time_restart = Time_restart + Time_step_restart + if ((restart_secs_aux > 0 .or. restart_days_aux > 0) .and. & + Time_atmos == Time_restart_aux .and. & + Time_restart_aux < Time_restart_end_aux) then + Time_restart_aux = Time_restart_aux + Time_step_restart_aux + endif + endif + endif + endif + + call print_memuse_stats('after full step') + + enddo + +!----------------------------------------------------------------------- + + call mpp_set_current_pelist() + call mpp_clock_end(mainClock) + call mpp_clock_begin(termClock) + + call coupler_end + call mpp_set_current_pelist() + call mpp_clock_end(termClock) + + call fms_end + +!----------------------------------------------------------------------- + + stop + +contains + +!####################################################################### + + subroutine coupler_init + +!----------------------------------------------------------------------- +! initialize all defined exchange grids and all boundary maps +!----------------------------------------------------------------------- + integer :: total_days, total_seconds, ierr, io + integer :: n, gnlon, gnlat + integer :: date(6), flags + type (time_type) :: Run_length + character(len=9) :: month + logical :: use_namelist + + logical, allocatable, dimension(:,:) :: mask + real, allocatable, dimension(:,:) :: glon_bnd, glat_bnd + character(len=:), dimension(:), allocatable :: restart_file !< Restart file saved as a string + integer :: time_stamp_unit !< Unit of the time_stamp file + integer :: ascii_unit !< Unit of a dummy ascii file + +!----------------------------------------------------------------------- +!----- initialization timing identifiers ---- + +!----- read namelist ------- +!----- for backwards compatibilty read from file coupler.nml ----- + + read(input_nml_file, nml=coupler_nml, iostat=io) + ierr = check_nml_error(io, 'coupler_nml') + +!----- write namelist to logfile ----- + call write_version_number (version, tag) + if (mpp_pe() == mpp_root_pe()) write(stdlog(),nml=coupler_nml) + +!----- allocate and set the pelist (to the global pelist) ----- + allocate( Atm%pelist (mpp_npes()) ) + call mpp_get_current_pelist(Atm%pelist) + +!----- read restart file ----- + + if (file_exists('INPUT/coupler.res')) then + call ascii_read('INPUT/coupler.res', restart_file) + read(restart_file(1), *) calendar_type + read(restart_file(2), *) date_init + read(restart_file(3), *) date + deallocate(restart_file) + else + force_date_from_namelist = .true. + endif + +!----- use namelist value (either no restart or override flag on) --- + + if ( force_date_from_namelist ) then + + if ( sum(current_date) <= 0 ) then + call error_mesg ('program coupler', & + 'no namelist value for current_date', FATAL) + else + date = current_date + endif + +!----- override calendar type with namelist value ----- + + select case( uppercase(trim(calendar)) ) + case( 'JULIAN' ) + calendar_type = JULIAN + case( 'NOLEAP' ) + calendar_type = NOLEAP + case( 'THIRTY_DAY' ) + calendar_type = THIRTY_DAY_MONTHS + case( 'NO_CALENDAR' ) + calendar_type = NO_CALENDAR + case default + call mpp_error ( FATAL, 'COUPLER_MAIN: coupler_nml entry calendar must '// & + 'be one of JULIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) + end select + + endif + + !--- setting affinity +!$ call fms_affinity_set('ATMOS', use_hyper_thread, atmos_nthreads) +!$ call omp_set_num_threads(atmos_nthreads) + + call set_calendar_type (calendar_type) + +!----- write current/initial date actually used to logfile file ----- + + if ( mpp_pe() == mpp_root_pe() ) then + write (stdlog(),16) date(1),trim(month_name(date(2))),date(3:6) + endif + + 16 format (' current date used = ',i4,1x,a,2i3,2(':',i2.2),' gmt') + +!----------------------------------------------------------------------- +!------ initialize diagnostics manager ------ + + call diag_manager_init (TIME_INIT=date) + +!----- always override initial/base date with diag_manager value ----- + + call get_base_date ( date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6) ) + +!----- use current date if no base date ------ + + if ( date_init(1) == 0 ) date_init = date + +!----- set initial and current time types ------ + + Time_init = set_date (date_init(1), date_init(2), date_init(3), & + date_init(4), date_init(5), date_init(6)) + + Time_atmos = set_date (date(1), date(2), date(3), & + date(4), date(5), date(6)) + +!----------------------------------------------------------------------- +!----- compute the ending time (compute days in each month first) ----- +! +! (NOTE: if run length in months then starting day must be <= 28) + + if ( months > 0 .and. date(3) > 28 ) & + call error_mesg ('program coupler', & + 'if run length in months then starting day must be <= 28', FATAL) + + Time_end = Time_atmos + total_days = 0 + do n = 1, months + total_days = total_days + days_in_month(Time_end) + Time_end = Time_atmos + set_time (0,total_days) + enddo + + total_days = total_days + days + total_seconds = hours*3600 + minutes*60 + seconds + Run_length = set_time (total_seconds,total_days) + Time_end = Time_atmos + Run_length + + !Need to pass Time_end into diag_manager for multiple thread case. + call diag_manager_set_time_end(Time_end) + + +!----------------------------------------------------------------------- +!----- write time stamps (for start time and end time) ------ + + if ( mpp_pe().EQ.mpp_root_pe() ) open(newunit = time_stamp_unit, file='time_stamp.out', status='replace', form='formatted') + + month = month_name(date(2)) + if ( mpp_pe() == mpp_root_pe() ) write (time_stamp_unit,20) date, month(1:3) + + call get_date (Time_end, date(1), date(2), date(3), & + date(4), date(5), date(6)) + month = month_name(date(2)) + if ( mpp_pe() == mpp_root_pe() ) write (time_stamp_unit,20) date, month(1:3) + + if ( mpp_pe().EQ.mpp_root_pe() ) close(time_stamp_unit) + + 20 format (6i4,2x,a3) + +!----------------------------------------------------------------------- +!----- compute the time steps ------ + +Time_step_atmos = set_time (dt_atmos,0) +Time_step_ocean = set_time (dt_ocean,0) +num_cpld_calls = Run_length / Time_step_ocean +num_atmos_calls = Time_step_ocean / Time_step_atmos +Time_step_restart = set_time (restart_secs, restart_days) +if (restart_start_secs > 0 .or. restart_start_days > 0) then + Time_start_restart = set_time (restart_start_secs, restart_start_days) + Time_restart = Time_atmos + Time_start_restart +else + Time_restart = Time_atmos + Time_step_restart +end if +Time_step_restart_aux = set_time (restart_secs_aux, restart_days_aux) +Time_duration_restart_aux = set_time (restart_duration_secs_aux, restart_duration_days_aux) +Time_start_restart_aux = set_time (restart_start_secs_aux, restart_start_days_aux) +Time_restart_aux = Time_atmos + Time_start_restart_aux +Time_restart_end_aux = Time_restart_aux + Time_duration_restart_aux +intrm_rst = .false. +intrm_rst_1step = .false. +if (restart_days > 0 .or. restart_secs > 0) intrm_rst = .true. +if (intrm_rst .and. restart_start_secs == 0 .and. & + restart_start_days == 0) intrm_rst_1step = .true. + +!----------------------------------------------------------------------- +!------------------- some error checks --------------------------------- + +!----- initial time cannot be greater than current time ------- + + if ( Time_init > Time_atmos ) call error_mesg ('program coupler', & + 'initial time is greater than current time', FATAL) + +!----- make sure run length is a multiple of ocean time step ------ + + if ( num_cpld_calls * Time_step_ocean /= Run_length ) & + call error_mesg ('program coupler', & + 'run length must be multiple of ocean time step', FATAL) + +! ---- make sure cpld time step is a multiple of atmos time step ---- + + if ( num_atmos_calls * Time_step_atmos /= Time_step_ocean ) & + call error_mesg ('program coupler', & + 'atmos time step is not a multiple of the ocean time step', FATAL) + +!------ initialize component models ------ + + call atmos_model_init (Atm, Time_init, Time_atmos, Time_step_atmos, & + iau_offset) + + call print_memuse_stats('after atmos model init') + + call mpp_get_global_domain(Atm%Domain, xsize=gnlon, ysize=gnlat) + allocate ( glon_bnd(gnlon+1,gnlat+1), glat_bnd(gnlon+1,gnlat+1) ) + call mpp_global_field(Atm%Domain, Atm%lon_bnd, glon_bnd, position=CORNER) + call mpp_global_field(Atm%Domain, Atm%lat_bnd, glat_bnd, position=CORNER) + + if (.NOT.Atm%bounded_domain) call data_override_init (Atm_domain_in = Atm%domain) + ! Atm_domain_in = Atm%domain, & + ! Ice_domain_in = Ice%domain, & + ! Land_domain_in = Land%domain ) + +!----------------------------------------------------------------------- +!---- open and close dummy file in restart dir to check if dir exists -- + + if (mpp_pe() == 0 ) then !one pe should do this check only in case of a nest + open(newunit = ascii_unit, file='RESTART/file', status='replace', form='formatted') + close(ascii_unit,status="delete") + endif + +!----------------------------------------------------------------------- + + end subroutine coupler_init + +!####################################################################### + subroutine coupler_res(timestamp) + character(len=32), intent(in) :: timestamp + + integer :: date(6) + integer :: restart_unit !< Unit for the coupler restart file + +!----- compute current date ------ + + call get_date (Time_atmos, date(1), date(2), date(3), & + date(4), date(5), date(6)) + +!----- write restart file ------ + call mpp_set_current_pelist() + if (mpp_pe() == mpp_root_pe())then + open(newunit = restart_unit, file='RESTART/'//trim(timestamp)//'.coupler.res', status='replace', form='formatted') + write(restart_unit, '(i6,8x,a)' )calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + write(restart_unit, '(6i6,8x,a)' )date_init, & + 'Model start time: year, month, day, hour, minute, second' + write(restart_unit, '(6i6,8x,a)' )date, & + 'Current model time: year, month, day, hour, minute, second' + close(restart_unit) + endif + end subroutine coupler_res + +!####################################################################### + + subroutine coupler_end + + integer :: date(6) + integer :: restart_unit !< Unit for the coupler restart file +!----------------------------------------------------------------------- + + call atmos_model_end (Atm) + +!----- compute current date ------ + + call get_date (Time_atmos, date(1), date(2), date(3), & + date(4), date(5), date(6)) + +!----- check time versus expected ending time ---- + + if (Time_atmos /= Time_end) call error_mesg ('program coupler', & + 'final time does not match expected ending time', WARNING) + +!----- write restart file ------ + call mpp_set_current_pelist() + if (mpp_pe() == mpp_root_pe())then + open(newunit = restart_unit, file='RESTART/coupler.res', status='replace', form='formatted') + write(restart_unit, '(i6,8x,a)' )calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + write(restart_unit, '(6i6,8x,a)' )date_init, & + 'Model start time: year, month, day, hour, minute, second' + write(restart_unit, '(6i6,8x,a)' )date, & + 'Current model time: year, month, day, hour, minute, second' + close(restart_unit) + endif + +!----- final output of diagnostic fields ---- + + call diag_manager_end (Time_atmos) + +!----------------------------------------------------------------------- + + end subroutine coupler_end + +!####################################################################### + +end program coupler_main +